From 851925875dc7cd08768b932dae12a3c698d0d4b3 Mon Sep 17 00:00:00 2001 From: Larry Masinter Date: Sat, 29 Aug 2020 18:36:46 -0700 Subject: [PATCH] initial checkin for sources --- sources/10MBDECLS | 1 + sources/10MBDRIVER | 1 + sources/AARITH | 1 + sources/ABASIC | 1 + sources/ACODE | 1 + sources/ADDARITH | 1 + sources/ADIR | 1 + sources/ADISPLAY | 1281 ++++++++++++ sources/ADVISE | 1 + sources/AERROR | 1 + sources/AFONT | 1 + sources/AINTERRUPT | 1 + sources/AOFD | 1 + sources/APRINT | 1 + sources/APUTDQ | 1 + sources/ARGLIST | 1 + sources/ASKUSER | 1 + sources/ASTACK | 1 + sources/ATBL | 1 + sources/ATERM | 1 + sources/ATTACHEDWINDOW | 1 + sources/AUTHENTICATION | 1 + sources/BOOTSTRAP | 1 + sources/BREAK-AND-TRACE | 1 + sources/BRKDWN | 1 + sources/BSP | 1 + sources/BYTECOMPILER | 1 + sources/CL-ERROR | 1 + sources/CLEARINGHOUSE | 1 + sources/CLISP | 1 + sources/CLISPIFY | 1 + sources/CLOSURE-CACHE | 1 + sources/CLSTREAMS | 1 + sources/CMLARITH | 1 + sources/CMLARRAY | 1 + sources/CMLARRAY-SUPPORT | 726 +++++++ sources/CMLARRAYINSPECTOR | 268 +++ sources/CMLCHARACTER | 285 +++ sources/CMLCOMPILE | 1 + sources/CMLDEFFER | 1 + sources/CMLDESTRUCT | 1 + sources/CMLDOC | 1 + sources/CMLENVIRONMENT | 177 ++ sources/CMLEVAL | 1265 ++++++++++++ sources/CMLEXEC | 1 + sources/CMLFILESYS | 1 + sources/CMLFLOAT | 1 + sources/CMLFLOATARRAY | 1 + sources/CMLFORMAT | 1 + sources/CMLHASH | 1 + sources/CMLLIST | 1 + sources/CMLLOAD | 1 + sources/CMLMACROS | 1 + sources/CMLMISCIO | 1 + sources/CMLMODULES | 1 + sources/CMLMVS | 1 + sources/CMLPACKAGE | 1 + sources/CMLPARSE | 1 + sources/CMLPATHNAME | 1 + sources/CMLPRED | 1 + sources/CMLPRINT | 1 + sources/CMLPROGV | 1 + sources/CMLRAND | 1 + sources/CMLREAD | 1 + sources/CMLREADTABLE | 1 + sources/CMLSEQ | 1 + sources/CMLSEQBASICS | 1 + sources/CMLSEQCOMMON | 1 + sources/CMLSEQFINDER | 1 + sources/CMLSEQMAPPERS | 1 + sources/CMLSEQMODIFY | 1 + sources/CMLSETF | 1 + sources/CMLSMARTARGS | 37 + sources/CMLSORT | 1 + sources/CMLSPECIALFORMS | 1 + sources/CMLSTEP | 1 + sources/CMLSTRING | 1 + sources/CMLSYMBOL | 1 + sources/CMLTIME | 1 + sources/CMLTYPES | 1 + sources/CMLUNDO | 1 + sources/CMLWALK | 1 + sources/COMMENT | 1 + sources/COMMON | 1 + sources/COMPARE | 1 + sources/COMPATIBILITY | 1 + sources/COMPILE | 1 + sources/COMPILER-PACKAGE | 1 + sources/CONDITION-HIERARCHY | 1 + sources/CONDITION-HIERARCHY-IL | 1 + sources/CONDITION-HIERARCHY-POST-SI | 1 + sources/CONDITION-HIERARCHY-SI | 1 + sources/CONDITION-PACKAGE | 1 + sources/COREIO | 1 + sources/COROUTINE | 1 + sources/COURIER | 751 +++++++ sources/D-ASSEM | 1 + sources/D-ASSEM-PACKAGE | 1 + sources/DEBUGEDIT | 1 + sources/DEBUGGER | 1 + sources/DEFFER-RUNTIME | 1 + sources/DEFPACKAGE-IMPORT | 1 + sources/DEFSTRUCT | 1 + sources/DEFSTRUCT-RUN-TIME | 1 + sources/DESCRIBE | 1 + sources/DEXEC | 1 + sources/DFILE | 1 + sources/DIRECTORY | 1 + sources/DISKDLION | 1 + sources/DISKVMEMDECLS | 1 + sources/DLAP | 1 + sources/DLFIXINIT | 166 ++ sources/DMISC | 1 + sources/DOVEDECLS | 397 ++++ sources/DOVEDISK | 729 +++++++ sources/DOVEDISPLAY | 307 +++ sources/DOVEETHER | 381 ++++ sources/DOVEETHERDECLS | 293 +++ sources/DOVEFLOPPY | 1139 ++++++++++ sources/DOVEINPUTOUTPUT | 136 ++ sources/DOVEMISC | 287 +++ sources/DPUPFTP | 1 + sources/DSK | 1 + sources/DSKDISPLAY | 1 + sources/DSPRINTDEF | 1 + sources/DTDECLARE | 1 + sources/DWIM | 1 + sources/DWIMIFY | 1 + sources/EDIT | 1 + sources/EDITINTERFACE | 1 + sources/ERROR-RUNTIME | 1 + sources/ERROR-RUNTIME-AFTER-FASL | 1 + sources/EXEC-COMMANDS | 1 + sources/FASDUMP | 1 + sources/FASL-PACKAGE | 1 + sources/FASL-SUPPORT | 1 + sources/FASLOAD | 1 + sources/FILEIO | 1 + sources/FILEPKG | 1 + sources/FILESETS | 175 ++ sources/FILESETS.NOETHER | 1 + sources/FILESETS.ORIG | 1 + sources/FILESETS.PUP | 1 + sources/FLOPPY | 1 + sources/FONT | 1 + sources/FREEMENU | 1459 +++++++++++++ sources/FREEMENU.TEDIT | Bin 0 -> 56331 bytes sources/GAINSPACE | 1 + sources/HARDCOPY | 1 + sources/HIST | 1 + sources/HLDISPLAY | 1193 +++++++++++ sources/HPRINT | 352 ++++ sources/ICONW | 1 + sources/ICONW.TEDIT | Bin 0 -> 10934 bytes sources/IDLER | 1 + sources/IL-ERROR-STUFF | 1 + sources/IMAGEIO | 296 +++ sources/IMPLICIT-KEY-HASH | 1 + sources/INSPECT | 35 + sources/INSPECT-CLOSURE | 1 + sources/INTERPRESS | 1 + sources/IOCHAR | 1 + sources/LEAF | 1 + sources/LISP-PACKAGE | 1 + sources/LISPBCPLFILES.DM | Bin 0 -> 192713 bytes sources/LLARITH | 1 + sources/LLARRAYELT | 2968 +++++++++++++++++++++++++++ sources/LLBASIC | 2219 ++++++++++++++++++++ sources/LLBFS | 1 + sources/LLBIGNUM | 235 +++ sources/LLCHAR | 217 ++ sources/LLCODE | 1 + sources/LLCOLOR | 1 + sources/LLDATATYPE | 1175 +++++++++++ sources/LLDISPLAY | 1838 +++++++++++++++++ sources/LLERROR | 1 + sources/LLETHER | 1 + sources/LLFAULT | 1 + sources/LLFLOAT | 1 + sources/LLGC | 296 +++ sources/LLINTERP | 580 ++++++ sources/LLKEY | 35 + sources/LLMVS | 280 +++ sources/LLNEW | 847 ++++++++ sources/LLNS | 1 + sources/LLNSDECLS | 1 + sources/LLPACKAGE | 1 + sources/LLPARAMS | 1705 +++++++++++++++ sources/LLREAD | 1666 +++++++++++++++ sources/LLRESTART | 1 + sources/LLSTK | 1 + sources/LLSUBRS | 1 + sources/LLSYMBOL | 1 + sources/LLTIMER | 1 + sources/LOADFNS | 1 + sources/LOADFULL.CM | 1 + sources/LOADFULL.LISP | 1 + sources/LOADFULLFROMDLINIT.CM | 1 + sources/LOADFULLFROMDLINITSLOW.CM | 1 + sources/LOADFULLFROMLISP.CM | 1 + sources/LOADFULLSLOW.CM | 1 + sources/LOADINIT.CM | 1 + sources/LOADINITSLOW.CM | 1 + sources/LOADUP.LISP | 1 + sources/LOCALFILE | 1 + sources/LOGOW | 126 ++ sources/LispDMC.DM | Bin 0 -> 354892 bytes sources/MACHINEINDEPENDENT | 1 + sources/MACROAUX | 1 + sources/MACROAUX-OPTIMIZERS | 1 + sources/MACROS | 1 + sources/MAIKOBITBLT | 64 + sources/MAIKOCOLOR | 972 +++++++++ sources/MAIKOETHER | 1 + sources/MAIKOLOADUPFNS | 429 ++++ sources/MAKEINIT | 286 +++ sources/MAPATOMS | 1 + sources/MEM | 1 + sources/MENU | 275 +++ sources/MISC | 1 + sources/MOD44IO | 1 + sources/MODARITH | 1 + sources/NEW-EDIT-INTERFACE | 1 + sources/NEWPRINTDEF | 1 + sources/NSFILING | 1 + sources/NSPRINT | 1 + sources/P4A.scn | 245 +++ sources/PACKAGE-CONVERSION-TABLE | 1 + sources/PACKAGE-STARTUP | 1 + sources/PAINTW | 1 + sources/PASSWORDS | 1 + sources/PMAP | 1 + sources/POSTLOADUP | 1 + sources/PRETTY | 1 + sources/PRINTFN | 1 + sources/PROC | 2220 ++++++++++++++++++++ sources/PROFILE | 1 + sources/PUP | 1 + sources/READ-PRINT-PROFILE | 1 + sources/RECORD | 1 + sources/RENAMEFNS | 105 + sources/RENAMEMACROS | 222 ++ sources/RESOURCE | 1 + sources/SEDIT | 1 + sources/SEDIT-ACCESS | 1 + sources/SEDIT-ATOMIC | 1 + sources/SEDIT-BASE | 1 + sources/SEDIT-COMMANDS | 1 + sources/SEDIT-COMMANDS.DATABASE | 1 + sources/SEDIT-COMMENTS | 1 + sources/SEDIT-CONVERT | 1 + sources/SEDIT-DEBUG | 1 + sources/SEDIT-DECLS | 1 + sources/SEDIT-EXPORTS | 1 + sources/SEDIT-INDENT | 1 + sources/SEDIT-LINEAR | 1 + sources/SEDIT-LIST-FORMATS | 1 + sources/SEDIT-LISTS | 1 + sources/SEDIT-TERMINAL | 1 + sources/SEDIT-TEST.TEDIT | Bin 0 -> 2491 bytes sources/SEDIT-TOPLEVEL | 1 + sources/SEDIT-WINDOW | 1 + sources/SEDIT.TEDIT | Bin 0 -> 77258 bytes sources/SETF-RUNTIME | 1 + sources/SPELL | 1 + sources/SPELLFILE | 1 + sources/SPP | 1 + sources/SPPDECLS | 1 + sources/STACKFNS | 1 + sources/SUNFONT | 32 + sources/SYSPRETTY | 1 + sources/TIME | 1 + sources/TRSERVER | 1 + sources/TTYIN | 1 + sources/TWODINSPECTOR | 207 ++ sources/TWODINSPECTOR.TEDIT | 7 + sources/UFS | 771 +++++++ sources/UFSCALLC | 1 + sources/UNDO | 1 + sources/UNIXPRINT | 1 + sources/UNIXPRINT.TEDIT | Bin 0 -> 6583 bytes sources/UNWINDMACROS | 1 + sources/VANILLADISK | 1 + sources/WALKER | 1 + sources/WEDIT | 1 + sources/WINDOW | 1887 +++++++++++++++++ sources/WINDOWICON | 86 + sources/WINDOWOBJ | 1 + sources/WINDOWSCROLL | 913 ++++++++ sources/WRAPPERS | 502 +++++ sources/WTFIX | 1 + sources/XCL-COMPILER | 1 + sources/XCL-EXTRAS | 1 + sources/XCL-PACKAGE | 1 + sources/XCLC-ALPHA | 1 + sources/XCLC-ANALYZE | 1 + sources/XCLC-ANNOTATE | 1 + sources/XCLC-DATABASE | 1 + sources/XCLC-ENV-CTXT | 1 + sources/XCLC-GENCODE | 1 + sources/XCLC-META-EVAL | 1 + sources/XCLC-OPTIMIZERS | 1 + sources/XCLC-PEEPHOLE | 1 + sources/XCLC-RUNTIME | 1 + sources/XCLC-TOP-LEVEL | 1557 ++++++++++++++ sources/XCLC-TRANSFORMS | 1 + sources/XCLC-TREES | 1 + sources/XMAS | 1 + sources/XMAS2 | 1 + sources/XXFILL | 1 + sources/XXGEOM | 1 + sources/new-edit-interface.tedit | Bin 0 -> 4542 bytes sources/read-print-profile.tedit | Bin 0 -> 3785 bytes sources/subrs.h | 91 + 314 files changed, 37442 insertions(+) create mode 100644 sources/10MBDECLS create mode 100644 sources/10MBDRIVER create mode 100644 sources/AARITH create mode 100644 sources/ABASIC create mode 100644 sources/ACODE create mode 100644 sources/ADDARITH create mode 100644 sources/ADIR create mode 100644 sources/ADISPLAY create mode 100644 sources/ADVISE create mode 100644 sources/AERROR create mode 100644 sources/AFONT create mode 100644 sources/AINTERRUPT create mode 100644 sources/AOFD create mode 100644 sources/APRINT create mode 100644 sources/APUTDQ create mode 100644 sources/ARGLIST create mode 100644 sources/ASKUSER create mode 100644 sources/ASTACK create mode 100644 sources/ATBL create mode 100644 sources/ATERM create mode 100644 sources/ATTACHEDWINDOW create mode 100644 sources/AUTHENTICATION create mode 100644 sources/BOOTSTRAP create mode 100644 sources/BREAK-AND-TRACE create mode 100644 sources/BRKDWN create mode 100644 sources/BSP create mode 100644 sources/BYTECOMPILER create mode 100644 sources/CL-ERROR create mode 100644 sources/CLEARINGHOUSE create mode 100644 sources/CLISP create mode 100644 sources/CLISPIFY create mode 100644 sources/CLOSURE-CACHE create mode 100644 sources/CLSTREAMS create mode 100644 sources/CMLARITH create mode 100644 sources/CMLARRAY create mode 100644 sources/CMLARRAY-SUPPORT create mode 100644 sources/CMLARRAYINSPECTOR create mode 100644 sources/CMLCHARACTER create mode 100644 sources/CMLCOMPILE create mode 100644 sources/CMLDEFFER create mode 100644 sources/CMLDESTRUCT create mode 100644 sources/CMLDOC create mode 100644 sources/CMLENVIRONMENT create mode 100644 sources/CMLEVAL create mode 100644 sources/CMLEXEC create mode 100644 sources/CMLFILESYS create mode 100644 sources/CMLFLOAT create mode 100644 sources/CMLFLOATARRAY create mode 100644 sources/CMLFORMAT create mode 100644 sources/CMLHASH create mode 100644 sources/CMLLIST create mode 100644 sources/CMLLOAD create mode 100644 sources/CMLMACROS create mode 100644 sources/CMLMISCIO create mode 100644 sources/CMLMODULES create mode 100644 sources/CMLMVS create mode 100644 sources/CMLPACKAGE create mode 100644 sources/CMLPARSE create mode 100644 sources/CMLPATHNAME create mode 100644 sources/CMLPRED create mode 100644 sources/CMLPRINT create mode 100644 sources/CMLPROGV create mode 100644 sources/CMLRAND create mode 100644 sources/CMLREAD create mode 100644 sources/CMLREADTABLE create mode 100644 sources/CMLSEQ create mode 100644 sources/CMLSEQBASICS create mode 100644 sources/CMLSEQCOMMON create mode 100644 sources/CMLSEQFINDER create mode 100644 sources/CMLSEQMAPPERS create mode 100644 sources/CMLSEQMODIFY create mode 100644 sources/CMLSETF create mode 100644 sources/CMLSMARTARGS create mode 100644 sources/CMLSORT create mode 100644 sources/CMLSPECIALFORMS create mode 100644 sources/CMLSTEP create mode 100644 sources/CMLSTRING create mode 100644 sources/CMLSYMBOL create mode 100644 sources/CMLTIME create mode 100644 sources/CMLTYPES create mode 100644 sources/CMLUNDO create mode 100644 sources/CMLWALK create mode 100644 sources/COMMENT create mode 100644 sources/COMMON create mode 100644 sources/COMPARE create mode 100644 sources/COMPATIBILITY create mode 100644 sources/COMPILE create mode 100644 sources/COMPILER-PACKAGE create mode 100644 sources/CONDITION-HIERARCHY create mode 100644 sources/CONDITION-HIERARCHY-IL create mode 100644 sources/CONDITION-HIERARCHY-POST-SI create mode 100644 sources/CONDITION-HIERARCHY-SI create mode 100644 sources/CONDITION-PACKAGE create mode 100644 sources/COREIO create mode 100644 sources/COROUTINE create mode 100644 sources/COURIER create mode 100644 sources/D-ASSEM create mode 100644 sources/D-ASSEM-PACKAGE create mode 100644 sources/DEBUGEDIT create mode 100644 sources/DEBUGGER create mode 100644 sources/DEFFER-RUNTIME create mode 100644 sources/DEFPACKAGE-IMPORT create mode 100644 sources/DEFSTRUCT create mode 100644 sources/DEFSTRUCT-RUN-TIME create mode 100644 sources/DESCRIBE create mode 100644 sources/DEXEC create mode 100644 sources/DFILE create mode 100644 sources/DIRECTORY create mode 100644 sources/DISKDLION create mode 100644 sources/DISKVMEMDECLS create mode 100644 sources/DLAP create mode 100644 sources/DLFIXINIT create mode 100644 sources/DMISC create mode 100644 sources/DOVEDECLS create mode 100644 sources/DOVEDISK create mode 100644 sources/DOVEDISPLAY create mode 100644 sources/DOVEETHER create mode 100644 sources/DOVEETHERDECLS create mode 100644 sources/DOVEFLOPPY create mode 100644 sources/DOVEINPUTOUTPUT create mode 100644 sources/DOVEMISC create mode 100644 sources/DPUPFTP create mode 100644 sources/DSK create mode 100644 sources/DSKDISPLAY create mode 100644 sources/DSPRINTDEF create mode 100644 sources/DTDECLARE create mode 100644 sources/DWIM create mode 100644 sources/DWIMIFY create mode 100644 sources/EDIT create mode 100644 sources/EDITINTERFACE create mode 100644 sources/ERROR-RUNTIME create mode 100644 sources/ERROR-RUNTIME-AFTER-FASL create mode 100644 sources/EXEC-COMMANDS create mode 100644 sources/FASDUMP create mode 100644 sources/FASL-PACKAGE create mode 100644 sources/FASL-SUPPORT create mode 100644 sources/FASLOAD create mode 100644 sources/FILEIO create mode 100644 sources/FILEPKG create mode 100644 sources/FILESETS create mode 100644 sources/FILESETS.NOETHER create mode 100644 sources/FILESETS.ORIG create mode 100644 sources/FILESETS.PUP create mode 100644 sources/FLOPPY create mode 100644 sources/FONT create mode 100644 sources/FREEMENU create mode 100644 sources/FREEMENU.TEDIT create mode 100644 sources/GAINSPACE create mode 100644 sources/HARDCOPY create mode 100644 sources/HIST create mode 100644 sources/HLDISPLAY create mode 100644 sources/HPRINT create mode 100644 sources/ICONW create mode 100644 sources/ICONW.TEDIT create mode 100644 sources/IDLER create mode 100644 sources/IL-ERROR-STUFF create mode 100644 sources/IMAGEIO create mode 100644 sources/IMPLICIT-KEY-HASH create mode 100644 sources/INSPECT create mode 100644 sources/INSPECT-CLOSURE create mode 100644 sources/INTERPRESS create mode 100644 sources/IOCHAR create mode 100644 sources/LEAF create mode 100644 sources/LISP-PACKAGE create mode 100644 sources/LISPBCPLFILES.DM create mode 100644 sources/LLARITH create mode 100644 sources/LLARRAYELT create mode 100644 sources/LLBASIC create mode 100644 sources/LLBFS create mode 100644 sources/LLBIGNUM create mode 100644 sources/LLCHAR create mode 100644 sources/LLCODE create mode 100644 sources/LLCOLOR create mode 100644 sources/LLDATATYPE create mode 100644 sources/LLDISPLAY create mode 100644 sources/LLERROR create mode 100644 sources/LLETHER create mode 100644 sources/LLFAULT create mode 100644 sources/LLFLOAT create mode 100644 sources/LLGC create mode 100644 sources/LLINTERP create mode 100644 sources/LLKEY create mode 100644 sources/LLMVS create mode 100644 sources/LLNEW create mode 100644 sources/LLNS create mode 100644 sources/LLNSDECLS create mode 100644 sources/LLPACKAGE create mode 100644 sources/LLPARAMS create mode 100644 sources/LLREAD create mode 100644 sources/LLRESTART create mode 100644 sources/LLSTK create mode 100644 sources/LLSUBRS create mode 100644 sources/LLSYMBOL create mode 100644 sources/LLTIMER create mode 100644 sources/LOADFNS create mode 100644 sources/LOADFULL.CM create mode 100644 sources/LOADFULL.LISP create mode 100644 sources/LOADFULLFROMDLINIT.CM create mode 100644 sources/LOADFULLFROMDLINITSLOW.CM create mode 100644 sources/LOADFULLFROMLISP.CM create mode 100644 sources/LOADFULLSLOW.CM create mode 100644 sources/LOADINIT.CM create mode 100644 sources/LOADINITSLOW.CM create mode 100644 sources/LOADUP.LISP create mode 100644 sources/LOCALFILE create mode 100644 sources/LOGOW create mode 100644 sources/LispDMC.DM create mode 100644 sources/MACHINEINDEPENDENT create mode 100644 sources/MACROAUX create mode 100644 sources/MACROAUX-OPTIMIZERS create mode 100644 sources/MACROS create mode 100644 sources/MAIKOBITBLT create mode 100644 sources/MAIKOCOLOR create mode 100644 sources/MAIKOETHER create mode 100644 sources/MAIKOLOADUPFNS create mode 100644 sources/MAKEINIT create mode 100644 sources/MAPATOMS create mode 100644 sources/MEM create mode 100644 sources/MENU create mode 100644 sources/MISC create mode 100644 sources/MOD44IO create mode 100644 sources/MODARITH create mode 100644 sources/NEW-EDIT-INTERFACE create mode 100644 sources/NEWPRINTDEF create mode 100644 sources/NSFILING create mode 100644 sources/NSPRINT create mode 100644 sources/P4A.scn create mode 100644 sources/PACKAGE-CONVERSION-TABLE create mode 100644 sources/PACKAGE-STARTUP create mode 100644 sources/PAINTW create mode 100644 sources/PASSWORDS create mode 100644 sources/PMAP create mode 100644 sources/POSTLOADUP create mode 100644 sources/PRETTY create mode 100644 sources/PRINTFN create mode 100644 sources/PROC create mode 100644 sources/PROFILE create mode 100644 sources/PUP create mode 100644 sources/READ-PRINT-PROFILE create mode 100644 sources/RECORD create mode 100644 sources/RENAMEFNS create mode 100644 sources/RENAMEMACROS create mode 100644 sources/RESOURCE create mode 100644 sources/SEDIT create mode 100644 sources/SEDIT-ACCESS create mode 100644 sources/SEDIT-ATOMIC create mode 100644 sources/SEDIT-BASE create mode 100644 sources/SEDIT-COMMANDS create mode 100644 sources/SEDIT-COMMANDS.DATABASE create mode 100644 sources/SEDIT-COMMENTS create mode 100644 sources/SEDIT-CONVERT create mode 100644 sources/SEDIT-DEBUG create mode 100644 sources/SEDIT-DECLS create mode 100644 sources/SEDIT-EXPORTS create mode 100644 sources/SEDIT-INDENT create mode 100644 sources/SEDIT-LINEAR create mode 100644 sources/SEDIT-LIST-FORMATS create mode 100644 sources/SEDIT-LISTS create mode 100644 sources/SEDIT-TERMINAL create mode 100644 sources/SEDIT-TEST.TEDIT create mode 100644 sources/SEDIT-TOPLEVEL create mode 100644 sources/SEDIT-WINDOW create mode 100644 sources/SEDIT.TEDIT create mode 100644 sources/SETF-RUNTIME create mode 100644 sources/SPELL create mode 100644 sources/SPELLFILE create mode 100644 sources/SPP create mode 100644 sources/SPPDECLS create mode 100644 sources/STACKFNS create mode 100644 sources/SUNFONT create mode 100644 sources/SYSPRETTY create mode 100644 sources/TIME create mode 100644 sources/TRSERVER create mode 100644 sources/TTYIN create mode 100644 sources/TWODINSPECTOR create mode 100644 sources/TWODINSPECTOR.TEDIT create mode 100644 sources/UFS create mode 100644 sources/UFSCALLC create mode 100644 sources/UNDO create mode 100644 sources/UNIXPRINT create mode 100644 sources/UNIXPRINT.TEDIT create mode 100644 sources/UNWINDMACROS create mode 100644 sources/VANILLADISK create mode 100644 sources/WALKER create mode 100644 sources/WEDIT create mode 100644 sources/WINDOW create mode 100644 sources/WINDOWICON create mode 100644 sources/WINDOWOBJ create mode 100644 sources/WINDOWSCROLL create mode 100644 sources/WRAPPERS create mode 100644 sources/WTFIX create mode 100644 sources/XCL-COMPILER create mode 100644 sources/XCL-EXTRAS create mode 100644 sources/XCL-PACKAGE create mode 100644 sources/XCLC-ALPHA create mode 100644 sources/XCLC-ANALYZE create mode 100644 sources/XCLC-ANNOTATE create mode 100644 sources/XCLC-DATABASE create mode 100644 sources/XCLC-ENV-CTXT create mode 100644 sources/XCLC-GENCODE create mode 100644 sources/XCLC-META-EVAL create mode 100644 sources/XCLC-OPTIMIZERS create mode 100644 sources/XCLC-PEEPHOLE create mode 100644 sources/XCLC-RUNTIME create mode 100644 sources/XCLC-TOP-LEVEL create mode 100644 sources/XCLC-TRANSFORMS create mode 100644 sources/XCLC-TREES create mode 100644 sources/XMAS create mode 100644 sources/XMAS2 create mode 100644 sources/XXFILL create mode 100644 sources/XXGEOM create mode 100644 sources/new-edit-interface.tedit create mode 100644 sources/read-print-profile.tedit create mode 100644 sources/subrs.h diff --git a/sources/10MBDECLS b/sources/10MBDECLS new file mode 100644 index 00000000..27aa1ad3 --- /dev/null +++ b/sources/10MBDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 11:35:37" {DSK}local>lde>lispcore>sources>10MBDECLS.;2 18593 changes to%: (VARS 10MBDECLSCOMS) previous date%: "14-Apr-88 15:31:50" {DSK}local>lde>lispcore>sources>10MBDECLS.;1) (* ; " Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT 10MBDECLSCOMS) (RPAQQ 10MBDECLSCOMS ((COMS (RECORDS 10MBENCAPSULATION) (CONSTANTS \10MBHOST.WORDS \10MBENCAPSULATION.WORDS)) (MACROS \D0.CONTROLLERBITS \D0.TURNOFFETHER \DL.TURNOFFETHER) (RECORDS D0ETHERCSB D0ETHERIOCB DLETHERCSB DLETHERIOCB) (CONSTANTS (\D0.ENABLE.10MBINPUT 49152) (\D0.ENABLE.10MBOUTPUT 192) (\D0.RESET.10MBCONTROLLER 512) (\D0.INPUTSTATE 1) (\D0.OUTPUTSTATE 2) (\CSB.LENGTH 16) (\IOCB.LENGTH 8) (\MIN2PAGEBUFLENGTH 232) (\10MB.MINPACKETLENGTH 30)) (CONSTANTS * DLIONETHERCONSTANTS) (CONSTANTS * ETHERSTATUSCONSTANTS) (CONSTANTS * D0ETHERSTATUSCONSTANTS) (CONSTANTS * DLETHERSTATUSCONSTANTS) (CONSTANTS (\MAXLLBUFFERPAGES 2) (\MINLLBUFFERPAGES 1) (\MAXIOCBS 64) (\10MB.MAX.INPUT.LENGTH 20)) (GLOBALVARS \IOCB.INPUT.ALLOC \IOCB.INPUT.TOTAL \IOCB.OUTPUT.ALLOC \IOCB.OUTPUT.TOTAL \IOCBTOTAL \10MB.GETGARBAGE \10MB.RAWPACKETQ \10MB.IDEAL.INPUT.LENGTH \10MB.COLLECTSTATS \MACHINETYPE \10MBPACKETLENGTH \IOCBFREELIST))) (DECLARE%: EVAL@COMPILE (ACCESSFNS 10MBENCAPSULATION [(10MBBASE (LOCF (fetch (ETHERPACKET EPENCAPSULATION) of DATUM))) (10MBDESTNSADDRESSBASE (PROGN (* ; "This is a pseudo-field. There isn't really an NS address here, but you can fetch the host fields of it.") (\ADDBASE DATUM (SUB1 (INDEXF (fetch (ETHERPACKET EPENCAPSULATION) of DATUM] [BLOCKRECORD 10MBBASE ((10MBLENGTH WORD) (* ; "Length of packet in words, starting at the next word. Not part of the actual packet; it is here for convenience") (10MBDESTHOST0 3 WORD) (* ; "Immediate destination host") (10MBSOURCEHOST0 3 WORD) (* ; "Us") (10MBTYPE WORD) (* ; "Type of packet -- PUP, NS") ) (BLOCKRECORD 10MBBASE ((NIL WORD) (* ; "Length") (NIL BITS 7) (10MBMULTICASTP FLAG) (NIL BITS 8) (* ;  "Lo bit of first destination byte is the multicast bit") )) [ACCESSFNS 10MBDESTHOST0 ((10MBDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (10MBPACKETBASE (LOCF DATUM)) (10MBDESTHOSTBASE (LOCF DATUM] (ACCESSFNS 10MBSOURCEHOST0 ((10MBSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE)) (10MBSOURCEHOSTBASE (LOCF DATUM] (TYPE? (type? ETHERPACKET DATUM))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \10MBHOST.WORDS 3) (RPAQQ \10MBENCAPSULATION.WORDS 7) (CONSTANTS \10MBHOST.WORDS \10MBENCAPSULATION.WORDS) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \D0.CONTROLLERBITS MACRO ((NDB STATE) (* ;; "Returns a TASKREG argument for use with \DEVICE.INPUT / OUTPUT for controller's STATE reg, 0 <= STATE < 15; \D0.ETHERTASKNUMBER is a global set in initialization") (LOGOR (LLSH (fetch NDBTASK# of NDB) 4) STATE))) (PUTPROPS \D0.TURNOFFETHER MACRO (OPENLAMBDA (NDB) (\D0.STARTIO \D0.RESET.10MBCONTROLLER))) (PUTPROPS \DL.TURNOFFETHER MACRO [NIL (PROGN (\DEVICE.OUTPUT \DL.TURNOFFETHER \DL.ETHERINPUTREG) (to 3 repeatuntil (ZEROP (LOGAND (\DEVICE.INPUT \DL.ETHERSTATUSREG ) (LOGOR \DL.INPUT.ENABLED \DL.OUTPUT.ENABLED ]) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD D0ETHERCSB ((D0FIRSTOCB WORD) (* ; "Short pointer to first OCB") (D0OUTPUTMASK WORD) (* ; "Bit mask for output interrupt") (D0INPUTMASK WORD) (* ; "Bit mask for input interrupt") (D0MISSEDPACKETS WORD) (* ;  "Count of missed packets (for debugging)") (D0FIRSTICB WORD) (* ; "Short pointer to first ICB") (D0LOCALHOST0 WORD) (* ;  "Address we are listening for, 48d bits") (D0LOCALHOST1 WORD) (D0LOCALHOST2 WORD) (D0UCODESCRATCH 4 WORD) (* ; "Scratch buffer for microcode") (D0LASTICB WORD) (* ;  "Short pointer to last ICB if D0FIRSTICB non-null; not used by microcode") (D0LASTOCB WORD) (* ; "last OCB if D0FIRSTOCB non-null") (D0CSBSPARE 2 WORD))) (BLOCKRECORD D0ETHERIOCB ((D0NEXTIOCB WORD) (* ; "Short pointer to next one") (D0RETRANSMISSIONMASK WORD) (* ;  "Retransmission mask, output only") (NIL WORD) (D0IOCBSTATUS WORD) (* ;  "Completion code, filled in by microcode task") (D0IOCBBYTESUSED WORD) (* ; "Number of bytes received") (D0IOCBLENGTH WORD) (* ; "Length of buffer in bytes") (D0IOCBBUFFERLO WORD) (* ;  "Long pointer to buffer. Must be locked and quad-1 aligned") (D0IOCBBUFFERHI WORD)) [ACCESSFNS D0ETHERIOCB ((D0IOCBBUFFER (\VAG2 (fetch D0IOCBBUFFERHI of DATUM) (fetch D0IOCBBUFFERLO of DATUM)) (PROGN (replace D0IOCBBUFFERHI of DATUM with (\HILOC NEWVALUE)) (replace D0IOCBBUFFERLO of DATUM with (\LOLOC NEWVALUE]) (BLOCKRECORD DLETHERCSB ((DLLOCALHOST0 WORD) (* ;  "Address we are listening for, 48d bits") (DLLOCALHOST1 WORD) (DLLOCALHOST2 WORD) (DLFIRSTICB WORD) (* ; "Short pointer to first ICB") (DLINPUTMASK WORD) (* ; "Bit mask for input interrupt") (DLFIRSTOCB WORD) (* ; "Short pointer to first OCB") (DLOUTPUTMASK WORD) (* ; "Bit mask for output interrupt") (DLMISSEDPACKETS WORD) (* ;  "Count of missed packets (for debugging)") (DLLASTICB WORD) (* ;  "Short pointer to last ICB if DLFIRSTICB non-null; not used by microcode") (DLLASTOCB WORD) (* ; "last OCB if DLFIRSTOCB non-null") )) (BLOCKRECORD DLETHERIOCB ((DLIOCBLENGTH WORD) (* ; "Length of buffer in bytes") (DLIOCBBUFFERLO WORD) (* ;  "Long pointer to buffer. Must be locked and quad-1 aligned") (DLIOCBBUFFERHI WORD) (DLRETRANSMISSIONMASK WORD) (* ;  "Retransmission mask, output only") (DLIOCBBYTESUSED WORD) (* ; "Number of bytes received") (DLIOCBSTATUS WORD) (* ;  "Completion code, filled in by microcode task") (DLNEXTIOCB WORD) (* ; "Short pointer to next one") (DLFOROUTPUTUSE WORD) (* ; "Not used by microcode") ) [ACCESSFNS DLETHERIOCB ((DLIOCBBUFFER (\VAG2 (fetch DLIOCBBUFFERHI of DATUM) (fetch DLIOCBBUFFERLO of DATUM)) (PROGN (replace DLIOCBBUFFERHI of DATUM with (\HILOC NEWVALUE)) (replace DLIOCBBUFFERLO of DATUM with (\LOLOC NEWVALUE]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \D0.ENABLE.10MBINPUT 49152) (RPAQQ \D0.ENABLE.10MBOUTPUT 192) (RPAQQ \D0.RESET.10MBCONTROLLER 512) (RPAQQ \D0.INPUTSTATE 1) (RPAQQ \D0.OUTPUTSTATE 2) (RPAQQ \CSB.LENGTH 16) (RPAQQ \IOCB.LENGTH 8) (RPAQQ \MIN2PAGEBUFLENGTH 232) (RPAQQ \10MB.MINPACKETLENGTH 30) (CONSTANTS (\D0.ENABLE.10MBINPUT 49152) (\D0.ENABLE.10MBOUTPUT 192) (\D0.RESET.10MBCONTROLLER 512) (\D0.INPUTSTATE 1) (\D0.OUTPUTSTATE 2) (\CSB.LENGTH 16) (\IOCB.LENGTH 8) (\MIN2PAGEBUFLENGTH 232) (\10MB.MINPACKETLENGTH 30)) ) (RPAQQ DLIONETHERCONSTANTS ((\DL.ETHERINPUTREG 5) (\DL.ETHEROUTPUTREG 12) (\DL.ETHERSTATUSREG 1) (\DL.TURNOFFETHER 2) (\DL.ENABLE.OUTPUT 1) (\DL.ENABLE.INPUT 1) (\DL.INPUT.ENABLED 1024) (\DL.OUTPUT.ENABLED 256))) (DECLARE%: EVAL@COMPILE (RPAQQ \DL.ETHERINPUTREG 5) (RPAQQ \DL.ETHEROUTPUTREG 12) (RPAQQ \DL.ETHERSTATUSREG 1) (RPAQQ \DL.TURNOFFETHER 2) (RPAQQ \DL.ENABLE.OUTPUT 1) (RPAQQ \DL.ENABLE.INPUT 1) (RPAQQ \DL.INPUT.ENABLED 1024) (RPAQQ \DL.OUTPUT.ENABLED 256) (CONSTANTS (\DL.ETHERINPUTREG 5) (\DL.ETHEROUTPUTREG 12) (\DL.ETHERSTATUSREG 1) (\DL.TURNOFFETHER 2) (\DL.ENABLE.OUTPUT 1) (\DL.ENABLE.INPUT 1) (\DL.INPUT.ENABLED 1024) (\DL.OUTPUT.ENABLED 256)) ) (RPAQQ ETHERSTATUSCONSTANTS ((\ES.PENDING 0) (\ES.GOOD.PACKET 1) (\ES.PACKET.TOO.LONG 2) (\ES.BAD.CRC 3) (\ES.BAD.CRC&ALIGNMENT 4) (\ES.BAD.ALIGNMENT 5) (\ES.OVERRUN 6) (\ES.TOO.MANY.COLLISIONS 7) (\ES.UNDERRUN 8) (\ES.LATE.COLLISION 9) (\ES.OTHER.ERROR 10))) (DECLARE%: EVAL@COMPILE (RPAQQ \ES.PENDING 0) (RPAQQ \ES.GOOD.PACKET 1) (RPAQQ \ES.PACKET.TOO.LONG 2) (RPAQQ \ES.BAD.CRC 3) (RPAQQ \ES.BAD.CRC&ALIGNMENT 4) (RPAQQ \ES.BAD.ALIGNMENT 5) (RPAQQ \ES.OVERRUN 6) (RPAQQ \ES.TOO.MANY.COLLISIONS 7) (RPAQQ \ES.UNDERRUN 8) (RPAQQ \ES.LATE.COLLISION 9) (RPAQQ \ES.OTHER.ERROR 10) (CONSTANTS (\ES.PENDING 0) (\ES.GOOD.PACKET 1) (\ES.PACKET.TOO.LONG 2) (\ES.BAD.CRC 3) (\ES.BAD.CRC&ALIGNMENT 4) (\ES.BAD.ALIGNMENT 5) (\ES.OVERRUN 6) (\ES.TOO.MANY.COLLISIONS 7) (\ES.UNDERRUN 8) (\ES.LATE.COLLISION 9) (\ES.OTHER.ERROR 10)) ) (RPAQQ D0ETHERSTATUSCONSTANTS ((\D0.BAD.ALIGNMENT 2048) (\D0.INPUT.OVERRUN 1024) (\D0.INPUT.BAD.PACKET 512) (\D0.INPUT.BAD.CRC 256) (\D0.OUTPUT.UNDERRUN 64) (\D0.COLLISION 32) (\D0.OUTPUT.BAD.PARITY 128) (\D0.OUTPUT.FAULT 16) (\D0.GOOD.PACKET 16384) (\D0.PACKET.TOO.LONG 25088) (\D0.TOO.MANY.COLLISIONS 25600) (\D0.LATE.COLLISION 26112) (\D0.BUFFER.TOO.SHORT 26624))) (DECLARE%: EVAL@COMPILE (RPAQQ \D0.BAD.ALIGNMENT 2048) (RPAQQ \D0.INPUT.OVERRUN 1024) (RPAQQ \D0.INPUT.BAD.PACKET 512) (RPAQQ \D0.INPUT.BAD.CRC 256) (RPAQQ \D0.OUTPUT.UNDERRUN 64) (RPAQQ \D0.COLLISION 32) (RPAQQ \D0.OUTPUT.BAD.PARITY 128) (RPAQQ \D0.OUTPUT.FAULT 16) (RPAQQ \D0.GOOD.PACKET 16384) (RPAQQ \D0.PACKET.TOO.LONG 25088) (RPAQQ \D0.TOO.MANY.COLLISIONS 25600) (RPAQQ \D0.LATE.COLLISION 26112) (RPAQQ \D0.BUFFER.TOO.SHORT 26624) (CONSTANTS (\D0.BAD.ALIGNMENT 2048) (\D0.INPUT.OVERRUN 1024) (\D0.INPUT.BAD.PACKET 512) (\D0.INPUT.BAD.CRC 256) (\D0.OUTPUT.UNDERRUN 64) (\D0.COLLISION 32) (\D0.OUTPUT.BAD.PARITY 128) (\D0.OUTPUT.FAULT 16) (\D0.GOOD.PACKET 16384) (\D0.PACKET.TOO.LONG 25088) (\D0.TOO.MANY.COLLISIONS 25600) (\D0.LATE.COLLISION 26112) (\D0.BUFFER.TOO.SHORT 26624)) ) (RPAQQ DLETHERSTATUSCONSTANTS ((\DL.COLLISION 64) (\DL.UNDERRUN 32) (\DL.BAD.ALIGNMENT 16) (\DL.OVERRUN 8) (\DL.BAD.CRC 4) (\DL.ODDLENGTH 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \DL.COLLISION 64) (RPAQQ \DL.UNDERRUN 32) (RPAQQ \DL.BAD.ALIGNMENT 16) (RPAQQ \DL.OVERRUN 8) (RPAQQ \DL.BAD.CRC 4) (RPAQQ \DL.ODDLENGTH 2) (CONSTANTS (\DL.COLLISION 64) (\DL.UNDERRUN 32) (\DL.BAD.ALIGNMENT 16) (\DL.OVERRUN 8) (\DL.BAD.CRC 4) (\DL.ODDLENGTH 2)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \MAXLLBUFFERPAGES 2) (RPAQQ \MINLLBUFFERPAGES 1) (RPAQQ \MAXIOCBS 64) (RPAQQ \10MB.MAX.INPUT.LENGTH 20) (CONSTANTS (\MAXLLBUFFERPAGES 2) (\MINLLBUFFERPAGES 1) (\MAXIOCBS 64) (\10MB.MAX.INPUT.LENGTH 20)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IOCB.INPUT.ALLOC \IOCB.INPUT.TOTAL \IOCB.OUTPUT.ALLOC \IOCB.OUTPUT.TOTAL \IOCBTOTAL \10MB.GETGARBAGE \10MB.RAWPACKETQ \10MB.IDEAL.INPUT.LENGTH \10MB.COLLECTSTATS \MACHINETYPE \10MBPACKETLENGTH \IOCBFREELIST) ) (PUTPROPS 10MBDECLS COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/10MBDRIVER b/sources/10MBDRIVER new file mode 100644 index 00000000..3636b7fe --- /dev/null +++ b/sources/10MBDRIVER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Feb-91 13:32:30" {DSK}sybalsky>3-BYTE-ATOM-CHANGES>10MBDRIVER.;1 40281 changes to%: (FNS \HANDLE.RAW.3TO10) previous date%: " 5-Sep-90 11:30:30" |{PELE:MV:ENVOS}SOURCES>10MBDRIVER.;3|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT 10MBDRIVERCOMS) (RPAQQ 10MBDRIVERCOMS ((COMS (* ; "raw packet interface") (FNS \10MBGETPACKET \10MBSENDPACKET \10MBENCAPSULATE \10MB.BROADCASTP \10MBWATCHER)) (COMS (* ; "Machine independent part") (FNS \10MB.STARTDRIVER \10MB.CREATENDB \10MB.INPUT.INTERRUPT \10MB.OUTPUT.INTERRUPT \10MB.NOTESTAT) (INITVARS (\10MB.RCLK.BOX (CREATECELL \FIXP)) (\10MB.EXPECTED.RECEIVE.INTERVAL 60) (\10MB.INPUT.TIMEOUT (TIMES \RCLKSECOND \10MB.EXPECTED.RECEIVE.INTERVAL)) (\10MB.INPUT.TIMER (SETUPTIMER 0))) (GLOBALVARS \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER)) (COMS (* ; "Buffer management") (FNS \10MB.LOADINPUTQ \RELEASE.IOCB \GET.IOCB \INIT.ETHER.BUFFER.POOL) (INITVARS (\10MBPACKETLENGTH 488))) (COMS (* ; "Dolphin/Dlion head") (FNS \10MB.GETPACKETLENGTH \10MB.GETPACKETSTATUS \QUEUE.INPUT.IOCB \QUEUE.OUTPUT.IOCB \10MB.TURNOFFETHER \10MB.TURNONETHER \10MB.RESTART.ETHER)) (COMS (* ; "Misc") (FNS \NOMACHINETYPE \10MB.PRINT.ENCAPSULATION) (FNS IOCBQLENGTH)) (INITVARS \10MB.GETGARBAGE \10MB.COLLECTSTATS) [COMS (* ; "PUP address resolution") (FNS \HANDLE.RAW.3TO10 \TRANSLATE.3TO10 PRINT3TO10 \NOTE.3TO10) (INITVARS (\10MBTYPE.PUP 512) (\10MBTYPE.3TO10 513) (\10MBTYPE.TRANSLATIONS)) (GLOBALVARS \10MBTYPE.3TO10 \10MBTYPE.PUP \10MBTYPE.TRANSLATIONS) (CONSTANTS \EPT.3TO10) (ADDVARS (\PACKET.PRINTERS (513 . PRINT3TO10] (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (SOURCE) 10MBDECLS DOVEDECLS DOVEETHERDECLS LLNSDECLS) (FILES (LOADCOMP) LLETHER)))) (* ; "raw packet interface") (DEFINEQ (\10MBGETPACKET [LAMBDA NIL (* ; "Edited 31-Mar-87 18:11 by bvm:") (LET (PACKET TYPE) (COND ((SETQ PACKET (\DEQUEUE \10MB.RAWPACKETQ)) (replace EPTYPE of PACKET with (for PAIR in \10MBTYPE.TRANSLATIONS bind (TYPE _ (fetch 10MBTYPE of PACKET)) when (EQ TYPE (CAR PAIR)) do (* ;; "TYPE is the raw type of the etherpacket. These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.") (RETURN (CDR PAIR)) finally (RETURN TYPE))) [COND (\RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWGET] PACKET]) (\10MBSENDPACKET [LAMBDA (NDB PACKET) (* ; "Edited 14-Apr-88 15:30 by bvm") (PROG ([DROPIT (AND \ETHERLIGHTNING (EQ 0 (RAND 0 \ETHERLIGHTNING] IOCB BUFLENGTH) [COND (\RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWPUT] [COND ([AND (NOT (fetch NDBCANHEARSELF of NDB)) (OR (fetch 10MBMULTICASTP of PACKET) (EQNSADDRESS.HOST \MY.NSADDRESS (fetch 10MBDESTNSADDRESSBASE of PACKET ] (* ;  "We would hear this packet if our hardware let us, so fake receipt") (PROG ((COPYPACKET (\ALLOCATE.ETHERPACKET))) (\BLT (LOCF (fetch 10MBLENGTH of COPYPACKET)) (LOCF (fetch 10MBLENGTH of PACKET)) (ADD1 (fetch 10MBLENGTH of PACKET))) (* ;  "Copy all data that would have been transmitted") (replace EPNETWORK of COPYPACKET with NDB) (\ENQUEUE \10MB.RAWPACKETQ COPYPACKET] (UNINTERRUPTABLY (replace EPTRANSMITTING of PACKET with T) (COND ([OR DROPIT (NULL (SETQ IOCB (\GET.IOCB 'OUTPUT] (* ; "Fake transmission") (replace EPNETWORK of PACKET with NIL)) (T (replace EPNETWORK of PACKET with IOCB) (SETQ BUFLENGTH (IMAX (fetch 10MBLENGTH of PACKET) \10MB.MINPACKETLENGTH)) (\TEMPLOCKPAGES PACKET (COND ((IGEQ BUFLENGTH \MIN2PAGEBUFLENGTH) 2) (T 1))) (* ; "Put on microcode queue") (\QUEUE.OUTPUT.IOCB NDB IOCB (fetch 10MBPACKETBASE of PACKET) BUFLENGTH) T)) (\ENQUEUE (fetch NDBTQ of NDB) PACKET) (* ;  "Put on driver's queue to pick up after microcode finishes with it") ) (RETURN (AND IOCB T]) (\10MBENCAPSULATE [LAMBDA (NDB PACKET PDH LENGTH TYPE) (* ; "Edited 14-Jan-88 15:35 by bvm") (* ;; "Encapsulates PACKET for transmission on 10mb net NDB: Fill in destination host (48 bits), source host (me, 48 bits), LENGTH (in bytes) and protocol TYPE. PDH can be an NSHOSTNUMBER or any piece of storage resembling an NSADDRESS.") (if (type? NSHOSTNUMBER PDH) then (replace 10MBDESTHOST of PACKET with PDH) else (* ;  "PDH is an NSADDRESS object or piece of storage") (\BLT (fetch 10MBDESTHOSTBASE of PACKET) (LOCF (FFETCH NSHNM0 OF PDH)) \10MBHOST.WORDS)) (\BLT (fetch 10MBSOURCEHOSTBASE of PACKET) (LOCF (FFETCH NSHNM0 OF \MY.NSADDRESS)) \10MBHOST.WORDS) (replace 10MBLENGTH of PACKET with (+ (FOLDHI LENGTH BYTESPERWORD) \10MBENCAPSULATION.WORDS)) (replace 10MBTYPE of PACKET with TYPE) PACKET]) (\10MB.BROADCASTP [LAMBDA (PACKET) (* bvm%: "23-Apr-84 14:34") (fetch 10MBMULTICASTP of PACKET]) (\10MBWATCHER [LAMBDA (NDB) (* bvm%: "26-OCT-83 15:23") (* ;; "Process that watches the 10mb net and pulls packets in. Decodes the type and passes packet to interested party") (PROG ((CNTR 0) PACKET) LP (UNINTERRUPTABLY (\10MB.INPUT.INTERRUPT NDB) (\10MB.OUTPUT.INTERRUPT NDB)) [COND ((SETQ PACKET (\10MBGETPACKET)) (* ; "Got something") (\HANDLE.RAW.PACKET PACKET) (COND ((ILESSP (add CNTR 1) \MAXWATCHERGETS) (* ;  "Hack to get better ether service in lieu of preemption") (GO LP] (BLOCK) (SETQ CNTR 0) (GO LP]) ) (* ; "Machine independent part") (DEFINEQ (\10MB.STARTDRIVER [LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* ejs%: " 7-Sep-85 19:24") (\10MB.TURNOFFETHER NDB) (OR (\INIT.ETHER.BUFFER.POOL) (ERROR "Unable to create buffer pool")) (replace NDBTQ of NDB with (create SYSQUEUE)) (SETQ \10MB.RAWPACKETQ (create SYSQUEUE)) (SETQ \10MB.INPUT.TIMEOUT (TIMES \RCLKSECOND \10MB.EXPECTED.RECEIVE.INTERVAL)) (\10MB.TURNONETHER NDB NIL NIL (OR MYNSNUMBER T) 0 0) (PROG ((LEN 0) (IQ (fetch NDBIQ of NDB))) [COND [IQ (SETQ LEN (\10MB.LOADINPUTQ NDB (fetch SYSQUEUEHEAD of IQ] (T (replace NDBIQ of NDB with (SETQ IQ (create SYSQUEUE] (bind IOCB PACKET to (IDIFFERENCE \10MB.IDEAL.INPUT.LENGTH LEN) while (SETQ IOCB (\GET.IOCB 'INPUT)) do (SETQ PACKET (\ALLOCATE.ETHERPACKET)) (\TEMPLOCKPAGES PACKET 2) (replace EPNETWORK of PACKET with IOCB) (\QUEUE.INPUT.IOCB NDB IOCB (fetch 10MBPACKETBASE of PACKET) \10MBPACKETLENGTH) (* ; "Add IOCB to microcode's queue") (\ENQUEUE IQ PACKET) (* ;  "and to driver's queue, so it can process it after arrival") (add LEN 1)) (replace NDBIQLENGTH of NDB with LEN) (replace NDBWATCHER of NDB with (ADD.PROCESS (LIST '\10MBWATCHER (KWOTE NDB)) 'RESTARTABLE 'SYSTEM 'AFTEREXIT 'DELETE)) (RETURN NDB]) (\10MB.CREATENDB [LAMBDA (ETHERTASK#) (* ; "Edited 31-Mar-87 19:33 by bvm:") (* ;; "If using new ethernet style pups, set up translation list") (if (NEQ \10MBTYPE.PUP \EPT.PUP) then (CL:PUSHNEW (CONS \10MBTYPE.PUP \EPT.PUP) \10MBTYPE.TRANSLATIONS :TEST 'EQUAL)) (if (NEQ \10MBTYPE.3TO10 \EPT.3TO10) then (CL:PUSHNEW (CONS \10MBTYPE.3TO10 \EPT.3TO10) \10MBTYPE.TRANSLATIONS :TEST 'EQUAL)) (\10MB.STARTDRIVER (create NDB NDBNSNET# _ 0 NDBPUPNET# _ 0 NETTYPE _ 10 NDBPUPTYPE _ \10MBTYPE.PUP NDBTRANSMITTER _ (FUNCTION \10MBSENDPACKET) NDBENCAPSULATOR _ (FUNCTION \10MBENCAPSULATE) NDBBROADCASTP _ (FUNCTION \10MB.BROADCASTP) NDBTASK# _ ETHERTASK# NDBETHERFLUSHER _ (FUNCTION \10MB.TURNOFFETHER) NDBCANHEARSELF _ (EQ \MACHINETYPE \DOLPHIN]) (\10MB.INPUT.INTERRUPT [LAMBDA (NDB) (* ; "Edited 31-Mar-87 18:10 by bvm:") (* ;; "This routine gets called when 10MB input signals an interrupt. See if the head of the input queue has indeed been processed, and if so, take care of it") (PROG ((PACKET (fetch SYSQUEUEHEAD of (fetch NDBIQ of NDB))) STATUS ACCEPTPACKET IOCB) [COND ((AND PACKET (NEQ [SETQ STATUS (\10MB.GETPACKETSTATUS (SETQ IOCB (fetch EPNETWORK of PACKET] \ES.PENDING)) (* ;  "Yes, something is there, and microcode is finished with it") (\DEQUEUE (fetch NDBIQ of NDB)) [COND (\10MB.COLLECTSTATS (\10MB.NOTESTAT STATUS PACKET 'INPUT] [COND ((SETQ ACCEPTPACKET (OR (EQ STATUS \ES.GOOD.PACKET) \10MB.GETGARBAGE)) (PROG ((LENGTH (\10MB.GETPACKETLENGTH IOCB))) (* ; "Accept the packet") (replace 10MBLENGTH of PACKET with LENGTH) (\RCLK (LOCF (fetch EPTIMESTAMP of PACKET))) (replace EPRECEIVING of PACKET with NIL) (replace EPNETWORK of PACKET with NDB) (COND ((AND (OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK)) (IGREATERP LENGTH \MIN2PAGEBUFLENGTH)) (* ;; "Dandelion ether uCode doesn't set the dirty bit on pages of PACKET, so make sure the second page gets marked dirty if it needs to be. The first page has been implicitly marked dirty by the replaces above") (\PUTBASE PACKET (SUB1 (ITIMES WORDSPERPAGE 2)) 0))) (\TEMPUNLOCKPAGES PACKET 2) (\ENQUEUE \10MB.RAWPACKETQ PACKET)) (PROGN (* ; "Now stuff a new buffer on queue") (SETQ PACKET (\ALLOCATE.ETHERPACKET)) (\TEMPLOCKPAGES PACKET 2) (replace EPNETWORK of PACKET with IOCB] (* ;  "Now stuff a buffer back on the input") (\QUEUE.INPUT.IOCB NDB IOCB (fetch 10MBPACKETBASE of PACKET) \10MBPACKETLENGTH) (\ENQUEUE (fetch NDBIQ of NDB) PACKET)) (PACKET (* ;  "There is something there, and the microcode is NOT finished with it") (COND ((NOT (fetch EPRECEIVING of PACKET)) (* ;; "Furthermore, this is the first time we've seen this packet at the head of the receive queue. We timestamp it, and if it's still here sometime later, we kick the Ethernet receiver microcode, just in case it's turned itself off") (SETUPTIMER \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER 'TICKS) (replace EPRECEIVING of PACKET with T)) (T (* ;;  "We've seen this packet before. Check for timeout, and kick the receiver microcode if necessary") (COND ((TIMEREXPIRED? \10MB.INPUT.TIMER 'TICKS) (\10MB.RESTART.ETHER NDB) (* ; "Update the timestamp") (SETUPTIMER \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER 'TICKS] (RETURN ACCEPTPACKET]) (\10MB.OUTPUT.INTERRUPT [LAMBDA (NDB) (* bvm%: "10-JUN-83 14:56") (* ;; "This routine gets called when 10MB output signals an interrupt. Remove the head of the output queue and put it on the done queue") (PROG ((NEXTPACKET (fetch SYSQUEUEHEAD of (fetch NDBTQ of NDB))) STATUS IOCB) (RETURN (COND ((AND NEXTPACKET (OR (NULL (SETQ IOCB (fetch EPNETWORK of NEXTPACKET))) (NEQ (SETQ STATUS (\10MB.GETPACKETSTATUS IOCB)) \ES.PENDING)))(* ;  "Yes, microcode has finished processing this buffer") (\DEQUEUE (fetch NDBTQ of NDB)) (replace EPTRANSMITTING of NEXTPACKET with NIL) (replace EPNETWORK of NEXTPACKET with NIL) (\REQUEUE.ETHERPACKET NEXTPACKET) [COND (IOCB (\RELEASE.IOCB IOCB 'OUTPUT) (\TEMPUNLOCKPAGES NEXTPACKET 2) (COND (\10MB.COLLECTSTATS (\10MB.NOTESTAT STATUS NEXTPACKET 'OUTPUT] T]) (\10MB.NOTESTAT [LAMBDA (STATUS BUF USE) (* bvm%: "15-JUL-82 14:43") (* ;; "Increment counter associated with this status") NIL]) ) (RPAQ? \10MB.RCLK.BOX (CREATECELL \FIXP)) (RPAQ? \10MB.EXPECTED.RECEIVE.INTERVAL 60) (RPAQ? \10MB.INPUT.TIMEOUT (TIMES \RCLKSECOND \10MB.EXPECTED.RECEIVE.INTERVAL)) (RPAQ? \10MB.INPUT.TIMER (SETUPTIMER 0)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER) ) (* ; "Buffer management") (DEFINEQ (\10MB.LOADINPUTQ (LAMBDA (NDB PACKETS) (* bvm%: "28-FEB-83 17:36") (* ;; "PACKETS points at the first of several buffers of NDB's IQ. We load them into the microcode's chain. Value returned is the number of buffers") (bind (CNT _ 0) while PACKETS do (\TEMPLOCKPAGES PACKETS 2) (\QUEUE.INPUT.IOCB NDB (fetch EPNETWORK of PACKETS) (fetch 10MBPACKETBASE of PACKETS) \10MBPACKETLENGTH) (SETQ PACKETS (fetch EPLINK of PACKETS)) (add CNT 1) finally (RETURN CNT))) ) (\RELEASE.IOCB (LAMBDA (IOCB USE) (* bvm%: " 3-MAR-83 16:17") (* ;; "Returns an IOCB to the free pool. USE is INPUT or OUTPUT, according to which side should be credited. Must be called uninterruptably") (COND ((NOT (AND IOCB (EMADDRESSP IOCB))) (ERROR "ARG NOT IOCB" IOCB)) (T (SELECTQ USE (INPUT (add \IOCB.INPUT.ALLOC 1)) (OUTPUT (add \IOCB.OUTPUT.ALLOC 1)) (\ILLEGAL.ARG USE)) (replace D0NEXTIOCB of IOCB with (\LOLOC \IOCBFREELIST)) (* ; "(\LOLOC NIL) = 0 works also") (SETQ \IOCBFREELIST IOCB) NIL))) ) (\GET.IOCB (LAMBDA (USE) (* edited%: "14-Aug-85 16:46") (* ;; "returns a IOCB for INPUT or OUTPUT use, or NIL if none is available. This must be called uninterruptably, since we don't have any easy way of GCing these guys") (DECLARE (GLOBALVARS \10MBLOCALNDB)) (COND ((AND \IOCBFREELIST (IGREATERP (SELECTQ USE (INPUT \IOCB.INPUT.ALLOC) (OUTPUT \IOCB.OUTPUT.ALLOC) (\ILLEGAL.ARG USE)) 0)) (SELECTQ USE (INPUT (add \IOCB.INPUT.ALLOC -1)) (add \IOCB.OUTPUT.ALLOC -1)) (* ;; "I removed the call to HELP that used to be in here. If the IOCB freelist goes NIL, the packet is dropped on the floor") (PROG1 \IOCBFREELIST (SETQ \IOCBFREELIST (EMPOINTER (fetch D0NEXTIOCB of \IOCBFREELIST))) (* ; "Note that (EMPOINTER 0) = NIL, so this works even when free list runs out"))))) ) (\INIT.ETHER.BUFFER.POOL (LAMBDA NIL (* ejs%: "26-Jul-85 23:14") (* ;; "Divides up the zone bcpl reserved for us into IOCB's used for sending/receiving ether packets. The IOCB's must be quad-aligned. When an ether packet is to be sent, or prepared for receiving, an IOCB is assigned to it. The IOCB contains length and status info and a pointer to the ether packet buffer in Lisp space. The IOCB's are chained for the microcode, and the packets are chained independently in Lisp space so that we can keep track of them after the microcode finishes. \IOCBFREELIST points at the first IOCB; there are a total of \IOCBTOTAL of them.") (PROG (LASTBUF BUFFER ZONE ZONELENGTH) (COND ((EQ (SETQ ZONELENGTH (fetch (IFPAGE MDSZoneLength) of \InterfacePage)) 0) (* ; "Bcpl was unable to allocate any space for us") (SETQ \IOCBFREELIST NIL) (SETQ \IOCBTOTAL 0) (RETURN)) (T (SETQ ZONE (fetch (IFPAGE MDSZone) of \InterfacePage)) (SETQ ZONELENGTH (IDIFFERENCE ZONELENGTH (IDIFFERENCE ZONE (SETQ ZONE (CEIL ZONE (ITIMES 2 WORDSPERQUAD)))))) (* ; "8-align the zone, in case the microcode cares, and adjust the length downward if necessary") (SETQ ZONE (EMPOINTER ZONE)) (* ; "Make an actual pointer"))) (SETQ \IOCBTOTAL (IMIN (IQUOTIENT (IDIFFERENCE ZONELENGTH 3) (SELECTC \MACHINETYPE (\DAYBREAK \DoveEther.IOIOCBLength) \IOCB.LENGTH)) \MAXIOCBS)) (SETQ \IOCBFREELIST ZONE) (to \IOCBTOTAL do (* ; "Link the idle IOCB's together using short addresses") (replace D0NEXTIOCB of ZONE with (\LOLOC (SETQ ZONE (\ADDBASE ZONE (SELECTC \MACHINETYPE (\DAYBREAK \DoveEther.IOIOCBLength) \IOCB.LENGTH))))) finally (replace D0NEXTIOCB of ZONE with 0)) (SETQ \TELERAIDIOCB (PROG1 \IOCBFREELIST (SETQ \IOCBFREELIST (EMPOINTER (fetch D0NEXTIOCB of \IOCBFREELIST))))) (* ; "Pop one off for TeleRaid") (add \IOCBTOTAL -1) (SETQ \IOCB.INPUT.ALLOC (SETQ \IOCB.INPUT.TOTAL (SETQ \IOCB.OUTPUT.ALLOC (SETQ \IOCB.OUTPUT.TOTAL (IQUOTIENT (ITIMES \IOCBTOTAL 2) 3))))) (SETQ \10MB.IDEAL.INPUT.LENGTH (IMIN \10MB.MAX.INPUT.LENGTH (IQUOTIENT \IOCBTOTAL 2))) (RETURN \IOCBTOTAL))) ) ) (RPAQ? \10MBPACKETLENGTH 488) (* ; "Dolphin/Dlion head") (DEFINEQ (\10MB.GETPACKETLENGTH (LAMBDA (IOCB) (* ejs%: "18-Sep-85 15:09") (SELECTC \MACHINETYPE (\DANDELION (fetch DLIOCBBYTESUSED of IOCB)) (\DAYBREAK (fetch (Dove.EtherIOIOCB count) of IOCB)) (\DOLPHIN (FOLDLO (fetch D0IOCBBYTESUSED of IOCB) BYTESPERWORD)) (\NOMACHINETYPE))) ) (\10MB.GETPACKETSTATUS (LAMBDA (IOCB) (* ejs%: "26-Jul-85 22:43") (* ;; "Translate device bits to device-independent constants") (* ;; "Now allow odd-length packets to be received") (SELECTC \MACHINETYPE (\DANDELION (PROG ((STATUS (fetch DLIOCBSTATUS of IOCB))) (RETURN (COND ((EQ STATUS 0) \ES.PENDING) ((EQ (fetch DLFOROUTPUTUSE of IOCB) 0) (* ; "Input errors") (COND ((EQ (fetch DLIOCBLENGTH of IOCB) 65535) \ES.PACKET.TOO.LONG) (T (COND ((EQ (SETQ STATUS (LOGAND STATUS (LOGOR \DL.BAD.ALIGNMENT \DL.OVERRUN \DL.BAD.CRC))) 0) \ES.GOOD.PACKET) ((NEQ (LOGAND STATUS \DL.OVERRUN) 0) \ES.OVERRUN) ((NEQ (LOGAND STATUS \DL.BAD.CRC) 0) (COND ((EQ (LOGAND STATUS (LOGOR \DL.BAD.ALIGNMENT \DL.ODDLENGTH)) 0) \ES.BAD.CRC) (T \ES.BAD.CRC&ALIGNMENT))) ((NEQ (LOGAND STATUS \DL.BAD.ALIGNMENT) 0) \ES.BAD.ALIGNMENT) (T \ES.OTHER.ERROR))))) (T (* ; "Output errors") (COND ((EQ (fetch DLRETRANSMISSIONMASK of IOCB) 8191) \ES.TOO.MANY.COLLISIONS) (T (COND ((EQ (LOGAND STATUS (LOGOR \DL.COLLISION \DL.UNDERRUN)) 0) \ES.GOOD.PACKET) (T \ES.UNDERRUN))))))))) (\DAYBREAK (\DoveEther.GetPacketStatus IOCB)) (\DOLPHIN (PROG ((STATUS (fetch D0IOCBSTATUS of IOCB))) (RETURN (SELECTC STATUS (0 \ES.PENDING) (\D0.GOOD.PACKET \ES.GOOD.PACKET) (\D0.LATE.COLLISION \ES.LATE.COLLISION) (\D0.TOO.MANY.COLLISIONS \ES.TOO.MANY.COLLISIONS) (\D0.PACKET.TOO.LONG \ES.PACKET.TOO.LONG) (\D0.BAD.ALIGNMENT \ES.BAD.ALIGNMENT) (\D0.INPUT.BAD.CRC \ES.BAD.CRC) ((LOGOR \D0.BAD.ALIGNMENT \D0.INPUT.BAD.CRC) \ES.BAD.CRC&ALIGNMENT) (COND ((NEQ (LOGAND STATUS \D0.INPUT.OVERRUN) 0) \ES.OVERRUN) ((NEQ (LOGAND STATUS \D0.OUTPUT.UNDERRUN) 0) \ES.UNDERRUN) (T \ES.OTHER.ERROR)))))) (\NOMACHINETYPE))) ) (\QUEUE.INPUT.IOCB (LAMBDA (NDB IOCB BUFFER LENGTH) (* ; "Edited 29-Jun-88 16:57 by bvm") (* ;; "Add IOCB to the end of the microcode input queue, with BUFFER of LENGTH words as its buffer. I.e., this is a buffer that packets will be read into") (PROG ((CSB (fetch NDBCSB of NDB))) (SELECTC \MACHINETYPE (\DANDELION (replace DLFOROUTPUTUSE of IOCB with 0) (* ; "So that \10MB.GETPACKETSTATUS can tell which way packet is going") (replace DLNEXTIOCB of IOCB with 0) (replace DLRETRANSMISSIONMASK of IOCB with 0) (replace DLIOCBSTATUS of IOCB with \ES.PENDING) (replace DLIOCBLENGTH of IOCB with (SUB1 LENGTH)) (* ; "The %"Length%" field on DLion is actually %"offset to last word in buffer%"") (replace DLIOCBBUFFER of IOCB with BUFFER) (COND ((NEQ (fetch DLFIRSTICB of CSB) 0) (* ; "There are some packets there, so add this to end") (replace DLNEXTIOCB of (OR (EMPOINTER (fetch DLLASTICB of CSB)) (RAID "Garbage last ICB")) with (\LOLOC IOCB)))) (COND ((AND (EQ (fetch DLFIRSTICB of CSB) 0) (EQ (fetch DLIOCBSTATUS of IOCB) \ES.PENDING)) (* ;; "No buffers left, so queue this as the only one. While we were in the last clause, microcode could have eaten up its last buffer, which is why we test twice") (replace DLFIRSTICB of CSB with (\LOLOC IOCB)) (\DEVICE.OUTPUT \DL.ENABLE.INPUT \DL.ETHERINPUTREG))) (replace DLLASTICB of CSB with (\LOLOC IOCB))) (\DAYBREAK (\DoveEther.QueueInput IOCB BUFFER LENGTH)) (\DOLPHIN (replace D0NEXTIOCB of IOCB with 0) (replace D0RETRANSMISSIONMASK of IOCB with 0) (replace D0IOCBSTATUS of IOCB with \ES.PENDING) (replace D0IOCBLENGTH of IOCB with (UNFOLD LENGTH BYTESPERWORD)) (replace D0IOCBBUFFER of IOCB with BUFFER) (COND ((NEQ (fetch D0FIRSTICB of CSB) 0) (* ; "There are some packets there, so add this to end") (replace D0NEXTIOCB of (OR (EMPOINTER (fetch D0LASTICB of CSB)) (RAID "Garbage last ICB")) with (\LOLOC IOCB)))) (COND ((AND (EQ (fetch D0FIRSTICB of CSB) 0) (EQ (fetch D0IOCBSTATUS of IOCB) \ES.PENDING)) (* ;; "No buffers left, so queue this as the only one. While we were in the last clause, microcode could have eaten up its last buffer, which is why we test twice") (replace D0FIRSTICB of CSB with (\LOLOC IOCB)) (\DEVICE.OUTPUT \D0.ENABLE.10MBINPUT (\D0.CONTROLLERBITS NDB \D0.INPUTSTATE)))) (replace D0LASTICB of CSB with (\LOLOC IOCB))) (\NOMACHINETYPE)))) ) (\QUEUE.OUTPUT.IOCB (LAMBDA (NDB IOCB BUFFER LENGTH) (* ; "Edited 29-Jun-88 16:57 by bvm") (* ;; "Queue up IOCB for transmission. LENGTH is length of BUFFER in words") (PROG ((CSB (fetch NDBCSB of NDB))) (SELECTC \MACHINETYPE (\DANDELION (replace DLFOROUTPUTUSE of IOCB with 1) (* ; "So that \10MB.GETPACKETSTATUS can tell which way packet is going") (replace DLIOCBLENGTH of IOCB with (SUB1 LENGTH)) (* ; "The %"Length%" field on DLion is actually %"offset to last word in buffer%"") (replace DLNEXTIOCB of IOCB with 0) (replace DLRETRANSMISSIONMASK of IOCB with 0) (replace DLIOCBSTATUS of IOCB with \ES.PENDING) (replace DLIOCBBUFFER of IOCB with BUFFER) (COND ((NEQ (fetch DLFIRSTOCB of CSB) 0) (* ; "Hardware active, add to end of chain") (replace DLNEXTIOCB of (OR (EMPOINTER (fetch DLLASTOCB of CSB)) (RAID "Garbage Last OCB")) with (\LOLOC IOCB)))) (COND ((AND (EQ (fetch DLFIRSTOCB of CSB) 0) (EQ (fetch DLIOCBSTATUS of IOCB) \ES.PENDING)) (* ; "Separate check, as the hardware could have just gone idle since we last checked") (replace DLFIRSTOCB of CSB with (\LOLOC IOCB)) (\DEVICE.OUTPUT \DL.ENABLE.OUTPUT \DL.ETHEROUTPUTREG))) (replace DLLASTOCB of CSB with (\LOLOC IOCB))) (\DAYBREAK (\DoveEther.QueueOutput IOCB BUFFER LENGTH)) (\DOLPHIN (replace D0IOCBLENGTH of IOCB with (UNFOLD LENGTH BYTESPERWORD)) (replace D0NEXTIOCB of IOCB with 0) (replace D0RETRANSMISSIONMASK of IOCB with 0) (replace D0IOCBSTATUS of IOCB with \ES.PENDING) (replace D0IOCBBUFFER of IOCB with BUFFER) (COND ((NEQ (fetch D0FIRSTOCB of CSB) 0) (* ; "Hardware active, add to end of chain") (replace D0NEXTIOCB of (OR (EMPOINTER (fetch D0LASTOCB of CSB)) (RAID "Garbage Last OCB")) with (\LOLOC IOCB)))) (COND ((AND (EQ (fetch D0FIRSTOCB of CSB) 0) (EQ (fetch D0IOCBSTATUS of IOCB) \ES.PENDING)) (* ; "Separate check, as the hardware could have just gone idle since we last checked") (replace D0FIRSTOCB of CSB with (\LOLOC IOCB)) (\DEVICE.OUTPUT \D0.ENABLE.10MBOUTPUT (\D0.CONTROLLERBITS NDB \D0.OUTPUTSTATE)))) (replace D0LASTOCB of CSB with (\LOLOC IOCB))) (\NOMACHINETYPE)))) ) (\10MB.TURNOFFETHER (LAMBDA (NDB) (* ejs%: "26-Jul-85 22:47") (SELECTC \MACHINETYPE (\DANDELION (\DL.TURNOFFETHER)) (\DAYBREAK (\DoveEther.MakeSureOff)) (\DOLPHIN (\D0.TURNOFFETHER NDB)) (\NOMACHINETYPE))) ) (\10MB.TURNONETHER (LAMBDA (NDB SMASHSTATE NEWSTATE NSHOSTNUMBER ININTERRUPT OUTINTERRUPT) (* ejs%: "30-Oct-85 17:41") (* ;;; "Reset and activate ether associated with NDB. If SMASHSTATE is given, it is a CSB-length block into which state is saved for later restoration by passing as the NEWSTATE arg. If NEWSTATE is NIL, then the remaining non-NIL args give parameters for this activation: the host number for microcode to watch for, T meaning my own number; and interrupt masks for when a packet arrives or finishes transmitting") (* ;; "For Daybreak, SMASHSTATE and NEWSTATE must be NIL") (PROG ((CSB (fetch NDBCSB of NDB))) (SELECTC \MACHINETYPE (\DANDELION (\DL.TURNOFFETHER)) (\DAYBREAK (\DoveEther.MakeSureOff SMASHSTATE)) (\DOLPHIN (\D0.TURNOFFETHER NDB)) (\NOMACHINETYPE)) (COND ((AND SMASHSTATE (NEQ \MACHINETYPE \DAYBREAK)) (COND (CSB (\BLT SMASHSTATE CSB \CSB.LENGTH)) (T (* ; "Arcane way of indicating ether is off. May have to revisit") (\PUTBASE CSB 4 65535))))) (COND ((AND NEWSTATE (NEQ \MACHINETYPE \DAYBREAK)) (* ; "Smash old state into CSB") (COND ((EQ (\GETBASE NEWSTATE 4) 65535) (* ; "Leave ether off") (RETURN))) (\BLT CSB NEWSTATE \CSB.LENGTH)) (T (SELECTC \MACHINETYPE (\DANDELION (OR CSB (replace NDBCSB of NDB with (SETQ CSB (LOCF (fetch DLETHERNET of \IOPAGE))))) (COND (NEWSTATE (* ; "Smash old state into CSB") (* ; "I don't think you can get here! --ejs") (COND ((EQ (\GETBASE NEWSTATE 4) 65535) (* ; "Leave ether off") (RETURN))) (\BLT CSB NEWSTATE \CSB.LENGTH)) (T (* ; "Initialize the Ether CSB according to args. No buffers initially") (replace DLFIRSTOCB of CSB with 0) (replace DLFIRSTICB of CSB with 0) (AND NSHOSTNUMBER (COND ((EQ NSHOSTNUMBER T) (\BLT (LOCF (fetch DLLOCALHOST0 of CSB)) (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage)) \#WDS.NSHOSTNUMBER)) (T (\STORENSHOSTNUMBER (LOCF (fetch DLLOCALHOST0 of CSB)) NSHOSTNUMBER)))) (AND OUTINTERRUPT (replace DLOUTPUTMASK of CSB with OUTINTERRUPT)) (AND ININTERRUPT (replace DLINPUTMASK of CSB with ININTERRUPT)) (replace DLMISSEDPACKETS of CSB with 0) (replace DLLASTICB of CSB with 0) (replace DLLASTOCB of CSB with 0))) (\DEVICE.OUTPUT \DL.ENABLE.INPUT \DL.ETHERINPUTREG)) (\DAYBREAK (\DoveEther.TurnOn NSHOSTNUMBER NEWSTATE)) (\DOLPHIN (OR CSB (replace NDBCSB of NDB with (SETQ CSB (EMPOINTER (IPLUS 65280 (LLSH (fetch NDBTASK# of NDB) 4)))))) (* ; "Initialize the Ether CSB according to args. No buffers initially") (replace D0FIRSTOCB of CSB with 0) (replace D0FIRSTICB of CSB with 0) (AND NSHOSTNUMBER (COND ((EQ NSHOSTNUMBER T) (\BLT (LOCF (fetch D0LOCALHOST0 of CSB)) (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage)) \#WDS.NSHOSTNUMBER)) (T (\STORENSHOSTNUMBER (LOCF (fetch D0LOCALHOST0 of CSB)) NSHOSTNUMBER)))) (AND OUTINTERRUPT (replace D0OUTPUTMASK of CSB with OUTINTERRUPT)) (AND ININTERRUPT (replace D0INPUTMASK of CSB with ININTERRUPT)) (replace D0LASTICB of CSB with 0) (replace D0LASTOCB of CSB with 0) (\DEVICE.OUTPUT \D0.ENABLE.10MBINPUT (\D0.CONTROLLERBITS NDB \D0.INPUTSTATE))) (\NOMACHINETYPE)))) (SELECTC \MACHINETYPE (\DANDELION (\DEVICE.OUTPUT \DL.ENABLE.INPUT \DL.ETHERINPUTREG)) (\DAYBREAK) (\DOLPHIN (\DEVICE.OUTPUT \D0.ENABLE.10MBINPUT (\D0.CONTROLLERBITS NDB \D0.INPUTSTATE))) (\NOMACHINETYPE)) (RETURN NDB))) ) (\10MB.RESTART.ETHER (LAMBDA (NDB) (* ejs%: "13-Nov-85 13:36") (* ;;; "Kick the Ethernet receiver microcode (or Daybreak IOP) to restart the Ethernet receiver task. This function gets called when the 10MBDRIVER thinks the Ethernet has been accidentally disabled") (SELECTC \MACHINETYPE (\DANDELION (\DEVICE.OUTPUT \DL.ENABLE.INPUT \DL.ETHERINPUTREG)) (\DOLPHIN (\DEVICE.OUTPUT \D0.ENABLE.10MBINPUT (\D0.CONTROLLERBITS NDB \D0.INPUTSTATE))) (\DAYBREAK (LET ((EtherQueues (\ALLOCBLOCK (CONSTANT (FOLDHI (ITIMES 2 (MESASIZE Dove.QueueBlock)) WORDSPERCELL))))) (\BLT EtherQueues (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) (CONSTANT (ITIMES 2 (MESASIZE Dove.QueueBlock)))) (\DoveEther.TurnOn \MY.NSHOSTNUMBER EtherQueues))) NIL)) ) ) (* ; "Misc") (DEFINEQ (\NOMACHINETYPE (LAMBDA NIL (* bvm%: "24-JUL-82 17:47") (RAID "Operation not implemented on this machine"))) (\10MB.PRINT.ENCAPSULATION (LAMBDA (PACKET CALLER STREAM) (* ; "Edited 17-Dec-86 19:07 by bvm:") (FRESHLINE STREAM) (AND CALLER (printout STREAM CALLER ": ")) (PRIN1 "From host " STREAM) (PRINTNSHOSTNUMBER (fetch 10MBSOURCEHOST of PACKET) STREAM) (PRIN1 " to " STREAM) (PRINTNSHOSTNUMBER (fetch 10MBDESTHOST of PACKET) STREAM) (TERPRI STREAM) PACKET) ) ) (DEFINEQ (IOCBQLENGTH (LAMBDA (FIRSTIOCB) (* bvm%: " 2-MAR-83 17:52") (OR FIRSTIOCB (SETQ FIRSTIOCB \IOCBFREELIST)) (while FIRSTIOCB sum (PROGN (SETQ FIRSTIOCB (EMPOINTER (fetch D0NEXTIOCB of FIRSTIOCB))) 1))) ) ) (RPAQ? \10MB.GETGARBAGE NIL) (RPAQ? \10MB.COLLECTSTATS NIL) (* ; "PUP address resolution") (DEFINEQ (\HANDLE.RAW.3TO10 [LAMBDA (PACKET TYPE) (* ; "Edited 26-Feb-91 11:48 by jds") (* ;; "Called when a TRANSLATION packet is received. This is either a packet requesting a 10-to-3 translation, in which case we respond if it is asking about us; or it is a response to a request of ours, in which case we store the info in the cache") (COND ((EQ TYPE \EPT.3TO10) (PROG ((NDB (fetch EPNETWORK of PACKET)) ADDR) (AND XIPTRACEFLG (\MAYBEPRINTPACKET PACKET 'GET)) (AND NDB (SELECTC (fetch TRANSOPERATION of PACKET) (\TRANS.OP.REQUEST (COND ([AND (EQ (fetch TRANSPUPHOST of PACKET) (fetch NDBPUPHOST# of NDB)) (>= (fetch 10MBLENGTH of PACKET) (+ \10MBENCAPSULATION.WORDS (FOLDHI \TRANS.DATALENGTH BYTESPERWORD] (* ;  "It's for us, and it's big enough") (\BLT [LOCF (fetch NSHNM0 of (SETQ ADDR (create NSADDRESS] (LOCF (fetch BASETRANSSENDERNSHOST of PACKET)) 3) (\NOTE.3TO10 ADDR (fetch TRANSSENDERPUPHOST of PACKET ) NDB) (* ; "Add sender's address to cache") (\BLT (LOCF (fetch BASETRANSNSHOST of PACKET)) (LOCF (fetch NSHNM0 of \MY.NSADDRESS)) 3) (* ; "Add in the information he wants") (replace TRANSOPERATION of PACKET with \TRANS.OP.RESPONSE ) (ENCAPSULATE.ETHERPACKET NDB PACKET ADDR \TRANS.DATALENGTH \10MBTYPE.3TO10) (* ; "Send back the response") (AND XIPTRACEFLG (NOT (MEMB 'TRANS XIPIGNORETYPES)) (PRINT3TO10 PACKET 'PUT XIPTRACEFILE)) (replace EPREQUEUE of PACKET with 'FREE) (TRANSMIT.ETHERPACKET NDB PACKET) (RETURN)))) (\TRANS.OP.RESPONSE (* ;  "Add the information to the cache") (\BLT [LOCF (fetch NSHNM0 of (SETQ ADDR (create NSADDRESS ] (LOCF (fetch BASETRANSNSHOST of PACKET)) 3) (\NOTE.3TO10 ADDR (fetch TRANSPUPHOST of PACKET) NDB)) NIL)) (\RELEASE.ETHERPACKET PACKET)) T]) (\TRANSLATE.3TO10 (LAMBDA (PUPHOSTNUMBER NDB) (* ; "Edited 15-Jan-88 00:49 by bvm") (* ;; "Translate from an PUPHOSTNUMBER to a NSHOSTNUMBER for the indicated network. If we don't have the translation, we initiate a probe for it and return NIL") (OR (CADR (ASSOC PUPHOSTNUMBER (ffetch NDBTRANSLATIONS of (\DTEST NDB (QUOTE NDB))))) (PROG ((MYPUPHOSTNUMBER (ffetch NDBPUPHOST# of NDB)) PACKET) (COND ((EQ MYPUPHOSTNUMBER 0) (* ; "We don't know who we are yet") (RETURN))) (SETQ PACKET (\ALLOCATE.ETHERPACKET)) (replace EPTYPE of PACKET with \EPT.3TO10) (freplace TRANSOPERATION of PACKET with \TRANS.OP.REQUEST) (freplace TRANSPUPHOST of PACKET with PUPHOSTNUMBER) (\BLT (LOCF (FETCH BASETRANSSENDERNSHOST of PACKET)) (LOCF (FETCH NSHNM0 OF \MY.NSADDRESS)) 3) (freplace TRANSSENDERPUPHOST of PACKET with MYPUPHOSTNUMBER) (ENCAPSULATE.ETHERPACKET NDB PACKET BROADCASTNSHOSTNUMBER \TRANS.DATALENGTH \10MBTYPE.3TO10) (AND XIPTRACEFLG (\MAYBEPRINTPACKET PACKET (QUOTE PUT))) (freplace EPREQUEUE of PACKET with (QUOTE FREE)) (TRANSMIT.ETHERPACKET NDB PACKET) (* ; "We didn't find out this time, but we will later on") (RETURN)))) ) (PRINT3TO10 (LAMBDA (EPKT CALLER FILE PRE.NOTE DOFILTER) (* bvm%: "14-Feb-85 21:21") (COND ((OR (NOT DOFILTER) (NOT (MEMB (QUOTE TRANS) XIPIGNORETYPES))) (OR FILE (SETQ FILE XIPTRACEFILE)) (FRESHLINE FILE) (COND (PRE.NOTE (PRIN1 PRE.NOTE FILE))) (SELECTC (fetch TRANSOPERATION of EPKT) (\TRANS.OP.REQUEST (printout FILE CALLER " 3:10 trans request for " (fetch TRANSPUPHOST of EPKT) " from " (fetch TRANSSENDERPUPHOST of EPKT) " = ") (PRINTNSHOSTNUMBER (fetch TRANSSENDERNSHOST of EPKT) FILE)) (\TRANS.OP.RESPONSE (printout FILE CALLER " 3:10 trans response: " (fetch TRANSPUPHOST of EPKT) " = ") (PRINTNSHOSTNUMBER (fetch TRANSNSHOST of EPKT) FILE)) (printout FILE CALLER " unknown 10 to 3 translation operation " (fetch TRANSOPERATION of EPKT))) (TERPRI FILE)))) ) (\NOTE.3TO10 (LAMBDA (NSADDR PUPHOST NDB) (* ; "Edited 15-Jan-88 00:47 by bvm") (* ;; "Update cache to include this pairing") (PROG ((A (ASSOC PUPHOST (ffetch NDBTRANSLATIONS of (\DTEST NDB (QUOTE NDB)))))) (COND (A (RPLACA (CDR A) NSADDR)) (T (push (ffetch NDBTRANSLATIONS of NDB) (LIST PUPHOST NSADDR (CLOCK 0))))))) ) ) (RPAQ? \10MBTYPE.PUP 512) (RPAQ? \10MBTYPE.3TO10 513) (RPAQ? \10MBTYPE.TRANSLATIONS ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \10MBTYPE.3TO10 \10MBTYPE.PUP \10MBTYPE.TRANSLATIONS) ) (DECLARE%: EVAL@COMPILE (RPAQQ \EPT.3TO10 513) (CONSTANTS \EPT.3TO10) ) (ADDTOVAR \PACKET.PRINTERS (513 . PRINT3TO10)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SOURCE) 10MBDECLS DOVEDECLS DOVEETHERDECLS LLNSDECLS) (FILESLOAD (LOADCOMP) LLETHER) ) (PUTPROPS 10MBDRIVER COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2804 8844 (\10MBGETPACKET 2814 . 3973) (\10MBSENDPACKET 3975 . 6616) (\10MBENCAPSULATE 6618 . 7806) (\10MB.BROADCASTP 7808 . 7968) (\10MBWATCHER 7970 . 8842)) (8886 17927 (\10MB.STARTDRIVER 8896 . 10848) (\10MB.CREATENDB 10850 . 12084) (\10MB.INPUT.INTERRUPT 12086 . 16304) ( \10MB.OUTPUT.INTERRUPT 16306 . 17736) (\10MB.NOTESTAT 17738 . 17925)) (18324 22148 (\10MB.LOADINPUTQ 18334 . 18800) (\RELEASE.IOCB 18802 . 19316) (\GET.IOCB 19318 . 20094) (\INIT.ETHER.BUFFER.POOL 20096 . 22146)) (22219 32781 (\10MB.GETPACKETLENGTH 22229 . 22504) (\10MB.GETPACKETSTATUS 22506 . 24166) ( \QUEUE.INPUT.IOCB 24168 . 26493) (\QUEUE.OUTPUT.IOCB 26495 . 28567) (\10MB.TURNOFFETHER 28569 . 28780) (\10MB.TURNONETHER 28782 . 32027) (\10MB.RESTART.ETHER 32029 . 32779)) (32803 33285 (\NOMACHINETYPE 32813 . 32925) (\10MB.PRINT.ENCAPSULATION 32927 . 33283)) (33286 33504 (IOCBQLENGTH 33296 . 33502)) ( 33614 39608 (\HANDLE.RAW.3TO10 33624 . 37376) (\TRANSLATE.3TO10 37378 . 38508) (PRINT3TO10 38510 . 39280) (\NOTE.3TO10 39282 . 39606))))) STOP \ No newline at end of file diff --git a/sources/AARITH b/sources/AARITH new file mode 100644 index 00000000..8b1007a2 --- /dev/null +++ b/sources/AARITH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-May-90 11:41:16" |{DSK}local>lde>lispcore>sources>AARITH.;2| 32769 |changes| |to:| (VARS AARITHCOMS) |previous| |date:| "22-Oct-86 19:52:52" |{DSK}local>lde>lispcore>sources>AARITH.;1|) ; Copyright (c) 1981, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT AARITHCOMS) (RPAQQ AARITHCOMS ((FNS LOG ANTILOG SIN ARCSIN COS ARCCOS TAN ARCTAN ARCTAN2 ATAN FEXPT \\SIN-FLOAT \\TAN-FLOAT \\SIN.OLD \\COS.OLD \\TAN.OLD) (VARS \\ANTILOGARRAY \\ANTILOGCARRAY \\ARCTANARRAY \\LOGARRAY \\SIN-PPOLY \\SIN-QPOLY \\TAN-PPOLY \\TAN-QPOLY \\SINARRAY1 \\SINARRAY2 \\TANARRAY \\ATANARRAY) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS (* |now| |obsolete| - |use| POLYEVAL |instead|) HORNERIFY FLEQ FGEQ) (FILES (LOADCOMP) LLFLOAT) (CONSTANTS (\\SIN-EPSILON 2.441406E-4) (\\TAN-EPSILON 2.441406E-4) (\\EXPONENT.BIAS 127) (2PI 6.283185) (CL:PI 3.141593) (-PI -3.141593) (-PI/2 -1.570796) (PI/2 1.570796) (4/PI 1.273239) (3PI/2 4.712389) (PI/4 0.7853982) (-PI/4 -0.7853982) (PI/180 0.01745329) (180/PI 57.29578) (-PI/2 -1.570796) (LN2 0.6931472) (|2^-126| 1.17549407E-38))))) (DEFINEQ (LOG (LAMBDA (X) (* |hdj| "11-Feb-85 17:14") (DECLARE (GLOBALVARS \\LOGARRAY)) (PROG ((SX (OR (FLOATP X) (FLOAT X))) (EXP 0) SSUM) (|if| (NOT (FGREATERP SX 0.0)) |then| (ERROR "LOG OF NON-POSITIVE NUMBER:" X)) (|if| (EQ 0 (|fetch| (FLOATP EXPONENT) |of| SX)) |then| (* * |Don't| |really| |need| |to| |consider| |unnormalized| |numbers,| |but|  |there| |is| \a |bug| |in| |Interlisp-D's| |floating| |point| |arithmetic| |as|  |of| |3/17/84| |regarding| |zero| |exponent.|) (SETQ EXP (|while| (FLESSP SX |2^-126|) |count| (SETQ SX (FTIMES SX 2.0))))) (|if| (EQ SX X) |then| (* |Need| |smashable| |copy|) (SETQ SX (\\FLOAT.BOX X))) (SETQ EXP (IDIFFERENCE (IDIFFERENCE (|fetch| (FLOATP EXPONENT) |of| SX) \\EXPONENT.BIAS) EXP)) (* * |Depends| |on| |Interlisp-D's| |use| |of| IEEE 32 |bit| |float| |format|  |internally| |and| |smashes| |the| |number| |to| |the| |range| 1 |to| 2 |and|  |saves| |the| |exponent|) (|replace| (FLOATP EXPONENT) |of| SX |with| \\EXPONENT.BIAS) (SETQ SX (FDIFFERENCE SX 1.0)) (SETQ SSUM (POLYEVAL SX \\LOGARRAY 8)) (* * |Polynomial| |from| |Handbook| |of| |Mathematical| |Functions|  (|edited| |by| |Aramowitz|) |page| 69 |accuracy| 28 |bits|  (|of| |the| 24 |available!|)) (RETURN (FPLUS SSUM (FTIMES LN2 EXP)))))) (ANTILOG (LAMBDA (X) (* JAS "19-Jul-85 11:55") (DECLARE (GLOBALVARS \\ANTILOGARRAY \\ANTILOGCARRAY)) (PROG ((XX (FLOAT X)) FRAC IP SSUM YY) (DECLARE (TYPE FLOATING XX FRAC SSUM YY)) (SETQ YY (FABS XX)) (COND ((GREATERP YY 88.7) (COND ((LESSP XX 0) (RETURN 0.0)) (T (ERROR "FLOATING OVERFLOW" X))))) (SETQ FRAC (FDIFFERENCE YY (FTIMES (CONSTANT (LOG 2)) (SETQ IP (FIX (FTIMES YY (CONSTANT (FQUOTIENT 1.0 (LOG 2))))))))) (SETQ SSUM (POLYEVAL FRAC \\ANTILOGARRAY 7)) (* * |Polynomial| |from| |Handbook| |of| |Mathematical| |Functions|  (|edited| |by| |Aramowitz|) |page| 71 |accuracy| 32 |bits| |of| |the| 24  |available!|) (* SSUM |is| |in| |the| |range| .5  |to| 2 (|and| |series| |produced| .5  |to| 1)) (SETQ SSUM (QUOTIENT SSUM (ELT \\ANTILOGCARRAY (IPLUS IP 127)))) (RETURN (|if| (FGREATERP XX 0.0) |then| (FQUOTIENT 1.0 SSUM) |else| SSUM))))) (SIN (LAMBDA (X RADIANSFLG) (* FS "15-Oct-86 19:56") (PROG ((XX X)) (DECLARE (TYPE FLOATP XX)) (|if| RADIANSFLG |then| (RETURN (\\SIN-FLOAT XX)) |else| (RETURN (\\SIN-FLOAT (FTIMES PI/180 XX))))))) (ARCSIN (LAMBDA (X RADIANSFLG) (* |JonL| "30-Mar-84 23:59") (PROG ((XX (OR (FLOATP X) (FLOAT X))) SSUM NEGP REDUCED Z Q1 Q2) (|if| (OR (FLESSP XX -1.0) (FGREATERP XX 1.0)) |then| (ERROR "ARCSIN: arg not in range" XX) |elseif| (FLESSP XX 0.0) |then| (SETQ NEGP T) (SETQ XX (FDIFFERENCE 0.0 XX))) (|if| (FGREATERP XX .5) |then| (SETQ REDUCED T) (SETQ XX (SQRT (FTIMES .5 (FDIFFERENCE 1.0 XX))))) (* |Special| |case| |for| |small| |magnitude| |arguments,| |from| |Computer|  |Evaluation| |of| |Mathematical| |Funcitons|  (|by| C. T. |Fike|) |page| 57) (SETQ Z (FTIMES XX XX)) (SETQ Q1 (FTIMES .5315066 Z)) (SETQ Q2 (FTIMES (SETQ Q2 (FDIFFERENCE Q1 .08982446)) Q2)) (SETQ Q2 (FPLUS .3697723 (FTIMES Q2 (FPLUS .4918762 Q2)))) (SETQ SSUM (FTIMES XX (FPLUS .7533057 (FTIMES Q2 (FPLUS .6599526 Q1))))) (|if| REDUCED |then| (SETQ SSUM (FDIFFERENCE PI/2 (FTIMES 2.0 SSUM)))) (|if| NEGP |then| (SETQ SSUM (FDIFFERENCE 0.0 SSUM))) (RETURN (|if| RADIANSFLG |then| SSUM |else| (FTIMES SSUM 180/PI)))))) (COS (LAMBDA (X RADIANSFLG) (* FS "15-Oct-86 19:58") (PROG ((XX X)) (DECLARE (TYPE FLOATP XX)) (|if| RADIANSFLG |then| (RETURN (\\SIN-FLOAT XX T)) |else| (RETURN (\\SIN-FLOAT (FTIMES PI/180 XX) T)))))) (ARCCOS (LAMBDA (X RADIANSFLG) (* |JonL| "30-Mar-84 20:21") (PROG ((XX (OR (FLOATP X) (FLOAT X)))) (RETURN (FDIFFERENCE (|if| RADIANSFLG |then| PI/2 |else| 90.0) (ARCSIN XX RADIANSFLG)))))) (TAN (LAMBDA (X RADIANSFLG) (* FS "17-Oct-86 18:20") (PROG ((XX X)) (DECLARE (TYPE FLOATP XX)) (|if| RADIANSFLG |then| (RETURN (\\TAN-FLOAT XX)) |else| (RETURN (\\TAN-FLOAT (FTIMES PI/180 XX))))))) (ARCTAN (LAMBDA (X RADIANSFLG) (* |hdj| "11-Feb-85 17:24") (DECLARE (GLOBALVARS \\ARCTANARRAY)) (PROG ((XX (FPLUS X 0.0)) (SSUM .002866226) X2 FLIPPED) (* POLYNOMIAL FROM HANDBOOK OF MATHEMATICAL FUNCTIONS  (EDITED BY ARAMOWITZ) PAGE 81 ACCURACY 28 BITS) (|if| (OR (FLESSP XX -1.0) (FGREATERP XX 1.0)) |then| (SETQ FLIPPED (|if| (FLESSP XX 0.0) |then| -PI/2 |else| PI/2)) (SETQ XX (FQUOTIENT 1.0 XX))) (SETQ X2 (FTIMES XX XX)) (SETQ SSUM (FTIMES XX (POLYEVAL X2 \\ARCTANARRAY 8))) (|if| FLIPPED |then| (SETQ SSUM (FDIFFERENCE FLIPPED SSUM))) (RETURN (|if| RADIANSFLG |then| SSUM |else| (FTIMES SSUM 180/PI)))))) (ARCTAN2 (LAMBDA (Y X RADIANSFLG) (* |JonL| "17-Mar-84 21:41") (OR (FLOATP Y) (SETQ Y (FLOAT Y))) (OR (FLOATP X) (SETQ X (FLOAT X))) (PROG ((ANGLE (ARCTAN (ABS (FQUOTIENT Y X)) T))) (SETQ ANGLE (|if| (FLESSP X 0.0) |then| (|if| (FLESSP Y 0.0) |then| (* |Quadrant| 3) (FPLUS -PI ANGLE) |else| (* |Quadrant| 2) (FDIFFERENCE CL:PI ANGLE)) |else| (|if| (FLESSP Y 0.0) |then| (* |Quadrant| 4) (FDIFFERENCE 0.0 ANGLE) |else| (* |Quadrant| 1) ANGLE))) (RETURN (|if| RADIANSFLG |then| ANGLE |else| (FTIMES ANGLE 180/PI)))))) (ATAN (LAMBDA (Y X RADIANSFLG) (* |hdj| "11-Feb-85 17:26") (* |version| |of| |arctan| |which| |returns| |value| |in| |radians| |between| 0  |and| 2 PI. |Copied| |from| |the| PDP-10 |MacLisp| |machine| |language| |code.|) (OR (FLOATP Y) (SETQ Y (FLOAT Y))) (OR (FLOATP X) (SETQ X (FLOAT X))) (DECLARE (GLOBALVARS \\ATANARRAY)) (PROG ((Y.NEGP (FLESSP Y 0.0)) (X.NEGP (FLESSP X 0.0)) ATAN.Y ATAN.X T. TT D R (ANS -.004054058)) (SETQ ATAN.Y (|if| Y.NEGP |then| (FDIFFERENCE 0.0 Y) |else| Y)) (SETQ ATAN.X (|if| X.NEGP |then| (FDIFFERENCE 0.0 X) |else| X)) (SETQ T. (FQUOTIENT (FDIFFERENCE ATAN.Y ATAN.X) (FPLUS ATAN.Y ATAN.X))) (SETQ R (FTIMES T. T.)) (SETQ D (FTIMES T. (POLYEVAL R \\ATANARRAY 7))) (SETQ TT (|if| (FLESSP D 0.0) |then| (FDIFFERENCE 0.0 D) |else| D)) (SETQ D (|if| (OR (FGEQ TT .7855) (FLESSP TT .7853)) |then| (FPLUS D .7853982) |elseif| (FLESSP D 0.0) |then| (* |When| |the| |rational| |approximation| |is| |not| |very| |good,| |we| |can|  |patch| |it| |up| |by| |using| Y/X |and| |an| |approximation| |for|  (ARCTAN Y/X)) (FQUOTIENT ATAN.Y ATAN.X) |else| (* |Corresponds| |to| |label| ATAN.2) (FPLUS PI/2 (FQUOTIENT (FDIFFERENCE 0.0 ATAN.X) ATAN.Y)))) ATAN.4 (* W\e |now| |have| \a |quadrant-1| |result;|  |patch| |it| |up| |to| |get| |other| |quadrant| |values.|) (SETQ D (|if| X.NEGP |then| (|if| Y.NEGP |then| (* |Quadrant| 3) (FPLUS CL:PI D) |else| (* |Quadrant| 2) (FDIFFERENCE CL:PI D)) |else| (|if| Y.NEGP |then| (* |Quadrant| 4) (FDIFFERENCE 2PI D) |else| (* |Quadrant| 1) D))) (RETURN (|if| RADIANSFLG |then| D |else| (FTIMES D 180/PI)))))) (FEXPT (LAMBDA (A N) (* JAS "29-Jul-85 15:13") (* I\n |addition| |to| |coercing| |the| |args| |to| |floating-point,| |this|  |handles| |the| |case| |of| |negative| |values| |for| N) (COND ((EQP A 0.0) 0.0) (T (ANTILOG (FTIMES (OR (FLOATP N) (FLOAT N)) (LOG (OR (FLOATP A) (FLOAT A))))))))) (\\SIN-FLOAT (LAMBDA (X COS-FLAG) (* FS "15-Oct-86 19:52") (* * SIN |of| \a FLOAT X |calculated| |via| SIN 3374 |rational| |approximation|  |of| |Harris| |et| |al.| *) (PROG (R SIGN R2 ANSWER) (DECLARE (GLOBALVARS \\SIN-PPOLY \\SIN-QPOLY) (TYPE FLOATP X R SIGN R2 ANSWER)) (* * I\f |this| |function| |called| |by| COS |then| |use|  (COS X) = (SIN (|minus| PI/2 X)) = (SIN (+ PI/2 X)) |Case| |out| |on| |sign|  |of| X |for| |improved| |numerical| |stability.|  |Avoids| |unnecessary| |rounding| |and| |promotes| |symmetric| |properties.|  (COS X) = (COS (|minus| X)) |is| |guaranteed| |by| |this| |strategy.|  *) (SETQ R (COND ((NOT COS-FLAG) X) ((> X 0) (- PI/2 X)) (T (+ PI/2 X)))) (* * |First| |range| |reduce| |to| (0 |infinity|) |by|  (SIN (|minus| X)) = (|minus| (SIN X)) |This| |strategy| |guarantees|  (SIN (|minus| X)) = (|minus| (SIN X)) *) (COND ((< R 0) (SETQ SIGN -1.0) (SETQ R (- R))) (T (SETQ SIGN 1.0))) (* * |Next| |range| |reduce| |to| |interval|  (0 2PI) |by| (SIN X) = (SIN (MOD X 2PI)) . *) (SETQ R (CL:REM R 2PI)) (* * |Next| |range| |reduce| |to| |interval|  (0 CL:PI) |by| (SIN (+ X CL:PI)) = (|minus|  (SIN X)) *) (COND ((> R CL:PI) (SETQ SIGN (- SIGN)) (SETQ R (- R CL:PI)))) (* * |Next| |range| |reduce| |to| |interval|  (0 PI/2) |by| (SIN (+ X PI/2)) = (SIN (|minus| PI/2 X)) *) (COND ((> R PI/2) (SETQ R (- CL:PI R)))) (COND ((< R \\SIN-EPSILON) (* * I\f R |is| |in| |the| |interval| (0 %SIN-EPSILON) |then|  (SIN R) = R |to| |the| |precision| |that| |we| |can| |offer.|  |Return| R |because| (1) |it| |is| |desirable| |that|  (SIN R) = R |exactly| |for| |small| R |and|  (2) |microcode| POLYEVAL |will| |underflow| |on| |sufficiently| |small|  |positive| R. *) (RETURN (FTIMES SIGN R)))) (* * |Now| |use| SIN 3374 |rational| |approximation| |of| |Harris| |et| |al.|  |which| |works| |on| |interval| (0 %PI/2) *) (SETQ R2 (FTIMES R R)) (SETQ ANSWER (FTIMES SIGN R (/ (POLYEVAL R2 \\SIN-PPOLY 5) (POLYEVAL R2 \\SIN-QPOLY 5)))) (RETURN ANSWER)))) (\\TAN-FLOAT (LAMBDA (X) (* FS "17-Oct-86 20:29") (* * TAN |of| \a FLOAT X |calculated| |via| TAN 4288 |rational| |approximation|  |of| |Harris| |et| |al.| *) (PROG (R SIGN RECIPFLG R2 ANSWER) (DECLARE (GLOBALVARS \\TAN-PPOLY \\TAN-QPOLY) (TYPE FLOATP X R R2 ANSWER)) (SETQ R X) (* * |First| |range| |reduce| |to| (0 |infinity|) |by|  (TAN (|minus| X)) = (|minus| (TAN X)) *) (COND ((< R 0) (SETQ SIGN -1.0) (SETQ R (- R))) (T (SETQ SIGN 1.0))) (* * |Next| |range| |reduce| |to| (0 CL:PI) *) (SETQ R (CL:REM R CL:PI)) (* * |Next,| |range| |reduce| |to| (-PI/4 PI/4) |using|  (TAN X) = (TAN (|minus| X CL:PI)) |to| |get| |into| |interval|  (-PI/2 PI/2) |and| |then| (TAN X) = (/ (TAN  (|minus| PI/2 X))) |to| |get| |into| |interval|  (-PI/4 PI/4) *) (COND ((> R PI/2) (SETQ R (- R CL:PI)) (COND ((< R -PI/4) (SETQ RECIPFLG T) (SETQ R (- -PI/2 R))))) (T (COND ((> R PI/4) (SETQ RECIPFLG T) (SETQ R (- PI/2 R)))))) (COND ((< (ABS R) \\TAN-EPSILON) (* * I\f R |is| |in| |the| |interval| (0 %TAN-EPSILON) |then|  (TAN R) = R |to| |the| |precision| |that| |we| |can| |offer.|  |Return| R |because| (1) |it| |is| |desirable| |that|  (TAN R) = R |exactly| |for| |small| R |and|  (2) |microcode| POLYEVAL |will| |underflow| |on| |sufficiently| |small|  |positive| R. *) (SETQ ANSWER (FTIMES SIGN R)) (COND (RECIPFLG (SETQ ANSWER (/ ANSWER)))) (RETURN ANSWER))) (* * |Now| |use| TAN 4288 |rational| |approximation| |of| |Harris| |et| |al.|  |which| |works| |on| |interval| (0 PI/4) *) (SETQ R2 (FTIMES R R)) (SETQ ANSWER (FTIMES SIGN R (/ (POLYEVAL R2 \\TAN-PPOLY 4) (POLYEVAL R2 \\TAN-QPOLY 5)))) (COND (RECIPFLG (SETQ ANSWER (/ ANSWER)))) (RETURN ANSWER)))) (\\SIN.OLD (LAMBDA (X RADIANSFLG) (* FS "15-Oct-86 19:35") (DECLARE (GLOBALVARS \\SINARRAY1 \\SINARRAY2)) (* * |Old| |version,| |claimed| |less| |accurate| -FS) (PROG ((XX X) X2) (DECLARE (TYPE FLOATP XX X2)) (|if| RADIANSFLG |then| (|if| (OR (FGEQ XX 2PI) (FLEQ XX (CONSTANT (MINUS 2PI)))) |then| (SETQ XX (FREMAINDER XX 2PI))) |else| (|if| (OR (FGEQ XX 360.0) (FLEQ XX -360.0)) |then| (SETQ XX (FREMAINDER XX 360.0))) (SETQ XX (FTIMES PI/180 XX))) (|if| (FLESSP XX -PI/2) |then| (SETQ XX (FPLUS XX 2PI))) (|if| (FGREATERP XX 3PI/2) |then| (SETQ XX (FDIFFERENCE XX 2PI)) |elseif| (FGREATERP XX PI/2) |then| (SETQ XX (FDIFFERENCE CL:PI XX))) (* |Range-reduce| |to| |between| 0  |and| PI/2) (RETURN (|if| (FGEQ XX PI/4) |then| (SETQ X2 (FTIMES XX XX)) (* |Polynomial| |from| |Handbook| |of| |Mathematical| |Functions|  (|edited| |by| |Aramowitz|) |page| 76 |accuracy| 26 |bits|  (|of| |the| 24 |available!|)) (SETQ X2 (FTIMES XX (POLYEVAL X2 \\SINARRAY1 5))) |else| (SETQ XX (FTIMES 4/PI XX)) (SETQ X2 (FTIMES XX XX)) (* |Chebyshev| |approximation| |from| |Computer| |Evaluation| |of|  |Mathematical| |Functions| (|by| C. T. |Fike|) |Page| 117) (SETQ X2 (FTIMES XX (POLYEVAL X2 \\SINARRAY2 3)))))))) (\\COS.OLD (LAMBDA (X RADIANSFLG) (* FS "15-Oct-86 19:57") (PROGN (DECLARE (GLOBALVARS \\SINARRAY1 \\SINARRAY2)) (PROG ((XX X) X2) (DECLARE (TYPE FLOATP XX X2)) (|if| RADIANSFLG |then| (|if| (OR (FGEQ XX 2PI) (FLEQ XX (CONSTANT (MINUS 2PI)))) |then| (SETQ XX (FREMAINDER XX 2PI))) |else| (|if| (OR (FGEQ XX 360.0) (FLEQ XX -360.0)) |then| (SETQ XX (FREMAINDER XX 360.0))) (SETQ XX (FTIMES PI/180 XX))) (SETQ XX (FDIFFERENCE PI/2 XX)) (|if| (FLESSP XX -PI/2) |then| (SETQ XX (FPLUS XX 2PI))) (|if| (FGREATERP XX 3PI/2) |then| (SETQ XX (FDIFFERENCE XX 2PI)) |elseif| (FGREATERP XX PI/2) |then| (SETQ XX (FDIFFERENCE CL:PI XX)))(* |Range-reduce| |to| |between| 0  |and| PI/2) (RETURN (|if| (FGEQ XX PI/4) |then| (SETQ X2 (FTIMES XX XX)) (* |Polynomial| |from| |Handbook| |of| |Mathematical| |Functions|  (|edited| |by| |Aramowitz|) |page| 76 |accuracy| 26 |bits|  (|of| |the| 24 |available!|)) (SETQ X2 (FTIMES XX (POLYEVAL X2 \\SINARRAY1 5))) |else| (SETQ XX (FTIMES 4/PI XX)) (SETQ X2 (FTIMES XX XX)) (* |Chebyshev| |approximation| |from| |Computer| |Evaluation| |of|  |Mathematical| |Functions| (|by| C. T. |Fike|) |Page| 117) (SETQ X2 (FTIMES XX (POLYEVAL X2 \\SINARRAY2 3))))))))) (\\TAN.OLD (LAMBDA (X RADIANSFLG) (* FS "17-Oct-86 18:19") (DECLARE (GLOBALVARS \\TANARRAY)) (PROG ((XX X) FLIPPED Y X2) (DECLARE (TYPE FLOATP XX Y X2)) (SETQ XX (|if| RADIANSFLG |then| (FREMAINDER XX CL:PI) |else| (FTIMES (FREMAINDER XX 180.0) PI/180))) (DECLARE (TYPE FLOATP XX Y X2)) (* |First,| |normalize| |to| |between|  -PI |and| CL:PI) (|if| (FGREATERP XX PI/2) |then| (SETQ XX (FDIFFERENCE XX CL:PI)) |elseif| (FLESSP XX -PI/2) |then| (SETQ XX (FPLUS XX CL:PI))) (* |Then| |normalize| |to| |between|  -PI/2 |and| PI/2) (SETQ Y (|if| (FGREATERP XX PI/4) |then| (SETQ FLIPPED T) (FDIFFERENCE PI/2 XX) |elseif| (FLESSP XX -PI/4) |then| (SETQ FLIPPED T) (FDIFFERENCE -PI/2 XX) |else| XX)) (SETQ X2 (FTIMES Y Y)) (SETQ Y (FTIMES Y (POLYEVAL X2 \\TANARRAY 6))) (* POLYNOMIAL APPROXIMATION FROM HANDBOOK OF MATHEMATICAL FUNCTIONS  (EDITED BY ABRAMOWITZ) PAGE 76 GOOD TO ALMOST 26 BITS) (RETURN (|if| FLIPPED |then| (SETQ Y (FQUOTIENT 1.0 Y)) |else| Y))))) ) (RPAQ \\ANTILOGARRAY (READARRAY-FROM-LIST 8 (QUOTE FLOATP) 0 (QUOTE (-1.413161E-4 0.001329882 -0.00830136 0.04165735 -0.1666653 0.4999999 -1.0 1.0 NIL)))) (RPAQ \\ANTILOGCARRAY (READARRAY-FROM-LIST 255 (QUOTE FLOATP) 0 (QUOTE (5.87747456E-39 1.17549407E-38 2.350992E-38 4.70198E-38 9.40396E-38 1.880791E-37 3.761582E-37 7.523175E-37 1.504633E-36 3.009266E-36 6.018532E-36 1.203706E-35 2.407413E-35 4.814832E-35 9.629655E-35 1.92593E-34 3.85186E-34 7.70372E-34 1.540746E-33 3.081488E-33 6.162979E-33 1.232595E-32 2.465191E-32 4.930382E-32 9.860764E-32 1.972152E-31 3.944305E-31 7.888613E-31 1.577722E-30 3.155448E-30 6.310891E-30 1.262178E-29 2.524355E-29 5.04871E-29 1.009743E-28 2.019484E-28 4.038968E-28 8.077936E-28 1.615587E-27 3.231174E-27 6.462349E-27 1.29247E-26 2.58494E-26 5.169879E-26 1.033976E-25 2.067952E-25 4.135903E-25 8.271806E-25 1.654361E-24 3.308724E-24 6.617445E-24 1.323489E-23 2.646978E-23 5.293956E-23 1.058791E-22 2.117583E-22 4.235165E-22 8.47033E-22 1.694066E-21 3.388132E-21 6.776264E-21 1.355253E-20 2.710506E-20 5.421011E-20 1.084202E-19 2.168405E-19 4.336809E-19 8.67363E-19 1.734724E-18 3.469447E-18 6.938904E-18 1.387779E-17 2.775558E-17 5.551115E-17 1.110223E-16 2.220446E-16 4.440892E-16 8.881784E-16 1.776359E-15 3.552714E-15 7.105429E-15 1.421086E-14 2.842171E-14 5.684342E-14 1.136868E-13 2.273737E-13 4.547474E-13 9.094948E-13 1.818989E-12 3.637979E-12 7.275959E-12 1.455192E-11 2.910383E-11 5.820766E-11 1.164153E-10 2.328307E-10 4.656613E-10 9.31324E-10 1.862645E-9 3.72529E-9 7.450583E-9 1.490116E-8 2.980232E-8 5.960465E-8 1.192093E-7 2.384186E-7 4.768372E-7 9.536744E-7 1.907349E-6 3.814697E-6 7.629397E-6 1.525879E-5 3.051759E-5 6.103516E-5 1.220703E-4 2.441406E-4 4.882813E-4 9.765626E-4 0.001953125 0.00390625 0.0078125 0.015625 0.03125 0.0625 0.125 0.25 0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0 2048.0 4096.0 8192.0 16384.0 32768.0 65536.0 131072.0 262144.0 524288.0 1048576.0 2097152.0 4194304.0 8388608.0 1.677722E+7 3.355443E+7 6.710887E+7 1.342177E+8 2.684355E+8 5.368709E+8 1.073742E+9 2.147484E+9 4.294968E+9 8.589936E+9 1.717987E+10 3.435974E+10 6.871948E+10 1.37439E+11 2.748779E+11 5.497558E+11 1.099512E+12 2.199023E+12 4.398047E+12 8.796094E+12 1.759219E+13 3.518437E+13 7.036876E+13 1.407375E+14 2.81475E+14 5.6295E+14 1.1259E+15 2.2518E+15 4.5036E+15 9.0072E+15 1.80144E+16 3.60288E+16 7.205761E+16 1.441152E+17 2.882304E+17 5.764609E+17 1.152922E+18 2.305843E+18 4.611686E+18 9.223372E+18 1.844675E+19 3.689349E+19 7.378698E+19 1.47574E+20 2.951479E+20 5.902958E+20 1.180592E+21 2.361183E+21 4.722367E+21 9.444734E+21 1.888947E+22 3.777893E+22 7.555786E+22 1.511157E+23 3.022315E+23 6.044629E+23 1.208926E+24 2.417852E+24 4.835703E+24 9.671406E+24 1.934281E+25 3.868563E+25 7.737125E+25 1.547425E+26 3.09485E+26 6.1897E+26 1.23794E+27 2.47588E+27 4.95176E+27 9.90352E+27 1.980704E+28 3.961408E+28 7.922816E+28 1.584563E+29 3.169126E+29 6.338253E+29 1.267651E+30 2.535301E+30 5.070602E+30 1.01412E+31 2.028241E+31 4.056482E+31 8.112964E+31 1.622593E+32 3.245186E+32 6.490371E+32 1.298074E+33 2.596148E+33 5.192297E+33 1.038459E+34 2.076919E+34 4.153837E+34 8.307675E+34 1.661535E+35 3.32307E+35 6.64614E+35 1.329228E+36 2.658456E+36 5.316912E+36 1.063382E+37 2.126765E+37 4.25353E+37 8.50706E+37 1.701412E+38 NIL)))) (RPAQ \\ARCTANARRAY (READARRAY-FROM-LIST 9 (QUOTE FLOATP) 0 (QUOTE (0.002866226 -0.01616574 0.04290961 -0.07528964 0.1065626 -0.142089 0.1999355 -0.3333315 1.0 NIL)))) (RPAQ \\LOGARRAY (READARRAY-FROM-LIST 9 (QUOTE FLOATP) 0 (QUOTE (-0.006453544 0.03608849 -0.0953294 0.1676541 -0.2407338 0.331799 -0.4998741 0.9999964 0.0 NIL)))) (RPAQ \\SIN-PPOLY (READARRAY-FROM-LIST 6 (QUOTE FLOATP) 0 (QUOTE (-1.312516E-9 5.565546E-7 -8.703754E-5 0.005830397 -0.1509093 1.0 NIL)))) (RPAQ \\SIN-QPOLY (READARRAY-FROM-LIST 6 (QUOTE FLOATP) 0 (QUOTE (3.535755E-12 1.995733E-9 6.131296E-7 1.232982E-4 0.01575741 1.0 NIL)))) (RPAQ \\TAN-PPOLY (READARRAY-FROM-LIST 5 (QUOTE FLOATP) 0 (QUOTE (8.443456E-8 -3.939664E-5 0.004337587 -0.140375 1.0 NIL)))) (RPAQ \\TAN-QPOLY (READARRAY-FROM-LIST 6 (QUOTE FLOATP) 0 (QUOTE (-1.539329E-9 2.275635E-6 -4.822159E-4 0.02890704 -0.4737084 1.0 NIL)))) (RPAQ \\SINARRAY1 (READARRAY-FROM-LIST 6 (QUOTE FLOATP) 0 (QUOTE (-2.39E-8 2.7526E-6 -1.98409E-4 0.008333332 -0.1666667 1.0 NIL)))) (RPAQ \\SINARRAY2 (READARRAY-FROM-LIST 4 (QUOTE FLOATP) 0 (QUOTE (-3.59544E-5 0.002490007 -0.08074545 0.7853982 NIL)))) (RPAQ \\TANARRAY (READARRAY-FROM-LIST 7 (QUOTE FLOATP) 0 (QUOTE (0.00951681 0.002900525 0.02456509 0.05337406 0.1333924 0.3333314 1.0 NIL)))) (RPAQ \\ATANARRAY (READARRAY-FROM-LIST 8 (QUOTE FLOATP) 0 (QUOTE (-0.004054058 0.02186123 -0.05590989 0.09642004 -0.1390853 0.1994654 -0.3332986 0.9999994 NIL)))) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS HORNERIFY MACRO (X (PROG ((INITIAL (CAR X)) (VARNAME (CADR X)) (COEFFICIENTS (CDDR X)) TERM) (OR COEFFICIENTS (SHOULDNT)) (OR (AND (LITATOM VARNAME) VARNAME (NEQ T VARNAME)) (\\ILLEGAL.ARG VARNAME)) (SETQ TERM (LIST 'FPLUS (LIST 'FTIMES INITIAL VARNAME) (CAR COEFFICIENTS))) (OR (CONSTANTEXPRESSIONP (CAR COEFFICIENTS)) (ARGS.COMMUTABLEP (CAR COEFFICIENTS) (CADR TERM)) (LISPERROR X "Can't hack non-commutable coefficient expressions" )) (RETURN (COND ((NULL (CDR COEFFICIENTS)) TERM) (T (CONS 'HORNERIFY (CONS TERM (CONS VARNAME (CDR COEFFICIENTS )))))))))) (PUTPROPS FLEQ MACRO ((X Y) (NOT (FGREATERP X Y)))) (PUTPROPS FGEQ MACRO ((X Y) (NOT (FLESSP X Y)))) ) (FILESLOAD (LOADCOMP) LLFLOAT) (DECLARE\: EVAL@COMPILE (RPAQQ \\SIN-EPSILON 2.441406E-4) (RPAQQ \\TAN-EPSILON 2.441406E-4) (RPAQQ \\EXPONENT.BIAS 127) (RPAQQ 2PI 6.283185) (RPAQQ CL:PI 3.141593) (RPAQQ -PI -3.141593) (RPAQQ -PI/2 -1.570796) (RPAQQ PI/2 1.570796) (RPAQQ 4/PI 1.273239) (RPAQQ 3PI/2 4.712389) (RPAQQ PI/4 0.7853982) (RPAQQ -PI/4 -0.7853982) (RPAQQ PI/180 0.01745329) (RPAQQ 180/PI 57.29578) (RPAQQ -PI/2 -1.570796) (RPAQQ LN2 0.6931472) (RPAQQ |2^-126| 1.17549407E-38) (CONSTANTS (\\SIN-EPSILON 2.441406E-4) (\\TAN-EPSILON 2.441406E-4) (\\EXPONENT.BIAS 127) (2PI 6.283185) (CL:PI 3.141593) (-PI -3.141593) (-PI/2 -1.570796) (PI/2 1.570796) (4/PI 1.273239) (3PI/2 4.712389) (PI/4 0.7853982) (-PI/4 -0.7853982) (PI/180 0.01745329) (180/PI 57.29578) (-PI/2 -1.570796) (LN2 0.6931472) (|2^-126| 1.17549407E-38)) ) ) (PUTPROPS AARITH COPYRIGHT ("Venue & Xerox Corporation" 1981 1983 1984 1985 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1715 24691 (LOG 1725 . 3572) (ANTILOG 3574 . 5170) (SIN 5172 . 5493) (ARCSIN 5495 . 6982) (COS 6984 . 7343) (ARCCOS 7345 . 7726) (TAN 7728 . 8049) (ARCTAN 8051 . 9061) (ARCTAN2 9063 . 10240) (ATAN 10242 . 13121) (FEXPT 13123 . 13637) (\\SIN-FLOAT 13639 . 16530) (\\TAN-FLOAT 16532 . 19042) (\\SIN.OLD 19044 . 20956) (\\COS.OLD 20958 . 23000) (\\TAN.OLD 23002 . 24689))))) STOP \ No newline at end of file diff --git a/sources/ABASIC b/sources/ABASIC new file mode 100644 index 00000000..50bc531d --- /dev/null +++ b/sources/ABASIC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 11:43:16" {DSK}local>lde>lispcore>sources>ABASIC.;2 24522 changes to%: (VARS ABASICCOMS) previous date%: "10-Nov-87 13:01:39" {DSK}local>lde>lispcore>sources>ABASIC.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ABASICCOMS) (RPAQQ ABASICCOMS [(FNS EVALQT \SystemERROR) (FNS NILL EVQ TRUE ZERO CL:IDENTITY DUMMYDEF NOTIMP) (P (DUMMYDEF (WINDOWWORLDP NILL))) (FNS EQUAL NEQ NULL NOT) (COMS (* ;  "Belong on ACODE except they would clobber 10-versions in ABC") (FNS LAPRD DEFC CGETD)) (FNS NCONC \NCONC2 SORT MERGE SORT1 FASSOC FLAST FLENGTH FMEMB FNTH LIST LIST* COUNT) (FNS CHANGENAME1 CHANGENAME1A) (FNS CDDR CDAR CADR CAAR CDDDR CDDAR CDADR CDAAR CADDR CADAR CAADR CAAAR CDDDDR CAAAAR CDDDAR CDDADR CDDAAR CDAAAR CADADR CDADDR CDADAR CAADDR CDAADR CAADAR CADDDR CADAAR CADDAR CAAADR) (FNS SYSTEMTYPE) (COMS (* ;  "Because can't have bignums in code at makeinit time") (VARS (\IMAX.FLOAT (FIX MAX.FLOAT)) (\IMIN.FLOAT (FIX MIN.FLOAT))) (GLOBALVARS \IMAX.FLOAT \IMIN.FLOAT)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DUMMYDEF) (NLAML) (LAMA LIST* LIST NCONC NOTIMP ZERO TRUE NILL]) (DEFINEQ (EVALQT [LAMBDA NIL (* lmm "11-MAR-80 15:57") (PROG (EVALQTXX) EVALQTLP (PRIN1 '_ T) (PRINT [COND ((NULL (SETQ EVALQTXX (READ T))) (GO EVALQTLP)) ((OR (LISTP EVALQTXX) (NULL (READP T))) (EVAL EVALQTXX)) (T (APPLY EVALQTXX (READ T] T) (GO EVALQTLP]) (\SystemERROR [LAMBDA NIL (* lmm " 6-MAY-80 20:41") (SELECTQ (GETTOPVAL '\SystemErrorVAL) (0 (RAID)) (1 (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED")) (RAID]) ) (DEFINEQ (NILL [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") NIL]) (EVQ [LAMBDA (X) (* lmm%: 26 JUN 75 726) X]) (TRUE [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") T]) (ZERO [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") 0]) (CL:IDENTITY [LAMBDA (X) (* bvm%: " 3-Nov-86 22:37") X]) (DUMMYDEF [NLAMBDA LST (* lmm " 4-OCT-83 03:08") (for X in LST when (NOT (GETD (CAR X))) do (PUTD (CAR X) (GETD (CADR X)) T]) (NOTIMP [LAMBDA N (* lmm " 5-MAR-80 20:17") (HELP "UNIMPLEMENTED FUNCTION"]) ) (DUMMYDEF (WINDOWWORLDP NILL)) (DEFINEQ (EQUAL [LAMBDA (X Y) (* bvm%: " 7-Jul-86 22:41") (* ; "tortured logic to optimize performance") (OR (EQ X Y) (COND [(LISTP X) (AND (LISTP Y) (PROG NIL RETRYLISTP (RETURN (AND (EQUAL (CAR X) (CAR Y)) (COND [(LISTP (SETQ X (CDR X))) (RETURN (AND (LISTP (SETQ Y (CDR Y))) (OR (EQ X Y) (GO RETRYLISTP] (T (EQUAL X (CDR Y] ((OR (LITATOM X) (LITATOM Y)) (* ; "can't be EQUAL and not EQ") NIL) [(NUMBERP X) (AND (NUMBERP Y) (SELECTC (NTYPX X) (\FLOATP [SELECTC (NTYPX Y) (\FLOATP (FEQP X Y)) (\SMALLP (FEQP X Y)) (\FIXP (FEQP X Y)) (PROGN (* ; "If comparing against bignum, avoid floating overflow when coercing a too-large bignum to floatp") (AND (NOT (GREATERP Y \IMAX.FLOAT)) (NOT (LESSP Y \IMIN.FLOAT)) (FEQP X Y]) (\SMALLP (SELECTC (NTYPX Y) (\FLOATP (FEQP X Y)) (\SMALLP (* ; "both small, not EQ") NIL) (\FIXP (* ; "should allow small in fixp boxes?") [AND (EQ (ffetch (FIXP LONUM) of Y) (\LOLOC X)) (EQ (ffetch (FIXP HINUM) of Y) (COND ((ILESSP X 0) MAX.SMALLP) (T 0]) NIL)) (\FIXP (SELECTC (NTYPX Y) (\FLOATP (FEQP X Y)) (\SMALLP (* ; "should allow small in fixp boxes?") [AND (EQ (ffetch (FIXP LONUM) of X) (\LOLOC Y)) (EQ (ffetch (FIXP HINUM) of X) (COND ((ILESSP Y 0) MAX.SMALLP) (T 0]) (\FIXP (AND (EQ (ffetch (FIXP HINUM) of X) (ffetch (FIXP HINUM) of Y)) (EQ (ffetch (FIXP LONUM) of X) (ffetch (FIXP LONUM) of Y)))) (PROGN (* ; "fixp bignum") NIL))) (SELECTC (NTYPX Y) (\FLOATP (* ; "BIGNUM \FLOATP") (AND (NOT (GREATERP X \IMAX.FLOAT)) (NOT (LESSP X \IMIN.FLOAT)) (FEQP X Y))) (\SMALLP (* ; "BIGNUM \SMALLP") NIL) (\FIXP (* ; "BIGNUM \FIXP") NIL) (PROGN (* ; "BIGNUM BIGNUM") (EQ (\BIGNUM.COMPARE X Y) 0] ((NUMBERP Y) NIL) ((STRINGP X) (STREQUAL X Y)) (T (\EXTENDED.EQP X Y]) (NEQ [LAMBDA (X Y) (NOT (EQ X Y]) (NULL [LAMBDA (X) (EQ X NIL]) (NOT [LAMBDA (X) (EQ X NIL]) ) (* ; "Belong on ACODE except they would clobber 10-versions in ABC") (DEFINEQ (LAPRD [LAMBDA (FN) (* wsh%: "20-JUL-79 12:27") (PROG (X Y) (RETURN (COND ([OR (NEQ (PEEKC) '% ) [NOT (LITATOM (SETQ X (SETQ Y (READ] (NOT (LISTP (SETQ X (GETP X 'CODEREADER] (ERROR '"Bad compiled function" FN)) (T (APPLY* (CAR X) FN]) (DEFC [LAMBDA (NM DF) (* ; "Edited 10-Nov-87 13:01 by jds") (* ;; "Put in a new definition (DF) for the name NM.") (PROG ((PROP 'CODE)) (COND ((OR (NULL DFNFLG) (EQ DFNFLG T)) (* ;; "OK to redefine it.") [COND ((GETD NM) (VIRGINFN NM T) (COND ((NULL DFNFLG) (PRINT (CONCAT NM " redefined") T T) (* ;  "NOTE: this call to PRINT is changed to LISPXPRINT later in the loadup.") (SAVEDEF NM] (PUTD NM DF T) (* ;  "NOTE: this call to PUTD is changed to /PUTD later in the loadup.") ) (T (* ;; "DFNFLG is PROP, so save the definition.") (PUTPROP NM PROP DF) (* ;  "NOTE: this call to PUTPROP is changed to /PUTPROP later in the loadup.") )) (RETURN DF]) (CGETD [LAMBDA (X) (COND ((LITATOM X) (GETD X)) (T X]) ) (DEFINEQ (NCONC [LAMBDA N (AND (NEQ N 0) (PROG ((L (ARG N N)) (J N) X) LP (COND ((EQ (SETQ J (SUB1 J)) 0) (RETURN L)) ((LISTP (SETQ X (ARG N J))) (FRPLACD (LAST X) L) (SETQ L X))) (GO LP]) (\NCONC2 [LAMBDA (X Y) (* lmm "15-APR-82 22:10") (COND ((LISTP X) (RPLACD (LAST X) Y) X) (T Y]) (SORT [LAMBDA (DATA COMPAREFN) (DECLARE (LOCALVARS . T)) (* lmm%: "11-NOV-76 23:48:23") (COND [(NLISTP DATA) (COND (DATA (ERROR '"DATA NOT LIST:" DATA] (T (OR COMPAREFN (SETQ COMPAREFN (FUNCTION ALPHORDER))) (FRPLACD (LAST DATA) NIL) (SORT1 DATA NIL COMPAREFN]) (MERGE [LAMBDA (A B COMPAREFN) (* lmm " 6-MAY-80 21:36") (PROG (ATAIL BTAIL) [COND ((NULL B) (* ; "MERGE will work if either arg is NIL.") (RETURN A)) ((NULL A) (RETURN B)) ((NLISTP B) (* ; "No possible meaning here; user must be in error.") (ERRORX (LIST 4 B))) ((NLISTP A) (ERRORX (LIST 4 A))) ([NOT (SELECTQ COMPAREFN (T (ALPHORDER (CAAR A) (CAAR B))) (NIL (ALPHORDER (CAR A) (CAR B))) (APPLY* COMPAREFN (CAR A) (CAR B] (* ;; "(CAR A) must be before (CAR B) at LOOP (see comment below). If not, swap A and B. --- The SELECTQ compares the next things on A and B.") (SETQ A (PROG1 B (SETQ B A] (SETQ ATAIL A) (* ;; "It is desireable to make the value of the merged list available to the user not only as the return from MERGE, but also on both the CONSES given as arguments. To this end, the MERGE is actually performed on the lists A and (CONS (CAR B) (CDR B)), so that when we return, the original B may be smashed with (CAR A) and (CDR A).") (SETQ BTAIL (CONS (CAR B) (CDR B))) (* ;; "Whenever we pass LOOP, we know that ATAIL is LISTP, BTAIL is LISTP, and (CAR ATAIL) belongs before (CAR BTAIL). We therefore look to see if there is anything more on ATAIL; if not, tie on BTAIL and return. Otherwise, compare (CADR ATAIL) to (CAR BTAIL). If ATAIL wins, just take one CDR and go around. But if BTAIL wins, then we swap variable/structures: ATAIL is rplacd'd to the structure that was on BTAIL, and BTAIL is bound to the old CDR of ATAIL. We then take the CDR and go around. Observe that this swapping preserves the assumptions made at LOOP.") LOOP [COND [(NLISTP (CDR ATAIL)) (FRPLACD ATAIL BTAIL) (RETURN (FRPLACA (FRPLACD B (CDR A)) (CAR A] [(SELECTQ COMPAREFN (NIL (ALPHORDER (CADR ATAIL) (CAR BTAIL))) (T (ALPHORDER (CAADR ATAIL) (CAAR BTAIL))) (APPLY* COMPAREFN (CADR ATAIL) (CAR BTAIL] (T (FRPLACD ATAIL (PROG1 BTAIL (SETQ BTAIL (CDR ATAIL] (SETQ ATAIL (CDR ATAIL)) (GO LOOP]) (SORT1 [LAMBDA (DATA END COMPAREFN) (DECLARE (LOCALVARS . T)) (* lmm%: "11-NOV-76 23:49:27") (COND ((OR (EQ DATA END) (EQ (CDR DATA) END)) DATA) (T (PROG ((L DATA) (A DATA) TM) (* ; "Split DATA by setting A to one cell before its midpoint. DATA remains EQ to the original list.") LP (COND ((AND (NEQ (SETQ L (CDR L)) END) (NEQ (SETQ L (CDR L)) END)) (SETQ A (CDR A)) (GO LP))) (SETQ TM (SORT1 DATA (CDR A) COMPAREFN)) (SORT1 (SETQ L (CDR A)) END COMPAREFN) (* ;; "Merge DATA thru A with L (= (CDR A)) up to END. This is a little tricky because DATA must remain EQ to its original value.") ALP (COND ((EQ TM L) (* ; "Exhausted first list.") (RETURN DATA))) BLP (COND ((SELECTQ COMPAREFN (T [ALPHORDER (COND ((LISTP (CAR TM)) (CAAR TM)) (T (CAR TM))) (COND ((LISTP (CAR L)) (CAAR L)) (T (CAR L]) (APPLY* COMPAREFN (CAR TM) (CAR L))) (SETQ TM (CDR TM)) (GO ALP))) (* ;; "Move first element of second list (L = (CDR A)) to before first element of first list (TM). This must be done by exchanging the CARs and then patching up the CDRs, to retain the EQ property. This is a 'critical section' in that data will be lost if a hard interrupt occurs, but it cannot be interrupted by ^H because it does no function calls.") (* ;; "NOT TRUE IN INTERLISP-D--THIS SECTION IS AN UNPROTECTED CRITICAL REGION.") [COND [(EQ TM A) (* ; "Special case.") [FRPLACA TM (PROG1 (CAR L) (FRPLACA L (CAR TM] (SETQ L (CDR (SETQ TM (SETQ A L] (T [FRPLACD A (PROG1 (CDR L) (FRPLACA TM (PROG1 (CAR L) (FRPLNODE2 L TM) (FRPLACD TM L] (SETQ TM L) (SETQ L (CDR A] (COND ((NEQ L END) (GO BLP))) (* ; "Exhausted second list.") (RETURN DATA]) (FASSOC [LAMBDA (KEY ALST) (* lmm " 5-MAR-80 20:55") (COND ((NULL ALST) NIL) ((EQ KEY (CAAR ALST)) (CAR ALST)) (T (FASSOC KEY (CDR ALST]) (FLAST [LAMBDA (X) (* lmm " 5-MAR-80 20:57") (PROG ((Y X)) (GO LP0) LP (SETQ X Y) (SETQ Y (CDR X)) LP0 (COND (Y (GO LP))) (RETURN X]) (FLENGTH [LAMBDA (X) (* lmm%: "11-NOV-76 23:53:54") (PROG ((N 0) Y) (SETQ Y X) (GO LP0) LP (SETQ X Y) (SETQ N (ADD1 N)) (SETQ Y (CDR X)) LP0 (COND (Y (GO LP))) (RETURN N]) (FMEMB [LAMBDA (X Y) (* lmm "27-MAR-80 12:53") (PROG NIL LP (RETURN (COND ((NULL Y) NIL) ((EQ (CAR Y) X) Y) (T (SETQ Y (CDR Y)) (GO LP]) (FNTH [LAMBDA (X N) (* lmm " 6-MAY-80 22:29") (COND ((IGREATERP 1 N) (CONS NIL X)) (T (PROG ((X0 X)) (DECLARE (LOCALVARS X0)) LP (COND ((NULL X) (RETURN NIL)) ((NOT (IGREATERP N 1)) (RETURN X))) (SETQ N (SUB1 N)) (SETQ X (CDR X)) (GO LP]) (LIST [LAMBDA N (* JonL "24-Apr-84 14:49") (PROG ((J N) L) LP (COND ((EQ 0 J) (RETURN L))) (SETQ L (CONS (ARG N J) L)) (SETQ J (SUB1 J)) (GO LP]) (LIST* [LAMBDA NARGS (* JonL "27-Sep-84 21:19") (COND ((EQ 0 NARGS) NIL) ((EQ 1 NARGS) (ARG NARGS 1)) (T (bind (VAL _ (ARG NARGS NARGS)) for I from (SUB1 NARGS) by -1 until (ILEQ I 0) do (push VAL (ARG NARGS I)) finally (RETURN VAL]) (COUNT [LAMBDA (X) (* lmm%: 24 JUN 75 32) (PROG ((N 0)) LP (COND ((NLISTP X) (RETURN N)) (T (SETQ N (IPLUS (COUNT (CAR X)) 1 N)) (SETQ X (CDR X)) (GO LP]) ) (DEFINEQ (CHANGENAME1 [LAMBDA (DEF X Y) (* rmk%: "15-APR-80 17:29") (* ; "This isn't on ACODE because it would smash the 10 version in ABC") (COND ((EXPRP DEF) (NLSETQ (ESUBST Y X DEF))) ((CCODEP DEF) [COND ((LITATOM DEF) (SETQ DEF (GETD DEF] (CHANGENAME1A DEF X Y (CHANGECCODE X X DEF]) (CHANGENAME1A [LAMBDA (DEF OLD NEW MAP) (* lmm "20-MAY-80 09:43") (COND ((AND MAP (find X in (CDR MAP) suchthat (find Y in (CDR X) suchthat Y))) (CHANGECCODE NEW MAP DEF) (UNDOSAVE (LIST 'CHANGENAME1A DEF NEW OLD MAP)) T]) ) (DEFINEQ (CDDR [LAMBDA (X) (CDR (CDR X]) (CDAR [LAMBDA (X) (CDR (CAR X]) (CADR [LAMBDA (X) (CAR (CDR X]) (CAAR [LAMBDA (X) (CAR (CAR X]) (CDDDR [LAMBDA (X) (CDR (CDDR X]) (CDDAR [LAMBDA (X) (CDR (CDAR X]) (CDADR [LAMBDA (X) (CDR (CADR X]) (CDAAR [LAMBDA (X) (CDR (CAAR X]) (CADDR [LAMBDA (X) (CAR (CDDR X]) (CADAR [LAMBDA (X) (CAR (CDAR X]) (CAADR [LAMBDA (X) (CAR (CADR X]) (CAAAR [LAMBDA (X) (CAR (CAAR X]) (CDDDDR [LAMBDA (X) (CDDR (CDDR X]) (CAAAAR [LAMBDA (X) (CAAR (CAAR X]) (CDDDAR [LAMBDA (X) (CDDR (CDAR X]) (CDDADR [LAMBDA (X) (CDDR (CADR X]) (CDDAAR [LAMBDA (X) (CDDR (CAAR X]) (CDAAAR [LAMBDA (X) (CDAR (CAAR X]) (CADADR [LAMBDA (X) (CADR (CADR X]) (CDADDR [LAMBDA (X) (CDAR (CDDR X]) (CDADAR [LAMBDA (X) (CDAR (CDAR X]) (CAADDR [LAMBDA (X) (CAAR (CDDR X]) (CDAADR [LAMBDA (X) (CDAR (CADR X]) (CAADAR [LAMBDA (X) (CAAR (CDAR X]) (CADDDR [LAMBDA (X) (CADR (CDDR X]) (CADAAR [LAMBDA (X) (CADR (CAAR X]) (CADDAR [LAMBDA (X) (CADR (CDAR X]) (CAAADR [LAMBDA (X) (CAAR (CADR X]) ) (DEFINEQ (SYSTEMTYPE [LAMBDA NIL (* lmm "17-AUG-81 15:50") (* ; "let the macro decide") (SYSTEMTYPE]) ) (* ; "Because can't have bignums in code at makeinit time") (RPAQ \IMAX.FLOAT (FIX MAX.FLOAT)) (RPAQ \IMIN.FLOAT (FIX MIN.FLOAT)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \IMAX.FLOAT \IMIN.FLOAT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DUMMYDEF) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LIST* LIST NCONC NOTIMP ZERO TRUE NILL) ) (PRETTYCOMPRINT ABASICCOMS) (RPAQQ ABASICCOMS [(FNS EVALQT \SystemERROR) (FNS NILL EVQ TRUE ZERO CL:IDENTITY DUMMYDEF NOTIMP) (P (DUMMYDEF (WINDOWWORLDP NILL))) (FNS EQUAL NEQ NULL NOT) (COMS (* ;  "Belong on ACODE except they would clobber 10-versions in ABC") (FNS LAPRD DEFC CGETD)) (FNS NCONC \NCONC2 SORT MERGE SORT1 FASSOC FLAST FLENGTH FMEMB FNTH LIST LIST* COUNT) (FNS CHANGENAME1 CHANGENAME1A) (FNS CDDR CDAR CADR CAAR CDDDR CDDAR CDADR CDAAR CADDR CADAR CAADR CAAAR CDDDDR CAAAAR CDDDAR CDDADR CDDAAR CDAAAR CADADR CDADDR CDADAR CAADDR CDAADR CAADAR CADDDR CADAAR CADDAR CAAADR) (FNS SYSTEMTYPE) (COMS (* ;  "Because can't have bignums in code at makeinit time") (VARS (\IMAX.FLOAT (FIX MAX.FLOAT)) (\IMIN.FLOAT (FIX MIN.FLOAT))) (GLOBALVARS \IMAX.FLOAT \IMIN.FLOAT)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DUMMYDEF) (NLAML) (LAMA LIST* LIST NCONC NOTIMP ZERO NILL]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DUMMYDEF) (ADDTOVAR NLAML ) (ADDTOVAR LAMA LIST* LIST NCONC NOTIMP ZERO NILL) ) (PUTPROPS ABASIC COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1772 2517 (EVALQT 1782 . 2275) (\SystemERROR 2277 . 2515)) (2518 3516 (NILL 2528 . 2634 ) (EVQ 2636 . 2737) (TRUE 2739 . 2843) (ZERO 2845 . 2949) (CL:IDENTITY 2951 . 3064) (DUMMYDEF 3066 . 3377) (NOTIMP 3379 . 3514)) (3553 8305 (EQUAL 3563 . 8173) (NEQ 8175 . 8222) (NULL 8224 . 8263) (NOT 8265 . 8303)) (8383 10259 (LAPRD 8393 . 8884) (DEFC 8886 . 10169) (CGETD 10171 . 10257)) (10260 19969 (NCONC 10270 . 10673) (\NCONC2 10675 . 10870) (SORT 10872 . 11256) (MERGE 11258 . 14142) (SORT1 14144 . 17315) (FASSOC 17317 . 17553) (FLAST 17555 . 17801) (FLENGTH 17803 . 18118) (FMEMB 18120 . 18479) ( FNTH 18481 . 18963) (LIST 18965 . 19268) (LIST* 19270 . 19640) (COUNT 19642 . 19967)) (19970 20799 ( CHANGENAME1 19980 . 20471) (CHANGENAME1A 20473 . 20797)) (20800 22254 (CDDR 20810 . 20851) (CDAR 20853 . 20894) (CADR 20896 . 20937) (CAAR 20939 . 20980) (CDDDR 20982 . 21029) (CDDAR 21031 . 21078) (CDADR 21080 . 21127) (CDAAR 21129 . 21176) (CADDR 21178 . 21225) (CADAR 21227 . 21274) (CAADR 21276 . 21323 ) (CAAAR 21325 . 21372) (CDDDDR 21374 . 21427) (CAAAAR 21429 . 21482) (CDDDAR 21484 . 21537) (CDDADR 21539 . 21592) (CDDAAR 21594 . 21647) (CDAAAR 21649 . 21702) (CADADR 21704 . 21757) (CDADDR 21759 . 21812) (CDADAR 21814 . 21867) (CAADDR 21869 . 21922) (CDAADR 21924 . 21977) (CAADAR 21979 . 22032) ( CADDDR 22034 . 22087) (CADAAR 22089 . 22142) (CADDAR 22144 . 22197) (CAAADR 22199 . 22252)) (22255 22481 (SYSTEMTYPE 22265 . 22479))))) STOP \ No newline at end of file diff --git a/sources/ACODE b/sources/ACODE new file mode 100644 index 00000000..b9c80ed5 --- /dev/null +++ b/sources/ACODE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Jun-2017 22:35:00" {DSK}Personal>local>medley3.5>sources>ACODE.;5 70390 changes to%: (VARS ACODECOMS) (FNS BROKENDEF) previous date%: " 3-Oct-95 12:17:05" {DSK}Personal>local>medley3.5>sources>ACODE.;3) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1995, 2017 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ACODECOMS) (RPAQQ ACODECOMS ((COMS (* ; "Printing compiled code") (FNS PRINTCODE PRINTCODENT) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS PCVAR PRINJUMP NEXTBYTE PRINTCODEHEADERDECODE) (GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE))) (COMS (* ; "Analyzing compiled code") (FNS CALLSCCODE RUNION) (FNS CHANGECCODE CCCSUBFN? \SUBFNDEF CCCSCAN \CODEBLOCKP) (FNS \MAP-CODE-POINTERS \MAP-CODE-LITERALS) (BLOCKS (CALLSCCODE CALLSCCODE RUNION) (CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN)) (* ;; "MACROS/OPTIMIZERS for getting and setting symbol entries in a compiled-code block. These are parameterized to allow for 2-, 3-, and 4-byte symbol representations.") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS REFMAP) (MACROS CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2 CODEBASELT3 CODEBASELT4 CODEBASESETA3 CODEBASESETA4) (OPTIMIZERS CODEBASESETATOM CODEBASEGETATOM CODEBASEGETNAME BYTESPERCODEATOM BIG-VMEM-HOST) (FILES (LOADCOMP) LLGC LLCODE LLBASIC MODARITH RENAMEMACROS)) (ADDVARS (IGNOREFNS))) (COMS (* ;  "Maintaining ref count consistency in code") (FNS \COPYCODEBLOCK \COPYFNHEADER \RECLAIMCODEBLOCK)) (COMS (* ; "Low-level break") (FNS LLBREAK BROKENDEF)) [COMS (* ; "for TELERAID") (DECLARE%: DONTCOPY (ADDVARS (RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF)) (EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2 PRINTCODEHEADERDECODE] (COMS (* ;  "reference to opcodes symbolically") (FNS PRINTOPCODES) (GLOBALVARS \OPCODES)) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (* ; "Printing compiled code") (DEFINEQ (PRINTCODE [LAMBDA (FN LVFLG RADIX OUTF FIRSTBYTE PC FN.IS.CODEBASE) (* ;  "Edited 30-Nov-92 11:10 by sybalsky:mv:envos") (* ; "Edited 25-Feb-91 15:46 ") (* ; "by sybalsky") (* ;;; "WARNING: this code must run `renamed' for TeleRaid Printcode to work. However, it is pretty tricky to get it to run renamed because some of the constructs run in local space (e.g., the CARs and CADRs of the code list) and many run in remote space (e.g., the bytes of the code).") (* ;;; "It seems that frequently when modifying any part of PRINTCODE the renamed version stops working, so *BEWARE* and make sure you test any edits by doing a (DORENAME 'R) and checking TeleRaid's CodePrint command, as well as in normal PRINTCODE mode.") (* ;;; "All the CODEARRAY accesses are equivalent to FNHEADER accesses indirected thru the CCODEP object. The reason it is done this awful crufty way, instead of fetching the code base, is so this works in Interlisp-10 as well. Might want to punt that now.") (DECLARE (SPECVARS OUTF)) (OR RADIX (SETQ RADIX 8)) (LET ([CODEBASE (COND (FN.IS.CODEBASE FN) (T (OR (\GET-COMPILED-CODE-BASE FN) [AND (LITATOM FN) (\GET-COMPILED-CODE-BASE (GET FN 'CODE] (ERROR FN "not compiled code"] (I4 (NUMFORMATCODE (LIST 'FIX 4 RADIX))) (I6 (NUMFORMATCODE (LIST 'FIX 6 RADIX))) NTSIZE STARTPC TAG TEMP OP# PVARS FVARS IVARS) (DECLARE (SPECVARS CODEBASE IVARS PVARS FVARS I4 I6)) (* ; "Used by PRINTCODENT") (LET ((*PRINT-BASE* RADIX)) (for I from 0 by BYTESPERWORD while (ILESSP I (UNFOLD (fetch (FNHEADER OVERHEADWORDS ) of T) BYTESPERWORD)) do (PRINTNUM I4 I OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (CODEBASELT2 CODEBASE I) OUTF) (PRINTCODEHEADERDECODE CODEBASE I OUTF) (* ; "Interpret header word") (TERPRI OUTF))) (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE)) (PRINTCODENT "name table: " (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD) (UNFOLD NTSIZE BYTESPERWORD)) (SETQ STARTPC (fetch (FNHEADER STARTPC) of CODEBASE)) (COND ((GREATERP [SETQ NTSIZE (IDIFFERENCE (COND ((fetch (FNHEADER NATIVE) CODEBASE) (* ;; "native code has an extra 4 bytes") (- STARTPC 4)) (T STARTPC)) (SETQ TEMP (IPLUS (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD) (COND ((EQ NTSIZE 0) (* ;  "No nametable, but there's a quad of zeros there anyway") BYTESPERQUAD) (T (UNFOLD NTSIZE (ITIMES 2 BYTESPERWORD] BYTESPERCELL) (PRINTCODENT "Local args: " TEMP (FOLDLO NTSIZE 2))) ((EQ NTSIZE BYTESPERCELL) (* ; "Debugging info") (printout OUTF T "Info: " .P2 (\GETBASEPTR CODEBASE (FOLDLO TEMP BYTESPERWORD)) T))) (printout OUTF T "----" T) (PROG ((CODELOC STARTPC) (LEVEL (AND LVFLG 0)) B B1 B2 B3 B4 B5 FN LEN LEVADJ STK) [ALLOCAL (COND (LEVEL (SETUPHASHARRAY '\PRINTCODE.LEVEL) (SETUPHASHARRAY '\PRINTCODE.STKSTATE) (CLRHASH \PRINTCODE.LEVEL) (CLRHASH \PRINTCODE.STKSTATE] LP (COND ((AND PC (IGEQ CODELOC PC)) (* ;  "Caller asked to highlight this spot") (COND ((NOT (IEQP CODELOC PC)) (PRINTOUT OUTF "(PC ") (PRINTNUM I4 PC OUTF) (PRINTOUT OUTF " not found)"))) (printout OUTF "------------------------------" T) (SETQ PC))) (COND ((OR (NULL FIRSTBYTE) (IGEQ CODELOC FIRSTBYTE)) (PRINTNUM I4 CODELOC OUTF) (PRIN1 ": " OUTF) [COND (LVFLG (SETQ TEMP (GETHASH CODELOC \PRINTCODE.LEVEL)) [COND [LEVEL (COND ([AND TEMP (OR (NEQ LEVEL TEMP) (NOT (EQUAL STK (GETHASH CODELOC \PRINTCODE.STKSTATE] (PRIN1 "*" OUTF] (T (SETQ LEVEL TEMP) (SETQ STK (GETHASH CODELOC \PRINTCODE.STKSTATE] (COND (LEVEL (TAB 7 NIL OUTF) (PRINTNUM I4 LEVEL OUTF] (TAB 12 NIL OUTF)) (T (* ;  "Don't print code, but quietly process LEVEL etc") (SETQ TAG (\FINDOP (NEXTBYTE))) (SELECTQ (ALLOCAL (OR (fetch OPPRINT of TAG) (fetch OPCODENAME of TAG))) (-X- (TERPRI OUTF) (RETURN)) (BIND [ALLOCAL (COND (LEVEL (push STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (LOGAND (CODEBASELT CODEBASE CODELOC) 15]) (UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK]) (DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK]) (RETURN (SETQ LEVEL)) (SUBRCALL [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT CODEBASE (ADD1 CODELOC]) (MISCN [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL (CODEBASELT CODEBASE (IPLUS 2 CODELOC]) NIL) [COND ([AND LEVEL (ALLOCAL (SETQ LEVADJ (fetch LEVADJ of TAG] [ALLOCAL (COND ((LISTP LEVADJ) (SETQ LEVADJ (CAR LEVADJ] (SELECTQ LEVADJ (FNX (add LEVEL (IDIFFERENCE 1 (CODEBASELT CODEBASE CODELOC)))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL (CODEBASELT CODEBASE CODELOC)))) ((JUMP UNWIND) (SETQ LEVEL)) ((CJUMP NCJUMP) (add LEVEL -1)) (COND ((NUMBERP LEVADJ) (add LEVEL LEVADJ] (ALLOCAL (add CODELOC (fetch OPNARGS of TAG))) (GO LP))) [SETQ LEN (LOCAL (fetch OPNARGS of (SETQ TAG (\FINDOP (SETQ B (NEXTBYTE] (PRINTNUM I4 B OUTF) (COND ((IGREATERP LEN 0) (PRINTNUM I4 (SETQ B1 (NEXTBYTE)) OUTF))) (COND ((IGREATERP LEN 1) (PRINTNUM I4 (SETQ B2 (NEXTBYTE)) OUTF))) (COND ((IGREATERP LEN 2) (PRINTNUM I4 (SETQ B3 (NEXTBYTE)) OUTF))) (COND ((IGREATERP LEN 3) (PRINTNUM I4 (SETQ B4 (NEXTBYTE)) OUTF))) (COND ((IGREATERP LEN 4) (PRINTNUM I4 (SETQ B5 (NEXTBYTE)) OUTF))) [ALLOCAL (PROGN (printout OUTF 30 (fetch OPCODENAME of TAG)) (SETQ OP# (fetch OP# of TAG)) (SETQ LEVADJ (fetch LEVADJ of TAG] [ALLOCAL (COND ((LISTP OP#) (SETQ OP# (CAR OP#] [SELECTQ [SETQ TAG (ALLOCAL (OR (fetch OPPRINT of TAG) (fetch OPCODENAME of TAG] (-X- (TERPRI OUTF) (RETURN)) (IVAR (TAB 40 NIL OUTF) (PCVAR (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) IVARS 'ivar)) (PVAR (TAB 40 NIL OUTF) (PCVAR (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) PVARS 'pvar)) (FVAR (TAB 40 NIL OUTF) (PCVAR (SELECTQ LEN (0 (IDIFFERENCE B OP#)) (LRSH B1 1)) FVARS 'fvar)) (JUMP (PRINJUMP (IPLUS (IDIFFERENCE B OP#) 2))) (SIC (printout OUTF 40 .P2 B1)) (SNIC (printout OUTF 40 .P2 (IDIFFERENCE B1 256))) (SICX (printout OUTF 40 .P2 (IPLUS (LLSH B1 8) B2))) (JUMPX (PRINJUMP (COND ((IGEQ B1 128) (IDIFFERENCE B1 256)) (T B1)))) (FN (* ;; "it's a function. Print the name.") (NEW-SYMBOL-CODE (BIG-VMEM-HOST (SETQ B (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4)) (SETQ B (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (SETQ B (IPLUS (LLSH B1 8) B2))) (printout OUTF 40 .P2 (\INDEXATOMDEF B))) (BIND (TAB 40 NIL OUTF) [ALLOCAL (PROG ((NNILS (LRSH B1 4)) (NVALS (LOGAND B1 15))) (for I from (ADD1 (IDIFFERENCE B2 (IPLUS NNILS NVALS))) to (IDIFFERENCE B2 NNILS) do (SPACES 1 OUTF) (PCVAR I PVARS 'pvar)) (PRIN1 '; OUTF) (for I from (ADD1 (IDIFFERENCE B2 NNILS)) to B2 do (SPACES 1 OUTF) (PCVAR I PVARS 'pvar)) (COND (LEVEL (push STK (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL NVALS]) (JUMPXX [PRINJUMP (IPLUS (LLSH B1 8) B2 (COND ((IGREATERP B1 127) -65536) (T 0]) (ATOM [printout OUTF 40 .P2 (\INDEXATOMPNAME (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4) (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3)) (IPLUS (LLSH B1 8) B2]) (GCONST [printout OUTF 40 .P2 (1ST (BIG-VMEM-HOST (\VAG2 (IPLUS (LLSH B1 8) B2) (IPLUS (LLSH B3 8) B4)) (\VAG2 B1 (IPLUS (LLSH B2 8) B3]) (FNX [printout OUTF "(" B1 ")" 40 .P2 (\INDEXATOMDEF (NEW-SYMBOL-CODE (BIG-VMEM-HOST (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4) 8) B5) (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4)) (IPLUS (LLSH B2 8) B3]) (TYPEP (printout OUTF "(" .P2 (OR (\TYPENAMEFROMNUMBER B1) '?) ")")) (UNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (pop STK]) (DUNBIND [ALLOCAL (AND LEVEL (SETQ LEVEL (SUB1 (pop STK]) (RETURN (SETQ LEVEL)) (SUBRCALL [ALLOCAL (printout OUTF 40 (for X in \INITSUBRS when (EQ B1 (CADR X)) do (RETURN (CAR X)) finally (RETURN "?"] [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2]) (MISCN [ALLOCAL (printout OUTF 40 (for X in \USER-SUBR-LIST when (EQ B1 (CADR X)) do (RETURN (CAR X)) finally (RETURN "?"] [AND LEVEL (SETQ LEVEL (ADD1 (IDIFFERENCE LEVEL B2]) (ALLOCAL (COND ((LISTP TAG) (printout OUTF 40 (CAR (NTH TAG (ADD1 B1] (TERPRI OUTF) [COND ((AND LEVEL LEVADJ) (SELECTQ LEVADJ (FNX (add LEVEL (IDIFFERENCE 1 B1))) (POP.N (SETQ LEVEL (IDIFFERENCE LEVEL B1))) ((JUMP UNWIND) (SETQ LEVEL)) ((CJUMP NCJUMP) (add LEVEL -1)) (COND ((NUMBERP LEVADJ) (add LEVEL LEVADJ] (GO LP]) (PRINTCODENT [LAMBDA (STR START1 START2) (DECLARE (USEDFREE CODEBASE IVARS PVARS FVARS I4 I6 OUTF)) (* ; "Edited 20-Feb-91 10:38 by jds") (* ;; "Prints the name table identified with title STR that starts with names at START1 and codes at START2") (LET (NAME TAG) (COND ((ILESSP START1 (SETQ START2 (IPLUS START2 START1))) (printout OUTF STR T) (for NT1 from START1 by (BYTESPERNAMEENTRY) while (ILESSP NT1 START2) as NT2 from START2 by (BYTESPERNTOFFSETENTRY) do (PRINTNUM I4 NT1 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNAMEENTRY CODEBASE NT1) OUTF) (SPACES 3 OUTF) (PRINTNUM I4 NT2 OUTF) (PRIN1 ": " OUTF) (PRINTNUM I6 (GETNTOFFSETENTRY CODEBASE NT2) OUTF) (COND ((SETQ NAME (\INDEXATOMVAL (CODEBASEGETNAME CODEBASE NT1))) (SETQ TAG (GETNTOFFSET CODEBASE NT2)) (printout OUTF .SP 5 (SELECTC (NTSLOT-VARTYPE (GETNTOFFSETENTRY CODEBASE NT2)) (IVARCODE (ALLOCAL (push IVARS (LIST TAG NAME))) 'IVAR) (PVARCODE (ALLOCAL (push PVARS (LIST TAG NAME))) 'PVAR) (PROGN (ALLOCAL (push FVARS (LIST TAG NAME))) 'FVAR)) " " TAG ": " |.P2| NAME))) (TERPRI OUTF]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS PCVAR MACRO [(IND LST NAME) (* lmm "11-AUG-81 22:27") (ALLOCAL (PROG NIL (PRIN2 [CADR (OR (ASSOC IND LST) (RETURN (printout OUTF "[" NAME IND "]"] OUTF]) (PUTPROPS PRINJUMP MACRO [LAMBDA (N) (PRIN1 "->" OUTF) (PRINTNUM I4 [SETQ N (IPLUS N (IDIFFERENCE CODELOC (ADD1 LEN] OUTF) (COND (LEVEL (PUTHASH N (SELECTQ LEVADJ ((NCJUMP JUMP) LEVEL) (SUB1 LEVEL)) \PRINTCODE.LEVEL) (PUTHASH N STK \PRINTCODE.STKSTATE]) (PUTPROPS NEXTBYTE MACRO [NIL (CODEBASELT CODEBASE (PROG1 CODELOC (add CODELOC 1]) (PUTPROPS PRINTCODEHEADERDECODE DMACRO (DEFMACRO (CODEBASE INDEX OUTF) (LET (INDICES I THERE) [for NAME in (CDR (RECORDFIELDNAMES 'FNHEADER T)) when (AND NAME (CL:SYMBOLP NAME)) do [SETQ I (EVAL `(INDEXF (fetch (FNHEADER ,NAME] (COND ((EQ NAME '%#FRAMENAME) (add I 1))) (COND ((SETQ THERE (ASSOC I INDICES)) (push (CDR THERE) NAME)) (T (push INDICES (LIST I NAME] `(SELECTQ ,INDEX (\,@ [for PAIR in INDICES collect (CONS (UNFOLD (CAR PAIR) BYTESPERWORD) (COND [(CDDR PAIR) (for NAME in (CDR PAIR) collect (SELECTQ NAME ((NATIVE CLOSUREP) `(AND (fetch (FNHEADER ,NAME) of ,CODEBASE) (PRIN1 ,(CONCAT "[" NAME "]") ,OUTF))) `(printout ,OUTF ,(CONCAT " " (L-CASE (MKSTRING NAME)) ": ") (fetch (FNHEADER ,NAME) of ,CODEBASE] [(EQ (CADR PAIR) '%#FRAMENAME) `((printout ,OUTF " frame name: " .P2 (1ST (fetch (FNHEADER %#FRAMENAME) of ,CODEBASE] (T `((PRIN1 ,[CONCAT " " (L-CASE (MKSTRING (CADR PAIR] ,OUTF]) NIL)))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \INITSUBRS \PRINTCODE.LEVEL \PRINTCODE.STKSTATE) ) ) (* ; "Analyzing compiled code") (DEFINEQ (CALLSCCODE [LAMBDA (DEF OPTION FNAPPLY) (* DECLARATIONS%: (RECORD RESULT  (LNCALLED CALLED BOUND USEDFREE  GLOBALS))) (* ;  "Edited 1-Dec-92 00:51 by sybalsky:mv:envos") (* ;;; "Analyze DEF for function calls and variable references. Action depends on OPTION as follows:") (* ;;; "OPTION = NIL means return value of CALLSCCODE as described in IRM;") (* ;;; "OPTION = T means return list of free variable references;") (* ;;; "OPTION = APPLY, FNAPPLY, or VARAPPLY means call FNAPPLY on various references and return nothing. FNAPPLY takes two arguments: a symbol and a keyword indicating the type of reference, one of BOUND, USEDFREE, GLOBALS, or CALLED. If OPTION is FNAPPLY, only function references are noticed; if VARAPPLY, only variable bindings and references; otherwise all.") (* ;;; "For OPTION = NIL or T, CALLSCCODE descends into subfunctions.") (PROG ((CODEBASE (OR (\GET-COMPILED-CODE-BASE DEF) (\CODEBLOCKP DEF) (ERROR DEF "not compiled code"))) (IGNOREFNS IGNOREFNS) USEDFREE BOUND GLOBALS CALLED LNCALLED NTSIZE NAME TYPE TAG) (DECLARE (SPECVARS IGNOREFNS)) [COND ((NEQ OPTION 'FNAPPLY) (* ; "Get variables out of name table") (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of CODEBASE)) (for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD) by (BYTESPERNAMEENTRY) as NT2 from (IPLUS (CONSTANT (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD)) (UNFOLD NTSIZE BYTESPERWORD)) by (BYTESPERNTOFFSETENTRY) until [NULL (SETQ NAME (\INDEXATOMVAL (GETNAMEENTRY CODEBASE NT1] do (SETQ TYPE (SELECTQ (NTSLOT-VARTYPE (GETNTOFFSET CODEBASE NT2)) ((IVARCODE PVARCODE) 'BOUND) 'USEDFREE)) (* ; "Top two bits of the entry indicate kind of name: 00(\NT.IVARCODE) = IVAR, 10(\NT.PVARCODE) = PVAR, 11 = FVAR") (SELECTQ OPTION ((VARAPPLY APPLY) (CL:FUNCALL FNAPPLY NAME TYPE)) (SELECTQ TYPE (BOUND (pushnew BOUND NAME)) (pushnew USEDFREE NAME] (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBASE)) B B1 B2 B3 B4 B5 FN LEN) LP (SETQ B (NEXTBYTE)) (SETQ B1 (AND [ILESSP 0 (SETQ LEN (fetch OPNARGS of (SETQ TAG (\FINDOP B] (NEXTBYTE))) (SETQ B2 (AND (ILESSP 1 LEN) (NEXTBYTE))) (SETQ B3 (AND (ILESSP 2 LEN) (NEXTBYTE))) (SETQ B4 (AND (ILESSP 3 LEN) (NEXTBYTE))) (SETQ B5 (AND (ILESSP 4 LEN) (NEXTBYTE))) (SELECTQ (fetch OPCODENAME of TAG) (-X- (RETURN)) ((FN0 FN1 FN2 FN3 FN4) [COND [(FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4] [(FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3] (T (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B1 8) B2] (GO FN)) (FNX [COND [(FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4) 8) B5] [(FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH (IPLUS (LLSH B2 8) B3) 8) B4] (T (SETQ NAME (\INDEXATOMDEF (IPLUS (LLSH B2 8) B3] (GO FN)) (GCONST [SETQ FN (BIG-VMEM-HOST (\VAG2 (IPLUS (LLSH B1 8) B2) (IPLUS (LLSH B3 8) B4)) (\VAG2 B1 (IPLUS (LLSH B2 8) B3] (COND ((AND (OR (type? COMPILED-CLOSURE FN) (\CODEBLOCKP FN)) (NOT (FMEMB FN IGNOREFNS))) (push IGNOREFNS FN) (GO COMPILED-CLOSURE)))) ((GVAR GVAR_) [SELECTQ OPTION (FNAPPLY) ((VARAPPLY APPLY) (CL:FUNCALL FNAPPLY [COND ((FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4))) ((FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (T (\INDEXATOMVAL (IPLUS (LLSH B1 8) B2] 'GLOBALS)) (pushnew GLOBALS (COND ((FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3) 8) B4))) ((FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (\INDEXATOMVAL (IPLUS (LLSH (IPLUS (LLSH B1 8) B2) 8) B3))) (T (\INDEXATOMVAL (IPLUS (LLSH B1 8) B2]) NIL) (GO LP) FN [SELECTQ OPTION ((FNAPPLY APPLY) (CL:FUNCALL FNAPPLY NAME 'CALLED)) (VARAPPLY) (COND ((FMEMB NAME IGNOREFNS) (* ; "Don't show calls to these") ) ((SETQ FN (\SUBFNDEF NAME)) (push IGNOREFNS NAME) (GO COMPILED-CLOSURE)) ((EQ OPTION T) (* ; "Only look at vars") ) (T (pushnew CALLED NAME] (GO LP) COMPILED-CLOSURE (* ;  "Compiled subfunction, recursively analyze it") [LET ((RESULT (CALLSCCODE FN OPTION FNAPPLY))) (AND RESULT (COND ((EQ OPTION T) (* ; "Just got free variables back") (SETQ USEDFREE (RUNION RESULT USEDFREE))) (T (SETQ LNCALLED (RUNION (fetch LNCALLED of RESULT) LNCALLED)) (SETQ BOUND (RUNION (fetch BOUND of RESULT) BOUND)) (SETQ USEDFREE (RUNION (fetch USEDFREE of RESULT) USEDFREE)) (SETQ GLOBALS (RUNION (fetch GLOBALS of RESULT) GLOBALS)) (SETQ CALLED (RUNION (fetch CALLED of RESULT) CALLED] (GO LP)) (RETURN (SELECTQ OPTION ((FNAPPLY VARAPPLY APPLY) NIL) (T (* ; "All free var references") (RUNION USEDFREE GLOBALS)) (create RESULT LNCALLED _ (REVERSE LNCALLED) CALLED _ (REVERSE CALLED) BOUND _ (REVERSE BOUND) USEDFREE _ (REVERSE USEDFREE) GLOBALS _ (REVERSE GLOBALS]) (RUNION (LAMBDA (L1 L2) (* bvm%: "14-Mar-86 14:27") (* ;;; "Fast UNION using EQ") (for X in L1 unless (FMEMB X L2) do (push L2 X)) L2) ) ) (DEFINEQ (CHANGECCODE [LAMBDA (NEWREF OLDREF FN) (* ;  "Edited 13-Nov-92 14:13 by sybalsky:mv:envos") (* ;;; "A reference map is a list (`refmap' E1 ... EN), where each element E has the form (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS). The first element is for the main function, and further elements are for compiler-generated subfunctions. Each LOCS list is a list of byte locations in the code to be fixed up in the indicated way (i.e. VALINDEX, LOLOC, DEFINDEX, and full 24-bit pointer in GCONST format respectively).") (DECLARE (SPECVARS ALL-CODE-BASES)) (* ;  "ALL-CODE-BASES is list of all code bases examined. See CCCSUBFN? for details.") (PROG ((SEAL '"refmap") DEF MAP ALL-CODE-BASES) (SETQ DEF (OR (\GET-COMPILED-CODE-BASE FN) (RETURN))) [COND [(NEQ (CAR (LISTP OLDREF)) SEAL) (* ;  "Construct a reference map for OLDREF in DEF") (COND ((EQ (PROG1 OLDREF (SETQ OLDREF (CONS SEAL (CCCSCAN DEF OLDREF)))) NEWREF) (* ;  "No change, just return reference map") (RETURN OLDREF] ((NEQ (fetch (REFMAP CODEARRAY) of (CADR OLDREF)) DEF) (ERROR '"Inconsistent reference map" (CONS OLDREF FN] (* ;  "Change all references in the map OLDREF to refer to NEWREF") [for MAP in (CDR OLDREF) do (SETQ DEF (fetch CODEARRAY of MAP)) [COND ((OR (fetch NAMELOCS of MAP) (fetch CONSTLOCS of MAP) (fetch DEFLOCS of MAP)) (OR (LITATOM NEWREF) (ERROR "Can't changename a symbol to a non-symbol in compiled code" NEWREF ] [for LC in (fetch NAMELOCS of MAP) do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMVALINDEX NEWREF] [for LC in (fetch CONSTLOCS of MAP) do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMPNAMEINDEX NEWREF] [for LC in (fetch DEFLOCS of MAP) do (CODEBASESETATOM DEF LC (NEW-SYMBOL-CODE NEWREF (\ATOMDEFINDEX NEWREF] (for LC in (fetch PTRLOCS of MAP) do (UNINTERRUPTABLY (* ;; "Decrement ref count of old literal, add new. Order here is such that the worst that happens if it is somehow aborted (despite the UNINTERRUPTABLY) is that the old and new literals never get collected") (\ADDREF NEWREF) (\DELREF (PROG1 (CODEBASELT3 DEF LC) (CODEBASESETA3 DEF LC NEWREF))))] (RETURN OLDREF]) (CCCSUBFN? (LAMBDA (X) (* ; "Edited 9-Jun-88 20:53 by drc:") (DECLARE (USEDFREE ALL-CODE-BASES SUBMAPS OLDREF)) (* ;; "X is a literal found in the code. If X denotes a compiled subfunction, adds X's analysis to SUBMAPS. Subfunctions are either a symbol fnA0nnn or a compiled function object produced by PavCompiler.") (LET ((BASE (CL:TYPECASE X (COMPILED-CLOSURE (\GET-COMPILED-CODE-BASE X)) (LITATOM (AND (SETQ X (\SUBFNDEF X)) (\GET-COMPILED-CODE-BASE X))) (T (\CODEBLOCKP X))))) (if (AND BASE (NOT (FMEMB BASE ALL-CODE-BASES))) then (push ALL-CODE-BASES BASE) (* ;; "break circles by remembering what we've already analyzed in ALL-CODE-BASES") (SETQ SUBMAPS (NCONC SUBMAPS (CCCSCAN BASE OLDREF)))))) ) (\SUBFNDEF (LAMBDA (X) (* bvm%: " 7-Jul-86 16:31") (AND (LITATOM X) (EQ (NTHCHARCODE X -5) (CHARCODE A)) (NOT (find I C from -4 to -1 suchthat (OR (ILESSP (SETQ C (NTHCHARCODE X I)) (CHARCODE 0)) (IGREATERP C (CHARCODE 9))))) (\GET-COMPILED-DEFINITION X))) ) (CCCSCAN [LAMBDA (DEF OLDREF) (DECLARE (SPECVARS SUBMAPS OLDREF)) (* ;  "Edited 13-Nov-92 14:09 by sybalsky:mv:envos") (* ;; "Scan the code block DEF for instances of the symbol OLDREF. Return a list of the instances and their locations, for use in doing CHANGENAME, e.g.") (PROG ((CA DEF) CONSTLOCS DEFLOCS PTRLOCS SUBMAPS NAMELOCS TAG B NAME CODELOC) (SETQ CODELOC (fetch (FNHEADER STARTPC) of CA)) [COND ((LITATOM OLDREF) (for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD) by (CONSTANT (BYTESPERNAMEENTRY)) do (OR (SETQ NAME (\INDEXATOMVAL (CODEBASEGETNAME CA NT1))) (RETURN)) (AND (EQ NAME OLDREF) (push NAMELOCS NT1] LP (SETQ B (CODEBASELT CA CODELOC)) (SETQ TAG (\FINDOP B)) (add CODELOC (fetch OPNARGS of TAG) 1) (SELECTQ (OR (fetch OPPRINT of TAG) (fetch OPCODENAME of TAG)) (-X- (RETURN (CONS (create REFMAP CODEARRAY _ CA NAMELOCS _ NAMELOCS CONSTLOCS _ CONSTLOCS DEFLOCS _ DEFLOCS PTRLOCS _ PTRLOCS) SUBMAPS))) ((FN FNX) [SETQ NAME (CODEBASEGETATOM CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM] [COND ([AND (LITATOM OLDREF) (EQP NAME (NEW-SYMBOL-CODE OLDREF (\ATOMDEFINDEX OLDREF] (push DEFLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM] (CCCSUBFN? (\INDEXATOMDEF NAME))) (ATOM [SETQ NAME (CODEBASEGETATOM CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM] [COND ([AND (LITATOM OLDREF) (EQ NAME (NEW-SYMBOL-CODE OLDREF (\ATOMPNAMEINDEX OLDREF] (push CONSTLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM] (CCCSUBFN? (\INDEXATOMPNAME NAME))) (GCONST [COND ((EQ [SETQ NAME (CODEBASELT3 CA (IDIFFERENCE CODELOC (BYTESPERCODEATOM] OLDREF) (push PTRLOCS (IDIFFERENCE CODELOC (BYTESPERCODEATOM] (CCCSUBFN? NAME)) NIL) (GO LP]) (\CODEBLOCKP (LAMBDA (PTR) (* ; "Edited 5-Apr-88 18:49 by bvm") (* ;; "Returns PTR if it is a pointer to a raw code block, else NIL. Code blocks come in two varieties: code hunks and code arrayblocks. Hunks are easy to check, because they have a distinct type. Arrayblocks are tricky to check, because they are typeless. The code here assumes that if you pass a typeless pointer, it is a pointer to the start of an object. If you pass a pointer to the middle of a bitmap, for example, you could, if you were very unlucky, get a false positive.") (AND (LET ((TEM (NTYPX PTR))) (if (EQ TEM 0) then (* ;; "Maybe arrayblock. Carefully check that: it is in the range for arrayspace; its header (the previous cell) exists and contains the magic arrayblock password, the block's type is code, the block is in use, and its trailer is well-formed.") (AND (>= (\HILOC PTR) \FirstArraySegment) (PROGN (SETQ TEM (\ADDBASE PTR (- \ArrayBlockHeaderWords))) (OR (>= (fetch (POINTER WORDINPAGE) of PTR) \ArrayBlockHeaderWords) (\VALIDADDRESSP TEM))) (EQ (fetch (ARRAYBLOCK PASSWORD) of TEM) \ArrayBlockPassword) (EQ (fetch (ARRAYBLOCK GCTYPE) of TEM) CODEBLOCK.GCT) (fetch (ARRAYBLOCK INUSE) of TEM) (\VALIDADDRESSP (SETQ TEM (fetch (ARRAYBLOCK TRAILER) of TEM))) (EQ (fetch (ARRAYBLOCK PASSWORD) of TEM) \ArrayBlockPassword)) elseif (fetch DTDHUNKP of (SETQ TEM (\GETDTD TEM))) then (* ; "It's a hunk, check the hunk's gc type") (EQ (fetch DTDGCTYPE of TEM) CODEBLOCK.GCT))) PTR)) ) ) (DEFINEQ (\MAP-CODE-POINTERS [LAMBDA (CODEBLOCK MAPFN) (* ;  "Edited 13-Nov-92 14:11 by sybalsky:mv:envos") (* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each pointer we find (i.e., GCONST). MAPFN is called with three args: the pointer, CODEBLOCK, and the byte offset in CODEBLOCK where the pointer lives.") (COND ((NEQ [LET ((TYPENO (NTYPX CODEBLOCK))) (COND [(EQ TYPENO 0) (fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS \ArrayBlockHeaderWords ] (T (fetch DTDGCTYPE of (\GETDTD TYPENO] CODEBLOCK.GCT) (ERROR "ARG NOT Compiled Code Block" CODEBLOCK)) (T (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK)) TAG) LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC))) (add CODELOC 1) (SELECTQ (fetch OPCODENAME of TAG) (-X- (RETURN)) (GCONST (CL:FUNCALL MAPFN (CODEBASELT3 CODEBLOCK CODELOC) CODEBLOCK CODELOC)) NIL) (add CODELOC (fetch OPNARGS of TAG)) (GO LP]) (\MAP-CODE-LITERALS [LAMBDA (CODEBLOCK MAPFN) (* ;  "Edited 13-Nov-92 15:35 by sybalsky:mv:envos") (* ;; "CODEBLOCK is pointer to base of compiled code block. We walk thru the code and apply MAPFN to each literal we find (i.e., GCONST). MAPFN is called with four args: the literal, CODEBLOCK, the byte offset in CODEBLOCK where the literal lives, and the type of literal, one of ATOM, FN or POINTER. If you're only interested in pointers, the speedier \MAP-CODE-POINTERS is more appropriate.") (COND ((NEQ [LET ((TYPENO (NTYPX CODEBLOCK))) (COND [(EQ TYPENO 0) (fetch (ARRAYBLOCK GCTYPE) of (\ADDBASE CODEBLOCK (IMINUS \ArrayBlockHeaderWords ] (T (fetch DTDGCTYPE of (\GETDTD TYPENO] CODEBLOCK.GCT) (ERROR "ARG NOT Compiled Code Block" CODEBLOCK)) (T (PROG ((CODELOC (fetch (FNHEADER STARTPC) of CODEBLOCK)) TAG) (for NT1 from (UNFOLD (fetch (FNHEADER OVERHEADWORDS) of T) BYTESPERWORD) by (BYTESPERNAMEENTRY) do (CL:FUNCALL MAPFN (OR (\INDEXATOMVAL (GETNAMEENTRY CODEBLOCK NT1)) (RETURN)) CODEBLOCK NT1 'ATOM)) LP (SETQ TAG (\FINDOP (CODEBASELT CODEBLOCK CODELOC))) (add CODELOC (fetch OPNARGS of TAG) 1) (SELECTQ (OR (fetch OPPRINT of TAG) (fetch OPCODENAME of TAG)) (-X- (RETURN)) ((FN FNX) (CL:FUNCALL MAPFN [\INDEXATOMDEF (CODEBASELT3 CODEBLOCK (IDIFFERENCE CODELOC ( BYTESPERCODEATOM ] CODEBLOCK (IDIFFERENCE CODELOC (BYTESPERCODEATOM)) 'FN)) (ATOM (CL:FUNCALL MAPFN [\INDEXATOMPNAME (CODEBASELT3 CODEBLOCK (IDIFFERENCE CODELOC ( BYTESPERCODEATOM ] CODEBLOCK (IDIFFERENCE CODELOC (BYTESPERCODEATOM)) 'ATOM)) (GCONST (CL:FUNCALL MAPFN (\VAG2 (CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 4)) (CODEBASELT2 CODEBLOCK (IDIFFERENCE CODELOC 2))) CODEBLOCK (IDIFFERENCE CODELOC 4) 'POINTER)) NIL) (GO LP]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: CALLSCCODE CALLSCCODE RUNION) (BLOCK%: CHANGECCODE CHANGECCODE CCCSUBFN? CCCSCAN) ) (* ;; "MACROS/OPTIMIZERS for getting and setting symbol entries in a compiled-code block. These are parameterized to allow for 2-, 3-, and 4-byte symbol representations." ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD REFMAP (CODEARRAY NAMELOCS CONSTLOCS DEFLOCS PTRLOCS)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS CODEBASELT MACRO [OPENLAMBDA (CODEBASE OFFSET) (COND ((fetch (FNHEADER BYTESWAPPED) of CODEBASE) (\GETBASEBYTE CODEBASE (LOGXOR OFFSET 3))) (T (\GETBASEBYTE CODEBASE OFFSET]) (PUTPROPS CODEBASELT2 MACRO [OPENLAMBDA (DEF LC) (LOGOR (LLSH (CODEBASELT DEF LC) BITSPERBYTE) (CODEBASELT DEF (ADD1 LC]) (PUTPROPS CODEBASESETA MACRO [OPENLAMBDA (CODEBASE OFFSET NEWVALUE) (COND ((fetch (FNHEADER BYTESWAPPED) of CODEBASE) (\PUTBASEBYTE CODEBASE (LOGXOR OFFSET 3) NEWVALUE)) (T (\PUTBASEBYTE CODEBASE OFFSET NEWVALUE]) (PUTPROPS CODEBASESETA2 MACRO [OPENLAMBDA (DEF LC VALUE) (CODEBASESETA DEF LC (LRSH VALUE BITSPERBYTE)) (CODEBASESETA DEF (ADD1 LC) (IMOD VALUE (CONSTANT (LLSH 1 BITSPERBYTE]) (PUTPROPS CODEBASELT3 MACRO [OPENLAMBDA (DEF LC) (BIG-VMEM-CODE [\VAG2 (LOGOR (LLSH (CODEBASELT DEF LC) BITSPERBYTE) (CODEBASELT DEF (ADD1 LC))) (LOGOR (LLSH (CODEBASELT DEF (IPLUS 2 LC)) BITSPERBYTE) (CODEBASELT DEF (IPLUS 3 LC] (\VAG2 (CODEBASELT DEF LC) (LOGOR (LLSH (CODEBASELT DEF (IPLUS 1 LC)) BITSPERBYTE) (CODEBASELT DEF (IPLUS 2 LC]) (PUTPROPS CODEBASELT4 MACRO [OPENLAMBDA (DEF LC) (BIG-VMEM-CODE [\VAG2 (LOGOR (LLSH (CODEBASELT DEF LC) BITSPERBYTE) (CODEBASELT DEF (ADD1 LC))) (LOGOR (LLSH (CODEBASELT DEF (IPLUS 2 LC)) BITSPERBYTE) (CODEBASELT DEF (IPLUS 3 LC] (\VAG2 (CODEBASELT DEF LC) (LOGOR (LLSH (CODEBASELT DEF (IPLUS 1 LC)) BITSPERBYTE) (CODEBASELT DEF (IPLUS 2 LC]) (PUTPROPS CODEBASESETA3 MACRO [OPENLAMBDA (DEF LC VALUE) (CODEBASESETA DEF LC (\HILOC VALUE)) (CODEBASESETA DEF (ADD1 LC) (LRSH (\LOLOC VALUE) BITSPERBYTE)) (CODEBASESETA DEF (IPLUS 2 LC) (IMOD (\LOLOC VALUE) (CONSTANT (LLSH 1 BITSPERBYTE]) (PUTPROPS CODEBASESETA4 MACRO [OPENLAMBDA (DEF LC VALUE) (CODEBASESETA DEF LC (LRSH (\HILOC VALUE) BITSPERBYTE)) [CODEBASESETA DEF (ADD1 LC) (IMOD (\HILOC VALUE) (CONSTANT (LLSH 1 BITSPERBYTE] (CODEBASESETA DEF (IPLUS 2 LC) (LRSH (\LOLOC VALUE) BITSPERBYTE)) (CODEBASESETA DEF (IPLUS 3 LC) (IMOD (\LOLOC VALUE) (CONSTANT (LLSH 1 BITSPERBYTE]) ) (DEFOPTIMIZER CODEBASESETATOM (DEFINITION OFFSET SYMBOL &ENVIRONMENT ENV) [COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASESETA4 ,DEFINITION ,OFFSET ,SYMBOL] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASESETA3 ,DEFINITION ,OFFSET ,SYMBOL] (T `(CODESETA2 ,DEFINITION ,OFFSET ,SYMBOL]) (DEFOPTIMIZER CODEBASEGETATOM (DEFINITION OFFSET SYMBOL &ENVIRONMENT ENV) (* ;; "Get an atom out of a compiled function definition.") [COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASELT4 ,DEFINITION ,OFFSET] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASELT3 ,DEFINITION ,OFFSET] (T `(CODEBASELT2 ,DEFINITION ,OFFSET ,SYMBOL]) (DEFOPTIMIZER CODEBASEGETNAME (BASE OFFSET &ENVIRONMENT ENV) [COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASEGETATOM ,BASE ,OFFSET] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CODEBASEGETATOM ,BASE ,OFFSET] (T `(CODEBASELT2 ,BASE ,OFFSET]) (DEFOPTIMIZER BYTESPERCODEATOM (&ENVIRONMENT ENV) [COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CONSTANT 4)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(CONSTANT 3)) (T `(CONSTANT 2]) (DEFOPTIMIZER BIG-VMEM-HOST (NEW-SYMBOL-FORM OLD-SYMBOL-FORM &ENVIRONMENT ENV) (* ;;  "Allow for differences between 4-byte pointers and 3-byte pointers..") `(COND ((FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) ,NEW-SYMBOL-FORM) (T ,OLD-SYMBOL-FORM))) (FILESLOAD (LOADCOMP) LLGC LLCODE LLBASIC MODARITH RENAMEMACROS) ) (ADDTOVAR IGNOREFNS ) (* ; "Maintaining ref count consistency in code") (DEFINEQ (\COPYCODEBLOCK (LAMBDA (NEWCA OLDCA NWORDS NEWFN) (* ; "Edited 3-Mar-87 22:28 by bvm:") (* ;; "Copies code from an old code block OLDCA to a new block NEWCA. Length of the code in words is NWORDS. NEWFN is optional new frame name for the code.") (UNINTERRUPTABLY (\BLT NEWCA OLDCA NWORDS) (* ;; "now have to fix up ref counts. First increment ref count of everything in a GCONST") (\MAP-CODE-POINTERS NEWCA (FUNCTION (LAMBDA (PTR) (\ADDREF PTR)))) (* ;; "Then ref count the frame name (usually a no-op, if it's a symbol, but be careful anyway).") (\ADDREF (IF NEWFN THEN (replace (FNHEADER %#FRAMENAME) of NEWCA with NEWFN) NEWFN ELSE (fetch (FNHEADER %#FRAMENAME) of NEWCA))) NEWCA)) ) (\COPYFNHEADER (LAMBDA (FNHD) (* ; "Edited 3-Mar-87 22:39 by bvm:") (* ;; "Returns a copy of just the header portion of FNHD -- the fixed header plus name table. This is useable as a NAMETABLE on the stack, but not as code.") (PROG ((HEADWORDS (UNFOLD (fetch (FNHEADER NTSIZE) of FNHD) 2)) NEWFNHD) (SETQ HEADWORDS (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) (COND ((EQ HEADWORDS 0) (* ; "No name table, but still need to copy quad of zeros") WORDSPERQUAD) (T HEADWORDS)))) (SETQ NEWFNHD (\ALLOC.CODE.BLOCK (UNFOLD HEADWORDS BYTESPERCELL) HEADWORDS)) (* ; "make it a code block, not just a regular block, so gc knows how to reclaim it") (UNINTERRUPTABLY (\BLT NEWFNHD FNHD HEADWORDS) (replace (FNHEADER STARTPC) of NEWFNHD with 0) (* ; "make it unexecutable. \RECLAIMCODEBLOCK also cares about this.") (\ADDREF (fetch (FNHEADER FRAMENAME) of NEWFNHD))) (RETURN NEWFNHD))) ) (\RECLAIMCODEBLOCK (LAMBDA (CODEBASE) (* ; "Edited 6-May-88 13:01 by amd") (* ;; "Finalization for code hunks; also called by RECLAIMCODEBLOCK. Decrements the reference count of all the literals in the block.") (COND ((AND SI::*CLOSURE-CACHE-ENABLED* (XCL::GET-IMPLICIT-KEY-HASH CODEBASE SI::*CLOSURE-CACHE*)) (* ;; "clear cache entry") (CL:SETF (XCL::GET-IMPLICIT-KEY-HASH CODEBASE SI::*CLOSURE-CACHE*) NIL) (* ;; "and don't reclaim (code block will be reclaimed next time 'round)") T) (T (\DELREF (fetch (FNHEADER FRAMENAME) of CODEBASE)) (IF (NEQ (fetch (FNHEADER STARTPC) of CODEBASE) 0) THEN (* ;; "Code block never got filled in, or it's a vestigial one from \COPYFNHEADER") (\MAP-CODE-POINTERS CODEBASE (FUNCTION (LAMBDA (PTR) (OR (EQ PTR CODEBASE) (\DELREF PTR)))))) (* ;; "Return NIL to say it's ok to reclaim it now") NIL))) ) ) (* ; "Low-level break") (DEFINEQ (LLBREAK (LAMBDA (FN WHEN) (DECLARE (GLOBALVARS BROKENFNS)) (* ; "Edited 15-Apr-87 18:33 by bvm:") (PROG (NUFN DEF) (COND ((GETPROP FN (QUOTE BROKEN)) (XCL:UNBREAK-FUNCTION FN))) (OR (SETQ DEF (\GET-COMPILED-DEFINITION FN)) (ERROR FN "is not compiled code")) (/SETATOMVAL (QUOTE BROKENFNS) (CONS FN BROKENFNS)) (/PUTD (SETQ NUFN (PACK* FN (GENSYM (QUOTE L)))) DEF T) (/PUTPROP FN (QUOTE BROKEN) NUFN) (/PUTD FN (create COMPILED-CLOSURE using DEF FNHEADER _ (BROKENDEF DEF WHEN))) (RETURN FN))) ) (BROKENDEF [LAMBDA (DEF WHEN) (* ; "Edited 25-Jun-2017 22:16 by rmk:") (PROG ((CA (\GET-COMPILED-CODE-BASE DEF)) BEFORE AFTER SIZE FIRSTBYTE NEWCA) (SETQ FIRSTBYTE (fetch (FNHEADER STARTPC) of CA)) (UNLESSRDSYS (SELECTQ WHEN (BEFORE (SETQ BEFORE T)) (AFTER (SETQ AFTER T)) ((NIL BOTH) (SETQ BEFORE T) (SETQ AFTER T)) (LISPERROR "ILLEGAL ARG" WHEN))) (* ;  "Check validity of WHEN before going uninterruptable") (UNINTERRUPTABLY (* ;  "Uninterruptable because of ref count modification") (UNLESSRDSYS (PROGN (* ;  "Locally, create new code block and copy into it") (SETQ SIZE (UNFOLD (\#BLOCKDATACELLS CA) BYTESPERCELL)) (SETQ NEWCA (\ALLOC.CODE.BLOCK (+ (COND (BEFORE 3) (T 0)) SIZE) (CEIL (ADD1 (FOLDHI FIRSTBYTE BYTESPERCELL)) CELLSPERQUAD))) (COND (BEFORE (* ; "Need to insert preamble code") (\MOVEBYTES CA 0 NEWCA 0 FIRSTBYTE) (* ; "Copy header") [PROGN (* ;  "insert call to RAID followed by a POP") [CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP '%'NIL] [CODEBASESETA NEWCA (+ FIRSTBYTE 1) (CAR (\FINDOP 'RAID] (CODEBASESETA NEWCA (+ FIRSTBYTE 2) (CAR (\FINDOP 'POP] (\MOVEBYTES CA FIRSTBYTE NEWCA (+ FIRSTBYTE 3) (- SIZE FIRSTBYTE)) (add FIRSTBYTE 3)) (T (* ; "Just copy verbatim") (\MOVEBYTES CA 0 NEWCA 0 SIZE))) (\ADDREF (fetch (FNHEADER FRAMENAME) of NEWCA)) (* ; "count reference to framename") ) (PROGN (* ;  "For Teleraid, can't create new code blocks, so can only make break AFTER") (SETQ NEWCA CA) (SETQ AFTER T))) (* ; "rmk: Remove (GO DOSCAN), since there is no place to go. Seems reasonable to fall through to the AFTER test, if AFTER was just set.") [COND (AFTER (* ; "Change all RETURNs to \RETURN") (bind OP do (SELECTQ [fetch (OPCODE OPCODENAME) of (SETQ OP (\FINDOP (CODEBASELT NEWCA FIRSTBYTE] (-X- (RETURN)) (GCONST [UNLESSRDSYS (\ADDREF (\VAG2 (CODEBASELT NEWCA (+ FIRSTBYTE 1)) (CODEBASELT2 NEWCA (+ FIRSTBYTE 2]) (RETURN [CODEBASESETA NEWCA FIRSTBYTE (CAR (\FINDOP '\RETURN]) NIL) (add FIRSTBYTE 1 (fetch (OPCODE OPNARGS) of OP]) (RETURN NEWCA]) ) (* ; "for TELERAID") (DECLARE%: DONTCOPY (ADDTOVAR RDCOMS (FNS PRINTCODE PRINTCODENT BROKENDEF)) (ADDTOVAR EXPANDMACROFNS NEXTBYTE PCVAR PRINJUMP CODEBASELT CODEBASELT2 CODEBASESETA CODEBASESETA2 PRINTCODEHEADERDECODE) ) (* ; "reference to opcodes symbolically") (DEFINEQ (PRINTOPCODES (LAMBDA (SINGLE) (* lmm "22-Mar-85 10:34") (printout NIL " #" 9 "name" 24 "len-1" 34 "format" 43 "stk effect" 55 "UFN table entry" T T) (for X in (COND (SINGLE (LIST (\FINDOP SINGLE))) (T \OPCODES)) do (LET ((OP (fetch OP# of X))) (COND ((LISTP OP) (printout NIL |.I3.8| (CAR OP) "-" (CADR OP))) (T (printout NIL |.I3.8| OP)))) (TAB 9) (PRIN1 (fetch OPCODENAME of X)) (COND ((NEQ (fetch OPCODENAME of X) (QUOTE unused)) (printout NIL 26 (OR (fetch OPNARGS of X) (QUOTE ?)) 35 (OR (fetch OPPRINT of X) (QUOTE ?)) 44 (OR (fetch LEVADJ of X) (QUOTE ?)) 55 (OR (fetch UFNFN of X) "")))) (TERPRI))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \OPCODES) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS ACODE COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1995 2017)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3122 23643 (PRINTCODE 3132 . 21458) (PRINTCODENT 21460 . 23641)) (29183 41340 ( CALLSCCODE 29193 . 41196) (RUNION 41198 . 41338)) (41341 50049 (CHANGECCODE 41351 . 44833) (CCCSUBFN? 44835 . 45546) (\SUBFNDEF 45548 . 45810) (CCCSCAN 45812 . 48567) (\CODEBLOCKP 48569 . 50047)) (50050 55143 (\MAP-CODE-POINTERS 50060 . 51603) (\MAP-CODE-LITERALS 51605 . 55141)) (61350 63784 ( \COPYCODEBLOCK 61360 . 62055) (\COPYFNHEADER 62057 . 62938) (\RECLAIMCODEBLOCK 62940 . 63782)) (63817 69146 (LLBREAK 63827 . 64326) (BROKENDEF 64328 . 69144)) (69473 70099 (PRINTOPCODES 69483 . 70097)))) ) STOP \ No newline at end of file diff --git a/sources/ADDARITH b/sources/ADDARITH new file mode 100644 index 00000000..377f34af --- /dev/null +++ b/sources/ADDARITH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 11:46:37" {DSK}local>lde>lispcore>sources>ADDARITH.;2 27815 changes to%: (VARS ADDARITHCOMS) previous date%: "30-Mar-89 11:13:59" {DSK}local>lde>lispcore>sources>ADDARITH.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ADDARITHCOMS) (RPAQQ ADDARITHCOMS ((LOCALVARS . T) (* ; "OK") (MACROS MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR) (COMS (OPTIMIZERS LOGNOT) (FNS LOGNOT)) (COMS (* ; "BYTE hacking functions") (MACROS LOADBYTE DEPOSITBYTE) (MACROS BYTESIZE BYTEPOSITION)) (COMS (OPTIMIZERS IMOD) (FNS IMODLESSP) (MACROS IMODPLUS IMODDIFFERENCE)) (COMS (FNS ROT) (MACROS .ROT.)) (COMS (* ;; "Primitive Functions for extracting fields as integers") (MACROS \XLOADBYTEWORD) (FNS \PUTBASEBITS) (* ;; "Primitive functions, especially needed for CommonLisp array package.") (DECLARE%: DONTCOPY (MACROS .HIHALFWORDLO. .HIHALFWORDHI. .LOHALFWORDLO. .LOHALFWORDHI. ))) (COMS (* ;;  "Beginning of rewrite of some LLARITH things, modularly using the macros of this file") (DECLARE%: DONTCOPY (EXPORT (CONSTANTS MASK0WORD1'S MASK1WORD0'S MASKWORD1'S MASKHALFWORD1'S BITSPERHALFWORD) (MACROS EQZEROP) (MACROS \MOVETOBOX .XUNBOX. .XLLSH. .XLLSH1. .XLRSH. .ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.) (MACROS .SUMSMALLMOD. .DIFFERENCESMALLMOD.) (MACROS \GETBASENIBBLE \PUTBASENIBBLE \GETBASEBIT \PUTBASEBIT)) (MACROS .ADD.2WORD.INTEGERS. .SUB.2WORD.INTEGERS. .32BITMUL.))) (PROP (MAKEFILE-ENVIRONMENT FILETYPE) ADDARITH))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (* ; "OK") (DECLARE%: EVAL@COMPILE (PUTPROPS MASK.1'S MACRO (OPENLAMBDA (POSITION SIZE) (LSH (SUB1 (LSH 1 SIZE)) POSITION))) (PUTPROPS MASK.0'S MACRO (OPENLAMBDA (POSITION SIZE) (LOGNOT (MASK.1'S POSITION SIZE)))) (PUTPROPS BITTEST MACRO ((N MASK) (NEQ 0 (LOGAND N MASK)))) (PUTPROPS BITSET MACRO (= . LOGOR)) (PUTPROPS BITCLEAR MACRO ((X MASK) (LOGAND X (LOGNOT MASK)))) ) (DEFOPTIMIZER LOGNOT (INTEGER) `(LOGXOR -1 ,INTEGER)) (DEFINEQ (LOGNOT [LAMBDA (INTEGER) (* kbr%: "12-Jul-86 17:05") (LOGXOR -1 INTEGER]) ) (* ; "BYTE hacking functions") (DECLARE%: EVAL@COMPILE (PUTPROPS LOADBYTE MACRO ((N POS SIZE) (LOGAND (LSH N (IMINUS POS)) (MASK.1'S 0 SIZE)))) (PUTPROPS DEPOSITBYTE MACRO (OPENLAMBDA (N POS SIZE VAL) (LOGOR (BITCLEAR N (MASK.1'S POS SIZE)) (LSH (LOGAND VAL (MASK.1'S 0 SIZE)) POS)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BYTESIZE MACRO ((BYTESPEC) (BYTE-SIZE BYTESPEC))) (PUTPROPS BYTEPOSITION MACRO ((BYTESPEC) (CL:BYTE-POSITION BYTESPEC))) ) (DEFOPTIMIZER IMOD (&REST L) [PROG [(N (CONSTANTEXPRESSIONP (CADR L] (if (NULL N) then (RETURN 'IGNOREMACRO)) (SETQ N (CAR N)) (RETURN (COND ((NOT (POWEROFTWOP N)) 'IGNOREMACRO) (T (LIST 'LOGAND (CAR L) (SUB1 N]) (DEFINEQ (IMODLESSP [LAMBDA (X Y MODULUS) (* lmm "12-Apr-85 12:43") (ILESSP (IMODDIFFERENCE Y X MODULUS) (FOLDHI MODULUS 2]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS IMODPLUS MACRO ((X Y MODULUS) (IMOD (IPLUS X Y) MODULUS))) (PUTPROPS IMODDIFFERENCE MACRO ((X Y MODULUS) (IMOD (IDIFFERENCE X Y) MODULUS))) ) (DEFINEQ (ROT [LAMBDA (X N FIELDSIZE) (* Pavel " 7-Oct-86 15:26") (* ;; "Normalize N, the shift factor, into the half-open interval of 0 to FIELDSIZE and transform a negative N (rotating rightwards) into a positive form.") (LET* ((N (IMOD N FIELDSIZE)) (N.B (IDIFFERENCE FIELDSIZE N))) (DEPOSITBYTE (LOADBYTE X N.B N) N N.B X]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .ROT. MACRO ((XFORM N FIELDSIZE) ((OPENLAMBDA (X) (DEPOSITBYTE (LOADBYTE X (IDIFFERENCE FIELDSIZE N) N) N (IDIFFERENCE FIELDSIZE N) X)) XFORM))) ) (* ;; "Primitive Functions for extracting fields as integers") (DECLARE%: EVAL@COMPILE (PUTPROPS \XLOADBYTEWORD DMACRO [(N POS SIZE) (* ; "N is constrained to be a SMALLP") (LOGAND (\XLRSHWORD N POS) (MASK.1'S 0 (IMIN BITSPERWORD SIZE]) ) (DEFINEQ (\PUTBASEBITS [LAMBDA (ADDR POSITION SIZE VAL) (* lmm "12-Apr-85 15:18") (if (GREATERP POSITION BITSPERWORD) then (\PUTBASEBITS (\ADDBASE ADDR (FOLDLO POSITION BITSPERWORD)) (IMOD POSITION BITSPERWORD) SIZE VAL) elseif (GREATERP SIZE (DIFFERENCE BITSPERWORD POSITION)) then (* ; "more than one word") [\PUTBASEBITS ADDR POSITION (DIFFERENCE BITSPERWORD POSITION) (RSH VAL (SETQ SIZE (DIFFERENCE SIZE (DIFFERENCE BITSPERWORD POSITION] (\PUTBASEBITS (\ADDBASE ADDR 1) 0 SIZE VAL) else (* ; "a single word") (\PUTBASE ADDR 0 (DEPOSITBYTE (\GETBASE ADDR 0) (DIFFERENCE (SUB1 BITSPERWORD) POSITION) SIZE VAL]) ) (* ;; "Primitive functions, especially needed for CommonLisp array package.") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS .HIHALFWORDLO. MACRO ((X) (LRSH X BITSPERHALFWORD))) (PUTPROPS .HIHALFWORDHI. MACRO [(X) (LOGAND X (CONSTANT (LSH MASKHALFWORD1'S BITSPERHALFWORD]) (PUTPROPS .LOHALFWORDLO. MACRO ((X) (LOGAND X MASKHALFWORD1'S))) (PUTPROPS .LOHALFWORDHI. MACRO ((X) (LLSH (LOGAND X MASKHALFWORD1'S) BITSPERHALFWORD))) ) ) (* ;; "Beginning of rewrite of some LLARITH things, modularly using the macros of this file") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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) ) (DECLARE%: EVAL@COMPILE (PUTPROPS EQZEROP MACRO ((X) (EQ 0 X))) ) (DECLARE%: EVAL@COMPILE (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)))) ) (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (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)))) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (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 ADDARITH MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 )) (PUTPROPS ADDARITH FILETYPE CL:COMPILE-FILE) (PUTPROPS ADDARITH COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3219 3360 (LOGNOT 3229 . 3358)) (4685 4874 (IMODLESSP 4695 . 4872)) (5230 5657 (ROT 5240 . 5655)) (6505 7564 (\PUTBASEBITS 6515 . 7562))))) STOP \ No newline at end of file diff --git a/sources/ADIR b/sources/ADIR new file mode 100644 index 00000000..70e619b7 --- /dev/null +++ b/sources/ADIR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "29-Jun-2017 15:36:08" {DSK}Personal>local>medley3.5>sources>ADIR.;10 46943 changes to%: (VARS ADIRCOMS) (FNS INTERPRET.REM.CM) previous date%: "28-Jun-2017 23:35:49" {DSK}Personal>local>medley3.5>sources>ADIR.;7 ) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1920, 2017 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ADIRCOMS) (RPAQQ ADIRCOMS [[COMS (* ; "user-level i/o routines") (FNS DELFILE FULLNAME INFILE INFILEP IOFILE OPENFILE OPENSTREAM OUTFILE OUTFILEP RENAMEFILE SIMPLE.FINDFILE) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) (P (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP] (COMS (FNS UNPACKFILENAME UNPACKFILENAME.STRING LASTCHPOS \UPF.NEXTPOS \UPF.TEMPFILEP FILENAMEFIELD PACKFILENAME PACKFILENAME.STRING) (DECLARE%: DONTCOPY (MACROS CANONICAL.DIRECTORY UNPACKFILE1.DIRECTORY PACKFILENAME.ASSEMBLE UNPACKFILE1)) (VARS \FILENAME.SYNTAX) (GLOBALVARS \FILENAME.SYNTAX)) (COMS (* ;  "saving and restoring system state") (FNS LOGOUT MAKESYS SYSOUT SAVEVM HERALD INTERPRET.REM.CM \USEREVENT) (ADDVARS (AROUNDEXITFNS)) (INITVARS (HERALDSTRING "") (\USERNAME)) (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) (FNS USERNAME SETUSERNAME)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) FILEIO)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PACKFILENAME.STRING PACKFILENAME]) (* ; "user-level i/o routines") (DEFINEQ (DELFILE (LAMBDA (FILE) (* bvm%: "23-Oct-85 11:20") (AND FILE (NEQ FILE T) (\DELETEFILE FILE)))) (FULLNAME (LAMBDA (X RECOG) (* rmk%: "22-AUG-83 13:33") (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T (SELECTQ RECOG (NIL (SETQQ RECOG OLD)) ((OLD OLD/NEW NEW OLDEST)) (\ILLEGAL.ARG RECOG)) (\GETFILENAME X RECOG)))) ) (INFILE (LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:23") (INPUT (OPENFILE FILE (QUOTE INPUT) (QUOTE OLD))))) (INFILEP (LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE OLD)))) (IOFILE (LAMBDA (FILE) (* rmk%: " 5-SEP-81 13:54") (OPENFILE FILE (QUOTE BOTH) (QUOTE OLD)))) (OPENFILE [LAMBDA (FILE ACCESS RECOG PARAMETERS OPTIONAL) (* ; "Edited 23-May-91 19:12 by jds") (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL) else (fetch (STREAM FULLNAME) of (OPENSTREAM FILE ACCESS RECOG PARAMETERS OPTIONAL]) (OPENSTREAM (LAMBDA (FILE ACCESS RECOG PARAMETERS OBSOLETE) (* hdj "28-Aug-86 14:50") (PROG (REC OLDSTREAM STREAM) (SELECTQ ACCESS ((INPUT OUTPUT BOTH APPEND)) (\ILLEGAL.ARG ACCESS)) (SETQ REC (SELECTQ RECOG ((EXACT NEW OLD OLD/NEW OLDEST) RECOG) (NIL (SELECTQ ACCESS (INPUT (QUOTE OLD)) (OUTPUT (QUOTE NEW)) (QUOTE OLD/NEW))) (\ILLEGAL.ARG RECOG))) (if (OR (LISTP OBSOLETE) (AND PARAMETERS (NLISTP PARAMETERS))) then (* ;; "used to have OPENFILE/OPENSTREAM with BYTESIZE and PARAMETERS. Now it will take PARAMETERS, and generally ignore the BYTESIZE") (SETQ PARAMETERS (APPEND (SELECTQ PARAMETERS (7 (QUOTE ((TYPE TEXT)))) (8 (QUOTE ((TYPE BINARY)))) NIL) OBSOLETE))) (COND ((OR (EQ FILE T) (NULL FILE)) (* ;; "Handle T and NIL separately, cause they can return the terminal streams, for which the search isn't necessary and the \ADDOFD shouldn't be done.") (SETQ STREAM (\GETSTREAM FILE ACCESS)) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (RETURN STREAM))) (* ;; "Explicitly test for PATHNAMEP, as PATHNAMEP will have a NILL def early in the loadup, and the tests in \CONVERT-PATHNAME won't break anything") (* ;; "Pavel changed a call to (PATHNAMEP FILE) into (TYPEP FILE `PATHNAME) because PATHNAMEP didn't have a NILL defn early in the loadup and TYPEP has an optimizer on it that compiles away the call to TYPEP which also has no defn early in the loadup.") (* ;; "Pavel also added the call to MKSTRING below as a temporary hack to get around the fact that the Interlisp string functions can't yet handle Common Lisp simple-strings.") (if (TYPEP FILE (QUOTE PATHNAME)) then (SETQ FILE (\CONVERT-PATHNAME FILE))) (* ;; "We open the file before looking to see whether it is already open. This guarantees that we acquire the opening rights at the time we lookup the name. We then check to see if it is currently open in Lisp. If it is, we return the previous stream, which has the file's current state. ") (* ;; "There are still potential problems: First, an interrupt can happen while we are doing the search which causes the file to be deleted or re-opened beneath us, BEFORE it gets added to \OPENFILES. Second, a network device might not allow multiple openings of the file, even by the same guy with the same mode.") (SETQ STREAM (\OPENFILE FILE ACCESS REC PARAMETERS)) (COND ((AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (SETQ OLDSTREAM (\SEARCHOPENFILES (fetch FULLNAME of STREAM)))) (* ;; "There is already a stream open on the file. Check that there is no conflict. Eventually all this registration belongs in the device, so that we can have multiple streams open per file") (COND ((AND (EQ ACCESS (QUOTE INPUT)) (EQ (fetch ACCESS of OLDSTREAM) (QUOTE INPUT))) (* ; "Dispose of the newly-obtained stream, This might be a noop, but a network device (LEAF) cares") (OR (EQ STREAM OLDSTREAM) (\CLOSEFILE STREAM)) (\DO.PARAMS.AT.OPEN OLDSTREAM ACCESS PARAMETERS) (* ; "Do parameters on the old stream") (RETURN OLDSTREAM)) (T (LISPERROR "FILE WON'T OPEN" FILE)))) (T (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (\ADDOFD STREAM)) (* ; "Parameters done on new stream by \OPENFILE") (RETURN STREAM))))) ) (OUTFILE (LAMBDA (FILE) (* rmk%: " 3-OCT-79 14:24") (OUTPUT (OPENFILE FILE (QUOTE OUTPUT) (QUOTE NEW))))) (OUTFILEP (LAMBDA (FILE) (* rmk%: " 9-OCT-79 22:39") (\GETFILENAME FILE (QUOTE NEW)))) (RENAMEFILE (LAMBDA (OLDFILE NEWFILE) (* hdj " 4-Sep-86 16:56") (SETQ OLDFILE (\CONVERT-PATHNAME OLDFILE)) (SETQ NEWFILE (\CONVERT-PATHNAME NEWFILE)) (AND OLDFILE NEWFILE (NEQ OLDFILE T) (NEQ NEWFILE T) (\RENAMEFILE OLDFILE NEWFILE))) ) (SIMPLE.FINDFILE (LAMBDA (FILE DUMMY DIRLST) (* bvm%: "23-Oct-85 11:22") (OR (for DIR in DIRLST when (SETQ $$VAL (INFILEP (PACKFILENAME.STRING (QUOTE DIRECTORY) DIR (QUOTE BODY) FILE))) do (RETURN $$VAL)) (AND (NOT (MEMB NIL DIRLST)) (INFILEP FILE)))) ) ) (DECLARE%: EVAL@COMPILE (RPAQQ MULTIPLE.STREAMS.PER.FILE.ALLOWED T) (CONSTANTS (MULTIPLE.STREAMS.PER.FILE.ALLOWED T)) ) (MOVD? 'SIMPLE.FINDFILE 'FINDFILE NIL T) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "for the benefit of the call to PATHNAMEP in OPENSTREAM. PATHNAMEP (and pathnames) get defined much later in the loadup.") (MOVD? 'NILL 'CL:PATHNAMEP) ) (DEFINEQ (UNPACKFILENAME (LAMBDA (FILE ONEFIELDFLG OSTYPE) (* ; "Edited 6-Jan-88 13:13 by bvm:") (UNPACKFILENAME.STRING FILE ONEFIELDFLG NIL OSTYPE T)) ) (UNPACKFILENAME.STRING (LAMBDA (FILE ONEFIELDFLG DIRFLG OSTYPE PACKFLG CLFLG) (* ; "Edited 30-Mar-90 22:37 by nm") (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (PROG ((POS 1) (LEN (NCHARS FILE)) TEM BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND FIRSTDOT SECONDDOT USEDSEMI) (COND ((NULL FILE) (RETURN NIL)) ((OR (LITATOM FILE) (STRINGP FILE) (NUMBERP FILE))) ((TYPEP FILE (QUOTE PATHNAME)) (RETURN (UNPACKPATHNAME.STRING FILE ONEFIELDFLG DIRFLG PACKFLG))) ((STREAMP FILE) (* ; "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (COND (ONEFIELDFLG (AND (EQ ONEFIELDFLG (QUOTE NAME)) FILE)) (T (LIST (QUOTE NAME) FILE))))))) (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ; "some Xerox and Arpanet systems use '[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ; "this is the 'proposed standard' for Xerox servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (UNPACKFILE1 (QUOTE HOST) 2 TEM) (COND ((EQ TEM -1) (* ; "Started with the host field delimiter, but there was no corresponding terminating delimiter .") (* ; "I'm not sure why the name is dealt with the host name.") (RETURN (DREVERSE VAL)))) (SETQ POS (IPLUS TEM 2)) (if (EQ OSTYPE T) then (* ; "Use actual host to determine os type") (SETQ OSTYPE (GETHOSTINFO (CAR VAL) (QUOTE OSTYPE)))) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (* ; "all device returned have DEVICE.END on it so that NIL: will work") (UNPACKFILE1 (QUOTE DEVICE) POS (if CLFLG then (SUB1 TEM) else TEM)) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (COND ((EQ DIRFLG (QUOTE RETURN)) (* ; "assert that this is a directory; more forgiving about missing trailing delimiter. There are two distinct cases for the missing initial delimiter. If HOST is also specified, it is dealt with as the true %"relative pathname%" by device dependent manner, otherwise it is dealt with following the %"incomplete file names%" convention. In the first case, returns RELATIVEDIRECTORY instead of DIRECTORY and in the second case, returns SUBDIRECTORY.") (LET ((TYPE (QUOTE DIRECTORY)) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (* ; "just host, return") (RETURN (DREVERSE VAL))) ((/ <) (* ; "Started with the initial directory delimiter.") (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) (COND ((EQ START POS) (* ; "Didn't start with a directory delimiter,") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY)))))) (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}/%").") (SETQ START POS) -1) (T -2))) (PROGN (COND ((EQ START POS) (* ; "Both of the initial and trail delimiters are omitted.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case defined in IRM. This is a subdirectory of the current connected directory") (SETQ TYPE (QUOTE SUBDIRECTORY))) (T (* ; "True %"relative pathname%". The way to deal with it is dependent on the device on which HOST is implemented.") (SETQ TYPE (QUOTE RELATIVEDIRECTORY))))) (T (COND ((EQ LEN POS) (* ; "Only the initial directory is specified (i.e. %"{DSK}<%").") (SETQ START POS))))) -1))) (UNPACKFILE1.DIRECTORY TYPE START END)) (RETURN (DREVERSE VAL))) ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ; "unix and the 'xerox standard' use / for delimiter") (* ; "In the case of the {DSK}/FOO>BAR, FOO should be dealt with as a directory.") (SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE (ADD1 POS))) T) ((< >) (* ; "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (* ; "In the case of the {DSK} /)) FILE (ADD1 POS))) T) NIL) (* ;; "allow {DSK}/etc to be a directory specification.") (if TEM then (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) (ADD1 POS) (SUB1 TEM)) (SETQ POS (ADD1 TEM)) else (* ;; "{DSK}/foo: the directory is /, the name is foo") (UNPACKFILE1.DIRECTORY (QUOTE DIRECTORY) POS POS) (SETQ POS (ADD1 POS))) (SETQ HOSTP T)) ((SETQ TEM (LASTCHPOS (CHARCODE (/ >)) FILE POS)) (* ; " {eris}abc> relative") (* ;; " This is the true %"relative pathname%". Returns RELATIVEDIRECTORY instead of DIRECTORY.") (COND ((NOT HOSTP) (* ; "%"Incomplete file names%" case.") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE SUBDIRECTORY)) POS (SUB1 TEM))) (T (* ; "True %"relative pathname%".") (UNPACKFILE1.DIRECTORY (if (EQ DIRFLG (QUOTE FIELD)) then (QUOTE DIRECTORY) else (QUOTE RELATIVEDIRECTORY)) POS (SUB1 TEM)))) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) (OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (DREVERSE VAL))) (if (EQ OSTYPE T) then (* ; "There wasn't a host field in the name, so we have no clue") (SETQ OSTYPE NIL)) NAMELP (* ;; "At this point, CODE is the TEM'th char of file name. POS is the first character of the field we are currently working on.") (SELCHARQ CODE (%. (* ; "Note position for later--we only want to deal with the last set of dots") (if BEYONDNAME then (* ; "no longer of interest (probably a bad name, too)") elseif FIRSTDOT then (* ; "We're recording the second dot") (if SECONDDOT then (* ; "Note only the two most recent dots") (SETQ FIRSTDOT SECONDDOT)) (SETQ SECONDDOT TEM) else (SETQ FIRSTDOT TEM))) ((! ; NIL) (* ; "SUBDIRECTORY, NAME and EXTENSION fields definitely terminated by now") (if (SELCHARQ CODE (! (* ; "! is only a delimiter on IFS, so ignore it if we know the ostype is something else") (AND OSTYPE (NEQ OSTYPE (QUOTE IFS)))) (; (* ; "If we've already parsed the extension, then we have a semi in the middle of the version. Skip it unless it's ;T or ;S") (AND BEYONDEXT (NOT (\UPF.TEMPFILEP FILE (ADD1 TEM))))) NIL) then (GO NEXTCHAR)) (if FIRSTDOT then (* ; "Have a name and/or extension to parse now") (if (AND SECONDDOT (NOT (if OSTYPE then (* ; "Known OS type must be Tops20 for second dot to mean version") (EQ OSTYPE (QUOTE TOPS20)) else (* ; "Unknown OS type, so check that %"version%" is numeric or wildcard") (AND (for I from (ADD1 SECONDDOT) to (SUB1 TEM) bind CH always (OR (DIGITCHARP (SETQ CH (NTHCHARCODE FILE I))) (EQ CH (CHARCODE *)))) (SELCHARQ CODE (NIL (* ; "end of file name, ok") T) (; (* ; "This semi-colon better not be introducing a version") (\UPF.TEMPFILEP FILE (ADD1 TEM))) NIL))))) then (* ; "Second dot is not intoducing a version") (SETQ FIRSTDOT SECONDDOT) (SETQ SECONDDOT NIL)) (UNPACKFILE1 (QUOTE NAME) POS (SUB1 FIRSTDOT)) (SETQ POS (ADD1 (if SECONDDOT then (UNPACKFILE1 (QUOTE EXTENSION) (ADD1 FIRSTDOT) (SUB1 SECONDDOT)) (SETQ BEYONDEXT T) SECONDDOT else FIRSTDOT))) (SETQ BEYONDNAME T) (SETQ FIRSTDOT NIL)) (UNPACKFILE1 (COND ((NOT BEYONDNAME) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (QUOTE EXTENSION)) ((AND (EQ BEYONDEXT (CHARCODE ";")) (\UPF.TEMPFILEP FILE POS))) (T (* ; "Everything after the semi was version") (QUOTE VERSION))) POS (SUB1 TEM)) (if (NULL CODE) then (* ; "End of string") (RETURN (DREVERSE VAL))) (SETQ BEYONDEXT CODE) (* ; "Note the character that terminated the name/ext") (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP))) ) (LASTCHPOS (LAMBDA (CH STR START) (* ; "Edited 17-May-88 13:43 by MASINTER") (PROG (RESULT NC) (OR START (SETQ START 1)) (while (SETQ NC (NTHCHARCODE STR START)) do (COND ((EQMEMB NC CH) (SETQ RESULT START)) ((EQ NC (CHARCODE %')) (add START 1))) (add START 1)) (RETURN RESULT))) ) (\UPF.NEXTPOS (LAMBDA (CHAR STRING POS) (* lmm " 5-Oct-84 18:41") (bind NCH while (SETQ NCH (NTHCHARCODE STRING POS)) do (COND ((EQMEMB NCH CHAR) (RETURN POS)) ((EQ NCH (CHARCODE %')) (add POS 1))) (add POS 1))) ) (\UPF.TEMPFILEP (LAMBDA (FILENAME START) (* ; "Edited 6-Jan-88 13:12 by bvm:") (* ;; "Checks whether START denotes a temporary mark for Twenex filename beginning at START. Returns the appropriate field name if so. Not sure we should parse this junk any more, but this at least localizes it.") (SELCHARQ (NTHCHARCODE FILENAME START) ((T S) (* ; "Funny temp stuff") (AND (EQ START (NCHARS FILENAME)) (QUOTE TEMPORARY))) NIL)) ) (FILENAMEFIELD (LAMBDA (FILE FIELDNAME) (* ; "Edited 6-Mar-90 19:38 by nm") (UNPACKFILENAME.STRING FILE (SELECTQ FIELDNAME ((VERSION GENERATION) (QUOTE VERSION)) ((DEVICE STRUCTURE) (QUOTE DEVICE)) FIELDNAME) (QUOTE FIELD) NIL T)) ) (PACKFILENAME (LAMBDA N (* bvm%: " 5-Jul-85 15:40") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME) (ARG N 1))) (T (PACK (PACKFILENAME.ASSEMBLE))))) ) (PACKFILENAME.STRING (LAMBDA N (* bvm%: " 5-Jul-85 15:41") (COND ((AND (EQ N 1) (LISTP (ARG N 1))) (* ; "spread argument list") (APPLY (FUNCTION PACKFILENAME.STRING) (ARG N 1))) (T (CONCATLIST (PACKFILENAME.ASSEMBLE))))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CANONICAL.DIRECTORY MACRO [OPENLAMBDA (SRCSTRING) (AND SRCSTRING (LET ((LEN (NCHARS SRCSTRING))) (COND ((EQ LEN 1) (if (STREQUAL SRCSTRING "/") then "<" else SRCSTRING)) (T (LET* ((FATP (ffetch (STRINGP FATSTRINGP) of SRCSTRING)) (DSTSTRING (ALLOCSTRING LEN NIL NIL (AND FATP T))) (DSTBASE (ffetch (STRINGP BASE) of DSTSTRING)) (DSTPOS 0) (NEXTPOS -1)) (if (NOT FATP) then [for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) (if (> SRCPOS LEN) then (RETURN "<")) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASETHIN DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASETHIN DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1))) (add DSTPOS 1))) (PROGN (\PUTBASETHIN DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS] else (for SRCPOS from 1 to LEN bind CODE first (while (EQMEMB (NTHCHARCODE SRCSTRING SRCPOS) (CHARCODE (< / >))) do (add SRCPOS 1)) do (SELCHARQ (SETQ CODE (NTHCHARCODE SRCSTRING SRCPOS)) ((> /) (if (> DSTPOS NEXTPOS) then (\PUTBASEFAT DSTBASE DSTPOS (CHARCODE >)) (SETQ NEXTPOS (add DSTPOS 1)))) (%' (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1) (if (NEQ SRCPOS LEN) then (\PUTBASEFAT DSTBASE DSTPOS (NTHCHARCODE SRCSTRING (add SRCPOS 1))) (add DSTPOS 1))) (PROGN (\PUTBASEFAT DSTBASE DSTPOS CODE) (add DSTPOS 1))) finally (RETURN (if (EQ DSTPOS LEN) then (if (EQMEMB (NTHCHARCODE DSTSTRING -1) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 -2) else DSTSTRING) elseif (EQMEMB (NTHCHARCODE DSTSTRING DSTPOS) (CHARCODE (> /))) then (SUBSTRING DSTSTRING 1 (SUB1 DSTPOS)) else (SUBSTRING DSTSTRING 1 DSTPOS]) (PUTPROPS UNPACKFILE1.DIRECTORY MACRO [OPENLAMBDA (NAM ST END) (LET* ((OLDDIR (SUBSTRING FILE ST END)) (NEWDIR (CANONICAL.DIRECTORY OLDDIR))) (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (AND NEWDIR (MKATOM NEWDIR))) (T (OR NEWDIR ""]) (PUTPROPS PACKFILENAME.ASSEMBLE MACRO [NIL (PROG ((BLIP "") (I 1) HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY RELATIVEDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT PACKLIST VAR VAL TEMP) (DECLARE (SPECVARS HOST DEVICE STRUCTURE DIRECTORY SUBDIRECTORY NAME EXTENSION VERSION TEMPORARY PROTECTION ACCOUNT)) LP (COND ((<= I N) (* ;; "Grab the next field-name / value pair and fold it into the filename:") (COND ((LISTP (SETQ VAR (ARG N I))) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR))) ((<= (SETQ I (ADD1 I)) N) (SETQ VAL (ARG N I))) (T (SETQ VAL))) (OR (STRINGP VAL) (ATOM VAL) (EQ VAR 'BODY) (\ILLEGAL.ARG VAL)) (SELECTQ VAR (BODY (MAP (UNPACKFILENAME.STRING (COND ((LISTP VAL) (PACKFILENAME.STRING VAL)) (T VAL)) NIL 'OK) [FUNCTION (LAMBDA (X) (SELECTQ (CAR X) (HOST (OR HOST (SETQ HOST (OR (CADR X) BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR (CADR X) BLIP)))) (RELATIVEDIRECTORY [OR RELATIVEDIRECTORY (COND (DIRECTORY (SETQ RELATIVEDIRECTORY BLIP) ) (T (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP]) (NAME (OR NAME (SETQ NAME (OR (CADR X) BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR (CADR X) BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR (CADR X) BLIP)))) (SHOULDNT] (FUNCTION CDDR))) (HOST [OR HOST (SETQ HOST (COND (VAL (SELCHARQ (CHCON1 VAL) (({ %[ %() (SUBSTRING VAL 2 (SELCHARQ (NTHCHARCODE VAL -1) ((} %] %)) -2) -1))) VAL)) (T BLIP]) ((PATHNAME DIRECTORY) [COND (VAL (for X on (SETQ VAL (UNPACKFILENAME.STRING VAL NIL 'RETURN)) by (CDDR X) do (SELECTQ (CAR X) (HOST [COND ((NOT HOST) (SETQ HOST (OR (CADR X) BLIP]) (DEVICE [COND ((NOT DEVICE) (SETQ DEVICE (OR (CADR X) BLIP]) (SUBDIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR (CADR X) BLIP)))) (DIRECTORY [OR DIRECTORY (COND (RELATIVEDIRECTORY (SETQ DIRECTORY BLIP)) (T (SETQ DIRECTORY (OR (CADR X) BLIP]) (ERROR "Illegal field in DIRECTORY slot" VAL))) (for X on VAL by (CDDR X) do (SELECTQ (CAR X) (HOST (OR DEVICE (SETQ DEVICE BLIP)) (OR DIRECTORY (SETQ DIRECTORY BLIP))) (DEVICE (OR DIRECTORY (SETQ DIRECTORY BLIP))) NIL))) (T (OR DIRECTORY (SETQ DIRECTORY BLIP]) (SUBDIRECTORY (OR SUBDIRECTORY (SETQ SUBDIRECTORY (OR VAL BLIP)))) (RELATIVEDIRECTORY (* ;; "This used to set RELATIVEDIRECTORY to BLIP if DIRECTORY was already specified. It really should act as a subdirectory in that case? JDS") (OR RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (OR VAL BLIP)))) (DEVICE (OR DEVICE (SETQ DEVICE (OR VAL BLIP)))) (NAME (OR NAME (SETQ NAME (OR VAL BLIP)))) (EXTENSION (OR EXTENSION (SETQ EXTENSION (OR VAL BLIP)))) (VERSION (OR VERSION (SETQ VERSION (OR VAL BLIP)))) (TEMPORARY (OR TEMPORARY (SETQ TEMPORARY (OR VAL BLIP)))) (\ILLEGAL.ARG VAR)) (SETQ I (ADD1 I)) (GO LP))) (COND ((EQ HOST BLIP) (SETQ HOST NIL))) (COND ((EQ DEVICE BLIP) (SETQ DEVICE NIL))) (COND ((EQ DIRECTORY BLIP) (SETQ DIRECTORY NIL))) [COND ((EQ SUBDIRECTORY BLIP) (SETQ SUBDIRECTORY NIL)) ((AND NIL SUBDIRECTORY) (COND ((AND (NULL DIRECTORY) (OR HOST DEVICE)) (SETQ DIRECTORY SUBDIRECTORY) (SETQ SUBDIRECTORY NIL] (COND ((EQ RELATIVEDIRECTORY BLIP) (SETQ RELATIVEDIRECTORY NIL))) (RETURN (NCONC (AND HOST (LIST "{" HOST "}")) [AND DEVICE (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE %:) DEVICE 1)) (EQ TEMP (NCHARS DEVICE))) (LIST DEVICE)) (T (LIST DEVICE ":"] [COND (DIRECTORY (COND [[OR (STREQUAL DIRECTORY "<") (AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) DIRECTORY 1)) (EQ TEMP (NCHARS DIRECTORY] (COND ((EQMEMB (NTHCHARCODE DIRECTORY 1) (CHARCODE (< /))) (LIST DIRECTORY)) (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY] (T (LIST (CL:FIRST \FILENAME.SYNTAX) DIRECTORY (CL:SECOND \FILENAME.SYNTAX] [COND (RELATIVEDIRECTORY (COND ((AND (SETQ TEMP (LASTCHPOS (CHARCODE (> /)) RELATIVEDIRECTORY 1)) (EQ TEMP (NCHARS RELATIVEDIRECTORY))) (LIST RELATIVEDIRECTORY)) (T (LIST RELATIVEDIRECTORY (CL:SECOND \FILENAME.SYNTAX ] [COND (SUBDIRECTORY (LIST SUBDIRECTORY (CL:SECOND \FILENAME.SYNTAX] (AND NAME (NEQ NAME BLIP) (LIST NAME)) (AND (OR (AND EXTENSION (NEQ EXTENSION BLIP)) (AND VERSION (NEQ VERSION BLIP))) (LIST (COND ((AND EXTENSION (EQ (CHCON1 EXTENSION) (CHARCODE %.))) BLIP) (T '%.)) (OR EXTENSION BLIP))) (AND VERSION (NEQ VERSION BLIP) (LIST (CL:THIRD \FILENAME.SYNTAX) (COND ((FIXP VERSION) VERSION) (T (SELCHARQ (CHCON1 VERSION) ((%. ! ;) (SUBSTRING VERSION 2 -1)) VERSION]) (PUTPROPS UNPACKFILE1 MACRO [OPENLAMBDA (NAM ST END) (* lmm "22-APR-81 22:21") (COND [(NOT ONEFIELDFLG) (SETQ VAL (CONS (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""))) (CONS NAM VAL] ((EQMEMB NAM ONEFIELDFLG) (RETURN (COND (PACKFLG (SUBATOM FILE ST END)) (T (OR (SUBSTRING FILE ST END) ""]) ) ) (RPAQQ \FILENAME.SYNTAX ("<" ">" ";")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FILENAME.SYNTAX) ) (* ; "saving and restoring system state") (DEFINEQ (LOGOUT (LAMBDA (FAST) (* hdj "23-May-86 16:20") (\USEREVENT (QUOTE BEFORELOGOUT)) (COND ((OR (EQ FAST T) (\FLUSHVMOK? (QUOTE LOGOUT))) (* ; "Check that we have a vmem file before allowing LOGOUT") (\PROCESS.BEFORE.LOGOUT) (\DEVICEEVENT (QUOTE BEFORELOGOUT)) (\SETTOTALTIME) (* ; "update the total time that this sysout has been running.") (\LOGOUT0 FAST) (* ;; "Must re-establish the state of devices and of previously open files that might have been modified at the EXEC.") (\RESETKEYBOARD) (\DEVICEEVENT (QUOTE AFTERLOGOUT)) (\OPENLINEBUF) (\PROCESS.AFTER.EXIT (QUOTE AFTERLOGOUT)) (\USEREVENT (QUOTE AFTERLOGOUT)) (INTERPRET.REM.CM) NIL))) ) (MAKESYS [LAMBDA (FILE NAME) (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE NAME)) (* ;  "Edited 7-Feb-2000 08:52 by rmk:") (* ; "Edited 28-Jul-88 18:16 by drc:") (\FLUSHVMOK? 'MAKESYS) (\USEREVENT 'BEFOREMAKESYS) (HERALD (CONCAT (OR NAME (CL:STRING-CAPITALIZE MAKESYSNAME)) " " (SUBSTRING (SETQ MAKESYSDATE (DATE)) 1 11) " ...")) (\DEVICEEVENT 'BEFOREMAKESYS) (PROG ((NEWFILE (\COPYSYS FILE))) (RETURN (COND ((NLISTP NEWFILE) (* ;  "Coming back from doing the MAKESYS, so just set up to keep going.,") (\DEVICEEVENT 'AFTERDOMAKESYS) (\USEREVENT 'AFTERDOMAKESYS) NEWFILE) (T (* ;  "Coming back in the MAKESYS'd sysout, so restart the world.") (\DEVICEEVENT 'AFTERMAKESYS) (\PROCESS.AFTER.EXIT 'AFTERMAKESYS) (PRIN1 HERALDSTRING T) (\USEREVENT 'AFTERMAKESYS) (INTERPRET.REM.CM) (* ;  "Run the commands in the file REM.CM") (RESET]) (SYSOUT (LAMBDA (FILE) (* hdj "29-Sep-86 12:14") (DECLARE (GLOBALVARS \MISCSTATS) (SPECVARS FILE)) (* ; "FILE is special so that BEFORESYSOUTFORMS can alter it") (\FLUSHVMOK? (QUOTE SYSOUT)) (\USEREVENT (QUOTE BEFORESYSOUT)) (\DEVICEEVENT (QUOTE BEFORESYSOUT)) (PROG ((TOTALTIMESAVE (fetch TOTALTIME of \MISCSTATS)) NEWFILE) (* ; "update the total time field so that the run time in the sysout will be right.") (\SETTOTALTIME) (RETURN (PROG1 (SETQ NEWFILE (\COPYSYS FILE)) (COND ((NLISTP NEWFILE) (* ;; "Continuing in same sysout; reset TOTALTIME in misc stats page to not include the time before the sysout.") (replace TOTALTIME of \MISCSTATS with TOTALTIMESAVE) (\DEVICEEVENT (QUOTE AFTERDOSYSOUT)) (\USEREVENT (QUOTE AFTERDOSYSOUT))) (T (* ; "restarting") (\DEVICEEVENT (QUOTE AFTERSYSOUT)) (\PROCESS.AFTER.EXIT (QUOTE AFTERSYSOUT)) (INTERPRET.REM.CM) (\USEREVENT (QUOTE AFTERSYSOUT)))))))) ) (SAVEVM (LAMBDA (RELEASEFLG) (* hdj "23-May-86 16:20") (* ;; "Save the virtual memory. This is similar to logging out, then back in, but is much faster, since it doesn't lose any pages. Conceptually, this is like doing a sysout to Lisp.virtualmem") (\FLUSHVMOK? (QUOTE SAVEVM)) (\USEREVENT (QUOTE BEFORESAVEVM)) (\DEVICEEVENT (QUOTE BEFORESAVEVM)) (COND ((\FLUSHVM) (\RESETKEYBOARD) (* ; "Returns T when starting up fresh") (\DEVICEEVENT (QUOTE AFTERSAVEVM)) (\PROCESS.AFTER.EXIT (QUOTE AFTERSAVEVM)) (\USEREVENT (QUOTE AFTERSAVEVM)) T) (T (\DEVICEEVENT (QUOTE AFTERDOSAVEVM)) (\USEREVENT (QUOTE AFTERDOSAVEVM))))) ) (HERALD (LAMBDA (STR) (* wt%: " 2-MAY-79 15:38") (AND STR (SETQ HERALDSTRING STR)) HERALDSTRING)) (INTERPRET.REM.CM [LAMBDA (RETFLG) (* ; "Edited 29-Jun-2017 15:36 by rmk:") (DECLARE (GLOBALVARS STARTUPFORM)) (* ;;; "Looks at REM.CM and evaluates the form there if the first character of the file is open paren or doublequote. If it's a string, it will be unread,, else the form will be evaluated at the next prompt. For use in INIT.LISP, among others. If RETFLG is true, the expression read is simply returned") (PROG ([FILE (CAR (NLSETQ (OPENSTREAM '{DSK}REM.CM;1 'BOTH 'OLD] COM AUXFILE) (OR FILE (RETURN)) [COND ([AND (IGREATERP (GETFILEINFO FILE 'LENGTH) 0) (SELECTQ (SKIPSEPRS FILE T) ((%( %") T) NIL) (SETQ COM (PROGN (SETFILEINFO FILE 'ENDOFSTREAMOP (FUNCTION ERROR!)) (CAR (NLSETQ (READ FILE T] (COND (RETFLG (* ; "Save it to return")) ((LISTP COM) (* ; "make it happen at next prompt") (SETQ STARTUPFORM (LIST 'PROGN '(SETQ PROMPTCHARFORMS (DREMOVE STARTUPFORM PROMPTCHARFORMS)) (LIST 'PRINT (LIST 'LISPXEVAL (KWOTE COM)) T T))) (SETQ PROMPTCHARFORMS (CONS STARTUPFORM PROMPTCHARFORMS))) (T (* ; "Unread a string") (* ;  "RMK: Replace CR and LF by space to avoid EOL convention issues") (FOR I FROM 1 TO (NCHARS COM) WHEN (FMEMB (NTHCHARCODE COM I) (CHARCODE (CR LF EOL))) DO (RPLCHARCODE COM I (CHARCODE SPACE))) (BKSYSBUF COM))) (* ;; "Eat up the command terminator") (WHILE (FMEMB (\PEEKBIN FILE T) (CHARCODE (CR LF EOL ;))) DO (\BIN FILE)) (COND ((\EOFP FILE) (* ;  "Nothing left, get rid of the file") (CLOSEF FILE) (DELFILE FILE) (\SETEOFPTR FILE 0)) (T (* ;; "Need to rewrite REM.CM with remainder of text") (SETQ AUXFILE (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW)) (COPYBYTES FILE AUXFILE) (SETFILEPTR FILE 0) (COPYBYTES AUXFILE FILE 0 (GETFILEPTR AUXFILE)) (CLOSEF AUXFILE) (\SETEOFPTR FILE (GETFILEPTR FILE)) (CLOSEF FILE] (RETURN (COND (RETFLG COM) (COM T]) (\USEREVENT (LAMBDA (EVENT) (DECLARE (GLOBALVARS AROUNDEXITFNS)) (* bvm%: "16-Dec-83 15:27") (for FN in (SELECTQ EVENT ((BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM BEFOREMAKESYS) AROUNDEXITFNS) (REVERSE AROUNDEXITFNS)) do (APPLY* FN EVENT))) ) ) (ADDTOVAR AROUNDEXITFNS ) (RPAQ? HERALDSTRING "") (RPAQ? \USERNAME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS HERALDSTRING USERNAME \USERNAME AROUNDEXITFNS) ) (DEFINEQ (USERNAME (LAMBDA (FLG STRPTR PRESERVECASE) (* lmm "28-MAR-82 14:10") (* ; "On 10, USERNAME can take a user number as arg") (PROG (ADDR NAME) (SETQ NAME (COND (FLG NIL) ((NEQ 0 (SETQ ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (GetBcplString (\ADDBASE (EMADDRESS 0) ADDR) (EQ STRPTR T))) (T \USERNAME))) (OR PRESERVECASE (NULL NAME) (SETQ NAME (U-CASE NAME))) (RETURN (COND ((NULL NAME) NIL) ((STRINGP STRPTR) (SUBSTRING NAME 1 -1 STRPTR)) (T NAME))))) ) (SETUSERNAME (LAMBDA (NAME) (* lmm "28-MAR-82 14:11") (* ; "Changed interpretation of UserName0") (COND (NAME (PROG ((ADDR (fetch (IFPAGE UserNameAddr) of \InterfacePage))) (RETURN (COND ((NEQ ADDR 0) (SetBcplString (\ADDBASE (EMADDRESS 0) ADDR) NAME) (SETQ USERNAME (USERNAME NIL T))) (T (SETQ \USERNAME (CONCAT NAME))))))))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) FILEIO) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PACKFILENAME.STRING PACKFILENAME) ) (PUTPROPS ADIR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1920 2017)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2781 7660 (DELFILE 2791 . 2891) (FULLNAME 2893 . 3127) (INFILE 3129 . 3235) (INFILEP 3237 . 3326) (IOFILE 3328 . 3425) (OPENFILE 3427 . 3827) (OPENSTREAM 3829 . 6954) (OUTFILE 6956 . 7065 ) (OUTFILEP 7067 . 7157) (RENAMEFILE 7159 . 7399) (SIMPLE.FINDFILE 7401 . 7658)) (8032 17396 ( UNPACKFILENAME 8042 . 8191) (UNPACKFILENAME.STRING 8193 . 15779) (LASTCHPOS 15781 . 16066) ( \UPF.NEXTPOS 16068 . 16285) (\UPF.TEMPFILEP 16287 . 16719) (FILENAMEFIELD 16721 . 16958) (PACKFILENAME 16960 . 17166) (PACKFILENAME.STRING 17168 . 17394)) (38034 45492 (LOGOUT 38044 . 38693) (MAKESYS 38695 . 40339) (SYSOUT 40341 . 41241) (SAVEVM 41243 . 41865) (HERALD 41867 . 41968) (INTERPRET.REM.CM 41970 . 45245) (\USEREVENT 45247 . 45490)) (45674 46489 (USERNAME 45684 . 46153) (SETUSERNAME 46155 . 46487))))) STOP \ No newline at end of file diff --git a/sources/ADISPLAY b/sources/ADISPLAY new file mode 100644 index 00000000..1b54f17b --- /dev/null +++ b/sources/ADISPLAY @@ -0,0 +1,1281 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "15-Sep-94 17:07:04" {DSK}sources>ADISPLAY.;7 259403 + + changes to%: (VARS ADISPLAYCOMS) + (FNS \CURSOR.DEFPRINT) + + previous date%: "24-Aug-94 14:14:55" {DSK}sources>ADISPLAY.;4) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT ADISPLAYCOMS) + +(RPAQQ ADISPLAYCOMS + [(COMS (* ; "COMPILE SUPPORT") + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + WINDOW))) + (COMS (* ; "Interlisp-D dependent stuff.") + (EXPORT (RECORDS REGION BITMAP BITMAPWORD POSITION CURSOR MOUSEEVENT SCREENREGION + SCREENPOSITION)) + (SYSRECORDS PILOTBBT \DISPLAYDATA) + (CONSTANTS (BITSPERINTEGER 32)) + (FNS \BBTCURVEPT) + (FNS CREATETEXTUREFROMBITMAP PRINTBITMAP PRINT-BITMAPS-NICELY PRINTCURSOR \WRITEBITMAP) + (P (DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY)) + (FNS \GETINTEGERPART \CONVERTTOFRACTION) + (CONSTANTS (INTEGERBITS 12))) + [COMS (* ; + "cursor functions not on LLDISPLAY") + (FNS CURSORP CURSORBITMAP CreateCursorBitMap) + (EXPORT (MACROS CURSORBITMAP) + (CONSTANTS (HARDCURSORHEIGHT 16) + (HARDCURSORWIDTH 16)) + (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS CursorBitMap] + (COMS * CARETCOMS) + (COMS (* ; "Region functions") + (FNS CREATEREGION REGIONP INTERSECTREGIONS UNIONREGIONS REGIONSINTERSECTP SUBREGIONP + EXTENDREGION EXTENDREGIONBOTTOM EXTENDREGIONLEFT EXTENDREGIONRIGHT EXTENDREGIONTOP + INSIDEP STRINGREGION)) + (COMS (* ; "line and spline drawing.") + (COMS (* ; + "Brushes and brush initialization") + (GLOBALRESOURCES \BRUSHBBT) + (FNS \BRUSHBITMAP \GETBRUSH \GETBRUSHBBT \InitCurveBrushes \BrushFromWidth) + (FNS \MAKEBRUSH.DIAGONAL \MAKEBRUSH.HORIZONTAL \MAKEBRUSH.VERTICAL + \MAKEBRUSH.SQUARE \MAKEBRUSH.ROUND) + (FNS INSTALLBRUSH) + (VARS \BrushNames) + (INITVARS (KNOWN.BRUSHES NIL) + (\BrushAList NIL)) + (RECORDS BRUSHITEM) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\InitCurveBrushes))) + (DECLARE%: DONTCOPY (GLOBALVARS \BrushAList KNOWN.BRUSHES))) + (* ; "Lines") + (FNS \DRAWLINE.DISPLAY RELMOVETO MOVETOUPPERLEFT) + (FNS \CLIPANDDRAWLINE \CLIPANDDRAWLINE1 \CLIPCODE \LEASTPTAT \GREATESTPTAT \DRAWLINE1 + \DRAWLINE.UFN) + (DECLARE%: DONTCOPY (MACROS .DRAWLINEX. .DRAWLINEY.)) + (* ; "Curves") + (FNS \DRAWCIRCLE.DISPLAY \DRAWARC.DISPLAY \DRAWARC.GENERIC \COMPUTE.ARC.POINTS + \DRAWELLIPSE.DISPLAY \DRAWCURVE.DISPLAY \DRAWPOINT.DISPLAY \DRAWPOLYGON.DISPLAY + \LINEWITHBRUSH) + (FNS LOADPOLY PARAMETRICSPLINE \CURVE \CURVE2 \CURVEEND \CURVESLOPE \CURVESTART + \FDIFS/FROM/DERIVS) + (DECLARE%: DONTCOPY (* ; "Used by drawcurve") + (EXPORT (RECORDS POLYNOMIAL SPLINE))) + (DECLARE%: DONTCOPY (EXPORT (MACROS HALF \FILLCIRCLEBLT)) + (MACROS \CURVEPT .SETUP.FOR.\BBTCURVEPT. \CIRCLEPTS \CURVESMOOTH)) + (FNS \FILLCIRCLE.DISPLAY \LINEBLT)) + [COMS (* ; "making and copying bitmaps") + (FNS SCREENBITMAP BITMAPP BITMAPHEIGHT BITSPERPIXEL) + (EXPORT (FILEPKGCOMS BITMAPS CURSORS)) + (DECLARE%: EVAL@COMPILE (EXPORT (ADDVARS (GLOBALVARS SCREENHEIGHT SCREENWIDTH + ScreenBitMap] + [COMS (* ; + "Display stream functions that are not needed in the primitive system") + (FNS DSPFILL INVERTW) + (FNS \DSPCOLOR.DISPLAY \DSPBACKCOLOR.DISPLAY DSPEOLFN) + (EXPORT (CONSTANTS (BLACKSHADE 65535) + (WHITESHADE 0)) + (VARS (GRAYSHADE 43605)) + (ADDVARS (GLOBALVARS GRAYSHADE))) + (MACROS DSPRUBOUTCHAR) + (FNS DSPCLEOL DSPRUBOUTCHAR \DSPMOVELR) + (COMS (* ; "for cursor") + (BITMAPS \DefaultCursor) + (FNS \CURSOR.DEFPRINT) + [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (DEFAULTCURSOR (CURSORCREATE + \DefaultCursor + NIL 0 15))) + (P (COND ((NULL \CURRENTCURSOR) + (SETQ \CURRENTCURSOR DEFAULTCURSOR))) + (DEFPRINT 'CURSOR '\CURSOR.DEFPRINT] + (DECLARE%: DONTCOPY (GLOBALVARS DEFAULTCURSOR] + [COMS (* ; + "stuff to interpret colors as textures which is needed even in system that don't have color.") + (FNS TEXTUREOFCOLOR \PRIMARYTEXTURE \LEVELTEXTURE INSURE.B&W.TEXTURE INSURE.RGB.COLOR + \LOOKUPCOLORNAME RGBP HLSP HLSTORGB \HLSVALUEFN) + (VARS COLORNAMES) + (GLOBALVARS COLORNAMES) + (DECLARE%: DONTCOPY (GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 + WHITESHADE16 REDTEXTURE GREENTEXTURE BLUETEXTURE)) + (UGLYVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE + GREENTEXTURE BLUETEXTURE) + (DECLARE%: DONTCOPY (* ; "Used by drawcurve") + (EXPORT (RECORDS HLS RGB] + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA UNIONREGIONS + INTERSECTREGIONS]) + + + +(* ; "COMPILE SUPPORT") + +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + WINDOW) +) + + + +(* ; "Interlisp-D dependent stuff.") + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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)) +) + +(/DECLAREDATATYPE 'BITMAP '(POINTER WORD WORD WORD WORD) + '((BITMAP 0 POINTER) + (BITMAP 2 (BITS . 15)) + (BITMAP 3 (BITS . 15)) + (BITMAP 4 (BITS . 15)) + (BITMAP 5 (BITS . 15))) + '6) + +(/DECLAREDATATYPE 'CURSOR '(POINTER POINTER POINTER POINTER POINTER) + '((CURSOR 0 POINTER) + (CURSOR 2 POINTER) + (CURSOR 4 POINTER) + (CURSOR 6 POINTER) + (CURSOR 8 POINTER)) + '10) + +(* "END EXPORTED DEFINITIONS") + +(ADDTOVAR SYSTEMRECLST + +(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))) + +(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))) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ BITSPERINTEGER 32) + + +(CONSTANTS (BITSPERINTEGER 32)) +) +(DEFINEQ + +(\BBTCURVEPT [LAMBDA (X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 NBITSRIGHTPLUS1 TOPMINUSBRUSH DestinationBitMap BRUSHHEIGHT BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA) (* kbr%: "27-Aug-86 23:17") (* ;; "Called by \CURVEPT macro. Draws a brush point by bitblting BRUSHBM to point X,Y in DestinationBitMap. BBT is a BitBlt table where everything is already set except the source and destination addresses, width and height. In other words, only the easy stuff") (* ; "set the width fields of the bbt") [PROG (CLIPPEDTOP STY) [COND [(ILEQ Y TOPMINUSBRUSH) (* ;  "the top part of the brush is visible") (SETQ CLIPPEDTOP (IPLUS Y BRUSHHEIGHT)) (replace PBTSOURCE of BBT with BRUSHBASE) (freplace PBTHEIGHT of BBT with (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH] (T (* ; "only the bottom is visible") (SETQ CLIPPEDTOP TOP) [replace PBTSOURCE of BBT with (\ADDBASE BRUSHBASE (ITIMES BRUSHRASTERWIDTH (SETQ STY (IDIFFERENCE Y TOPMINUSBRUSH] (freplace PBTHEIGHT of BBT with (IDIFFERENCE (IMIN BRUSHHEIGHT (IDIFFERENCE Y BOTTOMMINUSBRUSH )) STY] (freplace PBTDEST of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH (\SFInvert DestinationBitMap CLIPPEDTOP] [COND (COLORBRUSHBASE [COND [(ILESSP X LEFT) (* ;  "only the right part of the brush is visible") (* ;  "FOR NOW BRUTE FORCE WITH NBITS CHECK") [freplace PBTDESTBIT of BBT with (COND ((EQ NBITS 4) (LLSH LEFT 2)) (T (LLSH LEFT 3] (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (freplace PBTWIDTH of BBT with (COND ((EQ NBITS 4) (LLSH (IDIFFERENCE X LEFTMINUSBRUSH) 2)) (T (LLSH (IDIFFERENCE X LEFTMINUSBRUSH) 3] (T (* ; "left edge is visible") [freplace PBTDESTBIT of BBT with (SETQ X (COND ((EQ NBITS 4) (LLSH X 2)) (T (LLSH X 3] (freplace PBTSOURCEBIT of BBT with 0) (* ;  "set width to the amount that is visible") (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE NBITSRIGHTPLUS1 X] (* ;  "if color brush is used, the ground must be cleared before the brush is put in.") (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) 'ERASE) (\PILOTBITBLT BBT 0) (* ;  "reset the source to point to the color bitmap.") [COND ((ILEQ Y TOPMINUSBRUSH) (* ;  "the top part of the brush is visible") (freplace PBTSOURCE of BBT with COLORBRUSHBASE)) (T (* ; "only the bottom is visible") (freplace PBTSOURCE of BBT with (\ADDBASE COLORBRUSHBASE (ITIMES BRUSHRASTERWIDTH (IDIFFERENCE Y TOPMINUSBRUSH] (\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) 'PAINT)) (T (COND [(ILESSP X LEFT) (* ;  "only the right part of the brush is visible") (freplace PBTDESTBIT of BBT with LEFT) (freplace PBTSOURCEBIT of BBT with (IDIFFERENCE BRUSHWIDTH (freplace PBTWIDTH of BBT with (IDIFFERENCE X LEFTMINUSBRUSH ] (T (* ; "left edge is visible") (freplace PBTDESTBIT of BBT with X) (freplace PBTSOURCEBIT of BBT with 0) (* ;  "set width to the amount that is visible") (freplace PBTWIDTH of BBT with (IMIN BRUSHWIDTH (IDIFFERENCE RIGHTPLUS1 X ] (\PILOTBITBLT BBT 0]) +) +(DEFINEQ + +(CREATETEXTUREFROMBITMAP [LAMBDA (BITMAP) (* rrb "17-May-84 11:22") (* ;; "creates a texture object from the lower left corner of a bitmap") (OR (BITMAPP BITMAP) (\ILLEGAL.ARG BITMAP)) (PROG ((H (fetch BITMAPHEIGHT of BITMAP)) (W (fetch BITMAPWIDTH of BITMAP)) TEXTHEIGHT TEXTURE) (COND ((AND (OR (EQ W 2) (EQ W 4)) (OR (EQ H 2) (EQ H 4))) (* ;  "small texture will match bitmap exactly so use integer representation.") (SETQ TEXTURE 0) [for X from 0 to 3 do (for Y from 0 to 3 do (COND ([NOT (EQ 0 (BITMAPBIT BITMAP (IREMAINDER X W) (IREMAINDER Y H] (SETQ TEXTURE (LOGOR TEXTURE (\BITMASK (IPLUS (ITIMES (IDIFFERENCE 3 Y) 4) X] (RETURN TEXTURE)) ((AND (EQ W 16) (ILESSP H 17)) (* ;  "if it is already 16 by n n<=16, use it.") (RETURN BITMAP)) (T (* ; "make a 16 bit wide one.") (SETQ TEXTURE (BITMAPCREATE 16 (IMIN H 16))) (for X from 0 by W to 16 do (BITBLT BITMAP 0 0 TEXTURE X 0 W H 'INPUT 'REPLACE)) (RETURN TEXTURE]) + +(PRINTBITMAP [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") (* ;;; "Writes a bitmap on a file such that READBITMAP will read it back in.") (DECLARE (LOCALVARS . T)) (PROG ((BM BITMAP)) (COND ((type? BITMAP BITMAP)) ([AND (LITATOM BITMAP) (type? BITMAP (SETQ BM (EVALV BITMAP] (* ;  "Coerce litatoms for compatibility with original specification") ) (T (printout T "******** " BITMAP " is not a BITMAP." T) (RETURN NIL))) (printout FILE "(" .P2 (BITMAPWIDTH BM) %, .P2 (BITMAPHEIGHT BM)) (* ;  "if the number of bits per pixel is not 1, write it out.") (COND ((NEQ (BITSPERPIXEL BM) 1) (SPACES 1 FILE) (PRIN2 (BITSPERPIXEL BM) FILE))) (* ;  "Enclose in list so that compile-copying works.") (\WRITEBITMAP BM FILE) (* ; "Now write out contents.") (PRIN1 ")" FILE]) + +(PRINT-BITMAPS-NICELY [LAMBDA (BITMAP STREAM) (* ; "Edited 20-Mar-87 17:06 by jop") (* ;;; "The syntax for bitmaps is") (* ;; "#*(width height [bits-per-pixel])XXXXXX...") (* ;;; "where WIDTH and HEIGHT are the dimensions of the bitmap, BITS-PER-PIXEL can be omitted if it is equal to one, and the X's are single characters between @ and O (in ASCII), each representing four bits. There will be exactly (* (ceiling (* WIDTH BITS-PER-PIXEL) 16) 4) characters for each row of the bitmap and exactly HEIGHT rows. Note that there are no spaces allowed between the * and the (, between the ) and the first X, or anywhere inside the string of X's. Also, the character after the last X must not be of type OTHER.") (* ;;; "This function %"observes%" *print-length*: it truncates after printing *print-length* characters in the bitmap's representation.") (if (OR (NULL STREAM) (NULL *PRINT-ARRAY*)) then (* ;; "Let it be printed in the normal way, with an address.") NIL else (* ;; "Print this bitmap in the preferred way.") (LET* ((WIDTH (BITMAPWIDTH BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) (BITS-PER-PIXEL (BITSPERPIXEL BITMAP)) (BASE (fetch BITMAPBASE of BITMAP)) (QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL) 16)) (CHARS-SO-FAR *PRINT-LENGTH*)) (PRINTOUT STREAM "#*(" .P2 WIDTH " " .P2 HEIGHT) (if (NEQ BITS-PER-PIXEL 1) then (PRINTOUT STREAM " " .P2 BITS-PER-PIXEL)) (PRINTOUT STREAM ")") (PROG NIL [CL:MACROLET [(ELIDE? NIL `(IF (AND CHARS-SO-FAR (EQ 0 (CL:DECF CHARS-SO-FAR ))) THEN (PRINTOUT STREAM "...") (GO OUT] (CL:DOTIMES (ROW HEIGHT) (CL:DOTIMES (QUAD QUAD-CHARS-PER-ROW) (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 0) 4) (CL:CHAR-INT #\@))) STREAM) (ELIDE?) (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 0) 15) (CL:CHAR-INT #\@))) STREAM) (ELIDE?) (CL:WRITE-CHAR (CL:INT-CHAR (+ (LRSH (\GETBASEBYTE BASE 1) 4) (CL:CHAR-INT #\@))) STREAM) (ELIDE?) (CL:WRITE-CHAR (CL:INT-CHAR (+ (LOGAND (\GETBASEBYTE BASE 1) 15) (CL:CHAR-INT #\@))) STREAM) (ELIDE?) (SETQ BASE (\ADDBASE BASE 1))))] OUT (RETURN T]) + +(PRINTCURSOR [LAMBDA (VAR) (* ; "Edited 2-Dec-86 14:15 by Pavel") (* ;; "Writes an expression that will define the cursor value of VAR") (PROG (CUR IMAGE MASK) (COND ([NOT (type? CURSOR (SETQ CUR (EVALV VAR 'PRINTCURSOR] (printout T "******** " VAR " is not a CURSOR." T) (RETURN NIL))) (* ; "write out defining form.") (\CURSORBITSPERPIXEL CUR 1) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of CUR)) (SETQ MASK (fetch (CURSOR CUMASK) of CUR)) (PRINT `(RPAQ ,VAR (CURSORCREATE ',IMAGE ',(AND (NOT (EQ IMAGE MASK)) MASK) ,(fetch (CURSOR CUHOTSPOTX) of CUR) ,(fetch (CURSOR CUHOTSPOTY) of CUR]) + +(\WRITEBITMAP [LAMBDA (BITMAP FILE) (* ; "Edited 1-Dec-86 16:24 by Pavel") (* ;;; "writes the contents of a bitmap onto the currently open output file.") (PROG (LIM (BASE (fetch BITMAPBASE of BITMAP)) (OFD (GETSTREAM FILE 'OUTPUT)) (W (fetch BITMAPRASTERWIDTH of BITMAP))) (FRPTQ (fetch BITMAPHEIGHT of BITMAP) (TERPRI FILE) (\BOUT OFD (CHARCODE %")) (SETQ LIM (\ADDBASE BASE W)) (until (EQ BASE LIM) do (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) (LRSH (\GETBASEBYTE BASE 0) 4))) (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) (LOGAND (\GETBASEBYTE BASE 0) 15))) (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) (LRSH (\GETBASEBYTE BASE 1) 4))) (\BOUT OFD (IPLUS (SUB1 (CHARCODE A)) (LOGAND (\GETBASEBYTE BASE 1) 15))) (SETQ BASE (\ADDBASE BASE 1))) (\BOUT OFD (CHARCODE %"]) +) + +(DEFPRINT 'BITMAP 'PRINT-BITMAPS-NICELY) +(DEFINEQ + +(\GETINTEGERPART [LAMBDA (FRACT) (* JonL " 7-May-84 02:43") (* ;; "gets the integer part of a fixed point number. The integer part has INTEGERBITS worth of significant bits the leftmost of which is sign.") (PROG [HIPART (ROUNDER (COND ([EQ 0 (LOGAND (fetch (FIXP HINUM) of FRACT) (CONSTANT (LLSH 1 (IDIFFERENCE BITSPERWORD (ADD1 INTEGERBITS ] 0) (T 1] (* ;; "assumes that the number of significant bits --- INTEGERBITS --- is less than can fit in the high order of the two words allocated for the integer.") (RETURN (COND ([IGREATERP [SETQ HIPART (LRSH (fetch (FIXP HINUM) of FRACT) (CONSTANT (IDIFFERENCE BITSPERWORD INTEGERBITS] (CONSTANT (EXPT 2 (SUB1 INTEGERBITS] (* ;  "the sign bit is on, make it negative.") (IDIFFERENCE (IDIFFERENCE HIPART (CONSTANT (EXPT 2 INTEGERBITS))) ROUNDER)) (T (IPLUS HIPART ROUNDER]) + +(\CONVERTTOFRACTION [LAMBDA (FLOAT) (* rmk%: " 3-JUL-82 23:29") (* ;; "converts a floating point number into a fixed point number with INTEGERBITS worth of integer part. Always returns a large integer so that the box can be clobbered.") (PROG (RESULT BOX) (RETURN (COND ([SMALLP (SETQ RESULT (FIX (FTIMES FLOAT (CONSTANT (FLOAT (EXPT 2 (IDIFFERENCE BITSPERINTEGER INTEGERBITS] (* ; "clobber a created box.") (PutUnboxed (SETQ BOX (CREATECELL \FIXP)) RESULT) BOX) (T RESULT]) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ INTEGERBITS 12) + + +(CONSTANTS (INTEGERBITS 12)) +) + + + +(* ; "cursor functions not on LLDISPLAY") + +(DEFINEQ + +(CURSORP [LAMBDA (X) (* kbr%: " 5-Jul-85 17:54") (* ; "is X a cursor?") (type? CURSOR X]) + +(CURSORBITMAP [LAMBDA NIL CursorBitMap]) + +(CreateCursorBitMap [LAMBDA (ARRAY) (* rmk%: " 1-APR-82 22:20") (* ;  "makes a bitmap out of an array of values.") (PROG ((BM (BITMAPCREATE 16 16)) BASE) (SETQ BASE (ffetch BITMAPBASE of BM)) (for I from 0 to 15 do (\PUTBASE BASE I (LOGAND (ELT ARRAY (ADD1 I)) WORDMASK))) (RETURN BM]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS CURSORBITMAP MACRO (NIL CursorBitMap)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ HARDCURSORHEIGHT 16) + +(RPAQQ HARDCURSORWIDTH 16) + + +(CONSTANTS (HARDCURSORHEIGHT 16) + (HARDCURSORWIDTH 16)) +) +(DECLARE%: EVAL@COMPILE + +(ADDTOVAR GLOBALVARS CursorBitMap) +) + +(* "END EXPORTED DEFINITIONS") + + +(RPAQQ CARETCOMS ((BITMAPS \DefaultCaret) + (INITVARS (\CARET.UP NIL + + (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") +) + (\CARET.DEFAULT NIL (* ; + "global = default caret to put up. An instance of CARET1 datatype") + ) + (\CARET.TIMER (SETUPTIMER 0) + (* ; "time for next caret action")) + (DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) + (DEFAULTCARETRATE 333 (* ; "default rate for flashing caret") + ) + (\CARET.ON.RATE DEFAULTCARETRATE) + (\CARET.OFF.RATE DEFAULTCARETRATE) + (\CARET.FORCED.OFF.RATE 0)) + (ADDVARS (\SYSTEMTIMERVARS \CARET.TIMER)) + (DECLARE%: DONTCOPY (RECORDS CARET1)) + (INITRECORDS CARET1) + (FNS CARET \CARET.CREATE \CARET.DOWN \CARET.FLASH? \CARET.SHOW CARETRATE + \CARET.FLASH.AGAIN \CARET.FLASH.MULTIPLE \CARET.FLASH) + (FNS \MEDW.CARET.SHOW) + (* ; "some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") + (GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET + \CARET.TIMER \CARET.UP \CARET.FORCED.OFF.RATE) + (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (TTYBACKGROUNDFNS \CARET.FLASH?))) + (FNS \AREAVISIBLE? \REGIONOVERLAPAREAP \AREAINREGIONP) + (P (CARET T)))) + +(RPAQQ \DefaultCaret #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@) + +(RPAQ? \CARET.UP NIL + (* ;; "global. NIL if no caret showing, otherwise a CARET1 record with CURSOR, stream, x, y, and RATE (= off rate)") +) + +(RPAQ? \CARET.DEFAULT NIL (* ; + "global = default caret to put up. An instance of CARET1 datatype") +) + +(RPAQ? \CARET.TIMER (SETUPTIMER 0) + (* ; "time for next caret action")) + +(RPAQ? DEFAULTCARET (CURSORCREATE \DefaultCaret NIL 3 4)) + +(RPAQ? DEFAULTCARETRATE 333 (* ; "default rate for flashing caret") +) + +(RPAQ? \CARET.ON.RATE DEFAULTCARETRATE) + +(RPAQ? \CARET.OFF.RATE DEFAULTCARETRATE) + +(RPAQ? \CARET.FORCED.OFF.RATE 0) + +(ADDTOVAR \SYSTEMTIMERVARS \CARET.TIMER) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD CARET1 (* ; + "a record that describes a SHOWING caret") + (STREAM (* ; + "the stream the caret is showing in") + STREAMX (* ; + "the X position stream relative that it was shown at") + STREAMY (* ; + "the Y position stream relative that it was shown at") + CURSOR (* ; + "the cursor bitmap + x and y that this caret represents") + RATE (* ; "the 'down rate' for this caret, in ticks. After comes down (when \CARET.TIMER expires), \CARET.TIMER will be rescheduled to put something up. This is the rate to use") + (* ; + "NEXT for threading carets together") + . NEXT)) +) +) +(DEFINEQ + +(CARET [LAMBDA (NEWCARET) (* kbr%: " 6-Jul-85 16:13") (* ;  "changes the 'system default' caret") (PROG1 (COND (\CARET.DEFAULT (* ;  "merely stored as a 'cursor' record for simplicity") (fetch (CARET1 CURSOR) of \CARET.DEFAULT)) (T 'OFF)) [COND (NEWCARET (\CHECKCARET) (CARETRATE (CARETRATE)) (* ; "make sure the caret rate is set") (SETQ \CARET.DEFAULT (SELECTQ NEWCARET (T (COND ((EQ DEFAULTCARET 'OFF) NIL) ((CURSORP DEFAULTCARET) (create CARET1 CURSOR _ DEFAULTCARET)) (T (ERROR "DEFAULTCARET is not a cursor" DEFAULTCARET)))) (OFF NIL) (COND ((CURSORP NEWCARET) (create CARET1 CURSOR _ NEWCARET)) (T (LISPERROR "ILLEGAL ARG" NEWCARET])]) + +(\CARET.CREATE [LAMBDA (CURSOR) (* jds "11-Jul-85 19:38") (create CARET1 CURSOR _ (OR CURSOR DEFAULTCARET]) + +(\CARET.DOWN [LAMBDA (STREAM INTERVAL UNLESSOCCLUDED) (* lmm " 4-May-84 18:15") (* ;; "take caret down if it is up. If you take it down, reschedule to put it back up in INTERVAL (or 0) --- often called thru \CHECKCARET macro") (COND (\CARET.UP (COND ([OR (NULL STREAM) (fetch (CARET1 NEXT) of \CARET.UP) (EQ (fetch (CARET1 STREAM) of \CARET.UP) (COND ((type? WINDOW STREAM) (fetch (WINDOW DSP) of STREAM)) (T STREAM] [while (UNINTERRUPTABLY [COND ((\CARET.SHOW \CARET.UP UNLESSOCCLUDED) (* ;  "take caret down and set global state") (replace (CARET1 STREAM) of \CARET.UP with NIL) (SETQ \CARET.UP (fetch (CARET1 NEXT) of \CARET.UP])] (SETUPTIMER (OR INTERVAL \CARET.FORCED.OFF.RATE) \CARET.TIMER]) + +(\CARET.FLASH? [LAMBDA (STREAM CARET ONRATE OFFRATE X Y) (* AJB "17-Jul-85 12:47") (* ;;; "Flashes the CARET at the ONRATE/OFFRATE at the X,Y position in the current TTY window. If CARET is NIL, uses \CARET.DEFAULT as the caret. Takes either a display stream or a textstream as the destination stream to flash the caret. The caret is not flashed on a shift-selection in a window") (COND (\CARET.UP [COND ((TIMEREXPIRED? \CARET.TIMER) (\CARET.DOWN NIL (fetch (CARET1 RATE) of \CARET.UP) (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY] NIL) ((AND (OR CARET (SETQ CARET \CARET.DEFAULT)) (TIMEREXPIRED? \CARET.TIMER) [OR [DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] (AND (IMAGESTREAMTYPEP STREAM 'TEXT) (SETQ STREAM (WINDOWPROP (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ STREAM))) 'DSP] (\CARET.FLASH CARET STREAM OFFRATE (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY)) X Y)) (* ;; "\CARET.DEFAULT is NIL if by default the caret is OFF --- the KEYDOWNP clause is a hack to detect whether we are doing a copy-select") (replace (CARET1 NEXT) of CARET with NIL)(* ;  "Since this function is displaying a new caret, destroy any chaining of multiple carets") (SETUPTIMER (OR ONRATE \CARET.ON.RATE) \CARET.TIMER) T]) + +(\CARET.SHOW + [LAMBDA (CARET UNLESSOCCLUDED) (* ; "Edited 25-Feb-94 16:53 by sybalsky") + + (* ;; "GENERIC caret flasher.") + + (LET (DS) + (SETQ DS (fetch (CARET1 STREAM) of CARET)) + (WINDOWOP 'SCCARETFLASH (FETCH (WINDOW SCREEN) OF (FETCH (\DISPLAYDATA + XWINDOWHINT) + OF (FETCH (STREAM + IMAGEDATA) + OF DS))) + CARET UNLESSOCCLUDED]) + +(CARETRATE [LAMBDA (ONRATE OFFRATE) (* lmm " 3-May-84 11:35") (* ;; "sets the default caret rate (s) to be ONRATE/OFFRATE in milliseconds") (PROG1 (COND ((EQ \CARET.ON.RATE \CARET.OFF.RATE) \CARET.ON.RATE) (T (CONS \CARET.ON.RATE \CARET.OFF.RATE))) [COND ((OR ONRATE OFFRATE) (SETUPTIMER 0 \CARET.TIMER) (SETQ \CARET.ON.RATE (OR (FIXP ONRATE) (FIX DEFAULTCARETRATE))) (SETQ \CARET.OFF.RATE (OR (FIXP OFFRATE) \CARET.ON.RATE])]) + +(\CARET.FLASH.AGAIN [LAMBDA (CARET STREAM X Y) (* AJB "14-Aug-85 17:04") (LET ((OCARET \CARET.UP)) (COND ([AND OCARET CARET (DISPLAYSTREAMP (OR STREAM (SETQ STREAM (TTYDISPLAYSTREAM] (for (OC _ OCARET) by (fetch (CARET1 NEXT) of OC) do (COND [(NULL OC) (RETURN (COND ((\CARET.FLASH CARET STREAM (fetch (CARET1 RATE) of \CARET.UP) (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY)) X Y) (* ; "OK, showed this one") (OR (EQ \CARET.UP CARET) (SHOULDNT)) (replace (CARET1 NEXT) of CARET with OCARET] ((EQ OC CARET) (* ; "this CARET is already showing") (RETURN]) + +(\CARET.FLASH.MULTIPLE [LAMBDA (STREAMS CARETS ONRATE OFFRATE) (* AJB "14-Aug-85 17:10") (* ;  "this is probably just a template for how to flash multiple carets") (COND ((\CARET.FLASH? (CAR STREAMS) (CAR CARETS) ONRATE OFFRATE) (for STR in (CDR STREAMS) as CARET in (CDR CARETS) do (\CARET.FLASH.AGAIN CARET STR]) + +(\CARET.FLASH [LAMBDA (CARET STREAM RATE UNLESSOCCLUDED X Y) (* kbr%: " 5-Jul-85 17:51") (PROG (CURSOR ANSWER) (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) (replace (CARET1 STREAM) of CARET with STREAM) (replace (CARET1 STREAMX) of CARET with (IDIFFERENCE (OR X (DSPXPOSITION NIL STREAM)) (fetch (CURSOR CUHOTSPOTX) of CURSOR))) (replace (CARET1 STREAMY) of CARET with (IDIFFERENCE (OR Y (DSPYPOSITION NIL STREAM)) (fetch (CURSOR CUHOTSPOTY) of CURSOR))) (replace (CARET1 RATE) of CARET with (OR RATE \CARET.OFF.RATE)) (UNINTERRUPTABLY (COND ((\CARET.SHOW CARET UNLESSOCCLUDED) (SETQ \CARET.UP CARET) (SETQ ANSWER T)))) (RETURN ANSWER]) +) +(DEFINEQ + +(\MEDW.CARET.SHOW [LAMBDA (SCREEN CARET UNLESSOCCLUDED) (* ;  "Edited 17-Jan-94 10:28 by sybalsky:mv:envos") (* ;; "MEDLEY-window-system specific version of \CARET.SHOW (vectored thru the screen). Flash the caret (by inverting its image). UNLESSOCCLUDED controls whether you bring the window to the top if the caret is under some other window.") (PROG (DS) (SETQ DS (fetch (CARET1 STREAM) of CARET)) (RETURN (PROG (DD CARETWIN CBMX CBMY CURSOR CARETBM CWX CWY CARETBMWIDTH CARETBMHEIGHT CLIPREG CLIPVAR) (SETQ DD (fetch (STREAM IMAGEDATA) of DS)) (SETQ CARETWIN (WFROMDS DS)) (SETQ CBMX 0) (SETQ CBMY 0) (SETQ CURSOR (fetch (CARET1 CURSOR) of CARET)) (\CURSORBITSPERPIXEL CURSOR (BITSPERPIXEL (DSPDESTINATION NIL CARETWIN))) (SETQ CARETBM (fetch (CURSOR CUIMAGE) of CURSOR)) (SETQ CWX (fetch (CARET1 STREAMX) of CARET)) (SETQ CWY (fetch (CARET1 STREAMY) of CARET)) (SETQ CARETBMWIDTH (fetch (BITMAP BITMAPWIDTH) of CARETBM)) (SETQ CARETBMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of CARETBM)) (* ;  "calculate how much to reduce the caret region by do to the clipping region of the window.") (SETQ CLIPREG (fetch (\DISPLAYDATA DDClippingRegion) of DD)) (COND ((IGREATERP (SETQ CLIPVAR (fetch (REGION LEFT) of CLIPREG)) CWX) [SETQ CARETBMWIDTH (IDIFFERENCE CARETBMWIDTH (SETQ CBMX (IDIFFERENCE CLIPVAR CWX] (SETQ CWX CLIPVAR))) (COND ((IGREATERP CARETBMWIDTH (SETQ CLIPVAR (IDIFFERENCE (IPLUS CLIPVAR (fetch (REGION WIDTH) of CLIPREG)) CWX))) (SETQ CARETBMWIDTH CLIPVAR))) (COND ((IGREATERP (SETQ CLIPVAR (fetch (REGION BOTTOM) of CLIPREG)) CWY) [SETQ CARETBMHEIGHT (IDIFFERENCE CARETBMHEIGHT (SETQ CBMY (IDIFFERENCE CLIPVAR CWY] (SETQ CWY CLIPVAR))) (COND ((IGREATERP CARETBMHEIGHT (SETQ CLIPVAR (IDIFFERENCE (IPLUS CLIPVAR (fetch (REGION HEIGHT) of CLIPREG)) CWY))) (SETQ CARETBMHEIGHT CLIPVAR))) (* note the time of the next change. This must be done without creating boxes  because happens during keyboard wait.) (COND ((OR (ILESSP CARETBMWIDTH 1) (ILESSP CARETBMHEIGHT 1)) (* caret isn't within clipping  region.) (RETURN T))) (* convert the base of the caret  location to screen coordinates.) (SETQ CWX (\DSPTRANSFORMX CWX DD)) (SETQ CWY (\DSPTRANSFORMY CWY DD)) (* having only this section uninterruptable leaves open the possibility that  the window moves or the timer is wrong but these will only mess up the display  and are low frequency events.) (COND [(AND (OPENWP CARETWIN) (\AREAVISIBLE? CARETWIN CWX CWY (IPLUS CWX (SUB1 CARETBMWIDTH)) (IPLUS CWY (SUB1 CARETBMHEIGHT] (UNLESSOCCLUDED (RETURN)) (T (TOTOPW CARETWIN))) (BITBLT CARETBM CBMX CBMY (DSPDESTINATION NIL CARETWIN) CWX CWY CARETBMWIDTH CARETBMHEIGHT 'INPUT 'INVERT) (RETURN T]) +) + + + +(* ; +"some declarations are on LLDISPLAY -- macro for \CHECKCARET and globalvar declaration for \CARET.UP") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \CARET.DEFAULT \CARET.ON.RATE \CARET.OFF.RATE DEFAULTCARET \CARET.TIMER \CARET.UP + \CARET.FORCED.OFF.RATE) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(ADDTOVAR TTYBACKGROUNDFNS \CARET.FLASH?) +) +(DEFINEQ + +(\AREAVISIBLE? [LAMBDA (WIN LFT BTM RGHT TOP) (* kbr%: "18-Feb-86 18:05") (* ;; "is the area whose screen limits are LFT BTM RGHT and TOP eniretly visible within WIN,") (PROG (WPTR) (SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WIN))) (COND ((NOT (\AREAINREGIONP (fetch (WINDOW REG) of WIN) LFT BTM RGHT TOP)) (* ;  "if the caret region isn't completely within the window, forget it.") (RETURN))) LP (COND ((EQ WPTR WIN) (RETURN T)) ((\REGIONOVERLAPAREAP (fetch (WINDOW REG) of WPTR) LFT BTM RGHT TOP) (RETURN NIL)) ((SETQ WPTR (fetch (WINDOW NEXTW) of WPTR)) (GO LP]) + +(\REGIONOVERLAPAREAP [LAMBDA (REG LFT BTM RGHT TOP) (* rrb "17-Feb-86 18:50") (* ;;  "is there any overlap between the region REG and the area defined by left bottom right and top?") (NOT (OR (IGREATERP (fetch (REGION LEFT) of REG) RGHT) (IGREATERP LFT (fetch (REGION RIGHT) of REG)) (IGREATERP (fetch (REGION BOTTOM) of REG) TOP) (IGREATERP BTM (fetch (REGION TOP) of REG]) + +(\AREAINREGIONP [LAMBDA (REGION LFT BTM RGHT TOP) (* rrb "14-OCT-83 15:32") (AND (IGEQ LFT (fetch LEFT of REGION)) (IGEQ BTM (fetch BOTTOM of REGION)) (IGEQ (fetch PRIGHT of REGION) RGHT) (IGEQ (fetch PTOP of REGION) TOP]) +) + +(CARET T) + + + +(* ; "Region functions") + +(DEFINEQ + +(CREATEREGION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* rrb "17-JUN-83 08:56") (* ; "creates a region structure.") (create REGION LEFT _ LEFT BOTTOM _ BOTTOM WIDTH _ WIDTH HEIGHT _ HEIGHT]) + +(REGIONP [LAMBDA (X) (* rrb "29-Jun-84 18:00") (AND (type? REGION X) X]) + +(INTERSECTREGIONS [LAMBDA REGIONS (* kbr%: "24-Jan-86 18:30") (* ;; "returns the largest region that is contained in all of REGIONS") (COND ((EQ REGIONS 0) (* ;; "this is documented as returning a very large region. This one covers the entire FIXP range so should work for many purposes. rrb") (create REGION LEFT _ (SUB1 MIN.FIXP) BOTTOM _ (SUB1 MIN.FIXP) WIDTH _ (PLUS (TIMES 2 MAX.FIXP) 4) HEIGHT _ (PLUS (TIMES 2 MAX.FIXP) 4))) (T (PROG (REG LFT RGHT BTTM TP) (SETQ REG (ARG REGIONS 1)) (SETQ LFT (fetch (REGION LEFT) of REG)) [SETQ RGHT (SUB1 (IPLUS LFT (fetch (REGION WIDTH) of REG] (SETQ BTTM (fetch (REGION BOTTOM) of REG)) [SETQ TP (SUB1 (IPLUS BTTM (fetch (REGION HEIGHT) of REG] [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I)) [COND ((IGREATERP (fetch (REGION LEFT) of REG) LFT) (SETQ LFT (fetch (REGION LEFT) of REG] [COND ((IGREATERP (fetch (REGION BOTTOM ) of REG) BTTM) (SETQ BTTM (fetch (REGION BOTTOM ) of REG] [COND ((ILESSP (fetch (REGION RIGHT) of REG) RGHT) (SETQ RGHT (fetch (REGION RIGHT) of REG] (COND ((ILESSP (fetch (REGION TOP) of REG) TP) (SETQ TP (fetch (REGION TOP) of REG] (RETURN (COND ((AND (IGEQ RGHT LFT) (IGEQ TP BTTM)) (create REGION LEFT _ LFT BOTTOM _ BTTM WIDTH _ (ADD1 (IDIFFERENCE RGHT LFT)) HEIGHT _ (ADD1 (IDIFFERENCE TP BTTM]) + +(UNIONREGIONS [LAMBDA REGIONS (* rrb "30-Dec-85 17:07") (* ;; "returns the smallest region that encloses all of REGIONS") (COND ((EQ 0 REGIONS) NIL) (T (PROG (REG LFT RGHT BTTM TP) (SETQ REG (ARG REGIONS 1)) (SETQ LFT (fetch (REGION LEFT) of REG)) (SETQ RGHT (fetch (REGION PRIGHT) of REG)) (SETQ BTTM (fetch (REGION BOTTOM) of REG)) (SETQ TP (fetch (REGION PTOP) of REG)) [for I from 2 thru REGIONS do (SETQ REG (ARG REGIONS I)) [COND ((LESSP (fetch (REGION LEFT) of REG) LFT) (SETQ LFT (fetch (REGION LEFT) of REG] [COND ((LESSP (fetch (REGION BOTTOM) of REG) BTTM) (SETQ BTTM (fetch (REGION BOTTOM ) of REG] [COND ((GREATERP (fetch (REGION PRIGHT) of REG) RGHT) (SETQ RGHT (fetch (REGION PRIGHT ) of REG] (COND ((GREATERP (fetch (REGION PTOP) of REG) TP) (SETQ TP (fetch (REGION PTOP) of REG] (RETURN (create REGION LEFT _ LFT BOTTOM _ BTTM WIDTH _ (DIFFERENCE RGHT LFT) HEIGHT _ (DIFFERENCE TP BTTM]) + +(REGIONSINTERSECTP [LAMBDA (REGION1 REGION2) (* rrb "16-AUG-81 08:29") (* ;; "determines if two regions intersect") (NOT (OR (IGREATERP (fetch LEFT of REGION1) (fetch RIGHT of REGION2)) (IGREATERP (fetch LEFT of REGION2) (fetch RIGHT of REGION1)) (IGREATERP (fetch BOTTOM of REGION1) (fetch TOP of REGION2)) (IGREATERP (fetch BOTTOM of REGION2) (fetch TOP of REGION1]) + +(SUBREGIONP [LAMBDA (LARGEREGION SMALLREGION) (* rrb "25-JUN-82 15:09") (* ;; "determines if small region is a subset of large region. (SUBREGIONP '(9 0 100 100) '(0 10 100 80))") (AND (IGEQ (fetch LEFT of SMALLREGION) (fetch LEFT of LARGEREGION)) (IGEQ (fetch BOTTOM of SMALLREGION) (fetch BOTTOM of LARGEREGION)) (IGEQ (fetch PRIGHT of LARGEREGION) (fetch PRIGHT of SMALLREGION)) (IGEQ (fetch PTOP of LARGEREGION) (fetch PTOP of SMALLREGION]) + +(EXTENDREGION [LAMBDA (REGION INCLUDEREGION) (* rrb " 5-FEB-82 09:25") (* ;; "destructively extends REGION to include INCLUDEREGION") [COND ((IGREATERP (fetch (REGION LEFT) of REGION) (fetch (REGION LEFT) of INCLUDEREGION)) (replace (REGION WIDTH) of REGION with (IDIFFERENCE (fetch (REGION PRIGHT) of REGION) (fetch (REGION LEFT) of INCLUDEREGION))) (replace (REGION LEFT) of REGION with (fetch (REGION LEFT) of INCLUDEREGION ] [COND ((IGREATERP (fetch (REGION BOTTOM) of REGION) (fetch (REGION BOTTOM) of INCLUDEREGION)) (replace (REGION HEIGHT) of REGION with (IDIFFERENCE (fetch (REGION PTOP) of REGION) (fetch (REGION BOTTOM) of INCLUDEREGION))) (replace (REGION BOTTOM) of REGION with (fetch (REGION BOTTOM) of INCLUDEREGION ] [COND ((IGREATERP (fetch (REGION RIGHT) of INCLUDEREGION) (fetch (REGION RIGHT) of REGION)) (replace (REGION WIDTH) of REGION with (ADD1 (IDIFFERENCE (fetch (REGION RIGHT) of INCLUDEREGION ) (fetch (REGION LEFT) of REGION] [COND ((IGREATERP (fetch (REGION TOP) of INCLUDEREGION) (fetch (REGION TOP) of REGION)) (replace (REGION HEIGHT) of REGION with (ADD1 (IDIFFERENCE (fetch (REGION TOP) of INCLUDEREGION ) (fetch (REGION BOTTOM) of REGION] REGION]) + +(EXTENDREGIONBOTTOM [LAMBDA (REG NEWBOTTOM) (* rrb "29-DEC-81 10:02") (* ; "extends a region to the bottom") (PROG ((OLDBOTTOM (fetch (REGION BOTTOM) of REG))) [COND ((IGREATERP OLDBOTTOM NEWBOTTOM) (replace (REGION BOTTOM) of REG with NEWBOTTOM) (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) of REG) (IDIFFERENCE OLDBOTTOM NEWBOTTOM] (RETURN REG]) + +(EXTENDREGIONLEFT [LAMBDA (REG NEWLEFT) (* rrb "29-DEC-81 09:37") (* ; "extends a region to the left") (PROG ((OLDLEFT (fetch (REGION LEFT) of REG))) [COND ((IGREATERP OLDLEFT NEWLEFT) (replace (REGION LEFT) of REG with NEWLEFT) (replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH) of REG) (IDIFFERENCE OLDLEFT NEWLEFT] (RETURN REG]) + +(EXTENDREGIONRIGHT [LAMBDA (REG NEWRIGHT) (* rrb "29-DEC-81 10:06") (* ; "extends a region to the left") (PROG ((OLDRIGHT (fetch (REGION RIGHT) of REG))) [COND ((ILESSP OLDRIGHT NEWRIGHT) (replace (REGION WIDTH) of REG with (IPLUS (fetch (REGION WIDTH) of REG) (IDIFFERENCE NEWRIGHT OLDRIGHT] (RETURN REG]) + +(EXTENDREGIONTOP [LAMBDA (REG NEWTOP) (* rrb "29-DEC-81 10:07") (* ; "extends a region to the top") (PROG ((OLDTOP (fetch (REGION TOP) of REG))) [COND ((ILESSP OLDTOP NEWTOP) (replace (REGION HEIGHT) of REG with (IPLUS (fetch (REGION HEIGHT) of REG) (IDIFFERENCE NEWTOP OLDTOP] (RETURN REG]) + +(INSIDEP [LAMBDA (REGION POSORX Y) (* rrb "18-May-84 21:04") (* ;; "returns T if the position X Y is inside the region REGION. If POSORX is a position, returns T if that position is inside of REGION") (COND ((WINDOWP REGION) (INSIDEP (DSPCLIPPINGREGION NIL REGION) POSORX Y)) (T (COND ((AND (NUMBERP POSORX) (NUMBERP Y)) (INSIDE? REGION POSORX Y)) ((POSITIONP POSORX) (INSIDE? REGION (fetch (POSITION XCOORD) of POSORX) (fetch (POSITION YCOORD) of POSORX))) ((NUMBERP POSORX) (\ILLEGAL.ARG Y)) (T (\ILLEGAL.ARG POSORX]) + +(STRINGREGION [LAMBDA (STR STREAM PRIN2FLG RDTBL) (* rmk%: "25-AUG-83 18:06") (* ;; "returns the region taken up by STR if it were printed at the current position of STREAM") (create REGION LEFT _ (DSPXPOSITION NIL STREAM) BOTTOM _ (IDIFFERENCE (DSPYPOSITION NIL STREAM) (FONTPROP STREAM 'DESCENT)) WIDTH _ (STRINGWIDTH STR STREAM PRIN2FLG RDTBL) HEIGHT _ (FONTPROP STREAM 'HEIGHT]) +) + + + +(* ; "line and spline drawing.") + + + + +(* ; "Brushes and brush initialization") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTDEF '\BRUSHBBT 'RESOURCES '(NEW (create PILOTBBT] +) +) + +(/SETTOPVAL '\\BRUSHBBT.GLOBALRESOURCE NIL) +(DEFINEQ + +(\BRUSHBITMAP [LAMBDA (BRUSHSHAPE BRUSHWIDTH) (* rrb " 9-Sep-86 16:30") (* ;;; "returns the bitmap for the brush of the shape and size. See comments on \InitCurveBrushes.") (DECLARE (GLOBALVARS \BrushAList)) (LET [(BRUSHES&METHOD (CDR (OR (FASSOC BRUSHSHAPE \BrushAList) (\ILLEGAL.ARG BRUSHSHAPE] (COND ((NOT (GREATERP BRUSHWIDTH 0)) (* ;; "if brush is 0 or negative, return an empty brush. Might want to error but this would require users to handle it.") (BITMAPCREATE 0 0)) [(ILESSP BRUSHWIDTH 17) (* ;  "lowest 16 brushes are stored. FIX them so ELT works.") (ELT (fetch (BRUSHITEM BRUSHARRAY) of BRUSHES&METHOD) (COND ((FIXP BRUSHWIDTH)) ((GREATERP BRUSHWIDTH 1) (FIXR BRUSHWIDTH)) (T 1] [(CDR (FASSOC BRUSHWIDTH (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD] (T (* ;; "cache the brush bitmap. This is done so that the brush creation methods don't have to be efficient.") (LET ((NEWBRUSHBM (APPLY* (fetch (BRUSHITEM CREATEMETHOD) of BRUSHES&METHOD) BRUSHWIDTH))) (replace (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD with (CONS (CONS BRUSHWIDTH NEWBRUSHBM) (fetch (BRUSHITEM BRUSHCACHE) of BRUSHES&METHOD))) NEWBRUSHBM]) + +(\GETBRUSH [LAMBDA (BRUSH) (* rrb " 9-Sep-86 16:30") (COND ((type? BITMAP BRUSH) BRUSH) [(LISTP BRUSH) (\BRUSHBITMAP (CAR BRUSH) (CAR (LISTP (CDR BRUSH] (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1]) + +(\GETBRUSHBBT [LAMBDA (BRUSHBM DISPLAYDATA BBT) (* kbr%: "18-Aug-85 12:46") (* ;; "Initializes BBT for the BRUSHBM and DS and returns BBT, unless the BRUSHBM is a 1-point brush, in which case it returns NIL.") (COND ((AND (EQ (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM) 1) (EQ (ffetch (BITMAP BITMAPWIDTH) of BRUSHBM) 1) (EQ (BITMAPBIT BRUSHBM 0 0) 1)) (* ;  "special case of single point brush shape.") NIL) (T (* ;  "update as many fields in the brush bitblt table as possible from DS.") (replace (PILOTBBT PBTDESTBPL) of BBT with (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH ) of (fetch (\DISPLAYDATA DDDestination ) of DISPLAYDATA)) BITSPERWORD)) (freplace (PILOTBBT PBTSOURCEBPL) of BBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH ) of BRUSHBM) BITSPERWORD)) (freplace (PILOTBBT PBTFLAGS) of BBT with 0) (freplace (PILOTBBT PBTDISJOINT) of BBT with T) (\SETPBTFUNCTION BBT (ffetch (\DISPLAYDATA DDSOURCETYPE) of DISPLAYDATA) (SELECTQ (ffetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA) ((PAINT REPLACE) 'PAINT) ((INVERT ERASE) 'ERASE) (SHOULDNT))) BBT]) + +(\InitCurveBrushes [LAMBDA NIL (* ; "Edited 13-Oct-87 14:31 by jds") (* ;; "Set up the initial set of brush specs for curve drawing. \BrushAList is an association list from brush-shape-names to a spec which is an instance of the record BRUSHITEM.") (DECLARE (GLOBALVARS \BrushNames \BrushAList \SingleBitBitmap)) (PROG (BARRAY CREATIONMETHOD) (SETQ \SingleBitBitmap (BITMAPCREATE 1 1)) (BITMAPBIT \SingleBitBitmap 0 0 1) (for BRUSHNAME in \BrushNames do (SETQ BARRAY (ARRAY 16 'POINTER NIL 1)) (SETQ CREATIONMETHOD (PACK* '\MAKEBRUSH. BRUSHNAME)) (SETA BARRAY 1 \SingleBitBitmap) (for SIZE from 2 to 16 do (SETA BARRAY SIZE (APPLY* CREATIONMETHOD SIZE))) (INSTALLBRUSH BRUSHNAME CREATIONMETHOD BARRAY]) + +(\BrushFromWidth [LAMBDA (W) (* hdj " 5-Nov-84 16:47") (LIST 'ROUND W]) +) +(DEFINEQ + +(\MAKEBRUSH.DIAGONAL [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:51") (PROG (BM) (SETQ BM (BITMAPCREATE SIZE SIZE)) (for X from 0 to (SUB1 SIZE) do (BITMAPBIT BM X X 1)) (RETURN BM]) + +(\MAKEBRUSH.HORIZONTAL [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:52") (* ;;; "create a brush that has a horizontal line across it halfway down") (PROG (BM) (SETQ BM (BITMAPCREATE SIZE SIZE)) (BITBLT NIL NIL NIL BM 0 (SUB1 (FOLDHI SIZE 2)) NIL 1 'TEXTURE 'REPLACE BLACKSHADE) (RETURN BM]) + +(\MAKEBRUSH.VERTICAL [LAMBDA (SIZE) (* kbr%: "18-Aug-85 12:53") (PROG (BM) (SETQ BM (BITMAPCREATE SIZE SIZE)) (BITBLT NIL NIL NIL BM (SUB1 (FOLDHI SIZE 2)) 0 1 SIZE 'TEXTURE 'REPLACE BLACKSHADE) (RETURN BM]) + +(\MAKEBRUSH.SQUARE [LAMBDA (SIZE) (* kbr%: "18-Aug-85 13:07") (PROG (BM) (SETQ BM (BITMAPCREATE SIZE SIZE)) (BITBLT NIL NIL NIL BM NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) (RETURN BM]) + +(\MAKEBRUSH.ROUND [LAMBDA (SIZE) (* rrb "15-Sep-86 14:32") (* ;  "special cased 8 so that it wouldn't have a width of 7. rrb") (PROG (RADIUS BITMAP BASE) (SETQ RADIUS (SUB1 (HALF SIZE))) (SETQ BITMAP (BITMAPCREATE SIZE SIZE)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (SELECTQ SIZE (1 (\PUTBASE BASE 0 (MASK.1'S 15 1))) (2 (\PUTBASE BASE 0 (MASK.1'S 14 2)) (\PUTBASE BASE 1 (MASK.1'S 14 2))) (3 (\PUTBASE BASE 0 (MASK.1'S 14 1)) (\PUTBASE BASE 1 (MASK.1'S 13 3)) (\PUTBASE BASE 2 (MASK.1'S 14 1))) (4 (\PUTBASE BASE 0 (MASK.1'S 13 2)) (\PUTBASE BASE 1 (MASK.1'S 12 4)) (\PUTBASE BASE 2 (MASK.1'S 12 4)) (\PUTBASE BASE 3 (MASK.1'S 13 2))) (5 (\PUTBASE BASE 0 (MASK.1'S 13 1)) (\PUTBASE BASE 1 (MASK.1'S 12 3)) (\PUTBASE BASE 2 (MASK.1'S 11 5)) (\PUTBASE BASE 3 (MASK.1'S 12 3)) (\PUTBASE BASE 4 (MASK.1'S 13 1))) (8 (\PUTBASE BASE 0 (MASK.1'S 10 4)) (\PUTBASE BASE 1 (MASK.1'S 9 6)) (\PUTBASE BASE 2 (MASK.1'S 8 8)) (\PUTBASE BASE 3 (MASK.1'S 8 8)) (\PUTBASE BASE 4 (MASK.1'S 8 8)) (\PUTBASE BASE 5 (MASK.1'S 8 8)) (\PUTBASE BASE 6 (MASK.1'S 9 6)) (\PUTBASE BASE 7 (MASK.1'S 10 4))) (FILLCIRCLE RADIUS RADIUS RADIUS BLACKSHADE (DSPCREATE BITMAP))) (RETURN BITMAP]) +) +(DEFINEQ + +(INSTALLBRUSH [LAMBDA (BRUSHNAME BRUSHFN BRUSHARRAY) (* kbr%: "18-Jan-86 15:27") (DECLARE (GLOBALVARS \BrushAList)) (PROG (OLDENTRY) (SETQ OLDENTRY (FASSOC BRUSHNAME \BrushAList)) (COND (OLDENTRY (AND BRUSHARRAY (replace (BRUSHITEM BRUSHARRAY) of (CDR OLDENTRY) with BRUSHARRAY)) (AND BRUSHFN (replace (BRUSHITEM CREATEMETHOD) of (CDR OLDENTRY) with BRUSHFN))) (T [COND ((AND BRUSHFN (NOT (ARRAYP BRUSHARRAY))) (SETQ BRUSHARRAY (ARRAY 16 'POINTER NIL 1)) (for X from 1 to 16 do (SETA BRUSHARRAY X (APPLY* BRUSHFN X] (push \BrushAList (CONS BRUSHNAME (create BRUSHITEM BRUSHARRAY _ BRUSHARRAY CREATEMETHOD _ BRUSHFN))) (push KNOWN.BRUSHES BRUSHNAME]) +) + +(RPAQQ \BrushNames (ROUND SQUARE DIAGONAL HORIZONTAL VERTICAL)) + +(RPAQ? KNOWN.BRUSHES NIL) + +(RPAQ? \BrushAList NIL) +(DECLARE%: EVAL@COMPILE + +(RECORD BRUSHITEM (BRUSHARRAY CREATEMETHOD . BRUSHCACHE)) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\InitCurveBrushes) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \BrushAList KNOWN.BRUSHES) +) +) + + + +(* ; "Lines") + +(DEFINEQ + +(\DRAWLINE.DISPLAY [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 29-Jan-91 14:59 by matsuda") (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Draws a line from x1,y1 to x2,y2 leaving the position at x2,y2") (* ;; "Added handling of brushes (I think, this is actually pretty tricky).") (DECLARE (LOCALVARS . T)) [COND [(OR DASHING (BRUSHP WIDTH)) (GLOBALRESOURCE \BRUSHBBT (LET ((BBT \BRUSHBBT) (BRUSH (INSURE.BRUSH WIDTH))) (if COLOR then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) (IF [NOT (type? BIGBM (ffetch DDDestination of (fetch IMAGEDATA of DISPLAYSTREAM] THEN (\LINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH) DISPLAYSTREAM BBT (SELECTQ OPERATION (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM))) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION))) ELSE (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) BITMAP BIGBMLIST HEIGHT BOTTOM BM YY1 YY2 ClippingTop ClippingBottom CTop CBottom) (SETQ BITMAP (ffetch DDDestination of DD)) (SETQ BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) (SETQ HEIGHT (BITMAPHEIGHT BITMAP)) (SETQ ClippingTop (ffetch DDClippingTop of DD)) (SETQ ClippingBottom (ffetch DDClippingBottom of DD)) (SETQ BM (GetNewFragment BIGBMLIST)) (while (AND BM (IGREATERP HEIGHT ClippingBottom)) do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) [SETQ CTop (COND ((IGREATERP ClippingTop HEIGHT) (IDIFFERENCE HEIGHT BOTTOM)) (T (IDIFFERENCE ClippingTop BOTTOM] (if (IGEQ CTop 0) then [SETQ CBottom (COND ((ILESSP ClippingBottom BOTTOM) 0) (T (IDIFFERENCE ClippingBottom BOTTOM] (replace DDDestination of DD with BM) (replace DDClippingTop of DD with CTop) (replace DDClippingBottom of DD with CBottom) (\LINEWITHBRUSH X1 (IDIFFERENCE Y1 BOTTOM) X2 (IDIFFERENCE Y2 BOTTOM) BRUSH (\GOOD.DASHLST DASHING BRUSH) DISPLAYSTREAM BBT (SELECTQ OPERATION (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM))) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION))) (SETQ BM (GetNewFragment BIGBMLIST)) (SETQ HEIGHT BOTTOM))) (freplace DDDestination of DD with BITMAP) (freplace DDClippingTop of DD with ClippingTop) (freplace DDClippingBottom of DD with ClippingBottom] (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) BITMAP) (\INSURETOPWDS DISPLAYSTREAM) (* ; "bring the window to the top") (SETQ BITMAP (ffetch DDDestination of DD)) (COND ((NOT (type? BIGBM BITMAP)) (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) (FIXR X1)) DD) (\DSPTRANSFORMY (OR (FIXP Y1) (FIXR Y1)) DD) (\DSPTRANSFORMX (OR (FIXP X2) (FIXR X2)) DD) (\DSPTRANSFORMY (OR (FIXP Y2) (FIXR Y2)) DD) [COND ((NULL WIDTH) 1) ((OR (FIXP WIDTH) (FIXR WIDTH] (SELECTQ OPERATION (NIL (ffetch DDOPERATION of DD)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION)) BITMAP (ffetch DDClippingLeft of DD) (SUB1 (ffetch DDClippingRight of DD)) (ffetch DDClippingBottom of DD) (SUB1 (ffetch DDClippingTop of DD)) DISPLAYSTREAM COLOR)) (T (PROG ((BIGBMLIST (fetch (BIGBM BIGBMLIST) of BITMAP)) (HEIGHT (BITMAPHEIGHT BITMAP)) BOTTOM BM CTop CBottom (ClippingTop (ffetch DDClippingTop of DD)) (ClippingBottom (ffetch DDClippingBottom of DD)) (YY1 (\DSPTRANSFORMY (OR (FIXP Y1) (FIXR Y1)) DD)) (YY2 (\DSPTRANSFORMY (OR (FIXP Y2) (FIXR Y2)) DD))) (SETQ BM (GetNewFragment BIGBMLIST)) (while (AND BM (IGREATERP HEIGHT ClippingBottom)) do (SETQ BOTTOM (IDIFFERENCE HEIGHT (BITMAPHEIGHT BM))) [SETQ CTop (COND ((IGREATERP ClippingTop HEIGHT) (IDIFFERENCE HEIGHT BOTTOM)) (T (IDIFFERENCE ClippingTop BOTTOM] (COND ((IGEQ CTop 0) [SETQ CBottom (COND ((ILESSP ClippingBottom BOTTOM) 0) (T (IDIFFERENCE ClippingBottom BOTTOM] (\CLIPANDDRAWLINE (\DSPTRANSFORMX (OR (FIXP X1) (FIXR X1)) DD) (IDIFFERENCE YY1 BOTTOM) (\DSPTRANSFORMX (OR (FIXP X2) (FIXR X2)) DD) (IDIFFERENCE YY2 BOTTOM) [COND ((NULL WIDTH) 1) ((OR (FIXP WIDTH) (FIXR WIDTH] (SELECTQ OPERATION (NIL (ffetch DDOPERATION of DD)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION)) BM (ffetch DDClippingLeft of DD) (SUB1 (ffetch DDClippingRight of DD)) CBottom (SUB1 CTop) DISPLAYSTREAM COLOR))) (SETQ BM (GetNewFragment BIGBMLIST)) (SETQ HEIGHT BOTTOM] (* ;  "the generic case of MOVETO is used so that the hardcopy streams get handled as well.") (MOVETO X2 Y2 DISPLAYSTREAM]) + +(RELMOVETO [LAMBDA (DX DY STREAM) (* rmk%: "25-AUG-83 18:13") (* ; "moves the position by a vector") (DSPXPOSITION [IPLUS DX (DSPXPOSITION NIL (SETQ STREAM (\OUTSTREAMARG STREAM] STREAM) (DSPYPOSITION (IPLUS DY (DSPYPOSITION NIL STREAM)) STREAM]) + +(MOVETOUPPERLEFT [LAMBDA (STREAM REGION) (* hdj " 5-Jul-85 12:19") (* ;; "moves the current position to the upper left corner so that the first line of text will all appear.") (PROG [(ASCENT (FONTPROP (DSPFONT NIL STREAM) 'ASCENT] (COND ((AND REGION (OR (type? REGION REGION) (\ILLEGAL.ARG REGION))) (MOVETO (fetch (REGION LEFT) of REGION) (IDIFFERENCE (fetch (REGION PTOP) of REGION) ASCENT) STREAM)) (T (MOVETO (DSPLEFTMARGIN NIL STREAM) (IDIFFERENCE (fetch (REGION PTOP) of (DSPCLIPPINGREGION NIL STREAM)) ASCENT) STREAM))) (RETURN STREAM]) +) +(DEFINEQ + +(\CLIPANDDRAWLINE [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR) (* ; "Edited 21-Aug-91 12:15 by jds") (* ;; "draws a line from {X1,Y1} to {X2,Y2} clipped to region specified by LEFT RIGHT BOTTOM and TOP. This code is a transliterated version of the BCPL routine that was in chat.") (* ;; "assumes that the width is at least 1") (* ;; "DS is passed so that window can be uninterruptably brought to top.") (COND ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) 1)) (* ;  "make adjustments in case of color.") (SETQ COLOR (COLORNUMBERP (OR COLOR (DSPCOLOR NIL DS)) (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))) (* ; "(COND ((EQ OPERATION 'ERASE) ; treat erase as AND of background (SETQ COLOR (OPPOSITECOLOR COLOR (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)))))") ) (T (SETQ COLOR BLACKSHADE))) (PROG NIL (COND [(EQ X1 X2) (* ; "special case of vertical line.") [COND ((IGREATERP WIDTH 2) (COND [(EQ Y1 Y2) (* ;; "special case. Since we don't know whether the guy is headed horizontally or vertically, put out a round brush This is a fairly infrequent case because I didn't get any bug reports on it in three years so efficiency is not a consideration.") (RETURN (.WHILE.TOP.DS. DS (\DRAWPOINT.DISPLAY (DSPDESTINATION NIL DS) X1 Y1 (LIST 'ROUND WIDTH COLOR) OPERATION] (T (SETQ X1 (SETQ X2 (IDIFFERENCE X1 (LRSH (SUB1 WIDTH) 1] (PROG (MIN MAX) (RETURN (COND ([OR (IGREATERP X1 RIGHT) (IGEQ LEFT (SETQ X2 (IPLUS X1 WIDTH))) (IGREATERP (SETQ MIN (IMIN Y1 Y2)) TOP) (IGREATERP BOTTOM (SETQ MAX (IMAX Y1 Y2] (* ; "outside clippingregion.") NIL) (T (.WHILE.TOP.DS. DS (BITBLT NIL 0 0 BITMAP (SETQ X1 (IMAX X1 LEFT)) (SETQ MIN (IMAX MIN BOTTOM)) (IDIFFERENCE (IMIN X2 (ADD1 RIGHT)) X1) (ADD1 (IDIFFERENCE (IMIN MAX TOP) MIN)) 'TEXTURE OPERATION COLOR] [(EQ Y1 Y2) (* ;  "special case of horizontal line.") [COND ((IGREATERP WIDTH 2) (SETQ Y1 (SETQ Y2 (IDIFFERENCE Y1 (LRSH (SUB1 WIDTH) 1] (PROG (MIN MAX) (RETURN (COND ([OR (IGREATERP Y1 TOP) (IGEQ BOTTOM (SETQ Y2 (IPLUS Y1 WIDTH))) (IGREATERP (SETQ MIN (IMIN X1 X2)) RIGHT) (IGREATERP LEFT (SETQ MAX (IMAX X1 X2] (* ; "outside clippingregion.") NIL) (T (.WHILE.TOP.DS. DS (BITBLT NIL 0 0 BITMAP (SETQ MIN (IMAX MIN LEFT)) (SETQ Y1 (IMAX Y1 BOTTOM)) (ADD1 (IDIFFERENCE (IMIN MAX RIGHT) MIN)) (IDIFFERENCE (IMIN Y2 (ADD1 TOP)) Y1) 'TEXTURE OPERATION COLOR] ((EQ WIDTH 1) (* ; "special case of width 1") (\CLIPANDDRAWLINE1 X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR)) ((IGREATERP (IABS (IDIFFERENCE X1 X2)) (IABS (IDIFFERENCE Y1 Y2))) (* ;  "slope is more horizontal, so make line grow in the positive y direction.") [COND ((IGREATERP WIDTH 2) (PROG (HALFWIDTH) (SETQ HALFWIDTH (LRSH (SUB1 WIDTH) 1)) (SETQ Y1 (IDIFFERENCE Y1 HALFWIDTH)) (SETQ Y2 (IDIFFERENCE Y2 HALFWIDTH] (for I from Y1 to (SUB1 (IPLUS Y1 WIDTH)) as J from Y2 do (\CLIPANDDRAWLINE1 X1 I X2 J OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR))) (T (* ;  "slope is more vertical, so make line grow in the positive x direction.") [COND ((IGREATERP WIDTH 2) (PROG (HALFWIDTH) (SETQ HALFWIDTH (LRSH (SUB1 WIDTH) 1)) (SETQ X1 (IDIFFERENCE X1 HALFWIDTH)) (SETQ X2 (IDIFFERENCE X2 HALFWIDTH] (for I from X1 to (SUB1 (IPLUS X1 WIDTH)) as J from X2 do (\CLIPANDDRAWLINE1 I Y1 J Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR]) + +(\CLIPANDDRAWLINE1 [LAMBDA (X1 Y1 X2 Y2 OPERATION BITMAP LEFT RIGHT BOTTOM TOP DS COLOR) (* JonL " 7-May-84 02:57") (* ;; "LEFT, RIGHT, BOTTOM, TOP are set to the boundaries of the clipping region") (* ;; "DS is passed so that window can be uninterruptably brought to top.") (PROG (DX DY YMOVEUP HALFDX HALFDY (BMRASTERWIDTH (fetch BITMAPRASTERWIDTH of BITMAP))) (COND ((IGREATERP X1 X2) (* ;  "switch points so DX is always positive.") (SETQ HALFDX X1) (SETQ X1 X2) (SETQ X2 HALFDX) (SETQ HALFDX Y1) (SETQ Y1 Y2) (SETQ Y2 HALFDX))) (* ;  "calculate differences and sign of Y movement.") (SETQ HALFDX (LRSH (SETQ DX (IDIFFERENCE X2 X1)) 1)) (SETQ HALFDY (LRSH [SETQ DY (COND ((IGREATERP Y2 Y1) (SETQ YMOVEUP T) (IDIFFERENCE Y2 Y1)) (T (IDIFFERENCE Y1 Y2] 1)) (COND ((AND (IGEQ X1 LEFT) (IGEQ RIGHT X2) [COND (YMOVEUP (AND (IGEQ Y1 BOTTOM) (IGEQ TOP Y2))) (T (AND (IGEQ Y2 BOTTOM) (IGEQ TOP Y1] (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) 1)) (* ;  "line is completely visible, fast case.") (.WHILE.TOP.DS. DS (\DRAWLINE1 X1 (SUB1 (\SFInvert BITMAP Y1)) DX DY DX DY (COND ((IGREATERP DX DY) (* ; "X is the fastest mover.") HALFDX) (T (* ; "y is the fastest mover.") HALFDY)) (COND (YMOVEUP (* ;  "y is moving in positive direction but bits are stored inversely") (IMINUS BMRASTERWIDTH)) (T BMRASTERWIDTH)) OPERATION (fetch BITMAPBASE of BITMAP) BMRASTERWIDTH))) (T (PROG ((CX1 X1) (CY1 Y1) (CX2 X2) (CY2 Y2) (CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) (CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM))) (* ;  "save the original points for the clipping computation.") (* ;  "determine the sectors in which the points fall.") CLIPLP [COND ((NOT (EQ 0 (LOGAND CA1 CA2))) (* ;  "line is entirely out of clipping region") (RETURN NIL)) ((EQ 0 (IPLUS CA1 CA2)) (* ; "line is completely visible") (* ;; "\SFInvert has an off by one bug that everybody else in LLDISPLAY uses to save computation so SUB1 from what you would expect.") (* ; "reuse the variable CA1") (RETURN (.WHILE.TOP.DS. DS (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) (1 (\DRAWLINE1 CX1 (SUB1 (\SFInvert BITMAP CY1)) (IDIFFERENCE CX2 CX1) (COND (YMOVEUP (IDIFFERENCE CY2 CY1)) (T (IDIFFERENCE CY1 CY2))) DX DY (COND ((IGREATERP DX DY) (* ; "X is the fastest mover.") (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1)) HALFDX) DX)) (T (* ; "y is the fastest mover.") (IREMAINDER (IPLUS [ITIMES DX (COND (YMOVEUP (IDIFFERENCE CY1 Y1 )) (T (IDIFFERENCE Y1 CY1] HALFDY) DY))) (COND (YMOVEUP (* ;  "y is moving in positive direction but bits are stored inversely") (IMINUS BMRASTERWIDTH)) (T BMRASTERWIDTH)) OPERATION (fetch BITMAPBASE of BITMAP) BMRASTERWIDTH)) ((4 8) (\DRAWCOLORLINE1 CX1 (SUB1 (\SFInvert BITMAP CY1)) (IDIFFERENCE CX2 CX1) (COND (YMOVEUP (IDIFFERENCE CY2 CY1)) (T (IDIFFERENCE CY1 CY2))) DX DY (COND ((IGREATERP DX DY) (* ; "X is the fastest mover.") (IREMAINDER (IPLUS (ITIMES DY (IDIFFERENCE CX1 X1)) HALFDX) DX)) (T (* ; "y is the fastest mover.") (IREMAINDER (IPLUS [ITIMES DX (COND (YMOVEUP (IDIFFERENCE CY1 Y1)) (T (IDIFFERENCE Y1 CY1] HALFDY) DY))) (COND (YMOVEUP (* ;  "y is moving in positive direction but bits are stored inversely") (IMINUS BMRASTERWIDTH)) (T BMRASTERWIDTH)) OPERATION (fetch BITMAPBASE of BITMAP) BMRASTERWIDTH (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP) COLOR)) (SHOULDNT] [COND ((NEQ CA1 0) (* ;; "now move point CX1 CY1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") (COND ((IGREATERP CA1 7) (* ; "y1 less than bottom") (* ;  "calculate the least X for which Y will be at bottom.") [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE BOTTOM Y1] (SETQ CY1 BOTTOM)) ((IGREATERP CA1 3) (* ; "y1 is greater than top") [SETQ CX1 (IPLUS X1 (\LEASTPTAT DX DY (IDIFFERENCE Y1 TOP] (SETQ CY1 TOP)) (T (* ; "x1 is less than left") [SETQ CY1 (COND [YMOVEUP (IPLUS Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] (T (IDIFFERENCE Y1 (\LEASTPTAT DY DX (IDIFFERENCE LEFT X1] (SETQ CX1 LEFT))) (SETQ CA1 (\CLIPCODE CX1 CY1 LEFT RIGHT TOP BOTTOM))) (T (* ;  "now move point CX2 CY2 so that one of the coordinates is on one of the boundaries") (COND ((IGREATERP CA2 7) (* ; "y2 less than bottom") [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE Y1 BOTTOM] (SETQ CY2 BOTTOM)) ((IGREATERP CA2 3) (* ; "y2 is greater than top") [SETQ CX2 (IPLUS X1 (\GREATESTPTAT DX DY (IDIFFERENCE TOP Y1] (SETQ CY2 TOP)) (T (* ; "x2 is greater than right") [SETQ CY2 (COND [YMOVEUP (IPLUS Y1 (\GREATESTPTAT DY DX (IDIFFERENCE RIGHT X1] (T (IDIFFERENCE Y1 (\GREATESTPTAT DY DX (IDIFFERENCE RIGHT X1] (SETQ CX2 RIGHT))) (SETQ CA2 (\CLIPCODE CX2 CY2 LEFT RIGHT TOP BOTTOM] (GO CLIPLP]) + +(\CLIPCODE [LAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* rrb " 4-DEC-80 10:34") (* ;; "determines the sector code for a point wrt a region. Used to clip things quickly.") (* ;; "RIGHT and TOP are one past the region.") (COND ((LESSP X LEFT) (* ; "falls to left of region") (COND ((GREATERP Y TOP) (* ; "left above") 5) ((LESSP Y BOTTOM) (* ; "left below") 9) (T (* ; "left inside") 1))) ((GREATERP X RIGHT) (* ; "right") (COND ((GREATERP Y TOP) (* ; "right above") 6) ((LESSP Y BOTTOM) (* ; "right below") 10) (T (* ; "right inside") 2))) ((GREATERP Y TOP) (* ; "inside top") 4) ((LESSP Y BOTTOM) (* ; "inside below") 8) (T (* ; "inside 0") 0]) + +(\LEASTPTAT [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 11:56") (* ;; "determines the smallest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") (COND ((IGREATERP DA DB) (ADD1 (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES THISB DA) (HALF DA)) -1) DB))) (T (IQUOTIENT (IPLUS (ITIMES THISB DA) (HALF DB)) DB]) + +(\GREATESTPTAT [LAMBDA (DA DB THISB) (* rrb " 7-JAN-82 14:24") (* ;; "determines the largest value in the dimension A that would give a B coordinate of THISB if a line were drawn from the point (0,0) with a slope of DA/DB.") (COND ((IGREATERP DA DB) (IQUOTIENT (IPLUS (IDIFFERENCE (ITIMES (ADD1 THISB) DA) (HALF DA)) -1) DB)) (T (IQUOTIENT (IPLUS (ITIMES THISB DA) (HALF DB)) DB]) + +(\DRAWLINE1 [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH) (* mpl " 2-Jan-84 18:00") (* ;; "this was changed to interface with the opcode for line drawing. It probably be incorporated into the places it is called.") (* ;; "draws a line starting at X0,Y0 at a slope of DX/DY until reaching either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE. Arranged so that the clipping routines can determine what the exact location of the end point of the clipped line is wrt line drawing coordinates eg. amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be moved in that direction.") (\DRAWLINE.UFN (\ADDBASE BITMAPBASE (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 BITSPERWORD))) (LOGAND X0 15) DX YINC DY (SELECTQ MODE (INVERT 2) (ERASE 1) 0) CDL (ADD1 XLIMIT) (ADD1 YLIMIT]) + +(\DRAWLINE.UFN [LAMBDA (FIRSTADDR FIRSTBIT XDELTA YINCR YDELTA OPERATIONCODE INITIALBUCKET PIXELSINX PIXELSINY) (* jds " 6-Jan-86 11:27") (* ;; "FIRSTADDR is the address of the word which contains the first point. FIRSTBIT is the address of the first bit in FIRSTADDR. XDELTA and YDELTA are how far the complete line has to move in X and Y respectively; both are positive quantities. YINCR is the amount the address should be incremented if the Y coordinate changes and can be either positive or negative. OPERATIONCODE is 0 for REPLACE, 1 for ERASE and 2 for INVERT. INITIALBUCKET is between 0 and the maximum of DX and DY and gives the starting amount of the bucket used to determine when to increment in the slower moving direction. PIXELSINX and PIXELSINY indicates how many pixels should be drawn in the X and Y direction.") (DECLARE (LOCALVARS . T)) (PROG ((MASK (\BITMASK FIRSTBIT))) (COND [(IGEQ XDELTA YDELTA) (* ; "X is the fastest mover.") (SELECTQ OPERATIONCODE (0 (.DRAWLINEX. 'REPLACE/PAINT)) (1 (.DRAWLINEX. 'ERASE)) (.DRAWLINEX. 'INVERT] (T (* ; "Y is the fastest mover.") (SELECTQ OPERATIONCODE (0 (.DRAWLINEY. 'REPLACE/PAINT)) (1 (.DRAWLINEY. 'ERASE)) (.DRAWLINEY. 'INVERT]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS .DRAWLINEX. MACRO ((MODE) + (bind (NY _ 0) for PT from 1 to PIXELSINX + do (* ; "main loop") + [replace (BITMAPWORD BITS) of FIRSTADDR + with (SELECTQ MODE + (INVERT (LOGXOR MASK (fetch (BITMAPWORD + BITS) + of FIRSTADDR))) + (ERASE (LOGAND (LOGXOR MASK WORDMASK) + (fetch (BITMAPWORD BITS) + of FIRSTADDR))) + (PROGN (* ; + "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") + (LOGOR MASK (fetch (BITMAPWORD + BITS) + of FIRSTADDR] + [COND + ([NOT (IGREATERP XDELTA (SETQ INITIALBUCKET (IPLUS + INITIALBUCKET + YDELTA] + (* ; "increment in the Y direction") + (COND + ((EQ (SETQ NY (ADD1 NY)) + PIXELSINY) + (RETURN))) + (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET XDELTA)) + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR] + (SETQ MASK (LRSH MASK 1)) + (COND + ((EQ 0 MASK) (* ; "crossed word boundary") + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) + (SETQ MASK 32768] + +[PUTPROPS .DRAWLINEY. MACRO ((MODE) + (bind (NX _ 0) for PT from 1 to PIXELSINY + do (* ; "main loop") + [replace (BITMAPWORD BITS) of FIRSTADDR + with (SELECTQ MODE + (INVERT (LOGXOR MASK (fetch (BITMAPWORD + BITS) + of FIRSTADDR))) + (ERASE (LOGAND (LOGXOR MASK WORDMASK) + (fetch (BITMAPWORD BITS) + of FIRSTADDR))) + (PROGN (* ; + "case is PAINT or REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1") + (LOGOR MASK (fetch (BITMAPWORD + BITS) + of FIRSTADDR] + [COND + ([NOT (IGREATERP YDELTA (SETQ INITIALBUCKET (IPLUS + INITIALBUCKET + XDELTA] + (COND + ((EQ (SETQ NX (ADD1 NX)) + PIXELSINX) + (RETURN))) + (SETQ INITIALBUCKET (IDIFFERENCE INITIALBUCKET YDELTA)) + (SETQ MASK (LRSH MASK 1)) + (COND + ((EQ 0 MASK) (* ; "crossed word boundary") + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR 1)) + (SETQ MASK 32768] + (SETQ FIRSTADDR (\ADDBASE FIRSTADDR YINCR] +) +) + + + +(* ; "Curves") + +(DEFINEQ + +(\DRAWCIRCLE.DISPLAY [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* kbr%: "15-Feb-86 22:24") (* ;; "\DRAWCIRCLE.DISPLAY extended for color. Color is specified by either BRUSH or the DSPCOLOR of DS.") (DECLARE (LOCALVARS . T)) (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) ((EQ RADIUS 0) (* ; "don't draw anything.") NIL) (DASHING (* ;  "draw it with the arc drawing code which does dashing. Slow but effective.") (* ;; "the CDR removes the first point to work around a bug in curve drawing when closed and first and last points the same. AR 4623.0") (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360)) T BRUSH DASHING DISPLAYSTREAM)) (T (GLOBALRESOURCE \BRUSHBBT (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN) (SETQ X 0) (SETQ Y RADIUS) (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) (SETQ BBT \BRUSHBBT) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ USERFN (AND (LITATOM BRUSH) BRUSH)) (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") (COND (USERFN (* ;  "if calling user fn, don't bother with set up and leave points in stream coordinates.") (SETQ CX CENTERX) (SETQ CY CENTERY)) (T (.SETUP.FOR.\BBTCURVEPT.) (SELECTQ NBITS (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)) DISPLAYDATA))) (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) 2)) DISPLAYDATA))) (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) 2)) DISPLAYDATA))) (24 (* ;  "I doubt that this will be right.") (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO (IQUOTIENT BRUSHWIDTH 24 ) 2)) DISPLAYDATA))) (SHOULDNT)) (* ;  "take into account the brush thickness.") (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) DISPLAYDATA)) (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") (\INSURETOPWDS DISPLAYSTREAM))) [COND ((EQ RADIUS 1) (* ; "put a single brush down.") (* ;  "draw the top and bottom most points.") [COND (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX CY] (RETURN)) (T (* ;  "draw the top and bottom most points.") (COND (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) DISPLAYSTREAM) (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT CX (IPLUS CY RADIUS)) (\CURVEPT CX (IDIFFERENCE CY RADIUS] LP (* ;  "(UNFOLD x 2) is used instead of (ITIMES x 2)") [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3)) (SETQ Y (SUB1 Y] (COND [(EQ Y 0) (* ;; "left most and right most points are drawn specially so that they are not duplicated which leaves a hole in XOR mode.") (COND (USERFN (APPLY* USERFN (IPLUS CX X) CY DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) CY DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX X) CY) (\CURVEPT (IDIFFERENCE CX X) CY] (T [COND (USERFN (APPLY* USERFN (IPLUS CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IPLUS CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CIRCLEPTS CX CY X Y] (GO LP))) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL]) + +(\DRAWARC.DISPLAY [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* ; "draws an arc on the display") (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) + +(\DRAWARC.GENERIC [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* rrb " 4-Oct-85 18:23") (* ;  "draws an arc by drawing a curve.") (COND ((AND (GREATERP 360 NDEGREES) (LESSP -360 NDEGREES)) (DRAWCURVE (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS STARTANGLE NDEGREES) NIL BRUSH DASHING STREAM)) (T (* ;  "use circle drawing which could be faster") (DRAWCIRCLE CENTERX CENTERY RADIUS BRUSH DASHING STREAM]) + +(\COMPUTE.ARC.POINTS [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES) (* DECLARATIONS%: FLOATING) (* rrb "30-Oct-85 11:48") (* ;; "computes a list of knots that a spline goes through to make an arc") (PROG ((ANGLESIZE (COND ((OR (GREATERP NDEGREES 360.0) (GREATERP -360.0 NDEGREES)) 360.0) (T NDEGREES))) ANGLEINCR) (* ;; "calculate an increment close to 10.0 that is exact but always have at least 5 knots and don't have more than a knot every 5 pts") [SETQ ANGLEINCR (FQUOTIENT ANGLESIZE (IMIN (IMAX (ABS (FIX (FQUOTIENT ANGLESIZE 10.0))) 5) (PROGN (* ;  "don't have more than a knot every 5 pts") (IMAX (ABS (FIX (QUOTIENT (TIMES RADIUS 6.3 (QUOTIENT ANGLESIZE 360.0)) 4))) 3] (* ;; "go from initial point to just past the last point. The just past (PLUS BETA (QUOTIENT ANGLEINCR 5.0)) picks up the case where the floating pt rounding error accumulates to be greater than the last point when it is very close to it.") (RETURN (for ANGLE from STARTANGLE to (PLUS STARTANGLE ANGLESIZE (QUOTIENT ANGLEINCR 5.0)) by ANGLEINCR collect (create POSITION XCOORD _ [FIXR (PLUS CENTERX (TIMES RADIUS (COS ANGLE] YCOORD _ (FIXR (PLUS CENTERY (TIMES RADIUS (SIN ANGLE]) + +(\DRAWELLIPSE.DISPLAY [LAMBDA (DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 12-Apr-88 23:58 by FS") (DECLARE (LOCALVARS . T)) (* ;; "Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical. Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center of the ellipse.") (PROG ((CENTERX (FIXR CENTERX)) (CENTERY (FIXR CENTERY)) (SEMIMINORRADIUS (FIXR SEMIMINORRADIUS)) (SEMIMAJORRADIUS (FIXR SEMIMAJORRADIUS))) (COND ((OR (EQ 0 SEMIMINORRADIUS) (EQ 0 SEMIMAJORRADIUS)) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN))) (COND ((ILESSP SEMIMINORRADIUS 1) (\ILLEGAL.ARG SEMIMINORRADIUS)) ((ILESSP SEMIMAJORRADIUS 1) (\ILLEGAL.ARG SEMIMAJORRADIUS)) ((OR (NULL ORIENTATION) (EQ SEMIMINORRADIUS SEMIMAJORRADIUS)) (SETQ ORIENTATION 0)) ((NULL (NUMBERP ORIENTATION)) (\ILLEGAL.ARG ORIENTATION))) (* ;; "If dashing, draw it with the curve drawing code which can do dashing") (COND (DASHING (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (RETURN))) (* ;; "If degenerate ellipse, attempt circumvention of Pitteway breakdown by trying spline code instead, which appears more numerically stable (see AR6502)") (COND ((< 40 (/ SEMIMAJORRADIUS SEMIMINORRADIUS)) (\DRAWELLIPSE.GENERIC DISPLAYSTREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (RETURN))) (* ;;; "This function is the implementation of the algorithm given in 'Algorithm for drawing ellipses or hyperbolae with a digital plotter' by Pitteway appearing in Computer Journal 10: (3) Nov 1967.0 The input parameters are used to determine the ellipse equation (1/8) Ayy+ (1/8) Bxx+ (1/4) Gxy+ (1/4) Ux+ (1/4) Vy= (1/4) K which specifies a translated version of the desired ellipse. This ellipse passes through the mesh point (0,0), the initial point of the algorithm. The power of 2 factors reflect an implementation convenience.") (GLOBALRESOURCE \BRUSHBBT (PROG (DestinationBitMap LEFT RIGHTPLUS1 BOTTOM TOP BOTTOMMINUSBRUSH TOPMINUSBRUSH LEFTMINUSBRUSH DESTINATIONBASE BRUSHBASE BRUSHHEIGHT BRUSHWIDTH RASTERWIDTH BRUSHRASTERWIDTH BRUSHBM OPERATION HEIGHTMINUS1 (BBT \BRUSHBBT) (cosOrientation (COS ORIENTATION)) (sinOrientation (SIN ORIENTATION)) (SEMIMINORRADIUSSQUARED (ITIMES SEMIMINORRADIUS SEMIMINORRADIUS)) (SEMIMAJORRADIUSSQUARED (ITIMES SEMIMAJORRADIUS SEMIMAJORRADIUS)) (x 0) (y 0) (x2 1) x1 y1 y2 k1 k2 k3 a b d w A B G U V K CX CY yOffset CYPlusOffset CYMinusOffset NBITSRIGHTPLUS1 COLORBRUSHBASE COLOR NBITS (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") (COND (USERFN (* ;  "if calling user fn, don't bother with set up and leave points in window coordinates.") (SETQ CX CENTERX) (SETQ CY CENTERY)) (T (.SETUP.FOR.\BBTCURVEPT.) (* ;  "take into account the brush thickness.") (SELECTQ NBITS (1 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO BRUSHWIDTH 2)) DISPLAYDATA))) (4 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 2) 2)) DISPLAYDATA))) (8 (SETQ CX (\DSPTRANSFORMX (IDIFFERENCE CENTERX (FOLDLO (LRSH BRUSHWIDTH 3) 2)) DISPLAYDATA))) (SHOULDNT)) (SETQ CY (\DSPTRANSFORMY (IDIFFERENCE CENTERY (FOLDLO BRUSHHEIGHT 2)) DISPLAYDATA)) (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") (\INSURETOPWDS DISPLAYSTREAM))) (SETQ A (FPLUS (FTIMES SEMIMAJORRADIUSSQUARED cosOrientation cosOrientation) (FTIMES SEMIMINORRADIUSSQUARED sinOrientation sinOrientation))) (SETQ B (LSH (FIXR (FPLUS (FTIMES SEMIMINORRADIUSSQUARED cosOrientation cosOrientation) (FTIMES SEMIMAJORRADIUSSQUARED sinOrientation sinOrientation))) 3)) (SETQ G (FTIMES cosOrientation sinOrientation (LSH (IDIFFERENCE SEMIMINORRADIUSSQUARED SEMIMAJORRADIUSSQUARED ) 1))) [SETQ yOffset (FIXR (FQUOTIENT (ITIMES SEMIMINORRADIUS SEMIMAJORRADIUS) (SQRT A] (SETQ CYPlusOffset (IPLUS CY yOffset)) (SETQ CYMinusOffset (IDIFFERENCE CY yOffset)) (SETQ U (LSH (FIXR (FTIMES A (LSH yOffset 1))) 2)) (SETQ V (LSH (FIXR (FTIMES G yOffset)) 2)) (SETQ K (LSH [FIXR (FDIFFERENCE (ITIMES SEMIMINORRADIUSSQUARED SEMIMAJORRADIUSSQUARED) (FTIMES A (ITIMES yOffset yOffset] 2)) (SETQ A (LSH (FIXR A) 3)) (SETQ G (LSH (FIXR G) 2)) (* ;; "The algorithm is incremental and iterates through the octants of a cartesian plane. The octants are labeled from 1 through 8 beginning above the positive X axis and proceeding counterclockwise. Decisions in making the incremental steps are determined according to the error term d which is updated according to the curvature terms a and b. k1, k2, and k3 are used to correct the error and curvature terms at octant boundaries. The initial values of these terms depends on the octant in which drawing begins. The initial move steps (x1,y1) and (x2,y2) also depend on the starting octant.") [COND [(ILESSP (ABS U) (ABS V)) (SETQ x1 0) (COND [(MINUSP V) (* ; "start in octant 2") (SETQ y1 1) (SETQ y2 1) (SETQ k1 (IMINUS A)) (SETQ k2 (IDIFFERENCE k1 G)) (SETQ k3 (IDIFFERENCE k2 (IPLUS B G))) (SETQ b (IPLUS U (RSH (IPLUS A G) 1))) (SETQ a (IMINUS (IPLUS b V))) (SETQ d (IPLUS b (RSH B 3) (RSH V 1) (IMINUS K] (T (* ; "start in octant 7") (SETQ y1 -1) (SETQ y2 -1) (SETQ k1 A) (SETQ k2 (IDIFFERENCE k1 G)) (SETQ k3 (IPLUS k2 B (IMINUS G))) (SETQ b (IPLUS U (RSH (IDIFFERENCE G A) 1))) (SETQ a (IDIFFERENCE V b)) (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH V 1) (RSH B 3] (T (SETQ x1 1) (SETQ y1 0) (COND [(MINUSP V) (* ; "start in octant 1") (SETQ y2 1) (SETQ k1 B) (SETQ k2 (IPLUS k1 G)) (SETQ k3 (IPLUS k2 A G)) [SETQ b (IMINUS (IPLUS V (RSH (IPLUS B G) 1] (SETQ a (IDIFFERENCE U b)) (SETQ d (IPLUS b K (IMINUS (IPLUS (RSH A 3) (RSH U 1] (T (* ; "start in octant 8") (SETQ y2 -1) (SETQ k1 (IMINUS B)) (SETQ k2 (IPLUS k1 G)) (SETQ k3 (IPLUS k2 G (IMINUS A))) (SETQ b (IPLUS V (RSH (IDIFFERENCE B G) 1))) (SETQ a (IDIFFERENCE U b)) (SETQ d (IPLUS b (RSH A 3) (IMINUS (IPLUS K (RSH U 1] (* ;; "The ellipse equation describes an ellipse of the desired size and ORIENTATION centered at (0,0) and then dropped yOffset mesh points so that it will pass through (0,0). Thus, the intended starting point is (CX, CY+yOffset) where (CX, CY) is the center of the desired ellipse. Drawing is accomplished with point relative steps. In each octant, the error term d is used to choose between move 1 (an axis move) and move 2 (a diagonal move).") MOVE [COND ((MINUSP d) (* ; "move 1") (SETQ x (IPLUS x x1)) (SETQ y (IPLUS y y1)) (SETQ b (IDIFFERENCE b k1)) (SETQ a (IPLUS a k2)) (SETQ d (IPLUS b d))) (T (* ; "move 2") (SETQ x (IPLUS x x2)) (SETQ y (IPLUS y y2)) (SETQ b (IDIFFERENCE b k2)) (SETQ a (IPLUS a k3)) (SETQ d (IDIFFERENCE d a] (COND ((MINUSP x) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL))) [COND (USERFN (APPLY* USERFN (IPLUS CX x) (IPLUS CYPlusOffset y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX x) (IDIFFERENCE CYMinusOffset y) DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVEPT (IPLUS CX x) (IPLUS CYPlusOffset y)) (\CURVEPT (IDIFFERENCE CX x) (IDIFFERENCE CYMinusOffset y] (AND (MINUSP b) (GO SQUARE)) DIAGONAL (OR (MINUSP a) (GO MOVE)) (* ; "diagonal octant change") (SETQ x1 (IDIFFERENCE x2 x1)) (SETQ y1 (IDIFFERENCE y2 y1)) (SETQ w (IDIFFERENCE (LSH k2 1) k3)) (SETQ k1 (IDIFFERENCE w k1)) (SETQ k2 (IDIFFERENCE k2 k3)) (SETQ k3 (IMINUS k3)) [SETQ b (IPLUS b a (IMINUS (RSH (ADD1 k2) 1] [SETQ d (IPLUS b (RSH (IPLUS k3 4) 3) (IMINUS d) (IMINUS (RSH (ADD1 a) 1] (SETQ a (IDIFFERENCE (RSH (ADD1 w) 1) a)) (OR (MINUSP b) (GO MOVE)) SQUARE (* ; "square octant change") [COND ((EQ 0 x1) (SETQ x2 (IMINUS x2))) (T (SETQ y2 (IMINUS y2] (SETQ w (IDIFFERENCE k2 k1)) (SETQ k1 (IMINUS k1)) (SETQ k2 (IPLUS w k1)) (SETQ k3 (IDIFFERENCE (LSH w 2) k3)) (SETQ b (IDIFFERENCE (IMINUS b) w)) (SETQ d (IDIFFERENCE (IDIFFERENCE b a) d)) (SETQ a (IDIFFERENCE (IDIFFERENCE a w) (LSH b 1))) (GO DIAGONAL]) + +(\DRAWCURVE.DISPLAY [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 9-Jan-87 16:49 by rrb") (* ;; "draws a spline curve with a given brush.") (GLOBALRESOURCE \BRUSHBBT (PROG ((BBT \BRUSHBBT) (DASHLST (\GOOD.DASHLST DASHING BRUSH))) (SELECTQ (LENGTH KNOTS) (0 (* ;  "No knots => empty curve rather than error?") NIL) (1 (* ;  "only one knot, put down a brush shape") (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) BRUSH)) (2 (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (OR (type? POSITION (CADR KNOTS)) (ERROR "bad knot" (CADR KNOTS))) (\LINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) (fetch XCOORD of (CADR KNOTS)) (fetch YCOORD of (CADR KNOTS)) BRUSH DASHLST DISPLAYSTREAM BBT)) (\CURVE2 (PARAMETRICSPLINE KNOTS CLOSED) BRUSH DASHLST BBT DISPLAYSTREAM)) (RETURN DISPLAYSTREAM]) + +(\DRAWPOINT.DISPLAY [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION) (* rrb "17-Sep-86 17:51") (* ;; "draws a brush point at position X Y") (* ;; "this is used in 4, 8, and 24 bit per pixel bitmaps as well. For these, it may be should call BITMAPWIDTH instead of fetching.") (PROG ((BRUSHBM (\GETBRUSH BRUSH))) (* ;  "SUB1 is to put extra bit of even brush on the top or left.") (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (fetch (BITMAP BITMAPWIDTH) of BRUSHBM] [IDIFFERENCE Y (HALF (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BRUSHBM] NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM)) (REPLACE 'PAINT) OPERATION]) + +(\DRAWPOLYGON.DISPLAY [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 13-Apr-88 14:14 by FS") (* ;; "Somewhat less generic version of drawpolygon that calls \drawline.display. Brush must be a brush (guaranteed in DRAWPOLYGON) other users must also ensure.") (* ;; "This is different than drawline.generic, because drawline.display will use width argument instead of bltting brushes around. That way you can get shades, dspoperation, eventually.") (PROG [COLOR (PTBRUSH (COND ((EQ (fetch (BRUSH BRUSHSHAPE) of BRUSH) 'ROUND) BRUSH) (T (create BRUSH using BRUSH BRUSHSHAPE _ 'ROUND] (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of PTBRUSH)) (for PTAIL on POINTS while (CDR PTAIL) do (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD) of (CAR PTAIL)) (ffetch (POSITION YCOORD) of (CAR PTAIL)) (fetch (POSITION XCOORD) of (CADR PTAIL)) (ffetch (POSITION YCOORD) of (CADR PTAIL)) (fetch (BRUSH BRUSHSIZE) of BRUSH) NIL COLOR DASHING) (* ;  "put a brush between lines so it looks better. It's not mitered this way but better than not.") (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION XCOORD) of (CADR POINTS)) (fetch (POSITION YCOORD) of (CADR POINTS)) PTBRUSH 'NIL) finally (COND ((AND CLOSED (CDDR POINTS)) (* ; "draw the closing line.") (\DRAWLINE.DISPLAY STREAM (fetch (POSITION XCOORD) of (CAR PTAIL)) (ffetch (POSITION YCOORD) of (CAR PTAIL)) (fetch (POSITION XCOORD) of (CAR POINTS)) (ffetch (POSITION YCOORD) of (CAR POINTS)) (fetch (BRUSH BRUSHSIZE) of BRUSH) NIL COLOR DASHING))) (OR (NULL (CDR POINTS)) (\DRAWPOINT.DISPLAY STREAM (fetch (POSITION XCOORD) of (CAR POINTS)) (fetch (POSITION YCOORD) of (CAR POINTS)) PTBRUSH NIL]) + +(\LINEWITHBRUSH [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM BBT OPERATION) (* ; "Edited 29-Oct-87 17:40 by scp") (* ;; "draws a line with a brush on a guaranteed display-stream DISPLAYSTREAM") (DECLARE (LOCALVARS . T)) (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))) (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") (* ;  "move the display stream position before the coordinates are clobbered.") (COND ((NOT USERFN) (.SETUP.FOR.\BBTCURVEPT.) (SELECTQ NBITS (1 (* ;  "SUB1 is so that the extra bit goes on the top and right as it is documented as doing for lines.") (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH (FOLDLO (SUB1 BRUSHWIDTH) 2))) DISPLAYDATA))) (4 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH (FOLDLO (LRSH (SUB1 BRUSHWIDTH) 2) 2))) DISPLAYDATA))) (8 (SETQ X1 (\DSPTRANSFORMX (IDIFFERENCE X1 (SETQ HALFBRUSHWIDTH (FOLDLO (LRSH (SUB1 BRUSHWIDTH) 3) 2))) DISPLAYDATA))) (SHOULDNT)) (SETQ X2 (\DSPTRANSFORMX (IDIFFERENCE X2 HALFBRUSHWIDTH) DISPLAYDATA)) (SETQ Y1 (\DSPTRANSFORMY (IDIFFERENCE Y1 (SETQ HALFBRUSHHEIGHT (FOLDLO (SUB1 BRUSHHEIGHT ) 2))) DISPLAYDATA)) (* ;  "take into account the brush thickness.") (SETQ Y2 (\DSPTRANSFORMY (IDIFFERENCE Y2 HALFBRUSHHEIGHT) DISPLAYDATA)) (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") (\INSURETOPWDS DISPLAYSTREAM))) (* ;  "arrange things so that dx is positive.") (COND ((IGREATERP X1 X2) (* ; "switch points") (swap X1 X2) (swap Y1 Y2))) (SETQ DX (ADD1 (IDIFFERENCE X2 X1))) [SETQ DY (ADD1 (COND ((IGREATERP Y2 Y1) (SETQ YINC 1) (IDIFFERENCE Y2 Y1)) (T (SETQ YINC -1) (IDIFFERENCE Y1 Y2] [SETQ CDL (HALF (COND ((IGREATERP DX DY) (* ;  "set up the bucket so that the ends will be the same.") (IREMAINDER DX DY)) (T (IREMAINDER DY DX] [COND [USERFN (* ;  "if user function is being called, don't bother bringing window to top uninterruptably.") (COND ((IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ((NOT (IGREATERP DX (add CDL DY))) (add Y1 YINC) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (add X1 1))) (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (add Y1 YINC] (T (* ;  "when we put the points down make it uninterruptable") (.WHILE.TOP.DS. DISPLAYSTREAM (COND [(IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (\CURVEPT X1 Y1))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (SETQ Y1 (IPLUS Y1 YINC)) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (SETQ X1 (ADD1 X1] (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (\CURVEPT X1 Y1))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (SETQ Y1 (IPLUS Y1 YINC] (RETURN NIL]) +) +(DEFINEQ + +(LOADPOLY [LAMBDA (POLY POLYPRIME A B C D) (* hdj "13-Mar-85 18:01") (replace (POLYNOMIAL A) of POLY with (FQUOTIENT A 6.0)) (replace (POLYNOMIAL B) of POLY with (FQUOTIENT B 2.0)) (replace (POLYNOMIAL C) of POLY with C) (replace (POLYNOMIAL D) of POLY with D) (replace (POLYNOMIAL A) of POLYPRIME with (FQUOTIENT A 2.0)) (replace (POLYNOMIAL B) of POLYPRIME with B) (replace (POLYNOMIAL C) of POLYPRIME with C]) + +(PARAMETRICSPLINE [LAMBDA (KNOTS CLOSEDFLG SPLINE) (* rmk%: "30-Nov-84 17:02") (* ;; "KNOTS is a non-NIL list of knots, CLOSEDFLG => closed curve") (PROG (DX DY DDX DDY DDDX DDDY %#KNOTS A BX BY X Y SX SY A C R D2X D2Y I) [COND (CLOSEDFLG (* ; "Wrap around") (push KNOTS (CAR (LAST KNOTS] (SETQ %#KNOTS (LENGTH KNOTS)) (SETQ DX (ARRAY %#KNOTS 0 0.0)) (SETQ DDX (ARRAY %#KNOTS 0 0.0)) (SETQ DDDX (ARRAY %#KNOTS 0 0.0)) (SETQ DY (ARRAY %#KNOTS 0 0.0)) (SETQ DDY (ARRAY %#KNOTS 0 0.0)) (SETQ DDDY (ARRAY %#KNOTS 0 0.0)) (SETQ X (ARRAY %#KNOTS 0 0.0)) (SETQ Y (ARRAY %#KNOTS 0 0.0)) (for KNOT in KNOTS as I from 1 to %#KNOTS do (OR (type? POSITION KNOT) (ERROR "bad knot" KNOT)) (SETA X I (CAR KNOT)) (SETA Y I (CDR KNOT))) (SETQ A (ARRAY %#KNOTS 0 0.0)) (SETQ BX (ARRAY %#KNOTS 0 0.0)) (SETQ BY (ARRAY %#KNOTS 0 0.0)) [COND (CLOSEDFLG (SETQ C (ARRAY %#KNOTS 0 0.0)) (SETQ R (ARRAY %#KNOTS 0 0.0)) (SETQ SX (ARRAY %#KNOTS 0 0.0)) (SETQ SY (ARRAY %#KNOTS 0 0.0] (SETA A 1 4.0) [for I from 2 to (IDIFFERENCE %#KNOTS 2) do (SETA A I (FDIFFERENCE 4.0 (FQUOTIENT 1.0 (ELT A (SUB1 I] [COND (CLOSEDFLG (SETA C 1 1.0) (for I from 2 to (IDIFFERENCE %#KNOTS 2) do (SETA C I (FMINUS (FQUOTIENT (ELT C (SUB1 I)) (ELT A (SUB1 I] [COND ((IGEQ %#KNOTS 3) (COND [CLOSEDFLG [SETA BX 1 (FTIMES 6.0 (FPLUS (ELT X 2) (FMINUS (FTIMES 2.0 (ELT X 1))) (ELT X (SUB1 %#KNOTS] [SETA BY 1 (FTIMES 6.0 (FPLUS (ELT Y 2) (FMINUS (FTIMES 2.0 (ELT Y 1))) (ELT Y (SUB1 %#KNOTS] [for I from 2 to (IDIFFERENCE %#KNOTS 2) do [SETA BX I (FDIFFERENCE [FTIMES 6.0 (FPLUS (ELT X (ADD1 I)) (FMINUS (FTIMES 2.0 (ELT X I))) (ELT X (SUB1 I] (FQUOTIENT (ELT BX (SUB1 I)) (ELT A (SUB1 I] (SETA BY I (FDIFFERENCE [FTIMES 6.0 (FPLUS (ELT Y (ADD1 I)) (FMINUS (FTIMES 2.0 (ELT Y I))) (ELT Y (SUB1 I] (FQUOTIENT (ELT BY (SUB1 I)) (ELT A (SUB1 I] (SETA R (SUB1 %#KNOTS) 1.0) (SETA SX (SUB1 %#KNOTS) 0.0) (SETA SY (SUB1 %#KNOTS) 0.0) (for I from (IDIFFERENCE %#KNOTS 2) to 1 by -1 do [SETA R I (FMINUS (FQUOTIENT (FPLUS (ELT R (ADD1 I)) (ELT C I)) (ELT A I] (SETA SX I (FQUOTIENT (FDIFFERENCE (ELT BX I) (ELT SX (ADD1 I))) (ELT A I))) (SETA SY I (FQUOTIENT (FDIFFERENCE (ELT BY I) (ELT SY (ADD1 I))) (ELT A I] (T [SETA BX 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT X 3) (FTIMES 2.0 (ELT X 2))) (ELT X 1] [SETA BY 1 (FTIMES 6.0 (FPLUS (FDIFFERENCE (ELT Y 3) (FTIMES 2.0 (ELT Y 2))) (ELT Y 1] (for I from 2 to (IDIFFERENCE %#KNOTS 2) do [SETA BX I (FDIFFERENCE (FTIMES 6.0 (FPLUS [FDIFFERENCE (ELT X (IPLUS I 2)) (FTIMES 2 (ELT X (ADD1 I] (ELT X I))) (FQUOTIENT (ELT BX (SUB1 I)) (ELT A (SUB1 I] (SETA BY I (FDIFFERENCE (FTIMES 6.0 (FPLUS [FDIFFERENCE (ELT Y (IPLUS I 2)) (FTIMES 2 (ELT Y (ADD1 I] (ELT Y I))) (FQUOTIENT (ELT BY (SUB1 I)) (ELT A (SUB1 I] [COND (CLOSEDFLG [SETQ D2X (FPLUS (ELT X %#KNOTS) [FMINUS (FTIMES 2.0 (ELT X (SUB1 %#KNOTS] (ELT X (IDIFFERENCE %#KNOTS 2] [SETQ D2Y (FPLUS (ELT Y %#KNOTS) [FMINUS (FTIMES 2.0 (ELT Y (SUB1 %#KNOTS] (ELT Y (IDIFFERENCE %#KNOTS 2] (SETA DDX (SUB1 %#KNOTS) (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2X 6.0) (ELT SX 1)) (ELT SX (IDIFFERENCE %#KNOTS 2))) (FPLUS (ELT R 1) (ELT R (IDIFFERENCE %#KNOTS 2)) 4.0))) (SETA DDY (SUB1 %#KNOTS) (FQUOTIENT (FDIFFERENCE (FDIFFERENCE (FTIMES D2Y 6.0) (ELT SY 1)) (ELT SY (IDIFFERENCE %#KNOTS 2))) (FPLUS (ELT R 1) (ELT R (IDIFFERENCE %#KNOTS 2)) 4.0))) [for I from 1 to (IDIFFERENCE %#KNOTS 2) do [SETA DDX I (FPLUS (ELT SX I) (FTIMES (ELT R I) (ELT DDX (SUB1 %#KNOTS] (SETA DDY I (FPLUS (ELT SY I) (FTIMES (ELT R I) (ELT DDY (SUB1 %#KNOTS] (SETA DDX %#KNOTS (ELT DDX 1)) (SETA DDY %#KNOTS (ELT DDY 1))) (T (* ; "COMPUTE SECOND DERIVATIVES.") [SETA DDX 1 (SETA DDY 1 (SETA DDX %#KNOTS (SETA DDY %#KNOTS 0.0] (for I from (SUB1 %#KNOTS) to 2 by -1 do [SETA DDX I (FQUOTIENT (FDIFFERENCE (ELT BX (SUB1 I)) (ELT DDX (ADD1 I))) (ELT A (SUB1 I] (SETA DDY I (FQUOTIENT (FDIFFERENCE (ELT BY (SUB1 I)) (ELT DDY (ADD1 I))) (ELT A (SUB1 I] [for I from 1 to (SUB1 %#KNOTS) do (* ; "COMPUTE 1ST & 3RD DERIVATIVES") (SETA DX I (FDIFFERENCE (FDIFFERENCE (ELT X (ADD1 I)) (ELT X I)) (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDX I)) (ELT DDX (ADD1 I))) 6.0))) (SETA DY I (FDIFFERENCE (FDIFFERENCE (ELT Y (ADD1 I)) (ELT Y I)) (FQUOTIENT (FPLUS (FTIMES 2 (ELT DDY I)) (ELT DDY (ADD1 I))) 6.0))) (SETA DDDX I (FDIFFERENCE (ELT DDX (ADD1 I)) (ELT DDX I))) (SETA DDDY I (FDIFFERENCE (ELT DDY (ADD1 I)) (ELT DDY I] (SETQ SPLINE (create SPLINE %#KNOTS _ %#KNOTS SPLINEX _ X SPLINEY _ Y SPLINEDX _ DX SPLINEDY _ DY SPLINEDDX _ DDX SPLINEDDY _ DDY SPLINEDDDX _ DDDX SPLINEDDDY _ DDDY)) (RETURN SPLINE]) + +(\CURVE [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM) (* rrb "30-Apr-85 12:44") (DECLARE (LOCALVARS . T)) (* ;; "Puts a spline segment down. Since it calls BitBlt1 directly, it must clip to both clipping region and the size of the destination bit map.") (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) [COND ((NEQ N 0) [COND (USERFN (* ;  "if there is a user fn, stay in his coordinates.") (SETQ OLDX X0) (SETQ OLDY Y0)) (T (* ;; "SUB1 on brush size is to cause the extra bit to be in the top left direction as is documented for lines.") (SETQ OLDX (\DSPTRANSFORMX (IDIFFERENCE X0 (LRSH (SUB1 BRUSHWIDTH) 1)) DISPLAYDATA)) (SETQ OLDY (\DSPTRANSFORMY (IDIFFERENCE Y0 (LRSH (SUB1 BRUSHHEIGHT) 1)) DISPLAYDATA] (* ; "draw origin point") (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) (* ;  "convert the derivatives to fractional representation.") (* ;; "\CONVERTTOFRACTION always returns a large number box. This uses 0.49 because 0.5 causes rounding up.") (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) (SETQ DX (\CONVERTTOFRACTION DX)) (SETQ DY (\CONVERTTOFRACTION DY)) (SETQ DDX (\CONVERTTOFRACTION DDX)) (SETQ DDY (\CONVERTTOFRACTION DDY)) (SETQ DDDX (\CONVERTTOFRACTION DDDX)) (SETQ DDDY (\CONVERTTOFRACTION DDDY)) [for I from 1 to N do (* ;  "uses \BOXIPLUS to save box and also set the new value of the variable.") (\BOXIPLUS X DX) (\BOXIPLUS DX DDX) (\BOXIPLUS DDX DDDX) (\BOXIPLUS Y DY) (\BOXIPLUS DY DDY) (\BOXIPLUS DDY DDDY) (SETQ OOLDX OLDX) (SETQ OOLDY OLDY) (SETQ DELTAX (IDIFFERENCE (SETQ OLDX (  \GETINTEGERPART X)) OOLDX)) (SETQ DELTAY (IDIFFERENCE (SETQ OLDY (  \GETINTEGERPART Y)) OOLDY)) (SETQ DELTA (IMAX (IABS DELTAX) (IABS DELTAY))) (COND ((EQ DELTA 1) (\CURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM)) ) (COND ((IGREATERP DELTA 1) (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA))) (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA))) (SETQ TX (\CONVERTTOFRACTION OOLDX)) (SETQ TY (\CONVERTTOFRACTION OOLDY)) (for I from 0 to DELTA do (\CURVESMOOTH (\GETINTEGERPART TX) (\GETINTEGERPART TY) USERFN DISPLAYSTREAM) (\BOXIPLUS TX DELTAX) (\BOXIPLUS TY DELTAY] (* ; "draw the end point") (COND (USERFN (\CURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM)) (T (\CURVESMOOTH (\DSPTRANSFORMX (IDIFFERENCE X1 (LRSH (SUB1 BRUSHWIDTH) 1)) DISPLAYDATA) (\DSPTRANSFORMY (IDIFFERENCE Y1 (LRSH (SUB1 BRUSHHEIGHT) 1)) DISPLAYDATA) NIL DISPLAYSTREAM))) (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM] (COND (ENDING (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM) (\CURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM))) (RETURN NIL]) + +(\CURVE2 [LAMBDA (SPLINE BRUSH DASHLST BBT DISPLAYSTREAM) (* jds "26-Nov-85 12:21") (* ;;; "Given a spline curve, represented as a set of derivatives for each segment, draw it on DISPLAYSTREAM using the brush BRUSH, and dashing it according to DASHLST. For speed, use the bitblt table BBT.") (DECLARE (SPECVARS . T)) (* ;; "DISPLAYSTREAM is guaranteed to be a display-stream. Should declare most of these variables local but currently have the \CURVE function between here and \CURVEBBT so can't") (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY DDY DDDY (XPOLY (create POLYNOMIAL)) (X/PRIME/POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y/PRIME/POLY (create POLYNOMIAL)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (* ;; "many of these variables are used by the macro for \CURVEPT that passes them to \BBTCURVEPT and .SETUP.FOR.\BBTCURVEPT. sets them up.") [COND (USERFN (* ;  "if calling user fn, don't bother with set up and leave points in window coordinates.") (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1))) (T (.SETUP.FOR.\BBTCURVEPT.) (* ;  "Do it interruptably here to get set up, then uninterruptably when drawing points") (\INSURETOPWDS DISPLAYSTREAM) (* ;  "curve pts will be kept in screen coordinates, start smoothing values there.") (\CURVESTART (\DSPTRANSFORMX (IDIFFERENCE (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (LRSH (SUB1 BRUSHWIDTH) 1)) DISPLAYDATA) (\DSPTRANSFORMY (IDIFFERENCE (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1) (LRSH (SUB1 BRUSHHEIGHT) 1)) DISPLAYDATA] [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) when (PROGN (* ;;  "Loop thru the segments of the spline curve, drawing each in turn.") (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) KNOT)) (* ;  "Set up X0,Y0 -- the starting point of this segment") (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) KNOT)) (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) (ADD1 KNOT))) (* ; "And X1,Y1 -- the ending point") (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) (ADD1 KNOT))) (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) KNOT)) (* ;  "And the initial derivatives -- first") (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) KNOT)) (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) KNOT)) (* ; "Second") (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) KNOT)) (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) KNOT)) (* ; "And third.") (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) KNOT)) (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) (IABS (IDIFFERENCE Y1 Y0))) 3) 2)) (* ;; "Establish an upper bound on the number of points we'll draw while painting this segment. We know that 3/2 the maximum DX or DY is the right amount.") (NOT (ZEROP NPOINTS))) do (* ;; "NPOINTS can be zero if a knot is duplicated in the spline curve to produce a discontinuity. Skip over zero-length segments to avoid divide-by-zero trouble") (* ;; "To prevent round-off errors from accumulating, we'll draw this segment as runs of no more than 64 points each -- recomputing completely at the start of each run. This is a trade off of speed and accuracy.") [COND ((ILEQ NPOINTS 64) (* ;  "Fewer than 64 points to draw. Do it in one run.") (SETQ NSEGS 1) (SETQ POINTSPERSEG NPOINTS)) (T (* ;  "Figure out how many runs to do it in.") (SETQ NSEGS (FOLDLO NPOINTS 64)) (SETQ POINTSPERSEG 64) (SETQ NPOINTS (UNFOLD NSEGS 64] (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (* ;  "Set up ÿ&Eÿt, ÿ&Eÿt**2 and ÿ&Eÿt**3, for computing the next point.") (SETQ D2 (FTIMES D1 D1)) (SETQ D3 (FTIMES D2 D1)) (SETQ D3X (FTIMES D3 DDDX)) (SETQ D3Y (FTIMES D3 DDDY)) (COND [(EQ NSEGS 1) (* ; "Just one segment to draw.") [SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES DDX D2 0.5) (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) [SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (* ;  "Draw this run of points, using the user's supplied function.") (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM)) (T (* ;  "Draw this run of points, using the brush.") (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] (T (* ;  "Have to do this segment in several runs.") (SETQ PERSEG (FQUOTIENT 1.0 NSEGS)) (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0) (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0) (bind (TT _ 0.0) (DDDX/PER/SEG _ (FTIMES DDDX PERSEG)) (DDDY/PER/SEG _ (FTIMES DDDY PERSEG)) [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I from 0 to (SUB1 NSEGS) do (* ;;  "TT is the parameter, and runs from 0 to 1 as the curve segment runs from beginning to end.") (SETQ TT (FPLUS TT PERSEG)) (SETQ X1 (POLYEVAL TT XPOLY 3)) (SETQ Y1 (POLYEVAL TT YPOLY 3)) (SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES D2 DDX 0.5) D3XFACTOR)) (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) (SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) D3YFACTOR)) (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) [COND (USERFN (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA BBT NIL USERFN DISPLAYSTREAM)) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA BBT NIL NIL DISPLAYSTREAM] (SETQ X0 X1) (SETQ Y0 Y1) (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] (* ;; "Draw the final point on the curve.") (COND (USERFN (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T USERFN DISPLAYSTREAM )) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\CURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA BBT T NIL DISPLAYSTREAM]) + +(\CURVEEND [LAMBDA NIL (* rrb " 5-JAN-82 17:24") (* ;; "Put out the last two points, using \CURVEPT, since they were held back for smoothing.") (PROG ((X \CURX) (Y \CURY) (DX (IDIFFERENCE \CURX \OLDX)) (DY (IDIFFERENCE \CURY \OLDY))) (for I from 1 to 2 do (\CURVESMOOTH (SETQ X (IPLUS X DX)) (SETQ Y (IPLUS Y DY]) + +(\CURVESLOPE [LAMBDA (KNOTS ENDFLG) (* rrb "30-Nov-84 18:17") (* ;; "returns a CONS of DX DY that gives the slope of the curve thru KNOTS. If ENDFLG is NIL, it is at the beginning. If ENDFLG is T, it is at the last point.") (PROG (DX DY PARAMS (%#KNOTS (LENGTH KNOTS))) (RETURN (SELECTQ %#KNOTS ((0 1) (* ; "define slope as horizontal") '(1 . 0)) (2 [CONS (DIFFERENCE (fetch (POSITION XCOORD) of (CADR KNOTS)) (fetch (POSITION XCOORD) of (CAR KNOTS))) (DIFFERENCE (fetch (POSITION YCOORD) of (CADR KNOTS)) (fetch (POSITION YCOORD) of (CAR KNOTS]) (PROGN [SETQ PARAMS (COND [ENDFLG (PARAMETRICSPLINE (REVERSE (NLEFT KNOTS (IMIN %#KNOTS 4] (T (PARAMETRICSPLINE (COND ((EQ %#KNOTS 3) (LIST (CAR KNOTS) (CADR KNOTS) (CADDR KNOTS))) (T (LIST (CAR KNOTS) (CADR KNOTS) (CADDR KNOTS) (CADDDR KNOTS] (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of PARAMS) 1)) (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of PARAMS) 1)) (if ENDFLG then (CONS (MINUS DX) (MINUS DY)) else (CONS DX DY]) + +(\CURVESTART [LAMBDA (X Y) (* jds "27-OCT-81 15:48") (* ;; "Set up the init vals for \OLDER* \OLD* \CUR*, for curve smoothing in \CURVEPT.") (SETQ \OLDERX X) (SETQ \OLDX X) (SETQ \CURX X) (SETQ \OLDERY Y) (SETQ \OLDY Y) (SETQ \CURY Y]) + +(\FDIFS/FROM/DERIVS [LAMBDA (DZ DDZ DDDZ RAD NSTEPS) (* rrb "12-MAY-81 10:59") (* ;; "the derivatives of the function, plus a scale factor (radius for drawing circles) See 'Spline Curve Techniques' , equations 2.18.") (PROG (S SS SSS) (SETQ S (FQUOTIENT 1.0 NSTEPS)) (SETQ SS (FTIMES S S)) (SETQ SSS (FTIMES SS S)) (SETQ S (FTIMES S DZ RAD)) (SETQ SS (FTIMES SS DDZ RAD)) (SETQ SSS (FTIMES SSS DDDZ RAD)) (RETURN (LIST (FPLUS S (FQUOTIENT SS 2.0) (FQUOTIENT SSS 6.0)) (FPLUS SS SSS) SSS]) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(ARRAYRECORD POLYNOMIAL (A B C D) + (CREATE (ARRAY 4 'FLOATP)) + (SYSTEM)) + +(RECORD SPLINE (%#KNOTS SPLINEX SPLINEY SPLINEDX SPLINEDY SPLINEDDX SPLINEDDY SPLINEDDDX + SPLINEDDDY)) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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))) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \CURVEPT MACRO + (OPENLAMBDA (X Y) + (COND + ((OR (ILEQ X LEFTMINUSBRUSH) + (IGEQ X RIGHTPLUS1) + (ILEQ Y BOTTOMMINUSBRUSH) + (IGEQ Y TOP)) + NIL) + ((NULL BBT) + (\FBITMAPBIT DESTINATIONBASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH)) + (T + (* ;; + "This should have been done in .SETUP.FOR.\BBTCURVEPT., under \GETBRUSHBBT.") + + (* ;; "Its a bug here, because brushes can't use operation REPLACE.") + + (* ;; "(\SETPBTFUNCTION BBT (ffetch DDSOURCETYPE of DISPLAYDATA) OPERATION)") + + (\BBTCURVEPT X Y BBT LEFT BRUSHWIDTH LEFTMINUSBRUSH RIGHTPLUS1 + NBITSRIGHTPLUS1 TOPMINUSBRUSH DestinationBitMap BRUSHHEIGHT + BOTTOMMINUSBRUSH TOP BRUSHBASE DESTINATIONBASE RASTERWIDTH + BRUSHRASTERWIDTH COLORBRUSHBASE NBITS DISPLAYDATA] + +[PUTPROPS .SETUP.FOR.\BBTCURVEPT. MACRO (NIL (PROGN (SETQ BOTTOM (ffetch (\DISPLAYDATA + DDClippingBottom) + of DISPLAYDATA)) + (SETQ TOP (ffetch (\DISPLAYDATA DDClippingTop + ) of DISPLAYDATA + )) + (SETQ RIGHTPLUS1 (ffetch (\DISPLAYDATA + DDClippingRight + ) + of DISPLAYDATA)) + (SETQ LEFT (ffetch (\DISPLAYDATA + DDClippingLeft) + of DISPLAYDATA)) + (SETQ DestinationBitMap (ffetch (\DISPLAYDATA + + DDDestination + ) + of DISPLAYDATA)) + (SETQ OPERATION (OR OPERATION (ffetch + (\DISPLAYDATA + DDOPERATION) + of + DISPLAYDATA + ))) + (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL + ) of + DestinationBitMap + )) + [COND + [(NOT (EQ NBITS 1)) + (SETQ BRUSHBM (\GETCOLORBRUSH BRUSH + (MAXIMUMCOLOR NBITS) + NBITS)) + [SETQ COLOR + (COND + [(AND (LISTP BRUSH) + (CAR (LISTP (CDDR BRUSH] + ((DSPCOLOR NIL DISPLAYSTREAM)) + (T (MAXIMUMCOLOR NBITS] + [COND + ((EQ OPERATION 'ERASE) + (SETQ COLOR (OPPOSITECOLOR COLOR NBITS] + (SETQ COLORBRUSHBASE + (fetch (BITMAP BITMAPBASE) + of (\GETCOLORBRUSH BRUSH COLOR NBITS] + (T (SETQ BRUSHBM (\GETBRUSH BRUSH] + (SETQ RASTERWIDTH (ffetch (BITMAP + BITMAPRASTERWIDTH + ) + of DestinationBitMap)) + (SETQ DESTINATIONBASE (ffetch (BITMAP + BITMAPBASE + ) + of DestinationBitMap + )) + (SETQ BBT (\GETBRUSHBBT BRUSHBM DISPLAYDATA + BBT)) + (SETQ BRUSHBASE (fetch (BITMAP BITMAPBASE) + of BRUSHBM)) + (SETQ BRUSHRASTERWIDTH (ffetch (BITMAP + BITMAPRASTERWIDTH + ) + of BRUSHBM)) + [COND + ((NULL BBT) + (SETQ HEIGHTMINUS1 (SUB1 (ffetch + (BITMAP + BITMAPHEIGHT + ) + of + DestinationBitMap + ))) + (COND + ((EQ (ffetch (\DISPLAYDATA DDOPERATION + ) of + DISPLAYDATA + ) + 'INVERT) + (SETQ OPERATION 'INVERT] + (SETQ BRUSHWIDTH (ffetch (BITMAP BITMAPWIDTH) + of BRUSHBM)) + (SETQ BRUSHHEIGHT (ffetch (BITMAP + BITMAPHEIGHT + ) + of BRUSHBM)) + (SETQ LEFTMINUSBRUSH (IDIFFERENCE LEFT BRUSHWIDTH + )) + (SETQ BOTTOMMINUSBRUSH (IDIFFERENCE BOTTOM + BRUSHHEIGHT)) + (SETQ TOPMINUSBRUSH (IDIFFERENCE TOP BRUSHHEIGHT) + ) + (SETQ NBITSRIGHTPLUS1 (ITIMES RIGHTPLUS1 NBITS)) + (SETQ BRUSHWIDTH (ITIMES BRUSHWIDTH NBITS] + +[PUTPROPS \CIRCLEPTS MACRO (OPENLAMBDA (CX CY X Y) + (\CURVEPT (IPLUS CX X) + (IPLUS CY Y)) + (\CURVEPT (IDIFFERENCE CX X) + (IPLUS CY Y)) + (\CURVEPT (IPLUS CX X) + (IDIFFERENCE CY Y)) + (\CURVEPT (IDIFFERENCE CX X) + (IDIFFERENCE CY Y] + +[PUTPROPS \CURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM) + (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX))) + (DY (IABS (IDIFFERENCE NEWY \OLDY] + (COND + ((OR (IGREATERP DX 1) + (IGREATERP DY 1)) + [COND + ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)) + (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY + \OLDERY] + 4) + [COND + (DASHON (COND + (USERFN (APPLY* USERFN \OLDX \OLDY + DISPLAYSTREAM)) + (T (.WHILE.TOP.DS. DISPLAYSTREAM + (\CURVEPT \OLDX \OLDY] + (COND + (DASHTAIL (COND + ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT) + )) + (SETQ DASHON (NOT DASHON)) + (SETQ DASHTAIL + (OR (LISTP (CDR DASHTAIL)) + DASHLST)) + (SETQ DASHCNT (CAR DASHTAIL] + (SETQ \OLDERX \OLDX) + (SETQ \OLDERY \OLDY) + (SETQ \OLDX \CURX) + (SETQ \OLDY \CURY))) + (SETQ \CURX NEWX) + (SETQ \CURY NEWY] +) +) +(DEFINEQ + +(\FILLCIRCLE.DISPLAY [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS TEXTURE) (* kbr%: "24-Jan-86 19:12") (* ;; "Fill in area bounded by circle DRAWCIRCLE would draw.") (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) (T (GLOBALRESOURCE \BRUSHBBT (PROG (TOP BOTTOM RIGHT LEFT OPERATION DestinationBitMap DISPLAYDATA X Y D DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE NBITS FCBBT) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ X 0) (SETQ Y RADIUS) (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) (SETQ FCBBT \BRUSHBBT) (SETQ LEFT (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA)) (SETQ BOTTOM (fetch (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA)) (SETQ TOP (SUB1 (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA))) (SETQ RIGHT (SUB1 (fetch (\DISPLAYDATA DDClippingRight) of DISPLAYDATA ))) (SETQ OPERATION (fetch (\DISPLAYDATA DDOPERATION) of DISPLAYDATA)) (SETQ DestinationBitMap (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA )) (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) [SETQ TEXTUREBM (COND ((BITMAPP TEXTURE)) [(NOT (EQ NBITS 1))(* ;  "color case, default texture differently") (COND ((BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL DISPLAYSTREAM)) NBITS T) NBITS))) [(AND (LISTP TEXTURE) (BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP (CADR TEXTURE) NBITS) NBITS] (T (\ILLEGAL.ARG TEXTURE] ((LISTP TEXTURE) (* ;  "either a color or a list of (texture color)") (INSURE.B&W.TEXTURE TEXTURE)) [(AND (NULL TEXTURE) (BITMAPP (fetch (\DISPLAYDATA DDTexture) of DISPLAYDATA] ([OR (FIXP TEXTURE) (AND (NULL TEXTURE) (SETQ TEXTURE (fetch (\DISPLAYDATA DDTexture) of DISPLAYDATA] (* ;  "create bitmap for the texture. Could reuse a bitmap but for now this is good enough.") (SETQ TEXTUREBM (BITMAPCREATE 16 4)) (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 12) 15))) (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8 ) 15))) (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4 ) 15))) (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) TEXTUREBM) (T (\ILLEGAL.ARG TEXTURE] (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (SETQ DESTINATIONBASE (fetch (BITMAP BITMAPBASE) of DestinationBitMap) ) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DestinationBitMap )) (* ;  "update as many fields in the brush bitblt table as possible from DS.") (replace (PILOTBBT PBTFLAGS) of FCBBT with 0) (replace (PILOTBBT PBTDESTBPL) of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD)) (* ;  "clear gray information. PBTSOURCEBPL is used for gray information too.") (replace (PILOTBBT PBTSOURCEBPL) of FCBBT with 0) (replace (PILOTBBT PBTUSEGRAY) of FCBBT with T) [replace (PILOTBBT PBTGRAYWIDTHLESSONE) of FCBBT with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH) of TEXTUREBM) 16] [replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of FCBBT with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM) 16] (replace (PILOTBBT PBTDISJOINT) of FCBBT with T) (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION) (replace (PILOTBBT PBTHEIGHT) of FCBBT with 1) (* ;  "take into account the brush thickness.") (SETQ CX (\DSPTRANSFORMX CENTERX DISPLAYDATA)) (SETQ CY (\DSPTRANSFORMY CENTERY DISPLAYDATA)) (* ;  "change Y TOP and BOTTOM to be in bitmap coordinates") (SETQ CY (SUB1 (\SFInvert DestinationBitMap CY))) (SETQ TOP (SUB1 (\SFInvert DestinationBitMap TOP))) (SETQ BOTTOM (SUB1 (\SFInvert DestinationBitMap BOTTOM))) (swap TOP BOTTOM) (\INSURETOPWDS DISPLAYSTREAM) (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") (COND ((EQ RADIUS 0) (* ;  "put a single point down. Use \LINEBLT to get proper texture. NIL") (.WHILE.TOP.DS. DISPLAYSTREAM (\LINEBLT FCBBT CX CY CX DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS)) (RETURN))) LP (* ;  "(UNFOLD x 2) is used instead of (ITIMES x 2)") [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1)) (* ; "don't draw unless Y changes.") (GO LP] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3] (COND ((EQ Y 0) (* ;  "draw the middle line differently to avoid duplication.") (.WHILE.TOP.DS. DISPLAYSTREAM (\LINEBLT FCBBT (IDIFFERENCE CX X) CY (IPLUS CX X) DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS))) (T (.WHILE.TOP.DS. DISPLAYSTREAM (\FILLCIRCLEBLT CX CY X Y)) (SETQ Y (SUB1 Y)) (GO LP))) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL]) + +(\LINEBLT [LAMBDA (BBT X Y XRIGHT DESTINATIONBASE RASTERWIDTH LEFT RIGHT BOTTOM TOP GRAYWIDTH GRAYHEIGHT GRAYBASE NBITS) (* kbr%: "15-Feb-86 22:08") (* ;; "fills in the changing fields of a bit blt tablt to draw one line of aan area.") (PROG NIL (COND ((ILESSP X LEFT) (SETQ X LEFT))) (COND ((IGREATERP XRIGHT RIGHT) (SETQ XRIGHT RIGHT))) (COND ((OR (IGREATERP X XRIGHT) (IGREATERP Y TOP) (IGREATERP BOTTOM Y)) (RETURN))) (replace (PILOTBBT PBTDEST) of BBT with (\ADDBASE DESTINATIONBASE (ITIMES RASTERWIDTH Y))) [freplace (PILOTBBT PBTSOURCE) of BBT with (\ADDBASE GRAYBASE (freplace (PILOTBBT PBTGRAYOFFSET) of BBT with (MOD Y GRAYHEIGHT ] (SELECTQ NBITS (1 (freplace (PILOTBBT PBTDESTBIT) of BBT with X) (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) (freplace (PILOTBBT PBTWIDTH) of BBT with (ADD1 (IDIFFERENCE XRIGHT X)))) (4 (* ;  "color case, shift x values {which are in pixels} into bit values.") (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 2))) (* ;  "if TEXTURE is not a multiple of nbits wide this is probably garbage.") (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT) 2) X))) (8 (* ;  "color case, shift x values {which are in pixels} into bit values.") (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (LLSH X 3))) (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (LLSH (ADD1 XRIGHT) 3) X))) (24 (* ;  "color case, shift x values {which are in pixels} into bit values.") (freplace (PILOTBBT PBTDESTBIT) of BBT with (SETQ X (ITIMES 24 X))) (freplace (PILOTBBT PBTSOURCEBIT) of BBT with (MOD X GRAYWIDTH)) (freplace (PILOTBBT PBTWIDTH) of BBT with (IDIFFERENCE (ITIMES 24 (ADD1 XRIGHT)) X))) (SHOULDNT)) (\PILOTBITBLT BBT 0]) +) + + + +(* ; "making and copying bitmaps") + +(DEFINEQ + +(SCREENBITMAP [LAMBDA (SCREEN) (* ; "Edited 20-Feb-87 14:57 by rrb") (* ;; "Return bitmap destination of SCREEN.") (COND ((NULL SCREEN) ScreenBitMap) ((type? SCREEN SCREEN) (fetch (SCREEN SCDESTINATION) of SCREEN)) ((WINDOWP SCREEN) (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of SCREEN))) (T (\ILLEGAL.ARG SCREEN]) + +(BITMAPP [LAMBDA (X) (* rrb "25-JUN-82 15:21") (* ; "is x a bitmap?") (AND (type? BITMAP X) X]) + +(BITMAPHEIGHT [LAMBDA (BITMAP) (* kbr%: " 8-Jul-85 16:01") (* ;; "returns the height in pixels of a bitmap.") (COND ((type? BITMAP BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'HEIGHT)) (T (\ILLEGAL.ARG BITMAP]) + +(BITSPERPIXEL + [LAMBDA (BITMAP) (* ; "Edited 15-Feb-94 16:10 by nilsson") + + (* ;; "returns the height in pixels of a bitmap.") + + (COND + ((type? BITMAP BITMAP) + (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) + ((type? SCREEN BITMAP) + + (* ;; "Read the propper slots, not the implicit bitmap.") + + (OR (fetch (SCREEN SCDEPTH) of BITMAP) + (fetch (SCREEN SCBITSPERPIXEL) of BITMAP))) + ((type? WINDOW BITMAP) + (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP))) + ((ARRAYP BITMAP) (* ; + "Consider array to be a colormap.") + (SELECTQ (ARRAYSIZE BITMAP) + (256 8) + (16 4) + (LISPERROR "ILLEGAL ARG" BITMAP))) + (T (LISPERROR "ILLEGAL ARG" BITMAP]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(PUTDEF (QUOTE BITMAPS) (QUOTE FILEPKGCOMS) '[(COM + MACRO + (X (VARS . X]) +(PUTDEF (QUOTE CURSORS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (E (MAPC 'X 'PRINTCURSOR]) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE +(* "FOLLOWING DEFINITIONS EXPORTED") +(ADDTOVAR GLOBALVARS SCREENHEIGHT SCREENWIDTH ScreenBitMap) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "Display stream functions that are not needed in the primitive system") + +(DEFINEQ + +(DSPFILL [LAMBDA (REGION TEXTURE OPERATION STREAM) (* kbr%: " 8-Jul-85 15:40") (* ;; "wipes a region of an imagestream with texture.") (* ;; "TEXTURE and OPERATION default to those of STREAM") (PROG (STRM) (SETQ STRM (\OUTSTREAMARG STREAM)) (OR REGION (SETQ REGION (DSPCLIPPINGREGION NIL STRM))) (RETURN (BLTSHADE TEXTURE STRM (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) OPERATION]) + +(INVERTW [LAMBDA (WIN SHADE) (* rrb "18-May-84 21:52") (* ;; "inverts a window and returns the window. Used in RESETFORMS.") (DSPFILL (DSPCLIPPINGREGION NIL WIN) (OR SHADE BLACKSHADE) 'INVERT WIN) WIN]) +) +(DEFINEQ + +(\DSPCOLOR.DISPLAY [LAMBDA (STREAM COLOR) (* ; "Edited 29-Jan-91 11:33 by matsuda") (* ;; "sets and returns a display stream's background color.") (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) (SETQ DD (\GETDISPLAYDATA STREAM)) (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (RETURN (COND (COLOR (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) (PROG1 (COND (COLORCELL (PROG1 (CAR COLORCELL) (RPLACA COLORCELL COLOR))) (T (* ; "no color cell yet, make one.") (replace (\DISPLAYDATA DDCOLOR) of DD with (CONS COLOR 0)) (MAXIMUMCOLOR BITSPERPIXEL))) (\SFFixFont STREAM DD))) (T (OR (CAR COLORCELL) (MAXIMUMCOLOR BITSPERPIXEL]) + +(\DSPBACKCOLOR.DISPLAY [LAMBDA (STREAM COLOR) (* kbr%: "25-Aug-85 18:15") (* ;; "sets and returns a display stream's foreground color.") (PROG (DD COLORCELL DESTINATION BITSPERPIXEL) (SETQ DD (\GETDISPLAYDATA STREAM)) (SETQ COLORCELL (fetch (\DISPLAYDATA DDCOLOR) of DD)) (RETURN (COND (COLOR (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION )) (SETQ COLOR (COLORNUMBERP COLOR BITSPERPIXEL)) (PROG1 (COND (COLORCELL (PROG1 (CDR COLORCELL) (RPLACD COLORCELL COLOR))) (T (* ; "no color cell yet, make one.") (replace (\DISPLAYDATA DDCOLOR) of DD with (CONS (MAXIMUMCOLOR BITSPERPIXEL) COLOR)) 0)) (\SFFixFont STREAM DD))) (T (OR (CDR COLORCELL) 0]) + +(DSPEOLFN [LAMBDA (EOLFN DISPLAYSTREAM) (* rrb "18-May-84 21:44") (* ;; "sets the end of line function for a displaystream. EOLFN will be called every EOL with the argument of the display stream. If EOLFN is 'OFF, the eolfn is cleared.") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (COND ((fetch (\DISPLAYDATA DDEOLFN) of DD)) (T 'OFF)) [AND EOLFN (COND [(LITATOM EOLFN) (replace (\DISPLAYDATA DDEOLFN) of DD with (COND ((EQ EOLFN 'OFF) NIL) (T EOLFN] (T (\ILLEGAL.ARG EOLFN])]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RPAQQ BLACKSHADE 65535) + +(RPAQQ WHITESHADE 0) + + +(CONSTANTS (BLACKSHADE 65535) + (WHITESHADE 0)) +) + +(RPAQQ GRAYSHADE 43605) + +(ADDTOVAR GLOBALVARS GRAYSHADE) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS DSPRUBOUTCHAR MACRO ((DS CHAR X Y TTBL) + (\DSPMOVELR DS CHAR X Y TTBL NIL T))) +) +(DEFINEQ + +(DSPCLEOL [LAMBDA (DISPLAYSTREAM XPOS YPOS HEIGHT) (* lmm " 3-May-84 10:31") (\CHECKCARET DISPLAYSTREAM) (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM))) (RETURN (BITBLT NIL NIL NIL DISPLAYSTREAM (OR (FIXP XPOS) (SETQ XPOS (ffetch DDLeftMargin of DD))) [OR (FIXP YPOS) (IDIFFERENCE (ffetch DDYPOSITION of DD) (FONTPROP DISPLAYSTREAM 'DESCENT] (IMAX 0 (IDIFFERENCE (ffetch DDRightMargin of DD) XPOS)) (OR (FIXP HEIGHT) (IMINUS (ffetch DDLINEFEED of DD))) 'TEXTURE 'REPLACE]) + +(DSPRUBOUTCHAR [LAMBDA (STREAM CHAR X Y TTBL) (* Pavel " 6-Oct-86 22:44") (if (DISPLAYSTREAMP CHAR) then (* ;; "Some older code may use the CHAR argument first.") (swap STREAM CHAR) (SETQ TTBL X) (SETQ X) (SETQ Y)) (\GETDISPLAYDATA STREAM STREAM) (\DSPMOVELR STREAM CHAR X Y TTBL NIL T]) + +(\DSPMOVELR [LAMBDA (DS CHAR X Y TTBL RIGHTWARDSFLG ERASEFLG) (* JonL " 7-May-84 02:47") (* ;; "Moves the cursor 'leftwards' (or 'rightwards' if RIGHTWARDSFLG is non-null) over any main character and control or meta indicators. Returns NIL if the move can't be determined, such as trying to move left when already at the left margin. Effaces (or 'Rubs out') any bits moved over if ERASEFLG is non-null.") ([LAMBDA (DD) (* ;;  "Must do the \GETDISPLAYDATA first, since it may reset DS when it coerces to a DISPLAYSTREAM") (PROG [(WIDTH (\STREAMCHARWIDTH (COND ((CHARCODEP CHAR) CHAR) (T (CHARCODE M))) DS TTBL)) (DEFAULTPOS? (AND (NULL X) (NULL Y] (OR ERASEFLG DEFAULTPOS? (SHOULDNT)) (* ;  "CURSORLEFT and CURSORRIGHT commands aren't allowed to start from anywhere except current spot") (* ;; "Note that if CHAR is not specified and DS has a variable-pitch font, then the results may be somewhat random. Smart terminal drivers thus can work well only on fixed-pitch fonts.") (COND ((NULL WIDTH) (RETURN)) ((EQ 0 WIDTH) (* ; "Ha, what an easy case") (RETURN T))) (OR (FIXP X) (SETQ X (ffetch DDXPOSITION of DD))) (OR (FIXP Y) (SETQ Y (ffetch DDYPOSITION of DD))) (COND ([COND (RIGHTWARDSFLG (IGREATERP (add X WIDTH) (ffetch DDRightMargin of DD))) (T (ILESSP (add X (IMINUS WIDTH)) (ffetch DDLeftMargin of DD] (* ;  "If we can't do the full backup, then return NIL to signal this fact") (RETURN))) (\CHECKCARET DS) (* ;  "Take down the caret, if there is one, just in case we are moving over it.") [COND (ERASEFLG (* ; "And do the erasure if requested") ([LAMBDA (FONT) (PROG ((YPRIME (IDIFFERENCE Y (FONTDESCENT FONT))) (HEIGHT (FONTHEIGHT FONT))) (COND ((NOT DEFAULTPOS?) (MOVETO X Y DS) (* ;  "Backup over the bits, and 'wipe' them out.") )) (BITBLT NIL 0 0 DS X YPRIME WIDTH HEIGHT 'TEXTURE 'REPLACE) (* ; "wipe out some bits") ] (ffetch DDFONT of DD] (DSPXPOSITION X DS) (* ; "Now do the move.") (RETURN T] (\GETDISPLAYDATA DS DS]) +) + + + +(* ; "for cursor") + + +(RPAQQ \DefaultCursor #*(16 16)H@@@L@@@N@@@O@@@OH@@OL@@ON@@O@@@MH@@IH@@@L@@@L@@@F@@@F@@@C@@@C@@) +(DEFINEQ + +(\CURSOR.DEFPRINT + [LAMBDA (CURSOR STREAM) (* ; "Edited 15-Sep-94 16:13 by sybalsky") + (COND + (*PRINT-ARRAY* (PRIN1 "#,(LET(image) (CURSORCREATE (SETQ image '" STREAM) + (PRIN4 (fetch (CURSOR CUIMAGE) of CURSOR) + STREAM) + (PRIN1 ") " STREAM) + (COND + ((EQ (fetch (CURSOR CUIMAGE) of CURSOR) + (fetch (CURSOR CUMASK) of CURSOR)) + (PRIN1 " image " STREAM)) + (T (PRIN1 " '" STREAM) + (PRIN4 (fetch (CURSOR CUMASK) of CURSOR) + STREAM))) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUHOTSPOTX) of CURSOR) + STREAM) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUHOTSPOTY) of CURSOR) + STREAM) + (PRIN1 " " STREAM) + (PRIN1 (fetch (CURSOR CUDATA) of CURSOR) + STREAM) + (PRIN1 "))" STREAM]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ? DEFAULTCURSOR (CURSORCREATE \DefaultCursor NIL 0 15)) + + +(COND + ((NULL \CURRENTCURSOR) + (SETQ \CURRENTCURSOR DEFAULTCURSOR))) + +(DEFPRINT 'CURSOR '\CURSOR.DEFPRINT) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DEFAULTCURSOR) +) +) + + + +(* ; "stuff to interpret colors as textures which is needed even in system that don't have color.") + +(DEFINEQ + +(TEXTUREOFCOLOR [LAMBDA (COLOR NOERRORFLG) (* rrb "30-Oct-85 19:43") (* ;; "returns a texture to represent a color on a black and white display") (PROG ((RGB (INSURE.RGB.COLOR COLOR NOERRORFLG))) (RETURN (COND ((NULL RGB) NIL) ((AND (IGREATERP (fetch (RGB RED) of RGB) 245) (IGREATERP (fetch (RGB GREEN) of RGB) 245) (IGREATERP (fetch (RGB BLUE) of RGB) 245)) (* ; "special case white") BLACKSHADE16) (T (PROG [(TEX (\PRIMARYTEXTURE 'RED (fetch (RGB RED) of RGB] (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT (\PRIMARYTEXTURE 'BLUE (fetch (RGB BLUE) of RGB))) (BITBLT NIL NIL NIL TEX 0 0 16 16 'TEXTURE 'PAINT (\PRIMARYTEXTURE 'GREEN (fetch (RGB GREEN) of RGB))) (RETURN TEX]) + +(\PRIMARYTEXTURE [LAMBDA (PRIMARY LEVEL) (* rrb "30-Oct-85 19:25") (* ;; "returns the 16x16 texture for a primary color level.") (PROG [(TEXTURE (BITMAPCOPY (SELECTQ PRIMARY (RED REDTEXTURE) (BLUE BLUETEXTURE) (GREEN GREENTEXTURE) (\ILLEGAL.ARG PRIMARY] (BITBLT (\LEVELTEXTURE LEVEL) 0 0 TEXTURE 0 0 16 16 'INPUT 'ERASE) (RETURN TEXTURE]) + +(\LEVELTEXTURE [LAMBDA (LEVEL) (* rrb "20-Aug-85 16:42") (* ;; "returns a 16x16 texture which is merged so that only light bits on both go to light with a primary color pattern to get a level primary pattern.") (COND ((ILESSP LEVEL 100) BLACKSHADE16) ((ILESSP LEVEL 150) DARKGRAY16) ((ILESSP LEVEL 200) MEDIUMGRAY16) ((ILESSP LEVEL 245) LIGHTGRAY16) (T WHITESHADE16]) + +(INSURE.B&W.TEXTURE [LAMBDA (TEXTURE NOERRORFLG) (* rrb "30-Oct-85 19:47") (* ;; "coerces a TEXTURE argument to a 1 bit per pixel bitmap or small number") (SELECTQ (TYPENAME TEXTURE) (LITATOM (* ; "includes NIL case") (COND (TEXTURE (* ; "should be a color name") (TEXTUREOFCOLOR (INSURE.RGB.COLOR TEXTURE NOERRORFLG))) (T WHITESHADE))) ((SMALLP FIXP) (LOGAND TEXTURE BLACKSHADE)) (BITMAP TEXTURE) (LISTP (* ;  "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") (COND ((TEXTUREOFCOLOR TEXTURE T)) ((CAR TEXTURE) (INSURE.B&W.TEXTURE (CAR TEXTURE) NOERRORFLG)) ((CAR (LISTP (CDR TEXTURE))) (TEXTUREOFCOLOR (CADR TEXTURE) NOERRORFLG)) (T (* ; "list of form (NIL NIL)") WHITESHADE))) (COND ((NULL NOERRORFLG) (\ILLEGAL.ARG TEXTURE]) + +(INSURE.RGB.COLOR [LAMBDA (COLOR NOERRFLG) (* rrb "30-Oct-85 19:34") (* ;  "returns the RGB triple for a color.") (PROG (LEVELS) (RETURN (COND [(FIXP COLOR) (* ;  "don't know what to do with color numbers so error") (COND (NOERRFLG NIL) (T (\ILLEGAL.ARG COLOR] [(LITATOM COLOR) (COND ((SETQ LEVELS (\LOOKUPCOLORNAME COLOR)) (* ;  "recursively look up color number") (INSURE.RGB.COLOR (CDR LEVELS) NOERRFLG)) (NOERRFLG NIL) (T (ERROR "Unknown color name" COLOR] ((HLSP COLOR) (* ; "HLS form convert to RGB") (HLSTORGB COLOR)) ((RGBP COLOR) (* ; "check for RGB or HLS") COLOR) (NOERRFLG NIL) (T (\ILLEGAL.ARG COLOR]) + +(\LOOKUPCOLORNAME [LAMBDA (COLORNAME) (* rrb "13-DEC-82 13:14") (* ;; "looks up a prospective color name. Returns a list whose CAR is the name and whose CDR is a color spec.") (FASSOC COLORNAME COLORNAMES]) + +(RGBP [LAMBDA (X) (* rrb "27-OCT-82 10:15") (* ;  "return X if it is a red green blue triple.") (PROG (TMP) (RETURN (AND (LISTP X) (SMALLP (SETQ TMP (CAR X))) (IGREATERP TMP -1) (IGREATERP 256 TMP) (SMALLP (SETQ TMP (CADR X))) (IGREATERP TMP -1) (IGREATERP 256 TMP) (SMALLP (SETQ TMP (CADDR X))) (IGREATERP TMP -1) (IGREATERP 256 TMP) X]) + +(HLSP [LAMBDA (X) (* rrb "31-Oct-85 10:51") (* ;; "return T if X is a hue lightness saturation triple.") (AND (NUMBERP (CAR (LISTP X))) (IGREATERP (CAR X) -1) (IGREATERP 361 (CAR X)) [FLOATP (CAR (LISTP (CDR X] [FLOATP (CAR (LISTP (CDDR X] X]) + +(HLSTORGB [LAMBDA (HLS) (* rrb "30-Oct-85 19:59") (* ;; "converts from a hue saturation lightness triple into red green blue triple. HUE is in range 0 to 360, lightness and saturation are in the range 0 to 1.0") (* ;; "this algorithm was taken from siggraph vol 13 number 3 August 1979: Status report on graphics standards planning committee.") (PROG ((H (fetch (HLS HUE) of HLS)) (L (fetch (HLS LIGHTNESS) of HLS)) (S (fetch (HLS SATURATION) of HLS)) Max Min) [SETQ Max (COND ((FGREATERP 0.5 L) (FTIMES L (FPLUS 1.0 S))) (T (FDIFFERENCE (FPLUS L S) (FTIMES L S] (SETQ Min (FDIFFERENCE (FTIMES L 2) Max)) (RETURN (create RGB RED _ (\HLSVALUEFN Min Max H) GREEN _ (\HLSVALUEFN Min Max (IDIFFERENCE H 120)) BLUE _ (\HLSVALUEFN Min Max (IDIFFERENCE H 240]) + +(\HLSVALUEFN [LAMBDA (MIN MAX HUE) (* rrb "25-OCT-82 10:47") (* ;; "internal value function for converting from HLS to RGB.") [COND ((ILESSP HUE 0) (SETQ HUE (IPLUS HUE 360] (FIX (FTIMES (COND ((ILESSP HUE 60) (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) HUE) 60))) ((ILESSP HUE 180) MAX) ((ILESSP HUE 240) (FPLUS MIN (FQUOTIENT (FTIMES (FDIFFERENCE MAX MIN) (FDIFFERENCE 240 HUE)) 60))) (T MIN)) 255]) +) + +(RPAQQ COLORNAMES ((WHITE 255 255 255) + (CYAN 0 255 255) + (MAGENTA 255 0 255) + (YELLOW 255 255 0) + (RED 255 0 0) + (GREEN 0 255 0) + (BLUE 0 0 255) + (BLACK 0 0 0))) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS COLORNAMES) +) +(DECLARE%: DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE GREENTEXTURE + BLUETEXTURE) +) +) + +(READVARS-FROM-STRINGS '(BLACKSHADE16 DARKGRAY16 MEDIUMGRAY16 LIGHTGRAY16 WHITESHADE16 REDTEXTURE + GREENTEXTURE BLUETEXTURE) + "({(READBITMAP)(16 16 +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%" +%"OOOO%")} {(READBITMAP)(16 16 +%"NMGG%" +%"KGMM%" +%"MNKK%" +%"GKNN%" +%"MNKK%" +%"GKNM%" +%"NMGN%" +%"KGMG%" +%"NKKM%" +%"KNNK%" +%"GGMN%" +%"MMGG%" +%"GGKM%" +%"MJOG%" +%"NOEK%" +%"KMNN%")} {(READBITMAP)(16 16 +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%" +%"JJJJ%" +%"EEEE%")} {(READBITMAP)(16 16 +%"HBDB%" +%"BHAA%" +%"DDHD%" +%"AABH%" +%"HHDA%" +%"BBAD%" +%"DDHB%" +%"AABH%" +%"HDAD%" +%"AADA%" +%"DHBH%" +%"BBHB%" +%"HHAD%" +%"ABDA%" +%"DDHH%" +%"BABB%")} {(READBITMAP)(16 16 +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%" +%"@@@@%")} {(READBITMAP)(16 16 +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%" +%"LLLL%")} {(READBITMAP)(16 16 +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%" +%"CLCL%" +%"O@O@%" +%"LCLC%" +%"@O@O%")} {(READBITMAP)(16 16 +%"LFGA%" +%"NCCH%" +%"GAIL%" +%"CHLN%" +%"ALFG%" +%"HNCC%" +%"LGAI%" +%"NCHL%" +%"GALF%" +%"CHNC%" +%"ILGA%" +%"LNCH%" +%"FGAL%" +%"CCHN%" +%"AILG%" +%"HLNC%")}) +") +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RECORD HLS (HUE LIGHTNESS SATURATION)) + +(RECORD RGB (RED GREEN BLUE)) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA UNIONREGIONS INTERSECTREGIONS) +) +(PUTPROPS ADISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 + 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (12396 20453 (\BBTCURVEPT 12406 . 20451)) (20454 30512 (CREATETEXTUREFROMBITMAP 20464 . +22496) (PRINTBITMAP 22498 . 23827) (PRINT-BITMAPS-NICELY 23829 . 27846) (PRINTCURSOR 27848 . 28795) ( +\WRITEBITMAP 28797 . 30510)) (30555 33101 (\GETINTEGERPART 30565 . 32108) (\CONVERTTOFRACTION 32110 . +33099)) (33238 34124 (CURSORP 33248 . 33467) (CURSORBITMAP 33469 . 33515) (CreateCursorBitMap 33517 . +34122)) (38756 48618 (CARET 38766 . 40514) (\CARET.CREATE 40516 . 40694) (\CARET.DOWN 40696 . 42149) ( +\CARET.FLASH? 42151 . 44048) (\CARET.SHOW 44050 . 44806) (CARETRATE 44808 . 45466) (\CARET.FLASH.AGAIN + 45468 . 46743) (\CARET.FLASH.MULTIPLE 46745 . 47277) (\CARET.FLASH 47279 . 48616)) (48619 53719 ( +\MEDW.CARET.SHOW 48629 . 53717)) (54083 55914 (\AREAVISIBLE? 54093 . 55015) (\REGIONOVERLAPAREAP 55017 + . 55560) (\AREAINREGIONP 55562 . 55912)) (55963 72020 (CREATEREGION 55973 . 56309) (REGIONP 56311 . +56457) (INTERSECTREGIONS 56459 . 60282) (UNIONREGIONS 60284 . 63484) (REGIONSINTERSECTP 63486 . 64094) + (SUBREGIONP 64096 . 64741) (EXTENDREGION 64743 . 67963) (EXTENDREGIONBOTTOM 67965 . 68770) ( +EXTENDREGIONLEFT 68772 . 69475) (EXTENDREGIONRIGHT 69477 . 70114) (EXTENDREGIONTOP 70116 . 70742) ( +INSIDEP 70744 . 71512) (STRINGREGION 71514 . 72018)) (72265 78654 (\BRUSHBITMAP 72275 . 73999) ( +\GETBRUSH 74001 . 74312) (\GETBRUSHBBT 74314 . 77077) (\InitCurveBrushes 77079 . 78518) ( +\BrushFromWidth 78520 . 78652)) (78655 81720 (\MAKEBRUSH.DIAGONAL 78665 . 78945) ( +\MAKEBRUSH.HORIZONTAL 78947 . 79341) (\MAKEBRUSH.VERTICAL 79343 . 79655) (\MAKEBRUSH.SQUARE 79657 . +79934) (\MAKEBRUSH.ROUND 79936 . 81718)) (81721 82833 (INSTALLBRUSH 81731 . 82831)) (83234 95532 ( +\DRAWLINE.DISPLAY 83244 . 94247) (RELMOVETO 94249 . 94636) (MOVETOUPPERLEFT 94638 . 95530)) (95533 +119275 (\CLIPANDDRAWLINE 95543 . 102112) (\CLIPANDDRAWLINE1 102114 . 113984) (\CLIPCODE 113986 . +115360) (\LEASTPTAT 115362 . 115960) (\GREATESTPTAT 115962 . 116590) (\DRAWLINE1 116592 . 117716) ( +\DRAWLINE.UFN 117718 . 119273)) (124435 171434 (\DRAWCIRCLE.DISPLAY 124445 . 133313) (\DRAWARC.DISPLAY + 133315 . 133605) (\DRAWARC.GENERIC 133607 . 134426) (\COMPUTE.ARC.POINTS 134428 . 136929) ( +\DRAWELLIPSE.DISPLAY 136931 . 152596) (\DRAWCURVE.DISPLAY 152598 . 154967) (\DRAWPOINT.DISPLAY 154969 + . 156054) (\DRAWPOLYGON.DISPLAY 156056 . 159998) (\LINEWITHBRUSH 160000 . 171432)) (171435 204665 ( +LOADPOLY 171445 . 172005) (PARAMETRICSPLINE 172007 . 182276) (\CURVE 182278 . 188822) (\CURVE2 188824 + . 200648) (\CURVEEND 200650 . 201148) (\CURVESLOPE 201150 . 203648) (\CURVESTART 203650 . 203974) ( +\FDIFS/FROM/DERIVS 203976 . 204663)) (218666 233818 (\FILLCIRCLE.DISPLAY 218676 . 229874) (\LINEBLT +229876 . 233816)) (233862 235918 (SCREENBITMAP 233872 . 234345) (BITMAPP 234347 . 234581) ( +BITMAPHEIGHT 234583 . 234959) (BITSPERPIXEL 234961 . 235916)) (236559 237552 (DSPFILL 236569 . 237252) + (INVERTW 237254 . 237550)) (237553 241354 (\DSPCOLOR.DISPLAY 237563 . 238856) (\DSPBACKCOLOR.DISPLAY +238858 . 240387) (DSPEOLFN 240389 . 241352)) (241779 246557 (DSPCLEOL 241789 . 242735) (DSPRUBOUTCHAR +242737 . 243175) (\DSPMOVELR 243177 . 246555)) (246687 247801 (\CURSOR.DEFPRINT 246697 . 247799)) ( +248213 256835 (TEXTUREOFCOLOR 248223 . 249485) (\PRIMARYTEXTURE 249487 . 250069) (\LEVELTEXTURE 250071 + . 250572) (INSURE.B&W.TEXTURE 250574 . 251967) (INSURE.RGB.COLOR 251969 . 253449) (\LOOKUPCOLORNAME +253451 . 253721) (RGBP 253723 . 254486) (HLSP 254488 . 254863) (HLSTORGB 254865 . 256005) (\HLSVALUEFN + 256007 . 256833))))) +STOP diff --git a/sources/ADVISE b/sources/ADVISE new file mode 100644 index 00000000..efe4cefa --- /dev/null +++ b/sources/ADVISE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM") (IL:FILECREATED "16-May-90 11:55:52" IL:|{DSK}local>lde>lispcore>sources>ADVISE.;2| 40413 IL:|changes| IL:|to:| (IL:VARS IL:ADVISECOMS) IL:|previous| IL:|date:| "15-Aug-88 12:29:50" IL:|{DSK}local>lde>lispcore>sources>ADVISE.;1| ) ; Copyright (c) 1978, 1984, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ; The following program was created in 1978 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. (IL:PRETTYCOMPRINT IL:ADVISECOMS) (IL:RPAQQ IL:ADVISECOMS ((IL:STRUCTURES ADVICE) (IL:VARIABLES IL:ADVISEDFNS *UNADVISED-FNS*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:FNS IL:ADVISE IL:UNADVISE IL:READVISE) (IL:PROP IL:ARGNAMES IL:ADVISE) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION) (IL:FUNCTIONS UNADVISE-FROM-RESTORE-CALLS FINISH-ADVISING FINISH-UNADVISING) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (IL:VARIABLES *ADVICE-HASH-TABLE*) (IL:FUNCTIONS ADD-ADVICE DELETE-ADVICE GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN INSERT-ADVICE-FORM) (IL:SETFS GET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (IL:FUNCTIONS CREATE-ADVISED-DEFINITION MAKE-AROUND-BODY) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:FILEPKGCOMS IL:ADVICE IL:ADVISE) (IL:FUNCTIONS XCL:REINSTALL-ADVICE) (IL:FUNCTIONS ADVICE-GETDEF ADVICE-PUTDEF ADVICE-DELDEF ADVICE-HASDEF ADVICE-NEWCOM ADVICE-FILE-DEFINITIONS ADVISE-CONTENTS ADVICE-ADDTOCOM) (IL:PROP IL:PROPTYPE IL:ADVISED) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (IL:FUNCTIONS IL:READVISE1 ADD-OLD-STYLE-ADVICE CANONICALIZE-ADVICE-SYMBOL CANONICALIZE-ADVICE-WHEN-SPEC CANONICALIZE-ADVICE-WHERE-SPEC) (IL:DEFINE-TYPES XCL:ADVISED-FUNCTIONS) (IL:FUNCTIONS XCL:DEFADVICE) (IL:* IL:|;;| "Arrange for the proper package. Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package.") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:ADVISE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA IL:READVISE IL:UNADVISE) (IL:NLAML) (IL:LAMA IL:ADVISE))))) (DEFSTRUCT (ADVICE (:TYPE LIST)) BEFORE AFTER AROUND) (DEFVAR IL:ADVISEDFNS NIL) (DEFVAR *UNADVISED-FNS* NIL) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:DEFINEQ (il:advise (il:lambda il:args (il:* il:\; "Edited 6-Apr-87 18:00 by Pavel") (il:* il:|;;;| "ADVISE the FN given. ADVISE1 is for advice of the type (foo IN bar)") (let (il:fn il:when il:where il:what) (il:* il:|;;| "First we straighten out the arguments given to us") (il:setq il:fn (il:arg il:args 1)) (case il:args (2 (il:setq il:what (il:arg il:args 2))) (3 (il:setq il:when (il:arg il:args 2)) (il:setq il:what (il:arg il:args 3))) (4 (il:setq il:when (il:arg il:args 2)) (il:setq il:where (il:arg il:args 3)) (il:setq il:what (il:arg il:args 4))) (t (il:if (< il:args 2) il:then (error 'il:too-few-arguments :callee 'il:advise :actual il:args :minimum 2) il:else (error 'il:too-many-arguments :callee 'il:advise :actual il:args :maximum 4)))) (il:setq il:when (canonicalize-advice-when-spec il:when)) (il:setq il:where (canonicalize-advice-where-spec il:where)) (il:if (il:nlistp il:fn) il:then (xcl:advise-function il:fn il:what :when il:when :priority il:where) il:elseif (il:string.equal (cadr il:fn) "IN") il:then (xcl:advise-function (first il:fn) il:what :in (third il:fn) :when il:when :priority il:where) il:else (il:for il:x il:in il:fn il:join (il:if (il:nlistp il:x) il:then (xcl:advise-function il:x il:what :when il:when :priority il:where) il:else (xcl:advise-function (first il:x) il:what :in (third il:x) :when il:when :priority il:where))))))) (il:unadvise (il:nlambda il:fns (il:* il:\; "Edited 6-Apr-87 16:21 by Pavel") (il:setq il:fns (il:nlambda.args il:fns)) (flet ((il:unadvise-entry (il:entry) (il:if (il:listp il:entry) il:then (xcl::unadvise-function (first il:entry) :in (third il:entry)) il:else (xcl::unadvise-function il:entry)))) (cond ((null il:fns) (il:for il:entry il:in (il:reverse il:advisedfns) il:join (il:unadvise-entry il:entry)) ) ((il:equal il:fns '(t)) (and (not (null il:advisedfns)) (il:unadvise-entry (car il:advisedfns)))) (t (il:for il:entry il:in il:fns il:join (il:unadvise-entry il:entry))))))) (il:readvise (il:nlambda il:fns (il:* il:\; "Edited 6-Apr-87 16:52 by Pavel") (il:setq il:fns (il:nlambda.args il:fns)) (flet ((il:readvise-entry (il:entry) (il:if (il:listp il:entry) il:then (xcl::readvise-function (first il:entry) :in (third il:entry)) il:else (xcl::readvise-function il:entry)))) (cond ((null il:fns) (il:* il:\;  "readvise them all, in reverse order.") (il:for il:entry il:in (il:reverse *unadvised-fns*) il:join (il:readvise-entry il:entry ))) ((il:equal il:fns '(t)) (il:* il:\;  "simple case, readvise just the last one that was unadvised.") (and (not (null *unadvised-fns*)) (il:readvise-entry (car *unadvised-fns*)))) (t (il:* il:\; "they gave us some functions, so readvise THEM. We can't use READVISE-ENTRY here, because we may have to deal with old-style advice.") (il:for il:entry il:in il:fns il:join (il:readvise1 il:entry))))))) ) (IL:PUTPROPS IL:ADVISE IL:ARGNAMES (IL:WHO IL:WHEN IL:WHERE IL:WHAT)) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (DEFUN XCL:ADVISE-FUNCTION (XCL::FN-TO-ADVISE XCL::FORM &KEY ((:IN XCL::IN-FN)) (WHEN :BEFORE) (XCL::PRIORITY :LAST)) (COND ((CONSP XCL::FN-TO-ADVISE) (IL:FOR XCL::FN IL:IN XCL::FN-TO-ADVISE IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN XCL::FORM :IN XCL::IN-FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN-TO-ADVISE XCL::FORM :IN XCL::FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) ((NULL XCL::FORM) (FORMAT *ERROR-OUTPUT* "No advice given, so nothing done.") NIL) ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-ADVISE "advise") (FORMAT *ERROR-OUTPUT* "~S not advised.~%" XCL::FN-TO-ADVISE) NIL) (T (COND (XCL::IN-FN (IF (NOT (HAS-CALLS XCL::IN-FN XCL::FN-TO-ADVISE)) (ERROR "~S is not called from ~S." XCL::FN-TO-ADVISE XCL::IN-FN))) (T (IF (NULL (IL:GETD XCL::FN-TO-ADVISE)) (ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-ADVISE)))) (XCL:UNBREAK-FUNCTION XCL::FN-TO-ADVISE :IN XCL::IN-FN :NO-ERROR T) (COND ((NULL XCL::IN-FN) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT (MEMBER XCL::FN-TO-ADVISE IL:ADVISEDFNS :TEST 'EQ)) (IL:* IL:\; "If FN-TO-ADVISE is not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::FN-TO-ADVISE)) (ADD-ADVICE XCL::FN-TO-ADVISE WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;| "Finish off the process. This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE NIL)) (T (LET* ((XCL::ADVICE-NAME `(,XCL::FN-TO-ADVISE :IN ,XCL::IN-FN)) (XCL::ALREADY-ADVISED? (MEMBER XCL::ADVICE-NAME IL:ADVISEDFNS :TEST 'EQUAL))) (IL:* IL:|;;| "Adjust the database of advice for this request.") (WHEN (NOT XCL::ALREADY-ADVISED?) (IL:* IL:\;  "If not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::ADVICE-NAME)) (ADD-ADVICE XCL::ADVICE-NAME WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;|  "Finish off the process. This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE XCL::IN-FN))))))) (DEFUN XCL:UNADVISE-FUNCTION (XCL::FN-TO-UNADVISE &KEY ((:IN XCL::IN-FN)) XCL::NO-ERROR) (COND ((CONSP XCL::FN-TO-UNADVISE) (IL:FOR XCL::FN IL:IN XCL::FN-TO-UNADVISE IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::FN))) (T (XCL:UNBREAK-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::IN-FN :NO-ERROR T) (IF (NULL XCL::IN-FN) (LET ((XCL::ORIGINAL (GET XCL::FN-TO-UNADVISE 'IL:ADVISED))) (COND ((NULL XCL::ORIGINAL) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::FN-TO-UNADVISE)) NIL) (T (IL:PUTD XCL::FN-TO-UNADVISE (IL:GETD XCL::ORIGINAL) T) (REMPROP XCL::FN-TO-UNADVISE 'IL:ADVISED) (PUSH XCL::FN-TO-UNADVISE *UNADVISED-FNS*) (SETQ IL:ADVISEDFNS (DELETE XCL::FN-TO-UNADVISE IL:ADVISEDFNS)) (LIST XCL::FN-TO-UNADVISE)))) (LET* ((XCL::ADVICE-NAME `(,XCL::FN-TO-UNADVISE :IN ,XCL::IN-FN)) (XCL::MIDDLE-MAN (GET-ADVICE-MIDDLE-MAN XCL::ADVICE-NAME))) (COND ((NULL XCL::MIDDLE-MAN) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::ADVICE-NAME)) NIL) (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::FN-TO-UNADVISE XCL::IN-FN) (FINISH-UNADVISING XCL::ADVICE-NAME XCL::MIDDLE-MAN) (LIST XCL::ADVICE-NAME)))))))) (DEFUN XCL:READVISE-FUNCTION (XCL::FN-TO-READVISE &KEY ((:IN XCL::IN-FN))) (COND ((CONSP XCL::FN-TO-READVISE) (IL:FOR XCL::FN IL:IN XCL::FN-TO-READVISE IL:JOIN (XCL:READVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:READVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::FN))) (T (XCL:UNADVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::IN-FN :NO-ERROR T) (FINISH-ADVISING XCL::FN-TO-READVISE XCL::IN-FN)))) (DEFUN UNADVISE-FROM-RESTORE-CALLS (FROM TO FN) (LET ((ENTRY (FIND-IF #'(LAMBDA (ENTRY) (AND (CONSP ENTRY) (EQ (FIRST ENTRY) FROM) (EQ (THIRD ENTRY) FN))) IL:ADVISEDFNS))) (ASSERT (NOT (NULL ENTRY)) NIL "BUG: Inconsistency in SI::UNADVISE-FROM-RESTORE-CALLS") (FINISH-UNADVISING ENTRY TO) (FORMAT *TERMINAL-IO* "~S unadvised.~%" ENTRY))) (DEFUN FINISH-ADVISING (FN-TO-ADVISE IN-FN) (COND ((NULL IN-FN) (LET* ((ALREADY-ADVISED? (MEMBER FN-TO-ADVISE IL:ADVISEDFNS :TEST 'EQ)) (ORIGINAL (IF ALREADY-ADVISED? (GET FN-TO-ADVISE 'IL:ADVISED) (LET ((*PRINT-CASE* :UPCASE)) (MAKE-SYMBOL (FORMAT NIL "Original ~A" FN-TO-ADVISE)))))) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT ALREADY-ADVISED?) (IL:PUTD ORIGINAL (IL:GETD FN-TO-ADVISE) T)) (IL:PUTD FN-TO-ADVISE (COMPILE NIL (CREATE-ADVISED-DEFINITION FN-TO-ADVISE ORIGINAL FN-TO-ADVISE))) (WHEN (NOT ALREADY-ADVISED?) (SETF (GET FN-TO-ADVISE 'IL:ADVISED) ORIGINAL)) (IL:* IL:|;;|  "These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE FN-TO-ADVISE *UNADVISED-FNS* :TEST 'EQ)) (SETQ IL:ADVISEDFNS (IL:* IL:\;  "Move FN-TO-ADVISE to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS FN-TO-ADVISE (DELETE FN-TO-ADVISE IL:ADVISEDFNS :TEST 'EQ))) (IL:MARKASCHANGED FN-TO-ADVISE 'IL:ADVICE) (LIST FN-TO-ADVISE))) (T (LET* ((ADVICE-NAME `(,FN-TO-ADVISE :IN ,IN-FN)) (ALREADY-ADVISED? (MEMBER ADVICE-NAME IL:ADVISEDFNS :TEST 'EQUAL)) MIDDLE-MAN) (IL:* IL:|;;|  "Create a middle-man for this request. If one has already been created, use it.") (SETQ MIDDLE-MAN (OR (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (SETF (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (CONSTRUCT-MIDDLE-MAN FN-TO-ADVISE IN-FN)))) (IL:* IL:|;;| "Give the middle-man the new advised definition.") (IL:PUTD MIDDLE-MAN (COMPILE NIL (CREATE-ADVISED-DEFINITION FN-TO-ADVISE FN-TO-ADVISE ADVICE-NAME))) (WHEN (NOT ALREADY-ADVISED?) (IL:* IL:|;;|  "Redirect any calls to FN-TO-ADVISE in IN-FN to call the middle-man.") (CHANGE-CALLS FN-TO-ADVISE MIDDLE-MAN IN-FN 'UNADVISE-FROM-RESTORE-CALLS)) (IL:* IL:|;;| "Save a trail of information. These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE ADVICE-NAME *UNADVISED-FNS* :TEST 'EQUAL)) (SETQ IL:ADVISEDFNS (IL:* IL:\;  "Move ADVICE-NAME to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS ADVICE-NAME (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST 'EQUAL))) (IL:MARKASCHANGED ADVICE-NAME 'IL:ADVICE) (LIST ADVICE-NAME))))) (DEFUN FINISH-UNADVISING (ADVICE-NAME MIDDLE-MAN) (SETQ IL:ADVISEDFNS (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST 'EQUAL)) (PUSH ADVICE-NAME *UNADVISED-FNS*)) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (DEFVAR *ADVICE-HASH-TABLE* (MAKE-HASH-TABLE :TEST 'EQUAL) (IL:* IL:|;;;| "Hash-table mapping either a function name or a list in the form (FOO :IN BAR) to a pair (advice . middle-man).") ) (DEFUN ADD-ADVICE (NAME WHEN PRIORITY FORM) (IL:* IL:|;;;| "Advice is stored on the hash table SI::*ADVICE-HASH-TABLE*. It is actually stored as a cons whose CAR is the advice and CDR is the middle-man name (for advice of the type (FOO :IN BAR)).") (LET* ((OLD-ADVICE (GETHASH NAME *ADVICE-HASH-TABLE*)) (ADVICE (IF (NULL OLD-ADVICE) (MAKE-ADVICE) (CAR OLD-ADVICE)))) (ECASE WHEN (:BEFORE (SETF (ADVICE-BEFORE ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-BEFORE ADVICE)))) (:AFTER (SETF (ADVICE-AFTER ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AFTER ADVICE)))) (:AROUND (SETF (ADVICE-AROUND ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AROUND ADVICE))))) (WHEN (NULL OLD-ADVICE) (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS ADVICE NIL))))) (DEFUN DELETE-ADVICE (NAME) (REMHASH NAME *ADVICE-HASH-TABLE*)) (DEFUN GET-ADVICE-MIDDLE-MAN (NAME) (CDR (GETHASH NAME *ADVICE-HASH-TABLE*))) (DEFUN SET-ADVICE-MIDDLE-MAN (NAME MIDDLE-MAN) (SETF (CDR (GETHASH NAME *ADVICE-HASH-TABLE*)) MIDDLE-MAN)) (DEFUN INSERT-ADVICE-FORM (FORM PRIORITY ENTRY-LIST) (IL:* IL:|;;;| "Insert the new advice FORM into ENTRY-LIST using PRIORITY as a specification of where in that list to put it. If an equalish piece of advice already exists, remove it first.") (LET ((ENTRY (LIST PRIORITY FORM))) (SETF ENTRY-LIST (LABELS ((EQUALISH (X Y) (IL:* IL:|;;| "EQUALP, but don't ignore case in strings.") (TYPECASE X (SYMBOL (EQ X Y)) (CONS (AND (CONSP Y) (EQUALISH (CAR X) (CAR Y)) (EQUALISH (CDR X) (CDR Y)))) (NUMBER (AND (NUMBERP Y) (= X Y))) (CHARACTER (AND (CHARACTERP Y) (CHAR= X Y))) (STRING (AND (STRINGP Y) (STRING= X Y))) (PATHNAME (AND (PATHNAMEP Y) (IL:%PATHNAME-EQUAL X Y))) (VECTOR (AND (VECTORP Y) (LET ((SX (LENGTH X))) (AND (EQL SX (LENGTH Y)) (DOTIMES (I SX T) (IF (NOT (EQUALISH (AREF X I) (AREF Y I))) (RETURN NIL))))))) (ARRAY (AND (ARRAYP Y) (EQUAL (ARRAY-DIMENSIONS X) (ARRAY-DIMENSIONS Y)) (LET ((FX (IL:%FLATTEN-ARRAY X)) (FY (IL:%FLATTEN-ARRAY Y))) (DOTIMES (I (ARRAY-TOTAL-SIZE X) T) (IF (NOT (EQUALISH (AREF FX I) (AREF FY I))) (RETURN NIL)))))) (T (IL:* IL:|;;| "so that datatypes will be properly compared") (OR (EQ X Y) (LET ((TYPENAME (IL:TYPENAME X))) (AND (EQ TYPENAME (IL:TYPENAME Y)) (LET ((DESCRIPTORS (IL:GETDESCRIPTORS TYPENAME))) (IF DESCRIPTORS (IL:FOR FIELD IL:IN DESCRIPTORS IL:ALWAYS (EQUALISH (IL:FFETCHFIELD FIELD X) (IL:FFETCHFIELD FIELD Y)))))))))) )) (DELETE-IF #'(LAMBDA (OLD-ENTRY) (XCL:DESTRUCTURING-BIND (OLD-PRIORITY OLD-FORM) OLD-ENTRY (AND (EQUAL PRIORITY OLD-PRIORITY) (EQUALISH FORM OLD-FORM)))) ENTRY-LIST))) (COND ((NULL ENTRY-LIST) (LIST ENTRY)) ((EQ PRIORITY :FIRST) (CONS ENTRY ENTRY-LIST)) ((EQ PRIORITY :LAST) (NCONC ENTRY-LIST (LIST ENTRY))) (T (IL:* IL:\;  "PRIORITY is a command to the old TTY Editor.") (UNLESS (AND (CONSP PRIORITY) (MEMBER (CAR PRIORITY) '(IL:BEFORE IL:AFTER))) (ERROR "Malformed priority argument to ADVISE: ~S" PRIORITY)) (XCL:CONDITION-CASE (IL:EDITE ENTRY-LIST `((IL:LC ,@(CDR PRIORITY)) (IL:BELOW IL:^) (,(CAR PRIORITY) ,ENTRY))) (ERROR (C) (ERROR "Error from EDITE during insertion of new advice:~% ~A~%" C))) ENTRY-LIST)))) (DEFSETF GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (DEFUN CREATE-ADVISED-DEFINITION (ADVISED-FN FN-TO-CALL ADVICE-NAME) (MULTIPLE-VALUE-BIND (LAMBDA-CAR ARG-LIST CALLING-FORM) (FUNCTION-WRAPPER-INFO ADVISED-FN FN-TO-CALL) (LET* ((ADVICE (CAR (GETHASH ADVICE-NAME *ADVICE-HASH-TABLE*))) (BEFORE-FORMS (MAPCAR 'SECOND (ADVICE-BEFORE ADVICE))) (AFTER-FORMS (MAPCAR 'SECOND (ADVICE-AFTER ADVICE))) (AROUND-FORMS (MAPCAR 'SECOND (ADVICE-AROUND ADVICE))) (BODY-FORM (MAKE-AROUND-BODY CALLING-FORM AROUND-FORMS))) `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA) '(&REST XCL:ARGLIST) ARG-LIST) ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA)) `((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST) (LIST ARG-LIST) ARG-LIST))))) (IL:\\CALLME '(:ADVISED ,ADVICE-NAME)) (BLOCK NIL (XCL:DESTRUCTURING-BIND (IL:!VALUE . IL:!OTHER-VALUES) (MULTIPLE-VALUE-LIST (PROGN ,@BEFORE-FORMS ,BODY-FORM)) ,@AFTER-FORMS (APPLY 'VALUES IL:!VALUE IL:!OTHER-VALUES))))))) (DEFUN MAKE-AROUND-BODY (CALLING-FORM AROUND-FORMS) (REDUCE #'(LAMBDA (CURRENT-BODY NEXT-AROUND-FORM) (LET ((CANONICALIZED-AROUND-FORM (SUBST '(XCL:INNER) 'IL:* NEXT-AROUND-FORM))) `(MACROLET ((XCL:INNER NIL ',CURRENT-BODY)) ,CANONICALIZED-AROUND-FORM))) AROUND-FORMS :INITIAL-VALUE CALLING-FORM)) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:PUTDEF (QUOTE IL:ADVICE) (QUOTE IL:FILEPKGCOMS) '((IL:COM IL:MACRO (IL:X (IL:P IL:* ( ADVICE-FILE-DEFINITIONS 'IL:X NIL))) IL:CONTENTS IL:NILL IL:ADD ADVICE-ADDTOCOM) (TYPE IL:DESCRIPTION "advice" IL:NEWCOM ADVICE-NEWCOM IL:GETDEF ADVICE-GETDEF IL:DELDEF ADVICE-DELDEF IL:PUTDEF ADVICE-PUTDEF IL:HASDEF ADVICE-HASDEF))) (IL:PUTDEF (QUOTE IL:ADVISE) (QUOTE IL:FILEPKGCOMS) '((IL:COM IL:MACRO (IL:X (IL:P IL:* ( ADVICE-FILE-DEFINITIONS 'IL:X T))) IL:CONTENTS ADVISE-CONTENTS IL:ADD ADVICE-ADDTOCOM))) (DEFUN XCL:REINSTALL-ADVICE (XCL::NAME &KEY XCL::BEFORE XCL::AFTER XCL::AROUND) (IL:FOR XCL::ADVICE IL:IN XCL::BEFORE IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :BEFORE XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AFTER IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AFTER XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AROUND IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AROUND XCL::PRIORITY XCL::FORM)))) (DEFUN ADVICE-GETDEF (NAME TYPE OPTIONS) (LET ((ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (AND ADVICE (APPEND (IL:FOR ENTRY IL:IN (ADVICE-BEFORE ADVICE) IL:COLLECT (CONS ':BEFORE (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AFTER ADVICE) IL:COLLECT (CONS ':AFTER (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AROUND ADVICE) IL:COLLECT (CONS ':AROUND (COPY-TREE ENTRY))))))) (DEFUN ADVICE-PUTDEF (NAME TYPE DEFINITION) (LET ((CANONICAL-DEFN (IL:FOR ENTRY IL:IN DEFINITION IL:COLLECT (LIST (CANONICALIZE-ADVICE-WHEN-SPEC (CAR ENTRY)) (CANONICALIZE-ADVICE-WHERE-SPEC (COPY-TREE (CADR ENTRY))) (COPY-TREE (CADDR ENTRY))))) (CURRENT-ADVICE (OR (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)) (CAR (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS (MAKE-ADVICE) NIL)))))) (SETF (ADVICE-BEFORE CURRENT-ADVICE) (MAPCAR #'REST (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :BEFORE) IL:COLLECT ENTRY))) (SETF (ADVICE-AFTER CURRENT-ADVICE) (MAPCAR #'REST (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AFTER) IL:COLLECT ENTRY))) (SETF (ADVICE-AROUND CURRENT-ADVICE) (MAPCAR #'REST (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AROUND) IL:COLLECT ENTRY))) (IF (CONSP NAME) (XCL:READVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:READVISE-FUNCTION NAME)))) (DEFUN ADVICE-DELDEF (NAME TYPE) (DECLARE (IGNORE TYPE)) (WHEN (MEMBER NAME IL:ADVISEDFNS :TEST 'EQUAL) (IF (CONSP NAME) (XCL:UNADVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:UNADVISE-FUNCTION NAME)) (FORMAT *TERMINAL-IO* "~S unadvised." NAME)) (REMHASH NAME *ADVICE-HASH-TABLE*)) (DEFUN ADVICE-HASDEF (NAME TYPE SOURCE) (AND (GETHASH NAME *ADVICE-HASH-TABLE*) (OR NAME T))) (DEFUN ADVICE-NEWCOM (NAME TYPE LISTNAME FILE) (IL:* IL:|;;;| "If you make a new com for ADVICE, you should make an ADVISE command.") (IL:DEFAULTMAKENEWCOM NAME 'IL:ADVISE LISTNAME FILE)) (DEFUN ADVICE-FILE-DEFINITIONS (NAMES READVISE?) (IL:* IL:|;;;| "READVISE? is true for the File Manager command ADVISE and false for the command ADVICE. For ADVISE, we want to emit a form to readvise the named functions after reinstalling the advice.") (LET ((REAL-NAMES NIL)) `(,@(IL:FOR FN IL:IN NAMES IL:COLLECT (LET* ((NAME (IL:IF (CONSP FN) IL:THEN (ASSERT (AND (EQ (SECOND FN) :IN) (= 3 (LENGTH FN))) NIL "~S should be of the form (FOO :IN BAR)" FN) FN IL:ELSE (LET ((NAME (CANONICALIZE-ADVICE-SYMBOL FN)) (OLD-ADVICE (GET FN 'IL:READVICE))) (WHEN OLD-ADVICE (ADD-OLD-STYLE-ADVICE NAME OLD-ADVICE) (REMPROP FN 'IL:READVICE)) NAME))) (ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (ASSERT (NOT (NULL ADVICE)) NIL "Can't find advice for ~S" NAME) (PUSH NAME REAL-NAMES) `(XCL:REINSTALL-ADVICE ',NAME ,@(AND (ADVICE-BEFORE ADVICE) `(:BEFORE ',(ADVICE-BEFORE ADVICE))) ,@(AND (ADVICE-AFTER ADVICE) `(:AFTER ',(ADVICE-AFTER ADVICE))) ,@(AND (ADVICE-AROUND ADVICE) `(:AROUND ',(ADVICE-AROUND ADVICE)))))) ,@(AND READVISE? `((IL:READVISE ,@(REVERSE REAL-NAMES))))))) (DEFUN ADVISE-CONTENTS (COM NAME TYPE) (AND (EQ TYPE 'IL:ADVICE) (COND ((NULL NAME) (IL:* IL:\;  "Return a list of the ADVICE's in the given COM.") (CDR COM)) ((EQ NAME 'T) (IL:* IL:\;  "Return T if there are ANY ADVICE's in the given COM.") (NOT (NULL (CDR COM)))) ((OR (SYMBOLP NAME) (= (LENGTH NAME) 3) (EQ (SECOND NAME) :IN)) (IL:* IL:\;  "Return T iff an ADVICE named NAME in the given COM.") (AND (MEMBER NAME (CDR COM) :TEST 'EQUAL) T)) (T (IL:* IL:\; "NAME is a list of names. Return the intersection of that list with the ADVICE's in the given COM.") (INTERSECTION NAME (CDR COM) :TEST 'EQUAL))))) (DEFUN ADVICE-ADDTOCOM (COM NAME TYPE NEAR) (IL:* IL:|;;;| "This is the ADD method for both of the ADVICE and ADVISE commands.") (IL:* IL:|;;;| "Add the given name only if the type is ADVICE. Also, add it to ADVICE commands only if a NEAR was specified. We want to normally create only ADVISE commands. If the user really wants an ADVICE command, they'll have to create it themselves.") (AND (EQ TYPE 'IL:ADVICE) (OR (EQ (CAR COM) 'IL:ADVISE) (NOT (NULL NEAR))) (IL:ADDTOCOM1 COM NAME NEAR NIL))) (IL:PUTPROPS IL:ADVISED IL:PROPTYPE IGNORE) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (DEFUN IL:READVISE1 (IL:FN) (FLET ((IL:READVISE-ENTRY (IL:ENTRY) (IL:IF (IL:LISTP IL:ENTRY) IL:THEN (XCL:READVISE-FUNCTION (FIRST IL:ENTRY) :IN (THIRD IL:ENTRY)) IL:ELSE (XCL:READVISE-FUNCTION IL:ENTRY)))) (IL:IF (IL:LISTP IL:FN) IL:THEN (ASSERT (IL:STRING.EQUAL (SECOND IL:FN) "IN") NIL "~S should be in the form (FOO IN BAR).~%" IL:FN) (IL:READVISE-ENTRY IL:FN) IL:ELSE (LET ((IL:NAME (CANONICALIZE-ADVICE-SYMBOL IL:FN)) (IL:OLD-ADVICE (GET IL:FN 'IL:READVICE))) (IL:IF IL:OLD-ADVICE IL:THEN (ADD-OLD-STYLE-ADVICE IL:NAME IL:OLD-ADVICE) (REMPROP IL:FN 'IL:READVICE)) (IL:READVISE-ENTRY IL:NAME))))) (DEFUN ADD-OLD-STYLE-ADVICE (NAME OLD-ADVICE) (IL:* IL:|;;;| "OLD-ADVICE should the value of the READVICE property of some symbol. Note that the CAR of that value is the old middle-man used for -IN- advice. Thus, we take the CDR below.") (WHEN (NOT (MEMBER NAME IL:ADVISEDFNS :TEST 'EQUAL)) (DELETE-ADVICE NAME)) (IL:FOR ADVICE IL:IN (CDR OLD-ADVICE) IL:DO (XCL:DESTRUCTURING-BIND (WHEN WHERE WHAT) ADVICE (IL:* IL:|;;|  "Translate Interlisp names to the new standard.") (ADD-ADVICE NAME ( CANONICALIZE-ADVICE-WHEN-SPEC WHEN) (CANONICALIZE-ADVICE-WHERE-SPEC WHERE) WHAT)))) (DEFUN CANONICALIZE-ADVICE-SYMBOL (SYMBOL) (LET ((IN-POS (IL:STRPOS "-IN-" SYMBOL))) (IF (NULL IN-POS) SYMBOL (LIST (IL:SUBATOM SYMBOL 1 (1- IN-POS)) :IN (IL:SUBATOM SYMBOL (+ IN-POS 4) NIL))))) (DEFUN CANONICALIZE-ADVICE-WHEN-SPEC (SPEC) (IF (NULL SPEC) ':BEFORE (INTERN (STRING SPEC) "KEYWORD"))) (DEFUN CANONICALIZE-ADVICE-WHERE-SPEC (SPEC) (CASE SPEC ((NIL LAST IL:BOTTOM IL:END :LAST) ':LAST) ((IL:TOP IL:FIRST :FIRST) ':FIRST) (T (IF (CONSP SPEC) SPEC (ERROR "Illegal WHERE specification to ADVISE: ~S" SPEC))))) (XCL:DEF-DEFINE-TYPE XCL:ADVISED-FUNCTIONS "Advised function definitions") (XCL:DEFDEFINER (XCL:DEFADVICE (:PROTOTYPE (LAMBDA (XCL::NAME) `(XCL:DEFADVICE ,XCL::NAME "advice")))) XCL:ADVISED-FUNCTIONS ( XCL::NAME &BODY XCL::ADVICE-FORMS ) `(PROGN ,.(XCL:WITH-COLLECTION (DOLIST (XCL::ADVICE XCL::ADVICE-FORMS) (XCL:COLLECT (XCL:DESTRUCTURING-BIND (XCL::FN-TO-ADVISE XCL::FORM &KEY XCL::IN WHEN XCL::PRIORITY) XCL::ADVICE `(XCL:ADVISE-FUNCTION ',XCL::FN-TO-ADVISE ',XCL::FORM ,@(AND XCL::IN `(:IN ',XCL::IN)) ,@(AND WHEN `(:WHEN ,WHEN)) ,@(AND XCL::PRIORITY `(:PRIORITY ,XCL::PRIORITY))))))))) (IL:* IL:|;;| "Arrange for the proper package. Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package." ) (IL:PUTPROPS IL:ADVISE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM")) (IL:PUTPROPS IL:ADVISE IL:FILETYPE :COMPILE-FILE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA IL:READVISE IL:UNADVISE) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA IL:ADVISE) ) (IL:PUTPROPS IL:ADVISE IL:COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3354 7926 (IL:ADVISE 3367 . 5496) (IL:UNADVISE 5498 . 6418) (IL:READVISE 6420 . 7924 ))))) IL:STOP \ No newline at end of file diff --git a/sources/AERROR b/sources/AERROR new file mode 100644 index 00000000..087b0d79 --- /dev/null +++ b/sources/AERROR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 11:58:35" {DSK}local>lde>lispcore>sources>AERROR.;2 10460 changes to%: (VARS AERRORCOMS) previous date%: " 1-Feb-89 09:38:44" {DSK}local>lde>lispcore>sources>AERROR.;1) (* ; " Copyright (c) 1982, 1983, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT AERRORCOMS) (RPAQQ AERRORCOMS ((FNS ERRORSTRING SETERRORN LISPERROR \LISPERROR \ILLEGAL.ARG \ARG.NOT.LITATOM) (EXPORT (DECLARE%: EVAL@COMPILE (VARS \ERRORMESSAGELIST) DONTCOPY (OPTIMIZERS LISPERROR))) (VARIABLES *LAST-CONDITION*) (GLOBALVARS \ERRORMESSAGELIST) (FUNCTIONS ERRM-TO-CONDITION) (PROP FILETYPE AERROR) (LOCALVARS . T))) (DEFINEQ (ERRORSTRING (LAMBDA (X) (* lmm "21-APR-80 15:46") (CAR (NTH \ERRORMESSAGELIST (ADD1 (OR (NUMBERP X) 17)))))) (SETERRORN (LAMBDA (NUM MESS) (* amd "30-Jul-86 17:00") (CL:SETQ *LAST-CONDITION* (ERRM-TO-CONDITION NUM MESS)))) (LISPERROR [LAMBDA (N X CONTINUEOKFLG) (* ; "Edited 1-Feb-89 09:38 by jds") (* ;; "compiles open as call to \LISPERROR") [COND ((STRINGP N) (* ;; "Case where LISPERROR is called with one of the %"canonical error message%" strings from the old IL implementation. Need to translate it to a number. THIS CODE IS STOLEN IN SPIRIT FROM THE OPTIMIZER.") (FOR MSG IN \ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL MSG N) DO (SETQ N I] (\LISPERROR X N CONTINUEOKFLG]) (\LISPERROR (LAMBDA (X N CONTINUEOKFLG) (* amd "11-Nov-86 12:09") (DECLARE (USEDFREE \INTERRUPTABLE)) (PROG NIL (SELECTQ N ((5 22) (* ; "File errors that can happen to files open for output") (* ;; "(\STOP.DRIBBLE? X)")) NIL) (OR \INTERRUPTABLE (\MP.ERROR \MP.UNINTERRUPTABLE "Error in uninterruptable system code -- ^N to continue into error handler" X)) RET (RETURN (PROG1 (COND ((SMALLP N) (ERRORX (LIST N X))) (T (ERROR N X))) (OR CONTINUEOKFLG (GO RET)))))) ) (\ILLEGAL.ARG (LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ILLEGAL ARG" X))) (\ARG.NOT.LITATOM (LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ARG NOT LITATOM" X))) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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")) DONTCOPY (DEFOPTIMIZER LISPERROR (MESSAGE ARG) `(\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))) ) (* "END EXPORTED DEFINITIONS") (CL:DEFVAR *LAST-CONDITION* NIL "Last condition signalled. This gets rebound to itself in nested execs.") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \ERRORMESSAGELIST) ) (CL:DEFUN ERRM-TO-CONDITION (NUM MESSAGE) (CL:IF (TYPEP NUM 'CONDITION) NUM (CASE NUM (2 (* ; "STACK OVERFLOW") (MAKE-CONDITION 'STACK-OVERFLOW)) (3 (* ; "ILLEGAL RETURN") (MAKE-CONDITION 'ILLEGAL-RETURN :TAG MESSAGE)) ((4 10 14 28 38 39 51) (* ; "ARG NOT x") [MAKE-CONDITION 'XCL:TYPE-MISMATCH :NAME MESSAGE :VALUE MESSAGE :EXPECTED-TYPE (CL:ECASE NUM (4 'LIST) (10 'CL:NUMBER) (14 'CL:SYMBOL) (28 'ARRAYP) (38 'READTABLEP) (39 'TERMTABLEP) (51 'CL:HASH-TABLE))]) (5 (* ; "HARD DISK ERROR") (MAKE-CONDITION 'XCL:SIMPLE-DEVICE-ERROR :MESSAGE MESSAGE)) ((6 35) (* ;  "ATTEMPT TO SET NIL, ATTEMPT TO BIND NIL OR T") (MAKE-CONDITION 'XCL:ATTEMPT-TO-CHANGE-CONSTANT :NAME NIL)) (7 (* ; "ATTEMPT TO RPLAC NIL") (MAKE-CONDITION 'XCL:ATTEMPT-TO-RPLAC-NIL :NAME MESSAGE)) (8 (* ; "UNDEFINED OR ILLEGAL GO") (MAKE-CONDITION 'ILLEGAL-GO :TAG MESSAGE)) (9 (* ; "FILE WON'T OPEN") (MAKE-CONDITION 'XCL:FILE-WONT-OPEN :PATHNAME MESSAGE)) (11 (* ; "ATOM TOO LONG") (MAKE-CONDITION 'XCL:SYMBOL-NAME-TOO-LONG)) (12 (* ; "ATOM HASH TABLE FULL") (MAKE-CONDITION 'XCL:SYMBOL-HT-FULL)) (13 (* ; "FILE NOT OPEN") (MAKE-CONDITION 'XCL:STREAM-NOT-OPEN :STREAM MESSAGE)) (16 (* ; "END OF FILE") (MAKE-CONDITION 'END-OF-FILE :STREAM MESSAGE)) (17 (* ; "ERROR") (MAKE-CONDITION 'INTERLISP-ERROR :MESSAGE MESSAGE)) (19 (* ; "ILLEGAL STACK ARG") (MAKE-CONDITION 'ILLEGAL-STACK-ARG :ARG MESSAGE)) (21 (* ; "ARRAYS FULL") (MAKE-CONDITION 'XCL:ARRAY-SPACE-FULL)) (22 (* ; "FILE SYSTEM RESOURCES EXCEEDED") (MAKE-CONDITION 'XCL:FS-RESOURCES-EXCEEDED :PATHNAME MESSAGE)) (23 (* ; "FILE NOT FOUND") (MAKE-CONDITION 'XCL:FILE-NOT-FOUND :PATHNAME MESSAGE)) ((25 27) (* ;  "UNUSUAL CDR ARG LIST, ILLEGAL ARG") (MAKE-CONDITION 'INVALID-ARGUMENT-LIST :ARGUMENT MESSAGE)) (26 (* ; "HASH TABLE FULL") (MAKE-CONDITION 'XCL:HASH-TABLE-FULL :TABLE MESSAGE)) (30 (* ; "STACK PTR HAS BEEN RELEASED") (MAKE-CONDITION 'STACK-POINTER-RELEASED :NAME MESSAGE)) (31 (* ; "STORAGE FULL") (MAKE-CONDITION 'XCL:STORAGE-EXHAUSTED)) (34 (* ; "DATA TYPES FULL") (MAKE-CONDITION 'XCL:DATA-TYPES-EXHAUSTED)) (41 (* ; "PROTECTION VIOLATION") (MAKE-CONDITION 'XCL:FS-PROTECTION-VIOLATION :PATHNAME MESSAGE)) (42 (* ; "BAD FILE NAME") (MAKE-CONDITION 'XCL:INVALID-PATHNAME :PATHNAME MESSAGE)) (44 (* ; "UNBOUND ATOM") (MAKE-CONDITION 'UNBOUND-VARIABLE :NAME MESSAGE)) (45 (* ; "UNDEFINED CAR OF FORM") (MAKE-CONDITION 'UNDEFINED-CAR-OF-FORM :FUNCTION MESSAGE)) (46 (* ; "UNDEFINED FUNCTION") (MAKE-CONDITION 'UNDEFINED-FUNCTION-IN-APPLY :NAME (CL:FIRST MESSAGE) :ARGUMENTS (CL:SECOND MESSAGE))) (47 (* ; "CONTROL-E") (MAKE-CONDITION 'XCL:CONTROL-E-INTERRUPT)) (48 (* ; "FLOATING UNDERFLOW") (MAKE-CONDITION 'CONDITIONS:FLOATING-POINT-UNDERFLOW)) (49 (* ; "FLOATING OVERFLOW") (MAKE-CONDITION 'CONDITIONS:FLOATING-POINT-OVERFLOW)) (52 (* ; "TOO MANY ARGUMENTS") (MAKE-CONDITION 'TOO-MANY-ARGUMENTS :CALLEE MESSAGE :MAXIMUM CL:CALL-ARGUMENTS-LIMIT)) (CL:OTHERWISE (CL:ERROR "Interlisp error number ~D (message: ~S) no longer supported" NUM MESSAGE))))) (PUTPROPS AERROR FILETYPE CL:COMPILE-FILE) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS AERROR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (872 2358 (ERRORSTRING 882 . 995) (SETERRORN 997 . 1114) (LISPERROR 1116 . 1703) ( \LISPERROR 1705 . 2174) (\ILLEGAL.ARG 2176 . 2261) (\ARG.NOT.LITATOM 2263 . 2356))))) STOP \ No newline at end of file diff --git a/sources/AFONT b/sources/AFONT new file mode 100644 index 00000000..e14efa91 --- /dev/null +++ b/sources/AFONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "IL") (FILECREATED "16-May-90 11:59:31" {DSK}local>lde>lispcore>sources>AFONT.;2 41645 changes to%: (VARS AFONTCOMS) previous date%: "14-Sep-87 11:59:36" {DSK}local>lde>lispcore>sources>AFONT.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT AFONTCOMS) (RPAQQ AFONTCOMS ((XCL:FILE-ENVIRONMENTS "AFONT") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BOUNDINGBOX FONTBOUNDINGBOX) (CONSTANTS noInfoCode)) (FNS \CREATESTARFONT \READACFONTBOXES \READACFONTFILE \ACCHARIMAGELIST \ACCHARWIDTHLIST \GETFBB \ACCHARPOSLIST \ACROTATECHAR \READFONTWDFILE \FACECODE \FAMILYCODE \FINDFONT) [INITVARS (INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>"] (MACROS \POSITIONFONTFILE))) (XCL:DEFINE-FILE-ENVIRONMENT "AFONT" :PACKAGE "IL" :READTABLE "INTERLISP" :COMPILER :COMPILE-FILE) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD BOUNDINGBOX ( (* * The bounding box for a character in an AC file) BBOX (* Offset from the left edge of the  bounding box to the character's  origin) BBOY (* Offset from the bottom of the  bounding box to the character's  origin) BBDX (* Width of the character's bounding  box in pixels) BBDY (* Height of the bounding box in  bits; -1 if this character doesn't  really exist) RASTERWIDTHX (* Width of the character's image  (i.e., the escapement for this  character) in raster bits) RASTERWIDTHY (* Amount this char moves in Y, in  raster units.) )) (RECORD FONTBOUNDINGBOX (FBBBDX FBBBDY FBBBOX FBBBOY)) ) (DECLARE%: EVAL@COMPILE (RPAQQ noInfoCode 32768) (CONSTANTS noInfoCode) ) ) (DEFINEQ (\CREATESTARFONT [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET) (* gbn " 1-Oct-85 18:29") (* ;; "the Build font descriptor for an Interpress NS font. If we can't find widths info for that font, return NIL") (* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") (DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS)) (RESETLST (* ;  "RESETLST to make sure the fontfiles get closed") (PROG [(CS (OR CHARSET \DEFAULTCHARSET)) (NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540) 72))) (FD (create FONTDESCRIPTOR FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ PSIZE FONTFACE _ FACE \SFFACECODE _ (\FACECODE FACE) ROTATION _ ROTATION OTHERDEVICEFONTPROPS _ \ASCIITONS FONTSCALE _ (CONSTANT (FQUOTIENT 2540 72] (RETURN (if (NOT (\GETCHARSETINFO CS FD T)) then (* ;  "return NIL and let FONTCREATE decide whether or not to cause an error") NIL else FD]) (\READACFONTBOXES [LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "15-Jun-85 11:48") (* ;  "GETACCHARSPECS returns (bbox bboy bbdx bbdy)") (* ;  "if bbdx and bbdy are both zero, then treat it as a space.") (SETFILEPTR FILE 48) (* ;  "Move to the start of AC file's width info.") (for X from STARTCHAR to ENDCHAR collect (* ;  "Now collect the 4 bounding box values into a list") (create BOUNDINGBOX RASTERWIDTHX _ (PROG1 (\WIN FILE) (* ;  "Read a fraction, and truncate it to an integer # of raster bits") (\WIN FILE)) RASTERWIDTHY _ (PROG1 (\WIN FILE) (* ;  "Read a fraction, and truncate it to an integer # of raster bits") (\WIN FILE)) BBOX _ (SIGNED (\WIN FILE) BITSPERWORD) BBOY _ (SIGNED (\WIN FILE) BITSPERWORD) BBDX _ (SIGNED (\WIN FILE) BITSPERWORD) BBDY _ (SIGNED (\WIN FILE) BITSPERWORD]) (\READACFONTFILE [LAMBDA (STRM FAMILY SIZE FACE PAD.LEFT DONT.PAD.RIGHT) (* ; "Edited 1-Sep-87 10:04 by Snow") (* ;; "Read an AC-format font file. Assumes that the file is open and has already been determined to be of type AC.") [COND ((RANDACCESSP STRM) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) STRM))) (T (* ;; "This is necessary unless we figure out how to read the AC file sequentially. When we figure this out, we can factor the RESETSAVE back in \READDISPLAYFONTFILE") (SETQ STRM (OPENSTREAM (CLOSEF? STRM) 'INPUT)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) STRM)) (COPYBYTES STRM (SETQ STRM (OPENSTREAM '{NODIRCORE} 'BOTH] (SETFILEPTR STRM 28) (* ;  "Starting at 28 skips the family and face bytes.") (PROG [FBBLIST STARTCHAR ENDCHAR CHARWIDTHLIST CHARIMAGEWIDTHLIST LEFTKERNS OFFSETS WIDTHS IMAGEWIDTHS FONTDESC FBBBITMAP CHARBITMAP STARTWORDLIST BBOXLIST DUMMYCHAROFFSET DUMMYWIDTH (CSINFO (create CHARSETINFO IMAGEWIDTHS _ (\CREATECSINFOELEMENT) LEFTKERN _ (\CREATEKERNELEMENT] (SETQ STARTCHAR (BIN STRM)) (* ;  "Get the first and last characters in this font") (SETQ ENDCHAR (BIN STRM)) (SETQ BBOXLIST (\READACFONTBOXES STRM STARTCHAR ENDCHAR)) (* ;  "Read the list of bounding boxes for all the chars in the font") (SETQ FBBLIST (\GETFBB BBOXLIST)) (SETQ CHARWIDTHLIST (\ACCHARIMAGELIST BBOXLIST)) (* ;  "And the escapement for each character.") (SETQ CHARIMAGEWIDTHLIST (\ACCHARWIDTHLIST BBOXLIST FBBLIST)) (* ;  "Create the list of character widths for the characters in the font.") (COND ([EVERY (CDR CHARWIDTHLIST) (FUNCTION (LAMBDA (WID) (OR (ZEROP WID) (EQP WID (CAR CHARWIDTHLIST] (* ;  "Fixed-pitch font. Make the dummy character (for non-existent chars) the same width.") (SETQ DUMMYWIDTH (CAR CHARWIDTHLIST))) (T (* ; "Otherwise, make the dummy 6 wide.") (SETQ DUMMYWIDTH 6))) (COND ((NULL (REMOVE 0 CHARIMAGEWIDTHLIST)) (ERROR "No raster images" NIL) (RETURN))) (SETQ LEFTKERNS (FETCH (CHARSETINFO LEFTKERN) OF CSINFO)) (FOR I FROM STARTCHAR TO ENDCHAR AS BOX IN BBOXLIST DO (* ; "set the left kerning values. the default value is ZERO which is set when the element is created. Currently it is an array because kerning values can be negative values.") (\FSETLEFTKERN LEFTKERNS I (FFETCH (BOUNDINGBOX BBOX) OF BOX))) (SETQ IMAGEWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETIMAGEWIDTH IMAGEWIDTHS I DUMMYWIDTH)) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETWIDTH WIDTHS I DUMMYWIDTH)) (* SETQ IMAGEWIDTHS (ARRAY 258  (QUOTE (BITS 16)) DUMMYWIDTH 0)) (* ;; "Create the array of character widths, assuming the dummy width for all characters--we'll write over it later") [for X from STARTCHAR to ENDCHAR as Y in CHARIMAGEWIDTHLIST do (* ;; "Fill in the image widths (the width of the image, as against how far to space over after printing the character)") (\FSETIMAGEWIDTH IMAGEWIDTHS X (COND ((ZEROP Y) 0) (T (IPLUS Y (COND (PAD.LEFT 1) (T 0)) (COND (DONT.PAD.RIGHT 0) (T 1] (* ;  "And the array of image escapements") (for X from STARTCHAR to ENDCHAR as Y in CHARWIDTHLIST do (\FSETWIDTH WIDTHS X Y)) [replace CHARSETDESCENT of CSINFO with (IMAX 0 (IMINUS (fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST] [replace CHARSETASCENT of CSINFO with (IMAX 0 (IPLUS (fetch (FONTBOUNDINGBOX FBBBDY) of FBBLIST) (fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST] [replace CHARSETBITMAP of CSINFO with (SETQ CHARBITMAP (BITMAPCREATE (IPLUS (SETQ DUMMYCHAROFFSET (for (X _ STARTCHAR) to ENDCHAR sum (\FGETWIDTH IMAGEWIDTHS X))) DUMMYWIDTH) (fetch (FONTBOUNDINGBOX FBBBDY) of FBBLIST] (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (for I from 0 to (ADD1 \MAXTHINCHAR) do (\FSETOFFSET OFFSETS I DUMMYCHAROFFSET)) (SETQ STARTWORDLIST (\ACCHARPOSLIST STRM STARTCHAR ENDCHAR)) (bind (DESTLEFT _ 0) for NTHCHAR from STARTCHAR to ENDCHAR as BBLIST in BBOXLIST as STARTWORD in STARTWORDLIST as CHARWIDTH in CHARWIDTHLIST do (PROG (RASTERINFO BBOX BBBITMAP BBBMBASE) (* ;  "\ACCHARPOSLIST returns NIL if no raster exists for the code") (COND ((NULL STARTWORD) (* ;; "This character has no image; use the dummy char's offset (already in the offset and width arrays from earlier)") (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) (GO L2))) (SETFILEPTR STRM STARTWORD) (* ;  "If could flush this, would work on non-randaccessp devices") (SETQ RASTERINFO (\WIN STRM)) (COND ((EQ -1 (fetch BBDY of BBLIST)) (\FSETWIDTH WIDTHS NTHCHAR DUMMYWIDTH) (\FSETIMAGEWIDTH IMAGEWIDTHS NTHCHAR DUMMYWIDTH) (GO L2))) (* ;  "\ACCHARPOSLIST returns NIL if no raster exists for the code") (SETQ BBOX (fetch BBOX of BBLIST)) (COND ((AND (ZEROP (fetch BBDX of BBLIST)) (ZEROP (fetch BBDY of BBLIST))) (* ;  "The image is zero wide or zero high. Don't bother reading a bitmap image") ) ((SETQ BBBITMAP (BITMAPCREATE (TIMES 16 (FOLDLO RASTERINFO 1024)) (IMOD RASTERINFO 1024))) (SETQ BBBMBASE (fetch BITMAPBASE of BBBITMAP)) (* ;; "STARTWORD is the characters raster information word. The high 6 bits record number of words per scan line and the lower 10 bits is the same as bbdx bbdx. The raster for the char follows STARTWORD") (\BINS STRM BBBMBASE 0 (TIMES 2 (FOLDLO RASTERINFO 1024) (IMOD RASTERINFO 1024))) (SETQ BBBITMAP (\ACROTATECHAR BBBITMAP)) (* ;  "here is the place to add a rotation function to manipulate the character images coming off *.ac") (BITBLT BBBITMAP 0 0 CHARBITMAP [PLUS DESTLEFT (IMAX 0 (COND (PAD.LEFT (ADD1 BBOX)) (T BBOX] (DIFFERENCE (fetch BBOY of BBLIST) (fetch (FONTBOUNDINGBOX FBBBOY) of FBBLIST)) (\FGETWIDTH IMAGEWIDTHS NTHCHAR) (CADDDR BBLIST) 'INPUT 'REPLACE) (* ;  "ADD1 to BBOX because we add an empty column to each raster image to the left") )) (\FSETOFFSET OFFSETS NTHCHAR DESTLEFT) (* ;; "on screen ac fonts, there are no spaces stored so that the width of the char is exactly that of the character image without any spacing columns") (add DESTLEFT (\FGETWIDTH IMAGEWIDTHS NTHCHAR)) L2 (* ;  "add 2 because of the two blank columns we add; one on either side of the ac raster image") )) (BITBLT NIL 0 0 CHARBITMAP (ADD1 DUMMYCHAROFFSET) 0 (IDIFFERENCE DUMMYWIDTH 2) NIL 'TEXTURE 'REPLACE BLACKSHADE) (* ;  "Fill in the dummy-character black blot") (RETURN CSINFO]) (\ACCHARIMAGELIST [LAMBDA (BOXLIST) (* jds "15-Jun-85 11:37") (* ;; "Returns a list of the ESCAPEMENTS (ie how far to move after printng this character) for each char in the font.") (for BOX in BOXLIST collect (fetch (BOUNDINGBOX RASTERWIDTHX) of BOX]) (\ACCHARWIDTHLIST [LAMBDA (BOXLIST FBBOX) (* jds " 4-Dec-84 16:05") (* ;  "GETACCHARSPECS returns (bbox bboy bbdx bbdy)") (* ;  "if bbdx and bbdy are both zero, then treat it as a space.") (for BOX in BOXLIST bind (STARTWORD BBOX BBOY BBDX BBDY) collect (SETQ BBOX (fetch BBOX of BOX)) (SETQ BBOY (fetch BBOY of BOX)) (SETQ BBDX (fetch BBDX of BOX)) (SETQ BBDY (fetch BBDY of BOX)) (COND ((AND (ZEROP BBDX) (ZEROP BBDY)) (* ;  "we've found a Space. Smash in a quarter of the maximum width. Maybe should be an explicit em?") (IMAX 2 (FOLDLO (IPLUS 2 (fetch (FONTBOUNDINGBOX FBBBDX) of FBBOX)) 4))) (T (COND ((EQ BBDX -1) 0) (T (IPLUS BBDX (IMAX 0 BBOX]) (\GETFBB [LAMBDA (BOXLIST) (* jds "17-May-85 10:22") (* ;  "Read a font bounding box from an AC file") (PROG (RESULTLIST CHARCOUNT BBLIST MAXBBOX MAXBBOY MINBBOX MINBBOY MAXSUMBBOXBBDX MAXSUMBBOYBBDY BBOX BBOY BBDX BBDY) (* ;  "\GETFBB returns the fbbdx fbbdy fbbox fbboy of an acfont") (SETQ MINBBOX 32767) (SETQ MINBBOY 32767) (SETQ MAXBBOX -32768) (SETQ MAXBBOY -32768) (SETQ MAXSUMBBOXBBDX -32768) (SETQ MAXSUMBBOYBBDY -32768) [for BOX in BOXLIST do (SETQ BBOX (fetch (BOUNDINGBOX BBOX) of BOX)) (SETQ BBOY (fetch (BOUNDINGBOX BBOY) of BOX)) (SETQ BBDX (fetch (BOUNDINGBOX BBDX) of BOX)) (SETQ BBDY (fetch (BOUNDINGBOX BBDY) of BOX)) (* ;  "GETACCHARSPECS returns bbox bboy bbdx bbdy") (COND [(IEQP BBDY -1) (* ;  "This character doesn't exist. Create a dummy bounding box for it") (SETQ BBLIST '(0 0 0 -1] (T (COND ((IGREATERP BBOX MAXBBOX) (SETQ MAXBBOX BBOX))) (COND ((ILESSP BBOX MINBBOX) (SETQ MINBBOX BBOX))) (COND ((IGREATERP BBOY MAXBBOY) (SETQ MAXBBOY BBOY))) (COND ((ILESSP BBOY MINBBOY) (SETQ MINBBOY BBOY))) [COND ((IGREATERP (IPLUS BBOX BBDX) MAXSUMBBOXBBDX) (SETQ MAXSUMBBOXBBDX (IPLUS BBOX BBDX] (COND ((IGREATERP (IPLUS BBOY BBDY) MAXSUMBBOYBBDY) (SETQ MAXSUMBBOYBBDY (IPLUS BBOY BBDY] (* ;  "\GETFBB returns the fbbdx fbbdy fbbox fbboy of an acfont") (RETURN (create FONTBOUNDINGBOX FBBBDX _ (IDIFFERENCE MAXSUMBBOXBBDX MINBBOX) FBBBDY _ (IDIFFERENCE MAXSUMBBOYBBDY MINBBOY) FBBBOX _ MINBBOX FBBBOY _ MINBBOY]) (\ACCHARPOSLIST [LAMBDA (FILE STARTCHAR ENDCHAR) (* jds "10-NOV-83 20:19") (* ;  "\ACCHARPOSLIST returns the word position of the raster for the nth character of the file") [SETFILEPTR FILE (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR] (bind HIWORD LOWORD [DIRECTORYSTART _ (IPLUS 48 (ITIMES 16 (ADD1 (IDIFFERENCE ENDCHAR STARTCHAR] first (SETFILEPTR FILE DIRECTORYSTART) for X from STARTCHAR to ENDCHAR collect (SETQ HIWORD (\WIN FILE)) (SETQ LOWORD (\WIN FILE)) (* ;  "If the position of the acchar is given as -1,-1 then the raster does not exist so return nil") (COND ((AND (IEQP HIWORD 65535) (IEQP LOWORD 65535)) NIL) (T (IPLUS (LLSH HIWORD 17) (LLSH LOWORD 1) DIRECTORYSTART]) (\ACROTATECHAR [LAMBDA (BITMAP) (* ; "Edited 28-Jul-87 18:49 by Snow") (* ;; "(prog (new.bitmap (width (|fetch| (bitmap bitmapwidth) |of| bitmap)) (height (|fetch| (bitmap bitmapheight) |of| bitmap))) (setq new.bitmap (bitmapcreate height width)) (|for| y |from| 0 |to| (sub1 height) |do| (|for| x |from| 0 |to| (sub1 width) |bind| (y1 _ (idifference (sub1 height) y)) |do| (bitmapbit new.bitmap y1 x (bitmapbit bitmap x y)))) (return new.bitmap))") (ROTATE-BITMAP-LEFT BITMAP]) (\READFONTWDFILE [LAMBDA (FILE FD WIDTHS SCALE) (* jds " 2-Jan-86 12:34") (* ;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") (DECLARE (GLOBALVARS FONTWIDTHSFILES)) (* (RESETLST (* ;  "RESETLST to make sure the fontfiles get closed")  (PROG (FIXEDFLAGS FIRSTCHAR LASTCHAR  TEM WIDTHSY) (SETFILEPTR FILE  (LLSH (\FIXPIN FILE) 1))  (* ; "Locate the segment")  (replace (FONTDESCRIPTOR FBBOX) of FD  with (SIGNED (\WIN FILE) BITSPERWORD))  (replace \SFDescent of FD with  (IMINUS (SIGNED (\WIN FILE)  BITSPERWORD))) (* ; "Descent is -FBBOY")  (replace (FONTDESCRIPTOR FBBDX) of FD  with (SIGNED (\WIN FILE) BITSPERWORD))  (replace \SFHeight of FD with  (SIGNED (\WIN FILE) BITSPERWORD))  (* ; "Height is FBBDY")  (replace \SFWidths of FD with WIDTHS)  (SETQ FIRSTCHAR (fetch FIRSTCHAR of FD))  (* ;  "First and last 'real' characters in the font")  (SETQ LASTCHAR (fetch LASTCHAR of FD))  (COND (SCALE (* ;  "Dimensions are relative, must be scaled")  (replace (FONTDESCRIPTOR FBBOX) of FD  with (IQUOTIENT (ITIMES  (fetch (FONTDESCRIPTOR FBBOX) of FD)  SCALE) 1000)) (replace \SFDescent of  FD with (IQUOTIENT (ITIMES  (fetch \SFDescent of FD) SCALE) 1000))  (replace (FONTDESCRIPTOR FBBDX) of FD  with (IQUOTIENT (ITIMES  (fetch (FONTDESCRIPTOR FBBDX) of FD)  SCALE) 1000)) (replace \SFHeight of FD  with (IQUOTIENT (ITIMES  (fetch \SFHeight of FD) SCALE) 1000))))  (replace \SFAscent of FD with  (IDIFFERENCE (fetch \SFHeight of FD)  (fetch \SFDescent of FD)))  (SETQ FIXEDFLAGS (LRSH  (\BIN FILE) 6)) (* ;  "The fixed flags") (\BIN FILE)  (* ; "Skip the spares")  (COND ((EQ 2 (LOGAND FIXEDFLAGS 2))  (SETQ TEM (\WIN FILE))  (* ; "The fixed width for this font")  (COND ((AND SCALE (NOT  (ZEROP TEM))) (SETQ TEM  (IQUOTIENT (ITIMES TEM SCALE) 1000))))  (for I from FIRSTCHAR to LASTCHAR do  (SETA WIDTHS I TEM)))  (T (AIN WIDTHS FIRSTCHAR  (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))  FILE) (for I from FIRSTCHAR to  LASTCHAR when (EQ noInfoCode  (ELT WIDTHS I)) do (SETA WIDTHS I 0))  (COND (SCALE (for I from FIRSTCHAR to  LASTCHAR do (SETA WIDTHS I  (IQUOTIENT (ITIMES (ELT WIDTHS I)  SCALE) 1000))))))) (COND  ((EQ 1 (LOGAND FIXEDFLAGS 1))  (SETQ WIDTHSY (\WIN FILE))  (* ;  "The fixed width-Y for this font; the width-Y field is a single integer in the FD")  (replace \SFWidthsY of FD with  (COND ((AND SCALE (NOT  (ZEROP WIDTHSY))) (IQUOTIENT  (ITIMES WIDTHSY SCALE) 1000))  (T WIDTHSY)))) (T (replace \SFWidthsY  of FD with (SETQ WIDTHSY  (ARRAY (ADD1 \MAXCHAR)  (QUOTE SMALLPOSP) 0 0)))  (AIN WIDTHSY FIRSTCHAR  (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR))  FILE) (for I from FIRSTCHAR to  LASTCHAR when (EQ noInfoCode  (ELT WIDTHSY I)) do (SETA WIDTHSY I 0))  (COND (SCALE (for I from FIRSTCHAR to  LASTCHAR do (SETA WIDTHSY I  (IQUOTIENT (ITIMES (ELT WIDTHSY I)  SCALE) 1000)))))))))) (HELP]) (\FACECODE [LAMBDA (FACE) (* rmk%: "27-FEB-81 12:16") (IPLUS (SELECTQ (fetch (FONTFACE EXPANSION) of FACE) (REGULAR 0) (COMPRESSED 6) (EXPANDED 12) (SHOULDNT)) (SELECTQ (fetch (FONTFACE WEIGHT) of FACE) (MEDIUM 0) (BOLD 2) (LIGHT 4) (SHOULDNT)) (SELECTQ (fetch (FONTFACE SLOPE) of FACE) (REGULAR 0) (ITALIC 1) (SHOULDNT]) (\FAMILYCODE [LAMBDA (FAMILY WSTRM) (* rmk%: "11-Sep-84 10:54") (* ;; "Returns the family CODE for FAMILY in a standard widths file, leaving the file positioned at the beginning of the next file entry. Returns NIL if FAMILY not found. If FAMILY is T, returns the code for the first family in the index.") (SETFILEPTR WSTRM 0) (bind TYPE CODE LENGTH (NCHARS _ (NCHARS FAMILY)) (NEXT _ 0) do (SETFILEPTR WSTRM NEXT) (SETQ TYPE (\BIN WSTRM)) (SETQ LENGTH (\BIN WSTRM)) (add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15) 8)) 1)) (SELECTQ (LRSH TYPE 4) (1 (SETQ CODE (\WIN WSTRM)) (COND ([OR (EQ FAMILY T) (AND (EQ NCHARS (\BIN WSTRM)) (for I from 1 to NCHARS always (EQ (\BIN WSTRM) (NTHCHARCODE FAMILY I] (SETFILEPTR WSTRM NEXT) (* ; "Move file to next entry") (RETURN CODE)))) (0 (RETURN NIL)) NIL]) (\FINDFONT [LAMBDA (FD WSTRM PRESSMICASIZE NSMICASIZE DONTCHECK) (* ; "Edited 2-Apr-87 14:39 by bvm:") (* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. The FIRSTCHAR and LASTCHAR of the font are filled in, since we have to read past those to check the size. If successful, returns the size found in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing just after the Rotation word of the font. --- If DONTCHECK, then assumes that this file contains exactly the right face and family, without checking --- Returns NIL if the font is not found") (* (bind TYPE LENGTH SIZE FAMILYCODE  (ROTATION _ (fetch ROTATION of FD))  (FACECODE _ (\FACECODE  (fetch FONTFACE of FD)))  (NEXT _ 0) (FUZZ _ (PROG1 0.02  (* ;  "percentile difference acceptable as the same font size")))  first (OR (SETQ FAMILYCODE  (\FAMILYCODE (OR DONTCHECK  (fetch FONTFAMILY of FD)) WSTRM))  (RETURN NIL)) do (SETQ TYPE  (\BIN WSTRM)) (SETQ LENGTH  (\BIN WSTRM)) (add NEXT  (LLSH (IPLUS LENGTH (LLSH  (LOGAND TYPE 15) 8)) 1))  (SELECTQ (LRSH TYPE 4)  (4 (COND ((OR (AND (EQ FAMILYCODE  (\BIN WSTRM)) (EQ FACECODE  (\BIN WSTRM))) DONTCHECK)  (* ;  "This is the right family/face (DONTCHECK must come last, so the file reads get done.)")  (replace FIRSTCHAR of FD with  (\BIN WSTRM)) (replace LASTCHAR of FD  with (\BIN WSTRM)) (COND  ((AND (OR (ZEROP (SETQ SIZE  (\WIN WSTRM))) (LESSP  (ABS (FQUOTIENT (IDIFFERENCE  (OR PRESSMICASIZE NSMICASIZE) SIZE)  PRESSMICASIZE)) FUZZ))  (EQ ROTATION (\WIN WSTRM)))  (replace \SFFACECODE of FD with  FACECODE) (RETURN SIZE))))))  (0 (RETURN NIL)) NIL)  (SETFILEPTR WSTRM NEXT))) (HELP]) ) (RPAQ? INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>")) (DECLARE%: EVAL@COMPILE (PUTPROPS \POSITIONFONTFILE MACRO ((WSTRM NSMICASIZE FIRSTCHAR LASTCHAR FAMILY FACECODE) (* gbn "25-Jul-85 02:15") (* ;  "sets FIRSTCHAR LASTCHAR, and positions the file correctly") (* ;; "Finds the widths information for the specified FAMILY, FACECODE, MSIZE, and ROTATION. FIRSTCHAR and LASTCHAR are passed in since we have to read past those to check the size. If successful, returns the size found in the widths file, with zero indicating that dimensions in the widths file are relative, leaving the file pointing just after the Rotation word of the font. --- --- Returns NIL if the font is not found") (bind TYPE LENGTH SIZE FAMCODE FILEFAM FILEFACE (NEXT _ 0) first (OR (SETQ FAMCODE (\FAMILYCODE (OR FAMILY T) WSTRM)) (RETURN NIL)) do (SETQ TYPE (\BIN WSTRM)) (SETQ LENGTH (\BIN WSTRM)) (add NEXT (LLSH (IPLUS LENGTH (LLSH (LOGAND TYPE 15) 8)) 1)) (SELECTQ (LRSH TYPE 4) (4 (SETQ FILEFAM (\BIN WSTRM)) (SETQ FILEFACE (\BIN WSTRM)) (* ; "This is the right family/face") [COND ((OR (EQ FAMILY T) (EQ FAMILY NIL) (AND (IEQP FILEFAM FAMCODE) (IEQP FILEFACE FACECODE))) (SETQ FIRSTCHAR (\BIN WSTRM)) (SETQ LASTCHAR (\BIN WSTRM)) (COND ((AND (OR (ZEROP (SETQ SIZE (\WIN WSTRM))) (LESSP (ABS (FQUOTIENT (IDIFFERENCE NSMICASIZE SIZE) NSMICASIZE)) 0.02)) (ZEROP (\WIN WSTRM))) (RETURN SIZE]) (0 (RETURN NIL)) NIL) (SETFILEPTR WSTRM NEXT)))) ) (PUTPROPS AFONT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2792 38939 (\CREATESTARFONT 2802 . 4480) (\READACFONTBOXES 4482 . 6709) ( \READACFONTFILE 6711 . 18604) (\ACCHARIMAGELIST 18606 . 18963) (\ACCHARWIDTHLIST 18965 . 20231) ( \GETFBB 20233 . 23513) (\ACCHARPOSLIST 23515 . 24565) (\ACROTATECHAR 24567 . 25131) (\READFONTWDFILE 25133 . 33166) (\FACECODE 33168 . 33762) (\FAMILYCODE 33764 . 35068) (\FINDFONT 35070 . 38937))))) STOP \ No newline at end of file diff --git a/sources/AINTERRUPT b/sources/AINTERRUPT new file mode 100644 index 00000000..04a653c6 --- /dev/null +++ b/sources/AINTERRUPT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-Sep-92 10:42:38" "{Pele:mv:envos}Sources>AINTERRUPT.;4" 41128 |changes| |to:| (FNS INTCHAR GETINTERRUPT) |previous| |date:| "28-Jun-90 18:45:07" "{Pele:mv:envos}Sources>AINTERRUPT.;3") ; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT AINTERRUPTCOMS) (RPAQQ AINTERRUPTCOMS ((COMS (* \; "handling interrupts") (FNS INTCHAR INTERRUPTCHAR INTERRUPTED LISPINTERRUPTS \\DOHELPINTERRUPT \\DOHELPINTERRUPT1 \\DOINTERRUPTHERE \\PROC.FINDREALFRAME \\SETPRINTLEVEL \\SETRECLAIMMIN GETINTERRUPT CURRENTINTERRUPTS SETINTERRUPT RESET.INTERRUPTS INTERRUPTABLE)) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (INTCHAR T))) (COMS (* |;;| "^T this is actually not very useful any more, and the percentages are wrong") (FNS CONTROL-T \\CONTROL-T.PRINTRATIO) (INITVARS (\\CONTROL-T.DEPTH 3) (\\CONTROL-T.BACKSLASH) (LAST^TTIMEBOX (CLOCK 0)) (LAST^TSWAPTIME) (LAST^TDISKIOTIME 0) (LAST^TGCTIME 0) (LAST^TNETIOTIME 0)) (GLOBALVARS \\CONTROL-T.DEPTH \\CONTROL-T.BACKSLASH LAST^TTIMEBOX LAST^TSWAPTIME LAST^TDISKIOTIME LAST^TNETIOTIME LAST^TGCTIME \\MISCSTATS) (ADDVARS (\\SYSTEMCACHEVARS LAST^TSWAPTIME))) (INITVARS (\\CURRENTINTERRUPTS) (\\INTERRUPTABLE) (INTERRUPTMENUFONT)) (ADDVARS (FONTVARS (INTERUPTMENUFONT DEFAULTFONT T))) (VARS \\SYSTEMINTERRUPTS) (DECLARE\: EVAL@COMPILE DONTCOPY (ADDVARS (NOFIXFNSLST CONTROL-T)) (LOCALVARS . T) (GLOBALVARS \\CURRENTINTERRUPTS \\SYSTEMINTERRUPTS INTERRUPTMENUFONT)) (DECLARE\: EVAL@COMPILE (EXPORT (ADDVARS (SYSSPECVARS \\INTERRUPTABLE)) (PROP INFO UNINTERRUPTABLY) (PROP DMACRO UNINTERRUPTABLY) (ALISTS (PRETTYPRINTMACROS UNINTERRUPTABLY))) DONTCOPY (EXPORT (RECORDS INTERRUPTSTATE) (PROP DMACRO \\TAKEINTERRUPT)) (MACROS \\SYSTEMINTERRUPTP)))) (* \; "handling interrupts") (DEFINEQ (INTCHAR (LAMBDA (CHAR TYP/FORM HARDFLG TABLE) (* \; "Edited 17-Sep-92 10:41 by jds") (* |;;| "this function is the non-undoable version of INTERRUPTCHAR; INTERRUPTCHAR calls it") (PROG (VAL SYSDEF OLDINT) (SELECTQ CHAR (NIL (* \;  "this is illegal, so don't do anything about it") (RETURN)) (T (* \;  "(INTCHAR T) means restore interrupts to the 'standard' setting") (UNINTERRUPTABLY (|for| CHAR |in| (GETINTERRUPT NIL TABLE) |do| (SETQ VAL (NCONC (INTCHAR CHAR NIL NIL TABLE) VAL))) (* \;  "turn off all user interrupts --- (GETINTERRUPT) returns list of user interrupts") (MAPC (LISPINTERRUPTS) (FUNCTION (LAMBDA (LST) (SETQ VAL (NCONC (INTCHAR (CAR LST) (CADR LST) (CADDR LST) TABLE) VAL))))) (* |;;| "and reset all SYSTEM interrupts to default --- (LISPINTERRUPTS) returns a list of argument lists for INTCHAR") (* \;  "and VAL has been set to a valid arg list for INTCHAR") (RETURN VAL))) NIL) (COND ((LISTP CHAR) (* \;  "Call from undoing or resetform. CHAR is a list of characters followed by typ/form arguments.") (|while| CHAR |do| (SETQ VAL (NCONC (INTCHAR (|pop| CHAR) (|pop| CHAR) (|pop| CHAR) TABLE) VAL))) (RETURN VAL))) (COND ((NOT (FIXP CHAR)) (COND ((\\SYSTEMINTERRUPTP CHAR) (* |;;| "CHAR can be an interrupt character class, meaning the character which is currently assigned to that interrupt --- this is most useful in, say, (INTCHAR (QUOTE HELP)) which says turn off the character whose class is HELP") (SETQ CHAR (OR (GETINTERRUPT CHAR TABLE) (ERRORX (LIST 27 CHAR))))) (T (* \;  "turn single character into character code") (SETQ CHAR (APPLY* 'CHARCODE CHAR)))))) (SETQ VAL (AND (SETQ OLDINT (GETINTERRUPT CHAR TABLE)) (LIST CHAR (CAR OLDINT) (CADR OLDINT)))) (COND ((EQ TYP/FORM T) (* \;  "just return value indicating what it was.") (RETURN VAL)) ((AND TYP/FORM (LITATOM TYP/FORM) (SETQ SYSDEF (ASSOC TYP/FORM \\SYSTEMINTERRUPTS))) (* \;  "System interrupt -- get its default HARDFLG") (OR HARDFLG (SETQ HARDFLG (CADR SYSDEF))))) (COND ((AND (EQ (CAR OLDINT) TYP/FORM) (EQ (CADR OLDINT) HARDFLG)) (* \;  "if the character is already set up, just return") (RETURN))) (COND (OLDINT (SETINTERRUPT CHAR NIL TABLE))) (COND ((NULL TYP/FORM) (* \; "just leave character disabled") ) (T (* \; "make a user interrupt") (COND ((AND SYSDEF (SETQ OLDINT (GETINTERRUPT TYP/FORM TABLE))) (* |;;| "if a system interrupt and there is another character assigned to that channel, turn that character off") (SETINTERRUPT OLDINT NIL TABLE) (|push| VAL OLDINT TYP/FORM NIL))) (SETINTERRUPT CHAR TYP/FORM TABLE HARDFLG) (|push| VAL CHAR NIL NIL))) (RETURN VAL)))) (interruptchar (lambda (char typ/form hardflg table) (* |lmm| "14-May-85 16:56") (prog ((val (intchar char typ/form hardflg table))) (and lispxhist (undosave (list 'interruptchar val nil nil table))) (return val)))) (INTERRUPTED (LAMBDA NIL (* \; "Edited 28-Jun-90 18:43 by jds") (* |;;| "This function gets control whenever an \"interrupt\" of some sort is signalled to Lisp, apart from the timer and keyboard-I/O handling interrupts. It dispatches to the proper handler routine for the \"hard-wired\" interrupt types, and signals the appropriate soft interrupt for interrupt characters.") (DECLARE (GLOBALVARS \\INTERRUPTSTATE) (USEDFREE \\MOUSEBUSY \\INTERRUPTABLE)) (COND ((NULL \\INTERRUPTABLE) (SETQ \\PENDINGINTERRUPT T) (|replace| (INTERRUPTSTATE IN-PROGRESS) |of| \\INTERRUPTSTATE |with| 0)) (T (COND ((|fetch| (INTERRUPTSTATE ETHERINTERRUPT) |of| \\INTERRUPTSTATE) (\\MAIKO.ETHER-INTERRUPT) (|replace| (INTERRUPTSTATE P-ETHERINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE LOGMSGSPENDING) |of| \\INTERRUPTSTATE) (\\MAIKO.CONSOLE-LOG-PRINT) (|replace| (INTERRUPTSTATE P-LOGMSGSPENDING) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE IOINTERRUPT) |of| \\INTERRUPTSTATE) (\\MAIKO.IO-INTERRUPT) (|replace| (INTERRUPTSTATE P-IOINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL))) (COND ((|fetch| (INTERRUPTSTATE STORAGEFULL) |of| \\INTERRUPTSTATE) (\\DOSTORAGEFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-STORAGEFULL) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE STACKOVERFLOW) |of| \\INTERRUPTSTATE) (\\DOSTACKFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-STACKOVERFLOW) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE VMEMFULL) |of| \\INTERRUPTSTATE) (\\DOVMEMFULLINTERRUPT) (|replace| (INTERRUPTSTATE P-VMEMFULL) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE GCDISABLED) |of| \\INTERRUPTSTATE) (\\DOGCDISABLEDINTERRUPT) (|replace| (INTERRUPTSTATE P-GCDISABLED) |of| \\INTERRUPTSTATE |with| NIL)) ((|fetch| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE) (LET* ((CH (|fetch| (INTERRUPTSTATE INTCHARCODE) |of| \\INTERRUPTSTATE)) (INTERRUPT (CDR (ASSOC CH (|fetch| (KEYACTION INTERRUPTLIST) |of| \\CURRENTKEYACTION ))))) (|replace| (INTERRUPTSTATE INTCHARCODE) |of| \\INTERRUPTSTATE |with| 0) (COND (INTERRUPT (LET* ((CLASS (CAR INTERRUPT)) (HARDFLG (CADR INTERRUPT)) (THISPROC (THIS.PROCESS)) (INTERRUPTED.PROC (COND ((OR (NULL THISPROC) (EQ HARDFLG T)) THISPROC) ((EQ HARDFLG 'MOUSE) (LET ((MP THISPROC)) (* \;  "Interrupt MOUSE proc if it's busy, else the tty process") (COND ((COND ((EQ (PROCESSPROP MP 'NAME) 'MOUSE) \\MOUSEBUSY) ((SETQ MP (FIND.PROCESS 'MOUSE)) (PROCESS.EVALV MP '\\MOUSEBUSY))) MP) (T (TTY.PROCESS))))) ((EQ HARDFLG 'WHICHW) (* \;  "Interrupt the process that owns the window the mouse is in") (AND (GETD 'WHICHW) (LET ((W (WHICHW))) (AND W (WINDOWPROP W 'PROCESS))))) (T (TTY.PROCESS))))) (COND ((EQ THISPROC INTERRUPTED.PROC) (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (\\DOINTERRUPTHERE CLASS) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL)) ((NULL INTERRUPTED.PROC) (* \;  "Nobody qualified, so dismiss interrupt") (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) NIL) ((\\PROCESS.MAKEFRAME INTERRUPTED.PROC (FUNCTION \\DOINTERRUPTHERE) (LIST CLASS CH HARDFLG)) (|replace| (INTERRUPTSTATE WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (|replace| (INTERRUPTSTATE P-WAITINGINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL)) (T (* \;  "Couldn't build frame, so leave interrupt pending") (SETQ \\PENDINGINTERRUPT T))))))))))))) (lispinterrupts (lambda nil (* |jds| "30-Sep-85 12:35") (* * |Returns| \a |list| |of| |the| "standard" |interrupt-character|  |settings| |for| |Interlisp-D.| |These| |are| |used,| |e.g.,| |in| intchar  |to| |reset| |things| |to| |the| |default| |state.|) '((2 break mouse) (4 reset mouse) (5 error mouse) (7 help t) (16 printlevel) (20 (control-t)) (127 rubout t)))) (\\dohelpinterrupt (lambda nil (* |bvm:| "27-JUL-83 18:37") (prog (proc) (cond ((null (this.process)) (flashwindow) (\\dohelpinterrupt1)) ((null (setq proc (progn (flashwindow) (\\selectprocess "Interrupt which process?")))) (* |Interrupt| |declined|) nil) ((eq proc (this.process)) (\\dohelpinterrupt1)) ((\\process.makeframe proc (function \\dohelpinterrupt1))) (t (* |Couldn't| |build| |frame,| |so|  |leave| |interrupt| |pending|) (setq \\pendinginterrupt t)))))) (\\dohelpinterrupt1 (lambda nil (* |bvm:| "11-AUG-83 11:56") (* |Does| help/break |interrupt| |in| |the| |current| |process.|  w\e |treat| ^b |same| |as| ^h\, |except| |that| |former| |always| |occurs|  |in| |tty| |process.| break |interrupt| |used| |to| |just| |do| \a  (errorx (list 18 nil)) |instead| |of| |calling| interrupt) (cond ((null \\interruptable) (* |Unlikely,| |but| |could| |occur|  |if| |someone| |blocked| |while|  |uninterruptable|) (flashwindow)) (t (prog (oldtty) (or (tty.processp) (setq oldtty (tty.process (this.process)))) (cond ((eq (|fetch| procname |of| (this.process)) 'mouse) (spawn.mouse (this.process)))) (clearbuf t t) (* |Find| |name| |of| \a |real| |frame| |before| interrupted\, |so| |break|  |message| |can| |be| |nice.|) (interrupt (\\proc.findrealframe) nil 2) (cond (oldtty (tty.process oldtty)))))))) (\\dointerrupthere (lambda (class) (declare (usedfree \\interruptable)) (* |bvm:| "18-Jul-85 12:37") (* * |Perform| |the| class |interrupt| |in| |the| |currently| |running|  |process|) (cond ((not \\interruptable) (setq \\pendinginterrupt t)) (t (selectq class (reset (\\clearsysbuf t) (reset)) (error (\\clearsysbuf t) (seterrorn 47) (error!)) (help (* |Does| \a ^b |in| |process|  |selected| |by| |user|) (\\dohelpinterrupt)) (break (\\dohelpinterrupt1)) (control-t (control-t)) (storage (\\setreclaimmin)) (printlevel (\\setprintlevel)) (rubout (flashwindow) (\\clearsysbuf t)) (raid (raid)) (cond ((litatom class) (set class t)) (t (\\eval class)))))))) (\\proc.findrealframe (lambda (pos) (* |bvm:| "18-Jul-85 13:00") (* |Returns| |the| |name| |of| |the| |first| |interesting| |frame| |before|  pos\, |or| |the| |caller| |if| pos = nil) (|for| i |from| (cond (pos 0) (t -2)) |by| -1 |do| (selectq (setq $$val (stknthname i pos)) ((interrupted \\interruptframe \\interrupted \\dohelpinterrupt \\dohelpinterrupt1 \\dobufferedtransitions \\dointerrupthere \\process.go.to.sleep block await.event monitor.await.event getmousestate) nil) (return $$val))))) (\\setprintlevel (lambda nil (* |lmm| "30-Dec-85 17:08") (declare (globalvars \\tcarprintlevel \\tcdrprintlevel)) (prog (buf olb osb carn) (\\bout \\term.ofd (charcode bell)) (setq olb (linbuf t)) (setq osb (sysbuf t)) (clearbuf t t) (prin3 "set printlevel to: " t) (prog ((n 0) ch) lp (selcharq (setq ch (\\getchar)) ((0 1 2 3 4 5 6 7 8 9) (setq n (iplus (itimes n 10) (idifference ch (charcode 0)))) (go lp)) ((\. !) (* carn |is| |set| |if| |we've|  |already| |seen| \a |comma|) (cond (carn (setq \\tcarprintlevel carn) (setq \\tcdrprintlevel n)) (t (setq \\tcarprintlevel n))) (cond ((eq ch (charcode !)) (* |Make| |it| |permanent|) (printlevel \\tcarprintlevel \\tcdrprintlevel)))) (\, (cond ((not carn) (setq carn n) (* |This| |is| |the| |first| |comma|) (setq n 0) (go lp)))) nil) (* |Restore| |buffers| |cleared|  |with| clearbuf) ) (cond ((setq buf (sysbuf t)) (bksysbuf buf))) (setq \\sysbuf osb) (and (setq buf (linbuf t)) (linbuf)) (setq \\linbuf olb)))) (\\setreclaimmin (lambda nil (* |lmm| "30-Dec-85 17:08") (prog (buf olb osb ch) (\\bout \\term.ofd (charcode bell)) (setq olb (linbuf t)) (setq osb (sysbuf t)) (clearbuf t t) (prin3 "set RECLAIMMIN to: " t) (prog ((n 0)) lp (selcharq (setq ch (\\getchar)) ((0 1 2 3 4 5 6 7 8 9) (setq n (iplus (itimes n 10) (idifference ch (charcode 0)))) (go lp)) (\. (reclaimmin n)) nil)) (cond ((setq buf (sysbuf t)) (bksysbuf buf))) (setq \\sysbuf osb) (and (setq buf (linbuf t)) (linbuf)) (setq \\linbuf olb)))) (GETINTERRUPT (LAMBDA (CHAR TABLE) (* \; "Edited 17-Sep-92 10:41 by jds") (* |;;| "Return the interrupt, if any, defined for CHAR in keyaction table TABLE.") (* |;;| "NIL => all user interrupts") (* |;;| "T => all system interrupts") (OR TABLE (SETQ TABLE \\CURRENTKEYACTION)) (SELECTQ CHAR (NIL (* \; "Non-system interrupts") (|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) TABLE) |unless| (\\SYSTEMINTERRUPTP (CADR X)) |collect| (CAR X))) (T (* \; "All system interrupts") (|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) TABLE) |collect| (CAR X))) (COND ((NUMBERP CHAR) (CDR (FASSOC CHAR (|fetch| (KEYACTION INTERRUPTLIST) TABLE)))) (T (|for| X |in| (|fetch| (KEYACTION INTERRUPTLIST) TABLE) |when| (EQ CHAR (CADR X)) |do| (* \; "Find CHAR in system class.") (RETURN (CAR X)))))))) (currentinterrupts (lambda (table) (* |bvm:| "18-Jul-85 12:37") (append (|fetch| (keyaction interruptlist) |of| (or table \\currentkeyaction))))) (setinterrupt (lambda (char class table hardflg) (* \; "Edited 20-Nov-87 11:00 by Snow") (or table (setq table \\currentkeyaction)) (let (tem) (* |;;| "This code assumes that the variable (FETCH (KEYACTION INTERRUPTLIST) TABLE) is an alist of the form ((CHAR CLASS)(CHAR CLASS) etc.)") (cond ((null char) (* \; "some mistake") nil) ((\\systeminterruptp char) (* \;  "If this is a system interrupt, then this is turning it off") (setinterrupt (getinterrupt char table) nil table)) ((setq tem (fassoc char (|fetch| (keyaction interruptlist) table))) (* \; "CHAR is currently an interrupt") (cond ((and (eq (cadr tem) class) (eq (caddr tem) hardflg)) (* \; "No change") nil) ((null class) (* \;  "REMOVE FROM INTERRUPT CHARACTER SET") (|change| (|fetch| (keyaction interruptlist) table) (dremove tem datum))) (t (* \; "Assign new interrupt to CHAR") (|change| (cdr tem) (list class hardflg))))) ((null class)) (t (* \; "Brand new interrupt") (|push| (|fetch| (keyaction interruptlist) table) (list char class hardflg))))))) (reset.interrupts (lambda (|PermittedInterrupts| |SaveCurrent?|) (declare (globalvars \\currentkeyaction)) (* \; "Edited 20-Nov-87 10:44 by Snow") (* |;;| "Returns list of previous settings, for use by RESETFORM but only when 2nd arg is non-NIL. --- PermittedInterrupts is a list of triples of the form (charcode interrupt hardness)") (cond (|PermittedInterrupts| (setq |PermittedInterrupts| (|for| triple |in| |PermittedInterrupts| |collect| (cond ((or (nlistp triple) (not (charcodep (car triple))) (nlistp (cdr triple))) (\\illegal.arg |PermittedInterrupts|)) ((nlistp (cddr triple)) (* \;  "Not a triple, so default the hardness to system hardness") (list (car triple) (cadr triple) (cadr (assoc (cadr triple) \\systeminterrupts)))) (t triple)))))) (uninterruptably (prog1 (and |SaveCurrent?| (|fetch| (keyaction interruptlist) |of| \\currentkeyaction )) (|replace| (keyaction interruptlist) |of| \\currentkeyaction |with| |PermittedInterrupts| ))))) (interruptable (lambda (flag) (* |lmm| "18-APR-82 13:52") (prog1 \\interruptable (setq \\interruptable flag)))) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (INTCHAR T) ) (* |;;| "^T this is actually not very useful any more, and the percentages are wrong") (DEFINEQ (control-t (lambda (pos out) (* \; "Edited 6-Dec-86 04:57 by lmm") (or out (setq out (getstream promptwindow 'output))) (|if| (and (hasttywindowp) (neq (ttydisplaystream) out) (wfromds (ttydisplaystream)) (openwp (wfromds (ttydisplaystream)))) |then| (flashwindow (ttydisplaystream) 1 10)) (uninterruptably (* \;  "UNINTERRUPTABLY only so you can't type ^T during ^T") (prog ((stki (cond ((stackp pos) 0) (t (setq pos 'control-t) -3))) temp swapdelta netiodelta diskiodelta gcdelta keyboarddelta totaldelta) (setq temp (stknthname stki pos)) (printout out "Process: " (process.name (this.process)) ", ") (|printout| out (|do| (selectq temp ((\\interruptframe \\interrupted interrupted \\dointerrupthere) (* \; "Skip over these") (setq temp (stknthname (|add| stki -1) pos))) ((\\getchar \\getkey \\ttybackground) (setq temp (stknthname (|add| stki -1) pos)) (setq $$val "wait in ")) ((block \\background await.event monitor.await.event \\process.go.to.sleep) (* \; "Forms of blocking") (setq temp (stknthname (|add| stki -1) pos)) (setq $$val "waiting in ")) (return (or $$val "in "))))) (|bind| (cnt _ 0) |do| (cond ((xcl::interesting-frame-p temp) (prin2 temp out t) (cond ((eq (|add| cnt 1) \\control-t.depth) (return)) (t (|printout| out " in "))))) (setq temp (stknthname (|add| stki -1) pos))) (cond ((null last^tswaptime) (* \; "Just initialize the first time") (setq last^ttimebox (clock)) (setq last^tdiskiotime (|fetch| diskiotime |of| \\miscstats)) (setq last^tnetiotime (|fetch| netiotime |of| \\miscstats)) (setq last^tgctime (|fetch| gctime |of| \\miscstats)) (setq last^tswaptime (|fetch| swapwaittime |of| \\miscstats))) (t (* |;;| "calculates the amount of time spent not in disk wait since the last control-T. Considers only time outside of key board wait.") (setq totaldelta (iplus (iminus last^ttimebox) (setq last^ttimebox (\\clock0 last^ttimebox)))) (setq swapdelta (iplus (iminus last^tswaptime) (setq last^tswaptime (|fetch| swapwaittime |of| \\miscstats)))) (setq diskiodelta (iplus (iminus last^tdiskiotime) (setq last^tdiskiotime (|fetch| diskiotime |of| \\miscstats)))) (setq netiodelta (iplus (iminus last^tnetiotime) (setq last^tnetiotime (|fetch| netiotime |of| \\miscstats) ))) (setq gcdelta (iplus (iminus last^tgctime) (setq last^tgctime (|fetch| gctime |of| \\miscstats) ))) (\\control-t.printratio swapdelta totaldelta "% Swap" nil out) (\\control-t.printratio diskiodelta totaldelta "% DskIO" nil out) (\\control-t.printratio netiodelta totaldelta "% Network" nil out) (\\control-t.printratio gcdelta totaldelta "% GC" nil out))) (terpri out))))) (\\control-t.printratio (lambda (n total label newline stream) (* \; "Edited 4-Dec-86 21:13 by lmm") (cond ((neq n 0) (cond (newline (terpri stream)) (t (|printout| stream ", "))) (cond ((or (igreaterp n total) (ilessp n 0)) (|printout| stream "??")) (t (|printout| stream |.I2| (iquotient (itimes n 100) total)))) (|printout| stream label))))) ) (RPAQ? \\CONTROL-T.DEPTH 3) (RPAQ? \\CONTROL-T.BACKSLASH ) (RPAQ? LAST^TTIMEBOX (CLOCK 0)) (RPAQ? LAST^TSWAPTIME ) (RPAQ? LAST^TDISKIOTIME 0) (RPAQ? LAST^TGCTIME 0) (RPAQ? LAST^TNETIOTIME 0) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\CONTROL-T.DEPTH \\CONTROL-T.BACKSLASH LAST^TTIMEBOX LAST^TSWAPTIME LAST^TDISKIOTIME LAST^TNETIOTIME LAST^TGCTIME \\MISCSTATS) ) (ADDTOVAR \\SYSTEMCACHEVARS LAST^TSWAPTIME) (RPAQ? \\CURRENTINTERRUPTS ) (RPAQ? \\INTERRUPTABLE ) (RPAQ? INTERRUPTMENUFONT ) (ADDTOVAR FONTVARS (INTERUPTMENUFONT DEFAULTFONT T)) (RPAQQ \\SYSTEMINTERRUPTS ((BREAK MOUSE) (CONTROL-T) (ERROR MOUSE) (ERRORX) (HELP T) (OUTPUTBUFFER T) (PRINTLEVEL) (RAID T) (RESET MOUSE) (RUBOUT T) (STORAGE))) (DECLARE\: EVAL@COMPILE DONTCOPY (ADDTOVAR NOFIXFNSLST CONTROL-T) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\CURRENTINTERRUPTS \\SYSTEMINTERRUPTS INTERRUPTMENUFONT) ) ) (DECLARE\: EVAL@COMPILE (* "FOLLOWING DEFINITIONS EXPORTED") (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 ")")))) (* "END EXPORTED DEFINITIONS") DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: EVAL@COMPILE (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)))) (* "END EXPORTED DEFINITIONS") (DECLARE\: EVAL@COMPILE (PUTPROPS \\SYSTEMINTERRUPTP MACRO ((KEY) (ASSOC KEY \\SYSTEMINTERRUPTS))) ) ) (PUTPROPS AINTERRUPT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1989 1990 1992)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2572 28843 (INTCHAR 2582 . 7650) (INTERRUPTCHAR 7652 . 7926) (INTERRUPTED 7928 . 15507) (LISPINTERRUPTS 15509 . 16026) (\\DOHELPINTERRUPT 16028 . 16926) (\\DOHELPINTERRUPT1 16928 . 18326) ( \\DOINTERRUPTHERE 18328 . 19508) (\\PROC.FINDREALFRAME 19510 . 20314) (\\SETPRINTLEVEL 20316 . 22268) (\\SETRECLAIMMIN 22270 . 23143) (GETINTERRUPT 23145 . 24519) (CURRENTINTERRUPTS 24521 . 24731) ( SETINTERRUPT 24733 . 26711) (RESET.INTERRUPTS 26713 . 28670) (INTERRUPTABLE 28672 . 28841)) (28991 34975 (CONTROL-T 29001 . 34442) (\\CONTROL-T.PRINTRATIO 34444 . 34973))))) STOP \ No newline at end of file diff --git a/sources/AOFD b/sources/AOFD new file mode 100644 index 00000000..996529d5 --- /dev/null +++ b/sources/AOFD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "13-Sep-90 16:39:58" |{PELE:MV:ENVOS}SOURCES>AOFD.;4| 34722 changes to%: (FNS \BASEBYTES.IO.INIT \BASEBYTES.SETFILEPTR) previous date%: "16-May-90 12:01:06" |{PELE:MV:ENVOS}SOURCES>AOFD.;3|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT AOFDCOMS) (RPAQQ AOFDCOMS [ (* ;;; "streams (= OpenFileDescriptors)") (COMS (FNS \ADD-OPEN-STREAM \GENERIC-UNREGISTER-STREAM) (INITVARS (*ISSUE-CLOSE-WARNINGS* NIL)) (FNS CLOSEALL CLOSEF EOFCLOSEF INPUT OPENP OUTPUT POSITION RANDACCESSP \IOMODEP WHENCLOSE) (FNS STREAMADDPROP) (INITVARS (DEFAULTEOFCLOSE 'NILL) (\OPENFILES)) (GLOBALVARS DEFAULTEOFCLOSE \OPENFILES)) (COMS (* ;; "STREAM interface to Read and Write to random memory") (DECLARE%: DONTCOPY (EXPORT (RECORDS BASEBYTESTREAM))) (FNS \BASEBYTES.IO.INIT \MAKEBASEBYTESTREAM \MBS.OUTCHARFN \BASEBYTES.NAME.FROM.STREAM \BASEBYTES.BOUT \BASEBYTES.SETFILEPTR \BASEBYTES.READP \BASEBYTES.BIN \BASEBYTES.PEEKBIN \BASEBYTES.TRUNCATEFN \BASEBYTES.OPENFN \BASEBYTES.BLOCKIO) (GLOBALVARS \BASEBYTESDEVICE) (DECLARE%: DONTEVAL@LOAD (P (\BASEBYTES.IO.INIT))) (FNS OPENSTRINGSTREAM)) [COMS (* ;; "STREAM interface for old-style strings") (FNS \STRINGSTREAM.INIT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\STRINGSTREAM.INIT] (COMS (FNS GETSTREAM \ADDOFD \CLEAROFD \DELETEOFD \GETSTREAM \SEARCHOPENFILES) (DECLARE%: DONTCOPY (EXPORT (MACROS \INSTREAMARG \OUTSTREAMARG \STREAMARG))) (MACROS GETOFD \GETOFD)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA WHENCLOSE]) (* ;;; "streams (= OpenFileDescriptors)") (DEFINEQ (\ADD-OPEN-STREAM [LAMBDA (DEVICE STREAM) (* hdj "28-May-86 11:22") (if (NOT (STREAMP STREAM)) then (\ILLEGAL.ARG STREAM)) (pushnew (fetch (FDEV OPENFILELST) of DEVICE) STREAM) STREAM]) (\GENERIC-UNREGISTER-STREAM [LAMBDA (DEVICE STREAM) (* hdj "22-Sep-86 18:30") (* ;;; "Remove an open stream from the list of streams kept by DEVICE. Assumes the use of the FDEV's OPENFILELSTto store the streams. Errors if passed a stream the device doesn't know about if *ISSUE-CLOSE-WARNINGS* is non-NIL.") (DECLARE (GLOBALVARS *ISSUE-CLOSE-WARNINGS*)) (if (NOT (STREAMP STREAM)) then (\ILLEGAL.ARG STREAM)) (LET ((OPENFILELST (fetch (FDEV OPENFILELST) of DEVICE))) (if (AND *ISSUE-CLOSE-WARNINGS* (NOT (FMEMB STREAM OPENFILELST))) then (ERROR "Closing a stream that's not open!" STREAM)) (replace (FDEV OPENFILELST) of DEVICE with (DREMOVE STREAM OPENFILELST)) STREAM]) ) (RPAQ? *ISSUE-CLOSE-WARNINGS* NIL) (DEFINEQ (CLOSEALL [LAMBDA (ALLFLG) (DECLARE (LOCALVARS . T)) (* hdj "11-Jul-86 10:33") (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then (ERROR "CLOSEALL no longer supported") else (for STREAM in (PROG1 (APPEND \OPENFILES) (* ; "Need to APPEND because CLOSEF will remove things from \OPENFILES") ) when [AND (fetch USERVISIBLE of STREAM) (\IOMODEP STREAM NIL T) (OR ALLFLG (NOT (STREAMPROP STREAM 'CLOSEALL] collect (CLOSEF STREAM]) (CLOSEF [LAMBDA (FILE) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG ((STREAM (\GETSTREAM FILE))) (COND ((OR (\OUTTERMP STREAM) (NOT (fetch USERCLOSEABLE of STREAM))) (RETURN NIL))) [MAPC (STREAMPROP STREAM 'BEFORECLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (\CLEAROFD) (COND ((EQ STREAM *STANDARD-INPUT*) (SETQ *STANDARD-INPUT* \LINEBUF.OFD))) (COND ((EQ STREAM *STANDARD-OUTPUT*) (SETQ *STANDARD-OUTPUT* \TERM.OFD))) (AND (NOT MULTIPLE.STREAMS.PER.FILE.ALLOWED) (\DELETEOFD STREAM)) (* ;; "Logical close before physical close; otherwise, we might have a logically open file with no physically open file behind it. (Device LPT depends on this)") (\CLOSEFILE STREAM) [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (RETURN (fetch FULLNAME of STREAM]) (EOFCLOSEF [LAMBDA (FILE) (* bvm%: "15-Jan-85 17:58") (DECLARE (LOCALVARS . T)) (PROG ((STREAM (GETSTREAM FILE))) (APPLY* (OR (STREAMPROP STREAM 'EOFCLOSE) DEFAULTEOFCLOSE) STREAM]) (INPUT [LAMBDA (FILE) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG1 (if (EQ *STANDARD-INPUT* \LINEBUF.OFD) then T else (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then *STANDARD-INPUT* else (fetch FULLNAME of *STANDARD-INPUT*))) (COND (FILE (SETQ *STANDARD-INPUT* (COND ((EQ FILE T) (* ; "Check explicitly for T to avoid needless creations") \LINEBUF.OFD) (T (\GETSTREAM FILE 'INPUT]) (OPENP [LAMBDA (FILE ACCESS) (* hdj "29-Sep-86 17:41") (DECLARE (GLOBALVARS MULTIPLE.STREAMS.PER.FILE.ALLOWED \FILEDEVICES)) (if (AND FILE (type? STREAM FILE)) then (\GETSTREAM FILE ACCESS T) elseif FILE then NIL else (\MAP-OPEN-STREAMS (FUNCTION EVQ) \FILEDEVICES NIL]) (OUTPUT [LAMBDA (FILE) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG1 (if (EQ *STANDARD-OUTPUT* \TERM.OFD) then T else (if MULTIPLE.STREAMS.PER.FILE.ALLOWED then *STANDARD-OUTPUT* else (fetch FULLNAME of *STANDARD-OUTPUT*))) (COND (FILE (SETQ *STANDARD-OUTPUT* (COND ((EQ FILE T) (* ; "Check for this special so we don't create a tty window needlessly") \TERM.OFD) (T (\GETSTREAM FILE 'OUTPUT]) (POSITION [LAMBDA (FILE N) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG [(STRM (COND (FILE (\GETSTREAM FILE)) (T *STANDARD-OUTPUT*] (RETURN (PROG1 (fetch CHARPOSITION of STRM) (COND (N (replace CHARPOSITION of STRM with (COND ((IGREATERP N 0) N) (T (* ; "compatible with PDP-10 version") 0]) (RANDACCESSP [LAMBDA (FILE) (* rmk%: "14-OCT-83 15:32") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (AND (fetch RANDOMACCESSP of (fetch DEVICE of STREAM)) (NEQ STREAM \LINEBUF.OFD) (fetch FULLNAME of STREAM]) (\IOMODEP [LAMBDA (STREAM ACCESS NOERROR) (* rmk%: "21-OCT-83 11:10") (* ;; "Returns STREAM if it represents a File open with access mode ACCESS") (COND ([COND ((NOT ACCESS) (fetch ACCESS of STREAM)) ((EQ ACCESS (fetch ACCESS of STREAM))) [(EQ (fetch ACCESS of STREAM) 'BOTH) (FMEMB ACCESS '(INPUT OUTPUT] ((EQ (fetch ACCESS of STREAM) 'APPEND) (EQ ACCESS 'OUTPUT] STREAM) (T (\FILE.NOT.OPEN STREAM NOERROR]) (WHENCLOSE [LAMBDA NARGS (* lmm " 2-Sep-84 16:07") (DECLARE (LOCALVARS . T)) (PROG [(STREAM (AND (IGREATERP NARGS 0) (GETSTREAM (ARG NARGS 1] [for I FN from 2 to NARGS by 2 do [SETQ FN (AND (IGREATERP NARGS I) (ARG NARGS (ADD1 I] (SELECTQ (ARG NARGS I) (CLOSEALL [STREAMPROP STREAM 'CLOSEALL (SELECTQ FN (NO T) (YES NIL) (ERRORX (LIST 27 FN]) (BEFORE (COND (FN (STREAMADDPROP STREAM 'BEFORECLOSE FN T)))) (AFTER (COND (FN (STREAMADDPROP STREAM 'AFTERCLOSE FN T)))) (STATUS (STREAMPROP STREAM 'STATUSFN FN)) (EOF (STREAMPROP STREAM 'EOFCLOSE FN)) (ERRORX (LIST 27 (ARG NARGS I] (RETURN STREAM]) ) (DEFINEQ (STREAMADDPROP [LAMBDA (STREAM PROP VAL) (STREAMPROP STREAM PROP (CONS VAL (STREAMPROP STREAM PROP]) ) (RPAQ? DEFAULTEOFCLOSE 'NILL) (RPAQ? \OPENFILES ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTEOFCLOSE \OPENFILES) ) (* ;; "STREAM interface to Read and Write to random memory") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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]) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\BASEBYTES.IO.INIT [LAMBDA NIL (DECLARE (GLOBALVARS \BASECHARDEVICE)) (* ; "Edited 13-Sep-90 16:27 by jds") (* ;; "Initialize the FDEV for base-bytes type devices (e.g. string streams).") (SETQ \BASEBYTESDEVICE (create FDEV DEVICENAME _ 'BASEBYTES RESETABLE _ T RANDOMACCESSP _ T PAGEMAPPED _ NIL FDBINABLE _ T FDBOUTABLE _ T FDEXTENDABLE _ NIL CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) GETFILEINFO _ (FUNCTION NILL) GETFILENAME _ (FUNCTION \BASEBYTES.NAME.FROM.STREAM) HOSTNAMEP _ (FUNCTION NILL) OPENFILE _ (FUNCTION \BASEBYTES.OPENFN) READPAGES _ (FUNCTION NILL) REOPENFILE _ [FUNCTION (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV STREAM) STREAM] SETFILEINFO _ (FUNCTION NILL) TRUNCATEFILE _ [FUNCTION (LAMBDA (STREAM I] WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) BIN _ (FUNCTION \BASEBYTES.BIN) BOUT _ (FUNCTION \BASEBYTES.BOUT) PEEKBIN _ (FUNCTION \BASEBYTES.PEEKBIN) READP _ (FUNCTION \BASEBYTES.READP) BACKFILEPTR _ [FUNCTION (LAMBDA (STREAM) (* ;; "Back up the file pointer") (AND (NEQ (fetch COFFSET of STREAM) (fetch BIASOFFST of STREAM)) (\PAGEDBACKFILEPTR STREAM)) (* ;; "And fix charposition.") (replace BBSNCHARS of STREAM with (IDIFFERENCE (fetch COFFSET of STREAM) (fetch BIASOFFST of STREAM] SETFILEPTR _ (FUNCTION \BASEBYTES.SETFILEPTR) GETFILEPTR _ [FUNCTION (LAMBDA (STREAM) (IDIFFERENCE (fetch COFFSET of STREAM) (fetch BIASOFFST of STREAM] GETEOFPTR _ [FUNCTION (LAMBDA (STREAM) (IDIFFERENCE (fetch EOFFSET of STREAM) (fetch BIASOFFST of STREAM] EOFP _ [FUNCTION (LAMBDA (STREAM) (IGEQ (fetch COFFSET of STREAM) (fetch EOFFSET of STREAM] BLOCKIN _ [FUNCTION (LAMBDA (STREAM BASE OFFST N) (\BASEBYTES.BLOCKIO STREAM BASE OFFST N 'INPUT] BLOCKOUT _ [FUNCTION (LAMBDA (STREAM BASE OFFST N) (\BASEBYTES.BLOCKIO STREAM BASE OFFST N 'OUTPUT] RENAMEFILE _ (FUNCTION \ILLEGAL.DEVICEOP))) (\DEFINEDEVICE NIL \BASEBYTESDEVICE]) (\MAKEBASEBYTESTREAM [LAMBDA (BASE OFFST LEN ACCESS WRITEXTENSIONFN OSTREAM) (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;; "If an error is to occur due to non-numeric arg or range restrictions, then let it happen outside the UNINTERRUPTABLY") (OR BASE (EQ LEN 0) (SHOULDNT)) (OR (AND (SMALLP OFFST) (SMALLP LEN) (SMALLP (add LEN OFFST))) (SHOULDNT "Currently can't support fixp-sized offsets")) (SELECTQ ACCESS (NIL (SETQ ACCESS 'INPUT)) ((INPUT OUTPUT BOTH)) (\ILLEGAL.ARG ACCESS)) (if (type? STREAM OSTREAM) then (if (EQ (ffetch (STREAM DEVICE) of OSTREAM) \BASEBYTESDEVICE) then (replace ACCESS of OSTREAM with NIL) else (CLOSEF OSTREAM) (SETQ OSTREAM (create BASEBYTESTREAM DEVICE _ \BASEBYTESDEVICE smashing OSTREAM))) else (SETQ OSTREAM (create BASEBYTESTREAM DEVICE _ \BASEBYTESDEVICE))) (UNINTERRUPTABLY (freplace USERCLOSEABLE of OSTREAM with NIL) (freplace USERVISIBLE of OSTREAM with NIL) (freplace BYTESIZE of OSTREAM with BITSPERBYTE) (freplace CPAGE of OSTREAM with (freplace EPAGE of OSTREAM with 0)) (freplace CBUFPTR of OSTREAM with BASE) (freplace COFFSET of OSTREAM with (freplace BIASOFFST of OSTREAM with OFFST)) (freplace CBUFSIZE of OSTREAM with (freplace EOFFSET of OSTREAM with LEN)) (replace ACCESS of OSTREAM with ACCESS) (* ;; "Insures that the BINABLE BOUTABLE and EXTENDABLE bits are setup setup, and that the correct BIN and BOUT fns are 'inherited' from the FDEV as well") (freplace FULLFILENAME of OSTREAM with NIL) (freplace OUTCHARFN of OSTREAM with (FUNCTION \MBS.OUTCHARFN)) (freplace LINELENGTH of OSTREAM with 0) (freplace CHARPOSITION of OSTREAM with 0) (freplace WRITEXTENSIONFN of OSTREAM with (SELECTQ ACCESS ((OUTPUT BOTH) WRITEXTENSIONFN) NIL)) (freplace BBSNCHARS of OSTREAM with 0)) OSTREAM]) (\MBS.OUTCHARFN [LAMBDA (STREAM CHAR) (* JonL " 7-NOV-83 21:54") (BOUT (SETQ STREAM (\DTEST STREAM 'STREAM)) CHAR) (* ; "The BBSNCHARS field *may* just be paralleling the CHARPOSITION field of the stream.") (add (ffetch BBSNCHARS of STREAM) 1]) (\BASEBYTES.NAME.FROM.STREAM [LAMBDA (STREAM) (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;; "STRING streams have a FULLFILENAME which is just the string itself; other random basebytes streams have this field null") (OR (fetch FULLFILENAME of STREAM) (LIST (fetch CBUFPTR of STREAM) (fetch BIASOFFST of STREAM) (GETEOFPTR STREAM]) (\BASEBYTES.BOUT [LAMBDA (STREAM BYTE) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG (CO) A (if (IGEQ (SETQ CO (fetch COFFSET of STREAM)) (fetch EOFFSET of STREAM)) then (if (SETQ CO (fetch (BASEBYTESTREAM WRITEXTENSIONFN) of STREAM)) then (APPLY* CO STREAM) (GO A) else (ERROR "Attempt to write past end of bytes block"))) (RETURN (\PUTBASEBYTE (fetch CBUFPTR of STREAM) (PROG1 CO (freplace COFFSET of STREAM with (ADD1 CO))) BYTE]) (\BASEBYTES.SETFILEPTR [LAMBDA (STREAM I) (* ; "Edited 13-Sep-90 16:30 by jds") (* ;; "SETFILEPTR for string streams &c.") (PROG ((I' I)) (add I' (fetch BIASOFFST of STREAM)) (if (IGREATERP I' (fetch EOFFSET of STREAM)) then (ERROR "Beyond end of byte range" I) else (* ;; "Fix both FILEPTR and CHARPOSITION to match.") (replace COFFSET of STREAM with I') (replace BBSNCHARS of STREAM with I']) (\BASEBYTES.READP [LAMBDA (STREAM FLG) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG ((CO (fetch COFFSET of STREAM)) (%#LEFT (fetch EOFFSET of STREAM))) (add %#LEFT (IMINUS CO)) (RETURN (OR (IGEQ %#LEFT 2) (if (EQ %#LEFT 0) then NIL elseif FLG else (NEQ (\GETBASEBYTE (fetch CBUFPTR of STREAM) (fetch COFFSET of STREAM)) (CHARCODE CR]) (\BASEBYTES.BIN [LAMBDA (STREAM) (* JonL " 7-NOV-83 22:49") (* ;; "Normally, the microcoded version of BIN will handle this, since the BINABLE flag is set and since the COFFSET etc fields are setup appropriately") (* ;; "Remember also that the VAX version installs a different STRMBINFN for the stringstream case") (PROG1 (\BASEBYTES.PEEKBIN STREAM) (add (fetch COFFSET of STREAM) 1]) (\BASEBYTES.PEEKBIN [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG ((CO (fetch COFFSET of STREAM))) (SELECTQ (SYSTEMTYPE) (VAX (if (fetch FULLNAME of STREAM) then (* ; "Aha, it's a string stream") (RETURN (\STRINGPEEKBIN STREAM NOERRORFLG)))) NIL) (RETURN (if (IGEQ CO (fetch EOFFSET of STREAM)) then (if (NOT NOERRORFLG) then (STREAMOP 'ENDOFSTREAMOP STREAM STREAM)) else (\GETBASEBYTE (fetch CBUFPTR of STREAM) CO]) (\BASEBYTES.TRUNCATEFN [LAMBDA (STREAM I) (* JonL " 7-NOV-83 22:20") ([LAMBDA (I' BO EO) (add I' BO) (if (ILESSP I 0) then (add I' EO)) (if (OR (ILESSP I BO) (IGREATERP I' EO)) then (ERROR "Beyond end of byte range" I) else (replace EOFFSET of STREAM with I'] I (fetch BIASOFFST of STREAM) (fetch EOFFSET of STREAM]) (\BASEBYTES.OPENFN [LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) (* ; "Edited 17-Jan-87 16:08 by bvm:") (if (fetch FULLFILENAME of NAME) then (OPENSTRINGSTREAM NAME ACCESS) else (\MAKEBASEBYTESTREAM (fetch CBUFPTR of NAME) (fetch BIASOFFST of NAME) (GETEOFPTR NAME) ACCESS (fetch WRITEXTENSIONFN of NAME) NAME]) (\BASEBYTES.BLOCKIO [LAMBDA (STREAM BASE OFFST N DIRECTION) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG (SBASE CO EO) A (if (ILEQ N 0) then (RETURN)) (SETQ SBASE (fetch CBUFPTR of STREAM)) (SETQ CO (fetch COFFSET of STREAM)) (SETQ EO (fetch EOFFSET of STREAM)) (if (IGREATERP N (IDIFFERENCE EO (SUB1 CO))) then (if (EQ DIRECTION 'INPUT) then (STREAMOP 'ENDOFSTREAMOP STREAM STREAM) else (* ; "Do a single BOUT to see if the WRITEXTENSIONFN will fix it up") (BOUT STREAM (\GETBASEBYTE BASE OFFST)) (add OFFST 1) (add N -1) (GO A))) (replace COFFSET of STREAM with (IPLUS CO N)) (if (EQ DIRECTION 'OUTPUT) then (swap SBASE BASE) (swap CO OFFST)) (\MOVEBYTES SBASE CO BASE OFFST N]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \BASEBYTESDEVICE) ) (DECLARE%: DONTEVAL@LOAD (\BASEBYTES.IO.INIT) ) (DEFINEQ (OPENSTRINGSTREAM [LAMBDA (STR ACCESS) (* rmk%: "28-Mar-85 08:40") (* ;; "Does not register the stream on \OPENFILES, nor does it search \OPENFILES for a previously opened stream. Thus, this implementation does not side-effect the string as the 10 does. However, the temporary coercion of strings to open streams in \GETSTREAM does simulate the side-effecting. Note that a string stream is unnamed.") (PROG (STREAM FATP) (OR (STRINGP STR) (\ILLEGAL.ARG STR)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of STR)) [SETQ STREAM (\MAKEBASEBYTESTREAM (OR (ffetch (STRINGP BASE) of STR) T) (COND (FATP (UNFOLD (ffetch (STRINGP OFFST) of STR) BYTESPERWORD)) (T (ffetch (STRINGP OFFST) of STR))) (COND (FATP (UNFOLD (ffetch (STRINGP LENGTH) of STR) BYTESPERWORD)) (T (ffetch (STRINGP LENGTH) of STR))) (SELECTQ ACCESS ((INPUT OUTPUT BOTH) ACCESS) (NIL 'INPUT) (\ILLEGAL.ARG ACCESS] (PROGN (* ; "Minor differences between a basebytestream and a stringstream") (if FATP then (freplace (STREAM CHARSET) of STREAM with \NORUNCODE)) (freplace USERCLOSEABLE of STREAM with T) (freplace USERVISIBLE of STREAM with T) (SELECTQ (SYSTEMTYPE) (VAX (freplace F2 of STREAM with 0) (freplace STRMBINFN of STREAM with (FUNCTION \STRINGBIN))) NIL)) (RETURN STREAM]) ) (* ;; "STREAM interface for old-style strings") (DEFINEQ (\STRINGSTREAM.INIT [LAMBDA NIL (* bvm%: "14-Feb-85 00:25") (SETQ \STRINGSTREAM.FDEV (create FDEV DEVICENAME _ 'STRING CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR) GETFILEINFO _ (FUNCTION NILL) GETFILENAME _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) OPENFILE _ (FUNCTION NILL) READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) REOPENFILE _ [FUNCTION (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV STREAM) STREAM] SETFILEINFO _ (FUNCTION NILL) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) BIN _ [FUNCTION (LAMBDA (STREAM) (replace F2 of STREAM with (COND ((fetch F1 of STREAM) (PROG1 (fetch F1 of STREAM) (replace F1 of STREAM with NIL))) ((GNCCODE (fetch FULLFILENAME of STREAM))) (T (\EOF.ACTION STREAM] PEEKBIN _ [FUNCTION (LAMBDA (STREAM NOERRORFLG) (OR (fetch F1 of STREAM) (CHCON1 (fetch FULLFILENAME of STREAM)) (AND (NOT NOERRORFLG) (\EOF.ACTION STREAM] READP _ [FUNCTION (LAMBDA (STREAM) (NOT (EOFP STREAM] BACKFILEPTR _ [FUNCTION (LAMBDA (STREAM) (replace F1 of STREAM with (fetch F2 of STREAM] EOFP _ (FUNCTION (LAMBDA (STREAM) (AND (NOT (fetch F1 of STREAM)) (EQ (NCHARS (fetch FULLFILENAME of STREAM)) 0]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\STRINGSTREAM.INIT) ) (DEFINEQ (GETSTREAM [LAMBDA (FILE ACCESS NOERROR) (* rrb "31-Oct-85 09:36") (* ; "USER ENTRY") (\GETSTREAM FILE ACCESS NOERROR]) (\ADDOFD [LAMBDA (STREAM) (* rmk%: "21-OCT-83 16:32") (* ;; "Returns the STREAM it adds to \OPENFILES") (\CLEAROFD) (AND (fetch NAMEDP of STREAM) (push \OPENFILES STREAM)) STREAM]) (\CLEAROFD [LAMBDA NIL (* lmm "30-SEP-80 20:08") (* ; "If GETOFD caches its args, this can clear the cache") NIL]) (\DELETEOFD [LAMBDA (OFD) (* rmk%: "25-OCT-79 08:20") (SETQ \OPENFILES (DREMOVE OFD \OPENFILES]) (\GETSTREAM [LAMBDA (X ACCESS NOERROR) (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;; "\GETSTREAM accepts a stream, NIL, T, or a window, and returns a corresponding stream. ACCESS is INPUT, OUTPUT, APPEND, BOTH or NIL. NOERROR, if non-NIL, means to return NIL if the file is not open in the specified access mode; otherwise, an error is caused.") (DECLARE (GLOBALVARS \DEFAULTLINEBUF \DEFAULTTTYDISPLAYSTREAM)) (COND ((NULL X) (SELECTQ ACCESS (INPUT (COND ((AND (EQ *STANDARD-INPUT* \DEFAULTLINEBUF) (EQ \KEYBOARD.STREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)) ) (\CREATE.TTYDISPLAYSTREAM))) *STANDARD-INPUT*) (OUTPUT (COND ((AND \DEFAULTTTYDISPLAYSTREAM (EQ *STANDARD-OUTPUT* \DEFAULTTTYDISPLAYSTREAM) ) (\CREATE.TTYDISPLAYSTREAM))) *STANDARD-OUTPUT*) (\IOMODEP (COND ((NOT (EQ *STANDARD-INPUT* \LINEBUF.OFD)) *STANDARD-INPUT*) (T *STANDARD-OUTPUT*)) ACCESS NOERROR))) ((EQ X T) (SELECTQ ACCESS (INPUT (COND ((EQ \LINEBUF.OFD \DEFAULTLINEBUF) (\CREATE.TTYDISPLAYSTREAM))) \LINEBUF.OFD) ((OUTPUT NIL) (COND ((AND \DEFAULTTTYDISPLAYSTREAM (EQ \TERM.OFD \DEFAULTTTYDISPLAYSTREAM)) (\CREATE.TTYDISPLAYSTREAM))) \TERM.OFD) (\FILE.NOT.OPEN X NOERROR))) ((type? STREAM X) (\IOMODEP X ACCESS NOERROR)) ((LITATOM X) (AND (NOT NOERROR) (ERROR "LITATOM 'streams' no longer supported" X))) ((AND (OR (EQ ACCESS 'OUTPUT) (NULL ACCESS)) (type? WINDOW X)) (fetch (WINDOW DSP) of X)) (T (\FILE.NOT.OPEN X NOERROR]) (\SEARCHOPENFILES [LAMBDA (NAME ACCESS) (* rmk%: "14-OCT-83 15:04") (* ;; "Returns a stream whose fullname is NAME if it has accessmode ACCESS") (for STREAM in \OPENFILES when (EQ NAME (fetch FULLNAME of STREAM)) do (RETURN (COND (ACCESS (\IOMODEP STREAM ACCESS T)) (T STREAM]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (PUTPROPS \INSTREAMARG MACRO ((STRM NOERRORFLG) (\GETSTREAM STRM 'INPUT NOERRORFLG))) (PUTPROPS \OUTSTREAMARG MACRO ((STRM NOERRORFLG) (\GETSTREAM STRM 'OUTPUT NOERRORFLG))) (PUTPROPS \STREAMARG MACRO [OPENLAMBDA (STRM NOERRORFLG) (COND (NOERRORFLG (\GETSTREAM STRM NIL T)) (T (\DTEST STRM 'STREAM]) ) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: EVAL@COMPILE (PUTPROPS GETOFD MACRO (= . GETSTREAM)) (PUTPROPS \GETOFD MACRO (= . \GETSTREAM)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA WHENCLOSE) ) (PUTPROPS AOFD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2304 3411 (\ADD-OPEN-STREAM 2314 . 2591) (\GENERIC-UNREGISTER-STREAM 2593 . 3409)) ( 3452 10531 (CLOSEALL 3462 . 4167) (CLOSEF 4169 . 5353) (EOFCLOSEF 5355 . 5651) (INPUT 5653 . 6407) ( OPENP 6409 . 6808) (OUTPUT 6810 . 7566) (POSITION 7568 . 8380) (RANDACCESSP 8382 . 8727) (\IOMODEP 8729 . 9366) (WHENCLOSE 9368 . 10529)) (10532 10654 (STREAMADDPROP 10542 . 10652)) (11820 23932 ( \BASEBYTES.IO.INIT 11830 . 15026) (\MAKEBASEBYTESTREAM 15028 . 17621) (\MBS.OUTCHARFN 17623 . 18011) ( \BASEBYTES.NAME.FROM.STREAM 18013 . 18476) (\BASEBYTES.BOUT 18478 . 19195) (\BASEBYTES.SETFILEPTR 19197 . 19818) (\BASEBYTES.READP 19820 . 20456) (\BASEBYTES.BIN 20458 . 20989) (\BASEBYTES.PEEKBIN 20991 . 21772) (\BASEBYTES.TRUNCATEFN 21774 . 22278) (\BASEBYTES.OPENFN 22280 . 22770) ( \BASEBYTES.BLOCKIO 22772 . 23930)) (24055 26305 (OPENSTRINGSTREAM 24065 . 26303)) (26362 29998 ( \STRINGSTREAM.INIT 26372 . 29996)) (30060 33611 (GETSTREAM 30070 . 30293) (\ADDOFD 30295 . 30582) ( \CLEAROFD 30584 . 30865) (\DELETEOFD 30867 . 31018) (\GETSTREAM 31020 . 33184) (\SEARCHOPENFILES 33186 . 33609))))) STOP \ No newline at end of file diff --git a/sources/APRINT b/sources/APRINT new file mode 100644 index 00000000..ef6926c8 --- /dev/null +++ b/sources/APRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Jan-2020 05:51:20" {DSK}kaplan>Local>medley3.5>lispcore>sources>APRINT.;2 87685 changes to%: (FNS \NUMERIC.PNAMEP) previous date%: " 6-Dec-91 11:43:22" {DSK}kaplan>Local>medley3.5>lispcore>sources>APRINT.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT APRINTCOMS) (RPAQQ APRINTCOMS [(COMS (* ; "User-level print functions") (FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE PRINTLEVEL RADIX SPACES TERPRI FRESHLINE DEFPRINT LINELENGTH)) (INITVARS (PLVLFILEFLG NIL) (\LINELENGTH 82) (\FLOATFORMAT T) (PRXFLG NIL) (*PRINT-BASE* 10) (*READ-BASE* 10) (*PRINT-RADIX* NIL) (*PRINT-ESCAPE* T) (*PRINT-CASE* ':UPCASE) (*PRINT-GENSYM* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-PRETTY* NIL) (*PRINT-CIRCLE* NIL) (*PRINT-ARRAY* NIL) (*PRINT-CIRCLE-HASHTABLE* NIL) (*PACKAGE* NIL) (*KEYWORD-PACKAGE* NIL) (*INTERLISP-PRIN1-CASE* ':UPCASE) (\DEFPRINTFNS NIL)) (COMS (* ; "PRINT internals") (FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER) (FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT \ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT \CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP \PRINSTACKP \PRINTADDR \PRINSTRING \SOUT \OUTCHAR) (FNS \FILEOUTCHARFN \JISFILEOUTCHARFN \SHIFTJISFILEOUTCHARFN \EUCFILEOUTCHARFN \THROUGHFILEOUTCHARFN) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .FILELINELENGTH.) (FUNCTIONS \PRINDATUM-LISTP) (EXPORT (MACROS .SPACECHECK. \CHECKRADIX) (MACROS \XCCSFILEOUTCHARFN))) (FNS \INVALID.RADIX) (SPECVARS \THISFILELINELENGTH)) (COMS (* ; "Internal printing") (FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP) (DECLARE%: DONTCOPY (RESOURCES \MAPPNAMESTREAM) (MACROS PNAMESTREAMP)) (INITRESOURCES \MAPPNAMESTREAM) [INITVARS (\PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T] (GLOBALVARS \PNAMEDEVICE)) (COMS (* ; "Obsolete") (FNS \MAPCHARS)) (DECLARE%: EVAL@COMPILE DOCOPY (ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*))) (COMS (* ; "PRINTNUM and friends") (FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING) (MACROS NUMFORMATCODE) (INITVARS (NILNUMPRINTFLG))) (LOCALVARS . T) (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "User-level print functions") (DEFINEQ (PRIN1 [LAMBDA (X FILE) (* bvm%: "29-Sep-86 23:59") (* ;;; "Like PRIN2 but no escaping. Also implies no radix qualifiers, although Common Lisp separates *PRINT-RADIX* from *PRINT-ESCAPE* -- might want to bind *PRINT-RADIX* to (AND (fetch (READTABLEP COMMONLISP) of *READTABLE*) *PRINT-RADIX*)") (LET* [(STRM (\GETSTREAM FILE 'OUTPUT)) (OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP) of (\DTEST *READTABLE* 'READTABLEP)) (OR (\OUTTERMP STRM) PLVLFILEFLG] (LET ((*PRINT-ESCAPE* NIL) (*PRINT-RADIX* NIL) (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*)) (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*)) (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*)) \THISFILELINELENGTH) (DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-CASE* \THISFILELINELENGTH)) (* ;  "*PRINT-CASE* because too many things in Interlisp prin1 things expecting the symbol's pname") (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM)) (\PRINDATUM X STRM 0) X]) (PRIN2 [LAMBDA (X FILE RDTBL) (* ; "Edited 20-Jan-87 17:04 by bvm:") (LET* [(STRM (\GETSTREAM FILE 'OUTPUT)) (OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP) of (SETQ RDTBL (\GTREADTABLE RDTBL))) (OR (\OUTTERMP STRM) PLVLFILEFLG] (LET ((*READTABLE* RDTBL) (*PRINT-ESCAPE* T) (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*)) (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*)) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) \THISFILELINELENGTH) (DECLARE (SPECVARS *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* *PRINT-LENGTH* *PACKAGE* \THISFILELINELENGTH)) (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STRM)) (\PRINDATUM X STRM 0) X]) (PRIN3 [LAMBDA (X FILE) (* bvm%: "29-Sep-86 23:59") (* ;;; "Like PRIN1 but no linelength checking") (LET* [(STRM (\GETSTREAM FILE 'OUTPUT)) (OBEY-PRINT-LEVEL (OR (ffetch (READTABLEP COMMONLISP) of (\DTEST *READTABLE* 'READTABLEP)) (OR (\OUTTERMP STRM) PLVLFILEFLG] (LET ((*PRINT-ESCAPE* NIL) (*PRINT-RADIX* NIL) (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*)) (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*)) (*PRINT-CASE* (OR *INTERLISP-PRIN1-CASE* *PRINT-CASE*)) \THISFILELINELENGTH) (DECLARE (SPECVARS *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-LEVEL* *PRINT-LENGTH* \THISFILELINELENGTH)) (\PRINDATUM X STRM 0) X]) (PRIN4 [LAMBDA (X FILE RDTBL) (* ; "Edited 20-Jan-87 17:05 by bvm:") (* ;;; "Like PRIN2 but doesn't check linelength") (LET* [(STRM (\GETSTREAM FILE 'OUTPUT)) (OBEY-PRINT-LEVEL (OR (fetch (READTABLEP COMMONLISP) of (SETQ RDTBL (\GTREADTABLE RDTBL))) (OR (\OUTTERMP STRM) PLVLFILEFLG] (LET ((*READTABLE* RDTBL) (*PRINT-ESCAPE* T) (*PRINT-LEVEL* (AND OBEY-PRINT-LEVEL *PRINT-LEVEL*)) (*PRINT-LENGTH* (AND OBEY-PRINT-LEVEL *PRINT-LENGTH*)) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) \THISFILELINELENGTH) (DECLARE (SPECVARS *PRINT-ESCAPE* *READTABLE* *PRINT-LEVEL* *PRINT-LENGTH* *PACKAGE* \THISFILELINELENGTH)) (\PRINDATUM X STRM 0) X]) (PRINT [LAMBDA (X FILE RDTBL) (* bvm%: " 9-May-86 23:08") (LET [(STRM (\GETSTREAM FILE 'OUTPUT] (PRIN2 X STRM RDTBL) (\OUTCHAR STRM (CHARCODE EOL)) X]) (PRINTCCODE [LAMBDA (CHARCODE FILE) (* bvm%: " 9-May-86 22:44") (\OUTCHAR (\GETSTREAM FILE 'OUTPUT) (COND ((\CHARCODEP CHARCODE) CHARCODE) (T (\ILLEGAL.ARG CHARCODE]) (PRINTLEVEL [LAMBDA (CARVAL CDRVAL) (* bvm%: " 9-May-86 22:47") (* ;;; "Sets Interlisp print level to the given values in CAR and CDR directions. These correspond to *PRINT-LEVEL* and *PRINT-LENGTH* in Common Lisp") [COND ((LISTP CARVAL) (SETQ CDRVAL (CDR CARVAL)) (SETQ CARVAL (CAR CARVAL] (PROG1 (CONS (OR *PRINT-LEVEL* -1) (OR *PRINT-LENGTH* -1)) [COND (CARVAL (SETQ *PRINT-LEVEL* (AND (IGEQ CARVAL 0) CARVAL] (COND (CDRVAL (SETQ *PRINT-LENGTH* (AND (IGEQ CDRVAL 0) CDRVAL]) (RADIX [LAMBDA (N) (* bvm%: " 5-May-86 10:56") (PROG1 *PRINT-BASE* (AND N (SETQ *PRINT-BASE* (\CHECKRADIX N]) (SPACES [LAMBDA (N FILE) (* rmk%: "21-OCT-83 12:32") [PROG ((STREAM (\GETSTREAM FILE 'OUTPUT)) \THISFILELINELENGTH) (SETQ \THISFILELINELENGTH (.FILELINELENGTH. STREAM)) (.SPACECHECK. STREAM N) (FRPTQ N (\OUTCHAR STREAM (CHARCODE SPACE] NIL]) (TERPRI [LAMBDA (FILE) (* rmk%: "21-OCT-83 12:31") (\OUTCHAR (\GETSTREAM FILE 'OUTPUT) (CHARCODE EOL)) NIL]) (FRESHLINE [LAMBDA (STREAM) (* rmk%: "22-AUG-83 13:48") (* ;; "Adjusts the STREAM to be at a new line -- does equivalent of TERPRI unless it is already 'sitting at the beginning of a line'") (COND ([NEQ 0 (fetch CHARPOSITION of (COND ((AND (type? STREAM STREAM) (WRITEABLE STREAM)) STREAM) (T (SETQ STREAM (GETSTREAM STREAM 'OUTPUT] (\OUTCHAR STREAM (CHARCODE EOL)) T]) (DEFPRINT [LAMBDA (TYPE FN) (* rmk%: "28-APR-80 12:04") (AND (FIXP TYPE) (SETQ TYPE (\TYPENAMEFROMNUMBER TYPE))) (* ; "The FIXP case should never occur") (PROG ((F (FASSOC TYPE \DEFPRINTFNS))) [COND (F (SETQ \DEFPRINTFNS (DREMOVE F \DEFPRINTFNS] [COND (FN (SETQ \DEFPRINTFNS (CONS (CONS TYPE FN) \DEFPRINTFNS] (RETURN (CDR F]) (LINELENGTH [LAMBDA (N FILE) (* bvm%: "11-Mar-86 14:56") (* ;;; "Sets to N the linelength of FILE -- defaults to primary output file") (LET [(STREAM (\GETSTREAM FILE 'OUTPUT] (PROG1 (fetch (STREAM LINELENGTH) of STREAM) (AND N (COND ((AND (NUMBERP N) (ILESSP N 1)) (\ILLEGAL.ARG N)) (T (replace (STREAM LINELENGTH) of STREAM with (COND ((EQ N T) (* ; "Infinite") MAX.SMALLP) (T (FIX N]) ) (RPAQ? PLVLFILEFLG NIL) (RPAQ? \LINELENGTH 82) (RPAQ? \FLOATFORMAT T) (RPAQ? PRXFLG NIL) (RPAQ? *PRINT-BASE* 10) (RPAQ? *READ-BASE* 10) (RPAQ? *PRINT-RADIX* NIL) (RPAQ? *PRINT-ESCAPE* T) (RPAQ? *PRINT-CASE* ':UPCASE) (RPAQ? *PRINT-GENSYM* T) (RPAQ? *PRINT-LEVEL* NIL) (RPAQ? *PRINT-LENGTH* NIL) (RPAQ? *PRINT-PRETTY* NIL) (RPAQ? *PRINT-CIRCLE* NIL) (RPAQ? *PRINT-ARRAY* NIL) (RPAQ? *PRINT-CIRCLE-HASHTABLE* NIL) (RPAQ? *PACKAGE* NIL) (RPAQ? *KEYWORD-PACKAGE* NIL) (RPAQ? *INTERLISP-PRIN1-CASE* ':UPCASE) (RPAQ? \DEFPRINTFNS NIL) (* ; "PRINT internals") (DEFINEQ (PRINT-CIRCLE-LOOKUP [LAMBDA (OBJECT) (* Pavel "16-Oct-86 21:13") (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*))) (CASE TABLEENTRY ((T1 NIL) (CL:VALUES NIL NIL)) (T2 (CL:VALUES (PROG1 (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) *PRINT-CIRCLE-NUMBER* "=") (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*) *PRINT-CIRCLE-NUMBER*) (CL:INCF *PRINT-CIRCLE-NUMBER*)) T)) (CL:OTHERWISE (CL:IF (NUMBERP TABLEENTRY) (CL:VALUES (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) TABLEENTRY "#") NIL) (CL:ERROR "Print-circle-lookup hashtable error!"]) (PRINT-CIRCLE-LABEL-P [CL:LAMBDA (OBJECT) (* jrb%: "30-Jun-86 23:04") (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE*)) (CL:BLOCK PRINT-CIRCLE-LABEL-P (LET ((TABLEENTRY (GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*))) (COND ((EQ TABLEENTRY 'T2)) ((CL:INTEGERP TABLEENTRY) TABLEENTRY) (T NIL]) (PRINT-CIRCLE-SCAN [CL:LAMBDA (OBJECT) (* ; "Edited 16-Jan-87 15:53 by jrb:") (DECLARE (CL:SPECIAL *PRINT-ARRAY*)) (CL:TYPECASE OBJECT [CONS (COND ((NOT (PRINT-CIRCLE-ENTER OBJECT)) (PRINT-CIRCLE-SCAN (CAR OBJECT)) (PRINT-CIRCLE-SCAN (CDR OBJECT] [CL::STRUCTURE-OBJECT (COND ((AND XCL:*PRINT-STRUCTURE* (NOT (PRINT-CIRCLE-ENTER OBJECT) )) (CL:MAPCAR [FUNCTION (LAMBDA (DESCRIPTOR) (PRINT-CIRCLE-SCAN (FETCHFIELD DESCRIPTOR OBJECT] (CL::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF OBJECT] ((CL:ARRAY T) (COND ((AND *PRINT-ARRAY* (NOT (PRINT-CIRCLE-ENTER OBJECT))) (* ;  "No need to walk array if we're not printing them") (LET* [(ASIZE (CL:ARRAY-TOTAL-SIZE OBJECT)) (VARRAY (COND ((> (CL:ARRAY-RANK OBJECT) 1) (CL:MAKE-ARRAY ASIZE :DISPLACED-TO OBJECT)) (T OBJECT] (CL:DOTIMES (X ASIZE) (PRINT-CIRCLE-SCAN (CL:AREF VARRAY X]) (PRINT-CIRCLE-ENTER [CL:LAMBDA (OBJECT) (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES)) (* ; "Edited 31-Mar-87 19:16 by jrb:") (CASE (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*) ((NIL) (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*) 'T1) NIL) (T1 (CL:SETF (CL:GETHASH OBJECT *PRINT-CIRCLE-HASHTABLE*) 'T2) (SETQ THERE-ARE-CIRCLES T) T) (T2 T) (CL:OTHERWISE (CL:ERROR "Print-circle-enter hashtable error!"]) ) (DEFINEQ (\PRINDATUM [LAMBDA (OBJECT STREAM CPL) (* ; "Edited 11-Feb-91 14:34 by jds") (DECLARE (USEDFREE *READTABLE* *PRINT-RADIX* *PRINT-BASE* *PRINT-ESCAPE*)) (SELECTC (NTYPX OBJECT) ((LIST \LITATOM \NEW-ATOM) (\LITPRIN OBJECT STREAM)) (\LISTP (* ;; "macro call that uses the arguments already bound, to save a fn call.") (\PRINDATUM-LISTP)) ((LIST \SMALLP \FIXP) (WITH-RESOURCES (\NUMSTR \NUMSTR1) (\CKPOSSOUT STREAM (\CONVERTNUMBER OBJECT (\CHECKRADIX *PRINT-BASE*) T (AND (if (fetch (READTABLEP COMMONLISP) of *READTABLE*) then (* ;  "Common Lisp controlled solely by this var") *PRINT-RADIX* else (* ;  "Interlisp prints radix if it is not 10 and we are prin2") (AND *PRINT-ESCAPE* (NEQ *PRINT-BASE* 10))) *READTABLE*) \NUMSTR \NUMSTR1)))) (\FLOATP [WITH-RESOURCES (\NUMSTR \NUMSTR1) (\CKPOSSOUT STREAM (\CONVERT.FLOATING.NUMBER OBJECT \NUMSTR \NUMSTR1 (COND ((AND (PNAMESTREAMP STREAM) (NOT PRXFLG)) (* ;; "The pname of a number is unaffected by RADIX unless PRXFLG is true. This seems silly, but assorted code will break otherwise") T) (T \FLOATFORMAT]) (\STACKP (\PRINSTACKP OBJECT STREAM)) (COND ((STRINGP OBJECT) (\PRINSTRING OBJECT STREAM)) ((TYPENAMEP OBJECT 'CL::STRUCTURE-OBJECT) (* ;; "this is a structure, don't use defprint.") (CL::PRINT-STRUCTURE-INSTANCE OBJECT STREAM CPL)) ((TYPENAMEP OBJECT 'T) (* ;;  "this is a common-loops object, since it is a sub-class of t, so call the print-instance method.") (PRINT-INSTANCE OBJECT STREAM 0)) (T (\PRINT-USING-DEFPRINT OBJECT STREAM CPL]) (\PRINT-USING-DEFPRINT [LAMBDA (X STREAM CPL) (* ; "Edited 18-Dec-86 12:22 by bvm:") (DECLARE (USEDFREE *PRINT-LEVEL*)) (LET* ((TYPE (TYPENAME X)) (FN (FASSOC TYPE \DEFPRINTFNS))) (COND ([OR (NULL FN) (NULL (SETQ FN (LET [(*PRINT-LEVEL* (AND *PRINT-LEVEL* (IDIFFERENCE *PRINT-LEVEL* (OR CPL 0] (* ;  "This way recursive calls to PRINT etc will be at the 'right' level") (CL:FUNCALL (CDR FN) X STREAM 0] (* ;; "No defined printer, or printer declined to do anything") (\PRINT-USING-ADDRESS X STREAM CPL)) ((LISTP FN) (* ;; "PRIN1 the CAR (usually a macro char) and PRIN2 the CDR. Nowadays there is little reason for a defprint fn to not do its own printing") (AND (CAR FN) (LET (*PRINT-ESCAPE*) (\PRINDATUM (CAR FN) STREAM))) (AND (CDR FN) (\PRINDATUM (CDR FN) STREAM CPL]) (\PRINT-USING-ADDRESS (CL:LAMBDA (X STREAM CPL) (CL:BLOCK \PRINT-USING-ADDRESS [LET ((TYPE (TYPENAME X))) (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (.SPACECHECK. STREAM 2) (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\OUTCHAR STREAM (CHARCODE "<")) (AND TYPE (\LITPRIN TYPE STREAM)) (\CKPOSSOUT STREAM " @ ") (\PRINTADDR X STREAM) (\CKPOSBOUT STREAM (CHARCODE ">"))) (T (\CKPOSBOUT STREAM (CHARCODE {)) (AND TYPE (\LITPRIN TYPE STREAM)) (\CKPOSBOUT STREAM (CHARCODE })) (\OUTCHAR STREAM (CHARCODE "#")) (\PRINTADDR X STREAM] T))) (\ELIDE.PRINT.ELEMENT [LAMBDA (STREAM) (* jrb%: "29-Jun-86 21:05") (\OUTCHAR STREAM (\ELIDE.ELEMENT.CHAR]) (\ELIDE.ELEMENT.CHAR [LAMBDA NIL (* jrb%: "29-Jun-86 21:04") (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (T (CHARCODE "&"]) (\ELIDE.PRINT.TAIL [LAMBDA (STREAM NOSPACEP) (* jrb%: "29-Jun-86 21:06") (* ;;; "Prints the appropriate elision indicator for elements beyond *PRINT-DEPTH* according to the read table we're using. Prints first a space unless NOSPACEP") [COND ((NOT NOSPACEP) (\OUTCHAR STREAM (CHARCODE SPACE] (\SOUT (\ELIDE.TAIL.STRING) STREAM]) (\ELIDE.TAIL.STRING [LAMBDA NIL (* jrb%: "29-Jun-86 21:05") (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) "...") (T "--"]) (\CKPOSBOUT [LAMBDA (STREAM X) (* rmk%: "21-OCT-83 12:32") (.SPACECHECK. STREAM 1) (\OUTCHAR STREAM X]) (\CKPOSSOUT [LAMBDA (STREAM X) (* rmk%: "21-OCT-83 12:32") (.SPACECHECK. STREAM (\NSTRINGCHARS X)) (for I instring X do (\OUTCHAR STREAM I]) (\CONVERTNUMBER [LAMBDA (N R IGNORE RDTBL NS NSB) (* ; "Edited 18-Dec-86 17:53 by bvm:") (* ;;; "Convert integer N to a string in radix R. RDTBL governs whether radix qualifiers appear. NS is a scratch promised to be of sufficient length; NSB is a scratch string pointer. IGNORE is obsolete flag for printing unsigned numbers") (LET* ((SIGN) [MAGNITUDE (if (>= N 0) then N else (SETQ SIGN (IMINUS N] (X MAGNITUDE) (POS (\NSTRINGCHARS NS)) (END (SUB1 POS)) COMMONLISPY DIDQ) (if RDTBL then (* ; "do bletcherous suffix cases first") (if (SETQ COMMONLISPY (fetch (READTABLEP COMMONLISP) of RDTBL)) then (* ; "decimal is suffix") (if (EQ R 10) then (RPLCHARCODE NS (add END 1) (CHARCODE ".")) (SETQ DIDQ T)) elseif (AND (EQ R 8) (> MAGNITUDE 7)) then (* ; "Octal numbers have Q suffix") (RPLCHARCODE NS (add END 1) (CHARCODE Q)) (SETQ DIDQ T))) (repeatuntil (EQ X 0) do (* ;  "note this loop happens at least once, for benefit of MAGNITUDE = 0") [RPLCHARCODE NS (add POS -1) (LET ((DIGIT (IREMAINDER X R))) (if (< DIGIT 10) then (+ DIGIT (CHARCODE 0)) else (* ;  "For radices higher than 10, use letters of alphabet from A on up") (+ (- DIGIT 10) (CHARCODE A] (SETQ X (IQUOTIENT X R))) (if SIGN then (RPLCHARCODE NS (add POS -1) (CHARCODE -))) (if [AND RDTBL (NOT DIDQ) (OR COMMONLISPY (AND (NEQ R 10) (OR (> MAGNITUDE 9) (>= MAGNITUDE R] then (* ;; "Prepend a radix qualifier if it wasn't already done as a suffix. In Interlisp we don't do this if the radix is decimal or the number is smaller than the radix.") [SELECTQ R (16 (* ; "hex") (RPLCHARCODE NS (add POS -1) (CHARCODE x))) (8 (* ; "octal") (RPLCHARCODE NS (add POS -1) (CHARCODE o))) (2 (RPLCHARCODE NS (add POS -1) (CHARCODE b))) (PROGN (RPLCHARCODE NS (add POS -1) (CHARCODE r)) (RPLCHARCODE NS (add POS -1) (+ (CHARCODE 0) (IREMAINDER R 10))) (if (>= R 10) then (* ; "two-digit radix") (RPLCHARCODE NS (add POS -1) (+ (CHARCODE 0) (IQUOTIENT R 10] (RPLCHARCODE NS (add POS -1) (fetch (READTABLEP HASHMACROCHAR) of RDTBL))) (SUBSTRING NS POS END NSB]) (\LITPRIN [LAMBDA (X STREAM) (* ; "Edited 14-Apr-87 14:49 by jrb:") (DECLARE (USEDFREE \THISFILELINELENGTH *PRINT-ESCAPE* *READTABLE* *PACKAGE* *PRINT-GENSYM* *PRINT-CASE*)) (COND (*PRINT-ESCAPE* (LET ((RDTBL *READTABLE*) PKG PKGSEPR) [COND (*PACKAGE* (* ;  "This is NIL until packages get turned on") (COND ((EQ *PACKAGE* (SETQ PKG (fetch (CL:SYMBOL PACKAGE) of X))) (* ;  "No prefix needed in current package") (SETQ PKG NIL)) [(NULL PKG) (* ;  "Uninterned. Print something if flag is on") (COND (*PRINT-GENSYM* (* ;  "Print #: as prefix. Not PACKAGECHAR here because colon hardwired into hashmacro dispatch.") (RPLCHARCODE (SETQ PKGSEPR (ALLOCSTRING 2 (CHARCODE ":"))) 1 (fetch (READTABLEP HASHMACROCHAR) of RDTBL] ((EQ PKG *KEYWORD-PACKAGE*) (* ;  "Keywords get single colon, no prefix") (SETQ PKGSEPR (ALLOCSTRING 1 (fetch (READTABLEP PACKAGECHAR) of RDTBL))) (SETQ PKG NIL)) ((FIND-EXACT-SYMBOL X *PACKAGE*) (* ;; "Symbol is accessible in current package, either by being imported or by inheritance. This is a messy test, which is why we test for special case of PKG being the current package first above. No prefix needed here.") (SETQ PKG NIL)) (T (* ;; "Package qualifier is needed; we need only know now whether symbol is internal or external in its home package.") (SETQ PKGSEPR (ALLOCSTRING (COND ((EQ X ( FIND-EXTERNAL-SYMBOL X PKG)) (* ;  "X is external in PKG, use single colon") 1) (T 2)) (fetch (READTABLEP PACKAGECHAR) of RDTBL] (\LITPRIN.INTERNAL X RDTBL STREAM (AND PKG (PACKAGE-NAME-AS-SYMBOL PKG)) PKGSEPR \THISFILELINELENGTH))) (T (.SPACECHECK. STREAM (\NATOMCHARS X)) (* ;; "Following code munged to match \LITPRIN.INTERNAL's handling of :CAPITALIZE") (for C inatom X bind (DOWNCASE _ (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (SELECTQ *PRINT-CASE* ((:DOWNCASE :CAPITALIZE) *PRINT-CASE*) NIL))) (WAS-ALPHA _ NIL) do (\OUTCHAR STREAM (if DOWNCASE then (* ; "may have to change case") (if (AND (>= C (CHARCODE A)) (<= C (CHARCODE Z))) then (if (OR (NEQ DOWNCASE :CAPITALIZE) (PROG1 WAS-ALPHA (SETQ WAS-ALPHA T))) then (* ; "for :capitalize, lower all but the characters that start %"words%", i.e., those immediately after a non-alphanumeric") (+ C (- (CHARCODE a) (CHARCODE A))) else C) else [if (EQ DOWNCASE :CAPITALIZE) then (* ;  "C not upper-case. Set WAS-ALPHA if it's lowercase alpha or numeric ") (SETQ WAS-ALPHA (OR (AND (>= C (CHARCODE a)) (<= C (CHARCODE z))) (AND (>= C (CHARCODE 0)) (<= C (CHARCODE 9] C) else C]) (\LITPRIN.INTERNAL [LAMBDA (SYMBOL RDTBL STREAM PKGNAME PKGSEPR CHECKLENGTH) (* ; "Edited 18-Dec-86 17:33 by bvm:") (* ;;; "Print SYMBOL to STREAM according to RDTBL, preceded by PKGNAME (if non-NIL) and/or PKGSEPR. PKGNAME is a symbol, PKGSEPR is a string. If CHECKLENGTH is true, need to check that there is room for printing all three parts on this line; else caller has verified that there is room") (LET ((PNAMELENGTH (\NATOMCHARS SYMBOL)) (ESCAPE (fetch (READTABLEP ESCAPECHAR) of RDTBL)) (MULTESCAPE (fetch (READTABLEP MULTESCAPECHAR) of RDTBL)) USEMULTESCAPE CASEBASE SA SYN NESCAPES CHECKESCAPE FIRSTESCAPE) (if (OR (NEQ MULTESCAPE 0) CHECKLENGTH) then (* ;  "have to check now if linelength matters or we plan to use multiple escapes") (SETQ NESCAPES (\SYMBOL.ESCAPE.COUNT SYMBOL RDTBL (NULL CHECKLENGTH))) (if (EQ NESCAPES -1) then (* ;  "Pname is numeric and we don't have a multiple escape available--need to escape first char") (SETQ NESCAPES 1) (SETQ FIRSTESCAPE T) elseif (< NESCAPES 0) then (* ; "Use multiple escapes") (SETQ NESCAPES (IMINUS NESCAPES)) (SETQ USEMULTESCAPE T) elseif (NEQ NESCAPES 0) then (SETQ CHECKESCAPE T)) else (* ;  "if we don't check now then have to check while printing") (SETQ CHECKESCAPE T)) [if CHECKLENGTH then (* ; "Verify space for everything") (.SPACECHECK. STREAM (+ PNAMELENGTH NESCAPES (if PKGNAME then (* ;  "How much space to print package name") (IABS (\SYMBOL.ESCAPE.COUNT PKGNAME RDTBL)) else 0) (if PKGSEPR then (* ;  "Extra characters between pkg name and symbol name") (\NSTRINGCHARS PKGSEPR) else 0] (* ;; "First print any needed package qualifier") (if PKGNAME then (* ;  "Print package name, don't check length") (\LITPRIN.INTERNAL PKGNAME RDTBL STREAM)) (if PKGSEPR then (\SOUT PKGSEPR STREAM)) (if USEMULTESCAPE then (* ;  "Surround pname with multiple escape char, only escape internal escapes") (\OUTCHAR STREAM MULTESCAPE) (for C inatom SYMBOL do (if (OR (EQ C MULTESCAPE) (EQ C ESCAPE)) then (\OUTCHAR STREAM ESCAPE)) (\OUTCHAR STREAM C)) (\OUTCHAR STREAM MULTESCAPE) else [if FIRSTESCAPE then (* ;  "Need an escape character at start to keep atom from being interpreted as number") (\OUTCHAR STREAM ESCAPE) elseif CHECKESCAPE then (if (AND (EQ PNAMELENGTH 1) (EQ (CHCON1 SYMBOL) (CHARCODE "."))) then (* ;  "have to handle period special because it is only special in a dotted context") (\OUTCHAR STREAM ESCAPE) (SETQ CHECKESCAPE NIL) else (* ;  "prepare to check for escaping of chars in the printing loop") (SETQ CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY))) (SETQ SA (fetch READSA of RDTBL] (for C inatom SYMBOL bind (FIRSTFLG _ T) (DOWNCASE _ (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (SELECTQ *PRINT-CASE* ((:DOWNCASE :CAPITALIZE) *PRINT-CASE*) NIL))) WAS-ALPHA do (if [AND CHECKESCAPE (OR (if (AND CASEBASE (ILEQ C \MAXTHINCHAR) (NEQ C (\GETBASEBYTE CASEBASE C))) then (* ;  "lower-case alphabetic. We are assuming that no alphanumeric char will pass the next text") (SETQ WAS-ALPHA T)) (AND (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C))) (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN] then (* ;; "Need to escape if: character is lower case when case-insensitive, or character intrinsically needs escape.") (\OUTCHAR STREAM ESCAPE) (\OUTCHAR STREAM C) else (\OUTCHAR STREAM (if DOWNCASE then (* ; "may have to change case") (if (AND (<= C (CHARCODE Z)) (>= C (CHARCODE A))) then (if (OR (NEQ DOWNCASE :CAPITALIZE) (PROG1 WAS-ALPHA (SETQ WAS-ALPHA T))) then (* ; "for :capitalize, lower all but the characters that start %"words%", i.e., those immediately after a non-alphanumeric") (+ C (- (CHARCODE a) (CHARCODE A))) else C) else [if (EQ DOWNCASE :CAPITALIZE) then (* ; "C not upper-case. It's also not lowercase, because that was caught in the CHECKESCAPE clause if any, but note if it's numeric") (SETQ WAS-ALPHA (AND (>= C (CHARCODE 0)) (<= C (CHARCODE 9] C) else C))) (SETQ FIRSTFLG NIL]) (\SYMBOL.ESCAPE.COUNT [LAMBDA (SYMBOL RDTBL INEXACTOK) (* ; "Edited 18-Dec-86 17:08 by bvm:") (* ;;; "Counts the number of escape characters needed to print SYMBOL by RDTBL. If RDTBL has a multiple-escape character, then we return a negative count if we're assuming it is used instead of single escapes; else a positive count. The special value -1 means the symbol is numeric, so must be quoted, but no multiple escape is available, so just escape the first character. If INEXACTOK is true and we discover we want to use multiple escape char, returns -2 immediately.") (for C inatom SYMBOL bind (RESULT _ 0) (NESCAPES _ 0) (FIRSTFLG _ T) (MULTESCAPE _ (fetch (READTABLEP MULTESCAPECHAR) of RDTBL)) (ESCAPE _ (fetch (READTABLEP ESCAPECHAR) of RDTBL)) (CASEBASE _ (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY ))) (SA _ (fetch READSA of RDTBL)) SYN first (if (EQ MULTESCAPE 0) then (* ; "Can't use multiple-escape") (SETQ MULTESCAPE NIL)) do [if [OR (AND CASEBASE (ILEQ C \MAXTHINCHAR) (NEQ C (\GETBASEBYTE CASEBASE C))) (AND (fetch (READCODE ESCQUOTE) of (SETQ SYN (\SYNCODE SA C))) (OR FIRSTFLG (fetch (READCODE INNERESCQUOTE) of SYN] then (* ;; "Need protection if char is lowercase in a case-insensitive read table or the read table says it needs it") (add RESULT 1) (if MULTESCAPE then (if (OR (EQ C MULTESCAPE) (EQ C ESCAPE)) then (* ;  "These have to be escaped no matter what") (add NESCAPES 1) elseif (AND INEXACTOK (> (- RESULT NESCAPES) 1)) then (* ;  "If at least 2 chars need escaping, better to use multiple escape, and we can quit scanning now") (RETURN -2] (SETQ FIRSTFLG NIL) finally (RETURN (if (EQ RESULT 0) then (* ;  "No funny chars, check for some other perverse cases") (LET ((LEN (\NATOMCHARS SYMBOL))) (if (EQ LEN 0) then (* ;  "The bletcherous null symbol. Shouldn't be allowed to create this, grumble.") (if MULTESCAPE then (* ; "Can print as ||") -2 else (* ; "Single escape can't work") 0) elseif (AND (EQ LEN 1) (EQ C (CHARCODE "."))) then (* ;  "Special case, dot is always escaped when by itself, and prefer single escape to multiple") -1 elseif (\NUMERIC.PNAMEP SYMBOL (if (fetch (READTABLEP COMMONLISP) of RDTBL) then *READ-BASE* else 10)) then (* ;; "Is numeric, must escape it. Note that if pname is numeric, there can't be any special chars inside it needing escaping. We wait until now to test numeric on the grounds that it is more likely we will print a symbol with escapable chars than one that is a potential number.") (if MULTESCAPE then (* ;  "Nicer to use multiple escape around whole symbol") -2 else (* ; "Say to escape first char") -1) else 0)) elseif (AND MULTESCAPE (> (- RESULT NESCAPES) 1)) then (* ;; "The number of characters needing escaping, not counting the ones that have to be escaped in any case, is at least two. Use two multiple-escapes and NESCAPES regular escapes for the internal escapes = -(NESCAPES+2) total extra characters") (- -2 NESCAPES) else RESULT]) (\NUMERIC.PNAMEP [LAMBDA (SYMBOL RADIX) (* ; "Edited 17-Jan-2020 05:43 by rmk:") (* ; "Edited 6-Dec-91 11:27 by jds") (* ;;; "True if the chars in SYMBOL are a potential number in RADIX, which defaults to the current read base (according to current read table), OR IF the symbol consists solely of decimal points.") (LET* ((LASTCHARTYPE 'FIRST) [EFFECTIVE-RADIX (OR RADIX (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) *READ-BASE*) (T 10] (MAXALPHADIGIT (+ (CHARCODE A) (- EFFECTIVE-RADIX 11))) SEENALPHADIGITS SEENDIGITS SEENDECPT SEENEXPONENT SEENTIGHTLETTERS SEEN-ILLEGAL-SYNTAX) (* ;  "If RADIX is bigger than 10, this allows alphabetic digits") (for C inpname SYMBOL do (* ;; "The inpname is a nicety so it works on strings too (useful for testing) --- Note that we are assuming a partitioning of character space as follows: (--- + / decpt) (digits) (A-Z) (_ ^) (a-z)") [SETQ LASTCHARTYPE (COND [(< C (CHARCODE A)) (* ; "Numeric or funny char") (COND ((< C (CHARCODE 0)) (SELCHARQ C ((- +) (* ; "Signs anywhere but end") (* ;; "RMK 2020-01-17: Anywhere at the end conforms to the Commonlisp notion of being able to extend the number syntax. But this is never going to happen here, and the consequence of not recognizing signs just at the beginning is that tokens like 1-2 will get printed as |1-2|, which is surprising. So: I'm restricting signs to first position.") (CL:UNLESS (EQ LASTCHARTYPE 'FIRST) (RETURN NIL)) 'SIGN) ("." (COND (SEENALPHADIGITS (* ;; "Can't have decimal point in other radices, so if we saw combinations of chars that would have been invalid in radix 10, bomb out") (COND (SEENTIGHTLETTERS (RETURN NIL))) (SETQ SEENALPHADIGITS NIL)) (SEENDECPT (* ;; "Can't have 2 decimal points.") (SETQ SEEN-ILLEGAL-SYNTAX T))) (SETQ MAXALPHADIGIT 0) (SETQ SEENDECPT T)) (/ (COND ((EQ LASTCHARTYPE 'FIRST) (* ; "Can't start with ratio marker") (RETURN NIL)))) (RETURN NIL))) ((<= C (CHARCODE 9)) (* ; "digit") (SETQ SEENDIGITS T) 'DIGIT) (T (RETURN NIL] ((> C (CHARCODE z)) (* ; "Out in the wilderness.") (RETURN NIL)) ((PROGN [COND ((>= C (CHARCODE a)) (* ; "Raise it") (SETQ C (- C (- (CHARCODE a) (CHARCODE A] (<= C (CHARCODE Z))) (* ; "Letter") [COND ((<= C MAXALPHADIGIT) (* ;  "Letter is a digit in this base. Can't be digit in number with decimal pt") (COND (SEENDECPT (* ;; "If there was a decimal point earlier, bail out.") (RETURN NIL))) (SETQ SEENALPHADIGITS T) (SELECTQ LASTCHARTYPE ((LETTER FIRST) (* ;  "Two letters in a row or started with letter. Notice this in case a dec pt comes along") (SETQ SEENTIGHTLETTERS T)) NIL)) (T (* ;  "Potential exponent marker, only in radix 10") (OR (IEQP 10 EFFECTIVE-RADIX) (RETURN NIL)) (AND SEENEXPONENT (RETURN NIL)) (SELECTQ LASTCHARTYPE ((LETTER FIRST) (RETURN NIL)) (COND ((FMEMB C (CHARCODE (E S F D L))) (SETQ SEENEXPONENT T)) (T (RETURN NIL] 'LETTER) ((OR (EQ C (CHARCODE "_")) (EQ C (CHARCODE "^"))) (* ;  "Extension chars, not used now but maybe some day. We're supposed to escape these") NIL) (T (RETURN NIL] finally (* ; "Success if there was at least one digit and didn't end in a sign. Also true if symbol consisted solely of periods.") (RETURN (OR (AND (NOT SEEN-ILLEGAL-SYNTAX) (OR SEENDIGITS SEENALPHADIGITS) (NEQ LASTCHARTYPE 'SIGN)) (AND SEENDECPT (EQ LASTCHARTYPE T) (for C inpname SYMBOL always (EQ C (CHARCODE "."]) (\PRINSTACKP [LAMBDA (X STREAM) (* bvm%: "11-May-86 16:09") (* ;;; "Print stackp as addr/framename. If stackp is released or framename is not a symbol, print mumble") (.SPACECHECK. STREAM (IPLUS 1 (CONSTANT (NCHARS "]) (\PRINTADDR [LAMBDA (X STREAM) (* bvm%: "11-May-86 15:13") (WITH-RESOURCES (\NUMSTR \NUMSTR1) (SELECTQ (SYSTEMTYPE) (D (\CKPOSSOUT STREAM (\CONVERTNUMBER (\HILOC X) 8 NIL NIL \NUMSTR \NUMSTR1)) (\CKPOSBOUT STREAM (CHARCODE %,)) (\CKPOSSOUT STREAM (\CONVERTNUMBER (\LOLOC X) 8 NIL NIL \NUMSTR \NUMSTR1))) (JERICHO (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOGAND \ADDRMASK (LOC X)) 8 NIL NIL \NUMSTR \NUMSTR1))) (VAX (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X) 16 T NIL \NUMSTR \NUMSTR1))) ((TENEX TOPS-20) (\CKPOSSOUT STREAM (\CONVERTNUMBER (LOC X) 8 T NIL \NUMSTR \NUMSTR1))) (SYSTEMTYPEPUNT '(\PRINDATUM X]) (\PRINSTRING [LAMBDA (X STREAM) (* bvm%: "11-May-86 15:08") (COND [*PRINT-ESCAPE* (* ;  "Print with double quotes and escaped as needed") (LET ((ESC (fetch (READTABLEP ESCAPECHAR) of *READTABLE*))) [.SPACECHECK. STREAM (IPLUS 2 (\NSTRINGCHARS X) (for C instring X count (OR (EQ C (CHARCODE %")) (EQ C ESC] (\OUTCHAR STREAM (CHARCODE %")) (for C instring X do (COND ((OR (EQ C (CHARCODE %")) (EQ C (CHARCODE LF)) (EQ C ESC)) (* ;  "VM says only %" is escaped no matter what stringdelim's are.") (\OUTCHAR STREAM ESC))) (\OUTCHAR STREAM C)) (\OUTCHAR STREAM (CHARCODE %"] (T (.SPACECHECK. STREAM (\NSTRINGCHARS X)) (\SOUT X STREAM]) (\SOUT [LAMBDA (X STREAM) (* ; "Edited 14-Dec-88 22:17 by jds") (* ;; "Print the string X onto STREAM, which -must- be a stream.") (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) (DECLARE (SPECVARS *DRIBBLE-OUTPUT* \PRIMTERMSA \TERM.OFD)) (COND [(FMEMB (ffetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of STREAM)) \DISPLAYSTREAMTYPES) (LET ((*DRIBBLE-OUTPUT* *DRIBBLE-OUTPUT*) (\PRIMTERMSA \PRIMTERMSA) (\TERM.OFD \TERM.OFD)) (for I instring X do (\OUTCHAR STREAM I] ((for I instring X do (\OUTCHAR STREAM I]) (\OUTCHAR [LAMBDA (STREAM CHARCODE) (* rmk%: " 7-APR-82 00:25") (STREAMOP 'OUTCHARFN STREAM STREAM CHARCODE]) ) (DEFINEQ (\FILEOUTCHARFN (LAMBDA (ST CHARCODE) (* ; "Edited 25-Feb-91 17:15 by nm") (\XCCSFILEOUTCHARFN ST CHARCODE))) (\JISFILEOUTCHARFN (LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 11-Mar-91 11:49 by nm") (* ;;; "Encoder for JIS format.") (COND ((EQ CHARCODE (CHARCODE EOL)) (COND ((\KIMODEP OUTSTREAM NIL) (\OUTKO OUTSTREAM) (\CHNAGE.KI.MODE OUTSTREAM NIL NIL))) (\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 (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE)) (* ; "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.") (COND ((> CHARCODE 255) (COND ((NOT (\KIMODEP OUTSTREAM NIL)) (\OUTKI OUTSTREAM) (\CHNAGE.KI.MODE OUTSTREAM NIL T))) (\BOUT OUTSTREAM (\CHARSET CHARCODE)) (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) (T (* ; "ASCII or HANKAKUKATAKANA") (COND ((\KIMODEP OUTSTREAM NIL) (\OUTKO OUTSTREAM) (\CHNAGE.KI.MODE OUTSTREAM NIL NIL))) (\BOUT OUTSTREAM CHARCODE))) (freplace CHARPOSITION of OUTSTREAM with (PROGN (* ; "Ugh. Don't overflow") (IPLUS16 (ffetch CHARPOSITION of OUTSTREAM) 1)))))) ) (\SHIFTJISFILEOUTCHARFN (LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 7-Mar-91 21:55 by nm") (* ;;; "Encoder for Shift-JIS format.") (COND ((EQ CHARCODE (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 (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE)) (* ; "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.") (COND ((> CHARCODE 255) (LET ((CH1 (FOLDLO CHARCODE 256)) (CH2 (LOGAND CHARCODE 255))) (\CONV.JIS.TO.SJIS CH1 CH2) (COND ((AND (< CH1 256) (< CH2 256)) (\BOUT OUTSTREAM CH1) (\BOUT OUTSTREAM CH2))))) (T (\BOUT OUTSTREAM CHARCODE))) (freplace CHARPOSITION of OUTSTREAM with (PROGN (* ; "Ugh. Don't overflow") (IPLUS16 (ffetch CHARPOSITION of OUTSTREAM) 1)))))) ) (\EUCFILEOUTCHARFN (LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 11-Mar-91 11:29 by nm") (* ;;; "Encoder for EUC format.") (COND ((EQ CHARCODE (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 (SETQ CHARCODE (\CONV.XCCS.TO.JIS OUTSTREAM CHARCODE)) (* ; "\CONV.XCCS.TO.JIS converts ZENKAKUKATAKANA to HANKAKUKATAKANA if the stream desires it.") (COND ((> CHARCODE 255) (* ; "KANJI or GAIJI") (AND (NOT (\NOTGAIJIP CHARCODE)) (\BOUT OUTSTREAM 143)) (\BOUT OUTSTREAM (LOGOR (\CHARSET CHARCODE) 128)) (\BOUT OUTSTREAM (LOGOR (\CHAR8CODE CHARCODE) 128))) ((\HANKAKUP CHARCODE) (\BOUT OUTSTREAM 142) (\BOUT OUTSTREAM (LOGOR CHARCODE 128))) (T (* ; "C0, C1, SP, DEL or G0") (\BOUT OUTSTREAM CHARCODE))) (freplace CHARPOSITION of OUTSTREAM with (PROGN (* ; "Ugh. Don't overflow") (IPLUS16 (ffetch CHARPOSITION of OUTSTREAM) 1)))))) ) (\THROUGHFILEOUTCHARFN (LAMBDA (OUTSTREAM CHARCODE) (* ; "Edited 26-Feb-91 13:44 by nm") (* ;;; "Encoder for THROUGH format.") (COND ((> CHARCODE 255) (\BOUT OUTSTREAM (\CHARSET CHARCODE)) (\BOUT OUTSTREAM (\CHAR8CODE CHARCODE))) (T (\BOUT OUTSTREAM CHARCODE)))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS .FILELINELENGTH. MACRO ((STRM) (LET ((L (fetch (STREAM LINELENGTH) of STRM))) (SELECTC L (0 (* Some default) \LINELENGTH) (MAX.SMALLP (* Infinite) NIL) L)))) ) (DEFMACRO \PRINDATUM-LISTP () (* ;; "This is a hokey macro call to save the function call. Read it as though it were inline code in \prindatum") `[LET (LABEL FIRSTTIME) (OR CPL (SETQ CPL 0)) (if *PRINT-CIRCLE-HASHTABLE* then (* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.") (CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME) (PRINT-CIRCLE-LOOKUP OBJECT))) [if LABEL then (\CKPOSSOUT STREAM LABEL) (CL:WHEN FIRSTTIME (\CKPOSBOUT STREAM (CHARCODE SPACE)))] (COND ((AND LABEL (NOT FIRSTTIME)) (* ;  "Second reference --- just print label") NIL) ((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL)) (\ELIDE.PRINT.ELEMENT STREAM)) (T (PROG (CDRCNT) [COND (*PRINT-LENGTH* (SETQ CDRCNT (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) 0) (T (* ;  "Interlisp print depth is triangular, Common Lisp isn't") [COND ((IGEQ CPL *PRINT-LENGTH*) (* ;  "We would just print '(--)' so it's nicer to print '&'") (RETURN (\ELIDE.PRINT.ELEMENT STREAM] CPL] (add CPL 1) (* ;  "Recursive calls will be at 1 greater depth") (\CKPOSBOUT STREAM (CHARCODE %()) LP [COND ((AND CDRCNT (IGREATERP (add CDRCNT 1) *PRINT-LENGTH*)) (* ;  "have printed as many elements as allowed") (\ELIDE.PRINT.TAIL STREAM T)) (T (\PRINDATUM (CAR OBJECT) STREAM CPL) (COND ((LISTP (SETQ OBJECT (CDR OBJECT))) (\CKPOSBOUT STREAM (CHARCODE SPACE)) (if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT )) then (* ; "Must print as a dotted tail") (\CKPOSSOUT STREAM ". ") (\PRINDATUM OBJECT STREAM CPL) else (GO LP))) (OBJECT (* ; "Dotted tail") (\CKPOSSOUT STREAM " . ") (\PRINDATUM OBJECT STREAM] (\CKPOSBOUT STREAM (CHARCODE ")"]) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (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]) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\INVALID.RADIX [LAMBDA (N) (* bvm%: " 5-May-86 10:58") (ERROR "Bad value for *print-base*" N]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS \THISFILELINELENGTH) ) (* ; "Internal printing") (DEFINEQ (\MAPPNAME [LAMBDA (FN X FLG RDTBL *PRINT-LEVEL* *PRINT-LENGTH*) (* ; "Edited 23-Mar-87 11:01 by bvm:") (* ;;; "Run thru the characters in the pname of X, calling FN on each character. For speed, FN is defined to be of the same form as an OUTCHARFN, viz., arglist = (stream char); stream in this case is a dummy") (LET [(*READTABLE* (if FLG then (\GTREADTABLE RDTBL) else (\DTEST *READTABLE* 'READTABLEP] (LET ((*PACKAGE* (if (AND FLG (fetch (READTABLEP USESILPACKAGE) of *READTABLE*)) then *INTERLISP-PACKAGE* else *PACKAGE*)) (*PRINT-ESCAPE* FLG) (*PRINT-BASE* (if (OR FLG PRXFLG) then *PRINT-BASE* else 10)) (*PRINT-RADIX* (AND FLG *PRINT-RADIX*))) (\MAPPNAME.INTERNAL FN X]) (\MAPPNAME.INTERNAL [LAMBDA (FN X) (* bvm%: "13-May-86 15:01") (WITH-RESOURCE (\MAPPNAMESTREAM) (replace OUTCHARFN of \MAPPNAMESTREAM with FN) (replace STRMBOUTFN of \MAPPNAMESTREAM with FN) (* ;  "Should never use the bout fn, but include it just in case somebody thinks \OUTCHAR = \BOUT") (LET (\THISFILELINELENGTH) (* ; "Stream has no linelength checks") (DECLARE (SPECVARS \THISFILELINELENGTH)) (\PRINDATUM X \MAPPNAMESTREAM 0]) (PNAMESTREAMP [LAMBDA (STRM) (* bvm%: "24-Mar-86 17:37") (* ;;; "True if STRM is an internal-printing stream for pnames, i.e., one of the values of the \MAPPNAMESTREAM resource") (AND (TYPENAMEP STRM 'STREAM) (EQ (fetch (STREAM DEVICE) of STRM) \PNAMEDEVICE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\MAPPNAMESTREAM 'RESOURCES '(NEW (create STREAM DEVICE _ \PNAMEDEVICE ACCESSBITS _ OutputBits LINELENGTH _ MAX.SMALLP] ) (DECLARE%: EVAL@COMPILE (PUTPROPS PNAMESTREAMP DMACRO ((STRM) (EQ (fetch (STREAM DEVICE) of STRM) \PNAMEDEVICE))) ) ) (/SETTOPVAL '\\MAPPNAMESTREAM.GLOBALRESOURCE NIL) (RPAQ? \PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PNAMEDEVICE) ) (* ; "Obsolete") (DEFINEQ (\MAPCHARS [LAMBDA (\MAPCHARFN X FLG RDTBL) (* bvm%: "13-Mar-86 18:53") (DECLARE (SPECVARS RDTBL)) (* ;;; "Run thru the characters in the pname of X, calling \MAPCHARFN on each character.") (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CHAR) (SPREADAPPLY* \MAPCHARFN CHAR] X FLG RDTBL]) ) (DECLARE%: EVAL@COMPILE DOCOPY (ADDTOVAR SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*) ) (* ; "PRINTNUM and friends") (DEFINEQ (PRINTNUM [LAMBDA (FORMAT NUMBER FILE) (* DECLARATIONS%: (RECORD FIXFMT  (WIDTH RADIX PAD0 LEFTFLUSH))  (RECORD FLOATFMT (WIDTH DECPART  EXPPART PAD0 SIGDIGITS))) (* rmk%: "17-MAY-82 10:07") (DECLARE (GLOBALVARS NILNUMPRINTFLG)) (GLOBALRESOURCE (\NUMSTR \NUMSTR1) (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT)) (FLOAT T) (FIX NIL) (LISPERROR "ILLEGAL ARG" FORMAT))) (FMT (CDR FORMAT))) (SETQ WIDTH (fetch WIDTH of FMT)) [SETQ STR (COND ((AND (NULL NUMBER) NILNUMPRINTFLG)) (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER) \NUMSTR \NUMSTR1 (\CHECKFLTFMT FORMAT))) (T (\CONVERTNUMBER (OR (FIXP NUMBER) (FIXR NUMBER)) (COND ((SETQ RAD (fetch RADIX of FMT)) (SETQ TEMP (IABS RAD)) (COND ((OR (IGREATERP 2 TEMP) (IGREATERP TEMP 16)) (\ILLEGAL.ARG RAD))) TEMP) (T 10)) (OR (NULL RAD) (IGREATERP RAD 0)) NIL \NUMSTR \NUMSTR1] (SETQ PAD (COND (WIDTH (IDIFFERENCE WIDTH (NCHARS STR))) (T 0))) [COND ([AND (IGREATERP PAD 0) (OR FLOATFLAG (NULL (fetch LEFTFLUSH of FMT] (COND ((COND (FLOATFLAG (fetch (FLOATFMT PAD0) of FMT)) (T (fetch (FIXFMT PAD0) of FMT))) (FRPTQ PAD (PRIN1 "0" FILE))) (T (SPACES PAD FILE] (PRIN1 STR FILE) (COND ((AND (IGREATERP PAD 0) (NOT FLOATFLAG) (fetch LEFTFLUSH of FMT)) (SPACES PAD FILE))) (RETURN NUMBER]) (FLTFMT [LAMBDA (FORMAT) (* bvm%: "30-JAN-81 23:20") (* ;  "numeric arg, as on 10, not allowed") (PROG1 \FLOATFORMAT (AND FORMAT (\CHECKFLTFMT FORMAT) (SETQ \FLOATFORMAT FORMAT]) (\CHECKFLTFMT [LAMBDA (FORMAT) (* bvm%: "29-JAN-81 15:41") (* ;;; "Generates error if FORMAT is not legal FLOAT format: (FLOAT WIDTH DECPART EXPPART PAD SIGDIGITS)") (COND ([OR (EQ FORMAT T) (AND (EQ (CAR FORMAT) 'FLOAT) (EVERY (CDR FORMAT) (FUNCTION (LAMBDA (X) (OR (NULL X) (FIXP X] FORMAT) (T (LISPERROR "ILLEGAL ARG" FORMAT]) (PRINTNUM-TO-STRING [LAMBDA (FORMAT NUMBER) (* DECLARATIONS%: (RECORD FIXFMT  (WIDTH RADIX PAD0 LEFTFLUSH))  (RECORD FLOATFMT (WIDTH DECPART  EXPPART PAD0 SIGDIGITS))) (* ; "Edited 27-Nov-91 13:32 by jds") (DECLARE (GLOBALVARS NILNUMPRINTFLG)) (GLOBALRESOURCE (\NUMSTR \NUMSTR1) (PROG (STR WIDTH PAD TEMP RAD (FLOATFLAG (SELECTQ (CAR (LISTP FORMAT)) (FLOAT T) (FIX NIL) (LISPERROR "ILLEGAL ARG" FORMAT))) (FMT (CDR FORMAT))) (SETQ WIDTH (fetch WIDTH of FMT)) [SETQ STR (COND ((AND (NULL NUMBER) NILNUMPRINTFLG)) (FLOATFLAG (\CONVERT.FLOATING.NUMBER (FLOAT NUMBER) \NUMSTR \NUMSTR1 (\CHECKFLTFMT FORMAT))) (T (\CONVERTNUMBER (OR (FIXP NUMBER) (FIXR NUMBER)) (COND ((SETQ RAD (fetch RADIX of FMT)) (SETQ TEMP (IABS RAD)) (COND ((OR (IGREATERP 2 TEMP) (IGREATERP TEMP 16)) (\ILLEGAL.ARG RAD))) TEMP) (T 10)) (OR (NULL RAD) (IGREATERP RAD 0)) NIL \NUMSTR \NUMSTR1] (SETQ PAD (COND (WIDTH (IDIFFERENCE WIDTH (NCHARS STR))) (T 0))) (RETURN (CONCAT (COND [[AND (IGREATERP PAD 0) (OR FLOATFLAG (NULL (fetch LEFTFLUSH of FMT] (COND ((COND (FLOATFLAG (fetch (FLOATFMT PAD0) of FMT)) (T (fetch (FIXFMT PAD0) of FMT))) (ALLOCSTRING PAD "0")) (T (ALLOCSTRING PAD " "] (T "")) STR]) ) (DECLARE%: EVAL@COMPILE (PROGN (PUTPROPS NUMFORMATCODE BYTEMACRO (= . PROG1)) (PUTPROPS NUMFORMATCODE DMACRO (= . PROG1))) ) (RPAQ? NILNUMPRINTFLG ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS APRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3975 12601 (PRIN1 3985 . 5389) (PRIN2 5391 . 6496) (PRIN3 6498 . 7449) (PRIN4 7451 . 8546) (PRINT 8548 . 8788) (PRINTCCODE 8790 . 9067) (PRINTLEVEL 9069 . 9795) (RADIX 9797 . 9971) ( SPACES 9973 . 10323) (TERPRI 10325 . 10514) (FRESHLINE 10516 . 11181) (DEFPRINT 11183 . 11695) ( LINELENGTH 11697 . 12599)) (13263 17752 (PRINT-CIRCLE-LOOKUP 13273 . 14503) (PRINT-CIRCLE-LABEL-P 14505 . 15103) (PRINT-CIRCLE-SCAN 15105 . 17042) (PRINT-CIRCLE-ENTER 17044 . 17750)) (17753 62216 ( \PRINDATUM 17763 . 20705) (\PRINT-USING-DEFPRINT 20707 . 22097) (\PRINT-USING-ADDRESS 22099 . 23512) ( \ELIDE.PRINT.ELEMENT 23514 . 23688) (\ELIDE.ELEMENT.CHAR 23690 . 23977) (\ELIDE.PRINT.TAIL 23979 . 24407) (\ELIDE.TAIL.STRING 24409 . 24634) (\CKPOSBOUT 24636 . 24805) (\CKPOSSOUT 24807 . 25025) ( \CONVERTNUMBER 25027 . 29308) (\LITPRIN 29310 . 35845) (\LITPRIN.INTERNAL 35847 . 44202) ( \SYMBOL.ESCAPE.COUNT 44204 . 50972) (\NUMERIC.PNAMEP 50974 . 57553) (\PRINSTACKP 57555 . 58866) ( \PRINTADDR 58868 . 59949) (\PRINSTRING 59951 . 61332) (\SOUT 61334 . 62052) (\OUTCHAR 62054 . 62214)) (62217 66145 (\FILEOUTCHARFN 62227 . 62340) (\JISFILEOUTCHARFN 62342 . 63612) (\SHIFTJISFILEOUTCHARFN 63614 . 64688) (\EUCFILEOUTCHARFN 64690 . 65873) (\THROUGHFILEOUTCHARFN 65875 . 66143)) (76348 76520 ( \INVALID.RADIX 76358 . 76518)) (76624 78633 (\MAPPNAME 76634 . 77633) (\MAPPNAME.INTERNAL 77635 . 78272) (PNAMESTREAMP 78274 . 78631)) (79316 79704 (\MAPCHARS 79326 . 79702)) (80035 87091 (PRINTNUM 80045 . 83104) (FLTFMT 83106 . 83507) (\CHECKFLTFMT 83509 . 84081) (PRINTNUM-TO-STRING 84083 . 87089)) ))) STOP \ No newline at end of file diff --git a/sources/APUTDQ b/sources/APUTDQ new file mode 100644 index 00000000..aea91b89 --- /dev/null +++ b/sources/APUTDQ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Oct-90 11:02:58" |{PELE:MV:ENVOS}SOURCES>APUTDQ.;3| 12059 changes to%: (FNS ENDLOADUP) previous date%: "16-May-90 12:03:05" |{PELE:MV:ENVOS}SOURCES>APUTDQ.;2|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT APUTDQCOMS) (RPAQQ APUTDQCOMS [ (* ;; " this file contains some dummy definitions of functions whose real implementation is on other files") (DECLARE%: EVAL@LOAD DONTCOPY (P (PRIN1 "Warning: APUTDQ contains dummy definitions of " T) (PRIN1 "FAULTEVAL FAULTAPPLY ERRORX SET-DOCUMENTATION SMASHFILECOMS" T) (PRIN1 "Be careful not to confuse with the real definitions" T) (TERPRI T))) (FNS GREETFILENAME FAULTEVAL FAULTAPPLY ERRORX SET-DOCUMENTATION) (FNS SMASHFILECOMS SMASHFILECOMSLST) (INITVARS (DEFAULTREGISTRY) (USERGREETFILES) (LOGINHOST/DIR '{DSK})) (FNS LOADUP ENDLOADUP) (VARS LOADUPDIRECTORIES) (ALISTS (SYSTEMINITVARS \CONNECTED.DIRECTORY DWIMFLG ADDSPELLFLG FILEPKGFLG BUILDMAPFLG UPDATEMAPFLG DEFAULTREGISTRY DEFAULTPRINTINGHOST DIRECTORIES USERGREETFILES NETWORKOSTYPES CH.NET.HINT CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION ADVISEDFNS LISPUSERSDIRECTORIES DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS INTERPRESSFONTDIRECTORIES)) [DECLARE%: DONTEVAL@LOAD DOCOPY (* ;; "many of these are obsolete and can be removed, but it is unclear which ones") (P (DUMMYDEF (ADDSTATS *) (LISPXWATCH NILL) (CLBUFS NILL) (FINDFILE INFILEP) (FILEMAP *) (VIRGINFN GETD)) (DUMMYDEF (* QUOTE) (GETP GETPROP) (DECLARE QUOTE) (FRPLNODE2 RPLNODE2) (DISPLAYTERMP TRUE) (FRPLACA RPLACA) (FRPLACD RPLACD) (MISSPELLED? NILL) (UNDOSAVE NILL) (SETLINELENGTH ZERO) (DOBE NILL) (RELINK NILL) (PUT PUTPROP) (/PUT PUTPROP))) (ADDVARS (SYSFILES) (LISPXHISTORY) (LINKEDFNS)) (VARS (CLEARSTKLST T) (SYSHASHARRAY (HASHARRAY 50)) (DISPLAYTERMFLG T) (%#UNDOSAVES) (NLAMA) (NLAML) (LAMS) (TTYLINELENGTH 82) (COMPILE.EXT 'LCOM) (FASL.EXT 'DFASL) (*COMPILED-EXTENSIONS* '(DFASL LCOM)) (SYSOUT.EXT 'SYSOUT] (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ;; " this file contains some dummy definitions of functions whose real implementation is on other files") (DECLARE%: EVAL@LOAD DONTCOPY (PRIN1 "Warning: APUTDQ contains dummy definitions of " T) (PRIN1 "FAULTEVAL FAULTAPPLY ERRORX SET-DOCUMENTATION SMASHFILECOMS" T) (PRIN1 "Be careful not to confuse with the real definitions" T) (TERPRI T) ) (DEFINEQ (GREETFILENAME (LAMBDA (USER) (* ; "Edited 20-Jul-88 16:00 by drc:") (* ;; "Returns name of an existing greeting file, or NIL") (DECLARE (GLOBALVARS USERGREETFILES LOGINHOST/DIR COMPILE.EXT)) (LET (FILE) (SELECTQ USER (T (OR (AND (EQ \MACHINETYPE \MAIKO) (OR (AND (SETQ FILE (UNIX-GETENV "LDEINIT")) (INFILEP FILE)) (INFILEP "{DSK}/usr/local/lde/site-init.lisp"))) (FINDFILE-WITH-EXTENSIONS "{DSK}INIT" NIL (APPEND *COMPILED-EXTENSIONS* (QUOTE ("LISP")))) (while (SETQ FILE (PROMPTFORWORD (QUOTE "Please enter name of system init file (e.g. {server}INIT.extension): "))) until (SETQ FILE (INFILEP FILE)) finally (RETURN FILE)))) (NIL) (COND ((LISTP USERGREETFILES) (* ;; "USERGREETFILES is a list of templates for possible init file names. The templates contain pieces of file names and the symbols USER and COM to denote logged in user and compiled extension.") (LET ((POS (AND DEFAULTREGISTRY (STRPOS (QUOTE %.) (SETQ USER (U-CASE USER)))))) (* ; "Grapevine hack: if user's login name has registry same as default, strip off registry before treating name as a directory") (COND ((AND POS (STREQUAL (SUBSTRING USER (ADD1 POS) -1) (MKSTRING DEFAULTREGISTRY))) (SETQ USER (SUBSTRING USER 1 (SUB1 POS))))) (for D in (COND ((LISTP (CAR USERGREETFILES)) USERGREETFILES) (T (CONS USERGREETFILES))) when (SETQ D (if (MEMB (QUOTE COM) D) then (* ;; "Icky old compiled file specification. Want to search for everything in *COMPILED-EXTENSIONS*. Have to smash extension to NIL so that it looks like name has no explicit extension (there is already a dot in the template, sigh)") (FINDFILE-WITH-EXTENSIONS (PACKFILENAME.STRING (QUOTE EXTENSION) NIL (QUOTE BODY) (CONCATLIST (SUBPAIR (QUOTE (USER COM)) (LIST USER "") D))) NIL *COMPILED-EXTENSIONS*) else (* ; "Random file, no COM element") (INFILEP (CONCATLIST (SUBST USER (QUOTE USER) D))))) do (RETURN D)))))))) ) (FAULTEVAL (NLAMBDA FAULTX (* lmm "16-MAY-80 11:57") (RAID FAULTX))) (FAULTAPPLY (LAMBDA (FAULTFN FAULTARGS) (* lmm "16-MAY-80 11:58") (RAID FAULTFN))) (ERRORX (LAMBDA (ERXM) (* lmm "16-MAY-80 11:58") (RAID ERXM))) (SET-DOCUMENTATION (LAMBDA (NAME DOC-TYPE NEW-STRING) (* "lmm" "27-Oct-86 11:16") NIL)) ) (DEFINEQ (SMASHFILECOMS (LAMBDA (FILE) (* JonL " 8-Jun-84 10:43") (* ; "dummy definition for APUTDQ") (PROG ((FILECOMS (PACK (LIST FILE (QUOTE COMS))))) (COND ((BOUNDP FILECOMS) (* ; "Already loaded, but may want to clobber its FNS, VARS, and BLOCKS E.G. MISC, BASIC.") (SMASHFILECOMSLST (GETATOMVAL FILECOMS)) (SET FILECOMS (QUOTE NOBIND)))))) ) (SMASHFILECOMSLST (LAMBDA (COMS) (* lmm "11-MAR-83 13:17") (MAPC COMS (FUNCTION (LAMBDA (COM) (PROG (NAME) (AND (EQ (CADR COM) (QUOTE *)) (LITATOM (CADDR COM)) (SETQ NAME (CADDR COM))) (SELECTQ (CAR COM) (COMS (SMASHFILECOMSLST (COND (NAME (GETATOMVAL NAME)) (T (CDR COM))))) (FILEVARS (SETQ NAME (COND ((EQ (CADR COM) (QUOTE *)) (* ;; "if caddr is a litatom, name was set to it above. if caddr is not, dangerous to evaluate the form, so punt") (GETATOMVAL NAME)) (T (CDR COM))))) ((PROP IFPROP) (COND ((AND (EQ (CADDR COM) (QUOTE *)) (LITATOM (CADDDR COM))) (SETQ NAME (CADDDR COM))))) NIL) (COND ((AND NAME (LITATOM NAME)) (SET NAME (QUOTE NOBIND))))))))) ) ) (RPAQ? DEFAULTREGISTRY ) (RPAQ? USERGREETFILES ) (RPAQ? LOGINHOST/DIR '{DSK}) (DEFINEQ (LOADUP (LAMBDA (OPTION/FILES) (* ; "Edited 4-Feb-88 18:07 by bvm:") (SELECTQ OPTION/FILES ((NIL HUGE) (while BOOTLOADEDFILES do (pushnew SYSFILES (pop BOOTLOADEDFILES))) (LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) (LOADUP (QUOTE (BSP DPUPFTP))) (* ; "Load these now to speed up the rest of the loading") (LOADUP (QUOTE (AFONT))) (LOADUP (QUOTE (EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF COMMENT ADVISE LOADFNS DMISC DFILE))) (* ; "DMISC needs to come before DFILE") (LOADUP (QUOTE (COMPATIBILITY BREAK FILEPKG RESOURCE))) (LOADUP (QUOTE (MACROS DLAP BYTECOMPILER COMPILE))) (LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST HELPDL))) (LOADUP (QUOTE (COMMON))) (LOADUP (QUOTE (HPRINT MACROAUX ADDARITH))) (LOADUP (QUOTE (MSANALYZE MSPARSE MASTERSCOPE))) (DWIM (QUOTE C)) (COMPILEMODE (QUOTE D)) (LOADUP (QUOTE (AARITH))) (LOADUP (QUOTE (ADISPLAY HLDISPLAY MENU WINDOW ATTACHEDWINDOW WBREAK XXGEOM XXFILL))) (LOADUP (QUOTE (DEXEC INSPECT))) (LOADUP (QUOTE (DEDIT TTYIN))) (LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY))) (LOADUP (QUOTE (10MBDRIVER LLNS TRSERVER))) (LOADUP (QUOTE (BRKDWN MATCH))) (LOADUP (QUOTE (LLFCOMPILE))) (LOADUP (QUOTE (SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY PUPPRINT INTERPRESS FLOPPY))) (LOADUP (QUOTE (IDLER)))) (COND ((LISTP OPTION/FILES) (* ; "RESETVAR just in case some sub-loading wants to 'reach out' to other files") (for X in OPTION/FILES do (OR (FMEMB X SYSFILES) (RESETVAR DIRECTORIES LOADUPDIRECTORIES (DOFILESLOAD (LIST (QUOTE (SYSLOAD FROM VALUEOF LOADUPDIRECTORIES)) X)))) (SMASHFILECOMS X))) (T (HELP "BAD LOADUP OPTION" OPTION/FILES))))) ) (ENDLOADUP [LAMBDA NIL (* ; "Edited 11-Oct-90 11:02 by jds") (* ;; "set up for NONET configuration; sites with ethernet can load in init from other places") (* ;; "All records existing at this point in time have been loaded as part of the system.") [MAPC USERRECLST (FUNCTION (LAMBDA (R) (RECORDPRIORITY R 'SYSTEM] [MAPC SYSTEMINITVARS (FUNCTION (LAMBDA (X) (SETTOPVAL (CAR X) (COPY (CDR X] (COND ((NEQ \MACHINETYPE \MAIKO) (* ;;  "On a non-SUN loadup, need to clear out two fields in the Interface Page, per AR 11276. JDS") (replace (IFPAGE ProcessSize) of \InterfacePage with 0) (replace (IFPAGE StorageFullState) of \InterfacePage with 0]) ) (RPAQQ LOADUPDIRECTORIES ({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS})) (ADDTOVAR SYSTEMINITVARS (\CONNECTED.DIRECTORY . {DSK}) (DWIMFLG . T) (ADDSPELLFLG . T) (FILEPKGFLG . T) (BUILDMAPFLG . T) (UPDATEMAPFLG . T) (DEFAULTREGISTRY) (DEFAULTPRINTINGHOST) (DIRECTORIES) (USERGREETFILES) (NETWORKOSTYPES) (CH.NET.HINT) (CH.DEFAULT.DOMAIN) (CH.DEFAULT.ORGANIZATION) (ADVISEDFNS) (LISPUSERSDIRECTORIES {DSK}) (DISPLAYFONTDIRECTORIES {DSK}) (DISPLAYFONTEXTENSIONS DISPLAYFONT) (INTERPRESSFONTDIRECTORIES {DSK})) (DECLARE%: DONTEVAL@LOAD DOCOPY (DUMMYDEF (ADDSTATS *) (LISPXWATCH NILL) (CLBUFS NILL) (FINDFILE INFILEP) (FILEMAP *) (VIRGINFN GETD)) (DUMMYDEF (* QUOTE) (GETP GETPROP) (DECLARE QUOTE) (FRPLNODE2 RPLNODE2) (DISPLAYTERMP TRUE) (FRPLACA RPLACA) (FRPLACD RPLACD) (MISSPELLED? NILL) (UNDOSAVE NILL) (SETLINELENGTH ZERO) (DOBE NILL) (RELINK NILL) (PUT PUTPROP) (/PUT PUTPROP)) (ADDTOVAR SYSFILES ) (ADDTOVAR LISPXHISTORY ) (ADDTOVAR LINKEDFNS ) (RPAQQ CLEARSTKLST T) (RPAQ SYSHASHARRAY (HASHARRAY 50)) (RPAQQ DISPLAYTERMFLG T) (RPAQQ %#UNDOSAVES NIL) (RPAQQ NLAMA NIL) (RPAQQ NLAML NIL) (RPAQQ LAMS NIL) (RPAQQ TTYLINELENGTH 82) (RPAQQ COMPILE.EXT LCOM) (RPAQQ FASL.EXT DFASL) (RPAQQ *COMPILED-EXTENSIONS* (DFASL LCOM)) (RPAQQ SYSOUT.EXT SYSOUT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS APUTDQ COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4041 6249 (GREETFILENAME 4051 . 5924) (FAULTEVAL 5926 . 5998) (FAULTAPPLY 6000 . 6086) (ERRORX 6088 . 6154) (SET-DOCUMENTATION 6156 . 6247)) (6250 7270 (SMASHFILECOMS 6260 . 6602) ( SMASHFILECOMSLST 6604 . 7268)) (7364 9999 (LOADUP 7374 . 9079) (ENDLOADUP 9081 . 9997))))) STOP \ No newline at end of file diff --git a/sources/ARGLIST b/sources/ARGLIST new file mode 100644 index 00000000..e9b23059 --- /dev/null +++ b/sources/ARGLIST @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-May-90 12:03:44" |{DSK}local>lde>lispcore>sources>ARGLIST.;2| 5353 |changes| |to:| (VARS ARGLISTCOMS) |previous| |date:| " 3-Dec-86 22:19:56" |{DSK}local>lde>lispcore>sources>ARGLIST.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT ARGLISTCOMS) (RPAQQ ARGLISTCOMS ((FNS PRINT-ARGLIST))) (DEFINEQ (print-arglist (lambda (args actuals file left) (* \; "Edited 25-Nov-86 16:16 by lmm") (prog (type remargs) (or left (setq left 0)) (* |;;| "Prints args to fn, mastching up with ACTUALS, if supplied. Do this in a way that lets us keep track of where we are") (|if| (and args (nlistp args)) |then| (setq args (list '&nrest args))) (cond (actuals (cond ((cdr actuals) (tab 0 0 file)) (t (prin1 " " file))) (|bind| mode |while| actuals |do| (cond ((null args) (tab 0 0 file) (prin1 "...+" file)) ((nlistp args) (tab 0 0 file) (prin1 " . " file) (prin2 args file) (setq args)) (t (selectq (car args) ((&rest &body) (tab 0 0 file) (prin2 (|pop| args) file) (prin1 " " file) (prin2 (|pop| args) file) (progn (tab 15 1 file) (prin1 "= " file)) (prin2 actuals file) (setq actuals) (terpri file) (return)) (&rest (tab 0 0 file) (prin1 ". " file) (prin2 (|pop| args) file) (progn (tab 15 1 file) (prin1 "= " file)) (prin2 actuals file) (setq actuals) (terpri file) (return)) (&allow-other-keys (spaces 1 file) (prin2 (|pop| args) file) (terpri file) (go $$iterate)) (&optional (prin2 (setq mode (|pop| args)) file) (prin1 " " file) (prin2 (|pop| args) file)) (&key (|while| args |do| (prin1 " " file) (prin2 (|pop| args) file)) (|while| actuals |do| (progn (tab 15 1 file) (prin1 "= " file)) (prin2 (|pop| actuals) file) (prin1 " " file) (prin2 (|pop| actuals) file) (terpri file)) (return)) (prin2 (|pop| args) file)))) (progn (tab 15 1 file) (prin1 "= " file)) (prin2 (car actuals) file) (setq actuals (cdr actuals)) (terpri file)))) (|while| args |do| (prin2 (|pop| args) file) (and args (prin1 " " file)))))) ) (PUTPROPS ARGLIST COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (454 5261 (PRINT-ARGLIST 464 . 5259))))) STOP \ No newline at end of file diff --git a/sources/ASKUSER b/sources/ASKUSER new file mode 100644 index 00000000..84927ed4 --- /dev/null +++ b/sources/ASKUSER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Aug-2020 21:18:50" {DSK}kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;5 51071 changes to%: (FNS ASKUSER) (VARS ASKUSERCOMS) previous date%: "16-May-90 12:04:15" {DSK}kaplan>Local>medley3.5>lispcore>sources>ASKUSER.;1) (* ; " Copyright (c) 1986, 1987, 1990, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ASKUSERCOMS) (RPAQQ ASKUSERCOMS [(FNS ASKUSER ASKUSERLOOKUP ASKUSERCHAR ASKUSER$ ASKUSER1 ASKUSERSETUP ASKUSEREXPLAIN ASKUSERPRIN1 MAKEKEYLST) (* ;; "RMK: Avoid literal CR's on files.") (INITVARS [DEFAULTKEYLST `([Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL] (N ,(CONCAT "o" (CHARACTER (CHARCODE EOL] (ASKUSERTTBL (COPYTERMTABLE))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CONTROL T ASKUSERTTBL) (ECHOMODE NIL ASKUSERTTBL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS ASKUSER OPTIONS) (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (ASKUSER [LAMBDA (WAIT DEFAULT MESS KEYLST TYPEAHEAD LISPXPRNTFLG OPTIONSLST FILE) (DECLARE (SPECVARS LISPXPRNTFLG OPTIONSLST FILE)) (* ; "Edited 10-Aug-2020 20:58 by rmk:") (* ; "Edited 10-Aug-87 15:45 by jop") (* ;  "reads characters one at a time echoing and/or prompting as indicated by KEYLST") (* ;; "RMK: Changed literal ^M's and spaces to use the (CHARACTER (CHARCODE construct), for readability and to allow for EOL conversion from other file systems. We want this always to be the internal EOL (=CR).") (RESETLST (COND ((NULL KEYLST) (* ;  "Yes, no recognized without conforimation") (SETQ KEYLST DEFAULTKEYLST))) (PROG [OLDTTBL CHAR TEM KEYLST1 ANSWER BUFS (ORIGKEYLST KEYLST) (ORIGMESS MESS) (ORIGDEFAULT DEFAULT) (NC 1) KEY PROMPTSTRING OPTIONS NOECHOFLG CONFIRMFLG NOCASEFLG PRINTLST ECHOEDFLG (EOL (CHARACTER (CHARCODE EOL))) (SPACE (CHARACTER (CHARCODE SPACE] (COND ((NULL FILE) (SETQ FILE T)) ((NEQ FILE T) (GO MESS))) (SETQ OLDTTBL (GETTERMTABLE)) (RESETSAVE (SETTERMTABLE ASKUSERTTBL)) (* ;; "ASKUSERTTBL has (CONTROL T) and (RAISE T) performed. The latter means that if the user types lower case characters, they are converted to uppercase. Note however that this will recognize lower case y and n. This is so the caller can provide y or n as a default, and distinguish the default cse from the case where the user types lowercase y or n (which will be converted to uppercase automatically by the terminal table) ASKUSERTTBL also has (ECHOMODE NIL) performed so can handle mistypings and confirations properly.") (* ;  "File can be a file name or a string") (COND (TYPEAHEAD (* ; "TYPEAHEAD permitted") (SETQ TYPEAHEAD (READP T)) (* ;  "used in case there is a mistake. in this case all typeahead is restored.") (GO MESS))) (LINBUF) (SYSBUF) (SETQ BUFS (CLBUFS NIL T READBUF)) (* ;; "Clear and save typeahead. This call to CLBUFS will ring the bells if there is any typeahead to warn the user to stop typing.") (COND [(LISTP MESS) (ASKUSERPRIN1 (CAR MESS)) (COND ((SETQ MESS (CDR MESS)) (ASKUSERPRIN1 " ")) (T (ASKUSERPRIN1 " ? "] (MESS (ASKUSERPRIN1 MESS) (SETQ MESS NIL))) (* ;; "The problem with user interactions such as this where typeahead is not allowed is that we have no way of knowing WHEN the user types something, i.e. if he typed it after seeing part of the message or no, without doing a DOBE before doing any printing, and this is not desirable as it produces a noticeable snag in teletype output. --- Therefore what we do is the following: all typeahead before the call to ASKUSER is cleared and saved for later restoration, and n the event ther is any typeahead, bells are rung to warn the user to stop typing. (this is done by the call to CLBUFS above.) --- After that we print something, either the first part of the message or the message itself, to give the user time to respond to the warning to stop typing. IN this interval, anything that is typed is thrown away. After printing the message, we do a DOBE, and then check to see if user has typed anything. If he has, this material is discarded, and bells printed again to warn him.") (DOBE) (COND ((READP T) (PRINTBELLS) (DOBE) (CLEARBUF T))) MESS (* ;  "MESS is either an atom or string or a list, in which case it is MAPRINTed") (COND ((NULL MESS) (* ;  "Either user didnt supply a message or else was printed above.") ) ((NLISTP MESS) (ASKUSERPRIN1 MESS)) (T (MAPRINT MESS T NIL " ? " NIL NIL LISPXPRNTFLG))) (COND ((OR (NOT (NUMBERP WAIT)) (NULL DEFAULT)) (* ;  "is : either a number, meaning wait that many seconds or NIL, meaning wait forever") (GO READLP))) [COND ((AND DEFAULT (NLISTP DEFAULT)) (SETQ DEFAULT (LIST DEFAULT] (COND ((NULL (WAITFORINPUT (ITIMES WAIT 1000))) (* ;  "Assume DEFAULT if nothing typed in WAIT/4 seconds.") (PRIN1 "..." T) (SETQ CHAR (CAR DEFAULT)) (GO INTERP))) READLP [COND ((AND (STRINGP FILE) (NOT (READP FILE T))) (SETQ FILE T) (SETQ OLDTTBL (GETTERMTABLE)) (RESETSAVE (SETTERMTABLE ASKUSERTTBL] (* ; "the string ran out") (SETQ CHAR (PEEKC FILE)) (* ;  "PEEKC used so that in case of $ as a key, askuser can do a READ.") (SETQ ECHOEDFLG NIL) (* ;  "this character has not yet been echoed. or read") (SETQ DEFAULT NIL) INTERP (* ;; "KEYLST is a list of elements of the form (KEY PROMPTSTRING . OPTIONS), where KEY is an atom or string (including the empty string) that characters are to be matched against, PROMPTSTRING a string or atom (NIL is equivalent to ''), and OPTIONS a list in property list format which can contain the properties (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON AUTOCOMPLETEFLG) Default options for the entire keylst can be supplied as an argument to ASKUSER --- --- A key is considered to be complete when (1) all of its characters have been matched and it is the only key left, i.e. there are no other keys for which this key is a substring, (2) all of its characters have been matched, and CONFIRMFLG is NIL, and the next character matches one of the keys on its KEYLST, (3) all of its characters have been matched, and a confirming character is typed, i.e. a c.r., space, or member of CONFIRMFLG (This option is used for implementing TENEX protocosl, where CONFIRMFLG is ($)) or (4) there is only one key left and a confirming character is typed. --- --- When a key is complete, PROMPTSTRING is printed. Then if CONFIRMFLG is non-NIL and the key was not completed via a confirming character (case 3 and 4 above) askuser waits for a confirming character. --- --- After confirmation, if KEYLST is non NIL, askuser descends into KEYLST. Otherwise askuser returns a value which is the value of (eval of) the RETURN field, if non-NIL, otherwise the result of packing all the keys or keystrings, if present --- see below on the path. --- At any point, the user can type an alt-mode which is equivalent to typing the next n shared characters. (if there are none, a bell is rung.) Typing a confirming character has the same effect as typing an alt-mode, i.e. the next n shared characters will be supplied. If the key is the only key left, confirmation is not required. (this is case 4 above). If the key is not the only key left, a bell is rung. --- --- special options: --- EXPLAINSTRING if non-nil, used in place of key/keystring + promptstring when user types a ? --- NOECHOFLG if non-nil, characters that are matched are not echoed --- KEYSTRING if non-nil, characters that are matched are echoed from keystring. The main reason for this feature echoing, since ASKUSER converts everything to a canonical upper case form, keys will always be represented in uppercase. KEYSTRING can be used to provide for lower case echoing, and for returning a lower case value. i.e. if the RETURN option is not specified, and KEYSTRING is specified, then KEYSTRING will be used in constructing the value to be returned, rather than KEY. --- PROMPTON if non-NIL, PROMPTSTRING is printed only when the key is confirmed with a member of PROMPTON. This feature is used for implementing TENEX protocols, in which case PROMPTON would be ($) Note that this doesnt make much sense unless CONFIRMFLG is also non-NIL and includes the elements on PROMPTON --- --- COMPLETEON when a confirming character is typed, the n characters that are supplied are not echoed unless the confirming charactter is a member of COMPLETEON. This is used for implementing tenex protocols in which case COMPLETEON is ($), i.e. user could complete a command with space or c.r. but completion and prompting would take place only for $ --- --- AUTOCOMPLETEFLG if T, says supply characters as soon as they are unambiguous, i.e. act as though alt-mode were typed after each character (but dont ring a bell) --- MACROCHARS, a list of characters and forms. if one of the characters is typed, and doesnt match as a key, then the form is evaluated for effect and everything else stays the same, e.g. ? could have been implemented this way. this feature is probably most useful when MACROCHARS is supplied on OPTIONSLST since one probably wants a global set of MACROCHARS for a call single call to askuser. --- --- & as a key matches any character. --- --- '' can be used as a key It starts out with all of its characters matched, so that it is complete if it is the only key left, (1) above, or the next character mtches one of the keys on its KEYLST, etc. --- --- $ can be used as a key to match the result of doing a READ. For example, the filepkg has as one of its entries on its keylst ('' 'file/list: ' KEYLST ($)) which means that if a character is typpd that does not match any of the other charactters on its keylst, the prompt message file/list: is printed, and a read is then performed and eturned as the value of the call to askuser. --- --- --- For the more common useage, KEY is the same as (KEY NIL CONFIRMFLG T), and (KEY . PROMPT) the same as (KEY PROMPT)") [SETQ KEYLST1 (for ENTRY in KEYLST eachtime (ASKUSERSETUP ENTRY) collect ENTRY when (COND ((ASKUSERCHAR CHAR (SETQ TEM (NTHCHAR KEY NC))) (* ;  "char matches the corresponding character in key.") T) ((OR TEM $$VAL (EQ CHAR '?)) (* ;; "There was another character in the key, and char didnt match it. The $$VAL check is to insure that once there has been a match with a character in a key atthis level, we do not treat space or c.r. as terminators, so that space and c.r. can be used as keys themselves, nor do we descend into subkeylists, and so thatthe user can specify a default match via '' as a place marker, and have it operate ONLY when other elements are not matched by placing it last on the keylst. e.g. if keylst is of the form ((c.r. --) -- ('' -- subkeylst)) and a c.r. is typed, matching wont go into subkeylst ADDTOFILES uses this feature") NIL) ((AND (NULL (ASKUSERLOOKUP 'CONFIRMFLG)) (ASKUSERLOOKUP 'KEYLST) (ASKUSER1 ENTRY CHAR)) (* ;; "We have already matched all the characters in key, and entry contains a lower keylst. and char matches one of its elements, therefore do any prompting necessary for this key, and descend") (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP 'KEYSTRING) KEY))) [AND (NULL NOECHOFLG) (SETQ PRINTLST (NCONC1 PRINTLST (OR (ASKUSERLOOKUP 'KEYSTRING) KEY] [AND PROMPTSTRING (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T] (* ;; "PRINTLST is maintained to implement the ? feature and to be able to replay the output to put on the history.") (SETQ KEYLST (ASKUSERLOOKUP 'KEYLST)) (SETQ NC 1) (* ;  "CHAR will then be matched aainst the lower keylst.") (GO INTERP)) ([COND ((LISTP CONFIRMFLG) (MEMB CHAR CONFIRMFLG)) (T (OR (EQ CHAR EOL) (EQ CHAR SPACE] (* ;; "all of its characters were matched, and this character was a c.r. or space. e.g. CHARLST= (CLISP CLISPFLG CLISPTRANFLG) and CLISP c.r. has been typed The check is made after the other checks so that space and carriage return themselves can be used in keys. Note that it doesnt matter whether confirmflg is T or not, the user can still use c.r. or space to terminate a key.") (AND (NULL NOECHOFLG) (SETQ PRINTLST (NCONC1 PRINTLST CHAR))) T] (ASKUSERSETUP (CAR KEYLST)) [COND (KEYLST1 (SETQ KEYLST KEYLST1) (GO RIGHT)) ((AND (NULL ANSWER) (EQ NC 1) (NULL DEFAULT) (OR (EQ CHAR SPACE) (EQ CHAR EOL))) (* ;  "user typed eol or space simply to keep dwim from defaulting on him.") (AND (NULL NOECHOFLG) (PRIN1 CHAR T)) (AND (READC FILE)) (GO READLP)) ([OR [EQ CHAR (CONSTANT (CHARACTER (CHARCODE ESCAPE] (COND ((LISTP CONFIRMFLG) (MEMB CHAR CONFIRMFLG)) (T (OR (EQ CHAR EOL) (EQ CHAR SPACE] (* ;; "altmode c.r. or space says supply characters from atoms in this level of keylst until there are two or more atms with different characters at thatposition. C.R. and space is same as alt mode except if there is only one atom, then return without confirmation after supplying the characters. If thee are not atms with common characters beyond this point, then ring a bell and take no action.") [COND ((NULL (SETQ TEM (ASKUSER$ KEYLST CHAR NC))) (GO WRONG)) (T (SETQ NC (ADD1 TEM] (AND (NULL DEFAULT) (READC FILE)) (COND ((NULL (CDR KEYLST)) (* ;  "only one. Therefore this character completes the key,") (GO COMPLETED)) ((OR (EQ CHAR SPACE) (EQ CHAR EOL)) (PRIN1 (CHARACTER (CHARCODE BELL)) T) (* ; "print a bell.") )) (GO NEXT)) ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR)) 'CHARDELETE) (SYNTAXP TEM 'LINEDELETE)) (* ; "control-a, q,") (GO RETRY)) ([AND (NULL DEFAULT) (EQ FILE T) (SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS] (READC T) (SETTERMTABLE OLDTTBL) (EVAL (CDR TEM)) (SETTERMTABLE ASKUSERTTBL) (GO READLP)) ((AND (NULL DEFAULT) (EQ CHAR '?) (EQ FILE T)) (TERPRI T) (READC T) [NLSETQ (PROGN (PRIN1 (OR (fetch (OPTIONS EXPLAINSTRING) of OPTIONSLST) (CONCAT "one of:" EOL)) T) (ASKUSEREXPLAIN KEYLST PRINTLST OPTIONSLST (OR (ASKUSERLOOKUP 'EXPLAINDELIMITER) EOL] (TERPRI T) [AND ORIGMESS (COND ((NLISTP ORIGMESS) (ASKUSERPRIN1 ORIGMESS)) (T (MAPRINT ORIGMESS T NIL " ? " NIL NIL LISPXPRNTFLG] [MAPC PRINTLST (FUNCTION (LAMBDA (X) (PRIN1 X T] (AND (NEQ NC 1) (PRIN1 (SUBSTRING [COND ((NLISTP (CAR KEYLST)) (CAR KEYLST)) (T (OR (fetch (ASKUSER KEYSTRING) of (CAR KEYLST)) (fetch (ASKUSER KEY) of (CAR KEYLST] 1 (SUB1 NC)) T)) (* ;; "These are the characters that have been matched on this level key, but not yet added to answer or printlst.") (GO READLP)) ([SETQ KEYLST1 (find X in KEYLST suchthat (SELECTC X ([LIST '& (CHARACTER (CHARCODE ESCAPE)) (PACKC (CHARCODE (ESCAPE ESCAPE] (SETQ KEY X) T) (AND (LISTP X) (SELECTC (CAR X) ('& (COND ((OR [NULL (SETQ TEM (LISTGET1 X 'CLASS] (APPLY* TEM CHAR)) (SETQ KEY (CAR X)) T))) ([LIST (CHARACTER (CHARCODE ESCAPE)) (PACKC (CHARCODE (ESCAPE ESCAPE] (SETQ KEY (CAR X)) T) (AND (LISTP (CAR X)) (SETQ KEY (CAR X] (COND ((EQ KEY '&) [SETQ KEYLST (LIST (CONS CHAR (AND (LISTP KEYLST1) (CDR KEYLST1] (GO RIGHT)) (T (* ; "altmode. or double-altmode") (* (AND (EQ FILE T)  (PRIN1 CHAR T))) (* ;; "The character would not have been echoed since the PEEKC was done with echomode off. Since it has already been seen by LISP, it wold not be echoed by the READ below, even though ECHOMODE would then be turned on. Therefore must print it.") (SETTERMTABLE OLDTTBL) (OR (PROG1 [NLSETQ (COND ([EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE] (SETQ TEM (READ FILE T))) [[EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE] (LET (READBUF) (DECLARE (SPECVARS READBUF)) (* ;; "since READ is used, rather than lispxread for $ key, we should not have readline be affected by readbuf, e.g. if user is redoing an event contaig an askuser, he wants to type in tuff again.") (SETQ TEM (READLINE T] (T (SETQ TEM (EVAL KEY] (SETTERMTABLE ASKUSERTTBL)) (GO RETRY)) (SETQ KEYLST (LIST (create ASKUSER using (LISTP KEYLST1) KEY _ TEM))) (SETQ NC (ADD1 (NCHARS TEM))) (SETQ ECHOEDFLG T) (* ;  "so that the character terminatng the read wont be echoed twice") [COND [(SYNTAXP [SETQ TEM (CHCON1 (SETQ CHAR (LASTC FILE] 'SEPR T) (* ;  "character was included as part of the read") (replace OPTIONS of (CAR KEYLST) with (CONS 'CONFIRMFLG (CONS (LIST CHAR) (fetch OPTIONS of (CAR KEYLST] ((SYNTAXP TEM 'BREAK T) (* ; "e.g. read of a lit") (GO READLP)) (T (SETQ CHAR (READC FILE] (* ;; "(COND ((EQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE)))) (* (61 . 965) 130 ASSIST.;8 NIL) (SETQ CHAR (READC FILE))) ((EQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE))))) (SETQ CHAR (LASTC FILE)) (replace OPTIONS of (CAR KEYLST) with (CONS (QUOTE CONFIRMFLG) (CONS (QUOTE (] )) (fetch (ASKUSER OPTIONS) of (CAR KEYLST)))))) ((LISTP KEY) (* (73 . 955) 107 ASSIST.;30 NIL)) (T (SHOULDNT)))") (SETQ DEFAULT '(T)) (* ;; "so wont attempt to read the character again. reason we have to read it here, in the case of read, is that it has already been echoed, and in the case of a lower keylst, there would be no way to psass on the information about it having been echoed without setting echoedflg to T. thus we cant go back to READLP, sice that wold set echoflg to NIL.") (GO INTERP] WRONG (* ; "user typed invalid answer") (AND (NEQ FILE T) (ERROR!)) (AND (NULL DEFAULT) (READC FILE)) (COND (TYPEAHEAD (GO RETRY1))) (PRINTBELLS) (DOBE) (CLEARBUF T) (GO READLP) RIGHT (* ; "character matched.") (AND (NULL DEFAULT) (READC FILE)) RIGHT1 (ASKUSERSETUP (CAR KEYLST)) (COND ((OR (CDR KEYLST) (ILESSP NC (NCHARS KEY))) (* ;  "More than one candidate. or this candidate not finished yet.") (AND (NULL NOECHOFLG) (EQ FILE T) (SETQ TEM (COND ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING)) (* ;; "primarily to allow specifying of echoing in lower case, even though askuser always converts to uppercase when it reads.") (NTHCHAR TEM NC)) (T CHAR))) (PRIN1 TEM T)) (SETQ NC (ADD1 NC)) [COND ((AND (ASKUSERLOOKUP 'AUTOCOMPLETEFLG) (SETQ TEM (ASKUSER$ KEYLST CHAR NC))) (COND ((AND (NULL (CDR KEYLST)) (EQ (SETQ NC TEM) (NCHARS KEY))) (GO COMPLETED)) (T (SETQ NC (ADD1 TEM] (GO NEXT))) (* ;  "There is only one entry left, and all of its characters are matched.") (AND (NULL NOECHOFLG) (EQ FILE T) (EQ NC (NCHARS KEY)) (SETQ TEM (COND ((SETQ TEM (ASKUSERLOOKUP 'KEYSTRING)) (NTHCHAR TEM NC)) (T CHAR))) (PRIN1 TEM T)) (* ;; "the character is the last one in the key. the case where a c.r. was typed to terminate a key is handled below.") COMPLETED (SETQ ANSWER (NCONC1 ANSWER (OR (ASKUSERLOOKUP 'KEYSTRING) KEY))) [AND (NULL NOECHOFLG) (SETQ PRINTLST (NCONC1 PRINTLST (OR (ASKUSERLOOKUP 'KEYSTRING) KEY] [AND PROMPTSTRING (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'PROMPTON] (MEMB CHAR TEM)) (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T] (* ;; "If PROMPTON is present, must wait till after confirmation to see if confirming charactter is PROMPTON (usually $). this enables tenex like protocols.") (AND (NULL NOECHOFLG) (EQ FILE T) (IGREATERP NC (NCHARS KEY)) (PRIN1 (COND ([AND (EQ CHAR EOL) (NULL (ASKUSERLOOKUP 'KEYLST] (* ;; "space is echoed for all confirming characters except on a terminal leaf,in which char isused itself.") CHAR) (T SPACE)) T)) (COND ([OR (NULL CONFIRMFLG) (COND ((LISTP CONFIRMFLG) (MEMB CHAR CONFIRMFLG)) (T (OR (EQ CHAR EOL) (EQ CHAR SPACE] (* ;; "CONFIRMFLG can be a list of characters that are acceptable for confirming. e.g. ($) can be used to implemente tenex like protocols.") (GO CONFIRMED)) (T (GO CONFIRM))) NEXT (SETQ DEFAULT (CDR DEFAULT)) (* ;; "DEFAULT stays one behind the current character so that we can tell if the character came from a default list.") (COND ((NULL DEFAULT) (GO READLP)) (T (SETQ CHAR (CAR DEFAULT)) (GO INTERP))) (GO INTERP) CONFIRM (COND ((ASKUSERLOOKUP 'PROMPTCONFIRMFLG) (PRIN1 " [confirm] " T))) [COND ((AND (STRINGP FILE) (NOT (READP FILE T))) (SETQ FILE T) (SETQ OLDTTBL (GETTERMTABLE)) (RESETSAVE (SETTERMTABLE ASKUSERTTBL] [SETQ CHAR (COND ((SETQ DEFAULT (CDR DEFAULT)) (CAR DEFAULT)) (T (READC FILE] (COND ((OR (SYNTAXP (SETQ TEM (CHCON1 CHAR)) 'CHARDELETE) (SYNTAXP TEM 'LINEDELETE)) (* ; "control-a or q") (GO RETRY)) [(LISTP CONFIRMFLG) (COND ((MEMB CHAR CONFIRMFLG) (* ; "used for TENEX mode.") [AND PROMPTSTRING (SETQ TEM (ASKUSERLOOKUP 'PROMPTON)) (MEMB CHAR TEM) (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 PROMPTSTRING T] (AND (NULL NOECHOFLG) (PRIN1 SPACE T)) (GO CONFIRMED] ((OR (EQ CHAR SPACE) (EQ CHAR EOL)) [COND ((NULL NOECHOFLG) (SETQ PRINTLST (NCONC1 PRINTLST (PRIN1 (COND ((NULL (ASKUSERLOOKUP 'KEYLST)) CHAR) (T SPACE)) T] (GO CONFIRMED)) ([SETQ TEM (FASSOC CHAR (ASKUSERLOOKUP 'MACROCHARS] (SETTERMTABLE OLDTTBL) (EVAL (CDR TEM)) (SETTERMTABLE ASKUSERTTBL) (GO CONFIRM))) (COND ((NEQ CHAR '?) (PRIN1 (PACKC (CHARCODE (BELL ?))) T) (DOBE) (CLEARBUF T))) (PRIN1 " [confirm] " T) (GO CONFIRM) CONFIRMED (COND ((SETQ TEM (ASKUSERLOOKUP 'KEYLST)) (SETQ KEYLST TEM) (SETQ NC 1) (GO NEXT))) (COND (LISPXPRNTFLG [MAPC PRINTLST (FUNCTION (LAMBDA (X) (ASKUSERPRIN1 X T] (* ;  "fakes the printing for the history list.") )) (COND (BUFS (BKBUFS BUFS))) (RETURN (COND [(SETQ TEM (OR (FMEMB 'RETURN OPTIONS) (FMEMB 'RETURN OPTIONSLST))) (SETTERMTABLE OLDTTBL) (COND ([SETQ TEM (NLSETQ (EVAL (CADR TEM] (* ;; "ASKUSERLOOKUP (QUOTE not) used since then couldnt distinguish case where RETURN NIL was specified from case where RETURN was not specified at all.") (* ;; "This permits user to return ANSWER as a list itself, or to take some other action, and then restart by simply generateing an error.") (CAR TEM)) (T (SETTERMTABLE ASKUSERTTBL) (GO RETRY] (ANSWER (PACK ANSWER)) (T (NOTCHECKED) KEY))) RETRY (COND (TYPEAHEAD (GO RETRY1))) (PRIN1 "___" T) (TERPRI T) (DOBE) (CLEARBUF T) (SETQ KEYLST ORIGKEYLST) (SETQ PRINTLST NIL) (SETQ NC 1) (SETQ ANSWER NIL) (GO READLP) RETRY1 (* ;; "User has typed ahead before the call to askuser1 and his resonse is invalid. therefore assume he didnt know that askuser would be called and his typeahead was intended for what follows. clear and ave the typeahead and continue with interaction.") (LINBUF) (SYSBUF) (SETQ BUFS (CLBUFS NIL T READBUF)) [SETQ TEM (APPLY 'CONCAT (NCONC ANSWER [AND (NEQ NC 1) (LIST (SUBSTRING (COND ((LISTP (CAR KEYLST)) (CAAR KEYLST)) (T (CAR KEYLST))) 1 (SUB1 NC] (LIST CHAR] [COND ((NULL BUFS) (SETQ BUFS (CONS NIL TEM))) (T (RPLACD BUFS (COND ((CDR BUFS) (CONCAT TEM (CDR BUFS))) (T TEM] (SETQ TYPEAHEAD NIL) (* ; "so this is only done once") (SETQ ANSWER NIL) (SETQ KEYLST ORIGKEYLST) (SETQ MESS ORIGMESS) (SETQ DEFAULT ORIGDEFAULT) (SETQ PRINTLST NIL) (TERPRI T) (GO MESS)))]) (ASKUSERLOOKUP [LAMBDA (FIELD) (* bvm%: "26-Apr-86 17:14") (* * this wuld be just a fetch, xcept want to lok it up on optionslst if not  found on options.) (CADR (OR (FMEMB FIELD OPTIONS) (FMEMB FIELD OPTIONSLST]) (ASKUSERCHAR [LAMBDA (C1 C2) (* bvm%: "26-Apr-86 17:27") (COND ((EQ C1 C2)) ((AND (NULL NOCASEFLG) C2) (SETQ C1 (CHCON1 C1)) (SETQ C2 (CHCON1 C2)) (COND [(AND (IGEQ C1 (CHARCODE a)) (ILEQ C1 (CHARCODE z))) (EQ C2 (IDIFFERENCE C1 (IDIFFERENCE (CHARCODE a) (CHARCODE A] ((AND (IGEQ C2 (CHARCODE a)) (ILEQ C2 (CHARCODE z))) (EQ C1 (IDIFFERENCE C2 (IDIFFERENCE (CHARCODE a) (CHARCODE A]) (ASKUSER$ [LAMBDA (KEYLST CHAR NC) (* bvm%: "26-Apr-86 17:13") (for ENTRY bind NC0 KEY0 TEM in KEYLST eachtime [SETQ KEY (COND ((NLISTP ENTRY) ENTRY) (T (fetch (ASKUSER KEY) of ENTRY] when [AND [NEQ KEY (CONSTANT (CHARACTER (CHARCODE ESCAPE] (NEQ KEY (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE] do [COND ((NULL KEY0) (* first time through) [SETQ KEY0 (COND ((NLISTP (CAR KEYLST)) (CAR KEYLST)) (T (fetch (ASKUSER KEY) of (CAR KEYLST] (SETQ NC0 (NCHARS KEY0))) (T (* Goes through keylst and looks at each key and determines the largest N for  which NTHCHAR of thatcharacter is equal for every atom.) (SETQ NC0 (for I from 1 to NC0 while (EQ (NTHCHARCODE KEY I) (NTHCHARCODE KEY0 I)) finally (RETURN (SUB1 I] finally (COND ((OR (NULL NC0) (ILESSP NC0 NC)) (* all atoms have different characters  at this position.) (RETURN NIL))) (ASKUSERSETUP (CAR KEYLST)) [SETQ TEM (AND (OR [NULL (SETQ TEM (ASKUSERLOOKUP 'COMPLETEON] (MEMB CHAR TEM)) (SUBSTRING (OR (ASKUSERLOOKUP 'KEYSTRING) KEY) NC (COND ((EQ (NCHARS KEY0) NC0) (* reason for this is in case KEYSTRING is longer, will get all of it.) -1) (T NC0] (* if COMPLETEON is $ means only complete on alt-mode.  this is used for tenex type protocol) (AND (NULL NOECHOFLG) TEM (PRIN1 TEM T)) (* Reason for not just using value of noechoflg is that askusersetup oul have  set noechoflg to T when reading from a string in order to suppress echoing of  the character, but this does not mean that we do not echo the characters that  are supplied for copleting.) (RETURN NC0]) (ASKUSER1 [LAMBDA (ENTRY CHAR) (* DD%: "26-Oct-81 12:34") (* We know that ENTRY contains a subkeylst.  This function sees if char could conceivably match one of the entries on  keylst.) (thereis ENTRY bind TEM in (fetch (ASKUSER KEYLST) of ENTRY) eachtime [SETQ TEM (COND ((NLISTP ENTRY) ENTRY) (T (fetch (ASKUSER KEY) of ENTRY] suchthat (OR (EQ TEM '&) [EQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE] [EQ TEM (CONSTANT (PACKC (CHARCODE (ESCAPE ESCAPE] (LISTP TEM) (EQ (SETQ TEM (NTHCHAR TEM 1)) CHAR) (AND (NULL TEM) (LISTP ENTRY) (LISTP (CDR ENTRY)) (ASKUSER1 ENTRY CHAR]) (ASKUSERSETUP [LAMBDA (ENTRY) (* bvm%: "26-Apr-86 17:13") (* Sets free variables KEY,  CONFIRMFLG, QUIETFLG, and PROMPTSTRING) (PROG (TEM) [COND [(NLISTP ENTRY) (SETQ KEY ENTRY) (SETQ PROMPTSTRING NIL) (SETQ OPTIONS NIL) (* The default is for NOECHOFLG to be NIL and CONFIRMFLG to be T.) (SETQ CONFIRMFLG (COND ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST)) (CADR TEM)) (T T] [(NLISTP (CDR ENTRY)) (SETQ KEY (CAR ENTRY)) (SETQ PROMPTSTRING (CDR ENTRY)) (SETQ OPTIONS NIL) (SETQ CONFIRMFLG (COND ((SETQ TEM (MEMB 'CONFIRMFLG OPTIONSLST)) (CADR TEM)) (T T] (T (SETQ KEY (fetch (ASKUSER KEY) of ENTRY)) (SETQ PROMPTSTRING (fetch (ASKUSER PROMPTSTRING) of ENTRY)) (SETQ OPTIONS (fetch (ASKUSER OPTIONS) of ENTRY)) (SETQ CONFIRMFLG (ASKUSERLOOKUP 'CONFIRMFLG] (SETQ NOECHOFLG (ASKUSERLOOKUP 'NOECHOFLG)) (SETQ NOCASEFLG (ASKUSERLOOKUP 'NOCASEFLG)) (AND ECHOEDFLG (SETQ NOECHOFLG T)) (COND ((AND (NEQ FILE T) (STRINGP FILE) (READP FILE T)) (SETQ NOECHOFLG T) (SETQ PROMPTSTRING NIL) (* askusersetup is called after the character has been read.  Thus, this sets noechoflg to T and promptstring to NIL only if there are more  characters to be read. However, the check on whether or not the character JUST  read is to bechoed alsoincludes an (EQ FILE T) check) ]) (ASKUSEREXPLAIN [LAMBDA (KEYLST PREV OPTIONSLST DELIMITER) (* bvm%: "26-Apr-86 17:13") (MAPC KEYLST (FUNCTION (LAMBDA (ENTRY) (PROG (KEY CONFIRMFLG NOECHOFLG PROMPTSTRING TEM OPTIONS (FILE T)) (ASKUSERSETUP ENTRY) (COND ((SETQ TEM (ASKUSERLOOKUP 'KEYLST)) (* entry is of the form  (key prompt charlst)) (ASKUSEREXPLAIN TEM [COND ((SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS)) (* reason for not using askuserlookup is that don't want top level  explainstring on ptionslst, if any. doesnt make sense to print it each time.  it is printed only once.) (APPEND PREV (LIST TEM))) (T (APPEND PREV (AND (NULL NOECHOFLG) (LIST (OR (ASKUSERLOOKUP 'KEYSTRING) KEY))) (AND PROMPTSTRING (LIST PROMPTSTRING] OPTIONSLST DELIMITER) (RETURN))) [MAPC PREV (FUNCTION (LAMBDA (X) (COND ((LISTP X) (MAPRINT X T)) (T (PRIN1 X T] [COND [(SETQ TEM (fetch (OPTIONS EXPLAINSTRING) of OPTIONS)) (COND ((LISTP TEM) (MAPRINT TEM T)) (T (PRIN1 TEM T] ((SETQ TEM (OR (ASKUSERLOOKUP 'KEYSTRING) KEY)) (AND (NULL NOECHOFLG) [NEQ TEM (CONSTANT (CHARACTER (CHARCODE ESCAPE] (NEQ TEM '&) (PRIN1 TEM T)) (* If the user wants to explain the & or $, he can include the appropriate text  in the prompt field.) (AND PROMPTSTRING (PRIN1 PROMPTSTRING T] (AND (NEQ (POSITION T) 0) (PRIN1 DELIMITER T)) (RETURN]) (ASKUSERPRIN1 [LAMBDA (X NODOFLG) (* wt%: % 4-DEC-75 00%:39) (* does a lispxprin1 if lispxprntflg is non-NIL.  used to be done by having everythin printed with lispxprin1 and doing a  resetsave on lisxpprintflg, but this costs several conses each call.) (COND ((NULL LISPXPRNTFLG) (OR NODOFLG (PRIN1 X T))) (T (LISPXPRIN1 X T NIL NODOFLG))) X]) (MAKEKEYLST [LAMBDA (LST DEFAULTKEY LCASFLG AUTOCOMPLETEFLG) (* wt%: "14-NOV-78 02:03") (PROG (TEM) (RETURN (NCONC [SETQ TEM (MAPCAR LST (FUNCTION (LAMBDA (KEY) (LIST KEY NIL 'KEYSTRING (CONCAT (COND ((AND LCASFLG (EQUAL KEY (U-CASE KEY))) (* when ucasep gets in system, use it  instead) (L-CASE KEY)) (T KEY)) " ") 'CONFIRMFLG T 'AUTOCOMPLETEFLG AUTOCOMPLETEFLG 'RETURN (KWOTE KEY] [for X in TEM bind KEYSTRING as I from 1 collect (SETQ KEYSTRING (LISTGET X 'KEYSTRING)) (LIST I KEYSTRING 'NOECHOFLG T 'EXPLAINSTRING (CONCAT I " - " KEYSTRING) 'CONFIRMFLG T 'RETURN (LIST 'PROGN '(TERPRI T) (KWOTE (CAR X] (COND [(NULL DEFAULTKEY) (LIST '("No - none of the above " "" CONFIRMFLG T AUTOCOMPLETEFLG T RETURN NIL] ((LISTP DEFAULTKEY) (* so user can specify no default key by simply calling with defaultkey=T) (LIST DEFAULTKEY]) ) (* ;; "RMK: Avoid literal CR's on files.") (RPAQ? DEFAULTKEYLST `[[Y ,(CONCAT "es" (CHARACTER (CHARCODE EOL] (N ,(CONCAT "o" (CHARACTER (CHARCODE EOL]) (RPAQ? ASKUSERTTBL (COPYTERMTABLE)) (DECLARE%: DONTEVAL@LOAD DOCOPY (CONTROL T ASKUSERTTBL) (ECHOMODE NIL ASKUSERTTBL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD ASKUSER (KEY PROMPTSTRING . OPTIONS) (SYSTEM)) (PROPRECORD OPTIONS (KEYLST CONFIRMFLG RETURN EXPLAINSTRING NOECHOFLG KEYSTRING PROMPTON COMPLETEON AUTOCOMPLETEFLG MACROCHARS NOCASEFLG PROMPTCONFIRMFLG CLASS ) (SYSTEM)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTKEYLST ASKUSERTTBL) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS ASKUSER COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1432 50029 (ASKUSER 1442 . 37029) (ASKUSERLOOKUP 37031 . 37359) (ASKUSERCHAR 37361 . 38020) (ASKUSER$ 38022 . 40930) (ASKUSER1 40932 . 41963) (ASKUSERSETUP 41965 . 44094) (ASKUSEREXPLAIN 44096 . 47291) (ASKUSERPRIN1 47293 . 47769) (MAKEKEYLST 47771 . 50027))))) STOP \ No newline at end of file diff --git a/sources/ASTACK b/sources/ASTACK new file mode 100644 index 00000000..1017df1c --- /dev/null +++ b/sources/ASTACK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "23-May-91 14:25:00" |{PELE:MV:ENVOS}SOURCES>ASTACK.;4| 43099 changes to%: (FNS \STKARG) previous date%: "20-Feb-91 13:47:06" |{PELE:MV:ENVOS}SOURCES>ASTACK.;3|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ASTACKCOMS) (RPAQQ ASTACKCOMS [(COMS (* ; "ARG and SETARG, unusual cases") (FNS ARG SETARG \ARG \ARGPTR \SETARG)) (COMS (FNS \RETURN \STACKARGPTR)) (COMS (* ; "User level stack management") (FNS STKNTH STKNTHNAME STKNAME SETSTKNAME) (FNS STKPOS STKSCAN RETFROM RETTO RESUME \RESUME) (FNS STKARG \STKARG SETSTKARG STKARGNAME \SPREADFRAMEP SETSTKARGNAME STKNARGS FRAMESCAN \INTERPFRAMENT \FRAMESCAN \VAROFFSET)) (COMS (* ; "finalization for stackps") (FNS \RECLAIMSTACKP)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML SETARG ARG) (LAMA]) (* ; "ARG and SETARG, unusual cases") (DEFINEQ (ARG [NLAMBDA (VAR M) (* lmm "24-JUL-81 07:43") (GETBASEPTR \STACKSPACE (\ARGPTR VAR (\EVAL M]) (SETARG [NLAMBDA (VAR M X) (* lmm "24-JUL-81 07:43") (PUTBASEPTR \STACKSPACE (\ARGPTR VAR (\EVAL M)) (\EVAL X]) (\ARG [LAMBDA (VAR M) (* lmm "24-JUL-81 07:43") (* ;; "Version of ARG which doesn't EVAL 2nd argument") (GETBASEPTR \STACKSPACE (\ARGPTR VAR M]) (\ARGPTR [LAMBDA (VAR N) (* ; "Edited 18-Feb-91 16:51 by jds") (* ;;; "Returns a pointer to the basic frame corresponding to the lambda* variable VAR, and tests that N is a legal arg#") (PROG ((FRAME (\MYALINK)) (A (NEW-SYMBOL-CODE VAR (\ATOMVALINDEX VAR))) (INTERPDEF (fetch (LITATOM DEFPOINTER) of '\INTERPRETER)) BFLINK P DEF NARGS) LP (COND ((fetch (FX INVALIDP) of FRAME) (* ; "No frame found") (LISPERROR "ILLEGAL ARG" VAR))) (COND ((EQ (SETQ DEF (fetch (FX FNHEADER) of FRAME)) INTERPDEF) (* ;  "See if this is \INTERPRETER running a LAMBDA*") (OR [AND (SETQ P (\VAROFFSET FRAME A)) (EQ P (+ (fetch (BF IVAR) of (SETQ BFLINK (fetch (FX BLINK) of FRAME))) (UNFOLD (SETQ NARGS (SUB1 (fetch (BF NARGS) of BFLINK))) WORDSPERCELL] (GO NXT))) [(AND (EQ (fetch (FNHEADER NA) of DEF) -1) (\VAROFFSET FRAME A)) (* ; "FRAME is a Lambda nospread, and binds A. Used to insist that A also be in slot PVAR0, but that's an awkward restriction now. Maybe should check that A's value is same as NARGS") (SETQ NARGS (fetch (BF NARGS) of (SETQ BFLINK (fetch (FX BLINK) of FRAME] (T (GO NXT))) (* ;  "Found the variable as the first PROG variable of a LSTARP frame") [RETURN (COND ((AND (> N 0) (<= N NARGS)) (+ (fetch (BF IVAR) of BFLINK) (UNFOLD (SUB1 N) WORDSPERCELL))) (T (LISPERROR "ILLEGAL ARG" N] NXT (SETQ FRAME (fetch (FX ALINK) of FRAME)) (GO LP]) (\SETARG [LAMBDA (VAR M X) (* lmm "24-JUL-81 07:43") (* ;; "Version of SETARG which doesn't eval 2nd and 3rd arguments.") (PUTBASEPTR \STACKSPACE (\ARGPTR VAR M) X]) ) (DEFINEQ (\RETURN [LAMBDA (X) (* bvm%: "11-Nov-86 11:44") (DECLARE (LOCALVARS . T)) (* ;; "for use by LLBREAK--call RAID, then simulate the RETURN opcode.") (RAID X) (PROG1 X (\SMASHLINK NIL (SETQ X (fetch (FX CLINK) of (\MYALINK))) X]) (\STACKARGPTR [LAMBDA (POS) (* bvm%: " 7-Oct-86 22:07") (* ;;  "return the index of the frame extension corresponding to POS or cause appropriate error") (COND [(OR (STACKP POS) (TYPENAMEP POS 'PROCESS)) (* ;  "if POS is STACKP, it is merely the contents") (LET ((FRAME (fetch EDFXP of POS))) (COND ((OR (EQ FRAME 0) (AND (fetch (FX INVALIDP) of (fetch (FX CLINK) of FRAME)) (NEQ (fetch (FX FRAMENAME) of FRAME) T))) (* ; "Either stack pointer has been released explicitly, or somebody has already returned to/around the frame in question") (LISPERROR "STACK PTR HAS BEEN RELEASED" POS)) (T FRAME] (T (PROG ((FX (\MYALINK)) (P POS)) [COND ((NULL POS) (* ;  "those functions which allow NIL should explicitly check for it.") (LISPERROR "ILLEGAL STACK ARG" POS)) [(EQ POS T) (* ;; "scan up for top frame. This could possibly be a constant, although there might be some circumstances where it could move") (PROG NIL TOPLP (COND ([NOT (fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of FX] (SETQ FX P) (GO TOPLP] [(NUMBERP POS) (COND ((EQ (SETQ P (FIX POS)) 0) (SETQ P 1))) (COND [(IGREATERP P 0) (* ; "Search ALinks") (PROG NIL ALP (COND ((fetch (FX INVALIDP) of (SETQ FX (fetch (FX ALINK) of FX))) (LISPERROR "ILLEGAL STACK ARG" POS)) ((NEQ (SETQ P (SUB1 P)) 0) (GO ALP] (T (* ; "Search CLinks") (PROG NIL (SETQ P (IMINUS P)) CLP (COND ((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX))) (LISPERROR "ILLEGAL STACK ARG" POS)) ((NEQ (SETQ P (SUB1 P)) 0) (GO CLP] (T (* ;  "implicit STKPOS searching for a given name") (PROG NIL SCNLP (COND ((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX))) (LISPERROR "ILLEGAL STACK ARG" POS)) ((NOT (EQMEMB (\STKNAME FX) POS)) (GO SCNLP] (COND ((IGEQ (fetch (FX USECNT) of FX) \MAXSAFEUSECOUNT) (LISPERROR "ILLEGAL STACK ARG" POS))) (RETURN FX]) ) (* ; "User level stack management") (DEFINEQ (STKNTH [LAMBDA (N IPOS OPOS) (* bvm%: " 5-Feb-85 15:50") (PROG ((I (OR N -1)) CFLAG FRAME) [COND ((ILESSP I 0) (SETQ CFLAG T) (SETQ I (IMINUS I] [SETQ FRAME (COND (IPOS (\STACKARGPTR IPOS)) ((EQ I 0) (LISPERROR "ILLEGAL STACK ARG" N)) (T (add I -1) (\MYALINK] LP [COND ((fetch (FX INVALIDP) of FRAME) (RELSTK OPOS) (RETURN)) ((EQ I 0) (RETURN (\MAKESTACKP OPOS FRAME))) (CFLAG (SETQ FRAME (fetch (FX CLINK) of FRAME))) (T (SETQ FRAME (fetch (FX ALINK) of FRAME] (SETQ I (SUB1 I)) (GO LP]) (STKNTHNAME [LAMBDA (N POS) (* bvm%: " 5-Feb-85 15:51") (PROG ((I (OR N -1)) CFLAG FRAME) [COND ((ILESSP I 0) (SETQ CFLAG T) (SETQ I (IMINUS I] [SETQ FRAME (COND (POS (\STACKARGPTR POS)) ((EQ I 0) (LISPERROR "ILLEGAL STACK ARG" N)) (T (add I -1) (\MYALINK] LP [COND ((fetch (FX INVALIDP) of FRAME) (RETURN)) ((EQ I 0) (RETURN (fetch (FX FRAMENAME) of FRAME))) (CFLAG (SETQ FRAME (fetch (FX CLINK) of FRAME))) (T (SETQ FRAME (fetch (FX ALINK) of FRAME] (SETQ I (SUB1 I)) (GO LP]) (STKNAME [LAMBDA (POS) (* lmm " 2-Jul-86 12:37") (\STKNAME (\STACKARGPTR POS]) (SETSTKNAME [LAMBDA (POS NAME) (* bvm%: "15-Aug-84 11:13") (PROG ((FRAME (\STACKARGPTR POS)) FNH) [COND ((fetch (FX VALIDNAMETABLE) of FRAME) (* ;  "There is already a copied nametable here, just smash it") (SETQ FNH (fetch (FX NAMETABLE#) of FRAME)) (UNINTERRUPTABLY (replace (FX VALIDNAMETABLE) of FRAME with NIL) (* ;  "Do this so that the stack remains consistent, even while uninterruptable. This for SPY etc.") (COND ((EQ (\HILOC FNH) \STACKHI) (* ; "Don't refcnt on the stack") (replace (FNHEADER %#FRAMENAME) of FNH with NAME)) (T (replace (FNHEADER FRAMENAME) of FNH with NAME))) (replace (FX VALIDNAMETABLE) of FRAME with T))) (T (SETQ FNH (\COPYFNHEADER (fetch (FX FNHEADER) of FRAME))) (replace (FNHEADER FRAMENAME) of FNH with NAME) (UNINTERRUPTABLY (replace (FX NAMETABLE) of FRAME with FNH))] (RETURN NAME]) ) (DEFINEQ (STKPOS [LAMBDA (FRAMENAME N IPOS OPOS) (* lmm " 2-Jul-86 13:02") (PROG (FLAG [FX (COND ((NULL IPOS) (\MYALINK)) (T (\STACKARGPTR IPOS] (I (OR N -1))) [COND ((IGREATERP 0 I) (SETQ FLAG (SETQ I (IDIFFERENCE 0 I] LP [COND ((EQ (\STKNAME FX) FRAMENAME) (COND ((ILEQ (SETQ I (SUB1 I)) 0) (RETURN (\MAKESTACKP OPOS FX] (COND ([fetch (FX INVALIDP) of (SETQ FX (COND (FLAG (fetch (FX CLINK) of FX)) (T (fetch (FX ALINK) of FX] (RELSTK OPOS) (RETURN))) (GO LP]) (STKSCAN [LAMBDA (VAR IPOS OPOS) (* ; "Edited 19-Feb-91 22:58 by jds") (AND (LITATOM VAR) (PROG [[FX (COND ((NULL IPOS) (\MYALINK)) (T (\STACKARGPTR IPOS] (A (NEW-SYMBOL-CODE VAR (\ATOMVALINDEX VAR] LP (COND ((\FRAMESCAN FX A) (RETURN (\MAKESTACKP OPOS FX))) ((fetch (FX INVALIDP) of (SETQ FX (fetch (FX ALINK) of FX))) (RELSTK OPOS) (RETURN)) (T (GO LP]) (RETFROM [LAMBDA (POS VAL FLG) (* bvm "22-Nov-86 15:34") (LET ((P (\STACKARGPTR POS))) (COND ((fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of P))) (LISPERROR "ILLEGAL RETURN" VAL))) (\SMASHRETURN NIL P (AND FLG POS)) VAL]) (RETTO [LAMBDA (POS VAL FLG) (* bvm "22-Nov-86 15:34") (if (EQ POS T) then (RESET) else (LET ((P (\STACKARGPTR POS))) (\SMASHRETURN NIL P (AND FLG POS)) VAL]) (RESUME [LAMBDA (FROMPTR TOPTR VAL) (* bvm%: "11-Nov-86 20:56") (* ;; "FROMPTR is a stkptr which is smashed to contain a pointer to the caller of RESUME. Control is transfered to the frame specified by TOPTR, releasing that stack pointer. A call to this RESUME returns VAL as the value of the RESUME specified by TOPTR.") (PROG [[FROMFX (fetch EDFXP of (\DTEST FROMPTR 'STACKP] (TOFX (fetch EDFXP of (\DTEST TOPTR 'STACKP] (COND ((OR (fetch (FX INVALIDP) of TOFX) (fetch (FX INVALIDP) of (fetch (FX CLINK) of TOFX))) (* ;  "released stack pointer, or stack pointer that has been thrown thru") (LISPERROR "STACK PTR HAS BEEN RELEASED" TOPTR))) (UNINTERRUPTABLY (COND ((NOT (fetch (FX INVALIDP) of FROMFX)) (* ;  "Release FROMPTR if it hasn't been yet") (\DECUSECOUNT FROMFX))) (replace EDFXP of FROMPTR with (\MYALINK)) (replace EDFXP of TOPTR with 0) (\RESUME TOFX))) VAL]) (\RESUME [LAMBDA (FRAME) (* bvm%: " 5-Jun-85 17:08") (replace (FX ACLINK) of (\MYALINK) with FRAME) FRAME]) ) (DEFINEQ (STKARG [LAMBDA (N POS DEFAULT) (* lmm " 7-Nov-86 01:37") (LET ((VAL "NO SUCH ARG")) (CL:WHEN (EQ VAL (SETQ VAL (\STKARG N (\STACKARGPTR POS) DEFAULT VAL))) (LISPERROR "ILLEGAL STACK ARG" N)) VAL]) (\STKARG [LAMBDA (N FRAME DEFAULT NOSUCH) (* ; "Edited 23-May-91 12:49 by jds") (* ;; "Find the value for variable N looking from fRAME upward (??)") (PROG ((INDEX N) BLINK NARGS NT NTSIZE) (SETQ NT (\INTERPFRAMENT FRAME)) [COND ((LITATOM N) (SETQ INDEX (OR (\FRAMESCAN FRAME (NEW-SYMBOL-CODE N (\ATOMVALINDEX N)) NT) (RETURN NOSUCH] (COND ((ILESSP INDEX 1) (RETURN NOSUCH)) [NT (* ; "Interpreter frame") (COND [(\SPREADFRAMEP FRAME) (OR [AND (IGREATERP INDEX 0) (ILEQ INDEX (SETQ NARGS (fetch (BF NARGS) of (SETQ BLINK (fetch (FX BLINK) of FRAME] (RETURN NOSUCH)) (SETQ INDEX (IPLUS (fetch (BF IVAR) of BLINK) (UNFOLD (SUB1 INDEX) WORDSPERCELL] ([OR [IGEQ INDEX (FOLDLO (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT)) (CONSTANT (WORDSPERNAMEENTRY] (NULL-NTENTRY (GETSTKNAMEENTRY (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)) (UNFOLD (IPLUS INDEX -1) (CONSTANT (WORDSPERNAMEENTRY] (* ; "Out of range") (RETURN NOSUCH)) (T (SETQ INDEX (IPLUS (SELECTC (NTSLOT-VARTYPE (GETSTKNTOFFSETENTRY [SETQ NT (\ADDBASE NT (IPLUS NTSIZE (UNFOLD (SUB1 INDEX) (CONSTANT ( WORDSPERNAMEENTRY ))) (fetch (FNHEADER OVERHEADWORDS ) of T] 0)) (IVARCODE (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME) )) (PVARCODE (fetch (FX FIRSTPVAR) of FRAME)) (SHOULDNT)) (UNFOLD (NTSLOT-OFFSET (GETSTKNTOFFSETENTRY NT 0)) WORDSPERCELL] [[ILEQ INDEX (SETQ NARGS (fetch (BF NARGS) of (SETQ BLINK (fetch (FX BLINK) of FRAME] (SETQ INDEX (IPLUS (fetch (BF IVAR) of BLINK) (UNFOLD (SUB1 INDEX) WORDSPERCELL] [(ILEQ (SETQ INDEX (IDIFFERENCE INDEX NARGS)) (fetch (FX FNHEADER NLOCALS) of FRAME)) (SETQ INDEX (IPLUS (fetch (FX FIRSTPVAR) of FRAME) (UNFOLD (SUB1 INDEX) WORDSPERCELL] (T (RETURN NOSUCH))) (RETURN (COND ((NOT (fetch (PVARSLOT BOUND) of (STACKADDBASE INDEX))) DEFAULT) (T (STACKGETBASEPTR INDEX]) (SETSTKARG [LAMBDA (N POS VAL) (* ; "Edited 19-Feb-91 22:49 by jds") (PROG ((FRAME (\STACKARGPTR POS)) (INDEX N) BLINK NARGS NT NTSIZE) (SETQ NT (\INTERPFRAMENT FRAME)) [COND ((LITATOM N) (SETQ INDEX (OR (\FRAMESCAN FRAME (NEW-SYMBOL-CODE N (\ATOMVALINDEX N)) NT) (LISPERROR "ILLEGAL STACK ARG" N] [SETQ INDEX (COND ((ILESSP INDEX 1) (LISPERROR "ILLEGAL STACK ARG" INDEX)) [NT (* ; "Interpreter frame") (COND ([OR [IGEQ INDEX (FOLDLO (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT)) (CONSTANT (WORDSPERNAMEENTRY] (NULL-NTENTRY (GETSTKNAMEENTRY NT (IPLUS (fetch (FNHEADER OVERHEADWORDS ) of T) (UNFOLD (SUB1 INDEX) (CONSTANT ( WORDSPERNAMEENTRY ] (* ; "Out of range") (LISPERROR "ILLEGAL STACK ARG" INDEX)) (T (IPLUS (SELECTC (NTSLOT-VARTYPE (GETSTKNTOFFSETENTRY [SETQ NT (\ADDBASE NT (IPLUS NTSIZE (fetch (FNHEADER OVERHEADWORDS ) of T) (UNFOLD INDEX (CONSTANT ( WORDSPERNAMEENTRY ] 0)) (IVARCODE (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME))) (PVARCODE (fetch (FX FIRSTPVAR) of FRAME)) (SHOULDNT)) (UNFOLD (NTSLOT-OFFSET (GETSTKNTOFFSETENTRY NT 0)) WORDSPERCELL] ([ILEQ INDEX (SETQ NARGS (fetch (BF NARGS) of (SETQ BLINK (fetch (FX BLINK) of FRAME] (IPLUS (fetch (BF IVAR) of BLINK) (UNFOLD (SUB1 INDEX) WORDSPERCELL))) ((ILEQ (SETQ INDEX (IDIFFERENCE INDEX NARGS)) (fetch (FX FNHEADER NLOCALS) of FRAME)) (IPLUS (fetch (FX FIRSTPVAR) of FRAME) (UNFOLD (SUB1 INDEX) WORDSPERCELL))) (T (LISPERROR "ILLEGAL STACK ARG" N] (RETURN (COND ((fetch (PVARSLOT BOUND) of (STACKADDBASE INDEX)) (STACKPUTBASEPTR INDEX VAL)) (T (LISPERROR "ILLEGAL STACK ARG" N]) (STKARGNAME [LAMBDA (N POS) (* ; "Edited 18-Feb-91 16:55 by jds") (* ;; "Given an interpreted frame and an argument number, return the name of that argument (actually, just the n-th NameTable entry)") (* ;; "OR, Given the name of an argument and a frame to start looking from, return the nametable offset entry.") (* ;; "Brother, what an overloading!!") (PROG ((FRAME (\STACKARGPTR POS)) NT NM (NTENTRY N) NARGS) (SETQ NT (\INTERPFRAMENT FRAME)) [COND ((LITATOM NTENTRY) (SETQ NTENTRY (\FRAMESCAN FRAME (NEW-SYMBOL-CODE NTENTRY (\ATOMVALINDEX NTENTRY)) NT] [COND (NT (* ; "Interpreted frame") (RETURN (COND ((\SPREADFRAMEP FRAME) (* (LIST (QUOTE ARG)  (\INDEXATOMVAL (\GETBASE NT  (fetch (FNHEADER OVERHEADWORDS) of T)))  N)) NIL) (T (OR [AND (IGREATERP NTENTRY 0) (ILESSP NTENTRY (fetch (FNHEADER NTSIZE) of NT)) (\INDEXATOMVAL (GETSTKNAMEENTRY (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)) (UNFOLD (IPLUS NTENTRY -1) (CONSTANT (WORDSPERNAMEENTRY] (LISPERROR "ILLEGAL STACK ARG" N] (SETQ NT (fetch (FX NAMETABLE) of FRAME)) [SETQ NTENTRY (COND ((ILEQ NTENTRY 0) (LISPERROR "ILLEGAL STACK ARG" N)) ([ILEQ NTENTRY (SETQ NARGS (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME] (MAKE-NTENTRY IVARCODE (SUB1 NTENTRY))) ((ILEQ (SETQ NTENTRY (IDIFFERENCE NTENTRY NARGS)) (fetch (FNHEADER NLOCALS) of NT)) (COND ([NOT (fetch (PVARSLOT BOUND) of (STACKADDBASE (IPLUS (fetch (FX FIRSTPVAR) of FRAME) (UNFOLD (SUB1 NTENTRY) WORDSPERCELL] (RETURN))) (MAKE-NTENTRY PVARCODE (SUB1 NTENTRY))) (T (LISPERROR "ILLEGAL STACK ARG" N] (RETURN (for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of NT) (fetch (FNHEADER NTSIZE) of NT)) by (CONSTANT (WORDSPERNTOFFSETENTRY)) until (NULL-NTENTRY (SETQ NM ( GETSTKNAMEENTRY NT NT1))) do (COND ((EQP NTENTRY (GETSTKNTOFFSETENTRY NT NT2)) (RETURN (\INDEXATOMVAL NM]) (\SPREADFRAMEP [LAMBDA (FRAME) (* lmm " 1-Jun-86 17:19") (LET (NARGS BFLINK) (EQ (\GETBASEPTR \STACKSPACE (IPLUS (fetch (BF IVAR) of (SETQ BFLINK (fetch (FX BLINK) of FRAME))) (UNFOLD (SETQ NARGS (SUB1 (fetch (BF NARGS) of BFLINK))) WORDSPERCELL))) NARGS]) (SETSTKARGNAME [LAMBDA (N POS NAME) (* ; "Edited 20-Feb-91 01:04 by jds") (PROG ((FRAME (\STACKARGPTR POS)) NT NM (NTENTRY N) NARGS) (SETQ NT (\INTERPFRAMENT FRAME)) [COND ((LITATOM NTENTRY) (SETQ NTENTRY (\FRAMESCAN FRAME (NEW-SYMBOL-CODE NTENTRY (\ATOMVALINDEX NTENTRY)) NT] [COND (NT (* ; "Interpreted frame") (RETURN (OR [AND (IGREATERP NTENTRY 0) [ILESSP NTENTRY (FOLDLO (fetch (FNHEADER NTSIZE) of NT) (CONSTANT (WORDSPERNAMEENTRY] (\INDEXATOMVAL (GETSTKNAMEENTRY (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T)) (UNFOLD (IPLUS NTENTRY -1) (CONSTANT (WORDSPERNAMEENTRY] (LISPERROR "ILLEGAL STACK ARG" N] (SETQ NT (\COPYFNHEADER (fetch (FX NAMETABLE) of FRAME))) (* ;  "Need to copy nametable in order to smash the var name") [SETQ NTENTRY (COND ((ILEQ NTENTRY 0) (LISPERROR "ILLEGAL STACK ARG" N)) ([ILEQ NTENTRY (SETQ NARGS (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME] (MAKE-NTENTRY IVARCODE (SUB1 NTENTRY))) ((ILEQ (SETQ NTENTRY (IDIFFERENCE NTENTRY NARGS)) (fetch (FNHEADER NLOCALS) of NT)) (MAKE-NTENTRY PVARCODE (SUB1 NTENTRY))) (T (LISPERROR "ILLEGAL STACK ARG" N] (for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from [IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) (UNFOLD (fetch (FNHEADER NTSIZE) of NT) (CONSTANT (WORDSPERNAMEENTRY] by (CONSTANT ( WORDSPERNTOFFSETENTRY )) until (NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY NT NT1))) do (COND ((EQP NTENTRY (GETSTKNTOFFSETENTRY NT NT2)) (SETSTKNAMEENTRY NT NT1 (\ATOMVALINDEX NAME)) (UNINTERRUPTABLY (replace (FX NAMETABLE) of FRAME with NT)) (RETURN NAME]) (STKNARGS [LAMBDA (POS INCLUDEPVARS) (* ; "Edited 19-Feb-91 17:09 by jds") (PROG ((FRAME (\STACKARGPTR POS)) NA INTERPNT) (RETURN (COND ((EQ (fetch (FX FRAMENAME) of FRAME) '\INTERPRETER) (SETQ NA (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME))) (RETURN (SUB1 NA))) ((SETQ INTERPNT (\INTERPFRAMENT FRAME)) (* ;  "this is an interpreted frame. INTERPNT points at the name table of the frame") [COND ((\SPREADFRAMEP FRAME) (RETURN (SUB1 (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME] [SETQ NA (FOLDLO (fetch (FNHEADER NTSIZE) of INTERPNT) (CONSTANT (WORDSPERNAMEENTRY] (* ;  "Return number of VARS in nt. Padded with up to 4 zeros at end, so have to check") [COND ((IGREATERP NA 0) (do (add NA -1) repeatwhile (NULL-NTENTRY (GETSTKNAMEENTRY (\ADDBASE INTERPNT (fetch (FNHEADER OVERHEADWORDS) of T)) (UNFOLD (IPLUS NA -1) (CONSTANT (WORDSPERNAMEENTRY] NA) (T (SETQ NA (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME))) (RETURN (COND (INCLUDEPVARS (IPLUS NA (fetch (FX FNHEADER NLOCALS) of FRAME))) (T NA]) (FRAMESCAN [LAMBDA (ATOM POS) (* ; "Edited 19-Feb-91 22:56 by jds") (PROG ((FX (\STACKARGPTR POS))) (RETURN (\FRAMESCAN FX (COND ((LITATOM ATOM) (NEW-SYMBOL-CODE ATOM (\ATOMVALINDEX ATOM))) (T (RETURN NIL))) (\INTERPFRAMENT FX]) (\INTERPFRAMENT [LAMBDA (FX) (* bvm%: " 2-OCT-81 23:32") (* ;; "If FX is an interpreter frame (nametable is on stack), returns its nametable") (AND (fetch (FX VALIDNAMETABLE) of FX) (EQ (fetch (FX NAMETABHI) of FX) \STACKHI) (fetch (FX NAMETABLE#) of FX]) (\FRAMESCAN [LAMBDA (FRAME ATOM# INTERPNT) (* ; "Edited 18-Feb-91 13:01 by jds") (* ;;; "Returns index of binding of atom number ATOM# in FRAME. Indices of ivars start at 1, of pvars at nargs+1. If INTERPNT is given, this is an interpreter frame, and we merely return index of atom in its nametable, regardless of type") (for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT ( WORDSPERNAMEENTRY )) bind (NT _ (OR INTERPNT (fetch (FX NAMETABLE) of FRAME))) TMP NAME until (NULL-NTENTRY (SETQ NAME (GETSTKNAMEENTRY NT OFFSET))) do (COND ((EQ NAME ATOM#) (* ;; "Found ATOM# in nametable. Now look in second half of table to see what kind of binding and where it lies") (COND [INTERPNT (RETURN (ADD1 (FOLDLO (IDIFFERENCE OFFSET (fetch (FNHEADER OVERHEADWORDS ) of T)) (CONSTANT (WORDSPERNAMEENTRY] (T (SELECTC [NTSLOT-VARTYPE (SETQ TMP (GETSTKNTOFFSETENTRY NT (IPLUS OFFSET (fetch (FNHEADER NTSIZE ) of NT] (IVARCODE (RETURN (ADD1 (NTSLOT-OFFSET TMP)))) (PVARCODE (AND [fetch (PVARSLOT BOUND) of (ADDSTACKBASE (IPLUS (fetch (FX FIRSTPVAR) of FRAME) (UNFOLD (SETQ TMP (NTSLOT-OFFSET TMP)) WORDSPERCELL] (RETURN (IPLUS TMP (fetch (BF NARGS) of (fetch (FX BLINK) of FRAME)) 1)))) (FVARCODE (RETURN)) (RAID]) (\VAROFFSET [LAMBDA (FRAME ATN) (* ; "Edited 18-Feb-91 15:19 by jds") (* ;;; "Returns stack offset to binding of atom number ATN in FRAME, or NIL if it is not bound here.") (for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT ( WORDSPERNAMEENTRY )) bind (NT _ (fetch (FX NAMETABLE) of FRAME)) TMP NAME until (NULL-NTENTRY (SETQ NAME (GETSTKNAMEENTRY NT OFFSET))) do (COND ((EQ NAME ATN) (* ;; "Found ATN in nametable. Now look in second half of table to see what kind of binding and where it lies") (SELECTC [NTSLOT-VARTYPE (SETQ TMP (GETSTKNTOFFSETENTRY NT (IPLUS OFFSET (fetch (FNHEADER NTSIZE ) of NT] (IVARCODE (RETURN (IPLUS (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME)) (UNFOLD (NTSLOT-OFFSET TMP) WORDSPERCELL)))) (PVARCODE (AND [fetch (PVARSLOT BOUND) of (ADDSTACKBASE (SETQ TMP (IPLUS (fetch (FX FIRSTPVAR ) of FRAME) (UNFOLD (NTSLOT-OFFSET TMP) WORDSPERCELL] (RETURN TMP))) (FVARCODE (RETURN)) (RAID]) ) (* ; "finalization for stackps") (DEFINEQ (\RECLAIMSTACKP [LAMBDA (PTR) (* ; "Edited 4-Mar-87 10:43 by bvm:") (* ;; "Finalization for STACKP's -- release the stack frames tied down by PTR") (LET ((FX (fetch (STACKP EDFXP) of PTR))) (IF (NOT (fetch (FX INVALIDP) of FX)) THEN (\DECUSECOUNT FX)) (* ;  "return NIL to say it's ok to reclaim") NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML SETARG ARG) (ADDTOVAR LAMA ) ) (PUTPROPS ASTACK COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1519 4724 (ARG 1529 . 1688) (SETARG 1690 . 1874) (\ARG 1876 . 2111) (\ARGPTR 2113 . 4455) (\SETARG 4457 . 4722)) (4725 8940 (\RETURN 4735 . 5093) (\STACKARGPTR 5095 . 8938)) (8985 12362 (STKNTH 8995 . 9893) (STKNTHNAME 9895 . 10782) (STKNAME 10784 . 10929) (SETSTKNAME 10931 . 12360)) ( 12363 16138 (STKPOS 12373 . 13294) (STKSCAN 13296 . 13942) (RETFROM 13944 . 14298) (RETTO 14300 . 14575) (RESUME 14577 . 15950) (\RESUME 15952 . 16136)) (16139 42186 (STKARG 16149 . 16484) (\STKARG 16486 . 21189) (SETSTKARG 21191 . 25374) (STKARGNAME 25376 . 29599) (\SPREADFRAMEP 29601 . 30142) ( SETSTKARGNAME 30144 . 33435) (STKNARGS 33437 . 35846) (FRAMESCAN 35848 . 36298) (\INTERPFRAMENT 36300 . 36700) (\FRAMESCAN 36702 . 39755) (\VAROFFSET 39757 . 42184)) (42228 42781 (\RECLAIMSTACKP 42238 . 42779))))) STOP \ No newline at end of file diff --git a/sources/ATBL b/sources/ATBL new file mode 100644 index 00000000..9cb0cf49 --- /dev/null +++ b/sources/ATBL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "20-Apr-2018 17:35:56" {DSK}kaplan>Local>medley3.5>lispcore>sources>ATBL.;7 256555Q changes to%: (VARS ATBLCOMS) (FNS \ATBLSET) previous date%: "20-Apr-2018 16:53:30" {DSK}kaplan>Local>medley3.5>lispcore>sources>ATBL.;6) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1993, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ATBLCOMS) (RPAQQ ATBLCOMS [(E (RESETSAVE (RADIX 8))) (COMS (* ;  "Common features of read and terminal tables") (DECLARE%: DONTCOPY (EXPORT (MACROS \SYNCODE \SETSYNCODE) (RECORDS CHARTABLE)) (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW) (MACROS \CREATENSCHARHASH)) (FNS GETSYNTAX SETSYNTAX SYNTAXP \COPYSYNTAX \GETCHARCODE \SETFATSYNCODE \MAPCHARTABLE) ) (COMS (* ; "terminal tables") (FNS CONTROL COPYTERMTABLE DELETECONTROL GETDELETECONTROL ECHOCHAR ECHOCONTROL ECHOMODE GETECHOMODE GETCONTROL GETTERMTABLE RAISE GETRAISE RESETTERMTABLE SETTERMTABLE TERMTABLEP \GETTERMSYNTAX \GTTERMTABLE \ORIGTERMTABLE \SETTERMSYNTAX \TERMCLASSTOCODE \TERMCODETOCLASS \LITCHECK) (DECLARE%: DONTCOPY (EXPORT (CONSTANTS * CCECHOMODES) (CONSTANTS * TERMCLASSES) (RECORDS TERMCODE TERMTABLEP))) (INITRECORDS TERMTABLEP)) (COMS (* ; "read tables") (FNS COPYREADTABLE FIND-READTABLE IN-READTABLE ESCAPE GETBRK GETREADTABLE GETSEPR READMACROS READTABLEP READTABLEPROP RESETREADTABLE SETBRK SETREADTABLE SETSEPR \GETREADSYNTAX \GTREADTABLE \GTREADTABLE1 \ORIGREADTABLE \READCLASSTOCODE \SETMACROSYNTAX \SETREADSYNTAX \READTABLEP.DEFPRINT) (PROP ARGNAMES READTABLEPROP) (DECLARE%: EVAL@COMPILE DONTCOPY (* ;  "READCLASSTOKENS Generates READCLASSES and some interesting SELECTQ's") (* ;  "OTHER must be zero because of initialization.") [VARS READCLASSTOKENS (READCLASSES (MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR) (LIST (PACK* (CAR PAIR) ".RC") (CADR PAIR] (MACROS \COMPUTED.FORM) (* ;  "This macro ought to be official somehow") (RECORDS CONTEXTS ESCAPES WAKEUPS) (EXPORT (MACROS \GETREADMACRODEF \GTREADTABLE \GTREADTABLE1) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) (CONSTANTS * READCODEMASKS) (CONSTANTS * READMACROCONTEXTS) (CONSTANTS * READCLASSES) (CONSTANTS * READMACROWAKEUPS) (CONSTANTS * READMACROESCAPES) (RECORDS READCODE READMACRODEF READTABLEP)) (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE)) (INITRECORDS READTABLEP)) [COMS (INITVARS (\READTABLEHASH)) (FNS \ATBLSET) (INITRECORDS READER-ENVIRONMENT) (* ;  "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*") (FNS MAKE-READER-ENVIRONMENT EQUAL-READER-ENVIRONMENT SET-READER-ENVIRONMENT) (INITVARS (*LISP-PACKAGE*) (*INTERLISP-PACKAGE*) (*KEYWORD-PACKAGE*)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\ATBLSET] (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA READTABLEPROP]) (* ; "Common features of read and terminal tables") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (DATATYPE CHARTABLE ((CHARSET0 400Q BYTE) (NSCHARHASH FULLPOINTER))) ) (/DECLAREDATATYPE 'CHARTABLE '(BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE FULLPOINTER) '((CHARTABLE 0 (BITS . 7)) (CHARTABLE 0 (BITS . 207Q)) (CHARTABLE 1 (BITS . 7)) (CHARTABLE 1 (BITS . 207Q)) (CHARTABLE 2 (BITS . 7)) (CHARTABLE 2 (BITS . 207Q)) (CHARTABLE 3 (BITS . 7)) (CHARTABLE 3 (BITS . 207Q)) (CHARTABLE 4 (BITS . 7)) (CHARTABLE 4 (BITS . 207Q)) (CHARTABLE 5 (BITS . 7)) (CHARTABLE 5 (BITS . 207Q)) (CHARTABLE 6 (BITS . 7)) (CHARTABLE 6 (BITS . 207Q)) (CHARTABLE 7 (BITS . 7)) (CHARTABLE 7 (BITS . 207Q)) (CHARTABLE 10Q (BITS . 7)) (CHARTABLE 10Q (BITS . 207Q)) (CHARTABLE 11Q (BITS . 7)) (CHARTABLE 11Q (BITS . 207Q)) (CHARTABLE 12Q (BITS . 7)) (CHARTABLE 12Q (BITS . 207Q)) (CHARTABLE 13Q (BITS . 7)) (CHARTABLE 13Q (BITS . 207Q)) (CHARTABLE 14Q (BITS . 7)) (CHARTABLE 14Q (BITS . 207Q)) (CHARTABLE 15Q (BITS . 7)) (CHARTABLE 15Q (BITS . 207Q)) (CHARTABLE 16Q (BITS . 7)) (CHARTABLE 16Q (BITS . 207Q)) (CHARTABLE 17Q (BITS . 7)) (CHARTABLE 17Q (BITS . 207Q)) (CHARTABLE 20Q (BITS . 7)) (CHARTABLE 20Q (BITS . 207Q)) (CHARTABLE 21Q (BITS . 7)) (CHARTABLE 21Q (BITS . 207Q)) (CHARTABLE 22Q (BITS . 7)) (CHARTABLE 22Q (BITS . 207Q)) (CHARTABLE 23Q (BITS . 7)) (CHARTABLE 23Q (BITS . 207Q)) (CHARTABLE 24Q (BITS . 7)) (CHARTABLE 24Q (BITS . 207Q)) (CHARTABLE 25Q (BITS . 7)) (CHARTABLE 25Q (BITS . 207Q)) (CHARTABLE 26Q (BITS . 7)) (CHARTABLE 26Q (BITS . 207Q)) (CHARTABLE 27Q (BITS . 7)) (CHARTABLE 27Q (BITS . 207Q)) (CHARTABLE 30Q (BITS . 7)) (CHARTABLE 30Q (BITS . 207Q)) (CHARTABLE 31Q (BITS . 7)) (CHARTABLE 31Q (BITS . 207Q)) (CHARTABLE 32Q (BITS . 7)) (CHARTABLE 32Q (BITS . 207Q)) (CHARTABLE 33Q (BITS . 7)) (CHARTABLE 33Q (BITS . 207Q)) (CHARTABLE 34Q (BITS . 7)) (CHARTABLE 34Q (BITS . 207Q)) (CHARTABLE 35Q (BITS . 7)) (CHARTABLE 35Q (BITS . 207Q)) (CHARTABLE 36Q (BITS . 7)) (CHARTABLE 36Q (BITS . 207Q)) (CHARTABLE 37Q (BITS . 7)) (CHARTABLE 37Q (BITS . 207Q)) (CHARTABLE 40Q (BITS . 7)) (CHARTABLE 40Q (BITS . 207Q)) (CHARTABLE 41Q (BITS . 7)) (CHARTABLE 41Q (BITS . 207Q)) (CHARTABLE 42Q (BITS . 7)) (CHARTABLE 42Q (BITS . 207Q)) (CHARTABLE 43Q (BITS . 7)) (CHARTABLE 43Q (BITS . 207Q)) (CHARTABLE 44Q (BITS . 7)) (CHARTABLE 44Q (BITS . 207Q)) (CHARTABLE 45Q (BITS . 7)) (CHARTABLE 45Q (BITS . 207Q)) (CHARTABLE 46Q (BITS . 7)) (CHARTABLE 46Q (BITS . 207Q)) (CHARTABLE 47Q (BITS . 7)) (CHARTABLE 47Q (BITS . 207Q)) (CHARTABLE 50Q (BITS . 7)) (CHARTABLE 50Q (BITS . 207Q)) (CHARTABLE 51Q (BITS . 7)) (CHARTABLE 51Q (BITS . 207Q)) (CHARTABLE 52Q (BITS . 7)) (CHARTABLE 52Q (BITS . 207Q)) (CHARTABLE 53Q (BITS . 7)) (CHARTABLE 53Q (BITS . 207Q)) (CHARTABLE 54Q (BITS . 7)) (CHARTABLE 54Q (BITS . 207Q)) (CHARTABLE 55Q (BITS . 7)) (CHARTABLE 55Q (BITS . 207Q)) (CHARTABLE 56Q (BITS . 7)) (CHARTABLE 56Q (BITS . 207Q)) (CHARTABLE 57Q (BITS . 7)) (CHARTABLE 57Q (BITS . 207Q)) (CHARTABLE 60Q (BITS . 7)) (CHARTABLE 60Q (BITS . 207Q)) (CHARTABLE 61Q (BITS . 7)) (CHARTABLE 61Q (BITS . 207Q)) (CHARTABLE 62Q (BITS . 7)) (CHARTABLE 62Q (BITS . 207Q)) (CHARTABLE 63Q (BITS . 7)) (CHARTABLE 63Q (BITS . 207Q)) (CHARTABLE 64Q (BITS . 7)) (CHARTABLE 64Q (BITS . 207Q)) (CHARTABLE 65Q (BITS . 7)) (CHARTABLE 65Q (BITS . 207Q)) (CHARTABLE 66Q (BITS . 7)) (CHARTABLE 66Q (BITS . 207Q)) (CHARTABLE 67Q (BITS . 7)) (CHARTABLE 67Q (BITS . 207Q)) (CHARTABLE 70Q (BITS . 7)) (CHARTABLE 70Q (BITS . 207Q)) (CHARTABLE 71Q (BITS . 7)) (CHARTABLE 71Q (BITS . 207Q)) (CHARTABLE 72Q (BITS . 7)) (CHARTABLE 72Q (BITS . 207Q)) (CHARTABLE 73Q (BITS . 7)) (CHARTABLE 73Q (BITS . 207Q)) (CHARTABLE 74Q (BITS . 7)) (CHARTABLE 74Q (BITS . 207Q)) (CHARTABLE 75Q (BITS . 7)) (CHARTABLE 75Q (BITS . 207Q)) (CHARTABLE 76Q (BITS . 7)) (CHARTABLE 76Q (BITS . 207Q)) (CHARTABLE 77Q (BITS . 7)) (CHARTABLE 77Q (BITS . 207Q)) (CHARTABLE 100Q (BITS . 7)) (CHARTABLE 100Q (BITS . 207Q)) (CHARTABLE 101Q (BITS . 7)) (CHARTABLE 101Q (BITS . 207Q)) (CHARTABLE 102Q (BITS . 7)) (CHARTABLE 102Q (BITS . 207Q)) (CHARTABLE 103Q (BITS . 7)) (CHARTABLE 103Q (BITS . 207Q)) (CHARTABLE 104Q (BITS . 7)) (CHARTABLE 104Q (BITS . 207Q)) (CHARTABLE 105Q (BITS . 7)) (CHARTABLE 105Q (BITS . 207Q)) (CHARTABLE 106Q (BITS . 7)) (CHARTABLE 106Q (BITS . 207Q)) (CHARTABLE 107Q (BITS . 7)) (CHARTABLE 107Q (BITS . 207Q)) (CHARTABLE 110Q (BITS . 7)) (CHARTABLE 110Q (BITS . 207Q)) (CHARTABLE 111Q (BITS . 7)) (CHARTABLE 111Q (BITS . 207Q)) (CHARTABLE 112Q (BITS . 7)) (CHARTABLE 112Q (BITS . 207Q)) (CHARTABLE 113Q (BITS . 7)) (CHARTABLE 113Q (BITS . 207Q)) (CHARTABLE 114Q (BITS . 7)) (CHARTABLE 114Q (BITS . 207Q)) (CHARTABLE 115Q (BITS . 7)) (CHARTABLE 115Q (BITS . 207Q)) (CHARTABLE 116Q (BITS . 7)) (CHARTABLE 116Q (BITS . 207Q)) (CHARTABLE 117Q (BITS . 7)) (CHARTABLE 117Q (BITS . 207Q)) (CHARTABLE 120Q (BITS . 7)) (CHARTABLE 120Q (BITS . 207Q)) (CHARTABLE 121Q (BITS . 7)) (CHARTABLE 121Q (BITS . 207Q)) (CHARTABLE 122Q (BITS . 7)) (CHARTABLE 122Q (BITS . 207Q)) (CHARTABLE 123Q (BITS . 7)) (CHARTABLE 123Q (BITS . 207Q)) (CHARTABLE 124Q (BITS . 7)) (CHARTABLE 124Q (BITS . 207Q)) (CHARTABLE 125Q (BITS . 7)) (CHARTABLE 125Q (BITS . 207Q)) (CHARTABLE 126Q (BITS . 7)) (CHARTABLE 126Q (BITS . 207Q)) (CHARTABLE 127Q (BITS . 7)) (CHARTABLE 127Q (BITS . 207Q)) (CHARTABLE 130Q (BITS . 7)) (CHARTABLE 130Q (BITS . 207Q)) (CHARTABLE 131Q (BITS . 7)) (CHARTABLE 131Q (BITS . 207Q)) (CHARTABLE 132Q (BITS . 7)) (CHARTABLE 132Q (BITS . 207Q)) (CHARTABLE 133Q (BITS . 7)) (CHARTABLE 133Q (BITS . 207Q)) (CHARTABLE 134Q (BITS . 7)) (CHARTABLE 134Q (BITS . 207Q)) (CHARTABLE 135Q (BITS . 7)) (CHARTABLE 135Q (BITS . 207Q)) (CHARTABLE 136Q (BITS . 7)) (CHARTABLE 136Q (BITS . 207Q)) (CHARTABLE 137Q (BITS . 7)) (CHARTABLE 137Q (BITS . 207Q)) (CHARTABLE 140Q (BITS . 7)) (CHARTABLE 140Q (BITS . 207Q)) (CHARTABLE 141Q (BITS . 7)) (CHARTABLE 141Q (BITS . 207Q)) (CHARTABLE 142Q (BITS . 7)) (CHARTABLE 142Q (BITS . 207Q)) (CHARTABLE 143Q (BITS . 7)) (CHARTABLE 143Q (BITS . 207Q)) (CHARTABLE 144Q (BITS . 7)) (CHARTABLE 144Q (BITS . 207Q)) (CHARTABLE 145Q (BITS . 7)) (CHARTABLE 145Q (BITS . 207Q)) (CHARTABLE 146Q (BITS . 7)) (CHARTABLE 146Q (BITS . 207Q)) (CHARTABLE 147Q (BITS . 7)) (CHARTABLE 147Q (BITS . 207Q)) (CHARTABLE 150Q (BITS . 7)) (CHARTABLE 150Q (BITS . 207Q)) (CHARTABLE 151Q (BITS . 7)) (CHARTABLE 151Q (BITS . 207Q)) (CHARTABLE 152Q (BITS . 7)) (CHARTABLE 152Q (BITS . 207Q)) (CHARTABLE 153Q (BITS . 7)) (CHARTABLE 153Q (BITS . 207Q)) (CHARTABLE 154Q (BITS . 7)) (CHARTABLE 154Q (BITS . 207Q)) (CHARTABLE 155Q (BITS . 7)) (CHARTABLE 155Q (BITS . 207Q)) (CHARTABLE 156Q (BITS . 7)) (CHARTABLE 156Q (BITS . 207Q)) (CHARTABLE 157Q (BITS . 7)) (CHARTABLE 157Q (BITS . 207Q)) (CHARTABLE 160Q (BITS . 7)) (CHARTABLE 160Q (BITS . 207Q)) (CHARTABLE 161Q (BITS . 7)) (CHARTABLE 161Q (BITS . 207Q)) (CHARTABLE 162Q (BITS . 7)) (CHARTABLE 162Q (BITS . 207Q)) (CHARTABLE 163Q (BITS . 7)) (CHARTABLE 163Q (BITS . 207Q)) (CHARTABLE 164Q (BITS . 7)) (CHARTABLE 164Q (BITS . 207Q)) (CHARTABLE 165Q (BITS . 7)) (CHARTABLE 165Q (BITS . 207Q)) (CHARTABLE 166Q (BITS . 7)) (CHARTABLE 166Q (BITS . 207Q)) (CHARTABLE 167Q (BITS . 7)) (CHARTABLE 167Q (BITS . 207Q)) (CHARTABLE 170Q (BITS . 7)) (CHARTABLE 170Q (BITS . 207Q)) (CHARTABLE 171Q (BITS . 7)) (CHARTABLE 171Q (BITS . 207Q)) (CHARTABLE 172Q (BITS . 7)) (CHARTABLE 172Q (BITS . 207Q)) (CHARTABLE 173Q (BITS . 7)) (CHARTABLE 173Q (BITS . 207Q)) (CHARTABLE 174Q (BITS . 7)) (CHARTABLE 174Q (BITS . 207Q)) (CHARTABLE 175Q (BITS . 7)) (CHARTABLE 175Q (BITS . 207Q)) (CHARTABLE 176Q (BITS . 7)) (CHARTABLE 176Q (BITS . 207Q)) (CHARTABLE 177Q (BITS . 7)) (CHARTABLE 177Q (BITS . 207Q)) (CHARTABLE 200Q FULLPOINTER)) '202Q) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ \NSCHARHASHKEYS 12Q) (RPAQQ \NSCHARHASHOVERFLOW 1.3) (CONSTANTS \NSCHARHASHKEYS \NSCHARHASHOVERFLOW) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \CREATENSCHARHASH MACRO (ARGS (* ;  "added size argument for creation of \ORIGTERMTABLE during initialization.") (LIST 'HASHARRAY (OR (CAR ARGS) '\NSCHARHASHKEYS) '\NSCHARHASHOVERFLOW))) ) ) (DEFINEQ (GETSYNTAX [LAMBDA (CH TABLE) (* bvm%: " 8-Mar-86 17:22") (COND [(FIXP (SETQ CH (\GETCHARCODE CH))) (COND ((type? TERMTABLEP TABLE) (\GETTERMSYNTAX CH TABLE)) (T (\GETREADSYNTAX CH (\GTREADTABLE TABLE T] (T (PROG (TEM CHARTBL RESULT) (COND ((SETQ TEM (\READCLASSTOCODE CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM VAL) (push RESULT KEY] CHARTBL)) ((EQ CH 'BREAK) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((fetch BREAK of VAL) (push RESULT KEY] CHARTBL)) ((SETQ TEM (\TERMCLASSTOCODE CH)) (SETQ CHARTBL (fetch TERMSA of (\GTTERMTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch TERMCLASS of VAL)) (push RESULT (PROG1 KEY (* SELECTC TEM ((LIST NONE.TC  WORDSEPR.TC) (* ;  "Only these classes have multiple members")  KEY) (RETURN (CONS KEY)))] CHARTBL)) [(FMEMB CH '(MACRO SPLICE INFIX)) (PROG [LST (A (fetch READMACRODEFS of (\GTREADTABLE TABLE T] (COND (A [MAPHASH A (FUNCTION (LAMBDA (DEF C) (AND (EQ CH (fetch MACROTYPE of DEF)) (push LST C] (RETURN LST] ((SETQ TEM (fetch (CONTEXTS VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch MACROCONTEXT of VAL)) (push RESULT KEY] CHARTBL)) ((SETQ TEM (fetch (WAKEUPS VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch WAKEUP of VAL)) (push RESULT KEY] CHARTBL)) ((SETQ TEM (fetch (ESCAPES VAL) of CH)) (SETQ CHARTBL (fetch READSA of (\GTREADTABLE TABLE T))) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (DECLARE (USEDFREE TEM RESULT)) (COND ((EQ TEM (fetch ESCAPE of VAL)) (push RESULT KEY] CHARTBL)) (T (\ILLEGAL.ARG CH))) (RETURN RESULT]) (SETSYNTAX [LAMBDA (CHAR CLASS TBL) (* rmk%: "20-Nov-84 15:47") (OR (FIXP (SETQ CHAR (\GETCHARCODE CHAR))) (\ILLEGAL.ARG CHAR)) [OR (type? READTABLEP TBL) (type? TERMTABLEP TBL) (SETQ TBL (COND ((OR (type? TERMTABLEP CLASS) (\TERMCLASSTOCODE CLASS)) (\GTTERMTABLE TBL)) (T (\GTREADTABLE TBL] [COND ((OR (type? READTABLEP CLASS) (type? TERMTABLEP CLASS) (SELECTQ CLASS ((NIL T ORIG) T) NIL)) (SETQ CLASS (GETSYNTAX CHAR CLASS))) ((FIXP (SETQ CLASS (\GETCHARCODE CLASS))) (SETQ CLASS (GETSYNTAX CLASS TBL] (COND ((type? READTABLEP TBL) (PROG1 (\GETREADSYNTAX CHAR TBL) (\SETREADSYNTAX CHAR CLASS TBL))) (T (PROG1 (\GETTERMSYNTAX CHAR TBL) (\SETTERMSYNTAX CHAR CLASS TBL]) (SYNTAXP [LAMBDA (CODE CLASS TABLE) (* rmk%: " 5-JUN-80 22:40") (PROG (D) (RETURN (COND ((EQ CLASS 'BREAK) (fetch BREAK of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE))) ((SETQ D (\READCLASSTOCODE CLASS)) (EQ D (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE))) [(SETQ D (\TERMCLASSTOCODE CLASS)) (EQ D (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of (\GTTERMTABLE TABLE)) CODE] [(FMEMB CLASS '(MACRO SPLICE INFIX)) (AND (SETQ D (fetch READMACRODEFS of (\GTREADTABLE TABLE))) (EQ CLASS (fetch MACROTYPE of (GETHASH CODE D] [(SETQ D (fetch (CONTEXTS VAL) of CLASS)) (EQ D (fetch MACROCONTEXT of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE] [(SETQ D (fetch (WAKEUPS VAL) of CLASS)) (EQ D (fetch WAKEUP of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE] [(SETQ D (fetch (ESCAPES VAL) of CLASS)) (EQ D (fetch ESCAPE of (\SYNCODE (fetch READSA of (\GTREADTABLE TABLE)) CODE] (T (\ILLEGAL.ARG CLASS]) (\COPYSYNTAX [LAMBDA (A B) (* gbn "15-Sep-85 22:36") (* ;; "Copies chartable A into chartable B") (CHECK (AND (type? CHARTABLE A) (type? CHARTABLE B))) (\MOVEBYTES A 0 B 0 (ADD1 \MAXTHINCHAR)) (COND ((fetch (CHARTABLE NSCHARHASH) of A) (replace (CHARTABLE NSCHARHASH) of B with (REHASH (fetch (CHARTABLE NSCHARHASH) of A) (\CREATENSCHARHASH]) (\GETCHARCODE [LAMBDA (C) (* rmk%: "20-Nov-84 15:46") (COND ((AND (NUMBERP C) (\CHARCODEP (FIX C))) (FIX C)) ((AND (LITATOM C) (EQ 1 (NCHARS C))) (CHCON1 C)) (T C]) (\SETFATSYNCODE [LAMBDA (TABLE CHAR CODE) (* bvm%: " 8-Mar-86 17:03") (* ;;; "Called by \SETSYNCODE macro for fat characters") (SETQ TABLE (\DTEST TABLE 'CHARTABLE)) (* ;  "CODE = 0 is REAL.CCE, NONE.TC, OTHER.RC") (COND ((ILEQ CHAR \MAXTHINCHAR) (\PUTBASEBYTE TABLE CHAR CODE)) ((EQ 0 CODE) (COND ((fetch (CHARTABLE NSCHARHASH) of TABLE) (* ;  "there was already a table here so record the change") (PUTHASH CHAR CODE (fetch (CHARTABLE NSCHARHASH) of TABLE))) (T (* ;  "No hashtable yet, and only the default is being stored, so don't build the hashtable") 0))) (T (PUTHASH CHAR CODE (OR (fetch (CHARTABLE NSCHARHASH) of TABLE) (replace (CHARTABLE NSCHARHASH) of TABLE with (\CREATENSCHARHASH]) (\MAPCHARTABLE [LAMBDA (FN CHARTBL) (* ; "Edited 20-Apr-2018 16:53 by rmk:") (for I from 0 to \MAXTHINCHAR do (APPLY* FN (\GETBASEBYTE CHARTBL I) I)) (COND ((fetch (CHARTABLE NSCHARHASH) of CHARTBL) (MAPHASH (fetch (CHARTABLE NSCHARHASH) of CHARTBL) FN]) ) (* ; "terminal tables") (DEFINEQ (CONTROL [LAMBDA (MODE TTBL) (* rmk%: " 8-FEB-80 11:59") (PROG1 (fetch CONTROLFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace CONTROLFLG of TTBL with (AND MODE T]) (COPYTERMTABLE [LAMBDA (TTBL) (* lmm "14-APR-81 14:27") (create TERMTABLEP using (SETQ TTBL (\GTTERMTABLE TTBL T)) TERMSA _ (create CHARTABLE using (fetch TERMSA of TTBL]) (DELETECONTROL [LAMBDA (TYPE MESSAGE TTBL) (* lmm " 1-Jan-85 21:34") (PROG [VAL (TBL (\GTTERMTABLE TTBL (NULL MESSAGE] (SETQ VAL (SELECTQ TYPE ((ECHO NOECHO) (PROG1 (fetch DELCHARECHO of TBL) (replace DELCHARECHO of TBL with TYPE))) (DELCHARECHO (PROG1 (fetch DELCHARECHO of TBL) (SELECTQ MESSAGE (NIL (* ; "Called only to get current value")) ((ECHO NOECHO) (replace DELCHARECHO of TBL with MESSAGE)) (LISPERROR "ILLEGAL ARG" MESSAGE)))) ((LINEDELETE DELETELINE) [PROG1 (fetch LINEDELETE of TBL) (AND MESSAGE (replace LINEDELETE of TBL with (\LITCHECK MESSAGE]) (1STCHDEL [PROG1 (fetch 1STCHDEL of TBL) (AND MESSAGE (replace 1STCHDEL of TBL with (\LITCHECK MESSAGE]) (NTHCHDEL [PROG1 (fetch NTHCHDEL of TBL) (AND MESSAGE (replace NTHCHDEL of TBL with (\LITCHECK MESSAGE]) (POSTCHDEL [PROG1 (fetch POSTCHDEL of TBL) (AND MESSAGE (replace POSTCHDEL of TBL with (\LITCHECK MESSAGE]) (EMPTYCHDEL [PROG1 (fetch EMPTYCHDEL of TBL) (AND MESSAGE (replace EMPTYCHDEL of TBL with (\LITCHECK MESSAGE]) (LISPERROR "ILLEGAL ARG" TYPE))) (RETURN (COND ((STRINGP VAL) (CONCAT VAL)) (T VAL]) (GETDELETECONTROL [LAMBDA (TYPE TTBL) (* lmm " 1-Jan-85 21:20") (PROG (TBL VAL) (SETQ TBL (\GTTERMTABLE TTBL T)) (SETQ VAL (SELECTQ TYPE ((ECHO NOECHO) (fetch DELCHARECHO of TBL)) (DELCHARECHO (fetch DELCHARECHO of TBL)) ((LINEDELETE DELETELINE) (fetch LINEDELETE of TBL)) (1STCHDEL (fetch 1STCHDEL of TBL)) (NTHCHDEL (fetch NTHCHDEL of TBL)) (POSTCHDEL (fetch POSTCHDEL of TBL)) (EMPTYCHDEL (fetch EMPTYCHDEL of TBL)) (LISPERROR "ILLEGAL ARG" TYPE))) (RETURN (COND ((STRINGP VAL) (CONCAT VAL)) (T VAL]) (ECHOCHAR [LAMBDA (CHARCODE MODE TTBL) (* lmm " 1-Jan-85 21:29") (COND ((LISTP CHARCODE) (for X in CHARCODE do (ECHOCHAR X MODE TTBL))) (T (PROG [B (SA (fetch TERMSA of (\GTTERMTABLE TTBL (NULL MODE] (RETURN (PROG1 (SELECTC (fetch CCECHO of (SETQ B (\SYNCODE SA CHARCODE))) (REAL.CCE 'REAL) (IGNORE.CCE 'IGNORE) (SIMULATE.CCE 'SIMULATE) 'INDICATE) (AND MODE (\SETSYNCODE SA CHARCODE (create TERMCODE using B CCECHO _ (SELECTQ MODE (REAL REAL.CCE) (IGNORE IGNORE.CCE) (SIMULATE SIMULATE.CCE) ((INDICATE UPARROW) INDICATE.CCE) (\ILLEGAL.ARG MODE]) (ECHOCONTROL [LAMBDA (CHAR MODE TTBL) (* rmk%: "20-Nov-84 15:14") (PROG ((C (\GETCHARCODE CHAR))) (OR [AND (\THINCHARCODEP C) (OR (ILESSP C 40Q) (AND (IGEQ C (CHARCODE A)) (ILEQ C (CHARCODE Z)) (SETQ C (IDIFFERENCE C 100Q] (\ILLEGAL.ARG C)) (RETURN (ECHOCHAR C MODE TTBL]) (ECHOMODE [LAMBDA (FLG TTBL) (* rmk%: " 8-FEB-80 11:57") (PROG1 (fetch ECHOFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace ECHOFLG of TTBL with (AND FLG T]) (GETECHOMODE [LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch ECHOFLG of (\GTTERMTABLE TTBL T]) (GETCONTROL [LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch CONTROLFLG of (\GTTERMTABLE TTBL T]) (GETTERMTABLE [LAMBDA (TTBL) (\GTTERMTABLE TTBL NIL]) (RAISE [LAMBDA (FLG TTBL) (* bvm%: "14-Feb-85 00:17") (PROG1 (fetch RAISEFLG of (SETQ TTBL (\GTTERMTABLE TTBL))) (replace RAISEFLG of TTBL with (COND ((EQ FLG 0) 0) (FLG T]) (GETRAISE [LAMBDA (TTBL) (* lmm " 1-Jan-85 21:21") (fetch RAISEFLG of (\GTTERMTABLE TTBL T]) (RESETTERMTABLE [LAMBDA (TTBL FROM) (* lmm "14-APR-81 14:34") (PROG ((FR (\GTTERMTABLE FROM T)) (TT (\GTTERMTABLE TTBL))) (\COPYSYNTAX (fetch TERMSA of FR) (fetch TERMSA of TT)) (replace RAISEFLG of TT with (fetch RAISEFLG of FR)) (replace DELCHARECHO of TT with (fetch DELCHARECHO of FR)) (replace LINEDELETE of TT with (fetch LINEDELETE of FR)) (replace 1STCHDEL of TT with (fetch 1STCHDEL of FR)) (replace NTHCHDEL of TT with (fetch NTHCHDEL of FR)) (replace POSTCHDEL of TT with (fetch POSTCHDEL of FR)) (replace EMPTYCHDEL of TT with (fetch EMPTYCHDEL of FR)) (replace CONTROLFLG of TT with (fetch CONTROLFLG of FR)) (replace ECHOFLG of TT with (fetch ECHOFLG of FR)) (RETURN TT]) (SETTERMTABLE [LAMBDA (TBL) (* rmk%: " 8-FEB-80 12:16") (PROG1 \PRIMTERMTABLE (SETQ \PRIMTERMSA (fetch TERMSA of (SETQ \PRIMTERMTABLE (\GTTERMTABLE TBL]) (TERMTABLEP [LAMBDA (TTBL) (* rmk%: "20-FEB-80 12:29") (AND (type? TERMTABLEP TTBL) TTBL]) (\GETTERMSYNTAX [LAMBDA (C TBL) (* rmk%: "24-APR-80 09:44") (\TERMCODETOCLASS (fetch TERMCLASS of (\SYNCODE (fetch TERMSA of TBL) C]) (\GTTERMTABLE [LAMBDA (TTBL FLG) (* lmm " 6-MAY-80 20:35") (COND ((type? TERMTABLEP TTBL) TTBL) ((NULL TTBL) \PRIMTERMTABLE) ((AND (EQ TTBL 'ORIG) FLG) \ORIGTERMTABLE) (T (LISPERROR "ILLEGAL TERMINAL TABLE" TTBL]) (\ORIGTERMTABLE [LAMBDA NIL (* rrb " 5-Oct-85 10:33") (* ;; "Creates the original terminal table") (* ;; "must be created with a hash table big enough to hold all of the indicates in character set 1 because this gets evaluated in the loadup before HASHOVERFLOW is defined. rrb 5-oct-85") (PROG ((TBL (create TERMTABLEP TERMSA _ (create CHARTABLE NSCHARHASH _ (\CREATENSCHARHASH 454Q)) DELCHARECHO _ 'ECHO ECHOFLG _ T LINEDELETE _ "## " 1STCHDEL _ "\" NTHCHDEL _ "" POSTCHDEL _ "\" EMPTYCHDEL _ "## "))) (PROGN (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE) ((TENEX D) (CHARCODE ^A)) ((JERICHO VAX TOPS-20) (CHARCODE DEL)) (SHOULDNT)) 'CHARDELETE TBL) (\SETTERMSYNTAX (CHARCODE ^H) 'CHARDELETE TBL) (* ;  "Added ^H as a CHARDELETE character 9/30/85") (\SETTERMSYNTAX (CHARCODE ^W) 'WORDDELETE TBL) (\SETTERMSYNTAX (SELECTQ (SYSTEMTYPE) ((TENEX D) (CHARCODE ^Q)) ((JERICHO VAX) (CHARCODE ^U)) (SHOULDNT)) 'LINEDELETE TBL) (\SETTERMSYNTAX (CHARCODE ^R) 'RETYPE TBL) (\SETTERMSYNTAX (CHARCODE ^V) 'CTRLV TBL) (\SETTERMSYNTAX (CHARCODE EOL) 'WAKEUPCHAR TBL) (for C in (CHARCODE (SPACE TAB ! @ %# $ ~ & * - = + %| { } ^ _ %: ; < > %, %. ? /)) do (\SETTERMSYNTAX C 'WORDSEPR TBL))) (PROGN (ECHOCHAR (CHARCODE (NULL ^A ^B ^C ^D ^E ^F ^H ^K ^L ^N ^O ^P ^Q ^R ^S ^T ^U ^V ^W ^X ^Y ^Z ^\ ^%] ^^)) 'INDICATE TBL) (ECHOCHAR (CHARCODE (BELL TAB LF CR)) 'REAL TBL) (SELECTQ (SYSTEMTYPE) (D (ECHOCHAR (CHARCODE (NULL ^A ^W ^Q ^R)) 'IGNORE TBL) (ECHOCHAR (CHARCODE (BELL TAB ESCAPE LF TENEXEOL)) 'SIMULATE TBL)) (JERICHO (ECHOCHAR [CONSTANT (CONS ERASECHARCODE (CHARCODE (BELL TAB ESCAPE EOL] 'SIMULATE TBL)) (VAX (ECHOCHAR (CHARCODE (TAB ESCAPE EOL DEL)) 'SIMULATE TBL)) NIL)) (for C from 200Q to \MAXTHINCHAR do (ECHOCHAR C 'REAL TBL)) (for C from (CHARCODE 1,0) to (CHARCODE 1,377) do (ECHOCHAR C 'INDICATE TBL)) (RETURN TBL]) (\SETTERMSYNTAX [LAMBDA (C CLASS TBL) (* rmk%: "26-Mar-85 23:45") (* ;; "Changes the terminal syntax class for charcode C. Unlike Interlisp-10, does not turn off previous characters for CHARDELETE, etc. classes") (\SETSYNCODE (fetch TERMSA of TBL) C (create TERMCODE using (\SYNCODE (fetch TERMSA of TBL) C) TERMCLASS _ (OR (\TERMCLASSTOCODE CLASS) (LISPERROR "ILLEGAL ARG" CLASS]) (\TERMCLASSTOCODE [LAMBDA (CLASS) (* rmk%: "11-FEB-82 21:24") (SELECTQ CLASS ((EOL WAKEUPCHAR) EOL.TC) (NONE NONE.TC) (CHARDELETE CHARDELETE.TC) (WORDDELETE WORDDELETE.TC) (WORDSEPR WORDSEPR.TC) (LINEDELETE LINEDELETE.TC) (RETYPE RETYPE.TC) ((CTRLV CNTRLV) CTRLV.TC) NIL]) (\TERMCODETOCLASS [LAMBDA (CODE) (* rmk%: "11-FEB-82 21:24") (SELECTC CODE (EOL.TC 'EOL) (NONE.TC 'NONE) (CHARDELETE.TC 'CHARDELETE) (WORDDELETE.TC 'WORDDELETE) (WORDSEPR.TC 'WORDSEPR) (LINEDELETE.TC 'LINEDELETE) (RETYPE.TC 'RETYPE) (CTRLV.TC 'CNTRLV) NIL]) (\LITCHECK [LAMBDA (X) (* rmk%: "11-FEB-82 21:26") (COND ((EQ X 'BACKUP) (* ;  "Means take terminal/implementation dependent backup action") X) ((LITATOM X) (MKSTRING X)) ((STRINGP X) (CONCAT X)) (T (\ILLEGAL.ARG X]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ CCECHOMODES (REAL.CCE IGNORE.CCE SIMULATE.CCE INDICATE.CCE)) (DECLARE%: EVAL@COMPILE (RPAQQ REAL.CCE 0) (RPAQQ IGNORE.CCE 10Q) (RPAQQ SIMULATE.CCE 20Q) (RPAQQ INDICATE.CCE 30Q) (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)) (DECLARE%: EVAL@COMPILE (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) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS TERMCODE ((CCECHO (LOGAND DATUM 30Q)) (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)) ) (/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG) '((TERMTABLEP 0 POINTER) (TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) (TERMTABLEP 10Q POINTER) (TERMTABLEP 12Q POINTER) (TERMTABLEP 14Q POINTER) (TERMTABLEP 16Q POINTER) (TERMTABLEP 16Q (FLAGBITS . 0)) (TERMTABLEP 16Q (FLAGBITS . 20Q))) '20Q) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'TERMTABLEP '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG) '((TERMTABLEP 0 POINTER) (TERMTABLEP 2 POINTER) (TERMTABLEP 4 POINTER) (TERMTABLEP 6 POINTER) (TERMTABLEP 10Q POINTER) (TERMTABLEP 12Q POINTER) (TERMTABLEP 14Q POINTER) (TERMTABLEP 16Q POINTER) (TERMTABLEP 16Q (FLAGBITS . 0)) (TERMTABLEP 16Q (FLAGBITS . 20Q))) '20Q) (* ; "read tables") (DEFINEQ (COPYREADTABLE [LAMBDA (RDTBL) (* rmk%: " 2-FEB-80 12:26") (RESETREADTABLE (create READTABLEP) (\GTREADTABLE RDTBL T]) (FIND-READTABLE [LAMBDA (NAME) (* bvm%: "27-Jul-86 15:53") (GETHASH NAME \READTABLEHASH]) (IN-READTABLE [LAMBDA (RDTBL) (* bvm%: "27-Jul-86 15:55") (SETQ *READTABLE* (\GTREADTABLE RDTBL T]) (ESCAPE [LAMBDA (FLG RDTBL) (* rmk%: " 1-FEB-80 13:12") (PROG1 (fetch ESCAPEFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))) (replace ESCAPEFLG of RDTBL with (NEQ FLG NIL]) (GETBRK [LAMBDA (RDTBL) (* rmk%: " 2-MAY-80 17:04") (GETSYNTAX 'BREAK RDTBL]) (GETREADTABLE [LAMBDA (RDTBL) (* lmm%: 4-FEB-76 3 62Q) (\GTREADTABLE RDTBL]) (GETSEPR [LAMBDA (RDTBL) (* rmk%: " 2-MAY-80 17:05") (GETSYNTAX 'SEPR RDTBL]) (READMACROS [LAMBDA (FLG RDTBL) (* rmk%: " 1-FEB-80 13:11") (PROG1 (fetch READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL))) (replace READMACROFLG of RDTBL with (NEQ FLG NIL]) (READTABLEP [LAMBDA (RDTBL) (* rmk%: "20-FEB-80 12:32") (AND (type? READTABLEP RDTBL) RDTBL]) (READTABLEPROP [LAMBDA ARGS (* bvm%: "28-Aug-86 15:28") (COND ((LESSP ARGS 2) (\ILLEGAL.ARG NIL)) ((GREATERP ARGS 3) (\ILLEGAL.ARG (ARG ARGS 4))) (T (LET [(RDTBL (\GTREADTABLE (ARG ARGS 1))) (NEWVALUEP (EQ ARGS 3)) (NEWVALUE (AND (EQ ARGS 3) (ARG ARGS 3] (SELECTQ (ARG ARGS 2) (NUMBERBASE [PROG1 (fetch (READTABLEP NUMBERBASE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP NUMBERBASE) of RDTBL with NEWVALUE]) (NAME [LET ((OLDNAME (fetch (READTABLEP READTBLNAME) of RDTBL))) (PROG1 OLDNAME (COND (NEWVALUEP (COND (OLDNAME (REMHASH OLDNAME \READTABLEHASH))) (replace (READTABLEP READTBLNAME) of RDTBL with NEWVALUE) (PUTHASH NEWVALUE RDTBL \READTABLEHASH]) (COMMONLISP [PROG1 (fetch (READTABLEP COMMONLISP) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP COMMONLISP) of RDTBL with NEWVALUE) (if NEWVALUE then (* ;  "COMMONLISP implies COMMONNUMSYNTAX and not USESILPACKAGE") (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with T) (replace (READTABLEP USESILPACKAGE) of RDTBL with NIL]) (COMMONNUMSYNTAX [PROG1 (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with NEWVALUE]) (USESILPACKAGE [PROG1 (fetch (READTABLEP USESILPACKAGE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP USESILPACKAGE) of RDTBL with NEWVALUE]) (CASEINSENSITIVE [PROG1 (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (COND (NEWVALUEP (replace (READTABLEP CASEINSENSITIVE) of RDTBL with NEWVALUE]) (ESCAPECHAR [PROG1 (fetch (READTABLEP ESCAPECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'ESCAPE RDTBL) (replace (READTABLEP ESCAPECHAR) of RDTBL with NEWVALUE]) (MULTIPLE-ESCAPECHAR [PROG1 (fetch (READTABLEP MULTESCAPECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'MULTIPLE-ESCAPE RDTBL) (replace (READTABLEP MULTESCAPECHAR) of RDTBL with NEWVALUE]) (PACKAGECHAR [PROG1 (fetch (READTABLEP PACKAGECHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE 'PACKAGEDELIM RDTBL) (replace (READTABLEP PACKAGECHAR) of RDTBL with NEWVALUE]) (HASHMACROCHAR [PROG1 (fetch (READTABLEP HASHMACROCHAR) of RDTBL) (COND (NEWVALUEP (\SETREADSYNTAX NEWVALUE '(INFIX ALWAYS NONIMMEDIATE ESCQUOTE READVBAR) RDTBL) (replace (READTABLEP HASHMACROCHAR) of RDTBL with NEWVALUE]) (\ILLEGAL.ARG (ARG ARGS 2]) (RESETREADTABLE [LAMBDA (RDTBL FROM) (* ; "Edited 20-Apr-2018 16:22 by rmk:") (* bvm%: "27-Aug-86 22:28") (* ;; "RMK: Copy the macrodefs") [replace READMACROFLG of (SETQ RDTBL (\GTREADTABLE RDTBL)) with (fetch READMACROFLG of (SETQ FROM (\GTREADTABLE FROM T] (replace ESCAPEFLG of RDTBL with (fetch ESCAPEFLG of FROM)) (replace (READTABLEP COMMONLISP) of RDTBL with (fetch (READTABLEP COMMONLISP) of FROM)) (replace (READTABLEP NUMBERBASE) of RDTBL with (fetch (READTABLEP NUMBERBASE) of FROM)) (replace (READTABLEP CASEINSENSITIVE) of RDTBL with (fetch (READTABLEP CASEINSENSITIVE) of FROM)) (replace (READTABLEP COMMONNUMSYNTAX) of RDTBL with (fetch (READTABLEP COMMONNUMSYNTAX) of FROM)) (replace (READTABLEP USESILPACKAGE) of RDTBL with (fetch (READTABLEP USESILPACKAGE) of FROM)) (replace (READTABLEP HASHMACROCHAR) of RDTBL with (fetch (READTABLEP HASHMACROCHAR) of FROM)) (replace (READTABLEP ESCAPECHAR) of RDTBL with (fetch (READTABLEP ESCAPECHAR) of FROM)) (replace (READTABLEP MULTESCAPECHAR) of RDTBL with (fetch (READTABLEP MULTESCAPECHAR) of FROM)) (replace (READTABLEP PACKAGECHAR) of RDTBL with (fetch (READTABLEP PACKAGECHAR) of FROM)) (replace (READTABLEP DISPATCHMACRODEFS) of RDTBL with (COPY (fetch (READTABLEP DISPATCHMACRODEFS) of FROM))) (* ;; "Placeholder. If DISPATCHMACRODEFS ends up containing a CHARTABLE or a hash table, will have to do a REHASH or \COPYSYNTAX as well") [LET ((RDEFS (fetch (READTABLEP READMACRODEFS) of RDTBL)) (FDEFS (fetch (READTABLEP READMACRODEFS) of FROM))) [COND (RDEFS (CLRHASH RDEFS)) (T (SETQ RDEFS (replace (READTABLEP READMACRODEFS) of RDTBL with (HASHARRAY (HARRAYSIZE FDEFS) 7] (AND FDEFS (MAPHASH FDEFS (FUNCTION (LAMBDA (VAL KEY) (PUTHASH KEY (COPY VAL) RDEFS] (\COPYSYNTAX (fetch READSA of FROM) (fetch READSA of RDTBL)) RDTBL]) (SETBRK [LAMBDA (LST FLG RDTBL) (* rmk%: "13-AUG-81 00:01") (* ;  "This is a very ugly def which needs to be cleaned up cause a lot of people call SETBRK") (COND [(EQ LST T) [MAPC (GETSYNTAX 'BREAK RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X 'OTHER RDTBL] (MAPC (GETSYNTAX 'BREAK (COND ((EQ RDTBL T) 'ORIG) (T T))) (FUNCTION (LAMBDA (X) (SETSYNTAX X 'BREAK RDTBL] (T (SELECTQ FLG (NIL (* ; "reset") [MAPC (GETSYNTAX 'BREAK RDTBL) (FUNCTION (LAMBDA (X) (OR (MEMB X LST) (SETSYNTAX X 'OTHER RDTBL] [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'BREAK RDTBL]) (0 (* ; "clear out lst") [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'OTHER RDTBL]) (1 (* ; "add chars") [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'BREAK RDTBL]) NIL]) (SETREADTABLE [LAMBDA (RDTBL FLG) (* bvm%: " 4-May-86 16:32") (PROG1 *READTABLE* (SETQ *READTABLE* (\GTREADTABLE RDTBL]) (SETSEPR [LAMBDA (LST FLG RDTBL) (* rmk%: " 8-JUN-80 07:16") (* ;  "This one also needs to be cleaned up") (COND [(EQ LST T) [MAPC (GETSYNTAX 'SEPR RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X 'OTHER RDTBL] (MAPC (GETSYNTAX 'SEPR (COND ((EQ RDTBL T) 'ORIG) (T T))) (FUNCTION (LAMBDA (X) (SETSYNTAX X 'SEPR RDTBL] (T (SELECTQ FLG (NIL (* ; "reset") [MAPC (GETSYNTAX 'SEPR RDTBL) (FUNCTION (LAMBDA (X) (SETSYNTAX X 'OTHER RDTBL] [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'SEPR RDTBL]) (0 (* ; "clear out lst") [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'OTHER RDTBL]) (1 (* ; "add chars") [MAPC LST (FUNCTION (LAMBDA (X) (SETSYNTAX X 'SEPR RDTBL]) NIL]) (\GETREADSYNTAX [LAMBDA (C TBL) (* bvm%: "30-Jun-86 17:49") (LET ((B (\SYNCODE (fetch READSA of TBL) C))) (* ;; "This will turn into a SELECTQ that keys off syntax code numbers and produces class tokens. The default clause at the end: if it's not a built-in class, must be a macro") (* ;; "Sample code:") (* (SELECTQ B (0 (QUOTE OTHER))  (140Q (QUOTE SEPRCHAR))  (160Q (QUOTE BREAKCHAR))  (161Q (QUOTE STRINGDELIM))  (162Q (QUOTE LEFTPAREN))  (163Q (QUOTE RIGHTPAREN))  (164Q (QUOTE LEFTBRACKET))  (165Q (QUOTE RIGHTBRACKET))  (106Q (QUOTE ESCAPE))  (107Q (QUOTE MULTIPLE-ESCAPE))  (105Q (QUOTE PACKAGEDELIM)) )) (\COMPUTED.FORM `(SELECTQ B (\,@ [for PAIR in READCLASSTOKENS collect (LIST (EVAL (CADR PAIR)) (KWOTE (CAR PAIR]) (LET ((E (\GETREADMACRODEF C TBL)) KEY) `(,(fetch MACROTYPE of E) ,(fetch (CONTEXTS KEY) of (fetch MACROCONTEXT of B)) ,@(AND (NEQ (SETQ KEY (fetch (WAKEUPS KEY) of (fetch WAKEUP of B))) 'NONIMMEDIATE) (LIST KEY)) ,@(AND (NEQ (SETQ KEY (fetch (ESCAPES KEY) of (fetch ESCAPE of B))) 'ESCQUOTE) (LIST KEY)) ,(fetch MACROFN of E]) (\GTREADTABLE [LAMBDA (X FLG) (* bvm%: " 5-May-86 11:05") (SELECTQ X ((NIL T) (\DTEST *READTABLE* 'READTABLEP)) (\GTREADTABLE1 X FLG]) (\GTREADTABLE1 [LAMBDA (X FLG) (* bvm%: "27-Jul-86 15:37") (COND ((type? READTABLEP X) X) ((AND FLG (GETHASH X \READTABLEHASH))) (T (LISPERROR "ILLEGAL READTABLE" X]) (\ORIGREADTABLE [LAMBDA NIL (* ; "Edited 16-Apr-87 17:45 by bvm:") (* ;; "Creates a copy of the 'original' read-table.") (PROG [(TBL (create READTABLEP READMACROFLG _ T ESCAPEFLG _ T NUMBERBASE _ 12Q USESILPACKAGE _ T ESCAPECHAR _ (CHARCODE %%) PACKAGECHAR _ (PROGN (* ;; "Need to have a character for package delimiter in all read tables, but for old read tables want one that is unlikely to have appeared in a symbol in an old source file. Also would like it to be a 7-bit char, so we don't needlessly force MAKEFILE to produce binary files.") (CHARCODE "^^")) HASHMACROCHAR _ (CHARCODE "|"] (* ;; "Actually, '|' is not defined in ORIG table, but rather later. But the radix printer and others want it, and this is better than nothing") (SETSEPR (CHARCODE (SPACE TENEXEOL CR ^L LF TAB)) 1 TBL) (\SETREADSYNTAX (CHARCODE %]) 'RIGHTBRACKET TBL) (\SETREADSYNTAX (CHARCODE %[) 'LEFTBRACKET TBL) (\SETREADSYNTAX (CHARCODE %)) 'RIGHTPAREN TBL) (\SETREADSYNTAX (CHARCODE %() 'LEFTPAREN TBL) (\SETREADSYNTAX (CHARCODE %%) 'ESCAPE TBL) (\SETREADSYNTAX (CHARCODE %") 'STRINGDELIM TBL) (\SETREADSYNTAX 247Q 'PACKAGEDELIM TBL) (* ; "Old choice for package delim char: the NS section symbol. Keep for compatibility with Lyric Beta files") (\SETREADSYNTAX (CHARCODE "^^") 'PACKAGEDELIM TBL) (RETURN TBL]) (\READCLASSTOCODE [LAMBDA (CLASS) (* bvm%: " 9-Jul-85 00:43") (* ;;; "This turns into a SELECTQ that goes from CLASS token to numeric code") (\COMPUTED.FORM `(SELECTQ CLASS (\,@ READCLASSTOKENS) (SEPR (* ; "Synonym for SEPRCHAR") SEPRCHAR.RC) NIL]) (\SETMACROSYNTAX [LAMBDA (C CLASS TBL) (* rmk%: " 3-Jan-84 13:20") (OR (AND (FMEMB (CAR CLASS) '(MACRO SPLICE INFIX)) (CDR CLASS)) (\ILLEGAL.ARG CLASS)) (PROG (CONTEXT WAKEUP ESCAPE (LST CLASS) (A (fetch READMACRODEFS of TBL))) LP (COND ([CDR (SETQ LST (LISTP (CDR LST] (OR [AND (NULL CONTEXT) (SETQ CONTEXT (fetch (CONTEXTS VAL) of (CAR LST] [AND (NULL WAKEUP) (SETQ WAKEUP (fetch (WAKEUPS VAL) of (CAR LST] [AND (NULL ESCAPE) (SETQ ESCAPE (fetch (ESCAPES VAL) of (CAR LST] (\ILLEGAL.ARG CLASS)) (GO LP))) (OR (LISTP LST) (\ILLEGAL.ARG CLASS)) [COND (A (* ;; "This hack guarantees that the hasharray will not overflow and cause an error in the uninterruptable PUTHASH below. If it didn't already have a value for C, then the macro bits are not set in C's syntax code, so the T value is harmless.") (OR (GETHASH C A) (PUTHASH C T A))) (T (replace READMACRODEFS of TBL with (SETQ A (HASHARRAY 7 7] (UNINTERRUPTABLY (PUTHASH C (create READMACRODEF MACROTYPE _ (CAR CLASS) MACROFN _ (CAR LST)) A) (\SETSYNCODE (fetch READSA of TBL) C (LOGOR (OR CONTEXT ALWAYS.RMC) (OR ESCAPE ESC.RME) (OR WAKEUP NONIMMEDIATE.RMW))))]) (\SETREADSYNTAX [LAMBDA (C CLASS TBL) (* bvm%: " 8-Mar-86 16:37") (PROG ((OLDSYNTAX (\SYNCODE (fetch (READTABLEP READSA) of TBL) C)) TEM) [COND ((EQ CLASS 'BREAK) (COND ((fetch BREAK of OLDSYNTAX) (RETURN)) (T (SETQ CLASS 'BREAKCHAR] (* ;  "If already a BREAK character but also something else, like LPAR, leave it alone") (COND ((LISTP CLASS) (\SETMACROSYNTAX C CLASS TBL)) ((SETQ TEM (\READCLASSTOCODE CLASS)) (UNINTERRUPTABLY [COND ((fetch MACROP of OLDSYNTAX) (* ; "No longer a macro") (REMHASH C (fetch READMACRODEFS of TBL] (\SETSYNCODE (fetch READSA of TBL) C TEM))) (T (\ILLEGAL.ARG CLASS]) (\READTABLEP.DEFPRINT [LAMBDA (RDTBL STREAM) (* bvm%: "13-Oct-86 17:32") (* ;; "Print read table as, for example, #") (LET ((NAME (fetch (READTABLEP READTBLNAME) of RDTBL))) [.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "")) (PROGN (* ; "Longest address is `177,177777'") 12Q) (COND (NAME (NCHARS NAME)) (T 0] (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\SOUT ")) T]) ) (PUTPROPS READTABLEPROP ARGNAMES (RDTBL PROP NEWVALUE)) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ READCLASSTOKENS ((OTHER 0) (SEPRCHAR (LOGOR ESCAPEBIT STOPATOMBIT 0)) (BREAKCHAR (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 0)) (STRINGDELIM (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 1)) (LEFTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 2)) (RIGHTPAREN (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 3)) (LEFTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 4)) (RIGHTBRACKET (LOGOR ESCAPEBIT STOPATOMBIT BREAKBIT 5)) (ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 6)) (MULTIPLE-ESCAPE (LOGOR ESCAPEBIT INNERESCAPEBIT 7)) (PACKAGEDELIM (LOGOR ESCAPEBIT INNERESCAPEBIT 1)))) (RPAQ READCLASSES [MAPCAR READCLASSTOKENS (FUNCTION (LAMBDA (PAIR) (LIST (PACK* (CAR PAIR) ".RC") (CADR PAIR]) (DECLARE%: EVAL@COMPILE (PUTPROPS \COMPUTED.FORM MACRO [X (CONS 'PROGN (MAPCAR X (FUNCTION EVAL]) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS CONTEXTS ((KEY (SELECTC DATUM (ALWAYS.RMC 'ALWAYS) (FIRST.RMC 'FIRST) (ALONE.RMC 'ALONE) NIL)) (VAL (SELECTQ DATUM (ALWAYS ALWAYS.RMC) (FIRST FIRST.RMC) (ALONE ALONE.RMC) NIL)))) (ACCESSFNS ESCAPES ((KEY (SELECTC DATUM (ESC.RME 'ESCQUOTE) (NOESC.RME 'NOESCQUOTE) NIL)) (VAL (SELECTQ DATUM ((ESCQUOTE ESC) ESC.RME) ((NOESCQUOTE NOESC) NOESC.RME) NIL)))) (ACCESSFNS WAKEUPS ((KEY (SELECTC DATUM (IMMEDIATE.RMW 'IMMEDIATE) (NONIMMEDIATE.RMW 'NONIMMEDIATE) NIL)) (VAL (SELECTQ DATUM ((IMMEDIATE IMMED WAKEUP) IMMEDIATE.RMW) ((NONIMMEDIATE NONIMMED NOWAKEUP) NONIMMEDIATE.RMW) NIL)))) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \GETREADMACRODEF MACRO ((C TBL) (GETHASH C (fetch READMACRODEFS of TBL)))) (PUTPROPS \GTREADTABLE MACRO [ARGS (COND [(LITATOM (CAR ARGS)) (SUBPAIR '(X . FLG) ARGS '(SELECTQ X ((NIL T) (\DTEST *READTABLE* 'READTABLEP)) (\GTREADTABLE1 X . FLG] (T 'IGNOREMACRO]) (PUTPROPS \GTREADTABLE1 DMACRO [ARGS (COND [(NULL (CDR ARGS)) (LIST '\DTEST (CAR ARGS) ''READTABLEP] (T 'IGNOREMACRO]) ) (DECLARE%: EVAL@COMPILE (RPAQQ MACROBIT 10Q) (RPAQQ BREAKBIT 20Q) (RPAQQ STOPATOMBIT 40Q) (RPAQQ ESCAPEBIT 100Q) (RPAQQ INNERESCAPEBIT 4) (CONSTANTS MACROBIT BREAKBIT STOPATOMBIT ESCAPEBIT INNERESCAPEBIT) ) (RPAQQ READCODEMASKS ((CONTEXTMASK (LOGOR MACROBIT STOPATOMBIT BREAKBIT 1)) (WAKEUPMASK (LOGOR MACROBIT 2)))) (DECLARE%: EVAL@COMPILE (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)))) (DECLARE%: EVAL@COMPILE (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)))) (DECLARE%: EVAL@COMPILE (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)))) (DECLARE%: EVAL@COMPILE (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))) (DECLARE%: EVAL@COMPILE (RPAQ ESC.RME ESCAPEBIT) (RPAQQ NOESC.RME 0) (CONSTANTS (ESC.RME ESCAPEBIT) (NOESC.RME 0)) ) (DECLARE%: EVAL@COMPILE (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)) ) (/DECLAREDATATYPE 'READTABLEP '(POINTER POINTER FLAG FLAG FLAG (BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER) '((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 20Q)) (READTABLEP 2 (FLAGBITS . 40Q)) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 60Q)) (READTABLEP 0 (FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 20Q)) (READTABLEP 0 (FLAGBITS . 40Q)) (READTABLEP 0 (FLAGBITS . 60Q)) (READTABLEP 4 (FLAGBITS . 120Q)) (READTABLEP 4 (FLAGBITS . 140Q)) (READTABLEP 4 (FLAGBITS . 160Q)) (READTABLEP 6 POINTER) (READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 207Q)) (READTABLEP 4 (BITS . 207Q)) (READTABLEP 10Q (BITS . 7)) (READTABLEP 12Q POINTER)) '14Q) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \ORIGREADTABLE \READTABLEHASH \ORIGTERMTABLE) ) ) (/DECLAREDATATYPE 'READTABLEP '(POINTER POINTER FLAG FLAG FLAG (BITS 5) FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER BYTE BYTE BYTE BYTE POINTER) '((READTABLEP 0 POINTER) (READTABLEP 2 POINTER) (READTABLEP 2 (FLAGBITS . 0)) (READTABLEP 2 (FLAGBITS . 20Q)) (READTABLEP 2 (FLAGBITS . 40Q)) (READTABLEP 4 (BITS . 4)) (READTABLEP 2 (FLAGBITS . 60Q)) (READTABLEP 0 (FLAGBITS . 0)) (READTABLEP 0 (FLAGBITS . 20Q)) (READTABLEP 0 (FLAGBITS . 40Q)) (READTABLEP 0 (FLAGBITS . 60Q)) (READTABLEP 4 (FLAGBITS . 120Q)) (READTABLEP 4 (FLAGBITS . 140Q)) (READTABLEP 4 (FLAGBITS . 160Q)) (READTABLEP 6 POINTER) (READTABLEP 5 (BITS . 7)) (READTABLEP 5 (BITS . 207Q)) (READTABLEP 4 (BITS . 207Q)) (READTABLEP 10Q (BITS . 7)) (READTABLEP 12Q POINTER)) '14Q) (RPAQ? \READTABLEHASH ) (DEFINEQ (\ATBLSET [LAMBDA NIL (* ; "Edited 20-Apr-2018 17:34 by rmk:") (* ; "Edited 3-Dec-86 18:07 by Pavel") (DECLARE (GLOBALVARS \ORIGREADTABLE \ORIGTERMTABLE)) (COND ((NULL (BOUNDP '\PRIMREADTABLE)) (initrecord CHARTABLE) (* ;; "Read tables") (* ;; "RMK: If reloading, don't smash an existing hash table") [OR (HARRAYP \READTABLEHASH) (SETQ \READTABLEHASH (HASHARRAY 24Q NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL] (LET (TRDTBL NEW-IL-RDTBL) (PROGN (* ; "The ORIG read table") (SETQ \ORIGREADTABLE (\ORIGREADTABLE)) (READTABLEPROP \ORIGREADTABLE 'NAME 'ORIG)) (PROGN (* ;  "The old Interlisp T read table. May not have a use for this any more") (SETQ TRDTBL (COPYREADTABLE \ORIGREADTABLE)) (SETSYNTAX (CHARCODE "|") '(MACRO READVBAR) TRDTBL) (SETSYNTAX (CHARCODE "`") '(MACRO FIRST READBQUOTE) TRDTBL) (SETSYNTAX (CHARCODE ",") '(MACRO FIRST READBQUOTECOMMA) TRDTBL) (SETSYNTAX (CHARCODE "'") '(MACRO FIRST READQUOTE) TRDTBL) (READTABLEPROP TRDTBL 'NAME "OLD-INTERLISP-T") (PROGN (* ; "Temporary") (SETTOPVAL '%#CURRENTRDTBL# TRDTBL))) (PROGN (* ; "The old FILERDTBL") (SETQ FILERDTBL (COPYREADTABLE \ORIGREADTABLE)) (SETSYNTAX (CHARCODE "|") TRDTBL FILERDTBL) (READTABLEPROP FILERDTBL 'NAME "OLD-INTERLISP-FILE") (SETQ *OLD-INTERLISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REREADTABLE _ FILERDTBL REBASE _ 12Q)) (* ;  "need this to read files in the loadup") ) (PROGN (SETQ NEW-IL-RDTBL (COPYREADTABLE TRDTBL)) (* ;  "The new Interlisp read table is more common lispy") (READTABLEPROP NEW-IL-RDTBL 'MULTIPLE-ESCAPECHAR (CHARCODE "|")) (READTABLEPROP NEW-IL-RDTBL 'HASHMACROCHAR (CHARCODE "#")) (SET-DEFAULT-HASHMACRO-SETTINGS NEW-IL-RDTBL) (READTABLEPROP NEW-IL-RDTBL 'COMMONNUMSYNTAX T) (READTABLEPROP NEW-IL-RDTBL 'USESILPACKAGE NIL) (READTABLEPROP NEW-IL-RDTBL 'NAME "INTERLISP") (for I from 1 to 32Q do (SETSYNTAX I 'SEPRCHAR FILERDTBL) (* ; "Make font switch chars seprs") (SETSYNTAX I 'SEPRCHAR NEW-IL-RDTBL)) (SETQ *READTABLE* NEW-IL-RDTBL)) (* ;; "Make ^Y like #. in the old T readtable and the new INTERLISP one.") (SETSYNTAX (CHARCODE ^Y) '[MACRO ALWAYS (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL] TRDTBL) (SETSYNTAX (CHARCODE ^Y) TRDTBL NEW-IL-RDTBL) (DEFPRINT 'READTABLEP '\READTABLEP.DEFPRINT)) (* ;; "Terminal tables") (SETQ \ORIGTERMTABLE (\ORIGTERMTABLE)) (SETQ \PRIMTERMTABLE (COPYTERMTABLE \ORIGTERMTABLE)) (SETQ \PRIMTERMSA (fetch TERMSA of \PRIMTERMTABLE)) (PUTD '\ATBLSET) (PUTD '\ORIGTERMTABLE) NIL]) ) (/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER) '((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER)) '10Q) (* ; "Definition is on CMLREAD, need it here to initialize *OLD-INTERLISP-READ-ENVIRONMENT*") (DEFINEQ (MAKE-READER-ENVIRONMENT [LAMBDA (PACKAGE READTABLE BASE) (* ; "Edited 18-Dec-86 18:28 by bvm:") (create READER-ENVIRONMENT REPACKAGE _ (COND (PACKAGE (\DTEST PACKAGE 'PACKAGE)) (T *PACKAGE*)) REREADTABLE _ (COND (READTABLE (\DTEST READTABLE 'READTABLEP)) (T *READTABLE*)) REBASE _ (COND (BASE (\CHECKRADIX BASE)) (T *PRINT-BASE*]) (EQUAL-READER-ENVIRONMENT [LAMBDA (ENV1 ENV2) (* bvm%: "31-Jul-86 12:54") (AND (EQ (fetch (READER-ENVIRONMENT REREADTABLE) of ENV1) (fetch (READER-ENVIRONMENT REREADTABLE) of ENV2)) (EQ (fetch (READER-ENVIRONMENT REPACKAGE) of ENV1) (fetch (READER-ENVIRONMENT REPACKAGE) of ENV2)) (EQ (fetch (READER-ENVIRONMENT REBASE) of ENV1) (fetch (READER-ENVIRONMENT REBASE) of ENV2]) (SET-READER-ENVIRONMENT [LAMBDA (ENV) (* bvm%: "28-Aug-86 17:44") (* ;;; "Sets the reader environment variables from ENV. Should usually only be called inside a WITH-READER-ENVIRONMENT.") [SETQ *PACKAGE* (ffetch REPACKAGE of (\DTEST ENV 'READER-ENVIRONMENT] (SETQ *READTABLE* (ffetch REREADTABLE of ENV)) (SETQ *READ-BASE* (SETQ *PRINT-BASE* (ffetch REBASE of ENV))) ENV]) ) (RPAQ? *LISP-PACKAGE* ) (RPAQ? *INTERLISP-PACKAGE* ) (RPAQ? *KEYWORD-PACKAGE* ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\ATBLSET) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA READTABLEPROP) ) (PUTPROPS ATBL COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3706Q 3711Q 3742Q)) (DECLARE%: DONTCOPY (FILEMAP (NIL (44105Q 67336Q (GETSYNTAX 44117Q . 55046Q) (SETSYNTAX 55050Q . 57135Q) (SYNTAXP 57137Q . 62543Q) (\COPYSYNTAX 62545Q . 63630Q) (\GETCHARCODE 63632Q . 64276Q) (\SETFATSYNCODE 64300Q . 66453Q) (\MAPCHARTABLE 66455Q . 67334Q)) (67377Q 124165Q (CONTROL 67411Q . 70011Q) (COPYTERMTABLE 70013Q . 70455Q) (DELETECONTROL 70457Q . 75277Q) (GETDELETECONTROL 75301Q . 77207Q) (ECHOCHAR 77211Q . 102107Q) (ECHOCONTROL 102111Q . 103031Q) (ECHOMODE 103033Q . 103425Q) (GETECHOMODE 103427Q . 103677Q) (GETCONTROL 103701Q . 104153Q) (GETTERMTABLE 104155Q . 104260Q) (RAISE 104262Q . 105104Q) ( GETRAISE 105106Q . 105354Q) (RESETTERMTABLE 105356Q . 107456Q) (SETTERMTABLE 107460Q . 110147Q) ( TERMTABLEP 110151Q . 110416Q) (\GETTERMSYNTAX 110420Q . 111027Q) (\GTTERMTABLE 111031Q . 111555Q) ( \ORIGTERMTABLE 111557Q . 120420Q) (\SETTERMSYNTAX 120422Q . 121621Q) (\TERMCLASSTOCODE 121623Q . 122504Q) (\TERMCODETOCLASS 122506Q . 123315Q) (\LITCHECK 123317Q . 124163Q)) (131156Q 210103Q ( COPYREADTABLE 131170Q . 131502Q) (FIND-READTABLE 131504Q . 131733Q) (IN-READTABLE 131735Q . 132201Q) ( ESCAPE 132203Q . 132604Q) (GETBRK 132606Q . 133024Q) (GETREADTABLE 133026Q . 133237Q) (GETSEPR 133241Q . 133457Q) (READMACROS 133461Q . 134074Q) (READTABLEP 134076Q . 134345Q) (READTABLEPROP 134347Q . 146545Q) (RESETREADTABLE 146547Q . 157034Q) (SETBRK 157036Q . 162142Q) (SETREADTABLE 162144Q . 162431Q ) (SETSEPR 162433Q . 165433Q) (\GETREADSYNTAX 165435Q . 172615Q) (\GTREADTABLE 172617Q . 173164Q) ( \GTREADTABLE1 173166Q . 173572Q) (\ORIGREADTABLE 173574Q . 177413Q) (\READCLASSTOCODE 177415Q . 200324Q) (\SETMACROSYNTAX 200326Q . 203742Q) (\SETREADSYNTAX 203744Q . 206027Q) (\READTABLEP.DEFPRINT 206031Q . 210101Q)) (241125Q 251763Q (\ATBLSET 241137Q . 251761Q)) (252522Q 255615Q ( MAKE-READER-ENVIRONMENT 252534Q . 253622Q) (EQUAL-READER-ENVIRONMENT 253624Q . 254653Q) ( SET-READER-ENVIRONMENT 254655Q . 255613Q))))) STOP \ No newline at end of file diff --git a/sources/ATERM b/sources/ATERM new file mode 100644 index 00000000..56115e75 --- /dev/null +++ b/sources/ATERM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 12:08:04" {DSK}local>lde>lispcore>sources>ATERM.;2 36386 changes to%: (VARS ATERMCOMS) previous date%: "29-Jul-88 15:37:31" {DSK}local>lde>lispcore>sources>ATERM.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ATERMCOMS) (RPAQQ ATERMCOMS [ (* ; "Line-buffering") (FNS BKLINBUF CLEARBUF LINBUF PAGEFULLFN SETLINELENGTH SYSBUF TERMCHARWIDTH TERMINAL-INPUT TERMINAL-OUTPUT \CHDEL1 \CLOSELINE \DECPARENCOUNT \ECHOCHAR \FILLBUFFER \FILLBUFFER.WORDSEPRP \FILLBUFFER.BACKUP \GETCHAR \INCPARENCOUNT \RESETLINE \RESETTERMINAL \SAVELINEBUF \STOPSCROLL?) (COMS * BCPLDISPLAYCOMS) (COMS (FNS VIDEOCOLOR) (VARS (\VideoColor)) (PROP ARGNAMES VIDEOCOLOR)) [DECLARE%: DOCOPY DONTEVAL@LOAD (P (MOVD? 'NILL 'SETDISPLAYHEIGHT] (DECLARE%: DONTCOPY (MACROS \RAISECHAR \LINEBUFBOUT)) (FNS \PEEKREFILL \READREFILL \RATOM/RSTRING-REFILL \READCREFILL) (FNS DRIBBLE DRIBBLEFILE) (FNS \SETUP.DEFAULT.LINEBUF \CREATELINEBUFFER \LINEBUF.READP \LINEBUF.EOFP \LINEBUF.PEEKBIN \OPENLINEBUF) (COMS (* ;  "User entries to make up for fact that (EOFP T) = NIL now.") (FNS LINEBUFFER-EOFP LINEBUFFER-SKIPSEPRS)) (DECLARE%: DOCOPY DONTEVAL@LOAD (VARS (\#DISPLAYLINES 58) (\DISPLAYLINELENGTH 82) (\CURRENTDISPLAYLINE 0) (\STOPSCROLLMESSAGE "---MORE---")) (VARS (\SYSBUF NIL) (\LINBUF NIL)) (P (MOVD? '\OPENLINEBUF '\CREATE.TTYDISPLAYSTREAM)) (VARS (\DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF))) (P (\OPENLINEBUF))) (FNS \INTERMP \OUTTERMP) (EXPORT (DECLARE%: DONTCOPY (RECORDS LINEBUFFER) (CONSTANTS * LINEBUFFERSTATES) (MACROS \INTERMP \OUTTERMP) (GLOBALVARS \DEFAULTLINEBUF))) (DECLARE%: DONTCOPY (CONSTANTS * FILLTYPES)) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT]) (* ; "Line-buffering") (DEFINEQ (BKLINBUF (LAMBDA (STR) (* bvm%: " 5-May-86 11:38") (COND ((STRINGP STR) (\RESETLINE) (for J C (SA _ (fetch READSA of (\DTEST *READTABLE* (QUOTE READTABLEP)))) from 1 while (SETQ C (NTHCHARCODE STR J)) do (\OUTCHAR \LINEBUF.OFD C) (\INCPARENCOUNT (\SYNCODE SA C))) (\CLOSELINE) STR))) ) (CLEARBUF (LAMBDA (FILE FLG) (* ; "Edited 17-Jan-87 16:08 by bvm:") (PROG ((STRM (SELECTQ FILE (T \LINEBUF.OFD) (NIL *STANDARD-INPUT*) (\GETSTREAM FILE (QUOTE INPUT)))) SYSBUF LINBUF) (* ; "Do the stream coercion in line so we don't needlessly create a tty window just to clear input") (COND ((AND (EQ STRM \LINEBUF.OFD) (NEQ STRM \DEFAULTLINEBUF)) (* ; "Don't do this if \LINEBUF.OFD is the default, since then there really isn't anything to save") (COND (FLG (SETQ LINBUF (\SAVELINEBUF)) (SETQ SYSBUF (\SAVESYSBUF)) (COND ((OR LINBUF SYSBUF) (* ; "note in manual: if both buffers are empty, don't change saved ones.") (SETQ \LINBUF LINBUF) (SETQ \SYSBUF SYSBUF)))) (T (\CLEARSYSBUF))) (* ; "check for mouse events enabled and coordinated with keyboard") (\RESETTERMINAL)))) NIL) ) (LINBUF (LAMBDA (FLG) (* rrb "21-JUL-83 15:33") (COND (FLG (AND \LINBUF (CONCAT \LINBUF))) (T (SETQ \LINBUF NIL)))) ) (PAGEFULLFN (LAMBDA (STREAM) (* lmm "10-Jan-86 01:19") (* ;; "default function that is called by \STOPSCROLL? when more lines are printed in a row than will fit on the screen or window.") (* ;; "If no input is pending, it waits for a character to be typed.") (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) (COND ((READP KEYSTREAM)) ((DISPLAYSTREAMP STREAM) (* ; "reverse only this window.") (RESETLST (RESETSAVE (SETDISPLAYHEIGHT T)) (COND ((AND (NOT (TTY.PROCESSP)) (EQ (PROCESSPROP (THIS.PROCESS) (QUOTE NAME)) (QUOTE MOUSE))) (* ; "Running under mouse, so can't make this proc be the tty process") (RESETSAVE (TTY.PROCESS (THIS.PROCESS))))) (RESETSAVE (INVERTW STREAM) (LIST (FUNCTION INVERTW) STREAM)) (BIN KEYSTREAM))) (T (PRIN1 \STOPSCROLLMESSAGE STREAM) (BIN KEYSTREAM) (* ; "Now erase the message") (FRPTQ (NCHARS \STOPSCROLLMESSAGE) (\OUTCHAR STREAM ERASECHARCODE)) (BLOCK))))) ) (SETLINELENGTH (LAMBDA (N) (* rrb "22-JUL-83 10:10") (LINELENGTH (OR N (fetch (STREAM LINELENGTH) of \TERM.OFD)) T))) (SYSBUF (LAMBDA (FLG) (* rrb "21-JUL-83 15:34") (COND (FLG (AND \SYSBUF (CONCAT \SYSBUF))) (T (SETQ \SYSBUF NIL)))) ) (TERMCHARWIDTH (LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:28") (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on the terminal STREAM, allowing for the various escape sequences. Used by \ECHOCHAR") (\STREAMCHARWIDTH (LOGAND CHARCODE \CHARMASK) (\OUTSTREAMARG STREAM) (GETTERMTABLE TTBL))) ) (TERMINAL-INPUT (LAMBDA U (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;;; "Return the current terminal output stream. If an argument is supplied, make it the new terminal output stream") (PROG1 \LINEBUF.OFD (COND ((IGEQ U 1) (LET ((STREAM (GETSTREAM (ARG U 1) (QUOTE INPUT)))) (if (EQ *STANDARD-INPUT* \LINEBUF.OFD) then (SETQ *STANDARD-INPUT* STREAM)) (SETQ \LINEBUF.OFD STREAM)))))) ) (TERMINAL-OUTPUT (LAMBDA U (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;;; "Return the current terminal output stream. If an argument is supplied, make it the new terminal output stream") (PROG1 \TERM.OFD (COND ((IGEQ U 1) (LET ((STREAM (GETSTREAM (ARG U 1) (QUOTE OUTPUT)))) (if (EQ *STANDARD-OUTPUT* \TERM.OFD) then (SETQ *STANDARD-OUTPUT* STREAM)) (SETQ TtyDisplayStream (SETQ \TERM.OFD STREAM))))))) ) (\CHDEL1 (LAMBDA NIL (* rmk%: "28-Mar-85 18:25") (COND ((\BACKNSCHAR \LINEBUF.OFD (UNFOLD \NORUNCODE 256)) (PROG1 (\NSPEEK \LINEBUF.OFD (UNFOLD \NORUNCODE 256)) (\SETEOFPTR \LINEBUF.OFD (GETFILEPTR \LINEBUF.OFD)))))) ) (\CLOSELINE (LAMBDA NIL (* lmm "10-Jan-86 03:07") (SETQ \CURRENTDISPLAYLINE 0) (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with READING.LBS))) ) (\DECPARENCOUNT (LAMBDA (RSNX) (* bvm%: "14-Feb-85 00:29") (* ;; "This updates parencounts as characters are removed from the buffer due to line-editting. RSNX is a readtable syntax code") (COND ((EQ RSNX STRINGDELIM.RC) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)))) ((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (SELECTC RSNX (LEFTPAREN.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) -1)))) (RIGHTPAREN.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 1)))) (LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) -1)) (RIGHTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 1)) NIL)))) ) (\ECHOCHAR (LAMBDA (C) (* ; "Edited 15-Jun-87 16:58 by jds") (* ;; "Echo the character-code C appropriately. If it really got echoed, return T, otherwise NIL.") (COND ((fetch ECHOFLG of \PRIMTERMTABLE) (COND ((AND (EQ (fetch RAISEFLG of \PRIMTERMTABLE) 0) (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (* ; "This is doing a raise if flag is set") (SETQ C (IDIFFERENCE C 32)))) (\OUTCHAR \TERM.OFD C) T))) ) (\FILLBUFFER (LAMBDA (FILLTYPE) (* ; "Edited 20-Aug-87 17:52 by jds") (* ;; "While filling the line, the current file pointer is the end of the line. When the line is closed, this is made the eof. *READTABLE* is used for syntactic delimiters and paren counting on READ and RATOM calls but isn't referenced (or bound) for READC") (DECLARE (USEDFREE *READTABLE* *READ-NEWLINE-SUPPRESS*)) (\RESETLINE) (PROG ((ILB (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)) (ISP (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (ILP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)) (KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)) (RTBLSA (fetch READSA of *READTABLE*)) (CONTROLTON (fetch CONTROLFLG of \PRIMTERMTABLE)) RSNX TCLASS CHAR RAISEDCHAR PEEKEDECHOED) (* ;; "AR 8999/9000 the RTBLSA init code used to set it to nil if FILLTYPE were READC.FT; alas, RTBLSA is used even when that's true. --JDS 8/20/87") (DECLARE (SPECVARS RTBLSA)) (* ; "TCLASS is terminal syntax class, RSNX is read-table code") (COND ((SETQ CHAR (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD)) (* ; "Account for peeked character, adn remember if for further down.") (SETQ CHAR (IABS CHAR)) (* ; "The peeked char may be negative because it was BIN'ed earlier. Make sure it is positive.") (COND ((NOT (fetch (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD)) (* ; "It wasn't echoed when first read, so echo it now if desired") (* ; "Incompatible with I-10 to do it this way") (\ECHOCHAR CHAR))) (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (replace (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD with NIL) (SETQ PEEKEDECHOED T) (SETQ RAISEDCHAR (\RAISECHAR CHAR)))) (COND ((AND CONTROLTON (EQ FILLTYPE READC.FT)) (\LINEBUFBOUT \LINEBUF.OFD (OR CHAR (\GETCHAR))) (GO EXIT))) (COND (CHAR (GO NEXTTCLASS))) NEXT (SETQ CHAR (BIN KEYSTREAM)) NEXTTCLASS (SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\RAISECHAR CHAR))))) REDO (SELECTC TCLASS (RETYPE.TC (\OUTCHAR \TERM.OFD (CHARCODE EOL)) (\SETEOFPTR \LINEBUF.OFD (\GETFILEPTR \LINEBUF.OFD)) (* ;; "Make the EOF be accurate during retyping, in case an interrupt happens and the buffer gets saved via \SAVELINEBUF.") (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS)) (until (\PAGEDEOFP \LINEBUF.OFD) do (\OUTCHAR \TERM.OFD (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256)))) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS) (GO NEXT)) (CHARDELETE.TC (COND ((SETQ CHAR (\CHDEL1)) (\FILLBUFFER.BACKUP CHAR))) (GO RECOMPUTE)) (LINEDELETE.TC (while (SETQ CHAR (\CHDEL1)) do (\FILLBUFFER.BACKUP CHAR)) (GO RECOMPUTE)) (WORDDELETE.TC (COND ((SETQ CHAR (\CHDEL1)) (while (\FILLBUFFER.WORDSEPRP CHAR) do (* ; "first chars are seprs, delete them all") (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE))) (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE)) (while (NULL (\FILLBUFFER.WORDSEPRP CHAR)) do (\FILLBUFFER.BACKUP CHAR) (OR (SETQ CHAR (\CHDEL1)) (GO RECOMPUTE))) (* ; "put CHAR back") (\LINEBUFBOUT \LINEBUF.OFD CHAR) (GO RECOMPUTE))) (GO NEXT)) (CTRLV.TC (* ;; "The reasonable thing to do is coerce the character, set TCLASS to NONE.TC, and go REDO. But on the 10, ctlv disables the immediacy of read-macros. This is quite bizarre, cause a macro that was suppose to do something in the middle of reading will be done out of context. We simulate that behavior, however.") (COND (PEEKEDECHOED (* ; "Has been echoed already, don't echo it again.") (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (* ; "Want to echo ^V") (\LINEBUFBOUT \LINEBUF.OFD (COND ((OR (AND (IGEQ (SETQ RAISEDCHAR (\GETCHAR)) (CHARCODE A)) (ILEQ RAISEDCHAR (CHARCODE Z))) (AND (IGEQ RAISEDCHAR (CHARCODE a)) (ILEQ RAISEDCHAR (CHARCODE z)))) (LOGAND RAISEDCHAR 31)) (T RAISEDCHAR))) (GO NEXT)) (EOL.TC (COND (PEEKEDECHOED (* ; "Has been echoed already, don't echo it again.") (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (GO EXIT)) NIL) (COND (PEEKEDECHOED (SETQ PEEKEDECHOED NIL)) (T (\ECHOCHAR CHAR))) (* ; "Here if it isn't a terminal class. Only echo if it isn't a special terminal class") (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (AND (EQ FILLTYPE READC.FT) (GO NEXT)) (COND ((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA RAISEDCHAR))) (* ; "On Tenex the escape inhibits the action of all terminal characters except control-V.") (COND ((EQ CTRLV.TC (SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\GETCHAR)))))) (GO REDO))) (\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR) (GO NEXT))) (SELECTC FILLTYPE (RATOM/RSTRING.FT (COND ((AND CONTROLTON (fetch STOPATOM of RSNX)) (GO EXIT)))) (READ.FT (COND ((AND CONTROLTON (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0) (fetch STOPATOM of RSNX) (SELECTC RSNX ((LIST LEFTPAREN.RC LEFTBRACKET.RC) NIL) (STRINGDELIM.RC (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)))) (* ;; "READ is reading an atom. Return when atom ends, but also obey bracket/paren exception noted on page 14.33 of manual.") (GO EXIT))) (COND ((\INCPARENCOUNT RSNX) (* ;; "Parens balance--throw the carriage if the closing paren or bracket character was not a CR, and if FLG argument of READ is NIL. (We know we are under a READ call because of FILLTYPE)") (\CLOSELINE) (* ; "\CLOSELINE first so dribble happens before EOL") (COND ((AND (NEQ RAISEDCHAR (CHARCODE EOL)) (NOT *READ-NEWLINE-SUPPRESS*)) (\OUTCHAR \TERM.OFD (CHARCODE EOL)))) (RETURN)) ((EQ IMMEDIATE.RMW (fetch WAKEUP of RSNX)) (* ; "Immediate read-macro") (GO EXIT)))) (SHOULDNT)) (GO NEXT) RECOMPUTE (AND (EQ FILLTYPE READ.FT) (PROGN (UNINTERRUPTABLY (\SETFILEPTR \LINEBUF.OFD 0) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS) (replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with ILB) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with ISP) (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with ILP)) (until (\PAGEDEOFP \LINEBUF.OFD) do (SETQ CHAR (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256))) (COND ((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA CHAR))) (OR (\PAGEDEOFP \LINEBUF.OFD) (\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE 256)))) (T (\INCPARENCOUNT RSNX)))) (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS))) (GO NEXT) EXIT (\CLOSELINE))) ) (\FILLBUFFER.WORDSEPRP (LAMBDA (CHAR) (* lmm "17-Jan-86 19:44") (OR (EQ WORDSEPR.TC (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA CHAR))) (NEQ OTHER.RC (\SYNCODE RTBLSA CHAR)))) ) (\FILLBUFFER.BACKUP (LAMBDA (CHAR) (* lmm "10-Jan-86 18:32") (DSPBACKUP (CHARWIDTH CHAR \TERM.OFD) \TERM.OFD))) (\GETCHAR (LAMBDA NIL (* lmm "30-Dec-85 17:25") (PROG ((C (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)))) (\ECHOCHAR C) (* ; "Echo here so raise-echo is correct") (RETURN (\RAISECHAR C)))) ) (\INCPARENCOUNT (LAMBDA (RSNX) (* bvm%: "14-Feb-85 00:30") (* ;; "This maintains the paren count as characters are added to the buffer. RSNX is a readtable syntax code. Returns T when parens balance.") (COND ((EQ RSNX STRINGDELIM.RC) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))) NIL) ((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD)) (SELECTC RSNX (LEFTPAREN.RC (AND (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 1)) NIL) (RIGHTPAREN.RC (* ; "NOTE: RP's never match left-brackets, just like on 10") (AND (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (OR (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0) (EQ (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) -1) 0)))) (LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 1) NIL) (RIGHTBRACKET.RC (COND ((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) 0) (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0)) (T (AND (EQ (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD) -1) 0) (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD) 0))))) NIL)))) ) (\RESETLINE (LAMBDA NIL (* jds "10-Apr-85 23:17") (UNINTERRUPTABLY (replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS) (\SETFILEPTR \LINEBUF.OFD 0) (\SETEOFPTR \LINEBUF.OFD 0)) (SETQ \CURRENTDISPLAYLINE 0)) ) (\RESETTERMINAL (LAMBDA NIL (* bvm%: "11-Jul-84 23:15") (DECLARE (GLOBALVARS \VideoColor)) (* ;; "Called by CLEARBUF and by RESET and ERROR! when returning to the TOPFRAME on the stack") (replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0) (replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with 0) (replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with NIL) (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (\RESETLINE) (* ; "Since we aren't immediately filling the buffer, guarantee that the next read causes an EOF error") (VIDEOCOLOR \VideoColor)) ) (\SAVELINEBUF (LAMBDA NIL (* ; "Edited 9-Mar-88 11:41 by bvm") (* ;; "Don't have to set the fileptr to its original place cause we are heading for a \RESETTERMINAL in CLEARBUF") (SELECTC (fetch (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD) (FILLING.LBS (\CLOSELINE)) (RETYPING.LBS (* ; "EOF is valid, but current fileptr isn't") (\SETFILEPTR \LINEBUF.OFD 0)) NIL) (COND ((NOT (\PAGEDEOFP \LINEBUF.OFD)) (LET* ((NBYTES (- (\GETEOFPTR \LINEBUF.OFD) (\GETFILEPTR \LINEBUF.OFD))) (NC NBYTES) (STR (if (EQ (fetch (STREAM CHARSET) of \LINEBUF.OFD) 0) then (* ; "Thin linebuffer") (ALLOCSTRING NC) else (* ; "Fat linebuffer. This should always be the case now") (ALLOCSTRING (SETQ NC (FOLDHI NBYTES 2)) NIL NIL T)))) (* ;; "Read chars into string. Do it this way, rather than thru, say RSTRING, because we want to treat linebuf as an ordinary stream, not a terminal stream; (EOFP T) = NIL would defeat us.") (\BINS \LINEBUF.OFD (fetch (STRINGP BASE) of STR) 0 NBYTES) (if (OR (> NC 1) (NEQ (CHCON1 STR) (CHARCODE CR))) then (* ; "Only something to save if it's not a naked eol.") STR))))) ) (\STOPSCROLL? (LAMBDA NIL (* lmm "11-Feb-86 09:56") (* ;; "Called whenever a carriage-return is printed on the display. Keeps track of number of lines since last user input. If this one would scroll information off the screen, it calls the users window specific function or the function PAGEFULLFN which waits for the user to type a character.") (DECLARE (GLOBALVARS \STOPSCROLLMESSAGE)) (* ; "Set \#DISPLAYLINEs to NIL to disable") (COND ((AND (NEQ \CURRENTDISPLAYLINE -1) (OR (EQ \#DISPLAYLINES 0) (NOT (SMALLP \#DISPLAYLINES))))) ((OR (EQ \CURRENTDISPLAYLINE -1) (EQ \#DISPLAYLINES (SETQ \CURRENTDISPLAYLINE (ADD1 \CURRENTDISPLAYLINE)))) (SETQ \CURRENTDISPLAYLINE 0) (LET ((W (AND \WINDOWWORLD (WFROMDS (TTYDISPLAYSTREAM)))) WINDOWFN) (COND ((AND W (SETQ WINDOWFN (WINDOWPROP W (QUOTE PAGEFULLFN)))) (APPLY* WINDOWFN (TTYDISPLAYSTREAM))) (T (PAGEFULLFN (TTYDISPLAYSTREAM)))))))) ) ) (RPAQQ BCPLDISPLAYCOMS ((FNS \DSCCOUT \INITBCPLDISPLAY) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INITBCPLDISPLAY))) (EXPORT (GLOBALVARS \BCPLDISPLAY)))) (DEFINEQ (\DSCCOUT (LAMBDA (STREAM CHARCODE) (* lmm " 5-OCT-83 18:31") (* ;; "The terminal outcharfn, prior for non-displaystream systems. STREAM is always \TERM.OFD, but passed as an argument so that calling structure is the same as the more general display outcharfn, and thus, so that a simple MOVD can be done to install the display world.") (SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (PROG ((CC CHARCODE)) (add (fetch CHARPOSITION of STREAM) (IPLUS (COND ((IGREATERP CC 127) (* ; "META character") (DSPBOUT (CHARCODE %#)) (SETQ CC (LOGAND CC 127)) 1) (T 0)) (COND ((ILESSP CC 32) (* ; "CONTROL character") (DSPBOUT (CHARCODE ^)) (SETQ CC (LOGOR CC 64)) 1) (T 0)) (PROGN (DSPBOUT CC) 1))))) (SIMULATE.CCE (SELCHARQ CHARCODE (LF (DSPBOUT (CHARCODE EOL)) (RPTQ (fetch CHARPOSITION of STREAM) (DSPBOUT (CHARCODE SPACE))) (\STOPSCROLL?)) (EOL (DSPBOUT (CHARCODE EOL)) (\STOPSCROLL?) (replace CHARPOSITION of STREAM with 0)) (ESCAPE (DSPBOUT (CHARCODE $)) (* ; "change to $") (add (fetch CHARPOSITION of STREAM) 1)) (TAB (FRPTQ (IDIFFERENCE 8 (MOD (fetch CHARPOSITION of STREAM) 8)) (DSPBOUT (CHARCODE SPACE)) (add (fetch CHARPOSITION of STREAM) 1))) (PROGN (DSPBOUT CHARCODE) (add (fetch CHARPOSITION of STREAM) 1)))) (REAL.CCE (DSPBOUT CHARCODE) (COND ((EQ CHARCODE (CHARCODE EOL)) (\STOPSCROLL?) (replace CHARPOSITION of STREAM with 0)) (T (add (fetch CHARPOSITION of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT))) ) (\INITBCPLDISPLAY (LAMBDA NIL (* ; "Edited 17-Jan-87 16:08 by bvm:") (SETQ \BCPLDISPLAY (create STREAM DEVICE _ (create FDEV BOUT _ (FUNCTION \DSCCOUT)) ACCESS _ (QUOTE OUTPUT) LINELENGTH _ 72 USERCLOSEABLE _ NIL USERVISIBLE _ NIL OUTCHARFN _ (FUNCTION \DSCCOUT))) (OR (STREAMP \TERM.OFD) (SETQ \TERM.OFD \BCPLDISPLAY)) (OR (STREAMP *STANDARD-OUTPUT*) (SETQ *STANDARD-OUTPUT* \BCPLDISPLAY))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\INITBCPLDISPLAY) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \BCPLDISPLAY) ) (* "END EXPORTED DEFINITIONS") (DEFINEQ (VIDEOCOLOR (LAMBDA NARGS (* ; "Edited 29-Jul-88 15:30 by drc:") (DECLARE (GLOBALVARS \VideoColor)) (* ;; "sets the interpretation of bits that are displayed on the screen so that 1 is black {NIL} or 1 is white {anything else}.") (PROG1 \VideoColor (COND ((NEQ NARGS 0) (SETQ \VideoColor (AND (ARG NARGS 1) T)) (SELECTC \MACHINETYPE (\MAIKO (SETQ \VideoColor (SUBRCALL DSP-VIDEOCOLOR \VideoColor))) (\DANDELION (replace DLDISPCONTROL of \IOPAGE with (COND (\VideoColor (* ; "Inverse video") (LOGOR 2048 (fetch DLDISPCONTROL of \IOPAGE))) (T (LOGAND (LOGXOR 2048 MAX.SMALLP) (fetch DLDISPCONTROL of \IOPAGE)))))) (\DAYBREAK (DOVE.XOR.CURSOR \DoveDisplay.XorCursor)) (SETSCREENCOLOR \VideoColor)))))) ) ) (RPAQQ \VideoColor NIL) (PUTPROPS VIDEOCOLOR ARGNAMES (BLACKFLG)) (DECLARE%: DOCOPY DONTEVAL@LOAD (MOVD? 'NILL 'SETDISPLAYHEIGHT) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \RAISECHAR MACRO (OPENLAMBDA (C) (COND ((AND (fetch RAISEFLG of \PRIMTERMTABLE) (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (IDIFFERENCE C 32)) (T C)))) (PUTPROPS \LINEBUFBOUT MACRO (OPENLAMBDA (STRM CHAR) (\BOUT STRM (\CHARSET CHAR)) (\BOUT STRM (\CHAR8CODE CHAR)))) ) ) (DEFINEQ (\PEEKREFILL (LAMBDA NIL (* ; "Edited 15-Jun-87 16:26 by jds") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (PROG (C) (COND ((SETQ C (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD)) (* ;; "Saved char, just return it. Ideally we might want to pay attention to echo state, but Interlisp-10 doesn't, so be compatible") (* ;; "Following code is a major crock. Problem is that the eof interface is at the BIN level, but terminal deals in characters, which take two BINs. The code here assumes that the main way we get called is via \NSPEEK macro, which does a \PEEKBIN to start, then a BIN of that character to get it out of the way, then another \PEEKBIN followed by \BACKFILEPTR. We're assuming the \BACKFILEPTR on the buffer stream is a no-op and that it is always called after the second \PEEKBIN. We keep track of whether we're peeking at the left or right half of the character by negating it after the first half is consumed, then making it normal again after the second one (so that a subsequent PEEKC would still return the character). It is also possible to be called here from SKIPSEPR[CODE]S, in which case there might be a real BIN to consume the char if it's a sepr.") (* ;; "Anyway, this code should be reworked someday using the READ-CHAR, PEEK-CHAR stream interface.") (RETURN (SELECTQ (STKNAME (QUOTE (\BIN \PEEKBIN))) (\BIN (* ;; "He is doing a \BIN -- remember for later calls that we have passed over the left half of the character") (COND ((IGREATERP C 0) (* ; "We're looking at the left half. Return it and move to right half.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C)) (\CHARSET (\RAISECHAR C))) (T (* ; "We looked at the left half before. Now return the right half and char is now totally consumed.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL) (\CHAR8CODE (\RAISECHAR (IMINUS C)))))) (COND ((IGREATERP C 0) (* ; "We're still looking at the left half. Return it.") (\CHARSET (\RAISECHAR C))) (T (* ; "We looked at the left half before. Now look at the right half.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C)) (\CHAR8CODE (\RAISECHAR (IMINUS C))))))))) (* ;; "Echo the character, and remember whether we echoed it or not:") (replace (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD with (\ECHOCHAR (SETQ C (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))))) (* ; "First time thru this: Get a key, and echo it.") (\RESETLINE) (* ; "Clear the line buffer.") (* ;; "Save the peeked character OUTSIDE the line buffer, to avoid problems if the guy later types ^E before the character is really read.") (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with C) (RETURN (\CHARSET (\RAISECHAR C))))) ) (\READREFILL (LAMBDA NIL (* AJB "15-Jan-86 14:52") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) READ.FT)) (T (\FILLBUFFER READ.FT))) (CL:FUNCALL (STKNAME (QUOTE (\BIN \PEEKBIN))) \LINEBUF.OFD)) ) (\RATOM/RSTRING-REFILL (LAMBDA NIL (* AJB "15-Jan-86 14:53") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) RATOM/RSTRING.FT)) (T (\FILLBUFFER RATOM/RSTRING.FT))) (\BIN \LINEBUF.OFD)) ) (\READCREFILL (LAMBDA NIL (* AJB "15-Jan-86 14:53") (* ;; "Called from \ENDOFFILE via \RefillBufferFn when the linebuffer is empty") (DECLARE (USEDFREE \LINEBUF.OFD)) (* ;; "If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER as default") (COND ((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) (APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN)) READC.FT)) (T (\FILLBUFFER READC.FT))) (\BIN \LINEBUF.OFD)) ) ) (DEFINEQ (DRIBBLE (LAMBDA (FILE APPENDFLG) (* ; "Edited 16-Jan-87 17:03 by hdj") (* ;; "Turn on/off dribbling for this process") (* ;; "") (* ;; "Dribbling is on if the special variable *dribble-output* is bound to a stream.") (LET ((OLD-DRIBBLE-STREAM (DRIBBLEFILE)) (NEW-DRIBBLE-STREAM NIL)) (* ;;; "Turn off dribbling.") (if OLD-DRIBBLE-STREAM then (* ;; "disable dribbling to old dribble stream") (SETQ *DRIBBLE-OUTPUT* NIL) (replace (STREAM USERCLOSEABLE) of OLD-DRIBBLE-STREAM with T) (replace (STREAM USERVISIBLE) of OLD-DRIBBLE-STREAM with T) (CLOSEF OLD-DRIBBLE-STREAM)) (* ;;; "Turn on dribbling.") (if (AND FILE (NEQ FILE T)) then (SETQ NEW-DRIBBLE-STREAM (OPENSTREAM FILE (COND (APPENDFLG (QUOTE APPEND)) (T (QUOTE OUTPUT))))) (UNINTERRUPTABLY (replace (STREAM USERCLOSEABLE) of NEW-DRIBBLE-STREAM with NIL) (replace (STREAM USERVISIBLE) of NEW-DRIBBLE-STREAM with NIL) (* ;; "Start dribbling to new-dribble-stream.") (SETQ *DRIBBLE-OUTPUT* NEW-DRIBBLE-STREAM))) (AND OLD-DRIBBLE-STREAM (fetch (STREAM FULLNAME) of OLD-DRIBBLE-STREAM)))) ) (DRIBBLEFILE (LAMBDA NIL (* ; "Edited 16-Jan-87 16:06 by hdj") (* ;; "return the stream that this process is dribbling to.") *DRIBBLE-OUTPUT*) ) ) (DEFINEQ (\SETUP.DEFAULT.LINEBUF (LAMBDA NIL (* ; "Edited 13-Apr-87 17:07 by bvm:") (* ;; "Line buffer initialization. First create the line buffer device.") (LET ((DEV (\NODIRCOREFDEV (QUOTE LINEBUFFER)))) (replace (FDEV READP) of DEV with (FUNCTION \LINEBUF.READP)) (* ; "Readp has to look at both keyboard stream and buffer") (replace (FDEV EOFP) of DEV with (FUNCTION NILL)) (* ; "EOFP is always false from terminal. May want this to be different for network terminals") (replace (FDEV PEEKBIN) of DEV with (FUNCTION \LINEBUF.PEEKBIN)) (* ; "PEEKBIN method has implicit EOFP test, so have to supply that ourselves, too.")) (* ;; "create a line buffer device which creates a line buffer the first time one is needed.") (PROG ((STREAM (\OPENFILE (QUOTE {LINEBUFFER}) (QUOTE BOTH) (QUOTE NEW)))) (replace FULLFILENAME of STREAM with T) (* ;; "No-one cares about the true file-name after this, so we make it convenient for code that wants to give a name back to the user") (replace LINEBUFSTATE of STREAM with READING.LBS) (replace USERCLOSEABLE of STREAM with NIL) (replace USERVISIBLE of STREAM with NIL) (* ; "Other linebuffer fields default properly") (replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) (* ; "create a TTY window and make it the tty stream. This also sets up a line buffer.") (\CREATE.TTYDISPLAYSTREAM) (STREAMOP (QUOTE ENDOFSTREAMOP) \LINEBUF.OFD \LINEBUF.OFD)))) (RETURN STREAM))) ) (\CREATELINEBUFFER (LAMBDA (TERMINAL.STREAM) (* ; "Edited 13-Apr-87 22:57 by bvm:") (* ;; "Create a new stream that buffers the raw input from TERMINAL.STREAM (default is the keyboard).") (LET* ((STREAM (\OPENFILE (QUOTE {LINEBUFFER}) (QUOTE BOTH) (QUOTE NEW) (QUOTE ((CHARSET T))))) (DEV (fetch (STREAM DEVICE) of STREAM)) EOFMETHOD) (replace LINEBUFSTATE of STREAM with READING.LBS) (replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM)) (replace USERCLOSEABLE of STREAM with NIL) (replace USERVISIBLE of STREAM with NIL) (* ; "Other linebuffer fields default properly") (replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM) (CL:FUNCALL \RefillBufferFn)))) (if (AND TERMINAL.STREAM (NEQ (SETQ EOFMETHOD (fetch (FDEV EOFP) of TERMINAL.STREAM)) (QUOTE NILL))) then (* ;; "Need to install an eof method for the buffered stream that looks at TERMINAL.STREAM when the buffer runs out. This is optimized away for the normal keyboard case, which never runs out.") (replace (STREAM DEVICE) of STREAM with (SETQ DEV (NCREATE (QUOTE FDEV) DEV))) (* ; "Copy the basic linebuffer device") (replace (FDEV EOFP) of DEV with EOFMETHOD)) STREAM)) ) (\LINEBUF.READP (LAMBDA (STREAM FLG) (* ; "Edited 13-Apr-87 22:05 by bvm:") (LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of STREAM))) (OR (AND KEYSTREAM (READP KEYSTREAM)) (fetch (LINEBUFFER PEEKEDCHAR) of STREAM) (\PAGEDREADP STREAM FLG)))) ) (\LINEBUF.EOFP (LAMBDA (STREAM) (* ; "Edited 13-Apr-87 18:09 by bvm:") (* ;; "End of file for linebuffer: true if both the buffer and the source of characters are empty") (AND (\PAGEDEOFP STREAM) (\EOFP (fetch (LINEBUFFER KEYBOARDSTREAM) of STREAM)))) ) (\LINEBUF.PEEKBIN (LAMBDA (STREAM NOERROR) (* ; "Edited 13-Apr-87 16:53 by bvm:") (OR (\BUFFERED.PEEKBIN STREAM T) (CL:FUNCALL \RefillBufferFn STREAM))) ) (\OPENLINEBUF (LAMBDA NIL (* ; "Edited 17-Jan-87 16:08 by bvm:") (* ;; "Don't assume that \LINEBUF.OFD or \TERM.OFD have been initialized. That way, they won't get smashed if ATERM is reloaded.") (DECLARE (GLOBALVARS DisplayFDEV)) (PROG (STREAM) (* ; "Output parameters") (* ; "Input parameters") (COND ((OR (NOT (type? STREAM \LINEBUF.OFD)) (EQ \LINEBUF.OFD \DEFAULTLINEBUF)) (SETQ \LINEBUF.OFD (\CREATELINEBUFFER)) (OR (AND (type? STREAM *STANDARD-INPUT*) (NEQ *STANDARD-INPUT* \DEFAULTLINEBUF)) (SETQ *STANDARD-INPUT* \LINEBUF.OFD)))) (\RESETTERMINAL))) ) ) (* ; "User entries to make up for fact that (EOFP T) = NIL now.") (DEFINEQ (LINEBUFFER-EOFP (LAMBDA (STREAM) (* ; "Edited 13-Apr-87 17:12 by bvm:") (* ;; "Public interface to %"old functionality%" of (EOFP T) -- returns true if there is no buffered input waiting on stream. If stream is not terminal input, is same as EOFP.") (LET ((S (\GETSTREAM STREAM (QUOTE INPUT)))) (if (EQ S \LINEBUF.OFD) then (\PAGEDEOFP S) else (\EOFP S)))) ) (LINEBUFFER-SKIPSEPRS (LAMBDA (STREAM RDTBL) (* ; "Edited 13-Apr-87 22:05 by bvm:") (* ;; "SKIPSEPRS applied to the terminal input linebuffer. If run out of buffer, return NIL.") (LET ((S (\GETSTREAM STREAM (QUOTE INPUT))) (*READTABLE* (\GTREADTABLE RDTBL)) CH) (if (EQ S \LINEBUF.OFD) then (until (\PAGEDEOFP S) do (if (SYNTAXP (SETQ CH (PEEKCCODE S)) (QUOTE SEPRCHAR)) then (READCCODE S) else (RETURN (CHARACTER CH)))) else (SKIPSEPRS S *READTABLE*)))) ) ) (DECLARE%: DOCOPY DONTEVAL@LOAD (RPAQQ \#DISPLAYLINES 58) (RPAQQ \DISPLAYLINELENGTH 82) (RPAQQ \CURRENTDISPLAYLINE 0) (RPAQ \STOPSCROLLMESSAGE "---MORE---") (RPAQQ \SYSBUF NIL) (RPAQQ \LINBUF NIL) (MOVD? '\OPENLINEBUF '\CREATE.TTYDISPLAYSTREAM) (RPAQ \DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF)) (\OPENLINEBUF) ) (DEFINEQ (\INTERMP (LAMBDA (OFD) (* rrb "21-JUL-83 16:33") (EQ OFD \LINEBUF.OFD))) (\OUTTERMP (LAMBDA (OFD) (* rrb "21-JUL-83 07:23") (EQ OFD \TERM.OFD))) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (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)) (DECLARE%: EVAL@COMPILE (RPAQQ FILLING.LBS 0) (RPAQQ READING.LBS 1) (RPAQQ RETYPING.LBS 2) (CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \INTERMP MACRO ((OFD) (EQ OFD \LINEBUF.OFD))) (PUTPROPS \OUTTERMP MACRO ((OFD) (EQ OFD \TERM.OFD))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DEFAULTLINEBUF) ) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DONTCOPY (RPAQQ FILLTYPES ((READ.FT 0) (RATOM/RSTRING.FT 1) (READC.FT 2))) (DECLARE%: EVAL@COMPILE (RPAQQ READ.FT 0) (RPAQQ RATOM/RSTRING.FT 1) (RPAQQ READC.FT 2) (CONSTANTS (READ.FT 0) (RATOM/RSTRING.FT 1) (READC.FT 2)) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA VIDEOCOLOR TERMINAL-OUTPUT TERMINAL-INPUT) ) (PUTPROPS ATERM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2985 19003 (BKLINBUF 2995 . 3285) (CLEARBUF 3287 . 4073) (LINBUF 4075 . 4196) ( PAGEFULLFN 4198 . 5115) (SETLINELENGTH 5117 . 5238) (SYSBUF 5240 . 5361) (TERMCHARWIDTH 5363 . 5713) ( TERMINAL-INPUT 5715 . 6104) (TERMINAL-OUTPUT 6106 . 6514) (\CHDEL1 6516 . 6738) (\CLOSELINE 6740 . 6941) (\DECPARENCOUNT 6943 . 7768) (\ECHOCHAR 7770 . 8180) (\FILLBUFFER 8182 . 14551) ( \FILLBUFFER.WORDSEPRP 14553 . 14732) (\FILLBUFFER.BACKUP 14734 . 14849) (\GETCHAR 14851 . 15057) ( \INCPARENCOUNT 15059 . 16222) (\RESETLINE 16224 . 16453) (\RESETTERMINAL 16455 . 17020) (\SAVELINEBUF 17022 . 18110) (\STOPSCROLL? 18112 . 19001)) (19214 21062 (\DSCCOUT 19224 . 20661) (\INITBCPLDISPLAY 20663 . 21060)) (21257 21973 (VIDEOCOLOR 21267 . 21971)) (22845 26969 (\PEEKREFILL 22855 . 25582) ( \READREFILL 25584 . 26060) (\RATOM/RSTRING-REFILL 26062 . 26526) (\READCREFILL 26528 . 26967)) (26970 28178 (DRIBBLE 26980 . 28026) (DRIBBLEFILE 28028 . 28176)) (28179 32035 (\SETUP.DEFAULT.LINEBUF 28189 . 29605) (\CREATELINEBUFFER 29607 . 30793) (\LINEBUF.READP 30795 . 31049) (\LINEBUF.EOFP 31051 . 31308) (\LINEBUF.PEEKBIN 31310 . 31468) (\OPENLINEBUF 31470 . 32033)) (32110 32949 (LINEBUFFER-EOFP 32120 . 32484) (LINEBUFFER-SKIPSEPRS 32486 . 32947)) (33306 33472 (\INTERMP 33316 . 33393) (\OUTTERMP 33395 . 33470))))) STOP \ No newline at end of file diff --git a/sources/ATTACHEDWINDOW b/sources/ATTACHEDWINDOW new file mode 100644 index 00000000..51150320 --- /dev/null +++ b/sources/ATTACHEDWINDOW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 17:18:50" {DSK}medley3.5>sources>ATTACHEDWINDOW.;3 124287 changes to%: (FNS RESHAPEALLWINDOWS) previous date%: "28-Jun-99 15:59:05" {DSK}medley3.5>sources>ATTACHEDWINDOW.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1995, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ATTACHEDWINDOWCOMS) (RPAQQ ATTACHEDWINDOWCOMS ((COMS (* User entries) (FNS ATTACHWINDOW ATTACHEDWINDOWS ALLATTACHEDWINDOWS DETACHWINDOW DETACHALLWINDOWS FREEATTACHEDWINDOW MAINWINDOW REMOVEWINDOW REPOSITIONATTACHEDWINDOWS)) (FNS ATTACHEDWINDOWREGION ATTACHEDWINDOWTOTOPFN CENTERINHEIGHT CENTERINWIDTH CENTRALWINDOW CLOSEATTACHEDWINDOWS DOATTACHEDWINDOWCOM DOATTACHEDWINDOWCOM2 DOMAINWINDOWCOMFN EXPANDATTACHEDWINDOWS MAKEMAINWINDOW MAXATTACHEDWINDOWEXTENT MAXIMUMMAINWINDOWSIZE MAXIMUMWINDOWSIZE MINATTACHEDWINDOWEXTENT MINIMUMMAINWINDOWSIZE MOVEATTACHEDWINDOWS MOVEATTACHEDWINDOWTOPLACE OPENATTACHEDWINDOWS RESHAPEALLWINDOWS \TOTALPROPOSEDSIZE SHRINKATTACHEDWINDOWS TOPATTACHEDWINDOWS UNMAKEMAINWINDOW UPIQUOTIENT WINDOWPOSITION WINDOWSIZE \ALLOCMINIMUMSIZES \ALLOCSPACETOGROUPEDWINDOWS \TOTALFIXEDHEIGHT \TOTALFIXEDWIDTH \ALLOCHEIGHTTOGROUPEDWINDOW \ALLOCWIDTHTOGROUPEDWINDOW \ATWGROUPSIZE \BREAKAPARTATWSTRUCTURE \BUILDATWSTRUCTURE \LIMITBYMAX \LIMITBYMIN \MAXHEIGHTOFGROUP \MAXWIDTHOFGROUP \RESHAPEATTACHEDWINDOWSAROUNDMAINW \SETGROUPMIN \SETWINFOXSIZE \SETWINFOYSIZE \SHAREOFXTRAX \SHAREOFXTRAY) (FNS ATTACHMENU CREATEMENUEDWINDOW MENUWINDOW MENUWMINSIZEFN MENUWRESHAPEFN) (FNS GETPROMPTWINDOW \PROMPTWINDOW.EXPAND \PROMPTWINDOW.SET.HEIGHT \PROMPTWINDOW.OPENFN \PROMPTWINDOW.PAGEFULLFN REATTACHPROMPTWINDOW REMOVEPROMPTWINDOW) (DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS RESHAPINGWINDOWDATA) (GLOBALVARS WindowMenu WindowTitleDisplayStream WBorder WindowMenuCommands)) (VARIABLES *ATTACHED-WINDOW-COMMAND-SYNONYMS*))) (* User entries) (DEFINEQ (ATTACHWINDOW [LAMBDA (WINDOWTOATTACH MAINWINDOW EDGE POSITIONONEDGE WINDOWCOMACTION) (* ; "Edited 12-Jan-87 18:12 by woz") (* ;; "attaches a window to another window. EDGE is one of LEFT, RIGHT, TOP or BOTTOM. POSITIONONEDGE is one of NIL {means reshape window to fit new main window size}, {left or bottom}, {center} or {right or top}. The attached window is opened if the main window is open, and not if not.") (PROG (MAINW ATTACHW) (SETQ MAINW (INSURE.WINDOW MAINWINDOW)) (SETQ ATTACHW (INSURE.WINDOW WINDOWTOATTACH)) (COND ((OR (EQ WINDOWTOATTACH MAINWINDOW) (MEMB MAINW (ALLATTACHEDWINDOWS ATTACHW))) (ERROR "Attempt to create a loop in window attachment" ATTACHW) (RETURN))) (SELECTQ EDGE ((LEFT RIGHT TOP BOTTOM)) (NIL (SETQ EDGE 'TOP)) (\ILLEGAL.ARG EDGE)) (SELECTQ POSITIONONEDGE ((JUSTIFY CENTER LEFT RIGHT TOP BOTTOM)) (NIL (SETQ POSITIONONEDGE 'JUSTIFY)) (\ILLEGAL.ARG POSITIONONEDGE)) (MAKEMAINWINDOW MAINW) (WINDOWADDPROP MAINW 'ATTACHEDWINDOWS ATTACHW) (WINDOWPROP ATTACHW 'WHEREATTACHED (CONS EDGE POSITIONONEDGE)) (WINDOWPROP ATTACHW 'MAINWINDOW MAINW) (WINDOWPROP ATTACHW 'TOTOPFN (FUNCTION ATTACHEDWINDOWTOTOPFN)) (* ;; "put a property on the window that will be noticed by DOWINDOWCOM to decide what to do with window command requests.") (WINDOWPROP ATTACHW 'DOWINDOWCOMFN (FUNCTION DOATTACHEDWINDOWCOM)) [SELECTQ WINDOWCOMACTION (MAIN (WINDOWPROP ATTACHW 'PASSTOMAINCOMS T)) (HERE (* ; "leave it alone") (WINDOWPROP ATTACHW 'PASSTOMAINCOMS NIL)) (LOCALCLOSE (* ;  "set up so that closing is handled locally and detaches the window.") (WINDOWADDPROP ATTACHW 'CLOSEFN (FUNCTION DETACHWINDOW)) (WINDOWPROP ATTACHW 'PASSTOMAINCOMS '(MOVEW SHAPEW SHRINKW BURYW))) (WINDOWPROP ATTACHW 'PASSTOMAINCOMS '(CLOSEW MOVEW SHAPEW SHRINKW BURYW] (MOVEATTACHEDWINDOWTOPLACE ATTACHW MAINW EDGE POSITIONONEDGE) (AND (OPENWP MAINW) (OPENW ATTACHW)) (RETURN MAINW]) (ATTACHEDWINDOWS (LAMBDA (WINDOW COM) (* ; "Edited 5-Jul-88 19:01 by drc:") (* ;; "Returns the list of windows attached to this window. COM can be a window command, only the attached windows who allow this COM to be applied to them from above will be returned. An attached window can have a ALLOWMAINCOMS prop, which is a list of allowable commands. If ALLOWMAINCOMS is NIL, all commands are allowed. If COM is not given, all attached windows are returned.") (DECLARE (GLOBALVARS *ATTACHED-WINDOW-COMMAND-SYNONYMS*)) (LET ((AWS (WINDOWPROP WINDOW (QUOTE ATTACHEDWINDOWS)))) (COND ((NULL COM) AWS) (T (LET ((REALCOM (OR (CDR (ASSOC COM *ATTACHED-WINDOW-COMMAND-SYNONYMS*)) COM))) (COND ((for ATTW in AWS thereis (FMEMB COM (WINDOWPROP ATTW (QUOTE REJECTMAINCOMS)))) (* ;; "don't cons new list of windows unless we must") (for ATTW in AWS unless (FMEMB COM (WINDOWPROP ATTW (QUOTE REJECTMAINCOMS))) collect ATTW)) (T AWS))))))) ) (ALLATTACHEDWINDOWS [LAMBDA (MAINW) (* rrb "30-NOV-83 16:29") (* returns a list of all of the windows attached to MAINW or any of its  attached windows.) (PROG ((ATWS (ATTACHEDWINDOWS MAINW))) (RETURN (COND (ATWS (APPEND ATWS (for ATW in ATWS join (ALLATTACHEDWINDOWS ATW]) (DETACHWINDOW (LAMBDA (WINDOWTODETACH MAINWINDOW) (* ; "Edited 5-Jul-88 19:43 by drc:") (* ;;; "detaches a window from its main window.") (PROG ((WHEREAT (WINDOWPROP WINDOWTODETACH (QUOTE WHEREATTACHED) NIL)) (MAINW (OR MAINWINDOW (WINDOWPROP WINDOWTODETACH (QUOTE MAINWINDOW) NIL))) ATWINS PWINDOW OLDFN) (OR MAINW (RETURN NIL)) (WINDOWDELPROP MAINW (QUOTE ATTACHEDWINDOWS) WINDOWTODETACH) (COND ((NOT (ATTACHEDWINDOWS MAINW)) (UNMAKEMAINWINDOW MAINW))) (SELECTQ (SETQ OLDFN (WINDOWPROP WINDOWTODETACH (QUOTE DOWINDOWCOMFN) NIL)) ((DOMAINWINDOWCOMFN DOATTACHEDWINDOWCOM)) (WINDOWPROP WINDOWTODETACH (QUOTE DOWINDOWCOMFN) OLDFN)) (* ; "Remove window's TOTOPFN and DOWINDOWCOMFN if they were the ones that ATTACHWINDOW put there") (SELECTQ (SETQ OLDFN (WINDOWPROP WINDOWTODETACH (QUOTE TOTOPFN) NIL)) (ATTACHEDWINDOWTOTOPFN) (WINDOWPROP WINDOWTODETACH (QUOTE TOTOPFN) OLDFN)) (RETURN WHEREAT))) ) (DETACHALLWINDOWS (LAMBDA (MAINWINDOW) (* ; "Edited 5-Jul-88 19:45 by drc:") (REMOVEPROMPTWINDOW MAINWINDOW) (* ;; "Do this separately so that prompt window is 'permanently' removed, not just locally closed") (for W in (WINDOWPROP MAINWINDOW (QUOTE ATTACHEDWINDOWS)) do (DETACHWINDOW W MAINWINDOW) (CLOSEW W))) ) (FREEATTACHEDWINDOW [LAMBDA (WINDOW) (* jow "16-Aug-85 14:35") (* frees an attached window and snuggles any other attached windows closer to  the main window. Only the windows that allowed MOVEW will be snuggled.) (LET* [(MAINWINDOW (MAINWINDOW WINDOW)) [ATWINS (COPY (ATTACHEDWINDOWS MAINWINDOW 'MOVEW] (REGION (WINDOWPROP WINDOW 'REGION)) (BOTTOM (fetch (REGION BOTTOM) of REGION)) (HEIGHT (fetch (REGION HEIGHT) of REGION)) (EDGE (CAR (WINDOWPROP WINDOW 'WHEREATTACHED] (DETACHWINDOW WINDOW) (SELECTQ EDGE (TOP [for ATWIN in ATWINS when (IGREATERP (fetch (REGION BOTTOM) of (WINDOWPROP ATWIN 'REGION)) BOTTOM) do (RELMOVEW ATWIN (create POSITION XCOORD _ 0 YCOORD _ (IMINUS HEIGHT]) (BOTTOM (for ATWIN in ATWINS when (ILESSP (fetch (REGION BOTTOM) of (WINDOWPROP ATWIN 'REGION)) BOTTOM) do (RELMOVEW ATWIN (create POSITION XCOORD _ 0 YCOORD _ HEIGHT)))) NIL]) (MAINWINDOW [LAMBDA (WINDOW RECURSEFLG) (* rrb "20-Aug-84 09:45") (* * returns the main window of a window.  If recurseflg is T, continues until it finds a window not attached to any  other.) (PROG ((WIN (\INSUREWINDOW WINDOW)) MAINW) (COND ([NULL (SETQ MAINW (WINDOWPROP WIN 'MAINWINDOW] (RETURN WIN)) ((NULL RECURSEFLG) (RETURN MAINW))) LP (COND ([NULL (SETQ WIN (WINDOWPROP MAINW 'MAINWINDOW] (RETURN MAINW)) (T (SETQ MAINW WIN) (GO LP]) (REMOVEWINDOW [LAMBDA (WINDOW) (* jow "16-Aug-85 14:37") (* Closes an attached window and then calls FREEATTACHEDWINDOW to snuggle up  other windows) (CLOSEW WINDOW) (FREEATTACHEDWINDOW WINDOW]) (REPOSITIONATTACHEDWINDOWS [LAMBDA (WINDOW) (* ; "Edited 6-Jan-87 14:38 by woz") (* can be a main window's RESHAPEFN. used when some attached windows don't want  to be reshaped, but do want to be repositioned after a reshape.) (for ATTW in (ATTACHEDWINDOWS WINDOW 'MOVEW) do (MOVEATTACHEDWINDOWTOPLACE ATTW WINDOW) (OR (OPENWP ATTW) (\OPENW1 ATTW]) ) (DEFINEQ (ATTACHEDWINDOWREGION [LAMBDA (MAINW COM) (* jow "15-Aug-85 13:08") (* returns the region of the area taken up by a window and all of its attached  windows. COM can be the command that this region is being calculated for, and  is passed to ATTACHEDWINDOWS so windows can except themselves.) (PROG [(REG (WINDOWPROP MAINW 'REGION] [for ATWIN in (ATTACHEDWINDOWS MAINW COM) do (SETQ REG (UNIONREGIONS REG (WINDOWREGION ATWIN] (RETURN REG]) (ATTACHEDWINDOWTOTOPFN [LAMBDA (WINDOW) (* ; "Edited 17-Aug-88 19:46 by jds") (* ;; "This function causes both the main window and its attached windows to be visible when either is selected") (LET ((ROOT (MAINWINDOW WINDOW T))) (* ;; "start at the root & let it propagate down ") (COND ((AND (WINDOWP ROOT) (NEQ ROOT WINDOW)) (TOTOPW ROOT]) (CENTERINHEIGHT [LAMBDA (HEIGHTTOCENTER RELATIVETOREGION) (* ; "Edited 13-Jan-87 13:52 by woz") (* returns the bottom coordinate that a height needs to be centered relative to  a region.) (PLUS (fetch (REGION BOTTOM) of RELATIVETOREGION) (IQUOTIENT (DIFFERENCE (fetch (REGION HEIGHT) of RELATIVETOREGION) HEIGHTTOCENTER) 2]) (CENTERINWIDTH [LAMBDA (WIDTHTOCENTER RELATIVETOREGION) (* rrb "15-NOV-83 13:21") (* returns the left coordinate that a width needs to be centered relative to a  region.) (PLUS (fetch (REGION LEFT) of RELATIVETOREGION) (IQUOTIENT (DIFFERENCE (fetch (REGION WIDTH) of RELATIVETOREGION) WIDTHTOCENTER) 2]) (CENTRALWINDOW [LAMBDA (WINDOW) (* rrb "30-Dec-83 13:59") (* returns the window that is a main window to this one and is not itself  attached to any other.) (PROG (MAINW) LP (COND ((SETQ MAINW (WINDOWPROP WINDOW 'MAINWINDOW)) (SETQ WINDOW MAINW) (GO LP))) (RETURN WINDOW]) (CLOSEATTACHEDWINDOWS [LAMBDA (WINDOW) (* jow "15-Aug-85 13:02") (* propagates closing to attached  windows.) (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW 'CLOSEW) do (CLOSEW ATTACHEDWINDOW) (WINDOWPROP ATTACHEDWINDOW 'MAINWINDOW NIL]) (DOATTACHEDWINDOWCOM [LAMBDA (ATTACHEDW) (* ; "Edited 16-Jul-92 11:22 by cat") (* ; "Edited 22-Jan-88 13:35 by woz") (* ;; "a right button function for attached windows that brings up the window command menu and then, depending upon the command selected, either passes the command to the main window or performs it on the attached window. The commands in the windowprop PASSTOMAINCOMS are passed to the central window. Others are applied to ATTACHEDW.") (COND ((WINDOWP ATTACHEDW) (TOTOPW ATTACHEDW) (LET [(COM (MENU (COND ((type? MENU WindowMenu) WindowMenu) (T (SETQ WindowMenu (create MENU ITEMS _ WindowMenuCommands CHANGEOFFSETFLG _ 'Y MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) WHENHELDFN _ (FUNCTION PPROMPT3) WHENUNHELDFN _ (FUNCTION CLRPROMPT) CENTERFLG _ T] (CL:WHEN COM (COND ([OR (EQ (WINDOWPROP ATTACHEDW 'PASSTOMAINCOMS) T) (MEMB (OR (CDR (ASSOC COM *ATTACHED-WINDOW-COMMAND-SYNONYMS*)) COM) (WINDOWPROP ATTACHEDW 'PASSTOMAINCOMS] (APPLY* COM (CENTRALWINDOW ATTACHEDW))) (T (APPLY* COM ATTACHEDW))) T))) ((NULL ATTACHEDW) (DOBACKGROUNDCOM]) (DOATTACHEDWINDOWCOM2 [LAMBDA (ATTACHEDW) (* rrb "28-Mar-84 11:25") (* a right button function for attached windows that want to handle CLOSE  locally.) (DOATTACHEDWINDOWCOM ATTACHEDW T]) (DOMAINWINDOWCOMFN [LAMBDA (ATTACHEDW) (* rrb "10-Dec-83 14:57") (* applies the right button function  of the main window.) (PROG (MAINW) (RETURN (APPLY* (OR (WINDOWPROP (SETQ MAINW (WINDOWPROP ATTACHEDW 'MAINWINDOW)) 'RIGHTBUTTONFN) (FUNCTION DOWINDOWCOM)) MAINW]) (EXPANDATTACHEDWINDOWS [LAMBDA (WINDOW) (* ; "Edited 5-Mar-87 11:03 by lal") (* ;  "propagates expanding to attached windows.") (* ;  "doesn't allow the attached window functions to stop the expanding.") (if (WINDOWPROP WINDOW 'EXPANDREGIONFN) then (REPOSITIONATTACHEDWINDOWS WINDOW) else (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW 'EXPANDW) do (OR (OPENWP ATTACHEDWINDOW) (DOUSERFNS (WINDOWPROP ATTACHEDWINDOW 'EXPANDFN) ATTACHEDWINDOW)) (* ;  "the expandfn may have opened the window.") (OR (OPENWP ATTACHEDWINDOW) (\OPENW1 ATTACHEDWINDOW]) (MAKEMAINWINDOW [LAMBDA (MAINWINDOW) (* jow "15-Aug-85 13:23") (* puts the necessary functions on a window to propagate its activities to all  of its attached windows.) (* has functions for moving,  reshaping, totoping) (WINDOWADDPROP MAINWINDOW 'TOTOPFN (FUNCTION TOPATTACHEDWINDOWS)) (WINDOWADDPROP MAINWINDOW 'CLOSEFN (FUNCTION CLOSEATTACHEDWINDOWS)) (WINDOWADDPROP MAINWINDOW 'OPENFN (FUNCTION OPENATTACHEDWINDOWS)) (WINDOWADDPROP MAINWINDOW 'SHRINKFN (FUNCTION SHRINKATTACHEDWINDOWS)) (WINDOWADDPROP MAINWINDOW 'EXPANDFN (FUNCTION EXPANDATTACHEDWINDOWS)) (WINDOWPROP MAINWINDOW 'CALCULATEREGIONFN (FUNCTION ATTACHEDWINDOWREGION)) [PROG [(OLDMINSIZE (WINDOWPROP MAINWINDOW 'MINSIZE)) (OLDMAXSIZE (WINDOWPROP MAINWINDOW 'MAXSIZE] (* move this windows minsize function and maxsize onto a different place.) (COND ((AND OLDMINSIZE (NEQ OLDMINSIZE (FUNCTION MINATTACHEDWINDOWEXTENT))) (WINDOWPROP MAINWINDOW 'MAINWINDOWMINSIZE OLDMINSIZE))) (COND ((AND OLDMAXSIZE (NEQ OLDMAXSIZE (FUNCTION MAXATTACHEDWINDOWEXTENT))) (WINDOWPROP MAINWINDOW 'MAINWINDOWMAXSIZE OLDMAXSIZE] (WINDOWPROP MAINWINDOW 'MINSIZE (FUNCTION MINATTACHEDWINDOWEXTENT)) (WINDOWPROP MAINWINDOW 'MAXSIZE (FUNCTION MAXATTACHEDWINDOWEXTENT)) (WINDOWADDPROP MAINWINDOW 'MOVEFN (FUNCTION MOVEATTACHEDWINDOWS)) (WINDOWPROP MAINWINDOW 'DOSHAPEFN (FUNCTION RESHAPEALLWINDOWS]) (MAXATTACHEDWINDOWEXTENT [LAMBDA (MAINW) (* bvm%: "29-Dec-83 15:57") (* returns the maximum extent of a window computing it from the attached  windows if necessary.) (PROG ((ATWS (ATTACHEDWINDOWS MAINW)) (EXTENT (MAXIMUMMAINWINDOWSIZE MAINW)) TL TC TR RT RC RB BR BC BL LB LC LT) [COND ((NULL ATWS) (RETURN EXTENT)) ((NULL EXTENT) (* if the main window is willing to expand, start with a large maximum) (RETURN (SETQ EXTENT (CONS 64000 64000] [SETQ TL (SETQ TC (SETQ TR (CDR EXTENT] [SETQ RT (SETQ RC (SETQ RB (CAR EXTENT] (SETQ BR (SETQ BC (SETQ BL 0))) (SETQ LB (SETQ LC (SETQ LT 0))) (bind ATWHERE WHERECODE ATWDTH ATWHGHT for ATW in ATWS do (* go through the attached windows keeping track of their effect on the extent.) (SETQ EXTENT (MAXIMUMWINDOWSIZE ATW)) (SETQ ATWDTH (OR (CAR EXTENT) 64000)) (SETQ ATWHGHT (OR (CDR EXTENT) 64000)) (SETQ WHERECODE (SELECTQ [CDR (SETQ ATWHERE (WINDOWPROP ATW 'WHEREATTACHED] (JUSTIFY 'JUSTIFY) (CENTER 0) ((LEFT BOTTOM) -1) 1)) (SELECTQ (CAR ATWHERE) (TOP [COND ((GREATERP ATWDTH (DIFFERENCE RT LT)) (* check to see if min width pushes the width.  This could push either way and is actually not right because a later window on  the left or right top could use this extra.) (SETQ RT (PLUS ATWDTH LT] (SELECTQ WHERECODE (JUSTIFY [SETQ TL (SETQ TC (SETQ TR (PLUS (MAX TL TC TR) ATWHGHT]) (-1 (SETQ TL (PLUS TL ATWHGHT))) (0 (SETQ TC (PLUS TC ATWHGHT))) (1 (SETQ TR (PLUS TR ATWHGHT))) (SHOULDNT))) (RIGHT [COND ((GREATERP ATWHGHT (DIFFERENCE TR BR)) (SETQ TR (PLUS ATWHGHT BR] (SELECTQ WHERECODE (JUSTIFY [SETQ RT (SETQ RC (SETQ RB (PLUS (MAX RT RC RB) ATWDTH]) (1 (SETQ RT (PLUS RT ATWDTH))) (0 (SETQ RC (PLUS RC ATWDTH))) (-1 (SETQ RB (PLUS RB ATWDTH))) (SHOULDNT))) (LEFT [COND ((GREATERP ATWHGHT (DIFFERENCE TL BL)) (SETQ TL (PLUS ATWHGHT BL] (SELECTQ WHERECODE (JUSTIFY [SETQ LT (SETQ LC (SETQ LB (DIFFERENCE (MIN LT LC LB) ATWDTH]) (1 (SETQ LT (DIFFERENCE LT ATWDTH))) (0 (SETQ LC (DIFFERENCE LC ATWDTH))) (-1 (SETQ LB (DIFFERENCE LB ATWDTH))) (SHOULDNT))) (BOTTOM [COND ((GREATERP ATWDTH (DIFFERENCE RB LB)) (SETQ RB (PLUS ATWDTH LB] (SELECTQ WHERECODE (JUSTIFY [SETQ BL (SETQ BC (SETQ BR (DIFFERENCE (MIN BL BC BR) ATWHGHT]) (-1 (SETQ BL (DIFFERENCE BL ATWHGHT))) (0 (SETQ BC (DIFFERENCE BC ATWHGHT))) (1 (SETQ BR (DIFFERENCE BR ATWHGHT))) (SHOULDNT))) (SHOULDNT))) (RETURN (CONS (DIFFERENCE (MAX RT RC RB) (MIN LT LC LB)) (DIFFERENCE (MAX TL TC TR) (MIN BL BC BR]) (MAXIMUMMAINWINDOWSIZE [LAMBDA (WINDOW) (* bvm%: "29-Dec-83 15:46") (* returns the maximum extent of a  main window) (PROG [(EXT (WINDOWPROP WINDOW 'MAINWINDOWMAXSIZE] [COND ((NULL EXT) (RETURN NIL)) ((LITATOM EXT) (SETQ EXT (APPLY* EXT WINDOW] [COND [(AND (NUMBERP (CAR EXT)) (NUMBERP (CDR EXT] (T (SETQ EXT (ERROR "Illegal maximum size property" EXT] (RETURN EXT]) (MAXIMUMWINDOWSIZE [LAMBDA (WINDOW) (* rrb "19-Mar-84 14:23") (* returns the maximum extent of a  window) (PROG [(EXT (WINDOWPROP WINDOW 'MAXSIZE] [COND ((NULL EXT) (RETURN NIL)) ((LITATOM EXT) (SETQ EXT (APPLY* EXT WINDOW] [COND [(AND (OR (NULL (CAR EXT)) (NUMBERP (CAR EXT))) (OR (NULL (CDR EXT)) (NUMBERP (CDR EXT] (EXT (SETQ EXT (ERROR "Illegal extent property" EXT] (RETURN EXT]) (MINATTACHEDWINDOWEXTENT [LAMBDA (MAINW) (* rrb "15-Dec-83 10:16") (* returns the extent of a window computing it from the attached windows if  necessary.) (PROG ((ATWS (ATTACHEDWINDOWS MAINW)) (EXTENT (MINIMUMMAINWINDOWSIZE MAINW)) TL TC TR RT RC RB BR BC BL LB LC LT) (COND ((NULL ATWS) (RETURN EXTENT))) [SETQ TL (SETQ TC (SETQ TR (CDR EXTENT] [SETQ RT (SETQ RC (SETQ RB (CAR EXTENT] (SETQ BR (SETQ BC (SETQ BL 0))) (SETQ LB (SETQ LC (SETQ LT 0))) (bind ATWHERE WHERECODE ATWDTH ATWHGHT for ATW in ATWS do (* go through the attached windows keeping track of their effect on the extent.) (SETQ EXTENT (MINIMUMWINDOWSIZE ATW)) (SETQ ATWDTH (CAR EXTENT)) (SETQ ATWHGHT (CDR EXTENT)) (SETQ WHERECODE (SELECTQ [CDR (SETQ ATWHERE (WINDOWPROP ATW 'WHEREATTACHED] (JUSTIFY 'JUSTIFY) (CENTER 0) ((LEFT BOTTOM) -1) 1)) (SELECTQ (CAR ATWHERE) (TOP [COND ((GREATERP ATWDTH (DIFFERENCE RT LT)) (* check to see if min width pushes the width.  This could push either way and is actually not right because a later window on  the left or right top could use this extra.) (SETQ RT (PLUS ATWDTH LT] (SELECTQ WHERECODE (JUSTIFY [SETQ TL (SETQ TC (SETQ TR (PLUS (MAX TL TC TR) ATWHGHT]) (-1 (SETQ TL (PLUS TL ATWHGHT))) (0 (SETQ TC (PLUS TC ATWHGHT))) (1 (SETQ TR (PLUS TR ATWHGHT))) (SHOULDNT))) (RIGHT [COND ((GREATERP ATWHGHT (DIFFERENCE TR BR)) (SETQ TR (PLUS ATWHGHT BR] (SELECTQ WHERECODE (JUSTIFY [SETQ RT (SETQ RC (SETQ RB (PLUS (MAX RT RC RB) ATWDTH]) (1 (SETQ RT (PLUS RT ATWDTH))) (0 (SETQ RC (PLUS RC ATWDTH))) (-1 (SETQ RB (PLUS RB ATWDTH))) (SHOULDNT))) (LEFT [COND ((GREATERP ATWHGHT (DIFFERENCE TL BL)) (SETQ TL (PLUS ATWHGHT BL] (SELECTQ WHERECODE (JUSTIFY [SETQ LT (SETQ LC (SETQ LB (DIFFERENCE (MIN LT LC LB) ATWDTH]) (1 (SETQ LT (DIFFERENCE LT ATWDTH))) (0 (SETQ LC (DIFFERENCE LC ATWDTH))) (-1 (SETQ LB (DIFFERENCE LB ATWDTH))) (SHOULDNT))) (BOTTOM [COND ((GREATERP ATWDTH (DIFFERENCE RB LB)) (SETQ RB (PLUS ATWDTH LB] (SELECTQ WHERECODE (JUSTIFY [SETQ BL (SETQ BC (SETQ BR (DIFFERENCE (MIN BL BC BR) ATWHGHT]) (-1 (SETQ BL (DIFFERENCE BL ATWHGHT))) (0 (SETQ BC (DIFFERENCE BC ATWHGHT))) (1 (SETQ BR (DIFFERENCE BR ATWHGHT))) (SHOULDNT))) (SHOULDNT))) (RETURN (CONS (DIFFERENCE (MAX RT RC RB) (MIN LT LC LB)) (DIFFERENCE (MAX TL TC TR) (MIN BL BC BR]) (MINIMUMMAINWINDOWSIZE [LAMBDA (WINDOW) (* rrb "24-Sep-86 14:03") (* returns the minimum extent of a  window) (PROG [(EXT (WINDOWPROP WINDOW 'MAINWINDOWMINSIZE] [COND [(NULL EXT) (SETQ EXT (CONS 26 (HEIGHTIFWINDOW (FONTPROP WINDOW 'HEIGHT) (WINDOWPROP WINDOW 'TITLE] ((LITATOM EXT) (SETQ EXT (APPLY* EXT WINDOW] [COND [(AND (NUMBERP (CAR EXT)) (NUMBERP (CDR EXT] (T (SETQ EXT (ERROR "Illegal extent property" EXT] (RETURN EXT]) (MOVEATTACHEDWINDOWS (LAMBDA (WINDOW NEWPOS) (* ; "Edited 8-Jul-88 11:00 by drc:") (* ; "propagates moving to attached windows.") (PROG ((DELTA (PTDIFFERENCE NEWPOS (WINDOWPOSITION WINDOW)))) (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW (QUOTE MOVEW)) do (* ;; "bring each to top by hand so we don't bring whole tree to top for each one we move") (AND (OPENWP ATTACHEDWINDOW) (TOTOPW ATTACHEDWINDOW T)) (MOVEW ATTACHEDWINDOW (PTPLUS (WINDOWPOSITION ATTACHEDWINDOW) DELTA)) (* ;; "main window (non-terminal) about to be moved. bring it to top by hand so that whole tree doesn't get brought to top. ") (AND (OPENWP WINDOW) (TOTOPW WINDOW T))))) ) (MOVEATTACHEDWINDOWTOPLACE [LAMBDA (ATWIN MAINW EDGE POSONEDGE) (* ; "Edited 12-Jan-87 17:01 by woz") (* DECLARATIONS%: (RECORD  ATTACHEDWINDATA ((EDGE . WHEREONEDGE)  WID . HGHT))) (* ;;; "moves a window to the place it should be relative to MAINW and reshapes it if it is JUSTIFY. The window will be opened if it is justified, and otherwise will not. This function should not open the window; it is a nasty side effect of reshaping the window. So if the main window is not open, punt, and let the openfn take care of calling me again, because the attached window shouldn't be opened. If the main window is open, the attached window will be moved into position, and it is the responsibility of the caller to ensure that the window gets opened. ") (AND (OPENWP MAINW) (PROG (MAINWEXTENT EXTENT ATMINWIDTH ATMINHEIGHT ATWHGHT ATWDTH TL TC TR RT RC RB BR BC BL LB LC LT) [COND ((NULL EDGE) (SETQ EDGE (WINDOWPROP ATWIN 'WHEREATTACHED)) (SETQ POSONEDGE (CDR EDGE)) (SETQ EDGE (CAR EDGE] (* ;  "calculate the minimum so that this window won't be reshaped smaller than its minimum.") [SETQ ATMINHEIGHT (CDR (SETQ ATMINWIDTH (MINIMUMWINDOWSIZE ATWIN] (SETQ ATMINWIDTH (CAR ATMINWIDTH)) (SETQ POSONEDGE (SELECTQ POSONEDGE (JUSTIFY 'JUSTIFY) (CENTER 0) ((LEFT BOTTOM) -1) 1)) (SETQ MAINWEXTENT (WINDOWPROP MAINW 'REGION)) (* ;; "the extent of a group of windows is thought of as its maximum extent along each edge and each position on that edge eg. top-left, top-center, top-right. A justify takes the maximum of the three positions along that edge.") [SETQ TL (SETQ TC (SETQ TR (fetch (REGION TOP) of MAINWEXTENT] [SETQ RT (SETQ RC (SETQ RB (fetch (REGION RIGHT) of MAINWEXTENT] [SETQ BR (SETQ BC (SETQ BL (fetch (REGION BOTTOM) of MAINWEXTENT] [SETQ LB (SETQ LC (SETQ LT (fetch (REGION LEFT) of MAINWEXTENT] (bind ATWHERE ATPOSONEDGE ATWREG for ATW in (ATTACHEDWINDOWS MAINW) until (EQ ATW ATWIN) do (* ;; "go through the attached windows keeping track of their effect on the position. Only consider windows attached to MAINW before ATWIN.") (SETQ ATWREG (WINDOWREGION ATW)) (SETQ ATWHGHT (fetch (REGION HEIGHT) of ATWREG)) (SETQ ATWDTH (fetch (REGION WIDTH) of ATWREG)) (SETQ ATPOSONEDGE (SELECTQ [CDR (SETQ ATWHERE (WINDOWPROP ATW 'WHEREATTACHED] (JUSTIFY 'JUSTIFY) (CENTER 0) ((LEFT BOTTOM) -1) 1)) (SELECTQ (CAR ATWHERE) (TOP (SELECTQ ATPOSONEDGE (JUSTIFY [SETQ TL (SETQ TC (SETQ TR (PLUS (MAX TL TC TR) ATWHGHT]) (-1 (SETQ TL (PLUS TL ATWHGHT))) (0 (SETQ TC (PLUS TC ATWHGHT))) (1 (SETQ TR (PLUS TR ATWHGHT))) (SHOULDNT))) (RIGHT (SELECTQ ATPOSONEDGE (JUSTIFY [SETQ RT (SETQ RC (SETQ RB (PLUS (MAX RT RC RB) ATWDTH]) (1 (SETQ RT (PLUS RT ATWDTH))) (0 (SETQ RC (PLUS RC ATWDTH))) (-1 (SETQ RB (PLUS RB ATWDTH))) (SHOULDNT))) (LEFT (SELECTQ ATPOSONEDGE (JUSTIFY [SETQ LT (SETQ LC (SETQ LB (DIFFERENCE (MIN LT LC LB) ATWDTH]) (1 (SETQ LT (DIFFERENCE LT ATWDTH))) (0 (SETQ LC (DIFFERENCE LC ATWDTH))) (-1 (SETQ LB (DIFFERENCE LB ATWDTH))) (SHOULDNT))) (BOTTOM (SELECTQ ATPOSONEDGE (JUSTIFY [SETQ BL (SETQ BC (SETQ BR (DIFFERENCE (MAX BL BC BR) ATWHGHT]) (-1 (SETQ BL (DIFFERENCE BL ATWHGHT))) (0 (SETQ BC (DIFFERENCE BC ATWHGHT))) (1 (SETQ BR (DIFFERENCE BR ATWHGHT))) (SHOULDNT))) (SHOULDNT))) (* ; "now position the window") (SETQ EXTENT (WINDOWREGION ATWIN)) (SETQ ATWHGHT (fetch (REGION HEIGHT) of EXTENT)) (SETQ ATWDTH (fetch (REGION WIDTH) of EXTENT)) (COND ((EQ POSONEDGE 'JUSTIFY) (SHAPEW ATWIN (SELECTQ EDGE (TOP (CREATEREGION LT (ADD1 (MAX TL TC TR)) (IMAX (ADD1 (DIFFERENCE RT LT)) ATMINWIDTH) ATWHGHT)) (RIGHT (CREATEREGION (ADD1 (MAX RT RC RB)) BR ATWDTH (IMAX (ADD1 (DIFFERENCE TR BR)) ATMINHEIGHT))) (LEFT (CREATEREGION (DIFFERENCE (MIN LT LC LB) ATWDTH) BL ATWDTH (IMAX (ADD1 (DIFFERENCE TL BL)) ATMINHEIGHT))) (BOTTOM (CREATEREGION LB (DIFFERENCE (MIN BL BC BR) ATWHGHT) (IMAX (ADD1 (DIFFERENCE RB LB)) ATMINWIDTH) ATWHGHT)) NIL))) (T (SELECTQ EDGE (TOP (SELECTQ POSONEDGE (1 (MOVEW ATWIN (ADD1 (DIFFERENCE RT ATWDTH)) (ADD1 TR))) (0 (MOVEW ATWIN (CENTERINWIDTH ATWDTH MAINWEXTENT) (ADD1 TC))) (MOVEW ATWIN LT (ADD1 TL)))) (RIGHT (SELECTQ POSONEDGE (1 (MOVEW ATWIN (ADD1 RT) (ADD1 (DIFFERENCE TR ATWHGHT)))) (0 (MOVEW ATWIN (ADD1 RC) (CENTERINHEIGHT ATWHGHT MAINWEXTENT))) (MOVEW ATWIN (ADD1 RB) BR))) (LEFT (SELECTQ POSONEDGE (1 (MOVEW ATWIN (DIFFERENCE LT ATWDTH) (ADD1 (DIFFERENCE TL ATWHGHT)))) (0 (MOVEW ATWIN (DIFFERENCE LC ATWDTH) (CENTERINHEIGHT ATWHGHT MAINWEXTENT))) (MOVEW ATWIN (DIFFERENCE LB ATWDTH) BL))) (BOTTOM (SELECTQ POSONEDGE (1 (MOVEW ATWIN (ADD1 (DIFFERENCE RB ATWDTH)) (DIFFERENCE BR ATWHGHT))) (0 (MOVEW ATWIN (CENTERINWIDTH ATWDTH MAINWEXTENT) (DIFFERENCE BC ATWHGHT))) (MOVEW ATWIN LB (DIFFERENCE BL ATWHGHT)))) NIL]) (OPENATTACHEDWINDOWS [LAMBDA (WINDOW) (* ; "Edited 12-Jan-87 11:11 by woz") (* ;;; "propagates opening to attached windows. since MOVEATTACHEDWINDOWTOPLACE punts when the main window is closed, must call it here to ensure the attached window is positioned.") (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW 'OPENW) do (* ;; "reestablish the link from the attached window and the main window.") (WINDOWPROP ATTACHEDWINDOW 'MAINWINDOW WINDOW) (MOVEATTACHEDWINDOWTOPLACE ATTACHEDWINDOW WINDOW) (OPENW ATTACHEDWINDOW]) (RESHAPEALLWINDOWS [LAMBDA (MAINW NEWREGION MAINONLYFLG) (* ; "Edited 24-Jan-97 11:27 by rmk:") (* DAHJr "11-Oct-86 18:57") (* reshapes all of the windows in a  group.) (* calculate all of the attached  window sizes) (PROG ((ATWINS (ATTACHEDWINDOWS MAINW 'SHAPEW)) (MWXOFF 0) (MWYOFF 0) (NEWWIDTH (fetch (REGION WIDTH) of NEWREGION)) (NEWHEIGHT (fetch (REGION HEIGHT) of NEWREGION)) FIXEDVAR TOTALNOWSIZE EXPANSIONWIDTH EXPANSIONHEIGHT NEWEXPANDABLEWIDTH NEWEXPANDABLEHEIGHT ATWINSINFO EXCESS NOW) [COND ((NULL ATWINS) (RETURN (SHAPEW1 MAINW NEWREGION))) (MAINONLYFLG (SHAPEW1 MAINW NEWREGION) (RETURN (\RESHAPEATTACHEDWINDOWSAROUNDMAINW MAINW (\BREAKAPARTATWSTRUCTURE (CDR (\BUILDATWSTRUCTURE MAINW ATWINS] (SETQ TOTALNOWSIZE (WINDOWSIZE MAINW)) (* calculate the amount of the total size that is available to change.  This ignores the case where a window can only expand 5 but its share would be  10 but it is easy and better than nothing.) (SETQ ATWINSINFO (\BUILDATWSTRUCTURE MAINW ATWINS)) (\ALLOCMINIMUMSIZES ATWINSINFO 0 0) [SETQ EXPANSIONWIDTH (IDIFFERENCE (CAR TOTALNOWSIZE) (SETQ FIXEDVAR (\TOTALFIXEDWIDTH ATWINSINFO] (SETQ NEWEXPANDABLEWIDTH (IMAX (DIFFERENCE NEWWIDTH FIXEDVAR) 0)) [SETQ EXPANSIONHEIGHT (IDIFFERENCE (CDR TOTALNOWSIZE) (SETQ FIXEDVAR (\TOTALFIXEDHEIGHT ATWINSINFO] (SETQ NEWEXPANDABLEHEIGHT (IMAX (DIFFERENCE NEWHEIGHT FIXEDVAR) 0)) (* make a pass through allocating each window a portion of the space that is in  excess of the minimum. In this pass, the grouped windows are treated as a  whole. (If there is no space in excess of minimum, allocate on the basis of the  actual size of the windows -- Austin Henderson |10-11-86|)) [for ATWINFO in ATWINSINFO do [COND [(EQP EXPANSIONWIDTH 0) (\SETWINFOXSIZE ATWINFO (\SHAREOFXTRAX ATWINFO (fetch (RESHAPINGWINDOWDATA ATNOWX) of ATWINFO) (CAR TOTALNOWSIZE] (T (\SETWINFOXSIZE ATWINFO (\SHAREOFXTRAX ATWINFO NEWEXPANDABLEWIDTH EXPANSIONWIDTH] (COND [(EQP EXPANSIONHEIGHT 0) (\SETWINFOYSIZE ATWINFO (\SHAREOFXTRAY ATWINFO (fetch (RESHAPINGWINDOWDATA ATNOWY) of ATWINFO) (CDR TOTALNOWSIZE] (T (\SETWINFOYSIZE ATWINFO (\SHAREOFXTRAY ATWINFO NEWEXPANDABLEHEIGHT EXPANSIONHEIGHT] (* now go through allocate the space  within the groups of windows.) (for ATWINFO in ATWINSINFO when (LISTP (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of ATWINFO)) do (\ALLOCSPACETOGROUPEDWINDOWS ATWINFO)) (* calculate how much of the available space was actually allocated.  This is necessary because some of the windows may have reached their maximum  and hence left some space not used. The extra is given to the main window.  The main window is shaped first so that user reshape functions can determine  its size and shape as they do their thing.) (SETQ TOTALNOWSIZE (\TOTALPROPOSEDSIZE ATWINSINFO)) [COND ((NEQ (SETQ EXCESS (IDIFFERENCE NEWWIDTH (CAR TOTALNOWSIZE))) 0) (* Feed the excess width to any windows that will take it, starting with the  main window) (for ATWINFO in ATWINSINFO do (SETQ EXCESS (IDIFFERENCE EXCESS (IDIFFERENCE (\SETWINFOXSIZE ATWINFO (IPLUS (SETQ NOW (fetch ( RESHAPINGWINDOWDATA ATXSIZE) of ATWINFO)) EXCESS)) NOW))) repeatuntil (EQ EXCESS 0] [COND ((NEQ (SETQ EXCESS (IDIFFERENCE NEWHEIGHT (CDR TOTALNOWSIZE))) 0) (* Feed the excess width to any windows that will take it, starting with the  main window) (for ATWINFO in ATWINSINFO do (SETQ EXCESS (IDIFFERENCE EXCESS (IDIFFERENCE (\SETWINFOYSIZE ATWINFO (IPLUS (SETQ NOW (fetch ( RESHAPINGWINDOWDATA ATYSIZE) of ATWINFO)) EXCESS)) NOW))) repeatuntil (EQ EXCESS 0] (for ATWINFO in ATWINSINFO do (* Calculate new position of main  window inside the total region) (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATWINFO) (BOTTOM (add MWYOFF (fetch (RESHAPINGWINDOWDATA ATYSIZE) of ATWINFO))) (LEFT (add MWXOFF (fetch ( RESHAPINGWINDOWDATA ATXSIZE) of ATWINFO))) NIL)) [SHAPEW1 MAINW (CREATEREGION (IPLUS MWXOFF (fetch (REGION LEFT) of NEWREGION)) (IPLUS MWYOFF (fetch (REGION BOTTOM) of NEWREGION)) (fetch (RESHAPINGWINDOWDATA ATXSIZE) of (CAR ATWINSINFO)) (fetch (RESHAPINGWINDOWDATA ATYSIZE) of (CAR ATWINSINFO] (* reshape all of the attached  windows according to the calculated  new sizes.) (\RESHAPEATTACHEDWINDOWSAROUNDMAINW MAINW (\BREAKAPARTATWSTRUCTURE (CDR ATWINSINFO]) (\TOTALPROPOSEDSIZE [LAMBDA (ATWSINFO PWIDTH PHEIGHT) (* rrb " 9-Dec-83 16:12") (* determines the width of the windows that do not change their size.) (COND [ATWSINFO (PROG (THISWID THISHEIGHT THISMINWIDTH THISMINHEIGHT (ATW (CAR ATWSINFO)) (RESTATWS (CDR ATWSINFO))) (SETQ THISMINWIDTH (fetch (RESHAPINGWINDOWDATA ATMINX) of ATW)) (SETQ THISMINHEIGHT (fetch (RESHAPINGWINDOWDATA ATMINY) of ATW)) (SETQ THISWID (fetch (RESHAPINGWINDOWDATA ATXSIZE) of ATW)) (SETQ THISHEIGHT (fetch (RESHAPINGWINDOWDATA ATYSIZE) of ATW)) (RETURN (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATW) ((LEFT RIGHT) (\TOTALPROPOSEDSIZE RESTATWS (IPLUS PWIDTH THISWID) (IMAX PHEIGHT THISMINHEIGHT))) ((TOP BOTTOM) (\TOTALPROPOSEDSIZE RESTATWS (IMAX PWIDTH THISMINWIDTH) (IPLUS PHEIGHT THISHEIGHT))) (PROGN (* this is the main window.) (\TOTALPROPOSEDSIZE RESTATWS THISWID THISHEIGHT] (T (CONS PWIDTH PHEIGHT]) (SHRINKATTACHEDWINDOWS [LAMBDA (WINDOW) (* ; "Edited 5-Mar-87 11:06 by lal") (* ;  "propagates shrinking to attached windows.") (* ;  "doesn't actually shrink, just closes and evaluates the shrink functions.") (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW 'SHRINKW) do (* ;  "Don't shrink the attached windows if they say not to") (if (EQ (DOUSERFNS (WINDOWPROP ATTACHEDWINDOW 'SHRINKFN) ATTACHEDWINDOW T) 'DON'T) then NIL else (\CLOSEW1 ATTACHEDWINDOW]) (TOPATTACHEDWINDOWS [LAMBDA (WINDOW RECURSIVE) (* ; "Edited 17-Aug-88 19:46 by jds") (* ;; "if WINDOW is root, propagate totoping down tree") (COND ([OR RECURSIVE (NULL (WINDOWPROP WINDOW 'MAINWINDOW] (for ATTACHEDWINDOW in (ATTACHEDWINDOWS WINDOW 'TOTOPW) do (* ;; "walk tree, totoping") (TOTOPW ATTACHEDWINDOW T) (TOPATTACHEDWINDOWS ATTACHEDWINDOW T]) (UNMAKEMAINWINDOW [LAMBDA (MAINWINDOW) (* rrb "21-NOV-83 14:37") (* the last attached window has been detached, clear any relevant window  properties.) (WINDOWDELPROP MAINWINDOW 'TOTOPFN (FUNCTION TOPATTACHEDWINDOWS)) (WINDOWDELPROP MAINWINDOW 'CLOSEFN (FUNCTION CLOSEATTACHEDWINDOWS)) (WINDOWDELPROP MAINWINDOW 'OPENFN (FUNCTION OPENATTACHEDWINDOWS)) (WINDOWDELPROP MAINWINDOW 'SHRINKFN (FUNCTION SHRINKATTACHEDWINDOWS)) (WINDOWDELPROP MAINWINDOW 'EXPANDFN (FUNCTION EXPANDATTACHEDWINDOWS)) (WINDOWPROP MAINWINDOW 'CALCULATEREGIONFN NIL) (WINDOWDELPROP MAINWINDOW 'MOVEFN (FUNCTION MOVEATTACHEDWINDOWS)) (WINDOWPROP MAINWINDOW 'DOSHAPEFN NIL]) (UPIQUOTIENT [LAMBDA (N DIVISOR) (* rrb "20-NOV-83 13:41") (* returns the smallest integer such that DIVISOR * that number is greater than  or equal to N.) (IQUOTIENT (IPLUS N (SUB1 DIVISOR)) DIVISOR]) (WINDOWPOSITION [LAMBDA (WINDOW) (* rrb "27-OCT-83 15:41") (PROG [(REG (WINDOWPROP WINDOW 'REGION] (RETURN (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG]) (WINDOWSIZE [LAMBDA (WINDOW) (* rrb " 6-Dec-83 17:45") (* returns the size (WIDTH . HEIGHT) of a window and its attached windows if  any.) (PROG ((EXT (WINDOWREGION WINDOW))) (* this will give the wrong answer if the attached windows have been moved and  have gaps between them.) (RETURN (CONS (fetch (REGION WIDTH) of EXT) (fetch (REGION HEIGHT) of EXT]) (\ALLOCMINIMUMSIZES [LAMBDA (ATWSINFO INTMINWIDTH INTMINHEIGHT NOWWIDTH NOWHEIGHT) (* rrb " 7-Jan-86 14:37") (* allocates to each window in the list of window structures ATWSINFO the  minimum space it should get based on the minimums of all of the other windows  in ATWSINFO) (* returns the minimum size dictated by the first window on ATWSINFO) (COND [ATWSINFO (PROG ((ATW (CAR ATWSINFO)) (THISMINWIDTH INTMINWIDTH) (THISMINHEIGHT INTMINHEIGHT) EXTSIZE EDGE WINDOWPILE RESTATWS FIXEDVAR EXPANSIONWIDTH NEWEXPANDABLEWIDTH NEWWIDTH EXPANSIONHEIGHT NEWEXPANDABLEHEIGHT NEWHEIGHT) (SETQ RESTATWS ATWSINFO) (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATW) ((LEFT RIGHT) (* collect a list of windows that fit on the sides.  This is so that any excess size imposed by windows further out can be allocated  among all of the windows piled together.) (for WININFO in RESTATWS until [NOT (FMEMB (fetch (RESHAPINGWINDOWDATA ATEDGE) of WININFO) '(LEFT RIGHT] do (SETQ THISMINHEIGHT (IMAX THISMINHEIGHT (fetch ( RESHAPINGWINDOWDATA ATMINY) of WININFO))) (* calculate the current size of this  pile of windows.) (SETQ NOWHEIGHT (IMAX NOWHEIGHT (fetch (RESHAPINGWINDOWDATA ATNOWY) of WININFO))) (SETQ NOWWIDTH (IPLUS NOWWIDTH (fetch (RESHAPINGWINDOWDATA ATNOWX) of WININFO))) (SETQ THISMINWIDTH (IPLUS THISMINWIDTH (fetch ( RESHAPINGWINDOWDATA ATMINX) of WININFO))) (SETQ WINDOWPILE (CONS WININFO WINDOWPILE)) (SETQ RESTATWS (CDR RESTATWS))) (* calculate the dimensions imposed by the minimum sizes of windows further out  on the attached window list.) [SETQ NEWWIDTH (CAR (SETQ EXTSIZE (\ALLOCMINIMUMSIZES RESTATWS THISMINWIDTH THISMINHEIGHT NOWWIDTH NOWHEIGHT] (SETQ NEWHEIGHT (CDR EXTSIZE)) (* compute how much of the current width can be expanded.) [SETQ EXPANSIONWIDTH (IDIFFERENCE NOWWIDTH (SETQ FIXEDVAR (\TOTALFIXEDWIDTH WINDOWPILE] (SETQ NEWEXPANDABLEWIDTH (IMAX (DIFFERENCE NEWWIDTH FIXEDVAR) 0)) (* allocate to each window on this level of the pile its share.) (for WININFO in WINDOWPILE do (\SETWINFOXSIZE WININFO (\SHAREOFXTRAX WININFO NEWEXPANDABLEWIDTH EXPANSIONWIDTH)) (\SETWINFOYSIZE WININFO NEWHEIGHT)) (RETURN (CONS (IDIFFERENCE NEWWIDTH (for WININFO in WINDOWPILE sum (* determine how much was actually allocated to the windows in the pile and  give the rest to the initial window.) (fetch ( RESHAPINGWINDOWDATA ATXSIZE) of WININFO))) NEWHEIGHT))) ((TOP BOTTOM) (* collect a list of windows that fit on the sides.  This is so that any excess size imposed by windows further out can be allocated  among all of the windows piled together.) (for WININFO in RESTATWS until [NOT (FMEMB (fetch (RESHAPINGWINDOWDATA ATEDGE) of WININFO) '(TOP BOTTOM] do (SETQ THISMINHEIGHT (IPLUS THISMINHEIGHT (fetch ( RESHAPINGWINDOWDATA ATMINY) of WININFO))) (SETQ NOWHEIGHT (IPLUS NOWHEIGHT (fetch (RESHAPINGWINDOWDATA ATNOWY) of WININFO))) (SETQ NOWWIDTH (IMAX NOWWIDTH (fetch (RESHAPINGWINDOWDATA ATNOWX) of WININFO))) (SETQ THISMINWIDTH (IMAX THISMINWIDTH (fetch ( RESHAPINGWINDOWDATA ATMINX) of WININFO))) (SETQ WINDOWPILE (CONS WININFO WINDOWPILE)) (SETQ RESTATWS (CDR RESTATWS))) (* calculate the dimensions imposed by the minimum sizes of windows further out  on the attached window list.) [SETQ NEWWIDTH (CAR (SETQ EXTSIZE (\ALLOCMINIMUMSIZES RESTATWS THISMINWIDTH THISMINHEIGHT NOWWIDTH NOWHEIGHT] (SETQ NEWHEIGHT (CDR EXTSIZE)) (* compute how much of the current height can be expanded.) [SETQ EXPANSIONHEIGHT (IDIFFERENCE NOWHEIGHT (SETQ FIXEDVAR (\TOTALFIXEDHEIGHT WINDOWPILE] (SETQ NEWEXPANDABLEHEIGHT (IMAX (DIFFERENCE NEWHEIGHT FIXEDVAR) 0)) (* allocate to each window on this level of the pile its share.) (for WININFO in WINDOWPILE do (\SETWINFOXSIZE WININFO NEWWIDTH) (\SETWINFOYSIZE WININFO (\SHAREOFXTRAY WININFO NEWEXPANDABLEHEIGHT EXPANSIONHEIGHT))) [RETURN (CONS NEWWIDTH (IDIFFERENCE NEWHEIGHT (for WININFO in WINDOWPILE sum (* determine how much was actually allocated to the windows in the pile and  give the rest to the initial window.) (fetch (RESHAPINGWINDOWDATA ATYSIZE) of WININFO]) (PROGN (* this is the main window.) (SETQ EXTSIZE (\ALLOCMINIMUMSIZES (CDR ATWSINFO) (fetch (RESHAPINGWINDOWDATA ATMINX) of ATW) (fetch (RESHAPINGWINDOWDATA ATMINY) of ATW) (fetch (RESHAPINGWINDOWDATA ATNOWX) of ATW) (fetch (RESHAPINGWINDOWDATA ATNOWY) of ATW))) (\SETWINFOXSIZE ATW (CAR EXTSIZE)) (\SETWINFOYSIZE ATW (CDR EXTSIZE] (T (CONS INTMINWIDTH INTMINHEIGHT]) (\ALLOCSPACETOGROUPEDWINDOWS [LAMBDA (WGROUPINFO) (* rrb " 9-Dec-83 15:15") (* allocates space to the windows on  EXTBUCKETS.) (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of WGROUPINFO) ((LEFT RIGHT) (* allocate in X) (\ALLOCWIDTHTOGROUPEDWINDOW WGROUPINFO)) (\ALLOCHEIGHTTOGROUPEDWINDOW WGROUPINFO]) (\TOTALFIXEDHEIGHT [LAMBDA (ATWSINFO) (* bvm%: "12-Apr-84 12:30") (* determines the height of the windows that do not change their size.) (bind (MAXEDW _ 0) THISMINHEIGHT for ATW in ATWSINFO when (AND [NOT (AND (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) 'JUSTIFY) (FMEMB (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATW) '(LEFT RIGHT] (EQ (SETQ THISMINHEIGHT (fetch (RESHAPINGWINDOWDATA ATMINY) of ATW)) (fetch (RESHAPINGWINDOWDATA ATMAXY) of ATW))) sum THISMINHEIGHT]) (\TOTALFIXEDWIDTH [LAMBDA (ATWSINFO) (* bvm%: "12-Apr-84 12:30") (* determines the width of the windows that do not change their size.  A window that is JUSTIFIED and is on the TOP or BOTTOM is not counted since it  will be stretched as needed.) (bind (MAXEDW _ 0) THISMINWIDTH for ATW in ATWSINFO when (AND [NOT (AND (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) 'JUSTIFY) (FMEMB (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATW) '(TOP BOTTOM] (EQ (SETQ THISMINWIDTH (fetch (RESHAPINGWINDOWDATA ATMINX) of ATW)) (fetch (RESHAPINGWINDOWDATA ATMAXX) of ATW))) sum THISMINWIDTH]) (\ALLOCHEIGHTTOGROUPEDWINDOW [LAMBDA (WGROUPINFO) (* rrb "15-Dec-83 10:19") (* allocates height to a collection of window all of which are attached to the  top, or bottom edge but at different places on the edge.  EXTBUCKET is a list of those window at the left center and right of the edge.  Also sets the width field in the window information structure.) (PROG ((EXTBUCKET (for WHEREONEDGE in '(LEFT CENTER RIGHT) collect (for ATW in (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of WGROUPINFO) when (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) WHEREONEDGE) collect ATW))) (TOTALNOWSIZE (fetch (RESHAPINGWINDOWDATA ATNOWY) of WGROUPINFO)) [TOTALXTRA (IDIFFERENCE (fetch (RESHAPINGWINDOWDATA ATYSIZE) of WGROUPINFO) (\TOTALFIXEDHEIGHT (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of WGROUPINFO] SHARE HEIGHTS MAXHEIGHT NOWSIZE MAXSIZE NEWSIZE XTRA) [SETQ HEIGHTS (for ATWS in EXTBUCKET collect (for ATW in ATWS sum (* leave the width the same. Possibly this should expand but calculation  depends on width of other windows attached next to this one.) (\SETWINFOXSIZE ATW (fetch ( RESHAPINGWINDOWDATA ATNOWX) of ATW)) (\SETWINFOYSIZE ATW (\SHAREOFXTRAY ATW TOTALXTRA TOTALNOWSIZE] (SETQ MAXHEIGHT (APPLY (FUNCTION MAX) HEIGHTS)) (* keep track of the width as part of the sizing.) (* allocate extra to places which are  not maximum yet.) (for ATWS in EXTBUCKET as HEIGHT in HEIGHTS unless (NULL ATWS) do (COND ((NEQ HEIGHT MAXHEIGHT) (SETQ XTRA (IDIFFERENCE MAXHEIGHT HEIGHT)) (until (OR (NULL ATWS) (EQ 0 XTRA)) do (SETQ SHARE (UPIQUOTIENT XTRA (LENGTH ATWS))) (* UPIQUOTIENT is used to make sure that all of the space is allocated.  Having the shares be greater than the total means that before the share is  given to the window, a check must be made to see that the space in fact exists.  This is done by the IMAX in calculating NEWSIZE.) (* THIS ALGORITHM HAS THE BAD PROPERTY THAT THE FIRST N-1 windows might get one  point too much and cause the last window to be N-2 points smaller than it would  be in the perfect case.) (for ATW in ATWS do (COND ((EQ (SETQ NOWSIZE (fetch (RESHAPINGWINDOWDATA ATYSIZE) of ATW)) (SETQ MAXSIZE (fetch (RESHAPINGWINDOWDATA ATMAXY) of ATW))) (* window has reached max, remove it from getting more space.) (SETQ ATWS (REMOVE ATW ATWS))) ((PROGN (* NEWSIZE needs to be calculated whether MAXSIZE exists or not.) (SETQ NEWSIZE (PLUS (IMAX SHARE XTRA) NOWSIZE)) (AND MAXSIZE (LESSP MAXSIZE NEWSIZE))) (* add only enough to reach maximum.) (SETQ XTRA (IDIFFERENCE XTRA (IDIFFERENCE MAXSIZE NOWSIZE))) (SETQ ATWS (REMOVE ATW ATWS)) (replace (RESHAPINGWINDOWDATA ATYSIZE) of ATW with MAXSIZE)) (T (SETQ XTRA (IDIFFERENCE XTRA (IDIFFERENCE NEWSIZE NOWSIZE))) (replace (RESHAPINGWINDOWDATA ATYSIZE) of ATW with NEWSIZE]) (\ALLOCWIDTHTOGROUPEDWINDOW [LAMBDA (WGROUPINFO) (* rrb "15-Dec-83 10:19") (* allocates width to a collection of window all of which are attached to the  left or right edge but at different places on the edge.  EXTBUCKET is a list of those window at the top, center and bottom of the edge.) (PROG ((EXTBUCKET (for WHEREONEDGE in '(TOP CENTER BOTTOM) collect (for ATW in (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of WGROUPINFO) when (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) WHEREONEDGE) collect ATW))) (TOTALNOWSIZE (fetch (RESHAPINGWINDOWDATA ATNOWX) of WGROUPINFO)) (TOTALXTRA (fetch (RESHAPINGWINDOWDATA ATXSIZE) of WGROUPINFO)) SHARE WIDTHS MAXWIDTH NOWSIZE MAXSIZE NEWSIZE XTRA) [SETQ WIDTHS (for ATWS in EXTBUCKET collect (for ATW in ATWS sum (* leave height the same as it was. Could expand if neighbors weren't too big  but haven't bothered.) (\SETWINFOYSIZE ATW (fetch ( RESHAPINGWINDOWDATA ATNOWY) of ATW)) (\SETWINFOXSIZE ATW (\SHAREOFXTRAX ATW TOTALXTRA TOTALNOWSIZE] (SETQ MAXWIDTH (APPLY (FUNCTION MAX) WIDTHS)) (* keep track of the width as part of the sizing.) (* allocate extra to places which are  not maximum yet.) (for ATWS in EXTBUCKET as WIDTH in WIDTHS unless (NULL ATWS) do (COND ((NEQ WIDTH MAXWIDTH) (SETQ XTRA (IDIFFERENCE MAXWIDTH WIDTH)) (until (OR (NULL ATWS) (EQ 0 XTRA)) do (SETQ SHARE (UPIQUOTIENT XTRA (LENGTH ATWS))) (* UPIQUOTIENT is used to make sure that all of the space is allocated.  Having the shares be greater than the total means that before the share is  given to the window, a check must be made to see that the space in fact exists.  This is done by the IMAX in calculating NEWSIZE.) (* THIS ALGORITHM HAS THE BAD PROPERTY THAT THE FIRST N-1 windows might get one  point too much and cause the last window to be N-2 points smaller than it would  be in the perfect case.) (for ATW in ATWS do (COND ((EQ (SETQ NOWSIZE (fetch (RESHAPINGWINDOWDATA ATXSIZE) of ATW)) (SETQ MAXSIZE (fetch (RESHAPINGWINDOWDATA ATMAXX) of ATW))) (* window has reached max, remove it from getting more space.) (SETQ ATWS (REMOVE ATW ATWS))) ((PROGN (* NEWSIZE needs to be calculated whether MAXSIZE exists or not.) (SETQ NEWSIZE (PLUS (IMAX SHARE XTRA) NOWSIZE)) (AND MAXSIZE (LESSP MAXSIZE NEWSIZE))) (* add only enough to reach maximum.) (SETQ XTRA (IDIFFERENCE XTRA (IDIFFERENCE MAXSIZE NOWSIZE))) (SETQ ATWS (REMOVE ATW ATWS)) (replace (RESHAPINGWINDOWDATA ATXSIZE) of ATW with MAXSIZE)) (T (SETQ XTRA (IDIFFERENCE XTRA (IDIFFERENCE NEWSIZE NOWSIZE))) (replace (RESHAPINGWINDOWDATA ATXSIZE) of ATW with NEWSIZE]) (\ATWGROUPSIZE [LAMBDA (ATWS) (* rrb " 8-Jan-86 11:48") (* returns the size of a group of attached window information structures.) (COND [ATWS (PROG [(EXTREGION (WINDOWREGION (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of (CAR ATWS] (for ATW in (CDR ATWS) do (SETQ EXTREGION (UNIONREGIONS (WINDOWREGION (fetch ( RESHAPINGWINDOWDATA ATTACHEDW) of ATW)) EXTREGION))) (RETURN (CONS (fetch (REGION WIDTH) of EXTREGION) (fetch (REGION HEIGHT) of EXTREGION] (T (CONS 0 0]) (\BREAKAPARTATWSTRUCTURE [LAMBDA (ATWLST) (* rrb "14-Dec-83 12:45") (* breaks apart the window grouping  that are in ATWLST) (for ATW in ATWLST join (COND [(APPEND (LISTP (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of ATW] (T (CONS ATW]) (\BUILDATWSTRUCTURE [LAMBDA (MAINW ATTACHEDWINDOWS) (* bvm%: "29-Dec-83 15:58") (* builds a structure which has place holders for each window or collection of  windows on an edge.) (PROG ((EDGEBUCKETLIST (for SIDE in '(TOP RIGHT BOTTOM LEFT) collect (CONS SIDE NIL))) EDGEBUCKET WHEREAT ATWINFO WHEREONEDGE PLACEHOLDERATW) (RETURN (CONS (LIST MAINW NIL (MINIMUMMAINWINDOWSIZE MAINW) (MAXIMUMMAINWINDOWSIZE MAINW) (CONS 0 0) (CONS [fetch (REGION WIDTH) of (SETQ WHEREAT (WINDOWPROP MAINW 'REGION] (fetch (REGION HEIGHT) of WHEREAT))) (for ATWIN in ATTACHEDWINDOWS join (* collect all of the information about an attached window and leave a place  for its determined size.) (SETQ WHEREAT (WINDOWPROP ATWIN 'WHEREATTACHED)) (SETQ EDGEBUCKET (FASSOC (CAR WHEREAT) EDGEBUCKETLIST)) (SETQ ATWINFO (LIST ATWIN WHEREAT (MINIMUMWINDOWSIZE ATWIN) (MAXIMUMWINDOWSIZE ATWIN) (CONS 0 0) (WINDOWSIZE ATWIN))) [COND ((EQ (SETQ WHEREONEDGE (fetch ATWHEREONEDGE of ATWINFO)) 'JUSTIFY) (* when a window that fits all the way across is encountered, set the fields in  the group information structure and clear it.  Then return the structure for this window.) (COND ((CDR EDGEBUCKET) (* compute the group mins from the windows that don't fit all the way across on  this edge.) (\SETGROUPMIN (CDR EDGEBUCKET)) (RPLACD EDGEBUCKET NIL))) (CONS ATWINFO)) (T (* if this window doesn't fit all the way across, put it in the group that is  being formed for this edge. If there isn't a group yet, form one and return it  so that it will take this place in the structure.) (COND ((CDR EDGEBUCKET) (* group already exists) (NCONC1 (CADR EDGEBUCKET) ATWINFO) NIL) (T (* make a with dummy value in its fields and return it to save its place in the  attached window list.) (SETQ PLACEHOLDERATW (LIST (LIST ATWINFO) WHEREAT (CONS 0 0) (CONS NIL NIL) (CONS 0 0) (CONS 0 0))) (RPLACD EDGEBUCKET PLACEHOLDERATW) (LIST PLACEHOLDERATW] finally (for old EDGEBUCKET in EDGEBUCKETLIST do (* allocate space for those groups that don't have any windows outside them  that fit all the way across.) (COND ((CDR EDGEBUCKET) (* compute the group mins from the windows that don't fit all the way across on  this edge.) (\SETGROUPMIN (CDR EDGEBUCKET)) (RPLACD EDGEBUCKET NIL]) (\LIMITBYMAX [LAMBDA (N MAX) (* limits the size of N to MAX) (COND (MAX (IMIN N MAX)) (T N]) (\LIMITBYMIN [LAMBDA (N MIN) (* bvm%: "10-Nov-84 15:14") (* limits the size of N to MIN) (COND (MIN (IMAX N MIN)) (T N]) (\MAXHEIGHTOFGROUP [LAMBDA (ATWINFOS) (* rrb "14-Dec-83 12:22") (* returns the largest minimum height of a group of windows all of which are on  the same edge. It must look at each position on the edge {left center right}  and sum over the elements that are on that position.) (for WHEREONEDGE in '(LEFT CENTER RIGHT) largest (for ATW in ATWINFOS when (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) WHEREONEDGE) sum (fetch (RESHAPINGWINDOWDATA ATMINY) of ATW)) finally (RETURN $$EXTREME]) (\MAXWIDTHOFGROUP [LAMBDA (ATWINFOS) (* rrb "15-Dec-83 10:21") (* returns the largest minimum width of a group of windows all of which are on  the same edge. It must look at each position on the edge {top center bottom}  and sum over the elements that are on that position.) (for WHEREONEDGE in '(TOP CENTER BOTTOM) largest (for ATW in ATWINFOS when (EQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) WHEREONEDGE) sum (fetch (RESHAPINGWINDOWDATA ATMINX) of ATW)) finally (RETURN $$EXTREME]) (\RESHAPEATTACHEDWINDOWSAROUNDMAINW [LAMBDA (MAINW ATWINSINFO) (* rrb " 3-Oct-84 16:33") (PROG ((MAINWEXTENT (WINDOWPROP MAINW 'REGION)) EXTENT ATWHGHT ATWDTH TL TC TR RT RC RB BR BC BL LB LC LT) [SETQ TL (SETQ TC (SETQ TR (fetch (REGION TOP) of MAINWEXTENT] [SETQ RT (SETQ RC (SETQ RB (fetch (REGION RIGHT) of MAINWEXTENT] [SETQ BR (SETQ BC (SETQ BL (fetch (REGION BOTTOM) of MAINWEXTENT] [SETQ LB (SETQ LC (SETQ LT (fetch (REGION LEFT) of MAINWEXTENT] (bind ATWHERE ATW TEMP for ATWINFO in ATWINSINFO do (* go through the attached windows shaping them and keeping track of their  effect on the position.) [SETQ EXTENT (WINDOWREGION (SETQ ATW (fetch (RESHAPINGWINDOWDATA ATTACHEDW) of ATWINFO] (SETQ ATWHGHT (fetch (REGION HEIGHT) of EXTENT)) (SETQ ATWDTH (fetch (REGION WIDTH) of EXTENT)) (SETQ ATWHERE (SELECTQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATWINFO) (JUSTIFY 'JUSTIFY) (CENTER 0) ((LEFT BOTTOM) -1) 1)) (SHAPEW ATW (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of ATWINFO) (TOP (* use new height) (SETQ ATWHGHT (fetch (RESHAPINGWINDOWDATA ATYSIZE) of ATWINFO)) (SELECTQ ATWHERE (JUSTIFY [PROG1 (CREATEREGION LT (ADD1 (SETQ TEMP (MAX TL TC TR))) (ADD1 (DIFFERENCE RT LT)) ATWHGHT) (SETQ TL (SETQ TC (SETQ TR (PLUS TEMP ATWHGHT]) (-1 (PROG1 (CREATEREGION LT (ADD1 TL) ATWDTH ATWHGHT) (SETQ TL (PLUS TL ATWHGHT)))) (0 (PROG1 (CREATEREGION (CENTERINWIDTH ATWDTH MAINWEXTENT) (ADD1 TC) ATWDTH ATWHGHT) (SETQ TC (PLUS TC ATWHGHT)))) (1 (PROG1 (CREATEREGION (ADD1 (DIFFERENCE RT ATWDTH)) (ADD1 TR) ATWDTH ATWHGHT) (SETQ TR (PLUS TR ATWHGHT)))) (SHOULDNT))) (RIGHT (SETQ ATWDTH (fetch (RESHAPINGWINDOWDATA ATXSIZE) of ATWINFO)) (SELECTQ ATWHERE (JUSTIFY [PROG1 (CREATEREGION (ADD1 (SETQ TEMP (MAX RT RC RB))) BR ATWDTH (ADD1 (DIFFERENCE TR BR)) ) (SETQ RT (SETQ RC (SETQ RB (PLUS TEMP ATWDTH]) (1 (PROG1 (CREATEREGION (ADD1 RT) (ADD1 (DIFFERENCE TR ATWHGHT)) ATWDTH ATWHGHT) (SETQ RT (PLUS RT ATWDTH)))) (0 (PROG1 (CREATEREGION (ADD1 RC) (CENTERINHEIGHT ATWHGHT MAINWEXTENT) ATWDTH ATWHGHT) (SETQ RC (PLUS RC ATWDTH)))) (-1 (PROG1 (CREATEREGION (ADD1 RB) BR ATWDTH ATWHGHT) (SETQ RB (PLUS RB ATWDTH)))) (SHOULDNT))) (LEFT (SETQ ATWDTH (fetch (RESHAPINGWINDOWDATA ATXSIZE) of ATWINFO)) (SELECTQ ATWHERE (JUSTIFY (CREATEREGION [SETQ LT (SETQ LC (SETQ LB (DIFFERENCE (MIN LT LC LB) ATWDTH] BL ATWDTH (ADD1 (DIFFERENCE TL BL)))) (1 (CREATEREGION (SETQ LT (DIFFERENCE LT ATWDTH)) (ADD1 (DIFFERENCE TL ATWHGHT)) ATWDTH ATWHGHT)) (0 (CREATEREGION (SETQ LC (DIFFERENCE LC ATWDTH)) (CENTERINHEIGHT ATWHGHT MAINWEXTENT) ATWDTH ATWHGHT)) (-1 (CREATEREGION (SETQ LB (DIFFERENCE LB ATWDTH)) BL ATWDTH ATWHGHT)) (SHOULDNT))) (BOTTOM (SETQ ATWHGHT (fetch (RESHAPINGWINDOWDATA ATYSIZE) of ATWINFO)) (SELECTQ ATWHERE (JUSTIFY (CREATEREGION LB [SETQ BL (SETQ BC (SETQ BR (DIFFERENCE (MIN BL BC BR) ATWHGHT] (ADD1 (DIFFERENCE RB LB)) ATWHGHT)) (-1 (CREATEREGION LB (SETQ BL (DIFFERENCE BL ATWHGHT)) ATWDTH ATWHGHT)) (0 (CREATEREGION (CENTERINWIDTH ATWDTH MAINWEXTENT) (SETQ BC (DIFFERENCE BC ATWHGHT)) ATWDTH ATWHGHT)) (1 (CREATEREGION (ADD1 (DIFFERENCE RB ATWDTH)) (SETQ BR (DIFFERENCE BR ATWHGHT)) ATWDTH ATWHGHT)) (SHOULDNT))) (SHOULDNT]) (\SETGROUPMIN [LAMBDA (GROUPATWINFO) (* rrb "14-Dec-83 12:23") (* sets the minimum of a group of  attached windows.) (* the CAR is the list of information structures of the members of the group.) (* set the size of the whole group so that the proportional calculation can go  through.) (* also sets the maximum in the dimension in which the group can expand if  everyone in the group has a limit. This information is used to determine  allocation shares in the case where the group has its maximum size, no more  space will be given to it.) (PROG [(GROUPSIZE (\ATWGROUPSIZE (CAR GROUPATWINFO] (replace (RESHAPINGWINDOWDATA ATNOWX) of GROUPATWINFO with (CAR GROUPSIZE)) (replace (RESHAPINGWINDOWDATA ATNOWY) of GROUPATWINFO with (CDR GROUPSIZE))) (SELECTQ (fetch (RESHAPINGWINDOWDATA ATEDGE) of GROUPATWINFO) ((LEFT RIGHT) (replace (RESHAPINGWINDOWDATA ATMINX) of GROUPATWINFO with (\MAXWIDTHOFGROUP (CAR GROUPATWINFO))) (replace (RESHAPINGWINDOWDATA ATMINY) of GROUPATWINFO with (for ATW in (CAR GROUPATWINFO) largest (fetch (RESHAPINGWINDOWDATA ATMINY) of ATW) finally (RETURN $$EXTREME))) [replace (RESHAPINGWINDOWDATA ATMAXX) of GROUPATWINFO with (PROG ((TMAX 0) (CMAX 0) (BMAX 0) THISMAX) (RETURN (for ATW in (CAR GROUPATWINFO) do [COND ((NULL (SETQ THISMAX (fetch (RESHAPINGWINDOWDATA ATMAXX) of ATW))) (* if any of the windows in the group doesn't have a max, the group doesn't  either.) (RETURN NIL)) (T (SELECTQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) (TOP (SETQ TMAX (IPLUS TMAX THISMAX))) (CENTER (SETQ CMAX (IPLUS CMAX THISMAX))) (SETQ BMAX (IPLUS BMAX THISMAX] finally (RETURN (IMAX TMAX CMAX BMAX]) ((TOP BOTTOM) (replace (RESHAPINGWINDOWDATA ATMINX) of GROUPATWINFO with (for ATW in (CAR GROUPATWINFO) largest (fetch (RESHAPINGWINDOWDATA ATMINX) of ATW) finally (RETURN $$EXTREME))) (replace (RESHAPINGWINDOWDATA ATMINY) of GROUPATWINFO with (\MAXHEIGHTOFGROUP (CAR GROUPATWINFO))) [replace (RESHAPINGWINDOWDATA ATMAXY) of GROUPATWINFO with (PROG ((LMAX 0) (CMAX 0) (RMAX 0) THISMAX) (RETURN (for ATW in (CAR GROUPATWINFO) do [COND ((NULL (SETQ THISMAX (fetch (RESHAPINGWINDOWDATA ATMAXY) of ATW))) (* if any of the windows in the group doesn't have a max, the group doesn't  either.) (RETURN NIL)) (T (SELECTQ (fetch (RESHAPINGWINDOWDATA ATWHEREONEDGE) of ATW) (LEFT (SETQ LMAX (IPLUS LMAX THISMAX))) (CENTER (SETQ CMAX (IPLUS CMAX THISMAX))) (SETQ RMAX (IPLUS RMAX THISMAX] finally (RETURN (IMAX LMAX CMAX RMAX]) (SHOULDNT]) (\SETWINFOXSIZE [LAMBDA (WINFO PROPOSEDSIZE) (* bvm%: "10-Nov-84 15:14") (* sets the X size of a window information structure, limiting by the maximum  and returns the value put in.) (replace (RESHAPINGWINDOWDATA ATXSIZE) of WINFO with (\LIMITBYMIN (\LIMITBYMAX PROPOSEDSIZE (fetch (RESHAPINGWINDOWDATA ATMAXX) of WINFO)) (fetch (RESHAPINGWINDOWDATA ATMINX) of WINFO]) (\SETWINFOYSIZE [LAMBDA (WINFO PROPOSEDSIZE) (* bvm%: "10-Nov-84 15:17") (* sets the Y size of a window information structure, limiting by the maximum  and returns the value put in.) (* bvm%: Used to say (IMAX this 0)%, but that is asymmetric with \SETWINFOXSIZE  and the \LIMITBYMIN should catch it anyway) (replace (RESHAPINGWINDOWDATA ATYSIZE) of WINFO with (\LIMITBYMIN (\LIMITBYMAX PROPOSEDSIZE (fetch (RESHAPINGWINDOWDATA ATMAXY) of WINFO)) (fetch (RESHAPINGWINDOWDATA ATMINY) of WINFO]) (\SHAREOFXTRAX [LAMBDA (WINFO TOTALNEWSIZE TOTALOLDSIZE) (* bvm%: "10-Nov-84 15:14") (* returns the proportion of space in X that a window should get base on its  size before the reshape.) (IMAX (IQUOTIENT (ITIMES (fetch (RESHAPINGWINDOWDATA ATNOWX) of WINFO) TOTALNEWSIZE) TOTALOLDSIZE) (fetch (RESHAPINGWINDOWDATA ATXSIZE) of WINFO]) (\SHAREOFXTRAY [LAMBDA (WINFO TOTALNEWSIZE TOTALOLDSIZE) (* rrb " 7-Jan-86 17:04") (* returns the proportion of space in Y that a window should get based on its  size before the reshape.) (COND ((EQ TOTALOLDSIZE 0) 0) (T (IMAX (IQUOTIENT (ITIMES (fetch (RESHAPINGWINDOWDATA ATNOWY) of WINFO) TOTALNEWSIZE) TOTALOLDSIZE) (fetch (RESHAPINGWINDOWDATA ATYSIZE) of WINFO]) ) (DEFINEQ (ATTACHMENU [LAMBDA (MENU MAINWINDOW EDGE POSITIONONEDGE NOOPENFLG) (* rrb "27-Jun-84 11:19") (* this function associates a menu  with a window.) (PROG (MENUWINDOW) (* VERTFLG is non-NIL if the menu is to be layed out above or below the main  window.) [SETQ MENUWINDOW (MENUWINDOW MENU (FMEMB EDGE '(LEFT RIGHT] (ATTACHWINDOW MENUWINDOW MAINWINDOW EDGE POSITIONONEDGE T) (OR NOOPENFLG (NOT (OPENWP MAINWINDOW)) (OPENW MENUWINDOW)) (RETURN MENUWINDOW]) (CREATEMENUEDWINDOW [LAMBDA (MENU WINDOWTITLE LOCATION WINDOWSPEC) (* bvm%: "12-Apr-84 16:59") (* This function is used to create a MAIN window MENU pair.  MENU specifies the menu content and may be a menu, a list of items.  WINDOWTITLE is a string specifying a title for the main window.  LOCATION specifies the placement of the window  (TOP BOTTOM LEFT RIGHT); WINDOWSPEC is a REGION.  If it is NIL, a new window will be created.) (PROG ((VERTFLG (COND ((NULL LOCATION) (* Default LOCATION is TOP) (SETQ LOCATION 'TOP) NIL) ((FMEMB LOCATION '(LEFT RIGHT)) T))) WINDOW MENUW MENUWIDTH MENUHEIGHT WHOLEREGION MINTOTALHEIGHT MINTOTALWIDTH) (COND [(LISTP MENU) (SETQ MENU (create MENU ITEMS _ MENU CENTERFLG _ T TITLE _ (COND ((AND WINDOWTITLE VERTFLG) (* If the menu is on the side continue the title bar even if the menu has no  title) " "] ((type? MENU MENU)) (T (\ILLEGAL.ARG MENU))) [COND ((NULL (fetch MENUROWS of MENU)) (replace MENUROWS of MENU with (COND (VERTFLG (LENGTH (fetch (MENU ITEMS) of MENU))) (T 1] (SETQ MENUW (MENUWINDOW MENU VERTFLG)) (SETQ MINTOTALWIDTH (SETQ MENUWIDTH (fetch (MENU IMAGEWIDTH) of MENU))) (SETQ MINTOTALHEIGHT (SETQ MENUHEIGHT (fetch (MENU IMAGEHEIGHT) of MENU))) (SELECTQ LOCATION ((TOP BOTTOM) (add MINTOTALHEIGHT (FONTPROP (DEFAULTFONT 'DISPLAY) 'HEIGHT) (COND (WINDOWTITLE (FONTPROP WindowTitleDisplayStream 'HEIGHT)) (T 0)))) ((LEFT RIGHT) (add MINTOTALWIDTH (TIMES 2 WBorder))) NIL) (* The window may be specified by the user.  A region or an existing window may be supplied by the caller.  In any case the size may have to be adjusted so that titles and and menu fit) [SETQ WHOLEREGION (COND ((NULL WINDOWSPEC) (PROMPTPRINT "Specify a region for " (OR WINDOWTITLE "the window")) (PROG1 (GETREGION MINTOTALWIDTH MINTOTALHEIGHT) (CLRPROMPT))) [(REGIONP WINDOWSPEC) (create REGION using WINDOWSPEC WIDTH _ (IMAX MINTOTALWIDTH (fetch (REGION WIDTH) of WINDOWSPEC)) HEIGHT _ (IMAX MINTOTALHEIGHT (fetch (REGION HEIGHT) of WINDOWSPEC] (T (\ILLEGAL.ARG WINDOWSPEC] (* Now set up the menu) (SELECTQ LOCATION ((TOP BOTTOM) (* Shrink height of region by menu-occupied space to get main window region) (COND ((EQ LOCATION 'BOTTOM) (add (fetch (REGION BOTTOM) of WHOLEREGION) MENUHEIGHT))) (replace (REGION HEIGHT) of WHOLEREGION with (IDIFFERENCE (fetch (REGION HEIGHT) of WHOLEREGION) MENUHEIGHT))) ((LEFT RIGHT) (COND ((EQ LOCATION 'LEFT) (add (fetch (REGION LEFT) of WHOLEREGION) MENUWIDTH))) (replace (REGION WIDTH) of WHOLEREGION with (IDIFFERENCE (fetch (REGION WIDTH) of WHOLEREGION) MENUWIDTH))) NIL) [ATTACHWINDOW MENUW (SETQ WINDOW (CREATEW WHOLEREGION WINDOWTITLE)) LOCATION (COND (VERTFLG 'TOP) (T 'JUSTIFY] (OPENW WINDOW) (OPENW MENUW) (RETURN WINDOW]) (MENUWINDOW [LAMBDA (MENU VERTFLG) (* rrb "27-Jun-84 10:37") (* this function creates a window that has menu in it.  The window has appropriate reshape, minsize and maxsize functions.) (PROG (WINDOW) [COND ((LISTP MENU) (* assume its an item list) (SETQ MENU (create MENU ITEMS _ MENU CENTERFLG _ T] (COND [(type? MENU MENU) (* check to make sure the number of rows and columns are set up.) (COND ((fetch MENUROWS of MENU)) ((fetch MENUCOLUMNS of MENU)) (VERTFLG (replace (MENU MENUCOLUMNS) of MENU with 1)) (T (replace (MENU MENUROWS) of MENU with 1] (T (ERROR "arg not MENU" MENU))) (* update the menu image in case any of its fields were changed above.) (COND ((NOT (NUMBERP (fetch (MENU MENUOUTLINESIZE) of MENU))) (replace (MENU MENUOUTLINESIZE) of MENU with 0))) (UPDATE/MENU/IMAGE MENU) (* Now build the menu window) (SETQ WINDOW (ADDMENU MENU (CREATEW (CREATEREGION 0 0 (WIDTHIFWINDOW (fetch (MENU IMAGEWIDTH ) of MENU) 1) (HEIGHTIFWINDOW (fetch (MENU IMAGEHEIGHT) of MENU) NIL 1)) NIL 1 T) NIL T)) (WINDOWPROP WINDOW 'MINSIZE (FUNCTION MENUWMINSIZEFN)) (WINDOWPROP WINDOW 'MAXSIZE (FUNCTION MENUWMINSIZEFN)) (WINDOWADDPROP WINDOW 'RESHAPEFN (FUNCTION MENUWRESHAPEFN)) (RETURN WINDOW]) (MENUWMINSIZEFN [LAMBDA (MENUW) (* ; "Edited 14-Jan-99 17:16 by rmk:") (* ;; "returns the minimum size of a menu window.") (PROG ([MENU (CAR (WINDOWPROP MENUW 'MENU] (TITLE? (WINDOWPROP MENUW 'TITLE)) TITLERELATEDVAR BORDERSIZE OUTLINESIZE MINWIDTH) (SETQ BORDERSIZE (ITIMES (fetch (MENU MENUBORDERSIZE) of MENU) 2)) (SETQ OUTLINESIZE (ITIMES (IPLUS (fetch (MENU MENUOUTLINESIZE) of MENU) (WINDOWPROP MENUW 'BORDER)) 2)) (SETQ MINWIDTH (ITIMES (IPLUS (MAXMENUITEMWIDTH MENU) BORDERSIZE 2) (fetch (MENU MENUCOLUMNS) of MENU))) (* ;  "The minimum width of the window takes into account the contents of the menu and its title") [COND ((SETQ TITLERELATEDVAR (fetch (MENU TITLE) of MENU)) (SETQ MINWIDTH (IMAX MINWIDTH (STRINGWIDTH TITLERELATEDVAR (SETQ TITLERELATEDVAR (MENUTITLEFONT MENU] (RETURN (CONS (WIDTHIFWINDOW MINWIDTH (WINDOWPROP MENUW 'BORDER)) (HEIGHTIFWINDOW (IPLUS (ITIMES (fetch (MENU MENUROWS) of MENU) (IPLUS BORDERSIZE (MAXMENUITEMHEIGHT MENU))) (COND (TITLERELATEDVAR (FONTPROP TITLERELATEDVAR 'HEIGHT)) (T 0))) TITLE? (WINDOWPROP MENUW 'BORDER]) (MENUWRESHAPEFN [LAMBDA (WINDOW OLDIMAGE OLDREGION) (* hdj " 6-Feb-85 15:50") (* This function takes care of size adjustments whenever the main window is  reshaped.) (PROG ([MENU (CAR (WINDOWPROP WINDOW 'MENU] INTREGION USABLEWIDTH USABLEHEIGHT NROWS NCOLUMNS XTRWIDTH XTRHEIGHT BORDER) (OR MENU (RETURN)) (DELETEMENU MENU NIL WINDOW) (SETQ BORDER (ITIMES 2 (fetch (MENU MENUOUTLINESIZE) of MENU))) (SETQ USABLEWIDTH (IDIFFERENCE (fetch (REGION WIDTH) of (SETQ INTREGION (DSPCLIPPINGREGION NIL WINDOW))) BORDER)) [SETQ USABLEHEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of INTREGION) (COND ((fetch (MENU TITLE) of MENU) (IPLUS (FONTPROP (MENUTITLEFONT MENU) 'HEIGHT) BORDER)) (T BORDER] (* calculate the largest item size that fits and the amount left over.) (SETQ XTRWIDTH (IDIFFERENCE USABLEWIDTH (ITIMES [replace ITEMWIDTH of MENU with (IQUOTIENT USABLEWIDTH (SETQ NCOLUMNS (fetch MENUCOLUMNS of MENU] NCOLUMNS))) (SETQ XTRHEIGHT (IDIFFERENCE USABLEHEIGHT (ITIMES [replace ITEMHEIGHT of MENU with (IQUOTIENT USABLEHEIGHT (SETQ NROWS (fetch MENUROWS of MENU] NROWS))) (UPDATE/MENU/IMAGE MENU) (* black out the window so the extra part of the window will not stand out.) (DSPFILL NIL BLACKSHADE 'REPLACE WINDOW) (* put the menu image centered in the  window) (ADDMENU MENU WINDOW (create POSITION XCOORD _ (IQUOTIENT XTRWIDTH 2) YCOORD _ (IQUOTIENT XTRHEIGHT 2))) (SHOWSHADEDITEMS MENU WINDOW) (RETURN WINDOW]) ) (DEFINEQ (GETPROMPTWINDOW (LAMBDA (MAINWINDOW %#LINES FONT DONTCREATE) (* ; "Edited 22-Jan-88 15:20 by woz") (* ;; "makes sure that MAINWINDOW has an attached promptwindow and returns it. If one already exists, it is shaped to be at least #LINES high. If FONT is NIL, the font of the main window is used for the promptwindow.") (PROG ((PWINDOWPROP (WINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW))) PWINDOW HEIGHT PAGEFULLFN) (COND (DONTCREATE (RETURN (CAR PWINDOWPROP)))) (SETQ FONT (COND (FONT (FONTCREATE FONT)) (T (DSPFONT NIL (OR (CAR PWINDOWPROP) MAINWINDOW))))) (COND (%#LINES (COND ((EQ %#LINES T) (* ; "Infinitely expandable window") (SETQ PAGEFULLFN (FUNCTION \PROMPTWINDOW.PAGEFULLFN)) (SETQ %#LINES 1)) ((STRINGP %#LINES) (* ; "Big enough for this string") (LET ((MAINWIDTH (fetch (REGION WIDTH) of (OR (CAR PWINDOWPROP) (WINDOWREGION MAINWINDOW)))) (STRWIDTH (STRINGWIDTH %#LINES FONT))) (SETQ %#LINES (IQUOTIENT (IPLUS STRWIDTH (SUB1 MAINWIDTH)) MAINWIDTH)))) ((FIXP %#LINES)) (T (\ILLEGAL.ARG %#LINES)))) (T (SETQ %#LINES 1))) (COND (PWINDOWPROP (SETQ PWINDOW (CAR PWINDOWPROP)) (COND ((NOT (OPENWP PWINDOW)) (REATTACHPROMPTWINDOW MAINWINDOW PWINDOW))) (COND ((IGREATERP %#LINES (CDR PWINDOWPROP)) (* ; "Window exists, but not big enough") (\PROMPTWINDOW.EXPAND PWINDOWPROP %#LINES)))) (T (SETQ PWINDOW (CREATEW (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch (REGION WIDTH) of (WINDOWREGION MAINWINDOW)) HEIGHT _ (SETQ HEIGHT (HEIGHTIFWINDOW (TIMES %#LINES (FONTPROP FONT (QUOTE HEIGHT)))))) NIL NIL T)) (DSPSCROLL T PWINDOW) (DSPFONT FONT PWINDOW) (WINDOWPROP PWINDOW (QUOTE PAGEFULLFN) (QUOTE NILL)) (REATTACHPROMPTWINDOW MAINWINDOW PWINDOW) (WINDOWPROP MAINWINDOW (QUOTE PROMPTWINDOW) (CONS PWINDOW %#LINES)) (WINDOWPROP PWINDOW (QUOTE OPENFN) (FUNCTION \PROMPTWINDOW.OPENFN)) (WINDOWPROP PWINDOW (QUOTE PASSTOMAINCOMS) (QUOTE (CLOSEW BURYW REDISPLAYW MOVEW SHAPEW SHRINKW HARDCOPYIMAGEW))) (\PROMPTWINDOW.SET.HEIGHT PWINDOW HEIGHT) (OPENW PWINDOW))) (AND PAGEFULLFN (WINDOWPROP PWINDOW (QUOTE PAGEFULLFN) PAGEFULLFN)) (RETURN PWINDOW))) ) (\PROMPTWINDOW.EXPAND [LAMBDA (PWINDOWPROP %#LINES) (* bvm%: " 2-May-86 14:59") (* * Expand the PWINDOWPROP = (window . nlines) to be %#LINES high) (LET* [(PWINDOW (CAR PWINDOWPROP)) (HEIGHT (HEIGHTIFWINDOW (TIMES %#LINES (FONTPROP PWINDOW 'HEIGHT] (SHAPEW PWINDOW (create REGION using (WINDOWPROP PWINDOW 'REGION) HEIGHT _ HEIGHT)) (RPLACD PWINDOWPROP %#LINES) (\PROMPTWINDOW.SET.HEIGHT PWINDOW HEIGHT]) (\PROMPTWINDOW.SET.HEIGHT [LAMBDA (PWINDOW HEIGHT) (* bvm%: " 2-May-86 14:57") (* * Sets prompt window's height to be HEIGHT --  makes window inflexible and coerces it onto screen if it is off) (LET [(OBSCUREDHEIGHT (IDIFFERENCE SCREENHEIGHT (fetch (REGION TOP) of (WINDOWPROP PWINDOW 'REGION] [COND ((ILESSP OBSCUREDHEIGHT 0) (* Promptwindow off screen at top, so slip window group down to make it visible) (RELMOVEW (MAINWINDOW PWINDOW) (create POSITION XCOORD _ 0 YCOORD _ OBSCUREDHEIGHT] (WINDOWPROP PWINDOW 'MINSIZE (CONS 0 HEIGHT)) (WINDOWPROP PWINDOW 'MAXSIZE (CONS 64000 HEIGHT]) (\PROMPTWINDOW.OPENFN [LAMBDA (WINDOW) (* bvm%: "11-Nov-84 15:52") (* * Called when WINDOW is opened. WINDOW had been closed, and hence detached,  from its main window, but perhaps somebody still had a handle on it and is now  printing to it. Look for an open window whose promptwindow is this window.) (OR (WINDOWPROP WINDOW 'MAINWINDOW) (for MAINW in (OPENWINDOWS) bind PWINDOWPROP when (AND (SETQ PWINDOWPROP (WINDOWPROP MAINW 'PROMPTWINDOW)) (EQ (CAR PWINDOWPROP) WINDOW)) do (RETURN (REATTACHPROMPTWINDOW MAINW WINDOW]) (\PROMPTWINDOW.PAGEFULLFN [LAMBDA (WINDOW) (* bvm%: " 2-May-86 14:59") (* * Called to automatically expand a prompt window) (LET* ((PWINDOWPROP (WINDOWPROP (MAINWINDOW WINDOW) 'PROMPTWINDOW)) (%#LINES (CDR PWINDOWPROP))) (AND %#LINES (\PROMPTWINDOW.EXPAND PWINDOWPROP (ADD1 %#LINES]) (REATTACHPROMPTWINDOW [LAMBDA (MAINWINDOW PWINDOW) (* ; "Edited 5-Sep-91 19:25 by jds") (* ;;  "Reattach a prompt window th the main window; -preserve PASSTOMAINCOMS rather than nuking them.") (LET [(OLDPASSTOMAINCOMS (WINDOWPROP PWINDOW 'PASSTOMAINCOMS] (ATTACHWINDOW PWINDOW MAINWINDOW 'TOP 'JUSTIFY) (WINDOWPROP PWINDOW 'PASSTOMAINCOMS OLDPASSTOMAINCOMS]) (REMOVEPROMPTWINDOW [LAMBDA (MAINWINDOW) (* rrb "23-Oct-85 13:56") (PROG (PWINDOW) LP [COND ((SETQ PWINDOW (WINDOWPROP MAINWINDOW 'PROMPTWINDOW NIL)) (WINDOWDELPROP (SETQ PWINDOW (CAR PWINDOW)) 'OPENFN (FUNCTION \PROMPTWINDOW.OPENFN)) (DETACHWINDOW PWINDOW) (RETURN (CLOSEW PWINDOW] (COND ((NEQ MAINWINDOW (SETQ MAINWINDOW (MAINWINDOW MAINWINDOW))) (GO LP]) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (DECLARE%: EVAL@COMPILE (RECORD RESHAPINGWINDOWDATA (ATTACHEDW (ATEDGE . ATWHEREONEDGE) (ATMINX . ATMINY) (ATMAXX . ATMAXY) (ATXSIZE . ATYSIZE) (ATNOWX . ATNOWY))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS WindowMenu WindowTitleDisplayStream WBorder WindowMenuCommands) ) ) (DEFGLOBALVAR *ATTACHED-WINDOW-COMMAND-SYNONYMS* (LIST (CONS '\INTERACTIVE.CLOSEW 'CLOSEW) (CONS 'HARDCOPYIMAGEW.TOPRINTER 'HARDCOPYIMAGEW) (CONS 'HARDCOPYIMAGEW.TOFILE 'HARDCOPYIMAGEW)) "used by attachwindows to associate window command substitutes with their original name, eg \interactive.closew with closew. Must be maintained as an alist, with each entry of the form (new-com . old-com)." ) (PUTPROPS ATTACHEDWINDOW COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 1992 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2273 10646 (ATTACHWINDOW 2283 . 4854) (ATTACHEDWINDOWS 4856 . 5792) (ALLATTACHEDWINDOWS 5794 . 6219) (DETACHWINDOW 6221 . 7121) (DETACHALLWINDOWS 7123 . 7440) (FREEATTACHEDWINDOW 7442 . 9079) (MAINWINDOW 9081 . 9761) (REMOVEWINDOW 9763 . 10065) (REPOSITIONATTACHEDWINDOWS 10067 . 10644)) (10647 104021 (ATTACHEDWINDOWREGION 10657 . 11325) (ATTACHEDWINDOWTOTOPFN 11327 . 11804) ( CENTERINHEIGHT 11806 . 12276) (CENTERINWIDTH 12278 . 12728) (CENTRALWINDOW 12730 . 13160) ( CLOSEATTACHEDWINDOWS 13162 . 13738) (DOATTACHEDWINDOWCOM 13740 . 15811) (DOATTACHEDWINDOWCOM2 15813 . 16101) (DOMAINWINDOWCOMFN 16103 . 16657) (EXPANDATTACHEDWINDOWS 16659 . 17725) (MAKEMAINWINDOW 17727 . 19442) (MAXATTACHEDWINDOWEXTENT 19444 . 24053) (MAXIMUMMAINWINDOWSIZE 24055 . 24740) ( MAXIMUMWINDOWSIZE 24742 . 25491) (MINATTACHEDWINDOWEXTENT 25493 . 29820) (MINIMUMMAINWINDOWSIZE 29822 . 30608) (MOVEATTACHEDWINDOWS 30610 . 31262) (MOVEATTACHEDWINDOWTOPLACE 31264 . 40365) ( OPENATTACHEDWINDOWS 40367 . 41320) (RESHAPEALLWINDOWS 41322 . 51053) (\TOTALPROPOSEDSIZE 51055 . 52568 ) (SHRINKATTACHEDWINDOWS 52570 . 53529) (TOPATTACHEDWINDOWS 53531 . 54044) (UNMAKEMAINWINDOW 54046 . 54818) (UPIQUOTIENT 54820 . 55129) (WINDOWPOSITION 55131 . 55473) (WINDOWSIZE 55475 . 56020) ( \ALLOCMINIMUMSIZES 56022 . 66540) (\ALLOCSPACETOGROUPEDWINDOWS 66542 . 67117) (\TOTALFIXEDHEIGHT 67119 . 67877) (\TOTALFIXEDWIDTH 67879 . 68769) (\ALLOCHEIGHTTOGROUPEDWINDOW 68771 . 74324) ( \ALLOCWIDTHTOGROUPEDWINDOW 74326 . 79621) (\ATWGROUPSIZE 79623 . 80738) (\BREAKAPARTATWSTRUCTURE 80740 . 81244) (\BUILDATWSTRUCTURE 81246 . 85867) (\LIMITBYMAX 85869 . 86032) (\LIMITBYMIN 86034 . 86294) ( \MAXHEIGHTOFGROUP 86296 . 87340) (\MAXWIDTHOFGROUP 87342 . 88384) (\RESHAPEATTACHEDWINDOWSAROUNDMAINW 88386 . 96384) (\SETGROUPMIN 96386 . 101125) (\SETWINFOXSIZE 101127 . 101971) (\SETWINFOYSIZE 101973 . 102981) (\SHAREOFXTRAX 102983 . 103464) (\SHAREOFXTRAY 103466 . 104019)) (104022 117243 (ATTACHMENU 104032 . 104740) (CREATEMENUEDWINDOW 104742 . 109899) (MENUWINDOW 109901 . 112303) (MENUWMINSIZEFN 112305 . 114268) (MENUWRESHAPEFN 114270 . 117241)) (117244 123236 (GETPROMPTWINDOW 117254 . 119306) ( \PROMPTWINDOW.EXPAND 119308 . 119885) (\PROMPTWINDOW.SET.HEIGHT 119887 . 120815) (\PROMPTWINDOW.OPENFN 120817 . 121792) (\PROMPTWINDOW.PAGEFULLFN 121794 . 122223) (REATTACHPROMPTWINDOW 122225 . 122666) ( REMOVEPROMPTWINDOW 122668 . 123234))))) STOP \ No newline at end of file diff --git a/sources/AUTHENTICATION b/sources/AUTHENTICATION new file mode 100644 index 00000000..dc95cd79 --- /dev/null +++ b/sources/AUTHENTICATION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 12:10:46" {DSK}local>lde>lispcore>sources>AUTHENTICATION.;2 26536 changes to%: (VARS AUTHENTICATIONCOMS) previous date%: " 6-Jun-89 11:14:40" {DSK}local>lde>lispcore>sources>AUTHENTICATION.;1) (* ; " Copyright (c) 1987, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT AUTHENTICATIONCOMS) (RPAQQ AUTHENTICATIONCOMS ((COMS (* ; "Authentication Protocol") (COURIERPROGRAMS AUTHENTICATION CHACCESSCONTROL)) (COMS (* ;  "Strong authentication and changing passwords") (FNS AS.CHANGE.OWN.PASSWORDS AS.REPLACE.PASSWORDS AS.CREATE.PASSWORDS AS.DELETE.PASSWORDS \AUTHENTICATION.FIND.SERVER AS.MAKE.CONVERSATION AS.NEXT.VERIFIER) (ADDVARS (\SYSTEMCACHEVARS \AUTHENTICATION.SERVER.CACHE)) (VARS AS.WELL.KNOWN.NAME) (INITVARS (AUTHENTICATION.NET.HINT) (\AUTHENTICATION.SERVER.CACHE)) (DECLARE%: DONTCOPY (CONSTANTS (\AUTHENTICATION.SIMPLE.CREDENTIALS 0) (\AUTHENTICATION.SOCKET 21)) (GLOBALVARS AUTHENTICATION.NET.HINT \AUTHENTICATION.SERVER.CACHE AS.WELL.KNOWN.NAME))) (COMS (* ; "Weak authentication") (FNS NSLOGIN NS.AUTHENTICATE NS.MAKE.SIMPLE.CREDENTIALS HASH.PASSWORD)) (COMS (* ; "Clearinghouse access control") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) CLEARINGHOUSE)) (FNS CH.RETRIEVE.DOMAIN.ACL CH.ADD.MEMBER.TO.DOMAIN.ACL CH.DELETE.MEMBER.FROM.DOMAIN.ACL CH.IS.IN.DOMAIN.ACL CH.RETRIEVE.PROPERTY.ACL CH.ADD.MEMBER.TO.PROPERTY.ACL CH.DELETE.MEMBER.FROM.PROPERTY.ACL CH.NUMBER.TO.PROPERTY)) (COMS (* ;; "These belong on CLEARINGHOUSE but are here temporarily for benefit of Lyric users wanting a functional NSMAINTAIN. Put these back when a %"Lyric%" version of this file has been stashed.") (FNS CH.LIST.PROPERTIES CH.LIST.ORGANIZATIONS CH.LIST.OBJECTS) (FNS CH.ADD.GROUP.PROPERTY CH.ADD.MEMBER CH.DELETE.MEMBER)))) (* ; "Authentication Protocol") (COURIERPROGRAM AUTHENTICATION (14 2) TYPES [(KEY (ARRAY 4 UNSPECIFIED)) (BLOCK (ARRAY 4 UNSPECIFIED)) (CREDENTIALS.TYPE (ENUMERATION (SIMPLE 0) (STRONG 1))) [CREDENTIALS (RECORD (TYPE CREDENTIALS.TYPE) (VALUE (SEQUENCE UNSPECIFIED] (CREDENTIALS.PACKAGE (RECORD (CREDENTIALS CREDENTIALS) (NONCE LONGCARDINAL) (RECIPIENT NSNAME) (CONVERSATION.KEY KEY))) (STRONG.CREDENTIALS (RECORD (CONVERSATION.KEY KEY) (EXPIRATION.TIME TIME) (INITIATOR NSNAME))) (SIMPLE.CREDENTIALS NSNAME) (VERIFIER (SEQUENCE UNSPECIFIED)) (STRONG.VERIFIER (RECORD (TIMESTAMP TIME) (TICKS LONGCARDINAL))) (SIMPLE.VERIFIER HASHED.PASSWORD) (HASHED.PASSWORD CARDINAL) (PROBLEM (ENUMERATION (CredentialsInvalid 0) (VerifierInvalid 1) (VerifierExpired 2) (VerifierReused 3) (CredentialsExpired 4) (InappropriateCredentials 5))) (CALL.PROBLEM (ENUMERATION (TooBusy 0) (AccessRightsInsufficient 1) (KeysUnavailable 2) (StrongKeyDoesNotExist 3) (SimpleKeyDoesNotExist 4) (StrongKeyAlreadyRegistered 5) (SimpleKeyAlreadyRegistered 6) (DomainForNewKeyUnavailable 7) (DomainForNewKeyUnknown 8) (BadKey 9) (BadName 10) (DatabaseFull 11) (Other 12))) (WHICH (ENUMERATION (notApplicable 0) (Initiator 1) (Recipient 2) (Client 3] PROCEDURES ((BROADCAST.FOR.SERVERS 0 NIL RETURNS ((CLEARINGHOUSE . NETWORK.ADDRESS.LIST))) (GET.STRONG.CREDENTIALS 1 (NSNAME NSNAME LONGCARDINAL) RETURNS ((SEQUENCE UNSPECIFIED)) REPORTS (CALL.ERROR)) (CHECK.SIMPLE.CREDENTIALS 2 (CREDENTIALS VERIFIER) RETURNS (BOOLEAN) REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (CREATE.STRONG.KEY 3 (CREDENTIALS VERIFIER NSNAME KEY) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (CHANGE.STRONG.KEY 4 (CREDENTIALS VERIFIER KEY) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (DELETE.STRONG.KEY 5 (CREDENTIALS VERIFIER NSNAME) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (CREATE.SIMPLE.KEY 6 (CREDENTIALS VERIFIER NSNAME HASHED.PASSWORD) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (CHANGE.SIMPLE.KEY 7 (CREDENTIALS VERIFIER HASHED.PASSWORD) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR)) (DELETE.SIMPLE.KEY 8 (CREDENTIALS VERIFIER NSNAME) RETURNS NIL REPORTS (AUTHENTICATION.ERROR CALL.ERROR))) ERRORS ((CALL.ERROR 1 (CALL.PROBLEM WHICH)) (AUTHENTICATION.ERROR 2 (PROBLEM)))) (COURIERPROGRAM CHACCESSCONTROL (127 1) INHERITS (CLEARINGHOUSE) TYPES ((DOMAIN.NAME NSNAME2) (ORGANIZATION.NAME STRING) (WHICH.LIST (ENUMERATION (Readers 0) (valueDONTUSE 1) (Administrators 2) (selfControllers 3))) (ELEMENT.NAME NSNAME) (DISTING.NAME NSNAME) (IS.MEMBER BOOLEAN) (ACCESS.LIST (SEQUENCE ELEMENT.NAME)) (CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER))) PROCEDURES ((RETRIEVE.PROPERTY.ACL 30 (ELEMENT.NAME PROPERTY WHICH.LIST BULK.DATA.SINK CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (ADD.MEMBER.TO.PROPERTY.ACL 31 (ELEMENT.NAME PROPERTY WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (DELETE.MEMBER.FROM.PROPERTY.ACL 32 (ELEMENT.NAME PROPERTY WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (IS.IN.PROPERTY.ACL 33 (ELEMENT.NAME PROPERTY WHICH.LIST PROPERTY ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (IS.MEMBER DISTING.NAME) REPORTS (CALL.ERROR)) (RETRIEVE.DOMAIN.ACL 34 (DOMAIN.NAME WHICH.LIST BULK.DATA.SINK CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (ADD.MEMBER.TO.DOMAIN.ACL 35 (DOMAIN.NAME WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS NIL REPORTS (CALL.ERROR)) (DELETE.MEMBER.FROM.DOMAIN.ACL 36 (DOMAIN.NAME WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (IS.IN.DOMAIN.ACL 37 (DOMAIN.NAME WHICH.LIST PROPERTY ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (IS.MEMBER) REPORTS (CALL.ERROR)) (RETRIEVE.ORGANIZATION.ACL 38 (ORGANIZATION.NAME WHICH.LIST BULK.DATA.SINK CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (ADD.MEMBER.TO.ORGANIZATION.ACL 39 (ORGANIZATION.NAME WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (DELETE.MEMBER.FROM.ORGANIZATION.ACL 40 (ORGANIZATION.NAME WHICH.LIST ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (DISTING.NAME) REPORTS (CALL.ERROR)) (IS.IN.ORGANIZATION.ACL 41 (ORGANIZATION.NAME WHICH.LIST PROPERTY ELEMENT.NAME CREDENTIALS VERIFIER) RETURNS (IS.MEMBER DISTING.NAME) REPORTS (CALL.ERROR)))) (* ; "Strong authentication and changing passwords") (DEFINEQ (AS.CHANGE.OWN.PASSWORDS (LAMBDA (NEWPASSWORD USERINFO) (* ; "Edited 24-Jul-87 16:37 by bvm:") (* ;;; "Changes user's own password to be NEWPASSWORD, which must be in internal %"encrypted%" form. USERINFO is the (name . pass) of the user making/being changed (defaults to global NS user). Returns NIL on success, else an error expression.") (DECLARE (GLOBALVARS AS.WELL.KNOWN.NAME)) (RESETLST (LET ((CONVGOOK (AS.MAKE.CONVERSATION AS.WELL.KNOWN.NAME USERINFO T))) (DESTRUCTURING-BIND (STREAM ADDR CREDS . CONVKEY) CONVGOOK (IF (EQ STREAM (QUOTE ERROR)) THEN (* ; "Pass along errors") CONVGOOK ELSEIF (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CHANGE.STRONG.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) (DES.BREAKOUT.BLOCKS (CONS (DES.ECB.ENCRYPT CONVKEY (DES.PASSWORD.TO.KEY NEWPASSWORD)))) (QUOTE RETURNERRORS)) ELSEIF (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CHANGE.SIMPLE.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) (HASH.PASSWORD NEWPASSWORD) (QUOTE RETURNERRORS)) ELSE (* ; "Success if neither call returned an error") T))))) ) (AS.REPLACE.PASSWORDS (LAMBDA (NAME NEWPASSWORD) (* ; "Edited 22-Jul-87 17:37 by bvm:") (* ;; "Replace the strong and simple keys for user NAME with NEWPASSWORD. This requires deleting the old keys and creating new ones.") (DECLARE (GLOBALVARS AS.WELL.KNOWN.NAME)) (SETQ NAME (PARSE.NSNAME NAME)) (RESETLST (LET ((CONVGOOK (AS.MAKE.CONVERSATION AS.WELL.KNOWN.NAME NIL T)) ERROR) (DESTRUCTURING-BIND (STREAM ADDR CREDS . CONVKEY) CONVGOOK (if (EQ STREAM (QUOTE ERROR)) then (* ; "Pass along errors") CONVGOOK elseif (AND (SETQ ERROR (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE DELETE.STRONG.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (QUOTE RETURNERRORS))) (NEQ (CADDR ERROR) (QUOTE StrongKeyDoesNotExist))) THEN (* ; "Don't complain if strong key doesn't exist to delete") ERROR elseif (AND (SETQ ERROR (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE DELETE.SIMPLE.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (QUOTE RETURNERRORS))) (NEQ (CADDR ERROR) (QUOTE SimpleKeyDoesNotExist))) THEN ERROR elseif (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CREATE.STRONG.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (DES.BREAKOUT.BLOCKS (CONS (DES.ECB.ENCRYPT CONVKEY (DES.PASSWORD.TO.KEY NEWPASSWORD)))) (QUOTE RETURNERRORS)) ELSEIF (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CREATE.SIMPLE.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (HASH.PASSWORD NEWPASSWORD) (QUOTE RETURNERRORS)) else (* ; "Success if neither call returned an error") T))))) ) (AS.CREATE.PASSWORDS (LAMBDA (NAME PASSWORD) (* ; "Edited 30-Jul-87 17:25 by bvm:") (* ;;; "Create Strong and Simple keys for user NAME. PASSWORD is in the %"encrypted%" form used by \INTERNAL/GETPASSWORD.") (DECLARE (GLOBALVARS AS.WELL.KNOWN.NAME)) (SETQ NAME (PARSE.NSNAME NAME)) (RESETLST (LET ((CONVGOOK (AS.MAKE.CONVERSATION AS.WELL.KNOWN.NAME NIL T))) (DESTRUCTURING-BIND (STREAM ADDR CREDS . CONVKEY) CONVGOOK (IF (EQ STREAM (QUOTE ERROR)) THEN (* ; "Pass along errors") CONVGOOK ELSEIF (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CREATE.STRONG.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (DES.BREAKOUT.BLOCKS (CONS (DES.ECB.ENCRYPT CONVKEY (DES.PASSWORD.TO.KEY PASSWORD)))) (QUOTE RETURNERRORS)) ELSEIF (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE CREATE.SIMPLE.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (HASH.PASSWORD PASSWORD) (QUOTE RETURNERRORS)) ELSE (* ; "Success if neither call returned an error") T))))) ) (AS.DELETE.PASSWORDS (LAMBDA (NAME) (* ; "Edited 22-Jul-87 13:07 by bvm:") (* ;; "Delete the strong and simple keys for user NAME") (DECLARE (GLOBALVARS AS.WELL.KNOWN.NAME)) (SETQ NAME (PARSE.NSNAME NAME)) (RESETLST (LET ((CONVGOOK (AS.MAKE.CONVERSATION AS.WELL.KNOWN.NAME NIL T))) (DESTRUCTURING-BIND (STREAM ADDR CREDS . CONVKEY) CONVGOOK (if (EQ STREAM (QUOTE ERROR)) then (* ; "Pass along errors") CONVGOOK elseif (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE DELETE.STRONG.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (QUOTE RETURNERRORS)) elseif (COURIER.CALL STREAM (QUOTE AUTHENTICATION) (QUOTE DELETE.SIMPLE.KEY) CREDS (AS.NEXT.VERIFIER CONVKEY ADDR) NAME (QUOTE RETURNERRORS)) else (* ; "Success if neither call returned an error") T))))) ) (\AUTHENTICATION.FIND.SERVER (LAMBDA NIL (* bvm%: " 1-Jul-84 15:26") (* ;; "Expanding ring broadcast, as defined in Clearinghouse Protocol spec.") (PROG (INFO) (RETURN (COND ((AND \AUTHENTICATION.SERVER.CACHE (find ADDR in \AUTHENTICATION.SERVER.CACHE suchthat (SELECTQ (CAR (LISTP (COURIER.EXPEDITED.CALL ADDR \AUTHENTICATION.SOCKET (QUOTE AUTHENTICATION) (QUOTE BROADCAST.FOR.SERVERS) (QUOTE RETURNERRORS)))) ((NIL ERROR REJECT) NIL) T)))) ((SETQ INFO (COURIER.BROADCAST.CALL \AUTHENTICATION.SOCKET (QUOTE AUTHENTICATION) (QUOTE BROADCAST.FOR.SERVERS) NIL NIL AUTHENTICATION.NET.HINT "Authentication servers")) (SETQ \AUTHENTICATION.SERVER.CACHE (APPEND INFO \AUTHENTICATION.SERVER.CACHE)) (CAR INFO)))))) ) (AS.MAKE.CONVERSATION (LAMBDA (RECIPIENT USERINFO KEEPSTREAM) (* ; "Edited 23-Jul-87 10:44 by bvm:") (* ;; "Set up a conversation with RECIPIENT by obtaining strong credentials. If USERINFO is supplied, it is a (user . password) pair, defaults to the global NS login. Value returned is (credentials . conversationkey). If KEEPSTREAM is true, then the caller plans to converse with an authentication service, in which case the same courier stream can be used here and there, and the value returned is (stream address credentials . conversationkey). Caller needs a resetlst for this option.") (OR USERINFO (SETQ USERINFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|)))) (LET ((NONCE (RAND)) CRED.PACK ADDR STREAM) (if (AND (SETQ ADDR (\AUTHENTICATION.FIND.SERVER)) (OR (NULL KEEPSTREAM) (SETQ STREAM (COURIER.OPEN ADDR NIL T (QUOTE AUTHENTICATION))))) then (if KEEPSTREAM then (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) STREAM))) (COND ((EQ (CAR (SETQ CRED.PACK (COURIER.CALL (OR STREAM ADDR) (QUOTE AUTHENTICATION) (QUOTE GET.STRONG.CREDENTIALS) (PARSE.NSNAME (CAR USERINFO)) (PARSE.NSNAME RECIPIENT) NONCE (QUOTE RETURNERRORS)))) (QUOTE ERROR)) (* ; "Return error") CRED.PACK) ((OR (NULL (NLSETQ (* ; "If our key is wrong, the decoding could break as we try to read a garbage sequence") (SETQ CRED.PACK (COURIER.READ.REP (DES.BREAKOUT.BLOCKS (DES.CBCC.DECRYPT (DES.PASSWORD.TO.KEY (CDR USERINFO)) (DES.MAKE.BLOCKS CRED.PACK))) (QUOTE AUTHENTICATION) (QUOTE CREDENTIALS.PACKAGE))))) (NOT (IEQP (COURIER.FETCH (AUTHENTICATION . CREDENTIALS.PACKAGE) NONCE of CRED.PACK) NONCE))) (* ; "decoding failed--either our key is wrong or the authentication server is bogus. We assume the latter is unlikely, so report bad key") (QUOTE (ERROR AUTHENTICATION.ERROR CredentialsInvalid))) (T (SETQ CRED.PACK (CONS (COURIER.FETCH (AUTHENTICATION . CREDENTIALS.PACKAGE) CREDENTIALS of CRED.PACK) (DES.MAKE.KEY (COURIER.FETCH (AUTHENTICATION . CREDENTIALS.PACKAGE) CONVERSATION.KEY of CRED.PACK)))) (if KEEPSTREAM then (CONS STREAM (CONS ADDR CRED.PACK)) else CRED.PACK))) else (QUOTE (ERROR CALL.ERROR Can'tGetAuthenticationService))))) ) (AS.NEXT.VERIFIER (LAMBDA (CONVKEY ADDR) (* jwo%: " 9-Aug-85 01:50") (* ;;; "The long garbage in the IF is and attempt to XOR the recipients 'processor id' with the courier data representation, before encrypting.") (DES.BREAKOUT.BLOCKS (LET ((BL (DES.MAKE.BLOCKS (LET ((L (COURIER.WRITE.REP (COURIER.CREATE (AUTHENTICATION . STRONG.VERIFIER) TIMESTAMP _ (IDATE) TICKS _ (RAND)) (QUOTE AUTHENTICATION) (QUOTE STRONG.VERIFIER)))) (if (CAR L) then (RPLACA L (LOGXOR (CAR L) (fetch (NSADDRESS NSHNM0) of ADDR))) (if (CADR L) then (RPLACA (CDR L) (LOGXOR (CADR L) (fetch (NSADDRESS NSHNM1) of ADDR))) (if (CADDR L) then (RPLACA (CDDR L) (LOGXOR (CADDR L) (fetch (NSADDRESS NSHNM2) of ADDR)))))) L)))) (for E in BL collect (DES.ECB.ENCRYPT CONVKEY E))))) ) ) (ADDTOVAR \SYSTEMCACHEVARS \AUTHENTICATION.SERVER.CACHE) (RPAQQ AS.WELL.KNOWN.NAME "Authentication Service:CHServers:CHServers") (RPAQ? AUTHENTICATION.NET.HINT ) (RPAQ? \AUTHENTICATION.SERVER.CACHE ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \AUTHENTICATION.SIMPLE.CREDENTIALS 0) (RPAQQ \AUTHENTICATION.SOCKET 21) (CONSTANTS (\AUTHENTICATION.SIMPLE.CREDENTIALS 0) (\AUTHENTICATION.SOCKET 21)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS AUTHENTICATION.NET.HINT \AUTHENTICATION.SERVER.CACHE AS.WELL.KNOWN.NAME) ) ) (* ; "Weak authentication") (DEFINEQ (NSLOGIN (LAMBDA (HOST MSG) (* bvm%: "23-Aug-84 15:10") (\INTERNAL/GETPASSWORD HOST T NIL MSG NIL (QUOTE NS)))) (NS.AUTHENTICATE (LAMBDA (SIMPLE.CREDENTIALS) (* bvm%: "15-Aug-84 16:00") (* ;;; "Checks SIMPLE.CREDENTIALS -- For convenience, if SIMPLE.CREDENTIALS is not a list, creates credentials from the login for NS::") (OR (LISTP SIMPLE.CREDENTIALS) (SETQ SIMPLE.CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS (\INTERNAL/GETPASSWORD (QUOTE |NS::|) SIMPLE.CREDENTIALS)))) (PROG ((ADDR (\AUTHENTICATION.FIND.SERVER)) RESULT) (RETURN (COND ((NULL ADDR) (QUOTE AllDown)) (T (SETQ RESULT (COURIER.CALL ADDR (QUOTE AUTHENTICATION) (QUOTE CHECK.SIMPLE.CREDENTIALS) (CAR SIMPLE.CREDENTIALS) (CDR SIMPLE.CREDENTIALS) (QUOTE RETURNERRORS))) (COND ((LISTP RESULT) (CADDR RESULT)) (RESULT) (T (QUOTE CredentialsInvalid)))))))) ) (NS.MAKE.SIMPLE.CREDENTIALS (LAMBDA (NAME/PASS) (* bvm%: "15-Aug-84 15:30") (CONS (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ (QUOTE SIMPLE) VALUE _ (COURIER.WRITE.REP (PARSE.NSNAME (CAR NAME/PASS)) (QUOTE AUTHENTICATION) (QUOTE SIMPLE.CREDENTIALS))) (COURIER.WRITE.REP (HASH.PASSWORD (CDR NAME/PASS)) (QUOTE AUTHENTICATION) (QUOTE SIMPLE.VERIFIER)))) ) (HASH.PASSWORD (LAMBDA (PASSWORD) (* bvm%: " 3-NOV-83 22:35") (* ;; "Compute remainder mod 65357 of PASSWORD considered as an arbitrary length integer whose 16 bit words, from most to least significant, are the characters in PASSWORD. Uses Horner's rule and properties of modular arithmetic to do it efficiently.") (bind (HASH _ 0) for CHAR instring (MKSTRING PASSWORD) do (SETQ HASH (IMOD (IPLUS (ITIMES HASH (CONSTANT (IMOD (EXPT 2 16) 65357))) (L-CASECODE (\DECRYPT.PWD.CHAR CHAR))) 65357)) finally (RETURN HASH))) ) ) (* ; "Clearinghouse access control") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) CLEARINGHOUSE) ) (DEFINEQ (CH.RETRIEVE.DOMAIN.ACL (LAMBDA (DOMAIN WHICH.LIST) (* jwo%: "24-Jun-85 14:54") (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.CALL (CH.FINDSERVER (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2))) (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.DOMAIN.ACL) DOMAIN WHICH.LIST (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.ADD.MEMBER.TO.DOMAIN.ACL (LAMBDA (DOMAIN WHICH.LIST NEWMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 14:54 by bvm:") (OR DONTCHECK (SETQ NEWMEMBER (CH.CANONICAL.NAME NEWMEMBER))) (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2))) \CH.BROADCAST.SOCKET (QUOTE CHACCESSCONTROL) (QUOTE ADD.MEMBER.TO.DOMAIN.ACL) DOMAIN WHICH.LIST NEWMEMBER (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.DELETE.MEMBER.FROM.DOMAIN.ACL (LAMBDA (DOMAIN WHICH.LIST OLDMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 14:55 by bvm:") (OR DONTCHECK (SETQ OLDMEMBER (CH.CANONICAL.NAME OLDMEMBER))) (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2))) \CH.BROADCAST.SOCKET (QUOTE CHACCESSCONTROL) (QUOTE DELETE.MEMBER.FROM.DOMAIN.ACL) DOMAIN WHICH.LIST OLDMEMBER (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.IS.IN.DOMAIN.ACL (LAMBDA (DOMAIN WHICH PROPERTY NAME) (* jwo%: " 9-Aug-85 18:55") (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.CALL (CH.FINDSERVER (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2)) T) (QUOTE CHACCESSCONTROL) (QUOTE IS.IN.DOMAIN.ACL) DOMAIN WHICH (OR (CH.PROPERTY PROPERTY) PROPERTY) (PARSE.NSNAME NAME) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.RETRIEVE.PROPERTY.ACL (LAMBDA (NAME PROPERTY WHICH.LIST) (* jwo%: "24-Jun-85 14:37") (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.CALL (CH.FINDSERVER (SETQ NAME (PARSE.NSNAME NAME)) T) (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.PROPERTY.ACL) NAME (OR (CH.PROPERTY PROPERTY) PROPERTY) WHICH.LIST (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.ADD.MEMBER.TO.PROPERTY.ACL (LAMBDA (OBJECT PROPERTY WHICH.LIST NEWMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 14:55 by bvm:") (OR DONTCHECK (SETQ NEWMEMBER (CH.CANONICAL.NAME NEWMEMBER))) (SETQ OBJECT (PARSE.NSNAME OBJECT)) (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.CALL (CH.FINDSERVER OBJECT) (QUOTE CHACCESSCONTROL) (QUOTE ADD.MEMBER.TO.PROPERTY.ACL) OBJECT (OR (CH.PROPERTY PROPERTY) PROPERTY) WHICH.LIST (PARSE.NSNAME NEWMEMBER) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.DELETE.MEMBER.FROM.PROPERTY.ACL (LAMBDA (OBJECT PROPERTY WHICH.LIST OLDMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 15:44 by bvm:") (OR DONTCHECK (SETQ OLDMEMBER (CH.CANONICAL.NAME OLDMEMBER))) (SETQ OBJECT (PARSE.NSNAME OBJECT)) (LET ((AUTH (CH.GETAUTHENTICATOR T))) (COURIER.CALL (CH.FINDSERVER OBJECT) (QUOTE CHACCESSCONTROL) (QUOTE DELETE.MEMBER.FROM.PROPERTY.ACL) OBJECT (OR (CH.PROPERTY PROPERTY) PROPERTY) WHICH.LIST (PARSE.NSNAME OLDMEMBER) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))) ) (CH.NUMBER.TO.PROPERTY (LAMBDA (PNUM) (* ejs%: "10-Jun-85 16:26") (* ;;; "reverse mapping to that of CH.PROPERTY") (CAR (for M in CH.PROPERTIES thereis (EQ PNUM (CADR M))))) ) ) (* ;; "These belong on CLEARINGHOUSE but are here temporarily for benefit of Lyric users wanting a functional NSMAINTAIN. Put these back when a %"Lyric%" version of this file has been stashed." ) (DEFINEQ (CH.LIST.PROPERTIES (LAMBDA (OBJECTNAMEPATTERN) (* ; "Edited 24-Jul-87 15:38 by bvm:") (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ OBJECTNAMEPATTERN (PARSE.NSNAME OBJECTNAMEPATTERN))) \CH.BROADCAST.SOCKET (QUOTE CLEARINGHOUSE) (QUOTE LIST.PROPERTIES) OBJECTNAMEPATTERN (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS))) ) (CH.LIST.ORGANIZATIONS (LAMBDA (ORGANIZATIONPATTERN) (* ; "Edited 24-Jul-87 17:47 by bvm:") (COURIER.CALL (GETCLEARINGHOUSE) (QUOTE CLEARINGHOUSE) (QUOTE LIST.ORGANIZATIONS) (PARSE.NSNAME ORGANIZATIONPATTERN 1) (QUOTE (CLEARINGHOUSE . ORGANIZATION)) (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS))) ) (CH.LIST.OBJECTS (LAMBDA (OBJECTPATTERN PROPERTY) (* ; "Edited 24-Jul-87 17:47 by bvm:") (COURIER.CALL (CH.FINDSERVER (SETQ OBJECTPATTERN (PARSE.NSNAME OBJECTPATTERN)) T) (QUOTE CLEARINGHOUSE) (QUOTE LIST.OBJECTS) OBJECTPATTERN (CH.PROPERTY (OR PROPERTY (QUOTE ALL))) (QUOTE (CLEARINGHOUSE . OBJECT)) (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS))) ) ) (DEFINEQ (CH.ADD.GROUP.PROPERTY (LAMBDA (OBJECTNAME PROPERTY MEMBERS DONTCHECK) (* ; "Edited 10-Aug-87 14:57 by bvm:") (OR DONTCHECK (SETQ MEMBERS (for X in MEMBERS collect (CH.CANONICAL.NAME X)))) (COURIER.CALL (CH.FINDSERVER (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME))) (QUOTE CLEARINGHOUSE) (QUOTE ADD.GROUP.PROPERTY) OBJECTNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (FUNCTION (LAMBDA (DATASTREAM) (* ; "Function to write the membership onto the bulk data stream") (COURIER.WRITE.BULKDATA DATASTREAM MEMBERS NIL (QUOTE NSNAME)))) (CH.GETAUTHENTICATOR T) (QUOTE RETURNERRORS))) ) (CH.ADD.MEMBER (LAMBDA (GROUPNAME PROPERTY NEWMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 14:51 by bvm:") (OR DONTCHECK (SETQ NEWMEMBER (CH.CANONICAL.NAME NEWMEMBER))) (COURIER.CALL (CH.FINDSERVER (SETQ GROUPNAME (PARSE.NSNAME GROUPNAME))) (QUOTE CLEARINGHOUSE) (QUOTE ADD.MEMBER) GROUPNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) NEWMEMBER (CH.GETAUTHENTICATOR T) (QUOTE RETURNERRORS))) ) (CH.DELETE.MEMBER (LAMBDA (GROUPNAME PROPERTY OLDMEMBER DONTCHECK) (* ; "Edited 10-Aug-87 14:50 by bvm:") (OR DONTCHECK (SETQ OLDMEMBER (CH.CANONICAL.NAME OLDMEMBER))) (COURIER.CALL (CH.FINDSERVER (SETQ GROUPNAME (PARSE.NSNAME GROUPNAME))) (QUOTE CLEARINGHOUSE) (QUOTE DELETE.MEMBER) GROUPNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) OLDMEMBER (CH.GETAUTHENTICATOR T) (QUOTE RETURNERRORS))) ) ) (PUTPROPS AUTHENTICATION COPYRIGHT ("Venue & Xerox Corporation" 1987 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9531 17395 (AS.CHANGE.OWN.PASSWORDS 9541 . 10594) (AS.REPLACE.PASSWORDS 10596 . 12078) (AS.CREATE.PASSWORDS 12080 . 13030) (AS.DELETE.PASSWORDS 13032 . 13794) (\AUTHENTICATION.FIND.SERVER 13796 . 14509) (AS.MAKE.CONVERSATION 14511 . 16637) (AS.NEXT.VERIFIER 16639 . 17393)) (18003 19732 ( NSLOGIN 18013 . 18128) (NS.AUTHENTICATE 18130 . 18835) (NS.MAKE.SIMPLE.CREDENTIALS 18837 . 19204) ( HASH.PASSWORD 19206 . 19730)) (19859 23845 (CH.RETRIEVE.DOMAIN.ACL 19869 . 20328) ( CH.ADD.MEMBER.TO.DOMAIN.ACL 20330 . 20892) (CH.DELETE.MEMBER.FROM.DOMAIN.ACL 20894 . 21466) ( CH.IS.IN.DOMAIN.ACL 21468 . 21943) (CH.RETRIEVE.PROPERTY.ACL 21945 . 22446) ( CH.ADD.MEMBER.TO.PROPERTY.ACL 22448 . 23049) (CH.DELETE.MEMBER.FROM.PROPERTY.ACL 23051 . 23662) ( CH.NUMBER.TO.PROPERTY 23664 . 23843)) (24052 25039 (CH.LIST.PROPERTIES 24062 . 24382) ( CH.LIST.ORGANIZATIONS 24384 . 24684) (CH.LIST.OBJECTS 24686 . 25037)) (25040 26432 ( CH.ADD.GROUP.PROPERTY 25050 . 25632) (CH.ADD.MEMBER 25634 . 26028) (CH.DELETE.MEMBER 26030 . 26430)))) ) STOP \ No newline at end of file diff --git a/sources/BOOTSTRAP b/sources/BOOTSTRAP new file mode 100644 index 00000000..5de3ae92 --- /dev/null +++ b/sources/BOOTSTRAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Nov-92 04:15:40" "{Pele:mv:envos}Sources>BOOTSTRAP.;4" 40191 changes to%: (FNS MOVD) previous date%: "22-May-92 12:00:44" "{Pele:mv:envos}Sources>BOOTSTRAP.;3") (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BOOTSTRAPCOMS) (RPAQQ BOOTSTRAPCOMS [(COMS (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO") (FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP PROPNAMES ADDPROP REMPROP MEMB CLOSEF?)) (COMS (* ;  "Need these in order to load even compiled files SYSLOAD") (FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO)) (INITVARS (EOLCHARCODE (CHCON1 " ")) (PRETTYHEADER) (DWIMFLG) (UPDATEMAPFLG) (DFNFLG) (ADDSPELLFLG) (BUILDMAPFLG) (FILEPKGFLG) (SYSFILES) (NOTCOMPILEDFILES) (RESETVARSLST) [LOADPARAMETERS '((SEQUENTIAL T] (LISPXHIST) (LISPXPRINTFLG T) (PRETTYHEADER "File created ") (LOAD-VERBOSE-STREAM T) (BELLS '"") (LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP)) (PRETTYDEFMACROS NIL) (PRETTYTYPELST NIL) (FILEPKGTYPES NIL)) (ADDVARS (LOADEDFILELST)) (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES) (DECLARE%: DONTEVAL@LOAD DOCOPY [P [MAPC '((PUTD . /PUTD) (PUTPROP . /PUTPROP) (PUTPROP . PUT) (PUTPROP . SAVEPUT) (ADDPROP . /ADDPROP) (PUT . /PUT) (PRIN1 . LISPXPRIN1) (PRIN2 . LISPXPRIN2) (PRINT . LISPXPRINT) (TERPRI . LISPXTERPRI) (SPACES . LISPXSPACES) (GETPROP . GETP) (SET . SAVESET) (SET . /SET) (NILL . MISSPELLED?) (SETTOPVAL . /SETTOPVAL) (BOOTSTRAP-NAMEFIELD . NAMEFIELD) (NILL . RESETRESTORE)) (FUNCTION (LAMBDA (X) (OR (CCODEP (CDR X)) (MOVD (CAR X) (CDR X) NIL T] (AND (CCODEP 'BOOTSTRAP-NAMEFIELD) (PUTD 'BOOTSTRAP-NAMEFIELD] (P (RADIX 10))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ; "eventually imported from FASL") (CONSTANTS FASL:SIGNATURE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ) (NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ) (LAMA]) (* ; "Some basic fns. Note that several are redefined later. E.g., RPAQQ et al real definitions are on UNDO" ) (DEFINEQ (GETPROP [LAMBDA (ATM PROP) (* lmm " 5-SEP-83 22:29") (* ; "Used to be called GETP") (AND (LITATOM ATM) (PROG ((PLIST (GETPROPLIST ATM))) LP [COND ((OR (NLISTP PLIST) (NLISTP (CDR PLIST))) (RETURN NIL)) ((EQ (CAR PLIST) PROP) (RETURN (CADR PLIST] (SETQ PLIST (CDDR PLIST)) (GO LP]) (SETATOMVAL [LAMBDA (X Y) (* bvm%: "29-Sep-86 16:14") (SETTOPVAL X Y]) (RPAQQ [NLAMBDA (X Y) (SETATOMVAL X Y]) (RPAQ [NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:10") (* ;  "RPAQ and RPAQQ are used by PRETTYDEF to save VARS.") (SETTOPVAL RPAQX (EVAL RPAQY]) (RPAQ? [NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:12") (* ;  "RPAQ? and RPAQQ are used by PRETTYDEF to save VARS.") (OR (NEQ (GETTOPVAL RPAQX) 'NOBIND) (SETTOPVAL RPAQX (EVAL RPAQY]) (MOVD [LAMBDA (FROM TO COPYFLG DONTCOPY) (* ;  "Edited 2-Nov-92 03:50 by sybalsky:mv:envos") (COND ((AND DONTCOPY (NULL COPYFLG)) (* ;; "He really wants NO copy made, not a renamed version.") (* ;;  "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.") (LET ((FROMCELL (fetch (LITATOM DEFINITIONCELL) of FROM)) (TOCELL (fetch (LITATOM DEFINITIONCELL) of TO))) (UNINTERRUPTABLY (replace (DEFINITIONCELL DEFPOINTER) of TOCELL with (fetch (DEFINITIONCELL DEFPOINTER) of FROMCELL)) (replace (DEFINITIONCELL DEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL DEFCELLFLAGS) of FROMCELL)) (replace (DEFINITIONCELL AUXDEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL AUXDEFCELLFLAGS) of FROMCELL)) TO))) (T (LET [(NEWFLG (NULL (GETD TO] (PUTD TO (COND (COPYFLG (COPY (VIRGINFN FROM))) (T (GETD FROM))) DONTCOPY) (AND FILEPKGFLG (EXPRP TO) (MARKASCHANGED TO 'FNS NEWFLG)) TO]) (MOVD? [LAMBDA (FROM TO COPYFLG DONTCOPY) (* bvm%: "10-Jul-85 13:00") (* ;; "Like MOVD but only does it if TO is not defined.") (COND ((NULL (GETD TO)) (PUTD TO (COND (COPYFLG (COPY (VIRGINFN FROM))) (T (GETD FROM))) DONTCOPY) (AND FILEPKGFLG (EXPRP TO) (MARKASCHANGED TO 'FNS T)) TO]) (SELECTQ [NLAMBDA SELCQ (APPLY 'PROGN (SELECTQ1 (EVAL (CAR SELCQ) 'SELECTQ) (CDR SELCQ)) 'SELECTQ]) (SELECTQ1 [LAMBDA (M L) (PROG (C) LP (SETQ C L) [COND ((NULL (SETQ L (CDR L))) (RETURN C)) ([OR (EQ (CAR (SETQ C (CAR C))) M) (AND (LISTP (CAR C)) (FMEMB M (CAR C] (RETURN (CDR C] (GO LP]) (NCONC1 [LAMBDA (LST X) (* included in wtmisc so can make the call to nconc be linked.  so that user can then break on nconc.) (NCONC LST (FRPLACD (CONS X LST]) (PUTPROP [LAMBDA (ATM PROP VAL) (* ; "Edited 28-May-87 09:16 by jop") (* ;; "Included because it must be defined before the MOVD's in BOOTSTRAPCOMS that initialize /PUTPROP are executed.") [COND ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0) LP (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)") (FRPLACD (CDR X0) (LIST PROP VAL)) (RETURN VAL))) (* ;; "propety 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) (FRPLACA (CDR X) VAL) (RETURN VAL)) (T (SETQ X (CDDR (SETQ X0 X))) (GO LP))) [SETPROPLIST ATM (CONS PROP (CONS VAL (GETPROPLIST ATM] (RETURN VAL]) (PROPNAMES [LAMBDA (ATM) (* wt%: " 3-AUG-78 01:23") (MAPLIST (GETPROPLIST ATM) (FUNCTION CAR) (FUNCTION CDDR]) (ADDPROP [LAMBDA (ATM PROP NEW FLG) (* ;  "If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.") (* ; "Value is new PROP value.") [COND [(NULL ATM) (ERRORX (LIST 7 (LIST PROP NEW] ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0) LP (COND ((NLISTP X) (COND ((AND (NULL X) X0) (* ;  "typical case. property list ran out on an even parity position.") [FRPLACD (CDR X0) (LIST PROP (SETQ NEW (LIST NEW] (RETURN NEW))) (* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g. (A B . C) fall through and add property at beginning of property list.") ) ((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or else ends in a non-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) (* ; "PROP found") [FRPLACA (CDR X) (SETQ NEW (COND (FLG (CONS NEW (CADR X))) (T (NCONC1 (CADR X) NEW] (RETURN NEW)) (T (SETQ X (CDDR (SETQ X0 X))) (GO LP))) (* ;  "Add to beginning of property list.") [SETPROPLIST ATM (CONS PROP (CONS (SETQ NEW (LIST NEW)) (GETPROPLIST ATM] (RETURN NEW]) (REMPROP [LAMBDA (ATM PROP) (* bvm%: "17-Sep-86 17:29") [COND ((NULL (LITATOM ATM)) (ERRORX (LIST 14 ATM] (PROG ((X (GETPROPLIST ATM)) X0 VAL) LP [COND ((OR (NLISTP X) (NLISTP (CDR X))) (RETURN VAL)) ((EQ (CAR X) PROP) (SETQ VAL (OR PROP T)) (* ; "T in case indicator is NIL") [COND (X0 (FRPLACD (CDR X0) (CDDR X))) (T (SETPROPLIST ATM (CDDR X] (* ; "iterate in case there are more occurrences. Shouldn't happen unless users manually clobber prop list") (SETQ X (CDDR X))) (T (SETQ X (CDDR (SETQ X0 X] (GO LP]) (MEMB [LAMBDA (X Y) (PROG NIL LP (RETURN (COND ((NLISTP Y) NIL) ((EQ X (CAR Y)) Y) (T (SETQ Y (CDR Y)) (GO LP]) (CLOSEF? [LAMBDA (FL) (* wt%: 18-MAR-77 12 20) (* ;  "useful for resetsaves, in case somebody else might close the file.") (AND FL (OPENP FL) (CLOSEF FL]) ) (* ; "Need these in order to load even compiled files SYSLOAD") (DEFINEQ (LOAD [LAMBDA (FILE LDFLG PRINTFLG PACKAGE) (* ; "Edited 9-Apr-87 18:44 by bvm:") (RESETLST (PROG (STREAM TEM) TOP (if (FMEMB LDFLG LOADOPTIONS) elseif (AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T))) then (SETQ LDFLG TEM) else (SETQ LDFLG (ERROR "unrecognized load option" LDFLG)) (GO TOP)) [if (AND PACKAGE (NOT (CL:PACKAGEP PACKAGE))) then (* ;  "Make sure package arg is ok, too") (SETQ PACKAGE (OR (CL:FIND-PACKAGE PACKAGE) (\DTEST PACKAGE 'PACKAGE] [RESETSAVE NIL (LIST 'CLOSEF? (SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD LOADPARAMETERS] (RETURN (\LOAD-STREAM STREAM LDFLG PRINTFLG (AND PRETTYHEADER T) PACKAGE]) (\LOAD-STREAM [LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE) (DECLARE (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM)) (* ; "Edited 29-Jan-88 19:02 by jop") (* ;;; "Internal function that loads from an already open stream. LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such. Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.") (PROG ((*STANDARD-INPUT* STREAM) (FILE (FULLNAME STREAM)) (*PACKAGE* *PACKAGE*) (*READTABLE* (PROG1 FILERDTBL (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read") )) (DFNFLG DFNFLG) (BUILDMAPFLG BUILDMAPFLG) (FILEPKGFLG FILEPKGFLG) (ADDSPELLFLG ADDSPELLFLG) (LISPXHIST LISPXHIST) (PRLST (AND FILEPKGFLG (FILEPKGCHANGES))) (FILECREATEDENV *OLD-INTERLISP-READ-ENVIRONMENT*) FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P FILECREATEDLOC) (DECLARE (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST FILECREATEDENV FILECREATEDLOC FILE)) (if (AND LOAD-VERBOSE-STREAM FILE) then (LISPXTERPRI LOAD-VERBOSE-STREAM) (if (NEQ LOAD-VERBOSE-STREAM T) then (* ;  "CL:LOAD says to prefix this stuff with comment marker") (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) (* ;  "Might use EXEC-FORMAT here except that it isn't defined early in loadup") (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM) (LISPXTERPRI LOAD-VERBOSE-STREAM)) (if (EQ (SETQ DFNFLG LDFLG) 'SYSLOAD) then (SETQ DFNFLG T) (SETQ ADDSPELLFLG NIL) (SETQ BUILDMAPFLG NIL) (SETQ FILEPKGFLG NIL) (SETQ LISPXHIST NIL)) (if LISPXHIST then (* ;  "Want UNDOSAVE to keep saving regardless of how many undosaves are involved") (if (SETQ LOADA (FMEMB 'SIDE LISPXHIST)) then (FRPLACA (CADR LOADA) -1) else (LISPXPUT 'SIDE (LIST -1) NIL LISPXHIST))) (if (EQ (SETQ TEM (SKIPSEPRCODES STREAM)) FASL:SIGNATURE) then (* ;  "FASL file handled by FASL loader") (FASL:PROCESS-FILE STREAM) [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME FILE T)) 'FILEDATES] (if (NOT (MEMB FILE LOADEDFILELST)) then (* ;  "Keep track of every file loaded.") (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST))) (if MANAGED-FILE-P then (if (EQ LDFLG 'SYSLOAD) then (* ;;  "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag") (if (NOT (MEMB ROOTNAME SYSFILES)) then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) (SMASHFILECOMS ROOTNAME) elseif FILEPKGFLG then (ADDFILE ROOTNAME 'Compiled] (RETURN FILE) elseif (NEQ TEM (CHARCODE "(")) then (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE))) (if (AND BUILDMAPFLG (RANDACCESSP STREAM)) then (SETQ MAYBEWANTFILEMAP T)) (WITH-READER-ENVIRONMENT FILECREATEDENV (PROG (ADR) LP (if FILEMAP then (* ;  "need to build map, so read carefully") (SETQ LOADA (SKIPSEPRCODES STREAM)) (if (OR (SYNTAXP LOADA 'LEFTPAREN) (SYNTAXP LOADA 'LEFTBRACKET)) then (* ; "See if we have a DEFINEQ") (SETQ ADR (GETFILEPTR STREAM)) (READCCODE STREAM) (* ; "Eat paren") (if (EQ (RATOM STREAM) 'DEFINEQ) then (SETQ FNADRLST (TCONC NIL ADR)) (TCONC FNADRLST NIL) (TCONC FILEMAP (CAR FNADRLST)) (GO DEFQLP)) (* ; "Not a DEFINEQ, so back out") (SETFILEPTR STREAM ADR))) (SELECTQ (SETQ LOADA (READ STREAM)) ((STOP NIL) (if (EQ LDFLG 'SYSLOAD) then (if (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST ))) SYSFILES)) then (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME) )) (SMASHFILECOMS ROOTNAME) elseif FILEPKGFLG then (* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES. Also, we want items mentioned earlier to be deleted if they are taken care of by this file. The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.") (ADDFILE FILE T PRLST FILECREATEDLST)) [if FILEMAP then (PUTFILEMAP FILE (CAR FILEMAP) FILECREATEDLST FILECREATEDENV NIL FILECREATEDLOC) (if UPDATEMAPFLG then (SETFILEPTR STREAM ADR) (* ;  "address of last expression read. good hint for finding filemap") (UPDATEFILEMAP STREAM (CAR FILEMAP] (if (NOT (MEMB FILE LOADEDFILELST)) then (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST))) (RETURN)) NIL) [if (LISTP LOADA) then (SELECTQ (CAR LOADA) (DEFINE-FILE-INFO (* ;  "Handle this specially, since we want to remember the environment") (SETQ FILECREATEDLOC (GETFILEPTR STREAM)) [SET-READER-ENVIRONMENT (SETQ LOADA (SETQ FILECREATEDENV (\DO-DEFINE-FILE-INFO NIL (CDR LOADA] (if PACKAGE then (* ;  "Caller better really mean it--overrides what's on file!") [replace REPACKAGE of FILECREATEDENV with (SETQ *PACKAGE* (\DTEST PACKAGE 'PACKAGE] (LISTPUT (fetch RESPEC of FILECREATEDENV ) :PACKAGE (CL:PACKAGE-NAME *PACKAGE*)))) (FILECREATED (if MAYBEWANTFILEMAP then (* ; "See if we have a valid file map") (SETQ ADR (GETFILEPTR STREAM)) (if [AND (FIXP (SETQ TEM (CADDDR LOADA))) [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM TEM) (READ STREAM] (EQ (CAR TEM) 'FILEMAP) (NULL (CAR (SETQ TEM (CADR TEM] then (* ; "Has ok map") (PUTFILEMAP FILE TEM NIL FILECREATEDENV) else (* ;  "Need to build a file map as we go") (SETQ FILEMAP (TCONC NIL NIL))) (SETFILEPTR STREAM ADR) (SETQ MAYBEWANTFILEMAP NIL)) (SETQ LOADA (\EVAL LOADA))) (SETQ LOADA (\EVAL LOADA))) else (* ;  "Atom found. Compiled code definition.") (if ADDSPELLFLG then (ADDSPELL LOADA)) (if FILEMAP then (SETQ ADR (GETFILEPTR STREAM))) (LAPRD LOADA) (if FILEMAP then (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM) LOADA] LP1 (if PRINTFLG then (PRINT LOADA PRINTFLG)) (GO LP) DEFQLP (SELCHARQ (SKIPSEPRCODES STREAM) ((%) %]) (* ; "Closes DEFINEQ.") (READCCODE STREAM) (if FNADRLST then (RPLACA (CDAR FNADRLST) (GETFILEPTR STREAM))) (* ;  "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.") (SETQ LOADA (DEFINE (DREVERSE LOADA))) (GO LP1)) ((%( %[) (* ;  "another function/definition pair") (SETQ ADR (GETFILEPTR STREAM)) (SETQ LOADA (CONS (READ STREAM) LOADA)) [if FNADRLST then (TCONC FNADRLST (CONS (CAAR LOADA) (CONS ADR (GETFILEPTR STREAM] (GO DEFQLP)) NIL) (ERROR "illegal argument in defineq"))) (RETURN FILE]) (FILECREATED [NLAMBDA X (* ; "Edited 12-Jan-88 10:44 by bvm") (DECLARE (USEDFREE FILECREATEDLST LOAD-VERBOSE-STREAM)) (PROG ((FILEDATE (CAR X)) (FILE (CADR X))) (SETQ FILECREATEDLST (NCONC1 FILECREATEDLST X)) (COND (LOAD-VERBOSE-STREAM (* ;; "Presumably if user sets prettyheader to NIL, he doesnt want to see any file created messages, even those frm compiled files.") (if (NEQ LOAD-VERBOSE-STREAM T) then (* ;  "CL:LOAD says to prefix this stuff with comment marker") (PRIN1 "; " LOAD-VERBOSE-STREAM)) (LISPXPRIN1 (FILECREATED1 X) LOAD-VERBOSE-STREAM) (LISPXPRIN1 FILEDATE LOAD-VERBOSE-STREAM) (LISPXTERPRI LOAD-VERBOSE-STREAM))) (COND ((AND FILE (NLISTP FILE)) (* ;; "This is just temporary, primarily for keeping dates of system files which are loaded with FILEPKGFLG=NIL. The real setting up of file property lists is done when ADDFILE is called.") (/PUT (ROOTFILENAME FILE) 'FILEDATES (LIST (CONS FILEDATE FILE]) (FILECREATED1 [LAMBDA (X) (* ; "Edited 12-Jan-88 10:44 by bvm") (* ;; "performs error checking on filecreated expressions. returns the thing to be printed. used by filecreated, and loadfns.") (* ;; "FILECREATED expression for source file is of form (FILECREATED date filename mapaddress . historyinfo). For compiled file, is of form (FILECREATED date (%"compiled on%" sourceFile)). ") (LET ((FILE (CADR X))) (COND ((AND NIL (STRINGP FILE)) (* ;  "old way of doing COMPILED ON -- we no longer have such files, and the file name can be a string.") FILE) ((LISTP FILE) (* ;  "New. also used for printing COMPILED ON message. CDR is a list of files that were compiled.") (CAR FILE)) (T (* ;  "FILE is atomic, the name of the file") PRETTYHEADER]) (PRETTYCOMPRINT [NLAMBDA (X) (* bvm%: "22-Sep-86 17:02") (if LOAD-VERBOSE-STREAM then (if (NEQ LOAD-VERBOSE-STREAM T) then (* ;  "CL:LOAD says to prefix this stuff with comment marker") (PRIN1 "; " LOAD-VERBOSE-STREAM)) (LISPXPRINT X LOAD-VERBOSE-STREAM]) (BOOTSTRAP-NAMEFIELD [LAMBDA (FILE SUFFIXFLG) (* bvm%: " 2-Aug-86 14:50") (* ;; "BOOTSTRAP VERSION -- this is replaced by real version from MACHINEINDEPENDENT") (PROG ((START 1) POS END) (while (SETQ POS (OR (STRPOS '} FILE START) (STRPOS '> FILE START) (STRPOS '/ FILE START))) do (SETQ START (ADD1 POS))) [COND ((SETQ POS (STRPOS '; FILE)) (SETQ END (SUB1 POS)) (COND ((EQ (NTHCHARCODE FILE END) (CHARCODE ".")) (* ; "eliminates null suffix") (SETQ END (SUB1 END] [COND ((SETQ POS (STRPOS '%. FILE START)) (COND ((NULL SUFFIXFLG) (SETQ END (SUB1 POS] (RETURN (SUBATOM FILE START END]) (PUTPROPS [NLAMBDA X (* bvm%: " 8-Sep-86 11:20") (* ;; "Later in the loadup, the PUTPROP is changed to SAVEPUT") (MAP (CDR X) [FUNCTION (LAMBDA (Y) (PUTPROP (CAR X) (CAR Y) (CADR Y] (FUNCTION CDDR]) (DECLARE%: [NLAMBDA X (* wt%: "20-OCT-77 13:00") (DECLARE%:1 X T]) (DECLARE%:1 [LAMBDA (X EVALFLG) (* wt%: "20-OCT-77 13:09") (PROG NIL LP (COND ((NLISTP X) (RETURN)) [(LISTP (CAR X)) (AND EVALFLG (COND ((EQ (CAAR X) 'DECLARE%:) (DECLARE%:1 (CDAR X) T)) (T (EVAL (CAR X] (T (SELECTQ (CAR X) ((EVAL@LOAD DOEVAL@LOAD) (SETQ EVALFLG T)) (EVAL@LOADWHEN (SETQ EVALFLG (EVAL (CADR X))) (SETQ X (CDR X))) (DONTEVAL@LOAD (SETQ EVALFLG NIL)) NIL))) (SETQ X (CDR X)) (GO LP]) (ROOTFILENAME [LAMBDA (NAME COMPFLG) (* ; "Edited 22-May-92 11:59 by jds") (* ;; "Returns the root of the filename NAME, the atom that all file package properties will be associated with. If NAME names a compiled file, then COMPFLG~=NIL and we assume that the extension is COMPILE.EXT, which is to be stripped off. We thus have something of an anomaly: We can keep track of 2 symbolic files whose names differ only in extension, but we confuse them when we deal with their compiled versions.") (* ;; "The name is always returned in upper case, so that file-system case dependencies don't carry over into Medley, where source file names are NOT case dependent. JDS, fixing AR 11518 5/21/92") (U-CASE (NAMEFIELD (COND ((TYPEP NAME 'STREAM) (FULLNAME NAME)) (T NAME)) (NOT COMPFLG]) (DEFINE-FILE-INFO [NLAMBDA ARGS (* bvm%: "13-Oct-86 17:24") (* ;; "Evaluated when it appears at top of file. Caller (e.g., LOAD) binds reader environment, so we just set it. Also return the env in case someone wants it.") (DECLARE (USEDFREE FILECREATEDLOC)) (SETQ FILECREATEDLOC (GETFILEPTR)) (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL ARGS]) (\DO-DEFINE-FILE-INFO [LAMBDA (STREAM ARGS) (* bvm%: "14-Oct-86 00:28") (* ;;; "Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM") (LET (PACKAGE READTABLE BASE VALUE) [for TAIL on ARGS by (CDDR TAIL) do (SETQ VALUE (CADR TAIL)) (SELECTQ (CAR TAIL) (:PACKAGE (SETQ PACKAGE (OR (if (LISTP VALUE) then (LET ((P (EVAL VALUE))) (if (TYPEP P 'PACKAGE) then P else (CL:FIND-PACKAGE P))) else (CL:FIND-PACKAGE VALUE)) (ERROR "Can't find package for reader environment" VALUE)))) (:READTABLE (SETQ READTABLE (OR (if (LISTP VALUE) then (\DTEST (EVAL VALUE) 'READTABLEP) else (FIND-READTABLE VALUE)) (ERROR "Can't find read table for reader environment" VALUE)))) (:BASE (SETQ BASE (OR (\CHECKRADIX (if (LISTP VALUE) then (EVAL VALUE) else VALUE)) (ERROR "Bad read base for reader environment" VALUE)))) (ERROR "Unrecognized file info key" (CAR TAIL] (create READER-ENVIRONMENT REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*) REREADTABLE _ (OR READTABLE FILERDTBL) REBASE _ (OR BASE 10) RESPEC _ ARGS]) ) (RPAQ? EOLCHARCODE (CHCON1 " ")) (RPAQ? PRETTYHEADER ) (RPAQ? DWIMFLG ) (RPAQ? UPDATEMAPFLG ) (RPAQ? DFNFLG ) (RPAQ? ADDSPELLFLG ) (RPAQ? BUILDMAPFLG ) (RPAQ? FILEPKGFLG ) (RPAQ? SYSFILES ) (RPAQ? NOTCOMPILEDFILES ) (RPAQ? RESETVARSLST ) (RPAQ? LOADPARAMETERS '((SEQUENTIAL T))) (RPAQ? LISPXHIST ) (RPAQ? LISPXPRINTFLG T) (RPAQ? PRETTYHEADER "File created ") (RPAQ? LOAD-VERBOSE-STREAM T) (RPAQ? BELLS '"") (RPAQ? LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP)) (RPAQ? PRETTYDEFMACROS NIL) (RPAQ? PRETTYTYPELST NIL) (RPAQ? FILEPKGTYPES NIL) (ADDTOVAR LOADEDFILELST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES) ) (DECLARE%: DONTEVAL@LOAD DOCOPY [MAPC '((PUTD . /PUTD) (PUTPROP . /PUTPROP) (PUTPROP . PUT) (PUTPROP . SAVEPUT) (ADDPROP . /ADDPROP) (PUT . /PUT) (PRIN1 . LISPXPRIN1) (PRIN2 . LISPXPRIN2) (PRINT . LISPXPRINT) (TERPRI . LISPXTERPRI) (SPACES . LISPXSPACES) (GETPROP . GETP) (SET . SAVESET) (SET . /SET) (NILL . MISSPELLED?) (SETTOPVAL . /SETTOPVAL) (BOOTSTRAP-NAMEFIELD . NAMEFIELD) (NILL . RESETRESTORE)) (FUNCTION (LAMBDA (X) (OR (CCODEP (CDR X)) (MOVD (CAR X) (CDR X) NIL T] (AND (CCODEP 'BOOTSTRAP-NAMEFIELD) (PUTD 'BOOTSTRAP-NAMEFIELD)) (RADIX 10) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ FASL:SIGNATURE 145) (CONSTANTS FASL:SIGNATURE) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ) (ADDTOVAR NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ) (ADDTOVAR LAMA ) ) (PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4429 14101 (GETPROP 4439 . 5011) (SETATOMVAL 5013 . 5142) (RPAQQ 5144 . 5197) (RPAQ 5199 . 5511) (RPAQ? 5513 . 5883) (MOVD 5885 . 7749) (MOVD? 7751 . 8181) (SELECTQ 8183 . 8370) ( SELECTQ1 8372 . 8714) (NCONC1 8716 . 8912) (PUTPROP 8914 . 10398) (PROPNAMES 10400 . 10591) (ADDPROP 10593 . 12656) (REMPROP 12658 . 13512) (MEMB 13514 . 13773) (CLOSEF? 13775 . 14099)) (14174 38092 ( LOAD 14184 . 15353) (\LOAD-STREAM 15355 . 29131) (FILECREATED 29133 . 30551) (FILECREATED1 30553 . 31661) (PRETTYCOMPRINT 31663 . 32148) (BOOTSTRAP-NAMEFIELD 32150 . 33110) (PUTPROPS 33112 . 33480) ( DECLARE%: 33482 . 33614) (DECLARE%:1 33616 . 34488) (ROOTFILENAME 34490 . 35438) (DEFINE-FILE-INFO 35440 . 35875) (\DO-DEFINE-FILE-INFO 35877 . 38090))))) STOP \ No newline at end of file diff --git a/sources/BREAK-AND-TRACE b/sources/BREAK-AND-TRACE new file mode 100644 index 00000000..415c5e3a --- /dev/null +++ b/sources/BREAK-AND-TRACE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM") (IL:FILECREATED "16-May-90 12:12:42" IL:|{DSK}local>lde>lispcore>sources>BREAK-AND-TRACE.;2| 38319 IL:|changes| IL:|to:| (IL:VARS IL:BREAK-AND-TRACECOMS) IL:|previous| IL:|date:| "12-Jul-88 18:49:08" IL:|{DSK}local>lde>lispcore>sources>BREAK-AND-TRACE.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS) (IL:RPAQQ IL:BREAK-AND-TRACECOMS ( (IL:* IL:|;;;| "Support for tracing.") (IL:VARIABLES XCL:*TRACE-DEPTH* XCL::*TRACED-FNS* IL:TRACEREGION) (IL:FUNCTIONS XCL:CREATE-TRACE-WINDOW) (IL:FUNCTIONS CREATE-TRACED-DEFINITION CONSTRUCT-ENTRY-PRINTING-CODE PRINT-TRACE-ENTRY-INFO PRINT-TRACE-EXIT-INFO PRINT-TRACED-ARGUMENT PRINT-TRACED-CL-ARGLIST) (IL:VARIABLES XCL:*TRACE-LEVEL* XCL:*TRACE-LENGTH* XCL:*TRACE-VERBOSE* *TRACE-OUTPUT*) (IL:FNS TRACE UNTRACE) (IL:FUNCTIONS XCL:TRACE-FUNCTION) (IL:* IL:|;;;| "Support for breaking.") (IL:FUNCTIONS XCL:BREAK-FUNCTION XCL:UNBREAK-FUNCTION XCL:REBREAK-FUNCTION CREATE-BROKEN-DEFINITION UNBREAK-FROM-RESTORE-CALLS FINISH-UNBREAKING) (IL:VARIABLES IL:BROKENFNS XCL::*BREAK-HASH-TABLE* XCL::*UNBROKEN-FNS*) (IL:PROP IL:PROPTYPE IL:BROKEN) (IL:* IL:|;;| "The old Interlisp interface to breaking.") (IL:FNS IL:BREAK IL:BREAK0 IL:REBREAK XCL:UNBREAK IL:UNBREAK0) (IL:FNS IL:BREAK1) (IL:SPECIAL-FORMS IL:BREAK1) (XCL:OPTIMIZERS IL:BREAK1) (IL:* IL:|;;| "Arrange for the proper compiler and package") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:BREAK-AND-TRACE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE) (IL:NLAML IL:BREAK1) (IL:LAMA))))) (IL:* IL:|;;;| "Support for tracing.") (DEFVAR XCL:*TRACE-DEPTH* 0) (DEFVAR XCL::*TRACED-FNS* NIL (IL:* IL:|;;;| "A subset of the entries on IL:BROKENFNS, being those that resulted from calls to TRACE as opposed to calls to BREAK-FUNCTION.") ) (DEFVAR IL:TRACEREGION (IL:|create| IL:REGION IL:LEFT IL:_ 8 IL:BOTTOM IL:_ 3 IL:WIDTH IL:_ 547 IL:HEIGHT IL:_ 310)) (DEFUN XCL:CREATE-TRACE-WINDOW (&KEY (XCL::REGION IL:TRACEREGION) (XCL::OPEN? NIL) (XCL::TITLE "*Trace-Output*")) (IL:* IL:|;;;| "Create and return a window suitable for use as the value of *TRACE-OUTPUT*.") (IL:* IL:|;;;| "REGION is the initial region of the window. It defaults to the value of IL:TRACEREGION.") (IL:* IL:|;;;| "OPEN? is true if the newly-created window should be opened on the screen immediately. If false, the window will open the first time any output is sent to it.") (LET ((XCL::WINDOW (IL:CREATEW XCL::REGION XCL::TITLE NIL (NOT XCL::OPEN?)))) (IL:DSPSCROLL 'IL:ON XCL::WINDOW) XCL::WINDOW)) (DEFUN CREATE-TRACED-DEFINITION (TRACED-FN IN-FN FN-TO-CALL) (MULTIPLE-VALUE-BIND (LAMBDA-CAR ARG-LIST CALLING-FORM) (FUNCTION-WRAPPER-INFO TRACED-FN FN-TO-CALL) `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA) '(&REST XCL:ARGLIST) ARG-LIST) ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA)) `((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST) (LIST ARG-LIST) ARG-LIST))))) (IL:\\CALLME '(:TRACED ,(IF (NULL IN-FN) TRACED-FN `(,TRACED-FN :IN ,IN-FN)))) (LET* (($THE-REAL-TRACE-OUTPUT$ (XCL:FOLLOW-SYNONYM-STREAMS (IL:\\GETSTREAM *TRACE-OUTPUT*))) ($IMAGE-STREAM?$ (IL:IMAGESTREAMP $THE-REAL-TRACE-OUTPUT$))) (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$) (IL:FONTCHANGEFLG $IMAGE-STREAM?$)) (DECLARE (SPECIAL IL:FONTCHANGEFLG)) ,@(CONSTRUCT-ENTRY-PRINTING-CODE TRACED-FN IN-FN LAMBDA-CAR ARG-LIST)) (LET (($TRACED-FN-VALUES$ (MULTIPLE-VALUE-LIST (LET ((XCL:*TRACE-DEPTH* (1+ XCL:*TRACE-DEPTH*))) ,CALLING-FORM)))) (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$) (IL:FONTCHANGEFLG $IMAGE-STREAM?$)) (DECLARE (SPECIAL IL:FONTCHANGEFLG)) (PRINT-TRACE-EXIT-INFO ',TRACED-FN ',IN-FN $TRACED-FN-VALUES$)) (VALUES-LIST $TRACED-FN-VALUES$)))))) (DEFUN CONSTRUCT-ENTRY-PRINTING-CODE (TRACED-FN IN-FN LAMBDA-CAR ARG-LIST) `((PRINT-TRACE-ENTRY-INFO ',TRACED-FN ',IN-FN) (LET ((*PRINT-LEVEL* XCL:*TRACE-LEVEL*) (*PRINT-LENGTH* XCL:*TRACE-LENGTH*)) ,@(CASE LAMBDA-CAR ((IL:LAMBDA IL:NLAMBDA) (IL:IF (LISTP ARG-LIST) IL:THEN (IL:* IL:|;;|  "Interlisp spread function. The ARG-LIST is, in fact, a list of argument names.") `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4)))) ,@(IL:FOR VAR IL:IN ARG-LIST IL:COLLECT `(PRINT-TRACED-ARGUMENT ',VAR ,VAR $$INDENT$$)))) IL:ELSEIF (EQ LAMBDA-CAR 'IL:LAMBDA) IL:THEN (IL:* IL:|;;|  "Interlisp Lambda no-spread function. Print out at most *TRACE-LENGTH* arguments.") `((IL:BIND ($$INDENT$$ IL:_ (+ 10 (* XCL:*TRACE-DEPTH* 4))) IL:FOR $ARG-COUNTER$ IL:FROM 1 IL:TO (IF (NULL XCL:*TRACE-LENGTH*) ,ARG-LIST (MIN XCL:*TRACE-LENGTH* ,ARG-LIST)) IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ (IL:ARG ,ARG-LIST $ARG-COUNTER$) $$INDENT$$))) IL:ELSE (IL:* IL:|;;| "Interlisp NLambda no-spread function. Print out at most *TRACE-LENGTH* arguments. Also, be careful to check that the argument list is really a list.") `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4)))) (IF (LISTP ,ARG-LIST) (IL:FOR $ARGUMENT$ IL:IN ,ARG-LIST IL:AS $ARG-COUNTER$ IL:FROM 1 IL:WHILE (OR (NULL XCL:*TRACE-LENGTH*) (<= $ARG-COUNTER$ XCL:*TRACE-LENGTH*)) IL:DO (PRINT-TRACED-ARGUMENT $ARG-COUNTER$ $ARGUMENT$ $$INDENT$$)) (PRINT-TRACED-ARGUMENT ',ARG-LIST ,ARG-LIST $$INDENT$$)))))) ((LAMBDA) (IL:* IL:|;;| "A Common Lisp function.") (MULTIPLE-VALUE-BIND (REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS) (PARSE-CL-ARGLIST ARG-LIST) `((PRINT-TRACED-CL-ARGLIST XCL:ARGLIST ',REQUIRED ',OPTIONAL ',REST ',KEY ,KEY-APPEARED? ,ALLOW-OTHER-KEYS (+ 8 (* XCL:*TRACE-DEPTH* 4)) XCL:*TRACE-VERBOSE*)))))))) (DEFUN PRINT-TRACE-ENTRY-INFO (TRACED-FN IN-FN) (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT)) (IL:SPACES (* XCL:*TRACE-DEPTH* 4)) (PRINC (1+ XCL:*TRACE-DEPTH*)) (PRINC " - Enter ") (IL:CHANGEFONT IL:BOLDFONT) (PRIN1 TRACED-FN) (IL:CHANGEFONT IL:DEFAULTFONT) (WHEN (NOT (NULL IN-FN)) (PRINC " in ") (IL:CHANGEFONT IL:BOLDFONT) (PRIN1 IN-FN) (IL:CHANGEFONT IL:DEFAULTFONT)) (PRINC ":") (TERPRI)) (DEFUN PRINT-TRACE-EXIT-INFO (TRACED-FN IN-FN FN-VALUES) (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT)) (IL:SPACES (* XCL:*TRACE-DEPTH* 4)) (PRINC (1+ XCL:*TRACE-DEPTH*)) (PRINC " - Exit ") (IL:CHANGEFONT IL:BOLDFONT) (PRIN1 TRACED-FN) (IL:CHANGEFONT IL:DEFAULTFONT) (WHEN (NOT (NULL IN-FN)) (PRINC " in ") (IL:CHANGEFONT IL:BOLDFONT) (PRIN1 IN-FN) (IL:CHANGEFONT IL:DEFAULTFONT)) (PRINC " =>") (TERPRI) (IL:FOR VALUE IL:IN FN-VALUES IL:DO (IL:SPACES (+ 10 (* XCL:*TRACE-DEPTH* 4))) (PRIN1 VALUE) (TERPRI))) (DEFUN PRINT-TRACED-ARGUMENT (NAME VALUE INDENT &OPTIONAL PRIN1-THE-NAME?) (IL:SPACES INDENT) (WHEN (TYPEP NAME 'FIXNUM) (PRINC "Arg ")) (IF PRIN1-THE-NAME? (PRIN1 NAME) (PRINC NAME)) (PRINC " = ") (PRIN1 VALUE) (TERPRI)) (DEFUN PRINT-TRACED-CL-ARGLIST (ARGS REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS SMALL-INDENT VERBOSE?) (DECLARE (SPECIAL IL:BOLDFONT IL:DEFAULTFONT)) (LET* ((INDENT (+ SMALL-INDENT 2))) (WHEN REQUIRED (IL:FOR VAR IL:IN REQUIRED IL:DO (COND ((NULL ARGS) (IL:SPACES INDENT) (PRINC VAR) (IL:CHANGEFONT IL:BOLDFONT) (PRINC " ** NOT SUPPLIED **") (IL:CHANGEFONT IL:DEFAULTFONT) (TERPRI)) (T (PRINT-TRACED-ARGUMENT VAR (POP ARGS) INDENT))))) (WHEN OPTIONAL (WHEN VERBOSE? (IL:SPACES SMALL-INDENT) (PRINC '&OPTIONAL) (TERPRI)) (IL:FOR VAR IL:IN OPTIONAL IL:DO (IF (NULL ARGS) (WHEN VERBOSE? (IL:SPACES INDENT) (PRINC VAR) (PRINC " not supplied") (TERPRI)) (PRINT-TRACED-ARGUMENT VAR (POP ARGS) INDENT)))) (WHEN REST (WHEN VERBOSE? (IL:SPACES SMALL-INDENT) (PRINC '&REST) (TERPRI)) (PRINT-TRACED-ARGUMENT REST ARGS INDENT)) (WHEN KEY (WHEN VERBOSE? (IL:SPACES SMALL-INDENT) (PRINC '&KEY) (TERPRI)) (IL:FOR VAR IL:IN KEY IL:DO (IL:FOR TAIL IL:ON ARGS IL:BY CDDR IL:DO (WHEN (EQ VAR (CAR TAIL)) (PRINT-TRACED-ARGUMENT VAR (CADR TAIL) INDENT T) (RETURN))))) (WHEN KEY-APPEARED? (LET (TEMP) (COND ((ODDP (LENGTH ARGS)) (IL:SPACES SMALL-INDENT) (IL:CHANGEFONT IL:BOLDFONT) (PRINC "** Odd-length &KEY argument list: **") (IL:CHANGEFONT IL:DEFAULTFONT) (TERPRI) (IL:SPACES INDENT) (PRIN1 ARGS) (TERPRI)) ((SETQ TEMP (IL:FIND KEYWORD IL:IN ARGS IL:BY (CDDR KEYWORD) IL:SUCHTHAT (IF ALLOW-OTHER-KEYS (NOT (KEYWORDP KEYWORD)) (NOT (MEMBER KEYWORD KEY :TEST 'EQ))))) (IL:SPACES SMALL-INDENT) (IL:CHANGEFONT IL:BOLDFONT) (PRINC "** Illegal &KEY argument: **") (IL:CHANGEFONT IL:DEFAULTFONT) (TERPRI) (IL:SPACES INDENT) (PRIN1 TEMP) (TERPRI))))) (WHEN (AND (NOT REST) (NOT KEY-APPEARED?) (NOT (NULL ARGS))) (IL:SPACES SMALL-INDENT) (IL:CHANGEFONT IL:BOLDFONT) (PRINC "** Extra arguments: **") (IL:CHANGEFONT IL:DEFAULTFONT) (TERPRI) (IL:SPACES INDENT) (PRIN1 ARGS) (TERPRI)))) (DEFVAR XCL:*TRACE-LEVEL* NIL (IL:* IL:|;;;| "What to bind *PRINT-LEVEL* to when printing argument values in TRACE output.") ) (DEFVAR XCL:*TRACE-LENGTH* NIL (IL:* IL:|;;;| "What to bind *PRINT-LENGTH* to during the printing of argument values in TRACE output. Also controls the number of arguments to no-spread functions that will be printed.") ) (DEFVAR XCL:*TRACE-VERBOSE* T (IL:* IL:|;;;| "Controls whether or not various parts of TRACE output are printed:") (IL:* IL:|;;| "The lambda-list keywords &OPTIONAL, &REST, and &KEY.") (IL:* IL:|;;| "Trailing unsupplied &OPTIONAL arguments.") ) (DEFVAR *TRACE-OUTPUT* (XCL:CREATE-TRACE-WINDOW)) (IL:DEFINEQ (trace (il:nlambda cl::fns (il:* il:\; "Edited 2-Apr-87 16:10 by Pavel") (setq cl::fns (il:nlambda.args cl::fns)) (if (null cl::fns) xcl::*traced-fns* (il:for cl::fn il:in cl::fns il:join (if (consp cl::fn) (xcl:trace-function (first cl::fn) :in (third cl::fn)) (xcl:trace-function cl::fn)))))) (untrace (il:nlambda cl::fns (il:* il:\; "Edited 2-Apr-87 16:39 by Pavel") (setq cl::fns (il:nlambda.args cl::fns)) (flet ((cl::untrace-entry (cl::entry) (if (consp cl::entry) (xcl:unbreak-function (first cl::entry) :in (second cl::entry)) (xcl:unbreak-function cl::entry)))) (cond ((null cl::fns) (il:for cl::entry il:in (reverse xcl::*traced-fns*) il:join (cl::untrace-entry cl::entry))) ((equal cl::fns '(t)) (when xcl::*traced-fns* (cl::untrace-entry (car xcl::*traced-fns*)))) (t (il:for cl::fn il:in cl::fns il:join (if (consp cl::fn) (xcl:unbreak-function (first cl::fn) :in (third cl::fn)) (xcl:unbreak-function cl::fn)))))))) ) (DEFUN XCL:TRACE-FUNCTION (XCL::FN-TO-TRACE &KEY ((:IN XCL::IN-FN)) XCL::REBREAK?) (COND ((CONSP XCL::FN-TO-TRACE) (IL:FOR XCL::FN IL:IN XCL::FN-TO-TRACE IL:JOIN (XCL:TRACE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:TRACE-FUNCTION XCL::FN-TO-TRACE :IN XCL::FN))) ((NULL (IL:GETD XCL::FN-TO-TRACE)) (ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-TRACE) NIL) ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-TRACE "trace") (FORMAT *ERROR-OUTPUT* "~S not traced.~%" XCL::FN-TO-TRACE) NIL) (T (XCL:UNBREAK-FUNCTION XCL::FN-TO-TRACE :IN XCL::IN-FN :NO-ERROR T) (UNLESS XCL::REBREAK? (IL:* IL:\; "Save the breaking information for REBREAK, but don't save it if we're being called from REBREAK itself.") (SETF (GETHASH (IF (NULL XCL::IN-FN) XCL::FN-TO-TRACE `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN)) XCL::*BREAK-HASH-TABLE*) (LIST XCL::FN-TO-TRACE :IN XCL::IN-FN :TRACE? T :REBREAK? T))) (IF (NULL XCL::IN-FN) (LET ((XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE)) (MAKE-SYMBOL (FORMAT NIL "Original ~A" XCL::FN-TO-TRACE))))) (IL:PUTD XCL::ORIGINAL (IL:GETD XCL::FN-TO-TRACE) T) (IL:PUTD XCL::FN-TO-TRACE (COMPILE NIL (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE NIL XCL::ORIGINAL)) T) (SETF (GET XCL::FN-TO-TRACE 'IL:BROKEN) XCL::ORIGINAL) (PUSH XCL::FN-TO-TRACE IL:BROKENFNS) (PUSH XCL::FN-TO-TRACE XCL::*TRACED-FNS*) (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-TRACE XCL::*UNBROKEN-FNS*)) (LIST XCL::FN-TO-TRACE)) (LET ((XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::FN-TO-TRACE XCL::IN-FN))) (IF (NOT (HAS-CALLS XCL::IN-FN XCL::FN-TO-TRACE)) (ERROR "~S is not called from ~S." XCL::FN-TO-TRACE XCL::IN-FN)) (COMPILE XCL::MIDDLE-MAN (CREATE-TRACED-DEFINITION XCL::FN-TO-TRACE XCL::IN-FN XCL::FN-TO-TRACE)) (CHANGE-CALLS XCL::FN-TO-TRACE XCL::MIDDLE-MAN XCL::IN-FN 'UNBREAK-FROM-RESTORE-CALLS) (LET ((XCL::ENTRY (LIST XCL::FN-TO-TRACE XCL::IN-FN XCL::MIDDLE-MAN))) (PUSH XCL::ENTRY IL:BROKENFNS) (PUSH XCL::ENTRY XCL::*TRACED-FNS*)) (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN) XCL::*UNBROKEN-FNS* :TEST 'EQUAL)) (LIST `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN))))))) (IL:* IL:|;;;| "Support for breaking.") (DEFUN XCL:BREAK-FUNCTION (XCL::FN-TO-BREAK &KEY ((:IN XCL::IN-FN)) ((:WHEN XCL::WHEN-EXPR) T) XCL::TRACE? XCL::REBREAK?) (COND (XCL::TRACE? (XCL:TRACE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :REBREAK? XCL::REBREAK?)) ((CONSP XCL::FN-TO-BREAK) (IL:FOR XCL::FN IL:IN XCL::FN-TO-BREAK IL:JOIN (XCL:BREAK-FUNCTION XCL::FN :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK? XCL::REBREAK?))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:BREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::FN :WHEN XCL::WHEN-EXPR :REBREAK? XCL::REBREAK?))) ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-BREAK "break") (FORMAT *ERROR-OUTPUT* "~S not broken." XCL::FN-TO-BREAK) NIL) (T (UNLESS XCL::REBREAK? (IL:* IL:\; "Save the breaking information for REBREAK. Don't do it, though, if we're being called from REBREAK.") (SETF (GETHASH (IF (NULL XCL::IN-FN) XCL::FN-TO-BREAK `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN)) XCL::*BREAK-HASH-TABLE*) (LIST XCL::FN-TO-BREAK :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK? T))) (WHEN (EQ XCL::WHEN-EXPR :ONCE) (SETQ XCL::WHEN-EXPR `(FUNCALL ',(LET ((XCL::TRIGGERED-YET? NIL)) #'(LAMBDA NIL (IF XCL::TRIGGERED-YET? NIL (SETQ XCL::TRIGGERED-YET? T))))))) (XCL:UNBREAK-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T) (IF (NULL XCL::IN-FN) (LET* ((XCL::ORIGINAL-DEF (OR (IL:GETD XCL::FN-TO-BREAK) (ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-BREAK))) (XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE)) (MAKE-SYMBOL (FORMAT NIL "Original ~A" XCL::FN-TO-BREAK))))) (IL:PUTD XCL::ORIGINAL XCL::ORIGINAL-DEF T) (IL:PUTD XCL::FN-TO-BREAK (COMPILE NIL (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK XCL::FN-TO-BREAK XCL::ORIGINAL XCL::WHEN-EXPR XCL::FN-TO-BREAK)) T) (SETF (GET XCL::FN-TO-BREAK 'IL:BROKEN) XCL::ORIGINAL) (PUSH XCL::FN-TO-BREAK IL:BROKENFNS) (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-BREAK XCL::*UNBROKEN-FNS*)) (LIST XCL::FN-TO-BREAK)) (LET ((XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::FN-TO-BREAK XCL::IN-FN))) (IF (NOT (HAS-CALLS XCL::IN-FN XCL::FN-TO-BREAK)) (ERROR "~S is not called from ~S." XCL::FN-TO-BREAK XCL::IN-FN)) (XCL:UNADVISE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T) (COMPILE XCL::MIDDLE-MAN (CREATE-BROKEN-DEFINITION XCL::FN-TO-BREAK XCL::MIDDLE-MAN XCL::FN-TO-BREAK XCL::WHEN-EXPR `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN))) (CHANGE-CALLS XCL::FN-TO-BREAK XCL::MIDDLE-MAN XCL::IN-FN 'UNBREAK-FROM-RESTORE-CALLS) (PUSH (LIST XCL::FN-TO-BREAK XCL::IN-FN XCL::MIDDLE-MAN) IL:BROKENFNS) (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN) XCL::*UNBROKEN-FNS* :TEST 'EQUAL)) (LIST `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN))))))) (DEFUN XCL:UNBREAK-FUNCTION (XCL::BROKEN-FN &KEY ((:IN XCL::IN-FN)) XCL::NO-ERROR) (COND ((CONSP XCL::BROKEN-FN) (IL:FOR XCL::FN IL:IN XCL::BROKEN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::FN :IN XCL::IN-FN))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNBREAK-FUNCTION XCL::BROKEN-FN :IN XCL::FN))) ((NULL XCL::IN-FN) (LET ((XCL::ORIGINAL (GET XCL::BROKEN-FN 'IL:BROKEN))) (COND ((NULL XCL::ORIGINAL) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not broken.~%" XCL::BROKEN-FN)) NIL) (T (IL:PUTD XCL::BROKEN-FN (IL:GETD XCL::ORIGINAL) T) (REMPROP XCL::BROKEN-FN 'IL:BROKEN) (SETQ IL:BROKENFNS (DELETE XCL::BROKEN-FN IL:BROKENFNS)) (SETQ XCL::*TRACED-FNS* (DELETE XCL::BROKEN-FN XCL::*TRACED-FNS*)) (PUSH XCL::BROKEN-FN XCL::*UNBROKEN-FNS*) (LIST XCL::BROKEN-FN))))) (T (LET* ((XCL::ENTRY (FIND-IF #'(LAMBDA (XCL::ENTRY) (AND (CONSP XCL::ENTRY) (EQ (FIRST XCL::ENTRY) XCL::BROKEN-FN) (EQ (SECOND XCL::ENTRY) XCL::IN-FN))) IL:BROKENFNS)) (XCL::MIDDLE-MAN (THIRD XCL::ENTRY))) (COND ((NULL XCL::ENTRY) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S :IN ~S is not broken.~%" XCL::BROKEN-FN XCL::IN-FN)) NIL) (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::BROKEN-FN XCL::IN-FN) (FINISH-UNBREAKING XCL::BROKEN-FN XCL::IN-FN XCL::MIDDLE-MAN XCL::ENTRY) (LIST `(,XCL::BROKEN-FN :IN ,XCL::IN-FN)))))))) (DEFUN XCL:REBREAK-FUNCTION (XCL::FN-TO-REBREAK &KEY ((:IN XCL::IN-FN))) (COND ((CONSP XCL::FN-TO-REBREAK) (IL:FOR XCL::FN IL:IN XCL::FN-TO-REBREAK IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN :IN XCL::IN-FN))) ((CONSP XCL::IN-FN) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:REBREAK-FUNCTION XCL::FN-TO-REBREAK :IN XCL::FN))) (T (LET* ((XCL::NAME (IF (NULL XCL::IN-FN) XCL::FN-TO-REBREAK `(,XCL::FN-TO-REBREAK :IN ,XCL::IN-FN))) (XCL::INFO (GETHASH XCL::NAME XCL::*BREAK-HASH-TABLE*))) (COND ((NULL XCL::INFO) (FORMAT *ERROR-OUTPUT* "~S has never been broken.~%" XCL::NAME) NIL) (T (APPLY 'XCL:BREAK-FUNCTION XCL::INFO))))))) (DEFUN CREATE-BROKEN-DEFINITION (WRAPPED-FN-NAME BROKEN-FN-NAME FN-TO-CALL WHEN-EXPR BREAKPOINT-NAME) (IL:* IL:|;;;| "WRAPPED-FN-NAME must be the symbol naming the function that will break when it is called.") (IL:* IL:|;;;| "BROKEN-FN-NAME is the symbol in whose function cell our lambda-form will be put.") (IL:* IL:|;;;| "FN-TO-CALL is the function-object to be FUNCALL'ed when we want to call the unbroken version of the wrapped function.") (IL:* IL:|;;;| "BREAKPOINT-NAME is the value the debugger will use for BRKFN.") (IL:* IL:|;;;| "We return a lambda-form suitable for being called in order to (possibly) activate the breakpoint.") (MULTIPLE-VALUE-BIND (LAMBDA-CAR ARG-LIST CALLING-FORM) (FUNCTION-WRAPPER-INFO WRAPPED-FN-NAME FN-TO-CALL) `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA) '(&REST XCL:ARGLIST) ARG-LIST) ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA)) `((DECLARE (SPECIAL ,@(IF (SYMBOLP ARG-LIST) (LIST ARG-LIST) ARG-LIST))))) (IL:\\CALLME '(:BROKEN ,BREAKPOINT-NAME)) (IF ,WHEN-EXPR (LET (($POS$ (IL:STKNTH -1))) (UNWIND-PROTECT (XCL:DEBUGGER :FORM `(FUNCALL ',#'(LAMBDA NIL ,CALLING-FORM)) :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION ',(XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION BREAKPOINT-NAME)) (IL:RELSTK $POS$))) ,CALLING-FORM)))) (DEFUN UNBREAK-FROM-RESTORE-CALLS (FROM TO FN) (IL:* IL:|;;;| "Somebody has restored all of the changed calls in FN, including one we made, changing calls to FROM into calls to TO. This came about from breaking (FROM :IN FN), where TO was the middle-man. Undo that breaking.") (LET ((ENTRY (FIND-IF #'(LAMBDA (ENTRY) (AND (CONSP ENTRY) (EQ (FIRST ENTRY) FROM) (EQ (SECOND ENTRY) FN))) IL:BROKENFNS))) (ASSERT (EQ TO (THIRD ENTRY)) NIL "BUG: Inconsistency in SI::UNBREAK-FROM-RESTORE-CALLS") (FINISH-UNBREAKING FROM FN TO ENTRY) (FORMAT *TERMINAL-IO* "(~S :IN ~S) unbroken.~%" FROM FN))) (DEFUN FINISH-UNBREAKING (BROKEN-FN IN-FN MIDDLE-MAN ENTRY) (SETQ IL:BROKENFNS (DELETE ENTRY IL:BROKENFNS)) (SETQ XCL::*TRACED-FNS* (DELETE ENTRY XCL::*TRACED-FNS*)) (PUSH `(,BROKEN-FN :IN ,IN-FN) XCL::*UNBROKEN-FNS*)) (DEFVAR IL:BROKENFNS NIL) (DEFVAR XCL::*BREAK-HASH-TABLE* (MAKE-HASH-TABLE :TEST 'EQUAL)) (DEFVAR XCL::*UNBROKEN-FNS* NIL) (IL:PUTPROPS IL:BROKEN IL:PROPTYPE IGNORE) (IL:* IL:|;;| "The old Interlisp interface to breaking.") (IL:DEFINEQ (il:break (il:nlambda il:x (il:* il:\; "Edited 13-Apr-87 13:51 by Pavel") (il:for il:x il:in (il:nlambda.args il:x) il:join (il:if (or (il:litatom il:x) (il:string.equal (cadr il:x) "IN")) il:then (il:break0 il:x t) il:else (il:apply 'il:break0 il:x))))) (il:break0 (il:lambda (il:fn il:when il:coms il:brkfn) (il:* il:\; "Edited 18-Apr-87 18:56 by Pavel") (when il:coms (cerror "Ignore COMS" "Break 'commands' ~S no longer supported." il:coms)) (when (and il:brkfn (il:neq il:brkfn 'il:break1)) (cerror "Ignore BRKFN" "Unexpected BRKFN passed to BREAK0: ~S" il:brkfn)) (when (null il:when) (il:setq il:when t)) (cond ((il:listp il:fn) (cond ((il:string.equal (second il:fn) "IN") (xcl:break-function (first il:fn) :in (third il:fn) :when il:when)) (t (il:for il:x il:in il:fn il:join (il:break0 il:x il:when))))) (t (xcl:break-function il:fn :when il:when))))) (il:rebreak (il:nlambda il:fns (il:* il:\; "Edited 3-Apr-87 12:07 by Pavel") (il:setq il:fns (il:nlambda.args il:fns)) (flet ((il:rebreak-fn (il:fn) (il:if (il:listp il:fn) il:then (xcl:rebreak-function (first il:fn) :in (third il:fn)) il:else (xcl:rebreak-function il:fn)))) (cond ((null il:fns) (il:for il:fn il:in xcl::*unbroken-fns* il:join (il:rebreak-fn il:fn))) ((il:equal il:fns '(t)) (and (not (null xcl::*unbroken-fns*)) (il:rebreak-fn (car xcl::*unbroken-fns*)))) (t (il:for il:fn il:in il:fns il:join (il:rebreak-fn il:fn))))))) (xcl:unbreak (il:nlambda xcl::fns (il:* il:\; "Edited 2-Apr-87 16:39 by Pavel") (setq xcl::fns (il:nlambda.args xcl::fns)) (flet ((xcl::unbreak-entry (xcl::entry) (if (consp xcl::entry) (xcl:unbreak-function (first xcl::entry) :in (second xcl::entry)) (xcl:unbreak-function xcl::entry)))) (cond ((null xcl::fns) (il:for xcl::entry il:in (reverse il:brokenfns) il:join (xcl::unbreak-entry xcl::entry) )) ((equal xcl::fns '(t)) (when il:brokenfns (xcl::unbreak-entry (car il:brokenfns)))) (t (il:for xcl::fn il:in xcl::fns il:join (if (consp xcl::fn) (xcl:unbreak-function (first xcl::fn) :in (third xcl::fn)) (xcl:unbreak-function xcl::fn)))))))) (il:unbreak0 (il:lambda (il:fn) (il:* il:\; "Edited 1-Apr-87 22:12 by Pavel") (il:if (il:listp il:fn) il:then (xcl:unbreak-function (car il:fn) :in (caddr il:fn)) il:else (xcl:unbreak-function il:fn)))) ) (IL:DEFINEQ (il:break1 (il:nlambda (il:brkexp il:brkwhen il:brkfn il:brkcoms il:brktype xcl:condition) (il:* il:\; "Edited 24-Mar-87 16:07 by amd") (il:|if| (eval il:brkwhen) il:|then| (il:* il:|;;|  "should probably default CONDITION depending on BRKTYPE to interrupt, breakpoint error, etc.") (when il:brkcoms (il:printout t "BRKCOMS no longer supported:" il:brkcoms t)) (let ((il:pos (il:stknth 0 il:brkfn))) (unwind-protect (xcl:debugger :form il:brkexp :environment nil :stack-position il:pos :condition (or xcl:condition (xcl:make-condition 'breakpoint :function il:brkfn))) (il:relstk il:pos))) il:|else| (eval il:brkexp)))) ) (XCL:DEFINE-SPECIAL-FORM IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION &ENVIRONMENT IL:ENV) (IL:IF (EVAL IL:WHEN IL:ENV) IL:THEN (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T)) (LET ((IL:POS (IL:STKNTH 0 IL:FN))) (UNWIND-PROTECT (XCL:DEBUGGER :FORM IL:EXP :ENVIRONMENT IL:ENV :STACK-POSITION IL:POS :CONDITION (OR XCL:CONDITION (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION IL:FN))) (IL:RELSTK IL:POS))) IL:ELSE (EVAL IL:EXP IL:ENV))) (XCL:DEFOPTIMIZER IL:BREAK1 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION) (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T )) `(FLET (($BRKEXP$ NIL ,IL:EXP)) (IL:IF ,IL:WHEN IL:THEN (LET (($POS$ (IL:STKNTH 0 ',IL:FN))) (UNWIND-PROTECT (XCL:DEBUGGER :FORM `(FUNCALL ',#'$BRKEXP$) :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION ,(OR XCL:CONDITION `(IL:LOADTIMECONSTANT (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION ',IL:FN)))) (IL:RELSTK $POS$))) IL:ELSE ($BRKEXP$)))) (IL:* IL:|;;| "Arrange for the proper compiler and package") (IL:PUTPROPS IL:BREAK-AND-TRACE IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:BREAK-AND-TRACE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE) (IL:ADDTOVAR IL:NLAML IL:BREAK1) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:BREAK-AND-TRACE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (15387 17225 (TRACE 15400 . 15987) (UNTRACE 15989 . 17223)) (30814 34614 (IL:BREAK 30827 . 31413) (IL:BREAK0 31415 . 32227) (IL:REBREAK 32229 . 33091) (XCL:UNBREAK 33093 . 34284) ( IL:UNBREAK0 34286 . 34612)) (34615 35663 (IL:BREAK1 34628 . 35661))))) IL:STOP \ No newline at end of file diff --git a/sources/BRKDWN b/sources/BRKDWN new file mode 100644 index 00000000..3e9689c1 --- /dev/null +++ b/sources/BRKDWN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 12:14:36" {DSK}local>lde>lispcore>sources>BRKDWN.;2 25376 changes to%: (VARS BRKDWNCOMS) previous date%: "23-Oct-86 21:37:08" {DSK}local>lde>lispcore>sources>BRKDWN.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT BRKDWNCOMS) (RPAQQ BRKDWNCOMS [(DECLARE%: FIRST (ADDVARS (NOSWAPFNS BRKDWN2))) (FNS BREAKDOWN BRKDWNINIT BRKDWNSETUP BRKDWN1 BRKDWNFORM BRKDWNCOMPILE2 BRKDWNTIME BRKDWNCONSES BRKDWNBOXES BRKDWNFBOXES RESULTS BRKDWNRESULTS BRKDWNRESULTS1 BRKDWNRESULTS2 BRKDWNCLEAR) (DECLARE%: EVAL@COMPILE (MACROS BRKDWNMACRO BRKDWNINCA) (MACROS BRKDWNADDTOA BRKDWNDIFFA CPUTIME IBOXCOUNT FBOXCOUNT BRKDWNELT BRKDWNSETA BRKDWNARRAY)) [VARS (BRKDWNLENGTH 0) (BRKDWNCOMPFLG NIL) BRKDWNARGS BRKDWNTYPES (BRKDWNFLTFMT (NUMFORMATCODE '(FLOAT 7 3 NIL NIL 10] (VARS (BRKDWNTYPE 'TIME) (BRKDWNLABELS) (BRKDWNLST)) (GLOBALVARS BRKDWNARGS BRKDWNLABELS BRKDWNLENGTH BRKDWNLST BRKDWNTOTLST BDLST BDSINK BDPTR) (BLOCKS (NIL BRKDWNTIME BRKDWNCONSES BRKDWNBOXES (LINKFNS . T)) (BREAKDOWN BREAKDOWN BRKDWNSETUP BRKDWN1 BRKDWNFORM BRKDWNCOMPILE2 (GLOBALVARS NOSWAPFLG)) (BRKDWNRESULTS BRKDWNRESULTS BRKDWNRESULTS1 BRKDWNRESULTS2)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA BREAKDOWN) (NLAML BRKDWNFBOXES BRKDWNBOXES BRKDWNCONSES BRKDWNTIME) (LAMA]) (DECLARE%: FIRST (ADDTOVAR NOSWAPFNS BRKDWN2) ) (DEFINEQ (BREAKDOWN (NLAMBDA FNS (* lmm "14-Aug-84 19:18") (SETQ FNS (NLAMBDA.ARGS FNS)) (BRKDWNINIT) (SETQ BRKDWNLST (SUBSET BRKDWNLST (FUNCTION (LAMBDA (X) (PROG ((DEF (GETD (CAR X)))) (* This enables both adding to and subtracting from the BREAKDOWN list.  If functions originally on BRKDWNLST are still broken, they are kept.  Then the new functions are added. The second alternative in the OR is for  functions with open-coded BRKDWN2.) (RETURN (AND (OR (AND (EXPRP DEF) (EQ (CAADDR DEF) 'BRKDWN2)) (AND DEF (EQP DEF (CADDDR X)))) (NOT (MEMB (CAR X) FNS))))))))) (COND (BRKDWNTYPE (* BRKDWN1 initializes BRKDWNLABELS and BRKDWNLENGTH and compiles a measuring  function, when necessary, for the measurement indicated by BRKDWNTYPE.  BRKDWNTYPE is initially set to TIME.) (BRKDWN1))) (CONSCOUNT 0) (BRKDWNCLEAR BDLST (ADD1 BRKDWNLENGTH)) (* BDLST is initialized to point to the first cell of an unboxed array and is  used for storing the last values of the statistics to be measured.  BDSINK is a dummy array for accumulating values not charged to any function.) (SETQ BDPTR BDSINK) (COND (FNS (PROG ((N 1)) (for X in FNS do (if (NUMBERP X) then (SETQ N X) NIL else (for X in (BREAK0 X T NIL 'BRKDWN2) do (if (LISTP X) then (PRINT X T T) else (* BRKDWNSETUP returns a list of the form  (PTR N) or (PTR N CODE DEF) which becomes an element of BRKDWNLST after adding  FN in front.) (SETQ BRKDWNLST (NCONC1 BRKDWNLST (CONS X (BRKDWNSETUP X (GETD X) (BRKDWNARRAY (ADD1 BRKDWNLENGTH )) N))))))))))) (MAPC BRKDWNLST (FUNCTION (LAMBDA (FNS) (BRKDWNCLEAR (CADR FNS) (ADD1 BRKDWNLENGTH))))) (* If a completely new BREAKDOWN was done, this isn't really necessary, but it  may have been just an additive BREAKDOWN, so counters for old functions should  be zeroed. Note that BREAKDOWN of NIL just zeroes counters without unbreaking  any functions. Note also that BRKDWNTYPE can be changed without unbreaking and  rebreaking, since redefining the function BRKDWN2 will take care of everything,  except that if more things are being measured, the statistic arrays must all be  lengthened (BRKDWN1 takes care of this.)) (MAPCAR BRKDWNLST (FUNCTION CAR)))) (BRKDWNINIT (LAMBDA NIL (* lmm "14-MAR-80 09:04") (COND ((NOT BDPTR) (SETQ BRKDWNLENGTH 0) (SETQ BDLST (BRKDWNARRAY 1)) (SETQ BDSINK (BRKDWNARRAY 1)) (SETQ BDPTR BDSINK))))) (BRKDWNSETUP (LAMBDA (FN DEF PTR N) (* lpd "31-MAY-77 16:28") (PROG ((BDEF (CADDR DEF)) (TEM (LIST PTR N))) (* Form of brokendown function is BDEF= (BRKDWN2 FORM PTR N) where PTR points  to the first cell of an unboxed array%: this cell contains the number of times  the function has been called, and following cells contain the  (negative of the) parameter/s being measured.  N is number of times FORM is to be evaluated.  If N is greater than 1, FORM should not involve any side effects since it will  be performed more than once.) (COND (BRKDWNCOMPFLG (* Compile the BRKDWN2 form open, redefining FN.  The PUTD nonsense is so that the compiler doesn't unbreak FN in the process of  redefining it.) (PUTD 'BRKDWNFN NIL) (BRKDWNCOMPILE2 'BRKDWNFN (LIST (CAR DEF) (CADR DEF) (LIST 'PROG (CDDDR BRKDWNARGS) (LIST 'RETURN (BRKDWNFORM BRKDWNLABELS (LIST 'SETQ 'BDY (COND ((NEQ N 1) (LIST 'RPTQ N (CADR BDEF))) (T (CADR BDEF)))) (KWOTE PTR)))))) (PUTD FN (GETD 'BRKDWNFN)) (PUTD 'BRKDWNFN NIL) (* * Save the address of the code, for checking whether the function is still  broken, and the old definition, to allow rebreaking if BRKDWNTYPE changes.) (NCONC1 TEM (GETD FN)) (NCONC1 TEM DEF)) (T (RPLACD (CDR BDEF) TEM))) (RETURN TEM)))) (BRKDWN1 (LAMBDA NIL (* lmm "19-Jul-84 18:55") (PROG ((LST (OR (LISTP BRKDWNTYPE) (LIST BRKDWNTYPE))) LEN X Y) (* * Form of each entry on BRKDWNTYPES is  (NAME FORM1 FORM2) e.g. (TIME (LAMBDA NIL  (CLOCK 2)) (LAMBDA (X) (FQUOTIENT X (TICKPS)))) FORM1 is the parameter being  measured, FORM2 (optional) can be used to convert the value of FORM1 to some  other units, e.g. clock ticks to seconds.) (OR (GETD (SETQ Y (PACK (CONS 'BRKDWN LST)))) (BRKDWNCOMPILE2 Y `(NLAMBDA %, BRKDWNARGS (DECLARE (LOCALVARS . T)) %, (BRKDWNFORM LST '(PROG NIL BDLP (SETQ BDY (EVAL BDEXP)) (COND ((NEQ BDN 1) (SUB1VAR BDN) (GO BDLP)))) (CADR BRKDWNARGS))))) (PUTD 'BRKDWN2 (GETD Y) T) (* * The function used for breaking the functions of interest is BRKDWNNAME  e.g. BRKDWNTIME, BRKDWNCONSES etc. Its definition is created, if not already  defined, by BRKDWNFORM and then compiled.  BRKDWNTIME and BRKDWNCONSES are already defined in the system since they are  used so frequently.) (COND ((IGREATERP (SETQ LEN (LENGTH LST)) BRKDWNLENGTH) (* More statistics are being measured, so go though all the broken functions  and give them larger statistic arrays.) (MAPC BRKDWNLST (FUNCTION (LAMBDA (FNS) (PROG ((A (BRKDWNARRAY (ADD1 LEN)))) (COND ((CDDDR FNS) (* Function has open-coded BRKDWN2 and  must be recompiled.) (RPLACD FNS (BRKDWNSETUP (CAR FNS) (PUTD (CAR FNS) (CAR (CDDDDR FNS))) A (CADDR FNS)))) (T (RPLACA (CDDR (CADDR (GETD (CAR FNS)))) A))) (RPLACA (CDR FNS) A))))))) (SETQ BRKDWNLENGTH (LENGTH (SETQ BRKDWNLABELS (APPEND LST)))) (SETQ BRKDWNTOTLST (CONS NIL (APPEND BRKDWNLABELS))) (SETQ BDLST (BRKDWNARRAY (ADD1 BRKDWNLENGTH))) (SETQ BDSINK (BRKDWNARRAY (ADD1 BRKDWNLENGTH))) (SETQ BRKDWNTYPE NIL)))) (BRKDWNFORM (LAMBDA (LST SETFORM PTR) (* lpd "31-MAY-77 16:29") (PROG ((I 1) (LST1 (CONS)) (LST2 (CONS))) (* Computes the body of the BRKDWNNAME function  (closed or open coded) when LST is the list of things being measured.  PTR is the (name of the) pointer to the statistics array.) (MAPC LST (FUNCTION (LAMBDA (STAT) (PROG ((X (CADR (ASSOC STAT BRKDWNTYPES)))) (OR X (HELP STAT '"not found")) (TCONC LST1 (LIST 'BRKDWNINCA 'BDPTR 'BDLST I X)) (TCONC LST2 (LIST 'BRKDWNINCA 'BDZ 'BDLST I X)) (ADD1VAR I))))) (RETURN (LIST 'BRKDWNMACRO (CONS 'PROGN (CAR LST1)) (CONS 'PROGN (CAR LST2)) SETFORM PTR))))) (BRKDWNCOMPILE2 (LAMBDA (FN DEF) (* lmm "19-Jul-84 18:53") (DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS)) (DECLARE (GLOBALVARS NLAMA NLAML LAMS LAMA NOFIXFNSLST NOFIXVARSLST)) (RESETVARS ((NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST)) (RETURN (RESETLST (* RESETLST to provide reset context for macros under COMPILE1 as generated  e.g. by DECL.) (PROG ((LCFIL) (LAPFLG) (STRF T) (SVFLG) (LSTFIL T) (SPECVARS T) (LOCALVARS (COND ((NEQ LOCALVARS T) (UNION SYSLOCALVARS LOCALVARS)) (T SYSLOCALVARS)))) (RETURN (COMPILE1 FN DEF T)))))))) (BRKDWNTIME (NLAMBDA (BDEXP BDX BDN BDY BDZ) (* lpd " 1-JUN-77 14:39") (DECLARE (LOCALVARS . T)) (BRKDWNMACRO (BRKDWNINCA BDPTR BDLST 1 (CPUTIME)) (BRKDWNINCA BDZ BDLST 1 (CPUTIME)) (PROG NIL BDLP (SETQ BDY (EVAL BDEXP)) (COND ((NEQ BDN 1) (SUB1VAR BDN) (GO BDLP)))) BDX))) (BRKDWNCONSES (NLAMBDA (BDEXP BDX BDN BDY BDZ) (DECLARE (LOCALVARS . T)) (* lpd "31-MAY-77 16:31") (BRKDWNMACRO (BRKDWNINCA BDPTR BDLST 1 (CONSCOUNT)) (BRKDWNINCA BDZ BDLST 1 (CONSCOUNT)) (PROG NIL BDLP (SETQ BDY (EVAL BDEXP)) (COND ((NEQ BDN 1) (SUB1VAR BDN) (GO BDLP)))) BDX))) (BRKDWNBOXES (NLAMBDA (BDEXP BDX BDN BDY BDZ) (DECLARE (LOCALVARS . T)) (* wt%: "15-MAR-78 16:31") (BRKDWNMACRO (BRKDWNINCA BDPTR BDLST 1 (IBOXCOUNT)) (BRKDWNINCA BDZ BDLST 1 (IBOXCOUNT)) (PROG NIL BDLP (SETQ BDY (EVAL BDEXP)) (COND ((NEQ BDN 1) (SUB1VAR BDN) (GO BDLP)))) BDX))) (BRKDWNFBOXES (NLAMBDA (BDEXP BDX BDN BDY BDZ) (DECLARE (LOCALVARS . T)) (* wt%: "15-MAR-78 16:32") (BRKDWNMACRO (BRKDWNINCA BDPTR BDLST 1 (FBOXCOUNT)) (BRKDWNINCA BDZ BDLST 1 (FBOXCOUNT)) (PROG NIL BDLP (SETQ BDY (EVAL BDEXP)) (COND ((NEQ BDN 1) (SUB1VAR BDN) (GO BDLP)))) BDX))) (RESULTS (LAMBDA (RETURNVALUESFLG) (* wt%: "15-MAR-78 19:49") (BRKDWNRESULTS RETURNVALUESFLG))) (BRKDWNRESULTS (LAMBDA (RETURNVALUESFLG) (* wt%: "15-MAR-78 16:25") (PROG (CL:VALUES (I 1)) (CONSCOUNT 0) (MAP BRKDWNTOTLST (FUNCTION (LAMBDA (X) (RPLACA X 0)))) (SETQ CL:VALUES (MAPCAR BRKDWNLST (FUNCTION (LAMBDA (X) (BRKDWNRESULTS1 (LIST (CAR X)) (CADR X) (CADDR X)))))) (COND (RETURNVALUESFLG (* Return values, don't print.) (RETURN CL:VALUES))) (RESETFORM (FLTFMT BRKDWNFLTFMT) (MAPC BRKDWNLABELS (FUNCTION (LAMBDA (LABEL) (LISPXTERPRI T) (PROG ((TOT (CAR (FNTH (CDR BRKDWNTOTLST) I))) (TERP (CADDR (ASSOC LABEL BRKDWNTYPES)))) (LISPXPRIN1 '"FUNCTIONS " T) (LISPXPRIN1 LABEL T) (LISPXTAB 23 NIL T) (LISPXPRIN1 '"# CALLS" T) (LISPXTAB 33 NIL T) (LISPXPRIN1 '"PER CALL" T) (LISPXTAB 46 NIL T) (LISPXPRIN1 '"%% " T) (MAPC CL:VALUES (FUNCTION (LAMBDA (X) (BRKDWNRESULTS2 (CAR X) (CAR (FNTH (CDDR X) I)) (CADR X) TOT TERP)))) (BRKDWNRESULTS2 'TOTAL TOT (CAR BRKDWNTOTLST) TOT TERP)) (ADD1VAR I)))))))) (BRKDWNRESULTS1 (LAMBDA (NLST PTR N) (* lmm " 8-Aug-84 12:40") (* NLST is a list of the form (NAME NCALLS STAT1 ...  STATn) which is smashed (and extended if necessary) with the values from PTR.) (PROG ((I 0) (TOT BRKDWNTOTLST) (LST NLST) VAL) LP (SETQ VAL (IMINUS (BRKDWNELT PTR I))) (RPLACA TOT (PLUS (CAR TOT) (COND ((OR (EQ N 1) (EQ I 0)) VAL) (T (FQUOTIENT VAL N))))) (COND ((LISTP (CDR LST)) (RPLACA (SETQ LST (CDR LST)) VAL)) (T (RPLACD LST (SETQ LST (LIST VAL))))) (COND ((SETQ TOT (CDR TOT)) (ADD1VAR I) (GO LP))) (RETURN NLST)))) (BRKDWNRESULTS2 (LAMBDA (NAME X NCALLS TOT TERP) (* lpd " 1-JUN-77 14:36") (PROG ((TEM (COND (TERP (APPLY* TERP X)) (T X)))) (LISPXPRIN2 NAME T T) (LISPXTAB 14 NIL T) (LISPXPRIN2 TEM T T) (LISPXTAB 26 NIL T) (LISPXPRIN2 NCALLS T T) (LISPXTAB 34 NIL T) (LISPXPRIN2 (FQUOTIENT TEM NCALLS) T T) (LISPXTAB 45 NIL T) (AND (NEQ NAME 'TOTAL) (LISPXPRIN2 (FIX (FPLUS .5 (FTIMES 100 (FQUOTIENT X TOT)))) T T)) (LISPXTERPRI T)))) (BRKDWNCLEAR (LAMBDA (PTR N) (PROG ((I N)) LP (COND ((NEQ I 0) (SUB1VAR I) (BRKDWNSETA PTR I 0) (GO LP)))))) ) (DECLARE%: EVAL@COMPILE (DECLARE%: EVAL@COMPILE (PUTPROPS BRKDWNMACRO MACRO ((FORM1 FORM2 SETFORM PTR) (PROGN FORM1 (BRKDWNADDTOA PTR 0 -1) (SETQ BDZ BDPTR) (SETQ BDPTR PTR) SETFORM (SETQ BDZ (PROG1 BDPTR (SETQ BDPTR BDZ))) FORM2 BDY))) (PUTPROPS BRKDWNINCA MACRO ((PTR LST I VAL) (BRKDWNADDTOA PTR I (BRKDWNDIFFA LST I VAL)))) ) (DECLARE%: EVAL@COMPILE [PROGN (PUTPROPS BRKDWNADDTOA DMACRO ((PTR I VAL) (* BOXIPLUS a little faster) (\BOXIPLUS (BRKDWNELT PTR I) VAL))) (PUTPROPS BRKDWNADDTOA MACRO (OPENLAMBDA (PTR I VAL) (SETA PTR (ADD1 I) (IPLUS (ELT PTR (ADD1 I)) VAL))))] [PROGN (PUTPROPS BRKDWNDIFFA DMACRO (OPENLAMBDA (PTR I VAL) (PROG1 (IDIFFERENCE (BRKDWNELT PTR I) VAL) (BRKDWNSETA PTR I VAL)))) (PUTPROPS BRKDWNDIFFA MACRO (OPENLAMBDA (PTR I VAL) (IDIFFERENCE (ELT PTR (ADD1 I)) (SETA PTR (ADD1 I) VAL))))] (PUTPROPS CPUTIME MACRO (NIL (CLOCK 2))) (PUTPROPS IBOXCOUNT MACRO (NIL (BOXCOUNT))) (PUTPROPS FBOXCOUNT MACRO (NIL (BOXCOUNT 'FLOATP))) (PROGN (PUTPROPS BRKDWNELT MACRO ((ARR I) (ELT ARR (ADD1 I)))) (PUTPROPS BRKDWNELT DMACRO (= . ELT))) [PROGN (PUTPROPS BRKDWNSETA DMACRO ((ARR I VAL) (\PUTBASEFIXP (BRKDWNELT ARR I) 0 VAL))) (PUTPROPS BRKDWNSETA MACRO ((ARR I VAL) (SETA ARR (ADD1 I) VAL)))] [PROGN (PUTPROPS BRKDWNARRAY DMACRO ((N) (PROG ((BLOCK (ARRAY (ADD1 N) 'POINTER NIL 0))) [for I from 0 to N do (SETA BLOCK I (NCREATE 'FIXP] (RETURN BLOCK)))) (PUTPROPS BRKDWNARRAY MACRO ((N) (ARRAY N N)))] ) ) (RPAQQ BRKDWNLENGTH 0) (RPAQQ BRKDWNCOMPFLG NIL) (RPAQQ BRKDWNARGS (BDEXP BDX BDN BDY BDZ)) (RPAQQ BRKDWNTYPES ([TIME (CPUTIME) (LAMBDA (X) (FQUOTIENT X 1000] (CONSES (CONSCOUNT)) (PAGEFAULTS (PAGEFAULTS)) (BOXES (IBOXCOUNT)) (FBOXES (FBOXCOUNT)))) (RPAQ BRKDWNFLTFMT (NUMFORMATCODE '(FLOAT 7 3 NIL NIL 10))) (RPAQQ BRKDWNTYPE TIME) (RPAQQ BRKDWNLABELS NIL) (RPAQQ BRKDWNLST NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BRKDWNARGS BRKDWNLABELS BRKDWNLENGTH BRKDWNLST BRKDWNTOTLST BDLST BDSINK BDPTR) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL BRKDWNTIME BRKDWNCONSES BRKDWNBOXES (LINKFNS . T)) (BLOCK%: BREAKDOWN BREAKDOWN BRKDWNSETUP BRKDWN1 BRKDWNFORM BRKDWNCOMPILE2 (GLOBALVARS NOSWAPFLG)) (BLOCK%: BRKDWNRESULTS BRKDWNRESULTS BRKDWNRESULTS1 BRKDWNRESULTS2) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA BREAKDOWN) (ADDTOVAR NLAML BRKDWNFBOXES BRKDWNBOXES BRKDWNCONSES BRKDWNTIME) (ADDTOVAR LAMA ) ) (PUTPROPS BRKDWN COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2123 21017 (BREAKDOWN 2133 . 6169) (BRKDWNINIT 6171 . 6448) (BRKDWNSETUP 6450 . 8723) ( BRKDWN1 8725 . 12179) (BRKDWNFORM 12181 . 13161) (BRKDWNCOMPILE2 13163 . 14433) (BRKDWNTIME 14435 . 14902) (BRKDWNCONSES 14904 . 15382) (BRKDWNBOXES 15384 . 15862) (BRKDWNFBOXES 15864 . 16343) (RESULTS 16345 . 16495) (BRKDWNRESULTS 16497 . 19200) (BRKDWNRESULTS1 19202 . 20176) (BRKDWNRESULTS2 20178 . 20833) (BRKDWNCLEAR 20835 . 21015))))) STOP \ No newline at end of file diff --git a/sources/BSP b/sources/BSP new file mode 100644 index 00000000..251fa6d9 --- /dev/null +++ b/sources/BSP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 10:23:19" {DSK}lde>lispcore>sources>BSP.;3 149048 changes to%: (RECORDS BSPSOC ACKPUP BSPSTREAM) previous date%: " 4-Jan-93 17:24:25" {DSK}lde>lispcore>sources>BSP.;2) (* ; " Copyright (c) 1982, 1983, 1900, 1984, 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BSPCOMS) (RPAQQ BSPCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (* ;  "This socket record has both RTP and BSP state info") (RECORDS BSPSOC ACKPUP BSPSTREAM) (CONSTANTS * RTPSTATES) (CONSTANTS * RTPEVENTS) (CONSTANTS (WORDSPERPORT 3)) (MACROS RTP.OTHERFN BSP.OTHERFN BSP.INPUT.ERROR BSP.OUTPUT.ERROR \BSPINCFILEPTR)) (COMS (* ;  "User-level RTP socket manipulation") (FNS OPENRTPSOCKET CLOSERTPSOCKET \INIT.RTPPROCESS)) (COMS (* ; "RTP process") (FNS \RTP.SOCKET.PROCESS \RTP.HANDLE.INPUT \RTP.HANDLE.PUP \RTP.HANDLE.RFC \RTP.CLEANUP \RTP.ACTION \RTP.ERROR \RTP.SHOW.FAILURE \RTP.FILTER \SEND.ABORT \SEND.ANSWERING.RFC \SEND.END \SEND.ENDREPLY \SEND.RFC \FILLRTPPUP \SETRTPPORTS) (FNS \BSPINIT \BSPEVENTFN \BSP.CLOSE.OPEN.SOCKETS)) (COMS (* ; "Creating BSP stream") (FNS OPENBSPSTREAM \SMASHBSPSTREAM BSPOUTPUTSTREAM BSPINPUTSTREAM BSPFRNADDRESS CLOSEBSPSTREAM \BSP.FLUSHINPUT BSPOPENP GETBSPUSERINFO SETBSPUSERINFO) (FNS CREATEBSPSTREAM ENDBSPSTREAM)) (COMS (* ; "BSP stream functions") (FNS BSPBIN \BSP.GETNEXTBUFFER BSPPEEKBIN BSPREADP BSPEOFP \BSPBACKFILEPTR \BSP.PREPARE.INPUT \BSP.GETFILEPTR \BSP.DECLARE.FILEPTR \BSP.SETFILEPTR \BSP.SKIPBYTES \BSP.CLEANUP.INPUT BSPBOUT \BSP.OTHERBOUT \BSPWRITEBLOCK BSPFORCEOUTPUT \BSP.SENDBUFFER \BSP.PREPARE.OUTPUT BSPGETMARK BSPPUTMARK BSP.PUTINTERRUPT)) (COMS (* ; "BSP pup handler") (FNS \BSP.HANDLE.INPUT \BSP.HANDLE.ACK \BSP.HANDLE.DATA \BSP.HANDLE.ERROR \BSP.HANDLE.INTERRUPT \BSP.HANDLE.INTERRUPTREPLY \SEND.ACK \SEARCH.OUTPUTQ \SETBSPTIMEOUT \TRANSMIT.STRATEGY)) (COMS (* ; "BSP utilities") (FNS \BSP.DEFAULT.ERROR.HANDLER \BSP.TIMERFN \BSP.FLUSH.SOCKET.QUEUES \FILLBSPPUP BSPHELP)) [COMS (* ; "debugging") (FNS PPSOC PPSOC.CURRENT PRINTTIMER PRINTPUPQUEUE BSPPRINTPUP \RTP.INFO.HOOK) (DECLARE%: DONTCOPY (ALISTS (PUPPRINTMACROS 8 9 16 17 18 20] (INITRECORDS BSPSOC) (SYSRECORDS BSPSOC) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\BSPINIT))) (COMS (* ;  "Some of these may want to be constants") (INITVARS (\BSPSOCKETS) (\RFC.TIMEOUT 2000) (\RTP.DALLY.TIMEOUT 5000) (\RTP.DEFAULTTIMEOUT 30000) (\BSP.MAXPUPS 12) (\BSP.IDLETIMEOUT 15000) (\BSP.OUTSTANDINGDATATIMEOUT 250) (\BSP.MAXPUPALLOC 200) (\BSP.ALLOCHYSTERESIS 50) (\BSP.OVERLAP.DATA.WITH.ACK) (\BSP.INITIAL.MAXPUPALLOC 5) (\BSP.INITIAL.ADATATIMEOUT 1000) (\BSP.MIN.ADATA.TIMEOUT 500) (\BSP.MAX.ADATA.TIMEOUT 10000) (\BSP.INACTIVITY.TIMEOUT 120000) (\BSP.NO.INACTIVITY.TIMEOUT T)) (GLOBALVARS \BSPSOCKETS \RFC.TIMEOUT \RTP.DALLY.TIMEOUT \RTP.DEFAULTTIMEOUT \BSP.MAXPUPS \BSP.IDLETIMEOUT \BSP.OUTSTANDINGDATATIMEOUT \BSP.MAXPUPALLOC \BSP.ALLOCHYSTERESIS \BSP.OVERLAP.DATA.WITH.ACK \BSP.INITIAL.MAXPUPALLOC \BSP.INITIAL.ADATATIMEOUT \BSP.MIN.ADATA.TIMEOUT \BSP.MAX.ADATA.TIMEOUT \BSP.INACTIVITY.TIMEOUT \BSP.NO.INACTIVITY.TIMEOUT)))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE BSPSOC ((FRNPORT WORD) (FRNSOCKET FIXP) (* ; "Net,host,socket of partner") (LCLPORT WORD) (LCLSOCKET FIXP) (* ; "Net,host,socket of us") (RTPSTATE BYTE) (* ;  "The current state of the RTP connection, see RTPSTATES") (RTPPROCESS POINTER) (* ; "Process handle for RTP demon") (RTPEVENT POINTER) (* ; "Notified when RTPSTATE changes") (PUPSOC POINTER) (* ;  "The packet-level socket used by us") (CONNID POINTER) (* ;  "A large integer, the connection ID") (RTPTIMER POINTER) (* ;  "Timer used for timing out some RTP steps") (RTPTIMEOUT WORD) (* ;  "Timeout for current RTP op, or zero if none") (BSPINPUTHANDLER POINTER) (* ;  "Function that is the top-level loop of the watcher process") (* ;; "The rest of this structure is dedicated to handling the BSP") (BSPINPUTSTREAM POINTER) (* ; "Pointer back to STREAM object") (BSPTIMER POINTER) (* ; "Timer for BSP use") (BSPTIMEOUT WORD) (BSPFAILUREREASON POINTER) (* ;  "Why connection was broken or not opened") (BSPOTHERPUPFN POINTER) (* ;  "Called on error, interrupt and non-bsp pups") (BSPERRORHANDLER POINTER) (* ; "Called for bsp errors") (BSPIOTIMEOUT POINTER) (* ;  "if non-zero will cause prepare.output and prepare.input to timeout") (RCVBYTEID POINTER) (* ; "ID of as far as we have acked") (RCVINTERRUPTID POINTER) (* ; "ID of next incoming interrupt") (BSPINPUTQ POINTER) (* ;  "Queue of all pups we have received") (%#UNREADPUPS WORD) (* ;  "How many pups do we have before first hole in input") (XMITBYTEID POINTER) (* ; "Id of next outgoing pup") (XMITINTERRUPTID POINTER) (* ; "id of next outgoing interrupt") (LASTACKID POINTER) (* ;  "Id of last ack, i.e. how far our partner has read us") (%#UNACKEDPUPS WORD) (%#UNACKEDBYTES WORD) (* ;  "how many pups/bytes have we sent that haven't been acked") (BSPOUTPUTQ POINTER) (* ;  "Queue of sent but not acked pups") (BYTESPERPUP WORD) (* ;  "Maximum size we are allowed to grow pups") (PUPALLOC WORD) (* ;  "Remaining outgoing pup allocation, i.e. partner's allocation less #UNACKEDPUPS") (BYTEALLOC WORD) (* ;  "Remaining outgoing byte allocation") (MAXPUPALLOC WORD) (PUPALLOCCOUNT WORD) (ADATACOUNT WORD) (* ; "incremented once per AData sent") (LASTADATATIME POINTER) (* ; "Time last ADATA was sent") (ADATATIMEOUT WORD) (* ;  "Timeout currently in use for AData") (INACTIVITYTIMER POINTER) (* ;  "Time of last incoming pup on this connection") (LISTENING FLAG) (* ;  "if socket was opened as a server rather than user") (INTERRUPTOUT FLAG) (* ;  "an unacked interrupt is outstanding") (INTERRUPTIN FLAG) (* ; "an interrupt has been received") (ACKPENDING FLAG) (* ;  "Adata was received, we need to ack") (ACKREQUESTED FLAG) (* ;  "We have sent an Adata, are waiting for ack") (SENTZEROALLOC FLAG) (* ; "Need to send gratuitous ack") (BSPNOACTIVITY FLAG) (* ;  "True if BSPINACTIVITYTIMEOUT has passed with no sign of life from other side") (BSPUSERSTATE POINTER) (* ;  "For applications use to do as it pleases") (NIL WORD) (* ; "No longer used") (IOTIMEOUTFN POINTER) (* ;  "function to be called when prepare.* timeout") (BSPWHENCLOSEDFN POINTER) (* ;  "Called when connection is closed") (BSPINPUTEVENT POINTER) (BSPLOCK POINTER) (BSPINITTIMER POINTER) (BSPFAILURESTRING POINTER) (BSPINACTIVITYTIMEOUT POINTER)) (BLOCKRECORD BSPSOC ((FRNNET BYTE) (FRNHOST BYTE) (FRNSOCKETHI WORD) (FRNSOCKETLO WORD) (LCLNET BYTE) (LCLHOST BYTE) (LCLSOCKETHI WORD) (LCLSOCKETLO WORD))) [ACCESSFNS BSPSOC ((FRNPUPADDRESS (CONS (fetch FRNPORT of DATUM) (fetch FRNSOCKET of DATUM))) (LCLPUPADDRESS (CONS (fetch LCLPORT of DATUM) (fetch LCLSOCKET of DATUM] (* ;; "Note: I assume record pkg does not break up the first six words (the two ports). I hope I don't have to force it") RTPTIMER _ (CREATECELL \FIXP) BSPTIMER _ (CREATECELL \FIXP) INACTIVITYTIMER _ (CREATECELL \FIXP) LASTADATATIME _ (CREATECELL \FIXP) BSPINPUTQ _ (NCREATE 'SYSQUEUE) BSPOUTPUTQ _ (NCREATE 'SYSQUEUE)) (BLOCKRECORD ACKPUP ((ACKBYTESPERPUP WORD) (ACKPUPS WORD) (ACKBYTES WORD)) (* ;  "body of ACK pup, giving partner's allocation") ) (ACCESSFNS BSPSTREAM [(BSPSOC (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (* ; "BSPSOC object") (BSPOUTPUTSTREAM (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (* ;  "If this stream is the input side, gives output side") (BSPCURRENTPUP (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (* ;  "PUP whose body is the current buffer. Could be redundant") (MARKPENDING (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE)) (* ;  "On input, true if next byte is a mark") (BSPFILEPTRHI (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (BSPFILEPTRLO (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE)) (BSPFILEPTR (\MAKENUMBER (fetch BSPFILEPTRHI of DATUM) (fetch BSPFILEPTRLO of DATUM)) (PROGN (replace BSPFILEPTRHI of DATUM with (LRSH NEWVALUE BITSPERWORD)) (replace BSPFILEPTRLO of DATUM with (LOGAND NEWVALUE MAX.SMALL.INTEGER]) ) (/DECLAREDATATYPE 'BSPSOC '(WORD FIXP WORD FIXP BYTE POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER WORD WORD POINTER WORD WORD WORD WORD WORD WORD POINTER WORD POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((BSPSOC 0 (BITS . 15)) (BSPSOC 1 FIXP) (BSPSOC 3 (BITS . 15)) (BSPSOC 4 FIXP) (BSPSOC 6 (BITS . 7)) (BSPSOC 8 POINTER) (BSPSOC 10 POINTER) (BSPSOC 12 POINTER) (BSPSOC 14 POINTER) (BSPSOC 16 POINTER) (BSPSOC 7 (BITS . 15)) (BSPSOC 18 POINTER) (BSPSOC 20 POINTER) (BSPSOC 22 POINTER) (BSPSOC 24 (BITS . 15)) (BSPSOC 26 POINTER) (BSPSOC 28 POINTER) (BSPSOC 30 POINTER) (BSPSOC 32 POINTER) (BSPSOC 34 POINTER) (BSPSOC 36 POINTER) (BSPSOC 38 POINTER) (BSPSOC 25 (BITS . 15)) (BSPSOC 40 POINTER) (BSPSOC 42 POINTER) (BSPSOC 44 POINTER) (BSPSOC 46 (BITS . 15)) (BSPSOC 47 (BITS . 15)) (BSPSOC 48 POINTER) (BSPSOC 50 (BITS . 15)) (BSPSOC 51 (BITS . 15)) (BSPSOC 52 (BITS . 15)) (BSPSOC 53 (BITS . 15)) (BSPSOC 54 (BITS . 15)) (BSPSOC 55 (BITS . 15)) (BSPSOC 56 POINTER) (BSPSOC 58 (BITS . 15)) (BSPSOC 60 POINTER) (BSPSOC 60 (FLAGBITS . 0)) (BSPSOC 60 (FLAGBITS . 16)) (BSPSOC 60 (FLAGBITS . 32)) (BSPSOC 60 (FLAGBITS . 48)) (BSPSOC 59 (FLAGBITS . 0)) (BSPSOC 59 (FLAGBITS . 16)) (BSPSOC 59 (FLAGBITS . 32)) (BSPSOC 62 POINTER) (BSPSOC 64 (BITS . 15)) (BSPSOC 66 POINTER) (BSPSOC 68 POINTER) (BSPSOC 70 POINTER) (BSPSOC 72 POINTER) (BSPSOC 74 POINTER) (BSPSOC 76 POINTER) (BSPSOC 78 POINTER)) '80) (RPAQQ RTPSTATES ((\STATE.CLOSED 0) (\STATE.SENTRFC 1) (\STATE.LISTENING 2) (\STATE.OPEN 3) (\STATE.ENDRECEIVED 4) (\STATE.ENDSENT 5) (\STATE.DALLYING 6) (\STATE.ABORTED 7))) (DECLARE%: EVAL@COMPILE (RPAQQ \STATE.CLOSED 0) (RPAQQ \STATE.SENTRFC 1) (RPAQQ \STATE.LISTENING 2) (RPAQQ \STATE.OPEN 3) (RPAQQ \STATE.ENDRECEIVED 4) (RPAQQ \STATE.ENDSENT 5) (RPAQQ \STATE.DALLYING 6) (RPAQQ \STATE.ABORTED 7) (CONSTANTS (\STATE.CLOSED 0) (\STATE.SENTRFC 1) (\STATE.LISTENING 2) (\STATE.OPEN 3) (\STATE.ENDRECEIVED 4) (\STATE.ENDSENT 5) (\STATE.DALLYING 6) (\STATE.ABORTED 7)) ) (RPAQQ RTPEVENTS ((\EVENT.OPEN 0) (\EVENT.OPENLISTENING 1) (\EVENT.OPENIMMEDIATE 2) (\EVENT.CLOSE 3) (\EVENT.FORCECLOSE 4) (\EVENT.RFC 5) (\EVENT.ABORT 6) (\EVENT.END 7) (\EVENT.ENDREPLY 8) (\EVENT.TIMEOUT 9))) (DECLARE%: EVAL@COMPILE (RPAQQ \EVENT.OPEN 0) (RPAQQ \EVENT.OPENLISTENING 1) (RPAQQ \EVENT.OPENIMMEDIATE 2) (RPAQQ \EVENT.CLOSE 3) (RPAQQ \EVENT.FORCECLOSE 4) (RPAQQ \EVENT.RFC 5) (RPAQQ \EVENT.ABORT 6) (RPAQQ \EVENT.END 7) (RPAQQ \EVENT.ENDREPLY 8) (RPAQQ \EVENT.TIMEOUT 9) (CONSTANTS (\EVENT.OPEN 0) (\EVENT.OPENLISTENING 1) (\EVENT.OPENIMMEDIATE 2) (\EVENT.CLOSE 3) (\EVENT.FORCECLOSE 4) (\EVENT.RFC 5) (\EVENT.ABORT 6) (\EVENT.END 7) (\EVENT.ENDREPLY 8) (\EVENT.TIMEOUT 9)) ) (DECLARE%: EVAL@COMPILE (RPAQQ WORDSPERPORT 3) (CONSTANTS (WORDSPERPORT 3)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS RTP.OTHERFN MACRO ((PUP SOCKET) (SELECTQ (fetch OTHERPUPFN of SOCKET) (RELEASE.PUP (RELEASE.PUP PUP)) (\BSP.PUPHANDLER (\BSP.PUPHANDLER PUP SOCKET)) (APPLY* (fetch OTHERPUPFN of SOCKET) PUP SOCKET] [PUTPROPS BSP.OTHERFN MACRO ((PUP SOCKET) (SELECTQ (fetch BSPOTHERPUPFN of SOCKET) (RELEASE.PUP (RELEASE.PUP PUP)) (APPLY* (fetch BSPOTHERPUPFN of SOCKET) PUP (fetch BSPINPUTSTREAM of SOCKET] (PUTPROPS BSP.INPUT.ERROR MACRO (OPENLAMBDA (STREAM ERRCODE) (APPLY* (fetch BSPERRORHANDLER of (fetch BSPSOC of STREAM)) STREAM ERRCODE))) (PUTPROPS BSP.OUTPUT.ERROR MACRO (OPENLAMBDA (STREAM ERRCODE) (APPLY* (fetch BSPERRORHANDLER of (fetch BSPSOC of STREAM)) STREAM ERRCODE))) [PUTPROPS \BSPINCFILEPTR MACRO ((STREAM N) (PROG (NEWLO) (replace BSPFILEPTRLO of STREAM with (COND ((IGREATERP (SETQ NEWLO (IPLUS (fetch BSPFILEPTRLO of STREAM) N)) MAX.SMALL.INTEGER) (add (fetch BSPFILEPTRHI of STREAM) 1) (SUB1 (IDIFFERENCE NEWLO MAX.SMALL.INTEGER))) (T NEWLO] ) ) (* ; "User-level RTP socket manipulation") (DEFINEQ (OPENRTPSOCKET [LAMBDA (FRNPORT MODE PUPSOC CONNID TIMEOUT FAILURESTRING) (* bvm%: " 6-Oct-86 11:42") (* ;;; "Open an RTP socket in given MODE, talking to FRNPORT. If mode is or contains USER, we set up a user RTP, sending an RFC to FRNPORT, with initial connection id CONNID (default is chosen at random). If mode is or contains SERVER, we merely listen for an RFC from somewhere, and FRNPORT and CONNID are ignored. If MODE is or contains RETURN, we don't wait around, but return immediately; caller is assumed to be monitoring the state of the connection. In the case where we wait, TIMEOUT is how long we will wait (msecs) before giving up and returning NIL. On success, we return a new BSPSOC. PUPSOC is a packet-level socket opened for the connection by the caller; if omitted, one is created. If MODE is NIL, we open a USER connection and wait for it to succeed.") (RESETLST [PROG (SOCKET INITSTATE SOCKET#) [COND (FRNPORT (SETQ FRNPORT (ETHERPORT FRNPORT T] [COND [(NULL PUPSOC) (SETQ SOCKET# (PUPSOCKETNUMBER (SETQ PUPSOC (OPENPUPSOCKET] [(FIXP PUPSOC) (SETQ PUPSOC (OPENPUPSOCKET (SETQ SOCKET# PUPSOC] (T (SETQ SOCKET# (PUPSOCKETNUMBER (\DTEST PUPSOC 'PUPSOCKET] (SETQ SOCKET (create BSPSOC RTPSTATE _ \STATE.CLOSED CONNID _ (OR CONNID (RAND 0 16384)) BSPINPUTHANDLER _ (FUNCTION \RTP.HANDLE.INPUT) BSPOTHERPUPFN _ (FUNCTION RELEASE.PUP) PUPSOC _ PUPSOC LCLPORT _ (\LOCALPUPADDRESS) LCLSOCKET _ SOCKET# BSPFAILURESTRING _ FAILURESTRING)) (\INIT.RTPPROCESS SOCKET) (* ;  "set up a process to monitor this socket") (push \BSPSOCKETS SOCKET) [COND (FRNPORT (replace FRNPORT of SOCKET with (CAR FRNPORT)) (replace FRNSOCKET of SOCKET with (CDR FRNPORT] (COND ((NOT MODE) (SETQQ MODE USER))) (OBTAIN.MONITORLOCK (fetch BSPLOCK of SOCKET) NIL T) [RESETSAVE (PROGN SOCKET) '(AND RESETSTATE (CLOSERTPSOCKET OLDVALUE 0] (COND [(EQMEMB 'USER MODE) (COND ((NOT FRNPORT) (ERROR "No foreign port specified"))) (\RTP.ACTION SOCKET \EVENT.OPEN) (* ; "Open the connection (send RFC)") (COND ((EQMEMB 'RETURN MODE) (RETURN SOCKET] [(EQMEMB 'SERVER MODE) (replace LISTENING of SOCKET with T) (\RTP.ACTION SOCKET \EVENT.OPENLISTENING) (COND ((EQMEMB 'RETURN MODE) (RETURN SOCKET] ((EQ MODE 'RETURN) (* ;  "Caller just wants to create this thing, putting it immediately open") (\RTP.ACTION SOCKET \EVENT.OPENIMMEDIATE) (RETURN SOCKET)) (T (\ILLEGAL.ARG MODE))) (SETQ INITSTATE (fetch RTPSTATE of SOCKET)) [COND ((NEQ TIMEOUT T) (replace BSPINITTIMER of SOCKET with (SETUPTIMER (OR TIMEOUT \RTP.DEFAULTTIMEOUT ] (until (NEQ (fetch RTPSTATE of SOCKET) INITSTATE) do (MONITOR.AWAIT.EVENT (fetch BSPLOCK of SOCKET ) (fetch RTPEVENT of SOCKET))) (* ; "Wait for transaction to happen") (RETURN (COND ((OR (EQ (fetch RTPSTATE of SOCKET) \STATE.OPEN) (EQ (fetch RTPSTATE of SOCKET) \STATE.ENDRECEIVED)) (* ; "Socket has been opened ok") SOCKET) (T (* ; "Give up, flush everything") (CLOSERTPSOCKET SOCKET 0) (COND (FAILURESTRING (\RTP.SHOW.FAILURE SOCKET NIL "No Response"))) (AND (EQ FAILURESTRING 'RETURN) (fetch BSPFAILUREREASON of SOCKET])]) (CLOSERTPSOCKET [LAMBDA (SOCKET TIMEOUT DONTSEND) (* bvm%: "29-Mar-85 21:23") (* ;;; "Close given RTP socket. This sends the normal end sequence if appropriate. TIMEOUT is how long we will wait for the end to complete normally. Value returned is true if the socket was closed normally, NIL if aborted. In either case, SOCKET goes away") (PROG (SUCCESS) (WITH.MONITOR (fetch BSPLOCK of SOCKET) (COND ((NEQ TIMEOUT 0) (* ;  "Is zero to force a bad connection closed immediately") (replace BSPINITTIMER of SOCKET with (SETUPTIMER (OR TIMEOUT \RTP.DEFAULTTIMEOUT ))) (\RTP.ACTION SOCKET \EVENT.CLOSE) (until (COND ((SETQ SUCCESS (EQ (fetch RTPSTATE of SOCKET) \STATE.CLOSED)) T) ((EQ (fetch RTPSTATE of SOCKET) \STATE.ABORTED) (\RTP.ACTION SOCKET \EVENT.FORCECLOSE) T)) do (* ; "wait for end handshake") (MONITOR.AWAIT.EVENT (fetch BSPLOCK of SOCKET) (fetch RTPEVENT of SOCKET) \RTP.DEFAULTTIMEOUT))) (T (\RTP.ACTION SOCKET \EVENT.FORCECLOSE)))) (DEL.PROCESS (PROG1 (fetch RTPPROCESS of SOCKET) (replace RTPPROCESS of SOCKET with NIL))) (* ; "Deleting the process performs any other cleanup needed, such as flushing the PUPSOCKET underneath") (RETURN SUCCESS]) (\INIT.RTPPROCESS [LAMBDA (SOCKET) (* bvm%: "29-Mar-85 21:42") (* ;;; "Creates a process to handle RTP connection on this socket") (PROG ((PROC (ADD.PROCESS (LIST (FUNCTION \RTP.SOCKET.PROCESS) (KWOTE SOCKET)) 'NAME 'RTP 'RESTARTABLE 'NO)) NAME) (replace RTPPROCESS of SOCKET with PROC) [replace RTPEVENT of SOCKET with (CREATE.EVENT (SETQ NAME (PROCESS.NAME PROC] (replace BSPLOCK of SOCKET with (CREATE.MONITORLOCK NAME]) ) (* ; "RTP process") (DEFINEQ (\RTP.SOCKET.PROCESS [LAMBDA (BSPSOCKET) (* bvm%: "29-Mar-85 21:43") (DECLARE (SPECVARS BSPSOCKET)) (* ;  "BSPSOCKET is for use by PPSOC in our INFO hook") (* ;;; "This is the process that monitors the state of the RTP connection on BSPSOCKET. This better get run periodically") (PROG NIL (OBTAIN.MONITORLOCK (fetch BSPLOCK of BSPSOCKET) NIL T) (RESETSAVE NIL (LIST (FUNCTION \RTP.CLEANUP) BSPSOCKET)) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION \RTP.INFO.HOOK)) LP (SPREADAPPLY* (fetch BSPINPUTHANDLER of BSPSOCKET) BSPSOCKET) (GO LP]) (\RTP.HANDLE.INPUT [LAMBDA (BSPSOCKET) (* bvm%: "29-Mar-85 14:19") (* ;;; "Top-level of RTP process while connection is being opened") (LET ((PUPSOC (fetch PUPSOC of BSPSOCKET)) PUP TIMER) (COND ((SETQ PUP (GETPUP PUPSOC)) (* ; "play with incoming pup") (\RTP.HANDLE.PUP PUP BSPSOCKET) (BLOCK)) (T (MONITOR.AWAIT.EVENT (fetch BSPLOCK of BSPSOCKET) (PUPSOCKETEVENT PUPSOC) [SETQ TIMER (COND ((NEQ (fetch RTPTIMEOUT of BSPSOCKET) 0) (fetch RTPTIMER of BSPSOCKET] (AND TIMER T)) (COND ((AND TIMER (TIMEREXPIRED? TIMER)) (\RTP.ACTION BSPSOCKET \EVENT.TIMEOUT]) (\RTP.HANDLE.PUP [LAMBDA (PUP BSPSOCKET) (* bvm%: "29-Mar-85 21:31") (* ;;; "Handles incoming PUP on an RTP connection") (SELECTC (fetch PUPTYPE of PUP) (\PT.RFC (\RTP.HANDLE.RFC BSPSOCKET PUP) (SETQ PUP NIL)) (\PT.END (COND ((\RTP.FILTER BSPSOCKET PUP T T) (\RTP.ACTION BSPSOCKET \EVENT.END PUP)))) (\PT.ENDREPLY (COND ((\RTP.FILTER BSPSOCKET PUP T T) (\RTP.ACTION BSPSOCKET \EVENT.ENDREPLY PUP)))) (\PT.ABORT [COND ((\RTP.FILTER BSPSOCKET PUP T T) (\RTP.ACTION BSPSOCKET \EVENT.ABORT PUP) (\RTP.SHOW.FAILURE BSPSOCKET PUP (CONCAT "[Abort] " (GETPUPSTRING PUP BYTESPERWORD]) (\PT.ERROR (COND ((AND (EQ (fetch ERRORPUPCODE of PUP) \PUPE.NOSOCKET) (\RTP.FILTER BSPSOCKET PUP T NIL)) (* ; "Treat type 2 errors as abort") (\RTP.ACTION BSPSOCKET \EVENT.ABORT PUP) (\RTP.SHOW.FAILURE BSPSOCKET PUP "No Such Socket")))) (PROGN (BSP.OTHERFN PUP BSPSOCKET) (SETQ PUP NIL))) (AND PUP (RELEASE.PUP PUP]) (\RTP.HANDLE.RFC [LAMBDA (BSPSOCKET PUP) (* bvm%: "29-Mar-85 12:52") (* ;; "RFC received. This may be either an initiating RFC (if we are listening) or an answering RFC (if we have sent out an initiating RFC of our own)") (LET ((DATA (fetch PUPCONTENTS of PUP))) [COND ((EQ (fetch (PORT NET) of DATA) 0) (* ;  "Sender didn't know its own net number, but we know it now") (replace (PORT NET) of DATA with (fetch PUPSOURCENET of PUP] (COND ((SELECTC (fetch RTPSTATE of BSPSOCKET) (\STATE.LISTENING (* ; "Accept all but broadcast pups") (NEQ (fetch PUPDESTHOST of PUP) 0)) (\STATE.SENTRFC (* ; "Must match the RFC we sent out") (\RTP.FILTER BSPSOCKET PUP T T)) ((LIST \STATE.OPEN \STATE.ENDSENT) (* ;  "probably a duplicate. Make sure it matches the connection we think we have open") (AND (\RTP.FILTER BSPSOCKET PUP NIL T) (EQ (fetch (PORT NETHOST) of DATA) (fetch FRNPORT of BSPSOCKET)) (EQ (fetch (PORT SOCKETHI) of DATA) (fetch FRNSOCKETHI of BSPSOCKET)) (EQ (fetch (PORT SOCKETLO) of DATA) (fetch FRNSOCKETLO of BSPSOCKET)))) NIL) (\RTP.ACTION BSPSOCKET \EVENT.RFC PUP)) (T (* ;  "Bad RFC. Send an Abort in reply") (SWAPPUPPORTS PUP) (replace PUPLENGTH of PUP with (IPLUS \PUPOVLEN BYTESPERWORD)) (\PUTBASE DATA 0 0) (PUTPUPSTRING PUP "RFC refused") (* ; "explanatory string") (replace TYPEWORD of PUP with \PT.ABORT) (replace EPREQUEUE of PUP with 'FREE) (SENDPUP (fetch PUPSOC of BSPSOCKET) PUP]) (\RTP.CLEANUP [LAMBDA (SOCKET) (* bvm%: "14-JUN-83 14:48") (* ;; "Cleanup called when the RTP process on this socket is deleted. CLOSERTPSOCKET may or may not have been called yet, so send an abort if socket isn't closed yet") (SETQ \BSPSOCKETS (DREMOVE SOCKET \BSPSOCKETS)) (\RTP.ACTION SOCKET \EVENT.FORCECLOSE) (* ;; "May have been flushed already if the socket was aborted and then timed out, so call CLOSEPUPSOCKET with NOERRORFLG T") (CLOSEPUPSOCKET (fetch PUPSOC of SOCKET) T) [PROG ((FN (fetch BSPWHENCLOSEDFN of SOCKET))) (AND FN (APPLY* FN (OR (fetch BSPINPUTSTREAM of SOCKET) SOCKET] (\BSP.FLUSH.SOCKET.QUEUES SOCKET) (replace BSPUSERSTATE of SOCKET with NIL) (* ;  "Explicitly delete to avoid problem of circular structures not being collected") (replace BSPINPUTSTREAM of SOCKET with NIL]) (\RTP.ACTION [LAMBDA (SOCKET EVENT PUP) (* bvm%: " 8-Mar-84 17:52") (* ;;; "Runs the RTP 'finite state machine' according to EVENT, one of several things one might want to do to an RTP socket, either intentionally or because of an arrived pup. In the latter case, PUP is also supplied. Performs the indicated event, changing state if appropriate and setting timeouts if appropriate") (PROG ((STATE (fetch RTPSTATE of SOCKET)) NEWSTATE TIMEOUT STREAM) (SELECTC EVENT (\EVENT.OPEN (* ;  "Normal opening of a user connection. Send RFC") (COND ((NEQ STATE \STATE.CLOSED) (\RTP.ERROR SOCKET EVENT)) (T (\SEND.RFC SOCKET) (SETQ NEWSTATE \STATE.SENTRFC)))) (\EVENT.OPENLISTENING (* ;  "Nothing to do, just prepare to listen for an RFC") (COND ((NEQ STATE \STATE.CLOSED) (\RTP.ERROR SOCKET EVENT)) (T (SETQ NEWSTATE \STATE.LISTENING)))) (\EVENT.OPENIMMEDIATE (* ;  "Assume RFC done, just put in open state") (COND ((NEQ STATE \STATE.CLOSED) (\RTP.ERROR SOCKET EVENT)) (T (SETQ NEWSTATE \STATE.OPEN)))) (\EVENT.CLOSE (* ;  "Try to close connection. Several cases") (SETQ NEWSTATE (SELECTC STATE (\STATE.SENTRFC (* ;  "Tried to open the connection, now giving up") (\SEND.ABORT SOCKET) \STATE.ABORTED) (\STATE.OPEN (* ; "Normal case, send an END") (\SEND.END SOCKET) \STATE.ENDSENT) (\STATE.ENDRECEIVED (* ;  "Other guy decided to END, too, so forget what we were trying to do and just reply to this END") (\SEND.ENDREPLY SOCKET) \STATE.DALLYING) STATE))) (\EVENT.FORCECLOSE (* ; "If open, abort") (SELECTC STATE ((LIST \STATE.SENTRFC \STATE.OPEN \STATE.ENDRECEIVED \STATE.ENDSENT) (\SEND.ABORT SOCKET)) NIL) (SETQ NEWSTATE \STATE.ABORTED)) (\EVENT.RFC (* ; "Received an RFC") (SELECTC STATE (\STATE.SENTRFC (* ;  "This is the answering RFC. Its body contains the port we should talk to after this") (\BLT (LOCF (fetch FRNPORT of SOCKET)) (fetch PUPCONTENTS of PUP) WORDSPERPORT) (SETQ NEWSTATE \STATE.OPEN)) ((LIST \STATE.LISTENING \STATE.OPEN \STATE.ENDSENT) (* ;  "we were listening for someone, and this is their opening RFC, or possibly a duplicate") [COND ((fetch LISTENING of SOCKET) (\SEND.ANSWERING.RFC SOCKET PUP) (COND ((EQ STATE \STATE.LISTENING) (SETQ NEWSTATE \STATE.OPEN]) (\RTP.ERROR SOCKET EVENT PUP))) (\EVENT.ABORT (* ; "Received an ABORT pup") (SELECTC STATE ((LIST \STATE.CLOSED \STATE.LISTENING) (* ; "Shouldn't happen") (\RTP.ERROR SOCKET EVENT PUP)) NIL) (SETQ NEWSTATE \STATE.ABORTED)) (\EVENT.END (* ; "Received END") (SELECTC STATE ((LIST \STATE.OPEN \STATE.ENDRECEIVED) (* ; "Note that we have received the end, but don't do anything until our user decides to accept the END") (SETQ STREAM (fetch BSPINPUTSTREAM of SOCKET)) (SETQ NEWSTATE (COND ([OR (AND (fetch BSPCURRENTPUP of STREAM ) (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM))) (IGREATERP (fetch %#UNREADPUPS of SOCKET) (COND ((fetch BSPCURRENTPUP of STREAM) 1) (T 0] (* ;  "There is still input waiting to be read, so can't end just yet") \STATE.ENDRECEIVED) (T (* ; "Okay, we're ready to end") (\SEND.ENDREPLY SOCKET) \STATE.DALLYING)))) ((LIST \STATE.ENDSENT \STATE.DALLYING) (* ;  "We've already sent an END, but other guy wants to end. Obey.") (\SEND.ENDREPLY SOCKET) (SETQ NEWSTATE \STATE.DALLYING)) (\RTP.ERROR SOCKET EVENT PUP))) (\EVENT.ENDREPLY (* ; "Received ENDREPLY") (SELECTC STATE (\STATE.ENDSENT (* ;  "This is the reply to our END. Echo ENDREPLY so partner can stop dallying") (\SEND.ENDREPLY SOCKET) (SETQ NEWSTATE \STATE.CLOSED)) (\STATE.DALLYING (* ;  "We send ENDREPLY to partner's END. This is the echoing ENDREPLY, so everything is cool") (SETQ NEWSTATE \STATE.CLOSED)) (\RTP.ERROR SOCKET EVENT PUP))) (\EVENT.TIMEOUT (* ;  "RTPTIMER expired, probably want to retransmit something") (* ;  "Might be nice, perhaps, if we kept copies of these pups that we might want to retransmit") (COND ((EQ STATE \STATE.DALLYING) (SETQ NEWSTATE \STATE.CLOSED)) ((AND (fetch BSPINITTIMER of SOCKET) (TIMEREXPIRED? (fetch BSPINITTIMER of SOCKET))) (\SEND.ABORT SOCKET) (SETQ NEWSTATE \STATE.CLOSED) (replace BSPINITTIMER of SOCKET with NIL)) (T (SELECTC STATE (\STATE.SENTRFC (\SEND.RFC SOCKET)) (\STATE.ENDSENT (\SEND.END SOCKET)) NIL)))) (ERROR "Unknown RTP event" EVENT)) [COND (NEWSTATE (replace RTPSTATE of SOCKET with (SETQ STATE NEWSTATE)) (NOTIFY.EVENT (fetch RTPEVENT of SOCKET)) (AND (fetch BSPINPUTEVENT of SOCKET) (NOTIFY.EVENT (fetch BSPINPUTEVENT of SOCKET] (SELECTC STATE ((LIST \STATE.SENTRFC \STATE.ENDSENT \STATE.DALLYING) (SETUPTIMER (SETQ TIMEOUT (COND ((EQ STATE \STATE.DALLYING) \RTP.DALLY.TIMEOUT) (T \RFC.TIMEOUT))) (fetch RTPTIMER of SOCKET)) (replace RTPTIMEOUT of SOCKET with TIMEOUT)) (replace RTPTIMEOUT of SOCKET with 0]) (\RTP.ERROR [LAMBDA (SOCKET EVENT FOREIGNPUP) (* bvm%: " 8-Mar-84 17:52") (COND (PUPTRACEFLG (PRIN1 "[Unexpected RTP event " PUPTRACEFILE) (PRINTCONSTANT EVENT RTPEVENTS PUPTRACEFILE "\EVENT.") (PRIN1 " when in state " PUPTRACEFILE) (PRINTCONSTANT (fetch RTPSTATE of SOCKET) RTPSTATES PUPTRACEFILE "\STATE.") (PRIN1 "] " PUPTRACEFILE]) (\RTP.SHOW.FAILURE [LAMBDA (SOCKET PUP REASON) (* bvm%: "29-Mar-85 21:38") (LET ((FAILURESTRING (fetch BSPFAILURESTRING of SOCKET))) (COND ((NEQ FAILURESTRING T) (* ;  "Only if we haven't done this already") (COND ((NEQ FAILURESTRING 'RETURN) (* ;  "RETURN means caller wants to see it, not user") [COND (PUP (printout PROMPTWINDOW T "From " (ETHERHOSTNAME (fetch PUPSOURCE of PUP) T))) (T (printout PROMPTWINDOW T (ETHERHOSTNAME (fetch FRNPORT of SOCKET) T] (PRIN1 ": " PROMPTWINDOW) (COND (FAILURESTRING (printout PROMPTWINDOW FAILURESTRING " because: "))) (PRIN1 REASON PROMPTWINDOW))) (replace BSPFAILURESTRING of SOCKET with T) (* ; "Don't do this again") (replace BSPFAILUREREASON of SOCKET with REASON]) (\RTP.FILTER [LAMBDA (SOCKET PUP CHECKFRNPORT CHECKID) (* bvm%: "29-Mar-85 21:25") (* ;; "True if PUP is a valid RTP pup for this socket, checking frnport and/or id as indicated") (AND (NEQ (fetch PUPDESTHOST of PUP) 0) [OR (NOT CHECKFRNPORT) (PROGN [COND ((EQ (fetch (BSPSOC FRNNET) of SOCKET) 0) (* ;  "We didn't know the local net when we opened the socket; perhaps we do now") (replace (BSPSOC FRNNET) of SOCKET with (fetch PUPDESTNET of PUP] (AND (EQ (fetch PUPSOURCE of PUP) (fetch (BSPSOC FRNPORT) of SOCKET)) (EQ (fetch PUPSOURCESOCKETHI of PUP) (fetch (BSPSOC FRNSOCKETHI) of SOCKET)) (EQ (fetch PUPSOURCESOCKETLO of PUP) (fetch (BSPSOC FRNSOCKETLO) of SOCKET] (OR (NOT CHECKID) (AND (EQ (fetch PUPIDHI of PUP) (\HINUM (fetch CONNID of SOCKET))) (EQ (fetch PUPIDLO of PUP) (\LONUM (fetch CONNID of SOCKET]) (\SEND.ABORT [LAMBDA (SOCKET) (* bvm%: " 8-Mar-84 17:52") (PROG ((PUP (ALLOCATE.PUP))) (\FILLRTPPUP SOCKET PUP \PT.ABORT (IPLUS BYTESPERWORD \PUPOVLEN)) (* ;  "Length counts the abort code word") (\PUTBASE (fetch PUPCONTENTS of PUP) 0 0) (* ; "Abort code") (PUTPUPSTRING PUP (COND ((EQ (fetch RTPSTATE of SOCKET) \STATE.SENTRFC) "Connection attempt aborted") (T "Connection aborted"))) (* ; "Explanatory string") (SENDPUP (fetch PUPSOC of SOCKET) PUP]) (\SEND.ANSWERING.RFC [LAMBDA (SOCKET IPUP) (* bvm%: " 8-Mar-84 17:52") (* ;;; "sends an RFC in response to the RFC in IPUP. The connection port we send is self, since we can only support one connection in this model") (PROG ((OPUP (ALLOCATE.PUP))) (COND ((EQ (fetch RTPSTATE of SOCKET) \STATE.LISTENING) (* ;; "We were waiting for this. If not, this is a duplicate RFC and we just throw it away after retransmitting the answering RFC") (replace CONNID of SOCKET with (fetch PUPID of IPUP)) (\BLT (LOCF (fetch FRNPORT of SOCKET)) (fetch PUPCONTENTS of IPUP) WORDSPERPORT) (* ;  "Set foreign connection port for this connection. Our LCLPORT should already be correct") )) (\FILLRTPPUP SOCKET OPUP \PT.RFC (IPLUS (UNFOLD WORDSPERPORT BYTESPERWORD) \PUPOVLEN)) (\BLT (LOCF (fetch DEST of OPUP)) (LOCF (fetch SOURCE of IPUP)) WORDSPERPORT) (* ;  "Send this pup to the port by which IPUP arrived, not by the RTP connection port") (\BLT (fetch PUPCONTENTS of OPUP) (LOCF (fetch LCLPORT of SOCKET)) WORDSPERPORT) (* ; "Our connection port is self") (replace EPREQUEUE of OPUP with 'FREE) (SENDPUP (fetch PUPSOC of SOCKET) OPUP]) (\SEND.END [LAMBDA (SOCKET) (* bvm%: " 8-FEB-83 18:22") (SENDPUP (fetch PUPSOC of SOCKET) (\FILLRTPPUP SOCKET NIL \PT.END \PUPOVLEN]) (\SEND.ENDREPLY [LAMBDA (SOCKET) (* bvm%: " 8-FEB-83 18:23") (SENDPUP (fetch PUPSOC of SOCKET) (\FILLRTPPUP SOCKET NIL \PT.ENDREPLY \PUPOVLEN]) (\SEND.RFC [LAMBDA (SOCKET) (* bvm%: "25-Aug-84 23:08") (* ;;; "Sends an initiating RFC on SOCKET") (PROG ((PUP (ALLOCATE.PUP))) (replace PUPLENGTH of PUP with (OR (IPLUS (UNFOLD WORDSPERPORT BYTESPERWORD) \PUPOVLEN) \PUPOVLEN)) (replace PUPTYPE of PUP with \PT.RFC) (replace PUPID of PUP with (fetch CONNID of SOCKET)) (\BLT (LOCF (fetch PUPDEST of PUP)) (LOCF (fetch FRNPORT of SOCKET)) (TIMES 2 WORDSPERPORT)) (replace PUPSOURCE of PUP with 0) (if (\ROUTE.PUP PUP) then (* ;  "Find out what net it will send on, then make that our local port") (replace LCLPORT of SOCKET with (fetch PUPSOURCE of PUP))) (\BLT (fetch PUPCONTENTS of PUP) (LOCF (fetch LCLPORT of SOCKET)) WORDSPERPORT) (* ; "Connection port = self") (SENDPUP (fetch PUPSOC of SOCKET) PUP]) (\FILLRTPPUP [LAMBDA (SOCKET PUP TYPE LENGTH) (* bvm%: " 8-FEB-83 18:21") (* ;;; "Fills in an RTP pup for SOCKET. TYPE is the pup type, LENGTH its length. We fill in also the ID (connection ID) and local and foreign ports (from socket)") (OR PUP (SETQ PUP (ALLOCATE.PUP))) (replace PUPLENGTH of PUP with (OR LENGTH \PUPOVLEN)) (replace TYPEWORD of PUP with TYPE) (* ;  "Clears TCONTROL while setting TYPE") (replace PUPID of PUP with (fetch CONNID of SOCKET)) (\SETRTPPORTS SOCKET PUP) PUP]) (\SETRTPPORTS [LAMBDA (SOCKET PUP) (* bvm%: " 2-NOV-83 14:33") (* ;  "Fill in both Frn and lcl ports in one move") (\BLT (LOCF (fetch DEST of PUP)) (LOCF (fetch FRNPORT of SOCKET)) (ITIMES WORDSPERPORT 2]) ) (DEFINEQ (\BSPINIT [LAMBDA NIL (* bvm%: "28-Apr-85 14:12") (* ;; "Defines the BSP device, so that you can BIN and BOUT on BSP streams") (DECLARE (GLOBALVARS \BSPFDEV)) (SETQ \BSPFDEV (create FDEV DEVICENAME _ (FUNCTION BSP) RESETABLE _ NIL RANDOMACCESSP _ NIL PAGEMAPPED _ NIL FDBINABLE _ T FDBOUTABLE _ T BUFFERED _ T CLOSEFILE _ (FUNCTION CLOSEBSPSTREAM) DELETEFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) OPENFILE _ (FUNCTION NILL) READPAGES _ (FUNCTION \IS.NOT.RANDACCESSP) SETFILEINFO _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \IS.NOT.RANDACCESSP) GETFILENAME _ (FUNCTION NILL) REOPENFILE _ (FUNCTION NILL) EVENTFN _ (FUNCTION \BSPEVENTFN) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) READP _ (FUNCTION BSPREADP) EOFP _ (FUNCTION BSPEOFP) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) GETFILEPTR _ (FUNCTION \BSP.GETFILEPTR) SETFILEPTR _ (FUNCTION \BSP.SETFILEPTR) BACKFILEPTR _ (FUNCTION \BSPBACKFILEPTR) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \BSPWRITEBLOCK) GETNEXTBUFFER _ (FUNCTION \BSP.GETNEXTBUFFER) FORCEOUTPUT _ (FUNCTION BSPFORCEOUTPUT) LASTC _ (FUNCTION \ILLEGAL.DEVICEOP) GETEOFPTR _ (FUNCTION \IS.NOT.RANDACCESSP))) (\DEFINEDEVICE NIL \BSPFDEV]) (\BSPEVENTFN [LAMBDA (DEV EVENT) (* bvm%: " 8-Mar-84 17:29") (SELECTQ EVENT (BEFORELOGOUT (\BSP.CLOSE.OPEN.SOCKETS)) ((AFTERSYSOUT AFTERMAKESYS AFTERLOGOUT AFTERSAVEVM) (\BSP.CLOSE.OPEN.SOCKETS) (\REMOVEDEVICE.NAMES DEV)) NIL]) (\BSP.CLOSE.OPEN.SOCKETS [LAMBDA NIL (* bvm%: "28-Apr-85 14:37") (for SOC in (for S in \BSPSOCKETS when (SELECTC (fetch (BSPSOC RTPSTATE) of S) ((LIST \STATE.CLOSED \STATE.LISTENING \STATE.ABORTED) NIL) T) collect S) do (WAKE.PROCESS (fetch RTPPROCESS of SOC)) (* ;; "Deadlock avoidance. If process is suspended after exit, as is the default, wake it up, so as to make sure it is not in a place that is holding on to the monitor lock.") (CLOSERTPSOCKET SOC 0) (BLOCK]) ) (* ; "Creating BSP stream") (DEFINEQ (OPENBSPSTREAM [LAMBDA (SOCKET OTHERPUPHANDLER ERRORHANDLER IOTIMEOUT IOTIMEOUTFN WHENCLOSEDFN FAILURESTRING) (* bvm%: " 6-Oct-86 11:46") (* ;;; "SOCKET is either an open RTP socket, or a host specification to which to open an rtp socket. This procedure fills in the parameters to make it a BSP stream, or returns the result of the OPENRTPSOCKET on failure.") (PROG (INSTREAM OUTSTREAM SOCKETPROC) [COND ((NOT (type? BSPSOC SOCKET)) (* ;  "Interpret it as a port to which to establish a user RTP connection") (SETQ SOCKET (OPENRTPSOCKET SOCKET 'USER NIL NIL NIL FAILURESTRING] (if (AND SOCKET (type? BSPSOC SOCKET)) then (* ; "Check that socket is good") (SELECTC (fetch RTPSTATE of SOCKET) ((LIST \STATE.OPEN \STATE.ENDRECEIVED)) (RETURN NIL)) else (* ; "return possible error message") (RETURN SOCKET)) [replace RCVBYTEID of SOCKET with (replace RCVINTERRUPTID of SOCKET with (replace XMITBYTEID of SOCKET with (replace XMITINTERRUPTID of SOCKET with (replace LASTACKID of SOCKET with (fetch CONNID of SOCKET ] (* ;  "All ID's start out as the connection ID") (replace ADATATIMEOUT of SOCKET with \BSP.INITIAL.ADATATIMEOUT) (replace MAXPUPALLOC of SOCKET with \BSP.INITIAL.MAXPUPALLOC) (\BSP.FLUSH.SOCKET.QUEUES SOCKET) [replace BSPINPUTSTREAM of SOCKET with (SETQ INSTREAM (create STREAM DEVICE _ \BSPFDEV ACCESS _ 'INPUT] (PROGN (replace STRMBOUTFN of INSTREAM with (FUNCTION \BSP.OTHERBOUT)) (* ;  "For backward compatibility, have to make lisp think we can print on the input side") (replace ACCESSBITS of INSTREAM with BothBits)) [replace BSPOUTPUTSTREAM of INSTREAM with (SETQ OUTSTREAM (create STREAM DEVICE _ \BSPFDEV ACCESS _ 'OUTPUT] (replace BSPSOC of INSTREAM with (replace BSPSOC of OUTSTREAM with SOCKET)) [replace %#UNREADPUPS of SOCKET with (replace %#UNACKEDPUPS of SOCKET with (replace %#UNACKEDBYTES of SOCKET with (replace PUPALLOC of SOCKET with (replace BYTESPERPUP of SOCKET with (replace BYTEALLOC of SOCKET with (replace PUPALLOCCOUNT of SOCKET with (replace ADATACOUNT of SOCKET with 0] (replace BSPFAILURESTRING of SOCKET with 'RETURN) (* ;  "Connection open now, so don't complain when it closes, just note reason") (SETUPTIMER 1 (fetch BSPTIMER of SOCKET)) (replace BSPTIMEOUT of SOCKET with 1) (* ;  "\SETBSPTIMEOUT will soon fix this") (OR (fetch BSPINACTIVITYTIMEOUT of SOCKET) (replace BSPINACTIVITYTIMEOUT of SOCKET with \BSP.INACTIVITY.TIMEOUT)) (SETUPTIMER (fetch BSPINACTIVITYTIMEOUT of SOCKET) (fetch INACTIVITYTIMER of SOCKET)) (replace BSPINPUTHANDLER of SOCKET with (FUNCTION \BSP.HANDLE.INPUT)) (replace BSPOTHERPUPFN of SOCKET with (OR OTHERPUPHANDLER (FUNCTION RELEASE.PUP))) (replace BSPERRORHANDLER of SOCKET with (OR ERRORHANDLER (FUNCTION \BSP.DEFAULT.ERROR.HANDLER ))) (replace BSPIOTIMEOUT of SOCKET with (FIXP IOTIMEOUT)) (replace IOTIMEOUTFN of SOCKET with IOTIMEOUTFN) (replace BSPWHENCLOSEDFN of SOCKET with WHENCLOSEDFN) (replace BSPINPUTEVENT of SOCKET with (CREATE.EVENT (CONCAT (PROCESS.NAME (SETQ SOCKETPROC (fetch RTPPROCESS of SOCKET))) "#INPUT"))) (BLOCK) (* ; "Let the socket process run to handle any stuff that's arrived since the RTP connection was opened") (WAKE.PROCESS SOCKETPROC) (* ;  "It may be stuck in a long timeout") (RETURN INSTREAM]) (\SMASHBSPSTREAM [LAMBDA (OPENSTREAM OLDSTREAM) (* bvm%: "28-OCT-83 18:50") (* ;;; "Hack for use with FTP error recovery. Copies info from OPENSTREAM into OLDSTREAM, making OLDSTREAM be the stream that controls this connection") (SETQ OLDSTREAM (\DTEST OLDSTREAM 'STREAM)) (PROG ([SOCKET (fetch BSPSOC of (SETQ OPENSTREAM (\DTEST OPENSTREAM 'STREAM] (OUTSTREAM (fetch BSPOUTPUTSTREAM of OPENSTREAM))) (with BSPSTREAM OLDSTREAM (* ; "Smash BSP-specific fields") (SETQ BSPOUTPUTSTREAM OUTSTREAM) (SETQ BSPCURRENTPUP (fetch BSPCURRENTPUP of OPENSTREAM)) (SETQ MARKPENDING (fetch MARKPENDING of OPENSTREAM))) (with STREAM OLDSTREAM (SETQ CBUFSIZE (fetch CBUFSIZE of OPENSTREAM)) (SETQ CPPTR (fetch CPPTR of OPENSTREAM)) (SETQ COFFSET (fetch COFFSET of OPENSTREAM)) (SETQ ACCESS (fetch ACCESS of OPENSTREAM))) (UNINTERRUPTABLY (replace BSPSOC of OLDSTREAM with (replace BSPSOC of OUTSTREAM with SOCKET)) (replace BSPINPUTSTREAM of SOCKET with OLDSTREAM))]) (BSPOUTPUTSTREAM [LAMBDA (BSPSTREAM) (* bvm%: "10-MAY-83 18:38") (* ;  "Returns the output side of a BSPSTREAM") (ffetch BSPOUTPUTSTREAM of (\DTEST BSPSTREAM 'STREAM]) (BSPINPUTSTREAM [LAMBDA (STREAM) (* bvm%: "28-Apr-85 13:56") (LET [(SOC (ffetch BSPSOC of (\DTEST STREAM 'STREAM] (AND SOC (fetch BSPINPUTSTREAM of SOC]) (BSPFRNADDRESS [LAMBDA (STREAM) (* bvm%: "28-Apr-85 14:00") (LET ((SOC (fetch BSPSOC of STREAM))) (AND SOC (fetch FRNPUPADDRESS of SOC]) (CLOSEBSPSTREAM [LAMBDA (STREAM TIMEOUT) (* bvm%: "29-Mar-85 21:21") (* ;; "Closes BSP stream. TIMEOUT is how long to wait for partner to agree. Returns true if closed amiably, NIL if aborted. SOCKET is dead afterwards in any case") (PROG [(SOCKET (\DTEST (fetch BSPSOC of STREAM) 'BSPSOC] (OR (FIXP TIMEOUT) (SETQ TIMEOUT \RTP.DEFAULTTIMEOUT)) (WITH.MONITOR (ffetch BSPLOCK of SOCKET) (PROG ((INPUTSTREAM (fetch BSPINPUTSTREAM of SOCKET)) TIMER) [COND ((SELECTC (fetch RTPSTATE of SOCKET) ((LIST \STATE.OPEN \STATE.ENDRECEIVED) T) NIL) (BSPFORCEOUTPUT (fetch BSPOUTPUTSTREAM of INPUTSTREAM)) (* ;  "Send any waiting output, and wait for all our output to be acked") (SETQ TIMER (SETUPTIMER TIMEOUT)) (while (OR (NEQ (fetch %#UNACKEDPUPS of SOCKET) 0) (fetch INTERRUPTOUT of SOCKET)) do (\BSP.FLUSHINPUT INPUTSTREAM) (* ; "Discard input while waiting") (COND ((AND (SELECTC (fetch RTPSTATE of SOCKET) ((LIST \STATE.OPEN \STATE.ENDRECEIVED) T) NIL) (NOT (TIMEREXPIRED? TIMER))) (MONITOR.AWAIT.EVENT (ffetch BSPLOCK of SOCKET) (fetch BSPINPUTEVENT of SOCKET) TIMER T)) (T (* ;  "Timed out or connection went bad") (SETQ TIMEOUT 0) (RETURN] (* ;; "now close the socket, continuing to flush input while we wait") (OR (CLOSERTPSOCKET SOCKET TIMEOUT) (SETQ TIMEOUT 0)))) (BLOCK) (RETURN (NEQ TIMEOUT 0]) (\BSP.FLUSHINPUT [LAMBDA (STREAM) (* bvm%: " 9-MAY-83 16:07") (* ;  "Flushes any BSP input currently waiting") (while (NULL (\BSP.PREPARE.INPUT STREAM 0)) do (* ; "Normal data waiting, flush it") (\BSP.CLEANUP.INPUT STREAM]) (BSPOPENP [LAMBDA (STREAM TYPE) (* bvm%: "25-Aug-84 22:16") (* ;;; "True if STREAM is open for the indicated TYPE of i/o: NIL (either), INPUT, OUTPUT, or BOTH. E.g. STREAM may be open for OUTPUT but not INPUT if partner has requested an end.") (PROG [(SOCKET (fetch BSPSOC of (\DTEST STREAM 'STREAM] (RETURN (AND SOCKET (OR (SELECTC (fetch RTPSTATE of SOCKET) (\STATE.OPEN T) (\STATE.ENDRECEIVED (OR (NULL TYPE) (EQ TYPE 'OUTPUT))) (\STATE.ENDSENT (OR (NULL TYPE) (EQ TYPE 'INPUT))) NIL) (AND (EQ TYPE 'INPUT) (OR (IGREATERP (fetch %#UNREADPUPS of SOCKET) 0) (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM]) (GETBSPUSERINFO [LAMBDA (STREAM) (* bvm%: "10-MAY-83 17:06") (ffetch BSPUSERSTATE of (\DTEST (ffetch BSPSOC of (\DTEST STREAM 'STREAM)) 'BSPSOC]) (SETBSPUSERINFO [LAMBDA (STREAM VALUE) (* bvm%: " 9-MAY-83 16:12") (freplace BSPUSERSTATE of (ffetch BSPSOC of (\DTEST STREAM 'STREAM)) with VALUE]) ) (DEFINEQ (CREATEBSPSTREAM [LAMBDA (SOCKET OTHERPUPHANDLER ERRORHANDLER IOTIMEOUT IOTIMEOUTFN WHENCLOSEDFN) (* bvm%: "13-JUN-83 18:21") (OPENBSPSTREAM SOCKET OTHERPUPHANDLER ERRORHANDLER IOTIMEOUT IOTIMEOUTFN WHENCLOSEDFN]) (ENDBSPSTREAM [LAMBDA (STREAM TIMEOUT) (* bvm%: "13-JUN-83 18:22") (CLOSEBSPSTREAM STREAM TIMEOUT]) ) (* ; "BSP stream functions") (DEFINEQ (BSPBIN [LAMBDA (STREAM) (* bvm%: "11-Jul-84 14:44") (\BUFFERED.BIN STREAM]) (\BSP.GETNEXTBUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* bvm%: "28-Aug-84 21:31") (* ;;; "Generic buffer refiller for BSP streams") (PROG (ERRCODE) (RETURN (SELECTQ WHATFOR (READ (COND ((NULL (SETQ ERRCODE (\BSP.PREPARE.INPUT STREAM))) T) ((OR (NEQ ERRCODE 'MARK.ENCOUNTERED) (NULL NOERRORFLG)) (BSP.INPUT.ERROR STREAM ERRCODE)))) (WRITE (SETQ STREAM (OR (ffetch BSPOUTPUTSTREAM of (\DTEST STREAM 'STREAM)) STREAM)) (* ;  "In case we were given the input side") (COND ((NULL (SETQ ERRCODE (\BSP.PREPARE.OUTPUT STREAM))) T) (T (BSP.OUTPUT.ERROR STREAM ERRCODE) (* ;  "If that returned, then client must want no error") (RETFROM (OR (STKPOS '\BUFFERED.BOUT) (STKPOS '\BUFFERED.BOUTS) (ERROR "Bad state for Bout on BSP stream" STREAM)) NIL T)))) (SHOULDNT]) (BSPPEEKBIN [LAMBDA (STREAM NOERRORFLG) (* bvm%: "11-Jul-84 15:04") (\BUFFERED.PEEKBIN STREAM NOERRORFLG]) (BSPREADP [LAMBDA (STREAM) (* bvm%: " 7-Feb-84 15:56") (* ;;; "true if there is input (not a mark) waiting on STREAM") (PROG (SOCKET) (COND ((fetch MARKPENDING of STREAM) (RETURN NIL)) ((AND (fetch BSPCURRENTPUP of STREAM) (ILESSP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM))) (RETURN T))) (RETURN (COND ((IGREATERP (fetch %#UNREADPUPS of (SETQ SOCKET (fetch BSPSOC of STREAM))) (COND ((fetch BSPCURRENTPUP of STREAM) 1) (T 0))) (SELECTC (fetch PUPTYPE of (\QUEUEHEAD (fetch BSPINPUTQ of SOCKET))) ((LIST \PT.MARK \PT.AMARK) NIL) T]) (BSPEOFP [LAMBDA (STREAM) (* bvm%: "28-Apr-85 14:08") (* ;;; "true if bsp STREAM is at end of file, i.e. is at a mark") (COND ([NULL (ffetch BSPOUTPUTSTREAM of (SETQ STREAM (\DTEST STREAM 'STREAM] (* ;  "Output file is always at EOF. Not sure EOFP should be used this way") T) ((ffetch MARKPENDING of STREAM) T) ((AND (ffetch BSPCURRENTPUP of STREAM) (ILESSP (ffetch COFFSET of STREAM) (ffetch CBUFSIZE of STREAM))) NIL) (T (EQ (\BSP.PREPARE.INPUT STREAM) 'MARK.ENCOUNTERED]) (\BSPBACKFILEPTR [LAMBDA (STREAM) (* bvm%: " 1-JUN-83 12:22") (COND ((AND (fetch BSPOUTPUTSTREAM of STREAM) (fetch CPPTR of STREAM) (IGREATERP (fetch COFFSET of STREAM) 0)) (add (fetch COFFSET of STREAM) -1)) (T (ERROR "Can't back up this BSP Stream" STREAM]) (\BSP.PREPARE.INPUT [LAMBDA (STREAM TIMEOUT) (* bvm%: "29-Mar-85 21:23") (* ;;; "Prepares INPUP for SOCKET, waiting at most TIMEOUT if supplied (else BSPIOTIMEOUT if in stream else forever). Returns NIL on success, an error code on failure.") (WITH.MONITOR (fetch BSPLOCK of (fetch BSPSOC of STREAM)) [PROG (PUP ERRCODE SOCKET) LP (COND [(NULL (fetch BSPCURRENTPUP of STREAM)) (SETQ SOCKET (fetch BSPSOC of STREAM)) (OR TIMEOUT (SETQ TIMEOUT (fetch BSPIOTIMEOUT of SOCKET))) (BLOCK) (* ;; "Note: we always yield, even before checking to see if pups are available. That way a process that is sitting reading from the bytestream at least yields once per pup") (COND ((SETQ ERRCODE (bind (TIMER _ (AND TIMEOUT (NEQ TIMEOUT 0) (SETUPTIMER TIMEOUT))) do [COND ((IGREATERP (fetch %#UNREADPUPS of SOCKET) 0) (RETURN)) ((NOT (BSPOPENP STREAM 'INPUT)) (RETURN 'BAD.STATE.FOR.BIN)) ((AND TIMEOUT (OR (EQ TIMEOUT 0) (TIMEREXPIRED? TIMER))) (RETURN (COND ((fetch IOTIMEOUTFN of SOCKET) (APPLY* (fetch IOTIMEOUTFN of SOCKET) STREAM 'INPUT)) (T 'BIN.TIMEOUT] (MONITOR.AWAIT.EVENT (fetch BSPLOCK of SOCKET) (fetch BSPINPUTEVENT of SOCKET) TIMER TIMER))) (RETURN ERRCODE))) (replace BSPCURRENTPUP of STREAM with (OR (SETQ PUP (\DEQUEUE (fetch BSPINPUTQ of SOCKET))) (SHOULDNT))) (replace COFFSET of STREAM with 0) (* ;  "Set byte pointers for reading bytes from pup") (replace MARKPENDING of STREAM with (SELECTC (fetch PUPTYPE of PUP) ((LIST \PT.MARK \PT.AMARK) (replace CBUFSIZE of STREAM with 0) (* ;  "Inhibit BIN microcode from reading mark") T) (PROGN (replace CPPTR of STREAM with (fetch PUPCONTENTS of PUP)) (replace CBUFSIZE of STREAM with (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN)) NIL] ((AND (IGEQ (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM)) (NOT (fetch MARKPENDING of STREAM))) (* ; "Current pup is exhausted") (\BSP.CLEANUP.INPUT STREAM) (GO LP))) (RETURN (AND (fetch MARKPENDING of STREAM) 'MARK.ENCOUNTERED])]) (\BSP.GETFILEPTR [LAMBDA (STREAM) (* bvm%: " 2-NOV-83 14:31") (IPLUS (fetch BSPFILEPTR of STREAM) (COND ((fetch CPPTR of STREAM) (fetch COFFSET of STREAM)) (T 0]) (\BSP.DECLARE.FILEPTR [LAMBDA (STREAM ADR) (* bvm%: "28-Apr-85 14:14") (replace BSPFILEPTR of STREAM with ADR]) (\BSP.SETFILEPTR [LAMBDA (STREAM INDX) (* bvm%: "28-Apr-85 14:10") (PROG (SKIPBYTES) (RETURN (COND ((AND (fetch BSPOUTPUTSTREAM of STREAM) (IGEQ (SETQ SKIPBYTES (IDIFFERENCE INDX (\BSP.GETFILEPTR STREAM))) 0)) (* ;  "Can only move file pointer on input, and then only forward") (\BSP.SKIPBYTES STREAM SKIPBYTES)) (T (\IS.NOT.RANDACCESSP STREAM]) (\BSP.SKIPBYTES [LAMBDA (STREAM NBYTES) (* bvm%: "28-Aug-84 22:37") (PROG (ERRCODE BYTESLEFT) LP [COND ((SETQ ERRCODE (\BSP.PREPARE.INPUT STREAM)) (RETURN (BSP.INPUT.ERROR STREAM ERRCODE] (COND ([IGREATERP NBYTES (SETQ BYTESLEFT (IDIFFERENCE (fetch CBUFSIZE of STREAM) (fetch COFFSET of STREAM] (SETQ NBYTES (IDIFFERENCE NBYTES BYTESLEFT)) (replace COFFSET of STREAM with (fetch CBUFSIZE of STREAM)) (\BSP.CLEANUP.INPUT STREAM) (GO LP)) (T (add (fetch COFFSET of STREAM) NBYTES]) (\BSP.CLEANUP.INPUT [LAMBDA (STREAM) (* bvm%: " 2-NOV-83 14:23") (* ;;; "Called after last byte has been read from this input pup") (PROG [(PUP (\DTEST (fetch BSPCURRENTPUP of STREAM) 'ETHERPACKET)) (SOCKET (\DTEST (fetch BSPSOC of STREAM) 'BSPSOC] (\BSPINCFILEPTR STREAM (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN)) (RELEASE.PUP PUP) (replace BSPCURRENTPUP of STREAM with NIL) (replace CBUFSIZE of STREAM with 0) (replace CPPTR of STREAM with NIL) (add (fetch %#UNREADPUPS of SOCKET) -1) (COND ((fetch SENTZEROALLOC of SOCKET) (* ;  "Our last ack said we had no allocation, so send a gratuitous ack now to get partner going again") (\SEND.ACK SOCKET]) (BSPBOUT [LAMBDA (STREAM BYTE) (* bvm%: "11-Jul-84 15:03") (\BOUT (OR (ffetch BSPOUTPUTSTREAM of (\DTEST STREAM 'STREAM)) STREAM) BYTE]) (\BSP.OTHERBOUT [LAMBDA (STREAM BYTE) (* bvm%: "11-Jul-84 14:52") (\BOUT (OR (ffetch BSPOUTPUTSTREAM of (\DTEST STREAM 'STREAM)) (LISPERROR "FILE NOT OPEN" STREAM)) BYTE]) (\BSPWRITEBLOCK [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "11-Jul-84 14:48") (\BUFFERED.BOUTS (OR (ffetch BSPOUTPUTSTREAM of (\DTEST STREAM 'STREAM)) STREAM) BASE OFF NBYTES]) (BSPFORCEOUTPUT [LAMBDA (STREAM DEMANDINGLY) (* bvm%: "11-Jul-84 15:05") (* ;;; "Forces any buffered output to be transmitted now. If DEMANDINGLY is true, sends it as an ADATA") (WITH.MONITOR (fetch BSPLOCK of (\DTEST (ffetch BSPSOC of (SETQ STREAM (OR [ffetch BSPOUTPUTSTREAM of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM))) 'BSPSOC)) [PROG ((PUP (fetch BSPCURRENTPUP of STREAM))) (COND (PUP (\BSP.SENDBUFFER STREAM PUP DEMANDINGLY])]) (\BSP.SENDBUFFER [LAMBDA (STREAM PUP DEMANDINGLY) (* bvm%: "11-Jul-84 14:36") (* ;;; "Transmits PUP, the current output packet of STREAM, then resets stream to output idle. Must be called while owning the bsp lock for this connection") (PROG ((SOCKET (fetch BSPSOC of STREAM)) (NBYTES (fetch COFFSET of STREAM))) (* ;  "number of bytes in this pup. Always greater than zero given the way we set things up") (replace PUPLENGTH of PUP with (IPLUS NBYTES \PUPOVLEN)) (replace PUPID of PUP with (fetch XMITBYTEID of SOCKET)) (* ;  "Give it the latest ID, and advance it") (\SETRTPPORTS SOCKET PUP) (replace AUXWORD of PUP with (fetch ADATACOUNT of SOCKET)) (* ;  "Lets us know where this pup falls with respect to ADATA's we may send") (UNINTERRUPTABLY (add (fetch XMITBYTEID of SOCKET) NBYTES) (* ;  "Note: this is wrong if \OVERFLOW ~= 0") (\BSPINCFILEPTR STREAM NBYTES) (add (fetch %#UNACKEDPUPS of SOCKET) 1) (add (fetch %#UNACKEDBYTES of SOCKET) NBYTES) (add (fetch PUPALLOC of SOCKET) -1) (* ;  "Adjust allocation information to account for pup/bytes we are sending to partner") (add (fetch BYTEALLOC of SOCKET) (IMINUS NBYTES)) (replace BSPCURRENTPUP of STREAM with NIL) (replace CBUFMAXSIZE of STREAM with (replace CBUFSIZE of STREAM with 0)) (replace CPPTR of STREAM with NIL) (\TRANSMIT.STRATEGY SOCKET PUP (AND DEMANDINGLY T)) (* ; "Maybe make it an ADATA") (replace EPREQUEUE of PUP with (fetch BSPOUTPUTQ of SOCKET)) (* ;  "Retain pup for possible retransmission") (SENDPUP (fetch PUPSOC of SOCKET) PUP)) (\SETBSPTIMEOUT SOCKET]) (\BSP.PREPARE.OUTPUT [LAMBDA (STREAM TIMEOUT) (* bvm%: "29-Mar-85 21:23") (* ;;; "Prepares OUTPUP for SOCKET, waiting at most TIMEOUT if supplied (else BSPIOTIMEOUT if in stream else forever). Returns NIL on success, an error code on failure. We only need to wait if allocation is exhausted") (WITH.MONITOR (fetch BSPLOCK of (fetch BSPSOC of STREAM)) (PROG (PUP ERRCODE SOCKET) LP (COND [(NULL (SETQ PUP (fetch BSPCURRENTPUP of STREAM))) (SETQ SOCKET (fetch BSPSOC of STREAM)) (OR TIMEOUT (SETQ TIMEOUT (fetch BSPIOTIMEOUT of SOCKET))) (COND ((SETQ ERRCODE (bind (TIMER _ (AND TIMEOUT (NEQ TIMEOUT 0) (SETUPTIMER TIMEOUT))) do [COND ((NOT (BSPOPENP STREAM 'OUTPUT)) (RETURN 'BAD.STATE.FOR.BOUT)) ((AND (IGREATERP (fetch PUPALLOC of SOCKET) 0) (IGREATERP (fetch BYTEALLOC of SOCKET) 0)) (* ; "Partner is ready for us") (RETURN)) ((AND TIMEOUT (OR (EQ TIMEOUT 0) (TIMEREXPIRED? TIMER))) (RETURN (COND ((fetch IOTIMEOUTFN of SOCKET) (APPLY* (fetch IOTIMEOUTFN of SOCKET) SOCKET 'OUTPUT)) (T 'BOUT.TIMEOUT] (MONITOR.AWAIT.EVENT (fetch BSPLOCK of SOCKET) (fetch BSPINPUTEVENT of SOCKET) TIMER TIMER))) (RETURN ERRCODE))) (replace BSPCURRENTPUP of STREAM with (SETQ PUP (ALLOCATE.PUP))) (replace TYPEWORD of PUP with \PT.DATA) (replace CPPTR of STREAM with (fetch PUPCONTENTS of PUP)) (replace COFFSET of STREAM with 0) (* ;  "Set counters according to current socket allocation information") (replace CBUFMAXSIZE of STREAM with (IMIN (fetch BYTESPERPUP of SOCKET) (fetch BYTEALLOC of SOCKET] ((IGEQ (fetch COFFSET of STREAM) (fetch CBUFMAXSIZE of STREAM)) (\BSP.SENDBUFFER STREAM PUP) (* ;  "Send the full packet we have built") (GO LP))) (RETURN NIL)))]) (BSPGETMARK [LAMBDA (STREAM) (* bvm%: "11-Jul-84 16:48") (COND ((EQ (\BSP.PREPARE.INPUT STREAM) 'MARK.ENCOUNTERED) (replace MARKPENDING of STREAM with NIL) (PROG1 (\GETBASEBYTE (fetch PUPCONTENTS of (fetch BSPCURRENTPUP of STREAM)) 0) (\BSP.CLEANUP.INPUT STREAM))) (T (BSP.INPUT.ERROR STREAM 'BAD.GETMARK]) (BSPPUTMARK [LAMBDA (STREAM MARKBYTE) (* bvm%: "11-Jul-84 15:02") (WITH.MONITOR (fetch BSPLOCK of (\DTEST (ffetch BSPSOC of (SETQ STREAM (OR [ffetch BSPOUTPUTSTREAM of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM))) 'BSPSOC)) (PROG ((PUP (fetch BSPCURRENTPUP of STREAM)) ERRCODE) (COND (PUP (* ; "Send anything waiting") (\BSP.SENDBUFFER STREAM PUP))) [COND ((SETQ ERRCODE (\BSP.PREPARE.OUTPUT STREAM)) (RETURN (BSP.OUTPUT.ERROR STREAM ERRCODE] (\PUTBASEBYTE (ffetch CPPTR of STREAM) (ffetch COFFSET of STREAM) MARKBYTE) (add (ffetch COFFSET of STREAM) 1) (replace PUPTYPE of (SETQ PUP (fetch BSPCURRENTPUP of STREAM)) with \PT.MARK) (\BSP.SENDBUFFER STREAM PUP) (RETURN MARKBYTE)))]) (BSP.PUTINTERRUPT [LAMBDA (STREAM CODE STRING TIMEOUT) (* bvm%: " 1-JUL-83 12:26") (* ;;; "Sends an Interrupt on SOCKET with given interrupt code and text. Since there can only be one unacked interrupt outstanding at once, it may have to wait. If TIMEOUT is given, we wait only that long. Returns true on success.") (PROG [(SOCKET (\DTEST (fetch BSPSOC of (\DTEST STREAM 'STREAM)) 'BSPSOC] (RETURN (WITH.MONITOR (fetch BSPLOCK of SOCKET) (bind PUP (TIMER _ (AND TIMEOUT (SETUPTIMER TIMEOUT))) do (COND ((OR (NOT (BSPOPENP STREAM 'OUTPUT)) (AND TIMEOUT (TIMEREXPIRED? TIMER))) (RETURN)) ((NOT (fetch INTERRUPTOUT of SOCKET)) (* ;  "State fine for sending interrupt") (SETQ PUP (ALLOCATE.PUP)) (\FILLBSPPUP SOCKET PUP \PT.INTERRUPT (IPLUS \PUPOVLEN BYTESPERWORD) (fetch XMITINTERRUPTID of SOCKET) (fetch BSPOUTPUTQ of SOCKET)) (\PUTBASE (fetch PUPCONTENTS of PUP) 0 CODE) (* ;  "Store error code in first data word") (PUTPUPSTRING PUP STRING)(* ; "Append string") (SENDPUP (fetch PUPSOC of SOCKET) PUP) (* ; "save pup until it is acked") (replace INTERRUPTOUT of SOCKET with T) (\SETBSPTIMEOUT SOCKET) (RETURN T))) (MONITOR.AWAIT.EVENT (fetch BSPLOCK of SOCKET) (fetch BSPINPUTEVENT of SOCKET) TIMER TIMER)))]) ) (* ; "BSP pup handler") (DEFINEQ (\BSP.HANDLE.INPUT [LAMBDA (BSPSOCKET) (* bvm%: "29-Mar-85 21:41") (* ;;; "Top-level of RTP process while BSP connection is active") (PROG ((PUPSOC (fetch PUPSOC of BSPSOCKET)) (LOCK (fetch BSPLOCK of BSPSOCKET)) EVENT PUP TIMER) (SETQ EVENT (PUPSOCKETEVENT PUPSOC)) LP [COND ((SETQ PUP (GETPUP PUPSOC)) (* ; "play with incoming pup") (SELECTC (fetch PUPTYPE of PUP) ((LIST \PT.MARK \PT.DATA) (* ; "Ordinary data") (\BSP.HANDLE.DATA PUP BSPSOCKET)) ((LIST \PT.AMARK \PT.ADATA) (* ; "Data that demands an ack") (replace ACKPENDING of BSPSOCKET with T) (\BSP.HANDLE.DATA PUP BSPSOCKET)) (\PT.ACK (\BSP.HANDLE.ACK PUP BSPSOCKET)) (\PT.INTERRUPT (\BSP.HANDLE.INTERRUPT PUP BSPSOCKET)) (\PT.INTERRUPTREPLY (\BSP.HANDLE.INTERRUPTREPLY PUP BSPSOCKET)) (\PT.ERROR (\BSP.HANDLE.ERROR PUP BSPSOCKET)) (\RTP.HANDLE.PUP PUP BSPSOCKET))) (T (COND ((fetch ACKPENDING of BSPSOCKET) (\SEND.ACK BSPSOCKET))) (MONITOR.AWAIT.EVENT LOCK EVENT [SETQ TIMER (COND ((NEQ (fetch RTPTIMEOUT of BSPSOCKET) 0) (fetch RTPTIMER of BSPSOCKET) ) ((NEQ (fetch BSPTIMEOUT of BSPSOCKET) 0) (fetch BSPTIMER of BSPSOCKET] (AND TIMER T)) (COND [(NEQ (fetch RTPTIMEOUT of BSPSOCKET) 0) (COND ((TIMEREXPIRED? (fetch RTPTIMER of BSPSOCKET)) (\RTP.ACTION BSPSOCKET \EVENT.TIMEOUT] ((NEQ (fetch BSPTIMEOUT of BSPSOCKET) 0) (COND ((TIMEREXPIRED? (fetch BSPTIMER of BSPSOCKET)) (\BSP.TIMERFN BSPSOCKET] (GO LP]) (\BSP.HANDLE.ACK [LAMBDA (PUP SOCKET) (* bvm%: "29-May-85 12:31") (* ;;; "Handle an ACK pup. This is a little messy. The ACK's id tells how far partner has gotten in the stream. Assuming this ack was in response to an ADATA of ours, we need to retransmit anything that we sent before that ADATA which isn't acknowledged in this ack. Finally, the body of the ack gives us an update of partner's allocation") (PROG (THISID NEXTPUP OLDPUP ADATACOUNT ACKDATA OUTQUEUE INTERRUPTPUP) (COND ((OR (NOT (\RTP.FILTER SOCKET PUP T)) (ILESSP (SETQ THISID (fetch PUPID of PUP)) (fetch LASTACKID of SOCKET))) (* ;  "not for us, or is a duplicate/delayed ack") (RELEASE.PUP PUP) (RETURN))) [COND ((fetch ACKREQUESTED of SOCKET) (* ;; "This is presumably in response to our last ADATA, so notice how long it took. Update our timeout = 2 * avg round trip delay, exponentially aged over the last 8 samples") (replace ADATATIMEOUT of SOCKET with (LRSH [IPLUS (ITIMES 7 (fetch ADATATIMEOUT of SOCKET)) (IMAX \BSP.MIN.ADATA.TIMEOUT (IMIN \BSP.MAX.ADATA.TIMEOUT (LLSH (CLOCKDIFFERENCE (fetch LASTADATATIME of SOCKET)) 1] 3] (replace LASTACKID of SOCKET with THISID) (SETQ OUTQUEUE (fetch BSPOUTPUTQ of SOCKET)) (* ;  "Now figure out who is acked and who needs retransmitting") [COND ((fetch INTERRUPTOUT of SOCKET) (SETQ INTERRUPTPUP (\SEARCH.OUTPUTQ SOCKET T] (UNINTERRUPTABLY (SETQ OLDPUP (fetch SYSQUEUEHEAD of OUTQUEUE)) (* ;  "Empty out the queue and refill it below") (replace SYSQUEUEHEAD of OUTQUEUE with (replace SYSQUEUETAIL of OUTQUEUE with NIL))) (COND (INTERRUPTPUP (* ;  "Retransmit interrupts immediately") (replace EPREQUEUE of INTERRUPTPUP with OUTQUEUE) (SENDPUP (fetch PUPSOC of SOCKET) INTERRUPTPUP))) (COND ((fetch ACKREQUESTED of SOCKET) (SETQ ADATACOUNT (fetch ADATACOUNT of SOCKET)) (* ;  "This lets us know whether a pup was sent before or after last adata") (replace ACKREQUESTED of SOCKET with NIL))) (while OLDPUP do (SETQ NEXTPUP (fetch QLINK of OLDPUP)) (replace QLINK of OLDPUP with NIL) (COND ((EQ (fetch PUPTYPE of OLDPUP) \PT.INTERRUPT) (* ;  "We retransmitted it above, so we should not be seeing this!") (\ENQUEUE OUTQUEUE OLDPUP)) ((IGEQ (IDIFFERENCE THISID (fetch PUPID of OLDPUP)) (IDIFFERENCE (fetch PUPLENGTH of OLDPUP) \PUPOVLEN)) (* ; "has been acked, release it") (add (fetch %#UNACKEDPUPS of SOCKET) -1) (add (fetch %#UNACKEDBYTES of SOCKET) (IDIFFERENCE \PUPOVLEN (fetch PUPLENGTH of OLDPUP))) (add (fetch PUPALLOCCOUNT of SOCKET) 1) (* ;  "one more pup successfully received") (RELEASE.PUP OLDPUP)) ((AND ADATACOUNT (IGREATERP ADATACOUNT (fetch AUXWORD of OLDPUP))) (* ;  "This pup was originally sent before our last ADATA, so retransmit it") [\TRANSMIT.STRATEGY SOCKET OLDPUP (COND ([AND (fetch QLINK of OLDPUP) (ILEQ ADATACOUNT (fetch AUXWORD of (fetch QLINK of OLDPUP] (SETQ ADATACOUNT NIL)) (T 'NO] (* ;  "Maybe make it an ADATA if this is the last thing we're retransmitting, else make it just DATA") (replace EPREQUEUE of OLDPUP with OUTQUEUE) (SENDPUP (fetch PUPSOC of SOCKET) OLDPUP)) (T (\ENQUEUE OUTQUEUE OLDPUP))) (SETQ OLDPUP NEXTPUP)) (* ;; "Now update allocations") [COND ((IGREATERP (fetch PUPALLOCCOUNT of SOCKET) \BSP.ALLOCHYSTERESIS) (* ;  "We've been doing okay for a while with no congestion, so increase our max pup allocation") (replace PUPALLOCCOUNT of SOCKET with 0) (COND ((ILESSP (fetch MAXPUPALLOC of SOCKET) \BSP.MAXPUPALLOC) (add (fetch MAXPUPALLOC of SOCKET) 1] (SETQ ACKDATA (fetch PUPCONTENTS of PUP)) (replace BYTESPERPUP of SOCKET with (IMIN (fetch ACKBYTESPERPUP of ACKDATA) \MAX.PUPLENGTH)) (replace PUPALLOC of SOCKET with (IMAX (IMIN (fetch MAXPUPALLOC of SOCKET) (IDIFFERENCE (fetch ACKPUPS of ACKDATA) (fetch %#UNACKEDPUPS of SOCKET))) 0)) (* ;  "number of pups we can still send") (replace BYTEALLOC of SOCKET with (IMAX (IDIFFERENCE (fetch ACKBYTES of ACKDATA) (fetch %#UNACKEDBYTES of SOCKET)) 0)) (RELEASE.PUP PUP) (NOTIFY.EVENT (fetch BSPINPUTEVENT of SOCKET)) (* ;  "Actually, notifying that allocation may have changed") (\SETBSPTIMEOUT SOCKET) (SETUPTIMER (fetch BSPINACTIVITYTIMEOUT of SOCKET) (fetch INACTIVITYTIMER of SOCKET]) (\BSP.HANDLE.DATA [LAMBDA (PUP SOCKET) (* bvm%: "29-Mar-85 21:23") (* ;;; "Processes BSP data and mark pups. Principal task is to figure out where this PUP goes on our input queue.") (PROG (THISID NEWID PREVPUP NEXTPUP DIF DATALENGTH INQUEUE) (COND ((OR (NOT (\RTP.FILTER SOCKET PUP T)) (EQ (SETQ DATALENGTH (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN)) 0) (PROGN (* ;; "if we have no space for incoming pups. If our partner is a good guy, she pays attention to our allocation reports and never overwhelms us, so this is mainly a problem if someone screws up") NIL)) (* ;  "Pup not for us or is zero-length, so nothing to do") (RELEASE.PUP PUP) (RETURN))) (COND ((ILEQ (SETQ NEWID (IPLUS (SETQ THISID (fetch PUPID of PUP)) DATALENGTH)) (fetch RCVBYTEID of SOCKET)) (* ; "NEWID is id of next byte after this packet. If less than RCVBYTEID, it's a duplicate, so discard") (RELEASE.PUP PUP) (RETURN))) [COND ([OR [NULL (fetch SYSQUEUEHEAD of (SETQ INQUEUE (fetch BSPINPUTQ of SOCKET] (IGREATERP THISID (fetch PUPID of (fetch SYSQUEUETAIL of INQUEUE] (* ;  "Checking easy case first: pup goes on end of queue") (\ENQUEUE INQUEUE PUP)) (T (* ;  "Pup goes somewhere in middle of q") (SETQ PREVPUP NIL) (SETQ NEXTPUP (fetch SYSQUEUEHEAD of INQUEUE)) (while (NEQ NEXTPUP NIL) do (COND ((EQ (SETQ DIF (IDIFFERENCE THISID (fetch PUPID of NEXTPUP))) 0) (* ; "Is duplicate of NEXTPUP") (RELEASE.PUP PUP) (RETURN (SETQ PUP NIL))) ((ILESSP DIF 0) (* ; "New pup comes before NEXTPUP") (GO $$OUT))) (SETQ NEXTPUP (fetch QLINK of (SETQ PREVPUP NEXTPUP))) finally (* ;  "Insert PUP between PREVPUP and NEXTPUP") (COND ((NULL PREVPUP) (replace SYSQUEUEHEAD of INQUEUE with PUP)) (T (replace QLINK of PREVPUP with PUP))) (replace QLINK of PUP with NEXTPUP] (* ;; "now see if the new pup fills a hole in front of queue, so we can advance our ID of contiguously read pups") (while (AND PUP (IEQP (fetch RCVBYTEID of SOCKET) (fetch PUPID of PUP))) do (add (fetch RCVBYTEID of SOCKET) (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN)) (* ; "Advance ID past this pup") (add (fetch %#UNREADPUPS of SOCKET) 1) (* ;  "One more pup available for BSPBIN") (NOTIFY.EVENT (fetch BSPINPUTEVENT of SOCKET)) (SETQ PUP (fetch QLINK of PUP))) (SETUPTIMER (fetch BSPINACTIVITYTIMEOUT of SOCKET) (fetch INACTIVITYTIMER of SOCKET)) (* ; "There was non-trivial activity") ]) (\BSP.HANDLE.ERROR [LAMBDA (PUP BSPSOCKET) (* bvm%: "28-Apr-85 14:38") (* ;;; "Handle ERROR pups. The only error codes BSP is interested in are the ones indicating network congestion.") (SELECTC (fetch ERRORPUPCODE of PUP) ((LIST \PUPE.SOCKETFULL \PUPE.GATEWAYFULL) (* ;; "Port IQ overflow, gateway OQ overflow--congestion error. Throttle back output by decreasing our max outgoing allocation") (COND ((IGREATERP (fetch MAXPUPALLOC of BSPSOCKET) 1) (add (fetch MAXPUPALLOC of BSPSOCKET) -1))) (replace PUPALLOCCOUNT of BSPSOCKET with 0) (* ; "Reset hysteresis counter") ) (\PUPE.NOSOCKET (\RTP.ACTION BSPSOCKET \EVENT.ABORT PUP)) NIL) (* ;  "Finally pass all errors on to higher-level proc if any") (BSP.OTHERFN PUP BSPSOCKET]) (\BSP.HANDLE.INTERRUPT [LAMBDA (PUP SOCKET) (* bvm%: "29-Mar-85 21:24") (* ;;; "Handles incoming interrupt. Notes that we have an interrupt, and sends an interrupt reply") (COND ((\RTP.FILTER SOCKET PUP T) (PROG [(DIF (IDIFFERENCE (fetch RCVINTERRUPTID of SOCKET) (fetch PUPID of PUP] [COND ((EQ DIF 0) (* ;  "New interrupt. Note receipt and pass on to higher-level handler") (add (fetch RCVINTERRUPTID of SOCKET) 1) (replace INTERRUPTIN of SOCKET with T) (BSP.OTHERFN PUP SOCKET)) (T (* ; "Duplicate or bad ID, discard") (RELEASE.PUP PUP) (COND ((NEQ DIF 1) (* ; "Garbage") (RETURN] [SENDPUP (fetch PUPSOC of SOCKET) (\FILLBSPPUP SOCKET NIL \PT.INTERRUPTREPLY \PUPOVLEN (SUB1 (fetch RCVINTERRUPTID of SOCKET] (* ; "reply to it") )) (T (* ; "Not for us") (RELEASE.PUP PUP]) (\BSP.HANDLE.INTERRUPTREPLY [LAMBDA (PUP SOCKET) (* bvm%: " 5-JUN-83 15:49") (* ;;; "Handles Interrupt Reply. Assuming this is in response to a (the) interrupt we sent out, we can release our copy of the interrupt pup") [COND ((AND (\RTP.FILTER SOCKET PUP T) (fetch INTERRUPTOUT of SOCKET) (IEQP (fetch PUPID of PUP) (fetch XMITINTERRUPTID of SOCKET))) (PROG ((INTPUP (\SEARCH.OUTPUTQ SOCKET T))) (COND (INTPUP (add (fetch XMITINTERRUPTID of SOCKET) 1) (replace INTERRUPTOUT of SOCKET with NIL) (* ;  "In case BSP.PUTINTERRUPT was waiting on us") (NOTIFY.EVENT (fetch BSPINPUTEVENT of SOCKET)) (RELEASE.PUP INTPUP)) (T (* ;; "Inconsistent state: we have INTERRUPTOUT, but can't find the pup on our retransmit queue. In bcpl implementation the pup might still be on the transmit queue, but here we know we have sent it. Change this when low-level pup gets into lisp") (BSPHELP "Couldn't find interrupt that elicited this reply"] (RELEASE.PUP PUP]) (\SEND.ACK [LAMBDA (SOCKET) (* bvm%: "29-Mar-85 21:24") (* ;;; "Send an ACK, telling partner how much of the bytestream we have received, and what our current allocation is") (PROG ((PUP (ALLOCATE.PUP)) [%#PUPS (IMAX 0 (IDIFFERENCE \BSP.MAXPUPS (fetch %#UNREADPUPS of SOCKET] DATA) (* ;; "Our current allocation is computed by subtracting from our max allocation anything sitting in the input queue. Don't want to say the length of the whole INPUTQ, since stuff after the hole doesn't really count. This is all approximate, of course, but is sufficient for decent flow control") (replace ACKPENDING of SOCKET with NIL) (\FILLBSPPUP SOCKET PUP \PT.ACK (IPLUS \PUPOVLEN 6) (fetch RCVBYTEID of SOCKET) 'FREE) (SETQ DATA (fetch PUPCONTENTS of PUP)) (replace ACKBYTESPERPUP of DATA with \MAX.PUPLENGTH) (* ;  "We can always receive maximal size pups") (replace ACKPUPS of DATA with %#PUPS) (replace ACKBYTES of DATA with (ITIMES %#PUPS \MAX.PUPLENGTH)) (replace SENTZEROALLOC of SOCKET with (EQ %#PUPS 0)) (* ;  "we said stop. This will encourage us to send an ack as soon as our allocation improves") (SENDPUP (fetch PUPSOC of SOCKET) PUP) (* ;; "At this point the BCPL implementation flushes the pups we have received but not acked, since they will probably be retransmitted anyway. No real need for us to do that, since we don't have a permanently constrained pup pool") ]) (\SEARCH.OUTPUTQ [LAMBDA (SOCKET LOOKFORINTERRUPT) (* bvm%: " 5-JUN-83 15:30") (* ;;; "Searches output queue of SOCKET for an interrupt packet, if LOOKFORINTERRUPT is true, or for the last non-interrupt if false, and returns it or NIL") (bind (PUP _ (fetch SYSQUEUEHEAD of (fetch BSPOUTPUTQ of SOCKET))) LASTPUP while PUP do (COND [LOOKFORINTERRUPT (COND ((EQ (fetch PUPTYPE of PUP) \PT.INTERRUPT) (RETURN (\UNQUEUE (fetch BSPOUTPUTQ of SOCKET) PUP] ((NEQ (fetch PUPTYPE of PUP) \PT.INTERRUPT) (SETQ LASTPUP PUP))) (SETQ PUP (fetch QLINK of PUP)) finally (RETURN (AND LASTPUP (\UNQUEUE (fetch BSPOUTPUTQ of SOCKET) LASTPUP]) (\SETBSPTIMEOUT [LAMBDA (SOCKET) (* bvm%: "10-MAY-83 23:11") (* ;;; "Sets timer for this socket to wake us up after a while if nothing happens. If we have unacked data outstanding, make this shorter than if we are idle") (SETUPTIMER (replace BSPTIMEOUT of SOCKET with (COND [(OR (fetch INTERRUPTOUT of SOCKET) (IGREATERP (fetch %#UNACKEDPUPS of SOCKET) 0) (ILEQ (fetch PUPALLOC of SOCKET) 0) (ILEQ (fetch BYTEALLOC of SOCKET) 0) (ILEQ (fetch BYTESPERPUP of SOCKET) 0)) (* ; "We're waiting for a response") (WAKE.PROCESS (fetch RTPPROCESS of SOCKET)) (* ;  "Because we may have shortened the timeout") (COND ((fetch ACKREQUESTED of SOCKET) (* ;  "Sent Adata, here's how long we expect to need") (fetch ADATATIMEOUT of SOCKET)) (T (IMAX (fetch ADATATIMEOUT of SOCKET) \BSP.OUTSTANDINGDATATIMEOUT] (T \BSP.IDLETIMEOUT))) (fetch BSPTIMER of SOCKET]) (\TRANSMIT.STRATEGY [LAMBDA (SOCKET PUP MAKEA?) (* bvm%: " 3-MAY-83 11:32") (* ;;; "Decides whether to make PUP an ADATA (AMARK) or just DATA (MARK) when MAKEA? is nil. If T it always makes ADATA, if NO it never does. Current strategy (from BCPL) : demand ack if allocation falls below 1/3 of that given in the last received ack, i.e. if PUPALLOC le (PUPALLOC+UNACKEDPUPS) /3, or equivalently PUPALLOC*2 le UNACKEDPUPS. If \BSP.OVERLAP.DATA.WITH.ACK is false, however, only demands ack when allocation is exhausted") (COND ([OR (EQ MAKEA? T) (SETQ MAKEA? (AND (NULL MAKEA?) (NOT (fetch ACKREQUESTED of SOCKET)) (PROG [(PUPALLOC (IMIN (fetch PUPALLOC of SOCKET) (IQUOTIENT (fetch BYTEALLOC of SOCKET) (fetch BYTESPERPUP of SOCKET] (* ;  "BCPL version also mins with socket allocations") (RETURN (COND (\BSP.OVERLAP.DATA.WITH.ACK (ILEQ (LSH PUPALLOC 1) (fetch %#UNACKEDPUPS of SOCKET))) (T (ILEQ PUPALLOC 0] (COND ((NOT (fetch ACKREQUESTED of SOCKET)) (* ; "unless ADATA is already outstanding, note the time so we can see how long partner takes to respond") (SETUPTIMER 0 (fetch LASTADATATIME of SOCKET)) (replace ACKREQUESTED of SOCKET with T))) (add (fetch ADATACOUNT of SOCKET) 1) (* ;  "This is used to distinguish pups originally sent before this ADATA vs after") )) (replace PUPTYPE of PUP with (SELECTC (fetch PUPTYPE of PUP) ((LIST \PT.DATA \PT.ADATA) (COND (MAKEA? \PT.ADATA) (T \PT.DATA))) ((LIST \PT.MARK \PT.AMARK) (COND (MAKEA? \PT.AMARK) (T \PT.MARK))) (BSPHELP "\TRANSMIT.STRATEGY called on non-data pup"]) ) (* ; "BSP utilities") (DEFINEQ (\BSP.DEFAULT.ERROR.HANDLER [LAMBDA (SOCKET ERRCODE) (* bvm%: "11-AUG-81 12:30") (DECLARE (SPECVARS %#MYHANDLE#)) (* ;  "Bind this to NIL to inhibit my toy scheduler") (PROG (%#MYHANDLE#) (RETURN (ERROR (CONCAT "BSP error: " ERRCODE) SOCKET]) (\BSP.TIMERFN [LAMBDA (SOCKET) (* bvm%: " 8-Mar-84 17:53") (* ;;; "Called when BSPTIMER expires. The timer gets reset every time we send something, so this means we haven't sent anything in a while") (COND ((SELECTC (fetch RTPSTATE of SOCKET) ((LIST \STATE.OPEN \STATE.ENDSENT \STATE.ENDRECEIVED) NIL) T) (* ;; "Socket not alive, so kill it. CLOSERTPSOCKET will free up all resources except any waiting input, which will be held, I hope") (CLOSERTPSOCKET SOCKET 0)) ((AND (NOT \BSP.NO.INACTIVITY.TIMEOUT) (TIMEREXPIRED? (fetch INACTIVITYTIMER of SOCKET))) (* ;  "Connection has fallen asleep, abort it") (\RTP.ACTION SOCKET \EVENT.FORCECLOSE)) (T (COND ((fetch ACKPENDING of SOCKET) (* ;  "I don't think this ever happens, because we can always get pups to do an ack with") (\SEND.ACK SOCKET))) [PROG (PUP) (COND ((AND (fetch INTERRUPTOUT of SOCKET) (SETQ PUP (\SEARCH.OUTPUTQ SOCKET T))) (* ; "Retransmit unacked interrupt") (replace EPREQUEUE of PUP with (fetch BSPOUTPUTQ of SOCKET)) (SENDPUP (fetch PUPSOC of SOCKET) PUP] (* ;; "Generate an ADATA unconditionally every BSPTIMER cycle, both to see whether partner is alive and to demonstrate that we are") (COND ((NOT (fetch ACKREQUESTED of SOCKET)) (* ;  "ADATA not outstanding, so start timing") (SETUPTIMER 0 (fetch LASTADATATIME of SOCKET)) (replace ACKREQUESTED of SOCKET with T))) (add (fetch ADATACOUNT of SOCKET) 1) (SENDPUP (fetch PUPSOC of SOCKET) (\FILLBSPPUP SOCKET NIL \PT.ADATA \PUPOVLEN (fetch XMITBYTEID of SOCKET) )) (\SETBSPTIMEOUT SOCKET]) (\BSP.FLUSH.SOCKET.QUEUES [LAMBDA (SOCKET) (* bvm%: "26-OCT-83 14:51") (\FLUSH.PACKET.QUEUE (fetch BSPOUTPUTQ of SOCKET)) (* ;; "Flush anything waiting for output/retransmission. Don't flush input side, because someone might have a stream to keep reading from") (PROG ((STREAM (fetch BSPINPUTSTREAM of SOCKET))) (OR STREAM (RETURN)) (COND ((fetch BSPCURRENTPUP of (SETQ STREAM (fetch BSPOUTPUTSTREAM of STREAM)) ) (replace CBUFSIZE of STREAM with 0) (RELEASE.PUP (fetch BSPCURRENTPUP of STREAM)) (replace BSPCURRENTPUP of STREAM with (replace CPPTR of STREAM with NIL]) (\FILLBSPPUP [LAMBDA (SOCKET PUP TYPE LENGTH ID REQUEUE) (* bvm%: " 1-JUL-83 12:23") (* ;;; "Fills in the indicated fields of PUP, plus source and dest ports from SOCKET") (OR PUP (SETQ PUP (ALLOCATE.PUP))) (replace PUPLENGTH of PUP with (OR LENGTH \PUPOVLEN)) (replace TYPEWORD of PUP with TYPE) (replace PUPID of PUP with ID) (replace EPREQUEUE of PUP with (OR REQUEUE 'FREE)) (\SETRTPPORTS SOCKET PUP) PUP]) (BSPHELP [LAMBDA (MSG) (* bvm%: " 5-JUN-83 15:51") (HELP "BSP error." MSG]) ) (* ; "debugging") (DEFINEQ (PPSOC [LAMBDA (SOC FILE VERBOSE) (* ; "Edited 6-Apr-87 20:03 by bvm:") (PROG ((*STANDARD-OUTPUT* (\GETSTREAM FILE 'OUTPUT)) (*PRINT-BASE* 10) [LOCALPORT (PORTSTRING (fetch LCLPORT of SOC) (\MAKENUMBER (fetch LCLSOCKETHI of SOC) (fetch LCLSOCKETLO of SOC] (STATE (fetch RTPSTATE of SOC)) STREAM PUP) (if (EQ STATE \STATE.LISTENING) then (printout NIL "Listening on " LOCALPORT) (RETURN)) (printout NIL "From " LOCALPORT " to " (PORTSTRING (fetch FRNPORT of SOC) (\MAKENUMBER (fetch FRNSOCKETHI of SOC) (fetch FRNSOCKETLO of SOC))) T "State: ") (PRINTCONSTANT STATE RTPSTATES) (printout NIL T "Last input activity: " .F1.1 (FQUOTIENT (+ (CLOCKDIFFERENCE (fetch INACTIVITYTIMER of SOC)) (fetch BSPINACTIVITYTIMEOUT of SOC)) 1000) " secs ago" T) (printout NIL "Connection id: " (fetch CONNID of SOC) T) (PRINTTIMER (fetch RTPTIMER of SOC) (fetch RTPTIMEOUT of SOC) "RTP timer: ") (PRINTTIMER (fetch BSPTIMER of SOC) (fetch BSPTIMEOUT of SOC) "BSP timer: ") (printout NIL T "Input:" T " ID: " (fetch RCVBYTEID of SOC) T " InterruptID: " (fetch RCVINTERRUPTID of SOC) T) [if (SETQ STREAM (fetch BSPINPUTSTREAM of SOC)) then (printout NIL " FilePtr: " (fetch BSPFILEPTR of STREAM) T) (COND ((SETQ PUP (fetch BSPCURRENTPUP of STREAM)) (PPSOC.CURRENT STREAM PUP) (COND ((fetch MARKPENDING of STREAM) (PRIN1 "{Mark pending}"))) (COND (VERBOSE (TAB 4) (BSPPRINTPUP PUP T) (TERPRI] (PRINTPUPQUEUE (fetch BSPINPUTQ of SOC) " Input queue: " VERBOSE) (printout NIL " #unread: " (fetch %#UNREADPUPS of SOC) T) (printout NIL T "Output:" T " ID: " (fetch XMITBYTEID of SOC) T " AckID: " (fetch LASTACKID of SOC) T " InterruptID: " (fetch XMITINTERRUPTID of SOC) T " Unacked pups: " (fetch %#UNACKEDPUPS of SOC) ", bytes: " (fetch %#UNACKEDBYTES of SOC) T) [if (SETQ STREAM (fetch BSPOUTPUTSTREAM of STREAM)) then (printout NIL " FilePtr: " (fetch BSPFILEPTR of STREAM) T) (COND ((SETQ PUP (fetch BSPCURRENTPUP of STREAM)) (PPSOC.CURRENT STREAM PUP] (PRINTPUPQUEUE (fetch BSPOUTPUTQ of SOC) " Retransmit queue: " VERBOSE) (printout NIL " Alloc: " (fetch PUPALLOC of SOC) " pups, " (fetch BYTEALLOC of SOC) " bytes, " (fetch BYTESPERPUP of SOC) "/pup" T " Max " (fetch MAXPUPALLOC of SOC) ", cntr " (fetch PUPALLOCCOUNT of SOC) T) (printout NIL T "Flags: ") (COND ((fetch LISTENING of SOC) (PRIN1 "Listener, "))) (COND ((fetch INTERRUPTOUT of SOC) (PRIN1 "Interrupt out, "))) (COND ((fetch INTERRUPTIN of SOC) (PRIN1 "Interrupt in, "))) (COND ((fetch ACKPENDING of SOC) (PRIN1 "Ack pending, "))) (COND ((fetch ACKREQUESTED of SOC) (PRIN1 "Ack requested, "))) (COND ((fetch SENTZEROALLOC of SOC) (PRIN1 "Sent zero allocation."))) (TERPRI) (printout NIL "AData timeout: " (fetch ADATATIMEOUT of SOC]) (PPSOC.CURRENT [LAMBDA (STREAM PUP) (* bvm%: " 9-MAY-83 15:11") (printout NIL " Current: " PUP " at " (fetch COFFSET of STREAM) ", " (IDIFFERENCE (fetch CBUFSIZE of STREAM) (fetch COFFSET of STREAM)) " left" T]) (PRINTTIMER [LAMBDA (TIMER TIMEOUT LABEL) (* bvm%: " 5-AUG-81 12:21") (COND ((AND TIMEOUT (NEQ TIMEOUT 0)) (PRIN1 LABEL) (PROG ((DIF (IDIFFERENCE (CLOCKDIFFERENCE TIMER) TIMEOUT))) (COND ((ILESSP DIF 0) (printout NIL (IMINUS DIF) " msecs left" T)) (T (printout NIL " expired " DIF " msecs ago." T]) (PRINTPUPQUEUE [LAMBDA (QUEUE HEADER VERBOSE) (* bvm%: " 7-MAR-83 13:52") (PROG ((PUP (fetch SYSQUEUEHEAD of QUEUE)) LASTPUP GAP) (PRIN1 HEADER) [COND (PUP (AND VERBOSE (TAB 4)) (do (BSPPRINTPUP (SETQ LASTPUP PUP) VERBOSE) repeatwhile (AND (SETQ PUP (fetch QLINK of PUP)) (PROGN (COND [VERBOSE (TAB 4) (COND ((NEQ (SETQ GAP (IDIFFERENCE (IDIFFERENCE (fetch PUPID of PUP) (fetch PUPID of LASTPUP) ) (IDIFFERENCE (fetch PUPLENGTH of LASTPUP) \PUPOVLEN))) 0) (printout NIL " 4] (T (PRIN1 ", "))) T] (COND ((NEQ (fetch SYSQUEUETAIL of QUEUE) LASTPUP) (printout NIL " Oops! Tail of queue = " LASTPUP))) (TERPRI]) (BSPPRINTPUP [LAMBDA (PUP VERBOSE) (* bvm%: " 6-AUG-81 19:07") (COND ((NOT VERBOSE) (PRIN2 PUP)) (T (printout NIL '{ (fetch PUPID of PUP) " for " (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN) '}) (SELECTC (fetch PUPTYPE of PUP) ((LIST \PT.AMARK \PT.MARK) (printout NIL "[Mark " (GETBASEBYTE (fetch PUPCONTENTS of PUP) 0) "]" T)) (PRINTPUPDATA PUP '(CHARS]) (\RTP.INFO.HOOK [LAMBDA (PROC BUTTON) (* bvm%: "10-JUL-83 22:25") (DECLARE (USEDFREE BSPSOCKET)) (* ;  "This is evaluated underneath \RTP.SOCKET.PROCESS") (PROG ((WINDOW (PROCESS.WINDOW PROC))) (COND ((NULL WINDOW) (SETQ WINDOW (CREATEW (GETBOXREGION 240 280) "BSP status")) (DSPFONT (FONTCREATE 'GACHA 8) WINDOW) (PROCESS.WINDOW PROC WINDOW)) (T (CLEARW WINDOW))) (PPSOC BSPSOCKET (WINDOWPROP WINDOW 'DSP) (EQ BUTTON 'MIDDLE]) ) (DECLARE%: DONTCOPY (ADDTOVAR PUPPRINTMACROS (8 BYTES 2 INTEGER) (9 WORD 2 CHARS) (16 CHARS) (17 CHARS) (18 WORDS) (20 WORD 2 CHARS)) ) (/DECLAREDATATYPE 'BSPSOC '(WORD FIXP WORD FIXP BYTE POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER WORD WORD POINTER WORD WORD WORD WORD WORD WORD POINTER WORD POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((BSPSOC 0 (BITS . 15)) (BSPSOC 1 FIXP) (BSPSOC 3 (BITS . 15)) (BSPSOC 4 FIXP) (BSPSOC 6 (BITS . 7)) (BSPSOC 8 POINTER) (BSPSOC 10 POINTER) (BSPSOC 12 POINTER) (BSPSOC 14 POINTER) (BSPSOC 16 POINTER) (BSPSOC 7 (BITS . 15)) (BSPSOC 18 POINTER) (BSPSOC 20 POINTER) (BSPSOC 22 POINTER) (BSPSOC 24 (BITS . 15)) (BSPSOC 26 POINTER) (BSPSOC 28 POINTER) (BSPSOC 30 POINTER) (BSPSOC 32 POINTER) (BSPSOC 34 POINTER) (BSPSOC 36 POINTER) (BSPSOC 38 POINTER) (BSPSOC 25 (BITS . 15)) (BSPSOC 40 POINTER) (BSPSOC 42 POINTER) (BSPSOC 44 POINTER) (BSPSOC 46 (BITS . 15)) (BSPSOC 47 (BITS . 15)) (BSPSOC 48 POINTER) (BSPSOC 50 (BITS . 15)) (BSPSOC 51 (BITS . 15)) (BSPSOC 52 (BITS . 15)) (BSPSOC 53 (BITS . 15)) (BSPSOC 54 (BITS . 15)) (BSPSOC 55 (BITS . 15)) (BSPSOC 56 POINTER) (BSPSOC 58 (BITS . 15)) (BSPSOC 60 POINTER) (BSPSOC 60 (FLAGBITS . 0)) (BSPSOC 60 (FLAGBITS . 16)) (BSPSOC 60 (FLAGBITS . 32)) (BSPSOC 60 (FLAGBITS . 48)) (BSPSOC 59 (FLAGBITS . 0)) (BSPSOC 59 (FLAGBITS . 16)) (BSPSOC 59 (FLAGBITS . 32)) (BSPSOC 62 POINTER) (BSPSOC 64 (BITS . 15)) (BSPSOC 66 POINTER) (BSPSOC 68 POINTER) (BSPSOC 70 POINTER) (BSPSOC 72 POINTER) (BSPSOC 74 POINTER) (BSPSOC 76 POINTER) (BSPSOC 78 POINTER)) '80) (ADDTOVAR SYSTEMRECLST (DATATYPE BSPSOC ((FRNPORT WORD) (FRNSOCKET FIXP) (LCLPORT WORD) (LCLSOCKET FIXP) (RTPSTATE BYTE) (RTPPROCESS POINTER) (RTPEVENT POINTER) (PUPSOC POINTER) (CONNID POINTER) (RTPTIMER POINTER) (RTPTIMEOUT WORD) (BSPINPUTHANDLER POINTER) (BSPINPUTSTREAM POINTER) (BSPTIMER POINTER) (BSPTIMEOUT WORD) (BSPFAILUREREASON POINTER) (BSPOTHERPUPFN POINTER) (BSPERRORHANDLER POINTER) (BSPIOTIMEOUT POINTER) (RCVBYTEID POINTER) (RCVINTERRUPTID POINTER) (BSPINPUTQ POINTER) (%#UNREADPUPS WORD) (XMITBYTEID POINTER) (XMITINTERRUPTID POINTER) (LASTACKID POINTER) (%#UNACKEDPUPS WORD) (%#UNACKEDBYTES WORD) (BSPOUTPUTQ POINTER) (BYTESPERPUP WORD) (PUPALLOC WORD) (BYTEALLOC WORD) (MAXPUPALLOC WORD) (PUPALLOCCOUNT WORD) (ADATACOUNT WORD) (LASTADATATIME POINTER) (ADATATIMEOUT WORD) (INACTIVITYTIMER POINTER) (LISTENING FLAG) (INTERRUPTOUT FLAG) (INTERRUPTIN FLAG) (ACKPENDING FLAG) (ACKREQUESTED FLAG) (SENTZEROALLOC FLAG) (BSPNOACTIVITY FLAG) (BSPUSERSTATE POINTER) (NIL WORD) (IOTIMEOUTFN POINTER) (BSPWHENCLOSEDFN POINTER) (BSPINPUTEVENT POINTER) (BSPLOCK POINTER) (BSPINITTIMER POINTER) (BSPFAILURESTRING POINTER) (BSPINACTIVITYTIMEOUT POINTER))) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\BSPINIT) ) (* ; "Some of these may want to be constants") (RPAQ? \BSPSOCKETS ) (RPAQ? \RFC.TIMEOUT 2000) (RPAQ? \RTP.DALLY.TIMEOUT 5000) (RPAQ? \RTP.DEFAULTTIMEOUT 30000) (RPAQ? \BSP.MAXPUPS 12) (RPAQ? \BSP.IDLETIMEOUT 15000) (RPAQ? \BSP.OUTSTANDINGDATATIMEOUT 250) (RPAQ? \BSP.MAXPUPALLOC 200) (RPAQ? \BSP.ALLOCHYSTERESIS 50) (RPAQ? \BSP.OVERLAP.DATA.WITH.ACK ) (RPAQ? \BSP.INITIAL.MAXPUPALLOC 5) (RPAQ? \BSP.INITIAL.ADATATIMEOUT 1000) (RPAQ? \BSP.MIN.ADATA.TIMEOUT 500) (RPAQ? \BSP.MAX.ADATA.TIMEOUT 10000) (RPAQ? \BSP.INACTIVITY.TIMEOUT 120000) (RPAQ? \BSP.NO.INACTIVITY.TIMEOUT T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \BSPSOCKETS \RFC.TIMEOUT \RTP.DALLY.TIMEOUT \RTP.DEFAULTTIMEOUT \BSP.MAXPUPS \BSP.IDLETIMEOUT \BSP.OUTSTANDINGDATATIMEOUT \BSP.MAXPUPALLOC \BSP.ALLOCHYSTERESIS \BSP.OVERLAP.DATA.WITH.ACK \BSP.INITIAL.MAXPUPALLOC \BSP.INITIAL.ADATATIMEOUT \BSP.MIN.ADATA.TIMEOUT \BSP.MAX.ADATA.TIMEOUT \BSP.INACTIVITY.TIMEOUT \BSP.NO.INACTIVITY.TIMEOUT) ) (PUTPROPS BSP COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1900 1984 1985 1986 1987 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (21817 29985 (OPENRTPSOCKET 21827 . 27095) (CLOSERTPSOCKET 27097 . 29287) ( \INIT.RTPPROCESS 29289 . 29983)) (30014 56369 (\RTP.SOCKET.PROCESS 30024 . 30875) (\RTP.HANDLE.INPUT 30877 . 31862) (\RTP.HANDLE.PUP 31864 . 33396) (\RTP.HANDLE.RFC 33398 . 35890) (\RTP.CLEANUP 35892 . 36936) (\RTP.ACTION 36938 . 47410) (\RTP.ERROR 47412 . 47878) (\RTP.SHOW.FAILURE 47880 . 49317) ( \RTP.FILTER 49319 . 50784) (\SEND.ABORT 50786 . 51704) (\SEND.ANSWERING.RFC 51706 . 53451) (\SEND.END 53453 . 53665) (\SEND.ENDREPLY 53667 . 53889) (\SEND.RFC 53891 . 55263) (\FILLRTPPUP 55265 . 55948) ( \SETRTPPORTS 55950 . 56367)) (56370 59627 (\BSPINIT 56380 . 58219) (\BSPEVENTFN 58221 . 58560) ( \BSP.CLOSE.OPEN.SOCKETS 58562 . 59625)) (59664 73949 (OPENBSPSTREAM 59674 . 66650) (\SMASHBSPSTREAM 66652 . 68023) (BSPOUTPUTSTREAM 68025 . 68381) (BSPINPUTSTREAM 68383 . 68617) (BSPFRNADDRESS 68619 . 68836) (CLOSEBSPSTREAM 68838 . 71542) (\BSP.FLUSHINPUT 71544 . 72095) (BSPOPENP 72097 . 73376) ( GETBSPUSERINFO 73378 . 73638) (SETBSPUSERINFO 73640 . 73947)) (73950 74411 (CREATEBSPSTREAM 73960 . 74256) (ENDBSPSTREAM 74258 . 74409)) (74449 99242 (BSPBIN 74459 . 74591) (\BSP.GETNEXTBUFFER 74593 . 76270) (BSPPEEKBIN 76272 . 76423) (BSPREADP 76425 . 77625) (BSPEOFP 77627 . 78407) (\BSPBACKFILEPTR 78409 . 78843) (\BSP.PREPARE.INPUT 78845 . 83265) (\BSP.GETFILEPTR 83267 . 83563) ( \BSP.DECLARE.FILEPTR 83565 . 83740) (\BSP.SETFILEPTR 83742 . 84359) (\BSP.SKIPBYTES 84361 . 85149) ( \BSP.CLEANUP.INPUT 85151 . 86185) (BSPBOUT 86187 . 86408) (\BSP.OTHERBOUT 86410 . 86666) ( \BSPWRITEBLOCK 86668 . 86927) (BSPFORCEOUTPUT 86929 . 87966) (\BSP.SENDBUFFER 87968 . 90804) ( \BSP.PREPARE.OUTPUT 90806 . 94683) (BSPGETMARK 94685 . 95162) (BSPPUTMARK 95164 . 96773) ( BSP.PUTINTERRUPT 96775 . 99240)) (99275 128762 (\BSP.HANDLE.INPUT 99285 . 102146) (\BSP.HANDLE.ACK 102148 . 111276) (\BSP.HANDLE.DATA 111278 . 116210) (\BSP.HANDLE.ERROR 116212 . 117412) ( \BSP.HANDLE.INTERRUPT 117414 . 118924) (\BSP.HANDLE.INTERRUPTREPLY 118926 . 120387) (\SEND.ACK 120389 . 122309) (\SEARCH.OUTPUTQ 122311 . 123790) (\SETBSPTIMEOUT 123792 . 125676) (\TRANSMIT.STRATEGY 125678 . 128760)) (128793 133197 (\BSP.DEFAULT.ERROR.HANDLER 128803 . 129217) (\BSP.TIMERFN 129219 . 131655) (\BSP.FLUSH.SOCKET.QUEUES 131657 . 132536) (\FILLBSPPUP 132538 . 133059) (BSPHELP 133061 . 133195)) (133224 143039 (PPSOC 133234 . 138530) (PPSOC.CURRENT 138532 . 138871) (PRINTTIMER 138873 . 139355) (PRINTPUPQUEUE 139357 . 141632) (BSPPRINTPUP 141634 . 142306) (\RTP.INFO.HOOK 142308 . 143037) )))) STOP \ No newline at end of file diff --git a/sources/BYTECOMPILER b/sources/BYTECOMPILER new file mode 100644 index 00000000..b9f9a2cc --- /dev/null +++ b/sources/BYTECOMPILER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "26-Apr-91 17:25:53" |{PELE:MV:ENVOS}LIBRARY>BYTECOMPILER.;1| 264022 changes to%: (FNS COMP.EXPR) previous date%: "17-Jul-90 11:28:59" |{PELE:MV:ENVOS}SOURCES>BYTECOMPILER.;8|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1900, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT BYTECOMPILERCOMS) (RPAQQ BYTECOMPILERCOMS [ (* ;;; "THE BYTE LISP COMPILER") (COMS (INITVARS (*BYTECOMPILER-IS-EXPANDING* NIL)) (FNS BYTEBLOCKCOMPILE2 BYTECOMPILE2 COMP.ATTEMPT.COMPILE COMP.RETFROM.POINT COMP.TRANSFORM COMPERROR COMPPRINT COMPERRM) (FNS COMP.TOPLEVEL.COMPILE COMP.BINDLIST COMP.CHECK.VAR COMP.BIND.VARS COMP.UNBIND.VARS ) (FNS COMP.VALN COMP.PROGN COMP.PROGLST COMP.EXP1 COMP.EXPR COMP.TRYUSERFN COMP.USERFN COMP.CONST COMP.CALL COMP.VAR COMP.VAL1 COMP.PROG1 COMP.EFFECT COMP.VAL COMP.MACRO ) (FNS COMP.VARTYPE COMP.LOOKUPVAR COMP.LOOKUPCONST) (FNS COMP.ST COMP.STFN COMP.STCONST COMP.STVAR COMP.STPOP COMP.DELFN COMP.STRETURN COMP.STTAG COMP.STJUMP COMP.STSETQ COMP.STCOPY COMP.DELPUSH COMP.DELPOP COMP.STBIND COMP.STUNBIND) (VARS *NO-SIDE-EFFECT-FNS*) (GLOBALVARS *NO-SIDE-EFFECT-FNS*) (FNS COMP.ARGTYPE COMP.CLEANEXPP COMP.CLEANFNP COMP.CLEANFNOP COMP.GLOBALVARP COMP.LINKCALLP COMP.ANONP COMP.NOSIDEEFFECTP) (FNS COMP.CPI COMP.CPI1 COMP.PICOUNT) (PROP BYTEMACRO EVQ) (FNS COMP.EVQ) (PROP BYTEMACRO AND OR) (FNS COMP.BOOL) (FNS COMP.APPLYFNP) (PROP BYTEMACRO AC) (FNS COMP.AC COMP.PUNT) (PROP BYTEMACRO FUNCTION) (FNS COMP.FUNCTION COMP.LAM1 COMP.GENFN) (INITVARS (COMP.GENFN.NUM 0)) (GLOBALVARS COMP.GENFN.NUM COMP.UNBOXED.TAG) (PROP BYTEMACRO COND SELECTQ) (FNS COMP.COND COMP.IF COMP.SELECTQ) (PROP BYTEMACRO PROGN PROG1) (PROP BYTEMACRO QUOTE *) (FNS COMP.QUOTE COMP.COMMENT) (PROP BYTEMACRO DECLARE) (FNS COMP.DECLARE COMP.DECLARE1) (PROP (BYTEMACRO CROPS) * MCROPS) (FNS COMP.CARCDR COMP.STCROP) (PROP BYTEMACRO NOT NULL) (FNS COMP.NOT) (PROP BYTEMACRO SETQ SETN) (FNS COMP.SETQ COMP.SETN) (FNS COMP.LAMBDA) (PROP DMACRO CL:TAGBODY) (PROP BYTEMACRO PROG GO RETURN CL:RETURN-FROM) (FNS COMP.PROG COMP.GO COMP.RETURN COMP.BLOCK COMP.RETURN-FROM COMP.TAGBODY) (PROP BYTEMACRO CL:LABELS) (FNS COMP.LABELS) (VARS COMP.UNBOXED.TAG NUMBERFNS (GLOBALVARFLG T) (NEWOPTFLG) (COMPVERSION (DATE))) (OPTIMIZERS IMINUS) (MACROS IPLUS ITIMES LOGOR LOGXOR LOGAND IDIFFERENCE IQUOTIENT IREMAINDER LSH LLSH RSH LRSH FIX PLUS DIFFERENCE TIMES QUOTIENT FPLUS FDIFFERENCE FTIMES FQUOTIENT FABS FGREATERP FLESSP FREMAINDER) (FNS COMP.NUMERIC COMP.NUMBERCALL COMP.FIX COMP.STFIX COMP.DELFIX) (PROP BYTEMACRO EQ EQUAL EQP) (FNS COMP.EQ) (PROP BYTEMACRO .TEST.) (FNS COMP.NUMBERTEST) (PROP BYTEMACRO * MAPFNS) (PROP BYTEMACRO .DOCOLLECT. .DOJOIN.) (FNS COMP.MAP) (PROP BYTEMACRO LISPXWATCH) (OPTIMIZERS BLKAPPLY BLKAPPLY*) (OPTIMIZERS ADD1VAR KWOTE FRPLNODE RPLNODE LISTGET1 FRPLNODE2) (PROP BYTEMACRO SUB1VAR) (OPTIMIZERS EQMEMB MKLIST) (COMS (* ;; "Pass 1 listing") (FNS COMP.MLLIST COMP.MLL COMP.MLLVAR COMP.MLLFN) (VARS COPS) (IFPROP MLSYM * (PROGN COPS))) (COMS (* ;; "ARJ --- JUMP LENGTH RESOLVER") (FNS OPT.RESOLVEJUMPS OPT.JLENPASS OPT.JFIXPASS OPT.JSIZE)) (COMS (* ;; "Utilities used by all files") (FNS OPT.CALLP OPT.JUMPCHECK OPT.DREV OPT.CHLEV OPT.CHECKTAG OPT.NOTJUMP OPT.INITHASH OPT.COMPINIT)) (P (MOVD? 'NILL 'REFRAME) (AND (GETD 'OPT.COMPINIT) (OPT.COMPINIT))) (PROP BYTEMACRO LOADTIMECONSTANT) (PROP BYTEMACRO FRPTQ) (FNS OPT.CFRPTQ) (DECLARE%: EVAL@COMPILE DONTCOPY (SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE COMFN COMFNS COMTYPE CONSTS EMFLAG EXP FRAME FREELST FREEVARS LAPFLG LBCNT LEVEL LOCALVARS LOCALVARS LSTFIL MACEXP NLAMS1 PIFN COMPILE.CONTEXT PROGCONTEXT RETURNLABEL SPECVARS SPECVARS SUBFNFREEVARS TAGS TOPFN TOPFRAME TOPLAB VARS INTERNALBLKFNS) (SPECVARS PLVLFILEFLG)) (PROP BYTEMACRO IMAX2 IMIN2) (PROP BOX FLOAT) (FNS COMP.AREF COMP.ASET COMP.BOX COMP.LOOKFORDECLARE COMP.DECLARETYPE COMP.FLOATBOX COMP.FLOATUNBOX COMP.PREDP COMP.UBFLOAT2 COMP.UNBOX)) (ADDVARS (COMPILETYPELST)) (COMS (* ; "POST OPTIMIZATION") (FNS OPT.POSTOPT OPT.SETUPOPT OPT.SCANOPT OPT.XVARSCAN OPT.XVARSCAN1 OPT.JUMPOPT OPT.JUMPTHRU OPT.LBMERGE OPT.PRDEL OPT.UBDEL OPT.LBDEL OPT.LABELNTHPR OPT.JUMPREV OPT.COMMONBACK OPT.DELTAGREF OPT.FINDEND OPT.RETOPT OPT.RETFIND OPT.RETPOP OPT.RETOPT1 OPT.RETTEST OPT.RETMERGE OPT.CODELEV OPT.CODEFRAME OPT.DEFREFS OPT.SETDEFREFS) (FNS OPT.FRAMEOPT OPT.FRAMEMERGE OPT.NONILVAR OPT.MERGEFRAMEP OPT.FRAMELOCAL OPT.CLEANFRAME OPT.FRAMEDEL OPT.FRAMEVAR OPT.DELETEFRAMECHECK OPT.ONLYMEMB) (VARS MERGEFRAMETYPES (OPTIMIZATIONSOFF)) (FNS OPT.SKIPPUSH OPT.DELCODE OPT.PRATTACH OPT.JUMPCOPYTEST OPT.EQOP OPT.EQVALUE OPT.DELCOPYFN) (FNS OPT.DEADSETQP OPT.DS1) (INITVARS (*BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV)) (*BYTECOMPILER-OPTIMIZE-MACROLET* T)) (FUNCTIONS CL:MACROLET) (DECLARE%: EVAL@COMPILE DONTCOPY (SPECVARS *BYTECOMPILER-IS-EXPANDING* *BC-MACRO-ENVIRONMENT*) (SPECVARS CODE LEVEL) (SPECVARS CL:LABELS PASS ANY CODE FRAME FRAMES) (GLOBALVARS MERGEFRAMEMAX MERGEFRAMEFLG MERGEFRAMETYPES *BYTECOMPILER-OPTIMIZE-MACROLET*) (SPECVARS VARS ANY FRAME) (SPECVARS ICNT TAG) (SPECVARS FRAME LEVEL ANY) (SPECVARS FRAME LEVEL ANY) (SPECVARS TAGS ANY))) (COMS (* ; "CONSISTENCY CHECKS") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS OPT.CCHECK) (VARS (COMPILECOMPILERCHECKS NIL))) (FNS OPT.COMPILERERROR OPT.OPTCHECK OPT.CCHECK)) (GLOBALVARS ALAMS BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA CLEANFNLIST COMP.SCRATCH COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS CONDITIONALS CONST.FNS CONSTOPS DONOTHING FILERDTBL FNA FORSHALLOW FRA HEADERBYTES HOKEYDEFPROP LAMBDANOBIND LAMS LBA LEVELARRAY LINKEDFNS LOADTIMECONSTANT MAXBNILS MAXBVALS MCONSTOPS MERGEFRAMEFLG MERGEFRAMEMAX MERGEFRAMETYPES MOPARRAY MOPCODES NODARR NOSTATSFLG NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA SELECTQFMEMB SELECTVARTYPES STATAR STATMAX STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS VREFFRA COUTFILE XVARFLG MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN NEWOPTFLG) [P (CL:PROCLAIM '(CL:SPECIAL COMPVARMACROHASH] (DECLARE%: DONTCOPY (* ; "for compiling compiler") EVAL@COMPILE (RECORDS CODELST) (PROP MACRO OASSOC) (RECORDS OP JUMP TAG VAR) (RECORDS FRAME COMINFO COMP JD BLOCKSTATUS)) (MACROS THETYPE) (PROP FILETYPE BYTECOMPILER) (PROP MAKEFILE-ENVIRONMENT BYTECOMPILER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML OPT.INITHASH) (LAMA]) (* ;;; "THE BYTE LISP COMPILER") (RPAQ? *BYTECOMPILER-IS-EXPANDING* NIL) (DEFINEQ (BYTEBLOCKCOMPILE2 [LAMBDA (BLKNAME BLKDEFS ENTRIES) (* Pavel "15-Nov-86 16:11") (COND [(EQ BYTECOMPFLG 'NOBLOCK) (* ; "use PDP-10 compiler for blocks") (RESETVARS (BYTECOMPFLG) (RETURN (BLOCKCOMPILE2 BLKNAME BLKDEFS ENTRIES] (T (PROG [(BLKFLG T) (INTERNALBLKFNS (AND (NEQ BYTECOMPFLG 'RETRY) (for X in BLKDEFS when (NOT (OR (FMEMB (CAR X) ENTRIES) (EQ (CAR X) BLKNAME) (FMEMB (CAR X) RETFNS) (AND (LISTP NOLINKFNS) (FMEMB (CAR X) NOLINKFNS)) (FMEMB (CAR X) BLKAPPLYFNS))) collect (CONS (CAR X) (PACK* '\ BLKNAME '/ (CAR X] (* ; "this is a dummy block compiler") (SETQ COMP.GENFN.NUM 0) (RETURN (MAPCONC BLKDEFS (FUNCTION (LAMBDA (X) (PROG1 (COMP.ATTEMPT.COMPILE (OR (CDR (FASSOC (CAR X) INTERNALBLKFNS)) (CAR X)) (CADDR X) (CAR X)) (* ;; "The FRPLACA allows the function definitions to be reclaimed. This is written to parallel BLOCKCOMPILE2 which needs the list of BLKDEFS for something. --- rrb") (FRPLACA (CDDR X) (LIST (CAR (CADDR X)) (CADR (CADDR X]) (BYTECOMPILE2 [LAMBDA (FN DEF) (* JonL "17-Dec-83 03:41") (PROG ((BLKFLG NIL)) (SETQ COMP.GENFN.NUM 0) (COMP.ATTEMPT.COMPILE FN DEF) (RETURN FN]) (COMP.ATTEMPT.COMPILE [LAMBDA (TOPFN DEF RECNAME) (* Pavel "15-Nov-86 16:09") (PROG ((EMFLAG TOPFN) COMFNS FLG SUBFNFREEVARS) (* ; "compile attempt") (SETQ FLG (COMP.RETFROM.POINT TOPFN DEF RECNAME)) [COND ((NULL EMFLAG) (LISPXPRIN1 '"----- " T) (COND ((NEQ COUTFILE T) (LISPXPRIN1 '"----- " COUTFILE] (COND (FLG (* ; "compile succeed") (RETURN COMFNS)) ((AND (GETD 'COMPILE2) (NEQ BYTECOMPFLG T)) (* ; "retry with COMPILE2") (LISPXPRINT (CONS TOPFN '(-- retrying with COMPILE2)) T T) [COND (BLKFLG (OR (EQ SPECVARS T) (EVAL (CONS 'SPECVARS LOCALFREEVARS] (RETURN (COMPILE2 TOPFN DEF))) (T (LISPXPRINT [LIST (CONS TOPFN '(not compiled] T T) (RETURN]) (COMP.RETFROM.POINT [LAMBDA (COMFN DEF RECNAME) (* Pavel "15-Nov-86 16:06") (PROG ((LBCNT 0)) (* ;; "This is the RETFROM point in case of an error while compiling COMFN or any of its generated subfunctions.") (FETCH (COMP CLEAR) OF T) (* ;; "CLEAR is an accessfn which clears all of the hash tables used by any HASHLINK field in the compiler; done this way so that the program need not know which hash tables are used") (RETURN (PROG1 (COMP.TOPLEVEL.COMPILE COMFN DEF RECNAME) (FETCH (COMP CLEAR) OF T]) (COMP.TRANSFORM [LAMBDA (FORM) (* ; "Edited 22-Jun-88 18:18 by TAL") (* ;;; "FORM is a form whose CAR is guaranteed to have a macro definition or optimizer. Transform it as much as possible and then compile it appropriately.") (* ;; "I'd like to be able to provide an environment, but I don't know how.") (PROG ([CONTEXT (COND ((EQ COMPILE.CONTEXT 'EFFECT) (COMPILER:MAKE-CONTEXT :VALUES-USED 0)) ((COMP.PREDP COMPILE.CONTEXT) (SELECTQ (fetch (JUMP OPNAME) of COMPILE.CONTEXT) ((TJUMP FJUMP) (COMPILER:MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P T)) ((NTJUMP NFJUMP) (* ;  "We need the value, so make it argument context instead of predicate.") (COMPILER:MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P NIL)) (OPT.COMPILERERROR))) (T (COMPILER:MAKE-CONTEXT] VAL (*BC-MACRO-ENVIRONMENT* *BC-MACRO-ENVIRONMENT*) (*BYTECOMPILER-IS-EXPANDING* T)) (* ; "First, try to use an optimizer.") (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING* *BC-MACRO-ENVIRONMENT*)) [CL:MULTIPLE-VALUE-BIND (KIND EXPANDER) (COMPILER:ENV-FBOUNDP *BC-MACRO-ENVIRONMENT* (CAR FORM) :LEXICAL-ONLY T) [for OPT-FN in (AND (NOT KIND) (COMPILER:OPTIMIZER-LIST (CAR FORM))) do (LET ((RESULT (CL:FUNCALL OPT-FN FORM *BC-MACRO-ENVIRONMENT* CONTEXT))) (if (AND (NEQ RESULT 'IGNOREMACRO) (NEQ RESULT 'COMPILER:PASS) (NEQ RESULT FORM)) then (* ;  "An optimization has taken place. Start over.") (SETQ VAL (COMP.EXP1 RESULT)) (GO OUT] (if (EQ KIND :MACRO) then (* ;  "We've got a locally-defined macro...") (RETURN (COMP.EXP1 (CL:FUNCALL EXPANDER FORM *BC-MACRO-ENVIRONMENT*] (* ; "now try interlisp macro") [LET ((MACROPROP (GETMACROPROP (CAR FORM) COMPILERMACROPROPS))) (AND MACROPROP (RETURN (COMP.MACRO FORM MACROPROP] (* ;  "Next, look for a DEFMACRO-produced expansion function.") [LET [(EXPN-FN (GET (CAR FORM) 'MACRO-FN] (COND (EXPN-FN (RETURN (COMP.EXP1 (CL:FUNCALL EXPN-FN FORM *BC-MACRO-ENVIRONMENT*] [RETURN (COMP.CALL (CAR FORM) (CDR FORM) (COMP.ARGTYPE (CAR FORM] OUT (RETURN VAL]) (COMPERROR [LAMBDA (X) (* Pavel "15-Nov-86 16:10") (* ;;;  "Terminal-error handler: Aborts the compilation of this function after issuing the proper message.") (AND X (COMPERRM X)) (RETFROM 'COMP.RETFROM.POINT NIL]) (COMPPRINT [LAMBDA (X) (* ; "Edited 20-Jan-88 10:54 by jds") (* A separate function so it can be broken or advised) (PRIN1 X COUTFILE T]) (COMPERRM [LAMBDA (X FL) (* jds " 1-Feb-84 15:34") (* Emit an error message for the  compiler) (AND (NULL FL) (SETQ FL COUTFILE)) (* If he specified no file, use the  compiler-message file.) (COND (EMFLAG (LISPXTAB 0 0 FL) (LISPXPRIN1 '"-----In " FL) (LISPXPRIN2 EMFLAG FL T) (LISPXPRINT '%: FL))) [COND (X (LISPXPRIN1 '***** FL T) (PROG ((PLVLFILEFLG T)) (RESETFORM (PRINTLEVEL 2 20) (LISPXPRINT X FL T] (COND ((NEQ FL T) (* so message gets printed in both  places) (* i.e., force the message to go to the terminal as well.) (COMPERRM X T))) (SETQ EMFLAG NIL]) ) (DEFINEQ (COMP.TOPLEVEL.COMPILE [LAMBDA (COMFN DEF RECNAME OUTER-ALLVARS) (* ; "Edited 17-Jul-90 10:28 by jds") (* ;; "This function controls the compilation of a single function.") (PROG (ALAMS1 NLAMS1 CONSTS ALLVARS ALLDECLS ARGVARS ARGS COMTYPE CODE FREEVARS CI (LEVEL 0) FRAME PIFN TOPLAB (LOCALVARS LOCALVARS) (SPECVARS SPECVARS) (*BC-MACRO-ENVIRONMENT* (COMPILER::COPY-ENV *BC-MACRO-ENVIRONMENT*)) (COMPILER::*ENVIRONMENT* (COMPILER::MAKE-ENV :PARENT T)) TOPFRAME MACEXP AC FRELST (COMPILE.DUNBIND.POP.MERGE.FLG T) TEMP) RETRY [OR [AND (LISTP DEF) (LISTP (CDR DEF)) (SETQ COMTYPE (COND [(OR (LISTP (SETQ ARGS (CADR DEF))) (NULL ARGS)) (SELECTQ (CAR DEF) (NLAMBDA 1) ([LAMBDA OPENLAMBDA] 0) (CL:LAMBDA (SETQ DEF (\TRANSLATE-CL%:LAMBDA DEF)) (GO RETRY)) (COND ((AND COMPILEUSERFN (SETQ DEF (APPLY* COMPILEUSERFN NIL DEF))) (GO RETRY] (T (COND ((AND LAMBDANOBIND (EQ ARGS 'NOBIND)) (SETQ ARGS NIL) 2) (T (SETQ ARGS (LIST ARGS)) (SELECTQ (CAR DEF) (LAMBDA 2) (NLAMBDA 3) (COND ((AND COMPILEUSERFN (SETQ DEF (APPLY* COMPILEUSERFN NIL DEF))) (GO RETRY] (COMPERROR (CONS COMFN '(not compilable] (SETQ PIFN (COND ((EQ PIFN T) (* ; "compile as call to self") 0) ((GETPROP COMFN OPCODEPROP) 0) ((EQ 0 COMTYPE) (OR RECNAME COMFN)) (T 0))) (SETQ FRAME (SETQ TOPFRAME (create FRAME VARS _ (SETQ ARGVARS (SETQ ALLVARS (COMP.BINDLIST ARGS))) NNILS _ 0))) (COMP.STTAG (SETQ TOPLAB (create TAG))) (COMP.VALN (CDDR DEF) 'RETURN) (COMP.UNBIND.VARS TOPFRAME T) (SETQ CI (create COMINFO COMTYPE _ COMTYPE CODE _ (OPT.POSTOPT CODE) TOPFRAME _ TOPFRAME ARGS _ ARGVARS)) (SETQ FREELST (FOR X IN FREEVARS WHEN (EQ (FETCH OPNAME OF X) 'FVAR) COLLECT (FETCH OPARG OF X))) [SETQ ALAMS1 (SUBSET ALAMS1 (FUNCTION (LAMBDA (X) (NOT (GETPROP X OPCODEPROP] (* ;; "Print out the status message for this function, noting the free variable references and calls to unknown functions. We don't report free variables that are either proclaimed special or bound in a super function of this one.") [LET* ((OUTER-VARS (FOR X IN OUTER-ALLVARS COLLECT (FETCH OPARG OF X))) (USES-LIST (FOR X IN FREELST UNLESS (OR (VARIABLE-GLOBALLY-SPECIAL-P X) (FMEMB X OUTER-VARS)) COLLECT X))) (COMPPRINT (CL:FORMAT NIL "(~S ~A~@[ (uses~{ ~S~})~]~@[ (calls~{ ~S~})~]~@[ (nlams~{ ~S~})~])~%%" COMFN (CADR DEF) USES-LIST ALAMS1 NLAMS1)) (* (COMPPRINT (BQUOTE  ((\, COMFN) (\, (CADR DEF))  (\,@ (AND USES-LIST  (BQUOTE ((:USES (\,@ USES-LIST))))))  (\,@ (AND ALAMS1 (BQUOTE  ((:CALLS (\,@ ALAMS1))))))  (\,@ (AND NLAMS1 (BQUOTE  ((:NLAMS (\,@ NLAMS1)))))))))) ] (SELECTQ LAPFLG ((1 T) (RESETFORM (OUTPUT LSTFIL) (COMP.MLLIST COMFN CI))) NIL) (APPLY* BYTEASSEMFN COMFN CI) [COND ((NEQ COMFN TOPFN) (* ; "generated subfunction") (SETQ SUBFNFREEVARS (APPEND SUBFNFREEVARS FREELST] (SETQ COMFNS (CONS COMFN COMFNS)) (RETURN COMFN]) (COMP.BINDLIST [LAMBDA (VARS) (* lmm " 1-Jul-84 17:00") (for VAR in VARS collect (create VAR VARNAME _ (COMP.CHECK.VAR VAR T) COMP.VARTYPE _ (COMP.VARTYPE VAR]) (COMP.CHECK.VAR [LAMBDA (X BIND) (* lmm " 6-Apr-84 17:49") [COND (BIND [COND ((NEQ X (COMP.USERFN X)) (COMPERRM (APPEND '(Attempt to bind CONSTANT) X] (COND ((COMP.GLOBALVARP X) (COMPERRM (CONS X '(- is global] (OR (AND (LITATOM X) (NEQ X T) X) (COMPERROR (CONS X '(is not a legal variable name]) (COMP.BIND.VARS [LAMBDA (ARGS VALS TYPE DECLARATIONS) (* Pavel "15-Nov-86 16:39") (PROG (VLV VLN NVALS NNILS DECL X VAR DECLS VAL) (for VARNAME in ARGS do (SETQ VAR (create VAR VARNAME _ (COMP.CHECK.VAR VARNAME T) COMP.VARTYPE _ (COMP.VARTYPE VARNAME))) (if (SETQ X (CDR (FASSOC VARNAME DECLARATIONS))) then (* ;  "variable declared to be of a given type") (COMP.EXPR (SETQ VAL (pop VALS)) (AND VAL X)) (replace (VAR COMP.VARTYPE) of VAR with 'HVAR) (push DECLS (CONS VAR X)) (push VLV VAR) elseif [OR (NULL (SETQ X (pop VALS))) (PROGN (COMP.VAL X) (COND ((EQ (CAR CODE) OPNIL) (COMP.DELPUSH) T] then (push VLN VAR) else (push VLV VAR))) (for X in VALS do (COMP.EFFECT X)) (SETQ NNILS (LENGTH VLN)) [COND ((IGREATERP (SETQ NVALS (LENGTH VLV)) MAXBVALS) (COMPERROR (CONS EXP '(-- too many variables with values] (RETURN (create FRAME PARENT _ FRAME NVALS _ (LENGTH VLV) VARS _ (OPT.DREV VLV (OPT.DREV VLN)) FRAMETYPE _ TYPE NNILS _ NNILS DECLS _ DECLS]) (COMP.UNBIND.VARS [LAMBDA (F TOPFLG) (* lmm "29-Jun-84 09:34") (COND ((NOT (OR TOPFLG (EQ COMPILE.CONTEXT 'RETURN) (OPT.JUMPCHECK CODE))) (OPT.CCHECK (EQ F FRAME)) (COMP.STUNBIND (EQ COMPILE.CONTEXT 'EFFECT)) (replace (FRAME PRIMARYRETURN) of (CAR CODE) with T))) 'NOVALUE]) ) (DEFINEQ (COMP.VALN [LAMBDA (L COMPILE.CONTEXT) (* lmm "29-Jun-84 08:25") (COMP.PROGN L]) (COMP.PROGN [LAMBDA (A) (* lmm "13-Jul-84 21:18") (COND ((NULL (CDR A)) (COMP.EXP1 (CAR A))) (T (PROG [(FLG (AND (NOT OPTIMIZATIONSOFF) (EQ COMPILE.CONTEXT 'RETURN] LP (COMP.EFFECT (CAR A)) (AND FLG (while (EQ (CAR CODE) OPPOP) do (* delete POP in PROGN) (COMP.DELPOP))) (COND ((OPT.JUMPCHECK CODE)) ((CDR (SETQ A (CDR A))) (GO LP)) (T (RETURN (COMP.EXP1 (CAR A]) (COMP.PROGLST [LAMBDA (LST N CONTEXT) (* lmm "18-Sep-84 16:28") (PROG (VAL) (while (IGREATERP N 0) do (SETQ VAL (COMP.EXPR (pop LST) (AND (EQ N 1) CONTEXT))) (add N -1)) (while (EQ (CAR (LISTP (CAR LST))) '*) do (pop LST)) [if LST then (COMPERRM `(extraneous arguments to %, (CAR EXP) %: ., LST)) (SELECTQ CONTEXT ((NIL EFFECT) (* ok NIL) (MAPC LST (FUNCTION COMP.EFFECT))) (COMPERRM '(not compiled] (RETURN VAL]) (COMP.EXP1 [LAMBDA (E) (* lmm "29-Jun-84 08:25") (COMP.EXPR E COMPILE.CONTEXT]) (COMP.EXPR [LAMBDA (EXP COMPILE.CONTEXT) (* ; "Edited 26-Apr-91 13:08 by jds") (DECLARE (SPECVARS *BC-MACRO-ENVIRONMENT*)) (PROG (M V) [COND ((NULL FRAME) (COND [(OPT.JUMPCHECK CODE) (RETURN (COND ((COMP.PREDP COMPILE.CONTEXT) 'PREDVALUE) (T 'NOVALUE] (T (OPT.COMPILERERROR] (AND (EQ COMPILE.CONTEXT 'EFFECT) (COMP.NOSIDEEFFECTP EXP) (RETURN 'NOVALUE)) TOP [SETQ V (COND [(NLISTP EXP) (COND ((LITATOM EXP) (SELECTQ EXP ((T NIL) (COMP.CONST EXP)) (COMP.VAR EXP))) ([OR (NUMBERP EXP) (PROGN (* ; "non-quoted string") (OR [NULL (SETQ M (CDR (FASSOC (TYPENAME EXP) COMPILETYPELST] (EQ EXP (SETQ EXP (APPLY* M EXP] (COMP.CONST EXP)) (T (GO TOP] [[NOT (LITATOM (SETQ M (CAR EXP] (SELECTQ (CAR (LISTP M)) ([LAMBDA NLAMBDA OPENLAMBDA] (COMP.LAMBDA M (CDR EXP))) (CL:LAMBDA (* ;  "Edited by TT(13-June-90) support convertion of CL:LAMBDA") (SETQ EXP (CONS (\TRANSLATE-CL%:LAMBDA M) (CDR EXP))) (GO TOP)) (OPCODES (OR (fetch EXTCALL of FRAME) (COMP.CLEANFNOP M 'FREEVARS) (replace EXTCALL of FRAME with F)) (COMP.STFN (CAR EXP) (for X in (CDR EXP) sum (COMP.VAL X) 1))) (COND ((SETQ M (COMP.TRYUSERFN EXP)) (SETQ EXP M) (GO TOP)) (T (COMPERROR (CONS M '(- non-atomic CAR of form] ((OR (AND (SETQ V (GETMACROPROP M COMPILERMACROPROPS)) (NEQ V T)) (GET M 'MACRO-FN) (COMPILER:OPTIMIZER-LIST M) (EQ (COMPILER:ENV-FBOUNDP *BC-MACRO-ENVIRONMENT* M :LEXICAL-ONLY T) :MACRO)) (COMP.TRANSFORM EXP)) ((AND (EQ COMPILE.CONTEXT 'RETURN) (EQ M PIFN)) (COMP.CPI M (CDR EXP))) ((SETQ V (COMP.ARGTYPE M)) (COMP.CALL M (CDR EXP) V)) ((SETQ V (COMP.TRYUSERFN EXP)) (SETQ EXP V) (GO TOP)) (T (COMP.CALL M (CDR EXP] (RETURN (SELECTQ COMPILE.CONTEXT (NIL NIL) (EFFECT (OR (EQ V 'NOVALUE) (COMP.STPOP)) 'NOVALUE) (RETURN (OR (OPT.JUMPCHECK CODE) (COMP.STRETURN)) 'NOVALUE) (COND ((COMP.PREDP COMPILE.CONTEXT) (COND ((NEQ V 'PREDVALUE) (* ;  "in this case, COMPILE.CONTEXT is a jump instruction") (COMP.STJUMP COMPILE.CONTEXT))) 'PREDVALUE) ((EQ (CAR (LISTP COMPILE.CONTEXT)) 'TYPE) NIL) ((EQ (CAR (LISTP COMPILE.CONTEXT)) 'UNBOXED) (OR (EQ V 'UNBOXED) (COMP.UNBOX (CDR COMPILE.CONTEXT))) 'UNBOXED]) (COMP.TRYUSERFN [LAMBDA (EXP M) (AND COMPILEUSERFN (COND ((EQ (SETQ M (COMP.USERFN EXP)) 'INSTRUCTIONS) [COMPERRM (CONS EXP '(COMPILEUSERFN returned INSTRUCTIONS] NIL) (T M]) (COMP.USERFN [LAMBDA (X) (* ; "Edited 7-Apr-87 13:12 by Pavel") (COND ((CL:KEYWORDP X) (LIST 'QUOTE X)) [(AND (EQ [CAR (LISTP (CAR (LISTP X] 'CL:LAMBDA) (COND ((INTERSECTION (CADR (CAR X)) CL:LAMBDA-LIST-KEYWORDS) (ERROR "Can't cope with lambda keywords in internal LAMBDA lists")) (T `([LAMBDA ,@(CDAR X] ,@(CDR X] ((LITATOM X) (OR (AND COMPVARMACROHASH (GETHASH X COMPVARMACROHASH)) X)) (T (LET [(FN TOPFN) (OTHERVARS (FOR X IN ALLVARS COLLECT (FETCH OPARG OF X] (DECLARE (SPECVARS FN OTHERVARS)) (* ; "uses FN DEF ARGS OTHERVARS") (APPLY* COMPILEUSERFN (CDR X) X]) (COMP.CONST [LAMBDA (X) (* lmm "13-Jul-84 21:18") (COND ((AND (NOT OPTIMIZATIONSOFF) (EQ COMPILE.CONTEXT 'EFFECT)) (* CONST in (EQ COMPILE.CONTEXT  (QUOTE EFFECT))) 'NOVALUE) ((AND (NOT OPTIMIZATIONSOFF) (COMP.PREDP COMPILE.CONTEXT)) [AND (SELECTQ (fetch OPNAME of COMPILE.CONTEXT) (TJUMP X) (NTJUMP (COND (X (COMP.STCONST X) T))) (FJUMP (NOT X)) (NFJUMP (COND ((NOT X) (COMP.STCONST X) T))) (SHOULDNT)) (COMP.STJUMP 'JUMP (CAR (fetch OPARG of COMPILE.CONTEXT)) (CDR (fetch OPARG of COMPILE.CONTEXT] 'PREDVALUE) (T (COMP.STCONST X]) (COMP.CALL [LAMBDA (F A TYP) (* ; "Edited 9-Feb-87 18:29 by Pavel") (PROG ((N 0)) (OR (fetch EXTCALL of FRAME) (COMP.CLEANFNOP F 'FREEVARS) (replace EXTCALL of FRAME with F)) (SELECTQ TYP (3 (* ;  "call nlambda by applying with entire arglist as first arg") (pushnew NLAMS1 F) (COMP.STCONST A) (RETURN (COMP.STFN F 1))) (1 (* ;  "call NLAMBDA spread merely by not compiling arguments") (pushnew NLAMS1 F)) (NIL (* ;  "unknown argtype, assume lambda, but warn user") (pushnew ALAMS1 F)) NIL) LP [COND ((LISTP A) (SELECTQ TYP (1 (COMP.STCONST (CAR A))) (COMP.VAL (CAR A))) (SETQ N (ADD1 N)) (SETQ A (CDR A)) (GO LP)) (A (COMPERROR (CONS A '(- unusual tail for argument list] (RETURN (COMP.STFN F N]) (COMP.VAR [LAMBDA (VAR) (* lmm "24-Jan-85 18:40") (COND ((EQ COMPILE.CONTEXT 'EFFECT) (* VAR in EFFECT) 'NOVALUE) (T (SETQ VAR (COMP.LOOKUPVAR VAR T)) (COMP.STVAR VAR) (LET [(DECL (CDR (ASSOC VAR ALLDECLS] (if (EQ (CAR (LISTP DECL)) 'UNBOXED) then (COMP.BOX (CDR DECL]) (COMP.VAL1 [LAMBDA (L COMPILE.CONTEXT) (* lmm "29-Jun-84 08:25") (COMP.PROG1 L]) (COMP.PROG1 [LAMBDA (A) (* lmm "29-Jun-84 08:25") (COND ((NULL (CDR A)) (COMP.EXP1 (CAR A))) (T (PROG1 (COMP.EXPR (CAR A) (COND ((EQ COMPILE.CONTEXT 'EFFECT) COMPILE.CONTEXT))) (MAPC (CDR A) (FUNCTION COMP.EFFECT]) (COMP.EFFECT [LAMBDA (E) (* lmm "13-Jul-84 21:18") (PROG ((LV LEVEL)) (COND ((OPT.JUMPCHECK CODE) (* code for effect eliminated after  JUMP or RETURN) (RETURN)) (T (OPT.CCHECK LV))) (RETURN (PROG1 (COMP.EXPR E 'EFFECT) (OPT.CCHECK (OR AC (EQ LEVEL LV) (OPT.JUMPCHECK CODE]) (COMP.VAL [LAMBDA (X) (* lmm "13-Jul-84 21:18") (PROG ((LV LEVEL)) (COND ((OPT.JUMPCHECK CODE) (* code for value eliminated after  JUMP or RETURN) (RETURN))) (RETURN (PROG1 (COMP.EXPR X) (OPT.CCHECK (OR (EQ (ADD1 LV) LEVEL) AC (OPT.JUMPCHECK CODE]) (COMP.MACRO [LAMBDA (EXP MAC) (* ; "Edited 11-May-87 16:25 by amd") (COND [(NLISTP MAC) (SELECTQ MAC (T (* ;  "The macro is 'T'. Compile this as a function-call.") (COMP.CALL (CAR EXP) (CDR EXP) (COMP.ARGTYPE (CAR EXP)))) (COMP.PUNT (COMP.PUNT)) (BLKAPPLY* MAC (CDR EXP] (T (SELECTQ (CAR MAC) (APPLY (APPLY (CADR MAC) (CDR EXP))) (APPLY* (APPLY (CADR MAC) (CONS (CDR EXP) (CDDR MAC)))) (OPENLAMBDA (COMP.LAMBDA MAC (CDR EXP))) (LET* ((*BYTECOMPILER-IS-EXPANDING* T) (EXPANSION (MACROEXPANSION EXP MAC T COMPILE.CONTEXT))) (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*)) (if (EQ EXPANSION EXP) then (* ;  "can't expand, e.g. returns IGNOREMACRO") (COMP.CALL (CAR EXP) (CDR EXP) (COMP.ARGTYPE (CAR EXP))) else (COMP.EXP1 EXPANSION]) ) (DEFINEQ (COMP.VARTYPE [LAMBDA (VAR) (* lmm "13-MAR-81 09:36") (OPT.CCHECK (AND VAR (LITATOM VAR))) (COND ((COMP.ANONP VAR) 'HVAR) (T 'AVAR]) (COMP.LOOKUPVAR [LAMBDA (V FORVALUE) (* jds " 1-Feb-84 15:08") (PROG (X) (COND ((SETQ X (find VAR in ALLVARS suchthat (EQ (fetch VARNAME of VAR) V))) (RETURN X))) (COND ((SETQ X (find VAR in FREEVARS suchthat (EQ (fetch VARNAME of VAR) V))) (RETURN X))) [COND ((NEQ V (SETQ X (COMP.USERFN V))) (COND (FORVALUE (RETAPPLY 'COMP.VAR (FUNCTION COMP.VAL) (LIST X) T)) (T (COMPERRM (CONS V " - is compile time constant, yet is bound or set."] (SETQ FREEVARS (CONS (SETQ X (create VAR COMP.VARTYPE _ (COND ((AND GLOBALVARFLG (COMP.GLOBALVARP V)) 'GVAR) (T 'FVAR)) VARNAME _ (COMP.CHECK.VAR V))) FREEVARS)) (RETURN X]) (COMP.LOOKUPCONST [LAMBDA (X) (* lmm "24-JUN-78 22:56") (COND ((NULL X) OPNIL) (T (OR [CAR (SOME CONSTS (FUNCTION (LAMBDA (Y) (EQ X (fetch OPARG of Y] (PROG1 (SETQ X (create OP OPNAME _ 'CONST OPARG _ X)) (SETQ CONSTS (NCONC1 CONSTS X]) ) (DEFINEQ (COMP.ST [LAMBDA (X DL) (* lmm "13-Jul-84 21:18") (OPT.CCHECK DL) (COND [(OR LEVEL (EQ DL T)) (SETQ CODE (CONS X CODE)) (SETQ LEVEL (COND ((FIXP DL) (IPLUS LEVEL DL] (T (OPT.CCHECK (OPT.JUMPCHECK CODE)) (* didn't store code after JUMP or  RETURN) NIL]) (COMP.STFN [LAMBDA (FN N) (* lmm "16-APR-82 00:14") (COMP.ST (create OP OPNAME _ 'FN OPARG _ (CONS N (OR (AND BLKFLG (LITATOM FN) (CDR (FASSOC FN INTERNALBLKFNS))) FN))) (IDIFFERENCE 1 N]) (COMP.STCONST [LAMBDA (X) (* lmm "16-APR-82 00:14") (COMP.ST (COMP.LOOKUPCONST X) 1]) (COMP.STVAR [LAMBDA (VREF) (* lmm "16-APR-82 00:14") (COMP.ST VREF 1]) (COMP.STPOP [LAMBDA (N) (* lmm "16-APR-82 00:14") (RPTQ (OR N 1) (COMP.ST OPPOP -1]) (COMP.DELFN [LAMBDA NIL (* lmm%: "22-JUL-77 02:40") [SETQ LEVEL (IPLUS (SUB1 LEVEL) (CAR (fetch OPARG of (CAR CODE] (SETQ CODE (CDR CODE]) (COMP.STRETURN [LAMBDA NIL (* lmm "16-APR-82 00:13") (COMP.ST OPRETURN T) (SETQ LEVEL (SETQ FRAME]) (COMP.STTAG [LAMBDA (TAG) (* lmm "13-Jul-84 21:18") (PROG ((NLV (fetch (TAG LEVEL) of TAG)) (NF (fetch (TAG FRAME) of TAG))) (OR (COND [(OR NLV NF) (AND (EQ NLV (OR LEVEL (SETQ LEVEL NLV))) (EQ NF (OR FRAME (SETQ FRAME NF] ((OR LEVEL FRAME) (AND (replace (TAG LEVEL) of TAG with LEVEL) (replace (TAG FRAME) of TAG with FRAME))) (T T)) (OPT.COMPILERERROR)) [COND ((AND (EQ (fetch OPNAME of (CAR CODE)) 'JUMP) (EQ (fetch (JUMP TAG) of (CAR CODE)) TAG)) (* delete JUMP to next in COMP.STTAG) (SETQ CODE (CDR CODE] (COMP.ST TAG 0]) (COMP.STJUMP [LAMBDA (OP TAG JT) (* lmm "13-Jul-84 21:18") (COND ((OPT.JUMPCHECK CODE) (* JUMP not stored after JUMP or  RETURN) NIL) (T [COND ((NULL TAG) (* even if OP is given and in correct format, re-cons it up since OPT.POSTOPT  might smash it) (SETQ TAG (CAR (fetch OPARG of OP))) (SETQ JT (CDR (fetch OPARG of OP))) (SETQ OP (fetch OPNAME of OP] (COMP.ST (create JUMP OPNAME _ OP TAG _ TAG JT _ JT) 0) (PROG ((F (fetch FRAME of TAG)) (V (fetch (TAG LEVEL) of TAG)) NV) (COND (F (OPT.CCHECK (EQ F FRAME))) (T (replace (TAG FRAME) of TAG with FRAME))) (SETQ NV (SELECTQ OP (JUMP (PROG1 LEVEL (SETQ FRAME (SETQ LEVEL)))) ((FJUMP TJUMP) (SETQ LEVEL (SUB1 LEVEL))) ((NFJUMP NTJUMP) (PROG1 LEVEL (SETQ LEVEL (SUB1 LEVEL)))) (ERRORSET (PROG1 (SUB1 LEVEL) (SETQ FRAME JT) (SETQ LEVEL 0))) (OPT.COMPILERERROR))) (OPT.CCHECK (OR (NULL NV) (IGEQ NV 0))) (OPT.CCHECK (OR (NULL LEVEL) (IGEQ LEVEL 0))) (COND (V (OPT.CCHECK (EQ V NV))) (T (replace (TAG LEVEL) of TAG with NV]) (COMP.STSETQ [LAMBDA (VREF) (* lmm "16-APR-82 00:14") (OPT.CCHECK (IGREATERP LEVEL 0)) (COMP.ST (create OP OPNAME _ 'SETQ OPARG _ VREF) 0]) (COMP.STCOPY [LAMBDA NIL (* lmm "16-APR-82 00:14") (OPT.CCHECK (IGREATERP LEVEL 0)) (COMP.ST OPCOPY 1]) (COMP.DELPUSH [LAMBDA NIL (* lmm%: " 9-AUG-76 21:50:49") (SUB1VAR LEVEL) (SETQ CODE (CDR CODE]) (COMP.DELPOP [LAMBDA NIL (* lmm "28-OCT-77 15:23") (SETQ LEVEL (ADD1 LEVEL)) (SETQ CODE (CDR CODE]) (COMP.STBIND [LAMBDA (F) (* lmm " 1-Jul-84 14:48") [COND ((NULL (fetch PARENT of F)) (replace PARENT of F with FRAME)) (T (OPT.CCHECK (EQ (fetch PARENT of F) FRAME] [COND [(NULL (fetch (FRAME LEVEL) of F)) (replace (FRAME LEVEL) of F with (IDIFFERENCE LEVEL (fetch NVALS of F] (T (OPT.CCHECK (EQ (fetch (FRAME LEVEL) of F) (IDIFFERENCE LEVEL (fetch NVALS of F] (COND ([EVERY CODE (FUNCTION (LAMBDA (X) (SELECTQ (fetch OPNAME of X) ((TAG HVAR AVAR GVAR CONST) T) (FN (OR (NULL (fetch (FRAME VARS) of F)) (COMP.CLEANFNOP (CDR (fetch OPARG of X)) 'FREEVARS))) NIL] (* PROG is first thing in function) (replace CPIOK of F with T))) (COMP.ST (create OP OPNAME _ 'BIND OPARG _ (CONS NIL F)) 0) (SETQ FRAME F) (SETQ LEVEL 0]) (COMP.STUNBIND [LAMBDA (D) (* lmm "16-APR-82 00:14") (COMP.ST (create OP OPNAME _ (COND (D 'DUNBIND) (T 'UNBIND)) OPARG _ (CONS LEVEL FRAME)) 0) [SETQ LEVEL (IPLUS (fetch (FRAME LEVEL) of FRAME) (COND (D 0) (T 1] (SETQ FRAME (fetch PARENT of FRAME]) ) (RPAQQ *NO-SIDE-EFFECT-FNS* (CL::%%* CL::%%+ CL::%%- CL::%%/ CL::%%< CL::%%= CL::%%> CL::%%LLSH1 CL::%%LLSH8 CL::%%LOGIOR CL::%%LRSH1 CL::%%LRSH8 CL:* + - / CL:/= /= CL:1+ CL:1- < <= = > >= ABS CL:ACOS CL:ACOSH ADD1 CL:ADJUSTABLE-ARRAY-P CL:ALPHA-CHAR-P CL:ALPHANUMERICP AND ANTILOG APPEND ARCCOS ARCSIN ARCTAN ARCTAN2 CL:AREF CL:ARRAY-ELEMENT-TYPE CL:ARRAY-HAS-FILL-POINTER-P CL:ARRAY-RANK ARRAYORIG CL:ARRAYP ARRAYP ARRAYSIZE ARRAYTYP CL:ASH CL:ASIN CL:ASINH ASSOC CL:ATAN CL:ATANH CL:ATOM ATOM CL:BIT-VECTOR-P BITCLEAR BITSET BITTEST CL:BOOLE CL:BOTH-CASE-P BYTE CL:BYTE-POSITION BYTE-SIZE BYTEPOSITION BYTESIZE CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR CAR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR CDDDR CDDR CDR CL:CEILING CL:CHAR-BIT CL:CHAR-BITS CL:CHAR-CODE CL:CHAR-DOWNCASE CL:CHAR-EQUAL CL:CHAR-FONT CL:CHAR-GREATERP CL:CHAR-INT CL:CHAR-LESSP CL:CHAR-NAME CL:CHAR-NOT-EQUAL CL:CHAR-NOT-GREATERP CL:CHAR-NOT-LESSP CL:CHAR-UPCASE CL:CHAR/= CL:CHAR< CL:CHAR<= CL:CHAR= CL:CHAR> CL:CHAR>= CL:CHARACTER CHARACTER CL:CHARACTERP CL:CIS CL:CODE-CHAR CL:COMMONP CL:COMPILED-FUNCTION-P COMPLEX CL:COMPLEXP CL:CONJUGATE CONS CL:CONSP COPY COPYALL CL:COS COS CL:COSH DATEFORMAT CL:DECODE-FLOAT CL:DECODE-UNIVERSAL-TIME CL:DENOMINATOR CL:DEPOSIT-FIELD DEPOSITBYTE DIFFERENCE CL:DIGIT-CHAR CL:DIGIT-CHAR-P DPB CL:EIGHTH ELT ELTD CL:ENCODE-UNIVERSAL-TIME CL:ENDP EQ EQL EQP CL:EQUAL EQUAL CL:EQUALP EVENP CL:EXP CL:EXPT EXPT FASSOC CL:FCEILING FCHARACTER FDIFFERENCE FEQP CL:FFLOOR FGREATERP CL:FIFTH CL:FIRST FIX FIXP FIXR FLESSP FLOAT CL:FLOAT-DIGITS CL:FLOAT-PRECISION CL:FLOAT-RADIX CL:FLOAT-SIGN CL:FLOATP FLOATP CL:FLOOR FMAX FMEMB FMIN FMINUS CL:FOURTH FPLUS FPLUS2 FQUOTIENT FREMAINDER CL:FROUND FTIMES CL:FTRUNCATE CL:FUNCTIONP CL:GCD GCD GEQ GETHASH GETP GETPROP CL:GRAPHIC-CHAR-P GREATERP HARRAYP HARRAYSIZE CL:HASH-TABLE-P CL:IDENTITY IDIFFERENCE IEQP IGEQ IGREATERP ILEQ ILESSP CL:IMAGPART IMAX IMIN IMINUS IMOD CL:INPUT-STREAM-P CL:INT-CHAR CL:INTEGER-DECODE-FLOAT CL:INTEGER-LENGTH INTEGERLENGTH CL:INTEGERP INTERSECTION IPLUS IQUOTIENT IREMAINDER CL:ISQRT ITIMES CL:KEYWORDP KWOTE LAST CL:LCM LDB CL:LDB-TEST LEQ LESSP LIST CL:LIST-LENGTH CL:LISTP LISTP LITATOM LLSH LOADBYTE LOG CL:LOG LOGAND CL:LOGANDC1 CL:LOGANDC2 CL:LOGBITP CL:LOGCOUNT CL:LOGEQV CL:LOGIOR CL:LOGNAND CL:LOGNOR LOGNOT LOGOR CL:LOGORC1 CL:LOGORC2 CL:LOGTEST LOGXOR CL:LOWER-CASE-P LRSH LSH CL:MAKE-CHAR CL:MASK-FIELD MASK.0'S MASK.1'S MAX MEMB MEMBER MIN MINUS MINUSP CL:MOD CL:NAME-CHAR NEQ NILL CL:NINTH NLISTP NOT CL:NTH CL:NTHCDR NTYPX NULL CL:NUMBERP NUMBERP CL:NUMERATOR ODDP OR CL:OUTPUT-STREAM-P CL:PACKAGEP CL:PATHNAMEP CL:PHASE PLUS CL:PLUSP POWEROFTWOP PROG1 PROGN QUOTIENT CL:RANDOM-STATE-P CL:RATIONAL CL:RATIONALIZE CL:RATIONALP READTABLEP CL:REALPART RELSTKP CL:REM REMAINDER CL:REST ROT ROUND RSH SASSOC CL:SCALE-FLOAT XCL::SCEILING CL:SECOND CL:SET-CHAR-BIT CL:SEVENTH XCL::SFLOOR CL:SIGNUM CL:SIMPLE-BIT-VECTOR-P CL:SIMPLE-STRING-P CL:SIMPLE-VECTOR-P CL:SIN SIN CL:SINH CL:SIXTH SMALLP CL:SQRT SQRT XCL::SROUND STACKP CL:STANDARD-CHAR-P STKNARGS CL:STREAM-ELEMENT-TYPE STREAMP CL:STRING-CHAR-P STRING-EQUAL CL:STRING-GREATERP CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP STRING.EQUAL CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>= CL:STRINGP STRINGP XCL::STRUNCATE SUB1 CL:SUBTYPEP CL:SXHASH CL:SYMBOLP TAILP TAN CL:TAN CL:TANH CL:TENTH CL:THIRD TIMEREXPIRED? TIMES TRUE CL:TRUNCATE CL:TYPE-OF TYPEP UNION CL:UPPER-CASE-P CL:VECTORP ZERO CL:ZEROP ZEROP \ADDBASE \ARG0 \CALLME \GETBASE \GETBASEBYTE \GETBASEFIXP \GETBASEPTR \GETBASESTRING \VAG2 create fetch)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *NO-SIDE-EFFECT-FNS*) ) (DEFINEQ (COMP.ARGTYPE [LAMBDA (FN) (* lmm "25-FEB-82 16:29") (PROG NIL (RETURN (COND ((NOT (LITATOM FN)) (ARGTYPE FN)) ((FMEMB FN LAMA) 2) ((FMEMB FN LAMS) 0) ((FMEMB FN NLAML) 1) ((FMEMB FN NLAMA) 3) (T (ARGTYPE (OR [AND BLKFLG (OR (CADDR (FASSOC FN BLKDEFS)) (AND (FMEMB FN BLKLIBRARY) (GETP FN 'BLKLIBRARYDEF] (GETPROP FN 'BROKEN) (AND (GETD FN) FN) (GETPROP FN 'EXPR) (RETURN (COND ((FMEMB FN NOFIXFNSLST) 2) (T NIL]) (COMP.CLEANEXPP [LAMBDA (X TYPE) (* lmm "15-APR-82 23:01") (COND ((NLISTP X)) ((COMP.CLEANFNP (CAR X) TYPE) (EVERY (CDR X) (FUNCTION (LAMBDA (X) (COMP.CLEANEXPP X TYPE]) (COMP.CLEANFNP [LAMBDA (X TYPE) (* lmm "15-APR-82 23:02") (COND ((LITATOM X) (APPLY* CLEANFNTEST X)) ((LISTP X) (SELECTQ (CAR X) ([LAMBDA OPENLAMBDA] [EVERY (CDDR X) (FUNCTION (LAMBDA (X) (COMP.CLEANEXPP X TYPE]) NIL]) (COMP.CLEANFNOP [LAMBDA (FN TYPE) (* lmm "15-APR-82 23:07") (APPLY* CLEANFNTEST FN TYPE]) (COMP.GLOBALVARP [LAMBDA (X) (* lmm%: " 9-AUG-76 20:34:14") (OR (GETP X 'GLOBALVAR) (FMEMB X GLOBALVARS]) (COMP.LINKCALLP [LAMBDA (FN) (* edited (18-NOV-75 . 2341)) (COND ((AND (LISTP NOLINKFNS) (FMEMB FN NOLINKFNS)) NIL) ((AND BLKFLG (OR (FASSOC FN BLKDEFS) (FMEMB FN BLKLIBRARY))) T) ((AND (LISTP LINKFNS) (FMEMB FN LINKFNS)) T) ((EQ NOLINKFNS T) NIL) ((OR BLKFLG (EQ LINKFNS T)) T]) (COMP.ANONP [LAMBDA (E) (* lmm "12-May-86 13:23") (COND ((NEQ LOCALVARS T) (FMEMB E LOCALVARS)) (T (NOT (OR (EQ SPECVARS T) (FMEMB E SPECVARS) (VARIABLE-GLOBALLY-SPECIAL-P E) (AND BLKFLG (FMEMB E LOCALFREEVARS]) (COMP.NOSIDEEFFECTP (LAMBDA (EXP) (* ; "Edited 17-May-90 16:47 by nm") (COMP.CLEANEXPP EXP *NO-SIDE-EFFECT-FNS*))) ) (DEFINEQ (COMP.CPI [LAMBDA (FN ARGS) (* Pavel "15-Nov-86 16:22") (PROG ((F FRAME)) LP (COND ((EQ F TOPFRAME) (COMP.CPI1 ARGS ARGVARS (COMP.PICOUNT ARGS)) (while (NEQ FRAME TOPFRAME) do (* ;  "unbind localvar FRAME before recursion") (COMP.STUNBIND T)) (COND ((NEQ LEVEL 0) (* ; "pop stack before recursion") (COMP.STPOP LEVEL))) (COMP.STJUMP 'JUMP TOPLAB) (* ; "COMP.CPI succeeds") (RETURN 'NOVALUE)) ((SELECTQ (fetch FRAMETYPE of F) ((PROG LAMBDA) [COND ((OASSOC 'AVAR (fetch VARS of F)) (COND ((NOT (fetch CPIOK of F)) (* ;  "can't remove recursion inside frame with SPECVARS") T) (T (* ;  "COMP.CPI can succeed because SPECVARS bound first thing in function") NIL]) (PROGN (* ;  "can't remove recursion inside ERRORSET") T)) (COMP.CALL FN ARGS 0)) ((SETQ F (fetch PARENT of F)) (GO LP)) (T (OPT.COMPILERERROR]) (COMP.CPI1 [LAMBDA (ARGS VARS N) (* lmm "16-APR-82 00:28") (COND [(NULL VARS) (COND ((LISTP ARGS) (COMP.EFFECT (CAR ARGS)) (COMP.CPI1 (CDR ARGS) VARS (SUB1 N] ([OR (IGREATERP N 0) (NOT (LITATOM (CAR ARGS))) (NEQ (CAR ARGS) (fetch OPARG of (CAR VARS] (COMP.VAL (CAR ARGS)) (COMP.CPI1 (CDR ARGS) (CDR VARS) (SUB1 N)) (COMP.STSETQ (CAR VARS)) (COMP.STPOP)) (T (COMP.CPI1 (CDR ARGS) (CDR VARS) (SUB1 N]) (COMP.PICOUNT [LAMBDA (ARGS) (* lmm "27-OCT-81 20:57") (PROG ((N 0) (ND 0) (VARS ARGVARS)) LP (COND (VARS (SETQ N (ADD1 N)) (COND [(AND (LITATOM (CAR ARGS)) (EQ (CAR ARGS) (fetch OPARG of (CAR VARS] ((NOT (COMP.CLEANEXPP (CAR ARGS) 'COMP.PICOUNT)) (SETQ ND N))) (SETQ VARS (CDR VARS)) (SETQ ARGS (CDR ARGS)) (GO LP))) (RETURN ND]) ) (PUTPROPS EVQ BYTEMACRO COMP.EVQ) (DEFINEQ (COMP.EVQ [LAMBDA (X) (* lmm "18-Sep-84 16:06") (RESETVARS (COMPVARMACROHASH) (RETURN (COMP.PROGLST X 1]) ) (PUTPROPS AND BYTEMACRO (APPLY* COMP.BOOL T)) (PUTPROPS OR BYTEMACRO (APPLY* COMP.BOOL NIL)) (DEFINEQ (COMP.BOOL [LAMBDA (A FLAG) (* lmm "29-Apr-85 13:33") (COND ((NULL A) (* (AND/OR)) (COMP.CONST FLAG)) ((NULL (CDR A)) (* (AND/OR expr)) (COMP.EXP1 (CAR A))) (T (PROG ((END (create TAG)) P) (SETQ P (create JUMP OPNAME _ [COND ((COMP.PREDP COMPILE.CONTEXT) (* AND/OR in PREDF) (SELECTQ (fetch OPNAME of (SETQ P COMPILE.CONTEXT)) ((TJUMP NTJUMP) (COND (FLAG 'FJUMP) (T (GO LP)))) ((FJUMP NFJUMP) (COND (FLAG (GO LP)) (T 'TJUMP))) (OPT.COMPILERERROR))) [(EQ COMPILE.CONTEXT 'EFFECT) (* AND/OR in EFFECT) (COND (FLAG 'FJUMP) (T 'TJUMP] (T (* other AND/OR) (COND (FLAG 'NFJUMP) (T 'NTJUMP] TAG _ END)) LP (COND ((CDR A) (COMP.EXPR (CAR A) P) (SETQ A (CDR A)) (GO LP))) (RETURN (PROG1 [COMP.EXPR (CAR A) (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN NIL) COMPILE.CONTEXT) (COND ((COMP.PREDP COMPILE.CONTEXT) COMPILE.CONTEXT) (T NIL] (COMP.STTAG END]) ) (DEFINEQ (COMP.APPLYFNP [LAMBDA (X) (* edited%: "21-MAY-80 09:38") (AND (LISTP X) (SELECTQ (CAR X) ((FUNCTION QUOTE) (AND (NULL (CDDR X)) (SELECTQ (COMP.ARGTYPE (CADR X)) (NIL (pushnew ALAMS1 (CADR X)) T) ((0 1 2) T) NIL))) NIL]) ) (PUTPROPS AC BYTEMACRO COMP.AC) (DEFINEQ (COMP.AC [LAMBDA NIL (* lmm%: " 1-OCT-76 12:41:01") (OR (EQ (SETQ AC EXP) DONOTHING) (COMP.PUNT)) NIL]) (COMP.PUNT [LAMBDA NIL (* lmm "22-OCT-79 12:44") (PROG [(EM (CONS (CAR EXP) '(-- can't compile] (COMPERROR (COND [MACEXP (CONS 'Under (CONS (CAR MACEXP) (CONS '- EM] (T EM]) ) (PUTPROPS FUNCTION BYTEMACRO COMP.FUNCTION) (DEFINEQ (COMP.FUNCTION [LAMBDA (A) (* lmm "16-APR-82 00:18") (PROG ((FN (CAR A))) [COND ((LISTP FN) (SETQ FN (COMP.LAM1 FN] (RETURN (COND ((CDR A) (COMP.CALL 'FUNCTION (CONS FN (CDR A)) 1)) (T (COMP.STCONST FN]) (COMP.LAM1 [LAMBDA (DEF) (* Pavel "15-Nov-86 16:12") (PROG ((FN (COMP.GENFN))) (COMP.TOPLEVEL.COMPILE FN DEF NIL ALLVARS) (for X in ALLVARS when (AND (NEQ (fetch OPNAME of X) 'AVAR) (FMEMB (fetch OPARG of X) SUBFNFREEVARS)) do (* ;  "change LOCALVAR to SPECVAR because subfn uses it free") (replace OPNAME of X with 'AVAR)) (RETURN FN]) (COMP.GENFN [LAMBDA NIL (* Pavel "28-Oct-86 20:16") (COND ((IGEQ COMP.GENFN.NUM 9999) (SETQ COMP.GENFN.NUM 0))) (CL:INTERN (CL:FORMAT NIL "~AA~4,'0D" (STRING COMFN) (add COMP.GENFN.NUM 1)) (CL:SYMBOL-PACKAGE COMFN]) ) (RPAQ? COMP.GENFN.NUM 0) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMP.GENFN.NUM COMP.UNBOXED.TAG) ) (PUTPROPS COND BYTEMACRO COMP.COND) (PUTPROPS SELECTQ BYTEMACRO COMP.SELECTQ) (DEFINEQ (COMP.COND [LAMBDA (A) (* lmm "12-Mar-85 07:04") (PROG (TEST CLAUSE (END (create TAG)) ENDF NEXT [CONTEXT (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN NIL) COMPILE.CONTEXT) (COND ((COMP.PREDP COMPILE.CONTEXT) NIL) ((EVERY A (FUNCTION CDR)) COMPILE.CONTEXT) (T NIL] COMPVAL) LP [SETQ TEST (CAR (SETQ CLAUSE (CAR A] (COND [(CDR CLAUSE) (* is there anything after the test?) (* * compile the test in a context where, if false, it will jump to NEXT) (LET [(MORE (LET ((HERE CODE)) [COMP.EXPR TEST (create JUMP OPNAME _ 'FJUMP TAG _ (SETQ NEXT (create TAG] (OR OPTIMIZATIONSOFF (for (X _ CODE) by (CDR X) while (AND X (NEQ X HERE)) do (AND (EQ [CAR (LISTP (fetch OPARG of (CAR X] NEXT) (RETURN T] [COND ((NOT (OPT.JUMPCHECK CODE)) (* it doesn't ALWAYS jump to next) (SETQ COMPVAL (COMP.VALN (CDR CLAUSE) CONTEXT)) (OR (OPT.JUMPCHECK CODE) (COMP.STJUMP 'JUMP (SETQ ENDF END] (COND (MORE (COMP.STTAG NEXT)) (T (GO OUT] [(CDR A) (* this is a form (COND (TEST) --) where there is more to come) (COMP.EXPR TEST (create JUMP OPNAME _ (COND ((EQ CONTEXT 'EFFECT) 'TJUMP) (T 'NTJUMP)) TAG _ (SETQ ENDF END] (T (* (COND -- (A)) is equivalent to  (COND -- (T A))) (SETQ COMPVAL (COMP.EXPR TEST CONTEXT)) (GO OUT))) (COND ((SETQ A (CDR A)) (GO LP))) (AND (NEQ CONTEXT 'EFFECT) (COMP.EXPR NIL)) OUT (AND ENDF (COMP.STTAG END)) (RETURN (COND ((EQ CONTEXT 'EFFECT) 'NOVALUE) (T COMPVAL]) (COMP.IF [LAMBDA (A) (* lmm "24-May-86 16:32") (* used by common lisp IF) (DESTRUCTURING-BIND (TEST THEN ELSE) A (PROG (CONDTEST (END (create TAG)) ENDF NEXT (CONTEXT (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN NIL) COMPILE.CONTEXT) NIL)) COMPVAL) [COMP.EXPR TEST (create JUMP OPNAME _ 'FJUMP TAG _ (SETQ NEXT (create TAG] [COND ((NOT (OPT.JUMPCHECK CODE)) (SETQ COMPVAL (COMP.EXPR THEN CONTEXT)) (OR (OPT.JUMPCHECK CODE) (COMP.STJUMP 'JUMP (SETQ ENDF END] (COMP.STTAG NEXT) [COND ((NOT (OPT.JUMPCHECK CODE)) (* it doesn't ALWAYS jump to next) (SETQ COMPVAL (COMP.EXPR ELSE CONTEXT] (AND ENDF (COMP.STTAG END)) (RETURN (COND ((EQ CONTEXT 'EFFECT) 'NOVALUE) (T COMPVAL]) (COMP.SELECTQ [LAMBDA (A) (* lmm "13-Jul-84 21:18") (PROG ((END (create TAG)) VAR THISLABEL NEXT TEST CLAUSE) (* compile SELECTQ) (COMP.VAL (CAR A)) (SETQ A (CDR A)) (COND ((FMEMB (fetch OPNAME of (CAR CODE)) SELECTVARTYPES) (* SELECTQVARTYPES is  (AVAR HVAR) for Alto and NIL for maxc) (* SELECTQ var) (SETQ VAR (CAR CODE)) (COMP.DELPUSH)) ((AND (EQ (fetch OPNAME of (CAR CODE)) 'SETQ) (FMEMB (fetch OPNAME of (fetch OPARG of (CAR CODE))) SELECTVARTYPES)) (* SELECTQ SETQ) (SETQ VAR (fetch OPARG of (CAR CODE))) (COMP.STPOP)) [(EQ (fetch OPNAME of (CAR CODE)) 'CONST) (* SELECTQ of constant) (RETURN (COMP.PROGN (PROG [(C (fetch OPARG of (CAR CODE] (COMP.DELPUSH) ALP (COND ((NULL (CDR A)) (RETURN A))) [COND ((COND ((LISTP (CAAR A)) (FMEMB C (CAAR A))) (T (EQ (CAAR A) C))) (RETURN (CDAR A] (SETQ A (CDR A)) (GO ALP] (T (SETQ THISLABEL T))) LP [COND ((NULL (CDR A)) (AND THISLABEL (NULL VAR) (COMP.STPOP)) (RETURN (PROG1 (COMP.EXPR (CAR A) (COND ((COMP.PREDP COMPILE.CONTEXT) NIL) (T COMPILE.CONTEXT))) (OR (EQ COMPILE.CONTEXT 'RETURN) (COMP.STTAG END] (SETQ THISLABEL) [COND ([LISTP (SETQ TEST (CAR (SETQ CLAUSE (PROG1 (CAR A) (SETQ A (CDR A] (COND ((NLISTP (CDR TEST)) (SETQ TEST (CAR TEST))) (SELECTQFMEMB (* FMEMB in SELECTQ) (COND (VAR (COMP.STVAR VAR)) ((CDR A) (COMP.STCOPY))) (COMP.STCONST (APPEND TEST)) (COMP.STFN 'FMEMB 2) (GO DUN)) (T (SETQ THISLABEL (create TAG)) (MAP TEST (FUNCTION (LAMBDA (Y) (COND ((CDR Y) (COND (VAR (COMP.STVAR VAR)) (T (COMP.STCOPY))) (COMP.STCONST (CAR Y)) (COMP.STFN 'EQ 2) (COMP.STJUMP 'TJUMP THISLABEL)) (T (SETQ TEST (CAR Y] (COND (VAR (COMP.STVAR VAR)) ((OR THISLABEL (CDR A)) (COMP.STCOPY))) (COMP.STCONST TEST) (COMP.STFN 'EQ 2) DUN [COND ((AND (NULL THISLABEL) (NULL (CDR A)) (NULL (CAR A))) (* SELECTQ ends in NIL) (COMP.STJUMP (COND ((EQ COMPILE.CONTEXT 'EFFECT) 'FJUMP) (T 'NFJUMP)) END) (RETURN (PROG1 (COMP.VALN (CDR CLAUSE) (COND ((EQ COMPILE.CONTEXT 'EFFECT) COMPILE.CONTEXT))) (COMP.STTAG END] (COMP.STJUMP 'FJUMP (SETQ NEXT (create TAG))) (COND (THISLABEL (COMP.STTAG THISLABEL))) (COND ((AND (OR THISLABEL (CDR A)) (NULL VAR)) (COMP.STPOP))) (COMP.VALN (CDR CLAUSE) (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN) COMPILE.CONTEXT) NIL)) (OR (EQ COMPILE.CONTEXT 'RETURN) (COMP.STJUMP 'JUMP END)) (COMP.STTAG NEXT) (GO LP]) ) (PUTPROPS PROGN BYTEMACRO COMP.PROGN) (PUTPROPS PROG1 BYTEMACRO COMP.PROG1) (PUTPROPS QUOTE BYTEMACRO COMP.QUOTE) (PUTPROPS * BYTEMACRO COMP.COMMENT) (DEFINEQ (COMP.QUOTE [LAMBDA (A) (* lmm%: " 9-AUG-76 22:04:49") [COND ((CDR A) (COMPERRM (CONS EXP '(- probable parenthesis error] (COMP.CONST (CAR A]) (COMP.COMMENT [LAMBDA (A) (* lmm "29-Jun-84 08:25") (COND ((NOT (EQ COMPILE.CONTEXT 'EFFECT)) [COMPERRM (CONS EXP '(- value of comment used?] (COMP.STCONST (CAR A))) (T 'NOVALUE]) ) (PUTPROPS DECLARE BYTEMACRO COMP.DECLARE) (DEFINEQ (COMP.DECLARE [LAMBDA (A) (* lmm "24-May-86 20:36") (* compile DECLARE) [MAPC A (FUNCTION (LAMBDA (B) (SELECTQ (CAR B) (LOCALVARS (COMP.DECLARE1 (CDR B) 'LOCALVARS 'SPECVARS SYSSPECVARS)) (SPECVARS (COMP.DECLARE1 (CDR B) 'SPECVARS 'LOCALVARS SYSLOCALVARS)) (CL:SPECIAL [MAPC (fetch VARS of FRAME) (FUNCTION (LAMBDA (V VTAG) (COND ((AND (EQ (fetch OPNAME of V) 'HVAR) (FMEMB (fetch OPARG of V) (CDR B))) (replace OPNAME of V with 'AVAR]) (IGNORE) (USEDFREE NIL) ((ADDTOVAR DEFLIST PUTPROPS CONSTANTS SETQQ USEDFREE GLOBALVARS) (EVAL B)) (UNBOXED (push ALLDECLS COMP.UNBOXED.TAG)) (TYPE (* handled elsewhere)) (COMPERRM (CONS B '(- used in DECLARE] (COMP.CONST (CAR A]) (COMP.DECLARE1 [LAMBDA (VAL VAR OTHERVAR SYSOTHERVAR) (* lmm "31-MAR-78 02:47") (SET VAR (COND ((LISTP VAL) (COND ((LISTP (SETQ VAR (EVALV VAR))) (APPEND VAL VAR)) ((EQ VAR T)) (T VAL))) ((EQ VAL T) (SET OTHERVAR SYSOTHERVAR) T) (T VAL))) (MAPC (fetch VARS of FRAME) (FUNCTION (LAMBDA (V VTAG) (COND ((NEQ (SETQ VTAG (COMP.VARTYPE (fetch OPARG of V))) (fetch OPNAME of V)) (* Already made some decision based on  localvars (COMPERRM (CONS EXP  (QUOTE (-  illegal DECLARE))))) (replace OPNAME of V with VTAG]) ) (RPAQQ MCROPS (CAR CDR CAAR CDAR CADR CDDR CAAAR CDAAR CADAR CDDAR CAADR CDADR CADDR CDDDR CAAAAR CDAAAR CADAAR CDDAAR CAADAR CDADAR CADDAR CDDDAR CAAADR CDAADR CADADR CDDADR CAADDR CDADDR CADDDR CDDDDR)) (PUTPROPS CAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDR BYTEMACRO COMP.CARCDR) (PUTPROPS CAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDAR BYTEMACRO COMP.CARCDR) (PUTPROPS CADR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDR BYTEMACRO COMP.CARCDR) (PUTPROPS CAAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CADAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDAR BYTEMACRO COMP.CARCDR) (PUTPROPS CAADR BYTEMACRO COMP.CARCDR) (PUTPROPS CDADR BYTEMACRO COMP.CARCDR) (PUTPROPS CADDR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDDR BYTEMACRO COMP.CARCDR) (PUTPROPS CAAAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDAAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CADAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDAAR BYTEMACRO COMP.CARCDR) (PUTPROPS CAADAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDADAR BYTEMACRO COMP.CARCDR) (PUTPROPS CADDAR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDDAR BYTEMACRO COMP.CARCDR) (PUTPROPS CAAADR BYTEMACRO COMP.CARCDR) (PUTPROPS CDAADR BYTEMACRO COMP.CARCDR) (PUTPROPS CADADR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDADR BYTEMACRO COMP.CARCDR) (PUTPROPS CAADDR BYTEMACRO COMP.CARCDR) (PUTPROPS CDADDR BYTEMACRO COMP.CARCDR) (PUTPROPS CADDDR BYTEMACRO COMP.CARCDR) (PUTPROPS CDDDDR BYTEMACRO COMP.CARCDR) (PUTPROPS CAR CROPS (A)) (PUTPROPS CDR CROPS (D)) (PUTPROPS CAAR CROPS (A A)) (PUTPROPS CDAR CROPS (A D)) (PUTPROPS CADR CROPS (D A)) (PUTPROPS CDDR CROPS (D D)) (PUTPROPS CAAAR CROPS (A A A)) (PUTPROPS CDAAR CROPS (A A D)) (PUTPROPS CADAR CROPS (A D A)) (PUTPROPS CDDAR CROPS (A D D)) (PUTPROPS CAADR CROPS (D A A)) (PUTPROPS CDADR CROPS (D A D)) (PUTPROPS CADDR CROPS (D D A)) (PUTPROPS CDDDR CROPS (D D D)) (PUTPROPS CAAAAR CROPS (A A A A)) (PUTPROPS CDAAAR CROPS (A A A D)) (PUTPROPS CADAAR CROPS (A A D A)) (PUTPROPS CDDAAR CROPS (A A D D)) (PUTPROPS CAADAR CROPS (A D A A)) (PUTPROPS CDADAR CROPS (A D A D)) (PUTPROPS CADDAR CROPS (A D D A)) (PUTPROPS CDDDAR CROPS (A D D D)) (PUTPROPS CAAADR CROPS (D A A A)) (PUTPROPS CDAADR CROPS (D A A D)) (PUTPROPS CADADR CROPS (D A D A)) (PUTPROPS CDDADR CROPS (D A D D)) (PUTPROPS CAADDR CROPS (D D A A)) (PUTPROPS CDADDR CROPS (D D A D)) (PUTPROPS CADDDR CROPS (D D D A)) (PUTPROPS CDDDDR CROPS (D D D D)) (DEFINEQ (COMP.CARCDR [LAMBDA (A) (* lmm "18-Sep-84 16:13") (* Used for compiling CAR/CDR etc) (COND ((EQ COMPILE.CONTEXT 'EFFECT) (* CAR/CDR in EFF) (COMP.PROGLST A 1 COMPILE.CONTEXT)) (T (COMP.PROGLST A 1) (MAPC (GETPROP (CAR EXP) 'CROPS) (FUNCTION (LAMBDA (X) (COMP.STFN (SELECTQ X (A 'CAR) 'CDR) 1]) (COMP.STCROP [LAMBDA (X) (* lmm "16-APR-82 00:16") (COMP.STFN (SELECTQ X (A 'CAR) 'CDR) 1]) ) (PUTPROPS NOT BYTEMACRO COMP.NOT) (PUTPROPS NULL BYTEMACRO COMP.NOT) (DEFINEQ (COMP.NOT [LAMBDA (A TMP) (* lmm "18-Sep-84 16:30") (COND ((AND (COMP.PREDP COMPILE.CONTEXT) (SETQ TMP (OPT.NOTJUMP COMPILE.CONTEXT))) (COMP.PROGLST A 1 TMP)) (T (COMP.PROGLST A 1) (COMP.STFN 'NULL 1]) ) (PUTPROPS SETQ BYTEMACRO COMP.SETQ) (PUTPROPS SETN BYTEMACRO COMP.SETN) (DEFINEQ (COMP.SETQ [LAMBDA (A) (* lmm "29-Oct-84 15:23") (PROG (VAR DECL) (SETQ VAR (COMP.LOOKUPVAR (CAR A))) [SETQ DECL (LISTP (CDR (ASSOC VAR ALLDECLS] (COMP.PROGLST (CDR A) 1 DECL) (COMP.STSETQ VAR) (IF (AND (NEQ COMPILE.CONTEXT 'EFFECT) (EQ (CAR DECL) 'UNBOXED)) THEN (COMP.BOX (CDR DECL]) (COMP.SETN [LAMBDA (A) (* lmm%: "20-OCT-76 01:33:55") [COMPERRM (CONS (CAR A) '(- warning%: SETN compiled as SETQ] (COMP.SETQ A]) ) (DEFINEQ (COMP.LAMBDA [LAMBDA (FN VALS) (* Pavel "15-Nov-86 16:23") (PROG ((VARS (CADR FN)) F (EXPS (CDDR FN)) V E (I 0) SUBOLD SUBNEW VAR) [if (EQ (CAR FN) 'OPENLAMBDA) then (* ; "compile OPENLAMBDA expression") [while VARS do (COMP.VAL (pop VALS)) (COND ((EQ (fetch OPNAME of (CAR CODE)) 'CONST) (push SUBOLD (pop VARS)) [push SUBNEW (KWOTE (fetch OPARG of (CAR CODE] (COMP.DELPUSH)) (T (push V (pop VARS] (for X in VALS do (COMP.EFFECT X)) (while (AND V (SETQ VAR (SELECTQ (fetch OPNAME of (CAR CODE)) ((AVAR HVAR FVAR GVAR) (PROG1 (fetch OPARG of (CAR CODE)) (COMP.DELPUSH))) (SETQ (PROG1 (fetch OPARG of (fetch OPARG of (CAR CODE))) (COMP.STPOP))) NIL))) do (* ;  "substitute for variable in OPENLAMBDA") (push SUBNEW VAR) (push SUBOLD (pop V))) [if (NULL V) then (* ;  "OPENLAMBDA with all variables substituted for") (RETURN (COMP.PROGN (SUBPAIR SUBOLD SUBNEW EXPS] (while V do [push SUBNEW (CAR (push VARS (COMP.GENFN] (push SUBOLD (pop V)) (push VALS DONOTHING)) (SETQ EXPS (CONS '(DECLARE (LOCALVARS . T)) (SUBPAIR SUBOLD SUBNEW EXPS))) else (SELECTQ (ARGTYPE FN) (0) (1 (* ; "open NLAMBDA nospread") (SETQ VALS (MAPCAR VALS (FUNCTION KWOTE)))) (2 (* ; "open LAMBDA nospread") (RETURN (COMP.CALL (COMP.LAM1 FN) VALS 2))) (3 (* ; "open NLAMBDA spread") (SETQ VARS (LIST VARS)) (SETQ VALS (LIST (KWOTE VALS)))) (COMPERROR (CONS FN '(- illegal open function] (SETQ F (COMP.BIND.VARS VARS VALS 'LAMBDA (COMP.LOOKFORDECLARE EXPS))) (PROG ((ALLVARS (APPEND (fetch VARS of F) ALLVARS)) (ALLDECLS (APPEND (fetch DECLS of F) ALLDECLS)) (LOCALVARS LOCALVARS) (SPECVARS SPECVARS)) (COMP.STBIND F) (COMP.VALN EXPS (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN) COMPILE.CONTEXT) NIL))) (RETURN (COMP.UNBIND.VARS F]) ) (PUTPROPS CL:TAGBODY DMACRO COMP.TAGBODY) (PUTPROPS PROG BYTEMACRO COMP.PROG) (PUTPROPS GO BYTEMACRO COMP.GO) (PUTPROPS RETURN BYTEMACRO COMP.RETURN) (PUTPROPS CL:RETURN-FROM BYTEMACRO COMP.RETURN-FROM) (DEFINEQ (COMP.PROG [LAMBDA (A) (* lmm "13-Jul-84 21:18") (PROG ([VARS (for X in (CAR A) collect (COND ((LITATOM X) X) [(NLISTP X) (COMPERROR (CONS X '(- bad PROG variable] (T (CAR X] [VALS (for X in (CAR A) collect (AND (LISTP X) (COND ((CDDR X) (CONS 'PROG1 (CDR X))) (T (CADR X] F) [SETQ F (COMP.BIND.VARS VARS VALS 'PROG (COMP.LOOKFORDECLARE (SETQ A (CDR A] (PROG ((ALLVARS (APPEND (fetch VARS of F) ALLVARS)) (ALLDECLS (APPEND (fetch DECLS of F) ALLDECLS)) (LOCALVARS LOCALVARS) (SPECVARS SPECVARS) TAGS (RETURNLABEL (create TAG LEVEL _ (COND ((EQ COMPILE.CONTEXT 'EFFECT) 0) (T 1)) FRAME _ F)) PROGLEVEL (PROGCONTEXT (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN) COMPILE.CONTEXT) NIL)) FLG) (COMP.STBIND F) [for X in A do (COND ((LISTP X)) [(NOT (LITATOM X)) (COMPERROR (CONS X '(- illegal tag] [(FASSOC X TAGS) (COMPERROR (CONS X '(- multiply defined tag] (T (SETQ TAGS (CONS (CONS X (SETQ X (create TAG LBNO _ X))) TAGS)) (replace (TAG FRAME) of X with FRAME) (replace (TAG LEVEL) of X with 0] (replace PROGLABELS of F with TAGS) [SETQ FLG (AND (NOT OPTIMIZATIONSOFF) (NULL TAGS) (EQ PROGCONTEXT 'RETURN] (* Check if can delete extra POP's) [for X in A do (COND [(LITATOM X) (COMP.STTAG (CDR (FASSOC X TAGS] (T (COMP.EFFECT X) (AND FLG (while (EQ (CAR CODE) OPPOP) do (* delete POP in PROG) (COMP.DELPOP] (COND ((NOT (OR (EQ COMPILE.CONTEXT 'EFFECT) (OPT.JUMPCHECK CODE))) (* PROG dropped off) (COMP.EXPR NIL))) (OR (EQ COMPILE.CONTEXT 'RETURN) (COMP.STTAG RETURNLABEL))) (RETURN (COMP.UNBIND.VARS F]) (COMP.GO [LAMBDA (A) (* lmm " 2-Jun-86 23:03") (PROG (D ANYPROG) [COND ((OPT.JUMPCHECK CODE) (* UNREACHABLE GO --  DON'T COMPILE) (RETURN 'NOVALUE] LP [SELECTQ (fetch FRAMETYPE of FRAME) ([LAMBDA PROG] [COND ((SETQ D (FASSOC (CAR A) (fetch PROGLABELS of FRAME))) (COND ((NOT (ZEROP LEVEL)) (* GO needs to POP) (COMP.STPOP LEVEL))) (COMP.STJUMP 'JUMP (CDR D)) (RETURN 'NOVALUE]) (COMPERROR (CONS (CAR A) '(- illegal GO] (* non local GO) (COMP.STUNBIND T) (GO LP]) (COMP.RETURN [LAMBDA (A) (* lmm "18-Sep-84 16:31") (PROG ((PROGFRAME FRAME)) [COND ((NEQ PROGCONTEXT 'RETURN) (COND ([NOT (OR (EQ PROGCONTEXT 'EFFECT) (EQ LEVEL 0) (NEQ (fetch FRAMETYPE of FRAME) 'PROG] (* RETURN POPs beforehand) (COMP.STPOP LEVEL] CHKLP [SELECTQ (fetch FRAMETYPE of PROGFRAME) (PROG) (LAMBDA (SETQ PROGFRAME (fetch PARENT of PROGFRAME)) (GO CHKLP)) (COMPERROR (CONS COMFN '(- illegal RETURN] (COMP.PROGLST A 1 PROGCONTEXT) [COND ((OPT.JUMPCHECK CODE) (RETURN 'NOVALUE] (COND ((NEQ PROGCONTEXT 'RETURN) [PROG NIL LP (SELECTQ (fetch FRAMETYPE of FRAME) (PROG (OPT.CCHECK (EQ FRAME PROGFRAME))) (LAMBDA (* RETURN inside LAMBDA) (COMP.STUNBIND (EQ PROGCONTEXT 'EFFECT)) (GO LP)) (COMPERROR (CONS COMFN '(- illegal RETURN] [COND ((EQ PROGCONTEXT 'EFFECT) (COMP.STPOP LEVEL)) ((NEQ LEVEL 1) (OPT.COMPILERERROR '(unimplemented RETURN] (COMP.STJUMP 'JUMP RETURNLABEL))) (RETURN 'NOVALUE]) (COMP.BLOCK [LAMBDA (A) (* lmm " 2-Jun-86 23:05") (if (NULL (CAR A)) then (COMP.PROG (CONS NIL A)) else (PROG (F) (SETQ F (COMP.BIND.VARS NIL NIL 'LAMBDA)) (PROG ((BLOCKEND (create TAG LEVEL _ (COND ((EQ COMPILE.CONTEXT 'EFFECT) 0) (T 1)) FRAME _ F)) (CTX (SELECTQ COMPILE.CONTEXT ((EFFECT RETURN) COMPILE.CONTEXT) NIL)) FLG) (COMP.STBIND F) [replace PROGLABELS of F with (LIST (CONS 'COMPILER-BLOCK-DATA (create BLOCKSTATUS BLOCKCONTEXT _ CTX BLOCKTAG _ (CAR A) BLOCKEND _ BLOCKEND] [COMP.RETURN-FROM (LIST (CAR A) (CONS 'PROGN (CDR A] (OR (EQ COMPILE.CONTEXT 'RETURN) (COMP.STTAG BLOCKEND))) (RETURN (COMP.UNBIND.VARS F]) (COMP.RETURN-FROM [LAMBDA (A) (* lmm " 2-Jun-86 23:10") (if (NULL (CAR A)) then (COMP.RETURN (CDR A)) else (PROG ((BLOCKFRAME FRAME) DATA CTX) CHKLP [SELECTQ (fetch FRAMETYPE of BLOCKFRAME) (LAMBDA (if (OR [NOT (SETQ DATA (CDR (FASSOC 'COMPILER-BLOCK-DATA (fetch PROGLABELS of BLOCKFRAME] (NEQ (CAR A) (fetch BLOCKTAG of DATA))) then (SETQ BLOCKFRAME (fetch PARENT of BLOCKFRAME)) (GO CHKLP))) (PROG (SETQ BLOCKFRAME (fetch PARENT of BLOCKFRAME)) (GO CHKLP)) (COMPERROR (CONS COMFN '(- illegal RETURN] (SETQ CTX (fetch BLOCKCONTEXT of DATA)) [COND ((NEQ CTX 'RETURN) (COND ([NOT (OR (EQ CTX 'EFFECT) (EQ LEVEL 0) (NEQ (fetch FRAMETYPE of FRAME) 'PROG] (* RETURN POPs beforehand) (COMP.STPOP LEVEL] (COMP.PROGLST (CDR A) 1 CTX) [COND ((OPT.JUMPCHECK CODE) (RETURN 'NOVALUE] [COND ((NEQ CTX 'RETURN) [until (EQ FRAME BLOCKFRAME) do (COMP.STUNBIND (EQ CTX 'EFFECT] [COND ((EQ CTX 'EFFECT) (COMP.STPOP LEVEL)) ((NEQ LEVEL 1) (OPT.COMPILERERROR '(unimplemented RETURN] (COMP.STJUMP 'JUMP (fetch BLOCKEND of DATA] (RETURN 'NOVALUE]) (COMP.TAGBODY [LAMBDA (A) (* lmm " 2-Jun-86 23:05") (PROG ((VARS NIL) (VALS NIL) F) (SETQ F (COMP.BIND.VARS NIL NIL 'LAMBDA)) [PROG (TAGS) (COMP.STBIND F) [for X in A do (COND ((LISTP X)) [(NOT (LITATOM X)) (COMPERROR (CONS X '(- illegal tag] [(FASSOC X TAGS) (COMPERROR (CONS X '(- multiply defined tag] (T (SETQ TAGS (CONS (CONS X (SETQ X (create TAG LBNO _ X))) TAGS)) (replace (TAG FRAME) of X with FRAME) (replace (TAG LEVEL) of X with 0] (replace PROGLABELS of F with TAGS) (* Check if can delete extra POP's) [for X in A do (COND [(LITATOM X) (COMP.STTAG (CDR (FASSOC X TAGS] (T (COMP.EFFECT X] (COND ((NOT (OR (EQ COMPILE.CONTEXT 'EFFECT) (OPT.JUMPCHECK CODE))) (* PROG dropped off) (COMP.EXPR NIL] (RETURN (COMP.UNBIND.VARS F]) ) (PUTPROPS CL:LABELS BYTEMACRO COMP.LABELS) (DEFINEQ (COMP.LABELS [LAMBDA (DEF) (* ; "Edited 2-Dec-87 12:32 by amd") (* ;;; "the byte compiler does a better job with LABELS because compiling UNDO needed it (!)") (LET [(FUNCTIONS (MAPCAR (CAR DEF) (FUNCTION (LAMBDA (X) (CONS (COMP.GENFN) X] (* ;  "list of functions to be substituted") (CL:FLET [(TRANSFORM (FORM CONTEXT) (CL:IF (NLISTP FORM) FORM (COND ((FMEMB (CAR FORM) '(FUNCTION CL:FUNCTION)) (for Z in FUNCTIONS when (EQ (CADR FORM) (CADR Z)) do [RETURN `',(CAR Z] finally (RETURN FORM))) (T (for Z in FUNCTIONS when (EQ (CAR FORM) (CADR Z)) do [RETURN `(,(CAR Z) ,@(CDR FORM] finally (RETURN FORM] (FOR Z IN FUNCTIONS DO (COMP.TOPLEVEL.COMPILE (CAR Z) [DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY) (CDR Z) (CL:MULTIPLE-VALUE-BIND (BODY DECLS) (PARSE-BODY FN-BODY NIL T) `(LAMBDA ,FN-ARGLIST ,(WALK-FORM `(CL:LOCALLY ,@DECLS (CL:BLOCK ,FN-NAME ,@BODY)) :WALK-FUNCTION (FUNCTION TRANSFORM] NIL ALLVARS)) (for X in ALLVARS when (AND (NEQ (fetch OPNAME of X) 'AVAR) (FMEMB (fetch OPARG of X) SUBFNFREEVARS)) do (* ;  "change LOCALVAR to SPECVAR because subfn uses it free") (replace OPNAME of X with 'AVAR)) (COMP.EXPR (WALK-FORM `(PROGN ,@(CDR DEF)) :WALK-FUNCTION (FUNCTION TRANSFORM)) COMPILE.CONTEXT]) ) (RPAQQ COMP.UNBOXED.TAG ("I'm on ALLDECLS if FPLUS compiles with unboxed arithmetic")) (RPAQQ NUMBERFNS (ITIMES2 LOGOR2 LOGXOR2 LOGAND2 LLSH1 LRSH1 LLSH8 LRSH8 IPLUS ITIMES LOGOR LOGXOR LOGAND IDIFFERENCE IQUOTIENT IREMAINDER IMINUS LSH LLSH RSH LRSH FIX)) (RPAQQ GLOBALVARFLG T) (RPAQQ NEWOPTFLG NIL) (RPAQ COMPVERSION (DATE)) (DEFOPTIMIZER IMINUS (X) `(IDIFFERENCE 0 ,X)) (DECLARE%: EVAL@COMPILE (PUTPROPS IPLUS BYTEMACRO (APPLY* COMP.NUMERIC IPLUS)) (PUTPROPS ITIMES BYTEMACRO (APPLY* COMP.NUMERIC ITIMES FIX 0)) (PUTPROPS LOGOR BYTEMACRO (APPLY* COMP.NUMERIC LOGOR FIX -1)) (PUTPROPS LOGXOR BYTEMACRO (APPLY* COMP.NUMERIC LOGXOR)) (PUTPROPS LOGAND BYTEMACRO (APPLY* COMP.NUMERIC LOGAND FIX 0)) (PUTPROPS IDIFFERENCE BYTEMACRO COMP.NUMBERCALL) (PUTPROPS IQUOTIENT BYTEMACRO COMP.NUMBERCALL) (PUTPROPS IREMAINDER BYTEMACRO COMP.NUMBERCALL) (PUTPROPS LSH BYTEMACRO COMP.NUMBERCALL) (PUTPROPS LLSH DMACRO COMP.SHIFT) (PUTPROPS RSH BYTEMACRO COMP.NUMBERCALL) (PUTPROPS LRSH DMACRO COMP.SHIFT) (PUTPROPS FIX BYTEMACRO COMP.FIX) (PUTPROPS PLUS DMACRO [APPLY* COMP.NUMERIC PLUS PLUS NIL ((FLOAT FPLUS (OPCODES UBFLOAT2 0]) (PUTPROPS DIFFERENCE DMACRO [APPLY* COMP.NUMBERCALL PLUS ((FLOAT FDIFFERENCE (OPCODES UBFLOAT2 1]) (PUTPROPS TIMES DMACRO [APPLY* COMP.NUMERIC TIMES PLUS 0 ((FLOAT FTIMES (OPCODES UBFLOAT2 3]) (PUTPROPS QUOTIENT DMACRO (APPLY* COMP.NUMBERCALL PLUS)) (PUTPROPS FPLUS DMACRO [APPLY* COMP.NUMERIC FPLUS FLOAT NIL ((FLOAT FPLUS (OPCODES UBFLOAT2 0 ]) (PUTPROPS FDIFFERENCE DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FDIFFERENCE (OPCODES UBFLOAT2 1]) (PUTPROPS FTIMES DMACRO [APPLY* COMP.NUMERIC FTIMES FLOAT 0 ((FLOAT FTIMES (OPCODES UBFLOAT2 3]) (PUTPROPS FQUOTIENT DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FQUOTIENT (OPCODES UBFLOAT2 4]) (PUTPROPS FABS DMACRO [(X) (\FLOATBOX ((OPCODES UBFLOAT1 2) (\FLOATUNBOX X]) (PUTPROPS FGREATERP DMACRO (APPLY* COMP.COMPARENUM FLOAT FGREATERP NIL (OPCODES UBFLOAT2 5))) [PROGN (PUTPROPS FLESSP MACRO [LAMBDA (X Y) (FGREATERP Y X]) (PUTPROPS FLESSP DMACRO (APPLY* COMP.COMPARENUM FLOAT FLESSP FGREATERP (OPCODES SWAP UBFLOAT2 5)))] (PUTPROPS FREMAINDER DMACRO [APPLY* COMP.NUMBERCALL FLOAT ((FLOAT FREMAINDER (OPCODES UBFLOAT2 8]) ) (DEFINEQ (COMP.NUMERIC [LAMBDA (A 2FN TYPE ZERO COERSIONS) (* ; "Edited 12-Apr-88 17:03 by amd") (* ;; "compile call to number function of arbitrary args. 2FN is holder of opcode. TYPE is FIX, FLOAT, PLUS (NIL->FIX)") (* ;; "ZERO IF GIVEN IS ZERO OF FUNCTION, E.G. 0 FOR TIMES, -1 FOR LOGOR") (* ;; "coercions say what to do if compile context is other numeric type") (PROG ((N 0) V (FN (CAR EXP)) TMP) [COND ((AND (EQ COMPILE.CONTEXT 'EFFECT) (NOT OPTIMIZATIONSOFF)) (RETURN (COMP.PROGN A] (OR 2FN (SETQ 2FN FN)) (SELECTQ (CAR (LISTP COMPILE.CONTEXT)) (TYPE [COND ((AND (NEQ (CDR COMPILE.CONTEXT) TYPE) (SETQ TMP (FASSOC (CDR COMPILE.CONTEXT) COERSIONS))) (SETQ TYPE (CAR TMP)) (SETQ 2FN (CADR TMP]) (UNBOXED (if (SETQ TMP (CADDR (FASSOC (CDR COMPILE.CONTEXT) COERSIONS))) then (while A do (COMP.EXPR (pop A) COMPILE.CONTEXT) (SETQ N (ADD1 N))) (FRPTQ (SUB1 N) (COMP.STFN TMP 2)) (RETURN 'UNBOXED))) NIL) (if (AND (SETQ TMP (CADDR (FASSOC TYPE COERSIONS))) (FMEMB COMP.UNBOXED.TAG ALLDECLS)) then (while A do (COMP.EXPR (pop A) (CONS 'UNBOXED TYPE)) (SETQ N (ADD1 N))) (FRPTQ (SUB1 N) (COMP.STFN TMP 2)) (RETURN (COMP.FLOATBOX))) [while A do [COMP.EXPR (pop A) (CONS 'TYPE (OR TYPE (SETQ TYPE 'FIX] (SETQ N (ADD1 N)) (COND ((NOT OPTIMIZATIONSOFF) (COMP.DELFIX TYPE) (while (OPT.CALLP (CAR CODE) 2FN) do (SETQ N (IPLUS N (CAR (fetch OPARG of (CAR CODE))) -1)) (* ;; "merge nested arithmetic calls") (COMP.DELFN)) (COND ((AND (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (NUMBERP (fetch OPARG of (CAR CODE))) (IGREATERP N 0)) [SETQ V (COND [V (* ;; "combine number args") (APPLY* FN V (fetch OPARG of (CAR CODE] (T (* ;; "move number constants to end") (APPLY* (OR TYPE (FUNCTION FIX)) (fetch OPARG of (CAR CODE] (COMP.DELPUSH) (SETQ N (SUB1 N] [COND (V (COND ((EQL (APPLY* FN V) (APPLY* FN)) (* ;; "I.E., IS UNIT OF FUNCTION: 1 FOR TIMES, ETC") ) ((EQL V ZERO) (FRPTQ N (COMP.STPOP)) (RETURN (COMP.STCONST V))) ((AND (IGREATERP N 0) (MINUSP V) (EQ 2FN 'IPLUS)) (* ;; "turn IPLUS of negative to IDIFFERENCE") (COMP.STCONST (IMINUS V)) (COMP.STFN 'IDIFFERENCE 2)) (T (COMP.STCONST V) (add N 1] (COND ((EQ N 0) (* ;; "number function, 0 args") (COMP.STCONST (APPLY* FN))) ((EQ N 1) (* ;; "number fn, 1 arg") (COMP.STFIX TYPE)) (T (FRPTQ (SUB1 N) (COMP.STFN 2FN 2]) (COMP.NUMBERCALL [LAMBDA (A TYPE COERSIONS) (* lmm " 9-Mar-85 14:55") (PROG ((N 0) TMP (2FN (CAR EXP))) [COND ((AND (EQ COMPILE.CONTEXT 'EFFECT) (NOT OPTIMIZATIONSOFF)) (RETURN (COMP.PROGN A] (SELECTQ (CAR (LISTP COMPILE.CONTEXT)) (TYPE [COND ((AND (NEQ (CDR COMPILE.CONTEXT) TYPE) (SETQ TMP (FASSOC (CDR COMPILE.CONTEXT) COERSIONS))) (SETQ TYPE (CAR TMP)) (SETQ 2FN (CADR TMP]) (UNBOXED (if (SETQ TMP (CADDR (FASSOC (CDR COMPILE.CONTEXT) COERSIONS))) then (while A do (COMP.EXPR (pop A) COMPILE.CONTEXT) (SETQ N (ADD1 N))) (FRPTQ (SUB1 N) (COMP.STFN TMP 2)) (RETURN 'UNBOXED))) NIL) (if (AND (SETQ TMP (CADDR (FASSOC TYPE COERSIONS))) (FMEMB COMP.UNBOXED.TAG ALLDECLS)) then (while A do (COMP.EXPR (pop A) (CONS 'UNBOXED TYPE)) (SETQ N (ADD1 N))) (FRPTQ (SUB1 N) (COMP.STFN TMP 2)) (RETURN (COMP.FLOATBOX))) (while A do (COMP.VAL (pop A)) [COND ((NOT OPTIMIZATIONSOFF) (COMP.DELFIX TYPE) (* remove extraneous FIX, FLOAT calls) (COND ((AND (NEQ TYPE 'PLUS) (EQ (fetch OPNAME of (CAR CODE)) 'CONST)) (* if FIX or FLOAT type and arg is constant, then coerce.) (COMP.STCONST (APPLY* (OR TYPE 'FIX) (PROG1 (fetch OPARG of (CAR CODE)) (COMP.DELPUSH] (SETQ N (ADD1 N))) [COND ((AND (NOT OPTIMIZATIONSOFF) (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (EQ N 2)) (COND ((EQ (fetch OPNAME of (CAR (fetch PREV of CODE))) 'CONST) (COMP.STCONST (PROG1 (APPLY* (CAR EXP) (fetch OPARG of (CAR (fetch PREV of CODE))) (fetch OPARG of (CAR CODE))) (COMP.DELPUSH) (COMP.DELPUSH))) (RETURN (COMP.STFIX TYPE))) ((FMEMB 2FN (SELECTQ (fetch OPARG of (CAR CODE)) (0 '(IDIFFERENCE LSH RSH LLSH LRSH)) (1 '(IQUOTIENT)) NIL)) (COMP.DELPUSH) (RETURN (COMP.STFIX TYPE] (RETURN (COMP.STFN 2FN N]) (COMP.FIX [LAMBDA (A) (* lmm "18-APR-80 18:28") (COMP.VAL1 A) (COMP.STFIX]) (COMP.STFIX [LAMBDA (TYPE) (* lmm "13-Jul-84 21:18") (OR TYPE (SETQ TYPE 'FIX)) (COND [[AND (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (NUMBERP (fetch OPARG of (CAR CODE] (* COMPILE TIME FIX) (COMP.STCONST (PROG1 (APPLY* TYPE (fetch OPARG of (CAR CODE))) (COMP.DELPUSH] ((AND (EQ TYPE 'FIX) (OPT.CALLP (CAR CODE) NUMBERFNS))) (T (COMP.STFN TYPE 1]) (COMP.DELFIX [LAMBDA (TYPE) (* lmm "16-APR-82 00:19") (* have compiled call to number  function; delete any coersions-to-TYPE) (while (OPT.CALLP (CAR CODE) (SELECTQ TYPE ((FIX NIL) '(IPLUS FIX)) (FLOAT 'FLOAT) 'PLUS) 1) do (COMP.DELFN]) ) (PUTPROPS EQ BYTEMACRO COMP.EQ) (PUTPROPS EQUAL BYTEMACRO COMP.EQ) (PUTPROPS EQP BYTEMACRO COMP.EQ) (DEFINEQ (COMP.EQ [LAMBDA (A) (* lmm " 2-Jan-85 00:23") (COND ((EQ COMPILE.CONTEXT 'EFFECT) (COMP.PROGN A)) (T (PROG (C) (COMP.VAL (pop A)) [COND ((OR OPTIMIZATIONSOFF (NEQ (fetch OPNAME of (CAR CODE)) 'CONST)) (COMP.PROGLST A 1)) ([NULL (SETQ C (fetch OPARG of (CAR CODE] (* (EQ NIL --)) (COMP.DELPUSH) (RETURN (COMP.NOT A))) (T (COMP.DELPUSH) (COMP.PROGLST A 1) (COND [(EQ (fetch OPNAME of (CAR CODE)) 'CONST) (* (EQ CONST CONST)) (RETURN (COMP.STCONST (PROG1 (APPLY* (CAR EXP) C (fetch OPARG of (CAR CODE))) (COMP.DELPUSH] (T (* (EQ CONST EXPRESSION)) (COMP.STCONST C] (RETURN (COMP.STFN (COND ([AND (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (LITATOM (fetch OPARG of (CAR CODE] (* EQ IFF EQUAL) 'EQ) (T (CAR EXP))) 2]) ) (PUTPROPS .TEST. BYTEMACRO (APPLY COMP.NUMBERTEST)) (DEFINEQ (COMP.NUMBERTEST [LAMBDA (X FORM FLG) (* lmm "13-Jul-84 21:18") (PROG (EXIT (TEST (SUBPAIR ' (*) (LIST DONOTHING) FORM)) A) (COMP.EXPR X) (RETURN (SELECTQ (AND (COMP.PREDP COMPILE.CONTEXT) (fetch OPNAME of COMPILE.CONTEXT)) ((FJUMP TJUMP NFJUMP) (* .TEST. in PREDF) (COMP.EXPR TEST COMPILE.CONTEXT)) (NTJUMP [COND ((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE))) '(AVAR HVAR GVAR FVAR)) (AND (EQ (fetch OPNAME of A) 'SETQ) (PROGN (SETQ A (fetch OPARG of A)) T))) (* .TEST. VAR in NTJUMP) [COMP.EXPR TEST (create JUMP OPNAME _ 'FJUMP TAG _ (SETQ EXIT (create TAG] (COMP.STVAR A) (COMP.STJUMP 'JUMP (fetch (JUMP TAG) of COMPILE.CONTEXT)) (COMP.STTAG EXIT) (RETURN 'PREDVALUE)) (T (* .TEST. in NTJUMP PREDF) (COMP.STCOPY) [COMP.EXPR TEST (create JUMP OPNAME _ 'FJUMP TAG _ (SETQ EXIT (create TAG] (COMP.STJUMP 'JUMP (fetch (JUMP TAG) of COMPILE.CONTEXT)) (COMP.STTAG EXIT) (COMP.STPOP) (RETURN 'PREDVALUE]) (COND ((OR (FMEMB (fetch OPNAME of (SETQ A (CAR CODE))) '(AVAR HVAR GVAR FVAR)) (AND (EQ (fetch OPNAME of A) 'SETQ) (PROGN (SETQ A (fetch OPARG of A)) T))) (* .TEST. VAR not in PREDF) [COMP.EXPR TEST (create JUMP OPNAME _ 'NFJUMP TAG _ (SETQ EXIT (create TAG] (COMP.STVAR A) (COMP.STTAG EXIT)) (T (* .TEST. not in PREDF) (COMP.STCOPY) [COMP.EXPR TEST (create JUMP OPNAME _ 'TJUMP TAG _ (SETQ EXIT (create TAG] (COMP.STPOP) (COMP.STCONST) (COMP.STTAG EXIT]) ) (RPAQQ MAPFNS (MAP MAPC MAPLIST MAPCAR MAPCON MAPCONC SUBSET SOME EVERY NOTANY NOTEVERY)) (PUTPROPS MAP BYTEMACRO (APPLY* COMP.MAP)) (PUTPROPS MAPC BYTEMACRO (APPLY* COMP.MAP T)) (PUTPROPS MAPLIST BYTEMACRO (APPLY* COMP.MAP NIL T)) (PUTPROPS MAPCAR BYTEMACRO (APPLY* COMP.MAP T T)) (PUTPROPS MAPCON BYTEMACRO (APPLY* COMP.MAP NIL J)) (PUTPROPS MAPCONC BYTEMACRO (APPLY* COMP.MAP T J)) (PUTPROPS SUBSET BYTEMACRO (APPLY* COMP.MAP T S)) (PUTPROPS SOME BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP)) (PUTPROPS EVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP T)) (PUTPROPS NOTANY BYTEMACRO (APPLY* COMP.MAP BOTH NIL TJUMP T)) (PUTPROPS NOTEVERY BYTEMACRO (APPLY* COMP.MAP BOTH NIL FJUMP NIL)) (PUTPROPS .DOCOLLECT. BYTEMACRO [(VAL TAIL ITEM) (COND [(NOT TAIL) (SETQ TAIL (SETQ VAL (LIST ITEM] (T (FRPLACD TAIL (SETQ TAIL (LIST ITEM]) (PUTPROPS .DOJOIN. BYTEMACRO [(VAL TAIL ITEM) (AND (LISTP ITEM) (COND (TAIL (FRPLACD (SETQ TAIL (LAST TAIL)) ITEM)) (T (SETQ TAIL (SETQ VAL ITEM]) (DEFINEQ (COMP.MAP [LAMBDA (L CARFLG COLLECT PRED NEG WHILEF) (* lmm "18-Sep-84 17:05") (* compile call to mapping function) (PROG [(FROMFORM (CAR L)) (DOF (CADR L)) (BYF (CADDR L)) BOUNDVARS BINDVALS F VAL (XARG '($X] (COMP.PROGLST (CDDDR L) 0) [COND [(COMP.APPLYFNP DOF) (SETQ DOF (CADR DOF)) (COND ((AND (NOT CARFLG) (EQ (CAR (LISTP DOF)) 'LAMBDA)) (* leave DOF alone) NIL) (T (SETQ DOF (LIST 'LAMBDA XARG (CONS DOF (COND ([AND (EQ CARFLG 'BOTH) (NOT (AND (COMP.CLEANFNP DOF 'NARGS) (EQ (NARGS DOF) 1] '((CAR $X) $X)) [CARFLG '((CAR $X] (T '($X] (T (* map function with computed  functional arg) (SETQ BINDVALS (LIST DOF FROMFORM)) [SETQ BOUNDVARS (LIST '$F1 (SETQ FROMFORM '$L] (SETQ DOF (LIST 'LAMBDA XARG (SELECTQ CARFLG (BOTH '(APPLY* $F1 (CAR $X) $X)) (NIL '(APPLY* $F1 $X)) '(APPLY* $F1 (CAR $X] [COND ((NULL BYF) (SETQ BYF 'CDR)) [(COMP.APPLYFNP BYF) (* mapping function with BY argument) (OR (EQ [CAR (LISTP (SETQ BYF (CADR BYF] 'LAMBDA) (SETQ BYF (LIST 'LAMBDA XARG (LIST BYF '$X] (T (* mapping function with computed BY  argument) (SETQ BINDVALS (CONS BYF BINDVALS)) (SETQ BOUNDVARS (CONS '$F2 BOUNDVARS)) (SETQ BYF '(LAMBDA ($X) (COND ((NULL $F2) (CDR $X)) (T (APPLY* $F2 $X] [COND ((NULL WHILEF) (SETQ WHILEF 'LISTP)) [(COMP.APPLYFNP WHILEF) (OR (EQ [CAR (LISTP (SETQ WHILEF (CADR WHILEF] 'LAMBDA) (SETQ WHILEF (LIST 'LAMBDA XARG (LIST WHILEF '$X] (T (SETQ BINDVALS (CONS (LIST 'OR WHILEF ''LISTP) BINDVALS)) (SETQ BOUNDVARS (CONS '$F3 BOUNDVARS)) (SETQ WHILEF '(LAMBDA ($X) (APPLY* $F3 $X] [COND (COLLECT (push BINDVALS NIL NIL NIL NIL) (push BOUNDVARS (SETQ VAL '$V) '$Z '$W '$X] (* bind extra vars) (SETQ F (COMP.BIND.VARS (OPT.DREV BOUNDVARS) (OPT.DREV BINDVALS) 'MAP)) [PROG ((ALLVARS (APPEND (fetch VARS of F) ALLVARS)) (SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (LP (create TAG)) (ENDLP (create TAG)) (OUT (create TAG)) NXT) (COMP.STBIND F) [COMP.EFFECT '(DECLARE (LOCALVARS $F1 $F2 $X $V $Z $W $F3] (COMP.VAL FROMFORM) (OPT.CCHECK (AND (EQ LEVEL 1) (EQ FRAME F))) (COMP.STJUMP 'JUMP ENDLP) (SETQ LEVEL 1) (SETQ FRAME F) (COMP.STTAG LP) (COMP.STCOPY) [COND (COLLECT (OPT.CCHECK (NOT PRED)) (SELECTQ COLLECT ((T J) (* collect or join) (COMP.EFFECT (LIST 'SETQ '$X DONOTHING)) [COMP.EFFECT (LIST 'SETQ '$W (COND ((EQ (CADR DOF) XARG) (CADDR DOF)) (T (LIST DOF '$X] [COMP.EFFECT (SELECTQ COLLECT (J '(.DOJOIN. $V $Z $W)) '(.DOCOLLECT. $V $Z $W]) (S (* SUBSET) [COMP.EXPR (LIST DOF DONOTHING) (create JUMP OPNAME _ 'FJUMP TAG _ (SETQ NXT (create TAG] (COMP.STCOPY) (COMP.EFFECT (LIST 'SETQ '$W (LIST 'CAR DONOTHING))) (COMP.EFFECT '(.DOCOLLECT. $V $Z $W)) (COMP.STTAG NXT)) (SHOULDNT))) (PRED (COMP.EXPR (LIST DOF DONOTHING) (create JUMP OPNAME _ PRED TAG _ OUT))) (T (COMP.EFFECT (LIST DOF DONOTHING] (OPT.CCHECK (EQ LEVEL 1)) (COMP.EXPR (LIST BYF DONOTHING)) (* get next element) (COMP.STTAG ENDLP) (COMP.EXPR (LIST WHILEF DONOTHING)) (COMP.STJUMP 'NTJUMP LP) (COND [PRED (COND ((AND (EQ PRED 'TJUMP) (NULL NEG)) (COMP.VAL NIL) (COMP.STTAG OUT)) (T (COMP.VAL NEG) (COMP.STJUMP 'JUMP (SETQ NXT (create TAG))) (COMP.STTAG OUT) (COMP.STPOP) (COMP.VAL (NULL NEG)) (COMP.STTAG NXT] (T (COMP.VAL VAL] (RETURN (COMP.UNBIND.VARS F]) ) (PUTPROPS LISPXWATCH BYTEMACRO T) (DEFOPTIMIZER BLKAPPLY (&REST ARGS) (CONS 'APPLY ARGS)) (DEFOPTIMIZER BLKAPPLY* (&REST ARGS) (CONS 'APPLY* ARGS)) (DEFOPTIMIZER ADD1VAR (X) `(SETQ ,X (ADD1 ,X))) (DEFOPTIMIZER KWOTE (&REST ARGS) (CONS '(OPENLAMBDA (Q) (COND ((AND Q (NEQ Q T) (NOT (NUMBERP Q))) (LIST 'QUOTE Q)) (T Q))) ARGS)) (DEFOPTIMIZER FRPLNODE (&REST ARGS) (CONS '(OPENLAMBDA (X A D) (FRPLACD (FRPLACA X A) D)) ARGS)) (DEFOPTIMIZER RPLNODE (&REST ARGS) (CONS '(OPENLAMBDA (X A D) (RPLACD (RPLACA X A) D)) ARGS)) (DEFOPTIMIZER LISTGET1 (&REST ARGS) (CONS '(OPENLAMBDA (X Y) (CADR (MEMB Y X))) ARGS)) (DEFOPTIMIZER FRPLNODE2 (&REST ARGS) (CONS '(OPENLAMBDA (X Y) (FRPLACD (FRPLACA X (CAR Y)) (CDR Y))) ARGS)) (PUTPROPS SUB1VAR BYTEMACRO ((X) (SETQ X (SUB1 X)))) (DEFOPTIMIZER EQMEMB (&REST ARGS) (CONS '(OPENLAMBDA (X Y) (OR (EQ X Y) (AND (LISTP Y) (FMEMB X Y) T))) ARGS)) (DEFOPTIMIZER MKLIST (&REST ARGS) (CONS '[OPENLAMBDA (X) (OR (LISTP X) (AND X (LIST X] ARGS)) (* ;; "Pass 1 listing") (DEFINEQ (COMP.MLLIST [LAMBDA (FN CC) (* lmm%: "13-NOV-76 06:56:28") (RESETLST (RESETSAVE (RADIX 10)) (RESETSAVE (LINELENGTH 72)) (PRIN2 FN) (MAPRINT (fetch ARGS of CC) NIL "(" ")" " " (FUNCTION COMP.MLLVAR)) (SPACES 5) [PRINT (CDR (FASSOC (fetch COMTYPE of CC) '((0 . LAMBDA) (2 . LAMBDA*) (1 . NLAMBDA) (2 . NLAMBDA*) (NIL . ???] (COMP.MLL (fetch CODE of CC]) (COMP.MLL [LAMBDA (LL) (* Pavel "15-Nov-86 16:02") [for X in LL do (if (type? TAG X) then (if (NOT (ZEROP (POSITION))) then (TERPRI)) (PRIN2 (fetch (TAG LBNO) of X)) (PRIN1 '%:) else (PROG ((S (GETPROP (fetch OPNAME of X) 'MLSYM)) (P (POSITION))) (if (ILESSP P 5) then (SPACES (IDIFFERENCE 6 P)) elseif (IGREATERP P 60) then (TERPRI) (SPACES 6) else (SPACES 1)) (AND (CAR S) (PRIN1 (CAR S))) [SELECTQ (CDDR S) (CONST (PRIN2 (FETCH OPARG OF X))) (VAR (COMP.MLLVAR X)) (FN (* ; "FN and LINKEDFN") (COMP.MLLFN X)) (VREF (* ; "SETQ ARG") (COMP.MLLVAR (fetch OPARG of X))) (JUMP (PRIN2 (fetch (TAG LBNO) of (fetch (JUMP TAG) of X)))) (BIND (PROG [NN N (F (CDR (FETCH OPARG OF X] (SETQ N (SETQ NN (FETCH NVALS OF F))) (FOR V IN (FETCH VARS OF F) DO (PRIN1 (IF (EQ N NN) THEN (* ; "1ST one") "" ELSEIF (ZEROP N) THEN '; ELSE '%,)) (SETQ N (IPLUS N -1)) (COMP.MLLVAR V)) (if (ZEROP N) then (* ; "All val-bound") (PRIN1 ";")))) (UNBIND (PRIN1 (CAR (fetch OPARG of X)))) (PROGN (PRIN1 (fetch OPNAME of X)) (AND (fetch OPARG of X) (PRIN1 (LIST (fetch OPARG of X] (AND (CADR S) (PRIN1 (CADR S] (TERPRI) (TERPRI]) (COMP.MLLVAR [LAMBDA (X N) (* Pavel "15-Nov-86 16:02") (SETQ N (FETCH (VAR VARNAME) OF X)) (PRIN2 (SELECTQ (FETCH OPNAME OF X) (HVAR (PRIN1 "@") N) (XVAR 'XVAR) N]) (COMP.MLLFN [LAMBDA (X FN) (* Pavel "15-Nov-86 16:03") [PRIN2 (SETQ FN (CDR (FETCH OPARG OF X] (SETQ X (CAR (FETCH OPARG OF X))) (AND (LITATOM FN) (OR (AND (ZEROP (ARGTYPE FN)) (EQ (NARGS FN) X)) (PROGN (SPACES 1) (PRIN2 X]) ) (RPAQQ COPS (BIND UNBIND DUNBIND ERRORSET JUMP TJUMP FJUMP NTJUMP NFJUMP POP COPY RETURN TAG FN CONST SETQ AVAR HVAR GVAR FVAR STORE)) (PUTPROPS BIND MLSYM ("BIND[" %] . BIND)) (PUTPROPS UNBIND MLSYM ("UNBIND(" %) . UNBIND)) (PUTPROPS DUNBIND MLSYM ("DUNBIND(" %) . UNBIND)) (PUTPROPS ERRORSET MLSYM ("ERRORSET " % . JUMP)) (PUTPROPS JUMP MLSYM ("JUMP " % . JUMP)) (PUTPROPS TJUMP MLSYM ("TJUMP " % . JUMP)) (PUTPROPS FJUMP MLSYM ("FJUMP " % . JUMP)) (PUTPROPS NTJUMP MLSYM ("NTJUMP " % . JUMP)) (PUTPROPS NFJUMP MLSYM ("NFJUMP " % . JUMP)) (PUTPROPS FN MLSYM (%[ %] . FN)) (PUTPROPS CONST MLSYM ("'" NIL . CONST)) (PUTPROPS SETQ MLSYM ("SETQ<" > . VREF)) (PUTPROPS AVAR MLSYM (< > . VAR)) (PUTPROPS HVAR MLSYM (< > . VAR)) (PUTPROPS GVAR MLSYM (< > . VAR)) (PUTPROPS FVAR MLSYM (< > . VAR)) (* ;; "ARJ --- JUMP LENGTH RESOLVER") (DEFINEQ (OPT.RESOLVEJUMPS [LAMBDA (JL PROP FN) (* lmm "19-JUL-80 10:00") (PROG ((CU 0) Z NEW) [for X in JL do (replace JSN of X with (fetch JMIN of X)) (COND [(fetch JPT of X) (* Jump) (SETQ Z (CAR (GETPROP (fetch OPNAME of (CAR (fetch JPT of X))) PROP))) (replace JML of X with (CAR Z)) (add CU (replace JU of X with (IDIFFERENCE (CDR Z) (CAR Z] (T (* Tag) (replace JU of X with CU] (while (LISTP (SETQ NEW (OPT.JLENPASS JL PROP))) do (SETQ JL NEW)) (COND (NEW (OPT.JFIXPASS JL FN]) (OPT.JLENPASS [LAMBDA (JL PROP) (* lmm "19-JUL-80 10:08") (PROG ((INC 0) (DEC 0) (CU 0) X U U1 DEF MIN ML SMIN SMAX) (* JPT is NIL (for tags) or a pointer into ACODE  (for jumps)%. JMIN is the lowest possible location for the instruction or tag.  JU is the cumulative uncertainty (for tags) or the length uncertainty  (for jumps)%. JML is the minimum length (for jumps)%.  JSN is a serial number (the original JMIN) used to decide whether a jump goes  forward or backward.) (* In the loop, CU is the cumulative uncertainty, DEC is the cumulative  decrease in uncertainty, and INC is the cumulative increase in minimum  location.) [for J in JL do (SETQ X (CAR (fetch JPT of J))) (add (fetch JMIN of J) INC) (COND ((NULL X) (SETQ DEC (IDIFFERENCE CU (fetch JU of J))) (replace JU of J with CU)) ((NEQ (SETQ U (fetch JU of J)) 0) [SETQ DEF (fetch (TAG JD) of (CAR (fetch OPARG of X] (SETQ MIN (IDIFFERENCE (fetch JMIN of DEF) (fetch JMIN of J))) (SETQ SMAX (OPT.JSIZE X (IPLUS (IDIFFERENCE (fetch JU of DEF) CU) (COND ((IGREATERP (fetch JSN of DEF) (fetch JSN of J)) (IPLUS (SETQ MIN (IPLUS MIN INC)) DEC)) (T MIN))) PROP)) (SETQ SMIN (OPT.JSIZE X MIN PROP)) [COND ((NEQ SMIN (SETQ ML (fetch JML of J))) (replace JML of J with SMIN) (add INC (IDIFFERENCE SMIN ML] (COND ((NEQ (SETQ U1 (IDIFFERENCE SMAX SMIN)) U) [COND ((ILESSP U1 0) (OPT.COMPILERERROR '(U1 negative] (add DEC (IDIFFERENCE U1 U)) (replace JU of J with U1))) (add CU U1] (RETURN (COND ((AND (NEQ DEC 0) (NEQ CU 0)) JL) (T T]) (OPT.JFIXPASS [LAMBDA (JL FN) (* lmm "19-JUL-80 10:23") (PROG (X) (for J in JL do (COND ([NULL (SETQ X (CAR (fetch JPT of J] (replace JU of J with 0)) (T (APPLY* FN (fetch JPT of J) (IDIFFERENCE [fetch JMIN of (fetch (TAG JD) of (CAR (fetch OPARG of X] (fetch JMIN of J]) (OPT.JSIZE [LAMBDA (OP D FN) (* lmm "27-OCT-81 20:28") (PROG [(Z (CDR (GETPROP (fetch OPNAME of OP) FN] LP (COND ((NLISTP Z) (RETURN Z)) (T [SETQ Z (COND ((ILESSP D (CAR Z)) (CADR Z)) (T (CDDR Z] (GO LP]) ) (* ;; "Utilities used by all files") (DEFINEQ (OPT.CALLP [LAMBDA (OP FN N) (* lmm%: "22-JUL-77 02:40") (AND (EQ (fetch OPNAME of OP) 'FN) (OR (NULL N) (EQ (CAR (fetch OPARG of OP)) N)) (OR (NULL FN) (EQ (CDR (fetch OPARG of OP)) FN) (AND (LISTP FN) (FMEMB (CDR (fetch OPARG of OP)) FN]) (OPT.JUMPCHECK [LAMBDA (C) (* lmm%: "22-JUL-77 02:39") (SELECTQ (fetch OPNAME of (CAR C)) ((JUMP RETURN) T) NIL]) (OPT.DREV [LAMBDA (L Z) (PROG (Y) R1 (COND ((NLISTP (SETQ Y L)) (RETURN Z))) (SETQ L (CDR L)) (SETQ Z (FRPLACD Y Z)) (GO R1]) (OPT.CHLEV [LAMBDA (N) (* lmm "14-MAR-81 09:54") (COND (LEVEL (PROG1 (add LEVEL N) (OPT.CCHECK (IGEQ LEVEL 0]) (OPT.CHECKTAG [LAMBDA (TAG TAGFLAG) (* lmm "14-MAR-81 09:15") (COND ((NULL LEVEL) (replace (TAG LEVEL) of TAG with NIL)) ((NULL (fetch (TAG LEVEL) of TAG)) (AND TAGFLAG (SETQ LEVEL NIL))) (T (OPT.CCHECK (EQ LEVEL (fetch (TAG LEVEL) of TAG))) T]) (OPT.NOTJUMP [LAMBDA (X) (* lmm%: "22-JUL-77 03:39") (PROG NIL (RETURN (create OP OPNAME _ (OR (SELECTQ (fetch OPNAME of X) (FJUMP 'TJUMP) (TJUMP 'FJUMP) NIL) (RETURN)) OPARG _ (fetch OPARG of X]) (OPT.INITHASH [NLAMBDA (X) (* ; "Edited 3-Oct-88 16:42 by tal") (DECLARE (LOCALVARS . T)) (LET ((H (EVALV X))) (COND [(HARRAYP H) (COND ((NEQ (HARRAYPROP H 'NUMKEYS) 0) (CLRHASH H] (T (SET X (HASHARRAY 100]) (OPT.COMPINIT [LAMBDA NIL (* lmm%: "22-JUL-77 16:51") [MAPC '((OPRETURN . RETURN) (OPPOP . POP) (OPCOPY . COPY) (OPNIL . CONST)) (FUNCTION (LAMBDA (X) (SET (CAR X) (create OP OPNAME _ (CDR X] (SETQ DONOTHING (LIST 'AC]) ) (MOVD? 'NILL 'REFRAME) (AND (GETD 'OPT.COMPINIT) (OPT.COMPINIT)) (PUTPROPS LOADTIMECONSTANT BYTEMACRO (= . DEFERREDCONSTANT)) (PUTPROPS FRPTQ BYTEMACRO OPT.CFRPTQ) (DEFINEQ (OPT.CFRPTQ [LAMBDA (L) (* lmm "29-Jun-84 08:25") (COND ((EQ COMPILE.CONTEXT 'EFFECT) (PROG ((END (create TAG)) (ST (create TAG))) (COMP.VAL (CAR L)) (* counter) (COMP.STTAG ST) (COMP.STCOPY) (COMP.VAL 0) (COMP.STFN 'IGREATERP 2) (COMP.STJUMP 'FJUMP END) (COMP.VALN (CDR L) 'EFFECT) (COMP.VAL 1) (COMP.STFN 'IDIFFERENCE 2) (COMP.STJUMP 'JUMP ST) (COMP.STTAG END))) (T (COMP.EXP1 (CONS 'RPTQ L]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS AC ALAMS1 ALLVARS ARGS ARGVARS BLKDEFS BLKFLG CODE COMFN COMFNS COMTYPE CONSTS EMFLAG EXP FRAME FREELST FREEVARS LAPFLG LBCNT LEVEL LOCALVARS LOCALVARS LSTFIL MACEXP NLAMS1 PIFN COMPILE.CONTEXT PROGCONTEXT RETURNLABEL SPECVARS SPECVARS SUBFNFREEVARS TAGS TOPFN TOPFRAME TOPLAB VARS INTERNALBLKFNS) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS PLVLFILEFLG) ) ) (PUTPROPS IMAX2 BYTEMACRO (OPENLAMBDA (X Y) (COND ((NOT (IGREATERP X Y)) Y) (T X)))) (PUTPROPS IMIN2 BYTEMACRO (OPENLAMBDA (X Y) (COND ((IGREATERP X Y) Y) (T X)))) (PUTPROPS FLOAT BOX (\FLOATBOX . \FLOATUNBOX)) (DEFINEQ (COMP.AREF [LAMBDA (A) (* raf "18-Jun-85 17:52") (PROG (DECL) [COND ([AND (LITATOM (CAR A)) (EQ [CAR (SETQ DECL (CDR (FASSOC (COMP.LOOKUPVAR (CAR A)) ALLDECLS] 'ARRAY) (EQ (LENGTH (MKLIST (CADDR DECL))) (LENGTH (CDR A] (COND ((EQUAL (CADR DECL) '(BYTE 16)) (RETURN (COMP.EXPR (CONS '\16AREF A) COMPILE.CONTEXT))) ((FMEMB (CADR DECL) '(FLOATP FLONUM)) (RETURN (COMP.EXPR (CONS '\LAREF A) COMPILE.CONTEXT))) (T (HELP] (MAPC A (FUNCTION COMP.VAL)) (COMP.STFN (SELECTQ (LENGTH A) (2 '\AREF.1) (3 '\AREF.2) 'CL:AREF) (LENGTH A]) (COMP.ASET [LAMBDA (A) (* kbr%: "12-Mar-85 17:08") (PROG (DECL) [COND ([AND (LITATOM (CADR A)) (EQ [CAR (SETQ DECL (CDR (FASSOC (COMP.LOOKUPVAR (CADR A)) ALLDECLS] 'ARRAY) (EQ (LENGTH (MKLIST (CADDR DECL))) (LENGTH (CDDR A] (COND ((EQUAL (CADR DECL) '(BYTE 16)) (RETURN (COMP.EXPR (CONS '\16ASET A) COMPILE.CONTEXT))) ((FMEMB (CADR DECL) '(FLOATP FLONUM)) (RETURN (COMP.EXPR (CONS '\LASET A) COMPILE.CONTEXT))) (T (HELP] (MAPC A (FUNCTION COMP.VAL)) (COMP.STFN (SELECTQ (LENGTH A) (3 '\ASET.1) (4 '\ASET.2) 'ASET) (LENGTH A]) (COMP.BOX [LAMBDA (TYPE) (* lmm " 1-Jul-84 17:45") (PROG [(BOXER (AND (LITATOM TYPE) (GETPROP TYPE 'BOX] (if BOXER then (if (OPT.CALLP (CAR CODE) (CDR BOXER) 1) then (* top of stack was (unbox value)%, just get rid of BOX) (COMP.DELFN) (COMP.STFIX TYPE) else (COMP.STFN (CAR BOXER) 1]) (COMP.LOOKFORDECLARE [LAMBDA (EXPS) (* lmm " 1-Jul-84 16:54") (while (EQ (CAR (LISTP (CAR EXPS))) COMMENTFLG) do (pop EXPS)) (if (EQ (CAR (LISTP (CAR EXPS))) 'DECLARE) then (for Y in (CDAR EXPS) bind DECLS do (SELECTQ (CAR Y) (TYPE [for Z in (CDDR Y) do (push DECLS (CONS Z (COMP.DECLARETYPE (CADR Y]) NIL) finally (RETURN DECLS]) (COMP.DECLARETYPE [LAMBDA (X) (* lmm "13-Jul-84 22:19") (* returns a valid compile context,  too) (SELECTQ X ((FLOATING FLOATP FLOAT) (* if you declare a variable to be FLOAT, you are really saying to hold it "unboxed") '(UNBOXED . FLOAT)) (if (LISTP X) then (SELECTQ (CAR X) (ARRAY X) NIL]) (COMP.FLOATBOX [LAMBDA NIL (* lmm "28-Jun-84 15:09") (COND ((OPT.CALLP (CAR CODE) '\FLOATUNBOX 1) (COMP.DELFN)) (T (COMP.STFN '\FLOATBOX 1]) (COMP.FLOATUNBOX [LAMBDA NIL (* lmm "28-Jun-84 15:08") (PROGN (COMP.DELFIX 'FLOAT) (COND ((OPT.CALLP (CAR CODE) '\FLOATBOX 1) (COMP.DELFN)) [[AND (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (NUMBERP (fetch OPARG of (CAR CODE] (PROG [(NUM (fetch OPARG of (CAR CODE] (COMP.DELPUSH) (if (EQUAL (SETQ NUM (FLOAT NUM)) 0) then (COMP.STCONST NIL) else (COMP.EXPR `(\VAG2 %, (fetch (FLOATP HIWORD) of NUM) %, (fetch (FLOATP LOWORD) of NUM] (T (COMP.STFN '\FLOATUNBOX 1]) (COMP.PREDP [LAMBDA (CTX) (* lmm "29-Jun-84 08:30") (AND (LISTP CTX) (FMEMB (CAR CTX) '(TJUMP FJUMP NTJUMP NFJUMP]) (COMP.UBFLOAT2 [LAMBDA (A OP) (* lmm "29-Jun-84 09:07") (PROG ((N 0)) [COND ((AND (EQ COMPILE.CONTEXT 'EFFECT) (NOT OPTIMIZATIONSOFF)) (RETURN (COMP.PROGN A] (while A do (COMP.VAL (pop A)) (COMP.FLOATUNBOX) (SETQ N (ADD1 N))) (FRPTQ (SUB1 N) (COMP.STFN (LIST 'OPCODES 'UBFLOAT2 OP) 1)) (COMP.FLOATBOX]) (COMP.UNBOX [LAMBDA (TYPE) (* lmm "29-Dec-84 11:46") (PROG [(BOXER (AND (LITATOM TYPE) (GETPROP TYPE 'BOX] (if BOXER then (COND ((OPT.CALLP (CAR CODE) (CAR BOXER) 1) (* top of stack was (box value)%, just get rid of BOX) (COMP.DELFN)) ((EQ TYPE 'FLOAT) (COMP.FLOATUNBOX)) (T (HELP) (* if top of stack is (convert-type value) then get rid of convert-type before  putting in unbox) (COMP.DELFIX TYPE) (COMP.STFN (CDR BOXER) 1))) else (HELP "CAN'T UNBOX" TYPE]) ) (ADDTOVAR COMPILETYPELST ) (* ; "POST OPTIMIZATION") (DEFINEQ (OPT.POSTOPT [LAMBDA (CODE) (* lmm "29-Dec-84 20:48") (COND [OPTIMIZATIONSOFF (while CODE bind C VAL do (SETQ TAGS NIL) (while (EQ (fetch OPNAME of (SETQ C (pop CODE))) 'TAG) do (push TAGS C)) (while (AND (EQ (fetch OPNAME of C) 'JUMP) (FMEMB (fetch OPARG of C) TAGS)) do (SETQ C (pop CODE))) (for TAG in TAGS do (push VAL TAG)) (push VAL C) finally (RETURN (CDR VAL] (T (PROG ((FRAME TOPFRAME) CL:LABELS ANY (FRAMES (LIST (LIST TOPFRAME))) (PASS 1) DELETEDBINDS) (SETQ CODE (CONS NIL (NCONC1 CODE NIL))) (OPT.SETUPOPT) OPTLP (SETQ ANY) (* optimization pass) (AND (OPT.FRAMEOPT (EQ PASS 1)) (SETQ ANY T)) (OPT.SCANOPT) (OPT.JUMPOPT) (OPT.RETOPT) (OPT.CCHECK (OPT.OPTCHECK)) [COND ((NOT ANY) (AND [NOT (OR (AND XVARFLG (PROGN (OPT.XVARSCAN) (OPT.FRAMEOPT T NIL T))) (AND MERGEFRAMEFLG (OPT.FRAMEOPT T T XVARFLG] (RETURN (CDR (OPT.DREV (CDR CODE] (SETQ PASS (ADD1 PASS)) (BLOCK) (GO OPTLP]) (OPT.SETUPOPT [LAMBDA NIL (* lmm%: "22-JUL-77 02:59") (* set up code list as doubly linked list, scan for tags) (PROG ((C CODE) P B) LPC (COND ((NULL C) (RETURN))) (SELECTQ (fetch OPNAME of (CAR C)) (TAG [COND ((SETQ B (FASSOC (CAR C) CL:LABELS)) (FRPLACA (CDR B) C)) (T (SETQ CL:LABELS (CONS (LIST (CAR C) C) CL:LABELS]) ((JUMP TJUMP FJUMP NTJUMP NFJUMP ERRORSET) [COND ((SETQ B (FASSOC (fetch (JUMP TAG) of (CAR C)) CL:LABELS)) (NCONC1 B C)) (T (SETQ CL:LABELS (CONS (LIST (fetch (JUMP TAG) of (CAR C)) NIL C) CL:LABELS]) NIL) (SELECTQ (fetch OPNAME of (CAR C)) ((ERRORSET BIND) [COND ((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C))) FRAMES)) (RPLACA (CDR B) C)) (T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C))) C) FRAMES]) ((UNBIND DUNBIND) [COND ((SETQ B (FASSOC (CDR (fetch OPARG of (CAR C))) FRAMES)) (NCONC1 B C)) (T (SETQ FRAMES (CONS (LIST (CDR (fetch OPARG of (CAR C))) NIL C) FRAMES]) NIL) (SETQ B (CDR C)) (replace PREV of C with B) (replace NXT of C with P) (SETQ P C) (SETQ C B) (GO LPC]) (OPT.SCANOPT [LAMBDA NIL (* lmm "29-Apr-85 19:26") (PROG ((CD CODE) A B P X Y) LP (SETQ B (fetch PREV of CD)) [AND P (OPT.CCHECK (EQ CD (fetch PREV of P] (SELECTQ (fetch OPNAME of (SETQ A (CAR CD))) (CONST (COND ((AND (OPT.CALLP (CAR P) NIL 1) (OR (FMEMB [SETQ X (CDR (fetch OPARG of (CAR P] CONSTFNS) (FMEMB X VCONDITIONALS) (FMEMB X CONDITIONALS))) (* CONST FN.1 -> (FN CONST)) [RPLACA CD (create OP OPNAME _ 'CONST OPARG _ (APPLY* X (fetch OPARG of A] (OPT.PRDEL P) (GO BLP)) ([AND (SETQ A (FASSOC (fetch OPARG of A) CONST.FNS)) (SOME (CDR A) (FUNCTION (LAMBDA (X) (OPT.CALLP (CAR P) (CAR (SETQ A (CDR X))) (CAR X] (* constant + fn -> otherfn) (OPT.PRDEL CD) (OPT.PRDEL P) [MAPC (CDR A) (FUNCTION (LAMBDA (X) (SETQ B (OPT.PRATTACH (create OP OPNAME _ (CAR X) OPARG _ (CDR X)) B] (GO BLP))) (GO CHECKPUSH)) (HVAR (GO CHECKPUSH)) ((AVAR GVAR FVAR) (GO CHECKPUSH)) (SETQ (COND ((EQ (fetch OPARG of A) (CAR B)) (* want OPT.EQVALUE B CD execept OPT.EQVALUE takes the wrong kind of arg) (* var (setq var) => var) (OPT.PRDEL CD) (GO BLP)) ((OPT.DEADSETQP (fetch OPARG of A) P) (* delete dead SETQ) (OPT.PRDEL CD) (GO BLP)))) (POP (SELECTQ (fetch OPNAME of (CAR B)) ((AVAR HVAR FVAR GVAR COPY CONST) (* push POP deleted) (OPT.PRDEL B) (OPT.PRDEL CD) (SETQ B P) (GO BLP)) (FN (COND ((COMP.CLEANFNOP (CDR (fetch OPARG of (CAR B))) 'NOSIDE) (* cleanfn POP deleted) (RPTQ (PROG1 (CAR (fetch OPARG of (CAR B))) (OPT.PRDEL B) (OPT.PRDEL CD) (SETQ B (fetch PREV of P))) (SETQ B (OPT.PRATTACH OPPOP B))) (GO BLP)))) (SETQ (COND ([EQUAL (CAR (fetch PREV of B)) (CONSTANT (create OP OPNAME _ 'COPY] (* COPY SETQ POP -> SETQ) (OPT.PRDEL (fetch PREV of B)) (OPT.PRDEL CD) (SETQ B P) (GO BLP)))) NIL)) (DUNBIND (COND ((AND COMPILE.DUNBIND.POP.MERGE.FLG (EQ (CAR B) OPPOP)) (* merge pop with DUNBIND) (OPT.PRDEL B) (* (DUNBIND level . frame)) [RPLACA (fetch OPARG of (CAR CD)) (ADD1 (CAR (fetch OPARG of (CAR CD] (GO ALP)))) (UNBIND (COND ((SELECTQ (fetch OPNAME of (CAR B)) (CONST (* CONST UNBIND) (replace OPNAME of A with 'DUNBIND) (* change to DUNBIND) (* level is 1 less) [RPLACA (fetch OPARG of A) (SUB1 (CAR (fetch OPARG of A]) (FN (COND ((AND (EQ (CAR (fetch OPARG of (CAR B))) 1) (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR B))) 'FREEVARS))(* clean FN UNBIND) T))) NIL) (RPLACA CD (CAR B)) (RPLACA B A) (* switch CONST and DUNBIND) (RPLACA (MEMB CD (CDDR (FASSOC (CDR (fetch OPARG of A)) FRAMES))) B) (GO BLP)))) NIL) TAG2 (COND ((NULL B) (RETURN))) (SETQ P CD) (SETQ CD B) (GO LP) BLP (SETQ CD B) CLP (SETQ P (fetch NXT of CD)) ALP (SETQ ANY T) (GO LP) CHECKPUSH (AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR B)) (POP (COND ((OPT.EQVALUE (fetch PREV of B) CD) (* X POP X) (OPT.PRDEL CD) (OPT.PRDEL B) (SETQ CD (fetch PREV of P)) (GO ALP)))) NIL)) [COND (NEWOPTFLG (COND ((SETQ X (OPT.JUMPCOPYTEST CD B)) (* can insert COPY at X and then  delete CD) (SETQ X (OPT.DELCOPYFN P X)) (SETQ P (fetch NXT of CD)) [COND ((EQ X (fetch PREV of CD)) (OPT.PRDEL CD)) (T (FRPLACA CD '(SWAP] (OPT.PRATTACH OPCOPY X) (SETQ CD (fetch PREV of P)) (GO ALP))) (COND ((AND (SETQ X (OPT.SKIPPUSH B 1 CD T)) (SETQ X (OPT.JUMPCOPYTEST CD X))) (SETQ X (OPT.DELCOPYFN P X)) (OPT.PRATTACH OPCOPY X) (FRPLACA CD '(SWAP)) (GO ALP))) (GO TAG2)) (T (COND ((OPT.EQVALUE B CD) (* val val -> val COPY) (FRPLACA CD OPCOPY)) ((EQ (CAR B) OPPOP) (COND ((OPT.EQVALUE (fetch PREV of B) CD) (* SETQ POP PUSH) (OPT.PRDEL CD) [OPT.PRDEL (PROG1 B (SETQ CD (fetch PREV of B] (GO ALP] (GO TAG2]) (OPT.XVARSCAN [LAMBDA NIL (* rmk%: " 2-Apr-85 12:44") (PROG ((CD CODE) A) [for X in FRAMES do (replace NOXVAR of (CAR X) with (NEQ NIL (OASSOC 'AVAR (fetch VARS of (CAR X] LP (SELECTQ (fetch OPNAME of (SETQ A (CAR CD))) (HVAR (AND (NOT (FMEMB A (FETCH VARS OF TOPFRAME))) (OPT.XVARSCAN1 A CD))) (SETQ (SETQ A (fetch OPARG of A)) (COND ((EQ (fetch OPNAME of A) 'HVAR) (OPT.XVARSCAN1 A CD)))) ((UNBIND DUNBIND) (OR (OPT.CODELEV CD 0) (replace NOXVAR of (CDR (fetch OPARG of A)) with T))) NIL) (COND ((NULL (SETQ CD (fetch PREV of CD))) (RETURN))) (GO LP]) (OPT.XVARSCAN1 [LAMBDA (A CD) (* rmk%: " 2-Apr-85 12:03") (PROG ((FR (OPT.CODEFRAME CD))) (OR FR (OPT.COMPILERERROR)) (COND ((FMEMB A (fetch VARS of FR)) (RETURN))) LP (SETQ FR (fetch PARENT of FR)) (COND ((FMEMB A (fetch VARS of FR)) (replace NOXVAR of FR with T) (RETURN))) (COND ((EQ FR TOPFRAME) (* can't find A) (OPT.COMPILERERROR))) (GO LP]) (OPT.JUMPOPT [LAMBDA NIL (* lmm "11-NOV-81 21:17") (MAPC CL:LABELS (FUNCTION (LAMBDA (X) (COND ((CADR X) (* Label defined) (COND ((OR (OPT.JUMPTHRU (CAR X) (CDR X)) (OPT.JUMPREV (CAR X) (CDR X))) (SETQ ANY T]) (OPT.JUMPTHRU [LAMBDA (TAG OPT.DEFREFS) (* lmm "13-Jul-84 21:18") (PROG ((DR OPT.DEFREFS) P APD ALST ANY INFO Y REF BR END (DEF (CAR OPT.DEFREFS)) PD B (FRAME (fetch (TAG FRAME) of TAG)) (LEVEL (fetch (TAG LEVEL) of TAG))) LQ (while [OR [type? TAG (SETQ APD (CAR (fetch PREV of DEF] (type? TAG (SETQ APD (CAR (SETQ PD (fetch NXT of DEF] do (* two adjacent tags -  merge them) (OPT.LBMERGE TAG APD)) [COND ((NULL (CDR DR)) (* tag which is not reference;  delete it) (RETURN (OPT.LBDEL TAG] [COND [(EQ APD OPNIL) (* instruction after the tag is NIL) (SETQQ ALST ((FJUMP NFJUMP . OPNIL] (T (SETQ ALST (SELECTQ (fetch OPNAME of APD) (JUMP '((JUMP) (TJUMP) (FJUMP) (NTJUMP) (NFJUMP))) (TJUMP '((NTJUMP TJUMP) (NFJUMP FJUMP . 1))) (FJUMP '((NTJUMP TJUMP . 1) (NFJUMP FJUMP))) (NTJUMP '((NTJUMP) (NFJUMP FJUMP . 1))) (NFJUMP '((NTJUMP TJUMP . 1) (NFJUMP))) (POP '((NTJUMP TJUMP . 1) (NFJUMP FJUMP . 1) (JUMP NIL . JP))) (RETURN '((JUMP NIL . R))) ((AVAR GVAR FVAR HVAR) '((FJUMP NFJUMP . L) (TJUMP NTJUMP . L) (JUMP NIL . LL))) (RETURN] LP (COND ((NOT (SETQ INFO (FASSOC [fetch OPNAME of (CAR (SETQ REF (CADR DR] ALST))) (GO NX))) (COND ((EQ REF PD) [COMPERRM (CONS COMFN '(-- infinite loop] (GO NX))) (SETQ BR (fetch PREV of REF)) (SETQ Y (SELECTQ (CDDR INFO) (NIL (* JUMP to JUMP) (fetch (JUMP TAG) of APD)) (R (* JUMP to RETURN) (FRPLACA REF OPRETURN) NIL) (L (* VARIABLE REFERENCE) (COND ((OR (OPT.EQVALUE BR PD) (AND (EQ (fetch OPNAME of (CAR REF)) 'TJUMP) (OPT.CALLP (CAR BR) VCONDITIONALS 1) (OPT.EQVALUE (fetch PREV of BR) PD))) (* VAR CJUMP to VAR) (OPT.LABELNTHPR DEF 1 LEVEL 1)) [(SETQ Y (OPT.JUMPCOPYTEST PD BR)) (* VAR CJUMP .. VAR -> VAR COPY CJUMP POP ..  VAR) (PROG ((N 1) PDN) [COND (NEWOPTFLG (SETQ PDN (fetch NXT of PD)) (while (AND (OPT.CALLP (CAR (SETQ INFO (fetch NXT of Y))) NIL 1) (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR INFO))) 'NOSIDE) (OPT.EQOP (CAR INFO) (CAR PDN))) do (SETQ Y INFO) (SETQ PDN (fetch NXT of PDN)) (add N 1] (OPT.PRATTACH OPCOPY Y) (OPT.PRATTACH OPPOP REF) (SETQ INFO) (RETURN (OPT.LABELNTHPR DEF N LEVEL 1] (T (GO NX)))) (LL (COND ((AND (EQ (CAR BR) OPPOP) (OPT.EQVALUE (fetch PREV of BR) PD)) (* SETQ var POP JUMP to var) (OPT.PRDEL BR) (OPT.LABELNTHPR DEF 1 LEVEL 1)) (T (GO NX)))) (1 (* NTJUMP to POP) (OPT.LABELNTHPR DEF 1 LEVEL -1)) (OPNIL (* FJUMP to NIL) (OPT.LABELNTHPR DEF 1 LEVEL 1)) (JP (COND ((SETQ B (OPT.SKIPPUSH BR 1 NIL T)) (* JUMP to POP) [PROG NIL LPB (SETQ BR (PROG1 (fetch PREV of BR) (OPT.PRDEL BR))) (COND ((NEQ BR B) (GO LPB] (OPT.LABELNTHPR DEF 1 LEVEL -1)) (T (GO NX)))) (OPT.COMPILERERROR))) (COND (Y (replace (JUMP TAG) of (CAR REF) with Y) (NCONC1 (OPT.DEFREFS Y) REF))) (SETQ ANY T) (* Since the jump to this tag was redirected, delete the jump from the REFS for  this tag) (FRPLACD DR (CDDR DR)) [COND ((CADR INFO) (replace OPNAME of (CAR REF) with (CADR INFO] (GO LX) NX (SETQ DR (CDR DR)) LX (COND ((CDR DR) (GO LP))) [COND ((NULL (CDR OPT.DEFREFS)) (RETURN (OPT.LBDEL TAG] (RETURN ANY]) (OPT.LBMERGE [LAMBDA (TO FROM) (* lmm%: "22-JUL-77 16:03") (PROG [(REFS (CDR (OPT.DEFREFS FROM] [MAPC REFS (FUNCTION (LAMBDA (X) (replace (JUMP TAG) of (CAR X) with TO] (NCONC (OPT.DEFREFS TO) REFS) [OR (fetch (TAG LEVEL) of FROM) (PROGN (replace (TAG LEVEL) of TO with NIL) (OR (fetch FRAME of FROM) (replace FRAME of TO with NIL] (RETURN (OPT.LBDEL FROM]) (OPT.PRDEL [LAMBDA (X) (* ; "Edited 10-Jul-90 23:18 by jds") (* ;;  "Remove X from the code stream by splicing it out of the doubly-linked list of code elements.") (PROG ((B (fetch PREV of X)) (P (fetch NXT of X))) (AND B (replace NXT of B with P)) (AND P (replace PREV of P with B)) (replace NXT of X with NIL]) (OPT.UBDEL [LAMBDA (CD) (* lmm "14-MAR-81 09:16") (DREMOVE CD (OR (FASSOC (CDR (fetch OPARG of (CAR CD))) FRAMES) (OPT.COMPILERERROR]) (OPT.LBDEL [LAMBDA (TAG) (* ; "Edited 10-Jul-90 23:19 by jds") (* ;; "Deleting a tag from the code stream. Remove references to the tag.") (PROG ((DEF (CAR (OPT.DEFREFS TAG))) B) (SETQ B (fetch PREV of DEF)) (OPT.PRDEL DEF) (OPT.SETDEFREFS TAG NIL) (SETQ CL:LABELS (DREMOVE (FASSOC TAG CL:LABELS) CL:LABELS)) [COND ((OPT.JUMPCHECK B) (* ;  "If there's a jump between this tag and any previous tags, delete code before deleted tag") (OPT.DELCODE (fetch NXT of B] (RETURN T]) (OPT.LABELNTHPR [LAMBDA (CODE CNT LEVEL DL) (* lmm%: "22-JUL-77 16:12") (PROG ((CD CODE) G) (OPT.CHLEV DL) LP (SETQ CD (fetch NXT of CD)) (COND ((IGREATERP CNT 0) (OR (type? TAG (CAR CD)) (SUB1VAR CNT)) (GO LP)) (T (RETURN (COND ((type? TAG (CAR CD)) (OPT.CHECKTAG (CAR CD) T) (CAR CD)) (T (PROG1 (SETQ G (create TAG)) (replace (TAG FRAME) of G with FRAME) (SETQ CD (OPT.PRATTACH G (fetch PREV of CD))) (OPT.SETDEFREFS G (LIST CD)) (replace (TAG LEVEL) of G with LEVEL]) (OPT.JUMPREV [LAMBDA (TAG OPT.DEFREFS) (* lmm "13-Jul-84 21:18") (* OPT.JUMPREV checks the things that PRECEDE particular kinds of jumps) (PROG ((DR OPT.DEFREFS) R (D (CAR OPT.DEFREFS)) END ANY LB CD (LEVEL (fetch (TAG LEVEL) of TAG)) (FRAME (fetch (TAG FRAME) of TAG)) BD ABD FLG BR ABR OABR PR APD OAR TMP) LP (SETQ R (CADR DR)) (SETQ PR (fetch NXT of R)) (SETQ BD (fetch PREV of D)) (SETQ ABD (CAR BD)) (SETQ BR (fetch PREV of R)) (SETQ ABR (CAR BR)) (SETQ OABR (fetch OPNAME of ABR)) (SETQ OAR (fetch OPNAME of (CAR R))) (* variable code%: last letter is R for reference {i.e.  place of jump}, D for definition {i.e. place where TAG is} -  preceding letters%: -  A for CAR -  O for COP {op code} -  P for CPR {next byte} -  B for CBR {previous byte}) (SELECTQ OAR (JUMP [COND ((EQ R BD) (* JUMP to next location deleted) (OPT.PRDEL R)) [(AND (OPT.EQOP ABD ABR) (SETQ TMP (OPT.COMMONBACK BD R LEVEL))) (* OPT.COMMONBACK returns NIL if does nothing;  T if deleted safe code or SAME if it deleted some code that contained a  reference to the label that is now being worked on.) (* merge similar code before JUMP and  TAG) (* IF SAME don't continue with this label! could have deleted other references  to it) (COND ((EQ TMP T) (SETQ ANY T) (GO LX)) (T (RETURN T] [[AND (CAR PR) (NOT (type? TAG (CAR PR] (* delete code after JUMP) (COND ((OPT.DELCODE PR) (* returns T if it deleted any jumps  (may have deleted a jump for this tag)) (RETURN)) (T (GO NX] ([AND (SELECTQ (fetch OPNAME of ABD) (RETURN T) (JUMP (NOT (FMEMB BD DR))) NIL) (SETQ END (fetch NXT of (OPT.FINDEND D R] (* move jumped-to code in line) (PROGN (replace NXT of BD with END) (replace PREV of (PROG1 END (SETQ END (fetch PREV of END))) with BD)) (PROGN (replace NXT of BR with D) (replace PREV of D with BR) (replace PREV of PR with END) (replace NXT of END with PR))) (T (SELECTQ OABR (CONST (* CONST JUMP) (SELECTQ (fetch OPNAME of APD) ((TJUMP NTJUMP) (SETQ FLG (fetch OPARG of ABR))) ((FJUMP NFJUMP) (SETQ FLG (NULL (fetch OPARG of ABR)))) (GO NX)) (NCONC1 [OPT.DEFREFS (replace (JUMP TAG) of (CAR R) with (COND (FLG (SELECTQ (fetch OPNAME of APD) ((TJUMP FJUMP) (* T JUMP to TJUMP) (OPT.PRDEL BR)) (* T JUMP to NTJUMP)) (fetch (JUMP TAG) of APD)) (T (* T JUMP to NF/FJUMP) (OPT.PRDEL BR) (OPT.LABELNTHPR D 1 LEVEL -1] R)) ((TJUMP FJUMP) (COND ((EQ (fetch (JUMP TAG) of (CAR R)) (fetch (JUMP TAG) of ABR)) (* TJUMP->TAG JUMP->TAG => POP  JUMP->TAG) (OPT.PRDEL R) (OPT.PRATTACH OPPOP (fetch PREV of BR)) (replace OPNAME of ABR with 'JUMP)) (T (GO NX)))) (GO NX]) ((FJUMP TJUMP) (COND ((EQ R BD) (* TJUMP to next location) (FRPLACA R OPPOP)) [(EQ OABR 'CONST) (COND ((SELECTQ OAR (TJUMP (fetch OPARG of ABR)) (NULL (fetch OPARG of ABR))) (* T TJUMP -> JUMP) (replace OPNAME of (CAR R) with 'JUMP) (OPT.PRDEL BR) (SETQ ANY T) (* try again) (GO LP)) (T (* T FJUMP -> NOOP) (OPT.PRDEL R) (OPT.PRDEL BR] ((OPT.CALLP ABR '(NOT NULL) 1) (* NULL TJUMP) (FRPLACA R (OPT.NOTJUMP (CAR R))) (OPT.PRDEL BR) (GO REDO)) ((AND (EQ ABR OPCOPY) (EQ (CAR PR) OPPOP)) (* COPY TJUMP POP -> NTJUMP) (OPT.PRDEL BR) (OPT.PRDEL PR) (replace OPNAME of (CAR R) with (SELECTQ OAR (TJUMP 'NTJUMP) 'NFJUMP)) (GO REDO)) ((AND (EQ (fetch OPNAME of ABD) 'JUMP) (EQ (fetch PREV of BD) R)) (* FJUMP.1 JUMP.2 1%: => TJUMP.2) (replace OPNAME of ABD with (SELECTQ OAR (TJUMP 'FJUMP) 'TJUMP)) (OPT.PRDEL R)) ((SETQ CD (OPT.JUMPCOPYTEST PR BR)) (* What is before the jump is also after -  e.g. X TJUMP X) (COND ((EQ (CAR PR) (CAR (fetch NXT of D))) (* X TJUMP.1 X ... 1%:X ... -> X COPY TJUMP.2 ...  1%:X 2%: ...) (OPT.PRATTACH OPCOPY CD) (SETQ LB (OPT.LABELNTHPR D 1 LEVEL 1))) ((AND (OPT.JUMPCHECK (fetch PREV of D)) (OR (OPT.EQVALUE BR PR) (AND (EQ OAR 'FJUMP) (OPT.CALLP ABR VCONDITIONALS 1) (OPT.EQVALUE (fetch PREV of BR) PR))) (SETQ END (OPT.FINDEND D R))) (* X FJUMP.1 X .a. 1%: .b. -> X NTJUMP.2 1%: .b.  ... 2%: .a.) (PROGN (replace NXT of (fetch PREV of D) with (fetch NXT of END)) (replace PREV of (fetch NXT of END) with (fetch PREV of D))) (PROGN (replace NXT of R with D) (replace PREV of D with R) (replace PREV of PR with END) (replace NXT of END with PR)) (replace OPNAME of (CAR R) with (SELECTQ OAR (FJUMP 'NTJUMP) 'NFJUMP)) (SETQ LB (OPT.LABELNTHPR PR 0 LEVEL 1))) (T (GO NX))) (OPT.PRDEL PR) (replace (JUMP TAG) of (CAR R) with LB) (NCONC1 (OPT.DEFREFS LB) R)) (T (GO NX)))) ((NFJUMP NTJUMP) (COND [(EQ OABR 'CONST) (COND ((SELECTQ OAR (NTJUMP (fetch OPARG of ABR)) (NULL (fetch OPARG of ABR))) (* T NTJUMP -> JUMP) (replace OPNAME of (CAR R) with 'JUMP) (GO REDO)) (T (* T NFJUMP -> NOOP) (OPT.PRDEL BR) (OPT.PRDEL R] ((OPT.EQVALUE BR PR) (* X NTJUMP X -> X COPY TJUMP) (OPT.PRATTACH OPCOPY (fetch PREV of R)) (OPT.PRDEL PR) (replace OPNAME of (CAR R) with (SELECTQ OAR (NTJUMP 'TJUMP) 'FJUMP)) (GO REDO)) [(EQ OAR 'NTJUMP) (COND [(NOT (OR (OPT.CALLP ABR CONDITIONALS) (OPT.CALLP ABR VCONDITIONALS))) (COND ((EQ (CAR (fetch NXT of R)) OPNIL) (* NTJUMP NIL -> COPY TJUMP) (OPT.PRDEL (fetch NXT of R)) (OPT.PRATTACH OPCOPY BR) (replace OPNAME of (CAR R) with 'TJUMP) (GO REDO)) (T (GO NX] [(OPT.CALLP ABR VCONDITIONALS 1) (COND ((OPT.EQVALUE (fetch PREV of BR) PR) (* X LISTP NTJUMP X -> X COPY LISTP  TJUMP) (OPT.PRATTACH OPCOPY (fetch PREV of BR)) (OPT.PRDEL PR) (replace OPNAME of (CAR R) with 'TJUMP) (GO REDO)) (T (GO NX] (T (GO NX] (T (GO NX)))) (GO NX)) (SETQ ANY T) (FRPLACD DR (CDDR DR)) (GO LX) NX (SETQ DR (CDR DR)) LX (COND ((CDR DR) (GO LP))) (RETURN ANY) REDO (SETQ ANY T) (GO LP]) (OPT.COMMONBACK [LAMBDA (BDEF REF LEVEL) (* ; "Edited 10-Jul-90 13:59 by jds") (* ;; "When the code preceding a jump is the same as the code preceding the label, can delete the code preceding the jump and move the label back --- BDEF is the code preceding the label and REF is the jump and the code that precedes it") (PROG ((BREF (fetch PREV of REF)) G FLG TMP (FRAME FRAME)) M (COND ((EQ (fetch OPNAME of (CAR BDEF)) 'TAG) (OPT.CHECKTAG (CAR BDEF) LEVEL) (SETQ BDEF (fetch PREV of BDEF)) (GO M))) (COND ((OPT.EQOP (CAR BDEF) (CAR BREF)) [SELECTQ (fetch OPNAME of (CAR BREF)) ((AVAR HVAR GVAR FVAR CONST COPY) (OPT.CHLEV -1)) ((SETQ STORE SWAP RETURN)) (POP (COND ((AND [NOT (OPT.EQOP (CAR (fetch PREV of BREF)) (CAR (fetch PREV of BDEF] (EQ (fetch OPNAME of (CAR (fetch PREV of BREF))) 'SETQ) (EQ (fetch OPNAME of (CAR (fetch PREV of BDEF))) 'SETQ)) (* ;  "no OPT.COMMONBACK for different SETQ pop.") (GO EXIT))) (OPT.CHLEV 1)) ((TJUMP FJUMP NTJUMP NFJUMP) (OPT.CHLEV 1) [COND ((EQ (fetch (JUMP TAG) of (CAR BREF)) (fetch (JUMP TAG) of (CAR REF))) (SETQ FLG 'SAME] (OPT.DELTAGREF BREF)) (FN [OPT.CHLEV (SUB1 (CAR (fetch OPARG of (CAR BDEF]) ((UNBIND DUNBIND) (OPT.UBDEL BREF) [SETQ LEVEL (CAR (fetch OPARG of (CAR BREF] [SETQ FRAME (CDR (fetch OPARG of (CAR BREF]) (OPT.COMPILERERROR '(OPT.COMMONBACK shouldn't get here] (OR FLG (SETQ FLG T)) (SETQ BDEF (fetch PREV of BDEF)) (SETQ BREF (PROG1 (fetch PREV of BREF) (OPT.PRDEL BREF))) (GO M))) EXIT (COND (FLG (SETQ G (OPT.LABELNTHPR BDEF 0 LEVEL 0)) (OPT.DELTAGREF REF) (replace (JUMP TAG) of (CAR REF) with G) (NCONC1 (OPT.DEFREFS G) REF) (RETURN FLG]) (OPT.DELTAGREF [LAMBDA (REF) (* ; "Edited 10-Jul-90 23:01 by jds") (* ;; "Delete a reference to a jumnp-target tag. If the tag has no references, remove it from the list LABELS, so we don't try to optimize the code around it.") (LET [(TAG (fetch (JUMP TAG) of (CAR REF] (for X on (OPT.DEFREFS TAG) when (EQ (CADR X) REF) do (RETURN (RPLACD X (CDDR X))) finally (OPT.COMPILERERROR)) (COND ((NOT (OPT.DEFREFS TAG)) (* ;; "No remaining refs to this tag. Remove it from LABELS, so we don't try to do jump optimization with respect to it.") (SETQ CL:LABELS (DREMOVE (FASSOC TAG CL:LABELS) CL:LABELS]) (OPT.FINDEND [LAMBDA (C STOP) (* lmm%: "22-JUL-77 03:38") (PROG NIL LP (COND ((EQ C STOP) (RETURN))) (COND ((OPT.JUMPCHECK C) (RETURN C))) (COND ((SETQ C (fetch NXT of C)) (GO LP]) (OPT.RETOPT [LAMBDA NIL (* DD%: "21-FEB-83 17:17") (* optimizations involving RETURN) (PROG ((RL (OPT.RETFIND CODE)) TESTL TARGL) [MAPC RL (FUNCTION (LAMBDA (C) (COND ((OPT.RETPOP C) (SETQ ANY T))) (COND ((OPT.RETTEST C C) (* Test if C is a possible test.) (* Looking for the case where two identical sequences ending with RETURN one of  which is preceded by a conditional jump;  -  TJUMP->x stuff RETURN x%: ... stuff RETURN ...  becomes -  FJUMP->y x%: ... y%: stuff RETURN) (SETQ TESTL (CONS C TESTL))) (T (SETQ TARGL (CONS C TARGL] (OR TESTL (RETURN ANY)) [SETQ TESTL (SUBSET TESTL (FUNCTION (LAMBDA (X) (NOT (OPT.RETOPT1 X TARGL] [MAP TESTL (FUNCTION (LAMBDA (Z) (AND (LISTP Z) (OPT.RETOPT1 (CAR Z) (CDR Z] (RETURN ANY]) (OPT.RETFIND [LAMBDA (C) (* lmm%: "18-AUG-76 02:12:31") (* returns the list of all RETURN's in  the code) (PROG ((L1 C) R) LP (COND ((SETQ L1 (FMEMB OPRETURN (CDR L1))) (SETQ R (CONS L1 R)) (GO LP))) (RETURN R]) (OPT.RETPOP [LAMBDA (RET) (* rmk%: " 2-Apr-85 12:46") (* can delete any UNBIND's preceding a RETURN -  the RETURN does it automatically) (PROG (ANY TAGS VAL) LP (SELECTQ [fetch OPNAME of (CAR (SETQ RET (fetch PREV of RET] (UNBIND (SELECTQ (fetch OPNAME of VAL) ((AVAR HVAR) (* don't delete UNBIND when followed  by VAR RETURN) ) (PROGN (* delete UNBIND before RETURN) (OPT.UBDEL RET) (GO DEL)))) (POP (COND (VAL (* delete POP before VAR RETURN) (GO DEL)))) (DUNBIND (COND (VAL (* delete DUNBIND before VAR RETURN) (OPT.UBDEL RET) (GO DEL)))) (COPY (COND ((NOT (fetch OPARG of (CAR RET))) (* delete COPY before RETURN) (GO DEL)))) ((AVAR HVAR FVAR GVAR CONST) (COND ((NULL VAL) (SETQ VAL (CAR RET)) (GO LP)) (T (* VAR VAR RETURN) (GO DEL)))) (TAG (if [AND XVARFLG (SELECTQ (fetch OPNAME of VAL) (CONST NIL) (NOT (FMEMB VAL (fetch VARS of TOPFRAME] then (* if have XVARs then TAGs can't be  ambiguous) else (SETQ TAGS (CONS (CAR RET) TAGS)) (GO LP))) NIL) (RETURN ANY) DEL (OPT.PRDEL RET) DOIT (SETQ ANY T) [MAPC TAGS (FUNCTION (LAMBDA (X) (replace (TAG LEVEL) of X with NIL] (SETQ TAGS) (GO LP]) (OPT.RETOPT1 [LAMBDA (X L) (* lmm%: "13-OCT-76 18:45:46") (PROG (END Y1) (RETURN (COND ([SETQ Y1 (SOME L (FUNCTION (LAMBDA (Y) (SETQ END (OPT.RETTEST X Y] (OPT.RETMERGE X END (CAR Y1)) (SETQ ANY T]) (OPT.RETTEST [LAMBDA (TEST TARGET) (* jds "ANOTHER FAKE DATE") (PROG ((L1 TEST) (L2 TARGET) F1 F2 ONLYIFSAMEFRAME) [COND ((EQ L1 L2) (SETQ F1 (SETQ F2 T] LP (SETQ L1 (fetch PREV of L1)) (SETQ L2 (fetch PREV of L2)) L1 (COND ((type? TAG (CAR L1)) [OR F1 (SETQ F1 (fetch (TAG FRAME) of (CAR L1] (SETQ L1 (fetch PREV of L1)) (GO L1))) L2 (COND ((type? TAG (CAR L2)) [OR F2 (SETQ F2 (fetch (TAG FRAME) of (CAR L2] (SETQ L2 (fetch PREV of L2)) (GO L2))) (SELECTQ (fetch OPNAME of (CAR L1)) (RETURN (GO RET)) (JUMP (GO RETJ)) ((FJUMP TJUMP) (COND ((EQ (fetch (JUMP TAG) of (CAR L1)) (CAR (fetch NXT of TEST))) (GO RETJ)))) (AVAR (COND ((EQ (CAR L1) (CAR L2)) (SETQ ONLYIFSAMEFRAME T) (GO LP)))) (HVAR [COND ((EQ (CAR L1) (CAR L2)) (COND ((EQ (OPT.CODEFRAME L1) (OPT.CODEFRAME L2)) (COND ((EQ (OPT.CODELEV L1 0) (OPT.CODELEV L2 0)) (GO LP) (* if NOXVAR would work, we could do this.  Unfortunately, NOXVAR is ignored at this point  (replace (FRAME NOXVAR) of (OPT.CODEFRAME L1) with T)) ]) ((UNBIND DUNBIND) (COND ([AND [EQ [CAR (LISTP (fetch OPARG of (LISTP (CAR L1] (CAR (LISTP (fetch OPARG of (LISTP (CAR L2] (EQ [CDR (fetch OPARG of (LISTP (CAR L1] (CDR (fetch OPARG of (LISTP (CAR L2] (SETQ F1 (SETQ F2 T)) (* same frame) (GO LP)))) (FN (COND ((OPT.EQOP (CAR L1) (CAR L2)) (GO LP)))) (BIND (* don't merge binds) NIL) ((POP CONST FVAR GVAR SWAP) (COND ((EQ (CAR L1) (CAR L2)) (GO LP)))) ((STORE COPY) (COND ((EQUAL (CAR L1) (CAR L2)) (GO LP)))) NIL) (RETURN) RETJ [OR F1 (SETQ F1 (fetch (TAG FRAME) of (fetch (JUMP TAG) of (CAR L1] RET [COND (ONLYIFSAMEFRAME (COND ((NEQ (OR F1 (OPT.CODEFRAME L1)) (OR F2 (OPT.CODEFRAME L2))) (* OPT.RETTEST fail because not same  frame) (RETURN] (RETURN L1]) (OPT.RETMERGE [LAMBDA (TEST END TARGET) (* lmm "13-OCT-78 21:25") (PROG ((L1 TEST) (L2 TARGET) G VEQ FEQ LEV) [COND ([AND (SETQ LEV (OPT.CODEFRAME (fetch PREV of TEST))) (EQ LEV (OPT.CODEFRAME (fetch PREV of TARGET] (SETQ FEQ T) (COND ((AND (SETQ LEV (OPT.CODELEV (fetch PREV of TEST) 0)) (EQ LEV (OPT.CODELEV (fetch PREV of TARGET) 0))) (SETQ VEQ T] LP (COND ((EQ L1 END) (SELECTQ (fetch OPNAME of (CAR L1)) ((TJUMP FJUMP) [COND [[NOT (type? TAG (SETQ G (CAR L2] (SETQ G (create TAG)) [COND (FEQ [replace (TAG FRAME) of G with (fetch (TAG FRAME) of (fetch (JUMP TAG) of (CAR L1] (COND (VEQ (replace (TAG LEVEL) of G with (fetch (TAG LEVEL) of (fetch (JUMP TAG) of (CAR L1] (OPT.SETDEFREFS G (LIST (OPT.PRATTACH G L2] (T (OR VEQ (replace (TAG LEVEL) of G with NIL)) (OR FEQ (replace (TAG FRAME) of G with NIL] (FRPLACA L1 (OPT.NOTJUMP (CAR L1))) [DREMOVE L1 (OPT.DEFREFS (fetch (JUMP TAG) of (CAR L1] (replace (JUMP TAG) of (CAR L1) with G) (NCONC1 (OPT.DEFREFS G) L1)) ((JUMP RETURN)) (OPT.COMPILERERROR)) (RETURN))) (COND ((type? TAG (CAR L1)) (OR VEQ (replace (TAG LEVEL) of (CAR L1) with NIL)) (OR FEQ (replace (TAG FRAME) of (CAR L1) with NIL)) (RPLACA (OPT.DEFREFS (CAR L1)) (OPT.PRATTACH (CAR L1) L2)) (SETQ L1 (PROG1 (fetch PREV of L1) (OPT.PRDEL L1))) (GO LP))) L2 (COND ((type? TAG (CAR L2)) (OR VEQ (replace (TAG LEVEL) of (CAR L2) with NIL)) (OR FEQ (replace (TAG FRAME) of (CAR L2) with NIL)) (SETQ L2 (fetch PREV of L2)) (GO L2))) (SELECTQ (fetch OPNAME of (CAR L1)) ((UNBIND DUNBIND) (OPT.UBDEL L1)) ((TJUMP NTJUMP FJUMP NFJUMP JUMP BIND ERRORSET) (OPT.COMPILERERROR)) NIL) (SETQ L1 (PROG1 (fetch PREV of L1) (OPT.PRDEL L1))) (SETQ L2 (fetch PREV of L2)) (GO LP]) (OPT.CODELEV [LAMBDA (CD LEV) (* jds "THIS IS A FAKE DATE") (PROG NIL (RETURN (IPLUS (SELECTQ (fetch OPNAME of (CAR CD)) (TAG (OR (fetch (TAG LEVEL) of (CAR CD)) (RETURN))) ((NTJUMP NFJUMP TJUMP FJUMP) (RETURN (OPT.CODELEV (fetch PREV of CD) (SUB1 LEV)))) ((AVAR HVAR COPY CONST FVAR GVAR) (RETURN (OPT.CODELEV (fetch PREV of CD) (ADD1 LEV)))) (FN [RETURN (OPT.CODELEV (fetch PREV of CD) (ADD1 (IDIFFERENCE LEV (CAR (fetch OPARG of (CAR CD]) (POP (RETURN (OPT.CODELEV (fetch PREV of CD) (SUB1 LEV)))) ((BIND ERRORSET) 0) (DUNBIND [fetch (FRAME LEVEL) of (CDR (fetch OPARG of (CAR CD]) (UNBIND (ADD1 (OR [fetch (FRAME LEVEL) of (CDR (fetch OPARG of (CAR CD] (RETURN)))) ((SETQ STORE SWAP) (RETURN (OPT.CODELEV (fetch PREV of CD) LEV))) (NIL (OPT.CCHECK (NOT (CDR CD))) 0) (OPT.COMPILERERROR (CAR CD))) LEV]) (OPT.CODEFRAME [LAMBDA (CD) (* rmk%: " 2-Apr-85 12:47") (SELECTQ (fetch OPNAME of (CAR CD)) (TAG (OR (fetch (TAG FRAME) of (CAR CD)) (OPT.CODEFRAME (fetch PREV of CD)))) ((NTJUMP NFJUMP TJUMP FJUMP) (* can't assume that code of jumped-to is same, because return-merging might  have messed it up) (OPT.CODEFRAME (fetch PREV of CD))) ((BIND ERRORSET) (CDR (fetch OPARG of (CAR CD)))) ((UNBIND DUNBIND) [fetch PARENT of (CDR (fetch OPARG of (CAR CD]) (NIL TOPFRAME) ((JUMP RETURN) NIL) (OPT.CODEFRAME (fetch PREV of CD]) (OPT.DEFREFS [LAMBDA (D) (* ; "Edited 10-Jul-90 23:02 by jds") (* ;; "Given a jump-target tag, return a list of the references to that tag.") (CDR (FASSOC D CL:LABELS]) (OPT.SETDEFREFS [LAMBDA (D V) (* lmm%: "22-JUL-77 15:58") (FRPLACD [OR (FASSOC D CL:LABELS) (CAR (SETQ CL:LABELS (CONS (CONS D) CL:LABELS] V]) ) (DEFINEQ (OPT.FRAMEOPT [LAMBDA (TRYLOCAL TRYMERGE TRYXVAR) (* lmm "16-DEC-81 17:05") (PROG (ANY) [COND (TRYLOCAL (MAPC FRAMES (FUNCTION (LAMBDA (X) (AND (OPT.FRAMELOCAL (CAR X)) (SETQ ANY T] [MAPC FRAMES (FUNCTION (LAMBDA (F) (AND (CADR F) (OPT.FRAMEVAR F) (SETQ ANY T] [COND (TRYMERGE (MAPC FRAMES (FUNCTION (LAMBDA (F) (AND (CADR F) (OPT.FRAMEMERGE F) (SETQ ANY T] [SETQ FRAMES (SUBSET FRAMES (FUNCTION (LAMBDA (F) (NOT (AND (CADR F) (OPT.FRAMEDEL F TRYXVAR) (SETQ ANY T] (RETURN ANY]) (OPT.FRAMEMERGE [LAMBDA (F) (* lmm "29-Dec-84 10:35") (AND MERGEFRAMEFLG (PROG ((FR (CAR F)) VAR VARS P) (COND ((AND (SETQ VARS (fetch VARS of FR)) (NULL (CDR (FNTH VARS MERGEFRAMEMAX))) (SETQ P (fetch PARENT of FR)) (OPT.MERGEFRAMEP FR P VARS)) [PROG ((N (fetch NVALS of FR)) (V VARS) (CD (fetch PREV of (CADR F))) P2) PLP (COND ((AND (SETQ P2 (fetch PARENT of P)) (OPT.MERGEFRAMEP FR P2 VARS)) (SETQ P P2) (GO PLP))) (replace VARS of P with (NCONC (fetch VARS of P) VARS)) (replace VARS of FR with NIL) (replace NNILS of P with (IPLUS (fetch NNILS of P) (fetch NNILS of FR) (fetch NVALS of FR))) (replace NNILS of FR with (replace NVALS of FR with 0)) LP (COND (V (SETQ VAR (create OP OPNAME _ 'SETQ OPARG _ (CAR V))) [COND ((IGREATERP N 0) (OPT.PRATTACH OPPOP (OPT.PRATTACH VAR CD))) (T [COND ((ZEROP N) (SETQ CD (OPT.PRATTACH OPNIL CD] (OR (OPT.NONILVAR (CAR V) CD P) (SETQ CD (OPT.PRATTACH VAR CD] (SETQ N (SUB1 N)) (SETQ V (CDR V)) (GO LP))) (COND ((MINUSP N) (OPT.PRATTACH OPPOP CD] (RETURN T]) (OPT.NONILVAR [LAMBDA (V CD FR) (* lmm " 8-JAN-82 09:06") (* used by OPT.FRAMEMERGE) (PROG NIL (RETURN (AND (SELECTQ (fetch OPNAME of (CAR CD)) ((CONST POP COPY AVAR HVAR FVAR GVAR TJUMP FJUMP NTJUMP NFJUMP SETQ STORE SWAP) T) (NIL NIL) (FN (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD))) 'FREEVARS)) (BIND (COND ([EQ FR (CDR (fetch OPARG of (CAR CD] (RETURN T)) (T T))) ((TAG RETURN) NIL) ((UNBIND DUNBIND ERRORSET) T) NIL) (OPT.NONILVAR V (CDR CD) FR]) (OPT.MERGEFRAMEP [LAMBDA (FR PARENT VARS) (* lmm "29-Dec-84 10:31") (AND (FMEMB (fetch FRAMETYPE of PARENT) MERGEFRAMETYPES) (COND [(OASSOC 'AVAR VARS) (AND (OPT.CLEANFRAME PARENT FR) (PROG NIL [for V in VARS do (if (FMEMB (fetch OPARG of V) SYSSPECVARS) then (GO BAD)) [for F in FRAMES when (NEQ (CAR F) FR) do (for V2 in (fetch VARS of (CAR F)) do (COND ((EQ (fetch OPARG of V2) (fetch OPARG of V)) (GO BAD] (for V2 in FREEVARS do (COND ((EQ (fetch OPARG of V2) (fetch OPARG of V)) (GO BAD] (RETURN T) BAD (RETURN] (T (EQ MERGEFRAMEFLG T]) (OPT.FRAMELOCAL [LAMBDA (F) (* lmm "29-Dec-84 20:45") (PROG (VARS ANY) (COND ((AND (OASSOC 'AVAR (SETQ VARS (fetch (FRAME VARS) of F))) (OPT.CLEANFRAME F)) (* make vars local when no external  calls) (for X in VARS when (AND (EQ (fetch OPNAME of X) 'AVAR) (NOT (FMEMB (fetch OPARG of X) SYSSPECVARS))) do (replace OPNAME of X with 'HVAR) (SETQ ANY T)) (RETURN ANY]) (OPT.CLEANFRAME [LAMBDA (FRAME AVOIDING) (* lmm%: " 9-NOV-76 16:20:20") (AND (NOT (fetch EXTCALL of FRAME)) (for F in FRAMES when (AND (EQ (fetch PARENT of (CAR F)) FRAME) (NEQ (CAR F) AVOIDING)) always (OPT.CLEANFRAME (CAR F) AVOIDING]) (OPT.FRAMEDEL [LAMBDA (F TRYXVAR) (* lmm "13-Jul-84 21:18") (PROG (VARS (FRM (CAR F)) PARENT OP FLV TMP DOXVAR) (SELECTQ (fetch FRAMETYPE of FRM) ((NIL ERRORSET) (RETURN)) NIL) (SETQ VARS (fetch VARS of FRM)) (SETQ FLV (fetch (FRAME LEVEL) of FRM)) (SETQ DOXVAR NIL) (COND ([AND [NOT (SOME (CDDR F) (FUNCTION (LAMBDA (X) (AND (EQ (fetch OPNAME of (CAR X)) 'UNBIND) (IGREATERP (CAR (fetch OPARG of (CAR X))) 1] (OR (NULL VARS) (AND (NOT (OASSOC 'AVAR VARS)) (OR (OPT.DELETEFRAMECHECK VARS F) (AND TRYXVAR (NOT (fetch NOXVAR of FRM)) (SETQ DOXVAR T] (* frame with no specvars, no UNBIND's with LEVEL gt 1) (OR (SETQ PARENT (fetch PARENT of FRM)) (OPT.COMPILERERROR)) [COND (DOXVAR (add FLV (fetch NNILS of FRM) (fetch NVALS of FRM] [for VR on VARS do (for CD on CODE do (COND [(AND (EQ (fetch OPARG of (CAR CD)) (CAR VR)) (EQ (fetch OPNAME of (CAR CD)) 'SETQ)) (COND [DOXVAR (OPT.CCHECK (EQ FRM (OPT.CODEFRAME CD))) (RPLACA CD (create OP OPNAME _ 'STORE OPARG _ (OR (OPT.CODELEV CD (LENGTH (CDR VR))) (OPT.COMPILERERROR] (T (OPT.PRDEL CD) (* delete SETQ in OPT.FRAMEDEL) ] ((AND DOXVAR (EQ (CAR CD) (CAR VR))) (OPT.CCHECK (EQ (OPT.CODEFRAME CD) FRM)) (RPLACA CD (COND ([ZEROP (SETQ TMP (OPT.CODELEV (fetch PREV of CD) (LENGTH (CDR VR] OPCOPY) (T (create OP OPNAME _ 'COPY OPARG _ TMP] [MAPC CL:LABELS (FUNCTION (LAMBDA (X) (COND ((EQ (fetch (TAG FRAME) of (CAR X)) FRM) (replace (TAG FRAME) of (CAR X) with PARENT) (AND (fetch (TAG LEVEL) of (CAR X)) FLV (replace (TAG LEVEL) of (CAR X) with (IPLUS (fetch (TAG LEVEL) of (CAR X)) FLV] [PROG ((CD (CADR F))) (* delete the bind and all of the var references after) [MAPC (CONS NIL (AND (NOT DOXVAR) VARS)) (FUNCTION (LAMBDA NIL (SETQ CD (PROG1 (fetch NXT of CD) (OPT.PRDEL CD] (FRPTQ (fetch NNILS of FRM) (OPT.PRATTACH OPNIL (fetch PREV of CD] (COND ((fetch EXTCALL of FRM) (replace EXTCALL of PARENT with T))) [MAPC (CDDR F) (FUNCTION (LAMBDA (CD) (* change DUNBIND to POP of LEVEL) (SELECTQ [PROG1 (fetch OPNAME of (SETQ OP (CAR CD))) (SETQ CD (PROG1 (fetch PREV of CD) (OPT.PRDEL CD] (UNBIND [COND [DOXVAR (COND ([NOT (ZEROP (SETQ TMP (IPLUS (CAR (fetch OPARG of OP)) (LENGTH VARS) -1] (SETQ CD (OPT.PRATTACH (create OP OPNAME _ 'STORE OPARG _ TMP) CD)) (FRPTQ TMP (OPT.PRATTACH OPPOP CD] (T (OPT.CCHECK (EQ (CAR (fetch OPARG of OP)) 1]) (DUNBIND (FRPTQ [COND (DOXVAR (IPLUS (CAR (fetch OPARG of OP)) (fetch NVALS of FRM) (fetch NNILS of FRM))) (T (CAR (fetch OPARG of OP] (OPT.PRATTACH OPPOP CD))) (OPT.COMPILERERROR] [MAPC FRAMES (FUNCTION (LAMBDA (F2) (COND ((EQ (fetch PARENT of (CAR F2)) FRM) (replace PARENT of (CAR F2) with PARENT) (replace (FRAME LEVEL) of (CAR F2) with (AND FLV (SETQ TMP (fetch (FRAME LEVEL) of (CAR F2))) (IPLUS TMP FLV] (RETURN T]) (OPT.FRAMEVAR [LAMBDA (F) (* lmm "13-Jul-84 21:18") (PROG (VARS CD (FR (CAR F)) VAL ANY NNILS NVALS) [SETQ VARS (REVERSE (OR (fetch VARS of FR) (RETURN] (SETQ NNILS (fetch NNILS of FR)) (SETQ NVALS (fetch NVALS of FR)) [for V on VARS as I from NNILS to 0 by -1 when (NEQ (fetch OPNAME of (CAR V)) 'AVAR) do (COND ((NOT (SETQ CD (FMEMB (CAR V) CODE))) [COND ((ZEROP I) (SETQ I 1) (OPT.PRATTACH OPPOP (fetch PREV of (CADR F))) (SETQ NVALS (SUB1 NVALS))) (T (SETQ NNILS (SUB1 NNILS] (* local var bound but not used) (PROG ((CD CODE)) LP (COND ((NOT CD) (RETURN))) (* delete all SETQ's) (COND ((AND (EQ (fetch OPARG of (CAR CD)) (CAR V)) (EQ (fetch OPNAME of (CAR CD)) 'SETQ)) (* local var set but never used) (OPT.PRDEL CD))) (SETQ CD (fetch PREV of CD)) (GO LP)) (RPLACA V NIL) (SETQ ANY T)) ([NOTANY CODE (FUNCTION (LAMBDA (X) (AND (EQ (fetch OPNAME of X) 'SETQ) (EQ (fetch OPARG of X) (CAR V] (COND ([SETQ VAL (COND ((NEQ I 0) (* NIL var never set) (SETQ NNILS (SUB1 NNILS)) OPNIL) ((AND (EQ [fetch OPNAME of (SETQ VAL (CAR (fetch PREV of (CADR F] 'CONST) (APPLY* EQCONSTFN (fetch OPARG of VAL))) (SETQ I 1) (SETQ NVALS (SUB1 NVALS)) (* delete this var, can try next) (* var bound to CONST and never set) (PROG1 (CAR (fetch PREV of (CADR F))) (OPT.PRDEL (fetch PREV of (CADR F] (do (FRPLACA CD VAL) repeatwhile (SETQ CD (FMEMB (CAR V) CD))) (FRPLACA V NIL) (SETQ ANY T] (COND (ANY [replace VARS of FR with (OPT.DREV (SUBSET VARS (FUNCTION (LAMBDA (X) X] (replace NNILS of FR with NNILS) (replace NVALS of FR with NVALS))) (RETURN ANY]) (OPT.DELETEFRAMECHECK [LAMBDA (VARS F) (* lmm%: "22-JUL-77 02:58") (PROG ((CD (OPT.ONLYMEMB (CAR VARS) CODE))) (OR (AND CD (EQ (fetch PREV of CD) (CADR F))) (RETURN)) LP (SETQ VARS (CDR VARS)) (SETQ CD (fetch NXT of CD)) (COND ((NULL VARS) (RETURN T))) (COND ((EQ (OPT.ONLYMEMB (CAR VARS) CODE) CD) (GO LP]) (OPT.ONLYMEMB [LAMBDA (X Y) (* lmm%: " 6-OCT-76 15:06:48") (AND (SETQ Y (FMEMB X Y)) (NOT (FMEMB X (CDR Y))) Y]) ) (RPAQQ MERGEFRAMETYPES (PROG LAMBDA MAP)) (RPAQQ OPTIMIZATIONSOFF NIL) (DEFINEQ (OPT.SKIPPUSH [LAMBDA (CD N VL LEVOPFLG) (* lmm "19-JAN-82 22:16") (OR N (SETQ N 1)) (COND ((ILESSP N 0) NIL) ((ZEROP N) CD) (T (SELECTQ (fetch OPNAME of (CAR CD)) ((AVAR HVAR FVAR GVAR CONST) (OPT.SKIPPUSH (fetch PREV of CD) (SUB1 N) VL LEVOPFLG)) (COPY (AND (NOT (fetch OPARG of (CAR CD))) (OPT.SKIPPUSH (fetch PREV of CD) (SUB1 N) VL LEVOPFLG))) (SWAP (AND (IGEQ N 2) (OPT.SKIPPUSH (fetch PREV of CD) N VL LEVOPFLG))) (POP (OPT.SKIPPUSH (fetch PREV of CD) (ADD1 N) VL LEVOPFLG)) ((FJUMP TJUMP NFJUMP NTJUMP) (AND NEWOPTFLG (NOT LEVOPFLG) (OPT.SKIPPUSH (fetch PREV of CD) (ADD1 N) VL LEVOPFLG))) (FN (COND ((OR (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD))) 'NOSIDE) (AND NEWOPTFLG (SELECTQ (fetch OPNAME of (CAR VL)) ((CONST HVAR) T) ((FVAR AVAR GVAR) (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR CD))) 'FREEVARS)) NIL))) (OPT.SKIPPUSH (fetch PREV of CD) [SUB1 (IPLUS N (CAR (fetch OPARG of (CAR CD] VL LEVOPFLG)))) (SETQ (COND ([AND NEWOPTFLG VL (NEQ (CAR VL) (fetch OPARG of (CAR CD] (OPT.SKIPPUSH (fetch PREV of CD) N VL LEVOPFLG)))) NIL]) (OPT.DELCODE [LAMBDA (CD) (* ; "Edited 10-Jul-90 23:45 by jds") (* ;; "Remove (unreachable) code from the code stream.") (PROG (X FLG) LP (SELECTQ (fetch OPNAME of (SETQ X (CAR CD))) (NIL (RETURN FLG)) (TAG (RETURN FLG)) ((BIND ERRORSET) (RPLACA (CDR (FASSOC (CDR (fetch OPARG of X)) FRAMES)) NIL) (for LB in CL:LABELS when (EQ (fetch (TAG FRAME) of (CAR LB)) (CDR (fetch OPARG of X))) do (MAPC (CDR LB) (FUNCTION OPT.PRDEL)))) ((UNBIND DUNBIND) (DREMOVE CD (FASSOC (CDR (fetch OPARG of X)) FRAMES))) ((JUMP FJUMP TJUMP NFJUMP NTJUMP ERRORSET) (* ; "delete unreachable jump") (OPT.DELTAGREF CD) (SETQ FLG T)) (* ; "delete unreachable code")) (SETQ ANY T) (SETQ CD (PROG1 (fetch NXT of CD) (OPT.PRDEL CD))) (GO LP]) (OPT.PRATTACH [LAMBDA (ITEM BEFORE) (* lmm%: "22-JUL-77 02:58") (PROG ((AFTER (fetch NXT of BEFORE)) (NEW (CONS))) (replace NXT of NEW with AFTER) (replace PREV of NEW with BEFORE) (FRPLACA NEW ITEM) (replace NXT of BEFORE with NEW) (AND AFTER (replace PREV of AFTER with NEW)) (RETURN NEW]) (OPT.JUMPCOPYTEST [LAMBDA (VL CDFROM) (* lmm "15-JAN-82 18:08") (* Where can a COPY be inserted such that VL would be on the stack -  either returns the code list or NIL -  used by transformation -  var TJUMP->l var ... l%: var -  => var COPY TJUMP->l2 ... l%: var l2%:) (COND ((OPT.EQVALUE CDFROM VL) CDFROM) ((AND (OPT.CALLP (CAR CDFROM)) (OR (EQ (fetch OPNAME of (CAR VL)) 'HVAR) (COMP.CLEANFNP (CDR (fetch OPARG of (CAR CDFROM))) 'FREEVARS)) (SETQ CDFROM (OPT.SKIPPUSH (fetch PREV of CDFROM) [SUB1 (CAR (fetch OPARG of (CAR CDFROM] VL T))) (OPT.JUMPCOPYTEST VL CDFROM]) (OPT.EQOP [LAMBDA (OP1 OP2) (* lmm " 8-JAN-82 09:04") (OR (EQ OP1 OP2) (AND (EQ (fetch OPNAME of OP1) (fetch OPNAME of OP2)) (SELECTQ (fetch OPNAME of OP1) ((FVAR GVAR CONST COPY STORE) (EQ (fetch OPARG of OP1) (fetch OPARG of OP2))) ((POP RETURN SWAP) [OPT.CCHECK (AND (NOT (fetch OPARG of OP1)) (NOT (fetch OPARG of OP2] T) (FN (EQUAL OP1 OP2)) ((JUMP TJUMP NTJUMP FJUMP NFJUMP BIND ERRORSET UNBIND DUNBIND) [AND (EQ (CAR (fetch OPARG of OP1)) (CAR (fetch OPARG of OP2))) (EQ (CDR (fetch OPARG of OP1)) (CDR (fetch OPARG of OP2]) (SETQ (OPT.EQOP (fetch OPARG of OP1) (fetch OPARG of OP2))) NIL]) (OPT.EQVALUE [LAMBDA (CD V) (* lmm "19-JAN-82 22:25") (PROG NIL LP (RETURN (SELECTQ (fetch OPNAME of (CAR CD)) (COPY (COND ((NULL (fetch OPARG of (CAR CD))) (SETQ CD (fetch PREV of CD)) (GO LP)))) (SETQ (COND ((EQ (fetch OPARG of (CAR CD)) (CAR V))) (T (SETQ CD (fetch PREV of CD)) (GO LP)))) ((HVAR AVAR FVAR GVAR CONST) (EQ (CAR CD) (CAR V))) ((POP FJUMP TJUMP NFJUMP NTJUMP SWAP) (COND ((SETQ CD (OPT.SKIPPUSH (fetch PREV of CD) 1 V)) (GO LP)))) NIL]) (OPT.DELCOPYFN [LAMBDA (P X) (* lmm "18-JAN-82 13:17") (while (AND (OPT.CALLP (CAR P) NIL 1) (OPT.EQOP (CAR P) (CAR (fetch NXT of X))) (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR P))) 'NOSIDE) (for Z_P by (fetch PREV of Z) while (AND Z (NEQ Z X)) always (SELECTQ (fetch OPNAME of (CAR Z)) (FN (COMP.CLEANFNOP (CDR (fetch OPARG of (CAR Z))) 'NOSIDE)) ((FVAR AVAR HVAR GVAR SETQ) (* SETQ is OK since we have already guaranteed that the value skipped is not  modified by intervening setqs) T) NIL))) do [SETQ P (fetch NXT of (PROG1 (fetch PREV of P) (OPT.PRDEL P] (SETQ X (fetch NXT of X))) X]) ) (DEFINEQ (OPT.DEADSETQP [LAMBDA (VAR CD) (* lmm "13-Jul-84 21:18") (DECLARE (SPECVARS ICNT)) (SELECTQ (fetch OPNAME of VAR) ((AVAR HVAR) (PROG (TAGS (ICNT 50)) (* ICNT is used to limit the nmber of instructions looked at past the setq.) (* look for dead SETQ) (RETURN (OPT.DS1 VAR CD)))) NIL]) (OPT.DS1 [LAMBDA (VAR CD) (* lmm "13-Jul-84 21:18") (* test if VAR is used in CD -- TAGS is a list of tags already visited) (PROG (A) LP [SELECTQ (fetch OPNAME of (SETQ A (CAR CD))) (SETQ (AND (EQ (fetch OPARG of A) VAR) (RETURN T))) (FN (AND (EQ (fetch OPNAME of VAR) 'AVAR) (NOT (COMP.CLEANFNOP (CDR (fetch OPARG of A)) 'FREEVARS)) (RETURN))) ((UNBIND DUNBIND) (COND ([FMEMB VAR (fetch (FRAME VARS) of (CDR (fetch OPARG of A] (RETURN T)))) (RETURN [RETURN (AND (SETQ A (OPT.CODEFRAME (fetch PREV of CD))) (never (EQ (fetch FRAMETYPE of A) 'ERRORSET) repeatwhile (SETQ A (fetch PARENT of A]) (JUMP (OR [SETQ CD (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A] (RETURN)) (GO LP)) ((TJUMP FJUMP NTJUMP NFJUMP ERRORSET) (OR [OPT.DS1 VAR (CAR (OPT.DEFREFS (fetch (JUMP TAG) of A] (RETURN))) (TAG [COND ((FMEMB A TAGS) (RETURN T)) (T (SETQ TAGS (CONS A TAGS]) (COND ((EQ A VAR) (RETURN] (OR (SETQ CD (fetch NXT of CD)) (OPT.COMPILERERROR)) NX [COND ((ZEROP ICNT) (* DEADSETP gives up) (RETURN)) (T (SETQ ICNT (SUB1 ICNT] (GO LP]) ) (RPAQ? *BC-MACRO-ENVIRONMENT* (COMPILER::MAKE-ENV)) (RPAQ? *BYTECOMPILER-OPTIMIZE-MACROLET* T) (DEFMACRO CL:MACROLET (CL::MACRODEFS &BODY CL::BODY &ENVIRONMENT CL::ENV) (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*)) (* ;; "This macro for the old interpreter and compiler only. The new interpreter has a special-form definition. When the new compiler is expanding, we simply return a disguised version of the form.") (IF (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*) THEN (LET ((CL::NEW-ENV (COMPILER::MAKE-CHILD-ENV CL::ENV))) (DECLARE (CL:SPECIAL *BC-MACRO-ENVIRONMENT*)) [FOR CL::FN IN CL::MACRODEFS DO (COMPILER::ENV-BIND-FUNCTION CL::NEW-ENV (CAR CL::FN) :MACRO (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO CL::FN] (CL:SETQ *BC-MACRO-ENVIRONMENT* CL::NEW-ENV) (CONS 'CL:LOCALLY CL::BODY)) ELSEIF (TYPEP CL::ENV 'COMPILER:ENV) THEN `(SI::%%MACROLET ,CL::MACRODEFS ,@CL::BODY) ELSE (LET* ((CL::NEW-ENV (\MAKE-CHILD-ENVIRONMENT CL::ENV)) (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) (FOR CL::FN IN CL::MACRODEFS DO (CL:SETQ CL::FUNCTIONS (LIST* (CAR CL::FN) [CONS :MACRO `(CL:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT ) (CL:BLOCK ,(CAR CL::FN) ,(PARSE-DEFMACRO (CADR CL::FN) 'SI::$$MACRO-FORM (CDDR CL::FN) (CAR CL::FN) NIL :ENVIRONMENT 'SI::$$MACRO-ENVIRONMENT))] CL::FUNCTIONS))) (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) CL::FUNCTIONS) (WALK-FORM (CONS 'CL:LOCALLY CL::BODY) :ENVIRONMENT CL::NEW-ENV)))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *BYTECOMPILER-IS-EXPANDING* *BC-MACRO-ENVIRONMENT*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS CODE LEVEL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS CL:LABELS PASS ANY CODE FRAME FRAMES) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MERGEFRAMEMAX MERGEFRAMEFLG MERGEFRAMETYPES *BYTECOMPILER-OPTIMIZE-MACROLET*) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS VARS ANY FRAME) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS ICNT TAG) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS FRAME LEVEL ANY) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS FRAME LEVEL ANY) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS TAGS ANY) ) ) (* ; "CONSISTENCY CHECKS") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS OPT.CCHECK MACRO [ARGS (COND (COMPILECOMPILERCHECKS (LIST 'AND (LIST 'NOT (CAR ARGS)) (LIST 'OPT.COMPILERERROR (CADR ARGS]) ) (RPAQQ COMPILECOMPILERCHECKS NIL) ) (DEFINEQ (OPT.COMPILERERROR [LAMBDA (MESS1 MESS2) (* lmm " 1-MAR-78 02:55") (LISPXPRIN1 "Compiler error " T) (HELP MESS1 MESS2]) (OPT.OPTCHECK [LAMBDA NIL (* lmm "14-MAR-81 11:03") (* set up code list as doubly linked list, scan for tags) (PROG ((CD CODE) P B) LPC (COND ((NULL CD) [for X in CL:LABELS do (COND ((CDR X) [OR (FMEMB (CAR X) CODE) (OPT.COMPILERERROR (CAR X) '(not in code] [MAPC (CDR X) (FUNCTION (LAMBDA (Y) (OR (TAILP Y CODE) (OPT.COMPILERERROR Y '(NOT CODE TAIL] [OR (EQ (CAR (CADR X)) (CAR X)) (OPT.COMPILERERROR X '(TAG wrong] (EVERY (CDDR X) (FUNCTION (LAMBDA (Y) (OR (EQ (fetch (JUMP TAG) of (CAR Y)) (CAR X)) (OPT.COMPILERERROR X '(TAG wrong] [for X in FRAMES do (COND [(EQ (CAR X) TOPFRAME) (AND (CDR X) (OPT.COMPILERERROR (CONS 'TOPFRAME X] (T [for Y in (CDR X) do (OR (TAILP Y CODE) (OPT.COMPILERERROR (LIST '(NOT IN CODE) Y X))) (OR (EQ (CDR (fetch OPARG of (CAR Y))) (CAR X)) (OPT.COMPILERERROR (LIST '(WRONG FRAME) Y X] (OR (FASSOC (fetch PARENT of (CAR X)) FRAMES) (OPT.COMPILERERROR '(PARENT NOT FRAME) X] (RETURN T))) (SELECTQ (fetch OPNAME of (CAR CD)) (TAG (OR (SETQ B (FASSOC (CAR CD) CL:LABELS)) (OPT.COMPILERERROR)) (OR (EQ (CAR (CDR B)) CD) (OPT.COMPILERERROR)) (OR (OR (NULL (fetch (TAG FRAME) of (CAR CD))) (FASSOC (fetch (TAG FRAME) of (CAR CD)) FRAMES)) (OPT.COMPILERERROR))) ((BIND ERRORSET) (OR (EQ (CADR (FASSOC (CDR (fetch OPARG of (CAR CD))) FRAMES)) CD) (OPT.COMPILERERROR))) ((UNBIND DUNBIND) (OR (FMEMB CD (CDDR (FASSOC (CDR (fetch OPARG of (CAR CD))) FRAMES))) (OPT.COMPILERERROR))) ((JUMP TJUMP FJUMP NTJUMP NFJUMP) (OR (SETQ B (FASSOC (fetch (JUMP TAG) of (CAR CD)) CL:LABELS)) (OPT.COMPILERERROR)) [OR (MEMB CD B) (OPT.COMPILERERROR CD '(NOT IN JUMP LIST]) NIL) (SETQ B (CDR CD)) (OR (AND (EQ (fetch PREV of CD) B) (EQ (fetch NXT of CD) P)) (OPT.COMPILERERROR)) (SETQ P CD) (SETQ CD B) (GO LPC]) (OPT.CCHECK [LAMBDA (X) (* lmm "14-MAR-81 09:18") (OR X (OPT.COMPILERERROR]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ALAMS BYTE.EXT BYTEASSEMFN BYTECOMPFLG COMPILERMACROPROPS CIA CLEANFNLIST COMP.SCRATCH COMPILETYPELST COMPILEUSERFN COMPSTATLST COMPSTATS CONDITIONALS CONST.FNS CONSTOPS DONOTHING FILERDTBL FNA FORSHALLOW FRA HEADERBYTES HOKEYDEFPROP LAMBDANOBIND LAMS LBA LEVELARRAY LINKEDFNS LOADTIMECONSTANT MAXBNILS MAXBVALS MCONSTOPS MERGEFRAMEFLG MERGEFRAMEMAX MERGEFRAMETYPES MOPARRAY MOPCODES NODARR NOSTATSFLG NUMBERFNS OPCOPY OPNIL OPPOP OPRETURN PRA SELECTQFMEMB SELECTVARTYPES STATAR STATMAX STATN SYSSPECVARS UNIQUE#ARRAY VCA VCONDITIONALS VREFFRA COUTFILE XVARFLG MERGEFRAMEFLG OPTIMIZATIONSOFF NOFREEVARSFNS EQCONSTFN NEWOPTFLG) ) (CL:PROCLAIM '(CL:SPECIAL COMPVARMACROHASH)) (DECLARE%: DONTCOPY EVAL@COMPILE (DECLARE%: EVAL@COMPILE (RECORD CODELST (OP . PREV) [ACCESSFNS CODELST ((NXT (GETHASH DATUM PRA) (PUTHASH DATUM NEWVALUE PRA]) ) (PUTPROPS OASSOC MACRO ((X Y) (FASSOC X Y))) (DECLARE%: EVAL@COMPILE (RECORD OP (OPNAME . OPARG)) (RECORD JUMP (OPNAME TAG . JT) (* kind of OP) ) (TYPERECORD TAG (LBNO . LEVEL) (* kind of OP) LBNO _ (SETQ LBCNT (ADD1 LBCNT)) [ACCESSFNS TAG ((FRAME (GETHASH DATUM FRA) (PUTHASH DATUM NEWVALUE FRA)) (JD (GETHASH DATUM LBA) (PUTHASH DATUM NEWVALUE LBA]) (RECORD VAR (COMP.VARTYPE . VARNAME) (* A particular kind of OP) ) ) (DECLARE%: EVAL@COMPILE (RECORD FRAME (FRAMETYPE (NNILS VARS . DECLS) LEVEL (BINDLST NVALS EXTCALL . CPIOK) . PROGLABELS) (* FRAMETYPE is one of PROG LAMBDA ERRORSET MAP NIL -  VARS are variables bound, NNILS are %# which are bound to NIL -  LEVEL is %# of things on stack between this and next higher frame) (ACCESSFNS FRAME ((PARENT (GETHASH DATUM FRA) (PUTHASH DATUM NEWVALUE FRA)) (VREFFROM (GETHASH DATUM VREFFRA) (PUTHASH DATUM NEWVALUE VREFFRA)) (NODBIND (GETHASH DATUM NODARR) (PUTHASH DATUM NEWVALUE NODARR)) (PRIMARYRETURN (GETHASH DATUM BCINFO) (PUTHASH DATUM NEWVALUE BCINFO))) (* PARENT is next higher enclosing  frame -  shares hash table with TAG.FRAME) ) (RECORD CPIOK NOXVAR (* Share the CPIOK field used by the compiler pass 1 and the NOXVAR field used  by the maxc assembler) ) NNILS _ 0) (RECORD COMINFO (COMTYPE TOPFRAME CODE ARGS)) (ACCESSFNS COMP (CLEAR (PROGN (OPT.INITHASH FRA) (OPT.INITHASH LBA) (OPT.INITHASH PRA) (OPT.INITHASH VREFFRA) (OPT.INITHASH NODARR) (OPT.INITHASH BCINFO)))) (RECORD JD (JPT (JMIN . JSN) JU . JML) (* JPT is NIL (for tags) or a pointer into ACODE  (for jumps)%. JMIN is the lowest possible location for the instruction or tag.  JU is the cumulative uncertainty (for tags) or the length uncertainty  (for jumps)%. JML is the minimum length  (for jumps)%. JSN is a serial number (the original JMIN) used to decide whether  a jump goes forward or backward.) ) (RECORD BLOCKSTATUS (BLOCKCONTEXT BLOCKTAG BLOCKEND)) ) ) (DECLARE%: EVAL@COMPILE (PUTPROPS THETYPE MACRO [(THETYPE . FORMS) ([LAMBDA (THEVALUE) (DECLARE (LOCALVARS THEVALUE) (TYPE THETYPE THEVALUE)) THEVALUE] . FORMS]) ) (PUTPROPS BYTECOMPILER FILETYPE CL:COMPILE-FILE) (PUTPROPS BYTECOMPILER MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML OPT.INITHASH) (ADDTOVAR LAMA ) ) (PUTPROPS BYTECOMPILER COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1900 1988 1989 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9298 19200 (BYTEBLOCKCOMPILE2 9308 . 11925) (BYTECOMPILE2 11927 . 12166) ( COMP.ATTEMPT.COMPILE 12168 . 13312) (COMP.RETFROM.POINT 13314 . 14004) (COMP.TRANSFORM 14006 . 17469) (COMPERROR 17471 . 17830) (COMPPRINT 17832 . 18056) (COMPERRM 18058 . 19198)) (19201 28848 ( COMP.TOPLEVEL.COMPILE 19211 . 25317) (COMP.BINDLIST 25319 . 25637) (COMP.CHECK.VAR 25639 . 26143) ( COMP.BIND.VARS 26145 . 28436) (COMP.UNBIND.VARS 28438 . 28846)) (28849 43028 (COMP.VALN 28859 . 28992) (COMP.PROGN 28994 . 29722) (COMP.PROGLST 29724 . 30622) (COMP.EXP1 30624 . 30772) (COMP.EXPR 30774 . 35500) (COMP.TRYUSERFN 35502 . 35831) (COMP.USERFN 35833 . 36754) (COMP.CONST 36756 . 37817) ( COMP.CALL 37819 . 39258) (COMP.VAR 39260 . 39739) (COMP.VAL1 39741 . 39874) (COMP.PROG1 39876 . 40304) (COMP.EFFECT 40306 . 40885) (COMP.VAL 40887 . 41510) (COMP.MACRO 41512 . 43026)) (43029 45232 ( COMP.VARTYPE 43039 . 43268) (COMP.LOOKUPVAR 43270 . 44742) (COMP.LOOKUPCONST 44744 . 45230)) (45233 52744 (COMP.ST 45243 . 45746) (COMP.STFN 45748 . 46142) (COMP.STCONST 46144 . 46313) (COMP.STVAR 46315 . 46451) (COMP.STPOP 46453 . 46616) (COMP.DELFN 46618 . 46856) (COMP.STRETURN 46858 . 47030) ( COMP.STTAG 47032 . 48002) (COMP.STJUMP 48004 . 50020) (COMP.STSETQ 50022 . 50290) (COMP.STCOPY 50292 . 50472) (COMP.DELPUSH 50474 . 50638) (COMP.DELPOP 50640 . 50808) (COMP.STBIND 50810 . 52204) ( COMP.STUNBIND 52206 . 52742)) (57165 60353 (COMP.ARGTYPE 57175 . 58344) (COMP.CLEANEXPP 58346 . 58662) (COMP.CLEANFNP 58664 . 59078) (COMP.CLEANFNOP 59080 . 59228) (COMP.GLOBALVARP 59230 . 59408) ( COMP.LINKCALLP 59410 . 59874) (COMP.ANONP 59876 . 60231) (COMP.NOSIDEEFFECTP 60233 . 60351)) (60354 63601 (COMP.CPI 60364 . 62172) (COMP.CPI1 62174 . 62903) (COMP.PICOUNT 62905 . 63599)) (63645 63846 ( COMP.EVQ 63655 . 63844)) (63958 66690 (COMP.BOOL 63968 . 66688)) (66691 67219 (COMP.APPLYFNP 66701 . 67217)) (67261 67843 (COMP.AC 67271 . 67467) (COMP.PUNT 67469 . 67841)) (67897 69523 (COMP.FUNCTION 67907 . 68327) (COMP.LAM1 68329 . 69183) (COMP.GENFN 69185 . 69521)) (69733 79689 (COMP.COND 69743 . 72832) (COMP.IF 72834 . 74307) (COMP.SELECTQ 74309 . 79687)) (79876 80406 (COMP.QUOTE 79886 . 80120) ( COMP.COMMENT 80122 . 80404)) (80458 83446 (COMP.DECLARE 80468 . 82352) (COMP.DECLARE1 82354 . 83444)) (86362 87269 (COMP.CARCDR 86372 . 87056) (COMP.STCROP 87058 . 87267)) (87357 87696 (COMP.NOT 87367 . 87694)) (87787 88524 (COMP.SETQ 87797 . 88294) (COMP.SETN 88296 . 88522)) (88525 92500 (COMP.LAMBDA 88535 . 92498)) (92749 104633 (COMP.PROG 92759 . 96529) (COMP.GO 96531 . 97549) (COMP.RETURN 97551 . 99228) (COMP.BLOCK 99230 . 100836) (COMP.RETURN-FROM 100838 . 102988) (COMP.TAGBODY 102990 . 104631)) (104686 107192 (COMP.LABELS 104696 . 107190)) (110639 120378 (COMP.NUMERIC 110649 . 115463) ( COMP.NUMBERCALL 115465 . 119055) (COMP.FIX 119057 . 119209) (COMP.STFIX 119211 . 119800) (COMP.DELFIX 119802 . 120376)) (120506 122351 (COMP.EQ 120516 . 122349)) (122413 125921 (COMP.NUMBERTEST 122423 . 125919)) (127424 134956 (COMP.MAP 127434 . 134954)) (137329 141510 (COMP.MLLIST 137339 . 138022) ( COMP.MLL 138024 . 140799) (COMP.MLLVAR 140801 . 141114) (COMP.MLLFN 141116 . 141508)) (142527 148126 ( OPT.RESOLVEJUMPS 142537 . 143608) (OPT.JLENPASS 143610 . 146975) (OPT.JFIXPASS 146977 . 147680) ( OPT.JSIZE 147682 . 148124)) (148172 151031 (OPT.CALLP 148182 . 148660) (OPT.JUMPCHECK 148662 . 148878) (OPT.DREV 148880 . 149079) (OPT.CHLEV 149081 . 149292) (OPT.CHECKTAG 149294 . 149673) (OPT.NOTJUMP 149675 . 150180) (OPT.INITHASH 150182 . 150559) (OPT.COMPINIT 150561 . 151029)) (151225 151996 ( OPT.CFRPTQ 151235 . 151994)) (153051 159997 (COMP.AREF 153061 . 154152) (COMP.ASET 154154 . 155247) ( COMP.BOX 155249 . 155899) (COMP.LOOKFORDECLARE 155901 . 156454) (COMP.DECLARETYPE 156456 . 157060) ( COMP.FLOATBOX 157062 . 157316) (COMP.FLOATUNBOX 157318 . 158288) (COMP.PREDP 158290 . 158493) ( COMP.UBFLOAT2 158495 . 159062) (COMP.UNBOX 159064 . 159995)) (160064 218417 (OPT.POSTOPT 160074 . 161970) (OPT.SETUPOPT 161972 . 164298) (OPT.SCANOPT 164300 . 173119) (OPT.XVARSCAN 173121 . 174296) ( OPT.XVARSCAN1 174298 . 174941) (OPT.JUMPOPT 174943 . 175573) (OPT.JUMPTHRU 175575 . 182498) ( OPT.LBMERGE 182500 . 183138) (OPT.PRDEL 183140 . 183622) (OPT.UBDEL 183624 . 183881) (OPT.LBDEL 183883 . 184635) (OPT.LABELNTHPR 184637 . 185627) (OPT.JUMPREV 185629 . 198988) (OPT.COMMONBACK 198990 . 201957) (OPT.DELTAGREF 201959 . 202837) (OPT.FINDEND 202839 . 203199) (OPT.RETOPT 203201 . 204639) ( OPT.RETFIND 204641 . 205116) (OPT.RETPOP 205118 . 207604) (OPT.RETOPT1 207606 . 208001) (OPT.RETTEST 208003 . 211618) (OPT.RETMERGE 211620 . 215060) (OPT.CODELEV 215062 . 217067) (OPT.CODEFRAME 217069 . 217895) (OPT.DEFREFS 217897 . 218136) (OPT.SETDEFREFS 218138 . 218415)) (218418 239190 (OPT.FRAMEOPT 218428 . 219579) (OPT.FRAMEMERGE 219581 . 222713) (OPT.NONILVAR 222715 . 223859) (OPT.MERGEFRAMEP 223861 . 225328) (OPT.FRAMELOCAL 225330 . 226147) (OPT.CLEANFRAME 226149 . 226666) (OPT.FRAMEDEL 226668 . 234584) (OPT.FRAMEVAR 234586 . 238394) (OPT.DELETEFRAMECHECK 238396 . 238993) (OPT.ONLYMEMB 238995 . 239188)) (239272 248086 (OPT.SKIPPUSH 239282 . 241705) (OPT.DELCODE 241707 . 243151) ( OPT.PRATTACH 243153 . 243626) (OPT.JUMPCOPYTEST 243628 . 244572) (OPT.EQOP 244574 . 245757) ( OPT.EQVALUE 245759 . 246866) (OPT.DELCOPYFN 246868 . 248084)) (248087 250651 (OPT.DEADSETQP 248097 . 248600) (OPT.DS1 248602 . 250649)) (254317 259058 (OPT.COMPILERERROR 254327 . 254505) (OPT.OPTCHECK 254507 . 258909) (OPT.CCHECK 258911 . 259056))))) STOP \ No newline at end of file diff --git a/sources/CL-ERROR b/sources/CL-ERROR new file mode 100644 index 00000000..c7df742f --- /dev/null +++ b/sources/CL-ERROR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "21-Aug-91 16:59:21" IL:|{PELE:MV:ENVOS}SOURCES>CL-ERROR.;3| 58889 IL:|changes| IL:|to:| (IL:FUNCTIONS CONDITIONS::DEFAULT-RESTART-REPORT) IL:|previous| IL:|date:| "16-May-90 12:20:11" IL:|{PELE:MV:ENVOS}SOURCES>CL-ERROR.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CL-ERRORCOMS) (IL:RPAQQ IL:CL-ERRORCOMS ((IL:COMS (IL:* IL:|;;| "Internal stuff. ") (IL:FUNCTIONS CONDITIONS::EXPAND-WITH-COLLECTION-SITES CONDITIONS::WITH-COLLECTION-SITES) (IL:FUNCTIONS DEFAULT-PROCEED-REPORT CONDITIONS::DEFAULT-RESTART-REPORT) (IL:FUNCTIONS IL:WITH-GENSYMS IL:WITH-ERR-LOOP-VARS IL:STRIP-KEYWORDS IL:MAKE-REPORT-FUNCTION CONDITIONS::NORMALIZE-SLOT-DESCRIPTION IL:CHECK-*CASE-SELECTOR IL:COLLECT-CASE-SELECTORS IL:%SUFFIX-SYMBOL IL:PROCEED-ARG-COLLECTOR SI::EXPAND-CONDITION-CASE SI::PROCESS-PROCEED-KEYWORDS SI::SPLIT-PROCEED-CLAUSES SI::EXPAND-PROCEED-CASE CONDITIONS::PARSE-RESTART-CASE CONDITIONS::CONVERT-RESTART-CASES CONDITIONS::EXPAND-RESTART-CASE)) (OPTIMIZERS CONDITION-CASE CATCH-ABORT PROCEED-CASE RESTART-CASE) (IL:COMS (IL:FUNCTIONS DEFINE-CONDITION CHECK-TYPE ETYPECASE CTYPECASE ECASE CCASE ASSERT HANDLER-BIND CONDITION-BIND CONDITION-CASE HANDLER-CASE IGNORE-ERRORS PROCEED-CASE RESTART-CASE RESTART-BIND WITH-SIMPLE-RESTART DEFINE-PROCEED-FUNCTION CATCH-ABORT)) (IL:* IL:|;;| "Conversion functions for translating old code") (IL:FUNCTIONS CONDITIONS::CONVERT-CONDITION-CASE CONDITIONS::CONVERT-OLD-DEFINE-CONDITION) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CL-ERROR) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (IL:* IL:|;;| "Internal stuff. ") (DEFUN CONDITIONS::EXPAND-WITH-COLLECTION-SITES (CONDITIONS::NEW-SITES CONDITIONS::BODY CONDITIONS::OLD-SITES) (LET ((CONDITIONS::NEW-SITES-AND-TAILS NIL)) `(LET ,(MAPCAN #'(LAMBDA (CONDITIONS::SITE) (UNLESS (GETF CONDITIONS::OLD-SITES CONDITIONS::SITE) `((,(CAR (PUSH (IL:GENSYM) CONDITIONS::OLD-SITES)) (LAST ,(CAR (PUSH CONDITIONS::SITE CONDITIONS::OLD-SITES)))))) ) CONDITIONS::NEW-SITES) (MACROLET ((CONDITIONS::WITH-COLLECTION-SITES ((&REST CONDITIONS::SITES) &BODY CONDITIONS::BODY) (CONDITIONS::EXPAND-WITH-COLLECTION-SITES CONDITIONS::SITES CONDITIONS::BODY ',CONDITIONS::OLD-SITES)) (CONDITIONS::COLLECT-INTO (CONDITIONS::SITE CONDITIONS::FORM) (IL:* IL:|;;| "written in this way to take advantage of RPLCONS. The FORM is evaluated first so that COLLECT-INTO nests properly, i.e., the test to determine if this is the first value collected should be done after the value itself is generated in case it does collection as well.") (LET ((CONDITIONS::TAIL (GETF ',CONDITIONS::OLD-SITES CONDITIONS::SITE))) (WHEN (NULL CONDITIONS::TAIL) (ERROR "~S is not a valid site for ~S." CONDITIONS::SITE 'CONDITIONS::COLLECT-INTO)) `(LET ((SI::$WITH-COLLECTION-VALUE$ ,CONDITIONS::FORM)) (IF ,CONDITIONS::SITE (RPLACD ,CONDITIONS::TAIL (SETQ ,CONDITIONS::TAIL (LIST SI::$WITH-COLLECTION-VALUE$ ))) (SETQ ,CONDITIONS::SITE (SETQ ,CONDITIONS::TAIL (LIST SI::$WITH-COLLECTION-VALUE$ )))) SI::$WITH-COLLECTION-VALUE$)))) ,@CONDITIONS::BODY)))) (DEFMACRO CONDITIONS::WITH-COLLECTION-SITES ((&REST CONDITIONS::SITES) &BODY CONDITIONS::BODY) (CONDITIONS::EXPAND-WITH-COLLECTION-SITES CONDITIONS::SITES CONDITIONS::BODY NIL)) (DEFMACRO DEFAULT-PROCEED-REPORT (PROCEED-TYPE) `(GET ,PROCEED-TYPE 'IL:%DEFAULT-PROCEED-REPORT 'IL:DEFAULT-PROCEED-REPORTER)) (DEFMACRO CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS::RESTART-TYPE) `(GET ,CONDITIONS::RESTART-TYPE 'IL:%DEFAULT-PROCEED-REPORT)) (DEFMACRO IL:WITH-GENSYMS (IL:VARS IL:PREFIX &BODY IL:BODY) `(LET ,(IL:MAPCAR IL:VARS (IL:FUNCTION (LAMBDA (IL:VAR) `(,IL:VAR (IL:GENSYM ,IL:PREFIX))))) ,@IL:BODY)) (DEFMACRO IL:WITH-ERR-LOOP-VARS (IL:PREFIX &BODY IL:BODY) `(IL:WITH-GENSYMS (IL:VAL IL:BLOCK-NAME IL:AGAIN) ,IL:PREFIX ,@IL:BODY)) (DEFUN IL:STRIP-KEYWORDS (IL:ARGS) (VALUES (IL:FOR IL:OLD IL:ARGS IL:ON IL:ARGS IL:BY CDDR IL:WHILE (KEYWORDP (FIRST IL:ARGS)) IL:COLLECT (LIST (FIRST IL:ARGS) (SECOND IL:ARGS))) IL:ARGS)) (DEFUN IL:MAKE-REPORT-FUNCTION (IL:DATUM IL:BOUND-VAR &OPTIONAL IL:TYPE-NAME) (ETYPECASE IL:DATUM (STRING IL:DATUM) (LIST `(LAMBDA (,IL:BOUND-VAR *STANDARD-OUTPUT*) ,(IF IL:TYPE-NAME `(IL:WITH ,IL:TYPE-NAME ,IL:BOUND-VAR ,IL:DATUM) IL:DATUM))))) (DEFUN CONDITIONS::NORMALIZE-SLOT-DESCRIPTION (CONDITIONS::SLOT-DESC) (ETYPECASE CONDITIONS::SLOT-DESC (CONS `(,(FIRST CONDITIONS::SLOT-DESC) ,(SECOND CONDITIONS::SLOT-DESC) :READ-ONLY T)) (SYMBOL `(,CONDITIONS::SLOT-DESC NIL :READ-ONLY T)))) (DEFUN IL:CHECK-*CASE-SELECTOR (IL:SELECTOR IL:NAME) (IF (OR (EQ IL:SELECTOR 'T) (EQ IL:SELECTOR 'OTHERWISE)) (ERROR "~A not allowed in the ~A form." IL:SELECTOR IL:NAME) IL:SELECTOR)) (DEFUN IL:COLLECT-CASE-SELECTORS (IL:CLAUSES IL:NAME) (IL:MAPCONC IL:CLAUSES (IL:FUNCTION (LAMBDA (IL:CLAUSE) (IL:IF (AND (CONSP (CAR IL:CLAUSE)) (IL:FMEMB IL:NAME '(ECASE CCASE))) IL:THEN (COPY-LIST (CAR IL:CLAUSE)) IL:ELSE (LIST (IL:CHECK-*CASE-SELECTOR (CAR IL:CLAUSE) IL:NAME))))))) (DEFUN IL:%SUFFIX-SYMBOL (IL:SYMBOL IL:SUFFIX PACKAGE) (INTERN (CONCATENATE 'STRING (SYMBOL-NAME IL:SYMBOL) IL:SUFFIX) PACKAGE)) (DEFMACRO IL:PROCEED-ARG-COLLECTOR (IL:NAME) "Function that collects user-specified optional args (excluding the condition) for a named proceed case." `(GET ,IL:NAME 'IL:%PROCEED-ARG-COLLECTOR)) (DEFUN SI::EXPAND-CONDITION-CASE (SI::FORM SI::CLAUSES SI::ENV SI::CTX SI::OPTIMIZE?) (MACROLET ((SI::BOUND-TYPES (SI::CLAUSE) `(FIRST ,SI::CLAUSE))) (IF (NULL SI::CLAUSES) SI::FORM (IL:* IL:|;;| "First, precompute the handler for this condition-case. We can use a constant catch tag because of the nice dynamic nesting properties of CONDITION-CASE.") (LET* ((SI::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING* (IL:GENSYM) 'SI::CONDITION-CASE-VALUES)) (SI::NO-ERROR-CLAUSE (ASSOC ':NO-ERROR SI::CLAUSES :TEST 'EQ)) (SI::ONLY-ONE-VALUE? (AND (NULL SI::NO-ERROR-CLAUSE) SI::OPTIMIZE? SI::CTX (EQL (COMPILER:CONTEXT-VALUES-USED SI::CTX) 1)))) (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*)) (FLET ((SI::CONSTRUCT-NO-ERROR-CODE (SI::VALUE-FORM) (DESTRUCTURING-BIND (SI::SELECTOR SI::BOUND-VARS &REST SI::BODY) SI::NO-ERROR-CLAUSE (DECLARE (IGNORE SI::SELECTOR)) (MACROLET ((SI::VALUE-IS-VALUES-LIST NIL '(AND (CONSP SI::VALUE-FORM) (EQ (FIRST SI::VALUE-FORM) 'VALUES-LIST)))) (COND ((NULL SI::BOUND-VARS) `(PROGN ,SI::VALUE-FORM ,@(CDDR SI::NO-ERROR-CLAUSE))) ((NULL (REST SI::BOUND-VARS)) (IL:* IL:|;;| "One bound var...") `(LET (,(FIRST SI::BOUND-VARS) ,(IF (SI::VALUE-IS-VALUES-LIST) `(FIRST ,(SECOND SI::VALUE-FORM)) SI::VALUE-FORM)) ,@SI::BODY)) (T (IL:* IL:|;;| "Several bound vars, need to capture them all") (IF (SI::VALUE-IS-VALUES-LIST) `(DESTRUCTURING-BIND ,SI::BOUND-VARS ,(SECOND SI::VALUE-FORM) ,@SI::BODY) `(MULTIPLE-VALUE-BIND ,SI::BOUND-VARS ,SI::VALUE-FORM ,@SI::BODY))))))) ) (WHEN (AND SI::NO-ERROR-CLAUSE (NULL (REST SI::CLAUSES))) (IL:* IL:|;;| "Degenerate case: only has a :NO-ERROR clause") (RETURN-FROM SI::EXPAND-CONDITION-CASE (SI::CONSTRUCT-NO-ERROR-CODE SI::FORM))) `(LET* ((SI::CONDITION-CASE-LITERALS (IL:LOADTIMECONSTANT (SI::CREATE-CONDITION-CASE-LITERALS ',(LET ((SI::TYPE-BINDINGS (WITH-COLLECTION (DOLIST (SI::CLAUSE SI::CLAUSES) (UNLESS (EQ (SI::BOUND-TYPES SI::CLAUSE) :NO-ERROR) (COLLECT (SI::BOUND-TYPES SI::CLAUSE))))))) (IF (NULL (REST SI::TYPE-BINDINGS)) (FIRST SI::TYPE-BINDINGS) (CONS 'OR SI::TYPE-BINDINGS)))))) ,SI::VALUE-SLOT (SI::CONDITION-CASE-SELECTOR (CATCH (CAR SI::CONDITION-CASE-LITERALS) (LET ((IL:*CONDITION-HANDLER-BINDINGS* (CONS (CDR SI::CONDITION-CASE-LITERALS) IL:*CONDITION-HANDLER-BINDINGS*))) (SETF ,SI::VALUE-SLOT ,(IF SI::ONLY-ONE-VALUE? SI::FORM `(MULTIPLE-VALUE-LIST ,SI::FORM))) :NORMAL)))) (DECLARE (IL:LOCALVARS SI::CONDITION-CASE-SELECTOR)) (COND ((EQ SI::CONDITION-CASE-SELECTOR :NORMAL) ,(COND (SI::NO-ERROR-CLAUSE (SI::CONSTRUCT-NO-ERROR-CODE `(VALUES-LIST ,SI::VALUE-SLOT)) ) (SI::ONLY-ONE-VALUE? SI::VALUE-SLOT) (T `(VALUES-LIST ,SI::VALUE-SLOT)))) ,@(MAPCAN #'(LAMBDA (SI::CLAUSE) (DESTRUCTURING-BIND (SI::SELECTOR SI::BOUND-VAR-LIST &REST SI::BODY) SI::CLAUSE (AND (NOT (EQ SI::SELECTOR :NO-ERROR)) `(((TYPEP SI::CONDITION-CASE-SELECTOR ',SI::SELECTOR) ,@(IF (NULL SI::BOUND-VAR-LIST) (OR SI::BODY '(NIL)) `(((LAMBDA ,SI::BOUND-VAR-LIST ,@(OR SI::BODY '(NIL))) SI::CONDITION-CASE-SELECTOR)))))))) SI::CLAUSES) (T (SI::CONDITION-CASE-ERROR SI::CONDITION-CASE-SELECTOR (CADR SI::CONDITION-CASE-LITERALS )))))))))) (DEFUN SI::PROCESS-PROCEED-KEYWORDS (SI::NAME SI::ARG PACKAGE) (LET (SI::FILTER SI::REPORT) (MULTIPLE-VALUE-BIND (SI::KEYS SI::TAIL) (IL:STRIP-KEYWORDS SI::ARG) (IL:|for| SI::PAIR IL:|in| SI::KEYS IL:|do| (DESTRUCTURING-BIND (SI::KEY SI::VALUE) SI::PAIR (CASE SI::KEY (:FILTER-FUNCTION (IF SI::FILTER (ERROR "Duplicate filter specified for proceed type ~S." SI::NAME)) (SETF SI::FILTER SI::VALUE)) (:FILTER (IF SI::FILTER (ERROR "Duplicate filter specified for proceed type ~S." SI::NAME)) (SETF SI::FILTER `(LAMBDA NIL ,SI::VALUE))) (:CONDITION (IF SI::FILTER (ERROR "Duplicate test form specified for proceed type ~S." SI::NAME)) (SETF SI::FILTER (IL:* IL:|;;| "consider using a closure here.") `(LAMBDA NIL (TYPEP *CURRENT-CONDITION* ',SI::VALUE)))) (:REPORT-FUNCTION (IF SI::REPORT (ERROR "Duplicate report form specified for proceed type ~S." SI::NAME)) (SETF SI::REPORT SI::VALUE)) (:REPORT (IF SI::REPORT (ERROR "Duplicate report form specified for proceed type ~S." SI::NAME)) (SETF SI::REPORT (ETYPECASE SI::VALUE (STRING SI::VALUE) (LIST `(LAMBDA (*STANDARD-OUTPUT*) ,SI::VALUE))))) (OTHERWISE (CERROR "Ignore key/value pair" "Illegal keyword ~S in proceed case ~S." SI::KEY SI::NAME))))) (VALUES SI::FILTER SI::REPORT SI::TAIL)))) (DEFUN SI::SPLIT-PROCEED-CLAUSES (SI::CLAUSES SI::ENV SI::OPTIMIZE?) (LET (SI::CASES SI::BODIES) (IL:FOR SI::CLAUSE IL:IN SI::CLAUSES IL:AS SI::SELECTOR IL:FROM 0 IL:DO (DESTRUCTURING-BIND (SI::NAME SI::VARS) SI::CLAUSE (MULTIPLE-VALUE-BIND (SI::FILTER SI::REPORT SI::TAIL) (SI::PROCESS-PROCEED-KEYWORDS SI::NAME (CDDR SI::CLAUSE) *PACKAGE*) (IF (NULL SI::NAME) (UNLESS SI::REPORT (ERROR "Unnamed proceed cases must have a report method: ~S" SI::CLAUSE))) (MACROLET ((SI::CONSTANT-PROCEED-CASE? NIL '(AND (OR (NULL SI::FILTER) (AND (SYMBOLP SI::FILTER) (OR (NULL SI::ENV) (NOT (COMPILER:ENV-FBOUNDP SI::ENV SI::FILTER))))) (OR (NULL SI::REPORT) (STRINGP SI::REPORT) (AND (SYMBOLP SI::REPORT) (OR (NULL SI::ENV) (NOT (COMPILER:ENV-FBOUNDP SI::ENV NIL)))))))) (PUSH (IF (AND SI::OPTIMIZE? (SI::CONSTANT-PROCEED-CASE?)) (IL:MAKE-PROCEED-CASE :NAME SI::NAME :SELECTOR SI::SELECTOR :TEST SI::FILTER :REPORT SI::REPORT) `(IL:MAKE-PROCEED-CASE :NAME ',SI::NAME :SELECTOR ,SI::SELECTOR :TEST ,(AND SI::FILTER `#',SI::FILTER) :REPORT ,(AND SI::REPORT (IF (STRINGP SI::REPORT) SI::REPORT `#',SI::REPORT)))) SI::CASES)) (PUSH (LIST* SI::SELECTOR SI::VARS SI::TAIL) SI::BODIES)))) (VALUES (FLET ((SI::MAYBE-QUOTE (SI::X) (IF (IL:PROCEED-CASE-P SI::X) (IL:KWOTE SI::X) SI::X))) (COND ((EQL (IL:LENGTH SI::CASES) 1) (SI::MAYBE-QUOTE (FIRST SI::CASES))) ((EVERY 'IL:PROCEED-CASE-P SI::CASES) (IL:KWOTE (NREVERSE SI::CASES))) (T `(LIST ,@(MAPCAR #'SI::MAYBE-QUOTE (NREVERSE SI::CASES)))))) (REVERSE SI::BODIES)))) (DEFUN SI::EXPAND-PROCEED-CASE (SI::FORM SI::CLAUSES SI::ENV SI::CTX SI::OPTIMIZE?) (LET ((SI::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING* (IL:GENSYM) 'SI::PROCEED-CASE-NORMAL-VALUES)) (SI::ONLY-ONE-VALUE? (AND SI::OPTIMIZE? SI::CTX (EQL (COMPILER:CONTEXT-VALUES-USED SI::CTX) 1)))) (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*)) (MULTIPLE-VALUE-BIND (SI::CASES SI::BODIES) (SI::SPLIT-PROCEED-CLAUSES SI::CLAUSES SI::ENV SI::OPTIMIZE?) (IF (NULL SI::CASES) SI::FORM `(LET* (,SI::VALUE-SLOT (SI::PROCEED-CASE-SELECTOR-AND-VALUES (LET ((IL:*PROCEED-CASES* (CONS ,SI::CASES IL:*PROCEED-CASES*))) (CATCH IL:*PROCEED-CASES* (SETF ,SI::VALUE-SLOT ,(IF SI::ONLY-ONE-VALUE? SI::FORM `(MULTIPLE-VALUE-LIST ,SI::FORM))) :NORMAL)))) (IF (EQ SI::PROCEED-CASE-SELECTOR-AND-VALUES :NORMAL) ,(IF SI::ONLY-ONE-VALUE? SI::VALUE-SLOT `(VALUES-LIST ,SI::VALUE-SLOT)) ,(FLET ((SI::CREATE-A-CASE (SI::X) (DESTRUCTURING-BIND (CASE SI::ARGS &REST SI::BODY) SI::X (IF (NULL SI::ARGS) `(,CASE ,@SI::BODY) `(,CASE (DESTRUCTURING-BIND (&OPTIONAL ,@SI::ARGS) SI::PROCEED-CASE-VALUES ,@SI::BODY)))))) (IF (EVERY #'(LAMBDA (SI::X) (NULL (SECOND SI::X))) SI::BODIES) `(CASE (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES) (IL:\\\,@ (MAPCAR #'SI::CREATE-A-CASE SI::BODIES))) `((LAMBDA (SI::PROCEED-CASE-SELECTOR SI::PROCEED-CASE-VALUES) (CASE SI::PROCEED-CASE-SELECTOR (IL:\\\,@ (MAPCAR #'SI::CREATE-A-CASE SI::BODIES)))) (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES) (CDR SI::PROCEED-CASE-SELECTOR-AND-VALUES)))))))))) (DEFUN CONDITIONS::PARSE-RESTART-CASE (CONDITIONS::NAME CONDITIONS::CLAUSE) (LET (CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE) (IL:WHILE (KEYWORDP (FIRST CONDITIONS::CLAUSE)) IL:DO (LET* ((CONDITIONS::KEY (POP CONDITIONS::CLAUSE)) (CONDITIONS::VALUE (POP CONDITIONS::CLAUSE))) (CASE CONDITIONS::KEY (:FILTER (UNLESS CONDITIONS::FILTER (SETF CONDITIONS::FILTER CONDITIONS::VALUE))) (:CONDITION (UNLESS CONDITIONS::FILTER (SETF CONDITIONS::FILTER `(LAMBDA NIL (TYPEP *CURRENT-CONDITION* ',CONDITIONS::VALUE))))) (:REPORT (UNLESS CONDITIONS::REPORT (SETF CONDITIONS::REPORT CONDITIONS::VALUE))) (:INTERACTIVE (UNLESS CONDITIONS::INTERACTIVE (SETF CONDITIONS::INTERACTIVE CONDITIONS::VALUE) )) (OTHERWISE (CERROR "Ignore key/value pair" "Illegal keyword ~S in restart named ~S." CONDITIONS::KEY CONDITIONS::NAME))))) (VALUES CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE CONDITIONS::CLAUSE))) (DEFUN CONDITIONS::CONVERT-RESTART-CASES (CONDITIONS::CLAUSES CONDITIONS::ENV CONDITIONS::OPTIMIZE?) (LET (CONDITIONS::CASES CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS? (CONDITIONS::ALL-CONSTANT? T)) (CONDITIONS::WITH-COLLECTION-SITES (CONDITIONS::CASES CONDITIONS::BODIES) (IL:FOR CONDITIONS::CLAUSE IL:IN CONDITIONS::CLAUSES IL:AS CONDITIONS::SELECTOR IL:FROM 0 IL:DO (LET* ((CONDITIONS::NAME (POP CONDITIONS::CLAUSE)) (CONDITIONS::ARGLIST (POP CONDITIONS::CLAUSE))) (WHEN CONDITIONS::ARGLIST (SETF CONDITIONS::ANY-ARGLISTS? T)) (MULTIPLE-VALUE-BIND (CONDITIONS::FILTER CONDITIONS::REPORT CONDITIONS::INTERACTIVE CONDITIONS::CODE) (CONDITIONS::PARSE-RESTART-CASE CONDITIONS::NAME CONDITIONS::CLAUSE) (MACROLET ((CONDITIONS::CONSTANT-RESTART? NIL '(AND (OR (NULL CONDITIONS::FILTER) (AND (SYMBOLP CONDITIONS::FILTER) (OR (NULL CONDITIONS::ENV) (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV CONDITIONS::FILTER)) ))) (OR (NULL CONDITIONS::REPORT) (STRINGP CONDITIONS::REPORT) (AND (SYMBOLP CONDITIONS::REPORT) (OR (NULL CONDITIONS::ENV) (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV CONDITIONS::REPORT)) ))) (OR (NULL CONDITIONS::INTERACTIVE) (AND (SYMBOLP CONDITIONS::INTERACTIVE) (OR (NULL CONDITIONS::ENV) (NOT (COMPILER:ENV-FBOUNDP CONDITIONS::ENV CONDITIONS::INTERACTIVE)))))))) (CONDITIONS::COLLECT-INTO CONDITIONS::CASES (IF (AND CONDITIONS::OPTIMIZE? (CONDITIONS::CONSTANT-RESTART?)) (CONDITIONS::MAKE-RESTART :NAME CONDITIONS::NAME :SELECTOR CONDITIONS::SELECTOR :TEST CONDITIONS::FILTER :REPORT CONDITIONS::REPORT :INTERACTIVE-FN CONDITIONS::INTERACTIVE) (PROGN (SETF CONDITIONS::ALL-CONSTANT? NIL) `(CONDITIONS::MAKE-RESTART :NAME ',CONDITIONS::NAME :SELECTOR ,CONDITIONS::SELECTOR :TEST ,(AND CONDITIONS::FILTER `#',CONDITIONS::FILTER) :REPORT ,(AND CONDITIONS::REPORT (IF (STRINGP CONDITIONS::REPORT) CONDITIONS::REPORT `#',CONDITIONS::REPORT)) :INTERACTIVE-FN ,(AND CONDITIONS::INTERACTIVE `#',CONDITIONS::INTERACTIVE)))))) (CONDITIONS::COLLECT-INTO CONDITIONS::BODIES (IF (NULL CONDITIONS::ARGLIST) `(,CONDITIONS::SELECTOR ,@CONDITIONS::CODE) `(,CONDITIONS::SELECTOR (DESTRUCTURING-BIND ( ,@ CONDITIONS::ARGLIST ) SI::PROCEED-CASE-VALUES ,@CONDITIONS::CODE)))))))) (VALUES (COND ((NULL (REST CONDITIONS::CASES)) (FIRST CONDITIONS::CASES)) (CONDITIONS::ALL-CONSTANT? `',CONDITIONS::CASES) (T (CONS 'LIST CONDITIONS::CASES))) CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS?))) (DEFUN CONDITIONS::EXPAND-RESTART-CASE (CONDITIONS::FORM CONDITIONS::CLAUSES CONDITIONS::ENV CONDITIONS::CTX CONDITIONS::OPTIMIZE?) (WHEN (NULL CONDITIONS::CLAUSES) (RETURN-FROM CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM)) (LET ((CONDITIONS::VALUE-SLOT (IF IL:*BYTECOMPILER-IS-EXPANDING* (IL:GENSYM) 'SI::PROCEED-CASE-NORMAL-VALUES)) (CONDITIONS::ONLY-ONE-VALUE? (AND CONDITIONS::OPTIMIZE? CONDITIONS::CTX (EQL ( COMPILER:CONTEXT-VALUES-USED CONDITIONS::CTX ) 1)))) (DECLARE (SPECIAL IL:*BYTECOMPILER-IS-EXPANDING*)) (MULTIPLE-VALUE-BIND (CONDITIONS::CASES CONDITIONS::BODIES CONDITIONS::ANY-ARGLISTS?) (CONDITIONS::CONVERT-RESTART-CASES CONDITIONS::CLAUSES CONDITIONS::ENV CONDITIONS::OPTIMIZE?) `(LET* (,CONDITIONS::VALUE-SLOT (SI::PROCEED-CASE-SELECTOR-AND-VALUES (LET ((IL:*PROCEED-CASES* (CONS ,CONDITIONS::CASES IL:*PROCEED-CASES*))) (CATCH IL:*PROCEED-CASES* (SETF ,CONDITIONS::VALUE-SLOT ,(IF CONDITIONS::ONLY-ONE-VALUE? CONDITIONS::FORM `(MULTIPLE-VALUE-LIST ,CONDITIONS::FORM))) :NORMAL)))) (IF (EQ SI::PROCEED-CASE-SELECTOR-AND-VALUES :NORMAL) ,(IF CONDITIONS::ONLY-ONE-VALUE? CONDITIONS::VALUE-SLOT `(VALUES-LIST ,CONDITIONS::VALUE-SLOT)) ,(IF CONDITIONS::ANY-ARGLISTS? `((LAMBDA (SI::PROCEED-CASE-SELECTOR SI::PROCEED-CASE-VALUES) (CASE SI::PROCEED-CASE-SELECTOR (IL:\\\,@ CONDITIONS::BODIES))) (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES) (CDR SI::PROCEED-CASE-SELECTOR-AND-VALUES)) (IL:* IL:|;;| "Slightly simpler if no arglists to deal with...") `(CASE (CAR SI::PROCEED-CASE-SELECTOR-AND-VALUES) (IL:\\\,@ CONDITIONS::BODIES)))))))) (DEFOPTIMIZER CONDITION-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV &CONTEXT CTX) (SI::EXPAND-CONDITION-CASE FORM CLAUSES ENV CTX T)) (DEFOPTIMIZER CATCH-ABORT (PRINT-FORM &BODY FORMS &ENVIRONMENT ENV &CONTEXT CTX) (IF (AND CTX (EQL (COMPILER:CONTEXT-VALUES-USED CTX) 1)) `(PROCEED-CASE (PROGN ,@FORMS) (ABORT NIL :REPORT ,PRINT-FORM NIL)) 'COMPILER:PASS)) (DEFOPTIMIZER PROCEED-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV &CONTEXT CTX) (SI::EXPAND-PROCEED-CASE FORM CLAUSES ENV CTX T)) (DEFOPTIMIZER RESTART-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES &ENVIRONMENT CONDITIONS::ENV &CONTEXT CONDITIONS::CTX) (CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM CONDITIONS::CLAUSES CONDITIONS::ENV CONDITIONS::CTX T)) (DEFDEFINER DEFINE-CONDITION IL:STRUCTURES (CONDITIONS::NAME (CONDITIONS::PARENT-TYPE) &OPTIONAL CONDITIONS::SLOTS &REST CONDITIONS::OPTIONS) (LET ((CONDITIONS::PARENT-SLOTS (AND CONDITIONS::PARENT-TYPE (CL::STRUCTURE-SLOT-NAMES CONDITIONS::PARENT-TYPE T))) CONDITIONS::REPORTER CONDITIONS::HANDLER CONDITIONS::SLOT-DESCRIPTIONS CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS CONDITIONS::CLASS-OPTIONS CONDITIONS::DOC) (SETQ CONDITIONS::SLOT-DESCRIPTIONS (WITH-COLLECTION (DOLIST (CONDITIONS::SLOT CONDITIONS::SLOTS) (SETQ CONDITIONS::SLOT (  CONDITIONS::NORMALIZE-SLOT-DESCRIPTION CONDITIONS::SLOT )) (IF (MEMBER (FIRST CONDITIONS::SLOT) CONDITIONS::PARENT-SLOTS :TEST 'EQ) (PUSH CONDITIONS::SLOT CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS ) (COLLECT CONDITIONS::SLOT))))) (SETQ CONDITIONS::CLASS-OPTIONS (WITH-COLLECTION (DOLIST (CONDITIONS::OPTION CONDITIONS::OPTIONS) (MACROLET ((CONDITIONS::MULTIPLE-OPTION-ERROR NIL '(CERROR "Ignore the later ~*~S option" "~S is a duplicate ~S option for ~S." CONDITIONS::OPTION (FIRST CONDITIONS::OPTION ) 'DEFINE-CONDITION))) (ECASE (FIRST CONDITIONS::OPTION) ((:CONC-NAME :INLINE) (COLLECT CONDITIONS::OPTION )) (:DOCUMENTATION (AND CONDITIONS::DOC (SETQ CONDITIONS::DOC (SECOND CONDITIONS::OPTION )))) (:REPORT (IF (NULL CONDITIONS::REPORTER) (SETQ CONDITIONS::REPORTER (SECOND CONDITIONS::OPTION )) ( CONDITIONS::MULTIPLE-OPTION-ERROR ))) (:HANDLE (IF (NULL CONDITIONS::HANDLER) (SETQ CONDITIONS::HANDLER (SECOND CONDITIONS::OPTION )) ( CONDITIONS::MULTIPLE-OPTION-ERROR )))))))) `(PROGN (DEFSTRUCT (,CONDITIONS::NAME ,@(AND CONDITIONS::PARENT-TYPE (IL:* IL:\; "hook for CONDITION") `((:INCLUDE ,CONDITIONS::PARENT-TYPE ,.(NREVERSE CONDITIONS::SHADOWED-SLOT-DESCRIPTIONS )))) ,.CONDITIONS::CLASS-OPTIONS (:PRINT-FUNCTION IL:%PRINT-CONDITION) (:CONSTRUCTOR ,(IL:%SUFFIX-SYMBOL CONDITIONS::NAME " constructor" (SYMBOL-PACKAGE CONDITIONS::NAME))) (:COPIER NIL) (:PREDICATE NIL)) ,.CONDITIONS::SLOT-DESCRIPTIONS) (EVAL-WHEN (LOAD EVAL) ,@(AND CONDITIONS::DOC `((SETF (DOCUMENTATION ',CONDITIONS::NAME 'TYPE) ',CONDITIONS::DOC))) ,@(IF (CONSP CONDITIONS::REPORTER) (LET ((CONDITIONS::REPORTER-NAME (IL:%SUFFIX-SYMBOL CONDITIONS::NAME " report method" (SYMBOL-PACKAGE CONDITIONS::NAME )))) (PROG1 `((SETF (SYMBOL-FUNCTION ',CONDITIONS::REPORTER-NAME) #',CONDITIONS::REPORTER)) (SETQ CONDITIONS::REPORTER CONDITIONS::REPORTER-NAME)))) (SETF (CONDITION-REPORTER ',CONDITIONS::NAME) ,(TYPECASE CONDITIONS::REPORTER (NULL NIL) (STRING CONDITIONS::REPORTER) (T `#',CONDITIONS::REPORTER))) ,@(IF (CONSP CONDITIONS::HANDLER) (LET ((CONDITIONS::HANDLER-NAME (IL:%SUFFIX-SYMBOL CONDITIONS::NAME " default handler" ( SYMBOL-PACKAGE CONDITIONS::NAME )))) (PROG1 `((SETF (SYMBOL-FUNCTION ',CONDITIONS::HANDLER-NAME) #',CONDITIONS::HANDLER)) (SETQ CONDITIONS::HANDLER CONDITIONS::HANDLER-NAME)))) (SETF (CONDITION-HANDLER ',CONDITIONS::NAME) ,(AND CONDITIONS::HANDLER `#',CONDITIONS::HANDLER)))))) (DEFMACRO CHECK-TYPE (CL::PLACE CL::TYPESPEC &OPTIONAL STRING) (IL:WITH-ERR-LOOP-VARS "CHECK-TYPE" `(BLOCK ,IL:BLOCK-NAME (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,CL::PLACE)) (WHEN (TYPEP ,IL:VAL ',CL::TYPESPEC) (RETURN-FROM ,IL:BLOCK-NAME)) (SETF ,CL::PLACE (IL:CHECK-TYPE-FAIL T ',CL::PLACE ,IL:VAL ',CL::TYPESPEC ,STRING)) (GO ,IL:AGAIN)))))) (DEFMACRO ETYPECASE (CL::KEYFORM &BODY CL::CLAUSES) (IL:WITH-GENSYMS (CL::VALUE) "ETYPECASE" (LET ((CL::CASE-SELECTORS (CONS 'OR (IL:COLLECT-CASE-SELECTORS CL::CLAUSES 'ETYPECASE)) )) `(LET ((,CL::VALUE ,CL::KEYFORM)) (TYPECASE ,CL::VALUE (IL:\\\,@ CL::CLAUSES) (T (IL:CHECK-TYPE-FAIL NIL ',CL::KEYFORM ,CL::VALUE ',CL::CASE-SELECTORS NIL ))))))) (DEFMACRO CTYPECASE (CL::KEYPLACE &BODY CL::CLAUSES) (LET ((CL::CASE-SELECTORS (CONS 'OR (IL:COLLECT-CASE-SELECTORS CL::CLAUSES 'CTYPECASE)))) (IL:WITH-ERR-LOOP-VARS "CTYPECASE" `(BLOCK ,IL:BLOCK-NAME (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,CL::KEYPLACE)) (RETURN-FROM ,IL:BLOCK-NAME (TYPECASE ,IL:VAL (IL:\\\,@ CL::CLAUSES) (T (SETF ,CL::KEYPLACE (IL:CHECK-TYPE-FAIL T ',CL::KEYPLACE ,IL:VAL ',CL::CASE-SELECTORS NIL)) (GO ,IL:AGAIN)))))))))) (DEFMACRO ECASE (CL::KEYFORM &REST CL::CLAUSES) (IL:WITH-GENSYMS (CL::VALUE) "ECASE" (LET ((CL::CASE-SELECTORS (IL:COLLECT-CASE-SELECTORS CL::CLAUSES 'ECASE))) (IF CL::CASE-SELECTORS `(LET ((,CL::VALUE ,CL::KEYFORM)) (CASE ,CL::VALUE (IL:\\\,@ CL::CLAUSES) (T (IL:ECASE-FAIL NIL ',CL::KEYFORM ,CL::VALUE ',CL::CASE-SELECTORS)))) (ERROR "Empty case statement."))))) (DEFMACRO CCASE (CL::KEYFORM &BODY CL::CLAUSES) (LET ((CL::CASE-SELECTORS (IL:COLLECT-CASE-SELECTORS CL::CLAUSES 'CCASE))) (UNLESS CL::CASE-SELECTORS (ERROR "Empty CCASE.")) (IL:WITH-ERR-LOOP-VARS "CCASE" `(BLOCK ,IL:BLOCK-NAME (TAGBODY ,IL:AGAIN (LET ((,IL:VAL ,CL::KEYFORM)) (RETURN-FROM ,IL:BLOCK-NAME (CASE ,IL:VAL (IL:\\\,@ CL::CLAUSES) (T (SETF ,CL::KEYFORM (IL:ECASE-FAIL T ',CL::KEYFORM ,IL:VAL ',CL::CASE-SELECTORS)) (GO ,IL:AGAIN)))))))))) (DEFMACRO ASSERT (CL::TEST-FORM &OPTIONAL CL::PLACES CL::DATUM &REST CL::ARGS) (UNLESS (LISTP CL::PLACES) (ERROR "~S should be a list of places." CL::PLACES)) (IL:WITH-ERR-LOOP-VARS "ASSERT" `(BLOCK ,IL:BLOCK-NAME (TAGBODY ,IL:AGAIN (WHEN ,CL::TEST-FORM (RETURN-FROM ,IL:BLOCK-NAME NIL)) (IL:ASSERT-FAIL ,CL::DATUM ,@CL::ARGS) (GO ,IL:AGAIN))))) (DEFMACRO HANDLER-BIND (BINDINGS &REST FORMS) "Eval forms under temporary new condition handlers." (IF (NULL BINDINGS) `(PROGN ,@FORMS) `(LET ((IL:*CONDITION-HANDLER-BINDINGS* (CONS ,(IF (NULL (REST BINDINGS)) `(CONS ',(FIRST (FIRST BINDINGS)) ,(SECOND (FIRST BINDINGS))) `(LIST :MULTIPLE-HANDLER-BINDINGS ,.(WITH-COLLECTION (DOLIST (BINDING BINDINGS) (COLLECT `',(FIRST BINDING)) (COLLECT (SECOND BINDING)))))) IL:*CONDITION-HANDLER-BINDINGS*))) ,@FORMS))) (DEFMACRO CONDITION-BIND (BINDINGS &REST FORMS) "Eval forms under temporary new condition handlers; synonym for HANDLER-BIND" `(HANDLER-BIND ,BINDINGS ,@FORMS)) (DEFMACRO CONDITION-CASE (FORM &REST CLAUSES) "Eval form under condition handlers that provide alternate continuations." (SI::EXPAND-CONDITION-CASE FORM CLAUSES NIL NIL NIL)) (DEFMACRO HANDLER-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES) "Eval form under condition handlers that provide alternate continuations." (SI::EXPAND-CONDITION-CASE CONDITIONS::FORM CONDITIONS::CLAUSES NIL NIL NIL) `(CONDITION-CASE ,CONDITIONS::FORM ,@CONDITIONS::CLAUSES)) (DEFMACRO IGNORE-ERRORS (&BODY IL:FORMS) "Eval forms with handler for any condition of type ERROR." `(CONDITION-CASE (PROGN ,@IL:FORMS) (ERROR (CONDITION) (VALUES NIL CONDITION)))) (DEFMACRO PROCEED-CASE (FORM &REST CLAUSES &ENVIRONMENT ENV) "Eval forms, establishing a place to proceed from errors." (SI::EXPAND-PROCEED-CASE FORM CLAUSES ENV NIL NIL)) (DEFMACRO RESTART-CASE (CONDITIONS::FORM &REST CONDITIONS::CLAUSES &ENVIRONMENT CONDITIONS::ENV) (CONDITIONS::EXPAND-RESTART-CASE CONDITIONS::FORM CONDITIONS::CLAUSES CONDITIONS::ENV NIL NIL)) (DEFMACRO RESTART-BIND (CONDITIONS::BINDINGS &BODY CONDITIONS::BODY) (IL:* IL:|;;| "This should also be optimized along the lines of RESTART-BIND. Not as important since this one will be rare.") (IF (NULL CONDITIONS::BINDINGS) `(PROGN ,@CONDITIONS::BODY) (LET ((CONDITIONS::CASES (MAPCAR #'(LAMBDA (CONDITIONS::BINDING) (DESTRUCTURING-BIND (CONDITIONS::NAME FUNCTION &KEY CONDITIONS::INTERACTIVE-FUNCTION CONDITIONS::REPORT-FUNCTION CONDITIONS::FILTER-FUNCTION) CONDITIONS::BINDING `(CONDITIONS::MAKE-RESTART :NAME ',CONDITIONS::NAME :SELECTOR 'SI::COMPLEX-RESTART-MARKER :FUNCTION ,FUNCTION :INTERACTIVE-FN ,CONDITIONS::INTERACTIVE-FUNCTION :REPORT ,CONDITIONS::REPORT-FUNCTION :TEST ,CONDITIONS::FILTER-FUNCTION))) CONDITIONS::BINDINGS))) `(LET ((IL:*PROCEED-CASES* (CONS ,(IF (NULL (REST CONDITIONS::CASES)) (FIRST CONDITIONS::CASES) `(LIST ,@CONDITIONS::CASES)) IL:*PROCEED-CASES*))) ,@CONDITIONS::BODY)))) (DEFMACRO WITH-SIMPLE-RESTART ((RESTART-NAME CONDITIONS::FORMAT-STRING &REST CONDITIONS::FORMAT-ARGS) &BODY CONDITIONS::BODY) `(RESTART-CASE (PROGN ,@CONDITIONS::BODY) (,RESTART-NAME NIL :REPORT (LAMBDA (STREAM) (FORMAT STREAM ,CONDITIONS::FORMAT-STRING ,@CONDITIONS::FORMAT-ARGS)) (VALUES NIL T)))) (DEFDEFINER DEFINE-PROCEED-FUNCTION IL:FUNCTIONS (NAME &REST TAIL) (MULTIPLE-VALUE-BIND (FILTER REPORT ARGLIST) (SI::PROCESS-PROCEED-KEYWORDS NAME TAIL (SYMBOL-PACKAGE NAME)) (LET ((VARS (IL:MAPCAR ARGLIST (IL:FUNCTION (IL:LAMBDA (X) (IF (SYMBOLP X) X (CAR X))))))) (UNLESS REPORT (SETF REPORT 'IL:DEFAULT-PROCEED-REPORTER)) `(PROGN ,@(IF (CONSP FILTER) (LET ((FILTER-FUNCTION (IL:%SUFFIX-SYMBOL NAME " proceed case default test" (SYMBOL-PACKAGE NAME)))) (PROG1 `((SETF (SYMBOL-FUNCTION ',FILTER-FUNCTION) #',FILTER)) (SETF FILTER FILTER-FUNCTION)))) (SETF (DEFAULT-PROCEED-TEST ',NAME) ,(AND FILTER `#',FILTER)) ,@(IF (CONSP REPORT) (LET ((REPORTER (IL:%SUFFIX-SYMBOL NAME " proceed case default report method" (SYMBOL-PACKAGE NAME)))) (PROG1 `((SETF (SYMBOL-FUNCTION ',REPORTER) #',REPORT)) (SETF REPORT REPORTER)))) (SETF (DEFAULT-PROCEED-REPORT ',NAME) ,(IF (STRINGP REPORT) REPORT `#',REPORT)) (DEFUN ,NAME (&OPTIONAL ,@ARGLIST) (LET ((RESTART (FIND-RESTART ',NAME))) (WHEN RESTART (INVOKE-RESTART RESTART ,@VARS)))))))) (DEFMACRO CATCH-ABORT (PRINT-FORM &BODY FORMS) `(PROCEED-CASE (PROGN ,@FORMS) (ABORT (CONDITION) :REPORT ,PRINT-FORM (VALUES NIL CONDITION)))) (IL:* IL:|;;| "Conversion functions for translating old code") (DEFUN CONDITIONS::CONVERT-CONDITION-CASE (CONDITIONS::WHOLE) (DESTRUCTURING-BIND (CONDITIONS::FN CONDITIONS::FORM &REST CONDITIONS::CLAUSES) CONDITIONS::WHOLE (DECLARE (IGNORE CONDITIONS::FN)) `(HANDLER-CASE ,CONDITIONS::FORM ,@(MAPCAR #'(LAMBDA (CONDITIONS::CLAUSE) (IF (LISTP (FIRST CONDITIONS::CLAUSE)) `((OR ,@(FIRST CONDITIONS::CLAUSE)) ,@(REST CONDITIONS::CLAUSE)) CONDITIONS::CLAUSE)) CONDITIONS::CLAUSES)))) (DEFUN CONDITIONS::CONVERT-OLD-DEFINE-CONDITION (CONDITIONS::FORM) (DESTRUCTURING-BIND (CONDITIONS::FN CONDITIONS::NAME CONDITIONS::PARENT-TYPE &REST CONDITIONS::ARGS) (REMOVE-COMMENTS CONDITIONS::FORM) (UNLESS (EQ CONDITIONS::FN 'DEFINE-CONDITION) (PRINT *ERROR-OUTPUT* "Not a define-condition form") (RETURN-FROM CONDITIONS::CONVERT-OLD-DEFINE-CONDITION CONDITIONS::FORM)) (FLET ((CONDITIONS::STRIP-KEYWORDS (CONDITIONS::ARGS) (VALUES (IL:FOR IL:OLD CONDITIONS::ARGS IL:ON CONDITIONS::ARGS IL:BY CDDR IL:WHILE (KEYWORDP (FIRST CONDITIONS::ARGS)) IL:COLLECT (LIST (FIRST CONDITIONS::ARGS) (SECOND CONDITIONS::ARGS))) CONDITIONS::ARGS))) (MULTIPLE-VALUE-BIND (CONDITIONS::KEYS CONDITIONS::SLOTS) (CONDITIONS::STRIP-KEYWORDS CONDITIONS::ARGS) (LET ((CONDITIONS::OPTIONS (WITH-COLLECTION (DOLIST (CONDITIONS::PAIR CONDITIONS::KEYS) (DESTRUCTURING-BIND (CONDITIONS::KEY CONDITIONS::VALUE) CONDITIONS::PAIR (CCASE CONDITIONS::KEY ((:INLINE :CONC-NAME) (COLLECT CONDITIONS::PAIR)) (:REPORT-FUNCTION (COLLECT `(:REPORT ,CONDITIONS::VALUE))) (:REPORT (COLLECT (ETYPECASE CONDITIONS::VALUE (STRING `(:REPORT ,CONDITIONS::VALUE)) (LIST `(:REPORT ,(LET ((CONDITION (INTERN "CONDITION" *PACKAGE*)) (CONDITIONS::ALL-SLOTS (APPEND (CL::STRUCTURE-SLOT-NAMES CONDITIONS::PARENT-TYPE T) (MAPCAR #'(LAMBDA (CONDITIONS::X) (IF (CONSP CONDITIONS::X ) (CAR CONDITIONS::X) CONDITIONS::X)) CONDITIONS::SLOTS)))) `(LAMBDA (,CONDITION *STANDARD-OUTPUT*) ,(WALK-FORM CONDITIONS::VALUE :WALK-FUNCTION #'(LAMBDA (CONDITIONS::FORM CONDITIONS::CONTEXT) (IF (AND (SYMBOLP CONDITIONS::FORM) (MEMBER CONDITIONS::FORM CONDITIONS::ALL-SLOTS)) (VALUES (LIST (IL:%SUFFIX-SYMBOL CONDITIONS::NAME (CONCATENATE 'STRING "-" (SYMBOL-NAME CONDITIONS::FORM )) *PACKAGE*) CONDITION) T) CONDITIONS::FORM)) :COPY T :LEXICAL-VARIABLES (LIST CONDITION))))))))) (:HANDLER-FUNCTION (COLLECT `(:HANDLE ,CONDITIONS::VALUE))) (:HANDLE (COLLECT `(:HANDLE ,(LET ((CONDITION (INTERN "CONDITION" *PACKAGE*)) (CONDITIONS::ALL-SLOTS (APPEND (CL::STRUCTURE-SLOT-NAMES CONDITIONS::PARENT-TYPE T) (MAPCAR #'(LAMBDA (CONDITIONS::X) (IF (CONSP CONDITIONS::X) (CAR CONDITIONS::X) CONDITIONS::X)) CONDITIONS::SLOTS)))) `(LAMBDA (,CONDITION) ,(WALK-FORM CONDITIONS::VALUE :WALK-FUNCTION #'(LAMBDA (CONDITIONS::FORM CONDITIONS::CONTEXT) (IF (AND (SYMBOLP CONDITIONS::FORM) (MEMBER CONDITIONS::FORM CONDITIONS::ALL-SLOTS)) (VALUES (LIST (IL:%SUFFIX-SYMBOL CONDITIONS::NAME (CONCATENATE 'STRING "-" (SYMBOL-NAME CONDITIONS::FORM)) *PACKAGE*) CONDITION) T) CONDITIONS::FORM)) :COPY T :LEXICAL-VARIABLES (LIST CONDITION))))))))))))) `(DEFINE-CONDITION ,CONDITIONS::NAME (,CONDITIONS::PARENT-TYPE) (,@CONDITIONS::SLOTS) ,@CONDITIONS::OPTIONS)))))) (IL:PUTPROPS IL:CL-ERROR IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:CL-ERROR IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:CL-ERROR IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CLEARINGHOUSE b/sources/CLEARINGHOUSE new file mode 100644 index 00000000..40a21733 --- /dev/null +++ b/sources/CLEARINGHOUSE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:24:59" {DSK}lde>lispcore>sources>CLEARINGHOUSE.;2 61119 changes to%: (RECORDS CHBROADCAST DOMAINCACHE ORGCACHE NSNAME) previous date%: " 4-Jan-93 17:33:21" {DSK}lde>lispcore>sources>CLEARINGHOUSE.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CLEARINGHOUSECOMS) (RPAQQ CLEARINGHOUSECOMS ( (* ; "Clearinghouse Protocol") (COURIERPROGRAMS CLEARINGHOUSE) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) ETHERRECORDS) (CONSTANTS (\CH.BROADCAST.SOCKET 20) (\CH.NULL.PROPERTY -1)) (RECORDS CHBROADCAST DOMAINCACHE ORGCACHE) (TEMPLATES CH.PROPERTY) (GLOBALVARS LOCAL.CLEARINGHOUSE \CH.CACHE CH.NET.HINT \CH.MAINLOCK NS.SERVER.NAMES.TO.ADDRESSES CLEARINGHOUSE.STRUCTURE.WINDOW CH.PROPERTIES *ASSUME-ZERO-NSSOCKETS*) (OPTIMIZERS CH.PROPERTY) (ADDVARS (CONSTANTFOLDFNS CH.PROPERTY))) (INITVARS (CH.NET.HINT) (CH.DEFAULT.DOMAIN NIL) (CH.DEFAULT.ORGANIZATION NIL) (LOCAL.CLEARINGHOUSE NIL) (\CH.CACHE NIL) (CLEARINGHOUSE.STRUCTURE.WINDOW NIL) (NS.SERVER.NAMES.TO.ADDRESSES NIL) (\CH.MAINLOCK (CREATE.MONITORLOCK "Clearinghouse"))) [P (CL:PROCLAIM '(CL:SPECIAL CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION] (ADDVARS (\SYSTEMCACHEVARS LOCAL.CLEARINGHOUSE \CH.CACHE NS.SERVER.NAMES.TO.ADDRESSES) (CH.PROPERTIES (ALL 0) (ALIAS 1) (ALIASES 2) (MEMBERS 3) (ADDRESS.LIST 4) (AUTHENTICATION.KEYS 6) (AUTHENTICATION.LEVEL 8) (MAILPRIMARY 30) (MAILBOXES 31) (MAILBOX.ACCESSCONTROL 32) (SERVICES 51) (FILE.SERVICE 10000) (PRINT.SERVICE 10001) (INTERNET.ROUTING.SERVICE 10002) (USER 10003) (MAIL.SERVICE 10004) (WORKSTATION 10005) (EXTERNAL.COMMUNICATION.SERVICE 10006) (RS232CPORT 10007) (INTERACTIVE.TERMINAL.SERVICE 10008) (GATEWAY.SERVICE 10009) (IBM3270.HOST 10010) (MAIL.GATEWAY 10011) (SIEMENS.9750.HOST 10012) (ADOBE.SERVICE 10013) (LIBRARIAN.SERVICE 10014) (TTX.GATEWAY 10015) (AUTHENTICATION.SERVICE 10016) (REMOTE.BATCH.SERVICE 10017) (NETWORK 10018) (NETWORK.SERVERS 10019) (CIU 10020) (CLEARINGHOUSE.SERVICE 10021) (USERGROUP 10022) (FETCH.SERVICE 10023) (SERVER 10024) (USERDATA 20000) (RS232CDATA 20001) (IBM3270HOSTDATA 20002) (SIEMENS9750HOSTDATA 20003) (CANMAILTO 20005) (MAILGATEWAYROUTEDATA 20006) (FOREIGNMAILSYSTEMNAME 20007) (RS232C.BACK 20102) (IBM3270.HOST.BACK 20103) (ASSOCIATED.WORKSTATION 30005) (FILESERVER 10))) (COMS (* ; "Clearinghouse names") (RECORDS NSNAME) (P (DEFPRINT 'NSNAME (FUNCTION \NSNAME.DEFPRINT))) (PROP COURIERDEF NSNAME NSNAME2) (FNS \NSNAME.DEFPRINT NSNAME.TO.STRING COURIER.READ.NSNAME COURIER.WRITE.NSNAME COURIER.NSNAME.LENGTH)) (COMS (* ; "Finding Clearinghouse") (FNS GETCLEARINGHOUSE \CH.CHECK.CLEARINGHOUSE START.CLEARINGHOUSE SHOW.CLEARINGHOUSE CH.FINDSERVER \CH.FIND.ORG.SERVER \CH.LOCATE.SERVERS \CH.PRINT.BLURB \CH.UPDATE.CACHE EQUAL.CH.NAMES PARSE.NSNAME CH.NAME.TO.STRING CANONICAL.CH.NAME CH.PROPERTY CH.GETAUTHENTICATOR) (FNS CH.SERVERS \CH.GUESS.NEW.PROPERTIES)) (COMS (* ; "Clearinghouse calls") (FNS CH.DOMAINS.SERVED CH.CREATE.OBJECT CH.DELETE.OBJECT CH.CREATE.ALIAS CH.DELETE.ALIAS CH.LIST.ALIASES CH.LIST.ALIASES.OF CH.LOOKUP.OBJECT CH.DELETE.PROPERTY) (FNS CH.RETRIEVE.MEMBERS CH.ISMEMBER CH.ADD.SELF CH.DELETE.SELF) (FNS CH.RETRIEVE.ITEM CH.ADD.ITEM.PROPERTY CH.CHANGE.ITEM) (FNS CH.LIST.DOMAINS) (* ;; "NOTE: the following functions were moved to the file AUTHENTICATION temporarily for benefit of Lyric users wanting a functional NSMAINTAIN: CH.LIST.PROPERTIES CH.LIST.ORGANIZATIONS CH.LIST.OBJECTS CH.DELETE.MEMBER CH.ADD.MEMBER CH.ADD.GROUP.PROPERTY") ) (COMS (* ; "Other entries") (FNS LOOKUP.NS.SERVER \CANONICAL.NSHOSTNAME CH.CANONICAL.NAME) (INITVARS (*ASSUME-ZERO-NSSOCKETS* T))) (FILES AUTHENTICATION))) (* ; "Clearinghouse Protocol") (COURIERPROGRAM CLEARINGHOUSE (2 3) TYPES [(ORGANIZATION STRING) (DOMAIN STRING) (OBJECT STRING) (ORGANIZATION.NAME ORGANIZATION) (DOMAIN.NAME NSNAME2) (OBJECT.NAME NSNAME) (NAME NSNAME) (ORGANIZATION.NAME.PATTERN ORGANIZATION) (DOMAIN.NAME.PATTERN NSNAME2) (OBJECT.NAME.PATTERN NSNAME) (PROPERTY LONGCARDINAL) (PROPERTIES (SEQUENCE PROPERTY)) (ITEM (SEQUENCE UNSPECIFIED)) (NETWORK.ADDRESS NSADDRESS) (NETWORK.ADDRESS.LIST (SEQUENCE NETWORK.ADDRESS)) [AUTHENTICATOR (RECORD (CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (VERIFIER (AUTHENTICATION . VERIFIER] [MAILBOX.VALUES (RECORD (TIME TIME) (MAIL.SERVICE (SEQUENCE NAME] (USERDATA.VALUE (RECORD (LAST.NAME.INDEX CARDINAL) (FILE.SERVICE NAME))) (WHICH.ARGUMENT (ENUMERATION (FIRST 1) (SECOND 2))) (ARGUMENT.PROBLEM (ENUMERATION (IllegalProperty 10) (IllegalOrganization 11) (IllegalDomain 12) (IllegalObject 13) (NoSuchOrganization 14) (NoSuchDomain 15) (NoSuchObject 16))) (CALL.PROBLEM (ENUMERATION (AccessRightsInsufficient 1) (TooBusy 2) (ServerDown 3) (USE.COURIER 4) (Other 5))) (PROPERTY.PROBLEM (ENUMERATION (Missing 20) (WrongType 21))) (UPDATE.PROBLEM (ENUMERATION (NoChange 30) (OutOfDate 31) (ObjectOverflow 32) (DatabaseOverflow 33] PROCEDURES ((RETRIEVE.ADDRESSES 0 NIL RETURNS (NETWORK.ADDRESS.LIST) REPORTS (CALL.ERROR)) (LIST.DOMAINS.SERVED 1 (BULK.DATA.SINK AUTHENTICATOR) RETURNS NIL REPORTS (CALL.ERROR)) (CREATE.OBJECT 2 (OBJECT.NAME AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)) (DELETE.OBJECT 3 (OBJECT.NAME AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)) (LOOKUP.OBJECT 4 (OBJECT.NAME.PATTERN AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR CALL.ERROR WRONG.SERVER)) (LIST.ORGANIZATIONS 5 (ORGANIZATION.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (LIST.DOMAINS 6 (DOMAIN.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (LIST.OBJECTS 7 (OBJECT.NAME.PATTERN PROPERTY BULK.DATA.SINK AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (LIST.ALIASES 8 (OBJECT.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR) RETURNS NIL REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (LIST.ALIASES.OF 9 (OBJECT.NAME.PATTERN BULK.DATA.SINK AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (CREATE.ALIAS 10 (OBJECT.NAME OBJECT.NAME AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)) (DELETE.ALIAS 11 (OBJECT.NAME AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR UPDATE.ERROR WRONG.SERVER)) (ADD.GROUP.PROPERTY 12 (OBJECT.NAME PROPERTY BULK.DATA.SOURCE AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (ADD.ITEM.PROPERTY 13 (OBJECT.NAME PROPERTY ITEM AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (DELETE.PROPERTY 14 (OBJECT.NAME PROPERTY AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (LIST.PROPERTIES 15 (OBJECT.NAME.PATTERN AUTHENTICATOR) RETURNS (OBJECT.NAME PROPERTIES) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR WRONG.SERVER)) (RETRIEVE.ITEM 16 (OBJECT.NAME.PATTERN PROPERTY AUTHENTICATOR) RETURNS (OBJECT.NAME ITEM) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER)) (CHANGE.ITEM 17 (OBJECT.NAME PROPERTY ITEM AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (RETRIEVE.MEMBERS 18 (OBJECT.NAME.PATTERN PROPERTY BULK.DATA.SINK AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER)) (ADD.MEMBER 19 (OBJECT.NAME PROPERTY NSNAME AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (ADD.SELF 20 (OBJECT.NAME PROPERTY AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (DELETE.MEMBER 21 (OBJECT.NAME PROPERTY NSNAME AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (DELETE.SELF 22 (OBJECT.NAME PROPERTY AUTHENTICATOR) RETURNS (OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR UPDATE.ERROR WRONG.SERVER)) (IS.MEMBER 23 (OBJECT.NAME.PATTERN PROPERTY PROPERTY NSNAME AUTHENTICATOR) RETURNS (BOOLEAN OBJECT.NAME) REPORTS (ARGUMENT.ERROR AUTHENTICATION.ERROR CALL.ERROR PROPERTY.ERROR WRONG.SERVER))) ERRORS [(CALL.ERROR 1 (CALL.PROBLEM)) (ARGUMENT.ERROR 2 (ARGUMENT.PROBLEM WHICH.ARGUMENT)) (PROPERTY.ERROR 3 (PROPERTY.PROBLEM OBJECT.NAME)) (UPDATE.ERROR 4 (UPDATE.PROBLEM BOOLEAN WHICH.ARGUMENT OBJECT.NAME)) (WRONG.SERVER 5 (OBJECT.NAME)) (AUTHENTICATION.ERROR 6 ((AUTHENTICATION . PROBLEM]) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) ETHERRECORDS) (DECLARE%: EVAL@COMPILE (RPAQQ \CH.BROADCAST.SOCKET 20) (RPAQQ \CH.NULL.PROPERTY -1) (CONSTANTS (\CH.BROADCAST.SOCKET 20) (\CH.NULL.PROPERTY -1)) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS CHBROADCAST ((CHBROADCASTBODY (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) of DATUM))) (BLOCKRECORD CHBROADCASTBODY ((LOW.VERSION WORD) (HIGH.VERSION WORD) (MSGTYPE WORD) (ZERO2 WORD) (PROGRAM# FIXP) (VERSION# WORD) (ZERO3 WORD)))) (RECORD DOMAINCACHE (DCDOMAIN DCKNOWNSERVERS DCHINTSERVERS DCCOMPLETE)) (RECORD ORGCACHE (OCORGANIZATION OCALLSERVERS . OCDOMAINS)) ) (SETTEMPLATE 'CH.PROPERTY '(PROP)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LOCAL.CLEARINGHOUSE \CH.CACHE CH.NET.HINT \CH.MAINLOCK NS.SERVER.NAMES.TO.ADDRESSES CLEARINGHOUSE.STRUCTURE.WINDOW CH.PROPERTIES *ASSUME-ZERO-NSSOCKETS*) ) (DEFOPTIMIZER CH.PROPERTY (&WHOLE FORM) (* ;  "for some reason, compiler needs more than having CH.PROPERTY on CONSTANTFOLDFNS") (OR (CAR (CONSTANTEXPRESSIONP FORM)) 'IGNOREMACRO)) (ADDTOVAR CONSTANTFOLDFNS CH.PROPERTY) ) (RPAQ? CH.NET.HINT ) (RPAQ? CH.DEFAULT.DOMAIN NIL) (RPAQ? CH.DEFAULT.ORGANIZATION NIL) (RPAQ? LOCAL.CLEARINGHOUSE NIL) (RPAQ? \CH.CACHE NIL) (RPAQ? CLEARINGHOUSE.STRUCTURE.WINDOW NIL) (RPAQ? NS.SERVER.NAMES.TO.ADDRESSES NIL) (RPAQ? \CH.MAINLOCK (CREATE.MONITORLOCK "Clearinghouse")) (CL:PROCLAIM '(CL:SPECIAL CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION)) (ADDTOVAR \SYSTEMCACHEVARS LOCAL.CLEARINGHOUSE \CH.CACHE NS.SERVER.NAMES.TO.ADDRESSES) (ADDTOVAR CH.PROPERTIES (ALL 0) (ALIAS 1) (ALIASES 2) (MEMBERS 3) (ADDRESS.LIST 4) (AUTHENTICATION.KEYS 6) (AUTHENTICATION.LEVEL 8) (MAILPRIMARY 30) (MAILBOXES 31) (MAILBOX.ACCESSCONTROL 32) (SERVICES 51) (FILE.SERVICE 10000) (PRINT.SERVICE 10001) (INTERNET.ROUTING.SERVICE 10002) (USER 10003) (MAIL.SERVICE 10004) (WORKSTATION 10005) (EXTERNAL.COMMUNICATION.SERVICE 10006) (RS232CPORT 10007) (INTERACTIVE.TERMINAL.SERVICE 10008) (GATEWAY.SERVICE 10009) (IBM3270.HOST 10010) (MAIL.GATEWAY 10011) (SIEMENS.9750.HOST 10012) (ADOBE.SERVICE 10013) (LIBRARIAN.SERVICE 10014) (TTX.GATEWAY 10015) (AUTHENTICATION.SERVICE 10016) (REMOTE.BATCH.SERVICE 10017) (NETWORK 10018) (NETWORK.SERVERS 10019) (CIU 10020) (CLEARINGHOUSE.SERVICE 10021) (USERGROUP 10022) (FETCH.SERVICE 10023) (SERVER 10024) (USERDATA 20000) (RS232CDATA 20001) (IBM3270HOSTDATA 20002) (SIEMENS9750HOSTDATA 20003) (CANMAILTO 20005) (MAILGATEWAYROUTEDATA 20006) (FOREIGNMAILSYSTEMNAME 20007) (RS232C.BACK 20102) (IBM3270.HOST.BACK 20103) (ASSOCIATED.WORKSTATION 30005) (FILESERVER 10)) (* ; "Clearinghouse names") (DECLARE%: EVAL@COMPILE (DATATYPE NSNAME ((NSOBJECT POINTER) (NSDOMAIN POINTER) (NSORGANIZATION POINTER)) (* Canonical three-part  Clearinghouse name) ) ) (/DECLAREDATATYPE 'NSNAME '(POINTER POINTER POINTER) '((NSNAME 0 POINTER) (NSNAME 2 POINTER) (NSNAME 4 POINTER)) '6) (DEFPRINT 'NSNAME (FUNCTION \NSNAME.DEFPRINT)) (PUTPROPS NSNAME COURIERDEF (COURIER.READ.NSNAME COURIER.WRITE.NSNAME COURIER.NSNAME.LENGTH)) (PUTPROPS NSNAME2 COURIERDEF (COURIER.READ.NSNAME COURIER.WRITE.NSNAME)) (DEFINEQ (\NSNAME.DEFPRINT [LAMBDA (NAME STREAM) (* bvm%: "28-Jun-84 16:36") (LIST (NSNAME.TO.STRING NAME]) (NSNAME.TO.STRING [LAMBDA (NSNAME FULLNAMEFLG) (* bvm%: "26-Jul-85 12:41") (PROG ([OBJ (ffetch NSOBJECT of (SETQ NSNAME (\DTEST NSNAME 'NSNAME] (DOM (ffetch NSDOMAIN of NSNAME)) (ORG (ffetch NSORGANIZATION of NSNAME)) (COLON ":")) (RETURN (COND ((NOT OBJ) (* ; "Two-part name") (CONCAT DOM COLON ORG)) ((OR FULLNAMEFLG (NOT (STRING-EQUAL ORG CH.DEFAULT.ORGANIZATION))) (* ; "No defaults") (CONCAT OBJ COLON DOM COLON ORG)) (T (CONCAT OBJ COLON (COND ((STRING-EQUAL DOM CH.DEFAULT.DOMAIN) "") (T DOM]) (COURIER.READ.NSNAME [LAMBDA (STREAM PROGRAM TYPE) (* bvm%: "27-Jun-84 15:41") (* ;;; "Read a Clearinghouse name: 3 strings, or 2 strings if reading a 2-part name") (create NSNAME NSORGANIZATION _ (COURIER.READ.STRING STREAM) NSDOMAIN _ (COURIER.READ.STRING STREAM) NSOBJECT _ (AND (EQ TYPE 'NSNAME) (COURIER.READ.STRING STREAM]) (COURIER.WRITE.NSNAME [LAMBDA (STREAM NAME PROGRAM TYPE) (* bvm%: "27-Jun-84 15:43") [COURIER.WRITE.STRING STREAM (ffetch NSORGANIZATION of (\DTEST NAME 'NSNAME] (COURIER.WRITE.STRING STREAM (ffetch NSDOMAIN of NAME)) (COND ((EQ TYPE 'NSNAME) (* ; "full 3-part name") (COURIER.WRITE.STRING STREAM (ffetch NSOBJECT of NAME]) (COURIER.NSNAME.LENGTH [LAMBDA (NSNAME PROGRAM TYPE) (* ; "Edited 21-Jul-87 17:00 by bvm:") (* ;; "Return the representation length of an NSNAME, or NIL if we can't cheaply.") (PROG NIL (RETURN (+ [COND ((EQ TYPE 'NSNAME2) 0) (T (OR (COURIER.REP.LENGTH (fetch NSOBJECT of NSNAME) NIL 'STRING) (RETURN NIL] (OR (COURIER.REP.LENGTH (fetch NSDOMAIN of NSNAME) NIL 'STRING) (RETURN NIL)) (OR (COURIER.REP.LENGTH (fetch NSORGANIZATION of NSNAME) NIL 'STRING) (RETURN NIL]) ) (* ; "Finding Clearinghouse") (DEFINEQ (GETCLEARINGHOUSE [LAMBDA NIL (* ; "Edited 24-Jul-87 17:33 by bvm:") (COND ((AND CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION LOCAL.CLEARINGHOUSE)) (T (WITH.MONITOR \CH.MAINLOCK [OR LOCAL.CLEARINGHOUSE (repeatuntil (SETQ $$VAL (COURIER.BROADCAST.CALL \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'RETRIEVE.ADDRESSES NIL (FUNCTION \CH.CHECK.CLEARINGHOUSE ) CH.NET.HINT "Clearinghouse servers"])]) (\CH.CHECK.CLEARINGHOUSE [LAMBDA (ADDRESSES) (* bvm%: "15-Aug-84 12:49") (PROG ((ADDR (BESTNSADDRESS ADDRESSES T)) DOMAINS DEFAULT) (RETURN (COND ([AND ADDR (SETQ DOMAINS (CH.DOMAINS.SERVED ADDR)) (find old DEFAULT in DOMAINS suchthat (PROGN (* ;  "Skip over the stupid ...:... domain") (NOT (STREQUAL (fetch NSORGANIZATION of DEFAULT) "..."] (COND ((OR (NULL CH.DEFAULT.DOMAIN) (NULL CH.DEFAULT.ORGANIZATION))(* ;  "Use the first domain that this server serves to set the default domain and organization.") (* ;  "Skip over the stupid ...:... domain") (printout PROMPTWINDOW T "[Default Clearinghouse domain set to " (SETQ CH.DEFAULT.DOMAIN (fetch NSDOMAIN of DEFAULT)) ":" (SETQ CH.DEFAULT.ORGANIZATION (fetch NSORGANIZATION of DEFAULT)) "]"))) (\CH.UPDATE.CACHE (create NSNAME NSOBJECT _ (MKSTRING ADDR) NSDOMAIN _ "CHServers" NSORGANIZATION _ "CHServers") ADDR DOMAINS) (SETQ LOCAL.CLEARINGHOUSE ADDR]) (START.CLEARINGHOUSE [LAMBDA (RESTARTFLG) (* bvm%: "27-Jun-84 10:57") (COND ((OR RESTARTFLG (NULL LOCAL.CLEARINGHOUSE)) (SETQ \NS.ROUTING.TABLE.RADIUS 5) (SETQ NS.SERVER.NAMES.TO.ADDRESSES (SETQ \CH.CACHE (SETQ LOCAL.CLEARINGHOUSE NIL))) (GETCLEARINGHOUSE))) LOCAL.CLEARINGHOUSE]) (SHOW.CLEARINGHOUSE [LAMBDA (ENTIRE.CLEARINGHOUSE? DONT.GRAPH) (* ; "Edited 23-Jul-87 12:02 by bvm:") (PROG (SEXPR) [SETQ SEXPR (CONS "" (COND [ENTIRE.CLEARINGHOUSE? (* ;  "Find all domains in all organizations.") (for ORG in (CH.LIST.ORGANIZATIONS "*") collect (CONS ORG (CH.LIST.DOMAINS (CONCAT "*:" ORG] (T (* ; "Use cached structure.") (for ORG in \CH.CACHE collect (CONS (fetch OCORGANIZATION of ORG) (for DOM in (fetch OCDOMAINS of ORG) collect (fetch DCDOMAIN of DOM] (COND (DONT.GRAPH (RETURN SEXPR))) (FILESLOAD (SYSLOAD FROM VALUEOF LISPUSERSDIRECTORIES) GRAPHER) (SETQ CLEARINGHOUSE.STRUCTURE.WINDOW (SHOWGRAPH (LAYOUTSEXPR SEXPR 'HORIZONTAL NIL '(HELVETICA 10 BOLD)) (OR CLEARINGHOUSE.STRUCTURE.WINDOW "Clearinghouse structure"))) [WINDOWPROP CLEARINGHOUSE.STRUCTURE.WINDOW 'CLOSEFN (FUNCTION (LAMBDA NIL (SETQ CLEARINGHOUSE.STRUCTURE.WINDOW NIL] (RETURN CLEARINGHOUSE.STRUCTURE.WINDOW]) (CH.FINDSERVER [LAMBDA (DOMAINPATTERN NOERRORFLG DONTPROBEFLG) (* ; "Edited 23-Jul-87 12:02 by bvm:") (* ;; "Find a Clearinghouse which serves the specified domain and return its NS address. If DONTPROBEFLG is T, just search the cache.") (OR (type? NSNAME DOMAINPATTERN) (SETQ DOMAINPATTERN (PARSE.NSNAME DOMAINPATTERN 2))) (LET ((ORGANIZATION (fetch NSORGANIZATION of DOMAINPATTERN)) (DOMAIN (fetch NSDOMAIN of DOMAINPATTERN)) ORGANIZATION.INFO) (SETQ ORGANIZATION.INFO (\CH.FIND.ORG.SERVER ORGANIZATION NOERRORFLG DONTPROBEFLG)) (COND [(STRING-EQUAL DOMAIN "*") (* ; "Any server in the org will do.") (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO] [(for DOMAIN.INFO in (fetch OCDOMAINS of ORGANIZATION.INFO) when (STRING-EQUAL (fetch DCDOMAIN of DOMAIN.INFO) DOMAIN) do (RETURN (CAR (CAR (fetch DCKNOWNSERVERS of DOMAIN.INFO] (DONTPROBEFLG (AND (NOT NOERRORFLG) (ERROR "Couldn't find Clearinghouse server for domain" DOMAINPATTERN T ))) (T (* ;; "Ask a clearinghouse in ORGANIZATION to find servers for this domain. For simplicity, assume the first one will tell us. This should be 'Local Clearinghouse' if it serves ORGANIZATION") (\CH.LOCATE.SERVERS (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO))) (create NSNAME NSOBJECT _ DOMAIN NSDOMAIN _ ORGANIZATION NSORGANIZATION _ "CHServers") NOERRORFLG ORGANIZATION DOMAIN) (CH.FINDSERVER DOMAINPATTERN NOERRORFLG T]) (\CH.FIND.ORG.SERVER [LAMBDA (ORGANIZATION NOERRORFLG DONTPROBEFLG) (* ; "Edited 23-Jul-87 12:19 by bvm:") (COND ((find ORGINFO in \CH.CACHE suchthat (STRING-EQUAL (fetch OCORGANIZATION of ORGINFO) ORGANIZATION))) (DONTPROBEFLG (AND (NOT NOERRORFLG) (ERROR "Couldn't find Clearinghouse server for organization" ORGANIZATION T ))) ((STRING-EQUAL ORGANIZATION "CHServers") (* ;; "Everyone handles this org, so create a fake organization %"CHServers%" whose domains are %"CHServers%" (served by everybody) and each known organization (served by all servers for that org).") (GETCLEARINGHOUSE) [LET (ALLSERVERS KNOWNDOMAINS) [SETQ KNOWNDOMAINS (for ORG in \CH.CACHE collect (SETQ ALLSERVERS (APPEND (fetch OCALLSERVERS of ORG) ALLSERVERS)) (* ; "Note servers for grand list") (create DOMAINCACHE DCDOMAIN _ (fetch OCORGANIZATION of ORG) DCKNOWNSERVERS _ (fetch OCALLSERVERS of ORG] (SETQ ALLSERVERS (SORT.NSADDRESSES.BY.DISTANCE ALLSERVERS)) (SETQ \CH.CACHE (NCONC1 \CH.CACHE (create ORGCACHE OCORGANIZATION _ ORGANIZATION OCALLSERVERS _ ALLSERVERS OCDOMAINS _ (CONS (create DOMAINCACHE DCDOMAIN _ ORGANIZATION DCKNOWNSERVERS _ ALLSERVERS) KNOWNDOMAINS] (\CH.FIND.ORG.SERVER ORGANIZATION NOERRORFLG T)) (T (* ;  "Search for servers for this org by asking for org:CHServers:CHServers") (\CH.LOCATE.SERVERS (GETCLEARINGHOUSE) (create NSNAME NSOBJECT _ ORGANIZATION NSDOMAIN _ "CHServers" NSORGANIZATION _ "CHServers") NOERRORFLG ORGANIZATION) (\CH.FIND.ORG.SERVER ORGANIZATION NOERRORFLG T]) (\CH.LOCATE.SERVERS [LAMBDA (CHSERVER SERVERGROUP NOERRORFLG ORGANIZATION DOMAIN) (* bvm%: "26-Jul-85 12:42") (* ;;; "Talks to clearinghouse CHSERVER asking it to enumerate the class of servers SERVERGROUP. We then locate each server and update the cache") (PROG (STREAM CHLIST CHNAMES NOROUTE) (\CH.PRINT.BLURB "Finding Clearinghouse server for " DOMAIN ORGANIZATION) (OR [COND ((SETQ STREAM (COURIER.OPEN CHSERVER NIL NOERRORFLG 'CLEARINGHOUSE)) (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) STREAM)) [COND ((AND (SETQ CHNAMES (CH.RETRIEVE.MEMBERS SERVERGROUP (CH.PROPERTY 'MEMBERS) STREAM)) (NEQ (CAR CHNAMES) 'ERROR)) (SETQ CHLIST (SORT.NSADDRESSES.BY.DISTANCE (for CH in CHNAMES bind INFO when (SETQ INFO (COURIER.CALL STREAM 'CLEARINGHOUSE 'RETRIEVE.ITEM CH (CH.PROPERTY 'ADDRESS.LIST) (CH.GETAUTHENTICATOR) 'NOERROR)) collect (LIST (CAR (COURIER.READ.REP (CADR INFO) 'CLEARINGHOUSE 'NETWORK.ADDRESS.LIST)) (CAR INFO]) (* ;; "Now have a list of all servers for the desired domain in hop order. Find the first one that's up, and make sure it serves the domain that the hint claimed. Could update cache with all domains it serves, but then we would be in danger of picking a distant server we know about in preference to a close server we haven't discovered yet") (for PAIR in CHLIST bind CHDOMAINS DOM when [COND ([NOT (\LOCATE.NSNET (fetch NSNET of (CAR PAIR] (* ;  "Give up when we get to inaccessible hosts") (SETQ NOROUTE T) (RETURN)) ((SETQ CHDOMAINS (CH.DOMAINS.SERVED (CAR PAIR))) (for old DOM in CHDOMAINS thereis (AND (OR (NULL DOMAIN) (STRING-EQUAL (fetch NSDOMAIN of DOM) DOMAIN)) (STRING-EQUAL (fetch NSORGANIZATION of DOM) ORGANIZATION] do (\CH.UPDATE.CACHE (CADR PAIR) (CAR PAIR) (LIST DOM)) (RETURN T] (\CH.PRINT.BLURB (COND ((EQ (CAR CHNAMES) 'ERROR) "Unknown domain: ") (NOROUTE "No network route to Clearinghouse for ") (T "Unable to contact Clearinghouse for ")) DOMAIN ORGANIZATION]) (\CH.PRINT.BLURB [LAMBDA (MSG DOMAIN ORGANIZATION) (* bvm%: "29-Jul-84 22:40") (printout PROMPTWINDOW T "[" MSG) [COND (DOMAIN (printout PROMPTWINDOW DOMAIN '%:] (printout PROMPTWINDOW ORGANIZATION "]"]) (\CH.UPDATE.CACHE [LAMBDA (OBJECT ADDRESS DOMAINS.SERVED) (* ; "Edited 23-Jul-87 12:19 by bvm:") (* ;; "Note the clearinghouse named OBJECT with given ADDRESS as serving each of the domains in DOMAINS.SERVED.") (* ;; "The Clearinghouse cache is sorted by organization and then by domain within org. Currently, we don't time out entries or do anything useful when servers go down.") (PROG (NAME.AND.ADDRESS ORGANIZATION DOMAINSTRING ORGANIZATION.INFO) (printout PROMPTWINDOW .TAB0 0 "[Noting Clearinghouse " (fetch NSOBJECT of OBJECT) "]") (SETQ NAME.AND.ADDRESS (LIST ADDRESS OBJECT)) [for DOMAIN in DOMAINS.SERVED do (SETQ ORGANIZATION (fetch NSORGANIZATION of DOMAIN)) (SETQ DOMAINSTRING (fetch NSDOMAIN of DOMAIN)) [COND ([NOT (SETQ ORGANIZATION.INFO (find X in \CH.CACHE suchthat (STRING-EQUAL (fetch OCORGANIZATION of X) ORGANIZATION] (SETQ \CH.CACHE (NCONC1 \CH.CACHE (SETQ ORGANIZATION.INFO (create ORGCACHE OCORGANIZATION _ ORGANIZATION] [for DOMAIN.INFO in (fetch OCDOMAINS of ORGANIZATION.INFO) when (STRING-EQUAL (fetch DCDOMAIN of DOMAIN.INFO) DOMAINSTRING) do (push (fetch DCKNOWNSERVERS of DOMAIN.INFO) NAME.AND.ADDRESS) (RETURN (SORT.NSADDRESSES.BY.DISTANCE (fetch DCKNOWNSERVERS of DOMAIN.INFO))) finally (push (fetch OCDOMAINS of ORGANIZATION.INFO) (create DOMAINCACHE DCDOMAIN _ DOMAINSTRING DCKNOWNSERVERS _ (LIST NAME.AND.ADDRESS] (if (NOT (MEMB NAME.AND.ADDRESS (fetch OCALLSERVERS of ORGANIZATION.INFO ))) then (* ; "Also add server to list of all servers for the organization. Note that the MEMB test is a quicky, only testing for duplicates on this call.") (SORT.NSADDRESSES.BY.DISTANCE (push (fetch OCALLSERVERS of ORGANIZATION.INFO) NAME.AND.ADDRESS] (COND (CLEARINGHOUSE.STRUCTURE.WINDOW (SHOW.CLEARINGHOUSE]) (EQUAL.CH.NAMES [LAMBDA (NAME1 NAME2) (* ; "Edited 6-Dec-88 16:22 by jds") (* ;; "Check if two Clearinghouse names are the same.") (AND (type? NSNAME NAME1) (type? NSNAME NAME2) (STRING-EQUAL (fetch (NSNAME NSOBJECT) of NAME1) (fetch (NSNAME NSOBJECT) of NAME2)) (STRING-EQUAL (fetch (NSNAME NSDOMAIN) of NAME1) (fetch (NSNAME NSDOMAIN) of NAME2)) (STRING-EQUAL (fetch (NSNAME NSORGANIZATION) of NAME1) (fetch (NSNAME NSORGANIZATION) of NAME2]) (PARSE.NSNAME [LAMBDA (NAME %#PARTS DEFAULTDOMAIN) (* bvm%: " 3-Jul-84 16:26") (* ;;; "Coerces NAME to a 3-part NS name. If #PARTS is 1 or 2 then interprets NAME as 1 or 2-part name, discarding the object and/or domain name if supplied. 3-part names are objects of type NSNAME --- 2-part names are objects of type NSNAME with an OBJECT field of NIL --- A 1 part name is simply the organization string. --- DEFAULTDOMAIN is the default to supply for missing parts, which in turn default to CH.DEFAULT.DOMAIN and CH.DEFAULT.ORGANIZATION --- If NAME is already an NSNAME, returns it or a copy if #PARTS implies coercion.") (COND ((type? NSNAME NAME) (SELECTQ %#PARTS ((NIL 3) NAME) (2 (COND ((fetch NSOBJECT of NAME) (create NSNAME using NAME NSOBJECT _ NIL)) (T NAME))) (1 (fetch NSORGANIZATION of NAME)) (LISPERROR "ILLEGAL ARG" %#PARTS))) [[OR (STRINGP NAME) (AND (NULL NAME) (SETQ NAME "*")) (AND (LITATOM NAME) (SETQ NAME (MKSTRING NAME] (PROG (FIRSTPART SECONDPART THIRDPART I J) (GETCLEARINGHOUSE) (COND [(SETQ I (STRPOS ":" NAME)) (SETQ FIRSTPART (SUBSTRING NAME 1 (SUB1 I))) (SETQ SECONDPART (SUBSTRING NAME (ADD1 I) (COND ((SETQ J (STRPOS ":" NAME (ADD1 I))) (SETQ THIRDPART (SUBSTRING NAME (ADD1 J) NIL)) (SUB1 J] (T (SETQ FIRSTPART NAME))) (RETURN (SELECTQ %#PARTS ((NIL 3) (create NSNAME NSOBJECT _ FIRSTPART NSDOMAIN _ (COND (SECONDPART) (DEFAULTDOMAIN (fetch NSDOMAIN of DEFAULTDOMAIN )) (T CH.DEFAULT.DOMAIN)) NSORGANIZATION _ (COND (THIRDPART) (DEFAULTDOMAIN (fetch NSORGANIZATION of DEFAULTDOMAIN)) (T CH.DEFAULT.ORGANIZATION)))) (2 (create NSNAME NSDOMAIN _ (OR (AND THIRDPART SECONDPART) FIRSTPART) NSORGANIZATION _ (COND (THIRDPART) (SECONDPART) (DEFAULTDOMAIN (fetch NSORGANIZATION of DEFAULTDOMAIN)) (T CH.DEFAULT.ORGANIZATION)))) (1 (OR THIRDPART SECONDPART FIRSTPART)) (LISPERROR "ILLEGAL ARG" %#PARTS] (T (LISPERROR "ILLEGAL ARG" NAME]) (CH.NAME.TO.STRING [LAMBDA (NSNAME FULLNAMEFLG) (* bvm%: "28-Jun-84 16:37") (* ;; "Return a string for a Clearinghouse name. Leaves off default components unless FULLNAMEFLG is set.") (NSNAME.TO.STRING (COND ((type? NSNAME NSNAME) NSNAME) (T (PARSE.NSNAME NSNAME))) FULLNAMEFLG]) (CANONICAL.CH.NAME [LAMBDA (NAME) (* bvm%: "28-Jun-84 16:37") (MKATOM (NSNAME.TO.STRING (PARSE.NSNAME NAME]) (CH.PROPERTY [LAMBDA (PROP) (* bvm%: "27-Aug-86 10:38") (* ;; "Return the official Clearinghouse property ID for the specified property.") (OR (COND [(LITATOM PROP) (for PAIR in CH.PROPERTIES when (EQ (CAR PAIR) PROP) do (RETURN (CADR PAIR] (T (FIXP PROP))) (ERROR "Unknown Clearinghouse property" PROP]) (CH.GETAUTHENTICATOR [LAMBDA (NONTRIVIAL) (* bvm%: " 3-Jul-84 21:51") (COND [NONTRIVIAL (PROG [(INFO (\INTERNAL/GETPASSWORD '|NS::|] (RETURN (COND (INFO (SETQ INFO (NS.MAKE.SIMPLE.CREDENTIALS INFO)) (COURIER.CREATE (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS _ (CAR INFO) VERIFIER _ (CDR INFO))) (T (ERROR!] (T (COURIER.CREATE (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS _ (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ 'SIMPLE VALUE _ NIL) VERIFIER _ '(0]) ) (DEFINEQ (CH.SERVERS [LAMBDA NIL (* bvm%: " 3-Jul-84 14:10") (* ;; "Return a list of the names of all Clearinghouse servers.") (COURIER.CALL (GETCLEARINGHOUSE) 'CLEARINGHOUSE 'RETRIEVE.MEMBERS (create NSNAME NSOBJECT _ "CHServers" NSDOMAIN _ "CHServers" NSORGANIZATION _ "CHServers") (CH.PROPERTY 'MEMBERS) '(CLEARINGHOUSE . OBJECT.NAME) (CH.GETAUTHENTICATOR]) (\CH.GUESS.NEW.PROPERTIES [LAMBDA (DOMAIN MINPROPERTYID MAXPROPERTYID) (* bvm%: " 4-Jul-84 14:25") (* ;; "This is a hack that finds all the objects in the given domain with any properties in the given range. Useful for finding out what the Services people are up to.") (PROG ((PATTERN (PARSE.NSNAME DOMAIN 2)) OBJECTS) (SETQ PATTERN (create NSNAME using PATTERN NSOBJECT _ "*")) (SETQ MINPROPERTYID (OR MINPROPERTYID 1)) (SETQ MAXPROPERTYID (OR MAXPROPERTYID 25)) (RETURN (for ID from MINPROPERTYID to MAXPROPERTYID when (SETQ OBJECTS (CH.LIST.OBJECTS PATTERN ID)) collect (CONS ID OBJECTS]) ) (* ; "Clearinghouse calls") (DEFINEQ (CH.DOMAINS.SERVED [LAMBDA (CHADDRESS) (* bvm%: " 3-Jul-84 14:12") (* ;; "We wrap this in an NLSETQ because we might get an error underneath the Bulk Data transfer if we're not really talking to a Clearinghouse.") (CAR (NLSETQ (COURIER.CALL CHADDRESS 'CLEARINGHOUSE 'LIST.DOMAINS.SERVED '(CLEARINGHOUSE . DOMAIN.NAME) (CH.GETAUTHENTICATOR]) (CH.CREATE.OBJECT [LAMBDA (OBJECTNAME STREAM) (* jwo%: " 8-Jul-85 14:13") (* ;;; "Creates an object with given name, no properties") (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME)) (OR (COURIER.CALL (OR STREAM (CH.FINDSERVER OBJECTNAME)) 'CLEARINGHOUSE 'CREATE.OBJECT OBJECTNAME (CH.GETAUTHENTICATOR T) 'RETURNERRORS) OBJECTNAME]) (CH.DELETE.OBJECT [LAMBDA (OBJECTNAME STREAM) (* jwo%: " 8-Jul-85 14:06") (* ;;; "Deletes specified object from Clearinghouse database") (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME)) (OR (COURIER.CALL (OR STREAM (CH.FINDSERVER OBJECTNAME)) 'CLEARINGHOUSE 'DELETE.OBJECT OBJECTNAME (CH.GETAUTHENTICATOR T) 'RETURNERRORS) OBJECTNAME]) (CH.CREATE.ALIAS [LAMBDA (ALIAS OBJECTNAME) (* ; "Edited 31-Jul-87 11:02 by bvm:") (* ;;; "Makes ALIAS be an alias of OBJECTNAME in the Clearinghouse database") (COURIER.CALL (CH.FINDSERVER (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME))) 'CLEARINGHOUSE 'CREATE.ALIAS (PARSE.NSNAME ALIAS) OBJECTNAME (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) (CH.DELETE.ALIAS [LAMBDA (ALIAS) (* jwo%: "10-Jun-85 21:03") (* ;;; "Deletes specified alias from Clearinghouse database") (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ ALIAS (PARSE.NSNAME ALIAS))) \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'DELETE.ALIAS ALIAS (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) (CH.LIST.ALIASES [LAMBDA (OBJECTNAMEPATTERN) (* ; "Edited 24-Jul-87 17:45 by bvm:") (COURIER.CALL (CH.FINDSERVER (SETQ OBJECTNAMEPATTERN (PARSE.NSNAME OBJECTNAMEPATTERN))) 'CLEARINGHOUSE 'LIST.ALIASES OBJECTNAMEPATTERN '(CLEARINGHOUSE . OBJECT) (CH.GETAUTHENTICATOR) 'RETURNERRORS]) (CH.LIST.ALIASES.OF [LAMBDA (OBJECTPATTERN) (* ; "Edited 24-Jul-87 18:05 by bvm:") (COURIER.CALL (CH.FINDSERVER (SETQ OBJECTPATTERN (PARSE.NSNAME OBJECTPATTERN))) 'CLEARINGHOUSE 'LIST.ALIASES.OF OBJECTPATTERN '(CLEARINGHOUSE . OBJECT.NAME) (CH.GETAUTHENTICATOR) 'NOERROR]) (CH.LOOKUP.OBJECT [LAMBDA (OBJECTPATTERN) (* bvm%: "28-Jun-84 16:37") (* ;;; "Returns the canonical name of the specified object. If object contains wildcards, result is the first match") (SETQ OBJECTPATTERN (PARSE.NSNAME OBJECTPATTERN)) (PROG ((ADDRESS (CH.FINDSERVER OBJECTPATTERN T))) (RETURN (AND ADDRESS (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'LOOKUP.OBJECT OBJECTPATTERN (CH.GETAUTHENTICATOR) 'NOERROR]) (CH.DELETE.PROPERTY [LAMBDA (OBJECTNAME PROPERTY) (* jwo%: "10-Jun-85 21:04") (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME))) \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'DELETE.PROPERTY OBJECTNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) ) (DEFINEQ (CH.RETRIEVE.MEMBERS [LAMBDA (OBJECTPATTERN PROPERTY STREAM) (* bvm%: "21-Feb-86 14:33") (SETQ OBJECTPATTERN (PARSE.NSNAME OBJECTPATTERN)) (COURIER.CALL (OR STREAM (CH.FINDSERVER OBJECTPATTERN)) 'CLEARINGHOUSE 'RETRIEVE.MEMBERS OBJECTPATTERN [COND (PROPERTY (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY))) (T (CH.PROPERTY 'MEMBERS] '(CLEARINGHOUSE . OBJECT.NAME) (CH.GETAUTHENTICATOR) 'RETURNERRORS]) (CH.ISMEMBER [LAMBDA (GROUPNAME PROPERTY SECONDARYPROPERTY NAME) (* bvm%: " 4-Jul-84 14:21") (CAR (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ GROUPNAME (PARSE.NSNAME GROUPNAME))) \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'IS.MEMBER GROUPNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (COND ((NULL SECONDARYPROPERTY) \CH.NULL.PROPERTY) ((FIXP SECONDARYPROPERTY)) (T (CH.PROPERTY SECONDARYPROPERTY))) (PARSE.NSNAME NAME) (CH.GETAUTHENTICATOR) 'RETURNERRORS]) (CH.ADD.SELF [LAMBDA (GROUPNAME PROPERTY STREAM) (* jwo%: " 7-Jul-85 17:24") (SETQ GROUPNAME (PARSE.NSNAME GROUPNAME)) (COURIER.CALL (OR STREAM (CH.FINDSERVER GROUPNAME)) 'CLEARINGHOUSE 'ADD.SELF GROUPNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) (CH.DELETE.SELF [LAMBDA (GROUPNAME PROPERTY STREAM) (* jwo%: " 7-Jul-85 17:24") (SETQ GROUPNAME (PARSE.NSNAME GROUPNAME)) (COURIER.CALL (OR STREAM (CH.FINDSERVER GROUPNAME)) 'CLEARINGHOUSE 'DELETE.SELF GROUPNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) ) (DEFINEQ (CH.RETRIEVE.ITEM [LAMBDA (OBJECTPATTERN PROPERTY INTERPRETATION) (* bvm%: "28-Jun-84 16:37") (* ;;; "Retrieves item property PROPERTY of object OBJECTPATTERN, returning (CanonicalName Value); If INTERPRETATION is given, then Value is interpreted via it, otherwise Value is just a SEQUENCE of UNSPECIFIED") (SETQ OBJECTPATTERN (PARSE.NSNAME OBJECTPATTERN)) (PROG ((ADDRESS (CH.FINDSERVER OBJECTPATTERN T)) NAME&VALUE) [COND ((AND ADDRESS (SETQ NAME&VALUE (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'RETRIEVE.ITEM OBJECTPATTERN (CH.PROPERTY PROPERTY) (CH.GETAUTHENTICATOR) 'NOERROR)) INTERPRETATION) (RPLACA (CDR NAME&VALUE) (COURIER.READ.REP (CADR NAME&VALUE) 'CLEARINGHOUSE INTERPRETATION] (RETURN NAME&VALUE]) (CH.ADD.ITEM.PROPERTY [LAMBDA (OBJECTNAME PROPERTY VALUE INTERPRETATION STREAM) (* lmm " 9-Jan-86 02:12") (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME)) (COURIER.CALL (OR STREAM (CH.FINDSERVER OBJECTNAME)) 'CLEARINGHOUSE 'ADD.ITEM.PROPERTY OBJECTNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (COND (INTERPRETATION (COURIER.WRITE.REP VALUE 'CLEARINGHOUSE INTERPRETATION)) (T VALUE)) (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) (CH.CHANGE.ITEM [LAMBDA (OBJECTNAME PROPERTY NEWVALUE INTERPRETATION) (* jwo%: "10-Jun-85 21:07") (COURIER.EXPEDITED.CALL (CH.FINDSERVER (SETQ OBJECTNAME (PARSE.NSNAME OBJECTNAME))) \CH.BROADCAST.SOCKET 'CLEARINGHOUSE 'CHANGE.ITEM OBJECTNAME (OR (FIXP PROPERTY) (CH.PROPERTY PROPERTY)) (COND (INTERPRETATION (COURIER.WRITE.REP NEWVALUE NIL INTERPRETATION)) (T NEWVALUE)) (CH.GETAUTHENTICATOR T) 'RETURNERRORS]) ) (DEFINEQ (CH.LIST.DOMAINS [LAMBDA (DOMAINPATTERN) (* ; "Edited 24-Jul-87 17:53 by bvm:") (SETQ DOMAINPATTERN (PARSE.NSNAME DOMAINPATTERN 2)) (COURIER.CALL [CAR (CAR (fetch OCALLSERVERS of (\CH.FIND.ORG.SERVER (fetch NSORGANIZATION of DOMAINPATTERN ) T] 'CLEARINGHOUSE 'LIST.DOMAINS DOMAINPATTERN '(CLEARINGHOUSE . DOMAIN) (CH.GETAUTHENTICATOR) 'RETURNERRORS]) ) (* ;; "NOTE: the following functions were moved to the file AUTHENTICATION temporarily for benefit of Lyric users wanting a functional NSMAINTAIN: CH.LIST.PROPERTIES CH.LIST.ORGANIZATIONS CH.LIST.OBJECTS CH.DELETE.MEMBER CH.ADD.MEMBER CH.ADD.GROUP.PROPERTY" ) (* ; "Other entries") (DEFINEQ (LOOKUP.NS.SERVER [LAMBDA (NAME TYPE FULLFLG) (* bvm%: "27-Aug-86 10:21") (* ;; "Return the NS address of the specified server. If a type is given, use the Clearinghouse if the address isn't in the cache.") (SETQ NAME (PARSE.NSNAME NAME)) (PROG (ADDRESSES NAME&VALUE ENTRY) (COND ((find old ENTRY in NS.SERVER.NAMES.TO.ADDRESSES suchthat (EQUAL.CH.NAMES (CAR ENTRY) NAME))) [[SETQ NAME&VALUE (COND (TYPE (CH.RETRIEVE.ITEM NAME TYPE 'NETWORK.ADDRESS)) (T (CH.RETRIEVE.ITEM NAME (CH.PROPERTY 'ADDRESS.LIST) 'NETWORK.ADDRESS.LIST] [push NS.SERVER.NAMES.TO.ADDRESSES (SETQ ENTRY (CONS (CAR NAME&VALUE) (SETQ ADDRESSES (COND (TYPE (* ; "Old way") (LIST (CADR NAME&VALUE))) (T (CADR NAME&VALUE] (COND (*ASSUME-ZERO-NSSOCKETS* (* ;  "Stupidity. Old clearinghouses sometimes give a nonzero socket here. Why?") (for ADDR in (CDR ENTRY) do (replace NSSOCKET of ADDR with 0] (T (RETURN))) (RETURN (COND (FULLFLG ENTRY) (T (CADR ENTRY]) (\CANONICAL.NSHOSTNAME [LAMBDA (HOST) (* bvm%: " 5-Feb-85 18:37") (PROG [(INFO (OR (LOOKUP.NS.SERVER HOST NIL T) (LOOKUP.NS.SERVER HOST 'FILESERVER T] (RETURN (AND INFO (MKATOM (NSNAME.TO.STRING (CAR INFO) T]) (CH.CANONICAL.NAME [LAMBDA (NAME) (* bvm%: " 4-Jul-84 14:46") (* ;;; "Canonicalizes name, unless it is a pattern. Result is a standard 3-part name. Name is not required to be a valid Clearinghouse name, but if it is, it is dereferenced to its distinguished name") (PROG ((PARSED (PARSE.NSNAME NAME))) (RETURN (OR (AND (NOT (STRPOS '* NAME)) (CH.LOOKUP.OBJECT PARSED)) PARSED]) ) (RPAQ? *ASSUME-ZERO-NSSOCKETS* T) (FILESLOAD AUTHENTICATION) (PUTPROPS CLEARINGHOUSE COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (18628 21596 (\NSNAME.DEFPRINT 18638 . 18791) (NSNAME.TO.STRING 18793 . 19745) ( COURIER.READ.NSNAME 19747 . 20189) (COURIER.WRITE.NSNAME 20191 . 20638) (COURIER.NSNAME.LENGTH 20640 . 21594)) (21635 46682 (GETCLEARINGHOUSE 21645 . 22599) (\CH.CHECK.CLEARINGHOUSE 22601 . 24666) ( START.CLEARINGHOUSE 24668 . 25039) (SHOW.CLEARINGHOUSE 25041 . 27292) (CH.FINDSERVER 27294 . 29307) ( \CH.FIND.ORG.SERVER 29309 . 32267) (\CH.LOCATE.SERVERS 32269 . 36523) (\CH.PRINT.BLURB 36525 . 36782) (\CH.UPDATE.CACHE 36784 . 40290) (EQUAL.CH.NAMES 40292 . 40938) (PARSE.NSNAME 40940 . 44724) ( CH.NAME.TO.STRING 44726 . 45171) (CANONICAL.CH.NAME 45173 . 45347) (CH.PROPERTY 45349 . 45839) ( CH.GETAUTHENTICATOR 45841 . 46680)) (46683 48010 (CH.SERVERS 46693 . 47251) (\CH.GUESS.NEW.PROPERTIES 47253 . 48008)) (48047 52191 (CH.DOMAINS.SERVED 48057 . 48575) (CH.CREATE.OBJECT 48577 . 49023) ( CH.DELETE.OBJECT 49025 . 49475) (CH.CREATE.ALIAS 49477 . 49946) (CH.DELETE.ALIAS 49948 . 50359) ( CH.LIST.ALIASES 50361 . 50744) (CH.LIST.ALIASES.OF 50746 . 51123) (CH.LOOKUP.OBJECT 51125 . 51721) ( CH.DELETE.PROPERTY 51723 . 52189)) (52192 54458 (CH.RETRIEVE.MEMBERS 52202 . 52863) (CH.ISMEMBER 52865 . 53593) (CH.ADD.SELF 53595 . 54020) (CH.DELETE.SELF 54022 . 54456)) (54459 56900 (CH.RETRIEVE.ITEM 54469 . 55668) (CH.ADD.ITEM.PROPERTY 55670 . 56318) (CH.CHANGE.ITEM 56320 . 56898)) (56901 57809 ( CH.LIST.DOMAINS 56911 . 57807)) (58109 60929 (LOOKUP.NS.SERVER 58119 . 60061) (\CANONICAL.NSHOSTNAME 60063 . 60416) (CH.CANONICAL.NAME 60418 . 60927))))) STOP \ No newline at end of file diff --git a/sources/CLISP b/sources/CLISP new file mode 100644 index 00000000..ffa417ed --- /dev/null +++ b/sources/CLISP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 12:27:02" {DSK}local>lde>lispcore>sources>CLISP.;2 45083 changes to%: (VARS CLISPCOMS) previous date%: "26-Nov-86 12:32:58" {DSK}local>lde>lispcore>sources>CLISP.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT CLISPCOMS) (RPAQQ CLISPCOMS [(COMS (* ; "DWIM stuff") [INITVARS (NOFIXFNSLST0) (NOFIXVARSLST0) (NOSPELLFLG) (LPARKEY 9) (RPARKEY 0) (WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL] (USERMACROS FIX8 FIX9) (ADDVARS (DWIMUSERFORMS) (LAMBDASPLST LAMBDA NLAMBDA) (OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND NEQ NOT NULL) (NOFIXFNSLST) (NOFIXVARSLST) (GLOBALVARS) (LOCALVARS) (SPECVARS) (NLAMA) (NLAML) (LAMA) (LAMS)) (P (MOVD? 'NILL 'FREEVARS)) (PROP FILEDEF BREAKDOWN CALLS CLISPRECORD SETUPHASHARRAY MAKEMATCH) (VARS (DWIMIFYFLG 'EVAL) (COMPILEUSERFN 'COMPILEUSERFN) (CLISPTRANFLG 'CLISP% ) (DWIMESSGAG)) (INITVARS (DWIMCHECK#ARGSFLG T) (DWIMCHECKPROGLABELSFLG T) (%#CLISPARRAY 250) (RECORDHASHFLG T) (CLISPRETRANFLG)) (ADDVARS (DWIMEQUIVLST)) (USERMACROS DW !DW CLISP%: NOCLISP PPT)) (COMS (* CLISP props) (PROP CLISPTYPE %') [E (SETQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) (CLISPDEC '(STANDARD MIXED] [VARS (CLISPFLG T) (CLISPCHARS '(^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­] (INITVARS (CLISPHELPFLG T) (TREATASCLISPFLG) (CLISPINFIXSPLST) (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) [LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬] (LEFT.ARROW '_) (CLISPISWORDSPLST) (CLISPLASTSUB (CONS)) (CHECKCARATOMFLG) (CLISPARITHOPLST '(+ - * / +- LT GT lt gt GEQ LEQ GE LE geq leq ge le)) (CLISPARITHCLASSLST '(INTEGER FIXED MIXED FLOATING)) (DWIMINMACROSFLG NIL)) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPBRACKET) ­ ^ * / + - = _ ¬ %: %' ~ +- ~= < > @ !) (VARS DECLWORDS) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG BROADSCOPE) * (PROGN DECLWORDS)) (IFPROP (CLISPTYPE LISPFN UNARYOP CLISPINFIX CLISPCLASS CLISPCLASSDEF CLISPNEG BROADSCOPE) LT lt GT gt LE le GE ge LEQ leq GEQ geq EQ NEQ EQP EQUAL EQUALS NOT AND OR and or NOR nor MEMBER SETQ IPLUS IMINUS IDIFFERENCE ITIMES IQUOTIENT ILESSP IGREATERP FPLUS FMINUS FDIFFERENCE FTIMES FQUOTIENT FGTP PLUS MINUS DIFFERENCE TIMES QUOTIENT LESSP GREATERP EXPT -> =>) (PROP SETFN ELT SETA) (OPTIMIZERS CLISP% )) (PROP CLISPWORD AND OR and or ! !! CLISP clisp MATCH match) (COMS (* IF) (VARS CLISPIFWORDSPLST) (INITVARS (CLISPIFTRANFLG T)) (PROP CLISPWORD IF THEN ELSE ELSEIF if then else elseif)) (COMS (* I.S.OPR) (VARS (CLISPI.S.GAG)) (PROP CLISPWORD * INITISOPRS) (IFPROP I.S.OPR * (PROGN INITISOPRS)) [ADDVARS * (LIST (CONS 'I.S.OPRLST INITISOPRS) (CONS 'CLISPFORWORDSPLST (SUBSET INITISOPRS 'U-CASEP] [VARS (CLISPDUMMYFORVARS '($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6] (ADDVARS * (LIST (CONS 'SYSLOCALVARS CLISPDUMMYFORVARS) (CONS 'INVISIBLEVARS CLISPDUMMYFORVARS))) (ADDVARS (SYSLOCALVARS $$VAL $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$END $$EXTREME) (INVISIBLEVARS $$VAL $$END $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$EXTREME)) (FILEPKGCOMS I.S.OPRS) (FNS DUMPI.S.OPRS GETDEF.I.S.OPR)) (COMS (* forDuration) (ADDVARS (DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits) (USINGBOX usingBox usingbox) (USINGTIMER usingTimer usingtimer) (FORDURATION forDuration forduration DURING during) (RESOURCENAME resourceName resourcename) (UNTILDATE untilDate untildate))) (IFPROP (CLISPWORD \DURATIONTRAN) * (APPLY 'APPEND DURATIONCLISPWORDS)) (RESOURCES \ForDurationOfBox)) (COMS (* ;; "Currently there are four possible entries for the INFO property: EVAL, BINDS, LABELS, PROGN, or a list containg any or all of these.") (* ;; "EVAL is used to indicate that an nlambda evaluates its arguments. EVAL affects DWIMIFY and CLISPIFY: neither will touch an nlambda that does not have this property.") (* ;; "BINDS tells clispify and dwimify that CADR of the form is a list of variables being bound, a la prog.") (* ;; "PROGN says that only the last top level expression is being used for value. This affects the way OR's and AND's are clispified, for example.") (* ;; "Finally, LABELS indicates that top level atoms in this expression are not being evaluated. This tells clispify not to create atoms out of lists at the top level. LABELS also implies that none of the top level expressions are being used for value.") (* ;; "For example, FOR has info property just BINDS, (EVAL is unnecssary since FOR is not a function and its dwimifying and clispifying affected by its clispword property), whereas PROG has (BINDS EVAL LABELS), and LAMBDA has (EVAL BINDS PROGN)") (PROP INFO PROG PROG* RESETVARS RESETBUFS RESETLST ADV-PROG ADV-SETQ AND ARG COND ERSETQ NLSETQ OR PROG1 PROG2 PROGN RESETFORM RESETSAVE RESETVAR RPAQ RPTQ FRPTQ SAVESETQ SETN SETQ UNDONLSETQ XNLSETQ SETARG LET LET* RETURN)) (PROP FILETYPE CLISP) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DUMPI.S.OPRS) (NLAML) (LAMA]) (* ; "DWIM stuff") (RPAQ? NOFIXFNSLST0 ) (RPAQ? NOFIXVARSLST0 ) (RPAQ? NOSPELLFLG ) (RPAQ? LPARKEY 9) (RPAQ? RPARKEY 0) (RPAQ? WTFIXCHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (RPAQ? WTFIXCHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (ADDTOVAR EDITMACROS (FIX9 (X N) (BIND (E (SETQ %#1 (EDITFPAT 'X)) T) (IF (NOT (ATOM (%##))) (1)) (COMS (SPLIT89 RPARKEY N)) (I F RPARKEY T) (E [SETQ %#2 (ADD1 (LENGTH (CAR L] T) !0 MARK (LPQ [IF (OR (NULL %#1) (NOT (EDIT4E %#1 (%## 1] UP (E (SETQ %#3 (LENGTH (CAR L))) T) (I RI 1 (MINUS %#2)) (E (SETQ %#2 %#3) T) 1 !0) __ (DELETE NX))) (FIX9 NIL (FIX9)) (FIX8 (X N) (BIND (E (SETQ %#1 (EDITFPAT 'X)) T) (IF (LISTP (%##)) (1)) (COMS (SPLIT89 LPARKEY N)) (I F LPARKEY T) (1) (LI 1) (IF (TAILP (CAR L) (CADR L)) (!0) NIL) (LPQ [IF (OR (NULL %#1) (NOT (EDIT4E %#1 (%## 1] UP (RO 1) !0))) (FIX8 NIL (FIX8))) (ADDTOVAR DWIMUSERFORMS ) (ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA) (ADDTOVAR OKREEVALST AND OR PROGN SAVESETQ CAR CDR ADD1 SUB1 CONS LIST EQ EQUAL PRINT PRIN1 APPEND NEQ NOT NULL) (ADDTOVAR NOFIXFNSLST ) (ADDTOVAR NOFIXVARSLST ) (ADDTOVAR GLOBALVARS ) (ADDTOVAR LOCALVARS ) (ADDTOVAR SPECVARS ) (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) (ADDTOVAR LAMS ) (MOVD? 'NILL 'FREEVARS) (PUTPROPS BREAKDOWN FILEDEF BRKDWN) (PUTPROPS CALLS FILEDEF MSANALYZE) (PUTPROPS CLISPRECORD FILEDEF RECORD) (PUTPROPS SETUPHASHARRAY FILEDEF (RECORD SETUPHASHARRAY)) (PUTPROPS MAKEMATCH FILEDEF MATCH) (RPAQQ DWIMIFYFLG EVAL) (RPAQQ COMPILEUSERFN COMPILEUSERFN) (RPAQQ CLISPTRANFLG CLISP% ) (RPAQQ DWIMESSGAG NIL) (RPAQ? DWIMCHECK#ARGSFLG T) (RPAQ? DWIMCHECKPROGLABELSFLG T) (RPAQ? %#CLISPARRAY 250) (RPAQ? RECORDHASHFLG T) (RPAQ? CLISPRETRANFLG ) (ADDTOVAR DWIMEQUIVLST ) (ADDTOVAR EDITMACROS (DW NIL (BIND (E (PROGN (SETQ %#1 (%##)) (AND (CDR L) (%## !0 (E (SETQ %#2 L) T))) (AND [SETQ %#3 (DWIMIFY %#1 T (OR %#2 '(NIL] EDITCHANGES (RPLACA (CDR EDITCHANGES) T))) T) (IF (NLISTP %#1) ((I %: %#3) (IF (LISTP %#3) (1) NIL)) NIL))) (PPT NIL (RESETVAR PRETTYTRANFLG T PP)) (!DW NIL (RESETVAR CLISPRETRANFLG T DW)) (NOCLISP NIL (NOCLISP TTY%:)) (NOCLISP COMS (RESETVAR CLISPTRANFLG NIL . COMS)) (CLISP%: NIL (BIND (E (COND ((SETQ %#1 (AND CLISPARRAY (GETHASH (%##) CLISPARRAY))) (SETQQ COM CLISP%:) (EDITE %#1)) (T (PRIN1 '"not translated. " T))) T)))) (ADDTOVAR EDITCOMSA PPT DW !DW CLISP%:) (* CLISP props) (PUTPROPS %' CLISPTYPE 15) (RPAQQ CLISPFLG T) (RPAQQ CLISPCHARS (^ * / + - = _ %: %' ~ +- ~= < > @ ! ¬ ­)) (RPAQ? CLISPHELPFLG T) (RPAQ? TREATASCLISPFLG ) (RPAQ? CLISPINFIXSPLST ) (RPAQ? CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (RPAQ? LEFT.ARROWS.BITTABLE (MAKEBITTABLE '(_ ¬))) (RPAQ? LEFT.ARROW '_) (RPAQ? CLISPISWORDSPLST ) (RPAQ? CLISPLASTSUB (CONS)) (RPAQ? CHECKCARATOMFLG ) (RPAQ? CLISPARITHOPLST '(+ - * / +- LT GT lt gt GEQ LEQ GE LE geq leq ge le)) (RPAQ? CLISPARITHCLASSLST '(INTEGER FIXED MIXED FLOATING)) (RPAQ? DWIMINMACROSFLG NIL) (PUTPROPS ­ CLISPTYPE 6) (PUTPROPS ^ CLISPTYPE 6) (PUTPROPS * CLISPTYPE 4) (PUTPROPS / CLISPTYPE 4) (PUTPROPS + CLISPTYPE 2) (PUTPROPS - CLISPTYPE 7) (PUTPROPS = CLISPTYPE -20) (PUTPROPS _ CLISPTYPE (8 . -12)) (PUTPROPS ¬ CLISPTYPE (8 . -12)) (PUTPROPS %: CLISPTYPE (14 . 13)) (PUTPROPS %' CLISPTYPE 15) (PUTPROPS ~ CLISPTYPE 7) (PUTPROPS +- CLISPTYPE 2) (PUTPROPS < CLISPTYPE BRACKET) (PUTPROPS > CLISPTYPE BRACKET) (PUTPROPS ­ LISPFN EXPT) (PUTPROPS ^ LISPFN EXPT) (PUTPROPS * LISPFN TIMES) (PUTPROPS / LISPFN QUOTIENT) (PUTPROPS + LISPFN PLUS) (PUTPROPS - LISPFN MINUS) (PUTPROPS = LISPFN EQ) (PUTPROPS _ LISPFN SETQ) (PUTPROPS ¬ LISPFN SETQ) (PUTPROPS %' LISPFN QUOTE) (PUTPROPS ~ LISPFN NOT) (PUTPROPS +- LISPFN DIFFERENCE) (PUTPROPS - UNARYOP T) (PUTPROPS %' UNARYOP T) (PUTPROPS ~ UNARYOP T) (PUTPROPS < UNARYOP T) (PUTPROPS > UNARYOP T) (PUTPROPS * CLISPCLASS *) (PUTPROPS / CLISPCLASS /) (PUTPROPS + CLISPCLASS +) (PUTPROPS - CLISPCLASS -) (PUTPROPS +- CLISPCLASS +-) (PUTPROPS * CLISPCLASSDEF (ARITH ITIMES FTIMES TIMES)) (PUTPROPS / CLISPCLASSDEF (ARITH IQUOTIENT FQUOTIENT QUOTIENT)) (PUTPROPS + CLISPCLASSDEF (ARITH IPLUS FPLUS PLUS)) (PUTPROPS - CLISPCLASSDEF (ARITH IMINUS FMINUS MINUS)) (PUTPROPS +- CLISPCLASSDEF (ARITH IDIFFERENCE FDIFFERENCE DIFFERENCE)) (PUTPROPS = CLISPNEG ~=) (PUTPROPS < CLISPBRACKET (< > SEPARATOR ! DWIMIFY CLISPANGLEBRACKETS CLISPIFY SHRIEKIFY)) (PUTPROPS > CLISPBRACKET (< > SEPARATOR ! DWIMIFY CLISPANGLEBRACKETS CLISPIFY SHRIEKIFY)) (RPAQQ DECLWORDS (FLOATING FAST FFETCHFIELD FETCHFIELD REPLACEFIELD FREPLACEFIELD /REPLACEFIELD /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /NCONC /NCONC1 /PUT /PUTASSOC /PUTHASH /PUTPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SETA ASSOC CLISPIFY FASSOC FIXED FLAST FMEMB FNTH FRPLACA FRPLACD FRPLNODE FRPLNODE2 INTEGER LAST LISTPUT LISTPUT1 MAPCON MAPCONC MEMB MIXED NCONC NCONC1 NTH PUT PUTASSOC PUTHASH PUTPROP RPLACA RPLACD RPLNODE RPLNODE2 SETA STANDARD UNDOABLE)) (PUTPROPS FMEMB CLISPTYPE -20) (PUTPROPS MEMB CLISPTYPE -20) (PUTPROPS FETCHFIELD LISPFN FETCHFIELD) (PUTPROPS REPLACEFIELD LISPFN REPLACEFIELD) (PUTPROPS FREPLACEFIELD LISPFN FREPLACEFIELD) (PUTPROPS ASSOC LISPFN ASSOC) (PUTPROPS LAST LISPFN LAST) (PUTPROPS LISTPUT LISPFN LISTPUT) (PUTPROPS LISTPUT1 LISPFN LISTPUT1) (PUTPROPS MAPCON LISPFN MAPCON) (PUTPROPS MAPCONC LISPFN MAPCONC) (PUTPROPS MEMB LISPFN MEMB) (PUTPROPS NCONC LISPFN NCONC) (PUTPROPS NCONC1 LISPFN NCONC1) (PUTPROPS NTH LISPFN NTH) (PUTPROPS PUT LISPFN PUT) (PUTPROPS PUTASSOC LISPFN PUTASSOC) (PUTPROPS PUTHASH LISPFN PUTHASH) (PUTPROPS PUTPROP LISPFN PUTPROP) (PUTPROPS RPLACA LISPFN RPLACA) (PUTPROPS RPLACD LISPFN RPLACD) (PUTPROPS RPLNODE LISPFN RPLNODE) (PUTPROPS RPLNODE2 LISPFN RPLNODE2) (PUTPROPS SETA LISPFN SETA) (PUTPROPS FLOATING CLISPCLASS (ARITH . 2)) (PUTPROPS FAST CLISPCLASS (ACCESS . 3)) (PUTPROPS FFETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS FETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS FREPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS /REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS /LISTPUT CLISPCLASS LISTPUT) (PUTPROPS /MAPCON CLISPCLASS MAPCON) (PUTPROPS /MAPCONC CLISPCLASS MAPCONC) (PUTPROPS /NCONC CLISPCLASS NCONC) (PUTPROPS /NCONC1 CLISPCLASS NCONC1) (PUTPROPS /PUT CLISPCLASS PUT) (PUTPROPS /PUTASSOC CLISPCLASS PUTASSOC) (PUTPROPS /PUTHASH CLISPCLASS PUTHASH) (PUTPROPS /PUTPROP CLISPCLASS PUTPROP) (PUTPROPS /RPLACA CLISPCLASS RPLACA) (PUTPROPS /RPLACD CLISPCLASS RPLACD) (PUTPROPS /RPLNODE CLISPCLASS RPLNODE) (PUTPROPS /RPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS /SETA CLISPCLASS SETA) (PUTPROPS ASSOC CLISPCLASS ASSOC) (PUTPROPS FASSOC CLISPCLASS ASSOC) (PUTPROPS FIXED CLISPCLASS (ARITH . 1)) (PUTPROPS FLAST CLISPCLASS LAST) (PUTPROPS FMEMB CLISPCLASS MEMB) (PUTPROPS FNTH CLISPCLASS NTH) (PUTPROPS FRPLACA CLISPCLASS RPLACA) (PUTPROPS FRPLACD CLISPCLASS RPLACD) (PUTPROPS FRPLNODE CLISPCLASS RPLNODE) (PUTPROPS FRPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS INTEGER CLISPCLASS (ARITH . 1)) (PUTPROPS LAST CLISPCLASS LAST) (PUTPROPS LISTPUT CLISPCLASS LISTPUT) (PUTPROPS LISTPUT1 CLISPCLASS LISTPUT1) (PUTPROPS MAPCON CLISPCLASS MAPCON) (PUTPROPS MAPCONC CLISPCLASS MAPCONC) (PUTPROPS MEMB CLISPCLASS MEMB) (PUTPROPS MIXED CLISPCLASS (ARITH . 3)) (PUTPROPS NCONC CLISPCLASS NCONC) (PUTPROPS NCONC1 CLISPCLASS NCONC1) (PUTPROPS NTH CLISPCLASS NTH) (PUTPROPS PUT CLISPCLASS PUT) (PUTPROPS PUTASSOC CLISPCLASS PUTASSOC) (PUTPROPS PUTHASH CLISPCLASS PUTHASH) (PUTPROPS PUTPROP CLISPCLASS PUTPROP) (PUTPROPS RPLACA CLISPCLASS RPLACA) (PUTPROPS RPLACD CLISPCLASS RPLACD) (PUTPROPS RPLNODE CLISPCLASS RPLNODE) (PUTPROPS RPLNODE2 CLISPCLASS RPLNODE2) (PUTPROPS SETA CLISPCLASS SETA) (PUTPROPS STANDARD CLISPCLASS (ACCESS . 1)) (PUTPROPS UNDOABLE CLISPCLASS (ACCESS . 2)) (PUTPROPS FETCHFIELD CLISPCLASSDEF (ACCESS FETCHFIELD NIL FFETCHFIELD)) (PUTPROPS REPLACEFIELD CLISPCLASSDEF (ACCESS REPLACEFIELD /REPLACEFIELD FREPLACEFIELD)) (PUTPROPS ASSOC CLISPCLASSDEF (ACCESS ASSOC NIL FASSOC)) (PUTPROPS LAST CLISPCLASSDEF (ACCESS LAST NIL FLAST)) (PUTPROPS LISTPUT CLISPCLASSDEF (ACCESS LISTPUT /LISTPUT)) (PUTPROPS LISTPUT1 CLISPCLASSDEF (ACCESS LISTPUT1 /LISTPUT1)) (PUTPROPS MAPCON CLISPCLASSDEF (ACCESS MAPCON /MAPCON)) (PUTPROPS MAPCONC CLISPCLASSDEF (ACCESS MAPCONC /MAPCONC)) (PUTPROPS MEMB CLISPCLASSDEF (ACCESS MEMB NIL FMEMB)) (PUTPROPS NCONC CLISPCLASSDEF (ACCESS NCONC /NCONC)) (PUTPROPS NCONC1 CLISPCLASSDEF (ACCESS NCONC1 /NCONC1)) (PUTPROPS NTH CLISPCLASSDEF (ACCESS NTH NIL FNTH)) (PUTPROPS PUT CLISPCLASSDEF (ACCESS PUT /PUT)) (PUTPROPS PUTASSOC CLISPCLASSDEF (ACCESS PUTASSOC /PUTASSOC)) (PUTPROPS PUTHASH CLISPCLASSDEF (ACCESS PUTHASH /PUTHASH)) (PUTPROPS PUTPROP CLISPCLASSDEF (ACCESS PUTPROP /PUTPROP)) (PUTPROPS RPLACA CLISPCLASSDEF (ACCESS RPLACA /RPLACA FRPLACA)) (PUTPROPS RPLACD CLISPCLASSDEF (ACCESS RPLACD /RPLACD FRPLACD)) (PUTPROPS RPLNODE CLISPCLASSDEF (ACCESS RPLNODE /RPLNODE FRPLNODE)) (PUTPROPS RPLNODE2 CLISPCLASSDEF (ACCESS RPLNODE2 /RPLNODE2 FRPLNODE2)) (PUTPROPS SETA CLISPCLASSDEF (ACCESS SETA /SETA)) (PUTPROPS FMEMB CLISPNEG ~FMEMB) (PUTPROPS MEMB CLISPNEG ~MEMB) (PUTPROPS FMEMB BROADSCOPE T) (PUTPROPS MEMB BROADSCOPE T) (PUTPROPS LT CLISPTYPE -20) (PUTPROPS lt CLISPTYPE -20) (PUTPROPS GT CLISPTYPE -20) (PUTPROPS gt CLISPTYPE -20) (PUTPROPS LE CLISPTYPE -20) (PUTPROPS le CLISPTYPE -20) (PUTPROPS GE CLISPTYPE -20) (PUTPROPS ge CLISPTYPE -20) (PUTPROPS LEQ CLISPTYPE -20) (PUTPROPS leq CLISPTYPE -20) (PUTPROPS GEQ CLISPTYPE -20) (PUTPROPS geq CLISPTYPE -20) (PUTPROPS EQ CLISPTYPE -20) (PUTPROPS NEQ CLISPTYPE -20) (PUTPROPS EQP CLISPTYPE -20) (PUTPROPS EQUAL CLISPTYPE -20) (PUTPROPS EQUALS CLISPTYPE -20) (PUTPROPS AND CLISPTYPE -25) (PUTPROPS OR CLISPTYPE -26) (PUTPROPS and CLISPTYPE -25) (PUTPROPS or CLISPTYPE -26) (PUTPROPS NOR CLISPTYPE -25) (PUTPROPS nor CLISPTYPE -25) (PUTPROPS MEMBER CLISPTYPE -20) (PUTPROPS ILESSP CLISPTYPE -20) (PUTPROPS IGREATERP CLISPTYPE -20) (PUTPROPS FGTP CLISPTYPE -20) (PUTPROPS MINUS CLISPTYPE 8) (PUTPROPS LESSP CLISPTYPE -20) (PUTPROPS GREATERP CLISPTYPE -20) (PUTPROPS -> CLISPTYPE 7) (PUTPROPS => CLISPTYPE 7) (PUTPROPS LT LISPFN LESSP) (PUTPROPS lt LISPFN LESSP) (PUTPROPS GT LISPFN GREATERP) (PUTPROPS gt LISPFN GREATERP) (PUTPROPS LE LISPFN LEQ) (PUTPROPS le LISPFN LEQ) (PUTPROPS GE LISPFN GEQ) (PUTPROPS ge LISPFN GEQ) (PUTPROPS LEQ LISPFN LEQ) (PUTPROPS leq LISPFN LEQ) (PUTPROPS GEQ LISPFN GEQ) (PUTPROPS geq LISPFN GEQ) (PUTPROPS EQUALS LISPFN EQUAL) (PUTPROPS AND LISPFN AND) (PUTPROPS OR LISPFN OR) (PUTPROPS and LISPFN AND) (PUTPROPS or LISPFN OR) (PUTPROPS NOR LISPFN AND) (PUTPROPS nor LISPFN AND) (PUTPROPS NOT UNARYOP T) (PUTPROPS MINUS UNARYOP T) (PUTPROPS LEQ CLISPINFIX le) (PUTPROPS GEQ CLISPINFIX ge) (PUTPROPS EQ CLISPINFIX =) (PUTPROPS NOT CLISPINFIX ~) (PUTPROPS AND CLISPINFIX and) (PUTPROPS OR CLISPINFIX or) (PUTPROPS SETQ CLISPINFIX _) (PUTPROPS IPLUS CLISPINFIX +) (PUTPROPS IMINUS CLISPINFIX -) (PUTPROPS IDIFFERENCE CLISPINFIX +-) (PUTPROPS ITIMES CLISPINFIX *) (PUTPROPS IQUOTIENT CLISPINFIX /) (PUTPROPS ILESSP CLISPINFIX lt) (PUTPROPS IGREATERP CLISPINFIX gt) (PUTPROPS PLUS CLISPINFIX +) (PUTPROPS MINUS CLISPINFIX -) (PUTPROPS DIFFERENCE CLISPINFIX +-) (PUTPROPS TIMES CLISPINFIX *) (PUTPROPS QUOTIENT CLISPINFIX /) (PUTPROPS LESSP CLISPINFIX lt) (PUTPROPS GREATERP CLISPINFIX gt) (PUTPROPS EXPT CLISPINFIX ^) (PUTPROPS LT CLISPCLASS LT) (PUTPROPS lt CLISPCLASS LT) (PUTPROPS GT CLISPCLASS GT) (PUTPROPS gt CLISPCLASS GT) (PUTPROPS LE CLISPCLASS LEQ) (PUTPROPS le CLISPCLASS LEQ) (PUTPROPS GE CLISPCLASS GEQ) (PUTPROPS ge CLISPCLASS GEQ) (PUTPROPS LEQ CLISPCLASS LEQ) (PUTPROPS leq CLISPCLASS LEQ) (PUTPROPS GEQ CLISPCLASS GEQ) (PUTPROPS geq CLISPCLASS GEQ) (PUTPROPS IPLUS CLISPCLASS +) (PUTPROPS IMINUS CLISPCLASS -) (PUTPROPS IDIFFERENCE CLISPCLASS +-) (PUTPROPS ITIMES CLISPCLASS *) (PUTPROPS IQUOTIENT CLISPCLASS /) (PUTPROPS ILESSP CLISPCLASS LT) (PUTPROPS IGREATERP CLISPCLASS GT) (PUTPROPS FPLUS CLISPCLASS +) (PUTPROPS FMINUS CLISPCLASS -) (PUTPROPS FDIFFERENCE CLISPCLASS +-) (PUTPROPS FTIMES CLISPCLASS *) (PUTPROPS FQUOTIENT CLISPCLASS /) (PUTPROPS FGTP CLISPCLASS GT) (PUTPROPS PLUS CLISPCLASS +) (PUTPROPS MINUS CLISPCLASS -) (PUTPROPS DIFFERENCE CLISPCLASS +-) (PUTPROPS TIMES CLISPCLASS *) (PUTPROPS QUOTIENT CLISPCLASS /) (PUTPROPS LESSP CLISPCLASS LT) (PUTPROPS GREATERP CLISPCLASS GT) (PUTPROPS LT CLISPCLASSDEF (ARITH ILESSP LESSP LESSP)) (PUTPROPS GT CLISPCLASSDEF (ARITH IGREATERP FGTP GREATERP)) (PUTPROPS LE CLISPCLASSDEF (ARITH ILEQ LEQ LEQ)) (PUTPROPS GE CLISPCLASSDEF (ARITH IGEQ GEQ GEQ)) (PUTPROPS LEQ CLISPCLASSDEF (ARITH ILEQ LEQ LEQ)) (PUTPROPS GEQ CLISPCLASSDEF (ARITH IGEQ GEQ GEQ)) (PUTPROPS LT CLISPNEG GEQ) (PUTPROPS GT CLISPNEG LEQ) (PUTPROPS EQUALS CLISPNEG ~EQUAL) (PUTPROPS MEMBER CLISPNEG ~MEMBER) (PUTPROPS LT BROADSCOPE T) (PUTPROPS lt BROADSCOPE T) (PUTPROPS GT BROADSCOPE T) (PUTPROPS gt BROADSCOPE T) (PUTPROPS LE BROADSCOPE T) (PUTPROPS le BROADSCOPE T) (PUTPROPS GE BROADSCOPE T) (PUTPROPS ge BROADSCOPE T) (PUTPROPS LEQ BROADSCOPE T) (PUTPROPS leq BROADSCOPE T) (PUTPROPS GEQ BROADSCOPE T) (PUTPROPS geq BROADSCOPE T) (PUTPROPS EQ BROADSCOPE T) (PUTPROPS NEQ BROADSCOPE T) (PUTPROPS EQP BROADSCOPE T) (PUTPROPS EQUAL BROADSCOPE T) (PUTPROPS EQUALS BROADSCOPE T) (PUTPROPS NOT BROADSCOPE T) (PUTPROPS AND BROADSCOPE T) (PUTPROPS OR BROADSCOPE T) (PUTPROPS and BROADSCOPE T) (PUTPROPS or BROADSCOPE T) (PUTPROPS NOR BROADSCOPE T) (PUTPROPS nor BROADSCOPE T) (PUTPROPS MEMBER BROADSCOPE T) (PUTPROPS ILESSP BROADSCOPE T) (PUTPROPS IGREATERP BROADSCOPE T) (PUTPROPS FGTP BROADSCOPE T) (PUTPROPS LESSP BROADSCOPE T) (PUTPROPS GREATERP BROADSCOPE T) (PUTPROPS ELT SETFN SETA) (PUTPROPS SETA SETFN (ELT)) (DEFOPTIMIZER CLISP%  (X &REST Y) X) (PUTPROPS AND CLISPWORD T) (PUTPROPS OR CLISPWORD T) (PUTPROPS and CLISPWORD T) (PUTPROPS or CLISPWORD T) (PUTPROPS ! CLISPWORD T) (PUTPROPS !! CLISPWORD T) (PUTPROPS CLISP CLISPWORD (PREFIXFN . clisp)) (PUTPROPS clisp CLISPWORD (PREFIXFN . clisp)) (PUTPROPS MATCH CLISPWORD (MATCHWORD . match)) (PUTPROPS match CLISPWORD (MATCHWORD . match)) (* IF) (RPAQQ CLISPIFWORDSPLST (THEN ELSE ELSEIF IF)) (RPAQ? CLISPIFTRANFLG T) (PUTPROPS IF CLISPWORD (IFWORD . if)) (PUTPROPS THEN CLISPWORD (IFWORD . then)) (PUTPROPS ELSE CLISPWORD (IFWORD . else)) (PUTPROPS ELSEIF CLISPWORD (IFWORD . elseif)) (PUTPROPS if CLISPWORD (IFWORD . if)) (PUTPROPS then CLISPWORD (IFWORD . then)) (PUTPROPS else CLISPWORD (IFWORD . else)) (PUTPROPS elseif CLISPWORD (IFWORD . elseif)) (* I.S.OPR) (RPAQQ CLISPI.S.GAG NIL) (RPAQQ INITISOPRS (ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count declare declare%: do eachtime fcollect finally find first for from in inside isthere join largest never old on original repeatuntil repeatwhile smallest suchthat sum thereis thru to unless until when where while)) (PUTPROPS ALWAYS CLISPWORD (FORWORD . always)) (PUTPROPS AS CLISPWORD (FORWORD . as)) (PUTPROPS BIND CLISPWORD (FORWORD . bind)) (PUTPROPS BY CLISPWORD (FORWORD . by)) (PUTPROPS COLLECT CLISPWORD (FORWORD . collect)) (PUTPROPS COUNT CLISPWORD (FORWORD . count)) (PUTPROPS DECLARE CLISPWORD (FORWORD . declare)) (PUTPROPS DECLARE%: CLISPWORD (FORWORD declare%: DECLARE)) (PUTPROPS DO CLISPWORD (FORWORD . do)) (PUTPROPS EACHTIME CLISPWORD (FORWORD . eachtime)) (PUTPROPS FCOLLECT CLISPWORD (FORWORD . fcollect)) (PUTPROPS FINALLY CLISPWORD (FORWORD . finally)) (PUTPROPS FIND CLISPWORD (FORWORD find FOR)) (PUTPROPS FIRST CLISPWORD (FORWORD . first)) (PUTPROPS FOR CLISPWORD (FORWORD . for)) (PUTPROPS FROM CLISPWORD (FORWORD . from)) (PUTPROPS IN CLISPWORD (FORWORD . in)) (PUTPROPS INSIDE CLISPWORD (FORWORD . inside)) (PUTPROPS ISTHERE CLISPWORD (FORWORD isthere THEREIS)) (PUTPROPS JOIN CLISPWORD (FORWORD . join)) (PUTPROPS LARGEST CLISPWORD (FORWORD . largest)) (PUTPROPS NEVER CLISPWORD (FORWORD . never)) (PUTPROPS OLD CLISPWORD (FORWORD . old)) (PUTPROPS ON CLISPWORD (FORWORD . on)) (PUTPROPS ORIGINAL CLISPWORD (FORWORD . original)) (PUTPROPS REPEATUNTIL CLISPWORD (FORWORD . repeatuntil)) (PUTPROPS REPEATWHILE CLISPWORD (FORWORD . repeatwhile)) (PUTPROPS SMALLEST CLISPWORD (FORWORD . smallest)) (PUTPROPS SUCHTHAT CLISPWORD (FORWORD suchthat THEREIS)) (PUTPROPS SUM CLISPWORD (FORWORD . sum)) (PUTPROPS THEREIS CLISPWORD (FORWORD . thereis)) (PUTPROPS THRU CLISPWORD (FORWORD thru TO)) (PUTPROPS TO CLISPWORD (FORWORD . to)) (PUTPROPS UNLESS CLISPWORD (FORWORD . unless)) (PUTPROPS UNTIL CLISPWORD (FORWORD . until)) (PUTPROPS WHEN CLISPWORD (FORWORD . when)) (PUTPROPS WHERE CLISPWORD (FORWORD where WHEN)) (PUTPROPS WHILE CLISPWORD (FORWORD . while)) (PUTPROPS always CLISPWORD (FORWORD . always)) (PUTPROPS as CLISPWORD (FORWORD . as)) (PUTPROPS bind CLISPWORD (FORWORD . bind)) (PUTPROPS by CLISPWORD (FORWORD . by)) (PUTPROPS collect CLISPWORD (FORWORD . collect)) (PUTPROPS count CLISPWORD (FORWORD . count)) (PUTPROPS declare CLISPWORD (FORWORD . declare)) (PUTPROPS declare%: CLISPWORD (FORWORD declare%: DECLARE)) (PUTPROPS do CLISPWORD (FORWORD . do)) (PUTPROPS eachtime CLISPWORD (FORWORD . eachtime)) (PUTPROPS fcollect CLISPWORD (FORWORD . fcollect)) (PUTPROPS finally CLISPWORD (FORWORD . finally)) (PUTPROPS find CLISPWORD (FORWORD find FOR)) (PUTPROPS first CLISPWORD (FORWORD . first)) (PUTPROPS for CLISPWORD (FORWORD . for)) (PUTPROPS from CLISPWORD (FORWORD . from)) (PUTPROPS in CLISPWORD (FORWORD . in)) (PUTPROPS inside CLISPWORD (FORWORD . inside)) (PUTPROPS isthere CLISPWORD (FORWORD isthere thereis)) (PUTPROPS join CLISPWORD (FORWORD . join)) (PUTPROPS largest CLISPWORD (FORWORD . largest)) (PUTPROPS never CLISPWORD (FORWORD . never)) (PUTPROPS old CLISPWORD (FORWORD . old)) (PUTPROPS on CLISPWORD (FORWORD . on)) (PUTPROPS original CLISPWORD (FORWORD . original)) (PUTPROPS repeatuntil CLISPWORD (FORWORD . repeatuntil)) (PUTPROPS repeatwhile CLISPWORD (FORWORD . repeatwhile)) (PUTPROPS smallest CLISPWORD (FORWORD . smallest)) (PUTPROPS suchthat CLISPWORD (FORWORD suchthat THEREIS)) (PUTPROPS sum CLISPWORD (FORWORD . sum)) (PUTPROPS thereis CLISPWORD (FORWORD . thereis)) (PUTPROPS thru CLISPWORD (FORWORD thru TO)) (PUTPROPS to CLISPWORD (FORWORD . to)) (PUTPROPS unless CLISPWORD (FORWORD . unless)) (PUTPROPS until CLISPWORD (FORWORD . until)) (PUTPROPS when CLISPWORD (FORWORD . when)) (PUTPROPS where CLISPWORD (FORWORD where WHEN)) (PUTPROPS while CLISPWORD (FORWORD . while)) (PUTPROPS always I.S.OPR ((COND ((NULL BODY) (SETQ $$VAL NIL) (GO $$OUT))) BIND (SETQ $$VAL T))) (PUTPROPS collect I.S.OPR ((SETQ $$VAL (NCONC1 $$VAL BODY)))) (PUTPROPS count I.S.OPR ((AND BODY (SETQ $$VAL (ADD1 $$VAL))) BIND ($$VAL _ 0))) (PUTPROPS do I.S.OPR (BODY)) (PUTPROPS fcollect I.S.OPR [(= SUBPAIR '(VAR1 VAR2) (LIST (GETDUMMYVAR T) (GETDUMMYVAR T)) '(PROGN (SETQ VAR1 BODY) (COND [VAR2 (FRPLACD VAR2 (SETQ VAR2 (LIST VAR1] (T (SETQ $$VAL (SETQ VAR2 (LIST VAR1]) (PUTPROPS inside I.S.OPR [NIL = SUBST (GETDUMMYVAR) 'VAR '(bind (VAR _ BODY) eachtime (COND ((NULL VAR) (GO $$OUT)) ((NLISTP VAR) (SETQ I.V. VAR) (SETQ VAR NIL)) (T (SETQ I.V. (CAR VAR)) (SETQ VAR (CDR VAR]) (PUTPROPS join I.S.OPR ((SETQ $$VAL (NCONC $$VAL BODY)))) (PUTPROPS largest I.S.OPR [NIL = SUBST (GETDUMMYVAR) '$$TEMP '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) (COND ((OR (NULL $$EXTREME) (GREATERP $$TEMP $$EXTREME)) (SETQ $$EXTREME $$TEMP) (SETQ $$VAL I.V.]) (PUTPROPS never I.S.OPR ((COND (BODY (SETQ $$VAL NIL) (GO $$OUT))) BIND ($$VAL _ T))) (PUTPROPS old I.S.OPR MODIFIER) (PUTPROPS smallest I.S.OPR [NIL = SUBST (GETDUMMYVAR) '$$TEMP '(BIND $$EXTREME $$TEMP DO (SETQ $$TEMP BODY) (COND ((OR (NULL $$EXTREME) (LESSP $$TEMP $$EXTREME)) (SETQ $$EXTREME $$TEMP) (SETQ $$VAL I.V.]) (PUTPROPS sum I.S.OPR ((SETQ $$VAL (PLUS $$VAL BODY)) BIND ($$VAL _ 0))) (PUTPROPS thereis I.S.OPR [(COND (BODY (SETQ $$VAL (OR I.V. T)) (GO $$OUT]) (ADDTOVAR I.S.OPRLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE always as bind by collect count declare declare%: do eachtime fcollect finally find first for from in inside isthere join largest never old on original repeatuntil repeatwhile smallest suchthat sum thereis thru to unless until when where while) (ADDTOVAR CLISPFORWORDSPLST ALWAYS AS BIND BY COLLECT COUNT DECLARE DECLARE%: DO EACHTIME FCOLLECT FINALLY FIND FIRST FOR FROM IN INSIDE ISTHERE JOIN LARGEST NEVER OLD ON ORIGINAL REPEATUNTIL REPEATWHILE SMALLEST SUCHTHAT SUM THEREIS THRU TO UNLESS UNTIL WHEN WHERE WHILE) (RPAQQ CLISPDUMMYFORVARS ($$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6)) (ADDTOVAR SYSLOCALVARS $$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6) (ADDTOVAR INVISIBLEVARS $$TEM0 $$TEM1 $$TEM2 $$TEM3 $$TEM4 $$TEM5 $$TEM6) (ADDTOVAR SYSLOCALVARS $$VAL $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$END $$EXTREME) (ADDTOVAR INVISIBLEVARS $$VAL $$END $$TEM $$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6 $$EXTREME) (PUTDEF (QUOTE I.S.OPRS) (QUOTE FILEPKGCOMS) '((COM MACRO [X (DECLARE%: EVAL@COMPILE (P * (DUMPI.S.OPRS . X] CONTENTS NILL) (TYPE DESCRIPTION "i.s. operators" GETDEF GETDEF.I.S.OPR WHENCHANGED (CLEARCLISPARRAY)))) (DEFINEQ (DUMPI.S.OPRS [NLAMBDA X (* lmm "14-Aug-84 18:34") (* Dump I.S.OPRS definitions. - redefined to dump out same case as given) (for Y in X collect (OR (GETDEF.I.S.OPR Y) (PROG1 NIL (LISPXPRINT (LIST 'I.S.OPR Y 'not 'defined) T T]) (GETDEF.I.S.OPR [LAMBDA (Y) (* lmm "14-Aug-84 18:34") (PROG (TEM BODY EVALFLG) (RETURN (CONS 'I.S.OPR (CONS (KWOTE Y) (OR [AND [SETQ TEM (LISTP (GETPROP Y 'CLISPWORD] (EQ (CAR TEM) 'FORWORD) (COND [[AND (NLISTP (CDR TEM)) (SETQ BODY (GETPROP (CDR TEM) 'I.S.OPR] (COND [(LISTP BODY) (CONS [KWOTE (COND ((EQ (CAR (LISTP (CAR BODY))) '=) (SETQ EVALFLG T) (CDAR BODY)) (T (CAR BODY] (COND ((EQ (CADR BODY) '=) (LIST (KWOTE (CDDR BODY)) T)) [(CDR BODY) (COND (EVALFLG (SHOULDNT))) (* somehow there was an = in front of the i.s.type and not in front of the others. this shouldnt happen) (LIST (KWOTE (CDR BODY] (EVALFLG '(NIL T] (T (LIST (KWOTE BODY] ((AND (LISTP (CDR TEM)) (CADDR TEM)) (LIST (KWOTE (CADDR TEM] (RETURN]) ) (* forDuration) (ADDTOVAR DURATIONCLISPWORDS (TIMERUNITS timerUnits timerunits) (USINGBOX usingBox usingbox) (USINGTIMER usingTimer usingtimer) (FORDURATION forDuration forduration DURING during) (RESOURCENAME resourceName resourcename) (UNTILDATE untilDate untildate)) (PUTPROPS TIMERUNITS CLISPWORD (FORWORD . timerUnits)) (PUTPROPS timerUnits CLISPWORD (FORWORD . timerUnits)) (PUTPROPS timerunits CLISPWORD (FORWORD . timerUnits)) (PUTPROPS USINGBOX CLISPWORD (FORWORD . usingBox)) (PUTPROPS usingBox CLISPWORD (FORWORD . usingBox)) (PUTPROPS usingbox CLISPWORD (FORWORD . usingBox)) (PUTPROPS USINGTIMER CLISPWORD (FORWORD . usingTimer)) (PUTPROPS usingTimer CLISPWORD (FORWORD . usingTimer)) (PUTPROPS usingtimer CLISPWORD (FORWORD . usingTimer)) (PUTPROPS FORDURATION CLISPWORD (FORWORD . forDuration)) (PUTPROPS forDuration CLISPWORD (FORWORD . forDuration)) (PUTPROPS forduration CLISPWORD (FORWORD . forDuration)) (PUTPROPS DURING CLISPWORD (FORWORD . during)) (PUTPROPS during CLISPWORD (FORWORD . during)) (PUTPROPS RESOURCENAME CLISPWORD (FORWORD . resourceName)) (PUTPROPS resourceName CLISPWORD (FORWORD . resourceName)) (PUTPROPS resourcename CLISPWORD (FORWORD . resourceName)) (PUTPROPS UNTILDATE CLISPWORD (FORWORD . untildate)) (PUTPROPS untilDate CLISPWORD (FORWORD . untilDate)) (PUTPROPS untildate CLISPWORD (FORWORD . untildate)) (PUTPROPS timerUnits \DURATIONTRAN T) (PUTPROPS usingBox \DURATIONTRAN T) (PUTPROPS usingTimer \DURATIONTRAN T) (PUTPROPS forDuration \DURATIONTRAN T) (PUTPROPS during \DURATIONTRAN T) (PUTPROPS resourceName \DURATIONTRAN T) (PUTPROPS untilDate \DURATIONTRAN T) (PUTPROPS untildate \DURATIONTRAN T) (DECLARE%: EVAL@COMPILE [PUTDEF '\ForDurationOfBox 'RESOURCES '(NEW (\TIMER.MAKETIMER] ) (* ;; "Currently there are four possible entries for the INFO property: EVAL, BINDS, LABELS, PROGN, or a list containg any or all of these." ) (* ;; "EVAL is used to indicate that an nlambda evaluates its arguments. EVAL affects DWIMIFY and CLISPIFY: neither will touch an nlambda that does not have this property." ) (* ;; "BINDS tells clispify and dwimify that CADR of the form is a list of variables being bound, a la prog." ) (* ;; "PROGN says that only the last top level expression is being used for value. This affects the way OR's and AND's are clispified, for example." ) (* ;; "Finally, LABELS indicates that top level atoms in this expression are not being evaluated. This tells clispify not to create atoms out of lists at the top level. LABELS also implies that none of the top level expressions are being used for value." ) (* ;; "For example, FOR has info property just BINDS, (EVAL is unnecssary since FOR is not a function and its dwimifying and clispifying affected by its clispword property), whereas PROG has (BINDS EVAL LABELS), and LAMBDA has (EVAL BINDS PROGN)" ) (PUTPROPS PROG INFO (EVAL BINDS LABELS)) (PUTPROPS PROG* INFO (EVAL BINDS LABELS)) (PUTPROPS RESETVARS INFO (EVAL BINDS LABELS)) (PUTPROPS RESETBUFS INFO EVAL) (PUTPROPS RESETLST INFO (EVAL PROGN)) (PUTPROPS ADV-PROG INFO (EVAL BINDS LABELS)) (PUTPROPS ADV-SETQ INFO EVAL) (PUTPROPS AND INFO EVAL) (PUTPROPS ARG INFO EVAL) (PUTPROPS COND INFO EVAL) (PUTPROPS ERSETQ INFO EVAL) (PUTPROPS NLSETQ INFO EVAL) (PUTPROPS OR INFO EVAL) (PUTPROPS PROG1 INFO EVAL) (PUTPROPS PROG2 INFO EVAL) (PUTPROPS PROGN INFO (EVAL PROGN)) (PUTPROPS RESETFORM INFO EVAL) (PUTPROPS RESETSAVE INFO EVAL) (PUTPROPS RESETVAR INFO EVAL) (PUTPROPS RPAQ INFO EVAL) (PUTPROPS RPTQ INFO EVAL) (PUTPROPS FRPTQ INFO EVAL) (PUTPROPS SAVESETQ INFO EVAL) (PUTPROPS SETN INFO EVAL) (PUTPROPS SETQ INFO EVAL) (PUTPROPS UNDONLSETQ INFO EVAL) (PUTPROPS XNLSETQ INFO EVAL) (PUTPROPS SETARG INFO EVAL) (PUTPROPS LET INFO (BINDS EVAL)) (PUTPROPS LET* INFO (BINDS EVAL)) (PUTPROPS RETURN INFO EVAL) (PUTPROPS CLISP FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DUMPI.S.OPRS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLISP COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (37614 40224 (DUMPI.S.OPRS 37624 . 38032) (GETDEF.I.S.OPR 38034 . 40222))))) STOP \ No newline at end of file diff --git a/sources/CLISPIFY b/sources/CLISPIFY new file mode 100644 index 00000000..edd1c00b --- /dev/null +++ b/sources/CLISPIFY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 12:28:58" {DSK}local>lde>lispcore>sources>CLISPIFY.;2 136351 changes to%: (VARS CLISPIFYCOMS) previous date%: "19-Jun-86 14:57:01" {DSK}local>lde>lispcore>sources>CLISPIFY.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CLISPIFYCOMS) (RPAQQ CLISPIFYCOMS [(FNS CLISPIFYFNS CLISPIFY CLISPIFY1 CLISPIFY2 CLISPIFY2A CLISPIFY2B CLISPIFY2C CLISPIFY2D CLISP3 CLISP3A CLISP3B CLISPACKUP CLISP3C CLISP4 CLISPCOND CLISPCOND1 CLISPAND CLISPAND1 CLISPIFYNOT CLISPIFYMATCHUP CLREMPARS CLISPIFYCROPS0 CLISPIFYCROPS CLISPIFYCROPS1 CLISPIFYRPLAC CLISPIFYMAPS CLMAPS1 CLMAPS2 CLSTOPSCAN? CLISPIFYLOOKUP LOWERCASE SHRIEKIFY SHRKFY SHRKFY2 WHILEDOUNTIL WHILEDO1 CLDISABLE) (INITVARS (FUNNYATOMLST) (CLREMPARSFLG) (CL%:FLG T) (CLISPIFYPACKFLG) (CLISPIFYENGLSHFLG) (CLISPIFYUSERFN)) (VARS CAR/CDRSTRING) (USERMACROS CL) (PROP CLISPFORM ADD1 SUB1 NEQ) (PROP CLISPBRACKET CONS LIST APPEND NCONC NCONC1 /NCONC /NCONC1) (PROP CLISPTYPE ~EQUAL ~MEMBER ~MEMB) (PROP CLMAPS MAPC MAP MAPCAR MAPLIST MAPCONC MAPCON SUBSET) (BLOCKS (CLISPIFYBLOCK CLISPIFYFNS CLISPIFY CLISPIFY1 CLISPIFY2 CLISPIFY2A CLISPIFY2B CLISPIFY2C CLISPIFY2D CLISP3 CLISP3A CLISP3B CLISPACKUP CLISP3C CLISP4 CLISPCOND CLISPCOND1 CLISPAND CLISPAND1 CLISPIFYNOT CLISPIFYMATCHUP CLREMPARS CLISPIFYCROPS0 CLISPIFYCROPS CLISPIFYCROPS1 CLISPIFYRPLAC CLISPIFYMAPS CLMAPS1 CLMAPS2 SHRIEKIFY SHRKFY SHRKFY2 CLISPIFYLOOKUP CLSTOPSCAN? WHILEDOUNTIL WHILEDO1 (ENTRIES CLISPIFYFNS CLISPIFY CLISPACKUP CLISPIFYMATCHUP CLISPIFY2A CLISP3A) (SPECVARS EXPR VARS DWIMIFYFLG DWIMIFYING DWIMIFY0CHANGE) (LOCALFREEVARS DECLST CLTYP0 OPR0 LST SEG TAIL FORM PARENT SUBPARENT NOVALFLG NEGFLG RESULTP SAFEFLAG VARS CLISPISTATE TYPE-IN? SIDES CLISPIFYFN) (GLOBALVARS CAR/CDRSTRING CL%:FLG CLISPARRAY CLISPCHARRAY CLISPCHARS CLISPFLG CLISPIFYENGLSHFLG CLISPIFYPACKFLG CLISPIFYSTATS CLISPIFYUSERFN CLISPISNOISEWORDS CLISPISVERBS CLISPTRANFLG CLREMPARSFLG COMMENTFLG DWIMFLG FILELST FUNNYATOMLST GLOBALVARS LCASEFLG) (RETFNS CLISPIFY2B) (NOLINKFNS CLISPIFYUSERFN)) (NIL LOWERCASE (GLOBALVARS CHCONLST LCASEFLG)) (NIL CLDISABLE (GLOBALVARS CLISPCHARS CLISPCHARRAY NOFIXFNSLST0 NOFIXVARSLST0)) (NIL (GLOBALVARS CLISPISNOISEWORDS CLISPISVERBS CLISPISWORDSPLST))) (P (LOWERCASE T)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS MATCHUP)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA CLISPIFYFNS) (NLAML) (LAMA]) (DEFINEQ (CLISPIFYFNS [NLAMBDA FNS (* wt%: 30-JUN-77 22 16) (PROG ((CLK (CLOCK 0)) TEM) (RETURN (MAPCONC [COND ((CDR FNS) FNS) ((LISTP (CAR FNS)) (STKEVAL 'CLISPIFYFNS (CAR FNS) NIL 'INTERNAL)) (T (* If (CAR FNS) is name of a file,  do clipifyfns on its functions.) (OR (LISTP (EVALV (CAR FNS) 'CLISPIFYFNS)) (AND (GETPROP (OR (AND DWIMFLG (MISSPELLED? (CAR FNS) 70 FILELST NIL FNS)) (CAR FNS)) 'FILE) (FILEFNSLST (CAR FNS))) (STKEVAL 'CLISPIFYFNS (CAR FNS) 'INTERNAL] (FUNCTION (LAMBDA (X) (COND ((IGREATERP (IDIFFERENCE (SETQ TEM (CLOCK 0)) CLK) 30000) (SETQ CLK TEM) (PRIN2 X T T) (PRIN1 '", " T))) (ERSETQ (CLISPIFY X]) (CLISPIFY [LAMBDA (X EDITCHAIN) (* lmm "27-FEB-83 10:53") (* CLISPIFY the expression X. EDITCHAIN if supplied is the chain of parents of  this expression; used for gathering the variables bound and the top level  context) (PROG (TEM CLISPIFYFN OPR0 CLTYP0 BROADSCOPE DECLST EXPR VARS PARENT SUBPARENT FORM SEG TAIL LST CLISPISTATE) [COND [(OR (LISTP X) EDITCHAIN) (COND ((NULL EDITCHAIN) (SETQ EXPR X)) (T (SETQ PARENT (CAR EDITCHAIN)) (AND (TAILP (SETQ TEM (EVQ LASTAIL)) (CAR EDITCHAIN)) (SETQ TAIL TEM)) [COND ((LISTP (SETQ CLISPIFYFN (EVQ ATM))) (* New editor conventions.) (SETQ CLISPIFYFN (CAR CLISPIFYFN] (* ATM is bound in EDITE) (SETQ VARS (VARSBOUNDINEDITCHAIN EDITCHAIN)) (* VARSBOUNDINEDITCHAIN climbs  EDITCHAIN and gathers up the VARS) (SETQ EXPR (CAR (LAST EDITCHAIN] (T (SETQ TEM (EXPRCHECK X)) (SETQ CLISPIFYFN (CAR TEM)) (SETQ EXPR (SETQ FORM (CDR TEM] (AND (NULL CLISPIFYFN) (SETQQ CLISPIFYFN TYPE-IN)) (SETQ DECLST (GETLOCALDEC EXPR CLISPIFYFN)) [COND ((NULL FORM) (* Corresponds to first clause in  first COND.) (RETURN (COND ((NULL EDITCHAIN) (* E.G. User just types in CLISPIFY  some expression.) (CLISPIFY2 X)) ((TAILP X PARENT) (SETQ FORM PARENT) (SETQ TEM (CLISPIFY1 X)) (CONS (CAR TEM) (CDR TEM))) ([OR (EQ (CAAR EDITCHAIN) 'COND) (AND (EQ (CAAR EDITCHAIN) 'SELECTQ) (NEQ X (CADAR EDITCHAIN)) (CDR (FMEMB X PARENT] (SETQ FORM (CAR X)) (* The LIST is because while this expression should be CLISPIFIED as a tail  (it being a COND clause)%, it is an element in the structure and the CL macro  is expecting a list returned.) (LIST (CLISPIFY1 X))) (T (* Commands expect a list returned) (CLISPIFY2A X] (SETQ TEM (CLISPIFY2 EXPR)) (RETURN (COND ((NULL CLISPIFYFN) TEM) (T (COND ((NULL (GETD CLISPIFYFN)) (DWIMUNSAVEDEF CLISPIFYFN T))) (/PUTD CLISPIFYFN TEM) (AND FILEPKGFLG (MARKASCHANGED CLISPIFYFN 'FNS)) CLISPIFYFN]) (CLISPIFY1 [LAMBDA (TAIL OPR0 CLTYP0 BROADSCOPE NOVALFLG SUBPARENT) (* lmm "27-Jan-85 00:27") (* Processes tails. When OPR0 is not NIL, called from CLISP3, and inserts OPR0  between each call to CLISPIFY2. If BROADSCOPE is T, OPR0 is an operator with  higher precedence than user functions, e.g.  EQ, LS, AND, etc. In this case, the arguments need not be parenthesized, e.g.  (AND (FOO X) Y) -> (FOO X AND Y)) (PROG (SEG TEM LST (TAIL0 TAIL) (PARENT FORM) PREVEXP) [COND ((NULL SUBPARENT) (* PARENT and SUBPARENT are used in CLISP4 for checking for partial  CLISPIFICATION and resulting calls to DWIMIFY.  e.g. when CLISPIFYING and expression like  (FOO X* (IPLUS X Y)) it is necessary to backup and DWIMIFY, but for  (SELECTQ X (X* (IPLUS X Y)) NIL) it is not.  PARENT and SUBPARENT are rebound in CLISPIFY1  (rather than CLISPIFY2)%. Therefore they are alsoebound by functions that  recurse by calling CLISPIFY2 directly, i.e.  CLISPIFYRPLAC, CLISPIFYCROPS, and CLISPIFYCOND.) (SETQ SUBPARENT TAIL)) ((NEQ SUBPARENT TAIL) (SETQ PREVEXP (CAR (NLEFT SUBPARENT 1 TAIL] [COND ((EQ NOVALFLG 'NOTLAST) (* Says all forms are nor being used  for value, EXCEPT for last one.) (SETQ NOVALFLG (LAST TAIL] LP [COND [(NULL TAIL) (RETURN (COND ((NULL LST) TAIL0) (TAIL0 (NCONC LST TAIL0)) (T LST] [(NLISTP TAIL) (RETURN (COND (TAIL0 (NCONC LST TAIL0)) (T (FRPLACD (FLAST LST) TAIL) LST] ((AND OPR0 (NEQ OPR0 T)) (COND (LST (NCONC1 LST OPR0)) ((GETPROP OPR0 'UNARYOP) (SETQ LST (LIST OPR0] [SETQ TEM (COND ((AND (LITATOM PREVEXP) (EQ (NTHCHARCODE PREVEXP -1) (CHARCODE %'))) (CAR TAIL)) (T (CLISPIFY2 (CAR TAIL) (COND ((EQ NOVALFLG T)) (NOVALFLG (NEQ TAIL NOVALFLG] (SETQ PREVEXP (CAR TAIL)) [COND ((OR SEG (NEQ TEM (CAR TAIL)) OPR0 (EQ CLTYP0 T)) (* The idea in CLISPIFYing is to do as few CONSes as necessary, i.e.  only construct new structure where needed.  TAIL0 keeps track of the last point in TAIL for which a corresponding element  has been added to L. Here we know that a new element will hve to be added to L,  and so any intermediate elements that were not added because the clispified  result was the same as the original structure, will now have to be added, e.g.  consider (LIST A B (SETQ X Y) C D E)%. The C D and E tail need not be copied,  however until we reach (SETQ X Y) we do not know that the A and B will have to  be copied, i.e in (LIST A B C) no conses are performed.  Note that CLTYP0=T is effectively a COPYFLG.  This is used in particular when CLISPIFYING a COND, i.e.  OPR0 is NIL, but CLTYP0 isT.) [AND (NEQ TAIL TAIL0) (SETQ LST (NCONC LST (LDIFF TAIL0 TAIL] [SETQ LST (COND (SEG (* Supposedly, whenever SEG is set to T, the entire form has already been  copied. An EQ check is not sufficient, as expressions produced by CLIPIFYing  may not be EQ to original expressions, but still have common tails.) (NCONC LST TEM)) (T (NCONC1 LST TEM] (SETQ TAIL0 (CDR TAIL] (SETQ TAIL (CDR TAIL)) (SETQ SEG NIL) (GO LP]) (CLISPIFY2 [LAMBDA (FORM NOVALFLG NEGFLG) (* lmm " 5-SEP-83 13:26") (* CLISPIFIES a form.) (* NOVALFLG is T if FORM is not  being used for value.) (AND FORM (PROG NIL (COND ((AND (LITATOM FORM) OPR0 CLTYP0 (FMEMB FORM CLISPCHARS)) (* this check was originally installed because of users who had variables with  same name as clisp oprators, and didnt want them to gt packed.) [PROG (POS) (COND ((SETQ POS (STKPOS 'CLISPIFY2B)) (RETEVAL POS 'FORM T] (* CL call on a tail.  screw it.) )) LP (RETURN (OR (CLISPIFY2B FORM) (GO LP))) (* CLISPIFY2b returns NIL (via a RETFROM in CLISP3) when it was necessary to  DWWIMIFY the prent expression and staat over, e.g.  (FOO X* (IPLUS Y Z)) note that (FOO X *  (IPLUS X Y)) wont be touched at all because the * causes an abort) ]) (CLISPIFY2A [LAMBDA (FORM FLG) (* Whereas the value of CLISPIFY2 is either an item or a segment, depending on  SEG, the value of CLISPIFY2A is always a segment, so thatthe caaling function  need not check SEG, it can just NCONC or APPEND.) (PROG (TEM SEG) (SETQ TEM (CLISPIFY2 FORM)) (RETURN (COND ([AND SEG (OR (NULL FLG) (NULL (CDR TEM] (* If FLG is T, the expression is to be parenthesized, even if SEG is T, unless  it is just atomic.) TEM) (T (LIST TEM]) (CLISPIFY2B [LAMBDA (FORM) (* lmm "27-Jan-85 00:29") (* Does the work of CLISIPIFY2. This function is separate from CLISPIFY2 so  that CLISPIFYNOT can CLISPIFY the inner form, and then check to ee if NEGLFG  has been set to NIL. It is also used when a for a %'recursive' call on the same  or equivalent form, again so that NEGFLG is not rebound, e.g.  (ADD1 --) is the same as (IPLUS -- 1)%, and is implemented by caaling  CLISPIFY2b again, itead of CLISPIFY2.) (PROG (TEM1 TEM2 TEM3) [COND ((NLISTP FORM) (COND ([AND (LISTP CLTYP0) (SETQ TEM1 (GETPROP FORM 'CLISPWORD)) (EQ (CAR TEM1) (CAR (GETPROP (CAR CLTYP0) 'CLISPWORD] [AND LCASEFLG (SETQ TEM2 (COND ((NLISTP (CDR TEM1)) (CDR TEM1)) (T (* The CLISPWORD property can be of the form  (FIND find FOR) when FIND is a synonym for FOR.) (CADR TEM1] (* Converts FOR words and IF words  to loercase.) (SETQ CLTYP0 TAIL))) (RETURN (OR TEM2 FORM))) ((LISTP (CAR FORM)) (RETURN (CLISPIFY1 FORM] [RETURN (SELECTQ (CAR FORM) (FUNCTION (CLISPIFY2C FORM)) (CAR (CLISPIFYCROPS0 '(%:1))) (CDR (CLISPIFYCROPS0 '(|::1|))) ((LAST FLAST) (AND (NEQ (CAR FORM) (CLISPIFYLOOKUP (CAR FORM) (CADR FORM) (CADDR FORM))) (GO A)) (CLISPIFYCROPS0 (LIST -1))) (NLEFT (COND [(AND (NUMBERP (SETQ TEM1 (CADDR FORM))) (NULL (CDDDR FORM))) (CLISPIFYCROPS0 (LIST (MINUS TEM1] (T (GO A)))) ((NTH FNTH) (* (NTH X 10) clispifies to |X::9|) (COND [[AND CL%:FLG (NUMBERP (CADDR FORM)) (EQ (CAR FORM) (CLISPIFYLOOKUP (CAR FORM) (CADR FORM] (CLISPIFYCROPS0 (LIST (SUB1 (CADDR FORM] (T (GO A)))) ((RPLACA FRPLACA /RPLACA) (CLISPIFYRPLAC FORM '%:1 T)) ((RPLACD FRPLACD /RPLACD) (CLISPIFYRPLAC FORM '|::1| T)) ((CLISP%: GO DECLARE) FORM) (* (COND ((EQ (CADR FORM) 'DECLARATIONS%:) (CONS 'CLISP%: (CDDR FORM))) (T FORM))) (COND (COND ((NULL (GETP 'IF 'CLISPWORD)) (GO A)) [(CDR FORM) (FRPLACA (PROG ((L FORM) VAL) (* An open MAPCONC.) LP (COND ((NULL (SETQ L (CDR L))) (RETURN VAL))) (SETQ VAL (NCONC VAL (CLISPCOND (CAR L) (CDR L) VAL))) (GO LP)) (COND (LCASEFLG 'if) (T 'IF] (T FORM))) ((AND OR) (COND ((NULL (GETP 'IF 'CLISPWORD)) (GO A)) (NOVALFLG (* Treat AND as COND.) (CLISP4 PARENT SUBPARENT) (SELECTQ (CAR FORM) (AND [FRPLACA (CLISPAND FORM) (COND (LCASEFLG 'if) (T 'IF]) (OR (COND [(NULL (CDDDR FORM)) (FRPLACA (CLISPCOND (CONS (LIST 'NOT (CADR FORM)) (CDDR FORM))) (COND (LCASEFLG 'if) (T 'IF] (T (GO A)))) (SHOULDNT))) (T (GO A)))) (SELECTQ [PROG (OPR0 CLTYP0 PARENT SUBPARENT) (CLISP4 FORM) (SETQ PARENT FORM) (SETQ SUBPARENT (CDR FORM)) (SETQ TEM1 (CLISPIFY2A (CADR FORM) T)) [SETQ TEM2 (AND (CDDDR FORM) (MAPCAR (CDDR FORM) [FUNCTION (LAMBDA (FORM) (COND [(LISTP FORM) (CONS (CAR FORM) (CLISPIFY1 (CDR FORM) NIL NIL NIL (OR NOVALFLG 'NOTLAST] (T FORM] (FUNCTION (LAMBDA (X) (AND (CDDR X) (CDR X] (RETURN (CONS 'SELECTQ (NCONC TEM1 TEM2 (CLISPIFY2A (CAR (LAST FORM)) T]) (PROGN (SETQ TEM1 (CLISPIFY1 (CDR FORM) NIL NIL NIL 'NOTLAST)) (* novalflg used to be (OR NOVALFLG (QUOTE NOTLAST)) however, this caused a bug  in the case where one had FOO_ (PROGN --) at the top level, because the FFO_  never got translated because the PROGN didnt require it.  rather than fix this, obseeve that if in fact PROGN were in noval context, then  the user would not need a progn at all, so lets just assume that a progn is  always in value context, and specify NOTLAST in the call to clispify1) (CLISPIFY2C FORM TEM1)) (NULL [COND ((AND (LISTP (CADR FORM)) (GETPROP (SETQ TEM1 (CAADR FORM)) 'CLISPTYPE)) (* e.g. (NULL (NUMBERP X)) is  treated as (NOT (NUMBERP X))) (CLISPIFYNOT (CADR FORM))) (T (* reason for not simply resetting form and jumping to top has to do with the  way clispify handle partially clispifyed expressions namely, by dwimifying the  expression, retfroming NIL from cal to clispify2b, and having clispify2 then  try again, relying on the fact that dwimify has physically changed form.  If we just reset form here, and there was any clisp in the original form, an  infinite loop wouldoccur since clipify2 would keep retrying with original form.) (CLISPIFY2 (LIST 'EQ (CADR FORM) NIL) NOVALFLG (PROG1 NEGFLG (SETQ NEGFLG]) (NOT (CLISPIFYNOT (CADR FORM))) (SETQ (SETQ VARS (CONS (CADR FORM) VARS)) (* In case any dwimifying occurs as  a result of partial clispification.) [AND (CDDDR FORM) (SETQ FORM (LIST (CAR FORM) (CADR FORM) (CONS 'PROG1 (CDDR FORM] (GO A)) (SETQQ (COND ((AND CLISPFLG (GETPROP '_ 'CLISPTYPE)) (CLISPIFY2 [LIST 'SETQ (CADR FORM) (COND ((OR (NULL (SETQ TEM1 (CADDR FORM))) (NUMBERP TEM1)) TEM1) (T (LIST 'QUOTE TEM1] NOVALFLG NEGFLG)) (T (GO B)))) ((match MATCH) [PROG ((OPR0 (AND [NULL (CDR (SETQ TEM2 (CDDDR FORM] OPR0))) (* OPR0 rebound to NIL if -> or => used in match expression, because in this  case, want CLISPIFYCROPS to %'wrap it up'.) (SETQ TEM1 (CLISPIFYCROPS (CADR FORM) (LIST (CAR TEM2)) 'match] [COND ((NULL (SETQ TEM2 (CDR TEM2))) TEM1) (T (NCONC TEM1 (CONS (CAR TEM2) (CLISPIFY1 (CDR TEM2]) ((fetch FETCH) (COND ([AND (EQLENGTH FORM 4) (FMEMB (CADDR FORM) '(of OF] (CLISP4 FORM) (CLISPIFYCROPS (CADDDR FORM) (LIST (CADR FORM)) 'fetch)) (T (GO A)))) ((replace REPLACE) (COND ([AND (EQLENGTH FORM 6) (OR (EQ (SETQ TEM1 (CADDR FORM)) 'OF) (EQ TEM1 'of)) (OR (EQ (SETQ TEM1 (CAR (CDDDDR FORM))) 'WITH) (EQ TEM1 'with] (CLISPIFYRPLAC FORM 'replace T)) (T (GO A)))) (ASSEMBLE FORM) (COND ((EQ (CAR FORM) CLISPTRANFLG) (SETQ FORM (CDDR FORM)) (CLISPIFY1 FORM NIL FORM)) ((FMEMB (CAR FORM) CLISPCHARS) (RETURN FORM)) [(AND (OR (EQMEMB 'BINDS (GETPROP (CAR FORM) 'INFO)) (FMEMB (CAR FORM) LAMBDASPLST)) (NOT (CLISPIFY2D FORM))) (* lambda, nlambda, dlambda, prog,  resetvars, etc.) (CONS (COND [(AND [LISTP (SETQ TEM2 (GETP (CAR FORM) 'CLISPWORD] LCASEFLG) (COND ((NLISTP (CDR TEM2)) (CDR TEM2)) (T (CADR TEM2] (T (CAR FORM))) (CONS [COND ((NULL (CADR FORM)) NIL) ((NLISTP (CADR FORM)) (* This is a quick and dirty attempt to collect vars in cse have to call  DWIMIFY1B. VARS are not rebound each expression, so open lambda variables will  justbuild up. if this turns out to be a problem, will have to rebind vars each  time we call clispify) (SETQ VARS (CONS (CADR FORM) VARS)) (CADR FORM)) (T (MAPCAR (CADR FORM) (FUNCTION (LAMBDA (X) (COND ((NLISTP X) (SETQ VARS (CONS X VARS)) X) (T (SETQ VARS (CONS (CAR X) VARS)) (CONS (CAR X) (CLISPIFY1 (CDR X] (CLISPIFY1 (WHILEDOUNTIL (CDDR FORM)) NIL (AND (GETP (CAR FORM) 'CLISPWORD) FORM) NIL (COND ((MEMB 'LABELS TEM1) (* e.g. prog no member used for  value) T) ((MEMB 'PROGN TEM1) (* e.g. lambdas, nlambdas.  only last element is used for value) (OR NOVALFLG 'NOTLAST)) (T (* e.g. for %, bind) NIL] (T (GO A] A [COND [(AND (SETQ TEM1 (GETPROP (CAR FORM) 'CROPS)) (NEQ (CAR FORM) 'GETPROPLIST)) (RETURN (CLISPIFYCROPS0 (SUBPAIR '(A D) '(%:1 |::1|) TEM1] [[AND (SETQ TEM1 (GETPROP (CAR FORM) 'CLISPCLASS)) (SETQ TEM3 (GETPROP TEM1 'CLISPTYPE] (* E.G. (CAR FORM) is FPLUS, TEM1 is  +.) (COND ([EQ (CAR FORM) (CLISPIFYLOOKUP (CAR FORM) (CADR FORM) (CADDR FORM) TEM1 (GETPROP TEM1 'CLISPCLASSDEF] (RETURN (CLISP3 (OR (GETPROP (GETPROP TEM1 'LISPFN) 'CLISPINFIX) TEM1) FORM TEM3)) (* TEM1 is now for example LT. Reason for not siply passing LT is this permits  user to put lower case lt on property lst of ILESSP under clispifnix property.) ] ((AND (SETQ TEM1 (GETPROP (CAR FORM) 'CLISPINFIX)) (CDDR FORM) (OR NEGFLG OPR0 CLTYP0 (FMEMB TEM1 CLISPCHARS))) (* E.g. IF (CAR FORM) is EXPT, TEM1 would be ^.  The CLTYP0 is because only want to convert to infix if under another operator,  e.g. (LIST (AND X Y)) is clearer than (LIST  (X AND Y))) (RETURN (CLISP3 TEM1 FORM (GETPROP TEM1 'CLISPTYPE] [RETURN (COND ((SETQ TEM1 (GETPROP (CAR FORM) 'CLISPFORM)) (* E.G. NEQ, ADD1, and SUB1.) (* code used to say (GO TOP)%. Then was changed to call Clispify2.  Callin clipify2 has a bad effect when negflg is t as it introduces an extra  binding of negflg.) (CLISPIFY2B (LSUBST (CDR FORM) '* TEM1))) [[AND (SETQ TEM1 (GETPROP (CAR FORM) 'CLISPBRACKET)) (SETQ TEM2 (GETPROP TEM1 'CLISPBRACKET] (COND [(SETQ TEM3 (LISTGET1 TEM2 'CLISPIFY)) (* built in userfn) (COND ((EQ TEM3 'SHRIEKIFY) (COND ([OR (NULL CLISPFLG) (NULL (GETPROP TEM1 'CLISPTYPE)) NOVALFLG (NULL (SETQ TEM1 (PROG ((PARENT FORM)) (RETURN (SHRIEKIFY FORM] (GO B)) ((EQ (CAR TEM1) '<) (CLISP3 '< TEM1 'BRACKET T)) (T (* E.G. didnt convert because of  declarations.) TEM1))) (T (SETQ TEM1 (APPLY* TEM3 FORM] ((GETP TEM1 'UNARYOP) (SETQ TEM3 (CLISPIFY1 (CDR FORM) (OR (SETQ TEM3 (LISTGET1 TEM2 'SEPARATOR)) T) 'BRACKET)) (CLISP3 TEM1 [CONS (CAR TEM2) (APPEND TEM3 (LIST (CADR TEM2] 'BRACKET T)) (T (SETQ TEM3 (CLISPIFY1 (CDDR FORM) (OR (SETQ TEM3 (LISTGET1 TEM2 'SEPARATOR)) T) 'BRACKET)) (CLISP3 TEM1 [CONS (CLISPIFY2 (CADR FORM)) (CONS (CAR TEM2) (APPEND TEM3 (LIST (CADR TEM2] 'BRACKET T] [[LISTP (SETQ TEM1 (GETPROP (CAR FORM) 'SETFN] (* The third aagument to CLISPIFYRPLAC indicates this is a %: transformation.  It is also true if there is an ACCESSFN property.  E.g. FOO has ACCESSFN GETFOO SETFN SETFOO and SETFOO has SETFN  (FOO)) (CLISPIFYRPLAC FORM (CAR TEM1) (GETPROP (CAR TEM1) 'ACCESSFN] ((AND TEM1 (EQ (SETQ TEM2 (GETPROP (CAR FORM) 'ACCESSFN)) (CAR FORM))) (* Occurs when FOO is its own  accessfn, e.g. FOO has ACCESSFN FOO  SETFN SETFOO.) (CLISPIFYCROPS0 (LIST TEM2))) ([LISTP (SETQ TEM1 (GETPROP (CAR FORM) 'ACCESSFN] (CLISPIFYCROPS0 TEM1)) [(AND (SETQ TEM1 (GETPROP (CAR FORM) 'CLMAPS)) (CLISPIFYMAPS (CAR TEM1) (CDR TEM1] ((AND (LITATOM (CAR FORM)) (NULL (FGETD (CAR FORM))) (GETPROP (CAR FORM) 'CLISPWORD) (NOT (CLISPIFY2D FORM))) (CLISPIFY1 FORM NIL FORM)) ((CLISPNOEVAL (CAR FORM) T) (* Dont clispify the tails of  nlambdas that dont evaluate their  arguments.) FORM) ((AND CLISPIFYUSERFN (SETQ TEM1 (CLISPIFYUSERFN FORM))) TEM1) ((AND [COND [(LITATOM (CAR FORM)) (NULL (FGETD (CAR FORM] ((LISTP (CAR FORM)) (NULL (OR (EQ (CAAR FORM) 'LAMBDA) (EQ (CAAR FORM) 'NLAMBDA] (GETHASH FORM CLISPARRAY)) (PUTHASH FORM NIL CLISPARRAY) (CLISPIFY2B FORM)) ((NULL (CDR FORM)) (* NULL checks for No arguments, so must leve as item since otherwise would be  convereted by dwimify to a variable, e.g.  (EQ (FOO) FORM) cannot become FOO=X. The AND checks for nlambdas.) FORM) (T (GO B] B (* On this call subparent is specified as being the fomr itself because OF  cases like (x* (IPLUS X Y))) (RETURN (CLISPIFY2C FORM NIL FORM]) (CLISPIFY2C [LAMBDA (FORM X SUBPARENT) (* lmm "27-FEB-83 10:38") (* (CAR FORM) is not to be treated  specially. CLISPIFY2C simply calls  CLISPIFY1.) (OR X (SETQ X (CLISPIFY1 (CDR FORM) NIL NIL NIL (COND ((EQMEMB 'PROGN (GETPROP (CAR FORM) 'INFO)) 'NOTLAST)) SUBPARENT))) (COND ((NEQ X (CDR FORM)) (CONS (CAR FORM) X)) (T FORM]) (CLISPIFY2D [LAMBDA (FORM) (* wt%: "23-JUL-78 23:32") (* expressions like (SUM + X) do not translate into iterative statements,  (see wtfix1) so that when clipified, they should not be lowercased.  this function returns T if the second element of an the form, X, would cause  the expression not to dwimify as an i.s.) (PROG (TEM) (RETURN (AND (SETQ TEM (CADR FORM)) (LITATOM TEM) (OR (GETPROP TEM 'CLISPTYPE) (MEMB (SETQ TEM (NTHCHAR TEM 1)) CLISPCHARS)) (NOT (GETPROP TEM 'UNARYOP)) [NOT (BOUNDP (SETQ TEM (CADR FORM] (NOT (MEMB TEM VARS)) (NOT (MEMB TEM NOFIXVARSLST)) (NOT (GETPROP TEM 'GLOBALVAR)) (NOT (MEMB TEM GLOBALVARS]) (CLISP3 [LAMBDA (OPR X CLTYP FLG) (* lmm " 5-SEP-83 23:53") (PROG (L (BROADSCOPE (GETPROP OPR 'BROADSCOPE)) TEM CLISPISTATE) [COND ((OR (NULL CLTYP) (NULL CLISPFLG)) (* This permits user to disable CLISPIFY transformations and CLISP  transformaions simply by remving CLISPYTPE property) (RETURN (CLISPIFY2C X] (SETQ L (CDR X)) (COND (FLG (* X was alrady CLISPIFIED.  Used by CLISPIFYNOT) (SETQ L X) (GO OUT)) ((EQ OPR '%') (SETQ L (LIST OPR (CAR L))) (GO OUT)) ([AND NEGFLG [OR (NULL CLISPIFYENGLSHFLG) (NULL (GETPROP OPR 'CLISPIFYISPROP] (SETQ TEM (GETPROP OPR 'CLISPNEG] (SETQ NEGFLG NIL) (SETQ FLG T) (* FLG is set so that clisp3 can know that negflg ws turned off in case for  some reason it was unable to convert to clispify, e.g.  variable was also name of function.) (SETQ OPR TEM))) [AND (NULL (GETPROP OPR 'UNARYOP)) (NULL (CDR L)) (COND [(EQ (ARGTYPE (GETP OPR 'LISPFN)) 2) (* E.G. (IPLUS X)) (RETURN (CONS (CAR X) (CLISPIFY1 (CDR X] (T (SETQ L (LIST (CADR X) NIL] (AND PARENT (CLISP4 PARENT SUBPARENT)) (* e.g. |...| x* (iplus y z) need to dwimify the higher expression in order to  discover the X* and to know that (iplus y z) must be parenthesized) (CLISP4 X) (* e.g. (iplus x _  (exp) z)) (SETQ L (CLISPIFY1 L OPR CLTYP BROADSCOPE)) OUT (COND ([OR (EQ (CAR L) '-) (AND (NUMBERP (CAR L)) (MINUSP (CAR L] (* Unary minus must be parenthesized) (SETQ SEG NIL)) [(NULL OPR0) (* Parent form is a regular function) (SETQ SEG (COND (CLTYP0 (* Parent form is an IF or FOR. Pathological cases occur when clispifying an  already paatially clispified expression, e.g.  (IF a then (AND B C) D)%. Here cant remove parentheses, but in  (IF (AND A B) THEN C) you can) (COND ((OR (EQ CLTYP0 'COND) (EQ CLTYP0 'IS)) (* Started out with a COND. CLISPCOND is careful about setting CLTYP0 so it is  safe to remove parentheses) T) ((NLISTP CLTYP0) (SHOULDNT)) ([AND (EQ TAIL (CDR CLTYP0)) [OR (NULL (CDR TAIL)) (EQ (CAR (GETPROP (CADR TAIL) 'CLISPWORD)) (CAR (GETPROP (CAR CLTYP0) 'CLISPWORD] (NULL (SOME L (FUNCTION (LAMBDA (X) (LISTP (GETPROP X 'CLISPWORD] (* Says there is only one expression there so safe to remove parentehses, e.g.  (IF A THEN (AND B C) ELSE D) The reason for the SOME is that cant remve parens  if any of the words in L are also operators, e.g.  user writes (WHILE (IGREATERP X COUNT) do --) can't remove parens because COUNT  is also an operator) T))) (BROADSCOPE (* If BROADSCOPE is T, form must be parentheseized, e.g.  (FOO (AND X Y)) must be (FOO (X AND Y)) not  (FOO X AND Y)) NIL) ((NULL CLISPIFYPACKFLG) (NOT (CLISPNOEVAL (CAR PARENT) T))) (T T] ((OR (AND (LITATOM (CAR L)) (FGETD (CAR L))) (CLISP3B OPR CLTYP)) (SETQ SEG NIL)) (T (SETQ SEG (COND ((AND BROADSCOPE (EQ CLTYP0 'BRACKET)) NIL) (T T))) (* And packing will be done by  higher operator) (RETURN L))) (SETQ TEM (CLISP3A L)) (RETURN (COND ((AND (LITATOM (CAR L)) (CLISPNOEVAL (CAR L))) (* Kaplan insists on this check. He has variables and nlambda function of the  same name. Note if function isnot defined at clispify time, you lose, i.e.  (AND FOO X) will go to (FOO AND X)) (SETQ NEGFLG FLG) (* SEE COMMENT AT CHECK FOR NEGFLG  EARLIER.) (SETQ SEG NIL) (CLISPIFY2C X)) (T TEM]) (CLISP3A [LAMBDA (L) (* lmm "27-FEB-83 09:14") (* L is a list of operands and operators.  CLISP3A packs up the atoms. Its value is always a list.  CLISPCHARS is a list of those infix operators which can be packed with their  operands. Most of these are single characters, but for example ~= appears on  this list.) (SETQ L (CLISPACKUP L)) (COND ([SELECTQ (CAR PARENT) ((SELECTQ SETN) (* if packing results in more than  one expression, then must put parens  around it.) (CDR L)) (EQMEMB 'LABELS (GETPROP (CAR PARENT) 'INFO] (SETQ SEG NIL))) L]) (CLISP3B [LAMBDA (OPR CLTYP) (* wt%: " 2-JUL-78 18:07") (* called by clisp3 and clispifycrops. determines if parens are needed around  the operator cluster by checking whether higher operator would incorrectly  gobble parts of this one OR is true if inner operaton must be parenthesized.  First clause corresponds to case where there is an operand to the left of this  one, and the inner operator would stop the scan of the outer one, i.e.  the one on the left, e.g. (ITIMES A (IPLUS B C))%, must go to A*  (B+C)%. Second clause corresponds to case where there is an operand to the  right of this one, and the outer operator, i.e.  the one on the right, would NOT stop the inner, e.g.  (ITIMES (IPLUS A B) C)%, mustgo to (A+B) *C.) (* The AND LISTP ILESSP expression is to cover the case handled specially in  stopscan?, namely that of A*B_Y+C grouping as A*  (B_Y+C) because the right precedence of _ is looser than that of *.  This is handled here by making the same comparison.  It will result in some extra unnecessary parens in some cases, e.g.  (ITIMES A (SETQ B (IPLUS C D))) clispifies to  (A* (B_Y+C))%. However, note that in (IPLUS  (ITIMES A (SETQ B Y)) C)%, the parens in  (A* (B_Y) +C) ARE necessary. However, the information relating to this is TWO  tails above this operator, so better just to be safe.) (AND OPR0 (NEQ CLTYP0 'BRACKET) (NEQ CLTYP 'BRACKET) (OR [AND LST (OR (CLSTOPSCAN? CLTYP CLTYP0) (AND (LISTP CLTYP) (ILESSP (CDR CLTYP) (COND ((ATOM CLTYP0) CLTYP0) (T (CDR CLTYP0] (AND (CDR TAIL) (NOT (CLSTOPSCAN? CLTYP0 CLTYP]) (CLISPACKUP [LAMBDA (L) (* wt%: " 9-JAN-80 20:47") (PROG ((LL L) L1 L2 TEM L-1 OPRFLG) TOP [COND ((NOT (ATOM (CAR LL))) (SETQ L-1 NIL) (GO PACKUP)) ((EQ (CAR LL) '%') (* %' has to be handled specially) [COND ((OR (NOT (FMEMB (CAR L2) CLISPCHARS)) (EQ (CAR L2) '!)) (* If the previous element was NOT an operatr, the %' must start a separate  atom, therefore pack up the segment up to the %'.) (CLISP3C L1 L2) (AND (ATOM (CADR LL)) (CLISP3C LL (CDR LL))) (* The %' and its argument must also be packed up, even if other opeators  follow, because %' is always the last operaar in an atom.) ) (T (SETQ LL (CLISP3C L1 (COND ((ATOM (CADR LL)) (CDR LL)) (T LL] (SETQ L1 (SETQ L-1 NIL)) (GO LP1)) [(OR (NOT (FMEMB (CAR LL) CLISPCHARS)) (EQ (CAR LL) '!)) (COND ((NOT (LITATOM (CAR LL))) (SETQ L-1 LL)) ((FMEMB 'CLISPTYPE (GETPROPLIST (CAR LL))) (* FMEMB is used instead of GETPROP so that we can tell CLISP3A not to pack up  thinks like ~EQUAL without making them be oprators.) (SETQ L-1 NIL) (GO PACKUP)) ([COND (FUNNYATOMLST (* The STRPOSL in the next clause slows CLISPIFY down about 10 per cent, but is  necessary to catch funnyatoms. If the user specifies FUNNYATOMLST, its a little  faster.) (AND (NEQ FUNNYATOMLST T) (FMEMB (CAR LL) FUNNYATOMLST))) (T (STRPOSL CLISPCHARRAY (CAR LL] (* The STRPOSL prevents a %'funny atom' from being packed with another  operator, e.g. (IPLUS *X Y) goes to *X +Y.  Setting OPRFLG to NIL will cause us to GO to PACKUP.) (SETQ L-1 NIL) (GO PACKUP)) (T (SETQ L-1 LL))) (COND (OPRFLG (* OPRFLG is T if previous element  was a CLISPCHAR. Therefore, continue  scanning this cluster.) (GO LP1)) (T (GO PACKUP] ((SETQ TEM (GETPROP (CAR LL) 'CLISPBRACKET)) (COND [(AND (EQ (CAR LL) (CAR TEM)) (NEQ (CAR L2) (CAR TEM))) (COND ((GETPROP (CAR LL) 'UNARYOP) (CLISP3C L1 L2) (SETQ L1 (SETQ L-1 NIL] ((AND (EQ (CAR LL) (CADR TEM)) (NEQ (CADR LL) (CADR TEM))) (SETQ LL (CLISP3C (COND ((OR (EQ (CAR (SETQ TEM (OR L1 L-1))) '+) (EQ (CAR TEM) '-)) (CDR TEM)) (T TEM)) LL)) (SETQ L1 (SETQ L-1 NIL)) (GO LP1] (* At this point we know that the  current element is a CLISPCHAR.) (AND (NULL L1) (SETQ L1 (OR L-1 LL))) (* L1 marks the beginning of the sequence of atoms to be packed.  If L-1 is not NIL, the atom before this one is not a CLISP word and is to be  included, e.g. (A + B) Note that we don't want to set L1 until we do see a  CLISPCHAR, e.g. (AND A B (EQ X Y)) beecomes  (A AND B AND X=Y)%. This is why we must save the last non-operator on L-1 until  this point.) (COND ((EQ (CAR LL) '+) (AND (EQ (CADR LL) '-) (FRPLACA LL '+-) (FRPLACD LL (CDDR LL))) (* This simplifies the code as it allows  (IPLUS -- (IMINUS --) --) to be treated the same as IDIFFERENCE.) ) ((NEQ (CAR LL) '+-) (GO A))) (* At this point we know (CAR L) is either a + or a +-.  (+- is the symbol for binary miinus.) The next COND checks for some special  cases.) [COND [(AND L-1 (NUMBERP (SETQ TEM (CADR LL))) (MINUSP TEM)) (AND [COND ((EQ (CAR LL) '+-) (* E.g. (IDIFFERENCE X -3) -> X +- -3 so change the +-  to + and reverse the sign.) (FRPLACA LL '+)) ((GETPROP '- 'CLISPTYPE) (* E.g. (IPLUS X -3) -> X + -3, so change the + to -  and reverse the sign. The GETPROP is because -  may be disabled, and wold not be detected beyond this point.  Note that if user disables -, he should also disable +-.) (FRPLACA LL '-] (FRPLACA (CDR LL) (MINUS TEM] ((EQ (CAR LL) '+-) (COND ((EQ (CADR LL) '-) (* E.g. (IDIFFERENCE X (IMINUS &)) -> X +-  -&, so change the +- to + and reverse the sign) (FRPLACA LL '+) (FRPLACD LL (CDDR LL))) (T (FRPLACA LL '-] A (SETQ L-1 NIL) (SETQ OPRFLG T) (GO LP) LP1 (SETQ OPRFLG NIL) LP (SETQ L2 LL) (* L2 stays one behind L0.) (COND ((NULL LL)) ((SETQ LL (CDR LL)) (GO TOP)) (T (GO PACKUP))) (RETURN L) PACKUP (AND L1 (CLISP3C L1 L2)) (SETQ L1 NIL) (GO LP1]) (CLISP3C [LAMBDA (L1 L2) (* lmm "24-DEC-81 13:28") (PROG (TEM (L3 (CDR L2))) (COND ((NULL L1) (RETURN L2)) ((EQ L2 L1) (RETURN L1))) (FRPLACD L2) [COND (CLISPIFYPACKFLG [SETQ TEM (RESETVARS (PRXFLG) (RETURN (PACK L1] (COND ((AND [COND (SEG (NOT (BOUNDP TEM))) (T (NOT (FNTYP TEM] (NOT (FMEMB TEM FUNNYATOMLST)) (NOT (NUMBERP TEM))) (* The FMEMB prevents packing up (ITIMES A B) ino A*B if A*B is a %'funny  atom', since in this case it wold not ever be unpacked by DWIM.  The check for clipifypackflg is made here rather than in clisp3a before calling  clispackup because the smarts for converting +-  to -  are in clispackup.) (FRPLACA L1 TEM) (FRPLACD L1 L3) (RETURN L1] (RETURN (FRPLACD L2 L3]) (CLISP4 [LAMBDA (EXP SUBPARENT) (* lmm "19-Jun-86 14:26") (* CLISP4 is called when an xpression is abut to be converted into infix  notation. IN this case, both the interior of the expression, and its parent,  are examined. SUBPARENT is used when checking the parent, i.e.  exp = parent, to prvent backing up to far, e.g.  (SELECTQ (= (SETQ X 5)) T)) (COND ([AND CLISPFLG (NEQ (CAR EXP) 'SETQ) [NOT (EQMEMB 'LABELS (GETPROP (CAR EXP) 'INFO] (NULL (GETHASH EXP CLISPARRAY)) (SOME (OR SUBPARENT EXP) (FUNCTION (LAMBDA (X $TAIL) (AND (LITATOM (CAR $TAIL)) (NOT (BOUNDP (CAR $TAIL))) (NOT (FMEMB (CAR $TAIL) VARS)) [NULL (AND (EQ $TAIL EXP) (FGETD (CAR $TAIL] (PROG ((N 1)) LP (COND ((NULL (SETQ N (STRPOSL CLISPCHARRAY (CAR $TAIL) N))) (RETURN NIL)) ((GETPROP (NTHCHAR (CAR $TAIL) N) 'CLISPTYPE) (RETURN N))) (SETQ N (ADD1 N)) (GO LP] (PROG (POS FLG) [PROG ((DWIMIFYFLG 'CLISPIFY) (NOSPELLFLG T)) (SETQ FLG (DWIMIFY0? EXP (OR SUBPARENT EXP) NIL NIL NIL CLISPIFYFN 'LINEAR] LP (COND [(NULL (SETQ POS (STKPOS 'CLISPIFY2B -1 POS POS))) (* Can occur if user calls CL at  funny) (RETFROM 'CLISPIFY (APPLY 'CLISPIFY (STKARGS 'CLISPIFY] ((OR (NEQ (STKEVAL POS 'FORM) EXP) (NOT FLG)) (RETEVAL POS 'FORM T)) (T (RETFROM POS NIL T]) (CLISPCOND [LAMBDA (CLAUSE CPYFLG VAL) (PROG (OPR0 (CLTYP0 'COND) TEM1 TEM2 PARENT SUBPARENT) (* CLTYP0 is bound inform CLISP3 that it is ok to remove parentheses from  expressions converted to infix notation, e.g.  (SETQ CLAUSE (FOO))) (RETURN (COND [(AND VAL (EQ (CAR CLAUSE) T)) (* Don't use ELSE unless previous clauses seen, otherewise  (COND (T --)) gets messed up, i.e. becomes IF --.) (CONS (COND (LCASEFLG 'else) (T 'ELSE)) (CLISPCOND1 (CDR CLAUSE] (T [SETQ TEM1 (AND (CDR CLAUSE) (CONS (COND (LCASEFLG 'then) (T 'THEN)) (CLISPCOND1 (CDR CLAUSE) CPYFLG] (SETQ TEM2 (CLISPIFY2 (CAR CLAUSE))) (CONS (COND (LCASEFLG 'elseif) (T 'ELSEIF)) (COND (SEG (SETQ SEG NIL) (NCONC TEM2 TEM1)) ((CLREMPARS TEM2) (* Says is a small list.) (APPEND TEM2 TEM1)) (T (CONS TEM2 TEM1]) (CLISPCOND1 [LAMBDA (L CPYFLG) (* If CPYFLG is T, something will be NCONCed onto the value returned by  CLISPCOND1, so we must make sure that it does not aapear in the original  function.) (PROG (TEM) [SETQ TEM (CLISPIFY1 L NIL (AND (NULL (CDR L)) 'COND) NIL (OR NOVALFLG 'NOTLAST] (RETURN (COND [(AND (NULL (CDR TEM)) (CLREMPARS (CAR TEM))) (COND ([AND CPYFLG (EQ (FLAST (CAR TEM)) (FLAST (CAR L] (* FLAST i is necesaary because forms may not be EQ but still have common  tails, ee.g. (FOO (SETQ X Y) Z) becomes  (FOO X_Y Z)%, but (Z) is same as in original expression.) (APPEND (CAR TEM))) (T (CAR TEM] ((AND CPYFLG (EQ (FLAST TEM) (FLAST L))) (APPEND TEM)) (T TEM]) (CLISPAND [LAMBDA (FORM) (* wt%: 3-AUG-77 3 1) (PROG (TEM) (CLISP4 FORM) (RETURN (CLISPCOND (COND ((OR (NULL (CDDDR FORM)) (CLISPAND1 (CADDR FORM))) (* E.G. (AND X Y) -> IF X THEN Y. Similary,  (AND X Y --) -> IF X THEN Y -- if it is known that Y is always true.) (CDR FORM)) (T (* E.G. (AND X Y Z) -> IF X AND Y  THEN z.) (CONS [LDIFF FORM (SETQ TEM (OR (SOME (CDDDR FORM) (FUNCTION CLISPAND1)) (FLAST FORM] TEM]) (CLISPAND1 [LAMBDA ($FORM) (* Returns T if $FORM is known to return a NON-NIL value.  used in clispifying ANDs.) (COND ((LISTP $FORM) (SELECTQ (CAR $FORM) ((CONS LIST RPLACA RPLACD FRPLACA FRPLACD /RPLACA /RPLACD) T) (QUOTE (CADR $FORM)) (SETQ (CLISPAND1 (CADDR $FORM))) (SETQQ (CADDR $FORM)) ((PRINT PRIN1) (CLISPAND1 (CADR $FORM))) (COND [AND (CLISPAND1 (CAAR (FLAST $FORM))) (EVERY (CDR $FORM) (FUNCTION (LAMBDA (CLAUSE) (CLISPAND1 (CAR (FLAST CLAUSE]) NIL)) ((LITATOM $FORM) (EQ $FORM T)) (T T]) (CLISPIFYNOT [LAMBDA (FORM) (* lmm "12-AUG-84 23:28") (PROG (TEM1 TEM2) (SETQ NEGFLG (NOT NEGFLG)) (SETQ TEM1 (CLISPIFY2B FORM)) (* reason we dont want to call CLISPIFY2 is in some cses, the NEGFLG will be  taken care of below, e.g. (NOT (ILESSP X Y)) goes to  (X GEQ Y)%. in this case, NEGFLG is reset  (in CLISP3)%, and CLISPIFY2 rebinds NEGFLG, so must call CLISPIFY2b instead) (RETURN (COND ((NULL NEGFLG) TEM1) ([AND CLISPFLG (GETPROP 'NOT 'CLISPINFIX) (SETQ TEM2 (GETPROP '~ 'CLISPTYPE] (CLISP3 '~ (LIST '~ TEM1) TEM2 T)) (T (LIST 'NOT TEM1]) (CLISPIFYMATCHUP [LAMBDA (PAT $LST $VARS ALST) (* wt%: 13-FEB-76 20 29) (* like clispmatchup except also recurses down into lists, and distinguishes  matches between elements and tails. clispmatchup doesnt have to do this) (PROG (TEM) LP (COND ((NLISTP $LST) (RETURN NIL)) [(FMEMB (CAR PAT) $VARS) (COND [(NOT (SETQ TEM (FASSOC (CAR PAT) ALST))) (SETQ ALST (NCONC1 ALST (CONS (CAR PAT) (CAR $LST] ((NOT (EQUAL (CDR TEM) (CAR $LST))) (* e.g. if (X IS POSITIVE) is  defined as (AND (NUMBERP X)  (IGREATERP X 0)) then  (AND (NUMBERP Y) (IGREATERP Z 0))  cant translate to (Y IS POSITIVE)) (RETURN NIL] ((EQ (CAR PAT) (CAR $LST))) [(AND (LISTP (CAR PAT)) (LISTP (CAR $LST))) (COND ((NULL (SETQ ALST (CLISPIFYMATCHUP (CAR PAT) (CAR $LST) $VARS ALST))) (RETURN NIL] ((EQ (CAR (GETPROP (CAR PAT) 'CLISPCLASS)) 'ISWORD) (SETQ PAT (CDR PAT)) (GO LP)) ((FMEMB (CAR PAT) CLISPISNOISEWORDS) (* e.g. A, AN, THE etc.) (SETQ PAT (CDR PAT)) (GO LP)) [(EQ (CAR PAT) (GETPROP (CAR $LST) 'CLISPISPROP] (T (RETURN NIL))) (COND ((SETQ PAT (CDR PAT)) (SETQ $LST (CDR $LST)) (GO LP)) ((NULL (CDR $LST)) (RETURN (OR ALST T))) (T (RETURN NIL]) (CLREMPARS [LAMBDA (X) (AND CLREMPARSFLG (LISTP X) (CDR X) (NULL (CDDDR X)) (ATOM (CAR X)) (ATOM (CADR X)) (ATOM (CADDR X)) (FGETD (CAR X)) (NULL (STRPOSL CLISPCHARRAY (CAR X]) (CLISPIFYCROPS0 [LAMBDA (CROPSLST) (* wt%: 3-AUG-77 3 1) (CLISP4 FORM) (* Handles things like  (CAR X_Y) and (LAST X_Y) by first  dwimifying,, when necessary.) (CLISPIFYCROPS (CADR FORM) CROPSLST (CAR FORM]) (CLISPIFYCROPS [LAMBDA (X CROPSLST CROPFN Y) (* lmm "16-Aug-84 14:17") (* X was originally of the form (car/cdr/...  X)%. Y is given on calls from CLISPIFYRPLAC.  In this case, Y is either NCONC, NCONC1, etc.  or CAR or CDR (correspnding to RPLACA or RPLACD)%.  Y tells CLISPIFYCROPS not to do a CLISP3A, and is also added to the end of the  CROP operatrs.) (PROG (TEM1 TEM2 PARENT SUBPARENT (PARENT0 PARENT)) [COND ([AND (SETQ TEM1 (OR (CAR CROPSLST) Y)) (COND [(LITATOM TEM1) (OR (FMEMB TEM1 CLISPCHARS) (AND (FMEMB CROPFN '(fetch replace)) (STRPOS "." TEM1] (T (AND (FMEMB CROPFN '(fetch replace)) (SOME TEM1 (FUNCTION (LAMBDA (TEM1) (STRPOS "." TEM1] (RETEVAL 'CLISPIFY2B 'FORM)) ([AND (NULL Y) (OR (NULL CLISPFLG) (NULL CL%:FLG) (NULL (SETQ TEM1 (GETPROP '%: 'CLISPTYPE] (* CLISPIFYRPLAC makes this check  before calling CLISPIFYCROPS.) (RETURN (CLISPIFY2C FORM] (PROG (OPR0 CLTYP0) [COND (CL%:FLG (SETQQ OPR0 %:) (SETQ CLTYP0 (GETPROP '%: 'CLISPTYPE] (* This means that if %: is encountered in the course of clipifying x,  clisifycrops will just return the list of %:1's and |::1's.|  Thus CADR of CDDR will clisify to %:4, not |::3:1.|) (SETQ TEM1 (CLISPIFY2 X))) (COND ((NULL SEG) (* Makes rest of program simpler  since TEM1 now always corresponds to  a segment.) (SETQ TEM1 (LIST TEM1))) ((OR (NULL CL%:FLG) (NEQ (CADR TEM1) CAR/CDRSTRING)) (* The NEQ says TEM1 is a sequence of operators and operands other than a CAR  or CDR perator, E.g. (CADR (SETQ X Y))) [COND ((CDR (SETQ TEM1 (CLISP3A TEM1))) (SETQ TEM1 (LIST TEM1)) (* This insures that the clispified form will be parenthesized.  This is necessar unless it reduces to a single atom, i.e.  CLISP3A returns a list of one element, since otherwise, the operator might be  broadscope, e.g. (CADR (AND X Y))) ] (GO OUT))) (COND ([OR (NULL CL%:FLG) (COND [(LISTP (CAR TEM1)) (COND [(EQ CL%:FLG T) (OR (CDDAR TEM1) (LISTP (CADAR TEM1] ((EQ CL%:FLG 'ALL) (* Says go back to %: notation  regardless of length of expression.) (SOME (CAR TEM1) (FUNCTION LISTP))) ((LISTP CL%:FLG) (NULL (APPLY* CL%:FLG (CAR TEM1] (T (CLISPNOEVAL (CAR TEM1] (* E.G. The first operand is a list,  therefore don't use %: notation.) (GO OUT))) (COND [(EQ OPR0 '%:) (* Leaves it as A's and D's for higher operator, which is also a %:, to  process. The reason for doing this is that  (CAR (CDDR X)) can therefore become %:3 not |::2:1.|) (SETQ SEG T) [COND ((NEQ (CADR TEM1) CAR/CDRSTRING) (* Special STRING used to mark list to inidicate that what follows is a list of  A's and D's for CLISPIFYCROPS1. Note that the marker may already be in there  from a lower call to CLISPIFYCROPS) (SETQ CROPSLST (CONS CAR/CDRSTRING CROPSLST] (RETURN (NCONC TEM1 (APPEND CROPSLST] ((EQ (CADR TEM1) CAR/CDRSTRING) (FRPLACD TEM1 (CDDR TEM1)) (* Reeove marker) (SETQ TEM2 TEM1)) ((NULL (CDR TEM1)) (* Of form (atom)%, e.g. CLISPIFYCROPS was called with X an atom, as in  CLISPIFYING (CAR X) (Remember that we hae listed the result of CLISPIFYING so  that all cses can be treated as segments)) (SETQ TEM2 TEM1)) (T (SHOULDNT))) (FRPLACD TEM2 (CLISPIFYCROPS1 (NCONC (CDR TEM2) CROPSLST) Y CROPFN)) (SETQ SEG T) [RETURN (COND ((CLISP3B '%: (GETPROP '%: 'CLISPTYPE)) (SETQ SEG NIL) (SETQ PARENT PARENT0) (CLISP3A TEM1)) ((OR Y OPR0) TEM1) (T (SETQ PARENT PARENT0) (CLISP3A TEM1] OUT (* dont use %: notation) (SETQ SEG NIL) (RETURN (COND ((NULL Y) (* TEM1 is the CLISPIFIED X, as a segment, so CONS the CROPFN back on it.) (SELECTQ CROPFN (fetch (CONS 'fetch (CONS (CAR CROPSLST) (CONS 'of TEM1)))) (match (CONS CROPFN (APPEND TEM1 (CONS 'with CROPSLST)))) (CONS CROPFN TEM1))) ((NULL CROPFN) TEM1) (T (LIST (CONS CROPFN TEM1]) (CLISPIFYCROPS1 [LAMBDA ($LST Y CROPFN) (* wt%: 27-JUN-77 23 41) (* takes a list consisting of %:1 (for car) |::1|  (for cdr)%, numbers (for nth)%, other litatoms  (from record operations)%, and lists (from pattern matches or records) and  produces the appropriate list contaiing just %:'s and numbers suitable for  packing.) (PROG (X N TAILSTATE TEM) LP (COND ($LST (SETQ TEM (CAR $LST))) (Y (SETQ TEM Y) (SETQ Y NIL)) (T (SETQ TEM NIL) (GO OUT))) LP1 [SELECTQ TEM (%:1 (* %:1 used instead of CAR, or A, because want to choose a name that is  unlikely to appear as a record field.) (SETQ X (CONS (COND ((NULL TAILSTATE) 1) ((MINUSP N) N) (T (ADD1 N))) (CONS '%: X))) (SETQ TAILSTATE NIL)) (|::1| (COND ((NULL TAILSTATE) (SETQ TAILSTATE T) (SETQ N 1)) ((NEQ N -1) (SETQ N (ADD1 N))) (T [SETQ X (CONS -1 (CONS '%: (CONS '%: X] (SETQ N 1)))) (COND [(NUMBERP TEM) (COND ((NULL TAILSTATE) (SETQ TAILSTATE T) (SETQ N TEM)) ((IGREATERP TEM 0) (SETQ N (IPLUS TEM N))) (T (* e.g. (LAST (CDR x))) [SETQ X (CONS N (CONS '%: (CONS '%: X] (SETQ N TEM] (T [AND TAILSTATE (SETQ X (CONS N (CONS '%: (CONS '%: X] (SETQ TAILSTATE NIL) (COND [(NLISTP TEM) (* ACCESS function, e.g.  X%:FOO.) (SETQ X (CONS TEM (CONS '%: X] [(EQ CROPFN 'match) (SETQ X (CONS TEM (CONS '%: X] [(CDR TEM) (* access path, e.g.  (FETCH (A B) OF C)) (SETQ X (CONS [PACK (CONS (CAR TEM) (MAPCONC (CDR TEM) (FUNCTION (LAMBDA (X) (LIST '%. X] (CONS '%: X] (T (* (FETCH (FOO) OF FIE) same as  (FETCH FOO OF FIE)) (SETQ X (CONS (CAR TEM) (CONS '%: X] (SETQ $LST (CDR $LST)) (GO LP) OUT [AND TAILSTATE (SETQ X (CONS N (CONS '%: (CONS '%: X] (AND TEM (SETQ X (APPEND TEM X))) (* Adds the %: or |::| foo NCONC or  Nconc2) (RETURN (DREVERSE X]) (CLISPIFYRPLAC [LAMBDA (X TYP %:FLG) (* wt%: 3-AUG-77 3 1) (PROG (TEM CROPS (CLTYP00 CLTYP0) (OPR0 '_) (CLTYP0 (GETPROP '_ 'CLISPTYPE)) LFT RGHT TYP0 (PARENT0 PARENT) PARENT SUBPARENT) [COND ([OR (NULL CLTYP0) (NULL CLISPFLG) (NULL CL%:FLG) (NULL (GETPROP '%: 'CLISPTYPE] (* _ transformation disabled) (RETURN (CLISPIFY2C X] (CLISP4 X) (* To handle cases like (RPLACA X_Y T)%, which if not first dwiified, would go  to X_Y%:1_T.) (COND ((EQ TYP 'replace) (SETQ LFT (CADDDR X)) (SETQ RGHT (CDR (CDDDDR X))) (SETQ TYP0 (CADR X))) ((NEQ (CAR X) (CLISPIFYLOOKUP (CAR X) (CADR X) (CADDR X))) (* E.g. RPLACA-RPLACD being used in  this function and this is an  FRPLACA.) (RETURN (CLISPIFY2C X))) (T (SETQ LFT (CADR X)) [SETQ RGHT (NTH (CDR X) (OR (GETPROP (CAR X) 'NARGS) (AND (NOT (SUBRP (CAR X))) (NARGS (CAR X))) (PUTPROP (CAR X) 'NARGS (LENGTH (SMARTARGLIST (CAR X] (* The problem is finding which of the arguments in thise xpression belong to  the accessfunction and which to the setfn, e.g.  Can't just default to all but last because last might not be supplied, e.g.  (RPLACA X) must clispify to X%:1_NIL, not X%:1_X.  The number of arguments is obtained either from the property NARGS, of from the  function NARGS, (if the function in question is not a SUBR//) or else an eror  is gnerated) (SETQ TYP0 TYP))) [COND ((NULL %:FLG) (* Doesnt involve %:'s, e.g. from a SETFN.  For example, if the original form were (SETA X Y Z)%, TYP would be ELT, and  CLISPIFY2A would be called on (ELT X Y)) [SETQ TEM (CLISPIFY2A (CONS TYP (LDIFF (CDR X) RGHT] (GO OUT)) ([AND (LISTP LFT) (COND ((SETQ CROPS (GETPROP (CAR LFT) 'CROPS)) (SETQ CROPS (SUBPAIR '(A D) '(%:1 |::1|) CROPS] (* E.g. (RPLACA (CDR X) --) becomes  X%:2_--. instead of |X::1:1_| --) (SETQ TEM (CLISPIFYCROPS (CADR LFT) CROPS (CAR LFT) TYP0))) (T (SETQ TEM (CLISPIFYCROPS LFT NIL NIL TYP0] [COND ((NULL (CDR TEM)) (* The first argument did not clispify to something containing %:'s, so we will  not use the _ notation) (SETQ SEG NIL) (RETURN (COND [(EQ TYP 'replace) (CONS TYP (CONS TYP0 (CONS 'of (NCONC TEM (CONS 'with (CLISPIFY1 RGHT] (T (CONS (CAR X) (NCONC TEM (CLISPIFY1 RGHT] OUT (SETQ SEG (NULL CLTYP00)) (SETQ PARENT PARENT0) (RETURN (CLISP3A (NCONC TEM (COND ((CAR RGHT) (CONS '_ ([LAMBDA (LST TAIL) (* LST is rbound to T to indicate to CLISP3 that there are operands to the left  of this expression (namely TEM and _)%.  Otherwise things like (RPLACD X (OR (FOO Y) Y)) would go to |X::1_|  (FOO Y) OR Y where actually the or should be parentheseized.  TAIL is rebound to NIL so that CLISP3 will know there isnt anything on the  right..) (CLISPIFY2A (CAR RGHT] T))) (T (LIST '_ NIL]) (CLISPIFYMAPS [LAMBDA (IN-ON OPR) (* lmm "12-JUN-81 07:13") (PROG (VAR (FN1 (CADDR FORM)) (FN2 (CADDDR FORM)) TEM) (COND ([OR (NLISTP FN1) (NEQ (CAR FN1) 'FUNCTION) (AND (LISTP (SETQ FN1 (CADR FN1))) (CDADR FN1)) [AND FN2 (OR (NLISTP FN2) (NEQ (CAR FN2) 'FUNCTION) (AND (LISTP (SETQ FN2 (CADR FN2))) (CDADR FN2] (NEQ (CAR FORM) (CLISPIFYLOOKUP (CAR FORM) (CADR FORM] (* E.G. (MAPCAR X Y)) (RETURN NIL))) [SETQ VAR (COND ((LISTP FN1) (CAADR FN1)) ((EQ (CADR FORM) 'X) 'Y) (T 'X] (COND ([AND (EQ OPR 'subset) (OR (CDDDR (LISTP FN1)) (EDITFINDP FN1 (LIST 'SETQ VAR '--] (RETURN NIL))) (RETURN (NCONC (AND VAR (LIST (COND (LCASEFLG 'for) (T 'FOR)) VAR)) (LIST IN-ON) (COND ((AND [NULL (CDR (SETQ TEM (CLISPIFY2A (CADR FORM] (CLREMPARS (CAR TEM))) (APPEND (CAR TEM))) (T TEM)) (CLMAPS2 FN2 (COND (LCASEFLG 'by) (T 'BY)) VAR) (CLMAPS2 FN1 OPR VAR]) (CLMAPS1 [LAMBDA (FN) (* wt%: 13-FEB-76 19 40) (COND ((NEQ (CAR FN) 'F/L) (CADR FN)) (T (CONS 'LAMBDA (COND ((AND (CDDR FN) (NOT (FGETD (CAADR FN))) (EVERY (CADR FN) (FUNCTION ATOM))) (CDR FN)) (T (CONS (LIST 'X) (CDR FN]) (CLMAPS2 [LAMBDA (DEF WORD VAR) (* lmm "12-JUN-81 07:17") (AND DEF (PROG (X Y TEM OPR0 CLTYP0) [COND ((EQ WORD 'subset) [SETQ WORD (COND (LCASEFLG 'when) (T 'WHEN] (SETQ Y (LIST (COND (LCASEFLG 'collect) (T 'COLLECT)) VAR] (* The expression constructed by clmaps2 is of the form WORD body when/unless  pred. body corresponds to the functional argument.  In the case of subset, it is when/unless body collect var.) [SETQ X (COND [(NLISTP DEF) (COND ((FNTYP DEF) (LIST DEF)) (T (* or otherwise wont dwimify back  right) (LIST (LIST DEF VAR] ([AND (FMEMB WORD '(DO JOIN do join)) (NULL (CDDDR DEF)) (COND ((AND (EQ (CAR (SETQ X (CADDR DEF))) 'COND) (NULL (CDDR X)))(* The form of the function is  (LAMBDA & (COND (--))) TEM is set to  the clause.) (SETQ TEM (CADR X))) ((EQ (CAR X) 'AND) (* If the NULL yields true, the form  is (AND & &)) (NULL (CDDR (SETQ TEM (CDR X] (SETQ Y TEM) (SETQ X (CDR Y)) (* X now corresonds to the body of  the iteraion.) [SETQ Y (CONS [COND [(EQ (CAAR Y) 'NOT) (SETQ Y (CADAR Y)) (COND (LCASEFLG 'unless) (T 'UNLESS] (T (SETQ Y (CAR Y)) (COND (LCASEFLG 'when) (T 'WHEN] (COND ((AND [NULL (CDR (SETQ TEM (CLISPIFY2A Y] (CLREMPARS (CAR TEM))) (CAR TEM)) (T TEM] [COND ((AND (OR (EQ WORD 'JOIN) (EQ WORD 'join)) [NULL (CDDAR (SETQ TEM (FLAST X] (EQ (CAAR TEM) 'LIST)) [SETQ WORD (COND (LCASEFLG 'collect) (T 'COLLECT] (SETQ X (NCONC (LDIFF X TEM) (CDAR TEM] (* E.g. JOIN (COND  (& -- (LIST &))) -> COLLECT --  WHEN &) (CLISPIFY1 X)) (T (CLISPIFY1 (CDDR DEF] [COND ((AND (LISTP DEF) (OR (CDADR DEF) (NEQ (CAADR DEF) VAR))) (* Entire LAMBDA expression must be included because the variable is not the  same as that in the FOR, i.e. not the same as the one in the first functional  argument.) (RETURN (CONS WORD (LIST (CONS (CONS (CAR DEF) (CONS (CADR DEF) X)) Y) VAR] (RETURN (CONS WORD (COND ((AND (NULL (CDR X)) (CLREMPARS (CAR X))) (APPEND (CAR X) Y)) (T (APPEND X Y]) (CLSTOPSCAN? [LAMBDA (CLTYPX CLTYP) (* STOPSCAN? is T if operator corresponding to CLTYPX would stop scan for  operator corresponding to CLTYP, i.e. if former is of lower or same precedence  as latter.) (AND CLTYPX CLTYP (NOT (ILESSP (COND ((ATOM CLTYP) CLTYP) (T (CDR CLTYP))) (COND ((ATOM CLTYPX) CLTYPX) (T (CAR CLTYPX]) (CLISPIFYLOOKUP [LAMBDA (WORD VAR1 VAR2 CLASS CLASSDEF) (* wt%: 31-MAY-76 22 34) (* In most cases, it is not necessary to do a full lookup.  This is q uick an dirty check inside of the block to avoid calling CLISPLOOKUP0  whenever there are no declarations.) (PROG (TEM) [OR CLASS (SETQ CLASS (GETPROP WORD 'CLISPCLASS] [OR CLASSDEF (SETQ CLASSDEF (GETPROP CLASS 'CLISPCLASSDEF] [SETQ TEM (COND ((AND CLASS DECLST) (* must do full lookup. Note that for CLISPLOOKUP, CLISPLOOKUP0 is only called  when there is a CLASSDEF. Here it is called when there is a CLASS property.  This is bcause what CLISPIFYLOOKUP is really asking is what would the infix  operator corresponding to WORD go to if DWIMIIED, e.g.  if WORD is FGTP, CLISPIFYLOOKUP is reaally asking what does GT go to.) (CLISPLOOKUP0 WORD VAR1 VAR2 DECLST NIL CLASS CLASSDEF)) (T (* The last GETPROP %, i.e. for CLASS, is so we dont have to implement global  declaraions by puttig a LISPFN property on each member of the class.) (OR (GETPROP WORD 'LISPFN) (GETPROP CLASS 'LISPFN) WORD] [COND ((AND (EQ (CAR CLASSDEF) 'ARITH) (EQ TEM (CADR CLASSDEF)) (OR (FLOATP VAR1) (FLOATP VAR2))) (SETQ TEM (CADDR CLASSDEF] (RETURN TEM]) (LOWERCASE [LAMBDA (FLG) (* wt%: 13-FEB-76 19 40) (PROG1 LCASEFLG [PROG (FN TEM) (AND (NULL CHCONLST) (SETQ CHCONLST 'NIL)) (* Because LOWERCASE is often done  in initialization, i.e.  before CHCONLST is set.) [SETQ FN (COND (FLG 'L-CASE) (T 'U-CASE] (RPAQ LCASEFLG FLG) [MAPC '(MAPC MAP MAPCAR MAPLIST MAPCONC MAPCON) (FUNCTION (LAMBDA (X) (/PUT X 'CLMAPS (CONS [APPLY* FN (CAR (SETQ TEM (GETPROP X 'CLMAPS] (APPLY* FN (CDR TEM] (/PUT 'OR 'CLISPINFIX (APPLY* FN 'OR)) (/PUT 'AND 'CLISPINFIX (APPLY* FN 'AND])]) (SHRIEKIFY [LAMBDA (LOOKAT) (* wt%: "23-JUL-78 23:31") (PROG (RESULTP CARTEST (OPR0 '<) (CLTYP0 (GETPROP '< 'CLISPTYPE)) PARENT SUBPARENT) (SELECTQ (SETQ CARTEST (CAR LOOKAT)) ((NCONC /NCONC) (COND ((NEQ CARTEST (CLISPIFYLOOKUP 'NCONC NIL)) (RETURN NIL)))) ((NCONC1 /NCONC1) (COND ((NEQ CARTEST (CLISPIFYLOOKUP 'NCONC1 NIL)) (RETURN NIL)))) NIL) (CLISP4 FORM) (SETQ RESULTP (LIST '<)) (SHRKFY LOOKAT 'STARTING T) [SETQ RESULTP (COND ((CDR RESULTP) (NCONC1 RESULTP '>] (RETURN (COND ([AND (LITATOM (CADR RESULTP)) (FNTYP (CADR RESULTP)) (NOT (BOUNDP (CADR RESULTP] NIL) ([OR (AND (NULL (GETPROP '! 'CLISPWORD)) (EDITFINDP RESULTP '!)) (AND (NULL (GETPROP '!! 'CLISPWORD)) (EDITFINDP RESULTP '!!] (* e.g., rich fikes likes to disable ! without disabling <.  this is not the most efficient way to make the check, but there are somany  places in shrkfy where !'s are put in, is easier to justcheck after wards.) NIL) (T RESULTP]) (SHRKFY [LAMBDA (LOOKAT WORKFLAG STAGEFLAG) (* wt%: "23-JUL-78 23:30") (* SHRKFY is a translator from LISP expressions involving CONS, LIST, APPEND,  NCONC, NCONC1, /NCONC, and /NCONC1 to CLISP expressions using !, !!, and <;  thus it is the inverse translator to SHRIEKER.  Although this is a large program, its operation is fairly simple.  Several prog labels, from A1 to A5, have been introduced to aid this  explication. Control flows straight through SHRKFY, from top to bottom, with no  awkward detours or loops. In essence, SHRKFY is a stack of three large  selectq's, each of which does some computation necessary for the next.) (PROG ((CARSAFEFLAG T) CARLOOKAT CDRLOOKAT CDARLOOKAT CAARLOOKAT OPFLG CARFLAG CDDARLOOKAT RESULTQ RESULTR OP2FLG OP3FLG FIRSTARGFLG APPSINGFLG) (SETQ CARLOOKAT (CAR LOOKAT)) (COND ((LISTP CARLOOKAT) (SETQ CAARLOOKAT (CAR CARLOOKAT)) (SETQ CDARLOOKAT (CDR CARLOOKAT)) (SETQ CDDARLOOKAT (CDR CDARLOOKAT)) (SETQQ CARFLAG ITSALIST)) (T (SETQQ CARFLAG ELEMENTAL))) (* These canonical prog varnames remain constant throughout the program.  I.e. CAARLOOKAT is always (CAAR LOOKAT)%, etc.) (SETQ CDRLOOKAT (CDR LOOKAT)) A1 (* SHRKFY works by emulating, or mimicing, the actions of APPEND, CONS, LIST,  NCONC, NCONC1, etc., on their arguments with respect to the CLISP operators !,  !!, and <. Whenever SHRKFY is called, WORKFLAG is the name of the function  being emulated and STAGEFLAG is the "stage"  (either T or NIL) that the emulation has reached.  The first time that SHRKFY is called to mimic a function, STAGEFLAG will be T,  which is SHRKFY's signal that this is indeed the first time it has been called,  and that LOOKAT is CDR of the original form.  STAGEFLAG will then be setq'd to NIL. Depending on the value of STAGEFLAG and  CDRLOOKAT (which tells SHRKFY whether or not there or more arguments besides  CARLOOKAT)%, OPFLG will be setq'd to %'!, %'!!, or %'LISTIT, and control will  then flow to A2.) (SELECTQ WORKFLAG ((NCONC /NCONC) (COND (STAGEFLAG (SETQQ OPFLG !!)) (CDRLOOKAT (SETQQ OPFLG !!)) (T (SETQQ OPFLG !))) (COND (STAGEFLAG (* FIRSTARGFLG is setq'd to T to save the fact that CARLOOKAT is the first  argument of the form.) (SETQ STAGEFLAG NIL) (SETQ FIRSTARGFLG T)))) (CONS (COND (STAGEFLAG (SETQQ OPFLG LISTIT) (SETQ STAGEFLAG NIL) (SETQ FIRSTARGFLG T)) (CDRLOOKAT (SETQQ OPFLG LISTIT)) (T (SETQQ OPFLG !)))) (APPEND (COND (STAGEFLAG (SETQ STAGEFLAG NIL) (SETQ FIRSTARGFLG T))) (SETQQ OPFLG !)) (LIST (SETQQ OPFLG LISTIT)) ((NCONC1 /NCONC1) (COND (STAGEFLAG (SETQQ OPFLG !!)) (T (SETQQ OPFLG LISTIT))) (COND (STAGEFLAG (SETQ STAGEFLAG NIL) (SETQ FIRSTARGFLG T)))) (STARTING (* The very first time that SHRKFY is called  (by SHRIEKIFY)%, WORKFLAG is eq to %'STARTING.  This branch takes care of recognizing whether the form LOOKAT has at least one  argument. If it does, then SHRKFY is called recursively on CDRLOOKAT, with  WORKFLAG = CARLOOKAT. Otherwise SHRKFY returns to SHRIEKIFY.) (COND (CDRLOOKAT (* the form has at least one  argument.) (RETURN (SHRKFY CDRLOOKAT CARLOOKAT STAGEFLAG))) (T (SELECTQ CARLOOKAT ((LIST APPEND NCONC /NCONC) (* (APPEND)%, (LIST)%, (NCONC)%, and (/NCONC) all evaluate to NIL.  RESULTP will be (<) when we return to SHRIEKIFY, which will return NIL.) (RETURN NIL)) ((CONS NCONC1 /NCONC1) (* (CONS)%, (LIST)%, (NCONC1)%, (/NCONC1) all evaluate to  (NIL)%, so this branch adds NIL to RESULTP and returns to SHRIEKIFY.) (RETURN (NCONC1 RESULTP NIL))) NIL)))) NIL) A2 [COND (CDRLOOKAT (* RESULTR holds SHRKFY's translation of the arguments after CARLOOKAT.  Nothing will be done with it until the final COND at the top level of the  SHRKFY prog, which takes care of adding RESULTR onto RESULTP.  The next three selectq's at A3, A4, and A5 are devoted to adding the proper  translation of CARLOOKAT to RESULTP.) (SETQ RESULTR (SHRKFY2 CDRLOOKAT WORKFLAG STAGEFLAG)) (SETQ RESULTR (CDR RESULTR] A3 (SELECTQ OPFLG ((!! !) (SELECTQ CARFLAG (ELEMENTAL [COND (CARLOOKAT (* If CARLOOKAT is not nil and not a list then we just add it on to RESULTP,  preceded by the appropriate operator (%'! or %'!!)%.  The selectq with the call to DWIMIFY1A enables us to catch errors like  (APPEND A B CONS D E) and issue a message to the user that there is a  "(possible) parentheses error." SHRKFY, however, continues with its  computation.) (NCONC RESULTP (LIST OPFLG CARLOOKAT)) (SELECTQ CARLOOKAT ((APPEND CONS LIST NCONC NCONC1 /NCONC /NCONC1 QUOTE) (DWIMIFY1A FORM LOOKAT CLISPIFYFN)) NIL)) (T (* makes sure that (APPEND NIL A)%, (NCONC NIL A)%, etc.  go to , , not .  Otherwise, ! NIL and !! NIL are left out of RESULTP.  Thus, (APPEND A B NIL C D) goes to .  This conditional could be refined a little to let cases like  (NCONC1 NIL A) go to < A >, rather than .) (COND ((AND FIRSTARGFLG (NULL (CDR CDRLOOKAT)) CDRLOOKAT) (NCONC RESULTP (LIST OPFLG NIL]) (ITSALIST (* CARLOOKAT is a list  (form)%.) [COND [CDARLOOKAT (* If CDARLOOKAT is non-nil then we know there's at least one argument in the  form, so we do a selectq on CAARLOOKAT, the first element of the form, which is  expected to be a function name. This selectq finds out which function name, and  saves this information in OP2FLG. (In certain cases, CARSAFEFLAG will be setq'd  to NIL.) Without exception, control then flows to the major selectq on OP2FLG,  which has the prog label A4.) (SELECTQ CAARLOOKAT ((LIST CONS) (SETQ OP2FLG CAARLOOKAT)) (APPEND (COND ((NULL CDDARLOOKAT) (* If CDDARLOOKAT is nil, then we know that the form CARLOOKAT, which has  APPEND as its function name, has exactly one argument.  So APPSINGFLG is setq'd to T, to save the fact that CARLOOKAT is an APPEND  singleton.) (SETQ APPSINGFLG T))) (SETQQ OP2FLG APPEND)) ((NCONC NCONC1 /NCONC /NCONC1) (SETQ OP2FLG CAARLOOKAT) (* CARSAFEFLAG is setq'd to NIL to indicate that CARLOOKAT may be  (in this case, is) a destructive operation.) (SETQ CARSAFEFLAG NIL)) (QUOTE (* SHRKFY understands that if CARLOOKAT is a QUOTE form then it is not a  destructive operation. So CARSAFEFLAG is not affected, but OP2FLG is setq'd to  OPFLG, which will result in calling CLISPIFY2A on CARLOOKAT.) (SETQ OP2FLG OPFLG)) (PROGN (* CARLOOKAT is a form, and its first element is a function name that SHRKFY  doesn't recognize. So CARSAFEFLAG is setq'd to NIL, to indicate that there may  be a destructive operation going on, and OP2FLG is setq'd to OPFLG  (i.e. either %'! or %'!!)%, which will result in calling CLISPIFY2A on  CARLOOKAT, when control flows to the selectq following the prog label A4.) (SETQ OP2FLG OPFLG) (SETQ CARSAFEFLAG NIL] (T (* this branch handles ! (APPEND)%, !! (CONS)%, !  (CONS)%, !! (NCONC)%, etc. I.e. CARLOOKAT is a form with no arguments.  If its function name is recognized by SHRKFY, then the appropriate code will be  added automatically to RESULTP. Although control will flow to the SELECTQ  following A4, nothing will happen there, because OP2FLG is NIL.  Similarly for the SELECTQ on OP3FLG, following A5.  Control will wind up at the final COND at the top level of the SHRKFY prog,  which takes care of adding RESULTR to RESULTP.  On the other hand, if SHRKFY does not recognize the function name in CARLOOKAT,  OP2FLG will be setq'd to OPFLG, which will cause CLISPIFY2A to be called on  CARLOOKAT, when control flows to the selectq following A4.) (SELECTQ CAARLOOKAT ((APPEND NCONC LIST QUOTE /NCONC) (* (APPEND) (NCONC) (LIST) (QUOTE) and (/NCONC) all evaluate to NIL.  Thus ! (APPEND) is the same as ! NIL, and can be left out of RESULTP, unless  doing so would cause the next element in LOOKAT to be copied when it shouldn't  be. E.g. (APPEND (APPEND) A) should go to  ()%, not ()%. The same conditional is used to avoid this  special case as in the branch above when CARFLAG = %'ELEMENTAL.  This conditional could be refined a little to let cases like  (NCONC1 (APPEND) A) go to (< A >)%, rather than to  ()%, as they do currently.) [COND ((AND FIRSTARGFLG (NULL (CDR CDRLOOKAT)) CDRLOOKAT) (NCONC RESULTP (LIST OPFLG NIL]) ((CONS NCONC1 /NCONC1) (* (CONS) (NCONC1) and (/NCONC1) all evaluate to  (NIL)%, so this branch replaces ! (CONS) by ! , etc.  The brackets are left in for the sake of simplicity, because some cases require  that they stay in. Thus if (NCONC A (CONS) B C) went to ,  then it would dwimify back to (NCONC A (CONS NIL  (NCONC B C)))%, which is not equivalent.  However, brackets can probably be left out whenever OPFLG = %'! and WORKFLAG =  %'APPEND or %'CONS, which is a refinement that merits investigation.  A small COND here would thus allow SHRKFY to simplify  (CONS A (APPEND)) to (LIST A NIL) and (APPEND  (APPEND) A) to (CONS NIL A)%.) (NCONC RESULTP (LIST OPFLG '< NIL '>))) (PROGN (* SHRKFY doesn't recognize the function name in CARLOOKAT, so this form will  be given to CLISPIFY2A when control flows to the selectq following A4, and  CARSAFEFLAG will be setq'd to NIL, to indicate that something destructive could  be happening.) (SETQ OP2FLG OPFLG) (SETQ CARSAFEFLAG NIL]) NIL)) (LISTIT (* This branch is analogous to the one above  (where OPFLG = %'! or %'!!)%, except that here CARLOOKAT is simply being  listed, or added on.) (SELECTQ CARFLAG (ELEMENTAL (* Note that there is an additional call to DWIMIFY1A here, which lets us catch  errors like (CONS NCONC D E) and issue a message to the user that there is a %'  (possible) parentheses error.) (NCONC1 RESULTP CARLOOKAT) (SELECTQ CARLOOKAT ((APPEND CONS LIST NCONC NCONC1 /NCONC /NCONC1 QUOTE) (DWIMIFY1A FORM LOOKAT CLISPIFYFN)) NIL)) (ITSALIST [COND [CDARLOOKAT (SELECTQ CAARLOOKAT ((CONS LIST APPEND) (SETQ OP2FLG CAARLOOKAT)) ((NCONC NCONC1 /NCONC /NCONC1) (SETQ CARSAFEFLAG NIL) (SETQ OP2FLG CAARLOOKAT)) (QUOTE (SETQQ OP2FLG ADDITON)) (PROGN (SETQ CARSAFEFLAG NIL) (SETQQ OP2FLG ADDITON] (T (SELECTQ CAARLOOKAT ((APPEND NCONC LIST QUOTE /NCONC) (NCONC1 RESULTP NIL)) ((CONS NCONC1 /NCONC1) (NCONC RESULTP (LIST '< NIL '>))) (PROGN (SETQQ OP2FLG ADDITON) (SETQ CARSAFEFLAG NIL]) NIL)) NIL) A4 (SELECTQ OP2FLG ((!! !) (NCONC (NCONC1 RESULTP OP2FLG) (CLISPIFY2A CARLOOKAT))) (ADDITON (NCONC RESULTP (CLISPIFY2A CARLOOKAT))) ((APPEND CONS LIST NCONC NCONC1 /NCONC /NCONC1) (* CARLOOKAT is a form of at least one argument, and its function name is one  of the special functions recognized by SHRKFY.  This function name is the value of OP2FLG.  Most of the general optimizations described in the memo on SHRKFY take place in  this selectq.) (SELECTQ OP2FLG ((NCONC /NCONC) (* If OP2FLG = %'NCONC, %'/NCONC, %'NCONC1, or %'/NCONC1, and is not eq to the  value of the corresponding CLISPIFYLOOKUP, then control will be sent to A5,  where CARLOOKAT will be given to CLISPIFY2C.) (COND ((NEQ OP2FLG (CLISPIFYLOOKUP 'NCONC NIL)) (SETQQ OP3FLG CLISPIFY2CIT) (GO A5)))) ((NCONC1 /NCONC1) (COND ((NEQ OP2FLG (CLISPIFYLOOKUP 'NCONC1 NIL)) (SETQQ OP3FLG CLISPIFY2CIT) (GO A5)))) NIL) (* Within the prog below, FORM is rebound to CARLOOKAT, so that Warren's  scanner will be appropriately triggered.  SHRKFY2 is called, rather than SHRKFY, so that the lower level SHRKFY will be  able to work with its own, fresh, RESULTP.  The RESULTP that is returned by SHRKFY2 will be made the value of the current  SHRKFY's RESULTQ. This RESULTQ will be a list of CLISP expressions, including !  and !!, without enclosing angle brackets.  The question of whether to add the angle brackets or not is resolved by the  body of this branch, and the nature of this decision is stored in OP3FLG.  Control then flows to the selectq following A5, where RESULTQ, with appropriate  surrounding brackets (and preceding operators ! or !!)%, will be added to  RESULTP. We may think of RESULTQ as always, implicitly, having angle brackets  around it, and thus the simple operation  (NCONC RESULTP RESULTQ) corresponds to "removing" the angle brackets.  This operation is denoted by (SETQQ OP3FLG OFFANGLES)%, while the operation of  leaving the brackets in and preceding them by %'!! or %'! is denoted by  (SETQQ OP3FLG OPANGLE)%.) (PROG ((FORM CARLOOKAT)) (SETQ RESULTQ (SHRKFY2 CDARLOOKAT OP2FLG T))) (SETQ RESULTQ (CDR RESULTQ)) (COND (RESULTQ (SELECTQ OPFLG ((!! !) (COND [CDRLOOKAT (COND ((AND CARSAFEFLAG (EQ WORKFLAG 'APPEND)) (* APPEND is the only non-destructive function which has OPFLG = %'! when  CDRLOOKAT is non-nil. By convention, brackets are never removed from RESULTQ  when OPFLG = %'!!, nor are they ever removed when RESULTQ is "unsafe"  (e.g. when RESULTQ contains %'!! at its top level) and CDRLOOKAT is non-nil;  CARSAFEFLAG is nil if RESULTQ is unsafe.  This accounts for the optimizations described in paragraphs %#1,2,3 of my memo  on SHRKFY.) (SETQQ OP3FLG OFFANGLES)) (T (SETQQ OP3FLG OPANGLE] (T (* CDRLOOKAT is nil, so CARLOOKAT is the last argument of the form we are  emulating. It may also be the first, which we can detect if FIRSTARGFLG is T,  in which case we are emulating a singleton.) (SELECTQ WORKFLAG (APPEND (SELECTQ OP2FLG ((CONS NCONC NCONC1 LIST /NCONC /NCONC1) (COND (FIRSTARGFLG (* Since CDRLOOKAT is nil and FIRSTARGFLG is T, LOOKAT is a singleton and we  are emulating an APPEND singleton. So brackets are not removed.) (SETQQ OP3FLG OPANGLE)) ((OR (EQ OP2FLG 'LIST) (EQ OP2FLG 'CONS)) (* Otherwise, if CARLOOKAT is a LIST or CONS form, brackets can be removed,  according to paragraph %#4 of the memo on SHRKFY optimizations.) (SETQQ OP3FLG OFFANGLES)) (T (* Otherwise brackets stay in.) (SETQQ OP3FLG OPANGLE)))) (APPEND (* This branch accounts for the optimzations described in paragraph %#5 of the  memo on SHRKFY.) (COND ((OR FIRSTARGFLG APPSINGFLG) (* If CARLOOKAT is an append singleton then brackets are not removed, because  it is the last argument of the APPEND form we are emulating.  Or if FIRSTARGFLG is T, then since CDRLOOKAT is nil, we must be inside an  append singleton, of which CARLOOKAT is the only argument, so brackets are not  removed.) (SETQQ OP3FLG OPANGLE)) (T (SETQQ OP3FLG OFFANGLES)))) NIL)) (CONS (* See paragraph %#6 of the memo on  SHRKFY.) (SELECTQ OP2FLG ((NCONC NCONC1 /NCONC /NCONC1) (SETQQ OP3FLG OPANGLE)) ((CONS LIST) (SETQQ OP3FLG OFFANGLES)) (APPEND (COND (APPSINGFLG (SETQQ OP3FLG OPANGLE)) (T (SETQQ OP3FLG OFFANGLES)))) NIL)) ((NCONC /NCONC) (* See paragraph %#7 of the memo on  SHRKFY.) (SELECTQ OP2FLG ((LIST APPEND CONS) (COND (FIRSTARGFLG (* We're emulating an NCONC  singleton.) (SETQQ OP3FLG OPANGLE)) (CDDARLOOKAT (* These cases all dwimify back  correctly.) (SETQQ OP3FLG OFFANGLES)) (T (SETQQ OP3FLG OPANGLE)))) ((NCONC NCONC1 /NCONC /NCONC1) (SETQQ OP3FLG OPANGLE)) NIL)) ((NCONC1 /NCONC1) (* There's no need to concern ourselves about bracket removal here.  Since CDRLOOKAT is NIL, and OPFLG = %'! or %'!!, and WORKFLAG = %'NCONC1 or  %'/NCONC1, OPFLG must eq %'!! (and FIRSTARGFLG must eq T, but we don't need to  check for it)%, because NCONC1 never setq's OPFLG to %'!.) (SETQQ OP3FLG OPANGLE)) NIL)))) (LISTIT (* Brackets can't be removed.) [COND ([AND (LITATOM (CAR RESULTQ)) (FNTYP (CAR RESULTQ)) (NOT (BOUNDP (CAR RESULTQ] (* something of the form ]) NIL)) (T (* RESULTQ has been pseudo-evaluated to NIL, so it disappears from or remains  in RESULTP according to the rules desccribed in paragraphs %#8 through %#13 of  the memo on SHRKFY.) (SELECTQ OPFLG ((!! !) (SELECTQ OP2FLG ((APPEND NCONC LIST /NCONC) [COND ((AND FIRSTARGFLG (NULL (CDR CDRLOOKAT)) CDRLOOKAT) (NCONC RESULTP (LIST OPFLG NIL]) ((CONS NCONC1 /NCONC1) (NCONC RESULTP (LIST OPFLG '< NIL '>))) NIL)) (LISTIT (SELECTQ OP2FLG ((APPEND NCONC LIST /NCONC) (NCONC1 RESULTP NIL)) ((CONS NCONC1 /NCONC1) (NCONC RESULTP (LIST '< NIL '>))) NIL)) NIL)))) NIL) A5 (* Here we add RESULTQ to RESULTP, according to the decision made in the  previous major selectq, at A4.) (SELECTQ OP3FLG (OFFANGLES (NCONC RESULTP RESULTQ)) (OPANGLE [COND [[AND (LITATOM (CAR RESULTQ)) (FNTYP (CAR RESULTQ)) (NOT (BOUNDP (CAR RESULTQ] (NCONC RESULTP (LIST OPFLG (CAR LOOKAT] (T (NCONC RESULTP (LIST OPFLG '<) RESULTQ (LIST '>]) (CLISPIFY2CIT (SELECTQ OPFLG ((! !!) (NCONC RESULTP (LIST OPFLG (CLISPIFY2C CARLOOKAT)))) (LISTIT (NCONC1 RESULTP (CLISPIFY2C CARLOOKAT))) NIL)) NIL) [COND (RESULTR (* RESULTR holds SHRKFY's translation of CDRLOOKAT, and of course does not have  "implicit angle brackets" around it, so we just add it on to RESULTP.) (NCONC RESULTP RESULTR)) ((AND FIRSTARGFLG (EQ WORKFLAG 'NCONC1)) (* In this branch, since RESULTR is nil, it has either been pseudo-evaluated to  nil or else we've been emulating an NCONC1 singleton.  This branch makes sure (NCONC1 A) goes to  ()%.) (NCONC1 RESULTP NIL)) ((AND (EQ WORKFLAG 'APPEND) CDRLOOKAT) (* This branch makes sure that CARLOOKAT is copied.  Since CDRLOOKAT is non nil, but RESULTR is nil, we know that RESULTR has been  psuedo-evaluated to nil. If (APPEND A B  (CONS) NIL (NCONC)) simply went to () and dwimified back to  (APPEND A B)%, B would no longer be copied.  So, for this case alone, we need to add a nil;  the same problem does not arise within a CONS, LIST, or NCONC form.  In fact, not doing anything in these cases allows us to optimize  (CONS A (APPEND)) to (LIST A)%, and (NCONC A B  (NCONC)) to (NCONC A B)%. On the other hand,  (LIST A B (NCONC)) naturally goes to () and back to  (LIST A B NIL)%.) (NCONC RESULTP (LIST '! NIL] (RETURN RESULTP]) (SHRKFY2 [LAMBDA (LOOKAT WORKFLAG STAGEFLAG) (PROG (RESULTP) (SETQ RESULTP (LIST 'TEMPATOM)) (SHRKFY LOOKAT WORKFLAG STAGEFLAG) (RETURN RESULTP]) (WHILEDOUNTIL [LAMBDA ($FORM) (* DD%: "24-FEB-83 18:19") (PROG (PL FX FX1 CONDX TGO TEM WHILE DO UNTIL) (* All syntatical patterns of the following format%: LABEL  (COND (p1 e1...e2 (GO LABEL)) clause1...clause2) will be converted to the  form%: LABEL (WHILE p1 DO e1...e2 (COND clause1...clause2))%.  In addition, all patterns%: LABEL e1...e2  (COND (p1 (GO LABEL)) clause1...clause2) will be converted to the form%: LABEL  (DO e1...e2 UNTIL (NOT p1)) (COND clause1...clause2)%.  This function is invoked by CLISPIFY2B during CLISPIFY processing of a PROG.) (SETQ FX $FORM) TOP (COND ((NULL FX) (RETURN $FORM)) ((NOT (ATOM (CAR FX))) (SETQ FX (CDR FX)) (GO TOP))) (* At this point a prog label has been detected and CADR of FX is a list.  A test will now be made to determine if is an appropriate COND expression) (SETQ PL (CAR FX)) (SETQ FX1 FX) (COND [(AND [LISTP (CAR (SETQ FX (CDR FX] (EQ (CAR (SETQ CONDX (CAR FX))) 'COND) (EQ [CAR (LISTP (CAR (SETQ TGO (LAST (CADR CONDX] 'GO) (EQ (CADAR TGO) PL) (NULL (EDITFINDP (CADR CONDX) 'RETURN T))) (SETQ DO (LDIFF (CDADR CONDX) TGO)) (* If the COND clause contains a  predicate only, the DO expresstion  will be omitted.) [SETQ WHILE (CONS 'WHILE (CONS (CAADR CONDX) (AND DO (CONS 'DO DO] (* If the COND expression contains only one clause, the COND expression,  constructed for the remaining clauses, is omitted.) (SETQ TEM (CONS WHILE (WHILEDO1 (CDDR CONDX] (T (GO TOP))) (RETURN (NCONC (LDIFF $FORM FX1) (NCONC (CONS PL TEM) (WHILEDOUNTIL (CDR FX]) (WHILEDO1 [LAMBDA (X) (COND ((NULL X) NIL) ((AND (NULL (CDR X)) (EQ (CAAR X) T)) (APPEND (CDAR X))) (T (LIST (CONS 'COND X]) (CLDISABLE [LAMBDA (OP) (* wt%: "14-NOV-78 01:44") (PROG (TEM FLG OP1 BRACKET) (SETQ OP1 (L-CASE OP)) (SETQ BRACKET (GETP OP 'CLISPBRACKET)) [COND ([AND (SETQ TEM (SELECTQ OP ((< ! >) (* I.S.OPR for JOIN uses <) 'join) (+ 'sum) NIL)) (SETQ TEM (GETPROP TEM 'I.S.OPR] (* purpose of this is to convert the indicated i.s.opr to a lisp form instead  of using infix notation before disabling the oprator, e.g.  for SUM, I.S.OPR is ($$VAL_$$VAL+BODY) want to convert this to use IPLUS now) (RESETVARS (NOFIXFNSLST0 NOFIXVARSLST0) (DWIMIFY0 (CAR TEM) NIL '(BODY $$VAL] [MAPC '(CLISPTYPE UNARYOP CLISPCLASS CLISPCLASSDEF CLISPNEG CLISPINFIX BROADSCOPE CLISPFORM I.S.OPR CLISPWORD CLMAPS SETFN CLISPBRACKET) (FUNCTION (LAMBDA (X) (* does not remove LISPFN property, because this will be needed for explicit  calls to CLISPLOOKUP from dwimify, e.g.  for translating iterative statements using FROM and UNTIL, need to look up +  and LT) (COND ((/REMPROP OP X) (SETQ FLG T))) (COND ((/REMPROP OP1 X) (SETQ FLG T] [MAPC '(I.S.OPRLST CLISPFORWORDSPLST CLISPINFIXSPLST) (FUNCTION (LAMBDA (X) (/SETATOMVAL X (REMOVE OP (GETATOMVAL X] [COND ((MEMB OP CLISPCHARS) (/SETATOMVAL 'CLISPCHARS (REMOVE OP CLISPCHARS)) (/SETATOMVAL 'CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (SETQ FLG T) (SELECTQ OP (- (CLDISABLE '+-)) (+- (CLDISABLE '-)) (! (CLDISABLE '!!)) NIL (COND (BRACKET (CLDISABLE (CAR BRACKET)) (CLDISABLE (CADR BRACKET)) (AND (SETQ TEM (LISTGET1 BRACKET 'SEPARATOR)) (CLDISABLE TEM] (RETURN (AND FLG OP]) ) (RPAQ? FUNNYATOMLST ) (RPAQ? CLREMPARSFLG ) (RPAQ? CL%:FLG T) (RPAQ? CLISPIFYPACKFLG ) (RPAQ? CLISPIFYENGLSHFLG ) (RPAQ? CLISPIFYUSERFN ) (RPAQQ CAR/CDRSTRING "CAR/21-") (ADDTOVAR EDITMACROS (CL NIL (BIND (IF (NULL (CDR L)) [(IF (MEMB (%## 1) LAMBDASPLST) ((MARK %#3) 3 UP) ((E (PROGN (SETQQ COM CL) (PRINT 'can't T T) (ERROR!] NIL) [IF (TAILP (SETQ %#1 (%##)) (%## !0 (E (SETQ %#2 L) T))) ((I %: (CLISPIFY %#1 %#2)) (LO 1)) ((COMS (CONS '%: (CLISPIFY %#1 %#2)) (AND (LISTP (%## 1)) 1] (IF %#3 ((\ %#3)) NIL)))) (ADDTOVAR EDITCOMSA CL) (PUTPROPS ADD1 CLISPFORM (IPLUS * 1)) (PUTPROPS SUB1 CLISPFORM (IPLUS * -1)) (PUTPROPS NEQ CLISPFORM (NOT (EQ . *))) (PUTPROPS CONS CLISPBRACKET <) (PUTPROPS LIST CLISPBRACKET <) (PUTPROPS APPEND CLISPBRACKET <) (PUTPROPS NCONC CLISPBRACKET <) (PUTPROPS NCONC1 CLISPBRACKET <) (PUTPROPS /NCONC CLISPBRACKET <) (PUTPROPS /NCONC1 CLISPBRACKET <) (PUTPROPS ~EQUAL CLISPTYPE NIL) (PUTPROPS ~MEMBER CLISPTYPE NIL) (PUTPROPS ~MEMB CLISPTYPE NIL) (PUTPROPS MAPC CLMAPS (in . do)) (PUTPROPS MAP CLMAPS (on . do)) (PUTPROPS MAPCAR CLMAPS (in . collect)) (PUTPROPS MAPLIST CLMAPS (on . collect)) (PUTPROPS MAPCONC CLMAPS (in . join)) (PUTPROPS MAPCON CLMAPS (on . join)) (PUTPROPS SUBSET CLMAPS (in . subset)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: CLISPIFYBLOCK CLISPIFYFNS CLISPIFY CLISPIFY1 CLISPIFY2 CLISPIFY2A CLISPIFY2B CLISPIFY2C CLISPIFY2D CLISP3 CLISP3A CLISP3B CLISPACKUP CLISP3C CLISP4 CLISPCOND CLISPCOND1 CLISPAND CLISPAND1 CLISPIFYNOT CLISPIFYMATCHUP CLREMPARS CLISPIFYCROPS0 CLISPIFYCROPS CLISPIFYCROPS1 CLISPIFYRPLAC CLISPIFYMAPS CLMAPS1 CLMAPS2 SHRIEKIFY SHRKFY SHRKFY2 CLISPIFYLOOKUP CLSTOPSCAN? WHILEDOUNTIL WHILEDO1 (ENTRIES CLISPIFYFNS CLISPIFY CLISPACKUP CLISPIFYMATCHUP CLISPIFY2A CLISP3A) (SPECVARS EXPR VARS DWIMIFYFLG DWIMIFYING DWIMIFY0CHANGE) (LOCALFREEVARS DECLST CLTYP0 OPR0 LST SEG TAIL FORM PARENT SUBPARENT NOVALFLG NEGFLG RESULTP SAFEFLAG VARS CLISPISTATE TYPE-IN? SIDES CLISPIFYFN) (GLOBALVARS CAR/CDRSTRING CL%:FLG CLISPARRAY CLISPCHARRAY CLISPCHARS CLISPFLG CLISPIFYENGLSHFLG CLISPIFYPACKFLG CLISPIFYSTATS CLISPIFYUSERFN CLISPISNOISEWORDS CLISPISVERBS CLISPTRANFLG CLREMPARSFLG COMMENTFLG DWIMFLG FILELST FUNNYATOMLST GLOBALVARS LCASEFLG) (RETFNS CLISPIFY2B) (NOLINKFNS CLISPIFYUSERFN)) (BLOCK%: NIL LOWERCASE (GLOBALVARS CHCONLST LCASEFLG)) (BLOCK%: NIL CLDISABLE (GLOBALVARS CLISPCHARS CLISPCHARRAY NOFIXFNSLST0 NOFIXVARSLST0)) (BLOCK%: NIL (GLOBALVARS CLISPISNOISEWORDS CLISPISVERBS CLISPISWORDSPLST)) ) (LOWERCASE T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD MATCHUP ((NIL . SUBJ) (NIL . OBJ))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA CLISPIFYFNS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CLISPIFY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3368 132460 (CLISPIFYFNS 3378 . 5192) (CLISPIFY 5194 . 8666) (CLISPIFY1 8668 . 13069) ( CLISPIFY2 13071 . 14503) (CLISPIFY2A 14505 . 15160) (CLISPIFY2B 15162 . 39982) (CLISPIFY2C 39984 . 40786) (CLISPIFY2D 40788 . 41775) (CLISP3 41777 . 47654) (CLISP3A 47656 . 48584) (CLISP3B 48586 . 50678) (CLISPACKUP 50680 . 57640) (CLISP3C 57642 . 58858) (CLISP4 58860 . 61450) (CLISPCOND 61452 . 63089) (CLISPCOND1 63091 . 64260) (CLISPAND 64262 . 65302) (CLISPAND1 65304 . 66106) (CLISPIFYNOT 66108 . 66961) (CLISPIFYMATCHUP 66963 . 69228) (CLREMPARS 69230 . 69479) (CLISPIFYCROPS0 69481 . 69944 ) (CLISPIFYCROPS 69946 . 76265) (CLISPIFYCROPS1 76267 . 79814) (CLISPIFYRPLAC 79816 . 84551) ( CLISPIFYMAPS 84553 . 86574) (CLMAPS1 86576 . 87117) (CLMAPS2 87119 . 92560) (CLSTOPSCAN? 92562 . 93193 ) (CLISPIFYLOOKUP 93195 . 94845) (LOWERCASE 94847 . 95926) (SHRIEKIFY 95928 . 97531) (SHRKFY 97533 . 127156) (SHRKFY2 127158 . 127347) (WHILEDOUNTIL 127349 . 129697) (WHILEDO1 129699 . 129900) (CLDISABLE 129902 . 132458))))) STOP \ No newline at end of file diff --git a/sources/CLOSURE-CACHE b/sources/CLOSURE-CACHE new file mode 100644 index 00000000..a7f6d03a --- /dev/null +++ b/sources/CLOSURE-CACHE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "16-May-90 12:36:15" IL:|{DSK}local>lde>lispcore>sources>CLOSURE-CACHE.;2| 3636 IL:|changes| IL:|to:| (IL:VARS IL:CLOSURE-CACHECOMS) IL:|previous| IL:|date:| "24-Jan-88 17:32:55" IL:|{DSK}local>lde>lispcore>sources>CLOSURE-CACHE.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CLOSURE-CACHECOMS) (IL:RPAQQ IL:CLOSURE-CACHECOMS ((IL:FILES IL:IMPLICIT-KEY-HASH) (IL:VARIABLES SI::*CLOSURE-CACHE*) (IL:FUNCTIONS SI::GET-CACHE-CLOSURE) (IL:* IL:|;;| "Utilities ") (IL:FUNCTIONS SI::INSTALL-CLOSURE-CACHE SI::DISABLE-CLOSURE-CACHE) (IL:FUNCTIONS SI::CLEAR-CLOSURE-CACHE SHOW-CLOSURE-CACHE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P ( SI::INSTALL-CLOSURE-CACHE ))) (FILE-ENVIRONMENTS "CLOSURE-CACHE"))) (IL:FILESLOAD IL:IMPLICIT-KEY-HASH) (DEFVAR SI::*CLOSURE-CACHE* (MAKE-IMPLICIT-KEY-HASH-TABLE 64 :FIRST)) (DEFUN SI::GET-CACHE-CLOSURE (CODE-BLOCK) (LET ((CLOSURE (GET-IMPLICIT-KEY-HASH CODE-BLOCK SI::*CLOSURE-CACHE*))) (OR CLOSURE (LET ((NEW-CLOSURE (IL:|create| IL:COMPILED-CLOSURE))) (IL:UNINTERRUPTABLY (IL:* IL:|;;| "A Non-refcount set of the fnheader field") (IL:FREPLACEFIELD '(IL:COMPILED-CLOSURE 0 IL:XPOINTER) NEW-CLOSURE CODE-BLOCK) (IL:* IL:|;;| "Cache the closure") (SETF (GET-IMPLICIT-KEY-HASH CODE-BLOCK SI::*CLOSURE-CACHE*) NEW-CLOSURE)) NEW-CLOSURE)))) (IL:* IL:|;;| "Utilities ") (DEFUN SI::INSTALL-CLOSURE-CACHE () (IF (NULL SI::*CLOSURE-CACHE-ENABLED*) (IL:UNINTERRUPTABLY (SETQ SI::*CLOSURE-CACHE-ENABLED* T)))) (DEFUN SI::DISABLE-CLOSURE-CACHE () (IF SI::*CLOSURE-CACHE-ENABLED* (IL:UNINTERRUPTABLY (IL:* IL:|;;| "Shut off caching") (SETQ SI::*CLOSURE-CACHE-ENABLED* NIL) (IL:* IL:|;;| "clear cache") (SI::CLEAR-CLOSURE-CACHE) T))) (DEFUN SI::CLEAR-CLOSURE-CACHE () (IL:UNINTERRUPTABLY (IMPLICIT-KEY-MAP-HASH #'(LAMBDA (BLOCK CLOSURE) (IL:* IL:|;;| "Make the pointer to block from closure real") (IL:\\ADDREF BLOCK)) SI::*CLOSURE-CACHE*) (CLEAR-IMPLICIT-KEY-HASH SI::*CLOSURE-CACHE*))) (DEFUN SHOW-CLOSURE-CACHE (&OPTIONAL (LONG-P NIL) (STREAM T)) (IMPLICIT-KEY-MAP-HASH #'(LAMBDA (VAL KEY) (IF LONG-P (FORMAT STREAM "Code block: ~s~%" KEY)) (FORMAT STREAM "Closure: ~s~%" VAL) (IF LONG-P (TERPRI STREAM))) SI::*CLOSURE-CACHE*)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (SI::INSTALL-CLOSURE-CACHE) ) (DEFINE-FILE-ENVIRONMENT "CLOSURE-CACHE" :READTABLE "XCL" :PACKAGE "XCL" :COMPILER :COMPILE-FILE) (IL:PUTPROPS IL:CLOSURE-CACHE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CLSTREAMS b/sources/CLSTREAMS new file mode 100644 index 00000000..d8e72ff6 --- /dev/null +++ b/sources/CLSTREAMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 3-Apr-91 15:11:53" |{PELE:MV:ENVOS}SOURCES>CLSTREAMS.;4| 54013 |changes| |to:| (FUNCTIONS CL:WITH-INPUT-FROM-STRING) |previous| |date:| "27-Feb-91 20:05:55" |{PELE:MV:ENVOS}SOURCES>CLSTREAMS.;3|) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CLSTREAMSCOMS) (RPAQQ CLSTREAMSCOMS ( (* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21") (COMS (* |;;| "documented functions and macros") (FUNCTIONS OPEN CL:CLOSE CL:STREAM-EXTERNAL-FORMAT) (FUNCTIONS CL:STREAM-ELEMENT-TYPE CL:INPUT-STREAM-P CL:OUTPUT-STREAM-P XCL:OPEN-STREAM-P) (COMS (FUNCTIONS FILE-STREAM-POSITION) (SETFS FILE-STREAM-POSITION)) (FUNCTIONS CL:MAKE-SYNONYM-STREAM XCL:SYNONYM-STREAM-P XCL:SYNONYM-STREAM-SYMBOL XCL:FOLLOW-SYNONYM-STREAMS) (FUNCTIONS CL:MAKE-BROADCAST-STREAM XCL:BROADCAST-STREAM-P XCL:BROADCAST-STREAM-STREAMS) (FUNCTIONS CL:MAKE-CONCATENATED-STREAM XCL:CONCATENATED-STREAM-P XCL:CONCATENATED-STREAM-STREAMS) (FUNCTIONS CL:MAKE-TWO-WAY-STREAM XCL:TWO-WAY-STREAM-P XCL:TWO-WAY-STREAM-OUTPUT-STREAM XCL:TWO-WAY-STREAM-INPUT-STREAM) (FUNCTIONS CL:MAKE-ECHO-STREAM XCL:ECHO-STREAM-P XCL:ECHO-STREAM-INPUT-STREAM XCL:ECHO-STREAM-OUTPUT-STREAM) (FUNCTIONS CL:MAKE-STRING-INPUT-STREAM MAKE-CONCATENATED-STRING-INPUT-STREAM) (FUNCTIONS %MAKE-INITIAL-STRING-STREAM-CONTENTS) (FUNCTIONS CL:WITH-OPEN-STREAM CL:WITH-INPUT-FROM-STRING CL:WITH-OUTPUT-TO-STRING CL:WITH-OPEN-FILE) (FUNCTIONS CL:MAKE-STRING-OUTPUT-STREAM MAKE-FILL-POINTER-OUTPUT-STREAM CL:GET-OUTPUT-STREAM-STRING \\STRING-STREAM-OUTCHARFN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN )) (COMS (* |;;| "helpers") (FUNCTIONS %NEW-FILE PREDICT-NAME) (DECLARE\: EVAL@COMPILE DONTCOPY (FUNCTIONS INTERLISP-ACCESS))) (COMS (* |;;| "methods for the special devices") (FNS %BROADCAST-STREAM-DEVICE-BOUT %BROADCAST-STREAM-DEVICE-OUTCHARFN %BROADCAST-STREAM-DEVICE-CLOSEFILE %BROADCAST-STREAM-DEVICE-FORCEOUTPUT) (FUNCTIONS %BROADCAST-STREAM-DEVICE-CHARSETFN) (FNS %CONCATENATED-STREAM-DEVICE-BIN %CONCATENATED-STREAM-DEVICE-CLOSEFILE %CONCATENATED-STREAM-DEVICE-EOFP %CONCATENATED-STREAM-DEVICE-PEEKBIN %CONCATENATED-STREAM-DEVICE-BACKFILEPTR) (FUNCTIONS %CONCATENATED-STREAM-DEVICE-CHARSETFN) (FNS %ECHO-STREAM-DEVICE-BIN) (FUNCTIONS %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM) (FNS %SYNONYM-STREAM-DEVICE-BIN %SYNONYM-STREAM-DEVICE-BOUT %SYNONYM-STREAM-DEVICE-OUTCHARFN %SYNONYM-STREAM-DEVICE-CLOSEFILE %SYNONYM-STREAM-DEVICE-EOFP %SYNONYM-STREAM-DEVICE-FORCEOUTPUT %SYNONYM-STREAM-DEVICE-GETFILEINFO %SYNONYM-STREAM-DEVICE-PEEKBIN %SYNONYM-STREAM-DEVICE-READP %SYNONYM-STREAM-DEVICE-BACKFILEPTR %SYNONYM-STREAM-DEVICE-SETFILEINFO %SYNONYM-STREAM-DEVICE-CHARSETFN) (FNS %TWO-WAY-STREAM-DEVICE-BIN %TWO-WAY-STREAM-DEVICE-INPUTSTREAM %TWO-WAY-STREAM-DEVICE-BOUT %TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM %TWO-WAY-STREAM-DEVICE-OUTCHARFN %TWO-WAY-STREAM-DEVICE-CLOSEFILE %TWO-WAY-STREAM-DEVICE-EOFP %TWO-WAY-STREAM-DEVICE-READP %TWO-WAY-STREAM-DEVICE-BACKFILEPTR %TWO-WAY-STREAM-DEVICE-FORCEOUTPUT %TWO-WAY-STREAM-DEVICE-PEEKBIN %TWO-WAY-STREAM-DEVICE-CHARSETFN) (FUNCTIONS %FILL-POINTER-STREAM-DEVICE-CLOSEFILE %FILL-POINTER-STREAM-DEVICE-GETFILEPTR) (GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE)) (COMS (* |;;| "helper stuff") (FNS %SYNONYM-STREAM-DEVICE-GET-STREAM)) (COMS (* |;;| "module initialization") (VARIABLES *DEBUG-IO* *QUERY-IO* *TERMINAL-IO* *ERROR-OUTPUT* *STANDARD-OUTPUT* *STANDARD-INPUT*) (FUNCTIONS %INITIALIZE-STANDARD-STREAMS) (FNS %INITIALIZE-CLSTREAM-TYPES) (DECLARE\: DONTEVAL@LOAD DOCOPY (* \; "initialization") (P (%INITIALIZE-CLSTREAM-TYPES) (%INITIALIZE-STANDARD-STREAMS)))) (PROP FILETYPE CLSTREAMS))) (* |;;;| "Implements a number of stream functions from CommonLisp. See CLtL chapter 21") (* |;;| "documented functions and macros") (CL:DEFUN OPEN (FILENAME &KEY (DIRECTION :INPUT) (ELEMENT-TYPE 'CL:STRING-CHAR) (IF-EXISTS NIL EXISTS-P) (IF-DOES-NOT-EXIST NIL DOES-NOT-EXIST-P) (EXTERNAL-FORMAT :DEFAULT)) (* |;;;| "Return a stream which reads from or writes to Filename. Defined keywords: :direction (one of :input, :output or :probe :element-type), Type of object to read or write, default String-Char, :if-exists (one of :error, :new-version, :overwrite, :append or nil), :if-does-not-exist (one of :error, :create or nil). :external-format (one of :DEFAULT, :EUC, :JIS, :W-MS, :MS or :XCCS). The specification of :external-format is based on the JEIDA proposal. See the manual for details.") (CL:UNLESS (MEMQ DIRECTION '(:INPUT :OUTPUT :IO :PROBE)) (CL:ERROR "~S isn't a valid direction for open." DIRECTION)) (CL:UNLESS (CL:MEMBER ELEMENT-TYPE '(CL:STRING-CHAR CL:SIGNED-BYTE CL:UNSIGNED-BYTE ( CL:UNSIGNED-BYTE 8) (CL:SIGNED-BYTE 8) CL:CHARACTER :DEFAULT) :TEST 'CL:EQUAL) (CL:ERROR "~S isn't an implemented element-type for open." ELEMENT-TYPE)) (LET ((PATHNAME (PATHNAME FILENAME)) (FOR-INPUT (MEMQ DIRECTION '(:IO :INPUT))) (FOR-OUTPUT (MEMQ DIRECTION '(:IO :OUTPUT))) (ACCESS (INTERLISP-ACCESS DIRECTION)) (FILE-TYPE (IF (CL:MEMBER ELEMENT-TYPE '(CL:UNSIGNED-BYTE CL:SIGNED-BYTE (CL:UNSIGNED-BYTE 8) (CL:SIGNED-BYTE 8)) :TEST 'CL:EQUAL) THEN 'BINARY ELSE 'TEXT)) (STREAM NIL)) (* |;;;| "Do hairy defaulting of :if-exists and :if-does-not-exist keywords.") (CL:UNLESS EXISTS-P (SETQ IF-EXISTS (CL:IF (EQ (CL:PATHNAME-VERSION PATHNAME) :NEWEST) :NEW-VERSION :ERROR))) (* \;  "If the file does not exist, it is OK to have :if-exists :overwrite. ") (CL:UNLESS DOES-NOT-EXIST-P (SETQ IF-DOES-NOT-EXIST (COND ((OR (EQ IF-EXISTS :APPEND) (EQ DIRECTION :INPUT)) :ERROR) ((EQ DIRECTION :PROBE) NIL) (T :CREATE)))) (CL:LOOP (* \;  "See if the file exists and handle the existential keywords.") (LET* ((NAME (PREDICT-NAME PATHNAME)) (CL:NAMESTRING (MKSTRING NAME))) (IF NAME THEN (* \; "file exists") (IF FOR-OUTPUT THEN (* |;;| "open for output/both") (CASE IF-EXISTS (:ERROR (CL:CERROR "write it anyway." "File ~A already exists." CL:NAMESTRING) (SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS NIL `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) ((:NEW-VERSION :SUPERSEDE :RENAME :RENAME-AND-DELETE) (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) (:OVERWRITE (SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) (:APPEND (IF (EQ DIRECTION :OUTPUT) THEN (* \;  "if the direction is output it is the same as interlisp append") (SETQ STREAM (OPENSTREAM CL:NAMESTRING 'APPEND 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) ELSE (* \;  "if direction is io it opens the file for both and goes to the end of the file") (SETQ STREAM (OPENSTREAM CL:NAMESTRING 'BOTH 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT) ))) (SETFILEPTR STREAM -1)) (RETURN NIL)) ((NIL) (CL:RETURN-FROM OPEN NIL)) (T (CL:ERROR "~S is not a valid value for :if-exists." IF-EXISTS))) |elseif| FOR-INPUT |then| (* |;;| "open for input/both") (SETQ STREAM (OPENSTREAM CL:NAMESTRING ACCESS 'OLD `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL) |else| (* |;;| "open for probe") (SETQ STREAM (|create| STREAM FULLFILENAME _ (FULLNAME CL:NAMESTRING))) (RETURN NIL)) |else| (* |;;| "file does not exist") (|if| FOR-OUTPUT |then| (CASE IF-DOES-NOT-EXIST (:ERROR (CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND :PATHNAME PATHNAME) (CL:FORMAT *QUERY-IO* "~&New file name: ") (SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*)))) (:CREATE (SETQ STREAM (OPENSTREAM PATHNAME ACCESS 'NEW `((TYPE ,FILE-TYPE) (EXTERNALFORMAT ,EXTERNAL-FORMAT)))) (RETURN NIL)) ((NIL) (CL:RETURN-FROM OPEN NIL)) (T (CL:ERROR "~S is not a valid value for :if-does-not-exist." IF-DOES-NOT-EXIST))) |elseif| FOR-INPUT |then| (CASE IF-DOES-NOT-EXIST (:ERROR (CL:CERROR "prompt for a new name." 'XCL:FILE-NOT-FOUND :PATHNAME PATHNAME) (CL:FORMAT *QUERY-IO* "~&New file name: ") (SETQ PATHNAME (PATHNAME (CL:READ-LINE *QUERY-IO*)))) (:CREATE (%NEW-FILE PATHNAME)) ((NIL) (CL:RETURN-FROM OPEN NIL)) (T (CL:ERROR "~S is not a valid value for :if-does-not-exist." IF-DOES-NOT-EXIST))) |else| (* \; "Open for probe.") (RETURN NIL))))) (STREAMPROP STREAM :FILE-STREAM-P T) STREAM)) (CL:DEFUN CL:CLOSE (STREAM &KEY ABORT) (* |;;;| "Close a stream. If ABORT, then don't keep the file") (|if| (STREAMP STREAM) |then| (|if| (OPENP STREAM) |then| (* |;;|  "determine 'deletability' of stream's file before closing, as that trashes the info") (LET ((ABORTABLE (AND (DIRTYABLE STREAM) (NOT (APPENDONLY STREAM))))) (CLOSEF STREAM) (|if| (AND ABORT ABORTABLE) |then| (* \;  "eventually we will change device CLOSEF methods to take an ABORT arg. For now, simulate it.") (DELFILE (CL:NAMESTRING STREAM))))) |else| (ERROR "Closing a non-stream" STREAM)) T) (CL:DEFUN CL:STREAM-EXTERNAL-FORMAT (STREAM) (\\EXTERNALFORMAT STREAM)) (CL:DEFUN CL:STREAM-ELEMENT-TYPE (STREAM) 'CL:UNSIGNED-BYTE) (CL:DEFUN CL:INPUT-STREAM-P (STREAM) (CL:WHEN (NOT (STREAMP STREAM)) (\\ILLEGAL.ARG STREAM)) (* |;;| "we return T instead of the stream because Symbolics does") (AND (\\IOMODEP STREAM 'INPUT T) T)) (CL:DEFUN CL:OUTPUT-STREAM-P (STREAM) (CL:WHEN (NOT (STREAMP STREAM)) (\\ILLEGAL.ARG STREAM)) (* |;;| "we return T instead of the stream because Symbolics does") (AND (\\IOMODEP STREAM 'OUTPUT T) T)) (CL:DEFUN XCL:OPEN-STREAM-P (STREAM) (* |;;| "is stream an open stream?") (AND (STREAMP STREAM) (OPENED STREAM))) (CL:DEFUN FILE-STREAM-POSITION (STREAM) (GETFILEPTR STREAM)) (CL:DEFSETF FILE-STREAM-POSITION SETFILEPTR) (CL:DEFUN CL:MAKE-SYNONYM-STREAM (CL:SYMBOL) (* |;;| "A CommonLisp function for shadowing a stream. See CLtL p. 329") (LET ((STREAM (|create| STREAM DEVICE _ %SYNONYM-STREAM-DEVICE ACCESS _ 'BOTH F1 _ CL:SYMBOL LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| (CL:SYMBOL-VALUE CL:SYMBOL)) OUTCHARFN _ (FUNCTION %SYNONYM-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P T) (* |;;| "save the synonym stream in the OPENFILELST field of %SYNONYM-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE))) STREAM)) (CL:DEFUN XCL:SYNONYM-STREAM-P (STREAM) (STREAMPROP STREAM 'XCL:SYNONYM-STREAM-P)) (CL:DEFUN XCL:SYNONYM-STREAM-SYMBOL (STREAM) (AND (XCL:SYNONYM-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN XCL:FOLLOW-SYNONYM-STREAMS (STREAM) (* |;;;| "Return the non-synonym stream at the heart of STREAM.") (CL:IF (XCL:SYNONYM-STREAM-P STREAM) (XCL:FOLLOW-SYNONYM-STREAMS (CL:SYMBOL-VALUE (XCL:SYNONYM-STREAM-SYMBOL STREAM))) STREAM)) (CL:DEFUN CL:MAKE-BROADCAST-STREAM (&REST STREAMS) (* |;;| "CommonLisp function that makes a broadcast stream. See CLtL p329") (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?)) THEN (LET ((STREAM (|create| STREAM DEVICE _ %BROADCAST-STREAM-DEVICE ACCESS _ 'OUTPUT F1 _ STREAMS OUTCHARFN _ (FUNCTION %BROADCAST-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P T) STREAM) ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?)) DO (RETURN STREAM?))))) (CL:DEFUN XCL:BROADCAST-STREAM-P (STREAM) (* |;;| "is stream a broadcast stream?") (STREAMPROP STREAM 'XCL:BROADCAST-STREAM-P)) (CL:DEFUN XCL:BROADCAST-STREAM-STREAMS (STREAM) (* |;;| "return all of the streams that STREAM broadcasts to") (AND (XCL:BROADCAST-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN CL:MAKE-CONCATENATED-STREAM (&REST STREAMS) (* |;;| "CommonLisp function that creates a concatenated stream. See CLtL p. 329") (IF (FOR STREAM? IN STREAMS ALWAYS (STREAMP STREAM?)) THEN (LET ((STREAM (|create| STREAM DEVICE _ %CONCATENATED-STREAM-DEVICE ACCESS _ 'INPUT F1 _ STREAMS))) (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P T) STREAM) ELSE (\\ILLEGAL.ARG (FOR STREAM? IN STREAMS WHEN (NOT (STREAMP STREAM?)) DO (RETURN STREAM?))))) (CL:DEFUN XCL:CONCATENATED-STREAM-P (STREAM) (STREAMPROP STREAM 'XCL:CONCATENATED-STREAM-P)) (CL:DEFUN XCL:CONCATENATED-STREAM-STREAMS (STREAM) (* |;;| "return all of STREAM's concatenated streams") (AND (XCL:CONCATENATED-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN CL:MAKE-TWO-WAY-STREAM (CL::INPUT-STREAM CL::OUTPUT-STREAM) (* |;;| "A CommonLisp function for splicing together two streams. See CLtL p. 329") (CL:UNLESS (STREAMP CL::INPUT-STREAM) (\\ILLEGAL.ARG CL::INPUT-STREAM)) (CL:UNLESS (STREAMP CL::OUTPUT-STREAM) (\\ILLEGAL.ARG CL::OUTPUT-STREAM)) (LET ((STREAM (|create| STREAM DEVICE _ %TWO-WAY-STREAM-DEVICE ACCESS _ 'BOTH F1 _ CL::INPUT-STREAM F2 _ CL::OUTPUT-STREAM LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| CL::OUTPUT-STREAM) OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P T) (* |;;| "save STREAM in the OPENFILELST field of %TWO-WAY-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %TWO-WAY-STREAM-DEVICE))) STREAM)) (CL:DEFUN XCL:TWO-WAY-STREAM-P (STREAM) (* |;;| "is STREAM a two-way stream?") (STREAMPROP STREAM 'XCL:TWO-WAY-STREAM-P)) (CL:DEFUN XCL:TWO-WAY-STREAM-OUTPUT-STREAM (STREAM) (AND (XCL:TWO-WAY-STREAM-P STREAM) (FETCH (STREAM F2) OF STREAM))) (CL:DEFUN XCL:TWO-WAY-STREAM-INPUT-STREAM (STREAM) (AND (XCL:TWO-WAY-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN CL:MAKE-ECHO-STREAM (CL::INPUT-STREAM CL::OUTPUT-STREAM) (* |;;| "A CommonLisp function for making an echo stream. See CLtL p. 329") (CL:UNLESS (STREAMP CL::INPUT-STREAM) (\\ILLEGAL.ARG CL::INPUT-STREAM)) (CL:UNLESS (STREAMP CL::OUTPUT-STREAM) (\\ILLEGAL.ARG CL::OUTPUT-STREAM)) (LET ((STREAM (|create| STREAM DEVICE _ %ECHO-STREAM-DEVICE ACCESS _ 'BOTH F1 _ CL::INPUT-STREAM F2 _ CL::OUTPUT-STREAM LINELENGTH _ (|fetch| (STREAM LINELENGTH) |of| CL::OUTPUT-STREAM) OUTCHARFN _ (FUNCTION %TWO-WAY-STREAM-DEVICE-OUTCHARFN)))) (STREAMPROP STREAM 'XCL:ECHO-STREAM-P T) (* |;;| "save STREAM in the OPENFILELST field of %ECHO-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE |with| (CONS STREAM (|fetch| (FDEV OPENFILELST) |of| %ECHO-STREAM-DEVICE))) STREAM)) (CL:DEFUN XCL:ECHO-STREAM-P (STREAM) (* |;;| "is stream an echo stream?") (STREAMPROP STREAM 'XCL:ECHO-STREAM-P)) (CL:DEFUN XCL:ECHO-STREAM-INPUT-STREAM (STREAM) (AND (XCL:ECHO-STREAM-P STREAM) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN XCL:ECHO-STREAM-OUTPUT-STREAM (STREAM) (AND (XCL:ECHO-STREAM-P STREAM) (FETCH (STREAM F2) OF STREAM))) (CL:DEFUN CL:MAKE-STRING-INPUT-STREAM (STRING &OPTIONAL (CL::START 0) (CL::END NIL)) (* |;;;| "A CommonLisp function for producing a stream from a string. See CLtL p. 330") (OPENSTRINGSTREAM (|if| (OR (NOT (CL:ZEROP CL::START)) (NOT (NULL CL::END))) |then| (* |;;| "A displaced array is ok here because the stream's uses GETBASEBYTE directly and doesn't go through the array code at all. ") (SUBSTRING STRING (CL:1+ CL::START) CL::END) |else| STRING) 'INPUT)) (CL:DEFUN MAKE-CONCATENATED-STRING-INPUT-STREAM (STRINGS) (COND ((NULL STRINGS) NIL) ((NULL (CL:REST STRINGS)) (CL:MAKE-STRING-INPUT-STREAM (CL:FIRST STRINGS))) (T (CL:APPLY 'CL:MAKE-CONCATENATED-STREAM (FOR STRING IN STRINGS COLLECT (CL:MAKE-STRING-INPUT-STREAM STRING)))))) (CL:DEFUN %MAKE-INITIAL-STRING-STREAM-CONTENTS () (CL:MAKE-ARRAY '(256) :ELEMENT-TYPE 'CL:STRING-CHAR :EXTENDABLE T :FILL-POINTER 0)) (DEFMACRO CL:WITH-OPEN-STREAM ((VAR STREAM) &BODY (BODY DECLS)) (LET ((ABORTP (GENSYM))) `(LET ((,VAR ,STREAM) (,ABORTP T)) ,@DECLS (CL:UNWIND-PROTECT (CL:MULTIPLE-VALUE-PROG1 (PROGN ,@BODY) (SETQ ,ABORTP NIL)) (CL:CLOSE ,VAR :ABORT ,ABORTP))))) (DEFMACRO CL:WITH-INPUT-FROM-STRING ((CL::VAR STRING &KEY (CL::INDEX NIL CL::INDEXP) (CL::START 0 CL::STARTP) (CL::END NIL CL:ENDP)) &BODY (CL::BODY CL::DECLS)) `(LET* ((CL::$STRING$ ,STRING) (CL::$START$ ,CL::START)) (DECLARE (LOCALVARS CL::$STRING$ CL::$START$)) (CL:WITH-OPEN-STREAM (,CL::VAR (CL:MAKE-STRING-INPUT-STREAM CL::$STRING$ CL::$START$ ,CL::END)) ,@CL::DECLS ,@(CL:IF CL::INDEXP (* |;;| "This exists as a fudge for the fat string problem. It WILL GO AWAY when STRINGSTREAMS HAVE THEIR OWN DEVICE.") `((CL:MULTIPLE-VALUE-PROG1 (PROGN ,@CL::BODY) (* |;;| "(IF (FASL::FAT-STRING-P $STRING$) (SETF ,INDEX (+ $START$ (IL:IQUOTIENT (IL:GETFILEPTR ,VAR) 2))) (SETF ,INDEX (+ $START$ (IL:GETFILEPTR ,VAR))))") (CL:SETF ,CL::INDEX (+ CL::$START$ (GETFILEPTR ,CL::VAR))))) CL::BODY)))) (DEFMACRO CL:WITH-OUTPUT-TO-STRING ((VAR &OPTIONAL (STRING NIL ST-P)) &BODY (FORMS DECLS)) (COND (ST-P `(CL:WITH-OPEN-STREAM (,VAR (MAKE-FILL-POINTER-OUTPUT-STREAM ,STRING)) ,@DECLS ,@FORMS)) (T `(CL:WITH-OPEN-STREAM (,VAR (CL:MAKE-STRING-OUTPUT-STREAM)) ,@DECLS (PROGN ,@FORMS (CL:GET-OUTPUT-STREAM-STRING ,VAR)))))) (DEFMACRO CL:WITH-OPEN-FILE ((VAR &REST OPEN-ARGS) &BODY (FORMS DECLS)) (* |;;;| "The file whose name is File-Name is opened using the OPEN-ARGS and bound to the variable VAR. The Forms are executed, and when they terminate, normally or otherwise, the file is closed.") (LET ((ABORTP (GENSYM))) `(LET ((,VAR (OPEN ,@OPEN-ARGS)) (,ABORTP T)) ,@DECLS (CL:UNWIND-PROTECT (CL:MULTIPLE-VALUE-PROG1 (PROGN ,@FORMS) (SETQ ,ABORTP NIL)) (CL:CLOSE ,VAR :ABORT ,ABORTP))))) (DEFINLINE CL:MAKE-STRING-OUTPUT-STREAM () (* |;;;| "A function for producing a string stream. See also the function get-output-stream-string. Also, see CLtL p. 330") (MAKE-FILL-POINTER-OUTPUT-STREAM)) (CL:DEFUN MAKE-FILL-POINTER-OUTPUT-STREAM (&OPTIONAL (STRING (  %MAKE-INITIAL-STRING-STREAM-CONTENTS ))) (DECLARE (GLOBALVARS \\FILL-POINTER-STREAM-DEVICE)) (|if| (NOT (CL:ARRAY-HAS-FILL-POINTER-P STRING)) |then| (\\ILLEGAL.ARG STRING) |else| (LET ((STREAM (|create| STREAM DEVICE _ \\FILL-POINTER-STREAM-DEVICE F1 _ STRING ACCESS _ 'OUTPUT OTHERPROPS _ '(STRING-OUTPUT-STREAM T)))) (* \;  "give it a canned property list to save some consing.") (|replace| (STREAM OUTCHARFN) |of| STREAM |with| (|if| (EXTENDABLE-ARRAY-P STRING) |then| (FUNCTION \\ADJUSTABLE-STRING-STREAM-OUTCHARFN) |else| (FUNCTION \\STRING-STREAM-OUTCHARFN))) (|replace| (STREAM STRMBOUTFN) |of| STREAM |with| (FUNCTION \\OUTCHAR)) STREAM))) (CL:DEFUN CL:GET-OUTPUT-STREAM-STRING (STRING-OUTPUT-STREAM) (* |;;;| "A CommonLisp function for getting the contents of the buffer created by a call to make-string-output-stream. See CLtL p. 330") (|if| (NOT (STREAMPROP STRING-OUTPUT-STREAM 'STRING-OUTPUT-STREAM)) |then| (ERROR "Stream not a string-output-stream" STRING-OUTPUT-STREAM) |else| (PROG1 (|fetch| (STREAM F1) |of| STRING-OUTPUT-STREAM) (|replace| (STREAM F1) |of| STRING-OUTPUT-STREAM |with| (  %MAKE-INITIAL-STRING-STREAM-CONTENTS ))))) (CL:DEFUN \\STRING-STREAM-OUTCHARFN (STREAM CHAR) (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM) (FETCH (STREAM LINELENGTH) OF STREAM)) (EQ CHAR (CHARCODE EOL))) THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM) 1)) (CL:VECTOR-PUSH (CL:CHARACTER CHAR) (FETCH (STREAM F1) OF STREAM))) (CL:DEFUN \\ADJUSTABLE-STRING-STREAM-OUTCHARFN (STREAM CHAR) (LET ((STRING (FETCH (STREAM F1) OF STREAM)) (CH (CL:CHARACTER CHAR))) (IF (OR (IEQP (FETCH (STREAM CHARPOSITION) OF STREAM) (FETCH (STREAM LINELENGTH) OF STREAM)) (EQ CHAR (CHARCODE EOL))) THEN (REPLACE (STREAM CHARPOSITION) OF STREAM WITH 0) ELSE (ADD (FETCH (STREAM CHARPOSITION) OF STREAM) 1)) (* |;;| "Do the equivalent of VECTOR-PUSH-EXTEND inline to save the significant! overhead of calculating the new length at each character.") (CL:UNLESS (CL:VECTOR-PUSH CH STRING) (LET ((CURRENT-LENGTH (CL:ARRAY-TOTAL-SIZE STRING))) (IF (>= CURRENT-LENGTH (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT)) THEN (PROCEED-CASE (CL:ERROR 'END-OF-FILE :STREAM STREAM) (SI::RETRY-OUTCHAR NIL :REPORT "VECTOR-PUSH the character anyway" :CONDITION END-OF-FILE (CL:VECTOR-PUSH CH (FETCH (STREAM F1) OF STREAM)) )) ELSE (CL:ADJUST-ARRAY STRING (MIN (CL:1- CL:ARRAY-TOTAL-SIZE-LIMIT) (+ CURRENT-LENGTH (MAX (LRSH CURRENT-LENGTH 1) *DEFAULT-PUSH-EXTENSION-SIZE* )))) (CL:VECTOR-PUSH CH STRING)))))) (* |;;| "helpers") (CL:DEFUN %NEW-FILE (FILENAME) (CLOSEF (OPENSTREAM FILENAME 'OUTPUT 'NEW))) (CL:DEFUN PREDICT-NAME (PATHNAME) (LET ((PATH (CL:PROBE-FILE PATHNAME))) (IF PATH THEN (CL:NAMESTRING PATH)))) (DECLARE\: EVAL@COMPILE DONTCOPY (DEFMACRO INTERLISP-ACCESS (DIRECTION) `(CASE ,DIRECTION (:INPUT 'INPUT) (:OUTPUT 'OUTPUT) (:IO 'BOTH) (T NIL))) ) (* |;;| "methods for the special devices") (DEFINEQ (%broadcast-stream-device-bout (lambda (stream byte) (* \; "Edited 13-Jan-87 14:45 by hdj") (* |;;| "The BOUT method for the broadcast-stream device") (|for| s |in| (|fetch| f1 |of| stream) |do| (\\bout s byte)) byte) ) (%broadcast-stream-device-outcharfn (lambda (stream charcode) (* \; "Edited 18-Mar-87 11:00 by lal") (* |;;| "outcharfn for broadcast streams") (* |;;| "Using the charposition from the first stream in the broadcast stream list") (|for| s |in| (|fetch| (stream f1) |of| stream) |do| (\\outchar s charcode)) (|replace| (stream charposition) |of| stream |with| (|fetch| (stream charposition) |of| (car (|fetch| (stream f1) |of| stream)))) charcode) ) (%broadcast-stream-device-closefile (lambda (stream) (* |hdj| "26-Mar-86 16:28") (* |;;;| "The CLOSEFILE method for the broadcast-stream device") (|replace| access |of| stream |with| nil) (|replace| f1 |of| stream |with| nil) stream) ) (%broadcast-stream-device-forceoutput (lambda (|stream| |waitForFinish?|) (* |smL| "14-Aug-85 15:55") (* |;;;| "The FORCEOUTPUT method for the broadcast-stream device") (|for| \s |in| (|fetch| f1 |of| |stream|) |do| (forceoutput \s |waitForFinish?|))) ) ) (CL:DEFUN %BROADCAST-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE) (* |;;| "charset function for broadcast streams. Not clear what the value should be, so we arbitrarily return the value of the last stream.") (FOR S IN (FETCH (STREAM F1) OF STREAM) DO (SETQ $$VAL (ACCESS-CHARSET S NEWVALUE)))) (DEFINEQ (%concatenated-stream-device-bin (lambda (stream) (* \; "Edited 13-Jan-87 14:52 by hdj") (* |;;| "The BIN method for the concatenated-stream device") (while (fetch (stream f1) of stream) do (if (eofp (car (fetch (stream f1) of stream))) then (closef (pop (fetch (stream f1) of stream))) else (return (\\bin (car (fetch (stream f1) of stream))))) finally (* \; "the EOF case") (\\eof.action stream))) ) (%concatenated-stream-device-closefile (lambda (|stream|) (* |smL| "14-Aug-85 16:53") (* |;;;| "The CLOSEFILE method for the concatenated-stream device") (|replace| access |of| |stream| |with| nil) (|for| \s |in| (|fetch| f1 |of| |stream|) |do| (closef \s)) (|replace| f1 |of| |stream| |with| nil) |stream|) ) (%concatenated-stream-device-eofp (lambda (|stream|) (* \; "Edited 17-Mar-87 09:20 by lal") (* |;;;| "The EOFP method for the concatenated-stream device") (|while| (|fetch| f1 |of| |stream|) |do| (|if| (eofp (car (|fetch| f1 |of| |stream|))) |then| (closef (|pop| (|fetch| f1 |of| |stream|))) |else| (return nil)) |finally| (* \; "the EOF case") (return t))) ) (%concatenated-stream-device-peekbin (lambda (|stream| |noErrorFlg?|) (* |smL| "14-Aug-85 16:53") (* |;;;| "The PEEKBIN method for the concatenated-stream device") (|while| (|fetch| f1 |of| |stream|) |do| (|if| (eofp (car (|fetch| f1 |of| |stream|))) |then| (closef (|pop| (|fetch| f1 |of| |stream|))) |else| (return (\\peekbin (car (|fetch| f1 |of| |stream|))))) |finally| (* \; "the EOF case") (|if| |noErrorFlg?| |then| (return nil) |else| (\\eof.action |stream|)))) ) (%concatenated-stream-device-backfileptr (lambda (|stream|) (* \; "Edited 24-Mar-87 10:47 by lal") (* |;;| "concatenated streams are read sequentially and a list of them are kept in F1. as they are read, the used stream is removed from the list. \\backfileptr will work because 1) when a file is stream is used up the new one is read, at least one character's worth and 2) \\backfileptr only needs to back up one character") (\\backfileptr (car (|fetch| f1 |of| |stream|)))) ) ) (CL:DEFUN %CONCATENATED-STREAM-DEVICE-CHARSETFN (STREAM NEWVALUE) (* |;;| "the charset method for concatenated stream devices") (LET ((STREAMS (FETCH (STREAM F1) OF STREAM))) (IF STREAMS THEN (ACCESS-CHARSET (CAR STREAMS) NEWVALUE) ELSE 0))) (DEFINEQ (%echo-stream-device-bin (lambda (stream) (* |hdj| "21-Apr-86 18:33") (* |;;;| "The BIN method for the echo-stream device") (let ((byte (%two-way-stream-device-bin stream))) (\\bout stream byte) byte)) ) ) (CL:DEFUN %SYNONYM-STREAM-DEVICE-GET-INDIRECT-STREAM (SYNONYM-STREAM) (* |;;| "given a synonym-stream, find out what it is currently tracking") (CL:SYMBOL-VALUE (XCL:SYNONYM-STREAM-SYMBOL SYNONYM-STREAM))) (DEFINEQ (%synonym-stream-device-bin (lambda (stream) (* |hdj| "19-Mar-86 17:19") (* |;;;| "The BIN method for the synonym-stream device.") (\\bin (%synonym-stream-device-get-stream stream))) ) (%synonym-stream-device-bout (lambda (stream byte) (* |hdj| "19-Mar-86 17:20") (* |;;;| "The BOUT method for the synonym-stream device.") (\\bout (%synonym-stream-device-get-stream stream) byte)) ) (%SYNONYM-STREAM-DEVICE-OUTCHARFN (LAMBDA (STREAM CHARCODE) (* \; "Edited 3-Jan-90 15:25 by jds") (* |;;| " OUTCHARFN for synonym streams") (LET ((OTHER-STREAM (%SYNONYM-STREAM-DEVICE-GET-STREAM STREAM))) (\\OUTCHAR OTHER-STREAM CHARCODE) (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM CHARPOSITION ) |of| OTHER-STREAM))) )) (%SYNONYM-STREAM-DEVICE-CLOSEFILE (LAMBDA (STREAM) (* \; "Edited 18-Dec-87 12:17 by sye") (* |;;;| "the CLOSEFILE method for the synonym-stream device") (|replace| F1 |of| STREAM |with| NIL) (* |;;|  "remove the synonym stream STREAM from the OPENFILELST field of %SYNONYM-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE |with| (DREMOVE STREAM (|fetch| (FDEV OPENFILELST) |of| %SYNONYM-STREAM-DEVICE))) STREAM)) (%synonym-stream-device-eofp (lambda (stream) (* |hdj| "19-Mar-86 17:20") (* |;;;| "The EOFP method for the synonym-stream device.") (\\eofp (%synonym-stream-device-get-stream stream))) ) (%synonym-stream-device-forceoutput (lambda (stream waitforfinish) (* |hdj| "19-Mar-86 17:09") (* |;;;| "The FORCEOUTPUT method for the synonym-stream device.") (forceoutput (%synonym-stream-device-get-stream stream) waitforfinish)) ) (%synonym-stream-device-getfileinfo (lambda (stream attribute device) (* |hdj| "19-Mar-86 17:10") (* |;;;| "The GETFILEINFO method for the synonym-stream device.") (getfileinfo (%synonym-stream-device-get-stream stream) attribute)) ) (%synonym-stream-device-peekbin (lambda (stream noerrorflg?) (* |hdj| "19-Mar-86 17:12") (* |;;;| "The PEEKBIN method for the synonym-stream device") (\\peekbin (%synonym-stream-device-get-stream stream) noerrorflg?)) ) (%synonym-stream-device-readp (lambda (stream flg) (readp (%synonym-stream-device-get-stream stream) flg))) (%synonym-stream-device-backfileptr (lambda (stream) (* |hdj| "26-Aug-86 17:35") (\\backfileptr (%synonym-stream-device-get-stream stream))) ) (%synonym-stream-device-setfileinfo (lambda (stream attribute value device) (* |hdj| "19-Mar-86 17:17") (* |;;;| "The SETFILEINFO method for the synonym-stream device.") (setfileinfo (%synonym-stream-device-get-stream stream) attribute value)) ) (%synonym-stream-device-charsetfn (lambda (stream newvalue) (* \; "Edited 11-Sep-87 16:01 by bvm:") (* |;;| "The charset method for the synonym-stream device.") (access-charset (%synonym-stream-device-get-stream stream) newvalue)) ) ) (DEFINEQ (%two-way-stream-device-bin (lambda (|stream|) (* |smL| "14-Aug-85 16:44") (* |;;;| "The BIN method for the two-way-stream device") (\\bin (|fetch| f1 |of| |stream|))) ) (%two-way-stream-device-inputstream (lambda (|stream|) (* \; "Edited 14-Apr-87 16:59 by bvm:") (* |;;;| "Fetch the real input for the two-way-stream device") (|fetch| f1 |of| |stream|)) ) (%two-way-stream-device-bout (lambda (stream byte) (* |hdj| "17-Sep-86 15:28") (* |;;| " the BOUT method for two-way streams") (\\bout (|fetch| f2 |of| stream) byte)) ) (%two-way-stream-device-outputstream (lambda (stream byte) (* \; "Edited 14-Apr-87 16:59 by bvm:") (* |;;| "Fetch the real output stream for two-way streams") (|fetch| f2 |of| stream)) ) (%TWO-WAY-STREAM-DEVICE-OUTCHARFN (LAMBDA (STREAM CHARCODE) (* \; "Edited 3-Jan-90 15:26 by jds") (* |;;| "outcharfn for two-way streams") (\\OUTCHAR (|fetch| (STREAM F2) |of| STREAM) CHARCODE) (|freplace| (STREAM CHARPOSITION) |of| STREAM |with| (|ffetch| (STREAM CHARPOSITION ) |of| (|ffetch| (STREAM F2) |of| STREAM)) ))) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE (LAMBDA (|stream|) (* \; "Edited 18-Dec-87 12:32 by sye") (* |;;;| "The CLOSEFILE method for the two-way-stream device and echo-stream device") (LET ((STREAMDEVICE (|if| (XCL:TWO-WAY-STREAM-P |stream|) |then| %TWO-WAY-STREAM-DEVICE |else| %ECHO-STREAM-DEVICE))) (|replace| ACCESS |of| |stream| |with| NIL) (CLOSEF? (|fetch| F1 |of| |stream|)) (|replace| F1 |of| |stream| |with| NIL) (CLOSEF? (|fetch| F2 |of| |stream|)) (|replace| F2 |of| |stream| |with| NIL) (* |;;|  "remove STREAM from the OPENFILELST field of %TWO-WAY-STREAM-DEVICE or %ECHO-STREAM-DEVICE") (|replace| (FDEV OPENFILELST) |of| STREAMDEVICE |with| (DREMOVE |stream| (|fetch| (FDEV OPENFILELST ) |of| STREAMDEVICE))) |stream|))) (%two-way-stream-device-eofp (lambda (|stream|) (* |smL| "14-Aug-85 16:47") (* |;;;| "The EOFP method for the two-way-stream device") (\\eofp (|fetch| f1 |of| |stream|))) ) (%two-way-stream-device-readp (lambda (stream flg) (* \; "Edited 14-Apr-87 17:01 by bvm:") (* |;;;| "The READP method for the two-way-stream device") (readp (|fetch| f1 |of| stream) flg)) ) (%two-way-stream-device-backfileptr (lambda (stream) (* |hdj| "15-Sep-86 15:02") (\\backfileptr (|fetch| (stream f1) |of| stream)))) (%two-way-stream-device-forceoutput (lambda (|stream| |waitForFinish?|) (* |smL| "14-Aug-85 16:49") (* |;;;| "the FORCEOUTPUT method for the two-way-stream device") (forceoutput (|fetch| f2 |of| |stream|) |waitForFinish?|)) ) (%two-way-stream-device-peekbin (lambda (|stream| |noErrorFlg?|) (* |smL| "14-Aug-85 16:46") (* |;;;| "The PEEKBIN method for the two-way-stream device") (\\peekbin (|fetch| f1 |of| |stream|) |noErrorFlg?|)) ) (%two-way-stream-device-charsetfn (lambda (stream newvalue) (* \; "Edited 11-Sep-87 16:00 by bvm:") (* |;;| "The charset method for two-way streams. Unclear what this is supposed to mean--let's apply it only to the input side (in which case newvalue is senseless)") (access-charset (|fetch| (stream f1) |of| stream) newvalue)) ) ) (CL:DEFUN %FILL-POINTER-STREAM-DEVICE-CLOSEFILE (STREAM &OPTIONAL ABORTFLAG) (* |;;;| "the CLOSEFILE method for the fill-pointer-string-stream device") (|replace| F1 |of| STREAM |with| NIL) STREAM) (CL:DEFUN %FILL-POINTER-STREAM-DEVICE-GETFILEPTR (STREAM) (CL:LENGTH (|fetch| (STREAM F1) |of| STREAM))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS %SYNONYM-STREAM-DEVICE %BROADCAST-STREAM-DEVICE %CONCATENATED-STREAM-DEVICE %TWO-WAY-STREAM-DEVICE %ECHO-STREAM-DEVICE \\FILL-POINTER-STREAM-DEVICE) ) (* |;;| "helper stuff") (DEFINEQ (%synonym-stream-device-get-stream (lambda (|stream|) (* \; "Edited 12-Jan-87 14:46 by hdj") (* |;;| "given a synonym-stream, find out what it is currently tracking") (cl:symbol-value (|fetch| (stream f1) |of| |stream|))) ) ) (* |;;| "module initialization") (CL:DEFVAR *DEBUG-IO*) (CL:DEFVAR *QUERY-IO*) (CL:DEFVAR *TERMINAL-IO*) (CL:DEFVAR *ERROR-OUTPUT*) (CL:DEFVAR *STANDARD-OUTPUT*) (CL:DEFVAR *STANDARD-INPUT*) (CL:DEFUN %INITIALIZE-STANDARD-STREAMS () (* |;;|  "Called when CLSTREAMS is loaded. Almost everything is same as *TERMINAL-IO* to start with.") (CL:SETQ *QUERY-IO* (CL:MAKE-TWO-WAY-STREAM (CL:MAKE-SYNONYM-STREAM '\\LINEBUF.OFD) (CL:MAKE-SYNONYM-STREAM '\\TERM.OFD))) (CL:SETQ *DEBUG-IO* *QUERY-IO*) (CL:SETQ *TERMINAL-IO* *QUERY-IO*) (CL:SETQ *ERROR-OUTPUT* (CL:MAKE-SYNONYM-STREAM '\\TERM.OFD))) (DEFINEQ (%initialize-clstream-types (lambda nil (* \; "Edited 14-Apr-87 17:08 by bvm:") (* |;;| "Initialize the CLSTREAMS package. This sets up some file devices for the functions make-two-way-stream-device, etc. See CLtL chapter 21") (setq %broadcast-stream-device (|create| fdev devicename _ (quote broadcast-stream-device) resetable _ nil randomaccessp _ nil nodirectories _ t buffered _ nil pagemapped _ nil fdbinable _ nil fdboutable _ nil fdextendable _ nil deviceinfo _ nil hostnamep _ (function nill) eventfn _ (function nill) directorynamep _ (function nill) reopenfile _ (function nill) closefile _ (function %broadcast-stream-device-closefile) getfilename _ (function nill) deletefile _ (function nill) generatefiles _ (function \\generatenofiles) renamefile _ (function nill) bin _ (function nill) bout _ (function %broadcast-stream-device-bout) peekbin _ (function nill) readp _ (function nill) eofp _ (function true) blockin _ (function \\generic.bins) blockout _ (function nill) forceoutput _ (function %broadcast-stream-device-forceoutput) getfileinfo _ (function nill) setfileinfo _ (function nill) charsetfn _ (function %broadcast-stream-device-charsetfn))) (setq %concatenated-stream-device (|create| fdev devicename _ (quote concatenated-stream-device) resetable _ nil randomaccessp _ nil nodirectories _ t buffered _ nil pagemapped _ nil fdbinable _ nil fdboutable _ nil fdextendable _ nil deviceinfo _ nil hostnamep _ (function nill) eventfn _ (function nill) directorynamep _ (function nill) reopenfile _ (function nill) closefile _ (function %concatenated-stream-device-closefile) getfilename _ (function nill) deletefile _ (function nill) generatefiles _ (function \\generatenofiles) renamefile _ (function nill) bin _ (function %concatenated-stream-device-bin) bout _ (function nill) peekbin _ (function %concatenated-stream-device-peekbin) readp _ (function \\generic.readp) backfileptr _ (function %concatenated-stream-device-backfileptr) eofp _ (function %concatenated-stream-device-eofp) blockin _ (function \\generic.bins) blockout _ (function nill) forceoutput _ (function nill) getfileinfo _ (function nill) setfileinfo _ (function nill) charsetfn _ (function %concatenated-stream-device-charsetfn))) (setq %two-way-stream-device (|create| fdev devicename _ (quote two-way-stream-device) resetable _ nil randomaccessp _ nil nodirectories _ t buffered _ nil pagemapped _ nil fdbinable _ nil fdboutable _ nil fdextendable _ nil input-indirected _ t output-indirected _ t deviceinfo _ nil hostnamep _ (function nill) eventfn _ (function nill) directorynamep _ (function nill) reopenfile _ (function nill) closefile _ (function %two-way-stream-device-closefile) getfilename _ (function nill) deletefile _ (function nill) generatefiles _ (function \\generatenofiles) renamefile _ (function nill) bin _ (function %two-way-stream-device-bin) bout _ (function %two-way-stream-device-bout) peekbin _ (function %two-way-stream-device-peekbin) readp _ (function %two-way-stream-device-readp) backfileptr _ (function %two-way-stream-device-backfileptr) eofp _ (function %two-way-stream-device-eofp) blockin _ (function \\generic.bins) blockout _ (function \\generic.bouts) forceoutput _ (function %two-way-stream-device-forceoutput) getfileinfo _ (function nill) setfileinfo _ (function nill) charsetfn _ (function %two-way-stream-device-charsetfn) inputstream _ (function %two-way-stream-device-inputstream) outputstream _ (function %two-way-stream-device-outputstream))) (setq %echo-stream-device (|create| fdev |using| %two-way-stream-device devicename _ (quote echo-stream-device) bin _ (function %echo-stream-device-bin))) (setq %synonym-stream-device (|create| fdev devicename _ (quote synonym-stream-device) resetable _ nil randomaccessp _ nil nodirectories _ t buffered _ nil pagemapped _ nil fdbinable _ nil fdboutable _ nil fdextendable _ nil deviceinfo _ nil input-indirected _ t output-indirected _ t hostnamep _ (function nill) eventfn _ (function nill) directorynamep _ (function nill) reopenfile _ (function nill) closefile _ (function %synonym-stream-device-closefile) getfilename _ (function nill) deletefile _ (function nill) generatefiles _ (function \\generatenofiles) renamefile _ (function nill) bin _ (function %synonym-stream-device-bin) bout _ (function %synonym-stream-device-bout) peekbin _ (function %synonym-stream-device-peekbin) readp _ (function %synonym-stream-device-readp) backfileptr _ (function %synonym-stream-device-backfileptr) eofp _ (function %synonym-stream-device-eofp) blockin _ (function \\generic.bins) blockout _ (function \\generic.bouts) forceoutput _ (function %synonym-stream-device-forceoutput) getfileinfo _ (function %synonym-stream-device-getfileinfo) setfileinfo _ (function %synonym-stream-device-setfileinfo) inputstream _ (function %synonym-stream-device-get-indirect-stream) outputstream _ (function %synonym-stream-device-get-indirect-stream) charsetfn _ (function %synonym-stream-device-charsetfn))) (setq \\fill-pointer-stream-device (|create| fdev devicename _ (quote fill-pointer-stream-device) resetable _ nil randomaccessp _ nil nodirectories _ t buffered _ nil pagemapped _ nil fdbinable _ nil fdboutable _ nil fdextendable _ nil deviceinfo _ nil hostnamep _ (function nill) eventfn _ (function nill) directorynamep _ (function nill) openfile _ (function nill) reopenfile _ (function nill) closefile _ (function %fill-pointer-stream-device-closefile) getfilename _ (function nill) deletefile _ (function nill) generatefiles _ (function \\generatenofiles) renamefile _ (function nill) bin _ (function \\illegal.deviceop) bout _ (function nill) peekbin _ (function \\illegal.deviceop) readp _ (function \\illegal.deviceop) eofp _ (function nill) blockin _ (function \\illegal.deviceop) blockout _ (function \\generic.bouts) forceoutput _ (function nill) getfileptr _ (function %fill-pointer-stream-device-getfileptr) setfileinfo _ (function \\illegal.deviceop)))) ) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (%INITIALIZE-CLSTREAM-TYPES) (%INITIALIZE-STANDARD-STREAMS) ) (PUTPROPS CLSTREAMS FILETYPE CL:COMPILE-FILE) (PUTPROPS CLSTREAMS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL (34128 35316 (%BROADCAST-STREAM-DEVICE-BOUT 34138 . 34361) ( %BROADCAST-STREAM-DEVICE-OUTCHARFN 34363 . 34814) (%BROADCAST-STREAM-DEVICE-CLOSEFILE 34816 . 35055) ( %BROADCAST-STREAM-DEVICE-FORCEOUTPUT 35057 . 35314)) (35732 37791 (%CONCATENATED-STREAM-DEVICE-BIN 35742 . 36147) (%CONCATENATED-STREAM-DEVICE-CLOSEFILE 36149 . 36462) (%CONCATENATED-STREAM-DEVICE-EOFP 36464 . 36828) (%CONCATENATED-STREAM-DEVICE-PEEKBIN 36830 . 37305) ( %CONCATENATED-STREAM-DEVICE-BACKFILEPTR 37307 . 37789)) (38129 38348 (%ECHO-STREAM-DEVICE-BIN 38139 . 38346)) (38576 41921 (%SYNONYM-STREAM-DEVICE-BIN 38586 . 38774) (%SYNONYM-STREAM-DEVICE-BOUT 38776 . 38977) (%SYNONYM-STREAM-DEVICE-OUTCHARFN 38979 . 39686) (%SYNONYM-STREAM-DEVICE-CLOSEFILE 39688 . 40272) (%SYNONYM-STREAM-DEVICE-EOFP 40274 . 40465) (%SYNONYM-STREAM-DEVICE-FORCEOUTPUT 40467 . 40705) (%SYNONYM-STREAM-DEVICE-GETFILEINFO 40707 . 40944) (%SYNONYM-STREAM-DEVICE-PEEKBIN 40946 . 41169) ( %SYNONYM-STREAM-DEVICE-READP 41171 . 41282) (%SYNONYM-STREAM-DEVICE-BACKFILEPTR 41284 . 41430) ( %SYNONYM-STREAM-DEVICE-SETFILEINFO 41432 . 41681) (%SYNONYM-STREAM-DEVICE-CHARSETFN 41683 . 41919)) ( 41922 46247 (%TWO-WAY-STREAM-DEVICE-BIN 41932 . 42105) (%TWO-WAY-STREAM-DEVICE-INPUTSTREAM 42107 . 42298) (%TWO-WAY-STREAM-DEVICE-BOUT 42300 . 42472) (%TWO-WAY-STREAM-DEVICE-OUTPUTSTREAM 42474 . 42664) (%TWO-WAY-STREAM-DEVICE-OUTCHARFN 42666 . 43528) (%TWO-WAY-STREAM-DEVICE-CLOSEFILE 43530 . 44953) ( %TWO-WAY-STREAM-DEVICE-EOFP 44955 . 45131) (%TWO-WAY-STREAM-DEVICE-READP 45133 . 45326) ( %TWO-WAY-STREAM-DEVICE-BACKFILEPTR 45328 . 45464) (%TWO-WAY-STREAM-DEVICE-FORCEOUTPUT 45466 . 45695) ( %TWO-WAY-STREAM-DEVICE-PEEKBIN 45697 . 45910) (%TWO-WAY-STREAM-DEVICE-CHARSETFN 45912 . 46245)) (46835 47074 (%SYNONYM-STREAM-DEVICE-GET-STREAM 46845 . 47072)) (47780 53743 (%INITIALIZE-CLSTREAM-TYPES 47790 . 53741))))) STOP \ No newline at end of file diff --git a/sources/CMLARITH b/sources/CMLARITH new file mode 100644 index 00000000..98b8a455 --- /dev/null +++ b/sources/CMLARITH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-93 17:38:48" IL:|{DSK}lde>lispcore>sources>CMLARITH.;2| 102283 IL:|previous| IL:|date:| "16-May-90 12:46:36" IL:|{DSK}lde>lispcore>sources>CMLARITH.;1| ) ; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLARITHCOMS) (IL:RPAQQ IL:CMLARITHCOMS ( (IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:COMS (IL:* IL:|;;| "Error utilities") (IL:FUNCTIONS %NOT-NUMBER-ERROR %NOT-NONCOMPLEX-NUMBER-ERROR %NOT-INTEGER-ERROR %NOT-RATIONAL-ERROR %NOT-FLOAT-ERROR)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (IL:COMS (IL:STRUCTURES RATIO) (IL:* IL:|;;| "The following makes NUMBERP true on ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME 'RATIO) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS DENOMINATOR NUMERATOR RATIONALP %RATIO-PRINT %BUILD-RATIO RATIONAL RATIONALIZE) (IL:FUNCTIONS %RATIO-PLUS %RATIO-TIMES)) (IL:COMS (IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.") (IL:COMS (IL:STRUCTURES COMPLEX) (IL:* IL:|;;| "So we don't inherit the deftype from defstruct") (IL:TYPES COMPLEX) (IL:* IL:|;;| "Make Complex NUMBERP") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME 'COMPLEX) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM))))) (IL:FUNCTIONS COMPLEX REALPART IMAGPART CONJUGATE PHASE %COMPLEX-PRINT %COMPLEX-+ %COMPLEX-- %COMPLEX-* %COMPLEX-/ %COMPLEX-ABS)) (IL:COMS (IL:* IL:|;;;| "Datatype predicates") (IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)") (IL:* IL:|;;|  "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic") (IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)") (IL:* IL:|;;|  "cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic") ) (IL:COMS (IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).") (IL:* IL:|;;|  "cl:zerop is not shared with il:zerop, although they are equivalent. There is no il;plusp ") (IL:COMS (IL:FUNCTIONS ZEROP PLUSP) (XCL:OPTIMIZERS ZEROP PLUSP)) (IL:* IL:|;;| "cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith") (IL:COMS (IL:FUNCTIONS MINUSP) (XCL:OPTIMIZERS MINUSP)) (IL:* IL:|;;| "Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared") (IL:COMS (IL:FUNCTIONS EVENP ODDP) (XCL:OPTIMIZERS EVENP ODDP))) (IL:COMS (IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)") (IL:COMS (IL:FUNCTIONS %= %/= %> %< %>= %<=) (IL:PROP IL:DOPVAL %= %> %<) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %> %< %>= %<=) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;|  "Backward compatibility") (IL:* IL:\;  " il:%= is listed as the punt function for the = opcode") (IL:MOVD '%= 'IL:%=) (IL:* IL:\;  "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode") (IL:MOVD '%> 'IL:GREATERP) (IL:* IL:\;  "Interlisp Greaterp and Lessp are defined in llarith") (IL:MOVD '%< 'IL:LESSP)))) (IL:* IL:|;;|  "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %COMPARISON-MACRO)) (IL:FNS = /= < > <= >=) (IL:FUNCTIONS %COMPARISON-OPTIMIZER) (XCL:OPTIMIZERS = /= < > <= >=)) (IL:* IL:|;;| "Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES.") (IL:* IL:|;;| "cl:min and cl:max are shared with il: (defined in llarith). They are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args") (XCL:OPTIMIZERS MIN MAX)) (IL:COMS (IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ") (IL:COMS (IL:FUNCTIONS %+ %- %* %/) (IL:* IL:\; "NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating") (IL:PROP IL:DOPVAL %+ %- %*) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO %+ %- %*) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:|;;|  "Backward compatibility") (IL:MOVD '%/ 'IL:%/) (IL:* IL:|;;|  "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.") (IL:MOVD '%+ 'IL:\\SLOWPLUS2) (IL:MOVD '%- 'IL:\\SLOWDIFFERENCE) (IL:MOVD '%* 'IL:\\SLOWTIMES2)))) (IL:COMS (IL:FNS + - * /) (IL:FUNCTIONS 1+ 1- %RECIPROCOL) (XCL:OPTIMIZERS + - * / 1+ 1-) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO + *) (IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:MOVD '+ 'IL:PLUS) (IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)") (IL:MOVD '* 'IL:TIMES) (IL:* IL:|;;|  "So Interlisp quotient will do something reasonable with ratios") (IL:* (IL:MOVD 'IL:NEW-QUOTIENT 'IL:QUOTIENT)) (IL:* IL:|;;|  "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.") ))) (IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.") (IL:FUNCTIONS %GCD %LCM) (IL:FNS GCD LCM)) (IL:COMS (IL:* IL:|;;|  "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.") (IL:* IL:|;;| "optimizer of IL:minus") (XCL:OPTIMIZERS IL:MINUS) (XCL:OPTIMIZERS IL:PLUS IL:IPLUS IL:FPLUS IL:TIMES IL:ITIMES IL:FTIMES IL:RSH) (IL:PROP IL:DOPVAL IL:PLUS2 IL:IPLUS2 IL:FPLUS2 IL:TIMES2 IL:ITIMES2 IL:FTIMES2)) (IL:COMS (IL:* IL:|;;;| "Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.") (IL:FUNCTIONS ISQRT) (IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.") (IL:FUNCTIONS ABS %ABS) (IL:FUNCTIONS SIGNUM %SIGNUM)) (IL:COMS (IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.") (IL:* IL:|;;| "Float implemented in cmlfloat ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:UNBOXEDOPS)) (IL:* IL:\;  "These should be exported from xcl") (IL:COMS (IL:FUNCTIONS XCL::STRUNCATE XCL::SFLOOR XCL::SCEILING XCL::SROUND) (XCL:OPTIMIZERS XCL::STRUNCATE XCL::SROUND)) (IL:* IL:\;  "Round is shared with il: (?!)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %INTEGER-COERCE-MACRO)) (IL:FUNCTIONS TRUNCATE FLOOR CEILING ROUND) (IL:FUNCTIONS %INTEGER-COERCE-OPTIMIZER) (XCL:OPTIMIZERS TRUNCATE FLOOR CEILING ROUND)) (IL:COMS (IL:FUNCTIONS FTRUNCATE FFLOOR FCEILING FROUND) (XCL:OPTIMIZERS FTRUNCATE FFLOOR FCEILING FROUND)) (IL:COMS (IL:FUNCTIONS MOD REM)) (IL:* IL:|;;| "Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod.") (IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends") ) (IL:COMS (IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.") (IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)") (IL:COMS (IL:FUNCTIONS %LOGICAL-OPTIMIZER) (XCL:OPTIMIZERS LOGXOR LOGAND)) (IL:COMS (IL:FUNCTIONS %LOGIOR %LOGEQV) (IL:PROP IL:DOPVAL %LOGIOR) (IL:* IL:\; "for the byte compiler") (IL:PROP IL:DMACRO %LOGIOR)) (IL:COMS (IL:FNS LOGIOR LOGEQV) (XCL:OPTIMIZERS LOGIOR LOGEQV)) (IL:COMS (IL:FUNCTIONS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2) (XCL:OPTIMIZERS LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2)) (IL:COMS (IL:VARIABLES BOOLE-CLR BOOLE-SET BOOLE-1 BOOLE-2 BOOLE-C1 BOOLE-C2 BOOLE-AND BOOLE-IOR BOOLE-XOR BOOLE-EQV BOOLE-NAND BOOLE-NOR BOOLE-ANDC1 BOOLE-ANDC2 BOOLE-ORC1 BOOLE-ORC2) (IL:FUNCTIONS BOOLE)) (IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ") (IL:COMS (IL:FUNCTIONS LOGTEST LOGBITP) (XCL:OPTIMIZERS LOGTEST)) (IL:COMS (IL:FUNCTIONS ASH) (IL:PROP IL:DOPVAL ASH) (IL:* IL:\; "For the byte compiler") (IL:PROP IL:DMACRO ASH)) (IL:COMS (IL:FUNCTIONS LOGCOUNT %LOGCOUNT) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES (IL:LOADCOMP) IL:LLBIGNUM)) (IL:* IL:\; "Should be in llbignum") (IL:FUNCTIONS %BIGNUM-LOGCOUNT)) (IL:FUNCTIONS INTEGER-LENGTH) (IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH") (IL:COMS (IL:FUNCTIONS %LLSH8 %LLSH1 %LRSH8 %LRSH1) (IL:PROP IL:DOPVAL %LLSH8 %LLSH1 %LRSH8 %LRSH1) (XCL:OPTIMIZERS IL:LLSH IL:LRSH))) (IL:COMS (IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.") (IL:COMS (IL:FUNCTIONS BYTE BYTE-SIZE BYTE-POSITION) (IL:* IL:|;;| "Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer") (IL:FUNCTIONS OPTIMIZE-BYTE) (IL:PROP IL:DMACRO BYTE)) (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %MAKE-BYTE-MASK-1 %MAKE-BYTE-MASK-0)) (IL:FUNCTIONS LDB DPB MASK-FIELD DEPOSIT-FIELD) (IL:FUNCTIONS %CONSTANT-BYTESPEC-P) (XCL:OPTIMIZERS LDB DPB MASK-FIELD DEPOSIT-FIELD)) (IL:COMS (IL:FUNCTIONS LDB-TEST) (XCL:OPTIMIZERS LDB-TEST))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLARITH) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =))))) (IL:* IL:|;;;| "Common Lisp Arithmetic ") (IL:* IL:|;;| "Error utilities") (DEFUN %NOT-NUMBER-ERROR (OBJECT) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE 'NUMBER :NAME OBJECT :VALUE OBJECT)) (DEFUN %NOT-NONCOMPLEX-NUMBER-ERROR (OBJECT) (IF (NOT (NUMBERP OBJECT)) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE 'NUMBER :NAME OBJECT :VALUE OBJECT) (ERROR "Arg a complex number~%~s" OBJECT))) (DEFUN %NOT-INTEGER-ERROR (OBJECT) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE 'INTEGER :NAME OBJECT :VALUE OBJECT)) (DEFUN %NOT-RATIONAL-ERROR (OBJECT) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE 'RATIONAL :VALUE OBJECT :NAME OBJECT)) (DEFUN %NOT-FLOAT-ERROR (OBJECT) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE 'FLOAT :NAME OBJECT :VALUE OBJECT)) (IL:* IL:|;;;| "Section 2.1.2 Ratios. ") (DEFSTRUCT (RATIO (:CONSTRUCTOR %MAKE-RATIO (NUMERATOR DENOMINATOR)) (:PREDICATE %RATIO-P) (:COPIER NIL) (:PRINT-FUNCTION %RATIO-PRINT)) (NUMERATOR :READ-ONLY) (DENOMINATOR :READ-ONLY)) (IL:* IL:|;;| "The following makes NUMBERP true on ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME 'RATIO) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM)) ) (DEFUN DENOMINATOR (RATIONAL) (IL:* IL:|;;| "Returns the denominator of a rational. ") (TYPECASE RATIONAL (RATIO (RATIO-DENOMINATOR RATIONAL)) (INTEGER 1) (T (%NOT-RATIONAL-ERROR RATIONAL)))) (DEFUN NUMERATOR (RATIONAL) (IL:* IL:|;;| "Returns the numerator of a rational.") (TYPECASE RATIONAL (RATIO (RATIO-NUMERATOR RATIONAL)) (INTEGER RATIONAL) (T (%NOT-RATIONAL-ERROR RATIONAL)))) (XCL:DEFINLINE RATIONALP (NUMBER) (OR (INTEGERP NUMBER) (%RATIO-P NUMBER))) (DEFUN %RATIO-PRINT (NUMBER STREAM) (LET ((TOP (RATIO-NUMERATOR NUMBER)) (BOTTOM (RATIO-DENOMINATOR NUMBER)) PR) (COND ((NOT (IL:|fetch| (READTABLEP IL:COMMONNUMSYNTAX) IL:|of| *READTABLE*)) (IL:* IL:\;  "Can't print nice ratios to old read tables") (IL:PRIN1 "|." STREAM) (IL:\\PRINDATUM (LIST '/ TOP BOTTOM) STREAM)) (T (IL:* IL:|;;| "If *PRINT-RADIX* is true, need to print radix prefix. Of course, want it on whole ratio and not components, so we rebind to NIL inside here.") (IF *PRINT-RADIX* (SETQ PR (CONCATENATE 'STRING (STRING (CODE-CHAR (IL:|fetch| (READTABLEP IL:HASHMACROCHAR ) IL:|of| *READTABLE*))) (CASE *PRINT-BASE* (2 (IL:* IL:\; "Binary") "b") (8 "o") (16 "x") (T (IL:* IL:\;  "generalized radix prefix, even for decimal!") (CONCATENATE 'STRING (LET* ((X *PRINT-BASE*) (*PRINT-BASE* 10) (*PRINT-RADIX* NIL)) (PRINC-TO-STRING X)) "r")))))) (IL:.SPACECHECK. STREAM (+ 1 (IL:NCHARS TOP) (IL:NCHARS BOTTOM) (IF PR (IL:NCHARS PR) 0))) (LET ((IL:\\THISFILELINELENGTH NIL) (*PRINT-RADIX* NIL)) (DECLARE (IL:SPECVARS IL:\\THISFILELINELENGTH)) (IL:* IL:\;  "Turn off linelength check just in case the NCHARS count is off because of radices") (IF PR (IL:\\SOUT PR STREAM)) (IL:\\PRINDATUM TOP STREAM) (IL:\\SOUT "/" STREAM) (IL:\\PRINDATUM BOTTOM STREAM)))))) (DEFUN %BUILD-RATIO (X Y) (IL:* IL:|;;| "%BUILD-RATIO takes two integer arguments and builds the rational number which is their quotient. ") (LET ((REM (IL:IREMAINDER X Y))) (IF (EQ 0 REM) (IL:IQUOTIENT X Y) (LET ((GCD (%GCD X Y))) (WHEN (NOT (EQ GCD 1)) (SETQ X (IL:IQUOTIENT X GCD)) (SETQ Y (IL:IQUOTIENT Y GCD))) (IF (MINUSP Y) (%MAKE-RATIO (- X) (- Y)) (%MAKE-RATIO X Y)))))) (DEFUN RATIONAL (NUMBER) (IL:* IL:|;;| "Rational produces a rational number for any numeric argument. Rational assumed that the floating point is completely accurate. ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONAL-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONAL (COMPLEX-REALPART NUMBER)) (RATIONAL (COMPLEX-IMAGPART NUMBER)))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN RATIONALIZE (NUMBER) (IL:* IL:|;;| "Rationalize does a rational, but it assumes that floats are only accurate to their precision, and generates a good rational aproximation of them. ") (TYPECASE NUMBER (RATIONAL NUMBER) (FLOAT (%RATIONALIZE-FLOAT NUMBER)) (COMPLEX (%MAKE-COMPLEX (RATIONALIZE (COMPLEX-REALPART NUMBER)) (RATIONALIZE (COMPLEX-IMAGPART NUMBER)))) (T (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN %RATIO-PLUS (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-D (%GCD DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ GCD-D 1) (%MAKE-RATIO (+ (* NUMERATOR-1 DENOMINATOR-2) (* NUMERATOR-2 DENOMINATOR-1)) (* DENOMINATOR-1 DENOMINATOR-2)) (LET* ((D1/GCD-D (IL:IQUOTIENT DENOMINATOR-1 GCD-D)) (TOP (+ (* NUMERATOR-1 (IL:IQUOTIENT DENOMINATOR-2 GCD-D)) (* NUMERATOR-2 D1/GCD-D))) (GCD-TOP (%GCD TOP GCD-D)) (D2/GCD-TOP DENOMINATOR-2)) (UNLESS (EQ GCD-TOP 1) (SETQ D2/GCD-TOP (IL:IQUOTIENT DENOMINATOR-2 GCD-TOP)) (SETQ TOP (IL:IQUOTIENT TOP GCD-TOP))) (IF (AND (EQ 1 D2/GCD-TOP) (EQ 1 D1/GCD-D)) TOP (%MAKE-RATIO TOP (* D1/GCD-D D2/GCD-TOP))))))) (DEFUN %RATIO-TIMES (NUMERATOR-1 DENOMINATOR-1 NUMERATOR-2 DENOMINATOR-2) (LET ((GCD-1-2 (%GCD NUMERATOR-1 DENOMINATOR-2)) (GCD-2-1 (%GCD NUMERATOR-2 DENOMINATOR-1))) (UNLESS (EQ GCD-1-2 1) (SETQ NUMERATOR-1 (IL:IQUOTIENT NUMERATOR-1 GCD-1-2)) (SETQ DENOMINATOR-2 (IL:IQUOTIENT DENOMINATOR-2 GCD-1-2))) (UNLESS (EQ GCD-2-1 1) (SETQ NUMERATOR-2 (IL:IQUOTIENT NUMERATOR-2 GCD-2-1)) (SETQ DENOMINATOR-1 (IL:IQUOTIENT DENOMINATOR-1 GCD-2-1)))) (LET ((H (* NUMERATOR-1 NUMERATOR-2)) (K (* DENOMINATOR-1 DENOMINATOR-2))) (IF (EQ K 1) H (IF (MINUSP K) (%MAKE-RATIO (- H) (- K)) (%MAKE-RATIO H K))))) (IL:* IL:|;;;| "Section 2.1.4 Complex Numbers.") (DEFSTRUCT (COMPLEX (:CONSTRUCTOR %MAKE-COMPLEX (REALPART IMAGPART)) (:PREDICATE COMPLEXP) (:COPIER NIL) (:PRINT-FUNCTION %COMPLEX-PRINT)) (REALPART :READ-ONLY) (IMAGPART :READ-ONLY)) (IL:* IL:|;;| "So we don't inherit the deftype from defstruct") (DEFTYPE COMPLEX (&OPTIONAL TYPE) (IF (EQ TYPE '*) '(:DATATYPE COMPLEX) `(AND COMPLEX (SATISFIES (IL:LAMBDA (IL:X) (AND (TYPEP (COMPLEX-REALPART IL:X) ',TYPE) (TYPEP (COMPLEX-IMAGPART IL:X) ',TYPE))))))) (IL:* IL:|;;| "Make Complex NUMBERP") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:\\SETTYPEMASK (IL:\\TYPENUMBERFROMNAME 'COMPLEX) (IL:LOGOR IL:\\TT.NUMBERP IL:\\TT.ATOM)) ) (DEFUN COMPLEX (REALPART &OPTIONAL (IMAGPART 0)) (IL:* IL:|;;| "Builds a complex number from the specified components. Note: IMAGPART = 0.0 or floating REALPART implies that we must build a complex not a real according to the manual while IMAGPART = 0 and rational REALPART implies that we build a real. ") (TYPECASE REALPART (RATIONAL (TYPECASE IMAGPART (RATIONAL (IF (EQ 0 IMAGPART) REALPART (%MAKE-COMPLEX REALPART IMAGPART))) (FLOAT (%MAKE-COMPLEX (FLOAT REALPART) IMAGPART)) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR IMAGPART)))) (FLOAT (%MAKE-COMPLEX REALPART (FLOAT IMAGPART))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR REALPART)))) (DEFUN REALPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-REALPART NUMBER)) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN IMAGPART (NUMBER) (TYPECASE NUMBER (COMPLEX (COMPLEX-IMAGPART NUMBER)) (FLOAT 0.0) (NUMBER 0) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN CONJUGATE (NUMBER) (TYPECASE NUMBER (COMPLEX (%MAKE-COMPLEX (COMPLEX-REALPART NUMBER) (- (COMPLEX-IMAGPART NUMBER)))) (NUMBER NUMBER) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN PHASE (NUMBER) (COND ((= NUMBER 0) (IL:* IL:|;;| "The phase of zero is arbitrarily defined to be zero.") 0.0) ((COMPLEXP NUMBER) (ATAN (COMPLEX-IMAGPART NUMBER) (COMPLEX-REALPART NUMBER))) ((MINUSP NUMBER) PI) (T (IL:* IL:|;;| "Page 206 of the silver book: The phase of a positive non-complex number is zero. ... The result is a floating-point number.") 0.0))) (DEFUN %COMPLEX-PRINT (NUMBER STREAM) (LET ((REALPART (COMPLEX-REALPART NUMBER)) (IMAGPART (COMPLEX-IMAGPART NUMBER))) (IL:.SPACECHECK. STREAM (+ 5 (IL:NCHARS REALPART) (IL:NCHARS IMAGPART))) (IL:\\OUTCHAR STREAM (IL:FETCH (READTABLEP IL:HASHMACROCHAR) IL:OF *READTABLE*)) (IL:\\SOUT "C" STREAM) (IL:\\SOUT "(" STREAM) (IL:\\PRINDATUM REALPART STREAM) (IL:\\SOUT " " STREAM) (IL:\\PRINDATUM IMAGPART STREAM) (IL:\\SOUT ")" STREAM))) (DEFUN %COMPLEX-+ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-2)) ((= IMAG-2 0) (COMPLEX (+ REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (+ REAL-1 REAL-2) (+ IMAG-1 IMAG-2))))) (DEFUN %COMPLEX-- (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (- REAL-1 REAL-2) (- IMAG-2))) ((= IMAG-2 0) (COMPLEX (- REAL-1 REAL-2) IMAG-1)) (T (COMPLEX (- REAL-1 REAL-2) (- IMAG-1 IMAG-2))))) (DEFUN %COMPLEX-* (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= IMAG-1 0) (COMPLEX (* REAL-1 REAL-2) (* REAL-1 IMAG-2))) ((= IMAG-2 0) (COMPLEX (* REAL-1 REAL-2) (* IMAG-1 REAL-2))) (T (COMPLEX (- (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) (+ (* IMAG-1 REAL-2) (* REAL-1 IMAG-2)))))) (DEFUN %COMPLEX-/ (REAL-1 IMAG-1 REAL-2 IMAG-2) (COND ((= 0 IMAG-1) (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (* REAL-1 REAL-2) MODULUS) (/ (- (* REAL-1 IMAG-2)) MODULUS)))) ((= 0 IMAG-2) (COMPLEX (/ REAL-1 REAL-2) (/ IMAG-1 REAL-2))) (T (LET ((MODULUS (+ (* REAL-2 REAL-2) (* IMAG-2 IMAG-2)))) (COMPLEX (/ (+ (* REAL-1 REAL-2) (* IMAG-1 IMAG-2)) MODULUS) (/ (- (* IMAG-1 REAL-2) (* REAL-1 IMAG-2)) MODULUS)))))) (DEFUN %COMPLEX-ABS (Z) (LET ((X (FLOAT (COMPLEX-REALPART Z))) (Y (FLOAT (COMPLEX-IMAGPART Z)))) (DECLARE (TYPE FLOAT X Y)) (IL:* IL:|;;| "Might want to use a BLUE algorithm here") (SQRT (SETQ X (+ (* X X) (* Y Y)))))) (IL:* IL:|;;;| "Datatype predicates") (IL:* IL:|;;| "cl:integerp is defined in cmlpred (has an optimizer)") (IL:* IL:|;;| "cl:floatp is defined in cmltypes (has an optimizer). il:floatp is defined on llbasic" ) (IL:* IL:|;;| "cl:complexp is a defstruct predicate (compiles in line)") (IL:* IL:|;;| "cl:numberp is defined in cmltypes (has an optimizer). il:numberp is defined on llbasic") (IL:* IL:|;;;| "Section 12.2 Predicates on Numbers (generic).") (IL:* IL:|;;| "cl:zerop is not shared with il:zerop, although they are equivalent. There is no il;plusp ") (DEFUN ZEROP (NUMBER) (= 0 NUMBER)) (DEFUN PLUSP (NUMBER) (> NUMBER 0)) (XCL:DEFOPTIMIZER ZEROP (NUMBER) `(= 0 ,NUMBER)) (XCL:DEFOPTIMIZER PLUSP (NUMBER) `(> ,NUMBER 0)) (IL:* IL:|;;| "cl:minusp is shared with il:minusp, but must be redefined to work with ratios. Old version resides in llarith" ) (DEFUN MINUSP (NUMBER) (< NUMBER 0)) (XCL:DEFOPTIMIZER MINUSP (NUMBER) `(< ,NUMBER 0)) (IL:* IL:|;;| "Both cl:evenp and cl:oddp are shared with il:. The functions are extended by allowing a second optional modulus argument. Another version of il:oddp exists on llarith, but the definition of il:evenp has disappeared" ) (DEFUN EVENP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 0) (ZEROP (MOD INTEGER MODULUS)))) (DEFUN ODDP (INTEGER &OPTIONAL MODULUS) (IF (NULL MODULUS) (EQ (LOGAND INTEGER 1) 1) (NOT (ZEROP (MOD INTEGER MODULUS))))) (XCL:DEFOPTIMIZER EVENP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) `(EQ (LOGAND ,INTEGER 1) 0) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER ODDP (INTEGER &OPTIONAL (MODULUS NIL MODULUS-P)) (IF (NULL MODULUS-P) `(EQ (LOGAND ,INTEGER 1) 1) 'COMPILER:PASS)) (IL:* IL:|;;;| "Section 12.3 Comparisons on Numbers. (generic)") (DEFUN %= (X Y) (IL:* IL:|;;| "%= does coercion when checking numbers for equality. Page 196 of silver book.") (IL:* IL:|;;| "Punt function for opcode =(decimal 255) -- actually the UFN is IL:%=") (IL:\\CALLME '=) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IEQP X Y)) (FLOAT (IL:FEQP X Y)) (RATIO NIL) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT RATIO) (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER NIL) (RATIO (AND (EQL (RATIO-NUMERATOR X) (RATIO-NUMERATOR Y)) (EQL (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y)))) (FLOAT (IL:FEQP X Y)) (COMPLEX (AND (= X (COMPLEX-REALPART Y)) (= 0 (COMPLEX-IMAGPART Y)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y (COMPLEX (AND (= (COMPLEX-REALPART X) (COMPLEX-REALPART Y)) (= (COMPLEX-IMAGPART X) (COMPLEX-IMAGPART Y)))) (NUMBER (AND (= Y (COMPLEX-REALPART X)) (= 0 (COMPLEX-IMAGPART X)))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))) (DEFMACRO %/= (X Y) `(NOT (%= ,X ,Y))) (DEFUN %> (X Y) (IL:* IL:|;;| "See page 196 of CLtl") (IL:* IL:|;;| "Compiles out to greaterp opcode") (IL:* IL:\;  "So we appear as > in a frame backtrace") (IL:\\CALLME '>) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IGREATERP X Y)) (FLOAT (IL:FGREATERP X Y)) (RATIO (IL:IGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FGREATERP X Y)) (RATIO (IL:FGREATERP (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (IL:IGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (FLOAT (IL:FGREATERP (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (IL:IGREATERP (* (RATIO-NUMERATOR X) (RATIO-DENOMINATOR Y)) (* (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR X)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR X)))) (DEFUN %< (X Y) (%> Y X)) (DEFMACRO %>= (X Y) `(NOT (%< ,X ,Y))) (DEFMACRO %<= (X Y) `(NOT (%> ,X ,Y))) (IL:PUTPROPS %= IL:DOPVAL (2 =)) (IL:PUTPROPS %> IL:DOPVAL (2 IL:GREATERP)) (IL:PUTPROPS %< IL:DOPVAL (2 IL:SWAP IL:GREATERP)) (IL:* IL:\; "For the byte compiler") (IL:PUTPROPS %> IL:DMACRO (= . IL:GREATERP)) (IL:PUTPROPS %< IL:DMACRO (= . IL:LESSP)) (IL:PUTPROPS %>= IL:DMACRO (= . IL:GEQ)) (IL:PUTPROPS %<= IL:DMACRO (= . IL:LEQ)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:* IL:|;;| "Backward compatibility") (IL:* IL:\;  " il:%= is listed as the punt function for the = opcode") (IL:MOVD '%= 'IL:%=) (IL:* IL:\;  "Greaterp is the UFN for the greaterp opcode. Effectively redefines the opcode") (IL:MOVD '%> 'IL:GREATERP) (IL:* IL:\;  "Interlisp Greaterp and Lessp are defined in llarith") (IL:MOVD '%< 'IL:LESSP) ) (IL:* IL:|;;| "=, <, >, <=, and >= are shared with il:, but cl:/= is NOT shared (?!)") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %COMPARISON-MACRO (PREDICATE ARGS) `(PROGN (IF (%< ,ARGS 1) (ERROR ,(CONCATENATE 'STRING (SUBSEQ (STRING PREDICATE) 1) " requires at least one argument"))) (LET ((LAST-ARG (IL:ARG ,ARGS 1)) (I 2) CURRENT-ARG) (IF (OR (NOT (NUMBERP LAST-ARG)) (COMPLEXP LAST-ARG)) (%NOT-NUMBER-ERROR LAST-ARG)) (LOOP (IF (%> I ,ARGS) (RETURN T)) (SETQ CURRENT-ARG (IL:ARG ,ARGS I)) (IF (NOT (,PREDICATE LAST-ARG CURRENT-ARG)) (RETURN NIL)) (SETQ LAST-ARG CURRENT-ARG) (SETQ I (1+ I)))))) ) (IL:DEFINEQ (= (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Apr-87 14:40 by jop") (IF (%< ARGS 1) (ERROR "= requires at least one argument")) (LET ((FIRST-ARG (IL:ARG ARGS 1)) (I 2)) (IF (NOT (NUMBERP FIRST-ARG)) (%NOT-NUMBER-ERROR FIRST-ARG)) (LOOP (IF (%> I ARGS) (RETURN T)) (IF (%/= FIRST-ARG (IL:ARG ARGS I)) (RETURN NIL)) (SETQ I (1+ I)))))) (/= (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 14:01 by jop") (IF (%< ARGS 1) (ERROR "/= requires at least one argument")) (LET ((I 1) CURRENT-ARG J) (LOOP (IF (%> I ARGS) (RETURN T)) (SETQ CURRENT-ARG (IL:ARG ARGS I)) (SETQ J (1+ I)) (IF (NULL (LOOP (IF (%> J ARGS) (RETURN T)) (IF (%= CURRENT-ARG (IL:ARG ARGS J)) (RETURN NIL)) (SETQ J (1+ J)))) (RETURN NIL)) (SETQ I (1+ I)))))) (< (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 14:17 by jop") (%COMPARISON-MACRO %< ARGS))) (> (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 14:17 by jop") (%COMPARISON-MACRO %> ARGS))) (<= (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 14:16 by jop") (%COMPARISON-MACRO %<= ARGS))) (>= (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 14:18 by jop") (%COMPARISON-MACRO %>= ARGS))) ) (DEFUN %COMPARISON-OPTIMIZER (PREDICATE FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) (COND ((NULL SECOND-NUMBER) 'COMPILER:PASS) ((NULL THIRD-NUMBER) `(,PREDICATE ,FIRST-NUMBER ,SECOND-NUMBER)) (T `((IL:OPENLAMBDA (SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) (AND (,PREDICATE SI::%$$COMPARISON-FIRST-NUMBER SI::%$$COMPARISON-MIDDLE-NUMBER) (,PREDICATE SI::%$$COMPARISON-MIDDLE-NUMBER ,THIRD-NUMBER))) ,FIRST-NUMBER ,SECOND-NUMBER)))) (XCL:DEFOPTIMIZER = (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) 'COMPILER:PASS) ((NULL MORE-NUMBERS) `(%= ,FIRST-NUMBER ,SECOND-NUMBER)) (T (SETQ MORE-NUMBERS (CONS SECOND-NUMBER MORE-NUMBERS)) `((IL:OPENLAMBDA (SI::%$$=FIRST-NUMBER) (AND ,@(LET ((RESULT NIL) (RESULT-TAIL NIL)) (DOLIST (NUMBER MORE-NUMBERS RESULT) (%LIST-COLLECT RESULT RESULT-TAIL (LIST `(%= SI::%$$=FIRST-NUMBER ,NUMBER))))))) ,FIRST-NUMBER)))) (XCL:DEFOPTIMIZER /= (FIRST-NUMBER &OPTIONAL (SECOND-NUMBER NIL SECOND-NUMBER-P) &REST MORE-NUMBERS) (COND ((NULL SECOND-NUMBER-P) 'COMPILER:PASS) ((NULL MORE-NUMBERS) `(%/= ,FIRST-NUMBER ,SECOND-NUMBER)) (T 'COMPILER:PASS))) (XCL:DEFOPTIMIZER < (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER '%< FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER > (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER '%> FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER <= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER '%<= FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER >= (FIRST-NUMBER &OPTIONAL SECOND-NUMBER THIRD-NUMBER &REST MORE-NUMBERS) (IF (NULL MORE-NUMBERS) (%COMPARISON-OPTIMIZER '%>= FIRST-NUMBER SECOND-NUMBER THIRD-NUMBER) 'COMPILER:PASS)) (IL:* IL:|;;| "Note: the related predicates EQL, EQUAL, and EQUALP should be consulted if any of the above change. EQL is on LLNEW (?), EQUAL and EQUALP on CMLTYPES." ) (IL:* IL:|;;| "cl:min and cl:max are shared with il: (defined in llarith). They are written in terms of GREATERP and hence work on ratios. Note (min) returns #.max.integer , which is an extension on the CLtl spec. We only optimize the case of two args" ) (XCL:DEFOPTIMIZER MIN (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) `((IL:OPENLAMBDA (SI::%$$MIN-X SI::%$$MIN-Y) (IF (< SI::%$$MIN-X SI::%$$MIN-Y) SI::%$$MIN-X SI::%$$MIN-Y)) ,X ,Y) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER MAX (&OPTIONAL (X NIL X-P) (Y NIL Y-P) &REST OTHER-NUMBERS) (IF (AND (NULL OTHER-NUMBERS) X-P Y-P) `((IL:OPENLAMBDA (SI::%$$MAX-X SI::%$$MAX-Y) (IF (> SI::%$$MAX-X SI::%$$MAX-Y) SI::%$$MAX-X SI::%$$MAX-Y)) ,X ,Y) 'COMPILER:PASS)) (IL:* IL:|;;;| "Section 12.4 Arithmetic Operations (generic). ") (DEFUN %+ (X Y) (IL:\\CALLME '+) (IL:* IL:|;;| "Simple case for the sum of two numbers. Is the ufn for the plus2 opcode") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IPLUS X Y)) (FLOAT (IL:FPLUS X Y)) (RATIO (%RATIO-PLUS X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FPLUS X Y)) (RATIO (IL:FPLUS X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-+ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FPLUS (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-+ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-+ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))) (DEFUN %- (X Y) (IL:* IL:|;;| "UFN for opcode difference. ") (IL:\\CALLME '-) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:IDIFFERENCE X Y)) (FLOAT (IL:FDIFFERENCE X Y)) (RATIO (%RATIO-PLUS X 1 (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FDIFFERENCE X Y)) (RATIO (IL:FDIFFERENCE X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-- X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- Y) 1)) (FLOAT (IL:FDIFFERENCE (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-PLUS (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (- (RATIO-NUMERATOR Y)) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-- X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-- (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))) (DEFUN %* (X Y) (IL:* IL:|;;| "UFN for opcode times2. ") (IL:\\CALLME '*) (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IL:ITIMES X Y)) (FLOAT (IL:FTIMES X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FTIMES X Y)) (RATIO (IL:FTIMES X (IL:FQUOTIENT (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y)))) (COMPLEX (%COMPLEX-* X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) Y 1)) (FLOAT (IL:FTIMES (IL:FQUOTIENT (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X)) Y)) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-NUMERATOR Y) (RATIO-DENOMINATOR Y))) (COMPLEX (%COMPLEX-* X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-* (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X)))) (DEFUN %/ (X Y) (IL:* IL:|;;| "The quotient of two numbers. Has no corresponding opcode.") (IL:\\CALLME '/) (IF (AND (IL:SMALLP X) (IL:SMALLP Y) (EQ 0 (IL:IREMAINDER X Y))) (IL:* IL:|;;| "See if we can do the straight-forward thing") (IL:IQUOTIENT X Y) (IL:* IL:|;;| "More exotic cases") (TYPECASE X (INTEGER (TYPECASE Y (INTEGER (IF (OR (EQ X IL:MIN.INTEGER) (EQ X IL:MAX.INTEGER) (EQ Y IL:MIN.INTEGER) (EQ Y IL:MAX.INTEGER)) (IL:IQUOTIENT X Y) (%BUILD-RATIO X Y))) (FLOAT (IL:FQUOTIENT X Y)) (RATIO (%RATIO-TIMES X 1 (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (FLOAT (TYPECASE Y ((OR INTEGER FLOAT) (IL:FQUOTIENT X Y)) (RATIO (IL:FQUOTIENT (* (RATIO-DENOMINATOR Y) X) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0.0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (RATIO (TYPECASE Y (INTEGER (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) 1 Y)) (FLOAT (IL:FQUOTIENT (RATIO-NUMERATOR X) (* (RATIO-DENOMINATOR X) Y))) (RATIO (%RATIO-TIMES (RATIO-NUMERATOR X) (RATIO-DENOMINATOR X) (RATIO-DENOMINATOR Y) (RATIO-NUMERATOR Y))) (COMPLEX (%COMPLEX-/ X 0 (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (COMPLEX (TYPECASE Y ((OR INTEGER RATIO) (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0)) (FLOAT (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) Y 0.0)) (COMPLEX (%COMPLEX-/ (COMPLEX-REALPART X) (COMPLEX-IMAGPART X) (COMPLEX-REALPART Y) (COMPLEX-IMAGPART Y))) (OTHERWISE (%NOT-NUMBER-ERROR Y)))) (OTHERWISE (%NOT-NUMBER-ERROR X))))) (IL:* IL:\; "NOTE: %/ cannot compile out to the existinq quotient opcode because it produces ratios rather than truncating" ) (IL:PUTPROPS %+ IL:DOPVAL (2 IL:PLUS2)) (IL:PUTPROPS %- IL:DOPVAL (2 IL:DIFFERENCE)) (IL:PUTPROPS %* IL:DOPVAL (2 IL:TIMES2)) (IL:* IL:\; "For the byte compiler") (IL:PUTPROPS %+ IL:DMACRO (= . IL:PLUS)) (IL:PUTPROPS %- IL:DMACRO (= . IL:DIFFERENCE)) (IL:PUTPROPS %* IL:DMACRO (= . IL:TIMES)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:* IL:|;;| "Backward compatibility") (IL:MOVD '%/ 'IL:%/) (IL:* IL:|;;| "Redefine UFNs for generic plus, difference, and times. Old UFN defined in llarith.") (IL:MOVD '%+ 'IL:\\SLOWPLUS2) (IL:MOVD '%- 'IL:\\SLOWDIFFERENCE) (IL:MOVD '%* 'IL:\\SLOWTIMES2) ) (IL:DEFINEQ (+ (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Apr-87 14:41 by jop") (IF (EQ ARGS 0) 0 (LET ((ACCUMULATOR (IL:ARG ARGS 1)) (I 2)) (IF (NOT (NUMBERP ACCUMULATOR)) (%NOT-NUMBER-ERROR ACCUMULATOR)) (LOOP (IF (%> I ARGS) (RETURN ACCUMULATOR)) (SETQ ACCUMULATOR (%+ ACCUMULATOR (IL:ARG ARGS I))) (SETQ I (1+ I))))))) (- (IL:LAMBDA ARGS (IL:* IL:\; "Edited 9-Feb-87 20:57 by jop") (COND ((EQ ARGS 0) (ERROR "- requires at least one argument")) ((EQ ARGS 1) (IL:* IL:|;;| "Negate the argument") (- 0 (IL:ARG ARGS 1))) (T (LET ((ACCUMULATOR (IL:ARG ARGS 1)) (I 2)) (LOOP (IF (%> I ARGS) (RETURN ACCUMULATOR)) (SETQ ACCUMULATOR (%- ACCUMULATOR (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) (* (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Apr-87 14:41 by jop") (IF (EQ ARGS 0) 1 (LET ((ACCUMULATOR (IL:ARG ARGS 1)) (I 2)) (IF (NOT (NUMBERP ACCUMULATOR)) (%NOT-NUMBER-ERROR ACCUMULATOR)) (LOOP (IF (%> I ARGS) (RETURN ACCUMULATOR)) (SETQ ACCUMULATOR (%* ACCUMULATOR (IL:ARG ARGS I))) (SETQ I (1+ I))))))) (/ (IL:LAMBDA ARGS (IL:* IL:\; "Edited 8-Feb-87 19:15 by jop") (COND ((EQ ARGS 0) (ERROR "/ requires at least one argument")) ((EQ ARGS 1) (%RECIPROCOL (IL:ARG ARGS 1))) (T (LET ((ACCUMULATOR (IL:ARG ARGS 1)) (I 2)) (LOOP (IF (%> I ARGS) (RETURN ACCUMULATOR)) (SETQ ACCUMULATOR (%/ ACCUMULATOR (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) ) (DEFUN 1+ (NUMBER) (+ NUMBER 1)) (DEFUN 1- (NUMBER) (- NUMBER 1)) (DEFUN %RECIPROCOL (NUMBER) (IF (FLOATP NUMBER) (IL:FQUOTIENT 1.0 NUMBER) (/ 1 NUMBER))) (XCL:DEFOPTIMIZER + (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(%+ ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER - (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) `(%- 0 ,NUMBER) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM `(%- ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER * (&REST NUMBERS) (IF (NULL NUMBERS) 1 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(%* ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER / (NUMBER &REST NUMBERS) (IF (NULL NUMBERS) `(%RECIPROCOL ,NUMBER) (LET ((FORM NUMBER)) (DOLIST (NUM NUMBERS FORM) (SETQ FORM `(%/ ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER 1+ (NUMBER) `(+ ,NUMBER 1)) (XCL:DEFOPTIMIZER 1- (NUMBER) `(- ,NUMBER 1)) (IL:* IL:\; "For the byte compiler") (IL:PUTPROPS + IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| `(IL:PLUS ,@IL:ARGS) IL:|else| 'IL:IGNOREMACRO))) (IL:PUTPROPS * IL:DMACRO (IL:ARGS (IL:|if| (IL:GREATERP (IL:LENGTH IL:ARGS) 1) IL:|then| `(IL:TIMES ,@IL:ARGS) IL:|else| 'IL:IGNOREMACRO))) (IL:* IL:|;;| "Redefine Interlisp generic arithmetic to work with ratios") (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:MOVD '+ 'IL:PLUS) (IL:* IL:|;;| "Don't need to redefine difference since it is defined in terms of the difference opcode (redefined above)") (IL:MOVD '* 'IL:TIMES) (IL:* IL:|;;| "So Interlisp quotient will do something reasonable with ratios") (IL:* (IL:MOVD (QUOTE  IL:NEW-QUOTIENT) (QUOTE IL:QUOTIENT))) (IL:* IL:|;;| "because QUOTIENT is already defined in LLARITH to do something useful with ratios. AR 8062.") ) (IL:* IL:|;;| "INCF and DECF implemented by CMLSETF.") (DEFUN %GCD (X Y) (IL:* IL:|;;| "%GCD -- Gcd of two integers, no type checking. ") (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (COND ((EQ X 0) Y) ((EQ Y 0) X) ((OR (EQL 1 Y) (EQL 1 X)) 1) (T (LET ((K (IL:* IL:\; "Factor out powers of two") (DO ((K 0 (1+ K))) ((OR (ODDP X) (ODDP Y)) K) (SETQ X (ASH X -1)) (SETQ Y (ASH Y -1))))) (DO ((J (IF (ODDP X) (- Y) (ASH X -1)) (- X Y))) ((EQ J 0)) (LOOP (IF (ODDP J) (RETURN NIL)) (SETQ J (ASH J -1))) (IF (PLUSP J) (SETQ X J) (SETQ Y (- J)))) (ASH X K))))) (DEFUN %LCM (X Y) (COND ((EQ X 1) Y) ((EQ Y 1) X) ((OR (EQ X 0) (EQ Y 0)) 0) (T (SETQ X (%ABS X)) (SETQ Y (%ABS Y)) (LET ((GCD (%GCD X Y))) (IF (EQ GCD 1) (* X Y) (* (IL:IQUOTIENT X GCD) Y)))))) (IL:DEFINEQ (GCD (IL:LAMBDA ARGS (IL:* IL:\; "Edited 10-Feb-87 11:14 by jop") (IL:* IL:|;;| "GCD -- gcd of an arbitrary number of integers. Since the probability is >.6 that the GCD of two numbers is 1, it is worth to time to check for GCD = 1 and quit if so. ") (COND ((EQ ARGS 0) 0) ((EQ ARGS 1) (%ABS (IL:ARG ARGS 1))) (T (LET ((RESULT (%GCD (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (OR (> I ARGS) (EQ RESULT 1)) (RETURN RESULT)) (SETQ RESULT (%GCD RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) (LCM (IL:LAMBDA ARGS (IL:* IL:\; "Edited 25-Feb-87 12:20 by jop") (IL:* IL:|;;| "LCM -- least common multiple. At least one argument is required. ") (COND ((EQ ARGS 0) (ERROR "lcm requires at least one argument")) ((EQ ARGS 1) (%ABS (IL:ARG ARGS 1))) (T (LET ((RESULT (%LCM (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (OR (> I ARGS) (EQ RESULT 0)) (RETURN RESULT)) (SETQ RESULT (%LCM RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) ) (IL:* IL:|;;| "Optimizers for Interlisp functions, so that they compile open with the PavCompiler.") (IL:* IL:|;;| "optimizer of IL:minus") (XCL:DEFOPTIMIZER IL:MINUS (IL:X) `(- 0 ,IL:X)) (XCL:DEFOPTIMIZER IL:PLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:PLUS2 ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER IL:IPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (COND ((CDR NUMBERS) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:IPLUS2 ,FORM ,NUM)))) (T `(IL:IPLUS2 ,FORM 0)))))) (XCL:DEFOPTIMIZER IL:FPLUS (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:FPLUS2 ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER IL:TIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:TIMES2 ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER IL:ITIMES (&REST NUMBERS) (IF (NULL NUMBERS) 0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:ITIMES2 ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER IL:FTIMES (&REST NUMBERS) (IF (NULL NUMBERS) 1.0 (LET ((FORM (CAR NUMBERS))) (DOLIST (NUM (CDR NUMBERS) FORM) (SETQ FORM `(IL:FTIMES2 ,FORM ,NUM)))))) (XCL:DEFOPTIMIZER IL:RSH (IL:VALUE IL:SHIFT-AMOUNT) `(IL:LSH ,IL:VALUE (IL:IMINUS ,IL:SHIFT-AMOUNT))) (IL:PUTPROPS IL:PLUS2 IL:DOPVAL (2 IL:PLUS2)) (IL:PUTPROPS IL:IPLUS2 IL:DOPVAL (2 IL:IPLUS2)) (IL:PUTPROPS IL:FPLUS2 IL:DOPVAL (2 IL:FPLUS2)) (IL:PUTPROPS IL:TIMES2 IL:DOPVAL (2 IL:TIMES2)) (IL:PUTPROPS IL:ITIMES2 IL:DOPVAL (2 IL:ITIMES2)) (IL:PUTPROPS IL:FTIMES2 IL:DOPVAL (2 IL:FTIMES2)) (IL:* IL:|;;;| "Section 12.5 Irrational and Transcendental functions. Most of these will be found on cmlfloat.") (DEFUN ISQRT (INTEGER) (IL:* IL:|;;| "ISQRT: Integer square root --- isqrt (n) **2 <= n. Upper and lower bounds on the result are estimated using integer-length. On each iteration, one of the bounds is replaced by their mean. The lower bound is returned when the bounds meet or differ by only 1. Initial bounds guarantee that lg (sqrt (n)) = lg (n) /2 iterations suffice.") (IF (NOT (AND (INTEGERP INTEGER) (>= INTEGER 0))) (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(INTEGER 0) :NAME INTEGER :VALUE INTEGER :MESSAGE "a nonnegative integer")) (LET* ((ILENGTH (INTEGER-LENGTH INTEGER)) (LOW (ASH 1 (ASH (1- ILENGTH) -1))) (HIGH (+ LOW (ASH LOW (IF (ODDP ILENGTH) -1 0))))) (DO ((MID (ASH (+ LOW HIGH) -1) (ASH (+ LOW HIGH) -1))) ((<= (1- HIGH) LOW) LOW) (IF (<= (* MID MID) INTEGER) (SETQ LOW MID) (SETQ HIGH MID))))) (IL:* IL:|;;| "Abs is shared with il: abs ia also defined in llarith.") (DEFUN ABS (NUMBER) (TYPECASE NUMBER (INTEGER (IF (< NUMBER 0) (- 0 NUMBER) NUMBER)) (FLOAT (IF (< NUMBER 0.0) (- 0.0 NUMBER) NUMBER)) (RATIO (IF (< (RATIO-NUMERATOR NUMBER) 0) (%MAKE-RATIO (- 0 (RATIO-NUMERATOR NUMBER)) (RATIO-DENOMINATOR NUMBER)) NUMBER)) (COMPLEX (%COMPLEX-ABS NUMBER)) (T (%NOT-NUMBER-ERROR NUMBER)))) (DEFMACRO %ABS (INTEGER) (IL:* IL:|;;| "Integer version of abs") `((IL:OPENLAMBDA (X) (IF (< X 0) (- 0 X) X)) ,INTEGER)) (DEFUN SIGNUM (NUMBER) (IL:* IL:|;;| "If NUMBER is zero, return NUMBER, else return (/ NUMBER (ABS NUMBER)).") (IF (ZEROP NUMBER) NUMBER (TYPECASE NUMBER (RATIONAL (IF (PLUSP NUMBER) 1 -1)) (FLOAT (IF (PLUSP NUMBER) 1.0 -1.0)) (COMPLEX (/ NUMBER (ABS NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))) (DEFMACRO %SIGNUM (INTEGER) (IL:* IL:|;;| "Integer version of signum") `((IL:OPENLAMBDA (X) (COND ((EQ X 0) 0) ((PLUSP X) 1) (T -1))) ,INTEGER)) (IL:* IL:|;;;| "Section 12.6 Type Conversions and Component Extractions on Numbers.") (IL:* IL:|;;| "Float implemented in cmlfloat ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:UNBOXEDOPS) ) (IL:* IL:\; "These should be exported from xcl") (DEFUN XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (TYPECASE NUMBER (FLOAT (IL:* IL:|;;| "Could be (IL:FIX NUMBER), but this is slightly faster") (IL:\\FIXP.FROM.FLOATP NUMBER)) (RATIO (IL:IQUOTIENT (RATIO-NUMERATOR NUMBER) (RATIO-DENOMINATOR NUMBER))) (INTEGER NUMBER) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR NUMBER))) (TYPECASE DIVISOR (INTEGER (IL:IQUOTIENT NUMBER DIVISOR)) (FLOAT (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (IL:UFIX (IL:FQUOTIENT FX FY)))) (RATIO (XCL::STRUNCATE (/ NUMBER DIVISOR))) (OTHERWISE (%NOT-NONCOMPLEX-NUMBER-ERROR DIVISOR))))) (DEFUN XCL::SFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the greatest integer not greater than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) (1- RESULT)) (T RESULT))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) RESULT (1- RESULT)) (IF (< DIVISOR 0) (1- RESULT) RESULT)))))) (DEFUN XCL::SCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns the least integer not less than number, or number/divisor. ") (IF (NULL DIVISOR) (LET ((RESULT (XCL::STRUNCATE NUMBER))) (COND ((= RESULT NUMBER) RESULT) ((< NUMBER 0) RESULT) (T (1+ RESULT)))) (LET ((RESULT (XCL::STRUNCATE NUMBER DIVISOR))) (IF (= (REM NUMBER DIVISOR) 0) RESULT (IF (< NUMBER 0) (IF (< DIVISOR 0) (1+ RESULT) RESULT) (IF (< DIVISOR 0) RESULT (1+ RESULT))))))) (DEFUN XCL::SROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 ") (IF (NULL DIVISOR) (IL:FIXR NUMBER) (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (IL:FIXR (IL:FQUOTIENT NUMBER DIVISOR)) (IL:FIXR (/ NUMBER DIVISOR))))) (XCL:DEFOPTIMIZER XCL::STRUNCATE (NUMBER &OPTIONAL DIVISOR) (IF (INTEGERP DIVISOR) `(IL:IQUOTIENT ,NUMBER ,DIVISOR) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER XCL::SROUND (NUMBER &OPTIONAL (DIVISOR NIL DIVISOR-P)) (IF (NULL DIVISOR-P) `(IL:FIXR ,NUMBER) 'COMPILER:PASS)) (IL:* IL:\; "Round is shared with il: (?!)") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %INTEGER-COERCE-MACRO (SINGLE-VALUE-FN NUMBER DIVISOR &OPTIONAL FLOAT-RESULT) `(LET* ((RESULT (IF (NULL ,DIVISOR) (,SINGLE-VALUE-FN ,NUMBER) (,SINGLE-VALUE-FN ,NUMBER ,DIVISOR))) (REMAINDER (IF (NULL ,DIVISOR) (- ,NUMBER RESULT) (- ,NUMBER (* ,DIVISOR RESULT))))) (VALUES ,(IF FLOAT-RESULT '(FLOAT RESULT) 'RESULT) REMAINDER))) ) (DEFUN TRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR)) (DEFUN FLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward - infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR)) (DEFUN CEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR)) (DEFUN ROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR)) (DEFUN %INTEGER-COERCE-OPTIMIZER (SINGLE-VALUE-FN NUMBER DIVISOR CONTEXT &OPTIONAL FLOAT-RESULT) (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT)) (LET ((FORM `(,SINGLE-VALUE-FN ,NUMBER ,@(IF DIVISOR (LIST DIVISOR))))) (IF FLOAT-RESULT `(FLOAT ,FORM) FORM)) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER TRUNCATE (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::STRUNCATE NUMBER DIVISOR CONTEXT)) (XCL:DEFOPTIMIZER FLOOR (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SFLOOR NUMBER DIVISOR CONTEXT)) (XCL:DEFOPTIMIZER CEILING (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SCEILING NUMBER DIVISOR CONTEXT)) (XCL:DEFOPTIMIZER ROUND (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SROUND NUMBER DIVISOR CONTEXT)) (DEFUN FTRUNCATE (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward 0.0 The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::STRUNCATE NUMBER DIVISOR T)) (DEFUN FFLOOR (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Like floor, but returns the first result as a float ") (%INTEGER-COERCE-MACRO XCL::SFLOOR NUMBER DIVISOR T)) (DEFUN FCEILING (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward + infinity. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SCEILING NUMBER DIVISOR T)) (DEFUN FROUND (NUMBER &OPTIONAL DIVISOR) (IL:* IL:|;;| "Returns number (or number/divisor) as an integer, rounded toward nearest integer. The second returned value is the remainder. ") (%INTEGER-COERCE-MACRO XCL::SROUND NUMBER DIVISOR T)) (XCL:DEFOPTIMIZER FTRUNCATE (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::STRUNCATE NUMBER DIVISOR CONTEXT T)) (XCL:DEFOPTIMIZER FFLOOR (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SFLOOR NUMBER DIVISOR CONTEXT T)) (XCL:DEFOPTIMIZER FCEILING (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SCEILING NUMBER DIVISOR CONTEXT T )) (XCL:DEFOPTIMIZER FROUND (NUMBER &OPTIONAL DIVISOR XCL:&CONTEXT CONTEXT) (%INTEGER-COERCE-OPTIMIZER 'XCL::SROUND NUMBER DIVISOR CONTEXT T)) (DEFUN MOD (NUMBER DIVISOR) (IL:* IL:|;;| "Returns second result of FLOOR.") (IF (OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR)) REM) (DECLARE (TYPE FLOAT FX FY REM)) (SETQ REM (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))) (IF (IL:UFEQP REM 0.0) 0.0 (IF (IF (IL:UFGREATERP 0.0 FY) (IL:UFGREATERP FX 0.0) (IL:UFGREATERP 0.0 FX)) (SETQ REM (+ REM FY)))) REM) (LET ((REM (REM NUMBER DIVISOR))) (IF (AND (NOT (ZEROP REM)) (IF (MINUSP DIVISOR) (PLUSP NUMBER) (MINUSP NUMBER))) (+ REM DIVISOR) REM)))) (DEFUN REM (NUMBER DIVISOR) (IL:* IL:|;;| "Returns the second value of truncate") (COND ((AND (INTEGERP NUMBER) (INTEGERP DIVISOR)) (IL:IREMAINDER NUMBER DIVISOR)) ((OR (FLOATP NUMBER) (FLOATP DIVISOR)) (LET ((FX (FLOAT NUMBER)) (FY (FLOAT DIVISOR))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- FX (* (FLOAT (IL:UFIX (IL:FQUOTIENT FX FY))) FY))))) (T (- NUMBER (* DIVISOR (XCL::STRUNCATE NUMBER DIVISOR)))))) (IL:* IL:|;;| "Should IL:remainder be equivalent to cl:rem?. Thereis no IL:mod in the IRM, although it has a macro which makes it equivalent to imod." ) (IL:* IL:|;;| "See cmlfloat for ffloor and friends, decode-float and friends") (IL:* IL:|;;;| "Section 12.7 Logical Operations on Numbers.") (IL:* IL:|;;| "LOGXOR and LOGAND are shared with IL. (definitions in llarith)") (DEFUN %LOGICAL-OPTIMIZER (BINARY-LOGICAL-FN IDENTITY FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) (COND ((NULL FIRST-INTEGER) IDENTITY) ((NULL SECOND-INTEGER) FIRST-INTEGER) ((NULL MORE-INTEGERS) `(,BINARY-LOGICAL-FN ,FIRST-INTEGER ,SECOND-INTEGER)) (T (LET ((FORM `(,BINARY-LOGICAL-FN ,FIRST-INTEGER ,SECOND-INTEGER))) (DOLIST (INTEGER MORE-INTEGERS FORM) (SETQ FORM `(,BINARY-LOGICAL-FN ,FORM ,INTEGER))))))) (XCL:DEFOPTIMIZER LOGXOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER 'LOGXOR 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER LOGAND (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (IF (AND COMPILER::*NEW-COMPILER-IS-EXPANDING* MORE-INTEGERS) (%LOGICAL-OPTIMIZER 'LOGAND -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS) 'COMPILER:PASS)) (DEFUN %LOGIOR (X Y) (IL:LOGOR X Y)) (DEFMACRO %LOGEQV (X Y) `(LOGNOT (LOGXOR ,X ,Y))) (IL:PUTPROPS %LOGIOR IL:DOPVAL (2 IL:LOGOR2)) (IL:* IL:\; "for the byte compiler") (IL:PUTPROPS %LOGIOR IL:DMACRO (= . IL:LOGOR)) (IL:DEFINEQ (LOGIOR (IL:LAMBDA ARGS (IL:* IL:\; "Edited 11-Feb-87 11:22 by jop") (IL:* IL:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into a sequence of opcodes") (COND ((EQ ARGS 0) 0) ((EQ ARGS 1) (IL:ARG ARGS 1)) ((EQ ARGS 2) (%LOGIOR (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (T (LET ((RESULT (%LOGIOR (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (%> I ARGS) (RETURN RESULT)) (SETQ RESULT (%LOGIOR RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) (LOGEQV (IL:LAMBDA ARGS (IL:* IL:\; "Edited 11-Feb-87 13:20 by jop") (IL:* IL:|;;| "Cannot be called interpreted. This defn relies on fact that the compiler turns class to %LOGIOR calls into a sequence of opcodes") (COND ((EQ ARGS 0) -1) ((EQ ARGS 1) (IL:ARG ARGS 1)) ((EQ ARGS 2) (%LOGEQV (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (T (LET ((RESULT (%LOGEQV (IL:ARG ARGS 1) (IL:ARG ARGS 2))) (I 3)) (LOOP (IF (%> I ARGS) (RETURN RESULT)) (SETQ RESULT (%LOGEQV RESULT (IL:ARG ARGS I))) (SETQ I (1+ I)))))))) ) (XCL:DEFOPTIMIZER LOGIOR (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER '%LOGIOR 0 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS)) (XCL:DEFOPTIMIZER LOGEQV (FIRST-INTEGER SECOND-INTEGER &REST MORE-INTEGERS) (%LOGICAL-OPTIMIZER '%LOGEQV -1 FIRST-INTEGER SECOND-INTEGER MORE-INTEGERS)) (DEFUN LOGNAND (INTEGER1 INTEGER2) (LOGNOT (LOGAND INTEGER1 INTEGER2))) (DEFUN LOGNOR (INTEGER1 INTEGER2) (LOGNOT (LOGIOR INTEGER1 INTEGER2))) (DEFUN LOGANDC1 (INTEGER1 INTEGER2) (LOGAND (LOGNOT INTEGER1) INTEGER2)) (DEFUN LOGANDC2 (INTEGER1 INTEGER2) (LOGAND INTEGER1 (LOGNOT INTEGER2))) (DEFUN LOGORC1 (INTEGER1 INTEGER2) (LOGIOR (LOGNOT INTEGER1) INTEGER2)) (DEFUN LOGORC2 (INTEGER1 INTEGER2) (LOGIOR INTEGER1 (LOGNOT INTEGER2))) (XCL:DEFOPTIMIZER LOGNAND (INTEGER1 INTEGER2) `(LOGNOT (LOGAND ,INTEGER1 ,INTEGER2))) (XCL:DEFOPTIMIZER LOGNOR (INTEGER1 INTEGER2) `(LOGNOT (LOGIOR ,INTEGER1 ,INTEGER2))) (XCL:DEFOPTIMIZER LOGANDC1 (INTEGER1 INTEGER2) `(LOGAND (LOGNOT ,INTEGER1) ,INTEGER2)) (XCL:DEFOPTIMIZER LOGANDC2 (INTEGER1 INTEGER2) `(LOGAND ,INTEGER1 (LOGNOT ,INTEGER2))) (XCL:DEFOPTIMIZER LOGORC1 (INTEGER1 INTEGER2) `(LOGIOR (LOGNOT ,INTEGER1) ,INTEGER2)) (XCL:DEFOPTIMIZER LOGORC2 (INTEGER1 INTEGER2) `(LOGIOR ,INTEGER1 (LOGNOT ,INTEGER2))) (DEFCONSTANT BOOLE-CLR 0) (DEFCONSTANT BOOLE-SET 1) (DEFCONSTANT BOOLE-1 2) (DEFCONSTANT BOOLE-2 3) (DEFCONSTANT BOOLE-C1 4) (DEFCONSTANT BOOLE-C2 5) (DEFCONSTANT BOOLE-AND 6) (DEFCONSTANT BOOLE-IOR 7) (DEFCONSTANT BOOLE-XOR 8) (DEFCONSTANT BOOLE-EQV 9) (DEFCONSTANT BOOLE-NAND 10) (DEFCONSTANT BOOLE-NOR 11) (DEFCONSTANT BOOLE-ANDC1 12) (DEFCONSTANT BOOLE-ANDC2 13) (DEFCONSTANT BOOLE-ORC1 14) (DEFCONSTANT BOOLE-ORC2 15) (DEFUN BOOLE (OP INTEGER1 INTEGER2) (COND ((EQ OP BOOLE-CLR) 0) ((EQ OP BOOLE-SET) -1) ((EQ OP BOOLE-1) INTEGER1) ((EQ OP BOOLE-2) INTEGER2) ((EQ OP BOOLE-C1) (LOGNOT INTEGER1)) ((EQ OP BOOLE-C2) (LOGNOT INTEGER2)) ((EQ OP BOOLE-AND) (LOGAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-IOR) (LOGIOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-XOR) (LOGXOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-EQV) (LOGEQV INTEGER1 INTEGER2)) ((EQ OP BOOLE-NAND) (LOGNAND INTEGER1 INTEGER2)) ((EQ OP BOOLE-NOR) (LOGNOR INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC1) (LOGANDC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ANDC2) (LOGANDC2 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC1) (LOGORC1 INTEGER1 INTEGER2)) ((EQ OP BOOLE-ORC2) (LOGORC2 INTEGER1 INTEGER2)) (T (ERROR "Not a valid op: ~s" OP)))) (IL:* IL:|;;| "Lognot is shared with IL.(in addarith) ") (DEFUN LOGTEST (INTEGER1 INTEGER2) (NOT (EQ 0 (LOGAND INTEGER1 INTEGER2)))) (XCL:DEFINLINE LOGBITP (INDEX INTEGER) (EQ 1 (LOGAND 1 (ASH INTEGER (- INDEX))))) (XCL:DEFOPTIMIZER LOGTEST (INTEGER1 INTEGER2) `(NOT (EQ 0 (LOGAND ,INTEGER1 ,INTEGER2)))) (DEFUN ASH (INTEGER COUNT) (IL:LSH INTEGER COUNT)) (IL:PUTPROPS ASH IL:DOPVAL (2 IL:LSH)) (IL:* IL:\; "For the byte compiler") (IL:PUTPROPS ASH IL:DMACRO (= . IL:LSH)) (DEFUN LOGCOUNT (INTEGER) (IL:* IL:|;;| "Logcount returns the number of bits that are the complement of the sign in the integer argument x. ") (IL:* IL:|;;| "If INTEGER is negative, then the number of 0 bits is returned, otherwise number of 1 bits is returned. ") (IF (MINUSP INTEGER) (SETQ INTEGER (LOGNOT INTEGER))) (IF (NOT (IL:TYPENAMEP INTEGER 'BIGNUM)) (%LOGCOUNT INTEGER) (%BIGNUM-LOGCOUNT INTEGER))) (DEFUN %LOGCOUNT (POSITIVE-INTEGER) (IL:* IL:|;;| "Returns number of 1 bits in nonnegative integer N. ") (LET ((CNT 0)) (IL:* IL:\;  "This loop uses a LOGAND trick to reduce the number of iterations. ") (LOOP (IF (EQ 0 POSITIVE-INTEGER) (RETURN CNT)) (IL:* IL:\;  "Change rightmost 1 bit of N to a 0 bit. ") (SETQ CNT (1+ CNT)) (SETQ POSITIVE-INTEGER (LOGAND POSITIVE-INTEGER (1- POSITIVE-INTEGER)))))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD (IL:LOADCOMP) IL:LLBIGNUM) ) (IL:* IL:\; "Should be in llbignum") (DEFUN %BIGNUM-LOGCOUNT (BIGNUM) (LET ((ELEMENTS (IL:|fetch| (BIGNUM IL:ELEMENTS) IL:|of| BIGNUM)) (CNT 0)) (DOLIST (ELEMENT ELEMENTS CNT) (SETQ CNT (+ CNT (%LOGCOUNT ELEMENT)))))) (DEFUN INTEGER-LENGTH (INTEGER) (COND ((< INTEGER 0) (SETQ INTEGER (- -1 INTEGER)))) (IL:* IL:|;;| "This algorithm is basicly a binary search") (MACROLET ((BITS-OR-LESS-P (INTEGER N) `(< ,INTEGER ,(ASH 1 N)))) (IF (BITS-OR-LESS-P INTEGER 16) (COND ((BITS-OR-LESS-P INTEGER 8) (COND ((BITS-OR-LESS-P INTEGER 4) (COND ((BITS-OR-LESS-P INTEGER 2) (IF (BITS-OR-LESS-P INTEGER 1) INTEGER 2)) ((BITS-OR-LESS-P INTEGER 3) 3) (T 4))) ((BITS-OR-LESS-P INTEGER 6) (IF (BITS-OR-LESS-P INTEGER 5) 5 6)) ((BITS-OR-LESS-P INTEGER 7) 7) (T 8))) ((BITS-OR-LESS-P INTEGER 12) (COND ((BITS-OR-LESS-P INTEGER 10) (IF (BITS-OR-LESS-P INTEGER 9) 9 10)) ((BITS-OR-LESS-P INTEGER 11) 11) (T 12))) ((BITS-OR-LESS-P INTEGER 14) (IF (BITS-OR-LESS-P INTEGER 13) 13 14)) ((BITS-OR-LESS-P INTEGER 15) 15) (T 16)) (+ 16 (INTEGER-LENGTH (ASH INTEGER -16)))))) (IL:* IL:|;;| "OPTIMIZERS FOR IL:LLSH AND IL:LRSH") (DEFUN %LLSH8 (X) (IL:LLSH X 8)) (DEFUN %LLSH1 (X) (IL:LLSH X 1)) (DEFUN %LRSH8 (X) (IL:LRSH X 8)) (DEFUN %LRSH1 (X) (IL:LRSH X 1)) (IL:PUTPROPS %LLSH8 IL:DOPVAL (1 IL:LLSH8)) (IL:PUTPROPS %LLSH1 IL:DOPVAL (1 IL:LLSH1)) (IL:PUTPROPS %LRSH8 IL:DOPVAL (1 IL:LRSH8)) (IL:PUTPROPS %LRSH1 IL:DOPVAL (1 IL:LRSH1)) (XCL:DEFOPTIMIZER IL:LLSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M '(INTEGER 0)) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM `(%LLSH8 ,FORM)) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM `(%LLSH1 ,FORM)) (DECF M 1)) FORM) 'COMPILER:PASS)) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:LRSH (X N) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((M (AND (CONSTANTP N) (EVAL N)))) (IF (TYPEP M '(INTEGER 0)) (LET ((FORM X)) (LOOP (IF (< M 8) (RETURN NIL)) (SETQ FORM `(%LRSH8 ,FORM)) (DECF M 8)) (LOOP (IF (<= M 0) (RETURN NIL)) (SETQ FORM `(%LRSH1 ,FORM)) (DECF M 1)) FORM) 'COMPILER:PASS)) 'COMPILER:PASS)) (IL:* IL:|;;;| "Section 12.8 Byte Manipulations Functions.") (DEFUN BYTE (SIZE POSITION) (IF (OR (< SIZE 0) (< POSITION 0)) (ERROR "Not a valid bytespec: ~s ~s" SIZE POSITION) (IF (AND (< SIZE 256) (< POSITION 256)) (+ (ASH SIZE 8) POSITION) (CONS SIZE POSITION)))) (XCL:DEFINLINE BYTE-SIZE (BYTESPEC) (IF (TYPEP BYTESPEC 'FIXNUM) (ASH BYTESPEC -8) (CAR BYTESPEC))) (XCL:DEFINLINE BYTE-POSITION (BYTESPEC) (IF (TYPEP BYTESPEC 'FIXNUM) (LOGAND BYTESPEC 255) (CDR BYTESPEC))) (IL:* IL:|;;| "Byte doesn't need an optimizer since the side-effects data-base will do constant folding, but the byte-compiler can profit from an optimizer" ) (DEFUN OPTIMIZE-BYTE (SIZE POSITION) (IF (AND (TYPEP SIZE '(INTEGER 0 255)) (TYPEP POSITION '(INTEGER 0 255))) (+ (ASH SIZE 8) POSITION) 'COMPILER:PASS)) (IL:PUTPROPS BYTE IL:DMACRO (IL:ARGS (OPTIMIZE-BYTE (CAR IL:ARGS) (CADR IL:ARGS)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %MAKE-BYTE-MASK-1 (SIZE POSITION) (IF (EQ POSITION 0) `(1- (ASH 1 ,SIZE)) `(ASH (1- (ASH 1 ,SIZE)) ,POSITION))) (DEFMACRO %MAKE-BYTE-MASK-0 (SIZE POSITION) `(LOGNOT (%MAKE-BYTE-MASK-1 ,SIZE ,POSITION))) ) (DEFUN LDB (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND (ASH INTEGER (- POSITION)) (%MAKE-BYTE-MASK-1 SIZE 0)))) (DEFUN DPB (NEWBYTE BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGIOR (ASH (LOGAND NEWBYTE (%MAKE-BYTE-MASK-1 SIZE 0)) POSITION) (LOGAND INTEGER (%MAKE-BYTE-MASK-0 SIZE POSITION))))) (DEFUN MASK-FIELD (BYTESPEC INTEGER) (LET ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC))) (LOGAND INTEGER (%MAKE-BYTE-MASK-1 SIZE POSITION)))) (DEFUN DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET* ((SIZE (BYTE-SIZE BYTESPEC)) (POSITION (BYTE-POSITION BYTESPEC)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) (LOGIOR (LOGAND NEWBYTE MASK) (LOGAND INTEGER (LOGNOT MASK))))) (DEFUN %CONSTANT-BYTESPEC-P (BYTESPEC) (COND ((TYPEP BYTESPEC 'FIXNUM) BYTESPEC) ((AND (CONSP BYTESPEC) (EQ (CAR BYTESPEC) 'BYTE) (INTEGERP (CADR BYTESPEC)) (INTEGERP (CADDR BYTESPEC))) (EVAL BYTESPEC)) (T NIL))) (XCL:DEFOPTIMIZER LDB (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) `(LOGAND ,INTEGER ,(%MAKE-BYTE-MASK-1 SIZE 0)) `(LOGAND (ASH ,INTEGER ,(- POSITION)) ,(%MAKE-BYTE-MASK-1 SIZE 0)))) 'COMPILER:PASS))) (XCL:DEFOPTIMIZER DPB (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) (IF (ZEROP POSITION) `(LOGIOR (LOGAND ,NEWBYTE ,(%MAKE-BYTE-MASK-1 SIZE 0)) (LOGAND ,INTEGER ,(%MAKE-BYTE-MASK-0 SIZE 0)) ) `(LOGIOR (ASH (LOGAND ,NEWBYTE ,(%MAKE-BYTE-MASK-1 SIZE 0)) ,POSITION) (LOGAND ,INTEGER ,(%MAKE-BYTE-MASK-0 SIZE POSITION))))) 'COMPILER:PASS))) (XCL:DEFOPTIMIZER MASK-FIELD (BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE))) `(LOGAND ,INTEGER ,(%MAKE-BYTE-MASK-1 SIZE POSITION))) 'COMPILER:PASS))) (XCL:DEFOPTIMIZER DEPOSIT-FIELD (NEWBYTE BYTESPEC INTEGER) (LET ((CONSTANT-BYTE (%CONSTANT-BYTESPEC-P BYTESPEC))) (IF CONSTANT-BYTE (LET* ((SIZE (BYTE-SIZE CONSTANT-BYTE)) (POSITION (BYTE-POSITION CONSTANT-BYTE)) (MASK (%MAKE-BYTE-MASK-1 SIZE POSITION))) `(LOGIOR (LOGAND ,NEWBYTE ,MASK) (LOGAND ,INTEGER ,(LOGNOT MASK)))) 'COMPILER:PASS))) (DEFUN LDB-TEST (BYTESPEC INTEGER) (NOT (EQ 0 (LDB BYTESPEC INTEGER)))) (XCL:DEFOPTIMIZER LDB-TEST (BYTESPEC INTEGER) `(NOT (EQ 0 (LDB ,BYTESPEC ,INTEGER)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:CMLARITH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:CMLARITH IL:FILETYPE COMPILE-FILE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA LOGEQV LOGIOR LCM GCD / * - + >= <= > < /= =) ) (IL:PUTPROPS IL:CMLARITH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1993) ) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (39320 41192 (= 39333 . 39855) (/= 39857 . 40582) (< 40584 . 40733) (> 40735 . 40884) (<= 40886 . 41037) (>= 41039 . 41190)) (57727 59881 (+ 57740 . 58248) (- 58250 . 58830) (* 58832 . 59340) (/ 59342 . 59879)) (64441 65951 (GCD 64454 . 65229) (LCM 65231 . 65949)) (83940 85510 (LOGIOR 83953 . 84729) (LOGEQV 84731 . 85508))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLARRAY b/sources/CMLARRAY new file mode 100644 index 00000000..3998e3f9 --- /dev/null +++ b/sources/CMLARRAY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 6-Jan-93 12:21:21" |{DSK}lde>lispcore>sources>CMLARRAY.;2| 113462 |previous| |date:| " 4-Jan-93 17:46:26" |{DSK}lde>lispcore>sources>CMLARRAY.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CMLARRAYCOMS) (RPAQQ CMLARRAYCOMS ( (* |;;| "If you change the record declarations on CMLARRAY-SUPPORT, You need to re-make this file so the INITRECORDS get filled in right.") (* |;;| "Contains table driven macros") (DECLARE\: DONTCOPY EVAL@COMPILE (EXPORT (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT))) (* |;;| "User entry points") (FUNCTIONS CL:ADJUST-ARRAY CL:ADJUSTABLE-ARRAY-P CL:ARRAY-DIMENSION CL:ARRAY-DIMENSIONS CL:ARRAY-ELEMENT-TYPE CL:ARRAY-HAS-FILL-POINTER-P ARRAY-NEEDS-INDIRECTION-P CL:ARRAY-RANK CL:ARRAY-TOTAL-SIZE BIT CL:BIT-AND CL:BIT-ANDC1 CL:BIT-ANDC2 BIT-ARRAY-P CL:BIT-EQV CL:BIT-IOR CL:BIT-NAND CL:BIT-NOR CL:BIT-NOT CL:BIT-ORC1 CL:BIT-ORC2 CL:BIT-VECTOR-P CL:BIT-XOR CL:CHAR CL:ARRAYP CL:STRINGP COPY-ARRAY COPY-VECTOR DISPLACED-ARRAY-P EQUAL-DIMENSIONS-P EXTENDABLE-ARRAY-P FILL-ARRAY CL:FILL-POINTER FILL-VECTOR CL:MAKE-ARRAY MAKE-VECTOR READ-ONLY-ARRAY-P CL:SBIT CL:SCHAR SET-FILL-POINTER SIMPLE-ARRAY-P CL:SIMPLE-BIT-VECTOR-P CL:SIMPLE-STRING-P CL:SIMPLE-VECTOR-P STRING-ARRAY-P CL:SVREF VECTOR-LENGTH CL:VECTOR-POP CL:VECTOR-PUSH CL:VECTOR-PUSH-EXTEND CL:VECTORP) (FNS CL:AREF CL:ARRAY-IN-BOUNDS-P CL:ARRAY-ROW-MAJOR-INDEX ASET CL:VECTOR) (* |;;| "New CLtL array functions") (COMS (FNS XCL:ROW-MAJOR-AREF CL::ROW-MAJOR-ASET) (SETFS XCL:ROW-MAJOR-AREF)) (* |;;| "Setfs") (SETFS CL:AREF BIT CL:CHAR CL:FILL-POINTER CL:SBIT CL:SCHAR CL:SVREF) (* |;;| "Optimizers") (FUNCTIONS %AREF-EXPANDER %ASET-EXPANDER) (OPTIMIZERS CL:AREF ASET BIT CL:CHAR CL:SBIT CL:SCHAR CL:SVREF) (* |;;| "Vars etc") (* \;  "*PRINT-ARRAY* is defined in APRINT") (VARIABLES CL:ARRAY-RANK-LIMIT CL:ARRAY-TOTAL-SIZE-LIMIT CL:ARRAY-DIMENSION-LIMIT *DEFAULT-PUSH-EXTENSION-SIZE*) (* |;;| "Run-time support") (FNS %ALTER-AS-DISPLACED-ARRAY %ALTER-AS-DISPLACED-TO-BASE-ARRAY %AREF0 %AREF1 %AREF2 %ARRAY-BASE %ARRAY-CONTENT-INITIALIZE %ARRAY-ELEMENT-INITIALIZE %ARRAY-OFFSET %ARRAY-TYPE-NUMBER %ASET0 %ASET1 %ASET2 %CHECK-SEQUENCE-DIMENSIONS %COPY-TO-NEW-ARRAY %DO-LOGICAL-OP %EXTEND-ARRAY %FAST-COPY-BASE %FAT-STRING-ARRAY-P %FILL-ARRAY-FROM-SEQUENCE %FLATTEN-ARRAY %MAKE-ARRAY-WRITEABLE %MAKE-DISPLACED-ARRAY %MAKE-GENERAL-ARRAY %MAKE-ONED-ARRAY %MAKE-STRING-ARRAY-FAT %MAKE-TWOD-ARRAY %TOTAL-SIZE SHRINK-VECTOR) (* \; "For Interlisp string hack") (FNS %SET-ARRAY-OFFSET %SET-ARRAY-TYPE-NUMBER) (* \; "Low level predicates") (FNS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P %THIN-STRING-ARRAY-P) (OPTIMIZERS %ONED-ARRAY-P %TWOD-ARRAY-P %GENERAL-ARRAY-P) (* \;  "Real record def's on cmlarray-support") (INITRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY) (SYSRECORDS GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY) (PROP DOPVAL %AREF1 %AREF2 %ASET1 %ASET2) (* |;;| "I/O") (FNS %DEFPRINT-ARRAY %DEFPRINT-BITVECTOR %DEFPRINT-GENERIC-ARRAY %DEFPRINT-VECTOR %DEFPRINT-STRING %PRINT-ARRAY-CONTENTS) (P (DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR) (DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY) (DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY)) (* |;;| "Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters") (FNS %ARRAY-READ %ARRAY-WRITE %CML-TYPE-TO-TYPENUMBER %GET-CANONICAL-CML-TYPE %GET-ENCLOSING-SIGNED-BYTE %GET-ENCLOSING-UNSIGNED-BYTE %MAKE-ARRAY-STORAGE %REDUCE-INTEGER %REDUCE-MOD %SLOW-ARRAY-READ %SLOW-ARRAY-WRITE) (OPTIMIZERS %ARRAY-READ %ARRAY-WRITE) (* |;;| "Compiler options") (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (PROP FILETYPE CMLARRAY) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:VECTOR ASET CL:ARRAY-ROW-MAJOR-INDEX CL:ARRAY-IN-BOUNDS-P CL:AREF))))) (* |;;| "If you change the record declarations on CMLARRAY-SUPPORT, You need to re-make this file so the INITRECORDS get filled in right." ) (* |;;| "Contains table driven macros") (DECLARE\: DONTCOPY EVAL@COMPILE (* "FOLLOWING DEFINITIONS EXPORTED") (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT) (* "END EXPORTED DEFINITIONS") ) (* |;;| "User entry points") (CL:DEFUN CL:ADJUST-ARRAY (ADJUSTABLE-ARRAY DIMENSIONS &KEY (ELEMENT-TYPE NIL ELEMENT-TYPE-P) (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P) (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P) (DISPLACED-TO NIL DISPLACED-TO-P) (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P) (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P) (FILL-POINTER NIL FILL-POINTER-P) FATP) (* |;;| "Do something wonderfull") (CL:IF (NOT (EXTENDABLE-ARRAY-P ADJUSTABLE-ARRAY)) (CL:ERROR "Not an adjustable or extendable array: ~S" ADJUSTABLE-ARRAY)) (CL:IF (NOT (CL:LISTP DIMENSIONS)) (SETQ DIMENSIONS (LIST DIMENSIONS))) (CL:IF (CL:DOLIST (DIM DIMENSIONS NIL) (CL:IF (OR (< DIM 0) (>= DIM CL:ARRAY-DIMENSION-LIMIT)) (RETURN T))) (CL:ERROR "Dimensions out of bounds ~S" DIMENSIONS)) (LET ((ADJUSTABLE-ARRAY-ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ADJUSTABLE-ARRAY)) (NELTS (%TOTAL-SIZE DIMENSIONS)) (RANK (LENGTH DIMENSIONS)) (EXTENDABLE-P (NOT (CL:ADJUSTABLE-ARRAY-P ADJUSTABLE-ARRAY)))) (* |;;| "Consistency checks") (CL:IF (>= RANK CL:ARRAY-RANK-LIMIT) (CL:ERROR "Too many dimensions: ~A" RANK)) (CL:IF (>= NELTS CL:ARRAY-TOTAL-SIZE-LIMIT) (CL:ERROR "Too many elements: ~A" NELTS)) (CL:IF (NOT (EQ RANK (CL:ARRAY-RANK ADJUSTABLE-ARRAY))) (CL:ERROR "Rank mismatch: ~S" DIMENSIONS)) (CL:IF ELEMENT-TYPE-P (CL:IF (NOT (EQUAL ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE)) (CL:ERROR "ADJUSTABLE-ARRAY not of specified element-type: ~A" ELEMENT-TYPE)) (SETQ ELEMENT-TYPE ADJUSTABLE-ARRAY-ELEMENT-TYPE)) (CL:IF (AND FILL-POINTER-P (NULL FILL-POINTER) (CL:ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY)) (CL:ERROR "ADJUSTABLE-ARRAY has fill pointer")) (CL:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P)) (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P)) (AND FILL-POINTER-P FILL-POINTER (NOT (CL:ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY))) (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P))) (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P)) (CL:ERROR "Inconsistent options to adjust-array")) (CL:IF DISPLACED-TO-P (COND ((NOT (%ARRAYP DISPLACED-TO)) (CL:ERROR "Not displaced to an array: ~S" DISPLACED-TO)) ((NOT (EQUAL ADJUSTABLE-ARRAY-ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE DISPLACED-TO))) (CL:ERROR "Not displaced to an array of the same element-type:")) ((> (+ DISPLACED-INDEX-OFFSET NELTS) (CL:ARRAY-TOTAL-SIZE DISPLACED-TO)) (CL:ERROR "More elements than displaced-to array")))) (CL:IF FILL-POINTER (COND ((EQ FILL-POINTER T) (SETQ FILL-POINTER NELTS)) ((NOT (<= 0 FILL-POINTER NELTS)) (CL:ERROR "Fill pointer out of bounds: ~A" FILL-POINTER))) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P ADJUSTABLE-ARRAY) (SETQ FILL-POINTER (MIN (CL:FILL-POINTER ADJUSTABLE-ARRAY) NELTS)))) (CL:IF EXTENDABLE-P (COND ((OR DISPLACED-TO-P DISPLACED-TO-BASE-P) (CL:ERROR "Cannot adjust an extendable array to be displaced")) ((< NELTS (CL:ARRAY-TOTAL-SIZE ADJUSTABLE-ARRAY)) (CL:ERROR "Cannot extend an extendable array to have fewer elements")))) (* |;;| "Specs ready, do the surgury") (COND (DISPLACED-TO-P (%ALTER-AS-DISPLACED-ARRAY ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER)) (DISPLACED-TO-BASE-P (%ALTER-AS-DISPLACED-TO-BASE-ARRAY ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FILL-POINTER FATP)) (T (CL:IF (EQUAL (CL:ARRAY-DIMENSIONS ADJUSTABLE-ARRAY) DIMENSIONS) (CL:IF FILL-POINTER (SET-FILL-POINTER ADJUSTABLE-ARRAY FILL-POINTER)) (LET ((NEW-ARRAY (CL:MAKE-ARRAY DIMENSIONS :ELEMENT-TYPE ELEMENT-TYPE :FATP (%FAT-STRING-ARRAY-P ADJUSTABLE-ARRAY)))) (COND (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE NEW-ARRAY INITIAL-CONTENTS)) (T (CL:IF INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE NEW-ARRAY INITIAL-ELEMENT)) (%COPY-TO-NEW-ARRAY (CL:ARRAY-DIMENSIONS ADJUSTABLE-ARRAY) (%FLATTEN-ARRAY ADJUSTABLE-ARRAY) 0 DIMENSIONS (%FLATTEN-ARRAY NEW-ARRAY) 0))) (%EXTEND-ARRAY ADJUSTABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER))))) (* |;;| "Return the adjusted array") ADJUSTABLE-ARRAY)) (CL:DEFUN CL:ADJUSTABLE-ARRAY-P (ARRAY) (CL:IF (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| ARRAY) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN CL:ARRAY-DIMENSION (ARRAY DIMENSION) (COND ((%ONED-ARRAY-P ARRAY) (CL:IF (EQ 0 DIMENSION) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY) (CL:ERROR "Dimension out of bounds: ~A" DIMENSION))) ((%TWOD-ARRAY-P ARRAY) (CASE DIMENSION (0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY)) (1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY)) (T (CL:ERROR "Dimension out of bounds: ~A" DIMENSION)))) ((%GENERAL-ARRAY-P ARRAY) (LET* ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)) (RANK (LENGTH DIMS))) (CL:IF (NOT (< -1 DIMENSION RANK)) (CL:ERROR "Dimension out of bounds: ~A" DIMENSION)) (CL:IF (EQ RANK 1) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY) (CL:NTH DIMENSION DIMS)))) (T (CL:ERROR "Not an array: ~S" ARRAY)))) (CL:DEFUN CL:ARRAY-DIMENSIONS (ARRAY) (COND ((%ONED-ARRAY-P ARRAY) (LIST (|ffetch| (ONED-ARRAY TOTAL-SIZE) |of| ARRAY))) ((%TWOD-ARRAY-P ARRAY) (LIST (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY) (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY))) ((%GENERAL-ARRAY-P ARRAY) (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)) (T (CL:ERROR "Not an array: ~S" ARRAY)))) (CL:DEFUN CL:ARRAY-ELEMENT-TYPE (ARRAY) (CL:IF (%ARRAYP ARRAY) (%TYPENUMBER-TO-CML-TYPE (%ARRAY-TYPE-NUMBER ARRAY)) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN CL:ARRAY-HAS-FILL-POINTER-P (ARRAY) (CL:IF (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| ARRAY) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN ARRAY-NEEDS-INDIRECTION-P (ARRAY) (COND ((OR (%ONED-ARRAY-P ARRAY) (%TWOD-ARRAY-P ARRAY)) NIL) ((%GENERAL-ARRAY-P ARRAY) (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)) (T (CL:ERROR "Not an array: ~S" ARRAY)))) (CL:DEFUN CL:ARRAY-RANK (ARRAY) (COND ((%ONED-ARRAY-P ARRAY) 1) ((%TWOD-ARRAY-P ARRAY) 2) ((%GENERAL-ARRAY-P ARRAY) (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))) (T (CL:ERROR "Not an array: ~S" ARRAY)))) (CL:DEFUN CL:ARRAY-TOTAL-SIZE (ARRAY) (CL:IF (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN BIT (BIT-ARRAY &REST INDICES) (CL:ASSERT (TYPEP BIT-ARRAY '(CL:ARRAY BIT)) (BIT-ARRAY) "Not a bit-array: ~S" BIT-ARRAY) (CL:APPLY #'CL:AREF BIT-ARRAY INDICES)) (CL:DEFUN CL:BIT-AND (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP AND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-ANDC1 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP ANDC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-ANDC2 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP ANDC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN BIT-ARRAY-P (ARRAY) (AND (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER BIT-P) |of| ARRAY))) (CL:DEFUN CL:BIT-EQV (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP EQV BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-IOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP IOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-NAND (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP NAND BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-NOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP NOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-NOT (BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY) (CL:IF (NOT (BIT-ARRAY-P BIT-ARRAY)) (CL:ERROR "BIT-ARRAY not a bit array")) (COND ((NULL RESULT-BIT-ARRAY) (SETQ RESULT-BIT-ARRAY (CL:MAKE-ARRAY (CL:ARRAY-DIMENSIONS BIT-ARRAY) :ELEMENT-TYPE 'BIT))) ((EQ RESULT-BIT-ARRAY T) (SETQ RESULT-BIT-ARRAY BIT-ARRAY)) ((NOT (AND (BIT-ARRAY-P RESULT-BIT-ARRAY) (EQUAL-DIMENSIONS-P BIT-ARRAY RESULT-BIT-ARRAY))) (CL:ERROR "Illegal result array"))) (%DO-LOGICAL-OP 'NOT BIT-ARRAY RESULT-BIT-ARRAY) RESULT-BIT-ARRAY) (CL:DEFUN CL:BIT-ORC1 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP ORC1 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-ORC2 (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP ORC2 BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:BIT-VECTOR-P (VECTOR) (AND (%VECTORP VECTOR) (|fetch| (ARRAY-HEADER BIT-P) |of| VECTOR))) (CL:DEFUN CL:BIT-XOR (BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL BIT-RESULT) (%EXPAND-BIT-OP XOR BIT-ARRAY1 BIT-ARRAY2 BIT-RESULT)) (CL:DEFUN CL:CHAR (STRING INDEX) (CL:ASSERT (TYPEP STRING 'STRING) (STRING) "Not a string: ~S" STRING) (CL:AREF STRING INDEX)) (CL:DEFUN CL:ARRAYP (ARRAY) (%ARRAYP ARRAY)) (CL:DEFUN CL:STRINGP (STRING) (%STRINGP STRING)) (CL:DEFUN COPY-ARRAY (FROM-ARRAY &OPTIONAL TO-ARRAY) (CL:IF (NOT (%ARRAYP FROM-ARRAY)) (CL:ERROR "Not an array: ~S" FROM-ARRAY)) (COND ((NULL TO-ARRAY) (SETQ TO-ARRAY (CL:MAKE-ARRAY (CL:ARRAY-DIMENSIONS FROM-ARRAY) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE FROM-ARRAY) :FATP (%FAT-STRING-ARRAY-P FROM-ARRAY)))) ((NOT (EQUAL-DIMENSIONS-P FROM-ARRAY TO-ARRAY)) (CL:ERROR "Dimensionality mismatch"))) (CL:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| TO-ARRAY) (%MAKE-ARRAY-WRITEABLE TO-ARRAY)) (LET ((FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER FROM-ARRAY)) (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-ARRAY))) (CL:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER) (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER)) (%MAKE-STRING-ARRAY-FAT TO-ARRAY) (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-ARRAY))) (%FAST-COPY-BASE (%ARRAY-BASE FROM-ARRAY) (%ARRAY-OFFSET FROM-ARRAY) FROM-TYPE-NUMBER (%ARRAY-BASE TO-ARRAY) (%ARRAY-OFFSET TO-ARRAY) TO-TYPE-NUMBER (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| FROM-ARRAY)) TO-ARRAY)) (CL:DEFUN COPY-VECTOR (FROM-VECTOR TO-VECTOR &KEY (START1 0) END1 (START2 0) END2) (LET ((FROM-LENGTH (VECTOR-LENGTH FROM-VECTOR)) (TO-LENGTH (VECTOR-LENGTH TO-VECTOR))) (CL:IF (NULL END1) (SETQ END1 FROM-LENGTH)) (CL:IF (NULL END2) (SETQ END2 TO-LENGTH)) (CL:IF (NOT (<= 0 START1 END1 FROM-LENGTH)) (CL:ERROR "Bad subsequence for FROM-VECTOR")) (CL:IF (NOT (<= 0 START2 END2 TO-LENGTH)) (CL:ERROR "Bad subsequence for TO-VECTOR")) (CL:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| TO-VECTOR) (%MAKE-ARRAY-WRITEABLE TO-VECTOR)) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2)) (FROM-TYPE-NUMBER (%ARRAY-TYPE-NUMBER FROM-VECTOR)) (TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-VECTOR))) (CL:WHEN (AND (%FAT-CHAR-TYPE-P FROM-TYPE-NUMBER) (%THIN-CHAR-TYPE-P TO-TYPE-NUMBER)) (%MAKE-STRING-ARRAY-FAT TO-VECTOR) (SETQ TO-TYPE-NUMBER (%ARRAY-TYPE-NUMBER TO-VECTOR))) (%FAST-COPY-BASE (%ARRAY-BASE FROM-VECTOR) (+ START1 (%ARRAY-OFFSET FROM-VECTOR)) FROM-TYPE-NUMBER (%ARRAY-BASE TO-VECTOR) (+ START2 (%ARRAY-OFFSET TO-VECTOR)) TO-TYPE-NUMBER (MIN SUBLEN1 SUBLEN2)) TO-VECTOR))) (CL:DEFUN DISPLACED-ARRAY-P (ARRAY) (CL:IF (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER DISPLACED-P) |of| ARRAY) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN EQUAL-DIMENSIONS-P (ARRAY-1 ARRAY-2) (COND ((%ONED-ARRAY-P ARRAY-1) (COND ((%ONED-ARRAY-P ARRAY-2) (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2))) ((%TWOD-ARRAY-P ARRAY-2) NIL) ((%GENERAL-ARRAY-P ARRAY-2) (AND (EQ 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2))) (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2)))) (T NIL))) ((%TWOD-ARRAY-P ARRAY-1) (COND ((%ONED-ARRAY-P ARRAY-2) NIL) ((%TWOD-ARRAY-P ARRAY-2) (AND (EQ (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-1) (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-2)) (EQ (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-1) (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-2)))) ((%GENERAL-ARRAY-P ARRAY-2) (LET ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2))) (AND (EQ 2 (LENGTH DIMS)) (AND (EQ (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-1) (CAR DIMS)) (EQ (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-1) (CADR DIMS)))))) (T NIL))) ((%GENERAL-ARRAY-P ARRAY-1) (LET ((DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-1))) (COND ((%ONED-ARRAY-P ARRAY-2) (AND (EQ 1 (LENGTH DIMS)) (EQ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-1) (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY-2)))) ((%TWOD-ARRAY-P ARRAY-2) (AND (EQ 2 (LENGTH DIMS)) (AND (EQ (CAR DIMS) (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY-2)) (EQ (CADR DIMS) (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY-2))))) ((%GENERAL-ARRAY-P ARRAY-2) (EQUAL DIMS (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY-2))) (T NIL)))) (T NIL))) (CL:DEFUN EXTENDABLE-ARRAY-P (ARRAY) (* *) (COND ((%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| ARRAY)) ((STRINGP ARRAY) NIL) (T (CL:ERROR "Not an array ~S" ARRAY)))) (CL:DEFUN FILL-ARRAY (ARRAY VALUE) (CL:IF (NOT (%ARRAYP ARRAY)) (CL:ERROR "Not an array: ~S" ARRAY)) (LET ((TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)) (TYPE-NUMBER (%ARRAY-TYPE-NUMBER ARRAY))) (CL:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ARRAY) (%MAKE-ARRAY-WRITEABLE ARRAY)) (CL:WHEN (> TOTAL-SIZE 0) (CL:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER) (%FAT-STRING-CHAR-P VALUE)) (%MAKE-STRING-ARRAY-FAT ARRAY) (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER ARRAY))) (CL:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE)) (CL:ERROR "Value of incorrect type for this array: ~S" VALUE)) (LET ((BASE (%ARRAY-BASE ARRAY)) (OFFSET (%ARRAY-OFFSET ARRAY))) (* \; "Start things off") (%ARRAY-WRITE VALUE BASE TYPE-NUMBER OFFSET) (* \; "An overlapping blt") (%FAST-COPY-BASE BASE OFFSET TYPE-NUMBER BASE (CL:1+ OFFSET) TYPE-NUMBER (CL:1- TOTAL-SIZE)))) ARRAY)) (CL:DEFUN CL:FILL-POINTER (VECTOR) (COND ((AND (OR (%ONED-ARRAY-P VECTOR) (%GENERAL-ARRAY-P VECTOR)) (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR)) (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR)) ((%VECTORP VECTOR) (CL:ERROR "vector has no fill pointer")) (T (CL:ERROR "Not a vector: ~S" VECTOR)))) (CL:DEFUN FILL-VECTOR (VECTOR VALUE &KEY (START 0) END) (CL:IF (NOT (%VECTORP VECTOR)) (CL:ERROR "Not a vector: ~S" VECTOR)) (LET ((TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR))) (CL:IF (NULL END) (SETQ END TOTAL-SIZE)) (CL:IF (NOT (<= START END TOTAL-SIZE)) (CL:ERROR "Invalid subsequence" END)) (LET ((CNT (- END START)) (TYPE-NUMBER (%ARRAY-TYPE-NUMBER VECTOR))) (CL:IF (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| VECTOR) (%MAKE-ARRAY-WRITEABLE VECTOR)) (CL:WHEN (> CNT 0) (CL:WHEN (AND (%THIN-CHAR-TYPE-P TYPE-NUMBER) (%FAT-STRING-CHAR-P VALUE)) (%MAKE-STRING-ARRAY-FAT VECTOR) (SETQ TYPE-NUMBER (%ARRAY-TYPE-NUMBER VECTOR))) (CL:IF (NOT (%LLARRAY-TYPEP TYPE-NUMBER VALUE)) (CL:ERROR "Value of incorrect type for this array: ~S" VALUE)) (LET ((BASE (%ARRAY-BASE VECTOR)) (OFFSET (+ START (%ARRAY-OFFSET VECTOR)))) (* \; "Start things off") (%ARRAY-WRITE VALUE BASE TYPE-NUMBER OFFSET) (* \; "An overlapping blt") (%FAST-COPY-BASE BASE OFFSET TYPE-NUMBER BASE (CL:1+ OFFSET) TYPE-NUMBER (CL:1- CNT)))) VECTOR))) (CL:DEFUN CL:MAKE-ARRAY (DIMENSIONS &KEY (ELEMENT-TYPE T) (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P) (INITIAL-CONTENTS NIL INITIAL-CONTENTS-P) (DISPLACED-TO NIL DISPLACED-TO-P) (DISPLACED-TO-BASE NIL DISPLACED-TO-BASE-P) (DISPLACED-INDEX-OFFSET 0 DISPLACED-INDEX-OFFSET-P) FILL-POINTER ADJUSTABLE EXTENDABLE FATP READ-ONLY-P) (* |;;| "String are by default thin unless FATP is T. DISPLACED-TO-BASE indicates displacement to a raw storage block. READ-ONLY-P indicates a read only array") (CL:IF (NOT (CL:LISTP DIMENSIONS)) (SETQ DIMENSIONS (LIST DIMENSIONS))) (CL:IF (CL:DOLIST (DIM DIMENSIONS NIL) (CL:IF (OR (< DIM 0) (>= DIM CL:ARRAY-DIMENSION-LIMIT)) (RETURN T))) (CL:ERROR "Dimensions out of bounds: ~S" DIMENSIONS)) (LET ((RANK (LENGTH DIMENSIONS)) (NELTS (%TOTAL-SIZE DIMENSIONS)) ARRAY) (* |;;| "Consistency checks") (CL:IF (>= RANK CL:ARRAY-RANK-LIMIT) (CL:ERROR "Too many dimensions: ~A" RANK)) (CL:IF (>= NELTS CL:ARRAY-TOTAL-SIZE-LIMIT) (CL:ERROR "Too many elements: ~A" NELTS)) (CL:IF (OR (AND DISPLACED-TO-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-BASE-P)) (AND DISPLACED-TO-BASE-P (OR INITIAL-ELEMENT-P INITIAL-CONTENTS-P DISPLACED-TO-P)) (AND FILL-POINTER (NOT (EQ RANK 1))) (AND DISPLACED-INDEX-OFFSET-P (NOT (OR DISPLACED-TO-P DISPLACED-TO-BASE-P))) (AND INITIAL-ELEMENT-P INITIAL-CONTENTS-P) (AND ADJUSTABLE EXTENDABLE) (AND READ-ONLY-P (OR EXTENDABLE ADJUSTABLE))) (CL:ERROR "Inconsistent options to make-array")) (CL:IF DISPLACED-TO-P (COND ((NOT (%ARRAYP DISPLACED-TO)) (CL:ERROR "Not displaced to an array: ~s" DISPLACED-TO)) ((NOT (EQUAL (%GET-CANONICAL-CML-TYPE ELEMENT-TYPE) (CL:ARRAY-ELEMENT-TYPE DISPLACED-TO))) (CL:ERROR "Not displaced to an array of the same element-type")) ((> (+ DISPLACED-INDEX-OFFSET NELTS) (CL:ARRAY-TOTAL-SIZE DISPLACED-TO)) (CL:ERROR "Displaced array out of bounds")))) (CL:IF FILL-POINTER (COND ((EQ FILL-POINTER T) (SETQ FILL-POINTER NELTS)) ((NOT (AND (>= FILL-POINTER 0) (<= FILL-POINTER NELTS))) (CL:ERROR "Fill pointer out of bounds ~A" FILL-POINTER)))) (* |;;| "Specs ready, make the array by case") (SETQ ARRAY (COND (DISPLACED-TO-P (%MAKE-DISPLACED-ARRAY NELTS DIMENSIONS ELEMENT-TYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER READ-ONLY-P ADJUSTABLE EXTENDABLE)) (DISPLACED-TO-BASE (CL:IF (OR (> RANK 1) ADJUSTABLE) (%MAKE-GENERAL-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P ADJUSTABLE EXTENDABLE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET) (%MAKE-ONED-ARRAY NELTS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P EXTENDABLE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET))) ((AND (EQ RANK 1) (NOT ADJUSTABLE)) (%MAKE-ONED-ARRAY NELTS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P EXTENDABLE)) ((AND (EQ RANK 2) (NOT ADJUSTABLE)) (%MAKE-TWOD-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P EXTENDABLE)) (T (%MAKE-GENERAL-ARRAY NELTS DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P ADJUSTABLE EXTENDABLE)))) (* |;;| "Initialize the storage") (COND (INITIAL-CONTENTS-P (%ARRAY-CONTENT-INITIALIZE ARRAY INITIAL-CONTENTS)) (INITIAL-ELEMENT-P (%ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-ELEMENT))) (* |;;| "Return the array") ARRAY)) (CL:DEFUN MAKE-VECTOR (SIZE &KEY (ELEMENT-TYPE T) (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P) FATP) (CL:IF (OR (< SIZE 0) (>= SIZE CL:ARRAY-TOTAL-SIZE-LIMIT)) (CL:ERROR "Size out of bounds: ~s" SIZE)) (LET ((VECTOR (%MAKE-ONED-ARRAY SIZE ELEMENT-TYPE NIL FATP))) (CL:IF INITIAL-ELEMENT-P (FILL-ARRAY VECTOR INITIAL-ELEMENT)) VECTOR)) (CL:DEFUN READ-ONLY-ARRAY-P (ARRAY) (CL:IF (%ARRAYP ARRAY) (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ARRAY) (CL:ERROR "Not an array: ~S" ARRAY))) (CL:DEFUN CL:SBIT (SIMPLE-BIT-ARRAY &REST INDICES) (CL:ASSERT (TYPEP SIMPLE-BIT-ARRAY '(CL:SIMPLE-ARRAY BIT)) (SIMPLE-BIT-ARRAY) "Not a bit-array: ~S" SIMPLE-BIT-ARRAY) (CL:APPLY #'CL:AREF SIMPLE-BIT-ARRAY INDICES)) (CL:DEFUN CL:SCHAR (SIMPLE-STRING INDEX) (CL:ASSERT (TYPEP SIMPLE-STRING 'CL:SIMPLE-STRING) (SIMPLE-STRING) "Not a simple-string: ~S" SIMPLE-STRING) (CL:AREF SIMPLE-STRING INDEX)) (CL:DEFUN SET-FILL-POINTER (VECTOR NEWVALUE) (COND ((AND (OR (%ONED-ARRAY-P VECTOR) (%GENERAL-ARRAY-P VECTOR)) (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR)) (CL:IF (NOT (<= 0 NEWVALUE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR))) (CL:ERROR "Fill pointer out of bounds: ~S" NEWVALUE)) (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| NEWVALUE) NEWVALUE) ((%VECTORP VECTOR) (CL:ERROR "Vector has no fill pointer")) (T (CL:ERROR "Not a vector: ~S" VECTOR)))) (CL:DEFUN SIMPLE-ARRAY-P (ARRAY) (%SIMPLE-ARRAY-P ARRAY)) (CL:DEFUN CL:SIMPLE-BIT-VECTOR-P (VECTOR) (AND (%ONED-ARRAY-P VECTOR) (|fetch| (ARRAY-HEADER SIMPLE-P) |of| VECTOR) (|fetch| (ARRAY-HEADER BIT-P) |of| VECTOR))) (CL:DEFUN CL:SIMPLE-STRING-P (STRING) (%SIMPLE-STRING-P STRING)) (CL:DEFUN CL:SIMPLE-VECTOR-P (VECTOR) (AND (%ONED-ARRAY-P VECTOR) (|fetch| (ARRAY-HEADER SIMPLE-P) |of| VECTOR) (EQ (CL:ARRAY-ELEMENT-TYPE VECTOR) T))) (CL:DEFUN STRING-ARRAY-P (ARRAY) (%CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY))) (CL:DEFUN CL:SVREF (CL:SIMPLE-VECTOR INDEX) (CL:ASSERT (TYPEP CL:SIMPLE-VECTOR 'CL:SIMPLE-VECTOR) (CL:SIMPLE-VECTOR) "Not a simple-vector: ~S" CL:SIMPLE-VECTOR) (CL:AREF CL:SIMPLE-VECTOR INDEX)) (CL:DEFUN VECTOR-LENGTH (VECTOR) (CL:IF (%VECTORP VECTOR) (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR) (CL:ERROR "Not a vector: ~s" VECTOR))) (CL:DEFUN CL:VECTOR-POP (VECTOR) (COND ((AND (OR (%ONED-ARRAY-P VECTOR) (%GENERAL-ARRAY-P VECTOR)) (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR)) (LET ((FILL-POINTER (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR))) (CL:IF (<= FILL-POINTER 0) (CL:ERROR "Can't pop from zero fill pointer")) (SETQ FILL-POINTER (CL:1- FILL-POINTER)) (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| FILL-POINTER) (CL:AREF VECTOR FILL-POINTER))) ((%VECTORP VECTOR) (CL:ERROR "Vector has no fill pointer")) (T (CL:ERROR "Not a vector: ~S" VECTOR)))) (CL:DEFUN CL:VECTOR-PUSH (NEW-ELEMENT VECTOR) (COND ((AND (OR (%ONED-ARRAY-P VECTOR) (%GENERAL-ARRAY-P VECTOR)) (|fetch| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR)) (LET ((FILL-POINTER (|fetch| (ARRAY-HEADER FILL-POINTER) |of| VECTOR))) (CL:WHEN (< FILL-POINTER (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR)) (ASET NEW-ELEMENT VECTOR FILL-POINTER) (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| (CL:1+ FILL-POINTER )) FILL-POINTER))) ((%VECTORP VECTOR) (CL:ERROR "Vector has no fill pointer")) (T (CL:ERROR "Not a vector: ~S" VECTOR)))) (CL:DEFUN CL:VECTOR-PUSH-EXTEND (NEW-ELEMENT VECTOR &OPTIONAL (EXTENSION-SIZE *DEFAULT-PUSH-EXTENSION-SIZE* )) (* |;;| "Like VECTOR-PUSH except if VECTOR is adjustable -- in which case a push beyond (array-total-size VECTOR ) will call adjust-array") (LET ((NEW-INDEX (CL:VECTOR-PUSH NEW-ELEMENT VECTOR))) (CL:IF (NULL NEW-INDEX) (COND ((> EXTENSION-SIZE 0) (CL:ADJUST-ARRAY VECTOR (+ (CL:ARRAY-TOTAL-SIZE VECTOR) EXTENSION-SIZE)) (CL:VECTOR-PUSH NEW-ELEMENT VECTOR)) (T (CL:ERROR "Extension-size not greater than zero"))) NEW-INDEX))) (CL:DEFUN CL:VECTORP (VECTOR) (%VECTORP VECTOR)) (DEFINEQ (CL:AREF (LAMBDA ARGS (* \; "Edited 11-Dec-87 15:32 by jop") (CL:IF (< ARGS 1) (CL:ERROR "Aref takes at least one arg")) (LET ((ARRAY (ARG ARGS 1))) (CASE ARGS (1 (%AREF0 ARRAY)) (2 (%AREF1 ARRAY (ARG ARGS 2))) (3 (%AREF2 ARRAY (ARG ARGS 2) (ARG ARGS 3))) (T (COND ((NOT (EQ (CL:ARRAY-RANK ARRAY) (CL:1- ARGS))) (CL:ERROR "Rank mismatch")) (T (* |;;| "If we've gotten this far ARRAY must be a general array") (* \; "Check indices in bounds") (CL:DO ((I 2 (CL:1+ I)) (DIMLIST (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY) (CDR DIMLIST)) INDEX) ((> I ARGS)) (SETQ INDEX (ARG ARGS I)) (CL:IF (NOT (< -1 INDEX (CAR DIMLIST))) (CL:ERROR "Index out of bounds: ~s" INDEX))) (* \;  "Now proceed to extract the element") (LET ((ROW-MAJOR-INDEX (CL:DO ((I 2 (CL:1+ I)) (DIMLIST (CDR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)) (CDR DIMLIST)) (TOTAL 0)) ((EQ I ARGS) (+ TOTAL (ARG ARGS ARGS))) (SETQ TOTAL (CL:* (CAR DIMLIST) (+ TOTAL (ARG ARGS I)))))) (BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY) (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX)))))))))) (CL:ARRAY-IN-BOUNDS-P (LAMBDA ARGS (* \; "Edited 11-Dec-87 15:32 by jop") (CL:IF (< ARGS 1) (CL:ERROR "Array-in-bounds-p takes at least one arg")) (LET ((ARRAY (ARG ARGS 1))) (CL:IF (EQ (CL:ARRAY-RANK ARRAY) (CL:1- ARGS)) (%CHECK-INDICES ARRAY 2 ARGS) (CL:ERROR "Rank mismatch"))))) (CL:ARRAY-ROW-MAJOR-INDEX (LAMBDA ARGS (* \; "Edited 11-Dec-87 15:32 by jop") (CL:IF (< ARGS 1) (CL:ERROR "Array-row-major-index takes at least one arg")) (LET ((ARRAY (ARG ARGS 1))) (COND ((NOT (EQ (CL:ARRAY-RANK ARRAY) (CL:1- ARGS))) (CL:ERROR "Rank mismatch")) ((NOT (%CHECK-INDICES ARRAY 2 ARGS)) (CL:ERROR "Index out of bounds")) (T (CL:DO ((I 2 (CL:1+ I)) (TOTAL 0)) ((EQ I ARGS) (+ TOTAL (ARG ARGS ARGS))) (SETQ TOTAL (CL:* (CL:ARRAY-DIMENSION ARRAY (CL:1- I)) (+ TOTAL (ARG ARGS I)))))))))) (ASET (LAMBDA ARGS (* \; "Edited 11-Dec-87 15:33 by jop") (CL:IF (< ARGS 2) (CL:ERROR "Aset takes at least two args")) (LET ((NEWVALUE (ARG ARGS 1)) (ARRAY (ARG ARGS 2))) (CASE ARGS (2 (%ASET0 NEWVALUE ARRAY)) (3 (%ASET1 NEWVALUE ARRAY (ARG ARGS 3))) (4 (%ASET2 NEWVALUE ARRAY (ARG ARGS 3) (ARG ARGS 4))) (T (COND ((NOT (EQ (CL:ARRAY-RANK ARRAY) (- ARGS 2))) (CL:ERROR "Rank mismatch")) (T (* \;  "If we've gotten this far array must be a general array") (* |;;| "Check indices") (CL:DO ((I 3 (CL:1+ I)) (DIMLIST (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY) (CDR DIMLIST)) INDEX) ((> I ARGS)) (SETQ INDEX (ARG ARGS I)) (CL:IF (NOT (< -1 INDEX (CAR DIMLIST))) (CL:ERROR "Index out of bounds: ~s" INDEX))) (* |;;| "Now proceed to extract the element") (LET ((ROW-MAJOR-INDEX (CL:DO ((I 3 (CL:1+ I)) (DIMLIST (CDR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY)) (CDR DIMLIST)) (TOTAL 0)) ((EQ I ARGS) (+ TOTAL (ARG ARGS ARGS))) (SETQ TOTAL (CL:* (CAR DIMLIST) (+ TOTAL (ARG ARGS I)))))) (BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY ))) (CL:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE) (CL:APPLY 'ASET NEWVALUE ARRAY (CL:DO ((I ARGS (CL:1- I)) LST) ((< I 1) LST) (SETQ LST (CONS (ARG ARGS I) LST)))) (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) TYPE-NUMBER (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX)))))))))))) (CL:VECTOR (LAMBDA ARGS (* \; "Edited 18-Dec-86 18:09 by jop") (LET ((VECTOR (%MAKE-ONED-ARRAY ARGS T))) (CL:DOTIMES (I ARGS) (ASET (ARG ARGS (CL:1+ I)) VECTOR I)) VECTOR))) ) (* |;;| "New CLtL array functions") (DEFINEQ (XCL:ROW-MAJOR-AREF (LAMBDA (ARRAY INDEX) (* \; "Edited 11-Dec-87 15:49 by jop") (* |;;| "specialized aref for the one-d case. Also the punt function for the aref1 opcode.") (CL:IF (NOT (AND (>= INDEX 0) (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)))) (CL:ERROR "Index out of bounds: ~A" INDEX) (LET ((BASE-ARRAY ARRAY)) (* |;;| "Now proceed to extract the element") (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX) (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY) (+ (%GET-ARRAY-OFFSET BASE-ARRAY) INDEX)))))) (CL::ROW-MAJOR-ASET (LAMBDA (ARRAY INDEX NEWVALUE) (* \; "Edited 11-Dec-87 15:54 by jop") (CL:IF (NOT (AND (>= INDEX 0) (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)))) (CL:ERROR "Index out of bounds: ~s" INDEX) (LET ((ROW-MAJOR-INDEX INDEX) (BASE-ARRAY ARRAY)) (* |;;| "Now proceed to extract the element") (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY))) (CL:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE) (CL::ROW-MAJOR-ASET ARRAY INDEX NEWVALUE) (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY ) TYPE-NUMBER (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX)))))))) ) (CL:DEFSETF XCL:ROW-MAJOR-AREF CL::ROW-MAJOR-ASET) (* |;;| "Setfs") (CL:DEFSETF CL:AREF (ARRAY &REST INDICES) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,@INDICES)) (CL:DEFSETF BIT (ARRAY &REST INDICES) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,@INDICES)) (CL:DEFSETF CL:CHAR (ARRAY INDEX) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,INDEX)) (CL:DEFSETF CL:FILL-POINTER SET-FILL-POINTER) (CL:DEFSETF CL:SBIT (ARRAY &REST INDICES) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,@INDICES)) (CL:DEFSETF CL:SCHAR (ARRAY INDEX) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,INDEX)) (CL:DEFSETF CL:SVREF (ARRAY INDEX) (NEWVALUE) `(ASET ,NEWVALUE ,ARRAY ,INDEX)) (* |;;| "Optimizers") (CL:DEFUN %AREF-EXPANDER (ARRAY INDICES) (CASE (LENGTH INDICES) (1 `(%AREF1 ,ARRAY ,@INDICES)) (2 `(%AREF2 ,ARRAY ,@INDICES)) (T 'COMPILER:PASS))) (CL:DEFUN %ASET-EXPANDER (NEWVALUE ARRAY INDICES) (CASE (LENGTH INDICES) (1 `(%ASET1 ,NEWVALUE ,ARRAY ,@INDICES)) (2 `(%ASET2 ,NEWVALUE ,ARRAY ,@INDICES)) (T 'COMPILER:PASS))) (DEFOPTIMIZER CL:AREF (ARRAY &REST INDICES) (%AREF-EXPANDER ARRAY INDICES)) (DEFOPTIMIZER ASET (NEWVALUE ARRAY &REST INDICES) (%ASET-EXPANDER NEWVALUE ARRAY INDICES)) (DEFOPTIMIZER BIT (ARRAY &REST INDICES) (%AREF-EXPANDER ARRAY INDICES)) (DEFOPTIMIZER CL:CHAR (STRING INDEX) `(%AREF1 ,STRING ,INDEX)) (DEFOPTIMIZER CL:SBIT (ARRAY &REST INDICES) (%AREF-EXPANDER ARRAY INDICES)) (DEFOPTIMIZER CL:SCHAR (STRING INDEX) `(%AREF1 ,STRING ,INDEX)) (DEFOPTIMIZER CL:SVREF (CL:SIMPLE-VECTOR INDEX) `(%AREF1 ,CL:SIMPLE-VECTOR ,INDEX)) (* |;;| "Vars etc") (* \; "*PRINT-ARRAY* is defined in APRINT") (CL:DEFCONSTANT CL:ARRAY-RANK-LIMIT (EXPT 2 7)) (CL:DEFCONSTANT CL:ARRAY-TOTAL-SIZE-LIMIT 65534) (CL:DEFCONSTANT CL:ARRAY-DIMENSION-LIMIT CL:ARRAY-TOTAL-SIZE-LIMIT) (CL:DEFPARAMETER *DEFAULT-PUSH-EXTENSION-SIZE* 20) (* |;;| "Run-time support") (DEFINEQ (%ALTER-AS-DISPLACED-ARRAY (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER) (* \; "Edited 18-Dec-86 17:11 by jop") (* |;;|  "Alter ADJUSTABLE-ARRAY to be displaced to displaced-to. ADJUSTABLE-ARRAY must be a general array") (CL:IF (NULL DISPLACED-INDEX-OFFSET) (SETQ DISPLACED-INDEX-OFFSET 0)) (LET ((DISPLACED-TO-READ-ONLY-P (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DISPLACED-TO)) (TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS)) (OFFSET (OR DISPLACED-INDEX-OFFSET 0)) BASE NEED-INDIRECTION-P) (COND ((OR (%THIN-CHAR-TYPE-P (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| DISPLACED-TO)) (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| DISPLACED-TO) (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| DISPLACED-TO) (AND DISPLACED-TO-READ-ONLY-P (NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO)))) (* \; "Provide for indirection") (SETQ BASE DISPLACED-TO) (SETQ NEED-INDIRECTION-P T)) (T (* \;  "Fold double displacement to single displacement") (SETQ BASE (|fetch| (ARRAY-HEADER BASE) |of| DISPLACED-TO)) (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO))) (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO) (SETQ NEED-INDIRECTION-P T)))) (* \;  "Don't need to touch the type-number since it can't change") (UNINTERRUPTABLY (|freplace| (GENERAL-ARRAY STORAGE) |of| ADJUSTABLE-ARRAY |with| BASE) (|freplace| (GENERAL-ARRAY READ-ONLY-P) |of| ADJUSTABLE-ARRAY |with| DISPLACED-TO-READ-ONLY-P ) (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| ADJUSTABLE-ARRAY |with| NEED-INDIRECTION-P ) (|freplace| (GENERAL-ARRAY DISPLACED-P) |of| ADJUSTABLE-ARRAY |with| T) (|freplace| (GENERAL-ARRAY FILL-POINTER-P) |of| ADJUSTABLE-ARRAY |with| FILL-POINTER) (|freplace| (GENERAL-ARRAY OFFSET) |of| ADJUSTABLE-ARRAY |with| OFFSET) (|freplace| (GENERAL-ARRAY FILL-POINTER) |of| ADJUSTABLE-ARRAY |with| (OR FILL-POINTER TOTAL-SIZE)) (|freplace| (GENERAL-ARRAY TOTAL-SIZE) |of| ADJUSTABLE-ARRAY |with| TOTAL-SIZE) (|freplace| (GENERAL-ARRAY DIMS) |of| ADJUSTABLE-ARRAY |with| DIMENSIONS)) ADJUSTABLE-ARRAY))) (%ALTER-AS-DISPLACED-TO-BASE-ARRAY (LAMBDA (ADJUSTABLE-ARRAY DIMENSIONS ELEMENT-TYPE DISPLACED-TO-BASE DISPLACED-INDEX-OFFSET FILL-POINTER FATP) (* \; "Edited 18-Dec-86 17:12 by jop") (* |;;| "Alter adjustable-array to be displaced to displaced-to-base ") (LET ((TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS)) (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP))) (UNINTERRUPTABLY (|freplace| (GENERAL-ARRAY STORAGE) |of| ADJUSTABLE-ARRAY |with| DISPLACED-TO-BASE ) (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| ADJUSTABLE-ARRAY |with| NIL) (|freplace| (GENERAL-ARRAY DISPLACED-P) |of| ADJUSTABLE-ARRAY |with| T) (|freplace| (GENERAL-ARRAY FILL-POINTER-P) |of| ADJUSTABLE-ARRAY |with| FILL-POINTER) (|freplace| (GENERAL-ARRAY TYPE-NUMBER) |of| ADJUSTABLE-ARRAY |with| TYPE-NUMBER) (|freplace| (GENERAL-ARRAY OFFSET) |of| ADJUSTABLE-ARRAY |with| (OR DISPLACED-INDEX-OFFSET 0)) (|freplace| (GENERAL-ARRAY FILL-POINTER) |of| ADJUSTABLE-ARRAY |with| (OR FILL-POINTER TOTAL-SIZE)) (|freplace| (GENERAL-ARRAY TOTAL-SIZE) |of| ADJUSTABLE-ARRAY |with| TOTAL-SIZE) (|freplace| (GENERAL-ARRAY DIMS) |of| ADJUSTABLE-ARRAY |with| DIMENSIONS)) ADJUSTABLE-ARRAY))) (%AREF0 (LAMBDA (ARRAY) (* \; "Edited 11-Dec-87 15:33 by jop") (* |;;| "Special aref for the zero dimensional case") (CL:IF (EQ (CL:ARRAY-RANK ARRAY) 0) (LET ((INDEX 0) (BASE-ARRAY ARRAY)) (* |;;| "Must be a general array") (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX) (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY) (+ (%GET-ARRAY-OFFSET BASE-ARRAY) INDEX))) (CL:ERROR "Rank mismatch")))) (%AREF1 (LAMBDA (ARRAY INDEX) (* \; "Edited 11-Dec-87 15:50 by jop") (* |;;| "specialized aref for the one-d case. Also the punt function for the aref1 opcode.") (COND ((NOT (EQ (CL:ARRAY-RANK ARRAY) 1)) (CL:ERROR "Rank mismatch")) ((NOT (AND (>= INDEX 0) (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)))) (CL:ERROR "Index out of bounds: ~A" INDEX)) (T (* |;;| "Now proceed to extract the element") (LET ((BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX) (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY) (+ (%GET-ARRAY-OFFSET BASE-ARRAY) INDEX))))))) (%AREF2 (LAMBDA (ARRAY I J) (* \; "Edited 11-Dec-87 15:33 by jop") (* |;;| "Specialized aref for the two-d case. Also the punt function for the aref 2 opcode.") (CL:IF (EQ (CL:ARRAY-RANK ARRAY) 2) (LET (BOUND0 BOUND1 OFFSET) (* \;  " ARRAY must be two-d or general") (* |;;| "Get bounds and offset") (COND ((%TWOD-ARRAY-P ARRAY) (* \; "Twod array case") (SETQ BOUND0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY)) (SETQ BOUND1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY)) (SETQ OFFSET 0)) (T (* \; "General array case") (SETQ BOUND0 (CAR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))) (SETQ BOUND1 (CADR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))) (SETQ OFFSET (|ffetch| (GENERAL-ARRAY OFFSET) |of| ARRAY)))) (* \; "Check indices") (COND ((NOT (< -1 I BOUND0)) (CL:ERROR "Index out of bounds: ~A" I)) ((NOT (< -1 J BOUND1)) (CL:ERROR "Index out of bounds: ~A" J))) (* \; "Extract the element") (LET ((ROW-MAJOR-INDEX (+ J (CL:* BOUND1 I))) (BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (%ARRAY-READ (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY) (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX)))) (CL:ERROR "Rank mismatch")))) (%ARRAY-BASE (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:20 by jop") (COND ((OR (%ONED-ARRAY-P ARRAY) (%TWOD-ARRAY-P ARRAY)) (|fetch| (ARRAY-HEADER BASE) |of| ARRAY)) ((%GENERAL-ARRAY-P ARRAY) (|fetch| (ARRAY-HEADER BASE) |of| (CL:LOOP (CL:IF (NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)) (RETURN ARRAY)) (SETQ ARRAY (|fetch| (ARRAY-HEADER BASE) |of| ARRAY))))) (T (CL:ERROR "Not an array: ~S" ARRAY))))) (%ARRAY-CONTENT-INITIALIZE (LAMBDA (ARRAY INITIAL-CONTENTS) (* \; "Edited 11-Dec-87 15:33 by jop") (CL:IF (EQ 0 (CL:ARRAY-RANK ARRAY)) (%ARRAY-ELEMENT-INITIALIZE ARRAY INITIAL-CONTENTS) (LET ((DIMS (CL:ARRAY-DIMENSIONS ARRAY))) (CL:IF (%CHECK-SEQUENCE-DIMENSIONS DIMS INITIAL-CONTENTS) (%FILL-ARRAY-FROM-SEQUENCE DIMS INITIAL-CONTENTS (%FLATTEN-ARRAY ARRAY) 0) (CL:ERROR "Dimensionality mismatch for Initial-contents")))))) (%ARRAY-ELEMENT-INITIALIZE (LAMBDA (ARRAY INITIAL-ELEMENT) (* \; "Edited 11-Dec-87 15:33 by jop") (* |;;| "Initialize an array with a value") (CL:UNLESS (EQ INITIAL-ELEMENT (%TYPENUMBER-TO-DEFAULT-VALUE (%ARRAY-TYPE-NUMBER ARRAY))) (FILL-ARRAY ARRAY INITIAL-ELEMENT)))) (%ARRAY-OFFSET (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:22 by jop") (* |;;| "Get the true offset for ARRAY") (COND ((%ONED-ARRAY-P ARRAY) (|fetch| (ARRAY-HEADER OFFSET) |of| ARRAY)) ((%TWOD-ARRAY-P ARRAY) 0) ((%GENERAL-ARRAY-P ARRAY) (CL:DO ((OFFSET (|fetch| (ARRAY-HEADER OFFSET) |of| ARRAY) (+ OFFSET (%GET-ARRAY-OFFSET ARRAY)))) ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)) OFFSET) (SETQ ARRAY (|fetch| (ARRAY-HEADER BASE) |of| ARRAY)))) (T (CL:ERROR "Not an array: ~S" ARRAY))))) (%ARRAY-TYPE-NUMBER (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:23 by jop") (* |;;| "Get the true array-typenumber for ARRAY") (COND ((OR (%ONED-ARRAY-P ARRAY) (%TWOD-ARRAY-P ARRAY)) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| ARRAY)) ((%GENERAL-ARRAY-P ARRAY) (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| (CL:LOOP (CL:IF (NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY)) (RETURN ARRAY)) (SETQ ARRAY (|fetch| ( ARRAY-HEADER BASE) |of| ARRAY))))) (T (CL:ERROR "Not an array: ~S" ARRAY))))) (%ASET0 (LAMBDA (NEWVALUE ARRAY) (* \; "Edited 11-Dec-87 15:33 by jop") (* |;;| "Specialized aset for the zero-d case.") (CL:IF (EQ (CL:ARRAY-RANK ARRAY) 0) (LET ((INDEX 0) (BASE-ARRAY ARRAY)) (* |;;| "Must be a general array") (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY INDEX) (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY))) (CL:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE) (%ASET0 NEWVALUE ARRAY) (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY ) TYPE-NUMBER (+ (%GET-ARRAY-OFFSET BASE-ARRAY) INDEX))))) (CL:ERROR "Rank mismatch")))) (%ASET1 (LAMBDA (NEWVALUE ARRAY INDEX) (* \; "Edited 11-Dec-87 15:34 by jop") (* |;;| "Specialized aset for the one-d case. Also the punt for the aset1 opcode.") (COND ((NOT (EQ (CL:ARRAY-RANK ARRAY) 1)) (CL:ERROR "Rank mismatch")) ((NOT (AND (>= INDEX 0) (< INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| ARRAY)))) (CL:ERROR "Index out of bounds: ~s" INDEX)) (T (* |;;| "Now proceed to extract the element") (LET ((ROW-MAJOR-INDEX INDEX) (BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY))) (CL:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE) (%ASET1 NEWVALUE ARRAY INDEX) (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) TYPE-NUMBER (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX))))))))) (%ASET2 (LAMBDA (NEWVALUE ARRAY I J) (* \; "Edited 11-Dec-87 15:34 by jop") (* |;;| "Specialized aset for the two-d case. Also the punt function for the aset2 opcode.") (CL:IF (EQ (CL:ARRAY-RANK ARRAY) 2) (LET (BOUND0 BOUND1 OFFSET) (* |;;| "Get bounds and offset") (COND ((%TWOD-ARRAY-P ARRAY) (* \; "Twod case") (SETQ BOUND0 (|ffetch| (TWOD-ARRAY BOUND0) |of| ARRAY)) (SETQ BOUND1 (|ffetch| (TWOD-ARRAY BOUND1) |of| ARRAY)) (SETQ OFFSET 0)) (T (* \; "General Case") (SETQ BOUND0 (CAR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))) (SETQ BOUND1 (CADR (|ffetch| (GENERAL-ARRAY DIMS) |of| ARRAY))) (SETQ OFFSET (|ffetch| (GENERAL-ARRAY OFFSET) |of| ARRAY)))) (* |;;| "Check indices") (COND ((NOT (< -1 I BOUND0)) (CL:ERROR "Index out of bounds ~s" I)) ((NOT (< -1 J BOUND1)) (CL:ERROR "Index out of bounds ~s" J))) (* |;;| "Set element") (LET ((ROW-MAJOR-INDEX (+ J (CL:* BOUND1 I))) (BASE-ARRAY ARRAY)) (%GENERAL-ARRAY-ADJUST-BASE BASE-ARRAY ROW-MAJOR-INDEX) (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY))) (CL:IF (%CHECK-NOT-WRITEABLE ARRAY TYPE-NUMBER NEWVALUE) (%ASET2 NEWVALUE ARRAY I J) (%ARRAY-WRITE NEWVALUE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) TYPE-NUMBER (+ (%GET-ARRAY-OFFSET BASE-ARRAY) ROW-MAJOR-INDEX)))))) (CL:ERROR "Rank mismatch")))) (%CHECK-SEQUENCE-DIMENSIONS (LAMBDA (DIM-LST SEQUENCE) (* \; "Edited 11-Dec-87 15:34 by jop") (* |;;| "Returns NIL if there is a mismatch") (CL:IF (EQ (CAR DIM-LST) (CL:LENGTH SEQUENCE)) (OR (NULL (CDR DIM-LST)) (CL:DOTIMES (I (CAR DIM-LST) T) (CL:IF (NOT (%CHECK-SEQUENCE-DIMENSIONS (CDR DIM-LST) (CL:ELT SEQUENCE I))) (RETURN NIL))))))) (%COPY-TO-NEW-ARRAY (LAMBDA (OLD-DIMS OLD-ARRAY OLD-OFFSET NEW-DIMS NEW-ARRAY NEW-OFFSET) (* \; "Edited 13-Feb-87 15:52 by jop") (* |;;| "It is assumed that OLD-ARRAY and NEW-ARRAY are of the same rank") (LET ((SIZE (MIN (CAR OLD-DIMS) (CAR NEW-DIMS)))) (CL:IF (CDR OLD-DIMS) (CL:DOTIMES (I SIZE) (%COPY-TO-NEW-ARRAY (CDR OLD-DIMS) OLD-ARRAY (CL:* (CADR OLD-DIMS) (+ OLD-OFFSET I)) (CDR NEW-DIMS) NEW-ARRAY (CL:* (CADR NEW-DIMS) (+ NEW-OFFSET I)))) (%FAST-COPY-BASE (%ARRAY-BASE OLD-ARRAY) (+ (%ARRAY-OFFSET OLD-ARRAY) OLD-OFFSET) (%ARRAY-TYPE-NUMBER OLD-ARRAY) (%ARRAY-BASE NEW-ARRAY) (+ (%ARRAY-OFFSET NEW-ARRAY) NEW-OFFSET) (%ARRAY-TYPE-NUMBER NEW-ARRAY) SIZE))))) (%DO-LOGICAL-OP (LAMBDA (OP SOURCE DEST) (* \; "Edited 18-Dec-86 17:43 by jop") (LET ((SOURCE-BASE (%ARRAY-BASE SOURCE)) (SOURCE-OFFSET (%ARRAY-OFFSET SOURCE)) (SOURCE-SIZE (CL:ARRAY-TOTAL-SIZE SOURCE)) (DEST-BASE (%ARRAY-BASE DEST)) (DEST-OFFSET (%ARRAY-OFFSET DEST)) (GBBT (DEFERREDCONSTANT (|create| PILOTBBT PBTHEIGHT _ 1 PBTDISJOINT _ T))) SOURCE-OP LOG-OP) (UNINTERRUPTABLY (|replace| (PILOTBBT PBTSOURCE) |of| GBBT |with| SOURCE-BASE) (|replace| (PILOTBBT PBTSOURCEBIT) |of| GBBT |with| SOURCE-OFFSET) (|replace| (PILOTBBT PBTDEST) |of| GBBT |with| DEST-BASE) (|replace| (PILOTBBT PBTDESTBIT) |of| GBBT |with| DEST-OFFSET) (|replace| (PILOTBBT PBTDESTBPL) |of| GBBT |with| SOURCE-SIZE) (|replace| (PILOTBBT PBTSOURCEBPL) |of| GBBT |with| SOURCE-SIZE) (|replace| (PILOTBBT PBTWIDTH) |of| GBBT |with| SOURCE-SIZE) (CASE OP (COPY (SETQ SOURCE-OP 0) (SETQ LOG-OP 0)) (NOT (SETQ SOURCE-OP 1) (SETQ LOG-OP 0)) (AND (SETQ SOURCE-OP 0) (SETQ LOG-OP 1)) (CAND (SETQ SOURCE-OP 1) (SETQ LOG-OP 1)) (OR (SETQ SOURCE-OP 0) (SETQ LOG-OP 2)) (COR (SETQ SOURCE-OP 1) (SETQ LOG-OP 2)) (XOR (SETQ SOURCE-OP 0) (SETQ LOG-OP 3)) (CXOR (SETQ SOURCE-OP 1) (SETQ LOG-OP 3))) (|replace| (PILOTBBT PBTSOURCETYPE) |of| GBBT |with| SOURCE-OP) (|replace| (PILOTBBT PBTOPERATION) |of| GBBT |with| LOG-OP) (* \; "Execute the BLT") (\\PILOTBITBLT GBBT 0) DEST)))) (%EXTEND-ARRAY (LAMBDA (EXTENDABLE-ARRAY NEW-ARRAY DIMENSIONS FILL-POINTER) (* \; "Edited 18-Dec-86 17:43 by jop") (* |;;| "Extend ADJUSTABLE-ARRAY, using the base provided by NEW-ARRAY ") (LET ((TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| NEW-ARRAY)) (TOTAL-SIZE (%TOTAL-SIZE DIMENSIONS)) (BASE (|fetch| (ARRAY-HEADER BASE) |of| NEW-ARRAY))) (UNINTERRUPTABLY (|replace| (ARRAY-HEADER BASE) |of| EXTENDABLE-ARRAY |with| BASE) (|replace| (ARRAY-HEADER READ-ONLY-P) |of| EXTENDABLE-ARRAY |with| NIL) (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| EXTENDABLE-ARRAY |with| TYPE-NUMBER) (|replace| (ARRAY-HEADER TOTAL-SIZE) |of| EXTENDABLE-ARRAY |with| TOTAL-SIZE ) (COND ((%TWOD-ARRAY-P EXTENDABLE-ARRAY) (|freplace| (TWOD-ARRAY BOUND0) |of| EXTENDABLE-ARRAY |with| (CAR DIMENSIONS)) (|freplace| (TWOD-ARRAY BOUND1) |of| EXTENDABLE-ARRAY |with| (CADR DIMENSIONS))) (T (* \; "must be oned or general") (|replace| (ARRAY-HEADER DISPLACED-P) |of| EXTENDABLE-ARRAY |with| NIL) (|replace| (ARRAY-HEADER FILL-POINTER-P) |of| EXTENDABLE-ARRAY |with| FILL-POINTER) (|replace| (ARRAY-HEADER OFFSET) |of| EXTENDABLE-ARRAY |with| 0) (|replace| (ARRAY-HEADER FILL-POINTER) |of| EXTENDABLE-ARRAY |with| (OR FILL-POINTER TOTAL-SIZE)) (CL:WHEN (%GENERAL-ARRAY-P EXTENDABLE-ARRAY) (|freplace| (GENERAL-ARRAY INDIRECT-P) |of| EXTENDABLE-ARRAY |with| NIL) (|freplace| (GENERAL-ARRAY DIMS) |of| EXTENDABLE-ARRAY |with| DIMENSIONS))))) EXTENDABLE-ARRAY))) (%FAST-COPY-BASE (LAMBDA (FROM-BASE FROM-OFFSET FROM-TYPENUMBER TO-BASE TO-OFFSET TO-TYPENUMBER CNT) (* \; "Edited 11-Dec-87 15:34 by jop") (* |;;| "Blts one array into another of the same element-type") (CL:IF (OR (NOT (EQ FROM-TYPENUMBER TO-TYPENUMBER)) (EQ (%TYPENUMBER-TO-GC-TYPE TO-TYPENUMBER) PTRBLOCK.GCT)) (CL:DO ((I FROM-OFFSET (CL:1+ I)) (LIMIT (+ FROM-OFFSET CNT)) (J TO-OFFSET (CL:1+ J))) ((EQ I LIMIT)) (%ARRAY-WRITE (%ARRAY-READ FROM-BASE FROM-TYPENUMBER I) TO-BASE TO-TYPENUMBER J)) (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TO-TYPENUMBER)) (PBBT (DEFERREDCONSTANT (|create| PILOTBBT PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 0)))) (* |;;| "Uses \\PILOTBITBLT instead of \\BLT because offsets might not be word aligned, and BITS-PER-ELEMENT may be greater than BITSPERWORD (16). ") (UNINTERRUPTABLY (|freplace| (PILOTBBT PBTSOURCE) |of| PBBT |with| FROM-BASE) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PBBT |with| (CL:* BITS-PER-ELEMENT FROM-OFFSET)) (|freplace| (PILOTBBT PBTDEST) |of| PBBT |with| TO-BASE) (|freplace| (PILOTBBT PBTDESTBIT) |of| PBBT |with| (CL:* BITS-PER-ELEMENT TO-OFFSET)) (|freplace| (PILOTBBT PBTDESTBPL) |of| PBBT |with| BITS-PER-ELEMENT) (|freplace| (PILOTBBT PBTSOURCEBPL) |of| PBBT |with| BITS-PER-ELEMENT) (|freplace| (PILOTBBT PBTWIDTH) |of| PBBT |with| BITS-PER-ELEMENT) (|freplace| (PILOTBBT PBTHEIGHT) |of| PBBT |with| CNT) (\\PILOTBITBLT PBBT 0)) NIL)))) (%FAT-STRING-ARRAY-P (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:44 by jop") (%FAT-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY)))) (%FILL-ARRAY-FROM-SEQUENCE (LAMBDA (DIMS SEQUENCE FLATTENED-ARRAY OFFSET) (* \; "Edited 11-Dec-87 15:34 by jop") (CL:IF (CDR DIMS) (CL:DOTIMES (I (CAR DIMS)) (%FILL-ARRAY-FROM-SEQUENCE (CDR DIMS) (CL:ELT SEQUENCE I) FLATTENED-ARRAY (CL:* (CADR DIMS) (+ OFFSET I)))) (CL:DO ((I 0 (CL:1+ I)) (J OFFSET (CL:1+ J)) (LIMIT (CAR DIMS))) ((EQ I LIMIT)) (ASET (CL:ELT SEQUENCE I) FLATTENED-ARRAY J))))) (%FLATTEN-ARRAY (LAMBDA (ARRAY) (* \; "Edited 11-Dec-87 15:34 by jop") (* |;;|  "Make a oned-array that shares storage with array. If array is already oned then return array") (CL:IF (EQ 1 (CL:ARRAY-RANK ARRAY)) ARRAY (CL:MAKE-ARRAY (CL:ARRAY-TOTAL-SIZE ARRAY) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ARRAY) :DISPLACED-TO ARRAY)))) (%MAKE-ARRAY-WRITEABLE (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 18:40 by jop") (CL:IF (NOT (%ARRAYP ARRAY)) (CL:ERROR "Not an array: ~S" ARRAY)) (LET ((BASE-ARRAY ARRAY) NEW-BASE OFFSET TOTAL-SIZE TYPE-NUMBER) (* |;;| "Find the base array") (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY) (CL:LOOP (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY) (SETQ BASE-ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)) (RETURN NIL)))) (CL:WHEN (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| BASE-ARRAY) (* |;;| "Allocate the new storage") (* \; "Be careful about offsets") (SETQ TOTAL-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| BASE-ARRAY)) (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY)) (SETQ TYPE-NUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)) (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE (+ TOTAL-SIZE OFFSET) TYPE-NUMBER)) (* |;;| "Initialize it") (%FAST-COPY-BASE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY) OFFSET TYPE-NUMBER NEW-BASE OFFSET TYPE-NUMBER TOTAL-SIZE) (* |;;| "Smash the new base into the array-header") (UNINTERRUPTABLY (|replace| (ARRAY-HEADER BASE) |of| BASE-ARRAY |with| NEW-BASE) (|replace| (ARRAY-HEADER READ-ONLY-P) |of| BASE-ARRAY |with| NIL))) (* |;;| "Declare the array (and all arrays on its access chain) readable") (UNINTERRUPTABLY (CL:DO ((NEXT-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE) |of| NEXT-ARRAY))) ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| NEXT-ARRAY))) (|replace| (ARRAY-HEADER READ-ONLY-P) |of| NEXT-ARRAY |with| NIL))) (* |;;| "return the original array") ARRAY))) (%MAKE-DISPLACED-ARRAY (LAMBDA (TOTALSIZE DIMENSIONS ELEMENT-TYPE DISPLACED-TO DISPLACED-INDEX-OFFSET FILL-POINTER READ-ONLY-P ADJUSTABLE EXTENDABLE) (* \; "Edited 18-Dec-86 17:48 by jop") (* |;;| "Make a displaced array") (LET ((DISPLACED-TO-TYPENUMBER (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| DISPLACED-TO)) (DISPLACE-TO-READ-ONLY-P (|fetch| (ARRAY-HEADER READ-ONLY-P) |of| DISPLACED-TO)) (OFFSET (OR DISPLACED-INDEX-OFFSET 0)) BASE NEED-INDIRECTION-P) (COND ((OR (%THIN-CHAR-TYPE-P DISPLACED-TO-TYPENUMBER) (|fetch| (ARRAY-HEADER EXTENDABLE-P) |of| DISPLACED-TO) (|fetch| (ARRAY-HEADER ADJUSTABLE-P) |of| DISPLACED-TO) (AND DISPLACE-TO-READ-ONLY-P (NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO)))) (* \; "Provide for indirection") (SETQ BASE DISPLACED-TO) (SETQ NEED-INDIRECTION-P T)) (T (* \;  "Fold double displacement to single displacement") (SETQ BASE (|fetch| (ARRAY-HEADER BASE) |of| DISPLACED-TO)) (SETQ OFFSET (+ OFFSET (%GET-ARRAY-OFFSET DISPLACED-TO))) (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| DISPLACED-TO) (SETQ NEED-INDIRECTION-P T)))) (COND ((OR NEED-INDIRECTION-P ADJUSTABLE (> (LENGTH DIMENSIONS) 1)) (* \;  "Indirect strings always have %FAT-CHAR-TYPENUMBER") (%MAKE-GENERAL-ARRAY TOTALSIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER (%CHAR-TYPE-P DISPLACED-TO-TYPENUMBER ) (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P) ADJUSTABLE EXTENDABLE BASE OFFSET)) (T (%MAKE-ONED-ARRAY TOTALSIZE ELEMENT-TYPE FILL-POINTER (%FAT-CHAR-TYPE-P DISPLACED-TO-TYPENUMBER ) (OR READ-ONLY-P DISPLACE-TO-READ-ONLY-P) EXTENDABLE BASE OFFSET)))))) (%MAKE-GENERAL-ARRAY (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P ADJUSTABLE-P EXTENDABLE-P DISPLACED-TO DISPLACED-INDEX-OFFSET) (* \; "Edited 11-Dec-87 15:35 by jop") (* |;;| "General arrays cover all make-array cases, including those requiring indirection.") (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP))) (|create| GENERAL-ARRAY STORAGE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER)) READ-ONLY-P _ READ-ONLY-P INDIRECT-P _ (%ARRAYP DISPLACED-TO) BIT-P _ (%BIT-TYPE-P TYPE-NUMBER) STRING-P _ (AND (%CHAR-TYPE-P TYPE-NUMBER) (EQ 1 (LENGTH DIMENSIONS))) ADJUSTABLE-P _ ADJUSTABLE-P DISPLACED-P _ DISPLACED-TO FILL-POINTER-P _ FILL-POINTER EXTENDABLE-P _ (OR EXTENDABLE-P ADJUSTABLE-P) TYPE-NUMBER _ TYPE-NUMBER OFFSET _ (OR DISPLACED-INDEX-OFFSET 0) FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE) TOTAL-SIZE _ TOTAL-SIZE DIMS _ DIMENSIONS)))) (%MAKE-ONED-ARRAY (LAMBDA (TOTAL-SIZE ELEMENT-TYPE FILL-POINTER FATP READ-ONLY-P EXTENDABLE-P DISPLACED-TO DISPLACED-INDEX-OFFSET) (* \; "Edited 18-Dec-86 17:48 by jop") (* |;;| "Oned-arrays cover all one dimensional cases, except adjustable and displaced-to when indirection is necessary") (LET ((TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP))) (|create| ONED-ARRAY BASE _ (OR DISPLACED-TO (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER)) READ-ONLY-P _ READ-ONLY-P BIT-P _ (%BIT-TYPE-P TYPE-NUMBER) STRING-P _ (%CHAR-TYPE-P TYPE-NUMBER) DISPLACED-P _ DISPLACED-TO FILL-POINTER-P _ FILL-POINTER EXTENDABLE-P _ EXTENDABLE-P TYPE-NUMBER _ TYPE-NUMBER OFFSET _ (OR DISPLACED-INDEX-OFFSET 0) FILL-POINTER _ (OR FILL-POINTER TOTAL-SIZE) TOTAL-SIZE _ TOTAL-SIZE)))) (%MAKE-STRING-ARRAY-FAT (LAMBDA (ARRAY) (* \; "Edited 11-Dec-87 15:35 by jop") (* |;;| "Like Adjust-array for the special case of Thin-string arrays") (CL:IF (NOT (%ARRAYP ARRAY)) (CL:ERROR "Not an array" ARRAY)) (LET ((BASE-ARRAY ARRAY) NEW-BASE OFFSET LIMIT) (* |;;| "Find the base array") (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| ARRAY) (CL:LOOP (CL:IF (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY) (SETQ BASE-ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)) (RETURN NIL)))) (* |;;| "Consistency check") (CL:IF (NOT (%THIN-CHAR-TYPE-P (|fetch| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY)) ) (CL:ERROR "Not a thin string-char array: ~S" BASE-ARRAY)) (* |;;| "Allocate the new storage") (* \; "Be careful about offsets") (SETQ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY)) (SETQ LIMIT (+ (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| BASE-ARRAY) OFFSET)) (SETQ NEW-BASE (%MAKE-ARRAY-STORAGE LIMIT %FAT-CHAR-TYPENUMBER)) (* |;;| "Initialize it") (* \;  "Can't use %fast-copy-base because of the differing type numbers") (CL:DO ((I OFFSET (CL:1+ I)) (BASE-ARRAY-BASE (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY))) ((EQ I LIMIT)) (%ARRAY-WRITE (%ARRAY-READ BASE-ARRAY-BASE %THIN-CHAR-TYPENUMBER I) NEW-BASE %FAT-CHAR-TYPENUMBER I)) (* |;;| "Smash the new base into the array-header") (UNINTERRUPTABLY (|replace| (ARRAY-HEADER BASE) |of| BASE-ARRAY |with| NEW-BASE) (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY |with| %FAT-CHAR-TYPENUMBER )) (* |;;| "return the original array") ARRAY))) (%MAKE-TWOD-ARRAY (LAMBDA (TOTAL-SIZE DIMENSIONS ELEMENT-TYPE FATP READ-ONLY-P EXTENDABLE-P) (* \; "Edited 18-Dec-86 17:49 by jop") (* |;;| "Two-d arrays are only simple or extendable twod-arrays") (LET ((BOUND0 (CAR DIMENSIONS)) (BOUND1 (CADR DIMENSIONS)) (TYPE-NUMBER (%CML-TYPE-TO-TYPENUMBER ELEMENT-TYPE FATP))) (|create| TWOD-ARRAY BASE _ (%MAKE-ARRAY-STORAGE TOTAL-SIZE TYPE-NUMBER) READ-ONLY-P _ READ-ONLY-P BIT-P _ (%BIT-TYPE-P TYPE-NUMBER) EXTENDABLE-P _ EXTENDABLE-P TYPE-NUMBER _ TYPE-NUMBER BOUND0 _ BOUND0 BOUND1 _ BOUND1 TOTAL-SIZE _ TOTAL-SIZE)))) (%TOTAL-SIZE (LAMBDA (DIMS) (* \; "Edited 18-Dec-86 17:53 by jop") (CL:DO ((DIM DIMS (CDR DIM)) (PROD 1)) ((NULL DIM) PROD) (SETQ PROD (CL:* (CAR DIM) PROD))))) (SHRINK-VECTOR (LAMBDA (VECTOR NEW-SIZE) (* \; "Edited 18-Dec-86 18:08 by jop") (COND ((%VECTORP VECTOR) (CL:IF (OR (< NEW-SIZE 0) (> NEW-SIZE (|fetch| (ARRAY-HEADER TOTAL-SIZE) |of| VECTOR))) (CL:ERROR "Trying to shrink array ~s to bad size ~s" VECTOR NEW-SIZE)) (|replace| (ARRAY-HEADER FILL-POINTER-P) |of| VECTOR |with| T) (|replace| (ARRAY-HEADER FILL-POINTER) |of| VECTOR |with| NEW-SIZE) VECTOR) (T (CL:ERROR "Not a vector: ~S" VECTOR))))) ) (* \; "For Interlisp string hack") (DEFINEQ (%SET-ARRAY-OFFSET (LAMBDA (ARRAY NEWVALUE) (* \; "Edited 18-Dec-86 17:51 by jop") (* |;;| "Set the true offset for ARRAY") (COND ((%ONED-ARRAY-P ARRAY) (|replace| (ARRAY-HEADER OFFSET) |of| ARRAY |with| NEWVALUE)) ((%TWOD-ARRAY-P ARRAY) (CL:ERROR "Twod-arrays have no offset")) ((%GENERAL-ARRAY-P ARRAY) (|replace| (ARRAY-HEADER OFFSET) |of| ARRAY |with| (- NEWVALUE (CL:DO* ((BASE-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY)) (OFFSET 0 (+ OFFSET (%GET-ARRAY-OFFSET BASE-ARRAY)))) ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY)) OFFSET))))) (T (CL:ERROR "Not an array: ~S" ARRAY))) NEWVALUE)) (%SET-ARRAY-TYPE-NUMBER (LAMBDA (ARRAY NEWVALUE) (* \; "Edited 18-Dec-86 17:52 by jop") (* |;;| "Set the true type-number for array") (COND ((OR (%ONED-ARRAY-P ARRAY) (%TWOD-ARRAY-P ARRAY)) (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| ARRAY |with| NEWVALUE)) ((%GENERAL-ARRAY-P ARRAY) (CL:DO ((BASE-ARRAY ARRAY (|fetch| (ARRAY-HEADER BASE) |of| BASE-ARRAY))) ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| BASE-ARRAY)) (|replace| (ARRAY-HEADER TYPE-NUMBER) |of| BASE-ARRAY |with| NEWVALUE)))) (T (CL:ERROR "Not an array ~S" ARRAY))) NEWVALUE)) ) (* \; "Low level predicates") (DEFINEQ (%ONED-ARRAY-P (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:49 by jop") (EQ (NTYPX ARRAY) %ONED-ARRAY))) (%TWOD-ARRAY-P (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:53 by jop") (EQ (NTYPX ARRAY) %TWOD-ARRAY))) (%GENERAL-ARRAY-P (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:44 by jop") (EQ (NTYPX ARRAY) %GENERAL-ARRAY))) (%THIN-STRING-ARRAY-P (LAMBDA (ARRAY) (* \; "Edited 18-Dec-86 17:53 by jop") (%THIN-CHAR-TYPE-P (%ARRAY-TYPE-NUMBER ARRAY)))) ) (DEFOPTIMIZER %ONED-ARRAY-P (ARRAY) `(AND ((OPCODES TYPEP 14) ,ARRAY) T)) (DEFOPTIMIZER %TWOD-ARRAY-P (ARRAY) `(AND ((OPCODES TYPEP 15) ,ARRAY) T)) (DEFOPTIMIZER %GENERAL-ARRAY-P (ARRAY) `(AND ((OPCODES TYPEP 16) ,ARRAY) T)) (* \; "Real record def's on cmlarray-support") (/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 4) POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP POINTER) '((GENERAL-ARRAY 0 (BITS . 3)) (GENERAL-ARRAY 0 POINTER) (GENERAL-ARRAY 2 (FLAGBITS . 0)) (GENERAL-ARRAY 2 (FLAGBITS . 16)) (GENERAL-ARRAY 2 (FLAGBITS . 32)) (GENERAL-ARRAY 2 (FLAGBITS . 48)) (GENERAL-ARRAY 2 (FLAGBITS . 64)) (GENERAL-ARRAY 2 (FLAGBITS . 80)) (GENERAL-ARRAY 2 (FLAGBITS . 96)) (GENERAL-ARRAY 2 (FLAGBITS . 112)) (GENERAL-ARRAY 2 (BITS . 135)) (GENERAL-ARRAY 3 (BITS . 15)) (GENERAL-ARRAY 4 FIXP) (GENERAL-ARRAY 6 FIXP) (GENERAL-ARRAY 8 POINTER)) '10) (/DECLAREDATATYPE 'ONED-ARRAY '((BITS 4) POINTER FLAG (BITS 1) FLAG FLAG (BITS 1) FLAG FLAG FLAG (BITS 8) WORD FIXP FIXP) '((ONED-ARRAY 0 (BITS . 3)) (ONED-ARRAY 0 POINTER) (ONED-ARRAY 2 (FLAGBITS . 0)) (ONED-ARRAY 2 (BITS . 16)) (ONED-ARRAY 2 (FLAGBITS . 32)) (ONED-ARRAY 2 (FLAGBITS . 48)) (ONED-ARRAY 2 (BITS . 64)) (ONED-ARRAY 2 (FLAGBITS . 80)) (ONED-ARRAY 2 (FLAGBITS . 96)) (ONED-ARRAY 2 (FLAGBITS . 112)) (ONED-ARRAY 2 (BITS . 135)) (ONED-ARRAY 3 (BITS . 15)) (ONED-ARRAY 4 FIXP) (ONED-ARRAY 6 FIXP)) '8) (/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 4) POINTER FLAG (BITS 1) FLAG (BITS 4) FLAG (BITS 8) FIXP FIXP FIXP) '((TWOD-ARRAY 0 (BITS . 3)) (TWOD-ARRAY 0 POINTER) (TWOD-ARRAY 2 (FLAGBITS . 0)) (TWOD-ARRAY 2 (BITS . 16)) (TWOD-ARRAY 2 (FLAGBITS . 32)) (TWOD-ARRAY 2 (BITS . 51)) (TWOD-ARRAY 2 (FLAGBITS . 112)) (TWOD-ARRAY 2 (BITS . 135)) (TWOD-ARRAY 3 FIXP) (TWOD-ARRAY 5 FIXP) (TWOD-ARRAY 7 FIXP)) '10) (ADDTOVAR SYSTEMRECLST (DATATYPE GENERAL-ARRAY ((NIL BITS 4) (STORAGE POINTER) (READ-ONLY-P FLAG) (INDIRECT-P FLAG) (BIT-P FLAG) (STRING-P FLAG) (ADJUSTABLE-P FLAG) (DISPLACED-P FLAG) (FILL-POINTER-P FLAG) (EXTENDABLE-P FLAG) (TYPE-NUMBER BITS 8) (OFFSET WORD) (FILL-POINTER FIXP) (TOTAL-SIZE FIXP) (DIMS POINTER))) (DATATYPE ONED-ARRAY ((NIL BITS 4) (BASE POINTER) (READ-ONLY-P FLAG) (NIL BITS 1) (BIT-P FLAG) (STRING-P FLAG) (NIL BITS 1) (DISPLACED-P FLAG) (FILL-POINTER-P FLAG) (EXTENDABLE-P FLAG) (TYPE-NUMBER BITS 8) (OFFSET WORD) (FILL-POINTER FIXP) (TOTAL-SIZE FIXP))) (DATATYPE TWOD-ARRAY ((NIL BITS 4) (BASE POINTER) (READ-ONLY-P FLAG) (NIL BITS 1) (BIT-P FLAG) (NIL BITS 4) (EXTENDABLE-P FLAG) (TYPE-NUMBER BITS 8) (BOUND0 FIXP) (BOUND1 FIXP) (TOTAL-SIZE FIXP))) ) (PUTPROPS %AREF1 DOPVAL (2 AREF1)) (PUTPROPS %AREF2 DOPVAL (3 AREF2)) (PUTPROPS %ASET1 DOPVAL (3 ASET1)) (PUTPROPS %ASET2 DOPVAL (4 ASET2)) (* |;;| "I/O") (DEFINEQ (%DEFPRINT-ARRAY (LAMBDA (ARRAY STREAM) (* \; "Edited 5-Feb-88 10:10 by jop") (* |;;| "This is the defprint for the array type") (COND ((%VECTORP ARRAY) (%DEFPRINT-VECTOR ARRAY STREAM)) ((NOT *PRINT-ARRAY*) (%DEFPRINT-GENERIC-ARRAY ARRAY STREAM)) ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0)) (\\ELIDE.PRINT.ELEMENT STREAM) T) (T (LET ((HASH (CL:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*))) (RANK (CL:ARRAY-RANK ARRAY)) RANKSTR) (%CHECK-CIRCLE-PRINT ARRAY STREAM (SETQ RANKSTR (CL:PRINC-TO-STRING RANK)) (* \; "Make sure we have room for #na") (.SPACECHECK. STREAM (+ (VECTOR-LENGTH RANKSTR) 2)) (CL:WRITE-CHAR HASH STREAM) (CL:WRITE-STRING RANKSTR STREAM) (CL:WRITE-CHAR (CONSTANT #\A) STREAM) (CL:IF (EQ RANK 0) (\\PRINDATUM (CL:AREF ARRAY) STREAM 0) (%PRINT-ARRAY-CONTENTS (%FLATTEN-ARRAY ARRAY) 0 (CL:ARRAY-DIMENSIONS ARRAY) STREAM))) T))))) (%DEFPRINT-BITVECTOR (LAMBDA (CL:BIT-VECTOR STREAM) (* \; "Edited 11-Dec-87 15:35 by jop") (* |;;| "*Print-level* is handled in %defprint-vector") (LET ((HASH (CL:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*))) (SIZE (VECTOR-LENGTH CL:BIT-VECTOR)) END.INDEX FINAL.INDEX ELIDED SIZESTR) (SETQ END.INDEX (CL:1- SIZE)) (%CHECK-CIRCLE-PRINT CL:BIT-VECTOR STREAM (CL:UNLESS (EQ SIZE 0) (CL:DO ((I (CL:1- END.INDEX) (CL:1- I)) (LAST.VALUE (CL:AREF CL:BIT-VECTOR END.INDEX))) ((OR (< I 0) (NOT (EQL (CL:AREF CL:BIT-VECTOR I) LAST.VALUE)))) (SETQ END.INDEX I))) (SETQ FINAL.INDEX (COND ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*)) (SETQ ELIDED T) (CL:1- *PRINT-LENGTH*)) (T END.INDEX))) (CL:IF (NOT (EQ (CL:1- SIZE) END.INDEX)) (SETQ SIZESTR (CL:PRINC-TO-STRING SIZE))) (.SPACECHECK. STREAM (+ (PROGN (* \;  "#* Plus 1 for final.index being 1 less than number bits printed") 3) (CL:IF SIZESTR (VECTOR-LENGTH SIZESTR) 0) FINAL.INDEX (CL:IF ELIDED (PROGN (* \; "Space for ...") 3) 0))) (CL:WRITE-CHAR HASH STREAM) (CL:IF SIZESTR (CL:WRITE-STRING SIZESTR STREAM)) (CL:WRITE-CHAR (CONSTANT #\*) STREAM) (CL:DO ((I 0 (CL:1+ I))) ((> I FINAL.INDEX)) (\\OUTCHAR STREAM (+ (BIT CL:BIT-VECTOR I) (CONSTANT (CL:CHAR-CODE #\0))))) (CL:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM))) T))) (%DEFPRINT-GENERIC-ARRAY (LAMBDA (ARRAY STREAM) (* \; "Edited 18-Dec-86 17:40 by jop") (* |;;| "Invoked when *PRINT-ARRAY* is NIL") (LET ((HASH (CL:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*)))) (%CHECK-CIRCLE-PRINT ARRAY STREAM (* \; "Make sure we have room for #<") (.SPACECHECK. STREAM 2) (CL:WRITE-CHAR HASH STREAM) (CL:WRITE-CHAR (CONSTANT #\<) STREAM) (CL:WRITE-STRING (CL:PRINC-TO-STRING 'CL:ARRAY) STREAM) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM) (CL:WRITE-STRING (CL:PRINC-TO-STRING (CL:ARRAY-ELEMENT-TYPE ARRAY)) STREAM) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM) (CL:WRITE-STRING (CL:PRINC-TO-STRING (CL:ARRAY-DIMENSIONS ARRAY)) STREAM) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM) (CL:WRITE-CHAR (CONSTANT #\@) STREAM) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM) (\\PRINTADDR ARRAY STREAM) (CL:WRITE-CHAR (CONSTANT #\>) STREAM)) T))) (%DEFPRINT-VECTOR (LAMBDA (VECTOR STREAM) (* \; "Edited 5-Feb-88 10:11 by jop") (* |;;| "Defprint for the oned-array type") (COND ((CL:STRINGP VECTOR) (%DEFPRINT-STRING VECTOR STREAM)) ((NOT *PRINT-ARRAY*) (%DEFPRINT-GENERIC-ARRAY VECTOR STREAM)) ((AND *PRINT-LEVEL* (<= *PRINT-LEVEL* 0)) (\\ELIDE.PRINT.ELEMENT STREAM) T) ((CL:BIT-VECTOR-P VECTOR) (%DEFPRINT-BITVECTOR VECTOR STREAM)) (T (LET ((HASH (CL:CODE-CHAR (|fetch| (READTABLEP HASHMACROCHAR) |of| *READTABLE*))) (SIZE (VECTOR-LENGTH VECTOR)) END.INDEX FINAL.INDEX ELIDED SIZESTR) (SETQ END.INDEX (CL:1- SIZE)) (%CHECK-CIRCLE-PRINT VECTOR STREAM (CL:UNLESS (EQ SIZE 0) (CL:DO ((I (CL:1- END.INDEX) (CL:1- I)) (LAST.VALUE (CL:AREF VECTOR END.INDEX))) ((OR (< I 0) (NOT (EQL (CL:AREF VECTOR I) LAST.VALUE)))) (SETQ END.INDEX I))) (SETQ FINAL.INDEX (COND ((AND *PRINT-LENGTH* (>= END.INDEX *PRINT-LENGTH*)) (SETQ ELIDED T) (CL:1- *PRINT-LENGTH*)) (T END.INDEX))) (CL:IF (NOT (EQ (CL:1- SIZE) END.INDEX)) (SETQ SIZESTR (CL:PRINC-TO-STRING SIZE))) (.SPACECHECK. STREAM (+ (CL:IF SIZESTR (VECTOR-LENGTH SIZESTR) 0) 2)) (CL:WRITE-CHAR HASH STREAM) (CL:IF SIZESTR (CL:WRITE-STRING SIZESTR STREAM)) (CL:WRITE-CHAR (CONSTANT #\() STREAM) (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (CL:1- *PRINT-LEVEL*)))) (CL:DO ((I 0 (CL:1+ I))) ((> I FINAL.INDEX)) (CL:IF (> I 0) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM)) (\\PRINDATUM (CL:AREF VECTOR I) STREAM 0))) (CL:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM)) (CL:WRITE-CHAR (CONSTANT #\)) STREAM)) T))))) (%DEFPRINT-STRING (LAMBDA (STRING STREAM) (* \; "Edited 11-Dec-87 15:36 by jop") (* |;;| "May never get called since (IL:typename (make-string 10)) returns IL:stringp") (LET ((ESCAPECHAR (|fetch| (READTABLEP ESCAPECHAR) |of| *READTABLE*)) (CLP (|fetch| (READTABLEP COMMONLISP) |of| *READTABLE*)) (SIZE (VECTOR-LENGTH STRING))) (%CHECK-CIRCLE-PRINT STRING STREAM (.SPACECHECK. STREAM (CL:IF CLP 2 (+ 2 SIZE))) (CL:WHEN *PRINT-ESCAPE* (\\OUTCHAR STREAM (CONSTANT (CL:CHAR-CODE #\")))) (CL:DO ((I 0 (CL:1+ I)) CH) ((EQ I SIZE)) (SETQ CH (CL:CHAR-CODE (CL:CHAR STRING I))) (CL:WHEN (AND *PRINT-ESCAPE* (OR (EQ CH (CONSTANT (CL:CHAR-CODE #\"))) (EQ CH ESCAPECHAR))) (\\OUTCHAR STREAM ESCAPECHAR)) (\\OUTCHAR STREAM CH)) (CL:WHEN *PRINT-ESCAPE* (\\OUTCHAR STREAM (CONSTANT (CL:CHAR-CODE #\"))))) T))) (%PRINT-ARRAY-CONTENTS (LAMBDA (FLAT-ARRAY OFFSET DIMENSIONS STREAM) (* \; "Edited 5-Feb-88 10:11 by jop") (LET ((NELTS (CAR DIMENSIONS)) FINAL.INDEX ELIDED) (COND ((AND *PRINT-LENGTH* (> NELTS *PRINT-LENGTH*)) (SETQ ELIDED T) (SETQ FINAL.INDEX (CL:1- *PRINT-LENGTH*))) (T (SETQ FINAL.INDEX (CL:1- NELTS)))) (CL:WRITE-CHAR (CONSTANT #\() STREAM) (COND ((NULL (CDR DIMENSIONS)) (* \;  "Down to bottom level, print the elements") (CL:DO ((I OFFSET (CL:1+ I)) (END-INDEX (+ OFFSET FINAL.INDEX))) ((> I END-INDEX)) (CL:IF (> I OFFSET) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM)) (\\PRINDATUM (CL:AREF FLAT-ARRAY I) STREAM 0))) ((EQ *PRINT-LEVEL* 1) (* \; "Elide at this level") (CL:DO ((I 0 (CL:1+ I))) ((> I FINAL.INDEX)) (CL:IF (> I OFFSET) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM)) (\\ELIDE.PRINT.ELEMENT STREAM))) (T (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (CL:1- *PRINT-LEVEL*)))) (CL:DO ((I 0 (CL:1+ I))) ((> I FINAL.INDEX)) (CL:IF (> I 0) (CL:WRITE-CHAR (CONSTANT #\Space) STREAM)) (%PRINT-ARRAY-CONTENTS FLAT-ARRAY (CL:* (CADR DIMENSIONS) (+ OFFSET I)) (CDR DIMENSIONS) STREAM))))) (CL:IF ELIDED (\\ELIDE.PRINT.TAIL STREAM)) (CL:WRITE-CHAR (CONSTANT #\)) STREAM)))) ) (DEFPRINT 'ONED-ARRAY '%DEFPRINT-VECTOR) (DEFPRINT 'TWOD-ARRAY '%DEFPRINT-ARRAY) (DEFPRINT 'GENERAL-ARRAY '%DEFPRINT-ARRAY) (* |;;| "Needed at run time. low level functions for accessing, setting, and allocating raw storage. also includes cml type to typenumber converters" ) (DEFINEQ (%ARRAY-READ (LAMBDA (BASE TYPE-NUMBER INDEX) (%SLOW-ARRAY-READ BASE TYPE-NUMBER INDEX))) (%ARRAY-WRITE (LAMBDA (NEWVALUE BASE TYPE-NUMBER INDEX) (* \; "Edited 18-Dec-86 17:23 by jop") (%SLOW-ARRAY-WRITE NEWVALUE BASE TYPE-NUMBER INDEX))) (%CML-TYPE-TO-TYPENUMBER (LAMBDA (ELEMENT-TYPE FATP) (* \; "Edited 18-Dec-86 17:30 by jop") (LET ((CANONICAL-TYPE (%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (CL:IF (AND FATP (EQ CANONICAL-TYPE 'CL:STRING-CHAR)) %FAT-CHAR-TYPENUMBER (%CML-TYPE-TO-TYPENUMBER-EXPANDER CANONICAL-TYPE))))) (%GET-CANONICAL-CML-TYPE (LAMBDA (ELEMENT-TYPE) (* \; "Edited 18-Dec-86 17:46 by jop") (* |;;| "Returns the enclosing specialized array type") (CL:IF (CL:CONSP ELEMENT-TYPE) (CASE (CAR ELEMENT-TYPE) (CL:UNSIGNED-BYTE (%GET-ENCLOSING-UNSIGNED-BYTE ELEMENT-TYPE)) (CL:SIGNED-BYTE (%GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE)) (CL:MOD (%REDUCE-MOD ELEMENT-TYPE)) (INTEGER (%REDUCE-INTEGER ELEMENT-TYPE)) (T (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE)))) (CL:IF EXPANDER (%GET-CANONICAL-CML-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T)))) (CASE ELEMENT-TYPE ((T XPOINTER CL:SINGLE-FLOAT CL:STRING-CHAR) ELEMENT-TYPE) (POINTER T) (FLOAT 'CL:SINGLE-FLOAT) (CL:FIXNUM '(CL:SIGNED-BYTE 32)) (CL:CHARACTER 'CL:STRING-CHAR) (BIT '(CL:UNSIGNED-BYTE 1)) (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE))) (CL:IF EXPANDER (%GET-CANONICAL-CML-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T))))))) (%GET-ENCLOSING-SIGNED-BYTE (LAMBDA (ELEMENT-TYPE) (* \; "Edited 8-May-88 15:21 by jop") (LET ((NBITS (CADR ELEMENT-TYPE))) (CL:IF (CL:INTEGERP NBITS) (COND ((<= NBITS 16) '(CL:SIGNED-BYTE 16)) ((<= NBITS 32) '(CL:SIGNED-BYTE 32)) (T T)) T)))) (%GET-ENCLOSING-UNSIGNED-BYTE (LAMBDA (ELEMENT-TYPE) (* \; "Edited 8-May-88 15:21 by jop") (LET ((NBITS (CADR ELEMENT-TYPE))) (CL:IF (CL:INTEGERP NBITS) (COND ((<= NBITS 1) '(CL:UNSIGNED-BYTE 1)) ((<= NBITS 8) '(CL:UNSIGNED-BYTE 8)) ((<= NBITS 16) '(CL:UNSIGNED-BYTE 16)) (T T)) T)))) (%MAKE-ARRAY-STORAGE (LAMBDA (NELTS TYPENUMBER INIT-ON-PAGE ALIGNMENT) (* \; "Edited 18-Dec-86 17:47 by jop") (* |;;| "Allocates a raw storage block for an array of NELTS elements, of type TYPENUMBER") (LET ((BITS-PER-ELEMENT (%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) (GC-TYPE (%TYPENUMBER-TO-GC-TYPE TYPENUMBER))) (\\ALLOCBLOCK (FOLDHI (CL:* NELTS BITS-PER-ELEMENT) BITSPERCELL) GC-TYPE INIT-ON-PAGE ALIGNMENT)))) (%REDUCE-INTEGER (LAMBDA (ELEMENT-TYPE) (* \; "Edited 8-May-88 15:27 by jop") (LET ((LOW (CADR ELEMENT-TYPE)) (HIGH (CADDR ELEMENT-TYPE))) (CL:IF (CL:CONSP LOW) (SETQ LOW (CL:1+ (CAR LOW)))) (CL:IF (CL:CONSP HIGH) (SETQ HIGH (CL:1- (CAR HIGH)))) (CL:IF (AND (CL:INTEGERP LOW) (CL:INTEGERP HIGH)) (CL:IF (>= LOW 0) (COND ((< HIGH 2) '(CL:UNSIGNED-BYTE 1)) ((< HIGH 256) '(CL:UNSIGNED-BYTE 8)) ((< HIGH 65536) '(CL:UNSIGNED-BYTE 16)) (T T)) (LET ((BOUND (MAX (- LOW) HIGH))) (COND ((< BOUND 32768) '(CL:SIGNED-BYTE 16)) ((<= BOUND MAX.FIXP) '(CL:SIGNED-BYTE 32)) (T T)))) T)))) (%REDUCE-MOD (LAMBDA (ELEMENT-TYPE) (* \; "Edited 8-May-88 15:22 by jop") (LET ((MODNUM (CADR ELEMENT-TYPE))) (CL:IF (CL:INTEGERP MODNUM) (COND ((<= MODNUM 2) '(CL:UNSIGNED-BYTE 1)) ((<= MODNUM 256) '(CL:UNSIGNED-BYTE 8)) ((<= MODNUM 65536) '(CL:UNSIGNED-BYTE 16)) (T T)) T)))) (%SLOW-ARRAY-READ (LAMBDA (BASE TYPENUMBER ROW-MAJOR-INDEX) (* \; "Edited 18-Dec-86 17:52 by jop") (* |;;| "Punt function for opcode arrayread") (%LLARRAY-TYPED-GET BASE TYPENUMBER ROW-MAJOR-INDEX))) (%SLOW-ARRAY-WRITE (LAMBDA (NEWVALUE BASE TYPENUMBER ROW-MAJOR-INDEX) (* \; "Edited 18-Dec-86 17:53 by jop") (* |;;| "Punt function for opcode arraywrite") (CL:IF (NOT (%LLARRAY-TYPEP TYPENUMBER NEWVALUE)) (CL:ERROR "Illegal value: ~S" NEWVALUE) (%LLARRAY-TYPED-PUT BASE TYPENUMBER ROW-MAJOR-INDEX NEWVALUE)) NEWVALUE)) ) (DEFOPTIMIZER %ARRAY-READ (BASE TYPENUMBER INDEX) `((OPCODES MISC3 9) ,BASE ,TYPENUMBER ,INDEX)) (DEFOPTIMIZER %ARRAY-WRITE (NEWVALUE BASE TYPENUMBER INDEX) `((OPCODES MISC4 7) ,NEWVALUE ,BASE ,TYPENUMBER ,INDEX)) (* |;;| "Compiler options") (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLARRAY FILETYPE CL:COMPILE-FILE) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:VECTOR ASET CL:ARRAY-ROW-MAJOR-INDEX CL:ARRAY-IN-BOUNDS-P CL:AREF) ) (PUTPROPS CMLARRAY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992 1993)) (DECLARE\: DONTCOPY (FILEMAP (NIL (36261 44172 (CL:AREF 36271 . 38974) (CL:ARRAY-IN-BOUNDS-P 38976 . 39392) ( CL:ARRAY-ROW-MAJOR-INDEX 39394 . 40192) (ASET 40194 . 43876) (CL:VECTOR 43878 . 44170)) (44217 46110 ( XCL:ROW-MAJOR-AREF 44227 . 45042) (CL::ROW-MAJOR-ASET 45044 . 46108)) (48359 87341 ( %ALTER-AS-DISPLACED-ARRAY 48369 . 51676) (%ALTER-AS-DISPLACED-TO-BASE-ARRAY 51678 . 53708) (%AREF0 53710 . 54408) (%AREF1 54410 . 55338) (%AREF2 55340 . 57335) (%ARRAY-BASE 57337 . 58351) ( %ARRAY-CONTENT-INITIALIZE 58353 . 58927) (%ARRAY-ELEMENT-INITIALIZE 58929 . 59268) (%ARRAY-OFFSET 59270 . 59993) (%ARRAY-TYPE-NUMBER 59995 . 61280) (%ASET0 61282 . 62251) (%ASET1 62253 . 63554) ( %ASET2 63556 . 65689) (%CHECK-SEQUENCE-DIMENSIONS 65691 . 66225) (%COPY-TO-NEW-ARRAY 66227 . 67434) ( %DO-LOGICAL-OP 67436 . 69791) (%EXTEND-ARRAY 69793 . 72355) (%FAST-COPY-BASE 72357 . 74798) ( %FAT-STRING-ARRAY-P 74800 . 74984) (%FILL-ARRAY-FROM-SEQUENCE 74986 . 75602) (%FLATTEN-ARRAY 75604 . 76083) (%MAKE-ARRAY-WRITEABLE 76085 . 78287) (%MAKE-DISPLACED-ARRAY 78289 . 81041) ( %MAKE-GENERAL-ARRAY 81043 . 82272) (%MAKE-ONED-ARRAY 82274 . 83299) (%MAKE-STRING-ARRAY-FAT 83301 . 85622) (%MAKE-TWOD-ARRAY 85624 . 86444) (%TOTAL-SIZE 86446 . 86732) (SHRINK-VECTOR 86734 . 87339)) ( 87385 89207 (%SET-ARRAY-OFFSET 87395 . 88469) (%SET-ARRAY-TYPE-NUMBER 88471 . 89205)) (89246 89957 ( %ONED-ARRAY-P 89256 . 89423) (%TWOD-ARRAY-P 89425 . 89592) (%GENERAL-ARRAY-P 89594 . 89767) ( %THIN-STRING-ARRAY-P 89769 . 89955)) (94839 106610 (%DEFPRINT-ARRAY 94849 . 96368) ( %DEFPRINT-BITVECTOR 96370 . 98903) (%DEFPRINT-GENERIC-ARRAY 98905 . 100319) (%DEFPRINT-VECTOR 100321 . 103213) (%DEFPRINT-STRING 103215 . 104543) (%PRINT-ARRAY-CONTENTS 104545 . 106608)) (106899 112443 (%ARRAY-READ 106909 . 107012) (%ARRAY-WRITE 107014 . 107197) (%CML-TYPE-TO-TYPENUMBER 107199 . 107566) (%GET-CANONICAL-CML-TYPE 107568 . 108829) (%GET-ENCLOSING-SIGNED-BYTE 108831 . 109242) ( %GET-ENCLOSING-UNSIGNED-BYTE 109244 . 109729) (%MAKE-ARRAY-STORAGE 109731 . 110247) (%REDUCE-INTEGER 110249 . 111346) (%REDUCE-MOD 111348 . 111826) (%SLOW-ARRAY-READ 111828 . 112068) (%SLOW-ARRAY-WRITE 112070 . 112441))))) STOP \ No newline at end of file diff --git a/sources/CMLARRAY-SUPPORT b/sources/CMLARRAY-SUPPORT new file mode 100644 index 00000000..9cdfbf3b --- /dev/null +++ b/sources/CMLARRAY-SUPPORT @@ -0,0 +1,726 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED " 2-May-99 14:57:41" |{DSK}sources>CMLARRAY-SUPPORT.;2| 32231 + + |changes| |to:| (RECORDS TWOD-ARRAY) + + |previous| |date:| "15-Sep-94 11:10:20" |{DSK}sources>CMLARRAY-SUPPORT.;1|) + + +; Copyright (c) 1986, 1990, 1992, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. + +(PRETTYCOMPRINT CMLARRAY-SUPPORTCOMS) + +(RPAQQ CMLARRAY-SUPPORTCOMS + ( + (* |;;| "Record def's") + + (RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY) + + (* |;;| "Cmlarray support macros and functions") + + (* \; "Fast predicates") + (FUNCTIONS %ARRAYP %SIMPLE-ARRAY-P %SIMPLE-STRING-P %STRINGP %VECTORP) + (FUNCTIONS %CHECK-CIRCLE-PRINT %CHECK-INDICES %CHECK-NOT-WRITEABLE %EXPAND-BIT-OP + %GENERAL-ARRAY-ADJUST-BASE %GET-ARRAY-OFFSET %GET-BASE-ARRAY) + (FUNCTIONS %BIT-TYPE-P %CHAR-TYPE-P %CML-TYPE-TO-TYPENUMBER-EXPANDER %FAT-CHAR-TYPE-P + %FAT-STRING-CHAR-P %GET-TYPE-TABLE-ENTRY %LIT-SIZE-TO-SIZE %LIT-TYPE-TO-TYPE + %LLARRAY-MAKE-ACCESSOR-EXPR %LLARRAY-MAKE-SETTOR-EXPR %LLARRAY-TYPED-GET + %LLARRAY-TYPED-PUT %LLARRAY-TYPEP %MAKE-ARRAY-TYPE-TABLE %MAKE-CML-TYPE-TABLE + %PACK-TYPENUMBER %SMALLFIXP-SMALLPOSP %SMALLPOSP-SMALLFIXP %THIN-CHAR-TYPE-P + %THIN-STRING-CHAR-P %TYPE-SIZE-TO-TYPENUMBER %TYPENUMBER-TO-BITS-PER-ELEMENT + %TYPENUMBER-TO-CML-TYPE %TYPENUMBER-TO-DEFAULT-VALUE %TYPENUMBER-TO-GC-TYPE + %TYPENUMBER-TO-SIZE %TYPENUMBER-TO-TYPE \\GETBASESMALL-FIXP \\GETBASESTRING-CHAR + \\GETBASETHINSTRING-CHAR \\PUTBASESMALL-FIXP \\PUTBASESTRING-CHAR + \\PUTBASETHINSTRING-CHAR) + + +(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE") + + (STRUCTURES ARRAY-TABLE-ENTRY) + + +(* |;;;| "These vars contain all the necessary info for typed arrays") + + (VARIABLES %LIT-ARRAY-SIZES %LIT-ARRAY-TABLE %LIT-ARRAY-TYPES) + + +(* |;;;| "Tables that drives various macros") + + (VARIABLES %ARRAY-TYPE-TABLE %CANONICAL-CML-TYPES) + + +(* |;;;| "Constants for (SIGNED-BYTE 16)") + + (VARIABLES MAX.SMALLFIXP MIN.SMALLFIXP) + + +(* |;;;| "Constants for STRING-CHARS") + + (VARIABLES %CHAR-TYPE %BIT-TYPE %THIN-CHAR-TYPENUMBER %FAT-CHAR-TYPENUMBER %MAXTHINCHAR) + + +(* |;;;| "Array data-type numbers") + + (VARIABLES %GENERAL-ARRAY %ONED-ARRAY %TWOD-ARRAY) + + +(* |;;;| "Compiler options") + + (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) + (PROP FILETYPE CMLARRAY-SUPPORT))) + + + +(* |;;| "Record def's") + +(DECLARE\: EVAL@COMPILE + +(BLOCKRECORD ARRAY-HEADER ( + (* |;;| "Describes common slots of all array headers. Used when the code can't tell what kind of array it has.") + + (NIL BITS 4) (* \; "First 8 bits are unused") + (BASE POINTER) (* \; + "24 bits of pointer. Points at raw storage or, in the indirect case, at another array header") + (* \; "8 bits of flags") + (READ-ONLY-P FLAG) (* \; + "Used for headers pointing at symbols pnames") + (INDIRECT-P FLAG) (* \; + "Points at an array header rather than a raw storage block") + (BIT-P FLAG) (* \; "Is a bit array") + (STRING-P FLAG) (* \; + "Is a string (implies is a vector)") + (* \; + "If any of the following flags are set, the array in non-simple") + (ADJUSTABLE-P FLAG) + (DISPLACED-P FLAG) + (FILL-POINTER-P FLAG) + (EXTENDABLE-P FLAG) + (TYPE-NUMBER BITS 8) (* \; "8 bits of type + size") + (OFFSET WORD) (* \; "For oned and general arrays") + (FILL-POINTER FIXP) (* \; "For oned and general arrays") + (TOTAL-SIZE FIXP)) + (BLOCKRECORD ARRAY-HEADER ((NIL POINTER) + (FLAGS BITS 8) + (TYPE BITS 4) + (SIZE BITS 4))) + (ACCESSFNS (SIMPLE-P (EQ 0 (LOGAND (|fetch| (ARRAY-HEADER FLAGS) + |of| DATUM) + 15)))) + (SYSTEM)) + +(DATATYPE GENERAL-ARRAY ((NIL BITS 4) (* \; "For alignment") + (STORAGE POINTER) (* \; "24 bits of pointer") + (READ-ONLY-P FLAG) (* \; "8 bits of flags") + (INDIRECT-P FLAG) + (BIT-P FLAG) + (STRING-P FLAG) + (ADJUSTABLE-P FLAG) + (DISPLACED-P FLAG) + (FILL-POINTER-P FLAG) + (EXTENDABLE-P FLAG) + (TYPE-NUMBER BITS 8) (* \; "8 bits of typenumber") + (OFFSET WORD) + (FILL-POINTER FIXP) (* \; + "As of 2.1, these 2 fields are fixp's.") + (TOTAL-SIZE FIXP) + (DIMS POINTER))) + +(DATATYPE ONED-ARRAY ((NIL BITS 4) (* \; "Don't use high 8 bits") + (BASE POINTER) (* \; "The raw storage base") + (READ-ONLY-P FLAG) (* \; "8 bits worth of flags") + (NIL BITS 1) (* \; + "Oned array's cann't be indirect") + (BIT-P FLAG) + (STRING-P FLAG) + (NIL BITS 1) (* \; + "Oned-array's cann't be adjustable") + (DISPLACED-P FLAG) + (FILL-POINTER-P FLAG) + (EXTENDABLE-P FLAG) + (TYPE-NUMBER BITS 8) (* \; + "4 bits of type and 4 bits of size") + (OFFSET WORD) (* \; "For displaced arrays") + (FILL-POINTER FIXP) (* \; "For filled arrays") + (TOTAL-SIZE FIXP) (* \; "Total number of elements") + )) + +(DATATYPE TWOD-ARRAY ((NIL BITS 4) (* \; "For alignmnet") + (BASE POINTER) (* \; "Raw storage pointer") + (READ-ONLY-P FLAG) (* \; "8 bits of flags") + (NIL BITS 1) (* \; "Twod arrays cann't be indirect") + (BIT-P FLAG) + (NIL BITS 4) (* \; + "Twod arrays cann't be strings, nor can they be adjustable, displaced, or have fill pointers") + (EXTENDABLE-P FLAG) + (TYPE-NUMBER BITS 8) + (NIL WORD) (* \; + "Dummy, so TOTAL-SIZE is in right place") + (BOUND0 FIXP) (* \; "Zero dimension bound") + (TOTAL-SIZE FIXP) (* \; + "Here to match the location of TOTAL-SIZE in other arrays...") + (BOUND1 FIXP) (* \; "One dimension bound") + )) +) + +(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 4) + POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8) + WORD FIXP FIXP POINTER) + '((GENERAL-ARRAY 0 (BITS . 3)) + (GENERAL-ARRAY 0 POINTER) + (GENERAL-ARRAY 2 (FLAGBITS . 0)) + (GENERAL-ARRAY 2 (FLAGBITS . 16)) + (GENERAL-ARRAY 2 (FLAGBITS . 32)) + (GENERAL-ARRAY 2 (FLAGBITS . 48)) + (GENERAL-ARRAY 2 (FLAGBITS . 64)) + (GENERAL-ARRAY 2 (FLAGBITS . 80)) + (GENERAL-ARRAY 2 (FLAGBITS . 96)) + (GENERAL-ARRAY 2 (FLAGBITS . 112)) + (GENERAL-ARRAY 2 (BITS . 135)) + (GENERAL-ARRAY 3 (BITS . 15)) + (GENERAL-ARRAY 4 FIXP) + (GENERAL-ARRAY 6 FIXP) + (GENERAL-ARRAY 8 POINTER)) + '10) + +(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 4) + POINTER FLAG (BITS 1) + FLAG FLAG (BITS 1) + FLAG FLAG FLAG (BITS 8) + WORD FIXP FIXP) + '((ONED-ARRAY 0 (BITS . 3)) + (ONED-ARRAY 0 POINTER) + (ONED-ARRAY 2 (FLAGBITS . 0)) + (ONED-ARRAY 2 (BITS . 16)) + (ONED-ARRAY 2 (FLAGBITS . 32)) + (ONED-ARRAY 2 (FLAGBITS . 48)) + (ONED-ARRAY 2 (BITS . 64)) + (ONED-ARRAY 2 (FLAGBITS . 80)) + (ONED-ARRAY 2 (FLAGBITS . 96)) + (ONED-ARRAY 2 (FLAGBITS . 112)) + (ONED-ARRAY 2 (BITS . 135)) + (ONED-ARRAY 3 (BITS . 15)) + (ONED-ARRAY 4 FIXP) + (ONED-ARRAY 6 FIXP)) + '8) + +(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 4) + POINTER FLAG (BITS 1) + FLAG + (BITS 4) + FLAG + (BITS 8) + WORD FIXP FIXP FIXP) + '((TWOD-ARRAY 0 (BITS . 3)) + (TWOD-ARRAY 0 POINTER) + (TWOD-ARRAY 2 (FLAGBITS . 0)) + (TWOD-ARRAY 2 (BITS . 16)) + (TWOD-ARRAY 2 (FLAGBITS . 32)) + (TWOD-ARRAY 2 (BITS . 51)) + (TWOD-ARRAY 2 (FLAGBITS . 112)) + (TWOD-ARRAY 2 (BITS . 135)) + (TWOD-ARRAY 3 (BITS . 15)) + (TWOD-ARRAY 4 FIXP) + (TWOD-ARRAY 6 FIXP) + (TWOD-ARRAY 8 FIXP)) + '10) + + + +(* |;;| "Cmlarray support macros and functions") + + + + +(* \; "Fast predicates") + + +(DEFMACRO %ARRAYP (ARRAY) + (CL:IF (CL:SYMBOLP ARRAY) + `(OR (%ONED-ARRAY-P ,ARRAY) + (%TWOD-ARRAY-P ,ARRAY) + (%GENERAL-ARRAY-P ,ARRAY)) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,ARRAY)) + (OR (%ONED-ARRAY-P ,SYM) + (%TWOD-ARRAY-P ,SYM) + (%GENERAL-ARRAY-P ,SYM)))))) + +(DEFMACRO %SIMPLE-ARRAY-P (ARRAY) + (CL:IF (CL:SYMBOLP ARRAY) + `(AND (%ARRAYP ,ARRAY) + (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,ARRAY)) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,ARRAY)) + (AND (%ARRAYP ,SYM) + (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM)))))) + +(DEFMACRO %SIMPLE-STRING-P (STRING) + (CL:IF (CL:SYMBOLP STRING) + `(AND (%ONED-ARRAY-P ,STRING) + (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,STRING) + (|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING)) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,STRING)) + (AND (%ONED-ARRAY-P ,SYM) + (|fetch| (ARRAY-HEADER SIMPLE-P) |of| ,SYM) + (|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM)))))) + +(DEFMACRO %STRINGP (STRING) + (CL:IF (CL:SYMBOLP STRING) + `(AND (OR (%ONED-ARRAY-P ,STRING) + (%GENERAL-ARRAY-P ,STRING)) + (|fetch| (ARRAY-HEADER STRING-P) |of| ,STRING)) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,STRING)) + (AND (OR (%ONED-ARRAY-P ,SYM) + (%GENERAL-ARRAY-P ,SYM)) + (|fetch| (ARRAY-HEADER STRING-P) |of| ,SYM)))))) + +(DEFMACRO %VECTORP (VECTOR) + (CL:IF (CL:SYMBOLP VECTOR) + `(OR (%ONED-ARRAY-P ,VECTOR) + (AND (%GENERAL-ARRAY-P ,VECTOR) + (EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,VECTOR))))) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,VECTOR)) + (OR (%ONED-ARRAY-P ,SYM) + (AND (%GENERAL-ARRAY-P ,SYM) + (EQL 1 (LENGTH (|ffetch| (GENERAL-ARRAY DIMS) |of| ,SYM))))))))) + +(DEFMACRO %CHECK-CIRCLE-PRINT (OBJECT STREAM &REST PRINT-FORMS) + + (* |;;| "If A has a circle label, print it. If it's not the first time or it has no label, print the contents") + + `(LET (CIRCLELABEL FIRSTTIME) + (AND *PRINT-CIRCLE-HASHTABLE* (CL:MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME) + (PRINT-CIRCLE-LOOKUP ,OBJECT))) + (CL:WHEN CIRCLELABEL + (.SPACECHECK. ,STREAM (VECTOR-LENGTH CIRCLELABEL)) + (LET (*PRINT-CIRCLE-HASHTABLE*) + (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE*)) + (* \; + "No need to print-circle this string (dangerous if we do, in fact)") + (CL:WRITE-STRING CIRCLELABEL ,STREAM)) + (CL:WHEN FIRSTTIME + (.SPACECHECK. ,STREAM 1) + (CL:WRITE-CHAR #\Space ,STREAM))) + (CL:WHEN (OR (NOT CIRCLELABEL) + FIRSTTIME) + ,@PRINT-FORMS))) + +(DEFMACRO %CHECK-INDICES (ARRAY START-ARG ARGS) + `(CL:DO ((I ,START-ARG (CL:1+ I)) + (DIM 0 (CL:1+ DIM)) + INDEX) + ((> I ,ARGS) + T) + (SETQ INDEX (ARG ,ARGS I)) + (CL:IF (OR (< INDEX 0) + (>= INDEX (CL:ARRAY-DIMENSION ,ARRAY DIM))) + (RETURN NIL)))) + +(DEFMACRO %CHECK-NOT-WRITEABLE (ARRAY TYPE-NUMBER NEWVALUE) + `(COND + ((|fetch| (ARRAY-HEADER READ-ONLY-P) |of| ,ARRAY) + (%MAKE-ARRAY-WRITEABLE ,ARRAY)) + ((AND (%THIN-CHAR-TYPE-P ,TYPE-NUMBER) + (%FAT-STRING-CHAR-P ,NEWVALUE)) + (%MAKE-STRING-ARRAY-FAT ,ARRAY)))) + +(DEFMACRO %EXPAND-BIT-OP (OP BIT-ARRAY1 BIT-ARRAY2 RESULT-BIT-ARRAY) + `(PROGN (CL:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY1)) + (CL:ERROR "BIT-ARRAY1 not a bit array: ~S" ,BIT-ARRAY1)) + (CL:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY2)) + (CL:ERROR "BIT-ARRAY2 not a bit array: ~S" ,BIT-ARRAY2)) + (CL:IF (NOT (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,BIT-ARRAY2)) + (CL:ERROR "Bit-arrays not of same dimensions")) + (COND + ((NULL ,RESULT-BIT-ARRAY) + (SETQ ,RESULT-BIT-ARRAY (CL:MAKE-ARRAY (CL:ARRAY-DIMENSIONS ,BIT-ARRAY1) + :ELEMENT-TYPE + 'BIT))) + ((EQ ,RESULT-BIT-ARRAY T) + (SETQ ,RESULT-BIT-ARRAY ,BIT-ARRAY1)) + ((NOT (AND (BIT-ARRAY-P ,RESULT-BIT-ARRAY) + (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,RESULT-BIT-ARRAY))) + (CL:ERROR "Illegal result array"))) + ,(CL:ECASE OP + ((AND IOR XOR ANDC2 ORC2) `(OR (EQ ,BIT-ARRAY1 ,RESULT-BIT-ARRAY) + (%DO-LOGICAL-OP 'COPY ,BIT-ARRAY1 ,RESULT-BIT-ARRAY))) + ((EQV NAND NOR ANDC1 ORC1) `(%DO-LOGICAL-OP 'NOT ,BIT-ARRAY1 ,RESULT-BIT-ARRAY))) + ,(CL:ECASE OP + (AND `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (IOR `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (XOR `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (EQV `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (NAND `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (NOR `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (ANDC1 `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (ANDC2 `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (ORC1 `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)) + (ORC2 `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))) + ,RESULT-BIT-ARRAY)) + +(DEFMACRO %GENERAL-ARRAY-ADJUST-BASE (ARRAY ROW-MAJOR-INDEX) + `(CL:IF (|ffetch| (GENERAL-ARRAY INDIRECT-P) |of| ,ARRAY) + (LET ((%OFFSET 0)) + (SETQ ,ARRAY (%GET-BASE-ARRAY ,ARRAY %OFFSET)) + (SETQ ,ROW-MAJOR-INDEX (+ ,ROW-MAJOR-INDEX %OFFSET)) + (CL:IF (NOT (< ,ROW-MAJOR-INDEX (|fetch| (ARRAY-HEADER TOTAL-SIZE) + |of| ,ARRAY))) + (CL:ERROR "Row-major-index out of bounds (displaced to adjustable?)"))))) + +(DEFMACRO %GET-ARRAY-OFFSET (ARRAY) + `(COND + ((OR (%ONED-ARRAY-P ,ARRAY) + (%GENERAL-ARRAY-P ,ARRAY)) + (|fetch| (ARRAY-HEADER OFFSET) |of| ,ARRAY)) + ((%TWOD-ARRAY-P ,ARRAY) + 0))) + +(DEFMACRO %GET-BASE-ARRAY (ARRAY OFFSET) + `(CL:DO ((%BASE-ARRAY ,ARRAY (|fetch| (ARRAY-HEADER BASE) |of| %BASE-ARRAY))) + ((NOT (|fetch| (ARRAY-HEADER INDIRECT-P) |of| %BASE-ARRAY)) + %BASE-ARRAY) + (SETQ ,OFFSET (+ ,OFFSET (%GET-ARRAY-OFFSET %BASE-ARRAY))))) + +(DEFMACRO %BIT-TYPE-P (TYPE-NUMBER) + `(EQ ,TYPE-NUMBER %BIT-TYPE)) + +(DEFMACRO %CHAR-TYPE-P (TYPE-NUMBER) + `(EQ (%TYPENUMBER-TO-TYPE ,TYPE-NUMBER) + %CHAR-TYPE)) + +(DEFMACRO %CML-TYPE-TO-TYPENUMBER-EXPANDER (CML-TYPE) + + (* *) + + (LET + ((SIMPLE-TYPES (REMOVE T (CL:MAPCAN #'(CL:LAMBDA (ENTRY) + (CL:IF (NOT (LISTP (CAR ENTRY))) + (LIST (CAR ENTRY)))) + %CANONICAL-CML-TYPES))) + (COMPOUND-TYPES (CL:REMOVE-DUPLICATES (CL:MAPCAN #'(CL:LAMBDA (ENTRY) + (CL:IF (LISTP (CAR ENTRY)) + (LIST (CAAR ENTRY)))) + %CANONICAL-CML-TYPES)))) + `(CL:IF (EQ ,CML-TYPE T) + ,(CADR (CL:ASSOC T %CANONICAL-CML-TYPES)) + (CL:IF (LISTP ,CML-TYPE) + (CL:ECASE (CAR ,CML-TYPE) + (\\\,@ + (CL:MAPCAR + #'(CL:LAMBDA + (TYPE) + `(,TYPE (CL:ECASE (CADR ,CML-TYPE) + (\\\,@ (CL:MAPCAN #'(CL:LAMBDA (ENTRY) + (CL:IF (AND (LISTP (CAR ENTRY)) + (EQ (CAAR ENTRY) + TYPE)) + (LIST (LIST (CADAR ENTRY) + (CADR ENTRY))))) + %CANONICAL-CML-TYPES))))) + COMPOUND-TYPES))) + (CL:ECASE ,CML-TYPE + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPE) + (CL:ASSOC TYPE %CANONICAL-CML-TYPES)) + SIMPLE-TYPES))))))) + +(DEFMACRO %FAT-CHAR-TYPE-P (TYPE-NUMBER) + `(EQ ,TYPE-NUMBER %FAT-CHAR-TYPENUMBER)) + +(DEFMACRO %FAT-STRING-CHAR-P (OBJECT) + `(> (CL:CHAR-CODE ,OBJECT) + %MAXTHINCHAR)) + +(CL:DEFUN %GET-TYPE-TABLE-ENTRY (TYPENUMBER) + (CADR (CL:ASSOC TYPENUMBER %ARRAY-TYPE-TABLE))) + +(CL:DEFUN %LIT-SIZE-TO-SIZE (LIT-SIZE) + (CADR (CL:ASSOC LIT-SIZE %LIT-ARRAY-SIZES))) + +(CL:DEFUN %LIT-TYPE-TO-TYPE (LIT-TYPE) + (CADR (CL:ASSOC LIT-TYPE %LIT-ARRAY-TYPES))) + +(CL:DEFUN %LLARRAY-MAKE-ACCESSOR-EXPR (TYPENUMBER BASE OFFSET) + (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY TYPENUMBER)) + (ACCESSOR (ARRAY-TABLE-ENTRY-ACCESSOR ENTRY)) + (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY)) + (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY))) + `(,ACCESSOR ,BASE ,(CL:IF NEEDS-SHIFT-P + `(LLSH ,OFFSET ,NEEDS-SHIFT-P) + OFFSET)))) + +(CL:DEFUN %LLARRAY-MAKE-SETTOR-EXPR (TYPENUMBER BASE OFFSET NEWVALUE) + (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY TYPENUMBER)) + (SETTOR (ARRAY-TABLE-ENTRY-SETTOR ENTRY)) + (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY)) + (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY))) + `(,SETTOR ,BASE ,(CL:IF NEEDS-SHIFT-P + `(LLSH ,OFFSET ,NEEDS-SHIFT-P) + OFFSET) + ,NEWVALUE))) + +(DEFMACRO %LLARRAY-TYPED-GET (BASE TYPENUMBER OFFSET) + `(CL:ECASE ,TYPENUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ,(%LLARRAY-MAKE-ACCESSOR-EXPR (CAR TYPEENTRY) + BASE OFFSET))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %LLARRAY-TYPED-PUT (BASE TYPENUMBER OFFSET NEWVALUE) + `(CL:ECASE ,TYPENUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ,(%LLARRAY-MAKE-SETTOR-EXPR (CAR TYPEENTRY) + BASE OFFSET NEWVALUE))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %LLARRAY-TYPEP (TYPENUMBER VALUE) + `(CL:ECASE ,TYPENUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + (,(ARRAY-TABLE-ENTRY-TYPE-TEST (CADR TYPEENTRY)) + ,VALUE))) + %ARRAY-TYPE-TABLE)))) + +(CL:DEFUN %MAKE-ARRAY-TYPE-TABLE (LIT-TABLE TYPES SIZES) + (CL:MAPCAN #'(CL:LAMBDA (TYPE-ENTRY) + (LET ((LIT-TYPE (CAR TYPE-ENTRY))) + (CL:MAPCAR #'(CL:LAMBDA (SIZE-ENTRY) + (LIST (%TYPE-SIZE-TO-TYPENUMBER LIT-TYPE + (CAR SIZE-ENTRY)) + (CADR SIZE-ENTRY))) + (CADR TYPE-ENTRY)))) + LIT-TABLE)) + +(CL:DEFUN %MAKE-CML-TYPE-TABLE (ARRAY-TABLE) + (CL:MAPCAR #'(CL:LAMBDA (TYPE-ENTRY) + (LET ((CMLTYPE (ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPE-ENTRY)))) + (LIST CMLTYPE (CAR TYPE-ENTRY)))) + ARRAY-TABLE)) + +(DEFMACRO %PACK-TYPENUMBER (ELTTYPE ELTSIZE) + `(\\ADDBASE (LLSH ,ELTTYPE 4) + ,ELTSIZE)) + +(DEFMACRO %SMALLFIXP-SMALLPOSP (NUM) + `(\\LOLOC ,NUM)) + +(DEFMACRO %SMALLPOSP-SMALLFIXP (NUM) + (LET ((SYM (GENSYM))) + `(LET ((,SYM ,NUM)) + (CL:IF (> ,SYM MAX.SMALLFIXP) + (\\VAG2 |\\SmallNegHi| ,SYM) + ,SYM)))) + +(DEFMACRO %THIN-CHAR-TYPE-P (TYPE-NUMBER) + `(EQ ,TYPE-NUMBER %THIN-CHAR-TYPENUMBER)) + +(DEFMACRO %THIN-STRING-CHAR-P (OBJECT) + `(<= (CL:CHAR-CODE ,OBJECT) + %MAXTHINCHAR)) + +(CL:DEFUN %TYPE-SIZE-TO-TYPENUMBER (LIT-TYPE LIT-SIZE) + (LET ((TYPE (CADR (CL:ASSOC LIT-TYPE %LIT-ARRAY-TYPES))) + (SIZE (CADR (CL:ASSOC LIT-SIZE %LIT-ARRAY-SIZES)))) + (%PACK-TYPENUMBER TYPE SIZE))) + +(DEFMACRO %TYPENUMBER-TO-BITS-PER-ELEMENT (TYPE-NUMBER) + `(CL:ECASE ,TYPE-NUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ,(ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT (CADR TYPEENTRY)))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %TYPENUMBER-TO-CML-TYPE (TYPE-NUMBER) + `(CL:ECASE ,TYPE-NUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ',(ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPEENTRY)))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %TYPENUMBER-TO-DEFAULT-VALUE (TYPE-NUMBER) + `(CL:ECASE ,TYPE-NUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ,(ARRAY-TABLE-ENTRY-DEFAULT-VALUE (CADR TYPEENTRY)))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %TYPENUMBER-TO-GC-TYPE (TYPE-NUMBER) + `(CL:ECASE ,TYPE-NUMBER + (\\\,@ (CL:MAPCAR #'(CL:LAMBDA (TYPEENTRY) + `(,(CAR TYPEENTRY) + ,(ARRAY-TABLE-ENTRY-GC-TYPE (CADR TYPEENTRY)))) + %ARRAY-TYPE-TABLE)))) + +(DEFMACRO %TYPENUMBER-TO-SIZE (TYPE-NUMBER) + `(LOGAND ,TYPE-NUMBER 15)) + +(DEFMACRO %TYPENUMBER-TO-TYPE (TYPE-NUMBER) + `(LRSH ,TYPE-NUMBER 4)) + +(DEFMACRO \\GETBASESMALL-FIXP (BASE OFFSET) + `(%SMALLPOSP-SMALLFIXP (\\GETBASE ,BASE ,OFFSET))) + +(DEFMACRO \\GETBASESTRING-CHAR (PTR DISP) + `(CL:CODE-CHAR (\\GETBASE ,PTR ,DISP))) + +(DEFMACRO \\GETBASETHINSTRING-CHAR (PTR DISP) + `(CL:CODE-CHAR (\\GETBASEBYTE ,PTR ,DISP))) + +(DEFMACRO \\PUTBASESMALL-FIXP (BASE OFFSET VALUE) + `(\\PUTBASE ,BASE ,OFFSET (%SMALLFIXP-SMALLPOSP ,VALUE))) + +(DEFMACRO \\PUTBASESTRING-CHAR (PTR DISP CHAR) + `(\\PUTBASE ,PTR ,DISP (CL:CHAR-CODE ,CHAR))) + +(DEFMACRO \\PUTBASETHINSTRING-CHAR (PTR DISP CHAR) + `(\\PUTBASEBYTE ,PTR ,DISP (CL:CHAR-CODE ,CHAR))) + + + +(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE") + + +(CL:DEFSTRUCT (ARRAY-TABLE-ENTRY (:TYPE LIST) + (:CONSTRUCTOR NIL) + (:COPIER NIL) + (:PREDICATE NIL)) + CML-TYPE + ACCESSOR + SETTOR + BITS-PER-ELEMENT + GC-TYPE + DEFAULT-VALUE + NEEDS-SHIFT-P + TYPE-TEST) + + + +(* |;;;| "These vars contain all the necessary info for typed arrays") + + +(CL:DEFPARAMETER %LIT-ARRAY-SIZES '((1BIT 0) + (8BIT 3) + (16BIT 4) + (32BIT 6)) + "Size codes") + +(CL:DEFPARAMETER %LIT-ARRAY-TABLE + '((CL:STRING-CHAR ((8BIT (CL:STRING-CHAR \\GETBASETHINSTRING-CHAR \\PUTBASETHINSTRING-CHAR 8 + UNBOXEDBLOCK.GCT #\Null NIL (CL:LAMBDA (OBJECT) + (%THIN-STRING-CHAR-P OBJECT + )))) + (16BIT (CL:STRING-CHAR \\GETBASESTRING-CHAR \\PUTBASESTRING-CHAR 16 + UNBOXEDBLOCK.GCT #\Null NIL (CL:LAMBDA (OBJECT) + (CL:STRING-CHAR-P OBJECT)))))) + (T ((32BIT (T \\GETBASEPTR \\RPLPTR 32 PTRBLOCK.GCT NIL 1 (CL:LAMBDA (OBJECT) + T))))) + (XPOINTER ((32BIT (XPOINTER \\GETBASEPTR \\PUTBASEPTR 32 UNBOXEDBLOCK.GCT NIL 1 (CL:LAMBDA + (OBJECT) + T))))) + (CL:SINGLE-FLOAT ((32BIT (CL:SINGLE-FLOAT \\GETBASEFLOATP \\PUTBASEFLOATP 32 UNBOXEDBLOCK.GCT + 0.0 1 (CL:LAMBDA (OBJECT) + (FLOATP OBJECT)))))) + (CL:UNSIGNED-BYTE ((1BIT ((CL:UNSIGNED-BYTE 1) + \\GETBASEBIT \\PUTBASEBIT 1 UNBOXEDBLOCK.GCT 0 NIL + (CL:LAMBDA (OBJECT) + (AND (>= OBJECT 0) + (<= OBJECT 1))))) + (8BIT ((CL:UNSIGNED-BYTE 8) + \\GETBASEBYTE \\PUTBASEBYTE 8 UNBOXEDBLOCK.GCT 0 NIL + (CL:LAMBDA (OBJECT) + (AND (>= OBJECT 0) + (< OBJECT 256))))) + (16BIT ((CL:UNSIGNED-BYTE 16) + \\GETBASE \\PUTBASE 16 UNBOXEDBLOCK.GCT 0 NIL (CL:LAMBDA (OBJECT) + (SMALLPOSP + OBJECT)))))) + (CL:SIGNED-BYTE ((16BIT ((CL:SIGNED-BYTE 16) + \\GETBASESMALL-FIXP \\PUTBASESMALL-FIXP 16 UNBOXEDBLOCK.GCT 0 NIL + (CL:LAMBDA (OBJECT) + (AND (>= OBJECT MIN.SMALLFIXP) + (<= OBJECT MAX.SMALLFIXP))))) + (32BIT ((CL:SIGNED-BYTE 32) + \\GETBASEFIXP \\PUTBASEFIXP 32 UNBOXEDBLOCK.GCT 0 1 + (CL:LAMBDA (OBJECT) + (AND (>= OBJECT MIN.FIXP) + (<= OBJECT MAX.FIXP)))))))) + "Fields described by record ARRAY-TYPE-TABLE-ENTRY") + +(CL:DEFPARAMETER %LIT-ARRAY-TYPES + '((CL:UNSIGNED-BYTE 0) + (CL:SIGNED-BYTE 1) + (T 2) + (CL:SINGLE-FLOAT 3) + (CL:STRING-CHAR 4) + (XPOINTER 5)) + "Type codes") + + + +(* |;;;| "Tables that drives various macros") + + +(CL:DEFPARAMETER %ARRAY-TYPE-TABLE (%MAKE-ARRAY-TYPE-TABLE %LIT-ARRAY-TABLE %LIT-ARRAY-TYPES + %LIT-ARRAY-SIZES) + "Drives various macros") + +(CL:DEFPARAMETER %CANONICAL-CML-TYPES (%MAKE-CML-TYPE-TABLE %ARRAY-TYPE-TABLE)) + + + +(* |;;;| "Constants for (SIGNED-BYTE 16)") + + +(CL:DEFCONSTANT MAX.SMALLFIXP (CL:1- (EXPT 2 15))) + +(CL:DEFCONSTANT MIN.SMALLFIXP (- (EXPT 2 15))) + + + +(* |;;;| "Constants for STRING-CHARS") + + +(CL:DEFCONSTANT %CHAR-TYPE (%LIT-TYPE-TO-TYPE 'CL:STRING-CHAR)) + +(CL:DEFCONSTANT %BIT-TYPE (%TYPE-SIZE-TO-TYPENUMBER 'CL:UNSIGNED-BYTE '1BIT)) + +(CL:DEFCONSTANT %THIN-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'CL:STRING-CHAR '8BIT)) + +(CL:DEFCONSTANT %FAT-CHAR-TYPENUMBER (%TYPE-SIZE-TO-TYPENUMBER 'CL:STRING-CHAR '16BIT)) + +(CL:DEFCONSTANT %MAXTHINCHAR (CL:1- (EXPT 2 8))) + + + +(* |;;;| "Array data-type numbers") + + +(CL:DEFCONSTANT %GENERAL-ARRAY 16 + "General-array-type-number") + +(CL:DEFCONSTANT %ONED-ARRAY 14 + "ONED-ARRAY type number") + +(CL:DEFCONSTANT %TWOD-ARRAY 15 + "TWOD-ARRAY type number") + + + +(* |;;;| "Compiler options") + +(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY +(DECLARE\: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) + +(PUTPROPS CMLARRAY-SUPPORT FILETYPE CL:COMPILE-FILE) +(PUTPROPS CMLARRAY-SUPPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1992 1994 1999)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/sources/CMLARRAYINSPECTOR b/sources/CMLARRAYINSPECTOR new file mode 100644 index 00000000..53ec75b4 --- /dev/null +++ b/sources/CMLARRAYINSPECTOR @@ -0,0 +1,268 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "31-Dec-93 12:26:35" {DSK}export>lispcore>sources>CMLARRAYINSPECTOR.;2 34659 + + changes to%: (FILES TWODINSPECTOR) + (VARS CMLARRAYINSPECTORCOMS) + (FNS ICMLARRAY ICMLARRAY.GETREGIONFN ICMLARRAY.GETMENUWGROUP) + + previous date%: "17-Aug-90 14:15:43" {DSK}export>lispcore>sources>CMLARRAYINSPECTOR.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT CMLARRAYINSPECTORCOMS) + +(RPAQQ CMLARRAYINSPECTORCOMS + [ + (* ;; "Inspector for Common-Lisp arrays.") + + + (* ;; "Functions used to compute load-time constants later (so must come first!):") + + (FNS \CREATE.INSPECTABLEMENU \CREATE.SETABLEMENU \CREATE.TITLEMENU) + (FNS CREATEARRAYSLICE GET.MENU.LIST ICMLARRAY ICMLARRAY.ATTACHDISPLAY ICMLARRAY.DETACHDISPLAY + ICMLARRAY.DOWINDOWCOMFN ICMLARRAY.INDICES ICMLARRAY.SETVALUE ICMLARRAY.TITLECOMMANDFN + ICMLARRAY.VALUECOMMANDFN ICMLARRAY.DISPLAYSLICE ICMLARRAY.GETREGIONFN + ICMLARRAY.GETMENUWGROUP ICMLARRAY.MENUW.APPLY ICMLARRAY.MENUW.GETLEVEL + ICMLARRAY.MENUW.SHOW SLICEDIMENSION SLICERANK SLICEREF SLICESET ZEROD.FETCHFN + ZEROD.STOREFN) + [ADDVARS (INSPECTMACROS ((FUNCTION CL:ARRAYP) . ICMLARRAY] + (INITRECORDS ICML.ARRAYSLICE) + (FILES TWODINSPECTOR FREEMENU) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS ICML.ARRAYSLICE)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA SLICESET SLICEREF + + ICMLARRAY.VALUECOMMANDFN + ]) + + + +(* ;; "Inspector for Common-Lisp arrays.") + + + + +(* ;; "Functions used to compute load-time constants later (so must come first!):") + +(DEFINEQ + +(\CREATE.INSPECTABLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Inspect" 'INSPECT "Inspect element") ("Set" 'SET "Set element") ("Indices" 'INDICES "Display indices") ("IT _ Selection" 'SETIT "Bind IT to element"]) + +(\CREATE.SETABLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Set" 'SET "Set element") ("Indices" 'INDICES "Display indices") ("IT _ Selection" 'SETIT "Bind IT to element"]) + +(\CREATE.TITLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Refetch" 'REFETCH "Refetch the array") ("IT _ Datum" 'IT "Bind IT to the inspected array"]) +) +(DEFINEQ + +(CREATEARRAYSLICE [LAMBDA (CMLARRAY LEVELS) (* jop%: "22-May-86 11:53") (* * An ARRAYSLICE is a zero, one or two dimensional slice of a CMLARRAY.  LEVELS is a list of length (CL:ARRAY-RANK CMLARRAY) which descibes the slice.  The atom ALL indications that that dimension is unrestricted) (LET* ((RANK (CL:ARRAY-RANK CMLARRAY)) (DIMS (CL:ARRAY-DIMENSIONS CMLARRAY)) (OFFSETCONSTANT 0) (SCANDIMS (bind (PROD _ 1) RESULT for DIM in (REVERSE DIMS) do (push RESULT PROD) (SETQ PROD (ITIMES PROD DIM)) finally (RETURN RESULT))) SELECTIONDIMS OFFSETS) [for LEVEL in LEVELS as DIM in DIMS as SCANDIM in SCANDIMS do (if (EQ LEVEL 'ALL) then (push SELECTIONDIMS DIM) (push OFFSETS SCANDIM) else (SETQ OFFSETCONSTANT (IPLUS OFFSETCONSTANT (ITIMES LEVEL SCANDIM] (create ICML.ARRAYSLICE SELECTEDDIMS _ (DREVERSE SELECTIONDIMS) OFFSETS _ (DREVERSE OFFSETS) OFFSETCONSTANT _ OFFSETCONSTANT LINEARIZEDARRAY _ (%%FLATTEN-ARRAY CMLARRAY]) + +(GET.MENU.LIST [LAMBDA (CMLARRAY DISPLAYEDLEVELS MAXWIDTH FONT BFONT) (* ; "Edited 5-Apr-87 18:05 by jop") (LET* [(RANK (CL:ARRAY-RANK CMLARRAY)) (MENU-P (AND (IGREATERP RANK 1) (for DIM in (CL:ARRAY-DIMENSIONS CMLARRAY) always (NEQ DIM 0] `((PROPS FONT ,FONT) ,[if MENU-P then `((TYPE MOMENTARY LABEL "SHOW" FONT ,BFONT BOX 1 SELECTEDFN ICMLARRAY.MENUW.SHOW) (TYPE MOMENTARY LABEL "APPLY" FONT ,BFONT BOX 1 SELECTEDFN ICMLARRAY.MENUW.APPLY] ((GROUP (PROPS FORMAT TABLE) ((TYPE DISPLAY LABEL "Element type:") (TYPE DISPLAY LABEL ,(MKSTRING (CL:ARRAY-ELEMENT-TYPE CMLARRAY)) FONT ,BFONT)) ,@[IF (SIMPLE-ARRAY-P CMLARRAY) THEN `[((TYPE DISPLAY LABEL "Simple-p:") (TYPE DISPLAY LABEL T FONT ,BFONT] ELSE `(,@[IF (CL:ADJUSTABLE-ARRAY-P CMLARRAY) THEN `[((TYPE DISPLAY LABEL "Adjustable-p:") (TYPE DISPLAY LABEL T FONT ,BFONT] ELSEIF (EXTENDABLE-ARRAY-P CMLARRAY) THEN `(((TYPE DISPLAY LABEL "Extendable-p:") (TYPE DISPLAY LABEL T FONT ,BFONT] ,@[IF (CL:ARRAY-HAS-FILL-POINTER-P CMLARRAY) THEN `(((TYPE DISPLAY LABEL "Fill-pointer-p:") (TYPE DISPLAY LABEL T FONT ,BFONT] ,@(IF (DISPLACED-ARRAY-P CMLARRAY) THEN `(((TYPE DISPLAY LABEL "Displaced-p:") (TYPE DISPLAY LABEL T FONT ,BFONT] ((TYPE DISPLAY LABEL "Rank:") (TYPE DISPLAY LABEL ,RANK FONT ,BFONT)) ,@[if (ILESSP RANK 2) then `[((TYPE DISPLAY LABEL "Total-size:") (TYPE DISPLAY LABEL ,(CL:ARRAY-TOTAL-SIZE CMLARRAY) FONT ,BFONT] else `([(TYPE DISPLAY LABEL "Dimension:") ,@(for I from 0 to (SUB1 RANK) collect `(TYPE DISPLAY LABEL ,I FONT ,BFONT] ((TYPE DISPLAY LABEL "Levels:") ,@(for I from 0 to (SUB1 RANK) collect `(TYPE DISPLAY LABEL ,(CL:ARRAY-DIMENSION CMLARRAY I) FONT ,BFONT] ,@(if MENU-P then `(((TYPE DISPLAY LABEL "Shown:") ,@(for LEVEL in DISPLAYEDLEVELS as I from 0 collect `(TYPE MOMENTARY ID ,(PACK* 'LEVEL I) LABEL ,LEVEL FONT ,BFONT MAXWIDTH ,MAXWIDTH BOX 1 DIM ,I SELECTEDFN ICMLARRAY.MENUW.GETLEVEL]) + +(ICMLARRAY + [LAMBDA (CMLARRAY ASTYPE WHERE) (* ; "Edited 5-Apr-87 17:26 by jop") + + (* ;; "Top level entry point into the CMLARRAY inspector") + + (LET* ((RANK (CL:ARRAY-RANK CMLARRAY)) + (FONT (DEFAULTFONT 'DISPLAY)) + (DISPLAYEDLEVELS (bind (LESS1RANK _ (SUB1 RANK)) for I from 0 + to (SUB1 RANK) collect (if (ILESSP (IDIFFERENCE LESS1RANK + I) + 2) + then 'ALL + else 0))) + DISPLAYGROUP MENUGROUP TOPLEFT) + [if (for DIM in (CL:ARRAY-DIMENSIONS CMLARRAY) always (IGREATERP DIM 0)) + then (SETQ DISPLAYGROUP (ICMLARRAY.DISPLAYSLICE CMLARRAY DISPLAYEDLEVELS WHERE) + ) + (SETQ TOPLEFT (create POSITION + XCOORD _ (ADD1 (fetch (REGION RIGHT) of ( + WINDOWREGION + + DISPLAYGROUP + ))) + YCOORD _ (fetch (REGION TOP) of (WINDOWREGION + DISPLAYGROUP] + (SETQ MENUGROUP (ICMLARRAY.GETMENUWGROUP CMLARRAY FONT DISPLAYEDLEVELS TOPLEFT)) + (if DISPLAYGROUP + then (ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUGROUP DISPLAYEDLEVELS)) + MENUGROUP]) + +(ICMLARRAY.ATTACHDISPLAY [LAMBDA (DISPLAYGROUP STATUSGROUP DISPLAYEDLEVELS) (* jop%: "24-Nov-85 15:45") (ATTACHWINDOW DISPLAYGROUP STATUSGROUP 'LEFT 'TOP) (for W in (CONS DISPLAYGROUP (ALLATTACHEDWINDOWS DISPLAYGROUP)) do (WINDOWPROP W 'DOWINDOWCOMFN (FUNCTION ICMLARRAY.DOWINDOWCOMFN))) (WINDOWPROP STATUSGROUP 'DISPLAYGROUP DISPLAYGROUP) (WINDOWPROP STATUSGROUP 'CURRENTLEVELS DISPLAYEDLEVELS]) + +(ICMLARRAY.DETACHDISPLAY [LAMBDA (STATUSGROUP) (* jop%: " 4-Oct-85 17:53") (* *) (PROG [(DISPLAYGROUP (WINDOWPROP STATUSGROUP 'DISPLAYGROUP] (DETACHWINDOW DISPLAYGROUP) (CLOSEW DISPLAYGROUP]) + +(ICMLARRAY.DOWINDOWCOMFN [LAMBDA (WINDOW) (* jop%: "24-Nov-85 15:45") (* * Pass on the usual comms, except for SHAPEW) (PROG ((PASSTOMAINCOMS (WINDOWPROP WINDOW 'PASSTOMAINCOMS)) (COM (MENU WindowMenu))) (if COM then (LET* [(CENTRAL (CENTRALWINDOW WINDOW)) (DISPLAYGROUP (WINDOWPROP CENTRAL 'DISPLAYGROUP] (if (EQ COM 'SHAPEW) then [SHAPEW DISPLAYGROUP (GETREGION NIL NIL NIL (FUNCTION ICMLARRAY.GETREGIONFN) (CONS DISPLAYGROUP 'CLOSED] elseif (MEMB COM PASSTOMAINCOMS) then (APPLY* COM CENTRAL) else (APPLY* COM WINDOW]) + +(ICMLARRAY.INDICES [LAMBDA (DISPLAYWINDOW ROW COLUMN) (* ; "Edited 5-Apr-87 17:11 by jop") (* ;; "Display the indices of the selected item") (LET* [(MAINW (MAINWINDOW DISPLAYWINDOW)) (CURRENTLEVELS (WINDOWPROP MAINW 'CURRENTLEVELS)) (PRTWINDOW (WINDOWPROP MAINW 'PRTWINDOW] (PRINTOUT PRTWINDOW T "Indices: ") (* ;  "In the zero-d case ROW and COLUMN are NIL. In the one-d case COLUMN is NIL") (bind FIRSTFLG for LEVEL in CURRENTLEVELS do (if (EQ LEVEL 'ALL) then (if FIRSTFLG then (PRINTOUT PRTWINDOW %, COLUMN %,) else (SETQ FIRSTFLG T) (PRINTOUT PRTWINDOW %, ROW %,)) else (PRINTOUT PRTWINDOW %, LEVEL %,]) + +(ICMLARRAY.SETVALUE [LAMBDA (DISPLAYWINDOW ROW COLUMN) (* ; "Edited 8-Apr-87 16:47 by jop") (* ;; "In the zero and one-d cases COLUMN should be NIL, and ROW is the only index") (PROG ((MAINW (MAINWINDOW DISPLAYWINDOW)) [SLICERANK (SLICERANK (WINDOWPROP DISPLAYWINDOW 'DATUM] PRTWINDOW NEWVALUE) (SETQ PRTWINDOW (WINDOWPROP MAINW 'PRTWINDOW)) (WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYWINDOW 'PROFILE) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLEARBUF T T) (PRINTOUT T T "Eval> ") (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) (* ;  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T))) (if (EQL SLICERANK 2) then (TWODINSPECT.REPLACE DISPLAYWINDOW ROW COLUMN NEWVALUE) else (ONEDINSPECT.REPLACE DISPLAYWINDOW ROW NEWVALUE]) + +(ICMLARRAY.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:02 by yabu") (if (MOUSESTATE MIDDLE) then (LET* ((TITLEMENU (CONSTANT (\CREATE.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the array%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected array%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (CMLARRAY (WINDOWPROP (MAINWINDOW WINDOW) 'CMLARRAY)) (MENUW (MAINWINDOW WINDOW))) (SELECTQ (MENU TITLEMENU) (REFETCH (ICMLARRAY.MENUW.SHOW (FM.GETITEM 'SHOW NIL MENUW) MENUW) (LET [(DISPLAYGROUP (WINDOWPROP MENUW 'DISPLAYGROUP)) (TOPRIGHT (with REGION (WINDOWPROP MENUW 'REGION) (create POSITION XCOORD _ (SUB1 LEFT) YCOORD _ TOP))) (LEVELS (WINDOWPROP MENUW 'CURRENTLEVELS] (ICMLARRAY.DETACHDISPLAY MENUW) (SETQ DISPLAYGROUP (XCL:WITH-PROFILE (WINDOWPROP DISPLAYGROUP 'PROFILE) (ICMLARRAY.DISPLAYSLICE CMLARRAY LEVELS DISPLAYGROUP TOPRIGHT))) (ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUW LEVELS))) (IT (SETQ IT CMLARRAY) (PROMPTPRINT "IT bound to " CMLARRAY)) NIL]) + +(ICMLARRAY.VALUECOMMANDFN [LAMBDA ARGS (* ; "Edited 20-Jul-90 19:59 by yabu") (PROG ((INSPECTABLEMENU (CONSTANT (\CREATE.INSPECTABLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect element%") (%"Set%" 'SET %"Set element%") (%"Indices%" 'INDICES %"Display indices%") (%"IT _ Selection%" 'SETIT %"Bind IT to element%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (SETABLEMENU (CONSTANT (\CREATE.SETABLEMENU)))(* ; "Original was (create MENU ITEMS _ '((%"Set%" 'SET %"Set element%") (%"Indices%" 'INDICES %"Display indices%") (%"IT _ Selection%" 'SETIT %"Bind IT to element%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (VALUE (ARG ARGS 1)) INDEX ROW COLUMN SLICE DISPLAYWINDOW SLICERANK) (if (EQL ARGS 4) then (* ; "must be in the one-d case") (SETQ INDEX (ARG ARGS 2)) (SETQ SLICE (ARG ARGS 3)) (SETQ DISPLAYWINDOW (ARG ARGS 4)) else (* ; "must be in the two-d case") (SETQ ROW (ARG ARGS 2)) (SETQ COLUMN (ARG ARGS 3)) (SETQ SLICE (ARG ARGS 4)) (SETQ DISPLAYWINDOW (ARG ARGS 5))) (SETQ SLICERANK (SLICERANK SLICE)) (SELECTQ (if (OR (NUMBERP VALUE) (NULL VALUE)) then (MENU SETABLEMENU) else (MENU INSPECTABLEMENU)) (INSPECT (INSPECT VALUE)) (SET (SELECTQ SLICERANK (0 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX)) (1 (ICMLARRAY.SETVALUE DISPLAYWINDOW INDEX)) (2 (ICMLARRAY.SETVALUE DISPLAYWINDOW ROW COLUMN)) (SHOULDNT))) (SETIT (SETQ IT (SELECTQ SLICERANK (0 (SLICEREF SLICE)) (1 (SLICEREF SLICE INDEX)) (2 (SLICEREF SLICE ROW COLUMN)) (SHOULDNT))) (* ; "Nice to have some feedback") (PROMPTPRINT (CONCAT "IT bound to " VALUE))) (INDICES (SELECTQ SLICERANK (0 (ICMLARRAY.INDICES DISPLAYWINDOW)) (1 (ICMLARRAY.INDICES DISPLAYWINDOW INDEX)) (2 (ICMLARRAY.INDICES DISPLAYWINDOW ROW COLUMN)) (SHOULDNT))) NIL]) + +(ICMLARRAY.DISPLAYSLICE [LAMBDA (CMLARRAY LEVELS WHERE TOPRIGHT) (* ; "Edited 5-Apr-87 17:15 by jop") (LET ((SLICE (CREATEARRAYSLICE CMLARRAY LEVELS))) (SELECTQ (SLICERANK SLICE) (0 (ONEDINSPECTW.CREATE SLICE '("Entry") (FUNCTION ZEROD.FETCHFN) (FUNCTION ZEROD.STOREFN) (FUNCTION ICMLARRAY.VALUECOMMANDFN) NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN) WHERE TOPRIGHT)) (1 (ONEDINSPECTW.CREATE SLICE (for I from 0 to (SUB1 (SLICEDIMENSION SLICE 0)) collect I) (FUNCTION SLICEREF) (FUNCTION SLICESET) (FUNCTION ICMLARRAY.VALUECOMMANDFN) NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN) WHERE TOPRIGHT)) (2 (TWODINSPECTW.CREATE SLICE (for I from 0 to (SUB1 (SLICEDIMENSION SLICE 0)) collect I) (for I from 0 to (SUB1 (SLICEDIMENSION SLICE 1)) collect I) (FUNCTION SLICEREF) (FUNCTION SLICESET) (FUNCTION ICMLARRAY.VALUECOMMANDFN) NIL NIL "Display Window" (FUNCTION ICMLARRAY.TITLECOMMANDFN) WHERE TOPRIGHT)) (SHOULDNT "Should not happen"]) + +(ICMLARRAY.GETREGIONFN + [LAMBDA (FIXEDPOINT MOVINGPOINT INFO) (* ; "Edited 5-Apr-87 17:26 by jop") + + (* ;; "Controled reshape of a CMLARRAY inspector display window. For use with GETREGION Assumes that info is CONS pair (WINDOW . STATE) The initial state is CLOSED. Assumes no init region or minsize") + + (PROG ((WINDOW (CAR INFO)) + (STATE (CDR INFO)) + WINDOWREGION) (* ; + "Assumes Window is an attached window") + (SETQ WINDOWREGION (WINDOWREGION WINDOW)) + (if (NULL MOVINGPOINT) + then [RETURN (create POSITION + XCOORD _ (ADD1 (fetch (REGION RIGHT) of WINDOWREGION)) + YCOORD _ (ADD1 (fetch (REGION TOP) of WINDOWREGION] + else (if (EQ STATE 'CLOSED) + then (RPLACD INFO 'OPEN) + [RETURN (create POSITION + XCOORD _ (SUB1 (fetch (REGION LEFT) of + WINDOWREGION + )) + YCOORD _ (SUB1 (fetch (REGION BOTTOM) of + WINDOWREGION + ] + else (if (IGREATERP (fetch (POSITION XCOORD) of MOVINGPOINT) + (fetch (REGION RIGHT) of WINDOWREGION)) + then (replace (POSITION XCOORD) of MOVINGPOINT + with (fetch (REGION RIGHT) of + WINDOWREGION + ))) + (if (IGREATERP (fetch (POSITION YCOORD) of MOVINGPOINT) + (fetch (REGION TOP) of WINDOWREGION)) + then (replace (POSITION YCOORD) of MOVINGPOINT + with (fetch (REGION TOP) of WINDOWREGION))) + (RETURN MOVINGPOINT]) + +(ICMLARRAY.GETMENUWGROUP + [LAMBDA (CMLARRAY FONT DISPLAYEDLEVELS TOPLEFT) (* ; "Edited 5-Apr-87 17:25 by jop") + + (* ;; "Constructs the three windows of the status group and puts them up on the screen. returns the mainwindow of the group.") + + (LET* ((BFONT (FONTCREATE (FONTPROP FONT 'FAMILY) + (FONTPROP FONT 'SIZE) + 'BRR)) + (DIMS (CL:ARRAY-DIMENSIONS CMLARRAY)) + (RANK (CL:ARRAY-RANK CMLARRAY)) + [PHEIGHT (HEIGHTIFWINDOW (FONTPROP FONT 'HEIGHT] + SWINDOW PWINDOW) (* ; "SWINDOW is the status window") + [SETQ SWINDOW (FREEMENU (GET.MENU.LIST CMLARRAY DISPLAYEDLEVELS + (IMAX (STRINGWIDTH 'ALL BFONT) + (STRINGWIDTH (for DIM in DIMS + largest (STRINGWIDTH DIM BFONT)) + BFONT)) + FONT BFONT) + (RESETVAR *PRINT-ARRAY* NIL (CONCAT CMLARRAY " Inspector"] + (* ; + "Makes no sense to reshape the statuswindow group") + (WINDOWPROP SWINDOW 'RESHAPEFN 'DON'T) (* ; "Cache the datum") + (WINDOWPROP SWINDOW 'CMLARRAY CMLARRAY) (* ; + "DISPLAYEDLEVELS is a description of the array slice to be displayed") + (WINDOWPROP SWINDOW 'DISPLAYEDLEVELS DISPLAYEDLEVELS) + (* ; "PWINDOW is the prompt window") + (if (for DIM in DIMS always (NEQ DIM 0)) + then (SETQ PWINDOW (CREATEW (CREATEREGION 0 0 100 PHEIGHT) + NIL NIL T)) + (WINDOWPROP PWINDOW 'MINSIZE (CONS 0 PHEIGHT)) + (WINDOWPROP PWINDOW 'MAXSIZE (CONS MAX.SMALLP PHEIGHT)) + (WINDOWPROP PWINDOW 'PAGEFULLFN (FUNCTION NILL)) + (DSPSCROLL 'ON PWINDOW) + (WINDOWPROP SWINDOW 'PRTWINDOW PWINDOW) + (DSPFONT FONT PWINDOW)) (* ; + "position and open the windowgroup") + [MOVEW SWINDOW (if TOPLEFT + then [create POSITION + XCOORD _ (fetch (POSITION XCOORD) of TOPLEFT) + YCOORD _ (IDIFFERENCE (fetch (POSITION YCOORD) + of TOPLEFT) + (SUB1 (fetch (REGION HEIGHT) + of (WINDOWPROP SWINDOW + 'REGION] + else (GETBOXPOSITION (fetch (REGION WIDTH) + of (WINDOWPROP SWINDOW 'REGION)) + (fetch (REGION HEIGHT) of (WINDOWPROP SWINDOW + 'REGION] + (REDISPLAYW SWINDOW) + (if PWINDOW + then (ATTACHWINDOW PWINDOW SWINDOW 'BOTTOM)) + SWINDOW]) + +(ICMLARRAY.MENUW.APPLY [LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 5-Apr-87 17:28 by jop") (* ;; "Display the slice descibed by the windowprop LEVELS") (LET* [(CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY)) (DISPLAYGROUP (WINDOWPROP MENUWINDOW 'DISPLAYGROUP)) (TOPRIGHT (with REGION (WINDOWPROP MENUWINDOW 'REGION) (create POSITION XCOORD _ (SUB1 LEFT) YCOORD _ TOP))) (LEVELS (for I from 0 to (SUB1 (CL:ARRAY-RANK CMLARRAY)) collect (FM.ITEMPROP (FM.GETITEM (PACK* 'LEVEL I) NIL MENUWINDOW) 'LABEL] (if (IGREATERP (for LEVEL in LEVELS count (EQ LEVEL 'ALL)) 2) then (PRINTOUT (WINDOWPROP MENUWINDOW 'PRTWINDOW) T "Rank too high") else (ICMLARRAY.DETACHDISPLAY MENUWINDOW) (SETQ DISPLAYGROUP (XCL:WITH-PROFILE (WINDOWPROP DISPLAYGROUP 'PROFILE) (ICMLARRAY.DISPLAYSLICE CMLARRAY LEVELS DISPLAYGROUP TOPRIGHT))) (ICMLARRAY.ATTACHDISPLAY DISPLAYGROUP MENUWINDOW LEVELS]) + +(ICMLARRAY.MENUW.GETLEVEL [LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 5-Apr-87 17:28 by jop") (* ;; "Get a new LEVEL for dim DIM") (LET ((DIM (FM.ITEMPROP ITEM 'DIM)) (LEVEL (FM.ITEMPROP ITEM 'LABEL)) (CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY)) (PRTWINDOW (WINDOWPROP MENUWINDOW 'PRTWINDOW)) LEVMENU NEWVALUE) (SETQ LEVEL (if (ILESSP (CL:ARRAY-DIMENSION CMLARRAY DIM) 10) then (LET [(LEVMENU (OR (FM.ITEMPROP ITEM 'LEVMENU) (create MENU ITEMS _ (CONS '(ALL 'ALL "Unrestricted") (for I from 0 to (SUB1 (CL:ARRAY-DIMENSION CMLARRAY DIM)) collect (LIST I (KWOTE I] (FM.ITEMPROP ITEM 'LEVMENU LEVMENU) (OR (MENU LEVMENU) LEVEL)) else (PRINTOUT PRTWINDOW T) (RESETFORM (TTY.PROCESS (THIS.PROCESS)) (SETQ NEWVALUE (PROMPTFORWORD "New level?" LEVEL (CONCAT "Type new level for dim " DIM) PRTWINDOW))) (if (STRINGP NEWVALUE) then (if (STREQUAL (U-CASE NEWVALUE) "ALL") then 'ALL else (SETQ NEWVALUE (READ (OPENSTRINGSTREAM NEWVALUE))) (if (AND (FIXP NEWVALUE) (GEQ NEWVALUE 0) (LESSP NEWVALUE (CL:ARRAY-DIMENSION CMLARRAY DIM))) then NEWVALUE else (PRINTOUT (WINDOWPROP MENUWINDOW 'PRTWINDOW) T (CONCAT "Illegal value " NEWVALUE)) LEVEL)) else LEVEL))) (FM.CHANGELABEL ITEM LEVEL MENUWINDOW]) + +(ICMLARRAY.MENUW.SHOW [LAMBDA (ITEM MENUWINDOW BUTTONS) (* ; "Edited 7-Apr-87 10:25 by jop") (LET [(DISPLAYEDLEVELS (WINDOWPROP MENUWINDOW 'CURRENTLEVELS)) (CMLARRAY (WINDOWPROP MENUWINDOW 'CMLARRAY] (bind LEVEL-ITEM for I from 0 to (SUB1 (CL:ARRAY-RANK CMLARRAY)) as LEVEL in DISPLAYEDLEVELS do (SETQ LEVEL-ITEM (FM.GETITEM (PACK* 'LEVEL I) NIL MENUWINDOW)) (if LEVEL-ITEM then (FM.CHANGELABEL LEVEL-ITEM LEVEL MENUWINDOW]) + +(SLICEDIMENSION [LAMBDA (SELECTION DIM) (* jop%: "20-Nov-85 20:23") (* *) (CAR (FNTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION) (ADD1 DIM]) + +(SLICERANK [LAMBDA (SELECTION) (* jop%: "20-Nov-85 20:23") (* *) (LENGTH (fetch (ICML.ARRAYSLICE SELECTEDDIMS) of SELECTION]) + +(SLICEREF [LAMBDA ARGS (* ; "Edited 5-Apr-87 17:11 by jop") (if (ILESSP ARGS 1) then (HELP "Need at least one arg")) (LET* ((SLICE (ARG ARGS 1)) (LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE)) (OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE)) (OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE))) (CL:AREF LINEARIZEDARRAY (IPLUS OFFSETCONSTANT (for OFFSET in OFFSETS as I from 2 sum (ITIMES OFFSET (ARG ARGS I]) + +(SLICESET [LAMBDA ARGS (* jop%: " 5-Aug-86 12:20") (* *) (if (ILESSP ARGS 2) then (HELP "Need at least two args")) (LET* ((NEWVALUE (ARG ARGS 1)) (SLICE (ARG ARGS 2)) (LINEARIZEDARRAY (fetch (ICML.ARRAYSLICE LINEARIZEDARRAY) of SLICE)) (OFFSETS (fetch (ICML.ARRAYSLICE OFFSETS) of SLICE)) (OFFSETCONSTANT (fetch (ICML.ARRAYSLICE OFFSETCONSTANT) of SLICE))) (ASET NEWVALUE LINEARIZEDARRAY (IPLUS OFFSETCONSTANT (for OFFSET in OFFSETS as I from 3 sum (ITIMES OFFSET (ARG ARGS I]) + +(ZEROD.FETCHFN [LAMBDA (SLICE PROP) (* jop%: " 5-Aug-86 12:20") (* *) (SLICEREF SLICE]) + +(ZEROD.STOREFN [LAMBDA (NEWVALUE SLICE PROP) (* jop%: " 5-Aug-86 12:20") (* *) (SLICESET NEWVALUE SLICE]) +) + +(ADDTOVAR INSPECTMACROS ((FUNCTION CL:ARRAYP) . ICMLARRAY)) + +(/DECLAREDATATYPE 'ICML.ARRAYSLICE '(POINTER POINTER POINTER POINTER) + '((ICML.ARRAYSLICE 0 POINTER) + (ICML.ARRAYSLICE 2 POINTER) + (ICML.ARRAYSLICE 4 POINTER) + (ICML.ARRAYSLICE 6 POINTER)) + '8) + +(FILESLOAD TWODINSPECTOR FREEMENU) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE ICML.ARRAYSLICE (SELECTEDDIMS OFFSETS OFFSETCONSTANT LINEARIZEDARRAY)) +) + +(/DECLAREDATATYPE 'ICML.ARRAYSLICE '(POINTER POINTER POINTER POINTER) + '((ICML.ARRAYSLICE 0 POINTER) + (ICML.ARRAYSLICE 2 POINTER) + (ICML.ARRAYSLICE 4 POINTER) + (ICML.ARRAYSLICE 6 POINTER)) + '8) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA SLICESET SLICEREF ICMLARRAY.VALUECOMMANDFN) +) +(PUTPROPS CMLARRAYINSPECTOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2345 3090 (\CREATE.INSPECTABLEMENU 2355 . 2655) (\CREATE.SETABLEMENU 2657 . 2893) ( +\CREATE.TITLEMENU 2895 . 3088)) (3091 33550 (CREATEARRAYSLICE 3101 . 4523) (GET.MENU.LIST 4525 . 7397) + (ICMLARRAY 7399 . 9425) (ICMLARRAY.ATTACHDISPLAY 9427 . 9880) (ICMLARRAY.DETACHDISPLAY 9882 . 10174) +(ICMLARRAY.DOWINDOWCOMFN 10176 . 11151) (ICMLARRAY.INDICES 11153 . 12100) (ICMLARRAY.SETVALUE 12102 . +13332) (ICMLARRAY.TITLECOMMANDFN 13334 . 15726) (ICMLARRAY.VALUECOMMANDFN 15728 . 18766) ( +ICMLARRAY.DISPLAYSLICE 18768 . 20326) (ICMLARRAY.GETREGIONFN 20328 . 22925) (ICMLARRAY.GETMENUWGROUP +22927 . 26582) (ICMLARRAY.MENUW.APPLY 26584 . 28029) (ICMLARRAY.MENUW.GETLEVEL 28031 . 30613) ( +ICMLARRAY.MENUW.SHOW 30615 . 31223) (SLICEDIMENSION 31225 . 31475) (SLICERANK 31477 . 31693) (SLICEREF + 31695 . 32403) (SLICESET 32405 . 33189) (ZEROD.FETCHFN 33191 . 33364) (ZEROD.STOREFN 33366 . 33548))) +)) +STOP diff --git a/sources/CMLCHARACTER b/sources/CMLCHARACTER new file mode 100644 index 00000000..7555400b --- /dev/null +++ b/sources/CMLCHARACTER @@ -0,0 +1,285 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 21:54:32" {DSK}medley3.5>sources>CMLCHARACTER.;2 32559 changes to%: (OPTIMIZERS CL:CODE-CHAR) (FUNCTIONS CL:CODE-CHAR) previous date%: "18-Aug-95 14:45:44" {DSK}medley3.5>sources>CMLCHARACTER.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990, 1995, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLCHARACTERCOMS) (RPAQQ CMLCHARACTERCOMS [(COMS (* ;  "Interlisp CHARCODE; Some is here, the rest is in LLREAD.") (FNS CHARCODE CHARCODE.UNDECODE) (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE) (OPTIMIZERS CHARCODE) (ALISTS (DWIMEQUIVLST SELCHARQ) (PRETTYEQUIVLST SELCHARQ))) (COMS (* ; "Common Lisp CHARACTER type") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER)) (VARIABLES \CHARHI) (VARIABLES CL:CHAR-BITS-LIMIT CL:CHAR-CODE-LIMIT CL:CHAR-CONTROL-BIT CL:CHAR-FONT-LIMIT CL:CHAR-HYPER-BIT CL:CHAR-META-BIT CL:CHAR-SUPER-BIT)) (COMS (* ; "Basic character fns") (FNS CL:CHAR-CODE CL:CHAR-INT CL:INT-CHAR) (FUNCTIONS CL:CODE-CHAR) (OPTIMIZERS CL:CHAR-CODE CL:CHAR-INT CL:CODE-CHAR CL:INT-CHAR)) [COMS (* ;  "I/O; Some is here, the rest is in LLREAD.") (FNS CHARACTER.PRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT 'CHARACTER 'CHARACTER.PRINT] (COMS (* ;; "Common lisp character functions") (FNS CL:CHAR-BIT CL:CHAR-BITS CL:CHAR-DOWNCASE CL:CHAR-FONT CL:CHAR-NAME CL:CHAR-UPCASE CL:CHARACTER CL:NAME-CHAR CL:SET-CHAR-BIT) (FUNCTIONS CL:DIGIT-CHAR CL:MAKE-CHAR) (OPTIMIZERS CL:CHAR-UPCASE CL:CHAR-DOWNCASE CL:MAKE-CHAR)) (COMS (* ;; "Predicates") (FNS CL:ALPHA-CHAR-P CL:ALPHANUMERICP CL:BOTH-CASE-P CL:CHARACTERP CL:GRAPHIC-CHAR-P CL:LOWER-CASE-P CL:STANDARD-CHAR-P CL:STRING-CHAR-P CL:UPPER-CASE-P) (FNS CL:CHAR-EQUAL CL:CHAR-GREATERP CL:CHAR-LESSP CL:CHAR-NOT-EQUAL CL:CHAR-NOT-GREATERP CL:CHAR-NOT-LESSP CL:CHAR/= CL:CHAR< CL:CHAR<= CL:CHAR= CL:CHAR> CL:CHAR>=) (FUNCTIONS CL:DIGIT-CHAR-P) (OPTIMIZERS CL:CHAR-EQUAL CL:CHAR-GREATERP CL:CHAR-LESSP CL:CHAR-NOT-EQUAL CL:CHAR-NOT-GREATERP CL:CHAR-NOT-LESSP CL:CHAR/= CL:CHAR< CL:CHAR<= CL:CHAR= CL:CHAR> CL:CHAR>= CL:CHARACTERP CL:LOWER-CASE-P CL:STRING-CHAR-P CL:UPPER-CASE-P)) (COMS (* ;; "Internals") (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR)) (COMS (* ;; "Compiler options") (PROP FILETYPE CMLCHARACTER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML CHARCODE) (LAMA CL:CHAR>= CL:CHAR> CL:CHAR= CL:CHAR<= CL:CHAR< CL:CHAR/= CL:CHAR-NOT-LESSP CL:CHAR-NOT-GREATERP CL:CHAR-NOT-EQUAL CL:CHAR-LESSP CL:CHAR-GREATERP CL:CHAR-EQUAL]) (* ; "Interlisp CHARCODE; Some is here, the rest is in LLREAD.") (DEFINEQ (CHARCODE + [NLAMBDA (CHAR) + (CHARCODE.DECODE CHAR]) (CHARCODE.UNDECODE + [LAMBDA (CODE) (* jop%: "26-Aug-86 14:27") + (LET [(NAME (CL:CHAR-NAME (CL:CODE-CHAR CODE] + (AND NAME (MKSTRING NAME]) ) (PUTPROPS SELCHARQ MACRO [F (CONS 'SELECTQ (CONS (CAR F) (MAPLIST (CDR F) (FUNCTION (LAMBDA (I) (COND ((CDR I) (CONS (CHARCODE.DECODE (CAAR I)) (CDAR I))) (T (CAR I]) (PUTPROPS ALPHACHARP MACRO ((CHAR) ([LAMBDA (UCHAR) (DECLARE (LOCALVARS UCHAR)) (AND (IGEQ UCHAR (CHARCODE A)) (ILEQ UCHAR (CHARCODE Z] (LOGAND CHAR 95)))) (PUTPROPS DIGITCHARP MACRO [LAMBDA (CHAR) (AND (IGEQ CHAR (CHARCODE 0)) (ILEQ CHAR (CHARCODE 9]) (PUTPROPS UCASECODE MACRO (OPENLAMBDA (CHAR) (COND ((AND (IGEQ CHAR (CHARCODE a)) (ILEQ CHAR (CHARCODE z))) (LOGAND CHAR 95)) (T CHAR)))) (DEFOPTIMIZER CHARCODE (C) (KWOTE (CHARCODE.DECODE C T))) (ADDTOVAR DWIMEQUIVLST (SELCHARQ . SELECTQ)) (ADDTOVAR PRETTYEQUIVLST (SELCHARQ . SELECTQ)) (* ; "Common Lisp CHARACTER type") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS CHARACTER [(CODE (\LOLOC (\DTEST DATUM 'CHARACTER] (CREATE (\VAG2 \CHARHI CODE))) ) ) (CL:DEFCONSTANT \CHARHI 7) (CL:DEFCONSTANT CL:CHAR-BITS-LIMIT 1) (CL:DEFCONSTANT CL:CHAR-CODE-LIMIT 65536) (CL:DEFCONSTANT CL:CHAR-CONTROL-BIT 0) (CL:DEFCONSTANT CL:CHAR-FONT-LIMIT 1) (CL:DEFCONSTANT CL:CHAR-HYPER-BIT 0) (CL:DEFCONSTANT CL:CHAR-META-BIT 0) (CL:DEFCONSTANT CL:CHAR-SUPER-BIT 0) (* ; "Basic character fns") (DEFINEQ (CL:CHAR-CODE + [LAMBDA (CHAR) (* jop%: "25-Aug-86 17:30") + (\LOLOC (\DTEST CHAR 'CHARACTER]) (CL:CHAR-INT + [LAMBDA (CHAR) + (CL:CHAR-CODE CHAR]) (CL:INT-CHAR + [LAMBDA (INTEGER) (* lmm " 7-Jul-85 16:50") + (CL:CODE-CHAR INTEGER]) ) (CL:DEFUN CL:CODE-CHAR (CODE &OPTIONAL (BITS 0) (FONT 0)) (CL:IF (AND (EQ BITS 0) (EQ FONT 0) (* ;; "This checks for smallposp") (EQ (\HILOC CODE) \SmallPosHi)) (%%CODE-CHAR CODE))) (DEFOPTIMIZER CL:CHAR-CODE (CHAR) [LET [(CONSTANT-CHAR (AND (CL:CONSTANTP CHAR) (CL:EVAL CHAR] (CL:IF (CL:CHARACTERP CONSTANT-CHAR) (\LOLOC CONSTANT-CHAR) `(\LOLOC (\DTEST ,CHAR 'CHARACTER)))]) (DEFOPTIMIZER CL:CHAR-INT (CHAR) `(CL:CHAR-CODE ,CHAR)) (DEFOPTIMIZER CL:CODE-CHAR (CODE &OPTIONAL (BITS 0) (FONT 0)) (CL:IF (AND (EQ BITS 0) (EQ FONT 0)) [LET [(CONSTANT-CODE (AND (CL:CONSTANTP CODE) (CL:EVAL CODE] (CL:IF (EQ (\HILOC CONSTANT-CODE) \SmallPosHi) (%%CODE-CHAR CONSTANT-CODE) `(LET ((%%CODE ,CODE)) (AND (EQ (\HILOC %%CODE) ,\SmallPosHi) (%%CODE-CHAR %%CODE))))] 'COMPILER:PASS)) (DEFOPTIMIZER CL:INT-CHAR (INTEGER) `(CL:CODE-CHAR ,INTEGER)) (* ; "I/O; Some is here, the rest is in LLREAD.") (DEFINEQ (CHARACTER.PRINT + [LAMBDA (CHAR STREAM) (* ; "Edited 10-Sep-87 16:29 by amd") + [COND + [*PRINT-ESCAPE* (* ; "Name that can be read back") + (LET ((PNAME (CL:CHAR-NAME CHAR))) + [.SPACECHECK. STREAM (+ 2 (COND + (PNAME (CL:LENGTH PNAME)) + (T 1] (* ; + "Print as #\ followed by charcter name") + (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) + (\OUTCHAR STREAM (CHARCODE "\")) + (COND + (PNAME (WRITE-STRING* PNAME STREAM)) + (T (\OUTCHAR STREAM (CL:CHAR-CODE CHAR] + (T (* ; "Character as character") + (\OUTCHAR STREAM (CL:CHAR-CODE CHAR] + T]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T) (NTYPX (CL:CODE-CHAR 0 0 0))) (DEFPRINT 'CHARACTER 'CHARACTER.PRINT) ) (* ;; "Common lisp character functions") (DEFINEQ (CL:CHAR-BIT + [LAMBDA (CHAR NAME) (* jop%: "26-Aug-86 15:01") + (CL:ERROR "Bit ~A not supported" NAME]) (CL:CHAR-BITS + [LAMBDA (CHAR) (* jop%: "25-Aug-86 17:35") + (AND (CL:CHARACTERP CHAR) + 0]) (CL:CHAR-DOWNCASE + [LAMBDA (CHAR) (* jop%: "25-Aug-86 18:01") + (%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CL:CHAR-CODE CHAR]) (CL:CHAR-FONT + [LAMBDA (CHAR) (* jop%: "25-Aug-86 17:35") + (AND (CL:CHARACTERP CHAR) + 0]) (CL:CHAR-NAME + [LAMBDA (CHAR) (* ; "Edited 19-Mar-87 15:49 by bvm:") + (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) + (COND + ((EQ CHAR #\Space) (* ; + "Space is special because it is graphic but has a name") + "Space") + ((CL:GRAPHIC-CHAR-P CHAR) (* ; "graphics have no special names") + NIL) + (T (LET ((CODE (CL:CHAR-CODE CHAR)) + CSET) + (COND + [(for X in CHARACTERNAMES when (EQ (CADR X) + CODE) + do (RETURN (CAR X] + (T (SETQ CSET (LRSH CODE 8)) + (SETQ CODE (LOGAND CODE 255)) + (COND + [(AND (EQ CSET 0) + (<= CODE (CHARCODE "^Z"))) (* ; + "represent ascii control chars nicely") + (CONCAT "^" (CL:CODE-CHAR (LOGOR CODE (- (CHARCODE "A") + (CHARCODE "^A"] + (T (* ; "Else charset-charcode") + (CONCAT (for X in CHARACTERSETNAMES + when (EQ (CADR X) + CSET) do (RETURN (CAR X)) + finally (RETURN (OCTALSTRING CSET))) + "-" + (OCTALSTRING CODE]) (CL:CHAR-UPCASE + [LAMBDA (CHAR) (* jop%: "25-Aug-86 18:01") + (%%CODE-CHAR (%%CHAR-UPCASE-CODE (CL:CHAR-CODE CHAR]) (CL:CHARACTER + [LAMBDA (OBJECT) (* jop%: "14-Nov-86 16:22") + (COND + ((TYPEP OBJECT 'CL:CHARACTER) + OBJECT) + ((TYPEP OBJECT 'CL:FIXNUM) + (CL:INT-CHAR OBJECT)) + ([AND (OR (TYPEP OBJECT 'STRING) + (TYPEP OBJECT 'CL:SYMBOL)) + (EQL 1 (CL:LENGTH (SETQ OBJECT (STRING OBJECT] + (CL:CHAR OBJECT 0)) + (T (CL:ERROR "Object cannot be coerced to a character: ~S" OBJECT]) (CL:NAME-CHAR + [LAMBDA (NAME) (* ; "Edited 18-Feb-87 22:05 by bvm:") + (LET ((CODE (CHARCODE.DECODE (STRING NAME) + T))) + (AND CODE (CL:CODE-CHAR CODE]) (CL:SET-CHAR-BIT + [LAMBDA (CHAR NAME NEWVALUE) (* jop%: "26-Aug-86 15:02") + (CL:ERROR "Bit ~A not supported" NAME]) ) (CL:DEFUN CL:DIGIT-CHAR (WEIGHT &OPTIONAL (RADIX 10) (FONT 0)) [AND (EQ FONT 0) (< -1 WEIGHT RADIX 37) (CL:IF (< WEIGHT 10) (%%CODE-CHAR (+ (CONSTANT (CL:CHAR-CODE #\0)) WEIGHT)) (%%CODE-CHAR (+ (CONSTANT (CL:CHAR-CODE #\A)) (- WEIGHT 10))))]) (CL:DEFUN CL:MAKE-CHAR (CHAR &OPTIONAL (BITS 0) (FONT 0)) (CL:IF (AND (EQL BITS 0) (EQL FONT 0)) CHAR)) (DEFOPTIMIZER CL:CHAR-UPCASE (CHAR) `[%%CODE-CHAR (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR]) (DEFOPTIMIZER CL:CHAR-DOWNCASE (CHAR) `[%%CODE-CHAR (%%CHAR-DOWNCASE-CODE (CL:CHAR-CODE ,CHAR]) (DEFOPTIMIZER CL:MAKE-CHAR (CHAR &OPTIONAL BITS FONT) (CL:IF (AND (OR (NULL BITS) (EQL BITS 0)) (OR (NULL FONT) (EQL FONT 0))) CHAR 'COMPILER:PASS)) (* ;; "Predicates") (DEFINEQ (CL:ALPHA-CHAR-P + [LAMBDA (CHAR) (* raf "23-Oct-85 15:03") + (LET ((CODE (CL:CHAR-CODE CHAR))) (* ; + "Might want to make this true for Greek char sets, etc.") + (OR (<= (CONSTANT (CL:CHAR-CODE #\A)) + CODE + (CONSTANT (CL:CHAR-CODE #\Z))) + (<= (CONSTANT (CL:CHAR-CODE #\a)) + CODE + (CONSTANT (CL:CHAR-CODE #\z]) (CL:ALPHANUMERICP + [LAMBDA (CHAR) (* lmm "28-Oct-85 20:40") + (OR (CL:ALPHA-CHAR-P CHAR) + (NOT (NULL (CL:DIGIT-CHAR-P CHAR]) (CL:BOTH-CASE-P + [LAMBDA (CHAR) + (OR (CL:UPPER-CASE-P CHAR) + (CL:LOWER-CASE-P CHAR]) (CL:CHARACTERP + [LAMBDA (OBJECT) (* lmm " 1-Aug-85 22:45") + (TYPENAMEP OBJECT 'CHARACTER]) (CL:GRAPHIC-CHAR-P + [LAMBDA (CHAR) (* bvm%: "14-May-86 16:19") + +(* ;;; +"True if CHAR represents a graphic (printing) character. Definition follows NS character standard") + + (LET* ((CODE (CL:CHAR-CODE CHAR)) + (CSET (LRSH CODE 8))) + (AND [PROGN (* ; + "Graphic charsets are zero, 41 thru 176, 241 thru 276") + (OR (EQ CSET 0) + (AND (> (SETQ CSET (LOGAND CSET 127)) + 32) + (NOT (EQ CSET 127] + (PROGN (* ; + "Printing chars within a character set are SPACE thru 176 and 241 thru 276") + (OR (EQ (SETQ CODE (LOGAND CODE 255)) + (CONSTANT (CL:CHAR-CODE #\Space))) + (AND (> (SETQ CODE (LOGAND CODE 127)) + 32) + (NOT (EQ CODE 127]) (CL:LOWER-CASE-P + [LAMBDA (CHAR) + (<= (CONSTANT (CL:CHAR-CODE #\a)) + (CL:CHAR-CODE CHAR) + (CONSTANT (CL:CHAR-CODE #\z]) (CL:STANDARD-CHAR-P + [LAMBDA (CHAR) (* ; "Edited 7-Jan-87 11:42 by jop") + (AND (CL:MEMBER CHAR + '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5 + #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I + #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\] + #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q + #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~ #\Space #\Newline)) + T]) (CL:STRING-CHAR-P + [LAMBDA (CHAR) + (\DTEST CHAR 'CHARACTER]) (CL:UPPER-CASE-P + [LAMBDA (CHAR) + (<= (CONSTANT (CL:CHAR-CODE #\A)) + (CL:CHAR-CODE CHAR) + (CONSTANT (CL:CHAR-CODE #\Z]) ) (DEFINEQ (CL:CHAR-EQUAL + [LAMBDA N (* jop%: "25-Aug-86 16:03") + (CL:IF (< N 1) + (CL:ERROR "CHAR-EQUAL takes at least one arg")) + (CL:DO ((TEST (CL:CHAR-UPCASE (ARG N 1))) + (I 2 (CL:1+ I))) + ((> I N) + T) + (CL:IF [NOT (EQ TEST (CL:CHAR-UPCASE (ARG N I] + (RETURN NIL)))]) (CL:CHAR-GREATERP + [LAMBDA N (* jop%: "25-Aug-86 17:15") + (CL:IF (< N 1) + (CL:ERROR "CHAR-LESSP takes at least one arg")) + (CL:DO ([LAST (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N 1] + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + [SETQ NEXT (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N I] + (CL:IF (NOT (> LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR-LESSP + [LAMBDA N (* jop%: "25-Aug-86 17:17") + (CL:IF (< N 1) + (CL:ERROR "CHAR-LESSP takes at least one arg")) + (CL:DO ([LAST (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N 1] + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + [SETQ NEXT (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N I] + (CL:IF (NOT (< LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR-NOT-EQUAL + [LAMBDA N (* jop%: "25-Aug-86 16:02") + (CL:IF (< N 1) + (CL:ERROR "CHAR-NOT-EQUAL takes at least one arg")) + (CL:DO ((I 1 (CL:1+ I)) + TEST) + ((> I N) + T) + (SETQ TEST (CL:CHAR-UPCASE (ARG N I))) + (CL:IF (CL:DO ((J (CL:1+ I) + (CL:1+ J))) + ((> J N) + NIL) + (CL:IF (EQ TEST (CL:CHAR-UPCASE (ARG N J))) + (RETURN T))) + (RETURN NIL)))]) (CL:CHAR-NOT-GREATERP + [LAMBDA N (* jop%: "25-Aug-86 17:18") + (CL:IF (< N 1) + (CL:ERROR "CHAR-LESSP takes at least one arg")) + (CL:DO ([LAST (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N 1] + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + [SETQ NEXT (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N I] + (CL:IF (NOT (<= LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR-NOT-LESSP + [LAMBDA N (* jop%: "25-Aug-86 17:19") + (CL:IF (< N 1) + (CL:ERROR "CHAR-LESSP takes at least one arg")) + (CL:DO ([LAST (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N 1] + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + [SETQ NEXT (%%CHAR-UPCASE-CODE (CL:CHAR-CODE (ARG N I] + (CL:IF (NOT (>= LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR/= + [LAMBDA N (* jop%: "25-Aug-86 17:07") + (CL:IF (< N 1) + (CL:ERROR "CHAR/= takes at least one arg")) + (CL:DO ((I 1 (CL:1+ I)) + TEST) + ((> I N) + T) + (SETQ TEST (CL:CHAR-CODE (ARG N I))) + (CL:IF (CL:DO ((J (CL:1+ I) + (CL:1+ J))) + ((> J N) + NIL) + (CL:IF (EQ TEST (CL:CHAR-CODE (ARG N J))) + (RETURN T))) + (RETURN NIL)))]) (CL:CHAR< + [LAMBDA N (* jop%: "25-Aug-86 14:29") + (CL:IF (< N 1) + (CL:ERROR "CHAR< takes at least one arg")) + (CL:DO ((LAST (CL:CHAR-CODE (ARG N 1))) + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + (SETQ NEXT (CL:CHAR-CODE (ARG N I))) + (CL:IF (NOT (< LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR<= + [LAMBDA N (* jop%: "25-Aug-86 14:38") + (CL:IF (< N 1) + (CL:ERROR "CHAR< takes at least one arg")) + (CL:DO ((LAST (CL:CHAR-CODE (ARG N 1))) + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + (SETQ NEXT (CL:CHAR-CODE (ARG N I))) + (CL:IF (NOT (<= LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR= + [LAMBDA N (* jop%: "25-Aug-86 17:05") + (CL:IF (< N 1) + (CL:ERROR "CHAR= takes at least one arg")) + (CL:DO ((TEST (CL:CHAR-CODE (ARG N 1))) + (I 2 (CL:1+ I))) + ((> I N) + T) + (CL:IF [NOT (EQ TEST (CL:CHAR-CODE (ARG N I] + (RETURN NIL)))]) (CL:CHAR> + [LAMBDA N (* jop%: "25-Aug-86 14:34") + (CL:IF (< N 1) + (CL:ERROR "CHAR< takes at least one arg")) + (CL:DO ((LAST (CL:CHAR-CODE (ARG N 1))) + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + (SETQ NEXT (CL:CHAR-CODE (ARG N I))) + (CL:IF (NOT (> LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) (CL:CHAR>= + [LAMBDA N (* jop%: "25-Aug-86 14:40") + (CL:IF (< N 1) + (CL:ERROR "CHAR< takes at least one arg")) + (CL:DO ((LAST (CL:CHAR-CODE (ARG N 1))) + NEXT + (I 2 (CL:1+ I))) + ((> I N) + T) + (SETQ NEXT (CL:CHAR-CODE (ARG N I))) + (CL:IF (NOT (>= LAST NEXT)) + (RETURN NIL) + (SETQ LAST NEXT)))]) ) (CL:DEFUN CL:DIGIT-CHAR-P (CHAR &OPTIONAL (RADIX 10)) "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix." (LET* [(CODE (CL:CHAR-CODE CHAR)) (VAL (COND [(<= (CONSTANT (CL:CHAR-CODE #\0)) CODE (CONSTANT (CL:CHAR-CODE #\9))) (- CODE (CONSTANT (CL:CHAR-CODE #\0] [(<= (CONSTANT (CL:CHAR-CODE #\A)) CODE (CONSTANT (CL:CHAR-CODE #\Z))) (+ 10 (- CODE (CONSTANT (CL:CHAR-CODE #\A] ((<= (CONSTANT (CL:CHAR-CODE #\a)) CODE (CONSTANT (CL:CHAR-CODE #\z))) (+ 10 (- CODE (CONSTANT (CL:CHAR-CODE #\a] (AND VAL (< VAL RADIX) VAL))) (DEFOPTIMIZER CL:CHAR-EQUAL (CHAR &REST MORE-CHARS) (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS)) `[EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,(CAR MORE-CHARS] 'COMPILER:PASS)) (DEFOPTIMIZER CL:CHAR-GREATERP (CHAR &REST MORE-CHARS) `(> (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR-LESSP (CHAR &REST MORE-CHARS) `(< (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR-NOT-EQUAL (CHAR &REST MORE-CHARS) (CL:IF (EQL 1 (CL:LENGTH MORE-CHARS)) `[NOT (EQ (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,(CAR MORE-CHARS] 'COMPILER:PASS)) (DEFOPTIMIZER CL:CHAR-NOT-GREATERP (CHAR &REST MORE-CHARS) `(<= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR-NOT-LESSP (CHAR &REST MORE-CHARS) `(>= (%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,CHAR)) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(%%CHAR-UPCASE-CODE (CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR/= (CHAR &REST MORE-CHARS) (CL:IF (CDR MORE-CHARS) 'COMPILER:PASS `(NEQ ,CHAR ,(CAR MORE-CHARS)))) (DEFOPTIMIZER CL:CHAR< (CHAR &REST MORE-CHARS) `(< (CL:CHAR-CODE ,CHAR) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR<= (CHAR &REST MORE-CHARS) `(<= (CL:CHAR-CODE ,CHAR) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR= (CHAR &REST MORE-CHARS) (CL:IF (CDR MORE-CHARS) [LET ((CH (GENSYM))) `(LET ((,CH ,CHAR)) (AND ,@(for X in MORE-CHARS collect `(EQ ,CH ,X] `(EQ ,CHAR ,(CAR MORE-CHARS)))) (DEFOPTIMIZER CL:CHAR> (CHAR &REST MORE-CHARS) `(> (CL:CHAR-CODE ,CHAR) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHAR>= (CHAR &REST MORE-CHARS) `(>= (CL:CHAR-CODE ,CHAR) ,@(CL:MAPCAR [FUNCTION (CL:LAMBDA (FORM) `(CL:CHAR-CODE ,FORM] MORE-CHARS))) (DEFOPTIMIZER CL:CHARACTERP (OBJECT) `(TYPENAMEP ,OBJECT 'CHARACTER)) (DEFOPTIMIZER CL:LOWER-CASE-P (CHAR) `(<= (CONSTANT (CL:CHAR-CODE #\a)) (CL:CHAR-CODE ,CHAR) (CONSTANT (CL:CHAR-CODE #\z)))) (DEFOPTIMIZER CL:STRING-CHAR-P (CHAR) `(\DTEST ,CHAR 'CHARACTER)) (DEFOPTIMIZER CL:UPPER-CASE-P (CHAR) `(<= (CONSTANT (CL:CHAR-CODE #\A)) (CL:CHAR-CODE ,CHAR) (CONSTANT (CL:CHAR-CODE #\Z)))) (* ;; "Internals") (DEFMACRO %%CHAR-DOWNCASE-CODE (CODE) `(LET ((%%CODE ,CODE)) (CL:IF (<= (CONSTANT (CL:CHAR-CODE #\A)) %%CODE (CONSTANT (CL:CHAR-CODE #\Z))) [+ %%CODE (- (CONSTANT (CL:CHAR-CODE #\a)) (CONSTANT (CL:CHAR-CODE #\A] %%CODE))) (DEFMACRO %%CHAR-UPCASE-CODE (CODE) `(LET ((%%CODE ,CODE)) (CL:IF (<= (CONSTANT (CL:CHAR-CODE #\a)) %%CODE (CONSTANT (CL:CHAR-CODE #\z))) [- %%CODE (- (CONSTANT (CL:CHAR-CODE #\a)) (CONSTANT (CL:CHAR-CODE #\A] %%CODE))) (DEFMACRO %%CODE-CHAR (CODE) `(\VAG2 \CHARHI ,CODE)) (* ;; "Compiler options") (PUTPROPS CMLCHARACTER FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML CHARCODE) (ADDTOVAR LAMA CL:CHAR>= CL:CHAR> CL:CHAR= CL:CHAR<= CL:CHAR< CL:CHAR/= CL:CHAR-NOT-LESSP CL:CHAR-NOT-GREATERP CL:CHAR-NOT-EQUAL CL:CHAR-LESSP CL:CHAR-GREATERP CL:CHAR-EQUAL) ) (PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4041 4323 (CHARCODE 4051 . 4110) (CHARCODE.UNDECODE 4112 . 4321)) (6868 7233 ( CL:CHAR-CODE 6878 . 7026) (CL:CHAR-INT 7028 . 7090) (CL:INT-CHAR 7092 . 7231)) (9139 10193 ( CHARACTER.PRINT 9149 . 10191)) (10406 13937 (CL:CHAR-BIT 10416 . 10569) (CL:CHAR-BITS 10571 . 10728) ( CL:CHAR-DOWNCASE 10730 . 10916) (CL:CHAR-FONT 10918 . 11075) (CL:CHAR-NAME 11077 . 12860) ( CL:CHAR-UPCASE 12862 . 13044) (CL:CHARACTER 13046 . 13534) (CL:NAME-CHAR 13536 . 13776) (CL:SET-CHAR-BIT 13778 . 13935)) (15381 18563 (CL:ALPHA-CHAR-P 15391 . 15927) (CL:ALPHANUMERICP 15929 . 16123) ( CL:BOTH-CASE-P 16125 . 16232) (CL:CHARACTERP 16234 . 16378) (CL:GRAPHIC-CHAR-P 16380 . 17513) ( CL:LOWER-CASE-P 17515 . 17668) (CL:STANDARD-CHAR-P 17670 . 18336) (CL:STRING-CHAR-P 18338 . 18406) ( CL:UPPER-CASE-P 18408 . 18561)) (18564 24388 (CL:CHAR-EQUAL 18574 . 18968) (CL:CHAR-GREATERP 18970 . 19477) (CL:CHAR-LESSP 19479 . 19983) (CL:CHAR-NOT-EQUAL 19985 . 20585) (CL:CHAR-NOT-GREATERP 20587 . 21099) (CL:CHAR-NOT-LESSP 21101 . 21610) (CL:CHAR/= 21612 . 22192) (CL:CHAR< 22194 . 22644) (CL:CHAR<= 22646 . 23098) (CL:CHAR= 23100 . 23480) (CL:CHAR> 23482 . 23932) (CL:CHAR>= 23934 . 24386))))) STOP \ No newline at end of file diff --git a/sources/CMLCOMPILE b/sources/CMLCOMPILE new file mode 100644 index 00000000..a6b3b60a --- /dev/null +++ b/sources/CMLCOMPILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 2-Jul-90 20:24:02" |{PELE:MV:ENVOS}SOURCES>CMLCOMPILE.;7| 21037 changes to%: (FNS COMPILE-FILE-EXPRESSION FAKE-COMPILE-FILE COMPILE-FILE-SCAN-FIRST) previous date%: "30-Jun-90 18:55:12" |{PELE:MV:ENVOS}SOURCES>CMLCOMPILE.;6|) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLCOMPILECOMS) (RPAQQ CMLCOMPILECOMS ((COMS (FUNCTIONS CL:DISASSEMBLE) (FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE) (FNS COMPILE-FILE-SCAN-FIRST) (* ; "This function is support for AR#11185") (VARS ARGTYPE.VARS) (PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT) (FUNCTIONS COMPILE-FILE-DECLARE%:)) (COMS (FNS NEWDEFC) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD (QUOTE NEWDEFC) (QUOTE DEFC))))) (PROP FILETYPE CMLCOMPILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FAKE-COMPILE-FILE))))) (CL:DEFUN CL:DISASSEMBLE (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8) (OUTPUT *STANDARD-OUTPUT*) FIRST-BYTE MARKED-PC) (PRINTCODE (if (CCODEP NAME-OR-COMPILED-FUNCTION) then NAME-OR-COMPILED-FUNCTION else (CL:COMPILE NIL (if (CL:SYMBOLP NAME-OR-COMPILED-FUNCTION) then (CL:SYMBOL-FUNCTION NAME-OR-COMPILED-FUNCTION) else NAME-OR-COMPILED-FUNCTION))) LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC)) (DEFINEQ (FAKE-COMPILE-FILE (CL:LAMBDA (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T) (COMPILER-OUTPUT T) (PROCESS-ENTIRE-FILE NIL PEFP)) (* ; "Edited 29-Jun-90 19:19 by nm") (LET (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML) (NLAMA NLAMA) (LAMS LAMS) (LAMA LAMA) (DFNFLG NIL)) (DECLARE (CL:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG)) (RESETLST (RESETSAVE NIL (LIST (QUOTE RESETUNDO)) (RESETUNDO)) (RESETSAVE COUTFILE COMPILER-OUTPUT) (RESETSAVE STRF REDEFINE) (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE (QUOTE DEFER))) (RESETSAVE LAPFLG LAP) (LET ((*PACKAGE* *INTERLISP-PACKAGE*) (*READ-BASE* 10) (LOCALVARS SYSLOCALVARS) (SPECVARS T) STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM) (DECLARE (CL:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL)) (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ STREAM (OPENSTREAM FILENAME (QUOTE INPUT))))) (CL:MULTIPLE-VALUE-SETQ (ENV FORM) (\PARSE-FILE-HEADER STREAM (QUOTE RETURN) T)) (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*))) (if (NOT PEFP) then (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT)) (if LAP then (SETQ LSTFIL COUTFILE)) (SETQ FILENAME (FULLNAME STREAM)) (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET) (SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING (QUOTE VERSION) NIL (QUOTE EXTENSION) COMPILE.EXT (QUOTE BODY) FILENAME)) (QUOTE OUTPUT) (QUOTE NEW) (QUOTE ((TYPE BINARY))))) STREAM (ROOTFILENAME FILENAME))) (if OUTPUT-FILE then (RESETSAVE LCFIL OUTPUT-FILE) (PRINT-COMPILE-HEADER (LIST STREAM) (QUOTE ("COMPILE-FILEd")) ENV)) (WITH-READER-ENVIRONMENT ENV (PROG ((DEFERRED.EXPRESSIONS NIL) (*PRINT-ARRAY* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (FIRSTFORMS NIL) (AFTERS NIL) (SCRATCH.LCOM (QUOTE {CORE}SCRATCH.LCOM)) DUMMYFILE TEMPVAL) (DECLARE (CL:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS)) (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)") (RESETSAVE NIL (LIST (FUNCTION CLOSEF?) (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM (QUOTE BOTH) (QUOTE NEW))))) LPDUMP (if (EQUAL (CAR FORM) (QUOTE RPAQQ)) then (* ; "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)") (SETQ TEMPVAL (CADDR FORM)) (if (SETQ TEMPVAL (ASSOC (QUOTE DECLARE%:) TEMPVAL)) then (if (SETQ TEMPVAL (FMEMB (QUOTE COMPILERVARS) (FMEMB (QUOTE DOEVAL@COMPILE) TEMPVAL))) then (SETQ DFNFLG T) (if (SETQ TEMPVAL (FMEMB (QUOTE ADDVARS) (SETQ TEMPVAL (CADR TEMPVAL)))) then (CL:DOLIST (ARG (CDR TEMPVAL)) (APPLY (QUOTE ADDTOVAR) ARG)))))) (COMPILE-FILE-EXPRESSION FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE) (SKIPSEPRCODES STREAM) (if (EOFP STREAM) then (CLOSEF STREAM) (for FORM in FIRSTFORMS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE)) (CLOSEF? DUMMYFILE) (DELFILE (FULLNAME DUMMYFILE)) (AND PROCESS-ENTIRE-FILE (for EXP in (REVERSE DEFERRED.EXPRESSIONS) do (APPLY* (CAR EXP) (CDR EXP) OUTPUT-FILE))) (for FORM in AFTERS do (COMPILE-FILE-EXPRESSION FORM OUTPUT-FILE NIL PROCESS-ENTIRE-FILE T)) (RETURN)) (SETQ FORM (READ STREAM)) (GO LPDUMP)) (PRINT NIL OUTPUT-FILE)) (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE)))) (* ; "Do these after UNDONLSETQ entered") (MAPC (REVERSE COMPILE.FILE.AFTER) (FUNCTION EVAL)) COMPILE.FILE.VALUE)) ) (INTERLISP-FORMAT-P [LAMBDA (STREAM) (* bvm%: " 3-Aug-86 14:01") (SELCHARQ (PEEKCCODE STREAM) (; NIL) ((^F "(") T) NIL]) (INTERLISP-NLAMBDA-FUNCTION-P [LAMBDA (X) (* lmm " 7-May-86 20:12") (AND (LITATOM X) (FMEMB (ARGTYPE X) '(1 3)) (NOT (CL:SPECIAL-FORM-P X]) (COMPILE-FILE-EXPRESSION (LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P) (* ; "Edited 30-Jun-90 18:31 by nm") (DECLARE (CL:SPECIAL COMPILED.FILE)) (AND (LISTP FORM) (SELECTQ (CAR FORM) ((DECLARE%: FILECREATED) (COMPILE-FILE-SCAN-FIRST FORM COMPILED.FILE NIL T COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)) ((DEFMACRO) (LET* ((DEFINITION (REMOVE-COMMENTS FORM)) (NAME (XCL::%%DEFINER-NAME (QUOTE DEFMACRO) DEFINITION)) (BODY (XCL::%%EXPAND-DEFINER (QUOTE DEFMACRO) DEFINITION))) (CL:EVAL BODY) (COMPILE-FILE-EXPRESSION BODY COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))) ((PROGN) (for X in (CDR FORM) do (COMPILE-FILE-EXPRESSION X COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))) ((QUOTE) (* ; " ignore top level quoted expression -i") NIL) ((CL:COMPILER-LET) (* ; " top level compiler-let. bind variables and recursively compile sub-expressions. This is here mainly for b PCL has top level compiler-lets") (LET ((VARS (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (X) (if (CL:CONSP X) then (CAR X) else X))) (CADR FORM))) (VALS (CL:MAPCAR (CL:FUNCTION (CL:LAMBDA (X) (if (CL:CONSP X) then (CL:EVAL (CADR X))))) (CADR FORM)))) (CL:PROGV VARS VALS (CL:MAPC (CL:FUNCTION (CL:LAMBDA (X) (COMPILE-FILE-EXPRESSION X COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))) (CDDR FORM))))) ((CL:EVAL-WHEN) (LET ((EVAL.SPECIFIED (OR (FMEMB (QUOTE EVAL) (CADR FORM)) (FMEMB (QUOTE CL:EVAL) (CADR FORM)))) (LOAD.SPECIFIED (OR (FMEMB (QUOTE LOAD) (CADR FORM)) (FMEMB (QUOTE CL:LOAD) (CADR FORM)))) (COMPILE.SPECIFIED (OR (FMEMB (QUOTE COMPILE) (CADR FORM)) (FMEMB (QUOTE CL:COMPILE) (CADR FORM))))) (COND ((NOT LOAD.SPECIFIED) (COND ((OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED)) (for INNER-FORM in (CDDR FORM) do (EVAL INNER-FORM))))) (T (for INNER-FORM in (CDDR FORM) do (COMPILE-FILE-EXPRESSION INNER-FORM COMPILED.FILE (OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED)) DEFER FORCE-OUTPUT-P)))))) ((CL:IN-PACKAGE) (* ; "This is special because it has to be dumped to the output BEFORE the package changes") (PRINT FORM COMPILED.FILE) (EVAL FORM)) ((CL:MAKE-PACKAGE CL:SHADOW CL:SHADOWING-IMPORT EXPORT CL:UNEXPORT CL:USE-PACKAGE CL:UNUSE-PACKAGE IMPORT) (* ; "This is Special also, becouse the compiling Environment Must be changed.(see CLtL, 11.7. Package System Functions and Variables) edited by TT(10-April-90)") (PRINT FORM COMPILED.FILE) (EVAL FORM)) ((CL:SETQ) (* ; "Gasly kludge because cl:setq needs to run in the init before macroexpansion is enabled") (COMPILE-FILE-EXPRESSION (EXPANDMACRO FORM T) COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)) (LET ((PROP (OR (GETPROP (CAR FORM) (QUOTE COMPILE-FILE-EXPRESSION)) (GETPROP (CAR FORM) (QUOTE COMPILE.FILE.EXPRESSION))))) (if (AND (NOT PROP) (NOT (CL:SPECIAL-FORM-P (CAR FORM))) (NOT (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM))) (NEQ FORM (SETQ FORM (CL:MACROEXPAND-1 FORM)))) then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P) else (if COMPILE.TIME.TOO then (EVAL FORM)) (if PROP then (COMPILE.FILE.APPLY PROP FORM DEFER FORCE-OUTPUT-P) elseif (NOT (EQUAL FORM (SETQ FORM (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION))))) then (COMPILE-FILE-EXPRESSION FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P) else (COMPILE.FILE.APPLY (FUNCTION PRINT) FORM DEFER FORCE-OUTPUT-P))))))) ) (COMPILE-FILE-WALK-FUNCTION [LAMBDA (FORM) (* lmm "26-Jun-86 17:25") (if (NLISTP FORM) then FORM else (CL:VALUES FORM (INTERLISP-NLAMBDA-FUNCTION-P (CAR FORM]) (ARGTYPE.STATE [LAMBDA NIL (for X in ARGTYPE.VARS do (PRINTOUT T X %, (EVAL (CADR X)) T]) (COMPILE.CHECK.ARGTYPE [LAMBDA (X AT) (* lmm "15-Jun-85 16:58") (if (NEQ AT (LET (BLKFLG) (COMP.ARGTYPE X))) then (* ;  "Incorrectly on one of the defining lists") (for ATYPEPAIR in ARGTYPE.VARS do (LET [(VAL (FMEMB X (EVALV (CADR ATYPEPAIR] (if (EQ AT (CAR ATYPEPAIR)) then (if VAL then (PRINTOUT COUTFILE "Compiler confused: " X " on " (CADR ATYPEPAIR) " but compiler doesn't think its a " (CADDR ATYPEPAIR))) [/SETTOPVAL (CADR ATYPEPAIR) (CONS X (PROGN (GETTOPVAL (CADR ATYPEPAIR] else (if VAL then (PRINTOUT COUTFILE "Warning: compiler thought " X " " (LIST 'a (OR (CADDR (ASSOC AT ARGTYPE.VARS)) "LAMBDA spread") 'function) " was a " (CADDR ATYPEPAIR) " because it was incorrectly on " (CADR ATYPEPAIR) T) (/SETTOPVAL (CADR ATYPEPAIR) (REMOVE X (PROGN (GETTOPVAL (CADR ATYPEPAIR]) (COMPILE.FILE.DEFINEQ [LAMBDA (FORM LCFIL) (* bvm%: "18-Sep-86 14:35") (for DEF in (CDR FORM) unless (FMEMB (CAR DEF) DONTCOMPILEFNS) do (COMPILE.CHECK.ARGTYPE (CAR DEF) (ARGTYPE (CADR DEF))) (BYTECOMPILE2 (CAR DEF) (COMPILE1A (CAR DEF) (CADR DEF) NIL]) (COMPILE-FILE-SETF-SYMBOL-FUNCTION [LAMBDA (FORM LCFIL) (* bvm%: " 8-Sep-86 16:55") (if [AND (FMEMB (CAR (LISTP (CL:THIRD FORM))) '(FUNCTION CL:FUNCTION)) (EQ (CAR (LISTP (CL:SECOND FORM))) 'QUOTE) (CL:CONSP (CL:SECOND (CL:THIRD FORM] then (BYTECOMPILE2 (CADR (CL:SECOND FORM)) (CADR (CL:THIRD FORM))) else (PRINT (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION)) LCFIL]) (COMPILE-FILE-EX/IMPORT [LAMBDA (FORM LCFIL RDTBL) (* bvm%: " 3-Aug-86 15:05") (* * "EXPORT, IMPORT, SHADOW, USE-PACKAGE are all implicitly EVAL@COMPILE, since they have to affect the package being used to read what follows") (PRINT FORM LCFIL RDTBL) (EVAL FORM]) (COMPILE.FILE.APPLY (LAMBDA (PROP FORM DEFER FORCE-OUTPUT-P) (* ; "Edited 29-Jun-90 19:21 by nm") (if FORCE-OUTPUT-P then (PRINT FORM COMPILED.FILE) else (if DEFER then (push DEFERRED.EXPRESSIONS (CONS PROP FORM)) else (APPLY* PROP FORM COMPILED.FILE)))) ) (COMPILE.FILE.RESET [LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME) (* bvm%: " 9-Sep-86 15:16") (* Cleans up after brecompile and  bcompl have finished operating,) (if (AND COMPILED.FILE (OPENP COMPILED.FILE)) then (CLOSE-AND-MAYBE-DELETE COMPILED.FILE)) (if SOURCEFILE then (CLOSEF? SOURCEFILE)) (if (NULL RESETSTATE) then (* Finished successfully.) (/SETATOMVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES)) (* Removes FILES from  NOTCOMPILEDFILES.)]) (COMPILE-IN-CORE [LAMBDA (fn-name fn-expr fn-type NOSAVE) (DECLARE (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD)) (* lmm " 2-Jun-86 22:04") (* in-core compiling for functions and forms, without the interview.  if X is a list, we assume that we are being called merely to display the lap  and machine code. the form is compiled as the definition of FOO but the  compiled :CODE is thrown away. -  if X is a litatom, then saving, redefining, and printing is controlled by the  flags.) (LET ((NOREDEFINE NIL) (PRINTLAP NIL) (DONT-TRANSFER-PUTD T)) (RESETVARS [(NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST) (COUTFILE (COND ((AND (BOUNDP 'NULLFILE) (STREAMP NULLFILE) (OPENP NULLFILE)) NULLFILE) (T (SETQ NULLFILE (OPENFILE '{NULL} 'OUTPUT] (RETURN (RESETLST (* RESETLST to provide reset context  for macros under COMPILE1 as  generated e.g. by DECL.) [PROG ((LCFIL) [LAPFLG (AND PRINTLAP (COND (BYTECOMPFLG T) (T 2] (STRF (NOT NOREDEFINE)) (SVFLG (if (EQ fn-type 'SELECTOR) then 'SELECTOR else (NOT NOSAVE))) (LSTFIL T) (SPECVARS SYSSPECVARS) (LOCALVARS T)) (RETURN (PROGN (SETQ fn-expr (COMPILE1A fn-name fn-expr T)) (PROG ((FREEVARS FREEVARS)) (RETURN (BYTECOMPILE2 fn-name fn-expr])]) ) (DEFINEQ (COMPILE-FILE-SCAN-FIRST (LAMBDA (FORM COMPILED.FILE FIRSTFLG DOCOPY EVAL@COMPILE DEFER FORCE-OUTPUT-P) (* ; "Edited 30-Jun-90 18:32 by nm") (* ; "Edited 26-Apr-90 by tt") (* ; "This is enhancement for Fake Compiler's interpretation of file package coms") (PROG ((DFNFLG DFNFLG) (FIRST FIRSTFLG) (DOCOPY DOCOPY) (EVAL@COMPILE EVAL@COMPILE) NOTFIRST) (if (LISTP FORM) then (SELECTQ (CAR FORM) ((DECLARE%:) (CL:DO ((TAIL (CDR FORM) (CDR TAIL))) ((CL:ENDP TAIL)) (if (CL:SYMBOLP (CAR TAIL)) then (CASE (CAR TAIL) ((DOCOPY COPY) (SETQ DOCOPY T)) ((DONTCOPY) (SETQ DOCOPY NIL)) ((COPYWHEN) (SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL) ((EVAL@LOADWHEN) (CL:POP TAIL)) ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T)) ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL)) ((EVAL@COMPILEWHEN) (SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((FIRST) (SETQ FIRST T) (SETQ NOTFIRST NIL)) (* ; "for First") ((NOTFIRST) (SETQ NOTFIRST T) (SETQ FIRST NIL)) (* ; "for Not First") ((COMPILERVARS) (SETQ DFNFLG T)) (* ; "for Compilervars") (CL:OTHERWISE (CL:FORMAT COUTFILE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%" (CAR TAIL)))) else (COND ((EQ (QUOTE DECLARE%:) (CAR (CAR TAIL))) (COMPILE-FILE-SCAN-FIRST (CAR TAIL) COMPILED.FILE FIRST DOCOPY EVAL@COMPILE DEFER)) (T (CL:WHEN EVAL@COMPILE (EVAL (CAR TAIL))) (CL:WHEN DOCOPY (CL:IF FIRST (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS (CAR TAIL))) (CL:IF NOTFIRST (SETQ AFTERS (NCONC1 AFTERS (CAR TAIL))) (COMPILE-FILE-EXPRESSION (CAR TAIL) COMPILED.FILE EVAL@COMPILE DEFER FORCE-OUTPUT-P))))))))) ((FILECREATED) (if FORCE-OUTPUT-P then (PRINT FORM COMPILED.FILE) else (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS FORM)))) NIL)))) ) ) (* ; "This function is support for AR#11185") (RPAQQ ARGTYPE.VARS ((1 NLAML "NLAMBDA spread") (2 LAMA "LAMBDA nospread") (0 LAMS "LAMBDA spread") (3 NLAMA "NLAMBDA no-spread"))) (PUTPROPS DEFINEQ COMPILE-FILE-EXPRESSION COMPILE.FILE.DEFINEQ) (PUTPROPS * COMPILE-FILE-EXPRESSION NILL) (PUTPROPS SETF-SYMBOL-FUNCTION COMPILE-FILE-EXPRESSION COMPILE-FILE-SETF-SYMBOL-FUNCTION) (PUTPROPS PRETTYCOMPRINT COMPILE-FILE-EXPRESSION NILL) (CL:DEFUN COMPILE-FILE-DECLARE%: (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER) (CL:DO ((TAIL (CDR FORM) (CDR TAIL))) ((CL:ENDP TAIL)) (CL:IF (CL:SYMBOLP (CAR TAIL)) (CASE (CAR TAIL) ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL) ((EVAL@LOADWHEN) (CL:POP TAIL)) ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T)) ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL)) ((EVAL@COMPILEWHEN) (SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((COPY DOCOPY) (SETQ DOCOPY T)) ((DONTCOPY) (SETQ DOCOPY NIL)) ((COPYWHEN) (SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL)))))) ((FIRST)) ((NOTFIRST COMPILERVARS)) (CL:OTHERWISE (CL:FORMAT COUTFILE "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%" (CAR TAIL)))) (COND ((EQ (QUOTE DECLARE%:) (CAR (CAR TAIL))) (COMPILE-FILE-DECLARE%: (CAR TAIL) COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)) (T (CL:WHEN EVAL@COMPILE (EVAL (CAR TAIL))) (CL:WHEN DOCOPY (COMPILE-FILE-EXPRESSION (CAR TAIL) COMPILED.FILE EVAL@COMPILE DEFER))))))) (DEFINEQ (NEWDEFC [LAMBDA (NM DF) (* bvm%: "30-Sep-86 23:12") [COND ((EQ SVFLG 'DEFER) (push COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC) (KWOTE NM) (KWOTE DF) T))) ((OR (NULL DFNFLG) (EQ DFNFLG T)) [COND ((GETD NM) (VIRGINFN NM T) (COND ((NULL DFNFLG) (CL:FORMAT *ERROR-OUTPUT* "~&(~S redefined)~%%" NM) (SAVEDEF NM] (/PUTD NM DF T)) (T (* ;; "Save on CODE prop. Be nice and change it from archaic CCODEP object to modern compiled code object.") (/PUTPROP NM 'CODE (if (ARRAYP DF) then (create COMPILED-CLOSURE FNHEADER _ (fetch (ARRAYP BASE) of DF)) else DF] DF]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD (QUOTE NEWDEFC) (QUOTE DEFC)) ) (PUTPROPS CMLCOMPILE FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA) (ADDTOVAR NLAML) (ADDTOVAR LAMA FAKE-COMPILE-FILE) ) (PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1675 16480 (FAKE-COMPILE-FILE 1685 . 5121) (INTERLISP-FORMAT-P 5123 . 5341) ( INTERLISP-NLAMBDA-FUNCTION-P 5343 . 5577) (COMPILE-FILE-EXPRESSION 5579 . 8929) ( COMPILE-FILE-WALK-FUNCTION 8931 . 9178) (ARGTYPE.STATE 9180 . 9340) (COMPILE.CHECK.ARGTYPE 9342 . 11334) (COMPILE.FILE.DEFINEQ 11336 . 11829) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 11831 . 12425) ( COMPILE-FILE-EX/IMPORT 12427 . 12755) (COMPILE.FILE.APPLY 12757 . 13017) (COMPILE.FILE.RESET 13019 . 13880) (COMPILE-IN-CORE 13882 . 16478)) (16481 18210 (COMPILE-FILE-SCAN-FIRST 16491 . 18208)) (19612 20676 (NEWDEFC 19622 . 20674))))) STOP \ No newline at end of file diff --git a/sources/CMLDEFFER b/sources/CMLDEFFER new file mode 100644 index 00000000..a726e66c --- /dev/null +++ b/sources/CMLDEFFER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (il:filecreated " 4-Jun-90 15:11:57" il:|{PELE:MV:ENVOS}SOURCES>CMLDEFFER.;3| 50879 il:|changes| il:|to:| (il:functions defconstant) il:|previous| il:|date:| "16-May-90 13:03:22" il:|{PELE:MV:ENVOS}SOURCES>CMLDEFFER.;2| ) ; Copyright (c) 1986, 1900, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:cmldeffercoms) (il:rpaqq il:cmldeffercoms ( (il:* il:|;;;| "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.") (il:* il:|;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!! It is heavily self-referential and thick with bootstrapping problems. All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water... You have been warned.") (il:* il:|;;;| "Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init") (il:coms (il:* il:\; "Filepkg interface") (il:functions remove-comments pprint-definer pprint-definer-fitp pprint-definer-recurse) (il:variables il:*remove-interlisp-comments*) (il:* il:\; "Share with xcl?") (il:functions %define-type-deldef %define-type-getdef %define-type-file-definitions %define-type-filegetdef %define-type-save-defn %define-type-putdef)) (il:coms (il:* il:\;  "Compatibility with old cmldeffer") (il:declare\: il:docopy il:donteval@load (il:p (il:movd '%define-type-deldef 'il:\\define-type-deldef) (il:movd '%define-type-getdef 'il:\\define-type-getdef) (il:movd ' %define-type-file-definitions ' il:\\define-type-file-definitions ) (il:movd '%define-type-filegetdef 'il:\\define-type-filegetdef) (il:movd '%define-type-save-defn 'il:\\define-type-save-defn) (il:movd '%define-type-putdef 'il:\\define-type-putdef) (il:movd 'pprint-definer 'il:pprint-definer)))) (il:declare\: il:docopy il:donteval@load (il:p (il:* il:|;;| "Set up fake definer prototype stuff for FNS") (add-prototype-fn 'il:fns 'il:nlambda #'(lambda (name) (and (symbolp name) `(il:defineq (,name (il:nlambda ,@( %make-function-prototype ))))))) (add-prototype-fn 'il:fns 'il:lambda #'(lambda (name) (and (symbolp name) `(il:defineq (,name (il:lambda ,@( %make-function-prototype ))))))))) (il:coms (il:* il:\;  "The groundwork for bootstrapping ") (il:define-types il:define-types il:functions il:variables) (il:* il:\;  "DefDefiner itself and friends") (il:functions si::expansion-function si::macro-funcall without-filepkg)) (il:coms (il:* il:\;  "Compatibility with old cmldeffer") (il:functions il:without-filepkg)) (il:coms (il:* il:\; "Some special forms") (il:functions definer named-progn)) (il:coms (il:* il:\; "Auxiliary functions") (il:functions get-definer-name %delete-definer) (il:functions def-define-type defdefiner) (il:functions %expand-definer %definer-name)) (il:coms (il:* il:\;  "The most commonly-used definers") (il:functions defun definline defmacro) (il:functions defvar defparameter defconstant defglobalvar defglobalparameter)) (il:coms (il:* il:\;  "Here so that the evaluator can be in the init without definers being in the init.") (il:define-types il:special-forms) (il:functions %remove-special-form) (il:functions define-special-form) (il:* il:\;  "Form for defining interpreters of special forms") ) (il:coms (il:* il:\;  "Don't note changes to these properties/variables") (il:prop il:proptype il:macro-fn :undefiners il:undefiners :definer-for il:definer-for :defined-by il:defined-by :definition-name il:definition-name ) (il:* il:\;  "Templates for definers not defined here. These should really be where they're defined.") (il:prop :definition-print-template defcommand define-condition define-modify-macro define-setf-method defsetf defstruct deftype)) (il:* il:|;;| "Arrange for the correct compiler to be used.") (il:prop (il:filetype il:makefile-environment) il:cmldeffer))) (il:* il:|;;;| "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.") (il:* il:|;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!! It is heavily self-referential and thick with bootstrapping problems. All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water... You have been warned." ) (il:* il:|;;;| "Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init" ) (il:* il:\; "Filepkg interface") (defun remove-comments (x) (il:* il:|;;;| "Removes SEdit-style comments from the given list structure.") (cond ((not (consp x)) x) ((and (consp (car x)) (eq (caar x) 'il:*) (consp (cdar x)) (or (member (cadar x) '(il:\; il:|;;| il:|;;;| il:|;;;;| il:\|) :test #'eq) (il:* il:\; "a sedit comment") (eq il:*remove-interlisp-comments* t) (il:* il:\; "always strip") (progn (if (eq il:*remove-interlisp-comments* ':warn) (warn "Possible comment not stripped ~S" (car x))) nil))) (remove-comments (cdr x))) (t (let ((a (remove-comments (car x))) (d (remove-comments (cdr x)))) (if (and (eq a (car x)) (eq d (cdr x))) x (cons a d)))))) (defun pprint-definer (define-expression) (declare (special il:formflg il:spacewidth)) (il:* il:\; "Bound in prettyprinter") (cond ((or (null il:formflg) (atom (cdr define-expression))) (il:* il:\;  "Degenerate cases or printing as a quoted form--punt to default prettyprinting") define-expression) (t (let ((il:tail define-expression) (il:left (il:dspxposition)) template top-level-p next type form newlinep) (declare (special il:tail il:left)) (il:* il:\; "For comment printer") (setq top-level-p (eq il:left (il:dspleftmargin))) (il:* il:\;  "Printing definition to file, etc.") (setq il:left (+ il:left (* 3 il:spacewidth))) (il:* il:\;  "Place we will indent body") (il:prin1 "(") (il:prin2 (car il:tail)) (setq template (or (get (pop il:tail) :definition-print-template) '(:name))) (il:* il:|;;| "This code should, and doesn't, pay attention to the NAME function to determine where the name is to decide what should and shouldn't be bold. Right now, it always bolds the second thing. Fortunately, we currently don't have any definers that don't have either the second or CAR of the second as the definition name.") (il:* il:|;;| "Also, this code should be careful about calling the NAME function on the form. Sometimes, the form is not really a call to the definer but instead a back-quoted expression in a macro. In most such cases, the name is not really there; some comma-quoted expression is there instead.") (il:while (consp il:tail) il:do (cond ((and (listp (setq next (car il:tail))) (eq (car next) il:commentflg) (il:semi-colon-comment-p next)) (il:* il:\; "Comments can appear anywhere, so print this one without consuming the template. ENDLINE has side effect of printing comments") (il:subprint/endline il:left *standard-output*) (setq newlinep t)) ((or (atom template) (eq (setq type (pop template)) :body)) (il:* il:\;  "Once we hit the body, there's nothing more special to do.") (return)) (t (il:spaces 1) (case type (:name (il:* il:\;  "Embolden the name of this thing") (setq newlinep nil) (cond ((not top-level-p) (il:* il:\;  "Nothing special here--could even be a backquoted thing") (pprint-definer-recurse)) (t (pop il:tail) (cond ((consp next) (il:* il:\;  "Name is a list. Assume the real name is the car and the rest is an options list or something") (unless (eq (il:dspyposition) (progn (il:prin1 "(") (il:printout nil il:.font il:lambdafont il:|.P2| (car next) il:.font il:defaultfont) (il:spaces 1) (il:printdef (cdr next) t t t il:fnslst) (il:prin1 ")") (il:dspyposition))) (il:* il:\;  "This thing took more than one line to print, so go to new line") (il:subprint/endline il:left *standard-output*) (setq newlinep t))) (t (il:* il:\; "Atomic name is bold") (il:printout nil il:.font il:lambdafont il:|.P2| next il:.font il:defaultfont)))))) (:arg-list (il:* il:\;  "NEXT is some sort of argument list. ") (cond ((null next) (il:* il:\;  "If NIL, be sure to print as ()") (il:prin1 "()") (pop il:tail)) (t (pprint-definer-recurse))) (setq newlinep nil)) (t (il:* il:\;  "Just print it, perhaps starting a new line") (unless (or newlinep (pprint-definer-fitp next)) (il:* il:\;  "Go to new line if getting crowded") (il:prinendline il:left)) (pprint-definer-recurse) (setq newlinep nil)))))) (il:* il:|;;|  "We've now gotten to the end of stuff we know how to print. Just prettyprint the rest") (unless (null il:tail) (cond (newlinep (il:* il:\; "Already on new line")) ((or (eq type :body) (not (pprint-definer-fitp (car il:tail)))) (il:* il:\; "Go to new line and indent a bit. Always do this for the part matching &BODY, whether or not the prettyprinter thought that the remainder would \"fit\"") (il:prinendline il:left nil t)) (t (il:spaces 1))) (il:while (and (consp il:tail) (atom (setq form (car il:tail)))) il:do (il:* il:|;;| "Print this doc string or whatever on its own line. This is because otherwise the prettyprinter gets confused and tries to put the next thing after the string") (pprint-definer-recurse) (when (and (keywordp form) (consp il:tail)) (il:* il:\;  "Some sort of keyword-value pair stuff--print it on same line") (il:spaces 1) (pprint-definer-recurse)) (when (null il:tail) (return)) (il:subprint/endline il:left *standard-output*)) (il:printdef il:tail t t t il:fnslst)) (il:prin1 ")") nil)))) (defun pprint-definer-fitp (item) (il:* il:|;;| "True if it won't look silly to try to print ITEM at current position instead of starting new line") (if (consp item) (or (eq (car item) il:commentflg) (and (< (il:count item) 20) (il:fitp item))) (< (+ (il:dspxposition) (il:stringwidth item *standard-output*)) (il:dsprightmargin)))) (defun pprint-definer-recurse () (il:* il:|;;|  "Print and pop the next element. Prettyprinter uses the variable IL:TAIL for lookahead") (declare (special il:tail)) (il:superprint (car il:tail) il:tail nil *standard-output*) (setq il:tail (cdr il:tail))) (defvar il:*remove-interlisp-comments* ':warn "Either NIL (don't) T (always do) or :WARN (don't and warn)") (il:* il:\; "Share with xcl?") (defun %define-type-deldef (name type) (il:* il:|;;| "DELETE definition of definer-defined NAME as TYPE ") (undoably-setf (documentation name type) nil) (let* ((ht (gethash type *definition-hash-table*)) (defn (and ht (gethash name ht)))) (and ht (il:/puthash name nil ht)) (dolist (fn (or (get type ':undefiners) (get type 'il:undefiners))) (funcall fn name)) (dolist (fn (or (get (car defn) ':undefiners) (get (car defn) 'il:undefiners))) (funcall fn name)) name)) (defun %define-type-getdef (name type options) (il:* il:|;;| "GETDEF method for all definers. The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.") (let* ((hash-table (gethash type *definition-hash-table*)) (defn (and hash-table (gethash name hash-table)))) (if (typecase options (cons (member 'il:edit options :test #'eq)) (t (eq options 'il:edit))) (copy-tree defn) defn))) (defun %define-type-file-definitions (type names) (il:* il:|;;|  "get the definitions for NAMES suitable for printing on a file. Like GETDEF but checks.") (mapcar #'(lambda (name) (let ((def (%define-type-getdef name type '(il:nocopy)))) (if (null def) (error 'il:no-such-definition :name name :type type) def))) names)) (defun %define-type-filegetdef (name type source options notfound) (let ((val (il:loadfns nil source 'il:getdef (il:* il:|;;|  "The bletcherous lambda form is require by the interface to loadfns (can't pass a closure)") `(il:lambda (first second) (and (member first ',(or (get type ':defined-by) (get type 'il:defined-by)) :test #'eq) (let ((namer (or (get first ':definition-name) (get first 'il:definition-name) 'second))) (if (eq namer 'second) (equal second ',name) (equal (funcall namer (remove-comments (il:read))) ',name)))))))) (cond ((eq (caar val) 'il:not-found\:) notfound) ((cdr val) (cons 'progn val)) (t (car val))))) (defun %define-type-save-defn (name type definition) (setq type (il:getfilepkgtype type 'type)) (let ((hash-table (gethash type *definition-hash-table*))) (when (null hash-table) (warn "Couldn't find a hash-table for ~S definitions.~%One will be created." type) (setq hash-table (setf (gethash type *definition-hash-table*) (make-hash-table :test #'equal :size 50 :rehash-size 50)))) (let ((old-definition (gethash name hash-table))) (unless (equal definition old-definition) (when (and old-definition (not (eq il:dfnflg t))) (format *terminal-io* "~&New ~A definition for ~S~:[~; (but not installed)~].~%" type name (member il:dfnflg '(il:prop il:allprop) :test #'eq))) (il:/puthash name definition hash-table) (il:markaschanged name type (if old-definition 'il:changed 'il:defined)))))) (defun %define-type-putdef (name type definition reason) (if (null definition) (%define-type-deldef name type) (let ((defn-without-comments (remove-comments definition))) (unless (and (consp defn-without-comments) (member (car defn-without-comments) (or (get type ':defined-by) (get type 'il:defined-by)) :test #'eq) (equal name (funcall (or (get (car defn-without-comments) ':definition-name) (get (car defn-without-comments) 'il:definition-name) 'second) defn-without-comments))) (signal 'il:definer-mismatch :name name :type type :definition definition)) (setq definition (copy-tree definition)) (eval (if il:lispxhist (make-undoable definition) definition))))) (il:* il:\; "Compatibility with old cmldeffer") (il:declare\: il:docopy il:donteval@load (il:movd '%define-type-deldef 'il:\\define-type-deldef) (il:movd '%define-type-getdef 'il:\\define-type-getdef) (il:movd '%define-type-file-definitions 'il:\\define-type-file-definitions) (il:movd '%define-type-filegetdef 'il:\\define-type-filegetdef) (il:movd '%define-type-save-defn 'il:\\define-type-save-defn) (il:movd '%define-type-putdef 'il:\\define-type-putdef) (il:movd 'pprint-definer 'il:pprint-definer) ) (il:declare\: il:docopy il:donteval@load (il:* il:|;;| "Set up fake definer prototype stuff for FNS") (add-prototype-fn 'il:fns 'il:nlambda #'(lambda (name) (and (symbolp name) `(il:defineq (,name (il:nlambda ,@( %make-function-prototype ))))))) (add-prototype-fn 'il:fns 'il:lambda #'(lambda (name) (and (symbolp name) `(il:defineq (,name (il:lambda ,@( %make-function-prototype ))))))) ) (il:* il:\; "The groundwork for bootstrapping ") (def-define-type il:define-types "Definition type") (def-define-type il:functions "Common Lisp functions/macros" :undefiner il:undoably-fmakunbound) (def-define-type il:variables "Common Lisp variables" :undefiner undoably-makunbound) (il:* il:\; "DefDefiner itself and friends") (defun si::expansion-function (name arg-list body) (il:* il:|;;;| "Shared code between DEFMACRO and DEFDEFINER. Takes the parts of a DEFMACRO and returns two values: a LAMBDA form for the expansion function, and the documentation string found, if any.") (multiple-value-bind (parsed-body parsed-declarations parsed-docstring) (il:parse-defmacro arg-list 'si::$$macro-form body name nil :environment 'si::$$macro-environment) (values `(lambda (si::$$macro-form si::$$macro-environment) ,@parsed-declarations (block ,name ,parsed-body)) parsed-docstring))) (defmacro si::macro-funcall (expansion-function macro-call env) (il:* il:|;;;| "Used by DEFDEFINER as a mechanism for delaying macro-expansion until after checking the value of DFNFLG. The arguments (unevaluated) are a macro-expansion function and a call on that macro. The call to MACRO-FUNCALL should expand into the result of expanding the given macro-call.") (funcall expansion-function macro-call env)) (defmacro without-filepkg (&body body) `(progn (eval-when (load) ,@body) (eval-when (eval) (unless (or (eq il:dfnflg 'il:prop) (eq il:dfnflg 'il:allprop)) (let ((il:filepkgflg nil) (il:dfnflg t)) ,@body))))) (il:* il:\; "Compatibility with old cmldeffer") (defmacro il:without-filepkg (&body body) `(without-filepkg ,@body)) (il:* il:\; "Some special forms") (defmacro definer (type name definition &optional env) (let* ((expander (get name :definition-expander)) (definition-without-comments (remove-comments definition)) (definition-name (funcall (get name :definition-name) definition-without-comments))) `(progn (without-filepkg (si::macro-funcall ,expander ,definition-without-comments ,env)) (eval-when (eval) (unless (null il:filepkgflg) (%define-type-save-defn ',definition-name ',type ',definition))) ',definition-name))) (defmacro named-progn (definer name &rest forms) (il:* il:|;;| "Used by the compiler when processing definers") `(progn ,@forms ',name)) (il:* il:\; "Auxiliary functions") (defun get-definer-name (definer string) (values (intern (concatenate 'string string (string definer)) (symbol-package definer)))) (defun %delete-definer (name) (and (symbolp name) (let ((type (or (get name ':definer-for) (get name 'il:definer-for)))) (il:/remprop name ':definer-for) (il:/remprop name 'il:definer-for) (il:/remprop name ':definition-name) (il:/remprop name 'il:definition-name) (il:/remprop name ':definition-expander) (when type (if (get type ':defined-by) (il:/putprop type ':defined-by (remove name (get type ':defined-by))) (il:/putprop type 'il:defined-by (remove name (get type 'il:defined-by)))) (il:* il:|;;| "need to remove the prototype function!") (let* ((lookup-type (assoc type *definition-prototypes* :test #'eq))) (il:/rplacd lookup-type (remove name (cdr lookup-type) :key #'car))))))) (defdefiner (def-define-type (:prototype (lambda (name) (and (symbolp name) `(def-define-type ,name "Description string") )))) il:define-types (name description &key undefiner &aux (changelst (intern (concatenate 'string "CHANGED" (string name) "LST") (symbol-package name)))) "Define NAME as a new definition type" (il:* il:|;;| "This definition is a clean interface to a hokey implementation. It works even before the file package is loaded.") `(progn (setf (documentation ',name 'il:define-types) ',description) (pushnew '(,name x (il:p il:* (%define-type-file-definitions ',name 'x))) il:prettydefmacros :test 'equal) (il:* il:|;;| "the information about a type in the file package is split up into a number of different places. PRETTYTYPELST contains a random amount: the changelist is the variable whose top level value contains the list of changed items, and the description is a string used by files? This is duplicated in the CL:DOCUMENTATION mechanism") (pushnew '(,changelst ,name ,description) il:prettytypelst :test 'equal) (defglobalvar ,changelst nil) (il:* il:|;;| "the definition hash table is where the definitions are really stored. Create an entry for this type. Note that definitions are compared using CL:EQUAL so that names can be strings, lists, etc.") (unless (gethash ',name *definition-hash-table*) (setf (gethash ',name *definition-hash-table*) (make-hash-table :test 'equal :size 50 :rehash-size 50))) (pushnew ',name il:filepkgtypes) (setf (get ',name 'il:getdef) '%define-type-getdef) (setf (get ',name 'il:deldef) '%define-type-deldef) (setf (get ',name 'il:putdef) '%define-type-putdef) (setf (get ',name 'il:filegetdef) '%define-type-filegetdef) (setf (get ',name 'il:filepkgcontents) 'il:nill) ,@(when undefiner `((pushnew ',undefiner (get ',name ':undefiners)))))) (defdefiner (defdefiner (:name (lambda (whole) (let ((name (second whole))) (if (consp name) (car name) name)))) (:prototype (lambda (name) (and (symbolp name) `(defdefiner ,name ,(if (eq (il:editmode) 'il:sedit) (symbol-value (intern "BASIC-GAP" "SEDIT")) "Type") ,@(%make-function-prototype))))) (:undefiner %delete-definer) (:template (:name :type :arg-list :body))) il:functions (name type arg-list &body body) (let* ((options (cond ((consp name) (prog1 (cdr name) (setq name (car name)))) (t nil))) (name-fn nil) (undefiner nil) (prototype-fn nil) (template nil) (prettymacro nil)) (dolist (opt-list options) (case (car opt-list) ((:undefiner) (setq undefiner (cadr opt-list))) ((:name) (setq name-fn (cadr opt-list))) ((:prototype) (setq prototype-fn (cadr opt-list))) ((:template) (setq template (cadr opt-list))) ((:prettyprintmacro) (setq prettymacro (cadr opt-list))) (otherwise (cerror "Ignore the option" "Unrecognized option to DefDefiner: ~S" opt-list))) ) (multiple-value-bind (expansion-fn doc) (si::expansion-function name arg-list body) (unless (or template prettymacro (not (member '&body arg-list))) (il:* il:\;  "Tell default prettyprinter where the body is") (setq template (nconc (il:for x il:in arg-list il:until (eq x '&body) il:unless (member x lambda-list-keywords) il:collect nil) (list :body))) (when (and (null (car template)) (null name-fn)) (il:* il:\; "Name is in default place") (setf (car template) :name))) (let ((expander-name (get-definer-name name "definition-expander-")) (name-fn-name (if (consp name-fn) (get-definer-name name "name-fn-")))) `(progn (eval-when (load eval compile) (setf (get ',name ':definer-for) ',type) (pushnew ',name (get ',type ':defined-by)) (setf (symbol-function ',expander-name) #',expansion-fn) (setf (get ',name ':definition-expander) ',expander-name) ,@(if name-fn-name `((setf (symbol-function ',name-fn-name) #',name-fn))) (setf (get ',name ':definition-name) ',(or name-fn-name name-fn 'second)) ,@(and undefiner (let ((undefiner-fn-name (get-definer-name name "undefiner-fn-"))) `((setf (symbol-function ',undefiner-fn-name) #',undefiner) (pushnew ',undefiner-fn-name (get ',name ':undefiners))))) ,@(and prototype-fn (let ((prototype-fn-name (get-definer-name name "prototype-fn-"))) `((setf (symbol-function ',prototype-fn-name) #',prototype-fn) (add-prototype-fn ',type ',name ',prototype-fn-name)))) ,@(and doc `((setf (documentation ',name 'function) ,doc))) ,@(and template `((setf (get ',name ':definition-print-template) ',template))) (pushnew '(,name ,@(or prettymacro 'pprint-definer)) il:prettyprintmacros :test 'equal)) (defmacro ,name (&whole definition &environment env) `(definer ,',type ,',name ,definition ,env))))))) (defun %expand-definer (definer definition-without-comments &optional env) (funcall (get definer :definition-expander) definition-without-comments env)) (defun %definer-name (definer definition-without-comments) (funcall (get definer :definition-name) definition-without-comments)) (il:* il:\; "The most commonly-used definers") (defdefiner (defun (:prototype (lambda (name) (and (symbolp name) `(defun ,name ,@(%make-function-prototype))))) (:template (:name :arg-list :body))) il:functions (name args &body (body decls documentation)) `(progn (setf (symbol-function ',name) #'(,'lambda ,args ,@decls (block ,name ,@body))) ,@(and documentation `((setf (documentation ',name 'function) ,documentation))))) (defdefiner (definline (:prototype (lambda (name) (and (symbolp name) `(definline ,name ,@(%make-function-prototype))))) (:template (:name :arg-list :body))) il:functions (name arg-list &body body &environment env) (il:* il:|;;;| "This is an INTERIM version of DEFINLINE. Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE. (It says so right here.) If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE. If you do, the compiler will run forever trying to expand the optimizer... Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.") (multiple-value-bind (code decls doc) (parse-body body env t) (let ((new-lambda `(,'lambda ,arg-list ,@decls (block ,name ,@code)))) `(progn (defun ,name ,arg-list ,@body) (defoptimizer ,name ,(pack (list "definline-" name) (symbol-package name)) (&rest args) (cons ',new-lambda args)))))) (defdefiner (defmacro (:prototype (lambda (name) (and (symbolp name) `(defmacro ,name ,@(%make-function-prototype))))) (:undefiner (lambda (name) (remprop name 'il:argnames))) (:template (:name :arg-list :body))) il:functions (name defmacro-args &body defmacro-body) (unless (and name (symbolp name)) (error "Illegal name used in DEFMACRO: ~S" name)) (let ((cmacroname (pack (list "expand-" name) (symbol-package name)))) (multiple-value-bind (expansion-fn doc-string) (si::expansion-function name defmacro-args defmacro-body) `(progn (setf (symbol-function ',cmacroname) #',expansion-fn) (setf (macro-function ',name) ',cmacroname) ,@(and doc-string `((setf (documentation ',name 'function) ,doc-string))) ,@(when compiler::*new-compiler-is-expanding* `((setf (get ',name 'il:argnames) ',(mapcar #'(lambda (arg) (if (member arg lambda-list-keywords) arg (prin1-to-string arg))) (il:\\simplify.cl.arglist defmacro-args))))))))) (defdefiner (defvar (:prototype (lambda (name) (and (symbolp name) `(defvar ,name))))) il:variables (name &optional (initial-value nil ivp) documentation) `(progn (proclaim '(special ,name)) ,@(and ivp `((or (boundp ',name) (setq ,name ,initial-value)))) ,@(and documentation `((setf (documentation ',name 'variable) ,documentation))))) (defdefiner (defparameter (:prototype (lambda (name) (and (symbolp name) `(defparameter ,name "Value" "Documentation string"))))) il:variables ( name initial-value &optional documentation ) `(progn (proclaim '(special ,name)) (setq ,name ,initial-value) ,@(and documentation `((setf (documentation ',name 'variable) ,documentation))))) (defdefiner (defconstant (:prototype (lambda (name) (and (symbolp name) `(defconstant ,name "Value" "Documentation string"))))) il:variables ( name value &optional documentation ) `(progn ,@(if (constantp name) `((set-constantp ',name nil))) (setq ,name ,value) (proclaim '(si::constant ,name)) ,@(and documentation `((setf (documentation ',name 'variable) ,documentation))))) (defdefiner (defglobalvar (:prototype (lambda (name) (and (symbolp name) `(defglobalvar ,name))))) il:variables (name &optional ( initial-value nil ivp) documentation ) (il:* il:|;;| "Use IL:SETQ here or the INIT dies.") `(progn (proclaim '(global ,name)) ,@(and ivp `((or (boundp ',name) (setq ,name ,initial-value)))) ,@(and documentation `((setf (documentation ',name 'variable) ,documentation))))) (defdefiner (defglobalparameter (:prototype (lambda (name) (and (symbolp name) `(defglobalparameter ,name "Value" "Documentation string"))))) il:variables (name initial-value &optional documentation) `(progn (proclaim '(global ,name)) (setq ,name ,initial-value) ,@(and documentation `((setf (documentation ',name 'variable) ,documentation))))) (il:* il:\; "Here so that the evaluator can be in the init without definers being in the init.") (def-define-type il:special-forms "Common Lisp special forms" :undefiner %remove-special-form) (defun %remove-special-form (x) (il:/remprop x 'il:special-form)) (defdefiner (define-special-form (:template (:name :arg-list :body))) il:special-forms (name args &rest body) (cond ((null body) (assert (symbolp name) nil "Ill-formed short DEFINE-SPECIAL-FORM; ~S is not a symbol." args) `(setf (get ',name 'il:special-form) ',args)) (t (let ((sf (intern (concatenate 'string "interpret-" (string name)) (symbol-package name)))) (multiple-value-bind (parsed-body decls doc) (il:parse-defmacro args '$$tail body name nil :path '$$tail :environment '$$env) `(progn (setf (symbol-function ',sf) #'(lambda ($$tail $$env) ,@decls (block ,name ,parsed-body))) (setf (get ',name 'il:special-form) ',sf))))))) (il:* il:\; "Form for defining interpreters of special forms") (il:* il:\; "Don't note changes to these properties/variables") (il:putprops il:macro-fn il:proptype il:functions) (il:putprops :undefiners il:proptype ignore) (il:putprops il:undefiners il:proptype ignore) (il:putprops :definer-for il:proptype ignore) (il:putprops il:definer-for il:proptype ignore) (il:putprops :defined-by il:proptype ignore) (il:putprops il:defined-by il:proptype ignore) (il:putprops :definition-name il:proptype ignore) (il:putprops il:definition-name il:proptype ignore) (il:* il:\; "Templates for definers not defined here. These should really be where they're defined.") (il:putprops defcommand :definition-print-template (:name :arg-list :body)) (il:putprops define-condition :definition-print-template (:name :value :body)) (il:putprops define-modify-macro :definition-print-template (:name :arg-list)) (il:putprops define-setf-method :definition-print-template (:name :arg-list :body)) (il:putprops defsetf :definition-print-template (:name :arg-list :arg-list :body)) (il:putprops defstruct :definition-print-template (:name :body)) (il:putprops deftype :definition-print-template (:name :arg-list :body)) (il:* il:|;;| "Arrange for the correct compiler to be used.") (il:putprops il:cmldeffer il:filetype :compile-file) (il:putprops il:cmldeffer il:makefile-environment (:readtable "XCL" :package "XCL")) (il:putprops il:cmldeffer il:copyright ("Venue & Xerox Corporation" 1986 1900 1987 1988 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/CMLDESTRUCT b/sources/CMLDESTRUCT new file mode 100644 index 00000000..e2bbbb59 --- /dev/null +++ b/sources/CMLDESTRUCT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 13:05:47" {DSK}local>lde>lispcore>sources>CMLDESTRUCT.;2 2660 changes to%: (VARS CMLDESTRUCTCOMS) previous date%: "29-Apr-87 11:30:49" {DSK}local>lde>lispcore>sources>CMLDESTRUCT.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLDESTRUCTCOMS) (RPAQQ CMLDESTRUCTCOMS ((FUNCTIONS DESTRUCTURING-BIND DESTRUCTURING-SETQ EXPAND-DESTRUCTURING-BIND) (* ;; "Arrange for the correct compiler to be used.") (PROP FILETYPE CMLDESTRUCT))) (DEFMACRO DESTRUCTURING-BIND (PATTERN FORM &BODY BODY &ENVIRONMENT ENV) (EXPAND-DESTRUCTURING-BIND PATTERN FORM BODY ENV)) (DEFMACRO DESTRUCTURING-SETQ (VARS VALUE) [IF (NULL VARS) THEN VALUE ELSEIF (NLISTP VARS) THEN `(SETQ ,VARS ,VALUE) ELSEIF (NULL (CDR VARS)) THEN `(DESTRUCTURING-SETQ ,(CAR VARS) (CAR ,VALUE)) ELSEIF (LISTP VALUE) THEN [LET ((DV (GENSYM))) `(LET ((,DV ,VALUE)) (DESTRUCTURING-SETQ ,(CAR VARS) (CAR ,DV)) (DESTRUCTURING-SETQ ,(CDR VARS) (CDR ,DV] ELSE `(PROGN (DESTRUCTURING-SETQ ,(CAR VARS) (CAR ,VALUE)) (DESTRUCTURING-SETQ ,(CDR VARS) (CDR ,VALUE]) (CL:DEFUN EXPAND-DESTRUCTURING-BIND (PATTERN FORM BODY ENVIRONMENT) (* ;;; "A compiled function so that circularity of MULTIPLE-VALUE-BIND isn't caught. DO NOT try to run with this function interpreted!") [LET ((WHOLE-VAR (GENSYM))) (CL:MULTIPLE-VALUE-BIND (CODE DECLARATIONS) (PARSE-DEFMACRO PATTERN WHOLE-VAR BODY 'DESTRUCTURING-BIND ENVIRONMENT :PATH WHOLE-VAR :DOC-STRING-ALLOWED NIL) (CL:ASSERT (EQ (CAR CODE) 'LET*) NIL "BUG: PARSE-DEFMACRO didn't return a LET* form.") `(,'LET* ((,WHOLE-VAR ,FORM) ,@(CADR CODE)) ,@DECLARATIONS ,@(CDDR CODE]) (* ;; "Arrange for the correct compiler to be used.") (PUTPROPS CMLDESTRUCT FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLDESTRUCT COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLDOC b/sources/CMLDOC new file mode 100644 index 00000000..5cb6a89e --- /dev/null +++ b/sources/CMLDOC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 13:06:35" {DSK}local>lde>lispcore>sources>CMLDOC.;2 3285 changes to%: (VARS CMLDOCCOMS) previous date%: "19-Mar-87 12:29:50" {DSK}local>lde>lispcore>sources>CMLDOC.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLDOCCOMS) (RPAQQ CMLDOCCOMS ( (* ;;; "Documentation strings") (VARIABLES *DOCUMENTATION-HASH-TABLE*) (FUNCTIONS CL:DOCUMENTATION HASH-TABLE-FOR-DOC-TYPE SET-DOCUMENTATION) (SETFS CL:DOCUMENTATION) (* ;; "Use the proper compiler") (PROP FILETYPE CMLDOC))) (* ;;; "Documentation strings") (DEFGLOBALVAR *DOCUMENTATION-HASH-TABLE* (* ;;; "This is the repository for all documentation strings in the system. It is a two-level hash-table scheme, just like *definition-hash-table*. At the first level, *DOCUMENTATION-HASH-TABLE* maps the symbols that name documentation-types into a separate hash table for each type. Those tables map names into the documentation strings for those names. The first-level table uses an EQ test while the second-level ones use CL:EQUAL.") (* ;; "The hash-table is initialized to have second-level tables for each of the required documentation types.") (LET ((CL::HT (CL:MAKE-HASH-TABLE :TEST 'EQ :SIZE 10 :REHASH-SIZE 5))) [FOR TYPE-LIST IN '((TYPES TYPE) (SETFS CL:SETF) (STRUCTURES CL:STRUCTURE RECORD RECORDS) (FUNCTIONS CL:FUNCTION FN FNS) (VARIABLES CL:VARIABLE VAR VARS)) DO (LET ((TABLE (CL:MAKE-HASH-TABLE :TEST 'CL:EQUAL :SIZE 50 :REHASH-SIZE 50))) (FOR TYPE IN TYPE-LIST DO (CL:SETF (CL:GETHASH TYPE CL::HT) TABLE] CL::HT)) (CL:DEFUN CL:DOCUMENTATION (NAME DOC-TYPE) (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE))) (CL:DEFUN HASH-TABLE-FOR-DOC-TYPE (DOC-TYPE) (OR (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*) (AND FILEPKGFLG (GETHASH (SETQ DOC-TYPE (GETFILEPKGTYPE DOC-TYPE 'TYPE)) (* ;;  "note that GETFILEPKGTYPE will signal an error if it doesn't recognize the type.") *DOCUMENTATION-HASH-TABLE*)) (CL:SETF (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*) (CL:MAKE-HASH-TABLE :TEST 'CL:EQUAL :SIZE 50 :REHASH-SIZE 50)))) (CL:DEFUN SET-DOCUMENTATION (NAME DOC-TYPE NEW-STRING) (CL:IF LISPXHIST (UNDOABLY-SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE)) NEW-STRING)) (CL:SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE DOC-TYPE)) NEW-STRING)) (CL:DEFSETF CL:DOCUMENTATION SET-DOCUMENTATION) (* ;; "Use the proper compiler") (PUTPROPS CMLDOC FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLDOC COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLENVIRONMENT b/sources/CMLENVIRONMENT new file mode 100644 index 00000000..44448461 --- /dev/null +++ b/sources/CMLENVIRONMENT @@ -0,0 +1,177 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") +(IL:FILECREATED " 3-Sep-93 09:49:06" IL:|{PELE:MV:ENVOS}SOURCES>CMLENVIRONMENT.;4| 7109 + + IL:|changes| IL:|to:| (IL:VARIABLES *FEATURES*) + + IL:|previous| IL:|date:| " 8-Nov-90 17:26:56" +IL:|{PELE:MV:ENVOS}SOURCES>CMLENVIRONMENT.;3|) + + +; Copyright (c) 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:CMLENVIRONMENTCOMS) + +(IL:RPAQQ IL:CMLENVIRONMENTCOMS + ( + (IL:* IL:|;;| "Misc environmental functions:") + + (IL:FUNCTIONS LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION MACHINE-INSTANCE + MACHINE-VERSION SOFTWARE-TYPE SOFTWARE-VERSION MACHINE-TYPE) + (IL:VARIABLES XCL:*SHORT-SITE-NAME* XCL:*LONG-SITE-NAME*) + (IL:FUNCTIONS SHORT-SITE-NAME LONG-SITE-NAME) + (IL:FUNCTIONS ROOM) + (IL:COMS + + (IL:* IL:|;;| + "Functions for printing the system information for Customer Support:") + + (IL:FNS IL:PRINT-LISP-INFORMATION IL:PRINT-LOADED-FILE-INFORMATION)) + (IL:VARIABLES *FEATURES*) + (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) + IL:CMLENVIRONMENT))) + + + +(IL:* IL:|;;| "Misc environmental functions:") + + +(DEFUN LISP-IMPLEMENTATION-TYPE () + "Venue Medley") + +(DEFUN LISP-IMPLEMENTATION-VERSION () + (CONCATENATE 'STRING (STRING-CAPITALIZE IL:MAKESYSNAME) + " " + (IL:MKSTRING IL:LISP-RELEASE-VERSION) + " sysout of " IL:MAKESYSDATE)) + +(DEFUN MACHINE-INSTANCE () + (IL:SELECTC IL:\\MACHINETYPE + (IL:\\MAIKO (FORMAT NIL "~A ~A" (OR (IL:UNIX-GETPARM "HOSTID") + (IL:UNIX-GETENV "HOSTID")) + (OR (IL:UNIX-GETPARM "HOSTNAME") + (IL:UNIX-GETENV "HOSTNAME")))) + (LET ((HOST IL:\\MY.NSHOSTNUMBER)) + (FORMAT NIL "~@[~A = ~]~O#" (AND IL:\\PUP.READY (IL:ETHERHOSTNAME)) + (+ (ASH (SECOND HOST) + 32) + (ASH (THIRD HOST) + 16) + (FOURTH HOST)))))) + +(DEFUN MACHINE-VERSION () + (IL:SELECTQ (IL:MACHINETYPE) + (IL:MAIKO (IL:* IL:\; + "For emulators, convert the emulator creation date from microcodeversion.") + (FORMAT NIL "Emulator created: ~A, memory size: ~D" + (IL:SUBSTRING (IL:GDATE (+ (IL:IDATE "14-OCT-87 12:00:00") + (* 86400 (IL:MICROCODEVERSION)))) + 1 9) + (IL:REALMEMORYSIZE))) + (FORMAT NIL "Microcode version: ~D, memory size: ~D" (IL:MICROCODEVERSION) + (IL:REALMEMORYSIZE)))) + +(DEFUN SOFTWARE-TYPE () + "Envos Medley") + +(DEFUN SOFTWARE-VERSION () + (CONCATENATE 'STRING (LISP-IMPLEMENTATION-VERSION) + ", Make-init dates: " + (CAR IL:MAKEINITDATES) + ", " + (CADR IL:MAKEINITDATES))) + +(DEFUN MACHINE-TYPE () + (IL:SELECTC IL:\\MACHINETYPE + (IL:\\DANDELION "Xerox 1108") + (IL:\\DORADO "Xerox 1132") + (IL:\\DAYBREAK "Xerox 1186") + (IL:\\MAIKO (OR (IL:UNIX-GETPARM "MACH") + (IL:UNIX-GETENV "MACH"))) + (IL:MKSTRING (IL:MACHINETYPE)))) + +(DEFVAR XCL:*SHORT-SITE-NAME* NIL) + +(DEFVAR XCL:*LONG-SITE-NAME* NIL) + +(DEFUN SHORT-SITE-NAME () + (OR XCL:*SHORT-SITE-NAME* "Unknown")) + +(DEFUN LONG-SITE-NAME () + (OR XCL:*LONG-SITE-NAME* XCL:*SHORT-SITE-NAME* "Unknown")) + +(DEFUN ROOM (&OPTIONAL (TYPES NIL SP) + (PAGE-LIMIT (IF SP + NIL + 20)) + (IN-USE-LIMIT NIL)) + + (IL:* IL:|;;| "The three args are identical to those of IL:STORAGE, except that TYPES = NIL, T or omitted is handled per silver book (small, maximal, medium, respectively).") + + (LET* ((STORAGE-LEFT (IL:STORAGE.LEFT)) + (DATA-REMAINING (ROUND (* 100 (SECOND STORAGE-LEFT)))) + (SYMBOLS-REMAINING (ROUND (* 100 (FIFTH STORAGE-LEFT)))) + (ONE-PERCENT-VMEM (ROUND (+ IL:\\LASTVMEMFILEPAGE 50) + 100)) + (VMEM-PERCENT (- 100 (ROUND (+ (IL:VMEMSIZE) + (ASH ONE-PERCENT-VMEM -1)) + ONE-PERCENT-VMEM)))) + (FORMAT T "Data area remaining:~25t~a%~%" DATA-REMAINING) + (FORMAT T "Symbol area remaining:~25t~a%~%" SYMBOLS-REMAINING) + (FORMAT T "Vmem remaining:~25t~a%~%" VMEM-PERCENT) + (WHEN (OR TYPES PAGE-LIMIT IN-USE-LIMIT) + (TERPRI T) + (WHEN (OR PAGE-LIMIT IN-USE-LIMIT) + (FORMAT T "Datatypes with at least") + (WHEN PAGE-LIMIT (FORMAT T " ~D pages allocated" PAGE-LIMIT IN-USE-LIMIT)) + (WHEN IN-USE-LIMIT (FORMAT T "~:[~; and at least~] ~D instances in use" PAGE-LIMIT + IN-USE-LIMIT)) + (FORMAT T ":~%~%")) + (IL:STORAGE (AND TYPES (NOT (EQ TYPES T)) + TYPES) + PAGE-LIMIT IN-USE-LIMIT)))) + + + +(IL:* IL:|;;| "Functions for printing the system information for Customer Support:") + +(IL:DEFINEQ + +(il:print-lisp-information + (il:lambda (il:file string) (il:* il:\; "Edited 7-Mar-88 15:24 by jds") + (il:printout (or il:file t) + (lisp-implementation-type) + " version " + (lisp-implementation-version) + " on " + (machine-type) + ", " + (machine-version) + ", " "machine " (machine-instance) + " based on " + (software-type) + " version " + (software-version) + t "Patch files: " il:\# (il:print-loaded-file-information il:file (or string "PATCH")) + ))) + +(il:print-loaded-file-information + (il:lambda (il:file string) (il:* il:|raf| " 2-Jan-86 17:37") + (il:|for| il:x il:|in| il:loadedfilelst il:|when| (il:strpos (or string "PATCH") + il:x) + il:|do| (il:printout il:file (il:namefield il:x) + " dated " + (caar (il:getprop (il:namefield il:x) + 'il:filedates)) + t)))) +) + +(DEFPARAMETER *FEATURES* '(:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT :MEDLEY)) + +(IL:PUTPROPS IL:CMLENVIRONMENT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) + +(IL:PUTPROPS IL:CMLENVIRONMENT IL:FILETYPE :COMPILE-FILE) +(IL:PUTPROPS IL:CMLENVIRONMENT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL (5523 6724 (IL:PRINT-LISP-INFORMATION 5536 . 6161) (IL:PRINT-LOADED-FILE-INFORMATION +6163 . 6722))))) +IL:STOP diff --git a/sources/CMLEVAL b/sources/CMLEVAL new file mode 100644 index 00000000..2260d241 --- /dev/null +++ b/sources/CMLEVAL @@ -0,0 +1,1265 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "30-Dec-93 14:27:43" |{DSK}export>lispcore>clos>2.0>CMLEVAL.;1| 102797 + + |changes| |to:| (OPTIMIZERS CL-EVAL-FN3-CALL) + + |previous| |date:| " 1-Apr-92 12:43:15" |{DSK}export>lispcore>sources>CMLEVAL.;1|) + + +; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. + +(PRETTYCOMPRINT CMLEVALCOMS) + +(RPAQQ CMLEVALCOMS ( + +(* |;;;| "Common Lisp interpreter") + + (COMS + (* |;;| "These really don't belong here") + + (FUNCTIONS CL:EQUAL CL:EQUALP) + + (* |;;| + "For the byte compiler: Optimize by constant fold and coerce to EQ where possible") + + (PROP BYTEMACRO CL:EQUAL CL:EQUALP) + (PROP DOPVAL CL:EQUAL)) + (COMS (FUNCTIONS \\REMOVE-DECLS) + (FUNCTIONS CL:SPECIAL-FORM-P)) + (COMS (SPECIAL-FORMS INTERLISP) + (PROP DMACRO INTERLISP COMMON-LISP) + (FNS COMMON-LISP)) + (COMS (ADDVARS (LAMBDASPLST CL:LAMBDA)) + (FNS \\TRANSLATE-CL\:LAMBDA) + (VARIABLES *CHECK-ARGUMENT-COUNTS* *SPECIAL-BINDING-MARK*)) + (VARIABLES CL:LAMBDA-LIST-KEYWORDS CL:CALL-ARGUMENTS-LIMIT + CL:LAMBDA-PARAMETERS-LIMIT) + (STRUCTURES CLOSURE ENVIRONMENT) + (FUNCTIONS \\MAKE-CHILD-ENVIRONMENT) + (COMS (FNS CL:EVAL \\EVAL-INVOKE-LAMBDA \\INTERPRET-ARGUMENTS + \\INTERPRETER-LAMBDA CHECK-BINDABLE CHECK-KEYWORDS) + (FUNCTIONS ARG-REF) + (PROP DMACRO .COMPILER-SPREAD-ARGUMENTS.)) + (FNS DECLARED-SPECIAL) + (COMS (* \; + "FUNCALL and APPLY, not quite same as Interlisp") + (FNS CL:FUNCALL CL:APPLY) + (PROP DMACRO CL:APPLY CL:FUNCALL)) + (COMS (* \; + "COMPILER-LET needs to work differently compiled and interpreted") + (FNS CL:COMPILER-LET COMP.COMPILER-LET) + (PROP DMACRO CL:COMPILER-LET) + (SPECIAL-FORMS CL:COMPILER-LET)) + (COMS (* \; + "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.") + (SPECIAL-FORMS CL:MACROLET CL:FLET CL:LABELS)) + (SPECIAL-FORMS QUOTE) + (COMS (SPECIAL-FORMS THE) + (PROP DMACRO THE)) + (COMS (PROP DMACRO CL:EVAL-WHEN) + (FNS CL:EVAL-WHEN) + (SPECIAL-FORMS CL:EVAL-WHEN)) + (COMS (SPECIAL-FORMS DECLARE) + (FUNCTIONS CL:LOCALLY)) + (COMS (* \; "Interlisp version on LLINTERP") + (SPECIAL-FORMS PROGN) + (FNS \\EVAL-PROGN)) + (COMS (* \; + "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex") + (* \; + "The Interlisp function is on LLINTERP") + (SPECIAL-FORMS PROG1) + (FUNCTIONS PROG1)) + (COMS (SPECIAL-FORMS LET* LET) + (PROP MACRO LET LET*) + (FNS \\LET*-RECURSION |\\LETtran|)) + (COMS (SPECIAL-FORMS COND) + (FUNCTIONS COND)) + (COMS (FNS CL:IF) + (SPECIAL-FORMS CL:IF) + (PROP DMACRO CL:IF)) + (COMS (* \; + "Interlisp NLAMBDA definitions on LLINTERP") + (* \; "both special form and macro") + (FUNCTIONS AND OR) + (SPECIAL-FORMS AND OR)) + (COMS (* \; "BLOCK and RETURN go together") + (FNS CL:BLOCK) + (PROP DMACRO CL:BLOCK) + (SPECIAL-FORMS CL:BLOCK) + (FUNCTIONS RETURN) + (FNS CL:RETURN-FROM) + (SPECIAL-FORMS CL:RETURN-FROM)) + (COMS (* \; + "IL and CL versions of FUNCTION.") + (FNS CL:FUNCTION) + (PROP DMACRO CL:FUNCTION) + (SPECIAL-FORMS CL:FUNCTION FUNCTION) + (FUNCTIONS CL:FUNCTIONP CL:COMPILED-FUNCTION-P)) + (SPECIAL-FORMS CL:MULTIPLE-VALUE-CALL CL:MULTIPLE-VALUE-PROG1) + (FNS COMP.CL-EVAL) + (FUNCTIONS CL:EVALHOOK CL:APPLYHOOK) + (VARIABLES *EVALHOOK* *APPLYHOOK* CL::*SKIP-EVALHOOK* CL::*SKIP-APPLYHOOK*) + (COMS (* \; "CONSTANTS mechanism") + (FNS CL:CONSTANTP) + (SETFS CL:CONSTANTP) + (FUNCTIONS XCL::SET-CONSTANTP)) + (COMS (* \; + "Interlisp SETQ for Common Lisp and vice versa") + (SPECIAL-FORMS CL:SETQ SETQ) + (PROP DMACRO CL:SETQ) + + (* |;;| + "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init") + + (FNS CL:SETQ) + (FUNCTIONS SETQ) + (FNS SET-SYMBOL) + (FUNCTIONS CL:PSETQ) + (FUNCTIONS SETQQ)) + (COMS (SPECIAL-FORMS CL:CATCH CL:THROW CL:UNWIND-PROTECT) + (FNS CL:THROW CL:CATCH CL:UNWIND-PROTECT)) + (COMS (FUNCTIONS PROG PROG*) + (SPECIAL-FORMS GO CL:TAGBODY) + (FNS CL:TAGBODY)) + (COMS (* \; "for macro caching") + (FNS CACHEMACRO) + (VARIABLES *MACROEXPAND-HOOK*) + (VARS (*IN-COMPILER-LET* NIL))) + (COMS + (* |;;| "PROCLAIM and friends.") + + + (* |;;| "Needs to come first because DEFVARs put it out. With package code in the init, also need this here rather than CMLEVAL") + + (FUNCTIONS CL:PROCLAIM) + (* \; "used by the codewalker, too") + (MACROS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-GLOBAL-P) + (FUNCTIONS XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P) + (FUNCTIONS XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P) + (SETFS XCL::DECL-SPECIFIER-P XCL::GLOBALLY-NOTINLINE-P) + (PROP PROPTYPE GLOBALLY-SPECIAL GLOBALVAR SI::DECLARATION-SPECIFIER + SI::GLOBALLY-NOTINLINE SPECIAL-FORM)) + (PROP (FILETYPE MAKEFILE-ENVIRONMENT) + CMLEVAL) + (DECLARE\: EVAL@COMPILE DONTCOPY (OPTIMIZERS CL-EVAL-FN3-CALL)) + (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) + (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA CL:TAGBODY CL:UNWIND-PROTECT CL:CATCH CL:SETQ CL:BLOCK + CL:EVAL-WHEN CL:COMPILER-LET COMMON-LISP) + (NLAML CL:THROW CL:FUNCTION CL:RETURN-FROM CL:IF) + (LAMA CL:APPLY CL:FUNCALL))))) + + + +(* |;;;| "Common Lisp interpreter") + + + + +(* |;;| "These really don't belong here") + + +(CL:DEFUN CL:EQUAL (CL::X CL::Y) + (CL:TYPECASE CL::X + (CL:SYMBOL (EQ CL::X CL::Y)) + (CL:NUMBER (EQL CL::X CL::Y)) + (CONS (AND (CL:CONSP CL::Y) + (CL:EQUAL (CAR CL::X) + (CAR CL::Y)) + (CL:EQUAL (CDR CL::X) + (CDR CL::Y)))) + (STRING (AND (CL:STRINGP CL::Y) + (CL:STRING= CL::X CL::Y))) + (CL:BIT-VECTOR (AND (CL:BIT-VECTOR-P CL::Y) + (LET ((CL::SX (CL:LENGTH CL::X))) + (AND (EQL CL::SX (CL:LENGTH CL::Y)) + (CL:DOTIMES (CL::I CL::SX T) + (CL:IF (NOT (EQ (BIT CL::X CL::I) + (BIT CL::Y CL::I))) + (RETURN NIL))))))) + (PATHNAME (AND (CL:PATHNAMEP CL::Y) + (%PATHNAME-EQUAL CL::X CL::Y))) + (T (EQ CL::X CL::Y)))) + +(CL:DEFUN CL:EQUALP (CL::X CL::Y) + (CL:TYPECASE CL::X + (CL:SYMBOL (EQ CL::X CL::Y)) + (CL:NUMBER (AND (CL:NUMBERP CL::Y) + (= CL::X CL::Y))) + (CONS (AND (CL:CONSP CL::Y) + (CL:EQUALP (CAR CL::X) + (CAR CL::Y)) + (CL:EQUALP (CDR CL::X) + (CDR CL::Y)))) + (CL:CHARACTER (AND (CL:CHARACTERP CL::Y) + (CL:CHAR-EQUAL CL::X CL::Y))) + (STRING (AND (CL:STRINGP CL::Y) + (STRING-EQUAL CL::X CL::Y))) + (PATHNAME (AND (CL:PATHNAMEP CL::Y) + (%PATHNAME-EQUAL CL::X CL::Y))) + (CL:VECTOR (AND (CL:VECTORP CL::Y) + (LET ((CL::SX (CL:LENGTH CL::X))) + (AND (EQL CL::SX (CL:LENGTH CL::Y)) + (CL:DOTIMES (CL::I CL::SX T) + (CL:IF (NOT (CL:EQUALP (CL:AREF CL::X CL::I) + (CL:AREF CL::Y CL::I))) + (RETURN NIL))))))) + (CL:ARRAY (AND (CL:ARRAYP CL::Y) + (CL:EQUAL (CL:ARRAY-DIMENSIONS CL::X) + (CL:ARRAY-DIMENSIONS CL::Y)) + (LET ((CL::FX (%FLATTEN-ARRAY CL::X)) + (CL::FY (%FLATTEN-ARRAY CL::Y))) + (CL:DOTIMES (CL::I (CL:ARRAY-TOTAL-SIZE CL::X) + T) + (CL:IF (NOT (CL:EQUALP (CL:AREF CL::FX CL::I) + (CL:AREF CL::FY CL::I))) + (RETURN NIL)))))) + (T + (* |;;| "so that datatypes will be properly compared") + + (OR (EQ CL::X CL::Y) + (LET ((CL::TYPENAME (TYPENAME CL::X))) + (AND (EQ CL::TYPENAME (TYPENAME CL::Y)) + (LET ((CL::DESCRIPTORS (GETDESCRIPTORS CL::TYPENAME))) + (CL:IF CL::DESCRIPTORS + (FOR CL::FIELD IN CL::DESCRIPTORS + ALWAYS (CL:EQUALP (FETCHFIELD CL::FIELD CL::X) + (FETCHFIELD CL::FIELD CL::Y))))))))))) + + + +(* |;;| "For the byte compiler: Optimize by constant fold and coerce to EQ where possible") + + +(PUTPROPS CL:EQUAL BYTEMACRO COMP.EQ) + +(PUTPROPS CL:EQUALP BYTEMACRO COMP.EQ) + +(PUTPROPS CL:EQUAL DOPVAL (2 CMLEQUAL)) + +(CL:DEFUN \\REMOVE-DECLS (CL::BODY CL::ENVIRONMENT) + +(* |;;;| "This is like parse-body, except that it returns the body and a list of specials declared in this frame. It side-effects the environment to mark the specials.") + + (PROG ((CL::SPECIALS NIL) + CL::FORM) + CL::NEXT-FORM + (CL:IF (NULL CL::BODY) + (GO CL::DONE)) + (CL:SETQ CL::FORM (CAR CL::BODY)) + CL::RETRY-FORM + (COND + ((OR (CL:ATOM CL::FORM) + (NOT (CL:SYMBOLP (CAR CL::FORM)))) + (GO CL::DONE)) + ((EQ (CAR CL::FORM) + 'DECLARE) + (CL:MAPC #'(CL:LAMBDA (CL:DECLARATION) + (CL:WHEN (CL:CONSP CL:DECLARATION) + (CL:WHEN (OR (EQ (CAR CL:DECLARATION) + 'CL:SPECIAL) + (EQ (CAR CL:DECLARATION) + 'SPECVARS)) + (CL:IF (EQ (CDR CL:DECLARATION) + T) + + (* |;;| "(specvars . t) refers to all variables inside this scope, not just those bound in this frame. So handling (specvars . t) by declaring the variables in this frame special would not be correct. Hence print a warning and continue.") + + (CL:WARN + "(IL:SPECVARS . T) has no effect in the CL evaluator." + ) + (CL:MAPC #'(CL:LAMBDA (CL::NAME) + (CL:PUSH CL::NAME CL::SPECIALS)) + (CDR CL:DECLARATION)))))) + (CDR CL::FORM)) + (CL:POP CL::BODY) + (GO CL::NEXT-FORM)) + ((CL:SPECIAL-FORM-P (CAR CL::FORM)) + (GO CL::DONE)) + (T (LET ((CL::NEW-FORM (CL:MACROEXPAND-1 CL::FORM CL::ENVIRONMENT))) + (COND + ((AND (NOT (EQ CL::NEW-FORM CL::FORM)) + (CL:CONSP CL::NEW-FORM)) + (CL:SETQ CL::FORM CL::NEW-FORM) + (GO CL::RETRY-FORM)) + (T (GO CL::DONE)))))) + CL::DONE + (RETURN (CL:IF CL::SPECIALS + (PROGN (FOR CL::VAR IN CL::SPECIALS + DO (CL:SETF (ENVIRONMENT-VARS CL::ENVIRONMENT) + (LIST* CL::VAR *SPECIAL-BINDING-MARK* + (ENVIRONMENT-VARS CL::ENVIRONMENT)))) + (CL:VALUES CL::BODY CL::SPECIALS)) + CL::BODY)))) + +(CL:DEFUN CL:SPECIAL-FORM-P (CL::X) + (GET CL::X 'SPECIAL-FORM)) + +(DEFINE-SPECIAL-FORM INTERLISP PROGN) + +(PUTPROPS INTERLISP DMACRO ((X . Y) + (PROGN X . Y))) + +(PUTPROPS COMMON-LISP DMACRO ((X) + X)) +(DEFINEQ + +(common-lisp (nlambda common-lisp-forms (* \; "Edited 12-Feb-87 20:24 by Pavel") (\\eval-progn common-lisp-forms nil))) +) + +(ADDTOVAR LAMBDASPLST CL:LAMBDA) +(DEFINEQ + +(\\translate-cl\:lambda (lambda (expr) (* \; "Edited 13-Feb-87 23:20 by Pavel") (let (vrbls keyvars optvars auxlist restform vartyp body keywords (cnt 1) (min 0) (max 0) decls (simplep t)) (|for| binding var |in| (car (cdr expr)) |do| (selectq binding ((&rest &body) (setq vartyp '&rest)) (&optional (setq vartyp binding)) (&aux (setq vartyp binding)) (&allow-other-keys (or (eq vartyp '&key) (error "&ALLOW-OTHER-KEYS not in &KEY"))) (&key (setq vartyp '&key)) (selectq vartyp (nil "required" (|push| vrbls binding) (|add| cnt 1) (|add| min 1) (|add| max 1) (and *check-argument-counts* (setq simplep nil))) (&rest (setq restform `((,binding (|for| i |from| ,cnt |to| |-args-| |collect| (arg |-args-| i))))) (setq max nil) (setq simplep nil)) (&aux (|push| auxlist binding)) (&key (let* (svar (init (cond ((listp binding) (prog1 (cadr binding) (setq svar (caddr binding)) (setq binding (car binding)))))) (key (cond ((listp binding) (prog1 (car binding) (setq binding (cadr binding)))) (t (make-keyword binding))))) (cond (svar (|push| keyvars (list svar t)))) (|push| keyvars (list binding `(|for| \\index |from| ,cnt |to| |-args-| |by| 2 |when| (eq (arg |-args-| \\index) ,key) |do| (return (arg |-args-| (add1 \\index)) ) |finally| (return ,(cond (svar `(progn (setq ,svar nil) ,init)) (t init))))))) (setq max nil) (setq simplep nil)) (&optional (or (listp binding) (setq binding (list binding))) (let ((svar (caddr binding))) (cl:when svar (|push| optvars svar) (setq simplep nil)) (cl:when (cadr binding) (setq simplep nil)) (|push| optvars `(,(car binding) (cond ((igreaterp ,cnt |-args-|) ,(cadr binding)) (t ,@(cond (svar `((setq ,svar t)))) (arg |-args-| ,cnt)))))) (and max (|add| max 1)) (|add| cnt 1)) (shouldnt)))) (cl:multiple-value-setq (body decls) (parse-body (cdr (cdr expr)) nil)) (cl:if simplep `(,'lambda (,@(reverse vrbls) ,@(mapcar (reverse optvars) (function car))) (declare (localvars . t)) ,@decls (,'let* (,@(reverse auxlist)) ,@decls ,@body)) `(lambda |-args-| (declare (localvars . t)) ,@(cond ((and *check-argument-counts* min (neq min 0)) `((cond ((ilessp ,'|-args-| ,min) (error "Too few args" ,'|-args-|)))))) ,@(cond ((and *check-argument-counts* max) `((cond ((igreaterp ,'|-args-| ,max) (error "Too many args" ,'|-args-|)))))) (,'let* (,@(|for| var |in| (reverse vrbls) |as| i |from| 1 |collect| (list var `(arg |-args-| ,i))) ,@(reverse optvars) ,@(reverse keyvars) ,@restform ,@(reverse auxlist)) ,@decls ,@body)))))) +) + +(CL:DEFPARAMETER *CHECK-ARGUMENT-COUNTS* NIL) + +(DEFGLOBALVAR *SPECIAL-BINDING-MARK* + "Variable specially bound. This string should never be visible") + +(CL:DEFCONSTANT CL:LAMBDA-LIST-KEYWORDS '(&OPTIONAL &REST &KEY &AUX &BODY &WHOLE + &ALLOW-OTHER-KEYS &ENVIRONMENT &CONTEXT)) + +(CL:DEFCONSTANT CL:CALL-ARGUMENTS-LIMIT 512) + +(CL:DEFCONSTANT CL:LAMBDA-PARAMETERS-LIMIT 512) + +(CL:DEFSTRUCT (CLOSURE (:PRINT-FUNCTION (LAMBDA (CLOSURE STREAM) + (LET ((*PRINT-RADIX* NIL)) + (CL:FORMAT STREAM "#" + (\\HILOC CLOSURE) + (\\LOLOC CLOSURE)))))) + +(* |;;;| "An interpreted lexical closure. Contains the function and an environment object.") + + FUNCTION + ENVIRONMENT) + +(CL:DEFSTRUCT (ENVIRONMENT (:CONSTRUCTOR \\MAKE-ENVIRONMENT NIL) + (:COPIER \\COPY-ENVIRONMENT) + (:PRINT-FUNCTION (LAMBDA (ENV STREAM DEPTH) + (DECLARE (IGNORE DEPTH)) + (LET ((*PRINT-RADIX* NIL)) + (CL:FORMAT STREAM + "#" + (\\HILOC ENV) + (\\LOLOC ENV)))))) + +(* |;;;| "An environment used by the Common Lisp interpreter. Every environment contains all of the information of its parents. That is, new child environments are made by copying the parent and then pushing new data onto one of the fields. This makes certain tests very fast.") + + (* |;;| "Lexically-bound or -declared variables. A property list mapping names into either *SPECIAL-BINDING-MARK* or their values.") + + VARS + + (* |;;| "Lexical functions and macros. A property list mapping names into either (:function . fn) or (:macro . expansion-fn).") + + FUNCTIONS + + (* |;;| "A property list mapping block names into unique blips. RETURN-FROMs can throw to the appropriate blip.") + + BLOCKS + + (* |;;| "A property list mapping TAGBODY bodies into unique blips. GOs throw the correct tail of the body to the blip.") + + TAGBODIES) + +(DEFMACRO \\MAKE-CHILD-ENVIRONMENT (PARENT &KEY ((:BLOCK (BLOCK-NAME BLOCK-BLIP)) + NIL BLOCK-P) + ((:TAGBODY (TAGBODY-TAIL TAGBODY-BLIP)) + NIL TAGBODY-P)) + `(LET* (($$PARENT ,PARENT) + ($$NEW-ENV (CL:IF $$PARENT + (\\COPY-ENVIRONMENT $$PARENT) + (\\MAKE-ENVIRONMENT)))) + ,@(AND BLOCK-P `((CL:SETF (ENVIRONMENT-BLOCKS $$NEW-ENV) + (LIST* ,BLOCK-NAME ,BLOCK-BLIP (ENVIRONMENT-BLOCKS $$NEW-ENV))) + )) + ,@(AND TAGBODY-P `((CL:SETF (ENVIRONMENT-TAGBODIES $$NEW-ENV) + (LIST* ,TAGBODY-TAIL ,TAGBODY-BLIP (ENVIRONMENT-TAGBODIES + $$NEW-ENV))))) + $$NEW-ENV)) +(DEFINEQ + +(CL:EVAL (LAMBDA (CL::EXPRESSION CL::ENVIRONMENT) (* \; "Edited 1-Apr-92 12:39 by jds") (* |;;| "This is in Interlisp and not a DEFUN to help avoid bootstrap death, although bootstrap death is quite possible anyway if, for example, any of the macros here are in Common Lisp and the macro definitions are interpreted.") (DECLARE (LOCALVARS . T)) (COND ((AND *EVALHOOK* (NOT (PROG1 CL::*SKIP-EVALHOOK* (CL:SETQ CL::*SKIP-EVALHOOK* NIL) ))) (LET ((CL::HOOKFN *EVALHOOK*) (*EVALHOOK* NIL)) (CL:FUNCALL CL::HOOKFN CL::EXPRESSION CL::ENVIRONMENT))) (T (CL:TYPECASE CL::EXPRESSION (CL:SYMBOL (COND ((NULL CL::EXPRESSION) NIL) ((EQ CL::EXPRESSION T) T) (T (LET (CL::LOC CL::VAL) (CL:BLOCK CL::EVAL-VARIABLE (CL:WHEN CL::ENVIRONMENT (|for| CL::TAIL |on| (ENVIRONMENT-VARS CL::ENVIRONMENT) |by| (CDDR CL::TAIL) |when| (EQ CL::EXPRESSION (CAR CL::TAIL)) |do| (CL:SETQ CL::VAL (CADR CL::TAIL)) (COND ((EQ CL::VAL *SPECIAL-BINDING-MARK*) (* |;;|  "return from FOR loop, skipping to SPECIALS code below.") (RETURN NIL)) (T (CL:RETURN-FROM CL::EVAL-VARIABLE CL::VAL))))) (* |;;|  "following copied from \\EVALVAR in the Interlisp interpreter") (SETQ CL::LOC (\\STKSCAN CL::EXPRESSION)) (COND ((EQ (CL:SETQ CL::VAL (\\GETBASEPTR CL::LOC 0)) 'NOBIND) (* \;  "Value is NOBIND even if it was not found as the top-level value.") (CL:ERROR 'UNBOUND-VARIABLE :NAME CL::EXPRESSION)) (T CL::VAL))))))) (CONS (COND ((CL:CONSP (CAR CL::EXPRESSION)) (LET ((CL::ARGCOUNT 1)) (* |;;| "This is a very very awful hack for getting into internal lambda expressions .COMPILER-SPREAD-ARGUMENTS. is handled specially by the compiler--it iterates over a list pushing things") (* |;;| "secondly, the (OPCODES) directly calls EVAL-INVOKE-LAMBDA with more args than are given, blowing away the following APPLYFN. Larry thought this level of hackery was important for performance.") (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CL-EVAL-FN3-CALL (CAR CL::EXPRESSION) CL::ENVIRONMENT) ((CL:EVAL CL::ENVIRONMENT))))) (T (LET ((CL::FN-DEFN (AND CL::ENVIRONMENT (CL:GETF (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT) (CAR CL::EXPRESSION))))) (COND ((NULL CL::FN-DEFN) (* \;  "The normal case: the function is not lexically-defined.") (CASE (ARGTYPE (CAR CL::EXPRESSION)) ((0 2) (* |;;| "has a Interlisp/CommonLisp lambda-spread definition") (CL:IF (AND *APPLYHOOK* (NOT (PROG1 CL::*SKIP-APPLYHOOK* (CL:SETQ CL::*SKIP-APPLYHOOK* NIL)))) (LET* ((CL::ARGS (CL:MAPCAR #'(CL:LAMBDA (CL::ARG) (CL:EVAL CL::ARG CL::ENVIRONMENT) ) (CDR CL::EXPRESSION))) (CL::HOOKFN *APPLYHOOK*) (*APPLYHOOK* NIL)) (CL:FUNCALL CL::HOOKFN (CAR CL::EXPRESSION) CL::ARGS CL::ENVIRONMENT)) (LET ((CL::ARGCOUNT 0)) (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CAR CL::EXPRESSION) ((CL:EVAL CL::ENVIRONMENT)))))) (T (* |;;|  "in Common Lisp, special form overrides nlambda definition") (* |;;| "note that the GET will error if not a symbol. ") (LET ((CL::TEMP (AND (CL:SYMBOLP (CAR CL::EXPRESSION)) (GET (CAR CL::EXPRESSION) 'SPECIAL-FORM)))) (COND (CL::TEMP (* \;  "CAR is the name of a special form.") (CL:FUNCALL CL::TEMP (CDR CL::EXPRESSION) CL::ENVIRONMENT)) ((CL:SETQ CL::TEMP (CL:MACRO-FUNCTION (CAR CL::EXPRESSION ))) (* \; "CAR is the name of a macro") (CL:EVAL (CL:FUNCALL CL::TEMP CL::EXPRESSION CL::ENVIRONMENT) CL::ENVIRONMENT)) (T (ERROR "Undefined car of form" (CAR CL::EXPRESSION))) ))))) ((EQ (CAR CL::FN-DEFN) :MACRO) (* \; "A use of a lexical macro.") (CL:EVAL (CL:FUNCALL (CDR CL::FN-DEFN) CL::EXPRESSION CL::ENVIRONMENT) CL::ENVIRONMENT)) (T (* \; "A call to a lexical function") (LET ((CL::ARGCOUNT 0)) (.COMPILER-SPREAD-ARGUMENTS. (CDR CL::EXPRESSION) CL::ARGCOUNT (CDR CL::FN-DEFN) ((CL:EVAL CL::ENVIRONMENT)))))))))) ((OR CL:NUMBER STRING CL:CHARACTER CL:BIT-VECTOR) (* |;;| "all of these are defined to be self-evaluating") CL::EXPRESSION) (T (CL:CERROR "Return the invalid expression as its own value" "~S is an invalid expression for EVAL." CL::EXPRESSION) CL::EXPRESSION)))))) + +(\\eval-invoke-lambda (lambda (n lam env) (declare (localvars . t)) (* \; "Edited 28-Apr-87 11:55 by Pavel") (let ((argblock (addstackbase (- (fetch (fx nextblock) of (\\myalink)) (+ (cl:decf n) n))))) (* |;;| "First sub-form is a list of (variable initialization) pairs. Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.") (cl:multiple-value-bind (body specials) (\\remove-decls (cddr lam) (cl:setq env (\\make-child-environment env))) (\\interpret-arguments "a LAMBDA as the CAR of a form" (case (car lam) ((lambda openlambda) '&interlisp) ((cl:lambda) '&required) (t (cl:error "(~S ...) is not legal as the CAR of a form." (car lam)))) (cadr lam) specials env body argblock n 0))))) + +(\\interpret-arguments (lambda (\\fn-name \\argtype \\arglist \\specials \\environment \\body \\argument-block \\length \\index) (* \; "Edited 7-Apr-88 16:16 by amd") (* |;;| "Written in a somewhat arcane style to avoid recursive calls whenever possible, & keep code inline. RECUR does a recursive call if under a PROGV, but otherwise does a GO. ") (cl:macrolet ((recur (tag) `(go ,tag)) (with-binding (var val &rest forms) `(progn (check-bindable ,var) (cl:if (or (fmemb ,var \\specials) (variable-globally-special-p ,var)) (cl:macrolet ((recur (tag) `(\\interpret-arguments \\fn-name ,(cl:if (eq tag 'in-keywords) '\\argtype `',tag) \\arglist \\specials \\environment \\body \\argument-block \\length \\index))) (cl:progv (list ,var) (list ,val) ,@forms)) (progn (cl:setf (environment-vars \\environment) (list* ,var ,val (environment-vars \\environment))) ,@forms))))) (prog (\\var \\val \\svar \\sp) (* |;;| "dispatch on input type. The in-keywords case is special, since it needs to pass down where the beginning of the keywords section is") (case \\argtype (&required (go &required)) (&optional (go &optional)) (&interlisp (go &interlisp)) (&rest (go &rest)) (&key (go &key)) (&aux (go &aux)) (&body (go &body)) (t (go in-keywords))) &required (return (cond ((null \\arglist) (cl:if (< \\index \\length) (cl:error 'too-many-arguments :callee \\fn-name :actual \\length :maximum \\index)) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&optional (recur &optional)) (&rest (recur &rest)) (&aux (recur &aux)) (&key (recur &key)) (t (cond ((>= \\index \\length) (cl:error 'too-few-arguments :callee \\fn-name :actual \\length :minimum (+ 1 \\index (for arg in \\arglist while (not (fmemb arg '(&optional &rest &aux &key))) sum 1))))) (setq \\val (arg-ref \\argument-block (prog1 \\index (cl:incf \\index)))) (with-binding \\var \\val (recur &required))))))) &optional (return (cond ((null \\arglist) (cl:if (< \\index \\length) (cl:error 'too-many-arguments :callee \\fn-name :actual \\length :maximum \\index)) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&rest (recur &rest)) (&aux (recur &aux)) (&key (recur &key)) (t (cl:if (>= \\index \\length) (cl:if (cl:consp \\var) (progn (setq \\val (cl:eval (cadr \\var) \\environment)) (setq \\svar (caddr \\var)) (setq \\var (car \\var)) (setq \\sp nil)) (setq \\val nil)) (progn (cond ((cl:consp \\var) (setq \\svar (caddr \\var)) (setq \\sp t) (setq \\var (car \\var)))) (setq \\val (arg-ref \\argument-block \\index)) (cl:incf \\index))) (with-binding \\var \\val (cl:if \\svar (with-binding \\svar \\sp (recur &optional)) (recur &optional)))))))) &interlisp (return (cond ((null \\arglist) (recur &body)) (t (setq \\var (|pop| \\arglist)) (cl:if (>= \\index \\length) (setq \\val nil) (progn (setq \\val (arg-ref \\argument-block \\index)) (cl:incf \\index))) (with-binding \\var \\val (recur &interlisp))))) &rest (setq \\var (|pop| \\arglist)) (setq \\val (|for| i |from| \\index |while| (< i \\length) |collect| (arg-ref \\argument-block i))) (return (with-binding \\var \\val (cl:if (null \\arglist) (recur &body) (case (|pop| \\arglist) (&aux (recur &aux)) (&key (recur &key)) (t (cl:error 'invalid-argument-list :callee \\fn-name)))))) &key (or (evenp (- \\length \\index)) (cl:error "Not an even number of arguments for &KEY")) (setq \\argtype \\arglist) (* \;  "Type is now the beginning of the keyword arguments") in-keywords (return (cond ((null \\arglist) (check-keywords \\argtype \\argument-block \\length \\index) (recur &body)) (t (case (setq \\var (|pop| \\arglist)) (&aux (check-keywords \\argtype \\argument-block \\length \\index) (recur &aux)) (&allow-other-keys (cl:if (null \\arglist) (recur &body) (case (|pop| \\arglist) (&aux (recur &aux)) (t (cl:error 'invalid-argument-list :callee \\fn-name))))) (t (cond ((cl:consp \\var) (setq \\val (cadr \\var)) (setq \\svar (caddr \\var)) (setq \\var (car \\var))) (t (setq \\svar nil) (setq \\val nil))) (let ((key (cl:if (cl:consp \\var) (prog1 (car \\var) (setq \\var (cadr \\var))) (make-keyword \\var)))) (|for| i |from| \\index |while| (< i \\length) |by| 2 |do| (cl:if (eq (arg-ref \\argument-block i) key) (return (progn (setq \\val (arg-ref \\argument-block (+ i 1))) (setq \\sp t)))) |finally| (setq \\val (cl:eval \\val \\environment)) (setq \\sp nil))) (with-binding \\var \\val (cl:if \\svar (with-binding \\svar \\sp (recur in-keywords)) (recur in-keywords)))))))) &aux (return (cond ((null \\arglist) (recur &body)) (t (setq \\var (|pop| \\arglist)) (cl:if (cl:consp \\var) (progn (setq \\val (cl:eval (cadr \\var) \\environment)) (setq \\var (car \\var))) (setq \\val nil)) (with-binding \\var \\val (recur &aux))))) &body (return (cl:if (null (cdr \\body)) (cl:if (cl:consp (setq \\body (car \\body))) (case (car \\body) (cl:block (* |;;| "special case to handle BLOCK to avoid consing two environments just to enter a normal LAMBDA function") (let ((blip (cons nil nil))) (cl:setf (environment-blocks \\environment) (list* (cadr \\body) blip (environment-blocks \\environment))) (cl:catch blip (\\eval-progn (cddr \\body) \\environment)))) (t (cl:eval \\body \\environment))) (cl:eval \\body \\environment)) (progn (cl:eval (pop \\body) \\environment) (recur &body)))))))) + +(\\interpreter-lambda (lambda (n def env fn) (* \; "Edited 13-Feb-87 21:21 by Pavel") (declare (localvars . t)) (let ((argblock (addstackbase (|fetch| (bf ivar) |of| (|fetch| (fx blink) |of| (\\myalink)))))) (setq env (\\make-child-environment env)) (cl:multiple-value-bind (body specials) (\\remove-decls (cdr (cdr def)) env) (\\interpret-arguments fn '&required (car (cdr def)) specials env body argblock (- n 1) 0))))) + +(check-bindable (lambda (var) (* \; "Edited 13-Feb-87 22:06 by Pavel") (cl:unless (cl:symbolp var) (cl:error "Attempt to bind a non-symbol: ~S" var)) (cl:when (or (cl:constantp var) (fmemb var cl:lambda-list-keywords)) (cl:error (cl:if (cl:keywordp var) "Attempt to bind a keyword: ~S" "Attempt to bind a constant: ~S") var)) (cl:when (variable-global-p var) (cl:cerror "Go ahead and bind it anyway" "Attempt to bind a variable proclaimed global: ~S" var)) var)) + +(check-keywords (lambda (key-arguments argblock length n) (* \; "Edited 1-Dec-87 16:47 by amd") (* |;;| "check to see if any keywords in ARGBLOCK are not in the keys - not called if &ALLOW-OTHER-KEYS was set") (cl:block check-keys (let (badkeyword) (cl:do ((i n (+ i 2))) ((>= i length)) (let ((given-key (arg-ref argblock i))) (cl:if (eq given-key :allow-other-keys) (cl:if (arg-ref argblock (cl:1+ i)) (cl:return-from check-keys nil) nil) (cl:do ((keytail key-arguments (cdr keytail))) ((or (null keytail) (eq (car keytail) '&aux)) (* \; "got to end of keyword segment") (setq badkeyword given-key)) (let ((wanted-key (car keytail))) (if (cl:consp wanted-key) then (setq wanted-key (car wanted-key)) (cl:if (cl:consp wanted-key) (setq wanted-key (car wanted-key)) (setq wanted-key (make-keyword wanted-key))) else (setq wanted-key (make-keyword wanted-key)) ) (cl:if (eq wanted-key given-key) (return nil))))))) (cl:if badkeyword (cl:error "Keyword argument doesn't match expected list of keywords: ~A" badkeyword)))))) +) + +(DEFMACRO ARG-REF (BLOCK N) + `(\\GETBASEPTR ,BLOCK (LLSH ,N 1))) + +(PUTPROPS .COMPILER-SPREAD-ARGUMENTS. DMACRO (APPLY COMP.SPREAD)) +(DEFINEQ + +(declared-special (lambda (var decls) (* |lmm| "24-May-86 22:27") (and decls (or (and (listp (car decls)) (eq (caar decls) 'declare) (|for| dec |in| (cdar decls) |when| (and (eq (car dec) 'cl:special) (fmemb var (cdr dec))) |do| (return t))) (declared-special var (cdr decls)))))) +) + + + +(* \; "FUNCALL and APPLY, not quite same as Interlisp") + +(DEFINEQ + +(cl:funcall (cl:lambda (cl::fn &rest cl::args) (* \; "Edited 14-Feb-87 00:16 by Pavel") (cl:apply cl::fn cl::args))) + +(cl:apply (lambda cl::n (* \; "Edited 14-Feb-87 00:16 by Pavel") (cl:if (eq cl::n 0) (error "TOO FEW ARGUMENTS TO APPLY") (spreadapply (arg cl::n 1) (let ((cl::av (arg cl::n cl::n))) (for cl::i from (cl:1- cl::n) to 2 by -1 do (cl:push (arg cl::n cl::i) cl::av)) cl::av))))) +) + +(PUTPROPS CL:APPLY DMACRO (DEFMACRO (FN &REST ARGS) (CASE COMPILE.CONTEXT + ((EFFECT RETURN) + `(LET + ((FN ,FN) + (CNT ,(LENGTH (CDR ARGS)))) + (.SPREAD. ((OPCODES) + \,@ ARGS) + CNT FN))) + (T + (* |;;| + "otherwise might not return multiple values") + + 'IGNOREMACRO)))) + +(PUTPROPS CL:FUNCALL DMACRO (DEFMACRO (FN &REST ARGS) (COND + ((AND (NLISTP FN) + (EVERY ARGS (FUNCTION NLISTP))) + `((OPCODES APPLYFN) + ,@ARGS + ,(LENGTH ARGS) + ,FN)) + (T + (LET ((TEM (GENSYM))) + `((LAMBDA (,TEM) + ((OPCODES APPLYFN) + ,@ARGS + ,(LENGTH ARGS) + ,TEM)) + ,FN)))))) + + + +(* \; "COMPILER-LET needs to work differently compiled and interpreted") + +(DEFINEQ + +(cl:compiler-let (nlambda $$compiler-let-tail (* \; "Edited 7-Apr-88 16:05 by amd") (cl:progv (|for| x |in| (car $$compiler-let-tail) |collect| (cond ((cl:consp x) (car x)) (t x))) (|for| x |in| (car $$compiler-let-tail) |collect| (cond ((cl:consp x) (\\eval (cadr x))))) (\\evprogn (cdr $$compiler-let-tail))))) + +(comp.compiler-let (lambda (\\a) (declare (localvars . t)) (* \; "Edited 7-Apr-88 16:38 by amd") (* entry point into bytecompiler) (* |lmm| "27-May-86 11:17") (cl:progv (|for| x |in| (car \\a) |collect| (|if| (cl:consp x) |then| (car x) |else| x)) (|for| x |in| (car \\a) |collect| (cond ((cl:consp x) (eval (cadr x))))) (comp.progn (cdr \\a))))) +) + +(PUTPROPS CL:COMPILER-LET DMACRO COMP.COMPILER-LET) + +(DEFINE-SPECIAL-FORM CL:COMPILER-LET (CL::ARGS &REST CL::BODY &ENVIRONMENT CL::ENV) + (LET ((*IN-COMPILER-LET* T)) + (DECLARE (CL:SPECIAL *IN-COMPILER-LET*)) (* \; + "the *IN-COMPILER-LET* is for macro-caching. It says: don't cache macros under compiler lets") + (CL:PROGV (FOR CL::X IN CL::ARGS COLLECT (IF (CL:CONSP CL::X) + THEN (CAR CL::X) + ELSE CL::X)) + (FOR CL::X IN CL::ARGS COLLECT (IF (CL:CONSP CL::X) + THEN (CL:EVAL (CADR CL::X) + CL::ENV) + ELSE NIL)) + (\\EVAL-PROGN CL::BODY CL::ENV)))) + + + +(* \; "Lexical function- and macro-binding forms: FLET, LABELS, and MACROLET.") + + +(DEFINE-SPECIAL-FORM CL:MACROLET (CL::MACRO-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) + (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) + (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) + (FOR CL::MACRO-DEFN IN CL::MACRO-DEFNS + DO (CL:SETQ CL::FUNCTIONS + (LIST* (CAR CL::MACRO-DEFN) + (CONS :MACRO `(CL:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) + (CL:BLOCK ,(CAR CL::MACRO-DEFN) + ,(PARSE-DEFMACRO (CADR CL::MACRO-DEFN) + 'SI::$$MACRO-FORM + (CDDR CL::MACRO-DEFN) + (CAR CL::MACRO-DEFN) + NIL :ENVIRONMENT + 'SI::$$MACRO-ENVIRONMENT)))) + CL::FUNCTIONS))) + (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) + CL::FUNCTIONS) + (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) + +(DEFINE-SPECIAL-FORM CL:FLET (CL::FN-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) + (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) + (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) + (FOR CL::FN-DEFN IN CL::FN-DEFNS + DO (CL:SETQ CL::FUNCTIONS + (LIST* (CL:FIRST CL::FN-DEFN) + (CONS :FUNCTION + (MAKE-CLOSURE :FUNCTION + (CL:MULTIPLE-VALUE-BIND + (CL::BODY CL::DECLS) + (PARSE-BODY (CDDR CL::FN-DEFN) + CL::ENV T) + `(CL:LAMBDA ,(CL:SECOND CL::FN-DEFN) + ,@CL::DECLS + (CL:BLOCK ,(CL:FIRST CL::FN-DEFN) + ,@CL::BODY))) + :ENVIRONMENT CL::ENV)) + CL::FUNCTIONS))) + (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) + CL::FUNCTIONS) + (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) + +(DEFINE-SPECIAL-FORM CL:LABELS (CL::FN-DEFNS &BODY CL::BODY &ENVIRONMENT CL::ENV) + (LET* ((CL::NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV)) + (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) + (FOR CL::FN-DEFN IN CL::FN-DEFNS + DO (CL:SETQ CL::FUNCTIONS + (LIST* (CL:FIRST CL::FN-DEFN) + (CONS :FUNCTION + + (* |;;| "Must share the environment object so that all of the new lexical function bindings appear in each new functions environment.") + + (MAKE-CLOSURE :FUNCTION + (CL:MULTIPLE-VALUE-BIND + (CL::BODY CL::DECLS) + (PARSE-BODY (CDDR CL::FN-DEFN) + CL::NEW-ENV T) + `(CL:LAMBDA ,(CL:SECOND CL::FN-DEFN) + ,@CL::DECLS + (CL:BLOCK ,(CL:FIRST CL::FN-DEFN) + ,@CL::BODY))) + :ENVIRONMENT CL::NEW-ENV)) + CL::FUNCTIONS))) + (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) + CL::FUNCTIONS) + (\\EVAL-PROGN CL::BODY CL::NEW-ENV))) + +(DEFINE-SPECIAL-FORM QUOTE CAR) + +(DEFINE-SPECIAL-FORM THE (CL::TYPE-SPEC CL::FORM &ENVIRONMENT CL::ENV) + (CL:IF (AND (CL:CONSP CL::TYPE-SPEC) + (EQ (CAR CL::TYPE-SPEC) + 'CL:VALUES)) + (LET ((CL:VALUES (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::FORM CL::ENV)))) + (CL:IF (CL:NOTEVERY #'(CL:LAMBDA (CL::VALUE CL::SPEC) + (TYPEP CL::VALUE CL::SPEC)) + CL:VALUES + (CDR CL::TYPE-SPEC)) + (CHECK-TYPE-FAIL T CL::FORM CL:VALUES CL::TYPE-SPEC NIL) + (CL:VALUES-LIST CL:VALUES))) + (LET ((CL::VALUE (CL:EVAL CL::FORM CL::ENV))) + (CL:IF (TYPEP CL::VALUE CL::TYPE-SPEC) + CL::VALUE + (CHECK-TYPE-FAIL T CL::FORM CL::VALUE CL::TYPE-SPEC NIL))))) + +(PUTPROPS THE DMACRO ((SPEC FORM) + FORM)) + +(PUTPROPS CL:EVAL-WHEN DMACRO (DEFMACRO (OPTIONS &BODY BODY) (AND (OR (FMEMB 'COMPILE OPTIONS) + (FMEMB 'CL:COMPILE OPTIONS) + ) + (MAPC BODY + (FUNCTION CL:EVAL))) + (AND (OR (FMEMB 'LOAD OPTIONS) + (FMEMB 'CL:LOAD OPTIONS)) + `(PROGN ,@BODY)))) +(DEFINEQ + +(cl:eval-when (nlambda options.body (* |lmm| " 1-Jun-86 15:16") (and (or (fmemb 'cl:eval (car options.body)) (fmemb 'eval (car options.body))) (mapc (cdr options.body) (function \\eval))))) +) + +(DEFINE-SPECIAL-FORM CL:EVAL-WHEN (CL::TAGS &REST CL::BODY &ENVIRONMENT CL::ENV) + (AND (OR (CL:MEMBER 'CL:EVAL CL::TAGS) + (CL:MEMBER 'EVAL CL::TAGS)) + (\\EVAL-PROGN CL::BODY CL::ENV))) + +(DEFINE-SPECIAL-FORM DECLARE FALSE) + +(DEFMACRO CL:LOCALLY (&BODY BODY) + `(LET NIL ,@BODY)) + + + +(* \; "Interlisp version on LLINTERP") + + +(DEFINE-SPECIAL-FORM PROGN \\EVAL-PROGN) +(DEFINEQ + +(\\eval-progn (lambda (body environment) (* \; "Edited 12-Feb-87 20:25 by Pavel") (|if| (cdr body) |then| (cl:eval (car body) environment) (\\eval-progn (cdr body) environment) |else| (cl:eval (car body) environment)))) +) + + + +(* \; "Confused because currently Interlisp special form, fixing MACRO-FUNCTION is complex") + + + + +(* \; "The Interlisp function is on LLINTERP") + + +(DEFINE-SPECIAL-FORM PROG1 (CL:FIRST &REST CL:REST &ENVIRONMENT CL::ENV) + (LET ((CL::VAL (CL:EVAL CL:FIRST CL::ENV))) + (CL:TAGBODY PROG1 (CL:IF CL:REST + (PROGN (CL:EVAL (CAR CL:REST) + CL::ENV) + (CL:SETQ CL:REST (CDR CL:REST))) + (CL:RETURN-FROM PROG1 CL::VAL)) + (GO PROG1)))) + +(DEFMACRO PROG1 (CL:FIRST &REST CL:REST) + `(LET ((SI::$PROG1-FIRST-EXPRESSION$ ,CL:FIRST)) + (DECLARE (LOCALVARS SI::$PROG1-FIRST-EXPRESSION$)) + ,@CL:REST SI::$PROG1-FIRST-EXPRESSION$)) + +(DEFINE-SPECIAL-FORM LET* (CL::VARS &REST CL::BODY &ENVIRONMENT CL::ENV) + (CL:MULTIPLE-VALUE-BIND (CL::BODY CL::SPECIALS) + (\\REMOVE-DECLS CL::BODY (CL:SETQ CL::ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV))) + (\\LET*-RECURSION CL::VARS CL::SPECIALS CL::ENV CL::BODY))) + +(DEFINE-SPECIAL-FORM LET (CL::VARS &BODY CL::BODY &ENVIRONMENT CL::ENV &AUX CL::\\NEW-ENV) + + (* |;;| "Initializes the variables, binding them to new values all at once, then executes the remaining forms as in a PROGN.") + + (CL:MULTIPLE-VALUE-BIND (CL::\\BODY CL::SPECIALS) + (\\REMOVE-DECLS CL::BODY (CL:SETQ CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT + CL::ENV))) + + (* |;;| "Note that since remove decls side-effects the environment, variables which are declared special inside this scope will cause references inside the variable value forms to do special reference.") + + (LET ((CL::ENV-VARS (ENVIRONMENT-VARS CL::\\NEW-ENV)) + CL::SPECVARS CL::SPECVALS CL::VALUE) + (FOR CL::VAR IN CL::VARS + DO (COND + ((CL:CONSP CL::VAR) + + (* |;;| "NEW-ENV current has all of the new specials, but none of the new lexicals. This is the right environment to eval in.") + + (CL:SETQ CL::VALUE (CL:EVAL (CADR CL::VAR) + CL::\\NEW-ENV)) + (CL:SETQ CL::VAR (CAR CL::VAR))) + (T (CL:SETQ CL::VALUE NIL))) + (CHECK-BINDABLE CL::VAR) + (IF (OR (FMEMB CL::VAR CL::SPECIALS) + (VARIABLE-GLOBALLY-SPECIAL-P CL::VAR)) + THEN (CL:PUSH CL::VAR CL::SPECVARS) + (CL:PUSH CL::VALUE CL::SPECVALS) + ELSE (CL:SETQ CL::ENV-VARS (LIST* CL::VAR CL::VALUE CL::ENV-VARS))) + ) + (CL:SETF (ENVIRONMENT-VARS CL::\\NEW-ENV) + CL::ENV-VARS) + (CL:IF CL::SPECVARS + (CL:PROGV CL::SPECVARS CL::SPECVALS + (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV)) + (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV))))) + +(PUTPROPS LET MACRO (X (|\\LETtran| X))) + +(PUTPROPS LET* MACRO (X (|\\LETtran| X T))) +(DEFINEQ + +(\\let*-recursion (lambda (vars $$let*-specials $$let*-env $$let*-body) (declare (localvars . t)) (* \; "Edited 7-Apr-88 16:09 by amd") (|bind| var value |for| $$let*-tail |on| vars |eachtime| (setq var (car $$let*-tail )) |do| (cond ((cl:consp var) (setq value (cl:eval (cadr var) $$let*-env)) (setq var (car var))) (t (setq value nil))) (check-bindable var) (cl:if (or (fmemb var $$let*-specials) (variable-globally-special-p var)) (return (cl:progv (list var) (list value) (\\let*-recursion (cdr $$let*-tail) $$let*-specials $$let*-env $$let*-body))) (cl:setf (environment-vars $$let*-env) (list* var value (environment-vars $$let*-env)))) |finally| (return (\\eval-progn $$let*-body $$let*-env))))) + +(|\\LETtran| (lambda (lettail sequentialp) (* \; "Edited 23-Dec-86 16:23 by lmm") (* |;;| "Interlisp version of LET/LET*/PROG*") (prog ((vars (mapcar (car lettail) (function (lambda (bindentry) (|if| (listp bindentry) |then| (car bindentry) |else| bindentry))))) (vals (mapcar (car lettail) (function (lambda (bindentry) (|if| (listp bindentry) |then| (cadr bindentry) |else| nil))))) (body (cdr lettail)) (decls nil)) (cl:multiple-value-setq (body decls) (parse-body body nil)) (return (|if| (not sequentialp) |then| `((,'lambda ,vars ,@decls ,@body) ,@vals) |elseif| (null (cdr vars)) |then| (selectq sequentialp (prog* `(prog ,@lettail)) `((,'lambda ,vars ,@decls ,@body) ,@vals)) |else| (* \;  "in the sequential case, all declarations must be included in each") (|if| (eq sequentialp 'prog*) |then| (setq body (list (list* 'prog nil body)))) (|for| var |in| (reverse (cdr vars)) |as| val |in| (reverse (cdr vals)) |do| (setq body `(((,'lambda (,var) ,@decls ,@body) ,val)))) `((,'lambda (,(car vars)) ,@decls ,@body) ,(car vals))))))) +) + +(DEFINE-SPECIAL-FORM COND (&REST CL::COND-CLAUSES &ENVIRONMENT CL::ENVIRONMENT) + (PROG NIL + CL::CONDLOOP + (COND + ((NULL CL::COND-CLAUSES) + (RETURN NIL)) + ((NULL (CDAR CL::COND-CLAUSES)) + (RETURN (OR (CL:EVAL (CAAR CL::COND-CLAUSES) + CL::ENVIRONMENT) + (PROGN (CL:SETQ CL::COND-CLAUSES (CDR CL::COND-CLAUSES)) + (GO CL::CONDLOOP))))) + ((CL:EVAL (CAAR CL::COND-CLAUSES) + CL::ENVIRONMENT) + (RETURN (\\EVAL-PROGN (CDAR CL::COND-CLAUSES) + CL::ENVIRONMENT))) + (T (CL:SETQ CL::COND-CLAUSES (CDR CL::COND-CLAUSES)) + (GO CL::CONDLOOP))))) + +(DEFMACRO COND (&REST CL::TAIL) + (CL:IF CL::TAIL + (CL:IF (NULL (CDAR CL::TAIL)) + (CL:IF (CDR CL::TAIL) + (LET ((VAR (CL:GENTEMP))) + `(LET ((,VAR ,(CAAR CL::TAIL))) + (CL:IF ,VAR + ,VAR + (COND + ,@(CDR CL::TAIL))))) + `(CL:VALUES ,(CAAR CL::TAIL))) + `(CL:IF ,(CAAR CL::TAIL) + ,(MKPROGN (CDAR CL::TAIL)) + ,@(CL:IF (CDR CL::TAIL) + (LIST (CL:IF (EQ (CAADR CL::TAIL) + T) + (CL:IF (NULL (CDADR CL::TAIL)) + T + (MKPROGN (CDADR CL::TAIL))) + `(COND + ,@(CDR CL::TAIL))))))))) +(DEFINEQ + +(cl:if (nlambda (cl::test cl::then cl::else) (declare (localvars . t)) (* \; "Edited 12-Feb-87 20:27 by Pavel") (cl:if (\\eval cl::test) (\\eval cl::then) (\\eval cl::else)))) +) + +(DEFINE-SPECIAL-FORM CL:IF (CL::TEST CL::THEN &OPTIONAL CL::ELSE &ENVIRONMENT CL::ENVIRONMENT) + (CL:IF (CL:EVAL CL::TEST CL::ENVIRONMENT) + (CL:EVAL CL::THEN CL::ENVIRONMENT) + (CL:EVAL CL::ELSE CL::ENVIRONMENT))) + +(PUTPROPS CL:IF DMACRO COMP.IF) + + + +(* \; "Interlisp NLAMBDA definitions on LLINTERP") + + + + +(* \; "both special form and macro") + + +(DEFMACRO AND (&REST CL::FORMS) + (COND + ((CDR CL::FORMS) + `(CL:IF ,(CAR CL::FORMS) + (AND ,@(CDR CL::FORMS)))) + (CL::FORMS (CAR CL::FORMS)) + (T T))) + +(DEFMACRO OR (&REST CL::FORMS) + (CL:IF (NULL (CDR CL::FORMS)) + (CAR CL::FORMS) + `(LET ((SI::*OR-GENTEMP* ,(CAR CL::FORMS))) + (DECLARE (LOCALVARS SI::*OR-GENTEMP*)) + (CL:IF SI::*OR-GENTEMP* + SI::*OR-GENTEMP* + (OR ,@(CDR CL::FORMS)))))) + +(DEFINE-SPECIAL-FORM AND (&REST CL::AND-CLAUSES &ENVIRONMENT CL::ENV) + (CL:LOOP (COND + ((NULL CL::AND-CLAUSES) + (RETURN T)) + ((NULL (CDR CL::AND-CLAUSES)) + (RETURN (CL:EVAL (CAR CL::AND-CLAUSES) + CL::ENV))) + (T (CL:IF (CL:EVAL (CAR CL::AND-CLAUSES) + CL::ENV) + (CL:POP CL::AND-CLAUSES) + (RETURN NIL)))))) + +(DEFINE-SPECIAL-FORM OR (&REST CL::TAIL &ENVIRONMENT CL::ENV) + (BIND CL::VAL FOR OLD CL::TAIL ON CL::TAIL (COND + ((NULL (CDR CL::TAIL)) + (RETURN (CL:EVAL + (CAR CL::TAIL) + CL::ENV))) + ((CL:SETQ CL::VAL + (CL:EVAL (CAR CL::TAIL) + CL::ENV)) + (RETURN CL::VAL))))) + + + +(* \; "BLOCK and RETURN go together") + +(DEFINEQ + +(cl:block (nlambda cl::tail (* \; "Edited 12-Feb-87 20:31 by Pavel") (\\evprogn (cdr cl::tail)))) +) + +(PUTPROPS CL:BLOCK DMACRO COMP.BLOCK) + +(DEFINE-SPECIAL-FORM CL:BLOCK (CL::NAME &REST CL::\\BODY &ENVIRONMENT CL::ENVIRONMENT) + + (* |;;| "Syntax is (BLOCK name . body). The body is evaluated as a PROGN, but it is possible to exit the block using (RETURN-FROM name value). The RETURN-FROM must be lexically contained within the block.") + + (LET* ((CL::BLIP (CONS NIL NIL)) + (CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENVIRONMENT :BLOCK (CL::NAME CL::BLIP)))) + (CL:CATCH CL::BLIP (\\EVAL-PROGN CL::\\BODY CL::\\NEW-ENV)))) + +(DEFMACRO RETURN (CL::VALUE) + `(CL:RETURN-FROM NIL ,CL::VALUE)) +(DEFINEQ + +(cl:return-from (nlambda (cl::retfrom-tag cl::retfrom-value) (declare (localvars . t)) (* \; "Edited 12-Feb-87 20:35 by Pavel") (let ((cl::retvalues (cl:multiple-value-list (\\eval cl::retfrom-value)))) (let ((cl::frame (stknth 1))) (while cl::frame do (cl:if (or (and (null cl::retfrom-tag) (eq (stkname cl::frame) '\\prog0)) (and (eq (stkname cl::frame) 'cl:block) (eq (car (stkarg 1 cl::frame)) cl::retfrom-tag))) (retvalues cl::frame cl::retvalues t) (cl:setq cl::frame (stknth 1 cl::frame cl::frame ))) finally (cl:error 'illegal-return :tag cl::retfrom-tag)))))) +) + +(DEFINE-SPECIAL-FORM CL:RETURN-FROM (CL::BLOCK-NAME CL::EXPR &ENVIRONMENT CL::ENV) + (LET ((CL::BLIP (AND CL::ENV (CL:GETF (ENVIRONMENT-BLOCKS CL::ENV) + CL::BLOCK-NAME)))) + (CL:IF (AND CL::BLOCK-NAME (NULL CL::BLIP)) + (CL:ERROR 'ILLEGAL-RETURN :TAG CL::BLOCK-NAME) + (LET ((CL::\\BLK CL::BLOCK-NAME) + (CL::VALS (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::EXPR CL::ENV)))) + (COND + (CL::BLIP (* \; + "This is a CL RETURN-FROM, so do the throw.") + (HANDLER-BIND ((ILLEGAL-THROW #'(CL:LAMBDA (CL::C) + (DECLARE (IGNORE CL::C)) + (CL:ERROR 'ILLEGAL-RETURN :TAG + CL::\\BLK)))) + (CL:THROW CL::BLIP (CL:VALUES-LIST CL::VALS)))) + (T (* \; + "This is an IL RETURN, so return from the closest enclosing \\PROG0.") + (RETVALUES (STKPOS '\\PROG0) + CL::VALS T))))))) + + + +(* \; "IL and CL versions of FUNCTION.") + +(DEFINEQ + +(cl:function (nlambda (cl::fn) (* \; "Edited 30-Jan-87 19:07 by Pavel") (* |;;;| "Fake CL:FUNCTION for Interlisp --- no lexical closures") (cl:if (cl:symbolp cl::fn) (cl:symbol-function cl::fn) cl::fn))) +) + +(PUTPROPS CL:FUNCTION DMACRO (DEFMACRO (X) (COND + ((CL:SYMBOLP X) + `(CL:SYMBOL-FUNCTION ',X)) + (T `(FUNCTION ,X))))) + +(DEFINE-SPECIAL-FORM CL:FUNCTION (CL::FN &ENVIRONMENT CL::ENVIRONMENT) + (COND + ((CL:SYMBOLP CL::FN) + (LET (CL::FN-DEFN) + (COND + ((OR (NULL CL::ENVIRONMENT) + (NULL (CL:SETQ CL::FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT + ) + CL::FN)))) + (CL:SYMBOL-FUNCTION CL::FN)) + ((EQ (CAR CL::FN-DEFN) + :FUNCTION) + (CDR CL::FN-DEFN)) + (T (CL:ERROR "The lexical macro ~S is not a legal argument to ~S." CL::FN + 'CL:FUNCTION))))) + ((OR (NULL CL::ENVIRONMENT) + (AND (FOR CL::VALUE IN (CDR (ENVIRONMENT-VARS CL::ENVIRONMENT)) + BY CDDR ALWAYS (EQ CL::VALUE *SPECIAL-BINDING-MARK*)) + (NULL (ENVIRONMENT-FUNCTIONS CL::ENVIRONMENT)) + (NULL (ENVIRONMENT-BLOCKS CL::ENVIRONMENT)) + (NULL (ENVIRONMENT-TAGBODIES CL::ENVIRONMENT)))) + + (* |;;| "Environment is empty: don't have to make a closure.") + + CL::FN) + (T (MAKE-CLOSURE :FUNCTION (COND + ((EQ (CAR CL::FN) + 'LAMBDA) + `(CL:LAMBDA (&OPTIONAL ,@(CADR CL::FN) + &REST IGNORE) + ,@(CDDR CL::FN))) + (T CL::FN)) + :ENVIRONMENT + (\\COPY-ENVIRONMENT CL::ENVIRONMENT) (* \; + "environment is copied so that forms that side-effect it (such as LET*) will work correctly.") + )))) + +(DEFINE-SPECIAL-FORM FUNCTION (FN &OPTIONAL FUNARGP &ENVIRONMENT ENVIRONMENT) + + (* |;;| "Interlisp FUNCTION in Common Lisp interpreter:") + + (* |;;| "like CL:FUNCTION except that (FUNCTION FOO) just returns FOO and not its definition.") + + (COND + (FUNARGP (CL:FUNCALL #'FUNCTION FN FUNARGP)) + ((CL:SYMBOLP FN) + (LET (FN-DEFN) + (COND + ((OR (NULL ENVIRONMENT) + (NULL (SETQ FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENVIRONMENT) + FN)))) + FN) + ((EQ (CAR FN-DEFN) + :FUNCTION) + (CDR FN-DEFN)) + (T (CL:ERROR "The lexical macro ~S is not a legal argument to ~S." FN 'FUNCTION))))) + ((OR (NULL ENVIRONMENT) + (AND (FOR VALUE IN (CDR (ENVIRONMENT-VARS ENVIRONMENT)) BY CDDR + ALWAYS (EQ VALUE *SPECIAL-BINDING-MARK*)) + (NULL (ENVIRONMENT-FUNCTIONS ENVIRONMENT)) + (NULL (ENVIRONMENT-BLOCKS ENVIRONMENT)) + (NULL (ENVIRONMENT-TAGBODIES ENVIRONMENT)))) + FN) + (T (MAKE-CLOSURE :FUNCTION (COND + ((EQ (CAR FN) + 'LAMBDA) + `(CL:LAMBDA (&OPTIONAL ,@(CADR FN) + &REST IGNORE) + ,@(CDDR FN))) + (T FN)) + :ENVIRONMENT ENVIRONMENT)))) + +(CL:DEFUN CL:FUNCTIONP (CL::FN) + (AND (OR (CL:SYMBOLP CL::FN) + (CL:COMPILED-FUNCTION-P CL::FN) + (AND (CL:CONSP CL::FN) + (EQ (CAR CL::FN) + 'CL:LAMBDA)) + (CLOSURE-P CL::FN)) + T)) + +(CL:DEFUN CL:COMPILED-FUNCTION-P (CL::FN) + (OR (TYPEP CL::FN 'COMPILED-CLOSURE) + (AND (ARRAYP CL::FN) + (EQ (|fetch| (ARRAYP TYP) |of| CL::FN) + \\ST.CODE)))) + +(DEFINE-SPECIAL-FORM CL:MULTIPLE-VALUE-CALL (CL::FN &REST CL::ARGS &ENVIRONMENT CL::ENV) + + (* |;;| + "for interpreted calls only. The macro inserts a \\MVLIST call after the computation of TAIL") + + (CL:APPLY (CL:EVAL CL::FN CL::ENV) + (FOR CL::X IN CL::ARGS JOIN (\\MVLIST (CL:EVAL CL::X CL::ENV))))) + +(DEFINE-SPECIAL-FORM CL:MULTIPLE-VALUE-PROG1 (CL::FORM &REST CL::OTHER-FORMS &ENVIRONMENT CL::ENV + ) + (CL:VALUES-LIST (PROG1 (CL:MULTIPLE-VALUE-LIST (CL:EVAL CL::FORM CL::ENV)) + (FOR CL::X IN CL::OTHER-FORMS DO (CL:EVAL CL::X CL::ENV))))) +(DEFINEQ + +(comp.cl-eval (lambda (exp) (* |lmm| " 5-Jun-86 00:44") (comp.spread `(cdr ,@exp) '*eval-argument-count* `(car ,@exp) '((cl:eval environment))))) +) + +(CL:DEFUN CL:EVALHOOK (CL::FORM CL::EVALHOOKFN CL::APPLYHOOKFN &OPTIONAL CL::ENV) + "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form." + (LET ((*EVALHOOK* CL::EVALHOOKFN) + (CL::*SKIP-EVALHOOK* T) + (*APPLYHOOK* CL::APPLYHOOKFN) + (CL::*SKIP-APPLYHOOK* NIL)) + (CL:EVAL CL::FORM CL::ENV))) + +(CL:DEFUN CL:APPLYHOOK (CL:FUNCTION CL::ARGS CL::EVALHOOKFN CL::APPLYHOOKFN &OPTIONAL CL::ENV + ) + "Evaluates Form with *Evalhook* bound to Evalhookfn and *Applyhook* bound to applyhookfn. Ignores these hooks once, for the top-level evaluation of Form." + (DECLARE (IGNORE CL::ENV)) + + (* |;;| "the env argument is not used as agreed on the Common Lisp mailing list. (Arguments have already been evaluated.)") + + (LET ((*EVALHOOK* CL::EVALHOOKFN) + (CL::*SKIP-EVALHOOK* T) + (*APPLYHOOK* CL::APPLYHOOKFN) + (CL::*SKIP-APPLYHOOK* NIL)) + (CL:APPLY CL:FUNCTION CL::ARGS))) + +(CL:DEFVAR *EVALHOOK* NIL) + +(CL:DEFVAR *APPLYHOOK* NIL) + +(CL:DEFVAR CL::*SKIP-EVALHOOK* NIL + "Used with non-null *EVALHOOK* to suppress the use of the hook-function + for one level of eval.") + +(CL:DEFVAR CL::*SKIP-APPLYHOOK* NIL + "Used with non-null *APPLYHOOK* to suppress the use of the hook function + for one level of eval.") + + + +(* \; "CONSTANTS mechanism") + +(DEFINEQ + +(cl:constantp (lambda (object environment) (* |vanMelle| "19-Nov-86 21:43") (cl:typecase object (cl:number t) (cl:character t) (string t) (cl:bit-vector t) (cl:symbol (or (eq object nil) (eq object t) (cl:keywordp object) (and compvarmacrohash (setq object (gethash object compvarmacrohash)) (cl:constantp object)))) (cons (case (car object) ((constant quote) t) (cl:otherwise (cond ((fmemb (car object) constantfoldfns) (every (cdr object) (function cl:constantp))) (t (cl:multiple-value-bind (new-form expanded) (cl:macroexpand object environment) (and expanded (cl:constantp new-form))))))))))) +) + +(CL:DEFSETF CL:CONSTANTP XCL::SET-CONSTANTP) + +(CL:DEFUN XCL::SET-CONSTANTP (CL:SYMBOL XCL::FLAG) + (CL:IF (NOT (NULL XCL::FLAG)) + (CL:SETF (GETHASH CL:SYMBOL COMPVARMACROHASH) + `(CONSTANT ,CL:SYMBOL)) + (CL:WHEN (TYPEP COMPVARMACROHASH 'CL:HASH-TABLE) + (REMHASH CL:SYMBOL COMPVARMACROHASH)))) + + + +(* \; "Interlisp SETQ for Common Lisp and vice versa") + + +(DEFINE-SPECIAL-FORM CL:SETQ (&REST CL::TAIL &ENVIRONMENT CL::ENV) + (LET (CL::VALUE) + (WHILE CL::TAIL DO (CL:SETQ CL::VALUE (SET-SYMBOL (CL:POP CL::TAIL) + (CL:EVAL (CL:POP CL::TAIL) + CL::ENV) + CL::ENV))) + CL::VALUE)) + +(DEFINE-SPECIAL-FORM SETQ (VAR VALUE &ENVIRONMENT ENV) + (SET-SYMBOL VAR (CL:EVAL VALUE ENV) + ENV)) + +(PUTPROPS CL:SETQ DMACRO (DEFMACRO (X Y &REST CL:REST) `(PROGN + (SETQ ,X ,Y) + ,@(AND CL:REST + `((CL:SETQ ,@CL:REST)))))) + + + +(* |;;| "An nlambda definition for cl:setq so cmldeffer may use cl:setq will run in the init") + +(DEFINEQ + +(cl:setq (nlambda cl::tail (* \; "Edited 15-Nov-87 17:34 by jop") (let ((cl::value nil)) (cl:loop (cl:if (null cl::tail) (return cl::value)) (cl:setq cl::value (set (cl:pop cl::tail) (cl:if (not (boundp *evalhook*)) (progn (* |;;| "CMLEVAL Init-forms not yet run") (eval (cl:pop cl::tail))) (cl:eval (cl:pop cl::tail))))))))) +) + +(DEFMACRO SETQ (VAR &REST VALUE-FORMS) + (COND + ((NULL VALUE-FORMS) + `(CL:SETQ ,VAR NIL)) + ((NULL (CDR VALUE-FORMS)) + `(CL:SETQ ,VAR ,(CAR VALUE-FORMS))) + (T `(CL:SETQ ,VAR (PROG1 ,@VALUE-FORMS))))) +(DEFINEQ + +(set-symbol (lambda (cl:symbol value environment) (* \; "Edited 7-Jan-87 15:37 by gbn") (cl:block set-symbol (|if| environment |then| (setq environment (environment-vars environment)) (while environment do (if (eq cl:symbol (car environment)) then (* |;;| "found a binding for this symbol") (if (eq (car (setq environment (cdr environment))) *special-binding-mark*) then (* |;;| "it is a special binding, or a mark that we are using the special value") (return nil) (* \; "return from WHILE") ) (rplaca environment value) (* |;;| "smash new value in") (cl:return-from set-symbol value) else (setq environment (cddr environment))))) (* |;;| "no environment, or not found") (setq environment (\\stkscan cl:symbol)) (cond ((eq (\\hiloc environment) \\stackhi) (\\putbaseptr environment 0 value)) (t (\\rplptr environment 0 value))) value))) +) + +(DEFMACRO CL:PSETQ (&REST TAIL) + (AND TAIL `(PROGN (SETQ ,(|pop| TAIL) + ,(CL:IF (CDR TAIL) + `(PROG1 ,(POP TAIL) + (CL:PSETQ ,@TAIL)) + (CAR TAIL))) + NIL))) + +(DEFMACRO SETQQ (SYMBOL VALUE) (* \; + "so common lisp interpreter will know about it") + `(SETQ ,SYMBOL ',VALUE)) + +(DEFINE-SPECIAL-FORM CL:CATCH (CL::CATCH-TAG &REST CL::\\CATCH-FORMS &ENVIRONMENT CL::\\CATCH-ENV + ) + (CL:CATCH (CL:EVAL CL::CATCH-TAG CL::\\CATCH-ENV) + (\\EVAL-PROGN CL::\\CATCH-FORMS CL::\\CATCH-ENV))) + +(DEFINE-SPECIAL-FORM CL:THROW (CL::TAG CL::VALUE &ENVIRONMENT CL::ENV) + (CL:THROW (CL:EVAL CL::TAG CL::ENV) + (CL:EVAL CL::VALUE CL::ENV))) + +(DEFINE-SPECIAL-FORM CL:UNWIND-PROTECT (CL::\\FORM &REST CL::\\CLEANUPS &ENVIRONMENT CL::\\ENV) + (CL:UNWIND-PROTECT + (CL:EVAL CL::\\FORM CL::\\ENV) + (\\EVAL-PROGN CL::\\CLEANUPS CL::\\ENV))) +(DEFINEQ + +(cl:throw (nlambda (throw-tag throw-value) (declare (localvars . t)) (* |lmm| "30-May-86 00:09") (cl:throw (\\eval throw-tag) (\\eval throw-value)))) + +(cl:catch (nlambda \\catch-forms (* \; "Edited 7-Apr-88 16:53 by amd") (cl:catch (\\eval (car \\catch-forms)) (\\evprogn (cdr \\catch-forms))))) + +(cl:unwind-protect (nlambda \\unwind-forms (* \; "Edited 7-Apr-88 16:54 by amd") (cl:unwind-protect (\\eval (car \\unwind-forms)) (\\evprogn (cdr \\unwind-forms))))) +) + +(DEFMACRO PROG (VARS &BODY (BODY DECLS)) + `(CL:BLOCK NIL + (LET ,VARS ,@DECLS (CL:TAGBODY ,@BODY)))) + +(DEFMACRO PROG* (VARS &BODY (BODY DECLS)) + `(CL:BLOCK NIL + (LET* ,VARS ,@DECLS (CL:TAGBODY ,@BODY)))) + +(DEFINE-SPECIAL-FORM GO (CL::\\TAG &ENVIRONMENT CL::ENV) + (BIND CL::TAIL FOR CL::TAGBODIES ON (AND CL::ENV (ENVIRONMENT-TAGBODIES CL::ENV)) + BY CDDR WHEN (CL:SETQ CL::TAIL (CL:MEMBER CL::\\TAG (CAR CL::TAGBODIES))) + + (* |;;| "MUST use EQL, as tags may be integers.") + DO (HANDLER-BIND ((ILLEGAL-THROW #'(CL:LAMBDA (CL::C) + (CL:ERROR 'ILLEGAL-GO :TAG CL::\\TAG)))) + (CL:THROW (CADR CL::TAGBODIES) + CL::TAIL)) FINALLY (CL:ERROR 'ILLEGAL-GO :TAG CL::\\TAG))) + +(DEFINE-SPECIAL-FORM CL:TAGBODY (&REST CL::\\TAGBODY-TAIL &ENVIRONMENT CL::ENV) + (LET* ((CL::BLIP (CONS NIL NIL)) + (CL::\\NEW-ENV (\\MAKE-CHILD-ENVIRONMENT CL::ENV :TAGBODY (CL::\\TAGBODY-TAIL CL::BLIP) + ))) + (WHILE (CL:SETQ CL::\\TAGBODY-TAIL (CL:CATCH CL::BLIP + (FOR CL::X IN CL::\\TAGBODY-TAIL + UNLESS (CL:SYMBOLP CL::X) + DO (CL:EVAL CL::X CL::\\NEW-ENV))) + )))) +(DEFINEQ + +(cl:tagbody (nlambda tail (* |lmm| "23-May-86 16:05") (* |like| prog |with| |no|  |variables|) (let ((tl (cons nil tail))) (\\prog0 tl tl)))) +) + + + +(* \; "for macro caching") + +(DEFINEQ + +(cachemacro (lambda (fn body env) (* \; "Edited 25-Sep-87 18:32 by jop") (* |;;;| "We want to cache the expansion unless") (* |;;| "1) the env is not an interpreted env (including NIL), ") (* |;;| "2) there are lexical macros in force, OR") (* |;;| "3) There is a compiler-let in force.") (cl:if (or (not (typep env 'environment)) (and env (for fn in (cdr (environment-functions env)) by cddr thereis (eq (car fn) :macro))) *in-compiler-let*) (cl:funcall fn body env) (or (gethash body clisparray) (puthash body (cl:funcall fn body env) clisparray))))) +) + +(CL:DEFPARAMETER *MACROEXPAND-HOOK* 'CACHEMACRO) + +(RPAQQ *IN-COMPILER-LET* NIL) + + + +(* |;;| "PROCLAIM and friends.") + + + + +(* |;;| +"Needs to come first because DEFVARs put it out. With package code in the init, also need this here rather than CMLEVAL" +) + + +(CL:DEFUN CL:PROCLAIM (CL::PROCLAMATION) + + (* |;;| "PROCLAIM is a top-level form used to pass assorted information to the compiler. This interpreter ignores proclamations except for those declaring variables to be SPECIAL.") + + (CL:WHEN (CL:CONSP CL::PROCLAMATION) + (CASE (CAR CL::PROCLAMATION) + (CL:SPECIAL (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF ( + VARIABLE-GLOBALLY-SPECIAL-P + CL::X) + T) + (CL:SETF (VARIABLE-GLOBAL-P + CL::X) + NIL) + (CL:SETF (CL:CONSTANTP + CL::X) + NIL))) + (GLOBAL (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF (VARIABLE-GLOBAL-P + CL::X) + T) + (CL:SETF ( + VARIABLE-GLOBALLY-SPECIAL-P + CL::X) + NIL) + (CL:SETF (CL:CONSTANTP + CL::X) + NIL))) + (SI::CONSTANT (FOR CL::X IN (CDR CL::PROCLAMATION) + DO (CL:SETF (CL:CONSTANTP CL::X) + T) + (CL:SETF (VARIABLE-GLOBAL-P CL::X) + NIL) + (CL:SETF (VARIABLE-GLOBALLY-SPECIAL-P CL::X) + NIL))) + (CL:DECLARATION (FOR CL::X IN (CDR CL::PROCLAMATION) + DO (CL:SETF (XCL::DECL-SPECIFIER-P CL::X) + T))) + (CL:NOTINLINE (FOR CL::X IN (CDR CL::PROCLAMATION) + DO (CL:SETF (XCL::GLOBALLY-NOTINLINE-P CL::X) + T))) + (CL:INLINE (FOR CL::X IN (CDR CL::PROCLAMATION) DO (CL:SETF ( + XCL::GLOBALLY-NOTINLINE-P + CL::X) + NIL)))))) + + + +(* \; "used by the codewalker, too") + +(DECLARE\: EVAL@COMPILE + +(PUTPROPS VARIABLE-GLOBALLY-SPECIAL-P MACRO ((VARIABLE) + (GET VARIABLE 'GLOBALLY-SPECIAL))) + +(PUTPROPS VARIABLE-GLOBAL-P MACRO ((VARIABLE) + (GET VARIABLE 'GLOBALVAR))) +) + +(CL:DEFUN XCL::DECL-SPECIFIER-P (CL:SYMBOL) + (GET CL:SYMBOL 'SI::DECLARATION-SPECIFIER)) + +(CL:DEFUN XCL::SET-DECL-SPECIFIER-P (XCL::SPEC XCL::VAL) + (CL:SETF (GET XCL::SPEC 'SI::DECLARATION-SPECIFIER) + XCL::VAL)) + +(CL:DEFUN XCL::GLOBALLY-NOTINLINE-P (XCL::FN) + (GET XCL::FN 'SI::GLOBALLY-NOTINLINE)) + +(CL:DEFUN XCL::SET-GLOBALLY-NOTINLINE-P (XCL::FN XCL::VAL) + (CL:SETF (GET XCL::FN 'SI::GLOBALLY-NOTINLINE) + XCL::VAL)) + +(CL:DEFSETF XCL::DECL-SPECIFIER-P XCL::SET-DECL-SPECIFIER-P) + +(CL:DEFSETF XCL::GLOBALLY-NOTINLINE-P XCL::SET-GLOBALLY-NOTINLINE-P) + +(PUTPROPS GLOBALLY-SPECIAL PROPTYPE IGNORE) + +(PUTPROPS GLOBALVAR PROPTYPE IGNORE) + +(PUTPROPS SI::DECLARATION-SPECIFIER PROPTYPE IGNORE) + +(PUTPROPS SI::GLOBALLY-NOTINLINE PROPTYPE IGNORE) + +(PUTPROPS SPECIAL-FORM PROPTYPE IGNORE) + +(PUTPROPS CMLEVAL FILETYPE CL:COMPILE-FILE) + +(PUTPROPS CMLEVAL MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) +(DECLARE\: EVAL@COMPILE DONTCOPY + +(DEFOPTIMIZER CL-EVAL-FN3-CALL (ARG1 ARG2 &ENVIRONMENT ENV) + + (* |;;| "Emit a call to FN3 after pushing only 2 arguments (the other having been pushed by IL:.COMPILER-SPREAD-ARGUMENTS. earlier in the game). Used in CL:EVAL.") + + (COND + ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) + `((OPCODES FN3 0 0 0 (FN . \\EVAL-INVOKE-LAMBDA) + RETURN) + ,ARG1 + ,ARG2)) + ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) + `((OPCODES FN3 0 0 (FN . \\EVAL-INVOKE-LAMBDA) + RETURN) + ,ARG1 + ,ARG2)) + (T `((OPCODES FN3 0 (FN . \\EVAL-INVOKE-LAMBDA) + RETURN) + ,ARG1 + ,ARG2)))) +) +(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY +(DECLARE\: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA CL:TAGBODY CL:UNWIND-PROTECT CL:CATCH CL:SETQ CL:BLOCK CL:EVAL-WHEN + CL:COMPILER-LET COMMON-LISP) + +(ADDTOVAR NLAML CL:THROW CL:FUNCTION CL:RETURN-FROM CL:IF) + +(ADDTOVAR LAMA CL:APPLY CL:FUNCALL) +) +(PUTPROPS CMLEVAL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (16590 16771 (COMMON-LISP 16600 . 16769)) (16810 22264 (\\TRANSLATE-CL\:LAMBDA 16820 . +22262)) (25766 50966 (CL:EVAL 25776 . 34711) (\\EVAL-INVOKE-LAMBDA 34713 . 35913) ( +\\INTERPRET-ARGUMENTS 35915 . 47331) (\\INTERPRETER-LAMBDA 47333 . 48020) (CHECK-BINDABLE 48022 . +48678) (CHECK-KEYWORDS 48680 . 50964)) (51110 51755 (DECLARED-SPECIAL 51120 . 51753)) (51820 52506 ( +CL:FUNCALL 51830 . 51993) (CL:APPLY 51995 . 52504)) (54754 56393 (CL:COMPILER-LET 54764 . 55558) ( +COMP.COMPILER-LET 55560 . 56391)) (63209 63498 (CL:EVAL-WHEN 63219 . 63496)) (63925 64325 ( +\\EVAL-PROGN 63935 . 64323)) (67720 71340 (\\LET*-RECURSION 67730 . 69073) (|\\LETtran| 69075 . 71338) +) (73162 73424 (CL:IF 73172 . 73422)) (75753 75917 (CL:BLOCK 75763 . 75915)) (76563 77808 ( +CL:RETURN-FROM 76573 . 77806)) (79253 79554 (CL:FUNCTION 79263 . 79552)) (84577 84797 (COMP.CL-EVAL +84587 . 84795)) (86277 87489 (CL:CONSTANTP 86287 . 87487)) (88889 89579 (CL:SETQ 88899 . 89577)) ( +89832 91441 (SET-SYMBOL 89842 . 91439)) (92634 93303 (CL:THROW 92644 . 92857) (CL:CATCH 92859 . 93069) + (CL:UNWIND-PROTECT 93071 . 93301)) (94809 95158 (CL:TAGBODY 94819 . 95156)) (95194 96093 (CACHEMACRO +95204 . 96091))))) +STOP diff --git a/sources/CMLEXEC b/sources/CMLEXEC new file mode 100644 index 00000000..fe99a21c --- /dev/null +++ b/sources/CMLEXEC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Jan-93 11:16:01" {DSK}lde>lispcore>sources>CMLEXEC.;2 92477 changes to%: (FUNCTIONS ADD-EXEC) previous date%: "25-Jun-91 12:22:29" {DSK}lde>lispcore>sources>CMLEXEC.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLEXECCOMS) (RPAQQ CMLEXECCOMS [(FILES CMLUNDO PROFILE) (XCL:PROFILES "EXEC") (STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY) (* ;  "These are public except for command-entry.") (FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE XCL:SET-DEFAULT-EXEC-TYPE XCL::ENTER-EXEC-FUNCTION) (SETFS XCL::GET-PROCESS-PROFILE) (FUNCTIONS DO-EVENT EXEC EXEC-EVAL PRINT-ALL-DOCUMENTATION PRINT-DOCUMENTATION VALUE-OF ADD-EXEC EXEC-READ-LINE EXEC-EVENT-ID-PROMPT FIND-EXEC-COMMAND) (FUNCTIONS CIRCLAR-COPYER) (FNS COPY-CIRCLE) (* ;  "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (FNS EXEC-READ DIR) (VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:/// *CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED* *THIS-EXEC-COMMANDS* *EXEC-COMMAND-TABLE* *DEBUGGER-COMMAND-TABLE* *CURRENT-EXEC-TYPE* *EXEC-MAKE-UNDOABLE-P*) (VARIABLES *EDIT-INPUT-WITH-TTYIN*) (FNS DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EVENTS-INPUT EXEC-PRIN1 EXEC-VALUE-OF GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT LISPXREPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? 'READ 'TTYINREAD) (MOVD '\PICK.EVALQT '\PROC.REPEATEDLYEVALQT) (SETQ BackgroundMenu))) (FUNCTIONS CASE-EQUALP EXEC-EVENT-PROPS EXEC-PRINT EXEC-FORMAT) (ALISTS (BackgroundMenuCommands EXEC)) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (* ;; "Exec Commands") (DEFINE-TYPES COMMANDS) (FUNCTIONS DEFCOMMAND) (COMMANDS "?" "??" "CONN" "DA" "DIR" "DO-EVENTS" "FIX" "FORGET" "NAME" "NDIR" "PL" "REDO" "REMEMBER" "SHH" "UNDO" "USE" "PP") (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLEXEC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DIR) (NLAML) (LAMA]) (FILESLOAD CMLUNDO PROFILE) (XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "") (XCL:*EXEC-PROMPT* "") (*READTABLE* "XCL") (*PACKAGE* "XCL") (XCL:*EVAL-FUNCTION* 'CL:EVAL)) (CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST)) ARGUMENTS FUNCTION MODE) (CL:DEFSTRUCT (EXEC-EVENT-ID (:TYPE LIST)) NUMBER NAME dummy) (CL:DEFSTRUCT (EXEC-EVENT (:TYPE LIST)) INPUT ID (VALUE *NOT-YET-EVALUATED*) dummy) (CL:DEFSTRUCT (HISTORY (:TYPE LIST)) (EVENTS NIL) (INDEX 0) (SIZE 100) (MOD 100)) (* ; "These are public except for command-entry.") (CL:DEFUN XCL::EXEC-CLOSEFN (XCL::WINDOW) [LET [(XCL::PROCESS (WINDOWPROP XCL::WINDOW 'PROCESS] (COND ((EQ (THIS.PROCESS) XCL::PROCESS) [ADD.PROCESS `(CLOSEW ',XCL::WINDOW] 'DON'T) ((PROCESSP XCL::PROCESS) (CL:IF (TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T)) (DEL.PROCESS XCL::PROCESS]) (CL:DEFUN XCL::EXEC-SHRINKFN (XCL::WINDOW) (LET [(XCL::PROCESS (WINDOWPROP XCL::WINDOW 'PROCESS] (COND ((EQ (THIS.PROCESS) XCL::PROCESS) [ADD.PROCESS `(SHRINKW ',XCL::WINDOW] 'DON'T) ((TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T) NIL)))) (CL:DEFUN XCL::SETUP-EXEC-WINDOW (XCL::WINDOW) "Add (non-title) properties to a new exec window." (WINDOWADDPROP XCL::WINDOW 'CLOSEFN 'XCL::EXEC-CLOSEFN) (WINDOWADDPROP XCL::WINDOW 'SHRINKFN 'XCL::EXEC-SHRINKFN) XCL::WINDOW) (CL:DEFUN XCL::EXEC-TITLE-FUNCTION (XCL::WINDOW EXEC-ID) [WINDOWPROP XCL::WINDOW 'TITLE (CL:FORMAT NIL "Exec ~A (~A)" EXEC-ID (READTABLEPROP *READTABLE* 'NAME]) (CL:DEFUN FIX-FORM (INPUT &OPTIONAL (CIRCLE-FLAG NIL)) (* ;;; "Edits a form, in the current window if it is shorter than ttyinfixlimit, or if longer in the display editor using edite. Returns the newly edited form.") (* ; "Edited by Tomoru Teruuchi") [COND ((OR (NOT *EDIT-INPUT-WITH-TTYIN*) (NOT (IMAGESTREAMP (TTYDISPLAYSTREAM))) (AND (NOT CIRCLE-FLAG) (EQUAL 0 (COUNTDOWN INPUT TTYINFIXLIMIT))) (* ; "(IGEQ (COUNT INPUT) TTYINFIXLIMIT) is Original Code. But This Codecan't accept circler. Edited by TT (31-May-1990)") ) (EDITE (CL:IF (AND (EQ 1 (LENGTH INPUT)) (CL:CONSP (CAR INPUT))) (CAR INPUT) INPUT) NIL NIL T NIL :CLOSE-ON-COMPLETION) INPUT) (T (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (CURSOR T) (* ;  "make sure can edit (in case cursor smashed somehow?)") (CL:WHEN NIL (* ; "Old expression") (TTYIN "" NIL NIL 'LISPXREAD NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*)) (EXEC-READ-LINE (LET ((%#RPARS NIL) (FONTCHANGEFLG NIL) (*PRINT-ESCAPE* T) (*PRINT-RADIX* (NOT (= *READ-BASE* 10))) (*PRINT-BASE* *READ-BASE*) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-GENSYM* ':REREAD) (*PRINT-ARRAY* T) (*PRINT-STRUCTURE* T)) (DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG) (* ;  "others are already globally special ") ) (CL:WITH-OUTPUT-TO-STRING (STR) (FOR X ON INPUT DO (IF CIRCLE-FLAG THEN (* ;  "Edited by TT (31-May-1990) CL:PRIN1 can print circlar") (CL:PRIN1 (CAR X) STR) ELSEIF (LISTP (CAR X)) THEN (PRINTDEF (CAR X) (POSITION STR) NIL NIL NIL STR) ELSE (PRIN2 (CAR X) STR)) (AND (CDR X) (PRIN1 " " STR]) (CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))) (PROCESSPROP XCL::PROCESS 'PROFILE)) (CL:DEFUN XCL::SAVE-CURRENT-EXEC-PROFILE () "Resave the profiled bindings of the exec process into their cache." (LET [(XCL::PROFILE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS] (CL:IF (XCL:PROFILE-P XCL::PROFILE) (XCL:SAVE-PROFILE XCL::PROFILE)))) (CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)) (XCL::PROFILE XCL:*PROFILE*)) (CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE)) (PROCESSPROP XCL::PROCESS 'PROFILE XCL::PROFILE) XCL::PROFILE) (CL:DEFUN XCL:SET-EXEC-TYPE (TYPE) "Set the current Exec's type to TYPE" (* ;; "The EXECA-FRAME bit is a gross hack to make this function work inside init files. The problem is that you want to affect the EXEC, regardless of who has bound the per-exec variables between here an the EXEC frame. Yech.") [LET [(XCL::EXECA-FRAME (STKPOS 'XCL::EXECA0001] (COND (XCL::EXECA-FRAME (ENVEVAL `(XCL:RESTORE-PROFILE ',TYPE) XCL::EXECA-FRAME XCL::EXECA-FRAME)) (T (XCL:RESTORE-PROFILE TYPE]) (CL:DEFUN XCL:SET-DEFAULT-EXEC-TYPE (TYPE) (SETTOPVAL 'XCL:*PROFILE* TYPE)) (CL:DEFUN XCL::ENTER-EXEC-FUNCTION (XCL::EXEC-FUNCTION XCL::PROFILE XCL::ID) "Start up an exec function in the proper profile, setting the default window title properly." (XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE) (XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (CL:FUNCALL XCL::EXEC-FUNCTION))) (CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE) (CL:DEFUN DO-EVENT (ORIGINAL-INPUT ENVIRONMENT &OPTIONAL (FUNCTION (FUNCTION EVAL-INPUT))) (* ; "Edited by Tomoru Teruuchi") (PROG (TODO INPUT VALUES COM (ADD-TO-SPELLING-LIST ADDSPELLFLG) STR (RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break. It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).") ) (DECLARE (CL:SPECIAL RETRYFLAG)) (* ;  "RETRY command sets this variable if it wants to be sure to break.") (DSPFONT PRINTOUTFONT T) (SETQ INPUT ORIGINAL-INPUT) RETRY (SETQ TODO (COPY-CIRCLE INPUT)) (* ; "Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.") [COND [[AND (OR (STRINGP (CAR INPUT)) (CL:SYMBOLP (CAR INPUT))) (PROGN (SETQ STR (STRING (CAR INPUT))) (SOME *THIS-EXEC-COMMANDS* (FUNCTION (LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE] (* ;; "Handle exec commands.") (CL:ECASE (COMMAND-ENTRY-MODE COM) (:QUIET [MAPC (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT))) (FUNCTION (LAMBDA (X) (EXEC-PRINT X] (SETQ IT (CAR VALUES)) (* ; "just do it and return") (RETURN)) ((:HISTORY :INPUT) (* ; " create new input. If an error occurs while handling the command, the INPUT will be left as the original input.") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (SETQ INPUT (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT)) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT) (* ;  " Overwrite the original input with the newly generated one.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* '*HISTORY* ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT* )))) (GO RETRY) (* ; " could have generated a command") ) ((NIL :EVAL) (* ;  " normal kind of command, just apply") [SETQ TODO `((CL:FUNCALL ',(COMMAND-ENTRY-FUNCTION COM) ',INPUT ',ENVIRONMENT] (SETQ ADD-TO-SPELLING-LIST NIL) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT))))] (T (* ;; "Handle non-exec commands (fns, functions, macros, etc.).") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (CL:WHEN *EXEC-MAKE-UNDOABLE-P* [if (CDR TODO) then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO) LISPXFNS)) (CAR TODO)) (CDR TODO))) else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO) NIL])] (AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ LISPXHIST *CURRENT-EVENT*) (DSPFONT PRINTOUTFONT T) (RETURN (LET ((HELPCLOCK (CLOCK 2)) VALUES) (DECLARE (CL:SPECIAL HELPCLOCK)) (CL:SETQ CL:+++ CL:++ CL:++ + + - - (CAR INPUT)) (* ;; "the book doesn't define what - and friends should be when input is in APPLY format. Here it says it is just the function name.") [SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG (LET ((HELPFLAG 'BREAK!)) (DECLARE (CL:SPECIAL HELPFLAG )) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)) ] (CL:SETQ CL:/// CL:// CL:// / / VALUES) (CL:UNLESS (EQ 'NOBIND (CAR VALUES)) (* ; "Be a bit careful about NOBIND.") (CL:SETQ CL:*** CL:** CL:** CL:* CL:* (SETQ IT (CAR VALUES)))) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (CAR VALUES)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* 'LISPXVALUES VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*)))) (DSPFONT VALUEFONT T) (for X in VALUES do (EXEC-PRINT X)) VALUES)))) (CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ;  "True of top level execs. Used for event number restarting and profile caching.") (XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM))) (* ; "Window for this exec, if any.") (XCL::TITLE NIL XCL::TITLE-SUPPLIED)(* ;  "If given, specific title for this window.") ((:COMMAND-TABLES *THIS-EXEC-COMMANDS*) (LIST *EXEC-COMMAND-TABLE*)) (* ;  "List of hash tables to look up commands in.") XCL::ENVIRONMENT (* ;  "Lexical environment to evaluate things in, default NIL.") XCL::PROMPT (* ;  "Special prompt to use (optional).") ((:FUNCTION XCL::FN) 'EVAL-INPUT) (* ; "Function for processing input.") XCL::PROFILE (* ;  "Optional profile, sets the exec's bindings.") XCL::ID (* ; "A handle on the exec.") &ALLOW-OTHER-KEYS (* ; "To catch obsolete calls") &AUX (*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))) (* ;  "The exec's cached profile (if entering from a hardreset).") ) [CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR)) [MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X) (EVAL (CADR XCL::X] (CL:WHEN (OR (NULL XCL::TOP-LEVEL-P) (NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...") (CL:WHEN XCL::PROFILE (* ;  "then initialize the profile vars.") (XCL:RESTORE-PROFILE XCL::PROFILE)) (CL:WHEN XCL::PROMPT (* ;  "If a special prompt was provided (as from the debugger)...") (CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it.") )) (CL:WHEN XCL::TOP-LEVEL-P (CL:IF (NULL XCL::PROFILE-CACHE) (* ;  "This was a new entry into top level exec.") (CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)) (XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC"))) (* ;  "...make a fresh cache and save bindings into it.") (XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ;  "...otherwise it was a HARDRESET.") )) (CL:WHEN XCL::WINDOW (COND ((NOT XCL::TITLE-SUPPLIED) (* ;  "If no title was supplied, set it to the default.") (XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*)) (XCL::TITLE (* ;  "If a non-nil title was supplied, set the title to it.") (WINDOWPROP XCL::WINDOW 'TITLE XCL::TITLE))) (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW))) (LET [(*CURRENT-EVENT* NIL) (* ;  "the event being processed. Used by some commands") (XCL::OLD-DS (CL:IF XCL::WINDOW (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW)))] (CL:LOOP (CL:FORMAT T "~&~%%") (* ;  "newlines to notice that this is a new instance of the exec") (PROG1 [ERSETQ (CL:LOOP (* ; "loop until errors out") (CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY *EXEC-ID* XCL:*EXEC-PROMPT* (NOT XCL::TOP-LEVEL-P ))) (* ; "This optimization keeps HARDRESET from generating all new event numbers for all execs that are open.") (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (LET ((XCL::ORIGINAL-INPUT (EXEC-READ-LINE)) (LISPXHIST LISPXHIST) (HELPCLOCK 0)) (DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK)) (CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT '(NIL)) (DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT XCL::FN) (CL:WHEN XCL::TOP-LEVEL-P (* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).") (XCL::SAVE-CURRENT-EXEC-PROFILE)))] (CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))]) (CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">") (ID "eval/") ((:TYPE *CURRENT-EXEC-TYPE*) 'COMMON-LISP)) (* ; "Edited by JDS 16-Aug-90 12:55.") (LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T)) (LISPXHIST LISPXHIST) (HELPCLOCK 0) VALUES) (DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK)) (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (LIST FORM)) ENVIRONMENT))) (SETQ IT (CAR VALUES)) (COND (*CURRENT-EVENT* (* ;; "Only update the current event if it's not NIL. This might happen, e.g., if LISPXHIST has been set to NIL by the user.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* 'LISPXVALUES VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*))) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) IT))) (CL:VALUES-LIST VALUES))) (CL:DEFUN PRINT-ALL-DOCUMENTATION (NAME) "Print all documentation strings for NAME (as symbol and string)." (LET ((FOUND NIL)) (CL:DOLIST (TYPE FILEPKGTYPES) (CL:WHEN (AND (CL:SYMBOLP TYPE) (GET TYPE 'DEFINED-BY) (HASH-TABLE-FOR-DOC-TYPE TYPE)) (SETQ FOUND (OR (PRINT-DOCUMENTATION NAME TYPE) FOUND)) (CL:WHEN (CL:SYMBOLP NAME) (SETQ FOUND (OR (PRINT-DOCUMENTATION (STRING NAME) TYPE) FOUND))))) (CL:UNLESS FOUND (CL:FORMAT *TERMINAL-IO* "No documentation found.~%%")))) (CL:DEFUN PRINT-DOCUMENTATION (NAME TYPE) "If it exists, print documentation for NAME as TYPE. Returns T if doc was found, else NIL." [LET ((DOC (CL:DOCUMENTATION NAME TYPE))) (AND DOC (TRUE (CL:FORMAT *TERMINAL-IO* "~&~A (~A)" DOC (OR (CL:DOCUMENTATION NAME 'DEFINE-TYPES) TYPE]) (DEFMACRO VALUE-OF (&REST EVENT-SPEC) `(EXEC-VALUE-OF ',EVENT-SPEC)) (CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*) XCL::REGION XCL::TTY (EXEC 'EXEC) XCL::ID &ALLOW-OTHER-KEYS) (LET* [(XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec"))) (XCL::HANDLE (ADD.PROCESS `[PROGN (TTYDISPLAYSTREAM ',XCL::WINDOW) (PROCESSPROP (THIS.PROCESS) 'WINDOW ',XCL::WINDOW) ,(CASE EXEC (EXEC `(EXEC :TOP-LEVEL-P T :PROFILE ',XCL::PROFILE :ID ',XCL::ID)) (T `(XCL::ENTER-EXEC-FUNCTION ',EXEC ',XCL::PROFILE ',XCL::ID)))] 'NAME 'EXEC 'RESTARTABLE T 'INTERRUPTS (LISPINTERRUPTS] (AND XCL::TTY (TTY.PROCESS XCL::HANDLE)) XCL::HANDLE)) (CL:DEFUN EXEC-READ-LINE (&OPTIONAL BUFFER-STRING) (* ;; "Code stolen from READLINE, and not cleaned up. ") [PROG (LINE SPACEFLG CHRCODE (*IN-THE-DEBUGGER* NIL)) (COND ((AND (READP T) (SYNTAXP (PEEKCCODE T T) 'EOL)) (* ;  "Avoid picking up end of line as a NIL.") (READC T))) (SETQ LINE (LIST (EXEC-READ BUFFER-STRING))) TOP (COND ((LISTP (CAR LINE)) (* ;  "If we got a list, return right away--it's a standard EVAL form of input") (GO OUT))) LP (SETQ SPACEFLG NIL) (* ; "to distinguish between") (* ; "FOO (A B)") (* ; "FOO(A B)") (* ;  "the latter has no space and returns right away") LP1 (COND ((NOT (READP T)) (* ;  "nothing more in line buffer, so must have consumed last thing on the line") (GO OUT)) ((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF. However, we already checked for READP before getting here.") (GO OUT)) ((SYNTAXP CHRCODE 'EOL) (READC T) (GO OUT)) ((OR (SYNTAXP CHRCODE 'RIGHTPAREN *READTABLE*) (SYNTAXP CHRCODE 'RIGHTBRACKET *READTABLE*)) (AND (READ T *READTABLE*) (SHOULDNT)) (AND (NULL (CDR LINE)) (SETQ LINE (NCONC1 LINE NIL))) (* ;  " A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called") (GO OUT)) ((EQ CHRCODE (CHARCODE SPACE)) (SETQ SPACEFLG T) (READC T) (GO LP1))) (SETQ LINE (NCONC1 LINE (EXEC-READ))) (COND ((NULL (OR (SYNTAXP (SETQ CHRCODE (CHCON1 (LASTC T))) 'RIGHTPAREN *READTABLE*) (SYNTAXP CHRCODE 'RIGHTBRACKET *READTABLE*))) (GO LP)) ((NOT SPACEFLG) (* ;  "A list terminates the line if it is the second element on the line, not preceded by a space.") (* ;; "[JDS 1/12/88: This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending. This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing. Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing. With the old test here, that would hang up a final eval-quote form without executing it.]") (GO OUT)) (T (GO LP))) (GO LP) OUT (RETURN (COND ((AND (LISTP LINE) CTRLUFLG) (* ;  "Edit interrupt during reading--forces structure editor use.") (SETQ CTRLUFLG NIL) (LET ((*EDIT-INPUT-WITH-TTYIN* NIL)) (FIX-FORM LINE))) (T LINE]) (DEFMACRO EXEC-EVENT-ID-PROMPT (EVENT-ID) `(CDDR ,EVENT-ID)) (CL:DEFUN FIND-EXEC-COMMAND (NAME TABLE) "Find an exec command based on its name (either a string or a symbol). Returns the command entry or NIL if not found." (CL:WHEN (OR (CL:STRINGP NAME) (CL:SYMBOLP NAME)) (LET ((STR (CL:IF (CL:SYMBOLP NAME) (CL:SYMBOL-NAME NAME) NAME))) (CL:SOME #'(CL:LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE))) TABLE)))) (CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990") (PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL)) (COND ((NLISTP INPUT) (RETURN INPUT)) (T [push SCANBUF (CONS INPUT (SETQ VAL (CONS NIL NIL] (push REST VAL) (RPLACA VAL (CAR INPUT)) (RPLACD VAL (CDR INPUT)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))") )) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 [COND ((NULL BODY) (RETURN (CL:VALUES VAL CIRCLAR-FLAG))) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACD NEW (CDR ID))) (T [push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW] (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACA NEW (CDR ID))) (T [push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW] (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX] (GO LP))) (DEFINEQ (COPY-CIRCLE (LAMBDA (X) (* ; "Edited 23-May-90 15:02 by Tomtom") (PROG (SCANBUF REST VAL NEW BODY ID AUX) (COND ((NLISTP X) (RETURN X)) (T (push SCANBUF (CONS X (SETQ VAL (CONS NIL NIL)))) (push REST VAL) (RPLACA VAL (CAR X)) (RPLACD VAL (CDR X)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))"))) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 (COND ((NULL BODY) (RETURN VAL)) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (RPLACD NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW)))) (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (RPLACA NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW)))) (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX))))) (GO LP))) ) ) (* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (DEFINEQ (EXEC-READ [CL:LAMBDA (&OPTIONAL BUFFER-STRING) (* ; "Edited 4-Feb-88 18:22 by amd") (* ;;; "Reads structure from the user (in the exec), taking care to handle read errors so that they will be edited and fixed.") (HANDLER-BIND [[XCL:SYMBOL-COLON-ERROR #'(LAMBDA (CONDITION) (DECLARE (CL:SPECIAL CTRLUFLG)) (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION) (SETQ CTRLUFLG T) (XCL::ESCAPE-COLONS-PROCEED) (SHOULDNT "Didn't find XCL::ESCAPE-COLONS-PROCEED"] [XCL:MISSING-EXTERNAL-SYMBOL #'(LAMBDA (CONDITION) (DECLARE (CL:SPECIAL CTRLUFLG)) (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION) (SETQ CTRLUFLG T) (XCL:MAKE-INTERNAL-PROCEED) (SHOULDNT "Didn't find XCL:MAKE-INTERNAL-PROCEED" ] (XCL:MISSING-PACKAGE #'(LAMBDA (CONDITION) (DECLARE (CL:SPECIAL CTRLUFLG)) (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION) (SETQ CTRLUFLG T) (XCL:UGLY-SYMBOL-PROCEED) (SHOULDNT "Didn't find XCL:UGLY-SYMBOL-PROCEED"] (COND ([OR (NOT (GETD 'TTYIN)) (NOT *EDIT-INPUT-WITH-TTYIN*) (NOT (DISPLAYSTREAMP (GETSTREAM T 'OUTPUT] (* ;  "If debugging and TTYIN breaks, don't want to die") (CL:READ T)) (T (LET (X) (COND ((OR (LINEBUFFER-SKIPSEPRS T *READTABLE*) (until (SETQ X (TTYIN "" NIL NIL '(EVALQT FILLBUFFER NOPROMPT) NIL NIL BUFFER-STRING *READTABLE*)) do (* ;; "Until he types something at all, keep printing the event-number prompt.") (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T)) (EQ X T)) (CL:READ-PRESERVING-WHITESPACE T)) (T (CAR X]) (DIR [NLAMBDA ARGS (* ; "Edited 12-Mar-87 16:08 by raf") (DODIR ARGS]) ) (CL:DEFPARAMETER *PER-EXEC-VARIABLES* '((CL:* CL:*) (CL:** CL:**) (CL:*** CL:***) (+ +) (CL:++ CL:++) (CL:+++ CL:+++) (- -) (/ /) (CL:// CL://) (CL:/// CL:///) (HELPFLAG T) (*EVALHOOK* NIL) (*APPLYHOOK* NIL) (*ERROR-OUTPUT* *TERMINAL-IO*) (*READTABLE* *READTABLE*) (*PACKAGE* *PACKAGE*) (XCL:*EVAL-FUNCTION* XCL:*EVAL-FUNCTION*) (XCL:*EXEC-PROMPT* XCL:*EXEC-PROMPT*) (XCL:*DEBUGGER-PROMPT* XCL:*DEBUGGER-PROMPT*)) "List of (non-profile) variables rebound for each Exec") (CL:DEFVAR CL:* NIL) (CL:DEFVAR CL:** NIL) (CL:DEFVAR CL:*** NIL) (CL:DEFVAR + NIL) (CL:DEFVAR CL:++ NIL) (CL:DEFVAR CL:+++ NIL) (CL:DEFVAR - NIL) (CL:DEFVAR / NIL "Holds a list of all the values returned by the most recent top-level EVAL.") (CL:DEFVAR CL:// NIL "Gets the previous value of / when a new value is computed.") (CL:DEFVAR CL:/// NIL "Gets the previous value of // when a new value is computed.") (CL:DEFVAR *CURRENT-EVENT* NIL "contains the current event being processed. Used for communicating between Exec and commands") (CL:DEFVAR *EXEC-ID* NIL "A unique per-exec-process ID so that commands that search the history list can find this Exec's events" ) (CL:DEFVAR XCL:*EXEC-PROMPT* "> " "Default prompt used by exec") (CL:DEFPARAMETER XCL:*EVAL-FUNCTION* 'CL:EVAL "The evaluator to use in the exec") (CL:DEFVAR *NOT-YET-EVALUATED* "") (CL:DEFVAR *THIS-EXEC-COMMANDS* NIL "List of command hash-tables for the current executive") (DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL) "hash-table for top level exec commands") (DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL 'STRING-EQUAL-HASHBITS 'STRING-EQUAL) "string-equal hash-table for debugger commands") (CL:DEFVAR *CURRENT-EXEC-TYPE* NIL "Rebound under Exec; if NIL, means use default") (CL:DEFPARAMETER *EXEC-MAKE-UNDOABLE-P* T "global parameter controls whether the exec makes input undoable") (CL:DEFVAR *EDIT-INPUT-WITH-TTYIN* T) (DEFINEQ (DO-APPLY-EVENT [LAMBDA (TODO) (* lmm "31-Jul-86 03:22") (CL:IF (CL:MACRO-FUNCTION (CAR TODO)) (CL:IF (EQ (ARGTYPE (CAR TODO)) 3) (CL:FUNCALL (CAR TODO) (CL:IF (CDDR TODO) (CDR TODO) (CADR TODO))) (CL:EVAL TODO)) (CL:APPLY (CAR TODO) (CADR TODO]) (DO-HISTORY-SEARCH [LAMBDA (SPEC PRED-P VALUE-P) (* ; "Edited 10-Mar-87 18:53 by raf") (* ;; "SEARCHES HISTORY LIST, LOOKING FOR SPEC AND RESETTING *EVENTS* TO THE CORRESPONDING TAIL.") (PROG (PAT1 PAT2 TEM PRED) (DECLARE (CL:SPECIAL *EVENTS*)) (* ; "Setup by FIND-HISTORY-EVENTS") [COND ((NOT PRED-P) (SETQ PAT2 (EDITFPAT SPEC T] LP [COND ((EQ (CAR *EVENTS*) *CURRENT-EVENT*) (SETQ *EVENTS* (CDR *EVENTS*] [COND ((COND (PRED-P (APPLY* SPEC (CAR *EVENTS*))) [PAT1 (EDIT4E PAT1 (CAR (EXEC-EVENT-INPUT (CAR *EVENTS*] (T (EDITFINDP [COND (VALUE-P (CL:GETF (EXEC-EVENT-PROPS (CAR *EVENTS*)) 'LISPXVALUES)) (T (EXEC-EVENT-INPUT (CAR *EVENTS*] PAT2 T))) (RETURN *EVENTS*)) (T (SETQ *EVENTS* (CDR *EVENTS*] LP1 (COND ((NULL *EVENTS*) (RETURN NIL))) (GO LP]) (EVAL-INPUT [CL:LAMBDA (TODO ENV) (* ; "Edited 23-Nov-87 13:07 by raf") (CASE XCL:*EVAL-FUNCTION* [EVAL (* ; "Interlisp EVAL") (COND [(CDR TODO) (* ; "this is the 'apply' case") (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)") (if [OR (CDDR TODO) (AND (CADR TODO) (NLISTP (CADR TODO] then (if (FMEMB (ARGTYPE (CAR TODO)) '(1 3)) then (* ; "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).") [if (AND (EQ (ARGTYPE (CAR TODO)) 3) (CDDR TODO)) then (APPLY (CAR TODO) (CDR TODO)) else (if (CDDR TODO) then (PRIN1 "... = ") (PRINT TODO) (APPLY (CAR TODO) (CDR TODO)) else (APPLY (CAR TODO) (CADR TODO] else (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g. a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case") (EVAL TODO)) else (* ; "a normal apply case") (if (CDDR TODO) then (PRIN1 "... = ") (PRINT TODO) (APPLY (CAR TODO) (MAPCAR (CDR TODO) (FUNCTION EVAL))) else (APPLY (CAR TODO) (CADR TODO] (T (* ; "a normal eval case") (EVAL (CAR TODO] (T (* ; "Common Lisp EVAL") (* ;; "maybe should have used ECASE and checked for Common-Lisp explicitly, but could get recursive errors if *current-exec-type* was rebound") (COND [(CDR TODO) (* ; "this is the 'apply' case") (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)") (COND [(CL:MACRO-FUNCTION (CAR TODO)) (COND [(FMEMB (ARGTYPE (CAR TODO)) '(1 3)) (* ; "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).") (COND ((AND (EQ (ARGTYPE (CAR TODO)) 3) (CDDR TODO)) (APPLY (CAR TODO) (CDR TODO))) (T (COND ((CDDR TODO) (PRIN1 "... = ") (PRINT TODO) (APPLY (CAR TODO) (CDR TODO))) (T (APPLY (CAR TODO) (CADR TODO] (T (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g. a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case") (CL:EVAL TODO ENV] (T (* ; "a normal apply case") (COND [(CDDR TODO) (PRIN1 "... = ") (PRINT TODO) (CL:APPLY (CAR TODO) (CL:MAPCAR #'(CL:LAMBDA (A) (CL:EVAL A ENV)) (CDR TODO] (T (CL:APPLY (CAR TODO) (CADR TODO] (T (* ; "a normal eval case") (CL:EVAL (CAR TODO) ENV]) (EVENTS-INPUT [CL:LAMBDA (EVENTS) (* ; "Edited 26-Nov-86 11:16 by lmm") (* ; "takes a list of events and returns the input concatenated into a single event, as appropriate ") (IF (CDR EVENTS) THEN [CONS 'DO-EVENTS (FOR EVENT IN EVENTS COLLECT (IF (CDR (EXEC-EVENT-INPUT EVENT)) THEN (CONS 'EVENT (  EXEC-EVENT-INPUT EVENT)) ELSE (CAR (EXEC-EVENT-INPUT EVENT] ELSE (LET* ((INPUT (EXEC-EVENT-INPUT (CAR EVENTS))) (TAIL (FMEMB HISTSTR0 INPUT))) (IF TAIL THEN (LDIFF INPUT TAIL) ELSE INPUT]) (EXEC-PRIN1 (CL:LAMBDA (VALUE) (* ; "Edited 23-Feb-87 18:15 by raf") (WRITE VALUE :STREAM *TERMINAL-IO* :ESCAPE T))) (EXEC-VALUE-OF [LAMBDA (EVENT-SPEC) (* lmm "11-Sep-86 17:28") (CL:VALUES-LIST (LISTGET (EXEC-EVENT-PROPS (CAR (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY))) 'LISPXVALUES]) (GET-NEXT-HISTORY-EVENT [LAMBDA (HISTORY ID PROMPT FIRST-ONLY) (* ; "Edited 2-Mar-87 15:34 by raf") (for EVENT in (HISTORY-EVENTS HISTORY) do (CL:WHEN (EQ (CADR (LISTP (EXEC-EVENT-ID EVENT))) ID) (CL:IF (AND (NULL (EXEC-EVENT-INPUT EVENT)) (NULL (EXEC-EVENT-PROPS EVENT))) (PROGN (CL:SETF (CDDR (EXEC-EVENT-ID EVENT)) PROMPT) (RETURN EVENT)) (GO $$OUT))) (if FIRST-ONLY then (* ; "only do this for the first event") (GO $$OUT)) finally (COND (HISTORY (* ; "Watch out for NIL LISPXHISTORY") (SETQ EVENT (MAKE-EXEC-EVENT :ID (LIST* (CL:INCF (HISTORY-INDEX HISTORY)) ID PROMPT))) (CL:PUSH EVENT (HISTORY-EVENTS HISTORY)) (CL:SETF (CDR (CL:NTHCDR (CL:1- (HISTORY-SIZE HISTORY)) (HISTORY-EVENTS HISTORY))) NIL) (RETURN EVENT]) (HISTORY-ADD-TO-SPELLING-LISTS [LAMBDA (INPUT) (* lmm "31-Jul-86 02:22") (COND ((CDR INPUT) (* ; "Add to the spelling list if it has a definition") (AND (LITATOM (CAR INPUT)) (FGETD (CAR INPUT)) (ADDSPELL (CAR INPUT) 2))) ([AND (CL:CONSP (CAR INPUT)) (LITATOM (CAR (CAR INPUT] (* ; "looks like a valid function") (AND [OR (CL:FBOUNDP (CAR (CAR INPUT))) (CL:SPECIAL-FORM-P (CAR (CAR INPUT] (ADDSPELL (CAR (CAR INPUT)) 2))) ((AND (CL:SYMBOLP (CAR INPUT)) (BOUNDP (CAR INPUT))) (ADDSPELL (CAR INPUT) 3]) (HISTORY-NTH [LAMBDA (LST N ID) (* lmm " 6-Nov-86 01:40") (bind EVENT while LST do (if (<= N 0) then (RETURN)) (SETQ EVENT (CAR LST)) (CL:IF (AND (EXEC-EVENT-INPUT EVENT) (NEQ EVENT *CURRENT-EVENT*) (OR (NOT (STRINGP ID)) (EQ (CADR (LISTP (EXEC-EVENT-ID EVENT))) ID))) (if (<= (CL:DECF N) 0) then (RETURN LST))) (pop LST]) (PRINT-HISTORY [CL:LAMBDA (HISTORY EVENT-SPECS &OPTIONAL NOVALUES) (* lmm " 5-Nov-86 23:29") (PROG [HELPCLOCK (EVENTS (CL:IF EVENT-SPECS (FIND-HISTORY-EVENTS EVENT-SPECS HISTORY) (HISTORY-EVENTS HISTORY] (TERPRI T) (for X in EVENTS do (PRINT-EVENT X NOVALUES) (FRESHLINE T) (TERPRI T)) (TERPRI T) (RETURN (CL:VALUES]) (FIND-HISTORY-EVENTS [LAMBDA (EVENT-SPEC HISTORY) (* ; "Edited 6-Nov-87 15:22 by raf") (PROG [(*EVENTS* (HISTORY-EVENTS HISTORY)) (ORIGINAL-EVENT-SPEC EVENT-SPEC) SPEC TEM VALUE-P VAL PRED-P ALL-P (AND-SPEC (CL:MEMBER "AND" EVENT-SPEC :TEST 'STRING.EQUAL] (DECLARE (CL:SPECIAL *EVENTS*)) (* ; "Used by DO-HISTORY-SEARCH") [if AND-SPEC then (RETURN (APPEND (SETQ *EVENTS* (FIND-HISTORY-EVENTS (LDIFF EVENT-SPEC AND-SPEC) HISTORY)) (for X in (FIND-HISTORY-EVENTS (CDR AND-SPEC ) HISTORY) when (NOT (FMEMB X *EVENTS*)) collect X] LP (CL:WHEN (EQ (CAR *EVENTS*) *CURRENT-EVENT*) (SETQ *EVENTS* (CDR *EVENTS*))) [CASE-EQUALP (SETQ SPEC (CAR EVENT-SPEC)) (ALL (SETQ ALL-P T) (pop EVENT-SPEC) (GO LP)) (F [COND ((SETQ TEM (CDR EVENT-SPEC)) (* ; "Otherwise, F is not a special symbol, e.g. user types REDO F, meaning search for F itself.") (SETQ EVENT-SPEC (CDR EVENT-SPEC)) (SETQ SPEC (CAR EVENT-SPEC] (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P)) [FROM (LET ((EVENTS (FIND-HISTORY-EVENTS (CDR EVENT-SPEC) HISTORY))) (CL:WHEN (CDR EVENTS) (ERROR "from?")) (RETURN (REVERSE (LDIFF *EVENTS* (CDR (CL:MEMBER (CAR EVENTS) *EVENTS*] (SUCHTHAT (* ;; "What follows SUCHTHAT is a function to be applied to the entire event; and if true, approves that event.") (SETQ PRED-P T) (SETQ EVENT-SPEC (CDR EVENT-SPEC)) (SETQ SPEC (CAR EVENT-SPEC)) (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P)) (= (SETQ VALUE-P T) (GO LP)) (T (COND ((NOT (CL:INTEGERP SPEC)) (DO-HISTORY-SEARCH SPEC PRED-P VALUE-P) (* ; "Does searching.") ) [(< SPEC 0) (* ; "count backward") (SETQ *EVENTS* (HISTORY-NTH *EVENTS* (- SPEC) (AND (NOT ALL-P) *EXEC-ID*] (T (* ; "absolute event number") (SETQ *EVENTS* (SEARCH-FOR-EVENT-NUMBER *EVENTS* HISTORY SPEC] [COND ((NULL *EVENTS*) (COND (ALL-P (RETURN VAL))) (ERROR SPEC '" ?" T)) ((NULL (SETQ EVENT-SPEC (CDR EVENT-SPEC))) (COND [(NULL ALL-P) (RETURN (LIST (CAR *EVENTS*] (T (SETQ VAL (NCONC1 VAL (CAR *EVENTS*))) (SETQ EVENT-SPEC ORIGINAL-EVENT-SPEC] (SETQ *EVENTS* (CDR *EVENTS*)) (CL:WHEN (EQ (CAR *EVENTS*) *CURRENT-EVENT*) (SETQ *EVENTS* (CDR *EVENTS*))) (SETQ VALUE-P NIL) (SETQ PRED-P NIL) (GO LP]) (PRINT-EVENT [CL:LAMBDA (EVENT &OPTIONAL NOVALUES) (* ; "Edited 9-Mar-87 11:02 by raf") (PROG ((INPUT (EXEC-EVENT-INPUT EVENT)) (FILE (\GETSTREAM T 'OUTPUT)) (POSITION (STRINGWIDTH "99/9999>" T)) Y TEM EVENT#) (FRESHLINE FILE) (if (SETQ TEM (LISTGET (EXEC-EVENT-PROPS EVENT) '*HISTORY*)) then (DSPXPOSITION POSITION FILE) (CL:FORMAT FILE "~{~S ~}~&" TEM)) (PRINT-EVENT-PROMPT EVENT) (DSPXPOSITION (MAX POSITION (DSPXPOSITION NIL FILE)) T) (DSPFONT INPUTFONT FILE) LP [COND ((SETQ Y (FMEMB HISTSTR0 (LISTP INPUT))) (SETQ INPUT (LDIFF INPUT Y] [COND [(NLISTP INPUT) (COND ((NULL INPUT) (if (EXEC-EVENT-PROPS EVENT) then (* ; "don't do anything") else (PRIN1 "" FILE))) (T (* ; "shouldn't happen??") (EXEC-PRIN1 INPUT] [(CDDR INPUT) (* ; "a command, just print out all elements") (CASE (CAR INPUT) (DO-EVENTS (* ; " special generated combination event") (DSPFONT DEFAULTFONT FILE) (CL:FORMAT FILE "~A" (CAR INPUT)) (DSPFONT INPUTFONT FILE) (for X in (CDR INPUT) do (FRESHLINE FILE) (DSPXPOSITION POSITION FILE) (CL:FORMAT FILE " ~S" X))) (T (CL:FORMAT FILE "~{~S ~}~&" INPUT] [(CDR INPUT) (* ; "APPLY format") (EXEC-PRIN1 (CAR INPUT)) (COND ((NULL (SETQ TEM (CADR INPUT))) (PRIN1 ")" FILE)) (T (COND ((NLISTP TEM) (SPACES 1 FILE))) (EXEC-PRIN1 TEM] (T (* ; "EVAL input") (EXEC-PRIN1 (CAR INPUT] (COND (Y (SETQ INPUT (CDR Y)) (TERPRI FILE) (DSPXPOSITION POSITION FILE) (GO LP))) LP1 [LET [(RNT (CL:GETF (EXEC-EVENT-PROPS EVENT) '*LISPXPRINT*] (if RNT then (DSPFONT PRINTOUTFONT FILE) (FRESHLINE FILE) (MAPC RNT (FUNCTION (LAMBDA (X) (LISPXREPRINT X FILE] (COND ((NOT NOVALUES) (DSPFONT VALUEFONT FILE) (for X in (LISTGET (CDDDR EVENT) 'LISPXVALUES) do (FRESHLINE FILE) (DSPXPOSITION POSITION FILE) (EXEC-PRIN1 X]) (PRINT-EVENT-PROMPT [LAMBDA (EVENT) (* ; "Edited 2-Mar-87 16:47 by raf") (LET [(TERM (\GETSTREAM T 'OUTPUT] (* ; "Crock because format interprets T to mean primary output, not terminal") (FRESHLINE TERM) (if (CL:CONSP (EXEC-EVENT-ID EVENT)) then (DSPFONT PROMPTFONT TERM) (DESTRUCTURING-BIND (INDEX ID . PROMPT) (EXEC-EVENT-ID EVENT) (IF (CL:EQUAL ID "") THEN (CL:FORMAT TERM "~D~A" INDEX PROMPT) ELSE (CL:FORMAT TERM "~A/~D~A" ID INDEX PROMPT))) elseif LISPXHISTORY then (CL:FORMAT TERM "~D~A" (ENTRY# LISPXHISTORY EVENT) (EXEC-EVENT-ID EVENT)) else (* ; "No prompt availible, use the default.") (CL:FORMAT TERM "~A" XCL:*EXEC-PROMPT*]) (PROCESS-EXEC-ID (CL:LAMBDA (PROCESS &OPTIONAL ID) (* ; "Edited 5-Mar-87 17:29 by raf") (OR (PROCESSPROP PROCESS 'ID) (LET ((NAME (PROCESS.NAME PROCESS))) [PROCESSPROP PROCESS 'ID (OR ID (SETQ ID (COND ((STRPOS "EXEC" NAME 1 NIL T) (OR (SUBSTRING NAME 6 -1) "")) (T (* ; "under some other process") (STRING NAME] ID)))) (SEARCH-FOR-EVENT-NUMBER [LAMBDA (EVENTS HISTORY SPEC) (* lmm "11-Sep-86 10:53") (while EVENTS do (if [LET [(ID (EXEC-EVENT-ID (CAR EVENTS] (COND ((LISTP ID) (EQL (CAR ID) SPEC)) (T (EQL SPEC (ENTRY# HISTORY (CAR EVENTS] then (RETURN EVENTS) else (pop EVENTS]) (\PICK.EVALQT [LAMBDA NIL (* ; "Edited 27-Feb-87 17:40 by raf") (* ;;; "Replacement for \PROC.REPEATEDLYEVALQT. Activated by the HARDRESET at the end of LOADUP.LISP") (INPUT T) (OUTPUT T) (TTYDISPLAYSTREAM \TopLevelTtyWindow) (\RESETSYSTEMSTATE) (EXEC :TOP-LEVEL-P T :PROFILE XCL:*PROFILE* :WINDOW (XCL::SETUP-EXEC-WINDOW \TopLevelTtyWindow]) (LISPXREPRINT [LAMBDA (X FILE) (* ; "Edited 19-Jan-87 16:03 by bvm:") (* ; "takes an element from a *LISPXPRINT* property and prints it properly.") [OR FILE (SETQ FILE (\GETSTREAM T 'OUTPUT] (COND ((STRINGP X) (PRIN1 X FILE)) ((NLISTP X) (PRIN2 X FILE)) ((CL:STRINGP (CAR X)) (CL:APPLY (FUNCTION CL:FORMAT) FILE X)) (T (SELECTQ (CAR X) ((PRINT PRIN1 PRIN2 SPACES) (APPLY* (CAR X) (CADR X) FILE (CADDDR X))) (TAB (TAB (CADR X) (CADDR X) FILE)) (TERPRI (TERPRI FILE)) (LISPXPRINTDEF0 [APPLY (CAR X) (CONS (CADR X) (CONS FILE (CDDDR X]) (APPLY (CAR X) (CONS (CADR X) (CONS FILE (CDDDR X]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? 'READ 'TTYINREAD) (MOVD '\PICK.EVALQT '\PROC.REPEATEDLYEVALQT) (SETQ BackgroundMenu) ) (DEFMACRO CASE-EQUALP (SELECTOR &REST CASES) [LET* [(KV (CL:IF (CL:SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (for STRING-CASE in CASES collect (COND [(FMEMB (CAR STRING-CASE) '(T CL:OTHERWISE)) `(T ,@(CDR STRING-CASE] [(NOT (CL:CONSP (CAR STRING-CASE))) `([STRING.EQUAL ,KV ',(CAR STRING-CASE] ,@(CDR STRING-CASE] (T `([OR ,@(CL:DO ((X (CAR STRING-CASE) (CDR X)) (Y NIL)) ((CL:ATOM X) (REVERSE Y)) (CL:PUSH `[STRING.EQUAL ,KV ',(CAR X] Y))] ,@(CDR STRING-CASE] (CL:IF (EQ KV SELECTOR) `(COND ,@CLAUSES) `(LET ((,KV ,SELECTOR)) (COND ,@CLAUSES)))]) (DEFMACRO EXEC-EVENT-PROPS (X) `(CDDDR ,X)) (CL:DEFUN EXEC-PRINT (VALUE) (FRESHLINE T) (WRITE VALUE :STREAM *TERMINAL-IO* :ESCAPE T)) (CL:DEFUN EXEC-FORMAT (FORMAT-STRING &REST ARGS) (AND (CL:STRINGP FORMAT-STRING) (LISPXPUT '*LISPXPRINT* (LIST (CONS FORMAT-STRING ARGS)) T *CURRENT-EVENT*)) (CL:APPLY 'CL:FORMAT (\GETSTREAM T 'OUTPUT) FORMAT-STRING ARGS)) (ADDTOVAR BackgroundMenuCommands [EXEC '(ADD-EXEC :TTY T) "Start a new Exec" (SUBITEMS ("Xerox Common Lisp" '(ADD-EXEC :PROFILE "XCL" :TTY T)) ("Common Lisp" '(ADD-EXEC :PROFILE "LISP" :TTY T)) ("Interlisp" '(ADD-EXEC :PROFILE "INTERLISP" :TTY T) "Start an Interlisp Exec" (SUBITEMS ("Old-Interlisp" '(ADD-EXEC :PROFILE "OLD-INTERLISP-T" :EXEC 'EVALQT :TTY T) "Start an old-style LISPX window"]) (ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100) (GREETHIST)) (* ;; "Exec Commands") (DEF-DEFINE-TYPE COMMANDS "Exec Commands") (DEFDEFINER (DEFCOMMAND [:NAME (CL:LAMBDA (WHOLE) (LET ((NAME (CL:SECOND WHOLE))) (CL:IF (CL:CONSP NAME) (CAR NAME) NAME)]) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV &BODY BODY) [LET ((COMMAND-LEVEL '*EXEC-COMMAND-TABLE*) (COMMAND-TYPE :EVAL) (PREFIX "exec-")) [if (LISTP NAME) then (SETQ NAME (PROG1 (CAR NAME) [for X in (CDR NAME) do (CL:ECASE X ((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ COMMAND-TYPE X)) ((:DEBUGGER :BREAK) (SETQ COMMAND-LEVEL '*DEBUGGER-COMMAND-TABLE*) (SETQ PREFIX "break-")))])] (LET* ((CMACRONAME (PACK* PREFIX NAME)) (STRINGNAME (STRING NAME))) (CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (PARSE-DEFMACRO ARGUMENTS '$$MACRO-FORM BODY NAME ENV :ENVIRONMENT '$$MACRO-ENV) `(PROGN [CL:SETF (CL:SYMBOL-FUNCTION ',CMACRONAME) (FUNCTION (CL:LAMBDA ($$MACRO-FORM $$MACRO-ENV) ,@PARSED-DECLARATIONS ,PARSED-BODY] (CL:SETF (CL:DOCUMENTATION ,STRINGNAME 'COMMANDS) ,PARSED-DOCSTRING) (PUTHASH ,STRINGNAME ',(MAKE-COMMAND-ENTRY :FUNCTION CMACRONAME :MODE COMMAND-TYPE :ARGUMENTS ( \SIMPLIFY.CL.ARGLIST ARGUMENTS)) ,COMMAND-LEVEL]) (DEFCOMMAND ("?" :QUIET) (&OPTIONAL (NAME NIL NAMEP)) "Show forms of valid input. ? shows name's documentation." (CL:IF NAMEP (PRINT-ALL-DOCUMENTATION NAME) [PROGN (CL:FORMAT T "~&You are typing at the Exec. Enter~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto evaluate an expression~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "function(arg1 arg2 ...)") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:") (FOR X ON (REVERSE *THIS-EXEC-COMMANDS*) DO (LET (COMS) [MAPHASH (CAR X) #'(CL:LAMBDA (VAL KEY) (AND [NOT (SOME (CDR X) #'(CL:LAMBDA (TAB) (GETHASH KEY TAB] (PUSH COMS (LIST KEY VAL] (CL:MAPC #'[CL:LAMBDA (COM) (CL:FORMAT T "~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "~A " (CAR COM)) (DSPFONT COMMENTFONT T) (PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM))) (DSPFONT DEFAULTFONT T) (LET [(DOC (CL:DOCUMENTATION (CAR COM) 'COMMANDS] (CL:WHEN DOC (TAB 20 1 T) (CL:FORMAT T "~A" DOC))] (CL:SORT COMS #'CL:STRING< :KEY #'CAR]) (CL:VALUES)) (DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)" (IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS) ':INPUT)) THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS) T) ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS)) (CL:VALUES)) (DEFCOMMAND ("CONN" :EVAL) (&OPTIONAL DIRECTORY) "Change default pathname to DIRECTORY" (/CNDIR DIRECTORY)) (DEFCOMMAND "DA" NIL "Returns current time & date" (DATE)) (DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME" [DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD) (IF (CL:SYMBOLP CL:KEYWORD) THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD) "INTERLISP") ELSE CL:KEYWORD]) (DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV) "Execute the multiple events in INPUTS, using the environment ENV for all evaluations." [LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*))) (* ;  "DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.") ) (CL:WHEN OUTER-EVENT (CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT) (CONS 'DO-EVENTS INPUTS)) (* ;  "Each of these is fixed up below.") ) (ERSETQ (CL:MAPL #'[CL:LAMBDA (INPUT) (LET ([TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT))) 'EVENT) (CDR (CAR INPUT)) (LIST (CAR INPUT)))] VALUES) (CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ VALUES (DO-EVENT TODO ENV)) (* ;  "If it exists, *CURRENT-EVENT* gets smashed here.") (CL:WHEN OUTER-EVENT (* ; "If there is an outer event...") (* ;;  "Fix the outer event's list of inputs with the expanded input.") (RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*))) (CL:WHEN VALUES (* ;  "If the last sub-event generated some values...") (* ;;  "Add the new values to the outer event's values.") [LET [(OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS OUTER-EVENT) 'LISPXVALUES] (CL:IF OLD-VALUES (NCONC OLD-VALUES VALUES) (CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT) (LIST* 'LISPXVALUES VALUES (EXEC-EVENT-PROPS OUTER-EVENT))))]))] INPUTS)) (CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...") (* ;  "Smash saved values back from OUTER-EVENT.") (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (EXEC-EVENT-INPUT OUTER-EVENT)) (CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*) (EXEC-EVENT-ID OUTER-EVENT)) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (EXEC-EVENT-VALUE OUTER-EVENT)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (EXEC-EVENT-PROPS OUTER-EVENT)))] (SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return. This is alright since *CURRENT-EVENT* is already pointed to by the history list.") (CL:VALUES) (* ;  "We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL.") ) (DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events" [APPLY 'FIX-FORM (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1)) LISPXHISTORY]) (DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)." (FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1)) LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&")) (CL:VALUES)) (DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC) "NAME command-name [argument-list] [event-spec] defines new command containing the event." (CL:UNLESS (LISTP ARGUMENT-LIST) (CL:PUSH ARGUMENT-LIST EVENT-SPEC) (SETQ ARGUMENT-LIST NIL)) [LET [(EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY)) (ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* 'ARG I] (CL:EVAL `(DEFCOMMAND (,COMMAND-NAME :HISTORY) ,ARGNAMES [SUBPAIR ',ARGNAMES (LIST ,@ARGNAMES) ',(SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS) T])]) (DEFCOMMAND ("NDIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME in abbreviated format" (DODIR (CONS PATHNAME KEYWORDS) '(P COLUMNS 20) '* "")) (DEFCOMMAND "PL" (CL:SYMBOL) "Show property list of SYMBOL" (PRINTPROPS CL:SYMBOL) (CL:VALUES)) (DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)" (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1)) LISPXHISTORY))) (DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC) "Tell Manager to remember type-in from specified event(s)" (MARKASCHANGED (GETEXPRESSIONFROMEVENTSPEC EVENT-SPEC) 'EXPRESSIONS)) (DEFCOMMAND ("SHH" :QUIET) (&REST LINE) "Execute LINE without history processing" (EVAL-INPUT LINE)) (DEFCOMMAND "UNDO" (&REST EVENT-SPEC) "Undo side effects associated with the specified event (or last undoable one)" [FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1)) LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT))) (RESULT (UNDOLISPX2 EVENT))) (CL:IF (LISTP INPUT) (SETQ INPUT (CAR INPUT))) (COND ((NULL RESULT) (CL:FORMAT T "No undo info saved for ~A.~&" INPUT)) ((EQ RESULT 'already) (CL:FORMAT T "~A already undone.~&" INPUT)) (T (CL:FORMAT T "~A undone.~&" INPUT] (CL:VALUES)) (DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE [FOR ] [IN ]" (* ;; "this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible") [PROG (EVENT-SPECS EXPR ARGS VARS (STATE 'VARS) LST TEM USE-ARGS GENLST) LP [COND ([OR (NULL LST) (NULL (CDR LINE)) (NULL (CASE-EQUALP (CAR LINE) (* ;  "look for one of the special keywords") (FOR (COND ((EQ STATE 'VARS) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE 'ARGS) (SETQ LST NIL) T))) (AND (COND ((EQ STATE 'EXPR) NIL) (T [COND ((EQ STATE 'ARGS) (SETQ ARGS (NCONC1 ARGS LST))) ((EQ STATE 'VARS)(* ;  "E.g. user types USE A AND B following previous USE command.") (SETQ VARS (NCONC1 VARS LST] (SETQ STATE 'VARS) (SETQ LST NIL) T))) (IN (COND ((AND (EQ STATE 'VARS) (NULL ARGS)) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE 'EXPR) (SETQ LST NIL) T) ((EQ STATE 'ARGS) (SETQ ARGS (NCONC1 ARGS LST)) (SETQ STATE 'EXPR) (SETQ LST NIL) T] (SETQ LST (NCONC1 LST (COND (NIL (MEMBER (CAR LINE) TEM) (* ;;  "This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A") (LET ((TEMP (CONCAT "temp string"))) (CL:PUSH (CONS (CAR LINE) TEMP) GENLST) TEMP)) (T (CAR LINE] (COND ((SETQ LINE (CDR LINE)) (GO LP))) (CL:ECASE STATE (VARS (SETQ VARS (NCONC1 VARS LST))) (ARGS (SETQ ARGS (NCONC1 ARGS LST))) (EXPR (SETQ EXPR LST))) (CL:WHEN (NULL EXPR) (CL:IF ARGS (SETQ EXPR (LIST 'F (CAAR ARGS))) (SETQ EXPR '(-1)))) (* ;; "EXPR specifies expressions to be substituted into, e.g. USE FOO FOR FIE IN FUM or USE FOO FOR FIE. In the latter case, searches for FIE. The F is added to avoid confusion with event numbers, etc.") (* ;; "") (SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY) (FUNCTION EXEC-EVENT-INPUT))) (* ;  "EXPR is now a list of event inputs") (* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ") (* ;; "USE A B FOR C AND D E FOR F would have ") (* ;; "((A B) (D E)) for VARS and") (* ;; "((C) (F)) for ARGS.") (IF (NULL ARGS) THEN [SETQ EXPR (FOR X IN EXPR JOIN (FOR VAR IN VARS COLLECT (IF (CL:CONSP (CAR X)) THEN (CONS (CONS (CAR VAR) (CDAR X)) (CDR X)) ELSE (CONS (CAR VAR) (CDR X] ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS) (POP ARGS) EXPR)) FINALLY (COND (VARS (ERROR '"use what??" "" T))) [MAPC GENLST (FUNCTION (LAMBDA (X) (LISPXSUBST (CAR X) (CDR X) EXPR T] (* ;; "samples:") (* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y") (* ;; " Equivalent to USE A C FOR X AND B D FOR Y") (* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:") (* ;; " A for D and X for W in the first") (* ;; " B for D and Y for W in the second") (* ;; " C for D and Z for W in the third") (* ;; "USE A B C FOR D AND X FOR Y means 3 operations:") (* ;; " A for D and X for Y in first") (* ;; " B for D and X for Y in second, etc.") (* ;; "USE A B C FOR D AND X Y FOR Z causes error") (* ;; "") (* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.") (* ;; "") (* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply.") )) (RETURN (COND [(CDR EXPR) (CONS 'DO-EVENTS (for X in EXPR collect (COND ((CDR X) (CONS 'EVENT X)) (T (CAR X] (T (CAR EXPR]) (DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD) &REST TYPES) "Show TYPES (or any) definition for NAME" (CL:BLOCK NIL (* ;; "returned from if no definitions found") (for TYPE in [OR TYPES [TYPESOF NAME NIL NIL '? (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE 'EDITDEF) 'NILL] (TYPESOF [SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL [FUNCTION (LAMBDA (WORD) (TYPESOF WORD NIL '(FIELDS FILES) 'CURRENT] NIL NIL NIL 'MUSTAPPROVE) (PROGN (CL:FORMAT *TERMINAL-IO* "No definitions found for ~S." NAME) (RETURN NIL] NIL NIL '? (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE 'EDITDEF) 'NILL] do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE))) (CL:VALUES)) (* ;; "Arrange to use the correct compiler") (PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DIR) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (33304 34258 (COPY-CIRCLE 33314 . 34256)) (34336 37641 (EXEC-READ 34346 . 37507) (DIR 37509 . 37639)) (39903 67037 (DO-APPLY-EVENT 39913 . 40475) (DO-HISTORY-SEARCH 40477 . 41934) ( EVAL-INPUT 41936 . 47365) (EVENTS-INPUT 47367 . 48745) (EXEC-PRIN1 48747 . 48923) (EXEC-VALUE-OF 48925 . 49264) (GET-NEXT-HISTORY-EVENT 49266 . 50761) (HISTORY-ADD-TO-SPELLING-LISTS 50763 . 51751) ( HISTORY-NTH 51753 . 52503) (PRINT-HISTORY 52505 . 53126) (FIND-HISTORY-EVENTS 53128 . 58189) ( PRINT-EVENT 58191 . 62412) (PRINT-EVENT-PROMPT 62414 . 63618) (PROCESS-EXEC-ID 63620 . 64565) ( SEARCH-FOR-EVENT-NUMBER 64567 . 65195) (\PICK.EVALQT 65197 . 65708) (LISPXREPRINT 65710 . 67035))))) STOP \ No newline at end of file diff --git a/sources/CMLFILESYS b/sources/CMLFILESYS new file mode 100644 index 00000000..364132a2 --- /dev/null +++ b/sources/CMLFILESYS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated " 8-Jun-90 16:41:26" |{PELE:MV:ENVOS}SOURCES>CMLFILESYS.;4| 4326 |changes| |to:| (functions cl:directory cl:user-homedir-pathname) |previous| |date:| " 4-Jun-90 14:56:58" |{PELE:MV:ENVOS}SOURCES>CMLFILESYS.;3|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (prettycomprint cmlfilesyscoms) (rpaqq cmlfilesyscoms ((functions cl:directory cl:file-author cl:file-length cl:file-position cl:user-homedir-pathname cl:file-write-date) (functions cl:probe-file cl:rename-file cl:delete-file) (prop filetype cmlfilesys))) (cl:defun cl:directory (pathname) (let (generator file) (declare (cl:special generator)) (resetlst (|if| (eql \\machinetype \\maiko) |then| (resetsave nil (quote (and resetstate (\\ufs.abort.cl-directory))))) (cl:setq generator (\\generatefiles (directory.fill.pattern (cl:namestring pathname)) nil (quote (sort resetlst)))) (|while| (setq file (\\generatenextfile generator)) |collect| (pathname file))))) (cl:defun cl:file-author (cl::file) (* |;;;| "Returns author of file as string, or NIL if it cannot be determined. FILE is a filename or stream.") (let ((cl::author (getfileinfo cl::file (quote author)))) (cl:if cl::author (coerce cl::author (quote cl:simple-string)) nil))) (cl:defun cl:file-length (file-stream) (|if| (and (streamp file-stream) (openp file-stream)) |then| (geteofptr file-stream))) (cl:defun cl:file-position (cl::file-stream &optional (cl:position nil cl::positionp)) (cl:unless (streamp cl::file-stream) (\\illegal.arg cl::file-stream)) (cl:if cl::positionp (cl:if (randaccessp cl::file-stream) (progn (setfileptr cl::file-stream (case cl:position (:start 0) (:end (geteofptr cl::file-stream)) (t cl:position))) t) nil) (getfileptr cl::file-stream))) (cl:defun cl:user-homedir-pathname (&optional host) (declare (globalvars loginhost/dir *default-pathname-defaults*)) (cl:if (machinetype (quote maiko)) (cl:if (and host (cl:string-not-equal (string host) (unix-getparm "HOSTNAME"))) nil (cl:make-pathname :host :dsk :directory (unpackfilename.string (unix-getenv "HOME") (quote directory) (quote return)))) (pathname (or loginhost/dir *default-pathname-defaults*)))) (cl:defun cl:file-write-date (file) (* |;;| "Return file's creation date, or NIL if it doesn't exist.") (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time") (let ((tn (cl:probe-file file))) (cl:when tn (%convert-internal-time-to-clut (getfileinfo tn (quote icreationdate)))))) (cl:defun cl:probe-file (file) (* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise. Returns NIL for non-file args.") (if (streamp file) then (if (openp file) then (pathname (fetch (stream fullname) of file)) else (let ((namestring-if-exists (infilep (fetch (stream fullname) of file)))) (and namestring-if-exists (pathname namestring-if-exists)))) else (let ((infilep (\\getfilename file (quote old)))) (if infilep then (pathname infilep) else nil)))) (cl:defun cl:rename-file (file new-name) (* |;;;| "Give FILE the new name NEW-NAME. If FILE is an open stream, error. Otherwise, do the rename. If successful, return three values: the new name, truename of original file, truename of new file.") (let ((old-pathname (pathname file)) (cl::new-fullname)) (if (streamp file) then (if (openp file) then (cl:error "Renaming open streams is not supported: ~S" file) else (setq cl::new-fullname (renamefile (setq file (fetch (stream fullname) of file)) new-name))) else (setq cl::new-fullname (renamefile file new-name))) (if cl::new-fullname then (cl:values (cl:merge-pathnames new-name file) old-pathname (pathname cl::new-fullname)) else (cl:error "Rename failed")))) (cl:defun cl:delete-file (file) (* * "Delete the specified file.") (let ((tn (cl:probe-file file))) (cl:when (streamp file) (cl:close file :abort t)) (cl:if tn (let ((ns (interlisp-namestring tn))) (cl:unless (delfile ns) (cl:error "Could not delete the file ~S" file))) (cl:unless (streamp file) (cl:error "File to be deleted does not exist: ~S" file)))) t) (putprops cmlfilesys filetype cl:compile-file) (putprops cmlfilesys copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (declare\: dontcopy (filemap (nil))) stop \ No newline at end of file diff --git a/sources/CMLFLOAT b/sources/CMLFLOAT new file mode 100644 index 00000000..6c435ebc --- /dev/null +++ b/sources/CMLFLOAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 13:16:23" IL:|{DSK}local>lde>lispcore>sources>CMLFLOAT.;2| 59358 IL:|changes| IL:|to:| (IL:VARS IL:CMLFLOATCOMS) IL:|previous| IL:|date:| " 7-Feb-88 15:16:05" IL:|{DSK}local>lde>lispcore>sources>CMLFLOAT.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLFLOATCOMS) (IL:RPAQQ IL:CMLFLOATCOMS ( (IL:* IL:|;;;| "CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions. Section 12.10, implementation parameters. ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:* IL:\;  "To generate unboxed opcodes") (IL:FILES IL:UNBOXEDOPS) (IL:* IL:\;  "To get constants from llfloat ") (IL:FILES (IL:LOADCOMP) IL:LLFLOAT)) (IL:COMS (IL:* IL:|;;| "Section 12.10, implementation parameters. ") (IL:* IL:|;;| "%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects. ") (IL:FUNCTIONS %FLOAT) (IL:VARIABLES MOST-POSITIVE-FIXNUM MOST-NEGATIVE-FIXNUM) (IL:VARIABLES MOST-POSITIVE-SINGLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (IL:VARIABLES MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT LEAST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-DOUBLE-FLOAT MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT LEAST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT) (IL:* IL:|;;| "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-EPSILON) (IL:VARIABLES SHORT-FLOAT-EPSILON DOUBLE-FLOAT-EPSILON LONG-FLOAT-EPSILON) (IL:* IL:|;;| "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES SHORT-FLOAT-NEGATIVE-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON LONG-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES PI)) (IL:COMS (IL:* IL:|;;| "Internal constants") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %E %2PI %PI %2PI/3 %PI/2 %-PI/2 %PI/3 %PI/4 %-PI/4 %PI/6 %2/PI ))) (IL:COMS (IL:* IL:|;;| "Utility macros") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %FLOAT-UNBOX %GET-TABLE-ENTRY %POLYEVAL %UFTRUNCATE %UMAKE-FLOAT))) (IL:* IL:|;;| " Unpack floating point functions") (IL:COMS (IL:FUNCTIONS DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT)) (IL:COMS (IL:* IL:|;;| "Exp (e to the power x)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG-BASE2-E)) (IL:VARIABLES %EXP-POLY %EXP-TABLE)) (IL:FUNCTIONS %EXP-FLOAT) (IL:FUNCTIONS EXP)) (IL:COMS (IL:* IL:|;;| "Expt (x to the power y)") (IL:FUNCTIONS %EXPT-INTEGER %EXPT-FLOAT-INTEGER) (IL:FUNCTIONS EXPT)) (IL:COMS (IL:* IL:|;;| "Log (log base e)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG2 %SQRT2)) (IL:VARIABLES %LOG-PPOLY %LOG-QPOLY)) (IL:FUNCTIONS %LOG-FLOAT) (IL:FUNCTIONS LOG)) (IL:COMS (IL:* IL:|;;| "Sqrt") (IL:FUNCTIONS %SQRT-FLOAT %SQRT-COMPLEX) (IL:FUNCTIONS SQRT)) (IL:COMS (IL:* IL:|;;| "Sin and Cos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SIN-EPSILON)) (IL:VARIABLES %SIN-PPOLY %SIN-QPOLY)) (IL:FUNCTIONS %SIN-FLOAT) (IL:FUNCTIONS SIN COS)) (IL:COMS (IL:* IL:|;;| "Tan") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %TAN-EPSILON)) (IL:VARIABLES %TAN-PPOLY %TAN-QPOLY)) (IL:FUNCTIONS %TAN-FLOAT) (IL:FUNCTIONS TAN)) (IL:COMS (IL:* IL:|;;| "Asin and Acos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %ASIN-EPSILON)) (IL:VARIABLES %ASIN-PPOLY %ASIN-QPOLY)) (IL:FUNCTIONS %ASIN-FLOAT) (IL:FUNCTIONS ASIN ACOS)) (IL:COMS (IL:* IL:|;;| "Atan ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SQRT3 %2-SQRT3 %INV-2-SQRT3)) (IL:FUNCTIONS %ATAN-FLOAT) (IL:FUNCTIONS ATAN)) (IL:COMS (IL:* IL:|;;| "Cis (exp (i x))") (IL:FUNCTIONS CIS)) (IL:COMS (IL:* IL:|;;| "Sinh, Cosh Tanh") (IL:FUNCTIONS SINH COSH TANH)) (IL:COMS (IL:* IL:|;;| "Asinh Acosh Atanh") (IL:FUNCTIONS ASINH ACOSH ATANH)) (IL:COMS (IL:* IL:|;;| "rational and rationalize ") (IL:FUNCTIONS %RATIONAL-FLOAT %RATIONALIZE-FLOAT)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLFLOAT))) (IL:* IL:|;;;| "CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions. Section 12.10, implementation parameters. " ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:UNBOXEDOPS) (IL:FILESLOAD (IL:LOADCOMP) IL:LLFLOAT) ) (IL:* IL:|;;| "Section 12.10, implementation parameters. ") (IL:* IL:|;;| "%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects. " ) (DEFUN %FLOAT (HIWORD LOWORD) (IL:\\FLOATBOX (IL:\\VAG2 HIWORD LOWORD))) (DEFCONSTANT MOST-POSITIVE-FIXNUM 65535) (DEFCONSTANT MOST-NEGATIVE-FIXNUM -65536) (DEFCONSTANT MOST-POSITIVE-SINGLE-FLOAT (%FLOAT 32639 65535)) (DEFCONSTANT LEAST-POSITIVE-SINGLE-FLOAT (%FLOAT 0 1)) (DEFCONSTANT LEAST-NEGATIVE-SINGLE-FLOAT (%FLOAT 32768 1)) (DEFCONSTANT MOST-NEGATIVE-SINGLE-FLOAT (%FLOAT 65407 65535)) (DEFCONSTANT MOST-POSITIVE-SHORT-FLOAT MOST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-NEGATIVE-SHORT-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT) (DEFCONSTANT MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (DEFCONSTANT MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-NEGATIVE-DOUBLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT) (DEFCONSTANT MOST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (DEFCONSTANT MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SINGLE-FLOAT) (DEFCONSTANT LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT) (DEFCONSTANT MOST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (IL:* IL:|;;| "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) " ) (DEFCONSTANT SINGLE-FLOAT-EPSILON (%FLOAT (ASH 103 7) 1)) (DEFCONSTANT SHORT-FLOAT-EPSILON SINGLE-FLOAT-EPSILON) (DEFCONSTANT DOUBLE-FLOAT-EPSILON SINGLE-FLOAT-EPSILON) (DEFCONSTANT LONG-FLOAT-EPSILON SINGLE-FLOAT-EPSILON) (IL:* IL:|;;| "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) " ) (DEFCONSTANT SINGLE-FLOAT-NEGATIVE-EPSILON (%FLOAT 13184 0)) (DEFCONSTANT SHORT-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON) (DEFCONSTANT DOUBLE-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON) (DEFCONSTANT LONG-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON) (DEFCONSTANT PI (%FLOAT 16457 4059)) (IL:* IL:|;;| "Internal constants") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %E (%FLOAT 16429 63572)) (DEFCONSTANT %2PI (%FLOAT 16585 4059)) (DEFCONSTANT %PI (%FLOAT 16457 4059)) (DEFCONSTANT %2PI/3 (%FLOAT 16390 2706)) (DEFCONSTANT %PI/2 (%FLOAT 16329 4059)) (DEFCONSTANT %-PI/2 (%FLOAT 49097 4059)) (DEFCONSTANT %PI/3 (%FLOAT 16262 2706)) (DEFCONSTANT %PI/4 (%FLOAT 16201 4059)) (DEFCONSTANT %-PI/4 (%FLOAT 48969 4059)) (DEFCONSTANT %PI/6 (%FLOAT 16134 2706)) (DEFCONSTANT %2/PI (%FLOAT 16162 63875)) ) (IL:* IL:|;;| "Utility macros") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %FLOAT-UNBOX (FLOAT SIGN EXP HI LO &OPTIONAL DONTSHIFT) (IL:* IL:|;;| "If dontshift is T -- the floatp fields are simply unpacked (with the hiddenbit restored -- and exp set to 1 for denormalized numbers). If dontshift is NIL -- exp, hi and lo are fiddled so the high bit of hi is on.") `(LET ((FLONUM (FLOAT ,FLOAT))) (SETQ ,SIGN (IL:|fetch| (IL:FLOATP IL:SIGNBIT) IL:|of| FLONUM)) (SETQ ,EXP (IL:|fetch| (IL:FLOATP IL:EXPONENT) IL:|of| FLONUM)) (SETQ ,HI (IL:|fetch| (IL:FLOATP IL:HIFRACTION) IL:|of| FLONUM)) (SETQ ,LO (IL:|fetch| (IL:FLOATP IL:LOFRACTION) IL:|of| FLONUM)) (IF (EQ ,EXP IL:\\MAX.EXPONENT) (IL:* IL:\;  "might want to check for NaN's here if EXP = \\MAX.EXPONENT") (ERROR "Not a number: ~s" FLONUM)) (IF (EQ 0 ,EXP) (WHEN (NOT (AND (EQ 0 ,HI) (EQ 0 ,LO))) (IL:* IL:\; "Denormalized number") (SETQ ,EXP 1) ,@(IF (NULL DONTSHIFT) `((LOOP (IF (NOT (EQ 0 (LOGAND ,HI IL:\\HIDDENBIT))) (RETURN NIL)) (IL:.LLSH1. ,HI ,LO) (SETQ ,EXP (1- ,EXP)))))) (IL:* IL:\; " Restore the hidden bit") (SETQ ,HI (+ ,HI IL:\\HIDDENBIT))) ,@(IF (NULL DONTSHIFT) `((IL:.LLSH8. ,HI ,LO))) NIL)) (DEFMACRO %GET-TABLE-ENTRY (ARRAY INDEX) `(IL:\\GETBASEFLOATP (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| ,ARRAY) (IL:LLSH ,INDEX 1))) (DEFMACRO %POLYEVAL (X COEFFS DEGREE) `(IL:\\FLOATBOX ((IL:OPCODES IL:UBFLOAT3 0) (IL:\\FLOATUNBOX ,X) (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| ,COEFFS) ,DEGREE))) (DEFMACRO %UFTRUNCATE (INT REM FLOAT &OPTIONAL DIVISOR) (IL:* IL:|;;| "As in truncate. Assumes FLOAT and DIVISOR are unboxed floatp's. ") (IF DIVISOR `(LET ((FFLOAT ,FLOAT) (FDIVISOR ,DIVISOR)) (DECLARE (TYPE FLOAT FFLOAT FDIVISOR)) (SETQ ,INT (IL:UFIX (IL:FQUOTIENT FFLOAT FDIVISOR))) (SETQ ,REM (- FFLOAT (* FDIVISOR (FLOAT ,INT)))) NIL) `(LET ((FFLOAT ,FLOAT)) (DECLARE (TYPE FLOAT FFLOAT)) (SETQ ,INT (IL:UFIX FFLOAT)) (SETQ ,REM (- FFLOAT (FLOAT ,INT))) NIL))) (DEFMACRO %UMAKE-FLOAT (SIGN EXP HI LOW) (IL:* IL:|;;| "as in \\makefloat -- but produces an unboxed number") `(IL:\\FLOATBOX ((IL:OPENLAMBDA (SIGN EXP HI LO) (IL:.LRSH8. HI LO) (SETQ HI (+ (ASH EXP 7) (LOGAND 127 HI))) (IF (EQ SIGN 1) (SETQ HI (LOGIOR IL:\\SIGNBIT HI))) (IL:\\VAG2 HI LO)) ,SIGN ,EXP ,HI ,LOW))) ) (IL:* IL:|;;| " Unpack floating point functions") (DEFUN DECODE-FLOAT (FLOAT) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0.0 0 1.0) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (VALUES (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO) (- EXP (1- IL:\\EXPONENT.BIAS)) (IF (EQ SIGN 0) 1.0 -1.0))))) (DEFUN SCALE-FLOAT (FLOAT INTEGER &OPTIONAL OLD-BOX) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) 0.0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (IL:\\MAKEFLOAT SIGN (+ EXP INTEGER) HI LO NIL OLD-BOX)))) (DEFUN FLOAT-RADIX (FLOAT) 2) (DEFUN FLOAT-SIGN (FLOAT1 &OPTIONAL FLOAT2 OLD-BOX) (IL:* IL:|;;| "Old-box is a floatp box to reuse (may be eq to float2)") (IF (FLOATP FLOAT1) (IF (NULL FLOAT2) (IF (MINUSP FLOAT1) -1.0 1.0) (IF (FLOATP FLOAT2) (IF (EQ (MINUSP FLOAT1) (MINUSP FLOAT2)) FLOAT2 (IF (FLOATP OLD-BOX) (LET ((NEW-SIGN-BIT (IF (EQ 0 (IL:FETCH (IL:FLOATP IL:SIGNBIT) IL:OF FLOAT2)) 1 0))) (IL:* IL:|;;| "Now smash the old-box") (IL:\\PUTBASEFLOATP OLD-BOX 0 FLOAT2) (IL:|replace| (IL:FLOATP IL:SIGNBIT) IL:|of| OLD-BOX IL:|with| NEW-SIGN-BIT ) OLD-BOX) (- FLOAT2))) (%NOT-FLOAT-ERROR FLOAT2))) (%NOT-FLOAT-ERROR FLOAT1))) (DEFUN FLOAT-DIGITS (FLOAT) (IF (FLOATP FLOAT) 24 (%NOT-FLOAT-ERROR FLOAT))) (DEFUN FLOAT-PRECISION (FLOAT) (IF (FLOATP FLOAT) (IF (= FLOAT 0.0) 0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (IF (< HI IL:\\HIDDENBIT) (IL:* IL:\; "Denormalized number") (IF (EQ HI 0) (INTEGER-LENGTH LO) (+ 16 (INTEGER-LENGTH HI))) (IL:* IL:\; "Normalized number") 24))) (%NOT-FLOAT-ERROR FLOAT))) (DEFUN INTEGER-DECODE-FLOAT (FLOAT) (IL:* IL:|;;| "As in decode-float -- but returns integers") (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0 0 1) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (VALUES (+ (ASH HI 16) LO) (- EXP (+ IL:\\EXPONENT.BIAS 23)) (IF (EQ SIGN 0) 1 -1))))) (IL:* IL:|;;| "Exp (e to the power x)") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %LOG-BASE2-E (%FLOAT 16312 43579)) ) (XCL:DEFGLOBALVAR %EXP-POLY (IL:* IL:|;;| "%EXP-POLY contains P and Q coefficients of Hart et al EXPB 1103 rational approximation to (EXPT 2 X) in interval (0 .125). ") (MAKE-ARRAY 6 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 15549 17659) (%FLOAT 16256 0) (%FLOAT 16801 38273) (%FLOAT 17257 7717) (%FLOAT 17597 11739) (%FLOAT 17800 30401)))) (XCL:DEFGLOBALVAR %EXP-TABLE (IL:* IL:|;;| " %EXP-TABLE contains values of powers (EXPT 2 (/ N 8)) . ") (MAKE-ARRAY 8 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 16267 38338) (%FLOAT 16280 14320) (%FLOAT 16293 65239) (%FLOAT 16309 1267) (%FLOAT 16325 26410) (%FLOAT 16343 17661) (%FLOAT 16362 49351)))) (DEFUN %EXP-FLOAT (X) (IL:* IL:|;;|  "(CL:EXP X) for float X calculated via EXPB 1103 rational approximation of Hart et al. ") (LET ((FX (FLOAT X)) R M N ANSWER RECIPFLG) (DECLARE (TYPE FLOAT FX R)) (IL:* IL:|;;| "First, arrange X to be in interval (0 infinity) via identity (CL:EXP (minus X)) = (/ 1.0 (CL:EXP X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ FX (IL:UFMINUS FX)) (SETQ RECIPFLG T)) (IL:* IL:|;;| "Next, the problem of (CL:EXP X) is converted into a problem (EXPT 2 Y) where Y = (* %LOG-BASE2-E X). ") (IL:* IL:|;;| "Then range reduction is accomplished via (EXPT 2 Y) = (* (EXPT 2 M) (EXPT 2 (/ N 8)) (EXPT 2 R)) where M and N are integers and R is a float in the interval (0.0 .125). ") (IL:* IL:|;;| "After M, N, R are determined, (EXPT 2 M) is effected by scaling, (EXPT 2 (/ N 8)) is found by table lookup, and (EXPT 2 R) is calculated by rational approximation EXPB 1103 of Hart et al. ") (%UFTRUNCATE M R (* %LOG-BASE2-E FX)) (%UFTRUNCATE N R R 0.125) (SETQ FX (IL:FTIMES (%GET-TABLE-ENTRY %EXP-TABLE N) (IL:FQUOTIENT (%POLYEVAL R %EXP-POLY 5) (%POLYEVAL (IL:UFMINUS R) %EXP-POLY 5)))) (COND (RECIPFLG (SETQ ANSWER (SETQ FX (IL:FQUOTIENT 1.0 FX))) (SCALE-FLOAT ANSWER (- M) ANSWER)) (T (SETQ ANSWER FX) (SCALE-FLOAT ANSWER M ANSWER))))) (DEFUN EXP (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((EXP (%EXP-FLOAT (COMPLEX-REALPART NUMBER))) (Y (COMPLEX-IMAGPART NUMBER))) (COMPLEX (* EXP (COS Y)) (* EXP (SIN Y))))) (NUMBER (%EXP-FLOAT NUMBER)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (IL:* IL:|;;| "Expt (x to the power y)") (DEFUN %EXPT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is an integer and POWER is an integer. ") (COND ((MINUSP POWER) (/ (%EXPT-INTEGER BASE (- POWER)))) ((EQ BASE 2) (ASH 1 POWER)) (T (IL:* IL:|;;| "Integer to positive integer power") (IL:* IL:\;  "Must check first for infinity cases") (COND ((EQ BASE IL:MIN.INTEGER) (IF (INTEGERP POWER) (COND ((< POWER 0) 0) ((EQ POWER 0) 1) ((EQ POWER IL:MAX.INTEGER) (ERROR "Can't raise negative infinity to infinite power.")) ((EVENP POWER) IL:MAX.INTEGER) (T (IL:* IL:\; "Odd integer POWER") IL:MIN.INTEGER)) (ERROR "Can't raise negative infinity to noninteger power." POWER))) ((EQ BASE IL:MAX.INTEGER) (IF (EQ POWER 0) 1 IL:MAX.INTEGER)) ((EQ POWER IL:MAX.INTEGER) (COND ((EQ BASE 0) 0) ((> BASE 0) IL:MAX.INTEGER) (T (ERROR "Can't expt negative number to infinite power.")))) (T (LET ((TOTAL 1)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* BASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ BASE (* BASE BASE))))))))) (DEFUN %EXPT-FLOAT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is a float and POWER is an integer. ") (COND ((MINUSP POWER) (IL:FQUOTIENT 1.0 (%EXPT-FLOAT-INTEGER BASE (- POWER)))) (T (IL:* IL:|;;| "float to positive integer power") (LET ((FBASE (FLOAT BASE)) (TOTAL 1.0)) (DECLARE (TYPE FLOAT FBASE TOTAL)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* FBASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ FBASE (* FBASE FBASE))))))) (DEFUN EXPT (BASE-NUMBER POWER-NUMBER) (IL:* IL:|;;| "This function calculates BASE-NUMBER raised to the nth power. It separates the cases by the type of POWER-NUMBER for efficiency reasons, as powers can be calculated more efficiently if POWER-NUMBER is a positive integer, Therefore, All integer values of POWER-NUMBER are calculated as positive integers, and inverted if negative. ") (TYPECASE POWER-NUMBER (INTEGER (IF (EQ POWER-NUMBER 0) (TYPECASE BASE-NUMBER (FLOAT 1.0) ((COMPLEX FLOAT) (COMPLEX 1.0 0.0)) (NUMBER 1) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))) (TYPECASE BASE-NUMBER (INTEGER (%EXPT-INTEGER BASE-NUMBER POWER-NUMBER)) (RATIO (%MAKE-RATIO (%EXPT-INTEGER (RATIO-NUMERATOR BASE-NUMBER) POWER-NUMBER) (%EXPT-INTEGER (RATIO-DENOMINATOR BASE-NUMBER) POWER-NUMBER))) (FLOAT (%EXPT-FLOAT-INTEGER BASE-NUMBER POWER-NUMBER)) (COMPLEX (* (%EXPT-FLOAT-INTEGER (%COMPLEX-ABS BASE-NUMBER) POWER-NUMBER) (CIS (* POWER-NUMBER (PHASE BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))))) (NUMBER (IF (= BASE-NUMBER 0) BASE-NUMBER (EXP (* POWER-NUMBER (LOG BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR POWER-NUMBER)))) (IL:* IL:|;;| "Log (log base e)") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %LOG2 (%FLOAT 16177 29208)) (DEFCONSTANT %SQRT2 (%FLOAT 16309 1267)) ) (XCL:DEFGLOBALVAR %LOG-PPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 16042 22803) (%FLOAT 49484 23590) (%FLOAT 17044 17982) (%FLOAT 49926 37153) (%FLOAT 17046 5367)))) (XCL:DEFGLOBALVAR %LOG-QPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49512 9103) (%FLOAT 16992 42274) (%FLOAT 49823 38048) (%FLOAT 16918 5367)))) (DEFUN %LOG-FLOAT (X) (IL:* IL:|;;| "(LOG X) for positive float X. ") (IF (<= (SETQ X (FLOAT X)) 0.0) (ERROR "Log of zero: ~s" X)) (IL:* IL:|;;| "Range reduce to an R in interval ((SQRT 0.5) (SQRT 2)) via identity (LOG X) = (+ (LOG R) (* %LOG-2 EXP)) for a suitable integer EXP. exp is found from the exponent field of the iee floating point number representation of x.") (LET (R EXP ANSWER) (DECLARE (TYPE FLOAT R)) (LET (SIGN HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (SETQ EXP (- EXP IL:\\EXPONENT.BIAS)) (SETQ R (%UMAKE-FLOAT SIGN IL:\\EXPONENT.BIAS HI LO)) NIL) (WHEN (IL:UFGREATERP R %SQRT2) (SETQ EXP (1+ EXP)) (SETQ R (IL:FQUOTIENT R 2.0))) (IL:* IL:|;;| "(LOG R) is calculated by rational approximation LOGE 2707 of Hart et al.") (LET* ((Z (IL:FQUOTIENT (1- R) (1+ R))) (Z2 (* Z Z))) (DECLARE (TYPE FLOAT Z Z2)) (SETQ ANSWER (SETQ R (+ (* Z (IL:FQUOTIENT (%POLYEVAL Z2 %LOG-PPOLY 4) (%POLYEVAL Z2 %LOG-QPOLY 4))) (* %LOG2 EXP))))) ANSWER)) (DEFUN LOG (NUMBER &OPTIONAL BASE) (IF BASE (IL:QUOTIENT (LOG NUMBER) (LOG BASE)) (TYPECASE NUMBER ((OR FLOAT RATIONAL) (IF (MINUSP NUMBER) (COMPLEX (%LOG-FLOAT (- NUMBER)) PI) (%LOG-FLOAT NUMBER))) (COMPLEX (COMPLEX (%LOG-FLOAT (%COMPLEX-ABS NUMBER)) (PHASE NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))) (IL:* IL:|;;| "Sqrt") (DEFUN %SQRT-FLOAT (X) (IL:* IL:|;;| "(SQRT X) for nonnegative float X") (SETQ X (FLOAT X)) (IF (<= X 0.0) 0.0 (LET ((FX X) V) (DECLARE (TYPE FLOAT FX V)) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (IL:* IL:|;;| "First guess") (SETQ V (%UMAKE-FLOAT 0 (+ (ASH EXP -1) (IL:CONSTANT (1+ (ASH IL:\\EXPONENT.BIAS -1)))) HI LO)) NIL) (IL:* IL:|;;| "Four step newton-raphson") (DOTIMES (I 4 V) (SETQ V (* 0.5 (+ V (IL:FQUOTIENT FX V)))))))) (DEFUN %SQRT-COMPLEX (Z) (IL:* IL:|;;| "(SQRT X) for complex X. ") (LET ((R (FLOAT (COMPLEX-REALPART Z))) (I (FLOAT (COMPLEX-IMAGPART Z))) (ABS (SQRT (ABS Z))) (PHASE (IL:FQUOTIENT (PHASE Z) 2.0)) C D E ANSWER) (DECLARE (TYPE FLOAT ABS R I)) (IL:* IL:|;;| "Newton's method.") (LET ((C (* ABS (COS PHASE))) (D (* ABS (SIN PHASE))) E) (DECLARE (TYPE FLOAT C D E)) (DOTIMES (K 4 (COMPLEX C D)) (SETQ E (+ (* C C) (* D D))) (SETQ C (* 0.5 (+ C (IL:FQUOTIENT (+ (* R C) (* I D)) E)))) (SETQ D (* 0.5 (+ D (IL:FQUOTIENT (- (* I C) (* R D)) E)))))))) (DEFUN SQRT (NUMBER) (IF (= NUMBER 0) 0.0 (TYPECASE NUMBER (COMPLEX (%SQRT-COMPLEX NUMBER)) (NUMBER (IF (MINUSP NUMBER) (IL:* IL:\;  "Negative real axis maps into positive imaginary axis.") (COMPLEX 0 (SQRT (- NUMBER))) (%SQRT-FLOAT NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))) (IL:* IL:|;;| "Sin and Cos") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %SIN-EPSILON (IL:* IL:|;;| "%SIN-EPSILON is sufficiently small that (SIN X) = X for X in interval (0 %SIN-EPSILON). It suffices to take %SIN-EPSILON a little bit smaller than (SQRT (* 6 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (SIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %SIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0)) ) (XCL:DEFGLOBALVAR %SIN-PPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)). The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0)))") (MAKE-ARRAY 6 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 45236 25611) (%FLOAT 13589 26148) (%FLOAT 47286 34797) (%FLOAT 15295 3306) (%FLOAT 48666 34805) (%FLOAT 16256 0)))) (XCL:DEFGLOBALVAR %SIN-QPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)). The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0))) *") (MAKE-ARRAY 6 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 11384 52865) (%FLOAT 12553 9550) (%FLOAT 13604 38385) (%FLOAT 14593 18841) (%FLOAT 15489 5549) (%FLOAT 16256 0)))) (DEFUN %SIN-FLOAT (X COS-FLG) (IL:* IL:|;;| "SIN of a FLOAT X calculated via SIN 3374 rational approximation of Hart et al. ") (LET ((THETA (FLOAT X)) (SIGN 1.0) SIGN) (DECLARE (TYPE FLOAT THETA SIGN)) (IL:* IL:|;;| "If this function is called by COS then use (COS X) = (SIN (-- %PI/2 X)) = (SIN (+ %PI/2 X)). Case out on sign of X for improved numerical stability. Avoids unnecessary rounding and promotes symmetric properties. (COS X) = (COS (-- X)) is guaranteed by this strategy.") (IF COS-FLG (IF (IL:UFGREATERP THETA 0.0) (SETQ THETA (- %PI/2 THETA)) (SETQ THETA (+ %PI/2 THETA)))) (IL:* IL:|;;| "First range reduce to (0 infinity) by (SIN (minus X)) = (minus (SIN X)) This strategy guarantees (SIN (minus X)) = (minus (SIN X))") (WHEN (IL:UFLESSP THETA 0.0) (SETQ SIGN -1.0) (SETQ THETA (IL:UFMINUS THETA))) (IL:* IL:|;;| "Next range reduce to interval (0 %2PI) by (SIN X) = (SIN (MOD X %2PI)) ") (IF (IL:UFGEQ THETA %2PI) (SETQ THETA (- THETA (* %2PI (FLOAT (IL:UFIX (IL:FQUOTIENT THETA %2PI))))))) (IL:* IL:|;;| "Next range reduce to interval (0 PI) by (SIN (+ X PI)) = (minus (SIN X)) ") (WHEN (IL:UFGREATERP THETA PI) (SETQ THETA (- THETA PI)) (SETQ SIGN (IL:UFMINUS SIGN))) (IL:* IL:|;;|  "Next range reduce to interval (0 %PI/2) by (SIN (+ X %PI/2)) = (SIN (minus %PI/2 X))") (IF (IL:UFGREATERP THETA %PI/2) (SETQ THETA (- PI THETA))) (IF (IL:UFLESSP THETA %SIN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %SIN-EPSILON) then (SIN R) = R to the precision that we can offer. Return R because (1) it is desirable that (SIN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R") (SETQ THETA (* SIGN THETA)) (IL:* IL:|;;|  "Now use SIN 3374 rational approximation of Harris et al. which works on interval (0 %PI/2) ") (LET ((R2 (* THETA THETA))) (DECLARE (TYPE FLOAT R2)) (SETQ THETA (* SIGN THETA (IL:FQUOTIENT (%POLYEVAL R2 %SIN-PPOLY 5) (%POLYEVAL R2 %SIN-QPOLY 5)))))))) (DEFUN SIN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (SIN X) (COSH Y)) (* (COS X) (SINH Y))))) (NUMBER (%SIN-FLOAT RADIANS NIL)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS)))) (DEFUN COS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (COS X) (COSH Y)) (- (* (SIN X) (SINH Y)))))) (NUMBER (%SIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS)))) (IL:* IL:|;;| "Tan") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %TAN-EPSILON (IL:* IL:|;;| "%TAN-EPSILON is sufficiently small that (TAN X) = X for X in interval (0 %TAN-EPSILON). It suffices to take %TAN-EPSILON a little bit smaller than (SQRT (* 3 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (TAN X) = (+ X (/ (EXPT X 3) 3) ...) (The relative error caused by ommitting (/ (EXPT X 3) 3) isn't observable.) Comparison against %TAN-EPSILON is used to avoid POLYEVAL microcode underflow when computing TAN.") (%FLOAT 14720 0)) ) (XCL:DEFGLOBALVAR %TAN-PPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4). The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 5 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 13237 21090) (%FLOAT 47141 15825) (%FLOAT 15246 8785) (%FLOAT 48655 48761) (%FLOAT 16256 0)))) (XCL:DEFGLOBALVAR %TAN-QPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4). The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 6 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 45267 36947) (%FLOAT 13848 46875) (%FLOAT 47612 53738) (%FLOAT 15596 52854) (%FLOAT 48882 35303) (%FLOAT 16256 0)))) (DEFUN %TAN-FLOAT (X) (IL:* IL:|;;| "TAN of a FLOAT X calculated via TAN 4288 rational approximation of Hart et al.") (LET ((FX (FLOAT X)) (SIGN 1.0) RECIPFLG) (DECLARE (TYPE FLOAT FX SIGN)) (IL:* IL:|;;| "First range reduce to (0 infinity) by (TAN (minus X)) = (minus (TAN X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ SIGN -1.0) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Next range reduce to (0 PI)") (IF (IL:UFGEQ FX PI) (SETQ FX (- FX (* PI (FLOAT (IL:UFIX (IL:FQUOTIENT FX PI))))))) (IL:* IL:|;;| "Next, range reduce to (-PI/4 PI/4) using (TAN X) = (TAN (minus X PI)) to get into interval (-PI/2 PI/2) and then (TAN X) = (/ (TAN (minus PI/2 X))) to get into interval (-PI/4 PI/4) ") (COND ((IL:UFGREATERP FX %PI/2) (SETQ FX (- FX PI)) (WHEN (IL:UFLESSP FX %-PI/4) (SETQ RECIPFLG T) (SETQ FX (- %-PI/2 FX)))) (T (WHEN (IL:UFGREATERP FX %PI/4) (SETQ RECIPFLG T) (SETQ FX (- %PI/2 FX))))) (COND ((IL:UFLESSP (IL:UFABS FX) %TAN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %TAN-EPSILON) then (TAN R) = R to the precision that we can offer. Return R because (1) it is desirable that (TAN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R.") (SETQ FX (* SIGN FX)) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX)) (T (IL:* IL:|;;|  "Now use TAN 4288 rational approximation of Hart et al. which works on interval (0 %PI/4)") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* SIGN FX (IL:FQUOTIENT (%POLYEVAL R2 %TAN-PPOLY 4) (%POLYEVAL R2 %TAN-QPOLY 5)))) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX)))))) (DEFUN TAN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET* ((X (* 2.0 (COMPLEX-REALPART RADIANS))) (Y (* 2.0 (COMPLEX-IMAGPART RADIANS))) (DENOM (+ (COS X) (COSH Y)))) (COMPLEX (IL:QUOTIENT (SIN X) DENOM) (IL:QUOTIENT (SINH Y) DENOM)))) (NUMBER (%TAN-FLOAT RADIANS)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS)))) (IL:* IL:|;;| "Asin and Acos") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %ASIN-EPSILON (IL:* IL:|;;| "%ASIN-EPSILON is sufficiently small that (ASIN X) = X for X in interval (0 %ASIN-EPSILON). It suffices to take %ASIN-EPSILON a little bit smaller than (* 2 SINGLE-FLOAT-EPSILON) which we get by the Taylor series expansion (ASIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %ASIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0)) ) (XCL:DEFGLOBALVAR %ASIN-PPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 16007 50045) (%FLOAT 49549 8020) (%FLOAT 17236 15848) (%FLOAT 50285 63464) (%FLOAT 17650 31235) (%FLOAT 50403 62852) (%FLOAT 17440 39471)))) (XCL:DEFGLOBALVAR %ASIN-QPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE 'SINGLE-FLOAT :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49672 25817) (%FLOAT 17308 55260) (%FLOAT 50326 38098) (%FLOAT 17674 22210) (%FLOAT 50417 22451) (%FLOAT 17440 39471)))) (DEFUN %ASIN-FLOAT (X ACOS-FLG) (IL:* IL:|;;|  "(ASIN X) for float X calculated via ARCSN 4671 rational approximation of Hart et al.") (IF (OR (< X -1.0) (> X 1.0)) (ERROR "Arg not in range: ~s" X)) (LET ((FX (FLOAT X)) NEGATIVE REDUCED) (DECLARE (TYPE FLOAT FX)) (IL:* IL:|;;| "Range reduce to (0 1) via identity (ASIN (minus X)) = (minus (ASIN X)) ") (WHEN (IL:UFLESSP FX 0.0) (SETQ NEGATIVE T) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Range reduce to (0 0.5) via identity (ASIN X) = (minus %PI/2 (* 2.0 (ASIN (SQRT (* 0.5 (minus 1.0 R)))))) Avoids numerical instability calculating (ASIN X) for X near one. SIN is horizontally flat near %PI/2 so calculating (ASIN X) by rational approximation wouldn't work well for X near (SIN %PI/2) = 1") (WHEN (IL:UFGREATERP FX 0.5) (SETQ REDUCED T) (SETQ FX (SQRT (SETQ FX (* 0.5 (- 1.0 FX)))))) (IL:* IL:|;;|  "R is now in range (0 0.5) Use ARCSN 4671 rational approximation to calculate (ASIN R) ") (IF (IL:UFGREATERP FX %ASIN-EPSILON) (IL:* IL:|;;|  "If R is in the interval (0 %SIN-EPSILON) then (ASIN R) = R to the precision that we can offer. ") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* FX (IL:QUOTIENT (%POLYEVAL R2 %ASIN-PPOLY 6) (%POLYEVAL R2 %ASIN-QPOLY 6)))) NIL)) (IF REDUCED (SETQ FX (- %PI/2 (* 2.0 FX)))) (IF NEGATIVE (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;|  "In case we want (ACOS X) then use identity (ACOS X) = (minus %PI/2 (ASIN X))") (IF ACOS-FLG (SETQ FX (- %PI/2 FX))) FX)) (DEFUN ASIN (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((Z (LOG (+ (COMPLEX (- (COMPLEX-IMAGPART NUMBER)) (COMPLEX-REALPART NUMBER)) (SQRT (- 1 (* NUMBER NUMBER))))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT NUMBER NIL)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))) (DEFUN ACOS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((Z (SQRT (- 1 (* RADIANS RADIANS))))) (SETQ Z (LOG (+ RADIANS (COMPLEX (- (COMPLEX-IMAGPART Z)) (COMPLEX-REALPART Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS)))) (IL:* IL:|;;| "Atan ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT %SQRT3 (%FLOAT 16349 46039)) (DEFCONSTANT %2-SQRT3 (%FLOAT 16009 12451)) (DEFCONSTANT %INV-2-SQRT3 (%FLOAT 16494 55788)) ) (DEFUN %ATAN-FLOAT (Y &OPTIONAL X) (LET ((FY (FLOAT Y)) FX FARG) (DECLARE (TYPE FLOAT FY FX FARG)) (IL:* IL:|;;| "Compute farg") (COND ((NULL X) (IF (= Y 0.0) (RETURN-FROM %ATAN-FLOAT 0.0) (SETQ FARG FY))) (T (IL:* IL:|;;|  "Don't use unboxed version of =, because it doesn't return t on comparison of 0.0 and -0.0") (SETQ FX (FLOAT X)) (COND ((= X 0.0) (IF (= Y 0.0) (ERROR "Both args to atan are 0.0") (RETURN-FROM %ATAN-FLOAT (IF (> Y 0.0) %PI/2 (- %PI/2))))) ((= Y 0.0) (RETURN-FROM %ATAN-FLOAT (IF (> X 0.0) 0.0 PI))) ((> Y 0.0) (IF (> X 0.0) (SETQ FARG (IL:FQUOTIENT FY FX)) (SETQ FARG (IL:FQUOTIENT (IL:UFMINUS FY) FX)))) ((> X 0.0) (SETQ FARG (IL:FQUOTIENT FY (IL:UFMINUS FX)))) (T (SETQ FARG (IL:FQUOTIENT FY FX)))))) (IL:* IL:|;;| "Compute result") (LET ((CONSTANT 0.0) (CONSTANT-FLAG T) NEGATE-FLAG ADD-FLAG) (DECLARE (TYPE FLOAT CONSTANT)) (IL:* IL:|;;| "(ATAN (minus X)) = (minus (ATAN X)) ") (WHEN (IL:UFLESSP FARG 0.0) (SETQ NEGATE-FLAG T) (SETQ FARG (IL:UFMINUS FARG))) (IL:* IL:|;;| "Range reduce to (0, 2-sqrt(3))") (COND ((IL:UFGEQ FARG %INV-2-SQRT3) (IL:* IL:|;;| "(ATAN X) = (minus %PI/2 (ATAN (/ X)))") (SETQ CONSTANT %PI/2) (SETQ FARG (IL:FQUOTIENT 1.0 FARG))) ((IL:UFGEQ FARG 1.0) (SETQ CONSTANT %PI/3) (SETQ FARG (IL:FQUOTIENT (- %SQRT3 FARG) (+ 1.0 (* FARG %SQRT3))))) ((IL:UFGEQ FARG %2-SQRT3) (SETQ ADD-FLAG T) (SETQ CONSTANT %PI/6) (SETQ FARG (IL:FQUOTIENT (- (* FARG %SQRT3) 1.0) (+ %SQRT3 FARG)))) (T (SETQ CONSTANT-FLAG NIL))) (IL:* IL:|;;| "Power series expansion cons'ed up on the fly") (LET ((SQR (IL:UFMINUS (* FARG FARG))) (INT 1.0) (POW FARG) (OLD 0.0)) (DECLARE (TYPE FLOAT SQR INT POW OLD)) (LOOP (IF (IL:UFEQP FARG OLD) (RETURN NIL)) (SETQ INT (+ INT 2.0)) (SETQ POW (* POW SQR)) (SETQ OLD FARG) (SETQ FARG (+ FARG (IL:FQUOTIENT POW INT))))) (IF CONSTANT-FLAG (IF ADD-FLAG (SETQ FARG (+ CONSTANT FARG)) (SETQ FARG (- CONSTANT FARG)))) (IF NEGATE-FLAG (SETQ FARG (IL:UFMINUS FARG)))) (IL:* IL:|;;| "Fix up") (IF X (COND ((IL:UFGREATERP FY 0.0) (IF (IL:UFLESSP FX 0.0) (SETQ FARG (- PI FARG)))) ((IL:UFGREATERP FX 0.0) (SETQ FARG (IL:UFMINUS FARG))) (T (SETQ FARG (- FARG PI))))) (IL:* IL:|;;| "Box and return") FARG)) (DEFUN ATAN (Y &OPTIONAL X) (COND (X (%ATAN-FLOAT (FLOAT Y) (FLOAT X))) ((COMPLEXP Y) (LET ((R (COMPLEX-REALPART Y)) (I (COMPLEX-IMAGPART Y))) (IF (NOT (AND (ZEROP R) (= (ABS I) 1))) (LET ((Z (COMPLEX (- I) R))) (SETQ Z (* 0.5 (LOG (/ (+ 1 Z) (- 1 Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z)))) (ERROR "Argument not in domain for atan. ~S" Y)))) (T (%ATAN-FLOAT Y)))) (IL:* IL:|;;| "Cis (exp (i x))") (DEFUN CIS (RADIANS) (IF (TYPEP RADIANS '(AND NUMBER (NOT COMPLEX))) (COMPLEX (%SIN-FLOAT RADIANS T) (%SIN-FLOAT RADIANS)) (%NOT-NONCOMPLEX-NUMBER-ERROR RADIANS))) (IL:* IL:|;;| "Sinh, Cosh Tanh") (DEFUN SINH (NUMBER) (IL:* IL:|;;| "Computed directly from its ") (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (- Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (- FZ (IL:FQUOTIENT 1.0 FZ)) 2.0))))) (DEFUN COSH (NUMBER) (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (+ Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (+ FZ (IL:FQUOTIENT 1.0 FZ)) 2.0))))) (DEFUN TANH (NUMBER) (IF (COMPLEXP NUMBER) (/ (SINH NUMBER) (COSH NUMBER)) (LET* ((FX (%EXP-FLOAT (* 2 NUMBER))) (FY (IL:FQUOTIENT 1.0 FX))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- (IL:FQUOTIENT 1.0 (+ 1.0 FY)) (IL:FQUOTIENT 1.0 (+ 1.0 FX))))))) (IL:* IL:|;;| "Asinh Acosh Atanh") (DEFUN ASINH (NUMBER) (IF (COMPLEXP NUMBER) (LOG (+ NUMBER (SQRT (+ (* NUMBER NUMBER) 1)))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (+ (* FX FX) 1.0))))))))) (DEFUN ACOSH (NUMBER) (IF (OR (COMPLEXP NUMBER) (< NUMBER 1)) (LOG (+ NUMBER (* (+ NUMBER 1) (SQRT (/ (- NUMBER 1) (+ NUMBER 1)))))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (- (* FX FX) 1.0))))))))) (DEFUN ATANH (NUMBER) (IF (OR (COMPLEXP NUMBER) (> (ABS NUMBER) 1)) (IF (AND (ZEROP (IMAGPART NUMBER)) (= (ABS (REALPART NUMBER)) 1)) (ERROR "Argument out of range. ~s" NUMBER) (* 0.5 (LOG (/ (+ 1 NUMBER) (- 1 NUMBER))))) (IF (= NUMBER 1.0) (ERROR "Argument out of range. ~s" NUMBER) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (SETQ BOX (* 0.5 (LOG (SETQ BOX (IL:FQUOTIENT (+ 1.0 FX) (- 1.0 FX)))))))))) (IL:* IL:|;;| "rational and rationalize ") (DEFUN %RATIONAL-FLOAT (NUMBER) (IF (= NUMBER 0.0) 0 (LET (SIGN EXP HI LO MANT) (%FLOAT-UNBOX NUMBER SIGN EXP HI LO T) (SETQ MANT (+ (ASH HI 16) LO)) (IF (EQ SIGN 1) (SETQ MANT (- MANT))) (SETQ EXP (- EXP 23 IL:\\EXPONENT.BIAS)) (IF (< EXP 0) (%BUILD-RATIO MANT (ASH 1 (- EXP))) (ASH MANT EXP))))) (DEFUN %RATIONALIZE-FLOAT (X) (IL:* IL:|;;| "Produce a rational approximating X. ") (IL:* IL:|;;| "This routine presupposes familiarity with topics in number theory and IEEE FLOATP representation. The algorithm uses a standard mathematical technique for approximating a real valued number, but in very sophisticated form more amenable to the computer and the nature of IEEE FLOATPs and is not an algorithm you are likely to find published anywhere. ") (IF (= X 0.0) (IL:* IL:\;  "In case X = 0, just return 0 ") 0 (LET (SIGN EXPT HI LO XNUM XDEN R) (IL:* IL:|;;| "First of all, X is range reduced to the interval ((SQRT .5) (SQRT 2)) excluding (SQRT 2) This strategy has the property that FLOATPs differing only by sign and a power of two rationalize into rationals differing only by sign and a power of two. The choice of interval ((SQRT .5) (SQRT 2)) versus another interval such as (.5 1) is due to our wanting there to be roughly the same number of significant bits in the numerator as in the denominator of the answer that is returned. Here, significant bits is taken to mean the number of bits in the results returned by the continued fraction approximation and excludes the bits resulting from multiplying by the power of two. ") (IL:* IL:\;  "Get SIGN XNUM XDEN and EXPT for X. ") (LET (BIT-SIGN EXP HI LO) (%FLOAT-UNBOX X BIT-SIGN EXP HI LO T) (SETQ XNUM (+ (ASH HI 16) LO)) (SETQ EXPT (- EXP (+ IL:\\EXPONENT.BIAS 23))) (SETQ SIGN (IF (EQ BIT-SIGN 0) 1 -1)) (IL:* IL:\; "Compute r") (LOOP (IF (NOT (EQ 0 (LOGAND HI IL:\\HIDDENBIT))) (RETURN NIL)) (IL:* IL:\;  "Handle the denormalized case") (IL:.LLSH1. HI LO)) (IL:.LLSH8. HI LO) (SETQ R (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO))) (IL:* IL:\;  "24 because FLOATPs have 24 bit mantissas. ") (SETQ XDEN (IL:CONSTANT (ASH 1 24))) (SETQ EXPT (+ EXPT 24)) (COND ((< XNUM 11863283) (IL:* IL:\;  "11863283 = (SQRT 0.5) mantissa. ") (SETQ XDEN (ASH XDEN -1)) (SETQ EXPT (1- EXPT)) (SETQ R (* 2 R)))) (IL:* IL:|;;| "At this point, X = (* (/ XNUM XDEN) (EXPT 2 EXPT)) and (/ XNUM XDEN) is in the interval ((SQRT 0.5) (SQRT 2)) ") (LET ((OLDNUM 1) (OLDDEN 0) (NUM 0) (DEN 1)) (IL:* IL:\;  "Continued fraction approximation loop. ") (LOOP (COND ((AND (NOT (EQ DEN 0)) (= (IL:FQUOTIENT NUM DEN) R)) (COND ((> EXPT 0) (SETQ NUM (ASH NUM EXPT))) ((< EXPT 0) (SETQ DEN (ASH DEN (- EXPT))))) (RETURN (/ (* SIGN NUM) DEN)))) (ROTATEF XNUM XDEN) (LET ((TRUNC (IL:IQUOTIENT XNUM XDEN))) (SETQ NUM (+ OLDNUM (* TRUNC (SETQ OLDNUM NUM)))) (SETQ DEN (+ OLDDEN (* TRUNC (SETQ OLDDEN DEN)))) (SETQ XNUM (- XNUM (* XDEN TRUNC))))))))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:CMLFLOAT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:CMLFLOAT IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLFLOAT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CMLFLOATARRAY b/sources/CMLFLOATARRAY new file mode 100644 index 00000000..18dbf834 --- /dev/null +++ b/sources/CMLFLOATARRAY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Jun-90 14:41:02" {DSK}local>lde>lispcore>library>CMLFLOATARRAY.;2 29331 changes to%: (VARS CMLFLOATARRAYCOMS) previous date%: " 9-Apr-87 16:32:45" {DSK}local>lde>lispcore>library>CMLFLOATARRAY.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLFLOATARRAYCOMS) (RPAQQ CMLFLOATARRAYCOMS [(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) UNBOXEDOPS FLOAT-ARRAY-SUPPORT)) (* ;; "MAPARRAY fns and macros") (FNS MAP-ARRAY) (FUNCTIONS MAP-ARRAY-1 MAP-ARRAY-2) (FUNCTIONS REDUCE-ARRAY EVALUATE-POLYNOMIAL FIND-ARRAY-ELEMENT-INDEX) (FUNCTIONS FLATTEN-ARG MAX-ABS MIN-ABS) (FUNCTIONS %%MAP-FLOAT-ARRAY-ABS %%MAP-FLOAT-ARRAY-FLOAT %%MAP-FLOAT-ARRAY-MINUS %%MAP-FLOAT-ARRAY-NEGATE %%MAP-FLOAT-ARRAY-PLUS %%MAP-FLOAT-ARRAY-QUOTIENT %%MAP-FLOAT-ARRAY-TIMES %%MAP-FLOAT-ARRAY-TRUNCATE %%REDUCE-FLOAT-ARRAY-MAX %%REDUCE-FLOAT-ARRAY-MAX-ABS %%REDUCE-FLOAT-ARRAY-MIN %%REDUCE-FLOAT-ARRAY-MIN-ABS %%REDUCE-FLOAT-ARRAY-PLUS %%REDUCE-FLOAT-ARRAY-TIMES) (* ;; "For convenience") (PROP FILETYPE CMLFLOATARRAY) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MAP-ARRAY]) (DECLARE%: DONTCOPY DOEVAL@COMPILE (FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES) UNBOXEDOPS FLOAT-ARRAY-SUPPORT) ) (* ;; "MAPARRAY fns and macros") (DEFINEQ (MAP-ARRAY [LAMBDA ARGS (* ; "Edited 9-Apr-87 16:22 by jop") (* ;; "First arg, RESULT, may either be an array of the correct type, or a symbol indicating the element-type of the result, or NIL if the map is for effect. Second arg is the mapping functions. Other args are arrays, all of which must have the same number of elements, or non-arrays which will be treated as scalars ") (CL:IF (< ARGS 3) (CL:ERROR "MAPARRAY takes at least three args")) (LET ((RESULT (ARG ARGS 1)) (MAPFN (ARG ARGS 2)) (ARRAY1 (ARG ARGS 3)) FIRST-ARRAY) (* ;; "Arg checking. First-array is the first array map argument") (CL:IF (NOT (TYPEP MAPFN 'CL:FUNCTION)) (CL:ERROR "Not a function: ~S" MAPFN)) [CL:DO ((I 3 (CL:1+ I)) MAP-ARG) ((> I ARGS)) (SETQ MAP-ARG (ARG ARGS I)) (CL:WHEN (CL:ARRAYP MAP-ARG) (CL:IF FIRST-ARRAY (CL:IF (NOT (EQUAL-DIMENSIONS-P MAP-ARG FIRST-ARRAY)) (CL:ERROR "Dimensions mismatch" MAP-ARG)) (SETQ FIRST-ARRAY MAP-ARG] (* ;; "Coerce RESULT into an array or NIL") [CL:TYPECASE RESULT (CL:ARRAY (CL:IF [NOT (OR (EQUAL-DIMENSIONS-P RESULT FIRST-ARRAY) (AND (NULL FIRST-ARRAY) (EQ 0 (CL:ARRAY-RANK RESULT] (CL:ERROR "Dimensions mismatch: ~S" RESULT))) [(OR CL:SYMBOL CONS) (SETQ RESULT (CL:IF FIRST-ARRAY (CL:MAKE-ARRAY (CL:ARRAY-DIMENSIONS FIRST-ARRAY) :ELEMENT-TYPE RESULT) (CL:MAKE-ARRAY NIL :ELEMENT-TYPE RESULT] (T (OR (NULL RESULT) (CL:ERROR "RESULT must be an array, an element type, or NIL: ~S" RESULT] (CL:IF FIRST-ARRAY [CL:IF (AND RESULT (< ARGS 5)) [CL:ECASE ARGS (3 (* ;  "Note: in this case (EQ ARRAY1 FIRST-ARRAY)") (MAP-ARRAY-1 RESULT MAPFN ARRAY1)) (4 (MAP-ARRAY-2 RESULT MAPFN ARRAY1 (ARG ARGS 4] (LET* ((FLATTENED-RESULT (FLATTEN-ARG RESULT)) (SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) [FLATTENED-ARRAYS (for I from 3 to ARGS collect (FLATTEN-ARG (ARG ARGS I] (ELT-SLICE (CL:COPY-LIST FLATTENED-ARRAYS)) VALUE) (CL:DOTIMES (INDEX SIZE RESULT) [SETQ VALUE (CL:APPLY MAPFN (CL:DO ((%%SUBSLICE ELT-SLICE (CDR %%SUBSLICE) ) (%%SUBARRAYS FLATTENED-ARRAYS (CDR %%SUBARRAYS))) ((NULL %%SUBARRAYS) ELT-SLICE) (AND (CL:ARRAYP (CAR %%SUBARRAYS)) (RPLACA %%SUBSLICE (CL:AREF (CAR %%SUBARRAYS) INDEX] (CL:IF RESULT (CL:SETF (CL:AREF FLATTENED-RESULT INDEX) VALUE] (CL:IF RESULT [CL:SETF (CL:AREF RESULT) (CL:APPLY MAPFN (for I from 3 to ARGS collect (ARG ARGS I] (CL:APPLY MAPFN (for I from 3 to ARGS collect (ARG ARGS I]) ) (CL:DEFUN MAP-ARRAY-1 (RESULT MAPFN ARRAY) (* ;;  "Does something fast for MAPFNS - abs truncate float and EXPONENT. ARRAY is always an array.") [LET [(RESULT-FLOAT-P (EQ (CL:ARRAY-ELEMENT-TYPE RESULT) 'CL:SINGLE-FLOAT)) (ARRAY-FLOAT-P (EQ (CL:ARRAY-ELEMENT-TYPE ARRAY) 'CL:SINGLE-FLOAT] (* ; "Coerce MAPFN to standard form") (SETQ MAPFN (CL:TYPECASE MAPFN (CL:SYMBOL (CASE MAPFN (MINUS '-) (FIX 'CL:TRUNCATE) (T MAPFN))) (COMPILED-CLOSURE (COND ((OR (CL::%%EQCODEP MAPFN '-) (CL::%%EQCODEP MAPFN 'MINUS)) '-) ((CL::%%EQCODEP MAPFN 'ABS) 'ABS) ((OR (CL::%%EQCODEP MAPFN 'FIX) (CL::%%EQCODEP MAPFN 'CL:TRUNCATE)) 'CL:TRUNCATE) ((CL::%%EQCODEP MAPFN 'FLOAT) 'FLOAT) (T MAPFN))) (T MAPFN))) (COND ((AND (EQ MAPFN '-) RESULT-FLOAT-P ARRAY-FLOAT-P) (%%MAP-FLOAT-ARRAY-NEGATE RESULT ARRAY)) ((AND (EQ MAPFN 'ABS) RESULT-FLOAT-P ARRAY-FLOAT-P) (%%MAP-FLOAT-ARRAY-ABS RESULT ARRAY)) ((AND (EQ MAPFN 'CL:TRUNCATE) ARRAY-FLOAT-P) (%%MAP-FLOAT-ARRAY-TRUNCATE RESULT ARRAY)) ((AND (EQ MAPFN 'FLOAT) RESULT-FLOAT-P) (%%MAP-FLOAT-ARRAY-FLOAT RESULT ARRAY)) (T (LET ((FLATTENED-RESULT (FLATTEN-ARG RESULT)) (FLATTENED-ARRAY (FLATTEN-ARG ARRAY))) (CL:DOTIMES (INDEX (CL:ARRAY-TOTAL-SIZE RESULT) RESULT) (CL:SETF (CL:AREF FLATTENED-RESULT INDEX) (CL:FUNCALL MAPFN (CL:AREF FLATTENED-ARRAY INDEX))))]) (CL:DEFUN MAP-ARRAY-2 (RESULT MAPFN ARRAY-1 ARRAY-2) (* ;; "Does something fast for MAPFNS + - * /. At least one of ARRAY-1 and ARRAY-2 is an array") [LET [(ARRAYS-FLOAT-P (AND (EQ (CL:ARRAY-ELEMENT-TYPE RESULT) 'CL:SINGLE-FLOAT) [OR (TYPEP ARRAY-1 '(CL:ARRAY CL:SINGLE-FLOAT)) (TYPEP ARRAY-1 '(OR FLOAT CL:RATIONAL] (OR (TYPEP ARRAY-2 '(CL:ARRAY CL:SINGLE-FLOAT)) (TYPEP ARRAY-2 '(OR FLOAT CL:RATIONAL] (* ; "Coerce MAPFN to standard form") (SETQ MAPFN (CL:TYPECASE MAPFN (CL:SYMBOL (CASE MAPFN (PLUS '+) (MINUS '-) (TIMES 'CL:*) (QUOTIENT '/) (T MAPFN))) (COMPILED-CLOSURE (COND ((OR (CL::%%EQCODEP MAPFN '+) (CL::%%EQCODEP MAPFN 'PLUS)) '+) ((OR (CL::%%EQCODEP MAPFN '-) (CL::%%EQCODEP MAPFN 'MINUS)) '-) ((OR (CL::%%EQCODEP MAPFN 'CL:*) (CL::%%EQCODEP MAPFN 'TIMES)) 'CL:*) ((OR (CL::%%EQCODEP MAPFN '/) (CL::%%EQCODEP MAPFN 'QUOTIENT)) '/) (T MAPFN))) (T MAPFN))) (COND ((AND (EQ MAPFN '+) ARRAYS-FLOAT-P) (%%MAP-FLOAT-ARRAY-PLUS RESULT ARRAY-1 ARRAY-2)) ((AND (EQ MAPFN '-) ARRAYS-FLOAT-P) (%%MAP-FLOAT-ARRAY-MINUS RESULT ARRAY-1 ARRAY-2)) ((AND (EQ MAPFN 'CL:*) ARRAYS-FLOAT-P) (%%MAP-FLOAT-ARRAY-TIMES RESULT ARRAY-1 ARRAY-2)) ((AND (EQ MAPFN '/) ARRAYS-FLOAT-P) (%%MAP-FLOAT-ARRAY-QUOTIENT RESULT ARRAY-1 ARRAY-2)) (T (LET ((FLATTENED-RESULT (FLATTEN-ARG RESULT)) (FLATTENED-ARRAY-1 (FLATTEN-ARG ARRAY-1)) (FLATTENED-ARRAY-2 (FLATTEN-ARG ARRAY-2))) (CL:IF (CL:ARRAYP ARRAY-1) (CL:IF (CL:ARRAYP ARRAY-2) (CL:DOTIMES (INDEX (CL:ARRAY-TOTAL-SIZE RESULT) RESULT) (CL:SETF (CL:AREF FLATTENED-RESULT INDEX) (CL:FUNCALL MAPFN (CL:AREF FLATTENED-ARRAY-1 INDEX) (CL:AREF FLATTENED-ARRAY-2 INDEX)))) (CL:DOTIMES (INDEX (CL:ARRAY-TOTAL-SIZE RESULT) RESULT) (CL:SETF (CL:AREF FLATTENED-RESULT INDEX) (CL:FUNCALL MAPFN (CL:AREF FLATTENED-ARRAY-1 INDEX) FLATTENED-ARRAY-2)))) (CL:DOTIMES (INDEX (CL:ARRAY-TOTAL-SIZE RESULT) RESULT) (CL:SETF (CL:AREF FLATTENED-RESULT INDEX) (CL:FUNCALL MAPFN FLATTENED-ARRAY-1 (CL:AREF FLATTENED-ARRAY-2 INDEX)))))]) (CL:DEFUN REDUCE-ARRAY (REDUCTION-FN ARRAY &OPTIONAL (INITIAL-VALUE NIL INITIAL-VALUE-P)) (SETQ REDUCTION-FN (CL:TYPECASE REDUCTION-FN (CL:SYMBOL (CASE REDUCTION-FN (PLUS '+) (TIMES 'CL:*) (T REDUCTION-FN))) (COMPILED-CLOSURE (COND ((OR (CL::%%EQCODEP REDUCTION-FN '+) (CL::%%EQCODEP REDUCTION-FN 'PLUS)) '+) ((OR (CL::%%EQCODEP REDUCTION-FN 'CL:*) (CL::%%EQCODEP REDUCTION-FN 'TIMES)) 'CL:*) ((CL::%%EQCODEP REDUCTION-FN 'MIN) 'MIN) ((CL::%%EQCODEP REDUCTION-FN 'MAX) 'MAX) ((CL::%%EQCODEP REDUCTION-FN 'MIN-ABS) 'MIN-ABS) ((CL::%%EQCODEP REDUCTION-FN 'MAX-ABS) 'MAX-ABS) (T REDUCTION-FN))) (T REDUCTION-FN))) (CL:IF (NOT (CL:ARRAYP ARRAY)) (CL:IF INITIAL-VALUE-P (CL:FUNCALL REDUCTION-FN INITIAL-VALUE ARRAY) ARRAY) [LET [(SIZE (CL:ARRAY-TOTAL-SIZE ARRAY)) (ARRAY-FLOAT-P (EQ (CL:ARRAY-ELEMENT-TYPE ARRAY) 'CL:SINGLE-FLOAT] (CASE SIZE (0 (CL:IF INITIAL-VALUE-P INITIAL-VALUE (CL:FUNCALL REDUCTION-FN))) (1 (CL:IF INITIAL-VALUE-P (CL:FUNCALL REDUCTION-FN INITIAL-VALUE (CL:AREF (FLATTEN-ARG ARRAY) 0)) (CL:AREF (FLATTEN-ARG ARRAY) 0))) (T [COND ((AND (EQ REDUCTION-FN '+) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-PLUS ARRAY INITIAL-VALUE)) ((AND (EQ REDUCTION-FN 'CL:*) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-TIMES ARRAY INITIAL-VALUE)) ((AND (EQ REDUCTION-FN 'MIN) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-MIN ARRAY INITIAL-VALUE)) ((AND (EQ REDUCTION-FN 'MAX) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-MAX ARRAY INITIAL-VALUE)) ((AND (EQ REDUCTION-FN 'MIN-ABS) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-MIN-ABS ARRAY INITIAL-VALUE)) ((AND (EQ REDUCTION-FN 'MAX-ABS) ARRAY-FLOAT-P) (%%REDUCE-FLOAT-ARRAY-MAX-ABS ARRAY INITIAL-VALUE)) (T (CL:DO* ((FLATTENED-ARRAY (FLATTEN-ARG ARRAY)) (ACCUMULATOR (CL:IF INITIAL-VALUE-P INITIAL-VALUE (CL:AREF FLATTENED-ARRAY 0))) (INDEX (CL:IF INITIAL-VALUE-P 0 1) (CL:1+ INDEX))) ((EQ INDEX SIZE) ACCUMULATOR) (SETQ ACCUMULATOR (CL:FUNCALL REDUCTION-FN ACCUMULATOR (CL:AREF FLATTENED-ARRAY INDEX))))]) )])) (CL:DEFUN EVALUATE-POLYNOMIAL (X COEFFICIENTS) (CL:IF (NOT (CL:ARRAYP COEFFICIENTS)) (CL:ERROR "Not an array: ~S" COEFFICIENTS) (CL:IF (EQ (CL:ARRAY-ELEMENT-TYPE COEFFICIENTS) 'CL:SINGLE-FLOAT) (%%POLY-EVAL (FLOAT X) (%%GET-FLOAT-ARRAY-BASE COEFFICIENTS) (CL:1- (CL:ARRAY-TOTAL-SIZE COEFFICIENTS))) (CL:DO ((FLATTENED-ARRAY (FLATTEN-ARG COEFFICIENTS)) (INDEX 1 (CL:1+ INDEX)) (SIZE (CL:ARRAY-TOTAL-SIZE COEFFICIENTS)) (PRODUCT (CL:AREF COEFFICIENTS 0))) ((EQ INDEX SIZE) PRODUCT) (SETQ PRODUCT (+ (CL:* X PRODUCT) (CL:AREF COEFFICIENTS INDEX))))))) (CL:DEFUN FIND-ARRAY-ELEMENT-INDEX (ELEMENT ARRAY) (CL:IF (NOT (CL:ARRAYP ARRAY)) (CL:ERROR "Not an array: ~S" ARRAY) (CL:IF (EQ (CL:ARRAY-ELEMENT-TYPE ARRAY) 'CL:SINGLE-FLOAT) (CL:DO ((BASE (%%GET-FLOAT-ARRAY-BASE ARRAY) (\ADDBASE BASE 2)) (INDEX 0 (CL:1+ INDEX)) (F-ELEMENT (FLOAT ELEMENT)) (SIZE (CL:ARRAY-TOTAL-SIZE ARRAY))) ((EQ INDEX SIZE) NIL) (DECLARE (TYPE FLOAT F-ELEMENT)) (CL:IF (UFEQP F-ELEMENT (\GETBASEFLOATP BASE 0)) (RETURN INDEX))) (CL:DO ((FLATTENED-ARRAY (FLATTEN-ARG ARRAY)) (INDEX 0 (CL:1+ INDEX)) (SIZE (CL:ARRAY-TOTAL-SIZE ARRAY))) ((EQ INDEX SIZE) NIL) (CL:IF (EQL ELEMENT (CL:AREF FLATTENED-ARRAY INDEX)) (RETURN INDEX)))))) (CL:DEFUN FLATTEN-ARG (ARG) (CL:IF (OR (NOT (CL:ARRAYP ARG)) (EQ 1 (CL:ARRAY-RANK ARG))) ARG (CL:MAKE-ARRAY (CL:ARRAY-TOTAL-SIZE ARG) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ARG) :DISPLACED-TO ARG))) (CL:DEFUN MAX-ABS (X Y) (CL:IF (> (ABS X) (ABS Y)) X Y)) (CL:DEFUN MIN-ABS (X Y) (CL:IF (< (ABS X) (ABS Y)) X Y)) (CL:DEFUN %%MAP-FLOAT-ARRAY-ABS (RESULT ARRAY) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY) (\ADDBASE ARRAY-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE) RESULT) (\PUTBASEFLOATP RESULT-BASE 0 (UFABS (\GETBASEFLOATP ARRAY-BASE 0))))) (CL:DEFUN %%MAP-FLOAT-ARRAY-FLOAT (RESULT ARRAY) (LET ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT))) (CL:IF (EQUAL (CL:ARRAY-ELEMENT-TYPE ARRAY) '(CL:UNSIGNED-BYTE 16)) (%%BLKSMALLP2FLOAT (%%GET-FLOAT-ARRAY-BASE ARRAY) (%%GET-FLOAT-ARRAY-BASE RESULT) SIZE) (CL:DO ((RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (\PUTBASEFLOATP RESULT-BASE 0 (FLOAT (CL:AREF ARRAY INDEX))))) RESULT)) (CL:DEFUN %%MAP-FLOAT-ARRAY-MINUS (RESULT ARRAY-1 ARRAY-2) (CL:IF (CL:ARRAYP ARRAY-1) (CL:IF (CL:ARRAYP ARRAY-2) (%%BLKFDIFF (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (%%GET-FLOAT-ARRAY-BASE RESULT) (CL:ARRAY-TOTAL-SIZE RESULT)) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (\ADDBASE ARRAY-1-BASE 2)) (SCALAR (FLOAT ARRAY-2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE (\GETBASEFLOATP ARRAY-1-BASE 0) SCALAR)))) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (SCALAR (FLOAT ARRAY-1)) (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (\ADDBASE ARRAY-2-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0))))) RESULT) (CL:DEFUN %%MAP-FLOAT-ARRAY-NEGATE (RESULT ARRAY) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY) (\ADDBASE ARRAY-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE) RESULT) (\PUTBASEFLOATP RESULT-BASE 0 (UFMINUS (\GETBASEFLOATP ARRAY-BASE 0))))) (CL:DEFUN %%MAP-FLOAT-ARRAY-PLUS (RESULT ARRAY-1 ARRAY-2) (CL:IF (NOT (CL:ARRAYP ARRAY-1)) (CL:ROTATEF ARRAY-1 ARRAY-2)) (* ; "addition is commutative") (CL:IF (CL:ARRAYP ARRAY-2) (%%BLKFPLUS (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (%%GET-FLOAT-ARRAY-BASE RESULT) (CL:ARRAY-TOTAL-SIZE RESULT)) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (\ADDBASE ARRAY-1-BASE 2)) (SCALAR (FLOAT ARRAY-2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FPLUS (\GETBASEFLOATP ARRAY-1-BASE 0) SCALAR)))) RESULT) (CL:DEFUN %%MAP-FLOAT-ARRAY-QUOTIENT (RESULT ARRAY-1 ARRAY-2) (CL:IF (CL:ARRAYP ARRAY-1) (CL:IF (CL:ARRAYP ARRAY-2) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (\ADDBASE ARRAY-1-BASE 2)) (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (\ADDBASE ARRAY-1-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0) (\GETBASEFLOATP ARRAY-2-BASE 0)))) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (\ADDBASE ARRAY-1-BASE 2)) (SCALAR (FLOAT ARRAY-2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0) SCALAR)))) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (SCALAR (FLOAT ARRAY-1)) (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (\ADDBASE ARRAY-2-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0))))) RESULT) (CL:DEFUN %%MAP-FLOAT-ARRAY-TIMES (RESULT ARRAY-1 ARRAY-2) (CL:IF (NOT (CL:ARRAYP ARRAY-1)) (CL:ROTATEF ARRAY-1 ARRAY-2)) (* ; "Multiplication is commutative") (CL:IF (CL:ARRAYP ARRAY-2) (%%BLKFTIMES (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (%%GET-FLOAT-ARRAY-BASE ARRAY-2) (%%GET-FLOAT-ARRAY-BASE RESULT) (CL:ARRAY-TOTAL-SIZE RESULT)) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT) (\ADDBASE RESULT-BASE 2)) (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1) (\ADDBASE ARRAY-1-BASE 2)) (SCALAR (FLOAT ARRAY-2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE)) (DECLARE (TYPE FLOATP SCALAR)) (\PUTBASEFLOATP RESULT-BASE 0 (FTIMES (\GETBASEFLOATP ARRAY-1-BASE 0) SCALAR)))) RESULT) (CL:DEFUN %%MAP-FLOAT-ARRAY-TRUNCATE (RESULT ARRAY) (CL:DO ((SIZE (CL:ARRAY-TOTAL-SIZE RESULT)) (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY) (\ADDBASE ARRAY-BASE 2)) (INDEX 0 (CL:1+ INDEX))) ((EQ INDEX SIZE) RESULT) (CL:SETF (CL:AREF RESULT INDEX) (UFIX (\GETBASEFLOATP ARRAY-BASE 0))))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-MAX (ARRAY INITIAL-VALUE) (LET [(RESULT (CL:AREF ARRAY (%%BLKFMAX (%%GET-FLOAT-ARRAY-BASE ARRAY) 0 (CL:ARRAY-TOTAL-SIZE ARRAY] (CL:IF INITIAL-VALUE (MAX INITIAL-VALUE RESULT) RESULT))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-MAX-ABS (ARRAY INITIAL-VALUE) (LET [(RESULT (CL:AREF ARRAY (%%BLKFABSMAX (%%GET-FLOAT-ARRAY-BASE ARRAY) 0 (CL:ARRAY-TOTAL-SIZE ARRAY] (CL:IF INITIAL-VALUE (MAX-ABS INITIAL-VALUE RESULT) RESULT))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-MIN (ARRAY INITIAL-VALUE) (LET [(RESULT (CL:AREF ARRAY (%%BLKFMIN (%%GET-FLOAT-ARRAY-BASE ARRAY) 0 (CL:ARRAY-TOTAL-SIZE ARRAY] (CL:IF INITIAL-VALUE (MIN INITIAL-VALUE RESULT) RESULT))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-MIN-ABS (ARRAY INITIAL-VALUE) (LET [(RESULT (CL:AREF ARRAY (%%BLKFABSMIN (%%GET-FLOAT-ARRAY-BASE ARRAY) 0 (CL:ARRAY-TOTAL-SIZE ARRAY] (CL:IF INITIAL-VALUE (MIN-ABS INITIAL-VALUE RESULT) RESULT))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-PLUS (ARRAY INITIAL-VALUE) (LET [(RESULT (%%POLY-EVAL 1.0 (%%GET-FLOAT-ARRAY-BASE ARRAY) (CL:1- (CL:ARRAY-TOTAL-SIZE ARRAY] (CL:IF INITIAL-VALUE (+ INITIAL-VALUE RESULT) RESULT))) (CL:DEFUN %%REDUCE-FLOAT-ARRAY-TIMES (ARRAY INITIAL-VALUE) (LET ((TOTAL 1.0)) (DECLARE (TYPE FLOAT TOTAL)) (CL:DO ((I 0 (CL:1+ I)) (BASE (%%GET-FLOAT-ARRAY-BASE ARRAY) (\ADDBASE BASE 2)) (SIZE (CL:ARRAY-TOTAL-SIZE ARRAY))) ((EQ I SIZE) TOTAL) (SETQ TOTAL (CL:* TOTAL (\GETBASEFLOATP BASE 0)))) (CL:IF INITIAL-VALUE (CL:* INITIAL-VALUE TOTAL) TOTAL))) (* ;; "For convenience") (PUTPROPS CMLFLOATARRAY FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MAP-ARRAY) ) (PUTPROPS CMLFLOATARRAY COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1935 6603 (MAP-ARRAY 1945 . 6601))))) STOP \ No newline at end of file diff --git a/sources/CMLFORMAT b/sources/CMLFORMAT new file mode 100644 index 00000000..e53c1047 --- /dev/null +++ b/sources/CMLFORMAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 13:19:59" {DSK}local>lde>lispcore>sources>CMLFORMAT.;2 79148 changes to%: (VARS CMLFORMATCOMS) previous date%: " 5-Apr-89 14:15:38" {DSK}local>lde>lispcore>sources>CMLFORMAT.;1) (* ; " Copyright (c) 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLFORMATCOMS) (RPAQQ CMLFORMATCOMS ( (* ;; "The FORMAT facility") (STRUCTURES FORMAT-ERROR) (FUNCTIONS MAKE-DISPATCH-VECTOR SCALE-EXPONENT SCALE-EXPT-AUX) (FUNCTIONS FORMAT-ERROR) (VARIABLES *DIGIT-STRING* *DIGITS*) (FUNCTIONS FLONUM-TO-STRING FORMAT-WITH-CONTROL-STRING FORMAT-STRINGIFY-OUTPUT POP-FORMAT-ARG WITH-FORMAT-PARAMETERS NEXTCHAR FORMAT-PEEK FORMAT-FIND-CHAR) (FUNCTIONS FORMAT-GET-PARAMETER PARSE-FORMAT-OPERATION FORMAT-FIND-COMMAND CL:FORMAT SUB-FORMAT FORMAT-CAPITALIZATION FORMAT-ESCAPE FORMAT-SEMICOLON-ERROR FORMAT-UNTAGGED-CONDITION FORMAT-FUNNY-CONDITION FORMAT-BOOLEAN-CONDITION FORMAT-CONDITION FORMAT-ITERATION FORMAT-DO-ITERATION FORMAT-GET-TRAILING-SEGMENTS FORMAT-GET-SEGMENTS MAKE-PAD-SEGS FORMAT-ROUND-COLUMNS FORMAT-JUSTIFICATION FORMAT-TERPRI FORMAT-FRESHLINE FORMAT-PAGE FORMAT-TILDE FORMAT-EAT-WHITESPACE FORMAT-NEWLINE FORMAT-PLURAL FORMAT-SKIP-ARGUMENTS FORMAT-INDIRECTION FORMAT-TAB FORMAT-PRINC FORMAT-PRIN1 FORMAT-PRINT-CHARACTER FORMAT-PRINT-NAMED-CHARACTER FORMAT-ADD-COMMAS FORMAT-WRITE-FIELD FORMAT-PRINT-NUMBER FORMAT-PRINT-SMALL-CARDINAL FORMAT-PRINT-CARDINAL FORMAT-PRINT-CARDINAL-AUX FORMAT-PRINT-ORDINAL FORMAT-PRINT-OLD-ROMAN FORMAT-PRINT-ROMAN FORMAT-PRINT-DECIMAL FORMAT-PRINT-BINARY FORMAT-PRINT-OCTAL FORMAT-PRINT-HEXADECIMAL FORMAT-PRINT-RADIX FORMAT-PRINT-RADIX-AUX FORMAT-FIXED FORMAT-FIXED-AUX FORMAT-EXPONENTIAL FORMAT-EXPONENT-MARKER FORMAT-EXP-AUX FORMAT-GENERAL-FLOAT FORMAT-GENERAL-AUX FORMAT-DOLLARS) (FUNCTIONS CHARPOS WHITESPACE-CHAR-P) (FUNCTIONS NAME-ARRAY) (VARIABLES *FORMAT-ARGUMENTS* *FORMAT-CONTROL-STRING* *FORMAT-DISPATCH-TABLE* *FORMAT-INDEX* *FORMAT-LENGTH* *FORMAT-ORIGINAL-ARGUMENTS* CARDINAL-ONES CARDINAL-TENS CARDINAL-TEENS CARDINAL-PERIODS ORDINAL-ONES ORDINAL-TENS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA))) (* ;; "Arrange to use the correct compiler.") (PROP FILETYPE CMLFORMAT))) (* ;; "The FORMAT facility") (DEFINE-CONDITION FORMAT-ERROR (CL:ERROR) (ARGS) [:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "~%%~:{~@?~%%~}" (FORMAT-ERROR-ARGS CONDITION]) (DEFMACRO MAKE-DISPATCH-VECTOR (&BODY ENTRIES) (* ;; "Hairy dispatch-table initialization macro. Takes a list of two-element lists ( ) and returns a vector char-code-limit elements in length, where the Ith element is the function associated with the character with char-code I. If the character is case-convertible, it must be given in only one case however, an entry in the vector will be made for both.") [LET ((ENTRIES (CL:MAPCAN #'[CL:LAMBDA (X) (LET [(LOWER (CL:CHAR-DOWNCASE (CAR X))) (UPPER (CL:CHAR-UPCASE (CAR X] (CL:IF (CL:CHAR= LOWER UPPER) (LIST X) (LIST (CONS UPPER (CDR X)) (CONS LOWER (CDR X))))] ENTRIES))) (CL:DO ([ENTRIES (SORT ENTRIES #'(CL:LAMBDA (X Y) (CL:CHAR< (CAR X) (CAR Y] (CHARIDX 0 (CL:1+ CHARIDX)) (COMTAB NIL (CONS (CL:IF ENTRIES (CL:IF (= (CL:CHAR-CODE (CAAR ENTRIES)) CHARIDX) (CADR (pop ENTRIES)) NIL) NIL) COMTAB))) [(= CHARIDX 256) (CL:IF ENTRIES (CL:ERROR "Garbage in dispatch vector - ~S" ENTRIES)) `(CL:MAKE-ARRAY '(256) :ELEMENT-TYPE T :INITIAL-CONTENTS ',(CL:NREVERSE COMTAB])]) (CL:DEFUN SCALE-EXPONENT (X) (SCALE-EXPT-AUX X 0.0 1.0 10.0 0.1 (CONSTANT (CL:LOG 2.0 10.0)))) (CL:DEFUN SCALE-EXPT-AUX (X ZERO ONE TEN ONE-TENTH LOG10-OF-2) [CL:MULTIPLE-VALUE-BIND (SIG EXPONENT) (CL:DECODE-FLOAT X) (DECLARE (IGNORE SIG)) (CL:IF (= X ZERO) (CL:VALUES ZERO 1) [LET* [(E (ROUND (CL:* EXPONENT LOG10-OF-2))) (NEWX (CL:IF (MINUSP E) (CL:* X TEN (CL:EXPT TEN (- -1 E))) (/ X TEN (CL:EXPT TEN (CL:1- E))))] (CL:DO ((D TEN (CL:* D TEN)) (Y NEWX (/ NEWX D)) (E E (CL:1+ E))) [(< Y ONE) (CL:DO ((M TEN (CL:* M TEN)) (Z Y (CL:* Z M)) (E E (CL:1- E))) ((>= Z ONE-TENTH) (CL:VALUES (/ X (CL:EXPT 10 E)) E)))])])]) (CL:DEFUN FORMAT-ERROR (COMPLAINT &REST FORMAT-ARGS) [CL:ERROR 'FORMAT-ERROR :ARGS (LIST (LIST "~?~%%~S~%%~V@T^" COMPLAINT FORMAT-ARGS *FORMAT-CONTROL-STRING* (CL:1+ *FORMAT-INDEX*]) (CL:DEFVAR *DIGIT-STRING* (CL:MAKE-ARRAY 50 :ELEMENT-TYPE 'CL:STRING-CHAR :FILL-POINTER 0 :ADJUSTABLE T)) (CL:DEFCONSTANT *DIGITS* "0123456789") (CL:DEFUN FLONUM-TO-STRING (X &OPTIONAL WIDTH DECPLACES SCALE FMIN) (* ;; "Returns FIVE values: a string of digits with one decimal point, the string's length, T if the point is at the front, T if the point is at the end, the index of the point in the string") (CL:IF (ZEROP X) (CL:VALUES "." 1 T T) [LET* ((REALDP (COND (DECPLACES (CL:IF FMIN (MAX DECPLACES FMIN) DECPLACES)) (FMIN))) [ROUND (COND [REALDP (* ;  "Foo! Compute rounding place based on size of number and scale factor") (MIN 9 (+ (DIGITSBDP X) REALDP (OR SCALE 0] (WIDTH (MAX 1 (MIN 9 (CL:1- WIDTH] MANTSTR INTEXP) (CL:MULTIPLE-VALUE-SETQ (MANTSTR INTEXP) (FLTSTR X ROUND)) (CL:IF SCALE (CL:INCF INTEXP SCALE)) (* ;;  "OK, now copy the digit string into *digit-string* with the decimal point set appropriately") (CL:MACROLET [(STRPUT (C) `(CL:VECTOR-PUSH-EXTEND ,C *DIGIT-STRING*] (LET* ((DIGITS (CL:LENGTH MANTSTR)) (INDEX -1) (POINTPLACE (+ DIGITS INTEXP)) DECPNT) (* ;; "MANTSTR may have more digits than necessary; prune off its zeros. Doing this will lose if X is zero.") (IF (NOT (ZEROP X)) THEN (WHILE (AND (CL:PLUSP DIGITS) (CL:CHAR= (CL:CHAR MANTSTR (CL:1- DIGITS)) #\0)) DO (CL:DECF DIGITS) (CL:INCF INTEXP))) (CL:SETF (CL:FILL-POINTER *DIGIT-STRING*) 0) [COND ((NOT (CL:PLUSP POINTPLACE)) (* ; " .") (STRPUT #\.) (CL:DOTIMES (I (- POINTPLACE)) (STRPUT #\0)) (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I))) (SETQ DECPNT 0)) ((MINUSP INTEXP) (* ; ".") (CL:DOTIMES (I POINTPLACE) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (STRPUT #\.) (CL:DOTIMES (I (- INTEXP)) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (SETQ DECPNT (+ DIGITS INTEXP))) (T (* ; "00.") (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I))) (CL:DOTIMES (I INTEXP) (STRPUT #\0)) (STRPUT #\.) (SETQ DECPNT (+ DIGITS INTEXP] (SETQ DIGITS (CL:1- (CL:LENGTH *DIGIT-STRING*))) (IF DECPLACES THEN (* ;; "Need extra 0s to get enough decimal places") (CL:DOTIMES (I (- DECPLACES (- DIGITS DECPNT))) (STRPUT #\0) (CL:INCF DIGITS))) (CL:VALUES *DIGIT-STRING* (CL:1+ DIGITS) (= DECPNT 0) (= DECPNT DIGITS) DECPNT])) (DEFMACRO FORMAT-WITH-CONTROL-STRING (CONTROL-STRING &BODY FORMS) (* ;; "This macro establishes the correct environment for processing an indirect control string. CONTROL-STRING is the string to process, and FORMS are the forms to do the processing. They invariably will involve a call to SUB-FORMAT. CONTROL-STRING is guaranteed to be evaluated exactly once.") `[LET ((STRING ,CONTROL-STRING)) (CONDITION-CASE (LET ((*FORMAT-CONTROL-STRING* STRING) (*FORMAT-LENGTH* (CL:LENGTH STRING)) (*FORMAT-INDEX* 0)) ,@FORMS) (FORMAT-ERROR (C) (CL:ERROR 'FORMAT-ERROR :ARGS (CONS (LIST "While processing indirect control string~%%~S~%%~V@T^" *FORMAT-CONTROL-STRING* (CL:1+ *FORMAT-INDEX* )) (FORMAT-ERROR-ARGS C]) (DEFMACRO FORMAT-STRINGIFY-OUTPUT (&BODY FORMS) (* ;; "This macro collects output to the standard output stream in a string. It used to try to avoid consing new string streams if possible.") `(CL:WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT*) ,@FORMS)) (DEFMACRO POP-FORMAT-ARG () (* ;; "Pops an argument from the current argument list. This is either the list of arguments given to the top-level call to FORMAT, or the argument list for the current iteration in a ~{~} construct. An error is signalled if the argument list is empty. *") '(CL:IF *FORMAT-ARGUMENTS* (CL:POP *FORMAT-ARGUMENTS*) (FORMAT-ERROR "Missing argument"))) (DEFMACRO WITH-FORMAT-PARAMETERS (PARMVAR PARMDEFS &BODY FORMS) (* ;; "This macro decomposes the argument list returned by PARSE-FORMAT-OPERATION. PARMVAR is the list of parameters. PARMDEFS is a list of lists of the form ( ) . The FORMS are evaluated in an environment where each is bound to either the value of the parameter supplied in the parameter list, or to its value if the parameter was omitted or explicitly defaulted.") `(LET ,[FOR PARMDEF IN PARMDEFS COLLECT `(,(CL:FIRST PARMDEF) (OR (CL:IF ,PARMVAR (POP ,PARMVAR)) ,(CL:SECOND PARMDEF] (CL:WHEN ,PARMVAR (FORMAT-ERROR "Too many parameters")) ,@FORMS)) (DEFMACRO NEXTCHAR () (* ;; "Gets the next character from the current control string. It is an error if there is none. Leave *format-index* pointing to the character returned. *") '(CL:IF (< (CL:INCF *FORMAT-INDEX*) *FORMAT-LENGTH*) (CL:CHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*) (FORMAT-ERROR "Syntax error"))) (DEFMACRO FORMAT-PEEK () (* ;; "Returns the current character, i.e. the one pointed to by *format-index*.") '(CL:CHAR *FORMAT-CONTROL-STRING* *FORMAT-INDEX*)) (DEFMACRO FORMAT-FIND-CHAR (CHAR START END) (* ;; "Returns the index of the first occurrence of the specified character between indices START (inclusive) and END (exclusive) in the control string.") `(CL:POSITION ,CHAR *FORMAT-CONTROL-STRING* :START ,START :END ,END :TEST 'CL:CHAR=)) (CL:DEFUN FORMAT-GET-PARAMETER () (* ;; "Attempts to parse a parameter, starting at the current index. Returns the value of the parameter, or NIL if none is found. On exit, *format-index* points to the first character which is not a part of the recognized parameter.") (LET [(NUMSIGN (CASE (FORMAT-PEEK) (#\+ (NEXTCHAR) NIL) (#\- (NEXTCHAR) T) (T NIL))] (CASE (FORMAT-PEEK) (#\# (NEXTCHAR) (CL:LENGTH *FORMAT-ARGUMENTS*)) ((#\V #\v) (PROG1 (POP-FORMAT-ARG) (NEXTCHAR))) (#\' (PROG1 (NEXTCHAR) (NEXTCHAR))) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (CL:DO* [(CL:NUMBER (CL:DIGIT-CHAR-P ( FORMAT-PEEK )) (+ (CL:* 10 CL:NUMBER) (CL:DIGIT-CHAR-P ( FORMAT-PEEK ] ((NOT (CL:DIGIT-CHAR-P (NEXTCHAR))) (CL:IF NUMSIGN (- CL:NUMBER) CL:NUMBER)))) (T NIL)))) (CL:DEFUN PARSE-FORMAT-OPERATION ()  (* amd " 1-May-86 14:33") (* ;; "Parses a format directive, including flags and parameters. On entry, *format-index* should point to the '~' preceding the command. On exit, *format-index* points to the command character itself. Returns the list of parameters, the ':' flag, the '@' flag, and the command character as multiple values. Explicitly defaulted parameters appear in the list of parameters as NIL. Omitted parameters are simply not included in the list at all. *") (LET ((CH (NEXTCHAR)) PARMS COLON ATSIGN) (* ;; "First get the parameters") (SETQ PARMS (CL:IF (OR (CL:DIGIT-CHAR-P CH) (CL:MEMBER CH '(#\, #\# #\V #\v #\') :TEST (FUNCTION CL:CHAR=))) (CL:DO ((PARMS (LIST (FORMAT-GET-PARAMETER)) (CONS (FORMAT-GET-PARAMETER) PARMS))) ((CL:CHAR/= (FORMAT-PEEK) #\,) (CL:NREVERSE PARMS)) (NEXTCHAR)) 'NIL)) (* ;; "Then check for : and @ (not necessarily in that order)") [CL:LOOP (CASE (FORMAT-PEEK) (#\: (CL:IF COLON (RETURN NIL) (SETQ COLON (NEXTCHAR)))) (#\@ (CL:IF ATSIGN (RETURN NIL) (SETQ ATSIGN (NEXTCHAR)))) (T (RETURN NIL)))] (CL:VALUES PARMS COLON ATSIGN (FORMAT-PEEK)))) (CL:DEFUN FORMAT-FIND-COMMAND (COMMAND-LIST) (* ;; "Starting at the current value of *format-index*, finds the first occurrence of one of the specified directives. Embedded constructs, i.e. those inside ~ (~) %%, ~[~], ~{~}, or ~<~>, are ignored. And error is signalled if no satisfactory command is found. Otherwise, the following are returned as multiple values: The value of *format-index* at the start of the search The index of the '~' character preceding the command The parameter list of the command The ':' flag The '@' flag The command character Implementation note: The present implementation is not particulary careful with storage allocation. It would be a good idea to have a separate function for skipping embedded constructs which did not bother to cons parameter lists and then throw them away. We go to some trouble here to use POSITION for most of the searching.") [LET ((START *FORMAT-INDEX*)) (CL:DO ((PLACE START *FORMAT-INDEX*) (TILDE (FORMAT-FIND-CHAR #\~ START *FORMAT-LENGTH*) (FORMAT-FIND-CHAR #\~ PLACE *FORMAT-LENGTH*))) ((NOT TILDE) (FORMAT-ERROR "Expecting one of ~S" COMMAND-LIST)) (SETQ *FORMAT-INDEX* TILDE) [CL:MULTIPLE-VALUE-BIND (PARMS COLON ATSIGN COMMAND) (PARSE-FORMAT-OPERATION) (CL:WHEN (MEMBER COMMAND COMMAND-LIST :TEST (FUNCTION CL:CHAR=)) (RETURN (CL:VALUES START TILDE PARMS COLON ATSIGN COMMAND))) NIL (CASE COMMAND (#\{ (NEXTCHAR) (FORMAT-FIND-COMMAND '(#\}))) (#\< (NEXTCHAR) (FORMAT-FIND-COMMAND '(#\>))) (#\( (NEXTCHAR) (FORMAT-FIND-COMMAND '(#\)))) (#\[ (NEXTCHAR) (FORMAT-FIND-COMMAND '(#\]))) ((#\} #\> #\) #\]) (FORMAT-ERROR "No matching bracket")))])]) (CL:DEFUN CL:FORMAT (CL::DESTINATION CL::CONTROL-STRING &REST CL::FORMAT-ARGUMENTS) [LET ((*FORMAT-ORIGINAL-ARGUMENTS* CL::FORMAT-ARGUMENTS) (*FORMAT-ARGUMENTS* CL::FORMAT-ARGUMENTS) (*FORMAT-CONTROL-STRING* CL::CONTROL-STRING)) (CL:MACROLET [(CL::WITH-FORMAT-ESCAPES (&BODY CL::BODY) `(CL:CATCH 'FORMAT-ESCAPE (CL:CATCH 'FORMAT-COLON-ESCAPE ,@CL::BODY))] (COND [(NOT CL::DESTINATION) (FORMAT-STRINGIFY-OUTPUT (CL::WITH-FORMAT-ESCAPES (SUB-FORMAT 0 (CL:LENGTH CL::CONTROL-STRING ] ((CL:STRINGP CL::DESTINATION) [CL:WITH-OUTPUT-TO-STRING (*STANDARD-OUTPUT* CL::DESTINATION) (CL::WITH-FORMAT-ESCAPES (SUB-FORMAT 0 (CL:LENGTH CL::CONTROL-STRING] NIL) (T (LET [(*STANDARD-OUTPUT* (CL:IF (EQ CL::DESTINATION T) *STANDARD-OUTPUT* (* ;; " FORMAT extension - IL:DESTINATION may be anything that IL:GETSTREAM can coerce into being a stream") (GETSTREAM CL::DESTINATION 'OUTPUT))] (CL::WITH-FORMAT-ESCAPES (SUB-FORMAT 0 (CL:LENGTH CL::CONTROL-STRING))) NIL]) (CL:DEFUN SUB-FORMAT (START END) (* ;; "This function does the real work of format. The segment of the control string between indiced START (inclusive) and END (exclusive) is processed as follows: Text not part of a directive is output without further processing. Directives are parsed along with their parameters and flags, and the appropriate handlers invoked with the arguments COLON, ATSIGN, and PARMS. Implementation Note: FORMAT-FIND-CHAR uses the POSITION stream operation for speed. This is potentially faster than character-at-a-time searching.") [LET ((*FORMAT-INDEX* START) (*FORMAT-LENGTH* END)) (DECLARE (CL:SPECIAL *FORMAT-INDEX* *FORMAT-LENGTH*)) (CL:DO* ((PLACE START *FORMAT-INDEX*) (TILDE (FORMAT-FIND-CHAR #\~ START END) (FORMAT-FIND-CHAR #\~ PLACE END))) ((NOT TILDE) (WRITE-STRING* *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* PLACE END)) (CL:WHEN (> TILDE PLACE) (WRITE-STRING* *FORMAT-CONTROL-STRING* *STANDARD-OUTPUT* PLACE TILDE)) (SETQ *FORMAT-INDEX* TILDE) [CL:MULTIPLE-VALUE-BIND (PARMS COLON ATSIGN COMMAND) (PARSE-FORMAT-OPERATION) (LET [(CMDFUN (CL:AREF *FORMAT-DISPATCH-TABLE* (CL:CHAR-CODE COMMAND] (CL:IF CMDFUN (CL:FUNCALL CMDFUN COLON ATSIGN PARMS) (FORMAT-ERROR "Illegal FORMAT command ~~~C" COMMAND))] (CL:UNLESS (< (CL:INCF *FORMAT-INDEX*) END) (RETURN)))]) (CL:DEFUN FORMAT-CAPITALIZATION (COLON ATSIGN PARMS) (* ;; "Capitalize ~(") (CL:WHEN PARMS (FORMAT-ERROR "No parameters allowed to ~~(")) (NEXTCHAR) [CL:MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN) (FORMAT-FIND-COMMAND '(#\))) (CL:WHEN (OR END-PARMS END-COLON END-ATSIGN) (FORMAT-ERROR "Flags or parameters not allowed")) (LET* [(ESCAPE NIL) (STRING (FORMAT-STRINGIFY-OUTPUT (SETQ ESCAPE 'FORMAT-COLON-ESCAPE) (CL:CATCH 'FORMAT-COLON-ESCAPE (LET ((SUB-ESCAPE 'FORMAT-ESCAPE)) (CL:CATCH 'FORMAT-ESCAPE (SUB-FORMAT PREV TILDE) (SETQ SUB-ESCAPE NIL)) (CL:SETQ ESCAPE SUB-ESCAPE)))] [WRITE-STRING* (COND ((AND ATSIGN COLON) (CL:NSTRING-UPCASE STRING)) (COLON (CL:NSTRING-CAPITALIZE STRING)) [ATSIGN (* ; "Capitalize the first word only") (LET ((STRLEN (CL:LENGTH STRING))) (CL:NSTRING-DOWNCASE STRING) (CL:DO ((I 0 (CL:1+ I))) ((OR (<= STRLEN I) (CL:ALPHA-CHAR-P (CL:CHAR STRING I))) (CL:SETF (CL:CHAR STRING I) (CL:CHAR-UPCASE (CL:CHAR STRING I))) STRING))] (T (CL:NSTRING-DOWNCASE STRING] (AND ESCAPE (CL:THROW ESCAPE NIL]) (CL:DEFUN FORMAT-ESCAPE (COLON ATSIGN PARMS) (* ;; "Up and Out (Escape) ~^") (CL:WHEN ATSIGN (FORMAT-ERROR "FORMAT command ~~~:[~;:~]@^ is undefined" COLON)) (CL:WHEN (CL:IF (CL:FIRST PARMS) (CL:IF (CL:SECOND PARMS) (CL:IF (CL:THIRD PARMS) (CL:TYPECASE (CL:SECOND PARMS) (INTEGER (<= (CL:FIRST PARMS) (CL:SECOND PARMS) (CL:THIRD PARMS))) (CL:CHARACTER (CL:CHAR< (CL:FIRST PARMS) (CL:SECOND PARMS) (CL:THIRD PARMS))) (T NIL)) (EQUAL (CL:FIRST PARMS) (CL:SECOND PARMS))) (ZEROP (CL:FIRST PARMS))) (NOT *FORMAT-ARGUMENTS*)) (CL:THROW (CL:IF COLON 'FORMAT-COLON-ESCAPE 'FORMAT-ESCAPE) NIL))) (CL:DEFUN FORMAT-SEMICOLON-ERROR (COLON ATSIGN PARAMS) (DECLARE (IGNORE COLON ATSIGN PARAMS)) (FORMAT-ERROR "Unexpected semicolon (probably a missing ~~ somewhere).")) (CL:DEFUN FORMAT-UNTAGGED-CONDITION () (* ;; "~[") [LET ((TEST (POP-FORMAT-ARG))) (CL:UNLESS (CL:INTEGERP TEST) (FORMAT-ERROR "Argument to ~~[ must be integer - ~S" TEST)) (CL:DO ((CL:COUNT 0 (CL:1+ CL:COUNT))) [(= CL:COUNT TEST) (CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD) (FORMAT-FIND-COMMAND '(#\; #\])) (DECLARE (IGNORE COLON)) (CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed")) (CL:WHEN PARMS (FORMAT-ERROR "No parameters allowed")) (SUB-FORMAT PREV TILDE) (CL:UNLESS (CL:CHAR= CMD #\]) (FORMAT-FIND-COMMAND '(#\])))] (CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD) (FORMAT-FIND-COMMAND '(#\; #\])) (DECLARE (IGNORE PREV TILDE)) (CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed")) (CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed")) (CL:WHEN (CL:CHAR= CMD #\]) (RETURN)) (CL:WHEN COLON (NEXTCHAR) [CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD) (FORMAT-FIND-COMMAND '(#\; #\])) (DECLARE (IGNORE PARMS COLON ATSIGN)) (SUB-FORMAT PREV TILDE) (CL:UNLESS (CL:CHAR= CMD #\]) (FORMAT-FIND-COMMAND '(#\])))] (RETURN)) (NEXTCHAR)))]) (CL:DEFUN FORMAT-FUNNY-CONDITION () (* ;; "~@[ ") (CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN) (FORMAT-FIND-COMMAND '(#\])) (CL:WHEN (OR COLON ATSIGN PARMS) (FORMAT-ERROR "Flags or arguments not allowed")) (CL:IF *FORMAT-ARGUMENTS* (CL:IF (CAR *FORMAT-ARGUMENTS*) (SUB-FORMAT PREV TILDE) (CL:POP *FORMAT-ARGUMENTS*)) (FORMAT-ERROR "Missing argument")))) (CL:DEFUN FORMAT-BOOLEAN-CONDITION () (* ;; "~:[") [CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN) (FORMAT-FIND-COMMAND '(#\;)) (CL:WHEN (OR PARMS COLON ATSIGN) (FORMAT-ERROR "Flags or parameters not allowed")) (NEXTCHAR) (CL:IF (POP-FORMAT-ARG) (CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN) (FORMAT-FIND-COMMAND '(#\])) (CL:WHEN (OR COLON ATSIGN PARMS) (FORMAT-ERROR "Flags or parameters not allowed")) (SUB-FORMAT PREV TILDE)) [PROGN (SUB-FORMAT PREV TILDE) (FORMAT-FIND-COMMAND '(#\]])]) (CL:DEFUN FORMAT-CONDITION (COLON ATSIGN PARMS) (CL:WHEN PARMS (CL:PUSH (POP PARMS) *FORMAT-ARGUMENTS*) (CL:UNLESS (NULL PARMS) (FORMAT-ERROR "Too many parameters to ~["))) (NEXTCHAR) (COND (COLON (CL:WHEN ATSIGN (FORMAT-ERROR "~~:@[ undefined")) (FORMAT-BOOLEAN-CONDITION)) (ATSIGN (FORMAT-FUNNY-CONDITION)) (T (FORMAT-UNTAGGED-CONDITION)))) (CL:DEFUN FORMAT-ITERATION (COLON ATSIGN PARMS) (* ;; "Iteration ~{ ... ~}") [WITH-FORMAT-PARAMETERS PARMS ((MAX-ITER -1)) (NEXTCHAR) (CL:MULTIPLE-VALUE-BIND (PREV TILDE END-PARMS END-COLON END-ATSIGN) (FORMAT-FIND-COMMAND '(#\})) (CL:WHEN (OR END-ATSIGN END-PARMS) (FORMAT-ERROR "Illegal terminator for ~~{")) (CL:IF (= PREV TILDE) (LET ((STRING (POP-FORMAT-ARG))) (* ;; "Use an argument as the control string if ~{~} is empty") (CL:UNLESS (CL:STRINGP STRING) (FORMAT-ERROR "Control string is not a string")) (FORMAT-WITH-CONTROL-STRING STRING (FORMAT-DO-ITERATION 0 *FORMAT-LENGTH* MAX-ITER COLON ATSIGN END-COLON)) ) (FORMAT-DO-ITERATION PREV TILDE MAX-ITER COLON ATSIGN END-COLON))]) (CL:DEFUN FORMAT-DO-ITERATION (START END MAX-ITER COLON ATSIGN AT-LEAST-ONCE-P) (* ;; "The two catch tags FORMAT-ESCAPE and FORMAT-COLON-ESCAPE are needed here to correctly implement ~^ and ~:^. The former aborts only the current iteration, but the latter aborts the entire iteration process. *") (CL:CATCH 'FORMAT-COLON-ESCAPE (CL:CATCH 'FORMAT-ESCAPE (CL:IF ATSIGN (CL:DO ((CL:COUNT 0 (CL:1+ CL:COUNT))) [(OR (= CL:COUNT MAX-ITER) (AND (NULL *FORMAT-ARGUMENTS*) (CL:IF (= CL:COUNT 0) (NOT AT-LEAST-ONCE-P) T)] (CL:CATCH 'FORMAT-ESCAPE (CL:IF COLON (LET* ((*ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG)) (*FORMAT-ARGUMENTS* *ORIGINAL-ARGUMENTS*)) (CL:UNLESS (CL:LISTP *FORMAT-ARGUMENTS*) (FORMAT-ERROR "Argument must be a list")) (SUB-FORMAT START END)) (SUB-FORMAT START END)))) [LET* ((*ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG)) (*FORMAT-ARGUMENTS* *ORIGINAL-ARGUMENTS*)) (CL:UNLESS (CL:LISTP *FORMAT-ARGUMENTS*) (FORMAT-ERROR "Argument must be a list")) (CL:DO ((CL:COUNT 0 (CL:1+ CL:COUNT))) [(OR (= CL:COUNT MAX-ITER) (AND (NULL *FORMAT-ARGUMENTS*) (CL:IF (= CL:COUNT 0) (NOT AT-LEAST-ONCE-P) T)] (CL:CATCH 'FORMAT-ESCAPE (CL:IF COLON (LET* ((*ORIGINAL-ARGUMENTS* (POP-FORMAT-ARG)) (*FORMAT-ARGUMENTS* *ORIGINAL-ARGUMENTS*)) (CL:UNLESS (CL:LISTP *FORMAT-ARGUMENTS*) (FORMAT-ERROR "Argument must be a list of lists")) (SUB-FORMAT START END)) (SUB-FORMAT START END))))])))) (CL:DEFUN FORMAT-GET-TRAILING-SEGMENTS () (* ;; "Parses a list of clauses delimited by ~ and terminated by ~>. Recursively invoke SUB-FORMAT to process them, and return a list of the results, the length of this list, and the total number of characters in the strings composing the list.") (NEXTCHAR) [CL:MULTIPLE-VALUE-BIND (PREV TILDE COLON ATSIGN PARMS CMD) (FORMAT-FIND-COMMAND '(#\; #\>)) (CL:WHEN COLON (FORMAT-ERROR "~~:; allowed only after first segment in ~~<")) (CL:WHEN (OR ATSIGN PARMS) (FORMAT-ERROR "Flags and parameters not allowed")) (LET [(STR (CL:CATCH 'FORMAT-ESCAPE (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE)))] (CL:IF STR (CL:IF (CL:CHAR= CMD #\;) [CL:MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS) (FORMAT-GET-TRAILING-SEGMENTS) (CL:VALUES (CONS STR SEGMENTS) (CL:1+ NUMSEGS) (+ NUMCHARS (CL:LENGTH STR] (CL:VALUES (LIST STR) 1 (CL:LENGTH STR))) (CL:VALUES NIL 0 0))]) (CL:DEFUN FORMAT-GET-SEGMENTS () (* ;; "Gets the first segment, which is treated specially. Call FORMAT-GET-TRAILING-SEGMENTS to get the rest.") [CL:MULTIPLE-VALUE-BIND (PREV TILDE PARMS COLON ATSIGN CMD) (FORMAT-FIND-COMMAND '(#\; #\>)) (CL:WHEN ATSIGN (FORMAT-ERROR "Atsign flag not allowed")) (LET [(FIRST-SEG (FORMAT-STRINGIFY-OUTPUT (SUB-FORMAT PREV TILDE] (CL:IF (CL:CHAR= CMD #\;) [CL:MULTIPLE-VALUE-BIND (SEGMENTS NUMSEGS NUMCHARS) (FORMAT-GET-TRAILING-SEGMENTS) (CL:IF COLON (CL:VALUES FIRST-SEG PARMS SEGMENTS NUMSEGS NUMCHARS) (CL:VALUES NIL NIL (CONS FIRST-SEG SEGMENTS) (CL:1+ NUMSEGS) (+ (CL:LENGTH FIRST-SEG) NUMCHARS)))] (CL:VALUES NIL NIL (LIST FIRST-SEG) 1 (CL:LENGTH FIRST-SEG)))]) (CL:DEFUN MAKE-PAD-SEGS (SPACES PADDINGS) (* ;; "Given the total number of SPACES needed for padding, and the number of padding segments needed (PADDINGS) , returns a list of such segments. We try to allocate the spaces equally to each segment. When this is not possible, we allocate the left-over spaces randomly, to improve the appearance of many successive lines of justified text.") (* ;; "Query: Is this right? Perhaps consistency might be better for the kind of applications ~<~> is used for.") (CL:DO* ([EXTRA-SPACE NIL (AND (CL:PLUSP EXTRA-SPACES) (< (RAND 0 (FLOAT 1)) (/ SEGS EXTRA-SPACES] (RESULT NIL (CONS (CL:IF EXTRA-SPACE (CL:1+ MIN-SPACE) MIN-SPACE) RESULT)) (MIN-SPACE (CL:TRUNCATE SPACES PADDINGS)) (EXTRA-SPACES (- SPACES (CL:* PADDINGS MIN-SPACE)) (CL:IF EXTRA-SPACE (CL:1- EXTRA-SPACES) EXTRA-SPACES)) (SEGS PADDINGS (CL:1- SEGS))) ((ZEROP SEGS) RESULT))) (CL:DEFUN FORMAT-ROUND-COLUMNS (WIDTH MINCOL COLINC) (* ;; "Determine the actual width to be used for a field requiring WIDTH characters according to the following rule: If WIDTH is less than or equal to MINCOL, use WIDTH as the actual width. Otherwise, round up to MINCOL + k * COLINC for the smallest possible positive integer k.") (CL:IF (> WIDTH MINCOL) WIDTH (+ WIDTH (CL:* COLINC (CL:CEILING (- MINCOL WIDTH) COLINC))))) (CL:DEFUN FORMAT-JUSTIFICATION (COLON ATSIGN PARMS) [WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0) (COLINC 1) (MINPAD 0) (PADCHAR #\Space)) (CL:UNLESS (AND (CL:INTEGERP MINCOL) (NOT (MINUSP MINCOL))) (FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL)) (CL:UNLESS (AND (CL:INTEGERP COLINC) (CL:PLUSP COLINC)) (FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC)) (CL:UNLESS (AND (CL:INTEGERP MINPAD) (NOT (MINUSP MINPAD))) (FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD)) (CL:UNLESS (CL:CHARACTERP PADCHAR) (FORMAT-ERROR "Padchar must be a character - ~S" PADCHAR)) (NEXTCHAR) (CL:MULTIPLE-VALUE-BIND (SPECIAL-ARG SPECIAL-PARMS SEGMENTS NUMSEGS NUMCHARS) (FORMAT-GET-SEGMENTS) (LET* ([PADSEGS (CL:IF (= NUMSEGS 1) (CL:IF (AND COLON ATSIGN) 2 1) (+ (CL:IF COLON 1 0) (CL:1- NUMSEGS) (CL:IF ATSIGN 1 0)))] (WIDTH (FORMAT-ROUND-COLUMNS (+ NUMCHARS (CL:* MINPAD PADSEGS)) MINCOL COLINC)) (SPACES (MAKE-PAD-SEGS (- WIDTH NUMCHARS) PADSEGS))) (CL:IF (= NUMSEGS 1) [COND ((AND ATSIGN (NOT COLON)) (CL:PUSH '0 SPACES)) ((OR (AND COLON (NOT ATSIGN)) (AND (NOT ATSIGN) (NOT COLON))) (NCONC SPACES '(0] (PROGN (CL:IF (OR (AND COLON (NOT ATSIGN)) (AND (NOT ATSIGN) (NOT COLON))) (NCONC SPACES '(0))) (CL:IF (OR (AND ATSIGN (NOT COLON)) (AND (NOT ATSIGN) (NOT COLON))) (CL:PUSH '0 SPACES)))) (CL:WHEN SPECIAL-ARG [WITH-FORMAT-PARAMETERS SPECIAL-PARMS ((SPARE 0) (LINEL (OR (LINELENGTH) 72))) (LET ((POS (OR (CHARPOS *STANDARD-OUTPUT*) 0))) (CL:WHEN (> (+ POS WIDTH SPARE) LINEL) (WRITE-STRING* SPECIAL-ARG]) (CL:DO ((SEGS SEGMENTS (CDR SEGS)) (SPCS SPACES (CDR SPCS))) ((NULL SEGS) (CL:DOTIMES (I (CAR SPCS)) (CL:WRITE-CHAR PADCHAR))) (CL:DOTIMES (I (CAR SPCS)) (CL:WRITE-CHAR PADCHAR)) (WRITE-STRING* (CAR SEGS)))]) (CL:DEFUN FORMAT-TERPRI (COLON ATSIGN PARMS) (* ;; "Newline ~&") (CL:WHEN (OR COLON ATSIGN) (FORMAT-ERROR "Flags not allowed")) (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1)) (CL:DOTIMES (I REPEAT-COUNT) (TERPRI *STANDARD-OUTPUT*)))) (CL:DEFUN FORMAT-FRESHLINE (COLON ATSIGN PARMS) (* ;; "Fresh-line ~%%") (CL:WHEN (OR COLON ATSIGN) (FORMAT-ERROR "Flags not allowed")) (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1)) (CL:FRESH-LINE *STANDARD-OUTPUT*) (CL:DOTIMES (I (CL:1- REPEAT-COUNT)) (TERPRI *STANDARD-OUTPUT*)))) (CL:DEFUN FORMAT-PAGE (COLON ATSIGN PARMS) (* ;; " Page ~|") (CL:WHEN (OR COLON ATSIGN) (FORMAT-ERROR "Flags not allowed")) (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1)) (CL:DOTIMES (I REPEAT-COUNT) (CL:WRITE-CHAR #\Page)))) (CL:DEFUN FORMAT-TILDE (COLON ATSIGN PARMS) (* ;; "Print a tilde ~~") (CL:WHEN (OR COLON ATSIGN) (FORMAT-ERROR "Flags not allowed")) (WITH-FORMAT-PARAMETERS PARMS ((REPEAT-COUNT 1)) (CL:DOTIMES (I REPEAT-COUNT) (CL:WRITE-CHAR #\~)))) (CL:DEFUN FORMAT-EAT-WHITESPACE () (* ;; "Continue control string on next line ~") (NEXTCHAR) [SETQ *FORMAT-INDEX* (LET ((NEXT-NON-WHITE (CL:POSITION-IF-NOT (FUNCTION WHITESPACE-CHAR-P) *FORMAT-CONTROL-STRING* :START *FORMAT-INDEX*))) (CL:IF NEXT-NON-WHITE (CL:1- NEXT-NON-WHITE) (CL:LENGTH *FORMAT-CONTROL-STRING*))]) (CL:DEFUN FORMAT-NEWLINE (COLON ATSIGN PARMS) (CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed")) (COND (COLON (CL:WHEN ATSIGN (FORMAT-ERROR "~:@ is undefined"))) (ATSIGN (TERPRI *STANDARD-OUTPUT*) (FORMAT-EAT-WHITESPACE)) (T (FORMAT-EAT-WHITESPACE)))) (CL:DEFUN FORMAT-PLURAL (COLON ATSIGN PARMS) (* ;; "Pluralize word ~P") (CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed")) (CL:WHEN COLON (* ;; "Back up one argument first ") [LET ((CDRS (- (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*) (CL:LENGTH *FORMAT-ARGUMENTS*) 1))) (CL:IF (MINUSP CDRS) (FORMAT-ERROR "No previous argument") (SETQ *FORMAT-ARGUMENTS* (CL:NTHCDR CDRS *FORMAT-ORIGINAL-ARGUMENTS*)))]) (CL:IF (EQL (POP-FORMAT-ARG) 1) (WRITE-STRING* (CL:IF ATSIGN "y" "")) (WRITE-STRING* (CL:IF ATSIGN "ies" "s")))) (CL:DEFUN FORMAT-SKIP-ARGUMENTS (COLON ATSIGN PARMS) (* ;; "Skip arguments (relative goto) ~*") [WITH-FORMAT-PARAMETERS PARMS ((CL:COUNT (CL:IF ATSIGN 0 1))) (COND (ATSIGN (CL:WHEN (OR (MINUSP CL:COUNT) (> CL:COUNT (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*))) (FORMAT-ERROR "Illegal to go to non-existant argument")) (SETQ *FORMAT-ARGUMENTS* (CL:NTHCDR CL:COUNT *FORMAT-ORIGINAL-ARGUMENTS*))) [COLON (LET ((CDRS (- (CL:LENGTH *FORMAT-ORIGINAL-ARGUMENTS*) (CL:LENGTH *FORMAT-ARGUMENTS*) CL:COUNT))) (CL:IF (MINUSP CDRS) (FORMAT-ERROR "Skip to nonexistant argument") (SETQ *FORMAT-ARGUMENTS* (CL:NTHCDR CDRS *FORMAT-ORIGINAL-ARGUMENTS*)))] (T (CL:IF (> CL:COUNT (CL:LENGTH *FORMAT-ARGUMENTS*)) (FORMAT-ERROR "Skip to nonexistant argument") (SETQ *FORMAT-ARGUMENTS* (CL:NTHCDR CL:COUNT *FORMAT-ARGUMENTS*)))]) (CL:DEFUN FORMAT-INDIRECTION (COLON ATSIGN PARMS) (* ;; "Indirection ~?") (CL:WHEN COLON (FORMAT-ERROR "Colon modifier not allowed")) (CL:WHEN PARMS (FORMAT-ERROR "Parameters not allowed")) [LET ((STRING (POP-FORMAT-ARG))) (CL:UNLESS (CL:STRINGP STRING) (FORMAT-ERROR "Indirected control string is not a string")) (FORMAT-WITH-CONTROL-STRING STRING (CL:IF ATSIGN (SUB-FORMAT 0 *FORMAT-LENGTH*) (LET ((*FORMAT-ARGUMENTS* (POP-FORMAT-ARG))) (SUB-FORMAT 0 *FORMAT-LENGTH*)))]) (CL:DEFUN FORMAT-TAB (COLON ATSIGN PARMS) (* ;; "Tabulation ~T") (WITH-FORMAT-PARAMETERS PARMS ((COLNUM 1) (COLINC 1)) (CL:WHEN COLON (FORMAT-ERROR "Tab-to in pixel units not supported")) (CL:DOTIMES [X (LET ((POSITION (POSITION *STANDARD-OUTPUT*))) (* ;; "Note: the first column is numbered ZERO.") (COND [POSITION (LET [(TABCOL (CL:* COLINC (CL:CEILING (CL:IF ATSIGN (+ POSITION COLNUM) COLNUM) COLINC] (CL:IF (> POSITION TABCOL) (- COLINC (CL:REM (- POSITION TABCOL) COLINC)) (- TABCOL POSITION))] (ATSIGN COLNUM) (T 2] (CL:WRITE-CHAR #\Space *STANDARD-OUTPUT*)))) (CL:DEFUN FORMAT-PRINC (COLON ATSIGN PARMS) (* ;; "Ascii ~A *") [LET ((ARG (POP-FORMAT-ARG))) (CL:IF (NULL PARMS) (CL:IF ARG (CL:PRINC ARG) (CL:IF COLON (WRITE-STRING* "()") (CL:PRINC NIL))) (WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0) (COLINC 1) (MINPAD 0) (PADCHAR #\Space)) (FORMAT-WRITE-FIELD (CL:IF ARG (CL:PRINC-TO-STRING ARG) (CL:IF COLON "()" (CL:PRINC-TO-STRING NIL))) MINCOL COLINC MINPAD PADCHAR ATSIGN)))]) (CL:DEFUN FORMAT-PRIN1 (COLON ATSIGN PARMS) (* ;; "S-expression ~S") [LET ((ARG (POP-FORMAT-ARG))) (CL:IF (NULL PARMS) (CL:IF ARG (CL:PRIN1 ARG) (CL:IF COLON (WRITE-STRING* "()") (CL:PRIN1 NIL))) (WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0) (COLINC 1) (MINPAD 0) (PADCHAR #\Space)) (FORMAT-WRITE-FIELD (CL:IF ARG (CL:PRIN1-TO-STRING ARG) (CL:IF COLON "()" (CL:PRIN1-TO-STRING NIL))) MINCOL COLINC MINPAD PADCHAR ATSIGN)))]) (CL:DEFUN FORMAT-PRINT-CHARACTER (COLON ATSIGN PARMS) (* ;; "Character ~C") [WITH-FORMAT-PARAMETERS PARMS NIL (LET ((CL:CHAR (POP-FORMAT-ARG))) (CL:UNLESS (CL:CHARACTERP CL:CHAR) (FORMAT-ERROR "Argument must be a character")) (COND ((AND (NOT COLON) (NOT ATSIGN)) (CL:WRITE-CHAR CL:CHAR)) ((AND ATSIGN (NOT COLON)) (CL:PRIN1 CL:CHAR)) (T (FORMAT-PRINT-NAMED-CHARACTER CL:CHAR COLON]) (CL:DEFUN FORMAT-PRINT-NAMED-CHARACTER (CHAR LONGP) [LET* ((CH (CL:CODE-CHAR (CL:CHAR-CODE CHAR))) (NAME (CL:CHAR-NAME CH))) (* ;  "The calls to CODE-CHAR and CHAR-CODE strip funny bits") (COND [NAME (WRITE-STRING* (CL:STRING-CAPITALIZE (CL:PRINC-TO-STRING NAME] [(<= 0 (CL:CHAR-CODE CHAR) 31) (* ;  "Print control characters as '^' ") (CL:WRITE-CHAR #\^) (CL:WRITE-CHAR (CL:CODE-CHAR (+ 64 (CL:CHAR-CODE CHAR] (T (CL:WRITE-CHAR CH]) (CL:DEFUN FORMAT-ADD-COMMAS (STRING COMMACHAR COMMA-INTERVAL) (* ;; "Insert commas after every COMMA-INTERVALth digit, scanning from right to left. Signs don't count in the final length.") (CL:DO* ((LENGTH (CL:LENGTH (THE STRING STRING))) (NEW-LENGTH (+ LENGTH (CL:FLOOR (- LENGTH (CL:IF (OR (EQL (CL:CHAR STRING 0) #\+) (EQL (CL:CHAR STRING 0) #\-)) 2 1)) COMMA-INTERVAL))) (NEW-STRING (CL:MAKE-STRING NEW-LENGTH :INITIAL-ELEMENT COMMACHAR) (CL:REPLACE (THE STRING NEW-STRING) (THE STRING STRING) :START1 (MAX 0 (- NEW-POS COMMA-INTERVAL)) :END1 NEW-POS :START2 (MAX 0 (- POS COMMA-INTERVAL)) :END2 POS)) (POS LENGTH (- POS COMMA-INTERVAL)) (NEW-POS NEW-LENGTH (- NEW-POS COMMA-INTERVAL 1))) ((NOT (CL:PLUSP POS)) (* ;; "If there was a sign, put it back now") (CL:IF (OR (EQL (CL:CHAR STRING 0) #\+) (EQL (CL:CHAR STRING 0) #\-)) (CL:SETF (CL:CHAR NEW-STRING 0) (CL:CHAR STRING 0))) NEW-STRING))) (CL:DEFUN FORMAT-WRITE-FIELD (STRING MINCOL COLINC MINPAD PADCHAR PADLEFT) (* ;; "Output a string in a field at MINCOL wide, padding with PADCHAR. Pads on the left if PADLEFT is true, else on the right. If the length of the string plus the minimum permissible padding, MINPAD, is greater than MINCOL, the actual field size is rounded up to MINCOL + k * COLINC for the smallest possible positive integer k.") (CL:UNLESS (AND (CL:INTEGERP MINCOL) (NOT (MINUSP MINCOL))) (FORMAT-ERROR "Mincol must be a non-negative integer - ~S" MINCOL)) (CL:UNLESS (AND (CL:INTEGERP COLINC) (CL:PLUSP COLINC)) (FORMAT-ERROR "Colinc must be a positive integer - ~S" COLINC)) (CL:UNLESS (AND (CL:INTEGERP MINPAD) (NOT (MINUSP MINPAD))) (FORMAT-ERROR "Minpad must be a non-negative integer - ~S" MINPAD)) (CL:UNLESS (CL:CHARACTERP PADCHAR) (FORMAT-ERROR "Padchar must be a character - ~S" PADCHAR)) [LET* ((STRLEN (CL:LENGTH (THE STRING STRING))) (WIDTH (FORMAT-ROUND-COLUMNS (+ STRLEN MINPAD) MINCOL COLINC))) (COND (PADLEFT (CL:DOTIMES (I (- WIDTH STRLEN)) (CL:WRITE-CHAR PADCHAR)) (WRITE-STRING* STRING)) (T (WRITE-STRING* STRING) (CL:DOTIMES (I (- WIDTH STRLEN)) (CL:WRITE-CHAR PADCHAR))]) (CL:DEFUN FORMAT-PRINT-NUMBER (NUMBER RADIX PRINT-COMMAS-P PRINT-SIGN-P PARMS) (* ;; "This functions does most of the work for the numeric printing directives. The parameters are interpreted as defined for ~D.") [WITH-FORMAT-PARAMETERS PARMS ((MINCOL 0) (PADCHAR #\Space) (COMMACHAR #\,) (COMMA-INTERVAL 3)) (* ;  "comma-interval is an XCL extension.") (LET* ((*PRINT-BASE* RADIX) (*PRINT-RADIX* NIL) (TEXT (CL:PRINC-TO-STRING NUMBER))) (CL:IF (CL:INTEGERP NUMBER) (PROGN (* ;; "colinc = 1, minpad = 0, padleft = t ") (FORMAT-WRITE-FIELD (CL:IF (AND (CL:PLUSP NUMBER) PRINT-SIGN-P) (CL:IF PRINT-COMMAS-P (CL:CONCATENATE 'STRING "+" (FORMAT-ADD-COMMAS TEXT COMMACHAR COMMA-INTERVAL)) (CL:CONCATENATE 'STRING "+" TEXT)) (CL:IF PRINT-COMMAS-P (FORMAT-ADD-COMMAS TEXT COMMACHAR COMMA-INTERVAL) TEXT)) MINCOL 1 0 PADCHAR T)) (WRITE-STRING* TEXT))]) (CL:DEFUN FORMAT-PRINT-SMALL-CARDINAL (N) [CL:MULTIPLE-VALUE-BIND (HUNDREDS REM) (CL:TRUNCATE N 100) (CL:WHEN (CL:PLUSP HUNDREDS) (WRITE-STRING* (CL:SVREF CARDINAL-ONES HUNDREDS)) (WRITE-STRING* " hundred") (CL:WHEN (CL:PLUSP REM) (CL:WRITE-CHAR #\Space))) (CL:WHEN (CL:PLUSP REM) [CL:MULTIPLE-VALUE-BIND (TENS ONES) (CL:TRUNCATE REM 10) (COND [(< 1 TENS) (WRITE-STRING* (CL:SVREF CARDINAL-TENS TENS)) (CL:WHEN (CL:PLUSP ONES) (CL:WRITE-CHAR #\-) (WRITE-STRING* (CL:SVREF CARDINAL-ONES ONES)))] ((= TENS 1) (WRITE-STRING* (CL:SVREF CARDINAL-TEENS ONES))) ((CL:PLUSP ONES) (WRITE-STRING* (CL:SVREF CARDINAL-ONES ONES])]) (CL:DEFUN FORMAT-PRINT-CARDINAL (N) (COND ((MINUSP N) (WRITE-STRING* "negative ") (FORMAT-PRINT-CARDINAL-AUX (- N) 0 N)) ((ZEROP N) (WRITE-STRING* "zero")) (T (FORMAT-PRINT-CARDINAL-AUX N 0 N)))) (CL:DEFUN FORMAT-PRINT-CARDINAL-AUX (N PERIOD ERR) [CL:MULTIPLE-VALUE-BIND (BEYOND HERE) (CL:TRUNCATE N 1000) (CL:UNLESS (<= PERIOD 10) (FORMAT-ERROR "Number too large to print in English: ~:D" ERR)) (CL:UNLESS (ZEROP BEYOND) (FORMAT-PRINT-CARDINAL-AUX BEYOND (CL:1+ PERIOD) ERR)) (CL:UNLESS (ZEROP HERE) (CL:UNLESS (ZEROP BEYOND) (CL:WRITE-CHAR #\Space)) (FORMAT-PRINT-SMALL-CARDINAL HERE) (WRITE-STRING* (CL:SVREF CARDINAL-PERIODS PERIOD)))]) (CL:DEFUN FORMAT-PRINT-ORDINAL (N) (CL:WHEN (MINUSP N) (WRITE-STRING* "negative ")) [LET ((CL:NUMBER (ABS N))) (CL:MULTIPLE-VALUE-BIND (TOP BOT) (CL:TRUNCATE CL:NUMBER 100) (CL:UNLESS (ZEROP TOP) (FORMAT-PRINT-CARDINAL (- CL:NUMBER BOT))) (CL:WHEN (AND (CL:PLUSP TOP) (CL:PLUSP BOT)) (CL:WRITE-CHAR #\Space)) (CL:MULTIPLE-VALUE-BIND (TENS ONES) (CL:TRUNCATE BOT 10) (COND ((= BOT 12) (WRITE-STRING* "twelfth")) ((= TENS 1) (WRITE-STRING* (CL:SVREF CARDINAL-TEENS ONES)) (WRITE-STRING* "th")) ((AND (ZEROP TENS) (CL:PLUSP ONES)) (WRITE-STRING* (CL:SVREF ORDINAL-ONES ONES))) ((AND (ZEROP ONES) (CL:PLUSP TENS)) (WRITE-STRING* (CL:SVREF ORDINAL-TENS TENS))) ((CL:PLUSP BOT) (WRITE-STRING* (CL:SVREF CARDINAL-TENS TENS)) (CL:WRITE-CHAR #\-) (WRITE-STRING* (CL:SVREF ORDINAL-ONES ONES))) ((CL:PLUSP CL:NUMBER) (WRITE-STRING* "th")) (T (WRITE-STRING* "zeroeth"]) (CL:DEFUN FORMAT-PRINT-OLD-ROMAN (N) (* ;; "Print Roman numerals") (CL:UNLESS (< 0 N 5000) (FORMAT-ERROR "Number too large to print in old Roman numerals: ~:D" N)) (CL:DO [(CHAR-LIST '(#\D #\C #\L #\X #\V #\I) (CDR CHAR-LIST)) (VAL-LIST '(500 100 50 10 5 1) (CDR VAL-LIST)) (CUR-CHAR #\M (CAR CHAR-LIST)) (CUR-VAL 1000 (CAR VAL-LIST)) (START N (CL:DO [(I START (PROGN (CL:WRITE-CHAR CUR-CHAR) (- I CUR-VAL] ((< I CUR-VAL) I))] ((ZEROP START)))) (CL:DEFUN FORMAT-PRINT-ROMAN (N) (CL:UNLESS (< 0 N 4000) (FORMAT-ERROR "Number too large to print in Roman numerals: ~:D" N)) (CL:DO [(CHAR-LIST '(#\D #\C #\L #\X #\V #\I) (CDR CHAR-LIST)) (VAL-LIST '(500 100 50 10 5 1) (CDR VAL-LIST)) (SUB-CHARS '(#\C #\X #\X #\I #\I) (CDR SUB-CHARS)) (SUB-VAL '(100 10 10 1 1 0) (CDR SUB-VAL)) (CUR-CHAR #\M (CAR CHAR-LIST)) (CUR-VAL 1000 (CAR VAL-LIST)) (CUR-SUB-CHAR #\C (CAR SUB-CHARS)) (CUR-SUB-VAL 100 (CAR SUB-VAL)) (START N (CL:DO [(I START (PROGN (CL:WRITE-CHAR CUR-CHAR) (- I CUR-VAL] ((< I CUR-VAL) (COND ((<= (- CUR-VAL CUR-SUB-VAL) I) (CL:WRITE-CHAR CUR-SUB-CHAR) (CL:WRITE-CHAR CUR-CHAR) (- I (- CUR-VAL CUR-SUB-VAL))) (T I))))] ((ZEROP START)))) (CL:DEFUN FORMAT-PRINT-DECIMAL (COLON ATSIGN PARMS) (* ;; "Decimal ~D") (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG) 10 COLON ATSIGN PARMS)) (CL:DEFUN FORMAT-PRINT-BINARY (COLON ATSIGN PARMS) (* ;; "Binary ~B") (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG) 2 COLON ATSIGN PARMS)) (CL:DEFUN FORMAT-PRINT-OCTAL (COLON ATSIGN PARMS) (* ;; "Octal ~O") (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG) 8 COLON ATSIGN PARMS)) (CL:DEFUN FORMAT-PRINT-HEXADECIMAL (COLON ATSIGN PARMS) (* ;; "Hexadecimal ~X") (FORMAT-PRINT-NUMBER (POP-FORMAT-ARG) 16 COLON ATSIGN PARMS)) (CL:DEFUN FORMAT-PRINT-RADIX (COLON ATSIGN PARMS) (* ;; "Radix ~R") [LET ((CL:NUMBER (POP-FORMAT-ARG))) (CL:IF (CAR PARMS) (FORMAT-PRINT-NUMBER CL:NUMBER (pop PARMS) COLON ATSIGN PARMS) (CL:IF PARMS (FORMAT-WRITE-FIELD (FORMAT-STRINGIFY-OUTPUT (FORMAT-PRINT-RADIX-AUX CL:NUMBER COLON ATSIGN)) (CADR PARMS) 1 0 (COND ((CADDR PARMS)) (T #\Space) NIL) T) (FORMAT-PRINT-RADIX-AUX CL:NUMBER COLON ATSIGN)))]) (CL:DEFUN FORMAT-PRINT-RADIX-AUX (CL:NUMBER COLON ATSIGN) (CL:IF (TYPEP CL:NUMBER 'INTEGER) (CL:IF ATSIGN (CL:IF COLON (FORMAT-PRINT-OLD-ROMAN CL:NUMBER) (FORMAT-PRINT-ROMAN CL:NUMBER)) (CL:IF COLON (FORMAT-PRINT-ORDINAL CL:NUMBER) (FORMAT-PRINT-CARDINAL CL:NUMBER))) (FORMAT-ERROR "Non-integer ~S can't be FORMATted ~~~:[~;:~]~:[~;@~]R" CL:NUMBER COLON ATSIGN))) (CL:DEFUN FORMAT-FIXED (COLON ATSIGN PARMS) (* ;; "Fixed-format floating point ~F") (CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed")) [WITH-FORMAT-PARAMETERS PARMS ((W NIL) (D NIL) (K NIL) (OVF NIL) (PAD #\Space)) (* ;; "Note that the scale factor k defaults to nil. This is interpreted as zero by flonum-to-string, but more efficiently.") (LET ((CL:NUMBER (POP-FORMAT-ARG))) (CL:IF (FLOATP CL:NUMBER) (FORMAT-FIXED-AUX CL:NUMBER W D K OVF PAD ATSIGN) (CL:IF (CL:RATIONALP CL:NUMBER) (FORMAT-FIXED-AUX (COERCE CL:NUMBER 'FLOAT) W D K OVF PAD ATSIGN) (LET ((*PRINT-BASE* 10)) (FORMAT-WRITE-FIELD (CL:PRINC-TO-STRING CL:NUMBER) W 1 0 #\Space T))))]) (CL:DEFUN FORMAT-FIXED-AUX (NUMBER W D K OVF PAD ATSIGN) (CL:IF (NOT (OR W D K)) (PROGN (* ;; "Code snarfed from Spice printer OUTPUT-FLOAT") (CL:WHEN (MINUSP NUMBER) (CL:WRITE-CHAR #\-) (CL:SETQ NUMBER (- NUMBER))) (* ;;  "When number is reasonable size, use FLONUM-TO-STRING, otherwise punt and PRINC it") (CL:IF (AND (>= NUMBER 0.001) (<= NUMBER 1.0E+7)) (CL:MULTIPLE-VALUE-BIND (STR LEN LPOINT TPOINT) (FLONUM-TO-STRING NUMBER) (CL:WHEN LPOINT (CL:WRITE-CHAR #\0)) (WRITE-STRING* STR) (CL:WHEN TPOINT (CL:WRITE-CHAR #\0))) (CL:PRINC NUMBER))) [LET ((SPACELEFT W)) (CL:WHEN (AND W (OR ATSIGN (MINUSP NUMBER))) (CL:DECF SPACELEFT)) (CL:MULTIPLE-VALUE-BIND (STR LEN LPOINT TPOINT) (FLONUM-TO-STRING (ABS NUMBER) SPACELEFT D K) (* ;;  "if caller specifically requested no fraction digits, suppress the optional trailing zero") (CL:WHEN (AND D (ZEROP D)) (SETQ TPOINT NIL)) (CL:WHEN W (CL:DECF SPACELEFT LEN) (* ;; "optional leading zero force at least one digit") (CL:WHEN LPOINT (CL:IF (OR (> SPACELEFT 0) TPOINT) (CL:DECF SPACELEFT) (SETQ LPOINT NIL))) (* ;; "optional trailing zero") (CL:WHEN TPOINT (CL:IF (> SPACELEFT 0) (CL:DECF SPACELEFT) (SETQ TPOINT NIL)))) (COND ((AND W (< SPACELEFT 0) OVF) (* ;; "field width overflow") (CL:DOTIMES (I W) (CL:WRITE-CHAR OVF))) (T (CL:WHEN W (CL:DOTIMES (I SPACELEFT) (CL:WRITE-CHAR PAD))) (CL:IF (MINUSP NUMBER) (CL:WRITE-CHAR #\-) (CL:IF ATSIGN (CL:WRITE-CHAR #\+))) (CL:WHEN LPOINT (CL:WRITE-CHAR #\0)) (WRITE-STRING* STR) (CL:WHEN TPOINT (CL:WRITE-CHAR #\0])) (CL:DEFUN FORMAT-EXPONENTIAL (COLON ATSIGN PARMS) (* ;; "Exponential-format floating point ~E") (CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed")) [WITH-FORMAT-PARAMETERS PARMS ((W NIL) (D NIL) (E NIL) (K 1) (OVF NIL) (PAD #\Space) (MARKER NIL)) (LET ((CL:NUMBER (POP-FORMAT-ARG))) (CL:IF (FLOATP CL:NUMBER) (FORMAT-EXP-AUX CL:NUMBER W D E K OVF PAD MARKER ATSIGN) (CL:IF (CL:RATIONALP CL:NUMBER) (FORMAT-EXP-AUX (COERCE CL:NUMBER 'FLOAT) W D E K OVF PAD MARKER ATSIGN) (LET ((*PRINT-BASE* 10)) (FORMAT-WRITE-FIELD (CL:PRINC-TO-STRING CL:NUMBER) W 1 0 #\Space T))))]) (CL:DEFUN FORMAT-EXPONENT-MARKER (CL:NUMBER) (CL:IF (TYPEP CL:NUMBER *READ-DEFAULT-FLOAT-FORMAT*) #\E (CL:ETYPECASE CL:NUMBER (CL:SHORT-FLOAT #\S) (CL:SINGLE-FLOAT #\F)))) (CL:DEFUN FORMAT-EXP-AUX (NUMBER W D E K OVF PAD MARKER ATSIGN) (* ;; "Here we prevent the scale factor from shifting all significance out of a number to the right. We allow insignificant zeroes to be shifted in to the left right, athough it is an error to specify k and d such that this occurs. Perhaps we should detect both these conditions and flag them as errors. As for now, we let the user get away with it, and merely guarantee that at least one significant digit will appear.") (CL:IF (NOT (OR W D)) (CL:PRIN1 NUMBER) [CL:MULTIPLE-VALUE-BIND (NUM EXPT) (SCALE-EXPONENT (ABS NUMBER)) (LET* ((EXPT (- EXPT K)) (ESTR (CL:PRINC-TO-STRING (ABS EXPT))) (ELEN (CL:IF E (MAX (CL:LENGTH ESTR) E) (CL:LENGTH ESTR))) (FDIG (CL:IF D (CL:IF (CL:PLUSP K) (CL:1+ (- D K)) D) NIL)) (FMIN (CL:IF (MINUSP K) (- 1 K) NIL)) (SPACELEFT (CL:IF W (- W 2 ELEN) NIL))) (CL:WHEN (OR ATSIGN (MINUSP NUMBER)) (CL:DECF SPACELEFT)) (CL:IF (AND W E OVF (> ELEN E)) (PROGN (* ;; "exponent overflow") (CL:DOTIMES (I W) (CL:WRITE-CHAR OVF))) [CL:MULTIPLE-VALUE-BIND (FSTR FLEN LPOINT TPOINT) (FLONUM-TO-STRING NUM SPACELEFT FDIG K FMIN) (CL:WHEN W (CL:DECF SPACELEFT FLEN) (CL:WHEN LPOINT (CL:IF (> SPACELEFT 0) (CL:DECF SPACELEFT) (SETQ LPOINT NIL)))) (COND ((AND W (< SPACELEFT 0) OVF) (* ;; "significand overflow") (CL:DOTIMES (I W) (CL:WRITE-CHAR OVF))) (T (CL:WHEN W (CL:DOTIMES (I SPACELEFT) (CL:WRITE-CHAR PAD))) (CL:IF (MINUSP NUMBER) (CL:WRITE-CHAR #\-) (CL:IF ATSIGN (CL:WRITE-CHAR #\+))) (CL:WHEN LPOINT (CL:WRITE-CHAR #\0)) (WRITE-STRING* FSTR) (* ;; "(cl:when tpoint (cl:write-char #\0))") (CL:WRITE-CHAR (CL:IF MARKER MARKER (FORMAT-EXPONENT-MARKER NUMBER))) (CL:WRITE-CHAR (CL:IF (MINUSP EXPT) #\- #\+)) (CL:WHEN E (* ;; "zero-fill before exponent if necessary") (CL:DOTIMES (I (- E (CL:LENGTH ESTR))) (CL:WRITE-CHAR #\0))) (WRITE-STRING* ESTR])])) (CL:DEFUN FORMAT-GENERAL-FLOAT (COLON ATSIGN PARMS) (* ;; "General Floating Point --- ~G") (CL:WHEN COLON (FORMAT-ERROR "Colon flag not allowed")) [WITH-FORMAT-PARAMETERS PARMS ((W NIL) (D NIL) (E NIL) (K NIL) (OVF #\*) (PAD #\Space) (MARKER NIL)) (LET ((CL:NUMBER (POP-FORMAT-ARG))) (* ;; "The Excelsior edition does not say what to do if the argument is not a float. Here, we adopt the conventions used by ~F and ~E.") (CL:IF (FLOATP CL:NUMBER) (FORMAT-GENERAL-AUX CL:NUMBER W D E K OVF PAD MARKER ATSIGN) (CL:IF (CL:RATIONALP CL:NUMBER) (FORMAT-GENERAL-AUX (COERCE CL:NUMBER 'FLOAT) W D E K OVF PAD MARKER ATSIGN) (LET ((*PRINT-BASE* 10)) (FORMAT-WRITE-FIELD (CL:PRINC-TO-STRING CL:NUMBER) W 1 0 #\Space T))))]) (CL:DEFUN FORMAT-GENERAL-AUX (CL:NUMBER W D E K OVF PAD MARKER ATSIGN) [CL:MULTIPLE-VALUE-BIND (IGNORE N) (SCALE-EXPONENT (ABS CL:NUMBER)) (DECLARE (IGNORE IGNORE)) (* ;; "Default d if omitted. The procedure is taken directly from the definition given in the manual, and is not very efficient, since we generate the digits twice. Future maintainers are encouraged to improve on this.") (CL:UNLESS D [CL:MULTIPLE-VALUE-BIND (STR LEN) (FLONUM-TO-STRING (ABS CL:NUMBER)) (DECLARE (IGNORE STR)) (LET [(Q (CL:IF (= LEN 1) 1 (CL:1- LEN))] (SETQ D (MAX Q (MIN N 7]) (LET* ((EE (CL:IF E (+ E 2) 4)) (WW (CL:IF W (- W EE) NIL)) (DD (- D N))) (COND ((<= 0 DD D) (FORMAT-FIXED-AUX CL:NUMBER WW DD NIL OVF PAD ATSIGN) (CL:DOTIMES (I EE) (CL:WRITE-CHAR #\Space))) (T (FORMAT-EXP-AUX CL:NUMBER W D E (OR K 1) OVF PAD MARKER ATSIGN]) (CL:DEFUN FORMAT-DOLLARS (COLON ATSIGN PARMS) (* ;; "Dollars floating-point format ~$") [WITH-FORMAT-PARAMETERS PARMS ((D 2) (N 1) (FW 0) (PAD #\Space)) (LET* [(CL:NUMBER (POP-FORMAT-ARG)) (SIGNSTR (CL:IF (MINUSP CL:NUMBER) "-" (CL:IF ATSIGN "+" ""))] (CL:MULTIPLE-VALUE-BIND (STR NUMLENGTH IG2 IG3 POINTPLACE) (FLONUM-TO-STRING (ABS CL:NUMBER) NIL D NIL) (DECLARE (IGNORE IG2 IG3)) (CL:WHEN COLON (WRITE-STRING* SIGNSTR)) (CL:DOTIMES [I (- FW NUMLENGTH (CL:LENGTH SIGNSTR) (MAX 0 (- N POINTPLACE] (CL:WRITE-CHAR PAD)) (CL:UNLESS COLON (WRITE-STRING* SIGNSTR)) (CL:DOTIMES (I (- N POINTPLACE)) (CL:WRITE-CHAR #\0)) (WRITE-STRING* STR]) (CL:DEFUN CHARPOS (STREAM) (CL:UNLESS (STREAMP STREAM) (CL:ERROR "CHARPOS: ~A isn't a stream" STREAM)) (fetch (STREAM CHARPOSITION) of STREAM)) (CL:DEFUN WHITESPACE-CHAR-P (CH) (CL:MEMBER CH '(#\Tab #\Page #\Space #\Backspace #\Newline #\Linefeed) :TEST (FUNCTION EQL))) (DEFMACRO NAME-ARRAY (CONTENTS) `(CL:MAKE-ARRAY ,(LENGTH CONTENTS) :ELEMENT-TYPE T :INITIAL-CONTENTS ',CONTENTS)) (CL:DEFVAR *FORMAT-ARGUMENTS* NIL "List of FORMAT args yet unprocessed") (CL:DEFVAR *FORMAT-CONTROL-STRING* NIL "Bound to FORMAT control string") (CL:DEFVAR *FORMAT-DISPATCH-TABLE* (MAKE-DISPATCH-VECTOR (#\B FORMAT-PRINT-BINARY) (#\O FORMAT-PRINT-OCTAL) (#\D FORMAT-PRINT-DECIMAL) (#\X FORMAT-PRINT-HEXADECIMAL) (#\R FORMAT-PRINT-RADIX) (#\F FORMAT-FIXED) (#\E FORMAT-EXPONENTIAL) (#\G FORMAT-GENERAL-FLOAT) (#\A FORMAT-PRINC) (#\C FORMAT-PRINT-CHARACTER) (#\P FORMAT-PLURAL) (#\S FORMAT-PRIN1) (#\T FORMAT-TAB) (#\% FORMAT-TERPRI) (#\& FORMAT-FRESHLINE) (#\* FORMAT-SKIP-ARGUMENTS) (#\| FORMAT-PAGE) (#\~ FORMAT-TILDE) (#\$ FORMAT-DOLLARS) (#\? FORMAT-INDIRECTION) (#\^ FORMAT-ESCAPE) (#\; FORMAT-SEMICOLON-ERROR) (#\[ FORMAT-CONDITION) (#\{ FORMAT-ITERATION) (#\< FORMAT-JUSTIFICATION) (#\( FORMAT-CAPITALIZATION) (#\Newline FORMAT-NEWLINE)) "Table of functions called by SUB-FORMAT to process ~foo stuff") (CL:DEFVAR *FORMAT-INDEX* NIL "Index into current control string") (CL:DEFVAR *FORMAT-LENGTH* NIL "Length of current control string") (CL:DEFVAR *FORMAT-ORIGINAL-ARGUMENTS* NIL "List of original FORMAT arguments") (CL:DEFVAR CARDINAL-ONES (NAME-ARRAY (NIL "one" "two" "three" "four" "five" "six" "seven" "eight" "nine")) "Table of strings used by ~R") (CL:DEFVAR CARDINAL-TENS (NAME-ARRAY (NIL NIL "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" "ninety")) "Table of strings used by ~R") (CL:DEFVAR CARDINAL-TEENS (NAME-ARRAY ("ten" "eleven" "twelve" "thirteen" "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" "nineteen")) "Table of strings used by ~R") (CL:DEFVAR CARDINAL-PERIODS (NAME-ARRAY ("" " thousand" " million" " billion" " trillion" " quadrillion" " quintillion" " sextillion" " septillion" " octillion" " nonillion" " decillion") ) "Table of strings used by ~R") (CL:DEFVAR ORDINAL-ONES (NAME-ARRAY (NIL "first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" "ninth")) "Table of strings used by ~R") (CL:DEFVAR ORDINAL-TENS (NAME-ARRAY (NIL "tenth" "twentieth" "thirtieth" "fourtieth" "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth")) "Table of strings used by ~R") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (* ;; "Arrange to use the correct compiler.") (PUTPROPS CMLFORMAT FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLFORMAT COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLHASH b/sources/CMLHASH new file mode 100644 index 00000000..449c2124 --- /dev/null +++ b/sources/CMLHASH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 13:25:03" IL:|{DSK}local>lde>lispcore>sources>CMLHASH.;2| 8265 IL:|changes| IL:|to:| (IL:VARS IL:CMLHASHCOMS) IL:|previous| IL:|date:| " 8-Jun-89 17:15:50" IL:|{DSK}local>lde>lispcore>sources>CMLHASH.;1| ) ; Copyright (c) 1985, 1986, 1987, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLHASHCOMS) (IL:RPAQQ IL:CMLHASHCOMS ( (IL:* IL:|;;| "External interface") (IL:FUNCTIONS MAKE-HASH-TABLE GETHASH MAPHASH HASH-TABLE-COUNT HASH-TABLE-P SXHASH) (XCL:OPTIMIZERS GETHASH HASH-TABLE-COUNT HASH-TABLE-P) (IL:SETFS GETHASH) (IL:* IL:|;;| "Internal interface") (IL:FUNCTIONS EQLHASHBITSFN SXHASH-PATHNAME) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES SXHASH-MAX) (IL:FUNCTIONS SXHASH-LIST SXHASH-STRING SXHASH-BIT-VECTOR SXHASH-ROT)) (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)") (IL:FNS SXHASH-UFN EQLHASHBITSFN-UFN %SXHASH) (XCL:OPTIMIZERS SXHASH EQLHASHBITSFN) (XCL:OPTIMIZERS IL:STRINGHASHBITS IL:STRING-EQUAL-HASHBITS) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLHASH))) (IL:* IL:|;;| "External interface") (DEFUN MAKE-HASH-TABLE (&KEY (TEST 'EQL) (SIZE 65) REHASH-SIZE REHASH-THRESHOLD) (IL:* IL:|;;| "Creates and returns a hash table. See manual for details.") (IF (NOT (SYMBOLP TEST)) (COND ((%EQCODEP TEST 'EQ) (SETQ TEST 'EQ)) ((%EQCODEP TEST 'EQL) (SETQ TEST 'EQL)) ((%EQCODEP TEST 'EQUAL) (SETQ TEST 'EQUAL)))) (ECASE TEST (EQ (IL:HASHARRAY SIZE REHASH-SIZE)) (EQL (IL:HASHARRAY SIZE REHASH-SIZE 'EQLHASHBITSFN 'EQL)) (EQUAL (IL:HASHARRAY SIZE REHASH-SIZE 'SXHASH 'EQUAL)))) (DEFUN GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT) (IL:GETHASH KEY HASHTABLE DEFAULT T)) (DEFUN MAPHASH (FN HASH-TABLE) "Call function with each key/value pair in the hash-table" (IL:MAPHASH HASH-TABLE #'(LAMBDA (VALUE KEY) (FUNCALL FN KEY VALUE))) NIL) (DEFUN HASH-TABLE-COUNT (HASH-TABLE) (IL:HARRAYPROP HASH-TABLE 'IL:NUMKEYS)) (DEFUN HASH-TABLE-P (OBJECT) (IL:TYPENAMEP OBJECT 'IL:HARRAYP)) (DEFUN SXHASH (OBJECT) (IL:MISCN SXHASH OBJECT)) (XCL:DEFOPTIMIZER GETHASH (KEY HASHTABLE &OPTIONAL DEFAULT XCL:&CONTEXT CONTEXT) (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT)) (IF DEFAULT `(IL:GETHASH ,KEY ,HASHTABLE ,DEFAULT) `(IL:GETHASH ,KEY ,HASHTABLE)) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER HASH-TABLE-COUNT (HASH-TABLE) `(IL:HARRAYPROP ,HASH-TABLE 'IL:NUMKEYS)) (XCL:DEFOPTIMIZER HASH-TABLE-P (OBJECT) `(IL:TYPENAMEP ,OBJECT 'IL:HARRAYP)) (DEFSETF GETHASH PUTHASH) (IL:* IL:|;;| "Internal interface") (DEFUN EQLHASHBITSFN (OBJ) (IL:MISCN EQLHASHBITSFN OBJ)) (DEFUN SXHASH-PATHNAME (PATHNAME) (LET ((HASH (SXHASH-ROT (LOGXOR (%SXHASH (IL:%PATHNAME-HOST PATHNAME)) (%SXHASH (IL:%PATHNAME-DEVICE PATHNAME)))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-TYPE PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-VERSION PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-DIRECTORY PATHNAME))))) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (IL:%PATHNAME-NAME PATHNAME))))))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFCONSTANT SXHASH-MAX 13) (DEFMACRO SXHASH-LIST (LIST) `(DO ((LIST ,LIST (CDR LIST)) (INDEX 0 (1+ INDEX)) (HASH 0)) ((OR (NOT (CONSP LIST)) (EQ INDEX SXHASH-MAX)) HASH) (SETQ HASH (SXHASH-ROT (LOGXOR HASH (%SXHASH (CAR LIST))))))) (DEFMACRO SXHASH-STRING (STRING) (IL:* IL:\;  "Returns hash value for a general string.") `(DO ((I 0 (1+ I)) (LENGTH (MIN (LENGTH ,STRING) SXHASH-MAX)) (HASH 0)) ((EQ I LENGTH) HASH) (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.") (SETQ HASH (SXHASH-ROT (LOGXOR HASH (CHAR-INT (AREF ,STRING I))))))) (DEFMACRO SXHASH-BIT-VECTOR (BIT-VECTOR) `(DO ((I 0 (1+ I)) (LENGTH (MIN (LENGTH ,BIT-VECTOR) 16)) (HASH 0)) ((EQ I LENGTH) HASH) (SETQ HASH (+ (ASH HASH 1) (AREF ,BIT-VECTOR I))))) (DEFMACRO SXHASH-ROT (X) `(LET ((X ,X)) (DPB X (BYTE 9 7) (LDB (BYTE 7 9) X)))) ) (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)") (IL:DEFINEQ (SXHASH-UFN (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR) (IL:* IL:\; "Edited 23-Feb-89 19:45 by jds") (IL:* IL:|;;|  "This is the UFN for the CL:SXHASH MISCN sub-opcode. That MISCN is being implemented on Suns.") (%SXHASH (IL:\\GETBASEPTR IL:ARG-PTR 0)))) (EQLHASHBITSFN-UFN (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR) (IL:* IL:\; "Edited 23-Feb-89 18:10 by jds") (LET ((OBJ (IL:\\GETBASEPTR IL:ARG-PTR 0))) (TYPECASE OBJ (CHARACTER (CHAR-INT OBJ)) (INTEGER (LOGAND OBJ 65535)) (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJ) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJ))) (RATIO (LOGXOR (EQLHASHBITSFN (NUMERATOR OBJ)) (EQLHASHBITSFN (DENOMINATOR OBJ)))) (COMPLEX (LOGXOR (EQLHASHBITSFN (REALPART OBJ)) (EQLHASHBITSFN (IMAGPART OBJ)))) (T (IL:\\EQHASHINGBITS OBJ)))))) (%SXHASH (IL:LAMBDA (OBJECT) (IL:* IL:\; "Edited 23-Feb-89 19:42 by jds") (COND ((SYMBOLP OBJECT) (IL:\\EQHASHINGBITS OBJECT)) ((LISTP OBJECT) (SXHASH-LIST OBJECT)) ((NUMBERP OBJECT) (TYPECASE OBJECT (INTEGER (LOGAND OBJECT MOST-POSITIVE-FIXNUM)) (FLOAT (LOGXOR (IL:|fetch| (IL:FLOATP IL:HIWORD) IL:|of| OBJECT) (IL:|fetch| (IL:FLOATP IL:LOWORD) IL:|of| OBJECT))) (RATIO (LOGXOR (%SXHASH (NUMERATOR OBJECT)) (%SXHASH (DENOMINATOR OBJECT)))) (COMPLEX (LOGXOR (%SXHASH (REALPART OBJECT)) (%SXHASH (IMAGPART OBJECT)))))) ((STRINGP OBJECT) (SXHASH-STRING OBJECT)) ((BIT-VECTOR-P OBJECT) (SXHASH-BIT-VECTOR OBJECT)) ((PATHNAMEP OBJECT) (SXHASH-PATHNAME OBJECT)) (T (IL:\\EQHASHINGBITS OBJECT))))) ) (XCL:DEFOPTIMIZER SXHASH (OBJECT) `(IL:MISCN SXHASH ,OBJECT)) (XCL:DEFOPTIMIZER EQLHASHBITSFN (OBJECT) `(IL:MISCN EQLHASHBITSFN ,OBJECT)) (XCL:DEFOPTIMIZER IL:STRINGHASHBITS (STRING) `(IL:MISCN IL:STRINGHASHBITS ,STRING)) (XCL:DEFOPTIMIZER IL:STRING-EQUAL-HASHBITS (STRING) `(IL:MISCN IL:STRING-EQUAL-HASHBITS ,STRING)) (IL:PUTPROPS IL:CMLHASH IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLHASH IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:CMLHASH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (5446 7499 (SXHASH-UFN 5459 . 5758) (EQLHASHBITSFN-UFN 5760 . 6499) (%SXHASH 6501 . 7497))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLLIST b/sources/CMLLIST new file mode 100644 index 00000000..c1f8d565 --- /dev/null +++ b/sources/CMLLIST @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 13:26:57" IL:|{DSK}local>lde>lispcore>sources>CMLLIST.;2| 83939 IL:|changes| IL:|to:| (IL:VARS IL:CMLLISTCOMS) IL:|previous| IL:|date:| "23-May-88 20:23:20" IL:|{DSK}local>lde>lispcore>sources>CMLLIST.;1| ) ; Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLLISTCOMS) (IL:RPAQQ IL:CMLLISTCOMS ( (IL:* IL:|;;;| "CMLLIST. Common Lisp Lists Covers all of chapter 15 ") (IL:COMS (IL:* IL:|;;| "Section 15.1 Conses.") (IL:* IL:|;;|  "CAR, CDR, ..., CDDDDR (all functions on pages 262-263) are shared with Interlisp.") (IL:* IL:|;;| "CONS is shared with Interlisp.") (IL:COMS (IL:FUNCTIONS %SIMPLE-TREE-EQUAL %COMPLEX-TREE-EQUAL) (IL:FUNCTIONS TREE-EQUAL))) (IL:COMS (IL:* IL:|;;| "Section 15.2 Lists.") (IL:FUNCTIONS ENDP LIST-LENGTH) (IL:COMS (IL:FUNCTIONS NTH %SET-NTH) (IL:SETFS NTH) (XCL:OPTIMIZERS NTH) (IL:* IL:\;  "To be compatible with old compiled code") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:P (IL:MOVD '%SET-NTH 'IL:%SETNTH)))) (IL:FUNCTIONS FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST ) (IL:COMS (IL:FUNCTIONS NTHCDR) (XCL:OPTIMIZERS NTHCDR)) (IL:* IL:|;;| "LAST, LIST, and LIST* are shared with Interlisp.") (IL:FUNCTIONS MAKE-LIST) (IL:* IL:|;;| "Common Lisp APPEND is different from Interlisp APPEND because Interlisp APPEND copies its last arg while Common Lisp APPEND does not. See page 268 of the silver book.") (IL:COMS (IL:FUNCTIONS %APPEND) (IL:FNS APPEND)) (IL:FUNCTIONS COPY-LIST COPY-ALIST COPY-TREE REVAPPEND) (IL:* IL:|;;| "NCONC is shared with Interlisp.") (IL:FUNCTIONS NRECONC) (IL:* IL:|;;|  "CL:PUSH and CL:PUSHNEW are macros defined elsewhere. POP is shared with Interlisp.") (IL:FUNCTIONS BUTLAST NBUTLAST LDIFF)) (IL:COMS (IL:* IL:|;;| "Section 15.3 Alteration of List Structure.") (IL:* IL:|;;| "RPLACA, and RPLACD are shared with Interlisp.") ) (IL:COMS (IL:* IL:|;;| "Section 15.4 Substitution of Expressions.") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %SUBST-MACRO %NSUBST-MACRO)) (IL:COMS (IL:FUNCTIONS %SIMPLE-SUBST %COMPLEX-SUBST %SUBST-IF %SUBST-IF-NOT) (IL:FUNCTIONS SUBST SUBST-IF SUBST-IF-NOT)) (IL:COMS (IL:FUNCTIONS %SIMPLE-NSUBST %COMPLEX-NSUBST %NSUBST-IF %NSUBST-IF-NOT) (IL:FUNCTIONS NSUBST NSUBST-IF NSUBST-IF-NOT)) (IL:COMS (IL:FUNCTIONS %SIMPLE-SUBLIS %COMPLEX-SUBLIS) (IL:FUNCTIONS SUBLIS)) (IL:COMS (IL:FUNCTIONS %SIMPLE-NSUBLIS %COMPLEX-NSUBLIS) (IL:FUNCTIONS NSUBLIS))) (IL:COMS (IL:* IL:|;;| "Section 15.5 Usng Lists as Sets.") (IL:* IL:|;;| "Utilities") (IL:COMS (IL:FUNCTIONS %EQCODEP) (IL:* IL:|;;| "used in various optimizers") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %CONSTANT-FUNCTION %CONSTANT-EXPRESSION))) (IL:COMS (IL:FUNCTIONS %SIMPLE-MEMBER %COMPLEX-MEMBER) (IL:FUNCTIONS MEMBER MEMBER-IF MEMBER-IF-NOT) (XCL:OPTIMIZERS MEMBER) (IL:PROP IL:DOPVAL %SIMPLE-MEMBER)) (IL:* IL:|;;| "TAILP is shared with Interlisp.") (IL:FUNCTIONS ADJOIN) (XCL:OPTIMIZERS ADJOIN) (IL:FUNCTIONS UNION NUNION) (IL:FUNCTIONS INTERSECTION NINTERSECTION) (IL:FUNCTIONS SET-DIFFERENCE NSET-DIFFERENCE) (IL:FUNCTIONS SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR) (IL:FUNCTIONS SUBSETP)) (IL:COMS (IL:* IL:|;;| "Section 15.6 Association Lists.") (IL:FUNCTIONS ACONS) (IL:FUNCTIONS PAIRLIS) (IL:COMS (IL:FUNCTIONS %SIMPLE-ASSOC %COMPLEX-ASSOC) (IL:FUNCTIONS ASSOC ASSOC-IF ASSOC-IF-NOT) (XCL:OPTIMIZERS ASSOC) (IL:PROP IL:DOPVAL %SIMPLE-ASSOC)) (IL:COMS (IL:FUNCTIONS %SIMPLE-RASSOC %COMPLEX-RASSOC) (IL:FUNCTIONS RASSOC RASSOC-IF RASSOC-IF-NOT))) (IL:COMS (IL:* IL:|;;| "Section 7.8.4 Mapping") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %MIN-LIST-LENGTH %FILL-SLICE-FROM-LISTS)) (IL:COMS (IL:* IL:|;;| "Utilities ") (IL:FUNCTIONS %LIST-MAP-OPTIMIZER %LIST-COLLECT)) (IL:COMS (IL:FUNCTIONS %MAPCAR-SINGLE %MAPCAR-MULTIPLE) (IL:FUNCTIONS MAPCAR) (XCL:OPTIMIZERS MAPCAR)) (IL:COMS (IL:FUNCTIONS %MAPLIST-SINGLE %MAPLIST-MULTIPLE) (IL:FUNCTIONS MAPLIST) (XCL:OPTIMIZERS MAPLIST)) (IL:COMS (IL:FUNCTIONS %MAPC-SINGLE %MAPC-MULTIPLE) (IL:FUNCTIONS MAPC) (XCL:OPTIMIZERS MAPC)) (IL:COMS (IL:FUNCTIONS %MAPL-SINGLE %MAPL-MULTIPLE) (IL:FUNCTIONS MAPL) (XCL:OPTIMIZERS MAPL)) (IL:COMS (IL:FUNCTIONS %MAPCAN-SINGLE %MAPCAN-MULTIPLE) (IL:FUNCTIONS MAPCAN) (XCL:OPTIMIZERS MAPCAN)) (IL:COMS (IL:FUNCTIONS %MAPCON-SINGLE %MAPCON-MULTIPLE) (IL:FUNCTIONS MAPCON) (XCL:OPTIMIZERS MAPCON)) (IL:COMS (IL:* IL:|;;|  "optimizers for Interlisp mapping functions whose bytemacros are not visible to the pav-compiler") (IL:* IL:\; "Utility") (IL:FUNCTIONS %EVERY-MAP-OPTIMIZER) (XCL:OPTIMIZERS IL:MAP IL:MAPC IL:MAPLIST IL:MAPCAR IL:MAPCON IL:MAPCONC) (XCL:OPTIMIZERS IL:SOME IL:EVERY IL:NOTANY IL:NOTEVERY IL:SUBSET))) (IL:FUNCTIONS XCL:WITH-COLLECTION) (IL:COMS (IL:* IL:|;;| "some people apparantly still use memq") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:MOVD 'IL:FMEMB 'IL:MEMQ)))) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PROP IL:FILETYPE IL:CMLLIST) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:CMLLIST) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA APPEND))))) (IL:* IL:|;;;| "CMLLIST. Common Lisp Lists Covers all of chapter 15 ") (IL:* IL:|;;| "Section 15.1 Conses.") (IL:* IL:|;;| "CAR, CDR, ..., CDDDDR (all functions on pages 262-263) are shared with Interlisp.") (IL:* IL:|;;| "CONS is shared with Interlisp.") (DEFUN %SIMPLE-TREE-EQUAL (X Y) (IF (AND (CONSP X) (CONSP Y)) (AND (%SIMPLE-TREE-EQUAL (CAR X) (CAR Y)) (%SIMPLE-TREE-EQUAL (CDR X) (CDR Y))) (EQL X Y))) (DEFUN %COMPLEX-TREE-EQUAL (X Y TEST TEST-NOT-P) (COND ((CONSP X) (AND (CONSP Y) (%COMPLEX-TREE-EQUAL (CAR X) (CAR Y) TEST TEST-NOT-P) (%COMPLEX-TREE-EQUAL (CDR X) (CDR Y) TEST TEST-NOT-P))) ((CONSP Y) NIL) (T (IF TEST-NOT-P (NOT (FUNCALL TEST X Y)) (FUNCALL TEST X Y))))) (DEFUN TREE-EQUAL (X Y &KEY TEST TEST-NOT) (IF (AND TEST TEST-NOT) (ERROR "Both test and test-not supplied") (IF (OR TEST TEST-NOT) (%COMPLEX-TREE-EQUAL X Y (OR TEST TEST-NOT) TEST-NOT) (%SIMPLE-TREE-EQUAL X Y)))) (IL:* IL:|;;| "Section 15.2 Lists.") (DEFUN ENDP (OBJECT) (COND ((CONSP OBJECT) NIL) ((NULL OBJECT) T) ((ERROR "Not a list: ~S" OBJECT)))) (DEFUN LIST-LENGTH (LIST) (IL:* IL:|;;| "Returns the length of the given LIST or NIL if the LIST is circular.") (LET ((N 0) (FAST-POINTER LIST) (SLOW-POINTER LIST)) (LOOP (COND ((NULL FAST-POINTER) (RETURN N)) ((NULL (CDR FAST-POINTER)) (RETURN (+ N 1))) ((AND (EQ FAST-POINTER SLOW-POINTER) (> N 0)) (RETURN NIL))) (SETQ N (+ N 2)) (SETQ FAST-POINTER (CDDR FAST-POINTER)) (SETQ SLOW-POINTER (CDR SLOW-POINTER))))) (DEFUN NTH (N LIST) (CAR (NTHCDR N LIST))) (DEFUN %SET-NTH (N LIST NEW-VALUE) (IF (< N 0) (ERROR "Illegal index: ~S" N) (DO ((CNT N (1- CNT)) (TAIL LIST)) ((EQL CNT 0) (RPLACA TAIL NEW-VALUE) NEW-VALUE) (SETQ TAIL (CDR TAIL)) (IF (NULL TAIL) (ERROR "Index out of bounds: ~S" N))))) (DEFSETF NTH %SET-NTH) (XCL:DEFOPTIMIZER NTH (N-ARG LIST-ARG) (IF (AND (TYPEP N-ARG 'FIXNUM) (<= 0 N-ARG 10)) (IL:* IL:|;;|  "The optimizer for NTHCDR will take care of the rest of this...") `(CAR (NTHCDR ,N-ARG ,LIST-ARG)) 'COMPILER:PASS)) (IL:* IL:\; "To be compatible with old compiled code") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:MOVD '%SET-NTH 'IL:%SETNTH) ) (XCL:DEFINLINE FIRST (LIST) (CAR LIST)) (XCL:DEFINLINE SECOND (LIST) (CADR LIST)) (XCL:DEFINLINE THIRD (LIST) (CADDR LIST)) (XCL:DEFINLINE FOURTH (LIST) (CADDDR LIST)) (XCL:DEFINLINE FIFTH (LIST) (CAR (CDDDDR LIST))) (XCL:DEFINLINE SIXTH (LIST) (CADR (CDDDDR LIST))) (XCL:DEFINLINE SEVENTH (LIST) (CADDR (CDDDDR LIST))) (XCL:DEFINLINE EIGHTH (LIST) (CADDDR (CDDDDR LIST))) (XCL:DEFINLINE NINTH (LIST) (CAR (CDDDDR (CDDDDR LIST)))) (XCL:DEFINLINE TENTH (LIST) (CADR (CDDDDR (CDDDDR LIST)))) (XCL:DEFINLINE REST (LIST) (CDR LIST)) (DEFUN NTHCDR (N LIST) (IF (< N 0) (ERROR "Illegal index: ~S" N) (LET ((TAIL LIST)) (DOTIMES (I N TAIL) (SETQ TAIL (CDR TAIL)))))) (XCL:DEFOPTIMIZER NTHCDR (N-ARG LIST-ARG) (IF (AND (TYPEP N-ARG 'FIXNUM) (<= 0 N-ARG 10)) (LET ((CDR-FORM LIST-ARG)) (DOTIMES (I N-ARG CDR-FORM) (SETQ CDR-FORM (LIST 'CDR CDR-FORM)))) 'COMPILER:PASS)) (IL:* IL:|;;| "LAST, LIST, and LIST* are shared with Interlisp.") (DEFUN MAKE-LIST (SIZE &KEY INITIAL-ELEMENT) (IF (< SIZE 0) (ERROR "Illegal size: ~S" SIZE) (LET ((RESULT NIL)) (DOTIMES (I SIZE RESULT) (SETQ RESULT (CONS INITIAL-ELEMENT RESULT)))))) (IL:* IL:|;;| "Common Lisp APPEND is different from Interlisp APPEND because Interlisp APPEND copies its last arg while Common Lisp APPEND does not. See page 268 of the silver book." ) (DEFUN %APPEND (LIST1 LIST2) (IF (ATOM LIST1) LIST2 (DO* ((RESULT (LIST (CAR LIST1))) (LIST1-TAIL (CDR LIST1) (CDR LIST1-TAIL)) (RESULT-TAIL RESULT (CDR RESULT-TAIL))) ((ATOM LIST1-TAIL) (RPLACD RESULT-TAIL LIST2) RESULT) (RPLACD RESULT-TAIL (LIST (CAR LIST1-TAIL)))))) (IL:DEFINEQ (APPEND (IL:LAMBDA ARGS (IL:* IL:\; "Edited 12-Jan-87 12:22 by jop") (IL:* IL:|;;| "The result is a list that is the concatenation of the arguments. The arguments are not destroyed. Note that APPEND copies the top-level list structure of each of its arguments except the last.") (CASE ARGS (0 NIL) (1 (IL:ARG ARGS 1)) (OTHERWISE (DO ((RESULT (IL:ARG ARGS ARGS)) (I (1- ARGS) (1- I))) ((EQL I 0) RESULT) (SETQ RESULT (%APPEND (IL:ARG ARGS I) RESULT))))))) ) (DEFUN COPY-LIST (LIST) (IF (CONSP LIST) (DO* ((RESULT (LIST (CAR LIST))) (RESULT-TAIL RESULT (CDR RESULT-TAIL)) (LIST-TAIL (CDR LIST) (CDR LIST-TAIL))) ((NOT (CONSP LIST-TAIL)) (IF LIST-TAIL (RPLACD RESULT-TAIL LIST-TAIL)) RESULT) (RPLACD RESULT-TAIL (LIST (CAR LIST-TAIL)))) LIST)) (DEFUN COPY-ALIST (LIST) (IF (CONSP LIST) (DO* ((RESULT (LIST (IF (CONSP (CAR LIST)) (CONS (CAAR LIST) (CDAR LIST)) (CAR LIST)))) (LIST-TAIL (CDR LIST) (CDR LIST-TAIL)) (RESULT-TAIL RESULT (CDR RESULT-TAIL)) LIST-ELEMENT) ((NOT (CONSP LIST-TAIL)) (IL:* IL:\;  "Non-null terminated alist done here. ") (IF LIST-TAIL (RPLACD RESULT-TAIL LIST-TAIL)) RESULT) (SETQ LIST-ELEMENT (CAR LIST-TAIL)) (RPLACD RESULT-TAIL (LIST (IF (CONSP LIST-ELEMENT) (CONS (CAR LIST-ELEMENT) (CDR LIST-ELEMENT)) LIST-ELEMENT)))) LIST)) (DEFUN COPY-TREE (OBJECT) (IF (CONSP OBJECT) (CONS (COPY-TREE (CAR OBJECT)) (COPY-TREE (CDR OBJECT))) OBJECT)) (DEFUN REVAPPEND (X Y) (IL:* IL:|;;| "Returns (APPEND (REVERSE X) Y) ") (IF (CONSP X) (DO ((TAIL X (CDR TAIL)) (RESULT Y (CONS (CAR TAIL) RESULT))) ((NULL TAIL) RESULT)) Y)) (IL:* IL:|;;| "NCONC is shared with Interlisp.") (DEFUN NRECONC (X Y) (IF (CONSP X) (LET ((TAIL X) (RESULT Y) NEXT-CELL) (LOOP (IF (NULL TAIL) (RETURN RESULT)) (SETQ TAIL (CDR (SETQ NEXT-CELL TAIL))) (SETQ RESULT (RPLACD NEXT-CELL RESULT)))) Y)) (IL:* IL:|;;| "CL:PUSH and CL:PUSHNEW are macros defined elsewhere. POP is shared with Interlisp.") (DEFUN BUTLAST (LIST &OPTIONAL (N 1)) (IF (< N 0) (ERROR "Illegal n: ~S" N)) (IL:* IL:\;  "Use IL:length because cmllist is in the init but cmlseq isn't") (LET ((LENGTH (IL:LENGTH LIST))) (IF (<= LENGTH N) NIL (DO* ((RESULT (LIST (CAR LIST))) (LIST-TAIL (CDR LIST) (CDR LIST-TAIL)) (RESULT-TAIL RESULT (CDR RESULT-TAIL)) (CNT (1- LENGTH) (1- CNT))) ((EQL CNT N) RESULT) (RPLACD RESULT-TAIL (LIST (CAR LIST-TAIL))))))) (DEFUN NBUTLAST (LIST &OPTIONAL (N 1)) (IF (< N 0) (ERROR "Illegal n: ~s" N)) (IL:* IL:\;  "Use IL:length because cmllist is in the init but cnlseq isn't") (LET* ((LENGTH (IL:LENGTH LIST)) (INDEX (- LENGTH N 1))) (COND ((< INDEX 0) NIL) (T (RPLACD (NTHCDR INDEX LIST) NIL) LIST)))) (DEFUN LDIFF (LIST SUBLIST) (IF (EQ LIST SUBLIST) NIL (DO* ((RESULT (LIST (CAR LIST))) (LIST-TAIL (CDR LIST) (CDR LIST-TAIL)) (RESULT-TAIL RESULT (CDR RESULT-TAIL))) ((OR (NULL LIST-TAIL) (EQ LIST-TAIL SUBLIST)) RESULT) (RPLACD RESULT-TAIL (LIST (CAR LIST-TAIL)))))) (IL:* IL:|;;| "Section 15.3 Alteration of List Structure.") (IL:* IL:|;;| "RPLACA, and RPLACD are shared with Interlisp.") (IL:* IL:|;;| "Section 15.4 Substitution of Expressions.") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %SUBST-MACRO (TEST-FORM CAR-RECURSION-FORM CDR-RECURSION-FORM) `(COND (,TEST-FORM NEW) ((ATOM TREE) TREE) (T (LET ((NEW-CAR ,CAR-RECURSION-FORM) (NEW-CDR ,CDR-RECURSION-FORM)) (IF (AND (EQ (CAR TREE) NEW-CAR) (EQ (CDR TREE) NEW-CDR)) TREE (CONS NEW-CAR NEW-CDR)))))) (DEFMACRO %NSUBST-MACRO (TEST-FORM RECURSION-FORM) `(IF ,(SUBST 'TREE 'TREE-FORM TEST-FORM) NEW (LET ((TAIL TREE)) (LOOP (IF (ATOM TAIL) (RETURN TREE)) (IF ,(SUBST '(CAR TAIL) 'TREE-FORM TEST-FORM) (RPLACA TAIL NEW) ,(SUBST '(CAR TAIL) 'TREE-FORM RECURSION-FORM)) (WHEN ,(SUBST '(CDR TAIL) 'TREE-FORM TEST-FORM) (RPLACD TAIL NEW) (IL:* IL:\;  "If we replace the cdr, then we need not recurse any further") (RETURN TREE)) (SETQ TAIL (CDR TAIL)))))) ) (DEFUN %SIMPLE-SUBST (NEW OLD TREE) (%SUBST-MACRO (EQL OLD TREE) (%SIMPLE-SUBST NEW OLD (CAR TREE)) (%SIMPLE-SUBST NEW OLD (CDR TREE)))) (DEFUN %COMPLEX-SUBST (NEW OLD TREE TEST TEST-NOT-P KEY) (%SUBST-MACRO (LET ((TEST-RESULT (FUNCALL TEST OLD (IF KEY (FUNCALL KEY TREE) TREE)))) (IF TEST-NOT-P (NOT TEST-RESULT) TEST-RESULT)) (%COMPLEX-SUBST NEW OLD (CAR TREE) TEST TEST-NOT-P KEY) (%COMPLEX-SUBST NEW OLD (CDR TREE) TEST TEST-NOT-P KEY))) (DEFUN %SUBST-IF (NEW TEST TREE KEY) (%SUBST-MACRO (FUNCALL TEST (IF KEY (FUNCALL KEY TREE) TREE)) (%SUBST-IF NEW TEST (CAR TREE) KEY) (%SUBST-IF NEW TEST (CDR TREE) KEY))) (DEFUN %SUBST-IF-NOT (NEW TEST TREE KEY) (%SUBST-MACRO (NOT (FUNCALL TEST (IF KEY (FUNCALL KEY TREE) TREE))) (%SUBST-IF-NOT NEW TEST (CAR TREE) KEY) (%SUBST-IF-NOT NEW TEST (CDR TREE) KEY))) (DEFUN SUBST (NEW OLD TREE &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-SUBST NEW OLD TREE (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-SUBST NEW OLD TREE))) (DEFUN SUBST-IF (NEW TEST TREE &KEY KEY) (%SUBST-IF NEW TEST TREE KEY)) (DEFUN SUBST-IF-NOT (NEW TEST TREE &KEY KEY) (%SUBST-IF-NOT NEW TEST TREE KEY)) (DEFUN %SIMPLE-NSUBST (NEW OLD TREE) (%NSUBST-MACRO (EQL OLD TREE-FORM) (%SIMPLE-NSUBST NEW OLD TREE-FORM))) (DEFUN %COMPLEX-NSUBST (NEW OLD TREE TEST TEST-NOT-P KEY) (LET (TEST-RESULT) (%NSUBST-MACRO (PROGN (SETQ TEST-RESULT (FUNCALL TEST OLD (IF KEY (FUNCALL KEY TREE-FORM) TREE-FORM))) (IF TEST-NOT-P (NOT TEST-RESULT) TEST-RESULT)) (%COMPLEX-NSUBST NEW OLD TREE-FORM TEST TEST-NOT-P KEY)))) (DEFUN %NSUBST-IF (NEW TEST TREE KEY) (%NSUBST-MACRO (FUNCALL TEST (IF KEY (FUNCALL KEY TREE-FORM) TREE-FORM)) (%NSUBST-IF NEW TEST TREE-FORM KEY))) (DEFUN %NSUBST-IF-NOT (NEW TEST TREE KEY) (%NSUBST-MACRO (NOT (FUNCALL TEST (IF KEY (FUNCALL KEY TREE-FORM) TREE-FORM))) (%NSUBST-IF-NOT NEW TEST TREE-FORM KEY))) (DEFUN NSUBST (NEW OLD TREE &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-NSUBST NEW OLD TREE (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-NSUBST NEW OLD TREE))) (DEFUN NSUBST-IF (NEW TEST TREE &KEY KEY) (%NSUBST-IF NEW TEST TREE KEY)) (DEFUN NSUBST-IF-NOT (NEW TEST TREE &KEY KEY) (%NSUBST-IF-NOT NEW TEST TREE KEY)) (DEFUN %SIMPLE-SUBLIS (A-LIST TREE) (LET ((PAIR (%SIMPLE-ASSOC TREE A-LIST))) (COND (PAIR (CDR PAIR)) ((ATOM TREE) TREE) (T (LET ((NEW-CAR (%SIMPLE-SUBLIS A-LIST (CAR TREE))) (NEW-CDR (%SIMPLE-SUBLIS A-LIST (CDR TREE)))) (IF (AND (EQ (CAR TREE) NEW-CAR) (EQ (CDR TREE) NEW-CDR)) TREE (CONS NEW-CAR NEW-CDR))))))) (DEFUN %COMPLEX-SUBLIS (A-LIST TREE TEST TEST-NOT-P KEY) (LET ((PAIR (%COMPLEX-ASSOC (IF KEY (FUNCALL KEY TREE) TREE) A-LIST TEST TEST-NOT-P NIL))) (COND (PAIR (CDR PAIR)) ((ATOM TREE) TREE) (T (LET ((NEW-CAR (%COMPLEX-SUBLIS A-LIST (CAR TREE) TEST TEST-NOT-P KEY)) (NEW-CDR (%COMPLEX-SUBLIS A-LIST (CDR TREE) TEST TEST-NOT-P KEY))) (IF (AND (EQ (CAR TREE) NEW-CAR) (EQ (CDR TREE) NEW-CDR)) TREE (CONS NEW-CAR NEW-CDR))))))) (DEFUN SUBLIS (A-LIST TREE &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-SUBLIS A-LIST TREE (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-SUBLIS A-LIST TREE))) (DEFUN %SIMPLE-NSUBLIS (A-LIST TREE) (LET ((PAIR NIL)) (IF (SETQ PAIR (%SIMPLE-ASSOC TREE A-LIST)) (CDR PAIR) (LET ((TAIL TREE)) (LOOP (IF (ATOM TAIL) (RETURN TREE)) (IF (SETQ PAIR (%SIMPLE-ASSOC (CAR TAIL) A-LIST)) (RPLACA TAIL (CDR PAIR)) (%SIMPLE-NSUBLIS A-LIST (CAR TAIL))) (WHEN (SETQ PAIR (%SIMPLE-ASSOC (CDR TAIL) A-LIST)) (RPLACD TAIL (CDR PAIR)) (RETURN TREE)) (SETQ TAIL (CDR TAIL))))))) (DEFUN %COMPLEX-NSUBLIS (A-LIST TREE TEST TEST-NOT-P KEY) (LET ((PAIR NIL)) (IF (SETQ PAIR (%COMPLEX-ASSOC (IF KEY (FUNCALL KEY TREE) TREE) A-LIST TEST TEST-NOT-P NIL)) (CDR PAIR) (LET ((TAIL TREE)) (LOOP (IF (ATOM TAIL) (RETURN TREE)) (IF (SETQ PAIR (%COMPLEX-ASSOC (IF KEY (FUNCALL KEY (CAR TAIL)) (CAR TAIL)) A-LIST TEST TEST-NOT-P NIL)) (RPLACA TAIL (CDR PAIR)) (%COMPLEX-NSUBLIS A-LIST (CAR TAIL) TEST TEST-NOT-P KEY)) (WHEN (SETQ PAIR (%COMPLEX-ASSOC (IF KEY (FUNCALL KEY (CDR TAIL)) (CDR TAIL)) A-LIST TEST TEST-NOT-P NIL)) (RPLACD TAIL (CDR PAIR)) (RETURN TREE)) (SETQ TAIL (CDR TAIL))))))) (DEFUN NSUBLIS (A-LIST TREE &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-NSUBLIS A-LIST TREE (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-NSUBLIS A-LIST TREE))) (IL:* IL:|;;| "Section 15.5 Usng Lists as Sets.") (IL:* IL:|;;| "Utilities") (DEFUN %EQCODEP (TESTFN KNOWNFN) (IL:* IL:|;;| "KNOWNFN is a symbol (like 'eq), and TESTFN is either a symbol or a compiled closure object. Tests if TESTFN represents the \"same\" function as KNOWNFN.") (OR (EQ TESTFN KNOWNFN) (AND (TYPEP TESTFN 'IL:COMPILED-CLOSURE) (TYPEP KNOWNFN 'SYMBOL) (EQ (IL:|fetch| (IL:COMPILED-CLOSURE IL:FNHEADER) IL:|of| TESTFN) (IL:|fetch| (SYMBOL IL:DEFPOINTER) IL:|of| KNOWNFN))))) (IL:* IL:|;;| "used in various optimizers") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %CONSTANT-FUNCTION (FN-ARG) `(OR (CAR (IL:CONSTANTEXPRESSIONP ,FN-ARG)) (AND (CONSP ,FN-ARG) (EQ (CAR ,FN-ARG) 'FUNCTION) (CADR ,FN-ARG)))) (DEFMACRO %CONSTANT-EXPRESSION (EXPR) `(CAR (IL:CONSTANTEXPRESSIONP ,EXPR))) ) (DEFUN %SIMPLE-MEMBER (ITEM LIST) (IF (OR (SYMBOLP ITEM) (TYPEP ITEM 'FIXNUM) (CHARACTERP ITEM)) (IL:* IL:\; "Can use the eq opcode") (IL:FMEMB ITEM LIST) (DO ((TAIL LIST (CDR TAIL))) ((OR (NULL TAIL) (EQL ITEM (CAR TAIL))) TAIL)))) (DEFUN %COMPLEX-MEMBER (ITEM LIST TEST TEST-NOT-P KEY) (IF TEST-NOT-P (IF KEY (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (NOT (FUNCALL TEST ITEM (FUNCALL KEY (CAR TAIL))))) TAIL)) (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (NOT (FUNCALL TEST ITEM (CAR TAIL)))) TAIL))) (IF KEY (COND ((%EQCODEP TEST 'EQL) (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (EQL ITEM (FUNCALL KEY (CAR TAIL)))) TAIL))) ((%EQCODEP TEST 'EQ) (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (EQ ITEM (FUNCALL KEY (CAR TAIL)))) TAIL))) ((%EQCODEP TEST 'EQUAL) (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (EQUAL ITEM (FUNCALL KEY (CAR TAIL)))) TAIL))) (T (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (FUNCALL TEST ITEM (FUNCALL KEY (CAR TAIL)))) TAIL)))) (COND ((%EQCODEP TEST 'EQUAL) (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (EQUAL ITEM (CAR TAIL))) TAIL))) ((%EQCODEP TEST 'EQ) (IL:FMEMB ITEM LIST)) ((%EQCODEP TEST 'EQL) (%SIMPLE-MEMBER ITEM LIST)) (T (DO ((TAIL LIST (CDR TAIL)) TEST-RESULT) ((OR (NULL TAIL) (FUNCALL TEST ITEM (CAR TAIL))) TAIL))))))) (DEFUN MEMBER (ITEM LIST &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-MEMBER ITEM LIST (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-MEMBER ITEM LIST))) (DEFUN MEMBER-IF (PREDICATE LIST &KEY KEY) (DO ((TAIL LIST (CDR TAIL)) ITEM) ((OR (NULL TAIL) (PROGN (SETQ ITEM (IF KEY (FUNCALL KEY (CAR TAIL)) (CAR TAIL))) (FUNCALL PREDICATE ITEM))) TAIL))) (DEFUN MEMBER-IF-NOT (PREDICATE LIST &KEY KEY) (DO ((TAIL LIST (CDR TAIL)) ITEM) ((OR (NULL TAIL) (PROGN (SETQ ITEM (IF KEY (FUNCALL KEY (CAR TAIL)) (CAR TAIL))) (NOT (FUNCALL PREDICATE ITEM)))) TAIL))) (XCL:DEFOPTIMIZER MEMBER (ITEM LIST &KEY (TEST ''EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IL:* IL:|;;| "optimize the simple cases") (LET ((CONSTANT-ITEM (%CONSTANT-EXPRESSION ITEM)) (CONSTANT-LIST (%CONSTANT-EXPRESSION LIST)) (CONSTANT-TEST (%CONSTANT-FUNCTION TEST))) (COND ((OR (AND (EQ CONSTANT-TEST 'EQ) (NULL TEST-NOT-P) (NULL KEY-P)) (AND (EQ CONSTANT-TEST 'EQL) (NULL TEST-NOT-P) (NULL KEY-P) (OR (AND CONSTANT-ITEM (TYPEP CONSTANT-ITEM 'SYMBOL)) (AND CONSTANT-LIST (CONSP CONSTANT-LIST) (EVERY #'(LAMBDA (X) (TYPEP X 'SYMBOL)) CONSTANT-LIST))))) (IL:* IL:|;;| "Use the eq opcode") `(IL:FMEMB ,ITEM ,LIST)) ((AND (EQ CONSTANT-TEST 'EQL) (NULL TEST-NOT-P) (NULL KEY-P)) `(%SIMPLE-MEMBER ,ITEM ,LIST)) (T 'COMPILER:PASS)))) (IL:PUTPROPS %SIMPLE-MEMBER IL:DOPVAL (2 IL:CMLMEMBER)) (IL:* IL:|;;| "TAILP is shared with Interlisp.") (DEFUN ADJOIN (ITEM LIST &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IL:* IL:|;;| "Add item to list unless it is already a member") (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (NOT (IF (OR TEST-P TEST-NOT-P KEY-P) (IL:* IL:\;  "Adjoin applies key to item (pg. 276)") (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ITEM) ITEM) LIST (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-MEMBER ITEM LIST))) (CONS ITEM LIST) LIST)) (XCL:DEFOPTIMIZER ADJOIN (ITEM LIST &KEY (TEST ''EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (LET ((CONSTANT-TEST (%CONSTANT-FUNCTION TEST))) (IL:* IL:|;;|  "take advantage of microcode support for list membership tests") (IL:* IL:|;;|  "note: PUSHNEW expands to ADJOIN & is the main reason we care that ADJOIN is fast.") (IF (AND (OR (EQ CONSTANT-TEST 'EQ) (EQ CONSTANT-TEST 'EQL)) (NOT TEST-NOT-P) (NOT KEY-P)) (LET ((ITEMVAR (GENTEMP)) (LISTVAR (GENTEMP))) `(LET ((,ITEMVAR ,ITEM) (,LISTVAR ,LIST)) (IF (,(CASE CONSTANT-TEST (EQ 'IL:FMEMB) (EQL '%SIMPLE-MEMBER)) ,ITEMVAR ,LISTVAR) ,LISTVAR (CONS ,ITEMVAR ,LISTVAR)))) 'COMPILER:PASS))) (DEFUN UNION (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IL:* IL:|;;| "Returns the union of LIST1 and LIST2. ") (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((LIST1-EXTRAS NIL) (LIST1-EXTRAS-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (LET ((LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DOLIST (ELEMENT LIST1) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT LIST1-EXTRAS LIST1-EXTRAS-TAIL (LIST ELEMENT))))) (DOLIST (ELEMENT LIST1) (IF (NOT (%SIMPLE-MEMBER ELEMENT LIST2)) (%LIST-COLLECT LIST1-EXTRAS LIST1-EXTRAS-TAIL (LIST ELEMENT))))) (COND (LIST1-EXTRAS (RPLACD LIST1-EXTRAS-TAIL LIST2) LIST1-EXTRAS) (T LIST2)))) (DEFUN NUNION (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((LIST1-EXTRAS NIL) (LIST1-EXTRAS-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL)) (LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) ((NULL LIST1-TAIL)) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY (CAR LIST1-TAIL)) (CAR LIST1-TAIL)) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT LIST1-EXTRAS LIST1-EXTRAS-TAIL LIST1-TAIL))) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL))) ((NULL LIST1-TAIL)) (IF (NOT (%SIMPLE-MEMBER (CAR LIST1-TAIL) LIST2)) (%LIST-COLLECT LIST1-EXTRAS LIST1-EXTRAS-TAIL LIST1-TAIL)))) (COND (LIST1-EXTRAS (RPLACD LIST1-EXTRAS-TAIL LIST2) LIST1-EXTRAS) (T LIST2)))) (DEFUN INTERSECTION (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (LET ((LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DOLIST (ELEMENT LIST1) (IF (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST2 LOOP-TEST TEST-NOT-P KEY) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))) (DOLIST (ELEMENT LIST1) (IF (%SIMPLE-MEMBER ELEMENT LIST2) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))) RESULT)) (DEFUN NINTERSECTION (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL)) (LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST)) TEMP) ((NULL LIST1-TAIL)) (IF (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY (CAR LIST1-TAIL)) (CAR LIST1-TAIL)) LIST2 LOOP-TEST TEST-NOT-P KEY) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL))) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL)) TEMP) ((NULL LIST1-TAIL)) (IF (%SIMPLE-MEMBER (CAR LIST1-TAIL) LIST2) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL)))) (COND (RESULT (RPLACD RESULT-TAIL NIL) RESULT) (T RESULT)))) (DEFUN SET-DIFFERENCE (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (LET ((LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DOLIST (ELEMENT LIST1) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))) (DOLIST (ELEMENT LIST1) (IF (NOT (%SIMPLE-MEMBER ELEMENT LIST2)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))) RESULT)) (DEFUN NSET-DIFFERENCE (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL)) (LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) ((NULL LIST1-TAIL)) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY (CAR LIST1-TAIL)) (CAR LIST1-TAIL)) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL))) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL))) ((NULL LIST1-TAIL)) (IF (NOT (%SIMPLE-MEMBER (CAR LIST1-TAIL) LIST2)) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL)))) (COND (RESULT (RPLACD RESULT-TAIL NIL) RESULT) (T RESULT)))) (DEFUN SET-EXCLUSIVE-OR (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (COND ((OR TEST-P TEST-NOT-P KEY-P) (LET ((LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DOLIST (ELEMENT LIST1) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT)))) (DOLIST (ELEMENT LIST2) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST1 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT)))) RESULT)) (T (DOLIST (ELEMENT LIST1) (IF (NOT (%SIMPLE-MEMBER ELEMENT LIST2)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT)))) (DOLIST (ELEMENT LIST2) (IF (NOT (%SIMPLE-MEMBER ELEMENT LIST1)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT)))))) RESULT)) (DEFUN NSET-EXCLUSIVE-OR (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (LET ((RESULT NIL) (RESULT-TAIL NIL)) (IF (OR TEST-P TEST-NOT-P KEY-P) (LET ((LIST1-HANDLE NIL) (LIST1-PREVIOUS NIL) (LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL))) ((NULL LIST1-TAIL)) (COND ((NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY (CAR LIST1-TAIL)) (CAR LIST1-TAIL)) LIST2 LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL) (IL:* IL:\; "splice cell out of list1") (IF LIST1-PREVIOUS (RPLACD LIST1-PREVIOUS (CDR LIST1-TAIL)))) (T (IF (NULL LIST1-HANDLE) (SETQ LIST1-HANDLE (SETQ LIST1-PREVIOUS LIST1-TAIL)) (SETQ LIST1-PREVIOUS (CDR LIST1-PREVIOUS)))))) (DO ((LIST2-TAIL LIST2 (CDR LIST2-TAIL))) ((NULL LIST2-TAIL)) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY (CAR LIST2-TAIL)) (CAR LIST2-TAIL)) LIST1-HANDLE LOOP-TEST TEST-NOT-P KEY)) (%LIST-COLLECT RESULT RESULT-TAIL LIST2-TAIL)))) (LET ((LIST1-HANDLE NIL) (LIST1-PREVIOUS NIL)) (DO ((LIST1-TAIL LIST1 (CDR LIST1-TAIL))) ((NULL LIST1-TAIL)) (COND ((NOT (%SIMPLE-MEMBER (CAR LIST1-TAIL) LIST2)) (%LIST-COLLECT RESULT RESULT-TAIL LIST1-TAIL) (IL:* IL:\; "splice cell out of list1") (IF LIST1-PREVIOUS (RPLACD LIST1-PREVIOUS (CDR LIST1-TAIL)))) (T (IF (NULL LIST1-HANDLE) (SETQ LIST1-HANDLE (SETQ LIST1-PREVIOUS LIST1-TAIL)) (SETQ LIST1-PREVIOUS (CDR LIST1-PREVIOUS)))))) (DO ((LIST2-TAIL LIST2 (CDR LIST2-TAIL))) ((NULL LIST2-TAIL)) (IF (NOT (%SIMPLE-MEMBER (CAR LIST2-TAIL) LIST1-HANDLE)) (%LIST-COLLECT RESULT RESULT-TAIL LIST2-TAIL))))) (COND (RESULT (RPLACD RESULT-TAIL NIL) RESULT) (T RESULT)))) (DEFUN SUBSETP (LIST1 LIST2 &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (LET ((LOOP-TEST (IF TEST-NOT-P TEST-NOT TEST))) (DOLIST (ELEMENT LIST1 T) (IF (NOT (%COMPLEX-MEMBER (IF KEY (FUNCALL KEY ELEMENT) ELEMENT) LIST2 LOOP-TEST TEST-NOT-P KEY)) (RETURN NIL)))) (DOLIST (ELEMENT LIST1 T) (IF (NOT (%SIMPLE-MEMBER ELEMENT LIST2)) (RETURN NIL))))) (IL:* IL:|;;| "Section 15.6 Association Lists.") (XCL:DEFINLINE ACONS (KEY DATUM A-LIST) (CONS (CONS KEY DATUM) A-LIST)) (DEFUN PAIRLIS (KEYS DATA &OPTIONAL A-LIST) (IL:* IL:|;;| "Construct an association list from KEYS and DATA (adding to ALIST) ") (COND ((AND (ENDP KEYS) (ENDP DATA)) A-LIST) ((NOT (EQL (IL:LENGTH KEYS) (IL:LENGTH DATA))) (IL:* IL:\;  "Use IL:Length since cmllist is in the init but cmlseq is not") (ERROR "Lists of unequal length: ~S and ~S" KEYS DATA)) (T (DO* ((RESULT (LIST (CONS (CAR KEYS) (CAR DATA)))) (LAST-CONS RESULT) (KEYS-TAIL (CDR KEYS) (CDR KEYS-TAIL)) (DATA-TAIL (CDR DATA) (CDR DATA-TAIL))) ((NULL KEYS-TAIL) (RPLACD LAST-CONS A-LIST) RESULT) (SETQ LAST-CONS (CDR (RPLACD LAST-CONS (LIST (CONS (CAR KEYS-TAIL) (CAR DATA-TAIL)))))))))) (DEFUN %SIMPLE-ASSOC (ITEM A-LIST) (IF (OR (SYMBOLP ITEM) (TYPEP ITEM 'FIXNUM) (CHARACTERP ITEM)) (IL:* IL:\; "Can use the eq opcode") (IL:ASSOC ITEM A-LIST) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQL ITEM (CAR PAIR))) (RETURN PAIR))))) (DEFUN %COMPLEX-ASSOC (ITEM A-LIST TEST TEST-NOT-P KEY) (IF TEST-NOT-P (IF KEY (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL TEST ITEM (FUNCALL KEY (CAR PAIR))))) (RETURN PAIR))) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL TEST ITEM (CAR PAIR)))) (RETURN PAIR)))) (IF KEY (COND ((%EQCODEP TEST 'EQL) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQL ITEM (FUNCALL KEY (CAR PAIR)))) (RETURN PAIR)))) ((%EQCODEP TEST 'EQ) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQ ITEM (FUNCALL KEY (CAR PAIR)))) (RETURN PAIR)))) ((%EQCODEP TEST 'EQUAL) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQUAL ITEM (FUNCALL KEY (CAR PAIR)))) (RETURN PAIR)))) (T (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL TEST ITEM (FUNCALL KEY (CAR PAIR)))) (RETURN PAIR))))) (COND ((%EQCODEP TEST 'EQUAL) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQUAL ITEM (CAR PAIR))) (RETURN PAIR)))) ((%EQCODEP TEST 'EQ) (IL:ASSOC ITEM A-LIST)) ((%EQCODEP TEST 'EQL) (%SIMPLE-ASSOC ITEM A-LIST)) (T (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL TEST ITEM (CAR PAIR))) (RETURN PAIR)))))))) (DEFUN ASSOC (ITEM A-LIST &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-ASSOC ITEM A-LIST (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-ASSOC ITEM A-LIST))) (DEFUN ASSOC-IF (PREDICATE A-LIST &KEY (KEY NIL KEY-P)) (IF KEY-P (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL PREDICATE (FUNCALL KEY (CAR PAIR)))) (RETURN PAIR))) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL PREDICATE (CAR PAIR))) (RETURN PAIR))))) (DEFUN ASSOC-IF-NOT (PREDICATE A-LIST &KEY (KEY NIL KEY-P)) (IF KEY-P (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL PREDICATE (FUNCALL KEY (CAR PAIR))))) (RETURN PAIR))) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL PREDICATE (CAR PAIR)))) (RETURN PAIR))))) (XCL:DEFOPTIMIZER ASSOC (ITEM A-LIST &KEY (TEST ''EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IL:* IL:|;;| "optimize simple cases") (LET ((CONSTANT-ITEM (%CONSTANT-EXPRESSION ITEM)) (CONSTANT-A-LIST (%CONSTANT-EXPRESSION A-LIST)) (CONSTANT-TEST (%CONSTANT-FUNCTION TEST))) (COND ((OR (AND (EQ CONSTANT-TEST 'EQ) (NULL TEST-NOT-P) (NULL KEY-P)) (AND (EQ CONSTANT-TEST 'EQL) (NULL TEST-NOT-P) (NULL KEY-P) (OR (AND CONSTANT-ITEM (TYPEP CONSTANT-ITEM 'SYMBOL)) (AND CONSTANT-A-LIST (CONSP CONSTANT-A-LIST) (EVERY #'(LAMBDA (X) (AND (CONSP X) (TYPEP (CAR X) 'SYMBOL))) CONSTANT-A-LIST))))) (IL:* IL:|;;| "Use the eq opcode") `(IL:ASSOC ,ITEM ,A-LIST)) ((AND (EQ CONSTANT-TEST 'EQL) (NULL TEST-NOT-P) (NULL KEY-P)) `(%SIMPLE-ASSOC ,ITEM ,A-LIST)) (T 'COMPILER:PASS)))) (IL:PUTPROPS %SIMPLE-ASSOC IL:DOPVAL (2 IL:CMLASSOC)) (DEFUN %SIMPLE-RASSOC (ITEM A-LIST) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (EQL ITEM (CDR PAIR))) (RETURN PAIR)))) (DEFUN %COMPLEX-RASSOC (ITEM A-LIST TEST TEST-NOT-P KEY) (DO ((TAIL A-LIST (CDR TAIL)) PAIR TEST-RESULT) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (LET ((TEST-RESULT (FUNCALL TEST ITEM (IF KEY (FUNCALL KEY (CDR PAIR)) (CDR PAIR))))) (IF TEST-NOT-P (NOT TEST-RESULT) TEST-RESULT))) (RETURN PAIR)))) (DEFUN RASSOC (ITEM A-LIST &KEY (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY NIL KEY-P)) (IF (AND TEST-P TEST-NOT-P) (ERROR "Both test and test-not supplied")) (IF (OR TEST-P TEST-NOT-P KEY-P) (%COMPLEX-RASSOC ITEM A-LIST (IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P KEY) (%SIMPLE-RASSOC ITEM A-LIST))) (DEFUN RASSOC-IF (PREDICATE A-LIST &KEY (KEY NIL KEY-P)) (IF KEY-P (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL PREDICATE (FUNCALL KEY (CDR PAIR)))) (RETURN PAIR))) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (FUNCALL PREDICATE (CDR PAIR))) (RETURN PAIR))))) (DEFUN RASSOC-IF-NOT (PREDICATE A-LIST &KEY (KEY NIL KEY-P)) (IF KEY-P (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL PREDICATE (FUNCALL KEY (CDR PAIR))))) (RETURN PAIR))) (DO ((TAIL A-LIST (CDR TAIL)) PAIR) ((NULL TAIL) NIL) (SETQ PAIR (CAR TAIL)) (IF (AND (CONSP PAIR) (NOT (FUNCALL PREDICATE (CDR PAIR)))) (RETURN PAIR))))) (IL:* IL:|;;| "Section 7.8.4 Mapping") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %MIN-LIST-LENGTH (LISTS) `(LET ((MIN (IL:LENGTH (CAR ,LISTS))) NEXT-LENGTH) (DOLIST (LIST (CDR ,LISTS) MIN) (SETQ NEXT-LENGTH (IL:LENGTH LIST)) (IF (< NEXT-LENGTH MIN) (SETQ MIN NEXT-LENGTH))))) (DEFMACRO %FILL-SLICE-FROM-LISTS (LISTS ARG-SLICE ARG-TAIL-FORM) `(DO ((SUBSLICE ,ARG-SLICE (CDR SUBSLICE)) (SUBLIST ,LISTS (CDR SUBLIST)) (SOME-LIST-EMPTY NIL) LIST) ((NULL SUBLIST) (COND (SOME-LIST-EMPTY (IL:* IL:\;  "Ran out of entries in a list.") NIL) (T (IL:* IL:\;  "still work to do; return it.") ,ARG-SLICE))) (SETQ LIST (CAR SUBLIST)) (SETQ SOME-LIST-EMPTY (OR SOME-LIST-EMPTY (NULL LIST))) (RPLACA SUBSLICE (PROG1 ,(SUBST 'LIST 'ARG-TAIL ARG-TAIL-FORM) (RPLACA SUBLIST (CDR LIST)))))) ) (IL:* IL:|;;| "Utilities ") (DEFUN %LIST-MAP-OPTIMIZER (FN LISTS &KEY TAIL-P COLLECT-P NCONC-P INC-FN NIL-RESULT-P) (IL:* IL:|;;| "Keywords INC-FN and NIL-RESULT-P are for Interlisp mapping functions") (LET ((CONSTANT-FN (COND ((CONSTANTP FN) (EVAL FN)) ((AND (CONSP FN) (OR (EQ (CAR FN) 'FUNCTION) (EQ (CAR FN) 'IL:FUNCTION))) (CADR FN)))) (CONSTANT-INC-FN (IF INC-FN (COND ((CONSTANTP INC-FN) (EVAL INC-FN)) ((AND (CONSP INC-FN) (OR (EQ (CAR INC-FN) 'FUNCTION) (EQ (CAR INC-FN) 'IL:FUNCTION))) (CADR INC-FN))) 'CDR)) (RESULT-P (OR COLLECT-P NCONC-P))) (IF (AND CONSTANT-FN CONSTANT-INC-FN) (LET* ((FIRST-LIST-RETURNED-P (NOT (OR RESULT-P NIL-RESULT-P))) (FIRST-LIST (CAR LISTS)) (OTHER-LISTS (CDR LISTS)) (OTHER-SUBLISTS (DO ((LST NIL) (SI-PACKAGE (FIND-PACKAGE "SI")) (I 1 (1+ I)) (MAP-LIST OTHER-LISTS (CDR MAP-LIST))) ((NULL MAP-LIST) (NREVERSE LST)) (PUSH (INTERN (CONCATENATE 'STRING "%$$MAP-SUBLIST" (PRIN1-TO-STRING I)) SI-PACKAGE) LST)))) `(DO* (,@(IF FIRST-LIST-RETURNED-P `((SI::%$$MAP-FIRST-LIST ,FIRST-LIST))) (SI::%$$MAP-FIRST-SUBLIST ,(IF FIRST-LIST-RETURNED-P 'SI::%$$MAP-FIRST-LIST FIRST-LIST) (,CONSTANT-INC-FN SI::%$$MAP-FIRST-SUBLIST)) ,@(IF OTHER-SUBLISTS (MAPCAR #'(LAMBDA (SYMBOL VAR) `(,SYMBOL ,VAR (,CONSTANT-INC-FN ,SYMBOL))) OTHER-SUBLISTS OTHER-LISTS)) ,@(IF RESULT-P `((SI::%$$MAP-RESULT NIL) (SI::%$$MAP-RESULT-TAIL NIL) SI::%$$MAP-ELEMENT))) (,(IF OTHER-SUBLISTS `(OR (NULL SI::%$$MAP-FIRST-SUBLIST) ,@(MAPCAR #'(LAMBDA (SYMBOL) `(NULL ,SYMBOL)) OTHER-SUBLISTS)) `(NULL SI::%$$MAP-FIRST-SUBLIST)) ,(IF RESULT-P 'SI::%$$MAP-RESULT (IF NIL-RESULT-P NIL 'SI::%$$MAP-FIRST-LIST))) ,(LET ((FORM `(,CONSTANT-FN ,(IF TAIL-P 'SI::%$$MAP-FIRST-SUBLIST '(CAR SI::%$$MAP-FIRST-SUBLIST)) ,@(MAPCAR #'(LAMBDA (SYMBOL) (IF TAIL-P SYMBOL `(CAR ,SYMBOL))) OTHER-SUBLISTS)))) (IF RESULT-P `(SETQ SI::%$$MAP-ELEMENT ,FORM) FORM)) ,@(COND (COLLECT-P '((IF SI::%$$MAP-RESULT (RPLACD SI::%$$MAP-RESULT-TAIL (SETQ SI::%$$MAP-RESULT-TAIL (LIST SI::%$$MAP-ELEMENT))) (SETQ SI::%$$MAP-RESULT (SETQ SI::%$$MAP-RESULT-TAIL (LIST SI::%$$MAP-ELEMENT )))))) (NCONC-P '((IF SI::%$$MAP-RESULT-TAIL (RPLACD SI::%$$MAP-RESULT-TAIL SI::%$$MAP-ELEMENT) (SETQ SI::%$$MAP-RESULT SI::%$$MAP-ELEMENT)) (IF (CONSP SI::%$$MAP-ELEMENT) (SETQ SI::%$$MAP-RESULT-TAIL (LAST SI::%$$MAP-ELEMENT)))))))) 'COMPILER:PASS))) (DEFMACRO %LIST-COLLECT (RESULT RESULT-TAIL ITEM-FORM) `(IF ,RESULT (RPLACD ,RESULT-TAIL (SETQ ,RESULT-TAIL ,ITEM-FORM)) (SETQ ,RESULT (SETQ ,RESULT-TAIL ,ITEM-FORM)))) (DEFUN %MAPCAR-SINGLE (FN LIST) (DO ((SUBLIST LIST (CDR SUBLIST)) (RESULT NIL) (RESULT-TAIL NIL)) ((NULL SUBLIST) RESULT) (%LIST-COLLECT RESULT RESULT-TAIL (LIST (FUNCALL FN (CAR SUBLIST)))))) (DEFUN %MAPCAR-MULTIPLE (FN LISTS) (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((RESULT NIL) (RESULT-TAIL NIL) (CURRENT-SLICE ARG-SLICE) ELEMENT) ((NULL CURRENT-SLICE) RESULT) (SETQ CURRENT-SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE (CAR ARG-TAIL))) (COND (CURRENT-SLICE (IL:* IL:\;  "There is really more work to do.") (SETQ ELEMENT (APPLY FN CURRENT-SLICE)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))))) (DEFUN MAPCAR (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided. The result is a list such that element is the result of applying FUNCTION to element i of each of the argument lists.") (IF (NULL MORE-LISTS) (%MAPCAR-SINGLE FUNCTION LIST) (%MAPCAR-MULTIPLE FUNCTION (CONS LIST MORE-LISTS)))) (XCL:DEFOPTIMIZER MAPCAR (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS :COLLECT-P T)) (DEFUN %MAPLIST-SINGLE (FN LIST) (DO ((SUBLIST LIST (CDR SUBLIST)) (RESULT NIL) (RESULT-TAIL NIL)) ((NULL SUBLIST) RESULT) (%LIST-COLLECT RESULT RESULT-TAIL (LIST (FUNCALL FN SUBLIST))))) (DEFUN %MAPLIST-MULTIPLE (FN LISTS) (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((RESULT NIL) (RESULT-TAIL NIL) (CURRENT-SLICE ARG-SLICE) ELEMENT) ((NULL CURRENT-SLICE) RESULT) (SETQ CURRENT-SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE ARG-TAIL)) (COND (CURRENT-SLICE (IL:* IL:\;  "There is really more work to do.") (SETQ ELEMENT (APPLY FN CURRENT-SLICE)) (%LIST-COLLECT RESULT RESULT-TAIL (LIST ELEMENT))))))) (DEFUN MAPLIST (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided. The result is a list such that element is the result of applying FUNCTION to element i of each of the argument lists.") (IF (NULL MORE-LISTS) (%MAPLIST-SINGLE FUNCTION LIST) (%MAPLIST-MULTIPLE FUNCTION (CONS LIST MORE-LISTS)))) (XCL:DEFOPTIMIZER MAPLIST (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS :TAIL-P T :COLLECT-P T)) (DEFUN %MAPC-SINGLE (FN LIST) (DOLIST (ELEMENT LIST) (FUNCALL FN ELEMENT))) (DEFUN %MAPC-MULTIPLE (FN LISTS) (IL:* IL:|;;| "MAPC for multiple lists") (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((SLICE ARG-SLICE)) ((NULL SLICE)) (IL:* IL:|;;|  "%FILL-SLICE-FROM-LISTS returns NIL if one of the lists we're slicing thru bottoms out.") (SETQ SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE (CAR ARG-TAIL))) (COND (SLICE (APPLY FN SLICE)))))) (DEFUN MAPC (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided.") (IF (NULL MORE-LISTS) (%MAPC-SINGLE FUNCTION LIST) (%MAPC-MULTIPLE FUNCTION (CONS LIST MORE-LISTS))) LIST (IL:* IL:\;  "Always return the first list argument") ) (XCL:DEFOPTIMIZER MAPC (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS)) (DEFUN %MAPL-SINGLE (FN LIST) (DO ((TAIL LIST (CDR TAIL))) ((NULL TAIL)) (FUNCALL FN TAIL))) (DEFUN %MAPL-MULTIPLE (FN LISTS) (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((SLICE ARG-SLICE)) ((NULL SLICE)) (IL:* IL:|;;|  "%FILL-SLICE-FROM-LISTS returns NIL if one of the lists we're slicing thru bottoms out.") (SETQ SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE ARG-TAIL)) (COND (SLICE (APPLY FN SLICE)))))) (DEFUN MAPL (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided.") (IF (NULL MORE-LISTS) (%MAPL-SINGLE FUNCTION LIST) (%MAPL-MULTIPLE FUNCTION (CONS LIST MORE-LISTS))) (IL:* IL:\;  "always return the first list argument") LIST) (XCL:DEFOPTIMIZER MAPL (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS :TAIL-P T)) (DEFUN %MAPCAN-SINGLE (FN LIST) (DO ((SUBLIST LIST (CDR SUBLIST)) (RESULT NIL) (RESULT-TAIL NIL) ELEMENT) ((NULL SUBLIST) RESULT) (SETQ ELEMENT (FUNCALL FN (CAR SUBLIST))) (IL:* IL:\;  "accumulate the results by nconc") (IF RESULT-TAIL (RPLACD RESULT-TAIL ELEMENT) (SETQ RESULT ELEMENT)) (IF (CONSP ELEMENT) (SETQ RESULT-TAIL (LAST ELEMENT))))) (DEFUN %MAPCAN-MULTIPLE (FN LISTS) (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((RESULT NIL) (RESULT-TAIL NIL) (CURRENT-SLICE ARG-SLICE) ELEMENT) ((NULL CURRENT-SLICE) RESULT) (SETQ CURRENT-SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE (CAR ARG-TAIL))) (COND (CURRENT-SLICE (IL:* IL:\;  "There is really more work to do.") (SETQ ELEMENT (APPLY FN CURRENT-SLICE)) (IF RESULT-TAIL (RPLACD RESULT-TAIL ELEMENT) (SETQ RESULT ELEMENT)) (IF (CONSP ELEMENT) (SETQ RESULT-TAIL (LAST ELEMENT)))))))) (DEFUN MAPCAN (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided. ") (IF (NULL MORE-LISTS) (%MAPCAN-SINGLE FUNCTION LIST) (%MAPCAN-MULTIPLE FUNCTION (CONS LIST MORE-LISTS)))) (XCL:DEFOPTIMIZER MAPCAN (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS :NCONC-P T)) (DEFUN %MAPCON-SINGLE (FN LIST) (DO ((SUBLIST LIST (CDR SUBLIST)) (RESULT NIL) (RESULT-TAIL NIL) ELEMENT) ((NULL SUBLIST) RESULT) (SETQ ELEMENT (FUNCALL FN SUBLIST)) (IF RESULT-TAIL (RPLACD RESULT-TAIL ELEMENT) (SETQ RESULT ELEMENT)) (IF (CONSP ELEMENT) (SETQ RESULT-TAIL (LAST ELEMENT))))) (DEFUN %MAPCON-MULTIPLE (FN LISTS) (LET ((ARG-SLICE (MAKE-LIST (IL:LENGTH LISTS)))) (DO ((RESULT NIL) (RESULT-TAIL NIL) (CURRENT-SLICE ARG-SLICE) ELEMENT) ((NULL CURRENT-SLICE) RESULT) (SETQ CURRENT-SLICE (%FILL-SLICE-FROM-LISTS LISTS ARG-SLICE ARG-TAIL)) (COND (CURRENT-SLICE (IL:* IL:\;  "There is really more work to do.") (SETQ ELEMENT (APPLY FN CURRENT-SLICE)) (IF RESULT-TAIL (RPLACD RESULT-TAIL ELEMENT) (SETQ RESULT ELEMENT)) (IF (CONSP ELEMENT) (SETQ RESULT-TAIL (LAST ELEMENT)))))))) (DEFUN MAPCON (FUNCTION LIST &REST MORE-LISTS) (IL:* IL:|;;| "FUNCTION must take as many arguments as there are lists provided. ") (IF (NULL MORE-LISTS) (%MAPCON-SINGLE FUNCTION LIST) (%MAPCON-MULTIPLE FUNCTION (CONS LIST MORE-LISTS)))) (XCL:DEFOPTIMIZER MAPCON (FN &REST LISTS) (%LIST-MAP-OPTIMIZER FN LISTS :TAIL-P T :NCONC-P T)) (IL:* IL:|;;| "optimizers for Interlisp mapping functions whose bytemacros are not visible to the pav-compiler") (IL:* IL:\; "Utility") (DEFUN %EVERY-MAP-OPTIMIZER (LIST FN &OPTIONAL INC-FN &KEY SOME-P NEGATE-P) (LET ((CONSTANT-FN (COND ((CONSTANTP FN) (EVAL FN)) ((AND (CONSP FN) (OR (EQ (CAR FN) 'FUNCTION) (EQ (CAR FN) 'IL:FUNCTION))) (CADR FN)))) (CONSTANT-INC-FN (IF INC-FN (COND ((CONSTANTP INC-FN) (EVAL INC-FN)) ((AND (CONSP INC-FN) (OR (EQ (CAR INC-FN) 'FUNCTION) (EQ (CAR INC-FN) 'IL:FUNCTION))) (CADR INC-FN))) 'CDR))) (IF (AND CONSTANT-FN CONSTANT-INC-FN) `(DO ((SI::%$$MAP-SUBLIST ,LIST (,CONSTANT-INC-FN SI::%$$MAP-SUBLIST))) ((NULL SI::%$$MAP-SUBLIST) ,(IF SOME-P NEGATE-P (NOT NEGATE-P))) ,(IF SOME-P `(IF (,CONSTANT-FN (CAR SI::%$$MAP-SUBLIST) SI::%$$MAP-SUBLIST) (RETURN ,(IF NEGATE-P NIL 'SI::%$$MAP-SUBLIST))) `(IF (NULL (,CONSTANT-FN (CAR SI::%$$MAP-SUBLIST) SI::%$$MAP-SUBLIST)) (RETURN ,NEGATE-P)))) 'COMPILER:PASS))) (XCL:DEFOPTIMIZER IL:MAP (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :TAIL-P T :INC-FN IL:MAPFN2 :NIL-RESULT-P T) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:MAPC (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :INC-FN IL:MAPFN2 :NIL-RESULT-P T) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:MAPLIST (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :TAIL-P T :COLLECT-P T :INC-FN IL:MAPFN2) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:MAPCAR (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :COLLECT-P T :INC-FN IL:MAPFN2) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:MAPCON (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :TAIL-P T :NCONC-P T :INC-FN IL:MAPFN2) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:MAPCONC (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%LIST-MAP-OPTIMIZER IL:MAPFN1 (LIST LIST) :NCONC-P T :INC-FN IL:MAPFN2) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:SOME (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%EVERY-MAP-OPTIMIZER LIST IL:MAPFN1 IL:MAPFN2 :SOME-P T) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:EVERY (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%EVERY-MAP-OPTIMIZER LIST IL:MAPFN1 IL:MAPFN2) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:NOTANY (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%EVERY-MAP-OPTIMIZER LIST IL:MAPFN1 IL:MAPFN2 :SOME-P T :NEGATE-P T) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:NOTEVERY (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (%EVERY-MAP-OPTIMIZER LIST IL:MAPFN1 IL:MAPFN2 :NEGATE-P T) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER IL:SUBSET (LIST IL:MAPFN1 &OPTIONAL IL:MAPFN2) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* (LET ((IL:CONSTANT-FN (COND ((CONSTANTP IL:MAPFN1) (EVAL IL:MAPFN1)) ((AND (CONSP IL:MAPFN1) (OR (EQ (CAR IL:MAPFN1) 'IL:FUNCTION) (EQ (CAR IL:MAPFN1) 'FUNCTION))) (CADR IL:MAPFN1))))) (IF IL:CONSTANT-FN `(IL:MAPCONC ,LIST (IL:FUNCTION (IL:LAMBDA (IL:X) (IL:IF (,IL:CONSTANT-FN IL:X) IL:THEN (LIST IL:X)))) ,IL:MAPFN2) 'COMPILER:PASS)) 'COMPILER:PASS)) (DEFMACRO XCL:WITH-COLLECTION (&BODY XCL::BODY) `(LET ((SI::$WITH-COLLECTION-RESULT$ NIL) SI::$WITH-COLLECTION-TAIL$) (MACROLET ((XCL:COLLECT (XCL::FORM) (IL:* IL:|;;| "written in this way to take advantage of RPLCONS. The FORM is evaluated first so that COLLECT nests properly, i.e., The test to determine if this is the first value collected should be done after the value itself is generated in case it does collection as well.") `(LET ((SI::$WITH-COLLECTION-VALUE$ ,XCL::FORM)) (IF SI::$WITH-COLLECTION-RESULT$ (RPLACD SI::$WITH-COLLECTION-TAIL$ (SETQ SI::$WITH-COLLECTION-TAIL$ (LIST SI::$WITH-COLLECTION-VALUE$ ))) (SETQ SI::$WITH-COLLECTION-RESULT$ (SETQ SI::$WITH-COLLECTION-TAIL$ (LIST SI::$WITH-COLLECTION-VALUE$ )))) SI::$WITH-COLLECTION-VALUE$))) ,@XCL::BODY SI::$WITH-COLLECTION-RESULT$))) (IL:* IL:|;;| "some people apparantly still use memq") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:MOVD 'IL:FMEMB 'IL:MEMQ) ) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PUTPROPS IL:CMLLIST IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLLIST IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA APPEND) ) (IL:PUTPROPS IL:CMLLIST IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (13493 14242 (APPEND 13506 . 14240))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLLOAD b/sources/CMLLOAD new file mode 100644 index 00000000..6c727a76 --- /dev/null +++ b/sources/CMLLOAD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (filecreated "13-Jul-90 18:00:23" |{PELE:MV:ENVOS}SOURCES>CMLLOAD.;4| 3202 |changes| |to:| (functions cl::\\openstream-with-default) |previous| |date:| " 4-Jun-90 15:23:02" |{PELE:MV:ENVOS}SOURCES>CMLLOAD.;3|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (prettycomprint cmlloadcoms) (rpaqq cmlloadcoms ((functions cl:load cl::\\openstream-with-default) (fns \\cml-load) (variables *load-print-stuff* *load-verbose*) (prop filetype cmlload))) (cl:defun cl:load (filename &key ((:verbose *load-verbose*) *load-verbose*) ((:print *load-print-stuff*) *load-print-stuff*) (if-does-not-exist :error) (loadflg nil) package) "Loads the file named by Filename into the Lisp environment." (let ((stream (or (streamp filename) (|if| (null if-does-not-exist) |then| (condition-case (cl::\\openstream-with-default filename) (xcl:file-not-found nil (* |;;| "Spec says return NIL if file not found and IF-DOES-NOT-EXIST is NIL") (cl:return-from cl:load nil))) |else| (cl::\\openstream-with-default filename))))) (cl:unwind-protect (\\load-stream stream (cl:intern (string loadflg) (cl:find-package "INTERLISP")) *load-print-stuff* (and *load-verbose* *terminal-io*) package) (cl:close stream)))) (cl:defun cl::\\openstream-with-default (cl::filename) (declare (cl:special loadparamaters)) (* |;;| "If the current connected directory is \"{DSK}\", (CL:LOAD \"{CORE}FOO\") should load \"{CORE}FOO\" rather than \"{CORE}FOO\". Thus we call MERGE-PATHNAMES iff HOST field is not specified in FILENAME. ") (cl:if (null (cl:if (cl:pathnamep cl::filename) (cl:pathname-host cl::filename) (filenamefield cl::filename (quote host)))) (openstream (cl:merge-pathnames (pathname cl::filename) *default-pathname-defaults*) (quote input) (quote old) loadparameters) (openstream cl::filename (quote input) (quote old) loadparameters))) (defineq (\\cml-load (lambda (stream printflg load-verbose-stream package) (* \; "Edited 19-Jan-87 18:27 by bvm:") (* |;;| "Loads a \"Common Lisp file\" a la CL:LOAD. Currently only do this if file starts with semi-colon. PACKAGE overrides the default (USER).") (let ((*package* (or package (cl:find-package "USER"))) (*readtable* cmlrdtbl) (full (fullname stream)) (eof-mark "EOF") expr) (|until| (eq eof-mark (setq expr (cl:read stream nil eof-mark))) |do| (cond (printflg (print (cl:eval expr) t)) (t (cl:eval expr)))) (|if| load-verbose-stream |then| (cl:format load-verbose-stream "; Finished loading ~A, ~D bytes read~&" full (getfileptr stream))) full))) ) (cl:defvar *load-print-stuff* nil "Default value for :PRINT keyword to LOAD") (cl:defvar *load-verbose* t "Default for VERBOSE keyword to LOAD.") (putprops cmlload filetype cl:compile-file) (putprops cmlload copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (declare\: dontcopy (filemap (nil (1980 2907 (\\cml-load 1990 . 2905))))) stop \ No newline at end of file diff --git a/sources/CMLMACROS b/sources/CMLMACROS new file mode 100644 index 00000000..525a667a --- /dev/null +++ b/sources/CMLMACROS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Oct-91 11:45:00" |{PELE:MV:ENVOS}SOURCES>CMLMACROS.;4| 12775 changes to%: (FNS CL:MACRO-FUNCTION) previous date%: "18-Sep-90 17:33:42" |{PELE:MV:ENVOS}SOURCES>CMLMACROS.;3|) (* ; " Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLMACROSCOMS) (RPAQQ CMLMACROSCOMS [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION \INTERLISP-NLAMBDA-MACRO CL:MACRO-FUNCTION CL:MACROEXPAND CL:MACROEXPAND-1 SETF-MACRO-FUNCTION) (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)) (ADDVARS (GLOBALVARS COMPILERMACROPROPS)) (PROP MACRO *) (FUNCTIONS CL:MACROLET) (SETFS CL:MACRO-FUNCTION) (PROP FILETYPE CMLMACROS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (CLISPEXPANSION [LAMBDA (X ENV) (* ; "Edited 4-Dec-86 01:19 by lmm") (* ;; "the macro function for all CLISP words. Expand X as a clisp macro.") (CL:VALUES (do (LET ((NOSPELLFLG T) (LISPXHIST NIL) (VARS NIL) (COP (COPY X))) (DECLARE (CL:SPECIAL NOSPELLFLG VARS LISPXHIST)) (* ;  "make a copy so dwim doesn't muck with it!") [COND ((GETPROP (CAR X) 'CLISPWORD) (DWIMIFY0? COP COP COP NIL NIL NIL 'VARSBOUND) (COND ((NOT (CL:EQUAL COP X)) (* ; "made a change") (RETURN COP)) ((SETQ COP (GETHASH COP CLISPARRAY)) (RETURN COP] (CL:CERROR "Try expanding again." "Can't CLISP expand expression ~S." X))) T]) (GLOBAL-MACRO-FUNCTION [LAMBDA (X ENV) (* ; "Edited 22-Apr-87 19:07 by Pavel") (LET (MD) (COND [(AND (TYPEP ENV 'COMPILER:ENV) (CL:MULTIPLE-VALUE-BIND (KIND EXPN-FN) (COMPILER:ENV-FBOUNDP ENV X) (AND (EQ KIND :MACRO) EXPN-FN] ((GET X 'MACRO-FN)) ((CL:SPECIAL-FORM-P X) NIL) [[AND [NOT (FMEMB (ARGTYPE X) '(0 2] (FIND PROP IN COMPILERMACROPROPS SUCHTHAT (AND (SETQ MD (GETPROP X PROP)) (NOT (OR (LITATOM MD) (FMEMB (CAR MD) '(APPLY APPLY*] `(LAMBDA (FORM ENV) (MACROEXPANSION FORM ',MD] ((AND (NOT (GETD X)) (GETPROP X 'CLISPWORD)) (FUNCTION CLISPEXPANSION)) ((FMEMB (ARGTYPE X) '(1 3)) (FUNCTION \INTERLISP-NLAMBDA-MACRO]) (LOCAL-MACRO-FUNCTION [LAMBDA (X ENV) (* ; "Edited 13-Apr-87 11:16 by Pavel") (AND ENV (CL:TYPECASE ENV [ENVIRONMENT (* ; "Interpreter's environments") (LET ((FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENV) X))) (AND FN-DEFN (EQ (CAR FN-DEFN) :MACRO) (CDR FN-DEFN] (COMPILER:ENV (* ; "Compiler's environments.") (CL:MULTIPLE-VALUE-BIND (KIND EXPN-FN) (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T) (AND (EQ KIND :MACRO) EXPN-FN]) (LOCAL-SYMBOL-FUNCTION [LAMBDA (X ENV) (* ; "Edited 31-Jul-87 18:06 by amd") (AND ENV (CL:TYPECASE ENV [ENVIRONMENT (* ; "Interpreter's environments") (LET ((FN-DEFN (CL:GETF (ENVIRONMENT-FUNCTIONS ENV) X))) (AND FN-DEFN (EQ (CAR FN-DEFN) :FUNCTION) (CDR FN-DEFN] (COMPILER:ENV (* ; "Compiler's environments.") (CL:MULTIPLE-VALUE-BIND (KIND FN) (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T) (AND (EQ KIND :FUNCTION) FN]) (\INTERLISP-NLAMBDA-MACRO [LAMBDA (X ENV) (* lmm " 7-May-86 17:24") `(CL:FUNCALL (FUNCTION ,(CAR X)) ,@(SELECTQ (ARGTYPE (CAR X)) (1 (MAPCAR (CDR X) (FUNCTION KWOTE))) (3 (LIST (KWOTE (CDR X)))) (SHOULDNT]) (CL:MACRO-FUNCTION [CL:LAMBDA (CL::X CL::ENV) (* ; "Edited 28-Oct-91 11:44 by jds") (AND (CL:SYMBOLP CL::X) (NOT (LOCAL-SYMBOL-FUNCTION CL::X CL::ENV)) (OR (LOCAL-MACRO-FUNCTION CL::X CL::ENV) (GLOBAL-MACRO-FUNCTION CL::X CL::ENV]) (CL:MACROEXPAND [CL:LAMBDA (CL::FORM &OPTIONAL CL::ENV) (* ; "Edited 13-Feb-87 23:47 by Pavel") (* ;;; "If FORM is a macro call, then the form is expanded until the result is not a macro. Returns as multiple values, the form after any expansion has been done and T if expansion was done, or NIL otherwise. Env is the lexical environment to expand in, which defaults to the null environment.") (PROG (CL::FLAG) (CL:MULTIPLE-VALUE-SETQ (CL::FORM CL::FLAG) (CL:MACROEXPAND-1 CL::FORM CL::ENV)) (CL:UNLESS CL::FLAG (RETURN (CL:VALUES CL::FORM NIL))) CL:LOOP (CL:MULTIPLE-VALUE-SETQ (CL::FORM CL::FLAG) (CL:MACROEXPAND-1 CL::FORM CL::ENV)) (CL:IF CL::FLAG (GO CL:LOOP) (RETURN (CL:VALUES CL::FORM T]) (CL:MACROEXPAND-1 [CL:LAMBDA (CL::FORM &OPTIONAL CL::ENV) (* ; "Edited 13-Feb-87 23:49 by Pavel") (* ;;; "If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. Env is the lexical environment to expand in, which defaults to the null environment.") (COND [(AND (CL:CONSP CL::FORM) (CL:SYMBOLP (CAR CL::FORM))) (LET ((CL::DEF (CL:MACRO-FUNCTION (CAR CL::FORM) CL::ENV))) (COND (CL::DEF (CL:IF [NOT (EQ CL::FORM (CL:SETQ CL::FORM (CL:FUNCALL *MACROEXPAND-HOOK* CL::DEF CL::FORM CL::ENV] (CL:VALUES CL::FORM T) (CL:VALUES CL::FORM NIL))) (T (CL:VALUES CL::FORM NIL] (T (CL:VALUES CL::FORM NIL]) (SETF-MACRO-FUNCTION [LAMBDA (X BODY) (* ; "Edited 13-Feb-87 13:26 by Pavel") (* ;; "the SETF function for MACRO-FUNCTION ") (* ;; "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!") (PROG1 (CL:SETF (GET X 'MACRO-FN) BODY) (AND (GETD X) (SELECTQ (ARGTYPE X) ((1 3) (* ;  "Leave Interlisp nlambda definition alone") ) (PUTD X NIL]) ) (APPENDTOVAR COMPILERMACROPROPS DMACRO BYTEMACRO MACRO) (ADDTOVAR GLOBALVARS COMPILERMACROPROPS) (PUTPROPS * MACRO ((X . Y) 'X)) (DEFMACRO CL:MACROLET (CL::MACRODEFS &BODY CL::BODY &ENVIRONMENT CL::ENV) (DECLARE (SPECVARS *BYTECOMPILER-IS-EXPANDING*)) (* ;; "This macro for the old interpreter and compiler only. The new interpreter has a special-form definition. When the new compiler is expanding, we simply return a disguised version of the form.") (IF (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*) THEN (LET ((CL::NEW-ENV (COMPILER::MAKE-CHILD-ENV CL::ENV))) (DECLARE (CL:SPECIAL *BC-MACRO-ENVIRONMENT*)) [FOR CL::FN IN CL::MACRODEFS DO (COMPILER::ENV-BIND-FUNCTION CL::NEW-ENV (CAR CL::FN) :MACRO (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO CL::FN] (CL:SETQ *BC-MACRO-ENVIRONMENT* CL::NEW-ENV) (CONS 'CL:LOCALLY CL::BODY)) ELSEIF (TYPEP CL::ENV 'COMPILER:ENV) THEN `(SI::%%MACROLET ,CL::MACRODEFS ,@CL::BODY) ELSE (LET* ((CL::NEW-ENV (\MAKE-CHILD-ENVIRONMENT CL::ENV)) (CL::FUNCTIONS (ENVIRONMENT-FUNCTIONS CL::NEW-ENV))) (FOR CL::FN IN CL::MACRODEFS DO (CL:SETQ CL::FUNCTIONS (LIST* (CAR CL::FN) [CONS :MACRO `(CL:LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT ) (CL:BLOCK ,(CAR CL::FN) ,(PARSE-DEFMACRO (CADR CL::FN) 'SI::$$MACRO-FORM (CDDR CL::FN) (CAR CL::FN) NIL :ENVIRONMENT 'SI::$$MACRO-ENVIRONMENT))] CL::FUNCTIONS))) (CL:SETF (ENVIRONMENT-FUNCTIONS CL::NEW-ENV) CL::FUNCTIONS) (WALK-FORM (CONS 'CL:LOCALLY CL::BODY) :ENVIRONMENT CL::NEW-ENV)))) (CL:DEFSETF CL:MACRO-FUNCTION SETF-MACRO-FUNCTION) (PUTPROPS CMLMACROS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PRETTYCOMPRINT CMLMACROSCOMS) (RPAQQ CMLMACROSCOMS [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION \INTERLISP-NLAMBDA-MACRO CL:MACRO-FUNCTION CL:MACROEXPAND CL:MACROEXPAND-1 SETF-MACRO-FUNCTION) (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO)) (ADDVARS (GLOBALVARS COMPILERMACROPROPS)) (PROP MACRO *) (FUNCTIONS CL:MACROLET) (SETFS CL:MACRO-FUNCTION) (PROP FILETYPE CMLMACROS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:MACRO-FUNCTION]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:MACRO-FUNCTION) ) (PUTPROPS CMLMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1177 8960 (CLISPEXPANSION 1187 . 2423) (GLOBAL-MACRO-FUNCTION 2425 . 3605) ( LOCAL-MACRO-FUNCTION 3607 . 4543) (LOCAL-SYMBOL-FUNCTION 4545 . 5479) (\INTERLISP-NLAMBDA-MACRO 5481 . 5842) (CL:MACRO-FUNCTION 5844 . 6184) (CL:MACROEXPAND 6186 . 7074) (CL:MACROEXPAND-1 7076 . 8276) ( SETF-MACRO-FUNCTION 8278 . 8958))))) STOP \ No newline at end of file diff --git a/sources/CMLMISCIO b/sources/CMLMISCIO new file mode 100644 index 00000000..34f4918f --- /dev/null +++ b/sources/CMLMISCIO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 13:33:00" |{DSK}local>lde>lispcore>sources>CMLMISCIO.;2| 4328 |changes| |to:| (VARS CMLMISCIOCOMS) |previous| |date:| " 3-Feb-88 10:31:05" |{DSK}local>lde>lispcore>sources>CMLMISCIO.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CMLMISCIOCOMS) (RPAQQ CMLMISCIOCOMS ( (* |;;| "Random leftover IO functions") (* |;;|  "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]") (FUNCTIONS CL:WRITE-STRING WRITE-STRING* CL:Y-OR-N-P CL:YES-OR-NO-P) (* |;;| "Arrange to use the proper compiler") (PROP FILETYPE CMLMISCIO))) (* |;;| "Random leftover IO functions") (* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]") (CL:DEFUN CL:WRITE-STRING (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (CL::START 0) CL::END) (WRITE-STRING* STRING STREAM CL::START CL::END) STRING) (CL:DEFUN WRITE-STRING* (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) (START 0) END &AUX (STRING-LENGTH (CL:LENGTH STRING))) (CL:CHECK-TYPE STRING STRING) (CL:WHEN (NULL END) (SETQ END STRING-LENGTH)) (CL:ASSERT (AND (<= 0 START STRING-LENGTH) (<= START END STRING-LENGTH)) '(START END) "Start (~D) or end (~D) argument out of bounds." START END) (* |;;| "The following comes mainly from \\PRINSTRING...") (LET ((CHARS-TO-PRINT (- END START)) (STRM (\\GETSTREAM STREAM 'OUTPUT)) \\THISFILELINELENGTH) (DECLARE (SPECVARS \\THISFILELINELENGTH)) (CL:WHEN (CL:PLUSP CHARS-TO-PRINT) (.SPACECHECK. STREAM CHARS-TO-PRINT) (* |;;| "Essentially (for x instring string do (\\outchar strm x)).") (CL:DO ((FATP (|ffetch| (STRINGP FATSTRINGP) |of| STRING)) (BASE (|ffetch| (STRINGP BASE) |of| STRING)) (OFFSET (IPLUS START (|ffetch| (STRINGP OFFST) |of| STRING)) (ADD1 OFFSET)) (END (IPLUS END (|ffetch| (STRINGP OFFST) |of| STRING)))) ((>= OFFSET END)) (\\OUTCHAR STRM (CL:IF FATP (\\GETBASEFAT BASE OFFSET) (\\GETBASETHIN BASE OFFSET)))))) STRING) (CL:DEFUN CL:Y-OR-N-P (&OPTIONAL FORMAT-STRING &REST ARGUMENTS) (COND (FORMAT-STRING (CL:FRESH-LINE) (CL:APPLY (FUNCTION CL:FORMAT) *QUERY-IO* FORMAT-STRING ARGUMENTS))) (CL:FLET ((CL::READ-CHAR-NOW NIL (RESETFORM (CONTROL T) (CL:READ-CHAR *QUERY-IO*)))) (CL:DO ((CL::RESPONSE (CL::READ-CHAR-NOW) (CL::READ-CHAR-NOW))) ((OR (CL:CHAR-EQUAL CL::RESPONSE #\Y) (CL:CHAR-EQUAL CL::RESPONSE #\N)) (CL:FRESH-LINE) (CL:CHAR-EQUAL CL::RESPONSE #\Y)) (CL:FORMAT *QUERY-IO* "~&Please type either Y or N: ")))) (CL:DEFUN CL:YES-OR-NO-P (&OPTIONAL CL::FORMAT-STRING &REST CL::ARGUMENTS) (CL:WHEN CL::FORMAT-STRING (CL:FRESH-LINE *QUERY-IO*) (CL:APPLY #'CL:FORMAT *QUERY-IO* CL::FORMAT-STRING CL::ARGUMENTS)) (CL:DO ((CL::RESPONSE (CL:READ-LINE *QUERY-IO*) (CL:READ-LINE *QUERY-IO*))) ((OR (STRING-EQUAL CL::RESPONSE "YES") (STRING-EQUAL CL::RESPONSE "NO")) (STRING-EQUAL CL::RESPONSE "YES")) (CL:FORMAT *QUERY-IO* "Please type either YES or NO: "))) (* |;;| "Arrange to use the proper compiler") (PUTPROPS CMLMISCIO FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLMISCIO COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLMODULES b/sources/CMLMODULES new file mode 100644 index 00000000..ba64762e --- /dev/null +++ b/sources/CMLMODULES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "CL") (IL:FILECREATED "16-Apr-2018 22:46:19"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.;2| 3470 IL:|changes| IL:|to:| (IL:FUNCTIONS REQUIRE) IL:|previous| IL:|date:| "12-Jun-90 16:56:18" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>CMLMODULES.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLMODULESCOMS) (IL:RPAQQ IL:CMLMODULESCOMS ((IL:VARIABLES *MODULES*) (IL:FUNCTIONS PROVIDE REQUIRE) (IL:PROP IL:FILETYPE IL:CMLMODULES) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:CMLMODULES))) (DEFVAR *MODULES* NIL "A list of all modules currently provided to the system.") (DEFUN PROVIDE (MODULE-NAME) "Declare that module-name is provided to the system." (DECLARE (SPECIAL *MODULES*)) (IF (SYMBOLP MODULE-NAME) (SETQ MODULE-NAME (SYMBOL-NAME MODULE-NAME))) (PUSHNEW MODULE-NAME *MODULES* :TEST #'STRING=) MODULE-NAME) (DEFUN REQUIRE (MODULE-NAME &OPTIONAL (PATHNAME NIL)) (IL:* IL:|;;|  "Rewritten by Ron Kaplan, April 2018. Commonlisp search logic was complicated and broken") (IL:* IL:|;;| "Declare that module-name is needed. If already loaded do nothing. If not, load using the pathname, which is a single pathname or list of pathnames. If pathname is not provided use the system default paths ( and directories).") (DECLARE (SPECIAL *MODULES* *DEFAULT-PATHNAME-DEFAULTS* IL:DIRECTORIES IL:*COMPILED-EXTENSIONS*)) (UNLESS (MEMBER MODULE-NAME *MODULES* :TEST #'STRING=) (LET (FOUND (SEARCHPATHS (CONS (NAMESTRING *DEFAULT-PATHNAME-DEFAULTS*) IL:DIRECTORIES))) (IL:* IL:\;  "default is connected directory") (IL:* IL:\;  "maybe final try should be home?") (DOLIST (PATHNAME (ETYPECASE PATHNAME (NULL (LIST MODULE-NAME)) ((OR SYMBOL STRING PATHNAME) (LIST PATHNAME)) (LIST PATHNAME)) T) (SETQ PATHNAME (NAMESTRING PATHNAME)) (OR (IL:* IL:\;  "first look for a compiled file, then source") (SETQ FOUND (IL:FINDFILE-WITH-EXTENSIONS PATHNAME SEARCHPATHS IL:*COMPILED-EXTENSIONS*)) (SETQ FOUND (IL:FINDFILE PATHNAME SEARCHPATHS)) (CERROR "Don't load file ~S~*." "Can't find file ~S for required module ~S." PATHNAME MODULE-NAME)) (IL:* IL:|;;| "LOAD? loads only if not already loaded or FOUND is newer") (IL:LOAD? FOUND))))) (IL:PUTPROPS IL:CMLMODULES IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:CMLMODULES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "CL")) (IL:PUTPROPS IL:CMLMODULES IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 2018)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (857 1132 (PROVIDE 857 . 1132)) (1134 3188 (REQUIRE 1134 . 3188))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLMVS b/sources/CMLMVS new file mode 100644 index 00000000..f7f8f16d --- /dev/null +++ b/sources/CMLMVS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 13:35:04" {DSK}local>lde>lispcore>sources>CMLMVS.;2 5521 changes to%: (VARS CMLMVSCOMS) previous date%: "16-Dec-86 15:45:21" {DSK}local>lde>lispcore>sources>CMLMVS.;1) (* ; " Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLMVSCOMS) (RPAQQ CMLMVSCOMS [ (* ;  "Interpreter and compiler support for multiple values. See LLMVS for runtime support") (FNS CL:MULTIPLE-VALUE-CALL RETVALUES) (PROP DMACRO CL:MULTIPLE-VALUE-CALL) (FUNCTIONS CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-PROG1 CL:MULTIPLE-VALUE-SETQ) [VARS (NEW-ADVISETEMPLATE '(ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES] (PROP FILETYPE CMLMVS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA CL:MULTIPLE-VALUE-CALL ) (NLAML) (LAMA]) (* ; "Interpreter and compiler support for multiple values. See LLMVS for runtime support") (DEFINEQ (CL:MULTIPLE-VALUE-CALL [NLAMBDA FORMS (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Dec-86 15:35 by bvm:") (* ;; "for interpreted calls only. Note that CL:APPLY will compile ok here, because this is in return context, so UNBIND doesn't get in the way.") (CL:APPLY (\EVAL (CAR FORMS)) (for X in (CDR FORMS) join (CL:MULTIPLE-VALUE-LIST (\EVAL X]) (RETVALUES [LAMBDA (POS VALUES FLG) (* bvm%: "10-Nov-86 18:13") (LET ((P (\STACKARGPTR POS))) (COND ((fetch (FX INVALIDP) of (SETQ P (fetch (FX CLINK) of P))) (LISPERROR "ILLEGAL RETURN" VALUES))) (\SMASHRETURN NIL P) (AND FLG (RELSTK POS)) (CL:VALUES-LIST VALUES]) ) (PUTPROPS CL:MULTIPLE-VALUE-CALL DMACRO (DEFMACRO (FN &BODY BODY) (* ;; "How to compile special form MULTIPLE-VALUE-CALL --- for benefit of macro writers, handle some degenerate cases and let the rest turn into an APPLY. This is not an OPTIMIZER because pavcompiler intercepts it for its own use.") [COND [[AND (LISTP FN) (MEMB (CAR FN) '(FUNCTION CL:FUNCTION)) (MEMB (CADR FN) '(LIST CL:VALUES] (if (NULL (CDR BODY)) then (* ;  "only one source of values. Either sole arg is the result itself, or a list of its values is") (CONS (if (EQ (CADR FN) 'LIST) then '\MVLIST else 'PROGN) BODY) else (* ; "Produce a list consisting of all args spread. This is either the result itself, or to be spread as values") `(,(if (EQ (CADR FN) 'LIST) then 'PROGN else 'CL:VALUES-LIST) (NCONC ,@(for F in BODY collect `(\MVLIST ,F] (T `(APPLY ,FN (NCONC ,@(for F in BODY collect `(\MVLIST ,F])) (DEFMACRO CL:MULTIPLE-VALUE-BIND (VARS VALUES-FORM &REST FORMS) `(DESTRUCTURING-BIND ,VARS (CL:MULTIPLE-VALUE-LIST ,VALUES-FORM) ,@FORMS)) (DEFMACRO CL:MULTIPLE-VALUE-LIST (FORM) `(CL:MULTIPLE-VALUE-CALL (FUNCTION LIST) ,FORM)) (DEFMACRO CL:MULTIPLE-VALUE-PROG1 (FORM . OTHER-FORMS) `(CL:VALUES-LIST (PROG1 (CL:MULTIPLE-VALUE-LIST ,FORM) ,@OTHER-FORMS))) (DEFMACRO CL:MULTIPLE-VALUE-SETQ (VARIABLES FORM) [LET ((LIST (GENSYM))) `(LET [(,LIST (CL:MULTIPLE-VALUE-LIST ,FORM] (DESTRUCTURING-SETQ ,VARIABLES ,LIST) (CAR ,LIST]) (RPAQQ NEW-ADVISETEMPLATE [ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES]) (PUTPROPS CMLMVS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA CL:MULTIPLE-VALUE-CALL) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CMLMVS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1760 2597 (CL:MULTIPLE-VALUE-CALL 1770 . 2207) (RETVALUES 2209 . 2595))))) STOP \ No newline at end of file diff --git a/sources/CMLPACKAGE b/sources/CMLPACKAGE new file mode 100644 index 00000000..e727ffc2 --- /dev/null +++ b/sources/CMLPACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (il:filecreated "14-Jun-90 17:33:55" il:|{PELE:MV:ENVOS}SOURCES>CMLPACKAGE.;3| 22253 il:|previous| il:|date:| "16-May-90 14:12:37" il:|{PELE:MV:ENVOS}SOURCES>CMLPACKAGE.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:cmlpackagecoms) (il:rpaqq il:cmlpackagecoms ((il:* il:|;;;| "This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init") (il:setfs symbol-package) (il:functions il:dwim-symbol-package escape-colons-proceed make-external-proceed make-internal-proceed ugly-symbol-proceed) (il:declare\: il:donteval@load il:docopy (il:addvars (il:dwimuserforms (il:dwim-symbol-package)))) (il:* il:|;;| "User friendly symbol error resolving functions") (il:structures read-conflict missing-external-symbol missing-package) (il:variables *preferred-reading-symbols*) (il:functions il:resolve-reader-conflict il:resolve-missing-external-symbol il:resolve-missing-package) (il:structures package-error symbol-conflict use-conflict export-conflict export-missing import-conflict unintern-conflict) (il:functions il:resolve-use-package-conflict il:resolve-export-conflict il:resolve-export-missing il:resolve-import-conflict il:resolve-unintern-conflict) (il:structures symbol-colon-error) (il:functions il:\\invalid.symbol (il:* il:\; "Also defined (w/o the error condition or proceed case) in LLREAD.")) (il:* il:|;;| "Symbol inspector") (il:functions il:symbol-inspect-fetchfn il:symbol-inspect-storefn) (il:p (let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package inspector") (il:functions il:package-inspect-fetchfn il:package-inspect-storefn) (il:p (let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package-hashtable inspector") (il:functions il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn) (il:p (let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)") (il:functions package-prefix setf-package-prefix) (il:setfs package-prefix) (il:prop (il:filetype il:makefile-environment) il:cmlpackage) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars (il:nlama) (il:nlaml) (il:lama)))) ) (il:* il:|;;;| "This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init" ) (defsetf symbol-package il:setf-symbol-package) (defun il:dwim-symbol-package nil (declare (special il:faultx il:faultapplyflg)) (il:* il:|;;| "This is placed on DWIMUSERFORMS to attempt corrections where the typed symbol is in the wrong package.") (let ((il:sym (or (car (il:listp il:faultx)) il:faultx)) il:others) (cond ((and (il:litatom il:sym) (cdr (il:setq il:others (find-all-symbols (symbol-name il:sym)))) (il:setq il:others (il:|for| il:x il:|in| il:others il:|collect| il:x il:|when| (and (il:neq il:x il:sym) (not (keywordp il:x)) (il:|if| (and (il:litatom il:faultx) (not il:faultapplyflg)) il:|then| (il:* il:\; "Error is uba") (boundp il:x) il:|else| (fboundp il:x)))))) (il:|for| il:choice il:|in| il:others il:|when| (il:fixspell1 il:sym il:choice nil t (and (cdr il:others) (quote il:mustapprove))) il:|do| (il:* il:|;;| "Normally there is only one choice, and we offer it. If there is more than one choice, probably should do something like a menu. This is quick and dirty--ask user for each in turn and require approval so that it doesn't choose the first automatically.") (return (il:|if| (il:listp il:faultx) il:|then| (il:* il:\; "SYM = (CAR FAULTX)") (il:/rplaca il:faultx il:choice) il:|else| il:choice))))))) (define-proceed-function escape-colons-proceed :condition symbol-colon-error :report "Treat the extra colon(s) as if they were escaped") (define-proceed-function make-external-proceed :condition missing-external-symbol :report "Return a new external symbol by that name" (condition *current-condition*)) (define-proceed-function make-internal-proceed :condition missing-external-symbol :report "Return a new internal symbol by that name") (define-proceed-function ugly-symbol-proceed :condition missing-package) (il:declare\: il:donteval@load il:docopy (il:addtovar il:dwimuserforms (il:dwim-symbol-package)) ) (il:* il:|;;| "User friendly symbol error resolving functions") (define-condition read-conflict (read-error) (name packages) (:report (lambda (condition stream) (quote (format stream "Symbols named ~a exist in packages:~{~a ~}" (read-conflict-name condition) (mapcar (function package-name) (read-conflict-packages condition)))) (format stream "Symbols named ~A exists in packages:" (read-conflict-name condition)) (dolist (pkg (read-conflict-packages condition)) (princ " " stream) (princ (package-name pkg) stream))))) (define-condition missing-external-symbol (read-error) (name package) (:report (lambda (condition stream) (format stream "External symbol ~a not found in package ~a" (missing-external-symbol-name condition) (package-name (missing-external-symbol-package condition)))))) (define-condition missing-package (read-error) (package-name symbol-name external) (:report (lambda (condition stream) (format stream "Can't find package ~a to look up symbol ~a" (missing-package-package-name condition) (missing-package-symbol-name condition))))) (defvar *preferred-reading-symbols* (quote (il:append il:apply il:apropos il:array il:arrayp il:assoc il:atan il:atom il:block il:break il:char il:character il:close il:common il:compile il:compile-file il:cos il:count il:defstruct il:delete il:describe il:directory il:do il:documentation il:elt il:equal il:error il:eval il:every il:exp il:expt il:fill-pointer il:find il:first il:floatp il:floor il:format il:function il:gcd il:gensym il:gethash il:if il:intersection il:keyword il:labels il:lambda il:ldiff il:length il:listp il:load il:locally il:log il:loop il:map il:mapc il:mapcar il:mapcon il:maphash il:maplist il:member il:merge il:mismatch il:mod il:namestring il:notany il:notevery il:nth il:number il:numberp il:numerator il:pop il:position il:prin1 il:print il:push il:pushnew il:rational il:read il:readtable il:remove il:replace il:rest il:reverse il:search il:second il:setq il:signed-byte il:simple-string il:sin il:some il:sort il:sqrt il:stringp il:structure il:sublis il:subseq il:subst il:symbol il:tan il:terpri trace il:union il:unless il:values il:variable il:vector il:when il:zerop il:* il:***)) "List of symbols whose lookup is preferred by the litatom to symbol converter. Initially it contains a list of symbols which are conflicting but are always qualified in old sources.") (defun il:resolve-reader-conflict (il:ilsym il:clsym il:clsymwhere) "Reader finds unqualified symbol that exists in both InterLisp and Lisp. Checks *PREFERRED-READING-SYMBOLS* list against names." (declare (special *preferred-reading-symbols*)) (il:* il:|;;| "CAUTION: Do not attempt to move the namestring check from \\NEW.READ.SYMBOL into this function as RESOLVE-READER-CONFLICT has a dummy definition in the INIT. Also, namestring resolutions must be made during the time that packages are turned off in the beginning of the INIT.") (cond ((not (eq il:clsymwhere :external)) (il:* il:\; "Will not resolve internal (therefore private) symbols from LISP") il:ilsym) (t (let ((il:ilpreferred (member il:ilsym *preferred-reading-symbols* :test (quote eq))) (il:clpreferred (member il:clsym *preferred-reading-symbols* :test (quote eq)))) (cond ((and il:ilpreferred (not il:clpreferred)) il:ilsym) ((and il:clpreferred (not il:ilpreferred)) il:clsym) (t (il:* il:\; "Raise the signal") (restart-case (error (quote read-conflict) :name (symbol-name il:ilsym) :packages (list (find-package "LISP") (find-package "INTERLISP"))) (prefer-clsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the LISP symbol ~A; make it preferred" il:clsym)) il:clsym) (prefer-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the INTERLISP symbol ~A; make it preferred" il:ilsym)) (setq *preferred-reading-symbols* (remove il:clsym *preferred-reading-symbols* :test (function eq))) (push il:ilsym *preferred-reading-symbols*) il:ilsym) (return-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Just return the INTERLISP symbol ~A" il:ilsym)) il:ilsym)))))))) (defun il:resolve-missing-external-symbol (il:name package) "Handle missing external symbols in a package during read." (let ((il:my-condition (make-condition (quote missing-external-symbol) :name il:name :package package))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (make-external-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new external symbol in package ~A named ~A" (package-name package) il:name)) (let ((il:symbol (intern il:name package))) (export il:symbol package) il:symbol)) (make-internal-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new internal symbol in package ~A named ~A" (package-name package) il:name)) (intern il:name package)))))) (defun il:resolve-missing-package (package-name symbol-name externalp) (let ((il:my-condition (make-condition (quote missing-package) :package-name package-name :symbol-name symbol-name :external externalp))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (new-package-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new symbol named ~A made in new package ~A" symbol-name package-name)) (let* ((package (make-package (missing-package-package-name il:my-condition))) (symbol (intern (missing-package-symbol-name il:my-condition) package))) (when (missing-package-external il:my-condition) (export symbol package)) symbol)) (ugly-symbol-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new ugly symbol |~a~a~a| made in current package ~a" package-name (if externalp ":" "::") symbol-name (package-name *package*))) :interactive (lambda nil (list *package*)) (intern (il:concat (missing-package-package-name il:my-condition) (if (missing-package-external il:my-condition) ":" "::") (missing-package-symbol-name il:my-condition)) *package*)))))) (define-condition package-error (error) (package)) (define-condition symbol-conflict (package-error) (symbols)) (define-condition use-conflict (symbol-conflict) (used-package) (:report (lambda (condition *standard-output*) (format t "Package ~a using ~a results in name conflicts for symbols:~%~{~s ~}" (package-name (use-conflict-package condition)) (package-name (use-conflict-used-package condition)) (use-conflict-symbols condition))))) (define-condition export-conflict (symbol-conflict) (exported-symbols packages) (:report (lambda (condition *standard-output*) (format t "Exporting these symbols from the ~a package:~%~{~s ~}~%results in name conflicts with package(s):~%~{~a ~}~%" (package-name (export-conflict-package condition)) (export-conflict-symbols condition) (mapcar (function package-name) (export-conflict-packages condition)))))) (define-condition export-missing (package-error) (symbols) (:report (lambda (condition *standard-output*) (format t "These symbols aren't in package ~a; can't export them from it:~%~{~s ~}" (package-name (export-missing-package condition)) (export-missing-symbols condition))))) (define-condition import-conflict (symbol-conflict) nil (:report (lambda (condition *standard-output*) (format t "Importing these symbols into package ~a causes a name conflict:~%~{~s ~}" (package-name (import-conflict-package condition)) (import-conflict-symbols condition))))) (define-condition unintern-conflict (symbol-conflict) (symbol) (:report (lambda (condition *standard-output*) (format t "Uninterning symbol ~s causes a name conflict among these symbols:~%~{~s ~}" (unintern-conflict-symbol condition) (unintern-conflict-symbols condition))))) (defun il:resolve-use-package-conflict (used-package symbols package) "Handle a conflict from use-package." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote use-conflict) :package package :symbols symbols :used-package used-package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadow-use-conflicts-proceed nil :filter filter :report (lambda (stream) (format stream "Shadow conflicting symbols from ~A in ~A" (package-name used-package) (package-name package))) (dolist (symbol symbols) (shadow symbol package))) (unintern-user-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (DANGEROUS)" (package-name package))) (dolist (symbol symbols) (il:moby-unintern symbol package))) (unintern-usee-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (VERY DANGEROUS)" (package-name used-package))) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) used-package) used-package))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort making package ~a use ~a" (package-name package) (package-name used-package))) (il:retfrom (quote use-package) nil)))))) (defun il:resolve-export-conflict (package symbols packages exported-symbols) "Handle a conflict raised by export." (il:setq symbols (sort symbols (quote string<))) (setq packages (sort packages (function (lambda (a b) (string< (package-name a) (package-name b)))))) (let ((my-condition (make-condition (quote export-conflict) :package package :symbols symbols :exported-symbols exported-symbols :packages packages))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (unintern-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols in package~P~{ ~a~} (DANGEROUS)" (if (null (rest packages)) 0 1) (mapcar (function package-name) packages))) (dolist (package packages exported-symbols) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) package) package)))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort exporting the symbols from package ~a" (package-name package))) (il:retfrom (quote export) nil)))))) (defun il:resolve-export-missing (package symbols) "Handle missing symbols needed to export." (setq symbols (sort symbols (quote string<))) (let ((my-condition (quote export-missing) :package package :symbols symbols (make-condition))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (import-proceed nil :filter filter :report (lambda (stream) (format stream "Import missing symbols into ~A, then export them" package)) (import symbols package)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort export from package ~A" package)) (il:retfrom (quote export) nil)))))) (defun il:resolve-import-conflict (package symbols) "Handle conflict signalled by import. Returning from here does shadowing import." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote import-conflict) :package package :symbols symbols))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed nil :filter filter :report (lambda (stream) (format stream "Import symbols into ~S with ~S instead" (package-name package) (quote shadowing-import))) nil) (abort nil :filter filter :report (lambda (stream) (format stream "Abort import into package ~S" (package-name package))) (il:retfrom (quote import) nil)))))) (defun il:resolve-unintern-conflict (symbol symbols package) "Handle a conflict noted by unintern." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote unintern-conflict) :symbol symbol :symbols symbols :package package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed (symbol-to-import) :filter filter :report (lambda (stream) (format stream "Choose symbol and ~S it to hide conflicts in package ~S" (quote shadowing-import) (package-name package))) :interactive (lambda nil (loop (let ((symbol (il:menu (il:create il:menu il:title il:_ "Choose symbol to shadowing-import" il:items il:_ symbols il:centerflg il:_ t)))) (when (member symbol symbols :test (function eq)) (return (list symbol)))))) (shadowing-import symbol-to-import package) (il:retfrom (quote il:resolve-unintern-conflict) t)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort unintern of symbol ~s from package ~s" symbol (package-name package))) (il:retfrom (quote unintern) nil)))))) (define-condition symbol-colon-error (read-error) (name) (:report (lambda (condition *standard-output*) (format t "Invalid symbol syntax in \"~A\"" (symbol-colon-error-name condition))))) (defun il:\\invalid.symbol (base len ncolons package extrasegments) (il:* il:|;;;| "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon. If return from here, will read the symbol as though the extra colons were escaped.") (declare (special il:\\fatpnamestringp) (il:* il:\; "This ain't my fault, honest.")) (let ((my-condition (make-condition (quote symbol-colon-error) :name (il:concat (if (and package (not (eq package il:*keyword-package*))) (if (stringp package) package (package-name package)) "") (case ncolons (1 ":") (2 "::") (t "")) (il:\\getbasestring base 0 len il:\\fatpnamestringp))))) (restart-case (error my-condition) (escape-colons-proceed nil :filter (lambda nil (eq *current-condition* my-condition)) :report "Treat the extra colon(s) as if they were escaped" nil)))) (il:* il:|;;| "Symbol inspector") (defun il:symbol-inspect-fetchfn (il:object il:property) (case il:property (il:name (symbol-name il:object)) (il:value (if (boundp il:object) (symbol-value il:object) (quote il:nobind))) (il:plist (symbol-plist il:object)) (package (symbol-package il:object)))) (defun il:symbol-inspect-storefn (il:object il:property il:value) (case il:property (il:name (il:promptprint "Can't set symbol name")) (il:value (setf (symbol-value il:object) il:value)) (il:plist (setf (symbol-plist il:object) il:value)) (package (setf (symbol-package il:object) il:value)))) (let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form)))) (il:* il:|;;| "Package inspector") (defun il:package-inspect-fetchfn (il:object il:property) (case il:property (il:name (lisp::%package-name il:object)) (il:nicknames (lisp::%package-nicknames il:object)) (il:use-list (lisp::%package-use-list il:object)) (il:internal-symbols (lisp::%package-internal-symbols il:object)) (il:external-symbols (lisp::%package-external-symbols il:object)) (il:shadowing-symbols (lisp::%package-shadowing-symbols il:object)))) (defun il:package-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package")) (let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form)))) (il:* il:|;;| "Package-hashtable inspector") (defun il:package-hashtable-inspect-fetchfn (il:object il:property) (case il:property (il:size (lisp::package-hashtable-size il:object)) (il:free (lisp::package-hashtable-free il:object)) (il:deleted (lisp::package-hashtable-deleted il:object)) (il:contents (lisp::package-hashtable-table il:object)))) (defun il:package-hashtable-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package-hashtable")) (let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form)))) (il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)") (defun package-prefix (package) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (lisp::%package-namesymbol (il:\\packagify package))) (defun setf-package-prefix (package prefix) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (if (symbolp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) prefix) (if (stringp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) (intern prefix)) (error "~S must be symbol or string." prefix)))) (defsetf package-prefix setf-package-prefix) (il:putprops il:cmlpackage il:filetype :compile-file) (il:putprops il:cmlpackage il:makefile-environment (:readtable "XCL" :package "XCL")) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addtovar il:nlama ) (il:addtovar il:nlaml ) (il:addtovar il:lama ) ) (il:putprops il:cmlpackage il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/CMLPARSE b/sources/CMLPARSE new file mode 100644 index 00000000..128f2dd6 --- /dev/null +++ b/sources/CMLPARSE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 8-Jun-90 14:57:22" |{PELE:MV:ENVOS}SOURCES>CMLPARSE.;3| 36284 changes to%: (FUNCTIONS ANALYZE) previous date%: "16-May-90 14:14:58" |{PELE:MV:ENVOS}SOURCES>CMLPARSE.;2|) (* ; " Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPARSECOMS) (RPAQQ CMLPARSECOMS ( (* ;; "Parsing bodies and argument lists") (VARIABLES %%ARG-COUNT %%MIN-ARGS %%UNBOUNDED-ARG-COUNT %%LET-LIST %%KEYWORD-TESTS %%ENV-ARG-USED %%CTX-ARG-USED %%ENV-ARG-NAME %%CTX-ARG-NAME) (VARIABLES *DEFAULT-DEFAULT* *KEY-FINDER*) (FUNCTIONS PARSE-BODY) (FUNCTIONS PARSE-DEFMACRO ANALYZE ANALYZE-AUX ANALYZE-KEY ANALYZE-PARAMETER CHECK-PARAMETER-NAME PUSH-KEYWORD-BINDING ANALYZE-REST RECURSIVELY-ANALYZE DEFMACRO-ARG-TEST) (* ;; "Testing the argument-list parsing") (VARIABLES ANALYZE-TESTS) (* ;; "Runtime support functions") (FUNCTIONS KEYWORD-TEST FIND-KEYWORD) (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLPARSE))) (* ;; "Parsing bodies and argument lists") (CL:DEFVAR %%ARG-COUNT NIL) (CL:DEFVAR %%MIN-ARGS NIL) (CL:DEFVAR %%UNBOUNDED-ARG-COUNT 0) (CL:DEFVAR %%LET-LIST NIL) (CL:DEFVAR %%KEYWORD-TESTS NIL) (CL:DEFVAR %%ENV-ARG-USED NIL) (CL:DEFVAR %%CTX-ARG-USED NIL) (CL:DEFVAR %%ENV-ARG-NAME NIL) (CL:DEFVAR %%CTX-ARG-NAME NIL) (CL:DEFVAR *DEFAULT-DEFAULT* NIL) (CL:DEFVAR *KEY-FINDER* NIL) (CL:DEFUN PARSE-BODY (XCL::BODY XCL::ENVIRONMENT &OPTIONAL (XCL::DOC-STRING-ALLOWED T)) (* ;; "CDR down the list of forms in BODY, looking for declarations and documentation strings, until we hit either the end of the BODY or a form that is neither of these. We expand macros in our search for declarations and doc-strings, but only until we find a form we don't understand.") (* ;; "") (* ;; "Return three values:") (* ;; " 1) The remainder of the BODY, after declarations and doc-strings,") (* ;; " 2) A list of the declarations found,") (* ;; " 3) The first documentation string found, or NIL if none are present.") (LET ((XCL::TAIL XCL::BODY) (XCL::DECLS NIL) (XCL::DOC NIL)) (CL:LOOP (CL:WHEN (NULL XCL::TAIL) (RETURN)) [LET ((XCL::FORM (CAR XCL::TAIL))) (COND ((AND (CL:STRINGP XCL::FORM) (CDR XCL::TAIL)) (* ;  "Be careful about strings at the end of BODY... They aren't doc-strings!") (CL:IF (AND (NOT XCL::DOC) XCL::DOC-STRING-ALLOWED) (CL:SETQ XCL::DOC XCL::FORM))) ([OR (CL:ATOM XCL::FORM) (NOT (CL:SYMBOLP (CAR XCL::FORM] (RETURN)) ((EQ (CAR XCL::FORM) 'DECLARE) (CL:PUSH XCL::FORM XCL::DECLS)) ((EQ (CAR XCL::FORM) COMMENTFLG) (* ; "Ignore Interlisp comments.") NIL) ((CL:SPECIAL-FORM-P (CAR XCL::FORM)) (RETURN)) (T (LET [(XCL::RESULT (CONDITIONS:RESTART-CASE (CL:MACROEXPAND XCL::FORM XCL::ENVIRONMENT) (CONDITIONS:CONTINUE NIL :REPORT (CL:LAMBDA (STREAM) (LET ((*PRINT-LEVEL* 3) (*PRINT-LENGTH* 3)) (CL:FORMAT STREAM "Assume that ~S does not expand into a declaration." XCL::FORM))) XCL::FORM] (CL:IF (AND (CL:CONSP XCL::RESULT) (EQ (CAR XCL::RESULT) 'DECLARE)) (CL:PUSH XCL::RESULT XCL::DECLS) (RETURN))] (CL:POP XCL::TAIL)) (CL:VALUES XCL::TAIL (CL:REVERSE XCL::DECLS) XCL::DOC))) (CL:DEFUN PARSE-DEFMACRO [ARGUMENT-LIST WHOLE-EXPRESSION MACRO-BODY ERROR-LOCATION ENVIRONMENT &KEY [PATH `(CDR ,WHOLE-EXPRESSION] ((:ENVIRONMENT %%ENV-ARG-NAME)) ((:CONTEXT %%CTX-ARG-NAME)) (ERROR-STRING NIL) (DOC-STRING-ALLOWED T) ((:DEFAULT-DEFAULT *DEFAULT-DEFAULT*) NIL) ((:KEY-FINDER *KEY-FINDER*) 'FIND-KEYWORD) (REMOVE-COMMENTS (AND (EQ (CAR ARGUMENT-LIST) '&WHOLE) (EQ (CADR ARGUMENT-LIST) '%%ORIGINAL-DEFINITION] (DECLARE (CL:SPECIAL %%CTX-ARG-NAME %%ENV-ARG-NAME *KEY-FINDER* *DEFAULT-DEFAULT*)) (* ;; "%"Parse-Defmacro provides a clean interface to ANALYZE for use by macros and macro-like forms that must parse some form according to a defmacro-like argument list.") (* ;; "") (* ;; "-- ARGUMENT-LIST is the argument-list to be used for parsing.") (* ;; "-- WHOLE-EXPRESSION is the variable which is bound to the entire macro-call, or NIL if &whole is illegal.") (* ;; "-- MACRO-BODY is the code that will be executed in the scope of the argument-list.") (* ;;  "-- ERROR-LOCATION is the name of the function being worked on, for use in error messages.") (* ;; "-- ENVIRONMENT is an environment in which PARSE-DEFMACRO may macroexpand the WHOLE-EXPRESSION, looking for declarations.") (* ;; "-- PATH is an access expression for getting to the object to be parsed, which defaults to the CDR of WHOLE.") (* ;; "-- :ENVIRONMENT is the place where the macroexpansion environment may be found. If not supplied, then no &environment arg is allowed.") (* ;; "-- :CONTEXT is the place where the macroexpansion compiler context may be found. If not supplied, then no &context arg is allowed.") (* ;; "-- :ERROR-STRING is used as the first argument to ERROR if an incorrect number of arguments are supplied. The additional arguments to ERROR are ERRLOC and the number of arguments supplied. If ERROR-STRING is not supplied, then no argument count error checking is done.") (* ;; "-- :DOC-STRING-ALLOWED indicates whether a doc-string should be parsed out of the body.") (* ;;  "-- :DEFAULT-DEFAULT is the default value for unsupplied arguments, which defaults to NIL.") (* ;; "-- :KEY-FINDER the function used to do keyword lookup. It defaults to a function that does the right thing. If you supply your own, it should take two arguments, the keyword to be found and a list in which to find it, and return either a list of one element, the value of the given keyword, or NIL, if the keyword is not present.") (* ;; "-- :REMOVE-COMMENTS should be non-NIL iff comments should be stripped from the macro-call before processing. The default is set up as a horrible hack to allow macros created by DEFDEFINER to get this feature.") (* ;; "") (* ;; "The first value returned is a LET* form which binds things and then evaluates the specified CODE.") (* ;; "The second value is a list of ignore declarations for the WHOLE and ENVIRONMENT vars, if appropriate.") (* ;; "The third value is the documentation string, if DOC-STRING-ALLOWED and one is present, and NIL otherwise.") (* ;; "The fourth and fifth values are the minimum and maximum number of arguments allowed, in case you care about that kind of thing. The fifth value is NIL if there is no upper limit.") [CL:MULTIPLE-VALUE-BIND (BODY LOCAL-DECS DOC) (PARSE-BODY MACRO-BODY ENVIRONMENT DOC-STRING-ALLOWED) (LET ((%%ARG-COUNT 0) (%%MIN-ARGS 0) (%%UNBOUNDED-ARG-COUNT NIL) (%%LET-LIST NIL) (%%KEYWORD-TESTS NIL) (%%ENV-ARG-USED NIL) (%%CTX-ARG-USED NIL)) (ANALYZE ARGUMENT-LIST (CL:IF REMOVE-COMMENTS `(REMOVE-COMMENTS ,PATH) PATH) ERROR-LOCATION WHOLE-EXPRESSION) (LET [(ARG-TEST (CL:IF ERROR-STRING (DEFMACRO-ARG-TEST PATH))) (BODY `(LET* ,(REVERSE %%LET-LIST) ,@LOCAL-DECS ,@%%KEYWORD-TESTS ,@BODY] (CL:VALUES (CL:IF ARG-TEST `(CL:IF ,ARG-TEST (CL:ERROR ,ERROR-STRING ',ERROR-LOCATION (CL:LENGTH ,PATH)) ,BODY) BODY) `[,@(CL:UNLESS (OR ARG-TEST ARGUMENT-LIST) `[(DECLARE (IGNORE ,WHOLE-EXPRESSION]) ,@(CL:WHEN (AND %%ENV-ARG-NAME (NOT %%ENV-ARG-USED)) `[(DECLARE (IGNORE ,%%ENV-ARG-NAME]) ,@(CL:WHEN (AND %%CTX-ARG-NAME (NOT %%CTX-ARG-USED)) `[(DECLARE (IGNORE ,%%CTX-ARG-NAME])] DOC %%MIN-ARGS (CL:IF %%UNBOUNDED-ARG-COUNT NIL %%ARG-COUNT)]) (CL:DEFUN ANALYZE (ARGLIST PATH ERRLOC WHOLE) (* ;; "ANALYZE is implemented as a finite-state machine that steps through the legal parts of an arglist in order: required, optional, rest, key, and aux. The results are accumulated in a set of special variables: %%let-list, %%arg-count, %%min-args, %%unbounded-arg-count, %%keyword-tests, %%ctx-arg-used and %%env-arg-used. It reads the special variables %%env-arg-name and %%ctx-arg-name.") (CL:ASSERT (CL:LISTP ARGLIST) NIL "The argument list %"~S%" was not a list." ARGLIST) (CL:UNLESS (OR (CL:ATOM PATH) (NULL ARGLIST)) (* ;  "Eliminate a common subexpression") (* ;  "(OR ...(NULL ARGLIST)) is added for solution of AR#7337(Edited by TT : 8-June-90) ") (LET ((NEW-PATH (GENSYM))) (CL:PUSH `(,NEW-PATH ,PATH) %%LET-LIST) (CL:SETQ PATH NEW-PATH))) (CL:DO ((ARGS ARGLIST (CDR ARGS)) (OPTIONALP NIL) A) ((CL:ATOM ARGS) (CL:UNLESS (NULL ARGS) (* ;  "If the variable-list is dotted, treat it as a &rest argument and return.") (CL:SETQ %%UNBOUNDED-ARG-COUNT T) (CL:PUSH `(,ARGS ,PATH) %%LET-LIST))) (CL:SETQ A (CAR ARGS)) (CASE A ((&WHOLE) (COND ((AND WHOLE (CL:CONSP (CDR ARGS))) (ANALYZE-PARAMETER (CADR ARGS) WHOLE ERRLOC) (SETQ %%UNBOUNDED-ARG-COUNT T) (SETQ ARGS (CDR ARGS)) (* ;  "Only one CDR here; the other one is done by the DO loop, above.") ) (T (CL:ERROR "Illegal or ill-formed &whole arg in ~S." ERRLOC)))) ((&ENVIRONMENT) (COND ((AND %%ENV-ARG-NAME (CL:CONSP (CDR ARGS)) (CL:SYMBOLP (CADR ARGS))) (CHECK-PARAMETER-NAME (CADR ARGS) ERRLOC) (CL:PUSH `(,(CADR ARGS) ,%%ENV-ARG-NAME) %%LET-LIST) (CL:SETQ %%ENV-ARG-USED T) (CL:SETQ ARGS (CDR ARGS))) (T (CL:ERROR "Illegal or ill-formed &environment arg in ~S." ERRLOC)))) ((&CONTEXT) (COND ((AND %%CTX-ARG-NAME (CL:CONSP (CDR ARGS)) (CL:SYMBOLP (CADR ARGS))) (CHECK-PARAMETER-NAME (CADR ARGS) ERRLOC) (CL:PUSH `(,(CADR ARGS) ,%%CTX-ARG-NAME) %%LET-LIST) (CL:SETQ %%CTX-ARG-USED T) (CL:SETQ ARGS (CDR ARGS))) (T (CL:ERROR "Illegal or ill-formed &context arg in ~S." ERRLOC)))) ((&OPTIONAL) (AND OPTIONALP (CL:CERROR "Ignore it." "Redundant &optional flag in varlist of ~S." ERRLOC)) (CL:SETQ OPTIONALP T)) ((&REST &BODY) (RETURN (ANALYZE-REST (CAR ARGS) (CDR ARGS) PATH ERRLOC WHOLE))) ((&KEY) (LET ((KEYWORD-ARGS-VAR (GENSYM))) (CL:SETQ %%UNBOUNDED-ARG-COUNT T) (CL:PUSH `(,KEYWORD-ARGS-VAR ,PATH) %%LET-LIST) (RETURN (ANALYZE-KEY (CDR ARGS) KEYWORD-ARGS-VAR ERRLOC)))) ((&ALLOW-OTHER-KEYS) (CL:CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC)) ((&AUX) (RETURN (ANALYZE-AUX (CDR ARGS) ERRLOC))) (* ;; "It's actually a parameter!") (CL:OTHERWISE (COND (* ;; "It's an optional argument.") [OPTIONALP (CL:SETQ %%ARG-COUNT (CL:1+ %%ARG-COUNT)) (COND (* ;; "The normal case, a simple variable.") ((CL:SYMBOLP A) (CHECK-PARAMETER-NAME A ERRLOC) (CL:PUSH `[,A (COND (,PATH (CAR ,PATH)) (T ,*DEFAULT-DEFAULT*] %%LET-LIST)) (* ;; "A buggy case.") ((CL:ATOM A) (CL:CERROR "Ignore this item." "Non-symbol variable name in ~S." ERRLOC)) (* ;; "The defaulting case: (var [default [svar]])") (T (ANALYZE-PARAMETER (CAR A) `[COND (,PATH (CAR ,PATH)) (T ,(COND ((CDR A) (* ; "Was a default value specified?") (CADR A)) (T *DEFAULT-DEFAULT*] ERRLOC) (CL:WHEN (NOT (NULL (CDDR A))) (CHECK-PARAMETER-NAME (CADDR A) ERRLOC) (CL:PUSH `[,(CADDR A) (NOT (NULL ,PATH] %%LET-LIST))] (* ;; "It's a required argument.") (T (CL:SETQ %%MIN-ARGS (CL:1+ %%MIN-ARGS)) (CL:SETQ %%ARG-COUNT (CL:1+ %%ARG-COUNT)) (ANALYZE-PARAMETER A `(CAR ,PATH) ERRLOC))) (* ;; "After each real parameter, we need to advance PATH by CDRing. In many cases, though, we can eliminate a common subexpression.") (CL:IF (OR (CL:ATOM (CDR ARGS)) (CL:ATOM (CDDR ARGS))) [CL:SETQ PATH `(CDR ,PATH] (LET ((NEW-PATH (GENSYM))) (CL:PUSH `(,NEW-PATH (CDR ,PATH)) %%LET-LIST) (CL:SETQ PATH NEW-PATH))))))) (CL:DEFUN ANALYZE-AUX (ARGLIST ERRLOC) (* ;; "Analyze stuff following &aux.") (CL:DO ((ARGS ARGLIST (CDR ARGS))) ((NULL ARGS)) (COND ((CL:ATOM ARGS) (CL:CERROR "Ignore the illegal terminator." "Dotted arglist after &AUX in ~S." ERRLOC) (RETURN NIL)) ((CL:SYMBOLP (CAR ARGS)) (CHECK-PARAMETER-NAME (CAR ARGS) ERRLOC) (CL:PUSH `(,(CAR ARGS) NIL) %%LET-LIST)) ((CL:ATOM (CAR ARGS)) (CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAR ARGS) ERRLOC)) ((CL:SYMBOLP (CAAR ARGS)) (CHECK-PARAMETER-NAME (CAAR ARGS) ERRLOC) (CL:PUSH `(,(CAAR ARGS) ,(CADAR ARGS)) %%LET-LIST)) (T (CL:ERROR "Non-symbolic &AUX parameter %"~S%" in arglist of ~S." (CAAR ARGS) ERRLOC))))) (CL:DEFUN ANALYZE-KEY (ARGLIST RESTVAR ERRLOC) (* ;; "Handle analysis of keywords, perhaps with destructuring over the keyword variable. Assumes the remainder of the calling form has already been bound to the variable passed in as RESTVAR.") (LET ((TEMP (GENSYM)) (CHECK-KEYWORDS T) (KEYWORDS-SEEN NIL)) (CL:PUSH TEMP %%LET-LIST) (* ;  "TEMP will be used for each keyword as a temporary piece of storage; see PUSH-KEYWORD-BINDING.") (CL:DO ((ARGS ARGLIST (CDR ARGS)) A K SP-VAR TEMP1) ((CL:ATOM ARGS) (CL:IF (NULL ARGS) NIL (CL:CERROR "Ignore the illegal terminator." "Dotted arglist after &key in ~S." ERRLOC))) (SETQ A (CAR ARGS)) (COND ((EQ A '&ALLOW-OTHER-KEYS) (SETQ CHECK-KEYWORDS NIL)) ((EQ A '&AUX) (RETURN (ANALYZE-AUX (CDR ARGS) ERRLOC))) [(EQ A '&ENVIRONMENT) (COND ((AND %%ENV-ARG-NAME (CL:CONSP (CDR ARGS)) (CL:SYMBOLP (CADR ARGS))) (CHECK-PARAMETER-NAME (CADR ARGS) ERRLOC) (CL:PUSH `(,(CADR ARGS) ,%%ENV-ARG-NAME) %%LET-LIST) (CL:SETQ %%ENV-ARG-USED T) (CL:SETQ ARGS (CDR ARGS))) (T (CL:ERROR "Illegal or ill-formed &environment arg in ~S." ERRLOC] [(EQ A '&CONTEXT) (COND ((AND %%CTX-ARG-NAME (CL:CONSP (CDR ARGS)) (CL:SYMBOLP (CADR ARGS))) (CHECK-PARAMETER-NAME (CADR ARGS) ERRLOC) (CL:PUSH `(,(CADR ARGS) ,%%CTX-ARG-NAME) %%LET-LIST) (CL:SETQ %%CTX-ARG-USED T) (CL:SETQ ARGS (CDR ARGS))) (T (CL:ERROR "Illegal or ill-formed &context arg in ~S." ERRLOC] ((CL:SYMBOLP A) (* ;  "Just a top-level variable. Make matching keyword.") (SETQ K (MAKE-KEYWORD A)) (PUSH-KEYWORD-BINDING A K NIL NIL RESTVAR TEMP ERRLOC) (CL:PUSH K KEYWORDS-SEEN)) ((CL:ATOM A) (* ;  "Filter out error that might choke defmacro.") (CL:CERROR "Ignore this item." "~S -- non-symbol variable name in arglist of ~S." A ERRLOC)) ((CL:SYMBOLP (CAR A)) (* ; "Deal with the common case:") (* ; "(var [init [svar]])") (SETQ K (MAKE-KEYWORD (CAR A))) (SETQ SP-VAR (CADDR A)) (PUSH-KEYWORD-BINDING (CAR A) K (CADR A) SP-VAR RESTVAR TEMP ERRLOC) (CL:PUSH K KEYWORDS-SEEN)) ((OR (CL:ATOM (CAR A)) (NOT (CL:KEYWORDP (CAAR A))) (CL:ATOM (CDAR A))) (* ;  "Filter out more error cases that might kill defmacro.") (CL:CERROR "Ignore this item." "~S -- ill-formed keyword arg in ~S." (CAR A) ERRLOC)) ((CL:SYMBOLP (CADR (CAR A))) (* ; "Next case is") (* ;  "((:key var) [init [supplied-p]]).") (SETQ K (CAAR A)) (CL:UNLESS (CL:KEYWORDP K) (CL:ERROR "%"~S%" should be a keyword, in arglist of ~S." K ERRLOC)) (SETQ SP-VAR (CADDR A)) (PUSH-KEYWORD-BINDING (CADR (CAR A)) K (CADR A) SP-VAR RESTVAR TEMP ERRLOC) (CL:PUSH K KEYWORDS-SEEN)) (T (* ;  "Same case, but must destructure the `variable'.") (SETQ K (CAAR A)) (CL:UNLESS (CL:KEYWORDP K) (CL:ERROR "%"~S%" should be a keyword, in arglist of ~S." K ERRLOC)) (SETQ TEMP1 (GENSYM)) (SETQ SP-VAR (CADDR A)) (PUSH-KEYWORD-BINDING TEMP1 K (CADR A) SP-VAR RESTVAR TEMP ERRLOC) (CL:PUSH K KEYWORDS-SEEN) (RECURSIVELY-ANALYZE (CADAR A) TEMP1 ERRLOC NIL)))) (CL:WHEN CHECK-KEYWORDS (CL:PUSH `(KEYWORD-TEST ,RESTVAR ',KEYWORDS-SEEN) %%KEYWORD-TESTS)))) (CL:DEFUN ANALYZE-PARAMETER (PARAM PATH ERRLOC) (* ;;; "We are given a single parameter and the path for getting to its value. The parameter may ask us to destructure the value. Arrange for the parameter to get its value.") [COND ((CL:SYMBOLP PARAM) (* ; "The simple, normal case.") (CHECK-PARAMETER-NAME PARAM ERRLOC) (CL:PUSH `(,PARAM ,PATH) %%LET-LIST)) ((CL:ATOM PARAM) (* ; "Not so good.") (CL:CERROR "Ignore this item." "Non-symbol variable name %"~S%" in ~S." PARAM ERRLOC)) (T (* ; "The destructuring case.") (LET ((NEW-WHOLE (GENSYM))) (CL:PUSH `(,NEW-WHOLE ,PATH) %%LET-LIST) (RECURSIVELY-ANALYZE PARAM NEW-WHOLE ERRLOC NEW-WHOLE]) (CL:DEFUN CHECK-PARAMETER-NAME (NAME ERRLOC) (CL:ASSERT (CL:SYMBOLP NAME) NIL "CHECK-PARAMETER-NAME should only be called with a symbol!") (COND ((NULL NAME) (CL:CERROR "Try to continue. Good luck!" "NIL used as a parameter name in ~S" ERRLOC)) ((CL:KEYWORDP NAME) (CL:CERROR "Use it anyway. This is UGLY..." "The keyword ~S was used as a parameter name in ~S" NAME ERRLOC)) ((MEMBER NAME CL:LAMBDA-LIST-KEYWORDS :TEST 'EQ) (CL:CERROR "Use it anyway. This is UGLY..." "The lambda-list keyword ~S was used as a parameter name in ~S" NAME ERRLOC)))) (CL:DEFUN PUSH-KEYWORD-BINDING (VARIABLE CL:KEYWORD DEFAULT SUPPLIED-P-VAR REST-VAR TEMP-VAR ERRLOC) (CHECK-PARAMETER-NAME VARIABLE ERRLOC) (CL:UNLESS (CL:SYMBOLP SUPPLIED-P-VAR) (CL:ERROR "Non-symbolic supplied-p parameter %"~S%" found in arglist of ~S." SUPPLIED-P-VAR ERRLOC)) (CL:PUSH `[,VARIABLE (COND ((CL:SETQ ,TEMP-VAR (,*KEY-FINDER* ',CL:KEYWORD ,REST-VAR)) (CAR ,TEMP-VAR)) (T ,(OR DEFAULT *DEFAULT-DEFAULT*] %%LET-LIST) (CL:WHEN (NOT (NULL SUPPLIED-P-VAR)) (CHECK-PARAMETER-NAME SUPPLIED-P-VAR ERRLOC) (CL:PUSH `[,SUPPLIED-P-VAR (NOT (NULL ,TEMP-VAR] %%LET-LIST))) (CL:DEFUN ANALYZE-REST (CL:KEYWORD ARGLIST PATH ERRLOC WHOLE) (* ;;; "This is complicated by the ``implicit PARSE-BODY'' convention. If a &body keyword is followed by a symbol, then it's just a normal &rest. If it's followed by a list of length one, then it's just like &rest using the CAR of that list. Otherwise, it's a list of length either 2 or 3: (body decls [doc]). The tail of the macro-call arguments is passed to PARSE-BODY along with the current lexical environment (as from &environment) and a doc-string-allowed-p argument of T iff the ``doc'' was specified (that is, the list after &body was of length three). PARSE-BODY returns three values that are then matched against ``body'', ``decls'', and ``doc'' respectively. Those three values can, in turn, be destructured, but it's not likely to be useful in any but the ``body'' case.") (CL:WHEN (CL:ATOM ARGLIST) (CL:ERROR "Bad ~S arg in ~S." CL:KEYWORD ERRLOC)) (SETQ %%UNBOUNDED-ARG-COUNT T) [LET ((REST-ARG (CAR ARGLIST))) (COND ((OR (CL:ATOM REST-ARG) (EQ CL:KEYWORD '&REST) (AND (EQ CL:KEYWORD '&BODY) (CL:CONSP REST-ARG) (NULL (CDR REST-ARG)) (PROGN (SETQ REST-ARG (CAR REST-ARG)) T))) (* ;  "The non-parsing case of &rest or &body.") (ANALYZE-PARAMETER REST-ARG PATH ERRLOC)) [(AND (CL:CONSP REST-ARG) (> (CL:LENGTH REST-ARG) 1)) (* ; "Fancy case:") (* ; "(body-var decls-var [doc-var])") (* ; "an implicit call to PARSE-BODY.") (CL:UNLESS %%ENV-ARG-NAME (CL:ERROR "The parsing version of &body is not allowed when no lexical environment is available." )) (LET ((BODY (CL:FIRST REST-ARG)) (DECLS (CL:SECOND REST-ARG)) (DOC (CL:THIRD REST-ARG)) (PARSE-BODY-RESULT (GENSYM))) (SETQ REST-ARG NIL) (* ; "This makes &key illegal.") (CL:PUSH `[,PARSE-BODY-RESULT (CL:MULTIPLE-VALUE-LIST (PARSE-BODY ,PATH ,%%ENV-ARG-NAME ,(NOT (NULL DOC] %%LET-LIST) (ANALYZE-PARAMETER BODY `(CL:FIRST ,PARSE-BODY-RESULT) ERRLOC) (ANALYZE-PARAMETER DECLS `(CL:SECOND ,PARSE-BODY-RESULT) ERRLOC) (CL:WHEN DOC (ANALYZE-PARAMETER DOC `(CL:THIRD ,PARSE-BODY-RESULT) ERRLOC))] (T (CL:ERROR "Bad &rest or &body arg in ~S." ERRLOC))) (* ;; "Handle any arguments after &rest or &body.") (CL:DO ((MORE (CDR ARGLIST) (CDR MORE))) ((CL:ATOM MORE) (CL:IF (NULL MORE) NIL (CL:CERROR "Ignore the illegal terminator." "Dotted arglist terminator after &rest arg in ~S." ERRLOC))) (CASE (CAR MORE) ((&KEY) (CL:IF (NULL REST-ARG) (CL:CERROR "Ignore the keywords." "The parsing version of &body was mixed with &key in arglist of ~S." ERRLOC) (RETURN (ANALYZE-KEY (CDR MORE) REST-ARG ERRLOC)))) ((&AUX) (RETURN (ANALYZE-AUX (CDR MORE) ERRLOC))) ((&ALLOW-OTHER-KEYS) (CL:CERROR "Ignore it." "Stray &ALLOW-OTHER-KEYS in arglist of ~S." ERRLOC)) ((&WHOLE) (COND ((AND WHOLE (CL:CONSP (CDR MORE)) (CL:SYMBOLP (CADR MORE))) (CL:PUSH `(,(CADR MORE) ,WHOLE) %%LET-LIST) (SETQ MORE (CDR MORE))) (T (CL:ERROR "Ill-formed or illegal &whole arg in ~S." ERRLOC)))) ((&ENVIRONMENT) (COND ((AND %%ENV-ARG-NAME (CL:CONSP (CDR MORE)) (CL:SYMBOLP (CADR MORE))) (CL:PUSH `(,(CADR MORE) ,%%ENV-ARG-NAME) %%LET-LIST) (SETQ %%ENV-ARG-USED T) (SETQ MORE (CDR MORE))) (T (CL:ERROR "Ill-formed or illegal &environment arg in ~S." ERRLOC)))) ((&CONTEXT) (COND ((AND %%CTX-ARG-NAME (CL:CONSP (CDR MORE)) (CL:SYMBOLP (CADR MORE))) (CL:PUSH `(,(CADR MORE) ,%%CTX-ARG-NAME) %%LET-LIST) (SETQ %%CTX-ARG-USED T) (SETQ MORE (CDR MORE))) (T (CL:ERROR "Ill-formed or illegal &context arg in ~S." ERRLOC)))) (CL:OTHERWISE (CL:CERROR "Ignore it." "Stray parameter %"~S%" found in arglist of ~S." (CAR MORE) ERRLOC))))]) (CL:DEFUN RECURSIVELY-ANALYZE (ARGLIST PATH ERRLOC WHOLE) (* ;; "Make a recursive call on ANALYZE, being careful to shield the data-structures of outer calls and to make certain constructs illegal. The bindings of MIN-ARGS, ARG-COUNT, and UNBOUNDED-ARG-COUNT are for shielding and those of ENV-ARG-NAME and CTX-ARG-NAME are to disallow &environment and &context respectively.") (LET ((%%MIN-ARGS 0) (%%ARG-COUNT 0) (%%UNBOUNDED-ARG-COUNT NIL) (%%ENV-ARG-NAME NIL) (%%CTX-ARG-NAME NIL)) (ANALYZE ARGLIST PATH ERRLOC WHOLE))) (CL:DEFUN DEFMACRO-ARG-TEST (ARGS) (* ;; "Return a form which tests whether an illegal number of arguments have been supplied. Args is a form which evaluates to the list of arguments.") [COND ((AND (ZEROP %%MIN-ARGS) %%UNBOUNDED-ARG-COUNT) NIL) [(ZEROP %%MIN-ARGS) `(> (CL:LENGTH ,ARGS) ,%%ARG-COUNT] [%%UNBOUNDED-ARG-COUNT `(< (CL:LENGTH ,ARGS) ,%%MIN-ARGS] [(= %%MIN-ARGS %%ARG-COUNT) `(CL:/= (CL:LENGTH ,ARGS) ,%%MIN-ARGS] (T `(OR (> (CL:LENGTH ,ARGS) ,%%ARG-COUNT) (< (CL:LENGTH ,ARGS) ,%%MIN-ARGS]) (* ;; "Testing the argument-list parsing") (CL:DEFVAR ANALYZE-TESTS '((CL:MULTIPLE-VALUE-LIST (PARSE-DEFMACRO '((&WHOLE HEAD MOUTH &OPTIONAL EYE1 (EYE2 7 EYE2-P)) ([FIN1 LENGTH1 &KEY ONE (TWO 8) ((:THREE TROIS) 3 TRES-P) ((:FOUR (QUATRE QUATRO)) '(4 4] &OPTIONAL ((FIN2 LENGTH2) 9 FL2-P)) TAIL &REST (FOO BAR BAZ) &ENVIRONMENT ENV) 'WHOLE-ARG '((CODE)) 'ERRLOC :ENVIRONMENT '*ENV* :ERROR-STRING "Ack!")) '((&WHOLE HEAD MOUTH EYE1 EYE2) ((FIN1 LENGTH1) (FIN2 LENGTH2)) TAIL) '((&WHOLE HEAD MOUTH &OPTIONAL EYE1 (EYE2 7 EYE2-P)) ([FIN1 LENGTH1 &KEY ONE (TWO 8) ((:THREE TROIS) 3 TRES-P) ((:FOUR (QUATRE QUATRO)) '(4 4] &OPTIONAL ((FIN2 LENGTH2) 9 FL2-P)) TAIL &REST (FOO BAR BAZ) &ENVIRONMENT ENV))) (* ;; "Runtime support functions") (CL:DEFUN KEYWORD-TEST (ARGS KEYS) (* ;; "Signal an error unless") (* ;; "-- one of the keywords on ARGS is :ALLOW-OTHER-KEYS and it has a non-NIL value, or") (* ;; "-- all of the keywords on ARGS are also on KEYS.") (* ;; "Note that we should search ARGS by CDDR and KEYS by CDR.") (LET ((EXTRA-KEY-FOUND NIL) (ALLOW-OTHER-KEYS-P NIL)) [FOR TAIL ON ARGS BY (CDDR TAIL) DO (CL:WHEN (EQ (CAR TAIL) :ALLOW-OTHER-KEYS) (SETQ ALLOW-OTHER-KEYS-P (CADR TAIL))) (CL:UNLESS (CL:MEMBER (CAR TAIL) KEYS :TEST #'EQ) (CL:SETQ EXTRA-KEY-FOUND (CAR TAIL)))] (CL:WHEN (AND EXTRA-KEY-FOUND (NOT ALLOW-OTHER-KEYS-P)) (CL:ERROR "Extraneous keyword %"~S%" given." EXTRA-KEY-FOUND)))) (CL:DEFUN FIND-KEYWORD (CL:KEYWORD KEYLIST) (* ;; "If keyword is present in the keylist, return a list of its argument. Else, return NIL.") (CL:DO ((L KEYLIST (CDDR L))) ((CL:ENDP L) NIL) (CL:WHEN (CL:ENDP (CDR L)) (CL:CERROR "Stick a NIL on the end and go on." "Unpaired item in keyword portion of macro call.") (RPLACD L (LIST NIL))) (CL:WHEN (EQ (CAR L) CL:KEYWORD) (RETURN (LIST (CADR L)))))) (* ;; "Arrange to use the correct compiler") (PUTPROPS CMLPARSE FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLPARSE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLPATHNAME b/sources/CMLPATHNAME new file mode 100644 index 00000000..97c2f381 --- /dev/null +++ b/sources/CMLPATHNAME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Sep-90 15:14:19" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;9| 42057 changes to%: (FNS CL:MAKE-PATHNAME) previous date%: "22-Aug-90 19:16:14" |{PELE:MV:ENVOS}SOURCES>CMLPATHNAME.;8|) (* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPATHNAMECOMS) (RPAQQ CMLPATHNAMECOMS [ (* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) (VARIABLES *DEFAULT-PATHNAME-DEFAULTS*) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME]) (* ;; "Common Lisp pathname functions") (PUTPROPS CMLPATHNAME FILETYPE CL:COMPILE-FILE) (* ;; "useful macros") (DEFMACRO %%WILD-NAME (STRING) `(LET ((S ,STRING)) (CL:IF (STRING-EQUAL S "*") :WILD S))) (DEFMACRO %%COMPONENT-STRING (COMPONENT) `(MKSTRING (OR ,COMPONENT ""))) (DEFMACRO %%UNPACKFILE1 (NAM ST END FILE PACKFLG ONEFIELDFLG VAL) `[if (NOT ,ONEFIELDFLG) then [SETQ ,VAL (CONS (COND (,PACKFLG (SUBATOM ,FILE ,ST ,END)) (T (OR (SUBSTRING ,FILE ,ST ,END) ""))) (CONS ,NAM ,VAL] elseif (EQMEMB ,NAM ,ONEFIELDFLG) then (RETURN (COND (,PACKFLG (SUBATOM ,FILE ,ST ,END)) (T (OR (SUBSTRING ,FILE ,ST ,END) ""]) (CL:DEFSTRUCT (PATHNAME (:CONC-NAME %%PATHNAME-) (:PRINT-FUNCTION %%PRINT-PATHNAME) (:CONSTRUCTOR %%%%MAKE-PATHNAME) (:PREDICATE CL:PATHNAMEP)) HOST DEVICE DIRECTORY NAME TYPE VERSION) (CL:DEFSTRUCT (DIRECTORY-COMPONENT (:CONC-NAME %%DIRECTORY-COMPONENT-) (:PRINT-FUNCTION %%PRINT-DIRECTORY-COMPONENT) (:CONSTRUCTOR %%MAKE-DIRECTORY-COMPONENT) (:PREDICATE %%DIRECTORY-COMPONENT-P)) TYPE PATH) (DEFINEQ (%%PRINT-PATHNAME (CL:LAMBDA (S STREAM D) (* hdj "19-Sep-86 15:49") (DECLARE (IGNORE D)) (CL:FORMAT STREAM "#.(~S ~S)" (QUOTE PATHNAME) (CL:NAMESTRING S))) ) (CL:MAKE-PATHNAME (CL:LAMBDA (&KEY DEFAULTS (HOST NIL HOSTP) (DEVICE NIL DEVICEP) (DIRECTORY NIL DIRECTORYP) (NAME NIL NAMEP) (TYPE NIL TYPEP) (VERSION NIL VERSIONP)) (* ; "Edited 28-Sep-90 15:02 by jds") (* ;; "Create a pathname from host, device, directory, name, type and version. If any field is omitted, it is obtained from defaults as though by merge-pathnames.") (CL:IF DEFAULTS [LET ((DEFAULTS (PATHNAME DEFAULTS))) (CL:UNLESS HOSTP (SETQ HOST (%%PATHNAME-HOST DEFAULTS))) (CL:UNLESS DEVICEP (SETQ DEVICE (%%PATHNAME-DEVICE DEFAULTS))) (CL:UNLESS DIRECTORYP (SETQ DIRECTORY (%%PATHNAME-DIRECTORY DEFAULTS))) (CL:UNLESS NAMEP (SETQ NAME (%%PATHNAME-NAME DEFAULTS))) (CL:UNLESS TYPEP (SETQ TYPE (%%PATHNAME-TYPE DEFAULTS))) (CL:UNLESS VERSIONP (SETQ VERSION (%%PATHNAME-VERSION DEFAULTS)))] (CL:UNLESS HOSTP (SETQ HOST (%%PATHNAME-HOST *DEFAULT-PATHNAME-DEFAULTS*)))) (%%MAKE-PATHNAME (CL:IF (STRINGP HOST) (COERCE HOST 'CL:SIMPLE-STRING) HOST) (CL:IF (STRINGP DEVICE) (COERCE DEVICE 'CL:SIMPLE-STRING) DEVICE) (CL:IF DIRECTORY (CL:TYPECASE DIRECTORY (DIRECTORY-COMPONENT DIRECTORY) ((OR CL:SYMBOL STRING) [COND ((AND (CL:SYMBOLP DIRECTORY) (EQ DIRECTORY :WILD)) (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH :WILD )) (T (SETQ DIRECTORY (STRING DIRECTORY)) (LET [(DEFAULT-DIR (CL:IF DEFAULTS (%%PATHNAME-DIRECTORY DEFAULTS) (%%PATHNAME-DIRECTORY *DEFAULT-PATHNAME-DEFAULTS* ))) (DIREND (CL:1- (CL:LENGTH DIRECTORY] (CASE (CL:CHAR DIRECTORY DIREND) ((#\> #\/) (* ; "MAKE-PATHNAME does not accept :SUBDIRECTORY argument. Thus a subdirectory and a relative directory is indicated with the trail directory delimiter.") (* ;;  "If HOST is also specifed, it is a relative directory, otherwize a subdirectory.") (CL:IF HOSTP (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (CL:SUBSEQ DIRECTORY 0 DIREND)) (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH (CL:CONCATENATE 'STRING ( %%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) (CL:SECOND \FILENAME.SYNTAX) (CL:SUBSEQ DIRECTORY 0 DIREND) )))) (T (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH DIRECTORY)))]) (T DIRECTORY)) DIRECTORY) (CL:IF (STRINGP NAME) (COERCE NAME 'CL:SIMPLE-STRING) NAME) (CL:IF (STRINGP TYPE) (COERCE TYPE 'CL:SIMPLE-STRING) TYPE) VERSION))) (%%PRINT-DIRECTORY-COMPONENT (CL:LAMBDA (S STREAM D) (DECLARE (IGNORE D)) (* ; "Edited 7-Mar-90 17:59 by nm") (* %| "(CL:FORMAT STREAM %"#.(~S ~S)%" (QUOTE DIRECTORY-COMPONENT) (CASE (%%%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (CL:CONCATENATE (QUOTE STRING) (%%%%DIRECTORY-COMPONENT-PATH S) %">%")) (T (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) (%%%%DIRECTORY-COMPONENT-PATH S) (CL:SECOND \FILENAME.SYNTAX)))))") (LET ((PATH (%%DIRECTORY-COMPONENT-PATH S))) (CL:FORMAT STREAM "~A" (CASE (%%DIRECTORY-COMPONENT-TYPE S) ((:SUBDIRECTORY :RELATIVE) (CL:CONCATENATE (QUOTE STRING) PATH ">")) (T (CL:IF (EQ PATH :WILD) (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) "*" (CL:SECOND \FILENAME.SYNTAX)) (CL:CONCATENATE (QUOTE STRING) (CL:FIRST \FILENAME.SYNTAX) PATH (CL:SECOND \FILENAME.SYNTAX)))))))) ) ) (CL:DEFUN CL:PATHNAME-HOST (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the host slot of it") (%%PATHNAME-HOST (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-DEVICE (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the device slot of it") (%%PATHNAME-DEVICE (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-DIRECTORY (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the directory slot of it") (%%PATHNAME-DIRECTORY (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-NAME (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the name slot of it") (%%PATHNAME-NAME (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-TYPE (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the type slot of it") (%%PATHNAME-TYPE (PATHNAME PATHNAME))) (CL:DEFUN CL:PATHNAME-VERSION (PATHNAME) (* ;; "takes a stream, string, symbol, or pathname as arg, and returns the version slot of it") (%%PATHNAME-VERSION (PATHNAME PATHNAME))) (DEFINEQ (PATHNAME (CL:LAMBDA (THING) (* hdj " 2-Apr-86 11:01") (* ;; "Turns Thing into a pathname. Thing may be a string, symbol, stream, or pathname.") (CL:VALUES (CL:PARSE-NAMESTRING THING))) ) (CL:MERGE-PATHNAMES (CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*) (DEFAULT-VERSION :NEWEST CL::VERSION-SPECIFIED-P)) (* ; "Edited 21-Aug-90 17:12 by nm") (* ;;; "Merge-Pathnames -- Public Returns a new pathname whose fields are the same as the fields in PATHNAME except that NIL fields are filled in from defaults. Type and Version field are only done if name field has to be done (see manual for explanation). Fills in unspecified slots of Pathname from Defaults (defaults to *default-pathname-defaults*). If the version remains unspecified, gets it from Default-Version.") (LET* ((PATH (PATHNAME PATHNAME)) (DEFAULT-PATH (PATHNAME DEFAULTS)) (HOST (OR (%%PATHNAME-HOST PATH) (%%PATHNAME-HOST DEFAULT-PATH))) (NAME (%%PATHNAME-NAME PATH)) (DEVICE (%%PATHNAME-DEVICE PATH)) (DIR (%%PATHNAME-DIRECTORY PATH)) (DEFAULT-DIR (%%PATHNAME-DIRECTORY DEFAULT-PATH)) DIREND DEFAULT-TYPE) (%%MAKE-PATHNAME HOST (OR DEVICE (%%PATHNAME-DEVICE DEFAULT-PATH)) (OR (AND DIR DEFAULT-DIR (CASE (%%DIRECTORY-COMPONENT-TYPE DIR) (:SUBDIRECTORY (CASE (SETQ DEFAULT-TYPE (%%DIRECTORY-COMPONENT-TYPE DEFAULT-DIR)) (:SUBDIRECTORY (* ; "Default is also a subdirectory, so explicit subdir overrides it") DIR) (T (* ; "Default is a full directory or a relative directory. Make sure to keep the type of the directory being same as the default one.") (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) :WILD) (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (%%DIRECTORY-COMPONENT-PATH DIR)) (%%MAKE-DIRECTORY-COMPONENT :TYPE DEFAULT-TYPE :PATH (CL:CONCATENATE (QUOTE STRING) (%%DIRECTORY-COMPONENT-PATH DEFAULT-DIR) (CL:SECOND \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH DIR))))))) (T (CL:IF (NOT (EQ (%%DIRECTORY-COMPONENT-PATH DIR) :WILD)) DIR DEFAULT-DIR)))) DIR DEFAULT-DIR) (OR NAME (%%PATHNAME-NAME DEFAULT-PATH)) (OR (%%PATHNAME-TYPE PATH) (%%PATHNAME-TYPE DEFAULT-PATH)) (OR (%%PATHNAME-VERSION PATH) (CL:IF NAME (CL:IF CL::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST) (OR (%%PATHNAME-VERSION DEFAULT-PATH) (CL:IF CL::VERSION-SPECIFIED-P DEFAULT-VERSION :NEWEST))))))) ) (FILE-NAME (CL:LAMBDA (FILE) (* hdj " 9-Oct-86 15:12") (LET ((NAME (FULLNAME FILE))) (if (STREAMP NAME) then "" else (MKSTRING NAME)))) ) (CL:HOST-NAMESTRING (CL:LAMBDA (PATHNAME) (* hdj "11-Jun-86 11:29") (* ;; "Returns the host part of PATHNAME as a string.") (%%COMPONENT-STRING (%%PATHNAME-HOST (PATHNAME PATHNAME)))) ) (CL:ENOUGH-NAMESTRING (CL:LAMBDA (PATHNAME &OPTIONAL (DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*)) (* ; "Edited 7-Mar-90 16:49 by nm") (* ;; "Enough-Namestring returns a string which uniquely identifies PATHNAME w.r.t. DEFAULTS.") (LET* ((*PRINT-BASE* 10) (PATH (PATHNAME PATHNAME)) (DEFAULT-PATHNAME (PATHNAME DEFAULTS)) (HOST (%%PATHNAME-HOST PATH)) (DEVICE (%%PATHNAME-DEVICE PATH)) (DIRECTORY (%%PATHNAME-DIRECTORY PATH)) (NAME (%%PATHNAME-NAME PATH)) (TYPE (%%PATHNAME-TYPE PATH)) (VERSION (%%PATHNAME-VERSION PATH)) (RESULT "") (NEED-NAME NIL)) (CL:WHEN (AND HOST (CL:STRING-NOT-EQUAL HOST (%%COMPONENT-STRING (%%PATHNAME-HOST DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) "{" (CL:PRINC-TO-STRING HOST) "}"))) (CL:WHEN (AND DEVICE (CL:STRING-NOT-EQUAL DEVICE (%%COMPONENT-STRING (%%PATHNAME-DEVICE DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING DEVICE) ":"))) (CL:WHEN (AND DIRECTORY (NOT (%%DIRECTORY-COMPONENT-EQUAL DIRECTORY (%%PATHNAME-DIRECTORY DEFAULT-PATHNAME)))) (CL:SETQ RESULT (CASE (%%DIRECTORY-COMPONENT-TYPE DIRECTORY) ((:SUBDIRECTORY :RELATIVE) (* ; "The initial directory delimiter is not needed for a subdirectory and a releative directory. Just concatenate a trail directory delimiter.") (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (%%DIRECTORY-COMPONENT-PATH DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))) (T (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH DIRECTORY) :WILD) (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:FIRST \FILENAME.SYNTAX) "*" (CL:SECOND \FILENAME.SYNTAX)) (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:FIRST \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))))))) (CL:WHEN (AND NAME (CL:STRING-NOT-EQUAL NAME (%%COMPONENT-STRING (%%PATHNAME-NAME DEFAULT-PATHNAME)))) (CL:SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CL:PRINC-TO-STRING NAME)))) (CL:WHEN (AND TYPE (CL:STRING-NOT-EQUAL TYPE (%%COMPONENT-STRING (%%PATHNAME-TYPE DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT "." (CL:PRINC-TO-STRING TYPE)))) (CL:WHEN (AND VERSION (OR NEED-NAME (CL:STRING-NOT-EQUAL (CL:PRINC-TO-STRING VERSION) (%%PATHNAME-VERSION DEFAULT-PATHNAME)))) (SETQ RESULT (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) RESULT (CASE VERSION (:WILD ";*") ((:NEWEST NIL) "") (CL:OTHERWISE (CL:CONCATENATE (QUOTE CL:SIMPLE-STRING) ";" (CL:PRINC-TO-STRING VERSION))))))) RESULT)) ) (%%NUMERIC-STRING-P (LAMBDA (STRING) (* hdj "28-Jul-86 12:25") (AND (CL:STRINGP STRING) (for CHAR instring STRING do (if (OR (ILESSP CHAR (CHARCODE 0)) (IGREATERP CHAR (CHARCODE 9))) then (RETURN NIL)) finally (RETURN T)))) ) ) (CL:DEFUN CL:NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as a string.") (CL:WHEN (AND (STREAMP PATHNAME) (NOT (fetch (STREAM NAMEDP) of PATHNAME))) (* ;  "unnamed streams have the empty string as name.") (CL:RETURN-FROM CL:NAMESTRING "")) [LET* ((PATHNAME (PATHNAME PATHNAME)) (CL::HOST (%%PATHNAME-HOST PATHNAME)) (CL::DEVICE (%%PATHNAME-DEVICE PATHNAME)) (CL:DIRECTORY (%%PATHNAME-DIRECTORY PATHNAME)) (CL::NAME (%%PATHNAME-NAME PATHNAME)) (TYPE (%%PATHNAME-TYPE PATHNAME)) (CL::VERSION (%%PATHNAME-VERSION PATHNAME)) (CL::RESULT NIL)) (CONCATLIST (NCONC (CL:WHEN CL::HOST (LIST "{" CL::HOST "}")) (CL:WHEN CL::DEVICE (LIST CL::DEVICE ":")) (CL:WHEN CL:DIRECTORY (CASE (%%DIRECTORY-COMPONENT-TYPE CL:DIRECTORY) ((:SUBDIRECTORY :RELATIVE) (* ; "The initial directory delimiter is not needed for a subdirectory and a releative directory. Just concatenate a trail directory delimiter.") (LIST (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) (CL:SECOND \FILENAME.SYNTAX))) (T (CL:IF (EQ (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) :WILD) NIL (LIST (CL:FIRST \FILENAME.SYNTAX) (%%DIRECTORY-COMPONENT-PATH CL:DIRECTORY) (CL:SECOND \FILENAME.SYNTAX)))))) (CL:WHEN CL::NAME (LIST (CL:IF (EQ CL::NAME :WILD) "*" CL::NAME))) (CL:WHEN TYPE (LIST "." (CL:IF (EQ TYPE :WILD) "*" TYPE))) (CL:WHEN (AND CL::VERSION (OR (NOT (EQ CL::VERSION ':NEWEST)) CL::NAME TYPE)) [COND [[AND (EQ \MACHINETYPE \MAIKO) (STREQUAL "UNIX" (U-CASE (MKSTRING CL::HOST] (* ; "{UNIX} device on Maiko breaks the Interlisp-D original file naming convention. The trail semicolonn is regarded as a part of the file name rather than a %"highest versioned%" file! Thus, if :newest, we have to elimit the semicolon.") (CASE CL::VERSION ((:WILD) (LIST (CL:THIRD \FILENAME.SYNTAX)) "*") ((:NEWEST) (LIST "")) (T (LIST (CL:THIRD \FILENAME.SYNTAX) CL::VERSION)))] (T (LIST (CL:THIRD \FILENAME.SYNTAX) (CASE CL::VERSION ((:WILD) "*") ((:NEWEST) "") (T CL::VERSION))])]) (CL:DEFUN CL:PARSE-NAMESTRING (THING &OPTIONAL HOST DEFAULTS &KEY (START 0) END (JUNK-ALLOWED NIL)) (* ;;; "Parses a string representation of a pathname into a pathname. For details on the other silly arguments see the manual. NOTE that this version ignores JUNK-ALLOWED (because UNPACKFILENAME a.k.a. PARSE-NAMESTRING1 will parse anything) It also ignores Host and defaults since we don't support non-standard hosts") (DECLARE (IGNORE HOST DEFAULTS JUNK-ALLOWED)) (CL:TYPECASE THING (STRING NIL) (PATHNAME (CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:VALUES THING START))) (STREAM (CL:IF (XCL:SYNONYM-STREAM-P THING) [CL:RETURN-FROM CL:PARSE-NAMESTRING (CL:PARSE-NAMESTRING (CL:SYMBOL-VALUE ( XCL:SYNONYM-STREAM-SYMBOL THING] (SETQ THING (FILE-NAME THING)))) (CL:SYMBOL (SETQ THING (CL:SYMBOL-NAME THING))) (T (CL:ERROR "This is of an inappropriate type for parse-namestring: ~S" THING))) (CL:UNLESS END (SETQ END (CL:LENGTH THING))) (LET* ((PATH-LIST (UNPACKFILENAME.STRING (SUBSTRING THING (+ 1 START) END) NIL NIL NIL NIL T))) (CL:VALUES [CL:MAKE-PATHNAME :HOST (LISTGET PATH-LIST 'HOST) :DEVICE (LISTGET PATH-LIST 'DEVICE) :DIRECTORY [LET [(CL:DIRECTORY (LISTGET PATH-LIST 'DIRECTORY)) (CL::SUBDIRECTORY (LISTGET PATH-LIST 'SUBDIRECTORY)) (CL::RELATIVEDIRECTORY (LISTGET PATH-LIST 'RELATIVEDIRECTORY] (COND (CL:DIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH (%%WILD-NAME CL:DIRECTORY))) (CL::SUBDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :SUBDIRECTORY :PATH (%%WILD-NAME CL::SUBDIRECTORY)) ) (CL::RELATIVEDIRECTORY (%%MAKE-DIRECTORY-COMPONENT :TYPE :RELATIVE :PATH (%%WILD-NAME CL::RELATIVEDIRECTORY)) ) (T (%%MAKE-DIRECTORY-COMPONENT :TYPE :DIRECTORY :PATH :WILD] :NAME (%%WILD-NAME (LISTGET PATH-LIST 'NAME)) :TYPE (%%WILD-NAME (LISTGET PATH-LIST 'EXTENSION)) :VERSION (LET [(VERSION (LISTGET PATH-LIST 'VERSION] (CL:IF (CL:EQUAL VERSION "") :NEWEST (CL:IF (CL:EQUAL VERSION "*") :WILD (MKATOM VERSION)))] END))) (CL:DEFUN PARSE-NAMESTRING1 (FILE) (* ;;; "Given a string or atom representation of a file name, unpack it into its component parts") (* ;;; "crudely hacked from UNPACKFILENAME.STRING") (PROG ((POS 1) TEM TEM2 BEYONDNAME BEYONDEXT VAL CODE HOSTP SUBDIREND PACKFLG DIRFLG ONEFIELDFLG) (COND ((NULL FILE) (RETURN (CONS (SUB1 POS) NIL))) ((OR (LITATOM FILE) (CL:STRINGP FILE) (NUMBERP FILE))) [(type? STREAM FILE) (* ;  "For streams, use full name. If anonymous, fake it") (SETQ FILE (OR (ffetch FULLFILENAME of FILE) (RETURN (CONS (SUB1 POS) (LIST 'NAME FILE] (T (\ILLEGAL.ARG FILE))) (COND ((SELCHARQ (NTHCHARCODE FILE 1) ({ (* ; "normal use in Interlisp-D") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE }) FILE 2) 0)))) (%[ (* ;  "some Xerox and Arpanet systems use `[' for host") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE "]") FILE 2) 0)))) (%( (* ;  "this is the standard for Xerox product file servers") (SETQ TEM (SUB1 (OR (\UPF.NEXTPOS (CHARCODE ")") FILE 2) 0)))) NIL) (%%UNPACKFILE1 'HOST 2 TEM FILE PACKFLG ONEFIELDFLG VAL) [COND ((EQ TEM -1) (RETURN (CONS (SUB1 POS) (DREVERSE VAL] (SETQ POS (IPLUS TEM 2)) (SETQ HOSTP T))) (COND ((SETQ TEM (LASTCHPOS (CHARCODE %:) FILE POS)) (SETQ TEM (SUB1 TEM)) (%%UNPACKFILE1 'DEVICE POS TEM FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (PLUS TEM 2)) (SETQ HOSTP T))) (COND [(EQ DIRFLG 'RETURN) (LET ((TYPE 'DIRECTORY) (START (SELCHARQ (NTHCHARCODE FILE POS) (NIL (RETURN (CONS (SUB1 POS) (DREVERSE VAL)))) ((/ <) (ADD1 POS)) POS)) END) (SETQ END (SELCHARQ (NTHCHARCODE FILE -1) ((/ >) [COND ((AND (EQ START POS) (NOT HOSTP)) (* ;  "Didn't start with a directory delimiter, but it ends with one, so this must be a subdirectory") (SETQ TYPE 'SUBDIRECTORY] -2) (PROGN -1))) (%%UNPACKFILE1 TYPE START END FILE PACKFLG ONEFIELDFLG VAL)) (RETURN (CONS (SUB1 POS) (DREVERSE VAL] ((SELCHARQ (NTHCHARCODE FILE POS) (/ (* ;  "unix and the `xerox standard' use / for delimiter") (SETQ TEM (LASTCHPOS (CHARCODE /) FILE (ADD1 POS)))) ((< >) (* ;  "Interlisp-D and most other Xerox systems, and Tops-20/Tenex use <>. Jericho uses >>") (SETQ TEM (LASTCHPOS (CHARCODE >) FILE (ADD1 POS)))) NIL) (%%UNPACKFILE1 'DIRECTORY (ADD1 POS) (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 TEM)) (SETQ HOSTP T))) [OR (SETQ CODE (NTHCHARCODE FILE (SETQ TEM POS))) (RETURN (CONS (SUB1 POS) (DREVERSE VAL] NAMELP (SELCHARQ CODE ((%. ! ; NIL) (* ;  "NAME and SUBDIRECTORY fields definitely terminated by now") (COND ((AND (EQ CODE (CHARCODE %.)) (NOT BEYONDNAME) (SETQ TEM2 (STRPOS "." FILE (ADD1 TEM))) (SETQ TEM2 (NTHCHAR FILE (ADD1 TEM2))) (NOT (FIXP TEM2))) (* ;; "If there's another dot followed by something other than a numeric extension, then ignore this dot, since we'll get another chance") (GO NEXTCHAR))) [COND (SUBDIREND (%%UNPACKFILE1 'SUBDIRECTORY POS (SUB1 SUBDIREND) FILE PACKFLG ONEFIELDFLG VAL) (SETQ POS (ADD1 SUBDIREND)) (SETQ SUBDIREND) (COND ((AND (NULL CODE) (EQ POS TEM)) (* ;  "Nothing follows the subdirectory; null name is NOT implied") (RETURN (CONS (SUB1 POS) (DREVERSE VAL] (%%UNPACKFILE1 [COND ((NOT BEYONDNAME) (COND ((NEQ CODE (CHARCODE %.)) (SETQQ BEYONDEXT ;))) (SETQQ BEYONDNAME NAME)) ((NOT BEYONDEXT) (SETQ BEYONDEXT (COND ((NEQ CODE (CHARCODE %.)) ';) (T T))) 'TYPE) (T (SELCHARQ (AND (EQ BEYONDEXT ';) (NTHCHARCODE FILE POS)) (P 'PROTECTION) (A (add POS 1) 'ACCOUNT) ((T S) 'TEMPORARY) 'VERSION] POS (SUB1 TEM) FILE PACKFLG ONEFIELDFLG VAL) [COND ((NULL CODE) (* ; "End of string") (RETURN (CONS (SUB1 POS) (DREVERSE VAL] (SETQ POS (ADD1 TEM))) (%' (* ; "Quoter") (add TEM 1)) ((/ >) (* ;  "Subdirectory terminating character") (COND ((AND (NOT HOSTP) (NOT BEYONDNAME) DIRFLG) (* ;  "Ok to treat this as a subdirectory") (SETQ SUBDIREND TEM)))) NIL) NEXTCHAR (SETQ CODE (NTHCHARCODE FILE (add TEM 1))) (GO NAMELP))) (CL:DEFUN CL:TRUENAME (PATHNAME) (* ;;; "Return the pathname for the actual file described by the pathname. An error is signaled if no such file exists. PATHNAME can be a pathname, string, symbol, or stream. Synonym streams are followed to their sources") [if (STREAMP PATHNAME) then (COND [(XCL:SYNONYM-STREAM-P PATHNAME) (CL:RETURN-FROM CL:TRUENAME (CL:TRUENAME (CL:SYMBOL-VALUE ( XCL:SYNONYM-STREAM-SYMBOL PATHNAME] ((NOT (fetch (STREAM NAMEDP) of PATHNAME)) (* ;  "let's catch this case, rather than have the message 'The file %"%" does not exist' appear.") (CL:ERROR "The stream ~S has no corresponding named file." PATHNAME] (LET ((RESULT (CL:PROBE-FILE PATHNAME))) (CL:UNLESS RESULT (CL:ERROR "The file ~S does not exist." (CL:NAMESTRING PATHNAME))) RESULT)) (CL:DEFUN %%MAKE-PATHNAME (HOST DEVICE DIRECTORY NAME TYPE VERSION) (%%%%MAKE-PATHNAME :HOST HOST :DEVICE DEVICE :DIRECTORY DIRECTORY :NAME NAME :TYPE TYPE :VERSION VERSION)) (CL:DEFUN %%PATHNAME-EQUAL (PATHNAME1 PATHNAME2) (AND (CL:EQUAL (%%PATHNAME-HOST PATHNAME1) (%%PATHNAME-HOST PATHNAME2)) (CL:EQUAL (%%PATHNAME-DEVICE PATHNAME1) (%%PATHNAME-DEVICE PATHNAME2)) (%%DIRECTORY-COMPONENT-EQUAL (%%PATHNAME-DIRECTORY PATHNAME1) (%%PATHNAME-DIRECTORY PATHNAME2)) (CL:EQUAL (%%PATHNAME-NAME PATHNAME1) (%%PATHNAME-NAME PATHNAME2)) (CL:EQUAL (%%PATHNAME-TYPE PATHNAME1) (%%PATHNAME-TYPE PATHNAME2)) (CL:EQUAL (%%PATHNAME-VERSION PATHNAME1) (%%PATHNAME-VERSION PATHNAME2)))) (CL:DEFUN %%DIRECTORY-COMPONENT-EQUAL (COMPONENT1 COMPONENT2) (CL:IF (AND (%%DIRECTORY-COMPONENT-P COMPONENT1) (%%DIRECTORY-COMPONENT-P COMPONENT2)) (AND (CL:EQUAL (%%DIRECTORY-COMPONENT-TYPE COMPONENT1) (%%DIRECTORY-COMPONENT-TYPE COMPONENT2)) (CL:EQUAL (%%DIRECTORY-COMPONENT-PATH COMPONENT1) (%%DIRECTORY-COMPONENT-PATH COMPONENT2))) (CL:EQUAL COMPONENT1 COMPONENT2))) (CL:DEFUN %%INITIALIZE-DEFAULT-PATHNAME () (DECLARE (GLOBALVARS *DEFAULT-PATHNAME-DEFAULTS* \CONNECTED.DIRECTORY)) (if (NOT (BOUNDP '\CONNECTED.DIRECTORY)) then (SETQ \CONNECTED.DIRECTORY '{DSK})) [SETQ *DEFAULT-PATHNAME-DEFAULTS* (CL:PARSE-NAMESTRING \CONNECTED.DIRECTORY (FILENAMEFIELD \CONNECTED.DIRECTORY 'HOST] (CL:SETF (%%PATHNAME-VERSION *DEFAULT-PATHNAME-DEFAULTS*) :NEWEST) *DEFAULT-PATHNAME-DEFAULTS*) (CL:DEFVAR *DEFAULT-PATHNAME-DEFAULTS*) (* ;; "Interlisp-D compatibility") (CL:DEFUN INTERLISP-NAMESTRING (PATHNAME) (* ;;; "Returns the full form of PATHNAME as an Interlisp string.") (MKSTRING (CL:NAMESTRING PATHNAME))) (CL:DEFUN UNPACKPATHNAME.STRING (FILE &OPTIONAL ONEFIELDFLG DIRFLG ATOMFLG) (* ;; "Simulate the action of UNPACKFILENAME.STRING on a pathname") (* ;; "") (DECLARE (IGNORE DIRFLG)) [if ONEFIELDFLG then [AND (CL:CONSP ONEFIELDFLG) (SETQ ONEFIELDFLG (CAR (CL:INTERSECTION ONEFIELDFLG '(HOST DEVICE DIRECTORY NAME EXTENSION VERSION] (LET [(RESULT (CASE ONEFIELDFLG (HOST (CL:PATHNAME-HOST FILE)) (DEVICE (CL:PATHNAME-DEVICE FILE)) (DIRECTORY (CL:PATHNAME-DIRECTORY FILE)) (NAME (CL:PATHNAME-NAME FILE)) (EXTENSION (CL:PATHNAME-TYPE FILE)) (VERSION (CL:PATHNAME-VERSION FILE)) (CL:OTHERWISE NIL))] (if ATOMFLG then (MKATOM RESULT) else RESULT)) else (LET ((COMPONENT)) (APPEND (if (SETQ COMPONENT (CL:PATHNAME-HOST FILE)) then (LIST 'HOST (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT) COMPONENT)) (if (SETQ COMPONENT (CL:PATHNAME-DEVICE FILE)) then (LIST 'DEVICE (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-DIRECTORY FILE)) then (LIST 'DIRECTORY (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-NAME FILE)) then (LIST 'NAME (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-TYPE FILE)) then (LIST 'EXTENSION (if ATOMFLG then (MKATOM COMPONENT) else COMPONENT))) (if (SETQ COMPONENT (CL:PATHNAME-VERSION FILE)) then (LIST 'VERSION (if ATOMFLG then (MKATOM COMPONENT) else (MKSTRING COMPONENT]) (CL:DEFUN CL:FILE-NAMESTRING (PATHNAME) (LET* ((*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (PATH (PATHNAME PATHNAME)) [RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING (MKSTRING (%%COMPONENT-STRING ( %%PATHNAME-NAME PATH))) "." (MKSTRING (%%COMPONENT-STRING (%%PATHNAME-TYPE PATH] (VERSION (%%PATHNAME-VERSION PATH))) (CL:WHEN VERSION [SETQ RESULT (CL:CONCATENATE 'CL:SIMPLE-STRING RESULT (CASE VERSION (:WILD ";*") (:NEWEST ";") (CL:OTHERWISE (CL:CONCATENATE 'CL:SIMPLE-STRING ";" (CL:PRINC-TO-STRING VERSION))))]) RESULT)) (CL:DEFUN CL:DIRECTORY-NAMESTRING (PATHNAME) (* ;; "Returns the directory part of PATHNAME as a string.") (%%COMPONENT-STRING (%%PATHNAME-DIRECTORY (PATHNAME PATHNAME)))) (DECLARE%: DONTEVAL@LOAD DOCOPY (%%INITIALIZE-DEFAULT-PATHNAME) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:HOST-NAMESTRING FILE-NAME CL:MERGE-PATHNAMES PATHNAME %%PRINT-DIRECTORY-COMPONENT CL:MAKE-PATHNAME %%PRINT-PATHNAME) ) (PRETTYCOMPRINT CMLPATHNAMECOMS) (RPAQQ CMLPATHNAMECOMS [ (* ;; "Common Lisp pathname functions") (PROP FILETYPE CMLPATHNAME) (COMS (* ;; "useful macros") (FUNCTIONS %%WILD-NAME %%COMPONENT-STRING %%UNPACKFILE1)) (STRUCTURES PATHNAME DIRECTORY-COMPONENT) (FNS %%PRINT-PATHNAME CL:MAKE-PATHNAME %%PRINT-DIRECTORY-COMPONENT) (FUNCTIONS CL:PATHNAME-HOST CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION) (FNS PATHNAME CL:MERGE-PATHNAMES FILE-NAME CL:HOST-NAMESTRING CL:ENOUGH-NAMESTRING %%NUMERIC-STRING-P) (FUNCTIONS CL:NAMESTRING CL:PARSE-NAMESTRING PARSE-NAMESTRING1 CL:TRUENAME) (FUNCTIONS %%MAKE-PATHNAME) (FUNCTIONS %%PATHNAME-EQUAL %%DIRECTORY-COMPONENT-EQUAL) (FUNCTIONS %%INITIALIZE-DEFAULT-PATHNAME) (VARIABLES *DEFAULT-PATHNAME-DEFAULTS*) (COMS (* ;; "Interlisp-D compatibility") (FUNCTIONS INTERLISP-NAMESTRING UNPACKPATHNAME.STRING)) (FUNCTIONS CL:FILE-NAMESTRING CL:DIRECTORY-NAMESTRING) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (%%INITIALIZE-DEFAULT-PATHNAME))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:ENOUGH-NAMESTRING CL:MERGE-PATHNAMES CL:MAKE-PATHNAME) ) (PUTPROPS CMLPATHNAME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3597 9368 (%%PRINT-PATHNAME 3607 . 3768) (CL:MAKE-PATHNAME 3770 . 8520) ( %%PRINT-DIRECTORY-COMPONENT 8522 . 9366)) (10569 15893 (PATHNAME 10579 . 10771) (CL:MERGE-PATHNAMES 10773 . 12859) (FILE-NAME 12861 . 13002) (CL:HOST-NAMESTRING 13004 . 13193) (CL:ENOUGH-NAMESTRING 13195 . 15660) (%%NUMERIC-STRING-P 15662 . 15891))))) STOP \ No newline at end of file diff --git a/sources/CMLPRED b/sources/CMLPRED new file mode 100644 index 00000000..97744728 --- /dev/null +++ b/sources/CMLPRED @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:19:02" {DSK}local>lde>lispcore>sources>CMLPRED.;2 1886 changes to%: (VARS CMLPREDCOMS) previous date%: "24-Oct-86 22:12:28" {DSK}local>lde>lispcore>sources>CMLPRED.;1) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPREDCOMS) (RPAQQ CMLPREDCOMS ((FNS CL:CONSP CL:ATOM CL:LISTP CL:INTEGERP CL:SYMBOLP) (OPTIMIZERS CL:ATOM CL:LISTP CL:CONSP CL:INTEGERP CL:SYMBOLP) (PROP FILETYPE CMLPRED))) (DEFINEQ (CL:CONSP (LAMBDA (X) (* raf " 4-Nov-85 19:02") (AND (LISTP X) T))) (CL:ATOM (LAMBDA (X) (NLISTP X))) (CL:LISTP (LAMBDA (X) (OR (NULL X) (AND (LISTP X) T)))) (CL:INTEGERP (LAMBDA (X) (AND (FIXP X) T))) (CL:SYMBOLP (LAMBDA (X) (LITATOM X))) ) (DEFOPTIMIZER CL:ATOM (&REST ARGS) (CONS 'NLISTP ARGS)) (DEFOPTIMIZER CL:LISTP (&REST ARGS) (CONS '(OPENLAMBDA (X) (OR (NULL X) (AND (LISTP X) T))) ARGS)) (DEFOPTIMIZER CL:CONSP (X) `(AND (LISTP ,X) T)) (DEFOPTIMIZER CL:INTEGERP (X) `(AND (FIXP ,X) T)) (DEFOPTIMIZER CL:SYMBOLP (&REST ARGS) (CONS 'LITATOM ARGS)) (PUTPROPS CMLPRED FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLPRED COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (627 1026 (CL:CONSP 637 . 778) (CL:ATOM 780 . 823) (CL:LISTP 825 . 911) (CL:INTEGERP 913 . 975) (CL:SYMBOLP 977 . 1024))))) STOP \ No newline at end of file diff --git a/sources/CMLPRINT b/sources/CMLPRINT new file mode 100644 index 00000000..0bb115a6 --- /dev/null +++ b/sources/CMLPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:19:58" {DSK}local>lde>lispcore>sources>CMLPRINT.;2 9569 changes to%: (VARS CMLPRINTCOMS) previous date%: "16-Feb-88 11:47:48" {DSK}local>lde>lispcore>sources>CMLPRINT.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPRINTCOMS) (RPAQQ CMLPRINTCOMS [(FNS WRITE CL:WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI CL:FRESH-LINE CL:FINISH-OUTPUT CL:FORCE-OUTPUT CL:CLEAR-OUTPUT CL:PPRINT CL:PRINC) (FUNCTIONS \WRITE1) (FNS CL:WRITE-TO-STRING CL:PRIN1-TO-STRING CL:PRINC-TO-STRING) (FUNCTIONS CL:WRITE-LINE) (INITVARS (XCL:*PRINT-STRUCTURE*)) (PROP FILETYPE CMLPRINT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:WRITE-TO-STRING CL:PRINC CL:PPRINT CL:PRINT CL:PRIN1 CL:WRITE-CHAR WRITE]) (DEFINEQ (WRITE (CL:LAMBDA (OBJECT &KEY (STREAM *STANDARD-OUTPUT*) ((:ESCAPE *PRINT-ESCAPE*) *PRINT-ESCAPE*) ((:RADIX *PRINT-RADIX*) *PRINT-RADIX*) ((:BASE *PRINT-BASE*) *PRINT-BASE*) ((:LEVEL *PRINT-LEVEL*) *PRINT-LEVEL*) ((:LENGTH *PRINT-LENGTH*) *PRINT-LENGTH*) ((:CASE *PRINT-CASE*) *PRINT-CASE*) ((:GENSYM *PRINT-GENSYM*) *PRINT-GENSYM*) ((:ARRAY *PRINT-ARRAY*) *PRINT-ARRAY*) ((:PRETTY *PRINT-PRETTY*) *PRINT-PRETTY*) ((:CIRCLE *PRINT-CIRCLE*) *PRINT-CIRCLE*)) (* ; "Edited 20-Feb-87 16:56 by bvm:") (DECLARE (CL:SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES)) (* ; "Make sure STREAM ends up as an appropriate stream") (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) [COND ((OR (NOT *PRINT-CIRCLE*) *PRINT-CIRCLE-HASHTABLE*) (\WRITE1 OBJECT STREAM)) (T (LET ((*PRINT-CIRCLE-NUMBER* 1) (*PRINT-CIRCLE-HASHTABLE* (CL:MAKE-HASH-TABLE)) THERE-ARE-CIRCLES) (DECLARE (CL:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE* THERE-ARE-CIRCLES)) (PRINT-CIRCLE-SCAN OBJECT) (COND ((NOT THERE-ARE-CIRCLES) (CL:SETQ *PRINT-CIRCLE-HASHTABLE* NIL))) (\WRITE1 OBJECT STREAM] OBJECT)) (CL:WRITE-CHAR (CL:LAMBDA (CHARACTER &OPTIONAL OUTPUT-STREAM) (* ; "Edited 20-Feb-87 16:57 by bvm:") (\OUTCHAR (\GETSTREAM OUTPUT-STREAM 'OUTPUT) (CL:CHAR-INT CHARACTER)) CHARACTER)) (CL:PRIN1 (CL:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM) (* ; "Edited 20-Feb-87 16:58 by bvm:") (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T))) (CL:PRINT (CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*)) (* lmm " 4-May-86 03:15") (TERPRI OUTPUT-STREAM) (PROG1 (CL:PRIN1 OBJECT OUTPUT-STREAM) (SPACES 1 OUTPUT-STREAM)))) (CL:TERPRI [LAMBDA (OUTPUT-STREAM) (* bvm%: "19-May-86 15:53") (TERPRI (OR OUTPUT-STREAM *STANDARD-OUTPUT*]) (CL:FRESH-LINE [LAMBDA (OUTPUT-STREAM) (* bvm%: "19-May-86 15:53") (FRESHLINE (OR OUTPUT-STREAM *STANDARD-OUTPUT*]) (CL:FINISH-OUTPUT [LAMBDA (OUTPUT-STREAM) (* bvm%: "19-May-86 15:53") (FORCEOUTPUT (OR OUTPUT-STREAM *STANDARD-OUTPUT*) T) NIL]) (CL:FORCE-OUTPUT [LAMBDA (OUTPUT-STREAM) (* bvm%: "19-May-86 15:53") (FORCEOUTPUT (OR OUTPUT-STREAM *STANDARD-OUTPUT*)) NIL]) (CL:CLEAR-OUTPUT [LAMBDA (OUTPUT-STREAM) (* bvm%: "19-May-86 15:38") NIL]) (CL:PPRINT (CL:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*)) (* lmm " 4-May-86 03:19") (TERPRI OUTPUT-STREAM) (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE T :PRETTY T) (CL:VALUES))) (CL:PRINC (CL:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM) (* ; "Edited 20-Feb-87 16:59 by bvm:") (WRITE OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL))) ) (CL:DEFUN \WRITE1 (OBJECT STREAM) (CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*) (NOT *PRINT-CIRCLE-HASHTABLE*)) *PRINT-ESCAPE*) (* ;; "If :pretty is on, and either :circle is not, or it was and no circles exist, and :escape is on...") (* ;; "For the moment, *PRINT-CIRCLE* and *PRINT-ESCAPE* override *PRINT-PRETTY* completely. This leaves *PRINT-LEVEL* AND *PRINT-LENGTH* ignored when *PRINT-PRETTY* is on; this must be fixed later... probably by a new pretty-printer (ecch).") (LET (FONTCHANGEFLG) (DECLARE (CL:SPECIAL FONTCHANGEFLG)) (PRINTDEF OBJECT (POSITION STREAM) NIL NIL NIL STREAM)) (* ;; "otherwise just print it all on one line") (LET (\THISFILELINELENGTH) (DECLARE (CL:SPECIAL \THISFILELINELENGTH)) (* ;; "CommonLisp streams do not observe line length") (\PRINDATUM OBJECT (\GETSTREAM STREAM 'OUTPUT) 0)))) (DEFINEQ (CL:WRITE-TO-STRING (CL:LAMBDA (OBJECT &KEY ((:ESCAPE *PRINT-ESCAPE*) *PRINT-ESCAPE*) ((:RADIX *PRINT-RADIX*) *PRINT-RADIX*) ((:BASE *PRINT-BASE*) *PRINT-BASE*) ((:CIRCLE *PRINT-CIRCLE*) *PRINT-CIRCLE*) ((:PRETTY *PRINT-PRETTY*) *PRINT-PRETTY*) ((:LEVEL *PRINT-LEVEL*) *PRINT-LEVEL*) ((:LENGTH *PRINT-LENGTH*) *PRINT-LENGTH*) ((:CASE *PRINT-CASE*) *PRINT-CASE*) ((:ARRAY *PRINT-ARRAY*) *PRINT-ARRAY*) ((:GENSYM *PRINT-GENSYM*) *PRINT-GENSYM*)) (* bvm%: "13-May-86 15:38") "Returns the printed representation of OBJECT as a string." (\PRINDATUM.TO.STRING OBJECT))) (CL:PRIN1-TO-STRING [LAMBDA (OBJECT) (* bvm%: "13-May-86 15:24") (* * Produces a string consisting of the output of (CL:PRIN1 OBJECT)) (LET ((*PRINT-ESCAPE* T)) (\PRINDATUM.TO.STRING OBJECT]) (CL:PRINC-TO-STRING [LAMBDA (OBJECT) (* bvm%: "13-May-86 15:23") (* ;;; "A lot like MKSTRING, but not quite. Produces a string consisting of the output of (PRINC OBJECT)") (LET ((*PRINT-ESCAPE* NIL)) (\PRINDATUM.TO.STRING OBJECT]) ) (CL:DEFUN CL:WRITE-LINE (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*) &KEY (CL::START 0) CL::END) (PROG1 (WRITE-STRING* STRING STREAM CL::START CL::END) (CL:TERPRI STREAM))) (RPAQ? XCL:*PRINT-STRUCTURE* ) (PUTPROPS CMLPRINT FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:WRITE-TO-STRING CL:PRINC CL:PPRINT CL:PRINT CL:PRIN1 CL:WRITE-CHAR WRITE) ) (PRETTYCOMPRINT CMLPRINTCOMS) (RPAQQ CMLPRINTCOMS [(FNS WRITE CL:WRITE-CHAR CL:PRIN1 CL:PRINT CL:TERPRI CL:FRESH-LINE CL:FINISH-OUTPUT CL:FORCE-OUTPUT CL:CLEAR-OUTPUT CL:PPRINT CL:PRINC) (FUNCTIONS \WRITE1) (FNS CL:WRITE-TO-STRING CL:PRIN1-TO-STRING CL:PRINC-TO-STRING) (FUNCTIONS CL:WRITE-LINE) (INITVARS (XCL:*PRINT-STRUCTURE*)) (PROP FILETYPE CMLPRINT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:WRITE-TO-STRING CL:PPRINT CL:PRINT WRITE]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:WRITE-TO-STRING CL:PPRINT CL:PRINT WRITE) ) (PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1101 5377 (WRITE 1111 . 3322) (CL:WRITE-CHAR 3324 . 3571) (CL:PRIN1 3573 . 3749) ( CL:PRINT 3751 . 4057) (CL:TERPRI 4059 . 4220) (CL:FRESH-LINE 4222 . 4390) (CL:FINISH-OUTPUT 4392 . 4588) (CL:FORCE-OUTPUT 4590 . 4772) (CL:CLEAR-OUTPUT 4774 . 4893) (CL:PPRINT 4895 . 5195) (CL:PRINC 5197 . 5375)) (6431 8056 (CL:WRITE-TO-STRING 6441 . 7451) (CL:PRIN1-TO-STRING 7453 . 7747) ( CL:PRINC-TO-STRING 7749 . 8054))))) STOP \ No newline at end of file diff --git a/sources/CMLPROGV b/sources/CMLPROGV new file mode 100644 index 00000000..c8933fd2 --- /dev/null +++ b/sources/CMLPROGV @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "30-Jan-91 19:07:51" {DSK}sybalsky>3-BYTE-ATOM-CHANGES>CMLPROGV.;4 5921 changes to%: (FNS \DO.PROGV.SETUP.FRAME.AND.EXECUTE) previous date%: "21-Jan-91 17:10:45" {DSK}sybalsky>3-BYTE-ATOM-CHANGES>CMLPROGV.;2) (* ; " Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLPROGVCOMS) (RPAQQ CMLPROGVCOMS ((FNS \DO.PROGV \DO.PROGV.SETUP.FRAME.AND.EXECUTE) (SPECIAL-FORMS CL:PROGV) (PROP DMACRO CL:PROGV) (PROP FILETYPE CMLPROGV))) (DEFINEQ (\DO.PROGV [LAMBDA (VARS VALUES FNTOCALL) (* ; "Edited 21-Jan-91 17:10 by jds") (* ;; "call FNTOCALL after binding VARS to VALUES") (DECLARE (LOCALVARS . T)) (LET ((NVARS 0) NTSIZE NNILS TMP) (for VAR in VARS do (* ;; "Count number of vars to bind, check their validity") (CHECK-BINDABLE VAR) (add NVARS 1)) (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\DO.PROGV.SETUP.FRAME.AND.EXECUTE NNILS NVARS NTSIZE VARS VALUES)) (CL:FUNCALL FNTOCALL]) (\DO.PROGV.SETUP.FRAME.AND.EXECUTE [LAMBDA (NNILS NVARS NTSIZE VARS VALUES) (* ; "Edited 30-Jan-91 19:02 by jds") (DECLARE (LOCALVARS . T)) (PROG ((CALLER (\MYALINK)) NILSTART NT HEADER) (* ;;; "Create a nametable inside CALLER where \DO.PROGV pushed all those NILs") (SETQ HEADER (fetch (FX FNHEADER) of CALLER)) (* ;  "The function header of code for \DO.PROGV") (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK) of CALLER) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "Address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") (for VAR in VARS as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of CALLER)) WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT ( WORDSPERNAMEENTRY )) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) as VALUEOFF from NILSTART by WORDSPERCELL do [PUTBASEPTR \STACKSPACE VALUEOFF (COND (VALUES (pop VALUES)) (T 'NOBIND] (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR)) (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)) (* ;;; "now fix up header of NT") (replace (FNHEADER FRAMENAME) of NT with '\PROGV) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (replace (FX NAMETABLE) of CALLER with NT]) ) (DEFINE-SPECIAL-FORM CL:PROGV (CL::VARIABLES CL:VALUES &REST CL::$$PROGV-FORMS &ENVIRONMENT CL::$$PROGV-ENVIRONMENT) (* ;; "$$PROGV-FORMS and $$PROGV-ENVIRONMENT are named this wierd way because the interpreter is still compiled with the ByteCompiler and those variables will eventually be made special by that compiler. They can get normal names whenever the new compiler starts being used on this file.") [\DO.PROGV (CL:EVAL CL::VARIABLES CL::$$PROGV-ENVIRONMENT) (CL:EVAL CL:VALUES CL::$$PROGV-ENVIRONMENT) #'(CL:LAMBDA NIL (\EVAL-PROGN CL::$$PROGV-FORMS CL::$$PROGV-ENVIRONMENT]) (PUTPROPS CL:PROGV DMACRO [(VARIABLES VALUES . FORMS) (\DO.PROGV VARIABLES VALUES #'(LAMBDA NIL . FORMS]) (PUTPROPS CMLPROGV FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLPROGV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (690 4946 (\DO.PROGV 700 . 2113) (\DO.PROGV.SETUP.FRAME.AND.EXECUTE 2115 . 4944))))) STOP \ No newline at end of file diff --git a/sources/CMLRAND b/sources/CMLRAND new file mode 100644 index 00000000..f84fdce0 --- /dev/null +++ b/sources/CMLRAND @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 14:21:56" IL:|{DSK}local>lde>lispcore>sources>CMLRAND.;2| 5977 IL:|changes| IL:|to:| (IL:VARS IL:CMLRANDCOMS) IL:|previous| IL:|date:| "21-Jan-88 11:43:47" IL:|{DSK}local>lde>lispcore>sources>CMLRAND.;1| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLRANDCOMS) (IL:RPAQQ IL:CMLRANDCOMS ((IL:STRUCTURES RANDOM-STATE) (IL:VARIABLES %RANDOM-SIZE) (IL:FUNCTIONS %MAKE-RANDOM-ARRAY %PRINT-RANDOM-STATE %RANDOM MAKE-RANDOM-STATE RANDOM) (IL:VARIABLES *RANDOM-STATE*) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLRAND) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)))) (DEFSTRUCT (RANDOM-STATE (:CONSTRUCTOR %MAKE-RANDOM-STATE) (:PRINT-FUNCTION %PRINT-RANDOM-STATE) (:COPIER NIL)) (I 0) (J 30) (ARRAY (%MAKE-RANDOM-ARRAY))) (DEFCONSTANT %RANDOM-SIZE 55) (DEFUN %MAKE-RANDOM-ARRAY (&OPTIONAL SEED1 SEED2) (MAKE-ARRAY %RANDOM-SIZE :INITIAL-CONTENTS (LET ((RANDOM-LIST '(53375 47430 1274 55702 61592 27723 11236 16824 35838 62289 11525 37822 34676 105 58750 27759 9988 4217 56951 30292 24550 1397 54588 54264 43300 3862 39006 11386 52259 1055 955 16320 19910 58470 3263 64657 1704 17373 56820 17255 51637 47962 26272 4464 2884 51773 39422 64835 57733 34919 5315 12110 15116 10133 10816)) (RANDOM-CONST-A (OR SEED1 (IL:CLOCK))) (RANDOM-CONST-B (OR SEED2 (IL:IDATE)))) (MAPCAR #'(LAMBDA (X) (SETQ RANDOM-CONST-A (LOGAND RANDOM-CONST-A MOST-POSITIVE-FIXNUM)) (LOGXOR X (SETQ RANDOM-CONST-B (PROG1 (LOGAND (+ (* RANDOM-CONST-A 19869) RANDOM-CONST-A) MOST-POSITIVE-FIXNUM) (SETQ RANDOM-CONST-A RANDOM-CONST-B))))) RANDOM-LIST)))) (DEFUN %PRINT-RANDOM-STATE (STATE STREAM PRINT-LEVEL) (LET ((XCL:*PRINT-STRUCTURE* T) (*PRINT-ARRAY* T)) (DEFAULT-STRUCTURE-PRINTER STATE STREAM PRINT-LEVEL))) (DEFUN %RANDOM (STATE) (IL:* IL:|;;| "This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive Random Number Generators, by John F. Reiser, on p 28.0.The numbers are stored as 16 bit binary fractions (i.e. the decimal point is on the left of the 16-bit quantity)") (LET ((I (RANDOM-STATE-I STATE)) (J (RANDOM-STATE-J STATE)) (ARRAY (RANDOM-STATE-ARRAY STATE)) RV) (SETQ RV (LOGAND (- (AREF ARRAY I) (AREF ARRAY J)) MOST-POSITIVE-FIXNUM)) (SETF (AREF ARRAY I) RV) (SETQ I (1+ I)) (IF (EQ I %RANDOM-SIZE) (SETQ I 0)) (SETQ J (1+ J)) (IF (EQ J %RANDOM-SIZE) (SETQ J 0)) (SETF (RANDOM-STATE-I STATE) I) (SETF (RANDOM-STATE-J STATE) J) RV)) (DEFUN MAKE-RANDOM-STATE (&OPTIONAL (STATE *RANDOM-STATE*)) (IL:* IL:|;;| "Make a random state object. If State is not supplied, return a copy of the default random state. If State is a random state, then return a copy of it. If state is T then return a random state generated from the universal time. ") (COND ((EQ STATE T) (%MAKE-RANDOM-STATE)) ((RANDOM-STATE-P STATE) (%MAKE-RANDOM-STATE :I (RANDOM-STATE-I STATE) :J (RANDOM-STATE-J STATE) :ARRAY (XCL:COPY-ARRAY (RANDOM-STATE-ARRAY STATE)))) (T (ERROR "Not a random-state: ~S" STATE)))) (DEFUN RANDOM (NUMBER &OPTIONAL (STATE *RANDOM-STATE*)) (IF (NOT (> NUMBER 0)) (ERROR "Not a positive number: ~s" NUMBER)) (LET ((RV (%RANDOM STATE))) (TYPECASE NUMBER (FIXNUM (IF (EQ NUMBER MOST-POSITIVE-FIXNUM) RV (IL:IREMAINDER RV NUMBER))) (FLOAT (LET ((FNUMBER (FLOAT NUMBER))) (DECLARE (TYPE FLOAT FNUMBER)) (SETQ FNUMBER (* FNUMBER (IL:FQUOTIENT (FLOAT RV) (FLOAT (1+ MOST-POSITIVE-FIXNUM))))))) (INTEGER (DO ((TOT RV (+ (ASH TOT 16) (%RANDOM STATE))) (END (ASH NUMBER -16) (ASH END -16))) ((EQ 0 END) (REM TOT NUMBER)))) (T (ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR INTEGER FLOAT) :NAME NUMBER :VALUE NUMBER :MESSAGE "an integer or a float"))))) (DEFPARAMETER *RANDOM-STATE* (%MAKE-RANDOM-STATE)) (IL:PUTPROPS IL:CMLRAND IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLRAND IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:CMLRAND IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CMLREAD b/sources/CMLREAD new file mode 100644 index 00000000..74c82334 --- /dev/null +++ b/sources/CMLREAD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:25:51" {DSK}lde>lispcore>sources>CMLREAD.;2 15363 changes to%: (RECORDS READER-ENVIRONMENT) previous date%: " 4-Jan-93 17:53:43" {DSK}lde>lispcore>sources>CMLREAD.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLREADCOMS) (RPAQQ CMLREADCOMS [(COMS (* ;; "Misc Common Lisp reader functions") (FNS CL:COPY-READTABLE) (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING CL:READ-BYTE CL:WRITE-BYTE ) (* ;  "must turn off packed version of CLISP infix") (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *] (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (DWIMINMACROSFLG)) (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*) (GLOBALVARS CMLRDTBL READ-LINE-RDTBL)) [COMS (* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup") (RECORDS READER-ENVIRONMENT) (FUNCTIONS WITH-READER-ENVIRONMENT) (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (PROP INFO WITH-READER-ENVIRONMENT) (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*) (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER") REREADTABLE _ CMLRDTBL REBASE _ 10] (PROP FILETYPE CMLREAD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE]) (* ;; "Misc Common Lisp reader functions") (DEFINEQ (CL:COPY-READTABLE [CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*) TO-READTABLE) (* bvm%: "13-Oct-86 15:21") (* ;  "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.") (if (AND (NULL FROM-READTABLE) (NULL TO-READTABLE)) then (* ; "just make a brand new one") (CMLRDTBL) else (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL)) 'READTABLEP)) (if TO-READTABLE then (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP) FROM-READTABLE) TO-READTABLE else (COPYREADTABLE FROM-READTABLE]) ) (DEFINEQ (CL:READ-LINE [CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T) EOF-VALUE RECURSIVE-P) (* ; "Edited 31-Mar-87 18:36 by bvm:") (* ;;  "Returns a line of text read from the STREAM as a string, discarding the newline character.") (CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT)) (if (AND (NULL EOF-ERRORP) (NULL RECURSIVE-P) (\EOFP STREAM)) then EOF-VALUE else (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL))) (if (\EOFP STREAM) then (CL:VALUES RESULT T) else (* ; "consume the eol") (READCCODE STREAM) (CL:VALUES RESULT NIL]) (CL:READ-CHAR [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 20:41 by bvm:") (* ;; "Inputs a character from STREAM and returns it.") (LET [(STREAM (\GETSTREAM STREAM 'INPUT] (COND ((AND (NOT EOF-ERRORP) (NOT RECURSIVE-P) (\EOFP STREAM)) EOF-VALUE) (T (CL:CODE-CHAR (READCCODE STREAM]) (CL:UNREAD-CHAR (CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:44") (* ;; "Puts the CHARACTER back on the front of the input STREAM. According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'") (\BACKCHAR (\GETSTREAM INPUT-STREAM 'INPUT)) NIL)) (CL:PEEK-CHAR [CL:LAMBDA (&OPTIONAL (PEEK-TYPE NIL) (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 14:39 by bvm:") (* ;; "Peeks at the next character in the input Stream. See manual for details.") (DECLARE (IGNORE RECURSIVE-P)) (LET ((STREAM (\GETSTREAM STREAM 'INPUT)) (\RefillBufferFn '\PEEKREFILL) CL:CHAR) (DECLARE (CL:SPECIAL \RefillBufferFn)) (SELECTQ PEEK-TYPE (NIL (* ; "standard case--return next char. \peekccode to terminal requires the binding of \RefillBufferFn above") (if (SETQ CL:CHAR (\PEEKCCODE STREAM (NULL EOF-ERRORP))) then (CL:CODE-CHAR CL:CHAR) else EOF-VALUE)) (T (* ; "skip whitespace before peeking") (if (SETQ CL:CHAR (SKIPSEPRCODES STREAM)) then (CL:CODE-CHAR CL:CHAR) elseif EOF-ERRORP then (\EOF.ACTION STREAM) else EOF-VALUE)) (if (CL:CHARACTERP PEEK-TYPE) then (LET ((DESIREDCHAR (CL:CHAR-CODE PEEK-TYPE)) (NOERROR (NULL EOF-ERRORP))) (until (EQ (SETQ CL:CHAR (\PEEKCCODE STREAM NOERROR)) DESIREDCHAR) do (if (NULL CL:CHAR) then (RETURN EOF-VALUE)) (READCCODE STREAM) finally (RETURN PEEK-TYPE))) else (\ILLEGAL.ARG PEEK-TYPE]) (CL:LISTEN (CL:LAMBDA (&OPTIONAL STREAM) (* ; "Edited 14-Apr-87 16:49 by bvm:") (* ;; "Returns T if a character is available on the given STREAM ") (READP (\GETSTREAM STREAM 'INPUT) T))) (CL:READ-CHAR-NO-HANG (CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Apr-87 16:40 by bvm:") (* ;; "Returns the next character from the STREAM if one is available, or NIL. However, if STREAM is at eof, do eof handling.") (COND ((READP STREAM T) (* ; "there is input, get it") (CL:READ-CHAR STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P)) ((NOT (EOFP STREAM)) (* ;  "there could be more input, so don't wait, return NIL") NIL) (EOF-ERRORP (\EOF.ACTION STREAM)) (T EOF-VALUE)))) (CL:CLEAR-INPUT [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)) (* bvm%: "13-Oct-86 15:46") (* ;; "Clears any buffered input associated with the Stream.") (CLEARBUF (\GETSTREAM STREAM 'INPUT]) (CL:READ-FROM-STRING [CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE) (* ; "Edited 8-Jun-90 14:15 by ymasuda") (LET [(STREAM (OPENSTRINGSTREAM (COND [END (SUBSTRING STRING 1 (IMIN END (NCHARS STRING] (T (MKSTRING STRING] (COND (START (SETFILEPTR STREAM START))) (CL:VALUES (CL:IF PRESERVE-WHITESPACE (CL:READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P EOF-VALUE) (CL:READ STREAM EOF-ERROR-P EOF-VALUE)) (\GETFILEPTR STREAM]) (CL:READ-BYTE [CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T) EOF-VALUE) (* bvm%: "13-Oct-86 15:49") (* ;; "Returns the next byte of the BINARY-INPUT-STREAM") (LET [(STREAM (\GETSTREAM BINARY-INPUT-STREAM 'INPUT] (CL:IF (AND (NOT EOF-ERRORP) (\EOFP STREAM)) EOF-VALUE (\BIN STREAM))]) (CL:WRITE-BYTE (CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM) (* bvm%: "13-Oct-86 15:49") (* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM") (BOUT BINARY-OUTPUT-STREAM INTEGER) INTEGER)) ) (* ; "must turn off packed version of CLISP infix") (RPAQ CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *))) (RPAQ CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (RPAQQ DWIMINMACROSFLG NIL) (CL:DEFVAR *READ-DEFAULT-FLOAT-FORMAT* 'CL:SINGLE-FLOAT) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CMLRDTBL READ-LINE-RDTBL) ) (* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup" ) (DECLARE%: EVAL@COMPILE (DATATYPE READER-ENVIRONMENT (REPACKAGE REREADTABLE REBASE RESPEC)) ) (/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER) '((READER-ENVIRONMENT 0 POINTER) (READER-ENVIRONMENT 2 POINTER) (READER-ENVIRONMENT 4 POINTER) (READER-ENVIRONMENT 6 POINTER)) '8) (DEFMACRO WITH-READER-ENVIRONMENT (ENV . BODY) `((CL:LAMBDA (E) (LET ((*PACKAGE* (ffetch (READER-ENVIRONMENT REPACKAGE) of E)) (*READTABLE* (ffetch (READER-ENVIRONMENT REREADTABLE) of E)) (*READ-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E)) (*PRINT-BASE* (ffetch (READER-ENVIRONMENT REBASE) of E))) ,@BODY)) (\DTEST ,ENV 'READER-ENVIRONMENT))) (ADDTOVAR SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*) (PUTPROPS WITH-READER-ENVIRONMENT INFO EVAL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*) ) (RPAQ? *COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER") REREADTABLE _ CMLRDTBL REBASE _ 10)) (PUTPROPS CMLREAD FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE) ) (PRETTYCOMPRINT CMLREADCOMS) (RPAQQ CMLREADCOMS [(COMS (* ;; "Misc Common Lisp reader functions") (FNS CL:COPY-READTABLE) (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING CL:READ-BYTE CL:WRITE-BYTE) (* ;  "must turn off packed version of CLISP infix") (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *] (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS)) (DWIMINMACROSFLG)) (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*) (GLOBALVARS CMLRDTBL READ-LINE-RDTBL)) [COMS (* ;; "Crude means to aid reading and printing things in same reader environment. There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup") (RECORDS READER-ENVIRONMENT) (FUNCTIONS WITH-READER-ENVIRONMENT) (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)) (PROP INFO WITH-READER-ENVIRONMENT) (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*) (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE "USER") REREADTABLE _ CMLRDTBL REBASE _ 10] (PROP FILETYPE CMLREAD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE) ) (PUTPROPS CMLREAD COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2481 3466 (CL:COPY-READTABLE 2491 . 3464)) (3467 10087 (CL:READ-LINE 3477 . 4349) ( CL:READ-CHAR 4351 . 4901) (CL:UNREAD-CHAR 4903 . 5351) (CL:PEEK-CHAR 5353 . 7337) (CL:LISTEN 7339 . 7604) (CL:READ-CHAR-NO-HANG 7606 . 8378) (CL:CLEAR-INPUT 8380 . 8617) (CL:READ-FROM-STRING 8619 . 9374 ) (CL:READ-BYTE 9376 . 9829) (CL:WRITE-BYTE 9831 . 10085))))) STOP \ No newline at end of file diff --git a/sources/CMLREADTABLE b/sources/CMLREADTABLE new file mode 100644 index 00000000..01f13a3d --- /dev/null +++ b/sources/CMLREADTABLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "13-Mar-95 12:41:10" {DSK}sources>CMLREADTABLE.;4 27688 changes to%: (FNS CMLREADSEMI) previous date%: "16-May-90 14:24:30" {DSK}sources>CMLREADTABLE.;1) (* ; " Copyright (c) 1986, 1987, 1990, 1995 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLREADTABLECOMS) (RPAQQ CMLREADTABLECOMS ((COMS (* ;  "Common Lisp readtable interface functions ") (FUNCTIONS HASH-LEFT-PAD-INITIAL-CONTENTS CL:SET-SYNTAX-FROM-CHAR CL:GET-DISPATCH-MACRO-CHARACTER CL:GET-MACRO-CHARACTER CL:MAKE-DISPATCH-MACRO-CHARACTER CL:SET-DISPATCH-MACRO-CHARACTER CL:SET-MACRO-CHARACTER) (FUNCTIONS DO-DISPATCH-MACRO FIND-MACRO-FUNCTION CL-MACRO-WRAPPED-P CL-UNWRAP-MACRO CL-WRAP-MACRO IL-MACRO-WRAPPED-P IL-UNWRAP-MACRO IL-WRAP-MACRO)) (COMS (* ; "hash macro sub functions") (FUNCTIONS HASH-LEFTPAREN HASH-A HASH-B HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA HASH-DOT HASH-DOUBLEQUOTE HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS HASH-NO-PARAMETER-ERROR HASH-O HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH HASH-STRUCTURE-LOOKUP) (* ; "Temporary") (VARIABLES *READ-SUPPRESS*)) [COMS (* ; "Common Lisp default readtables") (FNS CMLRDTBL INIT-CML-READTABLES SET-DEFAULT-HASHMACRO-SETTINGS CMLREADSEMI) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT-CML-READTABLES] (PROP FILETYPE CMLREADTABLE))) (* ; "Common Lisp readtable interface functions ") (CL:DEFUN HASH-LEFT-PAD-INITIAL-CONTENTS (SIZE IVAL-LIST) [LET [(PADLENGTH (- SIZE (LENGTH IVAL-LIST] (COND [(> PADLENGTH 0) (APPEND IVAL-LIST (CL:MAKE-LIST PADLENGTH :INITIAL-ELEMENT (CAR (LAST IVAL-LIST] (T (CL:ERROR "Values list too long for #~D()" SIZE]) (CL:DEFUN CL:SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*) (FROM-READTABLE CMLRDTBL)) (SETSYNTAX (CL:CHAR-CODE TO-CHAR) (GETSYNTAX (CL:CHAR-CODE FROM-CHAR) FROM-READTABLE) TO-READTABLE)) (CL:DEFUN CL:GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*)) [CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE ]) (CL:DEFUN CL:GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE*)) (* ;;; "insures entry is Common Lisp form - (MACRO {FIRST,ALWAYS} (LAMBDA (STREAM READTABLE) (FUNCALL ' STREAM))))") [LET ((TABENTRY (GETSYNTAX (CL:CHAR-CODE CHAR) READTABLE)) NON-TERMINATING-P) (AND (CL:CONSP TABENTRY) (EQ (CAR TABENTRY) 'MACRO) (CL:CONSP (CDR TABENTRY)) (FMEMB (CADR TABENTRY) '(ALWAYS FIRST)) (SETQ NON-TERMINATING-P (CADR TABENTRY)) (CL:CONSP (SETQ TABENTRY (CDDR TABENTRY))) (NULL (CDR TABENTRY)) (CL:VALUES (FIND-MACRO-FUNCTION (CAR TABENTRY)) (NEQ NON-TERMINATING-P 'ALWAYS]) (CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE* )) (SETSYNTAX (CL:CHAR-CODE CHAR) `[MACRO ,(CL:IF NON-TERMINATING 'FIRST 'ALWAYS) (LAMBDA (STREAM READTABLE Z) (DO-DISPATCH-MACRO ,CHAR STREAM READTABLE] READTABLE) T) (CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE *READTABLE*)) (CL:IF (CL:DIGIT-CHAR-P SUB-CHAR) (CL:ERROR "Digit ~S illegal as a sub-character for a dispatching macro" SUB-CHAR)) (SETQ SUB-CHAR (CL:CHAR-UPCASE SUB-CHAR)) (LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE) ) (LET ((NEWTABLE (LIST DISP-CHAR))) (push (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE) NEWTABLE) NEWTABLE))) DISP-CONS) (if (SETQ DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE))) then (CL:SETF (CDR DISP-CONS) FUNCTION) else (push (CDR DISP-TABLE) (CONS SUB-CHAR FUNCTION))) T)) (CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*) ) (SETSYNTAX (CL:CHAR-CODE CHAR) `[MACRO ,(CL:IF NON-TERMINATING 'FIRST 'ALWAYS) ,(COND ((IL-MACRO-WRAPPED-P FUNCTION) (IL-UNWRAP-MACRO FUNCTION)) (T (CL-WRAP-MACRO FUNCTION CHAR] READTABLE) T) (CL:DEFUN DO-DISPATCH-MACRO (CHAR STREAM RDTBL) [LET ((*READTABLE* RDTBL) [DISP-TABLE (CDR (ASSOC CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of RDTBL] INDEX NEXTCHAR) (COND ((NOT DISP-TABLE) (CL:ERROR "~S is not a dispatch macro character" CHAR)) (T (* ;  "DISPATCHMACRODEFS is a list of A-lists") [while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL))) do (* ; "read the optional numeric arg") (SETQ INDEX (+ (TIMES (OR INDEX 0) 10) (- NEXTCHAR (CHARCODE 0] (LET* [(DISP-CHARACTER (CL:CHAR-UPCASE (CL:CODE-CHAR NEXTCHAR))) (DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE] (if DISP-FUNCTION then (CL:FUNCALL DISP-FUNCTION STREAM DISP-CHARACTER INDEX) else (CL:IF *READ-SUPPRESS* (PROGN (* ; "Attempt to ignore it") (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (CL:ERROR "Undefined dispatch character ~S for dispatch macro character ~S" DISP-CHARACTER CHAR))]) (CL:DEFUN FIND-MACRO-FUNCTION (FORM) (COND ((CL-MACRO-WRAPPED-P FORM) (CL-UNWRAP-MACRO FORM)) ((CL:FUNCTIONP FORM) (IL-WRAP-MACRO FORM)))) (CL:DEFUN CL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by CL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) 'CL:LAMBDA) (CL:CONSP (CDR FORM)) (CL:EQUAL (CADR FORM) '(STREAM READTABLE Z)) (CL:CONSP (CDDR FORM)) (NULL (CDDDR FORM)) (CL:CONSP (CADDR FORM)) (EQ (CAADDR FORM) 'CL:FUNCALL))) (CL:DEFUN CL-UNWRAP-MACRO (FORM) (* ;;; "Fetches CL function out wrapped by CL-WRAP-MACRO") (CADR (CADR (CADDR FORM)))) (CL:DEFUN CL-WRAP-MACRO (FN CHAR) (* ;;; "Wraps a form around a CL readmacro to make it acceptable as an IL readmacro") `(CL:LAMBDA (STREAM READTABLE Z) (CL:FUNCALL ',FN STREAM ,CHAR))) (CL:DEFUN IL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by IL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) 'CL:LAMBDA) (CL:CONSP (CDR FORM)) (EQUAL (CADR FORM) '(STREAM CHAR)) (CL:CONSP (SETQ FORM (CDDR FORM))) (NULL (CDR FORM)) (CL:CONSP (SETQ FORM (CAR FORM))) (EQ (CAR FORM) 'CL:FUNCALL) (EQ (CADDR FORM) 'STREAM))) (CL:DEFUN IL-UNWRAP-MACRO (FORM) (CADR (CADR (CADDR FORM)))) (CL:DEFUN IL-WRAP-MACRO (FORM) (* ;;; "Wraps a form around an IL readmacro to make it acceptable as a CL readmacro") `(CL:LAMBDA (STREAM CHAR) (CL:FUNCALL ',FORM STREAM))) (* ; "hash macro sub functions") (CL:DEFUN HASH-LEFTPAREN (STREAM CHAR INDEX) [LET ((CONTENTS (CL:READ-DELIMITED-LIST #\) STREAM T))) (COND (*READ-SUPPRESS* NIL) [\INBQUOTE (* ;; "We are inside a back-quote - generate %",(coerce ',contents 'vector)%"") (CL:WHEN INDEX (CL:CERROR "Ignore the explicit length" "Explicit length not allowed in backquoted vectors:~%%#~D~S" INDEX CONTENTS)) (LIST '\, `(COERCE ,(LIST 'BQUOTE CONTENTS) 'CL:VECTOR] (INDEX (IF (<= (LENGTH CONTENTS) INDEX) THEN (LET [(VEC (CL:MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS] [LET ((XCL-USER::T0 (LENGTH CONTENTS)) (I 0)) (CL:BLOCK NIL (LET NIL (CL:TAGBODY LOOPTAG0015 (COND ((>= I XCL-USER::T0) (RETURN NIL))) (CL:SETF (CL:AREF VEC I) (POP CONTENTS)) (CL:INCF I) (GO LOOPTAG0015))))] VEC) ELSE (CL:ERROR "Values list too long for #~D()" INDEX))) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS]) (CL:DEFUN HASH-A (STREAM CHAR PARAM) [LET ((CONTENTS (CL:READ STREAM T NIL T))) (COND (*READ-SUPPRESS* NIL) (T (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY PARAM CONTENTS) :INITIAL-CONTENTS CONTENTS]) (CL:DEFUN HASH-B (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 2)))) (CL:DEFUN HASH-BACKSLASH (STREAM CHAR PARAM) [COND (*READ-SUPPRESS* (CHARACTER.READ STREAM) NIL) (T (CL:IF (OR (NULL PARAM) (AND (TYPEP PARAM 'CL:FIXNUM) (>= PARAM 0) (< PARAM CL:CHAR-FONT-LIMIT))) (CHARACTER.READ STREAM) (CL:ERROR "Illegal font specifier ~S for #\" PARAM))]) (CL:DEFUN HASH-C (STREAM CHAR PARAM) [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (DESTRUCTURING-BIND (NUM DEN) (CL:READ STREAM T NIL T) (COMPLEX NUM DEN]) (CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.") [COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM *READTABLE* T]) (CL:DEFUN HASH-COMMA (STREAM CHAR PARAM) (* ;;; "If the compiler is reading, then wrap up the form in a special data object to be noticed by FASL later. If it's not the compiler, then treat exactly like #.") [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LET ((FORM (CL:READ STREAM T NIL T))) (IF COMPILER::*COMPILER-IS-READING* THEN (COMPILER::MAKE-EVAL-WHEN-LOAD :FORM FORM) ELSEIF (FETCH (READTABLEP COMMONLISP) OF *READTABLE*) THEN (CL:EVAL FORM) ELSE (EVAL FORM]) (CL:DEFUN HASH-DOT (STREAM CHAR PARAM) [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (CL:EVAL (CL:READ STREAM T NIL T))) (T (EVAL (CL:READ STREAM T NIL T]) (CL:DEFUN HASH-DOUBLEQUOTE (STREAM CHAR PARAM) (* ;;; "An extension to Common Lisp. This reads a normal string but ignores CR's and any whitespace immediately following them.") [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (RSTRING STREAM *READTABLE* 'SKIP]) (CL:DEFUN HASH-ILLEGAL-HASH-CHAR (STREAM CHAR PARAM) (CL:ERROR "Illegal hash macro character ~S" CHAR)) (CL:DEFUN HASH-LEFTANGLE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:ERROR "Unreadable object #<~A>" (CL:READ STREAM T NIL T))) (CL:DEFUN HASH-MINUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression). Otherwise, we read the feature expression and, when it applies to us, skip over the controlled expression. In any case, we never return a value.") [COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:WHEN (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T)))] (CL:VALUES)) (CL:DEFUN HASH-NO-PARAMETER-ERROR (CHAR PARAM) (CL:WHEN PARAM (CL:ERROR "Parameter ~D not allowed with hash macro ~S" PARAM CHAR))) (CL:DEFUN HASH-O (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 8)))) (CL:DEFUN HASH-PLUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression). Otherwise, we read the feature expression and, unless it applies to us, skip over the controlled expression. In any case, we never return a value.") [COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T)))] (CL:VALUES)) (CL:DEFUN HASH-QUOTE (STREAM CHAR PARAM) [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LIST 'CL:FUNCTION (CL:READ STREAM T NIL T]) (CL:DEFUN HASH-R (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (PARAM (READNUMBERINBASE STREAM PARAM)) (T (CL:ERROR "No base supplied for #R")))) (CL:DEFUN HASH-S (STREAM CHAR PARAM) [COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CREATE-STRUCTURE (CL:READ STREAM T NIL T]) (CL:DEFUN HASH-STAR (STREAM CHAR PARAM) (DECLARE (IGNORE CHAR)) [IF (EQ (PEEKC STREAM) '%() THEN (* ; "It's a bitmap.") (IF *READ-SUPPRESS* THEN (CL:READ STREAM NIL NIL T) (CL:READ STREAM NIL NIL T) ELSEIF PARAM THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM) ELSE (FINISH-READING-BITMAP STREAM)) ELSE (* ; "It's a bit-vector.") (LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM)) (LEN (NCHARS CONTENTS))) (IF *READ-SUPPRESS* THEN NIL ELSEIF (AND (EQ LEN 0) PARAM (NEQ PARAM 0)) THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM) ELSEIF (AND PARAM (> LEN PARAM)) THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM CONTENTS) ELSE (LET [(BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN) :ELEMENT-TYPE 'BIT :INITIAL-ELEMENT (IF (AND PARAM (> PARAM LEN 0)) THEN (SELCHARQ (NTHCHARCODE CONTENTS -1) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)) ELSE 0] (CL:DOTIMES (I LEN) (CL:SETF (CL:AREF BITARRAY I) (SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I)) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)))) BITARRAY]) (CL:DEFUN HASH-VBAR (STREAM CHAR PARAM) (OR *READ-SUPPRESS* (HASH-NO-PARAMETER-ERROR CHAR PARAM)) (LET ((*READ-SUPPRESS* T)) (SKIP.HASH.COMMENT STREAM *READTABLE*) (CL:VALUES))) (CL:DEFUN HASH-X (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 16)))) (CL:DEFUN HASH-EQUAL (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* (CL:VALUES) [PROGN (CL:IF (NULL PARAM) (CL:ERROR "#= encountered")) (CL:IF (CL:ASSOC PARAM *CIRCLE-READ-LIST*) (CL:ERROR "#~D= seen twice in same context")) (LET ((NEWNODE (CONS PARAM NIL))) (CL:PUSH NEWNODE *CIRCLE-READ-LIST*) (CL:SETF (CDR NEWNODE) (CL:READ STREAM T NIL T])) (CL:DEFUN HASH-NUMBER-SIGN (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* NIL [LET ((CIRCLE-PART (CL:ASSOC PARAM *CIRCLE-READ-LIST*))) (COND (CIRCLE-PART) (T (CL:ERROR "#~D# encountered before #~D=" PARAM PARAM])) (CL:DEFUN HASH-STRUCTURE-SMASH (THING) (CL:TYPECASE THING (CONS (CL:IF (HASH-STRUCTURE-LOOKUP (CAR THING)) (CL:SETF (CAR THING) (CDAR THING)) (HASH-STRUCTURE-SMASH (CAR THING))) (CL:IF (HASH-STRUCTURE-LOOKUP (CDR THING)) (CL:SETF (CDR THING) (CDDR THING)) (HASH-STRUCTURE-SMASH (CDR THING)))) ((CL:ARRAY T) [LET* ((ASIZE (CL:ARRAY-TOTAL-SIZE THING)) (VARRAY (CL:IF (> (CL:ARRAY-RANK THING) 1) (CL:MAKE-ARRAY ASIZE :DISPLACED-TO THING) THING)) SLOTCONTENTS) (CL:DOTIMES (X ASIZE) (CL:SETQ SLOTCONTENTS (CL:AREF VARRAY X)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (CL:SETF (CL:AREF VARRAY X) (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS)))]) (CL::STRUCTURE-OBJECT [LET (SLOTCONTENTS) (CL:DOLIST (DESCR (CL::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF THING))) (CL:SETQ SLOTCONTENTS (FETCHFIELD DESCR THING)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (REPLACEFIELD DESCR THING (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS)))]))) (CL:DEFUN HASH-STRUCTURE-LOOKUP (SLOTCONTENTS) (AND (CL:CONSP SLOTCONTENTS) (MEMQ SLOTCONTENTS *CIRCLE-READ-LIST*))) (* ; "Temporary") (CL:DEFVAR *READ-SUPPRESS* NIL) (* ; "Common Lisp default readtables") (DEFINEQ (CMLRDTBL [LAMBDA NIL (* bvm%: "14-Oct-86 16:01") (* ;; "Creates a vanilla common-lisp read table") (PROG [(TBL (COPYREADTABLE 'ORIG] (* ;; "First reset the table") (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I 'OTHER TBL)) (* ;; "Install the goodies") (SETSEPR (CHARCODE (SPACE CR ^L LF TAB)) 1 TBL) (SETSYNTAX (CHARCODE "'") '(MACRO ALWAYS READQUOTE) TBL) (* ;; "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not") (SETSYNTAX (CHARCODE ";") '(MACRO ALWAYS CMLREADSEMI) TBL) (SETSYNTAX (CHARCODE ")") 'RIGHTPAREN TBL) (SETSYNTAX (CHARCODE "(") 'LEFTPAREN TBL) (READTABLEPROP TBL 'CASEINSENSITIVE T) (READTABLEPROP TBL 'COMMONLISP T) (READTABLEPROP TBL 'COMMONNUMSYNTAX T) (READTABLEPROP TBL 'USESILPACKAGE NIL) (READTABLEPROP TBL 'ESCAPECHAR (CHARCODE "\")) (READTABLEPROP TBL 'MULTIPLE-ESCAPECHAR (CHARCODE "|")) (if *PACKAGE* then (READTABLEPROP TBL 'PACKAGECHAR (CHARCODE ":"))) (SET-DEFAULT-HASHMACRO-SETTINGS TBL) (SETSYNTAX (CHARCODE %") 'STRINGDELIM TBL) (SETSYNTAX (CHARCODE "`") '(MACRO ALWAYS READBQUOTE) TBL) (SETSYNTAX (CHARCODE ",") '(MACRO ALWAYS READBQUOTECOMMA) TBL) (RETURN TBL]) (INIT-CML-READTABLES [LAMBDA NIL (* ; "Edited 16-Jan-87 15:47 by bvm:") (DECLARE (GLOBALVARS CMLRDTBL *COMMON-LISP-READ-ENVIRONMENT* READ-LINE-RDTBL)) (READTABLEPROP (SETQ CMLRDTBL (CMLRDTBL)) 'NAME "LISP") (SETQ *COMMON-LISP-READ-ENVIRONMENT* (MAKE-READER-ENVIRONMENT (CL:FIND-PACKAGE "USER") CMLRDTBL 10)) (LET ((FILETBL (COPYREADTABLE CMLRDTBL))) (* ; "Make one for files that has font indicators as seprs") (for I from 1 to 26 do (SETSYNTAX I 'SEPRCHAR FILETBL)) (READTABLEPROP FILETBL 'NAME "XCL")) (PROGN (* ; "Read table to make READ-LINE work easily") (SETQ READ-LINE-RDTBL (COPYREADTABLE 'ORIG)) (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I 'OTHER READ-LINE-RDTBL)) (SETBRK (CHARCODE (EOL)) NIL READ-LINE-RDTBL]) (SET-DEFAULT-HASHMACRO-SETTINGS [LAMBDA (RDTBL) (* jrb%: "10-Nov-86 15:46") (READTABLEPROP RDTBL 'HASHMACROCHAR (CHARCODE "#")) (CL:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\( 'HASH-LEFTPAREN RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\' 'HASH-QUOTE RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\. 'HASH-DOT RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\, 'HASH-COMMA RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\\ 'HASH-BACKSLASH RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\* 'HASH-STAR RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\: 'HASH-COLON RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\O 'HASH-O RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\B 'HASH-B RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\X 'HASH-X RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\R 'HASH-R RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\A 'HASH-A RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\S 'HASH-S RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\C 'HASH-C RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\+ 'HASH-PLUS RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\- 'HASH-MINUS RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\| 'HASH-VBAR RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\< 'HASH-LEFTANGLE RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\" 'HASH-DOUBLEQUOTE RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\= 'HASH-EQUAL RDTBL) (CL:SET-DISPATCH-MACRO-CHARACTER #\# #\# 'HASH-NUMBER-SIGN RDTBL) RDTBL]) (CMLREADSEMI [LAMBDA (STREAM RDTBL) (* ;  "Edited 9-Mar-95 13:41 by sybalsky:mv:envos") (* ;;; "Read and discard through end of line") (until (FMEMB (READCCODE STREAM) (CHARCODE (LF NEWLINE))) do NIL) (CL:VALUES]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (INIT-CML-READTABLES) ) (PUTPROPS CMLREADTABLE FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLREADTABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1995)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22724 27461 (CMLRDTBL 22734 . 24394) (INIT-CML-READTABLES 24396 . 25532) ( SET-DEFAULT-HASHMACRO-SETTINGS 25534 . 27112) (CMLREADSEMI 27114 . 27459))))) STOP \ No newline at end of file diff --git a/sources/CMLSEQ b/sources/CMLSEQ new file mode 100644 index 00000000..af291b63 --- /dev/null +++ b/sources/CMLSEQ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:26:04" {DSK}local>lde>lispcore>sources>CMLSEQ.;2 1265 changes to%: (VARS CMLSEQCOMS) previous date%: "15-Oct-86 17:56:17" {DSK}local>lde>lispcore>sources>CMLSEQ.;1) (* ; " Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQCOMS) (RPAQQ CMLSEQCOMS [(FILES CMLSEQCOMMON CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT) (PROP FILETYPE CMLSEQ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (FILESLOAD CMLSEQCOMMON CMLSEQBASICS CMLSEQMAPPERS CMLSEQMODIFY CMLSEQFINDER CMLSORT) (PUTPROPS CMLSEQ FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS CMLSEQ COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSEQBASICS b/sources/CMLSEQBASICS new file mode 100644 index 00000000..81e9b2f7 --- /dev/null +++ b/sources/CMLSEQBASICS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:26:56" {DSK}local>lde>lispcore>sources>CMLSEQBASICS.;2 9043 changes to%: (VARS CMLSEQBASICSCOMS) previous date%: " 9-Oct-87 16:34:51" {DSK}local>lde>lispcore>sources>CMLSEQBASICS.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQBASICSCOMS) (RPAQQ CMLSEQBASICSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS CL:CONCATENATE CL:COPY-SEQ CL:ELT CL:LENGTH CL:MAKE-SEQUENCE CL:NREVERSE CL:REVERSE CL:SUBSEQ %%SETELT) (FUNCTIONS MAKE-SEQUENCE-OF-TYPE) (SETFS CL:ELT CL:SUBSEQ) (PROPS (CMLSEQBASICS FILETYPE)) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD CMLSEQCOMMON) ) (CL:DEFUN CL:CONCATENATE (RESULT-TYPE &REST SEQUENCES) [LET [(RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE (LET ((CNT 0)) (CL:DOLIST (SEQ SEQUENCES CNT) (SETQ CNT (+ CNT (CL:LENGTH SEQ))))] (SEQ-DISPATCH RESULT [LET ((TAIL RESULT)) (CL:DOLIST (SEQUENCE SEQUENCES RESULT) [SEQ-DISPATCH SEQUENCE (CL:DOLIST (ELEMENT SEQUENCE) (RPLACA TAIL ELEMENT) (SETQ TAIL (CDR TAIL))) (CL:DOTIMES (I (VECTOR-LENGTH SEQUENCE)) (RPLACA TAIL (CL:AREF SEQUENCE I)) (SETQ TAIL (CDR TAIL)))])] (LET ((INDEX 0)) (CL:DOLIST (SEQUENCE SEQUENCES RESULT) [SEQ-DISPATCH SEQUENCE (CL:DOLIST (ELEMENT SEQUENCE) (CL:SETF (CL:AREF RESULT INDEX) ELEMENT) (SETQ INDEX (CL:1+ INDEX))) (CL:DOTIMES (I (VECTOR-LENGTH SEQUENCE)) (CL:SETF (CL:AREF RESULT INDEX) (CL:AREF SEQUENCE I)) (SETQ INDEX (CL:1+ INDEX)))])]) (CL:DEFUN CL:COPY-SEQ (SEQUENCE) "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ." [LET ((LENGTH (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT COPY TAIL) COPY (COLLECT-ITEM CURRENT COPY TAIL)) (LET [(COPY (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE] (COPY-VECTOR-SUBSEQ SEQUENCE 0 LENGTH COPY 0 LENGTH]) (CL:DEFUN CL:ELT (SEQUENCE INDEX)  (* amd " 5-Jun-86 17:48") (CL:IF (NOT (< -1 INDEX (CL:LENGTH SEQUENCE))) (CL:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX)) (SEQ-DISPATCH SEQUENCE (CL:NTH INDEX SEQUENCE) (CL:AREF SEQUENCE INDEX))) (CL:DEFUN CL:LENGTH (SEQUENCE) (SEQ-DISPATCH SEQUENCE [LET ((SIZE 0) (REST SEQUENCE)) (CL:LOOP (CL:IF (NOT (CL:CONSP REST)) (RETURN SIZE)) (SETQ REST (CDR REST)) (SETQ SIZE (CL:1+ SIZE] (VECTOR-LENGTH SEQUENCE))) (CL:DEFUN CL:MAKE-SEQUENCE (TYPE LENGTH &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)) "Make a sequnce of the specified type" (CL:IF (EQ TYPE 'LIST) (CL:MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT) (LET ((VECTOR (MAKE-SEQUENCE-OF-TYPE TYPE LENGTH))) (CL:IF INITIAL-ELEMENT-P (FILL-VECTOR-SUBSEQ VECTOR 0 LENGTH INITIAL-ELEMENT)) VECTOR))) (CL:DEFUN CL:NREVERSE (SEQUENCE) "Returns a sequence of the same elements in reverse order (the argument is destroyed)." [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE) LIST-HEAD RESULT) (CL:LOOP (CL:IF (NOT (CL:CONSP (SETQ LIST-HEAD REST))) (RETURN RESULT)) (SETQ REST (CDR REST)) (SETQ RESULT (RPLACD LIST-HEAD RESULT] (LET ((LENGTH (VECTOR-LENGTH SEQUENCE))) (CL:DO ((LEFT-INDEX 0 (CL:1+ LEFT-INDEX)) (RIGHT-INDEX (CL:1- LENGTH) (CL:1- RIGHT-INDEX)) (HALF-LENGTH (LRSH LENGTH 1))) ((EQL LEFT-INDEX HALF-LENGTH) SEQUENCE) (CL:ROTATEF (CL:AREF SEQUENCE LEFT-INDEX) (CL:AREF SEQUENCE RIGHT-INDEX)))]) (CL:DEFUN CL:REVERSE (SEQUENCE) "Returns a new sequence containing the same elements but in reverse order." [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE) RESULT) (CL:LOOP (CL:IF (NOT (CL:CONSP REST)) (RETURN RESULT)) (CL:PUSH (CAR REST) RESULT) (SETQ REST (CDR REST] (LET ((LENGTH (VECTOR-LENGTH SEQUENCE))) (CL:DO ((RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE))) (FORWARD-INDEX 0 (CL:1+ FORWARD-INDEX)) (BACKWARD-INDEX (CL:1- LENGTH) (CL:1- BACKWARD-INDEX))) ((EQL FORWARD-INDEX LENGTH) RESULT) (CL:SETF (CL:AREF RESULT FORWARD-INDEX) (CL:AREF SEQUENCE BACKWARD-INDEX)))]) (CL:DEFUN CL:SUBSEQ (SEQUENCE START &OPTIONAL END) [LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT COPY TAIL) COPY (COLLECT-ITEM CURRENT COPY TAIL)) (LET [(COPY (MAKE-VECTOR (- END START) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE] (COPY-VECTOR-SUBSEQ SEQUENCE START END COPY 0]) (CL:DEFUN %%SETELT (SEQUENCE INDEX NEWVAL) (CL:IF (NOT (< -1 INDEX (CL:LENGTH SEQUENCE))) (CL:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX)) (SEQ-DISPATCH SEQUENCE (CL:SETF (CL:NTH INDEX SEQUENCE) NEWVAL) (CL:SETF (CL:AREF SEQUENCE INDEX) NEWVAL))) (CL:DEFUN MAKE-SEQUENCE-OF-TYPE (TYPE LENGTH) [LET ((BROAD-TYPE (TYPE-SPECIFIER TYPE))) (CL:IF (EQ BROAD-TYPE 'LIST) (CL:MAKE-LIST LENGTH) [LET [(ELEMENT-TYPE (CASE BROAD-TYPE ((CL:SIMPLE-STRING STRING) 'CL:STRING-CHAR) ((CL:SIMPLE-BIT-VECTOR CL:BIT-VECTOR) 'BIT) (CL:SIMPLE-VECTOR T) ((CL:ARRAY CL:VECTOR CL:SIMPLE-ARRAY) (CL:IF (CL:CONSP TYPE) (LET ((ELT-TYPE (CADR TYPE))) (CL:IF [AND ELT-TYPE (NOT (EQ ELT-TYPE 'CL:*] ELT-TYPE T)) T)))] (CL:IF ELEMENT-TYPE (MAKE-VECTOR LENGTH :ELEMENT-TYPE ELEMENT-TYPE) (LET ((EXPANDER (CL::TYPE-EXPANDER BROAD-TYPE))) (CL:IF EXPANDER (MAKE-SEQUENCE-OF-TYPE (CL::TYPE-EXPAND TYPE EXPANDER) LENGTH) (CL:ERROR "~S is a bad type specifier for sequences." TYPE))))])]) (CL:DEFSETF CL:ELT %%SETELT) (CL:DEFSETF CL:SUBSEQ (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE) `(PROGN (CL:REPLACE ,SEQUENCE ,NEW-SEQUENCE :START1 ,START :END1 ,END) ,NEW-SEQUENCE)) (PUTPROPS CMLSEQBASICS FILETYPE CL:COMPILE-FILE) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSEQBASICS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSEQCOMMON b/sources/CMLSEQCOMMON new file mode 100644 index 00000000..2724ef4b --- /dev/null +++ b/sources/CMLSEQCOMMON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:28:05" {DSK}local>lde>lispcore>sources>CMLSEQCOMMON.;2 5238 changes to%: (VARS CMLSEQCOMMONCOMS) previous date%: "12-Nov-86 14:57:08" {DSK}local>lde>lispcore>sources>CMLSEQCOMMON.;1) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQCOMMONCOMS) (RPAQQ CMLSEQCOMMONCOMS ((FUNCTIONS CHECK-SUBSEQ COLLECT-ITEM COPY-VECTOR-SUBSEQ FILL-VECTOR-SUBSEQ MAKE-SEQUENCE-LIKE SEQ-DISPATCH TYPE-SPECIFIER ) (FUNCTIONS BACKWARD-LIST-LOOP BACKWARD-VECTOR-LOOP FORWARD-LIST-LOOP FORWARD-VECTOR-LOOP) (PROP FILETYPE CMLSEQCOMMON) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T)))) (DEFMACRO CHECK-SUBSEQ (SEQ START END LENGTH) `(CL:IF (NOT (<= 0 ,START ,END ,LENGTH)) (CL:ERROR "Illegal subsequence for ~S.~%%Start is ~D. End is ~D" ,SEQ ,START ,END))) (DEFMACRO COLLECT-ITEM (ITEM HEAD TAIL) `(CL:IF ,TAIL [RPLACD ,TAIL (SETQ ,TAIL (LIST ,ITEM] [SETQ ,HEAD (SETQ ,TAIL (LIST ,ITEM])) (DEFMACRO COPY-VECTOR-SUBSEQ (FROM-VECTOR START-FROM END-FROM TO-VECTOR START-TO END-TO) "Copy one vector subsequence to another" `(CL:DO ((FROM-INDEX ,START-FROM (CL:1+ FROM-INDEX)) (TO-INDEX ,START-TO (CL:1+ TO-INDEX))) (,(CL:IF END-FROM `(EQL FROM-INDEX ,END-FROM) `(EQL TO-INDEX ,END-TO)) ,TO-VECTOR) (CL:SETF (CL:AREF ,TO-VECTOR TO-INDEX) (CL:AREF ,FROM-VECTOR FROM-INDEX)))) (DEFMACRO FILL-VECTOR-SUBSEQ (VECTOR START END NEWVALUE) `(CL:DO ((INDEX ,START (CL:1+ INDEX))) ((EQL INDEX ,END) ,VECTOR) (CL:SETF (CL:AREF ,VECTOR INDEX) ,NEWVALUE))) (DEFMACRO MAKE-SEQUENCE-LIKE (SEQUENCE LENGTH) "Returns a sequence of the same type as SEQUENCE and the given LENGTH." `[LET ((SEQ ,SEQUENCE)) (CL:ETYPECASE SEQ (LIST (CL:MAKE-LIST ,LENGTH)) (STRING (CL:MAKE-STRING ,LENGTH)) (CL:VECTOR (MAKE-VECTOR ,LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQ))))]) (DEFMACRO SEQ-DISPATCH (SEQUENCE LIST-FORM VECTOR-FORM) `(CL:ETYPECASE ,SEQUENCE (LIST ,LIST-FORM) (CL:VECTOR ,VECTOR-FORM))) (DEFMACRO TYPE-SPECIFIER (TYPE) "Returns the broad class of which TYPE is a specific subclass." `(CL:IF (CL:ATOM ,TYPE) ,TYPE (CAR ,TYPE))) (DEFMACRO BACKWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) [LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) `(CL:DO ((,INDEX-VAR (CL:1- ,END) (CL:1- ,INDEX-VAR)) %%SUBSEQ ,CURRENT-ELEMENT-VAR ,@OTHER-VARS) ((< ,INDEX-VAR ,START) ,RETURN-FORM) (SETQ %%SUBSEQ (CL:NTHCDR ,INDEX-VAR ,SEQUENCE)) (SETQ ,CURRENT-ELEMENT-VAR (CAR %%SUBSEQ)) ,@BODY)]) (DEFMACRO BACKWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) [LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) `(CL:DO ((,INDEX-VAR (CL:1- ,END) (CL:1- ,INDEX-VAR)) ,CURRENT-ELEMENT-VAR ,@OTHER-VARS) ((< ,INDEX-VAR ,START) ,RETURN-FORM) (SETQ ,CURRENT-ELEMENT-VAR (CL:AREF ,SEQUENCE ,INDEX-VAR)) ,@BODY)]) (DEFMACRO FORWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) [LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) `(CL:DO ((%%SUBSEQ (CL:NTHCDR ,START ,SEQUENCE) (CDR %%SUBSEQ)) (,INDEX-VAR ,START (CL:1+ ,INDEX-VAR)) ,CURRENT-ELEMENT-VAR ,@OTHER-VARS) ((EQL ,INDEX-VAR ,END) ,RETURN-FORM) (SETQ ,CURRENT-ELEMENT-VAR (CAR %%SUBSEQ)) ,@BODY)]) (DEFMACRO FORWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) "Canonical forward loop for vectors" [LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) `(CL:DO ((,INDEX-VAR ,START (CL:1+ ,INDEX-VAR)) ,CURRENT-ELEMENT-VAR ,@OTHER-VARS) ((EQL ,INDEX-VAR ,END) ,RETURN-FORM) (SETQ ,CURRENT-ELEMENT-VAR (CL:AREF ,SEQUENCE ,INDEX-VAR)) ,@BODY)]) (PUTPROPS CMLSEQCOMMON FILETYPE CL:COMPILE-FILE) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSEQCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSEQFINDER b/sources/CMLSEQFINDER new file mode 100644 index 00000000..a93f7159 --- /dev/null +++ b/sources/CMLSEQFINDER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:29:23" {DSK}local>lde>lispcore>sources>CMLSEQFINDER.;2 33743 changes to%: (VARS CMLSEQFINDERCOMS) previous date%: "12-Nov-86 18:41:14" {DSK}local>lde>lispcore>sources>CMLSEQFINDER.;1) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQFINDERCOMS) (RPAQQ CMLSEQFINDERCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS SIMPLE-FIND-MACRO SIMPLE-FIND SIMPLE-FIND-IF SIMPLE-FIND-IF-NOT COMPLEX-FIND-MACRO COMPLEX-FIND COMPLEX-FIND-IF COMPLEX-FIND-IF-NOT CL:FIND CL:FIND-IF CL:FIND-IF-NOT) (FUNCTIONS SIMPLE-POSITION-MACRO SIMPLE-POSITION SIMPLE-POSITION-IF SIMPLE-POSITION-IF-NOT COMPLEX-POSITION-MACRO COMPLEX-POSITION COMPLEX-POSITION-IF COMPLEX-POSITION-IF-NOT CL:POSITION CL:POSITION-IF CL:POSITION-IF-NOT) (FUNCTIONS SIMPLE-COUNT-MACRO SIMPLE-COUNT SIMPLE-COUNT-IF SIMPLE-COUNT-IF-NOT COMPLEX-COUNT COMPLEX-COUNT-IF COMPLEX-COUNT-IF-NOT CL:COUNT CL:COUNT-IF CL:COUNT-IF-NOT) (FUNCTIONS COMPLEX-COMPARE-BACKWARD COMPLEX-COMPARE-FORWARD SIMPLE-COMPARE CL:MISMATCH CL:SEARCH) (PROP FILETYPE CMLSEQFINDER) (DECLARE%: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD CMLSEQCOMMON) ) (DEFMACRO SIMPLE-FIND-MACRO (ITEM SEQUENCE START END TEST-FORM) `[SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN CURRENT))) (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN CURRENT]) (CL:DEFUN SIMPLE-FIND (ITEM SEQUENCE START END) (SIMPLE-FIND-MACRO ITEM SEQUENCE START END (EQL ITEM CURRENT))) (CL:DEFUN SIMPLE-FIND-IF (TEST SEQUENCE START END) (SIMPLE-FIND-MACRO ITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-FIND-IF-NOT (TEST SEQUENCE START END) (SIMPLE-FIND-MACRO ITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-FIND-MACRO (ITEM SEQUENCE START END FROM-END KEY TEST-FORM) `(CL:IF (NULL ,FROM-END) [SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN CURRENT))) (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN CURRENT] [SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT LAST-ELEMENT) LAST-ELEMENT (CL:IF ,TEST-FORM (SETQ LAST-ELEMENT CURRENT))) (BACKWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN CURRENT])) (CL:DEFUN COMPLEX-FIND (ITEM SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) [COMPLEX-FIND-MACRO ITEM SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)) ) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-FIND-IF (TEST SEQUENCE START END FROM-END KEY) (COMPLEX-FIND-MACRO ITEM SEQUENCE START END FROM-END KEY (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT) ))) (CL:DEFUN COMPLEX-FIND-IF-NOT (TEST SEQUENCE START END FROM-END KEY) [COMPLEX-FIND-MACRO ITEM SEQUENCE START END FROM-END KEY (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:FIND (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) "Returns the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM" (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both Test and Test-not specified")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-FIND ITEM SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-FIND ITEM SEQUENCE START END)))) (CL:DEFUN CL:FIND-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P)) "Returns the zero-origin index of the first element satisfying the test." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P) (COMPLEX-FIND-IF TEST SEQUENCE START END FROM-END KEY) (SIMPLE-FIND-IF TEST SEQUENCE START END)))) (CL:DEFUN CL:FIND-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P)) "Returns the zero-origin index of the first element not satisfying the test." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P) (COMPLEX-FIND-IF-NOT TEST SEQUENCE START END FROM-END KEY) (SIMPLE-FIND-IF-NOT TEST SEQUENCE START END)))) (DEFMACRO SIMPLE-POSITION-MACRO (ITEM SEQUENCE START END TEST-FORM) `[SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN INDEX))) (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN INDEX]) (CL:DEFUN SIMPLE-POSITION (ITEM SEQUENCE START END) (SIMPLE-POSITION-MACRO ITEM SEQUENCE START END (EQL ITEM CURRENT))) (CL:DEFUN SIMPLE-POSITION-IF (TEST SEQUENCE START END) (SIMPLE-POSITION-MACRO ITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-POSITION-IF-NOT (TEST SEQUENCE START END) (SIMPLE-POSITION-MACRO ITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-POSITION-MACRO (ITEM SEQUENCE START END FROM-END KEY TEST-FORM) `(CL:IF (NULL ,FROM-END) [SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN INDEX))) (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN INDEX] [SEQ-DISPATCH ,SEQUENCE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT LAST-INDEX) LAST-INDEX (CL:IF ,TEST-FORM (SETQ LAST-INDEX INDEX))) (BACKWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:IF ,TEST-FORM (RETURN INDEX])) (CL:DEFUN COMPLEX-POSITION (ITEM SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) [COMPLEX-POSITION-MACRO ITEM SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) ]) (CL:DEFUN COMPLEX-POSITION-IF (TEST SEQUENCE START END FROM-END KEY) (COMPLEX-POSITION-MACRO ITEM SEQUENCE START END FROM-END KEY (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-POSITION-IF-NOT (TEST SEQUENCE START END FROM-END KEY) [COMPLEX-POSITION-MACRO ITEM SEQUENCE START END FROM-END KEY (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:POSITION (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) "Returns the zero-origin index of the first element in SEQUENCE satisfying the test (default is EQL) with the given ITEM" (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both Test and Test-not specified")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-POSITION ITEM SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-POSITION ITEM SEQUENCE START END)))) (CL:DEFUN CL:POSITION-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P)) "Returns the zero-origin index of the first element satisfying test(el)" (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P) (COMPLEX-POSITION-IF TEST SEQUENCE START END FROM-END KEY) (SIMPLE-POSITION-IF TEST SEQUENCE START END)))) (CL:DEFUN CL:POSITION-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P)) "Returns the zero-origin index of the first element not satisfying test(el)" (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P) (COMPLEX-POSITION-IF-NOT TEST SEQUENCE START END FROM-END KEY) (SIMPLE-POSITION-IF-NOT TEST SEQUENCE START END)))) (DEFMACRO SIMPLE-COUNT-MACRO (ITEM SEQUENCE START END TEST-FORM) `[SEQ-DISPATCH ,SEQUENCE [FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (CNT 0)) CNT (CL:IF ,TEST-FORM (SETQ CNT (CL:1+ CNT)))] (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (CNT 0)) CNT (CL:IF ,TEST-FORM (SETQ CNT (CL:1+ CNT)))]) (CL:DEFUN SIMPLE-COUNT (ITEM SEQUENCE START END) (SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (EQL ITEM CURRENT))) (CL:DEFUN SIMPLE-COUNT-IF (TEST SEQUENCE START END) (SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-COUNT-IF-NOT (TEST SEQUENCE START END) (SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (CL:DEFUN COMPLEX-COUNT (ITEM SEQUENCE START END KEY TEST TEST-NOT-P) [SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT ))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-COUNT-IF (TEST SEQUENCE START END KEY) (SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-COUNT-IF-NOT (TEST SEQUENCE START END KEY) [SIMPLE-COUNT-MACRO ITEM SEQUENCE START END (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:COUNT (ITEM SEQUENCE &KEY (START 0) END FROM-END (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both Test and Test-not specified")) (CL:IF (OR KEY-P TEST-P TEST-NOT-P) (COMPLEX-COUNT ITEM SEQUENCE START END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-COUNT ITEM SEQUENCE START END)))) (CL:DEFUN CL:COUNT-IF (TEST SEQUENCE &KEY (START 0) END FROM-END (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF KEY-P (COMPLEX-COUNT-IF TEST SEQUENCE START END KEY) (SIMPLE-COUNT-IF TEST SEQUENCE START END)))) (CL:DEFUN CL:COUNT-IF-NOT (TEST SEQUENCE &KEY (START 0) END FROM-END (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF KEY-P (COMPLEX-COUNT-IF-NOT TEST SEQUENCE START END KEY) (SIMPLE-COUNT-IF-NOT TEST SEQUENCE START END)))) (CL:DEFUN COMPLEX-COMPARE-BACKWARD (SEQUENCE1 SEQUENCE2 START1 END1 START2 END2 KEY TEST TEST-NOT-P) [LET ((LEN1 (- END1 START1)) (LEN2 (- END2 START2))) (CL:IF (> LEN1 LEN2) (SETQ START1 (- END1 LEN2)) (SETQ START2 (- END2 LEN1))) (SEQ-DISPATCH SEQUENCE1 [SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1)) (LAST-MISMATCH (CL:1- START1)) TEST-RESULT) ((EQL INDEX1 END1) (CL:1+ LAST-MISMATCH)) [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CAR SUBSEQ1)) (CL:FUNCALL KEY (CAR SUBSEQ2] (CL:IF (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT)) (SETQ LAST-MISMATCH INDEX1))) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) (LAST-MISMATCH (CL:1- START1)) TEST-RESULT) ((EQL INDEX1 END1) (CL:1+ LAST-MISMATCH)) [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CAR SUBSEQ1)) (CL:FUNCALL KEY (CL:AREF SEQUENCE2 INDEX2] (CL:IF (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT)) (SETQ LAST-MISMATCH INDEX1)))] (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) (LAST-MISMATCH (CL:1- START1)) TEST-RESULT) ((EQL INDEX1 END1) (CL:1+ LAST-MISMATCH)) [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CL:AREF SEQUENCE1 INDEX1)) (CL:FUNCALL KEY (CAR SUBSEQ2] (CL:IF (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT)) (SETQ LAST-MISMATCH INDEX1))) (CL:DO ((INDEX1 (CL:1- END1) (CL:1- INDEX1)) (INDEX2 (CL:1- END2) (CL:1- INDEX2)) TEST-RESULT) ([OR (< INDEX1 START1) (PROGN [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CL:AREF SEQUENCE1 INDEX1)) (CL:FUNCALL KEY (CL:AREF SEQUENCE2 INDEX2] (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT))] (CL:1+ INDEX1)))]) (CL:DEFUN COMPLEX-COMPARE-FORWARD (SEQUENCE1 SEQUENCE2 START1 END1 START2 END2 KEY TEST TEST-NOT-P) [LET ((LEN1 (- END1 START1)) (LEN2 (- END2 START2))) (CL:IF (> LEN1 LEN2) (SETQ END1 (+ START1 LEN2)) (SETQ END2 (+ START2 LEN1))) (SEQ-DISPATCH SEQUENCE1 (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1)) TEST-RESULT) ([OR (EQL INDEX1 END1) (PROGN [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CAR SUBSEQ1)) (CL:FUNCALL KEY (CAR SUBSEQ2] (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT))] INDEX1)) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) TEST-RESULT) ([OR (EQL INDEX1 END1) (PROGN [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CAR SUBSEQ1)) (CL:FUNCALL KEY (CL:AREF SEQUENCE2 INDEX2] (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT))] INDEX1))) (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1)) TEST-RESULT) ([OR (EQL INDEX1 END1) (PROGN [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CL:AREF SEQUENCE1 INDEX1)) (CL:FUNCALL KEY (CAR SUBSEQ2] (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT))] INDEX1)) (CL:DO ((INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) TEST-RESULT) ([OR (EQL INDEX1 END1) (PROGN [SETQ TEST-RESULT (CL:FUNCALL TEST (CL:FUNCALL KEY (CL:AREF SEQUENCE1 INDEX1)) (CL:FUNCALL KEY (CL:AREF SEQUENCE2 INDEX2] (CL:IF TEST-NOT-P TEST-RESULT (NOT TEST-RESULT))] INDEX1))]) (CL:DEFUN SIMPLE-COMPARE (SEQUENCE1 SEQUENCE2 START1 END1 START2 END2) [LET ((LEN1 (- END1 START1)) (LEN2 (- END2 START2))) (CL:IF (> LEN1 LEN2) (SETQ END1 (+ START1 LEN2)) (SETQ END2 (+ START2 LEN1))) (SEQ-DISPATCH SEQUENCE1 (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ([OR (EQL INDEX1 END1) (NOT (EQL (CAR SUBSEQ1) (CAR SUBSEQ2] INDEX1)) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ([OR (EQL INDEX1 END1) (NOT (EQL (CAR SUBSEQ1) (CL:AREF SEQUENCE2 INDEX2] INDEX1))) (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ([OR (EQL INDEX1 END1) (NOT (EQL (CL:AREF SEQUENCE1 INDEX1) (CAR SUBSEQ2] INDEX1)) (CL:DO ((INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ([OR (EQL INDEX1 END1) (NOT (EQL (CL:AREF SEQUENCE1 INDEX1) (CL:AREF SEQUENCE2 INDEX2] INDEX1))]) (CL:DEFUN CL:MISMATCH (SEQUENCE1 SEQUENCE2 &KEY (START1 0) END1 (START2 0) END2 (FROM-END NIL FROM-END-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY 'CL:IDENTITY KEY-P)) [LET ((LENGTH1 (CL:LENGTH SEQUENCE1)) (LENGTH2 (CL:LENGTH SEQUENCE2))) (CL:IF (NULL END1) (SETQ END1 LENGTH1)) (CL:IF (NULL END2) (SETQ END2 LENGTH2)) (CHECK-SUBSEQ SEQUENCE1 START1 END1 LENGTH1) (CHECK-SUBSEQ SEQUENCE2 START2 END2 LENGTH2) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both Test and test-not provided")) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2))) (CL:IF FROM-END (LET ((INDEX (COMPLEX-COMPARE-BACKWARD SEQUENCE1 SEQUENCE2 START1 END1 START2 END2 KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P))) (CL:IF (AND (EQL INDEX START1) (EQL SUBLEN1 SUBLEN2)) NIL INDEX)) (LET [(INDEX (CL:IF (OR KEY-P TEST-P TEST-NOT-P KEY-P) (COMPLEX-COMPARE-FORWARD SEQUENCE1 SEQUENCE2 START1 END1 START2 END2 KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-COMPARE SEQUENCE1 SEQUENCE2 START1 END1 START2 END2))] (CL:IF (AND (EQL INDEX END1) (EQL SUBLEN1 SUBLEN2)) NIL INDEX)))]) (CL:DEFUN CL:SEARCH (SEQUENCE1 SEQUENCE2 &KEY (START1 0) END1 (START2 0) END2 (FROM-END NIL FROM-END-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P) (KEY 'CL:IDENTITY KEY-P)) "A search is conducted for the first subsequence of sequence2 which element-wise matches sequence1. If there is such a subsequence in sequence2, the index of the its leftmost element is returned otherwise () is returned." [LET ((LENGTH1 (CL:LENGTH SEQUENCE1)) (LENGTH2 (CL:LENGTH SEQUENCE2))) (CL:IF (NULL END1) (SETQ END1 LENGTH1)) (CL:IF (NULL END2) (SETQ END2 LENGTH2)) (CHECK-SUBSEQ SEQUENCE1 START1 END1 LENGTH1) (CHECK-SUBSEQ SEQUENCE2 START2 END2 LENGTH2) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both Test and test-not provided")) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2))) (CL:IF (NULL FROM-END) (CL:IF (NOT (OR TEST-P TEST-NOT-P KEY-P)) (CL:DO ((SUBSTART2 START2 (CL:1+ SUBSTART2)) (END-SEARCH (- END2 SUBLEN1))) ((> SUBSTART2 END-SEARCH)) (CL:IF (EQL (SIMPLE-COMPARE SEQUENCE1 SEQUENCE2 START1 END1 SUBSTART2 END2) END1) (RETURN SUBSTART2))) (CL:DO ((SUBSTART2 START2 (CL:1+ SUBSTART2)) (END-SEARCH (- END2 SUBLEN1)) (PREDICATE (CL:IF TEST-NOT-P TEST-NOT TEST)) INDEX) ((> SUBSTART2 END-SEARCH)) (SETQ INDEX (COMPLEX-COMPARE-FORWARD SEQUENCE1 SEQUENCE2 START1 END1 SUBSTART2 END2 KEY PREDICATE TEST-NOT-P)) (CL:IF (EQL INDEX END1) (RETURN SUBSTART2)))) (CL:IF (NOT (OR TEST-P TEST-NOT-P KEY-P)) (CL:DO ((SUBSTART2 (- END2 SUBLEN1) (CL:1- SUBSTART2))) ((< SUBSTART2 START2)) (CL:IF (EQL (SIMPLE-COMPARE SEQUENCE1 SEQUENCE2 START1 END1 SUBSTART2 END2) END1) (RETURN SUBSTART2))) (CL:DO ((SUBSTART2 (- END2 SUBLEN1) (CL:1- SUBSTART2)) (PREDICATE (CL:IF TEST-NOT-P TEST-NOT TEST))) ((< SUBSTART2 START2)) (CL:IF (EQL (COMPLEX-COMPARE-FORWARD SEQUENCE1 SEQUENCE2 START1 END1 SUBSTART2 END2 KEY PREDICATE TEST-NOT-P) END1) (RETURN SUBSTART2)))))]) (PUTPROPS CMLSEQFINDER FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSEQFINDER COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSEQMAPPERS b/sources/CMLSEQMAPPERS new file mode 100644 index 00000000..184c9afa --- /dev/null +++ b/sources/CMLSEQMAPPERS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:31:36" {DSK}local>lde>lispcore>sources>CMLSEQMAPPERS.;2 17365 changes to%: (VARS CMLSEQMAPPERSCOMS) previous date%: " 1-Jun-87 11:21:23" {DSK}local>lde>lispcore>sources>CMLSEQMAPPERS.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQMAPPERSCOMS) (RPAQQ CMLSEQMAPPERSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS %%FILL-SLICE %%MAP-FOR-EFFECT %%MAP-FOR-EFFECT-MULTIPLE %%MAP-FOR-EFFECT-SINGLE %%MAP-FOR-RESULT-MULTIPLE %%MAP-FOR-RESULT-SINGLE %%MIN-SEQUENCE-LENGTH CL:MAP) (* ;; "For compatibility with old optimizers") (FUNCTIONS %%MAP-SINGLE-FOR-EFFECT %%MAP-SINGLE-TO-LIST %%MAP-SINGLE-TO-SIMPLE %%MAP-TO-LIST %%MAP-TO-SIMPLE) (OPTIMIZERS CL:MAP) (FUNCTIONS %%SOME-MULTIPLE %%SOME-SINGLE %%EVERY-MULTIPLE %%EVERY-SINGLE %%NOTANY-MULTIPLE %%NOTANY-SINGLE %%NOTEVERY-MULTIPLE %%NOTEVERY-SINGLE CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (* ;; "For compatibility with old optimizers") (P (MOVD '%%SOME-SINGLE '%%SINGLE-SOME) (MOVD '%%EVERY-SINGLE '%%SINGLE-EVERY) (MOVD '%%NOTEVERY-SINGLE '%%SINGLE-NOTEVERY) (MOVD '%%NOTANY-SINGLE '%%SINGLE-NOTANY)) (OPTIMIZERS CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (FUNCTIONS REDUCE-FROM-END REDUCE-FROM-START CL:REDUCE) (PROP FILETYPE CMLSEQMAPPERS) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD CMLSEQCOMMON) ) (DEFMACRO %%FILL-SLICE (INDEX SLICE SEQUENCES) `(CL:DO ((%%SUBSLICE ,SLICE (CDR %%SUBSLICE)) (%%SUBSEQ ,SEQUENCES (CDR %%SUBSEQ)) %%SEQUENCE) ((NULL %%SUBSEQ) ,SLICE) (SETQ %%SEQUENCE (CAR %%SUBSEQ)) [RPLACA %%SUBSLICE (SEQ-DISPATCH %%SEQUENCE (PROG1 (CAR %%SEQUENCE) (RPLACA %%SUBSEQ (CDR %%SEQUENCE))) (CL:AREF %%SEQUENCE ,INDEX])) (CL:DEFUN %%MAP-FOR-EFFECT (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES)))) (CL:DEFUN %%MAP-FOR-EFFECT-MULTIPLE (FUNCTION SEQUENCES) [LET [(MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES] (CL:DOTIMES (I MIN-LENGTH) (CL:APPLY FUNCTION (%%FILL-SLICE I ELT-SLICE SEQUENCES)))]) (CL:DEFUN %%MAP-FOR-EFFECT-SINGLE (FUNCTION SEQUENCE) [SEQ-DISPATCH SEQUENCE (CL:DOLIST (ELT SEQUENCE) (CL:FUNCALL FUNCTION ELT)) (CL:DOTIMES (I (VECTOR-LENGTH SEQUENCE)) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE I)))]) (CL:DEFUN %%MAP-FOR-RESULT-MULTIPLE (RESULT-TYPE FUNCTION SEQUENCES) [LET* ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES))) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE MIN-LENGTH))) (SEQ-DISPATCH RESULT (CL:DO ((SUBRESULT RESULT (CDR SUBRESULT)) (INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (RPLACA SUBRESULT (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (CL:SETF (CL:AREF RESULT INDEX) (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))))]) (CL:DEFUN %%MAP-FOR-RESULT-SINGLE (RESULT-TYPE FUNCTION SEQUENCE) (LET* ((LENGTH (CL:LENGTH SEQUENCE)) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE LENGTH))) [SEQ-DISPATCH SEQUENCE [SEQ-DISPATCH RESULT (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (SUBRESULT RESULT (CDR SUBRESULT))) ((NULL SUBSEQ)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CAR SUBSEQ)))) (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (INDEX 0 (CL:1+ INDEX))) ((NULL SUBSEQ)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CAR SUBSEQ))))] (SEQ-DISPATCH RESULT (CL:DO ((INDEX 0 (CL:1+ INDEX)) (SUBRESULT RESULT (CDR SUBRESULT))) ((EQL INDEX LENGTH)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX LENGTH)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX))))] RESULT)) (DEFMACRO %%MIN-SEQUENCE-LENGTH (SEQUENCES) `(CL:DO ([MIN-LENGTH (CL:LENGTH (CAR ,SEQUENCES] (SUBSEQ (CDR ,SEQUENCES) (CDR SUBSEQ)) NEXT-LENGTH) ((NULL SUBSEQ) MIN-LENGTH) (SETQ NEXT-LENGTH (CL:LENGTH (CAR SUBSEQ))) (CL:IF (< NEXT-LENGTH MIN-LENGTH) (SETQ MIN-LENGTH NEXT-LENGTH)))) (CL:DEFUN CL:MAP (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) "FUNCTION must take as many arguments as there are sequences provided. The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences." (CL:IF (NULL RESULT-TYPE) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))) (* ;; "For compatibility with old optimizers") (CL:DEFUN %%MAP-SINGLE-FOR-EFFECT (FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE)) (CL:DEFUN %%MAP-SINGLE-TO-LIST (FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE 'LIST FUNCTION SEQUENCE)) (CL:DEFUN %%MAP-SINGLE-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE)) (CL:DEFUN %%MAP-TO-LIST (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE 'LIST FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE 'LIST FUNCTION (CONS SEQUENCE MORE-SEQUENCES)))) (CL:DEFUN %%MAP-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES)))) (DEFOPTIMIZER CL:MAP (RESULT-TYPE FUNCTION FIRST-SEQUNCE &REST MORE-SEQUENCES) (CL:IF (AND (NULL MORE-SEQUENCES) (CL:CONSTANTP RESULT-TYPE)) (CL:IF (NULL (EVAL RESULT-TYPE)) `(%%MAP-FOR-EFFECT-SINGLE ,FUNCTION ,FIRST-SEQUNCE) `(%%MAP-FOR-RESULT-SINGLE ,RESULT-TYPE ,FUNCTION ,FIRST-SEQUNCE)) 'COMPILER:PASS)) (CL:DEFUN %%SOME-MULTIPLE (PREDICATE SEQUENCES) [LET [(MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES] (CL:DO ((INDEX 0 (CL:1+ INDEX)) PREDICATE-RESULT) ((EQL INDEX MIN-LENGTH)) (SETQ PREDICATE-RESULT (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT)))]) (CL:DEFUN %%SOME-SINGLE (PREDICATE SEQUENCE) [LET ((LENGTH (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT))) (FORWARD-VECTOR-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT]) (CL:DEFUN %%EVERY-MULTIPLE (PREDICATE SEQUENCES) [LET [(MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES] (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN NIL)))]) (CL:DEFUN %%EVERY-SINGLE (PREDICATE FIRST-SEQUENCE) [SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN NIL))) (CL:DOTIMES (INDEX (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE INDEX))) (RETURN NIL)))]) (CL:DEFUN %%NOTANY-MULTIPLE (PREDICATE SEQUENCES) [LET [(MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES] (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)) (RETURN NIL)))]) (CL:DEFUN %%NOTANY-SINGLE (PREDICATE FIRST-SEQUENCE) [SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (CL:FUNCALL PREDICATE ELT) (RETURN NIL))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I)) (RETURN NIL)))]) (CL:DEFUN %%NOTEVERY-MULTIPLE (PREDICATE SEQUENCES) [LET [(MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES] (CL:DOTIMES (INDEX MIN-LENGTH) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN T)))]) (CL:DEFUN %%NOTEVERY-SINGLE (PREDICATE FIRST-SEQUENCE) [SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN T))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE)) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I))) (RETURN T)))]) (CL:DEFUN CL:SOME (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. SOME returns the first non-() value encountered, or () if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%SOME-SINGLE PREDICATE FIRST-SEQUENCE) (%%SOME-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES)))) (CL:DEFUN CL:EVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%EVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%EVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES)))) (CL:DEFUN CL:NOTANY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%NOTANY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTANY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES)))) (CL:DEFUN CL:NOTEVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on. NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%NOTEVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTEVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES)))) (* ;; "For compatibility with old optimizers") (MOVD '%%SOME-SINGLE '%%SINGLE-SOME) (MOVD '%%EVERY-SINGLE '%%SINGLE-EVERY) (MOVD '%%NOTEVERY-SINGLE '%%SINGLE-NOTEVERY) (MOVD '%%NOTANY-SINGLE '%%SINGLE-NOTANY) (DEFOPTIMIZER CL:SOME (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND [(NULL MORE-SEQUENCES) `(%%SOME-SINGLE ,PREDICATE ,SEQUENCE] (T 'COMPILER:PASS))) (DEFOPTIMIZER CL:EVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND [(NULL MORE-SEQUENCES) `(%%EVERY-SINGLE ,PREDICATE ,SEQUENCE] (T 'COMPILER:PASS))) (DEFOPTIMIZER CL:NOTANY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND [(NULL MORE-SEQUENCES) `(%%NOTANY-SINGLE ,PREDICATE ,SEQUENCE] (T 'COMPILER:PASS))) (DEFOPTIMIZER CL:NOTEVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND [(NULL MORE-SEQUENCES) `(%%NOTEVERY-SINGLE ,PREDICATE ,SEQUENCE] (T 'COMPILER:PASS))) (CL:DEFUN REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE) "Backward reduction" [SEQ-DISPATCH SEQUENCE (BACKWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE) ) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR))) (BACKWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR]) (CL:DEFUN REDUCE-FROM-START (FUNCTION SEQUENCE START END INITIAL-VALUE) [SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT]) (CL:DEFUN CL:REDUCE (FUNCTION SEQUENCE &KEY (START 0) END FROM-END (INITIAL-VALUE NIL INITIAL-VALUE-P)) [LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF INITIAL-VALUE-P (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START END INITIAL-VALUE) (REDUCE-FROM-START FUNCTION SEQUENCE START END INITIAL-VALUE)) (CASE (- END START) (0 (CL:FUNCALL FUNCTION)) (1 (CL:ELT SEQUENCE START)) (T (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START (CL:1- END) (CL:ELT SEQUENCE (CL:1- END))) (REDUCE-FROM-START FUNCTION SEQUENCE (CL:1+ START) END (CL:ELT SEQUENCE START))))))]) (PUTPROPS CMLSEQMAPPERS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSEQMAPPERS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSEQMODIFY b/sources/CMLSEQMODIFY new file mode 100644 index 00000000..4a7a432b --- /dev/null +++ b/sources/CMLSEQMODIFY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:33:28" {DSK}local>lde>lispcore>sources>CMLSEQMODIFY.;2 54221 changes to%: (VARS CMLSEQMODIFYCOMS) previous date%: "15-Mar-87 15:52:22" {DSK}local>lde>lispcore>sources>CMLSEQMODIFY.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSEQMODIFYCOMS) (RPAQQ CMLSEQMODIFYCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS CL:FILL CL:REPLACE) (FUNCTIONS %%DESTRUCTIVE-RESULT-VECTOR) (FUNCTIONS SIMPLE-REMOVE-MACRO SIMPLE-REMOVE SIMPLE-REMOVE-IF SIMPLE-REMOVE-IF-NOT COMPLEX-REMOVE-MACRO COMPLEX-REMOVE COMPLEX-REMOVE-IF COMPLEX-REMOVE-IF-NOT CL:REMOVE CL:REMOVE-IF CL:REMOVE-IF-NOT) (FUNCTIONS SIMPLE-DELETE-MACRO SIMPLE-DELETE SIMPLE-DELETE-IF SIMPLE-DELETE-IF-NOT COMPLEX-DELETE-MACRO COMPLEX-DELETE COMPLEX-DELETE-IF COMPLEX-DELETE-IF-NOT CL:DELETE CL:DELETE-IF CL:DELETE-IF-NOT) (FUNCTIONS SIMPLE-REMOVE-DUPLICATES COMPLEX-REMOVE-DUPLICATES CL:REMOVE-DUPLICATES) (FUNCTIONS SIMPLE-DELETE-DUPLICATES COMPLEX-DELETE-DUPLICATES CL:DELETE-DUPLICATES) (FUNCTIONS SIMPLE-SUBSTITUTE-MACRO SIMPLE-SUBSTITUTE SIMPLE-SUBSTITUTE-IF SIMPLE-SUBSTITUTE-IF-NOT COMPLEX-SUBSTITUTE-MACRO COMPLEX-SUBSTITUTE COMPLEX-SUBSTITUTE-IF COMPLEX-SUBSTITUTE-IF-NOT CL:SUBSTITUTE CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT) (FUNCTIONS SIMPLE-NSUBSTITUTE-MACRO SIMPLE-NSUBSTITUTE SIMPLE-NSUBSTITUTE-IF SIMPLE-NSUBSTITUTE-IF-NOT COMPLEX-NSUBSTITUTE-MACRO COMPLEX-NSUBSTITUTE COMPLEX-NSUBSTITUTE-IF COMPLEX-NSUBSTITUTE-IF-NOT CL:NSUBSTITUTE CL:NSUBSTITUTE-IF CL:NSUBSTITUTE-IF-NOT) (PROP FILETYPE CMLSEQMODIFY) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD CMLSEQCOMMON) ) (CL:DEFUN CL:FILL (SEQUENCE ITEM &KEY (START 0) END) "Replace the specified elements of SEQUENCE with ITEM." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT) SEQUENCE (RPLACA %%SUBSEQ ITEM)) (FILL-VECTOR-SUBSEQ SEQUENCE START END ITEM)))) (CL:DEFUN CL:REPLACE (SEQUENCE1 SEQUENCE2 &KEY (START1 0) END1 (START2 0) END2) (LET ((LENGTH1 (CL:LENGTH SEQUENCE1)) (LENGTH2 (CL:LENGTH SEQUENCE2))) (CL:IF (NULL END1) (SETQ END1 LENGTH1)) (CL:IF (NULL END2) (SETQ END2 LENGTH2)) (CHECK-SUBSEQ SEQUENCE1 START1 END1 LENGTH1) (CHECK-SUBSEQ SEQUENCE2 START2 END2 LENGTH2) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2))) (* ; "Make equal length") (CL:IF (< SUBLEN1 SUBLEN2) (SETQ END2 (+ START2 SUBLEN1)) (SETQ END1 (+ START1 SUBLEN2))) (* ; "Check for overlap") (CL:WHEN (AND (EQ SEQUENCE1 SEQUENCE2) (> START1 START2) (< START1 END2)) (SETQ SEQUENCE2 (CL:SUBSEQ SEQUENCE2 START2 END2)) (SETQ START2 0) (SETQ END2 (- END2 START2))) [SEQ-DISPATCH SEQUENCE1 [SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CAR SUBSEQ2))) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CL:AREF SEQUENCE2 INDEX2)))] (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CAR SUBSEQ2))) (CL:DO ((INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CL:AREF SEQUENCE2 INDEX2)))] SEQUENCE1))) (CL:DEFUN %%DESTRUCTIVE-RESULT-VECTOR (VECTOR START) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P VECTOR) VECTOR (LET ((RESULT (CL:MAKE-ARRAY (VECTOR-LENGTH VECTOR) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE VECTOR) :FILL-POINTER T))) (COPY-VECTOR VECTOR RESULT :END1 START)))) (DEFMACRO SIMPLE-REMOVE-MACRO (SEQUENCE START END TEST-FORM) `(SEQ-DISPATCH ,SEQUENCE (LET [(RESULT-HEAD (CL:SUBSEQ ,SEQUENCE 0 ,START)) (RESULT-TAIL (CL:NTHCDR ,END ,SEQUENCE)) (RESULT-MIDDLE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT ,TEST-FORM) (COLLECT-ITEM CURRENT NEW-LIST TAIL] (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH ,SEQUENCE)) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ,SEQUENCE) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ ,SEQUENCE 0 ,START RESULT 0) [FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (SLOW-INDEX ,START)) NIL (COND ((NOT ,TEST-FORM) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT (- ,END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))) (CL:DEFUN SIMPLE-REMOVE (ITEM SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (EQL ITEM CURRENT))) (CL:DEFUN SIMPLE-REMOVE-IF (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-REMOVE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-REMOVE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) `(LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH ,SEQUENCE (LET [(RESULT-HEAD (CL:SUBSEQ ,SEQUENCE 0 ,START)) (RESULT-TAIL (CL:NTHCDR ,END ,SEQUENCE)) (RESULT-MIDDLE (CL:IF (NULL (AND ,FROM-END ,COUNT)) [FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (COLLECT-ITEM CURRENT NEW-LIST TAIL)) (T (CL:INCF NUMBER-OF-MATCHES] [BACKWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST) NEW-LIST (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (CL:PUSH CURRENT NEW-LIST)) (T (CL:INCF NUMBER-OF-MATCHES])] (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH ,SEQUENCE)) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ,SEQUENCE) :FILL-POINTER T))) (COPY-VECTOR-SUBSEQ ,SEQUENCE 0 ,START RESULT 0) (CL:IF (NULL (AND ,FROM-END ,COUNT)) [FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (RESULT-INDEX ,START)) NIL (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] [BACKWARD-VECTOR-LOOP ,SEQUENCE ,START ,END [INDEX CURRENT (RESULT-INDEX (CL:1- ,END] (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ ,START NUMBER-OF-MATCHES) ,END RESULT ,START (- ,END NUMBER-OF-MATCHES))) (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:DECF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES]) (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT (- ,END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))) (CL:DEFUN COMPLEX-REMOVE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) [COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-REMOVE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-REMOVE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) [COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:REMOVE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-REMOVE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE ITEM SEQUENCE START END)))) (CL:DEFUN CL:REMOVE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF TEST SEQUENCE START END)))) (CL:DEFUN CL:REMOVE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF-NOT TEST SEQUENCE START END)))) (DEFMACRO SIMPLE-DELETE-MACRO (SEQUENCE START END TEST-FORM) `(SEQ-DISPATCH ,SEQUENCE [LET [(HANDLE (CONS NIL ,SEQUENCE] (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (PREVIOUS (CL:NTHCDR ,START HANDLE))) (CDR HANDLE) (CL:IF (NOT ,TEST-FORM) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ)))] (LET [(LENGTH (VECTOR-LENGTH ,SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR ,SEQUENCE ,START] [FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (SLOW-INDEX ,START)) NIL (COND ((NOT ,TEST-FORM) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT (- ,END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))) (CL:DEFUN SIMPLE-DELETE (ITEM SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (EQL ITEM CURRENT))) (CL:DEFUN SIMPLE-DELETE-IF (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-DELETE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-DELETE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) `(LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH ,SEQUENCE [LET [(HANDLE (CONS NIL ,SEQUENCE] (CL:IF (NULL (AND ,FROM-END ,COUNT)) (CL:DO ((PREVIOUS (CL:NTHCDR ,START HANDLE)) (%%SUBSEQ (CL:NTHCDR ,START ,SEQUENCE) (CDR %%SUBSEQ)) (INDEX ,START (CL:1+ INDEX)) CURRENT) ([OR (EQL INDEX ,END) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] (CDR HANDLE)) (SETQ CURRENT (CAR %%SUBSEQ)) (COND ((NOT ,TEST-FORM) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))) (CL:DO ((INDEX (CL:1- ,END) (CL:1- INDEX)) (LAST (CL:NTHCDR ,END ,SEQUENCE)) PREVIOUS CURRENT) ([OR (< INDEX ,START) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] (CDR HANDLE)) (SETQ PREVIOUS (CL:NTHCDR INDEX HANDLE)) (SETQ CURRENT (CADR PREVIOUS)) (COND ((NOT ,TEST-FORM) (SETQ LAST (CDR PREVIOUS))) (T (RPLACD PREVIOUS LAST) (CL:INCF NUMBER-OF-MATCHES)))))] (LET [(LENGTH (VECTOR-LENGTH ,SEQUENCE)) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR ,SEQUENCE ,START] (CL:IF (NULL (AND ,FROM-END ,COUNT)) [FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT (SLOW-INDEX ,START)) NIL (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] [BACKWARD-VECTOR-LOOP ,SEQUENCE ,START ,END [INDEX CURRENT (SLOW-INDEX (CL:1- ,END] (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ ,START NUMBER-OF-MATCHES) ,END RESULT ,START (- ,END NUMBER-OF-MATCHES))) (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:DECF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES]) (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT (- ,END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))) (CL:DEFUN COMPLEX-DELETE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) [COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-DELETE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-DELETE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) [COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:DELETE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-DELETE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE ITEM SEQUENCE START END)))) (CL:DEFUN CL:DELETE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF TEST SEQUENCE START END)))) (CL:DEFUN CL:DELETE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF-NOT TEST SEQUENCE START END)))) (CL:DEFUN SIMPLE-REMOVE-DUPLICATES (SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END))) (CL:DEFUN COMPLEX-REMOVE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE (LET [(RESULT-HEAD (CL:SUBSEQ SEQUENCE 0 START)) (RESULT-TAIL (CL:NTHCDR END SEQUENCE)) (RESULT-MIDDLE (CL:IF (NULL FROM-END) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL ) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL ) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))))] (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH SEQUENCE)) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ SEQUENCE 0 START RESULT 0) (CL:IF (NULL FROM-END) [FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] [FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES]) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))) (CL:DEFUN CL:REMOVE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) "The elements of Sequence are examined, and if any two match, one is discarded. The resulting sequence is returned." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-REMOVE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE-DUPLICATES SEQUENCE START END)))) (CL:DEFUN SIMPLE-DELETE-DUPLICATES (SEQUENCE START END) (SEQ-DISPATCH SEQUENCE [LET ((HANDLE (CONS NIL SEQUENCE))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (PREVIOUS (CL:NTHCDR START HANDLE)) ) (CDR HANDLE) (CL:IF (NOT (SIMPLE-POSITION CURRENT (CDR %%SUBSEQ) 0 (- END INDEX 1))) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ)))] (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) [FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (SLOW-INDEX START)) NIL (COND ((NOT (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))) (CL:DEFUN COMPLEX-DELETE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE [LET ((HANDLE (CONS NIL SEQUENCE))) (CL:IF (NULL FROM-END) (CL:DO ((PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) (CDR %%SUBSEQ) 0 (- END INDEX 1) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ)))) (CL:DO ((NUMBER-OF-MATCHES 0) (PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) SEQUENCE START (- INDEX NUMBER-OF-MATCHES) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))))] (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) (CL:IF (NULL FROM-END) [FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES] [FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES]) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))) (CL:DEFUN CL:DELETE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-DELETE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE-DUPLICATES SEQUENCE START END)))) (DEFMACRO SIMPLE-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) `(SEQ-DISPATCH ,SEQUENCE (LET [(RESULT-HEAD (CL:SUBSEQ ,SEQUENCE 0 ,START)) (RESULT-TAIL (CL:NTHCDR ,END ,SEQUENCE)) (RESULT-MIDDLE (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (CL:IF ,TEST-FORM ,NEWITEM CURRENT)) (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL] (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* [(LENGTH (VECTOR-LENGTH ,SEQUENCE)) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ,SEQUENCE] (COPY-VECTOR-SUBSEQ ,SEQUENCE 0 ,START RESULT 0) (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (CL:IF ,TEST-FORM ,NEWITEM CURRENT))) (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT ,END) RESULT))) (CL:DEFUN SIMPLE-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT))) (CL:DEFUN SIMPLE-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) `(LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH ,SEQUENCE (LET [(RESULT-HEAD (CL:SUBSEQ ,SEQUENCE 0 ,START)) (RESULT-TAIL (CL:NTHCDR ,END ,SEQUENCE)) (RESULT-MIDDLE (CL:IF (NULL (AND ,FROM-END ,COUNT)) (FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST [SETQ NEW-ELEMENT (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) ,NEWITEM] (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL)) (BACKWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST NEW-ELEMENT) NEW-LIST [SETQ NEW-ELEMENT (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) ,NEWITEM] (CL:PUSH NEW-ELEMENT NEW-LIST)))] (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* [(LENGTH (VECTOR-LENGTH ,SEQUENCE)) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE ,SEQUENCE] (COPY-VECTOR-SUBSEQ ,SEQUENCE 0 ,START RESULT 0) (CL:IF (NULL ,FROM-END) [FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) ,NEWITEM] [BACKWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT)) (NOT ,TEST-FORM)) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) ,NEWITEM]) (COPY-VECTOR-SUBSEQ ,SEQUENCE ,END LENGTH RESULT ,END) RESULT)))) (CL:DEFUN COMPLEX-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) [COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) [COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:SUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END)))) (CL:DEFUN CL:SUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END)))) (CL:DEFUN CL:SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END)))) (DEFMACRO SIMPLE-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) `[SEQ-DISPATCH ,SEQUENCE [FORWARD-LIST-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) ,SEQUENCE (CL:IF ,TEST-FORM (RPLACA %%SUBSEQ ,NEWITEM))] (FORWARD-VECTOR-LOOP ,SEQUENCE ,START ,END (INDEX CURRENT) ,SEQUENCE (CL:IF ,TEST-FORM (CL:SETF (CL:AREF ,SEQUENCE INDEX) ,NEWITEM))]) (CL:DEFUN SIMPLE-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT))) (CL:DEFUN SIMPLE-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT))) (CL:DEFUN SIMPLE-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT)))) (DEFMACRO COMPLEX-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) `[LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH ,SEQUENCE (CL:IF (NULL (AND ,FROM-END ,COUNT)) (CL:DO ((%%SUBSEQ (CL:NTHCDR ,START ,SEQUENCE) (CDR %%SUBSEQ)) (INDEX ,START (CL:1+ INDEX)) CURRENT) ([OR (EQL INDEX ,END) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] ,SEQUENCE) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND ,TEST-FORM (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ ,NEWITEM))) (CL:DO ((INDEX (CL:1- ,END) (CL:1- INDEX)) %%SUBSEQ CURRENT) ([OR (< INDEX ,START) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] ,SEQUENCE) (SETQ %%SUBSEQ (CL:NTHCDR INDEX ,SEQUENCE)) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND ,TEST-FORM (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ ,NEWITEM)))) (LET [(LENGTH (VECTOR-LENGTH ,SEQUENCE] (CL:IF (NULL ,FROM-END) (CL:DO ((INDEX ,START (CL:1+ INDEX)) CURRENT) ([OR (EQL INDEX ,END) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] ,SEQUENCE) (SETQ CURRENT (CL:AREF ,SEQUENCE INDEX)) (CL:IF (AND ,TEST-FORM (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF ,SEQUENCE INDEX) ,NEWITEM))) (CL:DO ((INDEX (CL:1- ,END) (CL:1- INDEX)) CURRENT) ([OR (< INDEX ,START) (AND ,COUNT (>= NUMBER-OF-MATCHES ,COUNT] ,SEQUENCE) (SETQ CURRENT (CL:AREF ,SEQUENCE INDEX)) (CL:IF (AND ,TEST-FORM (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF ,SEQUENCE INDEX) ,NEWITEM))))]) (CL:DEFUN COMPLEX-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) [COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))]) (CL:DEFUN COMPLEX-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))) (CL:DEFUN COMPLEX-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) [COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT]) (CL:DEFUN CL:NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P) (TEST 'EQL TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END)))) (CL:DEFUN CL:NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END)))) (CL:DEFUN CL:NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY 'CL:IDENTITY KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END)))) (PUTPROPS CMLSEQMODIFY FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSEQMODIFY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSETF b/sources/CMLSETF new file mode 100644 index 00000000..501cd788 --- /dev/null +++ b/sources/CMLSETF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (il:filecreated "13-Jun-90 16:19:18" il:|{PELE:MV:ENVOS}SOURCES>CMLSETF.;6| 40556 il:|changes| il:|to:| (il:functions get-setf-method) il:|previous| il:|date:| "11-Jun-90 15:06:52" il:|{PELE:MV:ENVOS}SOURCES>CMLSETF.;5| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:cmlsetfcoms) (il:rpaqq il:cmlsetfcoms ((il:functions get-setf-method get-simple-setf-method get-setf-method-multiple-value) (il:define-types il:setfs) (il:functions defsetf define-modify-macro define-setf-method) (il:coms (il:* il:|;;| "Support for defstruct and friends ") (il:functions define-shared-setf-macro define-shared-setf get-shared-setf-method)) (il:functions setf setf-error) (il:functions psetf shiftf rotatef pop remf) (il:functions incf decf) (il:functions maybe-make-binding-form count-occurrences) (il:functions push pushnew) (il:setfs car cdr caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr first second third fourth fifth sixth seventh eighth ninth tenth rest nthcdr nth getf apply ldb mask-field char-bit the) (il:coms (il:* il:\;  "Some IL setfs, for no especially good reason") (il:setfs il:gethash) (il:functions il:%set-il-gethash)) (il:prop il:proptype :setf-method-expander :setf-inverse :shared-setf-inverse) (il:prop (il:filetype il:makefile-environment) il:cmlsetf) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars (il:nlama) (il:nlaml) (il:lama))))) (defun get-setf-method (form &optional environment) (let (temp) (cond ((symbolp form) (il:* il:|;;| "Symbols have a simple, constant SETF method.") (values nil nil (list (setq temp (il:gensym))) `(setq ,form ,temp) form)) ((not (consp form)) (il:* il:\; "Syntax error") (setf-error form)) ((setq temp (il:local-macro-function (car form) environment)) (il:* il:|;;|  "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (get-setf-method (funcall temp form environment) environment)) ((setq temp (or (get (car form) ':setf-inverse) (get (car form) 'il:setf-inverse) (get (car form) 'il:setfn))) (get-simple-setf-method form temp)) ((setq temp (get (car form) ':shared-setf-inverse)) (get-shared-setf-method form temp)) ((setq temp (or (get (car form) ':setf-method-expander) (get (car form) 'il:setf-method-expander))) (il:* il:|;;| "Do check number of the Store Variables") (multiple-value-bind (temps values stores setter getter) (funcall temp form environment) (when (/= (length stores) 1) (warn "SETF method contains more than one store variable. Only top of the elements was accepted." ) (setq stores (list (car stores)))) (values temps values stores setter getter))) (t (multiple-value-bind (expansion done) (macroexpand-1 form environment) (if (and done (not (eq expansion form))) (get-setf-method expansion environment) (setf-error (car form) form))))))) (defun get-simple-setf-method (form setf-inverse) (il:* il:|;;| "Produce SETF method for a form that has a setf-inverse. Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (let ((new-var (il:gensym)) vars vals args setf-inverse-form get-form) (setq args (mapcar #'(lambda (arg) (cond ((if (consp arg) (eq (car arg) 'quote) (constantp arg)) (il:* il:|;;| "We don't need gensym for this constant argument. The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") arg) (t (il:* il:|;;|  "Anything else might be side-effected, so will need to bind") (push arg vals) (let ((g (il:gensym))) (push g vars) g)))) (cdr form))) (setq setf-inverse-form (macroexpand-1 `(,setf-inverse ,@args ,new-var))) (setq get-form (macroexpand-1 `(,(car form) ,@args))) (il:* il:|;;|  "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (values (setq vars (nreverse vars)) (setq vals (nreverse vals)) (list new-var) setf-inverse-form get-form))) (defun get-setf-method-multiple-value (form &optional environment) (let (temp) (cond ((symbolp form) (il:* il:|;;| "Symbols have a simple, constant SETF method.") (values nil nil (list (setq temp (il:gensym))) `(setq ,form ,temp) form)) ((not (consp form)) (il:* il:\; "Syntax error") (setf-error form)) ((setq temp (il:local-macro-function (car form) environment)) (il:* il:|;;|  "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (get-setf-method (funcall temp form environment) environment)) ((setq temp (or (get (car form) ':setf-inverse) (get (car form) 'il:setf-inverse) (get (car form) 'il:setfn))) (get-simple-setf-method form temp)) ((setq temp (get (car form) ':shared-setf-inverse)) (get-shared-setf-method form temp)) ((setq temp (or (get (car form) ':setf-method-expander) (get (car form) 'il:setf-method-expander))) (il:* il:|;;| "Does not check the number of Store Variables.") (funcall temp form environment)) (t (multiple-value-bind (expansion done) (macroexpand-1 form environment) (if (and done (not (eq expansion form))) (get-setf-method expansion environment) (setf-error (car form) form))))))) (xcl:def-define-type il:setfs "Common Lisp SETF definitions") (xcl:defdefiner (defsetf (:prototype (lambda (name) (and (symbolp name) `(defsetf ,name "Inverse function"))))) il:setfs ( name &rest rest &environment env) (il:* il:|;;;| "Associates a SETF update function or macro with the specified access function or macro") (cond ((null rest) (error "No body for DEFSETF of ~A" name)) ((and (listp (car rest)) (cdr rest) (listp (cadr rest))) (il:* il:|;;| "The complex form:") (il:* il:|;;| "(defsetf access-fn args (store-var) {decl | doc}* {form}*)") (xcl:destructuring-bind (arg-list (store-var &rest others) &body body) rest (if others (cerror "Ignore the extra items in the list." "Currently only one new-value variable is allowed in DEFSETF.")) (let ((whole-var (xcl:pack (list name "-setf-form") (symbol-package name))) (environment (xcl:pack (list name "-setf-env") (symbol-package name))) (expander (xcl:pack (list name "-setf-expander") (symbol-package name)))) (multiple-value-bind (code decls doc) (il:parse-defmacro arg-list whole-var body name env :environment environment) `(progn (eval-when (eval compile load) (setf (symbol-function ',expander) #'(lambda (access-form ,environment) (let* ((dummies (mapcar #'(lambda (x) (il:gensym)) (cdr access-form))) (,whole-var (cons (car access-form) dummies)) (,store-var (il:gensym))) (values dummies (cdr access-form) (list ,store-var) (block ,name ,code) ,whole-var)))) (set-setf-method-expander ',name ',expander)) ,@(and doc `((setf (documentation ',name 'setf) ,doc)))))))) ((symbolp (car rest)) (il:* il:|;;| "The short form:") (il:* il:|;;| "(defsetf access-fn update-fn [doc])") (let ((update-fn (car rest)) (doc (cadr rest))) `(progn (eval-when (load compile eval) (set-setf-inverse ',name ',update-fn)) ,@(and doc `((setf (documentation ',name 'setf) ,doc)))))) (t (error "Ill-formed DEFSETF for ~S." name)))) (xcl:defdefiner (define-modify-macro (:prototype (lambda (name) (and (symbolp name) `(define-modify-macro ,name ,@( xcl::%make-function-prototype )))))) il:functions (name lambda-list function &optional doc-string) "Creates a new read-modify-write macro like PUSH or INCF." (let ((other-args nil) (rest-arg nil)) (do ((ll lambda-list (cdr ll)) (arg nil)) ((null ll)) (setq arg (car ll)) (cond ((eq arg '&optional)) ((eq arg '&rest) (setq rest-arg (cadr ll)) (return nil)) ((symbolp arg) (push arg other-args)) (t (push (car arg) other-args)))) (setq other-args (nreverse other-args)) `(defmacro ,name (si::%$$modify-macro-form ,@lambda-list &environment si::%$$modify-macro-environment) ,doc-string (multiple-value-bind (dummies vals newvals setter getter) (get-setf-method si::%$$modify-macro-form si::%$$modify-macro-environment) `(,'let* (,@(mapcar #'list dummies vals) (,(car newvals) ,,(if rest-arg `(list* ',function getter ,@other-args ,rest-arg) `(list ',function getter ,@other-args)))) ,setter))))) (xcl:defdefiner (define-setf-method (:prototype (lambda (name) (and (symbolp name) `(define-setf-method ,name ( "Arg list" ) "Body") )))) il:setfs (name lambda-list &environment env &body body) (let ((whole (xcl:pack (list "whole-" name) (symbol-package name))) (environment (xcl:pack (list "env-" name) (symbol-package name))) (expander (xcl:pack (list "setf-expander-" name) (symbol-package name)))) (multiple-value-bind (newbody local-decs doc) (il:parse-defmacro lambda-list whole body name env :environment environment :error-string "Setf expander for ~S cannot be called with ~S args.") `(eval-when (eval compile load) (defun ,expander (,whole ,environment) ,@local-decs (block ,name ,newbody)) (set-setf-method-expander ',name ',expander) ,@(and doc `((setf (documentation ',name 'setf) ,doc))))))) (il:* il:|;;| "Support for defstruct and friends ") (xcl:defdefiner define-shared-setf-macro il:functions (name accessor arg-list store-var &body body &environment env) (il:* il:|;;;| "Defines a shared SETF update function for a family of accessores -- used by defstruct") (if (not (and (consp store-var) (eq 1 (length store-var)))) (error "Store-var should be a list of one element: ~s" store-var)) (multiple-value-bind (code decls doc) (xcl:parse-body body env t) `(defmacro ,name (,accessor ,@arg-list ,@store-var) ,@doc ,@decls ,@code))) (xcl:defdefiner define-shared-setf il:setfs (name shared-expander &optional doc) (il:* il:|;;;| "Associates a shared SETF update macro with the specified accessor function -- used by defstruct") `(progn (eval-when (load compile eval) (set-shared-setf-inverse ',name ',shared-expander)) ,@(and doc `((setf (documentation ',name 'setf) ,doc))))) (defun get-shared-setf-method (form shared-setf-inverse) (il:* il:|;;| "Produce SETF method for a form that has a shared-setf-inverse. Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (let ((new-var (il:gensym)) vars vals args shared-setf-inverse-form get-form) (setq args (mapcar #'(lambda (arg) (cond ((if (consp arg) (eq (car arg) 'quote) (constantp arg)) (il:* il:|;;| "We don't need gensym for this constant argument. The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") arg) (t (il:* il:|;;|  "Anything else might be side-effected, so will need to bind") (push arg vals) (let ((g (il:gensym))) (push g vars) g)))) (cdr form))) (setq shared-setf-inverse-form (macroexpand-1 `(,shared-setf-inverse ,(car form) ,@args ,new-var))) (setq get-form (macroexpand-1 `(,(car form) ,@args))) (il:* il:|;;|  "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (values (setq vars (nreverse vars)) (setq vals (nreverse vals)) (list new-var) shared-setf-inverse-form get-form))) (defmacro setf (place new-value &rest others &environment env) (il:* il:|;;;| "Takes pairs of arguments like SETQ. The first is a place and the second is the value that is supposed to go into that place. Returns the last value. The place argument may be any of the access forms for which SETF knows a corresponding setting form.") (il:* il:|;;;| "We short-circuit the normal SETF-method mechanism for two very common special cases, so as to produce much simpler and more efficient code. The two cases are symbols and forms with simple inverses.") (cond (others `(progn (setf ,place ,new-value) (setf ,@others))) (t (prog (temp) lp (cond ((symbolp place) (return `(setq ,place ,new-value))) ((not (consp place)) (setf-error place)) ((setq temp (il:local-macro-function (car place) env)) (il:* il:|;;| "Before looking for an inverse, we have to macroexpand until it isn't a reference to a lexical macro, since those can't have SETF methods.") (setq place (funcall temp place env))) ((and (symbolp (car place)) (setq temp (or (get (car place) ':setf-inverse) (get (car place) 'il:setf-inverse) (get (car place) 'il:setfn)))) (return `(,temp ,@(cdr place) ,new-value))) ((and (symbolp (car place)) (setq temp (get (car place) ':shared-setf-inverse))) (return `(,temp ,(car place) ,@(cdr place) ,new-value))) ((or (get (car place) ':setf-method-expander) (get (car place) 'il:setf-method-expander)) (il:* il:|;;| "General setf hair") (return (multiple-value-bind (dummies vals newvals setter getter) (get-setf-method place env) `(,'let* (,@(mapcar #'list dummies vals) (,(car newvals) ,new-value)) ,setter)))) (t (il:* il:\; "Try macro expanding") (multiple-value-bind (expansion done) (macroexpand-1 place env) (cond ((and done (not (eq expansion place))) (setq place expansion)) (t (return (setf-error (car place) place))))))) (go lp))))) (defun setf-error (fn &optional form) (il:* il:|;;| "Common error routine for invalid SETF's. FN is the thing we tried to find a setf method for, FORM is its parent (not supplied when the form is a non-list).") (error "~S is not a known location specifier for SETF." fn)) (defmacro psetf (&rest args &environment env) "This is to SETF as PSETQ is to SETQ. Args are alternating place expressions and values to go into those places. All of the subforms and values are determined, left to right, and only then are the locations updated. Returns NIL." (do ((a args (cddr a)) (let-list nil) (setf-list nil)) ((atom a) `(,'let ,(reverse let-list) ,@(reverse setf-list) nil)) (if (atom (cdr a)) (error "Odd number of args to PSETF.")) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (car a) env) (declare (ignore getter)) (do* ((d dummies (cdr d)) (v vals (cdr v))) ((null d)) (push (list (car d) (car v)) let-list)) (push (list (car newval) (cadr a)) let-list) (push setter setf-list)))) (defmacro shiftf (&rest args &environment env) "Assigns to each place the value of the form to its right, returns old value of 1st" (cond ((or (null args) (null (cdr args))) (error "SHIFTF needs at least two arguments")) (t (do* ((a args (cdr a)) (let-list nil) (setf-list nil) (result (il:gensym)) (next-var result)) ((atom (cdr a)) (push (list next-var (car a)) let-list) `(,'let* ,(reverse let-list) ,@(reverse setf-list) ,result)) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (car a) env) (do ((d dummies (cdr d)) (v vals (cdr v))) ((null d)) (push (list (car d) (car v)) let-list)) (push (list next-var getter) let-list) (push setter setf-list) (setq next-var (car newval))))))) (defmacro rotatef (&rest args &environment env) "Assigns to each place the value of the form to its right; last gets first. Returns NIL." (il:* il:|;;| "forms evaluated in order") (cond ((null args) nil) ((null (cdr args)) `(progn ,(car args) nil)) (t (do ((a args (cdr a)) (let-list nil) (setf-list nil) (next-var nil) (fix-me nil)) ((atom a) (rplaca fix-me next-var) `(,'let* ,(reverse let-list) ,@(reverse setf-list) nil)) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (car a) env) (do ((d dummies (cdr d)) (v vals (cdr v))) ((null d)) (push (list (car d) (car v)) let-list)) (push (list next-var getter) let-list) (il:* il:|;;| "We don't know the newval variable for the last form yet,so fake it for the first getter and fix it at the end.") (unless fix-me (setq fix-me (car let-list))) (push setter setf-list) (setq next-var (car newval))))))) (defmacro pop (place &environment env) "Pops one item off the front of PLACE and returns it." (if (symbolp place) `(prog1 (car ,place) (setq ,place (cdr ,place))) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) `(,'let* (,@(mapcar #'list dummies vals) ,(list (car newval) getter)) (prog1 (car ,(car newval)) (setq ,(car newval) (cdr ,(car newval))) ,setter))))) (defmacro remf (place indicator &environment env) "Destructively remove INDICATOR from PLACE, returning T if it was present, NIL if not" (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((ind-temp (il:gensym)) (local1 (il:gensym)) (local2 (il:gensym))) `(,'let* (,@(mapcar #'list dummies vals) (,(car newval) ,getter) (,ind-temp ,indicator)) (do ((,local1 ,(car newval) (cddr ,local1)) (,local2 nil ,local1)) ((atom ,local1) nil) (cond ((atom (cdr ,local1)) (error "Odd-length property list in REMF.")) ((eq (car ,local1) ,ind-temp) (cond (,local2 (rplacd (cdr ,local2) (cddr ,local1)) (return t)) (t (setq ,(car newval) (cddr ,(car newval))) ,setter (return t)))))))))) (define-modify-macro incf (&optional (delta 1)) + "The first argument is some location holding a number. This number is incremented by the second argument, DELTA, which defaults to 1.") (define-modify-macro decf (&optional (delta 1)) - "The first argument is some location holding a number. This number is decremented by the second argument, DELTA, which defaults to 1.") (defun maybe-make-binding-form (newval-form dummies vals newvar setter getter) (il:* il:|;;| "For use in SETF-like forms to produce their final expression without using the NEWVAR gensym where possible. DUMMIES thru GETTER are the five values returned from the SETF method. NEWVAL-FORM is an expression to which the (sole) NEWVAR is logically to be bound, written in terms of the GETTER form. If it looks like there are no side-effect problems, we substitute NEWVAL-FORM into SETTER; otherwise we return a binding form that returns SETTER correctly.") (if (or dummies (> (count-occurrences (car newvar) setter) 1)) (il:* il:\;  " have to do messy binding form") `(,'let* (,@(mapcar #'list dummies vals) (,(car newvar) ,newval-form)) ,setter) (il:* il:\;  "No temp vars, setter used only once, so nothing can be side-effected, so store it directly") (subst newval-form (car newvar) setter))) (defun count-occurrences (symbol form) (cond ((consp form) (+ (count-occurrences symbol (car form)) (count-occurrences symbol (cdr form)))) ((eq symbol form) 1) (t 0))) (defmacro push (obj place &environment env) "Conses OBJ onto PLACE, returning the modified list." (if (symbolp place) `(setq ,place (cons ,obj ,place)) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (maybe-make-binding-form `(cons ,obj ,getter) dummies vals newval setter getter)))) (defmacro pushnew (obj place &rest keys &environment env) "Conses OBJ onto PLACE unless its already there, using :TEST if necessary" (if (symbolp place) `(setq ,place (adjoin ,obj ,place ,@keys)) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (maybe-make-binding-form `(adjoin ,obj ,getter ,@keys) dummies vals newval setter getter)))) (defsetf car (x) (v) `(car (rplaca ,x ,v))) (defsetf cdr (x) (v) `(cdr (rplacd ,x ,v))) (defsetf caaaar (x) (v) `(car (rplaca (caaar ,x) ,v))) (defsetf caaadr (x) (v) `(car (rplaca (caadr ,x) ,v))) (defsetf caaar (x) (v) `(car (rplaca (caar ,x) ,v))) (defsetf caadar (x) (v) `(car (rplaca (cadar ,x) ,v))) (defsetf caaddr (x) (v) `(car (rplaca (caddr ,x) ,v))) (defsetf caadr (x) (v) `(car (rplaca (cadr ,x) ,v))) (defsetf caar (x) (v) `(car (rplaca (car ,x) ,v))) (defsetf cadaar (x) (v) `(car (rplaca (cdaar ,x) ,v))) (defsetf cadadr (x) (v) `(car (rplaca (cdadr ,x) ,v))) (defsetf cadar (x) (v) `(car (rplaca (cdar ,x) ,v))) (defsetf caddar (x) (v) `(car (rplaca (cddar ,x) ,v))) (defsetf cadddr (x) (v) `(car (rplaca (cdddr ,x) ,v))) (defsetf caddr (x) (v) `(car (rplaca (cddr ,x) ,v))) (defsetf cadr (x) (v) `(car (rplaca (cdr ,x) ,v))) (defsetf cdaaar (x) (v) `(cdr (rplacd (caaar ,x) ,v))) (defsetf cdaadr (x) (v) `(cdr (rplacd (caadr ,x) ,v))) (defsetf cdaar (x) (v) `(cdr (rplacd (caar ,x) ,v))) (defsetf cdadar (x) (v) `(cdr (rplacd (cadar ,x) ,v))) (defsetf cdaddr (x) (v) `(cdr (rplacd (caddr ,x) ,v))) (defsetf cdadr (x) (v) `(cdr (rplacd (cadr ,x) ,v))) (defsetf cdar (x) (v) `(cdr (rplacd (car ,x) ,v))) (defsetf cddaar (x) (v) `(cdr (rplacd (cdaar ,x) ,v))) (defsetf cddadr (x) (v) `(cdr (rplacd (cdadr ,x) ,v))) (defsetf cddar (x) (v) `(cdr (rplacd (cdar ,x) ,v))) (defsetf cdddar (x) (v) `(cdr (rplacd (cddar ,x) ,v))) (defsetf cddddr (x) (v) `(cdr (rplacd (cdddr ,x) ,v))) (defsetf cdddr (x) (v) `(cdr (rplacd (cddr ,x) ,v))) (defsetf cddr (x) (v) `(cdr (rplacd (cdr ,x) ,v))) (defsetf first (x) (v) `(car (rplaca ,x ,v))) (defsetf second (x) (v) `(car (rplaca (cdr ,x) ,v))) (defsetf third (x) (v) `(car (rplaca (cddr ,x) ,v))) (defsetf fourth (x) (v) `(car (rplaca (cdddr ,x) ,v))) (defsetf fifth (x) (v) `(car (rplaca (cddddr ,x) ,v))) (defsetf sixth (x) (v) `(car (rplaca (cdr (cddddr ,x)) ,v))) (defsetf seventh (x) (v) `(car (rplaca (cddr (cddddr ,x)) ,v))) (defsetf eighth (x) (v) `(car (rplaca (cdddr (cddddr ,x)) ,v))) (defsetf ninth (x) (v) `(car (rplaca (cddddr (cddddr ,x)) ,v))) (defsetf tenth (x) (v) `(car (rplaca (cdr (cddddr (cddddr ,x))) ,v))) (defsetf rest (x) (v) `(cdr (rplacd ,x ,v))) (defsetf nthcdr (n list) (newval) `(cdr (rplacd (nthcdr (1- ,n) ,list) ,newval))) (defsetf nth %set-nth) (define-setf-method getf (place prop &optional default &environment env) (multiple-value-bind (temps values stores set get) (get-setf-method place env) (let ((newval (il:gensym)) (ptemp (il:gensym)) (def-temp (il:gensym))) (values `(,@temps ,(car stores) ,ptemp ,@(if default `(,def-temp))) `(,@values ,get ,prop ,@(if default `(,default))) `(,newval) `(cond ((null ,(car stores)) (let* ,(list (append stores `((list ,ptemp ,newval)))) ,set) ,newval) (t (il:listput ,(car stores) ,ptemp ,newval))) `(getf ,(car stores) ,ptemp ,@(if default `(,def-temp))))))) (define-setf-method apply (fn &rest args &environment env) (if (and (consp fn) (eq (length fn) 2) (member (first fn) '(function il:function quote) :test #'eq) (symbolp (second fn))) (setq fn (second fn)) (error "Setf of Apply is only defined for function args of form #'symbol.")) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method (cons fn args) env) (il:* il:|;;| "Make sure the place is one that we can handle.") (unless (and (eq (car (last args)) (car (last vals))) (eq (car (last getter)) (car (last dummies))) (eq (car (last setter)) (car (last dummies)))) (error "Apply of ~S not understood as a location for Setf." fn)) (values dummies vals newval `(apply #',(car setter) ,@(cdr setter)) `(apply #',(car getter) ,@(cdr getter))))) (define-setf-method ldb (bytespec place &environment env) "The first argument is a byte specifier. The second is any place form acceptable to SETF. Replaces the specified byte of the number in this place with bits from the low-order end of the new value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((btemp (il:gensym)) (gnuval (il:gensym))) (values (cons btemp dummies) (cons bytespec vals) (list gnuval) `(let ((,(car newval) (dpb ,gnuval ,btemp ,getter))) ,setter ,gnuval) `(ldb ,btemp ,getter))))) (define-setf-method mask-field (bytespec place &environment env) "The first argument is a byte specifier. The second is any place form acceptable to SETF. Replaces the specified byte of the number in this place with bits from the corresponding position in the new value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place) (let ((btemp (il:gensym)) (gnuval (il:gensym))) (values (cons btemp dummies) (cons bytespec vals) (list gnuval) `(let ((,(car newval) (deposit-field ,gnuval ,btemp ,getter))) ,setter ,gnuval) `(mask-field ,btemp ,getter))))) (define-setf-method char-bit (place bit-name &environment env) "The first argument is any place form acceptable to SETF. Replaces the specified bit of the character in this place with the new value." (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (let ((btemp (il:gensym)) (gnuval (il:gensym))) (values `(,@dummies ,btemp) `(,@vals ,bit-name) (list gnuval) `(let ((,(car newval) (set-char-bit ,getter ,btemp ,gnuval))) ,setter ,gnuval) `(char-bit ,getter ,btemp))))) (define-setf-method the (type place &environment env) (multiple-value-bind (dummies vals newval setter getter) (get-setf-method place env) (values dummies vals newval (subst `(the ,type ,(car newval)) (car newval) setter) `(the ,type ,getter)))) (il:* il:\; "Some IL setfs, for no especially good reason") (defsetf il:gethash il:%set-il-gethash) (defmacro il:%set-il-gethash (key hash-table &optional newvalue) (il:* il:|;;| "SETF inverse for IL:GETHASH. Tricky parts are that args to IL:PUTHASH are in wrong order, and IL:GETHASH might default its second arg (yuck, let's flush that), in which case the third arg is absent and the second is the new value.") (cond ((not newvalue) (il:* il:\; "Defaulted hash table") `(il:puthash ,key ,hash-table)) ((or (il:constantexpressionp newvalue) (and (symbolp newvalue) (symbolp hash-table))) (il:* il:\; "Ok to swap args") `(il:puthash ,key ,newvalue ,hash-table)) (t `(let (il:$$gethash-table) (declare (il:localvars il:$$gethash-table)) (il:puthash ,key (progn (il:setq il:$$gethash-table ,hash-table) ,newvalue) il:$$gethash-table))))) (il:putprops :setf-method-expander il:proptype ignore) (il:putprops :setf-inverse il:proptype ignore) (il:putprops :shared-setf-inverse il:proptype ignore) (il:putprops il:cmlsetf il:filetype :compile-file) (il:putprops il:cmlsetf il:makefile-environment (:readtable "XCL" :package "LISP")) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addtovar il:nlama ) (il:addtovar il:nlaml ) (il:addtovar il:lama ) ) (il:putprops il:cmlsetf il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/CMLSMARTARGS b/sources/CMLSMARTARGS new file mode 100644 index 00000000..a46c8ded --- /dev/null +++ b/sources/CMLSMARTARGS @@ -0,0 +1,37 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "27-Feb-91 19:20:13" {DSK}project2>lispcore>sources>CMLSMARTARGS.;2 23660 + + changes to%: (VARS *CL-ARGINFO-LIST*) + + previous date%: "15-Jun-90 15:24:56" {DSK}project2>lispcore>sources>CMLSMARTARGS.;1) + + +(* ; " +Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT CMLSMARTARGSCOMS) + +(RPAQQ CMLSMARTARGSCOMS ((VARS *CL-ARGINFO-LIST* *XCL-ARGINFO-LIST*) (FUNCTIONS ARGINFO-MUNG CLSMARTEN) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CLSMARTEN *CL-ARGINFO-LIST*) (CLSMARTEN *XCL-ARGINFO-LIST*) (SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST* (QUOTE NOBIND))))) (PROP FILETYPE CMLSMARTARGS))) + +(RPAQQ *CL-ARGINFO-LIST* (((CL:* +) &REST NUMBERS) ((- / CL:/= < <= = > >= MAX MIN) CL:NUMBER &REST MORE-NUMBERS) ((CL:1+ CL:1- ABS CL:ACOS CL:ACOSH CL:ASIN CL:ASINH CL:ATANH CL:CONJUGATE CL:COSH CL:EXP CL:IMAGPART MINUSP CL:PHASE CL:PLUSP CL:RATIONAL CL:RATIONALIZE CL:REALPART CL:SIGNUM CL:SINH CL:SQRT CL:TANH CL:ZEROP) CL:NUMBER) (CL:ACONS KEY DATUM A-LIST) ((CL:ADJOIN CL:MEMBER) ITEM LIST &KEY :TEST :TEST-NOT :KEY) (CL:ADJUST-ARRAY CL:ARRAY NEW-DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :DISPLACED-TO-BASE) ((CL:ADJUSTABLE-ARRAY-P CL:ARRAY-DIMENSIONS CL:ARRAY-ELEMENT-TYPE CL:ARRAY-HAS-FILL-POINTER-P CL:ARRAY-RANK CL:ARRAY-TOTAL-SIZE) CL:ARRAY) ((CL:ALPHA-CHAR-P CL:ALPHANUMERICP CL:BOTH-CASE-P CL:CHAR-BITS CL:CHAR-CODE CL:CHAR-DOWNCASE CL:CHAR-FONT CL:CHAR-INT CL:CHAR-NAME CL:CHAR-UPCASE CL:GRAPHIC-CHAR-P CL:LOWER-CASE-P CL:STANDARD-CHAR-P CL:STRING-CHAR-P CL:UPPER-CASE-P) CL:CHAR) ((AND OR PROGN) (CURLYLIST FORM) #\*) ((CL:APPEND NCONC) &REST LISTS) (CL:APPLY CL:FUNCTION ARG &REST MORE-ARGS) (CL:APPLYHOOK CL:FUNCTION ARGS EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV) ((CL:APROPOS CL:APROPOS-LIST) STRING &OPTIONAL PACKAGE) ((CL:AREF CL:ARRAY-IN-BOUNDS-P CL:ARRAY-ROW-MAJOR-INDEX) CL:ARRAY &REST SUBSCRIPTS) (CL:ARRAY-DIMENSION CL:ARRAY AXIS-NUMBER) ((CL:ARRAYP CL:ATOM CL:BIT-VECTOR-P CL:CHARACTER CL:CHARACTERP CL:COMMONP CL:COMPILED-FUNCTION-P CL:COMPLEXP CL:CONSP CL:CONSTANTP CL:COPY-TREE CL:DESCRIBE CL:ENDP CL:FLOATP CL:FUNCTIONP CL:HASH-TABLE-P CL:IDENTITY INSPECT CL:INTEGERP CL:KEYWORDP CL:LISTP NULL CL:NUMBERP CL:PACKAGEP CL:PATHNAMEP CL:PRIN1-TO-STRING CL:PRINC-TO-STRING CL:RANDOM-STATE-P CL:RATIONALP READTABLEP CL:SIMPLE-BIT-VECTOR-P CL:SIMPLE-STRING-P CL:SIMPLE-VECTOR-P STREAMP CL:STRINGP CL:SXHASH CL:SYMBOLP CL:TYPE-OF CL:VECTORP) OBJECT) (CL:ASH INTEGER CL:COUNT) (CL:ASSERT TEST-FORM (SQUARELIST ((CURLYLIST* PLACE)) (SQUARELIST STRING (CURLYLIST* ARG)))) ((CL:ASSOC CL:RASSOC) ITEM A-LIST &KEY :TEST :TEST-NOT :KEY) ((CL:ASSOC-IF CL:ASSOC-IF-NOT CL:RASSOC-IF CL:RASSOC-IF-NOT) PREDICATE A-LIST) (CL:ATAN Y &OPTIONAL X) (BIT BIT-ARRAY &REST SUBSCRIPTS) ((CL:BIT-AND CL:BIT-EQV CL:BIT-IOR CL:BIT-XOR) BIT-ARRAY1 BIT-ARRAY-2 &OPTIONAL RESULT-BIT-ARRAY) ((CL:BIT-ANDC1 CL:BIT-ANDC2 CL:BIT-NAND CL:BIT-NOR CL:BIT-ORC1 CL:BIT-ORC2) BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL RESULT-BIT-ARRAY) (CL:BIT-NOT BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY) (CL:BLOCK NAME (CURLYLIST FORM) #\*) (CL:BOOLE OP INTEGER1 INTEGER2) ((BOUNDP CL:FBOUNDP CL:FMAKUNBOUND CL:MACRO-FUNCTION CL:MAKE-SYNONYM-STREAM CL:MAKUNBOUND CL:SPECIAL-FORM-P CL:SYMBOL-FUNCTION CL:SYMBOL-PLIST CL:SYMBOL-VALUE) CL:SYMBOL) (CL:BREAK &OPTIONAL FORMAT-STRING &REST ARGS) ((CL:BUTLAST CL:NBUTLAST) LIST &OPTIONAL N) (BYTE SIZE CL:POSITION) ((CL:BYTE-POSITION BYTE-SIZE) BYTESPEC) ((CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR CAR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR CDDDR CDDR CDR CL:EIGHTH CL:FIFTH CL:FIRST CL:FOURTH LAST CL:LIST-LENGTH CL:NINTH CL:REST CL:SECOND CL:SEVENTH CL:SIXTH CL:TENTH CL:THIRD) LIST) ((CASE CL:ECASE) KEYFORM (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY)) #\| KEY) (CURLYLIST* FORM)))) (CL:CATCH TAG (CURLYLIST FORM) #\*) (CL:CCASE KEYPLACE (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY)) #\| KEY) (CURLYLIST* FORM)))) ((CL:CEILING CL:FCEILING CL:FFLOOR CL:FLOOR CL:FROUND CL:FTRUNCATE ROUND CL:TRUNCATE) CL:NUMBER &OPTIONAL DIVISOR) (CL:CERROR CONTINUE-FORMAT-STRING ERROR-FORMAT-STRING &REST ARGS) (CL:CHAR STRING INDEX) (CL:CHAR-BIT CL:CHAR NAME) ((CL:CHAR-EQUAL CL:CHAR-GREATERP CL:CHAR-LESSP CL:CHAR-NOT-EQUAL CL:CHAR-NOT-GREATERP CL:CHAR-NOT-LESSP CL:CHAR/= CL:CHAR< CL:CHAR<= CL:CHAR= CL:CHAR> CL:CHAR>=) CL:CHARACTER &REST MORE-CHARACTERS) (CL:CHECK-TYPE PLACE TYPESPEC &OPTIONAL STRING) ((CL:CIS CL:COS CL:SIN CL:TAN) RADIANS) ((CL:CLEAR-INPUT CL:LISTEN) &OPTIONAL INPUT-STREAM) ((CL:CLEAR-OUTPUT CL:FINISH-OUTPUT CL:FORCE-OUTPUT CL:FRESH-LINE CL:TERPRI) &OPTIONAL OUTPUT-STREAM) (CL:CLOSE STREAM &KEY :ABORT) ((CLRHASH CL:HASH-TABLE-COUNT) CL:HASH-TABLE) (CL:CODE-CHAR CODE &OPTIONAL BITS FONT) (COERCE OBJECT RESULT-TYPE) (CL:COMPILE NAME &OPTIONAL DEFINITION &KEY :LAP) (CL:COMPILE-FILE INPUT-PATHNAME &KEY :OUTPUT-FILE :ERROR-FILE :ERRORS-TO-TERMINAL :LAP-FILE :LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE) (CL:COMPILER-LET ((CURLYLIST VAR #\| (VAR VALUE)) #\*) (CURLYLIST FORM) #\*) (COMPLEX CL:REALPART &OPTIONAL CL:IMAGPART) (CL:CONCATENATE RESULT-TYPE &REST SEQUENCES) (COND (CURLYLIST (TEST (CURLYLIST FORM) #\*)) #\*) ((CONS CL:NRECONC CL:REVAPPEND RPLACA RPLACD) X Y) ((CL:COPY-ALIST CL:COPY-LIST CL:VALUES-LIST) LIST) (CL:COPY-READTABLE &OPTIONAL FROM-READTABLE TO-READTABLE) ((CL:COPY-SEQ CL:LENGTH CL:NREVERSE CL:REVERSE) SEQUENCE) (CL:COPY-SYMBOL SYM &OPTIONAL COPY-PROPS) ((CL:COUNT CL:FIND CL:POSITION) ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY) ((CL:COUNT-IF CL:COUNT-IF-NOT CL:FIND-IF CL:FIND-IF-NOT CL:POSITION-IF CL:POSITION-IF-NOT) TEST SEQUENCE &KEY :FROM-END :START :END :KEY) (CL:CTYPECASE KEYPLACE (CURLYLIST* (TYPE (CURLYLIST* FORM)))) ((CL:DECF CL:INCF) PLACE (SQUARELIST DELTA)) (DECLARE (CURLYLIST DECL-SPEC) #\*) ((CL:DECODE-FLOAT CL:FLOAT-DIGITS CL:FLOAT-PRECISION CL:FLOAT-RADIX CL:INTEGER-DECODE-FLOAT) FLOAT) (CL:DECODE-UNIVERSAL-TIME UNIVERSAL-TIME &OPTIONAL TIME-ZONE) ((CL:DEFCONSTANT CL:DEFPARAMETER) NAME INITIAL-VALUE (SQUARELIST CL:DOCUMENTATION)) (CL:DEFINE-MODIFY-MACRO NAME LAMBDA-LIST CL:FUNCTION (SQUARELIST DOC-STRING)) (CL:DEFINE-SETF-METHOD ACCESS-FN LAMBDA-LIST (CURLYLIST CL:DECLARATION #\| DOC-STRING) #\* (CURLYLIST FORM) #\*) ((DEFMACRO CL:DEFTYPE CL:DEFUN) NAME LAMBDA-LIST (CURLYLIST* CL:DECLARATION #\| DOC-STRING) (CURLYLIST* FORM)) (CL:DEFSETF ACCESS-FN (CURLYLIST UPDATE-FN (SQUARELIST DOC-STRING) #\| LAMBDA-LIST (STORE-VARIABLE) (CURLYLIST CL:DECLARATION #\| DOC-STRING) #\* (CURLYLIST FORM) #\*)) (CL:DEFSTRUCT NAME-AND-OPTIONS (SQUARELIST DOC-STRING) (CURLYLIST SLOT-DESCRIPTION) #\+) (CL:DEFVAR NAME (SQUARELIST INITIAL-VALUE (SQUARELIST CL:DOCUMENTATION))) ((CL:DELETE CL:REMOVE) ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY) ((CL:DELETE-DUPLICATES CL:REMOVE-DUPLICATES) SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY) ((CL:DELETE-FILE CL:FILE-AUTHOR CL:FILE-WRITE-DATE CL:PROBE-FILE) FILE) ((CL:DELETE-IF CL:DELETE-IF-NOT CL:REMOVE-IF CL:REMOVE-IF-NOT) TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY) ((CL:DENOMINATOR CL:NUMERATOR) CL:RATIONAL) ((CL:DEPOSIT-FIELD DPB) NEWBYTE BYTESPEC INTEGER) (CL:DIGIT-CHAR WEIGHT &OPTIONAL RADIX FONT) (CL:DIGIT-CHAR-P CL:CHAR &OPTIONAL RADIX) ((CL:DIRECTORY CL:DIRECTORY-NAMESTRING CL:FILE-NAMESTRING CL:HOST-NAMESTRING CL:NAMESTRING PATHNAME CL:PATHNAME-DEVICE CL:PATHNAME-DIRECTORY CL:PATHNAME-HOST CL:PATHNAME-NAME CL:PATHNAME-TYPE CL:PATHNAME-VERSION CL:TRUENAME) PATHNAME) (CL:DISASSEMBLE NAME-OR-COMPILED-FUNCTION) ((CL:DO CL:DO*) ((CURLYLIST* (VAR (SQUARELIST INIT (SQUARELIST CL:STEP))))) (END-TEST (CURLYLIST* RESULT)) (CURLYLIST* CL:DECLARATION) (CURLYLIST* TAG #\| STATEMENT)) (CL:DO-ALL-SYMBOLS (VAR (SQUARELIST RESULT-FORM)) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) ((CL:DO-EXTERNAL-SYMBOLS CL:DO-SYMBOLS) (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM))) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) (CL:DOCUMENTATION CL:SYMBOL DOC-TYPE) (CL:DOLIST (VAR LISTFORM (SQUARELIST RESULTFORM)) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) (CL:DOTIMES (VAR COUNTFORM (SQUARELIST RESULTFORM)) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) (DRIBBLE &OPTIONAL PATHNAME) (ED &OPTIONAL NAME OPTIONS #\= ((CURLYLIST "FILEPKGTYPE" #\| :DISPLAY #\| :NEW) #\*)) (CL:ELT SEQUENCE INDEX) (CL:ENCODE-UNIVERSAL-TIME CL:SECOND MINUTE HOUR DATE MONTH YEAR &OPTIONAL TIME-ZONE) (CL:ENOUGH-NAMESTRING PATHNAME &OPTIONAL DEFAULTS) ((EQ EQL CL:EQUAL CL:EQUALP) X Y) ((CL:ERROR CL:WARN) FORMAT-STRING &REST ARGS) ((CL:ETYPECASE CL:TYPECASE) KEYFORM (CURLYLIST (TYPE (CURLYLIST FORM) #\*)) #\*) ((CL:EVAL CL:GET-SETF-METHOD CL:GET-SETF-METHOD-MULTIPLE-VALUE) FORM) (CL:EVAL-WHEN ((CURLYLIST SITUATION) #\*) (CURLYLIST FORM) #\*) (CL:EVALHOOK FORM EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV) ((EVENP CL:INT-CHAR CL:INTEGER-LENGTH CL:ISQRT CL:LOGCOUNT LOGNOT ODDP) INTEGER) ((CL:EVERY CL:NOTANY CL:NOTEVERY CL:SOME) PREDICATE SEQUENCE &REST MORE-SEQUENCES) ((EXPORT IMPORT CL:SHADOW CL:SHADOWING-IMPORT CL:UNEXPORT) SYMBOLS &OPTIONAL PACKAGE) (CL:EXPT BASE-NUMBER POWER-NUMBER) (CL:FILE-LENGTH FILE-STREAM) (CL:FILE-POSITION FILE-STREAM &OPTIONAL CL:POSITION) (CL:FILL SEQUENCE ITEM &KEY :START :END) ((CL:FILL-POINTER CL:VECTOR-POP) CL:VECTOR) (CL:FIND-ALL-SYMBOLS STRING-OR-SYMBOL) ((CL:FIND-PACKAGE CL:NAME-CHAR) NAME) ((CL:FIND-SYMBOL CL:INTERN) STRING &OPTIONAL PACKAGE) ((CL:FLET CL:LABELS) ((CURLYLIST (NAME LAMBDA-LIST (CURLYLIST CL:DECLARATION #\| DOC-STRING) #\* (CURLYLIST FORM) #\*)) #\*) (CURLYLIST FORM) #\*) (FLOAT CL:NUMBER &OPTIONAL OTHER) (CL:FLOAT-SIGN FLOAT1 &OPTIONAL FLOAT2) (CL:FORMAT DESTINATION CONTROL-STRING &REST ARGUMENTS) (CL:FUNCALL FN &REST ARGUMENTS) (CL:FUNCTION FN) ((CL:GCD LOGAND CL:LOGEQV CL:LOGIOR LOGXOR) &REST INTEGERS) (CL:GENSYM &OPTIONAL X) (CL:GENTEMP &OPTIONAL PREFIX PACKAGE) (GET CL:SYMBOL INDICATOR &OPTIONAL DEFAULT) ((CL:GET-DECODED-TIME CL:GET-INTERNAL-REAL-TIME CL:GET-INTERNAL-RUN-TIME CL:GET-UNIVERSAL-TIME CL:LISP-IMPLEMENTATION-TYPE CL:LISP-IMPLEMENTATION-VERSION CL:LIST-ALL-PACKAGES CL:LONG-SITE-NAME CL:MACHINE-INSTANCE CL:MACHINE-TYPE CL:MACHINE-VERSION CL:MAKE-STRING-OUTPUT-STREAM CL:SHORT-SITE-NAME CL:SOFTWARE-TYPE CL:SOFTWARE-VERSION)) (CL:GET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR &OPTIONAL CL:READTABLE) (CL:GET-MACRO-CHARACTER CL:CHAR &OPTIONAL CL:READTABLE) (CL:GET-OUTPUT-STREAM-STRING STRING-OUTPUT-STREAM) (CL:GET-PROPERTIES PLACE INDICATOR-LIST) (CL:GETF PLACE INDICATOR &OPTIONAL DEFAULT) (CL:GETHASH KEY CL:HASH-TABLE &OPTIONAL DEFAULT) (GO TAG) (CL:IF TEST THEN (SQUARELIST ELSE)) (CL:IN-PACKAGE CL:PACKAGE-NAME &KEY :NICKNAMES :USE) ((CL:INPUT-STREAM-P CL:OUTPUT-STREAM-P CL:STREAM-ELEMENT-TYPE) STREAM) ((CL:INTERSECTION CL:NINTERSECTION CL:NSET-DIFFERENCE CL:NSET-EXCLUSIVE-OR CL:NUNION CL:SET-DIFFERENCE CL:SET-EXCLUSIVE-OR CL:SUBSETP CL:UNION) LIST1 LIST2 &KEY :TEST :TEST-NOT :KEY) (CL:LCM INTEGER &REST MORE-INTEGERS) ((LDB CL:LDB-TEST CL:MASK-FIELD) BYTESPEC INTEGER) (CL:LDIFF LIST SUBLIST) ((LET LET*) ((CURLYLIST VAR #\| (VAR VALUE)) #\*) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) ((LIST CL:VALUES) &REST ARGS) (LIST* ARG &REST OTHERS) (CL:LOAD FILENAME &KEY :VERBOSE :PRINT :IF-DOES-NOT-EXIST :PACKAGE :LOADFLG) (CL:LOCALLY (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (CL:LOG CL:NUMBER &OPTIONAL BASE) ((CL:LOGANDC1 CL:LOGANDC2 CL:LOGNAND CL:LOGNOR CL:LOGORC1 CL:LOGORC2 CL:LOGTEST) INTEGER1 INTEGER2) (CL:LOGBITP INDEX INTEGER) (CL:LOOP (CURLYLIST FORM) #\*) ((CL:MACROEXPAND CL:MACROEXPAND-1) FORM &OPTIONAL ENV) (CL:MACROLET ((CURLYLIST (NAME VARLIST (CURLYLIST CL:DECLARATION #\| DOC-STRING) #\* (CURLYLIST FORM) #\*)) #\*) (CURLYLIST FORM) #\*) (CL:MAKE-ARRAY DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :ADJUSTABLE :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :EXTENDABLE :READ-ONLY-P :DISPLACED-TO-BASE) ((CL:MAKE-BROADCAST-STREAM CL:MAKE-CONCATENATED-STREAM) &REST STREAMS) (CL:MAKE-CHAR CL:CHAR &OPTIONAL BITS FONT) (CL:MAKE-DISPATCH-MACRO-CHARACTER CL:CHAR &OPTIONAL NON-TERMINATING-P CL:READTABLE) ((CL:MAKE-ECHO-STREAM CL:MAKE-TWO-WAY-STREAM) INPUT-STREAM OUTPUT-STREAM) (CL:MAKE-HASH-TABLE &KEY :TEST :SIZE :REHASH-SIZE :REHASH-THRESHOLD) ((CL:MAKE-LIST CL:MAKE-STRING) SIZE &KEY :INITIAL-ELEMENT) (CL:MAKE-PACKAGE CL:PACKAGE-NAME &KEY :NICKNAMES :USE :PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS :EXTERNAL-ONLY) (CL:MAKE-PATHNAME &KEY :HOST :DEVICE :DIRECTORY :NAME :TYPE :VERSION :DEFAULTS) (CL:MAKE-RANDOM-STATE &OPTIONAL STATE) (CL:MAKE-SEQUENCE TYPE SIZE &KEY :INITIAL-ELEMENT) (CL:MAKE-STRING-INPUT-STREAM STRING &OPTIONAL START END) (CL:MAKE-SYMBOL PRINT-NAME) (MAKE-VECTOR CL:LENGTH &OPTIONAL TYPE INITIAL-VALUE) (CL:MAP RESULT-TYPE CL:FUNCTION SEQUENCE &REST MORE-SEQUENCES) ((CL:MAPC CL:MAPCAN CL:MAPCAR CL:MAPCON CL:MAPL CL:MAPLIST) CL:FUNCTION LIST &REST MORE-LISTS) (CL:MAPHASH CL:FUNCTION CL:HASH-TABLE) ((CL:MEMBER-IF CL:MEMBER-IF-NOT) PREDICATE LIST &KEY :KEY) (CL:MERGE RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY :KEY) (CL:MERGE-PATHNAMES PATHNAME &OPTIONAL DEFAULTS DEFAULT-VERSION) ((CL:MISMATCH CL:SEARCH) SEQUENCE1 SEQUENCE2 &KEY :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 :END2) ((CL:MOD CL:REM) CL:NUMBER DIVISOR) (CL:MULTIPLE-VALUE-BIND ((CURLYLIST VAR) #\*) VALUES-FORM (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (CL:MULTIPLE-VALUE-CALL CL:FUNCTION (CURLYLIST FORM) #\*) ((CL:MULTIPLE-VALUE-LIST CL:STEP) FORM) (CL:MULTIPLE-VALUE-PROG1 FORM (CURLYLIST FORM) #\*) (CL:MULTIPLE-VALUE-SETQ VARIABLES FORM) ((NOT STRING) X) ((CL:NSTRING-CAPITALIZE CL:NSTRING-DOWNCASE CL:NSTRING-UPCASE CL:STRING-CAPITALIZE CL:STRING-DOWNCASE CL:STRING-UPCASE) STRING &KEY :START :END) ((CL:NSUBLIS CL:SUBLIS) ALIST TREE &KEY :TEST :TEST-NOT :KEY) ((CL:NSUBST CL:SUBST) NEW OLD TREE &KEY :TEST :TEST-NOT :KEY) ((CL:NSUBST-IF CL:NSUBST-IF-NOT CL:SUBST-IF CL:SUBST-IF-NOT) NEW TEST TREE &KEY :KEY) ((CL:NSUBSTITUTE CL:SUBSTITUTE) NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY) ((CL:NSUBSTITUTE-IF CL:NSUBSTITUTE-IF-NOT CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT) NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY) ((CL:NTH CL:NTHCDR) N LIST) (OPEN FILENAME &KEY :DIRECTION :ELEMENT-TYPE :IF-EXISTS :IF-DOES-NOT-EXIST :EXTERNAL-FORMAT) ((CL:PACKAGE-NAME CL:PACKAGE-NICKNAMES CL:PACKAGE-SHADOWING-SYMBOLS CL:PACKAGE-USE-LIST CL:PACKAGE-USED-BY-LIST) PACKAGE) (CL:PAIRLIS KEYS DATA &OPTIONAL A-LIST) (CL:PARSE-INTEGER STRING &KEY :START :END :RADIX :JUNK-ALLOWED) (CL:PARSE-NAMESTRING THING &OPTIONAL HOST DEFAULTS &KEY :START :END :JUNK-ALLOWED) (CL:PEEK-CHAR &OPTIONAL PEEK-TYPE INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P) (CL:POP PLACE) ((CL:PPRINT CL:PRIN1 CL:PRINC CL:PRINT) OBJECT &OPTIONAL OUTPUT-STREAM) (CL:PROCLAIM DECL-SPEC) ((PROG PROG*) ((CURLYLIST VAR #\| (VAR (SQUARELIST INIT))) #\*) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) (PROG1 CL:FIRST (CURLYLIST FORM) #\*) (PROG2 CL:FIRST CL:SECOND (CURLYLIST FORM) #\*) (CL:PROGV SYMBOLS CL:VALUES (CURLYLIST FORM) #\*) (CL:PROVIDE MODULE-NAME) ((CL:PSETF CL:SETF) (CURLYLIST PLACE NEWVALUE) #\*) ((CL:PSETQ CL:SETQ) (CURLYLIST VAR FORM) #\*) (CL:PUSH ITEM PLACE) (CL:PUSHNEW ITEM LIST &KEY :TEST :TEST-NOT :KEY) (QUOTE OBJECT) (CL:RANDOM CL:NUMBER &OPTIONAL STATE) ((CL:READ CL:READ-CHAR CL:READ-CHAR-NO-HANG CL:READ-LINE) &OPTIONAL INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P) (CL:READ-BYTE BINARY-INPUT-STREAM &OPTIONAL EOF-ERROR-P EOF-VALUE) (CL:READ-DELIMITED-LIST CL:CHAR &OPTIONAL INPUT-STREAM RECURSIVE-P) (CL:READ-FROM-STRING STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY :START :END :PRESERVE-WHITESPACE) (CL:READ-PRESERVING-WHITESPACE &OPTIONAL IN-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P) (CL:REDUCE CL:FUNCTION SEQUENCE &KEY :FROM-END :START :END :INITIAL-VALUE) (CL:REMF PLACE INDICATOR) (REMHASH KEY CL:HASH-TABLE) (REMPROP CL:SYMBOL INDICATOR) (CL:RENAME-FILE FILE NEW-NAME) (CL:RENAME-PACKAGE PACKAGE NEW-NAME &OPTIONAL NEW-NICKNAMES) (CL:REPLACE SEQUENCE1 SEQUENCE2 &KEY :START1 :END1 :START2 :END2) (CL:REQUIRE MODULE-NAME &OPTIONAL PATHNAME) (RETURN (SQUARELIST RESULT)) (CL:RETURN-FROM NAME (SQUARELIST RESULT)) (CL:ROTATEF (CURLYLIST PLACE) #\*) (CL:SBIT SIMPLE-BIT-ARRAY &REST SUBSCRIPTS) (CL:SCALE-FLOAT FLOAT INTEGER) (CL:SCHAR CL:SIMPLE-STRING INDEX) (SET CL:SYMBOL VALUE) (CL:SET-CHAR-BIT CL:CHAR NAME NEWVALUE) (CL:SET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR CL:FUNCTION &OPTIONAL CL:READTABLE) (CL:SET-MACRO-CHARACTER CL:CHAR CL:FUNCTION &OPTIONAL NON-TERMINATING-P CL:READTABLE) (CL:SET-SYNTAX-FROM-CHAR TO-CHAR FROM-CHAR &OPTIONAL TO-READTABLE FROM-READTABLE) (CL:SHIFTF (CURLYLIST PLACE) #\+ NEWVALUE) (CL:SLEEP SECONDS) ((CL:SORT CL:STABLE-SORT) SEQUENCE PREDICATE &KEY :KEY) (CL:STREAM-EXTERNAL-FORMAT STREAM) ((STRING-EQUAL CL:STRING-GREATERP CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=) STRING1 STRING2 &KEY :START1 :END1 :START2 :END2) ((CL:STRING-LEFT-TRIM CL:STRING-RIGHT-TRIM CL:STRING-TRIM) CHARACTER-BAG STRING) (CL:SUBSEQ SEQUENCE START &OPTIONAL END) (CL:SUBTYPEP TYPE1 TYPE2) (CL:SVREF CL:SIMPLE-VECTOR INDEX) ((CL:SYMBOL-NAME CL:SYMBOL-PACKAGE) SYM) (CL:TAGBODY (CURLYLIST TAG #\| STATEMENT) #\*) (TAILP SUBLIST LIST) (THE VALUE-TYPE FORM) (CL:THROW TAG RESULT) (TIME FORM &KEY :REPEAT :OUTPUT :DATA-TYPES) ((TRACE UNTRACE) (CURLYLIST FUNCTION-NAME) #\*) (CL:TREE-EQUAL X Y &KEY :TEST :TEST-NOT) (TYPEP OBJECT TYPE) (CL:UNINTERN CL:SYMBOL &OPTIONAL PACKAGE) ((CL:UNLESS CL:WHEN) TEST (CURLYLIST FORM) #\*) (CL:UNREAD-CHAR CL:CHARACTER &OPTIONAL INPUT-STREAM) (CL:UNUSE-PACKAGE PACKAGES-TO-UNUSE &OPTIONAL PACKAGE) (CL:UNWIND-PROTECT PROTECTED-FORM (CURLYLIST CLEANUP-FORM) #\*) (CL:USE-PACKAGE PACKAGES-TO-USE &OPTIONAL PACKAGE) (CL:USER-HOMEDIR-PATHNAME &OPTIONAL HOST) (CL:VECTOR &REST OBJECTS) (CL:VECTOR-PUSH NEW-ELEMENT CL:VECTOR) (CL:VECTOR-PUSH-EXTEND NEW-ELEMENT CL:VECTOR &OPTIONAL EXTENSION) (CL:WITH-INPUT-FROM-STRING (VAR STRING (CURLYLIST CL:KEYWORD VALUE) #\*) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (CL:WITH-OPEN-FILE (STREAM FILENAME (CURLYLIST OPTIONS) #\*) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (CL:WITH-OPEN-STREAM (VAR STREAM) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (CL:WITH-OUTPUT-TO-STRING (VAR (SQUARELIST STRING)) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST FORM) #\*) (WRITE OBJECT &KEY :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM :ARRAY) (CL:WRITE-BYTE INTEGER BINARY-OUTPUT-STREAM) (CL:WRITE-CHAR CL:CHARACTER &OPTIONAL OUTPUT-STREAM) ((CL:WRITE-LINE CL:WRITE-STRING) STRING &OPTIONAL OUTPUT-STREAM &KEY :START :END) (CL:WRITE-TO-STRING OBJECT &KEY :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM :ARRAY) ((CL:Y-OR-N-P CL:YES-OR-NO-P) &OPTIONAL FORMAT-STRING &REST ARGUMENTS))) + +(RPAQQ *XCL-ARGINFO-LIST* ((ADD-EXEC &KEY :PROFILE :REGION :TTY :EXEC :ID) (ASET NEWVALUE ARRAY &REST INDICES) (CATCH-ABORT PRINT-FORM &BODY FORMS) (CONDITION-CASE FORM (CURLYLIST (TYPE ((SQUARELIST VAR)) (CURLYLIST FORM) #\*)) #\*) ((CONDITION-HANDLER CONDITION-REPORTER) TYPE) (COMPILER:COPY-ENV-WITH-FUNCTION ENVIRONMENT FUNCTION &OPTIONAL KIND EXP-FN) (COMPILER:COPY-ENV-WITH-VARIABLE ENVIRONMENT VARIABLE &OPTIONAL KIND) (DEBUG &OPTIONAL DATUM &REST ARGUMENTS) (DEF-DEFINE-TYPE NAME DESCRIPTION-STRING &KEY :UNDEFINER) (DEFAULT-PROCEED-TEST PROCEED-CASE-NAME) (DEFCOMMAND NAME ARGUMENT-LIST &REST BODY) (DEFDEFINER (CURLYLIST NAME #\| (NAME (CURLYLIST OPTION-CLAUSE) #\*)) TYPE ARGLIST &BODY BODY) (DEFGLOBALPARAMETER NAME INITIAL-VALUE &OPTIONAL DOC-STRING) (DEFGLOBALVAR NAME &OPTIONAL INITIAL-VALUE DOC-STRING) (DEFINE-CONDITION NAME PARENT-TYPE SLOT-LIST (SQUARELIST KEYWORD VALUE) #\*) (DEFINE-PROCEED-FUNCTION NAME (SQUARELIST KEYWORD VALUE) #\* &REST VARIABLES) (DEFINLINE NAME ARG-LIST &BODY BODY) (DEFOPTIMIZER FORM-NAME (SQUARELIST OPT-NAME) (SQUARELIST ARG-LIST (SQUARELIST DECL #\| DOC-STRING) #\*) BODY) (DEFPACKAGE NAME &REST OPTION-CLAUSES) (DESTRUCTURING-BIND BIND-PATTERN VALUE &BODY BODY) ((XCL:DO-INTERNAL-SYMBOLS DO-LOCAL-SYMBOLS) (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM))) (CURLYLIST CL:DECLARATION) #\* (CURLYLIST TAG #\| STATEMENT) #\*) (EXEC &KEY :TOP-LEVEL-P :WINDOW :TITLE :COMMAND-TABLES :ENVIRONMENT :PROMPT :FUNCTION :PROFILE :ID) (EXEC-EVAL FORM &OPTIONAL ENVIRONMENT &KEY :PROMPT :ID :TYPE) (EXEC-FORMAT CONTROL-STRING &REST ARGUMENTS) ((EXTENDABLE-ARRAY-P READ-ONLY-ARRAY-P) ARRAY) (FILL-VECTOR VECTOR VALUE &KEY :START :END) (GLOBALIZE NAMESTRINGS &OPTIONAL PACKAGE) (HANDLER-BIND ((CURLYLIST (TYPE HANDLER)) #\*) (CURLYLIST FORM) #\*) (IGNORE-ERRORS &BODY FORMS) (INVOKE-PROCEED-CASE PROCEED-CASE &REST VALUES) (MAKE-CONDITION TYPE &REST SLOT-INITIALIZATIONS) (COMPILER:MAKE-CONTEXT &KEY :TOP-LEVEL-P :VALUES-USED :PREDICATE-P) (PARSE-BODY BODY ENVIRONMENT &OPTIONAL DOC-STRING-ALLOWED?) (PROCEED-CASE FORM (CURLYLIST (PROCEED-FUNCTION-NAME ARGLIST (SQUARELIST KEYWORD VALUE) #\* (CURLYLIST BODY-FORM) #\*)) #\*) ((XCL:SET-DEFAULT-EXEC-TYPE XCL:SET-EXEC-TYPE) NAME) (SIGNAL DATUM &REST ARGUMENTS) ((STORE-VALUE USE-VALUE) &OPTIONAL NEW-VALUE) (UNDOABLY (CURLYLIST FORMS)) (UNDOABLY-SETF (CURLYLIST PLACE VALUE) #\*))) + +(CL:DEFUN ARGINFO-MUNG (LST) (* ;; "Flattens list elements of LST into a single top-level list of characters and words, recognizing special directives (SQUARELIST . things) and (CURLYLIST . things) to mean turn it into [things] and {things}, respectively.") (FOR THING IN LST JOIN (COND ((CL:CONSP THING) (CASE (CAR THING) (SQUARELIST (CONS #\[ (NCONC1 (ARGINFO-MUNG (CDR THING)) #\]))) (CURLYLIST (CONS #\{ (NCONC1 (ARGINFO-MUNG (CDR THING)) #\}))) (CURLYLIST* (CONS #\{ (NCONC (ARGINFO-MUNG (CDR THING)) (LIST #\} #\*)))) (CL:OTHERWISE (CONS #\( (NCONC1 (ARGINFO-MUNG THING) #\)))))) (T (LIST THING))))) + +(CL:DEFUN CLSMARTEN (FNLIST) (* ;; "Transfer arg info from entries in FNLIST to the ARGNAMES props of those fns that need it. Format of an entry in FNLIST is (Functions . StylizedArgInfo), where Functions can be a symbol or list of symbols.") (LET ((NOSPELLFLG T)) (* ; "Tell SMARTARGLIST not to try too hard") (DECLARE (CL:SPECIAL NOSPELLFLG)) (CL:DOLIST (PAIR FNLIST) (LET (NEWARGS KNOWNARGS) (CL:DOLIST (FN (OR (LISTP (CAR PAIR)) (LIST (CAR PAIR)))) (CL:UNLESS (AND (SETQ KNOWNARGS (NLSETQ (SMARTARGLIST FN (MEMB (ARGTYPE FN) (QUOTE (0 2)))))) (CL:LISTP (SETQ KNOWNARGS (CAR KNOWNARGS))) (NOT (CL:MACRO-FUNCTION FN))) (* ;; "Only do this for fns for which SMARTARGLIST doesn't know the answer (something other than an atomic arglist) already. Also ignore macros to override arglists provided by DEFMACRO. The ARGTYPE check means try EXPLAINFLG=T in the case where the function is already defined as a lambda (don't want to do that for macros, since SMARTARGLIST would then fake something out of a macro/dmacro prop). Format of ARGNAMES prop for this kind of guy is (NIL PrettyArgs . InterlispArgs).") (CL:SETF (GET FN (QUOTE ARGNAMES)) (LIST* NIL (OR NEWARGS (SETQ NEWARGS (ARGINFO-MUNG (CDR PAIR)))) KNOWNARGS)))))))) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(CLSMARTEN *CL-ARGINFO-LIST*) + +(CLSMARTEN *XCL-ARGINFO-LIST*) + +(SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST* (QUOTE NOBIND))) +) + +(PUTPROPS CMLSMARTARGS FILETYPE :COMPILE-FILE) +(PUTPROPS CMLSMARTARGS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/sources/CMLSORT b/sources/CMLSORT new file mode 100644 index 00000000..f5c5c845 --- /dev/null +++ b/sources/CMLSORT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 14:41:22" |{DSK}local>lde>lispcore>sources>CMLSORT.;2| 19836 |changes| |to:| (VARS CMLSORTCOMS) |previous| |date:| "25-Nov-86 14:28:27" |{DSK}local>lde>lispcore>sources>CMLSORT.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CMLSORTCOMS) (RPAQQ CMLSORTCOMS ( (* |;;| "CLtL Section 14.5 Merging and Sorting") (DECLARE\: DONTCOPY DOEVAL@COMPILE (FILES CMLSEQCOMMON)) (* |;;| "vector sort functions") (FUNCTIONS %VECTOR-QUICK-SORT-STEP %VECTOR-INSERTION-SORT-STEP %VECTOR-QSFENCE %SORT-VECTOR %STABLE-SORT-VECTOR %SIMPLE-VECTOR-QUICK-SORT %VECTOR-QUICK-SORT %SIMPLE-VECTOR-INSERTION-SORT %VECTOR-INSERTION-SORT) (* |;;| "list sort functions") (FUNCTIONS %SORT-SUBLIST %MERGE-SUBLISTS-MACRO %SIMPLE-MERGE-SUBLISTS %MERGE-SUBLISTS) (* |;;| "vector merge functions") (FUNCTIONS %MERGE-MACRO %SIMPLE-MERGE %MERGE %SIMPLE-MERGE-VECTORS %MERGE-VECTORS) (* |;;| "list merge functions") (FUNCTIONS %SIMPLE-MERGE-LISTS %MERGE-LISTS) (* |;;| "user entry points") (FUNCTIONS CL:SORT CL:STABLE-SORT CL:MERGE) (PROP FILETYPE CMLSORT) (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T)))) (* |;;| "CLtL Section 14.5 Merging and Sorting") (DECLARE\: DONTCOPY DOEVAL@COMPILE (FILESLOAD CMLSEQCOMMON) ) (* |;;| "vector sort functions") (DEFMACRO %VECTOR-QUICK-SORT-STEP (VECTOR PRED LOWER UPPER ACCESSOR-FORM &REST FORMS) `(LET ((I (CL:1+ ,LOWER)) (J (CL:1- ,UPPER)) (%X-LOWER ,(CL:SUBST LOWER 'INDEX ACCESSOR-FORM))) (CL:LOOP (CL:LOOP (CL:INCF I) (CL:IF (NOT (CL:FUNCALL ,PRED ,(CL:SUBST 'I 'INDEX ACCESSOR-FORM) %X-LOWER)) (RETURN NIL))) (CL:LOOP (CL:DECF J) (CL:IF (NOT (CL:FUNCALL ,PRED %X-LOWER ,(CL:SUBST 'J 'INDEX ACCESSOR-FORM))) (RETURN NIL))) (COND ((> J I) (CL:ROTATEF (CL:AREF ,VECTOR I) (CL:AREF ,VECTOR J))) (T (RETURN NIL)))) (CL:ROTATEF (CL:AREF ,VECTOR ,LOWER) (CL:AREF ,VECTOR J)) ,@FORMS)) (DEFMACRO %VECTOR-INSERTION-SORT-STEP (VECTOR COMPAREFN LOWER UPPER ACCESSOR-FORM) (* |;;| "Sort elements (LOWER .. UPPER) of the 1-dimensional CMLArray ARRAY using the ordering given by COMPAREFN. ARRAY is sorted in place, i.e. destructively. NO argument checking! Returns ARRAY. INTENDED FOR FEWER THAN 20 ELEMENTS, USE QuickSort FOR LARGER PROBLEMS!") `(CL:DO ((%I (CL:1+ ,LOWER) (CL:1+ %I)) %ITH-ELEMENT %ITH-COMPARATOR TEMP) ((EQL %I ,UPPER) ,VECTOR) (SETQ %ITH-ELEMENT (CL:AREF ,VECTOR %I)) (SETQ %ITH-COMPARATOR ,(CL:SUBST '%ITH-ELEMENT 'INDEXED-ELEMENT ACCESSOR-FORM)) (CL:DO ((%J %I (CL:1- %J))) ((OR (EQL %J ,LOWER) (NOT (CL:FUNCALL ,COMPAREFN %ITH-COMPARATOR (PROGN (SETQ TEMP (CL:AREF ,VECTOR (CL:1- %J))) ,(CL:SUBST 'TEMP 'INDEXED-ELEMENT ACCESSOR-FORM))))) (CL:SETF (CL:AREF ,VECTOR %J) %ITH-ELEMENT)) (CL:SETF (CL:AREF ,VECTOR %J) TEMP)))) (DEFMACRO %VECTOR-QSFENCE (VECTOR PRED LOWER UPPER ACCESSOR-FORM) (* |;;| "Identify the partitioning element as the median-of-three estimate of the median. Reference: Sedgewick, R. `Implementing Quicksort Programs' CACM vol. 21 no. 10 pp. 847--857.") `(LET ((%UP-IDX (CL:1- ,UPPER)) (%MD-IDX (CL:ASH (+ ,LOWER ,UPPER) -1)) (%LW-IDX+1 (CL:1+ ,LOWER))) (CL:ROTATEF (CL:AREF ,VECTOR %MD-IDX) (CL:AREF ,VECTOR %LW-IDX+1)) (CL:IF (CL:FUNCALL ,PRED ,(CL:SUBST '%UP-IDX 'INDEX ACCESSOR-FORM) ,(CL:SUBST '%LW-IDX+1 'INDEX ACCESSOR-FORM)) (CL:ROTATEF (CL:AREF ,VECTOR %LW-IDX+1) (CL:AREF ,VECTOR %UP-IDX))) (CL:IF (CL:FUNCALL ,PRED ,(CL:SUBST '%UP-IDX 'INDEX ACCESSOR-FORM) ,(CL:SUBST 'LOWER 'INDEX ACCESSOR-FORM)) (CL:ROTATEF (CL:AREF ,VECTOR ,LOWER) (CL:AREF ,VECTOR %UP-IDX))) (CL:IF (CL:FUNCALL ,PRED ,(CL:SUBST 'LOWER 'INDEX ACCESSOR-FORM) ,(CL:SUBST '%LW-IDX+1 'INDEX ACCESSOR-FORM)) (CL:ROTATEF (CL:AREF ,VECTOR %LW-IDX+1) (CL:AREF ,VECTOR ,LOWER))))) (CL:DEFUN %SORT-VECTOR (VECTOR PRED KEY) (* |;;| "Sort the 1-dimensional CMLArray ARRAY using the ordering given by COMPAREFN. ARRAY is sorted in place, i.e. destructively. Returns ARRAY. Reference: Sedgewick, R. `Implementing Quicksort Programs' CACM vol. 21 no. 10 pp. 847--857.") (LET ((LOWER 0) (UPPER (VECTOR-LENGTH VECTOR))) (COND (KEY (%VECTOR-QUICK-SORT VECTOR PRED KEY LOWER UPPER) (%VECTOR-INSERTION-SORT VECTOR PRED KEY LOWER UPPER)) (T (%SIMPLE-VECTOR-QUICK-SORT VECTOR PRED LOWER UPPER) (%SIMPLE-VECTOR-INSERTION-SORT VECTOR PRED LOWER UPPER))) VECTOR)) (CL:DEFUN %STABLE-SORT-VECTOR (VECTOR PRED KEY) (* |;;| "Uses Insertion sort which, although slower than quick sort, is stable") (LET ((LENGTH (VECTOR-LENGTH VECTOR))) (CL:IF KEY (%VECTOR-INSERTION-SORT VECTOR PRED KEY 0 LENGTH) (%SIMPLE-VECTOR-INSERTION-SORT VECTOR PRED 0 LENGTH))) VECTOR) (CL:DEFUN %SIMPLE-VECTOR-QUICK-SORT (VECTOR PRED LOWER UPPER) (CL:WHEN (> (- UPPER LOWER) 10) (%VECTOR-QSFENCE VECTOR PRED LOWER UPPER (CL:AREF VECTOR INDEX)) (* |;;|  "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)]") (%VECTOR-QUICK-SORT-STEP VECTOR PRED LOWER UPPER (CL:AREF VECTOR INDEX) (COND ((> (- J LOWER) (- UPPER I)) (%SIMPLE-VECTOR-QUICK-SORT VECTOR PRED LOWER J) (%SIMPLE-VECTOR-QUICK-SORT VECTOR PRED I UPPER)) (T (%SIMPLE-VECTOR-QUICK-SORT VECTOR PRED I UPPER) (%SIMPLE-VECTOR-QUICK-SORT VECTOR PRED LOWER J)))))) (CL:DEFUN %VECTOR-QUICK-SORT (VECTOR PRED KEY LOWER UPPER) (CL:WHEN (> (- UPPER LOWER) 10) (%VECTOR-QSFENCE VECTOR PRED LOWER UPPER (CL:FUNCALL KEY (CL:AREF VECTOR INDEX))) (* |;;|  "Perform the partitioning. At this point array[(1+ LOWER)] <= array[LOWER] <= array[(1- UPPER)]") (%VECTOR-QUICK-SORT-STEP VECTOR PRED LOWER UPPER (CL:FUNCALL KEY (CL:AREF VECTOR INDEX)) (COND ((> (- J LOWER) (- UPPER I)) (%VECTOR-QUICK-SORT VECTOR PRED KEY LOWER J) (%VECTOR-QUICK-SORT VECTOR PRED KEY I UPPER)) (T (%VECTOR-QUICK-SORT VECTOR PRED KEY I UPPER) (%VECTOR-QUICK-SORT VECTOR PRED KEY LOWER J)))))) (CL:DEFUN %SIMPLE-VECTOR-INSERTION-SORT (VECTOR PRED LOWER UPPER) (%VECTOR-INSERTION-SORT-STEP VECTOR PRED LOWER UPPER INDEXED-ELEMENT)) (CL:DEFUN %VECTOR-INSERTION-SORT (VECTOR PRED KEY LOWER UPPER) (%VECTOR-INSERTION-SORT-STEP VECTOR PRED LOWER UPPER (CL:FUNCALL KEY INDEXED-ELEMENT))) (* |;;| "list sort functions") (CL:DEFUN %SORT-SUBLIST (START END PRED KEY) (* |;;| "Based on the old Interlisp list sorter due to Deutch and Masinter") (CL:IF (OR (EQ START END) (EQ (CDR START) END)) (* \; "At bottom of recursion") START (LET ((MID (* \;  "Split sublist by setting MID to its midpoint. ") (CL:DO ((FAST-POINTER START) (SLOW-POINTER START)) ((OR (EQ (SETQ FAST-POINTER (CDR FAST-POINTER)) END) (EQ (SETQ FAST-POINTER (CDR FAST-POINTER)) END)) (CDR SLOW-POINTER)) (SETQ SLOW-POINTER (CDR SLOW-POINTER))))) (* \; "sort the two halves separately") (%SORT-SUBLIST START MID PRED KEY) (%SORT-SUBLIST MID END PRED KEY) (* \; "Now merge back") (CL:IF KEY (%MERGE-SUBLISTS START MID END PRED KEY) (%SIMPLE-MERGE-SUBLISTS START MID END PRED))))) (DEFMACRO %MERGE-SUBLISTS-MACRO (START1 START2 END PRED KEY) `(LET ((HANDLE ,START1) (END1 (* \; "always (eq (cdr end1) start2)") (CL:DO ((L ,START1 (CDR L))) ((EQ (CDR L) ,START2) L))) ,@(CL:IF KEY '(KEY-1 KEY-2))) (CL:LOOP (CL:IF (OR (EQ ,START1 ,START2) (EQ ,START2 ,END)) (RETURN HANDLE)) ,@(CL:IF KEY `((CL:IF (NULL KEY-1) (SETQ KEY-1 (CL:FUNCALL ,KEY (CAR ,START1)))) (CL:IF (NULL KEY-2) (SETQ KEY-2 (CL:FUNCALL ,KEY (CAR ,START2)))))) (COND ((NOT ,(CL:IF KEY `(CL:FUNCALL ,PRED KEY-2 KEY-1) `(CL:FUNCALL ,PRED (CAR ,START2) (CAR ,START1)))) ,@(CL:IF KEY `((SETQ KEY-1 NIL))) (SETQ ,START1 (CDR ,START1))) (T ,@(CL:IF KEY `((SETQ KEY-2 NIL))) (UNINTERRUPTABLY (* |;;| "Move first element of second sublist to before first element of first sublist . This must be done by exchanging the CARs and then patching up the CDRs, so that handle always points to the start of the list.") (COND ((EQ ,START1 END1) (* \; "Special case.") (RPLACA ,START1 (PROG1 (CAR ,START2) (RPLACA ,START2 (CAR ,START1)))) (SETQ ,START2 (CDR (SETQ ,START1 (SETQ END1 ,START2))))) (T (RPLACD END1 (PROG1 (CDR ,START2) (RPLACA ,START1 (PROG1 (CAR ,START2) (RPLACD (RPLACA ,START2 (CAR ,START1)) (CDR ,START1)) (RPLACD ,START1 ,START2))))) (SETQ ,START1 ,START2) (SETQ ,START2 (CDR END1)))))))))) (CL:DEFUN %SIMPLE-MERGE-SUBLISTS (START1 START2 END PRED) (%MERGE-SUBLISTS-MACRO START1 START2 END PRED)) (CL:DEFUN %MERGE-SUBLISTS (START1 START2 END PRED KEY) (%MERGE-SUBLISTS-MACRO START1 START2 END PRED KEY)) (* |;;| "vector merge functions") (DEFMACRO %MERGE-MACRO (RESULT SEQUENCE1 SEQUENCE2 PRED ACCESSOR-FORM KEY) `(LET ((LENGTH1 (CL:LENGTH ,SEQUENCE1)) (LENGTH2 (CL:LENGTH ,SEQUENCE2)) (RESULTLENGTH (CL:LENGTH ,RESULT)) (INDEX-1 0) (INDEX-2 0) (RESULT-INDEX 0) OBJECT-1 OBJECT-2 ,@(CL:IF KEY '(KEY-1 KEY-2))) (CL:LOOP (COND ((EQL RESULT-INDEX RESULTLENGTH) (RETURN ,RESULT)) ((EQL INDEX-1 LENGTH1) (RETURN (CL:REPLACE ,RESULT ,SEQUENCE2 :START1 RESULT-INDEX :START2 INDEX-2))) ((EQL INDEX-2 LENGTH2) (RETURN (CL:REPLACE ,RESULT ,SEQUENCE1 :START1 RESULT-INDEX :START2 INDEX-1)))) (CL:WHEN (NULL OBJECT-1) (SETQ OBJECT-1 ,(CL:SUBST SEQUENCE1 'OBJECT (CL:SUBST 'INDEX-1 'INDEX ACCESSOR-FORM))) ,@(CL:IF KEY `((SETQ KEY-1 (CL:FUNCALL ,KEY OBJECT-1))))) (CL:WHEN (NULL OBJECT-2) (SETQ OBJECT-2 ,(CL:SUBST SEQUENCE2 'OBJECT (CL:SUBST 'INDEX-2 'INDEX ACCESSOR-FORM))) ,@(CL:IF KEY `((SETQ KEY-2 (CL:FUNCALL ,KEY OBJECT-2))))) (COND ((CL:FUNCALL ,PRED ,(CL:IF KEY 'KEY-2 'OBJECT-2) ,(CL:IF KEY 'KEY-1 'OBJECT-1)) (CL:SETF ,(CL:SUBST RESULT 'OBJECT (CL:SUBST 'RESULT-INDEX 'INDEX ACCESSOR-FORM)) OBJECT-2) (CL:INCF INDEX-2) (SETQ OBJECT-2 NIL)) (T (CL:SETF ,(CL:SUBST RESULT 'OBJECT (CL:SUBST 'RESULT-INDEX 'INDEX ACCESSOR-FORM )) OBJECT-1) (CL:INCF INDEX-1) (SETQ OBJECT-1 NIL))) (CL:INCF RESULT-INDEX)))) (CL:DEFUN %SIMPLE-MERGE (RESULT SEQUENCE1 SEQUENCE2 PRED) (%MERGE-MACRO RESULT SEQUENCE1 SEQUENCE2 PRED (CL:ELT OBJECT INDEX))) (CL:DEFUN %MERGE (RESULT SEQUENCE1 SEQUENCE2 PRED KEY) (%MERGE-MACRO RESULT SEQUENCE1 SEQUENCE2 PRED (CL:ELT OBJECT INDEX) KEY)) (CL:DEFUN %SIMPLE-MERGE-VECTORS (RESULT VECTOR1 VECTOR2 PRED) (%MERGE-MACRO RESULT VECTOR1 VECTOR2 PRED (CL:AREF OBJECT INDEX))) (CL:DEFUN %MERGE-VECTORS (RESULT VECTOR1 VECTOR2 PRED KEY) (%MERGE-MACRO RESULT VECTOR1 VECTOR2 PRED (CL:AREF OBJECT INDEX) KEY)) (* |;;| "list merge functions") (CL:DEFUN %SIMPLE-MERGE-LISTS (LIST1 LIST2 PRED) (* |;;| "%SIMPLE-MERGE-LISTS destructively merges LIST1 with LIST2 In the resulting list, elements of LIST2 are guaranteed to come after equal elements of LIST1") (CL:DO* ((HANDLE (LIST NIL)) (LAST-CONS HANDLE)) (* |;;| "LAST-CONS = pointer to last cell of result. Done when either list used up in which case, append the other list. Returns the result sans header. ") ((OR (NULL LIST1) (NULL LIST2)) (CL:IF (NULL LIST1) (RPLACD LAST-CONS LIST2) (RPLACD LAST-CONS LIST1)) (CDR HANDLE)) (COND ((CL:FUNCALL PRED (CAR LIST2) (CAR LIST1)) (* |;;| "Append the lesser list to last cell of result. Note: test must be done for LIST2 < LIST1 so merge will be stable for LIST1 ") (RPLACD LAST-CONS LIST2) (SETQ LIST2 (CDR LIST2))) (T (RPLACD LAST-CONS LIST1) (SETQ LIST1 (CDR LIST1)))) (SETQ LAST-CONS (CDR LAST-CONS)))) (CL:DEFUN %MERGE-LISTS (LIST1 LIST2 PRED KEY) (* |;;| "%MERGE-LISTS* destructively merges LIST1 with LIST2 In the resulting list, elements of LIST2 are guaranteed to come after equal elements of LIST1") (CL:DO* ((HANDLE (LIST NIL)) (LAST-CONS HANDLE) KEY-1 KEY-2) (* |;;| "LAST-CONS = pointer to last cell of result. Done when either list used up in which case, append the other list. Returns the result sans header. ") ((OR (NULL LIST1) (NULL LIST2)) (CL:IF (NULL LIST1) (RPLACD LAST-CONS LIST2) (RPLACD LAST-CONS LIST1)) (CDR HANDLE)) (CL:IF (NULL KEY-1) (SETQ KEY-1 (CL:FUNCALL KEY (CAR LIST1)))) (CL:IF (NULL KEY-2) (SETQ KEY-2 (CL:FUNCALL KEY (CAR LIST2)))) (COND ((CL:FUNCALL PRED KEY-2 KEY-1) (* |;;| "Append the lesser list to last cell of result. Note: test must be done for LIST2 < LIST1 so merge will be stable for LIST1 ") (RPLACD LAST-CONS LIST2) (SETQ LIST2 (CDR LIST2)) (SETQ KEY-2 NIL)) (T (RPLACD LAST-CONS LIST1) (SETQ LIST1 (CDR LIST1)) (SETQ KEY-1 NIL))) (SETQ LAST-CONS (CDR LAST-CONS)))) (* |;;| "user entry points") (CL:DEFUN CL:SORT (SEQUENCE PREDICATE &KEY KEY) "Destructively sorts sequence. Predicate should returns non-NIL if Arg1 is to precede Arg2." (* |;;;| "Sort dispatches to type specific sorting routines.") (SEQ-DISPATCH SEQUENCE (%SORT-SUBLIST SEQUENCE NIL PREDICATE KEY) (%SORT-VECTOR SEQUENCE PREDICATE KEY))) (CL:DEFUN CL:STABLE-SORT (SEQUENCE PREDICATE &KEY KEY) "Destructively sorts Sequence. Predicate should return non-Nil if Arg1 is to precede Arg2. Stable sort is the same as sort, but it guarantees that equal elements will not change places. For lists, use the normal sort-list function, but vectors must use a less efficient algorithm." (SEQ-DISPATCH SEQUENCE (%SORT-SUBLIST SEQUENCE NIL PREDICATE KEY) (%STABLE-SORT-VECTOR SEQUENCE PREDICATE KEY))) (CL:DEFUN CL:MERGE (RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY (KEY NIL KEY-P)) (* |;;| "The sequences SEQUENCE1 and SEQUENCE2 are destructively merged into a sequence of type RESULT-TYPE using the PREDICATE to order the elements.") (CL:IF (AND (EQ RESULT-TYPE 'LIST) (CL:LISTP SEQUENCE1) (CL:LISTP SEQUENCE2)) (CL:IF KEY-P (%MERGE-LISTS SEQUENCE1 SEQUENCE2 PREDICATE KEY) (%SIMPLE-MERGE-LISTS SEQUENCE1 SEQUENCE2 PREDICATE)) (LET ((RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE (+ (CL:LENGTH SEQUENCE1) (CL:LENGTH SEQUENCE2))))) (CL:IF KEY-P (CL:IF (AND (CL:VECTORP RESULT) (CL:VECTORP SEQUENCE1) (CL:VECTORP SEQUENCE2)) (%MERGE-VECTORS RESULT SEQUENCE1 SEQUENCE2 PREDICATE KEY) (%MERGE RESULT SEQUENCE1 SEQUENCE2 PREDICATE KEY)) (CL:IF (AND (CL:VECTORP RESULT) (CL:VECTORP SEQUENCE1) (CL:VECTORP SEQUENCE2)) (%SIMPLE-MERGE-VECTORS RESULT SEQUENCE1 SEQUENCE2 PREDICATE) (%SIMPLE-MERGE RESULT SEQUENCE1 SEQUENCE2 PREDICATE)))))) (PUTPROPS CMLSORT FILETYPE CL:COMPILE-FILE) (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSPECIALFORMS b/sources/CMLSPECIALFORMS new file mode 100644 index 00000000..71c53ea1 --- /dev/null +++ b/sources/CMLSPECIALFORMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 14:43:08" IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;2| 20313 IL:|changes| IL:|to:| (IL:VARS IL:CMLSPECIALFORMSCOMS) IL:|previous| IL:|date:| "13-Jun-88 18:25:25" IL:|{DSK}local>lde>lispcore>sources>CMLSPECIALFORMS.;1|) ; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLSPECIALFORMSCOMS) (IL:RPAQQ IL:CMLSPECIALFORMSCOMS ((IL:COMS (IL:FUNCTIONS LOOP) (IL:COMS (IL:FUNCTIONS IDENTITY) (XCL:OPTIMIZERS IDENTITY)) (IL:FUNCTIONS UNLESS WHEN)) (IL:FUNCTIONS FLET LABELS IL:SELECTQ) (IL:COMS (IL:* IL:|;;| "DO DO* and support.") (IL:FUNCTIONS DO DO*) (IL:FUNCTIONS %DO-TRANSLATE)) (IL:COMS (IL:FUNCTIONS DOLIST DOTIMES) (IL:FUNCTIONS CASE)) (IL:COMS (IL:* IL:|;;| "hacks, These probably shouldn't be here") (IL:COMS (IL:* IL:|;;|  "Hacks for Interlisp NLAMBDAs that should look like functions") (IL:PROP IL:MACRO IL:FRPTQ IL:SETN IL:SUB1VAR IL:*)) (IL:COMS (IL:FNS IL:BQUOTIFY) (IL:USERMACROS . `IL:UNCOMMA) (IL:VARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*) (IL:GLOBALVARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*)) (IL:COMS (IL:FNS IL:CLEAR-CLISPARRAY) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:ADDVARS (IL:MARKASCHANGEDFNS IL:CLEAR-CLISPARRAY))) ) (IL:P (PROCLAIM '(SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*)) (PROCLAIM (CONS 'SPECIAL IL:SYSSPECVARS)))) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSPECIALFORMS) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (DEFMACRO LOOP (&REST FORMS) (LET ((TAG (GENSYM))) `(PROG NIL ,TAG ,@FORMS (GO ,TAG)))) (DEFUN IDENTITY (THING) (IL:* IL:|;;| "Returns what was passed to it. Default for :key options.") THING) (XCL:DEFOPTIMIZER IDENTITY (X) X) (DEFMACRO UNLESS (TEST &BODY BODY) `(COND (,(IL:NEGATE TEST) ,@BODY))) (DEFMACRO WHEN (TEST &BODY BODY) `(COND (,TEST ,@BODY))) (DEFMACRO FLET (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is only used by the old interpreter and compiler. The new ones treat FLET specially.") (LET ((FUNCTIONS (MAPCAR #'(LAMBDA (X) (CONS (GENSYM) X)) FUNCTION-BINDINGS))) `(,'LET ,(MAPCAR #'(LAMBDA (X) (XCL:DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY) (CDR X) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY FN-BODY ENV T) `(,(CAR X) #'(LAMBDA ,FN-ARGLIST ,@DECLS (BLOCK ,FN-NAME ,@BODY)))))) FUNCTIONS) ,(XCL:WALK-FORM `(LOCALLY ,@BODY) :ENVIRONMENT ENV :WALK-FUNCTION #'(LAMBDA (FORM CONTEXT) (IF (OR (ATOM FORM) (NOT (EQ CONTEXT :EVAL))) FORM (COND ((MEMBER (CAR FORM) '(IL:FUNCTION FUNCTION) :TEST #'EQ) (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CADR FORM) (CADR Z)) (RETURN (CAR Z))))) (T (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CAR FORM) (CADR Z)) (RETURN `(FUNCALL ,(CAR Z) ,@(CDR FORM))))))))))))) (DEFMACRO LABELS (FUNCTION-BINDINGS &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is only used by the old interpreter and compiler. The new ones treat LABELS specially.") (IL:* IL:|;;;| "(Actually, the new compiler still uses this, but it will soon stop doing so.)") (LET ((FUNCTIONS (MAPCAR #'(LAMBDA (X) (CONS (GENSYM) X)) FUNCTION-BINDINGS))) `(,'LET ,(MAPCAR #'CAR FUNCTIONS) ,(XCL:WALK-FORM `(PROGN ,@(MAPCAR #'(LAMBDA (X) (XCL:DESTRUCTURING-BIND (FN-NAME FN-ARGLIST &REST FN-BODY) (CDR X) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY FN-BODY ENV T) `(SETQ ,(CAR X) #'(LAMBDA ,FN-ARGLIST ,@DECLS (BLOCK ,FN-NAME ,@BODY)))))) FUNCTIONS) (LOCALLY ,@BODY)) :ENVIRONMENT ENV :WALK-FUNCTION #'(LAMBDA (FORM CONTEXT) (IF (OR (ATOM FORM) (NOT (EQ CONTEXT :EVAL))) FORM (COND ((MEMBER (CAR FORM) '(IL:FUNCTION FUNCTION) :TEST #'EQ) (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CADR FORM) (CADR Z)) (RETURN (CAR Z))))) (T (DOLIST (Z FUNCTIONS FORM) (IF (EQ (CAR FORM) (CADR Z)) (RETURN `(FUNCALL ,(CAR Z) ,@(CDR FORM))))))))))))) (DEFMACRO IL:SELECTQ (SELECTOR &REST FORMS) (COND ((EQUAL SELECTOR '(IL:SYSTEMTYPE)) (IL:* IL:|;;| "Special case required by the IRM. (selectq (systemtype) ...) mustn't even look at the untaken arms.") (LET ((TYPE (EVAL SELECTOR)) (TAIL FORMS)) (LOOP (IF (NULL (CDR TAIL)) (IL:* IL:|;;| "No more possibilities, so use the default.") (RETURN (CAR TAIL)) (IL:* IL:|;;| "Normal clause. Is this the one we want?") (WHEN (OR (EQ TYPE (CAAR TAIL)) (AND (CONSP (CAAR TAIL)) (MEMBER TYPE (CAAR TAIL) :TEST #'EQ))) (RETURN `(PROGN ,@(CDAR TAIL))))) (SETQ TAIL (CDR TAIL))))) (T (LET* ((KV (IF (SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (XCL:WITH-COLLECTION (DO ((C FORMS (CDR C))) ((NULL C)) (XCL:COLLECT (COND ((NULL (CDR C)) `(T ,(CAR C))) ((NOT (CONSP (CAAR C))) `((EQ ,KV ',(CAAR C)) ,@(CDAR C))) (T `((OR ,@(MAPCAR #'(LAMBDA (X) `(EQ ,KV ',X)) (CAAR C))) ,@(CDAR C))))))))) (IF (EQ KV SELECTOR) `(COND ,@CLAUSES) `(LET ((,KV ,SELECTOR)) (DECLARE (IL:LOCALVARS ,KV)) (COND ,@CLAUSES))))))) (IL:* IL:|;;| "DO DO* and support.") (DEFMACRO DO (VARS END-TEST &BODY BODY &ENVIRONMENT ENV) (%DO-TRANSLATE VARS END-TEST BODY NIL ENV)) (DEFMACRO DO* (BINDS END-TEST &REST BODY &ENVIRONMENT ENV) (%DO-TRANSLATE BINDS END-TEST BODY T ENV)) (DEFUN %DO-TRANSLATE (VARS END-TEST BODY SEQUENTIALP ENV) (LET ((VARS-AND-INITIAL-VALUES (MAPCAR #'(LAMBDA (X) (IF (CONSP X) (LIST (CAR X) (CADR X)) (LIST X NIL))) VARS)) (SUBSEQUENT-VALUES (MAPCAN #'(LAMBDA (X) (AND (CONSP X) (CDDR X) `((,(CAR X) ,(CADDR X))))) VARS)) (TAG (GENSYM))) (IF SUBSEQUENT-VALUES (SETQ SUBSEQUENT-VALUES (CONS (IF SEQUENTIALP 'SETQ 'PSETQ) (APPLY 'APPEND SUBSEQUENT-VALUES)))) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY BODY ENV) `(,(IF SEQUENTIALP 'PROG* 'PROG) ,VARS-AND-INITIAL-VALUES ,@DECLS ,TAG (COND (,(CAR END-TEST) (RETURN (PROGN ,@(CDR END-TEST))))) ,@BODY ,SUBSEQUENT-VALUES (GO ,TAG))))) (DEFMACRO DOLIST ((VAR LISTFORM &OPTIONAL RESULTFORM) &BODY BODY &ENVIRONMENT ENV) (LET ((TAIL (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECL) (XCL:PARSE-BODY BODY ENV) `(,'LET ((,TAIL ,LISTFORM) ,VAR) ,@DECL (LOOP (SETQ ,VAR (CAR (OR ,TAIL ,@(IF RESULTFORM `((SETQ ,VAR NIL))) (RETURN ,RESULTFORM)))) ,@BODY (SETQ ,TAIL (CDR ,TAIL))))))) (DEFMACRO DOTIMES ((VAR COUNTFORM &OPTIONAL RESULTFORM) &BODY BODY &ENVIRONMENT ENV) (LET ((MAX (GENSYM))) (MULTIPLE-VALUE-BIND (BODY DECLS) (XCL:PARSE-BODY BODY ENV) `(LET ((,MAX ,COUNTFORM) (,VAR 0)) ,@DECLS (LOOP (IF (>= ,VAR ,MAX) (RETURN ,RESULTFORM)) ,@BODY (SETQ ,VAR (1+ ,VAR))))))) (DEFMACRO CASE (SELECTOR &REST CASES) (LET* ((KV (IF (SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (MAPCAR #'(LAMBDA (CASE) (LET ((KEY-LIST (CAR CASE)) (CONSEQUENTS (OR (CDR CASE) (LIST NIL)))) (COND ((MEMBER KEY-LIST '(T OTHERWISE) :TEST #'EQ) `(T ,@CONSEQUENTS)) ((NULL KEY-LIST) (WARN "~S used as a singleton key in ~S. You probably meant to use (~S)." NIL 'CASE NIL) '(NIL)) ((ATOM KEY-LIST) `((EQL ,KV ',KEY-LIST) ,@CONSEQUENTS)) (T `((OR ,@(MAPCAR #'(LAMBDA (X) `(EQL ,KV ',X)) KEY-LIST)) ,@CONSEQUENTS))))) CASES))) (IF (EQ KV SELECTOR) `(COND ,@CLAUSES) `(LET ((,KV ,SELECTOR)) (COND ,@CLAUSES))))) (IL:* IL:|;;| "hacks, These probably shouldn't be here") (IL:* IL:|;;| "Hacks for Interlisp NLAMBDAs that should look like functions") (IL:PUTPROPS IL:FRPTQ IL:MACRO (= . IL:RPTQ)) (IL:PUTPROPS IL:SETN IL:MACRO (= . IL:SETQ)) (IL:PUTPROPS IL:SUB1VAR IL:MACRO ((IL:X) (IL:SETQ IL:X (IL:SUB1 IL:X)))) (IL:PUTPROPS IL:* IL:MACRO ((IL:X . IL:Y) 'IL:X)) (IL:DEFINEQ (il:bquotify (il:lambda (il:form) (il:* il:|bvm:| "10-Jun-86 17:07") (il:* il:|turn| il:form il:|into| il:\a il:bquote il:|if| il:|it| il:|can.|  il:i\f il:|so,| il:|return| il:|it| il:|as| il:\a il:|list,| il:|otherwise,|  il:|return| nil) (cond ((il:listp il:form) (let ((il:fn (car il:form)) (il:tail (cdr il:form))) (and (il:listp il:tail) (or (null (cdr il:tail)) (and (il:listp (cdr il:tail)) (or (null (cddr il:tail)) (il:selectq il:fn ((cons il:nconc1) (il:*  "These take exactly two args, so if there are more, it's an error") nil) t)))) (il:selectq il:fn ('il:bquote (and (null (cdr il:tail)) (list (car il:tail)))) (list (list (il:|for| il:x il:|in| il:tail il:|join| (or (il:bquotify il:x) (list (list il:*bquote-comma* il:x)))))) ((cons list*) (list (il:append (or (il:bquotify (car il:tail)) (list (list il:*bquote-comma* (car il:tail)))) (or (car (il:bquotify (il:setq il:tail (cond ((and (eq il:fn 'list*) (cddr il:tail)) (cons 'list* (cdr il:tail))) (t (cadr il:tail)))))) (list (list il:*bquote-comma-atsign* il:tail)))))) ((il:append nconc il:nconc1) (let ((il:default (cond ((eq il:fn 'il:append) il:*bquote-comma-atsign*) (t il:*bquote-comma-dot*))) (il:bqcar (il:bquotify (car il:tail)))) (list (il:append (cond ((and il:bqcar (il:|for| (il:tl il:_ (il:setq il:bqcar (car il:bqcar))) il:|by| (cdr il:tl) il:|while| il:tl il:|never| (il:nlistp il:tl))) (il:* "Second condition catches (APPEND (CONS A 0) --), where the (CONS A 0) turns into (,A . 0) and then the APPEND would lose it. It will lose it at runtime, too, of course, but let's not remove mistakes from the source.") il:bqcar) (t (list (list il:default (car il:tail))))) (cond ((eq il:fn 'il:nconc1) (il:*  "Second arg is an element, not a segment") (or (il:bquotify (il:setq il:tail (cadr il:tail))) (list (list il:*bquote-comma* il:tail)))) (t (or (car (il:bquotify (il:setq il:tail (cond ((cddr il:tail) (cons il:fn (cdr il:tail))) (t (cadr il:tail)))))) (list (list il:default il:tail))))))))) nil)))) ((or (il:numberp il:form) (il:stringp il:form) (eq il:form t) (null il:form)) (list il:form)) (t nil)))) ) (IL:ADDTOVAR IL:USERMACROS (IL:UNCOMMA NIL (IL:IF (EQ (IL:\## 1) 'IL:BQUOTE) NIL ((IL:IF (EQ (IL:\## IL:!0 1) 'IL:BQUOTE) (IL:!0)))) (IL:I 2 (IL:\\UNCOMMA (IL:\## 2))))) (IL:ADDTOVAR IL:EDITMACROS (IL:BQUOTE NIL IL:UP (IL:ORR ((IL:I 1 (OR (CONS 'IL:BQUOTE (OR (IL:BQUOTIFY (IL:\## 1)) (IL:ERROR!))) (IL:ERROR!)))) ((IL:E 'IL:BQUOTE?))) 1)) (IL:ADDTOVAR IL:EDITCOMSA IL:BQUOTE IL:UNCOMMA) (IL:RPAQQ IL:*BQUOTE-COMMA* IL:\\\,) (IL:RPAQQ IL:*BQUOTE-COMMA-ATSIGN* IL:\\\,@) (IL:RPAQQ IL:*BQUOTE-COMMA-DOT* IL:\\\,.) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS IL:*BQUOTE-COMMA* IL:*BQUOTE-COMMA-ATSIGN* IL:*BQUOTE-COMMA-DOT*) ) (IL:DEFINEQ (il:clear-clisparray (il:lambda (il:name type il:reason) (il:* il:|bvm:| "25-Jun-86 12:59") (il:selectq il:reason ((t il:clisp) (il:*  "New definition or changed only by CLISP translation") nil) (clrhash il:clisparray)))) ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:ADDTOVAR IL:MARKASCHANGEDFNS IL:CLEAR-CLISPARRAY) ) (PROCLAIM '(SPECIAL IL:FILEPKGFLG IL:DFNFLG *READTABLE*)) (PROCLAIM (CONS 'SPECIAL IL:SYSSPECVARS)) (IL:PUTPROPS IL:CMLSPECIALFORMS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLSPECIALFORMS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:CMLSPECIALFORMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (13354 18024 (IL:BQUOTIFY 13367 . 18022)) (19227 19633 (IL:CLEAR-CLISPARRAY 19240 . 19631))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLSTEP b/sources/CMLSTEP new file mode 100644 index 00000000..2975ebb7 --- /dev/null +++ b/sources/CMLSTEP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "16-May-90 14:44:40" IL:|{DSK}local>lde>lispcore>sources>CMLSTEP.;2| 7485 IL:|changes| IL:|to:| (IL:VARS IL:CMLSTEPCOMS) IL:|previous| IL:|date:| "10-Dec-87 15:11:29" IL:|{DSK}local>lde>lispcore>sources>CMLSTEP.;1| ) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLSTEPCOMS) (IL:RPAQQ IL:CMLSTEPCOMS ( (IL:* IL:|;;;| "CMLSTEP -- Single Stepper STEP") (IL:FUNCTIONS STEP) (IL:FUNCTIONS STEP-COMMAND STEP-EVAL STEP-FORM STOP-STEPPING STEP-PRINT STEP-PRINT-VALUES) (IL:VARIABLES *STEP-IO* *STEP-INDENTATION-INCREMENT* *STEP-INDENTATION-LEVEL* *STEP-PRINT-LEVEL* *STEP-STATE* *STEP-MAX-INDENTATION* *STEP-PRINT-LENGTH*) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSTEP) (IL:FUNCTIONS STEP-SLEEP) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (IL:* IL:|;;;| "CMLSTEP -- Single Stepper STEP") (DEFMACRO STEP (FORM) "Evaluate FORM interactively" `(LET ((*EVALHOOK* #'STEP-COMMAND) (*STEP-STATE* T) (*STEP-INDENTATION-LEVEL* 0) (*STEP-IO* *QUERY-IO*)) ,FORM)) (DEFUN STEP-COMMAND (FORM ENVIRONMENT) "This is the *EVALHOOK* when stepping. It prints the form, and then reads a command. The commands are single characters from the terminal. If the stepper has subsequently been turned off, do the equivalent of the s command without printing." (COND ((NOT *STEP-STATE*) (IL:* IL:\;  "If aborted, just eval it.") (EVAL FORM ENVIRONMENT)) ((NOT (OR (EQ *STEP-STATE* T) (AND (CONSP FORM) (MEMBER (CAR FORM) *STEP-STATE* :TEST 'EQ)))) (IL:* IL:\;  "Don't step this form, but keep on looking.") (EVALHOOK FORM #'STEP-COMMAND NIL ENVIRONMENT)) (T (IL:* IL:\;  "Otherwise, bind indent level, print form, and enter command loop.") (COND ((OR (SYMBOLP FORM) (CONSTANTP FORM) (IL:* IL:\;  "Handles quote, not function.") ) (STEP-PRINT FORM) (LET ((VALUE (EVAL FORM ENVIRONMENT))) (STEP-PRINT-VALUES (LIST VALUE)) VALUE)) (T (STEP-PRINT FORM) (ECASE (IL:ASKUSER NIL NIL ": " '((IL:\ "Step" IL:EXPLAINSTRING " -- Step") (IL:N "ext" IL:EXPAINSTRING "Next - Evaluate this expression without stepping" ) (IL:F "inish" IL:EXPAINSTRING "Finish - complete evaluation without the stepper" ) (IL:D "ebugger") (IL:^ " abort"))) (IL:\ (IL:* IL:\;  "Space: step thru the evaluation of this form") (STEP-FORM FORM ENVIRONMENT)) (IL:N (STEP-EVAL FORM ENVIRONMENT)) (IL:F (STOP-STEPPING) (EVAL FORM ENVIRONMENT)) (IL:D (IL:* IL:\;  "Enter the debugger with this form, but then continue stepping afterward.") (XCL:DEBUGGER :FORM FORM :ENVIRONMENT ENVIRONMENT :CONDITION (XCL:MAKE-CONDITION 'SI::BREAKPOINT :FUNCTION FORM)) (STEP-COMMAND FORM ENVIRONMENT)) (IL:^ (IL:ERROR!)))))))) (DEFUN STEP-EVAL (FORM ENVIRONMENT) "Evaluate this form (without stepping) and print values" (LET ((RESULTS (MULTIPLE-VALUE-LIST (EVAL FORM ENVIRONMENT)))) (STEP-PRINT-VALUES RESULTS) (VALUES-LIST RESULTS))) (DEFUN STEP-FORM (FORM ENVIRONMENT) "Evaluate this form by stepping and print values." (LET ((RESULTS (LET ((*STEP-INDENTATION-LEVEL* (+ *STEP-INDENTATION-INCREMENT* *STEP-INDENTATION-LEVEL*))) (MULTIPLE-VALUE-LIST (EVALHOOK FORM #'STEP-COMMAND NIL ENVIRONMENT))))) (STEP-PRINT-VALUES RESULTS) (VALUES-LIST RESULTS))) (DEFUN STOP-STEPPING () (SETQ *STEP-STATE* NIL) (SETQ *EVALHOOK* NIL)) (DEFUN STEP-PRINT (FORM) "Print form according to the current indentation level, and according to *STEP-PRINT-LEVEL* and *STEP-PRINT-LENGTH*" (LET ((*PRINT-LEVEL* *STEP-PRINT-LEVEL*) (*PRINT-LENGTH* *STEP-PRINT-LENGTH*)) (FORMAT *STEP-IO* "~&~vT~S " (MIN *STEP-INDENTATION-LEVEL* *STEP-MAX-INDENTATION*) FORM))) (DEFUN STEP-PRINT-VALUES (VALUE-LIST) "PRINT-VALUES is called to print a list of values which were returned from an evaluation." (WHEN VALUE-LIST (LET ((*PRINT-LEVEL* *STEP-PRINT-LEVEL*) (*PRINT-LENGTH* *STEP-PRINT-LENGTH*)) (DOLIST (VALUE VALUE-LIST) (FORMAT *STEP-IO* "~&~vT= ~S " (MIN *STEP-INDENTATION-LEVEL* *STEP-MAX-INDENTATION*) VALUE)))) (TERPRI *STEP-IO*)) (DEFVAR *STEP-IO* NIL "Stream to which step I/O is done, bound by CL:STEP.") (DEFVAR *STEP-INDENTATION-INCREMENT* 2 "Number of spaces to increase indenting.") (DEFVAR *STEP-INDENTATION-LEVEL* 0) (DEFVAR *STEP-PRINT-LEVEL* 2 "Local value") (DEFVAR *STEP-STATE* NIL "EG, enabled") (DEFVAR *STEP-MAX-INDENTATION* 40) (DEFVAR *STEP-PRINT-LENGTH* 5 "Local value") (IL:PUTPROPS IL:CMLSTEP IL:FILETYPE IL:COMPILE-FILE) (IL:PUTPROPS IL:CMLSTEP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (DEFUN STEP-SLEEP (FUNCTIONS) "Sleep until the given functions are reached." (IL:* IL:|;;;| "This is an interesting bit of functionality for step that needs a better interface. It currently exists but will not be documented for the release.") (WHEN (NULL FUNCTIONS) (SETQ FUNCTIONS 0)) (SETQ *STEP-STATE* FUNCTIONS) (SETQ *EVALHOOK* #'STEP-COMMAND) (SETQ *STEP-INDENTATION-LEVEL* 0)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:CMLSTEP IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CMLSTRING b/sources/CMLSTRING new file mode 100644 index 00000000..5a8a35f9 --- /dev/null +++ b/sources/CMLSTRING @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:45:59" {DSK}local>lde>lispcore>sources>CMLSTRING.;2 28996 changes to%: (VARS CMLSTRINGCOMS) previous date%: "24-Mar-87 16:29:35" {DSK}local>lde>lispcore>sources>CMLSTRING.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSTRINGCOMS) (RPAQQ CMLSTRINGCOMS ( (* ;; "run-time support ") (FUNCTIONS CL::SIMPLE-STRING= CL::SIMPLE-STRING-EQUAL) (FUNCTIONS %%STRING-BASE-COMPARE %%STRING-BASE-COMPARE-EQUAL %%STRING-UPCASE %%STRING-DOWNCASE) (* ;; "User entry points ") (FUNCTIONS CL:MAKE-STRING CL:NSTRING-CAPITALIZE CL:NSTRING-DOWNCASE CL:NSTRING-UPCASE STRING CL:STRING-CAPITALIZE CL:STRING-DOWNCASE STRING-EQUAL CL:STRING-GREATERP CL:STRING-LEFT-TRIM CL:STRING-LESSP CL:STRING-NOT-EQUAL CL:STRING-NOT-GREATERP CL:STRING-NOT-LESSP CL:STRING-RIGHT-TRIM CL:STRING-TRIM CL:STRING-UPCASE CL:STRING/= CL:STRING< CL:STRING<= CL:STRING= CL:STRING> CL:STRING>=) (OPTIMIZERS CL:STRING= STRING-EQUAL) (* ;; "Internal macros ") (DECLARE%: DONTCOPY DOEVAL@COMPILE (FUNCTIONS WITH-ONE-STRING WITH-ONE-STRING-ONLY WITH-STRING WITH-TWO-UNPACKED-STRINGS %%UNPACK-STRING %%ADJUST-FOR-OFFSET %%CHECK-BOUNDS %%PARSE-STRING-ARGS %%STRING-LENGTH)) (* ;; "Compiler options") (PROP FILETYPE CMLSTRING) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (* ;; "run-time support ") (CL:DEFUN CL::SIMPLE-STRING= (STRING1 STRING2) [LET ((END1 (%%STRING-LENGTH STRING1)) (END2 (%%STRING-LENGTH STRING2))) (CL:IF (EQ END1 END2) (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2) (%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1) (%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2) (CL:IF (NOT (EQ 0 OFFSET1)) (SETQ END1 (+ END1 OFFSET1))) (CL:IF (NOT (EQ 0 OFFSET2)) (SETQ END2 (+ END2 OFFSET2))) (EQ END1 (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1 OFFSET2 END2))))]) (CL:DEFUN CL::SIMPLE-STRING-EQUAL (STRING1 STRING2) [LET ((END1 (%%STRING-LENGTH STRING1)) (END2 (%%STRING-LENGTH STRING2))) (CL:IF (EQ END1 END2) (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2) (%%UNPACK-STRING STRING1 BASE1 OFFSET1 TYPENUMBER1) (%%UNPACK-STRING STRING2 BASE2 OFFSET2 TYPENUMBER2) (CL:IF (NOT (EQ 0 OFFSET1)) (SETQ END1 (+ END1 OFFSET1))) (CL:IF (NOT (EQ 0 OFFSET2)) (SETQ END2 (+ END2 OFFSET2))) (EQ END1 (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1 OFFSET2 END2))))]) (CL:DEFUN %%STRING-BASE-COMPARE (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2) (* ;; "Return index into base1 of first inequality ") (* ;; "Can use eq for character comparisons because they are immediate datatypes. Can use eq for numeric equality since Indices are always in the fixnum range") (CL:IF (EQ START1 START2) (CL:DO ((INDEX START1 (CL:1+ INDEX)) (ENDINDEX (MIN END1 END2))) ([OR (EQ INDEX ENDINDEX) (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX] INDEX)) (CL:DO [(INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) (ENDINDEX (MIN END1 (+ START1 (- END2 START2] ([OR (EQ INDEX1 ENDINDEX) (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1) (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2] INDEX1)))) (CL:DEFUN %%STRING-BASE-COMPARE-EQUAL (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2) (* ;; "Return index into base1 of first case insensitive inequality ") (* ;; "Can use eq for character comparisons because they are immediate datatypes. ") (* ;; "Char-upcase has been expanded out and simplified below.") (CL:IF (EQ START1 START2) (CL:DO ((INDEX START1 (CL:1+ INDEX)) (ENDINDEX (MIN END1 END2))) ([OR (EQ INDEX ENDINDEX) (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX))) (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX] INDEX)) (CL:DO [(INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2)) (ENDINDEX (MIN END1 (+ START1 (- END2 START2] ([OR (EQ INDEX1 ENDINDEX) (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1))) (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2] INDEX1)))) (CL:DEFUN %%STRING-UPCASE (STRING START END) (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively upcases string and returns it ") (LET ((BASE (%%ARRAY-BASE STRING)) (OFFSET (%%ARRAY-OFFSET STRING)) (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING))) (%%ADJUST-FOR-OFFSET START END OFFSET) (CL:DO ((INDEX START (CL:1+ INDEX))) ((EQ INDEX END) STRING) (%%ARRAY-WRITE (CL:CHAR-UPCASE (%%ARRAY-READ BASE TYPENUMBER INDEX)) BASE TYPENUMBER INDEX)))) (CL:DEFUN %%STRING-DOWNCASE (STRING START END) (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively downcases string and returns it ") (LET ((BASE (%%ARRAY-BASE STRING)) (OFFSET (%%ARRAY-OFFSET STRING)) (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING))) (%%ADJUST-FOR-OFFSET START END OFFSET) (CL:DO ((INDEX START (CL:1+ INDEX))) ((EQ INDEX END) STRING) (%%ARRAY-WRITE (CL:CHAR-DOWNCASE (%%ARRAY-READ BASE TYPENUMBER INDEX)) BASE TYPENUMBER INDEX)))) (* ;; "User entry points ") (CL:DEFUN CL:MAKE-STRING (SIZE &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P) FATP) "Makes a simple string" (LET ((STRING (MAKE-VECTOR SIZE :ELEMENT-TYPE 'CL:STRING-CHAR :FATP FATP))) (CL:IF INITIAL-ELEMENT-P (FILL-ARRAY STRING INITIAL-ELEMENT)) STRING)) (CL:DEFUN CL:NSTRING-CAPITALIZE (STRING &KEY START END) "Given a string, returns it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters" [WITH-ONE-STRING-ONLY STRING START END (CL:DO ((INDEX START (CL:1+ INDEX)) (ALPHA-P NIL) (WAS-ALPHA-P NIL ALPHA-P) CHAR) ((EQ INDEX END) STRING) (SETQ CHAR (CL:CHAR STRING INDEX)) (SETQ ALPHA-P (CL:ALPHANUMERICP CHAR)) (CL:SETF (CL:CHAR STRING INDEX) (CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P)) (CL:CHAR-UPCASE CHAR) (CL:CHAR-DOWNCASE CHAR))))]) (CL:DEFUN CL:NSTRING-DOWNCASE (STRING &KEY START END) "Given a string, returns that string with all uppercase alphabetic characters converted to lowercase." (WITH-ONE-STRING-ONLY STRING START END (%%STRING-DOWNCASE STRING START END))) (CL:DEFUN CL:NSTRING-UPCASE (STRING &KEY START END) "Given a string, returns that string with all lower case alphabetic characters converted to uppercase." (WITH-ONE-STRING-ONLY STRING START END (%%STRING-UPCASE STRING START END))) (CL:DEFUN STRING (X) "Coerces X into a string. If X is a string, X is returned. If X is a symbol, X's pname is returned. If X is a character then a one element string containing that character is returned. If X cannot be coerced into a string, an error occurs." (CL:TYPECASE X (STRING X) (CL:SYMBOL (CL:SYMBOL-NAME X)) (CL:CHARACTER (CL:MAKE-STRING 1 :INITIAL-ELEMENT X)) (CL:OTHERWISE (CL:ERROR "~S cannot be coerced into a string" X)))) (CL:DEFUN CL:STRING-CAPITALIZE (STRING &KEY START END) "Given a string, returns a new string that is a copy of it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters" (WITH-ONE-STRING STRING START END (LET ((NEW-STRING (CL:MAKE-STRING SLEN))) (CL:DOTIMES (INDEX START) (CL:SETF (CL:SCHAR NEW-STRING INDEX) (CL:CHAR STRING INDEX))) (CL:DO ((INDEX START (CL:1+ INDEX)) (ALPHA-P NIL) (WAS-ALPHA-P NIL ALPHA-P) CHAR) ((EQ INDEX END)) (SETQ CHAR (CL:CHAR STRING INDEX)) (SETQ ALPHA-P (CL:ALPHANUMERICP CHAR)) (CL:SETF (CL:SCHAR NEW-STRING INDEX) (CL:IF (AND ALPHA-P (NOT WAS-ALPHA-P)) (CL:CHAR-UPCASE CHAR) (CL:CHAR-DOWNCASE CHAR)))) (CL:DO ((INDEX END (CL:1+ INDEX))) ((EQ INDEX SLEN)) (CL:SETF (CL:SCHAR NEW-STRING INDEX) (CL:CHAR STRING INDEX))) NEW-STRING))) (CL:DEFUN CL:STRING-DOWNCASE (STRING &KEY START END) "Given a string, returns a new string that is a copy of it with all uppercase case alphabetic characters converted to lowercase." (WITH-ONE-STRING STRING START END (%%STRING-DOWNCASE (COPY-VECTOR STRING (CL:MAKE-STRING SLEN)) START END))) (CL:DEFUN STRING-EQUAL (STRING1 STRING2 &KEY START1 END1 START2 END2) "Compare two strings for case insensitive equality" (CL:IF (OR START1 END1 START2 END2) [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (CL:IF (EQ SLEN1 SLEN2) (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (EQ END1 (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2))))] (CL::SIMPLE-STRING-EQUAL STRING1 STRING2))) (CL:DEFUN CL:STRING-GREATERP (STRING1 STRING2 &KEY START1 END1 START2 END2) "Case insensitive version of STRING>" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ REL-INDEX SLEN2) (CL:IF (> SLEN1 SLEN2) (- INDEX OFFSET1))) ((EQ INDEX END1) NIL) ((CL:CHAR-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING-LEFT-TRIM (CHAR-BAG STRING) "Trim only on left" (WITH-STRING STRING (LET [(LEFT-END (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((OR (EQ INDEX SLEN) (NOT (CL:FIND (CL:CHAR STRING INDEX) CHAR-BAG))) INDEX))] (CL:SUBSEQ STRING LEFT-END SLEN)))) (CL:DEFUN CL:STRING-LESSP (STRING1 STRING2 &KEY START1 END1 START2 END2) "Case insensitive version of STRING<" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ INDEX END1) (CL:IF (< SLEN1 SLEN2) (- INDEX OFFSET1))) ((EQ (- INDEX START1) SLEN2) NIL) ((CL:CHAR-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING-NOT-EQUAL (STRING1 STRING2 &KEY START1 END1 START2 END2) "Compare two string for case insensitive equality" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2))) (CL:IF (AND (EQ INDEX END1) (EQ SLEN1 SLEN2)) NIL (- INDEX OFFSET1))]) (CL:DEFUN CL:STRING-NOT-GREATERP (STRING1 STRING2 &KEY START1 END1 START2 END2) "Case insensitive version of STRING<=" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ INDEX END1) (- INDEX OFFSET1)) ((EQ (- INDEX START1) SLEN2) NIL) ((CL:CHAR-NOT-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING-NOT-LESSP (STRING1 STRING2 &KEY START1 END1 START2 END2) "Case insensitive version of STRING>=" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ REL-INDEX SLEN2) (- INDEX OFFSET1)) ((EQ INDEX END1) NIL) ((CL:CHAR-NOT-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING-RIGHT-TRIM (CHAR-BAG STRING) "Trim only on right" (WITH-STRING STRING (LET [(RIGHT-END (CL:DO ((INDEX (CL:1- SLEN) (CL:1- INDEX))) ((OR (< INDEX 0) (NOT (CL:FIND (CL:CHAR STRING INDEX) CHAR-BAG))) (CL:1+ INDEX)))] (CL:SUBSEQ STRING 0 RIGHT-END)))) (CL:DEFUN CL:STRING-TRIM (CHAR-BAG STRING) (* ;; "Given a set of characters (a list or string) and a string, returns a copy of the string with the characters in the set removed from both ends.") (WITH-STRING STRING (LET* [(LEFT-END (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((OR (EQ INDEX SLEN) (NOT (CL:FIND (CL:CHAR STRING INDEX) CHAR-BAG))) INDEX))) (RIGHT-END (CL:DO ((INDEX (CL:1- SLEN) (CL:1- INDEX))) ((OR (< INDEX LEFT-END) (NOT (CL:FIND (CL:CHAR STRING INDEX) CHAR-BAG))) (CL:1+ INDEX)))] (CL:SUBSEQ STRING LEFT-END RIGHT-END)))) (CL:DEFUN CL:STRING-UPCASE (STRING &KEY START END) "Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase." (WITH-ONE-STRING STRING START END (%%STRING-UPCASE (COPY-VECTOR STRING (CL:MAKE-STRING SLEN)) START END))) (CL:DEFUN CL:STRING/= (STRING1 STRING2 &KEY START1 END1 START2 END2) "Compare two strings for case sensitive inequality" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2))) (CL:IF (AND (EQ INDEX END1) (EQ SLEN1 SLEN2)) NIL (- INDEX OFFSET1))]) (CL:DEFUN CL:STRING< (STRING1 STRING2 &KEY START1 END1 START2 END2) "A string A is less than a string B if in the first position in which they differ the character of A is less than the corresponding character of B according to char< or if string A is a proper prefix of string B (of shorter length and matching in all the characters of A). Returns either NIL or an index into STRING1" [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ INDEX END1) (CL:IF (< SLEN1 SLEN2) (- INDEX OFFSET1))) ((EQ (- INDEX START1) SLEN2) NIL) ((CL:CHAR< (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING<= (STRING1 STRING2 &KEY START1 END1 START2 END2) [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ INDEX END1) (- INDEX OFFSET1)) ((EQ (- INDEX START1) SLEN2) NIL) ((CL:CHAR<= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING= (STRING1 STRING2 &KEY START1 END1 START2 END2) "Compare two strings for case sensitive equality" (CL:IF (OR START1 END1 START2 END2) [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (CL:IF (EQ SLEN1 SLEN2) (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (EQ END1 (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2))))] (CL::SIMPLE-STRING= STRING1 STRING2))) (CL:DEFUN CL:STRING> (STRING1 STRING2 &KEY START1 END1 START2 END2) [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ REL-INDEX SLEN2) (CL:IF (> SLEN1 SLEN2) (- INDEX OFFSET1))) ((EQ INDEX END1) NIL) ((CL:CHAR> (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (CL:DEFUN CL:STRING>= (STRING1 STRING2 &KEY START1 END1 START2 END2) [%%PARSE-STRING-ARGS STRING1 STRING2 START1 END1 START2 END2 (WITH-TWO-UNPACKED-STRINGS STRING1 STRING2 START1 END1 START2 END2 (LET* ((INDEX (%%STRING-BASE-COMPARE BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)) (REL-INDEX (- INDEX START1))) (COND ((EQ REL-INDEX SLEN2) (- INDEX OFFSET1)) ((EQ INDEX END1) NIL) ((CL:CHAR>= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX) (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX))) (- INDEX OFFSET1]) (DEFOPTIMIZER CL:STRING= (STRING1 STRING2 &REST OPTIONS) (CL:IF OPTIONS 'COMPILER:PASS `(CL::SIMPLE-STRING= ,STRING1 ,STRING2))) (DEFOPTIMIZER STRING-EQUAL (STRING1 STRING2 &REST OPTIONS) (CL:IF OPTIONS 'COMPILER:PASS `(CL::SIMPLE-STRING-EQUAL ,STRING1 ,STRING2))) (* ;; "Internal macros ") (DECLARE%: DONTCOPY DOEVAL@COMPILE (DEFMACRO WITH-ONE-STRING (STRING START END &REST FORMS) "WITH-ONE-STRING is used to set up string operations. The keywords are parsed, and STRING is coerced into a string. SLEN is bound to the string length" `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING] (%%CHECK-BOUNDS ,START ,END SLEN) ,@FORMS)) (DEFMACRO WITH-ONE-STRING-ONLY (STRING START END &REST FORMS) (* ;; "Like WITH-ONE-STRING but only strings allowed") `(PROGN (CL:IF (NOT (CL:STRINGP ,STRING)) (CL:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'STRING :CULPRIT ,STRING)) (LET [(SLEN (VECTOR-LENGTH ,STRING] (%%CHECK-BOUNDS ,START ,END SLEN) ,@FORMS))) (DEFMACRO WITH-STRING (STRING &REST FORMS) (* ;; "WITH-STRING is like WITH-ONE-STRING, but doesn't process keywords") `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING] ,@FORMS)) (DEFMACRO WITH-TWO-UNPACKED-STRINGS (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS) (* ;; "Used to set up string comparison operations. String1 and string2 are unpacked and start1, end1, start2, end2 are adjusted for non-zero offsets. Base1 and base2, typenumber1, typenumber2 , offset1 and offset2 are bound to the appropriate unpacked quantities") `(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2) (%%UNPACK-STRING ,STRING1 BASE1 OFFSET1 TYPENUMBER1) (%%UNPACK-STRING ,STRING2 BASE2 OFFSET2 TYPENUMBER2) (%%ADJUST-FOR-OFFSET ,START1 ,END1 OFFSET1) (%%ADJUST-FOR-OFFSET ,START2 ,END2 OFFSET2) ,@FORMS)) (DEFMACRO %%UNPACK-STRING (OBJECT BASE OFFSET TYPENUMBER &OPTIONAL LENGTH) `[COND [(CL:SYMBOLP ,OBJECT) (SETQ ,BASE (fetch (LITATOM PNAMEBASE) of ,OBJECT)) (SETQ ,OFFSET 1) (SETQ ,TYPENUMBER (CL:IF (fetch (LITATOM FATPNAMEP) of ,OBJECT) %%FAT-CHAR-TYPENUMBER %%THIN-CHAR-TYPENUMBER)) ,@(CL:IF LENGTH `[(SETQ ,LENGTH (fetch (LITATOM PNAMELENGTH) of ,OBJECT])] (T [COND [(%%ONED-ARRAY-P ,OBJECT) (SETQ ,BASE (fetch (ARRAY-HEADER BASE) of ,OBJECT)) (SETQ ,OFFSET (fetch (ARRAY-HEADER OFFSET) of ,OBJECT)) (SETQ ,TYPENUMBER (fetch (ARRAY-HEADER TYPE-NUMBER) of ,OBJECT] (T (SETQ ,BASE (%%ARRAY-BASE ,OBJECT)) (SETQ ,OFFSET (%%ARRAY-OFFSET ,OBJECT)) (SETQ ,TYPENUMBER (%%ARRAY-TYPE-NUMBER ,OBJECT] ,@(CL:IF LENGTH `[(SETQ ,LENGTH (fetch (ARRAY-HEADER FILL-POINTER) of ,OBJECT])]) (DEFMACRO %%ADJUST-FOR-OFFSET (START END OFFSET) `(CL:WHEN (NOT (EQ 0 ,OFFSET)) (SETQ ,START (+ ,START ,OFFSET)) (SETQ ,END (+ ,END ,OFFSET)))) (DEFMACRO %%CHECK-BOUNDS (START END LENGTH) `[PROGN [COND ((NULL ,END) (SETQ ,END ,LENGTH)) ((> ,END ,LENGTH) (CL:ERROR "End out of bounds: ~S" ,END] (COND ((NULL ,START) (SETQ ,START 0)) ((NOT (<= 0 ,START ,END)) (CL:ERROR "Improper substring bounds: ~s ~s" ,START ,END]) (DEFMACRO %%PARSE-STRING-ARGS (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS) (* ;; "Used to set up string comparison operations. The keywords are defaulted, bounds are checked and Slen1 and Slen1 are bound to substring lengths%"") `(LET [(SLEN1 (%%STRING-LENGTH ,STRING1)) (SLEN2 (%%STRING-LENGTH ,STRING2] (%%CHECK-BOUNDS ,START1 ,END1 SLEN1) (%%CHECK-BOUNDS ,START2 ,END2 SLEN2) (SETQ SLEN1 (- ,END1 ,START1)) (SETQ SLEN2 (- ,END2 ,START2)) ,@FORMS)) (DEFMACRO %%STRING-LENGTH (STRING) `(COND ((%%STRINGP ,STRING) (fetch (ARRAY-HEADER FILL-POINTER) of ,STRING)) ((CL:SYMBOLP ,STRING) (fetch (LITATOM PNAMELENGTH) of ,STRING)) [(CL:CHARACTERP ,STRING) (VECTOR-LENGTH (SETQ ,STRING (STRING ,STRING] (T (CL:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR STRING CL:SYMBOL CL:CHARACTER) :NAME ,STRING :VALUE ,STRING :MESSAGE "a string, symbol or character")))) ) (* ;; "Compiler options") (PUTPROPS CMLSTRING FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS CMLSTRING COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLSYMBOL b/sources/CMLSYMBOL new file mode 100644 index 00000000..15890419 --- /dev/null +++ b/sources/CMLSYMBOL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:47:55" {DSK}local>lde>lispcore>sources>CMLSYMBOL.;2 2209 changes to%: (VARS CMLSYMBOLCOMS) previous date%: "23-Mar-87 16:05:27" {DSK}local>lde>lispcore>sources>CMLSYMBOL.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLSYMBOLCOMS) (RPAQQ CMLSYMBOLCOMS ( (* ;; "Latter part of the symbol functions. The rest are in LLSYMBOL") (OPTIMIZERS GET CL:GETF CL:SYMBOL-PLIST) (SETFS GET CL:SYMBOL-PLIST CL:SYMBOL-VALUE CL:SYMBOL-FUNCTION) (FUNCTIONS %%SET-GET) (PROP FILETYPE CMLSYMBOL))) (* ;; "Latter part of the symbol functions. The rest are in LLSYMBOL") (DEFOPTIMIZER GET (CL:SYMBOL INDICATOR &REST TAIL) `(CL:GETF (CL:SYMBOL-PLIST ,CL:SYMBOL) ,INDICATOR ,@TAIL)) (DEFOPTIMIZER CL:GETF (PLACE INDICATOR &OPTIONAL DEFAULT) [COND (DEFAULT 'IGNOREMACRO) (T `(LISTGET ,PLACE ,INDICATOR]) (DEFOPTIMIZER CL:SYMBOL-PLIST (CL:SYMBOL) `(GETPROPLIST ,CL:SYMBOL)) (CL:DEFSETF GET %%SET-GET) (CL:DEFSETF CL:SYMBOL-PLIST SETPROPLIST) (CL:DEFSETF CL:SYMBOL-VALUE SET) (CL:DEFSETF CL:SYMBOL-FUNCTION SETF-SYMBOL-FUNCTION) (DEFMACRO %%SET-GET (SYMBOL INDICATOR NEWVALUE &OPTIONAL EXTRAVALUE) (* ;; "SETF-INVERSE for GET. This would be simply PUTPROP if GET had exactly two args. However, if the GET form had optional 3rd arg, it shows up in the NEWVALUE position and the actual new value is EXTRAVALUE") `(PUTPROP ,SYMBOL ,INDICATOR ,(CL:IF EXTRAVALUE `(PROGN ,NEWVALUE ,EXTRAVALUE) NEWVALUE))) (PUTPROPS CMLSYMBOL FILETYPE CL:COMPILE-FILE) (PUTPROPS CMLSYMBOL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CMLTIME b/sources/CMLTIME new file mode 100644 index 00000000..f13c99c3 --- /dev/null +++ b/sources/CMLTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 14:48:46" |{DSK}local>lde>lispcore>sources>CMLTIME.;2| 10763 |changes| |to:| (VARS CMLTIMECOMS) |previous| |date:| "27-Oct-87 19:13:42" |{DSK}local>lde>lispcore>sources>CMLTIME.;1|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CMLTIMECOMS) (RPAQQ CMLTIMECOMS ( (* |;;;| "Common Lisp Time Functions") (FUNCTIONS %CONVERT-INTERNAL-TIME-TO-CLUT) (CONSTANTS (CL:INTERNAL-TIME-UNITS-PER-SECOND 1000)) (FNS CL:GET-INTERNAL-REAL-TIME CL:GET-INTERNAL-RUN-TIME CL:GET-UNIVERSAL-TIME CL:GET-DECODED-TIME CL:DECODE-UNIVERSAL-TIME CL:ENCODE-UNIVERSAL-TIME CL:SLEEP) (PROP FILETYPE CMLTIME) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:SLEEP CL:ENCODE-UNIVERSAL-TIME CL:DECODE-UNIVERSAL-TIME CL:GET-DECODED-TIME CL:GET-UNIVERSAL-TIME CL:GET-INTERNAL-RUN-TIME))))) (* |;;;| "Common Lisp Time Functions") (DEFMACRO %CONVERT-INTERNAL-TIME-TO-CLUT (TIME) (* |;;| "Converts from Interlisp-D internal time format to Common Lisp Universal Time") `(+ ,TIME (CL:* 365 24 60 60) MAX.FIXP 1)) (DECLARE\: EVAL@COMPILE (RPAQQ CL:INTERNAL-TIME-UNITS-PER-SECOND 1000) (CONSTANTS (CL:INTERNAL-TIME-UNITS-PER-SECOND 1000)) ) (DEFINEQ (cl:get-internal-real-time (lambda nil (* |hdj| "18-Jul-86 12:05") (* |;;;| "The current time is returned as a single integer in Internal Time format. (Internal Time format = time in milliseconds for us.) This time is relative to an arbitrary time base, but the difference between the values of two calls to this function will be the amount of elapsed real time between the two calls, measured in the units defined by INTERNAL-TIME-UNITS-PER-SECOND") (clock 0)) ) (cl:get-internal-run-time (cl:lambda nil (* |hdj| "18-Jul-86 12:06") (* |;;;| "The current run time is returned as a single integer in Internal Time format. (Internal Time format = time in milliseconds for us.) The precise meaning of this quantity is implementation-dependent; it may measure real time, run time, CPU cycles, or some other quantity. The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which the computational effort was expended on behalf of the executing program.") (clock 2)) ) (cl:get-universal-time (cl:lambda nil (* |hdj| "18-Jul-86 12:02") (* |;;;| "The current time of day is returned as a single integer in Universal Time format.") (%convert-internal-time-to-clut (daytime))) ) (cl:get-decoded-time (cl:lambda nil (* |hdj| "18-Jul-86 12:08") (* |;;;| "The current time is returned in Decoded Time format. Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.") (cl:decode-universal-time (cl:get-universal-time))) ) (cl:decode-universal-time (cl:lambda (universal-time &optional (time-zone |\\TimeZoneComp| time-zone-suppliedp)) (* |kbr:| " 7-Aug-86 10:21") (* |;;;| "The time specified by UNIVERSAL-TIME in Universal Time format is converted to Decoded Time format. Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.") (prog (checkdls time month sec hr totaldays days leap400 leap100 leap4 year yday wday min dls) (* |;;| "Page 446 of the silver book: If you don't specify TIME-ZONE it defaults to the current time zone adjusted for daylight savings time. If you provide TIME-ZONE explicitly, no adjustment for daylight savings time is is performed.") (setq checkdls (and (not time-zone-suppliedp) |\\DayLightSavings|)) (cl:multiple-value-setq (time sec) (cl:floor universal-time 60)) (cl:multiple-value-setq (time min) (cl:floor time 60)) (cl:multiple-value-setq (totaldays hr) (cl:floor (- time time-zone) 24)) dtloop (* |;;| "LEAP400 = number of 400 year blocks till Jan 1, 2000 Note: The algorithm still works correctly for dates after Jan 1, 2000 . LEAP400 will be negative but not wrong. (Any Jan 1 a year a multiple of 400 would do nicely. Jan 1, 2000 just happens to be close by.)") (cl:multiple-value-setq (leap400 days) (cl:floor (- 36524 totaldays) (+ 36525 (cl:* 3 36524)))) (* \; "LEAP100 = number of 100 year blocks till the 400 year blocks.") (cl:multiple-value-setq (leap100 days) (cl:floor days 36524)) (* \; "LEAP4 = number of 4 year blocks till the 100 year blocks.") (cl:multiple-value-setq (leap4 days) (cl:floor days (+ 366 (cl:* 3 365)))) (* |;;| "Date of answer will be (+ (* 146097 LEAP400) (* 36524 LEAP100) (* 1461 LEAP4) DAYS) days before Jan 1, 2000") (setq year (- 2000 (cl:* 400 leap400) (cl:* 100 leap100) (cl:* 4 leap4) (cdr (\\dtscan days (quote ((1096 . 4) (731 . 3) (366 . 2) (1 . 1) (0 . 0))))))) (* |;;| "YDAY is the ordinal of day as it would appear in a leap year. We thus have Jan 1 = day 0, Feb 29 = day 59, Mar 1 = day 60, and Dec 31 = day 365.") (setq yday (- (cdr (\\dtscan days (cond ((and (eq (cl:mod year 100) 0) (not (eq (cl:mod year 400) 0))) (quote ((1402 . 1460) (1096 . 1461) (1037 . 1095) (731 . 1096) (672 . 730) (366 . 731) (307 . 365) (1 . 366) (0 . 0)))) (t (quote ((1096 . 1461) (1037 . 1095) (731 . 1096) (672 . 730) (366 . 731) (307 . 365) (1 . 366) (0 . 0))))))) days)) (setq wday (cl:mod totaldays 7)) (cond ((and checkdls (setq dls (\\isdst? yday hr wday))) (* |;;| "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1900 was a Monday=0 so offset is 0") (cond ((> (setq hr (cl:1+ hr)) 23) (* |;;| "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") (setq totaldays (cl:1+ totaldays)) (setq hr 0) (setq checkdls nil) (go dtloop))))) (setq month (\\dtscan yday (quote ((335 . 12) (305 . 11) (274 . 10) (244 . 9) (213 . 8) (182 . 7) (152 . 6) (121 . 5) (91 . 4) (60 . 3) (31 . 2) (0 . 1))))) (* \; "Now return (SECOND MINUTE HOUR DAY MONTH YEAR WEEKDAY DAYLIGHT ZONE)") (return (cl:values sec min hr (cl:1+ (- yday (car month))) (cdr month) year wday dls time-zone)))) ) (cl:encode-universal-time (cl:lambda (second minute hour date month year &optional time-zone) (* \; "Edited 27-Oct-87 19:11 by bvm:") (* |;;;| "The time specified by the given components of Decoded Time format is encoded into Universal Time format and returned. If you don't specify TIME-ZONE, it defaults to the current time zone adjusted for daylight saving time. If you provide TIME-ZONE explicitly, no adjustment for daylight saving time is performed.") (prog (yday dayssinceday0) (* |;;| "From pages 444 and 445 of the silver book and Lucid testing, here are three examples of ENCODE-UNIVERSAL-TIME usage known to be correct and which should be rechecked by anyone who edits this function: (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1900 0) = 1 (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1976 0) = 2398291201 (ENCODE-UNIVERSAL-TIME 0 0 0 1 1 3000 0) = 34712668800") (* |;;| "If the YEAR is between 0 and 99 we have to figure out what the `obvious' year is.") (setq year (cl:if (< year 100) (cl:multiple-value-bind (sec min hour day month now-year) (cl:get-decoded-time) (declare (ignore sec min hour day month)) (cl:do ((y (+ year (cl:* 100 (cl:1- (cl:truncate now-year 100)))) (+ y 100))) ((<= (abs (- y now-year)) 50) y))) year)) (setq yday (+ (selectq month (1 0) (2 31) (3 59) (4 90) (5 120) (6 151) (7 181) (8 212) (9 243) (10 273) (11 304) (12 334) nil) (sub1 date))) (setq dayssinceday0 (+ yday (times 365 (setq year (idifference year 1900))) (iquotient (sub1 year) 4))) (|if| (> month 2) |then| (* \; "After February 28") (|add| yday 1) (* \; "Day-of-year is based on 366-day year") (|if| (and (eq 0 (iremainder year 4)) (or (not (eq (iremainder year 100) 0)) (eq (iremainder year 400) 0))) |then| (* \; "It is a leap year, so real day count also incremented") (|add| dayssinceday0 1))) (* |;;| "This is almost right - now correct for 100/400 leap year rule. 1900 is magically handled by above formula, and 2000 is a leap year, so we only need to do this for years after 2100.") (for i from 200 to year by 100 unless (or (= i year) (eq (iremainder i 400) 100)) do (cl:decf dayssinceday0)) (setq hour (+ hour (times 24 dayssinceday0) (cond (time-zone time-zone) ((and |\\DayLightSavings| (\\isdst? yday hour (iremainder dayssinceday0 7))) (* |;;| "Subtract one to go from daylight to standard time. Weekday argument (IREMAINDER DAYSSINCEDAY0 7) to \\ISDST? is based on day 0 = Jan 1, 1900, which was a Monday = 0") (sub1 |\\TimeZoneComp|)) (t |\\TimeZoneComp|)))) (return (+ second (times 60 (+ minute (times 60 hour))))))) ) (cl:sleep (cl:lambda (cl::seconds) (* \; "Edited 24-Apr-87 15:28 by jrb:") (* |;;;| "(SLEEP N) causes execution to cease and become dormant for approximately N seconds of real time, whereupon execution is resumed. The argument may be any non-negative non-complex number. SLEEP returns NIL.") (dismiss (round (cl:* cl::seconds 1000))) nil) ) ) (PUTPROPS CMLTIME FILETYPE CL:COMPILE-FILE) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:SLEEP CL:ENCODE-UNIVERSAL-TIME CL:DECODE-UNIVERSAL-TIME CL:GET-DECODED-TIME CL:GET-UNIVERSAL-TIME CL:GET-INTERNAL-RUN-TIME) ) (PRETTYCOMPRINT CMLTIMECOMS) (RPAQQ CMLTIMECOMS ( (* |;;;| "Common Lisp Time Functions") (FUNCTIONS %CONVERT-INTERNAL-TIME-TO-CLUT) (CONSTANTS (CL:INTERNAL-TIME-UNITS-PER-SECOND 1000)) (FNS CL:GET-INTERNAL-REAL-TIME CL:GET-INTERNAL-RUN-TIME CL:GET-UNIVERSAL-TIME CL:GET-DECODED-TIME CL:DECODE-UNIVERSAL-TIME CL:ENCODE-UNIVERSAL-TIME CL:SLEEP) (PROP FILETYPE CMLTIME) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:DECODE-UNIVERSAL-TIME ))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CL:DECODE-UNIVERSAL-TIME) ) (PUTPROPS CMLTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1528 9294 (CL:GET-INTERNAL-REAL-TIME 1538 . 2006) (CL:GET-INTERNAL-RUN-TIME 2008 . 2592 ) (CL:GET-UNIVERSAL-TIME 2594 . 2803) (CL:GET-DECODED-TIME 2805 . 3111) (CL:DECODE-UNIVERSAL-TIME 3113 . 6417) (CL:ENCODE-UNIVERSAL-TIME 6419 . 8944) (CL:SLEEP 8946 . 9292))))) STOP \ No newline at end of file diff --git a/sources/CMLTYPES b/sources/CMLTYPES new file mode 100644 index 00000000..8f1fb6ef --- /dev/null +++ b/sources/CMLTYPES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-93 17:55:42" IL:|{DSK}lde>lispcore>sources>CMLTYPES.;2| 66088 IL:|previous| IL:|date:| "16-May-90 14:50:29" IL:|{DSK}lde>lispcore>sources>CMLTYPES.;1| ) ; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLTYPESCOMS) (IL:RPAQQ IL:CMLTYPESCOMS ( (IL:* IL:|;;;| "Implementation of Common Lisp type system. ") (IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.") (IL:* IL:|;;;| "Predicates") (IL:FUNCTIONS COMMONP) (IL:* IL:|;;;| "Typep and friends") (IL:VARIABLES *TYPEP-HASH-TABLE*) (IL:FUNCTIONS TYPEP TYPE-OF COERCE TYPECASE) (IL:FUNCTIONS %VALID-TYPE-P) (XCL:OPTIMIZERS TYPEP COERCE) (IL:* IL:|;;;| "for DEFTYPE") (IL:DEFINE-TYPES IL:TYPES) (IL:FUNCTIONS DEFTYPE TYPE-EXPAND TYPE-EXPANDER SETF-TYPE-EXPANDER) (IL:SETFS TYPE-EXPANDER) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:* IL:|;;| "There is still code out there that calls the IL: versions") (IL:P (IL:MOVD 'TYPE-EXPAND 'IL:TYPE-EXPAND) (IL:MOVD 'TYPE-EXPANDER 'IL:TYPE-EXPANDER))) (IL:* IL:|;;;| "Support functions") (IL:FUNCTIONS ARRAY-TYPE SYMBOL-TYPE XCL:FALSE XCL:TRUE %RANGE-TYPE) (IL:FUNCTIONS NUMBERP FLOATP) (XCL:OPTIMIZERS NUMBERP FLOATP XCL:FALSE XCL:TRUE) (IL:* IL:|;;;| "For TYPEP") (IL:FUNCTIONS %TYPEP-PRED BIGNUMP) (IL:* IL:|;;;| "for SUBTYPEP ") (IL:VARIABLES %NO-SUPER-TYPE *COMMON-LISP-BASE-TYPES* *BASE-TYPE-LATTICE*) (IL:FUNCTIONS SUBTYPEP SUBTYPEP-TYPE-EXPAND SI::DATATYPE-P SI::SUB-DATATYPE-P EQUAL-DIMENSIONS COMPLETE-ARRAY-TYPE-DIMENSIONS COMPLETE-META-EXPRESSION-DEFAULTS RANGE<= BASE-SUBTYPEP EQUAL-ELEMENT-TYPE USEFUL-TYPE-EXPANSION-P) (IL:* IL:|;;;| "Basic deftypes") (IL:TYPES ATOM BIGNUM BIT CHARACTER CONS DOUBLE-FLOAT FIXNUM STREAM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER PACKAGE SHORT-FLOAT SIGNED-BYTE STANDARD-CHAR STRING-CHAR SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL READTABLE COMMON COMPILED-FUNCTION SEQUENCE) (IL:* IL:|;;;| "Array Types") (IL:TYPES ARRAY VECTOR STRING SIMPLE-STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR SIMPLE-BIT-VECTOR) (IL:* IL:|;;;| "Fast predicates for typep") (IL:DEFINE-TYPES TYPEP) (IL:FUNCTIONS DEFTYPEP) (TYPEP LIST SEQUENCE MEMBER ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR COMPLEX INTEGER MOD SIGNED-BYTE UNSIGNED-BYTE RATIONAL FLOAT STRING SIMPLE-STRING BIT-VECTOR SIMPLE-BIT-VECTOR) (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") (IL:PROP CMLTYPE IL:CHARACTER IL:FIXP IL:FLOATP IL:GENERAL-ARRAY IL:LISTP IL:LITATOM IL:ONED-ARRAY IL:SMALLP IL:HARRAYP IL:TWOD-ARRAY) (IL:PROP CMLSUBTYPE-DESCRIMINATOR SYMBOL ARRAY) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") (IL:PROP IL:PROPTYPE :TYPE-EXPANDER IL:TYPE-EXPANDER) (IL:* IL:|;;;| "Compiler options") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLTYPES) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T)))) (IL:* IL:|;;;| "Implementation of Common Lisp type system. ") (IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.") (IL:* IL:|;;;| "Predicates") (DEFUN COMMONP (OBJECT) (TYPEP OBJECT 'COMMON)) (IL:* IL:|;;;| "Typep and friends") (DEFPARAMETER *TYPEP-HASH-TABLE* (MAKE-HASH-TABLE :TEST 'EQ)) (DEFUN TYPEP (OBJECT TYPE) (IL:* IL:|;;| "Check if OBJECT is of type TYPE") (LET* ((SYMBOL-TYPE (IF (CONSP TYPE) (CAR TYPE) TYPE)) (FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*))) (IF FN (IF (CONSP TYPE) (FUNCALL FN OBJECT (CDR TYPE)) (FUNCALL FN OBJECT)) (IL:* IL:|;;| "Expand the type") (IF (CONSP TYPE) (CASE SYMBOL-TYPE (SATISFIES (FUNCALL (CADR TYPE) OBJECT)) ((:DATATYPE IL:DATATYPE) (IL:TYPENAMEP OBJECT (CADR TYPE))) (NOT (NOT (TYPEP OBJECT (CADR TYPE)))) (AND (DOLIST (SUB-TYPE (CDR TYPE) T) (IF (NOT (TYPEP OBJECT SUB-TYPE)) (RETURN NIL)))) (OR (DOLIST (SUB-TYPE (CDR TYPE) NIL) (IF (TYPEP OBJECT SUB-TYPE) (RETURN T)))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER TYPE)) (ERROR "Unknown type expression: ~s" TYPE))))) (CASE SYMBOL-TYPE ((T) T) ((NIL) NIL) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER (LIST TYPE))) (ERROR "Unknown type expression: ~s" TYPE))))))))) (DEFUN TYPE-OF (X) (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X)))))) (SETQ TYPENAME (OR (GET TYPENAME 'CMLTYPE) TYPENAME)) (OR (LET ((D (GET TYPENAME 'CMLSUBTYPE-DESCRIMINATOR))) (AND D (FUNCALL D X))) TYPENAME))) (DEFUN COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Coerce object to result-type if possible") (IF (TYPEP OBJECT RESULT-TYPE) OBJECT (COND ((EQ RESULT-TYPE 'CHARACTER) (CHARACTER OBJECT)) ((MEMBER RESULT-TYPE '(FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) :TEST #'EQ) (FLOAT OBJECT)) ((EQ (IF (CONSP RESULT-TYPE) (CAR RESULT-TYPE) RESULT-TYPE) 'COMPLEX) (IF (CONSP RESULT-TYPE) (LET ((SUBTYPE (CADR RESULT-TYPE))) (IF (COMPLEXP OBJECT) (COMPLEX (COERCE (REALPART OBJECT) SUBTYPE) (COERCE (IMAGPART OBJECT) SUBTYPE)) (COMPLEX (COERCE OBJECT SUBTYPE)))) (COMPLEX OBJECT))) ((TYPEP OBJECT 'SEQUENCE) (MAP RESULT-TYPE 'IDENTITY OBJECT)) (T (ERROR "Cannot coerce ~S to type: ~S" OBJECT RESULT-TYPE))))) (DEFMACRO TYPECASE (KEYFORM &REST FORMS) "Type dispatch, order is important, more specific types should appear first" `(LET (($$TYPE-VALUE ,KEYFORM)) (COND ,@(MAPCAR #'(LAMBDA (FORM) (LET ((PRED (IF (MEMBER (CAR FORM) '(OTHERWISE T) :TEST #'EQ) T `(TYPEP $$TYPE-VALUE ',(CAR FORM)))) (FORM (IF (NULL (CDR FORM)) '(NIL) (CDR FORM)))) `(,PRED ,@FORM))) FORMS)))) (DEFUN %VALID-TYPE-P (TYPE) (IF (CONSP TYPE) (CASE (CAR TYPE) (SATISFIES T) ((OR AND) (EVERY '%VALID-TYPE-P (CDR TYPE))) (NOT (%VALID-TYPE-P (CADR TYPE))) ((:DATATYPE IL:DATATYPE) T) (OTHERWISE (AND (TYPE-EXPANDER TYPE) T))) (OR (AND (TYPE-EXPANDER TYPE) T) (EQ TYPE T) (NULL TYPE)))) (XCL:DEFOPTIMIZER TYPEP (OBJ TYPE) (IF (CONSTANTP TYPE) (LET ((TYPE-EXPR (EVAL TYPE))) (IF (%VALID-TYPE-P TYPE-EXPR) `(,(%TYPEP-PRED TYPE-EXPR) ,OBJ) (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ TYPE) 'COMPILER:PASS))) 'COMPILER:PASS)) (XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Open code the simple coerce cases ") (IF (CONSTANTP RESULT-TYPE) (CASE (EVAL RESULT-TYPE) (CHARACTER `(CHARACTER ,OBJECT)) ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) `(FLOAT ,OBJECT)) (OTHERWISE 'COMPILER:PASS)) 'COMPILER:PASS)) (IL:* IL:|;;;| "for DEFTYPE") (XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions") (XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) `(DEFTYPE ,NAME ("Arg list") "Body"))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPE: ~S" NAME)) (LET ((EXPANDER-NAME (XCL:PACK (LIST "type-expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO DEFTYPE-ARGS 'SI::%$$TYPE-FORM BODY NAME NIL :DEFAULT-DEFAULT ''*) `(EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION ',EXPANDER-NAME) #'(LAMBDA (SI::%$$TYPE-FORM) ,@DECLS (BLOCK ,NAME ,PARSED-BODY))) (SETF (TYPE-EXPANDER ',NAME) ',EXPANDER-NAME) ,@(AND DOCSTRING `((SETF (DOCUMENTATION ',NAME 'TYPE) ,DOCSTRING))) ,@(IF (NULL DEFTYPE-ARGS) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) `((EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION ',TYPEP-NAME) #'(LAMBDA (SI::%$$OBJECT) (TYPEP SI::%$$OBJECT ',NAME))) (PUTHASH ',NAME *TYPEP-HASH-TABLE* ',TYPEP-NAME)) (EVAL-WHEN (EVAL) (PUTHASH ',NAME *TYPEP-HASH-TABLE* NIL))))))))) (DEFUN TYPE-EXPAND (FORM &OPTIONAL (EXPANDER (TYPE-EXPANDER FORM))) (IL:* IL:|;;| "Expands a type form according to deftypes in effect. The caller must ensure there is an expander for the form ") (IF EXPANDER (VALUES (FUNCALL EXPANDER (ETYPECASE FORM (SYMBOL (LIST FORM)) (CONS FORM))) T) (VALUES FORM NIL))) (DEFUN TYPE-EXPANDER (TYPE) (LET* ((SYMBOL-TYPE (ETYPECASE TYPE (SYMBOL TYPE) (CONS (CAR TYPE)))) (EXPANDER (OR (GET SYMBOL-TYPE ':TYPE-EXPANDER) (GET SYMBOL-TYPE 'IL:TYPE-EXPANDER)))) (IF (AND (NULL EXPANDER) (SYMBOLP TYPE) (SI::DATATYPE-P TYPE)) (IL:* IL:|;;| "Install a deftype") (LET ((DEFTYPE-FORM `(DEFTYPE ,TYPE () '(:DATATYPE ,TYPE)))) (IF (FBOUNDP 'XCL:COMPILE-FORM) (IL:* IL:|;;| "Compile form on the fly") (XCL:COMPILE-FORM DEFTYPE-FORM) (LET ((IL:DFNFLG NIL) (IL:FILEPKGFLG NIL) (IL:* IL:|;;|  "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.") ) (EVAL DEFTYPE-FORM))) (TYPE-EXPANDER TYPE)) EXPANDER))) (DEFMACRO SETF-TYPE-EXPANDER (SYMBOL EXPANDER) `(SETF (GET ,SYMBOL ':TYPE-EXPANDER) ,EXPANDER)) (DEFSETF TYPE-EXPANDER SETF-TYPE-EXPANDER) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:MOVD 'TYPE-EXPAND 'IL:TYPE-EXPAND) (IL:MOVD 'TYPE-EXPANDER 'IL:TYPE-EXPANDER) ) (IL:* IL:|;;;| "Support functions") (DEFUN ARRAY-TYPE (ARRAY) (LET ((RANK (ARRAY-RANK ARRAY))) (IF (XCL:SIMPLE-ARRAY-P ARRAY) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((SIMPLE-STRING-P ARRAY) (LIST 'SIMPLE-STRING SIZE)) ((SIMPLE-BIT-VECTOR-P ARRAY) (LIST 'SIMPLE-BIT-VECTOR SIZE)) (T (LET ((ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY))) (IF (EQ ELT-TYPE T) (LIST 'SIMPLE-VECTOR SIZE) (LIST 'SIMPLE-ARRAY ELT-TYPE (LIST SIZE))))))) (LIST 'SIMPLE-ARRAY (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((STRINGP ARRAY) (LIST 'STRING SIZE)) ((BIT-VECTOR-P ARRAY) (LIST 'BIT-VECTOR SIZE)) (T (LIST 'VECTOR (ARRAY-ELEMENT-TYPE ARRAY) SIZE)))) (LIST 'ARRAY (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY)))))) (DEFUN SYMBOL-TYPE (SYMBOL) (IF (KEYWORDP SYMBOL) 'KEYWORD 'SYMBOL)) (DEFUN XCL:FALSE () NIL) (DEFUN XCL:TRUE () T) (DEFUN %RANGE-TYPE (BASE-TYPE LOW HIGH RANGE-LIST) (IL:* IL:|;;| "Returns a type form discriminating basetype. Rangelist is a list of (decreasing) subranges of the full range of basetype (represented as a list of low, high and subtype). If low and high fall within its range, a form is returned which discriminates on the subtype, and checks the range. If low and high are exactly the range of the subtype then no range checking form is returned.") (COND ((AND (EQ LOW '*) (EQ HIGH '*)) BASE-TYPE) ((OR (EQ LOW '*) (EQ HIGH '*)) `(AND ,BASE-TYPE (SATISFIES (LAMBDA (X) ,@(IF (NOT (EQ LOW '*)) `((,(COND ((CONSP LOW) (SETQ LOW (CAR LOW)) '<) (T '<=)) ,LOW X))) ,@(IF (NOT (EQ HIGH '*)) `((,(COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) '<) (T '<=)) X ,HIGH))))))) (T (DOLIST (X RANGE-LIST `(AND ,BASE-TYPE (SATISFIES (LAMBDA (X) (AND (,(COND ((CONSP LOW) (SETQ LOW (CAR LOW)) '<) (T '<=)) ,LOW X) (,(COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) '<) (T '<=)) X ,HIGH)))))) (IL:* IL:|;;| "If the limits are exactly the range specified in the rangelist, then return the corresponding type (since no range-check will be required in the result).") (IF (AND (EQUAL LOW (CAR X)) (EQUAL HIGH (CADR X))) (RETURN (CADDR X))) (IL:* IL:|;;| "If the limits are within the range, then remember the basetype.") (IF (<= (CAR X) (IF (CONSP LOW) (1+ (CAR LOW)) LOW) (IF (CONSP HIGH) (1- (CAR HIGH)) HIGH) (CADR X)) (SETQ BASE-TYPE (CADDR X))))))) (DEFUN NUMBERP (X) (AND (IL:NUMBERP X) T)) (DEFUN FLOATP (X) (AND (IL:FLOATP X) T)) (XCL:DEFOPTIMIZER NUMBERP (X) `(AND (IL:NUMBERP ,X) T)) (XCL:DEFOPTIMIZER FLOATP (X) `(AND (IL:FLOATP ,X) T)) (XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS) `(PROG1 NIL ,@IL:FORMS)) (XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS) `(PROG1 T ,@XCL::FORMS)) (IL:* IL:|;;;| "For TYPEP") (DEFUN %TYPEP-PRED (TYPE) (IL:* IL:|;;| "returns the predicate of one argument that determines this type.") (COND ((CONSP TYPE) (CASE (CAR TYPE) (SATISFIES (CADR TYPE)) ((:DATATYPE IL:DATATYPE) `(LAMBDA (SI::%$$OBJECT) (IL:TYPENAMEP SI::%$$OBJECT ',(CADR TYPE)))) ((AND OR NOT) `(LAMBDA (SI::%$$OBJECT) (,(CAR TYPE) ,@(MAPCAR #'(LAMBDA (SUBTYPE) (LIST (%TYPEP-PRED SUBTYPE) 'SI::%$$OBJECT)) (CDR TYPE))))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER (CAR TYPE)))) (IF EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER TYPE)) (CERROR "Look again for a deftype on ~S." "No type definition for ~S. Specify one with DEFTYPE." TYPE))))) ) (T (COND ((EQ TYPE T) 'XCL:TRUE) ((EQ TYPE NIL) 'XCL:FALSE) (T (LET ((EXPANDER (TYPE-EXPANDER TYPE))) (COND (EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER (LIST TYPE)))) (T (IL:* IL:|;;| "there is no deftype on this non-list type. ") (LOOP (IF (TYPE-EXPANDER TYPE) (RETURN NIL)) (CERROR "Use the deftype you have specified." "No type definition for ~S. Specify one with DEFTYPE." TYPE)) (%TYPEP-PRED TYPE))))))))) (DEFUN BIGNUMP (X) (OR (IL:TYPENAMEP X 'IL:FIXP) (IL:TYPENAMEP X 'BIGNUM))) (IL:* IL:|;;;| "for SUBTYPEP ") (DEFCONSTANT %NO-SUPER-TYPE 0 "the value in the dtdsupertype field which indicates no super type.") (DEFCONSTANT *COMMON-LISP-BASE-TYPES* (IL:* IL:|;;|  "The types which are known to be disjoint from any type explicitly handled by subtypep.") '( (IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.") ARRAY ATOM BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.") CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE (IL:* IL:\;  "this is only here for back-compatibility. The first global recompile, this can go.") :DATATYPE FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO (IL:* IL:\;  "same comment for ratio as bignum.") RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T)) (DEFCONSTANT *BASE-TYPE-LATTICE* '((NUMBER RATIONAL INTEGER RATIO FIXNUM BIGNUM COMPLEX FLOAT) (RATIONAL INTEGER RATIO FIXNUM BIGNUM) (INTEGER FIXNUM BIGNUM) (CHARACTER STRING-CHAR STANDARD-CHAR) (STRING-CHAR STANDARD-CHAR) (LIST NULL) (SYMBOL KEYWORD NULL) (ARRAY SIMPLE-ARRAY) #'COMPILED-FUNCTION (NIL) (IL:DATATYPE :DATATYPE) (IL:* IL:\;  "the presence of il:datatype is for back compatibility.") (:DATATYPE IL:DATATYPE)) "the lattice which tells the (base) subtypes of any base type.") (DEFUN SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;|  "Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.") (IF (EQUAL TYPE1 TYPE2) (IL:* IL:|;;| "no need to complete any further recursion, so just return success.") (VALUES T T) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) (AND (IL:* IL:|;;| "(subtypep '(and t1 t2 ...) 't3) <= (or (subtypep 't1 't3) (subtypep 't2 't3) ... ) because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...") (IL:* IL:|;;| "Even if none of the conjuncts is a subtype, we still can't return (NIL T) because the intersection might still be a subtype.") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;|  "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) LOOP-CERTAINTY) (IL:* IL:|;;| "returns t only if every conjunct clause is a certain subtype, or if one conjunct clause is certainly not a subtype") (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;|  "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "Try to expand type1") (MULTIPLE-VALUE-BIND (NEW-TYPE1 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE1) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE1 EXPANDED?) (SUBTYPEP NEW-TYPE1 TYPE2) (IL:* IL:|;;| "We now have a base type for type1, there is nothing further to be done with it, by itself. So we check for special cases in type2") (CASE (IF (CONSP TYPE2) (CAR TYPE2) TYPE2) (AND (IL:* IL:|;;| " (subtypep 't1 '(and t2 t3 ...)) <=> (and (subtypep 't1 't2) (subtypep 't1 't3) ...) because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) LOOP-CERTAINTY) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;|  "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ... ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...") (IL:* IL:|;;|  "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") (IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))") (IL:* IL:|;;| "(deftype oddp nil '(and integer (satisfies %oddp)))") (IL:* IL:|;;| "(subtypep 'integer '(or evenp oddp)) is true, but the satisfies makes it undecidable, so we must return (nil nil).") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "try to expand type2.") (MULTIPLE-VALUE-BIND (NEW-TYPE2 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE2) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE2 EXPANDED?) (SUBTYPEP TYPE1 NEW-TYPE2) (IL:* IL:|;;|  "we have now handled everything but base types. There is no further expansion etc, to be done.") (BASE-SUBTYPEP TYPE1 TYPE2))))))))))) (DEFUN SUBTYPEP-TYPE-EXPAND (TYPE) (IL:* IL:|;;| "Like type-expand, except it doesn't expand base-types.") (IF (MEMBER (IF (CONSP TYPE) (CAR TYPE) TYPE) *COMMON-LISP-BASE-TYPES* :TEST #'EQ) (VALUES TYPE NIL) (TYPE-EXPAND TYPE))) (DEFUN SI::DATATYPE-P (SI::NAME) (IL:* IL:|;;| "Returns T if name is a datatype known to the XAIE type system") (AND (IL:\\TYPENUMBERFROMNAME SI::NAME) T)) (DEFUN SI::SUB-DATATYPE-P (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type2 is a (not necessarily proper) supertype of type1.") (DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1)) (TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2)) (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD SUPER-TYPE-NUMBER )))) ((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER) (IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL ") NIL) (IF (EQ SUPER-TYPE-NUMBER TYPE-NUMBER-2) (RETURN T)))) (DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2) (IL:* IL:|;;|  "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") (OR (EQ DIMS1 '*) (EQ DIMS2 '*) (AND (EQUAL (LENGTH DIMS1) (LENGTH DIMS2)) (DO ((DIM1 DIMS1 (CDR DIM1)) (DIM2 DIMS2 (CDR DIM2))) ((NULL DIM1) T) (IF (NOT (OR (EQ (CAR DIM1) '*) (EQ (CAR DIM2) '*) (EQ (CAR DIM1) (CAR DIM2)))) (RETURN NIL)))))) (DEFUN COMPLETE-ARRAY-TYPE-DIMENSIONS (DIMENSIONS) (ETYPECASE DIMENSIONS (CONS DIMENSIONS) ((OR NULL (MEMBER *)) '*) (INTEGER (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT '*)))) (DEFUN COMPLETE-META-EXPRESSION-DEFAULTS (TYPE) (IL:* IL:|;;| "given a type expression finishes the defaults the same way as the type-expander.") (LET ((LIST-TYPE (IF (LISTP TYPE) TYPE (LIST TYPE)))) (CASE (CAR LIST-TYPE) ((SIMPLE-ARRAY ARRAY) (XCL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE '*) (DIMENSIONS '*)) LIST-TYPE (LIST ARRAY-TYPE ELEMENT-TYPE (  COMPLETE-ARRAY-TYPE-DIMENSIONS DIMENSIONS)))) ((INTEGER FLOAT RATIONAL) (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (LOWER '*) (HIGHER '*)) LIST-TYPE (LIST NUMERIC-TYPE LOWER HIGHER))) (COMPLEX (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (ELEMENT-TYPE '*)) LIST-TYPE (LIST NUMERIC-TYPE ELEMENT-TYPE))) (T TYPE)))) (DEFUN RANGE<= (LOW2 LOW1 HIGH1 HIGH2 TYPE1 TYPE2) (IL:* IL:|;;;| "Returns t if bound1 is less than or equal bound2, allowing for wildcards. ") (IF (EQ TYPE1 'INTEGER) (COND ((CONSP LOW1) (SETQ LOW1 (+ (CAR LOW1) 1))) ((CONSP HIGH1) (SETQ HIGH1 (- (CAR HIGH1) 1))))) (IF (EQ TYPE2 'INTEGER) (COND ((CONSP LOW2) (SETQ LOW2 (+ (CAR LOW2) 1))) ((CONSP HIGH2) (SETQ HIGH2 (- (CAR HIGH2) 1))))) (AND (IL:* IL:|;;| "check the low bounds") (COND ((EQ LOW2 '*) T) ((EQ LOW1 '*) NIL) (T (IF (CONSP LOW2) (IF (CONSP LOW1) (<= (CAR LOW2) (CAR LOW1)) (< (CAR LOW2) LOW1)) (IF (CONSP LOW1) (<= LOW2 (CAR LOW1)) (<= LOW2 LOW1))))) (IL:* IL:|;;| "Check the high bounds") (COND ((EQ HIGH2 '*) T) ((EQ HIGH1 '*) NIL) (T (IF (CONSP HIGH2) (IF (CONSP HIGH1) (>= (CAR HIGH2) (CAR HIGH1)) (> (CAR HIGH2) HIGH1)) (IF (CONSP HIGH1) (>= HIGH2 (CAR HIGH1)) (>= HIGH2 HIGH1))))))) (DEFUN BASE-SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Contains subtypep's special cases for base types.") (LET ((SYMBOL-TYPE1 (IF (CONSP TYPE1) (CAR TYPE1) TYPE1)) (SYMBOL-TYPE2 (IF (CONSP TYPE2) (CAR TYPE2) TYPE2))) (COND ((OR (EQ TYPE1 NIL) (EQ TYPE2 T) (EQUAL TYPE1 TYPE2)) (VALUES T T)) ((EQ TYPE2 'COMMON) (IL:* IL:\; "Common does not list it's subtypes in the lattice, since their presence indicates that they are in COMMON.") (IF (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST #'EQ) (IL:* IL:|;;| "then this is part of common. Note this will include structures etc.") (VALUES T T) (VALUES NIL T))) ((OR (NOT (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST #'EQ)) (NOT (MEMBER SYMBOL-TYPE2 *COMMON-LISP-BASE-TYPES* :TEST #'EQ))) (IL:* IL:\; "one of the types is something we can't reason about (for instance a user defined type that expands into satisfies.)") (VALUES NIL NIL)) (IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.") ((EQ TYPE1 T) (IL:* IL:\;  "t is not a subtype of anything but t, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 NIL) (IL:* IL:\;  "nil is not a supertype of anything but nil, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 'ATOM) (IL:* IL:|;;| "this case could be explicitly added to the type lattice. But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)") (IF (EQ TYPE1 'CONS) (IL:* IL:\;  "this is the only base type that isn't a subtype of atom.") (VALUES NIL T) (VALUES T T))) ((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2) (MEMBER SYMBOL-TYPE1 (ASSOC SYMBOL-TYPE2 *BASE-TYPE-LATTICE* :TEST #'EQ) :TEST #'EQ))) (IL:* IL:|;;| "since we are now dealing with only base types, we can make sure that type1 (without its arguments) is a subtype of type2, before checking the constraints on the arguments.") (VALUES NIL T)) (T (IL:* IL:|;;| "Now check the constraints on the type arguments.") (LET ((TYPE1 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE1)) (TYPE2 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE2))) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) ((ARRAY SIMPLE-ARRAY) (IL:* IL:|;;|  "the type will look like (simple-array element-type dimensions)") (XCL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1) TYPE1 (XCL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2) TYPE2 (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2) (EQUAL-DIMENSIONS DIMS-1 DIMS-2)) (VALUES T T) (VALUES NIL T))))) ((:DATATYPE IL:DATATYPE) (IL:* IL:|;;| "we wouldn't have made it here if they weren't both datatypes, since only datatype is a subtype of datatype in the lattice.") (VALUES (SI::SUB-DATATYPE-P (CADR TYPE1) (CADR TYPE2)) T)) ((INTEGER RATIONAL FLOAT) (CASE TYPE2 (NUMBER (IL:* IL:|;;|  "number doesn't take ranges, there's nothing to verify.") (VALUES T T)) (OTHERWISE (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE1 LOW1 HIGH1) TYPE1 (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE2 LOW2 HIGH2) TYPE2 (IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2 NUMERIC-TYPE1 NUMERIC-TYPE2) (VALUES T T) (VALUES NIL T))))))) (COMPLEX (CASE TYPE2 (NUMBER (VALUES T T)) (OTHERWISE (IL:* IL:|;;| "typep2 must be complex") (LET ((ELT-TYPE1 (CADR TYPE1)) (ELT-TYPE2 (CADR TYPE2))) (COND ((EQ ELT-TYPE2 '*) (VALUES T T)) ((EQ ELT-TYPE1 '*) (VALUES NIL T)) (T (SUBTYPEP ELT-TYPE1 ELT-TYPE2))))))) (OTHERWISE (IL:* IL:|;;| "these are two base types. the lattice said they are subtypes, and there are no special rules on the arguments, so the result is (t t) if they are equal") (VALUES T T)))))))) (DEFUN EQUAL-ELEMENT-TYPE (ELEMENT-TYPE-1 ELEMENT-TYPE-2) (IL:* IL:|;;| "returns t if they are element types for compatible array types.") (COND ((EQ ELEMENT-TYPE-2 '*) T) ((EQ ELEMENT-TYPE-1 '*) NIL) (T (EQUAL (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-1) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-2))))) (DEFUN USEFUL-TYPE-EXPANSION-P (EXPANSION EXPANDED) (IL:* IL:|;;| "a type expansion only gained information if some expansion happened and the result isn't solely a satisfies form.") (AND EXPANDED (NOT (AND (CONSP EXPANSION) (EQ (CAR EXPANSION) 'SATISFIES))))) (IL:* IL:|;;;| "Basic deftypes") (DEFTYPE ATOM () '(SATISFIES ATOM)) (DEFTYPE BIGNUM () '(SATISFIES BIGNUMP)) (DEFTYPE BIT () '(INTEGER 0 1)) (DEFTYPE CHARACTER () '(SATISFIES CHARACTERP)) (DEFTYPE CONS () '(:DATATYPE IL:LISTP)) (DEFTYPE DOUBLE-FLOAT (&OPTIONAL LOW HIGH) `(FLOAT ,LOW ,HIGH)) (DEFTYPE FIXNUM () `(INTEGER ,MOST-NEGATIVE-FIXNUM ,MOST-POSITIVE-FIXNUM)) (DEFTYPE STREAM () '(:DATATYPE STREAM)) (DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (%RANGE-TYPE '(:DATATYPE IL:FLOATP) LOW HIGH)) (DEFTYPE FUNCTION () '(SATISFIES FUNCTIONP)) (DEFTYPE HASH-TABLE () '(:DATATYPE IL:HARRAYP)) (DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (%RANGE-TYPE '(SATISFIES INTEGERP) LOW HIGH `((,IL:MIN.INTEGER ,IL:MAX.INTEGER (SATISFIES INTEGERP)) (,IL:MIN.FIXP ,IL:MAX.FIXP (OR (SATISFIES IL:SMALLP) (:DATATYPE IL:FIXP))) (,IL:MIN.SMALLP ,IL:MAX.SMALLP (SATISFIES IL:SMALLP)) (0 1 (MEMBER 0 1))))) (DEFTYPE KEYWORD () '(SATISFIES KEYWORDP)) (DEFTYPE LIST (&OPTIONAL TYPE) (IF (EQ TYPE '*) '(OR NULL CONS) `(AND LIST (SATISFIES (LAMBDA (X) (EVERY #'(LAMBDA (ELEMENT) (TYPEP ELEMENT ',TYPE)) X)))))) (DEFTYPE LONG-FLOAT (&OPTIONAL LOW HIGH) `(FLOAT ,LOW ,HIGH)) (DEFTYPE MEMBER (&REST VALUES) `(SATISFIES (LAMBDA (X) (MEMBER X ',VALUES)))) (DEFTYPE MOD (N) `(INTEGER 0 ,(1- N))) (DEFTYPE NULL () '(SATISFIES NULL)) (DEFTYPE NUMBER () '(SATISFIES NUMBERP)) (DEFTYPE PACKAGE () '(:DATATYPE PACKAGE)) (DEFTYPE SHORT-FLOAT (&OPTIONAL LOW HIGH) `(FLOAT ,LOW ,HIGH)) (DEFTYPE SIGNED-BYTE (&OPTIONAL S) (IF (EQ S '*) 'INTEGER (LET ((SIZE (EXPT 2 (1- S)))) `(INTEGER ,(- SIZE) ,(1- SIZE))))) (DEFTYPE STANDARD-CHAR () '(SATISFIES STANDARD-CHAR-P)) (DEFTYPE STRING-CHAR () '(AND CHARACTER (SATISFIES STRING-CHAR-P))) (DEFTYPE SINGLE-FLOAT (&OPTIONAL LOW HIGH) `(FLOAT ,LOW ,HIGH)) (DEFTYPE SYMBOL () '(:DATATYPE IL:LITATOM)) (DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (IF (EQ S '*) '(INTEGER 0 *) `(INTEGER 0 (,(EXPT 2 S))))) (DEFTYPE RATIONAL (&OPTIONAL LOW HIGH) (%RANGE-TYPE '(OR RATIO INTEGER) LOW HIGH)) (DEFTYPE READTABLE () '(:DATATYPE READTABLEP)) (DEFTYPE COMMON () (IL:* IL:|;;| "This is a hack. (You can tell, because it uses TYPE-OF.) However, it is correct. (Note that even though subtypep uses expanders, there is no danger of a loop because it quits when it reachs a satisfies clause.)") `(SATISFIES (LAMBDA (OBJ) (VALUES (SUBTYPEP (TYPE-OF OBJ) 'COMMON))))) (DEFTYPE COMPILED-FUNCTION () '(SATISFIES COMPILED-FUNCTION-P)) (DEFTYPE SEQUENCE (&OPTIONAL TYPE) (IL:* IL:|;;| "Larry's dubious extension, that I can't remove because he wrote code that relies on it. Actually the extension is somewhat useful, but confusing. (it simulates the DECL facility for saying (LIST user-type).)") (IF (EQ TYPE '*) '(OR VECTOR LIST) `(AND SEQUENCE (SATISFIES (LAMBDA (X) (EVERY #'(LAMBDA (ELEMENT) (TYPEP ELEMENT ',TYPE)) X)))))) (IL:* IL:|;;;| "Array Types") (DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;;| "This type definition should not return anything other than satisfies. Other array types are determined in terms of this one, (for subtypep's sake) so this one must bottom out.") (IF (TYPEP DIMENSIONS 'FIXNUM) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT '*))) (IF (NOT (EQ ELEMENT-TYPE '*)) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (COND ((EQ DIMENSIONS '*) (IF (EQ ELEMENT-TYPE '*) '(SATISFIES ARRAYP) `(SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE)))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ ELEMENT-TYPE '*) (IF (EQ SIZE '*) '(SATISFIES VECTORP) `(SATISFIES (LAMBDA (X) (AND (VECTORP X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) ((EQ ELEMENT-TYPE 'STRING-CHAR) (IF (EQ SIZE '*) '(SATISFIES STRINGP) `(SATISFIES (LAMBDA (X) (AND (STRINGP X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) ((OR (EQ ELEMENT-TYPE 'BIT) (EQUAL ELEMENT-TYPE '(UNSIGNED-BYTE 1))) (IF (EQ SIZE '*) '(SATISFIES BIT-VECTOR-P) `(SATISFIES (LAMBDA (X) (AND (BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) (T (IL:* IL:|;;| "vector of explicit element-type") `(SATISFIES (LAMBDA (X) (AND (VECTORP X) ,@(IF (NOT (EQ SIZE '*)) `((EQ (ARRAY-TOTAL-SIZE X) ,SIZE))) (EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE)))))))) ((EVERY #'(LAMBDA (DIM) (EQ DIM '*)) DIMENSIONS) `(SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) ,(LENGTH DIMENSIONS)) ,@(IF (NOT (EQ ELEMENT-TYPE '*)) `((EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE))))))) ((EVERY #'(LAMBDA (DIM) (OR (EQ DIM '*) (TYPEP DIM 'FIXNUM))) DIMENSIONS) `(SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) ,(LENGTH DIMENSIONS)) ,@(DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) '*)) (PUSH `(EQ (ARRAY-DIMENSION X ,DIM) ,(CAR DIM-SPEC)) FORMS))) ,@(IF (NOT (EQ ELEMENT-TYPE '*)) `((EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE))))))) (T (ERROR "Bad (final) array type designator: ~S" `(ARRAY ,ELEMENT-TYPE ,DIMENSIONS))))) (DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (IL:* IL:|;;|  "this type must be defined in terms of array so that subtypep can reason(?) about them.") `(ARRAY ,ELEMENT-TYPE (,SIZE))) (DEFTYPE STRING (&OPTIONAL SIZE) `(ARRAY STRING-CHAR (,SIZE))) (DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) `(SIMPLE-ARRAY STRING-CHAR (,SIZE))) (DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;| "Simple-array type expander") (IF (TYPEP DIMENSIONS 'FIXNUM) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT '*))) (IF (NOT (EQ ELEMENT-TYPE '*)) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (IL:* IL:|;;| "at this point, dimensions is always a list of integers or *'s, and element-type is a canonical type.") (COND ((EQ DIMENSIONS '*) (IF (EQ ELEMENT-TYPE '*) '(SATISFIES XCL:SIMPLE-ARRAY-P) `(SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE)))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ ELEMENT-TYPE 'STRING-CHAR) (IF (EQ SIZE '*) '(SATISFIES SIMPLE-STRING-P) `(SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) ((OR (EQ ELEMENT-TYPE 'BIT) (EQUAL ELEMENT-TYPE '(UNSIGNED-BYTE 1))) (IF (EQ SIZE '*) '(SATISFIES SIMPLE-BIT-VECTOR-P) `(SATISFIES (LAMBDA (X) (AND (SIMPLE-BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) ((EQ ELEMENT-TYPE T) (IF (EQ SIZE '*) '(SATISFIES SIMPLE-VECTOR-P) `(SATISFIES (LAMBDA (X) (AND (SIMPLE-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) ,SIZE)))))) (T `(SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ 1 (ARRAY-RANK X)) ,@(IF (NOT (EQ SIZE '*)) `((EQ (ARRAY-TOTAL-SIZE X) ,SIZE))) ,@(IF (NOT (EQ ELEMENT-TYPE '*)) `((EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE)))))))))) ((EVERY #'(LAMBDA (DIM) (EQ DIM '*)) DIMENSIONS) `(SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) ,(LENGTH DIMENSIONS)) ,@(IF (NOT (EQ ELEMENT-TYPE '*)) `((EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE))))))) ((EVERY #'(LAMBDA (DIM) (OR (EQ DIM '*) (TYPEP DIM 'FIXNUM))) DIMENSIONS) `(SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) ,(LENGTH DIMENSIONS)) ,@(DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) '*)) (PUSH `(EQ (ARRAY-DIMENSION X ,DIM) ,(CAR DIM-SPEC)) FORMS))) ,@(IF (NOT (EQ ELEMENT-TYPE '*)) `((EQUAL (ARRAY-ELEMENT-TYPE X) ',ELEMENT-TYPE))))))) (T (ERROR "Bad (final) array type designator: ~S" `(SIMPLE-ARRAY ,ELEMENT-TYPE ,DIMENSIONS))))) (DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) `(SIMPLE-ARRAY T (,SIZE))) (DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) `(ARRAY (UNSIGNED-BYTE 1) (,SIZE))) (DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) `(SIMPLE-ARRAY (UNSIGNED-BYTE 1) (,SIZE))) (IL:* IL:|;;;| "Fast predicates for typep") (XCL:DEF-DEFINE-TYPE TYPEP "Typep evaluator for a type") (XCL:DEFDEFINER DEFTYPEP TYPEP (NAME TYPE-ARGS OBJECT-ARG &BODY BODY) (IL:* IL:|;;;| "The comment below is not necessarily true for deftype, so until the PavCompiler groks deftype, leave the eval-when alone.") (IL:* IL:|;;| "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with. The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.") (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPEP: ~S" NAME)) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO TYPE-ARGS 'SI::%$$TYPE-ARGS BODY NAME NIL :DEFAULT-DEFAULT ''* :PATH 'SI::%$$TYPE-ARGS) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:* IL:|;;|  "the eval-when insures that the functions in the hash table are always compiled") `(PROGN (EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION ',TYPEP-NAME) #'(LAMBDA (SI::%$$OBJECT &OPTIONAL SI::%$$TYPE-ARGS) ,@DECLS (BLOCK ,NAME (LET ((,(CAR OBJECT-ARG) SI::%$$OBJECT)) ,PARSED-BODY)))) (SETF (GETHASH ',NAME *TYPEP-HASH-TABLE*) ',TYPEP-NAME) ,@(AND DOCSTRING `((SETF (DOCUMENTATION ',NAME 'TYPEP) ,DOCSTRING)))) (EVAL-WHEN (EVAL) (IL:* IL:|;;| "With redefinition, clear the hash table") (SETF (GETHASH ',NAME *TYPEP-HASH-TABLE*) NIL)))))) (DEFTYPEP LIST (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (LISTP OBJECT) (IF (EQ ELEMENT-TYPE '*) T (DOLIST (L OBJECT T) (IF (NOT (TYPEP L ELEMENT-TYPE)) (RETURN NIL)))))) (DEFTYPEP SEQUENCE (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (TYPEP OBJECT 'SEQUENCE) (IF (EQ ELEMENT-TYPE '*) T (EVERY #'(LAMBDA (S) (TYPEP S ELEMENT-TYPE)) OBJECT)))) (DEFTYPEP MEMBER (&REST VALUES) (OBJECT) (MEMBER OBJECT VALUES)) (DEFTYPEP ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE '*)) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (ARRAYP OBJECT) (IF (EQ ELEMENT-TYPE '*) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS '*) T) ((TYPEP DIMS 'FIXNUM) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) 'FIXNUM) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL)))))))) (DEFTYPEP SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE '*)) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (XCL:SIMPLE-ARRAY-P OBJECT) (IF (EQ ELEMENT-TYPE '*) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS '*) T) ((TYPEP DIMS 'FIXNUM) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) 'FIXNUM) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL)))))))) (DEFTYPEP VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE '*)) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (VECTORP OBJECT) (IF (EQ ELEMENT-TYPE '*) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (DEFTYPEP SIMPLE-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-VECTOR-P OBJECT) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (DEFTYPEP COMPLEX (&OPTIONAL TYPE) (OBJECT) (AND (COMPLEXP OBJECT) (IF (EQ TYPE '*) T (AND (TYPEP (REALPART OBJECT) TYPE) (TYPEP (IMAGPART OBJECT) TYPE))))) (DEFTYPEP INTEGER (&OPTIONAL LOW HIGH) (OBJECT) (AND (INTEGERP OBJECT) (COND ((EQ LOW '*) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH '*) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT))))) (DEFTYPEP MOD (&OPTIONAL N) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ N '*) T (> N OBJECT)))) (DEFTYPEP SIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (IF (EQ S '*) T (LET ((BOUND (ASH 1 (1- S)))) (AND (>= OBJECT (- BOUND)) (> BOUND OBJECT)))))) (DEFTYPEP UNSIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ S '*) T (> (ASH 1 S) OBJECT)))) (DEFTYPEP RATIONAL (&OPTIONAL LOW HIGH) (OBJECT) (AND (RATIONALP OBJECT) (COND ((EQ LOW '*) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH '*) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT))))) (DEFTYPEP FLOAT (&OPTIONAL LOW HIGH) (OBJECT) (AND (FLOATP OBJECT) (COND ((EQ LOW '*) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH '*) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT))))) (DEFTYPEP STRING (&OPTIONAL SIZE) (OBJECT) (AND (STRINGP OBJECT) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (DEFTYPEP SIMPLE-STRING (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-STRING-P OBJECT) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (DEFTYPEP BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (BIT-VECTOR-P OBJECT) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (DEFTYPEP SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-BIT-VECTOR-P OBJECT) (IF (EQ SIZE '*) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE)))) (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") (IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER) (IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM) (IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT) (IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY) (IL:PUTPROPS IL:LISTP CMLTYPE CONS) (IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL) (IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY) (IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM) (IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE) (IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY) (IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE) (IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") (IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE) (IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE) (IL:* IL:|;;;| "Compiler options") (IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CMLUNDO b/sources/CMLUNDO new file mode 100644 index 00000000..2baf23ad --- /dev/null +++ b/sources/CMLUNDO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "16-May-90 14:54:01" IL:|{DSK}local>lde>lispcore>sources>CMLUNDO.;2| 30797 IL:|changes| IL:|to:| (IL:VARS IL:CMLUNDOCOMS) IL:|previous| IL:|date:| "29-Feb-88 19:40:15" IL:|{DSK}local>lde>lispcore>sources>CMLUNDO.;1| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CMLUNDOCOMS) (IL:RPAQQ IL:CMLUNDOCOMS ((IL:VARIABLES *IN-DEFINER*) (IL:FUNCTIONS NOHOOK UNDOABLY UNDOABLY-FMAKUNBOUND UNDOABLY-MAKUNBOUND UNDOABLY-SETF UNDOHOOK UNDOABLY-PSETF UNDOABLY-POP UNDOABLY-PUSH UNDOABLY-PUSHNEW UNDOABLY-REMF UNDOABLY-ROTATEF UNDOABLY-SHIFTF DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF UNDOABLY-INCF UNDOABLY-PROCLAIM) (IL:FUNCTIONS MAKE-UNDOABLE STOP-UNDOABLY) (IL:FUNCTIONS UNDOABLY-SETF-SYMBOL-FUNCTION UNDOABLY-SETF-MACRO-FUNCTION) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD ' UNDOABLY-SETF-SYMBOL-FUNCTION ' IL:UNDOABLY-SETF-SYMBOL-FUNCTION ) (IL:MOVD ' UNDOABLY-SETF-MACRO-FUNCTION ' UNDOABLY-SETF-MACRO-FUNCTION ))) (IL:ADDVARS (IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM) (POP . UNDOABLY-POP) (PSETF . UNDOABLY-PSETF) (PUSH . UNDOABLY-PUSH) (PUSHNEW . UNDOABLY-PUSHNEW) ((REMF) . UNDOABLY-REMF) (ROTATEF . UNDOABLY-ROTATEF) (SHIFTF . UNDOABLY-SHIFTF) (DECF . UNDOABLY-DECF) (INCF . UNDOABLY-INCF) (SET . UNDOABLY-SET-SYMBOL) (MAKUNBOUND . UNDOABLY-MAKUNBOUND) (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))) (IL:FUNCTIONS GET-UNDOABLE-SETF-METHOD UNDOABLY-SET-SYMBOL) (IL:FNS UNDOABLY-SETQ) (IL:SPECIAL-FORMS UNDOABLY UNDOABLY-SETQ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD ' UNDOABLY-SET-SYMBOL ' IL:UNDOABLY-SET-SYMBOL ))) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLUNDO) (IL:PROP :UNDOABLE-SETF-INVERSE SYMBOL-FUNCTION MACRO-FUNCTION) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA UNDOABLY-SETQ) (IL:NLAML) (IL:LAMA))))) (DEFVAR *IN-DEFINER* NIL) (DEFUN NOHOOK (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL)) (APPLY FN ARGS)) (DEFMACRO UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (WALK-FORM (IL:MKPROGN FORMS) :ENVIRONMENT ENV :WALK-FUNCTION #'(LAMBDA (X CONTEXT) (COND ((NOT (CONSP X)) X) ((NOT (SYMBOLP (CAR X))) X) (T (CASE (CAR X) ((SETQ SETQ SETF) (VALUES (IL:MKPROGN (WITH-COLLECTION (DO ((TAIL (CDR X) (CDDR TAIL))) ((NULL TAIL)) (COLLECT (IF (SYMBOLP (CAR TAIL)) (IF (VARIABLE-LEXICAL-P (CAR TAIL)) `(SETQ ,(CAR TAIL) ,(WALK-FORM-INTERNAL (CADR TAIL))) (PROGN (WARN "Variable ~S presumed special in UNDOABLY.. SETQ" (CAR TAIL)) `(UNDOABLY-SET-SYMBOL ',(CAR TAIL) ,(WALK-FORM-INTERNAL (CADR TAIL))))) (MULTIPLE-VALUE-BIND (FORMALS ACTUALS NEW-VALUE SETTER GETTER) (GET-UNDOABLE-SETF-METHOD (CAR TAIL)) `(,'LET* (,@(MAPCAR #'(LAMBDA (X Y) (LIST X (WALK-FORM-INTERNAL Y))) FORMALS ACTUALS) (,(WALK-FORM-INTERNAL (CAR NEW-VALUE)) ,(CADR TAIL))) ,SETTER))))))) T)) (STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X)) T)) (T (LET ((UNDONAME (CDR (MEMBER (CAR X) IL:LISPXFNS :TEST #'EQ)))) (IF UNDONAME (CONS UNDONAME (CDR X)) (IF (AND (OR (GET (CAR X) ':DEFINER-FOR) (GET (CAR X) 'IL:DEFINER-FOR)) (NOT *IN-DEFINER*)) (LET ((*IN-DEFINER* T)) (VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X)) T)) X)))))))))) (DEFUN UNDOABLY-FMAKUNBOUND (SYMBOL) (IL:/PUTD SYMBOL NIL) (IL:/REMPROP SYMBOL 'IL:MACRO-FN) (IL:/REMPROP SYMBOL 'IL:SPECIAL-FORM) (IL:/REMPROP SYMBOL 'IL:CODE) (IL:/REMPROP SYMBOL 'IL:EXPR) SYMBOL) (DEFUN UNDOABLY-MAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Make a symbol unbound.") (IL:SAVESET SYMBOL 'IL:NOBIND) (IL:* IL:\;  " unbound symbols are set to IL:NOBIND") (IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH) (IL:* IL:\;  "remove any constant entry") (IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL) (IL:* IL:\;  " left by PROCLAIM special") (IL:/REMPROP SYMBOL 'IL:GLOBALVAR) (IL:* IL:\; "") SYMBOL) (DEFMACRO UNDOABLY-SETF (PLACE NEW-VALUE &ENVIRONMENT ENV) "UNDOable version of SETF" (IL:* IL:|;;| "note that this is a \"one-shot\", in that (UNDOABLY (SETF (CDR (RPLACA X Y)) Z) will make the RPLACA undoable, but (UNDOABLY-SETF (CDR (RPLACA X Y)) Z) will not") (COND ((SYMBOLP PLACE) (IL:* IL:|;;| "assumes variable is not lexical !") `(UNDOABLY-SET-SYMBOL ',PLACE ,NEW-VALUE)) (T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD PLACE ENV) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) (,(CAR NEWVAL) ,NEW-VALUE)) ,SETTER))))) (DEFUN UNDOHOOK (FORM ENV &AUX (*APPLYHOOK* NIL)) (IF (ATOM FORM) (EVAL FORM ENV) (CASE (CAR FORM) ((SETQ SETQ SETF) (DO ((TAIL (CDR FORM)) VALUE) ((NULL TAIL) VALUE) (SETQ VALUE (IF (SYMBOLP (CAR TAIL)) (UNDOABLY-SET-SYMBOL (POP TAIL) (UNDOHOOK (POP TAIL) ENV) ENV) (EVAL (IL:* IL:|;;| "real cop-out , just to EVAL of making it undoable ") (MULTIPLE-VALUE-BIND (FORMALS VALS NEW-VALUE SETTER GETTER) (GET-UNDOABLE-SETF-METHOD (POP TAIL) ENV) `(,'LET* (,@(MAPCAR #'(LAMBDA (X Y) (LIST X (LIST 'UNDOABLY Y))) FORMALS VALS) (,(CAR NEW-VALUE) (UNDOABLY ,(POP TAIL)))) ,SETTER)) ENV))))) (STOP-UNDOABLY (IL:* IL:|;;| "special signal to not undo") (IL:\\EVAL-PROGN (CDR FORM) ENV)) (T (LET ((UNDONAME (CDR (MEMBER (CAR FORM) IL:LISPXFNS :TEST #'EQ)))) (IF UNDONAME (EVALHOOK (CONS UNDONAME (CDR FORM)) 'UNDOHOOK 'NOHOOK ENV) (EVALHOOK FORM 'UNDOHOOK 'NOHOOK ENV))))))) (DEFMACRO UNDOABLY-PSETF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "parallel version of UNDOABLY-SETF - simple minded version") (COND ((NULL ARGS) NIL) (T `(PROG1 NIL (UNDOABLY-SETF ,(POP ARGS) (PROG1 ,(POP ARGS) (UNDOABLY-PSETF ,@ARGS))))))) (DEFMACRO UNDOABLY-POP (PLACE &ENVIRONMENT ENV) (IF (SYMBOLP PLACE) `(PROG1 (CAR ,PLACE) (UNDOABLY-SETQ ,PLACE (CDR ,PLACE))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD PLACE ENV) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) ,(LIST (CAR NEWVAL) GETTER)) (PROG1 (CAR ,(CAR NEWVAL)) (SETQ ,(CAR NEWVAL) (CDR ,(CAR NEWVAL))) ,SETTER))))) (DEFMACRO UNDOABLY-PUSH (OBJ PLACE &ENVIRONMENT ENV) (IL:* IL:|;;| "Takes an object and a location holding a list. Conses the object onto PLACE returning then modified list.") (IF (SYMBOLP PLACE) `(UNDOABLY-SETQ ,PLACE (CONS ,OBJ ,PLACE)) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD PLACE ENV) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) (,(CAR NEWVAL) (CONS ,OBJ ,GETTER))) ,SETTER)))) (DEFMACRO UNDOABLY-PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV) (IF (SYMBOLP PLACE) `(UNDOABLY-SETQ ,PLACE (ADJOIN ,OBJ ,PLACE ,@KEYS)) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD PLACE ENV) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) (,(CAR NEWVAL) (ADJOIN ,OBJ ,GETTER ,@KEYS))) ,SETTER)))) (DEFMACRO UNDOABLY-REMF (PLACE INDICATOR &ENVIRONMENT ENV) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD PLACE ENV) (LET ((IND-TEMP (GENSYM)) (LOCAL1 (GENSYM)) (LOCAL2 (GENSYM))) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) (,(CAR NEWVAL) ,GETTER) (,IND-TEMP ,INDICATOR)) (DO ((,LOCAL1 ,(CAR NEWVAL) (CDDR ,LOCAL1)) (,LOCAL2 NIL ,LOCAL1)) ((ATOM ,LOCAL1) NIL) (COND ((ATOM (CDR ,LOCAL1)) (ERROR "Odd-length property list in REMF.")) ((EQ (CAR ,LOCAL1) ,IND-TEMP) (COND (,LOCAL2 (IL:/RPLACD (CDR ,LOCAL2) (CDDR ,LOCAL1)) (RETURN T)) (T (SETQ ,(CAR NEWVAL) (CDDR ,(CAR NEWVAL))) ,SETTER (RETURN T)))))))))) (DEFMACRO UNDOABLY-ROTATEF (&REST ARGS &ENVIRONMENT ENV) (COND ((NULL ARGS) NIL) ((NULL (CDR ARGS)) `(PROGN ,(CAR ARGS) NIL)) (T (DO ((A ARGS (CDR A)) (LET-LIST NIL) (SETF-LIST NIL) (NEXT-VAR NIL) (FIX-ME NIL)) ((ATOM A) (RPLACA FIX-ME NEXT-VAR) `(,'LET* ,(REVERSE LET-LIST) ,@(REVERSE SETF-LIST) NIL)) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD (CAR A) ENV) (DO ((D DUMMIES (CDR D)) (V VALS (CDR V))) ((NULL D)) (PUSH (LIST (CAR D) (CAR V)) LET-LIST)) (PUSH (LIST NEXT-VAR GETTER) LET-LIST) (UNLESS FIX-ME (SETQ FIX-ME (CAR LET-LIST))) (PUSH SETTER SETF-LIST) (SETQ NEXT-VAR (CAR NEWVAL))))))) (DEFMACRO UNDOABLY-SHIFTF (&REST ARGS &ENVIRONMENT ENV) (COND ((OR (NULL ARGS) (NULL (CDR ARGS))) (ERROR "SHIFTF needs at least two arguments")) (T (DO* ((A ARGS (CDR A)) (LET-LIST NIL) (SETF-LIST NIL) (RESULT (GENSYM)) (NEXT-VAR RESULT)) ((ATOM (CDR A)) (PUSH (LIST NEXT-VAR (CAR A)) LET-LIST) `(,'LET* ,(REVERSE LET-LIST) ,@(REVERSE SETF-LIST) ,RESULT)) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD (CAR A) ENV) (DO ((D DUMMIES (CDR D)) (V VALS (CDR V))) ((NULL D)) (PUSH (LIST (CAR D) (CAR V)) LET-LIST)) (PUSH (LIST NEXT-VAR GETTER) LET-LIST) (PUSH SETTER SETF-LIST) (SETQ NEXT-VAR (CAR NEWVAL))))))) (DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL DOC-STRING) (LET ((OTHER-ARGS NIL) (REST-ARG NIL)) (DO ((LL LAMBDA-LIST (CDR LL)) (ARG NIL)) ((NULL LL)) (SETQ ARG (CAR LL)) (COND ((EQ ARG '&OPTIONAL)) ((EQ ARG '&REST) (SETQ REST-ARG (CADR LL)) (RETURN NIL)) ((SYMBOLP ARG) (PUSH ARG OTHER-ARGS)) (T (PUSH (CAR ARG) OTHER-ARGS)))) (SETQ OTHER-ARGS (REVERSE OTHER-ARGS)) `(DEFMACRO ,NAME (SI::%$$MODIFY-MACRO-FORM ,@LAMBDA-LIST &ENVIRONMENT SI::%$$MODIFY-MACRO-ENVIRONMENT) ,DOC-STRING (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-UNDOABLE-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT) `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS) (,(CAR NEWVALS) ,,(IF REST-ARG `(LIST* ',FUNCTION GETTER ,@OTHER-ARGS ,REST-ARG) `(LIST ',FUNCTION GETTER ,@OTHER-ARGS)))) ,SETTER)))))) (DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF (&OPTIONAL (DELTA 1)) -) (DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-INCF (&OPTIONAL (DELTA 1)) +) (DEFUN UNDOABLY-PROCLAIM (PROCLAMATION) (IL:* IL:|;;| "Undoable version of PROCLAIM.") (WHEN (CONSP PROCLAMATION) (CASE (CAR PROCLAMATION) (SPECIAL (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X) T) (SETF (IL:VARIABLE-GLOBAL-P X) NIL) (SETF (CONSTANTP X) NIL)))) (GLOBAL (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (IL:VARIABLE-GLOBAL-P X) T) (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X) NIL) (SETF (CONSTANTP X) NIL)))) (SI::CONSTANT (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (CONSTANTP X) T) (SETF (IL:VARIABLE-GLOBAL-P X) NIL) (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X) NIL)))) (DECLARATION (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (DECL-SPECIFIER-P X) T)))) (NOTINLINE (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X) T)))) (INLINE (DOLIST (X (CDR PROCLAMATION)) (UNDOABLY (SETF (GLOBALLY-NOTINLINE-P X) NIL))))))) (DEFUN MAKE-UNDOABLE (FORM &OPTIONAL ENV) (LIST 'UNDOABLY FORM)) (DEFMACRO STOP-UNDOABLY (&REST FORMS) (IL:* IL:|;;| "evaluate forms -- inside UNDOABLY, stops transformation") (IL:MKPROGN FORMS)) (DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION) (IL:* IL:|;;|  "NOTE: If you change this version, be sure to change the not-undoable version on LLSYMBOL!") (IL:* IL:|;;| " undoable inverse of SYMBOL-FUNCTION") (IL:VIRGINFN SYMBOL T) (COND ((CONSP DEFINITION) (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.") (CASE (CAR DEFINITION) (:MACRO (UNDOABLY-SETF (MACRO-FUNCTION SYMBOL) (CDR DEFINITION))) (:SPECIAL-FORM (UNDOABLY-SETF (GET SYMBOL 'IL:SPECIAL-FORM) (CDR DEFINITION))) (T (IL:/PUTD SYMBOL DEFINITION T)))) (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR. This isn't quite like Lucid and Symbolics, but it will do for now.") ((AND (SYMBOLP DEFINITION) (NOT (NULL DEFINITION))) (IL:/PUTD SYMBOL (IL:GETD DEFINITION) T)) (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure. In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.") (T (IL:/PUTD SYMBOL DEFINITION T))) (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions. We only remove the ones that could come from DEFMACRO.") (UNLESS (OR (NULL DEFINITION) (AND (CONSP DEFINITION) (EQ (CAR DEFINITION) :MACRO))) (IL:/REMPROP SYMBOL 'IL:MACRO-FN)) DEFINITION) (DEFUN UNDOABLY-SETF-MACRO-FUNCTION (X BODY) (IL:* IL:|;;| "undoable setf of macro-function") (IL:* IL:|;;|  "NOTE: If you change this, be sure to change the not-undoable version on CMLMACROS!") (PROG1 (UNDOABLY-SETF (GET X 'IL:MACRO-FN) BODY) (AND (IL:GETD X) (CASE (IL:ARGTYPE X) ((1 3) (IL:* IL:\;  "Leave Interlisp nlambda definition alone") ) (OTHERWISE (IL:/PUTD X NIL)))))) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:MOVD 'UNDOABLY-SETF-SYMBOL-FUNCTION 'IL:UNDOABLY-SETF-SYMBOL-FUNCTION) (IL:MOVD 'UNDOABLY-SETF-MACRO-FUNCTION 'UNDOABLY-SETF-MACRO-FUNCTION) ) (IL:ADDTOVAR IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM) (POP . UNDOABLY-POP) (PSETF . UNDOABLY-PSETF) (PUSH . UNDOABLY-PUSH) (PUSHNEW . UNDOABLY-PUSHNEW) ((REMF) . UNDOABLY-REMF) (ROTATEF . UNDOABLY-ROTATEF) (SHIFTF . UNDOABLY-SHIFTF) (DECF . UNDOABLY-DECF) (INCF . UNDOABLY-INCF) (SET . UNDOABLY-SET-SYMBOL) (MAKUNBOUND . UNDOABLY-MAKUNBOUND) (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND)) (DEFUN GET-UNDOABLE-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT &AUX TEMP) (COND ((SYMBOLP FORM) (VALUES NIL NIL (LIST (SETQ TEMP (GENSYM))) `(IL:UNDOABLY-SET-SYMBOL ',FORM ,TEMP) FORM)) ((NOT (CONSP FORM)) (CL::SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "always expand local macros") (GET-UNDOABLE-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (GET (CAR FORM) ':UNDOABLE-SETF-INVERSE)) (IL:* IL:|;;| "found a special undoable property -- use it") (CL::GET-SIMPLE-SETF-METHOD FORM TEMP)) (T (BLOCK DONE (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (COND ((SETQ TEMP (OR (GET (CAR FORM) ':SETF-INVERSE) (GET (CAR FORM) 'IL:SETF-INVERSE) (GET (CAR FORM) 'IL:SETFN))) (CL::GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) ':SHARED-SETF-INVERSE)) (CL::GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) ':SETF-METHOD-EXPANDER) (GET (CAR FORM) 'IL:SETF-METHOD-EXPANDER))) (FUNCALL TEMP FORM ENVIRONMENT)) (T (MULTIPLE-VALUE-BIND (MAC MORE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND MORE (NOT (EQ MAC FORM))) (RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD MAC ENVIRONMENT)) (ERROR "~S is not a known location specifier for SETF." (CAR FORM)))))) (IL:* IL:|;;|  "this is lexically correct, but doesn't work in bytecompiler, interlisp") (IL:* IL:|;;| "(cl:values dummies vals newval `(cl:labels ((undostore (,@newval) (undosave (list #'undostore ,getter)) ,setter)) (undostore ,@newval)) getter)") (IL:* IL:|;;| "so, instead we do the following, which binds the dummies too so that there are no free references. LABELS is used because the thing saved on the undo list is also saved when the UNDO is undefined.") (IL:* IL:|;;| " ") (VALUES DUMMIES VALS NEWVAL `(IL:COMMON-LISP (LABELS ((UNDOSTORE (,@DUMMIES ,@NEWVAL) (IL:UNDOSAVE (LIST #'UNDOSTORE ,@DUMMIES ,GETTER)) ,SETTER)) (UNDOSTORE ,@DUMMIES ,@NEWVAL))) GETTER)))))) (DEFUN UNDOABLY-SET-SYMBOL (SYMBOL VALUE &OPTIONAL ENVIRONMENT) (BLOCK UNDOABLY-SET-SYMBOL (WHEN ENVIRONMENT (IL:* IL:|;;|  "This function only saves undo info when there is no lexical binding for the variable.") (SETQ ENVIRONMENT (IL:ENVIRONMENT-VARS ENVIRONMENT)) (LOOP (IF (NULL ENVIRONMENT) (RETURN NIL)) (IF (EQ SYMBOL (CAR ENVIRONMENT)) (IL:* IL:|;;| "found a binding for this symbol") (PROGN (IF (EQ (CAR (SETQ ENVIRONMENT (CDR ENVIRONMENT))) IL:*SPECIAL-BINDING-MARK*) (IL:* IL:|;;|  "it is a special binding, or a mark that we are using the special value") (RETURN NIL) (IL:* IL:\; "return from WHILE") ) (RPLACA ENVIRONMENT VALUE) (IL:* IL:|;;| "smash new value in") (RETURN-FROM UNDOABLY-SET-SYMBOL VALUE)) (SETQ ENVIRONMENT (CDDR ENVIRONMENT))))) (IL:* IL:|;;| "no environment, or not found. ") (LET ((VP (IL:\\STKSCAN SYMBOL))) (COND ((EQ (IL:\\HILOC VP) IL:\\STACKHI) (IL:\\PUTBASEPTR VP 0 VALUE)) (T (WHEN (CONSTANTP SYMBOL) (UNLESS (EQL VALUE (IL:GETTOPVAL SYMBOL)) (CERROR "Go ahead and set it" "Attempt to set constant ~S to ~S" SYMBOL VALUE))) (LET ((OLDVAL (IL:\\GETBASEPTR VP 0)) TEM) (UNLESS (OR (NULL IL:LISPXHIST) (AND (SETQ TEM (SOME #'(LAMBDA (X) (AND (CONSP X) (EQ (CAR X) 'IL:/SETTOPVAL) (EQ (CADR X) SYMBOL))) (IL:LISTGET1 IL:LISPXHIST 'IL:SIDE))) (NOT (TAILP TEM (IL:LISTP IL:UNDOSIDE0))))) (IL:* IL:|;;| "special optimization from Interlisp: don't save more than one assignment of the same variable in the same event(!)") (IL:UNDOSAVE (LIST 'IL:/SETTOPVAL SYMBOL OLDVAL)))) (IL:\\RPLPTR VP 0 VALUE)))))) (IL:DEFINEQ (undoably-setq (il:nlambda varvalue (il:* il:\; "Edited 8-Oct-87 18:54 by jop") (il:* il:\; "Interlisp version") (undoably-set-symbol (car varvalue) (il:\\evprog1 (cdr varvalue))))) ) (DEFINE-SPECIAL-FORM UNDOABLY (&REST FORMS &ENVIRONMENT ENV) (LOOP (IF (NULL (CDR FORMS)) (RETURN (UNDOHOOK (CAR FORMS) ENV)) (UNDOHOOK (POP FORMS) ENV)))) (DEFINE-SPECIAL-FORM UNDOABLY-SETQ (&REST TAIL &ENVIRONMENT ENV) (LET (VALUE) (LOOP (IF (NULL TAIL) (RETURN NIL) (SETQ VALUE (UNDOABLY-SET-SYMBOL (POP TAIL) (EVAL (POP TAIL) ENV) ENV)))) VALUE)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:MOVD 'UNDOABLY-SET-SYMBOL 'IL:UNDOABLY-SET-SYMBOL) ) (IL:PUTPROPS IL:CMLUNDO IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:CMLUNDO IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS SYMBOL-FUNCTION :UNDOABLE-SETF-INVERSE UNDOABLY-SETF-SYMBOL-FUNCTION) (IL:PUTPROPS MACRO-FUNCTION :UNDOABLE-SETF-INVERSE UNDOABLY-SETF-MACRO-FUNCTION) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA UNDOABLY-SETQ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (29112 29437 (UNDOABLY-SETQ 29125 . 29435))))) IL:STOP \ No newline at end of file diff --git a/sources/CMLWALK b/sources/CMLWALK new file mode 100644 index 00000000..96f2d2b8 --- /dev/null +++ b/sources/CMLWALK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:56:15" {DSK}local>lde>lispcore>sources>CMLWALK.;2 29711 changes to%: (VARS CMLWALKCOMS) previous date%: "17-Jun-87 17:43:58" {DSK}local>lde>lispcore>sources>CMLWALK.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT CMLWALKCOMS) (RPAQQ CMLWALKCOMS [(FUNCTIONS XCL:ONCE-ONLY) (* ;  "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.") (VARIABLES *WALK-FUNCTION* *WALK-FORM* *DECLARATIONS* *LEXICAL-VARIABLES* *ENVIRONMENT* *WALK-COPY*) (FUNCTIONS WITH-NEW-CONTOUR NOTE-LEXICAL-BINDING NOTE-DECLARATION) (FUNCTIONS VARIABLE-SPECIAL-P VARIABLE-LEXICAL-P GET-WALKER-TEMPLATE) (FUNCTIONS WALK-FORM) (FNS WALK-FORM-INTERNAL WALK-TEMPLATE WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-LIST WALK-RECONS) (FUNCTIONS WALK-RELIST*) (FNS WALK-DECLARATIONS WALK-ARGLIST WALK-LAMBDA) (COMS (PROP WALKER-TEMPLATE CL:COMPILER-LET) (FNS WALK-COMPILER-LET) (PROP WALKER-TEMPLATE DECLARE) (FNS WALK-UNEXPECTED-DECLARE) (PROP WALKER-TEMPLATE LET PROG LET* PROG*) (FNS WALK-LET WALK-LET* WALK-LET/LET*) (PROP WALKER-TEMPLATE CL:TAGBODY) (FNS WALK-TAGBODY) (PROP WALKER-TEMPLATE FUNCTION CL:FUNCTION GO CL:IF CL:MULTIPLE-VALUE-CALL CL:MULTIPLE-VALUE-PROG1 PROGN CL:PROGV QUOTE CL:RETURN-FROM RETURN CL:SETQ CL:BLOCK CL:CATCH CL:EVAL-WHEN THE CL:THROW CL:UNWIND-PROTECT LOAD-TIME-EVAL COND CL:UNWIND-PROTECT SETQ AND OR)) (COMS (* ;; "for Interlisp") (PROP WALKER-TEMPLATE RPAQ? RPAQ XNLSETQ ERSETQ NLSETQ RESETVARS)) (PROP FILETYPE CMLWALK) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE WALK-FORM-INTERNAL]) (DEFMACRO XCL:ONCE-ONLY (XCL::VARS &BODY XCL::BODY) (* ;;; "ONCE-ONLY assures that the forms given as vars are evaluated in the proper order, once only. Used in the body of macro definitions. Taken from Zeta Lisp.") [LET* [(XCL::GENSYM-VAR (CL:GENSYM)) (XCL::RUN-TIME-VARS (CL:GENSYM)) (XCL::RUN-TIME-VALS (CL:GENSYM)) (XCL::EXPAND-TIME-VAL-FORMS (FOR XCL::VAR IN XCL::VARS COLLECT `(CL:IF (OR (CL:SYMBOLP ,XCL::VAR) (CL:CONSTANTP ,XCL::VAR)) ,XCL::VAR (LET ((,XCL::GENSYM-VAR (CL:GENSYM))) (CL:PUSH ,XCL::GENSYM-VAR ,XCL::RUN-TIME-VARS) (CL:PUSH ,XCL::VAR ,XCL::RUN-TIME-VALS) ,XCL::GENSYM-VAR))] `(LET* [,XCL::RUN-TIME-VARS ,XCL::RUN-TIME-VALS (XCL::WRAPPED-BODY (LET ,(FOR XCL::VAR IN XCL::VARS AS XCL::EXPAND-TIME-VAL-FORM IN XCL::EXPAND-TIME-VAL-FORMS COLLECT (LIST XCL::VAR XCL::EXPAND-TIME-VAL-FORM)) ,@XCL::BODY] `(LET ,(FOR XCL::RUN-TIME-VAR IN (CL:REVERSE XCL::RUN-TIME-VARS) AS XCL::RUN-TIME-VAL IN (CL:REVERSE XCL::RUN-TIME-VALS) COLLECT (LIST XCL::RUN-TIME-VAR XCL::RUN-TIME-VAL) ) ,XCL::WRAPPED-BODY]) (* ; "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.") (CL:DEFVAR *WALK-FUNCTION* NIL "the function being called on each sub-form in the code-walker") (CL:DEFVAR *WALK-FORM* "When the first argument to the IF template in the code-walker is a list, it will be evaluated with *walk-form* bound to the form currently being walked." ) (CL:DEFVAR *DECLARATIONS* "a list of the declarations currently in effect while codewalking") (CL:DEFVAR *LEXICAL-VARIABLES* NIL (* ;  "used in walker to hold list of lexical variables available") ) (CL:DEFVAR *ENVIRONMENT* "while codewalking, this is the lexical environment as far as macros are concerned") (CL:DEFVAR *WALK-COPY* "while walking, this is true if we are making a copy of the expresion being walked") (DEFMACRO WITH-NEW-CONTOUR (&BODY BODY) (* ;; "WITH-NEW-CONTOUR is used to enter a new lexical binding contour which inherits from the exisiting one. Using WITH-NEW-CONTOUR is often overkill: It would suffice for the the walker to rebind *LEXICAL-VARIABLES* and *DECLARATIONS* when walking LET and rebind *ENVIRONMENT* and *DECLARATIONS* when walking MACROLET etc. WITH-NEW-CONTOUR is much more convenient and just as correct. *") `(LET ((*DECLARATIONS* NIL) (*LEXICAL-VARIABLES* *LEXICAL-VARIABLES*) (*ENVIRONMENT* *ENVIRONMENT*)) ,@BODY)) (DEFMACRO NOTE-LEXICAL-BINDING (THING) `(CL:PUSH ,THING *LEXICAL-VARIABLES*)) (DEFMACRO NOTE-DECLARATION (CL:DECLARATION) `(CL:PUSH ,CL:DECLARATION *DECLARATIONS*)) (CL:DEFUN VARIABLE-SPECIAL-P (VAR)  (* lmm "27-May-86 15:42") (OR (for DECL in *DECLARATIONS* do (AND (EQ (CAR DECL) 'CL:SPECIAL) (FMEMB VAR (CDR DECL)) (RETURN T))) (VARIABLE-GLOBALLY-SPECIAL-P VAR))) (CL:DEFUN VARIABLE-LEXICAL-P (VAR)  (* lmm "11-Apr-86 10:59") (AND (NOT (VARIABLE-SPECIAL-P VAR)) (CL:MEMBER VAR *LEXICAL-VARIABLES* :TEST (FUNCTION EQ)))) (CL:DEFUN GET-WALKER-TEMPLATE (X)  (* lmm "24-May-86 14:48") (CL:IF (NOT (CL:SYMBOLP X)) '(CL:LAMBDA :REPEAT (:EVAL)) (GET X 'WALKER-TEMPLATE))) (CL:DEFUN WALK-FORM (FORM &KEY ((:DECLARATIONS *DECLARATIONS*) NIL) ((:LEXICAL-VARIABLES *LEXICAL-VARIABLES*) NIL) ((:ENVIRONMENT *ENVIRONMENT*) NIL) ((:WALK-FUNCTION *WALK-FUNCTION*) (FUNCTION (CL:LAMBDA (X IGNORE) IGNORE X))) ((:COPY *WALK-COPY*) T)) "Walk FORM, expanding all macros, calling :WALK-FUNCTION on each subfof :COPY is true (default), will return the expansion" (WALK-FORM-INTERNAL FORM ':EVAL)) (DEFINEQ (WALK-FORM-INTERNAL (CL:LAMBDA (FORM CONTEXT &AUX FN TEMPLATE WALK-NO-MORE-P NEWFORM) (* lmm "24-May-86 20:28") (* ;; "WALK-FORM-INTERNAL is the main driving function for the code walker. It takes a form and the current context and walks the form calling itself or the appropriate template recursively.") (CL:MULTIPLE-VALUE-SETQ (NEWFORM WALK-NO-MORE-P) (CL:FUNCALL *WALK-FUNCTION* FORM CONTEXT)) (COND (WALK-NO-MORE-P NEWFORM) ((NOT (EQ FORM NEWFORM)) (WALK-FORM-INTERNAL NEWFORM CONTEXT)) ((NOT (CL:CONSP FORM)) FORM) ((NOT (CL:SYMBOLP (CAR FORM))) (WALK-TEMPLATE FORM '(:CALL :REPEAT (:EVAL)) CONTEXT)) ((SETQ TEMPLATE (GET-WALKER-TEMPLATE (CAR FORM))) (CL:IF (CL:SYMBOLP TEMPLATE) (CL:FUNCALL TEMPLATE FORM CONTEXT) (WALK-TEMPLATE FORM TEMPLATE CONTEXT))) ((NEQ FORM (SETQ FORM (CL:MACROEXPAND-1 FORM *ENVIRONMENT*))) (WALK-FORM-INTERNAL FORM CONTEXT)) (T  (* ;; "Otherwise, walk the form as if its just a standard function call using a template for standard function call.") (WALK-TEMPLATE FORM '(:CALL :REPEAT (:EVAL)) CONTEXT))))) (WALK-TEMPLATE (CL:LAMBDA (FORM TEMPLATE CONTEXT) (* lmm "24-May-86 16:43") (CL:IF (CL:ATOM TEMPLATE) (CL:ECASE TEMPLATE ((CALL :CALL) (if (CL:CONSP FORM) then (WALK-LAMBDA FORM NIL) else FORM)) ((QUOTE NIL PPE :ERROR) FORM) ((:EVAL EVAL :FUNCTION FUNCTION :TEST TEST :EFFECT EFFECT :RETURN RETURN) (WALK-FORM-INTERNAL FORM ':EVAL)) ((SET :SET) (WALK-FORM-INTERNAL FORM ':SET)) (CL:LAMBDA (WALK-LAMBDA FORM CONTEXT))) (CASE (CAR TEMPLATE) (CL:IF (LET ((*WALK-FORM* FORM)) (WALK-TEMPLATE FORM (COND ((CL:IF (LISTP (CL:SECOND TEMPLATE)) (CL:EVAL (CL:SECOND TEMPLATE)) (CL:FUNCALL (CL:SECOND TEMPLATE) FORM)) (CL:THIRD TEMPLATE)) (T (CL:FOURTH TEMPLATE))) CONTEXT))) ((REPEAT :REPEAT) (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE) (CL:NTHCDR (- (CL:LENGTH FORM) (CL:LENGTH (CDDR TEMPLATE))) FORM) CONTEXT)) (T (COND ((CL:ATOM FORM) FORM) (T (WALK-RECONS FORM (WALK-TEMPLATE (CAR FORM) (CAR TEMPLATE) CONTEXT) (WALK-TEMPLATE (CDR FORM) (CDR TEMPLATE) CONTEXT))))))))) (WALK-TEMPLATE-HANDLE-REPEAT (CL:LAMBDA (FORM TEMPLATE STOP-FORM CONTEXT) (* lmm "11-Apr-86 12:05") (CL:IF (EQ FORM STOP-FORM) (WALK-TEMPLATE FORM (CDR TEMPLATE) CONTEXT) (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE) STOP-FORM CONTEXT)))) (WALK-TEMPLATE-HANDLE-REPEAT-1 (CL:LAMBDA (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM CONTEXT) (* lmm "24-May-86 16:43") (COND ((NULL FORM) NIL) ((EQ FORM STOP-FORM) (CL:IF (NULL REPEAT-TEMPLATE) (WALK-TEMPLATE STOP-FORM (CDR TEMPLATE) CONTEXT) (CL:ERROR "While handling repeat: ~%%~Ran into stop while still in repeat template."))) ((NULL REPEAT-TEMPLATE) (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE) STOP-FORM CONTEXT)) (T (WALK-RECONS FORM (WALK-TEMPLATE (CAR FORM) (CAR REPEAT-TEMPLATE) CONTEXT) (WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM) TEMPLATE (CDR REPEAT-TEMPLATE) STOP-FORM CONTEXT)))))) (WALK-LIST (LAMBDA (LIST FN) (* lmm "24-May-86 16:43") (* copy list walking each element) (CL:IF LIST (WALK-RECONS LIST (CL:FUNCALL FN (CAR LIST)) (WALK-LIST (CDR LIST) FN))))) (WALK-RECONS (CL:LAMBDA (X CAR CDR) (* lmm "24-May-86 16:43") (CL:IF *WALK-COPY* (CL:IF (OR (NOT (EQ (CAR X) CAR)) (NOT (EQ (CDR X) CDR))) (CONS CAR CDR) X) NIL))) ) (DEFMACRO WALK-RELIST* (X FIRST &REST CL:REST) (CL:IF CL:REST `(WALK-RECONS ,X ,FIRST (WALK-RELIST* (CDR ,X) ,@CL:REST)) FIRST)) (DEFINEQ (WALK-DECLARATIONS (CL:LAMBDA (BODY FN &OPTIONAL DOC-STRING-P DECLARATIONS &AUX (FORM (CAR BODY))) (* lmm "18-Jun-86 14:35") (* skips over declarations) (COND ((AND (STRINGP FORM) (* might be a doc string *) (CDR BODY) (* isn't the returned value *) (NULL DOC-STRING-P) (* no doc string yet *) (NULL DECLARATIONS)) (* no declarations yet *) (WALK-RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY) FN T))) ((AND (LISTP FORM) (EQ (CAR FORM) 'DECLARE)) (* Got a real declaration. Record it, look for more.  *) (CL:DOLIST (CL:DECLARATION (CDR FORM)) (NOTE-DECLARATION CL:DECLARATION) (CL:PUSH CL:DECLARATION DECLARATIONS)) (WALK-RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY) FN DOC-STRING-P DECLARATIONS))) ((AND (CL:CONSP FORM) (NULL (GET-WALKER-TEMPLATE (CAR FORM))) (NOT (EQ FORM (SETQ FORM (CL:MACROEXPAND-1 FORM *ENVIRONMENT*))))) (* * When we macroexpanded this form we got something else back.  Maybe this is a macro which expanded into a declare? Recurse to find out.) (WALK-DECLARATIONS (CONS FORM (CDR BODY)) FN DOC-STRING-P DECLARATIONS)) (T (* Now that we have walked and recorded the declarations, call the function our  caller provided to expand the body. We call that function rather than passing  the real-body back, because we are RECONSING up the new body.) (CL:FUNCALL FN BODY))))) (WALK-ARGLIST (CL:LAMBDA (ARGLIST CONTEXT &OPTIONAL DESTRUCTURINGP &AUX ARG) (* lmm "24-May-86 16:44") (COND ((NULL ARGLIST) NIL) ((CL:SYMBOLP (CL:SETQ ARG (CAR ARGLIST))) (OR (CL:MEMBER ARG CL:LAMBDA-LIST-KEYWORDS :TEST (FUNCTION EQ)) (NOTE-LEXICAL-BINDING ARG)) (WALK-RECONS ARGLIST ARG (WALK-ARGLIST (CDR ARGLIST) CONTEXT (AND DESTRUCTURINGP (NOT (CL:MEMBER ARG CL:LAMBDA-LIST-KEYWORDS :TEST (FUNCTION EQ))))))) ((CL:CONSP ARG) (PROG1 (CL:IF DESTRUCTURINGP (WALK-ARGLIST ARG CONTEXT DESTRUCTURINGP) (WALK-RECONS ARGLIST (WALK-RELIST* ARG (CAR ARG) (WALK-FORM-INTERNAL (CADR ARG) ':EVAL) (CDDR ARG)) (WALK-ARGLIST (CDR ARGLIST) CONTEXT NIL))) (CL:IF (CL:SYMBOLP (CAR ARG)) (NOTE-LEXICAL-BINDING (CAR ARG)) (NOTE-LEXICAL-BINDING (CADAR ARG))) (OR (NULL (CDDR ARG)) (NOT (CL:SYMBOLP (CADDR ARG))) (NOTE-LEXICAL-BINDING ARG)))) (T (CL:ERROR "Can't understand something in the arglist ~S" ARGLIST))))) (WALK-LAMBDA (CL:LAMBDA (FORM CONTEXT) (* lmm "24-May-86 16:44") (WITH-NEW-CONTOUR (LET* ((ARGLIST (CADR FORM)) (BODY (CDDR FORM)) (WALKED-ARGLIST NIL) (WALKED-BODY (WALK-DECLARATIONS BODY (FUNCTION (CL:LAMBDA (REAL-BODY) (CL:SETQ WALKED-ARGLIST (WALK-ARGLIST ARGLIST CONTEXT )) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))) ))) (WALK-RELIST* FORM (CAR FORM) WALKED-ARGLIST WALKED-BODY))))) ) (PUTPROPS CL:COMPILER-LET WALKER-TEMPLATE WALK-COMPILER-LET) (DEFINEQ (WALK-COMPILER-LET (CL:LAMBDA (FORM CONTEXT) (* gbn " 7-Aug-86 18:21") (* ;  "bind the variables, but then return the COMPILER-LET") (LET ((VARS (CL:MAPCAR (FUNCTION (LAMBDA (X) (CL:IF (CL:CONSP X) (CAR X) X))) (CADR FORM))) (VALS (CL:MAPCAR (FUNCTION (CL:LAMBDA (X) (CL:IF (CL:CONSP X) (CL:EVAL (CADR X)) NIL))) (CADR FORM)))) (CL:PROGV VARS VALS (WALK-TEMPLATE FORM '(NIL NIL :REPEAT (:EVAL) :RETURN) CONTEXT))))) ) (PUTPROPS DECLARE WALKER-TEMPLATE WALK-UNEXPECTED-DECLARE) (DEFINEQ (WALK-UNEXPECTED-DECLARE (CL:LAMBDA (FORM CONTEXT) (* lmm "24-May-86 22:27") (DECLARE (IGNORE CONTEXT)) (CL:WARN "Encountered declare ~S in a place where a declare was not expected." FORM) FORM)) ) (PUTPROPS LET WALKER-TEMPLATE WALK-LET) (PUTPROPS PROG WALKER-TEMPLATE WALK-LET) (PUTPROPS LET* WALKER-TEMPLATE WALK-LET*) (PUTPROPS PROG* WALKER-TEMPLATE WALK-LET*) (DEFINEQ (WALK-LET (CL:LAMBDA (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT NIL))) (WALK-LET* (CL:LAMBDA (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT T))) (WALK-LET/LET* (CL:LAMBDA (FORM CONTEXT SEQUENTIALP) (* lmm "24-May-86 16:44") (LET ((OLD-DECLARATIONS *DECLARATIONS*) (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*)) (WITH-NEW-CONTOUR (LET* ((LET/LET* (CAR FORM)) (BINDINGS (CADR FORM)) (BODY (CDDR FORM)) WALKED-BINDINGS (WALKED-BODY (WALK-DECLARATIONS BODY (FUNCTION (CL:LAMBDA (REAL-BODY) (CL:SETQ WALKED-BINDINGS (WALK-LIST BINDINGS (FUNCTION (LAMBDA (BINDING) (CL:IF (CL:SYMBOLP BINDING) (PROG1 BINDING (NOTE-LEXICAL-BINDING BINDING)) (PROG1 (LET ((*DECLARATIONS* OLD-DECLARATIONS) (*LEXICAL-VARIABLES* (CL:IF SEQUENTIALP *LEXICAL-VARIABLES* OLD-LEXICAL-VARIABLES) )) (WALK-RELIST* BINDING (CAR BINDING) (WALK-FORM-INTERNAL (CADR BINDING) CONTEXT) (CDDR BINDING))) (NOTE-LEXICAL-BINDING (CAR BINDING)) )))))) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT)))))) (WALK-RELIST* FORM LET/LET* WALKED-BINDINGS WALKED-BODY)))))) ) (PUTPROPS CL:TAGBODY WALKER-TEMPLATE WALK-TAGBODY) (DEFINEQ (WALK-TAGBODY (CL:LAMBDA (FORM CONTEXT) (* lmm "24-May-86 16:44") (WALK-RECONS FORM (CAR FORM) (WALK-LIST (CDR FORM) (FUNCTION (LAMBDA (X) (WALK-FORM-INTERNAL X (CL:IF (CL:SYMBOLP X) 'QUOTE CONTEXT)))))))) ) (PUTPROPS FUNCTION WALKER-TEMPLATE (NIL :CALL)) (PUTPROPS CL:FUNCTION WALKER-TEMPLATE (NIL :CALL)) (PUTPROPS GO WALKER-TEMPLATE (NIL NIL)) (PUTPROPS CL:IF WALKER-TEMPLATE (NIL :TEST :RETURN :RETURN)) (PUTPROPS CL:MULTIPLE-VALUE-CALL WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL))) (PUTPROPS CL:MULTIPLE-VALUE-PROG1 WALKER-TEMPLATE (NIL :RETURN :REPEAT (:EVAL))) (PUTPROPS PROGN WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (PUTPROPS CL:PROGV WALKER-TEMPLATE (NIL :EVAL :EVAL :REPEAT (:EVAL))) (PUTPROPS QUOTE WALKER-TEMPLATE (NIL QUOTE)) (PUTPROPS CL:RETURN-FROM WALKER-TEMPLATE (NIL NIL :EVAL)) (PUTPROPS RETURN WALKER-TEMPLATE (NIL :EVAL)) (PUTPROPS CL:SETQ WALKER-TEMPLATE (NIL :REPEAT (:SET :EVAL))) (PUTPROPS CL:BLOCK WALKER-TEMPLATE (NIL NIL :REPEAT (:EVAL))) (PUTPROPS CL:CATCH WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL))) (PUTPROPS CL:EVAL-WHEN WALKER-TEMPLATE (NIL NIL :REPEAT (:EVAL))) (PUTPROPS THE WALKER-TEMPLATE (NIL NIL :EVAL)) (PUTPROPS CL:THROW WALKER-TEMPLATE (NIL :EVAL :EVAL)) (PUTPROPS CL:UNWIND-PROTECT WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL))) (PUTPROPS LOAD-TIME-EVAL WALKER-TEMPLATE (NIL :EVAL)) (PUTPROPS COND WALKER-TEMPLATE [NIL :REPEAT ((:REPEAT (:EVAL]) (PUTPROPS CL:UNWIND-PROTECT WALKER-TEMPLATE (NIL :EVAL :REPEAT (:EVAL))) (PUTPROPS SETQ WALKER-TEMPLATE (NIL :SET :EVAL)) (PUTPROPS AND WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (PUTPROPS OR WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (* ;; "for Interlisp") (PUTPROPS RPAQ? WALKER-TEMPLATE (NIL :SET :EVAL)) (PUTPROPS RPAQ WALKER-TEMPLATE (NIL :SET :EVAL)) (PUTPROPS XNLSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (PUTPROPS ERSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (PUTPROPS NLSETQ WALKER-TEMPLATE (NIL :REPEAT (:EVAL))) (PUTPROPS RESETVARS WALKER-TEMPLATE WALK-LET) (PUTPROPS CMLWALK FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE WALK-FORM-INTERNAL) ) (PRETTYCOMPRINT CMLWALKCOMS) (RPAQQ CMLWALKCOMS [(FUNCTIONS XCL:ONCE-ONLY) (* ;  "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.") (VARIABLES *WALK-FUNCTION* *WALK-FORM* *DECLARATIONS* *LEXICAL-VARIABLES* *ENVIRONMENT* *WALK-COPY*) (FUNCTIONS WITH-NEW-CONTOUR NOTE-LEXICAL-BINDING NOTE-DECLARATION) (FUNCTIONS VARIABLE-SPECIAL-P VARIABLE-LEXICAL-P GET-WALKER-TEMPLATE) (FUNCTIONS WALK-FORM) (FNS WALK-FORM-INTERNAL WALK-TEMPLATE WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-LIST WALK-RECONS) (FUNCTIONS WALK-RELIST*) (FNS WALK-DECLARATIONS WALK-ARGLIST WALK-LAMBDA) (COMS (PROP WALKER-TEMPLATE CL:COMPILER-LET) (FNS WALK-COMPILER-LET) (PROP WALKER-TEMPLATE DECLARE) (FNS WALK-UNEXPECTED-DECLARE) (PROP WALKER-TEMPLATE LET PROG LET* PROG*) (FNS WALK-LET WALK-LET* WALK-LET/LET*) (PROP WALKER-TEMPLATE CL:TAGBODY) (FNS WALK-TAGBODY) (PROP WALKER-TEMPLATE FUNCTION CL:FUNCTION GO CL:IF CL:MULTIPLE-VALUE-CALL CL:MULTIPLE-VALUE-PROG1 PROGN CL:PROGV QUOTE CL:RETURN-FROM RETURN CL:SETQ CL:BLOCK CL:CATCH CL:EVAL-WHEN THE CL:THROW CL:UNWIND-PROTECT LOAD-TIME-EVAL COND CL:UNWIND-PROTECT SETQ AND OR)) (COMS (* ;; "for Interlisp") (PROP WALKER-TEMPLATE RPAQ? RPAQ XNLSETQ ERSETQ NLSETQ RESETVARS)) (PROP FILETYPE CMLWALK) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT) ) (PUTPROPS CMLWALK COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8262 14412 (WALK-FORM-INTERNAL 8272 . 9743) (WALK-TEMPLATE 9745 . 12120) ( WALK-TEMPLATE-HANDLE-REPEAT 12122 . 12497) (WALK-TEMPLATE-HANDLE-REPEAT-1 12499 . 13602) (WALK-LIST 13604 . 13965) (WALK-RECONS 13967 . 14410)) (14610 19654 (WALK-DECLARATIONS 14620 . 16728) ( WALK-ARGLIST 16730 . 18511) (WALK-LAMBDA 18513 . 19652)) (19725 20773 (WALK-COMPILER-LET 19735 . 20771 )) (20842 21127 (WALK-UNEXPECTED-DECLARE 20852 . 21125)) (21330 24127 (WALK-LET 21340 . 21429) ( WALK-LET* 21431 . 21519) (WALK-LET/LET* 21521 . 24125)) (24188 24611 (WALK-TAGBODY 24198 . 24609))))) STOP \ No newline at end of file diff --git a/sources/COMMENT b/sources/COMMENT new file mode 100644 index 00000000..d3494f26 --- /dev/null +++ b/sources/COMMENT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:57:24" {DSK}local>lde>lispcore>sources>COMMENT.;2 850 changes to%: (VARS COMMENTCOMS) previous date%: "14-Oct-86 12:24:10" {DSK}local>lde>lispcore>sources>COMMENT.;1) (* ; " Copyright (c) 1983, 1984, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1983 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 COMMENTCOMS) (RPAQQ COMMENTCOMS ((FILES FONTPROFILE PRINTFN))) (FILESLOAD FONTPROFILE PRINTFN) (PUTPROPS COMMENT COPYRIGHT ("Venue & Xerox Corporation" T 1983 1984 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/COMMON b/sources/COMMON new file mode 100644 index 00000000..af03f325 --- /dev/null +++ b/sources/COMMON @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 14:58:17" {DSK}local>lde>lispcore>sources>COMMON.;2 14305 changes to%: (VARS COMMONCOMS) previous date%: "30-Mar-87 16:57:29" {DSK}local>lde>lispcore>sources>COMMON.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMMONCOMS) (RPAQQ COMMONCOMS [[COMS (* ; "BQUOTE") (FNS READBQUOTE READBQUOTECOMMA \UNCOMMA \BQUOTE.BREAKRESET) (VARIABLES SI::*BACKQUOTE-LEVEL*) (FUNCTIONS SI::BQUOTE-EXPANDER SI::BQUOTE-PROCESS-LIST SI::BQUOTE-CONS SI::BQUOTE-APPEND SI::BQUOTE-NCONC SI::COMMA-ERROR-EXPANDER . `SI::BQUOTE) (P (CL:SETF (CL:MACRO-FUNCTION '\,) 'SI::COMMA-ERROR-EXPANDER) (CL:SETF (CL:MACRO-FUNCTION '\,@) 'SI::COMMA-ERROR-EXPANDER) (CL:SETF (CL:MACRO-FUNCTION '\,.) 'SI::COMMA-ERROR-EXPANDER)) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (\INBQUOTE)) (ADDVARS (BREAKRESETFORMS (\BQUOTE.BREAKRESET] (COMS (* ;  "Pretty printing of quote and friends") (FNS QUOTE.WRAPPER BQUOTE.WRAPPER FUNCTION.WRAPPER) (PROP PRETTYWRAPPER BQUOTE SI::BQUOTE CL:FUNCTION QUOTE \, . ,.\,@)) (PROP FILETYPE COMMON) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "BQUOTE") (DEFINEQ (READBQUOTE [LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:41 by bvm:") (LET ((\INBQUOTE T)) (DECLARE (SPECVARS \INBQUOTE)) (LIST 'BQUOTE (CL:READ FILE T NIL T]) (READBQUOTECOMMA [LAMBDA (FILE) (DECLARE (USEDFREE \INBQUOTE)) (* ; "Edited 19-Mar-87 16:45 by bvm:") (if (OR (fetch (READTABLEP COMMONLISP) of *READTABLE*) \INBQUOTE) then (* ; "Valid context for comma") (LIST (SELCHARQ (SKIPSEPRCODES FILE) (@ (READCCODE FILE) '\,@) (%. (READCCODE FILE) '\,.) '\,) (CL:READ FILE T NIL T)) else (* ;; "Comma outside of backquote context is `an error' ") (* ;; "In Interlisp read table we want to treat it as though it had been escaped, because files written with old FILERDTBL might have had unescaped commas in them. In Common Lisp, we go ahead and read it as if we were in bquote context, for the benefit of typing subexpressions to DEdit") (LET ((CH (PEEKCCODE FILE))) (if (OR (SYNTAXP CH 'BREAK) (SYNTAXP CH 'SEPR)) then '%, else (PACK* '%, (READ FILE]) (\UNCOMMA [LAMBDA (X) (* bvm%: "19-May-86 12:38") (* * "Convert an old-style BQUOTE, where the commas were list elements, into the new style, where the commas are wrappers") (COND ((NLISTP X) X) (T (SELECTQ (CAR X) ((%, %,. %,@ ., %,!) (LET [(TAIL (\UNCOMMA (CDR X] (CONS (LIST (SELECTQ (CAR X) (%, '\,) (%,. '\,.) '\,@) (CAR TAIL)) (CDR TAIL)))) (LET [(BCAR (\UNCOMMA (CAR X))) (BCDR (\UNCOMMA (CDR X] (COND ((AND (EQ BCAR (CAR X)) (EQ BCDR (CDR X))) X) (T (CONS BCAR BCDR]) (\BQUOTE.BREAKRESET [LAMBDA (FLG) (* bvm%: " 6-Jul-85 23:19") (PROG1 \INBQUOTE (SETQ \INBQUOTE FLG]) ) (CL:DEFVAR SI::*BACKQUOTE-LEVEL* 0) (CL:DEFUN SI::BQUOTE-EXPANDER (SI::FORM SI::LEVEL) [LET ((SI::*BACKQUOTE-LEVEL* SI::LEVEL)) (CL:IF (CL:ATOM SI::FORM) (KWOTE SI::FORM) (CASE (CAR SI::FORM) (* ; "form is non-NIL") ((SI::BQUOTE BQUOTE) (SI::BQUOTE-EXPANDER (SI::BQUOTE-EXPANDER (CADR SI::FORM) (CL:1+ SI::LEVEL)) SI::LEVEL)) ((\,) (CADR SI::FORM)) (* ; "`,foo => foo") ((\,@) (CL:ERROR ",@ in illegal context: ,@~S" (CADR SI::FORM))) ((\,.) (CL:ERROR ",. in illegal context: ,.~S" (CADR SI::FORM))) (CL:OTHERWISE (SI::BQUOTE-PROCESS-LIST SI::FORM))))]) (CL:DEFUN SI::BQUOTE-PROCESS-LIST (LIST) (* ;; "Expand backquoted list.") (CL:IF (CL:ATOM LIST) (KWOTE LIST) (* ;  "(KWOTE NIL) => NIL, so this is OK.") [LET ((SI::ITEM (CAR LIST)) (SI::TAIL (CDR LIST))) (* ; "list has at least one CONS") (CASE SI::ITEM ((\,) (CAR SI::TAIL)) ((\,@) (CL:ERROR ",@ in illegal context: ,@~S" (CAR SI::TAIL))) ((\,.) (CL:ERROR ",. in illegal context: ,.~S" (CAR SI::TAIL))) (CL:OTHERWISE (CL:IF (CL:ATOM SI::ITEM) (SI::BQUOTE-CONS (KWOTE SI::ITEM) (* ; "save a call to bquote-expander.") (SI::BQUOTE-PROCESS-LIST SI::TAIL)) (CASE (CAR SI::ITEM) ((\,) (SI::BQUOTE-CONS (CADR SI::ITEM) (SI::BQUOTE-PROCESS-LIST SI::TAIL))) ((\,@) (SI::BQUOTE-APPEND (CADR SI::ITEM) (SI::BQUOTE-PROCESS-LIST SI::TAIL))) ((\,.) (SI::BQUOTE-NCONC (CADR SI::ITEM) (SI::BQUOTE-PROCESS-LIST SI::TAIL))) (CL:OTHERWISE (SI::BQUOTE-CONS (SI::BQUOTE-EXPANDER SI::ITEM SI::*BACKQUOTE-LEVEL*) (SI::BQUOTE-PROCESS-LIST SI::TAIL)))))))])) (CL:DEFUN SI::BQUOTE-CONS (SI::BCAR SI::BCDR) (* ;; "build a call to CONS of bcar and bcdr, optimizing where possible.") [LET (SI::CONSTA SI::CONSTD) (COND [(AND (CL:SETQ SI::CONSTA (CONSTANTEXPRESSIONP SI::BCAR)) (CL:SETQ SI::CONSTD (CONSTANTEXPRESSIONP SI::BCDR))) (KWOTE (CONS (CL:FIRST SI::CONSTA) (CL:FIRST SI::CONSTD] ((NULL SI::BCDR) (* ;; "(cons x nil) => (list x)") (LIST 'LIST SI::BCAR)) [(CL:LISTP SI::BCDR) (CASE (CL:FIRST SI::BCDR) ((CONS LIST*) (* ;; "(cons x (cons . rest)) => (list* x . rest)") (* ;; "(cons x (list* . rest)) => (list* x . rest)") (LIST* 'LIST* SI::BCAR (CL:REST SI::BCDR))) (LIST (* ;; "(cons x (list . rest)) => (list x . rest)") (LIST* 'LIST SI::BCAR (CL:REST SI::BCDR))) (CL:OTHERWISE (LIST 'CONS SI::BCAR SI::BCDR)))] (T (LIST 'CONS SI::BCAR SI::BCDR]) (CL:DEFUN SI::BQUOTE-APPEND (SI::HEAD SI::TAIL) (* ;; "create a call to APPEND of head and tail, optimizing where possible.") [COND ((NULL SI::HEAD) (CL:IF (CL:ZEROP SI::*BACKQUOTE-LEVEL*) SI::TAIL (LIST 'CL:APPEND SI::TAIL))) ((NULL SI::TAIL) (CL:IF (CL:ZEROP SI::*BACKQUOTE-LEVEL*) SI::HEAD (LIST 'CL:APPEND SI::HEAD))) (T (CASE (CAR (LISTP SI::HEAD)) (CONS (* ;; "(append (cons x y) z) => (cons x (append y z))") (SI::BQUOTE-CONS (CL:SECOND SI::HEAD) (SI::BQUOTE-APPEND (CL:THIRD SI::HEAD) SI::TAIL))) (LIST (* ;; "(append (list ...) x) => (list* ... x)") (CONS 'LIST* (APPEND (CL:REST SI::HEAD) (LIST SI::TAIL)))) (LIST* (* ;; "(append (list* ... x) y) => (list* ... (append x y))") [CONS 'LIST* (CL:APPEND (CL:BUTLAST (CL:REST SI::HEAD)) (LIST (SI::BQUOTE-APPEND (CAR (LAST SI::HEAD)) SI::TAIL]) ((CL:APPEND NCONC) (* ;; "(append (append ...) x) => (append ... x)") [CONS 'CL:APPEND (APPEND (CL:REST SI::HEAD) (CL:IF (EQ (CL:FIRST (LISTP SI::TAIL)) 'CL:APPEND) (CL:REST SI::TAIL) (LIST SI::TAIL))]) (CL:OTHERWISE (CL:IF (EQ (CL:FIRST (LISTP SI::TAIL)) 'CL:APPEND) (LIST* 'CL:APPEND SI::HEAD (CL:REST SI::TAIL)) (LIST 'CL:APPEND SI::HEAD SI::TAIL))))]) (CL:DEFUN SI::BQUOTE-NCONC (SI::HEAD SI::TAIL) (* ;; "create a call to NCONC of head and tail, optimizing where possible.") [COND ((NULL SI::HEAD) (CL:IF (CL:ZEROP SI::*BACKQUOTE-LEVEL*) SI::TAIL (LIST 'NCONC SI::TAIL))) ((NULL SI::TAIL) (CL:IF (CL:ZEROP SI::*BACKQUOTE-LEVEL*) SI::HEAD (LIST 'NCONC SI::HEAD))) (T (CASE (CL:FIRST (LISTP SI::HEAD)) (CONS (* ;; "(nconc (cons x y) z) => (cons x (nconc y z))") (SI::BQUOTE-CONS (CL:SECOND SI::HEAD) (SI::BQUOTE-NCONC (CL:THIRD SI::HEAD) SI::TAIL))) ((LIST LIST* CL:APPEND) (* ;;  "since you're splicing new structure, may as well use append and it's optimizations.") (SI::BQUOTE-APPEND SI::HEAD SI::TAIL)) (NCONC (* ;; "(nconc (nconc ...) y) => (nconc ... y)") [CONS 'NCONC (APPEND (CL:REST SI::HEAD) (CL:IF (EQ (CAR (LISTP SI::TAIL)) 'NCONC) (CL:REST SI::TAIL) (LIST SI::TAIL))]) (CL:OTHERWISE (CL:IF (EQ (CAR (LISTP SI::TAIL)) 'NCONC) (LIST* 'NCONC SI::HEAD (CL:REST SI::TAIL)) (LIST 'NCONC SI::HEAD SI::TAIL))))]) (CL:DEFUN SI::COMMA-ERROR-EXPANDER (SI::FORM SI::ENV) (CL:ERROR "Tried to evaluate ~A~S outside of a backquote scope.~%%Probably a missing backquote or too many commas." (CL:ECASE (CL:FIRST SI::FORM) ((\,) ",") ((\,@) ",@") ((\,.) ",.")) (CL:SECOND SI::FORM))) (DEFMACRO BQUOTE (FORM) (SI::BQUOTE-EXPANDER (\UNCOMMA FORM) 0)) (DEFMACRO SI::BQUOTE (SI::FORM) (SI::BQUOTE-EXPANDER (\UNCOMMA SI::FORM) 0)) (CL:SETF (CL:MACRO-FUNCTION '\,) 'SI::COMMA-ERROR-EXPANDER) (CL:SETF (CL:MACRO-FUNCTION '\,@) 'SI::COMMA-ERROR-EXPANDER) (CL:SETF (CL:MACRO-FUNCTION '\,.) 'SI::COMMA-ERROR-EXPANDER) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ \INBQUOTE NIL) (ADDTOVAR BREAKRESETFORMS (\BQUOTE.BREAKRESET)) ) (* ; "Pretty printing of quote and friends") (DEFINEQ (QUOTE.WRAPPER [LAMBDA (E FILE) (* bvm%: " 4-Jun-86 18:19") (LET [(SYN (GETSYNTAX '%'] (AND (LISTP SYN) (EQ (CAR (LAST SYN)) 'READQUOTE) "'"]) (BQUOTE.WRAPPER [LAMBDA (E FILE) (* bvm%: " 4-Jun-86 18:20") (* * "To print bquote wrappers in their original syntax") (AND [MEMB 'READBQUOTE (LISTP (GETSYNTAX '%`] (SELECTQ (CAR E) (BQUOTE "`") (\, ",") (\,. ",.") (\,@ ",@") NIL]) (FUNCTION.WRAPPER [LAMBDA (E FILE) (* bvm%: "18-Apr-86 16:36") (AND (EQ (fetch (READTABLEP HASHMACROCHAR) of (\GTREADTABLE NIL)) (CHARCODE %#)) "#'"]) ) (PUTPROPS BQUOTE PRETTYWRAPPER BQUOTE.WRAPPER) (PUTPROPS SI::BQUOTE PRETTYWRAPPER BQUOTE.WRAPPER) (PUTPROPS CL:FUNCTION PRETTYWRAPPER FUNCTION.WRAPPER) (PUTPROPS QUOTE PRETTYWRAPPER QUOTE.WRAPPER) (PUTPROPS \, PRETTYWRAPPER BQUOTE.WRAPPER) (PUTPROPS \,. PRETTYWRAPPER BQUOTE.WRAPPER) (PUTPROPS \,@ PRETTYWRAPPER BQUOTE.WRAPPER) (PUTPROPS COMMON FILETYPE COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS COMMON COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1909 4575 (READBQUOTE 1919 . 2158) (READBQUOTECOMMA 2160 . 3414) (\UNCOMMA 3416 . 4408) (\BQUOTE.BREAKRESET 4410 . 4573)) (12727 13631 (QUOTE.WRAPPER 12737 . 12994) (BQUOTE.WRAPPER 12996 . 13387) (FUNCTION.WRAPPER 13389 . 13629))))) STOP \ No newline at end of file diff --git a/sources/COMPARE b/sources/COMPARE new file mode 100644 index 00000000..69008804 --- /dev/null +++ b/sources/COMPARE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 14:59:25" {DSK}local>lde>lispcore>sources>COMPARE.;2 12260 changes to%: (VARS COMPARECOMS) previous date%: "20-Jan-87 12:44:37" {DSK}local>lde>lispcore>sources>COMPARE.;1) (* ; " Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COMPARECOMS) (RPAQQ COMPARECOMS ((FNS COMPARELST COMPARE1 COMPAREPRINT COMPAREPRINT1 COMPARELISTS COMPAREPRINTN COMPARENCHARS COMPAREFAIL COMPAREMAX COUNTDOWN) (ADDVARS (COMPARETRANSFORMS)) (INITVARS (*COMPARE-LEVEL* 1) (*COMPARE-LENGTH* 2)) (SPECVARS *COMPARE-LEVEL* *COMPARE-LENGTH* DIFFERENCES LOOSEMATCH) (GLOBALVARS COMPARETRANSFORMS COMMENTFLG))) (DEFINEQ (COMPARELST [LAMBDA (X Y LOOSEMATCH) (* ; "Edited 20-Jan-87 12:38 by bvm:") (DECLARE (SPECVARS LOOSEMATCH)) [COND ((EQ LOOSEMATCH -1) (SETQ LOOSEMATCH (COMPAREMAX X Y] (COMPARE1 X Y]) (COMPARE1 [LAMBDA (X Y) (* lmm "29-AUG-78 18:35") (* ;; "returns T if X and Y are similar; if LOOSEMATCH then sets DIFFERENCES to changes") (AND [OR (EQ X Y) (COND [(LISTP X) (COND [(LISTP Y) (OR (AND (EQ (CAR X) COMMENTFLG) (EQ (CAR Y) COMMENTFLG)) (PROG NIL LP (RETURN (COND ((NLISTP X) (OR (EQUAL X Y) (COMPAREFAIL X Y))) ((NLISTP Y) (COMPAREFAIL X Y)) ((NOT (COMPARE1 (CAR X) (CAR Y))) NIL) (T (SETQ X (CDR X)) (SETQ Y (CDR Y)) (GO LP] (T (COMPAREFAIL X Y] (T (OR (EQUAL X Y) (COMPAREFAIL X Y] (OR LOOSEMATCH T]) (COMPAREPRINT [LAMBDA (X Y STREAM) (* ; "Edited 20-Jan-87 12:20 by bvm:") (PROG ((*PRINT-LEVEL* *COMPARE-LEVEL*) (*PRINT-LENGTH* *COMPARE-LENGTH*) (PLVLFILEFLG T) FIN) (COND ((EQUAL X Y) (RETURN NIL))) (COND ((OR (NLISTP X) (NLISTP Y)) (PRINT X STREAM) (PRINT Y STREAM) (GO FIN))) (PRIN1 '%( STREAM) (* ; "Print list X by comparison with list Y") (COMPAREPRINT1 X Y STREAM) (PRIN1 '%) STREAM) (TERPRI STREAM) (PRIN1 '%( STREAM) (* ; "Do same for other list") (COMPAREPRINT1 Y X STREAM) (PRIN1 '%) STREAM) (TERPRI STREAM) FIN (RETURN T]) (COMPAREPRINT1 [LAMBDA (A B STREAM) (* ; "Edited 20-Jan-87 12:28 by bvm:") (* ;;; "[JDS: Added STREAM argument to direct output.]") (PROG ((N 0) X Y SPACE DOTFLAG L1 TAILX TAILY K) (SETQ TAILX A) (SETQ TAILY B) L1 [COND (DOTFLAG (SETQ X TAILX) (SETQ Y TAILY)) (T (SETQ X (CAR TAILX)) (SETQ Y (CAR TAILY] [COND ((EQ (SETQ K (COMPAREMAX X Y)) (SETQ K (COMPARELST X Y K))) (* ; "If two sublists are the same just type `&'") (COND ((AND (NOT SPACE) (LITATOM X) (EQ N 0)) (CL:PRIN1 X STREAM) (GO NX1)) (T (ADD1VAR N) (GO NX] (COMPAREPRINTN N SPACE T STREAM) (SETQ N 0) (COND ((OR (NLISTP X) (NLISTP Y))) [(EQ (CAR X) COMMENTFLG) (PRIN1 **COMMENT**FLG STREAM) (COND ((NEQ (CAR Y) COMMENTFLG) (SETQ TAILX (CDR TAILX)) (GO L1] ((EQ (CAR Y) COMMENTFLG) (SPACES (NCHARS **COMMENT**FLG) STREAM) (SETQ TAILY (CDR TAILY)) (GO L1))) [COND ((AND (NULL K) (NULL DOTFLAG)) (COND ((AND (LISTP TAILX) (LISTP (CDR TAILX)) (COMPARELST (CADR TAILX) Y -1)) (* ; "Next X same as this Y, so just have an inserted item") (CL:PRIN1 X STREAM) (SETQ TAILX (CDR TAILX)) (GO L1)) ((AND (LISTP TAILY) (LISTP (CDR TAILY)) (COMPARELST (CADR TAILY) X -1)) (* ; "Next Y same as this X, so leave space corresponding to the inserted item") (SPACES (COND ((NLISTP Y) (NCHARS Y T)) (T (* ; "List would be printed at print level 1, so count carefully") (COMPARENCHARS Y))) STREAM) (SETQ TAILY (CDR TAILY)) (GO L1] (COND ((OR (NLISTP X) (NLISTP Y)) (* ; "If they are unequal and one is not a list let PRIN2 type out something (atom or list)") (CL:PRIN1 X STREAM)) (T (PRIN1 '%( STREAM) (* ; "Otherwise print `()' and subanalyze") (COMPAREPRINT1 X Y STREAM) (PRIN1 '%) STREAM))) NX1 (SETQ SPACE T) NX (COND ((OR DOTFLAG (NLISTP TAILX) (NOT (CDR TAILX))) (* ; "X list ran out") (COMPAREPRINTN N SPACE NIL STREAM)) (T (SETQ DOTFLAG (NLISTP (CDR TAILX))) (COND ((CDR (LISTP TAILY)) (SETQ TAILX (CDR TAILX)) (SETQ TAILY (CDR TAILY)) (GO L1))) (COMPAREPRINTN N SPACE NIL STREAM) (COND (DOTFLAG (PRIN1 '" . " STREAM) (CL:PRIN1 (CDR TAILX) STREAM)) (T (* ; "(CDR TAILX) is a list") (SPACES 1 STREAM) (CL:PRIN1 (CADR TAILX) STREAM) (AND (CDDR TAILX) (PRIN1 '" --" STREAM]) (COMPARELISTS [LAMBDA (X Y STREAM) (* ; "Edited 20-Jan-87 12:39 by bvm:") (* ;; "functionally equivalent to CPLISTS . Prints differences on STREAM.") (SETQ STREAM (GETSTREAM STREAM 'OUTPUT)) (PROG (DIFFERENCES) (* ; "DIFFERENCES used by COMPAREFAIL") (DECLARE (SPECVARS DIFFERENCES)) (COND ((NOT (COMPARELST X Y T)) (* ; "lists are different enough to require play by play display") (COMPAREPRINT X Y STREAM)) [DIFFERENCES (* ; "x and y are different, but only by substitution. Each element of differences is a dotted pair") (for TAIL on DIFFERENCES do (LET ((PAIR (CAR TAIL))) (CL:FORMAT STREAM "~S -> ~S" (CAR PAIR) (CDR PAIR)) (if (CDR TAIL) then (PRIN1 ", " STREAM] (T (PRIN1 'SAME STREAM))) (TERPRI STREAM]) (COMPAREPRINTN [LAMBDA (N SPACE FLG STREAM) (* ; "Edited 29-Dec-86 11:56 by jds") [COND ((NEQ N 0) (COND (SPACE (SPACES 1 STREAM)) (T (SETQ SPACE T))) (SELECTQ N (1 (PRIN1 '& STREAM)) (PROGN (COND ((NOT (ILESSP (IPLUS (POSITION) 7) (LINELENGTH))) (TERPRI STREAM))) (PRIN1 '- STREAM) (PRIN2 N STREAM) (PRIN1 '- STREAM] (AND FLG SPACE (SPACES 1 STREAM]) (COMPARENCHARS [LAMBDA (X) (* ; "Edited 20-Jan-87 12:26 by bvm:") (* ;; "Count the number of characters that would be printed at the current print depth") (LET [(COMPARECNT 0) (*PRINT-ESCAPE* T) (*READTABLE* (\DTEST *READTABLE* 'READTABLEP] (DECLARE (SPECVARS *READTABLE* *PRINT-ESCAPE*)) (\MAPPNAME.INTERNAL [FUNCTION (LAMBDA (S C) (ADD COMPARECNT 1] X) COMPARECNT]) (COMPAREFAIL [LAMBDA (X Y) (* ; "Edited 13-Jan-87 14:29 by bvm:") (* ;; "X and Y are different. Return non-NIL if we are willing to believe that X and Y really are the same for purposes of not going thru COMPAREPRINT. DIFFERENCES is a list associating occurrences of X with a value of Y; if all such occurrences are the same, then COMPARELST will just print a series of transformations X -> Y.") (COND [(SOME COMPARETRANSFORMS (FUNCTION (LAMBDA (FN) (CL:FUNCALL FN X Y] ((NULL LOOSEMATCH) (* ; "exact match demanded") NIL) ((NUMBERP LOOSEMATCH) (IGREATERP [SETQ LOOSEMATCH (COUNTDOWN Y (COUNTDOWN X (SUB1 LOOSEMATCH] 0)) ([AND (NLISTP X) (OR (NLISTP Y) (EVERY Y (FUNCTION NLISTP] (LET ((OLD (FASSOC X DIFFERENCES))) (if OLD then (EQUAL Y (CDR OLD)) else (SETQ DIFFERENCES (NCONC1 DIFFERENCES (CONS X Y]) (COMPAREMAX [LAMBDA (X Y) (* lmm "30-AUG-78 02:19") (IQUOTIENT (IDIFFERENCE 65 (IPLUS (COUNTDOWN X 30) (COUNTDOWN Y 30))) 5]) (COUNTDOWN [LAMBDA (X N) (* lmm "30-AUG-78 02:37") (COND ((OR (NLISTP X) (NOT (IGREATERP N 0))) N) (T (COUNTDOWN (CDR X) (COUNTDOWN (CAR X) (SUB1 N]) ) (ADDTOVAR COMPARETRANSFORMS ) (RPAQ? *COMPARE-LEVEL* 1) (RPAQ? *COMPARE-LENGTH* 2) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS *COMPARE-LEVEL* *COMPARE-LENGTH* DIFFERENCES LOOSEMATCH) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMPARETRANSFORMS COMMENTFLG) ) (PUTPROPS COMPARE COPYRIGHT ("Venue & Xerox Corporation" 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (823 11885 (COMPARELST 833 . 1095) (COMPARE1 1097 . 2506) (COMPAREPRINT 2508 . 3465) ( COMPAREPRINT1 3467 . 7731) (COMPARELISTS 7733 . 9020) (COMPAREPRINTN 9022 . 9666) (COMPARENCHARS 9668 . 10226) (COMPAREFAIL 10228 . 11355) (COMPAREMAX 11357 . 11594) (COUNTDOWN 11596 . 11883))))) STOP \ No newline at end of file diff --git a/sources/COMPATIBILITY b/sources/COMPATIBILITY new file mode 100644 index 00000000..39d4b77e --- /dev/null +++ b/sources/COMPATIBILITY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:00:10" |{DSK}local>lde>lispcore>sources>COMPATIBILITY.;2| 2011 |changes| |to:| (VARS COMPATIBILITYCOMS) |previous| |date:| "16-Oct-86 23:43:55" |{DSK}local>lde>lispcore>sources>COMPATIBILITY.;1| ) ; Copyright (c) 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT COMPATIBILITYCOMS) (RPAQQ COMPATIBILITYCOMS ((FNS DEFINEDP FGETD PUTDQ PUTDQ? RESETTERMCHARS RESETINT) (P (MOVD 'HARRAYP 'HASHARRAYP)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML PUTDQ? PUTDQ) (LAMA))))) (DEFINEQ (definedp (lambda (a) (* |lmm| "10-Apr-84 15:13") (and (litatom a) (|fetch| (litatom defpointer) |of| a) t))) (fgetd (lambda (fn) (* |lmm:| "12-NOV-76 00:13:04") (setq fn (getd fn)) (cond ((and (listp fn) (smallp (car fn)) (smallp (cdr fn))) (cdr fn)) (t fn)))) (putdq (nlambda (x y) (putd x y) x)) (putdq? (nlambda (fn def) (and (null (getd fn)) (putd fn def)))) (resettermchars (lambda (termtable systemtype) (* |lmm| "24-May-86 18:51") nil)) (resetint (lambda (from to) (* |lmm| "24-May-86 18:51") nil)) ) (MOVD 'HARRAYP 'HASHARRAYP) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML PUTDQ? PUTDQ) (ADDTOVAR LAMA ) ) (PUTPROPS COMPATIBILITY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (853 1729 (DEFINEDP 863 . 1063) (FGETD 1065 . 1332) (PUTDQ 1334 . 1384) (PUTDQ? 1386 . 1469) (RESETTERMCHARS 1471 . 1597) (RESETINT 1599 . 1727))))) STOP \ No newline at end of file diff --git a/sources/COMPILE b/sources/COMPILE new file mode 100644 index 00000000..8a187878 --- /dev/null +++ b/sources/COMPILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "27-Jul-90 11:15:42" |{PELE:MV:ENVOS}SOURCES>COMPILE.;4| 68945 changes to%: (FNS BRECOMPILE) previous date%: " 8-Jun-90 11:48:47" |{PELE:MV:ENVOS}SOURCES>COMPILE.;3|) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1984 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 COMPILECOMS) (RPAQQ COMPILECOMS ((FNS BCOMPL BCOMPL.BODY PRINT-COMPILE-HEADER RESETOPENFILES BCOMPL1A BCOMPL2 BCOMPL3 BLOCK%: BRECOMPILE BRECOMPILE1 BRECOMPILE2 BRECOMPILE3 BLOCKCOMPILE BLOCKCOMPILE1 COMPSET COMPSETREAD COMPSETY COMPSETF RCOMP3 TCOMPL RECOMPILE RECOMP? COMPILE COMPILE1 COMPILE1A SHOULD-BE-DWIMIFIED? COMPILE.FILECHECK COMPEM GETCFILE SPECVARS LOCALVARS GLOBALVARS) (ADDVARS (NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE EDITL) (LINKFNS) (FREEVARS) (SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0 SPECVARS LOCALVARS GLOBALVARS) (SYSLOCALVARS) (LOCALFREEVARS) (BLKLIBRARY) (RETFNS) (BLKAPPLYFNS) (DONTCOMPILEFNS) (NLAML) (NLAMA) (LAMS) (LAMA)) (INITVARS (SPECVARS T) (LOCALVARS SYSLOCALVARS)) (INITVARS (DWIMIFYCOMPFLG NIL) (COMPILEHEADER "compiled on ") (COMPSETLST (QUOTE (ST F STF S Y N 1 2 NIL T))) (COMPSETKEYLST (QUOTE ((ST "ore and redefine " KEYLST ("" (F . "orget exprs"))) (S . "ame as last time") (F . "ile only") (T . "o terminal") (1) (2) (Y . "es") (N . "o")))) (COMPSETDEFAULTKEYLST (QUOTE ((Y . "es") (N . "o")))) (BCOMPL.SCRATCH (QUOTE {CORE}BCOMPL.SCRATCH)) (RECOMPILEDEFAULT (QUOTE CHANGES)) (COUTFILE T) (SVFLG T) (STRF T) (LSTFIL T) (LCFIL) (LAPFLG T)) (DECLARE%: DONTCOPY (RECORDS COMPFILEDESCR) (MACROS DIGITCHARP) (GLOBALVARS SYSSPECVARS SYSLOCALVARS RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER COMPVERSION BCOMPL.SCRATCH LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG CLISPARRAY COMPSETKEYLST REREADFLG HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL DWIMFLG DWIMWAIT)) (P (MOVD? (QUOTE NILL) (QUOTE FILECHANGES)) (CL:PROCLAIM (QUOTE (CL:SPECIAL COMPVARMACROHASH))) (CL:PROCLAIM (QUOTE (GLOBAL SYSSPECVARS SYSLOCALVARS COMPILE.EXT NOTCOMPILEDFILES CLISPARRAY FILERDTBL DWIMFLG DWIMWAIT LISPXHISTORY)))) (COMS (* ; "COMPILEMODE") (PROP VARTYPE COMPILEMODELST) (FNS COMPILEMODE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK%:) (NLAML BCOMPL3) (LAMA))))) (DEFINEQ (BCOMPL [LAMBDA (FILES CFILE NOBLOCKSFLG OPTIONSSET) (* ; "Edited 9-Feb-87 16:22 by Pavel") (* ;;; "BCOMPL is like TCOMPL, except that it reads in all of FILES before starting any compilations, so that a BLOCK can contain functions in several FILES. BLOCKS are set up using a DECLARE statement of the form") (* ;;; "(DECLARE (BLOCK: BLKNAME BLKFN1 BLKFN2 ... (VAR1 VALUE) (VAR2 VALUE) ...) (BLOCK: BLKNAME ...) ...) ") (* ;;; "where BLKFN1 ... are the functions in the BLOCK, and VAR1 ... are values for ENTRIES, RETFNS, SPECVARS, etc. A variable setting of the form (VAR . list) sets variable to UNION of the list with the variable's top level value. A variable setting of the form (VAR . ATOM) simply sets the variable to that atom, e.g. (NOLINKFLG . T)") (RESETLST (LET ((NLAML NLAML) (NLAMA NLAMA) (LAMS LAMS) (LAMA LAMA) (DWIMIFYCOMPFLG DWIMIFYCOMPFLG) (EXPRSLST NIL) (NOFIXVARSLST NOFIXVARSLST) (NOFIXFNSLST NOFIXFNSLST) (*PRINT-ARRAY* T) (*PRINT-LENGTH* NIL) (*PRINT-LEVEL* NIL)) (DECLARE (SPECVARS NLAML NLAMA LAMS LAMA DWIMIFYCOMPFLG EXPRSLST NOFIXVARSLST NOFIXFNSLST *PRINT-ARRAY* *PRINT-LEVEL* *PRINT-LENGTH*)) (SETQ FILES (RESETOPENFILES FILES)) (* ;; "Checks that all FILES are there, and if not, attempts spelling correction. Opens them for input, too, and returns the input stream") (BCOMPL.BODY FILES CFILE NOBLOCKSFLG OPTIONSSET]) (BCOMPL.BODY [LAMBDA (FILES CFILE NOBLOCKSFLG OPTIONSSET) (* bvm%: "13-Oct-86 17:07") (* ;;; "FILES is a list of streams. Compile everything on them, dumping to CFILE (default first stream.dcom). NOBLOCKSFLG means TCOMPL instead of BCOMPL. OPTIONSSET is true if the Listing? question has already been asked.") (DECLARE (SPECVARS CFILE)) (PROG ((SPECVARS T) (LOCALVARS SYSLOCALVARS) DEFS CHANGES OTHERS FIRST BLOCKS BLKFNS FILEROOT TEM SCRATCHFILE DESTINATIONENV UNPACKFILE ) (DECLARE (SPECVARS SPECVARS LOCALVARS CHANGES OTHERS FIRST BLOCKS BLKFNS DESTINATIONENV DEFS)) [OR OPTIONSSET (COMPSET NIL '(F % ] (* ; "OPTIONSSET is T on calls from TCOMPL. In this case, the first COMPSET has already been performed.") (COMPSET (OR CFILE (PACKFILENAME 'HOST [CADR (FMEMB 'HOST (SETQ UNPACKFILE (UNPACKFILENAME (CAR FILES] 'DIRECTORY (CADR (FMEMB 'DIRECTORY UNPACKFILE)) 'NAME (SETQ FILEROOT (CADR (FMEMB 'NAME UNPACKFILE))) 'EXTENSION COMPILE.EXT))) (* ;; "Edited by TT(8-June-90 : for Fix AR#2999)") [COND (LCFIL (SETQ SCRATCHFILE (OPENSTREAM BCOMPL.SCRATCH 'BOTH 'NEW] (RESETSAVE NIL (LIST 'BCOMPL3 NIL FILES SCRATCHFILE)) (* ;; "BCOMPL3 will close and if necessary delete all the appropriate files when bcompl finishes, or control-d or control-e occurs.") [LET (DFNFLG) (* ;; "if top level value of DFNFLG is PROP, still want to evaluate expressions in declarations etc as though it were T. i.e. make BCOMPL1A equivalent to doing a LOADCOMP") (for STREAM in FILES do (RESETLST (RESETSAVE NIL (LIST 'CLOSEF STREAM)) (RESETSAVE (INPUT STREAM)) (* ;  "Needs to be primary input for some of the filepkg expressions to work") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (until (OR (NULL (SETQ TEM (READ STREAM))) (EQ TEM 'STOP)) do (BCOMPL1A TEM 'DEFAULT 'DEFAULT 'DEFAULT))))] (SETQ NOFIXFNSLST (APPEND NLAMA NLAML LAMS (NCONC [MAPCAR DEFS (FUNCTION (LAMBDA (X) (RCOMP3 (CAR X) (CADR X] NOFIXFNSLST))) (* ;; "The BCOMPL1 reads in FILES. It returns a list of variables set in the files. The RCOMP3 adds function to NLAMA, LAMS, etc., and returns a list of functions. NOFIXFNLST is reset in case there is any dwimifying to be done.") (WITH-READER-ENVIRONMENT (OR DESTINATIONENV (SETQ DESTINATIONENV *OLD-INTERLISP-READ-ENVIRONMENT*)) (COND (LCFIL (PRINT-COMPILE-HEADER FILES [LIST (COND (NOBLOCKSFLG 'tcompl'd) (T 'bcompl'd] DESTINATIONENV))) (COND (SCRATCHFILE (* ;; "writes others on a scratchfile so space can be freed up. will be copied onto lcfil aftr compilation.") (for X in OTHERS do (PRINT X SCRATCHFILE)) (PRINT NIL SCRATCHFILE) (SETQ OTHERS NIL))) [OR DWIMIFYCOMPFLG (SETQ DWIMIFYCOMPFLG (EQMEMB 'CLISP (GETPROP FILEROOT 'FILETYPE] (* ;  "The FILETYPE may have been set during the course of BCOMPL1.") [MAPC FIRST (FUNCTION (LAMBDA (X) (PRINT X LCFIL] [PROG (LISPXHIST) (DECLARE (SPECVARS LISPXHIST)) (* ;; "compile blocks MAPC not used because BCOMPL2 checks BLOCKS. lispxhist rebound bcause no need to save information when compiling from file") (AND NOBLOCKSFLG (GO NOBLOCKLP)) BLOCKLP (COND (BLOCKS (BCOMPL2 (CAR BLOCKS)) (SETQ BLOCKS (CDR BLOCKS)) (GO BLOCKLP))) (* ;  "COMPILE other functions. done this way instead of MAPC to release the defs as soon aspossible.") NOBLOCKLP (COND (DEFS (AND (NOT (FMEMB (CAAR DEFS) DONTCOMPILEFNS)) (COMPILE1 (CAAR DEFS) (CADAR DEFS))) (SETQ DEFS (CDR DEFS)) (GO NOBLOCKLP]) (RETURN (FULLNAME LCFIL]) (PRINT-COMPILE-HEADER (LAMBDA (STREAMS HOW ENV) (* bvm%: "15-Sep-86 18:04") (* * "Prints the header at the start of a compiled file. First is a possible environment definition, then a FILECREATED expression naming the source files and what was compiled and how. STREAMS is list of sources, HOW is a list describing the details of how") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (if ENV then (PRINT-READER-ENVIRONMENT ENV LCFIL) (SET-READER-ENVIRONMENT ENV)) (PRINT (NCONC (LIST 'FILECREATED (DATE) (CONS COMPILEHEADER (MAPCAR STREAMS (FUNCTION FULLNAME))) COMPVERSION) (APPEND HOW (LIST 'in HERALDSTRING 'dated MAKESYSDATE))) LCFIL)))) (RESETOPENFILES (LAMBDA (FILES) (* bvm%: " 2-Aug-86 17:00") (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (FILES) (MAPC FILES (FUNCTION CLOSEF?)))) (SETQ FILES (for F inside FILES collect (OPENSTREAM F 'INPUT))))) FILES)) (BCOMPL1A [LAMBDA (X COMPCOPYFLG COMPEVALFLG FIRSTFLG) (* ; "Edited 20-Jan-88 17:48 by jds") (PROG (TEM) [SELECTQ (CAR (LISTP X)) (FILECREATED (SETQ CHANGES (NCONC (FILECHANGES X 'FNS) CHANGES)) (SETQ FIRST (NCONC1 FIRST X))) (DEFINE-FILE-INFO (SETQ TEM (EVAL X)) (COND ((NOT DESTINATIONENV) (* ;  "Will dump new dcom file in the environment of the first source") (SETQ DESTINATIONENV TEM)))) (DEFINEQ [COND ((EQ COMPCOPYFLG 'DEFAULT) (* ;  "DEFAULT means to copy the COMPILED definitions to the file.") (SETQ DEFS (NCONC DEFS (CDR X]) (DECLARE%: (* ;  "supercedes DECLARE, DEFLIST with third argument, and PROGN with funny atom.") (* ;  "Note that DECLARE: itself isn't copied to compiled file. nor is it evaluated at compile time.") (PROG ((DFNFLG DFNFLG) (FILEPKGFLG) (COMPEVALFLG0 COMPEVALFLG) (COMPCOPYFLG0 (EQ COMPCOPYFLG 'DEFAULT)) (FIRSTFLG0 FIRSTFLG) (X (CDR X))) (* ;; "FLG is the flag in effect when the DECLARE: staated, FLG0 the current flag. the use of two flags permits turning a flag off and then back on and the same level, but prohibiting turning the flag on at a lower level, i.e. overriding a higher comand with a lower one") LP [COND ((NLISTP X) (RETURN)) ((LISTP (CAR (LISTP X))) (BCOMPL1A (CAR (LISTP X)) COMPCOPYFLG0 COMPEVALFLG0 FIRSTFLG0)) (T (SELECTQ (CAR (LISTP X)) (DONTCOPY (SETQ COMPCOPYFLG0 NIL)) ((DOCOPY COPY) (* ;; "when a DECLARE: is encountered inside of a DECLARE: DOCOPY, want the entire DECLARE: copied (because it may contain EVAL@LOADWHEN tags). in this case we don't want each individual element also to be copied. starting compcopyflg0 off at NIL and only resetting when compcopyflg is DEFAULT achieves this.") (AND (EQ COMPCOPYFLG 'DEFAULT) (SETQ COMPCOPYFLG0 T))) (COPYWHEN (AND (EQ COMPCOPYFLG 'DEFAULT) (SETQ COMPCOPYFLG0 (AND (EVAL (CADR (LISTP X))) T))) (SETQ X (CDR (LISTP X)))) (FIRST (* ;  "these expressions are copied to the compiled file before any functions.") (AND FIRSTFLG (SETQ FIRSTFLG0 T))) (NOTFIRST (SETQ FIRSTFLG0 NIL)) (DONTEVAL@COMPILE (SETQ COMPEVALFLG0 NIL)) ((DOEVAL@COMPILE EVAL@COMPILE) (AND COMPEVALFLG (SETQ COMPEVALFLG0 T))) (EVAL@COMPILEWHEN (AND COMPEVALFLG (SETQ COMPEVALFLG0 (AND (EVAL (CADR (LISTP X))) T))) (SETQ X (CDR (LISTP X)))) (COMPILERVARS (* ;; "From ADDVARS NLAMA and NLAML in prettydef. The resetting of dfnflg will suppress the (NLAMA RESET) message.") (SETQ DFNFLG T)) (EVAL@LOADWHEN (SETQ X (CDR (LISTP X)))) ((DONTEVAL@LOAD DOEVAL@LOAD EVAL@LOAD) NIL) (CL:FORMAT (\GETSTREAM COUTFILE 'OUTPUT) "(~S unrecognized DECLARE tag)~%%" (CAR (LISTP X] (SETQ X (CDR (LISTP X))) (GO LP))) ((SETQ SETQQ RPAQ RPAQQ RPAQ?) (push NOFIXVARSLST (CADR X)) (AND (EQ COMPCOPYFLG 'DEFAULT) (SETQ COMPCOPYFLG T))) (COND ((EQ (CAR (LISTP X)) COMMENTFLG) (RETURN)) ((EQ COMPCOPYFLG 'DEFAULT) (SETQ COMPCOPYFLG T] [COND ((EQ COMPCOPYFLG T) (* ;; "OTHERS is a list of expressions to be written out later. FIRST is a list of expressions to be written out before the compiled code goes out") (COND ((EQ FIRSTFLG T) (SETQ FIRST (NCONC1 FIRST X))) (T (SETQ OTHERS (NCONC1 OTHERS X] (COND ((EQ COMPEVALFLG T) (EVAL X))) (RETURN]) (BCOMPL2 [LAMBDA (BLOCK FILEMAPLST COREOK) (* ; "Edited 6-Dec-86 03:59 by lmm") (* ;  "This function processes a single block.") (* ;  "FILEMAPLST is given when recompiling.") (RESETLST (PROG ((GLOBALVARS GLOBALVARS) (RETFNS RETFNS) (BLKLIBRARY BLKLIBRARY) (NOLINKFNS NOLINKFNS) (LINKFNS LINKFNS) (DONTCOMPILEFNS DONTCOMPILEFNS) (SPECVARS SPECVARS) (LOCALVARS LOCALVARS) (BLKNAME (CAR BLOCK)) BLKAPPLYFNS ENTRIES LOCALFREEVARS X TEM LST (BNDLEV 0) (TEM2)) (DECLARE (SPECVARS GLOBALVARS RETFNS BLKLIBRARY NOLINKFNS LINKFNS DONTCOMPILEFNS) ) (COND ((NULL BLKNAME) (* ;  "BLKNAME NIL means regualr compiling unless declared otherwise") (SPECVARS . T)) (T (LOCALVARS . T))) (GO LP1) LP (* ;; "Loop through BLOCK making assignments for non-atomic expressions and gathering on LST the definitions for the atoms.") (COND ((LISTP (SETQ X (CAR BLOCK))) (* ; "A declaration") [SETQ TEM (COND ((EQ (CADR X) '*) (EVAL (CADDR X))) (T (CDR X] [SELECTQ (CAR X) ((SPECVARS LOCALVARS) (EVAL X)) (SET (CAR X) (COND ((NLISTP (CDR X)) (CDR X)) ([LISTP (SETQ TEM2 (EVAL (CAR X] (APPEND TEM TEM2)) (T TEM] (GO LP1)) ((AND FILEMAPLST (NULL BLKNAME) (NOT (RECOMP? X FNS))) (* ;; "Function is not goin to be compiled, so no point in looking up its definition. Note that BRECOMPILE never calls BCOMPL2 on a block (other than one with a NIL name) unless the entire block is going to have to be recompiled.") (SETQ TEM (LIST X))) [FILEMAPLST (COND ((NULL (SETQ TEM (BRECOMPILE3 X FILEMAPLST COREOK))) [COMPEM (CONS X '(not compileable] (GO LP1] ((SETQ TEM (FASSOC X DEFS)) (AND [NOTANY (CDR BLOCKS) (FUNCTION (LAMBDA (X) (FMEMB (CAR TEM) (CDR X] (SETQ DEFS (DREMOVE TEM DEFS))) (* ;  "This is done primarily to release the space for recompilation as soon as possible.") ) [[AND COREOK (EXPRP (SETQ TEM (VIRGINFN X T] (* ;; "this is a new feature. it is designed to allow the user to have defnitions for functions in a library file and to load them in to the files thatneed them at compile time by doing a loadfns. thus he doesnt have to have a defiitionor blklibrarydef for the functon in each file that uses it. note that when recopiling, this feature falls out because BRECOMPILE3 checks for an incore definition before it goes to the file anyway, and doesntdistinguish between defiitions of functions in the file, and those that just happen to have in core definitions.") (SETQ TEM (LIST X TEM T)) (COMPEM (CONS X '(not on file, compiling in core definition] (T [COMPEM (CONS X '(not compileable] (GO LP1))) (SETQ LST (NCONC1 LST TEM)) (SETQ BLKFNS (CONS X BLKFNS)) (* ;  "A list of those functions contained in blocks. All others will be compiled separately.") LP1 (COND ((SETQ BLOCK (CDR BLOCK)) (GO LP)) ((AND (NULL LST) BLKNAME) (* ;; "BLOCK consists of single function: BLKNAME, e.g. (FOO) or (FOO (SPECVARS --) (globavlars --)) have to go back through loop to look up definition on defs.") (SETQ BLOCK (LIST BLKNAME)) (GO LP))) (COND ((NULL BLKNAME) (* ;; "By using NIL for BLOCK name, user indicates this is a non-block compilation. However, he can set LINKFLG to T, thereby causing all calls to be linked, even though he is not compiling a BLOCK. He can also set NOLINKFNS and GLOBALVARS.") (PROG NIL L1 (COND ((NULL LST) (RETURN)) [(OR (NULL FILEMAPLST) (AND (CADAR LST) (RECOMP? (CAAR LST) FNS))) (AND (NOT (MEMB (CAAR LST) DONTCOMPILEFNS)) (COMPILE1 (CAAR LST) (CADAR LST) (CADDAR LST] (T (BRECOMPILE1 (CAAR LST) T))) (SETQ LST (CDR LST)) (GO L1))) (T (* ;  "BLOCKCOMPILE1 will also make some checks on ENTRIES.") (BLOCKCOMPILE1 BLKNAME (PROG1 LST (SETQ LST NIL)) ENTRIES))) (RETURN]) (BCOMPL3 [NLAMBDA (CFILE FILES SCRATCHFILE) (* ; "Edited 15-Sep-89 11:23 by bvm") (* ;  "Cleans up after brecompile and bcompl have finished operating,") [COND (SCRATCHFILE [COND ((NULL RESETSTATE) (* ; "finished successfully.") (COPYBYTES SCRATCHFILE LCFIL 0 (GETFILEPTR SCRATCHFILE] (CLOSEF? SCRATCHFILE) (DELFILE (FULLNAME SCRATCHFILE] [COND (LCFIL (CLOSEF? LCFIL) (AND RESETSTATE (DELFILE (FULLNAME LCFIL] (COND ((AND LSTFIL LSTFIL1) (CLOSEF? LSTFIL1))) (COND (CFILE (CLOSEF? CFILE))) (for FILE in FILES unless RESETSTATE do (* ;  "Finished successfully--remove files from NOTCOMPILEDFILES") (/SETATOMVAL 'NOTCOMPILEDFILES (REMOVE (ROOTFILENAME FILE) NOTCOMPILEDFILES))) (AND (NULL RESETSTATE) (NEQ (POSITION COUTFILE) 0) (TERPRI COUTFILE]) (BLOCK%: (NLAMBDA X (* wt%: "26-FEB-78 20:27") (* Used in DECLARE%: expressions to set up blocks.  See comment in BCOMPL. probaby this shuld be implemented by havng bcompl1  specifically check for BLOCK%: rater than simply having EVAL called, because  that way can distinguish between block declarations in file being compiled from  block declaraions in a file being LOADCOMP'ed.  for now this is handled by havng LOADCOMP rebind BLOCKS.) (SETQ BLOCKS (NCONC1 BLOCKS X)))) (BRECOMPILE (LAMBDA (FILES CFILE FNS NOBLOCKSFLG) (* ; "Edited 6-Jan-89 10:01 by jds") (* ;;; "FNS is a list of functions to be recompiled. The object is to make a file that looks exactly like that produced by BCOMPL except to greatly reduce the work by copying from CFILE the compiled definitions those functions not being recompiled.") (* ;;; "BRECOMPILE is driven by the source file(s). The algorithm is whenever a DEFINEQ is encountered, process all of the functions in the DEFINEQ as follows: COMPILE the definition of the function if it is on the list FNS, or if FNS is EXPRS and the function is currently defined as an EXPR. Otherwise copy its compiled definition from CFILE. Note that functions with compiled definitions in CFILE that do not appear in PFILE are NOT copied. This corresponds to the case where functions have been deleted from the source file.") (* ;;; "The value FNS = CHANGES means recompile anything marked changed in the file header.") (* ;;; "(RECOMPILE file cfile fns) is equivalent to (BRECOMPILE file cfile fns T).") (* ;;; "Note that CFILE=NIL is interpreted as meaning file.dcom even when FNS supplied.") (RESETLST (PROG ((*PRINT-ARRAY* T) (*PRINT-LENGTH* NIL) (*PRINT-LEVEL* NIL) (NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (DWIMIFYCOMPFLG DWIMIFYCOMPFLG) (EXPRSLST NIL) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST) (BUILDMAPFLG T) (SPECVARS T) (LOCALVARS SYSLOCALVARS) (AUXFILECOM T) CHANGES OTHERS FIRST FILEMAPLST FNLST BLKFNS BLOCKS FILE FILE.COM TEM ADRLST SCRATCHFILE COREOK DESTINATIONENV MSG) (DECLARE (SPECVARS *PRINT-ARRAY* *PRINT-LENGTH* *PRINT-LEVEL* NLAMA NLAML LAMS LAMA DWIMIFYCOMPFLG EXPRSLST NOFIXFNSLST NOFIXVARSLST BUILDMAPFLG SPECVARS LOCALVARS CHANGES OTHERS FIRST BLKFNS BLOCKS DESTINATIONENV ADRLST FILEMAPLST CFILE FNS FILE)) (COND ((AND (NULL CFILE) (NULL FNS)) (SETQ FNS RECOMPILEDEFAULT))) (RESETSAVE (INPUT)) (SETQ FILES (RESETOPENFILES FILES)) (COND ((SETQ TEM (for FILE in FILES when (NOT (RANDACCESSP FILE)) collect (FULLNAME FILE))) (GO NONRAND))) (SETQ FILE (UNPACKFILENAME (CAR FILES))) (SETQ FILE.COM (PACKFILENAME (QUOTE HOST) (CADR (FMEMB (QUOTE HOST) FILE)) (QUOTE DIRECTORY) (CADR (FMEMB (QUOTE DIRECTORY) FILE)) (QUOTE NAME) (SETQ FILE (CADR (FMEMB (QUOTE NAME) FILE))) (QUOTE EXTENSION) COMPILE.EXT)) (* ;; "Edited by TT (8-June-90 : for fix AR#2999)") (COND ((EQ FNS (QUOTE ALL)) (GO BRECALL))) CFILERETRY (COND ((NLSETQ (SETQ CFILE (OPENSTREAM (OR CFILE FILE.COM) (QUOTE INPUT) (QUOTE OLD) NIL (QUOTE ((TYPE BINARY)))))) (COND ((NOT (RANDACCESSP CFILE)) (SETQ TEM (CLOSEF CFILE)) (GO NONRAND)) ((OR (NULL (SETQ DESTINATIONENV (GET-ENVIRONMENT-AND-FILEMAP (CAR FILES)))) (CL:MULTIPLE-VALUE-BIND (ENV DUMMY START) (\PARSE-FILE-HEADER CFILE) (COND ((OR (NULL ENV) (NOT (EQUAL-READER-ENVIRONMENT ENV DESTINATIONENV))) T) (T (* "Position cfile back to start") (SETFILEPTR CFILE START) NIL)))) (SETQ TEM (CLOSEF CFILE)) (SETQ MSG " has different reader environment than the new file") (GO NONREC))) (GO BREC)) ((OR (AND (EQ AUXFILECOM T) (SETQ AUXFILECOM (SPELLFILE (ROOTFILENAME (OR CFILE FILE.COM)))) (SETQ CFILE AUXFILECOM) (GO CFILERETRY)) (EQ (ASKUSER DWIMWAIT (QUOTE Y) (LIST (OR CFILE FILE.COM) "not found;" " compile all functions on " (FULLNAME (CAR FILES)) (QUOTE "instead"))) (QUOTE Y))) (* ; "Edited by TT(8-June-90 : for Fix AR#8017)") (GO BRECALL)) ((EQ (ASKUSER DWIMWAIT (QUOTE Y) (CONS (QUOTE "Just forget about compiling") (MAPCAR FILES (FUNCTION FULLNAME)))) (QUOTE Y)) (SELECTQ (CAR READBUF) ((ST F STF) (* "E.g. From CLEANUP.") (SETQ READBUF (CDR READBUF))) NIL) (RETFROM (QUOTE BRECOMPILE))) (T (PRIN1 "File to use for CFILE (source of compiled definitions not being recompiled): " T) (SETQ CFILE (READ T T)) (GO CFILERETRY))) BRECALL (SETQQ FNS ALL) (SETQ CFILE NIL) BREC (COMPSET NIL (QUOTE (S T % ))) (SETQ LCFIL (OPENSTREAM FILE.COM (QUOTE OUTPUT) (QUOTE NEW) NIL (QUOTE ((TYPE BINARY))))) (SETQ SCRATCHFILE (OPENSTREAM BCOMPL.SCRATCH (QUOTE BOTH) (QUOTE NEW))) (RESETSAVE NIL (LIST (QUOTE BCOMPL3) CFILE FILES SCRATCHFILE)) (* ;; "BCOMPL3 will close and if necessary delete all the appropriate files when brecompile finishes, or control-d or control-e occurs. Note that this call differs from the call for bcompl in that cfile is also specified. this corresponds to the fact that recompile has an extra file open.") (SETQ COREOK (for X in FILES always (AND (EQ (CDAR (GETPROP (SETQ TEM (ROOTFILENAME X)) (QUOTE FILEDATES))) X) (FMEMB (CDAR (GETPROP TEM (QUOTE FILE))) (QUOTE (LOADFNS T)))))) (SETQ FILEMAPLST (for STREAM in FILES collect (LET ((LDFLG (QUOTE EXPRESSIONS)) (VARLST (QUOTE COMPILING)) DONELST FNLST) (DECLARE (SPECVARS LDFLG VARLST DONELST FNLST)) (* ; "FNLST etc are used free in LOADFNSCAN") (SETFILEPTR STREAM 0) (INPUT STREAM) (* ;; "LOADFNSCAN scans the file, building a map if one not already there. Value is the map. In addition, sets DONELST to a list of all non-defineq expressions.") (CL:MULTIPLE-VALUE-BIND (ENV MAP FILECREATEDLOC) (GET-ENVIRONMENT-AND-FILEMAP STREAM) (DECLARE (CL:SPECIAL FILECREATEDLOC)) (* ; " used by LOADFNSCAN") (WITH-READER-ENVIRONMENT ENV (create COMPFILEDESCR COMPFILESTREAM _ STREAM COMPFILEENV _ ENV COMPFILEMAP _ (LOADFNSCAN MAP) COMPFILEXPRS _ (DREVERSE DONELST))))))) (SETQ FNLST (for DESCR in FILEMAPLST join (for DEFQ in (CDR (fetch COMPFILEMAP of DESCR)) join (for X in (CDDR DEFQ) collect (CAR X))))) (* ;; "FILEMAPLST is a list of information about each file, including its name, filemap and non-defineq expressions. The first entry on the filemap is NIL. We start mapping down CDR of the filemap, and each element therein corresponds to a single DEFINEQ, in the form (start stop . fnEntries). fnEntries is a list of (FN start . stop), so the inner MAPCAR gathers up the names of the functions. The reason for not asking LOADFNS to do this is in most cases the map will already have been built, so LOADFNS won't even go inside of the defineq.") (for DESCR in FILEMAPLST do (for FORM in (fetch COMPFILEXPRS of DESCR) do (BCOMPL1A FORM (QUOTE DEFAULT) (QUOTE DEFAULT) (QUOTE DEFAULT)))) (* ;; "BCOMPL1A adds VARS set in the files to NOFIXVARSLST. NOFIXFNLST and NOFIXVARSLST are reset in case there is any dwimifying to be done BCOMPL1 also sets free variable OTHERS to list of expressions to be printed on compiled file when all is done.") (SETQ NOFIXFNSLST (APPEND NLAMA NLAML LAMS FNLST NOFIXFNSLST)) (WITH-READER-ENVIRONMENT (SETQ DESTINATIONENV (fetch COMPFILEENV of (CAR FILEMAPLST))) (* ; "Start writing the compiled file. Use environment of one of the source files--usually the only one") (if LCFIL then (PRINT-COMPILE-HEADER FILES (CONS (if NOBLOCKSFLG then (QUOTE recompiled) else (QUOTE brecompiled)) (if (EQ FNS (QUOTE ALL)) then (LIST (QUOTE ALL)) else (CONS (SELECTQ FNS (CHANGES (QUOTE changes%:)) ((EXPRS T) (QUOTE exprs%:)) (QUOTE explicitly%:)) (OR (SUBSET FNLST (FUNCTION (LAMBDA (X) (RECOMP? X FNS)))) (LIST (QUOTE nothing)))))) DESTINATIONENV)) (MAPC FNLST (FUNCTION (LAMBDA (X) (RCOMP3 X (VIRGINFN X))))) (if SCRATCHFILE then (* ;; "writes others on a scratchfile so space can be freed up. will be copied onto lcfil aftr compilation.") (for X in OTHERS do (PRINT X SCRATCHFILE)) (PRINT NIL SCRATCHFILE) (SETQ OTHERS NIL)) (for X in (PROGN FIRST) do (PRINT X LCFIL)) (OR DWIMIFYCOMPFLG (SETQ DWIMIFYCOMPFLG (EQMEMB (QUOTE CLISP) (GETPROP FILE (QUOTE FILETYPE))))) (OR (EQ FNS (QUOTE ALL)) (INPUT CFILE)) (if (NOT NOBLOCKSFLG) then (for BLOCK in BLOCKS do (if (NULL (CAR BLOCK)) then (BCOMPL2 BLOCK FILEMAPLST) elseif (for X in BLOCK thereis (AND (LITATOM X) (RECOMP? X FNS))) then (* ; "If any function in the BLOCK is to be recompiled, the whole BLOCK must be recompiled.") (BCOMPL2 BLOCK FILEMAPLST COREOK) else (BRECOMPILE1 BLOCK)))) (* ;; "NOBLOCKSFLG is T for calls from RECOMPILE. In this case, even if there were any blocks, ignore them.") (* ; "Now COMPILE rest of functions.") (for X in FNLST do (if (OR (FMEMB X BLKFNS) (FMEMB X DONTCOMPILEFNS)) elseif (RECOMP? X FNS) then (* ;; "The HELP is bcause if X is on FNS, then it follows X is in the file map, and brecompile3 should be able to produce its definition.") (COMPILE1 X (CADR (SETQ TEM (BRECOMPILE3 X FILEMAPLST COREOK))) (CADDR TEM)) else (BRECOMPILE1 X T)))) (RETURN (FULLNAME LCFIL)) NONRAND (SETQ MSG " is not RANDACCESSP") NONREC (printout T TEM MSG ", using " (if NOBLOCKSFLG then (QUOTE TCOMPL) else (QUOTE BCOMPL)) " instead." T) (RETURN (BCOMPL.BODY FILES NIL NOBLOCKSFLG))))) ) (BRECOMPILE1 (LAMBDA (FN/BLOCK NOBLOCKSFLG) (* bvm%: "29-Aug-86 22:41") (* Looks for FN/BLOCK and its subfunctions on CFILE, skipping till found.) (COND ((AND (NULL NOBLOCKSFLG) BYTECOMPFLG (NEQ BYTECOMPFLG 'NOBLOCK)) (PROG ((LST (APPEND (CDR (ASSOC 'ENTRIES FN/BLOCK)) (CDR (ASSOC 'RETFNS FN/BLOCK)) (CDR (ASSOC 'BLKAPPLYFNS FN/BLOCK)) (LISTP (CDR (ASSOC 'NOLINKFNS FN/BLOCK))) (LIST (CAR FN/BLOCK))))) (for X in (CDR FN/BLOCK) when (LITATOM X) do (SETQ BLKFNS (CONS X BLKFNS)) (BRECOMPILE1 (if (NOT (MEMB X LST)) then (* functions that are normally "visible" are compiled with the same names.  othrs use this naming convention) (SETQ X (PACK* '\ (CAR FN/BLOCK) '/ X)) else X) T)))) (T (PROG ((NAME (if NOBLOCKSFLG then FN/BLOCK else (CAR FN/BLOCK))) X ADR (ADRLST0 ADRLST)) LP (SETQ ADR (GETFILEPTR CFILE)) (if (NULL (ATOM (SETQ X (READ CFILE)))) elseif (OR (EQ X NAME) (BRECOMPILE2 X NAME)) then (PRIN2 X COUTFILE T) (PRIN1 '", " COUTFILE) (OUTPUT LCFIL) (LCSKIP X T) (* copy the function) (if (EQ X NAME) then (if (NULL NOBLOCKSFLG) then (SETQ BLKFNS (CONS X BLKFNS)) (for X in (CDR FN/BLOCK) do (if (NLISTP X) then (SETQ BLKFNS (CONS X BLKFNS)) elseif (EQ (CAR X) 'ENTRIES) then (for X in (CDR X) do (if (EQ X NAME) then (* already copied, e.g. NAME is block name as well as an entry) elseif (PROGN (SETQ ADR (GETFILEPTR CFILE)) (NEQ (READ CFILE) X)) then (COMPEM (CONS X '(not found))) (SETFILEPTR CFILE ADR) else (PRIN2 X COUTFILE T) (PRIN1 '", " COUTFILE) (LCSKIP X T)))))) (RETURN)) elseif (AND (EQ ADRLST0 ADRLST) (for Y in ADRLST thereis (* NAME is not the next function on the file.  Before skipping this function, see if NAME has been encountered earlier by  scanning ADRLST. This saves skipping all the way down to the end of the file in  the case that NAME is simply out of order.  Only do this the first time, i.e. once you hve determined that NAME is not on  ADRLST, and skipped X, then no reason to recheck ADRLST.) (if (OR (EQ (CAR Y) NAME) (BRECOMPILE2 (CAR Y) NAME)) then (* NAME was previously encountered and skipped over, e.g.  out of order.) (SETFILEPTR CFILE (CDR Y)) (BRECOMPILE1 FN/BLOCK NOBLOCKSFLG) (SETFILEPTR CFILE ADR) (* Reset filepointer back to where it  was.) T))) then (RETURN) elseif (OR (NULL X) (EQ X 'STOP)) then (if (SETQ X (BRECOMPILE3 NAME FILEMAPLST)) then (COMPILE1 NAME (CADR X) (CADDR X)) else (COMPEM (CONS NAME '(not found))) (* The only way i can see the COMPEM happening is if a function is included in  a block declaration but is not in one of the files, since the list of functions  used to drive brecompile/recompile is precisely all of the functions on the  file.) ) (SETFILEPTR CFILE ADR) (* So next read wont hit end of file.) (RETURN) else (SETQ ADRLST (NCONC1 ADRLST (CONS X ADR))) (LCSKIP X)) (GO LP)))))) (BRECOMPILE2 [LAMBDA (X FN) (* bvm%: "22-OCT-82 15:45") (* True if X is a sub-function of FN, i.e.  X is FN followed by one or more Annnn substrings.) (AND (STRPOS FN X 1 NIL T) (PROG [(NX (ADD1 (NCHARS X))) (N (ADD1 (NCHARS FN] LP (COND ([AND (ILEQ (IPLUS N 5) NX) (EQ (NTHCHARCODE X N) (CHARCODE A)) (from 1 to 4 always (DIGITCHARP (NTHCHARCODE X (add N 1] (COND ((EQ (add N 1) NX) (RETURN T)) (T (GO LP]) (BRECOMPILE3 (LAMBDA (FN FILEMAPLST COREOK) (* bvm%: "29-Aug-86 22:07") (* * "returns definition of FN, either from in core, or from the file.") (LET (DEF STREAM) (COND ((AND COREOK (EXPRP (SETQ DEF (VIRGINFN FN T)))) (* "Value is of the form (FN DEF FLG) where FLG=T means the definition was obtained from in core, so that it is ok to do spelling correction.") (LIST FN DEF T)) (T (for FILEDESCR in FILEMAPLST when (PROGN (SETQ STREAM (fetch COMPFILESTREAM of FILEDESCR)) (for Y in (CDR (fetch COMPFILEMAP of FILEDESCR)) thereis (SETQ DEF (FASSOC FN (CDDR Y))))) do (SETFILEPTR STREAM (CADR DEF)) (SETQ DEF (WITH-READER-ENVIRONMENT (fetch COMPFILEENV of FILEDESCR) (READ STREAM))) (*  "TEM is an arg to DEFINEQ, of the form (fn def)") (COND ((NEQ FN (CAR DEF)) (ERROR '"filemap does not agree with contents of" (FULLNAME STREAM) T))) (RETURN DEF))))))) (BLOCKCOMPILE [LAMBDA (BLKNAME BLKFNS ENTRIES FLG) (* ; "Edited 6-Dec-86 03:59 by lmm") (RESETLST (PROG ((NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST) (EXPRSLST NIL) (LOCALVARS T) (SPECVARS SYSSPECVARS)) (DECLARE (SPECVARS NLAMA NLAML LAMS LAMA NOFIXFNSLST NOFIXVARSLST EXPRSLST)) (* ; "Corresponds to COMPILE.") [COND [(LISTP BLKNAME) (COND ((AND (NULL BLKFNS) (NULL ENTRIES)) (* ;  "A common mistake, user calls BLOCKCOMPILE as he would COMPILE.") (SETQ BLKFNS BLKNAME) (SETQ BLKNAME (CAR BLKNAME))) (T (ERROR '"block name not atomic" BLKNAME T] ((NULL BLKFNS) (SETQ BLKFNS (LIST BLKNAME] (COMPSET) (RETURN (PROG1 (BLOCKCOMPILE1 BLKNAME BLKFNS ENTRIES) (COND ((AND (NULL FLG) LCFIL) (PRINT NIL LCFIL FILERDTBL) (CLOSEF LCFIL))) (COND ((AND (NULL FLG) LSTFIL) (CLOSEF LSTFIL]) (BLOCKCOMPILE1 [LAMBDA (BLKNAME BLKFNS ENTRIES) (* ; "Edited 4-Dec-86 15:21 by Pavel") (PROG (BLOCKLIST NEWDEF FN DEF COREFLG CALLTAGS TEM (TAGNUM -1) (FREEVARS FREEVARS)) (COND ((AND (EQ BLKNAME (CAR ENTRIES)) (NULL (CDR ENTRIES)) (NULL BLKAPPLYFNS)) (* ;  "MKENTRIES treats the case of ENTRIES=NIL specially by not setting up a separate BLOCK.") (SETQ ENTRIES NIL))) [COND ((AND (NULL ENTRIES) BLKAPPLYFNS) (* ;  "Above caper only works if no BLKAPPLYFNS") (SETQ ENTRIES (LIST BLKNAME] (COND ([SETQ TEM (SOME (APPEND BLKAPPLYFNS (OR ENTRIES (LIST BLKNAME))) (FUNCTION (LAMBDA (X) (AND (NOT (MEMB X BLKFNS)) (NOT (ASSOC X BLKFNS] [COMPEM (CONS (CAR TEM) '(not on BLKFNS] (RETURN)) ((MEMB BLKNAME ENTRIES) [COMPEM (CONS BLKNAME (APPEND '(can't be both an entry and the block name) (COND ((CDR ENTRIES) '(since there is more than one entry)) (T '(when there are also BLKAPPLYFNS] (RETURN))) (AND (NEQ (POSITION COUTFILE) 0) (TERPRI COUTFILE)) LP (COND ((NLISTP BLKFNS) (GO NX)) ((LISTP (SETQ TEM (CAR BLKFNS))) (* ;; "when blockcompile1 is called from bcompl/brecompile via bcompl2, BLKFNS is a list of elements of the form (name def coreflg). When called from blockcompile, it is a list of function names.") (SETQ FN (CAR TEM)) (SETQ DEF (CADR TEM)) (SETQ COREFLG (CADDR TEM)) (* ;; "COREFLG is T if DEF is in core. It will determine the setting of NOSPELLFLG and FILEPKGFLG for any dwimifing from the call to COMPILE1A for this function.") ) ((EXPRP (SETQ DEF (VIRGINFN TEM T))) (SETQ FN TEM) (SETQ COREFLG T)) (T [COMPEM (CONS TEM '(not compileable] (RETURN))) (SETQ BLOCKLIST (CONS FN BLOCKLIST)) (SETQ CALLTAGS (NCONC1 CALLTAGS (LIST FN (SETQ TAGNUM (SUB1 TAGNUM)) (COMPILE1A FN DEF COREFLG) COREFLG))) (* ;; "CALLTAGS will be a list of TUPLES (FN LAPTAG DEF COREFLG) which is used for internal entry points. CALLTAGS can be added to from library or from internally genereated functions e/g functional arguments.") (SETQ BLKFNS (CDR BLKFNS)) (GO LP) NX (SETQ BLKFNS NIL) [SETQ COREFLG (MAPCAR CALLTAGS (FUNCTION (LAMBDA (X) (CONS (CAR X) (CADDDR X] (* ;  "for use by compileuserfn, so can tell which functions ar n core and which are from on the file") [SETQ TEM (COND (BYTECOMPFLG (* ;; "rrb dont know who uses COREFLG but need the room for the byte compiler that the definitions are taking up so reset it here.") (BYTEBLOCKCOMPILE2 BLKNAME CALLTAGS ENTRIES)) (T (BLOCKCOMPILE2 BLKNAME CALLTAGS ENTRIES] (COND (STRF (* ; "Store and redefine") (AND (NOT (FMEMB BLKNAME LINKEDFNS)) (SETQ LINKEDFNS (CONS BLKNAME LINKEDFNS))) [MAPC COREFLG (FUNCTION (LAMBDA (X) (COND ((EXPRP (CAR X)) (SAVEDEF (CAR X)) (/PUTD (CAR X)) (SETQ EXPRSLST (CONS (CAR X) EXPRSLST)) (* ;; "so that if this function appears more than once in block declaration, will be compiled more than once") ] (* ;; "All of the entries would now be compiled. the other function should have their definitions be removed from definition cell, so that subsequent recompile will do the right thing.") )) (RETURN (OR TEM BLKNAME]) (COMPSET (LAMBDA (FILE FLG) (* bvm%: " 2-Aug-86 16:58") (* If FILE is not NIL, COMPSET doesn't ask any questions but simply initializes  the output FILE, LCFIL. If FLG is T (AND FILE IS NIL) COMPSET doesn't ask for  an output FILE, but does set up LAPFLG, STRF, SVFLG, and LSTFIL.  -  -  BCOMPL and BRECOMPILE both call COMPSET twice, once with FILE NIL and FLG T,  and once with FILE set to their output FILE.  -  COMPILE calls COMPSET only once, with both arguments NIL.) (PROG (OLDO) (COND (FILE (GO NT))) (SELECTQ (SETQ FILE (COMPSETREAD '"listing? " COMPSETKEYLST (OR FLG '(S T % )))) (S (COND (LAPFLG (PRIN1 '"file: " T) (SETQ LSTFIL (COMPSETF (COMPSETREAD))))) (GO NOCHANGE)) ((ST STF) (SETQ LAPFLG NIL) (SETQ STRF T) (SETQ SVFLG (EQ FILE 'ST)) (GO NOCHANGE)) (F (SETQ LAPFLG NIL) (SETQ STRF NIL) (SETQ SVFLG NIL) (GO NOCHANGE)) (COND ((SETQ LAPFLG (COMPSETY FILE)) (SELECTQ FILE ((Y YES 1 2) (PRIN1 '"file: " T) (SETQ FILE (COMPSETREAD))) NIL) (SETQ LSTFIL (COMPSETF FILE))))) (COND ((SETQ STRF (COMPSETY (COMPSETREAD '"redefine? "))) (SETQ SVFLG (COMPSETY (COMPSETREAD '"save exprs? "))))) NOCHANGE (COND ((AND LAPFLG (NEQ LSTFIL 'T) (NOT (OPENP LSTFIL 'OUTPUT))) (SETQ LSTFIL1 (SETQ LSTFIL (OPENFILE LSTFIL 'OUTPUT 'NEW NIL '((TYPE TEXT))))) (* LSTFIL1 is set when the file is opened for this compilation.  in this case it will be closed when the compilation is finished or aborttd.) ) (T (SETQ LSTFIL1 NIL))) (COND ((AND (NULL FLG) (COMPSETY (COMPSETREAD '"output file? " NIL '(N % )))) (PRIN1 '"file name: " T) (SETQ FILE (COMPSETREAD))) (T (SETQ FILE NIL))) NT (COND ((AND (SETQ LCFIL (COMPSETF FILE)) (NEQ LCFIL T)) (SETQ LCFIL (OR (OPENP LCFIL 'OUTPUT) (OPENSTREAM LCFIL 'OUTPUT 'NEW NIL '((TYPE BINARY))))))) (RETURN 'DONE)))) (COMPSETREAD (LAMBDA (MESS KEYLST DEFAULT) (* wt%: "23-AUG-80 01:29") (PROG (X) (COND ((OR (NULL DWIMFLG) (AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) (NULL MESS)) (AND MESS (PRIN1 MESS T)) (SETQ X (LISPXREAD T)) (AND (NULL REREADFLG) (EQ (PEEKC T) '% ) (READC T)) (* so that askuser doesnt echo the carriage return again when it is called for  next question.) ) (T (SETQ REREADFLG NIL) (SETQ X (ASKUSER DWIMWAIT DEFAULT MESS (OR KEYLST COMPSETDEFAULTKEYLST) T T)) (* COMPSETDEFAULTKEYLST is a Y or N list with conforimation required.  user can make no confirmation by simply setting it to NIL, and letting askuser  default to its list.) )) (RETURN (COND ((NULL LISPXHISTORY) X) (REREADFLG (PRINT X T T)) (T (NCONC (CAAAR LISPXHISTORY) (LIST HISTSTR0 X)) X)))))) (COMPSETY (LAMBDA (A) (SELECTQ A ((Y YES) T) ((N NO) NIL) A))) (COMPSETF (LAMBDA (A) (* lmm " 5-NOV-82 00:13") (SELECTQ A (T T) (N NIL) A))) (RCOMP3 (LAMBDA (FN DEF) (* ; "Edited 18-Dec-86 19:34 by Pavel") (PROG (TYPE TEM1 TEM2) (SELECTQ (SETQ TYPE (ARGTYPE DEF)) (NIL) (1 (COND ((NOT (MEMB FN NLAML)) (SETQ NLAML (CONS FN NLAML)) (SETQ TEM1 'NLAML) (GO ERROR)) ((MEMB FN (CL:SYMBOL-VALUE (SETQ TEM1 'NLAMA))) (GO ERROR1)))) (3 (COND ((NOT (MEMB FN NLAMA)) (SETQ NLAMA (CONS FN NLAMA)) (SETQ TEM1 'NLAMA) (GO ERROR)) ((MEMB FN (CL:SYMBOL-VALUE (SETQ TEM1 'NLAML))) (GO ERROR1)))) ((0 2) (COND ((OR (MEMB FN (CL:SYMBOL-VALUE (SETQ TEM1 'NLAMA))) (MEMB FN (CL:SYMBOL-VALUE (SETQ TEM1 'NLAML)))) (GO ERROR1)) ((NEQ (ARGTYPE FN) TYPE) (* ;; "Situation can occur when TCOMPLING a file which contains a LAMBDA definition for a function, but for which the incore definition is an NLAMBDA.") (SETQ LAMS (CONS FN LAMS))))) (HELP)) (RETURN FN) ERROR1 (/SET TEM1 (REMOVE FN (CL:SYMBOL-VALUE TEM1))) (SETQ TEM2 " was incorrectly on ") ERROR (PRIN1 '"***note: " COUTFILE) (PRIN2 FN COUTFILE T) (PRIN1 (OR TEM2 '" was not on ") COUTFILE) (PRINT TEM1 COUTFILE) (RETURN FN)))) (TCOMPL (LAMBDA (FILES) (* lmm "19-NOV-82 12:07") (COMPSET NIL '(F % )) (for FILE inside FILES collect (OR (CAR (ERSETQ (BCOMPL FILE NIL T T))) (CONS FILE '(not compiled)))))) (RECOMPILE (LAMBDA (PFILE CFILE FNS) (BRECOMPILE PFILE CFILE FNS T))) (RECOMP? (LAMBDA (X FNS) (* rmk%: "24-MAY-82 21:14") (SELECTQ FNS (ALL T) (CHANGES (FMEMB X CHANGES)) ((T EXPRS) (OR (MEMB X EXPRSLST) (EXPRP (OR (GETPROP X 'ADVISED) (GETPROP X 'BROKEN) X)))) (COND ((NLISTP FNS) (EQ X FNS)) (T (FMEMB X FNS)))))) (COMPILE [LAMBDA (X FLG) (* ; "Edited 11-Jan-88 14:51 by jds") (* ;; "Compile a list of functions, optionally storing them on a file.") (RESETLST (PROG ((NLAMA NLAMA) (NLAML NLAML) (LAMS LAMS) (LAMA LAMA) (NOFIXFNSLST NOFIXFNSLST) (NOFIXVARSLST NOFIXVARSLST) (SPECVARS SPECVARS) (LOCALVARS LOCALVARS)) (DECLARE (SPECVARS NLAMA NLAML LAMS LAMA NOFIXFNSLST NOFIXVARSLST SPECVARS LOCALVARS)) (COMPSET) (COND (LCFIL (* ;; "We're saving the results on a file, so put out the file header....") (PRINT-COMPILE-HEADER X 'compile'd NIL))) [WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (* ;;  "So that the file is printed with the correct reader environment, so it'll read back in.") (SETQ X (MAPCAR (COND ((ATOM X) (LIST X)) (T X)) (FUNCTION (LAMBDA (FN) (COMPILE1 FN (VIRGINFN FN T) T] (COND ((AND (NULL FLG) LCFIL) (PRINT NIL LCFIL FILERDTBL) (CLOSEF LCFIL))) (COND ((AND (NULL FLG) LAPFLG LSTFIL) (CLOSEF LSTFIL))) (RETURN X]) (COMPILE1 [LAMBDA (FN DEF COREFLG) (* ; "Edited 23-Nov-86 17:00 by Pavel") (* ;; "COREFLG is used by COMPILE1A to reset NOSPELLFLG so that spelling correction not aatempted when DWIMIFYING definitions from the file. COREFLG IS ALSO USED BY COMPILEUSERFN FOR SAME PURPOSE") (SETQ DEF (COMPILE1A FN DEF COREFLG)) (PROG ((FREEVARS FREEVARS)) (RETURN (COND (BYTECOMPFLG (BYTECOMPILE2 FN DEF)) (T (COMPILE2 FN DEF]) (COMPILE1A [LAMBDA (FN DEF COREFLG) (* ; "Edited 20-Jan-88 17:48 by jds") (COND [(EXPRP DEF) (PROG NIL (* ;; "Used by compile1 and blockcompile1. dwimifies def where approrpriate and also checks to see if it has a remote clisptranslation (e.g. for sri qlisp.)") [COND ((OR DWIMIFYCOMPFLG (SHOULD-BE-DWIMIFIED? DEF)) (* ;; "Needs to be dwimified. Tell them it's happening, and do it.") (CL:FORMAT (\GETSTREAM COUTFILE 'OUTPUT) "(dwimifying ~S)~%%" FN) (LET ((NOSPELLFLG (OR NOSPELLFLG (NULL COREFLG))) (FILEPKGFLG (AND FILEPKGFLG COREFLG))) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (DWIMIFY0 DEF FN) (COND ((TAILP NOFIXFNSLST NOFIXFNSLST0) (SETQ NOFIXFNSLST NOFIXFNSLST0))) (COND ((TAILP NOFIXVARSLST NOFIXVARSLST0) (SETQ NOFIXVARSLST NOFIXVARSLST0] (AND (NEQ (POSITION COUTFILE) 0) (TERPRI COUTFILE)) (RETURN (COND ((AND CLISPTRANFLG (EQ (CAR DEF) CLISPTRANFLG)) (CADR DEF)) ((AND CLISPARRAY (GETHASH DEF CLISPARRAY))) (T DEF] (T DEF]) (SHOULD-BE-DWIMIFIED? [LAMBDA (LAMBDA-FORM) (* ; "Edited 10-Apr-87 13:14 by Pavel") (* ;;; "Check to see if this LAMBDA-FORM contains a DECLARATIONS: comment or the first form is a CLISP: call. Such functions are to be automatically dwimified.") (FOR FORM IN (CDDR LAMBDA-FORM) WHILE (EQ (CAR FORM) '*) DO (IF (EQ (CADR FORM) 'DECLARATIONS%:) THEN (RETURN T)) FINALLY (RETURN (EQ (CAR FORM) 'CLISP%:]) (COMPILE.FILECHECK (LAMBDA (FILE) (* lmm "11-Jul-84 17:27") (OPENFILE FILE 'INPUT))) (COMPEM (LAMBDA (X Y ERRORFLG FL) (* wt%: " 7-JUL-78 13:07") (* ERRORFLG is NIL when called from COMP.  Just prints X and goes on.) (AND (NULL FL) (SETQ FL COUTFILE)) (COND ((NULL ERRORFLG) (PRIN1 '" *****" FL) (PRIN1 X FL T) (COND (Y (SPACES 1 FL) (PRIN1 Y FL))) (TERPRI FL) (COND ((NEQ FL T) (* so error message printed both  places) (COMPEM X Y NIL T)))) (T (PRIN1 '"*****" T) (ERROR X Y T))))) (GETCFILE (LAMBDA (FILES CFILE) (* bvm%: " 2-Aug-86 17:13") (PROG (X STR) RETRY (COND ((NLSETQ (SETQ X (OPENSTREAM CFILE 'INPUT 'OLD))) (* The reason it is done this way instead of with an INFILEP is that the user  may have specified corrective action when INFILE fails via ERRORFNS, e.g.  check anther directory, spelling correct, etc.) (COND ((RANDACCESSP X) (RETURN X))) (CLOSEF X) (SETQQ STR "is not a random access file,")) (T (SETQQ STR "not found,"))) (TERPRI T) (COND ((EQ (ASKUSER DWIMWAIT 'Y (LIST (if X then (FULLNAME X) else CFILE) STR " compile all functions on " (FULLNAME (CAR FILES)) '"instead")) 'Y) (RETURN))) (COND ((EQ (ASKUSER DWIMWAIT 'Y (LIST '"Shall I just forget about compiling" (MAPCAR FILES (FUNCTION FULLNAME)))) 'Y) (COND ((OR (EQ (CAR READBUF) 'ST) (EQ (CAR READBUF) 'F)) (* E.g. From CLEANUP.) (SETQ READBUF (CDR READBUF)))) (ERROR!))) (PRIN1 '"Then what shall I use for CFILE ? " T) (SETQ CFILE (READ T T)) (GO RETRY)))) (SPECVARS (NLAMBDA A (* lmm " 8-APR-82 21:49") (SETQ SPECVARS (COND ((LISTP A) (COND ((LISTP SPECVARS) (APPEND A SPECVARS)) ((EQ SPECVARS T) T) (T A))) (T (SETQ LOCALVARS (UNION (LISTP LOCALVARS) SYSLOCALVARS)) T))))) (LOCALVARS (NLAMBDA A (* lmm " 8-APR-82 21:49") (SETQ LOCALVARS (COND ((LISTP A) (COND ((LISTP LOCALVARS) (APPEND A LOCALVARS)) ((EQ LOCALVARS T) T) (T A))) (T (SETQ SPECVARS (UNION (LISTP SPECVARS) SYSSPECVARS)) T))) NIL)) (GLOBALVARS [NLAMBDA A (* ; "Edited 4-Dec-86 15:25 by Pavel") (IF (LISTP A) THEN (SETQ GLOBALVARS (UNION A GLOBALVARS]) ) (ADDTOVAR NOLINKFNS HELP ERRORX ERRORSET EVALV FAULTEVAL INTERRUPT SEARCHPDL MAPDL BREAK1 EDITE EDITL) (ADDTOVAR LINKFNS) (ADDTOVAR FREEVARS) (ADDTOVAR SYSSPECVARS HELPCLOCK LISPXHIST RESETSTATE OLDVALUE UNDOSIDE0 SPECVARS LOCALVARS GLOBALVARS) (ADDTOVAR SYSLOCALVARS) (ADDTOVAR LOCALFREEVARS) (ADDTOVAR BLKLIBRARY) (ADDTOVAR RETFNS) (ADDTOVAR BLKAPPLYFNS) (ADDTOVAR DONTCOMPILEFNS) (ADDTOVAR NLAML) (ADDTOVAR NLAMA) (ADDTOVAR LAMS) (ADDTOVAR LAMA) (RPAQ? SPECVARS T) (RPAQ? LOCALVARS SYSLOCALVARS) (RPAQ? DWIMIFYCOMPFLG NIL) (RPAQ? COMPILEHEADER "compiled on ") (RPAQ? COMPSETLST (QUOTE (ST F STF S Y N 1 2 NIL T))) (RPAQ? COMPSETKEYLST (QUOTE ((ST "ore and redefine " KEYLST ("" (F . "orget exprs"))) (S . "ame as last time") (F . "ile only") (T . "o terminal") (1) (2) (Y . "es") (N . "o")))) (RPAQ? COMPSETDEFAULTKEYLST (QUOTE ((Y . "es") (N . "o")))) (RPAQ? BCOMPL.SCRATCH (QUOTE {CORE}BCOMPL.SCRATCH)) (RPAQ? RECOMPILEDEFAULT (QUOTE CHANGES)) (RPAQ? COUTFILE T) (RPAQ? SVFLG T) (RPAQ? STRF T) (RPAQ? LSTFIL T) (RPAQ? LCFIL) (RPAQ? LAPFLG T) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD COMPFILEDESCR (COMPFILESTREAM COMPFILEENV COMPFILEMAP . COMPFILEXPRS)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS DIGITCHARP MACRO (LAMBDA (CHAR) (AND (IGEQ CHAR (CHARCODE 0)) (ILEQ CHAR (CHARCODE 9))))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSSPECVARS SYSLOCALVARS RECOMPILEDEFAULT COMPILE.EXT NOTCOMPILEDFILES BYTECOMPFLG COMPILEHEADER COMPVERSION BCOMPL.SCRATCH LINKEDFNS NOFIXVARSLST0 NOFIXFNSLST0 CLISPTRANFLG CLISPARRAY COMPSETKEYLST REREADFLG HISTSTR0 LISPXHISTORY COMPSETDEFAULTKEYLST FILERDTBL DWIMFLG DWIMWAIT) ) ) (MOVD? (QUOTE NILL) (QUOTE FILECHANGES)) (CL:PROCLAIM (QUOTE (CL:SPECIAL COMPVARMACROHASH))) (CL:PROCLAIM (QUOTE (GLOBAL SYSSPECVARS SYSLOCALVARS COMPILE.EXT NOTCOMPILEDFILES CLISPARRAY FILERDTBL DWIMFLG DWIMWAIT LISPXHISTORY))) (* ; "COMPILEMODE") (PUTPROPS COMPILEMODELST VARTYPE ALIST) (DEFINEQ (COMPILEMODE (LAMBDA (MODE) (* lmm%: "22-JUL-77 03:53") (* returns current compile mode. If given a mode  (one of ALTO MAXC or PDP10) looks it up on COMPILEMODELST and sets values  appropriately.) (PROG1 COMPILEMODE (COND (MODE (MAPC (CDR (OR (ASSOC MODE COMPILEMODELST) (ERROR MODE '?))) (FUNCTION (LAMBDA (X) (COND ((LISTP (CAR X)) (EVAL (CAR X))) (T (SET (CAR X) (CDR X))))))) (SETQ COMPILEMODE MODE)))))) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA GLOBALVARS LOCALVARS SPECVARS BLOCK%:) (ADDTOVAR NLAML BCOMPL3) (ADDTOVAR LAMA) ) (PUTPROPS COMPILE COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2714 65742 (BCOMPL 2724 . 4466) (BCOMPL.BODY 4468 . 10254) (PRINT-COMPILE-HEADER 10256 . 11319) (RESETOPENFILES 11321 . 11674) (BCOMPL1A 11676 . 17689) (BCOMPL2 17691 . 24506) (BCOMPL3 24508 . 25857) (BLOCK%: 25859 . 26491) (BRECOMPILE 26493 . 34961) (BRECOMPILE1 34963 . 40815) ( BRECOMPILE2 40817 . 41619) (BRECOMPILE3 41621 . 42997) (BLOCKCOMPILE 42999 . 44859) (BLOCKCOMPILE1 44861 . 49946) (COMPSET 49948 . 52711) (COMPSETREAD 52713 . 54024) (COMPSETY 54026 . 54150) (COMPSETF 54152 . 54318) (RCOMP3 54320 . 56027) (TCOMPL 56029 . 56328) (RECOMPILE 56330 . 56413) (RECOMP? 56415 . 56875) (COMPILE 56877 . 58866) (COMPILE1 58868 . 59456) (COMPILE1A 59458 . 61105) ( SHOULD-BE-DWIMIFIED? 61107 . 61796) (COMPILE.FILECHECK 61798 . 61944) (COMPEM 61946 . 62670) (GETCFILE 62672 . 64403) (SPECVARS 64405 . 64960) (LOCALVARS 64962 . 65536) (GLOBALVARS 65538 . 65740)) (67713 68662 (COMPILEMODE 67723 . 68660))))) STOP \ No newline at end of file diff --git a/sources/COMPILER-PACKAGE b/sources/COMPILER-PACKAGE new file mode 100644 index 00000000..23912b1e --- /dev/null +++ b/sources/COMPILER-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "16-May-90 15:03:20" IL:{DSK}local>lde>lispcore>sources>COMPILER-PACKAGE.;2 2312 IL:changes IL:to%: (IL:VARS IL:COMPILER-PACKAGECOMS) IL:previous IL:date%: "14-Jan-87 21:43:52" IL:{DSK}local>lde>lispcore>sources>COMPILER-PACKAGE.;1) (IL:* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:COMPILER-PACKAGECOMS) (IL:RPAQQ IL:COMPILER-PACKAGECOMS ( (IL:* IL:;; "Setting up the COMPILER package") (IL:P (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL") (:NICKNAMES "XCLC") (:PREFIX-NAME "COMPILER") (:EXPORT PASS CONTEXT-TOP-LEVEL-P CONTEXT CONTEXT-VALUES-USED CONTEXT-PREDICATE-P MAKE-CONTEXT ENV ENV-BOUNDP ENV-FBOUNDP MAKE-EMPTY-ENV COPY-ENV-WITH-VARIABLE COPY-ENV-WITH-FUNCTION OPTIMIZE-AND-MACROEXPAND OPTIMIZE-AND-MACROEXPAND-1 OPTIMIZER-LIST ASSEMBLER-ERROR))) (IL:* IL:;; "Arrange for the correct MAKEFILE environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:COMPILER-PACKAGE))) (IL:* IL:;; "Setting up the COMPILER package") (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL") (:NICKNAMES "XCLC") (:PREFIX-NAME "COMPILER") (:EXPORT PASS CONTEXT-TOP-LEVEL-P CONTEXT CONTEXT-VALUES-USED CONTEXT-PREDICATE-P MAKE-CONTEXT ENV ENV-BOUNDP ENV-FBOUNDP MAKE-EMPTY-ENV COPY-ENV-WITH-VARIABLE COPY-ENV-WITH-FUNCTION OPTIMIZE-AND-MACROEXPAND OPTIMIZE-AND-MACROEXPAND-1 OPTIMIZER-LIST ASSEMBLER-ERROR)) (IL:* IL:;; "Arrange for the correct MAKEFILE environment") (IL:PUTPROPS IL:COMPILER-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:COMPILER-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CONDITION-HIERARCHY b/sources/CONDITION-HIERARCHY new file mode 100644 index 00000000..cf30ee7d --- /dev/null +++ b/sources/CONDITION-HIERARCHY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XCL" (USE))) (il:filecreated "22-Aug-90 09:45:58" il:|{PELE:MV:ENVOS}SOURCES>CONDITION-HIERARCHY.;6| 11320 il:|changes| il:|to:| (il:structures file-not-found) il:|previous| il:|date:| " 9-Jul-90 12:21:39" il:|{PELE:MV:ENVOS}SOURCES>CONDITION-HIERARCHY.;5|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:condition-hierarchycoms) (il:rpaqq il:condition-hierarchycoms ((il:structures condition simple-condition warning simple-warning serious-condition error simple-error assertion-failed hash-table-full) (il:structures cell-error unbound-variable undefined-function attempt-to-change-constant attempt-to-rplac-nil) (il:files il:condition-hierarchy-si il:condition-hierarchy-post-si) (il:coms (il:functions il:pretty-type-name) (il:structures type-error simple-type-error type-mismatch)) (il:structures control-error program-error illegal-go illegal-return illegal-throw bad-proceed-case) (il:structures stream-error stream-not-open read-error symbol-name-too-long end-of-file) (il:structures storage-condition stack-overflow critical-storage-condition storage-exhausted symbol-ht-full array-space-full data-types-exhausted) (il:structures device-error simple-device-error) (il:structures file-error file-wont-open fs-resources-exceeded fs-protection-violation fs-renamefile-source-couldnt-delete) (il:structures arithmetic-error division-by-zero floating-point-overflow floating-point-underflow) (il:structures pathname-error file-not-found invalid-pathname) (il:functions simple-condition-format-arguments simple-condition-format-string) (il:files il:condition-hierarchy-il) (il:prop (il:filetype il:makefile-environment) il:condition-hierarchy))) (define-condition condition nil nil (:report (lambda (condition *standard-output*) (format t "Condition ~S occurred." condition)))) (define-condition simple-condition (condition) (format-string format-arguments) (:conc-name "%SIMPLE-CONDITION-") (:report (lambda (condition stream) (apply (quote format) stream (%simple-condition-format-string condition) (%simple-condition-format-arguments condition))))) (define-condition warning (condition) (condition) (:report (lambda (c s) (format s "Warning: ~A" (warning-condition s))))) (define-condition simple-warning (warning) (format-string format-arguments) (:conc-name "%SIMPLE-WARNING-") (:report (lambda (condition stream) (apply (quote format) stream (%simple-warning-format-string condition) (%simple-warning-format-arguments condition))))) (define-condition serious-condition (condition) nil (:report (lambda (condition *standard-output*) (format t "Serious condition ~S occurred." (type-of condition))))) (define-condition error (serious-condition) nil) (define-condition simple-error (error) (format-string format-arguments) (:conc-name "%SIMPLE-ERROR-") (:report (lambda (condition stream) (apply (quote format) stream (%simple-error-format-string condition) (%simple-error-format-arguments condition))))) (define-condition assertion-failed (simple-error) nil (:report (lambda (condition *standard-output*) (apply (quote format) t (or (assertion-failed-format-string condition) "Assertion failed.") (assertion-failed-format-arguments condition))))) (define-condition hash-table-full (error) (table) (:report (lambda (condition *standard-output*) (format t "Hash table full: ~S" (hash-table-full-table condition))))) (define-condition cell-error (error) (name)) (define-condition unbound-variable (cell-error) nil (:report (lambda (c s) (format s "~S is an unbound variable." (unbound-variable-name c))))) (define-condition undefined-function (cell-error) nil (:report (lambda (c s) (format s "~S is an undefined function." (undefined-function-name c))))) (define-condition attempt-to-change-constant (cell-error) nil) (define-condition attempt-to-rplac-nil (attempt-to-change-constant) nil (:report (lambda (condition *standard-output*) (format t "Attempt to rplac NIL with ~S" (attempt-to-rplac-nil-name condition))))) (il:filesload il:condition-hierarchy-si il:condition-hierarchy-post-si) (defun il:pretty-type-name (il:typespec) (il:if (eq (car (il:listp il:typespec)) (quote or)) il:then (let ((il:types (il:subset (cdr il:typespec) (il:function (il:lambda (il:name) (not (il:some (cdr il:typespec) (il:function (il:lambda (il:other) (and (il:neq il:other il:name) (subtypep il:name il:other))))))))))) (il:if (il:equal (il:sort il:types) (quote (complex float integer ratio))) il:then "a number" il:else (il:concatlist (cdr (il:for il:x il:in il:types il:join (list " or " (il:pretty-type-name il:x))))))) il:else (let (il:doc) (if (and (symbolp il:typespec) (il:setq il:doc (documentation il:typespec (quote type)))) il:doc (il:concat "a " il:typespec))))) (define-condition type-error (error) (expected-type datum) (:report (lambda (c s) (format s "Arg not ~A~&~S" (il:pretty-type-name (type-error-expected-type c)) (type-error-datum c))))) (define-condition simple-type-error (il:* il:|;;;| "This is a pretty worthless type to have around.") (type-error) (format-string format-arguments) (:conc-name "%SIMPLE-TYPE-ERROR-") (:report (lambda (c s) (apply (quote format) s (%simple-type-error-format-string c) (%simple-type-error-format-arguments c))))) (define-condition type-mismatch (type-error) (name value message) (:report (lambda (condition *standard-output*) (if (eql (type-mismatch-name condition) (type-mismatch-value condition)) (format t "~S is not ~A." (type-mismatch-value condition) (or (type-mismatch-message condition) (il:pretty-type-name (type-mismatch-expected-type condition)))) (format t "The value of ~S, ~S, is not ~A." (type-mismatch-name condition) (type-mismatch-value condition) (or (type-mismatch-message condition) (il:pretty-type-name (type-mismatch-expected-type condition)))))))) (define-condition control-error (error) nil) (define-condition program-error (error) nil) (define-condition illegal-go (program-error) (tag) (:report (lambda (condition *standard-output*) (format t "GO to a nonexistent tag: ~S." (illegal-go-tag condition))))) (define-condition illegal-return (program-error) (tag) (:report (lambda (condition *standard-output*) (format t "RETURN to nonexistent block: ~S." (illegal-return-tag condition))))) (define-condition illegal-throw (control-error) (tag) (:report (lambda (condition *standard-output*) (format t "Tag for THROW not found: ~S." (illegal-throw-tag condition))))) (define-condition bad-proceed-case (control-error) (name) (:report (lambda (condition *standard-output*) (format t "Proceed case ~S is not currently active." (bad-proceed-case-name condition))))) (define-condition stream-error (error) (stream) (:report (lambda (condition *standard-output*) (format t "Stream error on ~S." (stream-error-stream condition))))) (define-condition stream-not-open (stream-error) nil (:report (lambda (condition *standard-output*) (format t "Stream not open: ~S" (stream-not-open-stream condition))))) (define-condition read-error (error) nil) (define-condition symbol-name-too-long (read-error) nil (:report "Symbol name too long")) (define-condition end-of-file (stream-error) nil (:report (lambda (condition stream) (format stream "End of file ~S" (end-of-file-stream condition))))) (define-condition storage-condition (serious-condition) nil) (define-condition stack-overflow (storage-condition) nil (:report "Stack overflow")) (define-condition critical-storage-condition (storage-condition) nil) (define-condition storage-exhausted (critical-storage-condition) nil) (define-condition symbol-ht-full (critical-storage-condition) nil (:report "Symbol hash table full")) (define-condition array-space-full (critical-storage-condition) nil (:report "Array space full")) (define-condition data-types-exhausted (critical-storage-condition) nil (:report "No more data types available")) (define-condition device-error (serious-condition) (device)) (define-condition simple-device-error (device-error) (message) (:report (lambda (condition *standard-output*) (format t "Device error: ~A" (simple-device-error-message condition))))) (define-condition file-error (error) (pathname)) (define-condition file-wont-open (file-error) nil (:report (lambda (condition *standard-output*) (format t "File won't open: ~A" (file-wont-open-pathname condition))))) (define-condition fs-resources-exceeded (file-error) nil (:report (lambda (c s) (format s "File system resources exceeded: ~A" (fs-resources-exceeded-pathname c))))) (define-condition fs-protection-violation (file-error) nil (:report (lambda (c s) (format s "Protection violation: ~A" (file-error-pathname c))))) (define-condition fs-renamefile-source-couldnt-delete (file-error) nil (:report (lambda (condition *standard-output*) (format t "Couldn't delete the source file: ~A" (fs-renamefile-source-couldnt-delete-pathname condition))))) (define-condition arithmetic-error (error) (operation operands) (:report (lambda (c s) (format s "Arithmetic error during (~S~{ ~S~})" (arithmetic-error-operation c) (arithmetic-error-operands c))))) (define-condition division-by-zero (arithmetic-error) nil (:report "Attempt to divide by zero.")) (define-condition floating-point-overflow (arithmetic-error) nil (:report "Floating point overflow.")) (define-condition floating-point-underflow (arithmetic-error) nil (:report "Floating point underflow.")) (define-condition pathname-error (error) (pathname)) (define-condition file-not-found (file-error) nil (:report (lambda (condition *standard-output*) (format t "File not found: ~A" (file-not-found-pathname condition)))) (:handle (lambda (condition) (cond ((boundp (quote il:errorpos)) (let ((newname (il:spellfile (il:rootfilename (file-not-found-pathname condition)) nil il:nofilespellflg))) (cond (newname (il:envapply (il:stkname il:errorpos) (il:subst newname (file-not-found-pathname condition) (mapcar (function (lambda (x) (if (pathnamep x) (namestring x) x))) (il:stkargs il:errorpos))) (il:stknth -1 il:errorpos il:errorpos) il:errorpos t t))))))))) (define-condition invalid-pathname (pathname-error) nil (:report (lambda (condition *standard-output*) (format t "Invalid pathname: ~A" (invalid-pathname-pathname condition))))) (defun simple-condition-format-arguments (condition) (etypecase condition (simple-error (%simple-error-format-arguments condition)) (simple-type-error (%simple-type-error-format-arguments condition)) (simple-condition (%simple-condition-format-arguments condition)) (simple-warning (%simple-warning-format-arguments condition)))) (defun simple-condition-format-string (condition) (etypecase condition (simple-error (%simple-error-format-string condition)) (simple-type-error (%simple-type-error-format-string condition)) (simple-condition (%simple-condition-format-string condition)) (simple-warning (%simple-warning-format-string condition)))) (il:filesload il:condition-hierarchy-il) (il:putprops il:condition-hierarchy il:filetype compile-file) (il:putprops il:condition-hierarchy il:makefile-environment (:readtable "XCL" :package (defpackage "XCL" (:use)))) (il:putprops il:condition-hierarchy il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/CONDITION-HIERARCHY-IL b/sources/CONDITION-HIERARCHY-IL new file mode 100644 index 00000000..eabebe3d --- /dev/null +++ b/sources/CONDITION-HIERARCHY-IL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 15:04:10" |{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-IL.;2| 5692 |changes| |to:| (VARS CONDITION-HIERARCHY-ILCOMS) |previous| |date:| "11-Jan-88 19:02:09" |{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-IL.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT CONDITION-HIERARCHY-ILCOMS) (RPAQQ CONDITION-HIERARCHY-ILCOMS ((STRUCTURES INTERLISP-ERROR DEFINER-MISMATCH NO-SUCH-DEFINITION STACK-POINTER-RELEASED UNDEFINED-FUNCTION-IN-APPLY INDEX-BOUNDS-ERROR UNDEFINED-CAR-OF-FORM ILLEGAL-STACK-ARG) (* |;;| "Should be in XCL") (STRUCTURES CALL-ERROR TOO-MANY-ARGUMENTS TOO-FEW-ARGUMENTS INVALID-ARGUMENT-LIST) (PROP FILETYPE CONDITION-HIERARCHY-IL))) (DEFINE-CONDITION INTERLISP-ERROR (CL:ERROR) (MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (DESTRUCTURING-BIND (MESS1 . MESS2) (INTERLISP-ERROR-MESSAGE CONDITION) (ERRORMESS1 MESS1 MESS2 'ERROR))))) (DEFINE-CONDITION DEFINER-MISMATCH (CONDITION) (NAME TYPE DEFINITION) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "Definition ~S isn't a ~A definition for ~S." ( DEFINER-MISMATCH-DEFINITION CONDITION) (DEFINER-MISMATCH-TYPE CONDITION) (DEFINER-MISMATCH-NAME CONDITION))))) (DEFINE-CONDITION NO-SUCH-DEFINITION (CL:ERROR) (NAME TYPE) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "No ~A definition for ~S." (NO-SUCH-DEFINITION-TYPE CONDITION) (NO-SUCH-DEFINITION-NAME CONDITION))))) (DEFINE-CONDITION STACK-POINTER-RELEASED (CELL-ERROR) NIL (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "Stack ptr has been released~&~S" NAME)))) (DEFINE-CONDITION UNDEFINED-FUNCTION-IN-APPLY (UNDEFINED-FUNCTION) (ARGUMENTS)) (DEFINE-CONDITION INDEX-BOUNDS-ERROR (CELL-ERROR) (INDEX) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "Index out of bounds: ~D." (INDEX-BOUNDS-ERROR-INDEX CONDITION))))) (DEFINE-CONDITION UNDEFINED-CAR-OF-FORM (CONTROL-ERROR) (FUNCTION)) (DEFINE-CONDITION ILLEGAL-STACK-ARG (CONTROL-ERROR) (ARG) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:FORMAT T "Illegal stack arg: ~S" (ILLEGAL-STACK-ARG-ARG CONDITION))))) (* |;;| "Should be in XCL") (DEFINE-CONDITION CALL-ERROR (CONTROL-ERROR) (CALLEE)) (DEFINE-CONDITION TOO-MANY-ARGUMENTS (CALL-ERROR) (MAXIMUM ACTUAL) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (COND ((AND (TOO-MANY-ARGUMENTS-MAXIMUM CONDITION) (TOO-MANY-ARGUMENTS-ACTUAL CONDITION)) (CL:FORMAT T "Too many arguments to ~A:~% ~D ~:*~[were~;was~:;were~] given but at most ~D ~:*~[are~;is~:;are~] accepted" (TOO-MANY-ARGUMENTS-CALLEE CONDITION) (TOO-MANY-ARGUMENTS-ACTUAL CONDITION) (TOO-MANY-ARGUMENTS-MAXIMUM CONDITION))) ((TOO-MANY-ARGUMENTS-CALLEE CONDITION) (CL:FORMAT T "Too many arguments to ~A" (TOO-MANY-ARGUMENTS-CALLEE CONDITION)) ) (T (CL:PRINC "Too many arguments")))))) (DEFINE-CONDITION TOO-FEW-ARGUMENTS (CALL-ERROR) (MINIMUM ACTUAL) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (CL:IF (AND (TOO-FEW-ARGUMENTS-MINIMUM CONDITION) (TOO-FEW-ARGUMENTS-ACTUAL CONDITION)) (CL:FORMAT T "Too few arguments to ~A:~% ~D ~:*~[were~;was~:;were~] given but at least ~D ~:*~[are~;is~:;are~] necessary" (TOO-FEW-ARGUMENTS-CALLEE CONDITION) (TOO-FEW-ARGUMENTS-ACTUAL CONDITION) (TOO-FEW-ARGUMENTS-MINIMUM CONDITION)) (CL:FORMAT T "Too few arguments to ~A" (TOO-FEW-ARGUMENTS-CALLEE CONDITION)))) )) (DEFINE-CONDITION INVALID-ARGUMENT-LIST (CALL-ERROR) (ARGUMENT) (:REPORT (CL:LAMBDA (CONDITION *STANDARD-OUTPUT*) (COND ((NULL (INVALID-ARGUMENT-LIST-CALLEE CONDITION)) (CL:FORMAT T "Invalid argument: ~S" (INVALID-ARGUMENT-LIST-ARGUMENT CONDITION) )) (T (CL:FORMAT T "~S was given an invalid argument: ~S" ( INVALID-ARGUMENT-LIST-CALLEE CONDITION) (INVALID-ARGUMENT-LIST-ARGUMENT CONDITION))))))) (PUTPROPS CONDITION-HIERARCHY-IL FILETYPE CL:COMPILE-FILE) (PUTPROPS CONDITION-HIERARCHY-IL COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/CONDITION-HIERARCHY-POST-SI b/sources/CONDITION-HIERARCHY-POST-SI new file mode 100644 index 00000000..38bd6d39 --- /dev/null +++ b/sources/CONDITION-HIERARCHY-POST-SI @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XCL" (USE))) (IL:FILECREATED "16-May-90 15:05:05"  IL:|{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-POST-SI.;2| 1508 IL:|changes| IL:|to:| (IL:VARS IL:CONDITION-HIERARCHY-POST-SICOMS) IL:|previous| IL:|date:| "11-Jan-88 19:32:28" IL:|{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-POST-SI.;1|) ; Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHY-POST-SICOMS) (IL:RPAQQ IL:CONDITION-HIERARCHY-POST-SICOMS ((IL:STRUCTURES CONTROL-E-INTERRUPT) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-HIERARCHY-POST-SI))) (DEFINE-CONDITION CONTROL-E-INTERRUPT (SI::INTERRUPT) NIL (:REPORT "CONTROL E")) (IL:PUTPROPS IL:CONDITION-HIERARCHY-POST-SI IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:CONDITION-HIERARCHY-POST-SI IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XCL" (:USE)))) (IL:PUTPROPS IL:CONDITION-HIERARCHY-POST-SI IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CONDITION-HIERARCHY-SI b/sources/CONDITION-HIERARCHY-SI new file mode 100644 index 00000000..64491b0a --- /dev/null +++ b/sources/CONDITION-HIERARCHY-SI @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "SYSTEM") (IL:FILECREATED "16-May-90 15:05:52"  IL:{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;2 2452 IL:changes IL:to%: (IL:VARS IL:CONDITION-HIERARCHY-SICOMS) IL:previous IL:date%: "11-Jan-88 18:43:35" IL:{DSK}local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;1) (IL:* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHY-SICOMS) (IL:RPAQQ IL:CONDITION-HIERARCHY-SICOMS ((IL:STRUCTURES DEBUGGER-EVAL-ABORTED) (IL:STRUCTURES NO-PROCEED-TEST) (IL:STRUCTURES BREAKPOINT INTERRUPT REVERT) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-HIERARCHY-SI))) (XCL:DEFINE-CONDITION DEBUGGER-EVAL-ABORTED (XCL:CONDITION) (CONDITION) (:REPORT "DEBUGGER-EVAL was aborted.")) (XCL:DEFINE-CONDITION NO-PROCEED-TEST (XCL:UNDEFINED-FUNCTION) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "No test specified for proceed case: ~S." NAME)))) (XCL:DEFINE-CONDITION BREAKPOINT (XCL:SERIOUS-CONDITION) (FUNCTION) [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (IF (CONSP (BREAKPOINT-FUNCTION CONDITION)) (FORMAT T "Breakpoint at ~S, called from ~S." (FIRST (BREAKPOINT-FUNCTION CONDITION)) (THIRD (BREAKPOINT-FUNCTION CONDITION))) (FORMAT T "Breakpoint at ~S." (BREAKPOINT-FUNCTION CONDITION)))]) (XCL:DEFINE-CONDITION INTERRUPT (BREAKPOINT) NIL [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Interrupt below ~S." (INTERRUPT-FUNCTION CONDITION]) (XCL:DEFINE-CONDITION REVERT (BREAKPOINT) NIL) (IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:FILETYPE IL:COMPILE-FILE) (IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "SYSTEM")) (IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/CONDITION-PACKAGE b/sources/CONDITION-PACKAGE new file mode 100644 index 00000000..8a4df477 --- /dev/null +++ b/sources/CONDITION-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "CONDITIONS")) (IL:FILECREATED "16-May-90 15:08:25" IL:{DSK}local>lde>lispcore>sources>CONDITION-PACKAGE.;2 5040 IL:changes IL:to%: (IL:VARS IL:CONDITION-PACKAGECOMS) IL:previous IL:date%: "31-Dec-00 16:49:37" IL:{DSK}local>lde>lispcore>sources>CONDITION-PACKAGE.;1) (IL:* ; " Copyright (c) 1987, 1988, 1900, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:CONDITION-PACKAGECOMS) (IL:RPAQQ IL:CONDITION-PACKAGECOMS ((IL:FUNCTIONS CL::NATURALIZE DEFECT-FROM-XCL-TO-CONDITIONS) (IL:VARIABLES *FUTURE-CITIZENS-OF-CONDITIONS*) (IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (XCL:DEFPACKAGE "CONDITIONS" (:EXPORT *BREAK-ON-SIGNALS* HANDLER-CASE WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND COMPUTE-RESTARTS RESTART-NAME FIND-RESTART INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY CONTINUE MUFFLE-WARNING INVOKE-DEBUGGER RESTART TYPE-ERROR-DATUM PROGRAM-ERROR FILE-ERROR FILE-ERROR-PATHNAME DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW)) (MAPC #'DEFECT-FROM-XCL-TO-CONDITIONS *FUTURE-CITIZENS-OF-CONDITIONS*))) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-PACKAGE))) (DEFUN CL::NATURALIZE (CL::NAME CL::SOURCE CL::DESTINATION) "Make a symbol, possibly in source, be in source and citizen and export of destination." (CHECK-TYPE CL::NAME STRING) (CHECK-TYPE CL::SOURCE PACKAGE) (CHECK-TYPE CL::DESTINATION PACKAGE) [MULTIPLE-VALUE-BIND (CL::SSYMBOL CL::SWHERE) (FIND-SYMBOL CL::NAME CL::SOURCE) (MULTIPLE-VALUE-BIND (CL::DSYMBOL CL::DWHERE) (FIND-SYMBOL CL::NAME CL::DESTINATION) (COND ((AND CL::SWHERE CL::DWHERE (NOT (EQ CL::SSYMBOL CL::DSYMBOL))) (ERROR "Can't naturalize ~s because name exists in ~s and ~s" CL::NAME (PACKAGE-NAME CL::SOURCE) (PACKAGE-NAME CL::DESTINATION))) (CL::SWHERE (IMPORT CL::SSYMBOL CL::DESTINATION) (EXPORT CL::SSYMBOL CL::DESTINATION) (SETF (SYMBOL-PACKAGE CL::SSYMBOL) CL::DESTINATION)) (CL::DWHERE (IMPORT CL::DSYMBOL CL::SOURCE) (EXPORT CL::DSYMBOL CL::DESTINATION) (SETF (SYMBOL-PACKAGE CL::DSYMBOL) CL::DESTINATION)) (T (LET ((SYMBOL (INTERN CL::NAME CL::DESTINATION))) (IMPORT SYMBOL CL::SOURCE) (EXPORT SYMBOL CL::DESTINATION] T) (DEFUN DEFECT-FROM-XCL-TO-CONDITIONS (NAME) (CL::NATURALIZE NAME (FIND-PACKAGE "XCL") (FIND-PACKAGE "CONDITIONS"))) (XCL:DEFGLOBALPARAMETER *FUTURE-CITIZENS-OF-CONDITIONS* '("SIGNAL" "IGNORE-ERRORS" "HANDLER-BIND" "DEFINE-CONDITION" "MAKE-CONDITION" "ABORT" "STORE-VALUE" "USE-VALUE" "CONDITION" "WARNING" "SERIOUS-CONDITION" "SIMPLE-CONDITION" "SIMPLE-WARNING" "SIMPLE-ERROR" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "STORAGE-CONDITION" "CONTROL-ERROR" "STREAM-ERROR" "STREAM-ERROR-STREAM" "END-OF-FILE" "CELL-ERROR" "CELL-ERROR-NAME" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERATION" "ARITHMETIC-ERROR-OPERANDS" "SIMPLE-TYPE-ERROR" "TYPE-ERROR" "TYPE-ERROR-EXPECTED-TYPE") "Current citizens of XCL that should be in CONDITIONS: do not change this list!!!") (IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY (XCL:DEFPACKAGE "CONDITIONS" (:EXPORT *BREAK-ON-SIGNALS* HANDLER-CASE WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND COMPUTE-RESTARTS RESTART-NAME FIND-RESTART INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY CONTINUE MUFFLE-WARNING INVOKE-DEBUGGER RESTART TYPE-ERROR-DATUM PROGRAM-ERROR FILE-ERROR FILE-ERROR-PATHNAME DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW)) (MAPC #'DEFECT-FROM-XCL-TO-CONDITIONS *FUTURE-CITIZENS-OF-CONDITIONS*) ) (IL:PUTPROPS IL:CONDITION-PACKAGE IL:FILETYPE IL:COMPILE-FILE) (IL:PUTPROPS IL:CONDITION-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (XCL:DEFPACKAGE "CONDITIONS" ))) (IL:PUTPROPS IL:CONDITION-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1900 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/COREIO b/sources/COREIO new file mode 100644 index 00000000..c5be7571 --- /dev/null +++ b/sources/COREIO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 4-Oct-2018 14:13:06" {DSK}kaplan>Local>medley3.5>lispcore>sources>COREIO.;4 55097 changes to%: (FNS \CORE.GETFILEINFO) previous date%: "28-Jun-99 16:15:28" {DSK}kaplan>Local>medley3.5>lispcore>sources>COREIO.;3) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT COREIOCOMS) (RPAQQ COREIOCOMS ( (* ;;; "Implementation of Core resident `files'") (FNS \CORE.CLOSEFILE \CORE.DELETEFILE \CORE.DIRECTORYNAMEP \CORE.FINDPAGE \CORE.GENERATEFILES \CORE.NEXTFILEFN \CORE.FILEINFOFN \CORE.GETFILEHANDLE \CORE.GETFILEINFO \CORE.GETFILEINFO.FROM.INFOBLOCK \CORE.GETFILENAME \CORE.GETINFOBLOCK \CORE.NAMESCAN \CORE.NAMESEGMENT \CORE.OPENFILE \COREFILE.SETPARAMETERS \CORE.PACKFILENAME \CORE.RELEASEPAGES \CORE.SETFILEPTR \CORE.UPDATEOF \CORE.BACKFILEPTR \CORE.SETEOFPTR \CORE.SETACCESSTIME \CORE.SETFILEINFO \CORE.GETNEXTBUFFER \CORE.UNPACKFILENAME) (FNS COREDEVICE \CREATECOREDEVICE) (FNS \NODIRCOREFDEV \NODIRCORE.OPENFILE) (DECLARE%: DONTCOPY (RECORDS CORE.PAGEENTRY COREFILEINFOBLK CORESTREAM COREDEVICE COREGENFILESTATE)) (INITRECORDS COREFILEINFOBLK) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (COREDEVICE 'NODIRCORE T) (COREDEVICE 'CORE) (COREDEVICE 'SCRATCH T))) (DECLARE%: DOEVAL@LOAD DONTCOPY (LOCALVARS . T)))) (* ;;; "Implementation of Core resident `files'") (DEFINEQ (\CORE.CLOSEFILE [LAMBDA (STREAM) (* hdj "22-Sep-86 18:40") (* ;;; "Close a CORE file.") (SELECTQ (fetch ACCESS of STREAM) ((OUTPUT BOTH APPEND) (\CORE.UPDATEOF STREAM) (replace IOEPAGE of (fetch INFOBLK of STREAM) with (fetch EPAGE of STREAM)) (replace IOEOFFSET of (fetch INFOBLK of STREAM) with (fetch EOFFSET of STREAM)) (\CORE.RELEASEPAGES STREAM (fetch EPAGE of STREAM))) NIL) (UNINTERRUPTABLY (replace CBUFPTR of STREAM with NIL) (replace CBUFSIZE of STREAM with 0)) STREAM]) (\CORE.DELETEFILE [LAMBDA (FILENAME DEV EVENIFOPEN) (* ; "Edited 23-Oct-87 16:36 by bvm:") (* ; "delete a file from a directory.") (PROG [(INFOBLOCK (COND ((type? STREAM FILENAME) (* ; "If ACCESS, it's open.") (AND (OR EVENIFOPEN (NULL (fetch ACCESS of FILENAME))) (fetch INFOBLK of FILENAME))) (T (\CORE.GETINFOBLOCK FILENAME 'OLDEST DEV] (COND ((OR (NULL INFOBLOCK) (FDEVOP 'OPENP DEV (fetch IOFILEFULLNAME of INFOBLOCK) NIL DEV)) (* ; "Can't delete an open file") (RETURN))) [for NAMETAIL on (fetch COREDIRECTORY of DEV) when [for EXTTAIL on (CADR NAMETAIL) when [for VERSTAIL on (CADR EXTTAIL) when (EQ (CDR (CADR VERSTAIL)) INFOBLOCK) do (RETURN (RPLACD VERSTAIL (CDDR VERSTAIL] do (RETURN (OR (CDADR EXTTAIL) (RPLACD EXTTAIL (CDDR EXTTAIL] do (RETURN (OR (CDADR NAMETAIL) (RPLACD NAMETAIL (CDDR NAMETAIL] (* ;  "Ad hoc code to Delete directory entry") (replace IOFILEPAGES of INFOBLOCK with (LIST (create CORE.PAGEENTRY PAGENUMBER _ 0))) (RETURN (fetch IOFILEFULLNAME of INFOBLOCK]) (\CORE.DIRECTORYNAMEP [LAMBDA (DIRNAME DEV) (* ; "Edited 19-Feb-93 16:04 by jds") (LET [(DIR (UNPACKFILENAME.STRING DIRNAME 'DIRECTORY] (AND DIRNAME DIR (> (NCHARS DIR) 0]) (\CORE.FINDPAGE [LAMBDA (STREAM PN) (* bvm%: "20-Apr-85 13:32") (* ;  "Finds the entry for page PN in the page list for STREAM, creating it if necessary.") (PROG ((CACHE (fetch COREPAGECACHE of STREAM)) PAGETAIL PREVTAIL PAGEPTR PE) [SETQ PAGETAIL (COND ((AND CACHE (LEQ (fetch PAGENUMBER of (CAR CACHE)) PN)) (* ;; "Use cache: PN must be somewhere in this tail of the page list, so no sense in searching the entire page list") CACHE) (T (COND ((LESSP PN 0) (* ;  "Consistency check so that we don't try to RPLACD NIL down below") (\ILLEGAL.ARG PN))) (fetch FILEPAGES of STREAM] LP (* ; "Page 0 always exists") (COND [(EQ (fetch PAGENUMBER of (SETQ PE (CAR PAGETAIL))) PN) (OR (SETQ PAGEPTR (fetch PAGEPOINTER of PE)) (replace PAGEPOINTER of PE with (SETQ PAGEPTR (\ALLOCBLOCK (FOLDHI WORDSPERPAGE WORDSPERCELL ] [[OR (IGREATERP (fetch PAGENUMBER of PE) PN) (NULL (SETQ PAGETAIL (CDR (SETQ PREVTAIL PAGETAIL] (* ;; "PN would be before this, so it doesn't exist yet; splice it onto front of tail. This case also works when we hit the end of the list, in which case we are just smashing a new cons onto the end") (RPLACD PREVTAIL (SETQ PAGETAIL (CONS [create CORE.PAGEENTRY PAGENUMBER _ PN PAGEPOINTER _ (SETQ PAGEPTR (\ALLOCBLOCK (FOLDHI WORDSPERPAGE WORDSPERCELL ] PAGETAIL] (T (GO LP))) (replace COREPAGECACHE of STREAM with PAGETAIL) (RETURN PAGEPTR]) (\CORE.GENERATEFILES [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: " 9-Jul-84 14:11") (PROG ((FILTER (DIRECTORY.MATCH.SETUP PATTERN)) (DESIREDVERSION (FILENAMEFIELD PATTERN 'VERSION)) MATCHINGFILES) [SETQ MATCHINGFILES (for NAME in (CDR (fetch (FDEV DEVICEINFO) of FDEV)) join (for EXT in (CDR NAME) when (CDR EXT) join (COND ((FIXP DESIREDVERSION) (AND (SETQ EXT (ASSOC DESIREDVERSION (CDR EXT))) [DIRECTORY.MATCH FILTER (fetch (COREFILEINFOBLK IOFILEFULLNAME) of (SETQ EXT (CDR EXT] (LIST EXT))) ((DIRECTORY.MATCH FILTER (CONCAT (CAR NAME) "." (CAR EXT))) (COND [(NULL DESIREDVERSION) (* ; "Highest version only") (LIST (CDR (CADR EXT] (T (for VERS in (CDR EXT) collect (CDR VERS] (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \CORE.NEXTFILEFN) FILEINFOFN _ (FUNCTION \CORE.FILEINFOFN) GENFILESTATE _ (create COREGENFILESTATE COREFILELST _ (CONS NIL MATCHINGFILES]) (\CORE.NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY SCRATCHLIST) (* bvm%: " 9-Jul-84 14:05") (PROG (FILE) (pop (fetch COREFILELST of GENFILESTATE)) [SETQ FILE (fetch (COREFILEINFOBLK IOFILEFULLNAME) of (CAR (OR (fetch COREFILELST of GENFILESTATE) (RETURN] (RETURN (COND (NAMEONLY (NAMEFIELD FILE T)) (T FILE]) (\CORE.FILEINFOFN [LAMBDA (GENFILESTATE ATTRIBUTE) (* bvm%: " 3-May-84 10:50") (\CORE.GETFILEINFO.FROM.INFOBLOCK (CAR (fetch COREFILELST of GENFILESTATE)) ATTRIBUTE]) (\CORE.GETFILEHANDLE [LAMBDA (NAME RECOG FD ACCESS) (* ; "Edited 23-Oct-87 17:35 by bvm:") (LET [(INFOBLOCK (\CORE.GETINFOBLOCK NAME RECOG FD (AND (NEQ ACCESS 'INPUT) (SELECTQ RECOG ((NEW OLD/NEW) (* ;  "Yes, create it if it doesn't already exist.") T) NIL] (if INFOBLOCK then (if (\FILE-CONFLICT (fetch IOFILEFULLNAME of INFOBLOCK) ACCESS FD) then (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME (fetch IOFILEFULLNAME of INFOBLOCK))) [if (EQ ACCESS 'OUTPUT) then (* ;  "Open for OUTPUT implies no content, so smash any existing pages") (replace IOEOFFSET of INFOBLOCK with 0) (replace IOEPAGE of INFOBLOCK with 0) (replace IOFILEPAGES of INFOBLOCK with (LIST (create CORE.PAGEENTRY PAGENUMBER _ 0] (create CORESTREAM DEVICE _ FD INFOBLK _ INFOBLOCK FULLFILENAME _ (fetch IOFILEFULLNAME of INFOBLOCK) EOFFSET _ (fetch IOEOFFSET of INFOBLOCK) EPAGE _ (fetch IOEPAGE of INFOBLOCK) EOLCONVENTION _ (fetch COREEOLC of INFOBLOCK) CBUFMAXSIZE _ BYTESPERPAGE]) (\CORE.GETFILEINFO [LAMBDA (STREAM ATTRIBUTE DEV) (* ; "Edited 4-Oct-2018 14:06 by rmk:") (* ; "Edited 9-Nov-87 14:23 by sye") (* ;; "Get the value of the ATTRIBUTE for a Core file. If STREAM is a filename, then the file is not open.") (* ;; "RMK: Changed so that EOL of an open stream reverts to the generic.") (if (AND (type? STREAM STREAM) (OPENED STREAM) (SELECTQ ATTRIBUTE ((LENGTH SIZE) T) NIL)) then (* ;  "Let generic GETFILEINFO get this from the stream") NIL else (\CORE.GETFILEINFO.FROM.INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV) ATTRIBUTE]) (\CORE.GETFILEINFO.FROM.INFOBLOCK [LAMBDA (INFOBLOCK ATTRIBUTE) (* bvm%: "15-Jan-85 17:39") (COND (INFOBLOCK (SELECTQ ATTRIBUTE (LENGTH (create BYTEPTR PAGE _ (fetch IOEPAGE of INFOBLOCK) OFFSET _ (fetch IOEOFFSET of INFOBLOCK))) (SIZE (IPLUS (fetch IOEPAGE of INFOBLOCK) (FOLDHI (fetch IOEOFFSET of INFOBLOCK) BYTESPERPAGE))) (BYTESIZE 8) (CREATIONDATE (GDATE (fetch IOFIBCreationTime of INFOBLOCK))) (READDATE (GDATE (fetch IOFIBReadTime of INFOBLOCK))) (WRITEDATE (GDATE (fetch IOFIBWriteTime of INFOBLOCK))) (ICREATIONDATE (fetch IOFIBCreationTime of INFOBLOCK)) (IREADDATE (fetch IOFIBReadTime of INFOBLOCK)) (IWRITEDATE (fetch IOFIBWriteTime of INFOBLOCK)) ((TYPE FILETYPE) (fetch IOFIBType of INFOBLOCK)) (EOL (SELECTC (fetch COREEOLC of INFOBLOCK) (CR.EOLC 'CR) (LF.EOLC 'LF) (CRLF.EOLC 'CRLF) (SHOULDNT))) NIL]) (\CORE.GETFILENAME [LAMBDA (NAME RECOG FD) (* ; "Edited 23-Oct-87 17:24 by bvm:") (LET (ROOT EXT VERS SCR CREATEFLG) (DECLARE (SPECVARS ROOT EXT VERS)) (\CORE.UNPACKFILENAME NAME) (* ; "Sets ROOT EXT and VERS freely") (if [AND [SETQ ROOT (CAR (OR (SETQ SCR (\CORE.NAMESCAN ROOT (fetch COREDIRECTORY of FD) CREATEFLG)) (\CORE.NAMESEGMENT ROOT] [SETQ EXT (CAR (OR (SETQ SCR (\CORE.NAMESCAN EXT SCR CREATEFLG)) (\CORE.NAMESEGMENT EXT] (COND [VERS (* ;  "Explicit version given--must be found, or RECOG must permit new file.") (OR (FASSOC VERS (CDR SCR)) (EQ RECOG 'OLD/NEW) (EQ RECOG 'NEW] (T (* ; "Default the version per RECOG") (SETQ SCR (CDR SCR)) (* ;  "Current versions, highest first. Each element is in the form (n . infoblock)") (SETQ VERS (SELECTQ RECOG (NEW (* ; "One higher than current highest") (ADD1 (OR (CAAR SCR) 0))) (OLD (CAAR SCR)) (OLDEST (CAAR (FLAST SCR))) (OLD/NEW (* ;  "Highest existing version, if any, else 1.") (OR (CAAR SCR) 1)) (SHOULDNT] then (\CORE.PACKFILENAME FD]) (\CORE.GETINFOBLOCK [LAMBDA (NAME RECOG FD CREATEFLG) (* rmk%: " 5-NOV-83 21:05") (COND ((type? STREAM NAME) (fetch INFOBLK of NAME)) (T (PROG (ROOT EXT VERS SCR INFOBLOCK NEWSTREAM) (DECLARE (SPECVARS ROOT EXT VERS)) (\CORE.UNPACKFILENAME NAME) (* ; "Sets ROOT EXT and VERS freely") (COND ((SETQ SCR (\CORE.NAMESCAN ROOT (fetch COREDIRECTORY of FD) CREATEFLG)) (SETQ ROOT (CAR SCR)) (* ;  "In case name completion occurred") ) (T (RETURN))) (COND ((SETQ SCR (\CORE.NAMESCAN EXT SCR CREATEFLG)) (SETQ EXT (CAR SCR))) (T (RETURN))) [COND [VERS (COND [(SETQ INFOBLOCK (CDR (FASSOC VERS (CDR SCR] (CREATEFLG (SETQ INFOBLOCK (create COREFILEINFOBLK IOFILEFULLNAME _ (\CORE.PACKFILENAME FD))) (for I on SCR when (OR (NOT (CDR I)) (IGREATERP VERS (CAADR I))) do (push (CDR I) (CONS VERS INFOBLOCK)) (RETURN] (T (SELECTQ (COND ((NEQ RECOG 'OLD/NEW) RECOG) ((CDR SCR) 'OLD) (T 'NEW)) (NEW (SETQ VERS (ADD1 (OR (CAAR (CDR SCR)) 0))) (SETQ INFOBLOCK (create COREFILEINFOBLK IOFILEFULLNAME _ (\CORE.PACKFILENAME FD))) (push (CDR SCR) (CONS VERS INFOBLOCK))) (OLD (SETQ INFOBLOCK (CDADR SCR))) (OLDEST (SETQ INFOBLOCK (CDAR (FLAST SCR)))) (SHOULDNT] (RETURN INFOBLOCK]) (\CORE.NAMESCAN [LAMBDA (NAME NAMELST CREATEFLG) (* ; "Edited 23-Oct-87 17:11 by bvm:") (COND ((LISTP NAMELST) (bind NEWSEG NEXTNAME while [AND (CDR NAMELST) (COND ((STRING-EQUAL (SETQ NEXTNAME (CAAR (CDR NAMELST) )) NAME) (* ; "Found it") (RETURN (CADR NAMELST))) (T (UALPHORDER NEXTNAME NAME] do (* ;  "Segments are in order, so stop when (CDR NAMELST) is lexicographically greater than NAME") (SETQ NAMELST (CDR NAMELST)) finally (RETURN (COND ((AND CREATEFLG (SETQ NEWSEG (  \CORE.NAMESEGMENT NAME))) (RPLACD NAMELST (CONS NEWSEG (CDR NAMELST))) NEWSEG]) (\CORE.NAMESEGMENT [LAMBDA (NAME) (* rmk%: "24-FEB-84 21:14") (* ;; "Checks that name is a valid name fragment and makes a list of it if so") (* ;; "Possibly we should check the validity of each character of NAME, but for the time being we just upper case it to merge together files spelt with different case letters.") (AND (NLISTP NAME) (LIST NAME]) (\CORE.OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 13-Jan-88 19:23 by bvm") (PROG (STREAM INFOBLK EOL) (AND OLDSTREAM (RETURN OLDSTREAM)) (* ;; "From REOPENFILE. Core files can't go away over logout, so just return old stream") (COND [(type? STREAM NAME) (COND ((NULL (fetch ACCESS of NAME)) (* ;; "A closed file to be re-opened by its stream") (SETQ INFOBLK (fetch INFOBLK of NAME)) [if (EQ ACCESS 'OUTPUT) then (* ;  "Open for OUTPUT implies no content, so smash any existing pages") (replace IOEOFFSET of INFOBLK with 0) (replace IOEPAGE of INFOBLK with 0) (replace IOFILEPAGES of INFOBLK with (LIST (create CORE.PAGEENTRY PAGENUMBER _ 0] (SETQ STREAM (create CORESTREAM smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK FULLFILENAME _ (fetch IOFILEFULLNAME of INFOBLK) EOFFSET _ (fetch IOEOFFSET of INFOBLK) EPAGE _ (fetch IOEPAGE of INFOBLK) EOLCONVENTION _ (fetch COREEOLC of INFOBLK) CBUFMAXSIZE _ BYTESPERPAGE))) ((\IOMODEP NAME ACCESS T) (* ;; "hdj - need we ever worry about being passed an already-open stream?") (RETURN NAME)) (T (\FILE.WONT.OPEN NAME] [(SETQ STREAM (\CORE.GETFILEHANDLE NAME RECOG FDEV ACCESS)) (COND ((NEQ ACCESS 'INPUT) (\COREFILE.SETPARAMETERS STREAM PARAMETERS)) ((SETQ EOL (ASSOC 'EOL PARAMETERS)) (* ;  "Set EOL for the input stream, in contradiction of whatever the file might have said.") (replace EOLCONVENTION of STREAM with (SELECTQ (CADR EOL) ((CR NIL) (* ; "default") CR.EOLC) (LF LF.EOLC) (CRLF CRLF.EOLC) (\ILLEGAL.ARG EOL] (T (* ;; "Head for not-found error in \OPENFILE") (RETURN NIL))) (\CORE.SETACCESSTIME STREAM ACCESS) (RETURN STREAM]) (\COREFILE.SETPARAMETERS [LAMBDA (STREAM PARAMETERS) (* ; "Edited 5-Nov-87 17:50 by sye") (for PAIR in PARAMETERS bind (INFOBLK _ (fetch INFOBLK of STREAM)) (TYPEFLG _ NIL) do (SELECTQ (CAR (LISTP PAIR)) (EOL [replace EOLCONVENTION of STREAM with (replace COREEOLC of INFOBLK with (SELECTQ (CADR PAIR) ((CR NIL) (* ; "default") CR.EOLC) (LF LF.EOLC) (CRLF CRLF.EOLC) (\ILLEGAL.ARG PAIR]) ((TYPE FILETYPE) (SETQ TYPEFLG T) (replace IOFIBType of INFOBLK with (CADR PAIR))) ((CREATIONDATE ICREATIONDATE) [replace IOFIBCreationTime of INFOBLK with (OR [FIXP (COND ((EQ (CAR PAIR) 'CREATIONDATE) (IDATE (CADR PAIR))) (T (CADR PAIR] (\ILLEGAL.ARG (CADR PAIR]) NIL) finally (OR (fetch IOFIBType of INFOBLK) TYPEFLG (replace IOFIBType of INFOBLK with DEFAULTFILETYPE ]) (\CORE.PACKFILENAME [LAMBDA (DEVICE) (DECLARE (USEDFREE ROOT EXT VERS)) (* ; "Edited 13-Jan-88 19:42 by bvm") (LET ((FULLNAME (CONCAT '{ (fetch (FDEV DEVICENAME) of DEVICE) '} ROOT '%. EXT '; VERS))) (if *UPPER-CASE-FILE-NAMES* then (MKATOM (U-CASE FULLNAME)) else FULLNAME]) (\CORE.RELEASEPAGES [LAMBDA (STREAM LP) (* rmk%: "23-SEP-83 16:02") (* ;  "Release all pages of the file beyond the last page") (OR LP (SETQ LP (fetch EPAGE of STREAM))) (for P in (fetch FILEPAGES of STREAM) when (ILESSP LP (fetch PAGENUMBER of P)) do (replace PAGEPOINTER of P with NIL]) (\CORE.SETFILEPTR [LAMBDA (STREAM INDX) (* bvm%: " 9-Jul-84 14:25") (\CORE.UPDATEOF STREAM) (* ;  "Update the EOF in case we have writen thru it") (PROG ((NEWPAGE (fetch (BYTEPTR PAGE) of INDX)) (NEWOFF (fetch (BYTEPTR OFFSET) of INDX))) (UNINTERRUPTABLY (COND ([OR (NEQ NEWPAGE (fetch CPAGE of STREAM)) (AND (APPENDONLY STREAM) (ILESSP NEWOFF (fetch COFFSET of STREAM] (* ;  "Force page release if ptr is going off the beaten path") (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL) (replace CPAGE of STREAM with NEWPAGE))) (replace COFFSET of STREAM with NEWOFF))]) (\CORE.UPDATEOF [LAMBDA (STREAM) (* bvm%: " 9-Jul-84 14:25") (* ;; "The EOF needs updating if we have written past the EOF. We check CBUFPTR to detect phony file positions from SETFILEPTR and TURNPAGE that were never actually written thru") (COND ([AND (fetch CBUFPTR of STREAM) (PROGN (* ;; "Determines if the current file ptr is BEYOND the end of file. Since page is loaded, we can test against the CBUFSIZE. As we are ignoring the equal case, we dont need the test for page numbers used by FASTEOF.") (IGREATERP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM] (UNINTERRUPTABLY (PROG ((OFF (fetch COFFSET of STREAM))) (COND ((IGEQ OFF BYTESPERPAGE) (add (fetch CPAGE of STREAM) (fetch (BYTEPTR PAGE) of OFF)) (replace COFFSET of STREAM with (SETQ OFF (fetch (BYTEPTR OFFSET) of OFF))) (replace CBUFPTR of STREAM with NIL))) (replace EPAGE of STREAM with (fetch CPAGE of STREAM)) (replace EOFFSET of STREAM with OFF) (replace CBUFSIZE of STREAM with OFF)))]) (\CORE.BACKFILEPTR [LAMBDA (STREAM) (* ; "Edited 5-Nov-87 16:58 by sye") (* ;  "also see similar function \DRIBBACKFILEPTR") [COND ((APPENDONLY STREAM) (LISPERROR "ILLEGAL ARG" (fetch (STREAM FULLNAME) of STREAM] (* ;  "Checks done separately so we dont take an error with interrupts off") (COND ((NOT (AND (EQ (fetch COFFSET of STREAM) 0) (EQ (fetch CPAGE of STREAM) 0))) (\CORE.UPDATEOF STREAM) (UNINTERRUPTABLY [replace COFFSET of STREAM with (COND ((EQ (fetch COFFSET of STREAM) 0) (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL) (add (fetch CPAGE of STREAM) -1) (SUB1 BYTESPERPAGE)) (T (SUB1 (fetch COFFSET of STREAM] [replace (STREAM CHARPOSITION) of STREAM with (IMAX 0 (SUB1 (fetch (STREAM CHARPOSITION ) of STREAM])]) (\CORE.SETEOFPTR [LAMBDA (STREAM NBYTES) (* bvm%: "13-Feb-85 23:26") (\CORE.UPDATEOF STREAM) (PROG [(NEWBYTES (IDIFFERENCE NBYTES (\GETEOFPTR STREAM] (RETURN (COND ((EQ NEWBYTES 0) (* ; "Nothing to do") T) ((OVERWRITEABLE STREAM) (UNINTERRUPTABLY [PROG ((NEWEP (fetch (BYTEPTR PAGE) of NBYTES)) (NEWEO (fetch (BYTEPTR OFFSET) of NBYTES))) (replace EPAGE of STREAM with NEWEP) (replace EOFFSET of STREAM with NEWEO) (replace CBUFSIZE of STREAM with (COND ((EQ NEWEP (fetch CPAGE of STREAM)) NEWEO) (T (replace CBUFPTR of STREAM with NIL) (* ; "Unmap noncurrent page") 0))) (COND ((ILESSP NEWBYTES 0) (* ; "File is shorter") (\ZEROBYTES (\CORE.FINDPAGE STREAM NEWEP) NEWEO (SUB1 BYTESPERPAGE)) (* ;  "Zero out the trailing fragment of the last page") (\CORE.RELEASEPAGES STREAM NEWEP]) T]) (\CORE.SETACCESSTIME [LAMBDA (STREAM ACCESS) (* rmk%: "23-SEP-83 14:38") (* ;; "Set the 'last read' and/or 'last written' times for a core file according to access.") (PROG ((DT (IDATE))) (SELECTQ ACCESS (INPUT (replace ReadTime of STREAM with DT)) (BOTH (replace ReadTime of STREAM with DT) (replace WriteTime of STREAM with DT)) ((OUTPUT APPEND) (replace WriteTime of STREAM with DT)) (SHOULDNT))) STREAM]) (\CORE.SETFILEINFO [LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* bvm%: "15-Jan-85 17:40") (PROG ((INFOBLOCK (\CORE.GETINFOBLOCK STREAM 'OLD DEV))) (SELECTQ ATTRIBUTE (CREATIONDATE (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (ICREATIONDATE (OR (FIXP VALUE) (LISPERROR "NON-NUMERIC ARG" VALUE))) NIL) (RETURN (AND INFOBLOCK (SELECTQ ATTRIBUTE ((TYPE FILETYPE) (replace IOFIBType of INFOBLOCK with VALUE)) (EOL (replace COREEOLC of INFOBLOCK with (SELECTQ VALUE (CR CR.EOLC) (LF LF.EOLC) (CRLF CRLF.EOLC) (LISPERROR "ILLEGAL ARG" VALUE)))) NIL]) (\CORE.GETNEXTBUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* ; "Edited 17-Sep-90 13:22 by jds") (* ;; "Advances STREAM to a new page. Leaves the current page pointer NIL as the new page may never be written, so must update eof. Returns T on success; any other return is a value to use by \BIN") (PROG ((CPAGE# (fetch CPAGE of STREAM)) (COFF (fetch COFFSET of STREAM)) EPAGE# COREBUF) [COND ((NOT (OPENED STREAM)) (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLNAME) of STREAM] (if (AND (ILESSP COFF (SELECTQ WHATFOR (READ (fetch CBUFSIZE of STREAM)) BYTESPERPAGE)) (fetch CBUFPTR of STREAM)) then (* ; " all OK, why were we called?") (SHOULDNT) (RETURN T)) (* ;; "Buffer exhausted or empty, prepare new one") (UNINTERRUPTABLY (* ; "Clean up current page") (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL) (if (EQ COFF BYTESPERPAGE) then (* ;  "Change to be first byte of next page instead of beyond last byte of previous page") (replace COFFSET of STREAM with (SETQ COFF 0)) (replace CPAGE of STREAM with (add CPAGE# 1)))) [COND ([AND (IGEQ CPAGE# (SETQ EPAGE# (fetch EPAGE of STREAM))) (OR (NEQ CPAGE# EPAGE#) (IGEQ COFF (fetch EOFFSET of STREAM] (* ;  "Current file pointer is at or past end of file") (SELECTQ WHATFOR (READ (RETURN (AND (NULL NOERRORFLG) (\EOF.ACTION STREAM)))) (WRITE (UNINTERRUPTABLY (replace EPAGE of STREAM with (SETQ EPAGE# CPAGE#)) (replace EOFFSET of STREAM with COFF))) (\ILLEGAL.ARG WHATFOR] (* ;; "Now fill the buffer -- map in current page") (SETQ COREBUF (\CORE.FINDPAGE STREAM CPAGE#)) (* ; "This is interruptable") (UNINTERRUPTABLY (* ;  "But these two fields must be set uninterruptably for benefit of ucode") (replace CBUFSIZE of STREAM with (COND ((ILESSP CPAGE# EPAGE#) (* ; "Full page") BYTESPERPAGE) ((EQ EPAGE# CPAGE#) (* ; "Last page") (fetch EOFFSET of STREAM)) (T (* ; "Beyond EOF so no data") 0))) (replace CBUFPTR of STREAM with COREBUF)) (COND (\INTERRUPTABLE (BLOCK))) (* ;  "Let someone else run. Useful for those long writings of scratch files.") (RETURN T]) (\CORE.UNPACKFILENAME [LAMBDA (NAME) (* ; "Edited 3-Nov-87 12:12 by bvm:") (* ;; "Breaks up a file name atom into its fields which it sets freely in its caller") (DECLARE (USEDFREE ROOT EXT VERS)) (PROG ((START (OR (AND (EQ (NTHCHAR NAME 1) '{) (STRPOS '} NAME NIL NIL NIL T)) 1)) (END (ADD1 (NCHARS NAME))) DOT SEMI) (SETQ DOT (STRPOS "." NAME START)) (SETQ SEMI (OR (STRPOS ";" NAME DOT) END)) (COND ((NULL DOT) (SETQ DOT SEMI))) (SETQ ROOT (OR (SUBSTRING NAME START (SUB1 DOT)) "")) (SETQ EXT (COND ((< DOT (- SEMI 1)) (SUBSTRING NAME (ADD1 DOT) (SUB1 SEMI))) (T (* ; "null extension.") ""))) (SETQ VERS (AND (< SEMI (- END 1)) (OR (FIXP (SUBATOM NAME (ADD1 SEMI))) (CL:ERROR 'XCL:INVALID-PATHNAME :PATHNAME NAME]) ) (DEFINEQ (COREDEVICE [LAMBDA (NAME NODIRFLG) (* rmk%: " 1-NOV-83 18:34") (\DEFINEDEVICE NAME (\CREATECOREDEVICE NAME NODIRFLG]) (\CREATECOREDEVICE [LAMBDA (NAME NODIRFLG) (* ; "Edited 14-Feb-99 13:57 by rmk:") (* ; "Edited 19-Feb-93 15:57 by jds") (* ;; "DIRECTORYNAMEP has to be fixed up. HOSTNAMEP is OK, cause each different host is defined by its own name. Creates a NODIRCORE device if NODIRFLG") (create FDEV FDBINABLE _ T FDBOUTABLE _ T FDEXTENDABLE _ T DEVICENAME _ NAME RESETABLE _ T RANDOMACCESSP _ T PAGEMAPPED _ NIL NODIRECTORIES _ T BUFFERED _ T CLOSEFILE _ (FUNCTION \CORE.CLOSEFILE) DELETEFILE _ (COND (NODIRFLG (FUNCTION NILL)) (T (FUNCTION \CORE.DELETEFILE))) GETFILEINFO _ (FUNCTION \CORE.GETFILEINFO) OPENFILE _ (COND (NODIRFLG (FUNCTION \NODIRCORE.OPENFILE)) (T (FUNCTION \CORE.OPENFILE))) READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION \CORE.SETFILEINFO) TRUNCATEFILE _ (FUNCTION \CORE.RELEASEPAGES) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ (COND (NODIRFLG (FUNCTION NILL)) (T (FUNCTION \CORE.GETFILENAME))) REOPENFILE _ (COND [NODIRFLG (FUNCTION (LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) OLDSTREAM] (T (FUNCTION \CORE.OPENFILE))) GENERATEFILES _ (COND (NODIRFLG (FUNCTION \NULLFILEGENERATOR)) (T (FUNCTION \CORE.GENERATEFILES))) EVENTFN _ (FUNCTION NILL) DEVICEINFO _ (AND (NOT NODIRFLG) (LIST 'CoreFiles)) DIRECTORYNAMEP _ (COND (NODIRFLG (FUNCTION NILL)) (T (*  #.(SEDIT::MAKE-BROKEN-ATOM "WAS:")  FUNCTION TRUE) (FUNCTION \CORE.DIRECTORYNAMEP))) HOSTNAMEP _ (FUNCTION NILL) READP _ (FUNCTION \GENERIC.READP) BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) BACKFILEPTR _ (FUNCTION \CORE.BACKFILEPTR) SETFILEPTR _ (FUNCTION \CORE.SETFILEPTR) GETFILEPTR _ (FUNCTION \PAGEDGETFILEPTR) GETEOFPTR _ (FUNCTION \PAGEDGETEOFPTR) SETEOFPTR _ (FUNCTION \CORE.SETEOFPTR) EOFP _ (FUNCTION \PAGEDEOFP) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \BUFFERED.BOUTS) FORCEOUTPUT _ (FUNCTION NILL) GETNEXTBUFFER _ (FUNCTION \CORE.GETNEXTBUFFER) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (COND (NODIRFLG (FUNCTION NILL)) (T (FUNCTION \ADD-OPEN-STREAM))) UNREGISTERFILE _ (COND (NODIRFLG (FUNCTION NILL)) (T (FUNCTION \GENERIC-UNREGISTER-STREAM]) ) (DEFINEQ (\NODIRCOREFDEV [LAMBDA (NAME READPFN) (* rmk%: " 1-NOV-83 18:33") (* ;; "Creates a core device with no directory structure--files can't be found from names, only by saving a pointer to the stream. This is used for linebuffers and perhaps other internal printing. The essential property is that the stream gets collected when it is no longer referenced.") (PROG ((FDEV (\CREATECOREDEVICE NAME T))) (AND READPFN (replace READP of FDEV with READPFN)) (\DEFINEDEVICE NAME FDEV) (RETURN FDEV]) (\NODIRCORE.OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV) (* lmm "24-May-85 11:59") (* ; "Open function for NODIRCORE") (COND [(type? STREAM NAME) (COND ((fetch ACCESS of NAME) (OR (\IOMODEP NAME ACCESS T) (\FILE.WONT.OPEN NAME))) (T (PROG ((INFOBLK (fetch INFOBLK of NAME))) (* ;; "We'll return the stream that was given us, but we make sure that all its fields are back to their initial settings") (create CORESTREAM smashing NAME DEVICE _ FDEV INFOBLK _ INFOBLK FULLFILENAME _ (fetch IOFILEFULLNAME of INFOBLK) EOFFSET _ (fetch IOEOFFSET of INFOBLK) EPAGE _ (fetch IOEPAGE of INFOBLK) EOLCONVENTION _ (fetch COREEOLC of INFOBLK) CBUFMAXSIZE _ BYTESPERPAGE] (T (SELECTQ RECOG ((NEW OLD/NEW) (SETQ NAME (create CORESTREAM DEVICE _ FDEV INFOBLK _ (create COREFILEINFOBLK) CBUFMAXSIZE _ BYTESPERPAGE))) (\FILE.WONT.OPEN NAME)) (\COREFILE.SETPARAMETERS NAME PARAMETERS))) (\CORE.SETACCESSTIME NAME ACCESS) NAME]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD CORE.PAGEENTRY (PAGENUMBER . PAGEPOINTER)) (DATATYPE COREFILEINFOBLK ((IOFIBCreationTime FIXP) (IOFIBReadTime FIXP) (IOFIBWriteTime FIXP) (IOFIBType POINTER) (IOFILEPAGES POINTER) (IOFILEFULLNAME POINTER) (IOEPAGE WORD) (IOEOFFSET WORD) (COREEOLC BITS 2) (IOFIBFileType WORD)) IOFIBCreationTime _ (IDATE) IOFILEPAGES _ (LIST (create CORE.PAGEENTRY PAGENUMBER _ 0)) COREEOLC _ CR.EOLC) (RECORD CORESTREAM STREAM (SUBRECORD STREAM) [ACCESSFNS CORESTREAM ((INFOBLK (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (COREPAGECACHE (fetch F10 of DATUM) (replace F10 of DATUM with NEWVALUE)) (BEINGPRINTED (fetch IOBEINGPRINTED of (fetch INFOBLK of DATUM)) (replace IOBEINGPRINTED of (fetch INFOBLK of DATUM) with NEWVALUE)) (FILEPAGES (fetch IOFILEPAGES of (fetch INFOBLK of DATUM)) (replace IOFILEPAGES of (fetch INFOBLK of DATUM) with NEWVALUE)) (CreationTime (fetch IOFIBCreationTime of (fetch INFOBLK of DATUM)) (replace IOFIBCreationTime of (fetch INFOBLK of DATUM) with NEWVALUE)) (ReadTime (fetch IOFIBReadTime of (fetch INFOBLK of DATUM)) (replace IOFIBReadTime of (fetch INFOBLK of DATUM) with NEWVALUE)) (WriteTime (fetch IOFIBWriteTime of (fetch INFOBLK of DATUM)) (replace IOFIBWriteTime of (fetch INFOBLK of DATUM) with NEWVALUE]) (ACCESSFNS COREDEVICE ((COREDIRECTORY (FETCH DEVICEINFO OF DATUM) (REPLACE DEVICEINFO OF DATUM WITH NEWVALUE)))) (RECORD COREGENFILESTATE (COREFILELST)) ) (/DECLAREDATATYPE 'COREFILEINFOBLK '(FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD) '((COREFILEINFOBLK 0 FIXP) (COREFILEINFOBLK 2 FIXP) (COREFILEINFOBLK 4 FIXP) (COREFILEINFOBLK 6 POINTER) (COREFILEINFOBLK 8 POINTER) (COREFILEINFOBLK 10 POINTER) (COREFILEINFOBLK 12 (BITS . 15)) (COREFILEINFOBLK 13 (BITS . 15)) (COREFILEINFOBLK 10 (BITS . 1)) (COREFILEINFOBLK 14 (BITS . 15))) '16) ) (/DECLAREDATATYPE 'COREFILEINFOBLK '(FIXP FIXP FIXP POINTER POINTER POINTER WORD WORD (BITS 2) WORD) '((COREFILEINFOBLK 0 FIXP) (COREFILEINFOBLK 2 FIXP) (COREFILEINFOBLK 4 FIXP) (COREFILEINFOBLK 6 POINTER) (COREFILEINFOBLK 8 POINTER) (COREFILEINFOBLK 10 POINTER) (COREFILEINFOBLK 12 (BITS . 15)) (COREFILEINFOBLK 13 (BITS . 15)) (COREFILEINFOBLK 10 (BITS . 1)) (COREFILEINFOBLK 14 (BITS . 15))) '16) (DECLARE%: DONTEVAL@LOAD DOCOPY (COREDEVICE 'NODIRCORE T) (COREDEVICE 'CORE) (COREDEVICE 'SCRATCH T) ) (DECLARE%: DOEVAL@LOAD DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS COREIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1993 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1755 43279 (\CORE.CLOSEFILE 1765 . 2538) (\CORE.DELETEFILE 2540 . 4526) ( \CORE.DIRECTORYNAMEP 4528 . 4789) (\CORE.FINDPAGE 4791 . 8020) (\CORE.GENERATEFILES 8022 . 10609) ( \CORE.NEXTFILEFN 10611 . 11110) (\CORE.FILEINFOFN 11112 . 11341) (\CORE.GETFILEHANDLE 11343 . 13497) ( \CORE.GETFILEINFO 13499 . 14462) (\CORE.GETFILEINFO.FROM.INFOBLOCK 14464 . 16001) (\CORE.GETFILENAME 16003 . 18292) (\CORE.GETINFOBLOCK 18294 . 20917) (\CORE.NAMESCAN 20919 . 22686) (\CORE.NAMESEGMENT 22688 . 23125) (\CORE.OPENFILE 23127 . 26246) (\COREFILE.SETPARAMETERS 26248 . 28429) ( \CORE.PACKFILENAME 28431 . 28826) (\CORE.RELEASEPAGES 28828 . 29429) (\CORE.SETFILEPTR 29431 . 30530) (\CORE.UPDATEOF 30532 . 32161) (\CORE.BACKFILEPTR 32163 . 34371) (\CORE.SETEOFPTR 34373 . 36242) ( \CORE.SETACCESSTIME 36244 . 36869) (\CORE.SETFILEINFO 36871 . 38062) (\CORE.GETNEXTBUFFER 38064 . 42020) (\CORE.UNPACKFILENAME 42022 . 43277)) (43280 46913 (COREDEVICE 43290 . 43461) ( \CREATECOREDEVICE 43463 . 46911)) (46914 49215 (\NODIRCOREFDEV 46924 . 47521) (\NODIRCORE.OPENFILE 47523 . 49213))))) STOP \ No newline at end of file diff --git a/sources/COROUTINE b/sources/COROUTINE new file mode 100644 index 00000000..6d8cb8f5 --- /dev/null +++ b/sources/COROUTINE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:10:30" |{DSK}local>lde>lispcore>sources>COROUTINE.;2| 10064 |changes| |to:| (VARS COROUTINECOMS) |previous| |date:| " 4-Dec-86 05:03:32" |{DSK}local>lde>lispcore>sources>COROUTINE.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT COROUTINECOMS) (RPAQQ COROUTINECOMS ((I.S.OPRS OUTOF) (OPTIMIZERS COROUTINE GENERATOR POSSIBILITIES TRYNEXT) (PROP (MACRO INFO) COROUTINE GENERATOR TRYNEXT POSSIBILITIES) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE) (LAMA AU-REVOIR ADIEU))) (FNS COROUTINE GENERATOR GENERATE PRODUCE GENERATEFN) (FNS ADIEU AU-REVOIR CLEANPOSLST NOTE POSSIBILITIES TRYNEXT TRYNEXT1 POSSIBILITYFN) (ADDVARS (SYSSPECVARS COMVAR## POSSLIST##)) (PROP FILETYPE COROUTINE))) (DECLARE\: EVAL@COMPILE (I.S.OPR 'OUTOF NIL '(SUBST (GENSYM) 'GENVAR '(BIND GENVAR _ (GENERATOR BODY) EACHTIME (COND ((EQ (SETQ I.V. (GENERATE GENVAR)) GENVAR) (GO $$OUT))) FINALLY (RELSTK (CDR GENVAR)))) T) ) (DEFOPTIMIZER COROUTINE (P1 P2 F1 F2) `(PROGN (OR (STACKP ,P1) (SETQ ,P1 (STKNTH 0 T))) (OR (STACKP ,P2) (SETQ ,P2 (STKNTH 0 T))) ((LAMBDA (..MACROX.) (COND ((EQ ..MACROX. ,P2) ,P2) (T (RESUME ,P2 ..MACROX. ,P2) ,F1 (RETTO ,P1 ,F2 T)))) (STKNTH -1)))) (DEFOPTIMIZER GENERATOR (FORM COMVAR) `(GENERATEFN (FUNCTION (LAMBDA NIL ,FORM)) ,COMVAR)) (DEFOPTIMIZER POSSIBILITIES (FORM) `(POSSIBILITYFN (FUNCTION (LAMBDA NIL ,FORM)))) (DEFOPTIMIZER TRYNEXT (PLST NOMORE MSG) `(COND ((SETQ ,PLST (TRYNEXT1 ,PLST ,MSG)) (PROG1 (CAR ,PLST) (SETQ ,PLST (CDR ,PLST)))) (T (SETQ ,PLST (CDR ,PLST)) ,NOMORE))) (PUTPROPS COROUTINE MACRO ((P1 P2 F1 F2) (PROGN (OR (STACKP P1) (SETQ P1 (STKNTH 0 T))) (OR (STACKP P2) (SETQ P2 (STKNTH 0 T))) ((LAMBDA (..MACROX.) (COND ((EQ ..MACROX. P2) P2) (T (RESUME P2 ..MACROX. P2) F1 (RETTO P1 F2 T)))) (STKNTH -1))))) (PUTPROPS GENERATOR MACRO ((FORM COMVAR) (GENERATEFN (FUNCTION (LAMBDA NIL FORM)) COMVAR))) (PUTPROPS TRYNEXT MACRO ((PLST NOMORE MSG) (COND ((SETQ PLST (TRYNEXT1 PLST MSG)) (PROG1 (CAR PLST) (SETQ PLST (CDR PLST)))) (T (SETQ PLST (CDR PLST)) NOMORE)))) (PUTPROPS POSSIBILITIES MACRO ((FORM) (POSSIBILITYFN (FUNCTION (LAMBDA NIL FORM))))) (PUTPROPS COROUTINE INFO EVAL) (PUTPROPS GENERATOR INFO EVAL) (PUTPROPS TRYNEXT INFO EVAL) (PUTPROPS POSSIBILITIES INFO EVAL) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML TRYNEXT POSSIBILITIES GENERATOR COROUTINE) (ADDTOVAR LAMA AU-REVOIR ADIEU) ) (DEFINEQ (coroutine (nlambda (callptr## coroutptr## coroutform## endform##) (* |wt:| 17-apr-76 19 48) (* callptr## |and| coroutptr## are |the| |names| |of| |communication|  |variables| |in| |the| |function| |calling| coroutine.  |They| |will| |be| |set| |to| |stkptrs| |if| |they| are |not| |already| |ones.|  coroutform## |is| |the| |form| |which| |starts| |the| coroutine.  endform## |is| |evaluated| |in| |the| |context| |of| |the| |caller| |when|  coroutform## |returns.|) (setq callptr## (set callptr## (or (stackp (evalv callptr##)) (stknth 0 t)))) (setq coroutptr## (set coroutptr## (or (stackp (evalv coroutptr##)) (stknth 0 t)))) (resume coroutptr## (stknth -1 'coroutine) coroutptr##) (eval coroutform##) (retto callptr## (enveval endform## (stknth -1 'coroutine) nil t) t))) (generator (nlambda (form## comvar##) (cond (comvar## (setq comvar## (eval comvar##)))) (cond ((nlistp comvar##) (setq comvar## (cons (stknth 0 t) (stknth 0 t)))) (t (cond ((not (stackp (car comvar##))) (frplaca comvar## (stknth 0 t)))) (cond ((not (stackp (cdr comvar##))) (frplacd comvar## (stknth 0 t)))))) (resume (cdr comvar##) (stknth -1 'generator (car comvar##)) comvar##) (eval form##) (retto (car comvar##) comvar## t))) (generate (lambda (handle val) (resume (car handle) (cdr handle) val))) (produce (lambda (val) (resume (cdr comvar##) (car comvar##) val))) (generatefn (lambda (fn comvar##) (declare (specvars comvar##)) (* |lmm:| "11-FEB-77 15:51:34") (cond ((nlistp comvar##) (setq comvar## (cons (stknth 0 t) (stknth 0 t)))) (t (cond ((not (stackp (car comvar##))) (frplaca comvar## (stknth 0 t)))) (cond ((not (stackp (cdr comvar##))) (frplacd comvar## (stknth 0 t)))))) (resume (cdr comvar##) (stknth -1 'generatefn (car comvar##)) comvar##) (apply* fn) (retto (car comvar##) comvar## t))) ) (DEFINEQ (adieu (lambda val## (cond ((not (zerop val##)) (note (arg val## 1)))) (retto (car comvar##) (prog1 posslist## (setq posslist## nil)) t))) (au-revoir (lambda val## (cond ((not (zerop val##)) (note (arg val## 1)))) (note comvar##) (resume (cdr comvar##) (car comvar##) (prog1 posslist## (setq posslist## nil))))) (cleanposlst (lambda (plst) (|for| x |in| plst |do| (cond ((and (listp x) (stackp (car x))) (relstk (car x)) (relstk (cdr x))))))) (note (lambda (val lstflg) (setq posslist## (nconc posslist## (cond (lstflg val) (t (list val))))))) (possibilities (nlambda (form##) (* dd\: " 5-Oct-81 17:08") (prog (comvar## posslist##) (produce (list (setq comvar## (cons (stknth -1 'possibilities) (stknth 0 t))))) (eval form##) (adieu)))) (trynext (nlambda (plst## endform## val##) (prog (pl1##) (set plst## (cdr (setq pl1## (trynext1 (eval plst##) (eval val##))))) (cond ((null pl1##) (reteval 'trynext endform##)) (t (return (car pl1##))))))) (trynext1 (lambda (plst## msg##) (prog (pl1##) lp (cond ((null plst##) (return nil))) (setq pl1## (car plst##)) (cond ((or (nlistp pl1##) (not (stackp (car pl1##)))) (return plst##))) (setq plst## (nconc (resume (car pl1##) (cdr pl1##) msg##) (cdr plst##))) (go lp)))) (possibilityfn (lambda (fn comvar## posslist##) (declare (localvars fn) (specvars comvar## posslist##)) (* |lmm:| "11-FEB-77 15:58:48") (produce (list (setq comvar## (cons (stknth -1 'possibilityfn) (stknth 0 t))))) (apply* fn) (adieu))) ) (ADDTOVAR SYSSPECVARS COMVAR## POSSLIST##) (PUTPROPS COROUTINE FILETYPE CL:COMPILE-FILE) (PUTPROPS COROUTINE COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4908 7425 (COROUTINE 4918 . 5952) (GENERATOR 5954 . 6565) (GENERATE 6567 . 6670) ( PRODUCE 6672 . 6771) (GENERATEFN 6773 . 7423)) (7426 9867 (ADIEU 7436 . 7629) (AU-REVOIR 7631 . 7866) (CLEANPOSLST 7868 . 8152) (NOTE 8154 . 8348) (POSSIBILITIES 8350 . 8685) (TRYNEXT 8687 . 9012) ( TRYNEXT1 9014 . 9515) (POSSIBILITYFN 9517 . 9865))))) STOP \ No newline at end of file diff --git a/sources/COURIER b/sources/COURIER new file mode 100644 index 00000000..36c02a09 --- /dev/null +++ b/sources/COURIER @@ -0,0 +1,751 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 2-Nov-93 13:53:08" |{PELE:MV:ENVOS}SOURCES>COURIER.;5| 75006 + + changes to%: (FNS \MAKE.EXPEDITED.STREAM \COURIER.BROADCAST.ON.NET) + + previous date%: "28-Apr-92 17:35:17" |{PELE:MV:ENVOS}SOURCES>COURIER.;4|) + + +(* ; " +Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT COURIERCOMS) + +(RPAQQ COURIERCOMS + [(COMS (* ; "COURIER Protocol") + (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * COURIERDECLS)) + (COMS (* ; "COURIERPROGRAMS type") + (INITVARS (\COURIERPROGRAM (HARRAY 20))) + (GLOBALVARS \COURIERPROGRAM) + (FILEPKGCOMS COURIERPROGRAMS) + (FNS COURIER.VERSION# COURIERPROGRAM \COURIER.CHECKDEF \COURIER.CHECK.PROCEDURES + \COURIER.CHECK.ERRORS \COURIER.DELDEF \COURIER.GETDEF \COURIER.PUTDEF + \DUMP.COURIERPROGRAMS) + (FNS \GET.COURIER.TYPE \GET.COURIER.DEFINITION)) + (COMS (* ; "COURIER record access") + (MACROS COURIER.FETCH COURIER.CREATE) + (PROP INFO COURIER.FETCH COURIER.CREATE) + (FNS \COURIER.RECORDTRAN)) + (COMS (* ; "COURIER calls and returns") + (FUNCTIONS STREAMTYPECASE) + (FNS COURIER.OPEN \COURIER.WHENCLOSED COURIER.CALL COURIER.EXECUTE.CALL + \COURIER.RESULTS COURIER.SIGNAL.ERROR \COURIER.HANDLE.BULKDATA + \COURIER.HANDLE.ERROR \BULK.DATA.STREAM \COURIER.ATTENTIONFN + \COURIER.OUTPUT.ABORTED \BULK.DATA.CLOSE \ABORT.BULK.DATA)) + (FNS COURIER.EXPEDITED.CALL COURIER.EXECUTE.EXPEDITED.CALL \BUILD.EXPEDITED.XIP + \SEND.EXPEDITED.XIP \COURIER.EXPEDITED.ARGS \MAKE.EXPEDITED.STREAM \COURIER.EOF + \COURIER.EXPEDITED.OVERFLOW) + (FNS COURIER.BROADCAST.CALL \COURIER.BROADCAST.ON.NET) + (FNS COURIER.READ \COURIER.UNKNOWN.TYPE COURIER.READ.SEQUENCE COURIER.READ.STRING + COURIER.WRITE COURIER.WRITE.SEQUENCE COURIER.WRITE.STRING COURIER.WRITE.FAT.STRING + COURIER.SKIP COURIER.SKIP.SEQUENCE \COURIER.TYPE.ERROR DECODE-NS-STRING) + (FNS COURIER.READ.BULKDATA BULKDATA.GENERATOR BULKDATA.GENERATE.NEXT + COURIER.WRITE.BULKDATA COURIER.ABORT.BULKDATA) + (COMS (* ; + "Reading/writing sequence unspecified in an interesting way") + (FNS COURIER.READ.REP COURIER.WRITE.REP COURIER.WRITE.SEQUENCE.UNSPECIFIED + \CWSU.DEFAULT COURIER.REP.LENGTH \MAKE.COURIER.REP.STREAM \COURIER.REP.BIN + \COURIER.REP.BOUT) + (INITVARS \COURIER.REP.DEVICE)) + (COMS (FNS COURIER.READ.NSADDRESS COURIER.WRITE.NSADDRESS) + (PROP COURIERDEF NSADDRESS))) + (COMS (* ; "Debugging") + (INITVARS (COURIERTRACEFILE) + (COURIERTRACEFLG) + (COURIERPRINTLEVEL '(2 . 4)) + (NSWIZARDFLG)) + (GLOBALVARS COURIERTRACEFLG COURIERTRACEFILE COURIERPRINTLEVEL NSWIZARDFLG) + (FNS COURIERTRACE \COURIER.TRACE)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA + \DUMP.COURIERPROGRAMS + COURIERPROGRAM) + (NLAML) + (LAMA + COURIER.EXPEDITED.CALL + COURIER.CALL]) + + + +(* ; "COURIER Protocol") + +(DECLARE%: EVAL@COMPILE DONTCOPY + +(RPAQQ COURIERDECLS + ((DECLARE%: EVAL@COMPILE (FILES (SOURCE) + LLNSDECLS SPPDECLS)) + (CONSTANTS (COURIER.VERSION# 3)) + (CONSTANTS (\COURIERMSG.CALL 0) + (\COURIERMSG.REJECT 1) + (\COURIERMSG.RETURN 2) + (\COURIERMSG.ABORT 3)) + (CONSTANTS (\NS.WKS.Courier 5)) + (MACROS \GET.COURIERPROGRAM \COURIER.QUALIFIED.NAMEP NULLORLISTP) + (RECORDS COURIERPGM COURIERFN COURIERERR \BULK.DATA.CONTINUATION COURIERREPSTREAM + BULKDATAGENERATOR) + (GLOBALVARS LCASEFLG \COURIER.REP.DEVICE \BASEBYTESDEVICE) + (COMS (CONSTANTS (\EXPEDITED.LENGTH (IPLUS \XIPOVLEN 6 4)) + \EXTYPE.EXPEDITED.COURIER) + (RECORDS EXPEDITEDXIP)))) +(DECLARE%: EVAL@COMPILE + +(FILESLOAD (SOURCE) + LLNSDECLS SPPDECLS) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ COURIER.VERSION# 3) + + +(CONSTANTS (COURIER.VERSION# 3)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \COURIERMSG.CALL 0) + +(RPAQQ \COURIERMSG.REJECT 1) + +(RPAQQ \COURIERMSG.RETURN 2) + +(RPAQQ \COURIERMSG.ABORT 3) + + +(CONSTANTS (\COURIERMSG.CALL 0) + (\COURIERMSG.REJECT 1) + (\COURIERMSG.RETURN 2) + (\COURIERMSG.ABORT 3)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \NS.WKS.Courier 5) + + +(CONSTANTS (\NS.WKS.Courier 5)) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \GET.COURIERPROGRAM MACRO ((PROGRAM) + (GETHASH PROGRAM \COURIERPROGRAM))) + +(PUTPROPS \COURIER.QUALIFIED.NAMEP MACRO [OPENLAMBDA (X) + (AND (LISTP X) + (LITATOM (CDR X)) + (LITATOM (CAR X]) + +(PUTPROPS NULLORLISTP MACRO (OPENLAMBDA (X) + (OR (NULL X) + (LISTP X)))) +) +(DECLARE%: EVAL@COMPILE + +(RECORD COURIERPGM (VERSIONPAIR . COURIERDEFS) + (RECORD VERSIONPAIR (PROGRAM# VERSION#)) + (PROPRECORD COURIERDEFS (TYPES PROCEDURES ERRORS INHERITS))) + +(RECORD COURIERFN (FN# ARGS RETURNSNOISE RESULTS REPORTSNOISE ERRORS)) + +(RECORD COURIERERR (ERR# ARGS)) + +(RECORD \BULK.DATA.CONTINUATION (PROGRAM PROCEDURE PGMDEF PROCDEF NOERRORFLG INTERNALFLG)) + +(ACCESSFNS COURIERREPSTREAM ((CRWORDLIST (fetch F1 of DATUM) + (replace F1 of DATUM with NEWVALUE)) + (CRNEXTBYTE (fetch F2 of DATUM) + (replace F2 of DATUM with NEWVALUE)) + (CRLASTWORD (fetch F3 of DATUM) + (replace F3 of DATUM with NEWVALUE)))) + +(RECORD BULKDATAGENERATOR (BGITEMSLEFT BGSTREAM (BGPROGRAM . BGTYPE) . BGLASTSEGMENT?)) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS LCASEFLG \COURIER.REP.DEVICE \BASEBYTESDEVICE) +) +(DECLARE%: EVAL@COMPILE + +(RPAQ \EXPEDITED.LENGTH (IPLUS \XIPOVLEN 6 4)) + +(RPAQQ \EXTYPE.EXPEDITED.COURIER 2) + + +(CONSTANTS (\EXPEDITED.LENGTH (IPLUS \XIPOVLEN 6 4)) + \EXTYPE.EXPEDITED.COURIER) +) +(DECLARE%: EVAL@COMPILE + +(ACCESSFNS EXPEDITEDXIP ((EXPEDITEDBASE (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) + of DATUM))) + (BLOCKRECORD EXPEDITEDBASE ((LOWVERSION WORD) + (HIGHVERSION WORD) + (MSGTYPE WORD) + (TRANSACTIONID WORD) + (PROGRAM# FIXP) + (VERSION# WORD) + (PROCEDURE# WORD) + (ARG0 WORD))) + [ACCESSFNS EXPEDITEDXIP ((EXPEDITEDMSGBODY (LOCF (fetch (EXPEDITEDXIP + MSGTYPE) + of DATUM))) + (EXPEDITEDARGBASE (LOCF (fetch (EXPEDITEDXIP + ARG0) + of DATUM]) +) +) + + + +(* ; "COURIERPROGRAMS type") + + +(RPAQ? \COURIERPROGRAM (HARRAY 20)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \COURIERPROGRAM) +) +(PUTDEF (QUOTE COURIERPROGRAMS) (QUOTE FILEPKGCOMS) '((COM MACRO (X (E (\DUMP.COURIERPROGRAMS . X))) + CONTENTS NILL) + (TYPE DESCRIPTION "Courier programs" GETDEF + \COURIER.GETDEF DELDEF \COURIER.DELDEF + PUTDEF \COURIER.PUTDEF))) +(DEFINEQ + +(COURIER.VERSION# +(LAMBDA NIL (* bvm%: " 2-May-84 12:27") (* ;;; "Returns number of the version of Courier we are running") COURIER.VERSION#) +) + +(COURIERPROGRAM +(NLAMBDA X (* bvm%: "10-Jun-84 23:02") (* ;; "Define a Courier program and its associated types, constants, procedures, and errors. Syntax is (COURIERPROGRAM programName (programNumber versionNumber) TYPES (typeDeclarations ...) PROCEDURES (procedureDeclarations ...) ERRORS (errorDeclarations ...)) The TYPES, PROCEDURES, and ERRORS may appear in any order after the program number/version number pair.") (PUTDEF (CAR X) (QUOTE COURIERPROGRAMS) (CDR X))) +) + +(\COURIER.CHECKDEF +(LAMBDA (NAME DEF) (* bvm%: "16-Jul-84 15:36") (COND ((OR (NLISTP (fetch (COURIERPGM VERSIONPAIR) of DEF)) (NOT (FIXP (fetch (COURIERPGM PROGRAM#) of DEF))) (NOT (FIXP (fetch (COURIERPGM VERSION#) of DEF)))) (ERROR "Bad version specification in Courier def" NAME)) (T (for TAIL on (fetch COURIERDEFS of DEF) by (CDDR TAIL) do (SELECTQ (CAR TAIL) ((TYPES INHERITS)) (PROCEDURES (\COURIER.CHECK.PROCEDURES (CADR TAIL))) (ERRORS (\COURIER.CHECK.ERRORS (CADR TAIL))) (ERROR "Courier definition not understood" (CAR TAIL))))))) +) + +(\COURIER.CHECK.PROCEDURES +(LAMBDA (DEFS) (* bvm%: "12-Oct-84 11:24") (for FNDEF in DEFS bind INFO unless (COND ((NLISTP FNDEF) NIL) ((EQ (CAR FNDEF) COMMENTFLG) (* ; "Comments ok") T) (T (SETQ INFO (CDR FNDEF)) (COND ((AND (FIXP (fetch (COURIERFN FN#) of INFO)) (NULLORLISTP (fetch (COURIERFN ARGS) of INFO)) (LITATOM (fetch (COURIERFN RETURNSNOISE) of INFO)) (NULLORLISTP (fetch (COURIERFN RESULTS) of INFO)) (LITATOM (fetch (COURIERFN REPORTSNOISE) of INFO)) (NULLORLISTP (fetch (COURIERFN ERRORS) of INFO))) (* ; "nice new format") T) (T (PROG (ARGS RESULTS ERRORS N) (RETURN (COND ((while INFO do (COND ((NULL (CDR INFO)) (RETURN (FIXP (SETQ N (CAR INFO))))) (T (SELECTQ (CAR INFO) (ARGS (OR (NULLORLISTP (SETQ ARGS (CADR INFO))) (RETURN))) (RESULTS (OR (NULLORLISTP (SETQ RESULTS (CADR INFO))) (RETURN))) (ERRORS (OR (NULLORLISTP (SETQ ERRORS (CADR INFO))) (RETURN))) (RETURN)) (SETQ INFO (CDDR INFO))))) (/RPLACD FNDEF (create COURIERFN FN# _ N ARGS _ ARGS RETURNSNOISE _ (QUOTE RETURNS) RESULTS _ RESULTS REPORTSNOISE _ (QUOTE REPORTS) ERRORS _ ERRORS)) T)))))))) do (ERROR "Bad Courier Procedure definition" FNDEF))) +) + +(\COURIER.CHECK.ERRORS +(LAMBDA (DEFS) (* bvm%: "12-Oct-84 11:24") (for ERRDEF in DEFS bind INFO unless (COND ((NLISTP ERRDEF) NIL) ((EQ (CAR ERRDEF) COMMENTFLG) (* ; "Comments ok") T) (T (SETQ INFO (CDR ERRDEF)) (COND ((AND (FIXP (fetch (COURIERERR ERR#) of INFO)) (NULLORLISTP (fetch (COURIERERR ARGS) of INFO))) (* ; "nice new format") T) (T (COND ((AND (EQ (CAR INFO) (QUOTE ARGS)) (NULLORLISTP (CADR INFO)) (FIXP (CADDR INFO))) (* ; "Old format") (/RPLACD ERRDEF (create COURIERERR ERR# _ (CADDR INFO) ARGS _ (CADR INFO))) T)))))) do (ERROR "Bad Courier Error definition" ERRDEF))) +) + +(\COURIER.DELDEF +(LAMBDA (NAME TYPE) (* bvm%: "15-Jun-84 15:34") (AND (EQ TYPE (QUOTE COURIERPROGRAMS)) (PUTHASH NAME NIL \COURIERPROGRAM))) +) + +(\COURIER.GETDEF +(LAMBDA (NAME TYPE OPTIONS) (* bvm%: " 4-Jul-84 15:44") (AND (EQ TYPE (QUOTE COURIERPROGRAMS)) (\GET.COURIERPROGRAM NAME))) +) + +(\COURIER.PUTDEF +(LAMBDA (NAME TYPE DEFINITION) (* ; "Edited 15-Jun-88 12:13 by drc:") (* ;;; "PUTDEF for type COURIERPROGRAMS -- also called by COURIERPROGRAM") (PROG (OLDINFO) (SETQ OLDINFO (GETHASH (SETQ NAME (\DTEST NAME (QUOTE LITATOM))) \COURIERPROGRAM)) (COND ((NULL OLDINFO) (MARKASCHANGED NAME TYPE (QUOTE DEFINED))) ((AND OLDINFO (NOT (EQUAL OLDINFO DEFINITION))) (COND ((NEQ DFNFLG T) (EXEC-FORMAT "(Courier program ~S redefined)~%%" NAME))) (MARKASCHANGED NAME TYPE (QUOTE CHANGED)))) (/PUTHASH NAME DEFINITION \COURIERPROGRAM) (RETURN NAME))) +) + +(\DUMP.COURIERPROGRAMS +(NLAMBDA NAMES (* bvm%: " 3-Oct-86 14:20") (* ;; "Used by the COURIERPROGRAMS filepkgcom") (for PROGRAM in NAMES bind PGMDEF do (COND ((SETQ PGMDEF (\GET.COURIERPROGRAM PROGRAM)) (TERPRI) (* ;; "because if you have a really bold font, it lines up the bottoms, but you can get crowded into the line above.") (printout NIL "(" |.P2| (QUOTE COURIERPROGRAM) %, .FONT PRETTYCOMFONT |.P2| PROGRAM .FONT DEFAULTFONT %, |.P2| (CAR PGMDEF)) (* ; "Version pair") (for TAIL on (CDR PGMDEF) by (CDDR TAIL) do (TAB 4) (CHANGEFONT PRETTYCOMFONT) (PRIN2 (CAR TAIL)) (* ; "Property name") (CHANGEFONT DEFAULTFONT) (TAB 6) (PRINTDEF (CADR TAIL) 6)) (PRIN1 (QUOTE %))) (TERPRI)) (T (CL:FORMAT T "(no COURIER definition for ~S)~%%" PROGRAM))))) +) +) +(DEFINEQ + +(\GET.COURIER.TYPE +(LAMBDA (PROGRAMNAME TYPENAME) (* ecc " 7-JUL-83 14:34") (CAR (\GET.COURIER.DEFINITION PROGRAMNAME TYPENAME (QUOTE TYPES)))) +) + +(\GET.COURIER.DEFINITION +(LAMBDA (PROGRAM NAME TYPE PGMDEF) (* bvm%: "16-Jul-84 15:35") (COND ((\COURIER.QUALIFIED.NAMEP NAME) (\GET.COURIER.DEFINITION (CAR NAME) (CDR NAME) TYPE)) (T (OR (CDR (ASSOC NAME (LISTGET (CDR (OR PGMDEF (SETQ PGMDEF (\GET.COURIERPROGRAM PROGRAM)))) TYPE))) (for OTHERPROGRAM in (LISTGET (CDR (OR PGMDEF (\GET.COURIERPROGRAM PROGRAM))) (QUOTE INHERITS)) when (SETQ $$VAL (CDR (ASSOC NAME (LISTGET (CDR (\GET.COURIERPROGRAM OTHERPROGRAM)) TYPE)))) do (* ; "Is defined in an inherited program") (RETURN $$VAL)) (ERROR (CONCAT "No " TYPE " definition for") (LIST PROGRAM NAME)))))) +) +) + + + +(* ; "COURIER record access") + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS COURIER.FETCH MACRO (ARGS (\COURIER.RECORDTRAN ARGS 'FETCH))) + +(PUTPROPS COURIER.CREATE MACRO (ARGS (\COURIER.RECORDTRAN ARGS 'CREATE))) +) + +(PUTPROPS COURIER.FETCH INFO NOEVAL) + +(PUTPROPS COURIER.CREATE INFO NOEVAL) +(DEFINEQ + +(\COURIER.RECORDTRAN +(LAMBDA (ARGS OP) (* bvm%: " 4-Jul-84 15:42") (PROG ((PROGRAM (CAR ARGS)) (REST (CDR ARGS)) TYPEDEF) (SETQ TYPEDEF (COND ((NLISTP PROGRAM) (\GET.COURIER.TYPE PROGRAM (pop REST))) ((\COURIER.QUALIFIED.NAMEP PROGRAM) (SETQ TYPEDEF (CDR PROGRAM)) (\GET.COURIER.TYPE (SETQ PROGRAM (CAR PROGRAM)) TYPEDEF)) (T (GO ERROR)))) LP (COND ((NLISTP TYPEDEF) (SETQ TYPEDEF (\GET.COURIER.TYPE PROGRAM TYPEDEF)) (GO LP)) ((NEQ (CAR TYPEDEF) (QUOTE RECORD)) (COND ((\COURIER.QUALIFIED.NAMEP TYPEDEF) (SETQ TYPEDEF (\GET.COURIER.TYPE (SETQ PROGRAM (CAR TYPEDEF)) (CDR TYPEDEF))) (GO LP)) (T (GO ERROR)))) (T (pop TYPEDEF))) (RETURN (SELECTQ OP (FETCH (* ; "FETCH FIELD of DATUM --- DATUM is a list of values, one for each field") (bind (FIELD _ (pop REST)) (FORM _ (CAR REST)) first (SELECTQ FORM ((OF of) (* ; "Noise word") (COND ((AND (EQ FORM (QUOTE OF)) LCASEFLG) (/RPLACA REST (QUOTE of)))) (SETQ FORM (CAR (SETQ REST (CDR REST))))) (COND ((EQ FORM (QUOTE of)) (* ; "Noise word") (SETQ FORM (CAR (SETQ REST (CDR REST))))))) (COND ((CDR REST) (* ; "Too many args") (GO ERROR))) while TYPEDEF do (COND ((EQ (CAAR TYPEDEF) FIELD) (RETURN (LIST (QUOTE CAR) FORM)))) (SETQ FORM (LIST (QUOTE CDR) FORM)) (SETQ TYPEDEF (CDR TYPEDEF)) finally (GO ERROR))) (CREATE (* ; "CREATE Field1 Value1 ... FieldN ValueN") (CONS (QUOTE LIST) (bind (TAIL _ REST) X while TAIL collect (COND ((NEQ (CAR TAIL) (CAR (pop TYPEDEF))) (* ; "Fields not in order") (GO ERROR)) (T (PROG1 (COND ((EQ (SETQ X (CAR (SETQ TAIL (CDR TAIL)))) (QUOTE _)) (* ; "Noise token") (CAR (SETQ TAIL (CDR TAIL)))) (T X)) (SETQ TAIL (CDR TAIL))))) finally (COND (TYPEDEF (GO ERROR)))))) (GO ERROR))) ERROR (ERROR "Invalid Courier Record Access form" (CONS OP ARGS)))) +) +) + + + +(* ; "COURIER calls and returns") + + +(DEFMACRO STREAMTYPECASE (STREAM &BODY FORMS) + `(AND (STREAMP ,STREAM) + (SELECTQ (fetch (FDEV DEVICENAME) of (fetch (STREAM DEVICE) of ,STREAM)) + ,@FORMS))) +(DEFINEQ + +(COURIER.OPEN + [LAMBDA (HOSTNAME OBSOLETE NOERRORFLG NAME WHENCLOSEDFN OTHERPROPS) + (* ; "Edited 28-Apr-92 17:34 by jds") + (* ; + "Open a Courier connection to the specified host.") + (RESETLST + (PROG (ADDRESS STREAM LOW.VERSION HIGH.VERSION) + [COND + [(NOT (SETQ ADDRESS (\COERCE.TO.NSADDRESS HOSTNAME))) + (RETURN (AND (NOT NOERRORFLG) + (ERROR "Unknown host" HOSTNAME] + ([NULL (SETQ STREAM (SPP.OPEN ADDRESS \NS.WKS.Courier T NAME + `(CLOSEFN ,(CONS (FUNCTION \COURIER.WHENCLOSED) + (MKLIST WHENCLOSEDFN)) + ,@OTHERPROPS] + (RETURN (AND (NOT NOERRORFLG) + (ERROR "Host not responding" HOSTNAME] + (RESETSAVE NIL (LIST (FUNCTION \SPP.CLOSE.IF.ERROR) + STREAM)) + (replace ENDOFSTREAMOP of STREAM with (FUNCTION \COURIER.EOF)) + (SPP.DSTYPE STREAM \SPPDSTYPE.COURIER) + [COND + (COURIERTRACEFLG (printout COURIERTRACEFILE T "Opened " (OR NAME "") + " with " + (SPP.DESTADDRESS STREAM] + (PUTWORD STREAM (SUB1 COURIER.VERSION#)) (* ; + "Lie about knowing an older version so as to demand a reply immediately") + (PUTWORD STREAM COURIER.VERSION#) + (SPP.SENDEOM STREAM) + (SETQ LOW.VERSION (GETWORD STREAM)) + (SETQ HIGH.VERSION (GETWORD STREAM)) + [COND + ((NOT (AND (ILEQ LOW.VERSION COURIER.VERSION#) + (ILEQ COURIER.VERSION# HIGH.VERSION))) + (SPP.CLOSE STREAM) + (RETURN (AND (NOT NOERRORFLG) + (ERROR "Server supports wrong version of Courier" + (LIST HOSTNAME LOW.VERSION HIGH.VERSION] + (if (EQ (\SPP.PREPARE.INPUT STREAM 0) + 'EOM) + then + + (* ;; " Clear the EOM with which the Alpine Sun server ends the version exchange (absent in Xerox D-machine servers). THIS SEEMS TO BE PART OF XNS NEW PROTOCOLS.") + + (SPP.CLEAREOM STREAM)) + (RETURN STREAM)))]) + +(\COURIER.WHENCLOSED +(LAMBDA (STREAM CON) (* ejs%: "27-May-86 11:24") (COND (COURIERTRACEFLG (printout COURIERTRACEFILE .TAB0 0 "Closed with " (STREAMTYPECASE STREAM (SPP (SPP.DESTADDRESS STREAM)) (TCP (TCP.DESTADDRESS STREAM)) "remote host") T)))) +) + +(COURIER.CALL +(LAMBDA ARGS (* ; "Edited 31-Jul-87 13:48 by bvm:") (* ;; "Call a Courier procedure: (COURIER.CALL stream program-name procedure-name arg1 ... argN)") (* ;; "Returns the result of the remote procedure, or a list of such results if it returns more than one. A single flag NoErrorFlg can be optionally appended to the arglist -- If NoErrorFlg is NOERROR, return NIL if the Courier program aborts with an error; if RETURNERRORS, then return an expression (ERROR ERRNAME . args) on error. If the Courier procedure takes a Bulk Data parameter, then the result of COURIER.CALL is a stream for the transfer. When the stream is closed, the results will be read and the functional argument that was supplied in the call, if any, will be applied to the results.") (LET ((STREAM (ARG ARGS 1)) (PROGRAM (ARG ARGS 2)) (PROCEDURE (ARG ARGS 3)) NARGS ARGLIST NOERRORFLG PGMDEF PROCDEF ARGTYPES) (SETQ PGMDEF (OR (\GET.COURIERPROGRAM PROGRAM) (ERROR "No such Courier program" PROGRAM))) (SETQ PROCDEF (\GET.COURIER.DEFINITION PROGRAM PROCEDURE (QUOTE PROCEDURES) PGMDEF)) (SETQ NARGS (LENGTH (SETQ ARGTYPES (fetch (COURIERFN ARGS) of PROCDEF)))) (OR (SELECTQ (- ARGS NARGS) (3 (* ; "Exactly right") T) (4 (* ; "Extra arg is errorflg") (SELECTQ (SETQ NOERRORFLG (ARG ARGS (+ NARGS 4))) ((NOERROR RETURNERRORS T) (* ; "The only valid values") T) NIL)) NIL) (ERROR "Wrong number of arguments to Courier procedure" (CONS PROGRAM PROCEDURE))) (SETQ ARGLIST (for I from 4 to (+ NARGS 3) collect (ARG ARGS I))) (COND ((type? STREAM STREAM) (COURIER.EXECUTE.CALL STREAM PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG)) ((type? NSADDRESS STREAM) (* ; "Means to make a single call to this address") (RESETLST (LET ((STREAM (COURIER.OPEN STREAM NIL NOERRORFLG))) (COND (STREAM (RESETSAVE NIL (LIST (STREAMTYPECASE STREAM (SPP (FUNCTION \SPP.RESETCLOSE)) (TCP (FUNCTION \TCP.RESETCLOSE)) (FUNCTION CLOSEF)) STREAM)) (COURIER.EXECUTE.CALL STREAM PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG)) ((EQ NOERRORFLG (QUOTE RETURNERRORS)) (QUOTE (ERROR CONNECTION.PROBLEM NoResponse))))))) ((NEQ NOERRORFLG (QUOTE NOERROR)) (\ILLEGAL.ARG STREAM))))) +) + +(COURIER.EXECUTE.CALL +(LAMBDA (STREAM PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG) (* ; "Edited 21-Jul-87 14:44 by bvm:") (* ;; "Send the arguments for a Courier call to the remote program. Returns NIL if none of the formal parameters are of type BULK.DATA.SOURCE or BULK.DATA.SINK, otherwise returns a stream for the Bulk Data transfer.") (COND (COURIERTRACEFLG (\COURIER.TRACE (QUOTE CALL) PROGRAM PROCEDURE ARGLIST))) (PROG ((OUTSTREAM STREAM) SOURCEFLG SINKFLG BULKDATAFN DATASTREAM) (STREAMTYPECASE STREAM (SPP (SPP.DSTYPE (SETQ OUTSTREAM (SPPOUTPUTSTREAM STREAM)) \SPPDSTYPE.COURIER)) NIL) (PUTWORD OUTSTREAM \COURIERMSG.CALL) (PUTWORD OUTSTREAM 0) (* ; "Transaction ID, ignored for now.") (PUTLONG OUTSTREAM (fetch (COURIERPGM PROGRAM#) of PGMDEF)) (PUTWORD OUTSTREAM (fetch (COURIERPGM VERSION#) of PGMDEF)) (PUTWORD OUTSTREAM (fetch (COURIERFN FN#) of PROCDEF)) (for VALUE in ARGLIST as TYPE in ARGTYPES do (SELECTQ TYPE (BULK.DATA.SOURCE (SETQ SOURCEFLG T) (SETQ BULKDATAFN VALUE) (PUTWORD OUTSTREAM 1)) (BULK.DATA.SINK (SETQ SINKFLG T) (SETQ BULKDATAFN VALUE) (PUTWORD OUTSTREAM 1)) (COURIER.WRITE OUTSTREAM VALUE PROGRAM TYPE))) (STREAMTYPECASE OUTSTREAM (SPP (SPP.SENDEOM OUTSTREAM)) (TCP (\TCP.FORCEOUTPUT OUTSTREAM)) (FORCEOUTPUT OUTSTREAM)) (CHECK (NOT (AND SOURCEFLG SINKFLG))) (RETURN (COND ((AND (OR SOURCEFLG SINKFLG) (SETQ DATASTREAM (\BULK.DATA.STREAM STREAM (COND (SINKFLG (QUOTE INPUT)) (T (QUOTE OUTPUT))) PROGRAM PROCEDURE PGMDEF PROCDEF NOERRORFLG BULKDATAFN))) (COND (BULKDATAFN (\COURIER.HANDLE.BULKDATA DATASTREAM BULKDATAFN NOERRORFLG)) (T (* ; "Return the stream to caller") DATASTREAM))) (T (\COURIER.RESULTS STREAM PROGRAM PGMDEF PROCEDURE PROCDEF NOERRORFLG)))))) +) + +(\COURIER.RESULTS +(LAMBDA (STREAM PROGRAM PGMDEF PROCEDURE PROCDEF NOERRORFLG EXPEDITEDFLG) (* ; "Edited 1-May-87 11:39 by bvm:") (LET (MSGTYPE RESULT) (SETQ RESULT (SELECTC (SETQ MSGTYPE (GETWORD STREAM)) (\COURIERMSG.RETURN (LET ((RESULTTYPES (fetch (COURIERFN RESULTS) of PROCDEF))) (GETWORD STREAM) (* ; "Skip the Transaction ID.") (COND ((AND RESULTTYPES (NOT (CDR RESULTTYPES))) (* ; "Single-valued procedures return conventionally") (COURIER.READ STREAM PROGRAM (CAR RESULTTYPES))) (T (for TYPE in RESULTTYPES collect (COURIER.READ STREAM PROGRAM TYPE)))))) (\COURIERMSG.ABORT (GETWORD STREAM) (* ; "Skip the Transaction ID.") (LET ((NUMBER (GETWORD STREAM)) ERRORDEF) (CONS (QUOTE ERROR) (COND ((SETQ ERRORDEF (find ERR in (OR (fetch (COURIERPGM ERRORS) of PGMDEF) (for OTHER in (fetch (COURIERPGM INHERITS) of PGMDEF) when (SETQ $$VAL (fetch (COURIERPGM ERRORS) of (\GET.COURIERPROGRAM OTHER))) do (RETURN $$VAL))) suchthat (IEQP (fetch (COURIERERR ERR#) of (CDR ERR)) NUMBER))) (CONS (CAR ERRORDEF) (for TYPE in (fetch (COURIERERR ARGS) of (CDR ERRORDEF)) collect (COURIER.READ STREAM PROGRAM TYPE)))) (T (LIST NUMBER)))))) (\COURIERMSG.REJECT (GETWORD STREAM) (* ; "Skip the Transaction ID.") (LIST (QUOTE ERROR) (QUOTE REJECT) (COURIER.READ STREAM PROGRAM (QUOTE (CHOICE (NoSuchService 0) (WrongVersionOfService 1 (RECORD (lowest CARDINAL) (highest CARDINAL))) (NoSuchProcedure 2) (invalidArguments 3) (unspecifiedError 65535)))))) (LIST (QUOTE ERROR) (QUOTE UnknownResponseType) MSGTYPE))) (COND ((NOT EXPEDITEDFLG) (STREAMTYPECASE STREAM (SPP (SPP.CLEAREOM STREAM)) NIL))) (COND (COURIERTRACEFLG (\COURIER.TRACE (QUOTE RETURN) PROGRAM PROCEDURE RESULT))) (COND ((EQ MSGTYPE \COURIERMSG.RETURN) (* ; "Normal return") RESULT) ((AND EXPEDITEDFLG (EQ (CADDR RESULT) (QUOTE USE.COURIER))) (* ; "Special flag on expedited courier call saying to use regular Courier") (QUOTE USE.COURIER)) (T (SELECTQ NOERRORFLG (RETURNERRORS (* ; "Caller wants to handle errors") RESULT) (NIL (* ; "Default--signal the error") (COURIER.SIGNAL.ERROR PROGRAM PROCEDURE RESULT)) (PROGN (* ; "Caller wants no errors") (\COURIER.HANDLE.ERROR PROGRAM PROCEDURE RESULT) NIL)))))) +) + +(COURIER.SIGNAL.ERROR +(LAMBDA (PROGRAM PROCEDURE ERRORFORM) (* ; "Edited 1-May-87 11:33 by bvm:") (* ;; "Signals the error returned from PROCEDURE of PROGRAM. ERRORFORM is a form starting with the symbol ERROR from a Courier result. ") (LET ((ARGS (CDR ERRORFORM))) (ERROR (CONCAT (COND ((EQ (CAR ARGS) (QUOTE REJECT)) (* ; "Reject errors of form (ERROR REJECT reason)") (SETQ ARGS (CADR ARGS)) "Courier rejected call to ") (T (* ; "Other errors of form (ERROR type . args)") (COND ((NULL (CDR ARGS)) (* ; "For errors with no arguments, make the error call slighly prettier by just naming the error") (SETQ ARGS (CAR ARGS)))) "Error in Courier procedure ")) PROGRAM "." PROCEDURE) ARGS))) +) + +(\COURIER.HANDLE.BULKDATA +(LAMBDA (DATASTREAM BULKDATAFN NOERRORFLG) (* ; "Edited 27-Aug-87 11:26 by bvm:") (* ;;; "Called when a Courier call has a bulkdata argument. BULKDATAFN is a function to apply to the bulk data stream. If it returns a non-NIL result, that is returned as the value of the Courier call, ignoring the Courier results, if any. As a special case, a BULKDATAFN of (Program . Type) interprets the bulk data stream as a `Stream of Program.Type'") (CL:UNWIND-PROTECT (CL:MULTIPLE-VALUE-BIND (BULKRESULTS ERROR) (CL:CATCH :BULKDATA (COND ((AND (LISTP BULKDATAFN) (SELECTQ (CAR BULKDATAFN) ((LAMBDA CL:LAMBDA) (* ; "Handler is not a type, just an interpreted fn") NIL) T)) (* ; "Special case, interpret as a type") (COURIER.READ.BULKDATA DATASTREAM (CAR BULKDATAFN) (CDR BULKDATAFN) T)) (T (CL:FUNCALL BULKDATAFN DATASTREAM)))) (* ;; "Bulk data handled now. If handler wanted to abort, then BULKRESULTS is :ABORT, in which case we send an abort packet (if necessary), and the second value ERROR is optional error value to return.") (LET ((MAINRESULTS (\BULK.DATA.CLOSE DATASTREAM (AND (EQ BULKRESULTS :ABORT) (OR NOERRORFLG T))))) (OR (AND (NEQ BULKRESULTS :ABORT) BULKRESULTS) ERROR MAINRESULTS))) (* ;; "Be sure bulk stream is closed on exit. This is a no-op on normal exit, since the stream has already been closed. On error exit, we send an abort.") (\BULK.DATA.CLOSE DATASTREAM T))) +) + +(\COURIER.HANDLE.ERROR +(LAMBDA (PROGRAM PROCEDURE ERRORARGS) (* bvm%: "27-Jun-84 23:05") (COND (NSWIZARDFLG (printout PROMPTWINDOW .TAB0 0 "Error in Courier program " PROGRAM ", procedure " PROCEDURE ": " ERRORARGS)))) +) + +(\BULK.DATA.STREAM +(LAMBDA (STREAM MODE PROGRAM PROCEDURE PGMDEF PROCDEF NOERRORFLG INTERNALFLG) (* ; "Edited 20-May-87 12:33 by bvm:") (* ;; "Return a specialized version of an SPP stream suitable for sending or receiving a Bulk Data object. Uses the Bulk Data device, which redefines the EOFP and CLOSE functions. Save the program, procedure, and result function in the stream record for use by \BULK.DATA.CLOSE.") (STREAMTYPECASE STREAM (SPP (PROG ((CON (GETSPPCON STREAM)) SUBSTREAM NEXTPKT) (COND ((EQ MODE (QUOTE INPUT)) (* ; "Preview the incoming stream to see if there's any data there") (COND ((NOT (SETQ NEXTPKT (\GETSPP CON NIL T))) (* ; "Connection died") (RETURN NIL)) ((NEQ (fetch (SPPXIP DSTYPE) of NEXTPKT) \SPPDSTYPE.BULKDATA) (* ; "Bulkdata not coming, must be error") (RETURN NIL)) ((fetch (SPPXIP ATTENTION) of NEXTPKT) (* ; "Immediately aborted, must be nothing coming") (\GETSPP CON) (* ; "Eat the packet") (RETURN NIL))))) (COND ((type? STREAM (SETQ SUBSTREAM (fetch F10 of STREAM))) (* ; "reuse old substream") (replace F10 of STREAM with NIL) (replace SPPFILEPTRHI of SUBSTREAM with 0) (replace SPPFILEPTRLO of SUBSTREAM with 0) (replace SPPEOFP of SUBSTREAM with NIL)) (T (SETQ SUBSTREAM (create STREAM DEVICE _ \SPP.BULKDATA.DEVICE)) (replace SPP.CONNECTION of SUBSTREAM with CON))) (replace BULK.DATA.CONTINUATION of SUBSTREAM with (create \BULK.DATA.CONTINUATION PROGRAM _ PROGRAM PROCEDURE _ PROCEDURE PGMDEF _ PGMDEF PROCDEF _ PROCDEF NOERRORFLG _ NOERRORFLG INTERNALFLG _ INTERNALFLG)) (replace (STREAM ACCESS) of SUBSTREAM with MODE) (replace SPPSUBSTREAM of CON with SUBSTREAM) (replace SPPATTENTIONFN of CON with (FUNCTION \COURIER.ATTENTIONFN)) (COND (COURIERTRACEFLG (\COURIER.TRACE (QUOTE BEGIN.BULK.DATA) PROGRAM PROCEDURE))) (SPP.DSTYPE SUBSTREAM \SPPDSTYPE.BULKDATA) (RETURN SUBSTREAM))) (ERROR "Courier bulk data not supported on stream of type" (fetch (FDEV DEVICENAME) of (fetch (STREAM DEVICE) of STREAM))))) +) + +(\COURIER.ATTENTIONFN +(LAMBDA (STREAM BYTE DSTYPE) (* bvm%: "12-Oct-84 16:16") (* ;;; "Called when attention packet received on input STREAM. If we are currently writing bulkdata, this is an abort, so arrange to kill the writer") (COND ((AND (EQ BYTE 1) (EQ DSTYPE \SPPDSTYPE.BULKDATA)) (* ; "Bulk data stream truncation signal") (LET (CON) (COND ((AND (SETQ CON (GETSPPCON STREAM)) (SETQ STREAM (fetch SPPSUBSTREAM of CON)) (WRITEABLE STREAM)) (replace SPPOUTPUTABORTEDFN of CON with (FUNCTION \COURIER.OUTPUT.ABORTED)) (replace SPPOUTPUTABORTEDP of CON with T))) (COND (NSWIZARDFLG (printout PROMPTWINDOW .TAB0 0 "[Remote host aborted data transfer]"))) T)))) +) + +(\COURIER.OUTPUT.ABORTED +(LAMBDA (STREAM) (* ; "Edited 18-May-87 17:07 by bvm:") (* ;; "Called when attempt is made to write data on STREAM when output has been aborted, or to read from a stream that is at ATTN (bulk data abort).") (LET (FILENAME CONTINUATION RESULT) (COND ((AND (SETQ CONTINUATION (fetch BULK.DATA.CONTINUATION of STREAM)) (NOT (fetch INTERNALFLG of CONTINUATION))) (* ; "This was a standalone bulkdata stream") (SETQ RESULT (\BULK.DATA.CLOSE STREAM (QUOTE RETURNERRORS))) (COND ((AND (SETQ FILENAME (fetch FULLFILENAME of STREAM)) (EQ (CADR RESULT) (QUOTE SPACE.ERROR))) (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" FILENAME)) (T (ERROR (CONCAT (COND ((DIRTYABLE STREAM) "Output") (T "Input")) " aborted: " (CADR RESULT) " -- " (CADDR RESULT)) (OR FILENAME STREAM))))) (T (* ; "Inside of \COURIER.HANDLE.BULKDATA") (CL:THROW :BULKDATA :ABORT))))) +) + +(\BULK.DATA.CLOSE +(LAMBDA (STREAM ABORTFLG) (* ; "Edited 27-Aug-87 11:29 by bvm:") (* ;; "Close a Bulk Data stream after the transfer has taken place. If a result function was specified in COURIER.CALL, call it on the stream and the result or list of results.") (PROG ((CON (GETSPPCON STREAM)) (CONTINUATION (fetch BULK.DATA.CONTINUATION of STREAM))) (replace SPPATTENTIONFN of CON with NIL) (COND ((NULL (fetch SPPSUBSTREAM of CON)) (* ; "This stream has already been closed. We don't want to try to read the Courier results twice") (RETURN))) (COND (COURIERTRACEFLG (\COURIER.TRACE (QUOTE END.BULK.DATA) (fetch PROGRAM of CONTINUATION) (fetch PROCEDURE of CONTINUATION)))) (COND ((WRITEABLE STREAM) (COND (ABORTFLG (SPP.SENDATTENTION STREAM 1)) (T (SPP.SENDEOM STREAM)))) ((NOT (\EOFP STREAM)) (* ; "Closing before all the data has been read -- abort the transfer.") (OR ABORTFLG (SETQ ABORTFLG T)) (\ABORT.BULK.DATA STREAM))) (replace BULK.DATA.CONTINUATION of STREAM with NIL) (* ; "Tell SPP handler not to take any more bulk data packets.") (replace SPPINPKT of CON with NIL) (* ;; "This stream is closing; make sure there aren't any dangling pointers into the middle of ether packets.") (replace CBUFPTR of STREAM with NIL) (replace CBUFSIZE of STREAM with 0) (RETURN (CAR (ERSETQ (RESETLST (* ;; "The result of the Courier call may be an error which the user should see; however, we still need to clean up the substream, so we wrap it in this RESETLST.") (LET ((COURIERSTREAM (fetch SPPINPUTSTREAM of CON))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (STRM ABORTFLG) (COND (ABORTFLG (replace ENDOFSTREAMOP of STRM with (FUNCTION \COURIER.EOF)))) (COND (RESETSTATE (SPP.CLOSE STRM T))))) COURIERSTREAM ABORTFLG)) (COND (ABORTFLG (replace ENDOFSTREAMOP of COURIERSTREAM with (FUNCTION ERROR!)))) (replace SPPSUBSTREAM of CON with NIL) (PROG1 (\COURIER.RESULTS COURIERSTREAM (fetch PROGRAM of CONTINUATION) (fetch PGMDEF of CONTINUATION) (fetch PROCEDURE of CONTINUATION) (fetch PROCDEF of CONTINUATION) (OR ABORTFLG (fetch NOERRORFLG of CONTINUATION))) (COND ((NOT (fetch FULLFILENAME of STREAM)) (* ; "On normal exit, save the substream for later reuse.") (replace F10 of COURIERSTREAM with STREAM))))))))))) +) + +(\ABORT.BULK.DATA +(LAMBDA (STREAM) (* ejs%: "18-Dec-84 17:32") (PROG (EPKT) (do (* ; "Empty queue of waiting packets without blocking.") (replace COFFSET of STREAM with (fetch CBUFSIZE of STREAM)) repeatwhile (NOT (\SPP.PREPARE.INPUT STREAM 0))) (COND ((fetch SPPEOFP of STREAM) (* ; "We've already received the last packet of the Bulk Data transfer.")) (T (* ;; "Abort the bulk data stream by sending an Attention packet with a 1 in it. WARNING: if the EOM bit is set in this packet, the NS fileserver will crash.") (SPP.SENDATTENTION STREAM 1) (if NIL then (* ;; "Ignore any remaining bulk data packets -- there shouldn't be many if the other end is obeying the protocol.") (while (\SPP.PREPARE.INPUT STREAM SPP.USER.TIMEOUT))))))) +) +) +(DEFINEQ + +(COURIER.EXPEDITED.CALL +(LAMBDA ARGS (* bvm%: "16-Jul-84 15:39") (* ;;; "Like COURIER.CALL but tries to use `expedited' calls. The first two args are the address and socket# to talk to, rather than a single open Courier stream. Remaining args are identical. If expedited version fails, a regular courier call is executed. Bulk data is prohibited") (PROG ((ADDRESS (ARG ARGS 1)) (SOCKET# (ARG ARGS 2)) (PROGRAM (ARG ARGS 3)) (PROCEDURE (ARG ARGS 4)) %#ARGS ARGLIST NOERRORFLG PGMDEF PROCDEF ARGTYPES) (SETQ PGMDEF (OR (\GET.COURIERPROGRAM PROGRAM) (ERROR "No such Courier program" PROGRAM))) (SETQ PROCDEF (\GET.COURIER.DEFINITION PROGRAM PROCEDURE (QUOTE PROCEDURES) PGMDEF)) (SETQ %#ARGS (LENGTH (SETQ ARGTYPES (fetch (COURIERFN ARGS) of PROCDEF)))) (COND ((for TYPE in ARGTYPES thereis (OR (EQ TYPE (QUOTE BULK.DATA.SINK)) (EQ TYPE (QUOTE BULK.DATA.SOURCE)))) (ERROR "Can't transfer bulk data with expedited call" (CONS PROGRAM PROCEDURE)))) (OR (SELECTQ (IDIFFERENCE ARGS %#ARGS) (4 (* ; "Exactly right") T) (5 (* ; "Extra arg is errorflg") (SELECTQ (SETQ NOERRORFLG (ARG ARGS (IPLUS %#ARGS 5))) ((NOERROR RETURNERRORS T) T) NIL)) NIL) (ERROR "Wrong number of arguments to Courier procedure" (CONS PROGRAM PROCEDURE))) (SETQ ARGLIST (for I from 5 to (IPLUS %#ARGS 4) collect (ARG ARGS I))) (RETURN (COURIER.EXECUTE.EXPEDITED.CALL ADDRESS SOCKET# PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG)))) +) + +(COURIER.EXECUTE.EXPEDITED.CALL +(LAMBDA (ADDRESS SOCKET# PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG) (* ; "Edited 31-Jul-87 14:19 by bvm:") (* ;;; "Attempts the actual expedited call") (COND (COURIERTRACEFLG (\COURIER.TRACE (QUOTE CALL) PROGRAM PROCEDURE ARGLIST))) (RESETLST (PROG ((NSOC (OPENNSOCKET)) XIP STREAM RESULT) (RESETSAVE NIL (LIST (QUOTE CLOSENSOCKET) NSOC)) (SETQ XIP (CREATE.PACKET.EXCHANGE.XIP NSOC ADDRESS SOCKET# \EXTYPE.EXPEDITED.COURIER)) (OR (\BUILD.EXPEDITED.XIP XIP PROGRAM PGMDEF PROCDEF ARGLIST ARGTYPES) (GO USECOURIER)) (COND ((NEQ (SETQ RESULT (\SEND.EXPEDITED.XIP XIP NSOC PROGRAM PGMDEF PROCEDURE PROCDEF NOERRORFLG)) (QUOTE USE.COURIER)) (RETURN RESULT))) USECOURIER (RETURN (COND ((SETQ STREAM (COURIER.OPEN ADDRESS NIL NOERRORFLG (QUOTE COURIER))) (* ; "Use regular courier") (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) STREAM)) (COURIER.EXECUTE.CALL STREAM PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG)) ((EQ NOERRORFLG (QUOTE RETURNERRORS)) (QUOTE (ERROR CONNECTION.PROBLEM NoResponse)))))))) +) + +(\BUILD.EXPEDITED.XIP +(LAMBDA (XIP PROGRAM PGMDEF PROCDEF ARGLIST) (* bvm%: " 4-Jul-84 15:41") (PROG (STREAM) (replace (EXPEDITEDXIP LOWVERSION) of XIP with (replace (EXPEDITEDXIP HIGHVERSION) of XIP with (COURIER.VERSION#))) (replace (EXPEDITEDXIP MSGTYPE) of XIP with \COURIERMSG.CALL) (replace (EXPEDITEDXIP TRANSACTIONID) of XIP with 0) (* ; "Transaction ID, ignored for now.") (replace (EXPEDITEDXIP PROGRAM#) of XIP with (fetch (COURIERPGM PROGRAM#) of PGMDEF)) (replace (EXPEDITEDXIP VERSION#) of XIP with (fetch (COURIERPGM VERSION#) of PGMDEF)) (replace (EXPEDITEDXIP PROCEDURE#) of XIP with (fetch (COURIERFN FN#) of PROCDEF)) (replace XIPLENGTH of XIP with (COND (ARGLIST (SETQ STREAM (\MAKE.EXPEDITED.STREAM XIP (QUOTE OUTPUT))) (OR (\COURIER.EXPEDITED.ARGS STREAM PROGRAM ARGLIST (fetch (COURIERFN ARGS) of PROCDEF)) (RETURN)) (fetch COFFSET of STREAM)) (T (IPLUS \XIPOVLEN (UNFOLD (IPLUS 3 (INDEXF (fetch (EXPEDITEDXIP ARG0) of T))) BYTESPERWORD))))) (RETURN XIP))) +) + +(\SEND.EXPEDITED.XIP +(LAMBDA (XIP NSOC PROGRAM PGMDEF PROCEDURE PROCDEF NOERRORFLG %#TRIES) (* bvm%: "21-Feb-86 14:21") (* ;;; "Sends XIP, which is in the form of an expedited courier call, and awaits a response on NSOC. The call is to PROCEDURE of PROGRAM. If there is no response, or the remote element responds with the USE.COURIER error, returns USE.COURIER else the actual result (which could be NIL)") (bind (TIMER _ (SETUPTIMER 0)) (EVENT _ (NSOCKETEVENT NSOC)) (ID _ (fetch PACKETEXCHANGEID of XIP)) IXIP to (OR %#TRIES \MAXETHERTRIES) do (SENDXIP NSOC XIP) (SETUPTIMER \ETHERTIMEOUT TIMER) (SELECTQ (until (TIMEREXPIRED? TIMER) when (PROGN (AWAIT.EVENT EVENT TIMER T) (SETQ IXIP (GETXIP NSOC))) do (SELECTC (fetch XIPTYPE of IXIP) (\XIPT.EXCHANGE (COND ((AND (IEQP (fetch PACKETEXCHANGEID of IXIP) ID) (ILEQ (fetch (EXPEDITEDXIP LOWVERSION) of IXIP) (COURIER.VERSION#)) (IGEQ (fetch (EXPEDITEDXIP HIGHVERSION) of IXIP) (COURIER.VERSION#)) (SELECTC (fetch (EXPEDITEDXIP MSGTYPE) of IXIP) ((LIST \COURIERMSG.RETURN \COURIERMSG.REJECT \COURIERMSG.ABORT) T) NIL)) (RETURN T)))) (\XIPT.ERROR (COND ((AND (EQ (fetch ERRORXIPCODE of IXIP) \XIPE.NOSOCKET) (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER))) (* ;; "Not responding to calls on this socket. If XIP were a broadcast, nobody should be replying with an error, but if some loser did, we should ignore it") (RELEASE.XIP IXIP) (RETURN (QUOTE USE.COURIER))))) NIL) (RELEASE.XIP IXIP)) (USE.COURIER (RETURN (QUOTE USE.COURIER))) (NIL (* ; "Keep trying")) (RETURN (PROG1 (\COURIER.RESULTS (\MAKE.EXPEDITED.STREAM IXIP (QUOTE INPUT)) PROGRAM PGMDEF PROCEDURE PROCDEF NOERRORFLG T) (RELEASE.XIP IXIP)))) finally (RETURN (QUOTE USE.COURIER)))) +) + +(\COURIER.EXPEDITED.ARGS +(LAMBDA (STREAM PROGRAM ARGLIST ARGTYPES) (* bvm%: "15-Jun-84 12:00") (* ;;; "Store the args for an expedited call into packet addressed by STREAM. Returns T on success. Failure is indicated by a RETFROM this fn with value NIL") (for VALUE in ARGLIST as TYPE in ARGTYPES do (COURIER.WRITE STREAM VALUE PROGRAM TYPE)) T) +) + +(\MAKE.EXPEDITED.STREAM + [LAMBDA (XIP ACCESS OSTREAM) (* ; + "Edited 2-Nov-93 13:52 by sybalsky:mv:envos") + +(* ;;; "Makes a STREAM to access the contents of XIP as an expedited courier message body. We use the BASEBYTES device for simplicity. All the operations we actually need are BIN, BOUT, BLOCKIN and BLOCKOUT") + + (PROG ([STREAM (OR OSTREAM (NCREATE 'STREAM] + END) + (replace (STREAM DEVICE) of STREAM with \BASEBYTESDEVICE) + (replace (STREAM ACCESS) of STREAM with ACCESS) + (replace (STREAM CBUFPTR) of STREAM with (fetch (XIP XIPBASE) of XIP)) + [replace (STREAM COFFSET) of STREAM + with (IPLUS \XIPOVLEN (UNFOLD 3 BYTESPERWORD) + (COND + ((EQ ACCESS 'INPUT) (* ; "For COURIER.RESULTS") + (SETQ END (fetch XIPLENGTH of XIP)) + (UNFOLD (INDEXF (fetch (EXPEDITEDXIP MSGTYPE) of T)) + BYTESPERWORD)) + (T (* ; "For COURIER.EXPEDITED.ARGS") + (SETQ END (IPLUS \MAX.XIPDATALENGTH \XIPOVLEN)) + (UNFOLD (INDEXF (fetch (EXPEDITEDXIP ARG0) of T)) + BYTESPERWORD] + (replace (STREAM EOFFSET) of STREAM with (replace CBUFSIZE of STREAM + with END)) + [COND + ((EQ ACCESS 'INPUT) (* ; + "Will cause error if COURIER.RESULTS tries to read more than was sent -- should never happen") + (replace (STREAM ENDOFSTREAMOP) of STREAM with (FUNCTION \COURIER.EOF))) + (T (* ; + "Invoked if COURIER.EXPEDITED.ARGS tries to write more than will fit in the packet") + (replace (BASEBYTESTREAM WRITEXTENSIONFN) of STREAM + with (FUNCTION \COURIER.EXPEDITED.OVERFLOW] + (RETURN STREAM]) + +(\COURIER.EOF +(LAMBDA (STREAM) (* bvm%: "15-Jun-84 11:56") (* ;;; "Called if we attempt to read beyond the end of a courier response") (ERROR "Unexpected end of stream while reading Courier response")) +) + +(\COURIER.EXPEDITED.OVERFLOW +(LAMBDA (STREAM) (* bvm%: " 4-Jul-84 15:41") (* ;;; "Called when \COURIER.EXPEDITED.ARGS tries to write beyond the end of the packet") (COND (NSWIZARDFLG (printout PROMPTWINDOW T "[Expedited call did not fit in one packet]"))) (RETFROM (FUNCTION \COURIER.EXPEDITED.ARGS) NIL)) +) +) +(DEFINEQ + +(COURIER.BROADCAST.CALL +(LAMBDA (DESTSOCKET# PROGRAM PROCEDURE ARGS RESULTFN NETHINT MESSAGE) (* bvm%: "21-Feb-86 14:24") (* ;; "Performs expanding ring broadcast for Courier PROCEDURE applied to ARGS. If RESULTFN is given, it is applied to the results of the courier call, and its result is returned, unless it is NIL, in which case the broadcast continues. NETHINT is a net or list of nets that are expected to have the desired server. If omitted, or if no server on those nets responds, broadcast starts with the connected net and expands outward") (RESETLST (PROG ((PGMDEF (OR (\GET.COURIERPROGRAM PROGRAM) (ERROR "No such Courier program" PROGRAM))) PROCDEF SKT EPKT ROUTINGTABLE RESULT NEARBYNETS) (DECLARE (SPECVARS NEARBYNETS)) (* ; "For \MAP.ROUTING.TABLE") (SETQ PROCDEF (\GET.COURIER.DEFINITION PROGRAM PROCEDURE (QUOTE PROCEDURES) PGMDEF)) (RESETSAVE NIL (LIST (QUOTE CLOSENSOCKET) (SETQ SKT (OPENNSOCKET)))) (SETQ EPKT (CREATE.PACKET.EXCHANGE.XIP SKT BROADCASTNSHOSTNUMBER DESTSOCKET# \EXTYPE.EXPEDITED.COURIER)) (OR (\BUILD.EXPEDITED.XIP EPKT PROGRAM PGMDEF PROCDEF ARGS) (ERROR "Could not build broadcast for servers packet" (CONS PROGRAM PROCEDURE))) (COND (MESSAGE (printout PROMPTWINDOW .TAB0 0 "[Looking for " MESSAGE " on net"))) (COND ((COND ((NOT NETHINT) NIL) ((FIXP NETHINT) (* ; "If there's a hint about the net, try harder for that net") (SETQ RESULT (\COURIER.BROADCAST.ON.NET NETHINT SKT EPKT PROGRAM PGMDEF PROCEDURE PROCDEF RESULTFN MESSAGE 4))) ((LISTP NETHINT) (for NET in NETHINT thereis (SETQ RESULT (\COURIER.BROADCAST.ON.NET NET SKT EPKT PROGRAM PGMDEF PROCEDURE PROCDEF RESULTFN MESSAGE 4))))) (* ; "Found server on hinted net")) (T (SETQ NEARBYNETS (CONS)) (\MAP.ROUTING.TABLE \NS.ROUTING.TABLE (FUNCTION (LAMBDA (RT) (* ; "Gather up info about what nets are nearby in order of hop count") (PROG ((HOPS (fetch (ROUTING RTHOPCOUNT) of RT))) (COND ((ILEQ HOPS 5) (for (TAIL _ NEARBYNETS) while (AND (CDR TAIL) (ILESSP (CAR (CADR TAIL)) HOPS)) do (SETQ TAIL (CDR TAIL)) finally (push (CDR TAIL) (LIST HOPS (fetch (ROUTING RTNET#) of RT)))))))))) (COND ((OR (NULL (CDR NEARBYNETS)) (NEQ (CAR (CADR NEARBYNETS)) 0)) (* ; "Include local net") (push (CDR NEARBYNETS) (LIST 0 0)))) (COND ((NOT (find PAIR in (CDR NEARBYNETS) suchthat (SETQ RESULT (\COURIER.BROADCAST.ON.NET (CADR PAIR) SKT EPKT PROGRAM PGMDEF PROCEDURE PROCDEF RESULTFN MESSAGE)))) (* ;; "Try once more, just in case we didn't wait long enough on the last guy. The previous tries overlapped each other, and we need to wait a bit to give the last one equal time") (SETQ RESULT (\COURIER.BROADCAST.ON.NET (CADR (CADR NEARBYNETS)) SKT EPKT PROGRAM PGMDEF PROCEDURE PROCDEF RESULTFN)))))) (COND (MESSAGE (printout PROMPTWINDOW %, (COND (RESULT "done]") (T "failed]"))))) (RETURN RESULT)))) +) + +(\COURIER.BROADCAST.ON.NET + [LAMBDA (NET NSOC XIP PROGRAM PGMDEF PROCEDURE PROCDEF RESULTFN MESSAGE %#TRIES) + (* ; + "Edited 2-Nov-93 13:51 by sybalsky:mv:envos") + (replace XIPDESTNET of XIP with NET) + (COND + (MESSAGE (printout PROMPTWINDOW %, .I0.8 NET ","))) + (LET [(RESULT (NLSETQ (\SEND.EXPEDITED.XIP XIP NSOC PROGRAM PGMDEF PROCEDURE PROCDEF T + (OR %#TRIES 2] + (COND + ((NOT RESULT) + NIL) + ((EQ (SETQ RESULT (CAR RESULT)) + 'USE.COURIER) + NIL) + (RESULTFN (CL:FUNCALL RESULTFN RESULT)) + (T RESULT]) +) +(DEFINEQ + +(COURIER.READ +(LAMBDA (STREAM PROGRAM TYPE) (* bvm%: "29-Oct-86 18:25") (LET (X) (COND ((LITATOM TYPE) (SELECTQ TYPE (BOOLEAN (NEQ 0 (GETWORD STREAM))) ((CARDINAL UNSPECIFIED) (GETWORD STREAM)) (INTEGER (SIGNED (GETWORD STREAM) BITSPERWORD)) ((LONGCARDINAL LONGINTEGER) (GETLONG STREAM)) (STRING (COURIER.READ.STRING STREAM)) (TIME (ALTO.TO.LISP.DATE (GETLONG STREAM))) (COND ((SETQ X (GETPROP TYPE (QUOTE COURIERDEF))) (* ; "User-defined type") (CL:FUNCALL (CAR X) STREAM PROGRAM TYPE)) ((SETQ X (\GET.COURIER.TYPE PROGRAM TYPE)) (COURIER.READ STREAM PROGRAM X)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) ((AND (LISTP TYPE) (LITATOM (CAR TYPE))) (SELECTQ (CAR TYPE) (ENUMERATION (bind (ITEM _ (GETWORD STREAM)) for DEF in (CDR TYPE) do (COND ((IEQP ITEM (CADR DEF)) (RETURN (CAR DEF)))) finally (RETURN ITEM))) (ARRAY (bind (BASETYPE _ (CADDR TYPE)) to (CADR TYPE) collect (COURIER.READ STREAM PROGRAM BASETYPE))) (SEQUENCE (* ; "We ignore the maximum length of the sequence.") (COURIER.READ.SEQUENCE STREAM PROGRAM (OR (CADDR TYPE) (CADR TYPE)))) (RECORD (for NAMEANDTYPE in (CDR TYPE) collect (COURIER.READ STREAM PROGRAM (CADR NAMEANDTYPE)))) (NAMEDRECORD (* ; "Expanded form for backward compatibility") (for NAMEANDTYPE in (CDR TYPE) collect (LIST (CAR NAMEANDTYPE) (COURIER.READ STREAM PROGRAM (CADR NAMEANDTYPE))))) (CHOICE (bind (WHICH _ (GETWORD STREAM)) for DEF in (CDR TYPE) do (* ; "DEF = (tag choice# type); type = NIL is shorthand for type null record") (COND ((IEQP WHICH (CADR DEF)) (RETURN (CONS (CAR DEF) (AND (CADDR DEF) (LIST (COURIER.READ STREAM PROGRAM (CADDR DEF)))))))) finally (RETURN (LIST WHICH (QUOTE ???))))) (COND ((LITATOM (CDR TYPE)) (* ; "Qualified name") (COURIER.READ STREAM (CAR TYPE) (CDR TYPE))) ((SETQ X (GETPROP (CAR TYPE) (QUOTE COURIERDEF))) (CL:FUNCALL (CAR X) STREAM PROGRAM TYPE)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) +) + +(\COURIER.UNKNOWN.TYPE +(LAMBDA (PROGRAM TYPE) (* bvm%: "27-Jun-84 15:36") (ERROR "Unknown Courier Type" (COND (PROGRAM (CONS PROGRAM TYPE)) (T TYPE)))) +) + +(COURIER.READ.SEQUENCE +(LAMBDA (STREAM PROGRAM BASETYPE) (* bvm%: "27-Jun-84 15:16") (* ;;; "Reads a Courier SEQUENCE, returning it as a list of objects of type BASETYPE") (to (GETWORD STREAM) collect (COURIER.READ STREAM PROGRAM BASETYPE))) +) + +(COURIER.READ.STRING + [LAMBDA (STREAM) (* ; "Edited 10-Mar-89 14:59 by bvm") + + (* ;; + "Read a string. First word is the length, then come that many bytes of an NS encoded string.") + + (LET* ((LENGTH (GETWORD STREAM)) + (STRING (ALLOCSTRING LENGTH)) + (BASE (fetch (STRINGP BASE) of STRING)) + (OFFSET (fetch (STRINGP OFFST) of STRING))) + (\BINS STREAM BASE OFFSET LENGTH) + (COND + ((ODDP LENGTH) + (BIN STREAM))) + (if (for I from OFFSET to (+ OFFSET LENGTH -1) + thereis (EQ (\GETBASEBYTE BASE I) + 255)) + then (* ; + "String had NS encoding, so have to read it more carefully") + (DECODE-NS-STRING STRING) + else STRING]) + +(COURIER.WRITE +(LAMBDA (STREAM ITEM PROGRAM TYPE) (* bvm%: "29-Oct-86 18:25") (PROG (X) (COND ((LITATOM TYPE) (SELECTQ TYPE (BOOLEAN (PUTWORD STREAM (COND (ITEM 1) (T 0)))) ((CARDINAL UNSPECIFIED) (PUTWORD STREAM ITEM)) (INTEGER (PUTWORD STREAM (UNSIGNED ITEM BITSPERWORD))) ((LONGCARDINAL LONGINTEGER) (PUTLONG STREAM ITEM)) (STRING (COURIER.WRITE.STRING STREAM ITEM)) (TIME (PUTLONG STREAM (LISP.TO.ALTO.DATE ITEM))) (COND ((SETQ X (GETPROP TYPE (QUOTE COURIERDEF))) (* ; "User-defined type") (CL:FUNCALL (CADR X) STREAM ITEM PROGRAM TYPE)) ((SETQ X (\GET.COURIER.TYPE PROGRAM TYPE)) (COURIER.WRITE STREAM ITEM PROGRAM X)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) ((AND (LISTP TYPE) (LITATOM (CAR TYPE))) (SELECTQ (CAR TYPE) (ENUMERATION (* ; "Keys can be either atoms, for fast lookup, or strings, to save atom space") (PUTWORD STREAM (OR (CADR (OR (ASSOC ITEM (CDR TYPE)) (find X in (CDR TYPE) bind (KEY _ (MKSTRING ITEM)) suchthat (STREQUAL KEY (CAR X))))) (\COURIER.TYPE.ERROR ITEM (QUOTE ENUMERATION))))) (ARRAY (PROG ((SIZE (CADR TYPE)) (BASETYPE (CADDR TYPE))) (COND ((NOT (IEQP SIZE (LENGTH ITEM))) (\COURIER.TYPE.ERROR ITEM TYPE))) (for X in ITEM do (COURIER.WRITE STREAM X PROGRAM BASETYPE)))) (SEQUENCE (* ; "We ignore the maximum length of the sequence.") (COURIER.WRITE.SEQUENCE STREAM ITEM PROGRAM (OR (CADDR TYPE) (CADR TYPE)))) (RECORD (for NAMEANDTYPE in (CDR TYPE) as VALUE in ITEM do (COURIER.WRITE STREAM VALUE PROGRAM (CADR NAMEANDTYPE)))) (NAMEDRECORD (* ; "Old style") (for NAMEANDTYPE in (CDR TYPE) as NAMEANDVALUE in ITEM do (COND ((NEQ (CAR NAMEANDTYPE) (CAR NAMEANDVALUE)) (\COURIER.TYPE.ERROR ITEM (CAR TYPE)))) (COURIER.WRITE STREAM (CADR NAMEANDVALUE) PROGRAM (CADR NAMEANDTYPE)))) (CHOICE (PROG ((WHICH (OR (ASSOC (CAR ITEM) (CDR TYPE)) (\COURIER.TYPE.ERROR ITEM (QUOTE CHOICE))))) (PUTWORD STREAM (CADR WHICH)) (COND ((CADDR WHICH) (COURIER.WRITE STREAM (CADR ITEM) PROGRAM (CADDR WHICH)))))) (COND ((LITATOM (CDR TYPE)) (* ; "Qualified name") (COURIER.WRITE STREAM ITEM (CAR TYPE) (CDR TYPE))) ((SETQ X (GETPROP (CAR TYPE) (QUOTE COURIERDEF))) (* ; "User-defined type") (CL:FUNCALL (CADR X) STREAM ITEM PROGRAM TYPE)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) +) + +(COURIER.WRITE.SEQUENCE +(LAMBDA (STREAM ITEMLIST PROGRAM TYPE) (* bvm%: " 4-Jul-84 15:13") (PROG ((BASETYPE TYPE)) (COND ((EQ (CAR (LISTP ITEMLIST)) (QUOTE INTERPRETATION)) (* ;; "This is how to write a (SEQUENCE UNSPECIFIED) without running it through COURIER.WRITE.REP first. ITEMLIST = (INTERPRETATION type value)") (COND ((NEQ BASETYPE (QUOTE UNSPECIFIED)) (\COURIER.TYPE.ERROR ITEMLIST TYPE)) (T (SETQ BASETYPE (CADR ITEMLIST)) (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM (CADDR ITEMLIST) (COND ((LISTP BASETYPE) (PROG1 (CAR BASETYPE) (SETQ BASETYPE (CDR BASETYPE)))) (T PROGRAM)) BASETYPE)))) ((NULL ITEMLIST) (PUTWORD STREAM 0)) ((LISTP ITEMLIST) (PUTWORD STREAM (LENGTH ITEMLIST)) (for X in ITEMLIST do (COURIER.WRITE STREAM X PROGRAM BASETYPE))) (T (\COURIER.TYPE.ERROR ITEMLIST TYPE))))) +) + +(COURIER.WRITE.STRING +(LAMBDA (STREAM STRING) (* ; "Edited 21-Jul-87 14:36 by bvm:") (if (fetch (STRINGP FATSTRINGP) of (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING)))) then (* ; "Have to produce NS encoding") (COURIER.WRITE.FAT.STRING STREAM STRING) else (LET ((LENGTH (NCHARS STRING))) (PUTWORD STREAM LENGTH) (\BOUTS STREAM (fetch (STRINGP BASE) of STRING) (fetch (STRINGP OFFST) of STRING) LENGTH) (COND ((ODDP LENGTH) (BOUT STREAM 0)))))) +) + +(COURIER.WRITE.FAT.STRING +(LAMBDA (STREAM STRING UNSPECIFIED) (* ; "Edited 21-Jul-87 15:24 by bvm:") (* ;; "Write the fat string STRING to courier STREAM. If UNSPECIFIED is true, encode it as a sequence unspecified, else as a string.") (LET ((CORE (OPENSTREAM (QUOTE {NODIRCORE}) (QUOTE BOTH))) LENGTH) (PRIN3 STRING CORE) (* ; "Write out string to get encoding and length, then copy the bytes") (SETQ LENGTH (GETFILEPTR CORE)) (if UNSPECIFIED then (* ; "writing sequence unspecified, so include length of sequence") (PUTWORD STREAM (ADD1 (FOLDHI LENGTH BYTESPERWORD)))) (PUTWORD STREAM LENGTH) (COPYBYTES CORE STREAM 0 LENGTH) (COND ((ODDP LENGTH) (BOUT STREAM 0))))) +) + +(COURIER.SKIP +(LAMBDA (STREAM PROGRAM TYPE) (* ; "Edited 30-Jun-87 17:40 by bvm:") (LET (X) (COND ((LITATOM TYPE) (SELECTQ TYPE ((BOOLEAN CARDINAL UNSPECIFIED INTEGER) (* ; "2 bytes") (\BIN STREAM) (\BIN STREAM)) ((LONGCARDINAL LONGINTEGER TIME) (* ; "4 bytes") (\BIN STREAM) (\BIN STREAM) (\BIN STREAM) (\BIN STREAM)) (STRING (* ; "Count followed by number of bytes, padded to even byte") (RPTQ (CEIL (GETWORD STREAM) BYTESPERWORD) (\BIN STREAM))) (COND ((SETQ X (GETPROP TYPE (QUOTE COURIERDEF))) (* ; "User-defined type") (CL:FUNCALL (CAR X) STREAM PROGRAM TYPE)) ((SETQ X (\GET.COURIER.TYPE PROGRAM TYPE)) (COURIER.SKIP STREAM PROGRAM X)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) ((AND (LISTP TYPE) (LITATOM (CAR TYPE))) (SELECTQ (CAR TYPE) (ENUMERATION (* ; "2 bytes") (\BIN STREAM) (\BIN STREAM)) (ARRAY (bind (BASETYPE _ (CADDR TYPE)) to (CADR TYPE) DO (COURIER.SKIP STREAM PROGRAM BASETYPE))) (SEQUENCE (* ; "We ignore the maximum length of the sequence.") (COURIER.SKIP.SEQUENCE STREAM PROGRAM (OR (CADDR TYPE) (CADR TYPE)))) ((RECORD NAMEDRECORD) (for NAMEANDTYPE in (CDR TYPE) DO (COURIER.SKIP STREAM PROGRAM (CADR NAMEANDTYPE)))) (CHOICE (bind (WHICH _ (GETWORD STREAM)) for DEF in (CDR TYPE) do (* ; "DEF = (tag choice# type); type = NIL is shorthand for type null record") (COND ((IEQP WHICH (CADR DEF)) (RETURN (AND (CADDR DEF) (COURIER.SKIP STREAM PROGRAM (CADDR DEF)))))))) (COND ((LITATOM (CDR TYPE)) (* ; "Qualified name") (COURIER.SKIP STREAM (CAR TYPE) (CDR TYPE))) ((SETQ X (GETPROP (CAR TYPE) (QUOTE COURIERDEF))) (CL:FUNCALL (CAR X) STREAM PROGRAM TYPE)) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) +) + +(COURIER.SKIP.SEQUENCE +(LAMBDA (STREAM PROGRAM BASETYPE) (* ; "Edited 30-Jun-87 17:40 by bvm:") (* ;;; "Reads a Courier SEQUENCE, returning it as a list of objects of type BASETYPE") (to (GETWORD STREAM) do (COURIER.SKIP STREAM PROGRAM BASETYPE))) +) + +(\COURIER.TYPE.ERROR +(LAMBDA (ITEM TYPE) (* bvm%: " 3-Jul-84 17:53") (ERROR (CONCAT "Arg not of Courier type " TYPE) ITEM)) +) + +(DECODE-NS-STRING + [LAMBDA (STR) (* ; "Edited 10-Mar-89 14:50 by bvm") + + (* ;; "STR is a string read from an 8-bit stream but that might have NS run coding in it. We return the string that results from interpreting the runcoding") + + (LET* + ((LENGTH (NCHARS STR)) + (BASE (fetch (STRINGP BASE) of STR)) + (OFFSET (fetch (STRINGP OFFST) of STR)) + (LASTOFFSET (+ OFFSET LENGTH)) + (FATLENGTH 0)) + (bind (I _ OFFSET) + (BYTEINC _ 1) while (< I LASTOFFSET) + do (* ; + "Count how many chars will be in output") + (if (EQ (\GETBASEBYTE BASE I) + 255) + then (SETQ BYTEINC (if (AND (< (add I 1) + LASTOFFSET) + (EQ (\GETBASEBYTE BASE I) + 255)) + then (* ; + "255-255-0 means 2 bytes per char") + 2 + else (* ; "255-x means shift to charset x") + 1)) + else (* ; "Ordinary character") + (add FATLENGTH 1)) + + (* ;; "Bump I past the number of bytes consumed on this iteration. Note that in the case of 255 we bumped i once already, and we now bump it 1 more ordinarily, or 2 if the sequence was 255-255-0") + + (add I BYTEINC)) + (if (< FATLENGTH LENGTH) + then (* ; + "If length is the same, then there must not have been any fat chars") + (LET* ((FATSTR (ALLOCSTRING FATLENGTH NIL NIL T)) + (FATBASE (\ADDBASE (fetch (STRINGP BASE) of FATSTR) + (fetch (STRINGP OFFST) of FATSTR))) + (I OFFSET) + (CSET 0) + CH) + (while (< I LASTOFFSET) + do (if (EQ (SETQ CH (\GETBASEBYTE BASE I)) + 255) + then (* ; "Switch char sets or runcoding") + [if (< (add I 1) + LASTOFFSET) + then (* ; + "Check is for naked 255 at end--bug, but we'll ignore it") + (SETQ CSET (if (EQ (SETQ CSET (\GETBASEBYTE BASE I)) + 255) + then + (* ; + "Stop runcoding. Ignore next byte (should be zero; if not, we haven't the foggiest)") + (add I 1) + T + else (LLSH CSET 8] + else (\PUTBASE FATBASE 0 + (if (EQ CSET T) + then (+ (LLSH CH 8) + (if (< (add I 1) + LASTOFFSET) + then (\GETBASEBYTE BASE I) + else + (* ; + "ack, eof. Don't attempt a possibly illegal fetch") + 0)) + else (+ CSET CH))) + (SETQ FATBASE (\ADDBASE FATBASE 1))) + (add I 1)) + FATSTR) + else STR]) +) +(DEFINEQ + +(COURIER.READ.BULKDATA +(LAMBDA (STREAM PROGRAM TYPE DONTCLOSE) (* bvm%: "13-Feb-85 23:42") (* ;;; "Read a Bulk Data object which is a stream of the specified type. This can be done by declaring the stream type in Courier, as is done in the protocol specs, but that causes COURIER.READ to produce a deeply nested structure. Instead, this function returns a list of objects making up the stream. See the Bulk Data Transfer spec.") (* ;; "Closes STREAM on exit unless DONTCLOSE is true. If STREAM is not a stream, returns it directly, presumably an error from COURIER.CALL") (COND ((type? STREAM STREAM) (PROG1 (bind LASTSEGMENT? join (PROGN (SETQ LASTSEGMENT? (NEQ (GETWORD STREAM) 0)) (COURIER.READ.SEQUENCE STREAM PROGRAM TYPE)) repeatuntil LASTSEGMENT?) (OR DONTCLOSE (CLOSEF STREAM)))) (T (* ; "An error return from COURIER.CALL -- pass it thru") STREAM))) +) + +(BULKDATA.GENERATOR +(LAMBDA (STREAM PROGRAM TYPE) (* bvm%: "19-Jul-84 11:40") (* ;; "Produces a generator for reading from STREAM a Courier `Stream of PROGRAM.TYPE' . The value returned from this function is an object to pass to BULKDATA.GENERATE.NEXT to retrieve the next item from the stream.") (create BULKDATAGENERATOR BGSTREAM _ STREAM BGPROGRAM _ PROGRAM BGTYPE _ TYPE BGLASTSEGMENT? _ NIL BGITEMSLEFT _ 0)) +) + +(BULKDATA.GENERATE.NEXT +(LAMBDA (GENSTATE) (* bvm%: "19-Jul-84 11:34") (* ;; "Returns the next item from bulkdata generator GENSTATE, updating the state. Returns NIL when generator exhausted") (PROG ((STREAM (fetch BGSTREAM of GENSTATE)) (CNT (fetch BGITEMSLEFT of GENSTATE))) LP (COND ((NEQ CNT 0) (* ; "Middle of a segment") (replace BGITEMSLEFT of GENSTATE with (SUB1 CNT))) ((fetch BGLASTSEGMENT? of GENSTATE) (* ; "Finished last segment") (RETURN NIL)) (T (* ; "Finished a segment, get the next") (COND ((NEQ (GETWORD STREAM) 0) (replace BGLASTSEGMENT? of GENSTATE with T))) (SETQ CNT (GETWORD STREAM)) (GO LP))) (RETURN (COURIER.READ STREAM (fetch BGPROGRAM of GENSTATE) (fetch BGTYPE of GENSTATE))))) +) + +(COURIER.WRITE.BULKDATA +(LAMBDA (STREAM ITEMLIST PROGRAM TYPE) (* bvm%: " 4-Jul-84 15:24") (* ;;; "Writes ITEMLIST as a Bulk Data object which is a stream of the specified type, i.e., ITEMLIST is interpreted as a list of (PROGRAM . TYPE) objects. Returns NIL") (* ;; "Format a little strange: a succession of SEQUENCE's, the last of which is flagged as the final sequence. In theory, one could send the entire list, up to 65535 items, as a single sequence, but maybe that overloads some processors, so break it up into smaller chunks") (PROG ((LEN (LENGTH ITEMLIST)) (TAIL ITEMLIST) SEGMENTLENGTH) (do (PUTWORD STREAM (COND ((IGREATERP LEN 100) (* ; "Don't try to write too long segments") (SETQ SEGMENTLENGTH 100) (* ; "Not last segment") 0) (T (SETQ SEGMENTLENGTH LEN) 1))) (PUTWORD STREAM SEGMENTLENGTH) (to SEGMENTLENGTH do (COURIER.WRITE STREAM (pop TAIL) PROGRAM TYPE)) (SETQ LEN (IDIFFERENCE LEN SEGMENTLENGTH)) repeatwhile TAIL))) +) + +(COURIER.ABORT.BULKDATA +(LAMBDA (ERROR) (* ; "Edited 27-Aug-87 11:18 by bvm:") (* ;; "Called from within a bulkdata handler to abort the bulk data operation. The corresponding CATCH is in \COURIER.HANDLE.BULKDATA. Optional ERROR should be returned from the courier call, instead of what the procedure returns (typically (error transfer.error Aborted)).") (COND (ERROR (CL:THROW :BULKDATA (CL:VALUES :ABORT ERROR))) (T (CL:THROW :BULKDATA :ABORT)))) +) +) + + + +(* ; "Reading/writing sequence unspecified in an interesting way") + +(DEFINEQ + +(COURIER.READ.REP +(LAMBDA (LIST.OF.WORDS PROGRAM TEMPLATE) (* bvm%: "14-Jun-84 15:08") (* ;; "Like COURIER.READ but `reads' from a list of integers corresponding to the words in the Courier representation.") (COURIER.READ (\MAKE.COURIER.REP.STREAM LIST.OF.WORDS) PROGRAM TEMPLATE)) +) + +(COURIER.WRITE.REP +(LAMBDA (VALUE PROGRAM TYPE) (* bvm%: "14-Jun-84 16:15") (PROG ((STREAM (\MAKE.COURIER.REP.STREAM))) (COURIER.WRITE STREAM VALUE PROGRAM TYPE) (COND ((fetch CRNEXTBYTE of STREAM) (\BOUT STREAM 0))) (RETURN (fetch CRWORDLIST of STREAM)))) +) + +(COURIER.WRITE.SEQUENCE.UNSPECIFIED +(LAMBDA (STREAM ITEM PROGRAM TYPE) (* ; "Edited 21-Jul-87 14:27 by bvm:") (* ;;; "Write ITEM on STREAM as a (SEQUENCE UNSPECIFIED) interpreted as a (PROGRAM . TYPE); this means figuring out how long ITEM is so we can write the appropriate word count before sending ITEM") (PROG (X FN) (COND ((LITATOM TYPE) (SELECTQ TYPE (BOOLEAN (PUTWORD STREAM 1) (PUTWORD STREAM (COND (ITEM 1) (T 0)))) ((CARDINAL UNSPECIFIED) (PUTWORD STREAM 1) (PUTWORD STREAM ITEM)) (INTEGER (PUTWORD STREAM 1) (PUTWORD STREAM (UNSIGNED ITEM BITSPERWORD))) ((LONGCARDINAL LONGINTEGER) (PUTWORD STREAM 2) (PUTLONG STREAM ITEM)) (STRING (if (fetch (STRINGP FATSTRINGP) of (OR (STRINGP ITEM) (SETQ ITEM (MKSTRING ITEM)))) then (* ; "Have to produce NS encoding") (COURIER.WRITE.FAT.STRING STREAM ITEM T) else (PUTWORD STREAM (ADD1 (FOLDHI (NCHARS ITEM) BYTESPERWORD))) (COURIER.WRITE.STRING STREAM ITEM))) (TIME (PUTWORD STREAM 2) (PUTLONG STREAM (LISP.TO.ALTO.DATE ITEM))) (COND ((SETQ X (GETPROP TYPE (QUOTE COURIERDEF))) (* ; "User-defined type") (GO USERTYPE)) ((SETQ X (\GET.COURIER.TYPE PROGRAM TYPE)) (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM ITEM PROGRAM X)) (T (\CWSU.DEFAULT STREAM ITEM PROGRAM TYPE))))) ((AND (LISTP TYPE) (LITATOM (CAR TYPE))) (SELECTQ (CAR TYPE) (ENUMERATION (PUTWORD STREAM 1) (COURIER.WRITE STREAM ITEM PROGRAM TYPE)) ((ARRAY SEQUENCE RECORD NAMEDRECORD CHOICE) (PROG ((LENGTH (COURIER.REP.LENGTH ITEM PROGRAM TYPE))) (COND (LENGTH (PUTWORD STREAM LENGTH) (COURIER.WRITE STREAM ITEM PROGRAM TYPE)) (T (\CWSU.DEFAULT STREAM ITEM PROGRAM TYPE))))) (COND ((LITATOM (CDR TYPE)) (* ; "Qualified name") (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM ITEM (CAR TYPE) (CDR TYPE))) ((SETQ X (GETPROP (CAR TYPE) (QUOTE COURIERDEF))) (* ; "User-defined type") (GO USERTYPE)) (T (\CWSU.DEFAULT STREAM ITEM PROGRAM TYPE))))) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))) (RETURN) USERTYPE (* ; "X = (readFn writeFn lengthFn writeSequenceFn)") (COND ((SETQ FN (CADDDR X)) (CL:FUNCALL FN STREAM ITEM PROGRAM TYPE)) ((AND (SETQ FN (CADDR X)) (OR (FIXP FN) (SETQ FN (CL:FUNCALL FN ITEM PROGRAM TYPE)))) (* ; "Says how long it is") (PUTWORD STREAM FN) (CL:FUNCALL (CADR X) STREAM ITEM PROGRAM TYPE)) (T (\CWSU.DEFAULT STREAM ITEM PROGRAM TYPE))))) +) + +(\CWSU.DEFAULT +(LAMBDA (STREAM ITEM PROGRAM TYPE) (* bvm%: " 1-Jul-84 18:05") (COURIER.WRITE STREAM (COURIER.WRITE.REP ITEM PROGRAM TYPE) NIL (QUOTE (SEQUENCE UNSPECIFIED)))) +) + +(COURIER.REP.LENGTH +(LAMBDA (ITEM PROGRAM TYPE) (* ; "Edited 21-Jul-87 14:35 by bvm:") (* ;;; "Returns the number of words that the Courier rep of ITEM as a (PROGRAM . TYPE) would occupy or NIL if we can't easily figure it out") (LET (X) (COND ((LITATOM TYPE) (SELECTQ TYPE ((BOOLEAN CARDINAL INTEGER UNSPECIFIED) 1) ((LONGCARDINAL LONGINTEGER TIME) 2) (STRING (if (NOT (fetch (STRINGP FATSTRINGP) of (OR (STRINGP ITEM) (SETQ ITEM (MKSTRING ITEM))))) then (* ; "Too hard to figure out fat length") (ADD1 (FOLDHI (NCHARS ITEM) BYTESPERWORD)))) (COND ((SETQ X (GETPROP TYPE (QUOTE COURIERDEF))) (* ; "User-defined type") (AND (SETQ X (CADDR X)) (OR (FIXP X) (CL:FUNCALL X ITEM PROGRAM TYPE)))) ((SETQ X (\GET.COURIER.TYPE PROGRAM TYPE)) (COURIER.REP.LENGTH ITEM PROGRAM X))))) ((AND (LISTP TYPE) (LITATOM (CAR TYPE))) (SELECTQ (CAR TYPE) (ENUMERATION 1) (ARRAY (for X in ITEM bind (BASETYPE _ (CADDR TYPE)) sum (OR (COURIER.REP.LENGTH X PROGRAM BASETYPE) (RETURN)))) (SEQUENCE (for X in ITEM bind (BASETYPE _ (OR (CADDR TYPE) (CADR TYPE))) sum (OR (COURIER.REP.LENGTH X PROGRAM BASETYPE) (RETURN)) finally (* ; "Count the word which is the sequence length") (RETURN (ADD1 $$VAL)))) (RECORD (for NAMEANDTYPE in (CDR TYPE) as VALUE in ITEM sum (OR (COURIER.REP.LENGTH VALUE PROGRAM (CADR NAMEANDTYPE)) (RETURN)))) (NAMEDRECORD (for NAMEANDTYPE in (CDR TYPE) as NAMEANDVALUE in ITEM sum (OR (COURIER.REP.LENGTH (CADR NAMEANDVALUE) PROGRAM (CADR NAMEANDTYPE)) (RETURN)))) (CHOICE (LET* ((WHICH (OR (ASSOC (CAR ITEM) (CDR TYPE)) (\COURIER.TYPE.ERROR ITEM (QUOTE CHOICE)))) (N (COND ((CADDR WHICH) (COURIER.REP.LENGTH (CADR ITEM) PROGRAM (CADDR WHICH))) (T 0)))) (AND N (ADD1 N)))) (COND ((LITATOM (CDR TYPE)) (* ; "Qualified name") (COURIER.REP.LENGTH ITEM (CAR TYPE) (CDR TYPE))) ((SETQ X (GETPROP (CAR TYPE) (QUOTE COURIERDEF))) (* ; "User-defined type") (AND (SETQ X (CADDR X)) (OR (FIXP X) (CL:FUNCALL X ITEM PROGRAM TYPE))))))) (T (\COURIER.UNKNOWN.TYPE PROGRAM TYPE))))) +) + +(\MAKE.COURIER.REP.STREAM +(LAMBDA (LIST.OF.WORDS) (* bvm%: "15-Jun-84 11:54") (* ;;; "Makes a STREAM whose BIN operation produces bytes from LIST.OF.WORDS or whose BOUT operation produces a list of words in the stream's CRWORDLIST field (can only use stream for one or the other, of course)") (PROG ((STREAM (NCREATE (QUOTE STREAM)))) (replace DEVICE of STREAM with (OR \COURIER.REP.DEVICE (PROGN (SETQ \COURIER.REP.DEVICE (NCREATE (QUOTE FDEV))) (replace BLOCKIN of \COURIER.REP.DEVICE with (FUNCTION \NONPAGEDBINS)) (replace BLOCKOUT of \COURIER.REP.DEVICE with (FUNCTION \NONPAGEDBOUTS)) \COURIER.REP.DEVICE))) (replace ACCESSBITS of STREAM with BothBits) (replace STRMBINFN of STREAM with (FUNCTION \COURIER.REP.BIN)) (replace STRMBOUTFN of STREAM with (FUNCTION \COURIER.REP.BOUT)) (replace ENDOFSTREAMOP of STREAM with (FUNCTION \COURIER.EOF)) (replace CRWORDLIST of STREAM with LIST.OF.WORDS) (RETURN STREAM))) +) + +(\COURIER.REP.BIN +(LAMBDA (STREAM) (* bvm%: "14-Jun-84 16:06") (PROG ((X (fetch CRNEXTBYTE of STREAM))) (RETURN (COND (X (replace CRNEXTBYTE of STREAM with NIL) X) (T (SETQ X (OR (pop (fetch CRWORDLIST of STREAM)) (ERROR "Courier stream prematurely terminated"))) (replace CRNEXTBYTE of STREAM with (fetch LOBYTE of X)) (fetch HIBYTE of X)))))) +) + +(\COURIER.REP.BOUT +(LAMBDA (STREAM BYTE) (* bvm%: "14-Jun-84 16:13") (PROG ((X (fetch CRNEXTBYTE of STREAM)) TAIL) (COND (X (SETQ X (create WORD HIBYTE _ X LOBYTE _ BYTE)) (replace CRLASTWORD of STREAM with (COND ((SETQ TAIL (fetch CRLASTWORD of STREAM)) (CDR (RPLACD TAIL (CONS X)))) (T (replace CRWORDLIST of STREAM with (LIST X))))) (replace CRNEXTBYTE of STREAM with NIL)) (T (replace CRNEXTBYTE of STREAM with BYTE))))) +) +) + +(RPAQ? \COURIER.REP.DEVICE NIL) +(DEFINEQ + +(COURIER.READ.NSADDRESS +(LAMBDA (STREAM) (* bvm%: "12-Jun-84 11:41") (* ;; "Read a standard NSADDRESS from the next 6 words of STREAM") (LET ((ADDR (create NSADDRESS))) (\BINS STREAM ADDR 0 (UNFOLD \#WDS.NSADDRESS BYTESPERWORD)) ADDR)) +) + +(COURIER.WRITE.NSADDRESS +(LAMBDA (STREAM ADDR) (* bvm%: "12-Jun-84 11:45") (\BOUTS STREAM (\DTEST ADDR (QUOTE NSADDRESS)) 0 (UNFOLD \#WDS.NSADDRESS BYTESPERWORD))) +) +) + +(PUTPROPS NSADDRESS COURIERDEF (COURIER.READ.NSADDRESS COURIER.WRITE.NSADDRESS 6)) + + + +(* ; "Debugging") + + +(RPAQ? COURIERTRACEFILE ) + +(RPAQ? COURIERTRACEFLG ) + +(RPAQ? COURIERPRINTLEVEL '(2 . 4)) + +(RPAQ? NSWIZARDFLG ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS COURIERTRACEFLG COURIERTRACEFILE COURIERPRINTLEVEL NSWIZARDFLG) +) +(DEFINEQ + +(COURIERTRACE +(LAMBDA (FLG REGION) (* ; "Edited 1-May-87 11:22 by bvm:") (if (NULL FLG) then (if (ACTIVEWP COURIERTRACEFILE) then (CLOSEW COURIERTRACEFILE)) (SETQ COURIERTRACEFILE T) (SETQ COURIERTRACEFLG NIL) else (if (NOT (ACTIVEWP COURIERTRACEFILE)) then (SETQ COURIERTRACEFILE (CREATEW REGION "Courier Trace Window"))) (WINDOWPROP COURIERTRACEFILE (QUOTE BUTTONEVENTFN) (FUNCTION (LAMBDA (WINDOW) (if (LASTMOUSESTATE (NOT UP)) then (\CHANGE.ETHER.TRACING WINDOW (QUOTE COURIERTRACEFLG)))))) (WINDOWPROP COURIERTRACEFILE (QUOTE CLOSEFN) (FUNCTION (LAMBDA (WINDOW) (if (EQ WINDOW COURIERTRACEFILE) then (SETQ COURIERTRACEFLG NIL) (SETQ COURIERTRACEFILE T))))) (WINDOWPROP COURIERTRACEFILE (QUOTE SHRINKFN) (FUNCTION (LAMBDA (WINDOW) (if (EQ WINDOW COURIERTRACEFILE) then (* ; "Turn off tracing while window shrunk") (WINDOWPROP WINDOW (QUOTE COURIERTRACEFLG) COURIERTRACEFLG) (SETQ COURIERTRACEFLG NIL))))) (WINDOWPROP COURIERTRACEFILE (QUOTE EXPANDFN) (FUNCTION (LAMBDA (WINDOW) (if (EQ WINDOW COURIERTRACEFILE) then (* ; "Restore tracing to previous state") (SETQ COURIERTRACEFLG (WINDOWPROP WINDOW (QUOTE COURIERTRACEFLG) NIL)))))) (DSPFONT (FONTCREATE (QUOTE GACHA) 8) COURIERTRACEFILE) (SETQ COURIERTRACEFLG FLG) (DSPSCROLL T COURIERTRACEFILE) (TOTOPW COURIERTRACEFILE) T)) +) + +(\COURIER.TRACE +(LAMBDA (EVENT PROGRAM PROCEDURE ARGUMENTS) (* bvm%: "22-Jun-84 17:16") (SELECTQ EVENT (CALL (printout COURIERTRACEFILE .TAB0 0 PROGRAM "." PROCEDURE "[") (COND (ARGUMENTS (COND ((EQ COURIERTRACEFLG (QUOTE PEEK)) (printout COURIERTRACEFILE (QUOTE --))) (T (for X in ARGUMENTS bind (FIRSTTIME _ T) do (COND (FIRSTTIME (SETQ FIRSTTIME NIL)) (T (SPACES 1 COURIERTRACEFILE))) (LVLPRIN2 X COURIERTRACEFILE (CAR COURIERPRINTLEVEL) (CDR COURIERPRINTLEVEL))))))) (printout COURIERTRACEFILE (QUOTE %]))) (RETURN (printout COURIERTRACEFILE " => ") (COND ((EQ COURIERTRACEFLG (QUOTE PEEK)) (printout COURIERTRACEFILE (COND ((CDR (LISTP ARGUMENTS)) (QUOTE --)) (T "&")))) (T (LVLPRINT ARGUMENTS COURIERTRACEFILE (CAR COURIERPRINTLEVEL) (CDR COURIERPRINTLEVEL))))) (BEGIN.BULK.DATA (printout COURIERTRACEFILE (COND ((EQ COURIERTRACEFLG (QUOTE PEEK)) (QUOTE {)) (T "{bulk data")))) (END.BULK.DATA (printout COURIERTRACEFILE (QUOTE }))) (SHOULDNT))) +) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA \DUMP.COURIERPROGRAMS COURIERPROGRAM) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA COURIER.EXPEDITED.CALL COURIER.CALL) +) +(PUTPROPS COURIER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 +1992 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (9734 14263 (COURIER.VERSION# 9744 . 9891) (COURIERPROGRAM 9893 . 10371) ( +\COURIER.CHECKDEF 10373 . 10920) (\COURIER.CHECK.PROCEDURES 10922 . 12053) (\COURIER.CHECK.ERRORS +12055 . 12646) (\COURIER.DELDEF 12648 . 12794) (\COURIER.GETDEF 12796 . 12942) (\COURIER.PUTDEF 12944 + . 13505) (\DUMP.COURIERPROGRAMS 13507 . 14261)) (14264 15037 (\GET.COURIER.TYPE 14274 . 14423) ( +\GET.COURIER.DEFINITION 14425 . 15035)) (15368 17115 (\COURIER.RECORDTRAN 15378 . 17113)) (17358 35200 + (COURIER.OPEN 17368 . 20070) (\COURIER.WHENCLOSED 20072 . 20326) (COURIER.CALL 20328 . 22494) ( +COURIER.EXECUTE.CALL 22496 . 24218) (\COURIER.RESULTS 24220 . 26390) (COURIER.SIGNAL.ERROR 26392 . +27088) (\COURIER.HANDLE.BULKDATA 27090 . 28503) (\COURIER.HANDLE.ERROR 28505 . 28729) ( +\BULK.DATA.STREAM 28731 . 30692) (\COURIER.ATTENTIONFN 30694 . 31362) (\COURIER.OUTPUT.ABORTED 31364 + . 32234) (\BULK.DATA.CLOSE 32236 . 34456) (\ABORT.BULK.DATA 34458 . 35198)) (35201 43641 ( +COURIER.EXPEDITED.CALL 35211 . 36634) (COURIER.EXECUTE.EXPEDITED.CALL 36636 . 37707) ( +\BUILD.EXPEDITED.XIP 37709 . 38694) (\SEND.EXPEDITED.XIP 38696 . 40422) (\COURIER.EXPEDITED.ARGS 40424 + . 40776) (\MAKE.EXPEDITED.STREAM 40778 . 43117) (\COURIER.EOF 43119 . 43326) ( +\COURIER.EXPEDITED.OVERFLOW 43328 . 43639)) (43642 47217 (COURIER.BROADCAST.CALL 43652 . 46444) ( +\COURIER.BROADCAST.ON.NET 46446 . 47215)) (47218 61382 (COURIER.READ 47228 . 49151) ( +\COURIER.UNKNOWN.TYPE 49153 . 49310) (COURIER.READ.SEQUENCE 49312 . 49559) (COURIER.READ.STRING 49561 + . 50555) (COURIER.WRITE 50557 . 52806) (COURIER.WRITE.SEQUENCE 52808 . 53611) (COURIER.WRITE.STRING +53613 . 54068) (COURIER.WRITE.FAT.STRING 54070 . 54745) (COURIER.SKIP 54747 . 56423) ( +COURIER.SKIP.SEQUENCE 56425 . 56678) (\COURIER.TYPE.ERROR 56680 . 56809) (DECODE-NS-STRING 56811 . +61380)) (61383 64808 (COURIER.READ.BULKDATA 61393 . 62261) (BULKDATA.GENERATOR 62263 . 62683) ( +BULKDATA.GENERATE.NEXT 62685 . 63399) (COURIER.WRITE.BULKDATA 63401 . 64348) (COURIER.ABORT.BULKDATA +64350 . 64806)) (64884 71585 (COURIER.READ.REP 64894 . 65181) (COURIER.WRITE.REP 65183 . 65445) ( +COURIER.WRITE.SEQUENCE.UNSPECIFIED 65447 . 67714) (\CWSU.DEFAULT 67716 . 67896) (COURIER.REP.LENGTH +67898 . 69874) (\MAKE.COURIER.REP.STREAM 69876 . 70799) (\COURIER.REP.BIN 70801 . 71151) ( +\COURIER.REP.BOUT 71153 . 71583)) (71623 72047 (COURIER.READ.NSADDRESS 71633 . 71874) ( +COURIER.WRITE.NSADDRESS 71876 . 72045)) (72407 74664 (COURIERTRACE 72417 . 73704) (\COURIER.TRACE +73706 . 74662))))) +STOP diff --git a/sources/D-ASSEM b/sources/D-ASSEM new file mode 100644 index 00000000..da72b129 --- /dev/null +++ b/sources/D-ASSEM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "D-ASSEM" (USE "LISP" "XCL"))) (IL:FILECREATED " 1-Dec-92 02:18:56" "{Pele:mv:envos}Sources>D-ASSEM.;12" 131316 IL:|changes| IL:|to:| (IL:FUNCTIONS EMIT-BYTE FIXUP-PTR FIXUP-PTR-NO-REF FIXUP-SYMBOL FIXUP-NTENTRY INTERN-DCODE) IL:|previous| IL:|date:| "17-Nov-92 02:55:57" "{Pele:mv:envos}Sources>D-ASSEM.;11") ; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:D-ASSEMCOMS) (IL:RPAQQ IL:D-ASSEMCOMS ( (IL:* IL:|;;;| "D-machine Assembler.") (IL:FILES IL:D-ASSEM-PACKAGE) (IL:COMS (IL:* IL:|;;| "Data structures and utilities") (IL:STRUCTURES DCODE DJUMP DLAMBDA DTAG DVAR) (IL:FUNCTIONS RELEASE-DCODE) (IL:FUNCTIONS CREATE-HUNK TYPE-NAME-FROM-SIZE) (IL:FUNCTIONS COPY-LAP-FN COPY-LAP-CODE) (IL:FUNCTIONS MAXF)) (IL:COMS (IL:* IL:|;;| "Handy constants") (IL:VARIABLES +IVAR-CODE+ +PVAR-CODE+ +FVAR-CODE+) (IL:VARIABLES +LAMBDA-SPREAD+ +NLAMBDA-SPREAD+ +LAMBDA-NO-SPREAD+ +NLAMBDA-NO-SPREAD+) (IL:VARIABLES +CONSTANT-OPCODES+)) (IL:COMS (IL:* IL:|;;| "Opcode generation") (IL:VARIABLES *BYTES* *BYTE-COUNT*) (IL:FUNCTIONS START-BYTES EMIT-BYTE EMIT-BYTE-LIST END-BYTES) (IL:FUNCTIONS CHOOSE-OP FETCH-HUNK REF-VAR STORE-VAR MAX-ARG PUSH-INTEGER)) (IL:COMS (IL:* IL:|;;| "Main driving") (IL:VARIABLES *DTAG-ENV* *DVAR-ENV* *STACK-ENV*) (IL:VARIABLES *HUNK-MAP* *DCODE* *LEVEL*) (IL:FUNCTIONS ASSEMBLE-FUNCTION DLAMBDA-FROM-LAMBDA DCODE-FROM-DLAMBDA)) (IL:COMS (IL:* IL:|;;| "Digesting the function") (IL:VARIABLES *HUNK-SIZE* *PVAR-COUNT* *FREE-VARS* *BOUND-SPECIALS*) (IL:VARIABLES +MAX-ALLOWABLE-PVAR-COUNT+ +MAX-ALLOWABLE-SPECIAL-COUNT+ +SLOW-FVAR-SLOT+) (IL:FUNCTIONS DIGEST-FUNCTION DETERMINE-LOCAL-FN-LEXICAL-LEVEL DIGEST-CODE STORE-DIGEST-INFO) (IL:FUNCTIONS DVAR-FROM-LAP-VAR LAP-VAR-ID INSTALL-LOCAL INSTALL-VAR INTERN-VAR INTERN-TAG)) (IL:COMS (IL:* IL:|;;| "Function entry code") (IL:FUNCTIONS EASY-ENTRY-P GENERATE-EASY-ENTRY) (IL:FUNCTIONS GENERATE-HARD-ENTRY GENERATE-ARG-CHECK GENERATE-KEY GENERATE-OPT-AND-REST)) (IL:COMS (IL:* IL:|;;| "Stack analysis") (IL:VARIABLES *ENDING-DEPTH*) (IL:FUNCTIONS GATHER-TAGS GATHER-ROOTS REACH-TAGS STACK-ANALYZE STACK-ANALYZE-CODE) ) (IL:COMS (IL:* IL:|;;| "The guts of assembly") (IL:FUNCTIONS ASSEMBLE ASSEMBLE-CODE)) (IL:COMS (IL:* IL:|;;| "Jump resolution") (IL:VARIABLES *JUMP-LIST*) (IL:VARIABLES +JUMP-CHOICES+ +JUMP-RANGE-SIZE-MAP+ +JUMP-SIZES+) (IL:FUNCTIONS RESOLVE-JUMPS REDUCE-UNCERTAINTY SPLICE-IN-JUMPS COMPUTE-JUMP-SIZE) (IL:COMS (IL:* IL:\;  "Debugging jump resolution") (IL:FUNCTIONS PRETTY-JUMPS))) (IL:COMS (IL:* IL:|;;| "Conversion to binary") (IL:VARIABLES *LOCAL-FN-FIXUPS*) (IL:FUNCTIONS CONVERT-TO-BINARY)) (IL:COMS (IL:* IL:|;;| "Setting up the debugging information") (IL:FUNCTIONS COMPUTE-DEBUGGING-INFO)) (IL:COMS (IL:* IL:|;;| "Fixup resolution and DCODE interning") (IL:FUNCTIONS START-PC-FROM-NT-COUNT START-PC-FROM-NT-COUNT-LOCAL ALLOCATE-CODE-BLOCK FIXUP-PTR FIXUP-PTR-NO-REF FIXUP-SYMBOL FIXUP-NTENTRY FIXUP-WORD INTERN-DCODE PERFORM-LOCAL-FN-FIXUPS)) (IL:* IL:|;;| "Arrange for the correct compiler to be used") (IL:PROP IL:FILETYPE IL:D-ASSEM) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:D-ASSEM) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP) IL:LLBASIC IL:LLCODE IL:LLGC IL:MODARITH) ))) (IL:* IL:|;;;| "D-machine Assembler.") (IL:FILESLOAD IL:D-ASSEM-PACKAGE) (IL:* IL:|;;| "Data structures and utilities") (DEFSTRUCT DCODE FRAME-NAME NLOCALS NFREEVARS ARG-TYPE NUM-ARGS (NAME-TABLE NIL) DEBUGGING-INFO CODE-ARRAY (FN-FIXUPS NIL) (SYM-FIXUPS NIL) (LIT-FIXUPS NIL) (TYPE-FIXUPS NIL) CLOSURE-P (LOCAL-FN-FIXUPS NIL) (INTERN-RESULT NIL)) (DEFSTRUCT DJUMP KIND TAG PTR MIN-PC MIN-SIZE FORWARD-P SIZE-UNCERTAINTY) (DEFSTRUCT (DLAMBDA (:CONSTRUCTOR MAKE-DLAMBDA (REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP CLOSED-OVER NON-LOCAL BODY LOCAL-FUNCTIONS))) REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP CLOSED-OVER NON-LOCAL BODY LOCAL-FUNCTIONS) (DEFSTRUCT DTAG (IL:* IL:|;;;| "LEVEL is the lexical level of this tag, for use by the stack analyzer.") (IL:* IL:|;;;| "STACK-DEPTH is a pair representing the state of the stack analyzer last time it was here.") (IL:* IL:|;;;| "PTR is the tail of the code list starting with this tag, used by the stack analyzer.") (IL:* IL:|;;;| "PC is the final location of this tag, after jump resolution.") (IL:* IL:|;;;| "MIN-PC is the least location at which this tag could end up, used during jump resolution.") (IL:* IL:|;;;| "PC-UNCERTAINTY is the amount of slack there is in the final location of this tag, used during jump resolution.") (IL:* IL:|;;;| "REACHABLE? is T if we have discovered a way to reach this tag. Used during a pre-pass of stack analysis.") LEVEL STACK-DEPTH PTR PC MIN-PC PC-UNCERTAINTY (REACHABLE? NIL)) (DEFSTRUCT DVAR KIND LEVEL SLOT NAME) (DEFUN RELEASE-DCODE (DCODE) (LET ((LOCAL-FN-FIXUPS (PROG1 (DCODE-LOCAL-FN-FIXUPS DCODE) (SETF (DCODE-LOCAL-FN-FIXUPS DCODE) NIL)))) (DOLIST (FIXUP LOCAL-FN-FIXUPS) (RELEASE-DCODE (FIRST FIXUP)) (RELEASE-DCODE (THIRD FIXUP))))) (DEFUN CREATE-HUNK (HUNK-SIZE MY-SLOT PREV-SLOT POP-P) (IL:* IL:|;;;| "Emit code to create a hunk of the given size and store it into PVAR my-slot. If prev-slot is non-NIL, also emit code to link the new hunk to the one in that slot. If pop-p is non-NIL then don't leave the hunk on the stack.") (EMIT-BYTE-LIST `(IL:SICX (:TYPE ,(TYPE-NAME-FROM-SIZE HUNK-SIZE)) IL:CREATECELL ,@(AND PREV-SLOT `(,@(CHOOSE-OP '(IL:PVAR . IL:PVARX) PREV-SLOT) IL:RPLPTR.N 0)) ,@(STORE-VAR MY-SLOT POP-P)))) (DEFUN TYPE-NAME-FROM-SIZE (LEN) (IL:PACK* '\\PTRHUNK (IL:|for| HUNK-SIZE IL:|in| IL:\\HUNK.PTRSIZES IL:|when| (<= LEN HUNK-SIZE) IL:|do| (RETURN HUNK-SIZE) IL:|finally| (ERROR "Can't make a hunk that big: ~S" LEN)))) (DEFUN COPY-LAP-FN (FN) (CAR (COPY-LAP-CODE (LIST FN)))) (DEFUN COPY-LAP-CODE (CODE) (IL:FOR INST IL:IN CODE IL:COLLECT (CASE (FIRST INST) ((:CONST) (IL:* IL:\;  "Don't copy the constant itself; it might be shared.") (COPY-LIST INST)) ((:LAMBDA) (FLET ((COPY-LAMBDA-ARGS (ARGS) (UNLESS (NULL ARGS) (WITH-COLLECTION (COLLECT (COPY-TREE (POP ARGS))) (IL:* IL:\; "required.") (LOOP (IL:* IL:\; "other (&KEY) args.") (WHEN (NULL ARGS) (RETURN)) (LET* ((KEY (POP ARGS)) (VAL (POP ARGS))) (COLLECT (COPY-TREE KEY)) (COLLECT (CASE KEY ((:LOCAL-FUNCTIONS) (MAPCAR #'(LAMBDA (FN-PAIR) (CONS (COPY-TREE (CAR FN-PAIR)) (COPY-LAP-CODE (CDR FN-PAIR)))) VAL)) (OTHERWISE (COPY-TREE VAL)))))))))) (LIST* :LAMBDA (COPY-LAMBDA-ARGS (SECOND INST)) (COPY-LAP-CODE (CDDR INST))))) ((:CLOSE) (LIST* :CLOSE (COPY-TREE (SECOND INST)) (COPY-LAP-CODE (CDDR INST)))) ((:CALL) (IF (AND (CONSP (SECOND INST)) (EQ :LAMBDA (FIRST (SECOND INST)))) (LIST* :CALL (LIST* :LAMBDA (COPY-TREE (SECOND (SECOND INST))) (COPY-LAP-CODE (CDDR (SECOND INST)))) (COPY-TREE (CDDR INST))) (COPY-TREE INST))) (OTHERWISE (COPY-TREE INST))))) (DEFINE-MODIFY-MACRO MAXF (&REST COMPILER::NEW-VALUES) MAX) (IL:* IL:|;;| "Handy constants") (DEFCONSTANT +IVAR-CODE+ 0 "Code in name-table for IVARs") (DEFCONSTANT +PVAR-CODE+ 2 "Code in name-table for PVARs") (DEFCONSTANT +FVAR-CODE+ 3 "Code in name-table for FVARs") (DEFCONSTANT +LAMBDA-SPREAD+ 0 "ARGTYPE value for lambda spread functions") (DEFCONSTANT +NLAMBDA-SPREAD+ 1 "ARGTYPE value for nlambda spread functions") (DEFCONSTANT +LAMBDA-NO-SPREAD+ 2 "ARGTYPE value for lambda no-spread functions") (DEFCONSTANT +NLAMBDA-NO-SPREAD+ 3 "ARGTYPE value for nlambda no-spread functions") (DEFCONSTANT +CONSTANT-OPCODES+ '((0 . IL:\'0) (1 . IL:\'1) (NIL . IL:\'NIL) (T . IL:\'T)) "An AList of all constants with dedicated opcodes.") (IL:* IL:|;;| "Opcode generation") (DEFVAR *BYTES* NIL "The data-structure holding the bytes of the current function. Use (start-bytes) to create an empty one, (emit-byte) or (emit-op) to add more bytes on the end, and (end-bytes) to close it off and get an array of the bytes." ) (DEFVAR *BYTE-COUNT* 0 "The number of bytes put on *bytes* so far.") (DEFUN START-BYTES () NIL) (DEFUN EMIT-BYTE (BYTE) (IL:* IL:|;;| "Given the symbolic representation of a byte/opcode to be emitted as part of the assembled code for a function, emit it. Actually, do some fix-ups at the same time, and record some information for other parts of the assembler.") (IL:* IL:|;;| "*BYTES* = the list of emitted bytes, in reverse order (we push onto it)") (IL:* IL:|;;| "*BYTE-COUNT* = running count of bytes emitted so far.") (IL:* IL:|;;| "*JUMP-LIST* = list of jumps and jump-target tags, for later jump resolution.") (COND ((CONSP BYTE) (CASE (FIRST BYTE) ((:TAG) (SETF (DTAG-MIN-PC (SECOND BYTE)) *BYTE-COUNT*) (PUSH (SECOND BYTE) *JUMP-LIST*)) ((:JUMP :FJUMP :TJUMP :NFJUMP :NTJUMP) (PUSH BYTE *BYTES*) (PUSH (MAKE-DJUMP :KIND (FIRST BYTE) :TAG (SECOND BYTE) :PTR *BYTES* :MIN-PC *BYTE-COUNT*) *JUMP-LIST*) (IL:* IL:\;  "Increase the byte-count by the minimum size of this kind of jump.") (INCF *BYTE-COUNT* (SECOND (ASSOC (FIRST BYTE) +JUMP-SIZES+)))) ((:PUSH-TAG) (PUSH 'IL:SICX *BYTES*) (PUSH BYTE *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT* 3)) ((:SYM :FN) (IL:* IL:|;;| "Symbol (e.g., for GVAR) or function name inline in code.") (PUSH BYTE *BYTES*) (COND ((IL:FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (INCF *BYTE-COUNT*) (INCF *BYTE-COUNT*) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*)) ((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (INCF *BYTE-COUNT*) (PUSH 0 *BYTES*))) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT* 2)) ((:TYPE) (IL:* IL:|;;| "Type numbers are 11 bits, and fit in 2 bytes of a SICX.") (PUSH BYTE *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT* 2)) ((:LAMBDA :LIT :LOCAL-FUNCTION) (PUSH BYTE *BYTES*) (COND ((IL:FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT* 4)) (T (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT* 3)))) ((IL:ATOM) (IL:* IL:|;;| "ByteCompiler-style fixup, here because of a DOPVAL. The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list. The padding bytes have been emitted already, so pop them off. Then emit the ATOM byte, and put out new padding bytes. The net increasd in bytes is 1, so incf *BYTE-COUNT*.") (POP *BYTES*) (COND ((IL:FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (POP *BYTES*) (POP *BYTES*)) ((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (POP *BYTES*))) (PUSH (LIST ':SYM (CDR BYTE)) *BYTES*) (COND ((IL:FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*)) ((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (PUSH 0 *BYTES*))) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT*)) ((IL:PTR) (IL:* IL:|;;| "ByteCompiler-style fixup, here because of a DOPVAL. The ByteCompiler put its fixup bytes AFTER the padding bytes, so we have to rearrange things in the byte list.") (COND ((IL:FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (POP *BYTES*) (POP *BYTES*) (POP *BYTES*) (PUSH (LIST ':LIT (CDR BYTE)) *BYTES*) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT*)) ((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) (POP *BYTES*) (POP *BYTES*) (PUSH (LIST ':LIT (CDR BYTE)) *BYTES*) (PUSH 0 *BYTES*) (PUSH 0 *BYTES*) (INCF *BYTE-COUNT*)))) (OTHERWISE (PUSH BYTE *BYTES*) (INCF *BYTE-COUNT*)))) (T (PUSH BYTE *BYTES*) (INCF *BYTE-COUNT*)))) (DEFUN EMIT-BYTE-LIST (L) (IL:|for| BYTE IL:|in| L IL:|do| (EMIT-BYTE BYTE))) (DEFUN END-BYTES () (NREVERSE *BYTES*)) (DEFUN CHOOSE-OP (CHOICES ARG) (IF (<= ARG (MAX-ARG (CAR CHOICES))) `((,(CAR CHOICES) ,ARG)) `(,(CDR CHOICES) ,(IL:LLSH ARG 1)))) (DEFUN FETCH-HUNK (LEVEL) (IF (ZEROP LEVEL) (IL:* IL:\;  "No environment pointer in the base lexical level.") '(IL:\'NIL) (LET* ((MAP-ENTRY (IL:|find| ENTRY IL:|in| (REVERSE *HUNK-MAP*) IL:|suchthat| (<= LEVEL (CAR ENTRY)))) (HUNK-LEVEL (CAR MAP-ENTRY)) (HUNK-SLOT (CDR MAP-ENTRY))) `(,@(CHOOSE-OP '(IL:PVAR . IL:PVARX) HUNK-SLOT) ,@(IL:|for| I IL:|from| 1 IL:|to| (- HUNK-LEVEL LEVEL) IL:|join| (LIST 'IL:GETBASEPTR.N 0)))))) (DEFUN REF-VAR (VAR) (IL:* IL:|;;;| "Return a list of instructions to push the given variable's value onto the stack.") (IF (DVAR-P VAR) (ECASE (DVAR-KIND VAR) ((:LOCAL) (CHOOSE-OP '(IL:PVAR . IL:PVARX) (DVAR-SLOT VAR))) ((:ARGUMENT) (CHOOSE-OP '(IL:IVAR . IL:IVARX) (DVAR-SLOT VAR))) ((:FREE) (IF (EQL (DVAR-SLOT VAR) +SLOW-FVAR-SLOT+) (IL:* IL:|;;| "This one is icky. It couldn't fit in the frame, so we use a call to SYMBOL-VALUE to find the value. Ugh.") `(IL:ACONST (:SYM ,(DVAR-NAME VAR)) IL:FN1 (:FN SYMBOL-VALUE)) (CHOOSE-OP '(IL:FVAR . IL:FVARX) (DVAR-SLOT VAR)))) ((:CLOSED) `(,@(FETCH-HUNK (DVAR-LEVEL VAR)) IL:GETBASEPTR.N ,(IL:LLSH (DVAR-SLOT VAR) 1))) ((:FUNCTION) (ASSERT (NOT (NULL (DVAR-LEVEL VAR))) '(VAR) "BUG: The local function ~A should have a lexical level by now." (DVAR-NAME VAR)) (COND ((AND NIL (ZEROP (DVAR-LEVEL VAR))) (IL:* IL:\;  "We used to do something different for empty environments.") `(IL:GCONST (:LOCAL-FUNCTION ,VAR))) (T `(IL:SICX (:TYPE IL:COMPILED-CLOSURE) IL:CREATECELL IL:GCONST (:LOCAL-FUNCTION ,VAR) IL:RPLPTR.N 0 ,@(AND (NOT (ZEROP (DVAR-LEVEL VAR))) `(,@(FETCH-HUNK (DVAR-LEVEL VAR)) IL:RPLPTR.N 2))))))) (IF (AND (CONSP VAR) (EQ (FIRST VAR) ':G)) `(IL:GVAR (:SYM ,(SECOND VAR))) (ERROR "BUG: This variable is neither global nor a DVAR: ~S" VAR)))) (DEFUN STORE-VAR (VAR-OR-SLOT POP-P) (IL:* IL:|;;;| "Return a list of instructions to store the value on the top of stack into the given variable. If a slot number is given instead, it is assumed to refer to a PVAR. If POP-P is non-NIL, don't leave the value on the stack.") (LET (KIND SLOT) (ETYPECASE VAR-OR-SLOT (FIXNUM (SETQ SLOT VAR-OR-SLOT) (SETQ KIND :LOCAL)) (CONS (UNLESS (EQ (FIRST VAR-OR-SLOT) ':G) (ERROR "BUG: This variable is neither a global nor a DVAR: ~S" VAR-OR-SLOT)) (SETQ KIND :GLOBAL) (SETQ SLOT (SECOND VAR-OR-SLOT))) (DVAR (SETQ SLOT (DVAR-SLOT VAR-OR-SLOT)) (SETQ KIND (DVAR-KIND VAR-OR-SLOT)))) (ECASE KIND ((:LOCAL) (IF POP-P (IF (<= SLOT (MAX-ARG 'IL:PVAR_^)) `((IL:PVAR_^ ,SLOT)) `(,@(CHOOSE-OP '(IL:PVAR_ . IL:PVARX_) SLOT) IL:POP)) (CHOOSE-OP '(IL:PVAR_ . IL:PVARX_) SLOT))) ((:ARGUMENT) `(IL:IVARX_ ,(IL:LLSH SLOT 1) ,@(AND POP-P '(IL:POP)))) ((:FREE) (IF (EQL SLOT +SLOW-FVAR-SLOT+) (IL:* IL:|;;| "This one is icky. It couldn't fit in the frame, so we use a call to SET to store the value. Ugh.") `(IL:ACONST (:SYM ,(DVAR-NAME VAR-OR-SLOT)) IL:SWAP IL:FN2 (:FN SET) ,@(AND POP-P '(IL:POP))) `(IL:FVARX_ ,(IL:LLSH SLOT 1) ,@(AND POP-P '(IL:POP))))) ((:CLOSED) `(,@(AND (NOT POP-P) '(IL:COPY)) ,@(FETCH-HUNK (DVAR-LEVEL VAR-OR-SLOT)) IL:SWAP IL:RPLPTR.N ,(IL:LLSH SLOT 1) IL:POP)) ((:GLOBAL) `(IL:GVAR_ (:SYM ,SLOT) ,@(AND POP-P '(IL:POP))))))) (DEFUN MAX-ARG (OPCODE) (LET ((RANGE (IL:|fetch| IL:OP# IL:|of| (IL:\\FINDOP OPCODE)))) (- (SECOND RANGE) (FIRST RANGE)))) (DEFUN PUSH-INTEGER (N) (COND ((ZEROP N) '(IL:\'0)) ((= N 1) '(IL:\'1)) ((<= -256 N -1) `(IL:SNIC ,(+ N 256))) ((<= 0 N 255) `(IL:SIC ,N)) ((<= 255 N 65535) `(IL:SICX ,(IL:LRSH N 8) ,(LOGAND N 255))) (T `(IL:GCONST (:LIT ,N))))) (IL:* IL:|;;| "Main driving") (DEFVAR *DTAG-ENV* NIL "A hash-table mapping the EQL-unique ID of a LAP tag into the DTAG structure used by D-ASSEM.") (DEFVAR *DVAR-ENV* NIL "A hash-table mapping the EQL-unique ID of a LAP variable into the DVAR structure used by D-ASSEM.") (DEFVAR *STACK-ENV* NIL (IL:* IL:|;;;| "Hash-table mapping stack-level identifiers to a pair (depth . binding-depths).") ) (DEFVAR *HUNK-MAP* NIL "An AList mapping lexical level numbers into the PVAR number of a slot in the current frame holding the hunk for that level." ) (DEFVAR *DCODE* 0 "The currently-under-construction DCODE structure.") (DEFVAR *LEVEL* 0 "The current lexical nesting level.") (DEFUN ASSEMBLE-FUNCTION (LAP-FN) (IL:* IL:|;;;| "LAP-FN is a LAP-format function description (a LAMBDA). Return the DCODE structure that results from assembling it into D-machine bytecodes. The code is copied so as to avoid problems with shared structure when we diddle with it.") (LET ((*DVAR-ENV* (MAKE-HASH-TABLE :TEST 'EQL)) (*DTAG-ENV* (MAKE-HASH-TABLE :TEST 'EQL)) (*STACK-ENV* (MAKE-HASH-TABLE :TEST 'EQL)) (*LOCAL-FN-FIXUPS* NIL)) (UNWIND-PROTECT (LET ((DCODE (DCODE-FROM-DLAMBDA (DLAMBDA-FROM-LAMBDA (COPY-LAP-FN LAP-FN)) 0))) (SETF (DCODE-CLOSURE-P DCODE) :FUNCTION) (IL:* IL:\;  "The top-level guy is always a :FUNCTION.") DCODE) (IL:* IL:|;;| "Break all of the circularities created during this assembly.") (MAPHASH #'(LAMBDA (ID TAG) (DECLARE (IGNORE ID)) (SETF (DTAG-PTR TAG) NIL)) *DTAG-ENV*)))) (DEFUN DLAMBDA-FROM-LAMBDA (LAP-FN) "Break out the fields of a LAP lambda and return them in the form of a DLAMBDA structure." (DESTRUCTURING-BIND ((REQUIRED &KEY OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP CLOSED-OVER NON-LOCAL LOCAL-FUNCTIONS) &REST BODY) (CDR LAP-FN) (MAKE-DLAMBDA REQUIRED OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP CLOSED-OVER (MAPCAR #'LAP-VAR-ID NON-LOCAL) (IL:* IL:\; "non-local") BODY (MAPCAR #'(LAMBDA (PAIR) (CONS (FIRST PAIR) (DLAMBDA-FROM-LAMBDA (SECOND PAIR)))) LOCAL-FUNCTIONS) (IL:* IL:\; "local-functions") ))) (DEFUN DCODE-FROM-DLAMBDA (DLAMBDA LEVEL) (IL:* IL:|;;;| "LEVEL is the length of the chain of hunks that will be passed to the result of assembling DLAMBDA at runtime.") (LET ((*DCODE* (MAKE-DCODE :FRAME-NAME (DLAMBDA-NAME DLAMBDA) :CLOSURE-P :CLOSURE) (IL:* IL:\; "By default, no DCODE gets wrapped up into a closure object. The values for this field are somewhat misleading.") ) (*HUNK-MAP* (AND (> LEVEL 0) `((,LEVEL . 0)))) (*HUNK-SIZE* (IF (> LEVEL 0) 1 0)) (*BYTES* (START-BYTES)) (*BYTE-COUNT* 0) (*JUMP-LIST* NIL) (*PVAR-COUNT* (IF (> LEVEL 0) 1 0)) (*LEVEL* LEVEL) (EASY-ENTRY (EASY-ENTRY-P DLAMBDA))) (IL:* IL:|;;| "Pass 0: Intern all of the variables and tags") (DIGEST-FUNCTION DLAMBDA EASY-ENTRY) (LET ((FIXUP-DESC (FIND DLAMBDA *LOCAL-FN-FIXUPS* :TEST 'EQ :KEY 'CADR))) (WHEN FIXUP-DESC (SETF (CADR FIXUP-DESC) *DCODE*))) (IL:* IL:|;;| "Pass 1: Translate LAP code into opcodes and bytes.") (IF EASY-ENTRY (GENERATE-EASY-ENTRY DLAMBDA) (GENERATE-HARD-ENTRY DLAMBDA)) (STACK-ANALYZE (DLAMBDA-BODY DLAMBDA)) (ASSEMBLE (DLAMBDA-BODY DLAMBDA)) (EMIT-BYTE 'IL:-X-) (SETQ *BYTES* (END-BYTES)) (IL:* IL:|;;| "Pass 1-1/2: Resolve the uncertainty in jump sizes and distances.") (UNLESS (NULL *JUMP-LIST*) (RESOLVE-JUMPS (REVERSE *JUMP-LIST*))) (IL:* IL:|;;| "Pass 2: Convert the byte-list into its final binary form and create the fixup lists. This pass also performs the recursion necessary to compile nested lambdas.") (CONVERT-TO-BINARY *BYTES*) (IL:* IL:|;;| "Fill in the last few bits of the DCODE and quit.") (COMPUTE-DEBUGGING-INFO DLAMBDA) *DCODE*)) (IL:* IL:|;;| "Digesting the function") (DEFVAR *HUNK-SIZE* 0 "The number of hunk slots allocated so far.") (DEFVAR *PVAR-COUNT* 0 "The number of PVAR allocated so far.") (DEFVAR *FREE-VARS* NIL "An AList mapping DVARs for the free variables in a function into the number of times they're referenced in the function." ) (DEFVAR *BOUND-SPECIALS* NIL "A list of the special variables bound in this frame.") (DEFCONSTANT +MAX-ALLOWABLE-PVAR-COUNT+ 128 (IL:* IL:|;;;| "On the D-machine, there is a hard limit to the number of bound variables we can allow. This is that limit.") ) (DEFCONSTANT +MAX-ALLOWABLE-SPECIAL-COUNT+ 119 (IL:* IL:|;;;| "Because of page-boundary constraints, there is a limit to how many entries there can be in the name table of a frame. This is that limit. Note that it refers both to bound and free specials.") ) (DEFCONSTANT +SLOW-FVAR-SLOT+ -1 (IL:* IL:|;;;| "This is the slot number for free variables that have to be accessed the slow way, using SYMBOL-VALUE and SET.") ) (DEFUN DIGEST-FUNCTION (DLAMBDA EASY-ENTRY) (LET ((CLOSED-OVER (DLAMBDA-CLOSED-OVER DLAMBDA)) (IVAR-COUNT 0) (*FREE-VARS* NIL) (*BOUND-SPECIALS* NIL)) (IL:* IL:|;;|  "Allocate slots for the top-level hunk and the blip slot variable, if they're needed.") (WHEN (NOT (NULL (DLAMBDA-BLIP DLAMBDA))) (IL:* IL:\;  "This can lead to a wasted PVAR0, but I'm not losing sleep over it.") (INSTALL-VAR (DLAMBDA-BLIP DLAMBDA) NIL :LOCAL 1) (SETQ *PVAR-COUNT* 2)) (WHEN (NOT (NULL CLOSED-OVER)) (INCF *LEVEL*) (IL:* IL:\;  "The lexical level just changed.") (PUSH (CONS *LEVEL* *PVAR-COUNT*) *HUNK-MAP*) (INCF *PVAR-COUNT*)) (IL:* IL:|;;| "Intern the local functions") (IL:|for| FN-PAIR IL:|in| (DLAMBDA-LOCAL-FUNCTIONS DLAMBDA) IL:|do| (LET ((DVAR (INSTALL-VAR (CAR FN-PAIR) CLOSED-OVER :FUNCTION NIL))) (PUSH (LIST DVAR (CDR FN-PAIR) *DCODE*) *LOCAL-FN-FIXUPS*) (SETF (CAR FN-PAIR) DVAR))) (IL:* IL:|;;| "Intern the required parameters.") (IL:|for| TAIL IL:|on| (DLAMBDA-REQUIRED DLAMBDA) IL:|do| (SETF (CAR TAIL) (INSTALL-VAR (CAR TAIL) CLOSED-OVER :ARGUMENT IVAR-COUNT)) (INCF IVAR-COUNT)) (IL:* IL:|;;| "And then the optional parameters and their supplied-p colleagues.") (IL:|for| OPT-VAR IL:|in| (DLAMBDA-OPTIONAL DLAMBDA) IL:|do| (COND (EASY-ENTRY (SETF (FIRST OPT-VAR) (INSTALL-VAR (FIRST OPT-VAR) CLOSED-OVER :ARGUMENT IVAR-COUNT)) (INCF IVAR-COUNT)) (T (SETF (FIRST OPT-VAR) (INSTALL-LOCAL (FIRST OPT-VAR) CLOSED-OVER)) (DIGEST-CODE (SECOND OPT-VAR)) (SETF (THIRD OPT-VAR) (INSTALL-LOCAL (THIRD OPT-VAR) CLOSED-OVER))))) (IL:* IL:|;;| "Next comes the rest and keyword parameters.") (WHEN (NOT EASY-ENTRY) (WHEN (AND (NOT (NULL (DLAMBDA-REST DLAMBDA))) (NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA)))) (SETF (DLAMBDA-REST DLAMBDA) (INSTALL-LOCAL (DLAMBDA-REST DLAMBDA) CLOSED-OVER))) (IL:|for| KEY-VAR IL:|in| (DLAMBDA-KEY DLAMBDA) IL:|do| (SETF (SECOND KEY-VAR) (INSTALL-LOCAL (SECOND KEY-VAR) CLOSED-OVER)) (DIGEST-CODE (THIRD KEY-VAR)) (SETF (FOURTH KEY-VAR) (INSTALL-LOCAL (FOURTH KEY-VAR) CLOSED-OVER)))) (IL:* IL:|;;| "Then intern any stragglers on the closed-over list.") (IL:|for| VAR IL:|in| CLOSED-OVER IL:|do| (WHEN (AND (CONSP VAR) (NULL (GETHASH (THIRD VAR) *DVAR-ENV*))) (SETF (GETHASH (THIRD VAR) *DVAR-ENV*) (MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE* :LEVEL *LEVEL* :NAME (SECOND VAR))) (INCF *HUNK-SIZE*))) (IL:* IL:|;;| "And, at long last, digest the body of the function.") (DIGEST-CODE (DLAMBDA-BODY DLAMBDA)) (IL:* IL:|;;| "Now that we have lexical levels for all of the variables in this lambda, we can figure out the proper lexical levels for all of its subfunctions.") (IL:|for| FN-PAIR IL:|in| (DLAMBDA-LOCAL-FUNCTIONS DLAMBDA) IL:|do| (SETF (DVAR-LEVEL (CAR FN-PAIR)) (DETERMINE-LOCAL-FN-LEXICAL-LEVEL (CAR FN-PAIR) NIL))) (IL:* IL:|;;| "Record the results of this digestion (yecch...).") (STORE-DIGEST-INFO))) (DEFUN DETERMINE-LOCAL-FN-LEXICAL-LEVEL (FN PENDING) (IL:* IL:|;;| "Determines the minimum lexical level of the given local functions. The level is the maximum of the levels of its non-local variable references and the levels of any functions that it references. PENDING is a list of function variables for which the level ie currently being determined. If you reference any of these, ignore them for now.") (ASSERT (EQ (DVAR-KIND FN) :FUNCTION) '(FN) "BUG: Trying to determine minimum level of a non-function.") (LET ((LEVEL 0) (DLAMBDA (SECOND (ASSOC FN *LOCAL-FN-FIXUPS*)))) (IL:FOR ID IL:IN (DLAMBDA-NON-LOCAL DLAMBDA) IL:DO (LET ((DVAR (GETHASH ID *DVAR-ENV*))) (MAXF LEVEL (OR (DVAR-LEVEL DVAR) (IF (OR (EQ DVAR FN) (MEMBER DVAR PENDING :TEST 'EQ)) 0) (IL:* IL:\; "ignore it.") (DETERMINE-LOCAL-FN-LEXICAL-LEVEL DVAR (CONS FN PENDING)))))) LEVEL)) (DEFUN DIGEST-CODE (LAP-CODE) (IL:FOR TAIL IL:ON LAP-CODE IL:DO (LET ((INST (CAR TAIL))) (CASE (FIRST INST) ((:VAR :VAR_) (SETF (SECOND INST) (INTERN-VAR (SECOND INST)))) ((:CALL) (WHEN (CONSP (SECOND INST)) (CASE (FIRST (SECOND INST)) ((:LAMBDA) (DIGEST-CODE (LIST (SECOND INST)))) ((:L :F :S :FN) (SETF (SECOND INST) (INTERN-VAR (SECOND INST))))))) ((:LAMBDA) (LET ((DLAMBDA (DLAMBDA-FROM-LAMBDA INST)) (LEVEL 0)) (IL:|for| ID IL:|in| (DLAMBDA-NON-LOCAL DLAMBDA) IL:|do| (LET ((DVAR (GETHASH ID *DVAR-ENV*))) (MAXF LEVEL (OR (DVAR-LEVEL DVAR) (  DETERMINE-LOCAL-FN-LEXICAL-LEVEL DVAR NIL))))) (SETF (CDR INST) (LIST DLAMBDA LEVEL)))) ((:BIND) (IL:* IL:|;;| "(if (and (consp var) (null (gethash (third var) *dvar-env*))) (install-local var nil) (error \"Variable in :BIND appeared earlier: ~S\" var))") (FLET ((INSTALL-NEW (VAR) (IF (AND (CONSP VAR) (NULL (GETHASH (THIRD VAR) *DVAR-ENV*))) (INSTALL-LOCAL VAR NIL) (GETHASH (THIRD VAR) *DVAR-ENV*)))) (SETF (SECOND INST) (MAPCAR #'INSTALL-NEW (SECOND INST))) (SETF (THIRD INST) (MAPCAR #'INSTALL-NEW (THIRD INST))))) ((:UNBIND :DUNBIND) (SETF (SECOND INST) (LENGTH (SECOND INST)) (THIRD INST) (LENGTH (THIRD INST)))) ((:TAG) (SETF (SECOND INST) (INTERN-TAG (SECOND INST))) (SETF (DTAG-PTR (SECOND INST)) TAIL) (SETF (DTAG-LEVEL (SECOND INST)) *LEVEL*)) ((:JUMP :FJUMP :TJUMP :NFJUMP :NTJUMP :PUSH-TAG) (SETF (SECOND INST) (INTERN-TAG (SECOND INST)))) ((:CLOSE) (LET ((*LEVEL* (1+ *LEVEL*)) (*HUNK-SIZE* (IF (> *LEVEL* 0) 1 0))) (IL:* IL:|;;| "In setting up the new lexical environment, don't forget to leave a slot for linking the hunks together, if necessary.") (LET ((DVARS (WITH-COLLECTION (DOLIST (VAR (SECOND INST)) (COLLECT (SETF (GETHASH (THIRD VAR) *DVAR-ENV*) (MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE* :LEVEL *LEVEL* :NAME (SECOND VAR)))) (INCF *HUNK-SIZE*))))) (SETF (REST INST) (LIST* DVARS *PVAR-COUNT* (CDDR INST)))) (INCF *PVAR-COUNT*) (IL:* IL:\;  "Allocate a slot for the new hunk.") (DIGEST-CODE (CDDDR INST)))))))) (DEFUN STORE-DIGEST-INFO () (LET* ((FREE-VAR-ALIST (SORT *FREE-VARS* #'< :KEY #'CDR)) (FREE-VAR-COUNT (LIST-LENGTH FREE-VAR-ALIST)) (BOUND-SPECIAL-COUNT (LIST-LENGTH *BOUND-SPECIALS*))) (IL:* IL:|;;| "First we check for there being too many variables. If we can get it down below the limit by eliminating FVAR's, we'll do that. The technique is to replace references with calls to SYMBOL-VALUE and SETQs by calls to SET. This is gross, but there's no easier way out. If there would still be too many after eliminating all of the FVARs, we have to punt.") (WHEN (> *PVAR-COUNT* +MAX-ALLOWABLE-PVAR-COUNT+) (COMPILER:ASSEMBLER-ERROR "Too many bound variables: ~D. Limit is ~D." *PVAR-COUNT* +MAX-ALLOWABLE-PVAR-COUNT+)) (WHEN (> BOUND-SPECIAL-COUNT +MAX-ALLOWABLE-SPECIAL-COUNT+) (COMPILER:ASSEMBLER-ERROR "Too many bound special variables: ~D. Limit is ~D." BOUND-SPECIAL-COUNT +MAX-ALLOWABLE-SPECIAL-COUNT+)) (DOTIMES (I (MAX (- (+ BOUND-SPECIAL-COUNT FREE-VAR-COUNT) +MAX-ALLOWABLE-SPECIAL-COUNT+) (- (+ *PVAR-COUNT* FREE-VAR-COUNT) +MAX-ALLOWABLE-PVAR-COUNT+) 0)) (SETF (DVAR-SLOT (CAR (POP FREE-VAR-ALIST))) +SLOW-FVAR-SLOT+) (DECF FREE-VAR-COUNT)) (IL:* IL:|;;| "This first part gets the entries on the name-table in the right order by building the table backwards. The final order is PVARs, IVARs, FVARs with the PVARs and IVARs in reverse order. This lets the free variable lookup find the correct variable first.") (IL:FOR PAIR IL:IN FREE-VAR-ALIST IL:AS SLOT IL:FROM (1- (+ FREE-VAR-COUNT *PVAR-COUNT*)) IL:BY -1 IL:DO (PUSH (LIST +FVAR-CODE+ SLOT (DVAR-NAME (CAR PAIR))) (DCODE-NAME-TABLE *DCODE*)) (SETF (DVAR-SLOT (CAR PAIR)) SLOT) (IL:* IL:\;  "While we're at this, assign slots to the free variables.") ) (IL:|for| DVAR IL:|in| (NREVERSE *BOUND-SPECIALS*) IL:|do| (PUSH (LIST (ECASE (DVAR-KIND DVAR) ((:LOCAL) +PVAR-CODE+) ((:ARGUMENT) +IVAR-CODE+)) (DVAR-SLOT DVAR) (DVAR-NAME DVAR)) (DCODE-NAME-TABLE *DCODE*))) (IL:* IL:|;;| "Now to fill in some of the more mundane fields of the DCODE.") (SETF (DCODE-NLOCALS *DCODE*) *PVAR-COUNT*) (SETF (DCODE-NFREEVARS *DCODE*) FREE-VAR-COUNT))) (DEFUN DVAR-FROM-LAP-VAR (LAP-VAR) (OR (GETHASH (LAP-VAR-ID LAP-VAR) *DVAR-ENV*) (ERROR "The LAP var ~S should have been interned by now." LAP-VAR))) (DEFINLINE LAP-VAR-ID (VAR) (IF (CONSP VAR) (THIRD VAR) VAR)) (DEFUN INSTALL-LOCAL (VAR CLOSED-OVER) (AND VAR (LET ((DVAR (INSTALL-VAR VAR CLOSED-OVER :LOCAL *PVAR-COUNT*))) (WHEN (EQ :LOCAL (DVAR-KIND DVAR)) (INCF *PVAR-COUNT*)) DVAR))) (DEFUN INSTALL-VAR (VAR CLOSED-OVER KIND SLOT) (AND VAR (DESTRUCTURING-BIND (SCOPE NAME ID) VAR (COND ((MEMBER ID CLOSED-OVER :KEY #'LAP-VAR-ID) (PROG1 (SETF (GETHASH ID *DVAR-ENV*) (MAKE-DVAR :KIND :CLOSED :SLOT *HUNK-SIZE* :LEVEL *LEVEL* :NAME NAME)) (INCF *HUNK-SIZE*))) (T (LET ((DVAR (SETF (GETHASH ID *DVAR-ENV*) (MAKE-DVAR :KIND (IF (EQ SCOPE ':F) :FREE KIND) :SLOT SLOT :NAME NAME)))) (CASE SCOPE ((:S) (PUSH DVAR *BOUND-SPECIALS*)) ((:F) (PUSH (CONS DVAR 1) *FREE-VARS*))) DVAR)))))) (DEFUN INTERN-VAR (VAR) (IF (CONSP VAR) (IF (EQ (FIRST VAR) ':G) (IL:* IL:\;  "Global vars don't get interned.") VAR (LET ((DVAR (GETHASH (THIRD VAR) *DVAR-ENV*))) (COND ((NOT (NULL DVAR)) (WHEN (EQ :FREE (DVAR-KIND DVAR)) (INCF (CDR (ASSOC DVAR *FREE-VARS*)))) DVAR) (T (INSTALL-LOCAL VAR NIL))))) (OR (GETHASH VAR *DVAR-ENV*) (ERROR "Unknown LAP variable ID: ~S" VAR)))) (DEFUN INTERN-TAG (ID) (OR (GETHASH ID *DTAG-ENV*) (SETF (GETHASH ID *DTAG-ENV*) (MAKE-DTAG)))) (IL:* IL:|;;| "Function entry code") (DEFUN EASY-ENTRY-P (DLAMBDA) (AND (OR (NULL (DLAMBDA-REST DLAMBDA)) (EQ :IGNORED (DLAMBDA-REST DLAMBDA))) (NULL (DLAMBDA-KEY DLAMBDA)) (IL:|for| OPT-VAR IL:|in| (DLAMBDA-OPTIONAL DLAMBDA) IL:|always| (AND (EQUAL '((:CONST NIL)) (SECOND OPT-VAR)) (NULL (THIRD OPT-VAR)))))) (DEFUN GENERATE-EASY-ENTRY (DLAMBDA) (IL:* IL:|;;| "Emit code to create the hunk for this level and leave it on top of stack. We'll use it in the processing of the arguments.") (WHEN (NOT (NULL (DLAMBDA-CLOSED-OVER DLAMBDA))) (CREATE-HUNK *HUNK-SIZE* (CDAR *HUNK-MAP*) (AND (> *LEVEL* 1) 0) NIL)) (IL:* IL:|;;| "The required and optional parameters are treated alike in the easy entry. If any of them are closed over, copy them into the hunk.") (IL:|for| DVAR IL:|in| (APPEND (DLAMBDA-REQUIRED DLAMBDA) (MAPCAR #'FIRST (DLAMBDA-OPTIONAL DLAMBDA))) IL:|as| IVAR-COUNT IL:|from| 0 IL:|do| (WHEN (EQ :CLOSED (DVAR-KIND DVAR)) (EMIT-BYTE-LIST `(,@(CHOOSE-OP '(IL:IVAR . IL:IVARX) IVAR-COUNT) IL:RPLPTR.N ,(IL:LLSH (DVAR-SLOT DVAR) 1))))) (WHEN (NOT (NULL (DLAMBDA-CLOSED-OVER DLAMBDA))) (IL:* IL:\;  "Get rid of the hunk on the top of stack.") (EMIT-BYTE 'IL:POP)) (IL:* IL:|;;| "Set up the ARG-TYPE and NUM-ARGS information. All Interlisp functions pass thru the easy-entry code, so this will catch them.") (LET ((ARG-TYPE (OR (DLAMBDA-ARG-TYPE DLAMBDA) +LAMBDA-SPREAD+))) (SETF (DCODE-ARG-TYPE *DCODE*) ARG-TYPE) (SETF (DCODE-NUM-ARGS *DCODE*) (COND ((OR (= ARG-TYPE +LAMBDA-SPREAD+) (= ARG-TYPE +NLAMBDA-SPREAD+)) (+ (LENGTH (DLAMBDA-REQUIRED DLAMBDA)) (LENGTH (DLAMBDA-OPTIONAL DLAMBDA)))) ((= ARG-TYPE +LAMBDA-NO-SPREAD+) -1) ((= ARG-TYPE +NLAMBDA-NO-SPREAD+) 1))))) (DEFUN GENERATE-HARD-ENTRY (DLAMBDA) (LET ((NUM-REQUIRED (LENGTH (DLAMBDA-REQUIRED DLAMBDA))) (NUM-OPTIONAL (LENGTH (DLAMBDA-OPTIONAL DLAMBDA)))) (IL:* IL:|;;| "Emit code to create the hunk for this level and store it away.") (WHEN (NOT (NULL (DLAMBDA-CLOSED-OVER DLAMBDA))) (CREATE-HUNK *HUNK-SIZE* (CDAR *HUNK-MAP*) (AND (> *LEVEL* 1) 0) T)) (IL:* IL:|;;|  "Generate a check for a bad number of arguments, unless there are no illegal values.") (UNLESS (AND (ZEROP NUM-REQUIRED) (OR (AND (DLAMBDA-REST DLAMBDA) (NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA)))) (DLAMBDA-KEY DLAMBDA))) (GENERATE-ARG-CHECK DLAMBDA)) (IL:* IL:|;;| "Copy the closed required args to the hunk.") (IL:|for| DVAR IL:|in| (DLAMBDA-REQUIRED DLAMBDA) IL:|as| IVAR-COUNT IL:|from| 0 IL:|do| (WHEN (EQ :CLOSED (DVAR-KIND DVAR)) (EMIT-BYTE-LIST `(,@(CHOOSE-OP '(IL:PVAR . IL:PVARX) (CDAR *HUNK-MAP*)) ,@(CHOOSE-OP '(IL:IVAR . IL:IVARX) IVAR-COUNT) IL:RPLPTR.N ,(IL:LLSH (DVAR-SLOT DVAR) 1) IL:POP)))) (IL:* IL:|;;| "Generate code for the optional and rest arguments.") (GENERATE-OPT-AND-REST DLAMBDA NUM-REQUIRED NUM-OPTIONAL) (IL:* IL:|;;| "Generate code for the keyword arguments.") (GENERATE-KEY DLAMBDA NUM-REQUIRED NUM-OPTIONAL) (IL:* IL:|;;| "Fill in some information in the DCODE structure.") (SETF (DCODE-ARG-TYPE *DCODE*) +LAMBDA-NO-SPREAD+) (SETF (DCODE-NUM-ARGS *DCODE*) -1))) (DEFUN GENERATE-ARG-CHECK (DLAMBDA) (IL:* IL:|;;;| "Generate code that signals an error if too few or too many arguments are given.") (LET* ((MIN-ARGS (LENGTH (DLAMBDA-REQUIRED DLAMBDA))) (MAX-ARGS (AND (NULL (DLAMBDA-REST DLAMBDA)) (NULL (DLAMBDA-KEY DLAMBDA)) (NULL (DLAMBDA-ALLOW-OTHER-KEYS DLAMBDA)) (+ MIN-ARGS (LENGTH (DLAMBDA-OPTIONAL DLAMBDA))))) (OK-TAG (MAKE-DTAG)) (BAD-TAG (MAKE-DTAG))) (IF (NULL MAX-ARGS) (EMIT-BYTE-LIST `(IL:MYARGCOUNT ,@(PUSH-INTEGER (1- MIN-ARGS)) IL:GREATERP (:TJUMP ,OK-TAG) ,@(PUSH-INTEGER MIN-ARGS) IL:\'NIL IL:FN2 (:FN SI::ARGUMENT-ERROR) IL:POP (:TAG ,OK-TAG))) (EMIT-BYTE-LIST `(IL:MYARGCOUNT ,@(PUSH-INTEGER (1- MIN-ARGS)) IL:GREATERP (:FJUMP ,BAD-TAG) IL:MYARGCOUNT ,@(PUSH-INTEGER MAX-ARGS) IL:GREATERP (:FJUMP ,OK-TAG) (:TAG ,BAD-TAG) ,@(PUSH-INTEGER MIN-ARGS) ,@(PUSH-INTEGER MAX-ARGS) IL:FN2 (:FN SI::ARGUMENT-ERROR) IL:POP (:TAG ,OK-TAG)))))) (DEFUN GENERATE-KEY (DLAMBDA NUM-REQUIRED NUM-OPTIONAL) "Generate code to check for and default the keyword arguments." (LET ((START (+ 1 NUM-REQUIRED NUM-OPTIONAL))) (IL:FOR TAIL IL:ON (DLAMBDA-KEY DLAMBDA) IL:DO (DESTRUCTURING-BIND (KEYWORD VAR CODE SVAR) (CAR TAIL) (LET ((FOUND-TAG (MAKE-DTAG)) (NEXT-TAG (MAKE-DTAG))) (EMIT-BYTE-LIST `(IL:ACONST (:SYM ,KEYWORD) IL:FINDKEY ,START (:NTJUMP ,FOUND-TAG))) (IL:* IL:|;;| "Not there; compute the init-form.") (STACK-ANALYZE CODE 1) (ASSEMBLE CODE) (EMIT-BYTE-LIST `(,@(STORE-VAR VAR T) ,@(AND SVAR `(IL:\'NIL ,@(STORE-VAR SVAR T))) (:JUMP ,NEXT-TAG) (:TAG ,FOUND-TAG) IL:ARG0 ,@(STORE-VAR VAR T) ,@(AND SVAR `(IL:\'T ,@(STORE-VAR SVAR T))) (:TAG ,NEXT-TAG)))))))) (DEFUN GENERATE-OPT-AND-REST (DLAMBDA NUM-REQUIRED NUM-OPTIONAL) (LET ((OPT-INIT-VALUES NIL) (AFTER-OPTS-TAG (MAKE-DTAG))) (IL:* IL:|;;| "OPT-INIT-VALUES will hold a list of lists (var svar tag . lap-code), one for each opt-var. These will be generated in order after we take care of the rest argument.") (UNLESS (ZEROP NUM-OPTIONAL) (IL:* IL:|;;| "Convert the arg-count into a count of remaining arguments.") (EMIT-BYTE-LIST `(IL:MYARGCOUNT ,@(AND (NOT (ZEROP NUM-REQUIRED)) `(,@(PUSH-INTEGER NUM-REQUIRED) IL:IDIFFERENCE)))) (IL:* IL:|;;| "Generate the code for testing for each optional variable. If it's there, copy it to its slot and set the svar, if one exists. Otherwise, jump into the middle of the stream of init-form computations.") (IL:|for| TAIL IL:|on| (DLAMBDA-OPTIONAL DLAMBDA) IL:|as| IVAR-COUNT IL:|from| (1+ NUM-REQUIRED) IL:|do| (LET ((TAG (MAKE-DTAG))) (DESTRUCTURING-BIND (VAR CODE SVAR) (CAR TAIL) (EMIT-BYTE-LIST `(,@(AND (CDR TAIL) '(IL:COPY)) IL:\'0 EQ (:TJUMP ,TAG) ,@(PUSH-INTEGER IVAR-COUNT) IL:ARG0 ,@(STORE-VAR VAR T) ,@(AND SVAR `(IL:\'T ,@(STORE-VAR SVAR T))) ,@(AND (CDR TAIL) '(IL:\'1 IL:IDIFFERENCE)))) (PUSH (LIST* VAR SVAR TAG CODE) OPT-INIT-VALUES))))) (IL:* IL:|;;| "All of the &optionals were provided. Handle the &rest argument.") (WHEN (AND (DLAMBDA-REST DLAMBDA) (NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA)))) (EMIT-BYTE-LIST `(IL:\'NIL IL:MYARGCOUNT IL:RESTLIST ,(+ 1 NUM-REQUIRED NUM-OPTIONAL) ,@(STORE-VAR (DLAMBDA-REST DLAMBDA) T)))) (IL:* IL:|;;| "Compute the default values for the various optional parameters one after another. The testing code above jumps into the middle of this.") (UNLESS (ZEROP NUM-OPTIONAL) (EMIT-BYTE `(:JUMP ,AFTER-OPTS-TAG)) (IL:* IL:\; "If we fall into this code, all of the optionals were provided, so jump around the default-value calculations.") (IL:FOR VARS-TAG-CODE IL:IN (NREVERSE OPT-INIT-VALUES) IL:DO (EMIT-BYTE `(:TAG ,(CADDR VARS-TAG-CODE))) (STACK-ANALYZE (CDDDR VARS-TAG-CODE) 1) (ASSEMBLE (CDDDR VARS-TAG-CODE)) (EMIT-BYTE-LIST (STORE-VAR (CAR VARS-TAG-CODE) T)) (WHEN (CADR VARS-TAG-CODE) (IL:* IL:\; "There's an svar") (EMIT-BYTE-LIST `(IL:\'NIL ,@(STORE-VAR (CADR VARS-TAG-CODE) T))))) (WHEN (AND (DLAMBDA-REST DLAMBDA) (NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA)))) (IL:* IL:\;  "If not all of the optionals were there, then there can't be any &rest arguments.") (EMIT-BYTE-LIST `(IL:\'NIL ,@(STORE-VAR (DLAMBDA-REST DLAMBDA) T)))) (EMIT-BYTE `(:TAG ,AFTER-OPTS-TAG))))) (IL:* IL:|;;| "Stack analysis") (DEFVAR *ENDING-DEPTH* NIL "An AList mapping lexical level to the stack depth at exit from that level.") (DEFUN GATHER-TAGS (CODE) (LET ((TAGS-FOUND NIL)) (DOLIST (INST CODE) (CASE (FIRST INST) ((:TAG) (PUSH (SECOND INST) TAGS-FOUND)) ((:CLOSE) (SETQ TAGS-FOUND (NCONC (GATHER-TAGS (CDDDR INST)) TAGS-FOUND))))) TAGS-FOUND)) (DEFUN GATHER-ROOTS (CODE) (IL:* IL:|;;;| "Return the minimum set of tags in CODE such that starting stack analysis at the beginning of CODE and at each of these tags will result in all of CODE being reached.") (IL:* IL:|;;;| "We work by using the same algorithm for reaching code as in STACK-ANALYZE, marking each reachable tag. We start the search first at the beginning of CODE and then at each so-far unmarked tag.") (LET ((TAG-LIST (GATHER-TAGS CODE))) (REACH-TAGS CODE) (DOLIST (TAG TAG-LIST) (WHEN (NOT (DTAG-REACHABLE? TAG)) (REACH-TAGS (CDR (DTAG-PTR TAG))))) (REMOVE-IF 'DTAG-REACHABLE? TAG-LIST))) (DEFUN REACH-TAGS (CODE) (IL:* IL:|;;;| "Mark all reachable tags as being so.") (DOLIST (INST CODE) (ECASE (CAR INST) ((:TAG) (COND ((DTAG-REACHABLE? (SECOND INST)) (RETURN)) (T (SETF (DTAG-REACHABLE? (SECOND INST)) T)))) ((:FJUMP :NFJUMP :TJUMP :NTJUMP) (REACH-TAGS (DTAG-PTR (SECOND INST)))) ((:JUMP) (REACH-TAGS (DTAG-PTR (SECOND INST))) (RETURN)) ((:RETURN) (RETURN)) ((:CLOSE) (REACH-TAGS (CDDDR INST))) ((:VAR :VAR_ :CONST :POP :LAMBDA :COPY :PUSH-TAG :NOTE-STACK :SET-STACK :DSET-STACK :SWAP :BIND :UNBIND :DUNBIND :CALL :STKCALL) NIL)))) (DEFUN STACK-ANALYZE (CODE &OPTIONAL (EXPECTED-ENDING-DEPTH 0)) (IL:* IL:|;;;| "Walk the given code annotating the tags in it with information about the stack and binding depth of control at that point.") (LET ((*LEVEL* *LEVEL*) (*ENDING-DEPTH* (LIST (CONS *LEVEL* NIL))) (ROOT-LIST (GATHER-ROOTS CODE))) (STACK-ANALYZE-CODE CODE 0 NIL) (DOLIST (TAG ROOT-LIST) (IL:* IL:|;;| "JDS 18-NOV-91 Added *Edning-DEPTH* binding here, because not all tags will be at level 1! Fixes AR 11428.") (WHEN (NULL (DTAG-STACK-DEPTH TAG)) (LET* ((*LEVEL* (DTAG-LEVEL TAG)) (*ENDING-DEPTH* (LIST (CONS *LEVEL* NIL)))) (STACK-ANALYZE-CODE (DTAG-PTR TAG) NIL NIL)))) (LET ((ENDING-DEPTH (CDR (FIRST *ENDING-DEPTH*)))) (ASSERT (OR (NULL ENDING-DEPTH) (= ENDING-DEPTH EXPECTED-ENDING-DEPTH)) NIL "Code doesn't leave stack empty!")))) (DEFUN STACK-ANALYZE-CODE (CODE INIT-DEPTH INIT-BINDING-DEPTH) (IL:* IL:|;;;| "Annotate the tags in CODE with the stack and binding depth at those points in execution, assuming that the stack depth is INIT-DEPTH and the binding depth is as in INIT-BINDING-DEPTH on entry to the code..") (FLET ((STACK-AMBIGUOUS-ERROR (OPCODE) (ERROR "BUG: The LAP opcode ~S should not appear in stack-ambiguous territory." OPCODE))) (MACROLET ((CHECK-STACK NIL `(WHEN (NULL DEPTH) (STACK-AMBIGUOUS-ERROR (FIRST INST))))) (LET ((DEPTH INIT-DEPTH) (BINDING-DEPTH INIT-BINDING-DEPTH)) (DOLIST (INST CODE) (ECASE (CAR INST) ((:TAG) (LET ((THE-TAG (SECOND INST))) (COND ((NULL (DTAG-STACK-DEPTH THE-TAG)) (SETF (DTAG-STACK-DEPTH THE-TAG) (CONS BINDING-DEPTH DEPTH)) (ASSERT (>= *LEVEL* (DTAG-LEVEL THE-TAG)) NIL "COMPILER BUG: Jump INTO a lexical contour." )) (T (ASSERT (AND (EQUAL BINDING-DEPTH (CAR ( DTAG-STACK-DEPTH THE-TAG))) (EQUAL DEPTH (CDR (DTAG-STACK-DEPTH THE-TAG)))) NIL "BUG: Inconsistent stack depths seen at the target of several branches." ) (RETURN-FROM STACK-ANALYZE-CODE))))) ((:JUMP) (RETURN-FROM STACK-ANALYZE-CODE (STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST)) DEPTH BINDING-DEPTH))) ((:FJUMP :TJUMP) (CHECK-STACK) (DECF DEPTH) (STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST)) DEPTH BINDING-DEPTH)) ((:NFJUMP :NTJUMP) (CHECK-STACK) (STACK-ANALYZE-CODE (DTAG-PTR (SECOND INST)) DEPTH BINDING-DEPTH) (DECF DEPTH)) ((:VAR :COPY :CONST :LAMBDA :PUSH-TAG) (CHECK-STACK) (INCF DEPTH)) ((:VAR_ :SWAP) (CHECK-STACK) (IL:* IL:\;  "Net stack effect is zero.") ) ((:POP) (CHECK-STACK) (DECF DEPTH)) ((:NOTE-STACK) (CHECK-STACK) (SETF (GETHASH (SECOND INST) *STACK-ENV*) (LIST DEPTH BINDING-DEPTH))) ((:SET-STACK :DSET-STACK) (LET ((LOOKUP (GETHASH (SECOND INST) *STACK-ENV*))) (ASSERT (NOT (NULL LOOKUP)) NIL ":NOTE-STACK not seen before :SET-STACK") (ASSERT (OR (NULL DEPTH)(IL:* IL:\;  "We don't know where we are, or") (AND (>= DEPTH (FIRST LOOKUP)) (OR (NULL (SECOND LOOKUP)) (TAILP (SECOND LOOKUP) BINDING-DEPTH))) (IL:* IL:\;  "We can, indeed, feasibly set the stack to the given place.") ) NIL "Attempt to :SET-STACK to unreachable state.") (DESTRUCTURING-SETQ (DEPTH BINDING-DEPTH) LOOKUP) (IF (EQ (FIRST INST) :SET-STACK) (INCF DEPTH)))) ((:BIND) (CHECK-STACK) (IL:* IL:|;;| "This takes into account the popping of some number of values into the variables and then the pushing of the binding mark(s).") (DECF DEPTH (LENGTH (SECOND INST))) (PUSH (CONS (FOURTH INST) DEPTH) BINDING-DEPTH) (INCF DEPTH (MAX 1 (FLOOR (+ (LENGTH (THIRD INST)) 14) 15)))) ((:UNBIND :DUNBIND) (CHECK-STACK) (UNLESS (EQL (FOURTH INST) (CAR (FIRST BINDING-DEPTH))) (ERROR "ASSEMBLER BUG: Mismatched :BIND and :UNBIND.")) (SETQ DEPTH (CDR (POP BINDING-DEPTH))) (WHEN (EQ ':UNBIND (FIRST INST)) (INCF DEPTH))) ((:CALL) (IF (NULL DEPTH) (UNLESS (EQ (SECOND INST) 'IL:\\MVLIST) (STACK-AMBIGUOUS-ERROR (FIRST INST))) (DECF DEPTH (1- (THIRD INST))))) ((:STKCALL) (CHECK-STACK) (DECF DEPTH (1+ (SECOND INST)))) ((:RETURN) (RETURN-FROM STACK-ANALYZE-CODE)) ((:CLOSE) (CHECK-STACK) (LET* ((*LEVEL* (1+ *LEVEL*)) (*ENDING-DEPTH* (CONS (CONS *LEVEL* NIL) *ENDING-DEPTH*))) (STACK-ANALYZE-CODE (CDDDR INST) DEPTH BINDING-DEPTH) (SETQ DEPTH (CDR (FIRST *ENDING-DEPTH*))) (WHEN (NULL DEPTH) (RETURN-FROM STACK-ANALYZE-CODE)))))) (LET ((LOOKUP (ASSOC *LEVEL* *ENDING-DEPTH*))) (IL:* IL:|;;| "If this assertion fails, it means that we've twice analyzed a piece of code -- and run off athe end of it without returning to the caller. Normally, this is used to compute the ending depth of a closed-over part of code.") (ASSERT (NOT (CDR LOOKUP)) NIL "Ran off end twice") (WHEN (NULL (CDR LOOKUP)) (SETF (CDR LOOKUP) DEPTH))))))) (IL:* IL:|;;| "The guts of assembly") (DEFUN ASSEMBLE (LAP-CODE) (IL:* IL:|;;;| "Translate LAP code into D-machine bytecodes.") (ASSEMBLE-CODE LAP-CODE 0 NIL)) (DEFUN ASSEMBLE-CODE (LAP-CODE DEPTH BINDING-DEPTH) (IL:* IL:|;;;| "Translate LAP code into D-machine bytecodes.") (DO ((TAIL LAP-CODE (CDR TAIL)) INST) ((ENDP TAIL)) (SETQ INST (FIRST TAIL)) (MACROLET ((INCR (VAR &OPTIONAL (DELTA 1)) `(AND ,VAR (SETQ ,VAR (+ ,VAR ,DELTA)))) (DECR (VAR &OPTIONAL (DELTA 1)) `(AND ,VAR (SETQ ,VAR (- ,VAR ,DELTA))))) (ECASE (CAR INST) ((:VAR) (EMIT-BYTE-LIST (REF-VAR (SECOND INST))) (INCR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :VAR)) ((:VAR_) (EMIT-BYTE-LIST (STORE-VAR (SECOND INST) (COND ((EQ ':POP (FIRST (SECOND TAIL))) (SETQ TAIL (CDR TAIL)) (DECR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :VAR_) T) (T NIL))))) ((:COPY) (EMIT-BYTE 'IL:COPY) (INCR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :COPY)) ((:SWAP) (EMIT-BYTE 'IL:SWAP)) ((:CONST) (LET* ((VALUE (SECOND INST)) (LOOKUP (ASSOC VALUE +CONSTANT-OPCODES+))) (COND ((NOT (NULL LOOKUP)) (EMIT-BYTE (CDR LOOKUP))) ((SYMBOLP VALUE) (EMIT-BYTE-LIST `(IL:ACONST (:SYM ,VALUE)))) ((INTEGERP VALUE) (EMIT-BYTE-LIST (PUSH-INTEGER VALUE))) (T (EMIT-BYTE-LIST `(IL:GCONST (:LIT ,VALUE)))))) (INCR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :CONST)) ((:LAMBDA) (LET ((DLAMBDA (SECOND INST)) (LAMBDA-LEVEL (THIRD INST))) (COND ((AND NIL (ZEROP LAMBDA-LEVEL)) (IL:* IL:\;  "We used to do something different for lambdas with empty environments.") (EMIT-BYTE-LIST `(IL:GCONST (:LAMBDA 0 ,DLAMBDA)))) (T (IL:* IL:|;;| "This will need to be a closure. Find our best hunk for it and construct a closure object around it and the lambda.") (EMIT-BYTE-LIST `(IL:SICX (:TYPE IL:COMPILED-CLOSURE) IL:CREATECELL IL:GCONST (:LAMBDA ,LAMBDA-LEVEL ,DLAMBDA) IL:RPLPTR.N 0 ,@(AND (NOT (ZEROP LAMBDA-LEVEL)) `(,@(FETCH-HUNK LAMBDA-LEVEL) IL:RPLPTR.N 2)))))) (INCR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :LAMBDA))) ((:POP) (EMIT-BYTE 'IL:POP) (DECR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :POP)) ((:NOTE-STACK) (IL:* IL:\;  "Now a no-op; used during stack analysis.") ) ((:SET-STACK :DSET-STACK) (FLET ((EMIT-UNWIND (DESIRED-DEPTH SAVE-TOS?) (EMIT-BYTE-LIST `(IL:UNWIND (:UNWIND ,DESIRED-DEPTH) ,(IF SAVE-TOS? 1 0))))) (LET* ((SAVE-TOS? (EQ (FIRST INST) :SET-STACK)) (LOOKUP (GETHASH (SECOND INST) *STACK-ENV*)) (DESIRED-DEPTH (FIRST LOOKUP)) (DESIRED-BINDING-DEPTH (MAPCAR 'CDR (SECOND LOOKUP)))) (COND ((NULL DEPTH) (IL:* IL:|;;| "We don't know where we are: use UNWIND.") (EMIT-UNWIND DESIRED-DEPTH SAVE-TOS?) (SETQ DEPTH DESIRED-DEPTH BINDING-DEPTH DESIRED-BINDING-DEPTH)) ((EQ (FIRST BINDING-DEPTH) (FIRST DESIRED-BINDING-DEPTH)) (IL:* IL:|;;| "There are no intervening binds, so we can just pop.") (WHEN SAVE-TOS? (DECF DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :SET-STACK)) (LET ((ADJUSTMENT (- DEPTH DESIRED-DEPTH))) (IF (MINUSP ADJUSTMENT) (HELP "POP.N stack adjustment negative: " ADJUSTMENT)) (CASE ADJUSTMENT ((0) ) ((1) (IF SAVE-TOS? (EMIT-BYTE 'IL:SWAP)) (EMIT-BYTE 'IL:POP)) (OTHERWISE (IF SAVE-TOS? (IF (<= ADJUSTMENT 128) (IL:* IL:|;;|  "STORE.N can only be used for distances less than this limit.") (EMIT-BYTE-LIST `(IL:STORE.N ,(* 2 (1- ADJUSTMENT)) IL:POP.N ,(1- ADJUSTMENT))) (EMIT-UNWIND DESIRED-DEPTH T)) (IF (<= ADJUSTMENT 256) (IL:* IL:|;;|  "POP.N can only be used for disatnces less than this limit.") (EMIT-BYTE-LIST `(IL:POP.N ,(1- ADJUSTMENT))) (EMIT-UNWIND DESIRED-DEPTH NIL))))) (SETQ DEPTH DESIRED-DEPTH))) ((AND (EQUAL (REST BINDING-DEPTH) DESIRED-BINDING-DEPTH) (EQL DESIRED-DEPTH (FIRST DESIRED-BINDING-DEPTH))) (IL:* IL:|;;| "There is only one bind mark in the way - use UNBIND") (EMIT-BYTE (IF SAVE-TOS? 'IL:UNBIND 'IL:DUNBIND)) (SETQ DEPTH (POP BINDING-DEPTH)) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :|pop-of-binding-stack|)) (T (IL:* IL:|;;| "Use UNWIND in all other cases.") (EMIT-UNWIND DESIRED-DEPTH SAVE-TOS?) (SETQ DEPTH DESIRED-DEPTH BINDING-DEPTH DESIRED-BINDING-DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :SET-STACK-USING-UNWIND))) (WHEN SAVE-TOS? (INCF DEPTH))))) ((:BIND) (LABELS ((DO-BIND (NUM-VALUES NUM-NILS STARTING-SLOT) (COND ((> NUM-VALUES 15) (COMPILER:ASSEMBLER-ERROR "Too many non-NIL values bound in a single :BIND: ~S. Limit is 15." NUM-VALUES)) ((> NUM-NILS 15) (DO-BIND NUM-VALUES 15 STARTING-SLOT) (DO-BIND 0 (- NUM-NILS 15) (+ STARTING-SLOT NUM-VALUES 15))) (T (EMIT-BYTE-LIST `(IL:BIND ,(+ (IL:LLSH NUM-NILS 4) NUM-VALUES) ,(1- (+ STARTING-SLOT NUM-VALUES NUM-NILS)))) (INCR DEPTH))))) (LET* ((VALUES (SECOND INST)) (NUM-VALUES (LENGTH VALUES)) (NILS (THIRD INST)) (NUM-NILS (LENGTH NILS))) (DECR DEPTH NUM-VALUES) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :BIND) (PUSH DEPTH BINDING-DEPTH) (DO-BIND NUM-VALUES NUM-NILS (COND (VALUES (DVAR-SLOT (CAR VALUES))) (NILS (DVAR-SLOT (CAR NILS))) (T 1)))))) ((:UNBIND :DUNBIND) (LET ((BYTE (CASE (FIRST INST) (:UNBIND 'IL:UNBIND) (:DUNBIND 'IL:DUNBIND)))) (DOTIMES (I (FLOOR (+ (SECOND INST) (THIRD INST) 14) 15)) (EMIT-BYTE BYTE))) (SETQ DEPTH (POP BINDING-DEPTH)) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :UNBIND) (IF (EQ (FIRST INST) ':UNBIND) (INCR DEPTH))) ((:TAG) (EMIT-BYTE `(:TAG ,(SECOND INST))) (LET ((STACK-DEPTH (DTAG-STACK-DEPTH (SECOND INST)))) (SETQ DEPTH (CDR STACK-DEPTH)) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :TAG) (SETQ BINDING-DEPTH (MAPCAR 'CDR (CAR STACK-DEPTH))))) ((:PUSH-TAG) (EMIT-BYTE INST) (INCR DEPTH)) ((:JUMP) (IL:* IL:\;  "JUMP opcode does NOT pop anything off the stack") (EMIT-BYTE INST)) ((:TJUMP :FJUMP :NTJUMP :NFJUMP) (IL:* IL:\; "Other jump opcodes DO pop (the NT & NF, only if the jump isn't taken). Since we're looking at stack depth right after this instruction, this means we can assume the jump didn't happen....") (EMIT-BYTE INST) (DECR DEPTH) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :JUMP)) ((:CALL) (DESTRUCTURING-BIND (FN-TO-CALL NUM-ARGS &KEY ((:NOT-INLINE NOT-INLINE?)) ((:SPREAD-LAST SPREAD-LAST?)) (IL:* IL:\; "SPREAD-LAST? is the hook for APPLY and the interpreter hacks. Currently ignored. The idea is that you let the assembler put in the magic loop that spreads the last argument, and takes case of allocating the temps for that loop.") ) (REST INST) (TYPECASE FN-TO-CALL (SYMBOL (IL:* IL:\; "External call") (LET ((DOPVAL (GET FN-TO-CALL 'IL:DOPVAL))) (BLOCK :CALL-PROCESSING (UNLESS (OR NOT-INLINE? (NULL DOPVAL)) (ASSERT (CONSP DOPVAL) '(FN-TO-CALL DOPVAL) "DOPVAL for ~S is not a list: ~S" FN-TO-CALL DOPVAL) (IL:FOR ITEM IL:INSIDE (IF (ATOM (CAR DOPVAL)) (LIST DOPVAL) DOPVAL) IL:DO (COND ((ATOM ITEM) (IL:* IL:\;  "The ITEM is OPT.COMPILERERROR. Compile the call closed.") (RETURN)) ((OR (NULL (CAR ITEM)) (= (CAR ITEM) NUM-ARGS)) (COND ((CONSP (CDR ITEM)) (MAPC 'EMIT-BYTE (CDR ITEM)) (RETURN-FROM :CALL-PROCESSING)) (T (IL:* IL:\;  "The ITEM is something like (0 . OPT.COMPILERERROR). Compile the call closed.") (RETURN))))))) (IL:* IL:|;;|  "Either no DOPVAL or the DOPVAL failed. Compile as a closed call.") (COND ((<= NUM-ARGS 255) (EMIT-BYTE-LIST (CASE NUM-ARGS ((0) '(IL:FN0)) ((1) '(IL:FN1)) ((2) '(IL:FN2)) ((3) '(IL:FN3)) ((4) '(IL:FN4)) (OTHERWISE `(IL:FNX ,NUM-ARGS)))) (EMIT-BYTE `(:FN ,FN-TO-CALL))) (T (IL:* IL:|;;| "Lots of arguments. Call using APPLYFN.") (EMIT-BYTE-LIST (PUSH-INTEGER NUM-ARGS)) (EMIT-BYTE-LIST `(IL:ACONST (:FN ,FN-TO-CALL) IL:APPLYFN))))))) (DVAR (IL:* IL:\;  "Call a function that lives in a variable") (EMIT-BYTE-LIST (PUSH-INTEGER NUM-ARGS)) (COND ((EQ (DVAR-KIND FN-TO-CALL) :FUNCTION) (ASSERT (NOT (NULL (DVAR-LEVEL FN-TO-CALL))) '(FN-TO-CALL) "BUG: The local function ~A should have a lexical level by now." (DVAR-NAME FN-TO-CALL)) (EMIT-BYTE-LIST `(IL:GCONST (:LOCAL-FUNCTION ,FN-TO-CALL))) (COND ((AND NIL (ZEROP (DVAR-LEVEL FN-TO-CALL))) (IL:* IL:\;  "We used to do something different for an empty environment.") (IL:* IL:\;  "No non-locals -- use applyfn.") (EMIT-BYTE 'IL:APPLYFN)) (T (EMIT-BYTE-LIST (FETCH-HUNK (DVAR-LEVEL FN-TO-CALL))) (EMIT-BYTE 'IL:ENVCALL)))) (T (EMIT-BYTE-LIST (REF-VAR FN-TO-CALL)) (EMIT-BYTE 'IL:APPLYFN)))) (CONS (ECASE (FIRST FN-TO-CALL) ((:OPCODES) (EMIT-BYTE-LIST (REST FN-TO-CALL))) ((:LAMBDA) (EMIT-BYTE-LIST (PUSH-INTEGER NUM-ARGS)) (LET ((DLAMBDA (SECOND FN-TO-CALL)) (LAMBDA-LEVEL (THIRD FN-TO-CALL))) (COND ((AND NIL (ZEROP LAMBDA-LEVEL)) (IL:* IL:\;  "We used to do something different for an empty environment.") (IL:* IL:|;;| "No closed-over variables: use APPLYFN.") (EMIT-BYTE-LIST `(IL:GCONST (:LAMBDA 0 ,DLAMBDA) IL:APPLYFN))) (T (IL:* IL:|;;|  "This will need to be a closure. Find our best hunk for it and call using ENVCALL.") (EMIT-BYTE-LIST `(IL:GCONST (:LAMBDA ,LAMBDA-LEVEL ,DLAMBDA) ,@(FETCH-HUNK LAMBDA-LEVEL) IL:ENVCALL)))))))) (T (ERROR "BUG: Weird argument to :CALL ~S" FN-TO-CALL))) (DECR DEPTH (1- NUM-ARGS)) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :CALL))) ((:STKCALL) (EMIT-BYTE 'IL:APPLYFN) (DECR DEPTH (1+ (SECOND INST))) (ASSERT (OR (NOT DEPTH) (>= DEPTH 0)) NIL "Depth went negative in ~S." :STKCALL)) ((:RETURN) (EMIT-BYTE 'RETURN)) ((:CLOSE) (IL:* IL:\;  "After digestion, this looks like this:") (IL:* IL:\;  "(:CLOSE dvars hunk-slot . code).") (CREATE-HUNK (+ (LIST-LENGTH (SECOND INST)) (IF (NULL *HUNK-MAP*) (IL:* IL:\; "If this hunk is not at level 0, we need an extra hunk slot in order to link it to the previous one.") 0 1)) (THIRD INST) (CDAR *HUNK-MAP*) T) (LET* ((*LEVEL* (1+ *LEVEL*)) (*HUNK-MAP* (CONS (CONS *LEVEL* (THIRD INST)) *HUNK-MAP*))) (SETQ DEPTH (ASSEMBLE-CODE (CDDDR INST) DEPTH BINDING-DEPTH)) (ASSERT (>= DEPTH 0) (OR (NOT DEPTH)) NIL "Depth went negative in ~S." :CLOSE)))))) DEPTH) (IL:* IL:|;;| "Jump resolution") (DEFVAR *JUMP-LIST* NIL "A list of DJUMP and DTAG structures for use by jump resolution.") (DEFCONSTANT +JUMP-CHOICES+ '((:JUMP IL:JUMP IL:JUMPX IL:JUMPXX) (:FJUMP IL:FJUMP IL:FJUMPX (IL:TJUMP 2)) (:TJUMP IL:TJUMP IL:TJUMPX (IL:FJUMP 2)) (:NFJUMP IL:NFJUMP IL:NFJUMPX) (:NTJUMP IL:NTJUMP IL:NTJUMPX)) (IL:* IL:|;;;| "AList from kinds of jumps to lists of choices for implementation of that kind of jump. See SPLICE-IN-JUMPS for details.") ) (DEFCONSTANT +JUMP-RANGE-SIZE-MAP+ '((:JUMP (-128 . 3) (1 . 2) (18 . 1) (128 . 2) (32768 . 3)) (:FJUMP (-128 . 4) (2 . 2) (18 . 1) (128 . 2) (32768 . 4)) (:TJUMP (-128 . 4) (2 . 2) (18 . 1) (128 . 2) (32768 . 4)) (:NFJUMP (-128 . 6) (128 . 2) (32768 . 6)) (:NTJUMP (-128 . 6) (128 . 2) (32768 . 6))) (IL:* IL:|;;;| "An AList mapping kinds of jumps into an range-to-size table. The table is a list of pairs, sorted on the CAR. The shortest jump for a given distance is the CDR of the first pair whose CAR is strictly greater than the distance.") ) (DEFCONSTANT +JUMP-SIZES+ '((:JUMP 1 3) (:FJUMP 1 4) (:TJUMP 1 4) (:NFJUMP 2 6) (:NTJUMP 2 6)) "AList mapping kinds of jumps into the range of sizes for that kind, in bytes.") (DEFUN RESOLVE-JUMPS (JUMP-LIST) (LET ((CUMULATIVE-UNCERTAINTY 0)) (IL:|for| JUMP-OR-TAG IL:|in| JUMP-LIST IL:|do| (ETYPECASE JUMP-OR-TAG (DTAG (SETF (DTAG-PC-UNCERTAINTY JUMP-OR-TAG) CUMULATIVE-UNCERTAINTY)) (DJUMP (LET ((RANGE (ASSOC (DJUMP-KIND JUMP-OR-TAG) +JUMP-SIZES+))) (SETF (DJUMP-FORWARD-P JUMP-OR-TAG) (> (DTAG-MIN-PC (DJUMP-TAG JUMP-OR-TAG)) (DJUMP-MIN-PC JUMP-OR-TAG))) (SETF (DJUMP-MIN-SIZE JUMP-OR-TAG) (SECOND RANGE)) (INCF CUMULATIVE-UNCERTAINTY (SETF (DJUMP-SIZE-UNCERTAINTY JUMP-OR-TAG) (- (THIRD RANGE) (SECOND RANGE))))))))) (IL:|while| (REDUCE-UNCERTAINTY JUMP-LIST)) (SPLICE-IN-JUMPS JUMP-LIST) (IL:* IL:|;;| "We need to convert the PC's in the tags from zero-based to START-PC-based.") (LET ((START-PC (START-PC-FROM-NT-COUNT-LOCAL (LENGTH (DCODE-NAME-TABLE *DCODE*))))) (IL:|for| JUMP-OR-TAG IL:|in| JUMP-LIST IL:|when| (DTAG-P JUMP-OR-TAG) IL:|do| (INCF (DTAG-PC JUMP-OR-TAG) START-PC)))) (DEFUN REDUCE-UNCERTAINTY (JUMP-LIST) (LET ((DECREASE-IN-UNCERTAINTY 0) (INCREASE-IN-MIN-PC 0) (CUMULATIVE-UNCERTAINTY 0)) (IL:FOR JUMP-OR-TAG IL:IN JUMP-LIST IL:DO (ETYPECASE JUMP-OR-TAG (DTAG (IL:* IL:\;  "Just record the current uncertainty at this tag.") (SETF (DTAG-PC-UNCERTAINTY JUMP-OR-TAG) CUMULATIVE-UNCERTAINTY) (INCF (DTAG-MIN-PC JUMP-OR-TAG) INCREASE-IN-MIN-PC)) (DJUMP (INCF (DJUMP-MIN-PC JUMP-OR-TAG) INCREASE-IN-MIN-PC) (WHEN (> (DJUMP-SIZE-UNCERTAINTY JUMP-OR-TAG) 0) (IL:* IL:\;  "This is a jump we can hope to improve.") (LET ((TAG (DJUMP-TAG JUMP-OR-TAG)) (KIND (DJUMP-KIND JUMP-OR-TAG)) (JUMP JUMP-OR-TAG) MIN-DISTANCE MAX-DISTANCE MIN-SIZE MAX-SIZE) (COND ((DJUMP-FORWARD-P JUMP) (IL:* IL:|;;| "In computing the min and max distance between a forward jump and its tag, we must adjust for the changes we've made so far this pass.") (SETQ MIN-DISTANCE (+ (- (DTAG-MIN-PC TAG) (DJUMP-MIN-PC JUMP)) INCREASE-IN-MIN-PC)) (SETQ MAX-DISTANCE (+ (- (DTAG-PC-UNCERTAINTY TAG) (+ DECREASE-IN-UNCERTAINTY CUMULATIVE-UNCERTAINTY)) MIN-DISTANCE))) (T (IL:* IL:\; "This situation is much simpler with backward jumps since both tag and jump are in the same units.") (SETQ MIN-DISTANCE (- (DTAG-MIN-PC TAG) (DJUMP-MIN-PC JUMP))) (SETQ MAX-DISTANCE (+ (- (DTAG-PC-UNCERTAINTY TAG) CUMULATIVE-UNCERTAINTY) MIN-DISTANCE)))) (SETQ MIN-SIZE (COMPUTE-JUMP-SIZE KIND MIN-DISTANCE)) (SETQ MAX-SIZE (COMPUTE-JUMP-SIZE KIND MAX-DISTANCE)) (WHEN (> MIN-SIZE (DJUMP-MIN-SIZE JUMP)) (INCF INCREASE-IN-MIN-PC (- MIN-SIZE (DJUMP-MIN-SIZE JUMP))) (SETF (DJUMP-MIN-SIZE JUMP) MIN-SIZE)) (LET ((NEW-SIZE-UNCERTAINTY (- MAX-SIZE MIN-SIZE))) (WHEN (/= (DJUMP-SIZE-UNCERTAINTY JUMP) NEW-SIZE-UNCERTAINTY) (ASSERT (>= NEW-SIZE-UNCERTAINTY 0) NIL "The size uncertainty went negative") (INCF DECREASE-IN-UNCERTAINTY (- ( DJUMP-SIZE-UNCERTAINTY JUMP) NEW-SIZE-UNCERTAINTY)) (SETF (DJUMP-SIZE-UNCERTAINTY JUMP) NEW-SIZE-UNCERTAINTY)) (INCF CUMULATIVE-UNCERTAINTY NEW-SIZE-UNCERTAINTY))))))) (IL:* IL:|;;| "If we've either got no uncertainty left in the system or didn't manage to achieve anything this pass, give it up; we're done.") (NOT (OR (ZEROP CUMULATIVE-UNCERTAINTY) (ZEROP DECREASE-IN-UNCERTAINTY))))) (DEFUN SPLICE-IN-JUMPS (JUMP-LIST) (IL:FOR JUMP IL:IN JUMP-LIST IL:DO (IF (DTAG-P JUMP) (SETF (DTAG-PC JUMP) (DTAG-MIN-PC JUMP)) (LET* ((PTR (DJUMP-PTR JUMP)) (TAG (DJUMP-TAG JUMP)) (DISTANCE (- (DTAG-MIN-PC TAG) (DJUMP-MIN-PC JUMP))) (KIND (DJUMP-KIND JUMP)) (SIZE (COMPUTE-JUMP-SIZE KIND DISTANCE)) (CHOICES (CDR (ASSOC KIND +JUMP-CHOICES+)))) (ECASE SIZE ((1) (IL:* IL:\;  "One-byte jumps: JUMP, TJUMP, and FJUMP") (COND ((= DISTANCE 1) (ASSERT (EQ KIND ':JUMP) NIL "BUG: SPLICE-IN-JUMPS found a wierd jump.") (RPLACA PTR 'IL:NOP)) (T (RPLACA PTR (LIST (FIRST CHOICES) (- DISTANCE 2)))))) ((2) (IL:* IL:\;  "Two-byte-jumps: JUMPX, FJUMPX, TJUMPX, NTJUMPX, and NFJUMPX") (IL:RPLNODE PTR (SECOND CHOICES) (CONS (IF (< DISTANCE 0) (+ DISTANCE 256) DISTANCE) (CDR PTR)))) ((3 4) (IL:* IL:\;  "The three-byte jump is JUMPXX. Four-byte jumps are like (FJUMP 4) JUMPXX to implement TJUMPXX.") (COND ((= SIZE 3) (RPLACA PTR (THIRD CHOICES))) (T (DECF DISTANCE) (IL:* IL:\;  "In the four-byte case, the true jump is from one byte later in the code stream.") (RPLACA PTR (THIRD CHOICES)) (RPLACD PTR (CONS 'IL:JUMPXX (CDR PTR))) (SETQ PTR (CDR PTR)))) (IL:* IL:|;;| "At this point, PTR is the tail of the code starting with the JUMPXX instruction. We need to fix up the jump offset here.") (RPLACD PTR (LIST* (LOGAND (IL:LRSH DISTANCE 8) 255) (LOGAND DISTANCE 255) (CDR PTR)))) ((6) (IL:* IL:\;  "Six-byte jumps are long NCJUMPXX's implemented by NCJUMPX 3 (JUMP 4) JUMPXX") (DECF DISTANCE 3) (IL:* IL:\; "Take into account that the actual jump to the destination is three bytes later in the code stream.") (IL:RPLNODE PTR (SECOND CHOICES) `(3 (IL:JUMP 4) IL:JUMPXX ,(LOGAND (IL:LRSH DISTANCE 8) 255) ,(LOGAND DISTANCE 255) ,@(CDR PTR))))))))) (DEFUN COMPUTE-JUMP-SIZE (KIND DISTANCE) (LET ((PAIRS (CDR (ASSOC KIND +JUMP-RANGE-SIZE-MAP+)))) (IL:|find| PAIR IL:|in| PAIRS IL:|suchthat| (< DISTANCE (CAR PAIR)) IL:|finally| (RETURN (CDR PAIR))))) (IL:* IL:\; "Debugging jump resolution") (DEFUN PRETTY-JUMPS () (IL:|for| JUMP-OR-TAG IL:|in| (REVERSE *JUMP-LIST*) IL:|collect| (ETYPECASE JUMP-OR-TAG (DTAG `(:TAG :MIN-PC ,(DTAG-MIN-PC JUMP-OR-TAG) :PC-UNCERTAINTY ,(DTAG-PC-UNCERTAINTY JUMP-OR-TAG))) (DJUMP `(,(DJUMP-KIND JUMP-OR-TAG) :MIN-PC ,(DJUMP-MIN-PC JUMP-OR-TAG) :MIN-SIZE ,(DJUMP-MIN-SIZE JUMP-OR-TAG) :FORWARD-P ,(DJUMP-FORWARD-P JUMP-OR-TAG) :SIZE-UNCERTAINTY ,(DJUMP-SIZE-UNCERTAINTY JUMP-OR-TAG) :TAG (:MIN-PC ,(DTAG-MIN-PC (DJUMP-TAG JUMP-OR-TAG)))))))) (IL:* IL:|;;| "Conversion to binary") (DEFVAR *LOCAL-FN-FIXUPS*) (DEFUN CONVERT-TO-BINARY (BYTE-LIST) (LET* ((CODELEN (LENGTH BYTE-LIST)) (CODE-ARRAY (MAKE-ARRAY CODELEN :ELEMENT-TYPE '(UNSIGNED-BYTE 8))) (UNWIND-OFFSET (+ (IL:CEIL (+ (DCODE-NLOCALS *DCODE*) (DCODE-NFREEVARS *DCODE*)) IL:CELLSPERQUAD) IL:CELLSPERQUAD) (IL:* IL:\; "The number of PVAR slots, rounded up to a quadword boundary, plus an extra quadword for the Dolphin's hardware stack.") ) (PUSH-TAG-FIXUPS NIL)) (IL:FOR BYTE IL:IN BYTE-LIST IL:AS CODE-INDEX IL:FROM 0 IL:DO (SETF (AREF CODE-ARRAY CODE-INDEX) (ETYPECASE BYTE (SYMBOL (IL:* IL:\;  "Symbols represent real D-machine opcodes.") (IL:|fetch| IL:OP# IL:|of| (LET ((OPCODE (IL:\\FINDOP BYTE))) (ASSERT (NOT (NULL OPCODE)) NIL "BUG: Can't find purported opcode ~S" BYTE) OPCODE))) ((UNSIGNED-BYTE 8) (IL:* IL:\; "Small integers generally represent themselves, usually either as arguments to opcodes or filler bytes for fixups.") BYTE) (CONS (IL:* IL:\;  "Conses are either fixups or opcodes that take their argument inside their bytecode.") (CASE (FIRST BYTE) ((:SYM) (PUSH (LIST CODE-INDEX (SECOND BYTE)) (DCODE-SYM-FIXUPS *DCODE*)) 0) ((:LIT) (PUSH (LIST CODE-INDEX (SECOND BYTE)) (DCODE-LIT-FIXUPS *DCODE*)) 0) ((:FN) (PUSH (LIST CODE-INDEX (SECOND BYTE)) (DCODE-FN-FIXUPS *DCODE*)) 0) ((:TYPE) (PUSH (LIST CODE-INDEX (SECOND BYTE)) (DCODE-TYPE-FIXUPS *DCODE*)) 0) ((:LAMBDA) (PUSH (LIST CODE-INDEX (DCODE-FROM-DLAMBDA (THIRD BYTE) (SECOND BYTE))) (DCODE-LIT-FIXUPS *DCODE*)) 0) ((:LOCAL-FUNCTION) (DESTRUCTURING-BIND (IGNORE DCODE-FIXUP DCODE-FOR-FIXUP) (FIND (SECOND BYTE) *LOCAL-FN-FIXUPS* :TEST 'EQ :KEY 'CAR) (DECLARE (IGNORE IGNORE)) (ETYPECASE DCODE-FIXUP (DLAMBDA (SETQ DCODE-FIXUP (DCODE-FROM-DLAMBDA DCODE-FIXUP (DVAR-LEVEL (SECOND BYTE))))) (DCODE NIL)) (PUSH (LIST *DCODE* CODE-INDEX DCODE-FIXUP) (DCODE-LOCAL-FN-FIXUPS DCODE-FOR-FIXUP))) 0) ((:UNWIND) (+ UNWIND-OFFSET (SECOND BYTE))) ((:PUSH-TAG) (PUSH (LIST CODE-INDEX (DTAG-PC (SECOND BYTE))) PUSH-TAG-FIXUPS) 0) (OTHERWISE (LET ((RANGE (IL:|fetch| IL:OP# IL:|of| (LET ((OPCODE (IL:\\FINDOP (FIRST BYTE)))) (ASSERT (NOT (NULL OPCODE)) NIL "BUG: Can't find purported opcode ~S" (FIRST BYTE)) OPCODE)))) (ASSERT (AND (CONSP RANGE) (INTEGERP (FIRST RANGE)) (INTEGERP (SECOND RANGE))) NIL "BUG: Argument given to the ~A opcode, but it doesn't take one." (FIRST BYTE)) (ASSERT (<= 0 (SECOND BYTE) (- (SECOND RANGE) (FIRST RANGE))) NIL "BUG: Illegal argument to ~A opcode: ~S" (FIRST BYTE) (SECOND BYTE)) (+ (FIRST RANGE) (SECOND BYTE))))))))) (IL:* IL:|;;| "Do the push-tag fixups") (IL:|for| FIXUP IL:|in| PUSH-TAG-FIXUPS IL:|do| (DESTRUCTURING-BIND (OFFSET PC) FIXUP (SETF (AREF CODE-ARRAY OFFSET) (LDB (BYTE 8 8) PC)) (SETF (AREF CODE-ARRAY (1+ OFFSET)) (LDB (BYTE 8 0) PC)))) (IL:* IL:|;;| "We're done making the bytes. Stuff the code-array into the DCODE.") (SETF (DCODE-CODE-ARRAY *DCODE*) CODE-ARRAY))) (IL:* IL:|;;| "Setting up the debugging information") (DEFUN COMPUTE-DEBUGGING-INFO (DLAMBDA) (SETF (DCODE-DEBUGGING-INFO *DCODE*) `((,@(MAPCAR #'DVAR-NAME (DLAMBDA-REQUIRED DLAMBDA)) ,@(AND (DLAMBDA-OPTIONAL DLAMBDA) (CONS '&OPTIONAL (MAPCAR #'(LAMBDA (OPT-VAR) (DVAR-NAME (FIRST OPT-VAR))) (DLAMBDA-OPTIONAL DLAMBDA)))) ,@(AND (DLAMBDA-REST DLAMBDA) (NOT (EQ :IGNORED (DLAMBDA-REST DLAMBDA))) (LIST '&REST (DVAR-NAME (DLAMBDA-REST DLAMBDA)))) ,@(AND (OR (DLAMBDA-KEY DLAMBDA) (DLAMBDA-ALLOW-OTHER-KEYS DLAMBDA)) (CONS '&KEY (MAPCAR #'FIRST (DLAMBDA-KEY DLAMBDA)))) ,@(AND (DLAMBDA-ALLOW-OTHER-KEYS DLAMBDA) '(&ALLOW-OTHER-KEYS))) ,@(AND (DLAMBDA-ARG-TYPE DLAMBDA) '(:INTERLISP T))))) (IL:* IL:|;;| "Fixup resolution and DCODE interning") (DEFUN START-PC-FROM-NT-COUNT (NT-COUNT) (IL:* IL:|;;;| "If a given compiled-code object has a name table NT-COUNT entries long, what will its starting PC be?") (IL:* IL:|;;| "IF YOU CHANGE THIS FUNCTION, CHANGE START-PC-FROM-NT-COUNT-LOCAL TO MATCH IT.") (LET* ((NT-SIZE (IL:CEIL (1+ (IL:UNFOLD NT-COUNT (IL:CONSTANT (IL:WORDSPERNAMEENTRY)))) IL:WORDSPERQUAD)) (NT-WORDS (IF (ZEROP NT-COUNT) IL:WORDSPERQUAD (+ NT-SIZE NT-SIZE)))) (* (+ (IL:|fetch| (IL:CODEARRAY IL:OVERHEADWORDS) IL:|of| T) NT-WORDS IL:WORDSPERCELL) IL:BYTESPERWORD))) (DEFUN START-PC-FROM-NT-COUNT-LOCAL (NT-COUNT) (IL:* IL:|;;;| "If a given compiled-code object has a name table NT-COUNT entries long, what will its starting PC be? This version computes thevalue at run-time, rather than having the architecture compiled in, as START-PC-FROM-NT-COUNT does.") (IL:* IL:|;;| "If you change this function, change START-PC-FROM-NT-COUNT to match!") (LET* ((NT-SIZE (IL:CEIL (1+ (IL:LLSH NT-COUNT (COND ((IL:FMEMB :3-BYTE ( COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT*)) 1) ((AND IL:CROSSCOMPILING (IL:FMEMB :3-BYTE-INIT ( COMPILER::ENV-TARGET-ARCHITECTURE COMPILER::*ENVIRONMENT* ))) 1) (T 0)))) IL:WORDSPERQUAD)) (NT-WORDS (IF (ZEROP NT-COUNT) IL:WORDSPERQUAD (+ NT-SIZE NT-SIZE)))) (* (+ (IL:|fetch| (IL:CODEARRAY IL:OVERHEADWORDS) IL:|of| T) NT-WORDS IL:WORDSPERCELL) IL:BYTESPERWORD))) (DEFUN ALLOCATE-CODE-BLOCK (NT-COUNT CODE-LEN) (IL:* IL:|;;;| "Return a code-array that is large enough to hold a compiled function with a name-table NT-COUNT entries long and with CODE-LEN bytecodes. Also return, as a second value, the index in that code-array of the place to put the first bytecode.") (LET* ((START-PC (START-PC-FROM-NT-COUNT NT-COUNT)) (TOTAL-SIZE (IL:CEIL (+ START-PC CODE-LEN) IL:BYTESPERQUAD)) (CODE-BASE (IL:\\ALLOC.CODE.BLOCK TOTAL-SIZE (IL:CEIL (1+ (CEILING START-PC IL:BYTESPERCELL )) IL:CELLSPERQUAD)))) (VALUES CODE-BASE START-PC))) (DEFUN FIXUP-PTR (BASE OFFSET PTR) (IL:* IL:|;;| "Fix up a pointer within a code block.") (LET ((LOW (IL:\\LOLOC PTR))) (IL:UNINTERRUPTABLY (IL:\\ADDREF PTR) (COND ((IL:FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (IL:LRSH (IL:\\HILOC PTR) 8))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LOGOR (IL:\\GETBASEBYTE BASE (+ 1 OFFSET)) (LOGAND 255 (IL:\\HILOC PTR)))) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (IL:LRSH LOW 8)) (IL:\\PUTBASEBYTE BASE (+ 3 OFFSET) (LOGAND LOW 255))) ((IL:FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (LOGAND 255 (IL:\\HILOC PTR)))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LRSH LOW 8)) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (LOGAND LOW 255))))) PTR)) (DEFUN FIXUP-PTR-NO-REF (BASE OFFSET PTR) (IL:* IL:|;;| "Only used for code self-references: doesn't ADDREF the pointer.") (LET ((LOW (IL:\\LOLOC PTR))) (IL:UNINTERRUPTABLY (COND ((IL:FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (IL:LRSH (IL:\\HILOC PTR) 8))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LOGOR (IL:\\GETBASEBYTE BASE (+ 1 OFFSET)) (LOGAND 255 (IL:\\HILOC PTR)))) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (IL:LRSH LOW 8)) (IL:\\PUTBASEBYTE BASE (+ 3 OFFSET) (LOGAND LOW 255))) ((IL:FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (LOGAND 255 (IL:\\HILOC PTR)))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LRSH LOW 8)) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (LOGAND LOW 255))))) PTR)) (DEFUN FIXUP-SYMBOL (BASE OFFSET SYMBOL) (IL:* IL:|;;| "Fix up an atom number (GVAR or FNx or ACONST) in a compiled-code object.") (LET ((WORD (COND ((SYMBOLP SYMBOL) (IL:\\LOLOC SYMBOL)) (T SYMBOL))) (HIBYTE (COND ((SYMBOLP SYMBOL) (IL:\\HILOC SYMBOL)) (T 0)))) (COND ((IL:FMEMB :4-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:* IL:|;;| "For 4-byte-atom architecture, treat it as a pointer.") (IL:UNINTERRUPTABLY (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (IL:LRSH HIBYTE 8))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LOGOR (IL:\\GETBASEBYTE BASE (+ 1 OFFSET)) (LOGAND 255 HIBYTE))) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (LOGAND 255 (IL:LRSH WORD 8))) (IL:\\PUTBASEBYTE BASE (+ 3 OFFSET) (LOGAND WORD 255))) WORD) ((IL:FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:* IL:|;;| "For 4-byte-atom architecture, treat it as a pointer.") (IL:UNINTERRUPTABLY (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (LOGAND 255 HIBYTE))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (LOGAND 255 (IL:LRSH WORD 8))) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (LOGAND WORD 255))) WORD) (T (IL:* IL:\;  "Otherwise, it's a 2-byte #.") (IL:\\PUTBASEBYTE BASE OFFSET (IL:LRSH WORD 8)) (IL:\\PUTBASEBYTE BASE (1+ OFFSET) (LOGAND WORD 255)) WORD)))) (DEFUN FIXUP-NTENTRY (BASE OFFSET SYMBOL) (IL:* IL:|;;| "Fix up a NAMETABLE entry. OFFSET is in BYTES.") (LET ((WORD (COND ((SYMBOLP SYMBOL) (IL:\\LOLOC SYMBOL)) (T SYMBOL))) (HIBYTE (COND ((SYMBOLP SYMBOL) (IL:\\HILOC SYMBOL)) (T 0)))) (COND ((IL:FMEMB :3-BYTE COMPILER::*HOST-ARCHITECTURE*) (IL:* IL:|;;| "For 3-byte-atom architecture, treat it as a pointer.") (IL:* SETQ OFFSET (IL:ADD1 OFFSET)) (IL:* IL:\;  "Pointer WAS 3 bytes, right-justified in a 4-byte field") (IL:UNINTERRUPTABLY (IL:\\PUTBASEBYTE BASE OFFSET (IL:LOGOR (IL:\\GETBASEBYTE BASE OFFSET) (LOGAND 255 (IL:LRSH HIBYTE 8)))) (IL:\\PUTBASEBYTE BASE (+ 1 OFFSET) (IL:LOGOR (IL:\\GETBASEBYTE BASE (+ 1 OFFSET)) (LOGAND 255 HIBYTE))) (IL:\\PUTBASEBYTE BASE (+ 2 OFFSET) (LOGAND 255 (IL:LRSH WORD 8))) (IL:\\PUTBASEBYTE BASE (+ 3 OFFSET) (LOGAND WORD 255))) WORD) (T (IL:* IL:\;  "Otherwise, it's a 2-byte #.") (IL:\\PUTBASEBYTE BASE OFFSET (IL:LRSH WORD 8)) (IL:\\PUTBASEBYTE BASE (1+ OFFSET) (LOGAND WORD 255)) WORD)))) (DEFUN FIXUP-WORD (BASE OFFSET WORD) (IL:* IL:|;;| "Fix up a 16-bit loadtime constant in the code stream. Used now only for type #s in a compiled-code object.") (IL:\\PUTBASEBYTE BASE OFFSET (IL:LRSH WORD 8)) (IL:\\PUTBASEBYTE BASE (1+ OFFSET) (LOGAND WORD 255)) WORD) (DEFUN INTERN-DCODE (DCODE &OPTIONAL (COPY-P (ARRAYP (DCODE-CODE-ARRAY DCODE)))) (IL:* IL:|;;;| "NOTE: For unfortunately unavoidable performance reasons, this code is essentially duplicated in the FASL loader. If you change something here, change it there as well. And don't change anything unless you've got a pointy hat with a lot of stars on it.") (IL:* IL:|;;| "NTSIZE and NTBYTESIZE are the length of one-half of the name table in words and bytes, respectively. NTWORDS is the length of the whole name table in words.") (LET* ((NAME-TABLE (DCODE-NAME-TABLE DCODE)) (NAME-TABLE-SIZE (LENGTH NAME-TABLE)) (NTSIZE (IL:CEIL (1+ (IL:UNFOLD NAME-TABLE-SIZE (IL:CONSTANT (IL:WORDSPERNAMEENTRY)))) IL:WORDSPERQUAD)) (NTBYTESIZE (* NTSIZE IL:BYTESPERWORD)) (NTWORDS (IF (ZEROP NAME-TABLE-SIZE) IL:WORDSPERQUAD (+ NTSIZE NTSIZE))) (OVERHEADBYTES (* (IL:|fetch| (IL:FNHEADER IL:OVERHEADWORDS) IL:|of| T) IL:BYTESPERWORD)) RAW-CODE FVAROFFSET RESULT) (IL:* IL:|;;| "Copy the bytes into a raw code block if necessary.") (IF (NULL COPY-P) (SETQ RAW-CODE (DCODE-CODE-ARRAY DCODE)) (LET ((CODE-ARRAY (DCODE-CODE-ARRAY DCODE))) (MULTIPLE-VALUE-BIND (CODE-BLOCK START-INDEX) (ALLOCATE-CODE-BLOCK (LENGTH NAME-TABLE) (LENGTH CODE-ARRAY)) (IL:|for| CA-INDEX IL:|from| 0 IL:|to| (1- (LENGTH CODE-ARRAY)) IL:|as| CB-INDEX IL:|from| START-INDEX IL:|do| (IL:\\PUTBASEBYTE CODE-BLOCK CB-INDEX (AREF CODE-ARRAY CA-INDEX))) (SETQ RAW-CODE CODE-BLOCK)))) (IL:* IL:|;;| "Set up the free-variable lookup name table.") (DO ((END (LENGTH NAME-TABLE)) (I 0 (1+ I)) (INDEX OVERHEADBYTES (+ INDEX (IL:BYTESPERNAMEENTRY)))) ((>= I END)) (LET ((ENTRY (ELT NAME-TABLE I))) (FIXUP-NTENTRY RAW-CODE INDEX (THIRD ENTRY)) (IL:* IL:\;  "Atom index (or atom itself for 3-byte case)") (FASL::FIXUP-NTOFFSET RAW-CODE (+ INDEX NTBYTESIZE) (IL:LLSH (FIRST ENTRY) 14) (SECOND ENTRY)) (IL:* IL:\; "VAR TYPE AND OFFSET") (WHEN (AND (NULL FVAROFFSET) (= (FIRST ENTRY) +FVAR-CODE+)) (SETQ FVAROFFSET (FLOOR INDEX IL:BYTESPERWORD))))) (IL:* IL:|;;| "Fill in the fixed-size fields at the front of the block.") (IL:|replace| (IL:FNHEADER IL:NA) IL:|of| RAW-CODE IL:|with| (DCODE-NUM-ARGS DCODE)) (IL:|replace| (IL:FNHEADER IL:PV) IL:|of| RAW-CODE IL:|with| (1- (CEILING (+ (DCODE-NLOCALS DCODE) (DCODE-NFREEVARS DCODE)) IL:CELLSPERQUAD))) (IL:* IL:|;;| "The start-pc is after the fixed-size stuff, the name-table, and a cell in which to store the debugging info.") (IL:|replace| (IL:FNHEADER IL:STARTPC) IL:|of| RAW-CODE IL:|with| (+ OVERHEADBYTES (* NTWORDS IL:BYTESPERWORD) IL:BYTESPERCELL)) (IL:|replace| (IL:FNHEADER IL:ARGTYPE) IL:|of| RAW-CODE IL:|with| ( DCODE-ARG-TYPE DCODE)) (LET ((FRAME-NAME (DCODE-FRAME-NAME DCODE))) (IL:UNINTERRUPTABLY (IL:\\ADDREF FRAME-NAME) (IL:|replace| (IL:FNHEADER IL:\#FRAMENAME) IL:|of| RAW-CODE IL:|with| FRAME-NAME))) (IL:|replace| (IL:FNHEADER IL:NTSIZE) IL:|of| RAW-CODE IL:|with| (IF (ZEROP NAME-TABLE-SIZE) 0 NTSIZE)) (IL:|replace| (IL:FNHEADER IL:NLOCALS) IL:|of| RAW-CODE IL:|with| (DCODE-NLOCALS DCODE)) (IL:|replace| (IL:FNHEADER IL:FVAROFFSET) IL:|of| RAW-CODE IL:|with| (OR FVAROFFSET 0)) (IL:|replace| (IL:FNHEADER IL:CLOSUREP) IL:|of| RAW-CODE IL:|with| (EQ :CLOSURE ( DCODE-CLOSURE-P DCODE))) (IL:|replace| (IL:FNHEADER IL:FIXED) IL:|of| RAW-CODE IL:|with| T) (IL:* IL:|;;| "Fill in the debugging information and perform the fixups. There WAS a + 1 in the + OVERHEADBYTES... is to allow for the fact that four bytes are allocated for the debugging information, but pointers are only three bytes long, so we right-justify the pointer in the cell.") (FIXUP-PTR RAW-CODE (+ OVERHEADBYTES (* NTWORDS IL:BYTESPERWORD)) (DCODE-DEBUGGING-INFO DCODE)) (LET ((START-PC (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| RAW-CODE))) (DO ((END (LENGTH (DCODE-FN-FIXUPS DCODE))) (I 0 (1+ I))) ((>= I END)) (DESTRUCTURING-BIND (OFFSET ITEM) (ELT (DCODE-FN-FIXUPS DCODE) I) (FIXUP-SYMBOL RAW-CODE (+ START-PC OFFSET) ITEM))) (DO ((END (LENGTH (DCODE-SYM-FIXUPS DCODE))) (I 0 (1+ I))) ((>= I END)) (DESTRUCTURING-BIND (OFFSET ITEM) (ELT (DCODE-SYM-FIXUPS DCODE) I) (FIXUP-SYMBOL RAW-CODE (+ START-PC OFFSET) ITEM))) (DO ((END (LENGTH (DCODE-LIT-FIXUPS DCODE))) (I 0 (1+ I))) ((>= I END)) (DESTRUCTURING-BIND (OFFSET ITEM) (ELT (DCODE-LIT-FIXUPS DCODE) I) (FIXUP-PTR RAW-CODE (+ START-PC OFFSET) (TYPECASE ITEM (IL:* IL:\;  "Some kinds of literals get special treatment.") (DCODE (INTERN-DCODE ITEM)) (COMPILER::EVAL-WHEN-LOAD (EVAL (COMPILER::EVAL-WHEN-LOAD-FORM ITEM))) (OTHERWISE ITEM))))) (DO ((END (LENGTH (DCODE-TYPE-FIXUPS DCODE))) (I 0 (1+ I))) ((>= I END)) (DESTRUCTURING-BIND (OFFSET ITEM) (ELT (DCODE-TYPE-FIXUPS DCODE) I) (FIXUP-WORD RAW-CODE (+ START-PC OFFSET) (IL:\\RESOLVE.TYPENUMBER ITEM))))) (IL:* IL:|;;| "Wrap this up in a closure-object if requested.") (SETF (DCODE-INTERN-RESULT DCODE) (SETQ RESULT (IF (EQ :FUNCTION (DCODE-CLOSURE-P DCODE)) (IL:MAKE-COMPILED-CLOSURE RAW-CODE NIL) RAW-CODE))) (IL:* IL:|;;| "Finally,do the mutual code reference fixups, if necessary.") (PERFORM-LOCAL-FN-FIXUPS DCODE) RESULT)) (DEFUN PERFORM-LOCAL-FN-FIXUPS (DCODE) (LET ((FIXUP-LIST (DCODE-LOCAL-FN-FIXUPS DCODE))) (UNLESS (NULL FIXUP-LIST) (ASSERT (NOT (NULL (DCODE-INTERN-RESULT DCODE))) '(DCODE) "BUG: Attempt to fix up an uninterned DCODE.") (MAPC #'(LAMBDA (FIXUP) (DESTRUCTURING-BIND (DCODE-TO-FIX OFFSET DCODE-TO-INSTALL) FIXUP (FLET ((GET-CODE (THING) (IF (TYPEP THING 'IL:COMPILED-CLOSURE) (IL:FETCH (IL:COMPILED-CLOSURE IL:FNHEADER) IL:OF THING) THING)) (GET-FIXUP-VALUE (DCODE) (OR (DCODE-INTERN-RESULT DCODE) (INTERN-DCODE DCODE)))) (LET* ((VALUE-TO-FIX (GET-CODE (GET-FIXUP-VALUE DCODE-TO-FIX) )) (VALUE-TO-INSTALL (GET-FIXUP-VALUE DCODE-TO-INSTALL))) (IF (EQ DCODE-TO-FIX DCODE-TO-INSTALL) (FIXUP-PTR-NO-REF VALUE-TO-FIX (+ (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| VALUE-TO-FIX) OFFSET) VALUE-TO-INSTALL) (FIXUP-PTR VALUE-TO-FIX (+ (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| VALUE-TO-FIX) OFFSET) VALUE-TO-INSTALL)))))) FIXUP-LIST)))) (IL:* IL:|;;| "Arrange for the correct compiler to be used") (IL:PUTPROPS IL:D-ASSEM IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PUTPROPS IL:D-ASSEM IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "D-ASSEM" (:USE "LISP" "XCL")))) (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILESLOAD (IL:LOADCOMP) IL:LLBASIC IL:LLCODE IL:LLGC IL:MODARITH) ) (IL:PUTPROPS IL:D-ASSEM IL:COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1990 1991 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/D-ASSEM-PACKAGE b/sources/D-ASSEM-PACKAGE new file mode 100644 index 00000000..32695091 --- /dev/null +++ b/sources/D-ASSEM-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "D-ASSEM" (USE "LISP" "XCL"))) (IL:FILECREATED " 8-Jan-91 00:37:24" IL:|{DSK}sybalsky>3-BYTE-ATOMS>D-ASSEM-PACKAGE.;1| 2047 IL:|changes| IL:|to:| (IL:VARS IL:D-ASSEM-PACKAGECOMS) IL:|previous| IL:|date:| "16-May-90 15:13:57" IL:|{PELE:MV:ENVOS}SOURCES>D-ASSEM-PACKAGE.;2|) ; Copyright (c) 1986, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:D-ASSEM-PACKAGECOMS) (IL:RPAQQ IL:D-ASSEM-PACKAGECOMS ( (IL:* IL:|;;;| "Setting up the D-ASSEM package") (IL:P (DEFPACKAGE "D-ASSEM" (:USE "LISP" "XCL") (:EXPORT DCODE +IVAR-CODE+ +PVAR-CODE+ +FVAR-CODE+ +LAMBDA-SPREAD+ +NLAMBDA-SPREAD+ +LAMBDA-NO-SPREAD+ +NLAMBDA-NO-SPREAD+ ASSEMBLE-FUNCTION INTERN-DCODE ALLOCATE-CODE-BLOCK FIXUP-PTR FIXUP-PTR-NO-REF FIXUP-SYMBOL FIXUP-WORD RELEASE-DCODE))) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:D-ASSEM-PACKAGE))) (IL:* IL:|;;;| "Setting up the D-ASSEM package") (DEFPACKAGE "D-ASSEM" (:USE "LISP" "XCL") (:EXPORT DCODE +IVAR-CODE+ +PVAR-CODE+ +FVAR-CODE+ +LAMBDA-SPREAD+ +NLAMBDA-SPREAD+ +LAMBDA-NO-SPREAD+ +NLAMBDA-NO-SPREAD+ ASSEMBLE-FUNCTION INTERN-DCODE ALLOCATE-CODE-BLOCK FIXUP-PTR FIXUP-PTR-NO-REF FIXUP-SYMBOL FIXUP-WORD RELEASE-DCODE)) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PUTPROPS IL:D-ASSEM-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "D-ASSEM" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:D-ASSEM-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/DEBUGEDIT b/sources/DEBUGEDIT new file mode 100644 index 00000000..8d8fa8c4 --- /dev/null +++ b/sources/DEBUGEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 15:24:15" |{DSK}local>lde>lispcore>sources>DEBUGEDIT.;2| 4300 |changes| |to:| (VARS DEBUGEDITCOMS) |previous| |date:| "12-Jan-88 18:16:06" |{DSK}local>lde>lispcore>sources>DEBUGEDIT.;1|) ; Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT DEBUGEDITCOMS) (RPAQQ DEBUGEDITCOMS ((COMMANDS "EDIT") (FUNCTIONS EDIT-IN-FNS EDIT-IN-FUNCTION FIND-EDIT-LOCATION FIND-EDIT-LOCATION-TAIL) (PROP FILETYPE DEBUGEDIT))) (DEFCOMMAND ("EDIT" :DEBUGGER) () "Edit call to function at LASTPOS" (DECLARE (CL:SPECIAL BRKVALUES)) (RESETLST (LET ((POS (STKNTH 0 LASTPOS)) SEEN NAME DEF) (RESETSAVE NIL (LIST 'RELSTK POS)) (WHILE POS FINALLY (RETURN "Can't") DO (SETQ NAME (STKNAME POS)) (COND ((NOT (CL:SYMBOLP NAME)) (* \;  "non-symbol names are not editable?") ) ((FMEMB NAME '(EVAL CL:EVAL)) (CL:PUSH (STKARG 1 POS) SEEN) (* \; "remember EVALs as lists") ) (T (COND ((AND (EXPRP NAME) (OR (AND (SETQ DEF (GETDEF NAME 'FUNCTIONS NIL '(EDIT NOERROR NOCOPY))) (EDIT-IN-FUNCTION NAME DEF SEEN)) (EDIT-IN-FNS NAME (GETD NAME) SEEN))) (CL:SETF BRKVALUES (LIST ':REVERT (STKARGS POS) (STKNTH 0 POS) NAME)) (RETURN NAME)) (T (CL:PUSH NAME SEEN))))) (SETQ POS (STKNTH -1 POS POS)))))) (CL:DEFUN EDIT-IN-FNS (NAME DEF SEEN) (* |;;| "NOT YET") (LET ((LOC (FIND-EDIT-LOCATION DEF SEEN))) (EDITDEF NAME 'FNS (CONS '= DEF) (AND LOC `((ORR ((F= ,LOC))) TTY\:))) (OR NAME T))) (CL:DEFUN EDIT-IN-FUNCTION (NAME DEF SEEN) (LET ((LOC (FIND-EDIT-LOCATION DEF SEEN))) (EDITDEF NAME 'FUNCTIONS (CONS '= DEF) (AND LOC `((ORR ((F= ,LOC))) TTY\:))) (OR NAME T))) (CL:DEFUN FIND-EDIT-LOCATION (DEFINITION SEEN) "return edit location in DEFINITION of lowest caller in SEEN found" (LET ((*REMOVE-INTERLISP-COMMENTS* (EQ *REMOVE-INTERLISP-COMMENTS* T)) (* \; " if :WARN set to NIL") (EXPRS (REVERSE SEEN)) FOUND) (WHILE EXPRS DO (COND ((NLISTP (CAR EXPRS)) (POP EXPRS)) ((SETQ FOUND (AND (LISTP (CAR EXPRS)) (FIND-EDIT-LOCATION-TAIL DEFINITION (CAR EXPRS) NIL))) (AND (NULL (CDR FOUND)) (RETURN (CAR FOUND)))))))) (CL:DEFUN FIND-EDIT-LOCATION-TAIL (X EXPRESSION OTHERS) (COND ((NLISTP X) OTHERS) ((EQ (CAAR X) '*) (* |;;| "ignore comments") (FIND-EDIT-LOCATION-TAIL (CDR X) EXPRESSION OTHERS)) ((EQUAL EXPRESSION (REMOVE-COMMENTS X)) (CONS X OTHERS)) (T (FIND-EDIT-LOCATION-TAIL (CDR X) EXPRESSION (FIND-EDIT-LOCATION-TAIL (CAR X) EXPRESSION OTHERS))))) (PUTPROPS DEBUGEDIT FILETYPE CL:COMPILE-FILE) (PUTPROPS DEBUGEDIT COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/DEBUGGER b/sources/DEBUGGER new file mode 100644 index 00000000..2d918d68 --- /dev/null +++ b/sources/DEBUGGER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "DEBUGGER" (PREFIX-NAME "DBG") (NICKNAMES "DBG"))) (IL:FILECREATED "16-Aug-91 17:38:56" IL:|{PELE:MV:ENVOS}SOURCES>DEBUGGER.;3| 84381 IL:|changes| IL:|to:| (IL:FUNCTIONS DEBUGGER-EVAL) IL:|previous| IL:|date:| "16-May-90 15:26:02" IL:|{PELE:MV:ENVOS}SOURCES>DEBUGGER.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DEBUGGERCOMS) (IL:RPAQQ IL:DEBUGGERCOMS ((IL:COMS (IL:VARIABLES IL:*DEBUGGER-MENU*) (IL:ADDVARS (IL:CACHEDMENUS IL:*DEBUGGER-MENU*) (IL:FONTVARS (IL:BACKTRACEFONT IL:TINYFONT T)))) (IL:COMS (IL:VARIABLES XCL:*DEBUGGER-PROMPT* *IN-THE-DEBUGGER* XCL:*DEBUGGER-ENTRY-POINTS* ) (IL:VARIABLES IL:BRKEXP IL:BRKTYPE IL:BRKCOND IL:BRKPOS) (IL:FUNCTIONS XCL:ENTER-DEBUGGER-P) (IL:FUNCTIONS XCL:DEBUGGER EMERGENCY-PANIC-LOOP IL:FIND-DEBUGGER-ENTRY-FRAME PRINT-ENTRY-MESSAGE SIMPLE-REPORT-CONDITION XCL::INTERESTING-FRAME-P)) (IL:COMS (IL:INITVARS (IL:WBREAK)) (IL:VARIABLES XCL:*DEBUGGER-MENU-ITEMS* *DEBUGGER-TERMINAL-TABLE* IL:BREAKREGIONSPEC) (IL:FNS IL:WBREAK) (IL:ADDVARS (IL:WINDOWUSERFORMS (IL:WBREAK T)) (IL:ENDOFWINDOWUSERFORMS (IL:WBREAK NIL))) (IL:FUNCTIONS REUSE-CURRENT-WINDOW CREATE-DEBUGGER-WINDOW SET-UP-DEBUGGER-WINDOW CLOSE-DEBUGGER-WINDOW RELEASE-DEBUGGER-WINDOW NEAR-BY-REGION) (IL:FUNCTIONS DEBUGGER-BUTTON-EVENT DEBUGGER-MENU-HELP)) (IL:COMS (IL:VARIABLES IL:LASTPOS) (IL:COMMANDS "@" "REVERT" "?=" "EVAL" "VALUE" "UB") (IL:FUNCTIONS DEBUGGER-EVAL) (IL:FUNCTIONS FIND-DEBUGGER-STACK-FRAME FIND-NAMED-STACK-POSITION) (IL:FUNCTIONS FIND-ORIGINAL-NAME-AND-DEFINITION STKPTR-CCODE)) (IL:COMS (IL:INITVARS (IL:AUTOBACKTRACEFLG)) (IL:VARS IL:BAKTRACELST) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:INITVARS (IL:AUTOBACKTRACEFLG NIL) (IL:BACKTRACEFONT))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:RECORDS IL:BKMENUITEM)) (IL:VARIABLES IL:*SHORT-BACKTRACE-FILTER* IL:|MaxBkMenuWidth|) (IL:FNS IL:BAKTRACE IL:BAKTRACE1) (IL:COMMANDS "BT" "BT!" "BTV" "BTV!" "DBT" "DBT!") (IL:FUNCTIONS ATTACH-BACKTRACE-MENU REGION-NEXT-TO BACKTRACE-MENU-BUTTONEVENTFN BACKTRACE-ITEM-SELECTED STACK-FRAME-PROPERTIES STACK-FRAME-FETCHFN STACK-FRAME-STOREFN STACK-FRAME-VALUE-COMMAND STACK-FRAME-PROPERTY MAKE-FRAME-INSPECT-WINDOW %RELEASE-STACK-DATUM PRINT-BACKTRACE)) (IL:COMS (IL:COMMANDS "STOP" "^" "RETURN" "PR" "PR!" "PROCEED" "OK") (IL:FUNCTIONS EXIT-DEBUGGER) (IL:FUNCTIONS INVOKE-ESCAPE-FROM-MENU ESCAPE-FROM-DEBUGGER MENU-FROM-ESCAPE-LIST KEYLIST-FROM-ESCAPE-LIST COLLECT-ACTIVE-ESCAPES)) (IL:COMS (IL:FUNCTIONS IL:FIND-LEXICAL-ENVIRONMENT) (IL:FNS IL:FIND-STACK-FRAME)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) XCL:DEBUGGER) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA IL:WBREAK))))) (DEFVAR IL:*DEBUGGER-MENU* NIL "Menu for debugger windows") (IL:ADDTOVAR IL:CACHEDMENUS IL:*DEBUGGER-MENU*) (IL:ADDTOVAR IL:FONTVARS (IL:BACKTRACEFONT IL:TINYFONT T)) (DEFVAR XCL:*DEBUGGER-PROMPT* "(debug)" "Prompt used by debugger") (DEFVAR *IN-THE-DEBUGGER* NIL (IL:* IL:|;;;| "globally NIL, rebound in the debugger. Used to prevent stack overflow when there's a bug in the debugger. Values are NIL (not in the debugger), T (in the debugger), and :READ (reading user input in the debugger).") ) (DEFPARAMETER XCL:*DEBUGGER-ENTRY-POINTS* '(IL:|\\interpret-BREAK1| ERROR CERROR XCL:DEBUG CONDITIONS:INVOKE-DEBUGGER BREAK IL:ERRORX IL:*CATCH* IL:CHECK-TYPE-FAIL SI::*UNWIND-PROTECT* IL:\\LISPERROR)) (DEFVAR IL:BRKEXP) (DEFVAR IL:BRKTYPE) (DEFVAR IL:BRKCOND) (DEFVAR IL:BRKPOS) (DEFUN XCL:ENTER-DEBUGGER-P (IL:N IL:POS XCL:CONDITION) (COND ((TYPEP XCL:CONDITION 'XCL:STORAGE-CONDITION) T) ((NULL IL:HELPFLAG) NIL) ((EQ IL:HELPFLAG 'IL:BREAK!) T) ((DO ((IL:POS (IL:STKNTH -1 IL:POS) (IL:* IL:\; " start at argument") (IL:STKNTH -1 IL:POS IL:POS))) (IL:* IL:\;  " and go back one at a time") ((NULL IL:POS) (IL:* IL:\;  " hit the top of the stack") NIL) (AND IL:N (DECF IL:N)) (WHEN (EQ (IL:STKNAME IL:POS) 'IL:ERRORSET) (CASE (AND (IL:IGEQ (IL:STKNARGS IL:POS) 2) (IL:STKARG 2 IL:POS)) ((NIL) (IL:* IL:\; " NLSETQ case") (IL:SETQ IL:PRINTMSG (NULL IL:NLSETQGAG)) (IL:RELSTK IL:POS) (RETURN NIL)) (IL:INTERNAL (IL:* IL:\; "ignore this one")) (IL:NOBREAK (IL:SETQ IL:PRINTMSG NIL) (IL:RELSTK IL:POS) (RETURN NIL)) (T (IL:SETQ IL:PRINTMSG T) (IL:RELSTK IL:POS) (RETURN (AND IL:N (< IL:N 0)))))))) ((OR (EQ IL:HELPFLAG 'IL:BREAK!) (AND (IL:FIXP IL:HELPCLOCK) (IL:FIXP IL:HELPTIME) (IL:IGREATERP (IL:IDIFFERENCE (IL:CLOCK 2) IL:HELPCLOCK) IL:HELPTIME))) T) (T NIL))) (DEFUN XCL:DEBUGGER (&KEY ((:FORM IL:BRKEXP)) (IL:* IL:\; "form to evaluate at EVAL") ((:ENVIRONMENT IL:BRKENV) (IL:FIND-LEXICAL-ENVIRONMENT (IL:STKNTH -1))) (IL:* IL:\;  "Interpreter lexical environment in which to evalate it. ") ((:CONDITION IL:BRKCOND)) (IL:* IL:\;  "condition which caused this debugger entry") ((:STACK-POSITION IL:BRKPOS)) (IL:* IL:\;  "location to start debugging, if not given will default. @ will always reset") ((:AT IL:BRKFN) NIL XCL::BRKFUN-PROVIDED) (IL:* IL:\; "where's the breakpoint?") ) (DECLARE (SPECIAL IL:WBREAK IL:AUTOBACKTRACEFLG IL:BRKEXP IL:BRKCOND IL:BRKENV IL:BRKPOS IL:BRKFN)) (IL:* IL:|;;| "main entry to the debugger. BRKEXP, BRKFN, BRKTYPE are compatible with Interlisp's BREAK1 argument. BRKCOND is the \"condition\" from the error system, while BRKENV is the lexical environment of the break. ") (LET ((XCL::WAS-IN-THE-DEBUGGER *IN-THE-DEBUGGER*) (*IN-THE-DEBUGGER* T) (IL:* IL:\;  "detect calls to debugger in critical sections.") (IL:* IL:|;;| " rebind variables which are possibly reset by redoing the window") (IL:\\LINEBUF.OFD IL:\\LINEBUF.OFD) (IL:\\TERM.OFD IL:\\TERM.OFD) (*STANDARD-INPUT* *STANDARD-INPUT*) (*STANDARD-OUTPUT* *STANDARD-OUTPUT*) (IL:\\INBQUOTE NIL) (IL:\\#DISPLAYLINES IL:\\#DISPLAYLINES) (IL:\\CURRENTDISPLAYLINE 0) (IL:* IL:\;  "to get around problem that pagehiehgt isn't per-stream") (IL:\\PRIMTERMTABLE IL:\\PRIMTERMTABLE) (IL:\\PRIMTERMSA IL:\\PRIMTERMSA) (IL:\\INTERRUPTABLE T) XCL::DEBUGGER-WINDOW (IL:* IL:\; "window for this break") (IL:LASTPOS) (IL:!VALUE IL:*NOT-YET-EVALUATED*) IL:BRKVALUES *EVALHOOK* (IL:* IL:\;  "because some of the reporting stuff can be interpreted") *APPLYHOOK* (IL:* IL:\; "likewise") ) (DECLARE (SPECIAL IL:\\#DISPLAYLINES IL:\\CURRENTDISPLAYLINE IL:\\INTERRUPTABLE IL:\\INBQUOTE IL:LASTPOS IL:\\LINEBUF.OFD IL:\\TERM.OFD *STANDARD-INPUT* *STANDARD-OUTPUT* IL:BRKVALUES IL:!VALUE IL:\\PRIMTERMTABLE IL:\\PRIMTERMSA)) (WHEN (EQ XCL::WAS-IN-THE-DEBUGGER T) (EMERGENCY-PANIC-LOOP)) (IL:OUTPUT T) (IL:INPUT T) (IL:SETTERMTABLE *DEBUGGER-TERMINAL-TABLE*) (IL:RESETLST (IL:|if| IL:BRKPOS IL:|then| (IL:SETQ IL:LASTPOS (IL:STKNTH 0 IL:BRKPOS)) IL:|else| (IL:SETQ IL:BRKPOS (IL:STKNTH 0 (IL:SETQ IL:LASTPOS (  IL:FIND-DEBUGGER-ENTRY-FRAME )))) (IL:RESETSAVE NIL (LIST 'IL:RELSTK IL:BRKPOS))) (IL:RESETSAVE NIL (LIST 'IL:RELSTK IL:LASTPOS)) (COND ((AND IL:WBREAK (IL:IMAGESTREAMP IL:\\TERM.OFD) (TYPEP IL:BRKCOND 'XCL::CRITICAL-STORAGE-CONDITION)) (REUSE-CURRENT-WINDOW)) ((AND IL:WBREAK (IL:IMAGESTREAMP IL:\\TERM.OFD)) (SETF XCL::DEBUGGER-WINDOW (CREATE-DEBUGGER-WINDOW)) (IL:RESETSAVE NIL (LIST 'RELEASE-DEBUGGER-WINDOW XCL::DEBUGGER-WINDOW)) (SET-UP-DEBUGGER-WINDOW XCL::DEBUGGER-WINDOW))) (IL:* IL:|;;| "clear typin buffer on errors") (WHEN (TYPEP IL:BRKCOND 'ERROR) (IL:CLEARBUF T)) (IL:* IL:|;;| " on a revert, fix up the stack") (WHEN (TYPEP IL:BRKCOND 'SI::REVERT) (AND (IL:LISTP (IL:STKNAME IL:LASTPOS)) (IL:LITATOM (SI::REVERT-FUNCTION IL:BRKCOND)) (IL:SETSTKNAME IL:LASTPOS (SI::REVERT-FUNCTION IL:BRKCOND)))) (IL:* IL:|;;| "Show where we are...") (COND (XCL::BRKFUN-PROVIDED (FORMAT T "In ~S:~&" IL:BRKFN)) ((TYPEP IL:BRKCOND 'SI::BREAKPOINT) (SETF IL:BRKFN (SI::BREAKPOINT-FUNCTION IL:BRKCOND)))) (PRINT-ENTRY-MESSAGE) (IL:* IL:|;;| "Automatically backtrace, if necessary") (AND XCL::DEBUGGER-WINDOW (CASE IL:AUTOBACKTRACEFLG ((IL:ALWAYS! IL:ALWAYS) T) ((NIL) NIL) (OTHERWISE (IL:* IL:|;;| " only backtrace on errors") (TYPEP IL:BRKCOND 'ERROR))) (ATTACH-BACKTRACE-MENU NIL (NOT (IL:FMEMB IL:AUTOBACKTRACEFLG '(IL:BT! IL:ALWAYS!))))) (IL:* IL:|;;| "Finally, the main debugger loop. This is simply an inferior exec with the appropriate command tables and eval function.") (CATCH 'DEBUGGER-EXIT (LET ((*READ-SUPPRESS* NIL) (*IN-THE-DEBUGGER* :READ)) (XCL:EXEC :TITLE NIL :COMMAND-TABLES (LIST IL:*DEBUGGER-COMMAND-TABLE* IL:*EXEC-COMMAND-TABLE*) :ENVIRONMENT IL:BRKENV :PROMPT XCL:*DEBUGGER-PROMPT* :FUNCTION #'(LAMBDA (XCL::INPUT XCL::ENV) (LET ((*IN-THE-DEBUGGER* NIL)) (IL:EVAL-INPUT XCL::INPUT XCL::ENV))))))) (IL:* IL:|;;| "Now, determine the appropriate error action: ") (ECASE (CAR IL:BRKVALUES) ((NIL) (VALUES)) ((T) (VALUES-LIST (CDR IL:BRKVALUES))) ((IL:ERROR!) (IL:ERROR!)) ((RETURN) (IL:* IL:|;;| "see RETURN command") (IL:RETAPPLY (THIRD IL:BRKVALUES) 'VALUES-LIST (LIST (SECOND IL:BRKVALUES)) T)) ((:REVERT) (IL:* IL:|;;| "see REVERT command") (IL:RETAPPLY (THIRD IL:BRKVALUES) (FOURTH IL:BRKVALUES) (SECOND IL:BRKVALUES) T))))) (DEFUN EMERGENCY-PANIC-LOOP () (IL:PRIN1 "Call to debugger while in the debugger, entering read-eval-print-loop" T) (IL:TERPRI T) (LET ((*READ-SUPPRESS* NIL) (*IN-THE-DEBUGGER* NIL)) (LOOP (IL:PRIN1 "eval:" T) (IL:PRINT (IL:EVAL (IL:READ T T)) T)))) (DEFUN IL:FIND-DEBUGGER-ENTRY-FRAME (&OPTIONAL (IL:POS 'XCL:DEBUGGER) IL:SKIP-FAKE?) (IL:* IL:|;;| " return initial value of LASTPOS for backtrace; called when entering the debugger and by @ command. ") (IL:BIND IL:NAME IL:INBRK IL:DO (IL:SETQ IL:POS (IL:IF IL:SKIP-FAKE? IL:THEN (IL:REALSTKNTH -1 IL:POS NIL IL:POS) (IL:* IL:\;  "this will ignore the ones that aren't REALFRAMEP") IL:ELSE (IL:STKNTH -1 IL:POS IL:POS) )) IL:REPEATWHILE (OR (IL:FMEMB (IL:SETQ IL:NAME (IL:STKNAME IL:POS)) XCL:*DEBUGGER-ENTRY-POINTS*) (IL:GENSYM? IL:NAME) (AND IL:INBRK (IL:FMEMB IL:NAME '(EVAL IL:EVAL-PROGN))) (IL:SETQ IL:INBRK (EQ IL:NAME (SPECIAL-FORM-P 'IL:BREAK1)))) (IL:* IL:|;;| "this will ignore the things that are generated subfunctions or internal debugger functions, e.g. ERRORX or CL:ERROR etc.") IL:|finally| (RETURN IL:POS))) (DEFUN PRINT-ENTRY-MESSAGE () (OR (IL:NLSETQ (PRINC IL:BRKCOND)) (IL:* IL:\;  "should this go to *ERROR-OUTPUT* or *DEBUG-IO* instead?") (IL:* IL:|;;| "Do something simple if printing the condition breaks...") (PROGN (PRINC "") (TERPRI) (PRINC "(problems trying to report it!)")))) (DEFUN SIMPLE-REPORT-CONDITION (XCL:CONDITION STREAM) (IL:* IL:|;;| "produce a short description of the condition, e.g. the condition-type ") (PRINC (TYPECASE XCL:CONDITION (XCL:SIMPLE-CONDITION XCL:CONDITION) (T (TYPE-OF XCL:CONDITION))) STREAM)) (DEFUN XCL::INTERESTING-FRAME-P (&OPTIONAL XCL::POS XCL::INTERPFLG) (IL:* IL:|;;| "Value is T if frame should be visible for backtrace, and error retry") (IL:* IL:|;;| "user did write a call to the function at POS, and either INTERPFLG is T, or else the functio call would also exist if compiled") (LET ((XCL::NAME (IF (IL:STACKP XCL::POS) (IL:STKNAME XCL::POS) XCL::POS))) (AND (SYMBOLP XCL::NAME) (CASE XCL::NAME (IL:*ENV* (IL:* IL:\;  "*ENV* is used by ENVEVAL etc.") NIL) (IL:ERRORSET (OR (<= (IL:STKNARGS XCL::POS) 1) (IL:NEQ (IL:STKARG 2 XCL::POS NIL) 'IL:INTERNAL))) (IL:EVAL (OR (<= (IL:STKNARGS XCL::POS) 1) (IL:NEQ (IL:STKARG 2 XCL::POS NIL) 'XCL::INTERNAL))) (IL:APPLY (OR (<= (IL:STKNARGS XCL::POS) 2) (NOT (IL:STKARG 3 XCL::POS NIL)))) (OTHERWISE (OR (NOT (SYMBOLP XCL::NAME)) (COND ((IL:FMEMB XCL::NAME IL:OPENFNS) XCL::INTERPFLG) (T (OR (IL:NEQ (IL:CHCON1 XCL::NAME) (IL:CHARCODE IL:\\)) (IL:EXPRP XCL::NAME)))))))))) (IL:RPAQ? IL:WBREAK ) (DEFPARAMETER XCL:*DEBUGGER-MENU-ITEMS* '("EVAL" "EDIT" "REVERT" "^" "PROCEED" "OK" "BT" "BT!" "?=") "Elements of debugger menu") (DEFVAR *DEBUGGER-TERMINAL-TABLE* (IL:COPYTERMTABLE NIL) "Terminal table for use in debugger") (XCL:DEFGLOBALVAR IL:BREAKREGIONSPEC (IL:|create| IL:REGION IL:LEFT IL:_ 17 IL:BOTTOM IL:_ -120 IL:WIDTH IL:_ 400 IL:HEIGHT IL:_ 120)) (IL:DEFINEQ (il:wbreak (lambda (&optional (il:on t il:onp)) (il:* il:\; "start and stop creating window debugging") (prog1 il:wbreak (and il:onp (il:setq il:wbreak il:on))))) ) (IL:ADDTOVAR IL:WINDOWUSERFORMS (IL:WBREAK T)) (IL:ADDTOVAR IL:ENDOFWINDOWUSERFORMS (IL:WBREAK NIL)) (DEFUN REUSE-CURRENT-WINDOW () (IL:* IL:|;;| "would want to create new window but won't because of storage error") (IL:PRINTOUT IL:PROMPTWINDOW T "Ran out of space " "running in process '" (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) "' ") (UNLESS (IL:HASTTYWINDOWP) (IL:* IL:|;;| " if this process doesn't have a tty then it is a background process that ran out of array space. Switch its tty to the PROMPT window because it should not have a process associated with it yet.") (IL:WINDOWPROP IL:PROMPTWINDOW 'IL:PAGEFULLFN NIL) (IL:* IL:|;;| " clobber PAGEFULLFN so that when user does BT it doesn't just scroll off screen. This changes PROMPTWINDOW but with arrays full they shouldn't be in this sysout long anyway.") (IL:PRINTOUT IL:PROMPTWINDOW "which does not have a TTY window." "Using PROMPTWINDOW as TTY window." T) (IL:TTYDISPLAYSTREAM IL:PROMPTWINDOW))) (DEFUN CREATE-DEBUGGER-WINDOW () (DECLARE (SPECIAL IL:\\TERM.OFD IL:DEFAULTTTYREGION)) (IL:CREATEW (IF (IL:HASTTYWINDOWP) (NEAR-BY-REGION (IL:WINDOWPROP (IL:WFROMDS (LET ((IL:POS (IL:STKPOS 'XCL:EXEC NIL 'XCL:DEBUGGER))) (IL:IF IL:POS IL:THEN (PROG1 (IL:EVALV 'IL:\\TERM.OFD IL:POS) (IL:RELSTK IL:POS)) IL:ELSE IL:\\TERM.OFD))) 'IL:REGION) (OR (IL:REGIONP IL:BREAKREGIONSPEC) (IL:CREATEREGION 17 -120 400 120))) (IL:* IL:|;;|  "\"in the case of break in a process that doesn't have a real tty yet. create one\"") IL:DEFAULTTTYREGION) "Debugger Window")) (DEFUN SET-UP-DEBUGGER-WINDOW (W) (IL:WINDOWPROP W 'STACK-POSITION IL:BRKPOS) (IL:WINDOWPROP W 'LASTPOS IL:LASTPOS) (IL:WINDOWPROP W 'IL:TITLE (IL:* IL:\;  " this is the wrong title, it doesn't show enough") (XCL:CONDITION-CASE (WITH-OUTPUT-TO-STRING (S) (SIMPLE-REPORT-CONDITION IL:BRKCOND S)) (IL:* IL:|;;| "Do something simple if SIMPLE-REPORT-CONDITION breaks...") (ERROR NIL (STRING (TYPE-OF IL:BRKCOND))))) (IL:WINDOWPROP W 'IL:BUTTONEVENTFN 'DEBUGGER-BUTTON-EVENT) (IL:WINDOWADDPROP W 'IL:CLOSEFN 'CLOSE-DEBUGGER-WINDOW) (IL:WINDOWPROP W 'PROCESS (IL:THIS.PROCESS)) (IL:TTYDISPLAYSTREAM W) (IL:* IL:|;;| "presumably *DEBUG-IO* points at something that points at the TTYDISPLAYSTREAM so that this affects where *DEBUG-IO* goes") ) (DEFUN CLOSE-DEBUGGER-WINDOW (W) (LET ((PROCESS (IL:WINDOWPROP W 'PROCESS) (IL:* IL:\; "get window's process ") )) (IL:\\CARET.DOWN) (COND ((AND (IL:PROCESSP PROCESS) (EQ W (IL:WFROMDS (IL:PROCESS.TTY PROCESS)))) (COND ((EQ PROCESS (IL:THIS.PROCESS)) (IL:* IL:\;  "if this is the process, just make sure that the caret is down ") (IL:WINDOWPROP W 'IL:PROCESS NIL) (EXIT-DEBUGGER)) ((IL:PROCESS.EVALV PROCESS '*IN-THE-DEBUGGER*)(IL:* IL:\; "if the process associated with this window has its tty as this window and is tty waiting, flush it.") (IL:WINDOWPROP W 'IL:PROCESS NIL) (IL:PROCESS.APPLY PROCESS 'EXIT-DEBUGGER NIL NIL) (IL:BLOCK))) (IL:* IL:|;;| "otherwise, don't bother, just let the window close") )))) (DEFUN RELEASE-DEBUGGER-WINDOW (W) (COND ((IL:WINDOWP W) (IL:RELSTK (IL:WINDOWPROP W 'LASTPOS NIL)) (IL:WINDOWPROP W 'PROCESS NIL) (IL:WINDOWPROP W 'IL:BUTTONEVENTFN 'IL:TOTOPW) (IL:\\CARET.DOWN) (IL:* IL:\; " just in case the caret is in the debugger window, this makes sure it goes away before closing the window. ") (IL:WINDOWDELPROP W 'IL:CLOSEFN 'CLOSE-DEBUGGER-WINDOW) (IL:CLOSEW W)))) (DEFUN NEAR-BY-REGION (REGION REGIONTEMPLATE) (LET ((WIDTH (IL:|fetch| (IL:REGION IL:WIDTH) IL:|of| REGIONTEMPLATE)) (HEIGHT (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| REGIONTEMPLATE))) (IL:|create| IL:REGION IL:LEFT IL:_ (MOD (+ (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| REGION) (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| REGIONTEMPLATE)) (- IL:\\CURSORDESTWIDTH WIDTH)) IL:BOTTOM IL:_ (MOD (+ (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| REGION) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| REGIONTEMPLATE)) (- IL:\\CURSORDESTHEIGHT HEIGHT)) IL:WIDTH IL:_ WIDTH IL:HEIGHT IL:_ HEIGHT))) (DEFUN DEBUGGER-BUTTON-EVENT (W &REST IGNORE &AUX SELECTION) (IL:* IL:\;  " button event function for debugger windows") (OR IL:*DEBUGGER-MENU* (IL:* IL:\; "create on demand") (SETF IL:*DEBUGGER-MENU* (IL:|create| IL:MENU IL:ITEMS IL:_ XCL:*DEBUGGER-MENU-ITEMS* IL:WHENHELDFN IL:_ 'DEBUGGER-MENU-HELP))) (IL:|if| (IL:LASTMOUSESTATE IL:MIDDLE) IL:|then| (IL:CASE-EQUALP (IL:SETQ SELECTION (IL:MENU IL:*DEBUGGER-MENU*)) (NIL) ("PROCEED" (INVOKE-ESCAPE-FROM-MENU)) ("BT" (ATTACH-BACKTRACE-MENU W T)) ("BT!" (ATTACH-BACKTRACE-MENU W NIL)) (T (IL:CLEARBUF T) (IL:BKSYSBUF SELECTION) (IL:BKSYSCHARCODE (IL:CHARCODE IL:CR)))))) (DEFUN DEBUGGER-MENU-HELP (COMMAND &REST IGNORE) (IL:* IL:\;  "whenheld function for debugger menu. Get doc from documentation system") (IL:PRINTOUT IL:PROMPTWINDOW T (IL:IF (IL:LISTP COMMAND) IL:THEN (OR (THIRD COMMAND) (DOCUMENTATION (FIRST COMMAND) 'IL:COMMANDS) (FOURTH (IL:GETHASH (FIRST COMMAND) IL:*DEBUGGER-COMMAND-TABLE*))) IL:ELSE (OR (DOCUMENTATION COMMAND 'IL:COMMANDS) (FOURTH (IL:GETHASH COMMAND IL:*DEBUGGER-COMMAND-TABLE*)))))) (DEFVAR IL:LASTPOS) (XCL:DEFCOMMAND ("@" :DEBUGGER) (&REST IL:PLACE &ENVIRONMENT IL:ENV) "Set debugger stack pointer to location specified by PLACE (or default)" (FORMAT T "@ = ~S~%" (IL:STKNAME (FIND-DEBUGGER-STACK-FRAME IL:PLACE IL:ENV))) (VALUES)) (XCL:DEFCOMMAND ("REVERT" :DEBUGGER) (&REST IL:PLACE &ENVIRONMENT IL:ENV) (DECLARE (SPECIAL IL:BRKVALUES) ) "Unwind to specified frame (or LASTPOS) and enter breakpoint" (IL:* IL:|;;| "Find the stack frame that the user asked to unwind to , if any:") (AND IL:PLACE (FIND-DEBUGGER-STACK-FRAME IL:PLACE IL:ENV)) (IL:* IL:|;;| "LASTPOS is now set to the REVERT target.") (LET ((IL:FN (IL:STKNAME IL:LASTPOS))) (WRITE IL:FN :STREAM *DEBUG-IO* :RADIX 10 :BASE 10 :ESCAPE T :CIRCLE NIL :PRETTY NIL :LEVEL 3 :LENGTH 3) (IL:* IL:|;;| "There's still an odd problem because the frame created by the cl:lambda application has one too many arguments... somehow STKNARGS returns 2 when called with a &rest???") (SETF IL:BRKVALUES (LIST ':REVERT (IL:STKARGS IL:LASTPOS) (IL:STKNTH 0 IL:LASTPOS) `(IL:LAMBDA IL:NOBIND (LET ((IL:POS ',(IL:STKNTH 0 IL:LASTPOS))) (FUNCALL #'(LAMBDA NIL (UNWIND-PROTECT (XCL:DEBUGGER :FORM '(APPLY ',IL:FN (IL:STKARGS ',IL:FN)) :CONDITION (XCL:MAKE-CONDITION 'SI::REVERT :FUNCTION ',IL:FN) :STACK-POSITION IL:POS) (IL:RELSTK IL:POS)))))))) (THROW 'DEBUGGER-EXIT NIL))) (XCL:DEFCOMMAND ("?=" :DEBUGGER) NIL "Show arguments" (MULTIPLE-VALUE-BIND (IL:NAME IL:DEFN) (FIND-ORIGINAL-NAME-AND-DEFINITION IL:LASTPOS) (MULTIPLE-VALUE-BIND (IL:LAMBDA-CAR IL:ARGLIST) (SI::NAMED-FUNCTION-WRAPPER-INFO IL:NAME IL:DEFN NIL) (LET ((*PRINT-LENGTH* 3) (*PRINT-LEVEL* 3) (IL:ARGUMENTS (IL:STKARGS IL:LASTPOS))) (ECASE IL:LAMBDA-CAR ((IL:LAMBDA IL:NLAMBDA) (COND ((LISTP IL:ARGLIST) (IL:FOR IL:NAME IL:IN IL:ARGLIST IL:AS IL:VALUE IL:IN IL:ARGUMENTS IL:DO (FORMAT T " ~a = ~s~%" IL:NAME IL:VALUE))) ((OR (EQ IL:LAMBDA-CAR 'IL:LAMBDA) (LISTP IL:ARGUMENTS)) (IL:FOR IL:VALUE IL:IN IL:ARGUMENTS IL:AS IL:ARGNUM IL:FROM 0 IL:DO (FORMAT T " Arg ~d = ~s~%" IL:ARGNUM IL:VALUE))) (T (FORMAT T " ~a = ~s~%" IL:ARGLIST IL:ARGUMENTS)))) ((LAMBDA) (MULTIPLE-VALUE-CALL 'SI::PRINT-TRACED-CL-ARGLIST IL:ARGUMENTS (SI::PARSE-CL-ARGLIST IL:ARGLIST) 0 T)))))) (VALUES)) (XCL:DEFCOMMAND ("EVAL" :DEBUGGER) (&OPTIONAL (IL:EXPRESSION NIL IL:EXPRESSION-PROVIDED?)) (DECLARE (SPECIAL IL:BRKENV IL:BRKVALUES)) "Evaluate expression in debugged context" (XCL:CONDITION-CASE (IF IL:EXPRESSION-PROVIDED? (DEBUGGER-EVAL IL:EXPRESSION IL:BRKENV) (VALUES-LIST (CDR (SETF IL:BRKVALUES (CONS T (MULTIPLE-VALUE-LIST (DEBUGGER-EVAL IL:BRKEXP IL:BRKENV))))))) (SI::DEBUGGER-EVAL-ABORTED (IL:C) (VALUES :ABORTED (SI::DEBUGGER-EVAL-ABORTED-CONDITION IL:C))))) (XCL:DEFCOMMAND ("VALUE" :DEBUGGER :QUIET) NIL "Show value from previous evaluation of debug expression" (IF IL:BRKVALUES (VALUES-LIST (CDR IL:BRKVALUES)) (PROGN (FORMAT T "Not yet evaluated~&") (VALUES)))) (XCL:DEFCOMMAND ("UB" :DEBUGGER) (&OPTIONAL (IL:FN IL:BRKFN)) "Unbreak function with breakpoint" (DECLARE (SPECIAL IL:BRKFN)) (IL:EVAL (LIST 'XCL:UNBREAK IL:FN))) (DEFUN DEBUGGER-EVAL (EXP ENV) (IL:* IL:|;;| "evaluate exp in the context that called the debugger.") (LET* ((ABORT-CONDITION NIL) (ABORTED NIL) (VALUES (MULTIPLE-VALUE-LIST (IL:ENVAPPLY #'(LAMBDA (EVAL-FN EXP ENV) (XCL:PROCEED-CASE (FUNCALL EVAL-FN EXP ENV) (XCL:ABORT (CONDITION) :REPORT "Return to previous debugger" (SETF ABORTED T ABORT-CONDITION CONDITION) (VALUES NIL CONDITION)))) (LIST (COND (ENV (IL:* IL:\;  "If there's a lexical environment around, we need to use CL:eval to watch for it.") 'EVAL) (T XCL:*EVAL-FUNCTION*)) EXP ENV) (IL:STKNTH -1 'XCL:DEBUGGER) NIL T)))) (WHEN ABORTED (XCL:SIGNAL 'SI::DEBUGGER-EVAL-ABORTED :CONDITION ABORT-CONDITION)) (VALUES-LIST VALUES))) (DEFUN FIND-DEBUGGER-STACK-FRAME (PLACE ENV) (IL:* IL:|;;| "Find stack position denoted by place") (IL:* IL:|;;| "Freely sets LASTPOS to the stack pointer corresponding to PLACE.") (DECLARE (SPECIAL IL:LASTPOS)) (IL:|bind| (LSTPOS IL:_ (IL:FIND-DEBUGGER-ENTRY-FRAME)) IL:|while| PLACE IL:|do| (IL:CASE-EQUALP (FIRST PLACE) (IL:@ (IL:* IL:\;  "@ @ foo means leave LASTPOS alone") (SETF LSTPOS (IL:STKNTH 0 IL:LASTPOS LSTPOS)) (POP PLACE)) (= (IL:* IL:\;  "@ = FOO means to evaluate FOO") (SETF LSTPOS (IL:STKNTH 0 (EVAL (SECOND PLACE) ENV)) PLACE (CDDR PLACE))) (T (IL:IF (INTEGERP (FIRST PLACE)) IL:THEN (IF (MINUSP (FIRST PLACE)) (SETF LSTPOS (IL:STKNTH (FIRST PLACE) LSTPOS LSTPOS)) (PROG ((N (FIRST PLACE)) (POS1 (IL:STKNTH -1 'XCL:DEBUGGER))) (IL:* IL:|;;| "Returns the stack position N below LSTPOS by starting at current position and backing up the control links until it reaches a point N frames before POS.") LP (COND ((IL:EQP POS1 LSTPOS) (IL:RELSTK POS1) (RETURN NIL)) ((> N 0) (DECF N) (SETF POS1 (IL:STKNTH -1 POS1 POS1)) (GO LP))) (SETF LSTPOS (IL:STKNTH -1 'IL:DEBUGGER-LOOP)) LP1 (IL:* IL:\;  "POS1 stays N ahead of POS2. When POS1 reaches END, LSTPOS is the desired position.") (COND ((NULL POS1) (IL:RELSTK LSTPOS) (RETURN NIL)) ((IL:EQP POS1 LSTPOS) (IL:RELSTK POS1) (RETURN LSTPOS))) (SETF POS1 (IL:STKNTH -1 POS1 POS1) LSTPOS (IL:STKNTH -1 LSTPOS LSTPOS)) (GO LP1))) (POP PLACE) IL:ELSE (SETF LSTPOS (FIND-NAMED-STACK-POSITION (FIRST PLACE) NIL (IL:STKNTH -1 LSTPOS LSTPOS))) (POP PLACE)))) IL:|finally| (OR LSTPOS (IL:ERROR "not found") ) (IL:STKNTH 0 LSTPOS IL:LASTPOS) (IL:* IL:|;;| "smashes LSTPOS into the LASTPOS stack pointer, cannot just reset lastpos to lstpos because of RELSTK etc") (IL:RELSTK LSTPOS) (RETURN IL:LASTPOS))) (DEFUN FIND-NAMED-STACK-POSITION (FN N LSTPOS &AUX TEM) (COND ((SETF TEM (IL:STKPOS FN N LSTPOS)) (IL:RELSTK LSTPOS) TEM) ((AND IL:DWIMFLG (IL:NEQ IL:NOSPELLFLG T) (XCL:DESTRUCTURING-BIND (IGNORE NCXWORD NDBLS &REST LST) (IL:EDITFPAT (IL:CONCAT FN "")) (DECLARE (IGNORE IGNORE)) (SETF TEM (IL:SEARCHPDL #'(LAMBDA (FN) (IL:SKOR0 FN NCXWORD NDBLS LST)) LSTPOS)))) (IL:PRIN1 '= T) (IL:PRINT (FIRST TEM) T) (IL:RELSTK LSTPOS) (CDR TEM)) (T (IL:RELSTK LSTPOS) (IL:ERROR FN '"not found" T)))) (DEFUN FIND-ORIGINAL-NAME-AND-DEFINITION (STKPTR) (LET ((NAME (IL:STKNAME STKPTR))) (COND ((SYMBOLP NAME) (VALUES NAME (STKPTR-CCODE STKPTR))) ((OR (ATOM NAME) (NOT (MEMBER (CAR NAME) '(:BROKEN :ADVISED :TRACED)))) (VALUES NIL (STKPTR-CCODE STKPTR))) (T (LET ((SYMBOL (FIRST (IL:MKLIST (SECOND NAME))))) (VALUES SYMBOL (IL:GETD (OR (GET SYMBOL 'IL:ADVISED) (GET SYMBOL 'IL:BROKEN) SYMBOL)))))))) (DEFUN STKPTR-CCODE (STKPTR) (IL:MAKE-COMPILED-CLOSURE (IL:FETCH (IL:FX IL:FNHEADER) IL:OF (IL:\\STACKARGPTR STKPTR)))) (IL:RPAQ? IL:AUTOBACKTRACEFLG ) (IL:RPAQQ IL:BAKTRACELST ((IL:APPLY (IL:**BREAK** IL:LISPX IL:ERRORSET IL:BREAK1A IL:ERRORSET IL:BREAK1) (IL:**TOP** IL:LISPX IL:ERRORSET IL:EVALQT T) (IL:**EDITOR** IL:LISPX IL:ERRORSET IL:ERRORSET IL:ERRORSET IL:EDITL1 IL:EDITL0 IL:ERRORSET ((IL:ERRORSET IL:ERRORSET IL:ERRORSET IL:EDITL1 IL:EDITL0 IL:ERRORSET) -) IL:EDITL IL:ERRORSET IL:ERRORSET IL:EDITE ((IL:EDITF) (IL:EDITV) (IL:EDITP) -)) (IL:**USEREXEC** IL:LISPX IL:ERRORSET IL:ERRORSET IL:USEREXEC)) (IL:EVAL (IL:**BREAK** IL:LISPX IL:ERRORSET IL:BREAK1A IL:ERRORSET IL:BREAK1) (IL:**TOP** IL:LISPX IL:ERRORSET IL:EVALQT T) (IL:**EDITOR** ((IL:MAPCAR IL:APPLY) (IL:ERRORSET IL:LISPX)) IL:ERRORSET IL:ERRORSET IL:ERRORSET IL:EDITL1 IL:EDITL0 IL:ERRORSET ((IL:ERRORSET IL:ERRORSET IL:ERRORSET IL:EDITL1 IL:EDITL0 IL:ERRORSET) -) IL:EDITL IL:ERRORSET IL:ERRORSET IL:EDITE ((IL:EDITF) (IL:EDITV) (IL:EDITP) -)) (IL:**USEREXEC** IL:ERRORSET IL:LISPX IL:ERRORSET IL:ERRORSET IL:USEREXEC)) (PROGN IL:**BREAK** IL:EVAL ((IL:ERRORSET IL:BREAK1A IL:ERRORSET IL:BREAK1) (IL:BREAK1))) (IL:BLKAPPLY IL:**BREAK** PROGN IL:EVAL IL:ERRORSET IL:BREAK1A IL:ERRORSET IL:BREAK1) (IL:*PROG*LAM (NIL IL:EVALA IL:*ENV*) (NIL IL:CLISPBREAK1)))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:RPAQ? IL:AUTOBACKTRACEFLG NIL) (IL:RPAQ? IL:BACKTRACEFONT ) ) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:EVAL@COMPILE (IL:RECORD IL:BKMENUITEM (IL:LABEL IL:BKMENUINFO)) ) ) (DEFVAR IL:*SHORT-BACKTRACE-FILTER* 'XCL::INTERESTING-FRAME-P "Used to determine what BT sees, applied to each stack frame") (DEFPARAMETER IL:|MaxBkMenuWidth| 125) (IL:DEFINEQ (il:baktrace (il:lambda (il:ipos il:epos il:skipfns il:flags il:file) (il:* il:\; "Edited 2-Jun-87 18:26 by amd") (il:* il:|;;| "FLAGS is a bit mask telling BACKTRACE what is to be printed. 1 is variables, 2 is eval blips, 4 is everything, 8 suppresses function name and 'UNTRACE:' , and 16 uses access links.") (prog ((*print-level* 2) (*print-length* 10) (il:pos (il:stknth 0 il:ipos)) (il:n 0) il:fn il:x il:y il:z (il:plvlfileflg t)) (or il:file (il:setq il:file t)) (and (il:neq il:clearstklst t) (il:setq il:clearstklst (cons il:pos il:clearstklst))) (il:* il:|;;| "POS is used as a scratch-position. N is an offset from FROM. whenever baktrace needs to look at a stkname or stack position, it (re) uses POS and computes (STKNTH N IPOS POS).") il:lp (il:setq il:fn (il:stkname il:pos)) il:lp1 (cond ((and il:skipfns (some #'(lambda (il:skipfn) (funcall il:skipfn il:fn)) il:skipfns))) (t (cond ((il:neq il:flags 0) (il:backtrace (il:setq il:pos (il:stknth il:n il:ipos il:pos)) il:pos (il:logor il:flags 8) il:file 'il:showprint) (il:* il:\; "Tells BACKTRACE not to print 'UNTRACE:' or the function name.") (il:* il:\; "The SETQ would be unnecessary in spaghetti") )) (il:prin2 (il:|if| (eq il:fn 'eval) il:|then| (il:stkarg 1 il:pos) il:|else| il:fn) il:file t) (il:* il:\; "Prints function name.") (il:prin1 il:breakdelimiter il:file))) (cond ((and (il:setq il:pos (il:stknth (il:setq il:n (il:sub1 il:n)) il:ipos il:pos)) (not (il:eqp il:pos il:epos))) (go il:lp))) (il:relstk il:pos) (il:terpri il:file) (return)))) (il:baktrace1 (il:lambda (il:lst il:n il:ipos il:pos) (il:* il:\; "Edited 2-Jun-87 18:28 by amd") (il:* il:|;;| "'MATCHES' LST against stack starting at POS. Returns NIL or offset corresponding to last functionthat matches") (prog (il:tem) il:lp (cond ((null il:lst) (return il:n)) ((null (il:setq il:pos (il:stknth (il:sub1 il:n) il:ipos il:pos))) (go il:out)) ((eq (il:setq il:tem (car il:lst)) (il:stkname il:pos)) (il:* il:|;;| "make this check first if user WANTS to put the name of a dummy frame in baktracelst, he can. e.g. this is necessary in order to have the sequence *PROG*LAM EVALA *ENV* disappear") (il:setq il:n (il:sub1 il:n))) ((il:dummyframep il:pos) (il:setq il:n (il:sub1 il:n)) (go il:lp)) ((eq il:tem 'il:&) (il:setq il:n (il:sub1 il:n))) ((il:nlistp il:tem) (go il:out)) ((null (some #'(lambda (il:x) (cond ((eq il:x '-) (il:* il:\; "Optional match") t) ((il:setq il:x (il:baktrace1 il:x il:n il:ipos il:pos)) (il:setq il:n il:x)))) il:tem)) (go il:out))) (il:setq il:lst (cdr il:lst)) (go il:lp) il:out (return nil)))) ) (XCL:DEFCOMMAND ("BT" :DEBUGGER) NIL "Print backtrace of external frames" (PRINT-BACKTRACE :FROM IL:LASTPOS :TEST 'XCL::INTERESTING-FRAME-P) (VALUES)) (XCL:DEFCOMMAND ("BT!" :DEBUGGER) NIL "Print backtrace of all frames" (PRINT-BACKTRACE :FROM IL:LASTPOS :TEST NIL) (VALUES)) (XCL:DEFCOMMAND ("BTV" :DEBUGGER) NIL "Print backtrace of frames and special bindings" (PRINT-BACKTRACE :FROM IL:LASTPOS :PRINT-VARIABLES T) (VALUES)) (XCL:DEFCOMMAND ("BTV!" :DEBUGGER) NIL "Print backtrace of all frame information" (PRINT-BACKTRACE :FROM IL:LASTPOS :PRINT-VARIABLES T :PRINT-JUNK T) (VALUES)) (XCL:DEFCOMMAND ("DBT" :DEBUGGER) NIL (ATTACH-BACKTRACE-MENU NIL T) (VALUES)) (XCL:DEFCOMMAND ("DBT!" :DEBUGGER) NIL (ATTACH-BACKTRACE-MENU) (VALUES)) (DEFUN ATTACH-BACKTRACE-MENU (&OPTIONAL IL:TTYWINDOW IL:SKIP) (DECLARE (SPECIAL IL:\\TERM.OFD IL:BACKTRACEFONT)) (OR IL:TTYWINDOW (IL:SETQ IL:TTYWINDOW (IL:WFROMDS (IL:TTYDISPLAYSTREAM)))) (PROG ((IL:POS (IL:STKNTH 0 (IL:GETWINDOWPROP IL:TTYWINDOW 'STACK-POSITION))) IL:BTW IL:BKMENU (*PRINT-LEVEL* 2) (IL:* IL:\; "for the FORMAT below") (*PRINT-LENGTH* 3) (*PRINT-ESCAPE* T) (*PRINT-GENSYM* T) (*PRINT-PRETTY* NIL) (*PRINT-CIRCLE* NIL) (*PRINT-RADIX* 10) (*PRINT-ARRAY* NIL) (IL:*PRINT-STRUCTURE* NIL) (IL:TTYREGION (IL:WINDOWPROP IL:TTYWINDOW 'IL:REGION))) (IL:SETQ IL:BKMENU (IL:|create| IL:MENU IL:ITEMS IL:_ (IL:|for| IL:N IL:|from| 0 IL:|bind| IL:NAME IL:|repeatwhile| (IL:SETQ IL:POS (IL:STKNTH -1 IL:POS IL:POS)) IL:|eachtime| (IL:SETQ IL:NAME (IL:STKNAME IL:POS)) IL:|when| (OR (NULL IL:SKIP) (FUNCALL (COND ((EQ IL:SKIP T) IL:*SHORT-BACKTRACE-FILTER*) (T IL:SKIP)) IL:POS)) IL:|collect| (IL:|create| IL:BKMENUITEM IL:LABEL IL:_ (PRIN1-TO-STRING (IL:|if| (EQ IL:NAME 'EVAL) IL:|then| (IL:STKARG 1 IL:POS IL:NAME) IL:|else| IL:NAME)) IL:BKMENUINFO IL:_ IL:N)) IL:WHENSELECTEDFN IL:_ 'BACKTRACE-ITEM-SELECTED IL:MENUOUTLINESIZE IL:_ 0 IL:MENUFONT IL:_ IL:BACKTRACEFONT IL:MENUCOLUMNS IL:_ 1)) (COND ((IL:SETQ IL:BTW (IL:|for| IL:ATW IL:|in| (IL:ATTACHEDWINDOWS IL:TTYWINDOW) IL:|when| (AND (IL:SETQ IL:BTW (IL:WINDOWPROP IL:ATW 'IL:MENU)) (EQ (IL:|fetch| (IL:MENU IL:WHENSELECTEDFN) IL:|of| (CAR IL:BTW)) 'BACKTRACE-ITEM-SELECTED)) IL:|do| (IL:* IL:\;  "test for an attached window that has a backtrace menu in it.") (RETURN IL:ATW))) (IL:* IL:\;  "if there is already a backtrace window, delete the old menu from it.") (IL:DELETEMENU (CAR (IL:WINDOWPROP IL:BTW 'IL:MENU)) NIL IL:BTW) (IL:WINDOWPROP IL:BTW 'IL:EXTENT NIL) (IL:CLEARW IL:BTW)) ((IL:SETQ IL:BTW (IL:CREATEW (REGION-NEXT-TO (IL:WINDOWPROP IL:TTYWINDOW 'IL:REGION) (IL:WIDTHIFWINDOW (IL:IMIN (IL:|fetch| (IL:MENU IL:IMAGEWIDTH) IL:|of| IL:BKMENU) IL:|MaxBkMenuWidth|)) (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| IL:TTYREGION) :LEFT))) (IL:* IL:\;  "put bt window at left of TTY window unless ttywindow is near left edge.") (IL:ATTACHWINDOW IL:BTW IL:TTYWINDOW (IF (IL:IGREATERP (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| (IL:WINDOWPROP IL:BTW 'IL:REGION)) (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| IL:TTYREGION)) 'IL:RIGHT 'IL:LEFT) NIL 'IL:LOCALCLOSE) (IL:WINDOWPROP IL:BTW 'IL:PROCESS (IL:WINDOWPROP IL:TTYWINDOW 'IL:PROCESS)) (IL:* IL:\;  " so that button clicks will switch TTY") )) (IL:ADDMENU IL:BKMENU IL:BTW (IL:|create| IL:POSITION IL:XCOORD IL:_ 0 IL:YCOORD IL:_ (IL:IDIFFERENCE (IL:WINDOWPROP IL:BTW 'IL:HEIGHT) (IL:|fetch| (IL:MENU IL:IMAGEHEIGHT ) IL:|of| IL:BKMENU)))) (IL:* IL:|;;| "IL:ADDMENU sets up buttoneventfn for window that we don't want. We want to catch middle button events before the menu handler, so that we can pop up edit/inspect menu for the frame currently selected. So replace the buttoneventfn, and can nuke the cursorin and cursormoved guys, cause don't need them.") (IL:WINDOWPROP IL:BTW 'IL:BUTTONEVENTFN 'BACKTRACE-MENU-BUTTONEVENTFN) (IL:WINDOWPROP IL:BTW 'IL:CURSORINFN NIL) (IL:WINDOWPROP IL:BTW 'IL:CURSORMOVEDFN NIL))) (DEFUN REGION-NEXT-TO (IL:REGION &OPTIONAL IL:WIDTH IL:HEIGHT IL:WHERE IL:TRIED-ONCE?) (IL:* IL:|;;| "returns the region that is next to REGION and has a width of WIDTH and a height of HEIGHT. WHERE can be :TOP :BOTTOM :LEFT or :RIGHT. If the region would not fit on the screen it is put on the opposite of WHERE.") (PROG ((IL:RLEFT (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| IL:REGION)) (IL:RBOTTOM (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| IL:REGION)) (IL:RWIDTH (IL:|fetch| (IL:REGION IL:WIDTH) IL:|of| IL:REGION)) (IL:RHEIGHT (IL:|fetch| (IL:REGION IL:HEIGHT) IL:|of| IL:REGION)) IL:NLFT IL:NBTM) (OR IL:WIDTH (SETF IL:WIDTH IL:RWIDTH)) (OR IL:HEIGHT (SETF IL:HEIGHT IL:RHEIGHT)) (ECASE IL:WHERE (:TOP (IF (> (+ (SETF IL:NBTM (IL:|fetch| (IL:REGION IL:TOP) IL:|of| IL:REGION)) IL:HEIGHT) IL:\\CURSORDESTHEIGHT) (IF IL:TRIED-ONCE? (IL:* IL:|;;| "top was tried since bottom wouldn't fit") (IL:SETQ IL:NBTM 0) (IL:* IL:|;;| "try :BOTTOM") (RETURN (REGION-NEXT-TO IL:REGION IL:WIDTH IL:HEIGHT :BOTTOM T))) (INCF IL:NBTM)) (SETF IL:NLFT IL:RLEFT)) (:BOTTOM (IF (< (SETF IL:NBTM (- IL:RBOTTOM IL:HEIGHT)) 0) (IF IL:TRIED-ONCE? (IL:* IL:|;;| "doesn't fit either place, put it down from top.") (SETF IL:NBTM (- IL:\\CURSORDESTHEIGHT IL:HEIGHT)) (IL:* IL:|;;| "try :TOP") (RETURN (REGION-NEXT-TO IL:REGION IL:WIDTH IL:HEIGHT :TOP T)))) (SETF IL:NLFT IL:RLEFT)) (:LEFT (IF (< (SETF IL:NLFT (- IL:RLEFT IL:WIDTH)) 0) (IF IL:TRIED-ONCE? (IL:* IL:|;;| "doesn't fit either place put at right of screen") (IL:SETQ IL:NLFT (- IL:\\CURSORDESTWIDTH IL:WIDTH)) (IL:* IL:|;;| "try :RIGHT") (RETURN (REGION-NEXT-TO IL:REGION IL:WIDTH IL:HEIGHT :RIGHT T)))) (SETF IL:NBTM (IL:IMAX (+ IL:RBOTTOM (- IL:RHEIGHT IL:HEIGHT)) 0))) (:RIGHT (IF (> (+ (SETF IL:NLFT (+ IL:RLEFT IL:RWIDTH)) (IL:SUB1 IL:WIDTH)) IL:\\CURSORDESTWIDTH) (IF IL:TRIED-ONCE? (IL:* IL:|;;| "doesn't fit either place put at left of screen") (SETF IL:NLFT 0) (IL:* IL:|;;| "try :LEFT") (RETURN (REGION-NEXT-TO IL:REGION IL:WIDTH IL:HEIGHT :LEFT T)))) (SETF IL:NBTM (IL:IMAX (+ IL:RBOTTOM (- IL:RHEIGHT IL:HEIGHT)) 0)))) (RETURN (IL:CREATEREGION IL:NLFT IL:NBTM IL:WIDTH IL:HEIGHT)))) (DEFUN BACKTRACE-MENU-BUTTONEVENTFN (WINDOW &AUX (MENU (CAR (IL:LISTP (IL:WINDOWPROP WINDOW 'IL:MENU))))) (UNLESS (OR (IL:LASTMOUSESTATE IL:UP) (NULL MENU)) (IL:TOTOPW WINDOW) (COND ((IL:LASTMOUSESTATE IL:MIDDLE) (IL:* IL:|;;| "look for a selected frame in this menu, and then pop up the editor invoke menu for that frame. don't change the selection, just present the edit menu.") (LET* ((TTYWINDOW (IL:WINDOWPROP WINDOW 'IL:MAINWINDOW)) (POS (IL:WINDOWPROP TTYWINDOW 'LASTPOS))) (IL:* IL:|;;| "don't have to worry about releasing POS because we only look at it here (nobody here hangs on to it) and we will be around for less time than LASTPOS. The debugger is responsible for releasing LASTPOS.") (IL:INSPECT/AS/FUNCTION (IF (AND (SYMBOLP (IL:STKNAME POS)) (IL:GETD (IL:STKNAME POS))) (IL:STKNAME POS) 'IL:NILL) POS TTYWINDOW))) (T (LET ((SELECTION (IL:MENU.HANDLER MENU (IL:WINDOWPROP WINDOW 'IL:DSP)))) (WHEN SELECTION (IL:DOSELECTEDITEM MENU (CAR SELECTION) (CDR SELECTION)))))))) (DEFUN BACKTRACE-ITEM-SELECTED (ITEM MENU BUTTON) (IL:* IL:|;;|  "When a frame name is selected in the backtrace menu, this is the function that gets called.") (DECLARE (SPECIAL IL:BRKENV)) (LET* ((FRAMESPECFN (IL:|fetch| (IL:BKMENUITEM IL:BKMENUINFO) IL:|of| ITEM)) (IL:* IL:\;  "number offset from the break position of the frame") (TTYWINDOW (IL:WINDOWPROP (IL:WFROMMENU MENU) 'IL:MAINWINDOW)) (BKPOS (IL:WINDOWPROP TTYWINDOW 'STACK-POSITION)) (POS (IL:STKNTH (- FRAMESPECFN) BKPOS))) (LET ((LP (IL:WINDOWPROP TTYWINDOW 'LASTPOS))) (AND LP (IL:STKNTH 0 POS LP))) (LET ((OLDITEM (IL:|fetch| (IL:MENU IL:MENUUSERDATA) IL:|of| MENU))) (IL:* IL:|;;| "change the item selected from OLDITEM to ITEM. Only do this on left buttons now. Middle just pops up the edit menu, doesn't select. -woz") (WHEN OLDITEM (IL:MENUDESELECT OLDITEM MENU)) (IL:MENUSELECT ITEM MENU)) (IL:* IL:|;;|  "Change the lexical environment so it is the one in effect as of this frame.") (IL:PROCESS.EVAL (IL:WINDOWPROP TTYWINDOW 'PROCESS) `(SETQ IL:BRKENV ',(IL:FIND-LEXICAL-ENVIRONMENT POS)) T) (LET ((FRAMEWINDOW (XCL:WITH-PROFILE (IL:PROCESS.EVAL (IL:WINDOWPROP TTYWINDOW 'IL:PROCESS) `(LET ((PROFILE (XCL:COPY-PROFILE (XCL:FIND-PROFILE "READ-PRINT")))) (SETF (XCL::PROFILE-ENTRY-VALUE 'XCL:*EVAL-FUNCTION* PROFILE) XCL:*EVAL-FUNCTION*) (XCL:SAVE-PROFILE PROFILE)) T) (IL:INSPECTW.CREATE POS #'(LAMBDA (POS) (STACK-FRAME-PROPERTIES POS T)) 'STACK-FRAME-FETCHFN 'STACK-FRAME-STOREFN NIL 'STACK-FRAME-VALUE-COMMAND NIL (FORMAT NIL "~S Frame" (IL:STKNAME POS)) NIL (MAKE-FRAME-INSPECT-WINDOW TTYWINDOW) 'STACK-FRAME-PROPERTY)))) (WHEN (NOT (IL:WINDOWPROP FRAMEWINDOW 'IL:MAINWINDOW)) (IL:ATTACHWINDOW FRAMEWINDOW TTYWINDOW (IF (IL:IGREATERP (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| (IL:WINDOWPROP FRAMEWINDOW 'IL:REGION)) (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| (IL:WINDOWPROP TTYWINDOW 'IL:REGION))) 'IL:TOP 'IL:BOTTOM) NIL 'IL:LOCALCLOSE) (IL:WINDOWADDPROP FRAMEWINDOW 'IL:CLOSEFN 'IL:DETACHWINDOW))))) (DEFUN STACK-FRAME-PROPERTIES (POS &OPTIONAL LOTS?) (LET* ((TOTAL-SLOTS (IL:STKNARGS POS T) (IL:* IL:\; "STKNARGS takes an extra arg which means to include internally bound names as well as those in the basic frame") ) (NUM-ARGS (IL:STKNARGS POS)) (IL:* IL:\;  "number of argument variables") (FNNAME (IL:STKNAME POS)) (IL:* IL:\;  "(novalue \"no such value\")") (ARGLIST (AND (SYMBOLP FNNAME) (IL:GETD FNNAME) (IL:LISTP (IL:SMARTARGLIST FNNAME T))))) `((,FNNAME) ,@(IF (EQ FNNAME 'EVAL) (IL:* IL:\;  "then open the lexical environment") (LIST* '("EXPRESSION" 1) (LET ((ENVIRONMENT (IL:STKARG 2 POS))) (WHEN (IL:ENVIRONMENT-P ENVIRONMENT) (MAPCAN #'(LAMBDA (SUB-ENV-NAME SUB-ENV-GET &OPTIONAL (SUB-ENV (FUNCALL SUB-ENV-GET ENVIRONMENT)) ) (WHEN SUB-ENV (LIST* `(,(STRING-DOWNCASE (SYMBOL-NAME SUB-ENV-NAME))) (DO ((PLIST SUB-ENV (CDDR PLIST)) (PROP-SPECS NIL)) ((NULL PLIST) PROP-SPECS) (PUSH `(,(FIRST PLIST) ,SUB-ENV-NAME) PROP-SPECS))))) '(VARS FUNCTIONS BLOCKS TAGBODIES) '(IL:ENVIRONMENT-VARS IL:ENVIRONMENT-FUNCTIONS IL:ENVIRONMENT-BLOCKS IL:ENVIRONMENT-TAGBODIES))))) (IL:BIND MODE ARGNAME IL:|for| I IL:|from| 1 IL:|to| NUM-ARGS IL:COLLECT (PROGN (IL:|while| (IL:FMEMB (SETF ARGNAME (POP ARGLIST)) LAMBDA-LIST-KEYWORDS) IL:|do| (SETF MODE ARGNAME)) (LIST (OR (IL:STKARGNAME I POS) (IL:* IL:\; "special") (IF (CASE MODE ((NIL &OPTIONAL) ARGNAME) (T NIL)) (STRING ARGNAME) (FORMAT NIL "arg ~D" (- I 1)))) I)))) ,@(LET ((SLOTS (IL:BIND ARGNAME (NOVALUE IL:_ "no such value") IL:FOR PVAR IL:FROM 0 IL:AS I IL:|from| (1+ NUM-ARGS) IL:|to| TOTAL-SLOTS IL:|when| (AND (IL:NEQ NOVALUE (IL:STKARG I POS NOVALUE)) (OR (SETF ARGNAME (IL:STKARGNAME I POS)) (AND LOTS? (SETQ ARGNAME (FORMAT NIL "local ~D" PVAR)) ))) IL:|collect| (LIST ARGNAME I)))) (AND SLOTS (CONS '("locals") SLOTS)))))) (DEFUN STACK-FRAME-FETCHFN (FRAMESPEC WHICHSPEC) (LET (FN) (COND ((NULL (CDR WHICHSPEC)) (IL:* IL:|;;| "this is a dummy with no value") (FIRST WHICHSPEC)) ((SETQ FN (CDR (ASSOC (CADR WHICHSPEC) '((VARS . IL:ENVIRONMENT-VARS) (FUNCTIONS . IL:ENVIRONMENT-FUNCTIONS) (BLOCKS . IL:ENVIRONMENT-BLOCKS) (TAGBODIES . IL:ENVIRONMENT-TAGBODIES)) :TEST 'EQ))) (IL:* IL:\;  "eval frame with lexical environment") (GETF (FUNCALL FN (IL:STKARG 2 FRAMESPEC)) (CAR WHICHSPEC))) (T (IL:* IL:|;;| "CAR is name, CADR is offset") (IL:STKARG (SECOND WHICHSPEC) FRAMESPEC))))) (DEFUN STACK-FRAME-STOREFN (FRAMESPEC WHICHSPEC NEWVALUE) (LET (FN) (COND ((NULL (CDR WHICHSPEC)) (IL:* IL:\; "no value, can't replace") NIL) ((SETQ FN (CDR (ASSOC (CADR WHICHSPEC) '((VARS . IL:ENVIRONMENT-VARS) (FUNCTIONS . IL:ENVIRONMENT-FUNCTIONS) (BLOCKS . IL:ENVIRONMENT-BLOCKS) (TAGBODIES . IL:ENVIRONMENT-TAGBODIES)) :TEST 'EQ))) (IL:* IL:\;  "eval frame with lexical environment") (LET ((PLIST (FUNCALL FN (IL:STKARG 2 FRAMESPEC)))) (IL:* IL:\; "don't want to depend on setf knowing how to do this; we can side effect since fields are always present.") (SETF (GETF PLIST (CAR WHICHSPEC)) NEWVALUE))) (T (IL:SETSTKARG (SECOND WHICHSPEC) FRAMESPEC NEWVALUE))))) (DEFUN STACK-FRAME-VALUE-COMMAND (VALUE PROP DATUM WINDOW) (IL:* IL:|;;| "property command function for inspect windows onto stack frames. Recognizes certain PROP as function names.") (IF (AND (LISTP PROP) (NULL (CDR PROP))) (COND ((SYMBOLP VALUE) (IL:INSPECT/AS/FUNCTION VALUE DATUM WINDOW)) ((AND (CONSP VALUE) (SYMBOLP (SECOND VALUE))) (IL:INSPECT/AS/FUNCTION (SECOND VALUE) DATUM WINDOW))) (IL:DEFAULT.INSPECTW.VALUECOMMANDFN VALUE PROP DATUM WINDOW))) (DEFUN STACK-FRAME-PROPERTY (PROP DATUM) (IL:* IL:|;;| "returns the thing to be printed as the value") (COND ((AND (CONSP PROP) (NULL (CDR PROP))) (IL:* IL:\; "frame function name") NIL) ((CONSP DATUM) (IL:* IL:\; "multiple frame window") (SECOND PROP)) (T (FIRST PROP)))) (DEFUN MAKE-FRAME-INSPECT-WINDOW (TTYWINDOW) (LET (TTYREGION BTWINDOW) (COND ((SETF BTWINDOW (IL:|for| ATW IL:|in| (IL:ATTACHEDWINDOWS TTYWINDOW) IL:|when| (IL:WINDOWPROP ATW 'FRAME-INSPECT) IL:|do| (IL:* IL:\;  "test for an attached window that is the frame window.") (%RELEASE-STACK-DATUM ATW) (RETURN ATW)))) (T (SETF TTYREGION (IL:WINDOWREGION TTYWINDOW)) (IL:* IL:\;  "create frame window and set its fixed properties.") (SETF BTWINDOW (IL:CREATEW (REGION-NEXT-TO TTYREGION NIL 150 :TOP) "Back Trace Frame Window")) (IL:* IL:|;;| "keep size of frame window fixed so that tty portion can grow. No very elegant way to do this but ...") (IL:WINDOWPROP BTWINDOW 'FRAME-INSPECT T) (IL:WINDOWPROP BTWINDOW 'IL:MAXSIZE '(300 . 150)) (IL:* IL:\;  "save backtrace window with window.") (IL:WINDOWPROP BTWINDOW 'IL:PROCESS (IL:WINDOWPROP TTYWINDOW 'IL:PROCESS)) (IL:WINDOWADDPROP BTWINDOW 'IL:CLOSEFN #'(LAMBDA (W) (%RELEASE-STACK-DATUM W) (IL:* IL:|;;|  "clear storage -- if/why this is necessary is now unclear") (IL:WINDOWPROP W 'IL:SELECTABLEITEMS NIL)) T))) BTWINDOW)) (DEFUN %RELEASE-STACK-DATUM (W) (LET ((ST (IL:WINDOWPROP W 'DATUM))) (IF (IL:STACKP ST) (IL:RELSTK ST) (IF (LISTP ST) (MAPC 'IL:RELSTK ST))))) (DEFUN PRINT-BACKTRACE (&KEY (FROM 'XCL:PRINT-BACKTRACE) TO TEST PRINT-VARIABLES PRINT-JUNK OUTPUT (LINK :ALINK) &AUX (*PRINT-LEVEL* 2) (*PRINT-LENGTH* 10)) (IL:BAKTRACE FROM TO (IF TEST (LIST #'(LAMBDA (X) (NOT (FUNCALL TEST X))))) (+ (IF PRINT-VARIABLES 1 0) (IF PRINT-JUNK 32 0) 8 (CASE LINK (:ALINK 16) (T 0))) OUTPUT)) (XCL:DEFCOMMAND ("STOP" :DEBUGGER :QUIET) NIL "Exit this debugger level" (IL:SETQ IL:BRKVALUES '(IL:ERROR!)) (THROW 'DEBUGGER-EXIT NIL)) (XCL:DEFCOMMAND ("^" :DEBUGGER :QUIET) NIL "Abort out of debugger" (IL:SETQ IL:BRKVALUES '(IL:ERROR!)) (THROW 'DEBUGGER-EXIT NIL)) (XCL:DEFCOMMAND ("RETURN" :DEBUGGER) (&OPTIONAL (IL:EXPRESSION NIL) &ENVIRONMENT IL:ENV) "Return value from debugger" (XCL:CONDITION-CASE (PROGN (IL:SETQ IL:BRKVALUES (LIST 'RETURN (MULTIPLE-VALUE-LIST (  DEBUGGER-EVAL IL:EXPRESSION IL:ENV)) (IL:STKNTH 0 IL:BRKPOS))) (THROW 'DEBUGGER-EXIT NIL)) (SI::DEBUGGER-EVAL-ABORTED (IL:C) (VALUES :ABORTED (SI::DEBUGGER-EVAL-ABORTED-CONDITION IL:C))))) (XCL:DEFCOMMAND ("PR" :DEBUGGER) (&OPTIONAL IL:NAME-OR-NUMBER) "Select and invoke a proceed case." (ESCAPE-FROM-DEBUGGER T IL:NAME-OR-NUMBER) (VALUES)) (XCL:DEFCOMMAND ("PR!" :DEBUGGER) (&OPTIONAL IL:NAME-OR-NUMBER) "Select and invoke a proceed case." (ESCAPE-FROM-DEBUGGER NIL IL:NAME-OR-NUMBER) (VALUES)) (XCL:DEFCOMMAND ("PROCEED" :DEBUGGER) (&OPTIONAL IL:NAME-OR-NUMBER) "Select and invoke a proceed case." (ESCAPE-FROM-DEBUGGER T IL:NAME-OR-NUMBER) (VALUES)) (XCL:DEFCOMMAND ("OK" :DEBUGGER :QUIET) NIL (DECLARE (SPECIAL IL:BRKENV)) "Exit/proceed from debugger" (XCL:CONDITION-CASE (PROGN (WHEN (TYPEP IL:BRKCOND 'SI::BREAKPOINT) (IL:* IL:|;;|  " if at a breakpoint, OK means to eval the expression if necessary and return") (UNLESS IL:BRKVALUES (IL:* IL:\;  "EQ only if already evaluated") (IL:SETQ IL:BRKVALUES (CONS T (MULTIPLE-VALUE-LIST (  DEBUGGER-EVAL IL:BRKEXP IL:BRKENV)) ))) (THROW 'DEBUGGER-EXIT NIL)) (CONDITIONS:CONTINUE) (IL:* IL:\;  "will escape if a proceed case named PROCEED is enabled") (ESCAPE-FROM-DEBUGGER) (IL:* IL:\;  "If all else fails, ask the user what to do...") ) (SI::DEBUGGER-EVAL-ABORTED (IL:C) (VALUES :ABORTED (SI::DEBUGGER-EVAL-ABORTED-CONDITION IL:C))))) (DEFUN EXIT-DEBUGGER () (SETF IL:BRKVALUES '(IL:ERROR!)) (THROW 'DEBUGGER-EXIT NIL)) (DEFUN INVOKE-ESCAPE-FROM-MENU () (LET ((MENU (MENU-FROM-ESCAPE-LIST (COLLECT-ACTIVE-ESCAPES IL:BRKCOND)))) (IF MENU (LET ((CASE (IL:MENU MENU))) (WHEN CASE (CONDITIONS:INVOKE-RESTART-INTERACTIVELY CASE))) (FORMAT *DEBUG-IO* "~&No restarts enabled.~%")))) (DEFUN ESCAPE-FROM-DEBUGGER (SHADOW? &OPTIONAL NAME-OR-NUMBER) (LET* ((ESCAPES (COLLECT-ACTIVE-ESCAPES IL:BRKCOND (NOT SHADOW?))) (KEYS (KEYLIST-FROM-ESCAPE-LIST ESCAPES))) (IF ESCAPES (ETYPECASE NAME-OR-NUMBER (NULL (LET ((ESCAPE (PROGN (IL:ASKUSEREXPLAIN KEYS NIL NIL " ") (IL:ASKUSER NIL NIL "Proceed how? " KEYS T)))) (WHEN ESCAPE (CONDITIONS:INVOKE-RESTART-INTERACTIVELY ESCAPE)))) ((INTEGER (0)) (LET ((ESCAPE (NTH (1- (THE INTEGER NAME-OR-NUMBER)) ESCAPES))) (IF ESCAPE (CONDITIONS:INVOKE-RESTART-INTERACTIVELY ESCAPE) (FORMAT *DEBUG-IO* "~&No such restart number: ~D~%" NAME-OR-NUMBER)))) (SYMBOL (LET ((ESCAPE (FIND (THE SYMBOL NAME-OR-NUMBER) ESCAPES :KEY 'CONDITIONS:RESTART-NAME :TEST 'EQ))) (IF ESCAPE (CONDITIONS:INVOKE-RESTART-INTERACTIVELY ESCAPE) (FORMAT *DEBUG-IO* "~&No restart named ~S~%" NAME-OR-NUMBER))))) (FORMAT *DEBUG-IO* "~&No restarts enabled.~%")))) (DEFUN MENU-FROM-ESCAPE-LIST (ESCAPES) (WHEN ESCAPES (IL:|create| IL:MENU IL:TITLE IL:_ "Ways to proceed..." IL:ITEMS IL:_ (MAPCAR #'(LAMBDA (ESCAPE) (LIST (PRINC-TO-STRING ESCAPE) ESCAPE)) ESCAPES)))) (DEFUN KEYLIST-FROM-ESCAPE-LIST (ESCAPES) (WHEN ESCAPES (LET ((KEYLIST (IL:|for| ESC IL:|in| ESCAPES IL:|as| I IL:|from| 1 IL:|bind| MESSAGE IL:|eachtime| (SETF MESSAGE (PRINC-TO-STRING ESC)) IL:|collect| `(,I ,MESSAGE IL:NOECHOFLG T IL:EXPLAINSTRING ,(FORMAT NIL "~D~:[~; (~:*~S)~] - ~A" I ( CONDITIONS:RESTART-NAME ESC) MESSAGE) IL:CONFIRMFLG T RETURN (PROGN (IL:TERPRI T) ',ESC))))) (SETF (CDR (LAST KEYLIST)) '(("N" "No - don't proceed " IL:NOECHOFLG T IL:CONFIRMFLG T IL:AUTOCONFIRMFLG T RETURN (IL:TERPRI T)))) KEYLIST))) (DEFUN COLLECT-ACTIVE-ESCAPES (CONDITION &OPTIONAL ALL) (LET ((ESCAPES (IL:ENVAPPLY XCL:*EVAL-FUNCTION* `((LET ((IL:BRKCOND ',CONDITION)) (CONDITIONS:COMPUTE-RESTARTS))) (IL:STKNTH -1 'XCL:DEBUGGER) NIL T))) (IF (NOT ALL) (DELETE-DUPLICATES ESCAPES :FROM-END T :TEST #'(LAMBDA (ESCAPE-1 ESCAPE-2) (AND (CONDITIONS:RESTART-NAME ESCAPE-1) (EQ (CONDITIONS:RESTART-NAME ESCAPE-1) (CONDITIONS:RESTART-NAME ESCAPE-2))))) ESCAPES))) (DEFUN IL:FIND-LEXICAL-ENVIRONMENT (&OPTIONAL (IL:STACKPOS IL:LASTPOS)) (IL:* IL:|;;| "used by DEBUGGER to find a lexical environment to use when evaluating commands") (DECLARE (SPECIAL IL:LASTPOS)) (LET ((IL:POS (IL:STKPOS 'EVAL NIL IL:STACKPOS))) (AND IL:POS (PROG1 (IL:STKARG 2 IL:POS) (IL:RELSTK IL:POS))))) (IL:DEFINEQ (il:find-stack-frame (il:lambda (il:frame-spec) (il:* il:|lmm| " 7-Nov-86 03:39") (il:* il:|;;| "handle debugger commands like @ which take a frame description. Smash LASTPOS to point at new position. ") (let ((il:pos (il:find-debugger-entry-frame t)) il:token) (il:while il:frame-spec il:do (il:setq il:pos (il:case-equalp (il:setq il:token (il:pop il:framespec) ) ("@" (il:* il:\; "leave LASTPOS alone") (il:stknth 0 il:lastpos il:pos)) ("=" (il:* il:\; "eval ") (il:stknth 0 (eval (il:pop il:framespec )))) (t (cond ((il:numberp il:token) (il:stknth il:token il:pos il:pos)) (t (or (il:stkpos il:token nil (il:stknth -1 il:pos il:pos) il:pos) (il:error il:token '"not found" t)))))))) (prog1 (il:setq il:lastpos (il:stknth 0 il:pos il:lastpos)) (il:relstk il:pos))))) ) (IL:PUTPROPS XCL:DEBUGGER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (XCL:DEFPACKAGE "DEBUGGER" (:PREFIX-NAME "DBG") (:NICKNAMES "DBG")))) (IL:PUTPROPS XCL:DEBUGGER IL:FILETYPE :COMPILE-FILE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA IL:WBREAK) ) (IL:PUTPROPS XCL:DEBUGGER IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (18680 18967 (IL:WBREAK 18693 . 18965)) (42297 47159 (IL:BAKTRACE 42310 . 45094) ( IL:BAKTRACE1 45096 . 47157)) (81689 83655 (IL:FIND-STACK-FRAME 81702 . 83653))))) IL:STOP \ No newline at end of file diff --git a/sources/DEFFER-RUNTIME b/sources/DEFFER-RUNTIME new file mode 100644 index 00000000..ffaedde3 --- /dev/null +++ b/sources/DEFFER-RUNTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "16-May-90 15:30:14" IL:|{DSK}local>lde>lispcore>sources>DEFFER-RUNTIME.;2| 4543 IL:|changes| IL:|to:| (IL:VARS IL:DEFFER-RUNTIMECOMS) IL:|previous| IL:|date:| " 6-Jul-88 20:55:09" IL:|{DSK}local>lde>lispcore>sources>DEFFER-RUNTIME.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DEFFER-RUNTIMECOMS) (IL:RPAQQ IL:DEFFER-RUNTIMECOMS ((IL:INITVARS (IL:FILEPKGFLG NIL)) (IL:* IL:|;;| "The definer data structures and manipulation functions") (IL:* IL:|;;| "Must be shared with IL for compatibility with old definers") (IL:VARIABLES *DEFINITION-HASH-TABLE*) (IL:* IL:|;;| "Prototype definition facility") (IL:VARIABLES *DEFINITION-PROTOTYPES*) (IL:FUNCTIONS ADD-PROTOTYPE-FN PROTOTYPE-DEFN-TYPES PROTOTYPE-DEFINERS-FOR-TYPE MAKE-PROTOTYPE %MAKE-FUNCTION-PROTOTYPE) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:DEFFER-RUNTIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (IL:RPAQ? IL:FILEPKGFLG NIL) (IL:* IL:|;;| "The definer data structures and manipulation functions") (IL:* IL:|;;| "Must be shared with IL for compatibility with old definers") (DEFGLOBALVAR *DEFINITION-HASH-TABLE* (MAKE-HASH-TABLE :TEST #'EQ :SIZE 20)) (IL:* IL:|;;| "Prototype definition facility") (DEFGLOBALVAR *DEFINITION-PROTOTYPES* NIL (IL:* IL:|;;| "An association list mapping file-manager types to association lists from definer-names to prototype-functions") ) (DEFUN ADD-PROTOTYPE-FN (TYPE DEFINER PROTOTYPE-FN) (LET ((TYPE-ALIST (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST #'EQ))) (IF (NULL TYPE-ALIST) (IL:* IL:|;;| "No entry for this type -- add one") (SETQ *DEFINITION-PROTOTYPES* (ACONS TYPE (LIST (CONS DEFINER PROTOTYPE-FN)) *DEFINITION-PROTOTYPES*)) (LET ((DEFINER-ALIST (ASSOC DEFINER (CDR TYPE-ALIST) :TEST #'EQ))) (IL:* IL:|;;| "If this definer didn't already have a PROTOTYPE-FN, add one. If it already had one, change it to the new one.") (IF (NULL DEFINER-ALIST) (SETF (CDR TYPE-ALIST) (ACONS DEFINER PROTOTYPE-FN (CDR TYPE-ALIST))) (SETF (CDR DEFINER-ALIST) PROTOTYPE-FN)))))) (DEFUN PROTOTYPE-DEFN-TYPES () (IL:* IL:|;;;| "Return a list of the file-manager types for which some definer can provide a prototype definition.") (MAPCAN #'(LAMBDA (X) (IF (CDR X) (LIST (CAR X)))) *DEFINITION-PROTOTYPES*)) (DEFUN PROTOTYPE-DEFINERS-FOR-TYPE (TYPE) (IL:* IL:|;;;| "Return a list of the definers that claim to be able to provide a prototype definition of the given type.") (MAPCAR #'CAR (CDR (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST #'EQ)))) (DEFUN MAKE-PROTOTYPE (NAME TYPE DEFINER) (LET ((PROTOTYPE-FN (CDR (ASSOC DEFINER (CDR (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST #'EQ)) :TEST #'EQ)))) (AND PROTOTYPE-FN (FUNCALL PROTOTYPE-FN NAME)))) (DEFUN %MAKE-FUNCTION-PROTOTYPE () (IL:* IL:|;;| "dummy definition -- redefined by SEdit") (LIST (LIST "Arg List") "Body")) (IL:PUTPROPS IL:DEFFER-RUNTIME IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:DEFFER-RUNTIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:DEFFER-RUNTIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/DEFPACKAGE-IMPORT b/sources/DEFPACKAGE-IMPORT new file mode 100644 index 00000000..782a8412 --- /dev/null +++ b/sources/DEFPACKAGE-IMPORT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:31:19" {DSK}local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;2 1000 changes to%: (VARS DEFPACKAGE-IMPORTCOMS) previous date%: "12-Dec-86 13:26:35" {DSK}local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;1 ) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DEFPACKAGE-IMPORTCOMS) (RPAQQ DEFPACKAGE-IMPORTCOMS ((P (IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP")) (PROP MAKEFILE-ENVIRONMENT DEFPACKAGE-IMPORT))) (IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP") (PUTPROPS DEFPACKAGE-IMPORT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" )) (PUTPROPS DEFPACKAGE-IMPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/DEFSTRUCT b/sources/DEFSTRUCT new file mode 100644 index 00000000..6feee91e --- /dev/null +++ b/sources/DEFSTRUCT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-93 18:04:53" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT.;2| 83865 IL:|previous| IL:|date:| "11-Jun-92 14:44:30" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT.;1| ) ; Copyright (c) 1986, 1987, 1900, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DEFSTRUCTCOMS) (IL:RPAQQ IL:DEFSTRUCTCOMS ( (IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp. (Chapter 19 of CLtL).") (IL:* IL:|;;;| "public interface ") (IL:DEFINE-TYPES IL:STRUCTURES) (IL:FUNCTIONS DEFSTRUCT) (IL:* IL:|;;;| "top-level ") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:FILES IL:DEFSTRUCT-RUN-TIME )) (IL:* IL:|;;;| "parsing code") (IL:VARIABLES %DEFAULT-DEFSTRUCT-TYPE %DEFAULT-SLOT-TYPE %DEFAULT-STRUCTURE-INCLUDE %DEFSTRUCT-OPTIONS %NO-CONSTRUCTOR %NO-PREDICATE %NO-COPIER %DEFSTRUCT-CONSP-OPTIONS %DEFSTRUCT-EXPORT-OPTIONS) (IL:FUNCTIONS ASSIGN-SLOT-ACCESSOR REMOVE-DOCUMENTATION RECORD-DOCUMENTATION ENSURE-VALID-TYPE PARSE-SLOT DEFSTRUCT-PARSE-OPTIONS ENSURE-CONSISTENT-PS PS-NUMBER-OF-SLOTS PS-TYPE-SPECIFIER) (IL:* IL:|;;;| "slot resolution code") (IL:FUNCTIONS ASSIGN-SLOT-OFFSET RESOLVE-SLOTS INSERT-INCLUDED-SLOT MERGE-SLOTS NAME-SLOT DUMMY-SLOT OFFSET-SLOT) (IL:* IL:|;;;| "data layout code") (IL:FUNCTIONS ASSIGN-STRUCTURE-REPRESENTATION COERCE-TYPE %STRUCTURE-TYPE-TO-FIELDSPEC ASSIGN-FIELD-DESCRIPTORS STRUCTURE-POINTER-SLOTS) (IL:* IL:|;;;| "type system hooks") (IL:FUNCTIONS PROCESS-TYPE PREDICATE-BODY TYPE-EXPAND-STRUCTURE TYPE-EXPAND-NAMED-STRUCTURE PS-NAME-SLOT-POSITION DEFAULT-PREDICATE-NAME DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER CACHE-PREDICATE-INFO) (IL:VARIABLES %FUNCTION-DEFINING-FORM-KEYWORDS) (IL:* IL:|;;;| "accessors and setfs") (IL:FUNCTIONS SETF-NAME) (IL:FUNCTIONS ACCESSOR-BODY PROCESS-ACCESSORS ESTABLISH-ACCESSORS DEFINE-ACCESSORS DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER DEFSTRUCT-SHARED-SETF-EXPANDER CACHE-SLOT-INFO) (IL:FUNCTIONS %MAKE-ACCESSOR-CLOSURE %MAKE-LIST-ACCESSOR %MAKE-ARRAY-ACCESSOR %MAKE-POINTER-ACCESSOR %MAKE-BIT-ACCESSOR %MAKE-FLAG-ACCESSOR %MAKE-WORD-ACCESSOR %MAKE-FIXP-ACCESSOR %MAKE-SMALL-FIXP-ACCESSOR %MAKE-FLOAT-ACCESSOR) (IL:* IL:|;;;| "constructor definition code") (IL:FUNCTIONS DEFINE-CONSTRUCTORS DEFINE-BOA-CONSTRUCTOR ARGUMENT-NAMES BOA-ARG-LIST-WITH-INITIAL-VALUES BOA-SLOT-SETFS FIND-SLOT RAW-CONSTRUCTOR BUILD-CONSTRUCTOR-ARGLIST BUILD-CONSTRUCTOR-SLOT-SETFS BOA-CONSTRUCTOR-P DEFAULT-CONSTRUCTOR-NAME) (IL:* IL:|;;;| "copiers") (IL:FUNCTIONS DEFINE-COPIERS BUILD-COPIER-SLOT-SETFS BUILD-COPIER-TYPE-CHECK) (IL:* IL:|;;;| "print functions") (IL:VARIABLES %DEFAULT-PRINT-FUNCTION) (IL:* IL:|;;;| "internal stuff.") (IL:SETFS IL:FFETCHFIELD) (IL:* IL:|;;;| "utilities") (IL:FUNCTIONS DEFSTRUCT-ASSERT-SUBTYPEP) (IL:* IL:|;;;| "inspecting structures") (IL:FUNCTIONS STRUCTURE-OBJECT-P INSPECT-STRUCTURE-OBJECT STRUCTURE-OBJECT-INSPECT-FETCHFN STRUCTURE-OBJECT-INSPECT-PROPPRINTFN STRUCTURE-OBJECT-INSPECT-STOREFN STRUCTURE-OBJECT-PROPCOMMANDFN) (IL:* IL:|;;|  "Defined last so functions required to load a defstruct are loaded first") (IL:STRUCTURES PS PARSED-SLOT) (IL:* IL:|;;|  "Mapping between names of generated functions and their associated structures") (IL:FUNCTIONS STRUCTURE-FUNCTION-P STRUCTURE-FUNCTIONS) (IL:* IL:|;;;| "Editing structures") (IL:FUNCTIONS STRUCTURES.HASDEF STRUCTURES.EDITDEF) (IL:P (IL:FILEPKGTYPE 'IL:STRUCTURES 'IL:HASDEF 'STRUCTURES.HASDEF 'IL:EDITDEF 'STRUCTURES.EDITDEF)) (IL:ADDVARS (IL:SHADOW-TYPES (IL:STRUCTURES IL:FNS))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:ADDVARS (IL:INSPECTMACROS ((IL:FUNCTION STRUCTURE-OBJECT-P ) . INSPECT-STRUCTURE-OBJECT) ))) (IL:* IL:|;;;| "file properties") (IL:PROP IL:FILETYPE IL:DEFSTRUCT) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:DEFSTRUCT))) (IL:* IL:|;;;| "Implementation of Structure facilities of Commmon Lisp. (Chapter 19 of CLtL).") (IL:* IL:|;;;| "public interface ") (XCL:DEF-DEFINE-TYPE IL:STRUCTURES "Common Lisp structures") (XCL:DEFDEFINER (DEFSTRUCT (:NAME (LAMBDA (WHOLE) (LET ((NAME-AND-OPTIONS (SECOND WHOLE))) (IF (CONSP NAME-AND-OPTIONS) (CAR NAME-AND-OPTIONS) NAME-AND-OPTIONS)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) `(DEFSTRUCT (,NAME (":option" "value")) "documentation string" ("slot-name" "initial-value")))))) IL:STRUCTURES (NAME &REST SLOT-DESCRIPTIONS) (LET* ((PS (DEFSTRUCT-PARSE-OPTIONS NAME)) (SLOT-DESCRIPTIONS (REMOVE-DOCUMENTATION PS SLOT-DESCRIPTIONS))) (RESOLVE-SLOTS SLOT-DESCRIPTIONS PS) `(PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (PARSED-STRUCTURE ',(PS-NAME PS) T) ',PS)) ,@(ASSIGN-STRUCTURE-REPRESENTATION PS) ,@(PROCESS-TYPE PS) ,@(PROCESS-ACCESSORS PS) (EVAL-WHEN (EVAL COMPILE LOAD) (ESTABLISH-SETFS-AND-OPTIMIZERS ',(PS-NAME PS))) ,@(DEFINE-CONSTRUCTORS PS) ,@(DEFINE-COPIERS PS) ,@(RECORD-DOCUMENTATION PS)))) (IL:* IL:|;;;| "top-level ") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:FILESLOAD IL:DEFSTRUCT-RUN-TIME) ) (IL:* IL:|;;;| "parsing code") (DEFVAR %DEFAULT-DEFSTRUCT-TYPE 'DATATYPE "The type of structures when no :type option is specified") (DEFVAR %DEFAULT-SLOT-TYPE 'T "the type of any slot which does not specifiy a :type option") (DEFCONSTANT %DEFAULT-STRUCTURE-INCLUDE 'STRUCTURE-OBJECT "datatype included by every structure") (DEFPARAMETER %DEFSTRUCT-OPTIONS '(:CONC-NAME :CONSTRUCTOR :COPIER :PREDICATE :INCLUDE :PRINT-FUNCTION :TYPE :INITIAL-OFFSET :NAMED :INLINE :FAST-ACCESSORS :TEMPLATE :EXPORT)) (DEFCONSTANT %NO-CONSTRUCTOR ':NONE "the value which says that no constructor was specified.") (DEFCONSTANT %NO-PREDICATE ':NONE "the value which says that no constructor was specified") (DEFCONSTANT %NO-COPIER ':NONE) (DEFPARAMETER %DEFSTRUCT-CONSP-OPTIONS (REMOVE ':NAMED %DEFSTRUCT-OPTIONS)) (DEFPARAMETER %DEFSTRUCT-EXPORT-OPTIONS '(:ACCESSOR :CONSTRUCTOR :PREDICATE :COPIER)) (DEFUN ASSIGN-SLOT-ACCESSOR (SLOT CONC-NAME) (IL:* IL:|;;| "assigns the accessor name to a slot") (IF (PSLOT-ACCESSOR SLOT) (SETF (PSLOT-ACCESSOR SLOT) (VALUES (INTERN (CONCATENATE 'STRING (STRING CONC-NAME) (STRING (PSLOT-NAME SLOT)))))))) (DEFUN REMOVE-DOCUMENTATION (PS SLOT-DESCRIPTIONS) (IL:* IL:|;;| "Records it if there is any documentation string.") (LET ((DOC? (CAR SLOT-DESCRIPTIONS))) (COND ((STRINGP DOC?) (IL:* IL:|;;| " save it and return the rest of the slots.") (SETF (PS-DOCUMENTATION-STRING PS) DOC?) (REST SLOT-DESCRIPTIONS)) (T (IL:* IL:|;;| "no doc string, return the whole thing.") SLOT-DESCRIPTIONS)))) (DEFUN RECORD-DOCUMENTATION (PS) (IL:* IL:|;;| "Returns a form which saves the documentation string for a structure.") (LET ((PARSED-DOCSTRING (PS-DOCUMENTATION-STRING PS))) (IF PARSED-DOCSTRING `((SETF (DOCUMENTATION ',(PS-NAME PS) 'STRUCTURE) ,PARSED-DOCSTRING))))) (DEFUN ENSURE-VALID-TYPE (TYPE-FORM) (IL:* IL:|;;| "Bogus right now ") TYPE-FORM) (DEFUN PARSE-SLOT (DESCRIPTION &OPTIONAL (GENERATE-ACCESSOR T)) (IL:* IL:|;;|  "Takes a slot description from the defstruct body or included slots and returns a parsed version") (LET* ((DESCRIPTION (IF (CONSP DESCRIPTION) DESCRIPTION (LIST DESCRIPTION))) (SLOT (MAKE-PARSED-SLOT))) (XCL:DESTRUCTURING-BIND (NAME &OPTIONAL INITIAL-VALUE &REST SLOT-OPTIONS) DESCRIPTION (IF (SYMBOLP NAME) (SETF (PSLOT-NAME SLOT) NAME) (ERROR "Slot name not symbol: ~S" NAME)) (SETF (PSLOT-INITIAL-VALUE SLOT) INITIAL-VALUE) (IL:* IL:|;;| "some variant of PCL's keyword-bind would be easier here, but it's incapable of producing reasonable error msgs for the user. Maybe later.") (DO ((OPTION-PAIR SLOT-OPTIONS (CDDR OPTION-PAIR))) ((NULL OPTION-PAIR)) (CASE (CAR OPTION-PAIR) (:TYPE (SETF (PSLOT-TYPE SLOT) (ENSURE-VALID-TYPE (CADR OPTION-PAIR)))) (:READ-ONLY (SETF (PSLOT-READ-ONLY SLOT) (AND (CADR OPTION-PAIR) T))) (OTHERWISE (IF (KEYWORDP INITIAL-VALUE) (ERROR "Initial value must be specified to use slot options. ~S" DESCRIPTION) (ERROR "Illegal slot option ~S in slot ~S" (CAR OPTION-PAIR) NAME))))) (IF GENERATE-ACCESSOR (SETF (PSLOT-ACCESSOR SLOT) T))) SLOT)) (DEFUN DEFSTRUCT-PARSE-OPTIONS (NAME&OPTIONS) (IL:* IL:|;;| "Returns a structure representing the options in a defstruct call.") (LET* ((OPTIONS (IF (LISTP NAME&OPTIONS) NAME&OPTIONS (LIST NAME&OPTIONS))) (NAME (POP OPTIONS)) (PS (MAKE-PS :NAME NAME :CONC-NAME (CONCATENATE 'STRING (STRING NAME) "-")))) (DOLIST (OPTION OPTIONS) (COND ((LISTP OPTION) (XCL:DESTRUCTURING-BIND (OPTION-KEYWORD &OPTIONAL (OPTION-VALUE NIL ARGUMENT-PROVIDED) &REST FURTHER-ARGUMENTS) OPTION (CASE OPTION-KEYWORD (:CONC-NAME (IL:* IL:|;;|  "if the option is specified, but the option value is nil, then use the empty string as conc-name") (SETF (PS-CONC-NAME PS) (OR OPTION-VALUE ""))) (:CONSTRUCTOR (IL:* IL:|;;|  "multiple constructors are allowed. If NIL is provided, then define no constructor.") (COND ((NOT OPTION-VALUE) (IF ARGUMENT-PROVIDED (IL:* IL:|;;|  "NIL was specified. Record that no constructor is to be built.") (SETF (PS-CONSTRUCTORS PS) NIL) (IL:* IL:|;;| "otherwise, it as though the option weren't specified (p. 312 cltl) so leave the default value there.") )) ((EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR) (IL:* IL:|;;|  "this is the first constructor specified. Make the field be a list now.") (SETF (PS-CONSTRUCTORS PS) (LIST (IF FURTHER-ARGUMENTS (CDR OPTION) OPTION-VALUE)))) (T (IL:* IL:|;;|  "just push another one on the list of constructors.") (PUSH (IF FURTHER-ARGUMENTS (CDR OPTION) OPTION-VALUE) (PS-CONSTRUCTORS PS))))) (:COPIER (IL:* IL:|;;| "if the argument is specified (even if it is nil), use it. Otherwise use the default COPY- form already in the ps.") (IF ARGUMENT-PROVIDED (SETF (PS-COPIER PS) OPTION-VALUE))) (:PREDICATE (IF ARGUMENT-PROVIDED (SETF (PS-PREDICATE PS) OPTION-VALUE))) (:INCLUDE (SETF (PS-INCLUDE PS) OPTION-VALUE) (IL:* IL:|;;| "if there are any included slots record them") (SETF (PS-INCLUDED-SLOTS PS) (CDDR OPTION))) (:PRINT-FUNCTION (COND ((AND ARGUMENT-PROVIDED (NULL OPTION-VALUE)) (IL:* IL:|;;| "extension to CLtL, if NIL is specified as the defprint, then the internal print function is specified.") (SETF (PS-PRINT-FUNCTION PS) 'IL:\\PRINT-USING-ADDRESS)) (ARGUMENT-PROVIDED (SETF (PS-PRINT-FUNCTION PS) OPTION-VALUE)))) (:TYPE (SETF (PS-TYPE PS) (COND ((EQ OPTION-VALUE 'LIST) 'LIST) ((EQ OPTION-VALUE 'VECTOR) (IL:* IL:\;  "default the vector type to t") (SETF (PS-VECTOR-TYPE PS) T) 'VECTOR) ((AND (CONSP OPTION-VALUE) (EQ (CAR OPTION-VALUE) 'VECTOR)) (SETF (PS-VECTOR-TYPE PS) (IL:%GET-CANONICAL-CML-TYPE (CADR OPTION-VALUE))) 'VECTOR) (T (ERROR "the specified :type is not list or subtype of vector: ~S" OPTION-VALUE))))) (:INITIAL-OFFSET (IF (NOT (TYPEP OPTION-VALUE '(INTEGER 0 *))) (ERROR ":initial-offset isn't a non-negative integer: ~S" OPTION-VALUE)) (SETF (PS-INITIAL-OFFSET PS) OPTION-VALUE)) (:INLINE (IL:* IL:|;;|  "Is one or both of :accessor, and :predicate or t, which is equivalent to both") (IL:* IL:|;;| "Default is '(:accessor :predicate) ") (IL:* IL:|;;|  "option (:inline :only) implies no funcallable accessors or predicate is generated") (IF ARGUMENT-PROVIDED (SETF (PS-INLINE PS) OPTION-VALUE))) (:FAST-ACCESSORS (IL:* IL:|;;|  "Is either t or nil, t implying no type checks for all accessors") (IF ARGUMENT-PROVIDED (SETF (PS-FAST-ACCESSORS PS) OPTION-VALUE))) (:TEMPLATE (IL:* IL:|;;| "Is either t or nil -- t implying type datatype, no copier, predicate, print-function or constructors, and fast accessors, and no new datatype declared.") (IF ARGUMENT-PROVIDED (SETF (PS-TEMPLATE PS) OPTION-VALUE))) (:EXPORT (IL:* IL:|;;| "Edited by TT(13-June-90) Export Option is added for DEFSTRUCT(Medley 1.2). The Specified functions(ex. :constructor, :copier...) will be exported.") (IF FURTHER-ARGUMENTS (ERROR "The specified export functions is not list or atom : ~S" (CONS :EXPORT (CONS OPTION-VALUE FURTHER-ARGUMENTS))) (IF ARGUMENT-PROVIDED (SETF (PS-EXPORT PS) OPTION-VALUE) (SETF (PS-EXPORT PS) T)))) (OTHERWISE (ERROR "Bad option to defstruct: ~S." OPTION))))) (T (CASE OPTION (:NAMED (SETF (PS-NAMED PS) T)) (OTHERWISE (IF (MEMBER OPTION %DEFSTRUCT-CONSP-OPTIONS :TEST #'EQ) (ERROR "defstruct option ~s must be in parentheses with its value" OPTION) (ERROR "Bad option to defstruct: ~S." OPTION))))))) (ENSURE-CONSISTENT-PS PS) PS)) (DEFUN ENSURE-CONSISTENT-PS (PS) (IL:* IL:|;;|  "Accomplishes the consistency checks that can't occur until all the options have been parsed.") (IF (PS-INCLUDE PS) (LET* ((INCLUDE (PS-INCLUDE PS)) (INCLUDED-PSTRUCTURE (PARSED-STRUCTURE INCLUDE))) (IL:* IL:|;;| "ensure that the user is not suicidal. If a structure includes itself, a *very* tight ucode loop will occur in the instancep opcode.") (IF (EQ INCLUDE (PS-NAME PS)) (ERROR "You probably don't want ~S to include ~S." INCLUDE INCLUDE)) (IL:* IL:|;;| "ensure that the included structure is defined.") (IF (OR (NULL INCLUDED-PSTRUCTURE) (PS-TEMPLATE INCLUDED-PSTRUCTURE)) (ERROR "Included structure ~s is unknown or not instantiated." INCLUDE)) (IL:* IL:|;;| "make sure the type of the included structure is the same") (IF (OR (NOT (EQ (PS-TYPE INCLUDED-PSTRUCTURE) (PS-TYPE PS))) (NOT (EQ (PS-VECTOR-TYPE INCLUDED-PSTRUCTURE) (PS-VECTOR-TYPE PS)))) (ERROR "~s must be same type as included structure ~s" (PS-NAME PS) INCLUDE)))) (LET ((INLINE (PS-INLINE PS)) (POSSIBLE-KEYWORDS '(:ACCESSOR :PREDICATE))) (CASE INLINE ((T) (IL:* IL:|;;|  "this is the default case, so make the default be that only the accessors, predicates are inline.") (SETF (PS-INLINE PS) POSSIBLE-KEYWORDS)) ((NIL :ONLY) ) (OTHERWISE (MAPCAR #'(LAMBDA (KEYWORD) (IF (NOT (MEMBER KEYWORD POSSIBLE-KEYWORDS :TEST #'EQ)) (ERROR "~s must be one of ~s." KEYWORD POSSIBLE-KEYWORDS) )) (IF (CONSP INLINE) INLINE (SETF (PS-INLINE PS) (LIST INLINE))))))) (COND ((PS-TEMPLATE PS) (IF (NOT (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (ERROR "Templated defstructs may not be of type: ~s" (PS-TYPE PS))) (IF (OR (NOT (EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR)) (NOT (EQ (PS-PREDICATE PS) %NO-PREDICATE)) (NOT (EQ (PS-COPIER PS) %NO-COPIER)) (PS-PRINT-FUNCTION PS)) (ERROR "Templated defstructs may not have constructors predicates copiers or print functions" ))) (T (IF (PS-PRINT-FUNCTION PS) (IF (NOT (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (ERROR "A print-function can't be specified for structures of type ~s" (PS-TYPE PS))) (LET ((INCLUDE (PS-INCLUDE PS))) (IF INCLUDE (IL:* IL:|;;| "CLtL is silent, but we inherit print-functions") (SETF (PS-PRINT-FUNCTION PS) (PS-PRINT-FUNCTION (PARSED-STRUCTURE INCLUDE))) (IL:* IL:|;;| "otherwise, use the default #s style printer") (SETF (PS-PRINT-FUNCTION PS) %DEFAULT-PRINT-FUNCTION)))) (IF (AND (EQ (PS-TYPE PS) 'VECTOR) (EQ (PS-NAMED PS) T)) (IL:* IL:|;;|  "check that the vector type can actually hold the symbol required for the name.") (DEFSTRUCT-ASSERT-SUBTYPEP 'SYMBOL (PS-VECTOR-TYPE PS) ("vector of ~S cannot contain the symbol required for the :named options" (PS-VECTOR-TYPE PS)))) (IF (EQ (PS-PREDICATE PS) %NO-PREDICATE) (IL:* IL:|;;| "there is no predicate. (Note that this is not a null check. If this field is NIL the user explicitly gave NIL as the predicate.) ") (IF (OR (EQ (PS-TYPE PS) 'DATATYPE) (PS-NAMED PS)) (IL:* IL:|;;| "If this structure is type datatype or named, use the default name") (SETF (PS-PREDICATE PS) (DEFAULT-PREDICATE-NAME (PS-NAME PS))) (IL:* IL:|;;| "now set it to NIL to signal no predicate to the predicate builder.") (SETF (PS-PREDICATE PS) NIL))) (IF (EQ (PS-COPIER PS) %NO-COPIER) (IL:* IL:|;;| "Note that this is not a null check. If this field is NIL the user explicitly gave NIL as the copier ") (SETF (PS-COPIER PS) (INTERN (CONCATENATE 'STRING "COPY-" (STRING (PS-NAME PS)))))) (LET ((EXPORTNAMES (PS-EXPORT PS))) (IL:* IL:|;;| "If export-slot is nil, functions will not be exported. otherwise, export the specified functions.[Edited by TT (13-June-90)") (AND EXPORTNAMES (OR (EQ EXPORTNAMES T) (AND (NOT (LISTP EXPORTNAMES)) (NOT (SETF (PS-EXPORT PS) (SETQ EXPORTNAMES (LIST EXPORTNAMES))))) (DOLIST (EXPORTNAME EXPORTNAMES T) (OR (MEMBER EXPORTNAME %DEFSTRUCT-EXPORT-OPTIONS) (ERROR "~S is not valid option keyword for :EXPORT" EXPORTNAME)))))) (COND ((EQ (PS-CONSTRUCTORS PS) %NO-CONSTRUCTOR) (IL:* IL:|;;| "There were no constructors specified. Default the value.") (SETF (PS-CONSTRUCTORS PS) `(,(DEFAULT-CONSTRUCTOR-NAME (PS-NAME PS))))))))) (DEFUN PS-NUMBER-OF-SLOTS (PS) "the number of slots in an instance of this structure" (LENGTH (PS-ALL-SLOTS PS))) (DEFUN PS-TYPE-SPECIFIER (PS) "returns list, vector, or (vector foo)" (ECASE (PS-TYPE PS) (LIST 'LIST) (VECTOR (LET ((ELEMENT-TYPE (PS-VECTOR-TYPE PS))) (IF (IL:NEQ ELEMENT-TYPE T) `(VECTOR ,ELEMENT-TYPE) 'VECTOR))))) (IL:* IL:|;;;| "slot resolution code") (DEFUN ASSIGN-SLOT-OFFSET (PS) (IL:* IL:|;;| "Assigns the offsets for each slot for type vector and list.") (LET* ((NAME (PS-NAME PS)) (SLOTS (PS-ALL-SLOTS PS))) (ECASE (PS-TYPE PS) ((VECTOR LIST) (IL:* IL:|;;| "the field descriptor is just the offset.") (DO ((I 0 (1+ I)) (SLOT SLOTS (CDR SLOT))) ((NULL SLOT)) (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT)) I)))))) (DEFUN RESOLVE-SLOTS (LOCAL-SLOT-DESCRIPTIONS PS) (IL:* IL:|;;| "Combines the slot descriptions from the defstruct call with the included slot-descriptions from supers and the :includes option, and installs the decription in the parsed-structure") (LET ((LOCAL-SLOTS (MAPCAR #'PARSE-SLOT LOCAL-SLOT-DESCRIPTIONS)) (INCLUDED-SLOTS (MAPCAR #'PARSE-SLOT (PS-INCLUDED-SLOTS PS))) (INCLUDES (PS-INCLUDE PS))) (WHEN (PS-NAMED PS) (IL:* IL:|;;| "Adds the slot representing the name pseudo-slot. ") (IF (NOT (PS-NAMED PS)) (ERROR ":named not supplied for this defstruct")) (PUSH (NAME-SLOT PS) LOCAL-SLOTS)) (WHEN (NOT (EQ 0 (PS-INITIAL-OFFSET PS))) (IL:* IL:|;;| "Adds parsed-slots to the local-slots to represent the initial offset.") (SETQ LOCAL-SLOTS (NCONC (XCL:WITH-COLLECTION (DOTIMES (I (PS-INITIAL-OFFSET PS)) (XCL:COLLECT (OFFSET-SLOT)))) LOCAL-SLOTS))) (IF INCLUDES (LET ((SUPER-SLOTS (IL:* IL:|;;| "must copy the slots, since the accessor-name will be destructively modified to use the new conc-name.") (MAPCAR #'COPY-PARSED-SLOT (PS-ALL-SLOTS (PARSED-STRUCTURE INCLUDES))))) (IL:* IL:|;;| "update the super-slots according to the included-slots, then make all-slots be (append merged-slots local-slots)") (SETF (PS-ALL-SLOTS PS) (NCONC (MERGE-SLOTS INCLUDED-SLOTS SUPER-SLOTS PS) LOCAL-SLOTS))) (PROGN (IF INCLUDED-SLOTS (ERROR "Can't include slots when ~s includes no structure." (PS-NAME PS))) (IL:* IL:|;;| "no included slots, so the local-slots are it.") (SETF (PS-ALL-SLOTS PS) LOCAL-SLOTS))) (WHEN (AND (NULL (PS-ALL-SLOTS PS)) (EQ (PS-TYPE PS) %DEFAULT-DEFSTRUCT-TYPE)) (PUSH (DUMMY-SLOT) LOCAL-SLOTS) (SETF (PS-ALL-SLOTS PS) LOCAL-SLOTS)) (IL:* IL:|;;| "No longer require local slots to be recorded") (SETF (PS-LOCAL-SLOTS PS) LOCAL-SLOTS) (IL:* IL:|;;| "now that all slots (included, super, local and filler) have been included, we can create accessor names.") (LET ((CONC-NAME (PS-CONC-NAME PS))) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (ASSIGN-SLOT-ACCESSOR SLOT CONC-NAME))) (IL:* IL:|;;|  "we can also record slot-names for the default-structure-printer and inspector.") (SETF (PS-ALL-SLOT-NAMES PS) (MAPCAR #'PSLOT-NAME (PS-ALL-SLOTS PS))) (IL:* IL:|;;| "make sure that no slot names have been repeated (either from being explicitly listed twice in the defstruct, or using a slot name that is present in the super without using :include for the slot)") (DO ((SLOT-NAMES (PS-ALL-SLOT-NAMES PS) (CDR SLOT-NAMES))) ((NULL SLOT-NAMES)) (IF (MEMBER (CAR SLOT-NAMES) (CDR SLOT-NAMES) :TEST #'EQ) (ERROR "The slot ~s is repeated in ~s." (CAR SLOT-NAMES) (PS-ALL-SLOT-NAMES PS)))))) (DEFUN INSERT-INCLUDED-SLOT (NEW-SLOT SUPER-SLOTS PS) (IL:* IL:|;;| "Replaces the slot in super-slots that corresponds to new-slot with new-slot") (FLET ((SAME-SLOT (SLOT1 SLOT2) (EQ (PSLOT-NAME SLOT1) (PSLOT-NAME SLOT2)))) (LET* ((TAIL (MEMBER NEW-SLOT SUPER-SLOTS :TEST #'SAME-SLOT)) (OLD-SLOT (CAR TAIL))) (IF (NOT TAIL) (ERROR "included slot ~S not present in included structure ~S" (PSLOT-NAME NEW-SLOT) (PS-INCLUDE PS))) (IL:* IL:|;;| " verify the inclusion rules.") (IF (AND (PSLOT-READ-ONLY OLD-SLOT) (NOT (PSLOT-READ-ONLY NEW-SLOT))) (ERROR "included slot ~s must be read-only. It is in included structure ~S" (PSLOT-NAME NEW-SLOT) (PS-INCLUDE PS))) (DEFSTRUCT-ASSERT-SUBTYPEP (PSLOT-TYPE NEW-SLOT) (PSLOT-TYPE OLD-SLOT) ("Included slot ~S's type ~s is not a subtype of original slot type ~s" (PSLOT-NAME NEW-SLOT) (PSLOT-TYPE NEW-SLOT) (PSLOT-TYPE OLD-SLOT))) (IL:* IL:|;;| "finally, we can replace the slot") (RPLACA TAIL NEW-SLOT)))) (DEFUN MERGE-SLOTS (INCLUDED-SLOTS SUPER-SLOTS PS) (IL:* IL:|;;| "Takes the included-slots, and the local slots, then merges them with the slots from the super that aren't shadowed.") (IL:* IL:|;;| "go through the slots from the super and replace the super's def with the overriding included-slot") (DOLIST (NEW-SLOT INCLUDED-SLOTS) (INSERT-INCLUDED-SLOT NEW-SLOT SUPER-SLOTS PS)) SUPER-SLOTS) (DEFUN NAME-SLOT (PS) (IL:* IL:|;;| "Returns a parsed-slot representing the 'name' field of a structure") (PARSE-SLOT `(SI::--STRUCTURE-NAME-SLOT-- ',(PS-NAME PS) :READ-ONLY T) NIL)) (DEFUN DUMMY-SLOT () (PARSE-SLOT `(SI::--STRUCTURE-DUMMY-SLOT-- NIL :READ-ONLY T :TYPE IL:XPOINTER) NIL)) (DEFUN OFFSET-SLOT () (PARSE-SLOT `(,(GENSYM) (IL:* IL:|;;| "to make sure that names are unique, so that when the inspector works on :type list, there will be a unique name.") NIL :READ-ONLY T) NIL)) (IL:* IL:|;;;| "data layout code") (DEFUN ASSIGN-STRUCTURE-REPRESENTATION (PS) (IL:* IL:|;;|  "Determines the descriptors and returns a form to create the datatype at loadtime.") (IL:* IL:|;;| "Side effects ps.") (LET ((LOCAL-SLOTS (PS-LOCAL-SLOTS PS))) (IL:* IL:|;;| "Local slots no longer need be recorded") (SETF (PS-LOCAL-SLOTS PS) NIL) (CASE (PS-TYPE PS) ((VECTOR LIST) (IL:* IL:|;;| "just assign the the field descriptors (offsets). No run-time declaration is needed since the representation is known (list and vector)") (ASSIGN-SLOT-OFFSET PS) NIL) (DATATYPE (LET* ((LOCAL-FIELD-SPECS (MAPCAR #'(LAMBDA (SLOT) (%STRUCTURE-TYPE-TO-FIELDSPEC (PSLOT-TYPE SLOT))) LOCAL-SLOTS)) (SUPER-FIELD-SPECS (IF (PS-INCLUDE PS) (PS-FIELD-SPECIFIERS (PARSED-STRUCTURE (PS-INCLUDE PS))))) (ALL-FIELD-SPECS (APPEND SUPER-FIELD-SPECS LOCAL-FIELD-SPECS)) (STRUCTURE-NAME (PS-NAME PS))) (SETF (PS-FIELD-SPECIFIERS PS) ALL-FIELD-SPECS) (XCL:DESTRUCTURING-BIND (LENGTH &REST FIELD-DESCRIPTORS) (IL:TRANSLATE.DATATYPE (IF (NOT (PS-TEMPLATE PS)) STRUCTURE-NAME) ALL-FIELD-SPECS) (IL:* IL:|;;| "Note that this side-effects ps") (ASSIGN-FIELD-DESCRIPTORS PS FIELD-DESCRIPTORS) (IL:* IL:|;;| "save the descriptors? No, even though the ones in the dtd are for the current world, not the crosscompiling world. They are recomputed each redeclaration by TRANSLATE.DATATYPE") (IF (NOT (PS-TEMPLATE PS)) `((SI::%STRUCTURE-DECLARE-DATATYPE ',STRUCTURE-NAME ',ALL-FIELD-SPECS ',FIELD-DESCRIPTORS ,LENGTH ',(OR (PS-INCLUDE PS) %DEFAULT-STRUCTURE-INCLUDE)))))))))) (DEFUN COERCE-TYPE (ELEMENT-TYPE) (IL:* IL:|;;| "As in IL:%canonical-cml-type -- Returns the types (t, string-char, single-float, IL:xpointer, (unsigned-byte n) and (signed-byte n)") (IF (CONSP ELEMENT-TYPE) (CASE (CAR ELEMENT-TYPE) (UNSIGNED-BYTE (IL:* IL:|;;| "Let the bits hang out") (IF (> (CADR ELEMENT-TYPE) 16) T ELEMENT-TYPE)) (SIGNED-BYTE (IL:%GET-ENCLOSING-SIGNED-BYTE ELEMENT-TYPE)) (MOD (IL:* IL:|;;| "From cmlarray -- reduces (mod n) to (unsigned-byte m)") (IL:%REDUCE-MOD ELEMENT-TYPE)) (INTEGER (IL:* IL:|;;| "From cmlarray -- reduces (integer x y) to (signed-byte m)") (IL:%REDUCE-INTEGER ELEMENT-TYPE)) (MEMBER (IF (AND (EQ 2 (LENGTH (CDR ELEMENT-TYPE))) (EVERY #'(LAMBDA (ELT) (OR (EQ ELT T) (EQ ELT NIL))) (CDR ELEMENT-TYPE))) ELEMENT-TYPE T)) (T (IL:* IL:|;;| "Attempt type expansion") (LET ((EXPANDER (TYPE-EXPANDER (CAR ELEMENT-TYPE)))) (IF EXPANDER (COERCE-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T)))) (CASE ELEMENT-TYPE ((T IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER SINGLE-FLOAT STRING-CHAR) ELEMENT-TYPE) (IL:POINTER T) ((FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) 'SINGLE-FLOAT) (FIXNUM (IL:* IL:|;;|  "Could be (signed-byte 32) -- but pointer representation is more efficient") T) (CHARACTER 'STRING-CHAR) (BIT '(UNSIGNED-BYTE 1)) (T (LET ((EXPANDER (TYPE-EXPANDER ELEMENT-TYPE))) (IF EXPANDER (COERCE-TYPE (TYPE-EXPAND ELEMENT-TYPE EXPANDER)) T)))))) (DEFUN %STRUCTURE-TYPE-TO-FIELDSPEC (ELEMENT-TYPE) (IL:* IL:|;;;| "Returns the most specific InterLisp type descriptor which will hold a given type.") (IL:* IL:|;;;| "Note: This function accepts only a limited subset of the Common Lisp type specifiers: T FLOAT SINGLE-FLOAT FIXNUM BIT (MOD n) (UNSIGNED-BYTE n) INTEGER (INTEGER low high) IL:XPOINTER DOUBLE-IL:POINTER") (LET ((COERCED-TYPE (COERCE-TYPE ELEMENT-TYPE))) (IF (NOT (CONSP COERCED-TYPE)) (CASE COERCED-TYPE ((T STRING-CHAR) 'IL:POINTER) ((IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) COERCED-TYPE) ((SINGLE-FLOAT) 'IL:FLOATP) (OTHERWISE 'IL:POINTER)) (CASE (CAR COERCED-TYPE) (UNSIGNED-BYTE `(IL:BITS ,(CADR COERCED-TYPE))) (SIGNED-BYTE (CASE (CADR COERCED-TYPE) (16 'IL:SIGNEDWORD) (32 'IL:FIXP) (OTHERWISE 'IL:POINTER))) (MEMBER 'IL:FLAG) (OTHERWISE 'IL:POINTER))))) (DEFUN ASSIGN-FIELD-DESCRIPTORS (PS FIELD-DESCRIPTORS) (IL:* IL:|;;| "Assigns the field descriptors for accessing each slot of the structure") (IF (NOT (EQ (PS-TYPE PS) 'DATATYPE)) (ERROR "Not a structure of type datatype")) (DO ((F FIELD-DESCRIPTORS (CDR F)) (SLOT (PS-ALL-SLOTS PS) (CDR SLOT))) ((NULL F)) (SETF (PSLOT-FIELD-DESCRIPTOR (CAR SLOT)) (CAR F))) (IL:* IL:|;;| "DON'T record where the pointer fields are for the circle printer. it will do this when it needs them.") (IL:* IL:|;;| "(setf (ps-pointer-descriptors ps) (mapcan #'(lambda (descriptor) (case (caddr descriptor) ((il:pointer il:fullpointer il:xpointer il:fullxpointer) (list descriptor)))) field-descriptors))") ) (DEFUN STRUCTURE-POINTER-SLOTS (STRUCTURE-NAME) (IL:* IL:|;;| "record where the pointer fields are for the circle printer.") (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME))) (OR (PS-POINTER-DESCRIPTORS PS) (SETF (PS-POINTER-DESCRIPTORS PS) (MAPCAN #'(LAMBDA (DESCRIPTOR) (CASE (CADDR DESCRIPTOR) ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (LIST DESCRIPTOR)))) (MAPCAR #'PSLOT-FIELD-DESCRIPTOR (PS-ALL-SLOTS PS))))))) (IL:* IL:|;;;| "type system hooks") (DEFUN PROCESS-TYPE (PS) (IL:* IL:|;;;| "adds the structure to the common lisp type system and defines the predicate, if any.") (IF (NOT (PS-TEMPLATE PS)) (LET* ((NAME (PS-NAME PS)) (TYPE (PS-TYPE PS)) (PREDICATE (PS-PREDICATE PS)) (PREDICATE-BODY (AND PREDICATE (PREDICATE-BODY PS 'OBJECT))) (EXPORTNAME (PS-EXPORT PS))) (IF (AND PREDICATE (OR (EQ EXPORTNAME T) (MEMBER :PREDICATE EXPORTNAME))) (EXPORT PREDICATE)) (IL:* IL:\;  "Edited by TT(13-June-90) Export Option Follow up") `(,@(COND ((EQ TYPE 'DATATYPE) `((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER ',NAME) 'TYPE-EXPAND-STRUCTURE)))) ((PS-NAMED PS) `((EVAL-WHEN (EVAL LOAD COMPILE) (SETF (TYPE-EXPANDER ',NAME) 'TYPE-EXPAND-NAMED-STRUCTURE))))) ,@(WHEN PREDICATE (LET* ((INLINE (PS-INLINE PS)) (INLINE-P (AND (EQ TYPE 'DATATYPE) (OR (EQ INLINE :ONLY) (AND (CONSP INLINE) (MEMBER :PREDICATE INLINE :TEST #'EQ))))) (INLINE-ONLY-P (EQ INLINE :ONLY))) (IF (NULL INLINE-P) (IL:* IL:|;;| "Flush optimizer (a bit extreme, but also gets rid of old definline optimizers from the old defstruct") (SETF (COMPILER:OPTIMIZER-LIST PREDICATE) NIL)) `(,@(IF (NOT INLINE-ONLY-P) `((DEFUN ,PREDICATE (OBJECT) ,PREDICATE-BODY))) ,@(IF INLINE-P `((EVAL-WHEN (EVAL LOAD COMPILE) (ESTABLISH-PREDICATE ',(PS-NAME PS)))))))))))) (DEFUN PREDICATE-BODY (PS ARG) (LET ((PREDICATE (PS-PREDICATE PS)) (TYPE (PS-TYPE PS))) (CASE TYPE (DATATYPE (IL:* IL:|;;| "for datatypes, always create a predicate. Use typep") `(TYPEP ,ARG ',(PS-NAME PS))) (OTHERWISE (IL:* IL:|;;| "vectors and lists can only have a predicate if they are named") (IF (NOT (PS-NAMED PS)) (ERROR "The predicate ~s may not be specified for ~s because it is not :name'd" PREDICATE (PS-NAME PS))) `(AND (TYPEP ,ARG ',(IF (EQ TYPE 'LIST) 'CONS 'VECTOR)) (EQ ,(IF (EQ TYPE 'LIST) `(NTH ,(PS-NAME-SLOT-POSITION PS) ,ARG) `(AREF ,ARG ,(PS-NAME-SLOT-POSITION PS))) ',(PS-NAME PS))))))) (DEFUN TYPE-EXPAND-STRUCTURE (TYPE-FORM) `(:DATATYPE ,(CAR TYPE-FORM))) (DEFUN TYPE-EXPAND-NAMED-STRUCTURE (TYPE-FORM) `(SATISFIES ,(PS-PREDICATE (PARSED-STRUCTURE (CAR TYPE-FORM))))) (DEFUN PS-NAME-SLOT-POSITION (PS) "returns the offset of the name slot for ps." (LET* ((INCLUDE (PS-INCLUDE PS)) (SUPER-SLOTS (AND INCLUDE (PS-ALL-SLOTS (PARSED-STRUCTURE INCLUDE))))) (+ (PS-INITIAL-OFFSET PS) (LENGTH SUPER-SLOTS)))) (DEFUN DEFAULT-PREDICATE-NAME (STRUCTURE-NAME) (VALUES (INTERN (CONCATENATE 'STRING (STRING STRUCTURE-NAME) "-P")))) (DEFUN DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER (FORM &OPTIONAL ENVIRONMENT CONTEXT) (XCL:DESTRUCTURING-BIND (PREDICATE OBJECT) FORM (LET ((NAME (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*))) (IF (NULL NAME) (SETQ NAME (CACHE-PREDICATE-INFO PREDICATE))) (IF NAME `(TYPEP ,OBJECT ',NAME) COMPILER:PASS)))) (DEFUN CACHE-PREDICATE-INFO (PREDICATE) (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate") (LET ((PS (GET-PS-FROM-PREDICATE PREDICATE T))) (WHEN PS (SETF (GETHASH PREDICATE *DEFSTRUCT-INFO-CACHE*) (PS-NAME PS))))) (DEFCONSTANT %FUNCTION-DEFINING-FORM-KEYWORDS '(:ACCESSOR :COPIER :PREDICATE :BOA-CONSTRUCTOR :CONSTRUCTOR) "all the legal contexts for function-defining-form in defstruct") (IL:* IL:|;;;| "accessors and setfs") (DEFUN SETF-NAME (ACCESSOR-NAME) "produces the name of the setf function for this accessor" (XCL:PACK (LIST '%%SETF- ACCESSOR-NAME))) (DEFUN ACCESSOR-BODY (SLOT ARGUMENT STRUCTURE-TYPE &OPTIONAL (NO-TYPE-CHECK NIL)) (IL:* IL:|;;| "Returns a form which fetches slot from argument") (ECASE STRUCTURE-TYPE (DATATYPE `(,(IF NO-TYPE-CHECK 'IL:FFETCHFIELD 'IL:FETCHFIELD) ',(PSLOT-FIELD-DESCRIPTOR SLOT) ,ARGUMENT)) (LIST `(NTH ,(PSLOT-FIELD-DESCRIPTOR SLOT) ,ARGUMENT)) (VECTOR `(AREF ,ARGUMENT ,(PSLOT-FIELD-DESCRIPTOR SLOT))))) (DEFUN PROCESS-ACCESSORS (PS) (IF (NOT (EQ (PS-INLINE PS) :ONLY)) (IF COMPILER::*NEW-COMPILER-IS-EXPANDING* `((ESTABLISH-ACCESSORS ',(PS-NAME PS))) `((EVAL-WHEN (EVAL) (ESTABLISH-ACCESSORS ',(PS-NAME PS))) (EVAL-WHEN (LOAD) ,@(DEFINE-ACCESSORS PS)))))) (DEFUN ESTABLISH-ACCESSORS (PS-NAME) (IL:* IL:|;;| "Makes a closure for every accessor ") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (STRUCTURE-TYPE (PS-TYPE PS))) (MAPCAN #'(LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)) (EXPORTNAME (PS-EXPORT PS))) (WHEN ACCESSOR (IF (OR (EQ EXPORTNAME T) (MEMBER :ACCESSOR EXPORTNAME)) (EXPORT ACCESSOR)) (IL:* IL:\;  "Edited by TT(13-June-90) Export Option Follow up ") (SETF (SYMBOL-FUNCTION ACCESSOR) (%MAKE-ACCESSOR-CLOSURE SLOT STRUCTURE-TYPE))))) (PS-ALL-SLOTS PS)))) (DEFUN DEFINE-ACCESSORS (PS) (IL:* IL:|;;| "Returns the forms that when evaluated, define the accessors") (IL:* IL:|;;| "Only used by the byte compiler") (LET ((NAME (PS-NAME PS)) (STRUCTURE-TYPE (PS-TYPE PS))) (IL:* IL:|;;|  "the arg-name must be the structure name, since it is already in the raw-accessors.") (MAPCAN #'(LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT)) (EXPORTNAME (PS-EXPORT PS))) (WHEN ACCESSOR (IF (OR (EQ EXPORTNAME T) (MEMBER :ACCESSOR EXPORTNAME)) (EXPORT ACCESSOR)) (IL:* IL:\;  "Edited by TT(13-June-90) Export Option follow-up. ") `((DEFUN ,ACCESSOR (,NAME) ,(ACCESSOR-BODY SLOT NAME STRUCTURE-TYPE)))))) (PS-ALL-SLOTS PS)))) (DEFUN DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER (FORM &OPTIONAL ENVIRONMENT CONTEXT) (XCL:DESTRUCTURING-BIND (ACCESSOR OBJECT) FORM (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*))) (IF (NULL SLOT-INFO) (SETQ SLOT-INFO (CACHE-SLOT-INFO ACCESSOR))) (IF SLOT-INFO (XCL:DESTRUCTURING-BIND (TYPE SLOT FAST-ACCESSORS-P) SLOT-INFO (ACCESSOR-BODY SLOT OBJECT TYPE FAST-ACCESSORS-P)) 'COMPILER:PASS)))) (DEFINE-SHARED-SETF-MACRO DEFSTRUCT-SHARED-SETF-EXPANDER ACCESSOR (DATUM) (NEW-VALUE) (IL:* IL:|;;| "Shared setf expander for all defstruct slot accessors ") (LET ((SLOT-INFO (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*))) (WHEN (NULL SLOT-INFO) (SETQ SLOT-INFO (CACHE-SLOT-INFO ACCESSOR))) (XCL:DESTRUCTURING-BIND (TYPE SLOT FAST-ACCESSSOR-P) SLOT-INFO (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT))) (ECASE TYPE (DATATYPE `(,(IF FAST-ACCESSSOR-P 'IL:FREPLACEFIELD 'IL:REPLACEFIELD) ',DESCRIPTOR ,DATUM ,NEW-VALUE)) (LIST `(SETF (NTH ,DESCRIPTOR ,DATUM) ,NEW-VALUE)) (VECTOR (MACROLET ((SIMPLE-P (X) `(OR (SYMBOLP ,X) (CONSTANTP ,X)))) (IF (AND (SIMPLE-P DATUM) (SIMPLE-P NEW-VALUE)) `(XCL:ASET ,NEW-VALUE ,DATUM ,DESCRIPTOR) (LET ((D (GENSYM)) (V (GENSYM))) `(LET ((,D ,DATUM) (,V ,NEW-VALUE)) (XCL:ASET ,V ,D ,DESCRIPTOR))))))))))) (DEFUN CACHE-SLOT-INFO (ACCESSOR) (IL:* IL:|;;;| "saves the internal accessors in a hash table so that setf methods can be generated at interpret/compile time.") (LET* ((PS (GET-PS-FROM-ACCESSOR ACCESSOR)) (FAST-ACCESSORS (PS-FAST-ACCESSORS PS))) (SETF (GETHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IL:* IL:\;  "Make a copy of the slot to keep refcounts down") (LIST (PS-TYPE PS) (COPY-TREE (GET-SLOT-DESCRIPTOR-FROM-PS ACCESSOR PS)) (AND FAST-ACCESSORS T))))) (DEFUN %MAKE-ACCESSOR-CLOSURE (SLOT STRUCTURE-TYPE) (LET ((DESCRIPTOR (PSLOT-FIELD-DESCRIPTOR SLOT))) (ECASE STRUCTURE-TYPE (DATATYPE (XCL:DESTRUCTURING-BIND (TYPENAME OFFSET FIELD-DESCRIPTOR) DESCRIPTOR (CASE FIELD-DESCRIPTOR ((IL:POINTER IL:FULLPOINTER IL:XPOINTER IL:FULLXPOINTER) (  %MAKE-POINTER-ACCESSOR TYPENAME OFFSET)) (IL:FLOATP (%MAKE-FLOAT-ACCESSOR TYPENAME OFFSET)) (IL:FIXP (%MAKE-FIXP-ACCESSOR TYPENAME OFFSET)) (OTHERWISE (IL:* IL:|;;| "Must be a bit field") (LET* ((FIELD-TYPE (CAR FIELD-DESCRIPTOR)) (FIELD-ARG (CDR FIELD-DESCRIPTOR)) (SIZE (1+ (LOGAND FIELD-ARG 15))) (POSITION (- 16 (+ SIZE (ASH FIELD-ARG -4))))) (ECASE FIELD-TYPE (IL:BITS (IF (EQ SIZE 16) (%MAKE-WORD-ACCESSOR TYPENAME OFFSET) (%MAKE-BIT-ACCESSOR TYPENAME OFFSET POSITION SIZE))) (IL:FLAGBITS (IF (EQ SIZE 1) (%MAKE-FLAG-ACCESSOR TYPENAME OFFSET POSITION) (ERROR "Illegal field descriptor: ~s" DESCRIPTOR))) (IL:SIGNEDBITS (IF (EQ SIZE 16) (%MAKE-SMALL-FIXP-ACCESSOR TYPENAME OFFSET) (IL:* IL:|;;|  "Would be better to say here \"Inconvenient field descriptor\"") (ERROR "Illegal field descriptor: ~s" DESCRIPTOR))))))))) (LIST (%MAKE-LIST-ACCESSOR DESCRIPTOR)) (VECTOR (%MAKE-ARRAY-ACCESSOR DESCRIPTOR))))) (DEFUN %MAKE-LIST-ACCESSOR (OFFSET) #'(LAMBDA (LIST) (NTH OFFSET LIST))) (DEFUN %MAKE-ARRAY-ACCESSOR (OFFSET) #'(LAMBDA (VECTOR) (AREF VECTOR OFFSET))) (DEFUN %MAKE-POINTER-ACCESSOR (TYPE OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEPTR OBJECT OFFSET))) #'(LAMBDA (OBJECT) (IL:\\GETBASEPTR OBJECT OFFSET)))) (DEFUN %MAKE-BIT-ACCESSOR (TYPE WORD-OFFSET OFFSET SIZE) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (LDB (BYTE SIZE OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET)))) #'(LAMBDA (OBJECT) (LDB (BYTE SIZE OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))) (DEFUN %MAKE-FLAG-ACCESSOR (TYPE WORD-OFFSET OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (NOT (EQ 0 (LDB (BYTE 1 OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET)))))) #'(LAMBDA (OBJECT) (NOT (EQ 0 (LDB (BYTE 1 OFFSET) (IL:\\GETBASE OBJECT WORD-OFFSET))))))) (DEFUN %MAKE-WORD-ACCESSOR (TYPE OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASE OBJECT OFFSET))) #'(LAMBDA (OBJECT) (IL:\\GETBASE OBJECT OFFSET)))) (DEFUN %MAKE-FIXP-ACCESSOR (TYPE OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEFIXP OBJECT OFFSET))) #'(LAMBDA (OBJECT) (IL:\\GETBASEFIXP OBJECT OFFSET)))) (DEFUN %MAKE-SMALL-FIXP-ACCESSOR (TYPE OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASESMALL-FIXP OBJECT OFFSET))) #'(LAMBDA (OBJECT) (IL:\\GETBASESMALL-FIXP OBJECT OFFSET)))) (DEFUN %MAKE-FLOAT-ACCESSOR (TYPE OFFSET) (IF TYPE #'(LAMBDA (OBJECT) (IF (NOT (IL:\\INSTANCE-P OBJECT TYPE)) (ERROR "Arg not ~s: ~s" TYPE OBJECT) (IL:\\GETBASEFLOATP OBJECT OFFSET))) #'(LAMBDA (OBJECT) (IL:\\GETBASEFLOATP OBJECT OFFSET)))) (IL:* IL:|;;;| "constructor definition code") (DEFUN DEFINE-CONSTRUCTORS (PS) (IL:* IL:|;;| "Returns the forms that when evaluated, define the constructors") (IF (NOT (PS-TEMPLATE PS)) (LET* ((CONSTRUCTORS (PS-CONSTRUCTORS PS)) (SLOTS (PS-ALL-SLOTS PS)) (RESULT-ARG (PS-NAME PS)) (ALL-BOAS? (EVERY #'BOA-CONSTRUCTOR-P CONSTRUCTORS)) (EXPORTNAME (PS-EXPORT PS))) (IF (OR (EQ EXPORTNAME T) (MEMBER :CONSTRUCTOR EXPORTNAME)) (EXPORT CONSTRUCTORS)) (IL:* IL:\;  "Edited by TT(13-June-90) Export Option Follow up") (COND (ALL-BOAS? (IL:* IL:|;;| "don't bother building the arglist etc.") (MAPCAR #'(LAMBDA (CONSTRUCTOR) (DEFINE-BOA-CONSTRUCTOR CONSTRUCTOR PS)) CONSTRUCTORS)) (T (LET* ((ARGUMENT-LIST (BUILD-CONSTRUCTOR-ARGLIST SLOTS)) (SLOT-SETFS (BUILD-CONSTRUCTOR-SLOT-SETFS SLOTS ARGUMENT-LIST PS))) (XCL:WITH-COLLECTION (DOLIST (CONSTRUCTOR CONSTRUCTORS) (XCL:COLLECT (COND ((BOA-CONSTRUCTOR-P CONSTRUCTOR) (DEFINE-BOA-CONSTRUCTOR CONSTRUCTOR PS)) (T (IL:* IL:|;;|  "keep the name of a standard constructor, if any, so that the #s form can work.") (SETF (PS-STANDARD-CONSTRUCTOR PS) CONSTRUCTOR) (IL:* IL:|;;|  "since we just built the object we're setting fields of, we don't need to type check it.") `(DEFUN ,CONSTRUCTOR (&KEY ,@ARGUMENT-LIST) (LET ((,RESULT-ARG ,(RAW-CONSTRUCTOR PS))) ,@SLOT-SETFS ,RESULT-ARG))))))))))))) (DEFUN DEFINE-BOA-CONSTRUCTOR (NAME&ARGLIST PS) (LET* ((CONSTRUCTOR-NAME (CAR NAME&ARGLIST)) (ARGLIST (CADR NAME&ARGLIST)) (NEW-ARGUMENT-LIST (BOA-ARG-LIST-WITH-INITIAL-VALUES ARGLIST PS)) (RESULT-ARG (PS-NAME PS)) (SLOT-SETFS (BOA-SLOT-SETFS RESULT-ARG (ARGUMENT-NAMES NEW-ARGUMENT-LIST) PS))) `(DEFUN ,CONSTRUCTOR-NAME ,NEW-ARGUMENT-LIST (LET ((,RESULT-ARG ,(RAW-CONSTRUCTOR PS))) ,@SLOT-SETFS ,RESULT-ARG)))) (DEFUN ARGUMENT-NAMES (ARG-LIST) (MAPCAN #'(LAMBDA (ARG) (COND ((CONSP ARG) (LIST ARG)) ((MEMBER ARG LAMBDA-LIST-KEYWORDS) NIL) (T (LIST (LIST ARG :REQUIRED-ARG))))) ARG-LIST)) (DEFUN BOA-ARG-LIST-WITH-INITIAL-VALUES (ARG-LIST PS) (LET ((NEW-ARG-LIST (COPY-TREE ARG-LIST)) (SLOTS (PS-ALL-SLOTS PS))) (IL:* IL:|;;| "for all the args from &optional up to &rest or &aux get the default value.") (IL:FOR ARG-TAIL IL:ON (CDR (MEMBER '&OPTIONAL NEW-ARG-LIST)) IL:DO (COND ((MEMBER (CAR ARG-TAIL) LAMBDA-LIST-KEYWORDS) (IL:* IL:|;;| "we have found an ampersand arg, we're done the optionals.") (RETURN)) (T (LET ((OPTIONAL (CAR ARG-TAIL))) (SETF (CAR ARG-TAIL) (COND ((MEMBER OPTIONAL '(&REST &AUX)) (IL:* IL:|;;|  "we have hit the end of the optionals, just return.") (RETURN)) ((MEMBER OPTIONAL LAMBDA-LIST-KEYWORDS) (IL:* IL:|;;| "illegal keyword here") (ERROR "~S cannot appear in a BOA constructor as it does in ~S." OPTIONAL ARG-LIST)) ((SYMBOLP OPTIONAL) (LET ((INTIAL-VALUE-FORM (PSLOT-INITIAL-VALUE (FIND-SLOT OPTIONAL SLOTS)))) (IF INTIAL-VALUE-FORM `(,OPTIONAL ,INTIAL-VALUE-FORM) `(,OPTIONAL NIL ,(IL:GENSYM))))) ((AND (CONSP OPTIONAL) (CDR OPTIONAL)) (IL:* IL:|;;| "already a default just leave it alone") OPTIONAL) ((CONSP OPTIONAL) (LET ((INTIAL-VALUE-FORM (PSLOT-INITIAL-VALUE (FIND-SLOT (CAR OPTIONAL) SLOTS)))) (IF INTIAL-VALUE-FORM `(,(CAR OPTIONAL) ,INTIAL-VALUE-FORM) `(,(CAR OPTIONAL) NIL ,(IL:GENSYM))))))))))) NEW-ARG-LIST)) (DEFUN BOA-SLOT-SETFS (RESULT-ARG SLOT-NAMES PS) (LET ((STRUCTURE-TYPE (PS-TYPE PS))) (XCL:WITH-COLLECTION (LET (SLOT-PLACE SLOT-NAME SLOT-ARGUMENT) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (SETQ SLOT-NAME (PSLOT-NAME SLOT)) (SETQ SLOT-PLACE (ACCESSOR-BODY SLOT RESULT-ARG STRUCTURE-TYPE T)) (SETQ SLOT-ARGUMENT (ASSOC SLOT-NAME SLOT-NAMES :TEST #'EQ)) (XCL:COLLECT (IF SLOT-ARGUMENT (LET ((SUPPLIED-P (CADDR SLOT-ARGUMENT))) (IF SUPPLIED-P `(IF ,SUPPLIED-P (SETF ,SLOT-PLACE ,SLOT-NAME)) `(SETF ,SLOT-PLACE ,SLOT-NAME))) `(SETF ,SLOT-PLACE ,(PSLOT-INITIAL-VALUE SLOT))))))))) (DEFUN FIND-SLOT (NAME SLOTS &OPTIONAL (DONT-ERROR NIL)) (DOLIST (SLOT SLOTS (OR DONT-ERROR (ERROR "slot ~s not found." NAME))) (IF (EQ NAME (PSLOT-NAME SLOT)) (RETURN SLOT)))) (DEFUN RAW-CONSTRUCTOR (PS) (IL:* IL:|;;| "Returns a form which will make an instance of this structure w/o initialisation") (ECASE (PS-TYPE PS) (DATATYPE `(IL:NCREATE ',(PS-NAME PS))) (LIST `(MAKE-LIST ,(PS-NUMBER-OF-SLOTS PS))) (VECTOR `(MAKE-ARRAY '(,(PS-NUMBER-OF-SLOTS PS)) :ELEMENT-TYPE ',(PS-VECTOR-TYPE PS))))) (DEFUN BUILD-CONSTRUCTOR-ARGLIST (SLOTS) (IL:* IL:|;;| "Gathers the keywords and initial-values for (non BOA) constructors") (MAPCAN #'(LAMBDA (SLOT) (LET* ((INIT-FORM (PSLOT-INITIAL-VALUE SLOT)) (ARG-NAME (PSLOT-NAME SLOT)) (KEYWORD-PAIR `(,(VALUES (INTERN (SYMBOL-NAME ARG-NAME) 'KEYWORD)) ,(GENSYM)))) (COND ((NOT (PSLOT-ACCESSOR SLOT)) (IL:* IL:|;;|  "this is an invisible slot (name, initial-offset, etc.) don't generate a keyword arg") NIL) (INIT-FORM (IL:* IL:|;;| "specify an initial value for the keyword arg") `((,KEYWORD-PAIR ,INIT-FORM))) (T `((,KEYWORD-PAIR NIL ,(GENSYM))))))) SLOTS)) (DEFUN BUILD-CONSTRUCTOR-SLOT-SETFS (SLOTS ARGUMENT-LIST PS) (IL:* IL:|;;| "Builds the setfs that initialize the slots in a constructor") (LET ((STRUCTURE-TYPE (PS-TYPE PS)) (OBJECT-NAME (PS-NAME PS)) (ARGUMENT-LIST ARGUMENT-LIST)) (IL:* IL:|;;| "The argument list does not have arguments for \"invisible\" slots.") (MAPCAR #'(LAMBDA (SLOT) (COND ((NOT (PSLOT-ACCESSOR SLOT)) (IL:* IL:|;;|  "invisible slot, so generate a setf to it's initial-value") `(SETF ,(ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T) ,(PSLOT-INITIAL-VALUE SLOT))) (T (LET* ((ARGUMENT (POP ARGUMENT-LIST)) (KEYWORD-VAR-NAME (CADAR ARGUMENT)) (INITIAL-VALUE-FORM (CADR ARGUMENT))) (IL:* IL:|;;|  "since slots can be read-only, we setf the raw accessor, not the slot accessor.") (IL:* IL:|;;| "Also, since we built the object in which we are setting fields, we use the internal-accessor without typecheck") (IF INITIAL-VALUE-FORM `(SETF ,(ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T ) ,KEYWORD-VAR-NAME) `(IF ,(CADDR ARGUMENT) (SETF ,(ACCESSOR-BODY SLOT OBJECT-NAME STRUCTURE-TYPE T) ,KEYWORD-VAR-NAME))))))) SLOTS))) (DEFUN BOA-CONSTRUCTOR-P (CONSTRUCTOR) (IL:* IL:|;;| "Returns t if the constructor is a By Order of Arguments constructor") (CONSP CONSTRUCTOR)) (DEFUN DEFAULT-CONSTRUCTOR-NAME (STRUCTURE-NAME) (VALUES (INTERN (CONCATENATE 'STRING "MAKE-" (STRING STRUCTURE-NAME))))) (IL:* IL:|;;;| "copiers") (DEFUN DEFINE-COPIERS (PS) (IL:* IL:|;;| "Returns the form that when evaluated, defines the copier") (IF (NOT (PS-TEMPLATE PS)) (LET ((COPIER (PS-COPIER PS)) (RESULT-ARG 'NEW) (FROM-ARG (PS-NAME PS))) (IF COPIER (MULTIPLE-VALUE-BIND (FROM-ARG-TYPE-CHECK TYPE-CHECK-SLOTS?) (BUILD-COPIER-TYPE-CHECK PS FROM-ARG) (LET ((SLOT-SETFS (BUILD-COPIER-SLOT-SETFS (PS-ALL-SLOTS PS) (PS-TYPE PS) FROM-ARG RESULT-ARG TYPE-CHECK-SLOTS?)) (EXPORTNAME (PS-EXPORT PS))) (IF (OR (EQ EXPORTNAME T) (MEMBER :COPIER EXPORTNAME)) (EXPORT (PS-COPIER PS))) (IL:* IL:\;  "Edited by TT(13-June-90) Export Option follow up") (IL:* IL:|;;|  "Since we just built the object we're setting fields of, we don't need to type check it.") `((DEFUN ,(PS-COPIER PS) (,FROM-ARG) ,@FROM-ARG-TYPE-CHECK (LET ((,RESULT-ARG ,(RAW-CONSTRUCTOR PS))) ,@SLOT-SETFS ,RESULT-ARG))))))))) (DEFUN BUILD-COPIER-SLOT-SETFS (SLOTS STRUCTURE-TYPE FROM-ARGUMENT TO-ARGUMENT TYPE-CHECK-SLOTS?) "constructs the forms that copy each individual slot." (IL:* IL:|;;| "build a series of forms that look like") (IL:* IL:|;;| "(setf (structure-slot to-arg) (structure-slot from-arg))") (MAPCAR #'(LAMBDA (SLOT) `(SETF ,(ACCESSOR-BODY SLOT TO-ARGUMENT STRUCTURE-TYPE T) ,(ACCESSOR-BODY SLOT FROM-ARGUMENT STRUCTURE-TYPE T))) SLOTS)) (DEFUN BUILD-COPIER-TYPE-CHECK (PS FROM-ARG) (IL:* IL:|;;| "Constructs the type checking form at the beginning of the copier and decides whether individual slots need to be type-checked.") (COND ((EQ (PS-TYPE PS) 'DATATYPE) (IL:* IL:|;;| "If something is a datatype type check the from-arg once at the beginning. Don't check the individual accesses.") (VALUES `((CHECK-TYPE ,FROM-ARG ,(PS-NAME PS))) NIL)) ((PS-PREDICATE PS) (IL:* IL:|;;| "if the structure has a predicate ,then call the predicate.") (VALUES `((OR (,(PS-PREDICATE PS) ,FROM-ARG) (ERROR ,(FORMAT NIL "Arg not ~s: ~~S" (PS-NAME PS)) ,FROM-ARG))) NIL)) (T (IL:* IL:|;;| "Otherwise, just use the type-checked slot access, so that at least the argument is assured to be a vector/list.") (VALUES NIL T)))) (IL:* IL:|;;;| "print functions") (DEFVAR %DEFAULT-PRINT-FUNCTION 'DEFAULT-STRUCTURE-PRINTER "print function used when none is specified in a defstruct") (IL:* IL:|;;;| "internal stuff.") (DEFSETF IL:FFETCHFIELD IL:FREPLACEFIELD) (IL:* IL:|;;;| "utilities") (DEFMACRO DEFSTRUCT-ASSERT-SUBTYPEP (TYPE1 TYPE2 (ERROR-STRING . ERROR-ARGS) &REST CERROR-ACTIONS) (IL:* IL:|;;|  "Provides an interface for places where the implementor isn't sure that subtypep can be trusted") (LET ((ERROR-STRING (OR ERROR-STRING "~S is not a subtype of ~S")) (ERROR-ARGS (OR ERROR-ARGS (LIST TYPE1 TYPE2)))) `(MULTIPLE-VALUE-BIND (SUBTYPE? CERTAIN?) (SUBTYPEP ,TYPE1 ,TYPE2) (COND (SUBTYPE? (IL:* IL:\; "it's ok, continue") T) (CERTAIN? (IL:* IL:\;  "subtypep says it sure, so blow up") (ERROR ,ERROR-STRING ,@ERROR-ARGS)) (T (IL:* IL:\;  "subtypep isn't sure, so raise a continuable error") (CERROR "Assume subtypep should return t" ,(FORMAT NIL "Perhaps, ~a" ERROR-STRING) ,@ERROR-ARGS) ,@CERROR-ACTIONS T))))) (IL:* IL:|;;;| "inspecting structures") (DEFUN STRUCTURE-OBJECT-P (OBJECT) (TYPEP OBJECT 'STRUCTURE-OBJECT)) (DEFUN INSPECT-STRUCTURE-OBJECT (STRUCTURE OBJECTTYPE WHERE) "calls the system facilities with the appropriate slots and functions." (IL:INSPECTW.CREATE STRUCTURE (PS-ALL-SLOTS (PARSED-STRUCTURE (TYPE-OF STRUCTURE))) 'STRUCTURE-OBJECT-INSPECT-FETCHFN 'STRUCTURE-OBJECT-INSPECT-STOREFN 'STRUCTURE-OBJECT-PROPCOMMANDFN NIL NIL (LET ((XCL:*PRINT-STRUCTURE* NIL)) (CONCATENATE 'STRING (PRINC-TO-STRING STRUCTURE) " Inspector")) NIL WHERE 'STRUCTURE-OBJECT-INSPECT-PROPPRINTFN)) (DEFUN STRUCTURE-OBJECT-INSPECT-FETCHFN (OBJECT PROPERTY) (IF (PSLOT-ACCESSOR PROPERTY) (FUNCALL (PSLOT-ACCESSOR PROPERTY) OBJECT) (IL:FETCHFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY) OBJECT))) (DEFUN STRUCTURE-OBJECT-INSPECT-PROPPRINTFN (PROPERTY DATUM) (PSLOT-NAME PROPERTY)) (DEFUN STRUCTURE-OBJECT-INSPECT-STOREFN (OBJECT PROPERTY NEWVALUE) (IL:* IL:|;;|  "this effectively does (eval `(setf (,(pslot-accessor property) object) newvalue)) ") (IF (PSLOT-ACCESSOR PROPERTY) (EVAL `(SETF (,(PSLOT-ACCESSOR PROPERTY) ',OBJECT) ',NEWVALUE)) (IL:REPLACEFIELD (PSLOT-FIELD-DESCRIPTOR PROPERTY) OBJECT NEWVALUE))) (DEFUN STRUCTURE-OBJECT-PROPCOMMANDFN (PROPERTY DATUM INSPECTOR-WINDOW) (IF (AND (TYPEP DATUM 'STRUCTURE-OBJECT) (PSLOT-READ-ONLY PROPERTY)) (IL:PROMPTPRINT "Can't set a read-only slot.") (IL:DEFAULT.INSPECTW.PROPCOMMANDFN PROPERTY DATUM INSPECTOR-WINDOW))) (IL:* IL:|;;| "Defined last so functions required to load a defstruct are loaded first") (DEFSTRUCT (PS (:TYPE LIST) :NAMED) (IL:* IL:|;;;| "Contains the parsed information for a SINGLE structure type") (IL:* IL:|;;| "most values are not defaulted here, because the defaults depend on other slot values (e.g. predicate depends on type and named.) These defaults are installed in ensure-consistent-ps.") (NAME) (IL:* IL:\;  "The name of the structure") (STANDARD-CONSTRUCTOR) (IL:* IL:\;  "Contains the constructor to be used by the #s reader.") (ALL-SLOT-NAMES) (IL:* IL:\;  "The slot-name list used by the inspector.") (TYPE %DEFAULT-DEFSTRUCT-TYPE) (IL:* IL:\;  "Is this structure a datatype, list or vector.") (VECTOR-TYPE) (IL:* IL:\;  "If its a vector, this is the element-type of the vector") (INCLUDE NIL) (IL:* IL:\;  "The included structure, if any.") (CONC-NAME) (CONSTRUCTORS %NO-CONSTRUCTOR) (IL:* IL:\;  "A list of the constructors for this structure. Boas have the argument list, not just the name.") (PREDICATE %NO-PREDICATE) (PRINT-FUNCTION) (COPIER %NO-COPIER) (NAMED NIL) (INITIAL-OFFSET 0) (LOCAL-SLOTS NIL) (IL:* IL:\;  "The slot descriptors for slots present locally (not included).") (ALL-SLOTS) (IL:* IL:\;  "The list of slot descriptors for every slot present in an instance of this slot.") (INCLUDED-SLOTS) (IL:* IL:\;  "Slots specified in the :include option.") (IL:* IL:|;;| "Redundant") (DOCUMENTATION-STRING) (IL:* IL:|;;| "Unused") (FIELD-SPECIFIERS) (IL:* IL:\; "The position of each slot in the structure. For vectors and list structures, it is just an offset. For datatypes, it is a field-specifier for fetchield.") (IL:* IL:|;;| "Unused") (POINTER-DESCRIPTORS) (IL:* IL:\; "the descriptors for all fields which the circle-printer must scan. It is filled in the first time it is needed.") (INLINE T) (IL:* IL:\;  "Flag telling whether or not functions built by defstruct are inline or not.") (FAST-ACCESSORS NIL) (IL:* IL:\; "Flag telling whether or not accessor functions should check the type of the object before slot accesses.") (TEMPLATE NIL) (IL:* IL:\; "As in IL:BLOCKRECORD. Implies type datatype, no copier, predicate or constructors, and fast accessors. No datatype is declared for this option.") (EXPORT NIL) (IL:* IL:\;  "EXPORT indicates export of Structure's functions") ) (DEFSTRUCT (PARSED-SLOT (:CONC-NAME PSLOT-) (:TYPE LIST)) "describes a single slot in a structure" (NAME NIL :TYPE SYMBOL) (INITIAL-VALUE NIL) (TYPE %DEFAULT-SLOT-TYPE) (READ-ONLY NIL) FIELD-DESCRIPTOR ACCESSOR) (IL:* IL:|;;| "Mapping between names of generated functions and their associated structures") (DEFUN STRUCTURE-FUNCTION-P (SYMBOL) (CATCH 'FOUND (MAPHASH #'(LAMBDA (KEY PS) (IF (OR (AND (CONSP (PS-CONSTRUCTORS PS)) (MEMBER SYMBOL (PS-CONSTRUCTORS PS) :TEST #'EQ)) (EQ SYMBOL (PS-PREDICATE PS)) (EQ SYMBOL (PS-COPIER PS)) (DOLIST (SLOT (PS-ALL-SLOTS PS)) (IF (EQ SYMBOL (PSLOT-ACCESSOR SLOT)) (RETURN (PS-NAME PS))))) (THROW 'FOUND KEY))) *PARSED-DEFSTRUCTS*))) (DEFUN STRUCTURE-FUNCTIONS (STRUCTURE-NAME) (LET ((PS (PARSED-STRUCTURE STRUCTURE-NAME))) `(,@(PS-CONSTRUCTORS PS) ,.(LET ((PREDICATE (PS-PREDICATE PS))) (IF PREDICATE (LIST PREDICATE))) ,.(LET ((COPIER (PS-COPIER PS))) (IF COPIER (LIST COPIER))) ,.(MAPCAN #'(LAMBDA (SLOT) (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (AND ACCESSOR (LIST ACCESSOR)))) (PS-ALL-SLOTS PS))))) (IL:* IL:|;;;| "Editing structures") (DEFUN STRUCTURES.HASDEF (NAME &OPTIONAL TYPE SOURCE SPELLFLG) (OR (IL:GETDEF NAME 'IL:STRUCTURES 'IL:CURRENT '(IL:NODWIM IL:NOCOPY IL:NOERROR IL:HASDEF)) (STRUCTURE-FUNCTION-P NAME))) (DEFUN STRUCTURES.EDITDEF (NAME TYPE SOURCE EDITCOMS OPTIONS) "From accessor function or structure name, edit the structure." (IF (PARSED-STRUCTURE NAME T) (IL:DEFAULT.EDITDEF NAME 'IL:STRUCTURES SOURCE EDITCOMS OPTIONS) (LET ((STRUCTURE-NAME (STRUCTURE-FUNCTION-P NAME))) (IF STRUCTURE-NAME (IL:DEFAULT.EDITDEF STRUCTURE-NAME 'IL:STRUCTURES SOURCE EDITCOMS OPTIONS) (IL:DEFAULT.EDITDEF NAME TYPE SOURCE EDITCOMS OPTIONS)))) NAME) (IL:FILEPKGTYPE 'IL:STRUCTURES 'IL:HASDEF 'STRUCTURES.HASDEF 'IL:EDITDEF 'STRUCTURES.EDITDEF) (IL:ADDTOVAR IL:SHADOW-TYPES (IL:STRUCTURES IL:FNS)) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:ADDTOVAR IL:INSPECTMACROS ((IL:FUNCTION STRUCTURE-OBJECT-P) . INSPECT-STRUCTURE-OBJECT)) ) (IL:* IL:|;;;| "file properties") (IL:PUTPROPS IL:DEFSTRUCT IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:DEFSTRUCT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:DEFSTRUCT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1900 1988 1989 1990 1992 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/DEFSTRUCT-RUN-TIME b/sources/DEFSTRUCT-RUN-TIME new file mode 100644 index 00000000..ad5b0ab0 --- /dev/null +++ b/sources/DEFSTRUCT-RUN-TIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED " 4-Jan-93 18:09:50" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT-RUN-TIME.;2| 16909 IL:|previous| IL:|date:| "16-May-90 15:32:24" IL:|{DSK}lde>lispcore>sources>DEFSTRUCT-RUN-TIME.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DEFSTRUCT-RUN-TIMECOMS) (IL:RPAQQ IL:DEFSTRUCT-RUN-TIMECOMS ((IL:COMS (IL:* IL:|;;| "Remembering parsed structures") (IL:VARIABLES *PARSED-DEFSTRUCTS*) (IL:FUNCTIONS PARSED-STRUCTURE SET-PARSED-STRUCTURE) (IL:SETFS PARSED-STRUCTURE)) (IL:COMS (IL:* IL:|;;| "Declaring storage for structures") (IL:FUNCTIONS SI::%STRUCTURE-DECLARE-DATATYPE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:* IL:|;;|  "This defines the root of the defstruct type hierarchy.") (IL:P (IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0)))) (IL:COMS (IL:* IL:|;;| "Support for setf expansions etc") (IL:VARIABLES *DEFSTRUCT-INFO-CACHE*) (IL:FUNCTIONS ESTABLISH-SETFS-AND-OPTIMIZERS ESTABLISH-PREDICATE) (IL:FUNCTIONS GET-PS-FROM-ACCESSOR GET-PS-FROM-PREDICATE GET-SLOT-DESCRIPTOR-FROM-PS) (IL:FUNCTIONS CACHE-SETF-INFO)) (IL:COMS (IL:* IL:|;;| "defstruct IO") (IL:VARIABLES XCL:*PRINT-STRUCTURE*) (IL:FUNCTIONS PRINT-STRUCTURE-INSTANCE DEFAULT-STRUCTURE-PRINTER STRUCTURE-SLOT-NAMES ) (IL:* IL:|;;| "For reading") (IL:FUNCTIONS IL:CREATE-STRUCTURE STRUCTURE-CONSTRUCTOR)) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:DEFSTRUCT-RUN-TIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA))))) (IL:* IL:|;;| "Remembering parsed structures") (DEFVAR *PARSED-DEFSTRUCTS* (IL:HASHARRAY 100) (IL:* IL:|;;| "All declared structures") ) (DEFMACRO PARSED-STRUCTURE (NAME &OPTIONAL (NO-ERROR NIL)) (IL:* IL:|;;| "Returns the parsed-structure corresponding to name") (COND (NO-ERROR `(IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*)) (T `(OR (IL:GETHASH ,NAME *PARSED-DEFSTRUCTS*) (ERROR "~s is not a defined structure" ,NAME))))) (DEFUN SET-PARSED-STRUCTURE (NAME PS &OPTIONAL (EXTRA NIL EXTRA-P)) (IL:* IL:|;;| "SETF method for CL::PARSED-STRUCTURE. Extra arg is because CL::PARSED-STRUCTURE takes an optional, which we ignore here, but that pushes the new value over one.") (WHEN EXTRA-P (SETQ PS EXTRA)) (IL:PUTHASH NAME PS *PARSED-DEFSTRUCTS*)) (DEFSETF PARSED-STRUCTURE SET-PARSED-STRUCTURE) (IL:* IL:|;;| "Declaring storage for structures") (DEFUN SI::%STRUCTURE-DECLARE-DATATYPE (NAME FIELD-SPECIFICATIONS FIELD-DESCRIPTORS WORD-LENGTH SUPERTYPE) (IL:* IL:|;;;| "analagous to declare-datatype, but does not prepend the supers descriptors. You must include all descs.") (IL:* IL:|;;;| "N.B. descriptions and specs are for ALL slots, not just local-slots.") (IL:* IL:|;;| "field-specifications is a list of the form '(pointer pointer (bits 3) (bits 5) word fixp). See p. 8.21 IRM") (IL:* IL:|;;| "field-descriptors is the list returned from translate.datatype when given the above FIELD-SPECIFICATIONS. They are legal to pass to fetchfield.") (IL:* IL:|;;| "word-length is the car of the result of translate.datatype.") (IL:* IL:|;;| "supertype is the typename of the supertype.") (IF (NOT (AND (SYMBOLP NAME) (IL:SMALLPOSP WORD-LENGTH))) (ERROR "Illegal arguments: ~s ~s" NAME WORD-LENGTH)) (LET ((REFERENCE-COUNTED-POINTERS (MAPCAN #'(LAMBDA (DESCRIPTOR) (CASE (CADDR DESCRIPTOR) ((IL:POINTER IL:FULLPOINTER) (LIST (CADR DESCRIPTOR))))) FIELD-DESCRIPTORS))) (MULTIPLE-VALUE-BIND (TYPE-NUMBER REDECLARED?) (IL:\\ASSIGNDATATYPE1 NAME FIELD-DESCRIPTORS WORD-LENGTH FIELD-SPECIFICATIONS REFERENCE-COUNTED-POINTERS SUPERTYPE) (IL:* IL:|;;| "set the magic global to the allocated type number") (IL:SETTOPVAL (IL:\\TYPEGLOBALVARIABLE NAME T) TYPE-NUMBER) (VALUES FIELD-DESCRIPTORS REDECLARED?)))) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:\\ASSIGNDATATYPE1 'STRUCTURE-OBJECT NIL 0) ) (IL:* IL:|;;| "Support for setf expansions etc") (DEFVAR *DEFSTRUCT-INFO-CACHE* (IL:HASHARRAY 100) (IL:* IL:|;;| "Used to cache slots and predicates") ) (DEFUN ESTABLISH-SETFS-AND-OPTIMIZERS (PS-NAME) (IL:* IL:|;;| "Caches shared setf expanders and accessor optimizers where appropriate") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (INLINE (PS-INLINE PS))) (MAPC #'(LAMBDA (SLOT) (IL:* IL:|;;|  "function-defining-form decides whether or not the accessors should be defun, definline, etc.") (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (WHEN ACCESSOR (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IF (NOT (PSLOT-READ-ONLY SLOT)) (IL:* IL:|;;|  "install the setf method expander that is shared for all accessors") (SET-SHARED-SETF-INVERSE ACCESSOR 'DEFSTRUCT-SHARED-SETF-EXPANDER)) (COND ((EQ INLINE :ONLY) (SETF (MACRO-FUNCTION ACCESSOR) 'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER)) ((MEMBER :ACCESSOR INLINE :TEST #'EQ) (SETF (GET ACCESSOR 'COMPILER:OPTIMIZER-LIST) (LIST 'DEFSTRUCT-SHARED-ACCESSOR-OPTIMIZER))) (T (REMPROP ACCESSOR 'COMPILER:OPTIMIZER-LIST)))))) (PS-ALL-SLOTS PS)))) (DEFUN ESTABLISH-PREDICATE (PS-NAME) (IL:* IL:|;;| "Establishes a shared a shared optimizer for a defstruct predicate") (LET* ((PS (PARSED-STRUCTURE PS-NAME)) (PREDICATE (PS-PREDICATE PS))) (REMHASH PREDICATE *DEFSTRUCT-INFO-CACHE*) (IF (EQ (PS-INLINE PS) :ONLY) (SETF (MACRO-FUNCTION PREDICATE) 'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER) (SETF (GET PREDICATE 'COMPILER:OPTIMIZER-LIST) (LIST 'DEFSTRUCT-SHARED-PREDICATE-OPTIMIZER))))) (DEFUN GET-PS-FROM-ACCESSOR (ACCESSOR &OPTIONAL (NO-ERROR-P NIL)) (OR (CATCH 'FIND-PS (MAPHASH #'(LAMBDA (KEY VALUE) (DOLIST (SLOT (PS-ALL-SLOTS VALUE) NIL) (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT)) (THROW 'FIND-PS VALUE)))) *PARSED-DEFSTRUCTS*)) (IF (NULL NO-ERROR-P) (ERROR "No such slot: ~s" ACCESSOR)))) (DEFUN GET-PS-FROM-PREDICATE (PREDICATE &OPTIONAL (NO-ERROR-P NIL)) (OR (CATCH 'FIND-PS (MAPHASH #'(LAMBDA (KEY VALUE) (IF (EQ PREDICATE (PS-PREDICATE VALUE)) (THROW 'FIND-PS VALUE))) *PARSED-DEFSTRUCTS*)) (IF (NULL NO-ERROR-P) (ERROR "No such predicate: ~s" PREDICATE)))) (DEFUN GET-SLOT-DESCRIPTOR-FROM-PS (ACCESSOR PS &OPTIONAL (NO-ERROR-P NIL)) (OR (DOLIST (SLOT (PS-ALL-SLOTS PS) NIL) (IF (EQ ACCESSOR (PSLOT-ACCESSOR SLOT)) (RETURN SLOT))) (IF (NULL NO-ERROR-P) (ERROR "No such slot: ~s" ACCESSOR)))) (DEFUN CACHE-SETF-INFO (PS-NAME) (IL:* IL:|;;| "For compatability with the old defstruct") (LET ((PS (PARSED-STRUCTURE PS-NAME))) (MAPC #'(LAMBDA (SLOT) (IL:* IL:|;;|  "function-defining-form decides whether or not the accessors should be defun, definline, etc.") (LET ((ACCESSOR (PSLOT-ACCESSOR SLOT))) (WHEN ACCESSOR (REMHASH ACCESSOR *DEFSTRUCT-INFO-CACHE*) (IF (NOT (PSLOT-READ-ONLY SLOT)) (IL:* IL:|;;|  "install the setf method expander that is shared for all accessors") (SET-SHARED-SETF-INVERSE ACCESSOR 'DEFSTRUCT-SHARED-SETF-EXPANDER))))) (PS-ALL-SLOTS PS)))) (IL:* IL:|;;| "defstruct IO") (DEFVAR XCL:*PRINT-STRUCTURE* T "Flag indicating whether the contents of structures are to be printed.") (DEFUN PRINT-STRUCTURE-INSTANCE (OBJECT STREAM DEPTH) (IL:* IL:|;;| "Looks up the print function for the structure instance and calls it") (FUNCALL (OR (PS-PRINT-FUNCTION (PARSED-STRUCTURE (TYPE-OF OBJECT))) %DEFAULT-PRINT-FUNCTION) OBJECT STREAM (OR DEPTH 0))) (DEFUN DEFAULT-STRUCTURE-PRINTER (STRUC STREAM &OPTIONAL (PRINT-LEVEL 0)) (IF (NOT XCL:*PRINT-STRUCTURE*) (IL:\\PRINT-USING-ADDRESS STRUC STREAM 0) (LET ((TYPE (IL:TYPENAME STRUC)) LABEL (FIRST-TIME? T)) (WHEN IL:*PRINT-CIRCLE-HASHTABLE* (IL:* IL:|;;| "only true if *print-circle* is true and the structure is circular.") (MULTIPLE-VALUE-SETQ (LABEL FIRST-TIME?) (IL:PRINT-CIRCLE-LOOKUP STRUC))) (IL:* IL:|;;| "(cl:format t \"label: ~S firsttime ~S~%\" label first-time?)") (WHEN LABEL (IL:* IL:|;;| "this guy needs to be flagged for circle-printing") (IL:PRIN3 LABEL STREAM)) (WHEN (OR (NOT LABEL) FIRST-TIME?) (LET ((*PRINT-LEVEL* (AND *PRINT-LEVEL* (1- *PRINT-LEVEL*)))) (IF (OR (AND *PRINT-LEVEL* (<= *PRINT-LEVEL* PRINT-LEVEL)) (AND *PRINT-LENGTH* (<= *PRINT-LENGTH* 0))) (IL:\\ELIDE.PRINT.ELEMENT STREAM) (LET ((LENGTHSOFAR (IF *PRINT-LENGTH* 0))) (IL:\\OUTCHAR STREAM (IL:|fetch| (READTABLEP IL:HASHMACROCHAR) IL:|of| *READTABLE*) ) (WRITE-STRING "S(" STREAM) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (IL:\\ELIDE.PRINT.TAIL STREAM T) (PROGN (IF *PRINT-ESCAPE* (PRIN1 TYPE STREAM) (PRINC TYPE STREAM)) (DO ((FIELD (STRUCTURE-SLOT-NAMES TYPE) (CDR FIELD)) (DESCRIPTOR (IL:GETDESCRIPTORS TYPE) (CDR DESCRIPTOR))) ((NULL FIELD)) (WHEN (EQ (CAR FIELD) 'SI::--STRUCTURE-DUMMY-SLOT--) (GO SKIP)) (IL:\\OUTCHAR STREAM (IL:CONSTANT (CHAR-CODE #\Space))) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T) (RETURN NIL)) (PROGN (PRINC (CAR FIELD) STREAM) (IF (AND LENGTHSOFAR (> (INCF LENGTHSOFAR) *PRINT-LENGTH*)) (PROGN (IL:\\ELIDE.PRINT.TAIL STREAM T) (RETURN NIL)) (PROGN (IL:\\OUTCHAR STREAM (IL:CONSTANT (CHAR-CODE #\Space))) (IL:\\PRINDATUM (IL:FETCHFIELD (CAR DESCRIPTOR ) STRUC) STREAM (1+ PRINT-LEVEL)))))) SKIP))) (WRITE-STRING ")" STREAM))))) T))) (DEFUN STRUCTURE-SLOT-NAMES (STRUCTURE-NAME &OPTIONAL (DONT-COPY NIL)) (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME)) NAMES) (SETQ NAMES (PS-ALL-SLOT-NAMES PS)) (IF DONT-COPY NAMES (COPY-LIST NAMES)))) (IL:* IL:|;;| "For reading") (DEFUN IL:CREATE-STRUCTURE (STRUCTURE-FORM) (APPLY (STRUCTURE-CONSTRUCTOR (CAR STRUCTURE-FORM)) (XCL:WITH-COLLECTION (DO ((TAIL (CDR STRUCTURE-FORM) (CDDR TAIL))) ((NULL TAIL)) (XCL:COLLECT (IL:MAKE-KEYWORD (CAR TAIL))) (XCL:COLLECT (CADR TAIL)))))) (DEFUN STRUCTURE-CONSTRUCTOR (STRUCTURE-NAME) (OR (GET STRUCTURE-NAME 'IL:STRUCTURE-CONSTRUCTOR) (LET* ((PS (PARSED-STRUCTURE STRUCTURE-NAME)) (CONSTRUCTOR (PS-STANDARD-CONSTRUCTOR PS))) (OR CONSTRUCTOR (ERROR "~S is a structure with no standard constructor." (PS-NAME PS)))) )) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:DEFSTRUCT-RUN-TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993) ) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/DESCRIBE b/sources/DESCRIBE new file mode 100644 index 00000000..98f361ad --- /dev/null +++ b/sources/DESCRIBE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM") (IL:FILECREATED "16-May-90 15:39:16" IL:|{DSK}local>lde>lispcore>sources>DESCRIBE.;2| 14141 IL:|changes| IL:|to:| (IL:VARS IL:DESCRIBECOMS) IL:|previous| IL:|date:| "16-May-88 17:04:26" IL:|{DSK}local>lde>lispcore>sources>DESCRIBE.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:DESCRIBECOMS) (IL:RPAQQ IL:DESCRIBECOMS ( (IL:* IL:|;;| "Common LISP describe facility") (IL:FUNCTIONS DESCRIBE DESCRIBE-INTERNAL DESCRIBE-NEW-LINE DESCRIBE-USING-DESCRIBERS GET-SUPER-DESCRIBERS GET-INSPECT-MACRO INSPECT-MACRO-USABLE-BY-DESCRIBE? DESCRIBE-USING-INSPECT-MACRO DESCRIBE-USING-RECORD-DECL) (IL:FUNCTIONS A-OR-AN VOWEL-P) (IL:DEFINE-TYPES CL::DESCRIBERS) (IL:FUNCTIONS CL::DEFDESCRIBER GET-DESCRIBERS) (IL:PROP IL:PROPTYPE DESCRIBERS) (CL::DESCRIBERS SYMBOL CL::STRUCTURE-OBJECT CHARACTER FIXNUM SINGLE-FLOAT HASH-TABLE) (IL:VARIABLES CL::*DESCRIBE-DEPTH* CL::*DESCRIBE-INDENT* CL::*DESCRIBE-PRINT-LENGTH* CL::*DESCRIBE-PRINT-LEVEL*) (IL:PROPS (IL:DESCRIBE IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)))) (IL:* IL:|;;| "Common LISP describe facility") (DEFUN DESCRIBE (CL::OBJECT) "Describe OBJECT, printing to *STANDARD-OUTPUT*." (LET ((*PRINT-LENGTH* CL::*DESCRIBE-PRINT-LENGTH*) (*PRINT-LEVEL* CL::*DESCRIBE-PRINT-LEVEL*)) (DESCRIBE-INTERNAL CL::OBJECT 0) (VALUES))) (DEFUN DESCRIBE-INTERNAL (OBJECT DEPTH) (IL:* IL:|;;;| "Recursive entry point for descriptions.") (IF (< DEPTH CL::*DESCRIBE-DEPTH*) (LET* ((TYPE (TYPE-OF OBJECT)) (TYPE-NAME (IF (CONSP TYPE) (CAR TYPE) TYPE)) DESCRIBERS INSPECT-MACRO SUPER-DESCRIBERS IL:DECL) (DESCRIBE-NEW-LINE DEPTH) (FORMAT T "~A ~A, " (A-OR-AN TYPE-NAME) TYPE-NAME) (COND ((SETQ DESCRIBERS (GET-DESCRIBERS TYPE-NAME)) (DESCRIBE-USING-DESCRIBERS OBJECT (1+ DEPTH) DESCRIBERS)) ((AND (SETQ INSPECT-MACRO (GET-INSPECT-MACRO OBJECT)) (INSPECT-MACRO-USABLE-BY-DESCRIBE? INSPECT-MACRO)) (DESCRIBE-USING-INSPECT-MACRO OBJECT (1+ DEPTH) INSPECT-MACRO)) ((SETQ SUPER-DESCRIBERS (GET-SUPER-DESCRIBERS TYPE-NAME)) (DESCRIBE-USING-DESCRIBERS OBJECT (1+ DEPTH) SUPER-DESCRIBERS)) ((SETQ IL:DECL (OR (IL:FINDRECDECL OBJECT) (IL:FINDSYSRECDECL OBJECT))) (DESCRIBE-USING-RECORD-DECL OBJECT IL:DECL (1+ DEPTH))) (T (IL:* IL:|;;| "Punt to printing") (PRIN1 OBJECT)))) (PRIN1 OBJECT))) (DEFUN DESCRIBE-NEW-LINE (DEPTH) (FRESH-LINE) (DOTIMES (N (* DEPTH CL::*DESCRIBE-INDENT*)) (WRITE-CHAR #\Space))) (DEFUN DESCRIBE-USING-DESCRIBERS (OBJECT DEPTH DESCRIBERS) (MAPC #'(LAMBDA (DESCRIBER) (IF (AND (CONSP DESCRIBER) (STRINGP (FIRST DESCRIBER))) (MULTIPLE-VALUE-BIND (FIELD EMPTY?) (FUNCALL (SECOND DESCRIBER) OBJECT) (UNLESS EMPTY? (DESCRIBE-NEW-LINE DEPTH) (FORMAT T "~A: " (FIRST DESCRIBER)) (DESCRIBE-INTERNAL FIELD (1+ DEPTH)))) (FUNCALL DESCRIBER OBJECT DEPTH))) DESCRIBERS)) (DEFUN GET-SUPER-DESCRIBERS (TYPE) (IL:* IL:|;;| "Search up super-types of TYPE for describers") (DO* ((TYPE TYPE (IL:GETSUPERTYPE TYPE)) (DESCRIBER NIL (GET-DESCRIBERS TYPE))) ((OR DESCRIBER (NULL TYPE)) DESCRIBER))) (DEFUN GET-INSPECT-MACRO (OBJECT) (IL:* IL:|;;| "Search IL:INSPECTMACROS for an inspect macro for OBJECT") (DECLARE (XCL:GLOBAL IL:INSPECTMACROS)) (DO* ((TAIL IL:INSPECTMACROS (REST TAIL)) (HEAD NIL (FIRST TAIL)) (TYPE NIL (FIRST HEAD)) (MACRO NIL (TYPECASE TYPE (CONS (AND (EQ (FIRST TYPE) 'IL:FUNCTION) (FUNCALL (SECOND TYPE) OBJECT))) (OTHERWISE (TYPEP OBJECT TYPE))))) ((OR MACRO (NULL TAIL)) HEAD))) (DEFUN INSPECT-MACRO-USABLE-BY-DESCRIBE? (MACRO) (CONSP (REST MACRO))) (DEFUN DESCRIBE-USING-INSPECT-MACRO (OBJECT DEPTH MACRO) (LET ((FETCHFN (THIRD MACRO)) (FIELDS (SECOND MACRO))) (MAPCAR #'(LAMBDA (FIELD-NAME) (DESCRIBE-NEW-LINE DEPTH) (PRINC FIELD-NAME) (PRINC ": ") (DESCRIBE-INTERNAL (FUNCALL FETCHFN OBJECT FIELD-NAME) (1+ DEPTH))) (IF (CONSP FIELDS) FIELDS (FUNCALL FIELDS OBJECT))))) (DEFUN DESCRIBE-USING-RECORD-DECL (OBJECT IL:DECL DEPTH) (MAPC #'(LAMBDA (FIELD-NAME) (DESCRIBE-NEW-LINE DEPTH) (FORMAT T "~A: " FIELD-NAME) (DESCRIBE-INTERNAL (IL:RECORDACCESS FIELD-NAME OBJECT IL:DECL) (1+ DEPTH))) (IL:INSPECTABLEFIELDNAMES IL:DECL))) (DEFUN A-OR-AN (WORD) "Return 'a' or 'an' depending upon whether the first letter in WORD is a vowel" (IF (VOWEL-P (ELT (ETYPECASE WORD (SYMBOL (SYMBOL-NAME WORD)) (STRING WORD)) 0)) "an" "a")) (DEFUN VOWEL-P (CHAR) "T if char is an A, E, I, O or U. Not dependable with funky charsets." (CASE (CHARACTER CHAR) ((#\A #\a #\E #\e #\I #\i #\O #\o #\U #\u) T) (OTHERWISE NIL))) (XCL:DEF-DEFINE-TYPE CL::DESCRIBERS "Describers of objects") (XCL:DEFDEFINER CL::DEFDESCRIBER CL::DESCRIBERS (TYPE &REST CL::DESCRIBERS) `(SETF (GET ',TYPE 'DESCRIBERS) (LIST ,@(MAPCAR #'(LAMBDA (CL::ITEM) (IL:* IL:|;;|  "Throughout here symbols are quoted and lambda-expressions are hash-quoted for compiler") (IF (AND (CONSP CL::ITEM) (STRINGP (FIRST CL::ITEM))) (IL:* IL:|;;| "It's a field name and function") `(LIST ',(FIRST CL::ITEM) (IF (CONSP ',(SECOND CL::ITEM)) #',(SECOND CL::ITEM) ',(SECOND CL::ITEM))) (IL:* IL:|;;| "Else, it must be just a function") (IF (CONSP CL::ITEM) `#',CL::ITEM `',CL::ITEM))) CL::DESCRIBERS)))) (DEFUN GET-DESCRIBERS (TYPE) (GET TYPE 'DESCRIBERS)) (IL:PUTPROPS DESCRIBERS IL:PROPTYPE IGNORE) (CL::DEFDESCRIBER SYMBOL (IL:* IL:|;;| "This describer uses all features") ("name" SYMBOL-NAME) (IL:* IL:\;  "A field name and accessor") (LAMBDA (SYMBOL CL::DEPTH) (IL:* IL:\; "An arbitrary function") (LET ((CL::FIRST-TIME? 'T) (CL::HASH-TABLES)) (MAPHASH #'(LAMBDA (TYPE HASH-TABLE) (WHEN (NOT (MEMBER HASH-TABLE CL::HASH-TABLES :TEST #'EQ)) (PUSH HASH-TABLE CL::HASH-TABLES) (LET ((CL::DOC (GETHASH SYMBOL HASH-TABLE))) (WHEN CL::DOC (WHEN CL::FIRST-TIME? (SETQ CL::FIRST-TIME? 'NIL) (DESCRIBE-NEW-LINE CL::DEPTH) (PRINC "documentation:")) (DESCRIBE-NEW-LINE (1+ CL::DEPTH)) (FORMAT T "~A: ~A" TYPE CL::DOC) NIL)))) IL:*DOCUMENTATION-HASH-TABLE*))) ("package cell" SYMBOL-PACKAGE) (IL:* IL:\;  "another field name & accessor") ("value cell" (IL:* IL:\;  "use of multiple values in accessor ") (LAMBDA (SYMBOL) (LET ((CL::UNBOUND? (NOT (BOUNDP SYMBOL)))) (VALUES (UNLESS CL::UNBOUND? (SYMBOL-VALUE SYMBOL)) CL::UNBOUND?)))) ("function cell" (IL:* IL:\; "ditto") (LAMBDA (SYMBOL) (LET ((CL::UNDEFINED? (NOT (FBOUNDP SYMBOL)))) (VALUES (UNLESS CL::UNDEFINED? (SYMBOL-FUNCTION SYMBOL)) CL::UNDEFINED?)))) (LAMBDA (SYMBOL CL::DEPTH) (IL:* IL:\;  "arbitratry function again") (LET ((CL::PLIST (SYMBOL-PLIST SYMBOL))) (WHEN CL::PLIST (DESCRIBE-NEW-LINE CL::DEPTH) (PRINC "property list:") (DO ((CL::PLIST CL::PLIST (CDDR CL::PLIST))) ((NULL CL::PLIST)) (DESCRIBE-NEW-LINE (1+ CL::DEPTH)) (PRIN1 (FIRST CL::PLIST)) (PRINC " : ") (IL:* IL:|;;| "Recurse on each property") (DESCRIBE-INTERNAL (SECOND CL::PLIST) (+ CL::DEPTH 2))))))) (CL::DEFDESCRIBER CL::STRUCTURE-OBJECT (IL:* IL:|;;| "Describer for objects created by DEFSTRUCT") (LAMBDA (CL::OBJECT CL::DEPTH) (MAPC #'(LAMBDA (CL::SLOT) (DESCRIBE-NEW-LINE CL::DEPTH) (FORMAT T "~A: " (CL::PSLOT-NAME CL::SLOT)) (IL:* IL:|;;| "Recurse on fields") (DESCRIBE-INTERNAL (FUNCALL (CL::PSLOT-ACCESSOR CL::SLOT) CL::OBJECT) (1+ CL::DEPTH))) (CL::PS-ALL-SLOTS (CL::PARSED-STRUCTURE (TYPE-OF CL::OBJECT)))))) (CL::DEFDESCRIBER CHARACTER (LAMBDA (CHAR CL::DEPTH) (MULTIPLE-VALUE-CALL 'FORMAT T "'~:@C', code #\\~O-~3,'0O (~D decimal, ~:*~X hex, ~:*~B binary)" CHAR (FLOOR (CHAR-CODE CHAR) 256) (CHAR-CODE CHAR)))) (CL::DEFDESCRIBER FIXNUM (LAMBDA (NUMBER CL::DEPTH) (FORMAT T "~D decimal, ~:*~O octal, ~:*~X hex, ~:*~B binary~@[, '~C' character~]" NUMBER (INT-CHAR NUMBER)))) (CL::DEFDESCRIBER SINGLE-FLOAT ("sign" (LAMBDA (FLOAT) (ECASE (FLOAT-SIGN FLOAT) (1.0 'CL::POSITIVE) (-1.0 'CL::NEGATIVE)))) ("radix" FLOAT-RADIX) ("digits" FLOAT-DIGITS) ("significand" (LAMBDA (FLOAT) (IL:* IL:|;;| "onlyt return first value, as second confuses describe.") (VALUES (DECODE-FLOAT FLOAT)))) ("exponent" (LAMBDA (FLOAT) (SECOND (MULTIPLE-VALUE-LIST (DECODE-FLOAT FLOAT)))))) (CL::DEFDESCRIBER HASH-TABLE ("count" HASH-TABLE-COUNT) ("size" IL:HARRAYSIZE) ("test" (LAMBDA (CL::TABLE) (IL:HARRAYPROP CL::TABLE 'IL:EQUIVFN))) (LAMBDA (CL::TABLE CL::DEPTH) (DESCRIBE-NEW-LINE CL::DEPTH) (PRINC "contents:") (LET* ((CL::NEW-DEPTH (1+ CL::DEPTH)) (CL::NEW-NEW-DEPTH (1+ CL::NEW-DEPTH))) (MAPHASH #'(LAMBDA (CL::KEY CL::VALUE) (DESCRIBE-NEW-LINE CL::NEW-DEPTH) (PRIN1 CL::KEY) (PRINC " : ") (DESCRIBE-INTERNAL CL::VALUE CL::NEW-NEW-DEPTH)) CL::TABLE)))) (DEFPARAMETER CL::*DESCRIBE-DEPTH* 1 "The recursive depth to which DESCRIBE describes") (DEFPARAMETER CL::*DESCRIBE-INDENT* 3 "Number of spaces to indent recursive descriptions") (DEFPARAMETER CL::*DESCRIBE-PRINT-LENGTH* 3 "The value of *PRINT-LENGTH* in DESCRIBE") (DEFPARAMETER CL::*DESCRIBE-PRINT-LEVEL* 3 "The value of *PRINT-LEVEL* in DESCRIBE") (IL:PUTPROPS IL:DESCRIBE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM")) (IL:PUTPROPS IL:DESCRIBE IL:FILETYPE :XCL-COMPILE-FILE) (IL:PUTPROPS IL:DESCRIBE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/DEXEC b/sources/DEXEC new file mode 100644 index 00000000..31b9bee6 --- /dev/null +++ b/sources/DEXEC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "11-Aug-2020 20:35:21" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;5 5160 changes to%: (FNS COPYALLBYTES) previous date%: " 1-May-2018 10:22:21" {DSK}kaplan>Local>medley3.5>lispcore>sources>DEXEC.;3) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990, 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 DEXECCOMS) (RPAQQ DEXECCOMS [ (* ;;; "Has to come after ADISPLAY and CMLEXEC.") (COMMANDS "see" "see*" "ty" "type") (LISPXMACROS CONN DA) (FNS /CNDIR COPYALLBYTES SEE SEE*) (COMS (CURSORS SAVINGCURSOR SYSOUTCURSOR \PROMPTFORWORD.CURSOR)) (PROP FILETYPE DEXEC) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'SEE 'TY] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA SEE* SEE) (NLAML) (LAMA]) (* ;;; "Has to come after ADISPLAY and CMLEXEC.") (DEFCOMMAND "see" (&REST ARGS) "Print the contents of a file on the screen, hiding comments" (APPLY 'SEE ARGS)) (DEFCOMMAND "see*" (&REST ARGS) "Print the contents of a file on the screen" (APPLY 'SEE* ARGS)) (DEFCOMMAND "ty" (&REST ARGS) "Print the contents of a file on the screen, hiding comments" (APPLY 'SEE ARGS)) (DEFCOMMAND "type" (&REST ARGS) "Print the contents of a file on the screen, hiding comments" (APPLY 'SEE ARGS)) (ADDTOVAR LISPXHISTORYMACROS (DA (PROGN (LISPXPRIN1 (DATE) T) (TERPRI T)))) (ADDTOVAR LISPXMACROS [CONN (/CNDIR (CAR (NLAMBDA.ARGS LISPXLINE]) (ADDTOVAR LISPXCOMS CONN DA) (DEFINEQ (/CNDIR (LAMBDA (HOST/DIR) (* rmk%: "19-JUL-81 22:44") (AND LISPXHIST (UNDOSAVE (LIST '/CNDIR (DIRECTORYNAME T T)) LISPXHIST)) (CNDIR HOST/DIR))) (COPYALLBYTES [LAMBDA (FROMFILE TOFILE BYTESIZE EXTERNALFORMAT) (* ; "Edited 11-Aug-2020 20:35 by rmk:") (* bvm%: "29-Jan-86 19:50") (RESETLST [PROG (INF OUTF PTR) [COND (FROMFILE [RESETSAVE NIL (LIST 'CLOSEF (SETQ INF (OPENSTREAM FROMFILE 'INPUT NIL `((EXTERNALFORMAT ,EXTERNALFORMAT) ) BYTESIZE] (OR (EQ (GETFILEPTR INF) 0) (SETFILEPTR INF 0))) (T (SETQ INF (INPUT] (* close the files only if I opened  them) [COND ((NULL TOFILE) (SETQ OUTF (OUTPUT))) ([NULL (SETQ OUTF (OPENP TOFILE 'OUTPUT] (RESETSAVE NIL (LIST 'CLOSEF (SETQ OUTF (OPENSTREAM TOFILE 'OUTPUT NIL BYTESIZE] (COND ((AND (NULL BYTESIZE) (DISPLAYP OUTF)) (PFCOPYBYTES INF OUTF NIL NIL PFDEFAULT)) (T (COPYBYTES INF OUTF])]) (SEE (NLAMBDA LINE (* lmm "14-Aug-84 19:07") (SETQ LINE (NLAMBDA.ARGS LINE)) (COPYALLBYTES (CAR LINE) (OR (CADR LINE) T) (CADDR LINE)))) (SEE* [NLAMBDA LINE (* ; "Edited 1-May-2018 10:22 by rmk:") (SETQ LINE (NLAMBDA.ARGS LINE)) (LET ((**COMMENT**FLG NIL)) (APPLY (FUNCTION SEE) LINE]) ) (RPAQ SAVINGCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@FDJ@HJJ@LJJ@BNJLJJD@LJD@@@@@@JDN@KEB@KE@@JMF@JMB@JEL@@@@@@@@ ) (QUOTE NIL) 0 15)) (RPAQ SYSOUTCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@CJDNDAE@C@HL@HHBDIABCA@L@@@@@@@@AIBNBEBDBEBDBEBDBEBDAHLD@@@@ ) (QUOTE NIL) 0 15)) (RPAQ \PROMPTFORWORD.CURSOR (CURSORCREATE (QUOTE #*(16 16)H@@@L@@@N@CLO@FFOHFFOL@FON@LO@AHMHAHIH@@@LAH@LAH@F@@@F@@@C@@@C@@ ) (QUOTE NIL) 0 15)) (PUTPROPS DEXEC FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD 'SEE 'TY) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA SEE* SEE) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS DEXEC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2133 4380 (/CNDIR 2143 . 2376) (COPYALLBYTES 2378 . 3894) (SEE 3896 . 4140) (SEE* 4142 . 4378))))) STOP \ No newline at end of file diff --git a/sources/DFILE b/sources/DFILE new file mode 100644 index 00000000..d2d3845c --- /dev/null +++ b/sources/DFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:42:03" {DSK}local>lde>lispcore>sources>DFILE.;2 860 changes to%: (VARS DFILECOMS) previous date%: "15-Oct-86 07:46:09" {DSK}local>lde>lispcore>sources>DFILE.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT DFILECOMS) (RPAQQ DFILECOMS ((FILES DIRECTORY SPELLFILE))) (FILESLOAD DIRECTORY SPELLFILE) (PUTPROPS DFILE COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/DIRECTORY b/sources/DIRECTORY new file mode 100644 index 00000000..e7d19b25 --- /dev/null +++ b/sources/DIRECTORY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "30-Apr-92 15:04:56" |{PELE:MV:ENVOS}SOURCES>DIRECTORY.;5| 26134 changes to%: (FNS DIRECTORY DODIRCOMMANDS) previous date%: "31-May-90 12:25:29" |{PELE:MV:ENVOS}SOURCES>DIRECTORY.;4|) (* ; " Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DIRECTORYCOMS) (RPAQQ DIRECTORYCOMS ((* DIRECTORY) (LISPXMACROS DIR NDIR) (FNS DODIR FILDIR DIRECTORY DIRECTORY.PARSE DIRECTORY.FILL.PATTERN DIRCONJ DIRECTORY.NEXTFILE DMATCH DIRECTORY.MATCH.SETUP DIRECTORY.MATCH DIRECTORY.MATCH1 DODIRCOMMANDS DIRPRINTNAME DPRIN1 DIRFILENAME DIRGETFILEINFO DREAD) (INITVARS (*UPPER-CASE-FILE-NAMES* T)) [P (CL:PROCLAIM '(CL:SPECIAL *UPPER-CASE-FILE-NAMES*] (VARS DIRCOMMANDS FILEINFOTYPES) (DECLARE%: DONTCOPY (RECORDS FILEGROUP) (MACROS DTAB) (GLOBALVARS DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES)))) (* DIRECTORY) (ADDTOVAR LISPXMACROS (DIR (DODIR (NLAMBDA.ARGS LISPXLINE))) (NDIR (DODIR (NLAMBDA.ARGS LISPXLINE) '(P COLUMNS 20) '* ""))) (DEFINEQ (DODIR (LAMBDA (LISPXLINE EXTRACOMS DEFAULTEXT DEFAULTVERS NOP) (* rmk%: "29-OCT-81 17:01") (PROG ((FILE (CAR LISPXLINE)) (TAIL (CDR LISPXLINE)) CONJ) LP (COND ((SETQ CONJ (DIRCONJ (CAR TAIL))) (* ; "The files can be strung out in the line separated by conjunctions.") (SETQ FILE (LIST FILE CONJ (CADR TAIL))) (SETQ TAIL (CDDR TAIL)) (GO LP))) (AND EXTRACOMS (SETQ TAIL (APPEND TAIL EXTRACOMS))) (OR NOP (FMEMB (QUOTE P) TAIL) (FMEMB (QUOTE PP) TAIL) (SETQ TAIL (CONS (QUOTE P) TAIL))) (RETURN (DIRECTORY FILE TAIL DEFAULTEXT DEFAULTVERS)))) ) (FILDIR (LAMBDA (FILEGROUP) (* lmm " 4-OCT-83 03:27") (DIRECTORY FILEGROUP))) (DIRECTORY [LAMBDA (FILES COMMANDS DEFAULTEXT DEFAULTVERS) (DECLARE (SPECVARS COMMANDS DEFAULTEXT DEFAULTVERS)) (* ; "Edited 30-Apr-92 14:55 by jds") (PROG (VALUE COLUMNS NAMEFLG DELETEDONLY FILEGROUP PRINTFLG OUTFILE PROMPTFLG LASTHOST&DIR DESIREDPROPS PFLG HEADINGS VALUES-WANTED) (DECLARE (SPECVARS VALUE COLUMNS NAMEFLG FILEGROUP DESIREDPROPS LASTHOST&DIR)) (PROG ([COMTAIL (SETQ COMMANDS (COND ((LISTP COMMANDS) (APPEND COMMANDS)) (T (SETQ COMMANDS (LIST (OR COMMANDS 'COLLECT] COM TEM) COMLP [SELECTQ (SETQ COM (CAR COMTAIL)) ((PAUSE P PP) (SETQ PFLG (SETQ PRINTFLG COMTAIL))) (OLDVERSIONS [OR (FIXP (CADR COMTAIL)) (RPLACD COMTAIL (CONS 1 (CDR COMTAIL] (pop COMTAIL)) (BY (RPLACA (SETQ COMTAIL (CDR COMTAIL)) (MKSTRING (CAR COMTAIL))) (push DESIREDPROPS 'AUTHOR)) (COLLECT (SETQ VALUES-WANTED T)) (DELETE) (COUNTSIZE (SETQ VALUE 0) (push DESIREDPROPS 'SIZE)) ((PROMPT PRINT) (SETQ COMTAIL (CDR COMTAIL)) [push HEADINGS (LIST NIL (NCHARS (CAR COMTAIL] (if (EQ COM 'PROMPT) then (SETQ PROMPTFLG T) else (SETQ PRINTFLG T))) (@ (SETQ COMTAIL (CDR COMTAIL)) (if (FNTYP (SETQ COM (CAR COMTAIL))) then [RPLACA COMTAIL (CONS COM '(FILENAME] (SETQ NAMEFLG T) elseif (FMEMB 'FILENAME (FREEVARS COM)) then (SETQ NAMEFLG T))) (COLUMNS (SETQ COLUMNS (CADR COMTAIL)) (SETQ PRINTFLG T) (RPLNODE COMTAIL 'NOP (CDDR COMTAIL))) (OUT (SETQ OUTFILE (CADR COMTAIL)) (RPLNODE COMTAIL 'NOP (CDDR COMTAIL))) ((DELETED UNDELETE) (ERROR "DELETED/UNDELETE directory commands are not supported") (SETQ DELETEDONLY T)) ((OLDERTHAN NEWERTHAN) (push DESIREDPROPS 'ICREATIONDATE 'IWRITEDATE) (if (EQ COM 'OLDERTHAN) then (push DESIREDPROPS 'IREADDATE)) (RPLACA (SETQ COMTAIL (CDR COMTAIL)) (if (NUMBERP (SETQ COM (CAR COMTAIL))) then (* ; "A number of days") [IDIFFERENCE (IDATE) (TIMES COM (DEFERREDCONSTANT (IDIFFERENCE (IDATE "2-JAN-77 00:00" ) (IDATE "1-JAN-77 00:00" ] elseif (IDATE COM) else (\ILLEGAL.ARG COM)))) (COND ((STRINGP COM) (RPLNODE COMTAIL 'PRINT (CONS (MKSTRING COM) (CDR COMTAIL))) (GO COMLP)) ((SETQ TEM (FASSOC COM FILEINFOTYPES)) (push DESIREDPROPS COM) (push HEADINGS (LIST COM (CADR TEM))) (SETQ PRINTFLG T)) ((LISTP COM) (FRPLNODE2 COMTAIL (APPEND COM (CDR COMTAIL))) (GO COMLP)) ((FIXSPELL COM NIL (NCONC (MAPCAR FILEINFOTYPES (FUNCTION CAR)) DIRCOMMANDS) NIL COMTAIL NIL NIL T NIL 'MUSTAPPROVE) (* ;; "User MUST approve any spelling corrections, to prevent accidental correction of DELVER to DELETE. Yucko!") (GO COMLP)) (T (ERROR "invalid DIRECTORY command" COM] (AND (SETQ COMTAIL (CDR COMTAIL)) (GO COMLP))) (RESETLST (* ;; "RESETLST is here, among other reasons, to clean up after any file generators that worry about the DIR being aborted") (SETQ FILEGROUP (create FILEGROUP PATTERN _ (DIRECTORY.PARSE FILES) FILEGENERATORS _ FILEGROUP)) (* ;  "DIRECTORY.PARSE smashes generators on FILEGROUP for each atomic file specification it finds.") [COND ((EQL \MACHINETYPE \MAIKO) (RESETSAVE NIL '(AND RESETSTATE (\UFS.ABORT.DIRECTORY] (* ;  "Make sure all instances of UFSGENFILESTATE will be released.") (COND ((OR PRINTFLG OUTFILE PROMPTFLG) [COND (PROMPTFLG (RESETSAVE (SETTERMTABLE ASKUSERTTBL] [RESETSAVE (OUTPUT (COND ((NULL OUTFILE) (* ; "Default output is to terminal") T) ((GETSTREAM OUTFILE T T)) (T [RESETSAVE NIL (LIST 'CLOSEF? (SETQ OUTFILE (OPENSTREAM OUTFILE 'OUTPUT] OUTFILE] [COND ((AND PFLG (NEQ (CAR PFLG) 'PAUSE)) (* ;  "Postpone print commands until after predicate commands") (SETQ COMTAIL COMMANDS) (bind SEENP PREVTAIL do (SELECTQ (CAR COMTAIL) ((P PP) (SETQ SEENP (OR PREVTAIL T))) ((BY COLUMNS @ OUT OLDERTHAN NEWERTHAN) (pop COMTAIL)) (PROGN [COND ((AND SEENP (NEQ COMTAIL (CDR PFLG))) (* ;  "Move the P or PP to before COMTAIL") (RPLACD PREVTAIL (CONS (CAR PFLG) COMTAIL)) (COND ((NEQ SEENP T) (RPLACD SEENP (CDDR SEENP))) (T (pop COMMANDS] (RETURN))) (SETQ COMTAIL (CDR (SETQ PREVTAIL COMTAIL] [COND ((AND HEADINGS (for X in HEADINGS thereis (CAR X))) (TERPRI) (for X in (REVERSE HEADINGS) bind (I _ 22) do (TAB I) [COND ((CAR X) (PRIN1 (CAR X] (add I (CADR X] (SETQ PRINTFLG T) (TAB 0 0))) (while (DIRECTORY.NEXTFILE FILEGROUP) do (DODIRCOMMANDS COMMANDS FILEGROUP)) (COND (PRINTFLG (TAB 0 0)))) (RETURN (OR VALUE (COND ((NOT VALUES-WANTED) (CL:VALUES]) (DIRECTORY.PARSE (LAMBDA (FG) (* bvm%: "14-May-84 12:55") (* ;; "This pushes file generators on FILEGROUP for each of the atomic filespecifications it comes to.") (DECLARE (USEDFREE FILEGROUP DESIREDPROPS DEFAULTEXT DEFAULTVERS)) (PROG (TEMP) (RETURN (COND ((NLISTP FG) (push FILEGROUP (\GENERATEFILES (SETQ FG (DIRECTORY.FILL.PATTERN FG DEFAULTEXT DEFAULTVERS)) DESIREDPROPS (QUOTE (SORT RESETLST)))) (DIRECTORY.MATCH.SETUP FG)) ((SETQ TEMP (DIRCONJ (CADR FG))) (CONS TEMP (CONS (DIRECTORY.PARSE (CAR FG)) (DIRECTORY.PARSE (CADDR FG))))) ((SETQ TEMP (DIRCONJ (CAR FG))) (CONS TEMP (CONS (DIRECTORY.PARSE (CADR FG)) (DIRECTORY.PARSE (CADDR FG))))) (T (ERROR "Bad file-group conjunction" (CADR FG))))))) ) (DIRECTORY.FILL.PATTERN (LAMBDA (PATTERN DEFAULTEXT DEFAULTVERS) (* bvm%: " 6-Feb-85 14:16") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (PACKFILENAME.STRING (QUOTE BODY) PATTERN (QUOTE NAME) (QUOTE *) (QUOTE VERSION) (OR DEFAULTVERS (QUOTE *)) (QUOTE EXTENSION) (OR DEFAULTEXT (QUOTE *)) (QUOTE DIRECTORY) (AND (NOT (FILENAMEFIELD PATTERN (QUOTE HOST))) \CONNECTED.DIRECTORY))) ) (DIRCONJ (LAMBDA (CONJ) (* rmk%: "29-OCT-81 11:01") (* ;; "Returns canonical form of directory conjunction, NIL if invalid") (SELECTQ CONJ ((OR +) (QUOTE OR)) ((AND *) (QUOTE AND)) ((- ANDNOT) (QUOTE ANDNOT)) NIL)) ) (DIRECTORY.NEXTFILE (LAMBDA (FG) (* bvm%: " 8-Jul-85 19:32") (PROG (TEM) LP (COND ((SETQ TEM (\GENERATENEXTFILE (CAR (fetch FILEGENERATORS of FG)) NIL)) (COND ((LISTP TEM) (* ; "Old style enumerator returns charlist") (SETQ TEM (CONCATCODES TEM)))) (COND ((STRINGP TEM) (replace STRINGNAME of FG with TEM) (replace LITERALNAME of FG with NIL)) (T (replace LITERALNAME of FG with (AND (LITATOM TEM) (U-CASEP TEM) TEM)) (replace STRINGNAME of FG with (SETQ TEM (MKSTRING TEM))))) (RETURN FG)) ((replace FILEGENERATORS of FG with (CDR (fetch FILEGENERATORS of FG))) (GO LP)) (T (RETURN))))) ) (DMATCH (LAMBDA (PAT TESTNAME) (* bvm%: " 4-May-84 13:16") (COND ((OR (EQ PAT T) (NULL PAT)) T) (T (SELECTQ (CAR PAT) (OR (OR (DMATCH (CADR PAT) TESTNAME) (DMATCH (CDDR PAT) TESTNAME))) (AND (AND (DMATCH (CADR PAT) TESTNAME) (DMATCH (CDDR PAT) TESTNAME))) (ANDNOT (AND (NOT (DMATCH (CDDR PAT) TESTNAME)) (DMATCH (CADR PAT) TESTNAME))) (DIRECTORY.MATCH PAT TESTNAME))))) ) (DIRECTORY.MATCH.SETUP (LAMBDA (FILENAME) (* bvm%: " 6-May-86 14:35") (SELCHARQ (CAR (SETQ FILENAME (CHCON FILENAME))) ({ (do (* ;; "Throw out hostname/device part, because the canonical name might be different from the one in the pattern") (SELCHARQ (pop FILENAME) (} (RETURN)) NIL))) NIL) (for TAIL on FILENAME bind (BASE _ (UPPERCASEARRAY)) do (* ; "Coerce to uppercase") (RPLACA TAIL (SELCHARQ (CAR TAIL) (ESCAPE (CHARCODE *)) (COND ((LEQ (CAR TAIL) \MAXTHINCHAR) (GETCASEARRAY BASE (CAR TAIL))) (T (CAR TAIL)))))) FILENAME) ) (DIRECTORY.MATCH (LAMBDA (PATTERN TESTNAME) (* bvm%: " 4-May-84 13:01") (PROG ((FIRSTCHAR 1)) (SELCHARQ (NTHCHARCODE TESTNAME 1) (({ %[) (do (* ;; "Throw out hostname/device part, because the canonical name might be different from the one in the pattern") (SELCHARQ (NTHCHARCODE TESTNAME (add FIRSTCHAR 1)) ((} %]) (RETURN (add FIRSTCHAR 1))) NIL))) NIL) (RETURN (DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR)))) ) (DIRECTORY.MATCH1 (LAMBDA (PATTERN TESTNAME FIRSTCHAR) (* ; "Edited 11-Mar-88 14:50 by bvm") (PROG ((CASEBASE (ffetch (ARRAYP BASE) of (\DTEST UPPERCASEARRAY (QUOTE ARRAYP)))) (NAMELIMIT (NCHARS TESTNAME)) PATCHAR TESTCHAR) LP (COND ((IGREATERP FIRSTCHAR NAMELIMIT) (* ; "Run out of name, so rest of pattern better be 'null', i.e., something like *.*;*") (RETURN (bind (OKCHARS _ (CHARCODE (%. ;))) do (if (NULL PATTERN) then (RETURN T) elseif (EQ (CAR PATTERN) (CHARCODE *)) then (SETQ PATTERN (CDR PATTERN)) elseif (MEMB (pop PATTERN) OKCHARS) then (SETQ OKCHARS (CDR OKCHARS)) else (RETURN NIL))))) ((NULL PATTERN) (* ;; "Name left, but no pattern. This is always a mismatch unless last matched pattern character was ';' in which case what follows is the version. Have to hope that the device generated only the newest version") (RETURN (EQ PATCHAR (CHARCODE ;)))) (T (COND ((EQ (SETQ PATCHAR (CAR PATTERN)) (CHARCODE *)) (* ;; "Matches any number of characters. Thus, see if we have a match ANYWHERE on remainder of TESTNAME. Also succeed if the pattern is just some tail of *.*;* now.") (RETURN (OR (NULL (SETQ PATTERN (CDR PATTERN))) (LET ((PAT PATTERN)) (* ;; "OK if pattern is *.*;*, *;*, or *.;* and TESTNAME has no extension") (AND (OR (NEQ (CAR PAT) (CHARCODE ".")) (if (EQ (CAR (SETQ PAT (CDR PAT))) (CHARCODE *)) then (* ; "Wildcard extension always ok") (SETQ PAT (CDR PAT))) (PROGN (* ; "Make sure we don't spuriously match a file with extension against extensionless pattern") (NOT (STRPOS "." TESTNAME FIRSTCHAR)))) (EQ (CAR PAT) (CHARCODE ";")) (OR (NULL (SETQ PAT (CDR PAT))) (EQ (CAR PAT) (CHARCODE *))))) (do (COND ((DIRECTORY.MATCH1 PATTERN TESTNAME FIRSTCHAR) (RETURN T))) (add FIRSTCHAR 1) repeatuntil (IGREATERP FIRSTCHAR NAMELIMIT))))) ((OR (EQ PATCHAR (COND ((LEQ (SETQ TESTCHAR (NTHCHARCODE TESTNAME FIRSTCHAR)) \MAXTHINCHAR) (\GETBASEBYTE CASEBASE TESTCHAR)) (T TESTCHAR))) (SELCHARQ PATCHAR (%# (* ; "Matches anything") T) (; (* ; "Would match except for different delimiter") (EQ TESTCHAR (CHARCODE !))) NIL)) (pop PATTERN) (add FIRSTCHAR 1) (GO LP)) (T (RETURN NIL))))))) ) (DODIRCOMMANDS [LAMBDA (COMMANDS FILEGROUP) (* ; "Edited 30-Apr-92 15:03 by jds") (PROG ((COMTAIL COMMANDS) (I 0) (FILENAME (fetch LITERALNAME of FILEGROUP)) COM FILE NAMEPRINTED ATTRVALUE) (DECLARE (SPECVARS FILENAME FILE NAMEPRINTED I) (USEDFREE VALUE)) (COND ([AND COLUMNS (NOT (ILESSP (SETQ I (ITIMES (IQUOTIENT (IPLUS (POSITION) COLUMNS -1) COLUMNS) COLUMNS)) (IDIFFERENCE (LINELENGTH) 30] (SETQ I 0))) (while COMTAIL do (SELECTQ (SETQ COM (pop COMTAIL)) (P (DIRPRINTNAME FILEGROUP)) (PP (DIRPRINTNAME FILEGROUP T)) (COUNTSIZE (add VALUE (DIRGETFILEINFO FILEGROUP 'SIZE))) (PAUSE (READC T) (SETQ I (IPLUS I 2))) (@ (* ;  "Arbitrary predicate -- next thing is form") (AND NAMEFLG (DIRFILENAME FILEGROUP)) (COND ((NOT (EVAL (pop COMTAIL))) (RETURN)))) ((OLDERTHAN NEWERTHAN) [LET ((COMDATE (pop COMTAIL)) DT) (COND ([OR [EQ (EQ COM 'OLDERTHAN) (OR (AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'ICREATIONDATE)) (IGEQ DT COMDATE)) (AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'IWRITEDATE)) (IGEQ DT COMDATE] (AND (EQ COM 'OLDERTHAN) (AND (SETQ DT (DIRGETFILEINFO FILEGROUP 'IREADDATE)) (IGEQ DT COMDATE] (* ;; "Only check Read date for the OLDERTHAN case, where it is useful for archiving. NEWERTHAN is only interested in files actually created recently") (RETURN]) (BY (SETQ COM (pop COMTAIL)) (COND ((AND (SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP 'AUTHOR)) (NOT (STRPOS COM ATTRVALUE NIL NIL NIL NIL UPPERCASEARRAY))) (RETURN)))) (DELETE (DTAB 12) (PRIN1 (COND ((DELFILE (DIRFILENAME FILEGROUP)) "deleted") (T "can't delete")))) (PROMPT (OR (DREAD (pop COMTAIL)) (RETURN))) (PRINT (DPRIN1 (pop COMTAIL))) (COLLECT (SETQ VALUE (NCONC1 VALUE (DIRFILENAME FILEGROUP)))) (OLDVERSIONS (* ;  "Not implemented, but user might continue from error in DIRECTORY") (COND ((NEQ (CAR COMTAIL) 1) (ERROR "can't count more than 1 version"))) (COND ((STRING.EQUAL (INFILEP (DIRFILENAME FILEGROUP)) (INFILEP (PACKFILENAME 'VERSION NIL 'BODY FILENAME))) (* ;; "Used to be EQ, but that fails for dsk files?") (RETURN))) (pop COMTAIL)) ((DELETED UNDELETE) (* ; "Not implemented") ) (NOP) (LET ((TYPE (FASSOC COM FILEINFOTYPES))) (COND [TYPE (DTAB (CADR TYPE)) (COND ((SETQ ATTRVALUE (DIRGETFILEINFO FILEGROUP COM)) (COND ((FIXP ATTRVALUE) (PRINTNUM (OR (CDDR TYPE) (LIST 'FIX (CADR TYPE))) ATTRVALUE)) ((AND (LISTP ATTRVALUE) (LISTP (CAR ATTRVALUE))) (PRINTDEF ATTRVALUE (POSITION))) (T (PRIN1 ATTRVALUE] (T (SHOULDNT]) (DIRPRINTNAME (LAMBDA (FILEGROUP FLG) (DECLARE (USEDFREE LASTHOST&DIR NAMEPRINTED)) (* ; "Edited 27-Apr-90 10:07 by nm") (COND ((NOT NAMEPRINTED) (PROG ((STREAM (GETSTREAM NIL (QUOTE OUTPUT))) (FULLNAME (fetch STRINGNAME of FILEGROUP)) (LASTNAME (CAR LASTHOST&DIR)) DIFFERENT DIRECTORYEND) (for I from 1 bind THISCHAR LASTCHAR do (* ; "Scan for end of directory name, and notice whether it matches previously printed directory") (SELCHARQ (SETQ THISCHAR (NTHCHARCODE FULLNAME I)) (NIL (RETURN)) ((} < > / %)) (SETQ DIRECTORYEND I)) NIL) (COND ((AND (NOT DIFFERENT) (COND ((NULL (SETQ LASTCHAR (NTHCHARCODE LASTNAME I)))) ((> LASTCHAR \MAXTHINCHAR) (* ; "Fat chars don't go thru casearray") (NEQ LASTCHAR THISCHAR)) ((> THISCHAR \MAXTHINCHAR)) (T (* ; "Two thin chars, are they really different?") (NEQ (GETCASEARRAY UPPERCASEARRAY LASTCHAR) (GETCASEARRAY UPPERCASEARRAY THISCHAR))))) (SETQ DIFFERENT I)))) (COND ((AND DIFFERENT DIRECTORYEND (OR (NEQ DIRECTORYEND (CADR LASTHOST&DIR)) (<= DIFFERENT DIRECTORYEND))) (TAB 0 0) (* ; "New directory") (TERPRI) (SPACES 3) (for I from 1 to DIRECTORYEND do (\OUTCHAR STREAM (NTHCHARCODE FULLNAME I))) (SETQ LASTHOST&DIR (LIST FULLNAME DIRECTORYEND)))) (DTAB 20) (for I from (ADD1 (OR DIRECTORYEND 0)) do (COND ((AND FLG (EQ (NTHCHARCODE FULLNAME I) (CHARCODE ;))) (RETURN))) (\OUTCHAR STREAM (OR (NTHCHARCODE FULLNAME I) (RETURN)))) (SPACES 1) (SETQ NAMEPRINTED T))))) ) (DPRIN1 (LAMBDA (STR) (* lmm "20-OCT-78 02:53") (DTAB (NCHARS STR)) (PRIN1 STR))) (DIRFILENAME (LAMBDA (FILEGROUP) (* ; "Edited 28-Jul-87 14:55 by bvm:") (DECLARE (USEDFREE FILE FILENAME)) (* ; "These might be used freely by user predicates, with @ commands") (OR (fetch LITERALNAME of FILEGROUP) (replace LITERALNAME of FILEGROUP with (SETQ FILE (SETQ FILENAME (MKATOM (LET ((NAME (fetch STRINGNAME of FILEGROUP))) (COND ((AND *UPPER-CASE-FILE-NAMES* (NOT (U-CASEP NAME))) (U-CASE NAME)) (T NAME))))))))) ) (DIRGETFILEINFO (LAMBDA (FILEGROUP ATTRIBUTE) (* bvm%: " 5-May-84 15:19") (\GENERATEFILEINFO (CAR (fetch FILEGENERATORS of FILEGROUP)) ATTRIBUTE)) ) (DREAD (LAMBDA (PROMPT) (* lmm "21-OCT-78 01:28") (PROG1 (PROG NIL LP (PROGN (TAB I 0) (PRIN1 PROMPT)) (SELECTQ (READC T) ((Y y) (PRIN1 (QUOTE "Yes") T) (RETURN T)) ((N n) (PRIN1 (QUOTE "No") T) (RETURN)) (? (PRIN1 (QUOTE "Y or N: ") T) (GO LP)) (PROGN (PRIN1 "" T) (GO LP)))) (add I (NCHARS PROMPT) 5))) ) ) (RPAQ? *UPPER-CASE-FILE-NAMES* T) (CL:PROCLAIM '(CL:SPECIAL *UPPER-CASE-FILE-NAMES*)) (RPAQQ DIRCOMMANDS ((- . PAUSE) (AU . AUTHOR) BY COLLECT (COLLECT? PROMPT " ? " COLLECT) COUNTSIZE (DA . CREATIONDATE) (DATE . CREATIONDATE) (DEL . DELETE) (DEL? . DELETE?) DELETE (DELETE? PROMPT " delete? " DELETE) DELETED (LE LENGTH "(" BYTESIZE ")") NEWERTHAN OLDVERSIONS (OLD OLDERTHAN 90) OLDERTHAN (OU . OUT) OUT P PAUSE (PR . PROTECTION) PROMPT (SI . SIZE) (TI . WRITEDATE) UNDELETE (VERBOSE AUTHOR CREATIONDATE SIZE READDATE WRITEDATE) TRIMTO (DELVER OLDVERSIONS DELETE))) (RPAQQ FILEINFOTYPES ((WRITEDATE 22) (READDATE 22) (CREATIONDATE 22) (LENGTH 9) (BYTESIZE 2) (PROTECTION 6 FIX 6 8) (SIZE 5) (AUTHOR 11) (READER 11) (TYPE 7) (FILETYPE 6 FIX 6 8))) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD FILEGROUP (STRINGNAME LITERALNAME PATTERN . FILEGENERATORS)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS DTAB DMACRO ((N) (TAB (PROG1 I (add I N 1)) 0))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DIRCOMMANDS ASKUSERTTBL FILEINFOTYPES) ) ) (PUTPROPS DIRECTORY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1339 24611 (DODIR 1349 . 1896) (FILDIR 1898 . 1979) (DIRECTORY 1981 . 11071) ( DIRECTORY.PARSE 11073 . 11781) (DIRECTORY.FILL.PATTERN 11783 . 12167) (DIRCONJ 12169 . 12389) ( DIRECTORY.NEXTFILE 12391 . 12984) (DMATCH 12986 . 13361) (DIRECTORY.MATCH.SETUP 13363 . 13897) ( DIRECTORY.MATCH 13899 . 14316) (DIRECTORY.MATCH1 14318 . 16431) (DODIRCOMMANDS 16433 . 22206) ( DIRPRINTNAME 22208 . 23624) (DPRIN1 23626 . 23711) (DIRFILENAME 23713 . 24142) (DIRGETFILEINFO 24144 . 24296) (DREAD 24298 . 24609))))) STOP \ No newline at end of file diff --git a/sources/DISKDLION b/sources/DISKDLION new file mode 100644 index 00000000..605eea0c --- /dev/null +++ b/sources/DISKDLION @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:46:03" {DSK}local>lde>lispcore>sources>DISKDLION.;2 61348 changes to%: (VARS DISKDLIONCOMS) previous date%: "30-Nov-87 15:40:41" {DSK}local>lde>lispcore>sources>DISKDLION.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DISKDLIONCOMS) (RPAQQ DISKDLIONCOMS ((FNS \DL.DISKINIT \DL.DOBNOCROSSP \DL.GETDISKADDRESS \DL.HANDLEMULTIRUN \DL.INIT.DOB.CHAIN \DL.OBTAINNEWDOB \DL.PUTDISKADDRESS \DL.RECALIBRATE \DL.RELEASEDOB \DL.SHUGART.XFERDISK \DL.TRANSFERPAGE \DLDISK.EXECUTE \DL.ACTONVMEMFILE \DL.ACTONVMEMPAGE \DL.DISKSEEK \DL.XFERDISK \DL.DISKOP \DL.TRI.INITIATE.IO \DL.TRI.XFERDISK) (FNS \DISKDLION.INIT) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.HEADSPERDRIVE \DLDISKSHAPE.SECTORSPERHEAD \DL.FAULTHANDLERDOB \DL.DOBPAGE \DL.DOBCHAIN \DL.SPAREDOB \DISKTYPE \CONTROLLERTYPE) (P (\DISKDLION.INIT))) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * DISKDLDECLS) (COMS * TRIDISKDLDECLS)))) (DEFINEQ (\DL.DISKINIT [LAMBDA NIL (* ; "Edited 30-Nov-87 15:06 by amd") (DECLARE (GLOBALVARS \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.HEADSPERDRIVE \DLDISKSHAPE.SECTORSPERCYLINDER \DISKTYPE \CONTROLLERTYPE \DL.SPAREDOB \DL.FAULTHANDLERDOB)) (* ;; "Determine controller type by looking on IOCB page for the password. yes, I know this is crude, but until I fix both initials, it'll have to do.") [COND [(EQ \DL.TRI.PASSWORD (fetch (TRIDENTIOCB TH.HEADER.OP) of \IOCBPAGE)) (* ;;  "If the password matches, we have a Trident (or SMD) disk. Try to figure out which disk it is.") (SETQ \CONTROLLERTYPE '\TRIDENT) (* ;; "Look at some remnants of trident initial to see if we're on a t80 / t300") (COND ((NEQ 19 (fetch (TRIDENTIOCB TH.HDSFROMINITIAL) of \IOCBPAGE)) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 30) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 5) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 150) (SETQ \DISKTYPE '\T80)) (T (SETQ \DLDISKSHAPE.SECTORSPERHEAD 30) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 19) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 570) (SETQ \DISKTYPE '\T300] (T (* ;; "Determines disk shape. \DEVICE.INPUT 3 is the KStatus register, \DEVICE.INPUT 6 is the KTest register. WARNING: Both of these registers read as their complements!") (SETQ \CONTROLLERTYPE '\SHUGART) (* ;;  "First, read work 15 of the io page. This is set to 10/11 resp. for an M2242/M2243 on the Kiku.") (COND ((EQ (\GETBASE \IOPAGE 15) 10) (* ; "M2242B: 50Mb Shugart-type disk.") (SETQ \DISKTYPE '\M2242) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 16) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 7) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 112)) ((EQ (\GETBASE \IOPAGE 15) 11) (* ; "M2243B: 80Mb Shugart-type disk.") (SETQ \DISKTYPE '\M2243) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 16) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 11) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 176)) ((NEQ 0 (LOGAND 32 (\DEVICE.INPUT 3))) (* ;  "An SA4000 is easy. The SA4000 bit is set inb KStatus") (SETQ \DISKTYPE '\SA4000) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 28) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 8) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 224)) (T (* ;; "Turn on HeadSelect16 in KCtl, which is tied to Sector' for Q2080s") (\DEVICE.OUTPUT 32768 3) (COND ((EQ 0 (LOGAND 64 (\DEVICE.INPUT 6))) (* ;  "KStatus.notsector was low when we set HeadSelect16 high, so must be the old shugart SA1000") (SETQQ \DISKTYPE \SA1000) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 16) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 4) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 64)) (T (* ; "Ktest.Sector' is false, so it must be a regular quantum. If it was a Q2080, bringing HS16 up would have brought Sector up too") (* ;; "Turn off the head select bit and see if Ktest.sector' changed") (\DEVICE.OUTPUT 0 3) (COND ((NEQ 0 (LOGAND 64 (\DEVICE.INPUT 6))) (* ;  "KStatus.notsector did not change. Must be a Q2040 with NotSector tied high") (SETQQ \DISKTYPE \Q2040) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 16) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 8) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 128)) (T (* ;  "KStatus.notsector did change, so must be Q2080 with NotSector tied to HeadSelect16") (SETQQ \DISKTYPE \Q2080) (SETQ \DLDISKSHAPE.SECTORSPERHEAD 16) (SETQ \DLDISKSHAPE.HEADSPERDRIVE 7) (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER 112] (* ;; "Initialize the DOB chain") (\DL.INIT.DOB.CHAIN) (SETQ \DL.FAULTHANDLERDOB (\DL.OBTAINNEWDOB T)) (replace (DLION.DOB FAULTFLG) of (\DL.DOB.FROM.PAGE.OFFSET \DL.FAULTHANDLERDOB) with T) (SETQ \DL.SPAREDOB (\DL.OBTAINNEWDOB T)) (replace (DLION.DOB FAULTFLG) of (\DL.DOB.FROM.PAGE.OFFSET \DL.SPAREDOB) with NIL]) (\DL.DOBNOCROSSP [LAMBDA (DOB) (* hts%: " 4-Jul-85 18:13") (* * Returns T if a DOB doesn't cross a cylinder boundary, NIL otherwise.  Needs to normalize head and sector. Last page will be first page plus run  length -  1.0) (DECLARE (GLOBALVARS \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.SECTORSPERHEAD)) (LET [(START.SECTOR (IPLUS (fetch (DLION.DOB SECTOR) of DOB) (ITIMES (fetch (DLION.DOB HEAD) of DOB) \DLDISKSHAPE.SECTORSPERHEAD] (EQ (IQUOTIENT START.SECTOR \DLDISKSHAPE.SECTORSPERCYLINDER) (IQUOTIENT (IPLUS START.SECTOR (SUB1 (OR (fetch (DLION.DOB RUNLENGTH) of DOB) 1))) \DLDISKSHAPE.SECTORSPERCYLINDER]) (\DL.GETDISKADDRESS [LAMBDA (DOB) (* mpl "27-Jun-85 10:18") (IPLUS (ITIMES (fetch (DLION.DOB CYLINDER) of DOB) \DLDISKSHAPE.SECTORSPERCYLINDER) (ITIMES (fetch (DLION.DOB HEAD) of DOB) \DLDISKSHAPE.SECTORSPERHEAD) (fetch (DLION.DOB SECTOR) of DOB]) (\DL.HANDLEMULTIRUN [LAMBDA (DOB) (* ejs%: "16-Sep-85 13:30") (* * For now, multi-page runs that cross cyl boundaries will be handled in a  simple loop) (DECLARE (GLOBALVARS \DL.SPAREDOB \IOCBPAGE)) (LET ((SPAREDOB (\DL.DOB.FROM.PAGE.OFFSET \DL.SPAREDOB))) (\BLT SPAREDOB DOB 16) (replace (DLION.DOB RUNLENGTH) of SPAREDOB with 1) (for I from 1 to (fetch (DLION.DOB RUNLENGTH) of DOB) bind STATUS do (SETQ STATUS (\DL.XFERDISK SPAREDOB)) (if (fetch (DLION.DOB INCDATAPTR) of DOB) then (replace (DLION.DOB BUFFER) of SPAREDOB with (\ADDBASE (fetch (DLION.DOB BUFFER) of SPAREDOB) WORDSPERPAGE))) (replace (DLION.DOB LABEL) of SPAREDOB with (LOCF (fetch (IOCBPAGE LID) of \IOCBPAGE)) ) (replace (DLION.DOB SECTOR) of SPAREDOB with (ADD1 (fetch (DLION.DOB SECTOR) of SPAREDOB)) ) (COND ((NEQ STATUS 'OK) (RETURN STATUS))) finally (RETURN STATUS]) (\DL.INIT.DOB.CHAIN [LAMBDA NIL (* ejs%: "14-Aug-85 23:46") (* * This fn creates the chain of DOBs that are used by the disk handler) (DECLARE (GLOBALVARS \DL.DOBPAGE \DL.DOBCHAIN) (CONSTANTS \DL.MAXDOBS \DL.DOBSIZE)) (for I from 0 to \DL.MAXDOBS bind (CurrentAddr _ \DL.DOBPAGE) do (replace (DLION.DOB NEXTDOB) of CurrentAddr with (\ADDBASE CurrentAddr \DL.DOBSIZE)) (replace (DLION.DOB STATUS) of CurrentAddr with 'FREE) (SETQ CurrentAddr (\ADDBASE CurrentAddr \DL.DOBSIZE)) finally (replace (DLION.DOB NEXTDOB) of CurrentAddr with NIL) (replace (DLION.DOB STATUS) of CurrentAddr with 'FREE)) (SETQ \DL.DOBCHAIN 0]) (\DL.OBTAINNEWDOB [LAMBDA (AS.OFFSET.INTO.PAGE) (* ejs%: "16-Sep-85 13:25") (* * Obtains a new DOB from the pool) (DECLARE (GLOBALVARS \DL.DOBCHAIN)) (PROG (NEWONE TEMP) (COND [\DL.DOBCHAIN (SETQ NEWONE (\DL.DOB.FROM.PAGE.OFFSET \DL.DOBCHAIN)) (SETQ TEMP (fetch (DLION.DOB NEXTDOB) of NEWONE)) (COND (TEMP (SETQ \DL.DOBCHAIN (\DL.PAGE.OFFSET.FROM.DOB TEMP))) (T (SETQ \DL.DOBCHAIN NIL))) (with DLION.DOB NEWONE (SETQ MODE 'VRR) (SETQ RUNLENGTH 1) (SETQ BUFFER NIL) (SETQ LABEL NIL) (SETQ FAULTFLG NIL) (SETQ INCDATAPTR NIL) (SETQ UPDATESOURCELABEL NIL) (SETQ STATUS 'INCOMPLETE) (SETQ NEXTDOB NIL)) (RETURN (COND (AS.OFFSET.INTO.PAGE (\DL.PAGE.OFFSET.FROM.DOB NEWONE)) (T NEWONE] (T (RETURN NIL]) (\DL.PUTDISKADDRESS [LAMBDA (DOB DA) (* mpl "27-Jun-85 10:15") (DECLARE (GLOBALVARS \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.SECTORSPERHEAD)) (replace (DLION.DOB CYLINDER) of DOB with (IQUOTIENT DA \DLDISKSHAPE.SECTORSPERCYLINDER)) (replace (DLION.DOB HEAD) of DOB with (IQUOTIENT (IREMAINDER DA \DLDISKSHAPE.SECTORSPERCYLINDER ) \DLDISKSHAPE.SECTORSPERHEAD)) (replace (DLION.DOB SECTOR) of DOB with (IREMAINDER (IREMAINDER DA \DLDISKSHAPE.SECTORSPERCYLINDER ) \DLDISKSHAPE.SECTORSPERHEAD]) (\DL.RECALIBRATE [LAMBDA NIL (* mpl "27-Jun-85 11:16") (* This function is used in the unlikely event that the disk drive fails to  seek correctly. It will find track 0) (PROG ((PUNTCOUNTER 1100)) (while (fetch (DLDISK.STATUS TRACK00) of (\DLDISK.GETSTATUS)) do [COND ((EQ (SETQ PUNTCOUNTER (SUB1 PUNTCOUNTER)) 0) (RAID 'CouldntRecalibrate] (with IOCBPAGE \IOCBPAGE (SETQ SSEEKCMD1 (LOGOR 128 \DL.MINUSSTEP)) (SETQ SSEEKCMD2 \DL.MINUSSTEP) (SETQ SCYLINDERDISPLACEMENT MAX.SMALLP)) (\DL.DISKOP \DL.SEEKIOCBSTART) (replace (IOCBPAGE HCYLINDER) of \IOCBPAGE with 0]) (\DL.RELEASEDOB [LAMBDA (DOB) (* ejs%: "16-Sep-85 13:39") (* * Releases a DOB to the free pool) (DECLARE (GLOBALVARS \DL.DOBCHAIN)) (replace (DLION.DOB STATUS) of DOB with 'FREE) (replace (DLION.DOB NEXTDOB) of DOB with (\DL.DOB.FROM.PAGE.OFFSET \DL.DOBCHAIN)) (replace (DLION.DOB BUFFER) of DOB with NIL) (replace (DLION.DOB LABEL) of DOB with NIL) (SETQ \DL.DOBCHAIN (\DL.PAGE.OFFSET.FROM.DOB DOB)) NIL]) (\DL.SHUGART.XFERDISK [LAMBDA (DOB) (* ; "Edited 30-Nov-87 14:40 by amd") (DECLARE (GLOBALVARS \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.HEADSPERDRIVE)) (PROG ((IOCBPG \IOCBPAGE) (TriedRecalibrate NIL) (CYL (fetch (DLION.DOB CYLINDER) of DOB)) (HD (fetch (DLION.DOB HEAD) of DOB)) (SEC (fetch (DLION.DOB SECTOR) of DOB)) (MODE (fetch (DLION.DOB MODE) of DOB)) Status RetryCount) (* ;; "Check for out of bounds triples and normalize") (SETQ HD (IPLUS HD (IQUOTIENT SEC \DLDISKSHAPE.SECTORSPERHEAD))) (SETQ SEC (IREMAINDER SEC \DLDISKSHAPE.SECTORSPERHEAD)) (SETQ CYL (IPLUS CYL (IQUOTIENT HD \DLDISKSHAPE.HEADSPERDRIVE))) (SETQ HD (IREMAINDER HD \DLDISKSHAPE.HEADSPERDRIVE)) (* ;; "First thing to do is seek the new track") RETRY (SETQ RetryCount 10) (\DL.DISKSEEK CYL) LP (* ;; "Compute and fill in the head and sector information for the IOCB's header field") (replace (IOCBPAGE HHEAD) of IOCBPG with HD) (replace (IOCBPAGE HSECTOR) of IOCBPG with SEC) (* ;; "We can do variable length runs now, but these runs MUST be in contiguous pages of virtual memory. Beware!") [replace (IOCBPAGE PRUNLENGTH) of IOCBPG with (COND ((EQ (fetch (DLION.DOB RUNLENGTH) of DOB) 0) 1) (T (fetch (DLION.DOB RUNLENGTH) of DOB] (* ;;  "Now that we know what we're doing, dispatch on the mode and set up the rest of the parameters") [with IOCBPAGE IOCBPG (* ;; "Fill in IOCB fields according to mode") (SETQ PDATALEN (COND ((fetch (DLION.DOB INCDATAPTR) of DOB) (LOGOR 256 32768)) (T 256))) (* ;; "Set the DATALEN variable to reflect wether we want to increment the page # or not") (SELECTQ MODE ((NIL VRR) (SETQ PLABELLEN 12) (SETQ PLABELCMD \DL.READFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR/CRC) (SETQ PDATACMD \DL.READFIELD) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR/CRC)) (VVR (SETQ PLABELLEN 11) (SETQ PLABELCMD \DL.VERIFYFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR/CRC/VERIFY) (SETQ PDATACMD \DL.READFIELD) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR/CRC)) (VWW (SETQ PLABELLEN 12) (SETQ PLABELCMD \DL.WRITEFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR) (SETQ PDATACMD \DL.WRITEFIELD) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR)) (VVW (SETQ PLABELLEN 11) (SETQ PLABELCMD \DL.VERIFYFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR/CRC/VERIFY) (SETQ PDATACMD \DL.WRITEFIELD) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR/CRC)) ((T VRW) (SETQ PLABELLEN 12) (SETQ PLABELCMD \DL.READFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR/CRC) (SETQ PDATACMD \DL.WRITEFIELD) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR)) (PROGN (RAID 'InvalidMode] (* ;; "Fill in the virtual page field") (* ;; "If we're incrementing the page number, the microcode increments the page number FIRST before doing the transfer. We have to offset that by subtracting one page") [replace (IOCBPAGE PVPAGE) of IOCBPG with (COND [(fetch (DLION.DOB INCDATAPTR) of DOB) (SUB1 (fetch (POINTER PAGE#) of (fetch (DLION.DOB BUFFER) of DOB] (T (fetch (POINTER PAGE#) of (fetch (DLION.DOB BUFFER) of DOB] (* ;; "More important bit twiddling gibberish that I don't understand yet") (replace (IOCBPAGE PTERMCOND1HEAD) of IOCBPG with HD) (replace (IOCBPAGE PTERMCOND2HEAD) of IOCBPG with HD) (* ;; "If we were given a label, we better put it on the IOCB page") (COND ((fetch (DLION.DOB LABEL) of DOB) (\BLT (LOCF (fetch (IOCBPAGE LID) of IOCBPG)) (fetch (DLION.DOB LABEL) of DOB) 10))) (* ;; "Finally, the moment has come.. Wake up the microcode") (SETQ Status (\DL.DISKOP \DL.XFERIOCBSTART)) (* ;;  "For now, verify errors OK in the swapper. This is so we don't have to worry about boot links.") (with IOCBPAGE IOCBPG (SETQ PLABELLEN 12) (SETQ PLABELCMD \DL.READFIELD) (SETQ PLABELABORT \DL.ABORT-NR/WF/OVR/CRC) (SETQ PDATACMD \DL.READFIELD) (SETQ PDATALEN (LOGOR 256 32768)) (SETQ PDATAABORT \DL.ABORT-NR/WF/OVR/CRC)) (* ;; "Figure out what kind of error and update the field in the DOB") [replace (DLION.DOB STATUS) of DOB with (SETQ Status (COND ((OR (fetch (DLDISK.STATUS CRCERR) of Status) (fetch (DLDISK.STATUS OVERRUN) of Status)) 'READERROR) ((fetch (DLDISK.STATUS WRITEFAULT) of Status) 'WRITEERROR) ((fetch (DLDISK.STATUS VERIFYERR) of Status) 'VERIFYERROR) (T 'OK] (* ;; "If no error but verify error, then we can go about returning; otherwise, go on and try reading again.") (COND ((OR (EQ Status 'OK) (EQ Status 'VERIFYERROR)) (* ;; "See if we have to return a label and do so if need be.") (COND ([AND (fetch (DLION.DOB LABEL) of DOB) (OR (fetch (DLION.DOB UPDATESOURCELABEL) of DOB) (EQ MODE 'VRR] (\BLT (fetch (DLION.DOB LABEL) of DOB) (LOCF (fetch (IOCBPAGE LID) of IOCBPG)) 10))) (* ;; "return the Status") (RETURN Status))) (COND ((NEQ (SETQ RetryCount (SUB1 RetryCount)) 0) (GO LP)) (TriedRecalibrate (* ;;  "We have already recalibrated and tried ten more times and failed, so we're really stuck") (RETURN Status)) (T (* ;; "Who knows? We might be lost. Recalibrate and try again") (\DL.RECALIBRATE) (SETQ TriedRecalibrate T) (GO RETRY]) (\DL.TRANSFERPAGE [LAMBDA (DA BUFPTR OP LABPTR RUNSIZE NORAIDFLG) (* mpl "29-Jun-85 17:09") (* * This is only here as a stub till all callers go away!!!) (PROG (DOB STAT) (SETQ DOB (\DL.OBTAINNEWDOB)) (COND ((NULL DOB) (RAID))) (with DLION.DOB DOB (SETQ DISKADDRESS DA) (SETQ BUFFER BUFPTR) (SETQ MODE OP) (SETQ LABEL LABPTR) (SETQ RUNLENGTH (OR RUNSIZE 1)) (SETQ NEXTDOB NIL)) (SETQ STAT (\DLDISK.EXECUTE DOB)) (SETQ DOB (\DL.RELEASEDOB DOB)) (RETURN (SELECTQ STAT (OK T) (WRITEERROR 8) (READERROR 2) (VERIFYERROR 1) NIL]) (\DLDISK.EXECUTE [LAMBDA (DOBCHAIN) (* mpl " 3-Aug-85 18:55") (* * Main call to the disk handler. Will process the chain of DOB's until an  error is detected) (while (NEQ DOBCHAIN NIL) bind (LASTSTATUS _ 'OK) do (* Check to see if the run crosses a cylinder boundary) [COND [(OR (EQ \MACHINETYPE \DAYBREAK) (EQ (OR (fetch (DLION.DOB RUNLENGTH) of DOBCHAIN) 1) 1) (\DL.DOBNOCROSSP DOBCHAIN)) (SETQ LASTSTATUS (SELECTC \MACHINETYPE (\DANDELION (\DL.XFERDISK DOBCHAIN)) (\DAYBREAK (with DLION.DOB DOBCHAIN (\DOVE.XFERDISK CYLINDER HEAD SECTOR BUFFER MODE LABEL RUNLENGTH))) (PROGN (RAID] (T (SETQ LASTSTATUS (\DL.HANDLEMULTIRUN DOBCHAIN] (replace (DLION.DOB STATUS) of DOBCHAIN with LASTSTATUS) (SETQ DOBCHAIN (fetch (DLION.DOB NEXTDOB) of DOBCHAIN)) (COND ((OR (NEQ LASTSTATUS 'OK) (NULL DOBCHAIN)) (RETURN LASTSTATUS]) (\DL.ACTONVMEMFILE [LAMBDA (FILEPAGE BUFFER NPAGES WRITEFLAG) (* bvm%: "12-Jun-85 16:32") (* Pilot page is zero-based, vmem  page is one-base) (FRPTQ NPAGES (\DL.ACTONVMEMPAGE (SUB1 FILEPAGE) BUFFER WRITEFLAG) (SETQ BUFFER (\ADDBASE BUFFER WORDSPERPAGE)) (add FILEPAGE 1]) (\DL.ACTONVMEMPAGE [LAMBDA (FILEPAGE BUFPTR WRITEFLAG) (* bvm%: " 8-Jan-86 15:29") (* This fn brings in a page of the VMEM file.  It scans over the bad page table, which contains a loose mapping of logical  pages to physical pages.) (DECLARE (GLOBALVARS \DL.FAULTHANDLERDOB)) (PROG ((LINKBASE (LOCF (fetch DLVMEMFILEINFO of \IOCBPAGE))) (I (IQUOTIENT (IDIFFERENCE (INDEXF (fetch FLOPPYIOCBSTART)) (INDEXF (fetch DLVMEMFILEINFO))) 3)) NEXTPAGE) LP [COND ((OR (IGREATERP (SETQ NEXTPAGE (fetch DLFIRSTFILEPAGE of (fetch DLNEXTRUN of LINKBASE))) FILEPAGE) (EQ 0 NEXTPAGE)) (with DLION.DOB (\DL.DOB.FROM.PAGE.OFFSET \DL.FAULTHANDLERDOB) (SETQ CYLINDER (fetch DLVMCYL of LINKBASE)) (SETQ HEAD (fetch DLVMHEAD of LINKBASE)) (SETQ SECTOR (IPLUS (IDIFFERENCE FILEPAGE (fetch DLFIRSTFILEPAGE of LINKBASE)) (fetch DLVMSECTOR of LINKBASE))) (SETQ RUNLENGTH 1) (SETQ BUFFER BUFPTR) (SETQ LABEL NIL) (SETQ MODE WRITEFLAG) (SETQ NEXTDOB NIL) (SETQ INCDATAPTR NIL) (SETQ UPDATESOURCELABEL NIL)) (RETURN (COND ((NEQ (\DL.XFERDISK (\DL.DOB.FROM.PAGE.OFFSET \DL.FAULTHANDLERDOB)) 'OK) (\MP.ERROR \MP.SWAPDISKERROR "Hard Disk Error in swapper"] (COND ((EQ 0 I) (\MP.ERROR \MP.BADRUNTABLE "Malformed run table for vmem file") (RETURN))) (SETQ I (SUB1 I)) (SETQ LINKBASE (fetch DLNEXTRUN of LINKBASE)) (GO LP]) (\DL.DISKSEEK [LAMBDA (Cylinder) (* bvm%: "12-Jun-85 16:37") (* Set DISPlacement to the difference between where we want to be and where  we are. Negative DISP means step OUT in the positive direction) (PROG ((Displacement (IDIFFERENCE Cylinder (fetch (IOCBPAGE HCYLINDER) of \IOCBPAGE))) MicrocodeSeekCommand) (* Don't try to move zero cylinders) (COND ((EQ Displacement 0) (RETURN 0))) (* This magic constant is used by the microcode to form the step command.  \DL.MINUSSTEP is the reverse step and \DL.PLUSSTEP is the forward step.  You need this constant twice, but the second time it has a 128 OR'd into it.  as part of the step command microcode) (SETQ MicrocodeSeekCommand \DL.PLUSSTEP) (* The microcode always expects to see a negative number for the  displacement, since it counts up to zero from it.  Thus, we have to make it negative if we are stepping to a cylinder that is  farther out than we are now.) (COND ((ILESSP Displacement 0) (SETQ Displacement (IMINUS Displacement))) (T (SETQ MicrocodeSeekCommand \DL.MINUSSTEP))) (* Deposit the seek commands onto  the IOCB Page) (replace (IOCBPAGE SSEEKCMD2) of \IOCBPAGE with MicrocodeSeekCommand) (replace (IOCBPAGE SSEEKCMD1) of \IOCBPAGE with (LOGOR MicrocodeSeekCommand 128 )) (* Place the displacement value onto  the IOCB Page) (replace (IOCBPAGE SCYLINDERDISPLACEMENT) of \IOCBPAGE with (ADD1 (LOGXOR Displacement 65535))) (* Two's complement of Displacement --  note it is not zero) (* Finally, we should update the header record to indicate our new position) (replace (IOCBPAGE HCYLINDER) of \IOCBPAGE with Cylinder) (* |...| and wake up the microcode to get things rolling! Note%: the 338  below is another DLion magic number, and it refers to the distance into the  I/O page + 256 where the beginning of the microprogram for the disk microcode  is. This is the beginning of the SEEK iocb.  It is also used in \DL.RECALIBRATE, and the TRANSFER iocb is used in  \DL.XFERDISK) (RETURN (\DL.DISKOP \DL.SEEKIOCBSTART]) (\DL.XFERDISK [LAMBDA (DOB) (* ; "Edited 30-Nov-87 15:40 by amd") (DECLARE (GLOBALVARS \CONTROLLERTYPE)) (COND [(EQ \CONTROLLERTYPE '\TRIDENT) (* ; "We're using a Trident") (replace (DLION.DOB STATUS) of DOB with (\DL.TRI.XFERDISK (fetch (DLION.DOB CYLINDER) of DOB) (fetch (DLION.DOB HEAD) of DOB) (fetch (DLION.DOB SECTOR) of DOB) (fetch (DLION.DOB BUFFER) of DOB) (fetch (DLION.DOB MODE) of DOB) (fetch (DLION.DOB LABEL) of DOB) (fetch (DLION.DOB RUNLENGTH) of DOB] (T (* ; "We're using a Shugart") (SELECTQ \DISKTYPE ((\SA4000 \M2242 \M2243) (* ;  "Bug somewhere that causes these drives to fail on VVW: change it to VRW to work around this.") (AND (EQ (FETCH (DLION.DOB MODE) OF DOB) 'VVW) (REPLACE (DLION.DOB MODE) OF DOB WITH 'VRW))) NIL) (\DL.SHUGART.XFERDISK DOB]) (\DL.DISKOP [LAMBDA (IOCB) (* bvm%: "12-Jun-85 13:15") (* Put something unreasonable onto the IOCB status so when it changes we will  know it's over.) (replace (IOCBPAGE LASTIOCBSTATUS) of \IOCBPAGE with 256) (* Start the microcode. There isn't a field in IOPAGE yet for this.) (\PUTBASE \IOPAGE 1 IOCB) (* Issue a FirmWare Enable) (\DEVICE.OUTPUT 32 3) (* wait for it to change back) (until (EQ (LOGAND (fetch (IOCBPAGE LASTIOCBSTATUS) of \IOCBPAGE) 256) 0)) (* return status) (fetch (IOCBPAGE LASTIOCBSTATUS) of \IOCBPAGE]) (\DL.TRI.INITIATE.IO [LAMBDA NIL (* bvm%: "12-Jun-85 13:14") (* This function starts the  microcode for the Trident disk) (* Send wakeup to KCMD, register 13) (\DEVICE.OUTPUT \DL.TRI.STARTCMD 13) (until (EQ (LOGAND (fetch (TRIDENTIOCB TH.CONTROLLERSTATUS) of \IOCBPAGE) 32768) 0)) (fetch (TRIDENTIOCB TH.CONTROLLERSTATUS) of \IOCBPAGE]) (\DL.TRI.XFERDISK [LAMBDA (CYL HD SEC BUFFER MODE LABEL RUNLENGTH NORAIDFLG) (* mpl " 2-Aug-85 15:51") (* This is \DL.TRI.XFERDISK, the lowest level driver for DLion Trident disks,  capable of working with labels and retaining the same arguments the old one,  but adding a few more%: NORAIDFLG LABEL, MODE, If USERFLG is T, errors will  be returned, or else RAID is called. LABEL points to a LABEL record, Mode  supplants WRITEFLG and can be VRR, VVR, VVW, or VWW.) (DECLARE (GLOBALVARS \DLDISKSHAPE.HEADSPERDRIVE \DLDISKSHAPE.SECTORSPERHEAD)) (PROG ((RetryCount 10) Status USERFLG (FLG NIL) (Drive 0) DriveMask) (* Check for out of bounds triples  and normalize) (COND ((EQ RUNLENGTH 0) (SETQ RUNLENGTH 1))) [SETQ DriveMask (LLSH 1 (IPLUS 8 (IDIFFERENCE 3 Drive] (SETQ HD (IPLUS HD (IQUOTIENT SEC \DLDISKSHAPE.SECTORSPERHEAD))) (SETQ SEC (IMOD SEC \DLDISKSHAPE.SECTORSPERHEAD)) (SETQ CYL (IPLUS CYL (IQUOTIENT HD \DLDISKSHAPE.HEADSPERDRIVE))) (SETQ HD (IMOD HD \DLDISKSHAPE.HEADSPERDRIVE)) (* no recal first time) (replace (TRIDENTDCB RECALIBRATE) of \IOPAGE with NIL) LP (* Compute and fill in the head and sector information for the IOCB's header  field) [with TRIDENTIOCB \IOCBPAGE (SETQ TH.CYL CYL) (SETQ TH.HD HD) (SETQ TH.SEC SEC) (SETQ TH.CONTROLLERSTATUS 49152) (SETQ TH.DISKSTATUS 0) (SETQ TH.MICRONEXT 0) (SETQ TH.DCBOFFSET 0) [SETQ TH.LABELPTRLO (LOGAND 65280 (\LOLOC (LOCF (fetch (TRIDENTIOCB TH.READLABEL ) of \IOPAGE] (SETQ TH.LABELPTRHI (\HILOC (LOCF (fetch (TRIDENTIOCB TH.READLABEL) of \IOPAGE] (* Copy client header to uCode  header) (with TRIDENTIOCB \IOCBPAGE (SETQ TH.uCYL TH.CYL) (SETQ TH.uSEC TH.SEC) (SETQ TH.uHD TH.HD)) (* Set up the SEEK portion of the  IOCB) (with TRIDENTIOCB \IOCBPAGE (SETQ TH.SEEK.XFERMASK 0) (SETQ TH.SEEK.KDRIVE 63488) (SETQ TH.SEEK.KCYL (LOGOR \TH.SEEK.CYLCMD CYL)) (SETQ TH.SEEK.KHEAD (LOGOR \TH.SEEK.HDCMD HD))) (* Set up the HEADER portion of the  IOCB) (with TRIDENTIOCB \IOCBPAGE (SETQ TH.HEADER.COMMAND \TH.HV.COMMAND) (SETQ TH.HEADER.CONTROL \TH.HV.CONTROL) (SETQ TH.HEADER.OP \TH.HV.OP) (SETQ TH.HEADER.ERRORMASK \TH.HV.ERRORMASK)) (* We can do variable length runs now, but these runs MUST be in contiguous  pages of virtual memory. Beware!) (replace (TRIDENTIOCB TH.PAGECOUNT) of \IOCBPAGE with (COND (RUNLENGTH RUNLENGTH) (T 1))) (* Now that we know what we're doing, dispatch on the mode and set up the  rest of the parameters) (SELECTQ MODE ((NIL VRR) (with TRIDENTIOCB \IOCBPAGE (SETQ TH.LABEL.OP \TH.LR.OP) (SETQ TH.LABEL.ERRORMASK \TH.LR.ERRORMASK) (SETQ TH.LABEL.CONTROL (LOGOR \TH.LR.CONTROL DriveMask)) (SETQ TH.LABEL.COMMAND \TH.LR.COMMAND) (SETQ TH.DATA.OP \TH.DR.OP) (SETQ TH.DATA.ERRORMASK \TH.DR.ERRORMASK) (SETQ TH.DATA.CONTROL (LOGOR \TH.DR.CONTROL DriveMask)) (SETQ TH.DATA.COMMAND \TH.DR.COMMAND))) (VVR (with TRIDENTIOCB \IOCBPAGE (SETQ TH.LABEL.OP \TH.LV.OP) (SETQ TH.LABEL.ERRORMASK \TH.LV.ERRORMASK) (SETQ TH.LABEL.CONTROL (LOGOR \TH.LV.CONTROL DriveMask)) (SETQ TH.LABEL.COMMAND \TH.LV.COMMAND) (SETQ TH.DATA.OP \TH.DR.OP) (SETQ TH.DATA.ERRORMASK \TH.DR.ERRORMASK) (SETQ TH.DATA.CONTROL (LOGOR \TH.DR.CONTROL DriveMask)) (SETQ TH.DATA.COMMAND \TH.DR.COMMAND))) (VWW (with TRIDENTIOCB \IOCBPAGE (SETQ TH.LABEL.OP \TH.LW.OP) (SETQ TH.LABEL.ERRORMASK \TH.LW.ERRORMASK) (SETQ TH.LABEL.CONTROL (LOGOR \TH.LW.CONTROL DriveMask)) (SETQ TH.LABEL.COMMAND \TH.LW.COMMAND) (SETQ TH.DATA.OP \TH.DW.OP) (SETQ TH.DATA.ERRORMASK \TH.DW.ERRORMASK) (SETQ TH.DATA.CONTROL (LOGOR \TH.WW.CONTROL DriveMask)) (SETQ TH.DATA.COMMAND \TH.DW.COMMAND))) (VVW (with TRIDENTIOCB \IOCBPAGE (SETQ TH.LABEL.OP \TH.LV.OP) (SETQ TH.LABEL.ERRORMASK \TH.LV.ERRORMASK) (SETQ TH.LABEL.CONTROL (LOGOR \TH.LV.CONTROL DriveMask)) (SETQ TH.DATA.OP \TH.DW.OP) (SETQ TH.DATA.ERRORMASK \TH.DW.ERRORMASK) (SETQ TH.DATA.CONTROL (LOGOR \TH.DW.CONTROL DriveMask)) (SETQ TH.DATA.COMMAND \TH.DW.COMMAND))) ((T VRW) (with TRIDENTIOCB \IOCBPAGE (SETQ TH.LABEL.OP \TH.LR.OP) (SETQ TH.LABEL.ERRORMASK \TH.LR.ERRORMASK) (SETQ TH.LABEL.CONTROL (LOGOR \TH.LR.CONTROL DriveMask)) (SETQ TH.LABEL.COMMAND \TH.LR.COMMAND) (SETQ TH.DATA.OP \TH.DW.OP) (SETQ TH.DATA.ERRORMASK \TH.DW.ERRORMASK) (SETQ TH.DATA.CONTROL (LOGOR \TH.DW.CONTROL DriveMask)) (SETQ TH.DATA.COMMAND \TH.DW.COMMAND))) (PROGN (RAID "Invalid MODE for \DL.TRI.XFERDISK"))) (* Fill in the virtual page field) (replace (TRIDENTIOCB TH.DATAPTRHI) of \IOCBPAGE with (\HILOC BUFFER)) (replace (TRIDENTIOCB TH.DATAPTRLO) of \IOCBPAGE with (\LOLOC BUFFER)) (* If we were given a label, we better put it on the IOCB page) (COND ((AND LABEL (NEQ MODE 'VRR) (NEQ MODE 'VRW)) (\BLT (LOCF (fetch (TRIDENTIOCB TH.WRITEVERIFYLABEL) of \IOCBPAGE)) LABEL 10))) (* why the hell does the uCode need  this???) (replace (TRIDENTIOCB TH.FILEPAGELO) of \IOCBPAGE with (\GETBASE (LOCF (fetch (TRIDENTIOCB TH.READLABEL) of \IOCBPAGE)) 5)) (* Finally, the moment has come..  Wake up the microcode) (* The constant here removes  uninteresting bits from the status) (replace (TRIDENTDCB MICRONEXT) of \IOPAGE with (\LOLOC \IOCBPAGE)) (SETQ Status (LOGAND 56888 (\DL.TRI.INITIATE.IO))) (* * If we need to return a label, copy it out of the iocb page) (COND (LABEL (SELECTQ MODE ((VRR VRW T) (\BLT LABEL (LOCF (fetch (TRIDENTIOCB TH.READLABEL) of \IOCBPAGE )) 10)) NIL))) (* only recal once) (replace (TRIDENTDCB RECALIBRATE) of \IOPAGE with NIL) (* Trident controller indicates good completion in bit 2 from left of  controller status) [COND ((NEQ (LOGAND 16384 Status) 0) (* Convert status to be same as for  shugart status) (RETURN 'OK] (SETQ RetryCount (SUB1 RetryCount)) (COND ((EQ RetryCount 0) (* We have already recalibrated and tried ten more times and failed, so we're  really stuck) (COND [FLG (COND (NORAIDFLG (RETURN Status)) (T (RAID "Hard disk error" Status] (T [SETQ Status (LOGOR (COND ((NEQ (LOGAND Status 2048) 0) 'VERIFYERROR)) (COND ((NEQ (LOGAND Status 1024) 0) 'READERROR)) (COND ((NEQ (LOGAND Status 512) 0) 'READERROR] (RETURN Status))) (* Who knows? We might be lost. Recalibrate and try again) (replace (TRIDENTDCB RECALIBRATE) of \IOPAGE with T) (SETQ FLG T) (GO LP)) (T (GO LP]) ) (DEFINEQ (\DISKDLION.INIT [LAMBDA NIL (* mpl " 2-Aug-85 15:39") (SETQ \DL.DOBPAGE (NCREATE 'VMEMPAGEP)) (\LOCKPAGES \DL.DOBPAGE 1) (MAPC '(\MAKENUMBER \SETGLOBALVAL.UFN \RPLPTR.UFN \HTFIND \SLOWIPLUS2 \SLOWIDIFFERENCE \SLOWLLSH1 \SLOWLLSH8 \SLOWLRSH1 \SLOWLRSH8 \SLOWLOGOR2 \SLOWLOGAND2 \SLOWLOGXOR2 \SLOWIGREATERP \SLOWIQUOTIENT \SLOWITIMES2 IMOD IREMAINDER) (FUNCTION \LOCKFN)) (MAPC '(\DL.DISKINIT \DL.INIT.DOB.CHAIN \DL.ACTONVMEMFILE \DL.ACTONVMEMPAGE \DL.DISKSEEK \DL.XFERDISK \DL.DISKOP \DL.RECALIBRATE \DL.SHUGART.XFERDISK \DL.OBTAINNEWDOB \DL.RELEASEDOB \DLDISK.EXECUTE \DL.HANDLEMULTIRUN \DL.PUTDISKADDRESS \DL.TRI.INITIATE.IO \DL.TRI.XFERDISK) (FUNCTION \LOCKFN)) (MAPC '(\SMALLNEGSPACE \IOCBPAGE \MDSTypeTable \HTCOLL \HTMAIN \VMBASEDP \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.HEADSPERDRIVE \DISKTYPE \CONTROLLERTYPE \DL.DOBPAGE \DL.DOBCHAIN \DL.FAULTHANDLERDOB \DL.SPAREDOB) (FUNCTION \LOCKVAR]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? \DLDISKSHAPE.SECTORSPERCYLINDER NIL) (RPAQ? \DLDISKSHAPE.HEADSPERDRIVE NIL) (RPAQ? \DLDISKSHAPE.SECTORSPERHEAD NIL) (RPAQ? \DL.FAULTHANDLERDOB NIL) (RPAQ? \DL.DOBPAGE NIL) (RPAQ? \DL.DOBCHAIN NIL) (RPAQ? \DL.SPAREDOB NIL) (RPAQ? \DISKTYPE NIL) (RPAQ? \CONTROLLERTYPE NIL) (\DISKDLION.INIT) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ DISKDLDECLS ((FILES (SOURCE) DISKVMEMDECLS) (GLOBALVARS \DL.DOBCHAIN \DL.DOBPAGE \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.HEADSPERDRIVE \DISKTYPE \CONTROLLERTYPE) (RECORDS DLDISK.STATUS TRIDENTIOCB) (MACROS \DLDISK.GETSTATUS) (FUNCTIONS \DL.DOB.FROM.PAGE.OFFSET \DL.PAGE.OFFSET.FROM.DOB) (CONSTANTS \DL.ABORT-NR/WF/OVR \DL.ABORT-NR/WF/OVR/CRC \DL.ABORT-NR/WF/OVR/CRC/VERIFY \DL.READFIELD \DL.SEEKIOCBSTART \DL.VERIFYFIELD \DL.WRITEFIELD \DL.XFERIOCBSTART \DL.MINUSSTEP \DL.PLUSSTEP) (CONSTANTS \DL.TRI.PASSWORD) (CONSTANTS \DL.DOBSIZE \DL.MAXDOBS) (RECORDS DLVMEMRUN IOCBPAGE))) (FILESLOAD (SOURCE) DISKVMEMDECLS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DL.DOBCHAIN \DL.DOBPAGE \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.HEADSPERDRIVE \DISKTYPE \CONTROLLERTYPE) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS DLDISK.STATUS ((TRACK00 (NEQ (LOGAND DATUM 512) 0)) (HEADSELECT (LOGXOR (LRSH DATUM 11) 31)) (SA1000 (NEQ (LOGAND DATUM 32) 0)) (DRIVENOTREADY (NEQ (LOGAND DATUM 16) 0)) (WRITEFAULT (NEQ (LOGAND DATUM 8) 0)) (OVERRUN (NEQ (LOGAND DATUM 4) 0)) (CRCERR (NEQ (LOGAND DATUM 2) 0)) (VERIFYERR (NEQ (LOGAND DATUM 1) 0)))) (BLOCKRECORD TRIDENTIOCB ((TH.CYL WORD) (TH.HD BYTE) (TH.SEC BYTE) (TH.LABELPTRLO WORD) (TH.LABELPTRHI WORD) (TH.DATAPTRLO WORD) (TH.DATAPTRHI WORD) (TH.RETRIES WORD) (TH.PAGECOUNT WORD) (TH.CONTROLLERSTATUS WORD) (TH.DISKSTATUS WORD) (TH.uCYL WORD) (TH.uHD BYTE) (TH.uSEC BYTE) (NIL WORD) (TH.MICRONEXT WORD) (TH.DCBOFFSET WORD) (TH.FILEPAGELO WORD) (TH.SEEK.XFERMASK WORD) (TH.SEEK.KDRIVE WORD) (TH.SEEK.KCYL WORD) (TH.SEEK.KHEAD WORD) (TH.HEADER.OP WORD) (TH.HEADER.COMMAND WORD) (TH.HEADER.CONTROL WORD) (TH.HEADER.ERRORMASK WORD) (TH.LABEL.OP WORD) (TH.LABEL.COMMAND WORD) (TH.LABEL.CONTROL WORD) (TH.LABEL.ERRORMASK WORD) (TH.DATA.OP WORD) (TH.DATA.COMMAND WORD) (TH.DATA.CONTROL WORD) (TH.DATA.ERRORMASK WORD) (TH.WRITEVERIFYLABEL 10 WORD) (NIL 5 WORD) (TH.HDSFROMINITIAL WORD) (TH.READLABEL 10 WORD) (NIL 8 WORD) (TH.DSB0.PILOTNEXT WORD) (TH.DSB0.MICRONEXT WORD) (TH.DSB0.PILOTTAIL WORD) (TH.DSB0.SELECTDATA WORD))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \DLDISK.GETSTATUS MACRO (NIL (\DEVICE.INPUT 3))) ) (DEFMACRO \DL.DOB.FROM.PAGE.OFFSET (OFFSET) `(\ADDBASE \DL.DOBPAGE ,OFFSET)) (DEFMACRO \DL.PAGE.OFFSET.FROM.DOB (DOB) `(IDIFFERENCE (\LOLOC ,DOB) (\LOLOC \DL.DOBPAGE))) (DECLARE%: EVAL@COMPILE (RPAQQ \DL.ABORT-NR/WF/OVR 28) (RPAQQ \DL.ABORT-NR/WF/OVR/CRC 30) (RPAQQ \DL.ABORT-NR/WF/OVR/CRC/VERIFY 31) (RPAQQ \DL.READFIELD 1072) (RPAQQ \DL.SEEKIOCBSTART 338) (RPAQQ \DL.VERIFYFIELD 1074) (RPAQQ \DL.WRITEFIELD 1083) (RPAQQ \DL.XFERIOCBSTART 355) (RPAQQ \DL.MINUSSTEP 1120) (RPAQQ \DL.PLUSSTEP 1056) (CONSTANTS \DL.ABORT-NR/WF/OVR \DL.ABORT-NR/WF/OVR/CRC \DL.ABORT-NR/WF/OVR/CRC/VERIFY \DL.READFIELD \DL.SEEKIOCBSTART \DL.VERIFYFIELD \DL.WRITEFIELD \DL.XFERIOCBSTART \DL.MINUSSTEP \DL.PLUSSTEP) ) (DECLARE%: EVAL@COMPILE (RPAQQ \DL.TRI.PASSWORD 279) (CONSTANTS \DL.TRI.PASSWORD) ) (DECLARE%: EVAL@COMPILE (RPAQQ \DL.DOBSIZE 16) (RPAQQ \DL.MAXDOBS 14) (CONSTANTS \DL.DOBSIZE \DL.MAXDOBS) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD DLVMEMRUN ((DLFIRSTFILEPAGE WORD) (DLVMCYL WORD) (DLVMHEAD BYTE) (DLVMSECTOR BYTE)) [ACCESSFNS DLVMEMRUN ((DLNEXTRUN (\ADDBASE DATUM 3]) (BLOCKRECORD IOCBPAGE ((NIL 3 WORD) (LASTIOCBSTATUS WORD) (NEXTIOCB WORD) (SEEKIOCBLOC WORD) (XFERIOCBLOC WORD) (VRRIOCBLOC WORD) (VVRIOCBLOC WORD) (HCYLINDER WORD) (HHEAD BYTE) (HSECTOR BYTE) (LID 5 WORD) (LPAGELO WORD) (LPAGEHI BITS 7) (NIL BITS 6) (LFLAGS BITS 3) (LTYPE WORD) (LBOOTLINKCHAIN1 WORD) (LBOOTLINKCHAIN2 WORD) (NIL 43 WORD) (PRUNLENGTH WORD) (NIL 6 WORD) (PLABELCMD WORD) (PLABELLEN WORD) (NIL WORD) (PLABELABORT WORD) (PDATACMD WORD) (PDATALEN WORD) (PVPAGE WORD) (PDATAABORT WORD) (PTERMCOND1HEAD BITS 5) (PTERMCOND1MAGIC BITS 11) (PTERMCOND2HEAD BITS 5) (PTERMCOND2MAGIC BITS 11) (SCYLINDERDISPLACEMENT WORD) (NIL 5 WORD) (SSEEKCMD1 WORD) (NIL WORD) (SSEEKCMD2 WORD) (NIL 9 WORD) (NIL 20 WORD) (* Used to be 21, but that bumps  into vmem file info.  RS232 bug?) (RS232CGETIOCB 8 WORD) (DLVMEMFILEINFO 113 WORD) (* bunch of VMEMFILERUN entries  describing vmem disk addresses) (FLOPPYIOCBSTART 16 WORD))) ) (RPAQQ TRIDISKDLDECLS ((RECORDS TRIDENTDCB TRIDENTIOCB) (CONSTANTS \TH.DR.COMMAND \TH.DR.CONTROL \TH.DR.ERRORMASK \TH.DR.OP \TH.DW.COMMAND \TH.DW.CONTROL \TH.DW.ERRORMASK \TH.DW.OP \TH.LN.COMMAND \TH.LN.CONTROL \TH.LN.ERRORMASK \TH.LN.OP \TH.LR.COMMAND \TH.LR.CONTROL \TH.LR.ERRORMASK \TH.LR.OP \TH.LV.COMMAND \TH.LV.CONTROL \TH.LV.ERRORMASK \TH.LV.OP \TH.LW.COMMAND \TH.LW.CONTROL \TH.LW.ERRORMASK \TH.LW.OP \TH.WW.CONTROL \DL.TRI.STARTCMD \TH.SEEK.HDCMD \TH.SEEK.CYLCMD) (CONSTANTS \TH.HV.COMMAND \TH.HV.CONTROL \TH.HV.ERRORMASK \TH.HV.OP \DL.TRI.PASSWORD) (CONSTANTS \TH.DOCTL.RESETDEVICECHECK \TH.DOCTL.SETHD5 \TH.NULLCTL.RESETDEVICECHECK \TH.NULLCTL.SETHD5))) (DECLARE%: EVAL@COMPILE (BLOCKRECORD TRIDENTDCB ((PILOTNEXT WORD) (MICRONEXT WORD) (PILOTTAIL WORD) (RECALIBRATE FLAG) (SELECTMASK BITS 7) (DISKTYPE BITS 3) (DCBOFFSET BITS 4))) (BLOCKRECORD TRIDENTIOCB ((TH.CYL WORD) (TH.HD BYTE) (TH.SEC BYTE) (TH.LABELPTRLO WORD) (TH.LABELPTRHI WORD) (TH.DATAPTRLO WORD) (TH.DATAPTRHI WORD) (TH.RETRIES WORD) (TH.PAGECOUNT WORD) (TH.CONTROLLERSTATUS WORD) (TH.DISKSTATUS WORD) (TH.uCYL WORD) (TH.uHD BYTE) (TH.uSEC BYTE) (NIL WORD) (TH.MICRONEXT WORD) (TH.DCBOFFSET WORD) (TH.FILEPAGELO WORD) (TH.SEEK.XFERMASK WORD) (TH.SEEK.KDRIVE WORD) (TH.SEEK.KCYL WORD) (TH.SEEK.KHEAD WORD) (TH.HEADER.OP WORD) (TH.HEADER.COMMAND WORD) (TH.HEADER.CONTROL WORD) (TH.HEADER.ERRORMASK WORD) (TH.LABEL.OP WORD) (TH.LABEL.COMMAND WORD) (TH.LABEL.CONTROL WORD) (TH.LABEL.ERRORMASK WORD) (TH.DATA.OP WORD) (TH.DATA.COMMAND WORD) (TH.DATA.CONTROL WORD) (TH.DATA.ERRORMASK WORD) (TH.WRITEVERIFYLABEL 10 WORD) (NIL 5 WORD) (TH.HDSFROMINITIAL WORD) (TH.READLABEL 10 WORD) (NIL 8 WORD) (TH.DSB0.PILOTNEXT WORD) (TH.DSB0.MICRONEXT WORD) (TH.DSB0.PILOTTAIL WORD) (TH.DSB0.SELECTDATA WORD))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TH.DR.COMMAND 11332) (RPAQQ \TH.DR.CONTROL 61582) (RPAQQ \TH.DR.ERRORMASK 1536) (RPAQQ \TH.DR.OP 14) (RPAQQ \TH.DW.COMMAND 11396) (RPAQQ \TH.DW.CONTROL 61583) (RPAQQ \TH.DW.ERRORMASK 512) (RPAQQ \TH.DW.OP 13) (RPAQQ \TH.LN.COMMAND 15364) (RPAQQ \TH.LN.CONTROL 61588) (RPAQQ \TH.LN.ERRORMASK 512) (RPAQQ \TH.LN.OP 0) (RPAQQ \TH.LR.COMMAND 11332) (RPAQQ \TH.LR.CONTROL 61580) (RPAQQ \TH.LR.ERRORMASK 1536) (RPAQQ \TH.LR.OP 10) (RPAQQ \TH.LV.COMMAND 11332) (RPAQQ \TH.LV.CONTROL 61573) (RPAQQ \TH.LV.ERRORMASK 3584) (RPAQQ \TH.LV.OP 11) (RPAQQ \TH.LW.COMMAND 11396) (RPAQQ \TH.LW.CONTROL 61581) (RPAQQ \TH.LW.ERRORMASK 512) (RPAQQ \TH.LW.OP 9) (RPAQQ \TH.WW.CONTROL 61455) (RPAQQ \DL.TRI.STARTCMD 3072) (RPAQQ \TH.SEEK.HDCMD 3072) (RPAQQ \TH.SEEK.CYLCMD 3072) (CONSTANTS \TH.DR.COMMAND \TH.DR.CONTROL \TH.DR.ERRORMASK \TH.DR.OP \TH.DW.COMMAND \TH.DW.CONTROL \TH.DW.ERRORMASK \TH.DW.OP \TH.LN.COMMAND \TH.LN.CONTROL \TH.LN.ERRORMASK \TH.LN.OP \TH.LR.COMMAND \TH.LR.CONTROL \TH.LR.ERRORMASK \TH.LR.OP \TH.LV.COMMAND \TH.LV.CONTROL \TH.LV.ERRORMASK \TH.LV.OP \TH.LW.COMMAND \TH.LW.CONTROL \TH.LW.ERRORMASK \TH.LW.OP \TH.WW.CONTROL \DL.TRI.STARTCMD \TH.SEEK.HDCMD \TH.SEEK.CYLCMD) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TH.HV.COMMAND 11332) (RPAQQ \TH.HV.CONTROL 63619) (RPAQQ \TH.HV.ERRORMASK 3584) (RPAQQ \TH.HV.OP 279) (RPAQQ \DL.TRI.PASSWORD 279) (CONSTANTS \TH.HV.COMMAND \TH.HV.CONTROL \TH.HV.ERRORMASK \TH.HV.OP \DL.TRI.PASSWORD) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TH.DOCTL.RESETDEVICECHECK 9224) (RPAQQ \TH.DOCTL.SETHD5 17413) (RPAQQ \TH.NULLCTL.RESETDEVICECHECK 1032) (RPAQQ \TH.NULLCTL.SETHD5 1029) (CONSTANTS \TH.DOCTL.RESETDEVICECHECK \TH.DOCTL.SETHD5 \TH.NULLCTL.RESETDEVICECHECK \TH.NULLCTL.SETHD5) ) ) (PUTPROPS DISKDLION COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1372 46542 (\DL.DISKINIT 1382 . 6503) (\DL.DOBNOCROSSP 6505 . 7435) (\DL.GETDISKADDRESS 7437 . 7825) (\DL.HANDLEMULTIRUN 7827 . 9539) (\DL.INIT.DOB.CHAIN 9541 . 10476) (\DL.OBTAINNEWDOB 10478 . 11703) (\DL.PUTDISKADDRESS 11705 . 12786) (\DL.RECALIBRATE 12788 . 13693) (\DL.RELEASEDOB 13695 . 14262) (\DL.SHUGART.XFERDISK 14264 . 24257) (\DL.TRANSFERPAGE 24259 . 25131) (\DLDISK.EXECUTE 25133 . 26617) (\DL.ACTONVMEMFILE 26619 . 27104) (\DL.ACTONVMEMPAGE 27106 . 29295) (\DL.DISKSEEK 29297 . 32176) (\DL.XFERDISK 32178 . 34456) (\DL.DISKOP 34458 . 35314) (\DL.TRI.INITIATE.IO 35316 . 35979) (\DL.TRI.XFERDISK 35981 . 46540)) (46543 47718 (\DISKDLION.INIT 46553 . 47716))))) STOP \ No newline at end of file diff --git a/sources/DISKVMEMDECLS b/sources/DISKVMEMDECLS new file mode 100644 index 00000000..36dadcfd --- /dev/null +++ b/sources/DISKVMEMDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 15:47:47" {DSK}local>lde>lispcore>sources>DISKVMEMDECLS.;2 4121 changes to%: (VARS DISKVMEMDECLSCOMS) previous date%: "27-Mar-86 12:49:26" {DSK}local>lde>lispcore>sources>DISKVMEMDECLS.;1) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DISKVMEMDECLSCOMS) (RPAQQ DISKVMEMDECLSCOMS ((* Records describing Dlion/Daybreak IOCBPAGE) (RECORDS DLVMEMRUN IOCBPAGE DLION.DOB))) (* Records describing Dlion/Daybreak IOCBPAGE) (DECLARE%: EVAL@COMPILE (BLOCKRECORD DLVMEMRUN ((DLFIRSTFILEPAGE WORD) (DLVMCYL WORD) (DLVMHEAD BYTE) (DLVMSECTOR BYTE)) [ACCESSFNS DLVMEMRUN ((DLNEXTRUN (\ADDBASE DATUM 3]) (BLOCKRECORD IOCBPAGE ((NIL 3 WORD) (LASTIOCBSTATUS WORD) (NEXTIOCB WORD) (SEEKIOCBLOC WORD) (XFERIOCBLOC WORD) (VRRIOCBLOC WORD) (VVRIOCBLOC WORD) (HCYLINDER WORD) (HHEAD BYTE) (HSECTOR BYTE) (LID 5 WORD) (LPAGELO WORD) (LPAGEHI BITS 7) (NIL BITS 6) (LFLAGS BITS 3) (LTYPE WORD) (LBOOTLINKCHAIN1 WORD) (LBOOTLINKCHAIN2 WORD) (NIL 43 WORD) (PRUNLENGTH WORD) (NIL 6 WORD) (PLABELCMD WORD) (PLABELLEN WORD) (NIL WORD) (PLABELABORT WORD) (PDATACMD WORD) (PDATALEN WORD) (PVPAGE WORD) (PDATAABORT WORD) (PTERMCOND1HEAD BITS 5) (PTERMCOND1MAGIC BITS 11) (PTERMCOND2HEAD BITS 5) (PTERMCOND2MAGIC BITS 11) (SCYLINDERDISPLACEMENT WORD) (NIL 5 WORD) (SSEEKCMD1 WORD) (NIL WORD) (SSEEKCMD2 WORD) (NIL 9 WORD) (NIL 20 WORD) (* Used to be 21, but that bumps  into vmem file info.  RS232 bug?) (RS232CGETIOCB 8 WORD) (DLVMEMFILEINFO 113 WORD) (* bunch of VMEMFILERUN entries  describing vmem disk addresses) (FLOPPYIOCBSTART 16 WORD))) (BLOCKRECORD DLION.DOB ((CYLINDER WORD) (HEAD WORD) (SECTOR WORD) (RUNLENGTH WORD) (MODE FULLXPOINTER) (BUFFER FULLXPOINTER) (LABEL FULLXPOINTER) (NIL WORD) (NIL BITS 13) (UPDATESOURCELABEL FLAG) (FAULTFLG FLAG) (INCDATAPTR FLAG) (STATUS FULLXPOINTER) (NEXTDOB FULLXPOINTER)) (ACCESSFNS (DISKADDRESS (\DL.GETDISKADDRESS DATUM) (\DL.PUTDISKADDRESS DATUM NEWVALUE)))) ) (PUTPROPS DISKVMEMDECLS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/DLAP b/sources/DLAP new file mode 100644 index 00000000..5a6d0215 --- /dev/null +++ b/sources/DLAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "25-Jan-93 16:56:13" |{PELE:MV:ENVOS}LIBRARY>DLAP.;1| 95225 changes to%: (PROPS (FLOAT DOPVAL) (\FLOAT.BOX DOPVAL)) previous date%: "17-Nov-92 01:01:02" |{PELE:MV:ENVOS}SOURCES>DLAP.;11|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1981 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 DLAPCOMS) (RPAQQ DLAPCOMS ( (* ;; " Assembler for the Byte Compiler. ") (FNS C.FLOATBOX C.FLOATUNBOX DASSEM.DASSEM DASSEM.DWRITEFN DASSEM.SAVELOCALVARS DASSEM.DSTOREFNDEF DASSEM.DPRINTLAP DASSEM.EQCONSTANTP DASSEM.MATCHVARS DASSEM.COUNTVARS DASSEM.CANSHAREBINDING) (CONSTANTS NARGMAX NLOCALMAX NFREEMAX) (FNS DASSEM.DASMBIND DASSEM.DSTOREFN DASSEM.ASMAJ) (VARS (EMFLAG) (COMPILEMODE 'D)) (PROP (MOPVAL AJSIZES) JUMP FJUMP TJUMP NTJUMP NFJUMP) (PROP DOPVAL * DOPVALS) (VARS CONSTOPS (COMPILE.ARG.FAST.FLG) (IPLUSNFLG)) (ADDVARS (8BITEXTS DCOM)) (ADDVARS (MACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO)) (ADDVARS (COMPILERMACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO)) (VARS (BYTEASSEMFN 'DASSEM.DASSEM) (MAXBVALS 15) (BYTECOMPFLG T) (SELECTQFMEMB NIL) (LAMBDANOBIND T) (SELECTVARTYPES '(AVAR HVAR)) [CONST.FNS '((NIL (1 CAR (CONST)) (1 CDR (CONST)) (1 NULL (CONST . T)) (2 EQ (FN 1 . NULL))) (0 (2 ITIMES2 (POP) (CONST . 0)) (2 LOGAND2 (POP) (CONST . 0)) (2 IPLUS (FN 1 . FIX)) (2 LOGOR2 (FN 1 . FIX)) (2 \ADDBASE)) (1 (2 ITIMES2 (FN 1 . FIX] (MERGEFRAMEFLG T) (MERGEFRAMEMAX 2) (CLEANFNLIST '(NTYPX EQ AND OR CONS LIST FMEMB MEMB GETP SUB1 ADD1 ZEROP ELT ILESSP LLSH LRSH IPLUS IDIFFERENCE \ARG0 GETHASH \ADDBASE \GETBASEPTR \GETBASEBYTE \GETBASE \GETBASEFIXP \GETBASESTRING \VAG2 \ADDBASE)) (OPCODEPROP 'DOPVAL) (VCONDITIONALS '(ARRAYP FIXP FLOATP LISTP SMALLP STACKP NUMBERP)) (CONDITIONALS '(EQ IGREATERP NULL GREATERP LESSP ILESSP)) (CONSTFNS '(IPLUS SUB1 ADD1 ZEROP LLSH LRSH IDIFFERENCE)) (MAXARGS 80) (XVARFLG NIL) (NOFREEVARFNS '(RPLACA RPLACD PUTHASH SETA)) (CLEANFNTEST 'DASSEM.CLEANFNTEST) (EQCONSTFN 'DASSEM.EQCONSTANTP)) (ADDVARS (NUMBERFNS LLSH1 LRSH1 LLSH8 LRSH8)) (CONSTANTS (SHALLOWFLG NIL) (SPAGHETTIFLG T)) (FNS DASSEM.CLEANFNTEST) (OPTIMIZERS ATOM EVALV FRPLACA GETATOMVAL LIST LITATOM MINUSP IEQP FASSOC SETATOMVAL SYSTEMTYPE SPREADAPPLY*) (PROP DMACRO FGETD FGREATERP FLESSP FMEMB FRPLACD GETD GREATERP IGREATERP ILESSP LESSP LLSH LRSH PRINTNUM RPLACD \FLOATBOX \FLOATUNBOX) (FNS COMP.RPLACD COMP.SHIFT COMP.COMPARENUM COMP.GETD COMP.FMEMB) (PROP PROPTYPE DMACRO) (COMS (* ; "COMP.GETBASE") (OPTIMIZERS \GETBASEBYTE \PUTBASEBYTE \HILOC \LOLOC \VAG2) (PROP DMACRO \GETBASE \GETBASEPTR \PUTBASE \PUTBASEPTR \RPLPTR \GETBITS \PUTBITS) (FNS COMP.GETBASE COMP.GETBASEBITS)) (COMS (FNS COMP.SPREADFN) (OPTIMIZERS NCONC APPEND)) (COMS (* ; "CAPPLYFN") (PROP DMACRO NILAPPLY .PUSHNILS. SPREADAPPLY .SPREAD. .EVALFORM. .CALLAFTERPUSHINGNILS. APPLY*) (PROP DOPVAL .SPREADCONS. .SWAPNIL.) (FNS COMP.PUSHNILS COMP.SPREAD COMP.EVALFORM COMP.PUSHCALL COMP.APPLY*)) (COMS (* ; "for ARG and SETARG") (PROP DMACRO ARG SETARG NAMEDLET) (FNS COMP.ARG COMP.SETARG COMP.NAMEDLET)) (COMS (PROP DMACRO LOADTIMECONSTANT) (VARS LOADTIMECONSTANTMARKER)) (PROP FILETYPE DLAP) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DASM) (GLOBALVARS FVINDEXHARRAY) (MACROS PARENTP AST OPCOUNT) (MACROS CHECKRANGE) DONTEVAL@LOAD (FILES (LOADCOMP) BYTECOMPILER LLCODE)))) (* ;; " Assembler for the Byte Compiler. ") (DEFINEQ (C.FLOATBOX [LAMBDA (A) (* lmm "29-Dec-84 11:39") (SELECTQ COMPILE.CONTEXT (EFFECT (COMP.VALN A 'EFFECT)) (PROGN (COMP.VAL1 A) (COMP.FLOATBOX]) (C.FLOATUNBOX [LAMBDA (A) (* lmm "29-Dec-84 11:44") (SELECTQ COMPILE.CONTEXT (EFFECT (COMP.VALN A 'EFFECT)) (COMP.VAL1 A '(UNBOXED . FLOAT]) (DASSEM.DASSEM [LAMBDA (FN CC) (* ;  "Edited 17-Nov-92 00:58 by sybalsky:mv:envos") (PROG ((ARGTYPE (fetch (COMINFO COMTYPE) of CC)) (ARGS (fetch (COMINFO ARGS) of CC)) (CODE (fetch (COMINFO CODE) of CC)) NARGS NLOCALS FREEVARS NFREEVARS ORG CD (VARCOUNT 0) LOCALS (FRAMENAME FN)) (DECLARE (SPECVARS VARCOUNT FRAMES CD CODELOC)) (fetch (DASM CLEAR) of T) (COND ((AND (EQ ARGTYPE 2) ARGS) [push CODE (create OP OPNAME _ 'FN OPARG _ '(0 . \MYARGCOUNT)) (create OP OPNAME _ 'BIND OPARG _ (CONS NIL (SETQ ARGS (fetch (COMINFO TOPFRAME) of CC] (replace NVALS of ARGS with 1) (replace NNILS of ARGS with 0) (SETQ ARGS NIL) (SETQ NARGS 0)) (T (DASSEM.COUNTVARS ARGS) (SETQ NARGS VARCOUNT))) (PROGN (PROG ((LL CODE) X A D FREELST FRAMES) (DECLARE (SPECVARS FRAMES)) LP (COND ((NULL LL) (GO OUT))) [SETQ A (fetch OPARG of (SETQ X (CAR LL] PR (SELECTQ (fetch OPNAME of X) (CONST (COND ((EQ (fetch OPNAME of (SETQ D (CADR LL))) 'FN) (SELECTQ (CDR (fetch OPARG of D)) ((IDIFFERENCE IPLUS2) (COND ((AND (NOT OPTIMIZATIONSOFF) IPLUSNFLG (EQ (CAR (fetch OPARG of D)) 2) (IGEQ A 0) (ILEQ A 255)) (RPLACA LL (SELECTQ (CDR (fetch OPARG of D)) (IDIFFERENCE 'IDIFFERENCE.N) 'IPLUS.N)) (RPLACA (CDR LL) A) (SETQ LL (CDR LL)) (GO LP)))) (\CALLME (COND ((EQ (CAR (fetch OPARG of D)) 1) (SETQ FRAMENAME A) (RPLNODE2 LL (CDDR LL)) (GO LP)))) NIL))) (COND ((FASSOC A CONSTOPS) (* ; "HAS OPCODE") ) ((AND (FIXP A) (IGEQ A -256) (ILEQ A 65535)) [SETQ LL (PROG1 (CDR LL) [RPLACA LL (COND ((ILESSP A 0) (push (CDR LL) (IPLUS 256 A)) 'SNIC) ((IGREATERP A 255) (push (CDR LL) (LRSH A 8) (LOGAND A 255)) 'SICX) (T (push (CDR LL) A) 'SIC])] (GO LP)))) (BIND (PROG [(FRAME (CDR A)) (VARS (fetch (FRAME VARS) of (CDR A] (DECLARE (SPECVARS FRAME)) (* ;  "frame is used free below DASSEM.MATCHVARS") [COND ((NEQ FRAME TOPFRAME) (for VAR in VARS when (EQ (CAR VAR) 'HVAR) do (* ;  "eliminate name of LOCALVAR variable") (RPLACD VAR NIL] (COND [(NULL LOCALS) (* ;  "no local variables seen yet. Assign var numbers sequentially") (DASSEM.COUNTVARS (SETQ LOCALS (APPEND VARS] (T (* ;  "try to share binding pointers with some previously seen local variables") (DASSEM.MATCHVARS VARS LOCALS))) (* ;  "remember this frame as having been seen") (push FRAMES (CDR A)))) (GVAR [SETQ LL (PROG1 (CDR LL) [RPLNODE LL (COND ((EQ X (CAR LL)) 'GVAR) (T 'GVAR_)) (COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (CONS 0 (CONS 0 (CONS 0 (CONS (CONS 'ATOM A) (CDR LL] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (CONS 0 (CONS 0 (CONS (CONS 'ATOM A) (CDR LL] (T (CONS 0 (CONS (CONS 'ATOM A) (CDR LL])] (GO LP)) (FVAR [COND [(SETQ D (FASSOC A FREELST)) (* ; "count how often each var occurs") (FRPLACD (CDR D) (ADD1 (CDDR D] (T (SETQ FREELST (CONS (CONS A (CONS (CAR X) 0)) FREELST]) (SETQ [SETQ A (fetch OPARG of (SETQ X (fetch OPARG of X] (GO PR)) NIL) (SETQ LL (CDR LL)) (GO LP) OUT (SETQ A 0) [MAPC [SORT FREELST (FUNCTION (LAMBDA (X Y) (IGREATERP (CDDR X) (CDDR Y] (FUNCTION (LAMBDA (X) (replace FREEVARINDEX of (CAR X) with A) (ADD1VAR A] (* ;  "Assign numbers to the free variables (most frequent first)") [MAPC FREELST (FUNCTION (LAMBDA (X) (FRPLACD X (PROG1 (CAR X) (FRPLACA X (CADR X)))] (SETQ FREEVARS FREELST))) (* ;; "SCAN CODE") (SETQ NLOCALS (IDIFFERENCE VARCOUNT NARGS)) (CHECKRANGE NARGS NARGMAX 'ARGS) (CHECKRANGE NLOCALS NLOCALMAX 'LOCALS) (SETQ NFREEVARS (LENGTH FREEVARS)) (CHECKRANGE NFREEVARS NFREEMAX 'FREEVARS) (PROGN (* ; "TURN INTO REAL CODE") (PROG ((CODELOC 0) (LL CODE) OP X D A JL N) LP (COND ((NULL LL) (SETQ CD (OPT.DREV CD)) (OPT.RESOLVEJUMPS (OPT.DREV JL) 'AJSIZES (FUNCTION DASSEM.ASMAJ)) (RETURN))) (SETQ X (CAR LL)) (COND ((NLISTP X) (AST X) (GO NEXT))) (SETQ A (fetch OPARG of X)) (* ;; "Dispatch on the main opcode type:") (SELECTQ (SETQ OP (fetch OPNAME of X)) ((AVAR HVAR) (* ; "Variable references") [SETQ OP (COND ((ILESSP (SETQ A (fetch VARINDEX of X)) NARGS) '(IVAR . IVARX)) (T (SETQ A (IDIFFERENCE A NARGS)) '(PVAR . PVARX] [COND ((ILESSP A (OPCOUNT (CAR OP))) (AST (LIST (CAR OP) A))) (T (AST (CDR OP)) (AST (LLSH A 1]) (FN (* ;  "Function calls (includes many primitives like IPLUS2)") [COND ((LISTP (SETQ D (CDR A))) (OR (EQ (CAR D) 'OPCODES) (OPT.COMPILERERROR)) (for X in (CDR D) do (AST X))) [(SETQ D (GETP D 'DOPVAL)) (* ; "A fn has DOPVAL") (PROG ((N (CAR A)) (F (CDR A))) OPLP (COND ((NLISTP D)) [(OR (EQ [CAR (SETQ A (COND ((FIXP (CAR D)) (PROG1 D (SETQ D))) (T (CAR D] N) (NULL (CAR A))) (* ;;  "Arg count matches the DOPVAL's needs, so emit it:") (COND ((LISTP (SETQ D (CDR A))) (RETURN (MAPC D (FUNCTION (LAMBDA (X) (AST X] ((ILESSP N (CAR A)) (* ;  "A fn with DOPVAL supplied too few args") (SETQ LL (CONS (create OP OPNAME _ 'FN OPARG _ (CONS (CAR A) F)) (CDR LL))) (* ;  "put out NIL's and change # args.") (FRPTQ (IDIFFERENCE (CAR A) N) (SETQ LL (CONS OPNIL LL))) (GO LP)) ((NULL (CDR D)) (* ;  "A fn with DOPVAL supplied too many args") (SETQ LL (CONS (create OP OPNAME _ 'FN OPARG _ (CONS (CAR A) F)) (CDR LL))) (FRPTQ (IDIFFERENCE N (CAR A)) (SETQ LL (CONS OPPOP LL))) (GO LP)) (T (SETQ D (CDR D)) (GO OPLP))) APPLY (SETQ LL (APPLY* D (fetch OPARG of X) LL] (T (* ;;  "Function is neither an opcode nor a DOPVAL, so emit the function call:") (SELECTQ (CAR A) (0 (AST 'FN0) (DASSEM.DSTOREFN (CDR A))) (1 (AST 'FN1) (DASSEM.DSTOREFN (CDR A))) (2 (AST 'FN2) (DASSEM.DSTOREFN (CDR A))) (3 (AST 'FN3) (DASSEM.DSTOREFN (CDR A))) (4 (AST 'FN4) (DASSEM.DSTOREFN (CDR A))) (PROGN (AST 'FNX) (AST (CAR A)) (DASSEM.DSTOREFN (CDR A]) ((JUMP FJUMP TJUMP NTJUMP NFJUMP) (push JL (create JD JPT _ (push CD X) JMIN _ CODELOC)) [add CODELOC (CAAR (GETP OP 'AJSIZES]) (TAG (replace (TAG JD) of X with (SETQ D (create JD JMIN _ CODELOC))) (SETQ JL (CONS D JL))) (CONST [COND ((SETQ D (FASSOC A CONSTOPS)) (AST (CDR D))) ((LITATOM A) (AST 'ACONST) (AST 0) (COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0) (AST 0)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0))) (AST (CONS 'ATOM A))) (T (AST 'GCONST) (AST 0) (COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0) (AST 0)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0))) (AST (CONS 'PTR A]) (SETQ (SELECTQ (fetch OPNAME of A) ((AVAR HVAR) [COND ((ILESSP (SETQ D (fetch VARINDEX of A)) NARGS) (AST 'IVARX_) (AST (LLSH D 1))) (T (SETQ D (IDIFFERENCE D NARGS)) (COND ([AND (EQ (fetch OPNAME of (CADR LL)) 'POP) (ILESSP D (OPCOUNT 'PVAR_^] (SETQ LL (CDR LL)) (AST (LIST 'PVAR_^ D))) ((ILESSP D (OPCOUNT 'PVAR_)) (AST (LIST 'PVAR_ D))) (T (AST 'PVARX_) (AST (LLSH D 1]) (FVAR (AST 'FVARX_) (AST (LLSH (IPLUS NLOCALS (fetch FREEVARINDEX of (fetch OPARG of A))) 1))) (OPT.COMPILERERROR))) (FVAR [COND ((ILESSP (SETQ A (IPLUS NLOCALS (fetch FREEVARINDEX of A))) (OPCOUNT 'FVAR)) (AST (LIST 'FVAR A))) (T (AST 'FVARX) (AST (LLSH A 1]) (BIND (SETQ A (CDR A)) (DASSEM.DASMBIND (fetch NVALS of A) (fetch NNILS of A) (COND ((SETQ D (fetch VARS of A)) (IDIFFERENCE (fetch VARINDEX of (CAR D)) NARGS)) (T 1)))) ((UNBIND DUNBIND) (SETQ A (CDR A)) (COND ((IGREATERP (fetch NVALS of A) 15) (OPT.COMPILERERROR))) (* ;  "if did extra BINDs because of #NILs bound, do extra UNBINDs") (FRPTQ (ADD1 (LRSH (fetch NNILS of A) 4)) (AST OP))) (ATOM (AST X)) (STORE (AST 'STORE.N) (OR (GREATERP A 0) (SHOULDNT)) (AST (LLSH (SUB1 A) 1))) (*STORE [MAPC A (FUNCTION (LAMBDA (X) (AST X]) (COPY (COND (A (if (EQ A 0) then (HELP)) (AST 'COPY.N) (AST (LLSH A 1))) (T (AST OP)))) (AST OP)) NEXT (SETQ LL (CDR LL)) (GO LP))) (DASSEM.DWRITEFN FN FRAMENAME ARGTYPE ARGS LOCALS FREEVARS CD]) (DASSEM.DWRITEFN [LAMBDA (FN FRAMENAME ARGTYPE ARGS LOCALS FREEVARS CD) (* bvm%: " 2-Oct-86 22:01") (PROG ((NARGS (LENGTH ARGS)) (NLOCALS (LENGTH LOCALS)) (NFREEVARS (LENGTH FREEVARS)) [LC (FLENGTH (NCONC1 CD '-X-] NAMETABLE LOCALVARINFO) (* ; "had set radix to 8, but not sure why that matters. Nowadays want to write in current reader environment anyway") [PROGN (* ;; "Construct the name table. Is a flattened list of entries , where code is one of P, I, F. First come PVAR's, in reverse order of binding, then IVAR's, then FVAR's. Thus free variable lookup can search the table in order. We build NAMETABLE backwards, consing onto front") [COND (FREEVARS (for X in FREEVARS as I from NLOCALS do (push NAMETABLE (CDR X) I 'F)) (* ;  "Fine, but backwards: the FVARS need to be in order, while the PVARS want to be in reverse order") (SETQ NAMETABLE (DREVERSE NAMETABLE] [for X in ARGS as I from 0 do (COND ((NEQ (CAR X) 'HVAR) (push NAMETABLE 'I I (CDR X))) (T (* ;  "Need to save localvar args for ARGLIST") (push LOCALVARINFO I (CDR X] [for X in LOCALS as I from 0 do (COND ((NEQ (CAR X) 'HVAR) (push NAMETABLE 'P I (CDR X))) ((AND (EQ ARGTYPE 2) (EQ I 0)) (push LOCALVARINFO I (CDR X] (COND ((AND LOCALVARINFO (DASSEM.SAVELOCALVARS FN)) (* ;  "Keep this separate, so for now DCODERD can easily discard it") (push NAMETABLE 'L LOCALVARINFO] (COND ((NEQ FRAMENAME FN) (push NAMETABLE 'NAME FRAMENAME))) (SELECTQ LAPFLG ((2 T) (DASSEM.DPRINTLAP FN NAMETABLE ARGTYPE CD)) NIL) [COND (LCFIL (LET [(OUTSTREAM (GETSTREAM LCFIL 'OUTPUT] (* ;; "First dump function name and codeindicator to say that what follows is compiled code. This is in FILERDTBL in the old days, or the current environment nowadays") (PRIN4 FN OUTSTREAM) (PRIN3 " " OUTSTREAM) (PRIN4 CODEINDICATOR OUTSTREAM) (TERPRI OUTSTREAM) (LET ((*READTABLE* (if (EQ *READTABLE* FILERDTBL) then (* ;  "old style file, print code with different read table!") CODERDTBL else (* ; "print code in same readtable") *READTABLE*)) FNFIX ATOMFIX PTRFIX) (* ;; "Now comes the code in several parts. Read table is now CODERDTBL old style, or current environment nowadays.") (PRIN4 NAMETABLE OUTSTREAM) (PRIN3 " " OUTSTREAM) (\BOUT OUTSTREAM (LRSH LC 8)) (\BOUT OUTSTREAM (LOGAND LC 255)) (\BOUT OUTSTREAM NLOCALS) (\BOUT OUTSTREAM NFREEVARS) (\BOUT OUTSTREAM ARGTYPE) (\BOUT OUTSTREAM NARGS) (* ;; "Now the actual code") [for X in CD as LOC from 0 do (\BOUT OUTSTREAM (COND [(NLISTP X) (COND ((AND (FIXP X) (IGEQ X 0) (ILEQ X 255)) X) (T (fetch OP# of (\FINDOP X T] (T (* ;  "something to be fixed up at load time") (SELECTQ (CAR X) (FN (push FNFIX LOC (CDR X)) 0) (ATOM (push ATOMFIX LOC (CDR X)) 0) (PTR (push PTRFIX LOC (CDR X)) 0) (IPLUS (CAR (fetch OP# of (\FINDOP (CAR X) T))) (CADR X] (* ;; "Now print 3 lists of code fixups.") (PRIN4 FNFIX OUTSTREAM) (TERPRI OUTSTREAM) (PRIN4 ATOMFIX OUTSTREAM) (TERPRI OUTSTREAM) (PRIN3 "(" OUTSTREAM) [for X in PTRFIX do (SPACES 1 OUTSTREAM) (COND ((EQ (CAR X) LOADTIMECONSTANTMARKER) (if (fetch (READTABLEP COMMONLISP) of *READTABLE*) then (PRIN3 "#." OUTSTREAM) else (BOUT OUTSTREAM (CHARCODE ^Y))) (PRIN4 (CDR X) OUTSTREAM)) (T (PRIN4 X OUTSTREAM] (PRIN3 ")" OUTSTREAM) (TERPRI OUTSTREAM] (COND (STRF (DASSEM.DSTOREFNDEF FN CD LC ARGTYPE NARGS NLOCALS NFREEVARS NAMETABLE))) (RETURN FN]) (DASSEM.SAVELOCALVARS [LAMBDA (FN) T]) (DASSEM.DSTOREFNDEF [LAMBDA (FN CD LC ARGTYPE NARGS NLOCALS NFREEVARS NAMETABLE) (* ; "Edited 6-Feb-91 17:26 by jds") (* ;; "Really store the definition of a [byte-compiled] function into a code block. Builds the name table, and fills in local-function, symbol, and constant corrections as well.") (* ;; "DO NOT RUN THIS CODE INTERPRETED. It depends for its proper operation on being compiled with XCLC::*TARGET-ARCHITECTURE* set correctly w.r.t. :3-BYTE atoms.") (* ;; "Much of this code is duplicated in DCODERD (in file LLCODE). Any changes to the codeblock format or this function's behavior should be mirrored there.") (PROG ((NTSIZE 0) (FRAMENAME FN) REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE) [COND ((EQ (CAR NAMETABLE) 'NAME) (SETQ FRAMENAME (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE] [COND ((EQ (CAR NAMETABLE) 'L) (SETQ LOCALARGS (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE] [COND (NAMETABLE (* ;  "NAMETABLE now is a sequence of flat triples, one per name to be stored in nametable") (on NAMETABLE by CDDDR do (add NTSIZE 1)) (SETQ NTSIZE (CEIL (UNFOLD (ADD1 NTSIZE) (CONSTANT (WORDSPERNAMEENTRY))) WORDSPERQUAD] [SETQ NTWORDS (COND (NAMETABLE (IPLUS NTSIZE NTSIZE)) (T (CONSTANT WORDSPERQUAD] (* ;; "NameTable must end in quadword which ends in 0 --- thus, round down and add a quad --- NTWORDS is the number of words allocated for nametable") (SETQ STARTPC (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T) NTWORDS) BYTESPERWORD)) (* ;  "initial pc for the function: after fixed header and double nametable") [COND (LOCALARGS (SETQ STARTLOCALS STARTPC) (* ;  "Insert an extra nametable between the real one and the start pc where we store localvar args") (SETQ LOCALSIZE (CEIL [ADD1 (UNFOLD (FOLDLO (FLENGTH LOCALARGS) 2) (CONSTANT (WORDSPERNAMEENTRY] (IQUOTIENT WORDSPERQUAD 2))) (* ;  "Number of words in half this nametable: must end in zero, when doubled is quad-aligned") (SETQ LOCALSIZE (UNFOLD LOCALSIZE BYTESPERWORD)) (* ; "size in bytes now") (add STARTPC (UNFOLD LOCALSIZE 2] (SETQ REALSIZE (CEIL (IPLUS STARTPC LC) BYTESPERQUAD)) (SETQ CA (\CODEARRAY REALSIZE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL)) CELLSPERQUAD))) [for X in CD as LOC from STARTPC do (COND [(NLISTP X) (CODESETA CA LOC (COND ((AND (FIXP X) (IGEQ X 0) (ILEQ X 255)) X) (T (* ;  "assume that this is an opcode which isn't a 'range'") (fetch OP# of (\FINDOP X T] (T (SELECTQ (CAR X) (FN (\FIXCODESYM CA LOC (\ATOMDEFINDEX (CDR X)))) (ATOM (\FIXCODESYM CA LOC (\ATOMPNAMEINDEX (CDR X)))) (PTR [\FIXCODEPTR CA LOC (COND ((EQ (CADR X) LOADTIMECONSTANTMARKER) (EVAL (CDDR X))) (T (CDR X]) (PROGN (* ;  "assume that this is a 'range' type opcode") (CODESETA CA LOC (IPLUS (CAR (fetch OP# of (\FINDOP (CAR X) T))) (CADR X] (* ;; "Now build the name table, which has two parallel parts: the names, and where to find them on the stack") (for X on NAMETABLE by (CDDDR X) as NT1 from (IPLUS (SUB1 (BYTESPERNAMEENTRY)) (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T) BYTESPERWORD)) by (BYTESPERNAMEENTRY) bind (NTBYTESIZE _ (UNFOLD NTSIZE BYTESPERWORD)) do (\FIXCODESYM CA NT1 (CADDR X) -1) (* ;  "Insert the name into first half of table") (SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE) (SELECTQ (CAR X) (P (CONSTANT PVARCODE)) (F [OR FVAROFFSET (SETQ FVAROFFSET (UNFOLD (FOLDLO NT1 (CONSTANT ( BYTESPERNAMEENTRY ))) (CONSTANT (WORDSPERNAMEENTRY] (* ;  "Save word offset of first FVAR in nametable, so ucode can easily access FVAR n") (CONSTANT FVARCODE)) (I (CONSTANT IVARCODE)) (SHOULDNT)) (CADR X)) (* ;  "Code type and index into second half") ) [COND (LOCALARGS (* ;  "Build invisible name table for locals") (for X on LOCALARGS by (CDDR X) as NT from (IPLUS (SUB1 (BYTESPERNAMEENTRY)) STARTLOCALS) by (CONSTANT (BYTESPERNAMEENTRY)) do (\FIXCODESYM CA NT (\ATOMVALINDEX (CADR X)) -1) (* ; "Name in first half") (SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE) (CONSTANT IVARCODE) (CAR X)) (* ; "index in second half")] (PROGN (* ; "Fill in function header") (replace (CODEARRAY NA) of CA with (COND ((EQ ARGTYPE 2) -1) (T NARGS))) (replace (CODEARRAY PV) of CA with (SUB1 (FOLDHI (IPLUS NLOCALS NFREEVARS) CELLSPERQUAD))) (replace (CODEARRAY STARTPC) of CA with STARTPC) (replace (CODEARRAY ARGTYPE) of CA with ARGTYPE) (replace (CODEARRAY FRAMENAME) of CA with FRAMENAME) (replace (CODEARRAY NTSIZE) of CA with NTSIZE) (replace (CODEARRAY NLOCALS) of CA with NLOCALS) (replace (CODEARRAY FVAROFFSET) of CA with (OR FVAROFFSET 0)) (replace (CODEARRAY FIXED) of CA with T)) (RESETVARS [(DFNFLG (COND (SVFLG NIL) (T T] (DPUTCODE FN CA (IPLUS STARTPC LC]) (DASSEM.DPRINTLAP [LAMBDA (FN NAMETABLE ARGTYPE CD) (* bvm%: " 2-Oct-86 21:57") (LET ((OUTSTREAM (GETSTREAM LSTFIL 'OUTPUT)) (*PRINT-BASE* 8)) (printout OUTSTREAM |.P2| FN T "name table: " T |.P2| NAMETABLE T "code length: " " argtype: " ARGTYPE T) (MAPRINT CD OUTSTREAM NIL NIL NIL (FUNCTION PRIN2)) (printout OUTSTREAM T T]) (DASSEM.EQCONSTANTP [LAMBDA (ARG FLG) (* lmm "26-DEC-81 15:52") (OR (LITATOM ARG) (AND (FIXP ARG) (IGEQ ARG -65536) (ILEQ ARG 65535]) (DASSEM.MATCHVARS [LAMBDA (VARS TAIL) (* lmm "29-JUL-81 07:03") (* ;; "find a match for VARS in TAIL (a tail of LOCALS) --- tack VARS onto end if not possible") (COND [(AND (for VAR in VARS as X in TAIL always (EQUAL VAR X)) (for VAR in VARS as X in TAIL always (DASSEM.CANSHAREBINDING VAR X))) (* ;  "variables in VARS can share binding pointers with variables in TAIL") (PROG NIL LP (replace VARINDEX of (CAR VARS) with (fetch VARINDEX of (CAR TAIL))) (COND ((SETQ VARS (CDR VARS)) (COND ((CDR TAIL) (SETQ TAIL (CDR TAIL)) (GO LP)) (T (* ;  "some variables left; tack onto end") (DASSEM.COUNTVARS VARS) (RPLACD TAIL VARS] ((CDR TAIL) (DASSEM.MATCHVARS VARS (CDR TAIL))) (T (DASSEM.COUNTVARS VARS) (RPLACD TAIL VARS]) (DASSEM.COUNTVARS [LAMBDA (VARS) (* lmm "26-JAN-80 21:23") (* ;; "assign sequential variable numbers to VARS") (for VAR in VARS do (replace VARINDEX of VAR with (PROG1 VARCOUNT (ADD1VAR VARCOUNT]) (DASSEM.CANSHAREBINDING [LAMBDA (V1 V2) (* lmm "22-DEC-81 22:58") (* ;; "can the two variables V1 and V2 share binding pointers? --- yes, if they are both either (HVAR) or else both (AVAR . atom) with same atom name, and V2's frame (and the frame of any variable which shares a binding pointer with V2) is mutually exclusive from V1's frame (i.e., both binds cannot happen at the same time)") (AND (EQUAL V1 V2) (for FR in FRAMES when (AND (find V3 in (fetch (FRAME VARS) of FR) suchthat (EQ (fetch VARINDEX of V3) (fetch VARINDEX of V2))) (OR (PARENTP FR FRAME) (PARENTP FRAME FR))) do (* ; "KILROY wuz here") (RETURN NIL) finally (RETURN T]) ) (DECLARE%: EVAL@COMPILE (RPAQQ NARGMAX 127) (RPAQQ NLOCALMAX 127) (RPAQQ NFREEMAX 127) (CONSTANTS NARGMAX NLOCALMAX NFREEMAX) ) (DEFINEQ (DASSEM.DASMBIND [LAMBDA (NV NN K) (* lmm "13-Jul-84 21:18") (COND [(IGREATERP NV 15) (COMPERROR (CONS NV '(- too many values bound] ((IGREATERP NN 15) (* ; "BIND of more than 15 NIL s") (DASSEM.DASMBIND NV 15 K) (DASSEM.DASMBIND 0 (IDIFFERENCE NN 15) (IPLUS K NV 15))) (T (* ; "BIND opcode") (AST 'BIND) (AST (IPLUS (LLSH NN 4) NV)) (AST (SUB1 (IPLUS K NV NN]) (DASSEM.DSTOREFN [LAMBDA (X) (* ;  "Edited 17-Nov-92 00:59 by sybalsky:mv:envos") (* ;; "Write out the extra bytes that go with a function call: The 2 (or on sun 3) bytes of symbol of the function to be called.") (AST 0) (* ;; "For suns, it's a 4-byte add-on.") (COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0) (AST 0)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE *BC-MACRO-ENVIRONMENT*)) (AST 0))) (AST (CONS 'FN X]) (DASSEM.ASMAJ [LAMBDA (P D) (* lmm " 8-Nov-84 18:46") (PROG ((OP (CAAR P)) Y S) (SETQ Y (GETP OP 'MOPVAL)) (SELECTQ (SETQ S (OPT.JSIZE (CAR P) D 'AJSIZES)) (1 (* ;  "1 byte jump --- JUMP FJUMP TJUMP") [FRPLACA P (if (ILESSP D 2) then (OR (AND (EQ D 1) (SELECTQ (CAAR P) (JUMP 'NOP) ((TJUMP FJUMP) 'POP) NIL)) (COMPILER.ERROR)) else (LIST (CAR Y) (IPLUS D -2]) (2 (* ;  "2 byte jump -- JUMPX TJUMPX FJUMPX NTJUMPX NFJUMPX") (FRPLNODE P (CADR Y) (CONS (COND ((ILESSP D 0) (COND ((ILESSP D -128) (OPT.COMPILERERROR))) (IPLUS 256 D)) (T (COND ((IGREATERP D 127) (OPT.COMPILERERROR))) D)) (CDR P)))) ((3 4) (* ;  "3 byte jump is JUMPXX. 4 byte jump is FJUMP.+4 JUMPXX to implement TJUMPXX") [COND ((EQ S 3) (OR (EQ (CADDR Y) 'JUMPXX) (OPT.COMPILERERROR)) (FRPLACA P (CADDR Y))) (T (* ;  "long t/f jump implemented by short jump followed by JUMPXX") (add D -1) (FRPLNODE P (CADDR Y) (SETQ P (CONS 'JUMPXX (CDR P] [FRPLACD P (CONS (LOGAND (RSH D 8) 255) (CONS (LOGAND D 255) (CDR P]) (6 (* ;  "long NXJUMP implemented by NXJUMP.+2 JUMP.+4 JUMPXX.place IN 6 BYTES") [FRPLNODE P (CADR Y) (CONS 3 (CONS '(JUMP 2) (CONS 'JUMPXX (CONS (LRSH (SETQ D (LOGAND (IPLUS D -3) 65535)) 8) (CONS (LOGAND D 255) (CDR P]) (OPT.COMPILERERROR]) ) (RPAQQ EMFLAG NIL) (RPAQQ COMPILEMODE D) (PUTPROPS JUMP MOPVAL (JUMP JUMPX JUMPXX)) (PUTPROPS FJUMP MOPVAL (FJUMP FJUMPX (TJUMP 2))) (PUTPROPS TJUMP MOPVAL (TJUMP TJUMPX (FJUMP 2))) (PUTPROPS NTJUMP MOPVAL (NIL NTJUMPX)) (PUTPROPS NFJUMP MOPVAL (NIL NFJUMPX)) (PUTPROPS JUMP AJSIZES ((1 . 3) 18 (1 (-127 3 . 2) . 1) 127 2 . 3)) (PUTPROPS FJUMP AJSIZES ((1 . 4) 18 (1 (-127 4 . 2) . 1) 127 2 . 4)) (PUTPROPS TJUMP AJSIZES ((1 . 4) 18 (1 (-127 4 . 2) . 1) 127 2 . 4)) (PUTPROPS NTJUMP AJSIZES ((2 . 6) 18 (2 (-127 6 . 2) . 2) 127 2 . 6)) (PUTPROPS NFJUMP AJSIZES ((2 . 6) 18 (2 (-127 6 . 2) . 2) 127 2 . 6)) (RPAQQ DOPVALS (.APPLYFN. ARRAYP ASSOC BIN CAR CDR CONS CREATECELL DIFFERENCE EQ EQL EQUAL FDIFFERENCE FGREATERP FIX FIXP FLESSP FLOAT FLOATP FMEMB FPLUS FQUOTIENT FTIMES GREATERP IDIFFERENCE IGREATERP ILESSP IPLUS IQUOTIENT IREMAINDER ITIMES LESSP LISTGET LISTP LLSH1 LLSH8 LOGAND LOGOR LOGXOR LRSH1 LRSH8 LSH NTYPX NULL NUMBERP PLUS QUOTIENT READPRINTERPORT RPLACA RPLACD SMALLP STACKP TIMES WRITEPRINTERPORT \ADDBASE \ARG0 \BIN \BLKEXPONENT \BLKFDIFF \BLKFLOATP2COMP \BLKFPLUS \BLKFTIMES \BLKMAG \BLKPERM \BLKSEP \BLKSMALLP2FLOAT \BLT \BOXIDIFFERENCE \BOXIPLUS \CONTEXTSWITCH \DRAWLINE.UFN \EVAL \FLOAT.BOX \FLOATBOX \FLOATUNBOX \GCRECLAIMCELL \GCSCAN1 \GCSCAN2 \IBLT1 \IBLT2 \MAKENUMBER \MTIMES3 \MTIMES4 \MYALINK \MYARGCOUNT \PILOTBITBLT \PIXELBLT \RCLK \READFLAGS \READRP \RPLCONS \STKSCAN \WRITEMAP \\ADDBASE)) (PUTPROPS .APPLYFN. DOPVAL ((NIL APPLYFN))) (PUTPROPS ARRAYP DOPVAL (1 TYPEP 6)) (PUTPROPS ASSOC DOPVAL (2 ASSOC)) (PUTPROPS BIN DOPVAL (1 BIN)) (PUTPROPS CAR DOPVAL (1 CAR)) (PUTPROPS CDR DOPVAL (1 CDR)) (PUTPROPS CONS DOPVAL (2 CONS)) (PUTPROPS CREATECELL DOPVAL (1 CREATECELL)) (PUTPROPS DIFFERENCE DOPVAL (2 DIFFERENCE)) (PUTPROPS EQ DOPVAL (2 EQ)) (PUTPROPS EQL DOPVAL (2 EQL)) (PUTPROPS EQUAL DOPVAL (2 EQUAL)) (PUTPROPS FDIFFERENCE DOPVAL (2 FDIFFERENCE)) (PUTPROPS FGREATERP DOPVAL (2 FGREATERP)) (PUTPROPS FIX DOPVAL (1 %'0 IPLUS2)) (PUTPROPS FIXP DOPVAL (1 TYPEMASK.N 32)) (PUTPROPS FLESSP DOPVAL (2 SWAP FGREATERP)) (PUTPROPS FLOAT DOPVAL ((1 DTEST 0 0 0 (ATOM . FLOATP)))) (PUTPROPS FLOATP DOPVAL (1 TYPEP 3)) (PUTPROPS FMEMB DOPVAL (2 FMEMB)) (PUTPROPS FPLUS DOPVAL ((2 FPLUS2))) (PUTPROPS FQUOTIENT DOPVAL (2 FQUOTIENT)) (PUTPROPS FTIMES DOPVAL ((2 FTIMES2))) (PUTPROPS GREATERP DOPVAL (2 GREATERP)) (PUTPROPS IDIFFERENCE DOPVAL (2 IDIFFERENCE)) (PUTPROPS IGREATERP DOPVAL (2 IGREATERP)) (PUTPROPS ILESSP DOPVAL (2 SWAP IGREATERP)) (PUTPROPS IPLUS DOPVAL ((0 . OPT.COMPILERERROR) (1 %'0 IPLUS2) (2 IPLUS2) . OPT.COMPILERERROR)) (PUTPROPS IQUOTIENT DOPVAL (2 IQUOTIENT)) (PUTPROPS IREMAINDER DOPVAL (2 IREMAINDER)) (PUTPROPS ITIMES DOPVAL ((0 . OPT.COMPILERERROR) (1 0 IPLUS2) (2 ITIMES2) . OPT.COMPILERERROR)) (PUTPROPS LESSP DOPVAL (2 SWAP GREATERP)) (PUTPROPS LISTGET DOPVAL (2 LISTGET)) (PUTPROPS LISTP DOPVAL (1 LISTP)) (PUTPROPS LLSH1 DOPVAL (1 LLSH1)) (PUTPROPS LLSH8 DOPVAL (1 LLSH8)) (PUTPROPS LOGAND DOPVAL ((2 LOGAND2))) (PUTPROPS LOGOR DOPVAL ((2 LOGOR2))) (PUTPROPS LOGXOR DOPVAL ((2 LOGXOR2))) (PUTPROPS LRSH1 DOPVAL (1 LRSH1)) (PUTPROPS LRSH8 DOPVAL (1 LRSH8)) (PUTPROPS LSH DOPVAL (2 LSH)) (PUTPROPS NTYPX DOPVAL (1 NTYPX)) (PUTPROPS NULL DOPVAL (1 %'NIL EQ)) (PUTPROPS NUMBERP DOPVAL (1 TYPEMASK.N 16)) (PUTPROPS PLUS DOPVAL ((1 %'0 PLUS2) (2 PLUS2) . OPT.COMPILERERROR)) (PUTPROPS QUOTIENT DOPVAL (2 QUOTIENT)) (PUTPROPS READPRINTERPORT DOPVAL (0 READPRINTERPORT)) (PUTPROPS RPLACA DOPVAL (2 RPLACA)) (PUTPROPS RPLACD DOPVAL (2 RPLACD)) (PUTPROPS SMALLP DOPVAL (1 TYPEP 1)) (PUTPROPS STACKP DOPVAL (1 TYPEP 8)) (PUTPROPS TIMES DOPVAL ((2 TIMES2))) (PUTPROPS WRITEPRINTERPORT DOPVAL (1 WRITEPRINTERPORT)) (PUTPROPS \ADDBASE DOPVAL (2 ADDBASE)) (PUTPROPS \ARG0 DOPVAL (1 ARG0)) (PUTPROPS \BIN DOPVAL (1 BIN)) (PUTPROPS \BLKEXPONENT DOPVAL (3 MISC3 0)) (PUTPROPS \BLKFDIFF DOPVAL (4 MISC4 3)) (PUTPROPS \BLKFLOATP2COMP DOPVAL (3 MISC3 3)) (PUTPROPS \BLKFPLUS DOPVAL (4 MISC4 2)) (PUTPROPS \BLKFTIMES DOPVAL (4 MISC4 0)) (PUTPROPS \BLKMAG DOPVAL (3 MISC3 1)) (PUTPROPS \BLKPERM DOPVAL (4 MISC4 1)) (PUTPROPS \BLKSEP DOPVAL (4 MISC4 4)) (PUTPROPS \BLKSMALLP2FLOAT DOPVAL (3 MISC3 2)) (PUTPROPS \BLT DOPVAL (3 BLT)) (PUTPROPS \BOXIDIFFERENCE DOPVAL (2 BOXIDIFFERENCE)) (PUTPROPS \BOXIPLUS DOPVAL (2 BOXIPLUS)) (PUTPROPS \CONTEXTSWITCH DOPVAL (1 CONTEXTSWITCH)) (PUTPROPS \DRAWLINE.UFN DOPVAL (9 DRAWLINE)) (PUTPROPS \EVAL DOPVAL (1 EVAL)) (PUTPROPS \FLOAT.BOX DOPVAL (1 GCONST 0 0 0 (PTR . 0.0) FPLUS2)) (PUTPROPS \FLOATBOX DOPVAL (1 UBFLOAT1 0)) (PUTPROPS \FLOATUNBOX DOPVAL (1 UBFLOAT1 1)) (PUTPROPS \GCRECLAIMCELL DOPVAL (1 RECLAIMCELL)) (PUTPROPS \GCSCAN1 DOPVAL (1 GCSCAN1)) (PUTPROPS \GCSCAN2 DOPVAL (1 GCSCAN2)) (PUTPROPS \IBLT1 DOPVAL (8 MISC8 0)) (PUTPROPS \IBLT2 DOPVAL (8 MISC8 1)) (PUTPROPS \MAKENUMBER DOPVAL (2 MAKENUMBER)) (PUTPROPS \MTIMES3 DOPVAL (3 UBFLOAT3 1)) (PUTPROPS \MTIMES4 DOPVAL (3 UBFLOAT3 2)) (PUTPROPS \MYALINK DOPVAL (1 MYALINK)) (PUTPROPS \MYARGCOUNT DOPVAL (0 MYARGCOUNT)) (PUTPROPS \PILOTBITBLT DOPVAL (2 PILOTBITBLT)) (PUTPROPS \PIXELBLT DOPVAL (10 MISC10 0)) (PUTPROPS \RCLK DOPVAL (1 RCLK)) (PUTPROPS \READFLAGS DOPVAL (1 READFLAGS)) (PUTPROPS \READRP DOPVAL (1 READRP)) (PUTPROPS \RPLCONS DOPVAL (2 RPLCONS)) (PUTPROPS \STKSCAN DOPVAL (1 STKSCAN)) (PUTPROPS \WRITEMAP DOPVAL (3 WRITEMAP)) (PUTPROPS \\ADDBASE DOPVAL (2 ADDBASE)) (RPAQQ CONSTOPS ((NIL . %'NIL) (T . %'T) (0 . %'0) (1 . %'1))) (RPAQQ COMPILE.ARG.FAST.FLG NIL) (RPAQQ IPLUSNFLG NIL) (ADDTOVAR 8BITEXTS DCOM) (ADDTOVAR MACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO) (ADDTOVAR COMPILERMACROPROPS DMACRO ALTOMACRO BYTEMACRO MACRO) (RPAQQ BYTEASSEMFN DASSEM.DASSEM) (RPAQQ MAXBVALS 15) (RPAQQ BYTECOMPFLG T) (RPAQQ SELECTQFMEMB NIL) (RPAQQ LAMBDANOBIND T) (RPAQQ SELECTVARTYPES (AVAR HVAR)) (RPAQQ CONST.FNS [(NIL (1 CAR (CONST)) (1 CDR (CONST)) (1 NULL (CONST . T)) (2 EQ (FN 1 . NULL))) (0 (2 ITIMES2 (POP) (CONST . 0)) (2 LOGAND2 (POP) (CONST . 0)) (2 IPLUS (FN 1 . FIX)) (2 LOGOR2 (FN 1 . FIX)) (2 \ADDBASE)) (1 (2 ITIMES2 (FN 1 . FIX]) (RPAQQ MERGEFRAMEFLG T) (RPAQQ MERGEFRAMEMAX 2) (RPAQQ CLEANFNLIST (NTYPX EQ AND OR CONS LIST FMEMB MEMB GETP SUB1 ADD1 ZEROP ELT ILESSP LLSH LRSH IPLUS IDIFFERENCE \ARG0 GETHASH \ADDBASE \GETBASEPTR \GETBASEBYTE \GETBASE \GETBASEFIXP \GETBASESTRING \VAG2 \ADDBASE)) (RPAQQ OPCODEPROP DOPVAL) (RPAQQ VCONDITIONALS (ARRAYP FIXP FLOATP LISTP SMALLP STACKP NUMBERP)) (RPAQQ CONDITIONALS (EQ IGREATERP NULL GREATERP LESSP ILESSP)) (RPAQQ CONSTFNS (IPLUS SUB1 ADD1 ZEROP LLSH LRSH IDIFFERENCE)) (RPAQQ MAXARGS 80) (RPAQQ XVARFLG NIL) (RPAQQ NOFREEVARFNS (RPLACA RPLACD PUTHASH SETA)) (RPAQQ CLEANFNTEST DASSEM.CLEANFNTEST) (RPAQQ EQCONSTFN DASSEM.EQCONSTANTP) (ADDTOVAR NUMBERFNS LLSH1 LRSH1 LLSH8 LRSH8) (DECLARE%: EVAL@COMPILE (RPAQQ SHALLOWFLG NIL) (RPAQQ SPAGHETTIFLG T) (CONSTANTS (SHALLOWFLG NIL) (SPAGHETTIFLG T)) ) (DEFINEQ (DASSEM.CLEANFNTEST [LAMBDA (FN TYPE) (* lmm "23-May-86 16:27") (DECLARE (GLOBALVARS CONDITIONALS VCONDITIONALS NUMBERFNS CLEANFNLIST NOFREEVARFNS NOSIDEFNS) ) (COND ((LITATOM FN) (OR (GETPROP FN 'CROPS) (FMEMB FN CONDITIONALS) (FMEMB FN VCONDITIONALS) (FMEMB FN NUMBERFNS) (FMEMB FN CLEANFNLIST) (SELECTQ TYPE (FREEVARS (FMEMB FN NOFREEVARFNS)) (NOSIDE (FMEMB FN NOSIDEFNS)) NIL))) ((EQ (CAR FN) 'OPCODES) (while (SETQ FN (CDR FN)) do [SELECTQ (CAR FN) ((GETBASEPTR.N GETBASE.N) (SETQ FN (CDR FN))) (GETBITS.N.FD (SETQ FN (CDDR FN))) (ARG0) (GCONST (SETQ FN (CDDDR FN))) (COND ((LISTP (CAR FN)) (SELECTQ (CAAR FN) (IVAR) (RETURN))) (T (RETURN] finally (RETURN T]) ) (DEFOPTIMIZER ATOM (&REST ARGS) (CONS '(OPENLAMBDA (X) (OR (NULL X) (AND (\TYPEMASK.UFN X 8) T))) ARGS)) (DEFOPTIMIZER EVALV (&REST X) (COND ((CADR X) 'IGNOREMACRO) (T (CONS '\EVALV1 X)))) (DEFOPTIMIZER FRPLACA (&REST ARGS) (CONS 'RPLACA ARGS)) (DEFOPTIMIZER GETATOMVAL (ATM) `(GETTOPVAL ,ATM)) (DEFOPTIMIZER LIST (&REST X) [AND X (LIST 'CONS (CAR X) (CONS 'LIST (CDR X]) (DEFOPTIMIZER LITATOM (X &ENVIRONMENT ENV) (* ;; "Optimizer for LITATOM predicate. For 3-byte atom world, needs to include a check for 3-byte-atoms. For old atoms, it's just a type check. For new ones, use the type mask.") [COND [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES COPY TYPEMASK.N ,(CONSTANT (LRSH \TT.SYMBOLP 8)) EQ) ,X] (T `(EQ (NTYPX ,X) (CONSTANT \LITATOM]) (DEFOPTIMIZER MINUSP (X) `(GREATERP 0 ,X)) (DEFOPTIMIZER IEQP (X Y) `(EQ 0 (IDIFFERENCE ,X ,Y))) (DEFOPTIMIZER FASSOC (&REST ARGS) (CONS 'ASSOC ARGS)) (DEFOPTIMIZER SETATOMVAL (ATM VAL) `(SETTOPVAL ,ATM ,VAL)) (DEFOPTIMIZER SYSTEMTYPE (&CTXT IGNORE) ''D) (DEFOPTIMIZER SPREADAPPLY* (FN &REST ARGS) `(CL:FUNCALL ,FN ,@ARGS)) (PUTPROPS FGETD DMACRO COMP.GETD) (PUTPROPS FGREATERP DMACRO (APPLY* COMP.COMPARENUM FLOAT FGREATERP NIL (OPCODES UBFLOAT2 5))) (PUTPROPS FLESSP DMACRO (APPLY* COMP.COMPARENUM FLOAT FLESSP FGREATERP (OPCODES SWAP UBFLOAT2 5))) (PUTPROPS FMEMB DMACRO COMP.FMEMB) (PUTPROPS FRPLACD DMACRO COMP.RPLACD) (PUTPROPS GETD DMACRO COMP.GETD) (PUTPROPS GREATERP DMACRO (APPLY* COMP.COMPARENUM PLUS GREATERP)) (PUTPROPS IGREATERP DMACRO (APPLY* COMP.COMPARENUM FIX IGREATERP)) (PUTPROPS ILESSP DMACRO (APPLY* COMP.COMPARENUM FIX ILESSP IGREATERP)) (PUTPROPS LESSP DMACRO (APPLY* COMP.COMPARENUM PLUS LESSP GREATERP)) (PUTPROPS LLSH DMACRO COMP.SHIFT) (PUTPROPS LRSH DMACRO COMP.SHIFT) (PUTPROPS PRINTNUM DMACRO T) (PUTPROPS RPLACD DMACRO COMP.RPLACD) (PUTPROPS \FLOATBOX DMACRO C.FLOATBOX) (PUTPROPS \FLOATUNBOX DMACRO C.FLOATUNBOX) (DEFINEQ (COMP.RPLACD [LAMBDA (A) (* ; "Edited 2-Mar-88 14:08 by amd") (PROG (NEED-POP) (COMP.EXPR (CAR A)) [COND ((OPT.CALLP (CAR CODE) 'CONS) (* ;  "(RPLACD (CONS --) --) -> (CONS & &)") (FRPTQ (PROG1 (CAR (fetch OPARG of (CAR CODE))) (COMP.DELFN) (COMP.STCONST)) (SELECTQ (fetch OPNAME of (CAR CODE)) ((CONST AVAR FVAR HVAR GVAR) (COMP.DELPUSH)) (COMP.STPOP))) (COMP.VAL1 (CDR A)) (RETURN (COMP.STFN 'CONS (COND ((EQ (CAR CODE) OPNIL) (COMP.DELPUSH) 1) (T 2] DOIT (OR (EQ COMPILE.CONTEXT 'EFFECT) (COMP.STCOPY)) (COMP.VAL1 (CDR A)) (COND ([AND (EQ (fetch OPNAME of (CAR CODE)) 'SETQ) (OR (OPT.CALLP (CADR CODE) 'CONS 1) (SETQ NEED-POP (AND (OPT.CALLP (CADR CODE) 'CONS 2) (EQ (CADDR CODE) OPNIL] (COMP.ST (PROG1 (pop CODE) (COMP.DELFN) (AND NEED-POP (COMP.DELPUSH)) (COMP.STFN '\RPLCONS 2)) 0)) ([OR (OPT.CALLP (CAR CODE) 'CONS 1) (SETQ NEED-POP (AND (OPT.CALLP (CAR CODE) 'CONS 2) (EQ (CADR CODE) OPNIL] (COMP.DELFN) (AND NEED-POP (COMP.DELPUSH)) (COMP.STFN '\RPLCONS 2)) (T (COMP.STFN 'RPLACD 2))) (COMP.STPOP) (RETURN 'NOVALUE]) (COMP.SHIFT [LAMBDA (A) (* Pavel " 3-Nov-86 18:13") (COMP.VAL (CAR A)) (COMP.DELFIX) (COMP.VAL (CADR A)) (COMP.DELFIX) (COND [(EQ (fetch OPNAME of (CAR CODE)) 'CONST) (* ; "A compile shift open") (PROG ((N (fetch OPARG of (CAR CODE))) FNS) (OR (FIXP N) (COMPERROR (LIST N "non-numeric arg to shift"))) (COMP.DELPUSH) [COND ((EQ (fetch OPNAME of (CAR CODE)) 'CONST) (RETURN (COMP.STCONST (PROG1 (APPLY* (CAR EXP) (fetch OPARG of (CAR CODE)) N) (COMP.DELPUSH] [SETQ FNS (SELECTQ [COND ((EQ 0 N) (RETURN)) ((IGREATERP N 0) (CAR EXP)) (T (SETQ N (IMINUS N)) (SELECTQ (CAR EXP) (LLSH 'LRSH) 'LLSH] (LLSH '(LLSH8 . LLSH1)) '(LRSH8 . LRSH1] LP8 (COND ((IGREATERP N 7) (COMP.STFN (CAR FNS) 1) (SETQ N (IDIFFERENCE N 8)) (GO LP8))) LP1 (COND ((IGREATERP N 0) (COMP.STFN (CDR FNS) 1) (SETQ N (SUB1 N)) (GO LP1] (T (* ; "A can't compile shift open") (COMP.STFN (CAR EXP) 2]) (COMP.COMPARENUM [LAMBDA (A TYPE FN OFN) (* lmm "24-Jan-85 19:20") (PROG (V1) (if (EQ COMPILE.CONTEXT 'EFFECT) then (RETURN (COMP.PROGN A))) [COND (OFN (COND ((SETQ V1 (CONSTANTEXPRESSIONP (CADR A))) (RETURN (COMP.COMPARENUM (LIST (CAR V1) (CAR A)) TYPE OFN] (COMP.EXPR (CAR A) TYPE) (COMP.DELFIX TYPE) [COND ((AND OFN (SELECTQ (fetch OPNAME of (CAR CODE)) (CONST [SETQ V1 (KWOTE (fetch OPARG of (CAR CODE]) ((AVAR HVAR GVAR FVAR) (SETQ V1 CODE) NIL) NIL)) (RETURN (PROGN (COMP.DELPUSH) (COMP.VAL1 (CDR A)) (COMP.DELFIX TYPE) (COMP.VAL V1) (COMP.STFN OFN 2] (COMP.VAL1 (CDR A) TYPE) (COMP.DELFIX TYPE) (COND ((AND OFN V1 (FMEMB (fetch OPNAME of (CAR CODE)) '(CONST AVAR HVAR FVAR GVAR)) (EQ (CDR CODE) V1)) (swap (CAR CODE) (CAR V1)) (COMP.STFN OFN 2)) (T (COMP.STFN FN 2]) (COMP.GETD [LAMBDA (A) (* Pavel " 3-Nov-86 18:13") (COMP.VAL1 A) (COND ((EQ COMPILE.CONTEXT 'EFFECT) (COMP.STPOP) 'NOVALUE) ((COMP.PREDP COMPILE.CONTEXT) (COMP.STFN (SELECTQ (CAR COMPILE.CONTEXT) ((TJUMP FJUMP NFJUMP) (* ;  "\DEFINEDP is the same as GETD when the value is used only for NIL or T") '\DEFINEDP) (CAR EXP)) 1)) (T (COMP.STFN (CAR EXP) 1]) (COMP.FMEMB [LAMBDA (A) (* Pavel " 3-Nov-86 18:13") (PROG NIL [COND ((EQ COMPILE.CONTEXT 'EFFECT) (RETURN (COMP.VALN A COMPILE.CONTEXT] (COMP.EXPR (pop A)) (COMP.VAL1 A) [COND ([AND (COMP.PREDP COMPILE.CONTEXT) (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (FMEMB (fetch OPNAME of COMPILE.CONTEXT) '(FJUMP TJUMP NFJUMP] (RETURN (COMP.SELECTQ (LIST DONOTHING (LIST (PROG1 (fetch OPARG of (CAR CODE)) (COMP.DELPUSH)) T) NIL] (RETURN (COMP.STFN (CAR EXP) 2]) ) (PUTPROPS DMACRO PROPTYPE MACROS) (* ; "COMP.GETBASE") (DEFOPTIMIZER \GETBASEBYTE (X N) `((OPCODES GETBASEBYTE) ,X ,N)) (DEFOPTIMIZER \PUTBASEBYTE (X N V) `((OPCODES PUTBASEBYTE) ,X ,N ,V)) (DEFOPTIMIZER \HILOC (X) `((OPCODES HILOC) ,X)) (DEFOPTIMIZER \LOLOC (X) `((OPCODES LOLOC) ,X)) (DEFOPTIMIZER \VAG2 (X Y) `((OPCODES VAG2) ,X ,Y)) (PUTPROPS \GETBASE DMACRO (APPLY* COMP.GETBASE NIL GETBASE.N)) (PUTPROPS \GETBASEPTR DMACRO (APPLY* COMP.GETBASE NIL GETBASEPTR.N)) (PUTPROPS \PUTBASE DMACRO (APPLY* COMP.GETBASE T PUTBASE.N)) (PUTPROPS \PUTBASEPTR DMACRO (APPLY* COMP.GETBASE T PUTBASEPTR.N)) (PUTPROPS \RPLPTR DMACRO (APPLY* COMP.GETBASE T RPLPTR.N)) (PUTPROPS \GETBITS DMACRO (APPLY* COMP.GETBASEBITS)) (PUTPROPS \PUTBITS DMACRO (APPLY* COMP.GETBASEBITS T)) (DEFINEQ (COMP.GETBASE [LAMBDA (A STFLG OPCODE) (* Pavel " 3-Nov-86 18:13") (COND ([AND STFLG (NOT (EQ COMPILE.CONTEXT 'EFFECT] (COMP.VAL (CONS (LIST 'OPENLAMBDA '(X N V) (CONS (CAR EXP) '(X N V)) 'V) A))) ((AND (NOT STFLG) (EQ COMPILE.CONTEXT 'EFFECT)) (COMP.VALN A 'EFFECT)) (T (PROG ((OFF 0)) (COMP.VAL (pop A)) (COND ((AND (OPT.CALLP (CAR CODE) '\ADDBASE 2) (EQ (fetch OPNAME of (CADR CODE)) 'CONST)) (COMP.DELFN) (add OFF (fetch OPARG of (CAR CODE))) (COMP.DELPUSH))) (COMP.EXPR (pop A) '(TYPE . FIX)) (COND ([AND (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (FIXP (fetch OPARG of (CAR CODE] (add OFF (fetch OPARG of (CAR CODE))) (COMP.DELPUSH)) (T (COMP.STFN '\ADDBASE 2))) (COND ((OR (ILESSP OFF 0) (IGREATERP OFF 255)) (COMP.STCONST OFF) (COMP.STFN '\ADDBASE 2) (SETQ OFF 0))) [COND (STFLG (COMP.EXPR (pop A) '(TYPE . FIX] (MAPC A (FUNCTION COMP.EFFECT)) (RETURN (if (EQ OPCODE 'GETBASE.32) then (if STFLG then (HELP) else (COMP.STFN `(OPCODES COPY GETBASE.N %, OFF SWAP GETBASE.N %, (ADD1 OFF) VAG2) 1)) else (COMP.STFN (LIST 'OPCODES OPCODE OFF) (COND (STFLG 2) (T 1]) (COMP.GETBASEBITS [LAMBDA (A STFLG) (* Pavel " 3-Nov-86 18:13") (COND [[AND STFLG (NOT (EQ COMPILE.CONTEXT 'EFFECT] (COMP.VAL (LIST (LIST 'OPENLAMBDA '(X V) (LIST (CAR EXP) 'X (CADR A) (CADDR A) 'V) 'V) (CAR A) (CADDDR A] (T (PROG ((OFF (CADR A))) (COMP.VAL (CAR A)) (COND ((AND (OPT.CALLP (CAR CODE) '\ADDBASE 2) (EQ (fetch OPNAME of (CADR CODE)) 'CONST)) (COMP.DELFN) (add OFF (fetch OPARG of (CAR CODE))) (COMP.DELPUSH))) (COND ((OR (ILESSP OFF 0) (IGREATERP OFF 255)) (COMP.STCONST OFF) (COMP.STFN '\ADDBASE 2) (SETQ OFF 0))) [COND (STFLG (COMP.VAL (CADDDR A] (RETURN (COMP.STFN [CONS 'OPCODES (COND [(EQ (CADDR A) 15) (COND (STFLG (LIST 'PUTBASE.N OFF)) (T (LIST 'GETBASE.N OFF] (T (COND (STFLG (LIST 'PUTBITS.N.FD OFF (CADDR A))) (T (LIST 'GETBITS.N.FD OFF (CADDR A] (COND (STFLG 2) (T 1]) ) (DEFINEQ (COMP.SPREADFN [LAMBDA (2FN ARGS) (* lmm "15-APR-82 22:26") (COND ((NULL (CDR ARGS)) (CAR ARGS)) ((NULL (CDDR ARGS)) (CONS 2FN ARGS)) (T (LIST 2FN (CAR ARGS) (COMP.SPREADFN 2FN (CDR ARGS]) ) (DEFOPTIMIZER NCONC (&REST ARGS) [COND ((NULL (CDR ARGS)) (CAR ARGS)) ((NULL (CDDR ARGS)) (CONS '\NCONC2 ARGS)) (T (LIST '\NCONC2 (CAR ARGS) (CONS 'NCONC (CDR ARGS]) (DEFOPTIMIZER APPEND (&REST ARGS) [COND ((NULL (CDR ARGS)) (LIST '\APPEND2 (CAR ARGS) NIL)) ((NULL (CDDR ARGS)) (CONS '\APPEND2 ARGS)) (T (LIST '\APPEND2 (CAR ARGS) (CONS 'APPEND (CDR ARGS]) (* ; "CAPPLYFN") (PUTPROPS NILAPPLY DMACRO (OPENLAMBDA (FN N) (.PUSHNILS. N FN))) (PUTPROPS .PUSHNILS. DMACRO (APPLY COMP.PUSHNILS)) (PUTPROPS SPREADAPPLY DMACRO [OPENLAMBDA (FN ARGLIST) (PROG ((CNT 0)) (DECLARE (LOCALVARS . T)) (RETURN (.SPREAD. ARGLIST CNT FN]) (PUTPROPS .SPREAD. DMACRO (APPLY COMP.SPREAD)) (PUTPROPS .EVALFORM. DMACRO COMP.EVALFORM) (PUTPROPS .CALLAFTERPUSHINGNILS. DMACRO (APPLY COMP.PUSHCALL)) (PUTPROPS APPLY* DMACRO COMP.APPLY*) (PUTPROPS .SPREADCONS. DOPVAL (1 COPY CAR SWAP CDR)) (PUTPROPS .SWAPNIL. DOPVAL (2 SWAP)) (DEFINEQ (COMP.PUSHNILS [LAMBDA (N FN) (* lmm "16-APR-82 00:39") (COMP.EXPR N) (PROG ((CHK (create TAG)) (LP (create TAG)) (LEV LEVEL) (FR FRAME)) (COMP.STJUMP 'JUMP CHK) (SETQ LEVEL LEV) (SETQ FRAME FR) (COMP.STTAG LP) (COMP.STCONST) (COMP.STFN '.SWAPNIL. 2) (COMP.STCONST 1) (COMP.STFN 'IDIFFERENCE 2) (COMP.STTAG CHK) (COMP.STCOPY) (COMP.STCONST 0) (COMP.STFN 'IGREATERP 2) (COMP.STJUMP 'TJUMP LP) (COMP.STPOP) (COMP.VAL N) (COMP.VAL FN) (COMP.STFN '.APPLYFN. 2]) (COMP.SPREAD [LAMBDA (L VAR FN APPLYTOEACH) (* ; "Edited 18-Dec-86 14:53 by lmm") [while [AND (EQ (CL:FIRST L) 'MAPCAR) (LISTP (CL:THIRD L)) (NULL (CDDDR L)) (FMEMB (CAR (CL:THIRD L)) '(FUNCTION CL:FUNCTION)) (LITATOM (CL:SECOND (CL:THIRD L] do (push APPLYTOEACH (CADR (CADDR L] (COMP.EXPR L) (PROG ((LSTCHECK (create TAG)) (LP (create TAG)) (LEV LEVEL) (FR FRAME)) (COMP.STJUMP 'JUMP LSTCHECK) (SETQ LEVEL LEV) (SETQ FRAME FR) (COMP.STTAG LP) (COMP.STFN '(OPCODES COPY CAR) 1) [for X in APPLYTOEACH do (if (CL:SYMBOLP X) then (COMP.STFN X 1) else (LET ((N 1)) (for ARG in (CDR X) do (COMP.EXPR ARG) (add N 1)) (COMP.STFN (CAR X) N] (COMP.STFN '(OPCODES SWAP CDR) 1) [COMP.EFFECT (LIST 'AND (LIST 'IGEQ (LIST 'ADD1VAR VAR) CL:CALL-ARGUMENTS-LIMIT) '(LISPERROR "TOO MANY ARGUMENTS"] (COMP.STTAG LSTCHECK) (COMP.STJUMP 'NTJUMP LP) (COMP.VAL VAR) (COMP.VAL FN) (RETURN (COMP.STFN '.APPLYFN. 2]) (COMP.EVALFORM [LAMBDA NIL (* lmm "29-Jun-84 08:25") (* ;; "Special code for compiling interpreter (see function \EVALFORM on LLNINTERP). Assume *ARGVAL* bound to 0, *FN* bound, *TAIL* bound") (OR (EQ COMPILE.CONTEXT 'RETURN) (SHOULDNT)) (* ;  "Must be in return context, since otherwise would have to pop off *ARGVAL* value") (PROG ((DONE (create TAG)) (LP (create TAG))) (COMP.STCONST '*ARGVAL*) (* ; "for BLIPVAL to find") (COMP.STTAG LP) [COMP.VAL '(LISTP (SETQ *TAIL* (CDR *TAIL*] (* ;  "*TAIL* initially bound to entire form.") (COMP.STJUMP 'FJUMP DONE) [COMP.VAL '(\EVAL (CAR *TAIL*] (* ; "evaluate this argument") [COMP.EFFECT (LIST 'AND (LIST 'IGREATERP '(SETQ *ARGVAL* (ADD1 *ARGVAL*)) MAXARGS) (LIST 'LISPERROR '"TOO MANY ARGUMENTS" '*TAIL*] (* ;  "increment counter of number of values") (SETQ LEVEL (SUB1 LEVEL)) (* ; "fool level check; the value of the \EVAL is left on the stack, even though the compiler doesn't think so") (COMP.STJUMP 'JUMP LP) (COMP.STTAG DONE) (* ;  "there are really *ARGVAL* values on the stack") [COMP.EFFECT '(AND *TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*] [COMP.VAL '(PROG1 *ARGVAL* (SETQ *ARGVAL*] (* ;  "push number of arguments --- mark frame as done (see \DEADBLIPFRAME on LLNINTERP)") (COMP.VAL '*FN*) (* ; "push name of function to call") (COMP.STFN '.APPLYFN. 2) (* ; "this will execute applyfn opcode, which really takes N+2 args even though compiler thinks it takes 2") (RETURN (COMP.STRETURN]) (COMP.PUSHCALL [LAMBDA (N FORM) (* lmm "16-APR-82 00:39") (COMP.VAL N) (PROG ((CHK (create TAG)) (LP (create TAG)) (LEV LEVEL) (FR FRAME)) (COMP.STJUMP 'JUMP CHK) (SETQ LEVEL LEV) (SETQ FRAME FR) (COMP.STTAG LP) (COMP.STCONST) (COMP.STFN '.SWAPNIL. 2) (COMP.STCONST 1) (COMP.STFN 'IDIFFERENCE 2) (COMP.STTAG CHK) (COMP.STCOPY) (COMP.STCONST 0) (COMP.STFN 'IGREATERP 2) (COMP.STJUMP 'TJUMP LP) (COMP.STPOP) (RETURN (COMP.EXP1 FORM]) (COMP.APPLY* [LAMBDA (A) (* lmm "13-Jul-84 21:18") (PROG (FN) (replace EXTCALL of FRAME with T) (COND ([AND (EQ (CAR (LISTP (CAR A))) 'FUNCTION) (NULL (CDDAR A)) (LISTP (SETQ FN (CADR (CAR A] (SELECTQ (ARGTYPE FN) ((0 2) [RETURN (COMP.EXP1 (CONS FN (CDR A]) (3 (* ; "APPLY* of NLAMBDA nospread") (* (AND (LITATOM FN)  (RETURN (COMP.CALL FN  (LIST (CONS (QUOTE LIST)  (CDR A))) 0)))) ) (1 (* ; "APPLY* of NLAMBDA spread") (* (AND (LITATOM FN)  (RETURN (COMP.CALL FN  (CDR A) 0)))) ) NIL))) (RETURN (COMP.EXP1 `((OPENLAMBDA (%, (SETQ FN (GENSYM))) ((OPCODES CHECKAPPLY* APPLYFN) %,@ (CDR A) %, (LENGTH (CDR A)) %, FN)) %, (CAR A]) ) (* ; "for ARG and SETARG") (PUTPROPS ARG DMACRO COMP.ARG) (PUTPROPS SETARG DMACRO COMP.SETARG) (PUTPROPS NAMEDLET DMACRO COMP.NAMEDLET) (DEFINEQ (COMP.ARG [LAMBDA (A) (* bvm%: "15-Oct-85 18:18") (COND ((AND (EQ COMPILE.CONTEXT 'EFFECT)) (COMP.PROGN A)) [(AND (EQ COMTYPE 2) (EQ (COMP.LOOKUPVAR (CAR A)) (CAR ARGVARS))) (COMP.VAL1 (CDR A)) (COND ((AND COMPILE.ARG.FAST.FLG (EQ (fetch OPNAME of (CAR CODE)) 'CONST) [FIXP (SETQ A (fetch OPARG of (CAR CODE] (IGREATERP A 0) (ILEQ A 255)) (COMP.DELPUSH) (COMP.STFN [COND ((IGREATERP A (OPCOUNT 'IVAR)) (LIST 'OPCODES 'IVARX (LLSH (SUB1 A) 1))) (T (LIST 'OPCODES (LIST 'IVAR (SUB1 A] 0)) (T (COMP.STFN '(OPCODES ARG0) 1] (T (* ; "unreasonable ARG") (COMP.CALL 'ARG (CONS (KWOTE (CAR A)) (CDR A)) 0]) (COMP.SETARG [LAMBDA (A) (* lmm " 6-Dec-85 13:17") (COND [(AND (EQ COMTYPE 2) (EQ (COMP.LOOKUPVAR (CAR A)) (CAR ARGVARS))) (COMP.VAL (CADR A)) (LET [(ARG (fetch OPARG of (CAR CODE] (COND ((AND COMPILE.ARG.FAST.FLG (EQ (fetch OPNAME of (CAR CODE)) 'CONST) (FIXP ARG) (IGREATERP ARG 0) (ILEQ ARG 255)) (COMP.DELPUSH) (COMP.VAL1 (CDDR A)) (COMP.STFN (LIST 'OPCODES 'IVARX_ (TIMES (SUB1 ARG) 2)) 1)) (T (COMP.VAL1 (CDDR A)) (COMP.STFN '\SETARG0 2] (T (* ; "unreasonable ARG") (COMP.CALL '\SETARG (CONS (KWOTE (CAR A)) (CDR A)) 0]) (COMP.NAMEDLET [LAMBDA (ARGS) (* lmm " 8-MAY-82 13:15") (PROG [(FN (COMP.LAM1 (CONS 'LAMBDA (CONS (MAPCAR (CAR (CDR ARGS)) (FUNCTION CAR)) (CONS (LIST '\CALLME (KWOTE (CAR ARGS))) (CDR (CDR ARGS] (RETURN (COMP.CALL FN [MAPCAR (CAR (CDR ARGS)) (FUNCTION (LAMBDA (X) (COND ((CDR (CDR X)) (CONS 'PROG1 (CDR X))) (T (CAR (CDR X] 0]) ) (PUTPROPS LOADTIMECONSTANT DMACRO [X (LIST 'QUOTE (CONS LOADTIMECONSTANTMARKER (CAR X]) (RPAQQ LOADTIMECONSTANTMARKER "LoadTimeConstant") (PUTPROPS DLAP FILETYPE CL:COMPILE-FILE) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS DASM [(FREEVARINDEX (GETHASH DATUM FVINDEXHARRAY) (PUTHASH DATUM NEWVALUE FVINDEXHARRAY)) (VARINDEX (GETHASH DATUM VCA) (PUTHASH DATUM NEWVALUE VCA)) (CLEAR (PROGN (OPT.INITHASH VCA) (OPT.INITHASH FVINDEXHARRAY] (* ; "for alto assembler") ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FVINDEXHARRAY) ) (DECLARE%: EVAL@COMPILE (PUTPROPS PARENTP MACRO [LAMBDA (X Y) (PROG NIL LP (RETURN (OR (EQ X Y) (AND (SETQ X (fetch PARENT of X)) (GO LP]) (PUTPROPS AST MACRO ((X) (SETQ CD (CONS X CD)) (SETQ CODELOC (ADD1 CODELOC)))) (PUTPROPS OPCOUNT MACRO [LAMBDA (X) (ADD1 (LET [(OP (fetch OP# of (\FINDOP X] (IDIFFERENCE (CADR OP) (CAR OP]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS CHECKRANGE MACRO [(X N MSG) (COND ((IGREATERP X (CONSTANT N)) (COMPERRM (LIST X MSG '%, 'LIMIT 'IS (CONSTANT N]) ) DONTEVAL@LOAD (FILESLOAD (LOADCOMP) BYTECOMPILER LLCODE) ) (PUTPROPS DLAP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5155 49029 (C.FLOATBOX 5165 . 5400) (C.FLOATUNBOX 5402 . 5619) (DASSEM.DASSEM 5621 . 28314) (DASSEM.DWRITEFN 28316 . 35849) (DASSEM.SAVELOCALVARS 35851 . 35899) (DASSEM.DSTOREFNDEF 35901 . 45050) (DASSEM.DPRINTLAP 45052 . 45471) (DASSEM.EQCONSTANTP 45473 . 45695) (DASSEM.MATCHVARS 45697 . 47149) (DASSEM.COUNTVARS 47151 . 47617) (DASSEM.CANSHAREBINDING 47619 . 49027)) (49176 53933 ( DASSEM.DASMBIND 49186 . 49816) (DASSEM.DSTOREFN 49818 . 50452) (DASSEM.ASMAJ 50454 . 53931)) (62936 64419 (DASSEM.CLEANFNTEST 62946 . 64417)) (67465 74962 (COMP.RPLACD 67475 . 69825) (COMP.SHIFT 69827 . 71836) (COMP.COMPARENUM 71838 . 73417) (COMP.GETD 73419 . 74038) (COMP.FMEMB 74040 . 74960)) (76239 80811 (COMP.GETBASE 76249 . 78675) (COMP.GETBASEBITS 78677 . 80809)) (80812 81123 (COMP.SPREADFN 80822 . 81121)) (82749 89911 (COMP.PUSHNILS 82759 . 83489) (COMP.SPREAD 83491 . 85133) (COMP.EVALFORM 85135 . 87443) (COMP.PUSHCALL 87445 . 88127) (COMP.APPLY* 88129 . 89909)) (90083 93192 (COMP.ARG 90093 . 91270) (COMP.SETARG 91272 . 92363) (COMP.NAMEDLET 92365 . 93190))))) STOP \ No newline at end of file diff --git a/sources/DLFIXINIT b/sources/DLFIXINIT new file mode 100644 index 00000000..c10cbe6e --- /dev/null +++ b/sources/DLFIXINIT @@ -0,0 +1,166 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "29-Jan-98 17:51:06" {DSK}disk2>jdstools>lc3>lispcore3.0>sources>DLFIXINIT.;2 27711 + + changes to%: (FNS DLCOPYPAGEMAP) + + previous date%: " 9-Nov-92 14:54:57" +{DSK}disk2>jdstools>lc3>lispcore3.0>sources>DLFIXINIT.;1) + + +(* ; " +Copyright (c) 1983, 1984, 1990, 1992, 1998 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DLFIXINITCOMS) + +(RPAQQ DLFIXINITCOMS + [(FNS DLFIXINIT DLSORTSYSOUTPAGES DLNEXTFP DLLOCKEDPAGEP DLSETLOCKBIT DLCOPYPAGEMAP + DLCOPYVMPAGE DLADDPAGEMAPENTRIES ASSIGNFILEPAGE ASSIGNFILEPAGERANGE DLDUMPSYSOUT + DLDUMPFPTOVP DLDUMPPAGEMAPS DLDUMPVMEMPAGES DLSETBOOTPTR DLDUMPARRAY DLMARKASDUMPED + DLDUMPVMEMPAGE INSTALLDOMINO INSTALLDOMINO.DIRECT INSTALLNEWDOMINO) + (FNS DLPRINTFPTOVP PRINTPRIMARYMAP DLREADPAGEOFWORDS SETDIF) + (CONSTANTS \NO.PAGE.ASSIGNED) + (GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM + DLPAGEMAPFP FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX) + (DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + READSYS LLFAULT) + (P (CHECKIMPORTS '(MODARITH LLPARAMS) + T]) +(DEFINEQ + +(DLFIXINIT [LAMBDA (SYSOUTFILE DLBOOTFILE DBFILE %#UCODEPAGES) (* ;  "Edited 2-Nov-92 08:16 by sybalsky:mv:envos") [COND ((NOT DLBOOTFILE) (SETQ DLBOOTFILE (PACKFILENAME 'EXTENSION 'DLINIT 'VERSION NIL 'BODY SYSOUTFILE] (FILESLOAD (SYSLOAD) READSYS RDSYS) (RESETLST (SETQ DBFILE (OPENFILE (OR DBFILE '{PHYLUM}FUGUE>DLISPDOMINO.DB) 'INPUT)) (RESETSAVE NIL (LIST 'CLOSEF DBFILE)) (PROG ((DBPAGES (IPLUS (FOLDHI (GETFILEINFO DBFILE 'LENGTH) BYTESPERPAGE) 2)) (%#ADDEDFILEPAGES 0) %#OLDFILEPAGES %#NEWFILEPAGES %#FPTOVPPAGES DLFILEX) (DECLARE (SPECVARS %#NEWFILEPAGES %#OLDFILEPAGES %#ADDEDFILEPAGES %#FPTOVPPAGES DLFILEX)) (* ;  "Plus 2 is to allow for interface page and copy of page 0") (COND ((NOT %#UCODEPAGES) (SETQ %#UCODEPAGES (IQUOTIENT (ITIMES DBPAGES 5) 4)) (printout T " Assuming " .P2 %#UCODEPAGES " pages of uCode/Domino" T)) ((ILESSP %#UCODEPAGES DBPAGES) (printout T "Not enough space for Domino; raising it to " .P2 (SETQ %#UCODEPAGES DBPAGES) " pages" T))) (READSYS SYSOUTFILE) (RESETSAVE NIL '(READSYS)) (* ;  "To close the sysout source on exit") (SETQ %#OLDFILEPAGES (FOLDHI (GETFILEINFO VMEMFILE 'LENGTH) BYTESPERPAGE)) (DLCOPYPAGEMAP) (SETQ NEWFPFROMOLD (ARRAY %#OLDFILEPAGES 'WORD \NO.PAGE.ASSIGNED 1)) (DLSORTSYSOUTPAGES) (until (ERSETQ (DLDUMPSYSOUT)) do (printout T T "DLFIXINIT failed, trying again..." T)) (RETURN DLBOOTFILE)))]) + +(DLSORTSYSOUTPAGES [LAMBDA NIL (* ;  "Edited 4-Nov-92 15:47 by sybalsky:mv:envos") (DECLARE (USEDFREE FPSIZE NEWFPFROMOLD FPTOVPSIZE FPTOVP PGTAB %#FPTOVPPAGES) (SPECVARS LASTFP)) (PROG (LASTFP) (ASSIGNFILEPAGE \FP.IFPAGE \VP.IFPAGE (SUB1 \FP.IFPAGE) T) (* ;  "SUB1 because old FP's are zero-based! See VMEM structures") (ASSIGNFILEPAGERANGE \VP.DISPLAY \NP.DISPLAY (DLFPFROMRP \RP.TEMPDISPLAY)) (ASSIGNFILEPAGERANGE \VP.STACK PAGESPERSEGMENT (DLFPFROMRP \RP.STACK) T) (ASSIGNFILEPAGERANGE \VP.TYPETABLE \NP.TYPETABLE (DLFPFROMRP \RP.TYPETABLE)) (ASSIGNFILEPAGERANGE \VP.GCTABLE \NP.GCTABLE (DLFPFROMRP \RP.GCTABLE)) (ASSIGNFILEPAGERANGE \VP.GCOVERFLOW \NP.GCOVERFLOW (DLFPFROMRP \RP.GCOVERFLOW)) (ASSIGNFILEPAGERANGE \VP.FPTOVP %#FPTOVPPAGES (DLFPFROMRP \RP.FPTOVP)) (replace (IFPAGE FPTOVPStart) of DLIFPAGE with (DLFPFROMRP \RP.FPTOVP)) (replace (IFPAGE LastDominoFilePage) of DLIFPAGE with (SETQ DLLASTDOMINOPAGE %#UCODEPAGES)) [SETQ LASTFP (SUB1 (SETQ DLPAGEMAPFP (DLFPFROMRP \RP.MISCLOCKED] (* ;; "Assign next the pagemap pages, since we have to know where they live (some are new) and it is very convenient for them to be contiguous") (for J from 0 to (SUB1 \NumPMTpages) do (ASSIGNFILEPAGE (DLNEXTFP) (IPLUS J \VP.PRIMARYMAP) NIL T)) (replace (IFPAGE filePnPMT0) of DLIFPAGE with DLPAGEMAPFP) (replace (IFPAGE filePnPMP0) of DLIFPAGE with (IPLUS DLPAGEMAPFP \NumPMTpages)) (* ;; "NO LONGER -- 5,,0 TAKEN FOR FPTOVP IN MEDLEY 2.1 -- but we need the decondary page table up thru building things, so assign it:") (for J from 0 to (SUB1 (FOLDHI DLNEXTPM WORDSPERPAGE)) do (ASSIGNFILEPAGE (DLNEXTFP) (IPLUS J \VP.SECONDARYMAP) NIL T)) (* ;; "Similarly, assign locked page table, which is another structure we rewrite") (for J from 0 to (SUB1 \NumLPTPages) do (ASSIGNFILEPAGE (DLNEXTFP) (IPLUS J \VP.LPT) NIL T)) (* ;; "Finally, assign file pages for everyone we haven't taken care of yet. First the locked pages, which have to be at the front of the sysout, after the fixed assignments we have already made") [for IFLOCKED in '(T NIL) do (for VPSEG from 0 to \MAXVMSEGMENT bind PGTAB2 when (NEQ (SETQ PGTAB2 (FASTELT PGTAB VPSEG)) PGEMPTY) do (for I from 0 to (SUB1 PAGESPERSEGMENT) bind (VPBASE _ (UNFOLD VPSEG PAGESPERSEGMENT)) OLDFP when (AND [NOT (ZEROP (SETQ OLDFP (FASTELTN PGTAB2 I ] (EQ (DLLOCKEDPAGEP (IPLUS VPBASE I)) IFLOCKED) (EQ (FASTELTN NEWFPFROMOLD OLDFP) \NO.PAGE.ASSIGNED)) do (ASSIGNFILEPAGE (DLNEXTFP) (IPLUS VPBASE I) OLDFP IFLOCKED))) (COND (IFLOCKED (replace (IFPAGE LastLockedFilePage) of DLIFPAGE with LASTFP) (SETQ LASTFP DLLASTDOMINOPAGE] (replace (IFPAGE NDirtyPages) of DLIFPAGE with (replace (IFPAGE NActivePages ) of DLIFPAGE with %#NEWFILEPAGES ]) + +(DLNEXTFP [LAMBDA NIL (* ;  "Edited 2-Nov-92 12:29 by sybalsky:mv:envos") (do (add LASTFP 1) repeatuntil (EQ (FASTELTN FPTOVP (LLSH LASTFP 1)) \NO.VMEM.PAGE)) LASTFP]) + +(DLLOCKEDPAGEP [LAMBDA (VP) (* bvm%: " 6-Dec-84 22:25") (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP) (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD]) + +(DLSETLOCKBIT [LAMBDA (VP) (* bvm%: " 6-Dec-84 22:26") (FASTSETAN DLLOCKBITS (FOLDLO VP BITSPERWORD) (LOGOR (.LOCKEDVPMASK. VP) (FASTELTN DLLOCKBITS (FOLDLO VP BITSPERWORD]) + +(DLCOPYPAGEMAP + [LAMBDA NIL (* ; + "Edited 3-Nov-92 15:46 by sybalsky:mv:envos") + (PROG NIL + [SETQ DLIFPAGE (DLCOPYVMPAGE \VP.IFPAGE (NCREATE 'VMEMPAGEP] + (* ; "Install interface page by magic") + (SETQ DLPRIMARYMAP (ARRAY (UNFOLD \NumPMTpages WORDSPERPAGE) + 'WORD 0 0)) (* ; "Primary map table") + [for J from 0 to (SUB1 \NumPMTpages) + do (DLCOPYVMPAGE (IPLUS J \VP.PRIMARYMAP) + (\ADDBASE (fetch (ARRAYP BASE) of DLPRIMARYMAP) + (UNFOLD J WORDSPERPAGE] + (SETQ DLNEXTPM (fetch (IFPAGE NxtPMAddr) of DLIFPAGE)) + (* ; + "First free offset in secondary map") + (DLADDPAGEMAPENTRIES \VP.FPTOVP \NP.FPTOVP) + (COND + ((NOT (VMPAGEP \VP.DISPLAY)) + (DLADDPAGEMAPENTRIES \VP.DISPLAY \NP.DISPLAY) + (add %#ADDEDFILEPAGES \NP.DISPLAY))) + (SETQ %#NEWFILEPAGES (IPLUS (SUB1 %#OLDFILEPAGES) + (SUB1 %#UCODEPAGES))) + + (* ;; "Used to use WORDSPERPAGE, until an FPTOVP entry went from word to cell 11/3/92 JDS:") + + (SETQ %#FPTOVPPAGES (ADD1 (FOLDHI (IPLUS %#NEWFILEPAGES %#ADDEDFILEPAGES) + CELLSPERPAGE))) + + (* ;; "Number of pages of FPTOVP needed -- cover everything in sysout, plus one more possibly needed to cover FPTOVP itself") + + (add %#ADDEDFILEPAGES %#FPTOVPPAGES) + (add %#NEWFILEPAGES %#ADDEDFILEPAGES) + + (* ;; +"Make FPTOVP big enough to hold #NEWPAGES, plus a couple of entries as slop, to prevent off-by-1's.") + + (SETQ FPTOVP (ARRAY (+ 16384 (LLSH %#NEWFILEPAGES 1)) + 'WORD \NO.VMEM.PAGE 1)) + (SETQ DLSECONDARYMAP (ARRAY (CEIL DLNEXTPM WORDSPERPAGE) + 'WORD 0 0)) + + (* ;; "Allocate enough space to accomodate existing secondary map plus anything we added. Round up to a page boundary") + + (replace (IFPAGE NxtPMAddr) of DLIFPAGE with DLNEXTPM) + (* ; + "Store back new DLNEXTPM as updated by DLADDPAGEMAPENTRIES") + (SETQ DLLOCKBITS (ARRAY (UNFOLD \NumLPTPages WORDSPERPAGE) + 'WORD 0 0)) (* ; "Read the locked page table") + (for J from 0 to (SUB1 \NumLPTPages) + do (DLCOPYVMPAGE (IPLUS J \VP.LPT) + (\ADDBASE (fetch (ARRAYP BASE) of DLLOCKBITS) + (UNFOLD J WORDSPERPAGE]) + +(DLCOPYVMPAGE [LAMBDA (VP BASE) (* bvm%: "14-Dec-84 12:46") (* Reads page VP from VMEMFILE into  BASE, returning BASE) (SETVMPTR (UNFOLD VP WORDSPERPAGE)) (\BINS VMEMFILEX BASE 0 BYTESPERPAGE) BASE]) + +(DLADDPAGEMAPENTRIES [LAMBDA (VP NPAGES) (* bvm%: "27-MAR-83 17:53") (to NPAGES do [COND ((IEQ (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP)) \EmptyPMTEntry) (COND ((EVENP DLNEXTPM WORDSPERPAGE) (* must add a new page map page) (add %#ADDEDFILEPAGES 1))) (FASTSETAN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP) DLNEXTPM) (SETQ DLNEXTPM (IPLUS DLNEXTPM \PMblockSize] (add VP 1]) + +(ASSIGNFILEPAGE [LAMBDA (FP VP OLDFP LOCKED) (* ;  "Edited 9-Nov-92 14:54 by sybalsky:mv:envos") (* ;; "Assign VP to live in FP (and hence a related real page); OLDFP is where VP lives in the old sysout") (COND ([NOT (ZEROP (OR OLDFP (SETQ OLDFP (LOGAND (FASTELTN (FASTELT PGTAB (LRSH VP 8)) (LOGAND VP 255)) 32767] (FASTSETAN NEWFPFROMOLD OLDFP FP))) (FASTSETAN FPTOVP (ADD1 (LLSH FP 1)) VP) (FASTSETAN FPTOVP (LLSH FP 1) 0) (PROG [(SECONDARY (FASTELTN DLPRIMARYMAP (fetch (VP PRIMARYKEY) of VP] (* ;  "Update pagemap to point to the new FP") (COND ((IEQ SECONDARY \EmptyPMTEntry) (HELP VP "has no primary map entry")) (T (FASTSETAN DLSECONDARYMAP (IPLUS SECONDARY (fetch (VP SECONDARYKEY) of VP)) FP))) (COND (LOCKED (DLSETLOCKBIT VP]) + +(ASSIGNFILEPAGERANGE [LAMBDA (VPSTART NPAGES FPSTART ONLYIFTHERE) (* bvm%: "25-MAR-83 12:44") (for I from 0 to (SUB1 NPAGES) unless [AND ONLYIFTHERE (NOT (VMPAGEP (IPLUS VPSTART I] do (ASSIGNFILEPAGE (IPLUS FPSTART I) (IPLUS VPSTART I) NIL T]) + +(DLDUMPSYSOUT [LAMBDA NIL (* ;  "Edited 3-Nov-92 10:50 by sybalsky:mv:envos") (PROG [(DLPAGEOFZEROS (NCREATE 'VMEMPAGEP] [RESETSAVE [SETQ DLFILEX (OPENSTREAM DLBOOTFILE 'OUTPUT 'NEW 8 (CONS (LIST 'LENGTH (UNFOLD %#NEWFILEPAGES BYTESPERPAGE)) '((SEQUENTIAL T) (TYPE BINARY] '(PROGN (CLOSEF? OLDVALUE) (AND RESETSTATE (DELFILE OLDVALUE] (SETQ DLBOOTFILE (FULLNAME DLFILEX)) (PROGN (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE) (* ; "First page of domino") (\BOUTS DLFILEX DLIFPAGE 0 BYTESPERPAGE) (* ; "Interface Page") (COPYBYTES DBFILE DLFILEX) (* ; "Rest of Domino") (RPTQ (IDIFFERENCE (UNFOLD (SUB1 DLLASTDOMINOPAGE) BYTESPERPAGE) (IPLUS (GETFILEPTR DBFILE) BYTESPERPAGE)) (\BOUT DLFILEX 0)) (* ;  "(SETFILEPTR DLFILEX (UNFOLD (SUB1 DLLASTDOMINOPAGE) BYTESPERPAGE))") (SETFILEPTR DBFILE 0) (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE) (* ; "Replicate domino first page") ) (DLDUMPVMEMPAGES (ADD1 DLLASTDOMINOPAGE) (SUB1 (DLFPFROMRP \RP.FPTOVP))) (DLDUMPFPTOVP) (DLDUMPVMEMPAGES (IPLUS (DLFPFROMRP \RP.FPTOVP) %#FPTOVPPAGES) (SUB1 DLPAGEMAPFP)) (DLDUMPPAGEMAPS) (DLDUMPVMEMPAGES (IPLUS DLPAGEMAPFP \NumPMTpages (FOLDHI DLNEXTPM WORDSPERPAGE) \NumLPTPages) %#NEWFILEPAGES]) + +(DLDUMPFPTOVP [LAMBDA NIL (* ;  "Edited 4-Nov-92 13:56 by sybalsky:mv:envos") (printout T "[FPTOVP]") (* ;; "Filepages are one-based, but FPTOVP in the sysout is zero-based for convenience. Hence, first entry (page zero) is dummy") (\WOUT DLFILEX \NO.VMEM.PAGE) (* ;; "With BIG VM, each FPTOVP entry is 2 words, and word 1 (the 1st element of the array) is actually part of the entry for page 0 (which we dumped the other half above). So we need to dump 2*#pages + 1 elements of the array:") (DLDUMPARRAY FPTOVP (ADD1 (LLSH %#NEWFILEPAGES 1))) (RPTQ (IDIFFERENCE (UNFOLD %#FPTOVPPAGES WORDSPERPAGE) (LLSH (ADD1 %#NEWFILEPAGES) 1)) (\WOUT DLFILEX \NO.VMEM.PAGE)) (* ; "Fill out rest of FPTOVP with no such page. Fill from #pages*2 (it's cells now, not words per FPTOVP entry), out to the end of the FPTOVP pages.") NIL]) + +(DLDUMPPAGEMAPS [LAMBDA NIL (* ;  "Edited 3-Nov-92 10:47 by sybalsky:mv:envos") (printout T "[PageMaps]") (DLDUMPARRAY DLPRIMARYMAP (UNFOLD \NumPMTpages WORDSPERPAGE)) (* ; "Dump primary map") (DLDUMPARRAY DLSECONDARYMAP (CEIL DLNEXTPM WORDSPERPAGE)) (* ; "Dump secondary map") (DLDUMPARRAY DLLOCKBITS (UNFOLD \NumLPTPages WORDSPERPAGE)) (* ; "Dump locked page table") NIL]) + +(DLDUMPVMEMPAGES [LAMBDA (FIRSTFP LASTFP) (* ;  "Edited 2-Nov-92 12:30 by sybalsky:mv:envos") (for FP from FIRSTFP to LASTFP bind VP do (COND ((AND (NEQ [SETQ VP (FASTELTN FPTOVP (ADD1 (LLSH FP 1] \NO.VMEM.PAGE) (VMPAGEP VP)) (SETVMPTR (UNFOLD VP WORDSPERPAGE)) (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE) (PRIN1 '* T)) (T (\BOUTS DLFILEX DLPAGEOFZEROS 0 BYTESPERPAGE) (PRIN1 'x T]) + +(DLSETBOOTPTR [LAMBDA (FP) (* bvm%: "27-MAR-83 17:39") (printout T "[" .P2 FP "]") (SETFILEPTR DLFILEX (UNFOLD (SUB1 FP) BYTESPERPAGE]) + +(DLDUMPARRAY [LAMBDA (ARR NWORDS) (* ;  "Edited 3-Nov-92 11:52 by sybalsky:mv:envos") (* ;; "Dump NWORDS from array ARR, starting with the first byte in the array's contents.") (\BOUTS DLFILEX (fetch (ARRAYP BASE) of ARR) 0 (UNFOLD NWORDS BYTESPERWORD]) + +(DLMARKASDUMPED [LAMBDA (FIRSTFP NPAGES) (* ;  "Edited 2-Nov-92 12:30 by sybalsky:mv:envos") (for I from FIRSTFP to (IPLUS FIRSTFP NPAGES -1) do (FASTSETAN FPTOVP (LLSH I 1) \NO.VMEM.PAGE]) + +(DLDUMPVMEMPAGE [LAMBDA (NEWFP VP LOCKEDP) (* bvm%: "28-MAR-83 12:11") (COND ((VMPAGEP VP) (SETVMPTR (UNFOLD VP WORDSPERPAGE)) [PROG ((DESTINATIONBYTE (UNFOLD (SUB1 NEWFP) BYTESPERPAGE))) (COND ((NOT (IEQP (\GETFILEPTR DLFILEX) DESTINATIONBYTE)) (printout T "[" .P2 NEWFP "]") (SETFILEPTR DLFILEX DESTINATIONBYTE] (COPYBYTES VMEMFILE DLFILEX BYTESPERPAGE) (PRIN1 (COND (LOCKEDP '$) (T '*)) T)) (T (PRIN1 'x T]) + +(INSTALLDOMINO [LAMBDA (DBFILE) (* edited%: "14-APR-83 12:00") (DLSETBOOTPTR 1) (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE) (DLSETBOOTPTR (ADD1 \FP.IFPAGE)) (* Skip over InterfacePage) (COPYBYTES DBFILE DLFILEX) (* Copy rest of Domino) (DLSETBOOTPTR DLLASTDOMINOPAGE) (SETFILEPTR DBFILE 0) (* Copy first DB page into scratch at end of Domino reserved space so that  SYSOUT can get it (Dolphin and Dorado smash first page of vmem)) (COPYBYTES DBFILE DLFILEX 0 BYTESPERPAGE]) + +(INSTALLDOMINO.DIRECT [LAMBDA (DBFILE) (* bvm%: "29-JUL-83 16:16") (PROG [(BUFFER (COND ((IGREATERP \#SWAPBUFFERS 1) (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE \EMUSWAPBUFFERS WORDSPERPAGE)) (RESETSAVE \#SWAPBUFFERS (SUB1 \#SWAPBUFFERS)) \EMUSWAPBUFFERS) (T (RESETSAVE \EMUDISKBUFFERS (\ADDBASE \EMUDISKBUFFERS WORDSPERPAGE)) (RESETSAVE \#DISKBUFFERS (SUB1 \#DISKBUFFERS)) \EMUDISKBUFFERS] (replace ENDOFSTREAMOP of DBFILE with (FUNCTION ZERO)) (\BINS DBFILE BUFFER 0 BYTESPERPAGE) (COND ((EQ \MACHINETYPE \DANDELION) (\ACTONVMEMFILE 1 BUFFER 1 T))) (\BINS DBFILE BUFFER 0 BYTESPERPAGE) (* Skip over InterfacePage) (for I from (ADD1 \FP.IFPAGE) until (\EOFP DBFILE) do (\BINS DBFILE BUFFER 0 BYTESPERPAGE) (\ACTONVMEMFILE I BUFFER 1 T)) (* Copy rest of Domino) ]) + +(INSTALLNEWDOMINO [LAMBDA (SYSOUTFILE DBFILE) (* bvm%: "29-JUL-83 16:08") (RESETLST (SETQ DBFILE (GETSTREAM (OPENFILE (OR DBFILE (INFILEP '{DSK}DLISPDOMINO.DB) '{PHYLUM}DLION>BASICS>DLISPDOMINO.DB) 'INPUT) 'INPUT)) (RESETSAVE NIL (LIST 'CLOSEF DBFILE)) (PROG ((DBPAGES (IPLUS (FOLDHI (GETFILEINFO DBFILE 'LENGTH) BYTESPERPAGE) 2)) %#UCODEPAGES DLFILEX) (DECLARE (SPECVARS DLFILEX)) [COND [SYSOUTFILE [RESETSAVE NIL (LIST 'CLOSEF (SETQ SYSOUTFILE (OPENFILE SYSOUTFILE 'INPUT] (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE LastDominoFilePage ) of (\MAPPAGE 1 (GETSTREAM SYSOUTFILE] ((ASKUSER NIL NIL (LIST "Shall I install" (fetch FULLFILENAME of DBFILE) "directly into the vmem file")) (SETQ %#UCODEPAGES (SETQ DLLASTDOMINOPAGE (fetch (IFPAGE LastDominoFilePage) of \InterfacePage] (COND ((ILESSP %#UCODEPAGES DBPAGES) (RETURN "Not enough space for Domino"))) (COND (SYSOUTFILE (OPENFILE (CLOSEF SYSOUTFILE) 'BOTH) (SETQ DLFILEX (GETSTREAM SYSOUTFILE)) (INSTALLDOMINO DBFILE)) (T (INSTALLDOMINO.DIRECT DBFILE))) (RETURN SYSOUTFILE)))]) +) +(DEFINEQ + +(DLPRINTFPTOVP [LAMBDA (STREAM) (* bvm%: "28-MAR-83 12:42") (\PRINTFPTOVP (\ADDBASE (fetch (ARRAYP BASE) of FPTOVP) -1) (fetch (IFPAGE NActivePages) of DLIFPAGE) STREAM]) + +(PRINTPRIMARYMAP [LAMBDA NIL (* bvm%: "28-MAR-83 23:25") (for I from 0 to 63 do (printout T I ": " 8) [for J from 0 to 7 bind PMPE do (COND ((EQ [SETQ PMPE (ELT DLPRIMARYMAP (PLUS J (TIMES I 8] 65535) (printout T " -----")) (T (printout T .I6.8 PMPE] (TERPRI T) unless (for J from 0 to 7 always (EQ (ELT DLPRIMARYMAP (PLUS J (TIMES I 8))) 65535]) + +(DLREADPAGEOFWORDS [LAMBDA (STREAM) (* bvm%: "29-MAR-83 00:03") (to WORDSPERPAGE collect (\WIN STREAM]) + +(SETDIF [LAMBDA (X Y) (* bvm%: "28-MAR-83 15:28") (for EL in X collect EL unless (FMEMB EL Y]) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \NO.PAGE.ASSIGNED 0) + + +(CONSTANTS \NO.PAGE.ASSIGNED) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DLPRIMARYMAP DLSECONDARYMAP DLLOCKBITS DLLASTDOMINOPAGE DLIFPAGE DLNEXTPM DLPAGEMAPFP + FPTOVP NEWFPFROMOLD VMEMFILE VMEMFILEX) +) +(DECLARE%: DONTEVAL@LOAD EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + READSYS LLFAULT) + + +(CHECKIMPORTS '(MODARITH LLPARAMS) + T) +) +(PUTPROPS DLFIXINIT COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1990 1992 1998)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1368 25824 (DLFIXINIT 1378 . 3816) (DLSORTSYSOUTPAGES 3818 . 8944) (DLNEXTFP 8946 . +9283) (DLLOCKEDPAGEP 9285 . 9499) (DLSETLOCKBIT 9501 . 9763) (DLCOPYPAGEMAP 9765 . 12816) ( +DLCOPYVMPAGE 12818 . 13208) (DLADDPAGEMAPENTRIES 13210 . 14025) (ASSIGNFILEPAGE 14027 . 15260) ( +ASSIGNFILEPAGERANGE 15262 . 15669) (DLDUMPSYSOUT 15671 . 17682) (DLDUMPFPTOVP 17684 . 18723) ( +DLDUMPPAGEMAPS 18725 . 19425) (DLDUMPVMEMPAGES 19427 . 20083) (DLSETBOOTPTR 20085 . 20315) ( +DLDUMPARRAY 20317 . 20704) (DLMARKASDUMPED 20706 . 21159) (DLDUMPVMEMPAGE 21161 . 21849) ( +INSTALLDOMINO 21851 . 22498) (INSTALLDOMINO.DIRECT 22500 . 23652) (INSTALLNEWDOMINO 23654 . 25822)) ( +25825 27182 (DLPRINTFPTOVP 25835 . 26124) (PRINTPRIMARYMAP 26126 . 26840) (DLREADPAGEOFWORDS 26842 . +27009) (SETDIF 27011 . 27180))))) +STOP diff --git a/sources/DMISC b/sources/DMISC new file mode 100644 index 00000000..d770825e --- /dev/null +++ b/sources/DMISC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 15:53:57" {DSK}local>lde>lispcore>sources>DMISC.;3 45292 changes to%: (VARS DMISCCOMS) previous date%: " 6-Apr-90 10:59:19" {DSK}local>lde>lispcore>sources>DMISC.;2) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1982 but has not been published within the meaning of the copyright law, is furnished under license, and may not be used, copied and/or disclosed except in accordance with the terms of said license. ") (PRETTYCOMPRINT DMISCCOMS) (RPAQQ DMISCCOMS [[COMS (FNS BACKSPACEDEL) (DECLARE%: DOCOPY DONTEVAL@LOAD (P (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL] [COMS (FNS PERIODICALLYRECLAIM) (DECLARE%: DONTEVAL@LOAD DOCOPY [INITVARS (RECLAIMWAIT 4) (\LASTRECLAIM (\DAYTIME0 (NCREATE 'FIXP] (APPENDVARS (BACKGROUNDFNS PERIODICALLYRECLAIM) (\SYSTEMTIMERVARS (\LASTRECLAIM SECONDS] (COMS (FNS \DIRTYBACKGROUND \SAVEVMBACKGROUND COPYVM) (INITVARS (BACKGROUNDPAGEMIN 40) (BACKGROUNDPAGECNT 0) (BACKGROUNDPAGEFREQ 4)) (INITVARS (SAVINGCURSOR) (SAVEVMMAX 600) (SAVEVMWAIT 300)) (ADDVARS (BACKGROUNDFNS \DIRTYBACKGROUND) (TTYBACKGROUNDFNS \SAVEVMBACKGROUND)) (GLOBALVARS BACKGROUNDPAGEMIN BACKGROUNDPAGEFREQ BACKGROUNDPAGECNT)) (COMS (* ; "Setting the time") (FNS SETTIME)) [COMS (FNS RINGBELLS FLASHWINDOW PLAYTUNE) (DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer)) (INITRESOURCES \PlayTimer) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;  "Overrides definition in the shared MISC") (P (MOVD 'RINGBELLS 'PRINTBELLS] [COMS (* ; "Changing display") (FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE) (INITVARS (\VIDEORATE 'NORMAL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (BREAKRESETFORMS (SETDISPLAYHEIGHT T)) (RESETFORMS (SETDISPLAYHEIGHT T] (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (%#EOLCHARS 1)) [P (OR (LISTP (EVALV 'EDITCHARACTERS)) (RPAQ EDITCHARACTERS '(J X Z Y N))] (ADDVARS (POSTGREETFORMS (CNDIR)) (LISPUSERSDIRECTORIES))) [INITVARS (CLEANUPOPTIONS '(RC] (COMS (FNS DOAROUNDEXITFORMS) (ADDVARS (AROUNDEXITFNS DOAROUNDEXITFORMS) (BEFORELOGOUTFORMS) (AFTERLOGOUTFORMS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (ADVISEDFNS))) (COMS (* ; "Versions") (FNS REALMEMORYSIZE LISPVERSION MICROCODEVERSION BCPLVERSION REQUIREVERSION)) (COMS (* ; "Interlisp's apropos") (FNS APROPOS APROPRINT)) (COMS (* ; "Misc ops") (FNS READPRINTERPORT WRITEPRINTERPORT \READPRINTERPORT.UFN \WRITEPRINTERPORT.UFN \MISC1.UFN \MISC2.UFN \MISC3.UFN \MISC4.UFN \MISC5.UFN \MISC6.UFN \MISC7.UFN \MISC8.UFN \MISC10.UFN) (* ;  "sub-functions of floating-point ufns") (FNS \BLKFDIFF.UFN \BLKFPLUS.UFN \BLKFTIMES.UFN \BLKSEP.UFN \BLKPERM.UFN \BLKEXPONENT.UFN \BLKFLOATP2COMP.UFN \BLKSMALLP2FLOAT.UFN \BLKMAG.UFN \FLOATTOBYTE.UFN \BLKFMAX.UFN \BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN) (* ; "functions for the 4045") (FNS \P-MISC2.UFN \LINES-EQUAL-P \GET-NEXT-RUN) (FNS IBLT1 IBLT2)) (VARS RINGBELLS.L1 RINGBELLS.L2) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \DIRTYBACKGROUND]) (DEFINEQ (BACKSPACEDEL [LAMBDA (TTBL) (* lmm "24-JUN-80 23:16") (* ;; "Hack for causing char-delete to backspace display. Also suppress ## when reach the left margin. --- This should be executed after the chardelete in TTBL has been established. --- ERASECHARCODE is in INITCONSTANTS on LLPARAMS") (DELETECONTROL '1STCHDEL (CHARACTER ERASECHARCODE) TTBL) (DELETECONTROL 'NTHCHDEL (CHARACTER ERASECHARCODE) TTBL) (DELETECONTROL 'POSTCHDEL "" TTBL) (DELETECONTROL 'EMPTYCHDEL "" TTBL) (DELETECONTROL 'NOECHO NIL TTBL) (ECHOCONTROL ERASECHARCODE 'REAL]) ) (DECLARE%: DOCOPY DONTEVAL@LOAD (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) ) (DEFINEQ (PERIODICALLYRECLAIM [LAMBDA NIL (* bvm%: " 4-Nov-85 17:21") (DECLARE (GLOBALVARS \RECLAIM.COUNTDOWN \LASTUSERACTION RECLAIMWAIT \LASTRECLAIM)) (if (AND \RECLAIM.COUNTDOWN (\SECONDSCLOCKGREATERP \LASTUSERACTION RECLAIMWAIT) (\SECONDSCLOCKGREATERP \LASTRECLAIM RECLAIMWAIT)) then (RECLAIM) (\DAYTIME0 \LASTRECLAIM]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? RECLAIMWAIT 4) (RPAQ? \LASTRECLAIM (\DAYTIME0 (NCREATE 'FIXP))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) ) (DEFINEQ (\DIRTYBACKGROUND [LAMBDA NIL (* lmm "14-AUG-83 16:08") (DECLARE (GLOBALVARS SAVEVMMAX \LASTUSERACTION SAVEVMWAIT SAVINGCURSOR \DIRTYPAGEHINT)) (COND ((AND BACKGROUNDPAGEFREQ (ILEQ (add BACKGROUNDPAGECNT -1) 0)) (\WRITEDIRTYPAGE BACKGROUNDPAGEMIN) (SETQ BACKGROUNDPAGECNT BACKGROUNDPAGEFREQ]) (\SAVEVMBACKGROUND [LAMBDA NIL (* bvm%: "14-Feb-85 23:27") (COND ((AND (ILESSP \DIRTYPAGEHINT SAVEVMMAX) (NEQ (fetch (IFPAGE Key) of \InterfacePage) \IFPValidKey) (FIXP SAVEVMWAIT) (\SECONDSCLOCKGREATERP \LASTUSERACTION SAVEVMWAIT)) (COND ((AND (ILESSP (SETQ \DIRTYPAGEHINT (\COUNTREALPAGES 'DIRTY)) SAVEVMMAX) (\FLUSHVMOK? 'SAVEVM T)) (* ; "Recalculate the hint before deciding it's okay") (RESETLST (AND SAVINGCURSOR (GETD 'CURSOR) (RESETSAVE (CURSOR SAVINGCURSOR))) (SAVEVM]) (COPYVM [LAMBDA (FILE) (* bvm%: "12-Jan-84 12:07") (DECLARE (GLOBALVARS \VMEM.INHIBIT.WRITE)) (RESETVARS ((\VMEM.INHIBIT.WRITE T)) (RETURN (COND ((EQ (fetch (IFPAGE Key) of \InterfacePage) \IFPValidKey) (\COPYSYS FILE NIL T)) (T "Can't--virtual memory has been written to"]) ) (RPAQ? BACKGROUNDPAGEMIN 40) (RPAQ? BACKGROUNDPAGECNT 0) (RPAQ? BACKGROUNDPAGEFREQ 4) (RPAQ? SAVINGCURSOR ) (RPAQ? SAVEVMMAX 600) (RPAQ? SAVEVMWAIT 300) (ADDTOVAR BACKGROUNDFNS \DIRTYBACKGROUND) (ADDTOVAR TTYBACKGROUNDFNS \SAVEVMBACKGROUND) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BACKGROUNDPAGEMIN BACKGROUNDPAGEFREQ BACKGROUNDPAGECNT) ) (* ; "Setting the time") (DEFINEQ (SETTIME [LAMBDA (DT) (* bvm%: "26-Jul-84 15:32") (if (OR (AND (NULL DT) (\NET.SETTIME)) (PROG [(IDT (AND DT (LISP.TO.ALTO.DATE (OR (IDATE DT) (ERROR "Invalid date" DT] RETRY [COND ((NOT IDT) (printout T "Enter date and time as string in double quotes: ") (COND ([SETQ IDT (IDATE (OR (SETQ DT (READ T T)) (RETURN "time not set"] (SETQ IDT (LISP.TO.ALTO.DATE IDT))) (T (printout T "Sorry, couldn't parse that" T) (GO RETRY] (\SETDAYTIME0 (COND ((SMALLP IDT) (create FIXP HINUM _ 0 LONUM _ IDT)) (T IDT))) (RETURN T))) then (DATE (DATEFORMAT TIME.ZONE]) ) (DEFINEQ (RINGBELLS [LAMBDA (N) (* ; "Edited 10-May-88 23:01 by MASINTER") (DECLARE (GLOBALVARS RINGBELLS.L1 RINGBELLS.L2)) (OR (FIXP N) (SETQ N 1)) (SELECTC \MACHINETYPE ((LIST \DAYBREAK \DANDELION \MAIKO) (to N do (PLAYTUNE RINGBELLS.L1) (FLASHWINDOW NIL NIL 100) (PLAYTUNE RINGBELLS.L2))) (FLASHWINDOW NIL N]) (FLASHWINDOW [LAMBDA (WIN? N FLASHINTERVAL SHADE) (* bvm%: "16-Jul-85 12:20") (* ; "This is an 'attention getting' action.") (* ; "rrb --- added shade argument so contrast of flash could be explored.") (OR (FIXP N) (SETQ N 1)) (OR (FIXP FLASHINTERVAL) (SETQ FLASHINTERVAL 200)) [COND ((WINDOWP WIN?) (SETQ WIN? (GETSTREAM WIN? 'OUTPUT] (for I to N bind (WHOLEP _ (NOT (DISPLAYSTREAMP WIN?))) COLORP first [COND (WHOLEP (SETQ COLORP (NULL (VIDEOCOLOR] do (UNINTERRUPTABLY (* ; "Open-coded 'during' loops so that no one else can sneak in and steal cycles") (COND [WHOLEP (* ; "Flash the whole screen") (VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP) (DISMISS FLASHINTERVAL NIL T] (T (* ;; "Although VIDEOCOLOR is nearly instantaneous, INVERTW may require a time approaching the interval time and thus this path could be much longer") (INVERTW WIN? SHADE) (DISMISS FLASHINTERVAL NIL T) (INVERTW WIN? SHADE)))) (COND ((NEQ I N) (BLOCK 250]) (PLAYTUNE [LAMBDA (TUNEPAIRS) (* ; "Edited 10-May-88 22:52 by MASINTER") (* ;;; "TUNEPAIRS is a list of (frequency . duration), where duration is (unfortunately) expressed in Dandelion Ticks (1/ \DLION.RCLKMILLISECOND) milliseconds") (SELECTC \MACHINETYPE ((LIST \DAYBREAK \MAIKO \DANDELION) (CL:UNWIND-PROTECT [for X in TUNEPAIRS do (COND ((CAR X) (BEEPON (CAR X))) (T (BEEPOFF))) (LET [(\DurationLimit (SETUPTIMER (if (EQ \RCLKMILLISECOND \DLION.RCLKMILLISECOND) then (CDR X) else (IQUOTIENT (ITIMES (CDR X) \RCLKMILLISECOND) \DLION.RCLKMILLISECOND) ) NIL 'TICKS] (until (TIMEREXPIRED? \DurationLimit 'TICKS) do (BLOCK] (BEEPOFF)) T) NIL]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\PlayTimer 'RESOURCES '(NEW (SETUPTIMER 0] ) ) (/SETTOPVAL '\\PlayTimer.GLOBALRESOURCE NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD 'RINGBELLS 'PRINTBELLS) ) (* ; "Changing display") (DEFINEQ (DISPLAYDOWN [LAMBDA (FORM NSCANLINES) (* rrb "27-MAR-82 12:23") (* ; "evaluates form with the number of scan lines set down.") (RESETFORM (SETDISPLAYHEIGHT (OR (SMALLP NSCANLINES) 0)) (EVAL FORM]) (SETDISPLAYHEIGHT [LAMBDA (NSCANLINES) (DECLARE (GLOBALVARS \DisplayStarted \EM.DISPLAYHEAD)) (* MPL "28-Jul-85 01:32") (* ;; "sets the number of scan lines to be displayed. returns previous setting.") (* ; "the number of lines in the dcb is 1/2 of the total. High bit is on to indicate long pointers.") (COND ((OR (EQ \MACHINETYPE \DOLPHIN) (EQ \MACHINETYPE \DORADO)) (OR \DisplayStarted (HELP "Display must be initialized.")) (AND \EM.DISPLAYHEAD (PROG [(MAGICADDR (EMPOINTER (IPLUS (\GETBASE \EM.DISPLAYHEAD 0) 3] (RETURN (PROG1 (ITIMES [LOGAND (\GETBASE MAGICADDR 0) (CONSTANT (SUB1 (EXPT 2 (SUB1 BITSPERWORD ] 2) (* ; "number of dcb lines may need to be even.") (COND (NSCANLINES (COND [(SMALLP NSCANLINES) (COND ((IGREATERP 0 NSCANLINES) (\ILLEGAL.ARG NSCANLINES)) ((IGREATERP NSCANLINES SCREENHEIGHT) (SETQ NSCANLINES SCREENHEIGHT] ((EQ NSCANLINES T) (SETQ NSCANLINES SCREENHEIGHT)) (T (\ILLEGAL.ARG NSCANLINES))) (\PUTBASE MAGICADDR 0 (LOGOR (ITIMES (LRSH NSCANLINES 2) 2) (CONSTANT (EXPT 2 (SUB1 BITSPERWORD ]) (VIDEORATE [LAMBDA (TYPE) (* bvm%: " 7-NOV-83 17:28") (DECLARE (GLOBALVARS \VIDEORATE)) (PROG1 \VIDEORATE (* ; "Return old setting") (AND TYPE (SETQ \VIDEORATE (SELECTC \MACHINETYPE (\DOLPHIN (SELECTQ TYPE ((NORMAL 77) (\DSPRATE 9 0 0) 'NORMAL) ((TAPE 60) (\DSPRATE 139 0 0) 'TAPE) (\ILLEGAL.ARG TYPE))) (\DORADO (SELECTQ TYPE ((NORMAL 77) (\DSPRATE 18 14 430) 'NORMAL) ((TAPE 60) (\DSPRATE 18 14 560) 'TAPE) ((PHILLIPS TAPEP) (\DSPRATE 58 25 520) 'PHILLIPS) (\ILLEGAL.ARG TYPE))) (\DANDELION (SELECTQ TYPE ((NORMAL 77) (\DEVICE.OUTPUT 14 7) 'NORMAL) ((TAPE 60) (\DEVICE.OUTPUT 142 7) 'TAPE) (\ILLEGAL.ARG TYPE))) 'NORMAL]) ) (RPAQ? \VIDEORATE 'NORMAL) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR BREAKRESETFORMS (SETDISPLAYHEIGHT T)) (ADDTOVAR RESETFORMS (SETDISPLAYHEIGHT T)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ %#EOLCHARS 1) [OR (LISTP (EVALV 'EDITCHARACTERS)) (RPAQ EDITCHARACTERS '(J X Z Y N))] (ADDTOVAR POSTGREETFORMS (CNDIR)) (ADDTOVAR LISPUSERSDIRECTORIES ) ) (RPAQ? CLEANUPOPTIONS '(RC)) (DEFINEQ (DOAROUNDEXITFORMS [LAMBDA (EVENT) (* JonL "13-Sep-84 13:42") (* ;; "For backward compatibility, handle the xxxFORMS that used to be in advise around LOGOUT, SYSOUT, MAKESYS") (for $$FORM in (SELECTQ EVENT (BEFORELOGOUT BEFORELOGOUTFORMS) (AFTERLOGOUT AFTERLOGOUTFORMS) (BEFORESYSOUT BEFORESYSOUTFORMS) (AFTERSYSOUT AFTERSYSOUTFORMS) (BEFOREMAKESYS BEFOREMAKESYSFORMS) (AFTERMAKESYS AFTERMAKESYSFORMS) NIL) do (ERSETQ (\EVAL $$FORM]) ) (ADDTOVAR AROUNDEXITFNS DOAROUNDEXITFORMS) (ADDTOVAR BEFORELOGOUTFORMS ) (ADDTOVAR AFTERLOGOUTFORMS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? ADVISEDFNS ) ) (* ; "Versions") (DEFINEQ (REALMEMORYSIZE [LAMBDA NIL (* bvm%: "19-JAN-83 17:06") (fetch NRealPages of \InterfacePage]) (LISPVERSION [LAMBDA NIL (* bvm%: "19-JAN-83 17:07") (fetch LVersion of \InterfacePage]) (MICROCODEVERSION [LAMBDA NIL (* bvm%: "19-JAN-83 17:07") (fetch RVersion of \InterfacePage]) (BCPLVERSION [LAMBDA NIL (* bvm%: "19-JAN-83 17:07") (fetch BVersion of \InterfacePage]) (REQUIREVERSION [LAMBDA (LISP MICROCODE BCPL) (* bvm%: "19-JAN-83 17:15") (PROG (TYPE NEEDED) (RETURN (COND ([SETQ TYPE (OR (AND LISP (LESSP (fetch LVersion of \InterfacePage) (SETQ NEEDED LISP)) 'LISP) (AND MICROCODE (LESSP (fetch RVersion of \InterfacePage) (SETQ NEEDED MICROCODE)) 'MICROCODE) (AND BCPL (LESSP (fetch BVersion of \InterfacePage) (SETQ NEEDED BCPL)) 'BCPL] (ERROR (CONCAT "This " TYPE " version is too old. The minimum version required is ") NEEDED) NIL) (T T]) ) (* ; "Interlisp's apropos") (DEFINEQ (APROPOS [LAMBDA (STRING ALLFLG QUIETFLG OUTPUT CASEXACT) (* bvm%: "19-Mar-86 16:09") (PROG ((FILTERFN (AND ALLFLG (NEQ ALLFLG T) (FNTYP ALLFLG) ALLFLG)) [DISPLAYSTREAM (AND (NOT QUIETFLG) (DISPLAYSTREAMP (SETQ OUTPUT (GETSTREAM (OR OUTPUT T) 'OUTPUT] (BLOCKCOUNT 32) (CASEARRAY (AND (NOT CASEXACT) UPPERCASEARRAY)) RESULT) (DECLARE (SPECVARS RESULT FILTERFN DISPLAYSTREAM)) [RESETFORM (PRINTLEVEL 3 5) (MAPATOMS (FUNCTION (LAMBDA (ATOM) (PROG (VAL) (DECLARE (USEDFREE RESULT BLOCKCOUNT FILTERFN)) (COND ((EQ 0 (SETQ BLOCKCOUNT (SUB1 BLOCKCOUNT))) (SETQ BLOCKCOUNT 32) (BLOCK))) (COND ([COND (FILTERFN (AND (STRPOS STRING ATOM NIL NIL NIL NIL CASEARRAY) (APPLY* FILTERFN ATOM))) (T (AND (OR ALLFLG (GETD ATOM) (GETPROPLIST ATOM) (NEQ (GETTOPVAL ATOM) 'NOBIND)) (STRPOS STRING ATOM NIL NIL NIL NIL CASEARRAY) (OR ALLFLG (AND (NOT (GENSYM? ATOM)) (NEQ (CHCON1 ATOM) (CHARCODE \)) (NOT (\SUBFNDEF ATOM] (COND (QUIETFLG (push RESULT ATOM)) (T (COND ((OR (GETD ATOM) (GETPROPLIST ATOM) (NEQ (GETTOPVAL ATOM) 'NOBIND)) (FRESHLINE OUTPUT))) (PRINTOUT OUTPUT |.P2| ATOM %,) (COND ((GETD ATOM) (APROPRINT "function:" (ARGLIST ATOM) OUTPUT))) (COND ((NEQ (SETQ VAL (GETTOPVAL ATOM)) 'NOBIND) (APROPRINT "value: " VAL OUTPUT))) (COND ((SETQ VAL (GETPROPLIST ATOM)) (APROPRINT "proplist:" VAL OUTPUT] (RETURN RESULT]) (APROPRINT [LAMBDA (STRING VALUE FILE) (* bvm%: "16-Jul-85 12:04") (printout FILE .TAB0 20 "-" STRING %,) (COND ((IMAGESTREAMP FILE) (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPLEFTMARGIN) (DSPLEFTMARGIN (DSPXPOSITION NIL FILE) FILE) FILE)) (POSITION FILE 0) (PRIN2 VALUE FILE T))) (T (PRIN2 VALUE FILE))) (FRESHLINE FILE]) ) (* ; "Misc ops") (DEFINEQ (READPRINTERPORT [LAMBDA NIL (* bvm%: "18-JAN-83 18:06") ((OPCODES READPRINTERPORT]) (WRITEPRINTERPORT [LAMBDA (DATUM) (* bvm%: "18-JAN-83 18:06") ((OPCODES WRITEPRINTERPORT) DATUM]) (\READPRINTERPORT.UFN [LAMBDA NIL (* hdj "16-Sep-84 21:37") (if (EQ \MACHINETYPE \DANDELION) then (\DEVICE.INPUT 7]) (\WRITEPRINTERPORT.UFN [LAMBDA (DATUM) (* hdj "16-Sep-84 21:45") (if (EQ \MACHINETYPE \DANDELION) then (\DEVICE.OUTPUT DATUM 14]) (\MISC1.UFN [LAMBDA (ARG ALPHA) (* kbr%: "12-Jul-85 17:14") (RAID "Illegal op to \MISC1.UFN -- " ALPHA]) (\MISC2.UFN [LAMBDA (ARG1 ARG2 ALPHA) (* ; "Edited 14-Jul-87 13:34 by Snow") (SELECTQ ALPHA (0 (\GET-NEXT-RUN ARG1 ARG2)) (RAID "Illegal op to \MISC2.UFN -- " ALPHA]) (\MISC3.UFN [LAMBDA (ARG1 ARG2 ARG3 ALPHA) (* ; "Edited 14-Jul-87 10:33 by Snow") (SELECTQ ALPHA (0 (\BLKEXPONENT.UFN ARG1 ARG2 ARG3)) (1 (\BLKMAG.UFN ARG1 ARG2 ARG3)) (2 (\BLKSMALLP2FLOAT.UFN ARG1 ARG2 ARG3)) (3 (\BLKFLOATP2COMP.UFN ARG1 ARG2 ARG3)) (4 (\BLKFMAX.UFN ARG1 ARG2 ARG3)) (5 (\BLKFMIN.UFN ARG1 ARG2 ARG3)) (6 (\BLKFABSMAX.UFN ARG1 ARG2 ARG3)) (7 (\BLKFABSMIN.UFN ARG1 ARG2 ARG3)) (8 (\FLOATTOBYTE.UFN ARG1 ARG2 ARG3)) (9 (%%SLOW-ARRAY-READ ARG1 ARG2 ARG3)) (10 (\LINES-EQUAL-P ARG1 ARG2 ARG3)) (RAID "Illegal op to \MISC3.UFN --" ALPHA]) (\MISC4.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ALPHA) (* ; "Edited 9-Apr-87 15:18 by jop") (SELECTQ ALPHA (0 (\BLKFTIMES.UFN ARG1 ARG2 ARG3 ARG4)) (1 (\BLKPERM.UFN ARG1 ARG2 ARG3 ARG4)) (2 (\BLKFPLUS.UFN ARG1 ARG2 ARG3 ARG4)) (3 (\BLKFDIFF.UFN ARG1 ARG2 ARG3 ARG4)) (4 (\BLKSEP.UFN ARG1 ARG2 ARG3 ARG4)) (6 (\BITMAPBIT ARG1 ARG2 ARG3 ARG4)) (7 (%%SLOW-ARRAY-WRITE ARG1 ARG2 ARG3 ARG4)) (RAID "Illegal op to \MISC4.UFN -- " ALPHA]) (\MISC5.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ALPHA) (* kbr%: "12-Jul-85 17:05") (RAID "Illegal op to \MISC5.UFN -- " ALPHA]) (\MISC6.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ALPHA) (* ; "Edited 5-Oct-89 18:59 by jds") (SELECTQ ALPHA (0 (\FBITMAPBIT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6)) (RAID "Illegal op to \MISC6.UFN -- " ALPHA]) (\MISC7.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ALPHA) (* ; "Edited 6-Oct-89 09:44 by jds") (SELECTQ ALPHA (0 (\PSEUDOCOLOR.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7)) (1 (* ;; "Fast turn a bitmap bit on, off, or invert it.") (* ;; "(\FASTBITMAPBIT BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH)") (\FBITMAPBIT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6)) (RAID "Illegal op to \MISC7.UFN -- " ALPHA]) (\MISC8.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ALPHA) (* hdj "26-Feb-85 11:56") (SELECTQ ALPHA (0 (IBLT1 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8)) (1 (IBLT2 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8)) (RAID "Illegal op to \MISC8.UFN --" ALPHA]) (\MISC10.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10 ALPHA) (* kbr%: "12-Jul-85 17:16") (SELECTQ ALPHA (0 (\PIXELBLT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10)) (HELP "Illegal op to \MISC10.UFN -- " ALPHA]) ) (* ; "sub-functions of floating-point ufns") (DEFINEQ (\BLKFDIFF.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* hdj "20-Sep-84 12:35") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FDIFFERENCE (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKFPLUS.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* ; "Edited 8-Jan-87 16:27 by jop") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FPLUS (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKFTIMES.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* ; "Edited 8-Jan-87 16:25 by jop") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FTIMES (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKSEP.UFN [LAMBDA (SOURCE1 SOURCE2 DEST CNT) (* ; "Edited 8-Jan-87 16:27 by jop") (for ALPHAINDEX from 0 to (LLSH (SUB1 CNT) 1) by 8 bind BETAINDEX GAMMAINDEX DELTAINDEX do (SETQ BETAINDEX (IDIFFERENCE CNT ALPHAINDEX)) (SETQ GAMMAINDEX (IPLUS ALPHAINDEX 2)) (SETQ DELTAINDEX (IPLUS BETAINDEX 2)) (\PUTBASEFLOATP DEST ALPHAINDEX (FPLUS (\GETBASEFLOATP SOURCE1 ALPHAINDEX) (\GETBASEFLOATP SOURCE2 BETAINDEX))) (\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 2) (FDIFFERENCE (\GETBASEFLOATP SOURCE1 GAMMAINDEX) (\GETBASEFLOATP SOURCE2 DELTAINDEX))) (\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 4) (FPLUS (\GETBASEFLOATP SOURCE1 GAMMAINDEX) (\GETBASEFLOATP SOURCE2 DELTAINDEX))) (\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 6) (FDIFFERENCE (\GETBASEFLOATP SOURCE1 ALPHAINDEX) (\GETBASEFLOATP SOURCE2 BETAINDEX]) (\BLKPERM.UFN [LAMBDA (ORIG PERMUTATIONS DEST CNT) (* ; "Edited 8-Jan-87 16:26 by jop") (* ;; "destination (x) _ orig (perm (x))") (* ;; "args are arrays of smallps (words)") (* ;; "must fold initial into offset for compatibility with microcode") (for X from 0 to (SUB1 CNT) do (\PUTBASE DEST X (\GETBASE ORIG (\GETBASE PERMUTATIONS X]) (\BLKEXPONENT.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 15:45 by jop") (* ;;; "extract the exponent of each element of source, stick it in destination") (for X from 0 to (SUB1 CNT) do (\PUTBASE DEST X (fetch (FLOATP EXPONENT) of (\GETBASEFLOATP SOURCE (LLSH X 1]) (\BLKFLOATP2COMP.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 16:03 by jop") (* ;; "moves the contents of a Real array into a Complex array; sets imaginary part to 0") (for I from 0 to (SUB1 CNT) do (LET [($$BASE (\ADDBASE DEST (LLSH I 2] (\PUTBASEFLOATP $$BASE 0 (\GETBASEFLOATP SOURCE (LLSH I 1))) (\PUTBASEFLOATP $$BASE 2 0.0]) (\BLKSMALLP2FLOAT.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 15:50 by jop") (* ;; "convert an array of SMALLPs to FLOATPs") (for I from 0 to (SUB1 CNT) do (\PUTBASEFLOATP DEST (LLSH I 1) (FLOAT (\GETBASE SOURCE I]) (\BLKMAG.UFN [LAMBDA (COMPLEX-ARRAY MAGNITUDE-ARRAY CNT) (* ; "Edited 8-Jan-87 15:48 by jop") (bind COMPLEX-CNT REAL IMAG declare (TYPE FLOAT REAL IMAG) for MAGNITUDE from 0 to (SUB1 CNT) do (SETQ COMPLEX-CNT (LLSH MAGNITUDE 2)) (SETQ REAL (\GETBASEFLOATP COMPLEX-ARRAY COMPLEX-CNT)) (SETQ IMAG (\GETBASEFLOATP COMPLEX-ARRAY (IPLUS COMPLEX-CNT 2))) (\PUTBASEFLOATP MAGNITUDE-ARRAY (LLSH MAGNITUDE 1) (FPLUS (FTIMES REAL REAL) (FTIMES IMAG IMAG]) (\FLOATTOBYTE.UFN [LAMBDA (SBASE DBASE CNT) (* ; "Edited 8-Jan-87 16:17 by jop") (for I from 0 to (SUB1 (LRSH CNT 1)) do (\PUTBASE DBASE I (LOGOR (LLSH [FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE (LLSH I 2] 8) (FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE (IPLUS 2 (LLSH I 2]) (\BLKFMAX.UFN [LAMBDA (BASE ZERO CNT) (LET ((IDX 0) (MX (\GETBASEFLOATP BASE 0))) [for I from 0 to (SUB1 CNT) do (if [NOT (GREATERP MX (\GETBASEFLOATP BASE (IPLUS I I] then (SETQ IDX I) (SETQ MX (\GETBASEFLOATP BASE (IPLUS IDX IDX] IDX]) (\BLKFMIN.UFN [LAMBDA (BASE ZERO CNT) (LET ((IDX 0) (MN (\GETBASEFLOATP BASE 0))) [for I from 0 to (SUB1 CNT) do (if [NOT (LESSP MN (\GETBASEFLOATP BASE (IPLUS I I] then (SETQ IDX I) (SETQ MN (\GETBASEFLOATP BASE (IPLUS IDX IDX] IDX]) (\BLKFABSMAX.UFN [LAMBDA (BASE ZERO CNT) (LET ((IDX 0) (MX (\GETBASEFLOATP BASE 0))) [for I from 0 to (SUB1 CNT) do (if [NOT (GREATERP MX (FABS (\GETBASEFLOATP BASE (IPLUS I I] then (SETQ IDX I) (SETQ MX (FABS (\GETBASEFLOATP BASE (IPLUS IDX IDX] IDX]) (\BLKFABSMIN.UFN [LAMBDA (BASE ZERO CNT) (LET ((IDX 0) (MN (\GETBASEFLOATP BASE 0))) [for I from 0 to (SUB1 CNT) do (if [NOT (LESSP MN (FABS (\GETBASEFLOATP BASE (IPLUS I I] then (SETQ IDX I) (SETQ MN (FABS (\GETBASEFLOATP BASE (IPLUS IDX IDX] IDX]) ) (* ; "functions for the 4045") (DEFINEQ (\P-MISC2.UFN [LAMBDA (ARG1 ARG2 ALPHA) (* ; "Edited 24-Jul-87 10:46 by Snow") (SELECTQ ALPHA (0 (\GET-NEXT-RUN ARG1 ARG2)) (RAID "Illegal op to \P-MISC2.UFN --" ALPHA]) (\LINES-EQUAL-P [LAMBDA (LAST-LINE CURRENT-LINE WORDS-PER-RASTER) (* ; "Edited 14-Jul-87 10:35 by Snow") (* ;; "Check if two raster lines have the same bytes") (CL:DOTIMES (I WORDS-PER-RASTER T) (CL:IF (NOT (EQ (\GETBASE LAST-LINE I) (\GETBASE CURRENT-LINE I))) (RETURN NIL]) (\GET-NEXT-RUN [LAMBDA (START MAX) (* ; "Edited 21-Jul-87 17:35 by Snow") (* ;; "Assume max > 0") (CL:IF (EQ MAX 0) (CL:ERROR "Max must be > 0: ~s" MAX)) (LET ((RUN-LENGTH 1) (OFFSET 0)) (CL:LOOP (* ;; "Find the next run ") [CL:DO ((INDEX (CL:1+ OFFSET) (CL:1+ INDEX)) (MATCHER (\GETBASE START OFFSET))) ((EQ INDEX MAX) (CL:WHEN (EQ RUN-LENGTH 1) (SETQ RUN-LENGTH 0) (SETQ OFFSET MAX))) (CL:IF (EQ MATCHER (\GETBASE START INDEX)) (CL:INCF RUN-LENGTH) (CL:IF (> RUN-LENGTH 1) (RETURN NIL) (RETURN (SETQ OFFSET INDEX] (CL:IF (OR (EQ OFFSET MAX) (> RUN-LENGTH 1)) (RETURN NIL))) (+ (CL:ASH OFFSET 8) RUN-LENGTH]) ) (DEFINEQ (IBLT1 [LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount) (* hdj " 2-Jul-84 17:52") (* ;;; "ValueArray --- an array of 128 elements, 8 bits each") (* ;;; "TextureArray --- an array of 256 elements, each a texture") (* ;;; "XCoord --- bit offset from left of destination bitmap") (* ;;; "BitmapAddr --- destination") (* ;;; "BitmapWidth --- width of dest bitmap in words") (* ;;; "ValHeight --- height of bar") (* ;;; "ValWidth --- width of bar") (* ;;; "Kount --- how many elements of ValueArray to graph") (PROG (TEXTURE (BITMAPOFFSET BitmapAddr)) (for val from (SUB1 Kount) to 0 by -1 do (SETQ TEXTURE (\GETBASE TextureArray (\GETBASE ValueArray val))) (for X from 1 to ValHeight do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth TEXTURE) (SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET BitmapWidth]) (IBLT2 [LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount) (* hdj "20-Sep-84 12:20") (* ;;; "Steps by 2, as opposed to IBLT1, which steps by 1") (* ;;; "ValueArray --- an array of 128 elements, 8 bits each") (* ;;; "TextureArray --- an array of 256 elements, each a texture") (* ;;; "XCoord --- bit offset from left of destination bitmap") (* ;;; "BitmapAddr --- destination") (* ;;; "BitmapWidth --- width of dest bitmap in words") (* ;;; "ValHeight --- height of bar") (* ;;; "ValWidth --- width of bar") (* ;;; "Kount --- how many elements of ValueArray to graph") (PROG (TEXTURE (BITMAPOFFSET BitmapAddr)) (for val from (SUB1 Kount) to 0 by -2 do (SETQ TEXTURE (\GETBASE TextureArray (\GETBASE ValueArray val))) (for X from 1 to ValHeight do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth TEXTURE) (SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET BitmapWidth]) ) (RPAQQ RINGBELLS.L1 ((1000 . 1000) (800 . 1000) (600 . 1000) (500 . 1000) (400 . 1000) (NIL . 500) (440 . 1000) (484 . 1000) (540 . 1000) (600 . 1000))) (RPAQQ RINGBELLS.L2 ((2000 . 1000) (1600 . 1000) (1200 . 1000) (1000 . 1000) (800 . 1000) (NIL . 500) (880 . 1000) (968 . 1000) (1080 . 1000) (1188 . 1000))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \DIRTYBACKGROUND) ) (PUTPROPS DMISC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4791 5494 (BACKSPACEDEL 4801 . 5492)) (5589 6022 (PERIODICALLYRECLAIM 5599 . 6020)) ( 6252 7943 (\DIRTYBACKGROUND 6262 . 6684) (\SAVEVMBACKGROUND 6686 . 7470) (COPYVM 7472 . 7941)) (8364 9563 (SETTIME 8374 . 9561)) (9564 13243 (RINGBELLS 9574 . 10067) (FLASHWINDOW 10069 . 11645) (PLAYTUNE 11647 . 13241)) (13505 19037 (DISPLAYDOWN 13515 . 13903) (SETDISPLAYHEIGHT 13905 . 16705) (VIDEORATE 16707 . 19035)) (19461 20182 (DOAROUNDEXITFORMS 19471 . 20180)) (20385 22100 (REALMEMORYSIZE 20395 . 20553) (LISPVERSION 20555 . 20708) (MICROCODEVERSION 20710 . 20868) (BCPLVERSION 20870 . 21023) ( REQUIREVERSION 21025 . 22098)) (22137 26715 (APROPOS 22147 . 26163) (APROPRINT 26165 . 26713)) (26741 30649 (READPRINTERPORT 26751 . 26892) (WRITEPRINTERPORT 26894 . 27049) (\READPRINTERPORT.UFN 27051 . 27240) (\WRITEPRINTERPORT.UFN 27242 . 27440) (\MISC1.UFN 27442 . 27595) (\MISC2.UFN 27597 . 27835) ( \MISC3.UFN 27837 . 28570) (\MISC4.UFN 28572 . 29122) (\MISC5.UFN 29124 . 29277) (\MISC6.UFN 29279 . 29529) (\MISC7.UFN 29531 . 30016) (\MISC8.UFN 30018 . 30319) (\MISC10.UFN 30321 . 30647)) (30703 38152 (\BLKFDIFF.UFN 30713 . 31278) (\BLKFPLUS.UFN 31280 . 31852) (\BLKFTIMES.UFN 31854 . 32429) ( \BLKSEP.UFN 32431 . 33562) (\BLKPERM.UFN 33564 . 34033) (\BLKEXPONENT.UFN 34035 . 34445) ( \BLKFLOATP2COMP.UFN 34447 . 35031) (\BLKSMALLP2FLOAT.UFN 35033 . 35392) (\BLKMAG.UFN 35394 . 36045) ( \FLOATTOBYTE.UFN 36047 . 36626) (\BLKFMAX.UFN 36628 . 37020) (\BLKFMIN.UFN 37022 . 37411) ( \BLKFABSMAX.UFN 37413 . 37782) (\BLKFABSMIN.UFN 37784 . 38150)) (38192 40010 (\P-MISC2.UFN 38202 . 38443) (\LINES-EQUAL-P 38445 . 38829) (\GET-NEXT-RUN 38831 . 40008)) (40011 44190 (IBLT1 40021 . 42023 ) (IBLT2 42025 . 44188))))) STOP \ No newline at end of file diff --git a/sources/DOVEDECLS b/sources/DOVEDECLS new file mode 100644 index 00000000..442721cf --- /dev/null +++ b/sources/DOVEDECLS @@ -0,0 +1,397 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 15:55:59" {DSK}local>lde>lispcore>sources>DOVEDECLS.;2 15966 + + changes to%: (VARS DOVEDECLSCOMS) + + previous date%: "31-Mar-86 11:10:09" {DSK}local>lde>lispcore>sources>DOVEDECLS.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEDECLSCOMS) + +(RPAQQ DOVEDECLSCOMS + ((DECLARE%: DONTCOPY (FILES MESATYPES)) + (MACROS \Dove.ClearQueueBlock \DoveIO.ByteSwap \DoveIO.IORegionOffset \DoveIO.LockMem + \DoveIO.NotifyIOP \DoveIO.SetMaintPanel \DoveFCBAt) + (CONSTANTS \DoveIO.ADD \DoveIO.AND \DoveIO.OR \DoveIO.OVERWRITEIFNIL \DoveIO.XCHG + \#WDS.OpieAddress) + (CONSTANTS \DoveIO.ByteFALSE \DoveIO.ByteTRUE) + (CONSTANTS * DoveIO.IORegionConstants) + (CONSTANTS * DoveIO.HandlerIDs) + (RECORDS Dove.OpieAddress DoveIO.ClientCondition DoveIO.TaskContextBlock DoveIO.SegmentRec + DoveIO.IORTable Dove.QueueBlock) + (PROP ARGNAMES \DoveFCBAt) + (COMS (CONSTANTS * DOVEIOREGIONOFFSETS) + (CONSTANTS * DOVEOPIEADDRESSTYPES) + (VARS \Dove.FCBSizes \DoveIO.PromVersion)) + (GLOBALVARS \DoveBeep.FCBPointer \DoveProcessor.FCBPointer \DoveKyMo.FCBPointer + \DoveMP.FCBPointer \DoveDisk.FCBPointer \DoveDisplay.FCBPointer \DoveEther.FCBPointer + \DoveFloppy.FCBPointer) + (TEMPLATES \DoveIO.LockMem))) +(DECLARE%: DONTCOPY + +(FILESLOAD MESATYPES) +) +(DECLARE%: EVAL@COMPILE + +(PROGN (DEFMACRO \Dove.ClearQueueBlock (BASE) + `(\CLEARWORDS %, BASE (MESASIZE Dove.QueueBlock))) + NIL) + +(PUTPROPS \DoveIO.ByteSwap DMACRO [ARGS (LET ((X (CAR ARGS))) + `((OPCODES DOVEMISC 4) + %, X]) + +(PROGN (DEFMACRO \DoveIO.IORegionOffset (X) + `(IDIFFERENCE (\LOLOC %, X) + (\LOLOC \DoveIORegion))) + NIL) + +(PUTPROPS \DoveIO.LockMem DMACRO [ARGS (LET ((MASK (CAR ARGS)) + (VALUE (CADR ARGS)) + (ADDR (CADDR ARGS)) + (OP (CADDDR ARGS))) + `((OPCODES DOVEMISC 5) + %, OP %, ADDR %, VALUE %, MASK]) + +(PUTPROPS \DoveIO.NotifyIOP DMACRO [ARGS (LET ((MASK (CAR ARGS))) + `((OPCODES DOVEMISC 6) + %, MASK]) + +(PUTPROPS \DoveIO.SetMaintPanel DMACRO [ARGS (LET ((CODE (CAR ARGS))) + `((OPCODES DOVEMISC 2) + %, + (\DTEST CODE 'SMALLP]) + +(PUTPROPS \DoveFCBAt DMACRO (DEFMACRO (X) (SELECTQ \DoveIO.PromVersion + (OLD `(\ADDBASE \DoveIORegion %, X)) + (NEW (ERROR "Don't use \DoveFCBAt anymore!")) + 'IGNOREMACRO))) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveIO.ADD 0) + +(RPAQQ \DoveIO.AND 1) + +(RPAQQ \DoveIO.OR 2) + +(RPAQQ \DoveIO.OVERWRITEIFNIL 4) + +(RPAQQ \DoveIO.XCHG 3) + +(RPAQQ \#WDS.OpieAddress 2) + + +(CONSTANTS \DoveIO.ADD \DoveIO.AND \DoveIO.OR \DoveIO.OVERWRITEIFNIL \DoveIO.XCHG \#WDS.OpieAddress) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveIO.ByteFALSE 0) + +(RPAQQ \DoveIO.ByteTRUE 255) + + +(CONSTANTS \DoveIO.ByteFALSE \DoveIO.ByteTRUE) +) + +(RPAQQ DoveIO.IORegionConstants ((DoveIO.SegmentGranularity 8) + (DoveIO.ioRegionByteOffset 16384) + (DoveIO.iorSegmentBase (FOLDLO DoveIO.ioRegionByteOffset 16)))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ DoveIO.SegmentGranularity 8) + +(RPAQQ DoveIO.ioRegionByteOffset 16384) + +(RPAQ DoveIO.iorSegmentBase (FOLDLO DoveIO.ioRegionByteOffset 16)) + + +(CONSTANTS (DoveIO.SegmentGranularity 8) + (DoveIO.ioRegionByteOffset 16384) + (DoveIO.iorSegmentBase (FOLDLO DoveIO.ioRegionByteOffset 16))) +) + +(RPAQQ DoveIO.HandlerIDs + ((DoveIO.beepHandler 1) + (DoveIO.diskHandler (ADD1 DoveIO.beepHandler)) + (DoveIO.displayHandler (ADD1 DoveIO.diskHandler)) + (DoveIO.ethernetHandler (ADD1 DoveIO.displayHandler)) + (DoveIO.floppyHandler (ADD1 DoveIO.ethernetHandler)) + (DoveIO.kymoHandler (ADD1 DoveIO.floppyHandler)) + (DoveIO.mpHandler (ADD1 DoveIO.kymoHandler)) + (DoveIO.lispHandler 16) + (DoveIO.ttyHandler (ADD1 DoveIO.lispHandler)) + (DoveIO.rs232Handler (ADD1 DoveIO.ttyHandler)) + (DoveIO.confHandler (ADD1 DoveIO.rs232Handler)) + (DoveIO.pceDispatchHandler (ADD1 DoveIO.confHandler)) + (DoveIO.pceDisplayHandler (ADD1 DoveIO.pceDispatchHandler)) + (DoveIO.pceKeyHandler (ADD1 DoveIO.pceDisplayHandler)) + (DoveIO.pceMouseHandler (ADD1 DoveIO.pceKeyHandler)) + (DoveIO.pcePrinterHandler (ADD1 DoveIO.pceMouseHandler)) + (DoveIO.pceFloppyHandler (ADD1 DoveIO.pcePrinterHandler)) + (DoveIO.pceHardDiskHandler (ADD1 DoveIO.pceFloppyHandler)) + (DoveIO.pceDMAHandler (ADD1 DoveIO.pceHardDiskHandler)) + (DoveIO.pceTimer (ADD1 DoveIO.pceDMAHandler)))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ DoveIO.beepHandler 1) + +(RPAQ DoveIO.diskHandler (ADD1 DoveIO.beepHandler)) + +(RPAQ DoveIO.displayHandler (ADD1 DoveIO.diskHandler)) + +(RPAQ DoveIO.ethernetHandler (ADD1 DoveIO.displayHandler)) + +(RPAQ DoveIO.floppyHandler (ADD1 DoveIO.ethernetHandler)) + +(RPAQ DoveIO.kymoHandler (ADD1 DoveIO.floppyHandler)) + +(RPAQ DoveIO.mpHandler (ADD1 DoveIO.kymoHandler)) + +(RPAQQ DoveIO.lispHandler 16) + +(RPAQ DoveIO.ttyHandler (ADD1 DoveIO.lispHandler)) + +(RPAQ DoveIO.rs232Handler (ADD1 DoveIO.ttyHandler)) + +(RPAQ DoveIO.confHandler (ADD1 DoveIO.rs232Handler)) + +(RPAQ DoveIO.pceDispatchHandler (ADD1 DoveIO.confHandler)) + +(RPAQ DoveIO.pceDisplayHandler (ADD1 DoveIO.pceDispatchHandler)) + +(RPAQ DoveIO.pceKeyHandler (ADD1 DoveIO.pceDisplayHandler)) + +(RPAQ DoveIO.pceMouseHandler (ADD1 DoveIO.pceKeyHandler)) + +(RPAQ DoveIO.pcePrinterHandler (ADD1 DoveIO.pceMouseHandler)) + +(RPAQ DoveIO.pceFloppyHandler (ADD1 DoveIO.pcePrinterHandler)) + +(RPAQ DoveIO.pceHardDiskHandler (ADD1 DoveIO.pceFloppyHandler)) + +(RPAQ DoveIO.pceDMAHandler (ADD1 DoveIO.pceHardDiskHandler)) + +(RPAQ DoveIO.pceTimer (ADD1 DoveIO.pceDMAHandler)) + + +(CONSTANTS (DoveIO.beepHandler 1) + (DoveIO.diskHandler (ADD1 DoveIO.beepHandler)) + (DoveIO.displayHandler (ADD1 DoveIO.diskHandler)) + (DoveIO.ethernetHandler (ADD1 DoveIO.displayHandler)) + (DoveIO.floppyHandler (ADD1 DoveIO.ethernetHandler)) + (DoveIO.kymoHandler (ADD1 DoveIO.floppyHandler)) + (DoveIO.mpHandler (ADD1 DoveIO.kymoHandler)) + (DoveIO.lispHandler 16) + (DoveIO.ttyHandler (ADD1 DoveIO.lispHandler)) + (DoveIO.rs232Handler (ADD1 DoveIO.ttyHandler)) + (DoveIO.confHandler (ADD1 DoveIO.rs232Handler)) + (DoveIO.pceDispatchHandler (ADD1 DoveIO.confHandler)) + (DoveIO.pceDisplayHandler (ADD1 DoveIO.pceDispatchHandler)) + (DoveIO.pceKeyHandler (ADD1 DoveIO.pceDisplayHandler)) + (DoveIO.pceMouseHandler (ADD1 DoveIO.pceKeyHandler)) + (DoveIO.pcePrinterHandler (ADD1 DoveIO.pceMouseHandler)) + (DoveIO.pceFloppyHandler (ADD1 DoveIO.pcePrinterHandler)) + (DoveIO.pceHardDiskHandler (ADD1 DoveIO.pceFloppyHandler)) + (DoveIO.pceDMAHandler (ADD1 DoveIO.pceHardDiskHandler)) + (DoveIO.pceTimer (ADD1 DoveIO.pceDMAHandler))) +) +(DECLARE%: EVAL@COMPILE + +(MESARECORD Dove.OpieAddress ((LoPart.BS WORD) + (HiPart BYTE) + (AddrType BYTE)) + [ACCESSFNS ((LispPointer (\DoveIO.PointerFromOpieAddress DATUM) + (\DoveIO.MakeOpieAddress DATUM NEWVALUE]) + +(MESATYPE DoveIO.ClientCondition (3 WORD)) + +(MESARECORD DoveIO.TaskContextBlock ((taskQueue 2 WORD) + (taskCondition WORD) + (taskICPtr WORD) + (taskSP WORD) + (returnSPSS 2 WORD) + (prevState BITS 4) + (presentState BITS 4) + (taskHandlerID BYTE) + (timerValue WORD))) + +(MESARECORD DoveIO.SegmentRec ((ioRegionSegment WORD) + (stackSegment WORD))) + +(MESARECORD DoveIO.IORTable ((mesaHasLock BITS 16) + (iopRequestsLock BITS 16) + (segments DoveIO.SegmentRec))) + +(MESARECORD Dove.QueueBlock ((QueueHead Dove.OpieAddress) + (QueueTail Dove.OpieAddress) + (QueueNext Dove.OpieAddress)) + [ACCESSFNS ((LispQueueHead (\DoveIO.PointerFromOpieAddress + (fetch (Dove.QueueBlock QueueHead) + of DATUM)) + (\DoveIO.MakeOpieAddress (fetch ( + Dove.QueueBlock + QueueHead) + of DATUM) + NEWVALUE)) + (LispQueueTail (\DoveIO.PointerFromOpieAddress + (fetch (Dove.QueueBlock QueueTail) + of DATUM)) + (\DoveIO.MakeOpieAddress (fetch ( + Dove.QueueBlock + QueueTail) + of DATUM) + NEWVALUE)) + (LispQueueNext (\DoveIO.PointerFromOpieAddress + (fetch (Dove.QueueBlock QueueNext) + of DATUM)) + (\DoveIO.MakeOpieAddress (fetch ( + Dove.QueueBlock + QueueNext) + of DATUM) + NEWVALUE]) +) + +(PUTPROPS \DoveFCBAt ARGNAMES (OFFSET)) + +(RPAQQ DOVEIOREGIONOFFSETS + ((\Dove.VmemPageRunTableOffset 16128) + (\Dove.MesaClientFCBOffset 4474) + (\Dove.RemoteMemoryFCBOffset 3911) + (\Dove.UnservicedFCBOffset 3815) + (\Dove.WorkNotifierFCBOffset 3719) + (\Dove.BindweedFCBOffset 3623) + (\Dove.BootStrapFCBOffset 3527) + (\Dove.WatchDogFCBOffset 3431) + (\Dove.TestClientFCBOffset 2816) + (\Dove.TimerFCBOffset 870) + (\Dove.UmbilicalFCBOffset 478) + (\Dove.ParityFCBOffset 382) + (\Dove.OpieFCBOffset 30) + (\Dove.BermudaFCBOffset 26))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \Dove.VmemPageRunTableOffset 16128) + +(RPAQQ \Dove.MesaClientFCBOffset 4474) + +(RPAQQ \Dove.RemoteMemoryFCBOffset 3911) + +(RPAQQ \Dove.UnservicedFCBOffset 3815) + +(RPAQQ \Dove.WorkNotifierFCBOffset 3719) + +(RPAQQ \Dove.BindweedFCBOffset 3623) + +(RPAQQ \Dove.BootStrapFCBOffset 3527) + +(RPAQQ \Dove.WatchDogFCBOffset 3431) + +(RPAQQ \Dove.TestClientFCBOffset 2816) + +(RPAQQ \Dove.TimerFCBOffset 870) + +(RPAQQ \Dove.UmbilicalFCBOffset 478) + +(RPAQQ \Dove.ParityFCBOffset 382) + +(RPAQQ \Dove.OpieFCBOffset 30) + +(RPAQQ \Dove.BermudaFCBOffset 26) + + +(CONSTANTS (\Dove.VmemPageRunTableOffset 16128) + (\Dove.MesaClientFCBOffset 4474) + (\Dove.RemoteMemoryFCBOffset 3911) + (\Dove.UnservicedFCBOffset 3815) + (\Dove.WorkNotifierFCBOffset 3719) + (\Dove.BindweedFCBOffset 3623) + (\Dove.BootStrapFCBOffset 3527) + (\Dove.WatchDogFCBOffset 3431) + (\Dove.TestClientFCBOffset 2816) + (\Dove.TimerFCBOffset 870) + (\Dove.UmbilicalFCBOffset 478) + (\Dove.ParityFCBOffset 382) + (\Dove.OpieFCBOffset 30) + (\Dove.BermudaFCBOffset 26)) +) + +(RPAQQ DOVEOPIEADDRESSTYPES (\DoveIO.ExtendedBusType \DoveIO.IOPIORegionRelativeType + \DoveIO.IOPLogicalType \DoveIO.PCLogicalType + \DoveIO.VirtualFirst64KRelativeType \DoveIO.VirtualPageType + \DoveIO.VirtualWordType)) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveIO.ExtendedBusType 16) + +(RPAQQ \DoveIO.IOPIORegionRelativeType 81) + +(RPAQQ \DoveIO.IOPLogicalType 80) + +(RPAQQ \DoveIO.PCLogicalType 144) + +(RPAQQ \DoveIO.VirtualFirst64KRelativeType 225) + +(RPAQQ \DoveIO.VirtualPageType 240) + +(RPAQQ \DoveIO.VirtualWordType 224) + + +(CONSTANTS \DoveIO.ExtendedBusType \DoveIO.IOPIORegionRelativeType \DoveIO.IOPLogicalType + \DoveIO.PCLogicalType \DoveIO.VirtualFirst64KRelativeType \DoveIO.VirtualPageType + \DoveIO.VirtualWordType) +) + +(RPAQQ \Dove.FCBSizes + ((NIL 2) + (\Dove.MesaIOPOffset 5) + (\Dove.WorkMaskAreaOffset 17) + (\Dove.MesaPageMapLocationOffset 2) + (\Dove.BermudaFCBOffset 4) + (\Dove.OpieFCBOffset 256) + (\Dove.MaintPanelFCBOffset 96) + (\Dove.ParityFCBOffset 96) + (\Dove.UmbilicalFCBOffset 96) + (\Dove.Keyboard&MouseFCBOffset 175) + (\Dove.BeepFCBOffset 25) + (\Dove.DisplayFCBOffset 96) + (\Dove.TimerFCBOffset 96) + (\Dove.EthernetFCBOffset 1850) + (\Dove.TestClientFCBOffset 340) + (\Dove.DiskFCBOffset 150) + (\Dove.FloppyFCBOffset 125) + (\Dove.WatchDogFCBOffset 96) + (\Dove.BootStrapFCBOffset 96) + (\Dove.BindweedFCBOffset 96) + (\Dove.WorkNotifierFCBOffset 96) + (\Dove.UnservicedFCBOffset 96) + (\Dove.RemoteMemoryFCBOffset 231) + (\Dove.TTYFCBOffset 96) + (\Dove.RS232CFCBOffset 140) + (\Dove.ProcessorFCBOffset 96) + (\Dove.MesaClientFCBOffset 96) + (\Dove.PCEDispatcherFCBOffset 96) + (\Dove.PCETimerFCBOffset 96) + (\Dove.PCEParallelFCBOffset 96) + (\Dove.PCEDisplayFCBOffset 96) + (\Dove.PCEKeyboardFCBOffset 96) + (\Dove.PCERS232CFCBOffset 96) + (\Dove.PCEDiskFCBOffset 96) + (\Dove.PCEFloppyFCBOffset 160))) + +(RPAQQ \DoveIO.PromVersion NEW) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveBeep.FCBPointer \DoveProcessor.FCBPointer \DoveKyMo.FCBPointer \DoveMP.FCBPointer + \DoveDisk.FCBPointer \DoveDisplay.FCBPointer \DoveEther.FCBPointer \DoveFloppy.FCBPointer) +) + +(SETTEMPLATE '\DoveIO.LockMem '(|..| EVAL)) +(PUTPROPS DOVEDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/sources/DOVEDISK b/sources/DOVEDISK new file mode 100644 index 00000000..463f6cd3 --- /dev/null +++ b/sources/DOVEDISK @@ -0,0 +1,729 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 15:58:10" {DSK}local>lde>lispcore>sources>DOVEDISK.;2 37028 + + changes to%: (VARS DOVEDISKCOMS) + + previous date%: " 8-Jan-86 15:51:22" {DSK}local>lde>lispcore>sources>DOVEDISK.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEDISKCOMS) + +(RPAQQ DOVEDISKCOMS + [(FNS \DISKDOVEINIT \DOVE.ACTONVMEMFILE \DOVE.ACTONVMEMPAGE \DOVE.XFERDISK + \DoveDisk.CopyByteSwappedLabel \DoveDisk.ExecuteIOCB \DoveDisk.HandleMajorError + \DoveDisk.Init \DoveDisk.InitIOCB \DoveDisk.Initiate \DoveDisk.TryRecalibrate + \DoveDisk.WaitForHandlerStopped) + (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * DOVEDISKDECLS)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DISKDOVEINIT]) +(DEFINEQ + +(\DISKDOVEINIT + [LAMBDA NIL (* ejs%: "16-Sep-85 13:50") + (for I in '(\DoveDisk.FCBPointer \DISKTYPE \CONTROLLERTYPE + \DLDISKSHAPE.SECTORSPERCYLINDER \DLDISKSHAPE.SECTORSPERHEAD + \DLDISKSHAPE.HEADSPERDRIVE \IOCBSCRATCHLABEL) do (\LOCKVAR I)) + (for I in '(\DOVE.ACTONVMEMFILE \DOVE.ACTONVMEMPAGE \DOVE.XFERDISK + \DoveDisk.CopyByteSwappedLabel \DoveDisk.ExecuteIOCB + \DoveDisk.HandleMajorError \DoveDisk.Init \DoveDisk.InitIOCB + \DoveDisk.Initiate \DoveDisk.TryRecalibrate + \DoveDisk.WaitForHandlerStopped) do (\LOCKFN I]) + +(\DOVE.ACTONVMEMFILE + [LAMBDA (FILEPAGE BUFFER NPAGES WRITEFLAG) (* mpl "20-Jun-85 12:07") + (* Pilot page is zero-based, vmem + page is one-base) + (FRPTQ NPAGES (\DOVE.ACTONVMEMPAGE (SUB1 FILEPAGE) + BUFFER WRITEFLAG) + (SETQ BUFFER (\ADDBASE BUFFER WORDSPERPAGE)) + (add FILEPAGE 1]) + +(\DOVE.ACTONVMEMPAGE + [LAMBDA (FILEPAGE BUFFER WRITEFLAG) (* bvm%: " 8-Jan-86 15:29") + + (* This fn brings in a page of the VMEM file. + It scans over the bad page table, which contains a loose mapping of logical + pages to physical pages.) + + (PROG ((THISRUN (LOCF (fetch DLVMEMFILEINFO of \IOCBPAGE))) + (FAULTLABEL (\ADDBASE \IOCBPAGE \FAULTLABEL)) + (I (IQUOTIENT (IDIFFERENCE (INDEXF (fetch FLOPPYIOCBSTART)) + (INDEXF (fetch DLVMEMFILEINFO))) + 3)) + NEXTPAGE NEXTRUN) + (replace (PilotDiskLabel FilePageLo) of FAULTLABEL with (ADD1 FILEPAGE)) + (replace (PilotDiskLabel BootLinkA) of FAULTLABEL with 0) + (replace (PilotDiskLabel BootLinkB) of FAULTLABEL with 0) + (SETQ NEXTRUN (fetch DLNEXTRUN of THISRUN)) + LP [COND + ((OR (IGREATERP (SETQ NEXTPAGE (fetch DLFIRSTFILEPAGE of NEXTRUN)) + FILEPAGE) + (EQ NEXTPAGE 0)) + [COND + ((EQ FILEPAGE (SUB1 NEXTPAGE)) + + (* If we're on the last page of a run, we've got to update the boot link) + + (replace (PilotDiskLabel BootLinkA) of FAULTLABEL + with (fetch DLVMCYL of NEXTRUN)) + (replace (PilotDiskLabel BootLinkB) of FAULTLABEL + with (LOGOR (LLSH (fetch DLVMHEAD of NEXTRUN) + 8) + (fetch DLVMSECTOR of NEXTRUN] + (RETURN (COND + ((NEQ (\DOVE.XFERDISK (fetch DLVMCYL of THISRUN) + (fetch DLVMHEAD of THISRUN) + (IPLUS (IDIFFERENCE FILEPAGE (fetch DLFIRSTFILEPAGE + of THISRUN)) + (fetch DLVMSECTOR of THISRUN)) + BUFFER WRITEFLAG FAULTLABEL) + 'OK) + (\MP.ERROR \MP.SWAPDISKERROR "Hard Disk Error in swapper"] + (COND + ((EQ 0 I) + (\MP.ERROR \MP.BADRUNTABLE "Malformed run table for vmem file") + (RETURN))) + (SETQ I (SUB1 I)) + (SETQ NEXTRUN (fetch DLNEXTRUN of (SETQ THISRUN NEXTRUN))) + (GO LP]) + +(\DOVE.XFERDISK + [LAMBDA (CYL HD SEC BUFFER MODE LABEL RUNLENGTH NORAIDFLG) + (* hts%: " 5-Sep-85 17:12") + (DECLARE (GLOBALVARS \IOCBPAGE \DLDISKSHAPE.HEADSPERDRIVE \DLDISKSHAPE.SECTORSPERHEAD) + (CONSTANTS \IOCBSCRATCHLABEL \DoveDisk.ReadCmd \DoveDisk.VerifyCmd \DoveDisk.WriteCmd)) + (SETQ HD (IPLUS HD (IQUOTIENT SEC \DLDISKSHAPE.SECTORSPERHEAD))) + (SETQ SEC (IREMAINDER SEC \DLDISKSHAPE.SECTORSPERHEAD)) + (SETQ CYL (IPLUS CYL (IQUOTIENT HD \DLDISKSHAPE.HEADSPERDRIVE))) + (SETQ HD (IREMAINDER HD \DLDISKSHAPE.HEADSPERDRIVE)) + [\CLEARWORDS \IOCBPAGE (SUB1 (INDEXF (fetch (Dove.DiskIOCB DOBBase] + (with Dove.DiskIOCB \IOCBPAGE (SETQ Header.Cylinder CYL) + (SETQ Header.Head HD) + (SETQ Header.Sector SEC) + [SETQ LabelPtr (COND + (LABEL LABEL) + (T (\ADDBASE \IOCBPAGE \IOCBSCRATCHLABEL] + (SETQ DataPtr BUFFER) + (SETQ HeaderCmd \DoveDisk.VerifyCmd) + (SELECTQ MODE + (VRR (SETQ LabelCmd \DoveDisk.ReadCmd) + (SETQ DataCmd \DoveDisk.ReadCmd)) + (VVR (SETQ LabelCmd \DoveDisk.VerifyCmd) + (SETQ DataCmd \DoveDisk.ReadCmd)) + (VVW (SETQ LabelCmd \DoveDisk.VerifyCmd) + (SETQ DataCmd \DoveDisk.WriteCmd)) + (VWW (SETQ LabelCmd \DoveDisk.WriteCmd) + (SETQ DataCmd \DoveDisk.WriteCmd)) + (T (SETQ LabelCmd \DoveDisk.WriteCmd) + (SETQ DataCmd \DoveDisk.WriteCmd)) + (NIL (SETQ LabelCmd \DoveDisk.ReadCmd) + (SETQ DataCmd \DoveDisk.ReadCmd)) + (PROGN (RAID "Invalid MODE"))) + (SETQ IncDataPtr NIL) + (SETQ RetryStrategy 10) + (SETQ PageCount (OR (SMALLP RUNLENGTH) + 1))) + (SELECTC (\DoveDisk.ExecuteIOCB \IOCBPAGE) + (\DoveDisk.NoError + 'OK) + (\DoveDisk.VerifyError + 'VERIFYERROR) + (PROGN (COND + ((OR (EQ MODE 'VRR) + (EQ MODE 'VVR)) + 'READERROR) + (T 'WRITEERROR]) + +(\DoveDisk.CopyByteSwappedLabel + [LAMBDA (FROMPTR TOPTR) (* MPL "16-Jun-85 14:25") + + (* * This atrocity is due to the IOP's byteswapping mess) + + (for I from 0 to 9 do (\PUTBASE TOPTR I (\DoveIO.ByteSwap (\GETBASE FROMPTR I]) + +(\DoveDisk.ExecuteIOCB + [LAMBDA (IOCB) (* ejs%: "16-Sep-85 16:52") + + (* * This function attempts to execute a disk IOCB) + + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \Dove.DiskFCBOffset \DoveIO.ByteFALSE \DoveIO.ByteTRUE)) + (PROG (FCBPtr DOBPtr (TriesLeft 16) + (TriedRecalibrate NIL)) + (SETQ FCBPtr \DoveDisk.FCBPointer) + (SETQ DOBPtr (LOCF (fetch (Dove.DiskIOCB DOBBase) of IOCB))) + + (* * Gotta try at least once...) + + DoItAgain + [COND + ((EQ 0 (SETQ TriesLeft (SUB1 TriesLeft))) + (RETURN (\DoveIO.ByteSwap (fetch (Dove.DOB LastError.BS) of DOBPtr] + (\DoveDisk.Initiate IOCB NIL) + [COND + ((EQ (fetch (Dove.DiskIOCB LabelCmd) of IOCB) + \DoveDisk.ReadCmd) + (\DoveDisk.CopyByteSwappedLabel (LOCF (fetch (Dove.DOB Label.FileID) + of DOBPtr)) + (fetch (Dove.DiskIOCB LabelPtr) of IOCB] + (COND + ((EQ (fetch (Dove.DiskIOCB HError) of IOCB) + \DoveIO.ByteFALSE) + (RETURN \DoveDisk.NoError))) + (COND + ((NEQ (fetch (Dove.DiskFCB HandlerState) of FCBPtr) + \DoveDisk.NormalHandlerState) + (\DoveDisk.HandleMajorError IOCB) + (GO DoItAgain))) + (replace (Dove.DiskIOCB HStopHandlerOnCompletion) of IOCB with \DoveIO.ByteTRUE + ) + (COND + ((EQ TriesLeft 8) + (\DoveDisk.TryRecalibrate IOCB) + (SETQ TriedRecalibrate T))) + (GO DoItAgain]) + +(\DoveDisk.HandleMajorError + [LAMBDA (IOCB) (* ejs%: "16-Sep-85 16:52") + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \DoveIO.ByteTRUE \DoveIO.ByteFALSE \Dove.DiskFCBOffset)) + (\DoveDisk.WaitForHandlerStopped) + (with Dove.DiskIOCB IOCB (SETQ HStopHandlerOnCompletion \DoveIO.ByteTRUE) + (SETQ HOnlyDOBFromController \DoveIO.ByteFALSE) + (SETQ HInProgress \DoveIO.ByteFALSE) + (SETQ HComplete \DoveIO.ByteFALSE) + (SETQ HDOBError \DoveIO.ByteFALSE) + (SETQ HDMATimedOut \DoveIO.ByteFALSE)) + (replace (Dove.DiskFCB HandlerState) of \DoveDisk.FCBPointer with + \DoveDisk.NormalHandlerState + ) + (\DoveIO.NotifyIOP (fetch (Dove.DiskFCB WorkMask) of \DoveDisk.FCBPointer)) + (\DoveDisk.WaitForHandlerStopped) + (with Dove.DiskIOCB IOCB (SETQ HStopHandlerOnCompletion \DoveIO.ByteTRUE) + (SETQ HOnlyDOBFromController \DoveIO.ByteFALSE) + (SETQ HInProgress \DoveIO.ByteFALSE) + (SETQ HComplete \DoveIO.ByteFALSE) + (SETQ HDOBError \DoveIO.ByteFALSE) + (SETQ HDMATimedOut \DoveIO.ByteFALSE]) + +(\DoveDisk.Init + [LAMBDA NIL (* ejs%: "16-Sep-85 16:54") + + (* * This fn is analagous to \DL.DISKINIT, the function which initializes the + disk head on the DLion) + + (DECLARE (GLOBALVARS \DISKTYPE \CONTROLLERTYPE \DLDISKSHAPE.SECTORSPERCYLINDER + \DLDISKSHAPE.SECTORSPERHEAD \DLDISKSHAPE.HEADSPERDRIVE \IOCBSCRATCHLABEL) + (CONSTANTS \Dove.VmemPageRunTableOffset \Dove.DiskFCBOffset)) + + (* * We already know what kind of controller...) + + (SETQQ \CONTROLLERTYPE \ST506) + + (* * No real limit on the number of different disk drives now...) + + (SETQQ \DISKTYPE \SEAGATE) + + (* * Initialize drive parameters) + + (with Dove.DCB (fetch (Dove.DiskFCB DCB0Base) of \DoveDisk.FCBPointer) + (SETQ \DLDISKSHAPE.HEADSPERDRIVE HeadsPerCylinder) + (SETQ \DLDISKSHAPE.SECTORSPERHEAD SectorsPerTrack) + (SETQ \DLDISKSHAPE.SECTORSPERCYLINDER (ITIMES HeadsPerCylinder SectorsPerTrack))) + + (* * The VMEM table is built in the IORegion now. + Copy it from the IORegion to where the disk code expects to find it.) + + (\CLEARWORDS \IOCBPAGE WORDSPERPAGE) + (\BLT (LOCF (fetch (IOCBPAGE DLVMEMFILEINFO) of \IOCBPAGE)) + (\ADDBASE \DoveIORegion \Dove.VmemPageRunTableOffset) + 128) + + (* * This fn is in DISKDLION. It sets up the DOB chain that the fault handler + will use and the file system currently uses.) + + (\DL.INIT.DOB.CHAIN) + NIL]) + +(\DoveDisk.InitIOCB + [LAMBDA (IOCBPtr JustRecalibrate?) (* ejs%: "16-Sep-85 16:53") + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \Dove.DiskFCBOffset \DoveIO.ByteFALSE \DoveIO.ByteTRUE + \DoveDisk.DefaultDrive&ControllerStatus \DoveDisk.DefaultWriteEndCount + \DoveDisk.CRC \DoveDisk.NoError \DoveDisk.RestoreOp \DoveDisk.VerifyCmd + \DoveDisk.NoopCmd \DoveDisk.ReadCmd \DoveDisk.WriteCmd \DoveDisk.ReadLabelOp + \DoveDisk.WriteLabelAndDataOp \DoveDisk.ReadDataOp \DoveDisk.WriteDataOp + \DoveDisk.VerifyDataOp \DoveDisk.Read \DoveDisk.Write \DoveDisk.NoOperation + \DoveDisk.FromLisp \DoveDisk.ToLisp)) + + (* * This fn is used to fill in all the fields for an IOCB. + The Dove disk software wasn't very well designed, so there's lots of redundancy + here) + + (PROG ((DOBBase (LOCF (fetch (Dove.DiskIOCB DOBBase) of IOCBPtr))) + (DCBBase (fetch (Dove.DiskFCB DCB0Base) of \DoveDisk.FCBPointer)) + (DiskOp NIL)) + (\DoveDisk.CopyByteSwappedLabel (fetch (Dove.DiskIOCB LabelPtr) of IOCBPtr) + (LOCF (fetch (Dove.DOB Label.FileID) of DOBBase))) + (\DoveIO.MakeOpieAddress (LOCF (fetch (Dove.DiskIOCB HDataPtr) of IOCBPtr)) + (fetch (Dove.DiskIOCB DataPtr) of IOCBPtr)) + (replace (Dove.DiskIOCB HComplementDOB) of IOCBPtr with T) + (with Dove.DiskIOCB IOCBPtr (SETQ HEtch 0) (* Etch=1 means etch 2) + (SETQ HUseLEDS NIL) + (SETQ HDiagnosticCommand NIL) + (SETQ HHalt NIL) + (SETQ HIncDataPtr IncDataPtr) + (SETQ HDMATimedOut \DoveIO.ByteFALSE) + (SETQ HError \DoveIO.ByteFALSE) + (SETQ HDOBError \DoveIO.ByteFALSE) + (SETQ HInProgress \DoveIO.ByteFALSE) + (SETQ HComplete \DoveIO.ByteFALSE) + (SETQ HOnlyDOBFromController \DoveIO.ByteFALSE) + (SETQ HStopHandlerOnCompletion \DoveIO.ByteTRUE) + (SETQ HPageCount (\DoveIO.ByteSwap PageCount))) + (with Dove.DOB DOBBase (SETQ Zero1 0) + (SETQ Zero2 0) + (SETQ Zero3 0) + (SETQ Zero4 0) + (SETQ Zero5 0) + (SETQ Zero6 0) + (SETQ Drive&ControllerStatus \DoveDisk.DefaultDrive&ControllerStatus) + [SETQ NegativeSectorCount.BS (\DoveIO.ByteSwap (ADD1 (LOGXOR MAX.SMALLP + (fetch ( + Dove.DiskIOCB + PageCount) + of IOCBPtr] + (SETQ WriteEndCount \DoveDisk.DefaultWriteEndCount) + (SETQ StartingSectorOnTrack 0) + (SETQ ECCSyndromeA 0) + (SETQ ECCSyndromeB 0) + (SETQ ECCFlag \DoveDisk.CRC) + (SETQ CurrentCylinder.BS (\DoveIO.ByteSwap 65535)) + (SETQ Header.Cylinder.BS (\DoveIO.ByteSwap (fetch (Dove.DiskIOCB Header.Cylinder + ) of IOCBPtr))) + (SETQ Header.Head (fetch (Dove.DiskIOCB Header.Head) of IOCBPtr)) + (SETQ Header.Sector (fetch (Dove.DiskIOCB Header.Sector) of IOCBPtr)) + (SETQ LabelError.BS (\DoveIO.ByteSwap \DoveDisk.NoError)) + (SETQ HeaderError.BS (\DoveIO.ByteSwap \DoveDisk.NoError)) + (SETQ DataError.BS (\DoveIO.ByteSwap \DoveDisk.NoError)) + (SETQ LastError.BS (\DoveIO.ByteSwap \DoveDisk.NoError)) + (SETQ ReducedWriteCylinder.BS (fetch (Dove.DCB ReduceWriteCurrentCylinder.BS) + of DCBBase)) + (SETQ PrecompensationCylinder.BS (fetch (Dove.DCB PrecompensationCylinder.BS) + of DCBBase)) + (SETQ SectorsPerTrack (fetch (Dove.DCB SectorsPerTrack) of DCBBase)) + (SETQ HeadsPerCylinder (fetch (Dove.DCB HeadsPerCylinder) of DCBBase)) + (SETQ CylindersPerDrive.BS (fetch (Dove.DCB CylindersPerDrive.BS) of DCBBase + ))) + [COND + (JustRecalibrate? (replace (Dove.DOB Operation) of DOBBase with + \DoveDisk.RestoreOp + ) + (SETQ DiskOp \DoveDisk.RestoreOp)) + (T (with Dove.DiskIOCB IOCBPtr (SETQ DiskOp (COND + ((EQ HeaderCmd \DoveDisk.VerifyCmd) + (SELECTC LabelCmd + (\DoveDisk.ReadCmd + (SELECTC DataCmd + (\DoveDisk.NoopCmd + + \DoveDisk.ReadLabelOp) + (\DoveDisk.ReadCmd + + \DoveDisk.ReadLabelAndDataOp) + (PROGN NIL))) + (\DoveDisk.WriteCmd + (COND + ((EQ DataCmd + \DoveDisk.WriteCmd) + + \DoveDisk.WriteLabelAndDataOp + ) + (T NIL))) + (\DoveDisk.VerifyCmd + (SELECTC DataCmd + (\DoveDisk.NoopCmd + + \DoveDisk.ReadDataOp) + (\DoveDisk.ReadCmd + + \DoveDisk.ReadDataOp) + (\DoveDisk.WriteCmd + + \DoveDisk.WriteDataOp) + (\DoveDisk.VerifyCmd + + \DoveDisk.VerifyDataOp) + (PROGN NIL))) + (PROGN NIL] + (COND + ((NOT DiskOp) + (RETURN T))) + (replace (Dove.DOB Operation) of DOBBase with DiskOp) + (replace (Dove.DiskIOCB HStopHandlerOnCompletion) of IOCBPtr with + \DoveIO.ByteTRUE + ) + + (* * HDataCommandTransfer is a FLAG, but the damned record package won't + believe it.) + + [with Dove.DiskIOCB IOCBPtr (SELECTC DiskOp + (\DoveDisk.ReadDataOp + (SETQ HDataCommandTransfer 1) + (SETQ HDataCommandDirection \DoveDisk.ToLisp) + (SETQ HDataXferDirection \DoveDisk.Read)) + (\DoveDisk.ReadLabelAndDataOp + (SETQ HDataCommandTransfer 1) + (SETQ HDataCommandDirection \DoveDisk.ToLisp) + (SETQ HDataXferDirection \DoveDisk.Read)) + (\DoveDisk.WriteDataOp + (SETQ HDataCommandTransfer 1) + (SETQ HDataCommandDirection \DoveDisk.FromLisp) + (SETQ HDataXferDirection \DoveDisk.Write)) + (\DoveDisk.WriteLabelAndDataOp + (SETQ HDataCommandTransfer 1) + (SETQ HDataCommandDirection \DoveDisk.FromLisp) + (SETQ HDataXferDirection \DoveDisk.Write)) + (PROGN (SETQ HDataCommandTransfer 0) + (SETQ HDataXferDirection \DoveDisk.NoOperation] + (RETURN NIL]) + +(\DoveDisk.Initiate + [LAMBDA (IOCBPtr JustRecalibrate?) (* ejs%: "16-Sep-85 17:09") + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \Dove.DiskFCBOffset \DoveIO.ByteFALSE \DoveIO.ByteTRUE)) + + (* * This one actually makes it all happen) + + (PROG ((InvalidOp NIL) + (DCBBase (fetch (Dove.DiskFCB DCB0Base) of \DoveDisk.FCBPointer)) + (ShortIOCBPtr (\LOLOC IOCBPtr)) + (Completion NIL)) + (replace (Dove.DCB Recalibrate) of DCBBase with JustRecalibrate?) + (\DoveIO.MakeOpieAddress (LOCF (fetch (Dove.DiskIOCB IOPNext) of IOCBPtr)) + NIL) + (with Dove.DiskIOCB IOCBPtr (SETQ Try 1) + (SETQ HStopHandlerOnCompletion \DoveIO.ByteTRUE)) + (SETQ InvalidOp (\DoveDisk.InitIOCB IOCBPtr JustRecalibrate?)) + + (* * Now, diddle with the IOREgion) + + [COND + (InvalidOp (with Dove.DiskIOCB IOCBPtr (SETQ HError \DoveIO.ByteTRUE) + (SETQ Completion 'INVALIDOPERATION) + (SETQ HComplete \DoveIO.ByteTRUE) + (RETURN Completion] + + (* * Fix up the IOCB so it's the first and the last) + + (replace (Dove.DiskIOCB MesaNext) of IOCBPtr with 0) + (with Dove.DCB DCBBase (SETQ MesaHead ShortIOCBPtr) + (SETQ MesaTail ShortIOCBPtr)) + (replace (Dove.DiskIOCB HNextIOCB) of IOCBPtr with 0) + (\DoveIO.LockMem \DoveIO.OVERWRITEIFNIL [\DoveIO.IORegionOffset + (LOCF (fetch (Dove.DCB HandlerMesaNext) + of (fetch (Dove.DiskFCB DCB0Base) + of \DoveDisk.FCBPointer] + (\DoveIO.ByteSwap ShortIOCBPtr) + (fetch (Dove.DiskFCB LockMask) of \DoveDisk.FCBPointer)) + (replace (Dove.DiskIOCB HComplete) of IOCBPtr with \DoveIO.ByteFALSE) + (replace (Dove.DiskFCB StartHandlerForMesa) of \DoveDisk.FCBPointer with 65535) + (\DoveIO.NotifyIOP (fetch (Dove.DiskFCB WorkMask) of \DoveDisk.FCBPointer)) + (repeatuntil (EQ \DoveIO.ByteTRUE (fetch (Dove.DiskIOCB HComplete) of IOCBPtr)) + ) + (replace (Dove.DCB Recalibrate) of DCBBase with NIL) + (RETURN (fetch (Dove.DiskIOCB HError) of IOCBPtr]) + +(\DoveDisk.TryRecalibrate + [LAMBDA (IOCB) (* mpl "16-Jul-85 12:54") + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \Dove.DiskFCBOffset)) + (PROG [OLDCMD (DOBBase (LOCF (fetch (Dove.DiskIOCB DOBBase) of IOCB] + (SETQ OLDCMD (fetch (Dove.DOB Operation) of DOBBase)) + (\DoveDisk.Initiate IOCB T) + (replace (Dove.DOB Operation) of DOBBase with OLDCMD]) + +(\DoveDisk.WaitForHandlerStopped + [LAMBDA NIL (* ejs%: "16-Sep-85 16:52") + (to 30000 do (COND + ((NEQ (fetch (Dove.DiskFCB HandlerStoppedForMesa) of + \DoveDisk.FCBPointer + ) + \DoveIO.ByteFALSE) + (RETURN))) finally (RAID]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(RPAQQ DOVEDISKDECLS + ((FILES (SOURCE) + DOVEDECLS DISKVMEMDECLS) + (CONSTANTS \DoveDisk.CRC \DoveDisk.DefaultDrive&ControllerStatus + \DoveDisk.DefaultWriteEndCount \DoveDisk.NoError \DoveDisk.VerifyError + \IOCBSCRATCHLABEL \FAULTLABEL \DoveDisk.NormalHandlerState) + (CONSTANTS \DoveDisk.WriteLabelAndDataOp \DoveDisk.WriteDataOp \DoveDisk.VerifyDataOp + \DoveDisk.ReadLabelAndDataOp \DoveDisk.ReadLabelOp \DoveDisk.RestoreOp + \DoveDisk.ReadDataOp \DoveDisk.ReadDiagnosticOp \DoveDisk.FormatTracksOp) + (CONSTANTS \DoveDisk.Execute \DoveDisk.FromLisp \DoveDisk.NoOperation \DoveDisk.NoopCmd + \DoveDisk.Read \DoveDisk.ReadCmd \DoveDisk.ToLisp \DoveDisk.VerifyCmd \DoveDisk.Write + \DoveDisk.WriteCmd) + (RECORDS Dove.DCB Dove.DOB Dove.DiskFCB Dove.DiskIOCB PilotDiskLabel) + (INITVARS (\DoveDisk.FCBPointer)) + (GLOBALVARS \DoveDisk.FCBPointer))) + +(FILESLOAD (SOURCE) + DOVEDECLS DISKVMEMDECLS) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveDisk.CRC 1) + +(RPAQQ \DoveDisk.DefaultDrive&ControllerStatus 52824) + +(RPAQQ \DoveDisk.DefaultWriteEndCount 255) + +(RPAQQ \DoveDisk.NoError 0) + +(RPAQQ \DoveDisk.VerifyError 35) + +(RPAQQ \IOCBSCRATCHLABEL 95) + +(RPAQQ \FAULTLABEL 110) + +(RPAQQ \DoveDisk.NormalHandlerState 0) + + +(CONSTANTS \DoveDisk.CRC \DoveDisk.DefaultDrive&ControllerStatus \DoveDisk.DefaultWriteEndCount + \DoveDisk.NoError \DoveDisk.VerifyError \IOCBSCRATCHLABEL \FAULTLABEL + \DoveDisk.NormalHandlerState) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveDisk.WriteLabelAndDataOp 4) + +(RPAQQ \DoveDisk.WriteDataOp 3) + +(RPAQQ \DoveDisk.VerifyDataOp 7) + +(RPAQQ \DoveDisk.ReadLabelAndDataOp 6) + +(RPAQQ \DoveDisk.ReadLabelOp 5) + +(RPAQQ \DoveDisk.RestoreOp 0) + +(RPAQQ \DoveDisk.ReadDataOp 2) + +(RPAQQ \DoveDisk.ReadDiagnosticOp 8) + +(RPAQQ \DoveDisk.FormatTracksOp 1) + + +(CONSTANTS \DoveDisk.WriteLabelAndDataOp \DoveDisk.WriteDataOp \DoveDisk.VerifyDataOp + \DoveDisk.ReadLabelAndDataOp \DoveDisk.ReadLabelOp \DoveDisk.RestoreOp \DoveDisk.ReadDataOp + \DoveDisk.ReadDiagnosticOp \DoveDisk.FormatTracksOp) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveDisk.Execute 2) + +(RPAQQ \DoveDisk.FromLisp 0) + +(RPAQQ \DoveDisk.NoOperation 3) + +(RPAQQ \DoveDisk.NoopCmd 0) + +(RPAQQ \DoveDisk.Read 0) + +(RPAQQ \DoveDisk.ReadCmd 1) + +(RPAQQ \DoveDisk.ToLisp 1) + +(RPAQQ \DoveDisk.VerifyCmd 3) + +(RPAQQ \DoveDisk.Write 1) + +(RPAQQ \DoveDisk.WriteCmd 2) + + +(CONSTANTS \DoveDisk.Execute \DoveDisk.FromLisp \DoveDisk.NoOperation \DoveDisk.NoopCmd + \DoveDisk.Read \DoveDisk.ReadCmd \DoveDisk.ToLisp \DoveDisk.VerifyCmd \DoveDisk.Write + \DoveDisk.WriteCmd) +) +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD Dove.DCB ((MesaHead WORD) + (HandlerMesaNext WORD) + (MesaTail WORD) + (BlockMesaQueue WORD) + (IOPHead WORD) + (IOPHeadHi WORD) + (IOPNext WORD) + (IOPNextHi WORD) + (IOPTail WORD) + (IOPTailHi WORD) + (BlockIOPQueue WORD) + (CurrentDriveMask BYTE) + (DiskCommand BYTE) + (MesaClientCondition 3 WORD) + (IOPClientCondition 3 WORD) + (CurrentIOCB 2 WORD) + (Recalibrate FLAG) + (DiskMisc BITS 15) + (NIL BYTE) + (DriveType BYTE) + (SectorsPerTrack BYTE) + (HeadsPerCylinder BYTE) + (CylindersPerDrive.BS WORD) + (ReduceWriteCurrentCylinder.BS WORD) + (PrecompensationCylinder.BS WORD))) + +(BLOCKRECORD Dove.DOB ((ECCSyndromeA WORD) + (ECCSyndromeB WORD) + (NegativeSectorCount.BS WORD) + (SectorsPerTrack BYTE) + (Zero1 BYTE) + (HeadsPerCylinder BYTE) + (Zero2 BYTE) + (CylindersPerDrive.BS WORD) + (StartingSectorOnTrack BYTE) + (Zero3 BYTE) + (ReducedWriteCylinder.BS WORD) + (PrecompensationCylinder.BS WORD) + (WriteEndCount BYTE) + (Zero4 BYTE) + (HeaderError.BS WORD) + (LabelError.BS WORD) + (DataError.BS WORD) + (LastError.BS WORD) + (CurrentCylinder.BS WORD) + (ECCFlag BYTE) + (Zero5 BYTE) (* These fields are switched around + to byteswap them) + (Header.Cylinder.BS WORD) + (Header.Sector BYTE) + (Header.Head BYTE) + (Reserved1 WORD) + (Reserved2 WORD) + (Drive&ControllerStatus WORD) + (Operation BYTE) + (Zero6 BYTE) + (NegativeFormatTrackCount.BS WORD) + (Label.FileID 5 WORD) + (Label.FilePageLo WORD) + (Label.FilePageHi BITS 7) + (Label.PageZeroAttributes BITS 9) + (Label.AttributesInAllPages WORD) + (Label.Unused 2 WORD))) + +(MESARECORD Dove.DiskFCB ((DiskTCB DoveIO.TaskContextBlock) + (DiskDMATCB DoveIO.TaskContextBlock) + (ConditionDMAWork.BS WORD) + (ConditionDMADone.BS WORD) + (ConditionWork.BS WORD) + (WorkMask WORD) + (LockMask WORD) + (MesaCleanupRequest WORD) + (IOPCleanupRequest WORD) + (HandlerStoppedForMesa WORD) + (HandlerStoppedForIOP WORD) + (HandlerStoppedForMesaCleanup WORD) + (HandlerStoppedForIOPCleanup WORD) + (StartHandlerForMesa WORD) + (StartHandlerForIOP WORD) + (HandlerState WORD) + (CurrentClient BYTE) + (ClientsToTest BYTE) + (NumPossibleClients BYTE) + (LastDriveMask BYTE) + (CurrentDrivePtr WORD) + (StatusRegister BYTE) + (CommandRegister BYTE) + (TaskRetryCount BYTE) + (BadInterruptReason BYTE) + (DMAStatusRegister BYTE) + (BadDMAInterruptReason BYTE) + (UnexpectedDiskInterruptCount WORD) + (UnexpectedDiskDMAInterruptCount WORD) + (DCB0Base 25 WORD) + (DCB1Base 25 WORD) + (DCB2Base 25 WORD) + (DCB3Base 25 WORD))) + +(BLOCKRECORD Dove.DiskIOCB ((Header.Cylinder WORD) + (Header.Head BYTE) + (Header.Sector BYTE) + (LabelPtr FULLXPOINTER) + (DataPtr FULLXPOINTER) + (IncDataPtr FLAG) + (NIL BITS 1) + (HeaderCmd BITS 2) + (LabelCmd BITS 2) + (DataCmd BITS 2) + (RetryStrategy BYTE) + (PageCount WORD) + (DeviceStatus 2 WORD) + (DiskHeader 2 WORD) + (DeviceHandle WORD) + (MesaNext WORD) + (IOPNext 2 WORD) + (OpType BITS 2) + (LabelFixupType BITS 2) + (LabelFixupTry BITS 12) + (Try WORD) + (Command WORD) + (RunLength WORD) + (PageLocalization WORD) + (NIL 14 WORD) + (HDataPtr 2 WORD) + (HDataCommandTransfer FLAG) + (NIL BITS 6) + (HDataCommandDirection BITS 1) + (HIncDataPtr FLAG) + (HComplementDOB FLAG) + (HEtch BITS 1) + (NIL BITS 2) + (HUseLEDS FLAG) + (HHalt FLAG) + (HDiagnosticCommand FLAG) + (HPageCount WORD) + (HStopHandlerOnCompletion BYTE) + (HOnlyDOBFromController BYTE) + (HError BYTE) + (HDOBError BYTE) + (HControllerError BYTE) + (HDMAError BYTE) + (HComplete BYTE) + (HInProgress BYTE) + (HDataXferDirection BYTE) + (HDMATimedOut BYTE) + (HNextIOCB 2 WORD) + (DOBBase 33 WORD))) + +(BLOCKRECORD PilotDiskLabel ((FileID 2 WORD) + (NIL 3 WORD) + (FilePageLo WORD) + (FilePageHi WORD) + (NIL WORD) + (BootLinkA WORD) + (BootLinkB WORD))) +) + +(RPAQ? \DoveDisk.FCBPointer ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveDisk.FCBPointer) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\DISKDOVEINIT) +) +(PUTPROPS DOVEDISK COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (886 26064 (\DISKDOVEINIT 896 . 1685) (\DOVE.ACTONVMEMFILE 1687 . 2174) ( +\DOVE.ACTONVMEMPAGE 2176 . 4779) (\DOVE.XFERDISK 4781 . 7042) (\DoveDisk.CopyByteSwappedLabel 7044 . +7343) (\DoveDisk.ExecuteIOCB 7345 . 9152) (\DoveDisk.HandleMajorError 9154 . 10433) (\DoveDisk.Init +10435 . 12023) (\DoveDisk.InitIOCB 12025 . 22461) (\DoveDisk.Initiate 22463 . 25070) ( +\DoveDisk.TryRecalibrate 25072 . 25552) (\DoveDisk.WaitForHandlerStopped 25554 . 26062))))) +STOP diff --git a/sources/DOVEDISPLAY b/sources/DOVEDISPLAY new file mode 100644 index 00000000..5e81b4ad --- /dev/null +++ b/sources/DOVEDISPLAY @@ -0,0 +1,307 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 16:01:14" {DSK}local>lde>lispcore>sources>DOVEDISPLAY.;2 15064 + + changes to%: (VARS DOVEDISPLAYCOMS) + + previous date%: "10-Sep-87 18:41:35" {DSK}local>lde>lispcore>sources>DOVEDISPLAY.;1) + + +(* ; " +Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEDISPLAYCOMS) + +(RPAQQ DOVEDISPLAYCOMS + [(FNS \DoveDisplay.GetBorderPattern \DoveDisplay.Init \DoveDisplay.ScreenHeight + \DoveDisplay.ScreenWidth \DoveDisplay.SetBorderPattern \DoveDisplay.SetCursorMix + \DoveDisplay.SetCursorPosition \DoveDisplay.SetCursorShape \DoveDisplay.SetVideoColor + \DoveDisplay.TurnOn \DoveDisplay.GetCursorBitmapBase) + (INITVARS (\DoveDisplay.FCBPointer)) + (GLOBALVARS \DoveDisplay.FCBPointer) + + (* ;; "xoring cursor patch") + + (INITVARS (\DoveDisplay.XorCursor NIL)) + (GLOBALVARS \DoveDisplay.XorCursor) + (FNS DOVE.XOR.CURSOR) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + DOVEDECLS) + (RECORDS DoveDisplay.CursorBitmap Dove.DisplayDCtlRegister Dove.DisplayFCB) + (CONSTANTS * DoveDisplay.ChangeMasks) + (CONSTANTS * DoveDisplay.CursorDisplayMixRules)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DoveDisplay.Init))) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA DOVE.XOR.CURSOR]) +(DEFINEQ + +(\DoveDisplay.GetBorderPattern + [LAMBDA NIL (* ejs%: "12-Sep-85 20:25") + (fetch (Dove.DisplayFCB BorderPattern) of \DoveDisplay.FCBPointer]) + +(\DoveDisplay.Init + [LAMBDA NIL (* ejs%: "16-Sep-85 13:05") + (MAPC '(\DoveDisplay.FCBPointer) (FUNCTION \LOCKVAR)) + (MAPC '(\DoveDisplay.TurnOn \DoveDisplay.SetCursorShape \DoveDisplay.SetCursorPosition + \DoveDisplay.GetCursorBitmapBase \DoveDisplay.SetCursorMix \DoveDisplay.ScreenWidth + \DoveDisplay.ScreenHeight) (FUNCTION \LOCKFN]) + +(\DoveDisplay.ScreenHeight + [LAMBDA NIL (* ejs%: "12-Sep-85 20:26") + (\DoveIO.ByteSwap (fetch (Dove.DisplayFCB ScreenHeight.BS) of \DoveDisplay.FCBPointer]) + +(\DoveDisplay.ScreenWidth + [LAMBDA NIL (* ejs%: "12-Sep-85 20:26") + (\DoveIO.ByteSwap (fetch (Dove.DisplayFCB ScreenWidth.BS) of \DoveDisplay.FCBPointer]) + +(\DoveDisplay.SetBorderPattern + [LAMBDA (SHADE) (* ejs%: "12-Sep-85 20:29") + (replace (Dove.DisplayFCB BorderPattern) of \DoveDisplay.FCBPointer with SHADE) + (\DoveIO.LockMem \DoveIO.OR [IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo] + \DoveDisplay.BorderPatternChangedMask NIL]) + +(\DoveDisplay.SetCursorMix + [LAMBDA (MIX) (* ejs%: "12-Sep-85 20:29") + (replace (Dove.DisplayDCtlRegister dataCursor) of (LOCF (fetch (Dove.DisplayFCB + DisplayControlRegister) + of \DoveDisplay.FCBPointer)) + with MIX) + (\DoveIO.LockMem \DoveIO.OR (IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo) + of T))) + \DoveDisplay.DisplayInfoChangedMask NIL]) + +(\DoveDisplay.SetCursorPosition + [LAMBDA (X Y) (* ejs%: "12-Sep-85 20:29") + (replace (Dove.DisplayFCB CursorXCoord.BS) of \DoveDisplay.FCBPointer with (\DoveIO.ByteSwap + X)) + (replace (Dove.DisplayFCB CursorYCoord.BS) of \DoveDisplay.FCBPointer with (\DoveIO.ByteSwap + Y)) + (\DoveIO.LockMem \DoveIO.OR [IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo] + \DoveDisplay.CursorPosChangedMask NIL]) + +(\DoveDisplay.SetCursorShape + [LAMBDA (BITMAP) (* ejs%: "13-Sep-85 00:53") + + (* * This makes some assumptions about the bitmap passed to it...) + + (* * Unless it's NIL, then we just tell the IOP the bitmap changed.) + + (* * This functions runs locked down, unless referencing the bitmap makes it + page fault.) + + (COND + (BITMAP (\BLT (fetch (Dove.DisplayFCB CursorBitmap) of \DoveDisplay.FCBPointer) + (fetch (BITMAP BITMAPBASE) of BITMAP) + 16))) + (\DoveIO.LockMem \DoveIO.OR [IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo] + \DoveDisplay.CursorMapChangedMask NIL]) + +(\DoveDisplay.SetVideoColor + [LAMBDA (INVERSE?) (* ejs%: "12-Sep-85 20:29") + [LET ((FCB \DoveDisplay.FCBPointer)) + (COND + (INVERSE? (replace (Dove.DisplayDCtlRegister dataCursor) + of (LOCF (fetch (Dove.DisplayFCB DisplayControlRegister) of FCB)) + with DoveDisplay.CursorORScreenInverted)) + (T (replace (Dove.DisplayDCtlRegister dataCursor) of (LOCF (fetch (Dove.DisplayFCB + DisplayControlRegister + ) of FCB)) + with DoveDisplay.CursorORScreenNormal] + (\DoveIO.LockMem \DoveIO.OR [IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo] + \DoveDisplay.BackgroundChangedMask NIL]) + +(\DoveDisplay.TurnOn + [LAMBDA NIL (* ejs%: "12-Sep-85 20:29") + (SETQ \DoveDisplay.FCBPointer (\DoveIO.GetHandlerIORegionPtr DoveIO.displayHandler)) + (replace (Dove.DisplayFCB CursorXCoord.BS) of \DoveDisplay.FCBPointer with 0) + (replace (Dove.DisplayFCB CursorYCoord.BS) of \DoveDisplay.FCBPointer with 0) + (replace (Dove.DisplayFCB BorderPattern) of \DoveDisplay.FCBPointer with (CONSTANT + WINDOWBACKGROUNDSHADE + )) + (replace (Dove.DisplayDCtlRegister dataCursor) of (LOCF (fetch (Dove.DisplayFCB + DisplayControlRegister) + of \DoveDisplay.FCBPointer)) + with DoveDisplay.DefaultMixRule) + (replace (Dove.DisplayDCtlRegister picture) of (LOCF (fetch (Dove.DisplayFCB + DisplayControlRegister) + of \DoveDisplay.FCBPointer)) with T) + (\DoveIO.LockMem \DoveIO.OR [IPLUS (\DoveIO.IORegionOffset \DoveDisplay.FCBPointer) + (INDEXF (fetch (Dove.DisplayFCB DisplayChangedInfo] + \DoveDisplay.AllInfoChangedMask NIL]) + +(\DoveDisplay.GetCursorBitmapBase + [LAMBDA NIL (* ejs%: "13-Sep-85 00:31") + (fetch (Dove.DisplayFCB CursorBitmap) of \DoveDisplay.FCBPointer]) +) + +(RPAQ? \DoveDisplay.FCBPointer ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveDisplay.FCBPointer) +) + + + +(* ;; "xoring cursor patch") + + +(RPAQ? \DoveDisplay.XorCursor NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveDisplay.XorCursor) +) +(DEFINEQ + +(DOVE.XOR.CURSOR + [LAMBDA NARGS (* ; "Edited 10-Sep-87 18:41 by jop") + + (DECLARE (GLOBALVARS \VideoColor)) + (PROG1 \DoveDisplay.XorCursor (IF (EQ NARGS 1) + THEN (SETQ \DoveDisplay.XorCursor (AND (ARG NARGS 1) + T)) + (if (EQ (MACHINETYPE) + 'DOVE) + then (\DoveDisplay.SetCursorMix + (SELECTQ \DoveDisplay.XorCursor + (NIL (SELECTQ \VideoColor + (NIL + DoveDisplay.CursorORScreenNormal) + (T + DoveDisplay.CursorORScreenInverted) + (SHOULDNT + "Bad value for \VideoColor") + )) + (T (SELECTQ \VideoColor + (NIL + DoveDisplay.CursorXORScreenNormal) + (T + DoveDisplay.CursorXORScreenInverted) + (SHOULDNT "Bad value for \VideoColor" + ))) + (SHOULDNT + "Bad value for \DoveDisplay.XorCursor" + ]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + DOVEDECLS) + +(DECLARE%: EVAL@COMPILE + +(MESATYPE DoveDisplay.CursorBitmap (16 WORD)) + +(BLOCKRECORD Dove.DisplayDCtlRegister ((dataCursor BITS 4) + (picture FLAG) + (NIL BITS 1) + (dontUse BITS 2))) + +(MESARECORD Dove.DisplayFCB ((DisplayTCB DoveIO.TaskContextBlock) + (DisplayLOCK.BS WORD) + (DisplayChangedInfo WORD) + (VerticalRetraceEvent DoveIO.ClientCondition) + (CursorXCoord.BS WORD) + (CursorYCoord.BS WORD) + (BorderPattern WORD) + (CursorBitmap DoveDisplay.CursorBitmap) + (DisplayControlRegister BYTE) + (CursorMixRule BITS 4) + (NIL BITS 4) + (ScreenWidth.BS WORD) + (ScreenHeight.BS WORD) + (DisplayConfig BYTE) + (NIL BYTE) + (ColorParams.BS WORD) + (CursorXCoordOffset.BS WORD) + (CursorYCoordOffset.BS WORD) + (PixelsPerInch BYTE) + (RefreshRate BYTE))) +) + + +(RPAQQ DoveDisplay.ChangeMasks ((\DoveDisplay.AllInfoChangedMask 248) + (\DoveDisplay.BackgroundChangedMask 16) + (\DoveDisplay.BorderPatternChangedMask 32) + (\DoveDisplay.CursorMapChangedMask 64) + (\DoveDisplay.CursorPosChangedMask 128) + (\DoveDisplay.DisplayInfoChangedMask 8) + (\DoveDisplay.PictureBorderPatternChangedMask 40))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveDisplay.AllInfoChangedMask 248) + +(RPAQQ \DoveDisplay.BackgroundChangedMask 16) + +(RPAQQ \DoveDisplay.BorderPatternChangedMask 32) + +(RPAQQ \DoveDisplay.CursorMapChangedMask 64) + +(RPAQQ \DoveDisplay.CursorPosChangedMask 128) + +(RPAQQ \DoveDisplay.DisplayInfoChangedMask 8) + +(RPAQQ \DoveDisplay.PictureBorderPatternChangedMask 40) + + +(CONSTANTS (\DoveDisplay.AllInfoChangedMask 248) + (\DoveDisplay.BackgroundChangedMask 16) + (\DoveDisplay.BorderPatternChangedMask 32) + (\DoveDisplay.CursorMapChangedMask 64) + (\DoveDisplay.CursorPosChangedMask 128) + (\DoveDisplay.DisplayInfoChangedMask 8) + (\DoveDisplay.PictureBorderPatternChangedMask 40)) +) + + +(RPAQQ DoveDisplay.CursorDisplayMixRules ((DoveDisplay.DefaultMixRule 1) + (DoveDisplay.CursorORScreenNormal 1) + (DoveDisplay.CursorORScreenInverted 14) + (DoveDisplay.CursorXORScreenNormal 9) + (DoveDisplay.CursorXORScreenInverted 6))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ DoveDisplay.DefaultMixRule 1) + +(RPAQQ DoveDisplay.CursorORScreenNormal 1) + +(RPAQQ DoveDisplay.CursorORScreenInverted 14) + +(RPAQQ DoveDisplay.CursorXORScreenNormal 9) + +(RPAQQ DoveDisplay.CursorXORScreenInverted 6) + + +(CONSTANTS (DoveDisplay.DefaultMixRule 1) + (DoveDisplay.CursorORScreenNormal 1) + (DoveDisplay.CursorORScreenInverted 14) + (DoveDisplay.CursorXORScreenNormal 9) + (DoveDisplay.CursorXORScreenInverted 6)) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\DoveDisplay.Init) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA DOVE.XOR.CURSOR) +) +(PUTPROPS DOVEDISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1736 8503 (\DoveDisplay.GetBorderPattern 1746 . 1957) (\DoveDisplay.Init 1959 . 2400) ( +\DoveDisplay.ScreenHeight 2402 . 2629) (\DoveDisplay.ScreenWidth 2631 . 2856) ( +\DoveDisplay.SetBorderPattern 2858 . 3323) (\DoveDisplay.SetCursorMix 3325 . 4062) ( +\DoveDisplay.SetCursorPosition 4064 . 4816) (\DoveDisplay.SetCursorShape 4818 . 5697) ( +\DoveDisplay.SetVideoColor 5699 . 6736) (\DoveDisplay.TurnOn 6738 . 8286) ( +\DoveDisplay.GetCursorBitmapBase 8288 . 8501)) (8768 10996 (DOVE.XOR.CURSOR 8778 . 10994))))) +STOP diff --git a/sources/DOVEETHER b/sources/DOVEETHER new file mode 100644 index 00000000..8158939a --- /dev/null +++ b/sources/DOVEETHER @@ -0,0 +1,381 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 16:02:49" {DSK}local>lde>lispcore>sources>DOVEETHER.;2 20988 + + changes to%: (VARS DOVEETHERCOMS) + + previous date%: "17-Dec-86 18:51:25" {DSK}local>lde>lispcore>sources>DOVEETHER.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEETHERCOMS) + +(RPAQQ DOVEETHERCOMS + [(FNS \DoveEther.ByteSwapIOCB \DoveEther.DeQueue \DoveEther.EnQueue \DoveEther.GetPacketStatus + \DoveEther.Init \DoveEther.Initiate \DoveEther.MakeSureOff \DoveEther.QueueInput + \DoveEther.QueueOutput \DoveEther.TurnOn) + (INITVARS (\DoveEther.FCBPointer)) + (GLOBALVARS \DoveEther.FCBPointer) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + 10MBDECLS DOVEDECLS DOVEETHERDECLS LLNSDECLS)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DoveEther.Init]) +(DEFINEQ + +(\DoveEther.ByteSwapIOCB + [LAMBDA (IOCB) (* ejs%: "11-Sep-85 22:46") + +(* ;;; "There are various IOCB fields which must be fed to Opie in byte-swapped form. This function swaps them") + + (replace (Dove.EtherIOCB i586Status) of IOCB with (\DoveIO.ByteSwap (fetch (Dove.EtherIOCB + i586Status) + of IOCB))) + (SELECTC (fetch (Dove.EtherIOCB IOCBType) of IOCB) + ((LIST DoveEther.inputIOCBType DoveEther.outputIOCBType) + (replace (Dove.EtherIOIOCB length) of IOCB with (\DoveIO.ByteSwap (fetch ( + Dove.EtherIOIOCB + length) + of IOCB))) + (replace (Dove.EtherIOIOCB count) of IOCB with (\DoveIO.ByteSwap (fetch ( + Dove.EtherIOIOCB + count) + of IOCB)))) + (DoveEther.commandIOCBType + (SELECTC (fetch (Dove.EtherIOCB Action) of IOCB) + (DoveEther.actionTimeDomainRfl + (\PUTBASE (fetch (Dove.EtherCommandIOCB select) of IOCB) + 0 + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.EtherCommandIOCB select) + of IOCB) + 0)))) + (DoveEther.actionMulticastAddr + (\PUTBASE (fetch (Dove.EtherCommandIOCB select) of IOCB) + 0 + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.EtherCommandIOCB select) + of IOCB) + 0)))) + (PROGN NIL))) + ((LIST DoveEther.resetIOCBType DoveEther.startRUIOCBType) + NIL) + (ERROR "Unknown ethernet IOCB type for ByteSwapIOCB" (fetch (Dove.EtherIOCB IOCBType) + of IOCB]) + +(\DoveEther.DeQueue + [LAMBDA (QueuePtr IOCB) (* ejs%: "14-Nov-85 20:40") + (LET ((Chase (fetch (Dove.QueueBlock LispQueueHead) of QueuePtr))) + (COND + (Chase (* ; "There's something in the queue") + (COND + [(EQ Chase IOCB) (* ; + "Optimal: the wanted IOCB is at the head of the queue") + (MESASETQ (fetch (Dove.QueueBlock QueueHead) of QueuePtr) + (fetch (Dove.EtherIOCB next) of IOCB) + Dove.OpieAddress) + (COND + ((EQ (fetch (Dove.QueueBlock LispQueueTail) of QueuePtr) + IOCB) (* ; + "It's also at the tail; the queue is now empty") + (replace (Dove.QueueBlock LispQueueTail) of QueuePtr with NIL] + (T (* ; + "The IOCB is in the middle of the queue") + (while Chase do (COND + ((EQ (fetch (Dove.EtherIOCB nextIOCB) of Chase) + IOCB) (* ; "Found it") + (MESASETQ (fetch (Dove.EtherIOCB next) of Chase) + (fetch (Dove.EtherIOCB next) of IOCB) + Dove.OpieAddress) + (COND + ((EQ (fetch (Dove.QueueBlock LispQueueTail) + of QueuePtr) + IOCB) (* ; + "The wanted IOCB was at the tail of the queue and not at the head of the queue") + (replace (Dove.QueueBlock LispQueueTail) + of QueuePtr with Chase))) + (RETURN)) + (T (SETQ Chase (fetch (Dove.EtherIOCB nextIOCB) + of Chase]) + +(\DoveEther.EnQueue + [LAMBDA (QueuePtr IOCB) (* edited%: "31-Dec-00 16:00") + +(* ;;; "Enqueues IOCB on IOP Queueblock at QueuePtr") + + (COND + ((NULL (fetch (Dove.QueueBlock LispQueueHead) of QueuePtr)) + (replace (Dove.QueueBlock LispQueueHead) of QueuePtr with IOCB)) + (T (replace (Dove.EtherIOCB nextIOCB) of (fetch (Dove.QueueBlock LispQueueTail) of QueuePtr) + with IOCB))) + (replace (Dove.EtherIOCB nextIOCB) of IOCB with NIL) + (\DoveIO.LockMem \DoveIO.OVERWRITEIFNIL (\DoveIO.IORegionOffset (fetch (Dove.QueueBlock QueueNext + ) of QueuePtr)) + (\DoveIO.ByteSwap (\LOLOC IOCB)) + (fetch (Dove.EtherFCB etherLockMask) of \DoveEther.FCBPointer)) + (replace (Dove.QueueBlock LispQueueTail) of QueuePtr with IOCB]) + +(\DoveEther.GetPacketStatus + [LAMBDA (IOCB) (* ejs%: "12-Sep-85 20:08") + (LET ((IOCBType (fetch (Dove.EtherIOCB IOCBType) of IOCB))) + (COND + ((NOT (fetch (Dove.EtherIOCB done) of IOCB)) + \ES.PENDING) + (T [COND + ((NOT (fetch (Dove.EtherIOCB isDequeued) of IOCB)) + (* ; + "Dequeue the packet and byte swap it for us") + (UNINTERRUPTABLY + (\DoveEther.DeQueue (COND + ((EQ IOCBType DoveEther.inputIOCBType) + (fetch (Dove.EtherFCB mesaInQueue) of + \DoveEther.FCBPointer + )) + (T (* ; + "Output and command IOCBs go on the mesaOutQueue, I think") + (fetch (Dove.EtherFCB mesaOutQueue) of + \DoveEther.FCBPointer + ))) + IOCB) + (\DoveEther.ByteSwapIOCB IOCB) + (replace (Dove.EtherIOCB isDequeued) of IOCB with T))] + (SELECTC IOCBType + (DoveEther.inputIOCBType + (COND + ((fetch (Dove.EtherIOCB okay) of IOCB) + (bind (PTR _ (fetch (Dove.EtherIOIOCB bufferAddress) of IOCB)) + for I from (FOLDHI (fetch (Dove.EtherIOIOCB length) of IOCB) + BYTESPERWORD) to 0 by (IMINUS WORDSPERPAGE) + do (\PUTBASE PTR I (\GETBASE PTR I))) + \ES.GOOD.PACKET) + ((fetch (Dove.Etheri586Status ovrnErr) of (LOCF (fetch (Dove.EtherIOCB + i586Status) + of IOCB))) + \ES.OVERRUN) + ((fetch (Dove.Etheri586Status crcErr) of (LOCF (fetch (Dove.EtherIOCB + i586Status) + of IOCB))) + \ES.BAD.CRC) + ((fetch (Dove.Etheri586Status alnErr) of (LOCF (fetch (Dove.EtherIOCB + i586Status) + of IOCB))) + \ES.BAD.ALIGNMENT) + ((fetch (Dove.EtherIOCB frameTooLong) of IOCB) + \ES.PACKET.TOO.LONG) + (T \ES.OTHER.ERROR))) + (DoveEther.outputIOCBType + (COND + ((fetch (Dove.EtherIOCB okay) of IOCB) + \ES.GOOD.PACKET) + ((fetch (Dove.EtherIOCB frameTooLong) of IOCB) + \ES.PACKET.TOO.LONG) + ((fetch (Dove.Etheri586Status underrun) of (LOCF (fetch (Dove.EtherIOCB + i586Status) + of IOCB))) + \ES.UNDERRUN) + ((fetch (Dove.Etheri586Status tooManyCollisions) + of (LOCF (fetch (Dove.EtherIOCB i586Status) of IOCB))) + \ES.TOO.MANY.COLLISIONS) + (T \ES.OTHER.ERROR))) + (COND + ((fetch (Dove.EtherIOCB okay) of IOCB) + \ES.GOOD.PACKET) + (T \ES.OTHER.ERROR]) + +(\DoveEther.Init + [LAMBDA NIL (* ejs%: "16-Sep-85 12:57") + (MAPC '(\DoveEther.FCBPointer) (FUNCTION \LOCKVAR]) + +(\DoveEther.Initiate + [LAMBDA (IOCB) (* ejs%: "12-Sep-85 20:08") + +(* ;;; "Queues a command-like IOCB on the ethernet output queue") + + (* ;; "Fill in the IOCB") + + (PROGN (\CLEARWORDS (fetch (Dove.EtherIOCB ClientCondition) of IOCB) + \DoveEther.ClientConditionSize) + (replace (Dove.EtherIOCB nextIOCB) of IOCB with NIL) + (replace (Dove.EtherIOCB Status) of IOCB with 0)) + + (* ;; "Byte Swap for Opie") + + (\DoveEther.ByteSwapIOCB IOCB) + + (* ;; "Put it on queue for output") + + (\DoveEther.EnQueue (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) + IOCB) + + (* ;; "Tell the IOP there's something there") + + (\DoveIO.NotifyIOP (fetch (Dove.EtherFCB etherOutWorkMask) of \DoveEther.FCBPointer]) + +(\DoveEther.MakeSureOff + [LAMBDA (oldMesaOutQueueLoc) (* ejs%: "30-Oct-85 18:54") + +(* ;;; "This fn makes sure the ethernet is OFF") + + (replace (Dove.EtherFCB mesaClientStateRequest) of \DoveEther.FCBPointer with + \DoveEther.RequestOFF + ) + (\DoveIO.NotifyIOP (fetch (Dove.EtherFCB etherInWorkMask) of \DoveEther.FCBPointer)) + (\DoveIO.NotifyIOP (fetch (Dove.EtherFCB etherOutWorkMask) of \DoveEther.FCBPointer)) + (until (EQ (fetch (Dove.EtherFCB mesaOutClientState) of \DoveEther.FCBPointer) + \DoveEther.RequestOFF)) + (COND + (oldMesaOutQueueLoc (MESASETQ oldMesaOutQueueLoc (fetch (Dove.EtherFCB mesaOutQueue) + of \DoveEther.FCBPointer) + Dove.QueueBlock) + (MESASETQ (\ADDBASE oldMesaOutQueueLoc (MESASIZE Dove.QueueBlock)) + (fetch (Dove.EtherFCB mesaInQueue) of \DoveEther.FCBPointer) + Dove.QueueBlock]) + +(\DoveEther.QueueInput + [LAMBDA (IOCB BUF LEN) (* ejs%: "12-Sep-85 20:08") + +(* ;;; "Queues a packet NIL associated IOCB on the input queue") + + (* ;; "Fill in the IOCB") + + (PROGN (\CLEARWORDS (fetch (Dove.EtherIOCB ClientCondition) of IOCB) + \DoveEther.ClientConditionSize) + (replace (Dove.EtherIOIOCB bufferAddress) of IOCB with BUF) + (replace (Dove.EtherIOIOCB length) of IOCB with (UNFOLD LEN BYTESPERWORD)) + (replace (Dove.EtherIOCB nextIOCB) of IOCB with NIL) + (replace (Dove.EtherIOCB Status) of IOCB with 0) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.inputIOCBType)) + + (* ;; "Byte swap for Opie") + + (\DoveEther.ByteSwapIOCB IOCB) + + (* ;; "Put it on queue for output") + + (\DoveEther.EnQueue (fetch (Dove.EtherFCB mesaInQueue) of \DoveEther.FCBPointer) + IOCB) + + (* ;; "Tell the IOP there's something there") + + (\DoveIO.NotifyIOP (fetch (Dove.EtherFCB etherInWorkMask) of \DoveEther.FCBPointer]) + +(\DoveEther.QueueOutput + [LAMBDA (IOCB BUF LEN) (* ejs%: "12-Sep-85 20:08") + +(* ;;; "Queues a packet NIL associated IOCB on the output queue") + + (* ;; "Must mark it referenced") + + (\GETBASE BUF 0) + (COND + ((IGREATERP LEN WORDSPERPAGE) + (\GETBASE BUF WORDSPERPAGE))) + + (* ;; "Fill in the IOCB") + + (PROGN (\CLEARWORDS (fetch (Dove.EtherIOCB ClientCondition) of IOCB) + \DoveEther.ClientConditionSize) + (replace (Dove.EtherIOIOCB length) of IOCB with (UNFOLD LEN BYTESPERWORD)) + (replace (Dove.EtherIOIOCB bufferAddress) of IOCB with BUF) + (replace (Dove.EtherIOCB nextIOCB) of IOCB with NIL) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.outputIOCBType) + (replace (Dove.EtherIOCB Status) of IOCB with 0)) + + (* ;; "Byte Swap for Opie") + + (\DoveEther.ByteSwapIOCB IOCB) + + (* ;; "Put it on queue for output") + + (\DoveEther.EnQueue (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) + IOCB) + + (* ;; "Tell the IOP there's something there") + + (\DoveIO.NotifyIOP (fetch (Dove.EtherFCB etherOutWorkMask) of \DoveEther.FCBPointer]) + +(\DoveEther.TurnOn + [LAMBDA (NSHostNumber oldMesaOutQueueLoc) (* ejs%: "30-Oct-85 18:57") + +(* ;;; "Turns on Daybreak ether driver") + + (SETQ \DoveEther.FCBPointer (\DoveIO.GetHandlerIORegionPtr DoveIO.ethernetHandler)) + (\DoveEther.MakeSureOff) + [COND + (oldMesaOutQueueLoc (MESASETQ (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) + oldMesaOutQueueLoc Dove.QueueBlock) + (MESASETQ (fetch (Dove.EtherFCB mesaInQueue) of \DoveEther.FCBPointer) + (\ADDBASE oldMesaOutQueueLoc (MESASIZE Dove.QueueBlock)) + Dove.QueueBlock)) + (T (\CLEARWORDS (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) + (MESASIZE Dove.QueueBlock)) + (\CLEARWORDS (fetch (Dove.EtherFCB mesaInQueue) of \DoveEther.FCBPointer) + (MESASIZE Dove.QueueBlock] + (replace (Dove.EtherFCB mesaClientStateRequest) of \DoveEther.FCBPointer with + \DoveEther.RequestON + ) + + (* ;; "Entirely too horrible kludge! We need a segment 0 storage allocator in this system!") + + (LET ((IOCB (\ADDBASE \IOPAGE 64))) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.resetIOCBType) + (COND + ((\DoveEther.DoOutput IOCB) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.commandIOCBType) + (replace (Dove.EtherIOCB Action) of IOCB with DoveEther.actionConfigure) + (LET ((Conf (fetch (Dove.EtherCommandIOCB select) of IOCB))) + (\CLEARBYTES (fetch (Dove.EtherCommandIOCB select) of IOCB) + 0 + (UNFOLD (IDIFFERENCE (MESASIZE Dove.EtherCommandIOCB) + (MESASIZE Dove.EtherIOCB)) + BYTESPERWORD)) + (with Dove.EtherConfigure Conf (SETQ ByteCount 9) + (SETQ FifoLimit 11) + (SETQ SaveBadFrames NIL) + (SETQ PreambleLength 2) + (SETQ AddrTypeLoc 1) + (SETQ AddrLength 6) + (SETQ InterframeSpacing 96) + (SETQ RetryNumber 15) + (SETQ SlotTimeHigh 2) + (SETQ PromiscuousMode (AND (LISTP NSHostNumber) + (EQUAL NSHostNumber BROADCASTNSHOSTNUMBER))) + (SETQ MinFrameLength 64)) + (COND + ((\DoveEther.DoOutput IOCB) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.commandIOCBType) + (replace (Dove.EtherIOCB Action) of IOCB with DoveEther.actionIndividualAddr) + (COND + ((OR (NULL NSHostNumber) + (EQ NSHostNumber T)) + (\BLT (fetch (Dove.EtherCommandIOCB select) of IOCB) + (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage)) + \#WDS.NSHOSTNUMBER)) + (T (\STORENSHOSTNUMBER (fetch (Dove.EtherCommandIOCB select) of IOCB) + NSHostNumber))) + (COND + ((\DoveEther.DoOutput IOCB) + (replace (Dove.EtherIOCB IOCBType) of IOCB with DoveEther.startRUIOCBType) + (\DoveEther.DoOutput IOCB]) +) + +(RPAQ? \DoveEther.FCBPointer ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveEther.FCBPointer) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + 10MBDECLS DOVEDECLS DOVEETHERDECLS LLNSDECLS) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\DoveEther.Init) +) +(PUTPROPS DOVEETHER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1003 20612 (\DoveEther.ByteSwapIOCB 1013 . 3676) (\DoveEther.DeQueue 3678 . 6303) ( +\DoveEther.EnQueue 6305 . 7289) (\DoveEther.GetPacketStatus 7291 . 11856) (\DoveEther.Init 11858 . +12031) (\DoveEther.Initiate 12033 . 12997) (\DoveEther.MakeSureOff 12999 . 14173) ( +\DoveEther.QueueInput 14175 . 15415) (\DoveEther.QueueOutput 15417 . 16827) (\DoveEther.TurnOn 16829 + . 20610))))) +STOP diff --git a/sources/DOVEETHERDECLS b/sources/DOVEETHERDECLS new file mode 100644 index 00000000..a2cd6f5a --- /dev/null +++ b/sources/DOVEETHERDECLS @@ -0,0 +1,293 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 16:04:03" {DSK}local>lde>lispcore>sources>DOVEETHERDECLS.;2 14397 + + changes to%: (VARS DOVEETHERDECLSCOMS) + + previous date%: "17-Dec-86 18:38:00" {DSK}local>lde>lispcore>sources>DOVEETHERDECLS.;1) + + +(* ; " +Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEETHERDECLSCOMS) + +(RPAQQ DOVEETHERDECLSCOMS + ((FILES MESATYPES) + (RECORDS Dove.EtherSCB) + (RECORDS Dove.EtherAddr Dove.EtherConfigure Dove.EtherDumpStatus Dove.EtherFCB + Dove.Etheri586Status Dove.EtherIOCB Dove.EtherCommandIOCB Dove.EtherIOIOCB + Dove.EtherMulticastAddr Dove.EtherTransmit Dove.RxBufferDesc Dove.RxFrameDesc + Dove.TimeDomainRFL) + (FUNCTIONS \DoveEther.DoOutput) + (CONSTANTS \DoveEther.MulticastAddr \DoveEther.QueuePtrSize \DoveEther.ClientConditionSize + \DoveEther.IOIOCBLength \DoveEther.RequestON \DoveEther.RequestOFF) + (CONSTANTS * DoveEther.IOCBTypes) + (CONSTANTS * DoveEther.ActionCommands))) + +(FILESLOAD MESATYPES) +(DECLARE%: EVAL@COMPILE + +(MESARECORD Dove.EtherSCB ((stat BITS 4) + (NIL BITS 1) + (cus BITS 3) (* command unit status) + (NIL BITS 1) + (rus BITS 3) (* receive unit status) + (NIL BITS 4) + (ack BITS 4) (* acknowledge int) + (NIL BITS 1) + (cuc BITS 3) (* command unit command) + (reset FLAG) + (ruc BITS 3) (* receive unit command) + (NIL BITS 4) + (cblOffset WORD) + (rfaOffset WORD) + (crcErrs WORD) + (alnErrs WORD) + (rscErrs WORD) + (ovrnErrs WORD))) +) +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD Dove.EtherAddr ((id 3 WORD))) + +(MESARECORD Dove.EtherConfigure ((NIL BITS 4) + (ByteCount BITS 4) + (NIL BITS 4) + (FifoLimit BITS 4) + (SaveBadFrames FLAG) + (SyncReady FLAG) + (NIL BITS 6) + (ExternalLoopBack FLAG) + (InternalLoopBack FLAG) + (PreambleLength BITS 2) + (AddrTypeLoc BITS 1) + (AddrLength BITS 3) + (ExpBackoffMethod BITS 1) + (AccContRes BITS 3) + (NIL BITS 1) + (LinearPolarity BITS 3) + (InterframeSpacing BYTE) + (SlotTimeLow BYTE) + (RetryNumber BITS 4) + (NIL BITS 1) + (SlotTimeHigh BITS 3) + (Padding FLAG) + (BitStuffing FLAG) + (CRC16 FLAG) + (NoCRCInsertion FLAG) + (TxNoCRS FLAG) + (NRZEncoding FLAG) + (BroadcastDisable FLAG) + (PromiscuousMode FLAG) + (InternalCDT FLAG) + (CDTFilter BITS 3) + (InternalCRS FLAG) + (CRSFilter BITS 3) + (MinFrameLength BYTE) + (NIL BYTE))) + +(BLOCKRECORD Dove.EtherDumpStatus ((Buffer WORD))) + +(MESARECORD Dove.EtherFCB ((mesaOutQueue Dove.QueueBlock) + (mesaInQueue Dove.QueueBlock) + (mesaClientStateRequest WORD) + (scb Dove.EtherSCB) + (etherOutWorkMask WORD) + (etherInWorkMask WORD) + (etherLockMask WORD) + (mesaInClientState WORD) + (mesaOutClientState WORD))) + +(BLOCKRECORD Dove.Etheri586Status ((completion FLAG) + (busy FLAG) + (okay FLAG)) + (BLOCKRECORD Dove.Etheri586Status ((NIL BITS 3) + (* receiveframe variant) + (unused FLAG) + (crcErr FLAG) + (alnErr FLAG) + (rscErr FLAG) + (ovrnErr FLAG) + (frameTooShort FLAG) + (noEOFFlag FLAG) + (NIL BITS 6))) + (BLOCKRECORD Dove.Etheri586Status ((NIL BITS 3) + (* command variant. + Mainly for transmit) + (aborted FLAG) + (NIL FLAG) + (noCRS FLAG) + (lossOfCTS FLAG) + (underrun FLAG) + (deferred FLAG) + (sqeTest FLAG) + (tooManyCollisions FLAG) + (NIL BITS 1) + (collisions BITS 4)))) + +(MESARECORD Dove.EtherIOCB ((next Dove.OpieAddress) (* Next IOCB in IO queue) + (ClientCondition 3 WORD) (* Gets notifed in Mesaland when IO + is complete) + (i586Status WORD) (* Status from the Dove ethernet + coprocessor) + (Status BYTE) (* IO status?) + (IOCBType BITS 4) (* What type of IO operation is + this?) + (Action BITS 4) (* Used only for Command variant) + ) + [ACCESSFNS ((nextIOCB (fetch (Dove.OpieAddress LispPointer) + of (fetch (Dove.EtherIOCB next) + of DATUM)) + (replace (Dove.OpieAddress LispPointer) + of (fetch (Dove.EtherIOCB next) + of DATUM) with NEWVALUE] + (BLOCKRECORD Dove.EtherIOCB ((NIL 6 WORD) + (done FLAG) + (handled FLAG) + (okay FLAG) + (frameTooLong FLAG) + (interruptTimeout FLAG) + (NIL BITS 2) + (isDequeued FLAG)))) + +(MESARECORD Dove.EtherCommandIOCB ((iocbCommon Dove.EtherIOCB) + (select 7 WORD))) + +(MESARECORD Dove.EtherIOIOCB ((iocbCommon Dove.EtherIOCB) + (address Dove.OpieAddress) + (length WORD) + (count WORD)) + [ACCESSFNS ((bufferAddress (fetch (Dove.OpieAddress LispPointer) + of (fetch (Dove.EtherIOIOCB + address) + of DATUM)) + (replace (Dove.OpieAddress LispPointer) + of (fetch (Dove.EtherIOIOCB address) + of DATUM) with NEWVALUE]) + +(BLOCKRECORD Dove.EtherMulticastAddr ((ByteCount WORD) + (MulticastID1 3 WORD) + (MulticastID2 3 WORD))) + +(BLOCKRECORD Dove.EtherTransmit ((BdPtr WORD) + (DestAddr 3 WORD) + (Type WORD))) + +(BLOCKRECORD Dove.RxBufferDesc ((EndOfFrame FLAG) + (Filled FLAG) + (ActualCount BITS 14) + (Next WORD) + (BufAddrIOPReal WORD) + (EndOfList FLAG) + (Unused FLAG) + (Size BITS 14))) + +(BLOCKRECORD Dove.RxFrameDesc ((Status WORD) + (EndOfList FLAG) + (Suspend FLAG) + (NIL BITS 14) + (Link WORD) + (BDPtr WORD) + (DestAddr 3 WORD) + (SourceAddr 3 WORD) + (Type WORD))) + +(BLOCKRECORD Dove.TimeDomainRFL ((LinkOK FLAG) + (XcvrProblem FLAG) + (Open FLAG) + (Short FLAG) + (NIL FLAG) + (Time BITS 11))) +) + +(DEFMACRO \DoveEther.DoOutput (IOCB) + `(PROGN (\DoveEther.Initiate ,IOCB) + (until (fetch (Dove.EtherIOCB done) of ,IOCB)) + (\DoveEther.DeQueue (fetch (Dove.EtherFCB mesaOutQueue) of \DoveEther.FCBPointer) + ,IOCB) + (fetch (Dove.EtherIOCB okay) of ,IOCB))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveEther.MulticastAddr 3) + +(RPAQQ \DoveEther.QueuePtrSize 6) + +(RPAQQ \DoveEther.ClientConditionSize 3) + +(RPAQQ \DoveEther.IOIOCBLength 11) + +(RPAQQ \DoveEther.RequestON 1) + +(RPAQQ \DoveEther.RequestOFF 0) + + +(CONSTANTS \DoveEther.MulticastAddr \DoveEther.QueuePtrSize \DoveEther.ClientConditionSize + \DoveEther.IOIOCBLength \DoveEther.RequestON \DoveEther.RequestOFF) +) + +(RPAQQ DoveEther.IOCBTypes ((DoveEther.commandIOCBType 0) + (DoveEther.outputIOCBType 1) + (DoveEther.resetIOCBType 2) + (DoveEther.startRUIOCBType 3) + (DoveEther.inputIOCBType 15))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ DoveEther.commandIOCBType 0) + +(RPAQQ DoveEther.outputIOCBType 1) + +(RPAQQ DoveEther.resetIOCBType 2) + +(RPAQQ DoveEther.startRUIOCBType 3) + +(RPAQQ DoveEther.inputIOCBType 15) + + +(CONSTANTS (DoveEther.commandIOCBType 0) + (DoveEther.outputIOCBType 1) + (DoveEther.resetIOCBType 2) + (DoveEther.startRUIOCBType 3) + (DoveEther.inputIOCBType 15)) +) + +(RPAQQ DoveEther.ActionCommands ((DoveEther.actionNop 0) + (DoveEther.actionIndividualAddr 1) + (DoveEther.actionConfigure 2) + (DoveEther.actionMulticastAddr 3) + (DoveEther.actionTransmit 4) + (DoveEther.actionTimeDomainRfl 5) + (DoveEther.actionDumpStatus 6) + (DoveEther.actionDiagnose 7))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ DoveEther.actionNop 0) + +(RPAQQ DoveEther.actionIndividualAddr 1) + +(RPAQQ DoveEther.actionConfigure 2) + +(RPAQQ DoveEther.actionMulticastAddr 3) + +(RPAQQ DoveEther.actionTransmit 4) + +(RPAQQ DoveEther.actionTimeDomainRfl 5) + +(RPAQQ DoveEther.actionDumpStatus 6) + +(RPAQQ DoveEther.actionDiagnose 7) + + +(CONSTANTS (DoveEther.actionNop 0) + (DoveEther.actionIndividualAddr 1) + (DoveEther.actionConfigure 2) + (DoveEther.actionMulticastAddr 3) + (DoveEther.actionTransmit 4) + (DoveEther.actionTimeDomainRfl 5) + (DoveEther.actionDumpStatus 6) + (DoveEther.actionDiagnose 7)) +) +(PUTPROPS DOVEETHERDECLS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/sources/DOVEFLOPPY b/sources/DOVEFLOPPY new file mode 100644 index 00000000..3bffedba --- /dev/null +++ b/sources/DOVEFLOPPY @@ -0,0 +1,1139 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "16-May-90 16:06:19" {DSK}local>lde>lispcore>sources>DOVEFLOPPY.;2 65852 + + changes to%: (VARS DOVEFLOPPYCOMS) + + previous date%: "11-Jun-87 17:31:32" {DSK}local>lde>lispcore>sources>DOVEFLOPPY.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEFLOPPYCOMS) + +(RPAQQ DOVEFLOPPYCOMS + ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES MESATYPES (SOURCE) + DOVEDECLS) + (COMS * DOVEFLOPPYDECLS)) + (INITVARS (\DOVEFLOPPY.TRACEFLG NIL)) + (VARS \DOVEFLOPPY.HARDFDCCOMMANDS \DOVEFLOPPY.#COMMANDBYTES \DOVEFLOPPY.#RESULTBYTES + \DOVEFLOPPY.COMMANDS \DOVEFLOPPY.DATATRANSFEROPS \DOVEFLOPPY.DEBUG + \DOVEFLOPPY.FDCBYTEONEMASKS \DOVEFLOPPY.FDCBYTETWOMASKS \DOVEFLOPPY.FORMATINFO + \DOVEFLOPPY.IMPLIEDSEEKOPS \DOVEFLOPPY.ST0MASKS \DOVEFLOPPY.ST1MASKS + \DOVEFLOPPY.ST2MASKS \DOVEFLOPPY.SECTORLENGTHS \DOVEFLOPPY.WAITFORINTERRUPTCMDS + \DOVEFLOPPY.CURRENTCONTEXT) + (FNS \DOVEFLOPPY.RESET \DOVEFLOPPY.SETCONTEXT \DOVEFLOPPY.XFERDISK \DOVEFLOPPY.BYTESWAPIOCB + \DOVEFLOPPY.CLEARDISKCHANGED \DOVEFLOPPY.DISKCHANGED \DOVEFLOPPY.DOOROPEN + \DOVEFLOPPY.GETERRORSTATUS \DOVEFLOPPY.INIT \DOVEFLOPPY.INITDCB \DOVEFLOPPY.INITIOCB + \DOVEFLOPPY.INITIATE \DOVEFLOPPY.SETUPDMAINFO \DOVEFLOPPY.SETUPPRIMITIVEFDCOP + \DOVEFLOPPY.STOPHANDLER \DOVEFLOPPY.TRANSFER \DOVEFLOPPY.VALIDATEIOCB + \DOVEFLOPPY.WRITEPROTECTED) + (INITVARS \DOVEFLOPPY.IOCB \DOVEFLOPPY.CURRENTCONTEXT (\DoveFloppy.FCBPointer)) + (GLOBALVARS \DOVEFLOPPY.IOCB \DOVEFLOPPY.CURRENTCONTEXT \DOVEFLOPPY.HARDFDCCOMMANDS + \DoveFloppy.FCBPointer))) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD MESATYPES (SOURCE) + DOVEDECLS) + + +(RPAQQ DOVEFLOPPYDECLS + ((CONSTANTS (\DOVEFLOPPY.STOPDMA 516) + (\DOVEFLOPPY.STARTDMAWRITE 5798) + (\DOVEFLOPPY.STOPCOUNTER 16384) + (\DOVEFLOPPY.STARTDMAREAD 41574) + (\DOVEFLOPPY.STARTCOUNTER 49159) + (\DOVEFLOPPY.BYTETRUE 1) + (\DOVEFLOPPY.BYTEFALSE 0)) + (CONSTANTS (\DOVEFLOPPY.HARDDOUBLEDENSITY 64) + (\DOVEFLOPPY.HARDHEADONE 4) + (\DOVEFLOPPY.HARDMULTITRACKMODE 128) + (\DOVEFLOPPY.HARDSKIPDELETEDSECTOR 32)) + (CONSTANTS (\DOVEFLOPPY.DMAINTERRUPTWHENDONE 256) + (\DOVEFLOPPY.FDCCMDLENGTH 13)) + (CONSTANTS (\DOVEFLOPPY.WRITEPROTECT 64) + (\DOVEFLOPPY.WAITING 3) + (\DOVEFLOPPY.READ 1) + (\DOVEFLOPPY.WRITE 2) + (\DOVEFLOPPY.NONE 0) + (\DOVEFLOPPY.OPERATIONCOMPLETED 6) + (\DOVEFLOPPY.INPROGRESS 4) + (\DOVEFLOPPY.OPERATIONFAILED 7) + (\DOVEFLOPPY.OPERATIONBUILT 2)) + (RECORDS DOVEFLOPPYCMDBYTES DOVEFLOPPYCONTEXT DOVEFLOPPYDCB DOVEFLOPPYFCB + DOVEFLOPPYFDCCOMMAND DOVEFLOPPYFORMATINFO DOVEFLOPPYIOCB DOVEFLOPPYSECTORHEADER + DOVEQUEUEBLOCK))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DOVEFLOPPY.STOPDMA 516) + +(RPAQQ \DOVEFLOPPY.STARTDMAWRITE 5798) + +(RPAQQ \DOVEFLOPPY.STOPCOUNTER 16384) + +(RPAQQ \DOVEFLOPPY.STARTDMAREAD 41574) + +(RPAQQ \DOVEFLOPPY.STARTCOUNTER 49159) + +(RPAQQ \DOVEFLOPPY.BYTETRUE 1) + +(RPAQQ \DOVEFLOPPY.BYTEFALSE 0) + + +(CONSTANTS (\DOVEFLOPPY.STOPDMA 516) + (\DOVEFLOPPY.STARTDMAWRITE 5798) + (\DOVEFLOPPY.STOPCOUNTER 16384) + (\DOVEFLOPPY.STARTDMAREAD 41574) + (\DOVEFLOPPY.STARTCOUNTER 49159) + (\DOVEFLOPPY.BYTETRUE 1) + (\DOVEFLOPPY.BYTEFALSE 0)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DOVEFLOPPY.HARDDOUBLEDENSITY 64) + +(RPAQQ \DOVEFLOPPY.HARDHEADONE 4) + +(RPAQQ \DOVEFLOPPY.HARDMULTITRACKMODE 128) + +(RPAQQ \DOVEFLOPPY.HARDSKIPDELETEDSECTOR 32) + + +(CONSTANTS (\DOVEFLOPPY.HARDDOUBLEDENSITY 64) + (\DOVEFLOPPY.HARDHEADONE 4) + (\DOVEFLOPPY.HARDMULTITRACKMODE 128) + (\DOVEFLOPPY.HARDSKIPDELETEDSECTOR 32)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DOVEFLOPPY.DMAINTERRUPTWHENDONE 256) + +(RPAQQ \DOVEFLOPPY.FDCCMDLENGTH 13) + + +(CONSTANTS (\DOVEFLOPPY.DMAINTERRUPTWHENDONE 256) + (\DOVEFLOPPY.FDCCMDLENGTH 13)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DOVEFLOPPY.WRITEPROTECT 64) + +(RPAQQ \DOVEFLOPPY.WAITING 3) + +(RPAQQ \DOVEFLOPPY.READ 1) + +(RPAQQ \DOVEFLOPPY.WRITE 2) + +(RPAQQ \DOVEFLOPPY.NONE 0) + +(RPAQQ \DOVEFLOPPY.OPERATIONCOMPLETED 6) + +(RPAQQ \DOVEFLOPPY.INPROGRESS 4) + +(RPAQQ \DOVEFLOPPY.OPERATIONFAILED 7) + +(RPAQQ \DOVEFLOPPY.OPERATIONBUILT 2) + + +(CONSTANTS (\DOVEFLOPPY.WRITEPROTECT 64) + (\DOVEFLOPPY.WAITING 3) + (\DOVEFLOPPY.READ 1) + (\DOVEFLOPPY.WRITE 2) + (\DOVEFLOPPY.NONE 0) + (\DOVEFLOPPY.OPERATIONCOMPLETED 6) + (\DOVEFLOPPY.INPROGRESS 4) + (\DOVEFLOPPY.OPERATIONFAILED 7) + (\DOVEFLOPPY.OPERATIONBUILT 2)) +) +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD DOVEFLOPPYCMDBYTES ((CB1 BYTE) + (CB2 BYTE) + (CB3 BYTE) + (CB4 BYTE) + (CB5 BYTE) + (CB6 BYTE) + (CB7 BYTE) + (CB8 BYTE) + (CB9 BYTE))) + +(TYPERECORD DOVEFLOPPYCONTEXT ( + (* ;; "This record describes the current 1186 floppy drive.") + + DRIVETYPE (* ; "Kind of drive -- symbol SA455") + SECTORSPERTRACK (* ; "How many sectors on a track") + NUMBEROFHEADS (* ; "1 sided or 2 sided?") + NUMBEROFCYLINDERS (* ; "How many tracks on a side?") + DENSITY (* ; "Symbol SINGLE or DOUBLE.") + DISKCHANGED (* ; "Has the door been opened?") + SECTORLENGTH (* ; "in bytes") + )) + +(MESARECORD DOVEFLOPPYDCB ((DEVICEATTRIBUTES 5 WORD) + (DRIVEACQUIREDBYPCE BYTE) + (DRIVEBUSY BYTE) + (DIAGNOSTICDISKCHANGED WORD) + (PILOTDISKCHANGED WORD) + (DIAGNOSTICCONTEXT WORD) + (PILOTCONTEXT WORD) + (DOOROPEN WORD) + (DRIVESTATUSHEAD0 BYTE) + (DRIVESTATUSHEAD1 BYTE) + (Port80ControlWord WORD) + (StepRateTimePlusHeadUnloadTime BYTE) + (HeadLoadTimePlusNotInDMAmode BYTE)) + (BLOCKRECORD DOVEFLOPPYDCB ((NIL 12 WORD) + (EnableMainMemory FLAG) + (EnableTimerZero FLAG) + (FDDMotorOn FLAG) + (FDDInUse FLAG) + (AllowTimerTC FLAG) + (FDDLowSpeed FLAG) + (SelectChAIntClk FLAG) + (EnableDCEClk FLAG) + (DriveSelect3 FLAG) + (DriveSelect2 FLAG) + (DriveSelect1 FLAG) + (DriveSelect0 FLAG) + (Select250KbDataRate FLAG) + (PreCompensation BITS 3)))) + +(MESARECORD DOVEFLOPPYFCB ((FLOPPYTASK DoveIO.TaskContextBlock) + (FLOPPYDMATASK DoveIO.TaskContextBlock) + (FLOPPYSTOPHANDLER BYTE) + (FLOPPYRESETFDC BYTE) + (FLOPPYHANDLERISSTOPPED BYTE) + (FLOPPYFDCHUNG BYTE) + (FLOPPYWAITINGFORDMA BYTE) + (FLOPPYFIRSTDMAINTERRUPT BYTE) + (FLOPPYDRIVEMOTORCONTROLCOUNT BYTE) + (FLOPPYNUMBEROFDRIVES BYTE) + (FLOPPYBADDMAINTERRUPTCOUNT BYTE) + (FLOPPYBADFDCINTERRUPTCOUNT BYTE) + (NIL WORD) + (FLOPPYFILLERFORFORMATTING BYTE) + (FLOPPYDIAGNOSTICSON BYTE) + (FLOPPYENCODEDDEVICETYPES WORD) + (FLOPPYWORKMASK WORD) + (FLOPPYWORKNOTIFY WORD) + (FLOPPYLOCKMASK WORD) + (FLOPPYCURRENTIOCB Dove.OpieAddress) + (FLOPPYDIAGNOSTICQUEUE Dove.QueueBlock) + (FLOPPYPILOTQUEUE Dove.QueueBlock) + (FLOPPYIOPQUEUE Dove.QueueBlock) + (FLOPPYDCB0BASE DOVEFLOPPYDCB) + (FLOPPYDCB1BASE DOVEFLOPPYDCB) + (FLOPPYDCB2BASE DOVEFLOPPYDCB) + (FLOPPYDCB3BASE DOVEFLOPPYDCB))) + +(BLOCKRECORD DOVEFLOPPYFDCCOMMAND ((FDCCODE BYTE) + (DATATRANSFERCODE BYTE) + (NIL BYTE) + (MUSTWAITFORINTERRUPT BYTE) + (NUMBEROFCOMMANDBYTES BYTE) + (NUMBEROFCOMMANDBYTESWRITTEN BYTE) + (COMMANDBYTES 10 BYTE) + (NUMBEROFRESULTBYTES BYTE) + (NUMBEROFRESULTBYTESREAD BYTE) + (RESULTBYTES 8 BYTE))) + +(RECORD DOVEFLOPPYFORMATINFO (VALIDFORMAT SECTORSPERTRACK READWRITEGAPLENGTH FORMATGAPLENGTH)) + +(BLOCKRECORD DOVEFLOPPYIOCB ((CYLINDER BYTE) + (HEAD BYTE) + (SECTOR BYTE) + (DENSITY BYTE) + (NIL WORD) + (RECALIBRATEFIRST? FLAG) + (RESETFIRST? FLAG) + (NIL BITS 6) + (DATATRANSFERCODE BYTE) + (BUFFER POINTER) + (OPERATION POINTER) + (FDCOPERATION BYTE) + (NIL BYTE) + (FLOPPYCONTEXT WORD) + (ALTERNATESECTORS FLAG) + (MULTITRACKMODE FLAG) + (SKIPDELETEDSECTOR FLAG) + (NIL BITS 5) + (CURRENTRETRYCOUNT BYTE) + (ISQUEUED BYTE) + (OPERATIONSTATE BYTE) + (NEXTIOCB 2 WORD) + (DATAADDRESS 2 WORD) + (CLIENTCONDITION 3 WORD) + (FinalStateOfFDC BYTE) + (SpecifyBeforeProcessing BYTE) + (PCEResetFDCFlag BYTE) + (PCEStartMotorFlags BYTE) + (RESETFDCBEFOREPROCESSING BYTE) + (RECALIBRATEBEFOREPROCESSING BYTE) + (DRIVENUMBER BYTE) + (FDCHUNG BYTE) + (BYTESTOTRANSFER WORD) + (BYTESTRANSFERRED WORD) + (COUNTERCONTROLREG WORD) + (FIRSTDMATRANSFERCOUNT WORD) + (FIRSTDMACONTROLWORD WORD) + (NUMBEROFMIDDLEDMATRANSFERS WORD) + (MIDDLEDMATRANSFERCOUNT WORD) + (MIDDLEDMACONTROLWORD WORD) + (LASTDMATRANSFERCOUNT WORD) + (LASTDMACONTROLWORD WORD) + (FINALDMACOUNT WORD) + (INCREMENTDATAPTR BYTE) + (TimeoutOccurred BYTE) + (NUMBEROFFDCCOMMANDS WORD) + (CURRENTFDCCOMMAND WORD) + (FDCCOMMANDS 39 WORD))) + +(BLOCKRECORD DOVEFLOPPYSECTORHEADER ((CYLINDER BYTE) + (HEAD BYTE) + (SECTOR BYTE) + (ENCODEDSECTORLENGTH BYTE))) + +(BLOCKRECORD DOVEQUEUEBLOCK ((QUEUEHEAD 2 WORD) + (QUEUETAIL 2 WORD) + (QUEUENEXT 2 WORD))) +) +) + +(RPAQ? \DOVEFLOPPY.TRACEFLG NIL) + +(RPAQQ \DOVEFLOPPY.HARDFDCCOMMANDS + ((NOP . 0) + (FORMATTRACK . 13) + (READDATA . 6) + (READDELETEDDATA . 12) + (READID . 10) + (READTRACK . 2) + (RECALIBRATE . 7) + (SCANEQUAL . 17) + (SCANHIGHOREQUAL . 29) + (SCANLOWOREQUAL . 25) + (SEEK . 15) + (SENSEDRIVESTATUS . 4) + (SENSEINTERRUPTSTATUS . 8) + (SPECIFY . 3) + (WRITEDATA . 5) + (WRITEDELETEDDATA . 9))) + +(RPAQQ \DOVEFLOPPY.#COMMANDBYTES + ((NOP . 0) + (FORMATTRACK . 6) + (READDATA . 9) + (READDELETEDDATA . 9) + (READID . 2) + (READTRACK . 9) + (RECALIBRATE . 2) + (SCANEQUAL . 9) + (SCANHIGHOREQUAL . 9) + (SCANLOWOREQUAL . 9) + (SEEK . 3) + (SENSEDRIVESTATUS . 2) + (SENSEINTERRUPTSTATUS . 1) + (SPECIFY . 3) + (WRITEDATA . 9) + (WRITEDELETEDDATA . 9))) + +(RPAQQ \DOVEFLOPPY.#RESULTBYTES + ((NOP . 0) + (FORMATTRACK . 7) + (READDATA . 7) + (READDELETEDDATA . 7) + (READID . 7) + (READTRACK . 7) + (RECALIBRATE . 0) + (SCANEQUAL . 7) + (SCANHIGHOREQUAL . 7) + (SCANLOWOREQUAL . 7) + (SEEK . 0) + (SENSEDRIVESTATUS . 1) + (SENSEINTERRUPTSTATUS . 2) + (SPECIFY . 0) + (WRITEDATA . 7))) + +(RPAQQ \DOVEFLOPPY.COMMANDS + ((NOP . 0) + (FORMATTRACK . 1) + (READDATA . 2) + (READDELETEDDATA . 3) + (READID . 4) + (READTRACK . 5) + (RECALIBRATE . 6) + (SCANEQUAL . 7) + (SCANHIGHOREQUAL . 8) + (SCANLOWOREQUAL . 9) + (SEEK . 10) + (SENSEDRIVESTATUS . 11) + (SENSEINTERRUPTSTATUS . 12) + (SPECIFY . 13) + (WRITEDATA . 14) + (WRITEDELETEDDATA . 15))) + +(RPAQQ \DOVEFLOPPY.DATATRANSFEROPS + ((NOP . 0) + (FORMATTRACK . 2) + (READDATA . 1) + (READDELETEDDATA . 1) + (READID . 0) + (READTRACK . 1) + (RECALIBRATE . 0) + (SCANEQUAL . 2) + (SCANHIGHOREQUAL . 2) + (SCANLOWOREQUAL . 2) + (SEEK . 0) + (SENSEDRIVESTATUS . 0) + (SENSEINTERRUPTSTATUS . 0) + (SPECIFY . 0) + (WRITEDATA . 2) + (WRITEDELETEDDATA . 2))) + +(RPAQQ \DOVEFLOPPY.DEBUG T) + +(RPAQQ \DOVEFLOPPY.FDCBYTEONEMASKS + ((NOP . 0) + (FORMATTRACK . 95) + (READDATA . 255) + (READDELETEDDATA . 255) + (READID . 95) + (READTRACK . 127) + (RECALIBRATE . 31) + (SCANEQUAL . 255) + (SCANHIGHOREQUAL . 255) + (SCANLOWOREQUAL . 255) + (SEEK . 31) + (SENSEDRIVESTATUS . 31) + (SENSEINTERRUPTSTATUS . 31) + (SPECIFY . 31) + (WRITEDATA . 223) + (WRITEDELETEDDATA . 223))) + +(RPAQQ \DOVEFLOPPY.FDCBYTETWOMASKS + ((NOP . 0) + (FORMATTRACK . 7) + (READDATA . 7) + (READDELETEDDATA . 7) + (READID . 7) + (READTRACK . 7) + (RECALIBRATE . 3) + (SCANEQUAL . 7) + (SCANHIGHOREQUAL . 7) + (SCANLOWOREQUAL . 7) + (SEEK . 7) + (SENSEDRIVESTATUS . 7) + (SENSEINTERRUPTSTATUS . 0) + (SPECIFY . 255) + (WRITEDATA . 7) + (WRITEDELETEDDATA . 7))) + +(RPAQQ \DOVEFLOPPY.FORMATINFO + [(128 ((SINGLE T 16 16 25) + (DOUBLE NIL 0 0 0))) + (256 ((SINGLE T 8 24 48) + (DOUBLE T 16 32 50))) + (512 ((SINGLE T 4 70 135) + (DOUBLE T 9 42 80))) + (1024 ((SINGLE NIL 2 200 255) + (DOUBLE NIL 4 200 240))) + (2048 ((SINGLE NIL 1 200 255) + (DOUBLE NIL 2 200 255))) + (4096 ((SINGLE NIL 0 0 0) + (DOUBLE NIL 1 200 255]) + +(RPAQQ \DOVEFLOPPY.IMPLIEDSEEKOPS (FORMATTRACK READDATA READDELETEDDATA READID READTRACK + SCANEQUAL SCANHIGHOREQUAL SCANLOWOREQUAL SEEK WRITEDATA + WRITEDELETEDDATA)) + +(RPAQQ \DOVEFLOPPY.ST0MASKS ((8 . NOTREADY))) + +(RPAQQ \DOVEFLOPPY.ST1MASKS ((128 . ENDOFTRACK) + (32 . DATAERROR) + (16 . OVERRUNERROR) + (4 . SECTORNOTFOUND) + (2 . WRITEPROTECTED) + (1 . MISSINGADDRESSMARK))) + +(RPAQQ \DOVEFLOPPY.ST2MASKS ((16 . WRONGCYLINDER) + (8 . SCANEQUALHIT) + (4 . SCANNOTSATISFIED) + (2 . BADCYLINDER))) + +(RPAQQ \DOVEFLOPPY.SECTORLENGTHS ((128 . 0) + (256 . 1) + (512 . 2) + (1024 . 3) + (2048 . 4) + (4096 . 5))) + +(RPAQQ \DOVEFLOPPY.WAITFORINTERRUPTCMDS (FORMATTRACK READDATA READDELETEDDATA READID READTRACK + RECALIBRATE SCANEQUAL SCANHIGHOREQUAL + SCANLOWOREQUAL SEEK WRITEDATA WRITEDELETEDDATA)) + +(RPAQQ \DOVEFLOPPY.CURRENTCONTEXT (DOVEFLOPPYCONTEXT SA455 9 2 40 DOUBLE NIL 512)) +(DEFINEQ + +(\DOVEFLOPPY.RESET + (LAMBDA NIL (* mpl " 7-Aug-85 15:17") + (\DOVEFLOPPY.INIT))) + +(\DOVEFLOPPY.SETCONTEXT + [LAMBDA (DENSITY SECTORLENGTH) (* ; "Edited 11-Jun-87 17:05 by jds") + + (* ;; "Set the current 1186 floppy density and sector length to validated values. Error if the values aren't legit.") + + (DECLARE (GLOBALVARS \DOVEFLOPPY.SECTORLENGTHS \DOVEFLOPPY.CURRENTCONTEXT)) + (COND + ((NOT (LISTP \DOVEFLOPPY.CURRENTCONTEXT)) + (\DOVEFLOPPY.INIT))) + (COND + ((FMEMB DENSITY '(SINGLE DOUBLE)) + (replace (DOVEFLOPPYCONTEXT DENSITY) of \DOVEFLOPPY.CURRENTCONTEXT with DENSITY)) + (T (HELP "Invalid density " DENSITY))) + (COND + ((FASSOC SECTORLENGTH \DOVEFLOPPY.SECTORLENGTHS) + (replace (DOVEFLOPPYCONTEXT SECTORLENGTH) of \DOVEFLOPPY.CURRENTCONTEXT with SECTORLENGTH)) + (T (HELP "Invalid sector length " SECTORLENGTH]) + +(\DOVEFLOPPY.XFERDISK + [LAMBDA (CYL HD SEC BUFF MODE RECAL? RESET?) (* ; "Edited 11-Jun-87 14:41 by jds") + + (* ;; "Transfer data to/from the floppy disk.") + + (PROG (STATUS) + (SETQ STATUS (\DOVEFLOPPY.TRANSFER CYL HD SEC BUFF MODE RESET? RECAL?)) + [for I from 1 to 50 do + +(* ;;; "kbr: ' 8-Nov-85 12:19' Repeat a few times because of spurious OVERRUN errors. I've also seen a few spurious DATAERRORs. 3 retries is not enough, so I've made it 10.0 *") + +(* ;;; "kbr: '19-Mar-86 17:18' Had problems copying an Intellicorp sysout floppy to {DSK}, but if we change the number of retries from 10 to 20, the problem (DATAERRORs) goes away. So I've set the number of retries to 40! *") + +(* ;;; "kbr: '19-Mar-86 17:18' MESA code uses ActualNumberOfRetriesWhenDMAHit = 50 when handlingError inside UpdateOperation on FLOPPYHEADDOVE.MESA. So I've set the number of retries to 50! *") + + (COND + ((OR (EQ STATUS 'OK) + (EQ STATUS 'TIMEOUT)) + [COND + (\DOVEFLOPPY.TRACEFLG (COND + ((EQ I 1) + (PRIN1 "." TRACEWINDOW)) + (T (PRIN1 "R" TRACEWINDOW) + (PRIN1 I TRACEWINDOW] + (RETURN)) + (\DOVEFLOPPY.TRACEFLG (PRIN1 STATUS TRACEWINDOW) + (PRIN1 "-" TRACEWINDOW))) + + (* ;; "kbr: '19-Mar-86 17:18' Try recalibrating and resetting every fourth time though loop instead of every time through loop. *") + + (COND + ((EQ (IMOD I 4) + 1) + (COND + (\DOVEFLOPPY.TRACEFLG (PRIN1 "RECALIBRATE-" TRACEWINDOW))) + (SETQ STATUS (\DOVEFLOPPY.TRANSFER CYL HD SEC BUFF MODE T T)) + (DISMISS 50)) + (T (SETQ STATUS (\DOVEFLOPPY.TRANSFER CYL HD SEC BUFF MODE NIL + NIL] + (RETURN STATUS]) + +(\DOVEFLOPPY.BYTESWAPIOCB + (LAMBDA (IOCB) (* kbr%: " 5-Oct-85 16:37") + (replace (DOVEFLOPPYIOCB BYTESTOTRANSFER) of IOCB with (\DoveIO.ByteSwap (fetch (DOVEFLOPPYIOCB + BYTESTOTRANSFER) + of IOCB))) + (replace (DOVEFLOPPYIOCB BYTESTRANSFERRED) of IOCB with (\DoveIO.ByteSwap (fetch (DOVEFLOPPYIOCB + + BYTESTRANSFERRED + ) of IOCB))) + (replace (DOVEFLOPPYIOCB COUNTERCONTROLREG) of IOCB with (\DoveIO.ByteSwap (fetch (DOVEFLOPPYIOCB + + COUNTERCONTROLREG + ) of IOCB))) + (replace (DOVEFLOPPYIOCB FIRSTDMATRANSFERCOUNT) of IOCB with (\DoveIO.ByteSwap + (fetch (DOVEFLOPPYIOCB + FIRSTDMATRANSFERCOUNT + ) of IOCB))) + (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB with (\DoveIO.ByteSwap (fetch ( + DOVEFLOPPYIOCB + + FIRSTDMACONTROLWORD + ) + of IOCB))) + (replace (DOVEFLOPPYIOCB NUMBEROFMIDDLEDMATRANSFERS) of IOCB with (\DoveIO.ByteSwap + (fetch (DOVEFLOPPYIOCB + NUMBEROFMIDDLEDMATRANSFERS + ) of IOCB))) + (replace (DOVEFLOPPYIOCB MIDDLEDMATRANSFERCOUNT) of IOCB with (\DoveIO.ByteSwap + (fetch (DOVEFLOPPYIOCB + MIDDLEDMATRANSFERCOUNT + ) of IOCB))) + (replace (DOVEFLOPPYIOCB MIDDLEDMACONTROLWORD) of IOCB with (\DoveIO.ByteSwap (fetch ( + DOVEFLOPPYIOCB + + MIDDLEDMACONTROLWORD + ) + of IOCB))) + (replace (DOVEFLOPPYIOCB LASTDMATRANSFERCOUNT) of IOCB with (\DoveIO.ByteSwap (fetch ( + DOVEFLOPPYIOCB + + LASTDMATRANSFERCOUNT + ) + of IOCB))) + (replace (DOVEFLOPPYIOCB LASTDMACONTROLWORD) of IOCB with (\DoveIO.ByteSwap (fetch ( + DOVEFLOPPYIOCB + + LASTDMACONTROLWORD + ) + of IOCB))) + (replace (DOVEFLOPPYIOCB FINALDMACOUNT) of IOCB with (\DoveIO.ByteSwap (fetch (DOVEFLOPPYIOCB + FINALDMACOUNT) + of IOCB))) + (replace (DOVEFLOPPYIOCB NUMBEROFFDCCOMMANDS) of IOCB with (\DoveIO.ByteSwap (fetch ( + DOVEFLOPPYIOCB + + NUMBEROFFDCCOMMANDS + ) + of IOCB))) + (replace (DOVEFLOPPYIOCB CURRENTFDCCOMMAND) of IOCB with (\DoveIO.ByteSwap (fetch (DOVEFLOPPYIOCB + + CURRENTFDCCOMMAND + ) of IOCB))))) + +(\DOVEFLOPPY.CLEARDISKCHANGED + (LAMBDA NIL (* mpl " 4-Aug-85 12:39") + (replace (DOVEFLOPPYDCB PILOTDISKCHANGED) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of + \DoveFloppy.FCBPointer + ) with 0))) + +(\DOVEFLOPPY.DISKCHANGED + (LAMBDA NIL (* mpl " 4-Aug-85 12:39") + (NOT (EQ 0 (fetch (DOVEFLOPPYDCB PILOTDISKCHANGED) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) + of \DoveFloppy.FCBPointer)))))) + +(\DOVEFLOPPY.DOOROPEN + (LAMBDA NIL (* mpl " 4-Aug-85 12:40") + (NOT (EQ 0 (fetch (DOVEFLOPPYDCB DOOROPEN) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of + \DoveFloppy.FCBPointer + )))))) + +(\DOVEFLOPPY.GETERRORSTATUS + (LAMBDA (IOCB) (* kbr%: " 5-Oct-85 16:40") + (DECLARE (GLOBALVARS \DOVEFLOPPY.ST0MASKS \DOVEFLOPPY.ST1MASKS \DOVEFLOPPY.ST2MASKS)) + (PROG (CMDINDEX CMDLOC CMDBYTES ST0 ST1 ST2 STATUS) + (SETQ CMDINDEX (SUB1 (fetch (DOVEFLOPPYIOCB CURRENTFDCCOMMAND) of IOCB))) + (SETQ CMDLOC (\ADDBASE (LOCF (fetch (DOVEFLOPPYIOCB FDCCOMMANDS) of IOCB)) + (ITIMES CMDINDEX \DOVEFLOPPY.FDCCMDLENGTH))) + (SETQ CMDBYTES (LOCF (fetch (DOVEFLOPPYFDCCOMMAND RESULTBYTES) of CMDLOC))) + (SETQ ST0 (fetch (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES)) + (SETQ ST1 (fetch (DOVEFLOPPYCMDBYTES CB2) of CMDBYTES)) + (SETQ ST2 (fetch (DOVEFLOPPYCMDBYTES CB3) of CMDBYTES)) + (SETQ STATUS NIL) + (COND + ((EQ (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB) + \DOVEFLOPPY.INPROGRESS) + (SETQ STATUS 'TIMEOUT))) + (SETQ STATUS (OR STATUS (for I in \DOVEFLOPPY.ST0MASKS + do (COND + ((NOT (EQ 0 (LOGAND (CAR I) + ST0))) + (RETURN (CDR I))))))) + (SETQ STATUS (OR STATUS (for I in \DOVEFLOPPY.ST1MASKS + do (COND + ((NOT (EQ 0 (LOGAND (CAR I) + ST1))) + (RETURN (CDR I))))))) + (SETQ STATUS (OR STATUS (for I in \DOVEFLOPPY.ST2MASKS + do (COND + ((NOT (EQ 0 (LOGAND (CAR I) + ST2))) + (RETURN (CDR I))))))) + (RETURN (OR STATUS 'OK))))) + +(\DOVEFLOPPY.INIT + [LAMBDA NIL (* ; "Edited 11-Jun-87 17:03 by jds") + + (* ;; "Initialize the 1186 floppy drive.") + + (DECLARE (GLOBALVARS \DOVEFLOPPY.CURRENTCONTEXT)) + (SETQ \DoveFloppy.FCBPointer (\DoveIO.GetHandlerIORegionPtr DoveIO.floppyHandler)) + (PROG1 (\DOVEFLOPPY.STOPHANDLER) + (SETQ \DOVEFLOPPY.CURRENTCONTEXT + (create DOVEFLOPPYCONTEXT + DRIVETYPE _ 'SA455 + SECTORSPERTRACK _ 9 + NUMBEROFCYLINDERS _ 40 + NUMBEROFHEADS _ 2 + DENSITY _ 'DOUBLE + SECTORLENGTH _ 512 + DISKCHANGED _ NIL)) + (\DOVEFLOPPY.INITDCB]) + +(\DOVEFLOPPY.INITDCB + [LAMBDA NIL (* ; "Edited 11-Jun-87 17:00 by jds") + + (* ;; "Fire up the IOP floppy handler, with a given DCB & FCB.") + + (replace (DOVEFLOPPYDCB DOOROPEN) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of + \DoveFloppy.FCBPointer + ) with 0) + (replace (DOVEFLOPPYDCB PILOTDISKCHANGED) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of + \DoveFloppy.FCBPointer + ) with 0) + (replace (DOVEFLOPPYDCB DIAGNOSTICDISKCHANGED) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) + of \DoveFloppy.FCBPointer) with 0) + (* ; + "Magic constant 6712 is byteswap of Mesa's 14362 magic constant. *") + + (replace (DOVEFLOPPYDCB Port80ControlWord) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of + \DoveFloppy.FCBPointer + ) with 6712) + + (* ;; "kbr: `20-Apr-86 13:15' Added the following two replaces. From an INSPECT window I can tell that the value of these fields were 177 and 2, but I have no idea where they originally got set from, and I have looked to try to find out how. According to OSBUNORTH people, HeadLoadTimePlusNotInDMAmode must be 20 to allow 40ms time for head settling before write operations. Without this change, what will happen is that occasionally the DAYBREAK floppy heads will still be vibrating around at the time of the write operation. Later, reads will not be able to read the malformed data and will cause DATAERRORs. *") + + (replace (DOVEFLOPPYDCB StepRateTimePlusHeadUnloadTime) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) + of \DoveFloppy.FCBPointer) + with 209) (* ; + "jds 22-Oct-86 Changed from 177 to 209, to slow down the head step rate, to cut data errors.") + + (replace (DOVEFLOPPYDCB HeadLoadTimePlusNotInDMAmode) of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) + of \DoveFloppy.FCBPointer) + with 20]) + +(\DOVEFLOPPY.INITIOCB + (LAMBDA (IOCB) (* kbr%: " 5-Oct-85 16:44") + (DECLARE (GLOBALVARS \DOVEFLOPPY.COMMANDS \DOVEFLOPPY.IMPLIEDSEEKOPS \DoveFloppy.DataTransferCode + \DOVEFLOPPY.DATATRANSFEROPS)) + (PROG (DCBPTR OP) + (SETQ DCBPTR (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of \DoveFloppy.FCBPointer)) + (SETQ OP (fetch (DOVEFLOPPYIOCB OPERATION) of IOCB)) + (\CLEARWORDS (LOCF (fetch (DOVEFLOPPYIOCB FDCOPERATION) of IOCB)) + 81) + (\DoveIO.MakeOpieAddress (LOCF (fetch (DOVEFLOPPYIOCB NEXTIOCB) of IOCB)) + NIL) + (\DoveIO.MakeOpieAddress (LOCF (fetch (DOVEFLOPPYIOCB DATAADDRESS) of IOCB)) + (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB)) + (replace (DOVEFLOPPYIOCB ALTERNATESECTORS) of IOCB with NIL) + (replace (DOVEFLOPPYIOCB FDCOPERATION) of IOCB with (CDR (FASSOC OP \DOVEFLOPPY.COMMANDS))) + (replace (DOVEFLOPPYIOCB MULTITRACKMODE) of IOCB with T) + (replace (DOVEFLOPPYIOCB SKIPDELETEDSECTOR) of IOCB with NIL) + (replace (DOVEFLOPPYIOCB CURRENTRETRYCOUNT) of IOCB with 1) + (replace (DOVEFLOPPYIOCB ISQUEUED) of IOCB with \DOVEFLOPPY.BYTEFALSE) + (replace (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB with \DOVEFLOPPY.OPERATIONBUILT) + (replace (DOVEFLOPPYIOCB RESETFDCBEFOREPROCESSING) of IOCB with (COND + ((fetch (DOVEFLOPPYIOCB + RESETFIRST?) + of IOCB) + \DOVEFLOPPY.BYTETRUE) + (T \DOVEFLOPPY.BYTEFALSE + ))) + (replace (DOVEFLOPPYIOCB RECALIBRATEBEFOREPROCESSING) of IOCB + with (COND + ((fetch (DOVEFLOPPYIOCB RECALIBRATEFIRST?) of IOCB) + \DOVEFLOPPY.BYTETRUE) + (T \DOVEFLOPPY.BYTEFALSE))) + (replace (DOVEFLOPPYIOCB DRIVENUMBER) of IOCB with 0) + (replace (DOVEFLOPPYIOCB FDCHUNG) of IOCB with \DOVEFLOPPY.BYTEFALSE) + (replace (DOVEFLOPPYIOCB COUNTERCONTROLREG) of IOCB with \DOVEFLOPPY.STOPCOUNTER) + (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB with \DOVEFLOPPY.STOPDMA) + (replace (DOVEFLOPPYIOCB MIDDLEDMACONTROLWORD) of IOCB with \DOVEFLOPPY.STOPDMA) + (replace (DOVEFLOPPYIOCB LASTDMACONTROLWORD) of IOCB with \DOVEFLOPPY.STOPDMA) + (replace (DOVEFLOPPYIOCB DATATRANSFERCODE) of IOCB with (CDR (FASSOC OP + \DOVEFLOPPY.DATATRANSFEROPS + ))) + (COND + ((FMEMB OP \DOVEFLOPPY.IMPLIEDSEEKOPS) + (\DOVEFLOPPY.SETUPPRIMITIVEFDCOP IOCB 'SEEK) + (\DOVEFLOPPY.SETUPPRIMITIVEFDCOP IOCB 'SENSEINTERRUPTSTATUS))) + (COND + ((NOT (FMEMB OP '(NOP SEEK))) + (\DOVEFLOPPY.SETUPPRIMITIVEFDCOP IOCB OP) + (COND + ((EQ OP 'RECALIBRATE) + (\DOVEFLOPPY.SETUPPRIMITIVEFDCOP IOCB 'SENSEINTERRUPTSTATUS)))))))) + +(\DOVEFLOPPY.INITIATE + [LAMBDA (IOCB) (* ; "Edited 11-Jun-87 11:43 by jds") + +(* ;;; "This fn makes the IOP go.") + +(* ;;; "We don't care about queues of IOCBs to floppies... what a waste!") + + (PROG (TIMER RESULTS) (* ; "\DoveIO.LockMem is pointless here") + + (\DOVEFLOPPY.VALIDATEIOCB IOCB) + (\DOVEFLOPPY.INITIOCB IOCB) + (\DOVEFLOPPY.SETUPDMAINFO IOCB) + (replace (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB with \DOVEFLOPPY.WAITING) + (replace (DOVEFLOPPYIOCB ISQUEUED) of IOCB with \DOVEFLOPPY.BYTETRUE) + (\DOVEFLOPPY.BYTESWAPIOCB IOCB) (* ; "Lock buffer before doing anything") + + (\TEMPLOCKPAGES IOCB 1) + (\PUTBASE (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB) + 0 + (\GETBASE (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB) + 0)) + (\TEMPLOCKPAGES (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB) + 1) + (replace (DOVEFLOPPYFCB FLOPPYSTOPHANDLER) of \DoveFloppy.FCBPointer with + \DOVEFLOPPY.BYTEFALSE + ) + (COND + ((EQ \DOVEFLOPPY.BYTETRUE (fetch (DOVEFLOPPYFCB FLOPPYFDCHUNG) of \DoveFloppy.FCBPointer + )) + (replace (DOVEFLOPPYFCB FLOPPYRESETFDC) of \DoveFloppy.FCBPointer with + \DOVEFLOPPY.BYTETRUE + ))) + (replace (Dove.QueueBlock LispQueueNext) of (fetch (DOVEFLOPPYFCB FLOPPYPILOTQUEUE) + of \DoveFloppy.FCBPointer) with IOCB) + (\DoveIO.NotifyIOP (fetch (DOVEFLOPPYFCB FLOPPYWORKMASK) of \DoveFloppy.FCBPointer)) + (SETQ TIMER (SETUPTIMER 2000)) + (until (OR (TIMEREXPIRED? TIMER) + (EQ (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB) + \DOVEFLOPPY.OPERATIONCOMPLETED) + (EQ (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB) + \DOVEFLOPPY.OPERATIONFAILED)) do (BLOCK)) + [SETQ RESULTS (COND + ((OR (EQ (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB) + \DOVEFLOPPY.OPERATIONCOMPLETED) + (EQ (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB) + \DOVEFLOPPY.OPERATIONFAILED)) + + (* ;; "NOTE: An expired TIMER doesn't necessarily imply FLOPPY failure. It can be that the process scheduler simply didn't get back to FLOPPY soon enough (e.g. user holds mouse button down long time.) A previous version of this COND tested (TIMEREXPIRED? TIMER) in the first branch, which was wrong. *") + + 'OK) + (T (\DOVEFLOPPY.STOPHANDLER) + 'TIMEOUT] + (\DOVEFLOPPY.BYTESWAPIOCB IOCB) + (\TEMPUNLOCKPAGES IOCB 1) + (\TEMPUNLOCKPAGES (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB) + 1) + (COND + ((EQ RESULTS 'TIMEOUT) + (replace (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB with \DOVEFLOPPY.INPROGRESS))) + (RETURN (fetch (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB]) + +(\DOVEFLOPPY.SETUPDMAINFO + (LAMBDA (IOCB) (* kbr%: " 5-Oct-85 17:52") + (DECLARE (GLOBALVARS \DOVEFLOPPY.CURRENTCONTEXT \DOVEFLOPPY.FORMATINFO \DOVEFLOPPY.SECTORLENGTHS) + ) + (PROG (FORMATINFO SECTORHEADER) + (SETQ FORMATINFO (CDR (FASSOC (fetch (DOVEFLOPPYCONTEXT DENSITY) of + \DOVEFLOPPY.CURRENTCONTEXT + ) + (CADR (FASSOC (fetch (DOVEFLOPPYCONTEXT SECTORLENGTH) + of \DOVEFLOPPY.CURRENTCONTEXT) + \DOVEFLOPPY.FORMATINFO))))) + (replace (DOVEFLOPPYIOCB COUNTERCONTROLREG) of IOCB with \DOVEFLOPPY.STARTCOUNTER) + (SELECTQ (fetch (DOVEFLOPPYIOCB OPERATION) of IOCB) + (FORMATTRACK (for I from 1 to (fetch (DOVEFLOPPYFORMATINFO SECTORSPERTRACK) + of FORMATINFO) + do (SETQ SECTORHEADER (\ADDBASE (fetch (DOVEFLOPPYIOCB BUFFER) + of IOCB) + (ITIMES 2 (SUB1 I)))) + (* Set up SECTORHEADER *) + (replace (DOVEFLOPPYSECTORHEADER CYLINDER) of SECTORHEADER + with (fetch (DOVEFLOPPYIOCB CYLINDER) of IOCB)) + (replace (DOVEFLOPPYSECTORHEADER HEAD) of SECTORHEADER + with (fetch (DOVEFLOPPYIOCB HEAD) of IOCB)) + (replace (DOVEFLOPPYSECTORHEADER SECTOR) of SECTORHEADER + with I) + (replace (DOVEFLOPPYSECTORHEADER ENCODEDSECTORLENGTH) of + SECTORHEADER + with (CDR (FASSOC (fetch (DOVEFLOPPYCONTEXT SECTORLENGTH) + of \DOVEFLOPPY.CURRENTCONTEXT) + \DOVEFLOPPY.SECTORLENGTHS)))) + (* Set up IOCB *) + (replace (DOVEFLOPPYIOCB BYTESTOTRANSFER) of IOCB + with (ITIMES 4 (fetch (DOVEFLOPPYFORMATINFO SECTORSPERTRACK) + of FORMATINFO))) + (replace (DOVEFLOPPYIOCB FIRSTDMATRANSFERCOUNT) of IOCB + with (fetch (DOVEFLOPPYIOCB BYTESTOTRANSFER) of IOCB)) + (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAWRITE + )) + (PROGN (replace (DOVEFLOPPYIOCB BYTESTOTRANSFER) of IOCB with (fetch (DOVEFLOPPYCONTEXT + SECTORLENGTH) + of + \DOVEFLOPPY.CURRENTCONTEXT + )) + (replace (DOVEFLOPPYIOCB FIRSTDMATRANSFERCOUNT) of IOCB + with (fetch (DOVEFLOPPYIOCB BYTESTOTRANSFER) of IOCB)) + (SELECTC (fetch (DOVEFLOPPYIOCB DATATRANSFERCODE) of IOCB) + (\DOVEFLOPPY.READ + (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAREAD + ) + (replace (DOVEFLOPPYIOCB MIDDLEDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAREAD + ) + (replace (DOVEFLOPPYIOCB LASTDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAREAD + )) + (\DOVEFLOPPY.WRITE + (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAWRITE + ) + (replace (DOVEFLOPPYIOCB MIDDLEDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAWRITE + ) + (replace (DOVEFLOPPYIOCB LASTDMACONTROLWORD) of IOCB with + \DOVEFLOPPY.STARTDMAWRITE + )) + (PROGN (replace (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) of IOCB + with (LOGOR (fetch (DOVEFLOPPYIOCB FIRSTDMACONTROLWORD) + of IOCB) + \DOVEFLOPPY.DMAINTERRUPTWHENDONE)) + (replace (DOVEFLOPPYIOCB NUMBEROFMIDDLEDMATRANSFERS) of IOCB + with 0) + (replace (DOVEFLOPPYIOCB LASTDMATRANSFERCOUNT) of IOCB with 0)))))))) + +(\DOVEFLOPPY.SETUPPRIMITIVEFDCOP + (LAMBDA (IOCB OPERATION) (* kbr%: " 5-Oct-85 17:00") + (DECLARE (GLOBALVARS \DOVEFLOPPY.SECTORLENGTHS \DOVEFLOPPY.COMMANDS \DOVEFLOPPY.CURRENTCONTEXT + \DOVEFLOPPY.FORMATINFO \DOVEFLOPPY.DATATRANSFEROPS \DOVEFLOPPY.#COMMANDBYTES + \DOVEFLOPPY.#RESULTBYTES \DOVEFLOPPY.FDCBYTEONEMASKS \DOVEFLOPPY.FDCBYTETWOMASKS + \DOVEFLOPPY.WAITFORINTERRUPTCMDS)) + (PROG (FDCCMDINDEX FDCCMD ENCODEDSECTORLENGTH FORMATINFO CURRENTCMDRECORD CMDBYTES) + (SETQ FDCCMDINDEX (ADD1 (fetch (DOVEFLOPPYIOCB NUMBEROFFDCCOMMANDS) of IOCB))) + (SETQ FDCCMD (CDR (FASSOC OPERATION \DOVEFLOPPY.COMMANDS))) + (SETQ ENCODEDSECTORLENGTH (CDR (FASSOC (fetch (DOVEFLOPPYCONTEXT SECTORLENGTH) of + \DOVEFLOPPY.CURRENTCONTEXT + ) + \DOVEFLOPPY.SECTORLENGTHS))) + (SETQ FORMATINFO (CDR (FASSOC (fetch (DOVEFLOPPYCONTEXT DENSITY) of + \DOVEFLOPPY.CURRENTCONTEXT + ) + (CADR (FASSOC (fetch (DOVEFLOPPYCONTEXT SECTORLENGTH) + of \DOVEFLOPPY.CURRENTCONTEXT) + \DOVEFLOPPY.FORMATINFO))))) + (SETQ CURRENTCMDRECORD (\ADDBASE (LOCF (fetch (DOVEFLOPPYIOCB FDCCOMMANDS) of IOCB)) + (ITIMES \DOVEFLOPPY.FDCCMDLENGTH (SUB1 FDCCMDINDEX)))) + (replace (DOVEFLOPPYIOCB NUMBEROFFDCCOMMANDS) of IOCB with FDCCMDINDEX) + (replace (DOVEFLOPPYIOCB DATATRANSFERCODE) of IOCB with (CDR (FASSOC (fetch (DOVEFLOPPYIOCB + OPERATION) + of IOCB) + + \DOVEFLOPPY.DATATRANSFEROPS + ))) + (* Set up CURRENTCMDRECORD *) + (replace (DOVEFLOPPYFDCCOMMAND FDCCODE) of CURRENTCMDRECORD with FDCCMD) + (replace (DOVEFLOPPYFDCCOMMAND DATATRANSFERCODE) of CURRENTCMDRECORD + with (CDR (FASSOC OPERATION \DOVEFLOPPY.DATATRANSFEROPS))) + (replace (DOVEFLOPPYFDCCOMMAND NUMBEROFCOMMANDBYTES) of CURRENTCMDRECORD + with (CDR (FASSOC OPERATION \DOVEFLOPPY.#COMMANDBYTES))) + (replace (DOVEFLOPPYFDCCOMMAND NUMBEROFRESULTBYTES) of CURRENTCMDRECORD + with (CDR (FASSOC OPERATION \DOVEFLOPPY.#RESULTBYTES))) + (replace (DOVEFLOPPYFDCCOMMAND MUSTWAITFORINTERRUPT) of CURRENTCMDRECORD + with (COND + ((FMEMB OPERATION \DOVEFLOPPY.WAITFORINTERRUPTCMDS) + \DOVEFLOPPY.BYTETRUE) + (T \DOVEFLOPPY.BYTEFALSE))) (* Set up CMDBYTES *) + (SETQ CMDBYTES (LOCF (fetch (DOVEFLOPPYFDCCOMMAND COMMANDBYTES) of CURRENTCMDRECORD))) + (replace (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES with (CDR (FASSOC OPERATION + \DOVEFLOPPY.HARDFDCCOMMANDS) + )) + (COND + ((fetch (DOVEFLOPPYIOCB MULTITRACKMODE) of IOCB) + (replace (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES with (LOGOR (fetch (DOVEFLOPPYCMDBYTES + CB1) of CMDBYTES) + + \DOVEFLOPPY.HARDMULTITRACKMODE + )))) + (COND + ((EQ (fetch (DOVEFLOPPYCONTEXT DENSITY) of \DOVEFLOPPY.CURRENTCONTEXT) + 'DOUBLE) + (replace (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES with (LOGOR (fetch (DOVEFLOPPYCMDBYTES + CB1) of CMDBYTES) + \DOVEFLOPPY.HARDDOUBLEDENSITY + )))) + (COND + ((fetch (DOVEFLOPPYIOCB SKIPDELETEDSECTOR) of IOCB) + (replace (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES with (LOGOR (fetch (DOVEFLOPPYCMDBYTES + CB1) of CMDBYTES) + + \DOVEFLOPPY.HARDSKIPDELETEDSECTOR + )))) + (replace (DOVEFLOPPYCMDBYTES CB1) of CMDBYTES with (LOGAND (fetch (DOVEFLOPPYCMDBYTES + CB1) of CMDBYTES) + (CDR (FASSOC OPERATION + \DOVEFLOPPY.FDCBYTEONEMASKS + )))) + (replace (DOVEFLOPPYCMDBYTES CB2) of CMDBYTES with 0) + (COND + ((EQ (fetch (DOVEFLOPPYIOCB HEAD) of IOCB) + 1) + (replace (DOVEFLOPPYCMDBYTES CB2) of CMDBYTES with (LOGOR (fetch (DOVEFLOPPYCMDBYTES + CB2) of CMDBYTES) + \DOVEFLOPPY.HARDHEADONE)))) + (replace (DOVEFLOPPYCMDBYTES CB2) of CMDBYTES with (LOGAND (fetch (DOVEFLOPPYCMDBYTES + CB2) of CMDBYTES) + (CDR (FASSOC OPERATION + \DOVEFLOPPY.FDCBYTETWOMASKS + )))) + (replace (DOVEFLOPPYCMDBYTES CB3) of CMDBYTES with (fetch (DOVEFLOPPYIOCB CYLINDER) + of IOCB)) + (replace (DOVEFLOPPYCMDBYTES CB4) of CMDBYTES with (fetch (DOVEFLOPPYIOCB HEAD) + of IOCB)) + (replace (DOVEFLOPPYCMDBYTES CB5) of CMDBYTES with (fetch (DOVEFLOPPYIOCB SECTOR) + of IOCB)) + (replace (DOVEFLOPPYCMDBYTES CB6) of CMDBYTES with ENCODEDSECTORLENGTH) + (replace (DOVEFLOPPYCMDBYTES CB7) of CMDBYTES with (fetch (DOVEFLOPPYFORMATINFO + SECTORSPERTRACK) + of FORMATINFO)) + (replace (DOVEFLOPPYCMDBYTES CB8) of CMDBYTES with (fetch (DOVEFLOPPYFORMATINFO + READWRITEGAPLENGTH) + of FORMATINFO)) + (replace (DOVEFLOPPYCMDBYTES CB9) of CMDBYTES with (COND + ((EQ (fetch (DOVEFLOPPYCMDBYTES + CB6) of CMDBYTES) + 0) + 128) + (T 255))) + (SELECTQ OPERATION + (FORMATTRACK (replace (DOVEFLOPPYCMDBYTES CB3) of CMDBYTES with ENCODEDSECTORLENGTH) + (replace (DOVEFLOPPYCMDBYTES CB4) of CMDBYTES with (fetch ( + DOVEFLOPPYFORMATINFO + SECTORSPERTRACK + ) of FORMATINFO + )) + (replace (DOVEFLOPPYCMDBYTES CB5) of CMDBYTES with (fetch ( + DOVEFLOPPYFORMATINFO + FORMATGAPLENGTH + ) of FORMATINFO + )) + (replace (DOVEFLOPPYCMDBYTES CB6) of CMDBYTES with (fetch (DOVEFLOPPYFCB + + FLOPPYFILLERFORFORMATTING + ) of + \DoveFloppy.FCBPointer + ))) + ((SCANEQUAL SCANHIGHOREQUAL SCANLOWOREQUAL) + (replace (DOVEFLOPPYCMDBYTES CB9) of CMDBYTES with 1)) + (SPECIFY (replace (DOVEFLOPPYCMDBYTES CB2) of CMDBYTES + with (fetch (DOVEFLOPPYDCB StepRateTimePlusHeadUnloadTime) + of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of \DoveFloppy.FCBPointer) + )) + (replace (DOVEFLOPPYCMDBYTES CB3) of CMDBYTES + with (fetch (DOVEFLOPPYDCB HeadLoadTimePlusNotInDMAmode) + of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of \DoveFloppy.FCBPointer) + ))) + NIL)))) + +(\DOVEFLOPPY.STOPHANDLER + [LAMBDA NIL (* ; "Edited 11-Jun-87 16:59 by jds") + + (* ;; "Stop the IOP floppy handler") + + (PROG (TIMER STATUS) + (replace (DOVEFLOPPYFCB FLOPPYSTOPHANDLER) of \DoveFloppy.FCBPointer with + \DOVEFLOPPY.BYTETRUE + ) + (\DoveIO.NotifyIOP (fetch (DOVEFLOPPYFCB FLOPPYWORKMASK) of \DoveFloppy.FCBPointer)) + (SETQ TIMER (SETUPTIMER 500)) + (until (OR (TIMEREXPIRED? TIMER) + (EQ \DOVEFLOPPY.BYTETRUE (fetch (DOVEFLOPPYFCB FLOPPYHANDLERISSTOPPED) + of \DoveFloppy.FCBPointer))) do (BLOCK)) + +(* ;;; "This line clears out all 3 queueblocks in the fcb. beware!") + + (\CLEARWORDS (fetch (DOVEFLOPPYFCB FLOPPYDIAGNOSTICQUEUE) of \DoveFloppy.FCBPointer) + (ITIMES 3 (MESASIZE Dove.QueueBlock))) + (replace (DOVEFLOPPYFCB FLOPPYSTOPHANDLER) of \DoveFloppy.FCBPointer with + \DOVEFLOPPY.BYTEFALSE + ) + [SETQ STATUS (COND + ((EQ \DOVEFLOPPY.BYTETRUE (fetch (DOVEFLOPPYFCB FLOPPYHANDLERISSTOPPED) + of \DoveFloppy.FCBPointer)) + (* ; + "A previous version of this COND had (TIMEREXPIRED? TIMER) as the first test, which was wrong. *") + + 'OK) + (T 'TIMEOUT] + (RETURN STATUS]) + +(\DOVEFLOPPY.TRANSFER + [LAMBDA (CYL HD SEC BUFF MODE RESET? RECAL?) (* ; "Edited 11-Jun-87 14:41 by jds") + + (PROG (STATUS) + [COND + ((NULL \DOVEFLOPPY.IOCB) + (SETQ \DOVEFLOPPY.IOCB (NCREATE 'VMEMPAGEP] + + (* ;; "Set up IOCB:") + + (replace (DOVEFLOPPYIOCB CYLINDER) of \DOVEFLOPPY.IOCB with CYL) + (replace (DOVEFLOPPYIOCB HEAD) of \DOVEFLOPPY.IOCB with HD) + (replace (DOVEFLOPPYIOCB SECTOR) of \DOVEFLOPPY.IOCB with SEC) + (replace (DOVEFLOPPYIOCB BUFFER) of \DOVEFLOPPY.IOCB with BUFF) + (replace (DOVEFLOPPYIOCB OPERATION) of \DOVEFLOPPY.IOCB with MODE) + (replace (DOVEFLOPPYIOCB RESETFIRST?) of \DOVEFLOPPY.IOCB with RESET?) + (replace (DOVEFLOPPYIOCB RECALIBRATEFIRST?) of \DOVEFLOPPY.IOCB with RECAL?) + [SETQ STATUS (COND + ((EQ (\DOVEFLOPPY.INITIATE \DOVEFLOPPY.IOCB) + \DOVEFLOPPY.OPERATIONCOMPLETED) + 'OK) + (T (\DOVEFLOPPY.GETERRORSTATUS \DOVEFLOPPY.IOCB] + (RETURN STATUS]) + +(\DOVEFLOPPY.VALIDATEIOCB + (LAMBDA (IOCB) (* kbr%: " 5-Oct-85 17:08") + (DECLARE (GLOBALVARS \DOVEFLOPPY.CURRENTCONTEXT \DOVEFLOPPY.COMMANDS)) + (PROG (DCBPTR) + (SETQ DCBPTR (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) of \DoveFloppy.FCBPointer)) + (COND + ((NOT (FASSOC (fetch (DOVEFLOPPYIOCB OPERATION) of IOCB) + \DOVEFLOPPY.COMMANDS)) + (HELP "Invalid operation " (fetch (DOVEFLOPPYIOCB OPERATION) of IOCB)))) + (COND + ((NOT (fetch (DOVEFLOPPYIOCB BUFFER) of IOCB)) + (HELP "No buffer supplied!"))) + (COND + ((OR (ILESSP (fetch (DOVEFLOPPYIOCB CYLINDER) of IOCB) + 0) + (IGREATERP (fetch (DOVEFLOPPYIOCB CYLINDER) of IOCB) + (fetch (DOVEFLOPPYCONTEXT NUMBEROFCYLINDERS) of \DOVEFLOPPY.CURRENTCONTEXT)) + ) + (HELP "Invalid Cylinder " (fetch (DOVEFLOPPYIOCB CYLINDER) of IOCB)))) + (COND + ((OR (ILESSP (fetch (DOVEFLOPPYIOCB HEAD) of IOCB) + 0) + (IGREATERP (fetch (DOVEFLOPPYIOCB HEAD) of IOCB) + (fetch (DOVEFLOPPYCONTEXT NUMBEROFHEADS) of \DOVEFLOPPY.CURRENTCONTEXT))) + (HELP "Invalid Head " (fetch (DOVEFLOPPYIOCB HEAD) of IOCB)))) + (COND + ((EQ (fetch (DOVEFLOPPYDCB DRIVEACQUIREDBYPCE) of DCBPTR) + \DOVEFLOPPY.BYTETRUE) + (HELP "The PCE is using this drive!"))) + (replace (DOVEFLOPPYIOCB OPERATIONSTATE) of IOCB with \DOVEFLOPPY.INPROGRESS)))) + +(\DOVEFLOPPY.WRITEPROTECTED + (LAMBDA NIL (* kbr%: " 5-Oct-85 17:45") + (NOT (EQ 0 (LOGAND \DOVEFLOPPY.WRITEPROTECT (fetch (DOVEFLOPPYDCB DRIVESTATUSHEAD0) + of (fetch (DOVEFLOPPYFCB FLOPPYDCB0BASE) + of \DoveFloppy.FCBPointer))))))) +) + +(RPAQ? \DOVEFLOPPY.IOCB NIL) + +(RPAQ? \DOVEFLOPPY.CURRENTCONTEXT NIL) + +(RPAQ? \DoveFloppy.FCBPointer ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DOVEFLOPPY.IOCB \DOVEFLOPPY.CURRENTCONTEXT \DOVEFLOPPY.HARDFDCCOMMANDS + \DoveFloppy.FCBPointer) +) +(PUTPROPS DOVEFLOPPY COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (18996 65478 (\DOVEFLOPPY.RESET 19006 . 19152) (\DOVEFLOPPY.SETCONTEXT 19154 . 20042) ( +\DOVEFLOPPY.XFERDISK 20044 . 22628) (\DOVEFLOPPY.BYTESWAPIOCB 22630 . 28745) ( +\DOVEFLOPPY.CLEARDISKCHANGED 28747 . 29156) (\DOVEFLOPPY.DISKCHANGED 29158 . 29486) ( +\DOVEFLOPPY.DOOROPEN 29488 . 29882) (\DOVEFLOPPY.GETERRORSTATUS 29884 . 31962) (\DOVEFLOPPY.INIT 31964 + . 32741) (\DOVEFLOPPY.INITDCB 32743 . 35440) (\DOVEFLOPPY.INITIOCB 35442 . 39225) ( +\DOVEFLOPPY.INITIATE 39227 . 42877) (\DOVEFLOPPY.SETUPDMAINFO 42879 . 49039) ( +\DOVEFLOPPY.SETUPPRIMITIVEFDCOP 49041 . 60258) (\DOVEFLOPPY.STOPHANDLER 60260 . 62033) ( +\DOVEFLOPPY.TRANSFER 62035 . 63273) (\DOVEFLOPPY.VALIDATEIOCB 63275 . 65060) ( +\DOVEFLOPPY.WRITEPROTECTED 65062 . 65476))))) +STOP diff --git a/sources/DOVEINPUTOUTPUT b/sources/DOVEINPUTOUTPUT new file mode 100644 index 00000000..c91c4b7b --- /dev/null +++ b/sources/DOVEINPUTOUTPUT @@ -0,0 +1,136 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 16:07:53" {DSK}local>lde>lispcore>sources>DOVEINPUTOUTPUT.;2 5700 + + changes to%: (VARS DOVEINPUTOUTPUTCOMS) + + previous date%: " 7-Dec-87 15:27:52" {DSK}local>lde>lispcore>sources>DOVEINPUTOUTPUT.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEINPUTOUTPUTCOMS) + +(RPAQQ DOVEINPUTOUTPUTCOMS + [(FNS \DoveIO.EQOpieAddrs \DoveIO.GetHandlerIORegionPtr \DoveIO.Init + \DoveIO.InitializeIORegionPtrs \DoveIO.MakeOpieAddress \DoveIO.NilOpieAddress + \DoveIO.PointerFromOpieAddress) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + DOVEDECLS) + (EXPORT (MACROS \DoveIO.InitFCBPtr))) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DoveIO.Init]) +(DEFINEQ + +(\DoveIO.EQOpieAddrs + [LAMBDA (A1 A2) + (AND (EQ (\GETBASE A1 0) + (\GETBASE A2 0)) + (EQ (\GETBASE A1 1) + (\GETBASE A2 1]) + +(\DoveIO.GetHandlerIORegionPtr + [LAMBDA (HandlerID) (* ejs%: "12-Sep-85 19:08") + + (* * Return the base address of the pointer to the requested handler) + + (\ADDBASE \DoveIORegion (ITIMES DoveIO.SegmentGranularity + (IDIFFERENCE [\DoveIO.ByteSwap + (fetch (DoveIO.SegmentRec ioRegionSegment) + of + (\ADDBASE (fetch (DoveIO.IORTable + segments) + of \DoveIORegion + ) + (ITIMES HandlerID + (MESASIZE + DoveIO.SegmentRec + ] + DoveIO.iorSegmentBase]) + +(\DoveIO.Init + [LAMBDA NIL (* ; "Edited 7-Dec-87 15:27 by raf") + + (MAPC '(\DoveIO.MakeOpieAddress \DoveIO.PointerFromOpieAddress \DoveIO.NilOpieAddress + \DoveIO.EQOpieAddrs \DoveIO.InitializeIORegionPtrs + \DoveIO.GetHandlerIORegionPtr) (FUNCTION \LOCKFN]) + +(\DoveIO.InitializeIORegionPtrs + [LAMBDA NIL (* ejs%: "31-Mar-86 11:12") + + (* * Set the values of the FCB pointers in the Dove IO Region) + + (\DoveIO.InitFCBPtr \DoveBeep.FCBPointer DoveIO.beepHandler) + (\DoveIO.InitFCBPtr \DoveDisk.FCBPointer DoveIO.diskHandler) + (\DoveIO.InitFCBPtr \DoveDisplay.FCBPointer DoveIO.displayHandler) + (\DoveIO.InitFCBPtr \DoveEther.FCBPointer DoveIO.ethernetHandler) + (\DoveIO.InitFCBPtr \DoveFloppy.FCBPointer DoveIO.floppyHandler) + (\DoveIO.InitFCBPtr \DoveKyMo.FCBPointer DoveIO.kymoHandler) + (\DoveIO.InitFCBPtr \DoveProcessor.FCBPointer DoveIO.lispHandler) + (\DoveIO.InitFCBPtr \DoveMP.FCBPointer DoveIO.mpHandler]) + +(\DoveIO.MakeOpieAddress + [LAMBDA (DESTLOC SRCPTR) (* ejs%: "12-Aug-85 07:01") + + (* * This function takes SRCPTR as a Lisp pointer and smashes the two words at + DESTLOC with an OpieAddress that corresponds to the pointer) + + (replace (Dove.OpieAddress LoPart.BS) + of DESTLOC with (\DoveIO.ByteSwap (\LOLOC SRCPTR))) + (replace (Dove.OpieAddress HiPart) + of DESTLOC with (\HILOC SRCPTR)) + (COND + ((NEQ (\HILOC SRCPTR) + 0) + (replace (Dove.OpieAddress AddrType) + of DESTLOC with \DoveIO.VirtualWordType)) + (T (replace (Dove.OpieAddress AddrType) + of DESTLOC with \DoveIO.VirtualFirst64KRelativeType]) + +(\DoveIO.NilOpieAddress + [LAMBDA (PTRTOADDRESS) + (AND (EQ 0 (\GETBASE PTRTOADDRESS 0)) + (EQ 0 (\GETBASE PTRTOADDRESS 1]) + +(\DoveIO.PointerFromOpieAddress + [LAMBDA (ADDRESSLOC) + (\VAG2 (fetch (Dove.OpieAddress HiPart) + of ADDRESSLOC) + (\DoveIO.ByteSwap (fetch (Dove.OpieAddress LoPart.BS) + of ADDRESSLOC]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + DOVEDECLS) + +(* "FOLLOWING DEFINITIONS EXPORTED") + +(DECLARE%: EVAL@COMPILE + +(PROGN (DEFMACRO \DoveIO.InitFCBPtr (FCBPointer HandlerID) + (COND + ((NOT (COMP.GLOBALVARP FCBPointer)) + (printout T "*** WARNING: " FCBPointer " is unknown in call to \DoveIO.InitFCBPtr ***" + T))) + (COND + ((NOT (CONSTANTEXPRESSIONP HandlerID)) + (printout T "*** WARNING: " HandlerID + " is not constant in call to \DoveIO.InitFCBPtr ***" T))) + `(SETQ %, FCBPointer (\DoveIO.GetHandlerIORegionPtr %, HandlerID))) + NIL) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\DoveIO.Init) +) +(PUTPROPS DOVEINPUTOUTPUT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (929 4815 (\DoveIO.EQOpieAddrs 939 . 1141) (\DoveIO.GetHandlerIORegionPtr 1143 . 2497) ( +\DoveIO.Init 2499 . 2866) (\DoveIO.InitializeIORegionPtrs 2868 . 3614) (\DoveIO.MakeOpieAddress 3616 + . 4391) (\DoveIO.NilOpieAddress 4393 . 4551) (\DoveIO.PointerFromOpieAddress 4553 . 4813))))) +STOP diff --git a/sources/DOVEMISC b/sources/DOVEMISC new file mode 100644 index 00000000..ec80d6a7 --- /dev/null +++ b/sources/DOVEMISC @@ -0,0 +1,287 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-May-90 16:09:03" {DSK}local>lde>lispcore>sources>DOVEMISC.;2 13204 + + changes to%: (VARS DOVEMISCCOMS) + + previous date%: "24-Oct-86 13:06:41" {DSK}local>lde>lispcore>sources>DOVEMISC.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT DOVEMISCCOMS) + +(RPAQQ DOVEMISCCOMS + [(FNS \DoveMisc.BeepOff \DoveMisc.BeepOn \DoveMisc.BootButton \DoveMisc.DoProcessorCommand + \DoveMisc.GetKBDBase \DoveMisc.GetMouseXBase \DoveMisc.GetMouseYBase \DoveMisc.Init + \DoveMisc.ReadDisplayDesc \DoveMisc.ReadGMT \DoveMisc.ReadHostID + \DoveMisc.ReadKeyboardType \DoveMisc.ReadPCType \DoveMisc.ReadRealMemDesc + \DoveMisc.ReadVMMapDesc \DoveMisc.SetMousePosition \DoveMisc.TODValid \DoveMisc.WriteGMT + ) + (INITVARS (\DoveBeep.FCBPointer) + (\DoveProcessor.FCBPointer) + (\DoveKyMo.FCBPointer) + (\DoveMP.FCBPointer)) + (GLOBALVARS \DoveBeep.FCBPointer \DoveProcessor.FCBPointer \DoveKyMo.FCBPointer + \DoveMP.FCBPointer) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + DOVEDECLS) + (RECORDS Dove.BeepFCB Dove.KeyboardFCB Dove.ProcessorFCB Dove.TODFormat) + (CONSTANTS (\DoveMisc.ReadGMT 1) + (\DoveMisc.WriteGMT 2) + (\DoveMisc.ReadHostID 3) + (\DoveMisc.ReadVMMapDesc 4) + (\DoveMisc.ReadRealMemDesc 5) + (\DoveMisc.ReadDisplayDesc 6) + (\DoveMisc.ReadKeyboardType 7) + (\DoveMisc.ReadPCType 8) + (\DoveMisc.BootButton 9))) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DoveMisc.Init]) +(DEFINEQ + +(\DoveMisc.BeepOff + (LAMBDA NIL (* ejs%: "13-Sep-85 00:25") + (replace (Dove.BeepFCB Frequency.BS) of \DoveBeep.FCBPointer with 0) + (\DoveIO.NotifyIOP (fetch (Dove.BeepFCB BeepMask) of \DoveBeep.FCBPointer)))) + +(\DoveMisc.BeepOn + (LAMBDA (FREQ) + (DECLARE (GLOBALVARS \DoveIORegion)) + (replace (Dove.BeepFCB Frequency.BS) of \DoveBeep.FCBPointer + with (\DoveIO.ByteSwap (FIX (QUOTIENT 1000000 (IMAX FREQ 14))))) + (\DoveIO.NotifyIOP (fetch (Dove.BeepFCB BeepMask) of \DoveBeep.FCBPointer)))) + +(\DoveMisc.BootButton + (LAMBDA NIL (* mpl "23-Jul-85 23:46") + + (* * This fn re-boots the machine) + + (DECLARE (CONSTANTS \DoveMisc.BootButton)) + (\DoveMisc.DoProcessorCommand \DoveMisc.BootButton) + (until NIL do (NILL)))) + +(\DoveMisc.DoProcessorCommand + (LAMBDA (CMD) (* ejs%: "14-Oct-85 00:04") + + (* * This fn stuffs commands at the mesa processor task) + + (replace (Dove.ProcessorFCB Command) of \DoveProcessor.FCBPointer with CMD) + (\PUTBASE \IOPAGE 10 7000) + (\DoveIO.NotifyIOP 0) + (\PUTBASE \IOPAGE 10 7003) + (until (EQ 0 (fetch (Dove.ProcessorFCB Command) of \DoveProcessor.FCBPointer))) + (\PUTBASE \IOPAGE 10 7004))) + +(\DoveMisc.GetKBDBase + (LAMBDA NIL (* ejs%: "12-Oct-85 21:22") + (fetch (Dove.KeyboardFCB KeyBitsBase) of \DoveKyMo.FCBPointer))) + +(\DoveMisc.GetMouseXBase + (LAMBDA NIL + (DECLARE (GLOBALVARS \DoveIORegion) + (CONSTANTS \Dove.Keyboard&MouseFCBOffset)) (* ejs%: "13-Sep-85 00:29") + (\ADDBASE \DoveKyMo.FCBPointer (INDEXF (fetch (Dove.KeyboardFCB MouseX)))))) + +(\DoveMisc.GetMouseYBase + (LAMBDA NIL (* ejs%: "13-Sep-85 00:30") + (\ADDBASE \DoveKyMo.FCBPointer (INDEXF (fetch (Dove.KeyboardFCB MouseY)))))) + +(\DoveMisc.Init + (LAMBDA NIL (* ejs%: "14-Oct-85 00:42") + (MAPC '(\DoveMisc.GetKBDBase \DoveMisc.GetMouseXBase \DoveMisc.GetMouseYBase \DoveMisc.BeepOff + \DoveMisc.SetMousePosition \DoveMisc.DoProcessorCommand \DoveMisc.ReadGMT + \DoveMisc.ReadHostID \DoveMisc.BootButton) (FUNCTION \LOCKFN)) + (MAPC '(\DoveBeep.FCBPointer \DoveProcessor.FCBPointer \DoveKyMo.FCBPointer \DoveMP.FCBPointer) + (FUNCTION \LOCKVAR)))) + +(\DoveMisc.ReadDisplayDesc + (LAMBDA NIL (* ejs%: "23-Oct-85 15:36") + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadDisplayDesc) + (LIST (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 0)) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 1)) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 2))))) + +(\DoveMisc.ReadGMT + (LAMBDA (CLOCKLOC) (* ejs%: "12-Oct-85 21:23") + (COND + ((EQ (fetch (Dove.ProcessorFCB TODValid) of \DoveProcessor.FCBPointer) + \DoveIO.ByteTRUE) (* Set clock) + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadGMT) + (\PUTBASE CLOCKLOC 0 (\DoveIO.ByteSwap (fetch (Dove.TODFormat ClockLow.BS) + of (fetch (Dove.ProcessorFCB Data) of + \DoveProcessor.FCBPointer + )))) + (\PUTBASE CLOCKLOC 1 (\DoveIO.ByteSwap (fetch (Dove.TODFormat ClockHigh.BS) + of (fetch (Dove.ProcessorFCB Data) of + \DoveProcessor.FCBPointer + ))))) + (T (* zero clock) + (\PUTBASE CLOCKLOC 0 0) + (\PUTBASE CLOCKLOC 1 0))))) + +(\DoveMisc.ReadHostID + (LAMBDA (HOSTLOC) (* ejs%: "12-Oct-85 21:23") + + (* * Reads host id of this machine and smashes 3 words at HOSTLOC) + + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadHostID) + (\BLT HOSTLOC (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 3) + NIL)) + +(\DoveMisc.ReadKeyboardType + (LAMBDA NIL (* ejs%: "23-Oct-85 15:31") + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadKeyboardType) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 0)))) + +(\DoveMisc.ReadPCType + (LAMBDA NIL (* ejs%: "23-Oct-85 15:31") + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadPCType) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 0)))) + +(\DoveMisc.ReadRealMemDesc + (LAMBDA NIL (* ejs%: "23-Oct-85 15:33") + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadRealMemDesc) + (LIST (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 0)) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 1)) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 2))))) + +(\DoveMisc.ReadVMMapDesc + (LAMBDA NIL (* ejs%: "23-Oct-85 15:35") + (\DoveMisc.DoProcessorCommand \DoveMisc.ReadVMMapDesc) + (LIST (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 0)) + (\DoveIO.ByteSwap (\GETBASE (fetch (Dove.ProcessorFCB Data) of \DoveProcessor.FCBPointer) + 1))))) + +(\DoveMisc.SetMousePosition + (LAMBDA (X Y) (* ejs%: "13-Sep-85 00:30") + (do (replace (Dove.KeyboardFCB MouseX) of \DoveKyMo.FCBPointer with X) + (replace (Dove.KeyboardFCB MouseY) of \DoveKyMo.FCBPointer with Y) + repeatuntil (AND (EQ X (fetch (Dove.KeyboardFCB MouseX) of \DoveKyMo.FCBPointer)) + (EQ Y (fetch (Dove.KeyboardFCB MouseY) of \DoveKyMo.FCBPointer)))))) + +(\DoveMisc.TODValid + (LAMBDA NIL (* ejs%: "29-Dec-85 15:23") + (EQ \DoveIO.ByteTRUE (fetch (Dove.ProcessorFCB TODValid) of \DoveProcessor.FCBPointer)))) + +(\DoveMisc.WriteGMT + (LAMBDA (CLOCKLOC) (* ejs%: "12-Oct-85 21:24") + (* Set clock) + (replace (Dove.TODFormat ClockLow.BS) of (fetch (Dove.ProcessorFCB Data) of + \DoveProcessor.FCBPointer + ) with (\DoveIO.ByteSwap (\GETBASE CLOCKLOC 0))) + (replace (Dove.TODFormat ClockHigh.BS) of (fetch (Dove.ProcessorFCB Data) of + \DoveProcessor.FCBPointer + ) with (\DoveIO.ByteSwap (\GETBASE CLOCKLOC 1))) + (\DoveMisc.DoProcessorCommand \DoveMisc.WriteGMT) + (replace (Dove.ProcessorFCB TODValid) of \DoveProcessor.FCBPointer with \DoveIO.ByteTRUE))) +) + +(RPAQ? \DoveBeep.FCBPointer ) + +(RPAQ? \DoveProcessor.FCBPointer ) + +(RPAQ? \DoveKyMo.FCBPointer ) + +(RPAQ? \DoveMP.FCBPointer ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DoveBeep.FCBPointer \DoveProcessor.FCBPointer \DoveKyMo.FCBPointer \DoveMP.FCBPointer) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + DOVEDECLS) + +(DECLARE%: EVAL@COMPILE + +(MESARECORD Dove.BeepFCB ((BeepTCB DoveIO.TaskContextBlock) + (BeepCondition WORD) + (BeepMask WORD) + (Frequency.BS WORD))) + +(MESARECORD Dove.KeyboardFCB ((KeyboardTCB DoveIO.TaskContextBlock) + (hexValue BYTE) + (convertKeyCodeToBit BYTE) + (frameErrorCnt.BS WORD) + (overRunErrorCnt.BS WORD) + (parityErrorCnt.BS WORD) + (spuriousIntCnt.BS WORD) + (watchDogCnt.BS WORD) + (badInterruptCnt.BS WORD) + (MouseX WORD) + (MouseY WORD) + (KeyBitsBase 9 WORD))) + +(MESARECORD Dove.ProcessorFCB ((notifiersLockMask WORD) + (upNotifyBits 1 WORD) + (downNotifyBits 2 WORD) + (mesaClientCondition WORD) + (mesaClientMask WORD) + (TODValid BYTE) + (Command BYTE) + (Data 3 WORD) + (ProcessorTCB DoveIO.TaskContextBlock) + (ClientTCB DoveIO.TaskContextBlock))) + +(BLOCKRECORD Dove.TODFormat ((ClockLow.BS WORD) + (ClockHigh.BS WORD))) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DoveMisc.ReadGMT 1) + +(RPAQQ \DoveMisc.WriteGMT 2) + +(RPAQQ \DoveMisc.ReadHostID 3) + +(RPAQQ \DoveMisc.ReadVMMapDesc 4) + +(RPAQQ \DoveMisc.ReadRealMemDesc 5) + +(RPAQQ \DoveMisc.ReadDisplayDesc 6) + +(RPAQQ \DoveMisc.ReadKeyboardType 7) + +(RPAQQ \DoveMisc.ReadPCType 8) + +(RPAQQ \DoveMisc.BootButton 9) + + +(CONSTANTS (\DoveMisc.ReadGMT 1) + (\DoveMisc.WriteGMT 2) + (\DoveMisc.ReadHostID 3) + (\DoveMisc.ReadVMMapDesc 4) + (\DoveMisc.ReadRealMemDesc 5) + (\DoveMisc.ReadDisplayDesc 6) + (\DoveMisc.ReadKeyboardType 7) + (\DoveMisc.ReadPCType 8) + (\DoveMisc.BootButton 9)) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\DoveMisc.Init) +) +(PUTPROPS DOVEMISC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1918 10351 (\DoveMisc.BeepOff 1928 . 2222) (\DoveMisc.BeepOn 2224 . 2546) ( +\DoveMisc.BootButton 2548 . 2876) (\DoveMisc.DoProcessorCommand 2878 . 3400) (\DoveMisc.GetKBDBase +3402 . 3601) (\DoveMisc.GetMouseXBase 3603 . 3871) (\DoveMisc.GetMouseYBase 3873 . 4083) ( +\DoveMisc.Init 4085 . 4612) (\DoveMisc.ReadDisplayDesc 4614 . 5250) (\DoveMisc.ReadGMT 5252 . 6471) ( +\DoveMisc.ReadHostID 6473 . 6859) (\DoveMisc.ReadKeyboardType 6861 . 7192) (\DoveMisc.ReadPCType 7194 + . 7513) (\DoveMisc.ReadRealMemDesc 7515 . 8151) (\DoveMisc.ReadVMMapDesc 8153 . 8638) ( +\DoveMisc.SetMousePosition 8640 . 9148) (\DoveMisc.TODValid 9150 . 9372) (\DoveMisc.WriteGMT 9374 . +10349))))) +STOP diff --git a/sources/DPUPFTP b/sources/DPUPFTP new file mode 100644 index 00000000..32ff9a4c --- /dev/null +++ b/sources/DPUPFTP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 16:10:35" {DSK}local>lde>lispcore>sources>DPUPFTP.;2 50085 changes to%: (VARS DPUPFTPCOMS) previous date%: "19-Aug-88 12:45:25" {DSK}local>lde>lispcore>sources>DPUPFTP.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DPUPFTPCOMS) (RPAQQ DPUPFTPCOMS [ (* ;;; "Implementation of the PUP FTP device") (COMS (FNS \FTPINIT \FTPEVENTFN \FTP.OPENFILE \FTP.REOPENFILE \FTP.OPENFILE.FROM.PLIST \FTP.GETFILENAME \FTP.RECOGNIZEFILE \FTP.DIRECTORYNAMEP \FTP.CLOSEFILE \FTP.REGISTER \FTP.UNREGISTER \FTP.RENAMEFILE \FTP.DELETEFILE \FTP.GENERATEFILES \FTP.NEXTFILE \FTP.FILEINFOFN \FTP.GETFILEINFO \FTP.GETFILEINFO.FROM.PROPS \FTP.FROM.LISP.ATTRIBUTE) (INITVARS (\FTPAVAILABLE) (\FTP.IDLE.TIMEOUT 120000) (*FTP-IGNORE-SERVER-FULL*))) (COMS (* ;; "internal") (FNS \FTP.OPEN.CONNECTION FTP.BREAKCONNECTION \FTP.SENDVERSION \FTP.WHENCLOSED \GETFTPCONNECTION \RELEASE.FTPCONNECTION \FTP.ERRORHANDLER \FTP.FIX.BROKEN.INPUT \FTP.CLEANUP \FTP.ASSURE.CLEANUP) (ADDVARS (\FTPCONNECTIONS)) (FNS \FTP.HANDLE.NO \FTP.DIRECTORYNAMEONLY \FTP.EOL.FROM.PLIST \FTP.MAKEPLIST \FTP.PRINTPLIST \FTP.PACKFILENAME \FTP.ADD.QUOTES \FTP.PACK.DIRECTORYNAMEP \FTP.UNPACKFILENAME \FTP.ADD.USERINFO \FTP.FLUSH.TO.EOC \FTP.FLUSH.TO.MARK \FTPERROR)) (COMS (* ;; "for debugging") (FNS FTPDEBUG FTPPRINTMARK FTPPRINTCODE FTPGETMARK FTPPUTMARK FTPPUTCODE FTPGETCODE) (INITVARS (FTPDEBUGLOG) (FTPDEBUGFLG))) (DECLARE%: EVAL@COMPILE DONTCOPY (VARS FTPMARKTYPES) (CONSTANTS \FTP.VERSION) (CONSTANTS * FTPNOCODES) (MACROS MARK# .EOC. .FTPDEBUGLOG.) (PROP INFO MARK#) (RECORDS FTPCONNECTION FTPSTREAM FTPFILEGENSTATE) (GLOBALVARS FTPDEBUGFLG \FTPCONNECTIONS \FTPAVAILABLE \FTP.IDLE.TIMEOUT \BSPFDEV \FTPFDEV)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\FTPINIT]) (* ;;; "Implementation of the PUP FTP device") (DEFINEQ (\FTPINIT (LAMBDA NIL (* ; "Edited 17-Nov-87 14:43 by bvm:") (COND ((type? FDEV \BSPFDEV) (SETQ \FTPFDEV (NCREATE (QUOTE FDEV) \BSPFDEV)) (* ; "Specialize the BSP device") (with FDEV \FTPFDEV (SETQ DEVICENAME (QUOTE DPUPFTP)) (SETQ OPENFILE (FUNCTION \FTP.OPENFILE)) (SETQ REOPENFILE (FUNCTION \FTP.REOPENFILE)) (SETQ CLOSEFILE (FUNCTION \FTP.CLOSEFILE)) (SETQ DIRECTORYNAMEP (FUNCTION \FTP.DIRECTORYNAMEP)) (SETQ GETFILENAME (FUNCTION \FTP.GETFILENAME)) (SETQ GETFILEINFO (FUNCTION \FTP.GETFILEINFO)) (SETQ RENAMEFILE (FUNCTION \FTP.RENAMEFILE)) (SETQ DELETEFILE (FUNCTION \FTP.DELETEFILE)) (SETQ GENERATEFILES (FUNCTION \FTP.GENERATEFILES)) (SETQ EVENTFN (FUNCTION \FTPEVENTFN)) (SETQ OPENP (FUNCTION \GENERIC.OPENP)) (SETQ REGISTERFILE (FUNCTION \FTP.REGISTER)) (SETQ UNREGISTERFILE (FUNCTION \FTP.UNREGISTER))) (SETQ \FTPAVAILABLE T)))) ) (\FTPEVENTFN (LAMBDA (DEV EVENT) (* bvm%: "28-Apr-85 14:32") (SELECTQ EVENT (BEFORELOGOUT (FTP.BREAKCONNECTION T)) ((BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM) (FTP.BREAKCONNECTION T T)) NIL) (\BSPEVENTFN DEV EVENT)) ) (\FTP.OPENFILE (LAMBDA (FILENAME ACCESS RECOG OTHERINFO) (* ; "Edited 16-Nov-87 17:17 by bvm") (RESETLST (PROG (HOST DESIREDPLIST TYPE BYTESIZE EOLCONVENTION) (COND ((SELECTQ ACCESS (INPUT (EQ RECOG (QUOTE NEW))) (OUTPUT (EQ RECOG (QUOTE OLD))) T) (LISPERROR "FILE WON'T OPEN" FILENAME))) (OR (SETQ HOST (\FTP.UNPACKFILENAME FILENAME)) (RETURN)) (SETQ DESIREDPLIST (CDR HOST)) (SETQ HOST (CAR HOST)) (SELECTQ ACCESS (OUTPUT (for PAIR in OTHERINFO when (LISTP PAIR) do (COND ((SELECTQ (CAR PAIR) ((TYPE FILETYPE) (SELECTQ (SETQ TYPE (CADR PAIR)) (TEXT T) (NIL) (PROGN (* ; "All unrecognized types are BINARY") (SETQ TYPE (QUOTE BINARY)))) NIL) (BYTESIZE (SETQ BYTESIZE (OR (FIXP (CADR PAIR)) (LISPERROR "ILLEGAL ARG" PAIR))) NIL) ((EOL EOLCONVENTION) (SETQ EOLCONVENTION (CADR PAIR)) NIL) ((CREATIONDATE ICREATIONDATE) (push DESIREDPLIST (LIST (QUOTE CREATION-DATE) (if (EQ (CAR PAIR) (QUOTE ICREATIONDATE)) then (GDATE (CADR PAIR) (DATEFORMAT TIME.ZONE)) else (CADR PAIR)))) NIL) (LENGTH (push DESIREDPLIST (LIST (QUOTE SIZE) (OR (FIXP (CADR PAIR)) (LISPERROR "ILLEGAL ARG" PAIR)))) NIL) ((SEQUENTIAL DON'TCACHE) NIL) T) (push DESIREDPLIST PAIR)))) (push DESIREDPLIST (LIST (QUOTE TYPE) (OR TYPE (SETQ TYPE DEFAULTFILETYPE)))) (SELECTQ TYPE (TEXT (push DESIREDPLIST (LIST (QUOTE END-OF-LINE-CONVENTION) (OR EOLCONVENTION (QUOTE CR))))) (BINARY (push DESIREDPLIST (LIST (QUOTE BYTE-SIZE) (OR BYTESIZE 8)))) NIL)) NIL) (RETURN (\FTP.OPENFILE.FROM.PLIST HOST DESIREDPLIST ACCESS))))) ) (\FTP.REOPENFILE (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV STREAM) (* ; "Edited 17-Nov-87 14:43 by bvm:") (* ;; "This is for the crufty REVALIDATEFILELST that the Leaf device (where all our open files are registered) does after logout, etc. Simplest to just pass the file back as though all is ok; we will actually reopen it in the broken connection error handler when somebody tries to read more from the stream. Of course, if file was open for output, all is lost.") (AND (EQ ACCESS (QUOTE INPUT)) STREAM)) ) (\FTP.OPENFILE.FROM.PLIST (LAMBDA (HOST DESIREDPLIST ACCESS) (* bvm%: "28-Apr-85 14:14") (PROG (CONNECTION INS OUTS REMOTEPLIST FULLNAME) NEWCONNECTION (OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T)) (RETURN)) (SETQ INS (fetch FTPIN of CONNECTION)) (SETQ OUTS (fetch FTPOUT of CONNECTION)) RETRY (FTPPUTMARK OUTS (SELECTQ ACCESS (INPUT (MARK# RETRIEVE)) (OUTPUT (MARK# NEW-STORE)) NIL)) (\FTP.PRINTPLIST OUTS DESIREDPLIST) (.EOC. OUTS) (SELECTC (FTPGETMARK INS) ((MARK# NO) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST) (COND ((BSPOPENP INS (QUOTE INPUT)) (GO RETRY)) (T (GO NEWCONNECTION)))) (T (\RELEASE.FTPCONNECTION CONNECTION) (RETURN)))) ((MARK# HERE-IS-PLIST) (SETQ REMOTEPLIST (READPLIST INS)) (SETQ FULLNAME (\FTP.PACKFILENAME HOST REMOTEPLIST NIL (CADR (ASSOC (QUOTE DEVICE) DESIREDPLIST)))) (OR (EQ (FTPGETMARK INS) (MARK# EOC)) (RETURN (\FTPERROR CONNECTION)))) ((MARK# BROKEN) (GO NEWCONNECTION)) (RETURN (\FTPERROR CONNECTION))) (SELECTQ ACCESS (INPUT (FTPPUTMARK OUTS (MARK# YES)) (FTPPUTCODE OUTS 0) (.EOC. OUTS) (SELECTC (FTPGETMARK INS) ((MARK# NO) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL NIL T) (CLOSEBSPSTREAM INS 2000) (* ; "Can't recover from in the middle like this, so just flush and start over") (GO NEWCONNECTION)) (T (\RELEASE.FTPCONNECTION CONNECTION) (RETURN (LISPERROR "FILE WON'T OPEN" FULLNAME))))) ((MARK# HERE-IS-FILE) (replace FULLFILENAME of INS with FULLNAME) (replace FTPFILEPROPS of INS with REMOTEPLIST) (replace ACCESS of INS with (QUOTE INPUT)) (replace EOLCONVENTION of INS with (\FTP.EOL.FROM.PLIST REMOTEPLIST)) (\BSP.DECLARE.FILEPTR INS 0) (* ; "For GETFILEPTR") (replace DEVICE of INS with \FTPFDEV) (RETURN INS)) ((MARK# BROKEN) (GO NEWCONNECTION)) (RETURN (\FTPERROR CONNECTION)))) (OUTPUT (COND ((BSPOPENP OUTS (QUOTE OUTPUT)) (FTPPUTMARK OUTS (MARK# HERE-IS-FILE)) (replace FULLFILENAME of OUTS with FULLNAME) (replace FTPFILEPROPS of OUTS with REMOTEPLIST) (\BSP.DECLARE.FILEPTR OUTS 0) (replace EOLCONVENTION of OUTS with (\FTP.EOL.FROM.PLIST DESIREDPLIST)) (replace DEVICE of OUTS with \FTPFDEV) (RETURN OUTS)) (T (GO NEWCONNECTION)))) NIL))) ) (\FTP.GETFILENAME (LAMBDA (NAME RECOG DEV) (* ; "Edited 16-Nov-87 18:52 by bvm") (SELECTQ RECOG ((OLD OLDEST) (\FTP.RECOGNIZEFILE NAME DEV NIL RECOG)) ((OLD/NEW NEW) (OR (\FTP.RECOGNIZEFILE NAME DEV NIL RECOG) (PACKFILENAME (QUOTE BODY) NAME (QUOTE VERSION) 1))) (SHOULDNT))) ) (\FTP.RECOGNIZEFILE (LAMBDA (NAME DEV OPTION RECOG DESIREDPROPS) (* ; "Edited 19-Aug-88 12:04 by bvm") (RESETLST (PROG (CONNECTION HOST INS OUTS REMOTEPLIST DESIREDPLIST BESTVERSION V BESTPLIST RESULT CODE DEVICEWANTED) (OR (SETQ HOST (\FTP.UNPACKFILENAME NAME)) (RETURN)) (SETQ DESIREDPLIST (CDR HOST)) (SETQ HOST (CAR HOST)) (if (EQ OPTION (QUOTE DIRECTORYNAMEP)) then (* ; "Give random fake name") (RPLACA (CDR (ASSOC (QUOTE NAME-BODY) DESIREDPLIST)) "QXZYQJ") else (push DESIREDPLIST (QUOTE (DESIRED-PROPERTY VERSION))) (* ; "Will need VERSION attribute to discriminate versions") (if (NULL (ASSOC (QUOTE VERSION) DESIREDPLIST)) then (* ; "Try to restrict enumeration to a single version for speed") (if (SETQ V (SELECTQ (GETHOSTINFO HOST (QUOTE OSTYPE)) (VMS (if (EQ RECOG (QUOTE OLDEST)) then "-0" else "0")) ((TENEX TOPS20) (if (EQ RECOG (QUOTE OLDEST)) then "-2" else "0")) ((NIL IFS D) (if (EQ RECOG (QUOTE OLDEST)) then "L" else "H")) NIL)) then (push DESIREDPLIST (LIST (QUOTE VERSION) V)))) (if (NEQ OPTION (QUOTE PROPS)) then (push DESIREDPLIST (QUOTE (DESIRED-PROPERTY NAME-BODY))))) (if (NEQ OPTION (QUOTE PROPS)) then (* ; "PROPS doesn't care about the actual name") (push DESIREDPLIST (QUOTE (DESIRED-PROPERTY DIRECTORY))) (if (SETQ DEVICEWANTED (CADR (ASSOC (QUOTE DEVICE) DESIREDPLIST))) then (push DESIREDPLIST (QUOTE (DESIRED-PROPERTY DEVICE))))) (for PROP in DESIREDPROPS do (push DESIREDPLIST (BQUOTE (DESIRED-PROPERTY (\, PROP))))) NEWCONNECTION (OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T T)) (RETURN)) (SETQ INS (fetch FTPIN of CONNECTION)) (SETQ OUTS (fetch FTPOUT of CONNECTION)) RETRY (FTPPUTMARK OUTS (MARK# ENUMERATE)) (\FTP.PRINTPLIST OUTS DESIREDPLIST) (.EOC. OUTS) LP (SELECTC (FTPGETMARK INS) ((MARK# NO) (SELECTC (SETQ CODE (FTPGETCODE INS T)) (\NO.ILLEGAL.DIRECTORY (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.))) (\NO.FILE.NOT.FOUND (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.)) (COND ((EQ OPTION (QUOTE DIRECTORYNAMEP)) (* ; "Directory exists") (SETQ RESULT (\FTP.PACK.DIRECTORYNAMEP CONNECTION DESIREDPLIST))))) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL CODE NIL T) (COND ((BSPOPENP INS (QUOTE INPUT)) (GO RETRY)) (T (GO NEWCONNECTION))))))) ((MARK# HERE-IS-PLIST) (* ; "Have to remember the plist corresponding to the best version.") (SETQ REMOTEPLIST (READPLIST INS)) (if (OR (NULL (SETQ V (CADR (ASSOC (QUOTE VERSION) REMOTEPLIST)))) (PROGN (SETQ V (MKATOM V)) (OR (NULL BESTVERSION) (SELECTQ RECOG (OLDEST (< V BESTVERSION)) (> V BESTVERSION))))) then (SETQ BESTVERSION V) (SETQ BESTPLIST REMOTEPLIST)) (GO LP)) ((MARK# BROKEN) (GO NEWCONNECTION)) ((MARK# EOC) (SETQ RESULT (SELECTQ OPTION (PROPS BESTPLIST) (DIRECTORYNAMEP (\FTP.PACK.DIRECTORYNAMEP CONNECTION BESTPLIST)) (PROGN (if (AND (EQ RECOG (QUOTE NEW)) BESTVERSION) then (* ; "For RECOG NEW bump the version") (RPLACA (CDR (ASSOC (QUOTE VERSION) BESTPLIST)) (+ BESTVERSION 1))) (\FTP.PACKFILENAME HOST BESTPLIST NIL DEVICEWANTED))))) (\FTPERROR CONNECTION)) (\RELEASE.FTPCONNECTION CONNECTION) (RETURN RESULT)))) ) (\FTP.DIRECTORYNAMEP (LAMBDA (HOST/DIR DEV) (* bvm%: "27-SEP-83 17:59") (\FTP.RECOGNIZEFILE HOST/DIR DEV (QUOTE DIRECTORYNAMEP))) ) (\FTP.CLOSEFILE (LAMBDA (STREAM) (* ; "Edited 30-Nov-87 16:35 by bvm:") (PROG ((ACCESS (fetch ACCESS of STREAM)) (CONN (find C in \FTPCONNECTIONS suchthat (OR (EQ (fetch FTPIN of C) STREAM) (EQ (fetch FTPOUT of C) STREAM)))) (FILENAME (fetch FULLFILENAME of STREAM)) INS SUCCESS) (replace FTPFILEPROPS of STREAM with NIL) (SELECTQ ACCESS (INPUT (COND ((NOT (BSPOPENP STREAM ACCESS)) (* ; "connection went away") NIL) ((OR (\EOFP STREAM) (PROGN (\BSP.FLUSHINPUT STREAM) (AND (BSPOPENP STREAM ACCESS) (\EOFP STREAM)))) (* ;; "Hack. We are at the end of the file, or the remainder of the file has been sent, so we can terminate the RETRIEVE cleanly") (SETQ SUCCESS (SELECTC (FTPGETMARK STREAM) ((MARK# YES) (* ; "File sent ok") (FTPGETCODE STREAM) (\FTP.FLUSH.TO.EOC STREAM (.FTPDEBUGLOG.))) ((MARK# NO) (FTPGETCODE STREAM T) (PROG1 (\FTP.FLUSH.TO.EOC STREAM (\GETSTREAM PROMPTWINDOW (QUOTE OUTPUT))) (ERROR "CLOSEF: Remote file not successfully retrieved"))) NIL))))) (OUTPUT (OR (SELECTC (COND ((SETQ INS (BSPINPUTSTREAM STREAM)) (FTPPUTMARK STREAM (MARK# YES)) (FTPPUTCODE STREAM 0) (.EOC. STREAM) (FTPGETMARK INS))) ((MARK# YES) (FTPGETCODE INS) (SETQ SUCCESS (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.)))) ((MARK# NO) (SELECTC (PROG1 (FTPGETCODE INS T) (CL:FORMAT PROMPTWINDOW "~&~A: " (fetch FTPHOST of CONN)) (SETQ SUCCESS (\FTP.FLUSH.TO.EOC INS (\GETSTREAM PROMPTWINDOW (QUOTE OUTPUT))))) (\NO.STORAGE.FULL (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" FILENAME)) NIL)) NIL) (ERROR "CLOSEF: Remote file not successfully stored" FILENAME))) NIL) (COND (SUCCESS (* ; "Stream still in good protocol state") (replace DEVICE of STREAM with \BSPFDEV) (* ; "Make it back into a plain BSP stream") (\RELEASE.FTPCONNECTION CONN)) (CONN (CLOSEBSPSTREAM (fetch FTPIN of CONN) 1000))) (RETURN FILENAME))) ) (\FTP.REGISTER (LAMBDA (DEVICE STREAM) (* PAVEL "14-Oct-86 19:09") (\ADD-OPEN-STREAM (\GETDEVICEFROMNAME (fetch (STREAM FULLFILENAME) of STREAM)) STREAM)) ) (\FTP.UNREGISTER (LAMBDA (DEVICE STREAM) (* hdj " 1-Oct-86 18:23") (\GENERIC-UNREGISTER-STREAM (if (FMEMB STREAM (\DEVICE-OPEN-STREAMS DEVICE)) then DEVICE else (\GETDEVICEFROMNAME (fetch (STREAM FULLNAME) of STREAM))) STREAM)) ) (\FTP.RENAMEFILE (LAMBDA (OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE) (* ; "Edited 16-Nov-87 19:02 by bvm") (COND ((NEQ OLD-DEVICE NEW-DEVICE) (\GENERIC.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE)) (T (RESETLST (PROG ((HOST (\FTP.UNPACKFILENAME OLDFILE)) CONNECTION HOST OLDNAME INS OUTS OLDPLIST NEWPLIST CODE) (if NIL then (* ; "This is junk") (OR HOST (FDEVOP (QUOTE OPENP) OLD-DEVICE (FULLNAME OLDFILE) NIL OLD-DEVICE) (RETURN))) (SETQ OLDPLIST (CDR HOST)) (SETQ HOST (CAR HOST)) (OR (SETQ NEWPLIST (\FTP.UNPACKFILENAME NEWFILE T)) (RETURN)) (if (NOT (STRING-EQUAL (CAR NEWPLIST) HOST)) then (* ; "Different hosts--can't do it. This happens only if both hosts are ftp-only hosts, in which case they got mapped to the same device ") (RETURN (\GENERIC.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE)) else (SETQ NEWPLIST (CDR NEWPLIST))) (CLEAR.LEAF.CACHE HOST) (* ; "In case Leaf has this file open for input") NEWCONNECTION (OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T T)) (RETURN)) (SETQ INS (fetch FTPIN of CONNECTION)) (SETQ OUTS (fetch FTPOUT of CONNECTION)) RETRY (FTPPUTMARK OUTS (MARK# RENAME)) (\FTP.PRINTPLIST OUTS OLDPLIST) (\FTP.PRINTPLIST OUTS NEWPLIST) (.EOC. OUTS) (RETURN (if (PROG1 (SELECTC (FTPGETMARK INS) ((MARK# NO) (SELECTC (SETQ CODE (FTPGETCODE INS T)) (\NO.UNIMPLEMENTED (* ;; "Concession to stupid DEI") (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.)) (RETURN (\GENERIC.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE))) (COND ((\FTP.HANDLE.NO CONNECTION OLDPLIST NIL CODE NIL NIL NEWPLIST) (COND ((BSPOPENP INS (QUOTE INPUT)) (GO RETRY)) (T (GO NEWCONNECTION))))))) ((MARK# YES) (FTPGETCODE INS) (AND (\FTP.FLUSH.TO.EOC INS (.FTPDEBUGLOG.)) NEWFILE)) ((MARK# BROKEN) (GO NEWCONNECTION)) (\FTPERROR CONNECTION)) (\RELEASE.FTPCONNECTION CONNECTION)) then NEWFILE else (LISPERROR "FILE WON'T OPEN" NEWFILE)))))))) ) (\FTP.DELETEFILE (LAMBDA (FILENAME) (* ; "Edited 30-Nov-87 16:16 by bvm:") (RESETLST (PROG (CONNECTION HOST REMOTENAME INS OUTS REMOTEPLIST DESIREDPLIST RESULT) (OR (SETQ HOST (\FTP.UNPACKFILENAME FILENAME)) (if NIL then (* ; "This is junk") (LET* ((NAME (FULLNAME FILENAME)) (DEVICE (\GETDEVICEFROMNAME NAME))) (FDEVOP (QUOTE OPENP) DEVICE NAME NIL DEVICE))) (RETURN)) (SETQ DESIREDPLIST (CDR HOST)) (SETQ HOST (CAR HOST)) (COND ((AND (NULL (ASSOC (QUOTE VERSION) DESIREDPLIST)) (EQ (GETHOSTINFO HOST (QUOTE OSTYPE)) (QUOTE VMS))) (* ; "Ugh bletch, VMS defaults version to newest, have to explicitly ask for oldest") (push DESIREDPLIST (LIST (QUOTE VERSION) "-0")))) (for PROP in (QUOTE (DIRECTORY NAME-BODY VERSION)) do (push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY) PROP))) (CLEAR.LEAF.CACHE HOST) (* ; "In case Leaf has this file open for input") NEWCONNECTION (OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T T)) (RETURN)) (SETQ INS (fetch FTPIN of CONNECTION)) (SETQ OUTS (fetch FTPOUT of CONNECTION)) RETRY (FTPPUTMARK OUTS (MARK# DELETE)) (\FTP.PRINTPLIST OUTS DESIREDPLIST) (.EOC. OUTS) (SELECTC (FTPGETMARK INS) ((MARK# NO) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL NIL NIL T) (COND ((BSPOPENP INS (QUOTE INPUT)) (GO RETRY)) (T (GO NEWCONNECTION)))) (T (* ; "Note that Lisp's DELFILE prefers to return NIL to reporting errors") (\RELEASE.FTPCONNECTION CONNECTION) (RETURN NIL)))) ((MARK# HERE-IS-PLIST) NIL) ((MARK# BROKEN) (GO NEWCONNECTION)) (RETURN (\FTPERROR CONNECTION))) NEXTPLIST (SETQ REMOTEPLIST (READPLIST INS)) (OR (EQ (FTPGETMARK INS) (MARK# EOC)) (\FTPERROR CONNECTION)) (FTPPUTMARK OUTS (MARK# YES)) (FTPPUTCODE OUTS 0) (.EOC. OUTS) (SELECTC (FTPGETMARK INS) ((MARK# NO) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL NIL T T) (CLOSEBSPSTREAM INS 2000) (GO NEWCONNECTION)))) ((MARK# YES) (FTPGETCODE INS) (\FTP.FLUSH.TO.MARK INS) (push RESULT (\FTP.PACKFILENAME HOST REMOTEPLIST NIL (CADR (ASSOC (QUOTE DEVICE) DESIREDPLIST))))) (RETURN (\FTPERROR CONNECTION))) (* ;; "Got Yes/No on that file, see if there will be more. Usually there is just one file, but this code is prepared to do DELETE *.*....") (SELECTC (FTPGETMARK INS) ((MARK# HERE-IS-PLIST) (GO NEXTPLIST)) ((MARK# EOC) (\RELEASE.FTPCONNECTION CONNECTION) (RETURN (COND ((CDR RESULT) (REVERSE RESULT)) (T (CAR RESULT))))) (RETURN (\FTPERROR CONNECTION)))))) ) (\FTP.GENERATEFILES (LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 19-Aug-88 11:54 by bvm") (PROG ((RESULT (RESETLST (PROG (CONNECTION HOST REMOTENAME INS OUTS DESIREDPLIST CODE VERSION EXTENSION DEVICE WANTDEVICE NAME DIRECTORY NAMEBODY OSTYPE INFO FILTERNEEDED) (for TAIL on (UNPACKFILENAME.STRING PATTERN) by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST (SETQ HOST (\CANONICAL.HOSTNAME (MKATOM (CADR TAIL))))) (DIRECTORY (SETQ DIRECTORY (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXTENSION (OR (CADR TAIL) ""))) (VERSION (SETQ VERSION (AND (IGREATERP (NCHARS (CADR TAIL)) 0) (MKATOM (CADR TAIL))))) (DEVICE (SETQ WANTDEVICE (SETQ DEVICE (CADR TAIL)))) (RETURN))) (SETQ OSTYPE (GETHOSTINFO HOST (QUOTE OSTYPE))) (SELECTQ OSTYPE (TENEX (COND ((AND (STRPOS (QUOTE *) NAME) (IGREATERP (NCHARS NAME) 1)) (SETQ FILTERNEEDED (SETQ NAME (QUOTE *))))) (COND (EXTENSION (SELECTQ (NCHARS EXTENSION) (0 (* ; "Maxc enumerates `name.*' even when given just `name.'") (SETQ FILTERNEEDED T)) (1 (* ; "Extension * no problem")) (COND ((STRPOS (QUOTE *) EXTENSION) (SETQ FILTERNEEDED (SETQ EXTENSION (QUOTE *)))))))) (OR VERSION (COND ((EQ OSTYPE (QUOTE TENEX)) (SETQ VERSION 0))))) (TOPS20 (* ; "Can handle all *'s") (OR VERSION (SETQ VERSION 0)) (OR WANTDEVICE (SETQ WANTDEVICE T))) (VMS (* ; "Can handle all *'s")) ((NIL IFS UNIX) (COND (EXTENSION (SELECTQ (NCHARS EXTENSION) (1 (COND ((EQ (CHCON1 EXTENSION) (CHARCODE *)) (* ; "If enumerating FOO.* need to ask for FOO* or else we will miss extensionless FOO") (SETQ EXTENSION NIL) (COND ((NEQ (NTHCHARCODE NAME -1) (CHARCODE *)) (SETQ FILTERNEEDED (SETQ NAME (CONCAT NAME (QUOTE *))))))))) (0 (* ;; "Explicit null extension. IFS enumerates FOO. okay, but FOO*. would also enumerate files with non-null extensions") (SETQ EXTENSION NIL) (SETQ FILTERNEEDED (STRPOS (QUOTE *) NAME))) NIL))) (COND ((EQ OSTYPE (QUOTE UNIX)) (* ; "Coerce directory name to lowercase, get rid of trailing /") (COND ((EQ (NTHCHARCODE DIRECTORY -1) (CHARCODE /)) (SETQ DIRECTORY (SUBSTRING DIRECTORY 1 -2)))) (COND ((NEQ (NTHCHARCODE DIRECTORY 1) (CHARCODE /)) (SETQ DIRECTORY (CONCAT (QUOTE /) DIRECTORY)))) (COND ((U-CASEP DIRECTORY) (SETQ DIRECTORY (L-CASE DIRECTORY))))) (T (OR VERSION (SETQ VERSION (QUOTE H)))))) NIL) (SETQ DESIREDPLIST (for PROP in (NCONC (for PROP in DESIREDPROPS collect (\FTP.FROM.LISP.ATTRIBUTE PROP)) (QUOTE (DIRECTORY NAME-BODY VERSION))) collect (LIST (QUOTE DESIRED-PROPERTY) PROP))) (COND ((AND VERSION (OR (NEQ VERSION (QUOTE *)) (EQ OSTYPE (QUOTE VMS)))) (push DESIREDPLIST (LIST (QUOTE VERSION) VERSION)))) (SETQ NAMEBODY (COND ((NULL EXTENSION) NAME) (T (CONCAT NAME "." EXTENSION)))) (COND ((EQ OSTYPE (QUOTE UNIX)) (COND ((AND NIL (U-CASEP NAMEBODY)) (* ;; "Would like to help out by coercing name to lowercase, but the leaf server really does write uppercase filenames!") (SETQ NAMEBODY (L-CASE NAMEBODY)))) (COND ((NEQ (NTHCHARCODE NAMEBODY -1) (CHARCODE *)) (* ; "Unix FTP server does not understand versions, so make sure that whatever pattern we give ends in *") (SETQ FILTERNEEDED (SETQ NAMEBODY (CONCAT NAMEBODY (QUOTE *)))))))) (push DESIREDPLIST (LIST (QUOTE NAME-BODY) NAMEBODY)) (COND (DIRECTORY (push DESIREDPLIST (LIST (QUOTE DIRECTORY) DIRECTORY)))) (COND (WANTDEVICE (push DESIREDPLIST (LIST (QUOTE DESIRED-PROPERTY) (QUOTE DEVICE))) (COND (DEVICE (push DESIREDPLIST (LIST (QUOTE DEVICE) DEVICE)))))) (push DESIREDPLIST (LIST (QUOTE USER-NAME) (CAR (SETQ INFO (\INTERNAL/GETPASSWORD HOST)))) (LIST (QUOTE USER-PASSWORD) (CDR INFO))) NEWCONNECTION (OR (SETQ CONNECTION (\GETFTPCONNECTION HOST T T)) (GO NOFILES)) (SETQ INS (fetch FTPIN of CONNECTION)) (SETQ OUTS (fetch FTPOUT of CONNECTION)) RETRY (FTPPUTMARK OUTS (MARK# ENUMERATE)) (\FTP.PRINTPLIST OUTS DESIREDPLIST) (.EOC. OUTS) (SELECTC (FTPGETMARK INS) ((MARK# NO) (COND ((\FTP.HANDLE.NO CONNECTION DESIREDPLIST NIL CODE NIL T) (COND ((BSPOPENP INS (QUOTE INPUT)) (GO RETRY)) (T (GO NEWCONNECTION)))) (T (\RELEASE.FTPCONNECTION CONNECTION)))) ((MARK# HERE-IS-PLIST) (replace FTPBUSY of CONNECTION with (SETUPTIMER \FTP.IDLE.TIMEOUT)) (* ; "This guy gets a timer because the generator could be aborted out of our control. Blech") (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \FTP.NEXTFILE) FILEINFOFN _ (FUNCTION \FTP.FILEINFOFN) GENFILESTATE _ (create FTPFILEGENSTATE FTPGENCONNECTION _ CONNECTION FTPDEVICEWANTED _ WANTDEVICE FTPGENPLIST _ NIL FTPNAMEFILTER _ (AND FILTERNEEDED (DIRECTORY.MATCH.SETUP PATTERN)))))) ((MARK# BROKEN) (GO NEWCONNECTION)) (\FTPERROR CONNECTION)) NOFILES (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION NILL))))))) (COND ((AND RESULT (fetch GENFILESTATE of RESULT)) (* ; "Have a generator, so need to assure generator will terminate") (COND ((EQMEMB (QUOTE RESETLST) OPTIONS) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (CONNECTION) (AND RESETSTATE (CLOSEBSPSTREAM (fetch FTPIN of CONNECTION) 0)))) (fetch FTPGENCONNECTION of (fetch GENFILESTATE of RESULT))))) (T (\FTP.ASSURE.CLEANUP))))) (RETURN RESULT))) ) (\FTP.NEXTFILE (LAMBDA (GENSTATE NAMEONLY) (* bvm%: "13-Jul-84 16:44") (DECLARE (SPECVARS FTPCONNECTION)) (* ; "Seen by \FTP.CLEANUP") (PROG ((FTPCONNECTION (fetch FTPGENCONNECTION of GENSTATE)) (FILTER (fetch FTPNAMEFILTER of GENSTATE)) INS NAMEBODY NAME EXT N PLIST) (COND ((NULL FTPCONNECTION) (RETURN (ERROR "End of file Enumerator" GENSTATE))) ((NOT (SETQ INS (fetch FTPIN of FTPCONNECTION))) (GO BROKEN))) LP (SETUPTIMER \FTP.IDLE.TIMEOUT (fetch FTPBUSY of FTPCONNECTION)) (COND ((\EOFP INS) (* ;; "NEW-ENUMERATE sends plists one after another with no intervening HERE-IS-PLIST; check here for oldstyle, or for end of command") (SELECTC (FTPGETMARK INS) ((MARK# EOC) (\RELEASE.FTPCONNECTION FTPCONNECTION) (replace FTPGENCONNECTION of GENSTATE with NIL) (RETURN NIL)) ((MARK# HERE-IS-PLIST) (* ; "Old style")) ((MARK# BROKEN) (GO BROKEN)) (RETURN (\FTPERROR FTPCONNECTION))))) (COND ((AND (NULL (SETQ PLIST (READPLIST INS))) (NOT (BSPOPENP INS (QUOTE INPUT)))) (GO BROKEN))) (SETQ NAME (COND (NAMEONLY (OR (CADR (ASSOC (QUOTE NAME-BODY) PLIST)) "")) (T (\FTP.PACKFILENAME (fetch FTPHOST of FTPCONNECTION) PLIST T (fetch FTPDEVICEWANTED of GENSTATE))))) (COND ((AND FILTER (NOT (DIRECTORY.MATCH FILTER NAME))) (GO LP))) (replace FTPGENPLIST of GENSTATE with PLIST) (SETUPTIMER \FTP.IDLE.TIMEOUT (fetch FTPBUSY of FTPCONNECTION)) (RETURN (OR NAME (AND FTPDEBUGFLG (HELP "Uninterpretable filename returned by ENUMERATE" PLIST)))) BROKEN (ERROR "File server broke connection before directory enumeration finished. RETURN() to terminate enumeration." (fetch FTPHOST of FTPCONNECTION)) (RETURN NIL))) ) (\FTP.FILEINFOFN (LAMBDA (GENSTATE ATTRIBUTE) (* bvm%: "26-Apr-84 15:22") (\FTP.GETFILEINFO.FROM.PROPS (fetch FTPGENPLIST of GENSTATE) ATTRIBUTE)) ) (\FTP.GETFILEINFO (LAMBDA (STREAM ATTRIBUTE DEV) (* ; "Edited 19-Aug-88 11:54 by bvm") (\FTP.GETFILEINFO.FROM.PROPS (COND ((type? STREAM STREAM) (fetch FTPFILEPROPS of STREAM)) (T (\FTP.RECOGNIZEFILE STREAM DEV (QUOTE PROPS) (QUOTE OLD) (LIST (\FTP.FROM.LISP.ATTRIBUTE ATTRIBUTE))))) ATTRIBUTE)) ) (\FTP.GETFILEINFO.FROM.PROPS (LAMBDA (PROPS ATTRIBUTE) (* bvm%: " 5-May-84 16:31") (PROG (TMP) (RETURN (SELECTQ ATTRIBUTE (CREATIONDATE (CADR (ASSOC (QUOTE CREATION-DATE) PROPS))) (WRITEDATE (CADR (ASSOC (QUOTE WRITE-DATE) PROPS))) (READDATE (CADR (ASSOC (QUOTE READ-DATE) PROPS))) (ICREATIONDATE (IDATE (CADR (ASSOC (QUOTE CREATION-DATE) PROPS)))) (IWRITEDATE (IDATE (CADR (ASSOC (QUOTE WRITE-DATE) PROPS)))) (IREADDATE (IDATE (CADR (ASSOC (QUOTE READ-DATE) PROPS)))) (LENGTH (MKATOM (CADR (ASSOC (QUOTE SIZE) PROPS)))) (SIZE (AND (SETQ TMP (CADR (ASSOC (QUOTE SIZE) PROPS))) (FIXP (SETQ TMP (MKATOM TMP))) (FOLDHI TMP BYTESPERPAGE))) (TYPE (MKATOM (U-CASE (CADR (ASSOC ATTRIBUTE PROPS))))) (BYTESIZE (MKATOM (CADR (ASSOC (QUOTE BYTE-SIZE) PROPS)))) (CADR (ASSOC ATTRIBUTE PROPS)))))) ) (\FTP.FROM.LISP.ATTRIBUTE (LAMBDA (ATTR) (* ; "Edited 19-Aug-88 11:48 by bvm") (* ;; "Returns FTP name for the specified Lisp attribute, or the attribute itself if unknown.") (SELECTQ ATTR (BYTESIZE (QUOTE BYTE-SIZE)) (LENGTH (QUOTE SIZE)) ((CREATIONDATE ICREATIONDATE) (QUOTE CREATION-DATE)) ((WRITEDATE IWRITEDATE) (QUOTE WRITE-DATE)) ((READDATE IREADDATE) (QUOTE READ-DATE)) (EOLCONVENTION (QUOTE END-OF-LINE-CONVENTION)) ATTR)) ) ) (RPAQ? \FTPAVAILABLE ) (RPAQ? \FTP.IDLE.TIMEOUT 120000) (RPAQ? *FTP-IGNORE-SERVER-FULL* ) (* ;; "internal") (DEFINEQ (\FTP.OPEN.CONNECTION (LAMBDA (HOST ECHOSTREAM FAILURESTRING) (* bvm%: " 6-Oct-86 13:57") (LET ((PORT (BESTPUPADDRESS HOST PROMPTWINDOW)) INSTREAM) (if (AND PORT (SETQ INSTREAM (OPENBSPSTREAM (CONS (CAR PORT) (COND ((EQ (CDR PORT) 0) \PUPSOCKET.FTP) (T (CDR PORT)))) NIL (FUNCTION \FTP.ERRORHANDLER) NIL NIL (FUNCTION \FTP.WHENCLOSED) (OR FAILURESTRING "Can't open FTP connection")))) then (if (TYPENAMEP INSTREAM (QUOTE STREAM)) then (SETQ INSTREAM (create FTPCONNECTION FTPIN _ INSTREAM FTPOUT _ (BSPOUTPUTSTREAM INSTREAM) FTPHOST _ (\CANONICAL.HOSTNAME (COND ((LITATOM HOST) HOST) (T (ETHERHOSTNAME PORT)))) FTPBUSY _ T)) (if (\FTP.SENDVERSION INSTREAM ECHOSTREAM) then (push \FTPCONNECTIONS INSTREAM) INSTREAM else (CLOSEBSPSTREAM (fetch FTPIN of INSTREAM))) else INSTREAM)))) ) (FTP.BREAKCONNECTION (LAMBDA (HOST IDLEONLY) (* bvm%: "28-Apr-85 14:51") (LET (HOSTS) (for STREAM in (for CONN in \FTPCONNECTIONS collect (pushnew HOSTS (fetch FTPHOST of CONN)) (fetch FTPIN of CONN) when (AND (OR (EQ HOST T) (EQ HOST (fetch FTPHOST of CONN))) (OR (NULL IDLEONLY) (NULL (fetch FTPBUSY of CONN))))) do (CLOSEBSPSTREAM STREAM 5000)) HOSTS)) ) (\FTP.SENDVERSION (LAMBDA (CONNECTION ECHOSTREAM) (* ; "Edited 11-Jan-88 14:54 by bvm") (PROG ((INS (fetch FTPIN of CONNECTION)) (OUTS (fetch FTPOUT of CONNECTION))) (FTPPUTMARK OUTS (MARK# VERSION)) (BOUT OUTS \FTP.VERSION) (PRIN3 "Xerox Lisp Ftp user" OUTS) (.EOC. OUTS) (RETURN (SELECTC (FTPGETMARK INS) ((MARK# VERSION) (COND ((EQ (BIN INS) \FTP.VERSION) (\FTP.FLUSH.TO.EOC INS ECHOSTREAM)))) NIL)))) ) (\FTP.WHENCLOSED (LAMBDA (INSTREAM) (* bvm%: "15-SEP-83 23:06") (PROG ((CONN (find C in \FTPCONNECTIONS suchthat (EQ (fetch FTPIN of C) INSTREAM)))) (COND (CONN (SETQ \FTPCONNECTIONS (DREMOVE CONN \FTPCONNECTIONS)) (AND FTPDEBUGFLG (printout FTPDEBUGLOG T "{FTP Connection with " (fetch FTPHOST of CONN) " closed}" T)))))) ) (\GETFTPCONNECTION (LAMBDA (HOST UNWINDSAVE TRYHARD) (* ; "Edited 17-Nov-87 14:55 by bvm:") (PROG ((H (\CANONICAL.HOSTNAME (if (LITATOM HOST) then HOST else (ETHERHOSTNAME HOST)))) CONNECTION) (if *FTP-IGNORE-SERVER-FULL* then (SETQ TRYHARD T)) RETRY (RETURN (if (SETQ CONNECTION (OR (for CONN in \FTPCONNECTIONS when (AND (EQ (fetch FTPHOST of CONN) H) (NOT (fetch FTPBUSY of CONN)) (BSPOPENP (fetch FTPIN of CONN) (QUOTE OUTPUT))) do (replace FTPBUSY of CONN with T) (replace ACCESS of (fetch FTPIN of CONN) with (QUOTE INPUT)) (* ; "Because \CLOSEFILE clobbered this field") (replace ACCESS of (fetch FTPOUT of CONN) with (QUOTE OUTPUT)) (RETURN CONN)) (\FTP.OPEN.CONNECTION HOST (.FTPDEBUGLOG.) (AND TRYHARD (QUOTE RETURN))))) then (if (type? FTPCONNECTION CONNECTION) then (if UNWINDSAVE then (RESETSAVE (PROGN (fetch FTPIN of CONNECTION)) (QUOTE (AND RESETSTATE (CLOSEBSPSTREAM OLDVALUE 0))))) CONNECTION elseif (AND TRYHARD (STRINGP CONNECTION)) then (* ; "Didn't get connection, but got error return of some sort (normal prompt message was suppressed).") (if (STRPOS "FULL" CONNECTION NIL NIL NIL NIL UPPERCASEARRAY) then (* ; "Got %"server full%" abort, try again later") (BLOCK 5000) (GO RETRY) else (* ; "Some other problem--print in prompt window before giving up.") (CL:FORMAT PROMPTWINDOW "~%%Couldn't get FTP connection to ~A because: ~A" H CONNECTION) NIL)))))) ) (\RELEASE.FTPCONNECTION (LAMBDA (CONN) (* bvm%: "18-MAY-83 10:53") (replace FTPBUSY of CONN with NIL))) (\FTP.ERRORHANDLER (LAMBDA (INSTREAM ERRCODE) (* ; "Edited 26-Nov-86 15:39 by bvm:") (PROG (OUTSTREAM TMP) (RETURN (SELECTQ ERRCODE (MARK.ENCOUNTERED (COND ((fetch FTPOPENP of INSTREAM) (* ; "If reading a file, this is EOF") (STREAMOP (QUOTE ENDOFSTREAMOP) INSTREAM INSTREAM)) (T -1))) (BAD.STATE.FOR.BOUT (COND ((AND (SETQ OUTSTREAM (BSPOUTPUTSTREAM INSTREAM)) (fetch FTPOPENP of OUTSTREAM)) (* ; "Writing a file, and partner timed out. Hard to recover from this") (ERROR "File server has broken connection" (fetch FULLFILENAME of OUTSTREAM))) (T (* ; "Just protocol stuff. Let it go by, and catch the error on the next input") NIL))) (BAD.STATE.FOR.BIN (COND ((fetch FTPOPENP of INSTREAM) (* ; "Could recover by reopening file") (\FTP.FIX.BROKEN.INPUT INSTREAM)) ((SETQ TMP (STKPOS (QUOTE READPLIST))) (* ; "Reading a plist, can't just barf in the middle") (RETFROM TMP NIL T)) (T (* ; "Act like end of file") -1))) (BAD.GETMARK (COND ((BSPOPENP INSTREAM (QUOTE INPUT)) (MARK# NOTAMARK)) (T (MARK# BROKEN)))) (ERROR ERRCODE (AND INSTREAM (OR (fetch FULLFILENAME of INSTREAM) (AND (SETQ OUTSTREAM (BSPOUTPUTSTREAM INSTREAM)) (fetch FULLFILENAME of OUTSTREAM)) (AND (SETQ OUTSTREAM (BSPFRNADDRESS INSTREAM)) (ETHERHOSTNAME OUTSTREAM T))))))))) ) (\FTP.FIX.BROKEN.INPUT (LAMBDA (INSTREAM) (* bvm%: "28-Apr-85 14:15") (* ;; "Called when remote server breaks connection in midstream. Try to reopen and set fileptr to the right place") (PROG ((FULLNAME (fetch FULLFILENAME of INSTREAM)) (PROPS (fetch FTPFILEPROPS of INSTREAM)) (POS (GETFILEPTR INSTREAM)) NEWSTREAM) (printout PROMPTWINDOW T "File server broke connection while reading " FULLNAME " at byte " |.P2| POS (QUOTE |...|)) (COND ((SETQ NEWSTREAM (\FTP.OPENFILE.FROM.PLIST (FILENAMEFIELD FULLNAME (QUOTE HOST)) (\FTP.ADD.USERINFO (for PAIR in PROPS collect PAIR when (FMEMB (CAR PAIR) (QUOTE (NAME-BODY VERSION DIRECTORY DEVICE SERVER-FILENAME))))) (QUOTE INPUT))) (\SMASHBSPSTREAM NEWSTREAM INSTREAM) (* ; "Smash new stream into old, so we are now using INSTREAM again") (for CONN in \FTPCONNECTIONS when (EQ (fetch FTPIN of CONN) NEWSTREAM) do (replace FTPIN of CONN with INSTREAM) (replace FTPOUT of CONN with (BSPOUTPUTSTREAM INSTREAM)) (RETURN)) (\BSP.DECLARE.FILEPTR INSTREAM 0) (printout PROMPTWINDOW T "Reopening file and restoring fileptr...") (SETFILEPTR INSTREAM POS) (printout PROMPTWINDOW "done.") (RETURN T)) (T (ERROR "File server broke connection; unable to reestablish" FULLNAME))))) ) (\FTP.CLEANUP (LAMBDA NIL (* bvm%: "19-AUG-83 16:19") (* ;; "Process that sits watching to see if an FTP connection has been idle too long") (DECLARE (SPECVARS CONNS FAIL)) (PROG ((TIMER (SETUPTIMER 0)) (INTERVAL (LRSH \FTP.IDLE.TIMEOUT 1)) CONNS) SLEEP (SETUPTIMER INTERVAL TIMER) (do (BLOCK NIL TIMER) until (TIMEREXPIRED? TIMER)) LP1 (COND ((NULL (SETQ CONNS \FTPCONNECTIONS)) (RETURN))) LP2 (COND ((AND (FIXP (fetch FTPBUSY of (CAR CONNS))) (TIMEREXPIRED? (fetch FTPBUSY of (CAR CONNS))) (NOT (PROG (FAIL) (MAP.PROCESSES (FUNCTION (LAMBDA (PROC) (COND ((EQ (PROCESS.EVALV PROC (QUOTE FTPCONNECTION)) (CAR CONNS)) (SETQ FAIL T)))))) (RETURN FAIL)))) (* ;; "Timer expired AND there is nobody actively using this connection. Latter is important in case the remote server was just slow to answer. Ideal solution would be to see if anyone has a pointer to the generator, but that takes gc changes") (CLOSEBSPSTREAM (fetch FTPIN of (CAR CONNS))) (GO LP1))) (COND ((SETQ CONNS (CDR CONNS)) (GO LP2))) (GO SLEEP))) ) (\FTP.ASSURE.CLEANUP (LAMBDA NIL (* bvm%: "19-AUG-83 16:12") (OR (FIND.PROCESS (QUOTE \FTP.CLEANUP)) (ADD.PROCESS (QUOTE (\FTP.CLEANUP)) (QUOTE RESTARTABLE) (QUOTE NO)))) ) ) (ADDTOVAR \FTPCONNECTIONS ) (DEFINEQ (\FTP.HANDLE.NO (LAMBDA (CONNECTION BADPLIST ECHOSTREAM CODE LEAVEMARK NOERRORFLG DESTPLIST) (* ; "Edited 17-Nov-87 18:17 by bvm:") (PROG ((INSTREAM (fetch FTPIN of CONNECTION)) (HOST (fetch FTPHOST of CONNECTION)) (FLUSHER (COND (LEAVEMARK (FUNCTION \FTP.FLUSH.TO.MARK)) (T (FUNCTION \FTP.FLUSH.TO.EOC)))) INFO CPASS CNAME NEWNAME) (SELECTC (OR CODE (SETQ CODE (FTPGETCODE INSTREAM T))) (\NO.FILE.NOT.FOUND (APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.))) (RETURN)) ((LIST \NO.BAD.TRANSFER.PARMS \NO.BAD.EOLCONVENTION) (COND ((AND (SETQ INFO (ASSOC (QUOTE END-OF-LINE-CONVENTION) BADPLIST)) (NEQ (CADR INFO) (QUOTE CR))) (RPLACA (CDR INFO) (QUOTE CR)) (* ; "Fall back on EOL = CR, which everyone must support") (APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.))) (RETURN T)))) (\NO.FILE.PROTECTED (* ;; "We are very dependent on precedence of errors. The code here assumes that if I specified CONNECT-NAME and still got a protection error, then there is nothing I can do--had the name been illegal or it required a password, I would have gotten a connect name/pass error instead. This is especially a problem for the RENAME command, since the error return gives no indication as to whether it is the source or the destination that has the problem. We solve it here by making the source good first, then if we still get errors, the problem must be in the destination.") (if (COND ((NULL (SETQ CNAME (ASSOC (QUOTE CONNECT-NAME) BADPLIST))) (* ; "First time thru--try adding connect name for the main file.") (NCONC1 BADPLIST (LIST (QUOTE CONNECT-NAME) (\FTP.DIRECTORYNAMEONLY (CADR (ASSOC (QUOTE DIRECTORY) BADPLIST))))) T) ((AND DESTPLIST (NOT (STRING-EQUAL (CADR CNAME) (SETQ NEWNAME (\FTP.DIRECTORYNAMEONLY (CADR (ASSOC (QUOTE DIRECTORY) DESTPLIST))))))) (* ; "Destination directory is different than source--maybe that's the problem. Oddly enough, IFS doesn't let us give separate connect passwords for the source and destination, so have to do it all in main plist.") (RPLACA (CDR CNAME) NEWNAME) (if (SETQ CPASS (ASSOC (QUOTE CONNECT-PASSWORD) BADPLIST)) then (RPLACA (CDR CPASS) "")) T)) then (* ; "Flush the error message, try again") (APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.))) (RETURN T))) (\NO.ILLEGAL.CONNECTPASSWORD (* ; "Connect Password error") (SETQ CNAME (MKATOM (CADR (ASSOC (QUOTE CONNECT-NAME) BADPLIST)))) (if (AND (NULL (SETQ CPASS (ASSOC (QUOTE CONNECT-PASSWORD) BADPLIST))) (SETQ INFO (\INTERNAL/GETPASSWORD HOST NIL CNAME))) then (* ; "quietly get a connect password and try again. Thus usually gets us the null password unless a real one has been previously cached.") (NCONC1 BADPLIST (LIST (QUOTE CONNECT-PASSWORD) (CDR INFO))) (APPLY* FLUSHER INSTREAM (OR ECHOSTREAM (.FTPDEBUGLOG.))) (RETURN T) else (* ; "Fall thru to process the noisy way"))) NIL) GENERAL.FAILURE (printout (OR ECHOSTREAM (SETQ ECHOSTREAM (GETSTREAM PROMPTWINDOW (QUOTE OUTPUT)))) T HOST ": ") (COND ((APPLY* FLUSHER INSTREAM ECHOSTREAM) (SELECTC CODE ((LIST \NO.ILLEGAL.USERNAME \NO.ILLEGAL.USERPASSWORD) (* ; "User Password errors") (RETURN (COND ((SETQ INFO (\INTERNAL/GETPASSWORD HOST T NIL NIL)) (for PAIR in BADPLIST do (SELECTQ (CAR PAIR) (USER-NAME (FRPLACA (CDR PAIR) (CAR INFO))) (USER-PASSWORD (FRPLACA (CDR PAIR) (CDR INFO))) NIL)) T)))) (\NO.ILLEGAL.CONNECTPASSWORD (* ; "Connect Password error") (RETURN (COND ((SETQ INFO (\INTERNAL/GETPASSWORD HOST T CNAME NIL)) (COND (CPASS (FRPLACA (CDR CPASS) (CDR INFO))) (T (NCONC1 BADPLIST (LIST (QUOTE CONNECT-PASSWORD) (CDR INFO))))) T) ((AND (NOT NOERRORFLG) (LISPERROR "PROTECTION VIOLATION" (\FTP.PACKFILENAME HOST (if (OR (NULL DESTPLIST) (STRING-EQUAL CNAME (\FTP.DIRECTORYNAMEONLY (CADR (ASSOC (QUOTE DIRECTORY) BADPLIST))))) then BADPLIST else (* ; "Problem is probably with the destination") DESTPLIST) NIL T))))))) (\NO.ILLEGAL.NAME.ERRORS (OR NOERRORFLG (LISPERROR "BAD FILE NAME" (\FTP.PACKFILENAME HOST BADPLIST NIL T)))) (\NO.STORAGE.FULL (OR NOERRORFLG (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" (\FTP.PACKFILENAME HOST BADPLIST NIL T)))) (\NO.FILE.PROTECTED (OR NOERRORFLG (LISPERROR "PROTECTION VIOLATION" (\FTP.PACKFILENAME HOST BADPLIST NIL T)))) (GO WONT.OPEN))) (T (\FTPERROR CONNECTION))) (RETURN) WONT.OPEN (OR NOERRORFLG (LISPERROR "FILE WON'T OPEN" (\FTP.PACKFILENAME HOST BADPLIST NIL T))))) ) (\FTP.DIRECTORYNAMEONLY (LAMBDA (DIRNAME) (* ; "Edited 16-Nov-87 16:09 by bvm") (LET ((N (STRPOS (QUOTE >) DIRNAME))) (COND (N (SUBSTRING DIRNAME 1 (- N 1))) (T DIRNAME)))) ) (\FTP.EOL.FROM.PLIST (LAMBDA (PLIST) (* bvm%: "21-NOV-83 15:33") (for PAIR in PLIST when (EQ (CAR PAIR) (QUOTE END-OF-LINE-CONVENTION)) do (RETURN (SELECTQ (CADR PAIR) (LF LF.EOLC) (CRLF CRLF.EOLC) CR.EOLC)) finally (RETURN CR.EOLC))) ) (\FTP.MAKEPLIST (LAMBDA (FILENAME HOST DESIREDPROPS) (* bvm%: " 4-JUN-83 21:35") (PROG ((INFO (\INTERNAL/GETPASSWORD HOST))) (RETURN (CONS (LIST (QUOTE USER-NAME) (CAR INFO)) (CONS (LIST (QUOTE USER-PASSWORD) (CDR INFO)) (CONS (LIST (QUOTE SERVER-FILENAME) FILENAME) (for PROP inside DESIREDPROPS collect (LIST (QUOTE DESIRED-PROPERTY) PROP)))))))) ) (\FTP.PRINTPLIST (LAMBDA (STREAM PLIST) (* ; "Edited 11-Jan-88 16:09 by bvm") (BOUT STREAM (CHARCODE %()) (for PAIR in PLIST do (for ITEM in PAIR bind (BEFORE _ (CHARCODE %()) ISPASSWORD do (BOUT STREAM BEFORE) (SETQ BEFORE (CHARCODE SPACE)) (for CH inpname ITEM do (SELCHARQ (COND (ISPASSWORD (SETQ CH (\DECRYPT.PWD.CHAR CH))) (T CH)) ((%( %)) (BOUT STREAM (CHARCODE %'))) NIL) (BOUT STREAM (COND ((ILEQ CH \MAXTHINCHAR) CH) (T (* ; "Illegal, try something hopeless") (CHARCODE %#^A))))) (SELECTQ ITEM ((USER-PASSWORD CONNECT-PASSWORD) (SETQ ISPASSWORD T)) NIL)) (BOUT STREAM (CHARCODE %)))) (BOUT STREAM (CHARCODE %))) (COND (FTPDEBUGFLG (PRIN2 PLIST FTPDEBUGLOG))) STREAM) ) (\FTP.PACKFILENAME (LAMBDA (HOST PLIST PRESERVECASE DEVICEWANTED) (* ; "Edited 11-Jan-88 16:54 by bvm") (PROG (NAMEBODY VERSION SERVERNAME DEVICE DIR FIELDS NAME I) (for PAIR in PLIST do (SELECTQ (CAR PAIR) (DIRECTORY (COND ((SETQ DIR (CADR PAIR)) (SELCHARQ (CHCON1 DIR) (%[ (COND ((EQ (NTHCHARCODE DIR -1) (CHARCODE %])) (* ; "patch around buggy VMS server") (SETQ DIR (SUBSTRING DIR 2 -2))))) (/ (* ; "UNIX returns a /, although Interlisp always uses complete directory names") (SETQ DIR (SUBSTRING DIR 2 -1))) NIL)))) (DEVICE (COND (DEVICEWANTED (SETQ DEVICE (CADR PAIR))))) (NAME-BODY (SETQ NAMEBODY (CADR PAIR))) (VERSION (SETQ VERSION (CADR PAIR))) (SERVER-FILENAME (SETQ SERVERNAME (CADR PAIR))) NIL)) (SETQ NAME (COND (NAMEBODY (* ; "Pack up the name right to left") (SETQ NAMEBODY (\FTP.ADD.QUOTES NAMEBODY)) (COND (VERSION (* ; "Note that some Unix servers won't give a version") (SETQ FIELDS (LIST (QUOTE ;) VERSION)) (COND ((NOT (SETQ I (STRPOS (QUOTE %.) NAMEBODY))) (* ; "Extensionless file looks like FOO.;3, but leave versionless files alone. This includes the output of broken unix servers that think %"FOO;3%" is a NAME-BODY") (push FIELDS (QUOTE %.))) ((AND (EQ I (NCHARS NAMEBODY)) (EQ (GETHOSTINFO HOST (QUOTE OSTYPE)) (QUOTE IFS))) (* ; "IFS file with a dot at the end needs to be quoted, or else the dot will get swallowed.") (SETQ NAMEBODY (CONCAT (SUBSTRING NAMEBODY 1 (SUB1 I)) "'.")))))) (push FIELDS NAMEBODY) (COND (DIR (push FIELDS (QUOTE <) (\FTP.ADD.QUOTES DIR) (QUOTE >)))) (COND (DEVICE (COND ((AND (NEQ DEVICEWANTED T) (NOT (STREQUAL DEVICE DEVICEWANTED)) SERVERNAME (SETQ I (STRPOS ":" SERVERNAME))) (* ; "Ugh, VMS puts a different device in the DEVICE field than in SERVER-FILENAME field") (SETQ DEVICE (SUBSTRING SERVERNAME 1 (SUB1 I))))) (if (NEQ (NTHCHARCODE DEVICE -1) (CHARCODE ":")) then (push FIELDS (QUOTE %:))) (push FIELDS (\FTP.ADD.QUOTES DEVICE))))) (SERVERNAME (SETQ FIELDS (LIST SERVERNAME))) (T (RETURN)))) (push FIELDS (QUOTE {) HOST (QUOTE })) (SETQ NAME (CONCATLIST FIELDS)) (RETURN (COND ((OR PRESERVECASE (NOT *UPPER-CASE-FILE-NAMES*)) (* ; "Give me the name straight.") NAME) (T (MKATOM (U-CASE NAME))))))) ) (\FTP.ADD.QUOTES (LAMBDA (NAME) (* ; "Edited 11-Jan-88 16:52 by bvm") (* ;; "The only funny char we know about is quote, so quote all the quotes with a quote.") (bind (N _ 1) I PIECES while (SETQ I (STRPOS "'" NAME N)) do (push PIECES "'" (SUBSTRING NAME N I)) (SETQ N (ADD1 I)) finally (RETURN (if PIECES then (if (<= N (NCHARS NAME)) then (push PIECES (SUBSTRING NAME N))) (CONCATLIST (DREVERSE PIECES)) else (* ; "nothing got quoted") NAME)))) ) (\FTP.PACK.DIRECTORYNAMEP (LAMBDA (CONNECTION PLIST) (* lmm "25-Mar-85 14:38") (PROG ((DIRECTORY (CADR (ASSOC (QUOTE DIRECTORY) PLIST))) (DEVICE (CADR (ASSOC (QUOTE DEVICE) PLIST)))) (RETURN (PACKFILENAME.STRING (QUOTE HOST) (fetch FTPHOST of CONNECTION) (QUOTE DEVICE) DEVICE (QUOTE DIRECTORY) DIRECTORY)))) ) (\FTP.UNPACKFILENAME (LAMBDA (FILENAME NOLOGIN) (* ; "Edited 16-Nov-87 17:43 by bvm") (LET ((FIELDS (UNPACKFILENAME.STRING FILENAME)) PLIST HOST DEVICE DIR NAME EXT INFO) (for TAIL on FIELDS by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST (SETQ HOST (CADR TAIL))) (DIRECTORY (SETQ DIR (CADR TAIL))) (DEVICE (SETQ DEVICE (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (push PLIST (LIST (QUOTE VERSION) (CADR TAIL)))) NIL)) (COND ((AND HOST (SETQ HOST (\CANONICAL.HOSTNAME HOST))) (push PLIST (LIST (QUOTE NAME-BODY) (COND ((AND EXT (> (NCHARS EXT) 0)) (CONCAT NAME (QUOTE %.) EXT)) (T NAME)))) (COND (DIR (COND ((EQ (GETHOSTINFO HOST (QUOTE OSTYPE)) (QUOTE UNIX)) (* ; "Coerce directory name to lowercase, get rid of trailing /") (COND ((EQ (NTHCHARCODE DIR -1) (CHARCODE /)) (SETQ DIR (SUBSTRING DIR 1 -2)))) (COND ((NEQ (NTHCHARCODE DIR 1) (CHARCODE /)) (SETQ DIR (CONCAT (QUOTE /) DIR)))) (COND ((U-CASEP DIR) (SETQ DIR (L-CASE DIR)))))) (push PLIST (LIST (QUOTE DIRECTORY) DIR)))) (COND (DEVICE (push PLIST (LIST (QUOTE DEVICE) DEVICE)))) (CONS HOST (if NOLOGIN then PLIST else (\FTP.ADD.USERINFO PLIST HOST))))))) ) (\FTP.ADD.USERINFO (LAMBDA (PLIST HOST) (* bvm%: "27-OCT-83 15:50") (PROG ((INFO (\INTERNAL/GETPASSWORD HOST))) (push PLIST (LIST (QUOTE USER-NAME) (CAR INFO)) (LIST (QUOTE USER-PASSWORD) (CDR INFO))) (RETURN PLIST))) ) (\FTP.FLUSH.TO.EOC (LAMBDA (INSTREAM ECHOSTREAM) (* bvm%: "13-JUN-83 15:36") (* ;; "Eat bytes from the input side of CONNECTION up to next mark, copying bytes to ECHOSTREAM if given, and return T if the mark is EOC") (PROG ((STREAM (AND ECHOSTREAM (GETSTREAM ECHOSTREAM (QUOTE OUTPUT)))) CH) (while (NEQ (SETQ CH (BIN INSTREAM)) -1) do (AND STREAM (\OUTCHAR STREAM CH))) (RETURN (EQ (FTPGETMARK INSTREAM) (MARK# EOC))))) ) (\FTP.FLUSH.TO.MARK (LAMBDA (INSTREAM ECHOSTREAM) (* bvm%: " 7-JUL-83 12:08") (bind CH (STREAM _ (AND ECHOSTREAM (GETSTREAM ECHOSTREAM (QUOTE OUTPUT)))) while (NEQ (SETQ CH (BIN INSTREAM)) -1) do (AND STREAM (\OUTCHAR STREAM CH))) T) ) (\FTPERROR (LAMBDA (CONNECTION ERRMSG ERRARG) (* bvm%: "11-Jul-84 15:33") (COND (FTPDEBUGFLG (printout FTPDEBUGLOG T "{FTP Protocol violation, aborted}" T) (HELP))) (CLOSEBSPSTREAM (COND ((type? STREAM CONNECTION) CONNECTION) (T (fetch FTPIN of CONNECTION))) 1000) (COND (ERRMSG (ERROR (COND ((EQ ERRMSG T) "FTP Protocol violation") (T ERRMSG)) ERRARG)))) ) ) (* ;; "for debugging") (DEFINEQ (FTPDEBUG (LAMBDA (FLG REGION) (* ; "Edited 16-Nov-87 16:13 by bvm") (SETQ FTPDEBUGLOG (CREATEW REGION "FTP Debug info")) (WINDOWPROP FTPDEBUGLOG (QUOTE CLOSEFN) (FUNCTION (LAMBDA (WINDOW) (AND (EQ (WINDOWPROP WINDOW (QUOTE DSP)) FTPDEBUGLOG) (SETQ FTPDEBUGLOG (SETQ FTPDEBUGFLG NIL)))))) (WINDOWPROP FTPDEBUGLOG (QUOTE SHRINKFN) (FUNCTION (LAMBDA (WINDOW) (* ;; "Suspend tracing while window shrunk") (AND (EQ (WINDOWPROP WINDOW (QUOTE DSP)) FTPDEBUGLOG) (SETQ FTPDEBUGFLG NIL))))) (WINDOWPROP FTPDEBUGLOG (QUOTE EXPANDFN) (FUNCTION (LAMBDA (WINDOW) (* ;; "Turn back on when expanded") (AND (EQ (WINDOWPROP WINDOW (QUOTE DSP)) FTPDEBUGLOG) (SETQ FTPDEBUGFLG T))))) (SETQ FTPDEBUGLOG (WINDOWPROP FTPDEBUGLOG (QUOTE DSP))) (DSPFONT (FONTCREATE (QUOTE GACHA) 8) FTPDEBUGLOG) (DSPSCROLL T FTPDEBUGLOG) (SETQ FTPDEBUGFLG T)) ) (FTPPRINTMARK (LAMBDA (MARK) (* bvm%: "25-Aug-84 21:58") (COND (FTPDEBUGFLG (printout FTPDEBUGLOG "[" (OR (CADR (FASSOC MARK (LISTP FTPMARKTYPES))) MARK) "]") (COND ((EQ MARK (MARK# EOC)) (TERPRI FTPDEBUGLOG))))) MARK) ) (FTPPRINTCODE (LAMBDA (CODE NOCODEP) (* bvm%: "20-AUG-83 00:12") (COND (FTPDEBUGFLG (PRIN1 (QUOTE {) FTPDEBUGLOG) (COND (NOCODEP (PRINTCONSTANT CODE FTPNOCODES FTPDEBUGLOG "\NO.")) (T (PRINTNUM (QUOTE (FIX 1)) CODE FTPDEBUGLOG))) (PRIN1 (QUOTE }) FTPDEBUGLOG))) CODE) ) (FTPGETMARK (LAMBDA (STREAM) (* bvm%: "23-Nov-86 15:50") (bind MARK while (EQ (SETQ MARK (FTPPRINTMARK (BSPGETMARK STREAM))) (MARK# COMMENT)) do (\FTP.FLUSH.TO.MARK STREAM (.FTPDEBUGLOG.)) finally (RETURN MARK))) ) (FTPPUTMARK (LAMBDA (STREAM MARK) (* bvm%: "12-MAY-83 10:24") (BSPPUTMARK STREAM (FTPPRINTMARK MARK)))) (FTPPUTCODE (LAMBDA (STREAM CODE NOCODEP) (* bvm%: "20-AUG-83 00:12") (BOUT STREAM (FTPPRINTCODE CODE NOCODEP)))) (FTPGETCODE (LAMBDA (STREAM NOCODEP) (* bvm%: "20-AUG-83 00:17") (FTPPRINTCODE (BIN STREAM) NOCODEP))) ) (RPAQ? FTPDEBUGLOG ) (RPAQ? FTPDEBUGFLG ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ FTPMARKTYPES ((1 RETRIEVE) (2 STORE) (3 YES) (4 NO) (5 HERE-IS-FILE) (6 EOC) (7 COMMENT) (8 VERSION) (9 NEW-STORE) (10 ENUMERATE) (11 HERE-IS-PLIST) (12 NEW-ENUMERATE) (14 DELETE) (15 RENAME) (16 STORE-MAIL) (17 RETRIEVE-MAIL) (18 FLUSH-MAILBOX) (19 MAILBOX-EXCEPTION) (253 NOTAMARK) (254 BROKEN))) (DECLARE%: EVAL@COMPILE (RPAQQ \FTP.VERSION 1) (CONSTANTS \FTP.VERSION) ) (RPAQQ FTPNOCODES ((\NO.UNIMPLEMENTED 1) (\NO.PROTOCOL.ERROR 3) (\NO.BAD.PLIST 8) (\NO.ILLEGAL.DIRECTORY 10) (\NO.ILLEGAL.NAME.ERRORS '(9 10 11 12 25)) (\NO.BAD.EOLCONVENTION 15) (\NO.ILLEGAL.USERNAME 16) (\NO.ILLEGAL.USERPASSWORD 17) (\NO.ILLEGAL.CONNECTNAME 19) (\NO.ILLEGAL.CONNECTPASSWORD 20) (\NO.FILE.NOT.FOUND 64) (\NO.FILE.PROTECTED 65) (\NO.BAD.TRANSFER.PARMS 66) (\NO.DISK.ERROR 67) (\NO.STORAGE.FULL 68) (\NO.UNSPECIFIED.ERRORS '(71 72)) (\NO.FILE.BUSY 73) (\NO.RENAME.DESTINATION.EXISTS 74))) (DECLARE%: EVAL@COMPILE (RPAQQ \NO.UNIMPLEMENTED 1) (RPAQQ \NO.PROTOCOL.ERROR 3) (RPAQQ \NO.BAD.PLIST 8) (RPAQQ \NO.ILLEGAL.DIRECTORY 10) (RPAQQ \NO.ILLEGAL.NAME.ERRORS (9 10 11 12 25)) (RPAQQ \NO.BAD.EOLCONVENTION 15) (RPAQQ \NO.ILLEGAL.USERNAME 16) (RPAQQ \NO.ILLEGAL.USERPASSWORD 17) (RPAQQ \NO.ILLEGAL.CONNECTNAME 19) (RPAQQ \NO.ILLEGAL.CONNECTPASSWORD 20) (RPAQQ \NO.FILE.NOT.FOUND 64) (RPAQQ \NO.FILE.PROTECTED 65) (RPAQQ \NO.BAD.TRANSFER.PARMS 66) (RPAQQ \NO.DISK.ERROR 67) (RPAQQ \NO.STORAGE.FULL 68) (RPAQQ \NO.UNSPECIFIED.ERRORS (71 72)) (RPAQQ \NO.FILE.BUSY 73) (RPAQQ \NO.RENAME.DESTINATION.EXISTS 74) (CONSTANTS (\NO.UNIMPLEMENTED 1) (\NO.PROTOCOL.ERROR 3) (\NO.BAD.PLIST 8) (\NO.ILLEGAL.DIRECTORY 10) (\NO.ILLEGAL.NAME.ERRORS '(9 10 11 12 25)) (\NO.BAD.EOLCONVENTION 15) (\NO.ILLEGAL.USERNAME 16) (\NO.ILLEGAL.USERPASSWORD 17) (\NO.ILLEGAL.CONNECTNAME 19) (\NO.ILLEGAL.CONNECTPASSWORD 20) (\NO.FILE.NOT.FOUND 64) (\NO.FILE.PROTECTED 65) (\NO.BAD.TRANSFER.PARMS 66) (\NO.DISK.ERROR 67) (\NO.STORAGE.FULL 68) (\NO.UNSPECIFIED.ERRORS '(71 72)) (\NO.FILE.BUSY 73) (\NO.RENAME.DESTINATION.EXISTS 74)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS MARK# MACRO [X (OR [CAR (find M in FTPMARKTYPES suchthat (EQ (CADR M) (CAR X] (HELP "Unknown mark type" (CAR X]) (PUTPROPS .EOC. MACRO ((STREAM) (FTPPUTMARK STREAM (MARK# EOC)))) (PUTPROPS .FTPDEBUGLOG. MACRO (NIL (AND FTPDEBUGFLG FTPDEBUGLOG))) ) (PUTPROPS MARK# INFO NOEVAL) (DECLARE%: EVAL@COMPILE (RECORD FTPCONNECTION (FTPIN FTPOUT FTPHOST FTPBUSY FTPCURRENTFILE) (TYPE? LISTP)) (ACCESSFNS FTPSTREAM ((FTPFILEPROPS (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE))) (SYNONYM FTPFILEPROPS (FTPOPENP))) (RECORD FTPFILEGENSTATE (FTPGENCONNECTION FTPGENPLIST FTPDEVICEWANTED FTPNAMEFILTER)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FTPDEBUGFLG \FTPCONNECTIONS \FTPAVAILABLE \FTP.IDLE.TIMEOUT \BSPFDEV \FTPFDEV) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\FTPINIT) ) (PUTPROPS DPUPFTP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2518 25872 (\FTPINIT 2528 . 3374) (\FTPEVENTFN 3376 . 3596) (\FTP.OPENFILE 3598 . 5084) (\FTP.REOPENFILE 5086 . 5602) (\FTP.OPENFILE.FROM.PLIST 5604 . 7720) (\FTP.GETFILENAME 7722 . 8003) ( \FTP.RECOGNIZEFILE 8005 . 11025) (\FTP.DIRECTORYNAMEP 11027 . 11162) (\FTP.CLOSEFILE 11164 . 12961) ( \FTP.REGISTER 12963 . 13123) (\FTP.UNREGISTER 13125 . 13358) (\FTP.RENAMEFILE 13360 . 15205) ( \FTP.DELETEFILE 15207 . 17569) (\FTP.GENERATEFILES 17571 . 22571) (\FTP.NEXTFILE 22573 . 24181) ( \FTP.FILEINFOFN 24183 . 24335) (\FTP.GETFILEINFO 24337 . 24638) (\FTP.GETFILEINFO.FROM.PROPS 24640 . 25431) (\FTP.FROM.LISP.ATTRIBUTE 25433 . 25870)) (26004 33071 (\FTP.OPEN.CONNECTION 26014 . 26800) ( FTP.BREAKCONNECTION 26802 . 27163) (\FTP.SENDVERSION 27165 . 27575) (\FTP.WHENCLOSED 27577 . 27905) ( \GETFTPCONNECTION 27907 . 29290) (\RELEASE.FTPCONNECTION 29292 . 29399) (\FTP.ERRORHANDLER 29401 . 30652) (\FTP.FIX.BROKEN.INPUT 30654 . 31871) (\FTP.CLEANUP 31873 . 32891) (\FTP.ASSURE.CLEANUP 32893 . 33069)) (33105 44252 (\FTP.HANDLE.NO 33115 . 37426) (\FTP.DIRECTORYNAMEONLY 37428 . 37606) ( \FTP.EOL.FROM.PLIST 37608 . 37848) (\FTP.MAKEPLIST 37850 . 38204) (\FTP.PRINTPLIST 38206 . 38887) ( \FTP.PACKFILENAME 38889 . 41060) (\FTP.ADD.QUOTES 41062 . 41514) (\FTP.PACK.DIRECTORYNAMEP 41516 . 41830) (\FTP.UNPACKFILENAME 41832 . 42993) (\FTP.ADD.USERINFO 42995 . 43218) (\FTP.FLUSH.TO.EOC 43220 . 43646) (\FTP.FLUSH.TO.MARK 43648 . 43887) (\FTPERROR 43889 . 44250)) (44284 46179 (FTPDEBUG 44294 . 45120) (FTPPRINTMARK 45122 . 45346) (FTPPRINTCODE 45348 . 45621) (FTPGETMARK 45623 . 45841) ( FTPPUTMARK 45843 . 45950) (FTPPUTCODE 45952 . 46069) (FTPGETCODE 46071 . 46177))))) STOP \ No newline at end of file diff --git a/sources/DSK b/sources/DSK new file mode 100644 index 00000000..5d00e561 --- /dev/null +++ b/sources/DSK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-May-90 12:23:59" {DSK}mitani>medley>system>DSK.;1 2878 changes to%: (FNS \DSKEventFn) previous date%: "16-May-90 16:13:07" {DSK}local>lde>lispcore>sources>DSK.;2) (* ; " Copyright (c) 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DSKCOMS) (RPAQQ DSKCOMS ((PROP (FILETYPE MAKEFILE-ENVIRONMENT) DSK) (* ;; " Create FDEV function.") (FNS \DSKCreateDevice \DSKOpenDevice \DSKCloseDevice) (* ;; "UNIX File System's FDEV methods. Only one here--the rest are shared with UFS") (FNS \DSKEventFn) (* ;; "Variables for UFS.") (INITVARS (\DSKDefaultConnDir "~/") (\DSKdevice) (\DSKtopMonitor (CREATE.MONITORLOCK "DSKTopMonitor"))) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \DSKdevice \DSKtopMonitor \DSKDefaultConnDir) (FILES (LOADCOMP) UFS)))) (PUTPROPS DSK FILETYPE :BCOMPL) (PUTPROPS DSK MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (* ;; " Create FDEV function.") (DEFINEQ (\DSKCreateDevice (LAMBDA NIL (* ; "Edited 27-Feb-89 18:29 by bvm") (* ;;; "Creates and remembers the local hard disk file device, but does not open the device or any of its associated directories.") (if (AND (BOUNDP (QUOTE \DSKdevice)) (type? FDEV \DSKdevice)) then \DSKdevice else (SETQ \DSKdevice (\UFS.CREATE.DEVICE (QUOTE DSK) (FUNCTION \DSKEventFn))))) ) (\DSKOpenDevice (LAMBDA NIL (* ; "Edited 12-Apr-88 18:05 by HH") (WITH.MONITOR \DSKtopMonitor (LET ((DEV (\DSKCreateDevice))) (\DEFINEDEVICE (QUOTE DSK) DEV) DEV))) ) (\DSKCloseDevice (LAMBDA NIL (* ; "Edited 28-Mar-88 11:11 by HH") (WITH.MONITOR \DSKtopMonitor (\REMOVEDEVICE \DSKdevice) NIL)) ) ) (* ;; "UNIX File System's FDEV methods. Only one here--the rest are shared with UFS") (DEFINEQ (\DSKEventFn (LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:37 by nm") (WITH.MONITOR \DSKtopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\DSKCloseDevice) (SELECTQ (MACHINETYPE) (MAIKO (\DSKOpenDevice) (* ;; "revalidate open streams ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL))) ) ) (* ;; "Variables for UFS.") (RPAQ? \DSKDefaultConnDir "~/") (RPAQ? \DSKdevice) (RPAQ? \DSKtopMonitor (CREATE.MONITORLOCK "DSKTopMonitor")) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DSKdevice \DSKtopMonitor \DSKDefaultConnDir) ) (FILESLOAD (LOADCOMP) UFS) ) (PUTPROPS DSK COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1074 1757 (\DSKCreateDevice 1084 . 1448) (\DSKOpenDevice 1450 . 1620) (\DSKCloseDevice 1622 . 1755)) (1853 2474 (\DSKEventFn 1863 . 2472))))) STOP \ No newline at end of file diff --git a/sources/DSKDISPLAY b/sources/DSKDISPLAY new file mode 100644 index 00000000..8f6057b3 --- /dev/null +++ b/sources/DSKDISPLAY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Jun-90 13:01:45" {DSK}oze>yabu>DSKDISPLAY.;1 11124 changes to%: (VARS DSKDISPLAYCOMS) previous date%: "16-May-90 16:16:07" |{PELE:MV:ENVOS}SOURCES>DSKDISPLAY.;2|) (* ; " Copyright (c) 1985, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DSKDISPLAYCOMS) (RPAQQ DSKDISPLAYCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) LOCALFILE)) (DECLARE%: (LOCALVARS . T)) (FNS DSKDISPLAY \DSKDISPLAY.BUTTONEVENTFN \DSKDISPLAY.UPDATE \DSKDISPLAY.CREATE.WINDOW \DSKDISPLAY.DESTROY.WINDOW \DSKDISPLAY.REPAINTFN \DSKDISPLAY.RESHAPEFN) (GLOBALVARS \DSKDISPLAY.FONT \DSKDISPLAY.BOLD \DSKDISPLAY.STATE \DSKDISPLAY.WINDOW DSKDISPLAY.POSITION) (INITVARS (\DSKDISPLAY.FONT (FONTCREATE 'GACHA 10 'MRR)) (\DSKDISPLAY.BOLD (FONTCREATE 'GACHA 10 'BRR)) (DSKDISPLAY.POSITION (CONS 100 50)) (* ;  " Original was (CREATE POSITION XCOORD _ 100 YCOORD _ 50).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (\DSKDISPLAY.STATE 'CLOSED) (\DSKDISPLAY.WINDOW NIL)))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) LOCALFILE) ) (DECLARE%: (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DEFINEQ (DSKDISPLAY [LAMBDA (newState) (* ; "Edited 12-Jan-87 12:19 by amd") (* ;; "Returns the old state of the file system display window. If newState is one of {ON, OFF, CLOSED}, sets this to be the new state: ON means updates continuously, OFF means updates only when buttoned, CLOSED means the display window is indeed closed.") (SELECTQ (MACHINETYPE) ((DANDELION DOVE) (if (\PFEnsureInitialized) then (LET ((oldState \DSKDISPLAY.STATE)) (SELECTQ newState ((ON OFF) (SETQ \DSKDISPLAY.STATE newState) (\DSKDISPLAY.CREATE.WINDOW) (WINDOWPROP \DSKDISPLAY.WINDOW 'TITLE (CONCAT "Local File System Display: " \DSKDISPLAY.STATE)) (REDISPLAYW \DSKDISPLAY.WINDOW)) (CLOSED (SETQ \DSKDISPLAY.STATE newState) (\DSKDISPLAY.DESTROY.WINDOW)) NIL) oldState))) NIL]) (\DSKDISPLAY.BUTTONEVENTFN [LAMBDA (W) (* ; "Edited 12-Jan-87 12:19 by amd") (* ;;  "Button event function to allow user to change file system display state with the mouse.") (if (MOUSESTATE LEFT) then (\DSKDISPLAY.REPAINTFN W) elseif (MOUSESTATE MIDDLE) then (DSKDISPLAY (MENU (create MENU ITEMS _ '(ON OFF CLOSED]) (\DSKDISPLAY.UPDATE [LAMBDA NIL (* ; "Edited 12-Jan-87 12:19 by amd") (* ;; "IF the local file system window stuff is set for continuous update, and there is a valid display window, update the display window.") (if (AND (EQ \DSKDISPLAY.STATE 'ON) (WINDOWP \DSKDISPLAY.WINDOW)) then (REDISPLAYW \DSKDISPLAY.WINDOW]) (\DSKDISPLAY.CREATE.WINDOW [LAMBDA NIL (* ; "Edited 12-Jan-87 15:35 by amd") (* ;; "Creates the local file system display window.") (if (NOT (WINDOWP \DSKDISPLAY.WINDOW)) then (SETQ \DSKDISPLAY.WINDOW (CREATEW (create REGION WIDTH _ 300 HEIGHT _ (IPLUS (ITIMES (FONTPROP \DSKDISPLAY.FONT 'HEIGHT) (IPLUS (LENGTH ( \PFGetVols )) 2)) (ITIMES WBorder 2) (FONTPROP WindowTitleDisplayStream 'HEIGHT)) LEFT _ (fetch (POSITION XCOORD) of DSKDISPLAY.POSITION ) BOTTOM _ (fetch (POSITION YCOORD) of DSKDISPLAY.POSITION )) "1108 Local File System")) (WINDOWPROP \DSKDISPLAY.WINDOW 'REPAINTFN (FUNCTION \DSKDISPLAY.REPAINTFN)) [WINDOWPROP \DSKDISPLAY.WINDOW 'RESHAPEFN (FUNCTION (LAMBDA (W) (\DSKDISPLAY.REPAINTFN W) (LET [(REG (WINDOWPROP W 'REGION] (SETQ DSKDISPLAY.POSITION (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM ) of REG] [WINDOWPROP \DSKDISPLAY.WINDOW 'MOVEFN (FUNCTION (LAMBDA (W POS) (SETQ DSKDISPLAY.POSITION POS] (WINDOWPROP \DSKDISPLAY.WINDOW 'BUTTONEVENTFN (FUNCTION \DSKDISPLAY.BUTTONEVENTFN)) (WINDOWPROP \DSKDISPLAY.WINDOW 'CLOSEFN (FUNCTION (LAMBDA NIL (DSKDISPLAY 'CLOSED]) (\DSKDISPLAY.DESTROY.WINDOW [LAMBDA NIL (* edited%: " 4-Jul-85 02:35") (* * Purges the local file system display window) (if [AND (WINDOWP \DSKDISPLAY.WINDOW) (NULL (WINDOWPROP \DSKDISPLAY.WINDOW 'CLOSING] then (WINDOWPROP \DSKDISPLAY.WINDOW 'CLOSING T) (CLOSEW \DSKDISPLAY.WINDOW) (SETQ \DSKDISPLAY.WINDOW NIL]) (\DSKDISPLAY.REPAINTFN [LAMBDA (W) (* edited%: " 4-Jul-85 03:08") (CLEARW W) (printout W .FONT \DSKDISPLAY.FONT "Default directory: " .FONT \DSKDISPLAY.BOLD (DIRECTORYNAME '{DSK}) .FONT \DSKDISPLAY.FONT T "Logical Volumes:" T) (for vol in (\PFGetVols) do (printout W .FONT \DSKDISPLAY.FONT (if (\LFDirectoryP vol) then "* " else " ") (\PFVolumeNumber vol) " " .FONT \DSKDISPLAY.BOLD (fetch (LogicalVolumeDescriptor LVlabel) of vol) " " .FONT \DSKDISPLAY.FONT .FR 22 (fetch ( LogicalVolumeDescriptor volumeSize) of vol) " Pages" .FR 35 (fetch (LogicalVolumeDescriptor freePageCount) of vol) " Free" T]) (\DSKDISPLAY.RESHAPEFN [LAMBDA (W) (* hts%: " 6-Aug-85 14:11") (* * Takes care of the necessary glop after reshaping the display window%:  redisplays it and remembers the new position.) (\DSKDISPLAY.REPAINTFN W) [LET [(REG (WINDOWPROP W 'REGION] (SETQ DSKDISPLAY.POSITION (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG] NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DSKDISPLAY.FONT \DSKDISPLAY.BOLD \DSKDISPLAY.STATE \DSKDISPLAY.WINDOW DSKDISPLAY.POSITION) ) (RPAQ? \DSKDISPLAY.FONT (FONTCREATE 'GACHA 10 'MRR)) (RPAQ? \DSKDISPLAY.BOLD (FONTCREATE 'GACHA 10 'BRR)) (RPAQ? DSKDISPLAY.POSITION (CONS 100 50)) (RPAQ? \DSKDISPLAY.STATE 'CLOSED) (RPAQ? \DSKDISPLAY.WINDOW NIL) (PUTPROPS DSKDISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1985 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1906 10636 (DSKDISPLAY 1916 . 3298) (\DSKDISPLAY.BUTTONEVENTFN 3300 . 3813) ( \DSKDISPLAY.UPDATE 3815 . 4249) (\DSKDISPLAY.CREATE.WINDOW 4251 . 8118) (\DSKDISPLAY.DESTROY.WINDOW 8120 . 8578) (\DSKDISPLAY.REPAINTFN 8580 . 10030) (\DSKDISPLAY.RESHAPEFN 10032 . 10634))))) STOP \ No newline at end of file diff --git a/sources/DSPRINTDEF b/sources/DSPRINTDEF new file mode 100644 index 00000000..1897c799 --- /dev/null +++ b/sources/DSPRINTDEF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:27:05" {DSK}lde>lispcore>sources>DSPRINTDEF.;2 18635 changes to%: (RECORDS DEDITMAP) previous date%: "16-May-90 16:17:21" {DSK}lde>lispcore>sources>DSPRINTDEF.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DSPRINTDEFCOMS) (RPAQQ DSPRINTDEFCOMS [(COMS (* ;  "NEWPRINTDEF primitives for a display that maintains a map as it PPs") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS BLANKS WIDTH XPOSITION YPOSITION OVERLAP) (GLOBALVARS \DEDITDSPS \DSPRINTBP \DEDITMEHASH \DEDITDPHASH \DEDITFONT# \DEDITFONTS COMMENTFLG) (CONSTANTS DOTSTRING) (COMS (* ;; "The DEDITMAP record declaration is here because several functions in this file use it when MAKEMAP is true (only on calls from DEDIT). However, it is DONTCOPY -- the INITRECORDS definition is on DEDITPP, which is only loaded when DEDIT is") (RECORDS DEDITMAP))) (FNS PRINOPEN PRINSHUT PRIN1S PRIN2S PRINENDLINE PRINDOTP SETFONT MAKEDOTPTAIL)) (COMS (* ; "Wrappers") (FNS SUPERPRINT/WRAPPER)) (COMS (* ; "String printer") (FNS PRIN2STRING PRIN2-LONG-STRING) (INITVARS (*DIVIDE-LONG-STRINGS* 'DISPLAY]) (* ; "NEWPRINTDEF primitives for a display that maintains a map as it PPs") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS BLANKS MACRO ((N) (TIMES N SPACEWIDTH))) (PUTPROPS WIDTH MACRO ((STR STREAM P2FLG) (STRINGWIDTH STR (OR STREAM *STANDARD-OUTPUT*) P2FLG))) (PUTPROPS XPOSITION MACRO ((X) (DSPXPOSITION X FILE))) (PUTPROPS YPOSITION MACRO ((Y) (DSPYPOSITION Y))) [PUTPROPS OVERLAP MACRO (OPENLAMBDA (H1 L1 H2 L2) (NOT (OR (ILESSP H1 L2) (ILESSP H2 L1] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DEDITDSPS \DSPRINTBP \DEDITMEHASH \DEDITDPHASH \DEDITFONT# \DEDITFONTS COMMENTFLG) ) (DECLARE%: EVAL@COMPILE (RPAQQ DOTSTRING " . ") (CONSTANTS DOTSTRING) ) (* ;; "The DEDITMAP record declaration is here because several functions in this file use it when MAKEMAP is true (only on calls from DEDIT). However, it is DONTCOPY -- the INITRECORDS definition is on DEDITPP, which is only loaded when DEDIT is" ) (DECLARE%: EVAL@COMPILE (DATATYPE DEDITMAP ((D# BYTE) (TAIL POINTER) (F# BYTE) (BP POINTER) (STARTX WORD) (STOPX WORD) (STARTY WORD) (STOPY WORD) (LONGSTRINGP FLAG) (* ;  "SELEXP is a string neatly divided over several lines") (LONGSTRING1MARGINP FLAG) (* ;; "String's left margin is same on every line. If false, then left margin for second and subsequent lines is STARTX of BP") (LONGSTRINGSYMMETRICP FLAG) (* ;; "String was in a centered comment, so its right margin is indented symmetrically with its left margin") (NIL 5 FLAG) (WRAPPER POINTER)) [ACCESSFNS DEDITMAP ((FNT (ELT \DEDITFONTS (fetch F# of DATUM))) (PDSP (ELT \DEDITDSPS (fetch D# of DATUM))) (SELEXP (CAR (fetch TAIL of DATUM))) (LPEND (DEDIT.LPEND DATUM)) (RPSTART (DEDIT.RPSTART DATUM]) ) (/DECLAREDATATYPE 'DEDITMAP '(BYTE POINTER BYTE POINTER WORD WORD WORD WORD FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER) '((DEDITMAP 0 (BITS . 7)) (DEDITMAP 2 POINTER) (DEDITMAP 1 (BITS . 7)) (DEDITMAP 4 POINTER) (DEDITMAP 6 (BITS . 15)) (DEDITMAP 7 (BITS . 15)) (DEDITMAP 8 (BITS . 15)) (DEDITMAP 9 (BITS . 15)) (DEDITMAP 4 (FLAGBITS . 0)) (DEDITMAP 4 (FLAGBITS . 16)) (DEDITMAP 4 (FLAGBITS . 32)) (DEDITMAP 4 (FLAGBITS . 48)) (DEDITMAP 2 (FLAGBITS . 0)) (DEDITMAP 2 (FLAGBITS . 16)) (DEDITMAP 2 (FLAGBITS . 32)) (DEDITMAP 2 (FLAGBITS . 48)) (DEDITMAP 10 POINTER)) '12) ) (DEFINEQ (PRINOPEN (LAMBDA (TAIL PAREN FILE) (* lmm "30-Jul-85 03:12") (COND (MAKEMAP (SETQ MAKEMAP (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) (DSPXPOSITION NIL FILE) (DSPYPOSITION NIL FILE) 0 0 (\DEDITFONT# FILE))))) (PRIN3 PAREN FILE)) ) (PRINSHUT (LAMBDA (TAIL PAREN FILE) (* AJB "22-Jan-86 16:30") (AND PAREN (PRIN3 PAREN FILE)) (COND (MAKEMAP (COND ((EQ MAKEMAP T) (SHOULDNT))) (replace STOPX of MAKEMAP with (DSPXPOSITION NIL FILE)) (replace STOPY of MAKEMAP with (DSPYPOSITION NIL FILE)) (SETQ MAKEMAP (OR (fetch BP of MAKEMAP) T))))) ) (PRIN1S (LAMBDA (STR TAIL FILE) (* lmm "18-Jan-86 01:09") (COND (MAKEMAP (* ; "if remembering where things went") (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) (DSPXPOSITION NIL FILE) (DSPYPOSITION NIL FILE) (PROGN (PRIN3 STR FILE) (DSPXPOSITION NIL FILE)) (DSPYPOSITION NIL FILE) (\DEDITFONT# FILE)) STR) (T (PRIN3 STR FILE)))) ) (PRIN2S (LAMBDA (STR TAIL FILE) (* lmm "30-Jul-85 03:26") (COND (MAKEMAP (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) (DSPXPOSITION NIL FILE) (DSPYPOSITION NIL FILE) (PROGN (PRIN4 STR FILE) (DSPXPOSITION NIL FILE)) (DSPYPOSITION NIL FILE) (\DEDITFONT# FILE)) STR) (T (PRIN4 STR FILE)))) ) (PRINENDLINE (LAMBDA (NEWXPOSITION FILE) (* ; "Edited 1-Apr-88 14:24 by bvm") (* ;; "Terminate line, setting x at NEWXPOSITION.") (OR FILE (SETQ FILE *STANDARD-OUTPUT*)) (COND (MAKEMAP (* ; "From DEdit") (MOVETO NEWXPOSITION (+ (DSPYPOSITION NIL FILE) (DSPLINEFEED NIL FILE)) FILE)) (T (TERPRI FILE) (COND ((OR (SELECTQ (IMAGESTREAMTYPE FILE) ((NIL TEXT) (* ; "These don't know how to set x position") T) (PROGN (* ; "Assume all other image streams are ok") NIL)) (if (EQ FILE (TTYDISPLAYSTREAM)) then (* ; "Even if FILE knows how to set xpos, the dribble file doesn't, so use spaces") (DRIBBLEFILE))) (SETFONT (PROG1 (SETFONT DEFAULTFONT FILE) (* ;; "Print introductory spaces in the default font because we don't quite have this right yet for pspool files") (LET ((NS (QUOTIENT (- NEWXPOSITION (DSPXPOSITION NIL FILE)) SPACEWIDTH))) (RPTQ (QUOTIENT NS 8) (PRIN3 " " FILE)) (RPTQ (REMAINDER NS 8) (PRIN3 " " FILE)))) FILE))) (DSPXPOSITION NEWXPOSITION FILE)))) ) (PRINDOTP (LAMBDA (E FILE) (* ; "Edited 13-Apr-88 15:08 by bvm") (* ;; "Print a dotted tail consisting of the non-list E, i.e., print %" . %"") (LET* ((DOT " . ") (MAXPOS (- RMARGIN (WIDTH E FILE T) (WIDTH DOT FILE) (WIDTH ")" FILE)))) (* ; "MAXPOS is the rightmost position at which this will fit") (if (AND (> (DSPXPOSITION NIL FILE) MAXPOS) (>= MAXPOS FIRSTPOS)) then (* ; "Print dotted tail on next line as far to right as possible") (PRINENDLINE MAXPOS FILE)) (PRIN3 DOT FILE) (PRIN2S E (COND (MAKEMAP (MAKEDOTPTAIL E MAKEMAP)) (T (CONS E E))) FILE))) ) (SETFONT [LAMBDA (FONT FILE) (* ; "Edited 2-Nov-88 13:16 by drc:") (* ;; "FONT can be a font, a number or a FONTCLASS. Returns a FONTDESCRIPTOR FOR PPDSP") (COND (FONT (* ;  "if FONT is NIL, leave things alone.") (LET ((OLDFONT (DSPFONT FONT FILE))) [COND ((NEQ OLDFONT FONT) (AND MAKEMAP (SETQ \DEDITFONT#)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE x) FILE)) (* ;  "SPACEWIDTH really means %"average character width%"") ) ((NULL SPACEWIDTH) (* ;; "initialize SPACEWIDTH") (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE x) FILE] OLDFONT]) (MAKEDOTPTAIL (LAMBDA (V B) (* bas%: "18-Mar-84 21:10") (* ;; "DPs have map entries keyed off a dummy CONS which is found by a hash link off the parent CONS thru the \DEDITDPHASH array. Done this way so we have a CONS to push on the selection stack which makes most of the changing functions transparent and which can be found quickly and repeatably. Usually we do not have the DP cons itself in hand, hence use of the parent CONS.") (* ;; "If there is a dummy CONS for the DP, we must preserve it because it may be being used as a key e.g. from the selection stack. But we must also ensure that it has the right contents, namely V") (PUTHASH (fetch TAIL of B) (RPLNODE (OR (GETHASH (fetch TAIL of B) \DEDITDPHASH) (CONS)) V V) \DEDITDPHASH)) ) ) (* ; "Wrappers") (DEFINEQ (SUPERPRINT/WRAPPER (LAMBDA (MACRO E TAIL BRFLG FILE) (* ; "Edited 15-Apr-88 11:51 by bvm") (* ;;; "Print E as MACRO followed by (CADR E), for example, print (QUOTE foo) as 'foo") (LET ((BODY (CADR E))) (if (AND (NLISTP BODY) (> (+ (DSPXPOSITION NIL FILE) (WIDTH MACRO FILE) (WIDTH BODY FILE T) (WIDTH ")" FILE)) RMARGIN)) then (* ; "It won't fit here. Case where BODY is a list is already judged in advance by prettyprinter.") (PRINENDLINE LEFT FILE)) (PRINOPEN TAIL MACRO FILE) (* ; "Print the prefix") (COND (MAKEMAP (* ;; "Need to fool DEDIT into thinking that it is printing the whole list E when only (CADR E) appears in print. So do a fake entry for (CAR E) whose width is zero") (replace WRAPPER of MAKEMAP with MACRO) (* ; "MAKEMAP is the entry for E -- want everyone to know it wasn't printed as normal list") (LET ((X (DSPXPOSITION NIL FILE)) (Y (DSPYPOSITION NIL FILE))) (MAKEMAPENTRY E (AND (NEQ MAKEMAP T) MAKEMAP) X Y X Y (\DEDITFONT# FILE))))) (LET ((LEFT (DSPXPOSITION NIL FILE))) (DECLARE (SPECVARS LEFT)) (PROG1 (SUPERPRINT BODY (CDR E) BRFLG FILE) (* ; "Make sure to return the result of SUPERPRINT, so that caller (eventually SUBPRINT) knows whether we printed something like a list or not") (PRINSHUT TAIL NIL FILE) (* ; "Finally, print a vacuous closing paren"))))) ) ) (* ; "String printer") (DEFINEQ (PRIN2STRING (LAMBDA (STR TAIL FILE LMARG RMARG COMMENTP) (* bvm%: "27-May-86 15:36") (COND ((SELECTQ *DIVIDE-LONG-STRINGS* (NIL NIL) (DISPLAY (IMAGESTREAMP FILE)) T) (PRIN2-LONG-STRING STR FILE T TAIL LMARG RMARG COMMENTP)) (T (LET ((TEM (IDIFFERENCE RMARGIN (WIDTH STR FILE T)))) (* ; "TEM is the last position at which E will fit") (COND ((AND (ILESSP TEM (DSPXPOSITION NIL FILE)) (IGREATERP TEM FIRSTPOS)) (PRINENDLINE (IMIN LMARG TEM) FILE)))) (PRIN2S STR TAIL FILE)))) ) (PRIN2-LONG-STRING (LAMBDA (STRING STREAM P2FLG TAIL LMARG RMARG COMMENTP USE-SEMI-COLONS) (* ; "Edited 15-Apr-88 11:41 by bvm") (* ;; "Fancy string printer that divides long strings into multiple lines at convenient breaks. If P2FLG is true, this is a call from PRIN2 or friend, in which case the surrounding doublequotes are printed, as well as escapes in front of special chars. TAIL is the list car of which is STRING. LMARG and RMARG specify the desired margins of the text. If COMMENTP is true, this is a comment. In addition, if USE-SEMI-COLONS is non-NIL, this is a semi-colon comment with that many semis.") (PROG ((ESC (fetch (READTABLEP ESCAPECHAR) of *READTABLE*)) (SA (fetch (READTABLEP READSA) of *READTABLE*)) (HERE (DSPXPOSITION NIL STREAM)) (FONT (DSPFONT NIL STREAM)) (IMSTREAMP (IMAGESTREAMP STREAM)) ESCWIDTH SPACEWIDTH CLOSEWIDTH SEMIWIDTH LASTSPACE I C NEXTC POS J MAPX1 MAPY1 SINGLELEFT SEMISTRING ESCAPESEPRS SEMICLOSE) (COND ((NOT (type? FONTDESCRIPTOR FONT)) (* ; "Ugh, happens for files") (SETQ FONT STREAM))) (SETQ ESCWIDTH (CHARWIDTH ESC FONT)) (SETQ SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) FONT)) (SETQ CLOSEWIDTH (COND (P2FLG (STRINGWIDTH "%")" FONT)) (T 0))) (if USE-SEMI-COLONS then (if (< USE-SEMI-COLONS 5) then (* ; "Semicolon comment") (SETQ SEMIWIDTH (+ SPACEWIDTH (TIMES USE-SEMI-COLONS (CHARWIDTH (CHARCODE ";") FONT)))) (SETQ SEMISTRING (CONCAT (ALLOCSTRING USE-SEMI-COLONS (CHARCODE ";")) " ")) else (* ; "Balanced (hash bar) comment") (SETQ SEMISTRING "#|") (SETQ SEMIWIDTH (STRINGWIDTH SEMISTRING FONT)) (SETQ SEMICLOSE "|#"))) (COND ((for C instring (PROGN (* ; "dwimify bug tries to turn naked STRING into (STRING C) here.") STRING) as I from 1 bind (POS _ (+ HERE (COND (P2FLG (CHARWIDTH (CHARCODE %") FONT)) ((NULL USE-SEMI-COLONS) 0) ((< USE-SEMI-COLONS 5) SEMIWIDTH) (T (* ; "Include the width of the closing |#") (TIMES 2 SEMIWIDTH))) CLOSEWIDTH)) do ((COND ((EQ C (CHARCODE CR)) (* ; "Always want to print these strings specially") (SETQ LASTSPACE I) (RETURN NIL)) ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (* ; "Need escape") (add POS ESCWIDTH))) (COND ((> (add POS (CHARWIDTH C FONT)) RMARG) (RETURN NIL))) (COND ((EQ C (CHARCODE SPACE)) (SETQ LASTSPACE I)))) finally (RETURN T)) (* ; "It all fits on this line") (RETURN (COND (P2FLG (PRIN2S STRING TAIL STREAM)) (T (if SEMISTRING then (PRIN1 SEMISTRING STREAM)) (PRIN1S STRING TAIL STREAM) (if SEMICLOSE then (PRIN1 SEMICLOSE STREAM))))))) (COND ((OR (NULL LASTSPACE) (AND (NULL COMMENTP) (NEQ HERE LMARG) MAKEMAP)) (* ;; "Can't print anything on this line before the end. Comments are allowed to have different first and subsequent margin In DEdit, but not ordinary strings.") (PRINENDLINE (SETQ HERE LMARG) STREAM) (SETQ LASTSPACE 0))) (COND (MAKEMAP (* ; "Note start") (SETQ MAPX1 HERE) (SETQ MAPY1 (DSPYPOSITION NIL STREAM)) (SETQ SINGLELEFT (EQ HERE LMARG)))) (COND (P2FLG (COND ((NOT (IMAGESTREAMP STREAM)) (* ; "Need to be able to read it back") (SETQ ESCAPESEPRS T) (LET ((HASH (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*))) (\OUTCHAR STREAM HASH) (add HERE (CHARWIDTH HASH FONT))))) (\OUTCHAR STREAM (CHARCODE %")) (add HERE (CHARWIDTH (CHARCODE %") FONT))) (USE-SEMI-COLONS (* ; "Print the first set of semi-colons or #|") (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH) (if (EQ USE-SEMI-COLONS 5) then (* ; "No more semis now") (SETQ SEMISTRING NIL)))) (* ;;; "Now loop, printing as much as we can while there's room") (SETQ I 0) LP (COND ((NULL (SETQ C (NTHCHARCODE STRING (add I 1)))) (* ; "Done") (GO DONE)) ((NOT (< I LASTSPACE)) (* ;; "Must find the next safe place to print up to. LASTSPACE is either a space or CR position, or is 0, which is our state when printing from the left margin until we encounter a space.") (SETQ POS HERE) (SETQ J I) (* ; "Ordinarily, J is pointing at a space or CR except when we have just printed an endline") (SELCHARQ C (SPACE (* ; "Would like all spaces before the eol, where they're invisible, not after") (SELCHARQ (NTHCHARCODE STRING (ADD1 J)) ((SPACE CR NIL) (SETQ LASTSPACE (ADD1 J)) (* ; "Go ahead and print this space, and note that it is now okay to break the line") (COND ((AND (>= (+ HERE SPACEWIDTH) RMARG) (NOT ESCAPESEPRS)) (* ; "Extra spaces have no effect, so don't print them at all, lest the dsprightmargin bite") (GO LP)) (T (GO PRINTIT)))) NIL) (add POS SPACEWIDTH)) (CR (* ; "If two cr's in a row, print them all; if only one, must escape it") (COND ((EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) (PRINENDLINE LMARG STREAM) (while (EQ (SETQ C (NTHCHARCODE STRING (add I 1))) (CHARCODE CR)) do (PRINENDLINE LMARG STREAM))) (ESCAPESEPRS (\OUTCHAR STREAM ESC))) (SETQ LASTSPACE 0) (GO ENDLINE)) (PROGN (* ;; "Gets set this way at left edge. Must print something on this line, even if there are no spaces before the right edge") (GO CHECKESCAPE))) (SETQ LASTSPACE 0) (while (< POS RMARG) do (SELCHARQ (SETQ NEXTC (NTHCHARCODE STRING (add J 1))) ((CR SPACE) (* ; "Can safely go this far") (SETQ LASTSPACE J) (RETURN)) (NIL (* ; "End of string -- ok if there is space for closing quote and paren as well") (COND ((< (+ POS CLOSEWIDTH) RMARG) (SETQ LASTSPACE J) (RETURN)) (T (GO $$OUT)))) NIL) (COND ((OR (EQ NEXTC (CHARCODE %")) (EQ NEXTC ESC)) (add POS ESCWIDTH))) (add POS (CHARWIDTH NEXTC FONT)) finally (COND ((EQ LASTSPACE 0) (* ; "Need break") (COND ((EQ C (CHARCODE SPACE)) (* ; "Will turn this space into CR") (SETQ C (NTHCHARCODE STRING (add I 1)))) (T (SHOULDNT))) (GO ENDLINE)))))) CHECKESCAPE (COND ((AND P2FLG (OR (EQ C (CHARCODE %")) (EQ C ESC))) (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH))) PRINTIT (\OUTCHAR STREAM C) (add HERE (CHARWIDTH C FONT)) (GO LP) ENDLINE (PRINENDLINE LMARG STREAM) (SETQ HERE LMARG) (COND ((NULL C) (* ; "Done") (GO DONE)) ((AND ESCAPESEPRS (EQ (\SYNCODE SA C) SEPRCHAR.RC)) (* ; "Have to quote sepr immediately following CR") (\OUTCHAR STREAM ESC) (add HERE ESCWIDTH) (GO PRINTIT)) (T (COND (SEMISTRING (PRIN1 SEMISTRING STREAM) (add HERE SEMIWIDTH))) (GO CHECKESCAPE))) DONE (COND (P2FLG (\OUTCHAR STREAM (CHARCODE %")))) (COND (MAKEMAP (LET ((ENTRY (MAKEMAPENTRY TAIL (AND (NEQ MAKEMAP T) MAKEMAP) MAPX1 MAPY1 (DSPXPOSITION NIL STREAM) (DSPYPOSITION NIL STREAM) (\DEDITFONT# STREAM)))) (replace LONGSTRINGP of ENTRY with T) (COND (SINGLELEFT (replace LONGSTRING1MARGINP of ENTRY with T))) (COND ((EQ (- (DSPRIGHTMARGIN NIL STREAM) LMARG) RMARG) (* ;; "Assume that RMARG not equal to stream's right margin only happens for centered comments. In reality, it happens as well inside REPP, where RESETCLIP hides the true right margin.") (replace LONGSTRINGSYMMETRICP of ENTRY with T))))) (SEMICLOSE (PRIN1 SEMICLOSE STREAM))) (RETURN))) ) ) (RPAQ? *DIVIDE-LONG-STRINGS* 'DISPLAY) (PUTPROPS DSPRINTDEF COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5344 9916 (PRINOPEN 5354 . 5594) (PRINSHUT 5596 . 5903) (PRIN1S 5905 . 6242) (PRIN2S 6244 . 6540) (PRINENDLINE 6542 . 7517) (PRINDOTP 7519 . 8084) (SETFONT 8086 . 9160) (MAKEDOTPTAIL 9162 . 9914)) (9942 11250 (SUPERPRINT/WRAPPER 9952 . 11248)) (11282 18460 (PRIN2STRING 11292 . 11772) ( PRIN2-LONG-STRING 11774 . 18458))))) STOP \ No newline at end of file diff --git a/sources/DTDECLARE b/sources/DTDECLARE new file mode 100644 index 00000000..95fbc0ec --- /dev/null +++ b/sources/DTDECLARE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 8-Mar-95 10:22:57" |{DSK}sources>DTDECLARE.;2| 34107 |changes| |to:| (FNS TRANSLATE.DATATYPE) |previous| |date:| "15-Dec-92 14:08:39" |{DSK}sources>DTDECLARE.;1|) ; Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1995 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT DTDECLARECOMS) (RPAQQ DTDECLARECOMS ( (* |;;| "declaring DATATYPES --- part of ABC too") (FNS /DECLAREDATATYPE DECLAREDATATYPE TRANSLATE.DATATYPE \\REUSETO \\TYPEGLOBALVARIABLE) (FUNCTIONS TYPE-VARIABLE-FROM-TYPE-NAME) (FNS |BitFieldMask| |BitFieldShift| |BitFieldShiftedMask| |MakeBitField| |BitFieldWidth| |BitFieldFirst|) (OPTIMIZERS FETCHFIELD FFETCHFIELD REPLACEFIELD FREPLACEFIELD REPLACEFIELDVAL FREPLACEFIELDVAL NCREATE \\DTEST) (PROP DMACRO \\TESTBITS) (FNS COMPILEDFETCHFIELD COMPILEDREPLACEFIELD COMPILEDNCREATE) (DECLARE\: DONTCOPY (EXPORT (RECORDS |FldDsc|))) (VARS DATATYPEFIELDTYPES) (COMS (* \;  "Macros which convert a record access form into an address-generating form") (MACROS LOCF INDEXF) (FNS TRANSLATE.LOCF)) (LOCALVARS . T) (PROP FILETYPE DTDECLARE))) (* |;;| "declaring DATATYPES --- part of ABC too") (DEFINEQ (/declaredatatype (lambda (typename fieldspecs dlist len supertype) (* \; "Edited 18-May-87 17:09 by Snow") (and lispxhist typename (undosave (list '/declaredatatype typename (getfieldspecs typename) nil nil (getsupertype typename)))) (cl:multiple-value-bind (dlist redeclared) (declaredatatype typename fieldspecs dlist len supertype) (cond (redeclared (lispxprint (list '|datatype| typename '|redeclared|) t t))) dlist))) (declaredatatype (lambda (typename fieldspecs dlist length supertype) (* |Pavel| "16-Oct-86 14:52") (* |;;| "this is called twice when declaring records; once where the DLIST and LENGTH hasn't been computed, and another time when it has.") (let ((superspecs (cond (supertype (getfieldspecs supertype))))) (* \; "maybe an error if supertype doesn't exist?") (setq fieldspecs (append superspecs fieldspecs)) (cond ((and fieldspecs (or (not dlist) (not length))) (* \;  "the AND is an optimization -- do we really need to compute DLIST?") (setq dlist (translate.datatype typename fieldspecs)) (setq length (|pop| dlist))))) (or (and typename (litatom typename)) (lisperror "ILLEGAL ARG" typename)) (let ((ptrs (|for| p |in| dlist |when| (selectq (|fetch| |fdType| |of| p) ((pointer fullpointer) t) nil) |collect| (|fetch| |fdOffset| |of| p)))) (cl:multiple-value-bind (typenum redeclared) (\\assigndatatype1 typename dlist length fieldspecs ptrs supertype) (settopval (\\typeglobalvariable typename t) typenum) (cl:values dlist redeclared))))) (TRANSLATE.DATATYPE (LAMBDA (TYPENAME FIELDSPECS) (* DECLARATIONS\: (RECORD SPEC  (N LEN . FD))) (DECLARE (SPECVARS TYPENAME UNUSED BIT OFFSET FD)) (* \;  "Edited 8-Mar-95 10:18 by sybalsky:mv:envos") (COND ((NULL TYPENAME)) ((OR (NOT (LITATOM TYPENAME)) (EQ TYPENAME '**DEALLOC**)) (ERROR "Invalid type name" TYPENAME))) (PROG ((N 0) UNUSED (OFFSET 0) (BIT 0) DLIST REUSE LEN FD) (SETQ DLIST (|for| S |in| FIELDSPECS |collect| (|create| SPEC N _ (|add| N 1) LEN _ (SELECTQ S ((POINTER XPOINTER) (COND ((FMEMB :4-BYTE-TEMP COMPILER::*TARGET-ARCHITECTURE* ) (* \;  "For old systems running in compatibility mode, assume 28-bit pointers when reserving space") 28) ((FMEMB :4-BYTE COMPILER::*TARGET-ARCHITECTURE* ) (* \;  "For BIGVM systems, use 28 bits for pointers") 28) (T (* \;  "For release 2.0 and earlier, use 24-bit pointers.") 24))) ((FIXP FLOATP SWAPPEDFIXP FULLPOINTER SWAPPEDXPOINTER FULLXPOINTER) BITSPERCELL) (FLAG (SETQQ S FLAGBITS) 1) (BYTE (SETQQ S BITS) BITSPERBYTE) (WORD (SETQQ S BITS) BITSPERWORD) (SIGNEDWORD (SETQQ S SIGNEDBITS) BITSPERWORD) (SELECTQ (CAR (LISTP S)) ((BITS FLAGBITS SIGNEDBITS) (PROG1 (CADR S) (SETQ S (CAR S)))) (ERROR "invalid field spec: " S))) FD _ (|create| |FldDsc| |fdTypeName| _ TYPENAME |fdType| _ S |fdOffset| _ NIL)))) (|for| S |in| DLIST |do| (|replace| |fdOffset| |of| (SETQ FD (|fetch| FD |of| S)) |with| (SELECTQ (|fetch| |fdType| |of| FD) ((POINTER XPOINTER) (COND ((AND TYPENAME (|find| X |in| UNUSED |suchthat| (AND (EQ 0 (LOGAND (CAR X) 1)) (IGEQ (CADDR X) (- (COND ((FMEMB :4-BYTE-TEMP COMPILER::*TARGET-ARCHITECTURE*) (* \;  "For old systems running in compatibility mode, assume 28-bit pointers when reserving space") 28) ((FMEMB :4-BYTE COMPILER::*TARGET-ARCHITECTURE* ) (* \;  "For BIGVM systems, use 28 bits for pointers") 28) (T (* \;  "For release 2.0 and earlier, use 24-bit pointers.") 24)) BITSPERWORD)) (EQ (IPLUS (CADR X) (CADDR X)) BITSPERWORD) (|find| Y |in| UNUSED |suchthat| (AND (EQ (CAR Y) (ADD1 (CAR X))) (EQ (CADDR Y) BITSPERWORD)))))) (* \; "unused 24 bit quantity") (* \; "this case not implemented yet") )) (COND ((IGREATERP BIT 4) (* \;  "Less than 8 bits left in this word") (\\REUSETO BITSPERWORD))) (COND ((ODDP OFFSET WORDSPERCELL) (* \; "not on double word boundary") (\\REUSETO BITSPERWORD))) (COND ((NEQ BIT 4) (\\REUSETO 4 (EQ BIT 0)))) (SETQ BIT 0) (* \; "") (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((FIXP SWAPPEDFIXP FLOATP SWAPPEDXPOINTER) (* \; "32 bit quantities") (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((FULLPOINTER FULLXPOINTER) (* \;  "32 bit doubleword-aligned quantities") (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (COND ((ODDP OFFSET WORDSPERCELL) (\\REUSETO BITSPERWORD))) (PROG1 OFFSET (|add| OFFSET WORDSPERCELL))) ((BITS FLAGBITS SIGNEDBITS) (SETQ LEN (|fetch| LEN |of| S)) (COND ((AND TYPENAME (SETQ REUSE (|find| X |in| UNUSED |suchthat| (ILEQ LEN (CADDR X))))) (RPLACA (CDDR REUSE) (IDIFFERENCE (CAR (CDDR REUSE)) LEN)) (|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType| |of| FD) (|MakeBitField| (CADR REUSE) LEN))) (|add| (CADR REUSE) LEN) (CAR REUSE)) ((IGREATERP LEN BITSPERWORD) (* \;  "more than 1 word --- Must right justify first word") (SETQ LEN (IDIFFERENCE LEN BITSPERWORD)) (COND ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT)) (\\REUSETO BITSPERWORD))) (COND ((NEQ (IDIFFERENCE BITSPERWORD BIT) LEN) (\\REUSETO (IDIFFERENCE BITSPERWORD LEN)))) (|replace| |fdType| |of| FD |with| (CONS 'LONGBITS (|MakeBitField| BIT LEN))) (SETQ BIT 0) (PROG1 OFFSET (|add| OFFSET 2))) (T (COND ((IGREATERP LEN (IDIFFERENCE BITSPERWORD BIT)) (\\REUSETO BITSPERWORD))) (|replace| |fdType| |of| FD |with| (CONS (|fetch| |fdType| |of| FD) (|MakeBitField| BIT LEN))) (|add| BIT LEN) (PROG1 OFFSET (COND ((EQ BIT BITSPERWORD) (SETQ BIT 0) (|add| OFFSET 1))))))) (SHOULDNT)))) (COND (TYPENAME (COND ((NEQ BIT 0) (\\REUSETO BITSPERWORD))) (|while| (ODDP OFFSET WORDSPERCELL) |do| (|add| OFFSET 1)) (COND ((IGREATERP OFFSET |\\MDSIncrement|) (ERROR TYPENAME "DATATYPE TOO BIG"))))) (RETURN (CONS OFFSET (MAPCAR DLIST (FUNCTION (LAMBDA (X) (|fetch| FD |of| X))))))))) (\\REUSETO (LAMBDA (N FLG) (* \; "Edited 15-Dec-92 13:46 by jds") (* |;;| "Skip over unused bits in a datatype or blockrecord declaration. Advance the bin-int-word and word-offset pointers accordingly. Complain if this isn't supposed to be allowed.") (SETQ N (IDIFFERENCE N BIT)) (COND ((NEQ N 0) (COND ((AND (NULL TYPENAME) (NOT FLG)) (ERROR "Block/datatype field not aligned properly" FD))) (|push| UNUSED (LIST OFFSET BIT N)))) (|add| BIT N) (COND ((EQ BIT 16) (SETQ BIT 0) (|add| OFFSET 1))))) (\\typeglobalvariable (lambda (typename varflg) (* \; "Edited 18-May-87 17:14 by Snow") (* |;;;| "Returns a constant or a variable that contains the datatype number of TYPENAME. It is used when compiling type tests and assigning datatypes. If TYPENAME is a system type, it returns the number. Otherwise it creates a variable name and puts it on GLOBALVARS.") (* |;;;| "This is a kludge that will go away when we have type resolution at load time.") (* |;;;| "If VARFLG is true, always returns a var, rather than a system constant. This is another kludge for backward compatibility.") (or (and (not varflg) (|for| entry |in| \\built-in-system-types |as| i |from| 1 |when| (eq typename (car entry)) |do| (return i))) (let ((var (type-variable-from-type-name typename))) (cond ((not (or (fmemb var globalvars) (getprop var 'globalvar))) (putprop var 'globalvar t))) var)))) ) (CL:DEFUN TYPE-VARIABLE-FROM-TYPE-NAME (TYPE-NAME) (* |;;;| "Convert a symbol naming a type into the unique global variable that holds the number for that type. This can be tricky during that portion of the init before packages have been turned on.") (IF (NULL *PACKAGE*) THEN (* |;;| "Packages are, indeed, not on yet. We must check the type-name symbol to see if it begins with a known init-time package prefix. If so, we strip that off and put it back on the front. The function NAMESTRING-CONVERSION-CLAUSE is from LLPACKAGE.") (LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| TYPE-NAME)) (LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| TYPE-NAME)) (FATP (|ffetch| (CL:SYMBOL FATPNAMEP) |of| TYPE-NAME)) (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP))) (COND ((NULL CLAUSE) (* \;  "TYPE-NAME is homed in the Interlisp Package. Nothing special to do.") (PACK* "" TYPE-NAME "TYPE#")) (T (* \; "The symbol matched a clause. We take the prefix off the front of the name and put it at the beginning.") (LET* ((PREFIX (CL:FIRST CLAUSE)) (PREFIX-LENGTH (FFETCH (STRINGP LENGTH) OF PREFIX))) (PACK* PREFIX "" (SUBSTRING TYPE-NAME (CL:1+ PREFIX-LENGTH)) "TYPE#"))))) ELSE (* |;;| "Packages are on; this is the normal case.") (CL:INTERN (CONCAT "" (MKSTRING TYPE-NAME) "TYPE#") (CL:SYMBOL-PACKAGE TYPE-NAME)))) (DEFINEQ (|BitFieldMask| (lambda (fd) (* \; "Edited 18-May-87 17:14 by Snow") (sub1 (llsh 1 (|BitFieldWidth| fd))))) (|BitFieldShift| (lambda (fd) (* \; "Edited 18-May-87 17:14 by Snow") (idifference 16 (iplus (|BitFieldFirst| fd) (|BitFieldWidth| fd))))) (|BitFieldShiftedMask| (lambda (fd) (* \; "Edited 18-May-87 17:15 by Snow") (idifference (llsh 1 (idifference 16 (|BitFieldFirst| fd))) (llsh 1 (idifference 16 (iplus (|BitFieldFirst| fd) (|BitFieldWidth| fd))))))) (|MakeBitField| (lambda (first width) (* \; "Edited 18-May-87 17:15 by Snow") (logor (llsh first 4) (sub1 width)))) (|BitFieldWidth| (lambda (fd) (* \; "Edited 18-May-87 17:16 by Snow") (add1 (logand fd 15)))) (|BitFieldFirst| (lambda (fd) (* \; "Edited 18-May-87 17:16 by Snow") (lrsh fd 4))) ) (DEFOPTIMIZER FETCHFIELD (&REST X) (COMPILEDFETCHFIELD X)) (DEFOPTIMIZER FFETCHFIELD (&REST X) (COMPILEDFETCHFIELD X T)) (DEFOPTIMIZER REPLACEFIELD (&REST X) (COMPILEDREPLACEFIELD X)) (DEFOPTIMIZER FREPLACEFIELD (&REST X) (COMPILEDREPLACEFIELD X T)) (DEFOPTIMIZER REPLACEFIELDVAL (&REST ARGS) (CONS '(OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE) (PROG1 DATUM (REPLACEFIELD DESCRIPTOR DATUM NEWVALUE) )) ARGS)) (DEFOPTIMIZER FREPLACEFIELDVAL (&REST ARGS) (CONS '(OPENLAMBDA (DESCRIPTOR DATUM NEWVALUE) (PROG1 DATUM (FREPLACEFIELD DESCRIPTOR DATUM NEWVALUE))) ARGS)) (DEFOPTIMIZER NCREATE (&REST X) (COMPILEDNCREATE X)) (DEFOPTIMIZER \\DTEST (VALUE TYPE &ENVIRONMENT ENV) (COND ((AND (EQ (CAR TYPE) 'QUOTE) (LITATOM (CADR TYPE))) (COND ((FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES DTEST 0 0 0 (ATOM \\\, (CADR TYPE))) ,VALUE)) ((FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES DTEST 0 0 (ATOM \\\, (CADR TYPE))) ,VALUE)) (T `((OPCODES DTEST 0 (ATOM \\\, (CADR TYPE))) ,VALUE)))) (T 'IGNOREMACRO))) (PUTPROPS \\TESTBITS DMACRO ((X N FD) (NEQ 0 (\\GETBITS X N FD)))) (DEFINEQ (compiledfetchfield (lambda (x fastflg) (* \; "Edited 18-May-87 17:32 by Snow") (cond ((eq (car (listp (car x))) 'quote) ((lambda (descriptor datum) (prog (typename) (cond ((and (not fastflg) (setq typename (|fetch| |fdTypeName| |of| descriptor))) (setq datum (list (function \\dtest) datum (kwote typename))))) (return (selectq (|fetch| |fdType| |of| descriptor) ((pointer xpointer fullpointer fullxpointer) (list '\\getbaseptr datum (|fetch| |fdOffset| |of| descriptor))) (swappedxpointer `((openlambda (d) (\\vag2 (\\getbase d ,(add1 (|fetch| |fdOffset| |of| descriptor)) ) (\\getbase d ,(|fetch| |fdOffset| |of| descriptor)))) ,datum)) (floatp `(\\getbasefloatp ,datum ,(|fetch| |fdOffset| |of| descriptor))) (fixp `(\\getbasefixp ,datum ,(|fetch| |fdOffset| |of| descriptor))) (swappedfixp `((openlambda (d) (\\makenumber (\\getbase d ,(add1 (|fetch| |fdOffset| |of| descriptor))) (\\getbase d ,(|fetch| |fdOffset| |of| descriptor) ))) ,datum)) (prog ((ft (|fetch| |fdType| |of| descriptor)) (off (|fetch| |fdOffset| |of| descriptor))) (return (selectq (car ft) (bits (list '\\getbits datum off (cdr ft))) (signedbits `(signed (\\getbits ,datum ,off ,(cdr ft)) ,(|BitFieldWidth| (cdr ft)))) (flagbits (list '\\testbits datum off (cdr ft))) (longbits `((openlambda (d) (\\makenumber (\\getbits d ,off ,(cdr ft)) (\\getbase d ,(add1 off)))) ,datum)) (shouldnt)))))))) (cadar x) (cadr x))) (t 'ignoremacro)))) (compiledreplacefield (lambda (x fastflg rplvalflg) (* \; "Edited 18-May-87 17:29 by Snow") (* |;;| "compile code for replacing field values. Goes to great length to ensure that the coerced value is returned") (cond ((eq (car (listp (car x))) 'quote) ((lambda (descriptor datum newvalue) (prog ((typename (|fetch| |fdTypeName| |of| descriptor)) (ft (|fetch| |fdType| |of| descriptor)) (offset (|fetch| |fdOffset| |of| descriptor))) (cond ((and (not fastflg) typename) (setq datum (list (function \\dtest) datum (kwote typename))))) (return (selectq ft ((pointer fullpointer) (list (function \\rplptr) datum offset newvalue)) (xpointer (list (function putbaseptrx) datum offset newvalue)) (fullxpointer (list '\\putbaseptr datum offset newvalue)) (swappedxpointer `((openlambda (d r) (\\putbase d ,offset (\\loloc r)) (\\putbase d ,(add1 offset) (\\hiloc r)) r) ,datum ,newvalue)) (fixp `(\\putbasefixp ,datum ,offset ,newvalue)) (swappedfixp `(\\putswappedfixp (\\addbase ,datum ,offset) ,newvalue)) (floatp `(\\putbasefloatp ,datum ,offset ,newvalue)) (selectq (car ft) (bits (list '\\putbits datum offset (cdr ft) newvalue)) (longbits (list (subpair '(offset ft) (list offset (cdr ft)) '(openlambda (d v) (\\putbits d offset ft (\\hinum v)) (\\putbase d (add1 offset) (\\lonum v)) v)) datum newvalue)) (signedbits `(signed (\\putbits ,datum ,offset ,(cdr ft) (unsigned ,newvalue ,(|BitFieldWidth| (cdr ft)))) ,(|BitFieldWidth| (cdr ft)))) (flagbits `(neq (\\putbits ,datum ,offset ,(cdr ft) (cond (,newvalue ,(|BitFieldMask| (cdr ft))) (t 0))) 0)) (return 'ignoremacro)))))) (cadar x) (cadr x) (caddr x))) (t 'ignoremacro)))) (compiledncreate (lambda (x) (* \; "Edited 18-May-87 17:34 by Snow") (* |;;;| "compiles code for NCREATEs. Exists to eliminate the call to \\TYPENUMBERFROMNAME.") (cond ((eq (car (listp (car x))) 'quote) (cond ((null (cadr x)) (list 'createcell (\\typeglobalvariable (cadar x)))) (t (list 'ncreate2 (\\typeglobalvariable (cadar x)) (cadr x))))) (t 'ignoremacro)))) ) (DECLARE\: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE\: EVAL@COMPILE (RECORD |FldDsc| (|fdTypeName| |fdOffset| |fdType|)) ) (* "END EXPORTED DEFINITIONS") ) (RPAQQ DATATYPEFIELDTYPES ((FLOATP 0.0) (FIXP 0) (SWAPPEDFIXP 0) (POINTER NIL) (XPOINTER NIL) (FULLPOINTER NIL) (FULLXPOINTER NIL) (SWAPPEDXPOINTER NIL) (FLAG NIL) (BYTE 0) (WORD 0) (SIGNEDWORD 0))) (* \; "Macros which convert a record access form into an address-generating form") (DECLARE\: EVAL@COMPILE (PUTPROPS LOCF DMACRO (X (TRANSLATE.LOCF X))) (PUTPROPS INDEXF DMACRO (X (TRANSLATE.LOCF X T))) ) (DEFINEQ (translate.locf (lambda (args indexonly) (* \; "Edited 18-May-87 17:35 by Snow") (declare (globalvars clisparray)) (prog ((form (mkprogn args)) newform offset spec) retry (selectq (car (listp form)) (progn (cond ((not (cddr form)) (* \;  "get rid of extra PROGN's inserted by record package") (setq form (cadr form)) (go retry)))) ((fetchfield ffetchfield) (cond ((and (setq offset (listp (cadr form))) (eq (car offset) 'quote) (setq offset (cadr (setq spec (cadr offset)))) (fixp offset)) (return (cond (indexonly offset) ((eq offset 0) (caddr form)) (t (setq form (caddr form)) (* |;;| "loop in order to merge \\ADDBASEs. Should actually be done by compiler optimization, but apparently that is currently broken") (|repeatwhile| (selectq (car (listp form)) (progn (cond ((null (cddr form)) (setq form (cadr form)) t))) ((addbase \\addbase) (cond ((fixp (caddr form)) (|add| offset (caddr form)) (setq form (cadr form)) t))) (cond ((neq (setq newform (cl:macroexpand-1 form)) form) (setq form newform) t)))) (list '\\addbase form offset))))))) (cond ((neq form (setq form (cl:macroexpand-1 form))) (go retry)))) (error "LOCF Can't figure out this argument" args) (return 'ignoremacro)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS DTDECLARE FILETYPE CL:COMPILE-FILE) (PUTPROPS DTDECLARE COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990 1992 1995)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1518 17273 (/DECLAREDATATYPE 1528 . 2111) (DECLAREDATATYPE 2113 . 3743) ( TRANSLATE.DATATYPE 3745 . 15504) (\\REUSETO 15506 . 16182) (\\TYPEGLOBALVARIABLE 16184 . 17271)) ( 19148 20420 (|BitFieldMask| 19158 . 19334) (|BitFieldShift| 19336 . 19574) (|BitFieldShiftedMask| 19576 . 19920) (|MakeBitField| 19922 . 20108) (|BitFieldWidth| 20110 . 20268) (|BitFieldFirst| 20270 . 20418)) (22610 30173 (COMPILEDFETCHFIELD 22620 . 25902) (COMPILEDREPLACEFIELD 25904 . 29637) ( COMPILEDNCREATE 29639 . 30171)) (30889 33863 (TRANSLATE.LOCF 30899 . 33861))))) STOP \ No newline at end of file diff --git a/sources/DWIM b/sources/DWIM new file mode 100644 index 00000000..79e4b155 --- /dev/null +++ b/sources/DWIM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "25-Feb-91 12:14:19" |{PELE:MV:ENVOS}SOURCES>DWIM.;3| 45595 changes to%: (VARS DWIMCOMS) (FNS COMPILEUSERFN compilation) previous date%: "16-May-90 16:20:03" |{PELE:MV:ENVOS}SOURCES>DWIM.;2|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT DWIMCOMS) (RPAQQ DWIMCOMS [(FNS DWIM NEWFAULT1 CHECKTRAN) (VARS DWIMODELST (DWIMWAIT 10) (LCASEFLG T)) (FNS RETDWIM2 RETDWIM3 FIXATOM2 SPLIT89 WTFIXLOADEF CLISP% ) (COMS (FNS VARSBOUNDINEDITCHAIN VARSBOUNDINFORM) (BLOCKS (VARSBOUNDINEDITCHAIN VARSBOUNDINEDITCHAIN VARSBOUNDINFORM))) (FNS DWIMLOADFNS?) (APPENDVARS (DWIMUSERFORMS (DWIMLOADFNS?))) (VARS (DWIMLOADFNSFLG T)) (FNS CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 CLISPERROR CLISPDEC CLISPDEC0 CLISPDEC1 GETLOCALDEC) (FNS COMPILEUSERFN COMPILEUSERFN1 USEDFREE CLISPTRAN compilation) (FNS CLISPFORERR CLISPFORERR1 I.S.OPR WARNUSER) (DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (NLAML BREAK1))) (BLOCKS (NEWFAULT1BLOCK NEWFAULT1 CHECKTRAN (ENTRIES NEWFAULT1) (GLOBALVARS %#CLISPARRAY) (NOLINKFNS WTFIX)) (CLISPLOOKUP0 CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 (GLOBALVARS DECLWORDS CLISPRECORDTYPES CLISPTRANFLG) (LOCALFREEVARS WORD CLASS CLASSDEF VAR1 VAR2)) (CLISPDECBLOCK CLISPDEC CLISPDEC0 CLISPDEC1 GETLOCALDEC (GLOBALVARS CLISPRECORDTYPES DECLWORDS CLISPARITHOPLST CLISPARITHCLASSLST COMMENTFLG SKORLST1) (ENTRIES CLISPDEC CLISPDEC0 GETLOCALDEC) (LOCALFREEVARS FAULTFN))) (GLOBALVARS DWIMODELST DWIMKEYLST DWIMWAIT LCASEFLG CLISPFORWORDSPLST I.S.OPRLST SKORLST3 DWIMLOADFNSFLG CLISPTRANFLG CLISPARRAY %#CLISPARRAY) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA USEDFREE CLISP% ) (NLAML) (LAMA FIXATOM2]) (DEFINEQ (DWIM [LAMBDA (X) (* wt%: "22-OCT-78 21:02") (COND ((NULL X) (/PUTD 'FAULT1 (GETD 'OLDFAULT1)) (/SETATOMVAL 'DWIMFLG NIL) (/SETATOMVAL 'ADDSPELLFLG NIL)) ((SETQ X (ASSOC X DWIMODELST)) (/PUTD 'FAULT1 (GETD 'NEWFAULT1)) (/SETATOMVAL 'DWIMFLG T) (/SETATOMVAL 'ADDSPELLFLG T) [MAPC (CDDR X) (FUNCTION (LAMBDA (X) (AND (LISTP X) (SET (CAR X) (CDR X] (CADR X)) (T (ERROR '"not on DWIMODELST." '"" T]) (NEWFAULT1 [LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG) (* lmm " 1-SEP-83 17:40") (* Replaces FAULT1) (PROG [(FAULTZ (if FAULTAPPLYFLG then FAULTX elseif (LISTP FAULTX) then (CAR FAULTX] (if [AND FAULTZ (LITATOM FAULTZ) (GETD FAULTZ) (SETQ FAULTZ (CHECKTRAN (GETD FAULTZ] then (if FAULTAPPLYFLG then (GO RETAPPLY) else (SETQ FAULTZ (CONS FAULTZ (CDR FAULTX))) (GO RETEVAL))) (* Covers the case where an atom has a definition that has a clisp translation,  e.g. FOO is defined as (QLAMBDA --) There are two cases, FOO  (args) and (FOO args)) (if (LISTP FAULTX) then (if (SETQ FAULTZ (CHECKTRAN FAULTX)) then (* Covers the case where the form has a clis translation itself,  (most common)%, and the case where faultx is a function object being applied  and has a clisptranslation.) (if FAULTAPPLYFLG then (GO RETAPPLY) else (GO RETEVAL))) (if (AND (NULL FAULTAPPLYFLG) (LISTP FAULTX) (LISTP (SETQ FAULTZ (CAR FAULTX))) (SETQ FAULTZ (CHECKTRAN FAULTZ))) then (* Covers the case where car of form is a function objection with a clisp  translation, e.g. ((QLAMBDA --) --)) (SETQ FAULTZ (CONS FAULTZ (CDR FAULTX))) (GO RETEVAL))) (SETQ FAULTZ (WTFIX FAULTX FAULTARGS FAULTAPPLYFLG)) (* info for diagnostic printed by  original FAULT1.) (RETURN (OLDFAULT1 FAULTX FAULTARGS FAULTAPPLYFLG FAULTZ)) RETAPPLY (RETAPPLY (FUNCTION FAULTAPPLY) FAULTZ FAULTARGS T 'INTERNAL) RETEVAL (RETEVAL 'FAULTEVAL FAULTZ]) (CHECKTRAN [LAMBDA (X) (* lmm "10-MAR-83 22:37") (DECLARE (GLOBALVARS %#CLISPARRAY CLISPARRAY CLISPTRANFLG)) (OR (AND CLISPARRAY (GETHASH X CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR X) CLISPTRANFLG) (PROG1 (CADR X) (COND ((OR CLISPARRAY %#CLISPARRAY) (CLISPTRAN X (CADR X)) (/RPLNODE X (CADDR X) (CDDDR X]) ) (RPAQQ DWIMODELST ((C CAUTIOUS (APPROVEFLG . T)) (T TRUSTING (APPROVEFLG)))) (RPAQQ DWIMWAIT 10) (RPAQQ LCASEFLG T) (DEFINEQ (RETDWIM2 [LAMBDA (X $TAIL N M) (* wt%: 25-FEB-76 2 3) (* N is a printlevel affecting TAILS, M one affecting elementens.  Value is a copy of X as though printed with these levels.) (AND (NULL N) (SETQ N 3)) (AND (NULL M) (SETQ M 1)) (RETDWIM3 X $TAIL N M]) (RETDWIM3 [LAMBDA (X $TAIL N1 M1) (* wt%: 25-FEB-76 2 3) (COND ((NLISTP X) X) ((ILESSP M1 0) '&) (T (CONS (RETDWIM3 (CAR X) NIL N1 (SUB1 M1)) (COND [$TAIL (COND ((EQ X $TAIL) (* Only begin counting down when you  reach TAIL.) (RETDWIM3 (CDR X) NIL (SUB1 N1) M1)) (T (RETDWIM3 (CDR X) $TAIL N1 M1] ((IGREATERP N1 0) (RETDWIM3 (CDR X) $TAIL (SUB1 N1) M1)) ((CDR X) '(--]) (FIXATOM2 [LAMBDA X (* Value is the last argument on the  stack.) (ARG X X]) (SPLIT89 [LAMBDA (N POS) (* Generates command that replaces atoms containing 8 or 9 with the  corresponding atom or atoms separated by the 8 or 9 so macro calling it can  determine where to insert or remove parentheses.) (PROG (X Y Z) (SETQ X (DUNPACK (CAR L) SKORLST3)) [SETQ Y (COND (POS (SETQ Y (NLEFT X POS))) (T (FMEMB N X] [COND ((NULL Y) (* User has already corrected atom containing 8 or 9 Now we must guess what  form it is. Assume if N is 8, was error of form 8CONS, if 9, X9) (RETURN (LIST (COND ((EQ N 8) 'B) (T 'A)) N] [COND ((CDR Y) (SETQ Z (CONS (PACK (CDR Y)) Z] (SETQ Z (CONS N Z)) [COND ((NEQ Y X) (SETQ Z (CONS (PACK (LDIFF X Y)) Z] (SETQ SPLIT89FLG Z) (RETURN (CONS '%: Z]) (WTFIXLOADEF [LAMBDA (FAULTEM1) (* ; "Edited 5-Apr-88 16:04 by amd") (* ;; "FAULTEM1 is the value of the FILEDEF property.") (PROG (FAULTEM2 FAULTEM3) (SETQ FAULTFN NIL) (* ;  "So file package wont try to update it") (RETURN (COND ((AND DWIMIFYFLG DWIMIFYING)) ([NULL (SETQ FAULTEM2 (OR (FINDFILE (PACKFILENAME 'BODY [SETQ FAULTEM2 (COND ((ATOM FAULTEM1) (* ;  "FAULTEM1 is the name of the file.") FAULTEM1) (T (* ;  "(CAR FAULTEM1) is the name of the file. CDR is the list of functions.") (PROG1 (CAR FAULTEM1) (SETQ FAULTEM1 (CDR FAULTEM1] 'EXTENSION FASL.EXT) T) (FINDFILE (PACKFILENAME 'BODY FAULTEM2 'EXTENSION COMPILE.EXT) T] (* ;  "If file isnt there don't bother to ask.") NIL) ((COND ((OR (ATOM FAULTEM1) (NLISTP (CAR FAULTEM1))) (EQ (ASKUSER DWIMWAIT 'Y (LIST '"Shall I load " FAULTEM1) DWIMKEYLST) 'Y)) ([STRINGP (SETQ FAULTEM3 (EVAL (PROG1 (CAR FAULTEM1) (SETQ FAULTEM1 (CDR FAULTEM1] (* ;; "(CAR FAULTEM1) computes either a string to be typed, or T or NIL, meaning do it or dont do it. not sure if this is being used aaymore") (FIXSPELL1 '"" FAULTEM3 '"" NIL 'MUSTAPPROVE)) (T FAULTEM3)) [COND ((ATOM FAULTEM1) (LOAD FAULTEM2 'SYSLOAD)) (T (LOADFNS FAULTEM1 FAULTEM2 'SYSLOAD] T]) (CLISP%  [NLAMBDA CLISPX (PROG (CLISPTEM) [COND ((AND (OR CLISPARRAY %#CLISPARRAY) (EQ [CAR (SETQ CLISPTEM (PROG1 (BLIPVAL 'EVAL (SETQ CLISPTEM (STKNTH -1 CLISPTRANFLG)) ) (RELSTK CLISPTEM] CLISPTRANFLG) (EQ (CDR CLISPTEM) CLISPX)) (CLISPTRAN CLISPTEM (CADR CLISPTEM)) (/RPLNODE CLISPTEM (CADDR CLISPTEM) (CDDDR CLISPTEM] (RETURN (EVAL (CAR CLISPX) 'INTERNAL]) ) (DEFINEQ (VARSBOUNDINEDITCHAIN [LAMBDA (EDITCHAIN) (* lmm "27-FEB-83 10:55") (* Climbs EDITCHAIN and makes list of all bound variabes.  Sets EXPR to the top level expression, i.e.  (CAR (LAST EDITCHAIN))) (MAPCONC EDITCHAIN (FUNCTION VARSBOUNDINFORM]) (VARSBOUNDINFORM [LAMBDA (FORM) (* lmm "23-JUL-83 22:27") (DECLARE (GLOBALVARS LAMBDASPLST COMPILERMACROPROPS)) (PROG ((FN (CAR FORM)) TEM MACRO) (RETURN (AND (LITATOM FN) (COND ((FMEMB FN LAMBDASPLST) (APPEND (ARGLIST FORM))) [(EQMEMB 'BINDS (GETPROP FN 'INFO)) (MAPCAR (CADR FORM) (FUNCTION (LAMBDA (X) (COND ((NLISTP X) X) (T (CAR X] ((EQ [CAR (LISTP (SETQ TEM (GETPROP FN 'CLISPWORD] 'FORWORD) (PROG ((TAIL FORM) VAL INVAR ELT) FORWORDLP (SETQ INVAR (SELECTQ (CDR TEM) ((for bind as) T) NIL)) LP (OR (SETQ TAIL (CDR TAIL)) (RETURN VAL)) (SETQ ELT (CAR TAIL)) [COND ((NOT (LITATOM ELT)) [COND ((AND INVAR (EQ (CADR (LISTP ELT)) '_)) (SETQ VAL (CONS (CAR ELT) VAL] (GO LP)) ((EQ [CAR (LISTP (SETQ TEM (GETPROP ELT 'CLISPWORD] 'FORWORD) (GO FORWORDLP)) ((EQ ELT '_) (SETQ TAIL (CDR TAIL))) (INVAR (SETQ VAL (CONS ELT VAL] (GO LP))) ((SETQ TEM (CHECKTRAN FORM)) (VARSBOUNDINFORM TEM)) ((AND (SETQ TEM (GETLIS FN COMPILERMACROPROPS)) (NOT (EQUAL (SETQ TEM (MACROEXPANSION FORM (CADR TEM))) FORM))) (VARSBOUNDINFORM TEM]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: VARSBOUNDINEDITCHAIN VARSBOUNDINEDITCHAIN VARSBOUNDINFORM) ) (DEFINEQ (DWIMLOADFNS? [LAMBDA NIL (* wt%: "27-SEP-79 18:15") (PROG [TEM (FN (COND (FAULTAPPLYFLG FAULTX) (T (CAR FAULTX] (RETURN (COND ((AND DWIMLOADFNSFLG (NULL (AND DWIMIFYFLG DWIMIFYING)) (LITATOM FN) (NULL (FGETD FN)) (SETQ TEM (EDITLOADFNS? FN)) (OR (EQ (CAR (SETQ TEM (LOADFNS (LISPXPRINT FN T T) TEM))) FN) (PROGN (LISPXPRINT (CAR TEM) T) NIL))) [AND (NULL TYPE-IN?) (SETQ SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] FAULTX]) ) (APPENDTOVAR DWIMUSERFORMS (DWIMLOADFNS?)) (RPAQQ DWIMLOADFNSFLG T) (DEFINEQ (CLISPLOOKUP0 [LAMBDA (WORD VAR1 VAR2 DECLST LISPFN CLASS CLASSDEF) (* lmm " 5-SEP-83 23:53") (* LISPFN is returned if no local declaration is found affecting FN.  CLASS is the CLASS for FN, e.g. RPLACA, +, MEMB, etc.  CLASS is supplied when looking up local record declaration  (in his case it is RECORD) or when looking up a local value for a variable,  such as VARDEFAULT ina pattern match, in which case it is VALUE.) (* To define a new class of functions a la RPLACA, FRPLACA, and /RPLACA, one  must add all three names to DECLWORDS, put the name of the standard one on the  property lits of each under property CLISPCLASS, and put under the standard one  on property CLISPCLASSDEF the property (ACCESS standard undoable fast) version,  where undoable or fast can be NIL. Then CLISPDEC STANDARD, UNDOABLE, or FAST  will have the right effect, and calling CLISPLOOKUP on the names of either of  the functions will eturn the current "Setting" %.) (PROG (TEM) [COND ((OR (NULL DECLST) (NULL CLASS)) (* CLISPLOOKUP0 is always supposed to be called with a non-NIL CLASS and  DECLST.) (SHOULDNT 'CLISPLOOKUP0] [OR CLASSDEF (SETQ CLASSDEF (GETPROP CLASS 'CLISPCLASSDEF] (SETQ VAR1 (CLISPLOOKUP2 VAR1)) (SETQ VAR2 (CLISPLOOKUP2 VAR2)) (RETURN (COND ((SETQ TEM (CLISPLOOKUP1 DECLST)) TEM) (T (* The last GETP in the OR below %, i.e.  for CLASS, is so we dont have to implement global declaraions by puttig a  LISPFN property on each member of the class.) (SELECTQ CLASS (VALUE (GETATOMVAL WORD)) ((RECORD RECORDFIELD) NIL) (OR LISPFN (GETPROP WORD 'LISPFN) (GETPROP CLASS 'LISPFN) WORD]) (CLISPLOOKUP1 [LAMBDA (LST) (* lmm "23-Aug-84 17:56") (* Searches LST for a delcaration releveant to CLASS, which is equal to  (GETP WORD (QUOTE CLISPCLASS.))) (PROG (TEM VAL) LP (COND ((NULL LST) (RETURN VAL)) [(LISTP (SETQ TEM (CAR LST))) (AND CLISPTRANFLG (EQ (CAR TEM) CLISPTRANFLG) (SETQ TEM (CDDR TEM))) (COND [(EQ (CADR TEM) '=) (AND (EQ CLASS 'VALUE) (EQ (CAR TEM) WORD) (SETQ VAL (CADDR TEM] [(OR (EQ CLASS 'RECORD) (EQ CLASS 'RECORDFIELD)) (AND (FMEMB (CAR TEM) CLISPRECORDTYPES) (COND ((EQ CLASS 'RECORDFIELD) (FMEMB WORD (RECORDFIELDNAMES TEM))) (T (EQ WORD TEM))) (SETQ VAL (CAR LST] ((EQ (CAR TEM) CLASS) (* So user can look up his own %'classes', e.g.  say (CLISP%: (FOOTYPE)) and then look up FOOTYPE.  Terry uses this.) (SETQ VAL (CAR LST))) ([AND (OR (EQ (SETQ TEM (CAAR LST)) VAR1) (EQ TEM VAR2)) (SETQ TEM (CLISPLOOKUP1 (CDAR LST] (RETURN TEM] [[ATOM (SETQ TEM (GETPROP (CAR LST) 'CLISPCLASS] (* E.g. WORD is FRPLACA CLASS is RPLACA, and  (CAR LST) is /RPLACA. TEM is also RPLACA.) (AND (EQ TEM CLASS) (SETQ VAL (CAR LST] ([AND (EQ (CAR TEM) (CAR CLASSDEF)) (SETQ TEM (CAR (NTH (CDR CLASSDEF) (CDR TEM] (* E.G. WORD is FRPLACA and (CAR LST) is FAST.  or WORD is + and (CAR LST) is FLOATING. The eason for checking that the nth  element is not nil is that FAST does not apply to NCONC, even though both are  ACCESS type declarations, similaly, undoable does not apply to LAST.) (SETQ VAL TEM))) LP1 (SETQ LST (CDR LST)) (GO LP]) (CLISPLOOKUP2 [LAMBDA (X) (COND ((NLISTP X) X) ((OR (EQ (CAR X) 'SETQ) (EQ (CAR X) 'SETQQ)) (CADR X)) ((EQ (CADR X) '_) (CAR X]) (CLISPERROR [LAMBDA (TYPE FLG) (* wt%: " 1-OCT-78 00:22") (COND (FLG (EVQ FAULTFN) (EVQ PARENT) (EVQ TAIL) (EVQ TYPE-IN?))) (AND (NULL DWIMESSGAG) (NEQ TYPE 'ALREADYPRINTED) (PROG (TEM AT IN) (COND ((NULL TYPE-IN?) (FIXPRINTIN FAULTFN) (LISPXSPACES 1 T))) (LISPXPRIN1 (SELECTQ [SETQ TEM (COND ((ATOM TYPE) TYPE) (T (CAR TYPE] (1 '"missing operand") (2 '"missing operator") ((%: :%: -> =>) (LISPXPRIN1 '"improper use of " T) TEM) (4 '"bad if statement") (_ '"incorrect use of _") (FIELDNAME '"undefined field name") (PHRASE '"can't parse this phrase") (CARATOM '"car or cdr of non-list taken") (COND ((EQ (CAR (LISTP TEM)) 'BRACKET) (LISPXPRIN1 '"missing " T) (CADR TEM)) (T TEM))) T) (COND ((LISTP TYPE) (GO A)) ((NEQ PARENT TAIL) (LISPXPRIN1 '" at " T) (LISPXPRIN2 (RETDWIM2 (CAR TAIL)) T T))) (LISPXPRIN1 '" in " T) (LISPXPRIN2 (RETDWIM2 (OR PARENT FAULTX) TAIL) T T) (LISPXTERPRI T) (RETURN) A (SETQ AT (CADR TYPE)) (SETQ IN (CADDR TYPE)) (COND ((OR (EQ AT IN) (NULL IN)) (LISPXPRIN1 '" in " T) (LISPXPRINT (RETDWIM2 AT) T T) (RETURN))) (LISPXTERPRI T) (LISPXPRIN1 '"at " T) (MAPRINT (RETDWIM2 AT (CDDR AT)) T '"... " '%) NIL NIL T) (LISPXTERPRI T) (LISPXPRIN1 '"in " T) (LISPXPRINT (RETDWIM2 IN) T T) (RETURN]) (CLISPDEC [LAMBDA (DECLST) (* wt%: "10-AUG-78 00:31") (* Does global declaratin) (AND DECLST (ATOM DECLST) (SETQ DECLST (LIST DECLST))) (PROG ((LST DECLST) TEM CLASSDEF) TOP (COND ((NULL LST) (RETURN DECLST))) (COND [(LISTP (CAR LST)) (COND ((FMEMB (CAAR LST) CLISPRECORDTYPES) (EVAL (CAR LST))) (T (GO ERROR] [(FMEMB (CAR LST) CLISPARITHCLASSLST) (MAPC CLISPARITHOPLST (FUNCTION (LAMBDA (X) (* E.g. X IS *, /, +, ETC.) (COND ((SETQ TEM (GETPROP X 'LISPFN)) (* May have been disabled) (/REMPROP TEM 'CLISPINFIX) (COND ([SETQ TEM (CAR (NTH [CDR (OR (GETPROP X 'CLISPCLASSDEF) (GETPROP (GETPROP X 'CLISPCLASS) 'CLISPCLASSDEF] (CDR (GETPROP (CAR LST) 'CLISPCLASS] (/PUT X 'LISPFN TEM) (* E.G. CLISPCLASS for FLOATING is (ARITH . 2)%, for * is  (ARITH ITIMES FTIMES TIMES) meaning the FLOATING version for * is FTIMES.) (/PUT TEM 'CLISPINFIX X] [(SETQ CLASSDEF (GETPROP (CAR LST) 'CLISPCLASS)) (COND [(LISTP CLASSDEF) (* e.g. clipdec (fast)) (MAPC DECLWORDS (FUNCTION (LAMBDA (X) (COND ([AND [EQ (CAR CLASSDEF) (CAR (SETQ TEM (GETPROP X 'CLISPCLASSDEF] (SETQ TEM (CAR (NTH (CDR TEM) (CDR CLASSDEF] (/PUT X 'LISPFN TEM] (T (* e.g. clispdec (fassoc)) (/PUT CLASSDEF 'LISPFN (CAR LST] [(FMEMB (CAR LST) DECLWORDS) (COND ([ATOM (SETQ TEM (GETPROP (CAR LST) 'CLISPCLASS] (/PUT TEM 'LISPFN (CAR LST))) (T (GO ERROR] ((SETQ TEM (OR (PROG (TYPE-IN? FAULTFN) (RETURN (FIXSPELL (CAR LST) NIL DECLWORDS))) (GO ERROR))) (/RPLNODE LST TEM (CDR LST)) (GO TOP))) (SETQ LST (CDR LST)) (GO TOP) ERROR (ERROR '"illegal declaration" (CAR LST]) (CLISPDEC0 [LAMBDA (X FN) (* wt%: 29-JUL-76 20 56) (/RPLNODE X COMMENTFLG (CONS 'DECLARATIONS%: (CLISPDEC1 (CDR X) FN))) (CDDR X]) (CLISPDEC1 [LAMBDA (X FAULTFN) (* wt%: "13-JUN-78 17:31") (MAPCON X (FUNCTION (LAMBDA (X) (PROG (TEM TYPE-IN?) TOP (RETURN (COND [(LISTP (CAR X)) (LIST (COND ((OR (EQ (CADAR X) '=) (FMEMB (CAAR X) CLISPRECORDTYPES) (EQ (CAAR X) 'RECORDS)) (CAR X)) (T (CONS (CAAR X) (CLISPDEC1 (CDAR X] ((FMEMB (CAR X) DECLWORDS) (LIST (CAR X))) ((FIXSPELL (CAR X) NIL DECLWORDS NIL X NIL NIL NIL (DUNPACK (CAR X) SKORLST1)) (GO TOP)) (T (ERROR '"illegal declaration" (CAR X]) (GETLOCALDEC [LAMBDA (EXPR FN) (* lmm "26-Sep-84 16:38") (AND (LISTP EXPR) (COND ((FMEMB (CAR EXPR) LAMBDASPLST) (for (TL _ (CDDR EXPR)) by (CDR TL) while TL bind X when (LISTP (SETQ X (CAR TL))) do (SELECTQ (CAR X) (BREAK1 (SETQ TL (CADR X))) (ADV-PROG [SETQ TL (CADR (CAR (LAST (CADDR (CADDR X]) (COND ((AND (EQ (CAR X) COMMENTFLG) (EQ (CADR X) 'DECLARATIONS%:)) (RETURN (CDDR X))) [(EQ (CAR X) 'CLISP%:) (RETURN (CLISPDEC0 X (OR FN FAULTFN] ((FMEMB (CAR X) '(DECLARE DECLARE%:)) (RETURN (for Y in (CDR X) do [COND ((EQ (CAR Y) 'CLISP%:) (RETURN (CDR Y] (COND ((AND (EQ (CAR Y) COMMENTFLG) (EQ (CADR Y) 'DECLARATIONS%:)) (RETURN (CDDR Y]) ) (DEFINEQ (COMPILEUSERFN [LAMBDA (X Y) (* ; "Edited 25-Feb-91 12:13 by jds") (* * this is an awful patch to fix the fact that COMPILEUSERFN1 is UNIONing  something with OTHERVARS, which is an unbound specvar) (OR (BOUNDP 'OTHERVARS) (SETQ OTHERVARS NIL)) (PROG (TEM) (RETURN (COND ((CHECKTRAN Y)) [(LISTP (CAR Y)) (COND ((SETQ TEM (CHECKTRAN (CAR Y))) (CONS TEM (CDR Y))) (DWIMFLG (COMPILEUSERFN1 Y) (COND ((CHECKTRAN Y)) ((SETQ TEM (CHECKTRAN (CAR Y))) (CONS TEM (CDR Y] ([AND (NLISTP (GETPROP (CAR Y) 'CLISPWORD)) (NOT (AND (FMEMB (CAR Y) LAMBDASPLST) (NOT (FMEMB (CAR Y) '(LAMBDA NLAMBDA] NIL) (DWIMFLG (COMPILEUSERFN1 Y) (COND ((AND CLISPARRAY (GETHASH Y CLISPARRAY))) ((AND CLISPTRANFLG (EQ (CAR Y) CLISPTRANFLG)) (CADR Y)) ((NULL (GETPROP (CAR Y) 'CLISPWORD)) (* IF's are transled directly into  COND's, and dont use hashing.) Y) ((NULL DWIMESSGAG) (* user can set DWIMESSGAG to T and go away and the compilation will go  through.) (PRIN1 '"unable to dwimify " T) (PRINT Y T) (CAR (NLSETQ (compilation Y]) (COMPILEUSERFN1 [LAMBDA (Y) (* lmm "19-Jun-86 13:59") (PROG [(FLG (AND (LISTP COREFLG) (CDR (FASSOC FN COREFLG] (LET ((NOSPELLFLG (OR NOSPELLFLG (NULL FLG))) (FILEPKGFLG (AND FILEPKGFLG FLG))) (* FILEKGFLG is T when when compiling from in core, so that if function is  changed, it will be marked.) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (DWIMIFY0 Y FN (UNION ARGS OTHERVARS) DEF) (COND ((TAILP NOFIXFNSLST NOFIXFNSLST0) (* For purposes of compilation, want anything added to NOFIXFNSLST0 to persist  throughout copiling the whole file.) (SETQ NOFIXFNSLST NOFIXFNSLST0))) (COND ((TAILP NOFIXVARSLST NOFIXVARSLST0) (SETQ NOFIXVARSLST NOFIXVARSLST0]) (USEDFREE [NLAMBDA A (* wt%: "20-SEP-77 22:10") (* permits the user to declare freevars which will then be "noticed" by dwimify  in thatthey wont be spelling corrected.) (SETQ FREEVARS (APPEND A FREEVARS]) (CLISPTRAN [LAMBDA (X TRAN) (* bvm%: "21-Jan-86 00:41") (COND ((OR CLISPARRAY (COND (%#CLISPARRAY (SETQ CLISPARRAY (HASHARRAY %#CLISPARRAY NIL NIL NIL T)) (SETQ %#CLISPARRAY NIL) (* Latter so user can turn clisphashing on and off by simply reseting  CLISPARRAY.) T))) (* Otherwise use CLISP% translation.) (/PUTHASH X TRAN CLISPARRAY)) (TRAN (* Can be called erase a translation.) (/RPLNODE X CLISPTRANFLG (CONS TRAN (CONS (CAR X) (CDR X]) (compilation [LAMBDA (EXP) (BREAK1 EXP T compilation]) ) (DEFINEQ (CLISPFORERR [LAMBDA (X Y TYPE) (* lmm " 4-SEP-83 22:56") (AND (NULL DWIMESSGAG) (PROG (TEM) (AND (FIXPRINTIN FAULTFN) (SPACES 1 T)) (LISPXPRIN1 '"error in iterative statement" T) (AND TYPE (LISPXPRINT '%, T) (LISPXPRIN1 (SELECTQ TYPE (BOTH '"can't use both of these operators together") (TWICE '"operator appears twice") (MISSING '"missing operand") (WHAT (LISPXPRIN1 (CADR X) T) '" what ? (no i.v. specified)") NIL) T)) (LISPXPRINT '%: T) (COND ((OR (AND X (NLISTP X)) (AND Y (NLISTP Y))) (LISPXPRIN2 X T T) (AND Y (LISPXPRIN2 Y T T)) (RETURN)) ((TAILP X Y) (SETQ TEM X) (SETQ X Y) (SETQ Y TEM))) (CLISPFORERR1 X Y) (COND (Y (LISPXSPACES 1 T) (CLISPFORERR1 Y))) (TERPRI T) (RETURN))) (DWIMERRORRETURN]) (CLISPFORERR1 [LAMBDA (X Y) (* wt%: 25-MAR-77 22 58) (PROG (TEM) (COND ((NEQ X I.S.) (LISPXPRIN1 '" ... " T))) (SETQ TEM (OR [CADADR (SOME I.S.PTRS (FUNCTION (LAMBDA (Z) (TAILP (CADR Z) X] Y)) LP (LISPXPRIN2 (RETDWIM2 (CAR X) NIL 3) T T) (COND ((AND (SETQ X (CDR X)) (NEQ X TEM)) (LISPXSPACES 1 T) (GO LP]) (I.S.OPR [LAMBDA (NAME FORM OTHERS EVALFLG) (* wt%: "18-SEP-78 23:22") (* E.g. NAME=SUM, FORM= (SETQ $$VAL ($$VAL + BODY))%, OTHERS=  (FIRST $$VAL_0) I f evalflg is T, means form and others are to be EVALUATED at  translation time.) (PROG ((UC (U-CASE NAME)) LC NEWPROP OLDPROP NEWFLG) [COND ((NEQ NAME UC) (* LC is the name used for clispifying. for mostcases it is the lower case, but  thi check lets users define i.s.oprs contaiing some lowercase and some  uppercase letters) (SETQ LC NAME)) (T (SETQ LC (L-CASE NAME] (* so tha user can call it with either loer or uppercase version.) (SETQ NEWFLG (NEQ (CAR (GETP LC 'CLISPWORD)) 'FORWORD)) (COND ((AND FORM (ATOM FORM) (NEQ FORM 'MODIFIER)) (* Synonym) (/PUT UC 'CLISPWORD (SETQ NEWPROP (LIST 'FORWORD LC FORM))) (SETQ OLDPROP (GETP LC 'CLISPWORD)) (/PUT LC 'CLISPWORD NEWPROP) (/REMPROP LC 'I.S.OPR)) ((AND OTHERS (NLISTP OTHERS) (NULL EVALFLG)) (ERROR "OTHERS must be a list of operators and operands" OTHERS)) ((AND OTHERS (NEQ (CAR (GETPROP (CAR OTHERS) 'CLISPWORD)) 'FORWORD) (NULL EVALFLG)) (ERROR '"OTHERS must begin with an operator" OTHERS)) (T (/PUT UC 'CLISPWORD (SETQ NEWPROP (CONS 'FORWORD LC))) (/PUT LC 'CLISPWORD NEWPROP) [SETQ NEWPROP (COND ((EQ FORM 'MODIFIER) 'MODIFIER) [EVALFLG (CONS (AND FORM (CONS '= FORM)) (AND OTHERS (CONS '= OTHERS] (T (CONS FORM OTHERS] (SETQ OLDPROP (GETP LC 'I.S.OPR)) (/PUT LC 'I.S.OPR NEWPROP))) [COND ((EQUAL NEWPROP OLDPROP) (RETURN NAME)) [(NULL NEWFLG) (* redefined) [COND ((EQ UC 'COLLECT) (/REMPROP 'fcollect 'I.S.OPR] (AND (NEQ DFNFLG T) (LISPXPRINT [CONS 'i.s.opr (CONS NAME '(redefined] T)) (AND CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION (LAMBDA (TRAN EXP) (AND (OR (MEMB UC EXP) (MEMB LC EXP)) (/PUTHASH EXP NIL CLISPARRAY] (T (* defined for the first time) (/NCONC1 CLISPFORWORDSPLST UC) (/NCONC I.S.OPRLST (LIST UC LC] (AND FILEPKGFLG (MARKASCHANGED (COND ((EQ NAME UC) UC) (T (* file package doesnt care whether you give upper or lower case named to  dumpi.s.oprs, however if user took pains to define thi i.ssop giving it a  owercase definition, (Or mixed upper and lower case) then inform him about this  i.s.opr in that fashion.) LC)) 'I.S.OPRS NEWFLG)) (RETURN NAME]) (WARNUSER [LAMBDA (X) (* wt%: "24-MAR-80 08:23") [SOME PROGVARS (FUNCTION (LAMBDA (VAR) (COND ((EDITFINDP (CADR X) (COND ((LISTP VAR) (CAR VAR)) (T VAR))) (PROG (TEM) (LISPXPRIN1 "****Warning: the iterative statement: " T) (LISPXPRIN2 (RETDWIM2 EXP NIL 8 2) T) (LISPXPRIN1 " now translates so that " T) (CLISPFORERR1 X T) (LISPXPRIN1 " ... is evaluated BEFORE " T) (COND ((LISTP VAR) (LISPXPRIN2 (CAR VAR) T) (LISPXPRIN1 " is bound and initialized to: " T) (LISPXPRIN2 (RETDWIM2 (CADR VAR) 3) T)) (T (LISPXPRIN1 " it is bound" T))) (LISPXTERPRI T)) T] (CADR X]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (ADDTOVAR NLAML BREAK1) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NEWFAULT1BLOCK NEWFAULT1 CHECKTRAN (ENTRIES NEWFAULT1) (GLOBALVARS %#CLISPARRAY) (NOLINKFNS WTFIX)) (BLOCK%: CLISPLOOKUP0 CLISPLOOKUP0 CLISPLOOKUP1 CLISPLOOKUP2 (GLOBALVARS DECLWORDS CLISPRECORDTYPES CLISPTRANFLG) (LOCALFREEVARS WORD CLASS CLASSDEF VAR1 VAR2)) (BLOCK%: CLISPDECBLOCK CLISPDEC CLISPDEC0 CLISPDEC1 GETLOCALDEC (GLOBALVARS CLISPRECORDTYPES DECLWORDS CLISPARITHOPLST CLISPARITHCLASSLST COMMENTFLG SKORLST1) (ENTRIES CLISPDEC CLISPDEC0 GETLOCALDEC) (LOCALFREEVARS FAULTFN)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DWIMODELST DWIMKEYLST DWIMWAIT LCASEFLG CLISPFORWORDSPLST I.S.OPRLST SKORLST3 DWIMLOADFNSFLG CLISPTRANFLG CLISPARRAY %#CLISPARRAY) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA USEDFREE CLISP% ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FIXATOM2) ) (PUTPROPS DWIM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2620 6284 (DWIM 2630 . 3282) (NEWFAULT1 3284 . 5726) (CHECKTRAN 5728 . 6282)) (6439 12979 (RETDWIM2 6449 . 6825) (RETDWIM3 6827 . 7840) (FIXATOM2 7842 . 8046) (SPLIT89 8048 . 9251) ( WTFIXLOADEF 9253 . 12216) (CLISP% 12218 . 12977)) (12980 16032 (VARSBOUNDINEDITCHAIN 12990 . 13341) ( VARSBOUNDINFORM 13343 . 16030)) (16153 17108 (DWIMLOADFNS? 16163 . 17106)) (17187 32111 (CLISPLOOKUP0 17197 . 19462) (CLISPLOOKUP1 19464 . 22027) (CLISPLOOKUP2 22029 . 22268) (CLISPERROR 22270 . 25034) ( CLISPDEC 25036 . 28460) (CLISPDEC0 28462 . 28714) (CLISPDEC1 28716 . 30332) (GETLOCALDEC 30334 . 32109 )) (32112 36529 (COMPILEUSERFN 32122 . 34306) (COMPILEUSERFN1 34308 . 35345) (USEDFREE 35347 . 35658) (CLISPTRAN 35660 . 36461) (compilation 36463 . 36527)) (36530 44197 (CLISPFORERR 36540 . 38009) ( CLISPFORERR1 38011 . 38699) (I.S.OPR 38701 . 42512) (WARNUSER 42514 . 44195))))) STOP \ No newline at end of file diff --git a/sources/DWIMIFY b/sources/DWIMIFY new file mode 100644 index 00000000..ded5d227 --- /dev/null +++ b/sources/DWIMIFY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 16:21:27" {DSK}local>lde>lispcore>sources>DWIMIFY.;2 310177 changes to%: (VARS DWIMIFYCOMS) previous date%: " 8-Dec-86 22:57:42" {DSK}local>lde>lispcore>sources>DWIMIFY.;1) (* ; " Copyright (c) 1978, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1978 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 DWIMIFYCOMS) (RPAQQ DWIMIFYCOMS ((FNS DWIMIFYFNS DWIMIFY DWIMIFY0 DWIMIFY0? DWMFY0 DWIMIFY1 DWIMIFY1? DWMFY1 DWIMIFY1A DWIMIFY2 DWIMIFY2? DWMFY2 DWIMIFY2A CLISPANGLEBRACKETS SHRIEKER CLISPRESPELL EXPRCHECK) (FNS CLISPATOM0 CLISPATOM1 CLRPLNODE STOPSCAN? CLUNARYMINUS? CLBINARYMINUS? CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPNOEVAL CLISPLOOKUP CLISPATOM2A CLISPBROADSCOPE CLISPBROADSCOPE1 CLISPATOM2C CLISPATOM2D CLISPCAR/CDR CLISPCAR/CDR1 CLISPCAR/CDR2 CLISPATOMIS1 CLISPATOMARE1 CLISPATOMARE2 CLISPATOMIS2) (FNS WTFIX WTFIX0 WTFIX1 RETDWIM DWIMERRORRETURN DWIMARKASCHANGED RETDWIM1 FIX89TYPEIN FIXLAMBDA FIXAPPLY FIXATOM FIXATOM1 FIXCONTINUE FIXCONTINUE1 CLISPATOM GETVARS GETVARS1 FIX89 FIXPRINTIN FIX89A CLISPFUNCTION? CLISPNOTVARP CLISP-SIMPLE-FUNCTION-P CLISPELL FINDFN DWIMUNSAVEDEF CHECKTRAN) (FNS CLISPIF CLISPIF0 CLISPIF1 CLISPIF2 CLISPIF3) (FNS CLISPFOR CLISPFOR0 CLISPFOR0A CLISPFOR1 CLISPRPLNODE CLISPFOR2 CLISPFOR3 CLISPFORVARS CLISPFORVARS1 CLISPFOR4 CLISPFORF/L CLISPDSUBST GETDUMMYVAR CLISPFORINITVAR) (COMS (FNS \DURATIONTRAN \CLISPKEYWORDPROCESS)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS DWIMUNDOCATCH)) (BLOCKS (FORBLOCK (ENTRIES CLISPFOR) CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST \CLISPKEYWORDPROCESS CLISPFORF/L CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 CLISPFOR0A CLISPFOR \DURATIONTRAN (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. I.V. PROGVARS MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS DWIMIFYCHANGE DUMMYVARS I.S.OPRSLST CLISPCONTEXT UNDOSIDE0 EXP)) (DWIMIFYBLOCK CLBINARYMINUS? CLISPANGLEBRACKETS CLISPATOM CLISPATOM0 CLISPATOM1 CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPATOM2A CLISPATOM2C CLISPATOM2D CLISPATOMARE1 CLISPATOMARE2 CLISPATOMIS1 CLISPATOMIS2 CLISPBROADSCOPE CLISPBROADSCOPE1 CLISPCAR/CDR CLISPCAR/CDR1 CLISPCAR/CDR2 CLISPIF CLISPIF0 CLISPIF1 CLISPIF2 CLISPIF3 CLISPLOOKUP CLISPRESPELL CLRPLNODE CLUNARYMINUS? DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1 DWIMIFY1? DWIMIFY1A DWIMIFY2 DWIMIFY2? DWIMIFY2A DWIMIFYFNS DWMFY0 DWMFY1 DWMFY2 FIX89 FIX89A FIX89TYPEIN FIXAPPLY FIXATOM FIXATOM1 FIXCONTINUE FIXCONTINUE1 FIXLAMBDA GETDUMMYVAR GETVARS GETVARS1 RETDWIM RETDWIM1 SHRIEKER STOPSCAN? WTFIX WTFIX0 WTFIX1 (ENTRIES WTFIX WTFIX1 DWIMIFYFNS DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1A GETDUMMYVAR DWIMIFY2 DWIMIFY2? DWIMIFY1? DWIMIFY1 DWIMIFY2A CLISPLOOKUP) (SPECVARS 89CHANGE 89FLG BRACKET BRACKETCNT ATTEMPTFLG BACKUPFLG BODY BREAKFLG BROADSCOPE CLISPCHANGE CLISPCHANGES CLISPCONTEXT CLISPERTYPE CLTYP CURRTAIL DWIMIFYCHANGE DWIMIFY0CHANGE DWIMIFYFLG DWIMIFYING ENDTAIL EXP EXPR FAULTAPPLYFLG FAULTARGS FAULTFN FAULTPOS FAULTX FAULTXX FIRSTI.V. FIXCLK FORMSFLG I.S.TYPE I.S.TYPE1 HISTENTRY I.S. I.V. INITVARS IVINITFLG LISPFN CHARLST MAKEPROGFLG NCONC1LKUP NCONCLKUP NEGFLG NEWTAIL NEXTAIL SUBPARENT NOFIX89 NOSAVEFLG ONEFLG ONLYSPELLFLG PARENT SIDES TAIL TENTATIVE TERMINATEFLG TYP TYPE-IN? UNDOLST UNDOSIDE UNDOSIDE0 VAR1 VAR2 VARS WORKFLAG UNARYFLG DEST FOR I.S.OPRSLST PROGVARS))) (GLOBALVARS DWIMINMACROSFLG CHECKCARATOMFLG TREATASCLISPFLG CLISPHELPFLG CLISPIFTRANFLG CLISPRETRANFLG DWIMCHECKPROGLABELSFLG DWIMCHECK#ARGSFLG SHALLOWFLG PRETTYTRANFLG CLEARSTKLST LCASEFLG LAMBDASPLST DURATIONCLISPWORDS CLISPTRANFLG CLISPIFWORDSPLST LPARKEY DWIMUSERFORMS DWIMKEYLST SPELLINGS3 SPELLINGS1 CLISPARRAY CLISPFLG CLISPCHARS CLISPISNOISEWORDS CLISPLASTSUB CLISPISWORDSPLST CLISPCHARRAY CLISPINFIXSPLST OKREEVALST WTFIXCHCONLST1 WTFIXCHCONLST RPARKEY NOFIXFNSLST0 NOFIXVARSLST0 LISPXHISTORY DWIMEQUIVLST COMMENTFLG USERWORDS SPELLINGS2 FILELST CLISPFORWORDSPLST CLISPDUMMYFORVARS LASTWORD COMPILERMACROPROPS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (ADDVARS (NLAML BREAK1))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DWIMIFYFNS) (NLAML) (LAMA))) (INITVARS (DWIM.GIVE.UP.TIME) (DWIM.GIVE.UP.INTERVAL 2000)))) (DEFINEQ (DWIMIFYFNS [NLAMBDA FNS (* lmm "20-May-84 19:57") (PROG ((CLK (CLOCK 0)) TEM) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) [SETQ TEM (MAPCAR [COND ((CDR FNS) FNS) ((LISTP (CAR FNS)) (STKEVAL 'DWIMIFYFNS (CAR FNS) NIL 'INTERNAL)) (T (* ; "If (CAR FNS) is name of a file, do dwimifyfns on its functions.") (OR (LISTP (EVALV (CAR FNS) 'DWIMIFYFNS)) (AND (GETPROP (OR (AND DWIMFLG (MISSPELLED? (CAR FNS) 70 FILELST NIL FNS)) (CAR FNS)) 'FILE) (FILEFNSLST (CAR FNS))) (STKEVAL 'DWIMIFYFNS (CAR FNS) 'INTERNAL] (FUNCTION (LAMBDA (X) (DWIMIFY0 X] (RETURN TEM]) (DWIMIFY [LAMBDA (X QUIETFLG L) (* lmm "20-May-84 19:57") (PROG (VAL) (COND ((NULL DWIMFLG) (LISPXPRIN1 "DWIM is turned off! " T) (RETURN NIL))) (* ;; "If X is an atom and L is NIL, X is treated as the name of a function, and its entire definition is DWIMIFIED. Otherwise, X is a piece of a function, and L the edit puh down list that leads to X (i.e. L is the push-dwown list after performing a !0) L is used to compute the bound variables, as well as to determine whether X is an element or tail.") (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (SETQ VAL (DWIMIFY0 X L)) (COND ((AND (LISTP X) (NULL L) (NULL QUIETFLG)) (RESETFORM (OUTPUT T) (RESETVARS ((PRETTYTRANFLG T)) (PRINTDEF VAL NIL T))) (TERPRI T))) (RETURN VAL]) (DWIMIFY0 [LAMBDA (X Y VARS EXPR) (* lmm "27-FEB-83 10:55") (* ;; "Some general comments: --- DWIMIFYFLG is bound in DWIMIFY0, WTFIX, and WTFIX0. It is set to T whenever WTFIX is called and given EXPR, TAIL, PARENT, etc. as arguments, i.e. from DWIMIFY1 or DWIMIFY2. Note that this may occur due to an explicit call to DWIMIFY0, or due to evaluating certain CLISP expressions, e.g. IF statements, which call DWIMIFY1 or DWIMIFY2. These two cases are distinguished by the value of DWIMIFYING. --- DWIMIFYING is bound in DWIMIFY0 (to T), and whenever DWIMIFY1 or DWIMIFY2 are called from contexts where DWIMIFYING may not be bound, e.g. from CLISPIF. In these latter cases, DWIMIFYING is bound to (AND DWIMIFYFLG DWIMIFYING). Thus DWIMIFYING is always bound when DWIMIFYFLG is bound, and is T when under a call to DWIMIFY0, otherwise NIL. Note that checking DWIMIFYING without also checking DWIMIFYFLG may cause a U.B.A. DWIMIFYING error. Similary, other state variables that are bound in DWIMIFY0 but not rebound by DWIMIFY1 or DWIMIFY2 such as CLISPCONTEXT, DWIMIFYCHANGE, etc., are assumed to be bound when DWIMIFYFLG is T, so that any call to DWIMIFY1 or DWIMIFY2 must also guarantee that these variables are bound. If the caller is not sure, it should use DWIMIFY1? and DWIMIFY2? since these do the appropriate checks. --- NOFIXFNSLST0 and NOFIXVARSLST0 are global varaales. They are initializaed to NOFIXFNSLST and NOFIXVARLST by DWIMIFY and DWIMIFYFNS, as well as CLISPIF, CLISPFOR, etc. when they enter the DWIMIFY functions, i.e. DWIMIFY1 and DWIMIFY2 for the first time. NOFIXFNSLST and NOFIXVARLST are the variable that the user can add things to. --- VARS is bound in WTFIX and in DWIMIFY0. DWIMIFY1 and DWIMIFY2 supply VARS in their call to WTFIX. Otherwise WTFIX comptes them. --- ATTEMPTFLG is bound in DWIMIFY1 and DWIMIFY2. It is used to inform DWIMIFY1 or DWIMIFY2, in the event that WTFIX was unable to make a correction, NOT to add the atom to NOFIXLST. For example, this occurs when a correction was offered to the user but rejected, e.g. U.D.F. T, and user declines the fix, T is not added to NOFIXLST.") (PROG (FN FAULTFN DWIMIFY0CHANGE DWIMIFYCHANGE TEM CLISPCONTEXT ONEFLG (DWIMIFYING T) (DWIMIFYFLG T) [SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] TYPE-IN? (FIXSPELLDEFAULT 'n)) (RETURN (COND [(LISTP Y) (* ; "from DW command") [COND ([LISTP (SETQ FAULTFN (EVALV 'ATM] (SETQ FAULTFN (CAR FAULTFN] (* ; "ATM is bound in EDITE.") (SETQ VARS (VARSBOUNDINEDITCHAIN Y)) (SETQ EXPR (OR (CAR (LAST Y)) X)) (LISPXPUT 'RESPELLS NIL NIL LISPXHIST) (* ; "Essentially, a new call to DW is treated as a new event.") (COND ((TAILP X (CAR Y)) (DWIMIFY2 X (CAR Y))) ((AND (EQ (OR (CDR (FASSOC (SETQ TEM (CAAR Y)) DWIMEQUIVLST)) TEM) 'COND) (NEQ (OR (CDR (FASSOC (SETQ TEM (CAADR Y)) DWIMEQUIVLST)) TEM) 'SELECTQ)) (DWIMIFY2 (CDR X) X) X) ([AND (EQ (OR (CDR (FASSOC (SETQ TEM (CAAR Y)) DWIMEQUIVLST)) TEM) 'SELECTQ) (NEQ X (CADAR Y)) (CDR (FMEMB X (CAR Y] (DWIMIFY2 (CDR X) X) X) (T (DWIMIFY1 X] (Y (* ; "called from compileuserfn or compile1a. X is the expression to be dwimified.") (SETQ FAULTFN Y) (AND (NULL EXPR) (SETQ EXPR X)) (* ;; "EXPR is supplied on calls from compileuserfn. it is the top level def. on calls from compile1a, x and expr are the same") (SETQ TEM (DWIMIFY1 X)) (AND DWIMIFY0CHANGE (DWIMARKASCHANGED FAULTFN SIDES)) TEM) ((LISTP X) (* ; "e.g. user types in a direct call to dwimify an xpression") (SETQQ FAULTFN TYPE-IN) (SETQ EXPR X) (DWIMIFY1 X)) (T (* ; "DWIMIFY (functon-name)") (SETQ TEM (EXPRCHECK X)) (* ; "If EXPRCHECK performs spelling correction, it will rset FN.") (SETQ FAULTFN (SETQ FN (CAR TEM))) (DWIMIFY1 (SETQ EXPR (CDR TEM))) [COND (DWIMIFY0CHANGE (* ;; "DWIMIFY0CHANGE is only bound in DWIMIFY0. it is only reset (in RETDWIM) when DWIMIFYFLG and DWIMIFYING are both T. It is true if there was ANY change in the entire expression. DWIMIFYCHANGE on the other hand is bound wheever DWIMIFYFLG is T, and it is true if there was any change in the prticular level expression being worked on.") (DWIMARKASCHANGED FN SIDES) (COND ([OR (NOT (FGETD FN)) (AND (NEQ DFNFLG 'PROP) (NOT (EXPRP FN] (DWIMUNSAVEDEF FN T] FN]) (DWIMIFY0? [LAMBDA (TAIL PARENT SUBPARENT FORMSFLG ONEFLG FAULTFN CLISPCONTEXT) (* lmm "27-MAY-82 09:54") (* ;; "DWIMIFY0? is an external entry to DWIMIFYBLOCK It is used to dwimify an expression where the contxt may or may not be under aother call to dwimify. it is used by RECORD, MATCH etc. as well s by CLISP4 in CLISPIFY.") (* ;; "The value of DWIMIFY0? is NOT the expression (dwiified) but T or NIL depending on whether or not there was any change, i.e. the value of dwiifychange.") (PROG NIL (SELECTQ DWIMIFYFLG (NIL (* ;; "Under a call to WTFIX, but not under a call to DWIMIFY, e.g. from evaluating a CREATE expression in a user program.") (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST)) ((CLISPIFY VARSBOUND) (* ;; "e.g. call from clispify or record package. WAnt it to look like we are inside of a call to dwimify. calling function has already set up VARS and EXPR.") (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) [RETURN (PROG ((DWIMIFY0CHANGE T) (DWIMIFYING T)) (* ; "This is going to be treated as though were a caal to dwimify.") (RETURN (DWMFY0]) (EVAL (* ; "random call to dwimify0? EVAL IS THE TOP LEVEL VALUE OF DWIMIFYFLG") (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) [RETURN (PROG (DWIMIFYFLG FAULTPOS EXPR VARS) (RETURN (DWMFY0]) NIL) (RETURN (DWMFY0]) (DWMFY0 [LAMBDA NIL (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (DWIMIFYFLG T) DWIMIFYCHANGE) (COND ((AND (NULL FORMSFLG) (EQ TAIL PARENT)) (DWIMIFY1 TAIL CLISPCONTEXT)) (T (DWIMIFY2 TAIL PARENT SUBPARENT FORMSFLG ONEFLG))) (RETURN DWIMIFYCHANGE]) (DWIMIFY1 [LAMBDA (FORM CLISPCONTEXT FORMSFLG) (DWMFY1 FORM]) (DWIMIFY1? [LAMBDA (FORM CLISPCONTEXT FORMSFLG) (COND (DWIMIFYFLG (DWMFY1 FORM)) (T (* ;; "See comment in dwimify0. DWIMIFY1? is used where caller is not sure whether state variables have been set up.") (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (DWIMIFYFLG T) DWIMIFYCHANGE) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (RETURN (DWMFY1 FORM]) (DWMFY1 [LAMBDA (FORM) (* lmm " 3-Jan-86 21:29") (PROG ((X FORM) CARFORM TEM CLISPCHANGE 89CHANGE ATTEMPTFLG CARISOKFLG) [COND ((NLISTP FORM) (SETQ TEM (LIST X)) (DWIMIFY2 TEM T) (RETURN (COND ((CDR TEM) TEM) (T (CAR TEM] TOP (SETQ CARFORM (OR (CDR (FASSOC (CAR X) DWIMEQUIVLST)) (CAR X))) [COND ([AND (NEQ CARFORM 'LAMBDA) (NEQ CARFORM 'NLAMBDA) (OR (NULL (CHECKTRAN X)) CLISPRETRANFLG (RETURN X)) (NOT (COND [(LISTP CARFORM) (* ;; "Checks whether CAR is a function object with a remote translation. Also converts to hash array from CLISP if hash array exists. CARISOKFLG is set so dont have to recheck at LP1.") (OR (EQ (SETQ TEM (OR (CDR (FASSOC (CAAR X) DWIMEQUIVLST)) (CAAR X))) 'LAMBDA) (EQ TEM 'NLAMBDA) (SETQ CARISOKFLG (AND (CHECKTRAN CARFORM) (NULL CLISPRETRANFLG] ((LITATOM CARFORM) (CLISP-SIMPLE-FUNCTION-P CARFORM](* ; "The AND is true if CAR of form is not recognized.") (COND [(PROG (NEXTAIL) (RETURN (WTFIX0 X X X X))) (* ; "Successful correction.") (COND ((CHECKTRAN X) (RETURN X)) [CLISPCHANGE (COND ((NEQ CLISPCHANGE 'PARTIAL) (* ;; "The tail must be DWIMIFIED if the transformation did not affect the entire form, e.g. (FOO<...> ...)") (RETURN FORM)) ((LISTP CARFORM) (GO DWIMIFYTAIL)) (T (SETQ CLISPCHANGE NIL) (GO TOP) (* ; "Recheck CAR of FORM, as it may still be misspelled.") ] (89CHANGE (SETQ 89CHANGE NIL) (GO TOP) (* ; "Recheck CAR of FORM, as it still may be misspelled, e.g. (conss8car X)") ] ((AND CLISPCHANGE (NEQ CLISPCHANGE 'PARTIAL)) (* ;; "This means a CLISPCHANGE failed and not to bother with dwimifying rest of form, e.g. a bad IF or FOR statement.") (RETURN FORM)) ((AND (NULL ATTEMPTFLG) (LITATOM CARFORM)) (* ;; "ATTEMPTFLG is used to distinguish between the case where DWIM does not recognize the problem at all, and that where it did but was unable to make the correction, e.g. a malformed IF, or else the user vetoed the correction.") (SETQ NOFIXFNSLST0 (CONS CARFORM NOFIXFNSLST0] (* ;; "The call to WTFIX is made before specific checks on CAR of FORM, since CAR of the FORM may be misspelled.") (COND ((LISTP CARFORM) (* ; "Skip selectq") (GO DWIMIFYTAIL))) [SELECTQ CARFORM (* ; "NIL") (DECLARE [MAPC (CDR X) (FUNCTION (LAMBDA (X) (SELECTQ (CAR X) ((USEDFREE GLOBALVARS) (* ; "SPECVARS AND LOCALVARS WOULD PRESUMABLY BE BOUND SOMEWHERE SO NO NEED TO ADD THEM") (SETQ NOFIXVARSLST0 (UNION (LISTP (CDR X)) NOFIXVARSLST0))) NIL]) ('GO (AND DWIMCHECK#ARGSFLG (CDDR X) (DWIMIFY1A X 1))) (SELECTQ (DWIMIFY2 (CDR X) FORM T NIL T) (AND (NLISTP (CADDR X)) (DWIMIFY2 (CDDR X) FORM NIL NIL T)) (SETQ X (CDDR X)) (PROG NIL LP (COND ((NULL (CDR X)) (DWIMIFY2 X FORM T) (RETURN FORM))) (DWIMIFY2 (CDAR X) (CDAR X) T T) (SETQ X (CDR X)) (GO LP))) ((SETQ SETN RPAQ SETARG) (AND (NOT (FMEMB (CADR X) VARS)) (NOT (FMEMB (CADR X) NOFIXVARSLST0)) (SETQ NOFIXVARSLST0 (CONS (CADR X) NOFIXVARSLST0))) (DWIMIFY2 (CDDR X) FORM T)) (COND [MAPC (CDR X) (FUNCTION (LAMBDA (X) (DWIMIFY2 X X NIL T]) (FUNCTION [DWIMIFY1 (COND ((LISTP (CADR X))) ((NULL (CDDR X)) (* ; "Doesnt DWIMIFY for (FUCNTION FOO (X Y)) i.e. FUNARY with atomic argument.") (CDR X]) (RESETVAR (DWIMIFY2 (CDDR X) FORM T)) ([LAMBDA NLAMBDA] ([LAMBDA (VARS) (DWIMIFY2 (CDDR X) FORM T] (APPEND [OR (LISTP (CADR X)) (AND (CADR X) (LIST (CADR X] VARS))) (COND ((EQMEMB 'BINDS (GETPROP CARFORM 'INFO)) (* ; "PROG EQUIVALENTS") ([LAMBDA (VARS) (DWIMIFY2 (CDDR X) FORM T] (NCONC [MAPCAR (CADR X) (FUNCTION (LAMBDA (X) (COND ((NLISTP X) X) (T (DWIMIFY2 (CDR X) X T) [COND ((NOT (LITATOM (CAR X))) (DWIMIFY1A (CADR FORM) (FMEMB X (CADR FORM] (CAR X] VARS))) ((CLISPNOEVAL CARFORM) (* ; "Don't DWIMIFY the tails of nlambdas.") ) (T (GO DWIMIFYTAIL] (RETURN FORM) DWIMIFYTAIL (DWIMIFY2 (CDR X) FORM) (SETQ CARFORM (OR (CDR (FASSOC (CAR X) DWIMEQUIVLST)) (CAR X))) (* ; "CARFORM may have changed if DWIMIFY2 changed X") (COND [(LISTP CARFORM) (AND (NULL CARISOKFLG) (NULL CLISPCHANGE) (DWIMIFY1 CARFORM)) (* ;; "Note that if CAR is a list, it itself has not yet been dwimified, e.g. may be a misspelled LAMBDA. However If CLISPCHANGE is not NIL, this expression was produced by the call to WTFIX and hence is already dwimified.") (COND ((AND (NULL FORMSFLG) (NEQ (SETQ TEM (OR (CDR (FASSOC (CAAR X) DWIMEQUIVLST)) (CAAR X))) 'LAMBDA) (NEQ TEM 'NLAMBDA) (NULL CARISOKFLG) (NULL (CHECKTRAN CARFORM))) (DWIMIFY1A X) (RETURN X] ((AND DWIMCHECK#ARGSFLG (EQ (ARGTYPE CARFORM) 0) (SELECTQ (SETQ TEM (NARGS CARFORM)) (0 (CDR X)) (1 (CDDR X)) (2 (CDDDR X)) (3 (CDDDDR X)) NIL)) (DWIMIFY1A X TEM))) (RETURN FORM]) (DWIMIFY1A [LAMBDA (PARENT TAIL FN) (* wt%: "10-DEC-80 23:36") (COND ((AND (NULL DWIMESSGAG) (OR FN (AND DWIMIFYFLG DWIMIFYING)) (NEQ CLISPCONTEXT 'IFWORD)) (* ; "clispif handles this itself.") (AND (FIXPRINTIN (OR FN FAULTFN)) (LISPXSPACES 1 T)) (COND ((EQ CLISPCONTEXT 'IFWORD)) (T (LISPXPRIN1 '"(possible) parentheses error in " T) (LISPXPRINT (RETDWIM2 PARENT TAIL) T T))) (COND ((NUMBERP TAIL) (LISPXPRIN1 "too many arguments (more than " T) (LISPXPRIN1 TAIL T) (LISPXPRIN1 ") " T)) (TAIL (LISPXPRIN1 '"at " T) (LISPXPRINT (CONCAT '"... " (SUBSTRING (RETDWIM2 TAIL NIL 2) 2 -1)) T T]) (DWIMIFY2 [LAMBDA (TAIL PARENT SUBPARENT FORMSFLG ONEFLG ONLYSPELLFLG) (DWMFY2]) (DWIMIFY2? [LAMBDA (TAIL PARENT SUBPARENT FORMSFLG ONEFLG ONLYSPELLFLG CLISPCONTEXT) (COND (DWIMIFYFLG (DWMFY2)) (T (* ;; "See comment in dwimify0. DWIMIFY2? is used where caller is not sure whether state variables have been set up.") (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (DWIMIFYFLG T) DWIMIFYCHANGE) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST) (RETURN (DWMFY2]) (DWMFY2 [LAMBDA NIL (* ; "Edited 4-Dec-86 11:02 by jop:") (* ; "handles tails.") (AND (LISTP TAIL) (PROG ((TAIL0 TAIL) X CARPARENT CLISPCHANGE 89CHANGE NEXTAIL ATTEMPTFLG TEM FNFLG NOTOKFLG) (AND (OR (EQ SUBPARENT T) (EQ PARENT TAIL)) (SETQ SUBPARENT TAIL)) (* ;; "Means dont ever back up beyond this point, e.g. in prog variables, if you write (PROG ((X FOO Y LT 3) .. dont want LT to gobble the x.))") (SETQ CARPARENT (OR (CDR (FASSOC (CAR PARENT) DWIMEQUIVLST)) (CAR PARENT))) LP (SETQ CLISPCHANGE NIL) (SETQ 89CHANGE NIL) (SETQ NEXTAIL NIL) (COND ((NULL TAIL) (GO OUT)) ((LISTP (SETQ X (CAR TAIL))) (AND (NEQ CLISPCONTEXT 'LINEAR) (DWIMIFY1 X)) [AND FORMSFLG (EQ TAIL PARENT) (OR (EQ CARPARENT 'LAMBDA) (EQ CARPARENT 'NLAMBDA)) (/RPLNODE TAIL (CONS (CAR TAIL) (CDR TAIL] (GO DROPTHRU)) ((NOT (LITATOM X)) (* ; "e.g. number, string, etc.") ) [(EQMEMB 'LABELS (GETPROP CARPARENT 'INFO))(* ;  "this is a prog label. or resetvars label etc.") (COND ((AND DWIMCHECKPROGLABELSFLG (NOT (FMEMB X NOFIXVARSLST0)) (STRPOSL CLISPCHARRAY X)) (AND (FIXPRINTIN FAULTFN) (LISPXSPACES 1 T)) (LISPXPRIN1 "suspicious prog label: " T) (LISPXPRINT X T] (NOSPELLFLG (* ;  "none of the following corrections wanted") ) ((CLISPNOTVARP X) (* ;; "(CAR TAIL) is not recognized as a variable. Note that when DWIMIFYING, WTFIX will be called on a variable which is used freely, but does not have a top level binding, i.e. DWIMIFYING hile the variable is bound is not sufficient, because we do not do a STKSCAN for its value, as this would be expensive. (STKSCAN is done when DWIMIFY2 is called out of an evaluation.)") (COND [(AND FORMSFLG (EQ TAIL PARENT) (DWIMIFY2A TAIL 'QUIET)) (* ;; "DWIMIFY2A calls CLISPFUNCTION? to see if (CAR TAIL) is the name of a function. If FORMSFLG is true and (CAR TAIL) is name of function, then TAIL may be one form with parenteeses removed.") (COND ((OR (NEQ X (CAR TAIL)) (NEQ FORMSFLG 'FORWORD)) (* ;; "Either the user has approved the combined spelling correction and insertion of paentheses, or else we are not under an I>S> without an oerator. (E.g. FOR X IN Y WHILE ATOM PRINT X, In this cae dont want to insert parentheses.) Note that if FOO is also the name of a variable as well as a function, no harm will be done in cases like IF A THEN FOO _ X. Only possible problem is for case like IF A THEN FOO _ X Y, where FFO is both a functionand a variable. In this case, parens would be inserted, and then an error generated. HOwever, this is extremely unlikely, since in most cases it would be written as IF A THEN FOO_X Y (not to mention the added improbability of FOO being both the name of a function and a variable.)") (GO ASK)) (T (* ;; "(CAR TAIL) is the name of a function, but user hasnt been consulted, and we are under a FOR with no operator, so wait.") (SETQ FNFLG T) (* ;  "Now drop through to next COND and call to WTFIX (because (CAR TAIL) may be a miispelled variable.)") ] ((AND (EQ FORMSFLG 'FORWORD) (EQ TAIL (CDR PARENT)) (OR (LISTP CARPARENT) (NULL NOTOKFLG) (NULL FNFLG)) (DWIMIFY2A TAIL 'QUIET) (OR (NEQ X (CAR TAIL)) (LISTP CARPARENT))) (* ;; "Corresponds to the case where the user left a DO out of a for statement. Already know that the first thing in TAIL is not the name of a function. However, only take action if the usr approves combined correction, (or (CAR PARENT) is a list.) since it is still possible that X is the (misspelled) name of a variable.") (SETQQ FORMSFLG FOR1) (GO INSERT)) ((AND [LISTP (SETQ TEM (GETPROP X 'CLISPWORD] [NEQ (CAR TEM) (CAR (GETPROP CARPARENT 'CLISPWORD] (CDDR TAIL)) (AND (EQ TAIL PARENT) (SETQ NOTOKFLG T)) (* ;; "E.g. (LIST X FOR X IN A --) The CDDR check is because very seldom you have an iterative statement only two elements long, but lots of places where iterative words can appear in another context, e.g. OF, TO, etc. See comment below on NOTOKFLG. Note that if FORMSFLG is true and (EQ TAIL PARENT), then CLISPFUNCTION? (via DWIMIFY2A) above would have returned T.") (DWIMIFY1A PARENT TAIL) (* ;  "Stop dwimifying, strong evidence that expression is screwed up.") (GO OUT))) (COND ((AND [NULL (AND ONLYSPELLFLG (OR (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?] (WTFIX0 X TAIL PARENT SUBPARENT ONLYSPELLFLG)) (* ;; "If both ONLYSPELLFLG and NOSPELLFLG are true, no point in calling WTFIX. ONLYSPELLFLG is true on calls fro CLISPATOM2A.") (COND (89CHANGE (SETQ NOTOKFLG NIL) (SETQ FNFLG NIL) (* ;  "If 89CHANGE, then want to look at (CAR TAIL) again, e.g. ... (CONS (CAR XX9))") (GO LP))) (GO DROPTHRU))) (* ;  "At this point we know that (CAR TAIL) is not ok.") (AND (EQ TAIL TAIL0) (SETQ NOTOKFLG T)) (* ;  "NOTOKFLG=T means first expression in TAIL was not recognized as a variable.") [COND ((AND FORMSFLG (EQ TAIL PARENT)) (* ;; "After DWIMIFYING the whole tail, if CAR is still an atom, we may want to insert parentheses, e.g. (FOO _ X Y) is ok, but (FOO X Y) may need to be converted to ((FOO X Y))") ) [(FGETD X) (* ;; "Don't add a function name to NOFIXVARSLST0 since this is tantamount to sanctiooning it as a variale.") (COND ((AND (EQ FORMSFLG 'FORWORD) (EQ TAIL (CDR PARENT)) (OR (LISTP CARPARENT) (NULL NOTOKFLG) (NULL FNFLG))) (SETQQ FORMSFLG FOR1) (GO INSERT)) ((AND (NEQ CLISPCONTEXT 'IFWORD) (NLISTP CLISPCONTEXT) (NEQ ONLYSPELLFLG 'NORUNONS) (NOT (EXPRP X)) (NEQ X 'E) (NEQ X COMMENTFLG)) (* ;  "Printx message but dwimify rest of tail --- might not be a parentheses error.") (DWIMIFY1A PARENT TAIL] ((NULL ATTEMPTFLG) (COND ([NOT (AND CLISPFLG (GETPROP X 'CLISPTYPE] (SETQ NOFIXVARSLST0 (CONS X NOFIXVARSLST0] (GO DROPTHRU))) DROPTHRU (COND (ONEFLG (GO OUT))) [SETQ TAIL (COND ((NULL NEXTAIL) (CDR TAIL)) ((EQ NEXTAIL T) NIL) (T (CDR NEXTAIL] (GO LP) OUT (COND ([OR (NULL FORMSFLG) (NOT (LITATOM (CAR TAIL0] (GO OUT1)) ([OR (EQ FORMSFLG 'FOR1) (AND (EQ FORMSFLG 'FORWORD) (OR (NULL NOTOKFLG) (NULL FNFLG)) (LISTP (CADR TAIL0] (* ;; "Corresponds to the cse where the user left out a DO. Want to check this before below as in this case dont want to stick in paens around entire form.") (GO OUT1)) ((EQ FORMSFLG T) (* ;  "(CAR TAIL0) is the name of a functionand NOT the name of a variable.") (AND NOTOKFLG FNFLG (GO ASK))) [(CDR TAIL0) (* ; "FORMSFLG is FOR or IF") (COND ((OR NOTOKFLG (DWIMIFY2A TAIL0 'QUIET)) (* ;; "(CAR TAIL) is not the name of a variable, or else IS the name of a function. The reason for the call to CLISPFUNCTION? (via DWIMIFY2A) instead of checking FNFLG is that in the case that (CAR TAIL) was the name of a variable as indicated by NOTOKFLG=NIL, CLISPFUNCTION? would not have been called earlier.") (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) (GO OUT1] ((AND NOTOKFLG FNFLG) (* ;; "(CAR TAIL) is not the name of a variable and is the name of a function, but nothing follows it. E.g. IF -- THEN RETURN ELSE --") (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) (GO OUT1))) OUT1 (RETURN (COND ((NULL ONEFLG) TAIL0) (NOTOKFLG (* ;; "In this way, the function thatcaled DWIMIFY2 can find out whether or not the atom in question is OK. NOte that if it appears on NOFIXLST, it is OK, i.e. havng been seen before, we treat it the same as a variable or what not.") NIL) ((NULL NEXTAIL) TAIL) ((EQ NEXTAIL T) PARENT) (T NEXTAIL))) ASK (COND ((NULL (FIXSPELL1 [COND (TYPE-IN? '"") (T (CONCAT '"... " (SUBSTRING (RETDWIM2 TAIL0) 2 -1] (CONCAT '"... " (MKSTRING (RETDWIM2 TAIL0)) '")") NIL T)) (GO OUT1))) INSERT (/RPLNODE TAIL (CONS (CAR TAIL) (CDR TAIL))) (DWIMIFY1 (CAR TAIL) CLISPCONTEXT) (GO DROPTHRU]) (DWIMIFY2A [LAMBDA ($TAIL $TYP) (* wt%: 25-FEB-76 1 54) (CLISPFUNCTION? $TAIL $TYP [FUNCTION (LAMBDA (X Y) (SUBSTRING (RETDWIM2 Y) 2 -1] [FUNCTION (LAMBDA (X Y) (CONCAT [MKSTRING (RETDWIM2 (COND [(LISTP X) (* ; "Run-on.") (CONS (CAR X) (CONS (CDR X) (CDR Y] (T (CONS X (CDR Y] '")"] $TAIL]) (CLISPANGLEBRACKETS [LAMBDA (LST) (* wt%: "26-JUN-78 01:20") (PROG [WORKFLAG (NCONCLKUP (CLISPLOOKUP 'NCONC)) (NCONC1LKUP (CLISPLOOKUP 'NCONC1] (RETURN (SHRIEKER LST]) (SHRIEKER [LAMBDA (LOOKAT) (* ;; "Shrieker is designed to 'understand' expressions of the form (! A B !! C !! D E F), where A, B, C,... represent lists, ! indicates that the list following it is to be (non-destructively) expanded (e.g. A's elements are to be brought to the top level of the list which contains A), and !! indicates that the list following it is to be destructively expanded. Thus, if A= (H I J), B= (K L M), C= (N O P), the result of evaluating (! A !! B C) should be a list (H I J K L M C). SHRIEKER does not actually evaluate the list given to it, but rather returns a form which will have the correct evaluation. Thus, if SHRIEKER is given the (shriekified) list (! A !! B C), it will return the form (APPEND A (NCONC1 B C)). Should A,B,C have the values given above, then evaluation of this form will leave A unchanged, but B will have been destructively altered, and will now evaluate to the list (K L M (N O P)).") (PROG (CARTEST RESULTP) (COND ((OR (ATOM LOOKAT) (NLISTP LOOKAT)) (SETQ WORKFLAG NIL) (RETURN LOOKAT))) (* ;; "As is evident from a look at the code, SHRIEKER is a fairly straightforward recursive prog; analysis of the argument, LOOKAT, is doen in effect from the tail of LOOKat to its head. I>e. given LOOKAT SHRIEKER separates it into two parts (roughly car and cdr), where one part (CARTEST) is the first element of LOOKAT that is not ! or !! , and the other part is the tail of LOOKAT below CARTEST-- LOOKAT is reset to evaluate to this tail and SHRIEKER is called recursively on the new LOOKAT, eventually returning a list structure, to which we setq RESULTP, that is the LISP equivalent of LOOKAT (which, with its !'s and !!'s is an expression in CLISP). The calling incarnation of SHRIEKER uses RESULTP and its knowledge of the shriek-sysmbol (! or ! ! or !!) immediately before CARTEST, to determine how CARTEST and RESULTP should be used to form the list structure that will be returned, possibly to higher level incarnations of SHRIEKER. into then possibly incarnations SHRIEKER.") (SETQ CARTEST (CAR LOOKAT)) (SETQ LOOKAT (CDR LOOKAT)) [RETURN (COND ((EQ CARTEST '!!) (GO A1)) [(EQ CARTEST '!) (COND (LOOKAT (SETQ CARTEST (CAR LOOKAT)) (SETQ LOOKAT (CDR LOOKAT)) (COND ((EQ CARTEST '!) (GO A1))) (* ;; "This conditional insures that SHRIEKER will understnad that the sequence ! ! means the atom !!. Control will be sent to the statement after A1, which will make sure that CARTEST is NCONCed onto RESULTP (if car of RESULTP is APPEND, CONS, NCONC1, or LIST) or will stuff CARTEST into second place in RESULTP, which is presumalby an NCONC expression-- all provided that WORKFLAG is NIL...") (SETQ RESULTP (SHRIEKER LOOKAT)) (* ; "Here's our recursive call to SHRIEKER..") (COND ((NULL RESULTP) (* ;; "WORKFLAG is a flag that is passed between incarnations of SHRIEKER and is the means by which SHRIEKER is able to distinguish between user-created code and SHRIEKER-created code. If WORKFLAG eq's T then SHRIEKER knows that what has been returned as RESULTP is user-created code and should not be altered.") (SETQQ WORKFLAG !IT) (LIST 'APPEND CARTEST)) ((ATOM RESULTP) (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST RESULTP)) ((NULL WORKFLAG) (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST RESULTP)) (T (* ;; "If the COND falls througn to this point then we may assume that RESULTP is SHRIEKER-created and do a SELECTQ on car of RESULTP (which should be either APPEND, NCONC, NCONC1, CONS, or LIST) to determine whether we should stuff CARTEST into RESULTP or not.") (SELECTQ WORKFLAG (APPENDING (ATTACH CARTEST (CDR RESULTP)) RESULTP) ((NCONCING CONSING LISTING NCONC1ING) (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST RESULTP)) (!IT (SETQQ WORKFLAG APPENDING) (ATTACH CARTEST (CDR RESULTP)) RESULTP) (!!IT (SETQQ WORKFLAG APPENDING) (LIST 'APPEND CARTEST (CADR RESULTP))) (LIST 'APPEND CARTEST RESULTP] [LOOKAT (* ;; "If we arrive here then we know that SHRIEKER's arguemnt-- hte intial value of LOOKAT--is a list, the first element of which is not ! or !!. Accordingly, we attempt to CONS or LIST together CARTEST and RESULTP, depending on the nature of RESULTP and the value of WORKFLAG left by the recursive call to SHRIEKER in the statement below.") (SETQ RESULTP (SHRIEKER LOOKAT)) (COND ((NULL WORKFLAG) (SETQQ WORKFLAG LISTING) (LIST 'LIST CARTEST)) (T (SELECTQ WORKFLAG ((CONSING APPENDING NCONCING NCONC1ING) (SETQQ WORKFLAG CONSING) (LIST 'CONS CARTEST RESULTP)) (LISTING (ATTACH CARTEST (CDR RESULTP)) RESULTP) ((!!IT !IT) (SETQQ WORKFLAG CONSING) (LIST 'CONS CARTEST (CADR RESULTP))) (LIST 'CONS CARTEST RESULTP] (T (* ;; "If we reach this point then we know that SHRIEKER was called on a singleton, i.e. the intial vlaue of LOOKAT was a list of one element, so we create the appropriate list structure around that element and setq WORKFLAG to NIL, enabling a possible parent SHRIEKER to modify our code.") (SETQQ WORKFLAG LISTING) (LIST 'LIST CARTEST] A1 (RETURN (COND (LOOKAT (SETQ CARTEST (CAR LOOKAT)) (SETQ LOOKAT (CDR LOOKAT)) (SETQ RESULTP (SHRIEKER LOOKAT)) (COND ((NULL RESULTP) (SETQQ WORKFLAG !!IT) (LIST NCONCLKUP CARTEST)) ((ATOM RESULTP) (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST RESULTP)) ((NULL WORKFLAG) (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST RESULTP)) (T (SELECTQ WORKFLAG (NCONCING (ATTACH CARTEST (CDR RESULTP)) RESULTP) ((APPENDING CONSING) (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST RESULTP)) (NCONC1ING (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST (CADR RESULTP) (CONS 'LIST (CDDR RESULTP)))) (!IT (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST (CADR RESULTP))) (!!IT (SETQQ WORKFLAG NCONCING) (ATTACH CARTEST (CDR RESULTP)) RESULTP) (LISTING (COND ((NULL (CDDR RESULTP)) (SETQQ WORKFLAG NCONC1ING) (LIST NCONC1LKUP CARTEST (CADR RESULTP))) (T (SETQQ WORKFLAG NCONCING) (LIST NCONCLKUP CARTEST RESULTP)))) (LIST NCONCLKUP CARTEST RESULTP]) (CLISPRESPELL [LAMBDA (TL WORDS FLG) (* lmm " 4-SEP-83 23:31") (* ;; "CLISPRESPELL essentially asks is it possible to inerpret (CAR TAIL) as one of WORDS. It first checks to make sure (CAR TAIL) isnt already something else-- e.g. a function, variable, member of NOFIXFNSLST (which is the same as being a function) etc.") (AND (NEQ NOSPELLFLG T) (OR (NOT NOSPELLFLG) TYPE-IN?) (LISTP TL) (LITATOM (CAR TL)) (NOT (CLISP-SIMPLE-FUNCTION-P (CAR TL))) (CLISPNOTVARP (CAR TL)) (MISSPELLED? (CAR TL) NIL WORDS FLG]) (EXPRCHECK [LAMBDA (X) (* wt%: "14-FEB-78 00:06") (PROG (D) (COND ((NOT (LITATOM X)) (ERROR X '"not a function.")) [(EXPRP (SETQ D (VIRGINFN X T] ((GETD X) (GO NOEXPR)) ([NULL (AND DWIMFLG (SETQ D (MISSPELLED? X 70 USERWORDS NIL NIL (FUNCTION GETD] (ERROR X '"not defined.")) ([NOT (EXPRP (SETQ D (VIRGINFN (SETQ X D] (GO NOEXPR))) (AND ADDSPELLFLG (ADDSPELL X 0)) (RETURN (CONS X D)) NOEXPR (ERROR X '"not an expr."]) ) (DEFINEQ (CLISPATOM0 [LAMBDA (CHARLST TAIL PARENT) (* bvm%: "21-Nov-86 18:05") (AND (NULL SUBPARENT) (SETQ SUBPARENT PARENT)) (PROG ((CURRTAIL TAIL) (NOFIXVARSLST1 NOFIXVARSLST0) 89FLG TEM) TOP (SELECTQ (DWIMUNDOCATCH 'CLISPATOM1 (SETQ TEM (CLISPATOM1 TAIL))) (:RESPELL (* ; "A misspelling was detected. Need to fix it now.") (SETQ NOFIXVARSLST0 NOFIXVARSLST1) (AND DWIMIFYFLG (SETQ CLISPCHANGE NIL)) (COND ((PROG1 (CLISPELL TAIL) (SETQ CHARLST (DUNPACK (CAR TAIL) WTFIXCHCONLST))) (* ;; "MIsspelling found. Note that even if the word wasnt found, LST is reset since some tentative changes were tried, it was probably clobbered.") (SETQ CURRTAIL TAIL) (GO TOP)))) (NIL (* ; "error") (SETQ NOFIXVARSLST0 NOFIXVARSLST1)) (RETURN TEM)) (RETURN (COND (89FLG (* ; "E.G. N*8FOO -- fix the 8-9 error first.") [PROG ((FAULTX (CAR CURRTAIL))) (SETQ TEM (FIX89 FAULTX (CAR 89FLG) (LENGTH 89FLG] (COND ((AND TEM (LITATOM (CAR TAIL))) (CLISPATOM0 (DUNPACK (CAR TAIL) WTFIXCHCONLST1) TAIL PARENT]) (CLISPATOM1 [LAMBDA (TAIL) (* lmm "29-Jul-86 00:25") (* ;;; "This function and its subfunctions handle infix operators. LST is an exploded list of characters for CAR of TAIL, which is a tail of PARENT. If LST contains an CLISP operator, or CAR of TAIL is one, CLISPATOM1 scans the rest of tail until it reaches the end of this cluster. For example, if TAIL is (... A* B + C D+E ...), the scan will stop after C. The scan separates out the operators from the operands. Note that because any operand can be a list, and hence separated from its operator, an operator can occur interior to an atom, as in A*B, at the end of an atom, as in (A* (--)), at the front of an atom, as in ((--) *A), or by itself, as in ((--) * (--)). Therefore, we permit the same options when the operand is a atomic, i.e. the user can type A*B, A* B, A *B, or A * B. Note that in the latter two cases, the first argument to the operator is not contained in TAIL, and it is necessary for CLISPATOM1 to back tail up one element using PARENT.") (* ;; "After the scan has been completed, the form for the first operator is assembled. Since operators are always processed left to right, the first operand to this operator is always the single element preceding it (unless it is a unary operator). The right boundary, and hence the second operand, is determined by the operator, e.g. * is tighter than +, which is tighter than LS, etc. Thus ... A*B+C ... becomes ... (ITIMES A B) + C ... while ... A+B*C ... becomes ... (IPLUS A B * C) In either case, the rest of this cluster is processed from within this call to CLISPATOM1, thereby taking advantage of the fact that we know that the atoms do not contain operators, and therefore don't have to be unpacked and examined character by character.") (PROG ((L CHARLST) (LST0 CHARLST) CURRTAIL-1 CLTYP CLTYP1 ENDTAIL BROADSCOPE BACKUPFLG OPRFLAG NOTFLG TYP ATMS NOSAVEFLG TENTATIVE TEM BRACKET (BRACKETCNT 0) ISFLG) (COND ((SETQ CLTYP1 (GETPROP (CAR CURRTAIL) 'CLISPTYPE)) (GO NEXT2))) TOP (SETQ ATMS NIL) LP (COND ((NULL L) (* ; "End of an atom.") (COND ((NULL TYP) (* ; "If we have gone through the first atom without finding an CLISP operator, we are done.") (COND ((NULL 89FLG) (* ; "The case where there was an 8 or 9 and an operator has been handled in CL89CHECK.") ) (CURRTAIL (* ;; "8 and 9 errors are handled here instead of back in CLISPATOM where there is similar code, because there may be more than one 8 or 9 in the expression, and the first one may be ok, e.g. 8*X*8ADD1 Y") (AND [FIX89A (CAR CURRTAIL) (CAR (LISTP 89FLG)) (IMINUS (SETQ TEM (LENGTH 89FLG] (FIX89 FAULTX (CAR (LISTP 89FLG)) TEM) (GO OUT3))) ((AND TYPE-IN? (NEQ NOSPELLFLG T) (EQ (CAR (LISTP 89FLG)) LPARKEY) (EQ (CAR (SETQ TEM (FLAST CHARLST))) RPARKEY)) (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by CURRTAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY.") (FIX89TYPEIN (FMEMB LPARKEY (SETQ TEM (LDIFF CHARLST TEM))) TEM T))) (RETURN NIL)) (LST0 (SETQ OPRFLAG T) (* ; "OPRFLAG is T means the element just processed did NOT end in an operator, e.g. A+B, or just A.") (SETQ TEM (PACK LST0)) (* ;; "Collects characters to the right of the last operator in the atom, or all the characters in the atom, if it contained no operator.") (SETQ ATMS (NCONC1 ATMS TEM)) (SETQ NOTFLG NIL))) (SETQ 89FLG NIL) (GO NEXT))) [COND ((FMEMB (CAR L) CLISPCHARS) (COND ((SETQ CLTYP1 (GETPROP (CAR L) 'CLISPTYPE)) [SELECTQ (CAR L) (- [COND ((NULL (AND (EQ L LST0) (CLUNARYMINUS? OPRFLAG))) (* ;; "Says minus is binary. See comments i CLUNARYMINUS?. By replacing binary minus with +- in CLISPATOM1, all the rest of the CLISP function can treat minus as unary.") (FRPLACA L '+-) (SETQ CLTYP1 (GETPROP '+- 'CLISPTYPE]) (%' (AND (NEQ L LST0) (GO LP1)) (* ;; "' is ignored interior to atoms, e.g. USER can have a function named ATOM' or a variable named A' which is not necessarily defined or bound at time of DWIMIFYing.") ) (COND [BRACKET (COND ((EQ (CAR L) (CAR BRACKET)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) ((EQ (CAR L) (CADR BRACKET)) (SETQ BRACKETCNT (SUB1 BRACKETCNT))) (T (GO OPR] [(EQ CLTYP1 'BRACKET) [SETQ BRACKET (LISTP (GETPROP (CAR L) 'CLISPBRACKET] (COND ((EQ (CAR L) (CAR BRACKET)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) (T (DWIMERRORRETURN (LIST (LIST 'BRACKET (CAR BRACKET)) PARENT] (89FLG) ((AND (NEQ NOSPELLFLG T) (OR (NULL NOSPELLFLG) TYPE-IN?) (OR (EQ (CAR L) LPARKEY) (EQ (CAR L) RPARKEY))) (SETQ 89FLG L] (GO OPR)) ([AND BRACKET (CAR L) (EQ (CAR L) (LISTGET1 BRACKET 'SEPARATOR] (GO OPR] LP1 (COND ((AND OPRFLAG (NULL BROADSCOPE) (ZEROP BRACKETCNT) (EQ L CHARLST)) (* ;; "If OPRFLAG is T and the first character in LST is not an operator, no need to scan further, e.g. A*B C unless we are processing a broad scope operator, e.g. (A EQ FOO B) or unless ANGCNT is not 0, i.e. we are inside of an <> pair.") (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) (* ;; "If ENDTAIL has not been set yet, set it. Note that ENDTAIL may already have been set, e.g. A*B+C D, in which case ENDTAIL would correspnd to the position of the +.") (GO OUT) (* ;; "If this is the first character in an atom, then we cango to out, e.g. A+B C. HOwever, this may be the first character following a >, as in FOO_C, in which case we have to finish out the atom.") )) (SETQ L (CDR L)) (* ; "Peel off the current character and go on.") (GO LP) NEXT (* ; "We have just exhausted the lit of characters for an atm.") [COND ((NULL TAIL) (* ; "We were originally given just an atom, e.g. user types FOO_FIE.") (SETQ TAIL ATMS) (OR PARENT (SETQ PARENT TAIL))) ([AND TAIL (OR (CDR ATMS) (NEQ (CAR (LISTP ATMS)) (CAR CURRTAIL] (* ;; "Splice burst version of atom into CURRTAIL, and set CURRTAIL to point to the as yet unexamined part of it. If the OR is not true, CURRTAIL would not be changd so don't bother e.g. (LIST A + B * C)") [/RPLNODE CURRTAIL (CAR (LISTP ATMS)) (NCONC (CDR ATMS) (SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (* ; "CURRTAIL-1 is used for backing up, see below.") ) (T (SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (COND ((NULL CURRTAIL) (* ; "We have reached the end of the faulty form.") (GO OUT))) NEXT1 (* ; "Look at the next thing in CURRTAIL.") (COND ([AND OPRFLAG DWIMIFYFLG ONEFLG (NULL BROADSCOPE) (ZEROP BRACKETCNT) (OR (NOT (LITATOM (CAR CURRTAIL))) (AND (NOT (GETPROP (CAR CURRTAIL) 'CLISPTYPE)) (NOT (GETPROP (NTHCHAR (CAR CURRTAIL) 1) 'CLISPTYPE] (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) (GO OUT)) ((AND (OR OPRFLAG (NEQ (CAR CURRTAIL-1) '%')) [OR (LITATOM (CAR CURRTAIL)) (AND (NUMBERP (CAR CURRTAIL)) (MINUSP (CAR CURRTAIL)) (AND (NULL BRACKET) OPRFLAG (CLBINARYMINUS? CURRTAIL-1 CURRTAIL] (CLISPNOTVARP (CAR CURRTAIL))) (* ;; "The OR check is to handle cases like (.. ' F/L) which I think means wquote the whole thing. NOte that this comes up in expressions like since when SHRIEKER calls DWIMIFY2, the ' and F/L have already been split apart.") (* ; "dont call clbinaryminus? if last thing ended in an operator. e.g. ((foo) + -2)") (COND ([AND (SETQ CLTYP1 (GETPROP (CAR CURRTAIL) 'CLISPTYPE)) (NOT (AND (EQ (CAR (LISTP CLTYP1)) 'BRACKET) (NULL BRACKET] (GO NEXT2))) [SETQ LST0 (SETQ L (SETQ CHARLST (UNPACK (CAR CURRTAIL] (COND ((AND BRACKET (SETQ TEM (FMEMB (CADR BRACKET) (CDDR L))) (NOT (FMEMB (CAR BRACKET) L))) (* ;; "< and > are thought of as brackets, rather than operaaors. Therefore this is necessary in order thatthings like <1 2 -1> work, i.e. --- not treated as binary in this case, also , and finally if A*B is the name of a variable Note that this doesnt quite handle all cases: where A*B is the name of a variable, will be broken apart, but then it isnt clear whats intended.") (CLRPLNODE CURRTAIL (PACK (LDIFF L TEM)) (CONS (PACK TEM) (CDR CURRTAIL))) (GO NEXT1))) (GO TOP)) ((AND OPRFLAG (SETQ TEM (LISTP (NLEFT TAIL 2 CURRTAIL))) (NEQ (CAR TEM) '%') (NEQ (CAR TEM) '%:) [OR (NULL (CAR CURRTAIL)) (AND (LISTP (CAR CURRTAIL)) (NOT (CLISPFUNCTION? (CAR CURRTAIL) 'OKVAR] (CLISPFUNCTION? (SETQ TEM (CDR TEM)) 'NOTVAR [FUNCTION (LAMBDA (X Y) (CONCAT X (COND ((NULL Y) '"()") (T (RETDWIM2 Y] [FUNCTION (LAMBDA (X Y) (MKSTRING (CONS X (RETDWIM2 Y] (CAR CURRTAIL))) (* ; "This clause checks for user typing in apply mode, e.g. X_CONS (A B)") (SETQQ TENTATIVE CERTAINLY) (* ; "Once you print a message, you dont want to go and try another interpretation.") (/RPLNODE TEM (CONS (CAR TEM) (CAR CURRTAIL)) (CDR CURRTAIL)) [SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 TEM] (SETQ OPRFLAG T) (SETQ NOTFLG NIL) (GO NEXT1))) (COND ((AND OPRFLAG (NULL BROADSCOPE) (ZEROP BRACKETCNT)) (* ; "Finished. E.g. A*B (--)") (OR ENDTAIL (SETQ ENDTAIL CURRTAIL)) (GO OUT)) ([SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (* ; "E.g. A* (--)") (SETQ OPRFLAG T) (SETQ NOTFLG NIL) (GO NEXT1)) (T (GO OUT))) NEXT2 (* ; "(CAR CURRTAIL) is an operaaor. CLTYP1 is its CLISPTYPe.") [SELECTQ (CAR CURRTAIL) (- [COND ((NULL (CLUNARYMINUS? OPRFLAG)) (* ; "The minus is biary. SEe comments at earlier call to CLUNARYMINUS? in CLSPATOM1.") (/RPLNODE CURRTAIL '+- (CDR CURRTAIL)) (SETQ CLTYP1 (GETPROP '+- 'CLISPTYPE]) ((-> =>) [COND ((EQ TYP '%:) (SETQ CLTYP CLTYP1) (GO NEXT3)) (T (DWIMERRORRETURN (CAR CURRTAIL]) (COND [BRACKET (COND ((EQ (CAR BRACKET) (CAR CURRTAIL)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) ((EQ (CADR BRACKET) (CAR CURRTAIL)) (SETQ BRACKETCNT (SUB1 BRACKETCNT] ([SETQ TEM (LISTP (GETP (CAR CURRTAIL) 'CLISPBRACKET] (COND ((EQ (CAR CURRTAIL) (CAR TEM)) (SETQ BRACKET TEM) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) (T (DWIMERRORRETURN (LIST (LIST 'BRACKET (CAR TEM)) PARENT] (COND (ENDTAIL) [(NULL TYP) (* ; "This is the first operator.") (SETQ TYP (CAR CURRTAIL)) (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP TYP 'BROADSCOPE)) (SETQ NOTFLG (EQ (SETQ TEM (GETPROP TYP 'LISPFN)) 'NOT] (NOTFLG (* ;; "NOTFLG is true when we are processing a NOT opeator, and it immediately precedes the current operator. In this case, the scope of the NOT is the scope of the next opeator, e.g. (X ~GR FOO Y)") (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP (CAR CURRTAIL) 'BROADSCOPE)) (SETQ NOTFLG (EQ (GETPROP (CAR CURRTAIL) 'LISPFN) 'NOT)) (* ; "So that NOTFLG is not turned off when there are two ~'s in a row, e.g. (X ~~GR FOO Y OR Z)") ) ((STOPSCAN? CLTYP1 CLTYP (CAR CURRTAIL) OPRFLAG) (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator. The AND is so that a unary operator will terminate the scope of a binary operator that has a right hand operand, e.g. X+Y -Z, X_Y 'Z, etc.") (SETQ ENDTAIL CURRTAIL))) (SETQ ISFLG (EQ [CAR (LISTP (GETPROP (CAR CURRTAIL) 'CLISPCLASS] 'ISWORD)) NEXT3 [SETQ OPRFLAG (AND BRACKET (EQ (CAR CURRTAIL) (CADR BRACKET] (* ; "OPRFLAG is T aater > since no right hand operand is reuired.") (COND ([SETQ CURRTAIL (LISTP (CDR (SETQ CURRTAIL-1 CURRTAIL] (GO NEXT1))) OUT (* ; "We are finished scanning. Now call CLISPATOM2 to assemble the correct form.") [COND ((NEQ (CAR (LISTP TAIL)) TYP) (GO OUT1)) ((GETPROP TYP 'UNARYOP) (GO OUT1)) ((OR (EQ PARENT TAIL) (EQ SUBPARENT TAIL)) (* ; "E.g. (+ X) or (SETQ Y + X)") (DWIMERRORRETURN (LIST 1 TAIL PARENT] (SETQ TAIL (NLEFT (OR SUBPARENT PARENT) 1 TAIL)) (* ;; "SUBPARENT can be used to mark that point in a list beyond which not to back up, e.g. (LAMBDA (X) FOO X LT Y)") (SETQ BACKUPFLG T) OUT1 (CLISPATOM2) OUT2 [COND ([AND [OR [NUMBERP (SETQ CLTYP (GETPROP (SETQ TYP (CAR ENDTAIL)) 'CLISPTYPE] (NUMBERP (CAR (LISTP CLTYP] (NULL (AND DWIMIFYFLG CLISPCONTEXT (EQ [CAR (LISTP (GETPROP (CAR ENDTAIL) 'CLISPWORD] 'FORWORD) (OR (EQ CLISPCONTEXT 'FORWORD) (EQ CLISPCONTEXT 'FOR/BIND](* ;; "i used to have just a (NULL (AND DWIMIFYFLG ONEFLG)) but this means tht if you have a predicate in an iterative statement, e.g. when x=y+z that it doesnt dwimify completely. the above clause handles it but i dont remember why i had the original one in there.") (* ; "reason for the or check is so that DO doesnt get treated as an IS word when coming from an i.s.") (SETQ TEM (CLISPATOM1A TYP CLTYP TAIL)) (COND ((OR DWIMIFYFLG (EQ TEM PARENT)) (SETQ TAIL TEM] OUT3 (SETQ TEM (COND ((AND (NULL FORMSFLG) (EQ TAIL PARENT)) T) (T TAIL))) (COND (DWIMIFYFLG (SETQ NEXTAIL TEM)) (BACKUPFLG (SETQ NEWTAIL TEM))) [SETQ TEM (COND ((AND (NULL FORMSFLG) (OR (NULL PARENT) (EQ TAIL PARENT))) TAIL) (T (CAR (LISTP TAIL] (COND ((AND TENTATIVE (NEQ TENTATIVE 'CERTAINLY)) (* ;; "Tentative is set to CERTAINLY when we are sure the correction will be CLISP, and to avoid somebody else setting to T . IN this casse there will be no message. This occurs when a message has already been printed, e.g. in X*FOO Y , when user is asked FOO Y -> (FOO Y), the approveal of the CLISP transformation is implicit.") (SETQ CLISPCHANGES (LIST TEM (CLISPATOM1B) TAIL (CDR TAIL) TENTATIVE NOFIXVARSLST0)) (* ;; "note --- (CDR TAIL) used to be endtail in above expression, however, for situations where clispatom1a munches for a while, this does not produce the right message, e.g. dwimifying .... FOO:1='ZAP ...") (AND DWIMIFYFLG (SETQ CLISPCHANGE NIL)) (DWIMERRORRETURN))) (RETURN TEM) OPR (* ; "We have hit an operator inside of an atom.") (COND ((NEQ L LST0) (SETQ TEM (PACK (LDIFF LST0 L))) (* ; "Collects characters to the right of the last operator in the atom.") (COND ((AND (FLOATP TEM) (OR (EQ (CAR L) '+) (EQ (CAR L) '+-)) (EQ (CAR (NLEFT LST0 1 L)) 'E)) (* ; "E.G. X+1.0E-5*Y") (AND (EQ (CAR L) '+-) (FRPLACA L '-)) (GO LP1))) (SETQ ATMS (NCONC1 ATMS TEM)) (SETQ NOTFLG NIL))) (SETQ ATMS (NCONC1 ATMS (CAR L))) [COND (ENDTAIL) [(NULL TYP) (* ; "First operator.") (SETQ TYP (CAR L)) (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP TYP 'BROADSCOPE)) (SETQ NOTFLG (EQ (GETPROP TYP 'LISPFN) 'NOT] [NOTFLG (* ;; "It is not only necessary that we are processing a NOT, but that it immediately precede the current operator.") (SETQ CLTYP CLTYP1) (SETQ BROADSCOPE (GETPROP (CAR L) 'BROADSCOPE)) (SETQ NOTFLG (EQ (GETPROP (CAR L) 'LISPFN) 'NOT] ((STOPSCAN? CLTYP1 CLTYP (CAR L) (OR (NEQ L LST0) OPRFLAG)) (* ;; "This operator delimits the scope of the first operator found. Set ENDTAIL to be the first thing not within the scope of the operator.") (SETQ ENDTAIL (COND ((EQ L CHARLST) (* ; "The scope delimiting operator was the first thing in an atom, e.g. A*B +C or A*B + C.") CURRTAIL) (T (FLAST ATMS] [SETQ OPRFLAG (AND BRACKET (EQ (CAR L) (CADR BRACKET] (* ; "OPRFLAG is T aater > since no right hand operand is reuired.") (COND ([AND (CDR L) CURRTAIL (OR (AND BRACKET (EQ (CAR L) (CADR BRACKET))) (EQ (CAR L) '~] (* ;; "So that the rest of the atom will be looked at as a unit before being unpacked, e.g. ~GR, want to look up GR. Also want to look at rest of atom as a unit following >, e.g. FOO_EQUAL C. By starting over with a new atom, we also perform the OPRFLAG terminating check, as in FOO_C.") (/RPLNODE CURRTAIL (CAR CURRTAIL) (CONS (PACK (CDR L)) (CDR CURRTAIL))) (SETQ L NIL))) (SETQ 89FLG NIL) (SETQ LST0 (CDR L)) (SETQ L (AND (NEQ (CAR L) '%') (CDR L))) (* ; "Following a ' no operaars are recognized in the rest of the atm.") (GO LP]) (CLRPLNODE [LAMBDA (X A D) (PROG ((L (CDR UNDOSIDE))) (COND (NOSAVEFLG (* ; "X is not contained in original expression, so don't bother to save") (GO OUT))) LP (COND ((EQ L (CDR UNDOSIDE0)) (* ; "X has not previously been saved") (/RPLNODE X A D) (RETURN X)) ((NEQ X (CAAR L)) (* ;; "If X is EQ to CAR of one of the entries on UNDOOSIDE, then the contents of this node have already been saved, so it is ok to smash it.") (SETQ L (CDR L)) (GO LP))) OUT (FRPLACA X A) (FRPLACD X D) (RETURN X]) (STOPSCAN? [LAMBDA (CLTYP2 CLTYP1 OPR OPRFLAG) (* wt%: "16-AUG-78 21:47") (* ;; "STOPSCAN? is T if operator corresponding to CLTYPX would stop scan for operator corresponding to CLTYP, i.e. if former is of lower or same precedence as latter.") (AND CLTYP2 CLTYP1 (PROG NIL (COND [BROADSCOPE (COND ((OR (NOT (ZEROP BRACKETCNT)) (EQ CLTYP2 'BRACKET)) (RETURN NIL] [(EQ CLTYP2 'BRACKET) (RETURN (COND [(EQ OPR (CAR BRACKET)) (* ; "a left bracket") (* ;; "e.g. for X+Y< -- stop scanning. note that for binary brackets, it never stops as is consistent with them being very tight operators, i.e. FOO_A{..} parses as FOO_ (A{..})") (AND OPRFLAG (EQ BRACKETCNT 1) (GETP OPR 'UNARYOP] ((EQ CLTYP1 'BRACKET) (* ;; "i.e. if OPR is the right bracket for BRACKET, or if OPR is some other bracket inside of scope of BRACKET.") (* ;; "if cltyp1 is ot a bracket, then bracket is not the operator, and should really treat the whole bracketed expression as an operand and not stop the scan.") (ZEROP BRACKETCNT] ((NOT (ZEROP BRACKETCNT)) (RETURN NIL)) ((GETPROP OPR 'UNARYOP) (RETURN OPRFLAG) (* ;; "If OPRFLAG is NIL, we have just seen a unary operator with no operand, so under no circumstance stop the scan. E.g. X*-Y. Note that this does NOT say do not consider next operand as possible operatr, so that X*-+Y will generate an error, not try to multiply X by (minus +). The case whee the unary operaar is ' is handled specially in CLISPATOM1 and CLISPATOM1A.") )) (RETURN (COND ([NOT (ILESSP (COND ((ATOM CLTYP1) CLTYP1) (T (CDR CLTYP1))) (COND ((ATOM CLTYP2) CLTYP2) (T (CAR CLTYP2] T) ([AND (LISTP CLTYP2) (ILESSP (CDR CLTYP2) (COND ((ATOM CLTYP1) CLTYP1) (T (CDR CLTYP1] (* ;; "Not sure of this. it is an attempt to handle the A*B_C+D case. Here the initial cltyp is that of *, but since the right precedence of _ is looser than that of *, means that it should be operative.") (SETQ CLTYP CLTYP2) NIL]) (CLUNARYMINUS? [LAMBDA (OPRFLAG) (* lmm "20-May-84 20:02") (* ;; "True if minus is unary. This is the case when either (1) it immediately follows an operator (the (AND TYP (NULL OPRFLAG)) check) or (2) it is the first thing in a list (the (EQ CURRTAIL SUBPARENT) check) or else, car of form is a function and not a variable, and --- negates its first argument. The case where car of form is amisspeleed function is handled, because the tentatitve correction for binry minus will be tried, and then when spelling correction on function name suceeds, this will be implemeneted. then there will be another call to clispatom when its aagument is evaluated, and this time the functionis spelled right. Note that the cse where car of a form is a misspelled variable works also, even when the variabl could be confusec for a function, since the correction on the variable is tried first.") (OR (AND TYP (NULL OPRFLAG)) (EQ CURRTAIL SUBPARENT) (AND (EQ CURRTAIL (CDR SUBPARENT)) (FNTYP (CAR SUBPARENT)) (OR (LISTP (CAR SUBPARENT)) (CLISPNOTVARP (CAR SUBPARENT))) (OR TYPE-IN? (AND CLISPHELPFLG (FIXSPELL1 [CONS (CAR SUBPARENT) (CONS (CADR SUBPARENT) (NCONC [AND (EQ (CADR SUBPARENT) '-) (LIST (RETDWIM2 (CADDR SUBPARENT] (RETDWIM2 (CDDR (COND ((EQ (CADR SUBPARENT) '-) (CDR SUBPARENT)) (T SUBPARENT] '"the %"-%" is unary" '" " T]) (CLBINARYMINUS? [LAMBDA ($TAIL MINUSTAIL) (* wt%: "10-OCT-78 21:22") (* ;; "used when a negative number follows a list. we dont know if a space was typed before the --- or not, so in situation ike ((list) -2) or (x* (list) -2) we ask. warren ^Z") (* ;; "the EQ used to check tail against subparent. i changed it because on calls to dwimify0? from record, e.g. (ADD z:1 -1), was trying to treat -1 as binary even though it shouldnt have.") (AND (EQ TAIL PARENT) [OR (LISTP (CAR TAIL)) (NUMBERP (CAR TAIL)) (AND (LITATOM (CAR TAIL)) (NOT (CLISPNOTVARP (CAR TAIL))) (NOT (CLISPFUNCTION? TAIL] (OR TYPE-IN? (AND CLISPHELPFLG (FIXSPELL1 [CONS (CAR $TAIL) (CONS (CADR $TAIL) (NCONC [AND (EQ (CADR $TAIL) '-) (LIST (RETDWIM2 (CADDR $TAIL] (RETDWIM2 (CDDR (COND ((EQ (CADR $TAIL) '-) (CDR $TAIL)) (T $TAIL] '"the %"-%" is a clisp operator" '" " T))) (OR (NULL MINUSTAIL) (/RPLNODE MINUSTAIL '- (CONS (MINUS (CAR MINUSTAIL)) (CDR MINUSTAIL]) (CLISPATOM1A [LAMBDA (TYP CLTYP TAIL NOSAVEFLG) (* lmm " 4-SEP-83 22:50") (* ;;; "This function is similar to CLISPATOM1 except that elements of TAIL do not have to be unpacked. It is called from either CLISPATOM1 or CLISPATOM2 when more than one operator was encountered in a cluster. CADR of TAIL is TYP, the next operator to be processed, and CLTYP is its CLISPTYPE. CLISPATOM1A scans down TAIL looking for the right hand boundary of TYP, but does not unpack any atoms. It then calls CLISPATOM2 to assemble the form, and then if necessary repeats the process. For example, if the original cluster was A+B*C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (IPLUS A B * C). CLISPATOM2 would then call CLISPATOM1A with TAIL= (B * C). Similary, if the original cluster were A*B+C, the call to CLISPATOM2 from CLISPATOM1 would replace this with (ITIMES A B) with + C having been spliced into the tail. CLISPATOM1 would then call CLISPATOM1A with TAIL= ((ITIMES A B) + C ...)") (PROG (ENDTAIL OPRFLAG BROADSCOPE CLTYP0 BRACKETCNT BRACKET ISFLG) TOP (SETQ ISFLG (EQ (CAR (GETPROP TYP 'CLISPCLASS)) 'ISWORD)) (SETQ BRACKETCNT (COND ((SETQ BRACKET (GETP TYP 'CLISPBRACKET)) 1) (T 0))) [SETQ ENDTAIL (COND ((EQ TYP (CAR TAIL)) (* ; "TYP is car of TAIL for unary operatrs, CADR for binary.") TAIL) (T (CDR TAIL] [COND ([AND (EQ TYP '~) (SETQ CLTYP0 (GETPROP (CADR ENDTAIL) 'CLISPTYPE] (SETQ CLTYP CLTYP0) (SETQ ENDTAIL (CDR ENDTAIL] (SETQ BROADSCOPE (GETPROP TYP 'BROADSCOPE)) (SETQ OPRFLAG NIL) LP [COND ((EQ (CAR ENDTAIL) '%') (SETQ ENDTAIL (CDDR ENDTAIL)) (SETQ OPRFLAG T)) (T (SETQ ENDTAIL (CDR ENDTAIL] (COND ((NULL ENDTAIL) (GO OUT)) ((SETQ CLTYP0 (GETPROP (CAR ENDTAIL) 'CLISPTYPE)) (SETQ ISFLG (EQ (CAR (GETPROP (CAR ENDTAIL) 'CLISPCLASS)) 'ISWORD)) [COND [BRACKET (COND ((EQ (CAR ENDTAIL) (CAR BRACKET)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) ((EQ (CAR ENDTAIL) (CADR BRACKET)) (SETQ BRACKETCNT (SUB1 BRACKETCNT] ((EQ CLTYP0 'BRACKET) (SETQ BRACKET (GETPROP (CAR ENDTAIL) 'CLISPBRACKET)) (COND ((EQ (CAR ENDTAIL) (CAR BRACKET)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) (T (DWIMERRORRETURN (LIST (LIST 'BRACKET (CAR BRACKET)) PARENT] (AND (STOPSCAN? CLTYP0 CLTYP (CAR ENDTAIL) OPRFLAG) (GO OUT)) [SETQ OPRFLAG (AND (EQ CLTYP0 'BRACKET) (EQ (CAR ENDTAIL) (CADR BRACKET] (* ; "E.g. X_ see comment in CLISPATOM1") ) ((AND OPRFLAG (ZEROP BRACKETCNT) (NULL BROADSCOPE)) (GO OUT)) (T (SETQ OPRFLAG T))) (GO LP) OUT (CLISPATOM2) (COND ([AND (SETQ CLTYP (GETPROP (SETQ TYP (CAR ENDTAIL)) 'CLISPTYPE)) (NULL (AND DWIMIFYFLG CLISPCONTEXT ONEFLG (EQ (CAR (GETPROP (CAR ENDTAIL) 'CLISPWORD)) 'FORWORD) (OR (EQ CLISPCONTEXT 'FORWORD) (EQ CLISPCONTEXT 'FOR/BIND](* ;; "E.g. A+B*C+D. The first call to CLISPATOM1A is with TAIL (B * C + D). The first call to CLISPATOM2 changes this to ((ITIMES B C) + D), and then we loop back to the top of CLISPATOM1A. The reason for the OR is so that do does not get treated as an IS WORD when coming from an i.s.") (GO TOP))) (AND TENTATIVE (SETQQ TENTATIVE PROBABLY)) (* ; "Don't consider another interpretation if there are two or more CLISP operators in this cluster.") (RETURN TAIL]) (CLISPATOM1B [LAMBDA NIL (* wt%: 25-FEB-76 1 41) (* ;; "Copies changes.") (PROG ((L UNDOSIDE) (L1 (CDR UNDOSIDE0)) LST) LP [COND ((EQ (SETQ L (CDR L)) L1) (RETURN LST)) ((LISTP (CAAR L)) (SETQ LST (CONS (CONS (CAAR L) (CONS (CAAAR L) (CDAAR L))) LST))) ((EQ (CAAR L) '/PUTHASH) (* ; "Pattern match.") (SETQ LST (CONS (LIST '/PUTHASH (CADAR L) (GETHASH (CADAR L) CLISPARRAY) CLISPARRAY) LST] (GO LP]) (CLISPATOM2 [LAMBDA NIL (* bvm%: "21-Nov-86 11:56") (* ;; "Assembles LISP forms from the CLISP expressions") (PROG ((PARENT PARENT) VAR1 VAR2 Z (UNARYFLG (GETPROP TYP 'UNARYOP)) (LISPFN (GETPROP TYP 'LISPFN)) TEM NEGFLG (CLISPCLASS (GETPROP TYP 'CLISPCLASS)) ENDTAIL-1) (AND (NEQ TYP (CAR TAIL)) UNARYFLG (SETQ TAIL (CDR TAIL))) (* ;; "On calls from CLISPATOM1A, TYP is always CADR of TAIL. e.g. in X+Y 'Z, on the call to CLISPATOM2 to process ', TAIL would be (IPLUS X Y) ' Z.") [COND ((AND (SETQ TEM (GETP (CAR ENDTAIL) 'CLISPBRACKET)) (EQ (CAR ENDTAIL) (CADR TEM))) (SETQ ENDTAIL-1 ENDTAIL) (SETQ ENDTAIL (CDR ENDTAIL] [COND ((AND (NOT (EQ 0 BRACKETCNT)) (EQ CLTYP 'BRACKET)) (DWIMERRORRETURN (LIST [LIST 'BRACKET (COND ((MINUSP BRACKETCNT) (CAR BRACKET)) (T (CADR BRACKET] PARENT))) ((NULL (CDR TAIL)) (DWIMERRORRETURN 1)) ((NULL ENDTAIL)) [(AND (NULL FORMSFLG) (GETPROP (CAR ENDTAIL) 'CLISPTYPE)) (COND ((NEQ TAIL PARENT)) ([OR (NULL (GETPROP (CAR ENDTAIL) 'UNARYOP)) (AND (EQ (CAR ENDTAIL) '~) (GETPROP (CADR ENDTAIL) 'CLISPTYPE] (* ; "X+Y~=Z is OK.") ) ((AND UNARYFLG (CLISPATOM2C TAIL)) (* ; "E.G. (~FOO 'X Y) is OK.") ) (T (* ; "E.G. (X + Y ' Z)") (DWIMERRORRETURN (LIST 2 ENDTAIL PARENT] [(AND (NULL FORMSFLG) (EQ PARENT TAIL)) (* ;; "An missing operand error is going to be generated if something isnt done in the next COND, e.g (X*Y Z)") (COND ((AND ENDTAIL DWIMIFYFLG (EQ CLISPCONTEXT 'IFWORD) (CLISPRESPELL ENDTAIL CLISPIFWORDSPLST)) (* ; "Found a correction; tell CLISPIF to try again.") (CL:THROW 'CLISPIF0 :RESPELL)) [(AND ENDTAIL (CLISPRESPELL ENDTAIL CLISPINFIXSPLST)) (* ;; "E.g. (X + Y LSS Z). Note that we do not try to correct spelling on infixes unless the form is otherwise going to cause an eror, e.g. in (FOO X_Y ORR --), the ORR is not checked for here. Thus in the event that the next thing on ENDTAIL is a CLISP transformation, e.g. (FOO X_Y Z_W), we do not have to do any extra work. This algorithm contains the implicit assumption that all the operatrs on CLISPINFIXSPLST (i.e. the ones we correct for) will terminate the scope of all non-broadscope operators. Otherwise, if FOO is a non-broadscope operator, and FIE would not terminate FOO, and FIE is on CLISPINFIXSPLST, the form (LIST A FOO B FIEE C) would parse as (LIST (A FOO B) FIE C), which is wrong. In this case, not only would we have to backup to CLISPATOM1 using RETEVAL as in CLIPATOMB, we would also have to check for misspelled operaaors appearng in CAR of ENDTAIL even when an error would not otherwise be generated, e.g. in (LIST X_Y Z_W) we would have to check the spelling of Z_W. Note that when the current operator is broadscope, we always perform spelling correction (via the call to DWIIFY! in CLISPTOM2B) since once parentheses are inserted, we can't distinguish e.g. (X AND Y ORR Z) from (X AND (Y ORR Z)).") (COND (DWIMIFYFLG (CL:THROW (COND ((LISTP CLISPCONTEXT) (* ;; "We want to go back to the clispatom1 above this call to wtfix, e.g. consider X AND Y_T ORR Z. In this case, we are dwimifying (Y_T ORR Z) but we want to go back to higher level. Used to do this via (RETDWIM0 'CLISPATOM1 (RETDWIM0 'WTFIX)), but now we just tell WTFIX to throw again.") 'WTFIX) (T 'CLISPATOM1)) :RESPELL] ([CLISPATOM2C (COND (UNARYFLG TAIL) (T (CDR TAIL] (* ; "E.G. FOO_GETP 'FIE 'EXPR") ) (T (* ; "E.g. (LIST * X Y)") (DWIMERRORRETURN (LIST 2 ENDTAIL PARENT] ((CLISPATOM2C (COND (UNARYFLG TAIL) (T (CDR TAIL] (COND ((EQ CLTYP 'BRACKET) (* ;; "Note that as currently implemented, ENDTAIL can be NIL. i.e. there is no check for whether or not matching > where actually found. This enables user to insert expressions like <, the scope may include the entire IF statement, e.g. IF A THEN ((FOO X) AND Y)") (SETQ BACKUPFLG T) (SETQ TAIL TEM))) (COND ((OR (NULL DWIMIFYFLG) (NULL CLISPCHANGE)) (CLISPBROADSCOPE1 TAIL PARENT BACKUPFLG] B (SETQ VAR1 (CAR TAIL)) (SELECTQ TYP (%: (AND LISPFN (GO C)) (* ; "means user has redefined : as a normal lisp operator") (SETQ Z (CLISPCAR/CDR (SETQ TEM VAR2))) (* ;; "the value returned by CLISPCAR/CDR indicates whether there was more than one operator involved, and is used to set CLISPCHANGE below.") (SETQ TEM (CLISPATOM2D NIL VAR1)) (* ; "Inserts new expressioninto TAIL.") (COND (DWIMIFYFLG (AND CLISPCHANGE (GO OUT)) (SETQ CLISPCHANGE TEM)) ((NOT (ATOM (CADR VAR2))) (GO OUT))) (CLISPATOM2A (CDR VAR2) VAR2) (AND TENTATIVE Z (SETQQ TENTATIVE PROBABLY)) (* ; "Means there was more than one : operator.") (GO OUT)) (_ [COND ((NLISTP VAR1) (SETQ TEM TYP)) (T (* ; "_ in connection with a : operator.") [SETQ TEM (SELECTQ (CAR VAR1) (CAR 'RPLACA) (CDR 'RPLACD) ((NCONC NCONC1) (CAR VAR1)) ((replace REPLACE) (* ; "From record declaration assigmnent.") (CLISPATOM2D NIL (CLISPRECORD VAR1 VAR2 T)) (* ; "Where the right hand operand to the _ will be DWIMIFIED, and TENTATIVE set, etc.") (GO C1)) (COND ([OR (SETQ TEM (GETPROP (CAR VAR1) 'SETFN)) (PROGN (DWIMIFY1? VAR1) (SETQ TEM (GETPROP (CAR VAR1) 'SETFN] (* ;; "E.G. User converts X \ FOO to (GETP X FOO), and puts PUT on SETFN of GETP, so that X \ FOO_T becomes (PUT X FOO T)") (CLISPATOM2D NIL (CONS (CLISPLOOKUP TEM (CADR VAR1)) (APPEND (CDR VAR1) VAR2))) (* ;; "SETFN. Must be handled this way because VAR1 may correspond to more than one operand, e.g. X \ FOO_T -> (ELT X FOO) _T and must go to (SETA X FOO T)") (GO C1)) (T (DWIMERRORRETURN '_] (SETQ LISPFN (GETPROP TEM 'LISPFN)) (SETQ VAR1 (CADR VAR1] (SETQ LISPFN (CLISPLOOKUP TEM VAR1 NIL LISPFN)) [COND ((AND (EQ LISPFN 'SETQ) (EQ (CAR VAR2) '%') (NULL (CDDR VAR2))) (* ; "Last AND clause to detect FOO _ ' FIE : 2 type of operations.") (SETQQ LISPFN SETQQ) (SETQ VAR2 (CDR VAR2] (COND ((AND TYPE-IN? (EQ VAR1 ')) (PRIN1 '= T) (PRINT (SETQ VAR1 LASTWORD) T T))) (GO INSERT)) NIL) C (SETQ LISPFN (CLISPLOOKUP TYP VAR1 (CAR VAR2) LISPFN)) (COND (UNARYFLG [SETQ VAR1 (COND ((CDR VAR2) (* ; "E.g. NOT is a unary operator which may take more than one expression, e.g. NOT A = B") VAR2) ((AND TYPE-IN? (EQ LISPFN 'QUOTE) (EQ (CAR VAR2) ')) (PRIN1 '= T) (PRINT LASTWORD T T)) (T (CAR VAR2] (SETQ VAR2 NIL) (GO INSERT))) [SETQ TEM (COND ((AND VAR2 (NULL (CDR VAR2))) (CAR VAR2] (* ; "TEM is the right-hand argument, if it is a single item.") (COND ((SELECTQ LISPFN (EQ (COND ((AND VAR2 (NULL (CDR VAR2)) (NULL (CAR VAR2))) (SETQQ LISPFN NULL)))) (IPLUS (COND ((AND (LISTP VAR1) (EQ (CAR VAR1) 'IPLUS)) (* ; "Leave asis, so X+Y+1 goes to (IPLUS X Y 1) instead of (ADD1 (IPLUS X Y))") NIL) ((EQ TEM 1) (SETQQ LISPFN ADD1)) ((EQ TEM -1) (SETQQ LISPFN SUB1)))) (IDIFFERENCE (COND ((AND (LISTP VAR1) (EQ (CAR VAR1) 'IPLUS) (NULL (CDR VAR2))) [SETQ VAR2 (LIST (COND ((NUMBERP (CAR VAR2)) (MINUS (CAR VAR2))) (T (LIST 'IMINUS (CAR VAR2] (SETQQ LISPFN IPLUS) NIL) ((EQ TEM 1) (SETQQ LISPFN SUB1)))) NIL) (SETQ VAR2 NIL))) INSERT (SETQ TEM (CLISPATOM2D LISPFN (CONS VAR1 VAR2))) (COND ((AND PARENT (ATOM PARENT)) (CLISPATOM2A TAIL TAIL) (GO OUT))) (* ;; "Corresponds to the case where the entire expression became an atom, e.g. X~=NIL gging to X, or --- 3 going to -3.0") (SETQ Z (CDR PARENT)) (* ;; "Z is used to find the operands for DWIMIFYING. It is now set so that CAR of it coresponds VAR1 and CADR of it coresponds CAR of VAR2.") (COND ((CLISPNOEVAL LISPFN) (AND DWIMIFYFLG (SETQ CLISPCHANGE TEM)) (GO NEG)) (DWIMIFYFLG (AND CLISPCHANGE (NULL UNARYFLG) (GO C1)) (* ;; "If CLISPCHANGE is T and this is not a UNARY operation, the first operand has already been dwimified.") (SETQ CLISPCHANGE TEM)) ((NOT (ATOM (CAR Z))) (GO C1))) (AND (NEQ LISPFN 'SETQ) (CLISPATOM2A Z PARENT)) (* ;; "Dwimifies VAR1, e.g. ((A+B) *C). If CLISPCHANGE is T, VAR1 has already been processed, e.g. A*B+C, becomes ((ITIMES A A) + C), and the A and B have already been checked by the first call to CLISPATOM2. VAR1 is also dwimified when running provided it is atomic. so that if it or VAR2 is unbound, an alternate correction will be tried, e.g. mistyping a variable named FOO-1 as FOOO-1.") C1 [COND (UNARYFLG (GO C2)) ((AND (LISTP VAR1) (EQ LISPFN (CAR VAR1)) (FMEMB LISPFN '(AND OR IPLUS ITIMES FPLUS FTIMES PLUS TIMES)) (NEQ VAR1 (CAR CLISPLASTSUB))) (* ;; "Handles nospreads, e.g. A+B+C becomes (IPLUS A B C) Note that where necessary, VAR1 has already been dwimified. The CLISPLASTSUB check is to prevent parens from beig taken out when VAR1 is the result of an IS PHRASE since this is needed later.") (CLRPLNODE Z (CADR VAR1) (APPEND (CDDR VAR1) VAR2] (SETQ Z VAR2) (COND ((OR DWIMIFYFLG (LITATOM (CAR Z))) (CLISPATOM2A Z PARENT))) C2 (* ; "Z is now set so that it corresponds to the right hand argument of the oprator.") (COND ([AND Z (SETQ CLTYP (GETPROP (SETQ LISPFN (CAR Z)) 'CLISPTYPE] (* ; "The second operand is itself an operator, e.g. a+*b.") (COND ([OR (NULL (CDR Z)) (NULL (GETPROP LISPFN 'UNARYOP] (* ; "The GETP check is because this is not an error if the operator is unary.") (DWIMERRORRETURN 2))) (CLISPATOM1A LISPFN CLTYP Z ENDTAIL) (* ;; "If ENDTAIL is non-nil, the LDIFF copied this portion of TAIL, so it is not necessary to do any saving.") ) ((NULL (CDR Z))) ((SETQ CLTYP (GETPROP (SETQ LISPFN (CADR Z)) 'CLISPTYPE)) (CLISPATOM1A LISPFN CLTYP Z ENDTAIL))) NEG [COND (NEGFLG (* ; "An operator was negated, e.g. X ~MEMB y") (CLRPLNODE PARENT 'NOT (LIST (CONS (CAR PARENT) (CDR PARENT] [COND ([AND (EQ (CAR PARENT) 'NOT) (LISTP (SETQ TEM (CADR PARENT))) (NOT (EQUAL PARENT (SETQ TEM (NEGATE TEM] (* ;; "Special stuff for negation. Done fter everything to take care of both X~=Y, and ~ (EQ X Y) in the same way.") [COND ((EQ PARENT (CAR TAIL)) (CLRPLNODE TAIL TEM (CDR TAIL))) ((LISTP TEM) (CLRPLNODE TAIL (CAR TEM) (CDR TEM] (AND TENTATIVE (SETQQ TENTATIVE PROBABLY] OUT (RETURN TAIL]) (CLISPNOEVAL [LAMBDA (FN DEFAULT) (* lmm "29-Jul-86 00:00") (* ;; "returns true if FN doesn't evaluate its args. If not sure, return DEFAULT") (PROG (TEM) [COND ((SETQ TEM (FASSOC FN DWIMEQUIVLST)) (SETQ FN (CDR TEM] (RETURN (AND (SELECTQ (ARGTYPE FN) ((1 3) (* ; "NLAMBDA") T) (NIL (* ; "udf -- see what else we know about it") (OR (FMEMB FN NLAMA) (FMEMB FN NLAML) (COND ((NOT (OR (GETPROP FN 'MACRO-FN) (GETLIS FN MACROPROPS))) DEFAULT) [DWIMINMACROSFLG (* ; "Macros are treated as LAMBDA forms unless INFO prop says otherwise") (RETURN (EQMEMB 'NOEVAL (GETPROP FN 'INFO] (T T)))) (OR (FMEMB FN NLAMA) (FMEMB FN NLAML))) (NOT (EQMEMB 'EVAL (GETPROP FN 'INFO]) (CLISPLOOKUP [LAMBDA (WORD $VAR1 $VAR2 $LISPFN) (* lmm "20-May-84 19:08") (* ;; "In most cases, it is not necessary to do a full lookup. This is quick an dirty check inside of the block to avoid calling CLISPLOOKUP0 It will work whenever there are no local declarations.") (PROG (TEM CLASS CLASSDEF) (SETQ CLASS (GETPROP WORD 'CLISPCLASS)) (SETQ CLASSDEF (GETPROP CLASS 'CLISPCLASSDEF)) (* ;; "used to be getprop word, but this meant GT worked differently than gt. also this new way is consistent with clispifylooup. shuld it bb (OR (getprop word) (getprop class))?") [SETQ TEM (COND ((AND CLASSDEF (SETQ TEM (GETLOCALDEC EXPR FAULTFN))) (* ;; "must do full lookup. Note that it is not necessary to do a call to CLISPLOOKUP0 if word has a CLASS, but no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these are ued as infix operators, they mean the corresponding functin regardless of declaraton. I.e. The CLASSDEF property says that this is the name of an infix operator. The CLASS property is used as a back pointer to the name of the operator/class of which this word is a member.") (CLISPLOOKUP0 WORD $VAR1 $VAR2 TEM $LISPFN CLASS CLASSDEF)) (T (SELECTQ CLASS (VALUE (RETURN (GETATOMVAL WORD))) ((RECORD RECORDFIELD) (RETURN NIL)) (OR $LISPFN (GETPROP WORD 'LISPFN) WORD] [COND ([AND (EQ (CAR CLASSDEF) 'ARITH) (EQ TEM (CADR CLASSDEF)) (OR [COND ((NLISTP $VAR1) (FLOATP $VAR1)) (T (EQ (CAR $VAR1) (CADDR CLASSDEF] (COND ((NLISTP $VAR2) (FLOATP $VAR2)) (T (EQ (CAR $VAR2) (CADDR CLASSDEF] (SETQ TEM (CADDR CLASSDEF] (RETURN TEM]) (CLISPATOM2A [LAMBDA (TAIL PARENT) (* lmm "21-Jun-85 16:49") (AND TAIL (NULL BROADSCOPE) (PROG ((DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (CLISPCONTEXT (AND DWIMIFYFLG CLISPCONTEXT)) DWIMIFYCHANGE TEM) (* ;; "If BROADSCOPE is T, everything has already been dwimified. See comments in clispatm2 and clispatom2b1") (* ;; "CLISPATOM2A sets up state variables itself rather than calling DWIMIFY1? or DWIMIFY2? because it wants to be able to add to NOFIXVARSLST0.") (COND ((NULL DWIMIFYFLG) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) [SETQ TEM (COND ((OR (AND (NEQ TYP '_) (NEQ TYP '¬)) (LISTP VAR1)) (* ; "VAR1 is a list when the _ is a record expression.") 'DONTKNOW) ((OR (FMEMB VAR1 VARS) (FMEMB VAR1 NOFIXVARSLST0)) 'PROBABLY) ((OR (BOUNDP VAR1) (AND (NULL DWIMIFYING) (STKSCAN VAR1 FAULTPOS)) (GETPROP VAR1 'GLOBALVAR) (FMEMB VAR1 GLOBALVARS)) (* ; "Added to NOFIXVARSLST0 so will be avilable for spelling correction in the future.") (SETQ NOFIXVARSLST0 (CONS VAR1 NOFIXVARSLST0)) 'PROBABLY) ([AND (NEQ CLISPCONTEXT 'FOR/BIND) (EQ VAR1 (CADR PARENT)) (NEQ NOSPELLFLG T) (OR (NULL NOSPELLFLG) TYPE-IN?) (OR [AND VARS (SETQ TEM (FIXSPELL VAR1 NIL VARS NIL NIL NIL NIL NIL T 'MUSTAPPROVE] (SETQ TEM (FIXSPELL VAR1 NIL SPELLINGS3 NIL NIL NIL NIL NIL T 'MUSTAPPROVE] (* ;; "FIXSPELL is called instead of CLISPRESPELL because we dont want runon corrections, and also we have performed msot of the checks of CLISPRESPELL.") (CLRPLNODE (CDR PARENT) TEM (CDDR PARENT)) 'CERTAINLY) (T (SETQ NOFIXVARSLST0 (CONS VAR1 NOFIXVARSLST0)) (* ; "Added to NOFIXVARSLST0 so that it will be available for spelling correction in the future.") 'DONTKNOW] (RETURN (COND [(LISTP (CAR TAIL)) (COND ((NEQ CLISPCONTEXT 'LINEAR) (DWIMIFY1 (CAR TAIL))) (T (CAR TAIL] ([AND TAIL (CAR TAIL) (LITATOM (CAR TAIL)) (NOT (GETPROP (CAR TAIL) 'CLISPTYPE] (* ; "We already know that the atom has no operators internal to it, having scanned through it earlier.") (SETQ CLISPCONTEXT NIL) (COND ((AND (NULL (DWIMIFY2 TAIL PARENT T NIL T 'NORUNONS)) (NULL TENTATIVE) (FMEMB TYP CLISPCHARS)) (SETQ TENTATIVE TEM]) (CLISPBROADSCOPE [LAMBDA ($TYP L CONTEXT) (* lmm "29-Jul-86 00:26") (PROG ((BRACKETCNT 0) (L0 L)) LP [COND ((NULL L) (COND ((NULL (CDR L0)) (CLISPBROADSCOPE1 L0 CONTEXT)) (T (CLRPLNODE L0 (CONS (CAR L0) (CDR L0)) NIL) (CLISPBROADSCOPE1 L0 CONTEXT T))) (RETURN)) ((AND (EQ (CAR L) '<) (GETP '< 'CLISPTYPE)) (SETQ BRACKETCNT (ADD1 BRACKETCNT))) ((AND (EQ (CAR L) '>) (GETP '> 'CLISPTYPE)) (SETQ BRACKETCNT (SUB1 BRACKETCNT))) ((AND (EQ (CAR L) $TYP) (ZEROP BRACKETCNT)) (COND ((EQ L (CDR L0)) (CLISPBROADSCOPE1 L0 CONTEXT) (SETQ L0 (SETQ L (CDR L))) (GO LP)) (T (CLRPLNODE L0 (LDIFF L0 L) L) (CLISPBROADSCOPE1 L0 CONTEXT T) (SETQ L0 (SETQ L (CDR L))) (GO LP] (SETQ L (CDR L)) (GO LP]) (CLISPBROADSCOPE1 [LAMBDA (X CONTEXT FLG) (PROG (TEM) (RETURN (COND [(NLISTP (CAR X)) [SETQ TEM (DWIMIFY2? (SETQ TEM (LIST (CAR X))) TEM TEM NIL NIL NIL (COND ((EQ CONTEXT 'IS) 'IS) (T (* ;; "Reason for the OR is to handle things like X IS A NUMBER AND NOT LT Y. In this case would be dwimifying (NOT LT Y) but when go to dwimify (NOT) want CLISPATOMIS? to be able to se the higher context.") (OR (AND DWIMIFYFLG (LISTP CLISPCONTEXT )) CONTEXT] (FRPLACA X (COND ((CDR TEM) TEM) (T (CAR TEM] ((EQ CONTEXT 'IS) (DWIMIFY2? (CAR X) (CAR X) (CAR X) NIL NIL NIL CONTEXT)) (T (* ;; "FLG says that the parens were inserted here, so that CONTEXT should be passed on to DWIMIFY1 in case there is a spelling error, e.g. (TAIL AND Y ORR Z) gets handled differently than (TAIL AND Y OR Z)") (DWIMIFY1? (CAR X) (AND FLG CONTEXT]) (CLISPATOM2C [LAMBDA (TAIL0) (* lmm "20-May-84 19:55") (* ;; "Checks for the case where user leaves out arentheses in front of functon name that follows an operator, e.g. (LIST X+ADD1 Y)") (SETQ TAIL0 (CDR TAIL0)) (* ; "TAIL0 is as of the right hand operand.") (COND ([AND (NEQ TYP '%') (NEQ TYP '%:) (NEQ TYP '<) (AND (LITATOM (CAR TAIL0)) (NULL (GETPROP (CAR TAIL0) 'UNARYOP)) (CLISPFUNCTION? TAIL0 'NOTVAR [FUNCTION (LAMBDA (X Y) (CONCAT [COND ((EQ (CDR Y) (CDAR Y)) (* ; "Unary operator") (CAAR Y)) (T (CONCAT (RETDWIM2 (CAAR Y)) (COND ((EQ (CADAR Y) '+-) '-) (T (CADAR Y] (SUBSTRING (RETDWIM2 (CDR Y)) 2 -1] [FUNCTION (LAMBDA (X Y) (CONCAT [COND ((EQ (CDR Y) (CDAR Y)) (* ; "Unary operator") (CAAR Y)) (T (CONCAT (RETDWIM2 (CAAR Y)) (COND ((EQ (CADAR Y) '+-) '-) (T (CADAR Y] [RETDWIM2 (COND [(LISTP X) (CONS (CAR X) (CONS (CDR X) (CDDR Y] (T (CONS X (CDDR Y] '")"] (CONS TAIL TAIL0] (* ;; "The GETP check is for situations like (LIST X_'FOO Y) i.e. a unary operator could never take care of the rest of the list.") (/RPLNODE TAIL0 (CONS (CAR TAIL0) (CDR TAIL0))) (SETQ ENDTAIL NIL) (* ; "Once you print a message, you dont want to go and try another interpretation.") (SETQQ TENTATIVE CERTAINLY]) (CLISPATOM2D [LAMBDA (X Y) (* ;; "Inserts new expression into TAIL. Value is T if expression was not parenthesized, PARTIAL if it was, i.e. if it corresponded to the new CAR of TAIL. If X is NIL, Y is the whole expression.") (COND ((AND (NULL ENDTAIL) (NULL FORMSFLG) (OR (NULL PARENT) (EQ PARENT TAIL))) (* ;; "This is the case in which we do not want to 'subordinate' the expression with an extra pair of parentheses. E.g. (LIST (A+B)). The ENDTAIL check is necessary because if it is not NIL, there are more expressions following the first one, e.g. (LIST (A*B+C)) and we must keep this expression separate, i.e. make (A*B+C) become ((ITIMES A A) + C)") (COND ((NULL X) (* ;; "Y is the entire expression to be inserted, but we can't use it because we have to 'take out' the parentheses.") (CLRPLNODE TAIL (CAR Y) (CDR Y)) (AND (SETQ X (GETHASH Y CLISPARRAY)) (CLISPTRAN TAIL X)) (* ;; "Must move translation to new expression. This only occurs if the expression is enclosed in prentheses, e.g. (X: (--))") (AND (EQ Y (CAR CLISPLASTSUB)) (FRPLACA CLISPLASTSUB TAIL)) (* ;; "Y is the expression returned by CLISPATOMIS but it is not going to apear in the new expression, so must change clisplastsub to correspnd") ) (T (CLRPLNODE TAIL X Y))) (SETQ PARENT TAIL) T) (T (* ; "Here we must parenthesize the expression so as to subordinate it.") [SETQ Y (COND ((NULL X) Y) ((AND (EQ TYP '-) (NUMBERP (CAR Y))) (MINUS (CAR Y))) (T (CONS X Y] (CLRPLNODE TAIL Y ENDTAIL) (* ; "ENDTAIL being all the stuff not belonging to the CLISP expression, i.e. beyond its scope.") (SETQ PARENT (CAR TAIL)) 'PARTIAL]) (CLISPCAR/CDR [LAMBDA (LST) (* lmm "21-Jun-85 16:50") (* ;; "Handles the : infix operatr.") (PROG ([SETQFLG (OR (EQ (CAR ENDTAIL) '_) (EQ (CAR ENDTAIL) '¬] TAILFLG N TEM VAL) (SETQ VAR2 NIL) LP (SETQ TAILFLG NIL) [COND ((EQ (CAR LST) '%:) (* ; "Tail") (SETQ TAILFLG T) (SETQ LST (CDR LST] (COND ((NULL LST) (SETQ VAR1 (LIST (COND ((NULL SETQFLG) (GO ERROR)) (TAILFLG (* ; "X::_") 'NCONC) (T 'NCONC1)) VAR1)) (RETURN VAL))) (COND ((EQ (SETQ N (CAR LST)) '-) (COND ([NOT (NUMBERP (SETQ N (CADR LST] (GO ERROR))) (SETQ N (MINUS N)) (SETQ LST (CDR LST)) (GO NEG)) ((NOT (NUMBERP N)) [COND (TAILFLG (GO ERROR)) ((LISTP N) (SETQ VAR1 (LIST 'match VAR1 'with N)) (COND ((OR (EQ (CADR LST) '->) (EQ (CADR LST) '=>)) (NCONC VAR1 (CDR LST)) (DWIMIFY2? (SETQ TEM (CDDR LST)) VAR1 TEM) (SETQ LST NIL))) (CLISPTRAN VAR1 (MAKEMATCH VAR1)) (AND (NULL VAR2) (SETQ VAR2 VAR1))) [[SETQ TEM (CLISPRECORD VAR1 N (AND SETQFLG (NULL (CDR LST] (SETQ VAR1 TEM) (AND (NULL VAR2) (SETQ VAR2 (NLEFT VAR1 2] ((SETQ TEM (GETPROP N 'ACCESSFN)) (SETQ VAR1 (LIST TEM VAR1)) (AND (NULL VAR2) (SETQ VAR2 VAR1))) (T (DWIMERRORRETURN 'FIELDNAME] (GO LP2)) ((ILESSP N 0) (GO NEG))) LP1 [COND ((AND (IGREATERP N 4) (ILESSP N 9)) (* ; "X:N for N greater than 8 goes to (NTH X N)") (SETQ N (IPLUS N -4)) (SETQ VAR1 (LIST 'CDDDDR VAR1)) (AND (NULL VAR2) (SETQ VAR2 VAR1)) (* ; "VAR2 marks the TAIL where the original operand appears, so thaadwimifying will continue from there.") (GO LP1)) ((AND SETQFLG (NULL (CDR LST))) (SETQ VAR1 (CLISPCAR/CDR1 1 (CLISPCAR/CDR1 (SUB1 N) VAR1 T) TAILFLG T))) (T (SETQ VAR1 (CLISPCAR/CDR1 N VAR1 TAILFLG] LP2 (COND ((NULL (SETQ LST (CDR LST))) (RETURN VAL)) ((EQ (CAR LST) '%:) (SETQ VAL T) (SETQ LST (CDR LST)) (GO LP))) ERROR [DWIMERRORRETURN (COND (TAILFLG '|::|) (T '%:] NEG (COND ((AND SETQFLG (NULL (CDR LST)) TAILFLG) [SETQ VAR1 (LIST 'NLEFT VAR1 (ADD1 (IMINUS N] (AND (NULL VAR2) (SETQ VAR2 VAR1)) (SETQ VAR1 (LIST 'CDR VAR1)) (RETURN VAL))) [SETQ VAR1 (COND ((EQ N -1) (LIST (CLISPLOOKUP 'LAST VAR1) VAR1)) (T (LIST 'NLEFT VAR1 (IMINUS N] (AND (NULL VAR2) (SETQ VAR2 VAR1)) [COND ((NULL TAILFLG) (SETQ VAR1 (LIST 'CAR VAR1] (GO LP2]) (CLISPCAR/CDR1 [LAMBDA (N X TAILFLG SETQFLG) (* lmm "20-May-84 19:56") (* ;; "All three level car and cdr operations go back to the corresponding function, i.e. CDAAR clispifies to X:1:1::1 and goes back to CDAAR.") (PROG (TEM) (COND ((ZEROP N) (RETURN X)) ((AND (NULL DWIMIFYFLG) CHECKCARATOMFLG) (* ; "If CHECKCARATOMFLG is T, then checks to see if the car/cdr chain goes through an atom (non-list)") (CLISPCAR/CDR2 N X))) [SETQ TEM (COND ([AND (NULL SETQFLG) (LISTP X) (SETQ TEM (COND ((EQ N 1) (SELECTQ (CAR X) (CAR (* ;; "The apparent incompleteness of the SELECTQ is bcause CAR of CDR would appear in CLISS as 2 and be handled directly, similarly for CDR of CDR.") (COND (TAILFLG 'CDAR) (T 'CAAR))) (CAAR (* ;; "Similarly, CAR of CDAR would come in as CADR of CAR, CDR of CDAR as CDDR of CAR, so checks for CDAR and CDDR are not necessary.") (COND (TAILFLG 'CDAAR) (T 'CAAAR))) (CADR (COND (TAILFLG 'CDADR) (T 'CAADR))) NIL)) ((AND (EQ N 2) (EQ (CAR X) 'CAR)) (* ;; "CADR of CDR would be written as X:3, similaly CAAR of CDR, CDAR of CDR, and CDDR of CDR are all taken care of.") (COND (TAILFLG 'CDDAR) (T 'CADAR] (* ; "If SETQFLG is T, want to leave the outer CAR or CDR because gets replaced by rplaca/d later.") (FRPLACA X TEM)) [(IGREATERP N 4) (SETQ TEM (CLISPLOOKUP 'NTH VAR1)) (COND (TAILFLG (LIST TEM X (ADD1 N))) (T (SETQ TEM (LIST TEM X N)) (AND (NULL VAR2) (SETQ VAR2 TEM)) (LIST 'CAR TEM] ([NULL (SETQ TEM (FASSOC N '((1 CAR . CDR) (2 CADR . CDDR) (3 CADDR . CDDDR) (4 CADDDR . CDDDDR] (SHOULDNT 'CLISPCAR/CDR)) (TAILFLG (LIST (CDDR TEM) X)) (T (LIST (CADR TEM) X] (AND (NULL VAR2) (SETQ VAR2 TEM)) (RETURN TEM]) (CLISPCAR/CDR2 [LAMBDA (N X) (* lmm "20-May-84 19:56") (PROG ((NODE (STKEVAL FAULTPOS X))) LP [COND ((ZEROP N) (RETURN)) ((AND NODE (NLISTP NODE)) (DWIMERRORRETURN 'CARATOM] (SETQ NODE (CDR NODE)) (SETQ N (SUB1 N)) (GO LP]) (CLISPATOMIS1 [LAMBDA (SUBJ OBJ ALST EXP NEGATE) (* lmm "20-May-84 20:03") (* ;; "ALST is cdr of the value returned by clispmatchup. CAR is split into the two arguments SUBJ and OBJ.") (SELECTQ (CAR SUBJ) ((AND OR) [CONS (CAR SUBJ) (MAPCAR (CDR SUBJ) (FUNCTION (LAMBDA (X) (* ;; "The AND is bcause it is ok for NEGFLG to be T instead of LISTONLY on recursive calls, because (NOT (NULL X)) can go to X in this case since we have the tail to put it in.") (CLISPATOMIS1 X OBJ ALST EXP (AND NEGATE T]) (PROGN (SETQ EXP (SUBLIS (CONS (CONS OBJ SUBJ) ALST) EXP T)) (COND (NEGATE (NEGATE EXP)) (T EXP]) (CLISPATOMARE1 [LAMBDA (X FLG) (* lmm "29-Jul-86 00:27") (* ;; "value is an edit pushdown list (of tails) leding to the place of the last is subject.") (PROG (L TEM) (SETQ L (CDR X)) LP (COND ((EQ (CAR L) (CAR CLISPLASTSUB)) (RETURN (LIST L))) ((AND (LISTP (CAR L)) (SETQ TEM (SELECTQ (CAAR L) ((AND OR) (CLISPATOMARE1 (CAR L) FLG)) NIL))) (RETURN (NCONC1 TEM L))) ((SETQ L (CDR L)) (GO LP))) (RETURN NIL]) (CLISPATOMARE2 [LAMBDA (L Z) (* lmm " 4-SEP-83 23:07") (PROG (X X1) [COND ((NULL (CDR L)) (COND (Z (RETURN (CAR Z))) (T (* ; "E.g. X AND Y IS A NUMBER ARE ATOMS.") (DWIMERRORRETURN (LIST 'PHRASE (CDR TAIL) PARENT] (SETQ X (CAADR L)) (* ; "the parent of (CAR L)") (SETQ X1 (CDAR L)) [COND ((AND DEST (EQ (CAR L) (CDR X))) (* ;; "move inner expression out. case 1: (A OR B ARE NUMBERS AND C OR D ARE LISTS) VAR1 is (OR (AND (OR (NUMBERP A) (NUMBERP B)) C) D) but the AND is reaaly the top leveloperator. case 2: (A OR B IS A NUMBER AND C OR D ARE LISTS) VAR1 is (OR A (AND (NUMBERP B) C) D) here the OR should be the top leveloperator. The difference is that") (FRPLACA (CADR L) (CADR X))) (T (FRPLACD (CAR L] [COND ((AND X1 (NULL DEST)) (SETQ DEST (CAR L] (SETQ X1 (APPEND Z X1)) (RETURN (CLISPATOMARE2 (CDR L) (COND ((CDR X1) (LIST (CONS (CAR X) X1))) (T X1]) (CLISPATOMIS2 [LAMBDA (X) (* ; "wt: 25-FEB-76 1 51") (* ;; "Used by clispatomaRE and clispatomIis? to eliminate unnecessary nesting of ands and ors after finishing processing. (Too hard to do on the fly as we built pushdown list of tails etc.) NOte that we cant remove parens from around clisplastsub since it might be needed later in parsing. Thus X AND Y ARE NUMBERS AND GREATER THAN 3 must be left as (AND (NUMBERP X) (NUMBER Y) (AND (IGREATERP X 3) (IGREATERP Y 3)))") (PROG (($TYP (CAR X))) LP [AND (LISTP (CAR X)) (NEQ (CAR X) (CAR CLISPLASTSUB)) (COND ((EQ (CAAR X) $TYP) (CLRPLNODE X (CADAR X) (APPEND (CDDAR X) (CDR X))) (GO LP)) ((OR (EQ (CAAR X) 'AND) (EQ (CAAR X) 'OR)) (CLISPATOMIS2 (CAR X] (COND ((SETQ X (CDR X)) (GO LP]) ) (DEFINEQ (WTFIX [LAMBDA (FAULTX FAULTARGS FAULTAPPLYFLG) (* lmm "15-Apr-86 09:59") (PROG (FAULTPOS FAULTFN EXPR VARS TAIL PARENT SUBPARENT FORMSFLG ONLYSPELLFLG DWIMIFYFLG TEM) (RETURN (WTFIX1]) (WTFIX0 [LAMBDA (FAULTX TAIL PARENT SUBPARENT ONLYSPELLFLG) (* ;; "Internal entry from dwimify1 and dwimify2. EXPR, FAULTFN, VARS, TAIL, and FORMSFLG already correctly bound.") (PROG (FAULTARGS FAULTAPPLYFLG (FAULTPOS (COND ((NULL (AND DWIMIFYFLG DWIMIFYING)) (* ; "Originally started out evaluting, so there is a higher faultpos.") FAULTPOS))) (DWIMIFYFLG T)) (RETURN (WTFIX1]) (WTFIX1 [LAMBDA NIL (* bvm%: "21-Nov-86 18:37") (* ;; "Replaces FAULT1 when DWIM is on. on u.b.a.'s FAULTX is the atom. On u.d.f.'s involving forms, FAULTX is the form. On u.d.f.'s from APPLY, faultx is the name of the function, FAULTARGS the arguments, and FAULTAPPLYFLG is T. Also is called directly to process a form from DWIMIFY. In this case, EXPR, VARS, ..., NOSPELLFLG0 are supplied, and FINDFN is not called.") (AND DWIMFLG (LET [(RESULT (CL:CATCH 'WTFIX (XNLSETQ (PROG ((NOSPELLFLG0 NOSPELLFLG) (CLISPERTYPE) (DWIM.GIVE.UP.TIME (OR DWIM.GIVE.UP.TIME (SETUPTIMER DWIM.GIVE.UP.INTERVAL))) TYPE-IN? BREAKFLG FAULTXX CHARLST FAULTEM1 NEWTAIL HISTENTRY FIXCLK CLISPCHANGES SIDES) (* ; "LIST because this used to be a XNLSETQ. I think callers only want to know whether we returned something interesting, or somebody called (RETDWIM)") [COND (DWIMIFYFLG (* ;; "Call from WTFIX0. Note that while this call from DWIMIFY1 or DWIMIFY2, the user may or may not have been DWIMIFYING, e.g. when IF's are encountered in evaluation, DWIMIFY1 and DWIMIFY2 are used. The variable DWIMIFYING is T if the call to DWIMIFY! or DWIMIFY2 is from an explicit call to DWIMIFY (or DWIMIFYFNS)") (SETQ TYPE-IN? (EQ FAULTFN 'TYPE-IN)) (* ;; "DWIMIFY is called on typein for processing FOR's and IF's. In this case, want to treat user approval the same as for type-in.") ) (T (SETQ FIXCLK (CLOCK 2)) (* ;; "If EXPR is given, i.e. if DWIMIFYFLG is gong to be T, the clkock is being measured at some higher caal to WTFIX or DWIMIIY.") [SETQ FAULTPOS (STKPOS (COND (FAULTAPPLYFLG 'FAULTAPPLY) (T 'FAULTEVAL] (AND (NEQ CLEARSTKLST T) (SETQ CLEARSTKLST (CONS FAULTPOS CLEARSTKLST))) (* ; "In case user control-ds out of correction, this will relstk faultpos") (SETQ FAULTFN (FINDFN (FSTKNTH -1 FAULTPOS) T)) (* ;; "The value of FINDFN is the name of the (interpreted) function in which the error occurred. FINDFN also sets the free variable EXPR to the definition of that function. If the error occurred under a call to EVAL, the value of FINDFN is EVAL, and EXPR is set to the expression being evaluated, i.e. the argument to EVAL. If the error occurred under an APPLY, the value of FINDFN is the first argument to APPLY, and EXPR is set to the second argument to APPLY, i.e. the list of arguments. In this case, FAULTX will usually be EQ to the value returned by FINDFN, and FAULTARGS EQ to EXPR. However, WTFIX may also be called from FAULTAPPLY, and FINDFN not find an APPLY, as occurs on undefined functions called from compiled code. For this reason, FIXAPPLY always uses FAULTX and FAULTARGS, not FAULTFN and EXPR.") (SETQ VARS (AND (SETQ FAULTEM1 (OR BREAKFLG (LISTP EXPR))) (GETVARS FAULTEM1] [AND (NULL TYPE-IN?) (SETQ SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] (AND TYPE-IN? (NULL DWIMIFYFLG) [COND (FAULTAPPLYFLG (EQ FAULTX (CAAAAR LISPXHISTORY))) (T (OR (EQ FAULTX (CAAAAR LISPXHISTORY)) (EQUAL FAULTX (CAAAR LISPXHISTORY] (SETQ HISTENTRY (CAAR LISPXHISTORY))) [COND ([LITATOM (SETQ FAULTXX (COND (FAULTAPPLYFLG FAULTX) ((NLISTP FAULTX) FAULTX) (T (CAR FAULTX] (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST] (COND ((AND (NULL FAULTAPPLYFLG) (LITATOM FAULTX)) (FIXATOM) (SHOULDNT)) (FAULTAPPLYFLG (FIXAPPLY) (SHOULDNT)) ([AND TYPE-IN? (EQ FAULTXX (CAAR HISTENTRY)) (AND (NEQ NOSPELLFLG T) (AND (SETQ FAULTEM1 (FMEMB LPARKEY CHARLST)) (NULL (AND CLISPFLG (STRPOSL CLISPCHARRAY FAULTXX] (* ;; "LPARKEY is the lowercase version of left prentheses, normally 8, rparkey is normally 9, but user can reset them for different terminals. The EQ distinguishes between (CONS8ADD1 3) which is handled by a call to FIX89 from CLISPATOM, and FOO8A B C ']' , which is handled by FIX89TYPEIN, since it requires changing an EVAL to an APPLY.") (FIX89TYPEIN FAULTEM1 CHARLST)) ((AND CLISPFLG CHARLST (LITATOM (SETQ FAULTEM1 (CADR FAULTX))) (OR (GETPROP FAULTEM1 'CLISPTYPE) (FMEMB (SETQ FAULTEM1 (NTHCHAR FAULTEM1 1)) CLISPCHARS)) [OR (NOT (GETPROP FAULTEM1 'UNARYOP)) (AND (EQ FAULTEM1 '~) (GETPROP (PACK (CDR (DUNPACK (CADR FAULTX) WTFIXCHCONLST1))) 'CLISPTYPE] (NOT (CLISPNOTVARP (CAR FAULTX))) (CLISPNOTVARP (CADR FAULTX))) (* ; "So that things like (SUM + X) will work, i.e. not be interpreted as iterative statement.") (GO NX0)) ((NULL CHARLST) (GO NX2))) (* ; "Both FIXAPPLY and FIXATOM exit via RETDWIM so there is no need for a return here in WTFIX.") TOP [SELECTQ (CAR FAULTX) (F/L [/RPLNODE FAULTX 'FUNCTION (LIST (CONS 'LAMBDA (COND ([AND (CDDR FAULTX) [OR (NULL (CADR FAULTX)) (AND (LISTP (CADR FAULTX)) (EVERY (CADR FAULTX) (FUNCTION (LAMBDA (X) (AND X (NEQ X T) (LITATOM X] (OR (MEMB (CAADR FAULTX) (FREEVARS (CDDR FAULTX))) (NOT (CLISPFUNCTION? (CADR FAULTX) 'OKVAR] (CDR FAULTX)) (T (CONS (LIST 'X) (CDR FAULTX] (GO OUT)) (CLISP%: (ERSETQ (CLISPDEC0 FAULTX FAULTFN)) (SETQ FAULTX T)) (COND [[CAR (LISTP (SETQ FAULTEM1 (GETPROP (CAR FAULTX) 'CLISPWORD] (RESETVARS [(LCASEFLG (AND LCASEFLG (NULL TYPE-IN?] (SELECTQ (CAR FAULTEM1) (FORWORD (SETQ FAULTX (OR (CLISPFOR FAULTX) (RETDWIM)))) (IFWORD (SETQ FAULTX (CLISPIF FAULTX)) (SETQ HISTENTRY NIL)) (MATCHWORD (* ; "CAR of FAULTX either MATCH or match.") (CLISPTRAN FAULTX (MAKEMATCH FAULTX))) (PREFIXFN (PROG ((EXPR FAULTX)) (SETQ FAULTEM1 (CDR FAULTX)) [COND ((EQ (CAR (LISTP (CAR FAULTEM1))) 'CLISP%:) (ERSETQ (CLISPDEC0 (CAR FAULTEM1) FAULTFN] [COND ((EQ (CAR (LISTP (CAR FAULTEM1))) COMMENTFLG) (SETQ FAULTEM1 (CDR FAULTEM1] [SETQ FAULTEM1 (APPEND (COND [(AND (NULL (CDR FAULTEM1)) (LISTP (CAR FAULTEM1] (T FAULTEM1] (RESETVARS ((CLISPFLG T)) (DWIMIFY1? FAULTEM1)) (CLISPELL FAULTX) (CLISPTRAN FAULTX FAULTEM1))) (SETQ FAULTX (APPLY* (CAR FAULTEM1) FAULTX] (T (GO NX0] (AND DWIMIFYFLG (SETQ CLISPCHANGE T)) (GO OUT) NX0 (COND [(GETD (CAR FAULTX)) (COND ([NULL (PROG (TYPE-IN? (FAULTFN (CAR FAULTX))) (RETURN (COND ((FIXLAMBDA (GETD (CAR FAULTX))) (* ; "This is the case where (FOO --) is being evaluated, and the definition of FOO is bad.") (AND FILEPKGFLG (LITATOM FAULTFN) (MARKASCHANGED FAULTFN 'FNS)) T] (SETQ NOSPELLFLG0 T) (GO NX3) (* ; "So DWIMUSERFN can be called.") ] ((AND (OR (GETPROP (CAR FAULTX) 'EXPR) (GETPROP (CAR FAULTX) 'CODE)) (DWIMUNSAVEDEF (CAR FAULTX))) (SETQ FAULTFN NIL) (* ; "So that RETDWIM won't do a MARKASCHANGED") ) ((SETQ FAULTEM1 (GETPROP (CAR FAULTX) 'FILEDEF)) (COND ((WTFIXLOADEF FAULTEM1) (GO OUT))) (RETDWIM)) (T (GO NX1))) (GO OUT) NX1 (COND ((AND (CLISPNOTVARP (CAR FAULTX)) (SETQ FAULTEM1 (CLISPATOM CHARLST FAULTX FAULTX))) (* ; "E.g. (FOO_ATOM) OR (FOO_ form)") (SETQ FAULTX FAULTEM1) (GO OUT))) NX2 (COND ([AND CLISPFLG (SETQ FAULTEM1 (CADR FAULTX)) (OR (LITATOM FAULTEM1) (AND (NUMBERP FAULTEM1) (MINUSP FAULTEM1) (CLBINARYMINUS? FAULTX))) (OR (GETPROP FAULTEM1 'CLISPTYPE) (FMEMB (CAR (SETQ FAULTEM1 (DUNPACK FAULTEM1 WTFIXCHCONLST1))) CLISPCHARS)) (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) FAULTX T)) (COND [(OR (NEQ FAULTXX (CAR FAULTX)) (AND CLISPARRAY (GETHASH FAULTX CLISPARRAY] (DWIMIFYFLG (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST)) (* ; "LST may have been clobbered") (SETQ CLISPCHANGE NIL] (* ;; "E.g. (FOO _atom) or (FOO _ form). The NEQ check is necessary to handle situations like (FOOO N-1) where an CLISP transformation is performed, but it does not correct CAR of the form. (In this case, we must continue to the spelling correction part below, and set CLISPCHANGE to NIL so that DWIMIFY1 will not be confused.) Note that if FOO also happens to be the name of a function, then WTFIX will not be called and the CLISP transformation not be performed until the arguments of FOO are evaluated and cause a u.b.a. error. Then DWIM will have to back up as described in FIXATOM and FIXATOM1.") (SETQ FAULTX FAULTEM1) (GO OUT)) ((AND (NULL NOSPELLFLG0) DWIMIFYFLG (LISTP (CADR FAULTX)) (FIXLAMBDA FAULTX)) (* ;; "The DWIMIFYFLG check is because in normal course of events, it never makes sense for LAMBDA to appear as CAR of a FORM. However, DWIMIFY1 is called on open LAMBDA expressions.") (GO OUT)) ((AND (NULL NOSPELLFLG0) (LISTP (CAR FAULTX)) (LISTP (CADAR FAULTX)) (FIXLAMBDA (CAR FAULTX))) (* ;; "This corresponds to the case where LAMBDA is misspelled in an open LAMBDA expression. Note that an open lambda expression only makes sense when there is a non-atomic argument list, so dont both spelling correcting if this is notthe case.") (GO OUT))) NX3 (COND [[SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) (SETQ FAULTEM1 (EVAL DWIMUSERFORM] (COND (FAULTAPPLYFLG (RETDWIM FAULTPOS FAULTEM1 T FAULTARGS)) (T (RETDWIM FAULTPOS FAULTEM1] (NOSPELLFLG0 (GO FAIL)) [[AND CHARLST (SETQ FAULTXX (OR (FIXSPELL (CAR FAULTX) NIL SPELLINGS2 NIL FAULTX NIL NIL NIL T) (AND DWIMIFYFLG NOFIXFNSLST0 (FIXSPELL (CAR FAULTX) NIL NOFIXFNSLST0 NIL FAULTX NIL NIL NIL T] (* ; "The extra argument to FIXSPELL indicates that SPLITS re tolerated, e.g. (BREAKFOO)") (COND ((EQ (CAAR HISTENTRY) (CAR FAULTX)) (/RPLNODE HISTENTRY FAULTX (CDR HISTENTRY)) (* ;; "Normally, RETDWIM patches the histroy entry to corresond to a list input, even if it was typed in as a line. In the special case of a pselling correction, we leave the entry as a line.") )) (SETQ HISTENTRY NIL) (COND ((NOT (FGETD FAULTXX)) (* ; "E.g. USER misspells FOR, IF, F/L etc. These are all contained on SPELLINGS2.") (GO TOP] ((AND CLISPFLG DWIMIFYFLG (CDR FAULTX) (LISTP CLISPCONTEXT) (FIXSPELL (CAR FAULTX) NIL CLISPISWORDSPLST NIL FAULTX NIL NIL NIL T) (SETQ FAULTEM1 (CLISPATOM (DUNPACK (CAR FAULTX) WTFIXCHCONLST) TAIL PARENT)))(* ;; "E.g. X IS A NUMBER AND LESS THAN Y. CLISPATOM will call CLISPATOMIS? which will retfrom back past here or generate an error. NOte that if (CAR FAUULTX) had been spelled correctly, thiswold have happened in first call to CLISPATOM at NX1 earlir. However, we dont do the misspelled check until here because it is more likely user has misspelled the name of one of his functions.") ) ([AND CLISPFLG (NULL CLISPCHANGES) (NULL CLISPERTYPE) (SETQ FAULTEM1 (CADR FAULTX)) (LITATOM FAULTEM1) (SETQ FAULTEM1 (FIXSPELL FAULTEM1 NIL CLISPINFIXSPLST NIL (OR (AND DWIMIFYFLG (LISTP CLISPCONTEXT)) (CDR FAULTX)) NIL NIL NIL T)) (COND ((AND DWIMIFYFLG (LISTP CLISPCONTEXT)) (* ;; "Return from the corresponding DWIMUNDOCATCH with a value telling CLISPATOM to try again.") (CL:THROW 'CLISPATOM1 :RESPELL)) (T (LET (CLISPERTYPE) (SETQ FAULTEM1 (CLISPATOM FAULTEM1 (CDR FAULTX) FAULTX T] (SETQ FAULTX FAULTEM1)) (T (GO FAIL))) OUT (RETDWIM FAULTPOS FAULTX) FAIL (RETDWIM] (SELECTQ RESULT (:RESPELL (* ; "from CLISPATOM2 -- wants us to throw this message back to a higher CLISPATOM") (CL:THROW 'CLISPATOM1 :RESPELL)) (PROGN (* ; "something interesting to return, or a value from RETDWIM ") RESULT]) (RETDWIM [LAMBDA (POS X APPLYFLG ARGS) (* bvm%: "21-Nov-86 18:02") (PROG NIL [AND FIXCLK HELPCLOCK (SETQ HELPCLOCK (IPLUS HELPCLOCK (IDIFFERENCE (CLOCK 2) FIXCLK] (* ; "So time spent in DWIM will not count towards a break.") TOP [COND [(OR POS X) (* ; "Successful correction.") (AND (EQ (CAR SIDES) 'CLISP% ) [NCONC1 (CADR SIDES) (CDR (LISTGET1 LISPXHIST 'SIDE] (LISPXPUT '*LISPXPRINT* (LIST SIDES) T LISPXHIST)) (* ;; "Some messages were printed, and the undo informaton marked. This completes the process enabling user to undo just the effects associated with the dwim change corresponding to the message printed between (CADR of this mark) and the place where the mark appears. The use of CLISP makes the mark invisible to the editor, and also does not i nterefere with printing the event.") [COND ((AND DWIMIFYFLG DWIMIFYING) (SETQ DWIMIFY0CHANGE T)) (T (AND (NULL TYPE-IN?) (EXPRP FAULTFN) (DWIMARKASCHANGED FAULTFN SIDES] (COND (DWIMIFYFLG (SETQ DWIMIFYCHANGE T) (CL:THROW 'WTFIX X))) (COND ((NULL APPLYFLG) [COND (HISTENTRY (/RPLNODE HISTENTRY (LIST X) (CDR HISTENTRY)) (AND (ATOM X) (SETQ LASTWORD X] (RETEVAL POS (FIXLISPX/ X) T)) (T (AND HISTENTRY (/RPLNODE HISTENTRY (LIST X ARGS) (CDR HISTENTRY))) (RETAPPLY POS (FIXLISPX/ X) (FIXLISPX/ ARGS X) T] ((AND CLISPFLG DWIMIFYFLG FORMSFLG (NEQ NOSPELLFLG T) (OR (NULL NOSPELLFLG) TYPE-IN?) (EQ FAULTX (CAR TAIL)) (EQ TAIL PARENT) (STRPOSL CLISPCHARRAY (CAR TAIL)) (DWIMIFY2A TAIL CHARLST)) (* ;; "In the event that a parenthesis was left out, and (CAR TAIL) is really the name of a function (or misspelled function), spelling correction would nothave been attempted earlier in DWIMIFY2 until seeing if this was ok CLISP, so try it now. E.g. (IF A THEN FOOX-1), where FOO is name of a function, or (IF A THEN R/PLNODE X). Note that CLISPCHANGES might be NIL in the case that the clisp transformationdidn't go throuh, e.g. missing operand.") (/RPLNODE TAIL (CONS (CAR TAIL) (CDR TAIL))) (SETQ X (DWIMIFY1? (CAR TAIL))) (SETQ POS FAULTPOS) (GO TOP)) (CLISPCHANGES (COND (DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T))) (COND ((NULL (RETDWIM1 (CDDR CLISPCHANGES))) (RELSTK FAULTPOS) (ERROR!))) (SETQ X (CAR CLISPCHANGES)) [MAPC (CADR CLISPCHANGES) (FUNCTION (LAMBDA (X) (COND ((LISTP (CAR X)) (/RPLNODE (CAR X) (CADR X) (CDDR X))) (T (APPLY (CAR X) (CDR X] (SETQ POS FAULTPOS) (GO TOP)) (CLISPERTYPE (* ;; "Error messages are postponed till this point because what looks like a bad clisp expression may be interpreted correctly in a different way --- e.g. _PENP will correct to openp.") (AND DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T)) (* ;; "ATTEMPTFLG to inform DWIMMFY not to add FAUTX to NOFIXLST. CLISPCHANGE is to prevent analysing cdr of the form in the case the error occurred in CAR of the form.") (AND (OR DWIMIFYFLG (NULL TYPE-IN?)) (CLISPERROR CLISPERTYPE] (COND (DWIMIFYFLG (* ; "ERROR! instead of CL:THROW so that UNDONLSETQ changes are undone") (ERROR!)) (T (RELSTK FAULTPOS) [CL:THROW 'WTFIX (AND (NULL TYPE-IN?) (CONS FAULTFN (COND ((ATOM FAULTX) (RETDWIM2 PARENT TAIL)) (T (RETDWIM2 FAULTX NIL 2] (* ; "The vaue retunred by WTFIX is used on the call to OLDFAULT1 for printing out a message.") ]) (DWIMERRORRETURN [LAMBDA (ARG) (* lmm " 5-SEP-83 23:51") (AND ARG (SETQ CLISPERTYPE ARG)) (ERROR!]) (DWIMARKASCHANGED [LAMBDA (FN $SIDES) (* rmk%: "18-FEB-83 17:07") (* ;; "Informs the file package that FN has been changed, giving CLISP as the reason if we detect (because no messages were printed) that the only changes are because of valid clisp dwimifications. Otherwise, the reason is CHANGED") (AND (LITATOM FN) (PROG [(L (CDR (LISTGET1 LISPXHIST 'SIDE] LP (COND ((OR (NULL L) (EQ L $SIDES)) (RETURN))) [SELECTQ (CAAR L) ((/PUTHASH CLISPRPLNODE *) (* ; "For some reason (ask wt!), these aren't counted as real changes") NIL) (RETURN (MARKASCHANGED FN 'FNS (COND ((FASSOC 'CLISP% (LISTGET1 LISPXHIST '*LISPXPRINT*)) 'CHANGED) (T 'CLISP] (SETQ L (CDR L)) (GO LP]) (RETDWIM1 [LAMBDA (L) (* lmm "20-May-84 19:58") (* ;; "Called when about to make a CLISP transformation for which one of the atmic operands are not bound.") (PROG (($TAIL (CAR L)) ($CURRTAIL (CADR L)) FLG TEM) (* ; "CLISPCHANGES rebound so that FIXSPELL1 will only ask for approval if dwim mode indicates.") [SETQ TEM (COND ((EQ (CDR $TAIL) $CURRTAIL) (RETDWIM2 (CAR $TAIL))) (T (APPLY 'CONCAT (MAPCON (COND ((TAILP $CURRTAIL $TAIL) (LDIFF $TAIL $CURRTAIL)) (T $TAIL)) (FUNCTION (LAMBDA (X) (COND [(LISTP (CAR X)) (LIST (RETDWIM2 (CAR X] ((OR (FMEMB (NTHCHAR (CAR X) -1) CLISPCHARS) (FMEMB (CADR X) CLISPCHARS)) (LIST (CAR X))) (T (LIST (CAR X) '" "] (COND ([OR TREATASCLISPFLG (AND (EQ (CADDR L) 'PROBABLY) (OR (AND DWIMIFYFLG DWIMIFYING) (NULL TYPE-IN?] (* ;; "The idea here is that it does not make sense to automatcaaly go ahead and perform a transformation to typein that is then going to produce an error, e.g. user type FOO_FIE where FIE is unbound. Therefore we will always ask him for type-in? Note that he may say YES even though it will produce an error, so that he can then say  ' or -> something. --- In functons, if the operation involves more than one CLISP operator (or an assignment where the variable is one of the bound varables.) we will just tell him.") (SETQQ FLG NEEDNOTAPPROVE)) (T (SETQQ FLG MUSTAPPROVE))) (COND ((COND ((AND TREATASCLISPFLG (NULL CLISPHELPFLG)) (* ; "dont print any message, but do treat it as clisp") T) ((OR TREATASCLISPFLG CLISPHELPFLG) (* ; "interact (ask or inform) with user if either treatasclispflg is T, or clisphelpflg is T , or both.") (FIXSPELL1 TEM (COND (LCASEFLG '" as clisp") (T (* ;; "The reason for the check is that the user may want to key on this message for an UNDO : operation, and if he is on a 33 and it is printed as a lowercase string (even though he sees it in uppercase) he wont be able to fnd it.") '" AS CLISP")) (COND [(EQ FLG 'NEEDNOTAPPROVE) (COND (LCASEFLG '" treated") (T '" TREATED"] [(EQ FLG 'MUSTAPPROVE) (COND (LCASEFLG '" treat") (T '" TREAT"] (T (SHOULDNT))) T FLG)) ((EQ FLG 'NEEDNOTAPPROVE) (* ; "dont interact, but treat it as clisp, e.g. when transformation is a PROBABLY and we are dwimifying.") T)) (SETQ NOFIXVARSLST0 (CADDDR L)) (* ;; "Since user has approved CLISP, it is ok to set NOFIXVARSLST0 to include any variabes detected during analysis of CLISP expression, e.g. if expression were A*B A and B can now be added NOFIXVARSLST0") (RETURN T))) (RETURN (COND (DWIMIFYFLG (SETQ NEXTAIL (NLEFT (CAR L) 1 $CURRTAIL)) (* ; "Tells DWIMIFY where to continue.") (COND ((LISTP (CAR NEXTAIL)) (SETQ NEXTAIL (NLEFT (CAR L) 2 $CURRTAIL)) (* ;; "E.G. In A* (FOO --), this will enable (FOO --) to be processed. If the expression immediately before CURRTAIL is an atom, we have no way of knowing if it contains a CLISP operator or not, e.g. is it A + B, or A+B. If we were to back up NEXTAIL so that DWIMIFYING continued as of this atom, it might cause a loop.") )) NIL]) (FIX89TYPEIN [LAMBDA (X CLST APPLYFLG) (PROG (TEM) (PRIN1 '= T) (COND [(EQ X CLST) (* ; "THE 8 is the first character.") (PRINT (SETQ TEM (PACK (CDR X))) T T) (RETDWIM FAULTPOS (CONS TEM (COND ((NULL APPLYFLG)(* ; "E.g. 8FOO X Y") (CDR FAULTX)) (FAULTARGS (* ; "E.G. 8FOO (A B)") (LIST FAULTARGS] (T [SETQ FAULTARGS (COND ((AND APPLYFLG FAULTARGS) (* ; "E.g. 'FOO8)' or 'FOO8A)' or 'FOO8A B]'") (LIST FAULTARGS)) (T (* ; "E.g. 'FOO8A B C]' (or 'FOO8 A B]')") (CDR FAULTX] (RETDWIM FAULTPOS (PRINT (SETQ TEM (PACK (LDIFF CLST X))) T T) T (COND ((NULL (CDR X)) FAULTARGS) (T (CONS (PACK (CDR X)) FAULTARGS]) (FIXLAMBDA [LAMBDA (DEF) (* lmm "20-May-84 19:57") (* ;; "LAMBDASPLST is initialized to (LAMBDA NLAMBDA). HOwever users can add to it for 'function' handled by DWIMMUSERFN. QLISP uses this feature.") (AND (LITATOM (CAR DEF)) (CDDR DEF) (NOT (FMEMB (CAR DEF) LAMBDASPLST)) (FIXSPELL (CAR DEF) NIL LAMBDASPLST NIL DEF NIL NIL NIL T]) (FIXAPPLY [LAMBDA NIL (* lmm "19-MAY-84 21:44") (PROG (X TEM) (COND ((NEQ FAULTFN FAULTX) (* ;; "means the call came out of compiled code, e.g. user types in FOO which contains a call to a mispelled function.") (SETQ TYPE-IN? NIL))) (COND ((AND (LITATOM FAULTX) (SETQ X (FGETD FAULTX))) (COND ([NULL (PROG (TYPE-IN?) (RETURN (FIXLAMBDA X] (GO NX))) (AND FILEPKGFLG (LITATOM FAULTX) (MARKASCHANGED FAULTX 'FNS)) (SETQ X FAULTX) (GO OUT)) ((AND (OR (GETPROP FAULTX 'EXPR) (GETPROP FAULTX 'CODE)) (DWIMUNSAVEDEF FAULTX)) (SETQ X FAULTX) (SETQ FAULTFN NIL) (* ; "So that RETDWIM won't do a NEWFILE?") (GO OUT)) ((SETQ TEM (GETPROP FAULTX 'FILEDEF)) (COND ((WTFIXLOADEF TEM) (SETQ X FAULTX) (GO OUT1))) (RETDWIM)) ((AND TYPE-IN? CLISPFLG (STRPOSL CLISPCHARRAY FAULTX) (SETQ X (CLISPATOM CHARLST (SETQ TEM (LIST FAULTX FAULTARGS)) TEM T))) (* ; "E.g. FOO_ form. FOO _form is caught by a special check in LISPX and treated as (FOO _form)") (RETDWIM FAULTPOS X)) ((AND TYPE-IN? (NEQ NOSPELLFLG T) (EQ FAULTXX (CAAR HISTENTRY)) (SETQ TEM (FMEMB LPARKEY CHARLST))) (FIX89TYPEIN TEM CHARLST T)) ((AND (LISTP FAULTX) (FIXLAMBDA FAULTX)) (* ; "LAMBDA or NLAMBDA misspelled in LAMBDA expression being applied, e.g. a functional argument.") (SETQ X FAULTX) (GO OUT))) NX (COND [[AND DWIMUSERFORMS (SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) (SETQ TEM (EVAL DWIMUSERFORM] (COND (FAULTAPPLYFLG (RETDWIM FAULTPOS TEM T FAULTARGS)) (T (RETDWIM FAULTPOS TEM] ([NULL (SETQ X (OR (FIXSPELL FAULTX NIL SPELLINGS1 NIL NIL NIL NIL NIL T) (FIXSPELL FAULTX NIL SPELLINGS2 NIL NIL NIL NIL NIL T] (RETDWIM))) OUT (FIXAPPLY1 (FSTKNTH -1 FAULTPOS) FAULTX X) OUT1 (RETDWIM FAULTPOS X T FAULTARGS]) (FIXATOM [LAMBDA NIL (* bvm%: "21-Nov-86 16:38") (PROG (X Y TAIL0) (COND ((NULL TAIL) (SETQ TAIL (FINDATOM FAULTX (SETQ X (STKNTH -1 FAULTPOS)) (BLIPVAL '*FORM* X))) (RELSTK X))) (SETQ TAIL0 (AND (NEQ ONLYSPELLFLG 'NORUNONS) TAIL)) (* ;; "ONLYSPELLFLG is NORUNONS for calls from CLISPATOM2A, i.e. when DWIMIYING one of the operands to an infix operator. IN this case it never makes sense to do a runon spelling correction, e.g. FOOX*A shouldnt correct to (ITIMES FOO X A), althouh it may correct to FOO X*A.") (COND ((SETQ X (CLISPATOM CHARLST TAIL PARENT)) (GO OUT)) ([AND (CDR TAIL) (LITATOM (SETQ Y (CADR TAIL))) (FMEMB (CHCON1 Y) (CHARCODE (_ ¬))) (PROG (CLISPERTYPE) (RETURN (SETQ X (CLISPATOM (UNPACK Y) (CDR TAIL) PARENT T] (* ; "E.G. (LIST FOO _ 3) where FOO is unbound at the time. See comment in WTFIX.") (GO OUT)) ([AND DWIMUSERFORMS (SOME DWIMUSERFORMS (FUNCTION (LAMBDA (DWIMUSERFORM) (SETQ X (EVAL DWIMUSERFORM] (GO OUT)) ((OR (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?)) (GETPROP FAULTX 'GLOBALVAR) (FMEMB FAULTX GLOBALVARS)) (* ;; "For efficiency, GLOBALVARS is a global variable itself for DWIMBLOCK. Thus FIXATOM obtains the top level value, not the one rebound by BCOMPL2. However, in the case that there are block declarations aafecting globalvars, the variables would also have been added to NOFIXVARSLST, so this is ok.") (RETDWIM)) ((AND VARS (SETQ X (FIXSPELL FAULTX NIL VARS NIL TAIL0 NIL NIL NIL T))) (* ;; "Corrects spellings using LAMBDA and PROG variables of function in which error occurred, or function that is broken.") ) ((SETQ X (FIXSPELL FAULTX NIL SPELLINGS3 NIL TAIL0 NIL NIL NIL T))) ((AND DWIMIFYFLG (EQ CLISPCONTEXT 'IFWORD) (FIXSPELL FAULTX NIL CLISPIFWORDSPLST NIL T NIL NIL NIL T)) (CL:THROW 'CLISPIF0 :RESPELL)) ((AND DWIMIFYFLG (EQ CLISPCONTEXT 'FORWORD) (FIXSPELL FAULTX NIL CLISPFORWORDSPLST NIL T NIL NIL NIL T)) (CL:THROW 'CLISPFOR0 :RESPELL)) [(AND DWIMIFYFLG NOFIXVARSLST0 (SETQ X (FIXSPELL FAULTX NIL NOFIXVARSLST0 NIL TAIL0 NIL NIL NIL T] ((AND DWIMIFYFLG CLISPFLG (OR (EQ CLISPCONTEXT 'IS) (AND (LISTP CLISPCONTEXT) TAIL (EQ TAIL PARENT))) (SETQ X (FIXSPELL FAULTX NIL CLISPISWORDSPLST NIL TAIL NIL NIL NIL T))) (COND ((EQ CLISPCONTEXT 'IS) (* ;; "In this case, we are dwimifying the tail before processing it in clispatomis so is sufficient just to correct spelling and return.") ) ((SETQ X (CLISPATOM (DUNPACK X WTFIXCHCONLST) TAIL PARENT)) (* ; "E.g. X IS A NUMBER OR STRNG, STRNG being misspelled. Will call CLISPATOMIS? which will retfrom.") )) (GO OUT)) ([AND CLISPFLG (NULL CLISPCHANGES) (NULL CLISPERTYPE) (SETQ X (FIXSPELL FAULTX NIL CLISPINFIXSPLST NIL (COND (DWIMIFYFLG (LISTP CLISPCONTEXT )) (T TAIL)) NIL NIL NIL T)) (COND ([AND DWIMIFYFLG (OR (LISTP CLISPCONTEXT) (EQ CLISPCONTEXT 'IS] (CL:THROW 'CLISPATOM1 :RESPELL)) (T (SETQ X (CLISPATOM (SETQ CHARLST (DUNPACK (SETQ FAULTX X) WTFIXCHCONLST1)) TAIL PARENT] (GO OUT)) ((AND (EQ FAULTX (CAR TAIL)) (NUMBERP (CAR CHARLST)) [SETQ X (SOME CHARLST (FUNCTION (LAMBDA (X) (NOT (NUMBERP X] (FIXSPELL1 FAULTX (SETQ Y (CONS (PACK (LDIFF CHARLST X)) (PACK X))) NIL CHARLST 'MUSTAPPROVE)) (/RPLNODE TAIL (CAR Y) (CONS (CDR Y) (CDR TAIL))) (SETQ X (CAR Y)) (GO OUT)) (T (RETDWIM))) [COND ((AND (NULL TAIL0) (EQ FAULTX (CAR TAIL))) (* ; "If TAIL0 is not NIL, the RPLNODE has aleady been done.") (/RPLNODE TAIL X (CDR TAIL] OUT [COND ((AND NEWTAIL (NULL DWIMIFYFLG)) (* ;; "The interpreter has already made up its mind about how to handle the first operand of the CLISP expression, e.g. it has already been evaluated as an argument, or else is about to be called as a function. Therefore continuing the computation requires some fiddling around.") (SETQ X (FIXATOM1] (RETDWIM FAULTPOS X]) (FIXATOM1 [LAMBDA NIL (* lmm "20-SEP-83 23:37") (* ;; "Called when evaluation went too far before DWIM fixed an CLISP expression. See comment in FIXATOM") (PROG ((POS (STKNTH -1 FAULTPOS)) X OLDTAIL OLDFN) (SETQ OLDTAIL (BLIPVAL '*TAIL* POS)) (AND (LISTP NEWTAIL) (SELECTQ (CAR PARENT) ((AND OR PROG PROG2 PROG1 PROGN LAMBDA NLAMBDA) (COND ((NEQ TAIL OLDTAIL) (GO ERROR))) (SETBLIPVAL '*TAIL* POS NIL NEWTAIL) (* ; "Change the binding for the tai") (FIXCONTINUE (CADAR NEWTAIL)) (SETQ X (CAR NEWTAIL)) (GO OUT)) NIL)) (SETQ OLDFN (BLIPVAL '*FN* POS)) [COND ([COND ((NEQ TAIL OLDTAIL) (* ; "E.g. (COND (ZAP _ T 3)) where ZAP is A u.b.a.") T) ((LISTP NEWTAIL) (* ; "E.G. (LIST FOO X + Y)") (NEQ OLDFN (CAR PARENT))) [(ATOM (CADR PARENT)) (* ;; "e.g. (FOO AND T) where FOO is the name of a function as well as a variable. the check here used to be (NEQ OLDFN (CADR PARENT)). however this fails for things like (FOO : FIE) which at this point would be (fetch FIE of FOO), i.e. cant assume that car of form is now CADR") (AND (NEQ OLDFN (CADR PARENT)) (NEQ OLDFN (CADDDR PARENT] (T (* ;; "For infixes like EQ, AND, OR, the function that was about to be called may now be parenthesized, e.g. (FOO X EQ Y) becomes (EQ (FOO X) Y) However, it is also possible that it was not a function at all, e.g. (FOO GT 4 AND FOO LT 6)") (NOT (FMEMB OLDFN (CADR PARENT] (* ;; "The procedure followed assumes that Y gives the binding for TAIL, and Z gives the binding for the name of the function that is about to be called. This checks to make sure that this is in fact the cas") (GO BAD)) ((NLISTP NEWTAIL) (* ;; "Occurs when CAR of an xpression in which a CLISP operator is used is the name of a function, e.g. (FOO + X), (FOO X AND FIE Y). Note that at this point in the evaluton, the nterpreter is evaluating the 'arguments' for that function, and plans to call it when they have all been evaluated") NIL) ((OR (CDR NEWTAIL) (ZEROP (LOGAND (ARGTYPE (CAR PARENT)) 2))) (* ;; "Either there are more arguments following the CLISP expression, or, in the case of a spread, evaluate, it doesn't matter if an extra NIL is passed. Therefore, proceed by smashing the last argument with the value of the CLISP expression, (CAR NEWTAIL), change the binding for the tail to be (CDR NEWTAIL), and RETDWIM with the next expression on TAIL, (CADR NEWTAIL) e.g. (LIST T 2 + 3 6)") [SETBLIPVAL '*ARGVAL* POS NIL (STKEVAL POS (FIXLISPX/ (CAR NEWTAIL] (SETBLIPVAL '*TAIL* POS NIL (CDR NEWTAIL)) (SETQ X (CADR NEWTAIL)) (GO OUT)) (T (* ;; "The function to be called is a nospread function, e.g. LIST, and the CLISP expression was its last argument, e.g. (LIST X (--) *2) Therefore can only continue by reevaluating the whole form") (FIXCONTINUE (CADAR NEWTAIL) (AND (NULL TYPE-IN?) FAULTFN] (SETBLIPVAL '*TAIL* POS NIL NIL) (* ; "Makes tail of the argument list be NIL") (SETBLIPVAL '*FN* POS NIL 'FIXATOM2) (* ; "A nospread, evaluate function whose value is the value of its last argument") (SETQ X PARENT) (GO OUT) (* ;; "PARENT will be evaluated, and its value stored on the stack. Then since the tail of the argument list is now NIL, the interpreter figures that the evaluation of arguments is finished, and calls the function. However since Z was changed, FIXATOM2 will be called instead, and it will return as its value its last argument, which will be the value of PARENT. Voila") BAD (* ; "Stack not in normal state") (SELECTQ (STKNAME (SELECTQ (SYSTEMTYPE) ((JERICHO D) (* ; "Skip over internal frames") (REALSTKNTH -1 POS T POS)) POS)) (COND (COND ((EQ PARENT NEWTAIL) (* ;; "The CLISP transformation changed the predicate of a COND clause, e.g. (COND (FOO _ form --) --) Since the COND would ordinarily continue down that clause, it is necessary to continue by constructing an appropriate COND expression, and returning its value as the value of the entire COND") [SETQ X (CONS 'COND (FMEMB PARENT (STKARG 1 POS] (RELSTK FAULTPOS) (SETQ FAULTPOS POS) (GO OUT)) (T (* ;; "The CLISP transformation did not affect the predicate of a COND clause, so can continue by just evaluating PARENT E.G. (COND (T FOO _ 2))") (SETQ X (CAR NEWTAIL)) (GO OUT)))) ((PROGN PROG1) (* ; "Error in SELECTQ clause, e.g. (SELECTQ -- (-- A * B)) or error in savesetq") (SETQ X (CONS (STKNAME POS) NEWTAIL)) (RELSTK FAULTPOS) (SETQ FAULTPOS POS) (GO OUT)) NIL) ERROR (ERROR '"DWIM is confused about the stack" '"" T) OUT (AND (NEQ POS FAULTPOS) (RELSTK POS)) (RETURN X]) (FIXCONTINUE [LAMBDA (X FN) (SETQ X (OR (AND CLISPARRAY (GETHASH X CLISPARRAY)) X)) (COND ((OR (NLISTP X) (FIXCONTINUE1 X)) T) (T (FIXPRINTIN FN) (OR (EQ (ASKUSER (ITIMES DWIMWAIT 3) 'Y (LIST '" ok to reevaluate " (RETDWIM2 X NIL 2)) DWIMKEYLST) 'Y) (RETDWIM]) (FIXCONTINUE1 [LAMBDA (X) (* True if it is ok to reevaluate X.) (OR (EQ (CAR X) 'QUOTE) (AND [OR (FMEMB (CAR X) OKREEVALST) (GETPROP (CAR X) 'CROPS) (EQ (CAR (GETPROP (GETPROP (CAR X) 'CLISPCLASS) 'CLISPCLASSDEF)) 'ARITH) (AND (EQ (CAR X) 'SETQ) (NOT (EDITFINDP (CADDR X) (CADR X] (PROG NIL LP (COND ((NULL (SETQ X (CDR X))) (RETURN T)) ([AND (LISTP (CAR X)) (NULL (FIXCONTINUE1 (CAR X] (RETURN NIL))) (GO LP]) (CLISPATOM [LAMBDA (CLST TAIL PARENT NOFIX89) (* lmm "20-May-84 19:46") (* ;; "CLST is an exploded character list for CAR of TAIL, which is a tail of PARENT, although not necessarily a proper tail. ONLYSPELLFLG=T indicates that the ONLY corrections to be attempted are spelling corrections. Occurs on calls from CLISPATOM2a.") (AND (NULL ONLYSPELLFLG) (PROG (TEM) (COND [(AND (NULL CLISPCHANGES) (OR (EQ CLISPFLG T) (AND (EQ CLISPFLG 'TYPE-IN) TYPE-IN?))) (* ;; "If CLISPCHANGES is not NIL, a CLISP correction has already been found, so don't bother to find another, e.g. in (X+Y + Z), if X and Y are not bound vriables, after ggetting (IPLUS X Y Z), this would be undone and saved, pending spelling correction on X+Y. Therefore don't do the transformation that staats with +Z.") (RETURN (COND ((SETQ TEM (CLISPATOM0 CLST TAIL PARENT)) TEM) (CLISPCHANGES (SETQ CHARLST (DUNPACK FAULTXX WTFIXCHCONLST)) (* ; "Since DWIMIFY2, and hence WTFIX, may have been called, LST may have been clobbered.") NIL] ((AND (EQ (CAR CLST) '%') (GETPROP '%' 'CLISPTYPE)) (* ; "So ' can be disabled when CLISP is turned off as well.") [COND [(CDR CLST) [SETQ TEM (LIST 'QUOTE (PACK (CDR CLST] (COND ((NULL TAIL)) ((NEQ TAIL PARENT) (/RPLNODE TAIL TEM (CDR TAIL))) (T (RETDWIM] ((NULL (CDR TAIL)) (RETDWIM)) ((EQ TAIL PARENT) (/RPLNODE TAIL 'QUOTE (CDR TAIL)) (SETQ TEM TAIL)) (T (/RPLNODE TAIL (SETQ TEM (LIST 'QUOTE (CADR TAIL))) (CDDR TAIL] (RETURN TEM))) (COND ([OR NOFIX89 (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?)) (NULL (OR (SETQ TEM (FMEMB LPARKEY CLST)) (SETQ TEM (FMEMB RPARKEY CLST] NIL) [(AND (OR (LISTP FAULTX) TAIL) (FIX89 FAULTX (CAR TEM))) (RETDWIM FAULTPOS (COND ((ATOM FAULTX) (CAR TAIL)) (T FAULTX] ((AND TYPE-IN? (EQ (CAR TEM) LPARKEY) (EQ (CAR (SETQ TEM (FLAST CLST))) RPARKEY)) (* ;; "This corresponds to the case where an atom was typed in containing both an 8 and a 9, e.g. FILES?89 or 8EDITF9. Note that if the atom were part of a larger expression, either CAR of form, or appearing in a tail, (as indicated by TAIL being non-NIL), the fix is performed by FIX89, and involves editing the expression. In the case covered here, the fix requires changing the EVAL to an apppropriate APPLY. The case where the 8 or 9 error appears in an APPLY context, or line format, is taken care of in WTFIX.") (FIX89TYPEIN (FMEMB LPARKEY (SETQ TEM (LDIFF CLST TEM))) TEM T]) (GETVARS [LAMBDA (X) (* lmm "20-May-84 19:24") (PROG (L POS TEM) (COND ((EQ X T) (* ; "context is inside of a BREAK --- Gets variables of BRKFN.") (SETQ POS (STKPOS 'BREAK1 -1 FAULTPOS)) [COND ((AND [NOT (EQ 0 (STKNARGS (SETQ TEM (FSTKNTH -1 POS] (LITATOM (STKARGNAME 1 TEM))) (* ; "If the first argument's name is #0 or #100, there are no genuine variables.") (SETQ L (VARIABLES TEM] (SETQ X (STKARG 1 POS)) (RELSTK TEM) (RELSTK POS) (* ; "Sets X to BRKEXP the first argument to BREAK1. Used for getting PROG variables below.") ) [(EQ (CAR X) 'LAMBDA) (* ; "Gets variables for expression X.") (SETQ L (APPEND (CADR X] (T (RETURN NIL))) (RETURN (NCONC L (AND (LISTP X) (MAPCAR (CADR (GETVARS1 X)) (FUNCTION (LAMBDA (X) (COND ((NLISTP X) X) (T (CAR X]) (GETVARS1 [LAMBDA (X) (* DD%: " 2-Dec-81 16:49") (* ;; "Looks for a PROG.") (SELECTQ [CAR (SETQ X (CAR (LISTP (LAST (LISTP X] ((PROG RESETVARS) X) ((RESETLST RESETVAR RESETFORM) (GETVARS1 X)) NIL]) (FIX89 [LAMBDA (FORM N POS) (* bvm%: "21-Nov-86 18:47") (* ;; "Handles corrections for 8 and 9 errors. N is either 8 or 9.0 POS is optional, and if given, it is the position of the 8 or 9 in the offending atom, and also indicates that the user has already approved the correction.") (PROG [SPLIT89FLG (C (COND ((EQ N LPARKEY) 'FIX8) (T 'FIX9] (COND ([OR (AND (ATOM FAULTX) (NULL TAIL)) (AND (NULL POS) (NULL (FIX89A FAULTX N] (* ; "pointless to attempt an 8 or 9 correction if TAIL is NIL.") (RETURN NIL))) (* ; "Gets user approval if necessary, i.e. if TYPE-IN? is NIL and APPROVEFLG is T.") (EDITE EXPR (LIST (LIST 'ORR (LIST (LIST (COND ((ATOM FORM) 'F) (T 'F=)) FORM T) (LIST C NIL POS)) NIL))) (* ; "Constructs command of form ((ORR ((F= FORM T) C) NIL)) C is either FIX8 or FIX9 depending on call.") (RETURN (COND ((NULL SPLIT89FLG) (* ; "Set in SPLIT89 if successful.") (EXEC-FORMAT "couldn't~%%") NIL) (T (AND DWIMIFYFLG (SETQ 89CHANGE T)) T]) (FIXPRINTIN [LAMBDA (FN FLG) (* wt%: 12-OCT-76 21 40) (* ;; "If FLG is T, printing goes on history lst.") (AND FN (NEQ FN 'TYPE-IN) (PROG ((LISPXHIST (AND FLG LISPXHIST))) (AND (NEQ (POSITION T) 0) (LISPXSPACES 1 T)) (LISPXPRIN1 '"{" T) (LISPXPRIN1 (COND [(OR (AND DWIMIFYFLG DWIMIFYING) (NULL FAULTAPPLYFLG)) (COND (LCASEFLG (* ;; "Done this way instead of just printing the lower case version because users may want to efer to the message to undo a dwim correction, e.g. by typing UNDO : $IN$.") '"in ") (T '"IN "] (LCASEFLG '"below ") (T '"BELOW ")) T) (LISPXPRIN2 FN T T) (LISPXPRIN1 '"}" T) (RETURN FN]) (FIX89A [LAMBDA (X N POS) (* wt%: 25-FEB-76 1 40) [COND ((LISTP X) (SETQ X (CAR X] (OR POS (SETQ POS (STRPOS N X))) (COND ((FIXSPELL1 X (CONS [CONCAT (OR (SUBSTRING X 1 (SUB1 POS)) '"") (COND ((EQ N LPARKEY) '" (") (T '" )"] (OR (SUBSTRING X (ADD1 POS)) '"")) NIL CHARLST (AND (NULL TYPE-IN?) 'MUSTAPPROVE)) T) (DWIMIFYFLG (SETQ ATTEMPTFLG T) NIL]) (CLISPFUNCTION? [LAMBDA (TL TYPE FN1 FN2 Y) (* lmm "20-May-84 18:56") (* ;; "returns TRUE if (CAR TAIL) corresponds to the name of a function (Possibly misspelled). If TYP=NOTVAR, checks first to make sure (CAR TAIL) does not correspond to the name of a variable.") (* ;; "FN1 and FN2 are used to compute the arguments to FIXSPELL1. FN1 is given (CAR TAIL) and Y as its arguments, FN2 (CAR TAIL) or the corrected spelling, and Y. If FN1 is supplied, FIXSPELL is called so as not to print any messages, and the interaction takes place under CLISPUNCTION? control via a direct call to FIXSPELL1. In this case, if TYP=QUIET, no message is printed at all. --- If FN1 is not suppied, FIXSPELL will take care of the interaction, if any, othrwisre there are no error messages.") (PROG (TEM CHRLST) (COND ((NULL (LITATOM (CAR TL))) (RETURN NIL)) ((LISTP TYPE) (* ;; "Means that we already know that (CAR TAIL) is not the name of a variable, and is also not the name of a function.") (SETQ CHRLST TYPE) (GO SPELL)) ([AND (EQ TYPE 'NOTVAR) (NULL (CLISPNOTVARP (CAR TL] (RETURN NIL)) ([OR (CLISP-SIMPLE-FUNCTION-P (CAR TL)) (FMEMB (CAR TL) (COND (DWIMIFYFLG NOFIXFNSLST0) (T NOFIXFNSLST))) (LISTP (GETPROP (CAR TL) 'CLISPWORD] (GO OUT)) ((OR (EQ NOSPELLFLG T) (AND NOSPELLFLG (NULL TYPE-IN?)) (STRPOSL CLISPCHARRAY (CAR TL))) (RETURN NIL))) (SETQ CHRLST (UNPACK (CAR TL))) SPELL (COND ([NULL (SETQ TEM (CAR (MISSPELLED? (CAR TL) NIL SPELLINGS2 (AND FN1 'NO-MESSAGE) (COND ((NULL FN1) TL) (T T] (RETURN NIL))) OUT (RETURN (COND ([OR (NULL FN1) (AND (EQ TYPE 'QUIET) (NULL TEM)) (AND CLISPHELPFLG (FIXSPELL1 [COND (TYPE-IN? '"") (T (CONCAT "in ... " (APPLY* FN1 (CAR TL) Y] (COND (TYPE-IN? (APPLY* FN2 (OR TEM (CAR TL)) Y)) (T (CONCAT "is '" (COND ((NULL TEM) (CAR TL)) ((LISTP TEM) (CAR TEM)) (T TEM)) "' meant to be used as a function"))) NIL T (AND (OR FN1 (LISTP TEM)) 'MUSTAPPROVE) (AND (LISTP TEM) 'n] (* ;; "If TYP=QUIET (from DWIMIFY2), the message is printed only on spelling correction. For other calls, e.g. TYP=OKVAR, or TYP=NOTVAR, the message is printed even if no correction involved.") [AND TEM FN1 (COND ((LISTP TEM) (* ; "Run on correction.") (/RPLNODE TL (CAR TEM) (CONS (CDR TEM) (CDR TL))) (SETQ TEM (CAR TEM))) (T (/RPLNODE TL TEM (CDR TL] (* ;; "If FN1 is NIL, TAIL would have been given to FIXSPPELL, and in this case the correction would already have been stmashed into TAIL.") (CAR TL]) (CLISPNOTVARP [LAMBDA (X) (* lmm "20-May-84 19:45") (AND (NOT (BOUNDP X)) (NOT (FMEMB X VARS)) [NOT (FMEMB X (COND (DWIMIFYFLG NOFIXVARSLST0) (T NOFIXVARSLST] [OR (AND DWIMIFYFLG DWIMIFYING) SHALLOWFLG (NULL (RELSTK (STKSCAN X FAULTPOS] (NOT (GETPROP X 'GLOBALVAR)) (NOT (FMEMB X (LISTP GLOBALVARS))) (NOT (FMEMB X (LISTP LOCALVARS))) (NOT (FMEMB X (LISTP SPECVARS]) (CLISP-SIMPLE-FUNCTION-P [LAMBDA (CARFORM) (* lmm "18-Jul-86 16:45") (AND (OR (FGETD CARFORM) (GET CARFORM 'EXPR) (AND (NOT (GET CARFORM 'CLISPWORD)) (CL:MACRO-FUNCTION CARFORM)) (GETLIS CARFORM COMPILERMACROPROPS)) T]) (CLISPELL [LAMBDA (FORM TYPE) (* lmm "20-May-84 18:54") (PROG (VAL TEM RESPELLTAIL) [MAPC (LISTGET1 LISPXHIST 'RESPELLS) (FUNCTION (LAMBDA (X) (COND ((SETQ RESPELLTAIL (FMEMB (CAR X) FORM)) (SETQ TEM (CDR X)) [COND [(LISTP TEM) (/RPLNODE RESPELLTAIL (CAR TEM) (CONS (CDR TEM) (CDR RESPELLTAIL] (T (/RPLNODE RESPELLTAIL TEM (CDR RESPELLTAIL] (AND (OR (NULL TYPE) (EQ (CAR (GETPROP (CAR RESPELLTAIL) 'CLISPWORD)) TYPE)) (SETQ VAL T] (RETURN VAL]) (FINDFN [LAMBDA (POS FLG) (* lmm "21-May-84 00:40") (* ;; "Used by HELPFIX and WTFIX. Locates highest interpreted form in the current chain of interpretation, sets free variable EXPR to this expression and returns the NAME of the corresponding function, or 'BREAK-EXP', 'EVAL', or 'TYPE-IN' depending on context. also sets free variable TYPE-IN? to T if the expression was typed in by the user.") (* ;; "When called from WTFIX, (FLG is T) and sets the variable BREAKFLG to T if the expression was typed into a BREAK, (In this case, DWIM uses the lambda and/or prog variables for spelling corrections.)") (PROG1 [PROG (NAME TOKEN TEM) [COND ((NULL POS) (SETQ POS (STKNTH 1] LP (COND ((NULL POS) (RETURN NIL))) (SETQ NAME (STKNAME POS)) LP1 (SELECTQ NAME ((APPLY BLKAPPLY) (SETQ TOKEN (STKARG 3 POS)) (GO APPLYTYPE)) (ENVAPPLY [SETQ TOKEN (COND ((OR (EQ (SETQ NAME (STKNTHNAME -1 POS)) 'RETAPPLY) (EQ NAME 'STKAPPLY)) (PROG1 (STKARG 5 (SETQ TEM (STKNTH -1 POS))) (RELSTK TEM] (GO APPLYTYPE)) ((STKAPPLY RETAPPLY) (SETQ TOKEN (STKARG 5 POS)) (GO APPLYTYPE)) (APPLY* [RETURN (COND (FLG (SETQ TEM (STKARGS POS)) (SETQ EXPR (CDR TEM)) (CAR TEM)) (T (SETQ EXPR (STKARG 1 POS]) ((EVAL \SAFEEVAL) (SETQ TOKEN (STKARG 2 POS)) (GO EVALTYPE)) (ENVEVAL [SETQ TOKEN (COND ((OR (EQ (SETQ NAME (STKNTHNAME -1 POS)) 'RETEVAL) (EQ NAME 'STKEVAL)) (PROG1 (STKARG 4 (SETQ TEM (STKNTH -1 POS))) (RELSTK TEM] (GO EVALTYPE)) ((STKEVAL RETEVAL) (SETQ TOKEN (STKARG 4 POS)) (GO EVALTYPE)) NIL) LP2 [COND ((LITATOM NAME) (COND ([EXPRP (SETQ EXPR (GETD (COND ((SETQ TEM (GETPROP NAME 'BROKEN)) (OR (CDR (GETPROP NAME 'ALIAS)) TEM)) (T NAME] (RETURN NAME] LP3 (SETQ POS (REALSTKNTH -1 POS NIL POS)) (GO LP) EVALTYPE (SETQ EXPR (STKARG 1 POS)) [RETURN (SELECTQ TOKEN ((SKIP SELECTQ) (SETQ POS (STKNTH -2 POS POS)) (GO LP)) (INTERNAL (GO LP3)) (NIL 'EVAL) (%: (* ; "Call to EVAL comes from a BREAK (i.e. via a LISPX which was called from BREAK1.)") (AND FLG (SETQ BREAKFLG T)) (SETQ TYPE-IN? T) 'TYPE-IN) (BREAK (* ; "Call to EVAL from evaluation of a breakcommand.") (AND FLG (SETQ BREAKFLG T)) 'BREAKCOMS) (BREAK-EXP (* ; "Call to EVAL from EVAL, OK, or GO command.") (COND ((NULL (EVALV 'BRKTYPE POS)) (* ;; "Since BRKTYPE is NIL, we are in a user BREAK. Therefore, if broken function is an EXPR, want to stop searching, otherwise continue (latter can only occur when FINDFN is called as result of EDIT command since WTFIX will never be called out of compiled function.)") (SETQ TEM (STKPOS 'BREAK1 -1 POS)) (RELSTK POS) [SETQ NAME (STKNAME (SETQ POS (STKNTH -1 TEM TEM] (GO LP2)) (T (* ;; "EVAL, OK, or GO command to non-user BREAK expression, e.g. get a non-numeric arg BREAK, fix the BRKEXP, do an EVAL, and get another error.") 'BREAK-EXP))) (COND ((LISTP TOKEN) (COND ((NLISTP EXPR) (* ; "permits caller to specify the tail") (SETQ TAIL TOKEN))) 'EVAL) (T (SETQ TYPE-IN? T) 'TYPE-IN] APPLYTYPE (SELECTQ TOKEN ((SKIP SELECTQ) (SETQ POS (STKNTH -2 POS POS)) (GO LP)) (INTERNAL (GO LP3)) NIL) (SETQ TYPE-IN? TOKEN) (* ;; "WTFIX would already know that this was an apply error because of FAULTAPPLYFLG. However, FINDFN is called to find out whether the expression was typed in or not.") (RETURN (COND (FLG (SETQ EXPR (STKARG 2 POS)) (STKARG 1 POS)) (T (SETQ EXPR (STKARG 1 POS] (RELSTK POS]) (DWIMUNSAVEDEF [LAMBDA (FN FLG) (* lmm "11-DEC-81 21:23") (LISPXPRIN2 FN T T) [AND (NULL FLG) (NULL TYPE-IN?) (NEQ (CAR SIDES) 'CLISP% ) (SETQ SIDES (LIST 'CLISP% (LIST COMMENTFLG (FLAST (LISTGET1 LISPXHIST '*LISPXPRINT*)) SIDES] (* ; "FLG is TRUE on calls from CLISPIFY, in which case SIDES is not relevant (or even bound)") (LISPXPRIN1 '" unsaved" T) (LISPXTERPRI T) (UNSAVEDEF FN]) (CHECKTRAN [LAMBDA (X) (* lmm "20-May-84 19:01") (DECLARE (GLOBALVARS %#CLISPARRAY CLISPARRAY CLISPTRANFLG)) (OR (AND CLISPARRAY (GETHASH X CLISPARRAY)) (AND CLISPTRANFLG (EQ (CAR X) CLISPTRANFLG) (CADR X]) ) (DEFINEQ (CLISPIF [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:09") (* ;; "Translates (IF -- THEN -- ELSEIF -- THEN -- ELSE --) to equivalent COND.") (COND (DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T))) (PROG ((CLISPCONTEXT 'IFWORD) (DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) [VARS (OR VARS (AND (NULL DWIMIFYFLG) (GETVARS (OR BREAKFLG (LISTP EXPR] (FNSLST0 NOFIXFNSLST0) (VARSLST0 NOFIXVARSLST0) TEM) LP (COND ((NULL DWIMIFYFLG) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) (SELECTQ (DWIMUNDOCATCH 'CLISPIF0 (SETQ TEM (CLISPIF0 FORM))) (:RESPELL (* ;; "A misspelled IF word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. IF FOO XTHENN PRINT X.") (COND ((CLISPELL FORM 'IFWORD) (SETQ NOFIXFNSLST0 FNSLST0) (SETQ NOFIXVARSLST0 VARSLST0) (* ;; "The additions made to these lists may be wrong as a result of the misspelling of the IF word, e.g. a variaae kay have appeared in a function slot.") (GO LP)))) (NIL (* ; "error")) (RETURN TEM)) (RETDWIM]) (CLISPIF0 [LAMBDA (FORM) (* lmm " 4-SEP-83 22:54") (PROG (X Y PRED TEM L L0 L-1 CLAUSE DWIMIFYCHANGE $SIDES) (SETQ L FORM) [AND CLISPIFTRANFLG (SETQ Y (LIST (CONS (CAR L] (GO LP0) LP (SELECTQ (CAR L) ((IF if) (COND [(EQ L (CDR L-1)) (* ;; "No IF's should be seen after the initial one except when immediately following an ELSE. In this case the two words are treated the same as ELSEIF.") (SETQ PRED NIL) (COND (CLISPIFTRANFLG (OR [EQ (CAR L-1) (CAR (LISTP (CAR Y] (SHOULDNT 'ELSE)) (RPLACA Y (SELECTQ (CAAR Y) (ELSE (CONS 'ELSEIF)) (else (CONS 'elseif)) (SHOULDNT 'ELSE] (T (GO ERROR)))) ((ELSEIF elseif) (SETQ X (NCONC1 X (CLISPIF1 PRED L0 L FORM))) (SETQ PRED NIL) (AND CLISPIFTRANFLG (SETQ Y (CONS (CONS (CAR L)) Y)))) ((ELSE else) (SETQ X (NCONC1 X (CLISPIF1 PRED L0 L FORM))) (SETQ L-1 L) (* ; "To enable ELSE IF as two words.") (SETQ PRED T) (AND CLISPIFTRANFLG (SETQ Y (CONS (CONS (CAR L)) Y)))) ((THEN then) [SETQ PRED (COND ((EQ L0 L) (GO ERROR)) (T (* ;; "The reason for doing the LDIFF even when L is (CDR L0) is that can't just set pred to CAR of L is becuase then couldnt distinguish no predicate from IF NIL THEN -- (Actually encountered by one user.)") (LDIFF L0 L] [COND (CLISPIFTRANFLG (OR (LISTP (CAR Y)) (SHOULDNT 'THEN)) (RPLACD (CAR Y) (CAR L]) (GO LP1)) LP0 (SETQ L0 (CDR L)) LP1 (COND ((SETQ L (CDR L)) (GO LP))) (SETQ X (NCONC1 X (CLISPIF1 PRED L0 L FORM))) (AND CLISPIFTRANFLG (SETQ Y (DREVERSE Y))) (/RPLNODE FORM 'COND X) [SETQ $SIDES (CDR (LISTGET1 LISPXHIST 'SIDE] (SETQ L (CDR FORM)) (* ;; "The COND must appear in the original definition before DWIMIFYing can be done, or else correction of 8 and 9 errors won't work. Some unnecessary work may be done by virtue of DWIMIFYING the whole IF statement, even when it is being evaluated (as opposed to being dwimified). however, in most cases, if the user employs IF, there will be other CLISP constructs in the predicates and consequents.") LP2 (SETQ CLAUSE (CAR L)) (COND [(LISTP (CAR CLAUSE)) (DWIMIFY1 (CAR CLAUSE) 'IFWORD) (COND ([AND (LISTP (CAAR CLAUSE)) (NOT (FNTYP (CAAR CLAUSE] (LISPXPRIN1 (COND ((EQ (CAADAR CLAUSE) COMMENTFLG) '"misplaced comment ") (T '"parentheses error ")) T) (SETQ L FORM) (GO ERROR] (T (SETQ TEM (CDR CLAUSE)) (FRPLACD CLAUSE NIL) (DWIMIFY2 CLAUSE CLAUSE NIL 'IFWORD) (NCONC CLAUSE TEM))) (DWIMIFY2 (SETQ TEM (CDR CLAUSE)) TEM NIL 'IFWORD) (COND ((SETQ L (CDR L)) (GO LP2))) (CLISPIF2 FORM) (COND (CLISPIFTRANFLG (* ;; "Bletcherous PROG here because fool Interlisp-D compiler can't handle MAP2CAR right when inside a BLOCKS") (PROG ((LF (CDR FORM)) (LY Y) (FIRSTP T) L) LP [COND ((OR (NLISTP LF) (NLISTP LY)) (RETURN (SETQ X (APPLY (FUNCTION NCONC) (DREVERSE L] (SETQ L (CONS (CLISPIF3 (CAR LF) (CAR LY) FIRSTP) L)) (SETQ LF (CDR LF)) (SETQ LY (CDR LY)) (SETQ FIRSTP) (GO LP)) (SETQ TEM (CONS (CAR FORM) (CDR FORM))) (* ; "the conditional expression, which is now in the function, and is going to be smashed") (RPLNODE FORM (CAR X) (CDR X)) (* ; "puts the clisp back in /rplnode unnecessary since this was already saved above.") [COND ((AND (EQ (CAAR $SIDES) FORM) (EQUAL (CAAR $SIDES) (CDAR $SIDES))) (* ;; "so function wont be marked as changed reason for EQUAL check is if it was converted to lower case, than do want to retain side informaton.") (FRPLACA (CAR $SIDES) '*] (CLISPTRAN FORM TEM))) (RETURN FORM) ERROR (DWIMERRORRETURN (LIST 4 L FORM]) (CLISPIF1 [LAMBDA (PRED L0 L FORM) (* lmm "26-Jul-84 05:01") (COND (PRED (CONS (COND ((OR (NLISTP PRED) (CDR PRED)) PRED) (T (CAR PRED))) (LDIFF L0 L))) ((EQ L0 L) (* ;; "Note that ELSE or ELSEIF can imediately follow a THEN by virtue of the PRED check in earlier clause.") (DWIMERRORRETURN (LIST 4 L FORM))) ((EQ (CDR L0) L) (LIST (CAR L0))) (T (LIST (LDIFF L0 L]) (CLISPIF2 [LAMBDA (X) (* lmm "16-Sep-85 18:15") (PROG (TEM1 TEM2 TEM3) (COND ((NEQ (CAR X) 'COND)) ((AND (EQ [CADR (SETQ TEM1 (CAR (SETQ TEM2 (FLAST X] X) (EQ (CAR TEM1) T) (NULL (CDDR TEM1))) (* ;; "Changes expression of X (COND -- (T (COND **))) to (COND -- **) useful for producing more aesthetic code when the 'DO' portion of a 'FOR' statement is an 'IF' Converts") (/RPLNODE TEM2 (CADR X) (CDDR X))) ((AND (EQ (CAR TEM1) T) (EQ [CADR (LISTP (SETQ TEM3 (CAR (SETQ TEM2 (NLEFT X 2] X) (NULL (CDDR TEM2))) (* ; "Converts expression of X (COND (& (COND --)) (T **)) to (COND ((NEGATION &) **) --)") (/RPLNODE TEM1 (CAR TEM3) (CDR TEM1)) (/RPLNODE TEM2 TEM1 (CDADR TEM3]) (CLISPIF3 [LAMBDA (CLAUSE ORIGWORDPAIR FIRSTCLAUSEFLG) (* JonL "22-APR-83 19:46") (PROG NIL (RETURN (CONS [COND [FIRSTCLAUSEFLG (COND (LCASEFLG 'if) ((CAR ORIGWORDPAIR)) (T 'IF] [(EQ (CAR CLAUSE) T) (RETURN (CONS (COND (LCASEFLG 'else) ((CAR ORIGWORDPAIR)) (T 'ELSE)) (APPEND (CDR CLAUSE] (T (COND (LCASEFLG 'elseif) ((CAR ORIGWORDPAIR)) (T 'ELSEIF] (CONS (CAR CLAUSE) (COND ((CDR CLAUSE) (CONS (COND (LCASEFLG 'then) ((CDR ORIGWORDPAIR)) (T 'THEN)) (APPEND (CDR CLAUSE]) ) (DEFINEQ (CLISPFOR [LAMBDA (FORM) (* bvm%: "21-Nov-86 18:10") (* ;; "Translates iterative statements, e.g., (for X in Y until --)") (COND (DWIMIFYFLG (SETQ ATTEMPTFLG T) (SETQ CLISPCHANGE T))) (PROG ((CLISPCONTEXT 'FORWORD) (DWIMIFYING (AND DWIMIFYFLG DWIMIFYING)) (VARS VARS) TEM) LP (COND ((NULL DWIMIFYFLG) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) (SELECTQ (DWIMUNDOCATCH 'CLISPFOR0 (SETQ TEM (CLISPFOR0 FORM))) (:RESPELL (* ;; "A misspelled I.S. word was detected. We now go through respellings and make any corrections that occur in FORM. Note that more than one correction may have been involved, e.g. FOR X IN YWHILLE Z FOO XTHENN PRINT X.") (COND ((CLISPELL FORM 'FORWORD) (GO LP)))) (NIL (* ; "error")) (RETURN TEM)) (RETURN]) (CLISPFOR0 [LAMBDA (EXP) (* rmk%: " 6-Oct-84 12:03") (DECLARE (SPECVARS EXP)) (PROG (DWIMIFYCHANGE (I.S. EXP) I.S.TYPE LASTPTR I.S.PTRS I.S.BODY OPR TEM I.S.TYPE1 I.V. FIRSTI.V. IVINITFLG PROGVARS INITVARS MAKEPROGFLG TERMINATEFLG TERM ITER LSTVAR (LSTVARS '($$LST1 $$LST2 $$LST3 $$LST4 $$LST5 $$LST6)) (DUMMYVARS CLISPDUMMYFORVARS) EXCEPTPREDS RETPREDS AFTERPREDS RETEXP OUTEXP UNDOLST FOR BIND DECLARELST AS FROM TO IN ON BY FINALLY EACHTIME FIRST CLISPWORD (VARS (APPEND '(I.V. BODY $$VAL) VARS)) I.S.OPRSLST I.S.OPR) (DECLARE (SPECVARS LASTPTR I.S.PTRS)) (* ; "Used freely by I.S.OPRS in IDL -- Ron") (COND ((NULL DWIMIFYFLG) (SETQ NOFIXFNSLST0 NOFIXFNSLST) (SETQ NOFIXVARSLST0 NOFIXVARSLST))) LP (COND ([NOT (LITATOM (SETQ OPR (CAR I.S.] (GO LP2))) RECHECK (COND ([NULL (SETQ CLISPWORD (GETPROP OPR 'CLISPWORD] (GO LP2)) ((OR (NLISTP CLISPWORD) (NEQ (CAR CLISPWORD) 'FORWORD)) (* ; "E.g. OR, AND,") (GO LP2))) [AND LCASEFLG (EQ OPR (CAR I.S.)) ([LAMBDA (LC) (* ;; "Replaces the uppercase word with the lowercase. the EQ check is so that synonyms are not replaced by their antecedents. the NEQ check so that the replacement is not done when it is already in lowercase.") (AND (NEQ LC (CAR I.S.)) (/RPLNODE I.S. LC (CDR I.S.] (COND ((NLISTP (CDR CLISPWORD)) (CDR CLISPWORD)) (T (CADR CLISPWORD] (COND ((EQ (GETP (CDR CLISPWORD) 'I.S.OPR) 'MODIFIER) (* ; "modifier") (GO LP2))) (COND ((AND LASTPTR (NULL (CDDR LASTPTR))) (* ;; "X identifies the end of the operand for the previous i.s.opr needs to be done before the caal to CLISPFOR0A because it might return a new X with some OTHERS in front. e.g. if the i.s. is (FOR X IN Y SUM X + 1 WHILE Z), at the time the WHILE is encountered, the range of the opeand for SUM is X + 1 after the call to CLISPISTYPE, x will be (FIRST (SETQ $$VAL 0) WHILE Z)") (NCONC1 LASTPTR I.S.))) (COND (I.S.OPR (SETQ I.S. (CLISPFOR0A I.S.OPR I.S. LASTPTR)) (* ; "see comment at end of selectq") (SETQ I.S.OPR NIL) (GO LP))) (COND ((NLISTP (CDR CLISPWORD)) (* ;; "This converts everything to the lowercase version thereby simplifying the selectq. (There is no information tored to enable getting back to uppercase from lowercase (using properties) so that lowercase is the only available canonical representation.)") (SETQ OPR (CDR CLISPWORD))) (T (* ; "This implements synonyms, e.g. WHERE is the same as WHEN.") (SETQ OPR (CADDR CLISPWORD)) (GO RECHECK))) (COND ((EQ OPR 'original) (GO SELECT)) [(EQ (CAR LASTPTR) 'ORIGINAL) (COND ((EQ (CADDR LASTPTR) (CDADR LASTPTR)) (GO SELECT)) (T (CLISPFORERR (CADR LASTPTR) (CADDR LASTPTR) 'MISSING] ([LISTP (SETQ I.S.OPR (GETPROP OPR 'I.S.OPR] [COND [(NULL (CAR I.S.OPR)) (* ;; "The i.s.type does not define the i.s.type for the i.s. e.g. Larry's UPTO which is defined as (BIND $$MAX_BODY TO $$MAX)") (COND ((NULL (CDR I.S.OPR)) (* ;; "the i.s.opr terminates (terminted) the scope of the prvious i.s.opr, but is otherwise a nop, i.e. invisible. this featre is used for i.s.oprs in which one does not want the argument dwimified, but wants a postprocessor to handle it, e.g. (for i from 1 to 10 decl (x fixp) do (foo))") (SETQ LASTPTR (LIST NIL I.S.))) (T (SETQ LASTPTR (LIST OPR I.S.] [(NULL I.S.TYPE) (* ; "e.g. COLLECT. DO, JOIN, SUM ETC.") (SETQ I.S.TYPE1 OPR) (SETQ LASTPTR (LIST 'I.S.TYPE (SETQ I.S.TYPE I.S.] ((AND (EQ I.S.TYPE1 'do) (EQ I.S. (CDR I.S.TYPE))) (* ; "E.g. DO COLLECT, DO JOIN. Ignore the DO") (SETQ I.S.TYPE1 OPR) (/RPLNODE I.S.TYPE (CAR I.S.) (CDR I.S.)) (FRPLACD (CDR LASTPTR))) ((AND (EQ I.S.TYPE1 'thereis) (OR (EQ (CAR I.S.) 'SUCHTHAT) (EQ (CAR I.S.) 'suchthat)) (NULL FOR)) (* ; "special glitch to allow ISTHERE -- SUCHTHAT --") (SETQ I.S.TYPE1 OPR) (SETQ LASTPTR (LIST 'I.S.TYPE (SETQ I.S.TYPE I.S.))) (SETQ OPR (FASSOC 'I.S.TYPE I.S.PTRS)) (FRPLACA OPR 'FOR) (SETQ FOR (CADR OPR))) (T (CLISPFORERR I.S.TYPE I.S. 'BOTH] (GO LP0)) ((GETP OPR '\DURATIONTRAN) (* ; "Foo, punt out by calling \DURATIONTRAN since it's too complicated to express as an I.S.OPRS") (SETQ I.S. (\DURATIONTRAN EXP)) (GO OUT))) SELECT [SELECTQ OPR (original (SETQ LASTPTR (LIST 'ORIGINAL I.S.))) ((for from in on to by) [SETQ LASTPTR (SELECTQ OPR (for (LIST 'FOR (SETQ FOR I.S.))) (from (AND (SETQ OPR (OR IN ON)) (CLISPFORERR OPR I.S. 'BOTH)) (LIST 'FROM (SETQ FROM I.S.))) (in (AND (SETQ OPR (OR FROM TO ON)) (CLISPFORERR OPR I.S. 'BOTH)) (LIST 'IN (SETQ IN I.S.))) (on (AND (SETQ OPR (OR FROM TO IN)) (CLISPFORERR OPR I.S. 'BOTH)) (LIST 'ON (SETQ ON I.S.))) (to (AND (SETQ OPR (OR IN ON)) (CLISPFORERR OPR I.S. 'BOTH)) (LIST 'TO (SETQ TO I.S.))) (by (LIST 'BY (SETQ BY I.S.))) (SHOULDNT 'CLISPFOR0] (GO TWICECHECK)) (as (OR TERMINATEFLG (SETQ TERMINATEFLG (OR IN ON RETPREDS TO))) (COND ((OR FOR AS I.V.)) ((OR FROM IN ON TO) (* ; "E.g. IN X AS I FROM 1 TO 10 DO --.") (SETQ FIRSTI.V. (SETQ I.V. (GETDUMMYVAR T))) (* ; "getdummyvar also adds to progvars and vars") )) (SETQ IN NIL) (SETQ ON NIL) (SETQ FROM NIL) (SETQ TO NIL) (SETQ BY NIL) (* ;; "Primarily for error detection, i.e. now can just check to see if say both IN/ON and FRM appear in one stretch.") (SETQ LASTPTR (LIST 'AS (SETQ AS I.S.)))) (bind (SETQ LASTPTR (LIST 'BIND (SETQ BIND I.S.)))) (declare (SETQ DECLARELST (CONS (SETQ LASTPTR (LIST 'DECLARE I.S.)) DECLARELST))) (while (* ;; "WHILE, UNTIL, UNLESS< WHEN, Finally, FIRST, and EACHTIME can appear more than once. the corresponding FORPTR'S are gathered on a list and processed by a call to either CLISPFOR2 for the first four, and CLISPFOR3 for latter three (which can have imlicit progns as well.)") (SETQ RETPREDS (CONS (SETQ LASTPTR (LIST 'WHILE I.S.)) RETPREDS))) (until (SETQ RETPREDS (CONS (SETQ LASTPTR (LIST 'UNTIL I.S.)) RETPREDS))) (repeatwhile (* ; "Like WHILE except test is mae after body of iterative statement.") (SETQ AFTERPREDS (CONS (SETQ LASTPTR (LIST 'REPEATWHILE I.S.)) AFTERPREDS))) (repeatuntil (SETQ AFTERPREDS (CONS (SETQ LASTPTR (LIST 'REPEATUNTIL I.S.)) AFTERPREDS))) (unless (SETQ EXCEPTPREDS (CONS (SETQ LASTPTR (LIST 'UNLESS I.S.)) EXCEPTPREDS))) (when (SETQ EXCEPTPREDS (CONS (SETQ LASTPTR (LIST 'WHEN I.S.)) EXCEPTPREDS))) (finally (SETQ FINALLY (CONS (SETQ LASTPTR (LIST 'FINALLY I.S.)) FINALLY))) (eachtime (SETQ EACHTIME (CONS (SETQ LASTPTR (LIST 'EACHTIME I.S.)) EACHTIME))) (first (SETQ FIRST (CONS (SETQ LASTPTR (LIST 'FIRST I.S.)) FIRST))) (COND ((EQ I.S.OPR 'MODIFIER) (* ; "e.g. OLD") (FRPLACD (CDR LASTPTR)) (* ; "The OLD does not terminate the scope of the previous i.s.") (GO LP2)) (T (GO LP2] (GO LP0) TWICECHECK (AND (SETQ TEM (FASSOC (CAR LASTPTR) I.S.PTRS)) (NULL AS) (CLISPFORERR (CADR TEM) (CADR LASTPTR) 'TWICE)) LP0 (SETQ I.S.PTRS (NCONC1 I.S.PTRS LASTPTR)) LP1 (COND ((AND (NULL (CDR I.S.)) (EQUAL EXP (CAR HISTENTRY))) (PRIN1 '... T) (PEEKC T) (NCONC EXP (READLINE T)) (GO LP0))) LP2 (COND ((LISTP (SETQ I.S. (CDR I.S.))) (GO LP)) (I.S. (* ; "i.s. ends in a non-nil tail") (AND (NULL DWIMESSGAG) (ERRORMESS (LIST 25 EXP))) (ERROR!)) (LASTPTR (NCONC1 LASTPTR NIL)) ((NULL I.S.PTRS) (* ; "shouldnt happen") (AND (NULL DWIMESSGAG) (ERRORMESS1 "No operator in:" EXP)) (ERROR!))) [COND (I.S.OPR (SETQ I.S. (CLISPFOR0A I.S.OPR NIL LASTPTR)) (SETQ I.S.OPR NIL) (COND (I.S. (GO LP] (SETQ TEM VARS) [MAP I.S.PTRS (FUNCTION (LAMBDA (PTRS) (SETQ PROGVARS (SELECTQ (CAAR PTRS) ((BIND AS) (APPEND PROGVARS (CLISPFORVARS PTRS))) (FOR (* ;; "The reason for the reverse in order in the APPEND beloow is in caseBIND appears before FOR, and a PROG is not being made, must have FOR variables first. NOte if a prog is being made, it doesnt matter.") (* ; "The call to CLISPFORVARS will also set I.V. and FIRSTI.V.") (APPEND (CLISPFORVARS PTRS) PROGVARS)) ((IN ON) (PROG [(VARS (COND (I.S.TYPE TEM) (T VARS] (CLISPFOR1 PTRS T)) (* ;; "IN/ON should be handled before adding VARS because that is when its operand is evaluqted. (Except when there is no FOROPR, because we really might be DWIMIFYING what will be the FOROPR.)") PROGVARS) PROGVARS] (* ;; "Need to do this before CLISPFOR1 to get all ofthe variables 'bound' i.e. added to rs, and to note the names of the i.v. (s)") [COND ((AND (NULL I.V.) (OR FROM IN ON TO)) (* ;; "This can only occur if there is no FOR and no AS. If thee is no FOR and an AS, the I.V. for the initial segment, if one is needed, is set up in the SELECTQ at LP.") (SETQ I.V. (GETDUMMYVAR T] (SETQ TEM I.S.PTRS) LP3 (COND ((SETQ TEM (CLISPFOR1 TEM)) (* ;; "maps down forpotrs applying clispfor1 to each one. for most calls, clispfor1 returns CDR of TEM, but for things on i.s.typelst, it jumps ahead and does the next few before finishing up this one so it can substitute.") (GO LP3))) [SETQ I.S.BODY (AND I.S.TYPE (COND [(NLISTP (CAR I.S.TYPE)) (LIST (COND ((AND (EQ [CAR (SETQ TEM (LISTP (GETPROP (CADR I.S.TYPE) 'CLISPWORD] 'FORWORD) (EQ (GETPROP (CDR TEM) 'I.S.OPR) 'MODIFIER)) (CADDR I.S.TYPE)) (T (CADR I.S.TYPE] (T (* ;; "This occurs when the FOROPR specifies more than one operation, i.e. an implicit PROGN. In this case, FOROPR was reset to the body of the PROGN.") (CAR I.S.TYPE] (COND ((OR RETPREDS AFTERPREDS) (GO MAKEPROG)) ((NULL I.S.TYPE) (AND (NULL DWIMESSGAG) (ERRORMESS1 '"No DO, COLLECT, or JOIN in:" EXP)) (ERROR!)) (TO (GO MAKEPROG)) ((AND (NULL IN) (NULL ON)) (COND ([AND (NULL DWIMESSGAG) (NULL TERMINATEFLG) (NULL (CLISPFOR4 (GETPROP I.S.TYPE1 'I.S.OPR] (* ;; "Before printing this message, check I>S>TYPE for possilb RETURN or GO, as with THEREIS, SUCHTHAT, etc.") (PRIN1 '"Possible non-terminating iterative statement: " T) (PRINT [MAPCAR EXP (FUNCTION (LAMBDA (I.S.) (RETDWIM2 I.S. NIL 1] T T))) (GO MAKEPROG)) ([OR FROM AS (CDR PROGVARS) INITVARS MAKEPROGFLG FINALLY FIRST EACHTIME [NOT (FMEMB I.S.TYPE1 '(collect join do] EXCEPTPREDS (AND ON (EDITFINDP I.S.BODY (LIST 'SETQ I.V. '&] (* ;; "On TYPE-IN? do not convert to MAPCONC, i.e. convert to a PROG, as otherwise the MAPCONC would be converted toa /MAPCONC, which is unnecessary.") (GO MAKEPROG))) [SETQ I.S. (CONS [COND [IN (SELECTQ I.S.TYPE1 (subset 'SUBSET) (collect 'MAPCAR) ((JOIN join) (CLISPLOOKUP 'MAPCONC (CADR IN))) ((DO do) 'MAPC) (SHOULDNT 'CLISPFOR0] [ON (SELECTQ I.S.TYPE1 (collect 'MAPLIST) (join (CLISPLOOKUP 'MAPCON (CADR ON))) (do 'MAP) (SHOULDNT 'CLISPFOR0] (T (SHOULDNT 'CLISPFOR0] (CONS (CADR (OR IN ON)) (LIST (CLISPFORF/L I.S.BODY PROGVARS DECLARELST] (COND (BY (NCONC1 I.S. (CLISPFORF/L (LIST (SUBST I.V. (CADR (OR IN ON)) (CADR BY))) PROGVARS DECLARELST)) (* ;; "The reason for the subst is the manual says you can refer to the current tail in a BY by using either the I.V> or the operand to IN/ON. This normalizes it to I>V., which is always (CAR PROGVARS). NOte similar operation in SUBPAIR about 3 pages from here.") )) (GO OUT) MAKEPROG [COND ([AND (EQ I.S.TYPE1 'collect) (SETQ I.S. (GETPROP 'fcollect 'I.S.OPR] (* ;; "This is the form for MAPCAR used by the compiler. Its advantage is it doesnt call NCONC1 and results in no extra function calls. User can disable this by removing the property of FCOLLECT.") [SETQ PROGVARS (APPEND PROGVARS (SETQ TEM (LISTGET1 (CDR I.S.) 'BIND] (SETQ VARS (APPEND VARS TEM))) ((NULL I.S.TYPE1) (GO MP0)) ([NULL (SETQ I.S. (GETPROP I.S.TYPE1 'I.S.OPR] (SHOULDNT 'CLISPFOR0] [COND [(EQ (CAAR I.S.) '=) (SETQ I.S. (EVAL (CDAR I.S.] (T (SETQ I.S. (CAR I.S.] [SETQ I.S.BODY (SUBPAIR '(BODY I.V.) (LIST (COND ((CDR I.S.BODY) (CONS 'PROGN I.S.BODY)) (T (CAR I.S.BODY))) (OR FIRSTI.V. I.V.)) (COND ((LISTP I.S.) (DWIMIFY1 (COPY I.S.))) (T (* ; "For DO, its just BODY.") I.S.] [SETQ I.S.BODY (COND ((EQ (CAR I.S.BODY) 'PROGN) (APPEND (CDR I.S.BODY))) (T (LIST I.S.BODY] (* ; "FORBODY is now a list of forms.") (CLISPFOR4 I.S.BODY) (* ; "Checks for GO's so know where you need an $$OUT typeof structure.") MP0 [COND ((NOT (FASSOC '$$VAL PROGVARS)) (SETQ PROGVARS (CONS '$$VAL PROGVARS] [SETQ RETEXP (LIST (LIST 'RETURN '$$VAL] (COND ((NULL AS) (GO NX))) (SETQ I.V. FIRSTI.V.) MP1 (SETQ IN NIL) (SETQ ON NIL) (SETQ FROM NIL) (SETQ TO NIL) (SETQ BY NIL) MP2 (SELECTQ (CAAR I.S.PTRS) (FROM (SETQ FROM (CADAR I.S.PTRS))) (BY (SETQ BY (CADAR I.S.PTRS))) (IN (SETQ IN (CADAR I.S.PTRS))) (ON (SETQ ON (CADAR I.S.PTRS))) (TO (SETQ TO (CADAR I.S.PTRS))) (AS (GO NX)) NIL) (COND ((SETQ I.S.PTRS (CDR I.S.PTRS)) (GO MP2))) NX (SETQ LSTVAR (CAR LSTVARS)) (COND ((OR IN ON) (SETQ TEM (CADR (OR IN ON))) [COND [(AND [COND [(OR (EQ TEM 'OLD) (EQ TEM 'old)) (* ; "IN OLD --") (SETQ TEM (CADDR (OR IN ON] ((OR (EQ (CAR TEM) 'OLD) (EQ (CAR TEM) 'old)) (* ; "IN (OLD --)") (SETQ TEM (CADR TEM] (COND ((LITATOM TEM) (* ; "IN OLD X or IN (OLD X)") (SETQ LSTVAR TEM)) ((OR (EQ (CAR TEM) 'SETQ) (EQ (CAR TEM) 'SETQQ)) (* ; "IN OLD X _ .. or IN (OLD X _ ..), or IN OLD (X _ ..) or IN (OLD (X _ ..))") (CLISPFORINITVAR (SETQ LSTVAR (CADR TEM)) (CADDR TEM))) (T (SHOULDNT 'CLISPFOR0] (ON (* ; "Normal case, no 'OLD'. No need for dummy variable for ON.") (SETQ LSTVAR I.V.) (CLISPFORINITVAR I.V. TEM)) (T (SETQ PROGVARS (CONS (LIST LSTVAR TEM) PROGVARS] [COND ((EQ I.V. LSTVAR) (SETQ RETPREDS (NCONC1 RETPREDS (LIST 'NLISTP LSTVAR))) (* ; "put it on last so when it is revrsed by CLISPFOR2 will come out first.") ) (T (SETQ TERM (NCONC1 TERM (LIST 'SETQ I.V. (COND [IN (* ;; "reason for checking here rather in retpreds is to avoid user setting a pointer to garbage, e.g. (FOR OLD X IN (QUOTE (19 . 20)) DO PRINT) would leave X set to (CAR 20) otherwise") (SETQ MAKEPROGFLG T) (* ; "to make sure that a $$OUT gets added") (SUBST LSTVAR 'VAR '(CAR (OR (LISTP VAR) (GO $$OUT] (T (SETQ RETPREDS (NCONC1 RETPREDS (LIST 'NLISTP LSTVAR))) LSTVAR] [SETQ ITER (NCONC1 ITER (CONS 'SETQ (CONS LSTVAR (COND [BY (SUBPAIR (LIST I.V. (CADR (OR IN ON))) (LIST LSTVAR LSTVAR) (LIST (CADR BY] (T (LIST (LIST 'CDR LSTVAR] (GO BUILDIT))) (COND (FROM [COND [(SETQ TEM (FMEMB I.V. PROGVARS)) (RPLACA TEM (LIST I.V. (CADR FROM] (T (CLISPFORINITVAR I.V. (CADR FROM] (* ;; "the reason for IVINITFLG (instead of simply searching the PROGVAR lst) is that the iv may bbe an OLD variable and it wont appear anywhere. neverhtless need to know if it is being initialized, because in case of TO, it must be initialzed to 1 if not.") (SETQ IVINITFLG T))) [COND (TO [SETQ TEM (COND [(NUMBERP (CADR BY)) (COND ((MINUSP (CADR BY)) 'LT) (T 'GT] [BY [SETQ BY (LIST 'BY (LIST 'SETQ (GETDUMMYVAR T) (WARNUSER BY] (LIST 'AND (CAR PROGVARS) (LIST 'OR (LIST 'ZEROP (CAR PROGVARS)) (LIST 'COND (LIST (LIST 'MINUSP (CAR PROGVARS)) (LIST (CLISPLOOKUP 'LT I.V.) I.V. (CADR TO))) (LIST T (LIST (CLISPLOOKUP 'GT I.V.) I.V. (CADR TO] ((AND (FIXP (CADR FROM)) (FIXP (CADR TO)) (ILESSP (CADR TO) (CADR FROM))) (SETQQ BY (BY -1)) 'LT) (T 'GT] [COND ((NULL IVINITFLG) (SETQ INITVARS (NCONC1 INITVARS (LIST 'SETQ I.V. 1] (SETQ PROGVARS (CONS (LIST (GETDUMMYVAR) (WARNUSER TO)) PROGVARS)) (SETQ RETPREDS (NCONC1 RETPREDS (COND ((NLISTP TEM) (LIST (CLISPLOOKUP TEM I.V.) I.V. (CAAR PROGVARS))) (T TEM] [COND ((OR BY FROM TO) (SETQ ITER (NCONC1 ITER (LIST 'SETQ I.V. (COND ((OR FROM TO (NUMBERP (CADR BY))) (LIST (CLISPLOOKUP '+ I.V.) I.V. (OR (CADR BY) 1))) (T (CADR BY] BUILDIT (COND ((AND AS I.S.PTRS) (SETQ TEM (CDDDAR I.S.PTRS)) (SETQ I.V. (CAR TEM)) (SETQ IVINITFLG (CADR TEM)) (SETQ I.S.PTRS (CDR I.S.PTRS)) (AND (NULL (SETQ LSTVARS (CDR LSTVARS))) (CLISPFORERR '"too many concurrent loops ")) (GO MP1))) [COND (FINALLY (SETQ TEM (CLISPFOR3 FINALLY)) (SETQ RETEXP (COND ((EQ (CAAR (FLAST TEM)) 'RETURN) TEM) (T (NCONC TEM RETEXP] [COND ((OR MAKEPROGFLG (AND RETPREDS AFTERPREDS)) (SETQ OUTEXP (CONS '$$OUT RETEXP)) (SETQ RETEXP (LIST (LIST 'GO '$$OUT] [COND ((SETQ AFTERPREDS (CLISPFOR2 AFTERPREDS)) (SETQ AFTERPREDS (LIST (LIST 'COND (CONS (COND ((CDR AFTERPREDS) (CONS 'OR AFTERPREDS)) (T (CAR AFTERPREDS))) RETEXP] [COND ((SETQ RETPREDS (CLISPFOR2 RETPREDS)) (SETQ RETPREDS (CONS (COND ((CDR RETPREDS) (CONS 'OR RETPREDS)) (T (CAR RETPREDS))) RETEXP] [COND ((SETQ EXCEPTPREDS (CLISPFOR2 EXCEPTPREDS)) [SETQ EXCEPTPREDS (LIST (COND ((CDR EXCEPTPREDS) (CONS 'OR EXCEPTPREDS)) (T (CAR EXCEPTPREDS))) (LIST 'GO '$$ITERATE] (SETQ I.S.BODY (CONS (COND (RETPREDS (LIST 'COND RETPREDS EXCEPTPREDS)) (T (LIST 'COND EXCEPTPREDS))) I.S.BODY))) (RETPREDS (SETQ I.S.BODY (CONS (LIST 'COND RETPREDS) I.S.BODY] [SETQ I.S. (CONS 'PROG (CONS PROGVARS (NCONC [AND DECLARELST (LIST (CONS 'DECLARE (MAPCONC (DREVERSE DECLARELST) (FUNCTION (LAMBDA (X) (LDIFF (CDADR X) (CADDR X] INITVARS (AND FIRST (CLISPFOR3 FIRST)) (CONS '$$LP (NCONC TERM (AND EACHTIME (CLISPFOR3 EACHTIME)) I.S.BODY (LIST '$$ITERATE) AFTERPREDS ITER (LIST (LIST 'GO '$$LP)) OUTEXP] OUT [SETQ TEM (CDR (LISTGET1 LISPXHIST 'SIDE] (* ; "TEM holds a list of side info") (* ;; "Restores those places where I.V.'s where stuck in, e.g. FOR X IN Y COLLECT FOO was temporarily converted to FOR X IN Y COLLECT (FOO X), and IN Y COLLECT FOO would have been chaged to IN Y COLLECT (FOO $$TEM)") [MAPC UNDOLST (FUNCTION (LAMBDA (X) (FRPLACA (CAR X) (CADR X)) (FRPLACD (CAR X) (CDDR X)) (COND ((SETQ X (FASSOC (CAR X) TEM)) (* ; "to tell dwimnewfile? thatthis change was undone, so not to count the function as being changed") (FRPLACA X '*] (CLISPTRAN EXP I.S.) (RETURN EXP]) (CLISPFOR0A [LAMBDA ($I.S.OPR I.S. LASTPTR) (* rmk%: " 6-Oct-84 12:11") (* ;; "Thisfunction is called when we hit the first i.s.opr following one defined via an istype property. The problems with such operaaors is that we cannot dwiify their operands (or any operands in the i.s.) until we have scanned the entire i.s. and found aal the VARS. This requires that we obtain the definitions of each i.s.opr from its property list, since there may be BIND's in the defiition. However, we cannot substiute in the operands until after we dwimify the operands, since otherwise any errors corrected in the operands wont be seen in the original i.s. when the user prints it after it is dwimified. Furthermore, if we substitute in before we dwimify, we cant distinguish the case where the usr writes a $$VAL, thereby requiring a PROG in the translation, from that where a $$VAL is specified in the definition for the i.s.opr e.g. for COLLECT or JOIN, but nevertheless it is ok to translate to a mapping function. Therefore we insert the definition and take note of thoe things requiring substiution later. and furthermore leave in the original i.s.opr so its operand can also be dwimified.") (DECLARE (SPECVARS LASTPTR)) (* ; "Used freely by IS.OPRS in IDL -- Ron") [COND ((CDR (LISTP $I.S.OPR)) (* ;; "OTHERS. Note that an i.s.opr defned by an i.s.opr property can specify an i.s.type, OTHERS, or both.") (SETQ I.S.OPRSLST (CONS LASTPTR I.S.OPRSLST)) (SETQ I.S. (NCONC [COPY (COND ((EQ (CADR $I.S.OPR) '=) (EVAL (CDDR $I.S.OPR))) (T (CDR $I.S.OPR] I.S.] I.S.]) (CLISPFOR1 [LAMBDA (PTRS FLG) (* wt%: "28-APR-80 16:11") (PROG ((OPRTAIL (CADAR PTRS)) BODYTAIL (NXTOPRTAIL (CADDAR PTRS)) Z TEM LSTFLG BODY) (* ;; "X is the TAIL of the iterative statement beginning with the operator, Y the tail beginning with the next opeator.") (SELECTQ (CAAR PTRS) ((FOR BIND DECLARE ORIGINAL NIL) (GO OUT)) ((IN ON) (AND (NULL FLG) (GO OUT)) (* ; "Already done.") ) (AS (SETQ I.V. (CADDDR (CAR PTRS))) (GO OUT)) NIL) [SETQ BODYTAIL (COND ((OR (EQ (CADR OPRTAIL) 'OLD) (EQ (CADR OPRTAIL) 'old)) (OR MAKEPROGFLG (SETQ MAKEPROGFLG T)) (CDDR OPRTAIL)) ((AND (EQ [CAR (SETQ TEM (LISTP (GETPROP (CADR OPRTAIL) 'CLISPWORD] 'FORWORD) (EQ (GETPROP (CDR TEM) 'I.S.OPR) 'MODIFIER)) (CDDR OPRTAIL)) ((CDR OPRTAIL)) (T (* ;; "special kluge to allow an i.s.opr to smash lastptr to indicate that this operator/operand is to be ignored, e.g. for handling (EVERY CHARACTER IN Z IS --)") (GO OUT] (COND ((EQ BODYTAIL NXTOPRTAIL) (* ; "2 FORWORDS in a row.") (CLISPFORERR OPRTAIL NXTOPRTAIL 'MISSING)) ((NEQ (CDR BODYTAIL) NXTOPRTAIL) (* ; "More than one expression between two forwords.") (GO BREAK))) [COND ((NLISTP (CAR BODYTAIL)) (COND ([AND (NEQ (CAAR PTRS) 'FROM) (NEQ (CAAR PTRS) 'IN) (NEQ (CAAR PTRS) 'ON) (NEQ (CAAR PTRS) 'TO) (SETQ Z (CLISPFUNCTION? BODYTAIL 'NOTVAR] (* ; "E.G. DO PRINT, BY SUB1, etc.") [COND ((NULL (SETQ TEM (OR FIRSTI.V. I.V.))) (CLISPFORERR OPRTAIL NIL 'WHAT)) ((EQ (COND ((EQ OPRTAIL I.S.TYPE) TEM) (T (SETQ TEM I.V.))) (CAR DUMMYVARS)) (* ; "In the case that an i.v. was supplied, make the change permanent. For $$TEM, undo it later.") (SETQ UNDOLST (CONS (CONS BODYTAIL (CONS (CAR BODYTAIL) (CDR BODYTAIL))) UNDOLST] (/RPLNODE BODYTAIL (LIST Z TEM) (CDR BODYTAIL))) (T (DWIMIFY2 BODYTAIL OPRTAIL BODYTAIL T T))) (SETQ Z (CAR BODYTAIL)) (GO C)) ((OR (EQ (CAAR BODYTAIL) 'OLD) (EQ (CAAR BODYTAIL) 'old)) (OR MAKEPROGFLG (SETQ MAKEPROGFLG T)) (DWIMIFY2 (CDAR BODYTAIL) (CAR BODYTAIL) T) (SETQ Z (CAR BODYTAIL)) (GO C)) (T (DWIMIFY1 (CAR BODYTAIL) NIL T) (SETQ Z (CAR BODYTAIL)) (COND ([AND (LISTP (CAAR BODYTAIL)) (NOT (FNTYP (CAAR BODYTAIL] (SETQ LSTFLG T) (GO A)) (T (GO C] BREAK (COND (NXTOPRTAIL (CLISPRPLNODE (SETQ Z (NLEFT OPRTAIL 1 NXTOPRTAIL)) (CAR Z) NIL))) (* ; "Breaks the list justbefore the next operator.") (CLISPRPLNODE BODYTAIL (SETQ Z (CONS (CAR BODYTAIL) (CDR BODYTAIL))) NXTOPRTAIL) (* ;; "Puts parentheses in --- E.g. For X in FOO Y do -- becomes for X in (FOO Y) do necessary in order to call DWIMIFY. Maybe should give DWIMIFY an rgument like stoptail?") (* ;; "Done this way instead of changing CDR X because CDR of first PTR is not EQ to the entry in the history list.") [DWIMIFY2 Z Z T (COND (I.S.TYPE 'IFWORD) (T (* ; "so if it sees a function in a variable position, it will insert parens, e.g. FOR X IN Y PRINT Z") 'FORWORD] A (COND ((NULL (CDR Z)) (* ;; "Because DWIMIFY2 was called with FORMSFLG T, this came out as a list of forms, but there was only one form. E.g. X_ (FOO) became ((SETQ X (FOO))).") (/RPLNODE Z (CAAR Z) (CDAR Z)) (GO C))) B [SELECTQ (CAAR PTRS) ((I.S.TYPE FIRST FINALLY EACHTIME) (* ; "More than one form permitted in operator --- means implicit progn.") (SETQ UNDOLST (CONS (CONS OPRTAIL (CONS (CAR OPRTAIL) (CDR OPRTAIL))) UNDOLST)) (SETQ BODY (CONS 'PROGN (APPEND Z))) (* ; "for possible use in substituting into an i.s.opr") (CLISPRPLNODE OPRTAIL (CDR BODY) (CDR OPRTAIL)) (* ;; "Smashes the operatr itself with the body of i.s. so that when we get back to clispfor0, can distinguish the implicit progn case from others. The setting of UNDOLST is to enable restoration.") [AND (NULL LSTFLG) (CLISPRPLNODE BODYTAIL (CAR Z) (NCONC (CDR Z) (CDR BODYTAIL] (* ; "Takes parentheses back out.") (GO C)) (COND [(FMEMB (CAR PTRS) I.S.OPRSLST) (* ;; "ok for a user defined opeator to have several arguments. (maybe we should phase out the errors and insertion of automatic DO??)") (SETQ BODY (CONS 'PROGN (APPEND Z))) (SETQ UNDOLST (CONS (CONS OPRTAIL (CONS (CAR OPRTAIL) (CDR OPRTAIL))) UNDOLST)) (AND (NULL LSTFLG) (CLISPRPLNODE (CDR OPRTAIL) (CAR Z) (NCONC (CDR Z) (CDDR OPRTAIL] (LSTFLG (CLISPFORERR OPRTAIL)) (I.S.TYPE (CLISPFORERR I.S.TYPE BODYTAIL)) ((EVERY (CDR Z) (FUNCTION LISTP)) (* ; "E.g. For X in Y print Z --.") (* ; "This really should be taken care of in DWIMIFY2 --- I.e. (Y prinnt Z)") (/RPLNODE BODYTAIL (CAR Z) (/NCONC (CDR Z) NXTOPRTAIL)) (SETQQ I.S.TYPE1 do) (SETQ I.S.TYPE (/ATTACH 'DO (CDR BODYTAIL))) (RPLACD PTRS (CONS (LIST 'I.S.TYPE I.S.TYPE NXTOPRTAIL) (CDR PTRS))) (SETQ Z (CAR Z] C (AND (LISTP Z) (CLISPFOR4 Z)) [COND ((FMEMB (CAR PTRS) I.S.OPRSLST) (* ; "I.S.OPRLST is the list of those entries on forptrs defined by an I.S.OPR.") (RETURN (PROG ((END (CADDAR PTRS)) LST) [OR BODY (COND ((EQ (CAR (GETPROP (CADR (SETQ BODY (CADAR PTRS))) 'CLISPWORD)) 'FORWORD) (* ; "modifier") (SETQ BODY (CADDR BODY))) (T (SETQ BODY (CADR BODY] (* ;; "BODY is the operand to the I.S.OPR operator. END is the tail of the i.s. beginning with the next operator following it. The in between operators are the result of the expansion, and need to be dwiified, i.e. processed by clispfor1, and then have i.v. and body substituted into them.") (SETQ LST (CDR PTRS)) LP1 (COND ((NEQ (CADAR LST) END) (* ; "CADR of each entry on PTRS is the actual tail.") (SETQ LST (CLISPFOR1 LST)) (GO LP1))) (SETQ LST (CDR PTRS)) LP2 (COND ((NEQ (CADAR LST) END) (PROG ((LST1 (CADAR LST)) (END1 (CADDAR LST))) (* ; "The tail of the iterative statement begining with the opeator") (* ;; "tail of iterative statement beginning with next operator the segment between tem and nxt corresponds to the body of this opeator") LP3 (COND ((EQ (SETQ LST1 (CDR LST1)) END1) (RETURN))) [SELECTQ (CAR LST1) (BODY (FRPLACA LST1 BODY)) (I.V. (FRPLACA LST1 I.V.)) (AND (LISTP (CAR LST1)) (CLISPDSUBST (CAR LST1] (GO LP3)) (SETQ LST (CDR LST)) (GO LP2))) (RETURN LST] OUT (RETURN (CDR PTRS]) (CLISPRPLNODE [LAMBDA (X A D) (* wt%: 16-DEC-75 23 43) (* ;; "like /rplnode, except that dwimnewfile? does not count it as a change to the function") (COND ((LISTP X) [AND LISPXHIST (UNDOSAVE (LIST 'CLISPRPLNODE X (CAR X) (CDR X] (FRPLACA X A) (FRPLACD X D)) (T (ERRORX (LIST 4 X]) (CLISPFOR2 [LAMBDA (LST FLG) (* lmm "13-Aug-84 16:42") [MAP (SETQ LST (DREVERSE LST)) (FUNCTION (LAMBDA (X) (SELECTQ (CAAR X) (WHEN [RPLACA X (COND (FLG (* ;; "When FLG is true, we are computing a condition forDOING it, and when FLG=NIL, for not doing it, hence difference in sign.") (CADADR (CAR X))) (T (NEGATE (CADADR (CAR X]) (UNLESS [RPLACA X (COND [FLG (NEGATE (CADADR (CAR X] (T (CADADR (CAR X]) ((WHILE REPEATWHILE) [RPLACA X (NEGATE (CADADR (CAR X]) ((UNTIL REPEATUNTIL) (RPLACA X (CADADR (CAR X)))) NIL] LST]) (CLISPFOR3 [LAMBDA (LST) (* wt%: 25-FEB-76 1 59) (* ;; "Used to process FINALLY, EACHTIME, and FIRST lists. LST is a list of form (FINALLY . tail)") (PROG (TEM) (RETURN (MAPCONC (DREVERSE LST) (FUNCTION (LAMBDA (X) (SETQ TEM (CADR X)) (OR (LISTP (CAR TEM)) (LIST (CADR TEM]) (CLISPFORVARS [LAMBDA (PTRS) (* lmm "20-Jul-86 12:40") (* ;; "Does for FOR and BIND what CLISPFOR1 does for the rest of the ptrs. LST is either a (FOR --) or (BIND --) entry from PTRS. CLISPFOR3 handles the following pathological cases. The variables may be spread out, or listed, they may involve assignments, either spread out or listed, and they may be terminated by a form or function in the case that there is no FOROPR. E.g. FOR X Y Z (PRINT X), FOR (X Y Z) PRINT X, FOR X Y _ T Z PRINTT X, FOR (X (Y_T) Z) (PRINT X) etc.") (PROG (TEM OLDFLG LST LST0 L1 VARLST IV (CLISPCONTEXT 'FOR/BIND)) (* ; "clispcontext tells CLISPATOM2 not to try spelling correction on the variable name.") (SETQ L1 (CADDR (CAR PTRS))) [SETQ LST0 (SETQ LST (CDR (CADAR PTRS] LP (COND ((EQ LST0 L1) (GO NX))) (COND ((LITATOM (CAR LST0)) (SELECTQ (CADR LST0) ((_ ¬) (RPLACA LST0 (LIST 'SETQ (CAR LST0) (CADDR LST0))) (RPLACD LST0 (CDDDR LST0)) (GO LP)) NIL) (AND CLISPFLG (STRPOSL LEFT.ARROWS.BITTABLE (CAR LST0)) (SETQ TEM (DWIMIFY2 LST0 LST NIL T T)) (SETQ LST0 TEM))) [(LISTP (CAR LST0)) (SELECTQ (CAAR LST0) ((SETQQ SAVESETQQ) (* ; "SAVESETQ and SAVESETQQ can occur on typein if the user should happen to DW a portion of the I.s.") ) ((SETQ SAVESETQ) (DWIMIFY2 (CDDAR LST0) (CAR LST0) T)) (COND ((AND (OR (EQ (CADAR LST0) '_) (EQ (CADAR LST0) '¬)) (NULL (CDDDAR LST0))) [FRPLACA LST0 (CONS 'SETQ (CONS (CAAR LST0) (CDDAR LST0] (GO LP)) [(AND CLISPFLG (PROG ((X (CAR LST0))) LX (COND ((NLISTP X) (RETURN NIL)) ((AND (LITATOM (CAR X)) (STRPOSL LEFT.ARROWS.BITTABLE (CAR X))) (RETURN T))) (SETQ X (CDR X)) (GO LX))) (CLISPFORVARS1 (CAR LST0) (EQ L1 (CDR LST))) (* ;; "The second argument to CLISPFORVARS1 corresonds to FORMSFLG in the call to DWIMIFY2, e.g. FOR X (Y_T) want FORMSFLG to be NIL. but FOR (X_T Y) want it to be T.") (COND ((AND (LISTP (CAAR LST0)) (NULL (CDAR LST0))) (* ;; "form was (A_form) and now is ((SETQ A form)) so remove extra parentheses inserted because formsflg was (incorrectly) T. Note that when we called clispforvars1, we donot know whether (CAR LST0) is of the form (A_B C_D) or (A _ B), i.e. one or two assignments.") (FRPLACA LST0 (CAAR LST0] ((AND (EQ LST0 LST) (EQ L1 (CDR LST0))) (* ; "Says this is the first argument.") (CLISPFORVARS1 (CAR LST0) T)) (I.S.TYPE (CLISPFORERR LST0 I.S.TYPE)) (T (* ;; "Necessary because LST0 may not really correspnd to ssructure in the original statement, because of ldiff.") (GO ADDDO] (T (CLISPFORERR LST0))) (SETQ LST0 (CDR LST0)) (GO LP) NX (* ;; "The area between LST and LST0 now corresponds to the (dwimified) variables. They may appears as a segment or as a list.") (SETQ LST0 (COND ([AND (EQ LST0 (CDR LST)) (LISTP (CAR LST)) (NOT (FMEMB (CAAR LST) '(SETQ SETQQ OLD old SAVESETQ SAVESETQQ] (SETQ L1 NIL) (CAR LST)) (T LST))) (* ;; "LST0 now corresponds to the beginning of the list of variables, L1 to its end. VARLST will be used to assemble the vlue.") LP1 [COND ((EQ LST0 L1) [COND ((AND IV (NEQ (CAAR PTRS) 'BIND) (NULL I.V.)) (SETQ FIRSTI.V. (SETQ I.V. IV] (* ; "IV is the first variable encountered in the variable list (may be OLD vriable)") (RETURN (DREVERSE VARLST))) ((FMEMB (CAR LST0) '(OLD old)) (SETQ OLDFLG T) (SETQ MAKEPROGFLG T) (SETQ LST0 (CDR LST0)) (SETQ TEM (CAR LST0))) ((FMEMB (CAR (LISTP (CAR LST0))) '(OLD old)) (SETQ OLDFLG T) (SETQ MAKEPROGFLG T) (SETQ TEM (CADAR LST0))) (T (SETQ OLDFLG NIL) (SETQ TEM (CAR LST0] [COND [(AND TEM (LITATOM TEM)) (SETQ VARS (CONS TEM VARS)) (COND ((NULL IV) (SETQ IV TEM) [COND ((EQ (CAAR PTRS) 'AS) (FRPLACD (CDDAR PTRS) (LIST IV] (* ;; "Marks the i.v. for this AS. used by clispfor11 when you specify an operatand which is just a functon name.") )) (COND ((NULL OLDFLG) (SETQ VARLST (CONS TEM VARLST] ((SELECTQ (CAR TEM) ((SETQ SAVESETQ) T) ((SETQQ SAVESETQQ) (FRPLACA TEM 'SETQ) (FRPLACA (CDDR TEM) (LIST 'QUOTE (CADDR TEM))) T) NIL) (SETQ MAKEPROGFLG T) (* ; "Says the expression must translate into an open prog.") (SETQ VARS (CONS (CADR TEM) VARS)) [COND ((NULL IV) (SETQ IV (CADR TEM)) (SELECTQ (CAAR PTRS) (BIND) (FOR (SETQ IVINITFLG T)) (AS (FRPLACD (CDDAR PTRS) (LIST IV T))) (SHOULDNT 'CLISPFORVARS] [COND (OLDFLG (SETQ INITVARS (CONS TEM INITVARS))) (T (SETQ VARLST (CONS (CDR TEM) VARLST] (SETQ UNDOLST (CONS (CONS LST0 (CONS (LIST (CADR TEM) LEFT.ARROW (CADDR TEM)) (CDR LST0))) UNDOLST))) (T (CLISPFORERR (LIST TEM] (SETQ LST0 (CDR LST0)) (GO LP1) ADDDO (/RPLNODE LST0 'DO (CONS (CAR LST0) (CDR LST0))) (SETQ L1 LST0) (FRPLACD PTRS (CONS (LIST 'I.S.TYPE (SETQ I.S.TYPE LST0) (CADDR (CAR PTRS))) (CDR PTRS))) (GO NX]) (CLISPFORVARS1 [LAMBDA (L FLG) (* lmm "21-Jun-85 16:59") (PROG ($TAIL) (SETQ $TAIL L) LP [COND ((NULL $TAIL) (RETURN)) ((STRPOSL LEFT.ARROW.BITTABLE (CAR $TAIL)) (COND ((LITATOM (CAR $TAIL)) (SETQ $TAIL (TAILP (DWIMIFY2 $TAIL L NIL FLG T) L))) (T (CLISPFORVARS1 (CAR $TAIL] (SETQ $TAIL (CDR $TAIL)) (GO LP]) (CLISPFOR4 [LAMBDA (X) (* wt%: 17-DEC-76 19 8) (SELECTQ (CAR X) ((GO RETURN ERROR! RETFROM RETEVAL) (SETQ TERMINATEFLG T) (SETQ MAKEPROGFLG T)) (PROG NIL) (SOME X (FUNCTION (LAMBDA (X) (COND ((EQ X '$$VAL) (SETQ MAKEPROGFLG T) (* ; "keep on looking for RETURN or GO") NIL) ((LISTP X) (CLISPFOR4 X]) (CLISPFORF/L [LAMBDA (EXP VAR DECLARELST) (* lmm "29-Jul-86 00:24") (* ;; "Build the FUNCTIONal expression to be executed as the MAPFN for the FOR loop") (LIST 'FUNCTION (COND (NIL (* ;; "This originally tried to elimate the dummy variable when the FOR was a unary function, but in this case, there was still a problem --- thus this is commented out") (CAAR EXP)) (T (* ; "Otherwise, build a LAMBDA expression that contains all the expressions to be evaluated.") `(LAMBDA ,VAR ,@[AND DECLARELST `((DECLARE ,@(MAPCONC (DREVERSE DECLARELST) (FUNCTION (LAMBDA (X) (LDIFF (CDADR X) (CADDR X] ,@EXP]) (CLISPDSUBST [LAMBDA (X) (* wt%: "21-JAN-80 20:11") (PROG (TEM) (* ;; "goes through X and does a dsubst of I.V. for (QUOTE I.V.) and BODY for (QUOTE BODY) in X AND all of the translations in the hasharray") [MAP X (FUNCTION (LAMBDA (X) (SELECTQ (CAR X) (BODY (FRPLACA X BODY)) (I.V. (FRPLACA X I.V.)) (AND (LISTP (CAR X)) (CLISPDSUBST (CAR X] (COND ((SETQ TEM (GETHASH X CLISPARRAY)) (COND ((EQ (CAR (GETP (CAR X) 'CLISPWORD)) 'CHANGETRAN) (* ;; "these constructs have the property that translation differs depending on expression, e.g. while (fetch foo of x) is always the same regardless of what x is, (change x y) differs depending on what x is.") (PUTHASH X NIL CLISPARRAY) (DWIMIFY1 X)) (T (CLISPDSUBST TEM]) (GETDUMMYVAR [LAMBDA (BINDITFLG) (* lmm "28-MAY-83 18:01") (PROG (VAR) [SETQ VAR (CAR (SETQ DUMMYVARS (OR (CDR DUMMYVARS) (CDR (RPLACD DUMMYVARS (LIST (GENSYM] [COND (BINDITFLG (SETQ VARS (CONS VAR VARS)) (SETQ PROGVARS (CONS VAR PROGVARS] (RETURN VAR]) (CLISPFORINITVAR [LAMBDA (VAR EXP) (* wt%: "21-JAN-80 20:44") (* ;; "this function is called when is necessary to initialize a variable to an expression outside of tje scope of anyvariables bound by i.s., i.e. in the prog binding. it generates a dummy variabe, binds it to exp, and then initializes var to that expresssin") (SETQ PROGVARS (CONS (LIST (GETDUMMYVAR) EXP) PROGVARS)) (SETQ INITVARS (NCONC1 INITVARS (LIST 'SETQ VAR (CAAR PROGVARS]) ) (DEFINEQ (\DURATIONTRAN [LAMBDA (FORM) (* JonL "23-Jul-84 15:39") (PROG ((BODY FORM) (OLDTIMER) (EXPANSION) (SETUPFORM '(SETUPTIMER FORDURATION OLDTIMER . TIMERUNITSLST)) (EXPIREDFORM '(TIMEREXPIRED? \DurationLimit . TIMERUNITSLST)) USINGTIMER USINGBOX FORDURATION RESOURCENAME UNTILDATE TIMERUNITS TIMERUNITSLST TEMP) (DECLARE (SPECVARS TIMERUNITS USINGTIMER USINGBOX FORDURATION RESOURCENAME UNTILDATE) (GLOBALVARS DURATIONCLISPWORDS LCASEFLG)) (* ;; "DURATIONCLISPWORDS is a list of lists, each one of which has the canonical word for some CLISPWORD as second element. First element is the all-caps version, so that SPECVARS communication can take place.") (PROG ((L DURATIONCLISPWORDS) (Z BODY)) LP (AND (NLISTP L) (RETURN (SETQ BODY Z))) (SETQ Z (\CLISPKEYWORDPROCESS Z (CAR L))) (SETQ L (CDR L)) (GO LP)) [COND ((NOT (LITATOM RESOURCENAME)) (SETERRORN 14 FORM) (ERRORX)) ((EQ RESOURCENAME T) (SETQ RESOURCENAME '\ForDurationOfBox] (COND (USINGBOX (AND RESOURCENAME (ERROR "Both 'usingTimer' and 'resourceName' specified" FORM )) (SETQ USINGTIMER USINGBOX))) [COND ((NULL TIMERUNITS) (* ; "Standard case") NIL) (UNTILDATE (ERROR "Can't specify timerUnits for 'untilDate'" FORM)) [(SETQ TEMP (CONSTANTEXPRESSIONP TIMERUNITS)) (COND ((AND (SETQ TEMP (\CanonicalizeTimerUnits (CAR TEMP))) (NEQ TEMP 'MILLISECONDS)) (SETQ TIMERUNITSLST (LIST (LIST 'QUOTE TEMP] (T (SETQ TIMERUNITSLST (LIST TIMERUNITS] (COND ((AND (NULL FORDURATION) (NULL UNTILDATE)) (ERROR "No duration interval" FORM)) ((AND FORDURATION UNTILDATE) (ERROR "Both 'untilDate' and 'forDuration' specified" FORM))) [COND (UNTILDATE (SETQ FORDURATION UNTILDATE) (* ; "Make the 'interval' be the thing supplied for the 'date'") (SETQ SETUPFORM '(SETUPTIMER.DATE FORDURATION OLDTIMER)) (SETQ TIMERUNITSLST '('SECONDS] (COND ([AND (PROG1 RESOURCENAME (* ; "Comment PPLossage")) (NOT (\TIMER.TIMERP (EVAL (LISTGET (GETDEF RESOURCENAME 'RESOURCES NIL 'NOERROR) 'NEW] (ERROR RESOURCENAME "is not a timer RESOURCE"))) (SETQ EXPANSION (LIST [LIST 'LAMBDA '(\DurationLimit) '(DECLARE (LOCALVARS \DurationLimit)) (CONS 'until (CONS EXPIREDFORM 'BODY] SETUPFORM)) [AND (LISTP (CAR TIMERUNITSLST)) (NEQ (CAAR TIMERUNITSLST) 'QUOTE) (SETQ EXPANSION (LIST (LIST 'LAMBDA '(\TimerUnit) '(DECLARE (LOCALVARS \TimerUnit)) EXPANSION) (CAR TIMERUNITSLST))) (SETQ TIMERUNITSLST '(\TimerUnit] (SETQ OLDTIMER (OR RESOURCENAME USINGTIMER)) (SETQ EXPANSION (SUBPAIR '(BODY FORDURATION OLDTIMER TIMERUNITSLST) (LIST BODY FORDURATION OLDTIMER TIMERUNITSLST) EXPANSION)) [COND (RESOURCENAME (SETQ EXPANSION (LIST 'WITH-RESOURCES RESOURCENAME EXPANSION] [COND (LCASEFLG (MAP FORM (FUNCTION (LAMBDA (X) (PROG [(Y (GETPROP (CAR X) 'CLISPWORD] (COND ((AND (LISTP Y) (SETQ Y (CDR Y)) [LITATOM (COND ((NLISTP Y) Y) (T (SETQ Y (CAR Y] (NEQ Y (CAR X))) (/RPLACA X Y] (RETURN EXPANSION]) (\CLISPKEYWORDPROCESS [LAMBDA (FORM WORDLST) (* JonL "27-APR-83 04:39") (* ;; "Looks for the first 'keyword' in the list FORM which is mentioned in the WORDLST -- and if one is found, the the first keyword in WORDLST is presumed to be the name of a variable to be set to the keyword's value. Returns the original list with the keyword pair non-destructively spliced out.") (COND ((NULL FORM) NIL) ((FMEMB (CAR FORM) WORDLST) (SET (CAR WORDLST) (CADR FORM)) (CDDR FORM)) ((NLISTP FORM) FORM) (T (PROG ((X WORDLST) TMP) LP (COND ([AND (LISTP X) (NOT (SETQ TMP (FMEMB (CAR X) FORM] (SETQ X (CDR X)) (GO LP))) (RETURN (COND (TMP (SET (CAR WORDLST) (CADR TMP)) (NCONC (LDIFF FORM TMP) (CDDR TMP))) (T FORM]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS DWIMUNDOCATCH MACRO ((TAG UNDOFORM) (* ;; "Hairy control structure used by DWIMIFY. Effectively (CATCH TAG (UNDONLSETQ UNDOFORM)), except that it ensures that the undoing occurs not only when the UNDONLSETQ returns NIL (from ERROR!), but also when a non-list is thrown to TAG. THROW is used in various places to tell the caller to do something different (usually try again after a successful spelling correction). The body of this macro is a copy of the UNDONLSETQ macro appropriately modified.") (PROG ((LISPXHIST LISPXHIST) UNDOSIDE0 UNDOSIDE UNDOTEM) (DECLARE (SPECVARS LISPXHIST)) [COND ([LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST 'SIDE] (SETQ UNDOSIDE0 (CDR UNDOSIDE))) (T (SETQ UNDOSIDE0 UNDOSIDE) (SETQ UNDOSIDE (LIST 0)) (COND (LISPXHIST (LISTPUT1 LISPXHIST 'SIDE UNDOSIDE)) (T (SETQ LISPXHIST (LIST 'SIDE UNDOSIDE] [SETQ UNDOTEM (RESETVARS (%#UNDOSAVES) (RETURN (CL:CATCH TAG (XNLSETQ UNDOFORM] (COND ((EQ UNDOSIDE0 'NOSAVE) (LISTPUT1 LISPXHIST 'SIDE 'NOSAVE)) (T (UNDOSAVE))) [COND ((NLISTP UNDOTEM) (* ;  "undo side effects on %"error%" return") (UNDONLSETQ1 (CDR UNDOSIDE) (LISTP UNDOSIDE0] (RETURN UNDOTEM)))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: FORBLOCK (ENTRIES CLISPFOR) CLISPFORVARS CLISPFOR0 CLISPFOR2 CLISPFORINITVAR CLISPDSUBST \CLISPKEYWORDPROCESS CLISPFORF/L CLISPFOR4 CLISPFORVARS1 CLISPFOR3 CLISPFOR1 CLISPFOR0A CLISPFOR \DURATIONTRAN (SPECVARS UNDOSIDE LISPXHIST BODY I.S.TYPE1 I.S.TYPE TERMINATEFLG FIRSTI.V. I.V. PROGVARS MAKEPROGFLG IVINITFLG INITVARS UNDOLST DWIMIFYING VARS DWIMIFYCHANGE DUMMYVARS I.S.OPRSLST CLISPCONTEXT UNDOSIDE0 EXP)) (BLOCK%: DWIMIFYBLOCK CLBINARYMINUS? CLISPANGLEBRACKETS CLISPATOM CLISPATOM0 CLISPATOM1 CLISPATOM1A CLISPATOM1B CLISPATOM2 CLISPATOM2A CLISPATOM2C CLISPATOM2D CLISPATOMARE1 CLISPATOMARE2 CLISPATOMIS1 CLISPATOMIS2 CLISPBROADSCOPE CLISPBROADSCOPE1 CLISPCAR/CDR CLISPCAR/CDR1 CLISPCAR/CDR2 CLISPIF CLISPIF0 CLISPIF1 CLISPIF2 CLISPIF3 CLISPLOOKUP CLISPRESPELL CLRPLNODE CLUNARYMINUS? DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1 DWIMIFY1? DWIMIFY1A DWIMIFY2 DWIMIFY2? DWIMIFY2A DWIMIFYFNS DWMFY0 DWMFY1 DWMFY2 FIX89 FIX89A FIX89TYPEIN FIXAPPLY FIXATOM FIXATOM1 FIXCONTINUE FIXCONTINUE1 FIXLAMBDA GETDUMMYVAR GETVARS GETVARS1 RETDWIM RETDWIM1 SHRIEKER STOPSCAN? WTFIX WTFIX0 WTFIX1 (ENTRIES WTFIX WTFIX1 DWIMIFYFNS DWIMIFY DWIMIFY0 DWIMIFY0? DWIMIFY1A GETDUMMYVAR DWIMIFY2 DWIMIFY2? DWIMIFY1? DWIMIFY1 DWIMIFY2A CLISPLOOKUP) (SPECVARS 89CHANGE 89FLG BRACKET BRACKETCNT ATTEMPTFLG BACKUPFLG BODY BREAKFLG BROADSCOPE CLISPCHANGE CLISPCHANGES CLISPCONTEXT CLISPERTYPE CLTYP CURRTAIL DWIMIFYCHANGE DWIMIFY0CHANGE DWIMIFYFLG DWIMIFYING ENDTAIL EXP EXPR FAULTAPPLYFLG FAULTARGS FAULTFN FAULTPOS FAULTX FAULTXX FIRSTI.V. FIXCLK FORMSFLG I.S.TYPE I.S.TYPE1 HISTENTRY I.S. I.V. INITVARS IVINITFLG LISPFN CHARLST MAKEPROGFLG NCONC1LKUP NCONCLKUP NEGFLG NEWTAIL NEXTAIL SUBPARENT NOFIX89 NOSAVEFLG ONEFLG ONLYSPELLFLG PARENT SIDES TAIL TENTATIVE TERMINATEFLG TYP TYPE-IN? UNDOLST UNDOSIDE UNDOSIDE0 VAR1 VAR2 VARS WORKFLAG UNARYFLG DEST FOR I.S.OPRSLST PROGVARS)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DWIMINMACROSFLG CHECKCARATOMFLG TREATASCLISPFLG CLISPHELPFLG CLISPIFTRANFLG CLISPRETRANFLG DWIMCHECKPROGLABELSFLG DWIMCHECK#ARGSFLG SHALLOWFLG PRETTYTRANFLG CLEARSTKLST LCASEFLG LAMBDASPLST DURATIONCLISPWORDS CLISPTRANFLG CLISPIFWORDSPLST LPARKEY DWIMUSERFORMS DWIMKEYLST SPELLINGS3 SPELLINGS1 CLISPARRAY CLISPFLG CLISPCHARS CLISPISNOISEWORDS CLISPLASTSUB CLISPISWORDSPLST CLISPCHARRAY CLISPINFIXSPLST OKREEVALST WTFIXCHCONLST1 WTFIXCHCONLST RPARKEY NOFIXFNSLST0 NOFIXVARSLST0 LISPXHISTORY DWIMEQUIVLST COMMENTFLG USERWORDS SPELLINGS2 FILELST CLISPFORWORDSPLST CLISPDUMMYFORVARS LASTWORD COMPILERMACROPROPS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (ADDTOVAR NLAML BREAK1) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DWIMIFYFNS) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (RPAQ? DWIM.GIVE.UP.TIME ) (RPAQ? DWIM.GIVE.UP.INTERVAL 2000) (PUTPROPS DWIMIFY COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5654 53366 (DWIMIFYFNS 5664 . 7147) (DWIMIFY 7149 . 8208) (DWIMIFY0 8210 . 14587) ( DWIMIFY0? 14589 . 16658) (DWMFY0 16660 . 17030) (DWIMIFY1 17032 . 17107) (DWIMIFY1? 17109 . 17655) ( DWMFY1 17657 . 27339) (DWIMIFY1A 27341 . 28276) (DWIMIFY2 28278 . 28372) (DWIMIFY2? 28374 . 28947) ( DWMFY2 28949 . 41405) (DWIMIFY2A 41407 . 42269) (CLISPANGLEBRACKETS 42271 . 42532) (SHRIEKER 42534 . 52011) (CLISPRESPELL 52013 . 52720) (EXPRCHECK 52722 . 53364)) (53367 148606 (CLISPATOM0 53377 . 55368 ) (CLISPATOM1 55370 . 81116) (CLRPLNODE 81118 . 81902) (STOPSCAN? 81904 . 85770) (CLUNARYMINUS? 85772 . 88018) (CLBINARYMINUS? 88020 . 89957) (CLISPATOM1A 89959 . 94944) (CLISPATOM1B 94946 . 95904) ( CLISPATOM2 95906 . 119040) (CLISPNOEVAL 119042 . 120567) (CLISPLOOKUP 120569 . 122877) (CLISPATOM2A 122879 . 126659) (CLISPBROADSCOPE 126661 . 128011) (CLISPBROADSCOPE1 128013 . 129883) (CLISPATOM2C 129885 . 133554) (CLISPATOM2D 133556 . 135828) (CLISPCAR/CDR 135830 . 140128) (CLISPCAR/CDR1 140130 . 143689) (CLISPCAR/CDR2 143691 . 144064) (CLISPATOMIS1 144066 . 145009) (CLISPATOMARE1 145011 . 145845) (CLISPATOMARE2 145847 . 147391) (CLISPATOMIS2 147393 . 148604)) (148607 224368 (WTFIX 148617 . 148844 ) (WTFIX0 148846 . 149467) (WTFIX1 149469 . 168890) (RETDWIM 168892 . 174459) (DWIMERRORRETURN 174461 . 174619) (DWIMARKASCHANGED 174621 . 175877) (RETDWIM1 175879 . 181388) (FIX89TYPEIN 181390 . 182844) (FIXLAMBDA 182846 . 183359) (FIXAPPLY 183361 . 186156) (FIXATOM 186158 . 192364) (FIXATOM1 192366 . 198783) (FIXCONTINUE 198785 . 199238) (FIXCONTINUE1 199240 . 200174) (CLISPATOM 200176 . 204058) ( GETVARS 204060 . 205587) (GETVARS1 205589 . 205960) (FIX89 205962 . 207791) (FIXPRINTIN 207793 . 209020) (FIX89A 209022 . 209770) (CLISPFUNCTION? 209772 . 214676) (CLISPNOTVARP 214678 . 215242) ( CLISP-SIMPLE-FUNCTION-P 215244 . 215580) (CLISPELL 215582 . 216701) (FINDFN 216703 . 223479) ( DWIMUNSAVEDEF 223481 . 224042) (CHECKTRAN 224044 . 224366)) (224369 235334 (CLISPIF 224379 . 226044) ( CLISPIF0 226046 . 232242) (CLISPIF1 232244 . 232869) (CLISPIF2 232871 . 233980) (CLISPIF3 233982 . 235332)) (235335 298091 (CLISPFOR 235345 . 236589) (CLISPFOR0 236591 . 269818) (CLISPFOR0A 269820 . 271805) (CLISPFOR1 271807 . 283210) (CLISPRPLNODE 283212 . 283699) (CLISPFOR2 283701 . 284733) ( CLISPFOR3 284735 . 285285) (CLISPFORVARS 285287 . 293567) (CLISPFORVARS1 293569 . 294117) (CLISPFOR4 294119 . 294723) (CLISPFORF/L 294725 . 295860) (CLISPDSUBST 295862 . 297053) (GETDUMMYVAR 297055 . 297465) (CLISPFORINITVAR 297467 . 298089)) (298092 304205 (\DURATIONTRAN 298102 . 302964) ( \CLISPKEYWORDPROCESS 302966 . 304203))))) STOP \ No newline at end of file diff --git a/sources/EDIT b/sources/EDIT new file mode 100644 index 00000000..a13eea94 --- /dev/null +++ b/sources/EDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 16:23:16" {DSK}local>lde>lispcore>sources>EDIT.;2 138537 changes to%: (VARS EDITCOMS) previous date%: "23-Nov-87 15:31:02" {DSK}local>lde>lispcore>sources>EDIT.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1983 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 EDITCOMS) (RPAQQ EDITCOMS [ (* ;; "the teletype editor") (FNS TTY/EDITE TTY/EDITL %## EDIT* EDIT%: EDITDEFAULT EDITDEFAULT1 EDITH EDITRAN EDITTO EDITXTR EDLOC EDLOCL EDOR EDRPT EDUP ESUBST ESUBST1 EDITFERROR EDITFA EDITELT UNSAVEBLOCK? EDITF1 EDITF2 EDITL0 EDITL1 EDITL2 UNDOEDITL EDITCOM EDITCOMA EDITCOML EDITCONT EDITMAC EDITMBD EDITMV EDITCOMS EDIT!UNDO UNDOEDITCOM UNDOEDITCOM1 EDITCOM1 EDITSAVE EDITSAVE1 EDITSMASH EDITSMASH1 EDITSW EDITNCONC EDITAPPEND EDIT1F EDIT2F EDIT4E EDIT4E1 EDITQF EDIT4F EDIT4F1 EDIT4F2 EDIT4F3 EDITFPAT EDITFPAT1 EDITFINDP FEDITFINDP EDITBELOW EDITBF EDITBF1 EDITNTH BPNT BPNT0 EDIT.RI EDIT.RO EDIT.LI EDIT.LO EDIT.BI EDIT.BO) (INITVARS (EDITRDTBL (COPYREADTABLE "OLD-INTERLISP-T"))) (USERMACROS ED) (BLOCKS (EDITBLOCK TTY/EDITL EDITL0 EDITL1 UNDOEDITL EDITCOM EDITCOMA EDITCOML EDITMAC EDITCOMS EDIT!UNDO UNDOEDITCOM UNDOEDITCOM1 EDITCOM1 EDITSMASH EDITSMASH1 EDITNCONC EDITAPPEND EDIT1F EDIT2F EDITNTH BPNT BPNT0 EDIT.RI EDIT.RO EDIT.LI EDIT.LO EDIT.BI EDIT.BO EDITDEFAULT EDITDEFAULT1 %## EDUP EDIT* EDOR EDRPT EDLOC EDLOCL EDIT%: EDITMBD EDITXTR EDITELT EDITCONT EDITSW EDITMV EDITTO EDITBELOW EDITRAN EDITSAVE EDITSAVE1 EDITH (ENTRIES TTY/EDITL EDITL0 %## UNDOEDITL BPNT0 EDITCONT EDLOCL) (SPECVARS L ATM COM LCFLG %#1 %#2 %#3 UNDOLST UNDOLST1 LASTAIL MARKLST UNFIND LASTP1 LASTP2 COMS EDITCHANGES EDITHIST0 LISPXID USERHANDLE) (RETFNS EDITL0 EDITL1) (BLKAPPLYFNS EDIT%: EDITMBD EDITMV EDITXTR EDITSW) (BLKLIBRARY NTH LAST MEMB NLEFT) (NOLINKFNS PRINTDEF EDITRACEFN EDITUSERFN) (LOCALFREEVARS FINDFLAG EDITHIST UNDOLST1 COM L L0 COM0 UNDOLST EDITLFLG ATM MARKLST EDITHIST0 UNFIND TYPEIN LCFLG LASTP1 LASTP2 LASTAIL COPYFLG ORIGFLG COMS TOFLG C LVL EDITCHANGES EDITLISPFLG) (GLOBALVARS EDITCALLS P.A.STATS EDITUNDOSTATS EDITUNDOSAVES SPELLSTATS1 P.A.STATS EDITUSERFN EDITIME DONTSAVEHISTORYCOMS COMPACTHISTORYCOMS EDITEVALSTATS MAXLOOP EDITCOMSL EDITCOMSA DWIMFLG CLISPTRANFLG EDITOPS HISTORYCOMS REREADFLG HISTSTR3 EDITRDTBL EDITHISTORY HISTSTR0 LISPXHISTORY LISPXBUFS EDITRACEFN EDITMACROS USERMACROS CLISPARRAY CHANGESARRAY COMMENTFLG **COMMENT**FLG EDITSMASHUSERFN)) (EDITFINDBLOCK EDIT4E EDIT4E1 EDITQF EDIT4F EDITFPAT EDITFPAT1 EDIT4F1 EDIT4F2 EDIT4F3 EDITSMASH EDITSMASH1 EDITFINDP EDITBF EDITBF1 ESUBST (ENTRIES EDIT4E EDIT4E1 EDITQF EDIT4F EDITFPAT EDITFINDP EDITBF ESUBST) (LOCALFREEVARS C3 CHANGEFLG N TOPLVL FF NEWFLG FLG) (GLOBALVARS EDITUNDOSAVES CHCONLST2 EDITQUIETFLG CHCONLST1 MAXLEVEL UPFINDFLG CLISPTRANFLG CHANGESARRAY CLISPARRAY EDITHISTORY) (SPECVARS ATM L COM UNFIND LASTAIL UNDOLST1 EDITCHANGES)) (NIL EDITFA TTY/EDITE (SPECVARS EDITCHANGES EDITFN))) (GLOBALVARS FILELST DWIMFLG DWIMWAIT DWIMLOADFNSFLG) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA %##) (NLAML EDITF2) (LAMA]) (* ;; "the teletype editor") (DEFINEQ (TTY/EDITE [LAMBDA (EXPR COMS ATM TYPE IFCHANGEDFN) (* ; "Edited 20-Nov-87 14:25 by woz") (* ;; "Used by both EDITF and EDITV. Calls EDITL in such a way that if a change occurs, and EDITL is exited via OK, STOP, or even conrol-D, the appropriate call to NEWFILE? is executed. Since it checks to see if a change has been made, it also does the UNSAVEDEFING for EDITF in he case that we are editing a PROP. Value is the edited expression or generates an error.") (RESETLST (PROG ((ECHOFILE (SELECTQ (SYSTEMTYPE) (D (TTYINFOSTREAM)) T)) EDITCHANGES TEM) (COND ((NLISTP EXPR) (ERROR EXPR '"not editable." T))) [AND ATM (RESETSAVE NIL (CONS 'EDITF2 (SETQ EDITCHANGES (LIST ATM NIL TYPE IFCHANGEDFN EXPR] (PREEDITFN ATM TYPE EDITCHANGES) (* ;  "extensions to handle editing property lists, vars etc.") [ERSETQ (SETQ TEM (COND ((SETQ EXPR (LAST (EDITL (LIST EXPR) COMS ATM NIL EDITCHANGES))) (CAR EXPR)) (T (HELP "EDITL returned NIL"] (COND ((CADR EDITCHANGES) (* ; "A change was made.") (COND ((NULL TEM) (ERROR!))) (SELECTQ TYPE (FNS (* ;;  "eliminate PROP edit type. just call PUTDEF, and let it worry about being smart about DFNFLG.") (PUTDEF ATM 'FNS TEM 'CHANGED)) (PROP (HELP "PROP edit type is no longer supported." "Where did this come from?")) (VARS (SAVESET ATM TEM NIL 'NOSAVE)) (PROPLST (/SETPROPLIST ATM TEM)) NIL)) ((NULL TEM) (ERROR!)) ((EQ TYPE 'PROP) (PRIN1 '"not changed, so not unsaved " ECHOFILE T))) (COND ((AND TYPE ATM ADDSPELLFLG) (ADDSPELL ATM (SELECTQ TYPE ((FNS PROP) NIL) (VARS T) (PROPLST 0) 0)) (* ;; "TYPE is FNS or PROP for calls from EDITF, VARS for calls from EDITV, and PROPLST for calls from EDITP. TYPE can also be a prettytype. Can also be the name of a CHANGEDLST in the case of a direct call from the user.") )) (RETURN TEM]) (TTY/EDITL [LAMBDA (L COMS ATM MESS EDITCHANGES) (* DD%: "20-Oct-81 14:02") (* ;  "Takes edit push-down list L as argument. Returns L as value.") (COND ((NLISTP L) L) (T (PROG (LASTAIL MARKLST UNDOLST UNDOLST0 UNDOLST1 UNFIND LASTP1 LASTP2 TEM1 TEM2 EDITHIST0 EDITIME0 EDITLISPFLG) (* ;  "EDITCHANGES is a cell used for destructively marking whether the edit has caused any changes.") (COND ((EQ (CAR (LISTP COMS)) 'START) (SETQ READBUF (CDR COMS)) (SETQ COMS NIL))) [COND ((AND ATM (NULL COMS) EDITHISTORY) (SETQ EDITHIST0 T) (LISPXWATCH EDITCALLS) (SETQ EDITIME0 (CLOCK 0] (SETQ TEM2 (CAR (LAST L))) (* ;; "TEM2 is the top level xpression. NOte that L is usually a list of only one element, i.e. you usually start editing at the top, but not necessarily, since editl can be called dirctly.") [COND ([OR [EQ TEM2 (CAR (LAST (CAR (SETQ TEM1 (GETPROP 'EDIT 'LASTVALUE] [AND ATM (EQ TEM2 (CAR (LAST (CAR (SETQ TEM1 (GETPROP ATM 'EDIT-SAVE] (SOME (CAR LISPXHISTORY) (FUNCTION (LAMBDA (X) (EQ TEM2 (CAR (LAST (CAR (SETQ TEM1 (CADR (FMEMB 'EDIT X] (* ;; "First clause is old method of always saving last call on editor property list. Second clause searches history list for a call to editor corresponding to this expression.") (AND (NULL (CDR L)) (SETQ L (CAR TEM1))) (* ;; "if editor was called with an edit chain specified, rather just list of the xpression, use this chain.") (SETQ MARKLST (CADR TEM1)) (SETQ UNDOLST (CADDR TEM1)) [COND ((CAR UNDOLST) (* ; "Don't want to block it twice.") (SETQ UNDOLST (CONS NIL UNDOLST] (SETQ UNDOLST0 UNDOLST) (* ;; "Marks UNDOLST as of this entry to editor, so UNDO of this entire EDIT session won't go too far back.") (SETQ UNFIND (CDDDR TEM1] (COND ([PROG1 (NLSETQ (SETQ L (EDITL0 L COMS MESS T))) [COND (UNDOLST1 (SETQ UNDOLST (CONS (CONS T (CONS L UNDOLST1)) UNDOLST] (COND ((NEQ UNDOLST UNDOLST0) (AND LISPXHIST (UNDOSAVE (LIST 'UNDOEDITL L UNDOLST UNDOLST0) LISPXHIST)) (* ;  "Takes care of making the entire call to EDITL undoable.") )) (COND (EDITIME0 (SETATOMVAL 'EDITIME (IPLUS EDITIME (IDIFFERENCE (CLOCK 0) EDITIME0] (* ;; "If one of COMS causes an error, or if call to session is terminated by a STOP, still want to move undo information to LISPXHISTORY.") (RETURN L)) (T (ERROR!]) (%## [NLAMBDA COMS (PROG ((L (EVQ L)) UNDOLST1 (LASTAIL (EVQ LASTAIL)) (MARKLST (EVQ MARKLST)) (UNFIND (EVQ UNFIND))) (* ;; "## is an external entry to the editblock, so local freevariables must be looked up or traps will occur. LASAIL, MARKLT, and UNDOLST1 are rebound (and therefore looked up) here to avoid their being changed by the call to ##. The rest are looked up in EDITL0 because it is called with EDITLFLG=nil.") (RETURN (CAR (COND ((NULL COMS) L) (T (EDITL0 L COMS]) (EDIT* [LAMBDA (N) (* ;; "Equivalent to a !0 followed by an appropriate number.") (CAR (SETQ L (PROG (COM (L L) [X (PROG ((L L)) (EDUP) (RETURN (CAR L] TEM) (* ;; "COM is rebound here because EDITCOM resets it so that 'CURRENT' command is typed when failure occurs. However, want to see BK typed, not !0 or -3") (EDITCOM '!0) (SETQ TEM (CAR L)) [COND ([COND ((MINUSP N) (SETQ TEM (NLEFT TEM (MINUS N) X))) (T (LISTP (SETQ TEM (CDR (NTH X N] (SETQ LASTAIL TEM) (RETURN (CONS (CAR TEM) L] (ERROR!]) (EDIT%: [LAMBDA (TYPE LC X) (* DD%: " 7-Oct-81 20:49") (PROG (TOFLG) [SETQ X (MAPCAR X (FUNCTION (LAMBDA (X) (COND [(EQ (CAR (LISTP X)) '%##) (PROG ((L L) UNDOLST1 (LCFLG T)) (RETURN (COPY (EDITCOMS (CDR X] (T X] (COND (LC [COND ((EQ (CAR (LISTP LC)) 'HERE) (SETQ LC (CDR LC] (EDLOC LC T))) (EDUP) (SELECTQ TYPE ((B BEFORE) (EDIT2F -1 X)) ((A AFTER) (COND ((CDAR L) (EDIT2F -2 X)) (T (EDITCOML (CONS 'N X) COPYFLG)))) ((%: FOR) [COND ((OR X (CDAR L)) (EDIT2F 1 X)) ((MEMB (CAR L) (CADR L)) (* ;; "Singleton list, e.g. (-- ((A)) --) (DELETE A) --- result is (-- NIL --); or (-- (A) --) and say (DELETE A 1) result is (-- NIL --)") (EDUP) (EDIT2F 1 (LIST NIL))) (T (* ;  "Delete last element of list of more than 1 element.") (EDITCOMS '(0 (NTH -2) (2]) (ERROR!)) (RETURN L]) (EDITDEFAULT [LAMBDA (EDITX) (* rmk%: " 6-JUN-82 15:13") (DECLARE (GLOBALVARS LPARKEY)) (PROG (EDITY EDITZ LISPXHIST) (* ;; "LISPXHIST is rebound so that messages associated with spelling corrections will not appear on history list.") (COND [(AND (LISTP EDITX) (SETQ EDITY (FASSOC (CAR EDITX) EDITOPS))) (RETURN (EDITRAN EDITX (CDR EDITY] [LCFLG (RETURN (COND ((EQ LCFLG T) (EDITQF EDITX)) (T (* ; "E.g. LCFLG= _ in BELOW command.") (EDITCOM (LIST LCFLG EDITX) TYPEIN] [(NLISTP EDITX) (COND ((AND EDITHISTORY TYPEIN (FMEMB EDITX HISTORYCOMS)) (RETURN (EDITH EDITX))) ((AND EDITUSERFN (SETQ EDITY (EDITUSERFN EDITX))) (RETURN (EDITCOM EDITY TYPEIN))) ((AND (NOT (U-CASEP EDITX)) (FMEMB (SETQ EDITY (U-CASE EDITX)) EDITCOMSA)) (SETQ EDITX EDITY) (GO BACKUP)) ((OR (FMEMB EDITX EDITCOMSL) (AND EDITY (FMEMB EDITY EDITCOMSL) (SETQ EDITX EDITY))) (COND ((AND [NULL (CDR (SETQ EDITX (COND (TYPEIN (READLINE EDITRDTBL (LIST EDITX))) ((EQ EDITX (CAR COMS)) (EDITSMASH COMS (CONS (CAR COMS) (CDR COMS))) (CAR COMS] (NEQ (CAR EDITX) '%:)) (* ;; ": by itself means DELETE if nothing else follows it. : is not an atomic command so that : -- will work as a line command.") (ERROR!))) (AND TYPEIN (EDITSAVE1 EDITX T))) ((AND TYPEIN (NULL REREADFLG) (EQ LPARKEY (NTHCHAR EDITX 1))) [EDITDEFAULT1 (SETQ EDITY (RPLSTRING EDITX 1 '"("] (GNC EDITY) [SETQ EDITX (READLINE EDITRDTBL (LIST (MKATOM EDITY] (AND EDITHIST (FRPLACA (CAAAR EDITHISTORY) EDITX))) ((AND TYPEIN (NULL REREADFLG) (FNTYP EDITX) (COND ([NULL (AND (CDR (SETQ EDITY (READLINE EDITRDTBL (LIST EDITX) T))) (NULL (CDDR EDITY)) (OR (NULL (CADR EDITY)) (LISTP (CADR EDITY))) (NOT (FMEMB (CAADR EDITY) EDITCOMSL] (SETQ READBUF (APPEND (CDR EDITY) (CONS HISTSTR0 READBUF))) (* ; "put it back.") NIL) (T T))) (EDITDEFAULT1 'E EDITX) (AND EDITHIST (FRPLACA (CAAR EDITHISTORY) (SETQ EDITX EDITY))) (EDITH '!E) (RETURN)) ([AND DWIMFLG (OR TYPEIN (EQ EDITX (CAR COMS))) (SETQ EDITY (COND ((AND (EQ (NTHCHARCODE EDITX -1) (CHARCODE P)) (GLC (SETQ EDITY (MKSTRING EDITX))) (SELECTQ (SETQ EDITY (MKATOM EDITY)) ((^ _ UP NX BK !NX UNDO REDO CL DW) T) (NUMBERP EDITY))) (* ;  "The GLC removes the last character.") (EDITDEFAULT1 EDITY 'P) (CONS EDITY 'P)) (T (FIXSPELL EDITX 70 EDITCOMSA (NULL TYPEIN) T] [COND ((LISTP EDITY) [COND [TYPEIN (SETQ READBUF (CONS (CDR EDITY) (CONS HISTSTR0 READBUF] (T (EDITSMASH COMS (CAR EDITY) (CONS (CDR EDITY) (CDR COMS] (SETQ EDITY (CAR EDITY))) ((NULL TYPEIN) (EDITSMASH COMS EDITY (CDR COMS] (SETQ EDITX EDITY) (GO BACKUP)) ([AND [CDR (SETQ EDITY (COND (TYPEIN (READLINE EDITRDTBL (LIST EDITX))) ((EQ EDITX (CAR COMS)) COMS] (COND ((NEQ (CAR EDITY) EDITX) (* ;  "In the call to READLINE above, the user typed control-U and changed the command himself.") T) ((AND DWIMFLG (SETQ EDITZ (FIXSPELL EDITX 70 EDITCOMSL (NULL TYPEIN) T))) (* ;  "E.g. user types MBBD -- without parentheses.") (COND [(LISTP EDITZ) (EDITSMASH EDITY (CAR EDITZ) (CONS (CDR EDITZ) (CDR EDITY] (T (EDITSMASH EDITY EDITZ (CDR EDITY] (AND (NULL TYPEIN) (EDITSMASH COMS (CONS (CAR COMS) (CDR COMS))) (SETQ EDITY (CAR COMS))) (SETQ EDITX EDITY) (EDITSAVE1 EDITX T)) (T (EDITSAVE1 EDITY T) (ERROR!] ((AND EDITHISTORY (FMEMB (CAR EDITX) HISTORYCOMS)) (RETURN (EDITH EDITX))) ((AND EDITUSERFN (SETQ EDITY (EDITUSERFN EDITX))) (RETURN (EDITCOM EDITY TYPEIN))) ((NLISTP EDITX) (ERROR!)) ((AND (EQ (CAR EDITX) '!) (NULL (CDR EDITX))) (EDITDEFAULT1 '(1)) (FRPLACA EDITX 1)) ((AND (EQ (CAR EDITX) '%#) (NULL (CDR EDITX))) (EDITDEFAULT1 '(3)) (FRPLACA EDITX 3)) [(AND DWIMFLG (ATOM (CAR EDITX)) (SETQ EDITY (FIXSPELL (CAR EDITX) 70 EDITCOMSL (NULL TYPEIN) T))) (COND [(LISTP EDITY) (EDITSMASH EDITX (CAR EDITY) (CONS (CDR EDITY) (CDR EDITX] (T (EDITSMASH EDITX EDITY (CDR EDITX] (T (ERROR!))) [RETURN (COND ((EQ REREADFLG 'ABORT) NIL) (T (EDITCOM (SETQ COM EDITX) TYPEIN] BACKUP (SETQ COM EDITX) (COND ((AND EDITHIST TYPEIN (NULL REREADFLG)) (FRPLACA EDITHISTORY (CDAR EDITHISTORY)) (FRPLACA (CDR EDITHISTORY) (SUB1 (CADR EDITHISTORY))) (EDITSAVE COM) (* ;; "Can't just smash com onto front of history because now that it has been corrected, EDITSAVE may not actually save it, e.g. suppose COM is a misspelled P.") )) (RETURN (EDITCOM COM TYPEIN]) (EDITDEFAULT1 [LAMBDA (X Y) (* ; "Edited 10-Nov-87 14:06 by jds") (PRIN1 "=" T) (COND ((STRINGP X) (PRIN1 X T)) (T (PRIN2 X T T))) (COND (Y (SPACES 1 T) (PRIN2 Y T T))) (TERPRI T) (LISPXWATCH SPELLSTATS1]) (EDITH [LAMBDA (C) (* ; "wt: 5-APR-77 17 56") (PROG (X COMS LINE TEM) [SELECTQ C ((DO !E !F !N) (* ;  "USE is used when operator was incorrect, wheras DO is used when operator was omitted.") [SETQ X (SELECTQ C (!E (* ;  "!E is equivalent to DO E, !F to DO F, and !N to DO N.") 'E) (!F 'F) (!N 'N) (COND ((NULL (SETQ LINE (READLINE EDITRDTBL))) (ERROR!)) (T (CAR LINE] (SETQ COMS (LISPXFIND EDITHISTORY NIL 'INPUT)) (* ;; "If COMS is a LINE command, e.g. FIE FUM, DO COMS is the same as (COMS FIE FUM) If COMS is a list command, e.g. (FIE FUM), same as (COMS (FIE FUM))") [COND ((SETQ TEM (FMEMB HISTSTR0 COMS)) (COND ((CDR TEM) (SETQ COM C) (ERROR!)) (T (* ; "removes the last ' followed by the new atom or string.") (RETURN (DREVERSE (CONS (CONS LST2 LST1) MATCH] ((NEQ EDITQUIETFLG T) (PRIN1 '= T) (PRINT X T T))) (RETURN T]) (EDITQF [LAMBDA (PAT) (PROG (Q1) (COND ([AND (LISTP (SETQ Q1 (CAR L))) (SETQ Q1 (MEMB PAT (COND ((EQ (CAR Q1) CLISPTRANFLG) (CDDDR Q1)) (T (CDR Q1] (SETQ L (CONS (COND (UPFINDFLG Q1) (T (SETQ LASTAIL Q1) (CAR Q1))) L))) (T (EDIT4F PAT 'N]) (EDIT4F [LAMBDA (PAT C3 CHANGEFLG CHARFLG) (* ; "Edited 10-Nov-87 14:36 by jds") (* ;; "Searches the expression being edited, starting from current point and continuing in print order, until a position is found for which the current level list matches PAT. Then, if (CAR L) is atomic, effectively does an UP (unless UPFINDFLG=NIL) Thus F (SETQ X --) and F SETQ will produce the same result. --- If C3 is T, the search starts with the current exppession. If C3 is 'N', the search skips the current expression, although it does search inside of it.") (PROG (LL X TAIL (FF (CONS)) (TOPLVL (NULL C3)) N NEWFLG (PAT0 PAT)) [COND ((EQ [CAR (LISTP (CDR (LISTP PAT] '|..|) (RETURN (EDITCONT (CAR PAT) (CDDR PAT) C3] (SETQ PAT (EDITFPAT PAT T)) (* ; "Checks PAT for altmodes.") (SETQ LL L) (COND (CHANGEFLG (SETQ N (COND ((NUMBERP CHANGEFLG) CHANGEFLG) (T (* ; "Means change all occurrences.") -1))) (SETQ TOPLVL NIL) (SETQ C3 (EDITFPAT1 C3)) [AND CHARFLG (NLISTP PAT) (NLISTP C3) [SETQ PAT (CONS ' (CONS ' (NCONC1 (UNPACK PAT) '] (SETQ C3 (CONS ' (CONS ' (NCONC1 (UNPACK C3) '] (* ;; "If CHARFLG is T and neither pattern nor format contain alt-modes, supply them, i.e. user wants a character replacement operation. This option is used by the RC and RC1 commands, and by ESUBST.") ) [(EQ C3 'N) (SETQ N 1) [COND ((NLISTP (CAR L)) (GO LP1)) ((EQ (CAAR L) CLISPTRANFLG) (SETQ X (CADDAR L))) (T (SETQ X (CAAR L] (SETQ LL (CONS X L)) (COND ((AND (NLISTP X) UPFINDFLG) (* ;; "E.g. If at (COND --) and do F COND, cannot be allowed to match with this COND, as the subsequent UP would leave you right where you started. However, if UPFINDFLG is NIL, then it is ok to match with this COND.") (GO LP1] (T (SETQ N C3))) (COND ((NOT (NUMBERP N)) (SETQ N 1))) [COND ([COND [(TAILP (CAR LL) (CADR LL)) (AND (EQ (CAR (LISTP PAT)) '|...|) (EDIT4E (CDR PAT) (CAR LL] (T (EDIT4E PAT (CAR LL] (* ;; "This EDIT4E check is necessary because once search starts, EDIT4F1 is always looking down one level, i.e. at car's of list it is examining. Similarly, since once the search starts, tails are only matched against patterns beginning with ..., we do not call EDIT4E here on a TAIL unless the pattern also begins with ...") (COND [CHANGEFLG (COND ([NULL (AND (EQ PAT '&) (LISTP (CAR L] (* ;; "R can't work if you are already there, e.g. current expression is B and user says (R B C), or current expression is (CAR X) and user says (R (CAR X) (CDR Y)). The AND check is to enable commands like (r1 & $.) to work. In this case, it is assumed that & meant the first element in the current expression, not the current expression itself.") (PRIN1 "can't " T T) (ERROR!] ((ZEROP (SETQ N (SUB1 N))) (RETURN (SETQ L LL] (SETQ X (CAR LL)) LP (COND [(EDIT4F1 PAT X MAXLEVEL TAIL) (AND (CDR L) (SETQ UNFIND L)) (RETURN (CAR (SETQ L (NCONC (CAR FF) (COND ((EQ (CADR FF) (CAR LL)) (* ; "To avoid repetitions.") (CDR LL)) (T LL] (TOPLVL (GO ERROR)) ((EQ CHANGEFLG T) (* ;; "R command only affects current expression. However, R1 is equivalent to an F and then a replacement and so is allowed to search above the current expression.") (COND (NEWFLG (RETURN T))) (GO ERROR))) LP1 (SETQ X (CAR LL)) (* ;  "Ascend from this element and begin searching the next element in the next higher list.") (COND ((NULL (SETQ LL (CDR LL))) (COND (NEWFLG (* ;  "This was a replacement operation which has found a successful match.") (RETURN T))) (GO ERROR)) ([SETQ TAIL (COND ((AND (EQ X (CAR LASTAIL)) (TAILP LASTAIL (CAR LL))) (* ;; "This is sort of an open UP. It is necessary to handle the case where the current expression is atomic and the next higher expression contains two instances of it.") LASTAIL) (T (MEMB X (CAR LL] (SETQ X (CDR TAIL)) (GO LP))) (GO LP1) ERROR (SETQ COM PAT0) (ERROR!]) (EDIT4F1 [LAMBDA (PAT X LVL TAIL) (* wt%: " 5-APR-78 11:07") (* ;; "In most cases, EDIT4F1 treats X as a list, and matches PAT against elements of X. However, if TAIL is not NIL, EDIT4F1 will also look at X itself if (1) X is not a list (this covers the case where a list ends in an atom other than NIL), or (2) PAT begins with ... In both cases, X is EQ to CDR of TAIL, and TAIL is used if replacement is being carried out.") (PROG ((L L) TEM XX) (AND CHANGEFLG (NEQ X (CAR L)) (SETQ L (CONS X L))) (* ;; "So that if there are any replacements in CLISP expressions that have been translated, editsmash will know to remove the translations.") [COND ((AND (LISTP X) (NULL TAIL) (EQ (CAR X) CLISPTRANFLG)) (SETQ XX X) (SETQ TAIL (CDR X)) (SETQ X (CDDR X] LP (COND ((AND (LISTP PAT) (EQ (CAR PAT) '...)) (* ;; "This check is made before the NULL check because F (...) is acceptable and means find the first list ending in NIL.") (GO CHECK...)) ((NULL X)) ((AND LVL (NOT (IGREATERP LVL 0))) (* ; "NIL = infinity.") (PRIN1 '"maxlevel exceeded. " T)) ((LISTP X) (GO ELEMENT)) ((AND TAIL (SETQ TEM (EDIT4E PAT X CHANGEFLG))) (* ;  "Compares PAT with atomic tail of a list.") [COND (CHANGEFLG (SETQ X (EDIT4F2 TAIL TEM C3 T] (COND ((ZEROP (SETQ N (SUB1 N))) (GO SUCC))) (* ;; "Note that the current expression is left at the (atomic) tail to prevent accidents like (MOVE FOO TO ...) and FOO is CDR of (FIE . FOO)") )) (RETURN NIL) CHECK... (COND [(AND TAIL (SETQ TEM (EDIT4E (CDR PAT) X CHANGEFLG))) (* ;  "Note that at this point, X may still be atomic, as in F (... . B)") [COND (CHANGEFLG (SETQ X (EDIT4F2 TAIL TEM C3 T] (COND ((ZEROP (SETQ N (SUB1 N))) (GO SUCC)) (CHANGEFLG (* ;; "Don't want to go to LP1 because you don't want to search through new structure inserted by replacement.") (RETURN NIL)) ((NLISTP X) (RETURN NIL)) (T (GO LP1] ((NLISTP X) (RETURN NIL)) (T (* ;  "PAT is a ... pattern, so don't compare it with elements.") (GO DESCEND))) ELEMENT [COND ((SETQ TEM (EDIT4E PAT (CAR X) CHANGEFLG)) (COND (CHANGEFLG (EDIT4F2 X TEM C3))) (COND ((ZEROP (SETQ N (SUB1 N))) [COND ((OR (NULL UPFINDFLG) (LISTP (CAR X))) (* ;; "Instead of adding atom and then doing UP --- this check is made and atom not added if UPFINDFLG is T.") (SETQ LASTAIL X) (* ; "For use by UP.") (SETQ X (CAR X] (GO SUCC)) (CHANGEFLG (* ;; "Don't want to go to DESCEND because you don't want to search through new structure inserted by replacement operation.") (GO LP1] DESCEND (COND ((AND (NULL TOPLVL) (LISTP (CAR X)) (EDIT4F1 PAT (CAR X) (AND LVL (SUB1 LVL))) (ZEROP N)) (SETQ X (CAR X))) (T (GO LP1))) SUCC (AND XX (EQ X (CDDR XX)) (SETQ X XX)) (* ; "CLISP expression.") (COND ([AND FF (NOT (AND X (EQ X (CADR FF] (* ; "To eliminate repetitions.") (TCONC FF X))) (RETURN (OR FF T)) LP1 (SETQ TAIL X) (SETQ X (CDR X)) (AND LVL (SETQ LVL (SUB1 LVL))) (GO LP]) (EDIT4F2 [LAMBDA (NODE MATCH FORMAT CDRFLG) (* ; "Edited 10-Nov-87 14:37 by jds") (* ;; "Analagous to CONSTRUCT in FLIP, with EDITFPAT1 playing the role of FORMTRAN. Replaces CAR of NODE by FORMAT (CDR if CDRFLG=T). MATCH is the value returned by EDIT4E. If MATCH is a list of pointers and FORMAT begins with $, EDIT4F2 assembles a new atom or string, replacing those sequences not matched by alt-modes with elements from NEW. For example, user types (R $1 $2) then all terminal 1's will be changed to 2's.") (PROG ([X (COND (CDRFLG (CDR NODE)) (T (CAR NODE] FLG) (SETQ NEWFLG T) (* ;  "to let EDIT4F know that a successful match was found.") (SETQ FORMAT (EDIT4F3 FORMAT MATCH X)) (COND ((EQ EDITQUIETFLG T) (GO OUT)) ((NEQ MATCH T) (* ; "EDIT4E printed X.") ) (FLG (* ;; "MATCH was T, indicating no alt-modes, and therefore X was not printed by EDIT4E1. However, FLG being T means a format was used, and therefore X must be printed here. For example, (R FOO $1)") (PRIN2 X T T)) (T (GO OUT))) (PRIN1 "->" T) (PRINT FORMAT T T) OUT [COND (CDRFLG (EDITSMASH NODE (CAR NODE) FORMAT)) (T (EDITSMASH NODE FORMAT (CDR NODE] (EDITSMASH1 FORMAT) (RETURN FORMAT]) (EDIT4F3 [LAMBDA (FORMAT MATCH X) (* lmm "18-NOV-82 13:54") (PROG (LST) (COND [(LISTP FORMAT) (COND ([EQ (CAR FORMAT) (CONSTANT (CHARACTER (CHARCODE ESCAPE] (SETQ FLG T)) (T (RETURN (CONS (EDIT4F3 (CAR FORMAT) MATCH X) (EDIT4F3 (CDR FORMAT) MATCH X] (T (RETURN FORMAT))) LP [COND [(NLISTP (SETQ FORMAT (CDR FORMAT))) (RETURN (COND ((AND (EQ MATCH T) (NULL (CDR LST))) (CAR LST)) ((STRINGP X) (CONCATLIST LST)) (T (PACK LST] [[EQ (CAR FORMAT) (CONSTANT (CHARACTER (CHARCODE ESCAPE] (SETQ LST (NCONC LST (COND ((EQ MATCH T) (* ;  "Permits user to say (R FOO $1) meaning change all FOO's to FOO1's, etc.") (LIST X)) (T (PROG1 (LDIFF (CAAR MATCH) (CDAR MATCH)) (SETQ MATCH (CDR MATCH] (T (SETQ LST (NCONC1 LST (CAR FORMAT] (GO LP]) (EDITFPAT [LAMBDA (PAT FLG) (* wt%: "23-NOV-76 1 45") (* ;; "Done once at beginning of find operation. Replaces atoms ending in alt-modes with patterns recognized by EDIT4E. Analagous to PATTRAN in FLIP, with role of MATCH being played by EDIT4E1.") (PROG (TEM) (RETURN (COND [(LISTP PAT) (COND ((OR (EQ (CAR PAT) '==) (EQ (CAR PAT) ') (EQ (CAR PAT) ')) PAT) (T (CONS (EDITFPAT (CAR PAT)) (EDITFPAT (CDR PAT] ((OR (EQ PAT ') (NOT (STRPOS ' PAT))) PAT) [(STRPOS '"" PAT -2) (* ;  "Used to specify a search for a 'close' word using SKOR. See comment in EDIT4E.") (SETQ TEM (CHCON PAT)) (FRPLACD (NLEFT TEM 3)) (CONS ' (CONS (LENGTH TEM) (CONS (PROG ((ND 0) CHAR) [MAPC TEM (FUNCTION (LAMBDA (X) (COND ((EQ X CHAR) (SETQ ND (ADD1 ND))) (T (SETQ CHAR X] (RETURN ND)) TEM] (T (CONS ' (COND (FLG (DUNPACK PAT CHCONLST1)) (T (UNPACK PAT]) (EDITFPAT1 [LAMBDA (X) (* rmk%: " 6-JUN-82 15:15") (* ;; "Analgous to FORMTRAN in FLIP, with EDIT4F2 playing the role of CONSTRUCT. Used by EDIT4F once at the beginning of a find operation that also specifies replacement --- i.e. an R command. Converts an atom or string containing alt modes into a list of the character sequences, e.g. if X is $ABC$DEF$ then the value of EDITFPAT1 is ($ $ ABC $ DEF $) (The first $ is merely a flag.)") (COND ((OR (LITATOM X) (STRINGP X)) (COND [(STRPOS ' X) (CONS ' (PROG ((N 1) (NC (NCHARS X)) VAL) LP (SETQ VAL (CONS [COND ((EQ (NTHCHARCODE X N) (CHARCODE ESCAPE)) ') (T (SUBSTRING X N (SETQ N (SUB1 (OR (STRPOS "" X N) 0] VAL)) [COND ((OR (EQ N -1) (IGREATERP (SETQ N (ADD1 N)) NC)) (RETURN (DREVERSE VAL] (GO LP] (T X))) [(LISTP X) (CONS (EDITFPAT1 (CAR X)) (EDITFPAT1 (CDR X] (T X]) (EDITFINDP [LAMBDA (X PAT FLG) (* Allows the user to use the edit find operation as a predicate without being  inside the editor or doing any conses.) (PROG ((N 1) CHANGEFLG LASTAIL TOPLVL FF) (AND (NULL FLG) (SETQ PAT (EDITFPAT PAT T))) (RETURN (OR (EDIT4E PAT X) (EDIT4F1 PAT X MAXLEVEL]) (FEDITFINDP [LAMBDA (LST AT) (* lmm "26-JUL-83 20:55") (OR (EQ AT LST) (AND (LISTP LST) (OR (FEDITFINDP (CAR LST) AT) (FEDITFINDP (CDR LST) AT]) (EDITBELOW [LAMBDA (PLACE DEPTH) (* ; "See comment in EDITCOML") (PROG ((L0 (PROG ((L L) (LCFLG '_)) (EDITCOM PLACE) (RETURN L))) L1 N) (COND ((NULL DEPTH) (SETQ COM C) (SETQ DEPTH 1)) ((MINUSP (SETQ COM (EVAL DEPTH))) (* ;  "If anything goes wrong from hhe on, the error message shuld print the value of DEPTH.") (ERROR!)) (T (SETQ DEPTH COM))) (SETQ L1 (REVERSE L)) (SETQ L0 (FMEMB (CAR L0) L1)) LP [COND ((NULL L0) (ERROR!)) [(ZEROP DEPTH) (FRPLACD L0) (SETQ UNFIND L) (RETURN (SETQ L (DREVERSE L1] ((NOT (TAILP (CADR L0) (CAR L0))) (SETQ DEPTH (SUB1 DEPTH] (SETQ L0 (CDR L0)) (GO LP]) (EDITBF [LAMBDA (PAT N) (PROG ((LL L) X Y (FF (CONS))) (* ;; "Same as EDIT4F, except searches in reverse printorder. If N is T (or at top level) search includes current expression, otherwise starts with first expression that would be printed before the current expression.") (SETQ COM PAT) (SETQ PAT (EDITFPAT PAT)) (COND ((OR (NLISTP (CAR LL)) (AND (NULL N) (CDR LL))) (* ;  "Do not examine current expression.") (GO LP1))) LP [COND ((EDITBF1 PAT (CAR LL) MAXLEVEL Y) (SETQ UNFIND L) (RETURN (CAR (SETQ L (NCONC (CAR FF) (COND ((EQ (CAR LL) (CADR FF)) (CDR LL)) (T LL] LP1 (SETQ X (CAR LL)) (COND ((NULL (SETQ LL (CDR LL))) (ERROR!)) ([OR (SETQ Y (MEMB X (CAR LL))) (SETQ Y (TAILP X (CAR LL] (GO LP))) (GO LP1]) (EDITBF1 [LAMBDA (PAT X LVL TAIL) (PROG [Y XX (...PAT (AND (LISTP PAT) (EQ (CAR PAT) '...] (AND (LISTP X) (EQ (CAR X) CLISPTRANFLG) (SETQ XX X) (SETQ X (CDDR X))) LP [COND ((AND LVL (NOT (IGREATERP LVL 0))) (PRIN1 '"maxlevel exceeded. " T) (RETURN NIL)) ((EQ TAIL X) (RETURN (COND ((AND (NOT ...PAT) (EDIT4E PAT X)) (* ;; "Only compare with X after you have searched inside it, e.g. if backing up to (COND -- (COND --)) should find inner COND.") (TCONC FF X] (SETQ Y X) LP1 (COND ([NULL (OR (EQ (CDR Y) TAIL) (NLISTP (CDR Y] (* ;  "TAIL is where you were last time. Go until you find the tail before it.") (SETQ Y (CDR Y)) (GO LP1))) (SETQ TAIL Y) (* ;  "Y is a tail of X, TAIL is CDR of Y.") (COND ((AND PAT (CDR TAIL) (NLISTP (CDR TAIL)) (EDIT4E PAT (CDR TAIL))) (* ; "Atomic tail.") (SETQ TAIL (CDR TAIL))) ((AND ...PAT (EDIT4E (CDR PAT) (CDR TAIL))) (SETQ TAIL (CDR TAIL))) ([AND (LISTP (CAR TAIL)) (EDITBF1 PAT (CAR TAIL) (AND LVL (SUB1 LVL] (* ;  "Descend first before comparing with outer one.") (SETQ TAIL (CAR TAIL))) [(AND (NOT ...PAT) (EDIT4E PAT (CAR TAIL))) (COND ((OR (NULL UPFINDFLG) (LISTP (CAR TAIL))) (SETQ LASTAIL TAIL) (SETQ TAIL (CAR TAIL] (T (AND LVL (SETQ LVL (SUB1 LVL))) (GO LP))) (AND XX (EQ TAIL (CDDR XX)) (SETQ TAIL XX)) (COND ([NOT (AND TAIL (EQ TAIL (CADR FF] (TCONC FF TAIL))) (RETURN FF]) (EDITNTH [LAMBDA (X N) (* ;; "If N is non-numeric, EDITELT is called, so that one can give commands such as (BI COND SETQ) meaning do a BI starting at the element containing COND up to the one containing SETQ.") (PROG (TEM) [COND ((NLISTP X) (ERROR!)) ((EQ (CAR X) CLISPTRANFLG) (SETQ X (CDDR X] (RETURN (COND ((NOT (NUMBERP N)) (* ;; "Normally EDITELT returns the element of this level list containing N. However, if N is atomic and ends with an alt-mode, it will fail the first FMEMB, and EDITELT will return the tail of the list, so the second MEMB will fail. This is the reason for the TAILP.") (OR (MEMB N X) (MEMB (SETQ N (EDITELT N (LIST X))) X) (TAILP N X))) ((ZEROP N) (ERROR!)) ([SETQ TEM (COND ((MINUSP N) (NLEFT X (IMINUS N))) (T (NTH X N] TEM) (T (SETQ COM N) (ERROR!]) (BPNT [LAMBDA (X) (* wt%: "14-MAY-76 18 42") (PROG (Y N Z) [COND ((ZEROP (CAR X)) (SETQ Y (CAR L)) (SETQ Z (CADR L))) (T (SETQ Y (CAR (EDITNTH (CAR L) (CAR X] [COND ((NULL (CDR X)) (SETQ N 1)) ([NULL (NUMBERP (SETQ N (CADR X] (ERROR!)) ((MINUSP N) (SETQ N (ADD1 N))) (T (* ;  "Makes (P 0 N) have same effect as it did in old system.") (SETQ N (SUB1 N] (RETURN (BPNT0 Y T N (OR (CADDR X) 20) Z]) (BPNT0 [LAMBDA (X FILE CARLVL CDRLVL TAIL) (* wt%: 11-MAY-76 18 0) (COND ((NULL (NLSETQ (LVLPRINT X FILE CARLVL CDRLVL TAIL))) (SETQ COM NIL) (ERROR!]) (EDIT.RI [LAMBDA (M N X) (PROG (A B) (SETQ A (EDITNTH X M)) (SETQ B (EDITNTH (CAR A) N)) (COND ((OR (NULL A) (NULL B)) (ERROR!))) [PROG ((L (CONS (CAR A) L))) (* ;; "The only reason for this is so that EDITSMASH will also check (CAR a) for clisp translation. Note that EDIT.RI is the only command which lets you change something INSIDE of (CAR L) (The R command for xample is rebinding L as it goes down.)") (MAPC (CDR B) (FUNCTION EDITSMASH1)) (EDITSMASH1 (CAR A)) (EDITSMASH A (CAR A) (EDITNCONC (CDR B) (CDR A] (EDITSMASH B (CAR B]) (EDIT.RO [LAMBDA (N X) (SETQ X (EDITNTH X N)) (COND ((OR (NULL X) (NLISTP (CAR X))) (ERROR!))) (EDITSMASH (SETQ N (LAST (CAR X))) (CAR N) (CDR X)) (EDITSMASH X (CAR X)) (EDITSMASH1 (CAR X]) (EDIT.LI [LAMBDA (N X) (SETQ X (EDITNTH X N)) (COND ((NULL X) (ERROR!))) (EDITSMASH X (CONS (CAR X) (CDR X))) (EDITSMASH1 (CAR X)) (EDITSMASH1 (CAR X]) (EDIT.LO [LAMBDA (N X) (SETQ X (EDITNTH X N)) (COND ((OR (NULL X) (NLISTP (CAR X))) (ERROR!))) (EDITSMASH X (CAAR X) (CDAR X)) (MAPC X (FUNCTION EDITSMASH1]) (EDIT.BI [LAMBDA (M N X) (* lmm "26-JUL-83 20:51") (PROG (A B) (OR N (SETQ N M)) [SETQ B (CDR (SETQ A (EDITNTH X N] (SETQ X (EDITNTH X M)) (COND ((AND A (TAILP A X)) (EDITSMASH A (CAR A)) (EDITSMASH X (CONS (CAR X) (CDR X)) B) (EDITSMASH1 (CAR X))) (T (ERROR!]) (EDIT.BO [LAMBDA (N X) (SETQ X (EDITNTH X N)) (COND ((NLISTP (CAR X)) (ERROR!))) (EDITSMASH X (CAAR X) (EDITNCONC (CDAR X) (CDR X))) (EDITSMASH1 (CAR X]) ) (RPAQ? EDITRDTBL (COPYREADTABLE "OLD-INTERLISP-T")) (ADDTOVAR USERMACROS [ED NIL (E (ED (COND ((LISTP (%##)) (CAR (%##))) (T (%##]) (ADDTOVAR EDITCOMSA ED) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: EDITBLOCK TTY/EDITL EDITL0 EDITL1 UNDOEDITL EDITCOM EDITCOMA EDITCOML EDITMAC EDITCOMS EDIT!UNDO UNDOEDITCOM UNDOEDITCOM1 EDITCOM1 EDITSMASH EDITSMASH1 EDITNCONC EDITAPPEND EDIT1F EDIT2F EDITNTH BPNT BPNT0 EDIT.RI EDIT.RO EDIT.LI EDIT.LO EDIT.BI EDIT.BO EDITDEFAULT EDITDEFAULT1 %## EDUP EDIT* EDOR EDRPT EDLOC EDLOCL EDIT%: EDITMBD EDITXTR EDITELT EDITCONT EDITSW EDITMV EDITTO EDITBELOW EDITRAN EDITSAVE EDITSAVE1 EDITH (ENTRIES TTY/EDITL EDITL0 %## UNDOEDITL BPNT0 EDITCONT EDLOCL) (SPECVARS L ATM COM LCFLG %#1 %#2 %#3 UNDOLST UNDOLST1 LASTAIL MARKLST UNFIND LASTP1 LASTP2 COMS EDITCHANGES EDITHIST0 LISPXID USERHANDLE) (RETFNS EDITL0 EDITL1) (BLKAPPLYFNS EDIT%: EDITMBD EDITMV EDITXTR EDITSW) (BLKLIBRARY NTH LAST MEMB NLEFT) (NOLINKFNS PRINTDEF EDITRACEFN EDITUSERFN) (LOCALFREEVARS FINDFLAG EDITHIST UNDOLST1 COM L L0 COM0 UNDOLST EDITLFLG ATM MARKLST EDITHIST0 UNFIND TYPEIN LCFLG LASTP1 LASTP2 LASTAIL COPYFLG ORIGFLG COMS TOFLG C LVL EDITCHANGES EDITLISPFLG) (GLOBALVARS EDITCALLS P.A.STATS EDITUNDOSTATS EDITUNDOSAVES SPELLSTATS1 P.A.STATS EDITUSERFN EDITIME DONTSAVEHISTORYCOMS COMPACTHISTORYCOMS EDITEVALSTATS MAXLOOP EDITCOMSL EDITCOMSA DWIMFLG CLISPTRANFLG EDITOPS HISTORYCOMS REREADFLG HISTSTR3 EDITRDTBL EDITHISTORY HISTSTR0 LISPXHISTORY LISPXBUFS EDITRACEFN EDITMACROS USERMACROS CLISPARRAY CHANGESARRAY COMMENTFLG **COMMENT**FLG EDITSMASHUSERFN)) (BLOCK%: EDITFINDBLOCK EDIT4E EDIT4E1 EDITQF EDIT4F EDITFPAT EDITFPAT1 EDIT4F1 EDIT4F2 EDIT4F3 EDITSMASH EDITSMASH1 EDITFINDP EDITBF EDITBF1 ESUBST (ENTRIES EDIT4E EDIT4E1 EDITQF EDIT4F EDITFPAT EDITFINDP EDITBF ESUBST) (LOCALFREEVARS C3 CHANGEFLG N TOPLVL FF NEWFLG FLG) (GLOBALVARS EDITUNDOSAVES CHCONLST2 EDITQUIETFLG CHCONLST1 MAXLEVEL UPFINDFLG CLISPTRANFLG CHANGESARRAY CLISPARRAY EDITHISTORY) (SPECVARS ATM L COM UNFIND LASTAIL UNDOLST1 EDITCHANGES)) (BLOCK%: NIL EDITFA TTY/EDITE (SPECVARS EDITCHANGES EDITFN)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FILELST DWIMFLG DWIMWAIT DWIMLOADFNSFLG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA %##) (ADDTOVAR NLAML EDITF2) (ADDTOVAR LAMA ) ) (PUTPROPS EDIT COPYRIGHT ("Venue & Xerox Corporation" T 1983 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4509 135740 (TTY/EDITE 4519 . 7734) (TTY/EDITL 7736 . 11709) (%## 11711 . 12364) (EDIT* 12366 . 13415) (EDIT%: 13417 . 15366) (EDITDEFAULT 15368 . 24108) (EDITDEFAULT1 24110 . 24434) (EDITH 24436 . 28940) (EDITRAN 28942 . 31622) (EDITTO 31624 . 33011) (EDITXTR 33013 . 34469) (EDLOC 34471 . 35760) (EDLOCL 35762 . 35962) (EDOR 35964 . 36383) (EDRPT 36385 . 37186) (EDUP 37188 . 38340) (ESUBST 38342 . 39159) (ESUBST1 39161 . 39852) (EDITFERROR 39854 . 40940) (EDITFA 40942 . 41393) (EDITELT 41395 . 41588) (UNSAVEBLOCK? 41590 . 43233) (EDITF1 43235 . 43436) (EDITF2 43438 . 44326) (EDITL0 44328 . 45852) (EDITL1 45854 . 49526) (EDITL2 49528 . 49865) (UNDOEDITL 49867 . 50687) (EDITCOM 50689 . 51809) (EDITCOMA 51811 . 63419) (EDITCOML 63421 . 76579) (EDITCONT 76581 . 77735) (EDITMAC 77737 . 78126) (EDITMBD 78128 . 78997) (EDITMV 78999 . 82395) (EDITCOMS 82397 . 82959) (EDIT!UNDO 82961 . 83850) (UNDOEDITCOM 83852 . 85653) (UNDOEDITCOM1 85655 . 86601) (EDITCOM1 86603 . 88708) (EDITSAVE 88710 . 90266) (EDITSAVE1 90268 . 91712) (EDITSMASH 91714 . 93801) (EDITSMASH1 93803 . 95310) (EDITSW 95312 . 95672) (EDITNCONC 95674 . 95960) (EDITAPPEND 95962 . 96317) (EDIT1F 96319 . 97340) (EDIT2F 97342 . 101382) (EDIT4E 101384 . 104074) (EDIT4E1 104076 . 106973) (EDITQF 106975 . 107591) (EDIT4F 107593 . 113731) (EDIT4F1 113733 . 118404) (EDIT4F2 118406 . 120080) (EDIT4F3 120082 . 121632) ( EDITFPAT 121634 . 123721) (EDITFPAT1 123723 . 125393) (EDITFINDP 125395 . 125815) (FEDITFINDP 125817 . 126115) (EDITBELOW 126117 . 127170) (EDITBF 127172 . 128529) (EDITBF1 128531 . 131009) (EDITNTH 131011 . 132317) (BPNT 132319 . 133173) (BPNT0 133175 . 133386) (EDIT.RI 133388 . 134253) (EDIT.RO 134255 . 134535) (EDIT.LI 134537 . 134768) (EDIT.LO 134770 . 134995) (EDIT.BI 134997 . 135501) ( EDIT.BO 135503 . 135738))))) STOP \ No newline at end of file diff --git a/sources/EDITINTERFACE b/sources/EDITINTERFACE new file mode 100644 index 00000000..c747d773 --- /dev/null +++ b/sources/EDITINTERFACE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 7-Nov-91 18:15:13" |{PELE:MV:ENVOS}SOURCES>EDITINTERFACE.;6| 38377 changes to%: (FUNCTIONS ED) previous date%: " 5-Feb-91 11:44:57" |{PELE:MV:ENVOS}SOURCES>EDITINTERFACE.;5|) (* ; " Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT EDITINTERFACECOMS) (RPAQQ EDITINTERFACECOMS [ (* ;; "This is John Wozencraft's simplified edit interface, created December 1990.") (PROP (Definition-for-EDITL Definition-for-EDITE Definition-for-EDITDATE) TELETYPE DISPLAY) (GLOBALVARS *LAST-DF* *LAST-DV* *LAST-DC* *LAST-DP*) (INITVARS (*LAST-DF*) (*LAST-DV*) (*LAST-DC*) (*LAST-DP*)) (INITVARS (*EDITMODE* 'TELETYPE) (*DISPLAY-EDITOR*)) (* ;; "init *EDITMODE* to TELETYPE, since that's the only editor we know is loaded. other editors should set *DISPLAY-EDITOR* and call EDITMODE as appropriate.") (VARS DUMMY-EDIT-FUNCTION-BODY) (VARIABLES *ED-OFFERS-PROPERTY-LIST* XCL::ED-LAST-INFO) (FUNCTIONS ED INSTALL-PROTOTYPE-DEFN) (FNS EDITDEF.FNS EDITF EDITFB EDITFNS EDITLOADFNS? EDITMODE EDITP EDITV DC DF DP DV EDITPROP EF EP EV EDITE EDITL) [COMS (* ;; "Time stamp on functions when edited") (* ;; "User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER )) The date fixup is enabled by the variable INITIALS. The function SETINITIALS sets INITIALS from INITIALSLIST and USERNAME at load time, and after a sysin.") (FNS NEW/EDITDATE FIXEDITDATE EDITDATE? EDITDATE SETINITIALS) (INITVARS (INITIALS) (INITIALSLST) (DEFAULTINITIALS T)) (VARIABLES *REPLACE-OLD-EDIT-DATES*) (P (MOVD? 'EDITDATE 'TTY/EDITDATE] [INITVARS (COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS OPTIMIZERS] (PROP FILETYPE EDITINTERFACE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA EV EP EF DV DP DF DC EDITV EDITP EDITFNS EDITF) (NLAML) (LAMA]) (* ;; "This is John Wozencraft's simplified edit interface, created December 1990.") (PUTPROPS TELETYPE Definition-for-EDITL TTY/EDITL) (PUTPROPS DISPLAY Definition-for-EDITL TTY/EDITL) (PUTPROPS TELETYPE Definition-for-EDITE TTY/EDITE) (PUTPROPS DISPLAY Definition-for-EDITE TTY/EDITE) (PUTPROPS TELETYPE Definition-for-EDITDATE TTY/EDITDATE) (PUTPROPS DISPLAY Definition-for-EDITDATE TTY/EDITDATE) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *LAST-DF* *LAST-DV* *LAST-DC* *LAST-DP*) ) (RPAQ? *LAST-DF* ) (RPAQ? *LAST-DV* ) (RPAQ? *LAST-DC* ) (RPAQ? *LAST-DP* ) (RPAQ? *EDITMODE* 'TELETYPE) (RPAQ? *DISPLAY-EDITOR* ) (* ;; "init *EDITMODE* to TELETYPE, since that's the only editor we know is loaded. other editors should set *DISPLAY-EDITOR* and call EDITMODE as appropriate." ) (RPAQQ DUMMY-EDIT-FUNCTION-BODY [LAMBDA (ARGS ...) BODY]) (CL:DEFVAR *ED-OFFERS-PROPERTY-LIST* T "Controls whether ED offers property list as an editable aspect") (DEFGLOBALVAR XCL::ED-LAST-INFO NIL "used in ED to stash last call info so (ED NIL) will restart last edit") (CL:DEFUN ED (CL::NAME CL::OPTIONS) (* ; "Edited 5-Jul-88 16:03 by woz") (* ;;; "Standard Common Lisp editor entry. CLtL say's ED does something reasonable when passed a pathname. We coerce name into something that might be the name of something with an IL:FILES definition, & try to edit that. Then save call info in ED-LAST-INFO, so (ED) will start last edit over again.") (CL:UNLESS (CL:LISTP CL::OPTIONS) (CL:SETQ CL::OPTIONS (LIST CL::OPTIONS))) (CL:WHEN (CL:PATHNAMEP CL::NAME) (CL:SETQ CL::NAME (NAMEFIELD (CL:STRING-UPCASE (CL:NAMESTRING CL::NAME)) T)) (CL:PUSHNEW 'FILES CL::OPTIONS)) [COND (CL::NAME (CL:SETQ XCL::ED-LAST-INFO (CONS CL::NAME CL::OPTIONS))) (T (CL:WHEN (NULL XCL::ED-LAST-INFO) (CL:FORMAT T "Sorry, there is no previous edit to restart.") (CL:RETURN-FROM ED NIL)) (CL:SETQ CL::NAME (CAR XCL::ED-LAST-INFO)) (CL:SETQ CL::OPTIONS (CL:APPEND (CDR XCL::ED-LAST-INFO) CL::OPTIONS] (LET* ((CL::FROM-DISPLAY (OR (EQ CL::OPTIONS T) (CL:MEMBER :DISPLAY CL::OPTIONS) (CL:MEMBER 'DISPLAY CL::OPTIONS))) (CL::GIVEN-TYPES (for X inside CL::OPTIONS when (NEQ X T) bind TYPE when (CL:SETQ TYPE (GETFILEPKGTYPE X 'TYPES T CL::NAME)) collect TYPE)) [CL::TYPES-WITH-DEFNS (TYPESOF CL::NAME CL::GIVEN-TYPES NIL (CL:IF (OR (CL:MEMBER :CURRENT CL::OPTIONS) (CL:MEMBER 'CURRENT CL::OPTIONS)) 'CURRENT '?) #'(LAMBDA (X) (NEQ (GET X 'EDITDEF) 'NILL] (CL::POSSIBLE-TYPES (COND ([AND (NULL CL::GIVEN-TYPES) (CL:SYMBOLP CL::NAME) (NOT (NULL *ED-OFFERS-PROPERTY-LIST*)) (find X on (GETPROPLIST CL::NAME) by (CDDR X) suchthat (NULL (GET (CAR X) 'PROPTYPE] (* ;; "if we're supposed to offer PROPERTY-LIST as an edit type, and this name has a property list with other than system properties on it, then add IL:PROPERTY-LIST to the possible types.") (CONS 'PROPERTY-LIST CL::TYPES-WITH-DEFNS)) (T CL::TYPES-WITH-DEFNS))) (TYPE)) (CL:WHEN (CL:MEMBER 'PROPERTY-LIST CL::OPTIONS) (* ;;  "this will allow PROPERTY-LIST to be specified as a fake filepkg type by the user (caller)") (CL:SETQ CL::POSSIBLE-TYPES '(PROPERTY-LIST))) [CL:SETQ TYPE (if (CL:MEMBER :NEW CL::OPTIONS) then (* ;; "if :NEW then install a blank definition first") (OR (INSTALL-PROTOTYPE-DEFN CL::NAME (OR CL::TYPES-WITH-DEFNS CL::GIVEN-TYPES) :NEW) (CL:RETURN-FROM ED NIL)) elseif (CDR CL::POSSIBLE-TYPES) then (* ;; "Many types were found/given. Ask the user which to use.") (if CL::FROM-DISPLAY then (OR (MENU (create MENU ITEMS _ CL::POSSIBLE-TYPES TITLE _ (CL:FORMAT NIL "Edit which definition of ~S ?" CL::NAME))) (CL:RETURN-FROM ED NIL)) else (ASKUSER NIL (CAR CL::POSSIBLE-TYPES) (CL:FORMAT NIL "Edit which ~A definition of ~S ? " CL::POSSIBLE-TYPES CL::NAME) CL::POSSIBLE-TYPES)) elseif (NOT (NULL CL::POSSIBLE-TYPES)) then (* ;; "Exactly one type was found.") (if CL::FROM-DISPLAY then (* ; "prepare the prompt window") (TERPRI PROMPTWINDOW)) (CL:FORMAT (if CL::FROM-DISPLAY then PROMPTWINDOW else T) "Editing ~A ~A ~S.~%%" (CAR CL::POSSIBLE-TYPES) (CL:IF (EQ (CAR CL::POSSIBLE-TYPES) 'PROPERTY-LIST) "of" "definition of") CL::NAME) (CAR CL::POSSIBLE-TYPES) else (* ;;  "No types were found. Use the DefDefiner prototyping machinery.") (OR (INSTALL-PROTOTYPE-DEFN CL::NAME CL::GIVEN-TYPES) (CL:RETURN-FROM ED NIL] (CL:IF (EQ TYPE 'PROPERTY-LIST) (EDITE (GETPROPLIST CL::NAME) NIL CL::NAME 'PROPLST NIL CL::OPTIONS) (EDITDEF CL::NAME TYPE NIL NIL CL::OPTIONS)) (CL:RETURN-FROM ED CL::NAME))) (CL:DEFUN INSTALL-PROTOTYPE-DEFN (NAME &REST ARGS) (* ;;; "Explain to the user that the given name has no definitions (of the given type, if any) and give them the chance to pick a new, dummy definition to install under that name. Return the file-manager type of the definition installed. If TYPES were supplied, the one returned should be one of them. If no dummy was selected, return NIL. If the third arg in :NEW then don't bother with the %"no defn found%" message, cause the user intends to intall anew.") [CL:FLET [(MAKE-AND-INSTALL (TYPE DEFINER) (LET ((DFNFLG 'PROP)) (DECLARE (CL:SPECIAL DFNFLG)) (EVAL (XCL::MAKE-PROTOTYPE NAME TYPE DEFINER] (LET* ((DEFINER-HELP-STRING (CL:FORMAT NIL "Installs a definition for ~S using this definer." NAME)) [REQUESTED-TYPES (AND (LISTP ARGS) (MKLIST (CAR ARGS] (NEW-DEFN-FLG (AND (LISTP ARGS) (EQ (CADR ARGS) :NEW))) [TYPES-WITH-PROTOTYPES (IF (NULL REQUESTED-TYPES) THEN (XCL::PROTOTYPE-DEFN-TYPES) ELSE (INTERSECTION REQUESTED-TYPES (XCL::PROTOTYPE-DEFN-TYPES] PROTOTYPE-TYPE) (IF (AND NEW-DEFN-FLG TYPES-WITH-PROTOTYPES) THEN (IF (CDR TYPES-WITH-PROTOTYPES) THEN (CL:FORMAT T "Installing new definition for ~S~%%" NAME) ELSE (CL:FORMAT T "Installing new ~S definition for ~S~%%" (CAR TYPES-WITH-PROTOTYPES ) NAME)) ELSEIF (NULL REQUESTED-TYPES) THEN (CL:FORMAT T "~S has no definitions.~%%" NAME) ELSEIF (NULL (CDR REQUESTED-TYPES)) THEN (CL:FORMAT T "~S has no ~A definition.~%%" NAME (CAR REQUESTED-TYPES)) ELSE (CL:FORMAT T "~S has no definition of any of these types:~%% ~A~%%" NAME REQUESTED-TYPES)) [IF (NULL TYPES-WITH-PROTOTYPES) THEN (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL) ELSEIF (NULL (CDR TYPES-WITH-PROTOTYPES)) THEN (SETQ PROTOTYPE-TYPE (CAR TYPES-WITH-PROTOTYPES)) ELSE (CL:FORMAT T "Select a type of dummy definition to install.~%%") (LET* ([MENU (CREATE MENU TITLE _ "Select a type for a dummy defn:" ITEMS _ (APPEND [FOR TYPE IN TYPES-WITH-PROTOTYPES COLLECT `(,TYPE '(:TYPE ,TYPE) "Displays a menu of definers for this type." (SUBITEMS ,@(FOR DEFINER IN ( XCL::PROTOTYPE-DEFINERS-FOR-TYPE TYPE) COLLECT `(,DEFINER '(:DEFINER ,TYPE ,DEFINER) ,DEFINER-HELP-STRING] (LIST '("Don't make a dummy defn" NIL] (RESULT (MENU MENU))) (CL:ECASE (CL:FIRST RESULT) (:TYPE (SETQ PROTOTYPE-TYPE (CL:SECOND RESULT))) (:DEFINER (MAKE-AND-INSTALL (CL:SECOND RESULT) (CL:THIRD RESULT)) (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN (CL:SECOND RESULT))) ((NIL) (CL:RETURN-FROM INSTALL-PROTOTYPE-DEFN NIL)))] (CL:FORMAT T "Select a definer to use for a dummy definition.~%%") (LET [(DEFINER (MENU (CREATE MENU TITLE _ "Select a definer for a dummy defn:" ITEMS _ (APPEND (XCL::PROTOTYPE-DEFINERS-FOR-TYPE PROTOTYPE-TYPE) (LIST '("Don't make a dummy defn" NIL] (IF DEFINER THEN (MAKE-AND-INSTALL PROTOTYPE-TYPE DEFINER) PROTOTYPE-TYPE ELSE NIL]) (DEFINEQ (EDITDEF.FNS [LAMBDA (NAME EDITCOMS OPTIONS) (* ; "Edited 20-Nov-87 14:25 by woz") (PROG (DEF) LP (COND ((EXPRP (SETQ DEF (OR (GET NAME 'ADVISED) (GET NAME 'BROKEN) NAME))) (EDITE (if (LITATOM DEF) then (GETD DEF) else DEF) EDITCOMS NAME 'FNS NIL OPTIONS) (RETURN NAME)) ([EXPRP (SETQ DEF (GETPROP NAME 'EXPR] (* ;; "woz: don't use edit type PROP anymore. Let putdef for fns worry about where the definition goes.") (EDITE DEF EDITCOMS NAME 'FNS NIL OPTIONS) (RETURN NAME)) ((EDITFB NAME) (GO LP)) (T (* ;; "Used to call EDITFERROR to check for MACROS definition or install dummy FNS defintion. FNS can no longer be coerced to MACROS, and the new prototype stuff handles the other case. So if we're here, it's because EDITFB failed to find the definition, and thus NAME is not editable.") (CL:FORMAT *ERROR-OUTPUT* "Could not find fns definition for ~a." NAME) (ERROR "Could not find fns definition for " NAME T]) (EDITF [NLAMBDA EDITFX (* ; "Edited 11-Jun-90 15:44 by jds") (SETQ EDITFX (NLAMBDA.ARGS EDITFX)) (LET ((FNTYPE 'FNS)) (EDITDEF (if EDITFX then (COND ((HASDEF (CAR EDITFX) 'FUNCTIONS '? EDITFX) (SETQ FNTYPE 'FUNCTIONS) (CAR EDITFX)) ((HASDEF (CAR EDITFX) 'FNS '? EDITFX) (CAR EDITFX))) else (PROGN (PRIN1 "Editing " T) (PRINT LASTWORD T))) FNTYPE NIL (CDR EDITFX]) (EDITFB [LAMBDA (FN) (* ; "Edited 27-Jan-87 14:50 by Pavel") (PROG (FL TEM) (COND ((SETQ FL (EDITLOADFNS? FN (AND (NULL EDITLOADFNSFLG) '"not editable, do you want to load it PROP from") (NULL EDITLOADFNSFLG))) (LOADFNS FN FL 'PROP)) ((AND (EQ (NARGS 'WHEREIS) 4) (SETQ FL (EDITLOADFNS? FN '"not editable; do you want to LOADFROM PROP the file" T T))) (LOADFROM FL (LIST FN) 'PROP)) (T (RETURN))) (COND ((GETPROP FN 'EXPR) (RETURN T)) (T (PRINTOUT T "** Not found on " FL T]) (EDITFNS [NLAMBDA X (* DD%: " 7-Oct-81 20:56") (* ;; "FNS is a list (or name of a list) of functions to be edited; (CDR X) are the operations to be performed.") (SETQ X (MKLIST X)) (MAPC [COND ((LISTP (CAR X)) (STKEVAL 'EDITFNS (CAR X) NIL 'INTERNAL)) (T (* ;  "If (CAR X) is name of a file, do editfns on its functions.") (OR (LISTP (EVALV (CAR X) 'EDITFNS)) (AND (GETPROP (OR (AND DWIMFLG (MISSPELLED? (CAR X) 70 FILELST NIL X)) (CAR X)) 'FILE) (FILEFNSLST (CAR X))) (STKEVAL 'EDITFNS (CAR X) 'INTERNAL] (FUNCTION (LAMBDA (Y) (ERSETQ (APPLY 'EDITF (CONS (PROG1 (PRIN2 Y T T) (SPACES 1 T)) (CDR X]) (EDITLOADFNS? [LAMBDA (FN STR ASKFLG FILES) (* lmm "20-Nov-86 21:23") (* ;; "Value is name of file from which function or functions can be loaded. If STR is non-NIL, user is asked to approve, and STR used in the message. EDITLOADFNS? is also used by prettyprint") (AND FN FILEPKGFLG (PROG ((LST (WHEREIS FN 'FNS FILES)) FILE DATES FD) (OR (COND ((EQ FILES T) (* ;; "if FILES = T, means consult data base. if user has removed a function from one of those files, as evidenced by the fact that editloafns? was called with files=T, then dont offer that file.") (SETQ LST (LDIFFERENCE LST FILELST))) (T LST)) (RETURN)) [SETQ FILE (COND ((CDR LST) (PRIN2 FN T) (MAPRINT LST T " is contained on " " " " and ") (OR (ASKUSER NIL NIL "indicate which file to use: " (MAKEKEYLST LST) T) (RETURN))) (T (CAR LST] [SETQ DATES (LISTP (GETPROP FILE 'FILEDATES] (* ;;  "only look at file in FILEDATES if the file has been LOADed or LOADFROMd") (SETQ FILE (OR (AND DATES (FMEMB (CDAR (GETPROP FILE 'FILE)) '(LOADFNS T)) (INFILEP (CDAR DATES))) (FINDFILE FILE T) (RETURN))) [COND ((AND DATES (NEQ FILE (CDAR DATES))) (* ;  "found a different file than in FILEDATES") (COND ((EQUAL (CAAR DATES) (SETQ FD (FILEDATE FILE))) (* ;  "found a goood version of file on a different name. smash name") (/RPLACD (CAR DATES) FILE)) (T (CL:FORMAT *TERMINAL-IO* "*** Note: loading definition from ~A dated ~A~&while file ~A dated ~A is the version currently loaded." FILE FD (CDAR DATES) (CAAR DATES] (COND ((STREQUAL STR "")) ((NULL ASKFLG) (if STR then (EXEC-FORMAT "~&~A~A" STR FILE) else (EXEC-FORMAT "~&Loading definition of ~S from ~A." FN FILE))) ((NEQ (ASKUSER DWIMWAIT 'Y (LIST FN STR FILE) NIL T) 'Y) (RETURN))) (RETURN FILE]) (EDITMODE [LAMBDA (NEWMODE) (* ;;; "WOZ- 1/9/91. Took (setq newmode (il:u-case newmode)) out because it puts newmode in the IL: package. This doesn't work with my new definition of what an editor is, ie a symbol whos function cell can be applied to (structure props options). The rest of the old code , eg Definition-for-EDITL remains until DEDIT goes away and the TTY/EDITOR becomes a programmatic structure editor only.") (PROG1 (if (NOT (DISPLAYSTREAMP (TTYDISPLAYSTREAM))) then (* ;; "not a display, always say teletype. This is mainly for chatserver") 'TELETYPE else (SELECTQ *EDITMODE* (DISPLAY *DISPLAY-EDITOR*) *EDITMODE*)) (* ;; "return old value, and, if new value given, set it.") (CL:WHEN NEWMODE (LET (new.display.editor) (if (EQ NEWMODE 'STANDARD) then (* ; "Obselete terminology") (SETQ NEWMODE 'TELETYPE) elseif (AND (EQ NEWMODE 'DISPLAY) *DISPLAY-EDITOR*) then (SETQ NEWMODE *DISPLAY-EDITOR*) elseif (NEQ NEWMODE 'TELETYPE) then (* ;  "if we've been called with the name of a display editor, make it the default display editor") (SETQ new.display.editor NEWMODE)) (if (NOT (GETPROP NEWMODE 'Definition-for-EDITL)) then (CL:CERROR "Ignore call to EDITMODE" "~S is unrecognized argument to EDITMODE" NEWMODE) else (if new.display.editor then (SETQ *DISPLAY-EDITOR* new.display.editor)) (SETQ *EDITMODE* NEWMODE)))))]) (EDITP [NLAMBDA EDITPX (* lmm "10-Jun-85 17:12") (SETQ EDITPX (NLAMBDA.ARGS EDITPX)) (PROG ((ATM (CAR EDITPX))) [COND ((AND DWIMFLG (NLISTP (GETPROPLIST ATM))) (SETQ ATM (OR (MISSPELLED? ATM 75 USERWORDS NIL NIL (FUNCTION GETPROPLIST)) ATM] (EDITE (GETPROPLIST ATM) (CDR EDITPX) ATM 'PROPLST) (RETURN ATM]) (EDITV [NLAMBDA EDITVX (* lmm " 2-Sep-85 13:17") (SETQ EDITVX (NLAMBDA.ARGS EDITVX)) (LET* [[VAR (OR (CAR EDITVX) (PROGN (PRIN1 "= " T) (PRINT LASTWORD T] (FRAME (AND VAR (STKSCAN VAR] (if FRAME then (EDITE (ENVEVAL VAR FRAME NIL T) (CDR EDITVX) VAR) elseif (SETQ VAR (HASDEF VAR 'VARS 'CURRENT T)) then (EDITDEF VAR 'VARS 'CURRENT (CDR EDITVX)) else (ERROR VAR "not editable"]) (DC [NLAMBDA FILE (* ; "Edited 18-Mar-87 16:03 by woz") (* ; "Edits COMS of file FILE") (LET ((*EDITMODE* 'DISPLAY) (ARGS (NLAMBDA.ARGS FILE))) (* ;; "(APPLY (QUOTE EDITV) (FILECOMS (OR (HASDEF (CAR (NLAMBDA.ARGS FILE)) (QUOTE FILE) NIL T) (ERROR FILE 'is not a loaded file' T))))") (if (LISTP ARGS) then (SETQ *LAST-DC* (CAR ARGS))) (if *LAST-DC* then (ED *LAST-DC* '(FILES :DONTWAIT)) else (ERROR "No saved file name." "Edit aborted."]) (DF [NLAMBDA FN (* ; "Edited 18-Mar-87 17:00 by woz") (LET ((*EDITMODE* 'DISPLAY) (ARGS (NLAMBDA.ARGS FN))) (* ;; "(APPLY (COND ((EQ (CADR (LISTP FN)) (QUOTE NEW)) (QUOTE EDITFERROR)) (T (QUOTE EDITF))) (NLAMBDA.ARGS FN))") (* ;; "DF used to look for MACROS under EDITFERROR. Decided this is bad, because could get the macro without noticing the fns if the file was sysloaded. Now just look for FUNCTIONS and FNS.") (if (LISTP ARGS) then (SETQ *LAST-DF* (CAR ARGS))) (if *LAST-DF* then [ED *LAST-DF* (if (AND (CDR ARGS) (EQ (CADR ARGS) 'NEW)) then '(FUNCTIONS FNS :DONTWAIT :NEW) else '(FUNCTIONS FNS :DONTWAIT] else (ERROR "No saved function name." "Edit aborted."]) (DP [NLAMBDA ATOM (* ; "Edited 18-Mar-87 16:16 by woz") (LET ((*EDITMODE* 'DISPLAY) (ARGS (NLAMBDA.ARGS ATOM))) (* ;  "(APPLY (QUOTE EDITPROP) (NLAMBDA.ARGS ATOM))") [if (LISTP ARGS) then (if (CDR ARGS) then (* ;  "specific PROP to edit. remember (ATOM PROP)") (SETQ *LAST-DP* ARGS) else (* ; "edit whole plist. remember ATOM") (SETQ *LAST-DP* (CAR ARGS] (if *LAST-DP* then [ED *LAST-DP* (if (LISTP *LAST-DP*) then '(PROPS :DONTWAIT) else '(PROPERTY-LIST :DONTWAIT] else (ERROR "No saved symbol name." "Edit aborted."]) (DV [NLAMBDA VAR (* ; "Edited 18-Mar-87 12:43 by woz") (LET ((*EDITMODE* 'DISPLAY) (ARGS (NLAMBDA.ARGS VAR))) (* ;  "(APPLY (QUOTE EDITV) (NLAMBDA.ARGS VAR))") (if (LISTP ARGS) then (SETQ *LAST-DV* (CAR ARGS))) (if *LAST-DV* then (ED *LAST-DV* '(VARIABLES VARS :DONTWAIT)) else (ERROR "No saved variable name." "Edit aborted."]) (EDITPROP [LAMBDA (NAME PROP) (* bas%: "21-MAR-83 20:29") (COND (PROP (EDITDEF (LIST NAME PROP) 'PROPS)) (T (APPLY 'EDITP NAME]) (EF [NLAMBDA FN (* jow "16-Oct-86 11:41") (LET ((*EDITMODE* 'TELETYPE)) (APPLY (COND ((EQ (CADR (LISTP FN)) 'NEW) 'EDITFERROR) (T 'EDITF)) (NLAMBDA.ARGS FN]) (EP [NLAMBDA ATOM (* jow "16-Oct-86 11:42") (LET ((*EDITMODE* 'TELETYPE)) (APPLY 'EDITPROP (NLAMBDA.ARGS ATOM]) (EV [NLAMBDA VAR (* jow "16-Oct-86 11:42") (LET ((*EDITMODE* 'TELETYPE)) (APPLY 'EDITV (NLAMBDA.ARGS VAR]) (EDITE [LAMBDA (EXPR COMS ATM TYPE IFCHANGEDFN OPTIONS) (* ; "Edited 17-Mar-87 11:59 by woz") (if (AND EXPR (NLISTP EXPR) (SELECTQ (EDITMODE) (TELETYPE (* ; "don't inspect") NIL) (SEDIT (NOT (STRINGP EXPR)) (* ;  "Sedit can't handle strings, it returns the old string") T) T)) then (* ;; "this used to be done by redefining EDITE on the file INSPECT. Its not clear that it is still a good idea") (INSPECT EXPR) else (CL:FUNCALL (GET (EDITMODE) 'Definition-for-EDITE) EXPR COMS ATM TYPE IFCHANGEDFN OPTIONS]) (EDITL [LAMBDA (L COMS ATM MESS EDITCHANGES) (* lmm "12-Nov-86 15:18") (CL:FUNCALL (GET (EDITMODE) 'Definition-for-EDITL) L COMS ATM MESS EDITCHANGES]) ) (* ;; "Time stamp on functions when edited") (* ;; "User enables this by an (ADDTOVAR INITIALSLIST (USERNAME )) in his INIT.LISP. E.g. (ADDTOVAR INITIALSLIST (MASINTER )) The date fixup is enabled by the variable INITIALS. The function SETINITIALS sets INITIALS from INITIALSLIST and USERNAME at load time, and after a sysin." ) (DEFINEQ (NEW/EDITDATE [LAMBDA (OLDATE INITLS) (* lmm "12-Nov-86 15:18") (CL:FUNCALL (GET (EDITMODE) 'Definition-for-EDITDATE) OLDATE INITLS]) (FIXEDITDATE [LAMBDA (EXPR) (* NOBIND "18-JUL-78 21:11") (* ;  "Inserts or replaces previous edit date") (AND INITIALS (LISTP EXPR) (FMEMB (CAR EXPR) LAMBDASPLST) (LISTP (CDR EXPR)) (PROG ((E (CDDR EXPR))) 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 ((AND (LISTP (CDR E)) (EDITDATE? (CAR E))) (/RPLACA E (EDITDATE (CAR E) INITIALS))) (T (/ATTACH (EDITDATE NIL INITIALS) E))) (RETURN EXPR]) (EDITDATE? (LAMBDA (COMMENT) (* ; "Edited 29-Oct-87 16:41 by drc:") (* ;;; "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. We settle for the conservative form of (* initials date-string), since only truly ancient edit dates look any different from that") (DECLARE (LOCALVARS . T)) (AND *REPLACE-OLD-EDIT-DATES* (LISTP COMMENT) (EQMEMB (CAR COMMENT) COMMENTFLG) (LISTP (CDR COMMENT)) (LISTP (CDDR COMMENT)) (NULL (CDDDR COMMENT)) (STRINGP (CADDR COMMENT)) (LET ((INITIALS? (CADR COMMENT))) (AND (NOT (EQMEMB INITIALS? COMMENTFLG)) (OR (EQ INITIALS? INITIALS) (if (LITATOM INITIALS?) then (if (for I from 1 to (NCHARS INITIALS?) always (EQ (NTHCHARCODE INITIALS? I) (CHARCODE ";"))) then (* ; " an sedit comment") (AND (EQ INITIALS? (QUOTE ;)) (STRPOS "Edited " (CADDR COMMENT) 1 NIL T) (>= (CL:LENGTH (CADDR COMMENT)) (CL:LENGTH "Edited 01-jan-86 00:00 by "))) else (* ; "an old-style comment") T) elseif (STRINGP INITIALS?) then (* ; "make sure it's not a string-body comment.") (ILESSP (NCHARS INITIALS?) 12))))))) ) (EDITDATE [LAMBDA (OLDATE INITLS) (* ; "Edited 20-Nov-86 23:23 by Masinter") (* ;;  "Generates a new date from an old one") (LET [(NEWDATE (LIST '; (CONCAT "Edited " (DATE (DATEFORMAT NO.SECONDS)) " by " INITLS] (COND ((EQMEMB (CAR (LISTP OLDATE)) COMMENTFLG) (* ;; "Destructively alter old date. This is for benefit of DEDIT being able to find the old form to reprint") (/RPLACD OLDATE NEWDATE)) (T (CONS (OR (CAR (LISTP COMMENTFLG)) COMMENTFLG) NEWDATE]) (SETINITIALS [LAMBDA NIL (* ; "Edited 20-Nov-86 23:22 by MASINTER") (* ;;; "Sets the default initials to appear in edited code, and sets the user's first name. Called following GREET via POSTGREETFORMS.") (LET ((DFNFLG T) (FILEPKGFLG NIL) (USER (USERNAME NIL NIL T)) POS TRIPLE) (SETQ POS (STRPOS "." USER)) (* ;  "Find out if there's a period in the name, which would indicate that there's a registry on the end.") [COND ((AND POS DEFAULTREGISTRY (STRING-EQUAL (SUBSTRING USER (ADD1 POS) -1) DEFAULTREGISTRY)) (* ;; "If there's a registry on the end, and it's the default registry, remove the registry. We assume that DEFAULTREGISTRY has been set by the time that GREET has finished.") (SETQ USER (SUBSTRING USER 1 (SUB1 POS] (COND [(find old TRIPLE in INITIALSLST suchthat (STRING-EQUAL USER (CAR TRIPLE))) (* ;  "OK we found his last name on the INITIALSLST. Now break out his initials and first name") (COND ((NLISTP (CDR TRIPLE)) (* ; "old style") (SAVESET 'INITIALS (CDR TRIPLE))) (T (SAVESET 'FIRSTNAME (CADR TRIPLE)) (SAVESET 'INITIALS (CADDR TRIPLE] (T (SAVESET 'INITIALS (COND ((NOT DEFAULTINITIALS) NIL) ((NEQ DEFAULTINITIALS T) DEFAULTINITIALS) (T USER]) ) (RPAQ? INITIALS ) (RPAQ? INITIALSLST ) (RPAQ? DEFAULTINITIALS T) (CL:DEFVAR *REPLACE-OLD-EDIT-DATES* T "NIL or T; if NIL, old edit dates will not be replaced") (MOVD? 'EDITDATE 'TTY/EDITDATE) (RPAQ? COMMON-SOURCE-MANAGER-TYPES '(FUNCTIONS VARIABLES STRUCTURES TYPES SETFS OPTIMIZERS)) (PUTPROPS EDITINTERFACE FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA EV EP EF DV DP DF DC EDITV EDITP EDITFNS EDITF) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS EDITINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14507 31290 (EDITDEF.FNS 14517 . 15853) (EDITF 15855 . 16735) (EDITFB 16737 . 17585) ( EDITFNS 17587 . 18907) (EDITLOADFNS? 18909 . 22709) (EDITMODE 22711 . 24721) (EDITP 24723 . 25234) ( EDITV 25236 . 25875) (DC 25877 . 26558) (DF 26560 . 27602) (DP 27604 . 28688) (DV 28690 . 29262) ( EDITPROP 29264 . 29483) (EF 29485 . 29814) (EP 29816 . 29999) (EV 30001 . 30180) (EDITE 30182 . 31060) (EDITL 31062 . 31288)) (31640 37712 (NEW/EDITDATE 31650 . 31872) (FIXEDITDATE 31874 . 33716) ( EDITDATE? 33718 . 34896) (EDITDATE 34898 . 35715) (SETINITIALS 35717 . 37710))))) STOP \ No newline at end of file diff --git a/sources/ERROR-RUNTIME b/sources/ERROR-RUNTIME new file mode 100644 index 00000000..477dfba8 --- /dev/null +++ b/sources/ERROR-RUNTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 16:27:39" |{DSK}local>lde>lispcore>sources>ERROR-RUNTIME.;2| 22062 |changes| |to:| (VARS ERROR-RUNTIMECOMS) |previous| |date:| " 5-Feb-88 15:54:20" |{DSK}local>lde>lispcore>sources>ERROR-RUNTIME.;1| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT ERROR-RUNTIMECOMS) (RPAQQ ERROR-RUNTIMECOMS ((COMS (* |;;;| "Internal functions.") (FUNCTIONS SI::CONDITION-CASE-ERROR CONDITION-HANDLER CONDITION-REPORTER %PRINT-CONDITION CONDITIONS::%RESTART-PRINTER CONDITIONS::%RESTART-DEFAULT-REPORTER REPORT-CONDITION CONDITION-PARENT) (VARIABLES *CONDITION-HANDLER-BINDINGS* *PROCEED-CASES*) (FUNCTIONS CHECK-TYPE-FAIL ECASE-FAIL ASSERT-FAIL) (FUNCTIONS MAKE-INTO-CONDITION RAISE-SIGNAL DEFAULT-HANDLE-CONDITION DEFAULT-PROCEED-REPORTER CONDITIONS::DEFAULT-RESTART-REPORTER DEFAULT-PROCEED-TEST TEST-PROCEED-CASE WALK-PROCEED-CASES SI::INVOKE-ACTUAL-RESTART)) (COMS (* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.") (VARIABLES CONDITIONS:*BREAK-ON-SIGNALS* *BREAK-ON-WARNINGS* XCL:*CURRENT-CONDITION*) (FUNCTIONS MAKE-CONDITION SIGNAL CL:ERROR CL:CERROR CL:WARN CL:BREAK CONDITIONS:INVOKE-DEBUGGER) (FUNCTIONS CONDITIONS:FIND-RESTART CONDITIONS:COMPUTE-RESTARTS CONDITIONS:INVOKE-RESTART CONDITIONS:INVOKE-RESTART-INTERACTIVELY)) (PROP FILETYPE ERROR-RUNTIME))) (* |;;;| "Internal functions.") (CL:DEFUN SI::CONDITION-CASE-ERROR (SI::REAL-SELECTOR SI::POSSIBILITIES) (CL:ERROR "Unexpected selector in ~S." 'CONDITION-CASE SI::REAL-SELECTOR SI::POSSIBILITIES)) (DEFMACRO CONDITION-HANDLER (XCL::CONDITION-TYPE) `(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-HANDLER)) (DEFMACRO CONDITION-REPORTER (XCL::CONDITION-TYPE) `(GETPROP ,XCL::CONDITION-TYPE '%CONDITION-REPORTER)) (CL:DEFUN %PRINT-CONDITION (CONDITION STREAM LEVEL) (DECLARE (IGNORE LEVEL)) (CL:IF *PRINT-ESCAPE* (CL:FORMAT STREAM "#" (CL:TYPE-OF CONDITION) (\\HILOC CONDITION) (\\LOLOC CONDITION)) (REPORT-CONDITION CONDITION STREAM))) (CL:DEFUN CONDITIONS::%RESTART-PRINTER (CONDITIONS:RESTART STREAM CONDITIONS::LEVEL) (CL:IF *PRINT-ESCAPE* (CL:FUNCALL CL::%DEFAULT-PRINT-FUNCTION CONDITIONS:RESTART STREAM CONDITIONS::LEVEL) (LET ((CONDITIONS::REPORTER (OR (CONDITIONS::RESTART-REPORT CONDITIONS:RESTART) (CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)) (CL:RETURN-FROM CONDITIONS::%RESTART-PRINTER ( CONDITIONS::DEFAULT-RESTART-REPORTER CONDITIONS:RESTART STREAM))))) (CL:IF (CL:STRINGP CONDITIONS::REPORTER) (CL:PRINC CONDITIONS::REPORTER STREAM) (CL:FUNCALL CONDITIONS::REPORTER STREAM))))) (CL:DEFUN CONDITIONS::%RESTART-DEFAULT-REPORTER (CONDITIONS:RESTART STREAM) (CL:FUNCALL (CONDITIONS::DEFAULT-RESTART-REPORT (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)) CONDITIONS:RESTART STREAM)) (CL:DEFUN REPORT-CONDITION (CONDITION STREAM) (CL:DO* ((TYPE (CL:TYPE-OF CONDITION) (CONDITION-PARENT TYPE)) (REPORTER (CONDITION-REPORTER TYPE) (CONDITION-REPORTER TYPE))) ((NULL TYPE) (CL:BREAK "No report function found for ~S." CONDITION)) (CL:WHEN REPORTER (RETURN (CL:IF (CL:STRINGP REPORTER) (CL:PRINC REPORTER STREAM) (CL:FUNCALL REPORTER CONDITION STREAM)))))) (CL:DEFUN CONDITION-PARENT (TYPE) (LET ((PARENT (GETSUPERTYPE TYPE))) (CL:IF (EQ PARENT 'CL::STRUCTURE-OBJECT) NIL PARENT))) (CL:DEFVAR *CONDITION-HANDLER-BINDINGS* NIL "Condition handler binding stack") (CL:DEFVAR *PROCEED-CASES* NIL "Active proceed case stack") (CL:DEFUN CHECK-TYPE-FAIL (PROCEEDABLE PLACE VALUE DESIRED-TYPE MESSAGE) (CONDITIONS:RESTART-CASE (CL:ERROR 'XCL:TYPE-MISMATCH :NAME PLACE :VALUE VALUE :EXPECTED-TYPE DESIRED-TYPE :MESSAGE MESSAGE) (STORE-VALUE (NEW) :REPORT (LAMBDA (STREAM) (CL:FORMAT STREAM "Change the value of ~A" PLACE)) :INTERACTIVE (LAMBDA NIL (CL:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE) (LIST (CL:EVAL (CL:READ *QUERY-IO*)))) :FILTER (LAMBDA NIL (AND PROCEEDABLE (TYPEP XCL:*CURRENT-CONDITION* 'XCL:TYPE-MISMATCH))) NEW))) (CL:DEFUN ECASE-FAIL (PROCEEDABLE PLACE VALUE SELECTORS) (CONDITIONS:RESTART-CASE (CL:IF (EQL PLACE VALUE) (CL:ERROR "~S is ~?." VALUE "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" SELECTORS) (CL:ERROR "The value of ~S, ~S,~&is ~?." PLACE VALUE "~#[wrong~;not ~S~;neither ~S nor ~S~:;not~@{~#[~; or~] ~S~^,~}~]" SELECTORS)) (STORE-VALUE (V) :FILTER (LAMBDA NIL PROCEEDABLE) :REPORT (LAMBDA (STREAM) (CL:FORMAT STREAM "Change the value of ~A" PLACE)) :INTERACTIVE (LAMBDA NIL (CL:FORMAT *QUERY-IO* "Enter a new value to store into ~A: " PLACE) (LIST (CL:EVAL (CL:READ *QUERY-IO*)))) V))) (CL:DEFUN ASSERT-FAIL (STRING &REST ARGS) (PROCEED-CASE (CL:ERROR 'XCL:ASSERTION-FAILED :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGS) (CONDITIONS:CONTINUE NIL :REPORT "Re-test assertion"))) (CL:DEFUN MAKE-INTO-CONDITION (DATUM DESIRED-TYPE ARGS) (CL:ETYPECASE DATUM (CONDITION DATUM) (CL:SYMBOL (CL:IF (CL:SUBTYPEP DATUM 'CONDITION) (CL:APPLY 'MAKE-CONDITION DATUM ARGS) (CL:ERROR "~S is not a condition type." DATUM))) (STRING (MAKE-CONDITION DESIRED-TYPE :FORMAT-STRING DATUM :FORMAT-ARGUMENTS ARGS)))) (CL:DEFUN RAISE-SIGNAL (CONDITION) (CL:WHEN (TYPEP CONDITION CONDITIONS:*BREAK-ON-SIGNALS*) (CL:BREAK "Condition ~S is about to be signalled." CONDITION)) (LET ((*CONDITION-HANDLER-BINDINGS* *CONDITION-HANDLER-BINDINGS*)) (CL:FLET ((TRY-TO-HANDLE (CONDITION TYPE-SPEC HANDLER) (CL:MACROLET ((WITHOUT-HANDLERS (&BODY BODY) `(LET (*CONDITION-HANDLER-BINDINGS*) ,@BODY))) (CL:WHEN (PROCEED-CASE (WITHOUT-HANDLERS (TYPEP CONDITION TYPE-SPEC)) (PROCEED NIL :REPORT "Skip the bad handler binding" NIL)) (CL:FUNCALL HANDLER CONDITION))))) (WHILE *CONDITION-HANDLER-BINDINGS* DO (LET ((BINDING (CL:POP *CONDITION-HANDLER-BINDINGS*))) (IF (EQ (CL:FIRST BINDING) :MULTIPLE-HANDLER-BINDINGS) THEN (CL:POP BINDING) (WHILE BINDING DO (TRY-TO-HANDLE CONDITION (CL:POP BINDING) (CL:POP BINDING))) ELSE (TRY-TO-HANDLE CONDITION (CAR BINDING) (CDR BINDING)))) FINALLY ( DEFAULT-HANDLE-CONDITION CONDITION))) CONDITION)) (CL:DEFUN DEFAULT-HANDLE-CONDITION (CONDITION) (CL:DO ((TYPE (CL:TYPE-OF CONDITION) (CONDITION-PARENT TYPE))) ((NULL TYPE)) (LET ((HANDLER (CONDITION-HANDLER TYPE))) (CL:WHEN HANDLER (CL:FUNCALL HANDLER CONDITION))))) (CL:DEFUN DEFAULT-PROCEED-REPORTER (PC STREAM) (CL:FORMAT STREAM "Proceed-type: ~A" (PROCEED-CASE-NAME PC))) (CL:DEFUN CONDITIONS::DEFAULT-RESTART-REPORTER (CONDITIONS:RESTART STREAM) (CL:FORMAT STREAM "Restart type: ~A" (CONDITIONS:RESTART-NAME CONDITIONS:RESTART))) (DEFMACRO DEFAULT-PROCEED-TEST (XCL::PROCEED-TYPE) `(GETPROP ,XCL::PROCEED-TYPE '%DEFAULT-PROCEED-TEST)) (CL:DEFUN TEST-PROCEED-CASE (PC &AUX FILTER) (COND ((CL:SETF FILTER (CONDITIONS::RESTART-TEST PC)) (CL:FUNCALL FILTER)) ((CONDITIONS:RESTART-NAME PC) (CL:IF (CL:SETF FILTER (DEFAULT-PROCEED-TEST (CONDITIONS:RESTART-NAME PC))) (CL:FUNCALL FILTER) T)) (T (* \;  "unnamed proceed case with no explicit test") T))) (CL:DEFUN WALK-PROCEED-CASES (PROCEED-CASES PRED) (CL:FLET ((CONVERT-PROCEED-CASE (PC BLIP) (CL:IF (NULL (CONDITIONS::RESTART-TAG PC)) (LET ((NEW (CONDITIONS::COPY-RESTART PC))) (CL:SETF (CONDITIONS::RESTART-TAG NEW) BLIP) NEW) PC))) (CL:DO ((TAIL PROCEED-CASES (CDR TAIL))) ((NULL TAIL) NIL) (CL:MACROLET ((PROCESS-THING (THING BLIP) `(LET ((PC (CONVERT-PROCEED-CASE ,THING ,BLIP))) (CL:WHEN (CL:FUNCALL PRED PC) (CL:RETURN-FROM WALK-PROCEED-CASES PC))))) (LET ((OBJECT (CAR TAIL))) (CL:IF (CL:CONSP OBJECT) (CL:DO ((THINGS OBJECT (CDR THINGS))) ((NULL THINGS)) (PROCESS-THING (CAR THINGS) TAIL)) (PROCESS-THING OBJECT TAIL))))))) (CL:DEFUN SI::INVOKE-ACTUAL-RESTART (SI::RESTART SI::ARGUMENTS) (COND ((NULL (CONDITIONS::RESTART-FUNCTION SI::RESTART)) (CL:THROW (CONDITIONS::RESTART-TAG SI::RESTART) (CONS (CONDITIONS::RESTART-SELECTOR SI::RESTART) SI::ARGUMENTS))) ((EQ (CONDITIONS::RESTART-SELECTOR SI::RESTART) 'SI::COMPLEX-RESTART-MARKER) (CL:APPLY (CONDITIONS::RESTART-FUNCTION SI::RESTART) SI::ARGUMENTS)) (T (CL:ERROR "Malformed restart object ~S." SI::RESTART)))) (* |;;;| "Exported symbols. Anything here that's not in CL should be in XCL.") (CL:DEFVAR CONDITIONS:*BREAK-ON-SIGNALS* NIL) (CL:DEFVAR *BREAK-ON-WARNINGS* NIL "If true, calls to WARN will cause a break as well as logging the warning.") (CL:DEFVAR XCL:*CURRENT-CONDITION* NIL "The condition currently being signalled") (CL:DEFUN MAKE-CONDITION (TYPE &REST XCL::SLOT-INITIALIZATIONS) "Create a condition object of the specified type." (CL:APPLY (CL::STRUCTURE-CONSTRUCTOR TYPE) XCL::SLOT-INITIALIZATIONS)) (CL:DEFUN SIGNAL (XCL::DATUM &REST XCL::ARGS) (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION XCL::DATUM 'SIMPLE-CONDITION XCL::ARGS))) (RAISE-SIGNAL (CL:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*)) (CL:RETURN-FROM SIGNAL XCL:*CURRENT-CONDITION*))) (CL:DEFUN CL:ERROR (CL::DATUM &REST CL::ARGS) (* |;;| "In Xerox Common Lisp, as with Interlisp, errors may not enter the debugger if they are simple, defined by ENTER-DEBUGGER-P") (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION CL::DATUM 'SIMPLE-ERROR CL::ARGS))) (RAISE-SIGNAL (CL:SETQ *LAST-CONDITION* XCL:*CURRENT-CONDITION*)) (* \; "may just unwind.") (RESETLST (LET ((PRINTMSG T) (ERRORPOS (FIND-DEBUGGER-ENTRY-FRAME 'CL:ERROR))) (DECLARE (CL:SPECIAL PRINTMSG ERRORPOS)) (RESETSAVE NIL (LIST 'RELSTK ERRORPOS)) (COND ((NULL (ENTER-DEBUGGER-P HELPDEPTH ERRORPOS XCL:*CURRENT-CONDITION*)) (* |;;| " says not to enter debugger") (COND (PRINTMSG (* \;  "print message if no break is to occur.") (CL:PRINC XCL:*CURRENT-CONDITION* *ERROR-OUTPUT*))) (ERROR!))) (DEBUGGER :CONDITION XCL:*CURRENT-CONDITION* :AT (STKNAME ERRORPOS)))))) (CL:DEFUN CL:CERROR (CL::PROCEED-FORMAT-STRING CL::DATUM &REST CL::ARGUMENTS) (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION CL::DATUM 'SIMPLE-ERROR CL::ARGUMENTS))) (PROCEED-CASE (CL:ERROR XCL:*CURRENT-CONDITION*) (CONDITIONS:CONTINUE NIL :REPORT (CL:APPLY (FUNCTION CL:FORMAT) T CL::PROCEED-FORMAT-STRING CL::ARGUMENTS) (CL:RETURN-FROM CL:CERROR XCL:*CURRENT-CONDITION*))))) (CL:DEFUN CL:WARN (CL::DATUM &REST CL::ARGUMENTS) (LET ((XCL:*CURRENT-CONDITION* (MAKE-INTO-CONDITION CL::DATUM 'SIMPLE-WARNING CL::ARGUMENTS))) (CL:UNLESS (TYPEP XCL:*CURRENT-CONDITION* 'WARNING) (CL:CERROR "Signal and report the condition anyway" 'XCL:TYPE-MISMATCH :NAME 'CL::CONDITION :VALUE XCL:*CURRENT-CONDITION* :EXPECTED-TYPE 'WARNING)) (CL:WHEN *BREAK-ON-WARNINGS* (CL:BREAK "Warning: ~A" XCL:*CURRENT-CONDITION*)) (PROCEED-CASE (PROGN (RAISE-SIGNAL XCL:*CURRENT-CONDITION*) (CL:FORMAT *ERROR-OUTPUT* "~&Warning: ~A~%" XCL:*CURRENT-CONDITION*) NIL) (CONDITIONS:MUFFLE-WARNING NIL :REPORT "Don't print the warning" NIL)))) (CL:DEFUN CL:BREAK (&OPTIONAL (CL::FORMAT-STRING "Break.") &REST CL::FORMAT-ARGUMENTS) (* |;;| "Want to try and get some indication of which break you're returning from.") (PROCEED-CASE (CONDITIONS:INVOKE-DEBUGGER (MAKE-CONDITION 'SIMPLE-CONDITION :FORMAT-STRING CL::FORMAT-STRING :FORMAT-ARGUMENTS CL::FORMAT-ARGUMENTS)) (CONDITIONS:CONTINUE NIL :REPORT "Return from BREAK" (CL:RETURN-FROM CL:BREAK NIL)))) (CL:DEFUN CONDITIONS:INVOKE-DEBUGGER (CONDITION) (* |;;| "always enter debugger, never return ") (DEBUGGER :CONDITION CONDITION)) (CL:DEFUN CONDITIONS:FIND-RESTART (CONDITIONS::IDENTIFIER) (CL:FLET ((CONDITIONS::SAME-RESTART (CONDITIONS::IDENTIFIER CONDITIONS::PROTOTYPE))) (CL:ETYPECASE CONDITIONS::IDENTIFIER (NULL (CL:ERROR "~S is an invalid argument to ~S;~% use ~S instead" NIL 'CONDITIONS:FIND-RESTART 'CONDITIONS:COMPUTE-RESTARTS)) (CONDITIONS:RESTART (WALK-PROCEED-CASES *PROCEED-CASES* #'(CL:LAMBDA (CONDITIONS:RESTART) (AND (OR (EQ CONDITIONS::IDENTIFIER CONDITIONS:RESTART) (AND (CONDITIONS::RESTART-TAG CONDITIONS::IDENTIFIER) (EQ (CONDITIONS:RESTART-NAME CONDITIONS::IDENTIFIER) (CONDITIONS:RESTART-NAME CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-TAG CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-TAG CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-SELECTOR CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-SELECTOR CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-TEST CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-TEST CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-REPORT CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-REPORT CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-INTERACTIVE-FN CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-INTERACTIVE-FN CONDITIONS:RESTART)) (EQ (CONDITIONS::RESTART-FUNCTION CONDITIONS::IDENTIFIER) (CONDITIONS::RESTART-FUNCTION CONDITIONS:RESTART)))) (TEST-PROCEED-CASE CONDITIONS:RESTART))))) (CL:SYMBOL (WALK-PROCEED-CASES *PROCEED-CASES* #'(CL:LAMBDA (CONDITIONS:RESTART) (AND (EQ ( CONDITIONS:RESTART-NAME CONDITIONS:RESTART) CONDITIONS::IDENTIFIER ) (TEST-PROCEED-CASE CONDITIONS:RESTART) ))))))) (CL:DEFUN CONDITIONS:COMPUTE-RESTARTS () (LET ((CONDITIONS::FOUND NIL)) (WALK-PROCEED-CASES *PROCEED-CASES* #'(CL:LAMBDA (CONDITIONS:RESTART) (CL:WHEN (CL:CATCH 'SI::SKIP-PROCEED-CASE (TEST-PROCEED-CASE CONDITIONS:RESTART)) (CL:PUSH CONDITIONS:RESTART CONDITIONS::FOUND)) NIL)) (CL:NREVERSE CONDITIONS::FOUND))) (CL:DEFUN CONDITIONS:INVOKE-RESTART (CONDITIONS:RESTART &REST CONDITIONS::ARGUMENTS) (LET ((CONDITIONS::R (CONDITIONS:FIND-RESTART CONDITIONS:RESTART))) (CL:IF (NULL CONDITIONS::R) (CL:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART) (SI::INVOKE-ACTUAL-RESTART CONDITIONS::R CONDITIONS::ARGUMENTS)))) (CL:DEFUN CONDITIONS:INVOKE-RESTART-INTERACTIVELY (CONDITIONS:RESTART) (LET ((CONDITIONS::R (CONDITIONS:FIND-RESTART CONDITIONS:RESTART))) (CL:IF (NULL CONDITIONS::R) (CL:ERROR 'XCL:BAD-PROCEED-CASE :NAME CONDITIONS:RESTART) (LET ((CONDITIONS::I-FN (CONDITIONS::RESTART-INTERACTIVE-FN CONDITIONS:RESTART))) (SI::INVOKE-ACTUAL-RESTART CONDITIONS::R (CL:IF CONDITIONS::I-FN (CL:FUNCALL CONDITIONS::I-FN ))))))) (PUTPROPS ERROR-RUNTIME FILETYPE CL:COMPILE-FILE) (PUTPROPS ERROR-RUNTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/ERROR-RUNTIME-AFTER-FASL b/sources/ERROR-RUNTIME-AFTER-FASL new file mode 100644 index 00000000..4f553703 --- /dev/null +++ b/sources/ERROR-RUNTIME-AFTER-FASL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 16:26:16"  |{DSK}local>lde>lispcore>sources>ERROR-RUNTIME-AFTER-FASL.;2| 2531 |changes| |to:| (VARS ERROR-RUNTIME-AFTER-FASLCOMS) |previous| |date:| " 4-Feb-88 19:01:54" |{DSK}local>lde>lispcore>sources>ERROR-RUNTIME-AFTER-FASL.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT ERROR-RUNTIME-AFTER-FASLCOMS) (RPAQQ ERROR-RUNTIME-AFTER-FASLCOMS ((PROP FILETYPE ERROR-RUNTIME-AFTER-FASL) (* |;;;| "These functions must be PavCompiled.") (FUNCTIONS SI::CREATE-CONDITION-CASE-LITERALS) (* |;;;| "These don't need to be, but depend on the previous stuff.") (FUNCTIONS ABORT CONDITIONS:CONTINUE CONDITIONS:MUFFLE-WARNING USE-VALUE STORE-VALUE))) (PUTPROPS ERROR-RUNTIME-AFTER-FASL FILETYPE :COMPILE-FILE) (* |;;;| "These functions must be PavCompiled.") (CL:DEFUN SI::CREATE-CONDITION-CASE-LITERALS (SI::TYPE-LIST) (LET ((SI::CATCH-TAG (LIST NIL))) (* \; "use a separate CONS for the catch tag so that you don't get a circular structure (you could save one by making the tag be the handler binding itself, then smashing its CDR with the closure).") (LIST* SI::CATCH-TAG SI::TYPE-LIST #'(CL:LAMBDA (SI::CONDITION) (CL:THROW SI::CATCH-TAG SI::CONDITION))))) (* |;;;| "These don't need to be, but depend on the previous stuff.") (DEFINE-PROCEED-FUNCTION ABORT :REPORT "Abort" (CONDITION XCL:*CURRENT-CONDITION*)) (CL:DEFUN CONDITIONS:CONTINUE () (LET ((CONDITIONS::R (CONDITIONS:FIND-RESTART 'CONDITIONS:CONTINUE))) (CL:WHEN CONDITIONS::R (CONDITIONS:INVOKE-RESTART CONDITIONS::R)))) (CL:DEFUN CONDITIONS:MUFFLE-WARNING () (LET ((CONDITIONS::R (CONDITIONS:FIND-RESTART 'CONDITIONS:MUFFLE-WARNING))) (CL:WHEN CONDITIONS::R (CONDITIONS:INVOKE-RESTART CONDITIONS::R)))) (DEFINE-PROCEED-FUNCTION USE-VALUE :REPORT "Use a different value" XCL::VALUE) (DEFINE-PROCEED-FUNCTION STORE-VALUE :REPORT "Store a new value and use it" XCL::VALUE) (PUTPROPS ERROR-RUNTIME-AFTER-FASL COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/EXEC-COMMANDS b/sources/EXEC-COMMANDS new file mode 100644 index 00000000..e18d7b4b --- /dev/null +++ b/sources/EXEC-COMMANDS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 16:29:25" |{DSK}local>lde>lispcore>sources>EXEC-COMMANDS.;2| 4370 |changes| |to:| (VARS EXEC-COMMANDSCOMS) |previous| |date:| " 2-Jun-87 14:53:25" |{DSK}local>lde>lispcore>sources>EXEC-COMMANDS.;1| ) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT EXEC-COMMANDSCOMS) (RPAQQ EXEC-COMMANDSCOMS ((GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS) (FNS PRINTPROPS PRINTBINDINGS) (LISPXMACROS PL PB \;) (COMMANDS "PB" "RETRY") (PROP FILETYPE EXEC-COMMANDS))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SPELLINGS1 SPELLINGS2 USERWORDS) ) (DEFINEQ (printprops (lambda (at) (* |lmm| " 7-May-84 15:35") (resetform (printlevel '(2 . 3)) (map (or (getproplist at) (getproplist (or (misspelled? at nil userwords) at))) (function (lambda (tl) (prin2 (car tl) t t) (prin1 " : " t) (showprint (cadr tl) t t))) (function cddr))))) (printbindings (lambda (at pos fl) (* |lmm| "14-Aug-84 20:33") (* |Print| |out| |the| |bindings| |of|  |an| |atom|) (resetform (printlevel 2 3) (prog (name val epos) (or fl (setq fl t)) (|printout| fl "bindings for " at ": " t) (setq pos (stknth 0 (or pos 'printbindings))) lp (or (setq pos (stkscan at pos pos)) (go out)) (setq val (stkarg at pos)) (prin1 '" @ " fl) (prin2 (stkname pos) fl t) (cond ((not (realframep pos)) (prin1 "/" fl) (prog nil (setq epos (stknth 1 pos epos)) lp (cond ((realframep epos) (prin2 (stkname epos) fl t)) ((setq epos (stknth 1 epos epos)) (go lp)) (t (prin1 "? " fl)))))) (prin1 '" : " fl) (showprint val fl t) (and (setq pos (stknth 1 pos pos)) (go lp)) out (relstk epos) (prin1 " @ " fl) last (prin1 '"TOP : " fl) (showprint (gettopval at) fl t) (return))))) ) (ADDTOVAR LISPXHISTORYMACROS (PL (COND (LISPXLINE (MAPC (NLAMBDA.ARGS LISPXLINE) (FUNCTION PRINTPROPS))) (T '(E PL)))) (PB (COND (LISPXLINE (MAPC (NLAMBDA.ARGS LISPXLINE) (FUNCTION (LAMBDA (X) (PRINTBINDINGS X (AND (EQ LISPXID '\:) LASTPOS)))))) (T '(E PB)))) (\; NIL NIL)) (ADDTOVAR HISTORYCOMS \;) (DEFCOMMAND "PB" (VARIABLE) "Show where on the stack VARIABLE is (special) bound" (PRINTBINDINGS VARIABLE) (CL:VALUES)) (DEFCOMMAND ("RETRY" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified events with debugging" (SETQ RETRYFLAG T) (* \; "Bound by and noticed in DO-EVENT. Causes HELPFLAG to be bound to !BREAK while executing the form.") (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC '(-1)) LISPXHISTORY))) (PUTPROPS EXEC-COMMANDS FILETYPE CL:COMPILE-FILE) (PUTPROPS EXEC-COMMANDS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (836 3105 (PRINTPROPS 846 . 1437) (PRINTBINDINGS 1439 . 3103))))) STOP \ No newline at end of file diff --git a/sources/FASDUMP b/sources/FASDUMP new file mode 100644 index 00000000..39168907 --- /dev/null +++ b/sources/FASDUMP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL") (IL:FILECREATED "11-Jan-91 16:21:54" IL:|{PELE:MV:ENVOS}SOURCES>FASDUMP.;3| 25486 IL:|changes| IL:|to:| (IL:FUNCTIONS OPEN-FASL-HANDLE) IL:|previous| IL:|date:| "16-May-90 16:31:44" IL:|{PELE:MV:ENVOS}SOURCES>FASDUMP.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:FASDUMPCOMS) (IL:RPAQQ IL:FASDUMPCOMS ( (IL:* IL:|;;;| "FASL Dumper.") (IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILES (IL:LOADCOMP) IL:FASLOAD)) (IL:STRUCTURES HANDLE) (IL:VARIABLES DUMMY-HANDLE) (IL:VARIABLES +SMALLEST-FOUR-BYTE-INTEGER+ +LARGEST-FOUR-BYTE-INTEGER+) (IL:VARIABLES *GATHER-DUMPER-STATS* *TABLE-ATTEMPTS* *TABLE-HITS*) (IL:FUNCTIONS RESET-DUMPER-STATS) (IL:FUNCTIONS DOTTED-LIST-LENGTH STATE-CASE FAT-STRING-P REMEMBER ELEMENTS-IDENTICAL-P END-BLOCK END-TEXT WRITE-OP LOOKUP-VALUE SAVE-VALUE) (IL:FUNCTIONS DUMP-VALUE-FETCH DUMP-CHARACTER DUMP-SYMBOL DUMP-LIST DUMP-SIMPLE-VECTOR DUMP-ARRAY-DESCRIPTOR DUMP-BIT-ARRAY DUMP-GENERAL-ARRAY DUMP-ARRAY WRITE-INTEGER-BYTES INTEGER-BYTE-LIST DUMP-RATIONAL DUMP-COMPLEX DUMP-INTEGER DUMP-PACKAGE DUMP-DCODE DUMP-STRING DUMP-FLOAT32 DUMP-STRUCTURE DUMP-BITMAP) (IL:FUNCTIONS OPEN-FASL-HANDLE WITH-OPEN-HANDLE BEGIN-TEXT BEGIN-BLOCK VALUE-DUMPABLE-P DUMP-VALUE DUMP-FUNCTION-DEF DUMP-FUNCALL DUMP-EVAL CLOSE-FASL-HANDLE) (IL:* IL:|;;| "Arrange for the correct compiler and makefile environment") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:FASDUMP))) (IL:* IL:|;;;| "FASL Dumper.") (IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILESLOAD (IL:LOADCOMP) IL:FASLOAD) ) (DEFSTRUCT (HANDLE (:CONSTRUCTOR MAKE-HANDLE)) STREAM (STATE :BLOCK-END) (LAST-INDEX 0) (HASH (MAKE-HASH-TABLE :TEST #'EQ))) (DEFCONSTANT DUMMY-HANDLE (MAKE-HANDLE :STREAM (OPEN "{null}" :DIRECTION :OUTPUT) :STATE :BLOCK :HASH NIL)) (DEFCONSTANT +SMALLEST-FOUR-BYTE-INTEGER+ (- (EXPT 2 31))) (DEFCONSTANT +LARGEST-FOUR-BYTE-INTEGER+ (1- (EXPT 2 31))) (DEFVAR *GATHER-DUMPER-STATS* NIL) (DEFVAR *TABLE-ATTEMPTS* 0 "Number of table lookups by the FASL dumper.") (DEFVAR *TABLE-HITS* 0 "Number of successful table lookups by the FASL dumper.") (DEFUN RESET-DUMPER-STATS () (SETQ *TABLE-ATTEMPTS* 0 *TABLE-HITS* 0)) (DEFUN DOTTED-LIST-LENGTH (X) (DO ((N 0 (+ N 2)) (FAST X (CDDR FAST)) (SLOW X (CDR SLOW))) (NIL) (COND ((NULL FAST) (RETURN N)) ((ATOM FAST) (RETURN (VALUES N T))) ((NULL (CDR FAST)) (RETURN (1+ N))) ((ATOM (CDR FAST)) (RETURN (VALUES (1+ N) T))) ((AND (EQ FAST SLOW) (> N 0)) (RETURN NIL))))) (DEFMACRO STATE-CASE (&REST CLAUSES) `(ECASE (HANDLE-STATE HANDLE) ,@CLAUSES)) (DEFUN FAT-STRING-P (STRING) (COND ((IL:STRINGP STRING) (EQ (IL:FETCH (IL:STRINGP IL:TYP) IL:OF STRING) IL:\\ST.POS16)) (T (IL:%FAT-STRING-ARRAY-P STRING)))) (DEFMACRO REMEMBER (VALUE &BODY BODY) `(LET (($REMEMBER-VAL$ ,VALUE)) (WHEN REMEMBER (WRITE-OP HANDLE 'FASL-TABLE-STORE)) ,@BODY (WHEN REMEMBER (SAVE-VALUE HANDLE $REMEMBER-VAL$)))) (DEFUN ELEMENTS-IDENTICAL-P (ARRAY) (LET* ((SEQ (IL:%FLATTEN-ARRAY ARRAY)) (TESTELT (AREF SEQ 0))) (EVERY #'(LAMBDA (X) (EQL X TESTELT)) SEQ))) (DEFUN END-BLOCK (HANDLE) (STATE-CASE (:BLOCK (WHEN CHECK-TABLE-SIZE (WRITE-OP HANDLE 'FASL-VERIFY-TABLE-SIZE) (DUMP-VALUE HANDLE (HANDLE-LAST-INDEX HANDLE) NIL)) (IL:BOUT (HANDLE-STREAM HANDLE) END-MARK) (SETF (HANDLE-LAST-INDEX HANDLE) 0) (SETF (HANDLE-HASH HANDLE) (MAKE-HASH-TABLE :TEST #'EQ)) (SETF (HANDLE-STATE HANDLE) :BLOCK-END)))) (DEFUN END-TEXT (HANDLE) (STATE-CASE (:TEXT (IL:BOUT (HANDLE-STREAM HANDLE) END-MARK) (SETF (HANDLE-STATE HANDLE) :BLOCK)))) (DEFUN WRITE-OP (HANDLE OPNAME) (STATE-CASE (:BLOCK (LET ((STREAM (HANDLE-STREAM HANDLE)) (OPSEQ (OPCODE-SEQUENCE OPNAME))) (IF (NULL OPSEQ) (ERROR 'UNIMPLEMENTED-OPCODE :OPNAME OPNAME) (DOLIST (OP OPSEQ) (IL:BOUT STREAM OP))))))) (DEFUN LOOKUP-VALUE (HANDLE VALUE) (LET ((HASH-TABLE (HANDLE-HASH HANDLE))) (AND HASH-TABLE (IL:GETHASH VALUE HASH-TABLE)))) (DEFUN SAVE-VALUE (HANDLE VALUE) (LET ((HASH-TABLE (HANDLE-HASH HANDLE))) (UNLESS (NULL HASH-TABLE) (SETF (IL:GETHASH VALUE HASH-TABLE) (HANDLE-LAST-INDEX HANDLE)) (INCF (HANDLE-LAST-INDEX HANDLE))))) (DEFUN DUMP-VALUE-FETCH (HANDLE INDEX) (WRITE-OP HANDLE 'FASL-TABLE-FETCH) (DUMP-VALUE HANDLE INDEX NIL)) (DEFUN DUMP-CHARACTER (HANDLE CHAR REMEMBER) (DECLARE (IGNORE REMEMBER)) (IL:* IL:|;;| "Characters don't get remembered.") (LET ((CODE (CHAR-CODE CHAR)) (STREAM (HANDLE-STREAM HANDLE))) (WRITE-OP HANDLE 'FASL-CHARACTER) (IF (< CODE 256) (IL:BOUT STREAM CODE) (PROGN (IL:BOUT STREAM 255) (IL:BOUT16 STREAM CODE))))) (DEFUN DUMP-SYMBOL (HANDLE SYMBOL REMEMBER) (IL:* IL:|;;|  "No point in remembering the pname because SYMBOL-NAME always gives you a new one.") (LET* ((PNAME (SYMBOL-NAME SYMBOL)) (PACKAGE (SYMBOL-PACKAGE SYMBOL)) (PKG-NAME (AND PACKAGE (PACKAGE-NAME PACKAGE)))) (REMEMBER SYMBOL (COND ((KEYWORDP SYMBOL) (WRITE-OP HANDLE 'FASL-KEYWORD-SYMBOL) (DUMP-VALUE HANDLE PNAME NIL)) ((EQUAL PKG-NAME "LISP") (WRITE-OP HANDLE 'FASL-LISP-SYMBOL) (DUMP-VALUE HANDLE PNAME NIL)) ((EQUAL PKG-NAME "INTERLISP") (WRITE-OP HANDLE 'FASL-INTERLISP-SYMBOL) (DUMP-VALUE HANDLE PNAME NIL)) (T (WRITE-OP HANDLE 'FASL-SYMBOL-IN-PACKAGE) (DUMP-VALUE HANDLE PNAME NIL) (DUMP-VALUE HANDLE PACKAGE REMEMBER)))))) (DEFUN DUMP-LIST (HANDLE LIST REMEMBER) (MULTIPLE-VALUE-BIND (LENGTH DOTTED) (DOTTED-LIST-LENGTH LIST) (UNLESS LENGTH (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT LIST)) (REMEMBER LIST (WRITE-OP HANDLE (IF DOTTED 'FASL-LIST* 'FASL-LIST)) (DUMP-VALUE HANDLE (IF DOTTED (1+ LENGTH) LENGTH) NIL) (DOTIMES (I LENGTH) (DUMP-VALUE HANDLE (CAR LIST)) (POP LIST)) (WHEN DOTTED (DUMP-VALUE HANDLE LIST NIL))))) (DEFUN DUMP-SIMPLE-VECTOR (HANDLE VECTOR REMEMBER) (LET ((LENGTH (LENGTH VECTOR))) (REMEMBER VECTOR (WRITE-OP HANDLE 'FASL-VECTOR) (DUMP-VALUE HANDLE LENGTH REMEMBER) (DOTIMES (I LENGTH) (DUMP-VALUE HANDLE (SVREF VECTOR I) REMEMBER))))) (DEFUN DUMP-ARRAY-DESCRIPTOR (HANDLE ARRAY REMEMBER &KEY (INITIAL-ELEMENT NIL USE-SINGLE-ELT)) (REMEMBER ARRAY (WRITE-OP HANDLE 'FASL-CREATE-ARRAY) (DUMP-VALUE HANDLE (IF (EQL (ARRAY-RANK ARRAY) 1) (CAR (ARRAY-DIMENSIONS ARRAY)) (ARRAY-DIMENSIONS ARRAY)) REMEMBER) (DUMP-VALUE HANDLE `(:ELEMENT-TYPE ,(ARRAY-ELEMENT-TYPE ARRAY) :ADJUSTABLE ,(ADJUSTABLE-ARRAY-P ARRAY) ,@(WHEN (ARRAY-HAS-FILL-POINTER-P ARRAY) `(:FILL-POINTER ,(FILL-POINTER ARRAY))) ,@(WHEN USE-SINGLE-ELT `(:INITIAL-ELEMENT ,INITIAL-ELEMENT))) REMEMBER))) (DEFUN DUMP-BIT-ARRAY (HANDLE ARRAY REMEMBER) (LET ((NBITS (ARRAY-TOTAL-SIZE ARRAY))) (UNLESS (ZEROP (IL:%ARRAY-OFFSET ARRAY)) (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT ARRAY)) (REMEMBER ARRAY (WRITE-OP HANDLE 'FASL-INITIALIZE-BIT-ARRAY) (DUMP-ARRAY-DESCRIPTOR HANDLE ARRAY REMEMBER) (DUMP-VALUE HANDLE NBITS REMEMBER) (IL:\\BOUTS (HANDLE-STREAM HANDLE) (IL:%ARRAY-BASE ARRAY) 0 (CEILING NBITS 8))))) (DEFUN DUMP-GENERAL-ARRAY (HANDLE ARRAY REMEMBER) (IL:* IL:|;;| "Arrays don't get remembered. Displacement information is lost.") (LET* ((NELTS (ARRAY-TOTAL-SIZE ARRAY)) (ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY))) (WRITE-OP HANDLE 'FASL-INITIALIZE-ARRAY) (DUMP-ARRAY-DESCRIPTOR HANDLE ARRAY NIL) (DUMP-VALUE HANDLE NELTS NIL) (LET ((INDIRECT (MAKE-ARRAY NELTS :DISPLACED-TO ARRAY :ELEMENT-TYPE ELT-TYPE))) (DOTIMES (I NELTS) (DUMP-VALUE HANDLE (AREF INDIRECT I) NIL))))) (DEFUN DUMP-ARRAY (HANDLE ARRAY REMEMBER) (COND ((XCL:DISPLACED-ARRAY-P ARRAY) (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT ARRAY)) ((ADJUSTABLE-ARRAY-P ARRAY) (DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER)) ((TYPEP ARRAY '(ARRAY BIT)) (DUMP-BIT-ARRAY HANDLE ARRAY REMEMBER)) ((TYPEP ARRAY 'VECTOR) (DUMP-SIMPLE-VECTOR HANDLE ARRAY REMEMBER)) (T (DUMP-GENERAL-ARRAY HANDLE ARRAY REMEMBER)))) (DEFUN WRITE-INTEGER-BYTES (HANDLE NBYTES VALUE) (LET ((STREAM (HANDLE-STREAM HANDLE))) (DOLIST (BYTE (INTEGER-BYTE-LIST VALUE NBYTES)) (IL:BOUT STREAM BYTE)))) (DEFUN INTEGER-BYTE-LIST (VALUE NBYTES) (DO ((COUNT 0 (1+ COUNT)) (RESULT NIL) (N VALUE) BYTE) ((>= COUNT NBYTES) RESULT) (MULTIPLE-VALUE-SETQ (N BYTE) (FLOOR N 256)) (PUSH BYTE RESULT))) (DEFUN DUMP-RATIONAL (HANDLE VALUE REMEMBER) (DECLARE (IGNORE REMEMBER)) (WRITE-OP HANDLE 'FASL-RATIO) (DUMP-VALUE HANDLE (NUMERATOR VALUE) NIL) (DUMP-VALUE HANDLE (DENOMINATOR VALUE) NIL)) (DEFUN DUMP-COMPLEX (HANDLE VALUE REMEMBER) (DECLARE (IGNORE REMEMBER)) (WRITE-OP HANDLE 'FASL-COMPLEX) (DUMP-VALUE HANDLE (REALPART VALUE) NIL) (DUMP-VALUE HANDLE (IMAGPART VALUE) NIL)) (DEFUN DUMP-INTEGER (HANDLE VALUE REMEMBER) (DECLARE (IGNORE REMEMBER)) (COND ((AND (<= 0 VALUE) (< VALUE 128)) (IL:BOUT (HANDLE-STREAM HANDLE) VALUE)) ((AND (<= +SMALLEST-FOUR-BYTE-INTEGER+ VALUE +LARGEST-FOUR-BYTE-INTEGER+)) (WRITE-OP HANDLE 'FASL-INTEGER) (WRITE-INTEGER-BYTES HANDLE 4 VALUE)) (T (WRITE-OP HANDLE 'FASL-LARGE-INTEGER) (LET* ((MINBITS (1+ (INTEGER-LENGTH VALUE))) (NBYTES (CEILING MINBITS 8))) (IL:* IL:|;;| "According to the book, MINBITS gives the minimum field width for this number in 2's complement representation.") (DUMP-VALUE HANDLE NBYTES NIL) (WRITE-INTEGER-BYTES HANDLE NBYTES VALUE))))) (DEFUN DUMP-PACKAGE (HANDLE PACKAGE REMEMBER) (REMEMBER PACKAGE (WRITE-OP HANDLE 'FASL-FIND-PACKAGE) (DUMP-VALUE HANDLE (PACKAGE-NAME PACKAGE) REMEMBER))) (DEFUN DUMP-DCODE (HANDLE DCODE REMEMBER) (LET ((STREAM (HANDLE-STREAM HANDLE))) (MACROLET ((DUMP-SEQ (SEQ DUMP-LENGTH &REST STUFF) `(LET ((SEQ ,SEQ)) ,@(AND DUMP-LENGTH '((DUMP-VALUE HANDLE (LENGTH SEQ) REMEMBER))) (IF (LISTP SEQ) (DOLIST (ELT SEQ) ,@STUFF) (DOTIMES (INDEX (LENGTH SEQ)) (LET ((ELT (AREF SEQ INDEX))) ,@STUFF)))))) (IL:* IL:|;;|  "If group fixups are necessary, wrap the whole thing in a FASL-LOCAL-FN-FIXUPS.") (UNLESS (NULL (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE)) (WRITE-OP HANDLE 'FASL-LOCAL-FN-FIXUPS)) (REMEMBER DCODE (IL:* IL:\;  "So that it turns up as a value fetch in the local function fixups below.") (WRITE-OP HANDLE 'FASL-DCODE) (DUMP-VALUE HANDLE (LENGTH (D-ASSEM::DCODE-NAME-TABLE DCODE)) REMEMBER) (LET* ((CODE-ARRAY (D-ASSEM::DCODE-CODE-ARRAY DCODE)) (NBYTES (LENGTH CODE-ARRAY))) (DUMP-VALUE HANDLE NBYTES REMEMBER) (DOTIMES (I NBYTES) (IL:BOUT STREAM (AREF CODE-ARRAY I)))) (DUMP-SEQ (D-ASSEM::DCODE-NAME-TABLE DCODE) NIL (IL:BOUT STREAM (FIRST ELT)) (DUMP-VALUE HANDLE (SECOND ELT) REMEMBER) (DUMP-VALUE HANDLE (THIRD ELT) REMEMBER)) (DUMP-VALUE HANDLE (D-ASSEM::DCODE-FRAME-NAME DCODE) REMEMBER) (IL:BOUT STREAM (D-ASSEM::DCODE-NLOCALS DCODE)) (IL:BOUT STREAM (D-ASSEM::DCODE-NFREEVARS DCODE)) (IL:BOUT STREAM (D-ASSEM::DCODE-ARG-TYPE DCODE)) (DUMP-VALUE HANDLE (D-ASSEM::DCODE-NUM-ARGS DCODE) REMEMBER) (DUMP-VALUE HANDLE (D-ASSEM::DCODE-CLOSURE-P DCODE) REMEMBER) (DUMP-VALUE HANDLE (D-ASSEM::DCODE-DEBUGGING-INFO DCODE) REMEMBER) (MACROLET ((DUMP-FIXUPS (LIST) `(DUMP-SEQ ,LIST T (DUMP-VALUE HANDLE (FIRST ELT)) (DUMP-VALUE HANDLE (SECOND ELT))))) (DUMP-FIXUPS (D-ASSEM::DCODE-FN-FIXUPS DCODE)) (DUMP-FIXUPS (D-ASSEM::DCODE-SYM-FIXUPS DCODE)) (DUMP-FIXUPS (D-ASSEM::DCODE-LIT-FIXUPS DCODE)) (DUMP-FIXUPS (D-ASSEM::DCODE-TYPE-FIXUPS DCODE)))) (IL:* IL:|;;| "Now do the actual group fixups if needed.") (UNLESS (NULL (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE)) (DUMP-SEQ (D-ASSEM::DCODE-LOCAL-FN-FIXUPS DCODE D-ASSEM:DCODE) T (DUMP-VALUE HANDLE (FIRST ELT)) (DUMP-VALUE HANDLE (SECOND ELT)) (DUMP-VALUE HANDLE (THIRD ELT))))) NIL)) (DEFUN DUMP-STRING (HANDLE STRING REMEMBER) (REMEMBER STRING (LET ((STREAM (HANDLE-STREAM HANDLE)) (NCHARS (LENGTH STRING))) (COND ((FAT-STRING-P STRING) (WRITE-OP HANDLE 'FASL-FAT-STRING) (DUMP-VALUE HANDLE NCHARS REMEMBER) (DO ((I 0 (1+ I)) (CSET 0)) ((>= I NCHARS)) (IL:* IL:\; "Always run-encode") (LET* ((CHAR (CHAR-CODE (CHAR STRING I))) (NEW-CSET (IL:LRSH CHAR 8))) (UNLESS (EQL NEW-CSET CSET) (SETQ CSET NEW-CSET) (IL:BOUT STREAM 255) (IL:BOUT STREAM CSET)) (IL:BOUT STREAM (LOGAND CHAR 255))))) (T (WRITE-OP HANDLE 'FASL-THIN-STRING) (DUMP-VALUE HANDLE NCHARS REMEMBER) (IL:* IL:|;;| "should use \\bouts") (DOTIMES (I NCHARS) (IL:BOUT STREAM (CHAR-CODE (CHAR STRING I))))))))) (DEFUN DUMP-FLOAT32 (HANDLE NUMBER REMEMBER) (IL:* IL:\;  "Floats don't get remembered") (WRITE-OP HANDLE 'FASL-FLOAT32) (IL:\\BOUTS (HANDLE-STREAM HANDLE) NUMBER 0 4)) (DEFUN DUMP-STRUCTURE (HANDLE VALUE REMEMBER) (LET ((TYPE (IL:TYPENAME VALUE))) (REMEMBER VALUE (WRITE-OP HANDLE 'FASL-STRUCTURE) (DUMP-VALUE HANDLE TYPE T) (DUMP-VALUE HANDLE (IL:FOR FIELD IL:IN (CL::STRUCTURE-SLOT-NAMES TYPE T) IL:AS DESCRIPTOR IL:IN (IL:GETDESCRIPTORS TYPE) IL:JOIN (LIST FIELD (IL:FETCHFIELD DESCRIPTOR VALUE))) T)))) (DEFUN DUMP-BITMAP (HANDLE VALUE REMEMBER) (LET ((WIDTH (IL:BITMAPWIDTH VALUE)) (HEIGHT (IL:BITMAPHEIGHT VALUE)) (BITS-PER-PIXEL (IL:BITSPERPIXEL VALUE)) (BASE (IL:FETCH (IL:BITMAP IL:BITMAPBASE) IL:OF VALUE)) (STREAM (HANDLE-STREAM HANDLE))) (REMEMBER VALUE (IL:* IL:\;  "Remember the bitmap itself.") (WRITE-OP HANDLE 'FASL-BITMAP16) (DUMP-VALUE HANDLE WIDTH) (DUMP-VALUE HANDLE HEIGHT) (DUMP-VALUE HANDLE BITS-PER-PIXEL) (IL:\\BOUTS STREAM BASE 0 (* 2 HEIGHT (CEILING (* WIDTH BITS-PER-PIXEL) 16)))))) (DEFUN OPEN-FASL-HANDLE (NAME &REST OPEN-OPTIONS) (LET ((STREAM (APPLY #'OPEN NAME :DIRECTION :OUTPUT :ELEMENT-TYPE '(UNSIGNED-BYTE 8) :IF-EXISTS :NEW-VERSION OPEN-OPTIONS))) (IL:* IL:|;;| "A newly opened stream has fileptr = 0..") (IL:BOUT STREAM SIGNATURE) (IL:BOUT16 STREAM CURRENT-VERSION) (MAKE-HANDLE :STREAM STREAM))) (DEFMACRO WITH-OPEN-HANDLE ((HANDLE FILENAME &REST OPEN-OPTIONS) &BODY (BODY DECLS)) (LET ((ABORT (IL:GENSYM "FASL:WITH-OPEN-FASL-HANDLE"))) `(LET ((,HANDLE (OPEN-FASL-HANDLE ,FILENAME ,@OPEN-OPTIONS)) (,ABORT T)) ,@DECLS (UNWIND-PROTECT (MULTIPLE-VALUE-PROG1 (PROGN ,@BODY) (SETQ ,ABORT NIL)) (WHEN ,HANDLE (CLOSE-FASL-HANDLE ,HANDLE :ABORT ,ABORT)))))) (DEFUN BEGIN-TEXT (HANDLE) (STATE-CASE ((:TEXT :BLOCK-END)) (:BLOCK (END-BLOCK HANDLE))) (SETF (HANDLE-STATE HANDLE) :TEXT) (HANDLE-STREAM HANDLE)) (DEFUN BEGIN-BLOCK (HANDLE) (STATE-CASE (:BLOCK-END (BEGIN-TEXT HANDLE) (END-TEXT HANDLE)) (:TEXT (END-TEXT HANDLE)) (:BLOCK))) (DEFUN VALUE-DUMPABLE-P (OBJ) (XCL:CONDITION-CASE (PROGN (DUMP-VALUE DUMMY-HANDLE OBJ NIL) T) (OBJECT-NOT-DUMPABLE NIL NIL))) (DEFUN DUMP-VALUE (HANDLE VALUE &OPTIONAL (REMEMBER T) &AUX INDEX) (STATE-CASE (:BLOCK (COND ((EQ VALUE NIL) (WRITE-OP HANDLE 'FASL-NIL)) ((EQ VALUE T) (WRITE-OP HANDLE 'FASL-T)) ((PROG1 (SETQ INDEX (LOOKUP-VALUE HANDLE VALUE)) (WHEN *GATHER-DUMPER-STATS* (INCF *TABLE-ATTEMPTS*))) (WHEN *GATHER-DUMPER-STATS* (INCF *TABLE-HITS*)) (DUMP-VALUE-FETCH HANDLE INDEX)) (T (TYPECASE VALUE (INTEGER (DUMP-INTEGER HANDLE VALUE REMEMBER)) (RATIONAL (DUMP-RATIONAL HANDLE VALUE REMEMBER)) (SINGLE-FLOAT (DUMP-FLOAT32 HANDLE VALUE REMEMBER)) (COMPLEX (DUMP-COMPLEX HANDLE VALUE REMEMBER)) (CHARACTER (DUMP-CHARACTER HANDLE VALUE REMEMBER)) (SYMBOL (DUMP-SYMBOL HANDLE VALUE REMEMBER)) (PACKAGE (DUMP-PACKAGE HANDLE VALUE REMEMBER)) (CONS (DUMP-LIST HANDLE VALUE REMEMBER)) (D-ASSEM:DCODE (DUMP-DCODE HANDLE VALUE REMEMBER)) (STRING (DUMP-STRING HANDLE VALUE REMEMBER)) (ARRAY (DUMP-ARRAY HANDLE VALUE REMEMBER)) (COMPILER::EVAL-WHEN-LOAD (LET ((REMEMBER T)) (IL:* IL:\; "always remember these.") (REMEMBER VALUE (DUMP-EVAL HANDLE ( COMPILER::EVAL-WHEN-LOAD-FORM VALUE))))) (CL::STRUCTURE-OBJECT (DUMP-STRUCTURE HANDLE VALUE REMEMBER)) (IL:BITMAP (DUMP-BITMAP HANDLE VALUE REMEMBER)) (OTHERWISE (ERROR 'OBJECT-NOT-DUMPABLE :OBJECT VALUE)))))))) (DEFUN DUMP-FUNCTION-DEF (HANDLE DCODE NAME) (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-SETF-SYMBOL-FUNCTION) (DUMP-VALUE HANDLE NAME) (DUMP-VALUE HANDLE DCODE)))) (DEFUN DUMP-FUNCALL (HANDLE FUNCTION) (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-FUNCALL) (DUMP-VALUE HANDLE FUNCTION)))) (DEFUN DUMP-EVAL (HANDLE FORM) (STATE-CASE (:BLOCK (WRITE-OP HANDLE 'FASL-EVAL) (DUMP-VALUE HANDLE FORM)))) (DEFUN CLOSE-FASL-HANDLE (HANDLE &REST CLOSE-OPTIONS &KEY ABORT &ALLOW-OTHER-KEYS) (STATE-CASE (:TEXT (END-TEXT HANDLE) (END-BLOCK HANDLE)) (:BLOCK (END-BLOCK HANDLE)) (:BLOCK-END)) (IL:BOUT (HANDLE-STREAM HANDLE) END-OF-DATA-MARK) (SETF (HANDLE-STATE HANDLE) :CLOSED) (APPLY #'CLOSE (HANDLE-STREAM HANDLE) CLOSE-OPTIONS)) (IL:* IL:|;;| "Arrange for the correct compiler and makefile environment") (IL:PUTPROPS IL:FASDUMP IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:FASDUMP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "FASL")) (IL:PUTPROPS IL:FASDUMP IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/FASL-PACKAGE b/sources/FASL-PACKAGE new file mode 100644 index 00000000..2224751c --- /dev/null +++ b/sources/FASL-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "FASL" (USE "LISP"))) (IL:FILECREATED "16-May-90 16:33:38" IL:{DSK}local>lde>lispcore>sources>FASL-PACKAGE.;2 4313 IL:changes IL:to%: (IL:VARS IL:FASL-PACKAGECOMS) IL:previous IL:date%: "27-Apr-88 19:02:59" IL:{DSK}local>lde>lispcore>sources>FASL-PACKAGE.;1 ) (IL:* ; " Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:FASL-PACKAGECOMS) (IL:RPAQQ IL:FASL-PACKAGECOMS ( (IL:* IL:;;; "Setting up the FASL package.") (IL:P (XCL:DEFPACKAGE "FASL" (:USE "LISP") (:EXPORT FASL-KEYWORD-SYMBOL FASL-T DUMP-FUNCALL FASL-LIST FASL-LIST* CLOSE-FASL-HANDLE WITH-OPTABLE PROCESS-BLOCK FASL-SHORT-INTEGER PROCESS-FILE FASL-EVAL FASL-RATIO WITH-OPEN-HANDLE FASL-SETF-SYMBOL-FUNCTION UNIMPLEMENTED-OPCODE-OPNAME FASL-VECTOR FASL-CHARACTER FASL-FLOAT32 OBJECT-NOT-DUMPABLE DEFRANGE FASL-VERIFY-TABLE-SIZE DUMP-VALUE VALUE-DUMPABLE-P FASL-DCODE FASL-LOCAL-FN-FIXUPS FASL-TABLE-STORE SKIP-TEXT UNEXPECTED-END-OF-BLOCK-STREAM READ-TEXT INCONSISTENT-TABLE-TABLE FASL-LISP-SYMBOL FASL-INTERLISP-SYMBOL DEFOP OPCODE-SEQUENCE FASL-INITIALIZE-ARRAY FASL-INITIALIZE-BIT-ARRAY SIGNATURE FASL-LARGE-INTEGER OBJECT-NOT-DUMPABLE-OBJECT FASL-FUNCALL FASL-NIL FASL-SYMBOL-IN-PACKAGE NEXT-VALUE UNEXPECTED-END-OF-BLOCK DUMP-FUNCTION-DEF BEGIN-BLOCK BEGIN-TEXT PROCESS-SEGMENT FASL-FIND-PACKAGE FASL-CREATE-ARRAY INCONSISTENT-TABLE-EXPECTED MAKE-OPTABLE *DEFAULT-OPTABLE* FASL-TABLE-FETCH OPEN-FASL-HANDLE CHECK-VERSION FASL-FAT-STRING CURRENT-VERSION UNIMPLEMENTED-OPCODE FASL-ERROR FASL-INTEGER FASL-COMPLEX DUMP-EVAL INCONSISTENT-TABLE FASL-THIN-STRING FASL-BITMAP16 FASL-STRUCTURE))) (IL:* IL:;; "Arrange for the correct makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:FASL-PACKAGE))) (IL:* IL:;;; "Setting up the FASL package.") (XCL:DEFPACKAGE "FASL" (:USE "LISP") (:EXPORT FASL-KEYWORD-SYMBOL FASL-T DUMP-FUNCALL FASL-LIST FASL-LIST* CLOSE-FASL-HANDLE WITH-OPTABLE PROCESS-BLOCK FASL-SHORT-INTEGER PROCESS-FILE FASL-EVAL FASL-RATIO WITH-OPEN-HANDLE FASL-SETF-SYMBOL-FUNCTION UNIMPLEMENTED-OPCODE-OPNAME FASL-VECTOR FASL-CHARACTER FASL-FLOAT32 OBJECT-NOT-DUMPABLE DEFRANGE FASL-VERIFY-TABLE-SIZE DUMP-VALUE VALUE-DUMPABLE-P FASL-DCODE FASL-LOCAL-FN-FIXUPS FASL-TABLE-STORE SKIP-TEXT UNEXPECTED-END-OF-BLOCK-STREAM READ-TEXT INCONSISTENT-TABLE-TABLE FASL-LISP-SYMBOL FASL-INTERLISP-SYMBOL DEFOP OPCODE-SEQUENCE FASL-INITIALIZE-ARRAY FASL-INITIALIZE-BIT-ARRAY SIGNATURE FASL-LARGE-INTEGER OBJECT-NOT-DUMPABLE-OBJECT FASL-FUNCALL FASL-NIL FASL-SYMBOL-IN-PACKAGE NEXT-VALUE UNEXPECTED-END-OF-BLOCK DUMP-FUNCTION-DEF BEGIN-BLOCK BEGIN-TEXT PROCESS-SEGMENT FASL-FIND-PACKAGE FASL-CREATE-ARRAY INCONSISTENT-TABLE-EXPECTED MAKE-OPTABLE *DEFAULT-OPTABLE* FASL-TABLE-FETCH OPEN-FASL-HANDLE CHECK-VERSION FASL-FAT-STRING CURRENT-VERSION UNIMPLEMENTED-OPCODE FASL-ERROR FASL-INTEGER FASL-COMPLEX DUMP-EVAL INCONSISTENT-TABLE FASL-THIN-STRING FASL-BITMAP16 FASL-STRUCTURE)) (IL:* IL:;; "Arrange for the correct makefile environment") (IL:PUTPROPS IL:FASL-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (XCL:DEFPACKAGE "FASL" (:USE "LISP")))) (IL:PUTPROPS IL:FASL-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/FASL-SUPPORT b/sources/FASL-SUPPORT new file mode 100644 index 00000000..c0e946fe --- /dev/null +++ b/sources/FASL-SUPPORT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL") (IL:FILECREATED "16-May-90 17:37:00" IL:|{DSK}local>lde>lispcore>sources>FASL-SUPPORT.;2| 1408 IL:|changes| IL:|to:| (IL:VARS IL:FASL-SUPPORTCOMS) IL:|previous| IL:|date:| "15-Dec-86 16:23:56" IL:|{DSK}local>lde>lispcore>sources>FASL-SUPPORT.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:FASL-SUPPORTCOMS) (IL:RPAQQ IL:FASL-SUPPORTCOMS ( (IL:* IL:|;;| "Needed for compiling FASLOAD and FASDUMP") (IL:P (OR (GET 'IL:ABC 'IL:FILEDATES) (IL:FILESLOAD (IMPORT) IL:LLBASIC IL:LLCHAR IL:ADISPLAY IL:MODARITH IL:LLGC))) (IL:DEFINE-TYPES FASL-OPS) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:FASL-SUPPORT))) (IL:* IL:|;;| "Needed for compiling FASLOAD and FASDUMP") (OR (GET 'IL:ABC 'IL:FILEDATES) (IL:FILESLOAD (IMPORT) IL:LLBASIC IL:LLCHAR IL:ADISPLAY IL:MODARITH IL:LLGC)) (XCL:DEF-DEFINE-TYPE FASL-OPS "FASL file opcodes") (IL:PUTPROPS IL:FASL-SUPPORT IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:FASL-SUPPORT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "FASL")) (IL:PUTPROPS IL:FASL-SUPPORT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/FASLOAD b/sources/FASLOAD new file mode 100644 index 00000000..a262e91f --- /dev/null +++ b/sources/FASLOAD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "FASL") (IL:FILECREATED "17-Apr-2018 07:55:20"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>FASLOAD.;2| 35249 IL:|changes| IL:|to:| (IL:FNS CONVERT-FASL-DATE) IL:|previous| IL:|date:| "25-Nov-92 12:35:33" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>FASLOAD.;1|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 2018 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:FASLOADCOMS) (IL:RPAQQ IL:FASLOADCOMS ( (IL:* IL:|;;| "FASL file loader.") (IL:* IL:|;;| "THIS FILE IS DUPLICATED as ...Sources> for the large-symbol version, and Sources>2-byte> for the older 2-byte atom version. IF YOU CHANGE THIS COPY, CHANGE THE OTHER, AS WELL!") (IL:COMS (IL:* IL:|;;| "Common definitions.") (IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILES (NIL IL:SOURCE) IL:FASL-SUPPORT)) (IL:STRUCTURES FASL-ERROR UNIMPLEMENTED-OPCODE OBJECT-NOT-DUMPABLE UNEXPECTED-END-OF-BLOCK INCONSISTENT-TABLE) (IL:VARIABLES SIGNATURE) (IL:VARIABLES CHECK-TABLE-SIZE FASL-EXTENDED END-MARK END-OF-DATA-MARK VERSION-RANGE CURRENT-VERSION) (IL:FUNCTIONS TABLE-STATS)) (IL:COMS (IL:* IL:|;;| "Reader.") (IL:COMS (IL:* IL:\; "Setting up the table") (IL:STRUCTURES OPTABLE) (IL:FUNCTIONS MAKE-OPTABLE DEFINE-OPCODE-RANGE DEFINE-SINGLE-OPCODE ADD-OP-TRANSLATION OPCODE-SEQUENCE) (IL:* IL:\; "Opcode definers") (IL:FUNCTIONS DEFOP DEFRANGE)) (IL:FUNCTIONS FASL-END-OF-BLOCK FASL-EXTENDED SETESCAPE UNIMPLEMENTED-OPCODE) (IL:VARIABLES *DEFAULT-OPTABLE* *CURRENT-OPTABLE* INITIAL-VALUE-TABLE-SIZE VALUE-TABLE-INCREMENT *VALUE-TABLE* *BLOCK-LEVEL* DEBUG-READER DEBUG-STREAM) (IL:* IL:|;;| "The main reader functions:") (IL:FUNCTIONS PROCESS-FILE PROCESS-SEGMENT) (IL:FUNCTIONS WITH-OPTABLE CHECK-VERSION READ-TEXT PROCESS-BLOCK SKIP-TEXT NEXT-VALUE DO-OP NEW-VALUE-TABLE CLEAR-TABLE STORE-VALUE FETCH-VALUE COLLECT-LIST) (IL:* IL:|;;| "FASL Opcode processors:") (FASL-OPS FASL-SHORT-INTEGER FASL-NIL FASL-T FASL-INTEGER FASL-LARGE-INTEGER FASL-RATIO FASL-COMPLEX FASL-VECTOR FASL-CREATE-ARRAY FASL-INITIALIZE-ARRAY FASL-INITIALIZE-BIT-ARRAY FASL-THIN-STRING FASL-FAT-STRING FASL-CHARACTER FASL-LISP-SYMBOL FASL-KEYWORD-SYMBOL FASL-FIND-PACKAGE FASL-SYMBOL-IN-PACKAGE FASL-LIST FASL-LIST* FASL-INTERLISP-SYMBOL FASL-DCODE FASL-LOCAL-FN-FIXUPS FASL-TABLE-STORE FASL-TABLE-FETCH FASL-VERIFY-TABLE-SIZE FASL-EVAL FASL-FLOAT32 FASL-SETF-SYMBOL-FUNCTION FASL-FUNCALL FASL-BITMAP16 FASL-STRUCTURE)) (XCL:OPTIMIZERS FIXUP-NTOFFSET) (IL:* IL:|;;| "make sure there's some print function around so that you can load early.") (IL:P (IL:MOVD? 'IL:PRIN1 'PRINC) (IL:MOVD? 'IL:TERPRI 'TERPRI)) (IL:COMS (IL:* IL:|;;|  "ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files.") (IL:FNS IL:FASL-FILEDATE CONVERT-FASL-DATE)) (IL:* IL:|;;| "Arrange for the correct compiler and makefile environment") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:FASLOAD))) (IL:* IL:|;;| "FASL file loader.") (IL:* IL:|;;| "THIS FILE IS DUPLICATED as ...Sources> for the large-symbol version, and Sources>2-byte> for the older 2-byte atom version. IF YOU CHANGE THIS COPY, CHANGE THE OTHER, AS WELL!" ) (IL:* IL:|;;| "Common definitions.") (IL:DECLARE\: IL:EVAL@COMPILE IL:EVAL@LOAD IL:DONTCOPY (IL:FILESLOAD (NIL IL:SOURCE) IL:FASL-SUPPORT) ) (XCL:DEFINE-CONDITION FASL-ERROR (ERROR) NIL) (XCL:DEFINE-CONDITION UNIMPLEMENTED-OPCODE (FASL-ERROR) (OPNAME) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Unimplemented FASL op: ~S" (UNIMPLEMENTED-OPCODE-OPNAME CONDITION))))) (XCL:DEFINE-CONDITION OBJECT-NOT-DUMPABLE (FASL-ERROR) (OBJECT) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Object not dumpable:~&~S" (OBJECT-NOT-DUMPABLE-OBJECT CONDITION))))) (XCL:DEFINE-CONDITION UNEXPECTED-END-OF-BLOCK (FASL-ERROR) (STREAM) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Unexpected FASL-END-OF-BLOCK at ~D." (IL:GETFILEPTR ( UNEXPECTED-END-OF-BLOCK-STREAM CONDITION)))))) (XCL:DEFINE-CONDITION INCONSISTENT-TABLE (FASL-ERROR) (TABLE EXPECTED) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Inconsistent FASL table size.~&Expected ~D but found ~D." ( INCONSISTENT-TABLE-EXPECTED CONDITION) (LENGTH (OPTABLE-VECTOR (INCONSISTENT-TABLE-TABLE CONDITION))))))) (DEFCONSTANT SIGNATURE 145 "First byte of a FASL file.") (DEFVAR CHECK-TABLE-SIZE T) (DEFCONSTANT FASL-EXTENDED 254) (DEFCONSTANT END-MARK 255) (DEFCONSTANT END-OF-DATA-MARK 255 "End-of-data marker: if first byte of a segment, terminate processing") (DEFCONSTANT VERSION-RANGE '(8 . 8) "Handles (car version-range) <= version <= (cdr version-range)") (DEFCONSTANT CURRENT-VERSION 8) (DEFUN TABLE-STATS (TABLE) (LET ((ITEMS (LIST (CONS '--TOTAL-- (LENGTH TABLE))))) (DOTIMES (I (LENGTH TABLE) ITEMS) (LET* ((TYPE (TYPE-OF (AREF TABLE I))) (PAIR (OR (FIND TYPE ITEMS :TEST 'EQUAL :KEY 'CAR) (CAR (PUSH (CONS TYPE 0) ITEMS))))) (INCF (CDR PAIR)))))) (IL:* IL:|;;| "Reader.") (IL:* IL:\; "Setting up the table") (DEFSTRUCT (OPTABLE (:CONSTRUCTOR NEW-OPTABLE)) VECTOR OPNAMES NEXT) (DEFUN MAKE-OPTABLE () (LET ((TABLE (NEW-OPTABLE)) (VECTOR (MAKE-ARRAY 256 :INITIAL-ELEMENT 'UNIMPLEMENTED-OPCODE))) (SETF (OPTABLE-VECTOR TABLE) VECTOR) (SETF (SVREF VECTOR END-MARK) 'FASL-END-OF-BLOCK) TABLE)) (DEFUN DEFINE-OPCODE-RANGE (NAME FIRST-OPCODE RANGE OFFSET TABLE) (IL:* IL:|;;| "For implementation of DEFRANGE definer--define a range of opcodes having the same implementation.") (LET ((PACKAGE (SYMBOL-PACKAGE NAME)) (PNAME (SYMBOL-NAME NAME))) (DOTIMES (I RANGE) (IL:* IL:\;  "Using IL:CONCAT here to minimize bootstrap woes") (DEFINE-SINGLE-OPCODE NAME (+ I FIRST-OPCODE) TABLE (INTERN (IL:CONCAT PNAME (+ I OFFSET)) PACKAGE))))) (DEFUN DEFINE-SINGLE-OPCODE (NAME OPCODE TABLE TRANS-NAME) (IL:* IL:|;;| "For implementation of DEFOP definer -- define NAME to be a fasl op numbered OPCODE in TABLE. NAME is the name of both the opcode as a FASL::FASL-OPS and the function implementing the opcode. TRANS-NAME is a name to associate with the opcode in the OPNAMES slot of the table (it is a generated name when we are called from DEFRANGE).") (SETF (ELT (OPTABLE-VECTOR TABLE) OPCODE) NAME) (ADD-OP-TRANSLATION TRANS-NAME OPCODE TABLE)) (DEFUN ADD-OP-TRANSLATION (NAME OPCODE TABLE) (LET ((PAIR (ASSOC NAME (OPTABLE-OPNAMES TABLE)))) (IF PAIR (SETF (CDR PAIR) OPCODE) (PUSH (CONS NAME OPCODE) (OPTABLE-OPNAMES TABLE))))) (DEFUN OPCODE-SEQUENCE (OPNAME &OPTIONAL (TABLE *DEFAULT-OPTABLE*) &AUX ENTRY) (COND ((NULL TABLE) NIL) ((SETQ ENTRY (ASSOC OPNAME (OPTABLE-OPNAMES TABLE))) (LIST (CDR ENTRY))) ((SETQ ENTRY (OPCODE-SEQUENCE OPNAME (OPTABLE-NEXT TABLE))) (CONS FASL-EXTENDED ENTRY)) (T NIL))) (IL:* IL:\; "Opcode definers") (XCL:DEFDEFINER DEFOP FASL-OPS (IL:NAME (OPCODE &KEY (INDIRECT 0) (TABLE '*DEFAULT-OPTABLE*)) &BODY BODY) (IF (ZEROP INDIRECT) `(PROGN (DEFUN ,IL:NAME (STREAM OPCODE) ,@BODY) (DEFINE-SINGLE-OPCODE ',IL:NAME ,OPCODE ,TABLE ',IL:NAME)) `(PROGN (UNLESS (OPTABLE-NEXT ,TABLE) (SETF (OPTABLE-NEXT ,TABLE) (MAKE-OPTABLE)) (SETESCAPE ,TABLE)) (DEFOP ,IL:NAME (,OPCODE :INDIRECT ,(1- INDIRECT) :TABLE (OPTABLE-NEXT ,TABLE)) ,@BODY)))) (XCL:DEFDEFINER DEFRANGE FASL-OPS (IL:NAME (FIRST-OPCODE &KEY (INDIRECT 0) (TABLE '*DEFAULT-OPTABLE*)) RANGE OFFSET &BODY BODY) (IF (ZEROP INDIRECT) `(PROGN (DEFUN ,IL:NAME (STREAM OPCODE) ,@BODY) (DEFINE-OPCODE-RANGE ',IL:NAME ,FIRST-OPCODE ,RANGE ,OFFSET ,TABLE)) `(PROGN (UNLESS (OPTABLE-NEXT ,TABLE) (SETF (OPTABLE-NEXT ,TABLE) (MAKE-OPTABLE)) (SETESCAPE ,TABLE)) (DEFRANGE ,IL:NAME (,FIRST-OPCODE :INDIRECT ,(1- INDIRECT) :TABLE (OPTABLE-NEXT ,TABLE)) ,@BODY)))) (DEFUN FASL-END-OF-BLOCK (STREAM OP) (IF (ZEROP *BLOCK-LEVEL*) (THROW 'FASL-BLOCK-FINISHED NIL) (ERROR 'UNEXPECTED-END-OF-BLOCK :STREAM STREAM))) (DEFUN FASL-EXTENDED (STREAM OP) (WITH-OPTABLE (OPTABLE-NEXT *CURRENT-OPTABLE*) (DO-OP STREAM))) (DEFUN SETESCAPE (TABLE) (SETF (SVREF (OPTABLE-VECTOR TABLE) FASL-EXTENDED) #'FASL-EXTENDED)) (DEFUN UNIMPLEMENTED-OPCODE (STREAM OPCODE) (ERROR 'UNIMPLEMENTED-OPCODE :OPNAME OPCODE)) (DEFVAR *DEFAULT-OPTABLE* (MAKE-OPTABLE)) (DEFVAR *CURRENT-OPTABLE* NIL) (DEFPARAMETER INITIAL-VALUE-TABLE-SIZE 2048) (DEFCONSTANT VALUE-TABLE-INCREMENT 1024) (DEFVAR *VALUE-TABLE* NIL) (DEFVAR *BLOCK-LEVEL* 0) (DEFVAR DEBUG-READER NIL) (DEFVAR DEBUG-STREAM NIL) (IL:* IL:|;;| "The main reader functions:") (DEFUN PROCESS-FILE (STREAM &KEY (TEXT-FN (AND *LOAD-VERBOSE* #'(LAMBDA (TEXT) (PRINC TEXT) (TERPRI)))) (ITEM-FN NIL)) (IL:* IL:|;;;| "Calls FASL:PROCESS-SEGMENT with the approriate arguments for each segment in the file. The stream should be positioned at the beginning.") (UNLESS (EQL (IL:BIN STREAM) SIGNATURE) (ERROR "Not a FASL file.")) (LET ((IL:FILEPKGFLG NIL) (IL:DFNFLG T) (IL:LISPXHIST NIL) (IL:ADDSPELLFLG NIL)) (IL:* IL:\;  "Bind these so that LOADing a FASL file is like LOADing SYSLOAD.") (DECLARE (SPECIAL IL:FILEPKGFLG IL:DFNFLG IL:LISPXHIST IL:ADDSPELLFLG)) (IF (< (CHECK-VERSION STREAM) 5) (DO NIL ((IL:EOFP STREAM) (VALUES)) (PROCESS-SEGMENT STREAM TEXT-FN ITEM-FN)) (DO NIL ((OR (IL:EOFP STREAM) (EQL (IL:\\PEEKBIN STREAM) END-OF-DATA-MARK)) (VALUES)) (PROCESS-SEGMENT STREAM TEXT-FN ITEM-FN))))) (DEFUN PROCESS-SEGMENT (STREAM &OPTIONAL TEXT-FN ITEM-FN (OPTABLE *DEFAULT-OPTABLE*)) (IF TEXT-FN (FUNCALL TEXT-FN (READ-TEXT STREAM)) (SKIP-TEXT STREAM)) (PROCESS-BLOCK STREAM ITEM-FN OPTABLE)) (DEFMACRO WITH-OPTABLE (TABLE &BODY BODY) `(LET ((*CURRENT-OPTABLE* ,TABLE)) ,@BODY)) (DEFUN CHECK-VERSION (STREAM) (LET ((VERSION (IL:BIN16 STREAM))) (UNLESS (AND (<= (CAR VERSION-RANGE) VERSION) (<= VERSION (CDR VERSION-RANGE))) (ERROR "Version not supported: ~D." VERSION)) (RETURN-FROM CHECK-VERSION VERSION))) (DEFUN READ-TEXT (STREAM) (DO ((RESULT (MAKE-ARRAY 512 :ELEMENT-TYPE 'CHARACTER :ADJUSTABLE T :FILL-POINTER 0)) (BYTE (IL:BIN STREAM) (IL:BIN STREAM))) ((EQL BYTE END-MARK) RESULT) (VECTOR-PUSH-EXTEND (CODE-CHAR BYTE) RESULT))) (DEFUN PROCESS-BLOCK (STREAM &OPTIONAL ITEM-FN (OPTABLE *DEFAULT-OPTABLE*)) (IL:WITH-READER-ENVIRONMENT IL:*COMMON-LISP-READ-ENVIRONMENT* (CATCH 'FASL-BLOCK-FINISHED (WITH-OPTABLE OPTABLE (DO ((*VALUE-TABLE* (NEW-VALUE-TABLE)) VAL) () (SETF VAL (DO-OP STREAM 0)) (WHEN ITEM-FN (FUNCALL ITEM-FN VAL))))))) (DEFUN SKIP-TEXT (STREAM) (DO ((BYTE (IL:BIN STREAM) (IL:BIN STREAM))) ((EQL BYTE END-MARK) (VALUES)))) (DEFMACRO NEXT-VALUE () '(DO-OP STREAM)) (DEFUN DO-OP (STREAM &OPTIONAL (*BLOCK-LEVEL* (1+ *BLOCK-LEVEL*))) (LET ((OP (IL:BIN STREAM)) VAL) (WHEN DEBUG-READER (FORMAT DEBUG-STREAM "~VT~A (~3O)~%" (* *BLOCK-LEVEL* 4) (CAR (RASSOC OP (OPTABLE-OPNAMES *CURRENT-OPTABLE*))) OP)) (SETQ VAL (FUNCALL (SVREF (OPTABLE-VECTOR *CURRENT-OPTABLE*) OP) STREAM OP)) (WHEN DEBUG-READER (FORMAT DEBUG-STREAM "~VTValue: ~S~%" (* *BLOCK-LEVEL* 4) VAL)) (RETURN-FROM DO-OP VAL))) (DEFUN NEW-VALUE-TABLE () (MAKE-ARRAY INITIAL-VALUE-TABLE-SIZE :FILL-POINTER 0 :EXTENDABLE T)) (DEFUN CLEAR-TABLE (&OPTIONAL (TABLE *VALUE-TABLE*)) (SETF (FILL-POINTER TABLE) 0)) (DEFUN STORE-VALUE (OBJ &OPTIONAL (TABLE *VALUE-TABLE*)) (IL:* IL:|;;| "This may want to change to another representation if we can't make VECTOR-PUSH-EXTEND fast enough.") (VECTOR-PUSH-EXTEND OBJ TABLE VALUE-TABLE-INCREMENT) OBJ) (DEFUN FETCH-VALUE (INDEX &OPTIONAL (TABLE *VALUE-TABLE*)) (AREF TABLE INDEX)) (DEFUN COLLECT-LIST (STREAM NELTS DOTTED) (IF (AND DOTTED (EQL NELTS 2)) (RETURN-FROM COLLECT-LIST (CONS (DO-OP STREAM) (DO-OP STREAM)))) (WHEN DOTTED (DECF NELTS)) (LET ((RESULT (IL:|to| NELTS IL:|collect| (DO-OP STREAM)))) (IL:* IL:|;;| "Assume dotted and other than a simple cons is rare.") (WHEN DOTTED (SETF (CDR (LAST RESULT)) (DO-OP STREAM))) (RETURN-FROM COLLECT-LIST RESULT))) (IL:* IL:|;;| "FASL Opcode processors:") (DEFRANGE FASL-SHORT-INTEGER (0) 128 0 "An entire set of FASL opcodes representing small integers" OPCODE) (DEFOP FASL-NIL (128) NIL) (DEFOP FASL-T (129) T) (DEFOP FASL-INTEGER (130) (+ (IL:LLSH (IL:BIN STREAM) 24) (IL:LLSH (IL:BIN STREAM) 16) (IL:LLSH (IL:BIN STREAM) 8) (IL:BIN STREAM))) (DEFOP FASL-LARGE-INTEGER (131) (LET ((NBYTES (NEXT-VALUE)) (FIRST-TIME T) (MASK 0)) (DO ((OFFSET (* (1- NBYTES) 8) (- OFFSET 8)) (RESULT 0) BYTE) ((< OFFSET 0) (IF (ZEROP MASK) RESULT (- (1+ RESULT)))) (SETF BYTE (IL:BIN STREAM)) (WHEN FIRST-TIME (SETF FIRST-TIME NIL) (WHEN (> BYTE 127) (SETQ MASK 255))) (SETF (LDB (BYTE 8 OFFSET) RESULT) (LOGXOR BYTE MASK))))) (DEFOP FASL-RATIO (134) (/ (NEXT-VALUE) (NEXT-VALUE))) (DEFOP FASL-COMPLEX (135) (COMPLEX (NEXT-VALUE) (NEXT-VALUE))) (DEFOP FASL-VECTOR (136) (LET* ((NELTS (NEXT-VALUE)) (VECTOR (MAKE-ARRAY NELTS :INITIAL-ELEMENT NIL))) (DOTIMES (I NELTS VECTOR) (SETF (AREF VECTOR I) (NEXT-VALUE))))) (DEFOP FASL-CREATE-ARRAY (137) (APPLY #'MAKE-ARRAY (NEXT-VALUE) (NEXT-VALUE))) (DEFOP FASL-INITIALIZE-ARRAY (138) (LET* ((ARRAY (NEXT-VALUE)) (INDIRECT (IL:%FLATTEN-ARRAY ARRAY)) (NELTS (NEXT-VALUE))) (DOTIMES (I NELTS ARRAY) (SETF (AREF INDIRECT I) (NEXT-VALUE))))) (DEFOP FASL-INITIALIZE-BIT-ARRAY (139) (LET* ((ARRAY (DO-OP STREAM)) (BASE (IL:%ARRAY-BASE ARRAY)) (NBITS (DO-OP STREAM))) (MULTIPLE-VALUE-BIND (NBYTES LEFTOVER) (FLOOR NBITS 8) (IL:\\BINS STREAM BASE 0 NBYTES) (UNLESS (ZEROP LEFTOVER) (LET ((BD (BYTE LEFTOVER (- 8 LEFTOVER)))) (SETF (LDB BD (IL:\\GETBASEBYTE BASE NBYTES)) (LDB BD (IL:BIN STREAM))))) ARRAY))) (DEFOP FASL-THIN-STRING (140) (LET* ((NCHARS (NEXT-VALUE)) (STRING (IL:ALLOCSTRING NCHARS))) (IL:\\BINS STREAM (IL:FETCH (IL:STRINGP IL:BASE) IL:OF STRING) 0 NCHARS) STRING)) (DEFOP FASL-FAT-STRING (141) (IL:* IL:|;;| "Read a string of specified length that has been encoded in standard NS format.") (LET* ((NCHARS (NEXT-VALUE)) (STRING (IL:ALLOCSTRING NCHARS))) (IL:ACCESS-CHARSET STREAM 0) (IL:* IL:\;  "Make sure we're in charset zero") (UNWIND-PROTECT (DOTIMES (I NCHARS STRING) (SETF (SVREF STRING I) (CODE-CHAR (IL:READCCODE STREAM)))) (IL:* IL:\;  "Restore charset zero, in case anyone cares") (IL:ACCESS-CHARSET STREAM 0)))) (DEFOP FASL-CHARACTER (142) (LET ((CODE (IL:BIN STREAM))) (CODE-CHAR (IF (EQL CODE 255) (IL:BIN16 STREAM) CODE)))) (DEFOP FASL-LISP-SYMBOL (143) (INTERN (NEXT-VALUE) (FIND-PACKAGE "LISP"))) (DEFOP FASL-KEYWORD-SYMBOL (144) (INTERN (NEXT-VALUE) (FIND-PACKAGE "KEYWORD"))) (DEFOP FASL-FIND-PACKAGE (145) (LET ((NAME (NEXT-VALUE))) (OR (FIND-PACKAGE NAME) (ERROR "FASL reader error: package ~S not found." NAME)))) (DEFOP FASL-SYMBOL-IN-PACKAGE (146) (LET* ((PNAME (NEXT-VALUE)) (PACKAGE (NEXT-VALUE))) (IF (NULL PACKAGE) (MAKE-SYMBOL PNAME) (INTERN PNAME PACKAGE)))) (DEFOP FASL-LIST (147) (COLLECT-LIST STREAM (NEXT-VALUE) NIL)) (DEFOP FASL-LIST* (148) (COLLECT-LIST STREAM (NEXT-VALUE) T)) (DEFOP FASL-INTERLISP-SYMBOL (149) (INTERN (NEXT-VALUE) (FIND-PACKAGE "INTERLISP"))) (DEFOP FASL-DCODE (150) (IL:* IL:|;;;| "DIRE WARNING!!! Be sure you have your pointy hat with lots of stars on if you're going to muck around with this code. Due to unfortunately unavoidable performance requirements, this code duplicates D-ASSEM:INTERN-DCODE. If you make a change here, you should probably change the corresponding code there.") (LET ((OVERHEADBYTES (* (IL:FETCH (IL:FNHEADER IL:OVERHEADWORDS) IL:OF T) IL:BYTESPERWORD)) NT-COUNT RAW-CODE START-PC CLOSURE-INFO) (SETF NT-COUNT (NEXT-VALUE)) (LET ((CODE-LEN (NEXT-VALUE))) (MULTIPLE-VALUE-SETQ (RAW-CODE START-PC) (D-ASSEM:ALLOCATE-CODE-BLOCK NT-COUNT CODE-LEN)) (IL:\\BINS STREAM RAW-CODE START-PC CODE-LEN) (IL:REPLACE (IL:FNHEADER IL:STARTPC) IL:OF RAW-CODE IL:WITH START-PC)) (IL:* IL:|;;| "Set up the free variable lookup name table.") (DO* ((I 0 (1+ I)) (INDEX OVERHEADBYTES (+ INDEX (IL:CONSTANT (IL:BYTESPERNAMEENTRY)))) (IL:* IL:|;;|  "NTSIZE and NTBYTESIZE the sizes of half the table in words and bytes resp.") (NTSIZE (IL:CEIL (1+ (IL:UNFOLD NT-COUNT (IL:CONSTANT (IL:WORDSPERNAMEENTRY)))) IL:WORDSPERQUAD)) (NTBYTESIZE (* NTSIZE IL:BYTESPERWORD)) PFI OFFSET NAME FVAROFFSET) ((>= I NT-COUNT) (IL:REPLACE (IL:FNHEADER IL:FVAROFFSET) IL:OF RAW-CODE IL:WITH (OR FVAROFFSET 0)) (IL:REPLACE (IL:FNHEADER IL:NTSIZE) IL:OF RAW-CODE IL:WITH (IF (ZEROP NT-COUNT) 0 NTSIZE))) (SETF PFI (IL:BIN STREAM)) (SETF OFFSET (NEXT-VALUE)) (SETF NAME (NEXT-VALUE)) (D-ASSEM::FIXUP-NTENTRY RAW-CODE INDEX (IL:\\ATOMVALINDEX NAME)) (FIXUP-NTOFFSET RAW-CODE (+ INDEX NTBYTESIZE) (IL:LLSH PFI 14) OFFSET) (WHEN (AND (NULL FVAROFFSET) (= PFI D-ASSEM:+FVAR-CODE+)) (SETF FVAROFFSET (FLOOR INDEX IL:BYTESPERWORD)))) (IL:* IL:|;;| "Fill in the fixed-size fields at the front of the block.") (LET ((FRAME-NAME (NEXT-VALUE))) (IL:UNINTERRUPTABLY (IL:\\ADDREF FRAME-NAME) (IL:REPLACE (IL:FNHEADER IL:\#FRAMENAME) IL:OF RAW-CODE IL:WITH FRAME-NAME))) (LET ((NLOCALS (IL:BIN STREAM)) (NFREEVARS (IL:BIN STREAM))) (IL:REPLACE (IL:FNHEADER IL:NLOCALS) IL:OF RAW-CODE IL:WITH NLOCALS) (IL:REPLACE (IL:FNHEADER IL:PV) IL:OF RAW-CODE IL:WITH (1- (CEILING (+ NLOCALS NFREEVARS) IL:CELLSPERQUAD)))) (IL:REPLACE (IL:FNHEADER IL:ARGTYPE) IL:OF RAW-CODE IL:WITH (IL:BIN STREAM)) (IL:REPLACE (IL:FNHEADER IL:NA) IL:OF RAW-CODE IL:WITH (NEXT-VALUE)) (SETF CLOSURE-INFO (NEXT-VALUE)) (IL:REPLACE (IL:FNHEADER IL:CLOSUREP) IL:OF RAW-CODE IL:WITH (EQ CLOSURE-INFO :CLOSURE)) (IL:REPLACE (IL:FNHEADER IL:FIXED) IL:OF RAW-CODE IL:WITH T) (IL:* IL:|;;| "Fill in debugging info. It goes into the spare cell just before the code: it's -3 instead of -bytespercell to right-justify the pointer in the cell. Aren't you glad I told you this?") (D-ASSEM:FIXUP-PTR RAW-CODE (- START-PC (IL:BIG-VMEM-CODE 4 3)) (NEXT-VALUE)) (IL:* IL:|;;| "Do fixups") (DO ((FN-FIXUP-COUNT (NEXT-VALUE)) (I 0 (1+ I)) OFFSET VALUE) ((>= I FN-FIXUP-COUNT)) (SETF OFFSET (NEXT-VALUE)) (SETF VALUE (NEXT-VALUE)) (D-ASSEM:FIXUP-SYMBOL RAW-CODE (+ START-PC OFFSET) VALUE)) (DO ((SYM-FIXUP-COUNT (NEXT-VALUE)) (I 0 (1+ I)) OFFSET VALUE) ((>= I SYM-FIXUP-COUNT)) (SETF OFFSET (NEXT-VALUE)) (SETF VALUE (NEXT-VALUE)) (D-ASSEM:FIXUP-SYMBOL RAW-CODE (+ START-PC OFFSET) VALUE)) (DO ((LIT-FIXUP-COUNT (NEXT-VALUE)) (I 0 (1+ I)) OFFSET VALUE) ((>= I LIT-FIXUP-COUNT)) (SETF OFFSET (NEXT-VALUE)) (SETF VALUE (NEXT-VALUE)) (D-ASSEM:FIXUP-PTR RAW-CODE (+ START-PC OFFSET) VALUE)) (DO ((TYPE-FIXUP-COUNT (NEXT-VALUE)) (I 0 (1+ I)) OFFSET VALUE) ((>= I TYPE-FIXUP-COUNT)) (SETF OFFSET (NEXT-VALUE)) (SETF VALUE (NEXT-VALUE)) (D-ASSEM:FIXUP-WORD RAW-CODE (+ START-PC OFFSET) (IL:\\RESOLVE.TYPENUMBER VALUE))) (IL:* IL:|;;| "Finally, wrap this up in a closure-object if requested.") (IF (EQ CLOSURE-INFO :FUNCTION) (IL:MAKE-COMPILED-CLOSURE RAW-CODE NIL) RAW-CODE))) (DEFOP FASL-LOCAL-FN-FIXUPS (151) (LET ((PASS-THROUGH (NEXT-VALUE))) (IL:* IL:\;  "This will typically correspond to the DCODE that had the fixups, but can be anything.") (DO ((FIXUP-COUNT (NEXT-VALUE)) (I 0 (IL:ADD1 I)) CODE-TO-FIX OFFSET VALUE) ((IL:IGEQ I FIXUP-COUNT) PASS-THROUGH) (SETF CODE-TO-FIX (NEXT-VALUE) OFFSET (NEXT-VALUE) VALUE (NEXT-VALUE)) (MACROLET ((GET-CODE (THING) (XCL:ONCE-ONLY (THING) `(IF (TYPEP ,THING 'IL:COMPILED-CLOSURE) (IL:FETCH (IL:COMPILED-CLOSURE IL:FNHEADER) IL:OF ,THING) ,THING)))) (IF (EQ CODE-TO-FIX VALUE) (LET ((CODE (GET-CODE CODE-TO-FIX))) (D-ASSEM:FIXUP-PTR-NO-REF CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER IL:STARTPC) IL:OF CODE) OFFSET) VALUE)) (LET ((CODE (GET-CODE CODE-TO-FIX))) (D-ASSEM:FIXUP-PTR CODE (IL:IPLUS (IL:FETCH (IL:FNHEADER IL:STARTPC) IL:OF CODE) OFFSET) VALUE))))))) (DEFOP FASL-TABLE-STORE (152) (STORE-VALUE (NEXT-VALUE))) (DEFOP FASL-TABLE-FETCH (153) (FETCH-VALUE (NEXT-VALUE))) (DEFOP FASL-VERIFY-TABLE-SIZE (154) (LET ((EXPECTED (NEXT-VALUE))) (OR (EQL EXPECTED (XCL:VECTOR-LENGTH *VALUE-TABLE*)) (ERROR 'INCONSISTENT-TABLE :TABLE *VALUE-TABLE* :EXPECTED EXPECTED)))) (DEFOP FASL-EVAL (155) (EVAL (NEXT-VALUE))) (DEFOP FASL-FLOAT32 (132) (LET ((RESULT (IL:NCREATE 'IL:FLOATP))) (IL:\\BINS STREAM RESULT 0 4) RESULT)) (DEFOP FASL-SETF-SYMBOL-FUNCTION (156) (SETF (SYMBOL-FUNCTION (NEXT-VALUE)) (NEXT-VALUE))) (DEFOP FASL-FUNCALL (157) (FUNCALL (NEXT-VALUE))) (DEFOP FASL-BITMAP16 (158) (IL:* IL:|;;;| "Load an Interlisp BITMAP.") (LET* ((WIDTH (NEXT-VALUE)) (HEIGHT (NEXT-VALUE)) (BITS-PER-PIXEL (NEXT-VALUE)) (BITMAP (IL:BITMAPCREATE WIDTH HEIGHT BITS-PER-PIXEL)) (BASE (IL:FETCH (IL:BITMAP IL:BITMAPBASE) IL:OF BITMAP))) (IL:\\BINS STREAM BASE 0 (* 2 HEIGHT (CEILING (* WIDTH BITS-PER-PIXEL) 16))) BITMAP)) (DEFOP FASL-STRUCTURE (159) (IL:* IL:|;;;| "Load a DEFSTRUCT-defined structure instance.") (IL:CREATE-STRUCTURE (CONS (NEXT-VALUE) (NEXT-VALUE)))) (XCL:DEFOPTIMIZER FIXUP-NTOFFSET (RAW-CODE OFFSET TYPE VALUE &ENVIRONMENT IL:ENV) (IL:* IL:|;;| "Do the fixups for a name-table offset entry, given a code block, the NTOffset's offset within the codeblock, and the variable type and FVAR offset.") (COND ((IL:FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE IL:ENV) ) (IL:* IL:|;;|  "3-byte case; the nametable entry is a full cell.") `(PROGN (D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET ,TYPE) (D-ASSEM:FIXUP-WORD ,RAW-CODE (+ ,OFFSET IL:BYTESPERWORD) ,VALUE))) (T (IL:* IL:|;;| "Old nametable case, it's just a word.") `(D-ASSEM:FIXUP-WORD ,RAW-CODE ,OFFSET (IL:IPLUS ,TYPE ,VALUE))))) (IL:* IL:|;;| "make sure there's some print function around so that you can load early.") (IL:MOVD? 'IL:PRIN1 'PRINC) (IL:MOVD? 'IL:TERPRI 'TERPRI) (IL:* IL:|;;| "ADDITION TO FILEDATE so it will handle FASL files as well as LCOMs and source files." ) (IL:DEFINEQ (IL:FASL-FILEDATE (IL:LAMBDA (STREAM IL:CFLG) (IL:* IL:\; "Edited 17-Feb-89 11:25 by jds") (IL:* IL:\;  "CFLG IS T FOR COMPILED FILES") (IL:* IL:|;;|  "If STREAM is open on a FASL file, returns the FILEDATE for that file. Otherwise, returns NIL.") (IL:* IL:|;;| "Used in FILEDATE; kept a separate function because FILEDATE is defined before the FASL package is loaded.") (COND ((EQL (IL:BIN STREAM) SIGNATURE) (IL:* IL:\; " \"Aha, a Dfasl file\"") (IL:SETFILEPTR STREAM 0) (IL:SETQ IL:VALUE (CONVERT-FASL-DATE (PROCESS-FILE STREAM :TEXT-FN #'(IL:LAMBDA (IL:X) (IL:RETFROM 'PROCESS-FILE IL:X)) :ITEM-FN 'IL:NILL) IL:CFLG)))))) (CONVERT-FASL-DATE (IL:LAMBDA (IL:DATESTRING IL:CFLG) (IL:* IL:\; "Edited 17-Apr-2018 07:55 by rmk:") (IL:* IL:\;  "Edited 23-Jan-89 13:55 by gadener") (IL:* IL:|;;| "CONVERT-FASL-DATE takes the file text info from a DFASL file describing creation dates for source and compiled code and returns either one of these dates, depending on the value of CLFG, in da-mon-yr hr:mn:sc format.") (IL:* IL:|;;| "") (IL:* IL:|;;| "RMK: The SHORT-DATE-STRING has all of the information in the right order, most likely with 4-digit years too. But it seems to have spaces between the day and month and month and year, whereas (DATE) with the default format produces strings with hyphens. It also has comma-space after the year while (DATE) has just space. The month is also spelled out (April instead of Apr). But those differences don't seem to matter to IDATE, which is where comparisons should be done. I commented out all the junky code.") (LET* ((IL:DATE-POS (IF IL:CFLG (IL:STRPOS "Source file created" IL:DATESTRING) (IL:STRPOS "FASL file created" IL:DATESTRING))) (IL:BEGIN-POS (IL:STRPOS "," IL:DATESTRING IL:DATE-POS)) (IL:END-POS (IL:STRPOS "." IL:DATESTRING IL:DATE-POS)) (IL:SHORT-DATE-STRING (IL:SUBSTRING IL:DATESTRING (+ IL:BEGIN-POS 2) (IL:SUB1 IL:END-POS))) IL:TEMP-DATE IL:DATE-RESULT) (IL:* IL:|;;| "(SETQ TEMP-DATE (CONCAT (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING))) (if (EQUAL \" \" (SUBSTRING TEMP-DATE 2)) then (SETQ TEMP-DATE (CONCAT \" \" (GNC TEMP-DATE))) else (GNC SHORT-DATE-STRING)) (SETQ DATE-RESULT (CONCAT TEMP-DATE \"-\" (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING) (GNC SHORT-DATE-STRING) \"-\")) (SETQ TEMP-DATE (SUBSTRING SHORT-DATE-STRING (PLUS 3 (STRPOS \" \" SHORT-DATE-STRING)))) (SETQ DATE-RESULT (CONCAT DATE-RESULT (GNC TEMP-DATE) (GNC TEMP-DATE) \" \")) (GNC TEMP-DATE) (GNC TEMP-DATE) (if (LESSP (STRPOS \":\" TEMP-DATE) 3) then (CONCAT DATE-RESULT \"0\" TEMP-DATE) else (CONCAT DATE-RESULT TEMP-DATE))") (IL:* IL:\; "") IL:SHORT-DATE-STRING))) ) (IL:* IL:|;;| "Arrange for the correct compiler and makefile environment") (IL:PUTPROPS IL:FASLOAD IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:FASLOAD IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "FASL")) (IL:PUTPROPS IL:FASLOAD IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 2018)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (6504 6920 (TABLE-STATS 6504 . 6920)) (7082 7361 (MAKE-OPTABLE 7082 . 7361)) (7363 8006 (DEFINE-OPCODE-RANGE 7363 . 8006)) (8008 8558 (DEFINE-SINGLE-OPCODE 8008 . 8558)) (8560 8818 ( ADD-OP-TRANSLATION 8560 . 8818)) (8820 9184 (OPCODE-SEQUENCE 8820 . 9184)) (10778 10944 ( FASL-END-OF-BLOCK 10778 . 10944)) (10946 11067 (FASL-EXTENDED 10946 . 11067)) (11069 11194 (SETESCAPE 11069 . 11194)) (11196 11292 (UNIMPLEMENTED-OPCODE 11196 . 11292)) (11653 13003 (PROCESS-FILE 11653 . 13003)) (13005 13235 (PROCESS-SEGMENT 13005 . 13235)) (13340 13652 (CHECK-VERSION 13340 . 13652)) ( 13654 13942 (READ-TEXT 13654 . 13942)) (13944 14446 (PROCESS-BLOCK 13944 . 14446)) (14448 14587 ( SKIP-TEXT 14448 . 14587)) (14642 15249 (DO-OP 14642 . 15249)) (15251 15352 (NEW-VALUE-TABLE 15251 . 15352)) (15354 15453 (CLEAR-TABLE 15354 . 15453)) (15455 15709 (STORE-VALUE 15455 . 15709)) (15711 15796 (FETCH-VALUE 15711 . 15796)) (15798 16326 (COLLECT-LIST 15798 . 16326)) (31293 34876 ( IL:FASL-FILEDATE 31306 . 32467) (CONVERT-FASL-DATE 32469 . 34874))))) IL:STOP \ No newline at end of file diff --git a/sources/FILEIO b/sources/FILEIO new file mode 100644 index 00000000..72d36e63 --- /dev/null +++ b/sources/FILEIO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Aug-2020 16:43:46" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;7 180720 changes to%: (FNS \EXTERNALFORMAT PUTSTREAMPROP GETSTREAMPROP) previous date%: " 3-Aug-2020 00:04:28" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEIO.;6) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1999, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILEIOCOMS) (RPAQQ FILEIOCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) FILEIO) (* ;; "Device independent IO. This file is used by VAX") (COMS (* ;; "STREAM, FDEV declarations") (DECLARE%: FIRST DOCOPY (* ;; "The microcode relies on STREAM being of a particular type, viz. the first type declared in the initial loadup (after VMEMPAGEP)") (INITRECORDS STREAM)) (SYSRECORDS STREAM) (DECLARE%: DONTCOPY (EXPORT (RECORDS STREAM) (MACROS STREAMOP) (CONSTANTS AppendBit NoBits ReadBit WriteBit (OutputBits (LOGOR AppendBit WriteBit)) (BothBits (LOGOR ReadBit OutputBits)) \NORUNCODE) (MACROS TestMasked APPENDABLE APPENDONLY DIRTYABLE OPENED OVERWRITEABLE READABLE READONLY WRITEABLE) (MACROS \RUNCODED) (CONSTANTS * EOLCONVENTIONS))) (FNS STREAMPROP GETSTREAMPROP PUTSTREAMPROP STREAMP) [COMS (* ; "make streams print pretty") (FNS \DEFPRINT.BY.NAME \STREAM.DEFPRINT \FDEV.DEFPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT] (COMS (* ;  "Needed because of STREAM initialization") (INITVARS (FILELINELENGTH 102) (\STREAM.DEFAULT.MAXBUFFERS 3))) (FNS \GETACCESS \SETACCESS) (DECLARE%: DONTCOPY (EXPORT (MACROS FDEVOP \RECOGNIZE-HACK) (RECORDS FDEV FILEGENOBJ))) (INITRECORDS FDEV) (SYSRECORDS FDEV)) [COMS (* ;  "EXTERNALFORMAT declaration and related functions") (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (RECORDS EXTERNALFORMAT))) (INITRECORDS EXTERNALFORMAT) (SYSRECORDS EXTERNALFORMAT) (FNS \INSTALL.EXTERNALFORMAT \REMOVE.EXTERNALFORMAT \GET.EXTERNALFORMAT.FROM.NAME \EXTERNALFORMAT) (INITVARS (*SUPPORTED-EXTERNALFORMATS* '(:XCCS :DEFAULT)) (*DEFAULT-EXTERNAL-FORMATS*) (*EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *DEFAULT-EXTERNAL-FORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*) (FNS \CREATE.JIS.EXTERNALFORMAT \CREATE.SHIFTJIS.EXTERNALFORMAT \CREATE.EUC.EXTERNALFORMAT \CREATE.THROUGH.EXTERNALFORMAT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT] (COMS (* ; "Device operations") (FNS \DEFINEDEVICE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME \REMOVEDEVICE \REMOVEDEVICE.NAMES) (FNS \CLOSEFILE \DELETEFILE \DEVICEEVENT \GENERATEFILES \GENERATENEXTFILE \GENERATEFILEINFO \GETFILENAME \GENERIC.READCCODE \GENERIC.OUTFILEP \OPENFILE \DO.PARAMS.AT.OPEN \RENAMEFILE \REVALIDATEFILE \PAGED.REVALIDATEFILELST \PAGED.REVALIDATEFILES \PAGED.REVALIDATEFILE \BUFFERED.REVALIDATEFILE \BUFFERED.REVALIDATEFILELST \PRINT-REVALIDATION-RESULT \TRUNCATEFILE \FILE-CONFLICT) (COMS (* ; "Generic enumerator") (FNS \GENERATENOFILES \NULLFILEGENERATOR \NOFILESNEXTFILEFN \NOFILESINFOFN) (DECLARE%: DONTCOPY (RECORDS NOFILEGENSTATE))) (FNS \FILE.NOT.OPEN \FILE.WONT.OPEN \ILLEGAL.DEVICEOP \IS.NOT.RANDACCESSP \STREAM.NOT.OPEN) (ADDVARS (\FILEDEVICES) (\FILEDEVICENAMES) (\DEVICENAMETODEVICE)) (COMS (* ; "Device instances") (FNS \FDEVINSTANCE) (MACROS \INHERITFDEVOP.D \INHERITFDEVOP.S)) (INITVARS (LOGINHOST/DIR '{DSK}) (\CONNECTED.DIRECTORY '{DSK})) (GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (COMS (* ; "Directory defaulting") (FNS CNDIR DIRECTORYNAME DIRECTORYNAMEP HOSTNAMEP \ADD.CONNECTED.DIR)) [COMS (* ; "Binary I/O Public functions") (FNS \BACKFILEPTR \BACKPEEKBIN \BACKBIN BIN \BIN \BINS BOUT \BOUT \BOUTS COPYBYTES COPYCHARS COPYFILE \COPYOPENFILE \INFER.FILE.TYPE EOFP FORCEOUTPUT \FLUSH.OPEN.STREAMS CHARSET ACCESS-CHARSET GETEOFPTR GETFILEINFO \TYPE.FROM.FILETYPE \FILETYPE.FROM.TYPE GETFILEPTR SETFILEINFO SETFILEPTR BOUT16 BIN16) (PROP (DOPCODE) BOUT) (* ; "Generic functions") (FNS \GENERIC.BINS \GENERIC.BOUTS \GENERIC.RENAMEFILE \GENERIC.OPENP \GENERIC.READP \GENERIC.CHARSET) (FNS \MAP-OPEN-STREAMS) (VARS FILING.TYPES) (GLOBALVARS FILING.TYPES) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \OUTCHAR \DEVICE-OPEN-STREAMS \CONVERT-PATHNAME) (OPTIMIZERS ACCESS-CHARSET))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAPC '((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS)) (FUNCTION (LAMBDA (PAIR) (PUTD (CADR PAIR) (GETD (CAR PAIR)) T] (COMS (* ; "Internal functions") (FNS \EOF.ACTION \EOSERROR \GETEOFPTR \INCFILEPTR \PEEKBIN \SETCLOSEDFILELENGTH \SETEOFPTR \SETFILEPTR) (FNS \FIXPOUT \FIXPIN) (DECLARE%: DONTCOPY (EXPORT (MACROS \DECFILEPTR \GETFILEPTR \SIGNEDWIN \SIGNEDWOUT \WIN \WOUT \BINS \BOUTS \EOFP SIZE.FROM.LENGTH) (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) WordsPerPage) [CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30] (RECORDS BYTEPTR)) (CONSTANTS MaxChar))) (COMS (* ; "Buffered IO") (FNS \BUFFERED.BIN \BUFFERED.PEEKBIN \BUFFERED.BOUT \BUFFERED.BINS \BUFFERED.BOUTS \BUFFERED.COPYBYTES)) [COMS (* ; "NULL device") (FNS \NULLDEVICE \NULL.OPENFILE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NULLDEVICE] (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP]) (PUTPROPS FILEIO FILETYPE :BCOMPL) (PUTPROPS FILEIO MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (* ;; "Device independent IO. This file is used by VAX") (* ;; "STREAM, FDEV declarations") (DECLARE%: FIRST DOCOPY (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG (BITS 3) POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER FLAG (BITS 2) FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (BITS . 18)) (STREAM 2 POINTER) (STREAM 4 (BITS . 7)) (STREAM 4 (BITS . 135)) (STREAM 5 (BITS . 15)) (STREAM 6 (BITS . 15)) (STREAM 7 (BITS . 15)) (STREAM 8 (FLAGBITS . 0)) (STREAM 8 (FLAGBITS . 16)) (STREAM 8 (FLAGBITS . 32)) (STREAM 8 (FLAGBITS . 48)) (STREAM 8 POINTER) (STREAM 10 (FLAGBITS . 0)) (STREAM 10 (FLAGBITS . 16)) (STREAM 10 (FLAGBITS . 32)) (STREAM 10 (FLAGBITS . 48)) (STREAM 10 POINTER) (STREAM 12 (FLAGBITS . 0)) (STREAM 12 (BITS . 17)) (STREAM 12 (FLAGBITS . 48)) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 (BITS . 15)) (STREAM 19 (BITS . 15)) (STREAM 20 POINTER) (STREAM 22 POINTER) (STREAM 24 POINTER) (STREAM 26 POINTER) (STREAM 28 POINTER) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 32 (BITS . 15)) (STREAM 33 (BITS . 15)) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 POINTER) (STREAM 50 POINTER) (STREAM 52 (BITS . 15)) (STREAM 53 (BITS . 15)) (STREAM 54 POINTER)) '56) ) (ADDTOVAR SYSTEMRECLST (DATATYPE STREAM ((COFFSET WORD) (CBUFSIZE WORD) (PEEKEDCHARP FLAG) (ACCESSBITS BITS 3) (CBUFPTR POINTER) (BYTESIZE BYTE) (CHARSET BYTE) (PEEKEDCHAR WORD) (CHARPOSITION WORD) (CBUFMAXSIZE WORD) (NONDEFAULTDATEFLG FLAG) (REVALIDATEFLG FLAG) (MULTIBUFFERHINT FLAG) (USERCLOSEABLE FLAG) (FULLFILENAME POINTER) (BINABLE FLAG) (BOUTABLE FLAG) (EXTENDABLE FLAG) (CBUFDIRTY FLAG) (DEVICE POINTER) (USERVISIBLE FLAG) (EOLCONVENTION BITS 2) (NOTXCCS FLAG) (VALIDATION POINTER) (CPAGE POINTER) (EPAGE POINTER) (EOFFSET WORD) (LINELENGTH WORD) (F1 POINTER) (F2 POINTER) (F3 POINTER) (F4 POINTER) (F5 POINTER) (FW6 WORD) (FW7 WORD) (FW8 WORD) (FW9 WORD) (F10 POINTER) (STRMBINFN POINTER) (STRMBOUTFN POINTER) (OUTCHARFN POINTER) (ENDOFSTREAMOP POINTER) (OTHERPROPS POINTER) (IMAGEOPS POINTER) (IMAGEDATA POINTER) (BUFFS POINTER) (MAXBUFFERS WORD) (LASTCCODE WORD) (EXTRASTREAMOP POINTER))) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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) 'EXTERNALFORMAT) (LET ((PROPS (ffetch (STREAM OTHERPROPS) of DATUM))) (freplace (STREAM NOTXCCS) of DATUM with T) [COND (PROPS (LISTPUT PROPS 'EXTERNALFORMAT NEWVALUE)) (T (freplace (STREAM OTHERPROPS) of DATUM with (LIST '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) '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 'EXTERNALFORMAT.NAME NAME)) (T (freplace (STREAM OTHERPROPS) of DATUM with (LIST 'EXTERNALFORMAT.NAME NAME] [ACCESSFNS STREAM (INCCODEFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM) 'EXTERNALFORMAT] (AND (type? EXTERNALFORMAT XFMT) (fetch (EXTERNALFORMAT INCCODEFN) of XFMT] [ACCESSFNS STREAM (PEEKCCODEFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM) 'EXTERNALFORMAT] (AND (type? EXTERNALFORMAT XFMT) (fetch (EXTERNALFORMAT PEEKCCODEFN) of XFMT] [ACCESSFNS STREAM (BACKCHARFN (LET [(XFMT (LISTGET (ffetch (STREAM OTHERPROPS) of DATUM) '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) ) (/DECLAREDATATYPE 'STREAM '(WORD WORD FLAG (BITS 3) POINTER BYTE BYTE WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER FLAG (BITS 2) FLAG POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((STREAM 0 (BITS . 15)) (STREAM 1 (BITS . 15)) (STREAM 2 (FLAGBITS . 0)) (STREAM 2 (BITS . 18)) (STREAM 2 POINTER) (STREAM 4 (BITS . 7)) (STREAM 4 (BITS . 135)) (STREAM 5 (BITS . 15)) (STREAM 6 (BITS . 15)) (STREAM 7 (BITS . 15)) (STREAM 8 (FLAGBITS . 0)) (STREAM 8 (FLAGBITS . 16)) (STREAM 8 (FLAGBITS . 32)) (STREAM 8 (FLAGBITS . 48)) (STREAM 8 POINTER) (STREAM 10 (FLAGBITS . 0)) (STREAM 10 (FLAGBITS . 16)) (STREAM 10 (FLAGBITS . 32)) (STREAM 10 (FLAGBITS . 48)) (STREAM 10 POINTER) (STREAM 12 (FLAGBITS . 0)) (STREAM 12 (BITS . 17)) (STREAM 12 (FLAGBITS . 48)) (STREAM 12 POINTER) (STREAM 14 POINTER) (STREAM 16 POINTER) (STREAM 18 (BITS . 15)) (STREAM 19 (BITS . 15)) (STREAM 20 POINTER) (STREAM 22 POINTER) (STREAM 24 POINTER) (STREAM 26 POINTER) (STREAM 28 POINTER) (STREAM 30 (BITS . 15)) (STREAM 31 (BITS . 15)) (STREAM 32 (BITS . 15)) (STREAM 33 (BITS . 15)) (STREAM 34 POINTER) (STREAM 36 POINTER) (STREAM 38 POINTER) (STREAM 40 POINTER) (STREAM 42 POINTER) (STREAM 44 POINTER) (STREAM 46 POINTER) (STREAM 48 POINTER) (STREAM 50 POINTER) (STREAM 52 (BITS . 15)) (STREAM 53 (BITS . 15)) (STREAM 54 POINTER)) '56) (DECLARE%: EVAL@COMPILE (PUTPROPS STREAMOP MACRO [ARGS (CONS 'SPREADAPPLY* (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) 'QUOTE) (LIST 'fetch (CADAR ARGS) 'of (CADR ARGS))) (T (HELP "STREAMOP - OPNAME not quoted:" ARGS)) ) (CDDR ARGS]) ) (DECLARE%: EVAL@COMPILE (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) ) (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (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))) (DECLARE%: EVAL@COMPILE (RPAQQ CR.EOLC 0) (RPAQQ LF.EOLC 1) (RPAQQ CRLF.EOLC 2) (CONSTANTS (CR.EOLC 0) (LF.EOLC 1) (CRLF.EOLC 2)) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (STREAMPROP [LAMBDA X (* rda%: "22-Aug-84 14:24") (* ;; "general top level entry for both fetching and setting stream properties.") (COND ((IGREATERP X 2) (PUTSTREAMPROP (ARG X 1) (ARG X 2) (ARG X 3))) ((EQ X 2) (GETSTREAMPROP (ARG X 1) (ARG X 2))) (T (\ILLEGAL.ARG NIL]) (GETSTREAMPROP [LAMBDA (STREAM PROP) (* ; "Edited 5-Aug-2020 16:42 by rmk:") (* rda%: "22-Aug-84 16:17") (IF (EQ PROP 'EXTERNALFORMAT) THEN (\EXTERNALFORMAT STREAM) ELSE (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) PROP]) (PUTSTREAMPROP [LAMBDA (STREAM PROP VALUE) (* ; "Edited 5-Aug-2020 16:42 by rmk:") (* rda%: "22-Aug-84 16:11") (IF (EQ PROP 'EXTERNALFORMAT) THEN (* ;; "Return the old name (=VALUE), not the format datum. Better design: the format should have it's name, and not have name as a separate property.") (PROG1 (\EXTERNALFORMAT STREAM NIL) (AND VALUE (\EXTERNALFORMAT STREAM VALUE))) ELSE (PROG ((OLDDATA (fetch OTHERPROPS of STREAM)) OLDVALUE) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* ; "Remove the property") (COND ((EQ (CAR OLDDATA) PROP) (replace OTHERPROPS of STREAM with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN] OLDVALUE) (VALUE (replace OTHERPROPS of STREAM with (LIST PROP VALUE)) (* ; "know old value is NIL") NIL]) (STREAMP [LAMBDA (X) (* rmk%: "14-OCT-83 14:35") (AND (type? STREAM X) X]) ) (* ; "make streams print pretty") (DEFINEQ (\DEFPRINT.BY.NAME [LAMBDA (OBJECT STREAM NAME TYPENAME) (* ; "Edited 8-May-87 15:53 by bvm:") (* ;; "Print an object using its name, for example, #. NAME is the object's name (or NIL if this one happens to be nameless), TYPENAME is a string giving the generic name you want to appear in front, e.g., %"FDev%"") [.SPACECHECK. STREAM (+ (NCHARS TYPENAME) (PROGN (* ;  "Longest address is `< /177,177777>'") 14) (COND (NAME (NCHARS NAME)) (T 0] (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\OUTCHAR STREAM (CHARCODE <)) (\SOUT (MKSTRING TYPENAME) STREAM) (COND (NAME (\OUTCHAR STREAM (CHARCODE SPACE)) (\SOUT (MKSTRING NAME) STREAM))) (\OUTCHAR STREAM (CHARCODE /)) (\PRINTADDR OBJECT STREAM) (\OUTCHAR STREAM (CHARCODE >)) T]) (\STREAM.DEFPRINT [LAMBDA (STRM OUTSTREAM) (* ; "Edited 19-Aug-88 14:01 by bvm") (LET ((TYPE (SELECTC (fetch ACCESSBITS of STRM) (ReadBit "Input") (OutputBits "Output") (BothBits "IO") (AppendBit "Append") "Closed"))) (\DEFPRINT.BY.NAME STRM OUTSTREAM NIL (COND ((fetch (STREAM NAMEDP) of STRM) (* ; "Use file name") (CONCAT TYPE " Stream on " (fetch (STREAM FULLFILENAME) of STRM))) (T (* ; "Name the device") (CONCAT TYPE " " [CL:STRING-CAPITALIZE (STRING (fetch (FDEV DEVICENAME) of (fetch DEVICE of STRM] " Stream"]) (\FDEV.DEFPRINT [LAMBDA (DEV STREAM) (* ; "Edited 8-May-87 15:55 by bvm") (* ;; "Print device using its name, for example, #") (\DEFPRINT.BY.NAME DEV STREAM (fetch (FDEV DEVICENAME) of DEV) "FDev"]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'STREAM (FUNCTION \STREAM.DEFPRINT)) (DEFPRINT 'FDEV (FUNCTION \FDEV.DEFPRINT)) ) (* ; "Needed because of STREAM initialization") (RPAQ? FILELINELENGTH 102) (RPAQ? \STREAM.DEFAULT.MAXBUFFERS 3) (DEFINEQ (\GETACCESS [LAMBDA (STREAM) (* bvm%: "26-DEC-81 15:43") (* ;; "Decodes the access bits. The inverse of the encoding in \SETACCESS. Ugly but no less so than the machinery to do it elegantly.") (SELECTC (fetch ACCESSBITS of STREAM) (NoBits NIL) (ReadBit 'INPUT) (AppendBit 'APPEND) (OutputBits 'OUTPUT) (BothBits 'BOTH) (SHOULDNT]) (\SETACCESS [LAMBDA (STREAM ACCESS) (* rmk%: " 7-NOV-83 15:02") (* ;; "The setfn for the ACCESS field. Does not assume that streams are initialized with all bits off and \STREAM.NOT.OPEN installed") (UNINTERRUPTABLY (PROG ((DEVICE (fetch DEVICE of STREAM))) (SELECTQ ACCESS (NIL (replace ACCESSBITS of STREAM with NoBits) (* ; "Was open, now closing") (replace BINABLE of STREAM with (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (replace STRMBINFN of STREAM with (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)))) (INPUT (replace ACCESSBITS of STREAM with ReadBit) (* ; "Was closed, now opening") (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BOUTABLE of STREAM with (replace EXTENDABLE of STREAM with NIL))) (APPEND (replace ACCESSBITS of STREAM with AppendBit) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (OUTPUT (replace ACCESSBITS of STREAM with OutputBits) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE)) (replace STRMBINFN of STREAM with (FUNCTION \STREAM.NOT.OPEN)) (replace BINABLE of STREAM with NIL)) (BOTH (replace ACCESSBITS of STREAM with BothBits) (replace BINABLE of STREAM with (fetch FDBINABLE of DEVICE)) (replace BOUTABLE of STREAM with (fetch FDBOUTABLE of DEVICE)) (replace EXTENDABLE of STREAM with (fetch FDEXTENDABLE of DEVICE)) (replace STRMBINFN of STREAM with (fetch BIN of DEVICE)) (replace STRMBOUTFN of STREAM with (fetch BOUT of DEVICE) )) (RAID "Illegal stream access mode")))) ACCESS]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS FDEVOP DMACRO [ARGS (LET ((OPNAME (CAR ARGS)) (METHOD-DEVICE (CADR ARGS)) (TAIL (CDDR ARGS))) (COND [(AND (LISTP OPNAME) (EQ (CAR OPNAME) 'QUOTE)) `(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))) `(if (type? STREAM ,NAME) then ,NAME else (FDEVOP 'GETFILENAME ,DEVICE ,NAME ,RECOG ,DEVICE]) ) (DECLARE%: EVAL@COMPILE (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)) ) (/DECLAREDATATYPE 'FDEV '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FDEV 0 (FLAGBITS . 0)) (FDEV 0 (FLAGBITS . 16)) (FDEV 0 (FLAGBITS . 32)) (FDEV 0 (FLAGBITS . 48)) (FDEV 0 (FLAGBITS . 64)) (FDEV 0 (FLAGBITS . 80)) (FDEV 0 (FLAGBITS . 96)) (FDEV 0 (FLAGBITS . 112)) (FDEV 2 POINTER) (FDEV 2 (FLAGBITS . 0)) (FDEV 2 (FLAGBITS . 16)) (FDEV 2 (FLAGBITS . 32)) (FDEV 2 (FLAGBITS . 48)) (FDEV 4 POINTER) (FDEV 6 POINTER) (FDEV 8 POINTER) (FDEV 10 POINTER) (FDEV 12 POINTER) (FDEV 14 POINTER) (FDEV 16 POINTER) (FDEV 18 POINTER) (FDEV 20 POINTER) (FDEV 22 POINTER) (FDEV 24 POINTER) (FDEV 26 POINTER) (FDEV 28 POINTER) (FDEV 30 POINTER) (FDEV 32 POINTER) (FDEV 34 POINTER) (FDEV 36 POINTER) (FDEV 38 POINTER) (FDEV 40 POINTER) (FDEV 42 POINTER) (FDEV 44 POINTER) (FDEV 46 POINTER) (FDEV 48 POINTER) (FDEV 50 POINTER) (FDEV 52 POINTER) (FDEV 54 POINTER) (FDEV 56 POINTER) (FDEV 58 POINTER) (FDEV 60 POINTER) (FDEV 62 POINTER) (FDEV 64 POINTER) (FDEV 66 POINTER) (FDEV 68 POINTER) (FDEV 70 POINTER) (FDEV 72 POINTER) (FDEV 74 POINTER) (FDEV 76 POINTER) (FDEV 78 POINTER) (FDEV 80 POINTER) (FDEV 82 POINTER) (FDEV 84 POINTER) (FDEV 86 POINTER) (FDEV 88 POINTER) (FDEV 90 POINTER) (FDEV 92 POINTER) (FDEV 94 POINTER) (FDEV 96 POINTER) (FDEV 98 POINTER) (FDEV 100 POINTER) (FDEV 102 POINTER) (FDEV 104 POINTER)) '106) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'FDEV '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FDEV 0 (FLAGBITS . 0)) (FDEV 0 (FLAGBITS . 16)) (FDEV 0 (FLAGBITS . 32)) (FDEV 0 (FLAGBITS . 48)) (FDEV 0 (FLAGBITS . 64)) (FDEV 0 (FLAGBITS . 80)) (FDEV 0 (FLAGBITS . 96)) (FDEV 0 (FLAGBITS . 112)) (FDEV 2 POINTER) (FDEV 2 (FLAGBITS . 0)) (FDEV 2 (FLAGBITS . 16)) (FDEV 2 (FLAGBITS . 32)) (FDEV 2 (FLAGBITS . 48)) (FDEV 4 POINTER) (FDEV 6 POINTER) (FDEV 8 POINTER) (FDEV 10 POINTER) (FDEV 12 POINTER) (FDEV 14 POINTER) (FDEV 16 POINTER) (FDEV 18 POINTER) (FDEV 20 POINTER) (FDEV 22 POINTER) (FDEV 24 POINTER) (FDEV 26 POINTER) (FDEV 28 POINTER) (FDEV 30 POINTER) (FDEV 32 POINTER) (FDEV 34 POINTER) (FDEV 36 POINTER) (FDEV 38 POINTER) (FDEV 40 POINTER) (FDEV 42 POINTER) (FDEV 44 POINTER) (FDEV 46 POINTER) (FDEV 48 POINTER) (FDEV 50 POINTER) (FDEV 52 POINTER) (FDEV 54 POINTER) (FDEV 56 POINTER) (FDEV 58 POINTER) (FDEV 60 POINTER) (FDEV 62 POINTER) (FDEV 64 POINTER) (FDEV 66 POINTER) (FDEV 68 POINTER) (FDEV 70 POINTER) (FDEV 72 POINTER) (FDEV 74 POINTER) (FDEV 76 POINTER) (FDEV 78 POINTER) (FDEV 80 POINTER) (FDEV 82 POINTER) (FDEV 84 POINTER) (FDEV 86 POINTER) (FDEV 88 POINTER) (FDEV 90 POINTER) (FDEV 92 POINTER) (FDEV 94 POINTER) (FDEV 96 POINTER) (FDEV 98 POINTER) (FDEV 100 POINTER) (FDEV 102 POINTER) (FDEV 104 POINTER)) '106) (ADDTOVAR SYSTEMRECLST (DATATYPE FDEV ((RESETABLE FLAG) (RANDOMACCESSP FLAG) (NODIRECTORIES FLAG) (PAGEMAPPED FLAG) (FDBINABLE FLAG) (FDBOUTABLE FLAG) (FDEXTENDABLE FLAG) (BUFFERED FLAG) (DEVICENAME POINTER) (REMOTEP FLAG) (SUBDIRECTORIES FLAG) (INPUT-INDIRECTED FLAG) (OUTPUT-INDIRECTED FLAG) (DEVICEINFO POINTER) (OPENFILELST POINTER) (HOSTNAMEP POINTER) (EVENTFN POINTER) (DIRECTORYNAMEP POINTER) (OPENFILE POINTER) (CLOSEFILE POINTER) (REOPENFILE POINTER) (GETFILENAME POINTER) (DELETEFILE POINTER) (GENERATEFILES POINTER) (RENAMEFILE POINTER) (OPENP POINTER) (REGISTERFILE POINTER) (UNREGISTERFILE POINTER) (FREEPAGECOUNT POINTER) (MAKEDIRECTORY POINTER) (CHECKFILENAME POINTER) (HOSTALIVEP POINTER) (BREAKCONNECTION POINTER) (BIN POINTER) (BOUT POINTER) (PEEKBIN POINTER) (READCHAR POINTER) (WRITECHAR POINTER) (PEEKCHAR POINTER) (UNREADCHAR POINTER) (READP POINTER) (EOFP POINTER) (BLOCKIN POINTER) (BLOCKOUT POINTER) (FORCEOUTPUT POINTER) (GETFILEINFO POINTER) (SETFILEINFO POINTER) (CHARSETFN POINTER) (INPUTSTREAM POINTER) (OUTPUTSTREAM POINTER) (GETFILEPTR POINTER) (GETEOFPTR POINTER) (SETFILEPTR POINTER) (BACKFILEPTR POINTER) (SETEOFPTR POINTER) (LASTC POINTER) (GETNEXTBUFFER POINTER) (RELEASEBUFFER POINTER) (READPAGES POINTER) (WRITEPAGES POINTER) (TRUNCATEFILE POINTER) (WINDOWOPS POINTER) (WINDOWDATA POINTER) (READCHARCODE POINTER))) ) (* ; "EXTERNALFORMAT declaration and related functions") (DECLARE%: DOEVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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) ) (/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER) '((EXTERNALFORMAT 0 (FLAGBITS . 0)) (EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) (EXTERNALFORMAT 6 POINTER)) '8) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'EXTERNALFORMAT '(FLAG (BITS 2) (BITS 1) POINTER POINTER POINTER POINTER) '((EXTERNALFORMAT 0 (FLAGBITS . 0)) (EXTERNALFORMAT 0 (BITS . 17)) (EXTERNALFORMAT 0 (BITS . 48)) (EXTERNALFORMAT 0 POINTER) (EXTERNALFORMAT 2 POINTER) (EXTERNALFORMAT 4 POINTER) (EXTERNALFORMAT 6 POINTER)) '8) (ADDTOVAR SYSTEMRECLST (DATATYPE EXTERNALFORMAT ((EOLVALID FLAG) (EOL BITS 2) (NIL BITS 1) (INCCODEFN POINTER) (PEEKCCODEFN POINTER) (BACKCHARFN POINTER) (FILEOUTCHARFN POINTER))) ) (DEFINEQ (\INSTALL.EXTERNALFORMAT [LAMBDA (NAME EXTERNALFORMAT) (* ; "Edited 26-Feb-91 17:33 by nm") (* ;;; "Install an external format vector, giving it the name NAME. EXTERNALFORMAT is an instance of the datatype EXTERNALFORMAT. *SUPPORTED-EXTERNALFORMATS* contains all installed external formats. *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* maps a name int its external format.") (DECLARE (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (COND ((type? EXTERNALFORMAT EXTERNALFORMAT) (LET (ENTRY) [SETQ NAME (COND ((LITATOM NAME) NAME) (T (MKATOM NAME] (UNINTERRUPTABLY [COND ((SETQ ENTRY (FASSOC NAME *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (RPLACD ENTRY EXTERNALFORMAT)) (T (pushnew *SUPPORTED-EXTERNALFORMATS* NAME) (push *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* (CONS NAME EXTERNALFORMAT] NAME))) (T (ERROR "INVALID EXTERNALFORMAT " EXTERNALFORMAT]) (\REMOVE.EXTERNALFORMAT [LAMBDA (EXTERNALFORMAT) (* ; "Edited 26-Feb-91 17:34 by nm") (* ;;; "Removes externalformat EXTERNALFORMAT and association between any of its name and EXTERNALFORMAT.") (DECLARE (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (LET (ENTRY) [COND ((SETQ ENTRY (CL:RASSOC EXTERNALFORMAT *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (UNINTERRUPTABLY (SETQ *SUPPORTED-EXTERNALFORMATS* (DREMOVE (CAR ENTRY) *SUPPORTED-EXTERNALFORMATS*)) (SETQ *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* (DREMOVE ENTRY *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* )))] EXTERNALFORMAT]) (\GET.EXTERNALFORMAT.FROM.NAME [LAMBDA (NAME) (DECLARE (GLOBALVARS *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*)) (* ; "Edited 26-Feb-91 17:33 by nm") [SETQ NAME (COND ((LITATOM NAME) NAME) (T (MKATOM NAME] (CDR (FASSOC NAME *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*]) (\EXTERNALFORMAT [LAMBDA (STREAM NEWVALUE) (* ; "Edited 5-Aug-2020 16:32 by rmk:") (* ; "Edited 26-Feb-91 13:20 by nm") (* ;;; "If NEWVALUE is nil, just returns the current external format name of STREAM. If NEWVALUE is supplied, the external format of STREAM is set to the external format named NEWVALUE.") (* ;;; "RMK July 2020: Added interface for per-device default external format. \DO.PARAMS.AT.OPEN will make that call even if it is not specified from the open.") (\DTEST STREAM 'STREAM) (CL:WHEN (EQ NEWVALUE :DEFAULT) (SETQ NEWVALUE (OR (CADR (ASSOC (FETCH DEVICENAME OF (FETCH DEVICE OF STREAM) ) *DEFAULT-EXTERNAL-FORMATS*)) :XCCS))) (* ;; "The accessfn for replacing EXTERNALFORMAT sets NOTXCCS to NIL. If we don't want to make that more general, we don't want to create and store an explicit :XCCS format, since that would flip the bit. But it is OK to store the name. Also, STREAMPROP is fixed to call \EXTERNALFORMAT to set the property EXTERNALFORMAT, to export a user-level way of manipulating this.") (COND [NEWVALUE (COND ((EQ NEWVALUE :XCCS) (freplace EXTERNALFORMAT.NAME of STREAM with :XCCS) (freplace (STREAM NOTXCCS) of STREAM with NIL)) [(FMEMB NEWVALUE *SUPPORTED-EXTERNALFORMATS*) (freplace EXTERNALFORMAT.NAME of STREAM with NEWVALUE) (freplace EXTERNALFORMAT of STREAM with (\DTEST (  \GET.EXTERNALFORMAT.FROM.NAME NEWVALUE) 'EXTERNALFORMAT] (T (ERROR NEWVALUE "INVALID EXTERNALFORMAT " NEWVALUE] (T (ffetch EXTERNALFORMAT.NAME of STREAM]) ) (RPAQ? *SUPPORTED-EXTERNALFORMATS* '(:XCCS :DEFAULT)) (RPAQ? *DEFAULT-EXTERNAL-FORMATS* ) (RPAQ? *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *SUPPORTED-EXTERNALFORMATS* *DEFAULT-EXTERNAL-FORMATS* *EXTERNALFORMAT-NAME-TO-EXTERNALFORMAT*) ) (DEFINEQ (\CREATE.JIS.EXTERNALFORMAT [LAMBDA NIL (* ; "Edited 25-Feb-91 17:21 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :JIS as its name.") (LET [(XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \JISIN) PEEKCCODEFN _ (FUNCTION \JISPEEK) BACKCHARFN _ (FUNCTION \BACKJISCHAR) FILEOUTCHARFN _ (FUNCTION \JISFILEOUTCHARFN] (\INSTALL.EXTERNALFORMAT :JIS XFMT]) (\CREATE.SHIFTJIS.EXTERNALFORMAT [LAMBDA NIL (* ; "Edited 25-Feb-91 18:15 by nm") (* ;;; "Create two instances of EXTERNALFORMAT datatype and install them with :W-MS and :MS as their names respectively. :MS have to change the end of line convention to CRLF.") (LET ((XFMT1 (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \SHIFTJISIN) PEEKCCODEFN _ (FUNCTION \SHIFTJISPEEK) BACKCHARFN _ (FUNCTION \BACKSHIFTJISCHAR) FILEOUTCHARFN _ (FUNCTION \SHIFTJISFILEOUTCHARFN))) (XFMT2 (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \SHIFTJISIN) PEEKCCODEFN _ (FUNCTION \SHIFTJISPEEK) BACKCHARFN _ (FUNCTION \BACKSHIFTJISCHAR) FILEOUTCHARFN _ (FUNCTION \SHIFTJISFILEOUTCHARFN) EOLVALID _ T EOL _ CRLF.EOLC))) (\INSTALL.EXTERNALFORMAT :W-MS XFMT1) (\INSTALL.EXTERNALFORMAT :MS XFMT2]) (\CREATE.EUC.EXTERNALFORMAT [LAMBDA NIL (* ; "Edited 25-Feb-91 17:27 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :EUC as its name.") (LET [(XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \EUCIN) PEEKCCODEFN _ (FUNCTION \EUCPEEK) BACKCHARFN _ (FUNCTION \BACKEUCCHAR) FILEOUTCHARFN _ (FUNCTION \EUCFILEOUTCHARFN] (\INSTALL.EXTERNALFORMAT :EUC XFMT]) (\CREATE.THROUGH.EXTERNALFORMAT [LAMBDA NIL (* ; "Edited 26-Feb-91 13:33 by nm") (* ;;; "Create an instance of EXTERNALFORMAT datatype and install it with :THROUGH as its name. EOL is adjusted to CR so as not to do any eol conversion on this stream.") (LET ((XFMT (create EXTERNALFORMAT INCCODEFN _ (FUNCTION \THROUGHIN) PEEKCCODEFN _ (FUNCTION \THROUGHPEEK) BACKCHARFN _ (FUNCTION \BACKTHROUGHCHAR) FILEOUTCHARFN _ (FUNCTION \THROUGHFILEOUTCHARFN) EOLVALID _ T EOL _ CR.EOLC))) (\INSTALL.EXTERNALFORMAT :THROUGH XFMT]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\CREATE.JIS.EXTERNALFORMAT) (\CREATE.SHIFTJIS.EXTERNALFORMAT) (\CREATE.EUC.EXTERNALFORMAT) (\CREATE.THROUGH.EXTERNALFORMAT) ) (* ; "Device operations") (DEFINEQ (\DEFINEDEVICE [LAMBDA (NAME DEV) (* bvm%: " 5-APR-83 15:33") (* ;; "NIL DEV removes any device associated with NAME. NIL NAME simply adds the device without associating a name with it. This is useful for getting its EVENTFN invoked. A litatom DEV makes NAME be a synonym for the device currently named DEV --- \FILEDEVICES contains each device only once, \FILEDEVICENAMES contains each name device/host name only once (for spelling correction), and \DEVICENAMETODEVICE maps a name into its device.") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (SETQ NAME (U-CASE NAME)) (* ;  "Use upper-case canonical device names") RETRY (COND [(NULL DEV) (COND ((SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE)) (SETQ \FILEDEVICENAMES (DREMOVE NAME \FILEDEVICENAMES)))] [(type? FDEV DEV) (SETQ TEMP (FASSOC NAME \DEVICENAMETODEVICE)) (UNINTERRUPTABLY (COND ((NOT (FMEMB DEV \FILEDEVICES)) [COND (TEMP (SETQ \FILEDEVICES (DREMOVE (CDR TEMP) \FILEDEVICES] (* ;  "Devices are stored in inverse order of their definition, for proper EVENTFN ordering.") (push \FILEDEVICES DEV))) (COND (NAME (pushnew \FILEDEVICENAMES NAME) (RPLACD [OR TEMP (CAR (push \DEVICENAMETODEVICE (CONS NAME] DEV))))] ([AND (LITATOM DEV) (SETQ TEMP (CDR (FASSOC (U-CASE DEV) \DEVICENAMETODEVICE] (SETQ DEV TEMP) (GO RETRY)) (T (SETQ DEV (ERROR "INVALID FILE DEVICE" DEV)) (GO RETRY))) (RETURN NAME]) (\GETDEVICEFROMNAME [LAMBDA (NAME NOERROR DONTCREATE) (* lmm " 5-Oct-84 18:06") (* ;; "maps a filename (with host added) into a device") (OR (AND (OR (LITATOM NAME) (STRINGP NAME)) (LET [(HOST (FILENAMEFIELD NAME 'HOST] (\GETDEVICEFROMHOSTNAME (OR HOST NAME) DONTCREATE))) (AND (NOT NOERROR) (LISPERROR "FILE NOT FOUND" NAME]) (\GETDEVICEFROMHOSTNAME [LAMBDA (HOSTN DONTCREATE) (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICES)) (* lmm " 5-Oct-84 14:36") (OR (CDR (FASSOC HOSTN \DEVICENAMETODEVICE)) (CDR (FASSOC (SETQ HOSTN (U-CASE HOSTN)) \DEVICENAMETODEVICE)) (AND (NOT DONTCREATE) (for D TEMP in \FILEDEVICES when (SETQ TEMP (FDEVOP 'HOSTNAMEP D HOSTN D)) do (* ;; "HOSTNAMEP is a pure predicate if the second arg is NIL. Here we give a device, which indicates that we are not just a predicate, but in fact would like a new device back, possibly constructed from the old one. A device value is installed with the new hostname; a T value means install with D.") (COND ((type? FDEV TEMP) (SETQ D TEMP))) (\DEFINEDEVICE HOSTN D) (RETURN D]) (\REMOVEDEVICE [LAMBDA (DEV) (* bvm%: " 3-NOV-83 23:17") (* ;; "Removes device DEV and also any association between any of its name and DEV") (DECLARE (GLOBALVARS \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE)) (PROG (TEMP) (UNINTERRUPTABLY (while (SETQ TEMP (find PAIR in \DEVICENAMETODEVICE suchthat (EQ (CDR PAIR) DEV))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAR TEMP) \FILEDEVICENAMES)) (SETQ \DEVICENAMETODEVICE (DREMOVE TEMP \DEVICENAMETODEVICE))) (SETQ \FILEDEVICES (DREMOVE DEV \FILEDEVICES))) (RETURN DEV]) (\REMOVEDEVICE.NAMES [LAMBDA (DEV NAMES) (* bvm%: "30-Jan-85 21:53") (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \FILEDEVICENAMES)) (* ;;; "removes any names associated with device DEV without actually removing the device itself. If NAMES is non-NIL, removes only the names inside it") (for TAIL on \DEVICENAMETODEVICE bind CHANGED when (AND (EQ (CDAR TAIL) DEV) (OR (NULL NAMES) (EQMEMB (CAAR TAIL) NAMES))) do (SETQ \FILEDEVICENAMES (DREMOVE (CAAR TAIL) \FILEDEVICENAMES)) (RPLACA TAIL NIL) (SETQ CHANGED T) finally (COND (CHANGED (SETQ \DEVICENAMETODEVICE (DREMOVE NIL \DEVICENAMETODEVICE]) ) (DEFINEQ (\CLOSEFILE [LAMBDA (STREAM ABORTFLG) (* ; "Edited 8-May-87 16:35 by bvm") (* ;; "Close the file specified by the given open file descriptor and return the file handle.") (COND ((NOT (READONLY STREAM)) (IMAGEOP 'IMCLOSEFN STREAM STREAM) (* ;  "Do image-specific operations before physically closing the stream") )) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM))) (PROG1 (FDEVOP 'CLOSEFILE DEVICE STREAM ABORTFLG) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (* ; "This marks the STREAM as closed") )]) (\DELETEFILE [LAMBDA (FILENAME DEV) (* hdj "13-Jun-86 14:36") (SETQ FILENAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILENAME))) (AND (OR DEV (SETQ DEV (\GETDEVICEFROMNAME FILENAME T))) (FDEVOP 'DELETEFILE DEV FILENAME DEV]) (\DEVICEEVENT [LAMBDA (EVENT) (* ; "Edited 20-Aug-88 18:08 by bvm") (* ;; "Executes device-dependent event code so all devices can respond to various system transition events (LOGOUT, MAKESYS, etc.) Before an event, devices are considered in the inverse order of their definition, so that older devices get processed later. The order is reversed for after-events.") (DECLARE (GLOBALVARS \FILEDEVICES)) (LET ((BEFOREP (SELECTQ EVENT ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) T) NIL))) (for D in (if BEFOREP then \FILEDEVICES else (REVERSE \FILEDEVICES)) do (FDEVOP 'EVENTFN D D EVENT) (if BEFOREP then (* ;; "Mark output files as needing revalidation if we write to them again. This is so that if you do a SAVEVM, then write to the file some more, then boot back to the SAVEVM, that the AFTERSAVEVM event will notice that the stream has changed.") (* ;; "Don't do this until AFTER we've run the eventfn because, e.g., the eventfn might have done a forceoutput on the stream, thereby prematurely observing this flag.") (for STREAM in (FDEVOP 'OPENP D NIL 'OUTPUT D) unless (fetch (STREAM NONDEFAULTDATEFLG) of STREAM) do (replace (STREAM REVALIDATEFLG) of STREAM with T]) (\GENERATEFILES [LAMBDA (PATTERN DESIREDPROPS OPTIONS) (* bvm%: "27-Apr-84 23:21") (* ;; "Returns a file-generator object that will generate all files whose names match PATTERN. A gen-object consists of a device dependent NEXTFILEFN and GENFILESTATE") (SETQ PATTERN (\ADD.CONNECTED.DIR PATTERN)) (PROG ((FDEV (\GETDEVICEFROMNAME PATTERN))) (RETURN (FDEVOP 'GENERATEFILES FDEV FDEV PATTERN DESIREDPROPS OPTIONS]) (\GENERATENEXTFILE [LAMBDA (GENOBJ NAMEONLY) (* bvm%: " 8-Jul-85 19:30") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES. The NEXTFILEFN must return the name of the next file generated by the generator, as a string or symbol. Returns NIL if no files left. It updates GENOBJ so that it will get the following satisfactory file on the next call to this function. --- If NAMEONLY, then filenames returned need not contain host, directory or version") (CL:FUNCALL (fetch NEXTFILEFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) NAMEONLY]) (\GENERATEFILEINFO [LAMBDA (GENOBJ ATTRIBUTE) (* bvm%: "26-Apr-84 15:40") (* ;; "GENOBJ is a file-generator object as created by \GENERATEFILES. The FILEINFOFN performs a GETFILEINFO on the file which is the currently enumerated file, i.e., the last thing that NEXTFILEFN returned") (CL:FUNCALL (fetch FILEINFOFN of GENOBJ) (fetch GENFILESTATE of GENOBJ) ATTRIBUTE]) (\GETFILENAME [LAMBDA (NAME RECOG FDEV) (* hdj " 4-Sep-86 15:22") (* ;; "Expands NAME according to recog, returning either the full NAME or NIL.") (SETQ NAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME NAME))) (COND ((OR FDEV (SETQ FDEV (\GETDEVICEFROMNAME NAME T))) (FDEVOP 'GETFILENAME FDEV NAME RECOG FDEV]) (\GENERIC.READCCODE [LAMBDA (FILE RDTBL) (* ; "Edited 13-Jan-88 10:04 by jds") (* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion and this function converts to a 16 bit value. Saves the character for LASTC as well.") (* ;; "This is the GENERIC method for READCCODE.") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL)) (STREAM (\INSTREAMARG FILE))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (replace (STREAM LASTCCODE) of STREAM with (\INCCODE STREAM]) (\GENERIC.OUTFILEP [LAMBDA (NAME DEV) (* lmm " 6-Jan-85 17:41") (PROG ((V (FDEVOP 'GETFILENAME DEV NAME 'OLD DEV))) (RETURN (if V then (PACKFILENAME 'VERSION (ADD1 (OR (FILENAMEFIELD V 'VERSION) 1)) 'BODY V) else (PACKFILENAME 'VERSION 1 'BODY NAME]) (\OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS) (* hdj "14-Oct-86 14:04") (* ;;; "Opens the file identified by NAME possibly expanded according to RECOG. Returns an open stream for the file. ACCESS is assumed to be one of INPUT, OUTPUT, BOTH, or APPEND.") (PROG (FDEV CDNAME STREAM) RETRY [COND [(type? STREAM NAME) (COND ((\IOMODEP NAME ACCESS T) (\DO.PARAMS.AT.OPEN NAME ACCESS PARAMETERS) (RETURN NAME)) (T (SETQ CDNAME NAME) (SETQ FDEV (fetch (STREAM DEVICE) of NAME] (T (SETQ CDNAME (\ADD.CONNECTED.DIR NAME)) (SETQ FDEV (\GETDEVICEFROMNAME CDNAME] (* ; "Keep NAME for possible error") (* ;; "The OPENFILE operation returns NIL if the file wasn't found, so the name is right for the not-found error. That error must not be generated from inside the device, or spellfile would be too constrained. The won't-open error may happen inside the device, if the device itself does some interlocking (e.g. a file-server). The generic code in OPENFILE may also generate that error, to enforce interlocks among files already opened in this Lisp.") (COND ((SETQ STREAM (FDEVOP 'OPENFILE FDEV CDNAME ACCESS RECOG PARAMETERS FDEV)) (replace ACCESS of STREAM with ACCESS) (replace CPAGE of STREAM with (COND ((EQ ACCESS 'APPEND) (fetch EPAGE of STREAM)) (T 0))) (replace COFFSET of STREAM with (COND ((EQ ACCESS 'APPEND) (fetch EOFFSET of STREAM)) (T 0))) (\DO.PARAMS.AT.OPEN STREAM ACCESS PARAMETERS) (* ;; "register the file using its internal device's registerfile method instead of FDEV's; this is primarily for the benefit of the file cacher") (LET ((STREAM-FDEV (fetch (STREAM DEVICE) of STREAM))) (FDEVOP 'REGISTERFILE STREAM-FDEV STREAM-FDEV STREAM)) (RETURN STREAM)) (T (SETQ NAME (LISPERROR "FILE NOT FOUND" NAME)) (GO RETRY]) (\DO.PARAMS.AT.OPEN [LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 2-Aug-2020 16:18 by rmk:") (* ; "Edited 5-Oct-92 13:45 by jds") (* ;; "Does generic parameters when a file/stream is open. Called by \OPENFILE and OPENSTREAM") (* ;; "RMK July 2020: Make sure that \EXTERNALFORMAT is always called, so that it can implement per-device defaults.") (for X ATTR VAL HADEXTFORMAT in PARAMETERS do (COND [(LISTP X) (SETQ ATTR (CAR X)) (SETQ VAL (CAR (LISTP (CDR X] (T (SETQ ATTR X) (SETQ VAL T))) (SELECTQ ATTR (BUFFERS (SETFILEINFO STREAM 'BUFFERS VAL)) (ENDOFSTREAMOP (SETFILEINFO STREAM 'ENDOFSTREAMOP VAL)) (CHARSET (CHARSET STREAM VAL)) (EXTERNALFORMAT (SETQ HADEXTFORMAT T) (\EXTERNALFORMAT STREAM VAL)) (CONVHANKAKU (CONVHANKAKU STREAM VAL)) ((EOL EOLCONVENTION EOLC) (replace EOLCONVENTION of STREAM with (SELECTQ VAL (CR CR.EOLC) (LF LF.EOLC) (CRLF CRLF.EOLC) (\ILLEGAL.ARG VAL)))) NIL) FINALLY (CL:UNLESS HADEXTFORMAT (\EXTERNALFORMAT STREAM :DEFAULT]) (\RENAMEFILE [LAMBDA (OLDFILE NEWFILE) (* hdj " 7-May-86 12:22") (SETQ OLDFILE (\ADD.CONNECTED.DIR OLDFILE)) (SETQ NEWFILE (\ADD.CONNECTED.DIR NEWFILE)) (LET ((OLD-DEVICE (\GETDEVICEFROMNAME OLDFILE T)) (NEW-DEVICE (\GETDEVICEFROMNAME NEWFILE T))) (AND OLD-DEVICE (FDEVOP 'RENAMEFILE OLD-DEVICE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE]) (\REVALIDATEFILE [LAMBDA (STREAM) (* bvm%: "30-DEC-81 17:45") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK.") (PROG ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (RETURN (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ;  "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM)) 'CHANGED]) (\PAGED.REVALIDATEFILELST [LAMBDA (DEVICE) (* hdj "30-Sep-86 15:23") (* ;;; "Revalidate all of the open files on DEVICE (a PMAP device)") (bind REASON PAGES for STREAM in (FDEVOP 'OPENP DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ;  "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM)) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ;  "might as well return something useful") (FDEVOP 'OPENP DEVICE NIL NIL DEVICE]) (\PAGED.REVALIDATEFILES [LAMBDA (LIST) (* hdj "30-Sep-86 15:18") (* ;;; "Revalidate all of the open files on LIST; they are all PMAPped streams") (LET ((NEWLIST (COPY LIST))) (bind REASON PAGES for STREAM in LIST do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed - update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ;  "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (LET ((DEVICE (fetch (STREAM DEVICE) of STREAM)) ) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM)) (SETQ NEWLIST (DREMOVE STREAM NEWLIST))) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM))) (* ;;; "return the remaining files") NEWLIST]) (\PAGED.REVALIDATEFILE [LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ;  "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM) ) 'CHANGED]) (\BUFFERED.REVALIDATEFILE [LAMBDA (STREAM) (* hdj "23-May-86 14:14") (* ;; "Check the file to determine if it corresponds to the status information for it found in the STREAM and file handle. Return DELETED if the file no longer exists, CHANGED if the file does not correspond to the status information, or NIL if everything is OK") (LET ((NEWSTREAM (FDEVOP 'REOPENFILE (fetch DEVICE of STREAM) (fetch FULLFILENAME of STREAM) (fetch ACCESS of STREAM) 'OLD NIL (fetch DEVICE of STREAM) STREAM))) (COND ((NOT NEWSTREAM) 'DELETED) ((EQ NEWSTREAM STREAM) (* ; "Nothing changed") NIL) (T (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (* ;  "Copy 'device' information from the new opening to the old") (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (COND ((EQUAL (fetch VALIDATION of NEWSTREAM) (fetch VALIDATION of STREAM)) NIL) (T (replace VALIDATION of STREAM with (fetch VALIDATION of NEWSTREAM)) (replace EPAGE of STREAM with (fetch EPAGE of NEWSTREAM)) (replace EOFFSET of STREAM with (fetch EOFFSET of NEWSTREAM) ) 'CHANGED]) (\BUFFERED.REVALIDATEFILELST [LAMBDA (DEVICE) (* hdj "30-Sep-86 15:16") (* ;;; "Revalidate all of the open files on DEVICE (a buffered device)") [bind REASON for STREAM in (FDEVOP 'OPENP DEVICE NIL NIL DEVICE) do (if (SETQ REASON (\BUFFERED.REVALIDATEFILE STREAM)) then (SELECTQ REASON ((DELETED CHANGED) (* ;  "the file changed or disappeared, so zap the stream") [MAPC (STREAMPROP STREAM 'AFTERCLOSE) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM] (replace ACCESS of STREAM with NIL) (FDEVOP 'UNREGISTERFILE DEVICE DEVICE STREAM) (\PRINT-REVALIDATION-RESULT REASON STREAM)) (SHOULDNT] (* ;; "might as well return something useful") (FDEVOP 'OPENP DEVICE NIL NIL DEVICE]) (\PRINT-REVALIDATION-RESULT [LAMBDA (RESULT STREAM) (* hdj "26-May-86 15:46") (printout T T T "**** WARNING: The file " (fetch (STREAM FULLNAME) of STREAM)) (SELECTQ RESULT (CHANGED (printout T " has been modified since you last accessed it!" T)) (DELETED (printout T " was previously opened but has disappeared!" T)) (SHOULDNT]) (\TRUNCATEFILE [LAMBDA (STREAM LASTPAGE LASTOFFSET) (* bvm%: " 8-MAY-82 16:11") (* ;; "Shorten an open file to have the given last page and offset. Last page = NIL means to truncate to the current length, which some devices may interpret as a noop") (FDEVOP 'TRUNCATEFILE (fetch DEVICE of STREAM) STREAM LASTPAGE LASTOFFSET]) (\FILE-CONFLICT [LAMBDA (NAME ACCESS DEVICE) (* ; "Edited 14-Apr-87 18:07 by jop") (* ;; "returns NIL if there's no conflict between the access mode of the file we're about to open and the ones already open there's no conflict if there are none already open, or if the ones already open are open for input, and so's the candidate") (LET* ((FILENAME (if (type? STREAM NAME) then (fetch (STREAM FULLFILENAME) of NAME) else NAME)) (STREAMS-FOR-THIS-FILE (FDEVOP 'OPENP DEVICE FILENAME NIL DEVICE))) (if STREAMS-FOR-THIS-FILE then [LET [(EXISTING-ACCESS-MODE (fetch (STREAM ACCESS) of (CAR STREAMS-FOR-THIS-FILE ] (if (NEQ ACCESS EXISTING-ACCESS-MODE) then T elseif (EQ ACCESS 'INPUT) then NIL else (NEQ NAME (CAR STREAMS-FOR-THIS-FILE] else NIL]) ) (* ; "Generic enumerator") (DEFINEQ (\GENERATENOFILES [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: " 5-Jun-84 16:31") (* ;; "A dummy function to be used by devices that don't support directory generation. This produces a generate that generates no files.") (PROG ((STAR (STRPOS '* PATTERN)) (ESC (STRPOS '(CONSTANT (CHARACTER (CHARCODE ESC))) PATTERN))) (RETURN (COND ([AND [OR (NULL STAR) (AND (EQ (NTHCHARCODE PATTERN (SUB1 STAR)) (CHARCODE ;)) (NULL (STRPOS '* PATTERN (ADD1 STAR] (OR (NULL ESC) (AND (EQ (NTHCHARCODE PATTERN (SUB1 ESC)) (CHARCODE ;)) (NULL (STRPOS (CONSTANT (CHARACTER (CHARCODE ESC))) PATTERN (ADD1 ESC] (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \NOFILESNEXTFILEFN) FILEINFOFN _ (FUNCTION \NOFILESINFOFN) GENFILESTATE _ (create NOFILEGENSTATE NOFILETYPE _ (COND ((AND (NULL STAR) (NULL ESC)) 'NOSTAR) (T (SETQ PATTERN (PACKFILENAME 'VERSION NIL 'BODY PATTERN)) 'STAR)) NOFILEPATTERN _ PATTERN))) (T (\NULLFILEGENERATOR]) (\NULLFILEGENERATOR [LAMBDA NIL (* bvm%: " 5-Jun-84 15:46") (* ;; "A file generator that generates no files") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION NILL]) (\NOFILESNEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) (* bvm%: " 8-Jul-85 19:28") (PROG (FILE TYPE) [SELECTQ (SETQ TYPE (fetch NOFILETYPE of GENFILESTATE)) (NOSTAR (replace NOFILETYPE of GENFILESTATE with 'DONE) (SETQ FILE (INFILEP (fetch NOFILEPATTERN of GENFILESTATE)))) (DONE (RETURN NIL)) (STAR (* ;; "Star in version field. Start out by producing the oldest file, and note its version and the version of the newest file for subsequent enumeration") (SETQ FILE (FULLNAME (fetch NOFILEPATTERN of GENFILESTATE) 'OLDEST)) [replace NOFILETYPE of GENFILESTATE with (CONS (FILENAMEFIELD FILE 'VERSION) (FILENAMEFIELD (INFILEP (fetch NOFILEPATTERN of GENFILESTATE )) 'VERSION]) (PROG [(VER (ADD1 (CAR TYPE] (* ;; "TYPE is a dotted pair of versions (old . newest) -- test INFILEP for each version number after old until we get to newest") LP (COND ((IGREATERP VER (CDR TYPE)) (RETURN NIL)) [[SETQ FILE (INFILEP (PACKFILENAME.STRING 'VERSION VER 'BODY (fetch NOFILEPATTERN of GENFILESTATE] (RPLACA TYPE (FILENAMEFIELD FILE 'VERSION] (T (add VER 1) (GO LP] (RETURN (COND (FILE (replace NOFILENAME of GENFILESTATE with FILE) FILE]) (\NOFILESINFOFN [LAMBDA (GENSTATE ATTRIBUTE) (* bvm%: "27-Apr-84 22:17") (* ;;; "Fileinfo fn for getting attributes of the file currently enumerated -- go thru the generic GETFILEINFO") (GETFILEINFO (fetch NOFILENAME of GENSTATE) ATTRIBUTE]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD NOFILEGENSTATE (NOFILETYPE NOFILEPATTERN . NOFILENAME)) ) ) (DEFINEQ (\FILE.NOT.OPEN [LAMBDA (X NOERROR) (* hdj "17-Jun-86 18:28") (* ;; "Returns NIL of NOERROR, otherwise causes the FILE NOT OPEN error. Used by \GETSTREAM. \STREAM.NOT.OPEN doesn't take NOERROR arg.") (AND (NULL NOERROR) (LISPERROR "FILE NOT OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X]) (\FILE.WONT.OPEN [LAMBDA (X) (* hdj "17-Jun-86 18:32") (LISPERROR "FILE WON'T OPEN" (COND ((type? STREAM X) (fetch (STREAM FULLNAME) of X)) (T X]) (\ILLEGAL.DEVICEOP [LAMBDA N (* bvm%: "28-DEC-81 15:44") (ERROR "Attempt to use undefined device operation" (for I from 1 to N collect (ARG N I]) (\IS.NOT.RANDACCESSP [LAMBDA N (* hdj "17-Jun-86 18:32") (PROG ((THING (ARG N 1))) (RETURN (ERROR "File is not RANDACCESSP" (COND ((type? STREAM THING) (fetch (STREAM FULLNAME) of THING)) (T THING]) (\STREAM.NOT.OPEN [LAMBDA (STREAM) (* hdj "17-Jun-86 18:32") (* ;; "Can be used as BIN/BOUT function. \FILE.NOT.OPEN accepts more than just a stream, and also has NOERROR control") (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLNAME) of STREAM]) ) (ADDTOVAR \FILEDEVICES ) (ADDTOVAR \FILEDEVICENAMES ) (ADDTOVAR \DEVICENAMETODEVICE ) (* ; "Device instances") (DEFINEQ (\FDEVINSTANCE [LAMBDA (FDEV) (* gbn "16-Sep-85 18:09") (* ;; "Creates an 'instance' of FDEV, a distinct device that executes all the operations of FDEV, but which can be smashed to change those operations in order to specialize streams. --- \INHERITFDEVOP.S and .D are macros that expect the device to be found from a STREAM or FDEV argument, respectively. Only operations that relate to streams are included, since non-stream device operations will be obtained from the original device, whose name is registered.") (create FDEV using FDEV DEVICEINFO _ FDEV CLOSEFILE _ (\INHERITFDEVOP.S CLOSEFILE STREAM) GETFILEINFO _ (\INHERITFDEVOP.D GETFILEINFO STREAM ATTRIB FDEV) OPENFILE _ (\INHERITFDEVOP.D OPENFILE CDNAME ACCESS RECOG OTHERINFO FDEV) READPAGES _ (\INHERITFDEVOP.S READPAGES STREAM FIRSTPAGE BUFFERLIST) SETFILEINFO _ (\INHERITFDEVOP.D SETFILEINFO STREAM ATTRIBUTE VALUE FDEV) TRUNCATEFILE _ (\INHERITFDEVOP.S TRUNCATEFILE STREAM LASTPAGE LASTOFFSET) WRITEPAGES _ (\INHERITFDEVOP.S WRITEPAGES STREAM FIRSTPAGE BUFFERLIST) REOPENFILE _ (\INHERITFDEVOP.D REOPENFILE NAME ACCESS RECOG OTHERINFO FDEV OLDSTREAM) BIN _ (\INHERITFDEVOP.S BIN STREAM) BOUT _ (\INHERITFDEVOP.S BOUT STREAM BYTE) PEEKBIN _ (\INHERITFDEVOP.S PEEKBIN STREAM NOERRORFLG) BACKFILEPTR _ (\INHERITFDEVOP.S BACKFILEPTR STREAM) SETFILEPTR _ (\INHERITFDEVOP.S SETFILEPTR STREAM INDX) GETFILEPTR _ (\INHERITFDEVOP.S GETFILEPTR STREAM) GETEOFPTR _ (\INHERITFDEVOP.S GETEOFPTR STREAM) EOFP _ (\INHERITFDEVOP.S EOFP STREAM) BLOCKIN _ (\INHERITFDEVOP.S BLOCKIN STREAM BASE OFFSET NBYTES) BLOCKOUT _ (\INHERITFDEVOP.S BLOCKOUT STREAM BASE OFFSET NBYTES) FORCEOUTPUT _ (\INHERITFDEVOP.S FORCEOUTPUT STREAM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \INHERITFDEVOP.D MACRO [X (SUBPAIR '(NEWARGS OPNAME . ARGS) (CONS (SUBST '(fetch DEVICEINFO of FDEV) 'FDEV (CDR X)) X) '(FUNCTION (LAMBDA ARGS (FDEVOP 'OPNAME (fetch DEVICEINFO of FDEV) . NEWARGS]) (PUTPROPS \INHERITFDEVOP.S MACRO [(OPNAME . ARGS) (FUNCTION (LAMBDA ARGS (FDEVOP 'OPNAME (fetch DEVICEINFO of (fetch DEVICE of STREAM)) . ARGS]) ) (RPAQ? LOGINHOST/DIR '{DSK}) (RPAQ? \CONNECTED.DIRECTORY '{DSK}) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LOGINHOST/DIR \CONNECTED.DIRECTORY \FILEDEVICES \FILEDEVICENAMES \DEVICENAMETODEVICE) ) (* ; "Directory defaulting") (DEFINEQ (CNDIR [LAMBDA (HOST/DIR) (* ; "Edited 11-Mar-87 14:28 by Pavel") (* ;;; "Connects to HOST/DIR, verifying that HOST/DIR exists.") (DECLARE (GLOBALVARS \CONNECTED.DIRECTORY)) (LET ([TEMP-DEFAULTS (PATHNAME (SETQ \CONNECTED.DIRECTORY (OR (DIRECTORYNAME (AND HOST/DIR (\CONVERT-PATHNAME HOST/DIR)) T 'ASK) (ERROR "Non-existent directory" HOST/DIR] (NEW-DEFAULTS (COPY-PATHNAME *DEFAULT-PATHNAME-DEFAULTS*))) (CL:SETF (%%PATHNAME-HOST NEW-DEFAULTS) (CL:PATHNAME-HOST TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DEVICE NEW-DEFAULTS) (CL:PATHNAME-DEVICE TEMP-DEFAULTS)) (CL:SETF (%%PATHNAME-DIRECTORY NEW-DEFAULTS) (CL:PATHNAME-DIRECTORY TEMP-DEFAULTS)) (SETQ *DEFAULT-PATHNAME-DEFAULTS* NEW-DEFAULTS)) \CONNECTED.DIRECTORY]) (DIRECTORYNAME [LAMBDA (DIRNAME STRPTR CREATE?) (* ; "Edited 20-May-92 11:08 by jds") (* ;; "Returns connected directory name") (AND (CL:PATHNAMEP DIRNAME) (SETQ DIRNAME (CL:NAMESTRING DIRNAME))) (SELECTQ (SYSTEMTYPE) (VAX (GETDIRNAME)) (D (DECLARE (GLOBALVARS LOGINHOST/DIR)) [PROG (DN FDEV) [SELECTQ DIRNAME (T (* ; "Connected host/dir") (SETQ DN \CONNECTED.DIRECTORY)) (NIL (SETQ DN (OR LOGINHOST/DIR '{DSK}))) (COND [(AND [SETQ FDEV (LET [(HOST (FILENAMEFIELD DIRNAME 'HOST] (SELCHARQ (NTHCHARCODE DIRNAME 1) (> (* ;  "Remove leading > from a subdirectory spec.") (SETQ DIRNAME (SUBSTRING DIRNAME 2))) NIL) (\GETDEVICEFROMHOSTNAME (OR HOST (FILENAMEFIELD [SELCHARQ (NTHCHARCODE DIRNAME 1) ((< /) (* ; "Whole directory, use it all.") (SETQ DIRNAME (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'BODY \CONNECTED.DIRECTORY))) (SELCHARQ (NTHCHARCODE DIRNAME (NCHARS DIRNAME)) ((> /) (* ;  "Remove any trailing > or / from a subdirectory spec.") (SETQ DIRNAME (PACKFILENAME.STRING 'SUBDIRECTORY (SUBSTRING DIRNAME 1 -2 ) 'DIRECTORY \CONNECTED.DIRECTORY))) (SETQ DIRNAME (PACKFILENAME.STRING 'SUBDIRECTORY DIRNAME 'DIRECTORY \CONNECTED.DIRECTORY] 'HOST] (SETQ DN (FDEVOP 'DIRECTORYNAMEP FDEV DIRNAME FDEV CREATE?))) (COND ((EQ DN T) (SETQ DN (PACKFILENAME.STRING 'HOST (fetch (FDEV DEVICENAME) of FDEV) 'DIRECTORY DIRNAME] (T (RETURN] (RETURN (COND ((NOT STRPTR) (MKSTRING DN)) ((EQ STRPTR T) (MKATOM DN)) (T (MKSTRING DN]) (HELP]) (DIRECTORYNAMEP [LAMBDA (DIRNAME HOSTNAME) (* bvm%: "18-Oct-85 14:38") (* ;; "T if DIRNAME is recognized as a currently existing directory, on HOSTNAME, or if not included, on the hostname in DIRNAME, or the connected host.") (LET ([DN (COND (HOSTNAME (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'HOST HOSTNAME)) (T (PACKFILENAME.STRING 'DIRECTORY DIRNAME 'DIRECTORY \CONNECTED.DIRECTORY] FDEV) (AND (SETQ FDEV (\GETDEVICEFROMNAME DN T)) (FDEVOP 'DIRECTORYNAMEP FDEV DN FDEV) T]) (HOSTNAMEP [LAMBDA (NAME) (* rmk%: "11-NOV-81 14:33") (* ;; "T if NAME is the name of a recognizable host") (DECLARE (GLOBALVARS \FILEDEVICENAMES \FILEDEVICES)) (PROG (N) (COND ((LITATOM NAME) (SETQ N (U-CASE NAME))) [(STRINGP NAME) (SETQ N (MKATOM (U-CASE NAME] (T (RETURN NIL))) [COND ((EQ (CHCON1 N) (CHARCODE {)) (SETQ N (SUBATOM N 2 (SUB1 (OR (STRPOS '} N 2) (RETURN NIL] (RETURN (AND (OR (MEMB N \FILEDEVICENAMES) (find D in \FILEDEVICES suchthat (FDEVOP 'HOSTNAMEP D N))) T]) (\ADD.CONNECTED.DIR [LAMBDA (FILENAME) (* ; "Edited 29-Dec-89 15:41 by jds") (* ;; "Modifies the filename to include connected host and/or dir") (COND ([AND (OR (LITATOM FILENAME) (STRINGP FILENAME)) (NOT (UNPACKFILENAME.STRING FILENAME 'HOST] (PACKFILENAME.STRING 'BODY FILENAME 'DIRECTORY \CONNECTED.DIRECTORY)) (T FILENAME]) ) (* ; "Binary I/O Public functions") (DEFINEQ (\BACKFILEPTR [LAMBDA (STREAM) (* bvm%: "30-JAN-82 16:59") (FDEVOP 'BACKFILEPTR (fetch DEVICE of STREAM) STREAM]) (\BACKPEEKBIN [LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:45") (* ;; "Returns previous byte on file without changing fileptr. Returns NIL if we are positioned at the beginning of the file. Called by LASTC") (UNINTERRUPTABLY (AND (\BACKFILEPTR STREAM) (\BIN STREAM)))]) (\BACKBIN [LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:46") (* ;; "Returns previous character on file and backs up fileptr so that next \BIN will also return it. Returns NIL if we are positioned at the beginning of the file.") (AND (\BACKFILEPTR STREAM) (\PEEKBIN STREAM]) (BIN [LAMBDA (STREAM) (* lmm "20-APR-82 22:00") (* ; "MERELY EXECUTE OPCODE") (\BIN STREAM]) (\BIN [LAMBDA (STREAM) (* rmk%: " 2-NOV-83 14:32") (* ; "UFN for BIN opcode") (STREAMOP 'STRMBINFN (SETQ STREAM (\DTEST STREAM 'STREAM)) STREAM]) (\BINS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:48") (* ;; "BINs NBYTES bytes from STREAM into BASE+OFF") (FDEVOP 'BLOCKIN [ffetch DEVICE of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM BASE OFF NBYTES]) (BOUT [LAMBDA (STREAM BYTE) (* ; "Edited 3-Mar-87 16:04 by lal") (* ; "Merely execute opcode") (if (NUMBERP BYTE) then (if (GREATERP BYTE 65535) then (\ILLEGAL.ARG BYTE))) (\BOUT STREAM BYTE]) (\BOUT [LAMBDA (STREAM BYTE) (* ; "Edited 8-Jan-88 17:00 by jds") [COND ((NUMBERP BYTE) (COND ((GREATERP BYTE 65535) (\ILLEGAL.ARG BYTE] (SETQ STREAM (\DTEST STREAM 'STREAM)) (STREAMOP 'STRMBOUTFN STREAM STREAM BYTE]) (\BOUTS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 12:47") (* ;; "BOUTs NBYTES bytes from BASE+OFF into OFD. Follows logic of BINS.") (FDEVOP 'BLOCKOUT [ffetch DEVICE of (SETQ STREAM (\DTEST STREAM 'STREAM] STREAM BASE OFF NBYTES]) (COPYBYTES [LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 24-Jun-88 15:08 by drc:") (* ;; "Copies bytes from START up to but not including END from SRCFIL into DSTFIL.") (PROG ((SRC (\GETSTREAM SRCFIL 'INPUT)) (DST (\GETSTREAM DSTFIL 'OUTPUT)) NBYTES) (SETQ NBYTES (COND (END (* ; "Specified a start and ending") (COND ((EQUAL START END) (* ; "special case: no bytes to copy") (RETURN))) [\SETFILEPTR SRC (COND ((type? BYTEPTR START) START) (T (\ILLEGAL.ARG START] (IDIFFERENCE (COND [(EQ END -1) (COND ((RANDACCESSP SRC) (* ;  "It's random access, so GETEOFPTR will work") (\GETEOFPTR SRC)) (T (* ;  "Otherwise, we have to hack around this (probably a bug in FTP streams)") (GETFILEINFO SRC 'LENGTH] ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END))) START)) (T START))) (* ;  "How much to copy, or NIL if to EOF") (COND ((AND NBYTES (ILESSP NBYTES 0)) (ERROR "Negative number of bytes to copy" NBYTES))) [COND ((fetch BUFFERED of (fetch DEVICE of SRC)) (* ; "Can copy by the bufferfull") (\BUFFERED.COPYBYTES SRC DST NBYTES)) [[OR NBYTES (SETQ NBYTES (COND ((fetch RANDOMACCESSP of (fetch DEVICE of SRC)) (IDIFFERENCE (\GETEOFPTR SRC) (\GETFILEPTR SRC] (* ; "Know how many bytes to copy") (FRPTQ NBYTES (\BOUT DST (\BIN SRC] (T (* ;  "Copying to EOF but can't tell when that will happen") (until (\EOFP SRC) do (\BOUT DST (\BIN SRC] (RETURN T) (* ; "As specified in VM") ]) (COPYCHARS [LAMBDA (SRCFIL DSTFIL START END) (* ; "Edited 11-Dec-95 10:48 by ") (* ; "Edited 8-Dec-95 16:38 by rmk:") (* ; "Edited 26-Mar-99 12:13 by rmk:") (* ;; "This is similar to COPYBYTES except that conversion is done between the EOL convention and externalformat of the input and the EOL convention/external format of the output") [PROG ((SRCSTRM (\GETSTREAM SRCFIL)) (DSTSTRM (\GETSTREAM DSTFIL)) (ACTUALSTART 0) RAP ACTUALEND EOF SRCEOLC DSTEOLC CH SAMEEXTFORM) [COND ([AND (EQ (SETQ SRCEOLC (fetch EOLCONVENTION of SRCSTRM)) (SETQ DSTEOLC (fetch EOLCONVENTION of DSTSTRM))) (SETQ SAMEEXTFORM (EQ (FETCH EXTERNALFORMAT OF SRCSTRM) (FETCH EXTERNALFORMAT OF DSTSTRM] (RETURN (COPYBYTES SRCSTRM DSTSTRM START END] [COND ((SETQ RAP (fetch RANDOMACCESSP of (fetch DEVICE of SRCSTRM))) (SETQ EOF (\GETEOFPTR SRCSTRM] (COND [END (OR RAP (ERROR "COPYCHARS: Source file is not random access" (fetch FULLFILENAME of SRCSTRM))) (OR (type? BYTEPTR (SETQ ACTUALSTART (FIX START))) (LISPERROR "ILLEGAL ARG" START)) (\SETFILEPTR SRCSTRM ACTUALSTART) (SETQ ACTUALEND (COND ((EQ END -1) EOF) ((type? BYTEPTR END) END) (T (\ILLEGAL.ARG END] [START (SETQ ACTUALEND (COND (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (IMIN EOF (IPLUS START ACTUALSTART))) (T START] (RAP (SETQ ACTUALSTART (\GETFILEPTR SRCSTRM)) (SETQ ACTUALEND EOF)) (T (until (\EOFP SRCSTRM) do (\OUTCHAR DSTSTRM (\INCHAR SRCSTRM))) (* ;  "Not RAP and START and END are both NIL. Slow copy to the end of the file.") (RETURN))) (OR (IGEQ ACTUALEND ACTUALSTART) (ERROR "Negative number of bytes to copy" (IDIFFERENCE ACTUALEND ACTUALSTART))) (IF SAMEEXTFORM THEN (* ;  "We only have to worry about mismatched EOLCs") (SELECTC SRCEOLC (CR.EOLC (* ; "DST is either CRLF or LF") (FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART) (SELCHARQ (SETQ CH (\BIN SRCSTRM)) (CR (AND (EQ DSTEOLC CRLF.EOLC) (\BOUT DSTSTRM (CHARCODE CR))) (\BOUT DSTSTRM (CHARCODE LF))) (\BOUT DSTSTRM CH)))) (LF.EOLC (* ; "DST is either CRLF or CR") (FRPTQ (IDIFFERENCE ACTUALEND ACTUALSTART) (SELCHARQ (SETQ CH (\BIN SRCSTRM)) (LF (\BOUT DSTSTRM (CHARCODE CR)) (AND (EQ DSTEOLC CRLF.EOLC) (\BOUT DSTSTRM (CHARCODE LF)))) (\BOUT DSTSTRM CH)))) (CRLF.EOLC (* ; "DST is either CR or LF") [for I from (IDIFFERENCE ACTUALEND ACTUALSTART) to 1 by -1 do (\BOUT DSTSTRM (COND ((OR (NEQ (SETQ CH (\BIN SRCSTRM)) (CHARCODE CR)) (EQ I 1)) CH) [(PROGN (add I -1) (* ; "Adjust for second character") (EQ (SETQ CH (\BIN SRCSTRM)) (CHARCODE LF))) (COND ((EQ DSTEOLC CR.EOLC) (CHARCODE CR)) (T (CHARCODE LF] (T (\BOUT DSTSTRM (CHARCODE CR)) CH]) (SHOULDNT)) ELSE (* ;  "Extformat mismatch. The \INCHAR and \OUTCHAR will also handle any EOL conversion issues.") (BIND (CNT _ (IDIFFERENCE ACTUALEND ACTUALSTART)) WHILE (IGREATERP CNT 0) DO (* ;; "Let the \INCHAR macro decrement the byte count") (\OUTCHAR DSTSTRM (\INCHAR SRCSTRM CNT] T]) (COPYFILE [LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* ; "Edited 2-Jan-93 13:35 by jds") (* ;;; "DESTPARAMETERS is like PARAMETERS arg to OPENSTREAM -- overrides default parameters") [AND (DIRECTORYNAMEP (PACKFILENAME 'HOST NIL 'BODY TOFILE) (UNPACKFILENAME TOFILE 'HOST)) (SETQ TOFILE (PACKFILENAME 'DIRECTORY TOFILE 'BODY (PACKFILENAME 'HOST NIL 'DIRECTORY NIL 'BODY FROMFILE] (RESETLST [RESETSAVE [SETQ FROMFILE (OPENSTREAM FROMFILE 'INPUT 'OLD '((SEQUENTIAL T) (DON'TCACHE T] '(PROGN (CLOSEF OLDVALUE] (\COPYOPENFILE FROMFILE TOFILE DESTPARAMETERS))]) (\COPYOPENFILE [LAMBDA (INSTREAM NEWNAME DESTPARAMETERS) (* ; "Edited 11-Dec-95 12:04 by ") (* ; "Edited 11-Dec-95 11:50 by ") (* ; "Edited 17-Sep-90 11:41 by jds") (* bvm%: "18-Oct-85 15:54") (PROG ((PROPS DESTPARAMETERS) TYPE X OUTSTREAM) [COND ([AND (NOT (ASSOC 'CREATIONDATE DESTPARAMETERS)) (SETQ X (GETFILEINFO INSTREAM 'CREATIONDATE] (push PROPS (LIST 'CREATIONDATE X] [COND [(SETQ TYPE (CADR (ASSOC 'TYPE DESTPARAMETERS] ((OR (AND (SETQ TYPE (GETFILEINFO INSTREAM 'TYPE)) (NEQ TYPE '?)) (SETQ TYPE (\INFER.FILE.TYPE INSTREAM))) (push PROPS (LIST 'TYPE TYPE] (* ;; "TAL removed : (COND ((AND (EQ TYPE 'TEXT) (SETQ X (GETFILEINFO INSTREAM 'EOL)) (NOT (ASSOC 'EOL DESTPARAMETERS))) (push PROPS (LIST 'EOL X)))) --- if the caller didn't specify, we ought to convert to the destination system's EOL convention for text files.") (CL:UNLESS (EQ TYPE 'TEXT) (* ;; "RMK: Setting the LENGTH seems wrong for TEXT files, since the byte-length could change if EOL or external-format differs. Let normal Length mechanisms prevail. Indeed, why bother with setting the length anyway--unless this is merely a hint for the opener? If so, the text guard can be removed.") [COND ((SETQ X (GETFILEINFO INSTREAM 'LENGTH)) (push PROPS (LIST 'LENGTH X]) [RESETSAVE [SETQ OUTSTREAM (OPENSTREAM NEWNAME 'OUTPUT 'NEW `((SEQUENTIAL T) (DON'TCACHE T) ,@PROPS] '(AND RESETSTATE (SETQ OLDVALUE (CLOSEF OLDVALUE)) (DELFILE OLDVALUE] (* ;; "Obsoleted by Lyric's multiple streams: (OR (EQ (\GETFILEPTR INSTREAM) 0) (SETFILEPTR INSTREAM 0)) ;; In case it was open by someone else! Really need multiple streams, but until then at least don't lose big this way") (COND ((EQ TYPE 'TEXT) (* ;; "RMK replaced the following with COPYCHARS, to make sure Externalformat gets done as well as EOL: ") (* ;; "(AND (EQ TYPE 'TEXT) (NEQ (GETFILEINFO OUTSTREAM 'EOL) X)) ; Incompatible EOL conventions, do slow way (replace ENDOFSTREAMOP of INSTREAM with (FUNCTION NILL)) (bind CH (SRCEOL _ (fetch EOLCONVENTION of INSTREAM)) until (NULL (SETQ CH (\BIN INSTREAM))) do (\OUTCHAR OUTSTREAM (\CHECKEOLC CH SRCEOL INSTREAM)))") (COPYCHARS INSTREAM OUTSTREAM)) (T (COPYBYTES INSTREAM OUTSTREAM))) (* ;; "On UNIX version, give FX the option of printing a warning when the file type is defaulted -- they want to discourage that behavior.") (AND (EQ \MACHINETYPE \MAIKO) FileTypeConfirmFlg (STKPOS 'COPYFILE) (NULL (ASSOC 'TYPE DESTPARAMETERS)) (\UFStoOtherCopyMess INSTREAM OUTSTREAM)) (* ;; "We return the closed stream.") (RETURN (CLOSEF OUTSTREAM]) (\INFER.FILE.TYPE [LAMBDA (STREAM) (* bvm%: " 8-Jun-84 11:48") (* ;; "STREAM is open on a file whose TYPE is unknown. If we can, decide between TEXT and BINARY by examining bytes") (COND ((RANDACCESSP STREAM) (SETFILEPTR STREAM 0) (PROG ((OLDEOF (fetch ENDOFSTREAMOP of STREAM)) TYPE) (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL)) [SETQ TYPE (do (COND ((IGREATERP (OR (\BIN STREAM) (RETURN 'TEXT)) 127) (RETURN 'BINARY] (replace ENDOFSTREAMOP of STREAM with OLDEOF) (SETFILEPTR STREAM 0) (* ; "Put file ptr back") (RETURN TYPE]) (EOFP [LAMBDA (FILE) (* bvm%: "10-Jun-84 22:46") (* ;; "User entry. T if FILE is at EOF. I-10 only considers input files, we merely give priority to them") (\EOFP (OR (\GETSTREAM FILE 'INPUT T) (\GETSTREAM FILE]) (FORCEOUTPUT [LAMBDA (STREAM WAITFORFINISH) (* bvm%: "27-Apr-84 22:45") (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) (FDEVOP 'FORCEOUTPUT (fetch DEVICE of STREAM) STREAM WAITFORFINISH]) (\FLUSH.OPEN.STREAMS [LAMBDA (FDEV) (* hdj " 5-Jun-86 12:58") (* ;;; "flush all of device's open streams") (for STREAM in (\DEVICE-OPEN-STREAMS FDEV) when (DIRTYABLE STREAM) do (FDEVOP 'FORCEOUTPUT (fetch (STREAM DEVICE) of STREAM) STREAM]) (CHARSET [LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 16:22 by bvm:") (* ;; "Public access to a stream's CHARSET. If NEWVALUE is given, changes the charset (which for output streams can write a charset shift). We invoke the stream's device's get/set charset method on the stream, and also invoke the IMCHARSET image operation (which is where file streams get to write a charset shift).") (* ;; "If CHARACTERSET is either 255 or T, set the stream so that it's non run-coded, i.e., you read 2 bytes for each character read.") (SETQ STREAM (\GETSTREAM STREAM)) (COND ((EQ NEWVALUE NSCHARSETSHIFT) (* ; "Coerce 255 to T for uniformity") (SETQ NEWVALUE T)) ([NOT (OR (EQ NEWVALUE NIL) (EQ NEWVALUE T) (AND (>= NEWVALUE 0) (< NEWVALUE \MAXCHARSET] (\ILLEGAL.ARG NEWVALUE))) (LET [(OLDVAL (ACCESS-CHARSET STREAM (if (EQ NEWVALUE T) then NSCHARSETSHIFT else NEWVALUE] (* ; "First modify the stream's slot") (if (EQ OLDVAL NSCHARSETSHIFT) then (SETQ OLDVAL T)) (if (AND NEWVALUE (NEQ OLDVAL NEWVALUE)) then (* ;  "Now invoke the imageop if anything interesting happened") (IMAGEOP 'IMCHARSET STREAM STREAM NEWVALUE)) OLDVAL]) (ACCESS-CHARSET [LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 15:46 by bvm:") (FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STREAM) STREAM NEWVALUE]) (GETEOFPTR [LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP 'GETEOFPTR (fetch DEVICE of STREAM) STREAM]) (GETFILEINFO [LAMBDA (FILE ATTRIB) (* ; "Edited 11-Dec-95 11:07 by ") (* ; "Edited 11-Dec-95 11:03 by ") (* ; "Edited 8-May-87 16:53 by bvm") (LET (FULLNAME DEV) (COND [(type? STREAM FILE) (* ; "FILE is open or nameless. Ask device for info; if it can't handle it, at least handle some generic cases") (COND ((EQ ATTRIB 'ACCESS) (fetch ACCESS of FILE)) ((FDEVOP 'GETFILEINFO (SETQ DEV (fetch DEVICE of FILE)) FILE ATTRIB DEV)) ((OPENED FILE) (* ;  "Could be false for a closed nameless stream") (SELECTQ ATTRIB ((BYTESIZE OPENBYTESIZE) (fetch BYTESIZE of FILE)) (EOL (SELECTC (fetch EOLCONVENTION of FILE) (CR.EOLC 'CR) (LF.EOLC 'LF) (CRLF.EOLC 'CRLF) (SHOULDNT))) (BUFFERS (fetch MAXBUFFERS of FILE)) (CHARSET (CHARSET FILE)) (ENDOFSTREAMOP (fetch ENDOFSTREAMOP of FILE)) (LENGTH (AND (RANDACCESSP FILE) (\GETEOFPTR FILE))) (SIZE [SIZE.FROM.LENGTH (OR (FDEVOP 'GETFILEINFO DEV FILE 'LENGTH DEV) (AND (RANDACCESSP FILE) (\GETEOFPTR FILE]) (EXTERNALFORMAT (\EXTERNALFORMAT FILE)) NIL)) ((EQ ATTRIB 'SIZE) (SIZE.FROM.LENGTH (FDEVOP 'GETFILEINFO DEV FILE 'LENGTH DEV] [(AND [SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILE] (SETQ FULLNAME (FDEVOP 'GETFILENAME DEV FULLNAME 'OLD DEV))) (* ; "Name of existing file. It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.") (SELECTQ ATTRIB ((ACCESS OPENBYTESIZE) (* ;  "Strip off attributes that apply only to open files") NIL) (OR (FDEVOP 'GETFILEINFO DEV FULLNAME ATTRIB DEV) (SELECTQ ATTRIB (SIZE (SIZE.FROM.LENGTH (FDEVOP 'GETFILEINFO DEV FULLNAME 'LENGTH DEV))) NIL] (T (LISPERROR "FILE NOT FOUND" FILE]) (\TYPE.FROM.FILETYPE [LAMBDA (FILETYPE) (* bvm%: "15-Jan-85 16:22") (* ;;; "Coerces a numeric FILETYPE to a symbolic TYPE or returns FILETYPE itself if it is not registered on the list FILING.TYPES") (AND FILETYPE (OR (CAR (find PAIR in FILING.TYPES suchthat (EQ (CADR PAIR) FILETYPE))) FILETYPE]) (\FILETYPE.FROM.TYPE [LAMBDA (TYPE) (* bvm%: "15-Jan-85 17:08") (OR (CADR (ASSOC TYPE FILING.TYPES)) (FIXP TYPE]) (GETFILEPTR [LAMBDA (FILE) (* rmk%: "21-OCT-83 11:19") (PROG ((STREAM (\GETSTREAM FILE))) (RETURN (FDEVOP 'GETFILEPTR (fetch DEVICE of STREAM) STREAM]) (SETFILEINFO [LAMBDA (FILE ATTRIB VALUE) (* ; "Edited 11-Dec-95 11:31 by ") (* ; "Edited 11-Dec-95 11:08 by ") (* ; "Edited 27-Mar-89 15:33 by bvm") (LET (FULLNAME DEV) (COND [(type? STREAM FILE) (* ;  "FILE is open, so strip off attributes that can be set from the stream.") (SELECTQ ATTRIB ((ACCESS BYTESIZE OPENBYTESIZE) (* ;  "These can't be changed for an open file") NIL) (EOL (replace EOLCONVENTION of FILE with (SELECTQ VALUE (CR CR.EOLC) (CRLF CRLF.EOLC) (LF LF.EOLC) (\ILLEGAL.ARG VALUE))) VALUE) (EXTERNALFORMAT (\EXTERNALFORMAT FILE VALUE) VALUE) (ENDOFSTREAMOP (replace ENDOFSTREAMOP of FILE with VALUE)) (BUFFERS (replace MAXBUFFERS of FILE with (IMAX 1 (FIX VALUE)))) (CHARSET (CHARSET FILE VALUE)) (OR (FDEVOP 'SETFILEINFO (SETQ DEV (fetch DEVICE of FILE)) FILE ATTRIB VALUE DEV) (SELECTQ ATTRIB (LENGTH (* ;; "Let device at this attribute first. Probably should not have this generic op, since we don't know how to do this for all devices") [\SETEOFPTR FILE (COND ((type? BYTEPTR VALUE) VALUE) (T (\ILLEGAL.ARG VALUE]) (SIZE (\SETEOFPTR FILE (UNFOLD VALUE BYTESPERPAGE))) NIL] [(AND [SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (\ADD.CONNECTED.DIR (\CONVERT-PATHNAME FILE] (SETQ FULLNAME (FDEVOP 'GETFILENAME DEV FULLNAME 'OLD DEV))) (* ; "Name of existing file. It's possible we should have the device do recognition instead, but then we have the confusion of file not found recovery in the wrong place.") (SELECTQ ATTRIB ((ACCESS OPENBYTESIZE EOLCONVENTION) NIL) (OR (FDEVOP 'SETFILEINFO DEV FULLNAME ATTRIB VALUE DEV) (COND ((EQ ATTRIB 'LENGTH) (\SETCLOSEDFILELENGTH FULLNAME (COND ((type? BYTEPTR VALUE) VALUE) (T (\ILLEGAL.ARG VALUE] (T (LISPERROR "FILE NOT FOUND" FILE]) (SETFILEPTR [LAMBDA (FILE ADR) (* ; "Edited 11-Sep-87 16:34 by bvm:") (LET ((STREAM (\GETSTREAM FILE))) [FDEVOP 'SETFILEPTR (ffetch DEVICE of STREAM) STREAM (COND ((EQ ADR -1) (\GETEOFPTR STREAM)) ((type? BYTEPTR ADR) ADR) (T (LISPERROR "ILLEGAL ARG" ADR] (if (\RUNCODED STREAM) then (* ;; "always shift the character set to 0. This might be wrong sometimes, but it is more often right than wrong. We don't do it when reading a non-runcoded file, since maybe the whole file is that way (unfortunately, we can't tell)") (ACCESS-CHARSET STREAM 0)) (freplace (STREAM CHARPOSITION) of STREAM with 0) (* ; "Value is not coerced!") ADR]) (BOUT16 [LAMBDA (STREAM N) (* edited%: " 2-Apr-85 17:11") (BOUT STREAM (LRSH N 8)) (BOUT STREAM (LOGAND N 255)) N]) (BIN16 [LAMBDA (STREAM) (* edited%: " 2-Apr-85 17:11") (LOGOR (LLSH (BIN STREAM) 8) (BIN STREAM]) ) (PUTPROPS BOUT DOPCODE (33 BOUT 0 T -1 \BOUT (4K DORADO))) (* ; "Generic functions") (DEFINEQ (\GENERIC.BINS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:41") (* ;; "BINs NBYTES bytes from STREAM to memory starting at BASE+OFF.") (FRPTQ NBYTES (\PUTBASEBYTE BASE OFF (\BIN STREAM)) (add OFF 1]) (\GENERIC.BOUTS [LAMBDA (STREAM BASE OFF NBYTES) (* bvm%: "25-MAY-83 11:40") (* ;; "BOUTs NBYTES bytes from BASE+OFF into STREAM") (FRPTQ NBYTES (\BOUT STREAM (\GETBASEBYTE BASE OFF)) (add OFF 1]) (\GENERIC.RENAMEFILE [LAMBDA (OLDDEVICE OLDFILE NEWDEVICE NEWFILE) (* ; "Edited 2-Jul-90 16:03 by nm") (if (NOT (FDEVOP 'OPENP OLDDEVICE (FULLNAME OLDFILE) NIL OLDDEVICE)) then (RESETLST [RESETSAVE [SETQ OLDFILE (OPENSTREAM OLDFILE 'INPUT 'OLD '((SEQUENTIAL T) DON'TCACHE] '(AND RESETSTATE (CLOSEF? OLDVALUE] [COND ((SETQ NEWFILE (\COPYOPENFILE OLDFILE NEWFILE)) (if (\DELETEFILE (CLOSEF OLDFILE)) then NEWFILE else (CONDITIONS:RESTART-CASE (CL:ERROR ' XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :PATHNAME OLDFILE) (DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Delete the destination file too." (DELFILE NEWFILE ) NIL) (DONT-DELETE-DESTINATION NIL :CONDITION XCL::FS-RENAMEFILE-SOURCE-COULDNT-DELETE :REPORT "Don't delete the destination file. Just returns the destination filename." NEWFILE])]) (\GENERIC.OPENP [LAMBDA (FILENAME ACCESS DEVICE) (* hdj " 6-Oct-86 17:07") (* ;;; "return all open stream on DEVICE with name FILENAME and access ACCESS. FILENAME is assumed to be fully 'recognized.' FILENAME and/or ACCESS may be NIL.") (if FILENAME then [LET ((OPENFILES (fetch (FDEV OPENFILELST) of DEVICE))) (if OPENFILES then (for STREAM in OPENFILES collect STREAM when (AND (STRING-EQUAL FILENAME (fetch (STREAM FULLNAME ) of STREAM)) (OR (NULL ACCESS) (\IOMODEP STREAM ACCESS T] else (for S in (fetch (FDEV OPENFILELST) of DEVICE) collect S when (AND (OR (NULL ACCESS) (\IOMODEP S ACCESS T)) (fetch USERVISIBLE of S]) (\GENERIC.READP [LAMBDA (STREAM FLG) (* ; "Edited 11-Sep-87 16:26 by bvm:") (* ;  "The 10 does not do the EOL check on the peeked character.") (* ;  "If FLG is NIL, a single EOL doesn't count.") (PROG ((SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256))) (RETURN (AND (NOT (\EOFP STREAM)) (OR (NOT (NULL FLG)) [NEQ EOL.TC (\SYNCODE \PRIMTERMSA (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN] (UNINTERRUPTABLY (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (* ;; "To find out if the EOL is the last character, we BIN the stream, check for EOF, then back it up again.") (PROG1 (NOT (\EOFP STREAM)) (\BACKNSCHAR STREAM SHIFTEDCHARSET)))]) (\GENERIC.CHARSET [LAMBDA (STREAM NEWVALUE) (* ; "Edited 11-Sep-87 16:20 by bvm:") (* ;;; "sets or returns the current numeric character set for this stream. This never writes anything on a stream, it just tells the stream what to think.") (PROG1 (ffetch (STREAM CHARSET) of (\DTEST STREAM 'STREAM)) (AND NEWVALUE (freplace (STREAM CHARSET) of STREAM with NEWVALUE)))]) ) (DEFINEQ (\MAP-OPEN-STREAMS [LAMBDA (FN DEVICES ACCESS) (* hdj "11-Sep-86 10:48") (for DEVICE in DEVICES when (fetch (FDEV OPENP) of DEVICE) join (for STREAM in (FDEVOP 'OPENP DEVICE NIL ACCESS DEVICE) collect (APPLY* FN STREAM]) ) (RPAQQ FILING.TYPES ((BINARY 0) (DIRECTORY 1) (TEXT 2) (SERIALIZED 3) (INTERPRESS 4361) (TEDIT 6056) (FASL 6057) (LAFITE 6058))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS FILING.TYPES) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \OUTCHAR DMACRO (OPENLAMBDA (STREAM CHARCODE) (STREAMOP 'OUTCHARFN STREAM STREAM CHARCODE))) (PUTPROPS \DEVICE-OPEN-STREAMS MACRO [ARGS (LET ((DEVICE (CAR ARGS))) `(FDEVOP '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) `((OPENLAMBDA (STRM) (FDEVOP 'CHARSETFN (fetch (STREAM DEVICE) of STRM) STRM ,NEWVALUE)) ,STREAM)) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: DONTEVAL@LOAD DOCOPY [MAPC '((FORCEOUTPUT FLUSHOUTPUT) (FORCEOUTPUT FLUSHMAP) (\GENERIC.BINS \NONPAGEDBINS) (\GENERIC.BOUTS \NONPAGEDBOUTS)) (FUNCTION (LAMBDA (PAIR) (PUTD (CADR PAIR) (GETD (CAR PAIR)) T] ) (* ; "Internal functions") (DEFINEQ (\EOF.ACTION [LAMBDA (STREAM) (* bvm%: "24-Aug-84 18:06") (* ;; "Standard thing to do at end of stream") (CL:FUNCALL (fetch (STREAM ENDOFSTREAMOP) of STREAM) STREAM]) (\EOSERROR [LAMBDA (STREAM) (* hdj "17-Jun-86 18:35") (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T]) (\GETEOFPTR [LAMBDA (STREAM) (* lmm "25-MAY-83 23:17") (FDEVOP 'GETEOFPTR (fetch DEVICE of STREAM) STREAM]) (\INCFILEPTR [LAMBDA (STREAM AMOUNT) (* bvm%: " 7-Jun-84 16:47") (COND ((NOT (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (\SETFILEPTR STREAM (IPLUS (\GETFILEPTR STREAM) AMOUNT))) (T (\PAGED.INCFILEPTR STREAM AMOUNT]) (\PEEKBIN [LAMBDA (STREAM NOERRORFLG) (* bvm%: "26-DEC-81 15:59") (FDEVOP 'PEEKBIN (fetch DEVICE of STREAM) STREAM NOERRORFLG]) (\SETCLOSEDFILELENGTH [LAMBDA (FILENAME NBYTES) (* bvm%: "13-JUL-83 15:15") (* ;; "Reset the length of a closed file to nBytes.") (PROG [(STREAM (\OPENFILE FILENAME 'BOTH 'OLD] (\SETEOFPTR STREAM NBYTES) (\CLOSEFILE STREAM) (RETURN T]) (\SETEOFPTR [LAMBDA (STREAM LEN) (* bvm%: " 9-Jul-84 17:37") (FDEVOP 'SETEOFPTR (fetch DEVICE of STREAM) STREAM LEN]) (\SETFILEPTR [LAMBDA (STREAM INDX) (* rmk%: "22-AUG-83 13:37") (* ;; "Fast case of SETFILEPTR, assumes STREAM is a stream and INDX is an already coerced fileptr (not -1) Does not reset CHARPOSITION and value is uninteresting") (FDEVOP 'SETFILEPTR (fetch DEVICE of STREAM) STREAM INDX]) ) (DEFINEQ (\FIXPOUT [LAMBDA (STRM N) (* rmk%: "25-Jun-84 14:47") (\BOUT STRM (LOADBYTE N 24 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 16 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 8 BITSPERBYTE)) (\BOUT STRM (LOADBYTE N 0 BITSPERBYTE]) (\FIXPIN [LAMBDA (STRM) (* rmk%: "14-Jun-84 19:36") (* ;; "Read in a full 32 bit integer") (LOGOR (LLSH (\WIN STRM) 16) (\WIN STRM]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \DECFILEPTR MACRO ((STREAM X) (\INCFILEPTR STREAM (IMINUS X)))) (PUTPROPS \GETFILEPTR MACRO (OPENLAMBDA (STRM) (FDEVOP '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 'BLOCKIN (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \BOUTS BYTEMACRO (OPENLAMBDA (STRM BASE OFF NBYTES) (FDEVOP 'BLOCKOUT (fetch (STREAM DEVICE) of STRM) STRM BASE OFF NBYTES))) (PUTPROPS \EOFP BYTEMACRO (OPENLAMBDA (STRM) (FDEVOP 'EOFP (fetch (STREAM DEVICE) of STRM) STRM))) (PUTPROPS SIZE.FROM.LENGTH MACRO [LAMBDA (LEN) (DECLARE (LOCALVARS LEN)) (AND LEN (FOLDHI LEN BYTESPERPAGE]) ) (DECLARE%: EVAL@COMPILE (RPAQQ BitsPerByte 8) (RPAQ ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) (RPAQQ WordsPerPage 256) (CONSTANTS BitsPerByte (ByteOffsetSize (SELECTQ (SYSTEMTYPE) (VAX 10) 9)) WordsPerPage) ) (DECLARE%: EVAL@COMPILE (RPAQ \MAXFILEPTR (SUB1 (LLSH 1 30))) [CONSTANTS (\MAXFILEPTR (SUB1 (LLSH 1 30] ) (DECLARE%: EVAL@COMPILE (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))) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ MaxChar 255) (CONSTANTS MaxChar) ) ) (* ; "Buffered IO") (DEFINEQ (\BUFFERED.BIN [LAMBDA (STREAM) (* bvm%: "10-Jul-84 13:25") (PROG (OFF X) RETRY [RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL))) (replace COFFSET of STREAM with (ADD1 OFF)))] REFILL (COND ((EQ (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ)) T) (GO RETRY)) (T (RETURN X]) (\BUFFERED.PEEKBIN [LAMBDA (STREAM NOERRORFLG) (* bvm%: "24-Aug-84 17:43") (PROG (OFF X) RETRY [RETURN (\GETBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((IGEQ OFF (fetch CBUFSIZE of STREAM)) (GO REFILL))))] REFILL (COND ((EQ (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ NOERRORFLG)) T) (GO RETRY)) (T (RETURN X]) (\BUFFERED.BOUT [LAMBDA (STREAM BYTE) (* bvm%: "10-Jul-84 13:30") (CHECK (type? STREAM STREAM) (WRITEABLE STREAM)) (PROG (OFF) RETRY (\PUTBASEBYTE (OR (fetch CBUFPTR of STREAM) (GO REFILL)) (PROG1 (SETQ OFF (fetch COFFSET of STREAM)) (COND ((ILESSP OFF (fetch CBUFMAXSIZE of STREAM)) (replace COFFSET of STREAM with (ADD1 OFF))) (T (GO REFILL)))) BYTE) (replace CBUFDIRTY of STREAM with T) (RETURN 1) REFILL (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'WRITE) (GO RETRY]) (\BUFFERED.BINS [LAMBDA (STREAM DBASE OFFSET NBYTES NOERRORFLG) (* bvm%: "11-Jul-84 19:15") (* ;;; "For buffered streams, BINs NBYTES bytes from STREAM to memory starting at DBASE+OFFSET --- If NOERRORFLG then stops without error at eof. Returns number of bytes actually read") (bind (BYTESLEFT _ NBYTES) CNT END IBASE START X do [COND ((SETQ IBASE (fetch CBUFPTR of STREAM)) (* ; "Current buffer") (SETQ START (fetch COFFSET of STREAM)) (* ;  "Offset of first byte to transfer") [COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFSIZE of STREAM)) START)) BYTESLEFT) (* ; "Not a whole buffer full") (SETQ END (IPLUS START (SETQ CNT BYTESLEFT] (* ;  "First byte BEYOND whats to be read from this page") (\MOVEBYTES IBASE START DBASE OFFSET CNT) (replace COFFSET of STREAM with END) (COND ((EQ CNT BYTESLEFT) (* ; "Finished") (RETURN NBYTES)) (T (add OFFSET CNT) (SETQ BYTESLEFT (IDIFFERENCE BYTESLEFT CNT] (COND ((NULL (SETQ X (FDEVOP 'GETNEXTBUFFER (fetch DEVICE of STREAM) STREAM 'READ NOERRORFLG))) (* ; "No error at eof") (RETURN (IDIFFERENCE NBYTES BYTESLEFT))) ((NEQ X T) (* ;  "At eof, but EOF op returned a value to fake more data at eof") (RETURN (do (\PUTBASEBYTE DBASE OFFSET X) (add OFFSET 1) (COND ((EQ (add BYTESLEFT -1) 0) (RETURN NBYTES))) (SETQ X (\BIN STREAM]) (\BUFFERED.BOUTS [LAMBDA (STREAM SBASE OFFSET NBYTES) (* bvm%: "10-Jul-84 13:39") (* ;;; "For buffered streams, bouts NBYTES bytes to STREAM from SBASE+OFFSET") (bind (DEV _ (fetch DEVICE of STREAM)) CNT END DBASE START do [COND ((SETQ DBASE (fetch CBUFPTR of STREAM)) (SETQ START (fetch COFFSET of STREAM)) [COND ((IGREATERP (SETQ CNT (IDIFFERENCE (SETQ END (fetch CBUFMAXSIZE of STREAM)) START)) NBYTES) (SETQ END (IPLUS START (SETQ CNT NBYTES] (\MOVEBYTES SBASE OFFSET DBASE START CNT) (replace COFFSET of STREAM with END) (replace CBUFDIRTY of STREAM with T) (COND ((ILEQ (SETQ NBYTES (IDIFFERENCE NBYTES CNT)) 0) (RETURN)) (T (add OFFSET CNT] (FDEVOP 'GETNEXTBUFFER DEV STREAM 'WRITE]) (\BUFFERED.COPYBYTES [LAMBDA (SRC DST NBYTES) (* bvm%: "10-Jul-84 21:48") (* ;;; "Copies NBYTES bytes from buffered stream SRC to arbitrary stream DST, or copies to eof if NBYTES is NIL") (bind (NOERRORFLG _ (NULL NBYTES)) (DEV _ (fetch DEVICE of SRC)) BUF NB STARTOFFSET END do [COND ((SETQ BUF (fetch CBUFPTR of SRC)) (* ; "Copy a buffer full") [SETQ NB (IDIFFERENCE (SETQ END (fetch CBUFSIZE of SRC)) (SETQ STARTOFFSET (fetch COFFSET of SRC] [COND ((AND NBYTES (IGREATERP NB NBYTES)) (* ; "Don't copy too much") (SETQ END (IPLUS STARTOFFSET (SETQ NB NBYTES] (\BOUTS DST BUF STARTOFFSET NB) (replace COFFSET of SRC with END) (COND (NBYTES (COND ((EQ NB NBYTES) (RETURN)) (T (SETQ NBYTES (IDIFFERENCE NBYTES NB] repeatwhile (FDEVOP 'GETNEXTBUFFER DEV SRC 'READ NOERRORFLG]) ) (* ; "NULL device") (DEFINEQ (\NULLDEVICE [LAMBDA NIL (* bvm%: "30-Jan-85 22:06") (* ;; "Defines the NULL device, an infinite source or sink") (\DEFINEDEVICE 'NULL (create FDEV DEVICENAME _ 'NULL RANDOMACCESSP _ T NODIRECTORIES _ T CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) OPENFILE _ (FUNCTION \NULL.OPENFILE) REOPENFILE _ (FUNCTION \NULL.OPENFILE) BIN _ (FUNCTION \EOF.ACTION) BOUT _ (FUNCTION NILL) PEEKBIN _ [FUNCTION (LAMBDA (STREAM NOERRORFLG) (AND (NULL NOERRORFLG) (BIN STREAM] READP _ (FUNCTION NILL) BACKFILEPTR _ (FUNCTION NILL) EOFP _ (FUNCTION TRUE) RENAMEFILE _ (FUNCTION NILL) GETFILENAME _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) BLOCKIN _ (FUNCTION \EOF.ACTION) BLOCKOUT _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR) GETFILEPTR _ (FUNCTION ZERO) GETEOFPTR _ (FUNCTION ZERO) SETFILEPTR _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) SETEOFPTR _ (FUNCTION NILL]) (\NULL.OPENFILE [LAMBDA (NAME ACCESS RECOG PARAMETERS DEVICE OLDSTREAM)(* bvm%: "30-Jan-85 22:05") (OR OLDSTREAM (create STREAM USERCLOSEABLE _ T ACCESS _ ACCESS FULLFILENAME _ NIL DEVICE _ DEVICE]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\NULLDEVICE) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \IS.NOT.RANDACCESSP \ILLEGAL.DEVICEOP STREAMPROP) ) (PUTPROPS FILEIO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (33036 36357 (STREAMPROP 33046 . 33480) (GETSTREAMPROP 33482 . 33881) (PUTSTREAMPROP 33883 . 36205) (STREAMP 36207 . 36355)) (36400 38919 (\DEFPRINT.BY.NAME 36410 . 37562) ( \STREAM.DEFPRINT 37564 . 38612) (\FDEV.DEFPRINT 38614 . 38917)) (39177 44218 (\GETACCESS 39187 . 39641 ) (\SETACCESS 39643 . 44216)) (67734 72507 (\INSTALL.EXTERNALFORMAT 67744 . 68942) ( \REMOVE.EXTERNALFORMAT 68944 . 69888) (\GET.EXTERNALFORMAT.FROM.NAME 69890 . 70297) (\EXTERNALFORMAT 70299 . 72505)) (72816 75822 (\CREATE.JIS.EXTERNALFORMAT 72826 . 73390) ( \CREATE.SHIFTJIS.EXTERNALFORMAT 73392 . 74510) (\CREATE.EUC.EXTERNALFORMAT 74512 . 75076) ( \CREATE.THROUGH.EXTERNALFORMAT 75078 . 75820)) (76037 82006 (\DEFINEDEVICE 76047 . 78363) ( \GETDEVICEFROMNAME 78365 . 78838) (\GETDEVICEFROMHOSTNAME 78840 . 79884) (\REMOVEDEVICE 79886 . 81009) (\REMOVEDEVICE.NAMES 81011 . 82004)) (82007 106484 (\CLOSEFILE 82017 . 82842) (\DELETEFILE 82844 . 83138) (\DEVICEEVENT 83140 . 84910) (\GENERATEFILES 84912 . 85390) (\GENERATENEXTFILE 85392 . 86043) ( \GENERATEFILEINFO 86045 . 86506) (\GETFILENAME 86508 . 86897) (\GENERIC.READCCODE 86899 . 87535) ( \GENERIC.OUTFILEP 87537 . 88007) (\OPENFILE 88009 . 90587) (\DO.PARAMS.AT.OPEN 90589 . 92321) ( \RENAMEFILE 92323 . 92747) (\REVALIDATEFILE 92749 . 95351) (\PAGED.REVALIDATEFILELST 95353 . 96911) ( \PAGED.REVALIDATEFILES 96913 . 98632) (\PAGED.REVALIDATEFILE 98634 . 100917) (\BUFFERED.REVALIDATEFILE 100919 . 103205) (\BUFFERED.REVALIDATEFILELST 103207 . 104391) (\PRINT-REVALIDATION-RESULT 104393 . 104808) (\TRUNCATEFILE 104810 . 105201) (\FILE-CONFLICT 105203 . 106482)) (106520 111183 ( \GENERATENOFILES 106530 . 108626) (\NULLFILEGENERATOR 108628 . 108872) (\NOFILESNEXTFILEFN 108874 . 110865) (\NOFILESINFOFN 110867 . 111181)) (111302 113210 (\FILE.NOT.OPEN 111312 . 111825) ( \FILE.WONT.OPEN 111827 . 112155) (\ILLEGAL.DEVICEOP 112157 . 112439) (\IS.NOT.RANDACCESSP 112441 . 112887) (\STREAM.NOT.OPEN 112889 . 113208)) (113345 115643 (\FDEVINSTANCE 113355 . 115641)) (117193 124567 (CNDIR 117203 . 118508) (DIRECTORYNAME 118510 . 122693) (DIRECTORYNAMEP 122695 . 123311) ( HOSTNAMEP 123313 . 124120) (\ADD.CONNECTED.DIR 124122 . 124565)) (124612 154355 (\BACKFILEPTR 124622 . 124810) (\BACKPEEKBIN 124812 . 125173) (\BACKBIN 125175 . 125526) (BIN 125528 . 125745) (\BIN 125747 . 126024) (\BINS 126026 . 126312) (BOUT 126314 . 126676) (\BOUT 126678 . 126993) (\BOUTS 126995 . 127306) (COPYBYTES 127308 . 130640) (COPYCHARS 130642 . 137202) (COPYFILE 137204 . 138001) ( \COPYOPENFILE 138003 . 141422) (\INFER.FILE.TYPE 141424 . 142378) (EOFP 142380 . 142677) (FORCEOUTPUT 142679 . 142926) (\FLUSH.OPEN.STREAMS 142928 . 143284) (CHARSET 143286 . 144950) (ACCESS-CHARSET 144952 . 145169) (GETEOFPTR 145171 . 145421) (GETFILEINFO 145423 . 148548) (\TYPE.FROM.FILETYPE 148550 . 149020) (\FILETYPE.FROM.TYPE 149022 . 149201) (GETFILEPTR 149203 . 149455) (SETFILEINFO 149457 . 152959) (SETFILEPTR 152961 . 153975) (BOUT16 153977 . 154162) (BIN16 154164 . 154353)) (154458 159956 (\GENERIC.BINS 154468 . 154748) (\GENERIC.BOUTS 154750 . 155015) (\GENERIC.RENAMEFILE 155017 . 156848) (\GENERIC.OPENP 156850 . 158165) (\GENERIC.READP 158167 . 159501) (\GENERIC.CHARSET 159503 . 159954)) (159957 160296 (\MAP-OPEN-STREAMS 159967 . 160294)) (162314 164394 (\EOF.ACTION 162324 . 162575) ( \EOSERROR 162577 . 162770) (\GETEOFPTR 162772 . 162954) (\INCFILEPTR 162956 . 163306) (\PEEKBIN 163308 . 163499) (\SETCLOSEDFILELENGTH 163501 . 163835) (\SETEOFPTR 163837 . 164025) (\SETFILEPTR 164027 . 164392)) (164395 164937 (\FIXPOUT 164405 . 164705) (\FIXPIN 164707 . 164935)) (168029 177893 ( \BUFFERED.BIN 168039 . 168891) (\BUFFERED.PEEKBIN 168893 . 169675) (\BUFFERED.BOUT 169677 . 170537) ( \BUFFERED.BINS 170539 . 174224) (\BUFFERED.BOUTS 174226 . 176027) (\BUFFERED.COPYBYTES 176029 . 177891 )) (177922 180274 (\NULLDEVICE 177932 . 179950) (\NULL.OPENFILE 179952 . 180272))))) STOP \ No newline at end of file diff --git a/sources/FILEPKG b/sources/FILEPKG new file mode 100644 index 00000000..452adc78 --- /dev/null +++ b/sources/FILEPKG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "10-Aug-2020 21:24:58"  {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;11 284888 changes to%: (VARS FILEPKGCOMS) (FNS ADDTOFILES?) previous date%: " 8-Aug-2020 17:33:31" {DSK}kaplan>Local>medley3.5>lispcore>sources>FILEPKG.;9) (* ; " 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 29-Aug-89 11:46 by bvm") (PROG* ((ROOTNAME (ROOTFILENAME FILE)) (COMPILER (COMPILE-FILE? ROOTNAME)) 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 (ROOTNAME) (* ; "Edited 19-Jan-87 21:12 by Pavel") (* ;;; "Which compiler should CLEANUP use?") (LET ((TYPE (GET ROOTNAME '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 (22908 24613 (SEARCHPRETTYTYPELST 22918 . 23897) (PRETTYDEFMACROS 23899 . 24357) ( FILEPKGCOMPROPS 24359 . 24611)) (25415 59356 (CLEANUP 25425 . 26813) (COMPILEFILES 26815 . 27091) ( COMPILEFILES0 27093 . 27813) (CONTINUEDIT 27815 . 29235) (MAKEFILE 29237 . 40879) (FILECHANGES 40881 . 43216) (FILEPKG.MERGECHANGES 43218 . 44041) (FILEPKG.CHANGEDFNS 44043 . 44355) (MAKEFILE1 44357 . 48627) (COMPILE-FILE? 48629 . 49961) (MAKEFILES 49963 . 51656) (ADDFILE 51658 . 54179) (ADDFILE0 54181 . 58317) (LISTFILES 58319 . 59354)) (60044 95284 (FILEPKGCHANGES 60054 . 61404) (GETFILEPKGTYPE 61406 . 64479) (MARKASCHANGED 64481 . 66118) (FILECOMS 66120 . 66504) (WHEREIS 66506 . 67926) ( SMASHFILECOMS 67928 . 68163) (FILEFNSLST 68165 . 68327) (FILECOMSLST 68329 . 68813) (UPDATEFILES 68815 . 74115) (INFILECOMS? 74117 . 76020) (INFILECOMTAIL 76022 . 77162) (INFILECOMS 77164 . 77325) ( INFILECOM 77327 . 87536) (INFILECOMSVALS 87538 . 87865) (INFILECOMSVAL 87867 . 88869) (INFILECOMSPROP 88871 . 89700) (IFCPROPS 89702 . 90963) (IFCEXPRTYPE 90965 . 91476) (IFCPROPSCAN 91478 . 92531) ( IFCDECLARE 92533 . 93844) (INFILEPAIRS 93846 . 94178) (INFILECOMSMACRO 94180 . 95282)) (95319 126095 ( FILES? 95329 . 97522) (FILES?1 97524 . 98174) (FILES?PRINTLST 98176 . 98958) (ADDTOFILES? 98960 . 109562) (ADDTOFILE 109564 . 110480) (WHATIS 110482 . 112458) (ADDTOCOMS 112460 . 114104) (ADDTOCOM 114106 . 120653) (ADDTOCOM1 120655 . 121826) (ADDNEWCOM 121828 . 122878) (MAKENEWCOM 122880 . 124723) (DEFAULTMAKENEWCOM 124725 . 126093)) (126165 128982 (MERGEINSERT 126175 . 128518) (MERGEINSERT1 128520 . 128980)) (130501 141413 (DELFROMFILES 130511 . 131361) (DELFROMCOMS 131363 . 133042) (DELFROMCOM 133044 . 138912) (DELFROMCOM1 138914 . 139711) (REMOVEITEM 139713 . 140587) (MOVETOFILE 140589 . 141411)) (141627 143996 (SAVEPUT 141637 . 143994)) (144121 152445 (UNMARKASCHANGED 144131 . 145839) ( PREEDITFN 145841 . 148352) (POSTEDITPROPS 148354 . 150855) (POSTEDITALISTS 150857 . 152443)) (152594 173148 (ALISTS.GETDEF 152604 . 152983) (ALISTS.WHENCHANGED 152985 . 153629) (CLEARCLISPARRAY 153631 . 154805) (EXPRESSIONS.WHENCHANGED 154807 . 155181) (MAKEALISTCOMS 155183 . 156256) (MAKEFILESCOMS 156258 . 157695) (MAKELISPXMACROSCOMS 157697 . 159715) (MAKEPROPSCOMS 159717 . 160415) ( MAKEUSERMACROSCOMS 160417 . 162217) (PROPS.WHENCHANGED 162219 . 162840) (FILEGETDEF.LISPXMACROS 162842 . 164284) (FILEGETDEF.ALISTS 164286 . 164905) (FILEGETDEF.RECORDS 164907 . 165838) (FILEGETDEF.PROPS 165840 . 166632) (FILEGETDEF.MACROS 166634 . 167694) (FILEGETDEF.VARS 167696 . 168112) (FILEGETDEF.FNS 168114 . 169478) (FILEPKGCOMS.PUTDEF 169480 . 171920) (FILES.PUTDEF 171922 . 172879) (VARS.PUTDEF 172881 . 173024) (FILES.WHENCHANGED 173026 . 173146)) (175170 182603 (RENAME 175180 . 176581) ( CHANGECALLERS 176583 . 182601)) (182604 230552 (SHOWDEF 182614 . 183407) (COPYDEF 183409 . 185883) ( GETDEF 185885 . 188161) (GETDEFCOM 188163 . 189129) (GETDEFCOM0 189131 . 190477) (GETDEFCURRENT 190479 . 196899) (GETDEFERR 196901 . 198202) (GETDEFFROMFILE 198204 . 202484) (GETDEFSAVED 202486 . 203590) (PUTDEF 203592 . 204295) (EDITDEF 204297 . 205274) (DEFAULT.EDITDEF 205276 . 208112) (EDITDEF.FILES 208114 . 208315) (LOADDEF 208317 . 208493) (DWIMDEF 208495 . 209349) (DELDEF 209351 . 212365) ( DELFROMLIST 212367 . 212871) (HASDEF 212873 . 219195) (GETFILEDEF 219197 . 219719) (SAVEDEF 219721 . 221380) (UNSAVEDEF 221382 . 222278) (COMPAREDEFS 222280 . 225582) (COMPARE 225584 . 226288) (TYPESOF 226290 . 230550)) (230619 235662 (FIXEDITDATE 230629 . 234132) (EDITDATE? 234134 . 235660)) (236081 244667 (FILEPKGCOM 236091 . 241024) (FILEPKGTYPE 241026 . 244665)) (256704 271256 (FINDCALLERS 256714 . 257229) (EDITCALLERS 257231 . 264889) (EDITFROMFILE 264891 . 270571) (FINDATS 270573 . 270845) ( LOOKIN 270847 . 271254)) (271257 272984 (SEPRCASE 271267 . 272982)) (273501 279043 (IMPORTFILE 273511 . 274485) (IMPORTEVAL 274487 . 275367) (IMPORTFILESCAN 275369 . 275790) (CHECKIMPORTS 275792 . 277128 ) (GATHEREXPORTS 277130 . 278453) (\DUMPEXPORTS 278455 . 279041)) (279381 281589 (CLEARFILEPKG 279391 . 281587))))) STOP \ No newline at end of file diff --git a/sources/FILESETS b/sources/FILESETS new file mode 100644 index 00000000..44f2109e --- /dev/null +++ b/sources/FILESETS @@ -0,0 +1,175 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "29-Jan-98 16:26:53" {DSK}disk2>jdstools>lc3>lispcore3.0>sources>FILESETS.;2 7340 + + changes to%: (VARS RENAMETYPES) + + previous date%: " 9-Apr-90 16:57:44" +{DSK}disk2>jdstools>lc3>lispcore3.0>sources>FILESETS.;1) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1998 by Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT FILESETSCOMS) + +(RPAQQ FILESETSCOMS ( + +(* ;;; "contains all of the lists of files which are used in various ways") + + + (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") + + (VARS * FILESETS) + (VARS EXPORTFILES) + (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES + DATABASEFILES) + (VARS DEADFNS))) + + + +(* ;;; "contains all of the lists of files which are used in various ways") + + + + +(* ;; +"I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" +) + + +(RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET + 9LISPSET)) + +(RPAQQ 0LISPSET + (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT + LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM + LLREAD LLCHAR LLSTK LLDATATYPE IOCHAR LLKEY LLTIMER)) + +(RPAQQ 1LISPSET + (ASTACK DTDECLARE ATBL LLCODE ACODE COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT + ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS + LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC + CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ + COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS + MAIKOBITBLT MAIKOINIT)) + +(RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) + +(RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) + +(RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) + +(RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) + +(RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) + +(RPAQQ 7LISPSET + (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT + INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT + CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN + DPUPFTP FLOPPY)) + +(RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) + +(RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) + +(RPAQQ EXPORTFILES + (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW + LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY + ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER + LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) + +(RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) + +(RPAQQ MAKEINITTYPES + ((NIL INIT (0 1) + 2LISPSET 1600) + (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD + LLCHAR TINYPATCH)) + (MACROTEST MACROTEST ((MACROTEST) + 0 1) + 2LISPSET) + (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) + (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) + (NULL NULL ((DUMMY))) + (MILLITEST MILLITEST + ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT + LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) + (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) + 2LISPSET))) + +(RPAQQ RENAMETYPES + ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS + MODARITH LLFAULT LLKEY LLBFS LLTIMER) + (RENAMEDFILE . I-NEW) + (SUBNAME . MKI.SUBFNS) + (COMSNAME . INEWCOMS) + (EXTRACOMS (VARS INITPTRS INITVALUES) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + MAKEINIT))) + (MKI.SUBFNS) + (INEWCOMS) + (VALUES . INITVALUES) + (PTRS . INITPTRS) + (PREFIX . I.) + (VAG2FN . I.VAG2)) + (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK + RENAMEMACROS MODARITH LLFAULT) + (RENAMEDFILE . RDSYS) + (SUBNAME . RD.SUBFNS) + (COMSNAME . RDCOMS) + (EXTRACOMS + + (* ;; "YOU MUST REMAKE THIS FILE using (DORENAME 'R) (after CONNing to library) whenever the SYSOUT layout changes in LLPARAMS (e.g., if MDSTypeTable moves)") + + (FILES VMEM) + (VARS RDVALS RDPTRS) + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + VMEM))) + (RD.SUBFNS (\CALLME . *)) + (RDCOMS) + (PTRS . RDPTRS) + (PREFIX . V) + (VAG2FN . VVAG2) + (VALUES . RDVALS) + (RDPTRS) + (RDVALUES)))) + +(RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 + DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) + +(RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) + +(RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) + (3LISPSET DLAP) + (4LISPSET DFILE DMISC) + 7LISPSET + (8LISPSET MAKEINIT MEM) + 9LISPSET + (10LISPSET LLPARAMS) + (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) + +(RPAQQ DEADFNS ((PUTBASE \PUTBASE) + (GETBASE \GETBASE) + (ADDBASE \ADDBASE) + (GETBASEBYTE \GETBASEBYTE) + (PUTBASEBYTE \PUTBASEBYTE) + (PUTBASEPTR \PUTBASEPTR) + (HILOC \HILOC) + (LOLOC \LOLOC) + (VAG2 \VAG2) + (PAGEBASE NIL) + (PAGELOC NIL) + (WordsPerPage WORDSPERPAGE) + (ALTOMACRO DMACRO) + (\STACKSPACE ??) + (GETBASEPTR \GETBASEPTR) + (FPLUS2) + (FTIMES2) + (CREATECELL \CREATECELL))) +(PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 +1998)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/sources/FILESETS.NOETHER b/sources/FILESETS.NOETHER new file mode 100644 index 00000000..0ac33fbb --- /dev/null +++ b/sources/FILESETS.NOETHER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "15-Feb-90 16:21:14" {DSK}/users/osamu/SUNLOADUP/FILESETS.;1 6850 previous date%: " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ( (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (* ;; "'90/02/15 osamu: REMOVE LLETHER from 1LISPSET.") (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/FILESETS.ORIG b/sources/FILESETS.ORIG new file mode 100644 index 00000000..a88668a2 --- /dev/null +++ b/sources/FILESETS.ORIG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 5-Apr-89 16:28:12" {ERIS}SUNLOADUP>FILESETS.;7 7015 changes to%: (VARS 1LISPSET) previous date%: " 6-Feb-89 15:49:03" {ERIS}SUNLOADUP>FILESETS.;6) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ( (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/FILESETS.PUP b/sources/FILESETS.PUP new file mode 100644 index 00000000..3dac6662 --- /dev/null +++ b/sources/FILESETS.PUP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 9-Apr-90 16:57:44" {DSK}mitani>SUNLOADUP>FILESETS;2 5281 changes to%: (VARS 1LISPSET) previous date%: " 5-Apr-89 16:28:12" {DSK}mitani>SUNLOADUP>FILESETS;1) (* " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FILESETSCOMS) (RPAQQ FILESETSCOMS ((* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel") (VARS * FILESETS) (VARS EXPORTFILES) (VARS MAKEINITFILES MAKEINITTYPES RENAMETYPES ABCFILES READSYSFILES DATABASEFILES) (VARS DEADFNS))) (* ;;; "contains all of the lists of files which are used in various ways") (* ;; "I took out the EXPORT of the filesets because it led to inconsistency when one had loaded ABC. -- Pavel" ) (RPAQQ FILESETS (0LISPSET 1LISPSET 2LISPSET 3LISPSET 4LISPSET 5LISPSET 6LISPSET 7LISPSET 8LISPSET 9LISPSET)) (RPAQQ 0LISPSET (PACKAGE-CONVERSION-TABLE LLFAULT LLSUBRS LLBFS LLNEW FILEIO IMAGEIO LLBASIC LLGC LLARRAYELT LLINTERP LLMVS DEFSTRUCT-RUN-TIME SETF-RUNTIME CMLSEQBASICS LLARITH LLFLOAT LLBIGNUM LLREAD LLCHAR LLSTK LLDATATYPE LLKEY LLTIMER)) (RPAQQ 1LISPSET (ASTACK DTDECLARE ATBL LLCODE ACODE IOCHAR COREIO AOFD ADIR PMAP VANILLADISK MOD44IO ATERM APRINT ABASIC AERROR AINTERRUPT MISC BOOTSTRAP CMLMACROS CMLEVAL CMLPROGV CMLSPECIALFORMS LLRESTART LLERROR LLSYMBOL LLPACKAGE PACKAGE-STARTUP CONDITION-PACKAGE XCL-PACKAGE PROC CMLARRAY DSK UFS UFSCALLC LLETHER PUP LEAF PASSWORDS FONT SUNFONT LLDISPLAY APUTDQ COMPATIBILITY DMISC CMLMACROS CMLLIST CMLCHARACTER CMLREADTABLE MAIKOLOADUPFNS MAIKOBITBLT MAIKOINIT)) (RPAQQ 2LISPSET (MACHINEINDEPENDENT POSTLOADUP)) (RPAQQ 3LISPSET (MACROS DLAP BYTECOMPILER COMPILE)) (RPAQQ 4LISPSET (EDIT WEDIT HELPDL PRETTY COMMENT BREAK ADVISE LOADFNS FILEPKG DFILE DMISC)) (RPAQQ 5LISPSET (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD ASSIST)) (RPAQQ 6LISPSET (MSANALYZE MSPARSE MASTERSCOPE HPRINT BRKDWN MATCH)) (RPAQQ 7LISPSET (ADISPLAY DEXEC AARITH AFONT HARDCOPY PRESS HLDISPLAY MENU WINDOW WBREAK INSPECT INSPECT-CLOSURE BSP CHAT TRSERVER 10MBDRIVER LLNS DISKDLION SPP COURIER NSPRINT CLEARINGHOUSE NSFILING INTERPRESS ADDARITH MACROAUX DEDIT DSPRINTDEF NEWPRINTDEF TTYIN DPUPFTP FLOPPY)) (RPAQQ 8LISPSET (MAKEINIT MEM RENAMEFNS)) (RPAQQ 9LISPSET (LLFCOMPILE VMEM READSYS APS PCALLSTATS UPCSTATS REMOTEVMEM)) (RPAQQ EXPORTFILES (FILESETS MODARITH LLPARAMS LLCODE AERROR AOFD APRINT ATERM LLARRAYELT LLDATATYPE LLNEW LLBASIC LLCHAR LLSTK PMAP LLGC ATBL FILEIO LLARITH LLFLOAT FONT LLKEY LLDISPLAY ADISPLAY AINTERRUPT PUP RENAMEMACROS HLDISPLAY WINDOW MACROAUX ADDARITH LLFAULT LLTIMER LLETHER IMAGEIO PROC LLREAD PASSWORDS INTERPRESS HARDCOPY CMLARRAY LLSUBRS)) (RPAQQ MAKEINITFILES (MAKEINIT MEM I-NEW)) (RPAQQ MAKEINITTYPES ((NIL INIT (0 1) 2LISPSET 1600) (SMALLINIT SMALLINIT (LLFAULT LLSUBRS LLNEW FILEIO LLBASIC LLGC LLINTERP LLARITH LLREAD LLCHAR TINYPATCH)) (MACROTEST MACROTEST ((MACROTEST) 0 1) 2LISPSET) (MICROTEST MICROTEST ((MICROTEST LLFAULT LLSTK LLSUBRS LLKEY LLBFS))) (NANOTEST NANOTEST ((MICROTEST LLSUBRS))) (NULL NULL ((DUMMY))) (MILLITEST MILLITEST ((MACROTEST LLFAULT LLSUBRS LLNEW LLBASIC LLGC LLINTERP LLARITH LLFLOAT LLARRAYELT LLSTK LLDATATYPE LLKEY ABASIC LLCHAR ASTACK MISC APUTDQ))) (CHECKARRAYS CHECKARRAYS (CHECKARRAYSPACE 0 1) 2LISPSET))) (RPAQQ RENAMETYPES ((I (FILES LLPARAMS LLCODE LLARRAYELT LLCHAR LLNEW LLBASIC LLDATATYPE LLGC LLSTK RENAMEMACROS MODARITH LLFAULT LLKEY LLBFS LLTIMER) (RENAMEDFILE . I-NEW) (SUBNAME . MKI.SUBFNS) (COMSNAME . INEWCOMS) (EXTRACOMS (VARS INITPTRS INITVALUES) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) MAKEINIT))) (MKI.SUBFNS) (INEWCOMS) (VALUES . INITVALUES) (PTRS . INITPTRS) (PREFIX . I.) (VAG2FN . I.VAG2)) (R (FILES LLCODE LLPARAMS LLBASIC LLDATATYPE LLNEW ACODE LLARRAYELT LLCHAR LLINTERP LLSTK RENAMEMACROS MODARITH LLFAULT) (RENAMEDFILE . RDSYS) (SUBNAME . RD.SUBFNS) (COMSNAME . RDCOMS) (EXTRACOMS (FILES VMEM) (VARS RDVALS RDPTRS) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) VMEM))) (RD.SUBFNS (\CALLME . *)) (RDCOMS) (PTRS . RDPTRS) (PREFIX . V) (VAG2FN . VVAG2) (VALUES . RDVALS) (RDPTRS) (RDVALUES)))) (RPAQQ ABCFILES (LOADABC COMPILEBANG SAMEDIR WHEREIS COMPILEFORMSLIST CHECKSET CMACROS DCODEFOR10 DTDECLARE BYTECOMPILER DLAP LLCODE ACODE MACROAUX)) (RPAQQ READSYSFILES (RDSYS READSYS VMEM REMOTEVMEM)) (RPAQQ DATABASEFILES (0LISPSET 1LISPSET (2LISPSET ACODE) (3LISPSET DLAP) (4LISPSET DFILE DMISC) 7LISPSET (8LISPSET MAKEINIT MEM) 9LISPSET (10LISPSET LLPARAMS) (NIL CHECKARRAYSPACE MAKEINEW PMEMSTATS PPAGESTATS LLFCOMPILE))) (RPAQQ DEADFNS ((PUTBASE \PUTBASE) (GETBASE \GETBASE) (ADDBASE \ADDBASE) (GETBASEBYTE \GETBASEBYTE) (PUTBASEBYTE \PUTBASEBYTE) (PUTBASEPTR \PUTBASEPTR) (HILOC \HILOC) (LOLOC \LOLOC) (VAG2 \VAG2) (PAGEBASE NIL) (PAGELOC NIL) (WordsPerPage WORDSPERPAGE) (ALTOMACRO DMACRO) (\STACKSPACE ??) (GETBASEPTR \GETBASEPTR) (FPLUS2) (FTIMES2) (CREATECELL \CREATECELL))) (PUTPROPS FILESETS COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/FLOPPY b/sources/FLOPPY new file mode 100644 index 00000000..e0ee3e02 --- /dev/null +++ b/sources/FLOPPY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 4-Jan-93 18:45:49" {DSK}lde>lispcore>sources>FLOPPY.;2 362267 previous date%: "16-May-90 17:50:46" {DSK}lde>lispcore>sources>FLOPPY.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FLOPPYCOMS) (RPAQQ FLOPPYCOMS [ (* ;; "FLOPPY disk driver") (COMS (* ;; "FACE") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (C.NOP 0) (C.READSECTOR 1) (C.WRITESECTOR 2) (C.WRITEDELETEDSECTOR 3) (C.READID 4) (C.FORMATTRACK 5) (C.RECALIBRATE 6) (C.INITIALIZE 7) (C.ESCAPE 8) (SC.NOP 0) (SC.DISKCHANGECLEAR 1) (S.DOOROPENED 32768) (S.TWOSIDED 8192) (S.DISKID 4096) (S.ERROR 2048) (S.RECALIBRATEERROR 512) (S.DATALOST 256) (S.NOTREADY 128) (S.WRITEPROTECT 64) (S.DELETEDDATA 32) (S.RECORDNOTFOUND 16) (S.CRCERROR 8) (S.TRACK0 4) (S.INDEX 2) (S.BUSY 1) (R.OK 0) (R.BUSY S.BUSY) (R.CRCERROR (LOGOR S.ERROR S.CRCERROR)) (R.DATALOST (LOGOR S.ERROR S.DATALOST)) (R.DOOROPENED (LOGOR S.ERROR S.DOOROPENED)) (R.DOORISOPEN (LOGOR S.ERROR S.DOOROPENED S.NOTREADY)) (R.DOORISOPEN2 (LOGOR S.DOOROPENED S.NOTREADY)) (R.NOTREADY (LOGOR S.ERROR S.NOTREADY)) (R.RECALIBRATEERROR (LOGOR S.ERROR S.RECALIBRATEERROR)) (R.RECORDNOTFOUND (LOGOR S.ERROR S.RECORDNOTFOUND)) (R.WRITEPROTECT (LOGOR S.ERROR S.WRITEPROTECT)) (R.READERRORMASK (LOGOR S.DOOROPENED S.ERROR S.RECALIBRATEERROR S.DATALOST S.NOTREADY S.RECORDNOTFOUND S.CRCERROR )) (R.WRITEERRORMASK (LOGOR R.READERRORMASK S.WRITEPROTECT)) (R.INFOMASK (LOGOR S.TWOSIDED S.WRITEPROTECT S.TRACK0)) (FLOPPYIOCB.SIZE 16) (B128 0) (B256 1) (B512 2) (B1024 3) (IBM 0) (TROY 1) (SINGLE 0) (DOUBLE 8) (NoBits 0) (IDLENGTH 3) (SEAL.PSECTOR9 49932) (VERSION.PSECTOR9 1) (LABELMAXLENGTH.PSECTOR9 40) (SEAL.PMPAGE 13003) (VERSION.PMPAGE 1) (SEAL.PFILELIST 45771) (VERSION.PFILELIST 1) (PMPAGEETYPE.FREE 0) (PMPAGEETYPE.FILE 1) (PMPAGEETYPE.PFILELIST 2) (PMPAGEETYPE.BADSECTORS 3) (SEAL.PLPAGE 43690) (VERSION.PLPAGE 1) (VERSION.DATA 2222) (NAMEMAXLENGTH.PLPAGE 100) (FILETYPE.FREE 0) (FILETYPE.FILE 2052) (FILETYPE.PFILELIST 2054))) (INITRECORDS DISKADDRESS FLOPPYIOCB FLOPPYRESULT PSECTOR9 PMPAGE PLPAGE PFILELIST PFLE) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS DISKADDRESS FLOPPYIOCB FLOPPYRESULT PSECTOR9 PMPAGE PLPAGE PFILELIST PFLE)) (FNS \FLOPPY.TRANSLATEFLOPPYRESULT \FLOPPY.SEVERE.ERROR \FLOPPY.TRANSLATEPMPAGEETYPE \FLOPPY.TRANSLATEFILETYPE \FLOPPY.MTL.FIXP \FLOPPY.LTM.FIXP \FLOPPY.MTL.IDATE \FLOPPY.LTM.IDATE)) (COMS (* ; "`HEAD' *") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (IBMS128 0) (IBMS256 1) (IBMS512 2) (IBMS1024 3) (IBMD128 4) (IBMD256 5) (IBMD512 6) (IBMD1024 7))) (INITVARS (\FLOPPY.DEBUG NIL) (\FLOPPY.CYLINDERS 77) (\FLOPPY.TRACKSPERCYLINDER 2) (\FLOPPY.SECTORSPERTRACK 15) (\FLOPPYMPERRORS 0) (\FLOPPYMPERRORSFLG NIL) (\FLOPPY.MOUNTEDP.DOVETIME NIL) (\FLOPPY.MOUNTEDP.DOVEANSWER NIL)) (FNS \FLOPPY.TRANSLATESETUP \FLOPPY.SETUP.IOCB \FLOPPY.CHECK.FLOPPYIOCB \FLOPPY.DENSITY \FLOPPY.SECTORLENGTH \FLOPPY.ENCODEDSECTORLENGTH \FLOPPY.GAP3 \FLOPPY.SECTORSPERTRACK \FLOPPY.RUN \FLOPPY.ERROR \FLOPPY.LOCK.BUFFER \FLOPPY.UNLOCK.BUFFER \FLOPPY.PREPAREFORCRASH \FLOPPY.COMMAND \FLOPPY.INITIALIZE \FLOPPY.NOP \FLOPPY.RECALIBRATE \FLOPPY.RECOVER \FLOPPY.TRANSFER \FLOPPY.READSECTOR \FLOPPY.WRITESECTOR \FLOPPY.FORMATTRACKS \FLOPPY.DISKCHANGECLEAR \FLOPPY.MOUNTEDP \FLOPPY.CAN.READP \FLOPPY.CAN.WRITEP \FLOPPY.WRITEABLEP \FLOPPY.TWOSIDEDP \FLOPPY.DUMP \FLOPPY.DEBUG)) (COMS (* ; "`COMMON' *") (INITVARS (\FLOPPYFDEV NIL) (\FLOPPYLOCK NIL) (\FLOPPY.SCRATCH.BUFFER NIL) (\FLOPPY.SCRATCH.BUFFER2 NIL) (\FLOPPY.SCRATCH.FLOPPYIOCB NIL) (\FLOPPY.IBMS128.FLOPPYIOCB NIL) (\FLOPPY.IBMD256.FLOPPYIOCB NIL) (\FLOPPY.IBMD512.FLOPPYIOCB NIL) (\FLOPPYIOCBADDR NIL) (\FLOPPYIOCB NIL) (\FLOPPYRESULT NIL)) (GLOBALRESOURCES \FLOPPY.SCRATCH.FLOPPYIOCB \FLOPPY.IBMS128.FLOPPYIOCB \FLOPPY.IBMD256.FLOPPYIOCB \FLOPPY.IBMD512.FLOPPYIOCB \FLOPPY.SCRATCH.BUFFER \FLOPPY.SCRATCH.BUFFER2) (INITRECORDS FLOPPYSTREAM FILEGENOBJ GENFILESTATE) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FLOPPYSTREAM FILEGENOBJ GENFILESTATE)) (FNS FLOPPY.RESTART FLOPPY.MODE \FLOPPY.SETUP.HARDWARE \FLOPPY.EVENTFN \FLOPPY.HOSTNAMEP \FLOPPY.ADDDEVICENAME \FLOPPY.ASSUREFILENAME \FLOPPY.OTHERINFO \FLOPPY.LEXASSOC \FLOPPY.LEXPUTASSOC \FLOPPY.LEXREMOVEASSOC \FLOPPY.CACHED.READ \FLOPPY.CACHED.WRITE \FLOPPY.OPEN \FLOPPY.CLOSE \FLOPPY.FLUSH \FLOPPY.UNCACHED.READ \FLOPPY.UNCACHED.WRITE \FLOPPY.EXISTSP \FLOPPY.BREAK \FLOPPY.MESSAGE \FLOPPY.BUFFER)) (COMS (* ; "`PILOT' *") (INITVARS (\PFLOPPYPSECTOR9 NIL) (\PFLOPPYPFILELIST NIL) (\PFLOPPYINFO NIL) (\PFLOPPYFDEV NIL)) (INITRECORDS PFALLOC PFINFO PFLOPPYFDEV) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS PFALLOC PFINFO PFLOPPYFDEV)) (FNS \PFLOPPY.INIT \PFLOPPY.OPEN \PFLOPPY.OPEN.PSECTOR9 \PFLOPPY.GET.PSECTOR9 \PFLOPPY.OPEN.PFILELIST \PFLOPPY.DAMAGED \PFLOPPY.OPENFILE \PFLOPPY.OPENFILE1 \PFLOPPY.OPENOLDFILE \PFLOPPY.OPENNEWFILE \PFLOPPY.ASSURESTREAM \PFLOPPY.GETFILEINFO \PFLOPPY.GETFILEINFO1 \PFLOPPY.SETFILEINFO \PFLOPPY.CLOSEFILE \PFLOPPY.CLOSEFILE1 \PFLOPPY.DELETEFILE \PFLOPPY.GENERATEFILES \PFLOPPY.NEXTFILEFN \PFLOPPY.FILEINFOFN \PFLOPPY.RENAMEFILE \PFLOPPY.STREAMS.AGAINST \PFLOPPY.STREAMS.USING \PFLOPPY.READPAGES \PFLOPPY.READPAGE \PFLOPPY.READPAGENO \PFLOPPY.WRITEPAGENO \PFLOPPY.PAGENOTODISKADDRESS \PFLOPPY.DISKADDRESSTOPAGENO \PFLOPPY.DIR.GET \PFLOPPY.DIR.PUT \PFLOPPY.DIR.REMOVE \PFLOPPY.DIR.VERSION \PFLOPPY.GETFILENAME \PFLOPPY.CREATE.PFILELIST \PFLOPPY.ADD.TO.PFILELIST \PFLOPPY.DELETE.FROM.PFILELIST \PFLOPPY.SAVE.PFILELIST \PFLOPPY.SAVE.PSECTOR9 \PFLOPPY.WRITEPAGES \PFLOPPY.WRITEPAGE \PFLOPPY.TRUNCATEFILE \PFLOPPY.FORMAT \PFLOPPY.CONFIRM \PFLOPPY.GET.NAME \PFLOPPY.SET.NAME)) (COMS (* ; "`ALLOCATE' *") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MINIMUM.ALLOCATION 5) (DEFAULT.ALLOCATION 50))) (INITVARS (\FLOPPY.ALLOCATIONS.BITMAP NIL)) (FNS \PFLOPPY.ALLOCATE \PFLOPPY.ALLOCATE.LARGEST \PFLOPPY.TRUNCATE \PFLOPPY.DEALLOCATE \PFLOPPY.EXTEND \PFLOPPY.GAINSPACE \PFLOPPY.GAINSPACE.MERGE \PFLOPPY.ALLOCATE.WATCHDOG \PFLOPPY.FREE.PAGES \PFLOPPY.LENGTHS \PFLOPPY.STARTS \PFLOPPY.ICHECK \PFLOPPY.ALLOCATIONS)) (COMS (* ; "`SERVICES' *") (FNS FLOPPY.FREE.PAGES FLOPPY.FORMAT FLOPPY.NAME FLOPPY.GET.NAME FLOPPY.SET.NAME FLOPPY.CAN.READP FLOPPY.CAN.WRITEP FLOPPY.WAIT.FOR.FLOPPY)) (COMS (* ; "`SYSOUT' *") (INITVARS (\SFLOPPYINFO NIL) (\SFLOPPYFDEV NIL) (\HFLOPPY.MAXPAGES NIL) (\SFLOPPY.PAGENO NIL) (\SFLOPPY.FLOPPYNO NIL) (\SFLOPPY.PAGES NIL) (\SFLOPPY.HUGELENGTH NIL) (\SFLOPPY.HUGEPAGELENGTH NIL) (\SFLOPPY.IWRITEDATE NIL) (\SFLOPPY.FLOPPYNAME "Lisp Sysout ") (\SFLOPPY.FILENAME 'lisp.sysout) (\SFLOPPY.RECOG NIL) (\SFLOPPY.OTHERINFO NIL) (\SFLOPPY.SLOWFLG T) (\SFLOPPY.HACK.MODE NIL) (\SFLOPPY.HACK.STREAM NIL)) (FNS \SFLOPPY.INIT \SFLOPPY.GETFILEINFO \SFLOPPY.OPENHUGEFILE \SFLOPPY.WRITEPAGES \SFLOPPY.WRITEPAGE \SFLOPPY.READPAGES \SFLOPPY.READPAGE \SFLOPPY.CLOSEHUGEFILE \SFLOPPY.INPUTFLOPPY \SFLOPPY.OUTPUTFLOPPY \SFLOPPY.CLOSEFLOPPY \SFLOPPY.HACK)) (COMS (* ; "`HUGE' *") (INITVARS (\HFLOPPYINFO NIL) (\HFLOPPYFDEV NIL) (\HFLOPPY.MAXPAGES NIL) (\HFLOPPY.PAGENO NIL) (\HFLOPPY.FLOPPYNO NIL) (\HFLOPPY.HUGELENGTH NIL) (\HFLOPPY.HUGEPAGELENGTH NIL) (\HFLOPPY.IWRITEDATE NIL) (\HFLOPPY.FLOPPYNAME NIL) (\HFLOPPY.FILENAME NIL) (\HFLOPPY.RECOG NIL) (\HFLOPPY.OTHERINFO NIL) (\HFLOPPY.SLOWFLG T)) (FNS \HFLOPPY.INIT \HFLOPPY.GETFILEINFO \HFLOPPY.OPENHUGEFILE \HFLOPPY.WRITEPAGES \HFLOPPY.WRITEPAGE \HFLOPPY.READPAGES \HFLOPPY.READPAGE \HFLOPPY.CLOSEHUGEFILE \HFLOPPY.INPUTFLOPPY \HFLOPPY.OUTPUTFLOPPY \HFLOPPY.CLOSEFLOPPY)) (COMS (* ; "`SCAVENGE' *") (INITVARS (\FLOPPY.SCAVENGE.IDATE NIL)) (FNS FLOPPY.SCAVENGE \PFLOPPY.SCAVENGE \PFLOPPY.SCAVENGE.PMPAGES \PFLOPPY.SCAVENGE.PMPAGEA \PFLOPPY.SCAVENGE.PMPAGE.AFTER \PFLOPPY.SCAVENGE.PMPAGE.AFTER1 \PFLOPPY.SCAVENGE.PLPAGES \PFLOPPY.SCAVENGE.PSECTOR9 \PFLOPPY.SCAVENGE.PFILELIST)) (COMS (* ; "`COPY' *") (FNS FLOPPY.TO.FILE FLOPPY.FROM.FILE)) (COMS (* ; "`COMPACT' *") (FNS FLOPPY.COMPACT \PFLOPPY.COMPACT \PFLOPPY.COMPACT.PFALLOCS \PFLOPPY.COMPACT.PFALLOC \PFLOPPY.COMPACT.PSECTOR9 \PFLOPPY.COMPACT.PFILELIST)) (COMS (* ; "`ARCHIVE' *") (FNS FLOPPY.ARCHIVE FLOPPY.UNARCHIVE)) (GLOBALVARS \FLOPPY.DEBUG \FLOPPY.INSPECTW \FLOPPYFDEV \FLOPPYLOCK \FLOPPYIOCBADDR \FLOPPYIOCB \FLOPPYRESULT \FLOPPY.MODE.BEFORE.EVENT \PFLOPPYPSECTOR9 \PFLOPPYPFILELIST \PFLOPPYINFO \PFLOPPYFDEV \FLOPPY.ALLOCATIONS.BITMAP \SFLOPPYINFO \SFLOPPYFDEV \HFLOPPY.MAXPAGES \SFLOPPY.PAGENO \SFLOPPY.FLOPPYNO \SFLOPPY.HUGELENGTH \SFLOPPY.HUGEPAGELENGTH \SFLOPPY.IWRITEDATE \SFLOPPY.FILENAME \SFLOPPY.RECOG \SFLOPPY.FLOPPYNAME \SFLOPPY.SLOWFLG \HFLOPPYINFO \HFLOPPYFDEV \HFLOPPY.MAXPAGES \HFLOPPY.PAGENO \HFLOPPY.FLOPPYNO \HFLOPPY.HUGELENGTH \HFLOPPY.HUGEPAGELENGTH \HFLOPPY.IWRITEDATE \HFLOPPY.RECOG \HFLOPPY.FILENAME \HFLOPPY.SLOWFLG \FLOPPY.SCAVENGE.IDATE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (FLOPPY.RESTART]) (* ;; "FLOPPY disk driver") (* ;; "FACE") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ C.NOP 0) (RPAQQ C.READSECTOR 1) (RPAQQ C.WRITESECTOR 2) (RPAQQ C.WRITEDELETEDSECTOR 3) (RPAQQ C.READID 4) (RPAQQ C.FORMATTRACK 5) (RPAQQ C.RECALIBRATE 6) (RPAQQ C.INITIALIZE 7) (RPAQQ C.ESCAPE 8) (RPAQQ SC.NOP 0) (RPAQQ SC.DISKCHANGECLEAR 1) (RPAQQ S.DOOROPENED 32768) (RPAQQ S.TWOSIDED 8192) (RPAQQ S.DISKID 4096) (RPAQQ S.ERROR 2048) (RPAQQ S.RECALIBRATEERROR 512) (RPAQQ S.DATALOST 256) (RPAQQ S.NOTREADY 128) (RPAQQ S.WRITEPROTECT 64) (RPAQQ S.DELETEDDATA 32) (RPAQQ S.RECORDNOTFOUND 16) (RPAQQ S.CRCERROR 8) (RPAQQ S.TRACK0 4) (RPAQQ S.INDEX 2) (RPAQQ S.BUSY 1) (RPAQQ R.OK 0) (RPAQ R.BUSY S.BUSY) (RPAQ R.CRCERROR (LOGOR S.ERROR S.CRCERROR)) (RPAQ R.DATALOST (LOGOR S.ERROR S.DATALOST)) (RPAQ R.DOOROPENED (LOGOR S.ERROR S.DOOROPENED)) (RPAQ R.DOORISOPEN (LOGOR S.ERROR S.DOOROPENED S.NOTREADY)) (RPAQ R.DOORISOPEN2 (LOGOR S.DOOROPENED S.NOTREADY)) (RPAQ R.NOTREADY (LOGOR S.ERROR S.NOTREADY)) (RPAQ R.RECALIBRATEERROR (LOGOR S.ERROR S.RECALIBRATEERROR)) (RPAQ R.RECORDNOTFOUND (LOGOR S.ERROR S.RECORDNOTFOUND)) (RPAQ R.WRITEPROTECT (LOGOR S.ERROR S.WRITEPROTECT)) (RPAQ R.READERRORMASK (LOGOR S.DOOROPENED S.ERROR S.RECALIBRATEERROR S.DATALOST S.NOTREADY S.RECORDNOTFOUND S.CRCERROR)) (RPAQ R.WRITEERRORMASK (LOGOR R.READERRORMASK S.WRITEPROTECT)) (RPAQ R.INFOMASK (LOGOR S.TWOSIDED S.WRITEPROTECT S.TRACK0)) (RPAQQ FLOPPYIOCB.SIZE 16) (RPAQQ B128 0) (RPAQQ B256 1) (RPAQQ B512 2) (RPAQQ B1024 3) (RPAQQ IBM 0) (RPAQQ TROY 1) (RPAQQ SINGLE 0) (RPAQQ DOUBLE 8) (RPAQQ NoBits 0) (RPAQQ IDLENGTH 3) (RPAQQ SEAL.PSECTOR9 49932) (RPAQQ VERSION.PSECTOR9 1) (RPAQQ LABELMAXLENGTH.PSECTOR9 40) (RPAQQ SEAL.PMPAGE 13003) (RPAQQ VERSION.PMPAGE 1) (RPAQQ SEAL.PFILELIST 45771) (RPAQQ VERSION.PFILELIST 1) (RPAQQ PMPAGEETYPE.FREE 0) (RPAQQ PMPAGEETYPE.FILE 1) (RPAQQ PMPAGEETYPE.PFILELIST 2) (RPAQQ PMPAGEETYPE.BADSECTORS 3) (RPAQQ SEAL.PLPAGE 43690) (RPAQQ VERSION.PLPAGE 1) (RPAQQ VERSION.DATA 2222) (RPAQQ NAMEMAXLENGTH.PLPAGE 100) (RPAQQ FILETYPE.FREE 0) (RPAQQ FILETYPE.FILE 2052) (RPAQQ FILETYPE.PFILELIST 2054) (CONSTANTS (C.NOP 0) (C.READSECTOR 1) (C.WRITESECTOR 2) (C.WRITEDELETEDSECTOR 3) (C.READID 4) (C.FORMATTRACK 5) (C.RECALIBRATE 6) (C.INITIALIZE 7) (C.ESCAPE 8) (SC.NOP 0) (SC.DISKCHANGECLEAR 1) (S.DOOROPENED 32768) (S.TWOSIDED 8192) (S.DISKID 4096) (S.ERROR 2048) (S.RECALIBRATEERROR 512) (S.DATALOST 256) (S.NOTREADY 128) (S.WRITEPROTECT 64) (S.DELETEDDATA 32) (S.RECORDNOTFOUND 16) (S.CRCERROR 8) (S.TRACK0 4) (S.INDEX 2) (S.BUSY 1) (R.OK 0) (R.BUSY S.BUSY) (R.CRCERROR (LOGOR S.ERROR S.CRCERROR)) (R.DATALOST (LOGOR S.ERROR S.DATALOST)) (R.DOOROPENED (LOGOR S.ERROR S.DOOROPENED)) (R.DOORISOPEN (LOGOR S.ERROR S.DOOROPENED S.NOTREADY)) (R.DOORISOPEN2 (LOGOR S.DOOROPENED S.NOTREADY)) (R.NOTREADY (LOGOR S.ERROR S.NOTREADY)) (R.RECALIBRATEERROR (LOGOR S.ERROR S.RECALIBRATEERROR)) (R.RECORDNOTFOUND (LOGOR S.ERROR S.RECORDNOTFOUND)) (R.WRITEPROTECT (LOGOR S.ERROR S.WRITEPROTECT)) (R.READERRORMASK (LOGOR S.DOOROPENED S.ERROR S.RECALIBRATEERROR S.DATALOST S.NOTREADY S.RECORDNOTFOUND S.CRCERROR)) (R.WRITEERRORMASK (LOGOR R.READERRORMASK S.WRITEPROTECT)) (R.INFOMASK (LOGOR S.TWOSIDED S.WRITEPROTECT S.TRACK0)) (FLOPPYIOCB.SIZE 16) (B128 0) (B256 1) (B512 2) (B1024 3) (IBM 0) (TROY 1) (SINGLE 0) (DOUBLE 8) (NoBits 0) (IDLENGTH 3) (SEAL.PSECTOR9 49932) (VERSION.PSECTOR9 1) (LABELMAXLENGTH.PSECTOR9 40) (SEAL.PMPAGE 13003) (VERSION.PMPAGE 1) (SEAL.PFILELIST 45771) (VERSION.PFILELIST 1) (PMPAGEETYPE.FREE 0) (PMPAGEETYPE.FILE 1) (PMPAGEETYPE.PFILELIST 2) (PMPAGEETYPE.BADSECTORS 3) (SEAL.PLPAGE 43690) (VERSION.PLPAGE 1) (VERSION.DATA 2222) (NAMEMAXLENGTH.PLPAGE 100) (FILETYPE.FREE 0) (FILETYPE.FILE 2052) (FILETYPE.PFILELIST 2054)) ) ) (/DECLAREDATATYPE 'FLOPPYIOCB '(WORD WORD WORD WORD (BITS 12) (BITS 4) FIXP WORD WORD FLAG (BITS 15) WORD (BITS 8) (BITS 8) (BITS 8) (BITS 8) WORD WORD WORD) '((FLOPPYIOCB 0 (BITS . 15)) (FLOPPYIOCB 1 (BITS . 15)) (FLOPPYIOCB 2 (BITS . 15)) (FLOPPYIOCB 3 (BITS . 15)) (FLOPPYIOCB 4 (BITS . 11)) (FLOPPYIOCB 4 (BITS . 195)) (FLOPPYIOCB 5 FIXP) (FLOPPYIOCB 7 (BITS . 15)) (FLOPPYIOCB 8 (BITS . 15)) (FLOPPYIOCB 9 (FLAGBITS . 0)) (FLOPPYIOCB 9 (BITS . 30)) (FLOPPYIOCB 10 (BITS . 15)) (FLOPPYIOCB 11 (BITS . 7)) (FLOPPYIOCB 11 (BITS . 135)) (FLOPPYIOCB 12 (BITS . 7)) (FLOPPYIOCB 12 (BITS . 135)) (FLOPPYIOCB 13 (BITS . 15)) (FLOPPYIOCB 14 (BITS . 15)) (FLOPPYIOCB 15 (BITS . 15))) '16) (/DECLAREDATATYPE 'PSECTOR9 '(WORD WORD WORD WORD WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD SWAPPEDFIXP FLAG (BITS 15) WORD BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PSECTOR9 0 (BITS . 15)) (PSECTOR9 1 (BITS . 15)) (PSECTOR9 2 (BITS . 15)) (PSECTOR9 3 (BITS . 15)) (PSECTOR9 4 (BITS . 15)) (PSECTOR9 5 (BITS . 15)) (PSECTOR9 6 SWAPPEDFIXP) (PSECTOR9 8 (BITS . 15)) (PSECTOR9 9 SWAPPEDFIXP) (PSECTOR9 11 (BITS . 15)) (PSECTOR9 12 (BITS . 15)) (PSECTOR9 13 (BITS . 15)) (PSECTOR9 14 (BITS . 15)) (PSECTOR9 15 (BITS . 15)) (PSECTOR9 16 (BITS . 15)) (PSECTOR9 17 (BITS . 15)) (PSECTOR9 18 SWAPPEDFIXP) (PSECTOR9 20 (FLAGBITS . 0)) (PSECTOR9 20 (BITS . 30)) (PSECTOR9 21 (BITS . 15)) (PSECTOR9 22 (BITS . 7)) (PSECTOR9 22 (BITS . 135)) (PSECTOR9 23 (BITS . 7)) (PSECTOR9 23 (BITS . 135)) (PSECTOR9 24 (BITS . 7)) (PSECTOR9 24 (BITS . 135)) (PSECTOR9 25 (BITS . 7)) (PSECTOR9 25 (BITS . 135)) (PSECTOR9 26 (BITS . 7)) (PSECTOR9 26 (BITS . 135)) (PSECTOR9 27 (BITS . 7)) (PSECTOR9 27 (BITS . 135)) (PSECTOR9 28 (BITS . 7)) (PSECTOR9 28 (BITS . 135)) (PSECTOR9 29 (BITS . 7)) (PSECTOR9 29 (BITS . 135)) (PSECTOR9 30 (BITS . 7)) (PSECTOR9 30 (BITS . 135)) (PSECTOR9 31 (BITS . 7)) (PSECTOR9 31 (BITS . 135)) (PSECTOR9 32 (BITS . 7)) (PSECTOR9 32 (BITS . 135)) (PSECTOR9 33 (BITS . 7)) (PSECTOR9 33 (BITS . 135)) (PSECTOR9 34 (BITS . 7)) (PSECTOR9 34 (BITS . 135)) (PSECTOR9 35 (BITS . 7)) (PSECTOR9 35 (BITS . 135)) (PSECTOR9 36 (BITS . 7)) (PSECTOR9 36 (BITS . 135)) (PSECTOR9 37 (BITS . 7)) (PSECTOR9 37 (BITS . 135)) (PSECTOR9 38 (BITS . 7)) (PSECTOR9 38 (BITS . 135)) (PSECTOR9 39 (BITS . 7)) (PSECTOR9 39 (BITS . 135)) (PSECTOR9 40 (BITS . 7)) (PSECTOR9 40 (BITS . 135)) (PSECTOR9 41 (BITS . 7)) (PSECTOR9 41 (BITS . 135)) (PSECTOR9 42 (BITS . 15)) (PSECTOR9 43 (BITS . 15)) (PSECTOR9 44 (BITS . 15)) (PSECTOR9 45 (BITS . 15)) (PSECTOR9 46 (BITS . 15)) (PSECTOR9 47 (BITS . 15)) (PSECTOR9 48 (BITS . 15)) (PSECTOR9 49 (BITS . 15)) (PSECTOR9 50 (BITS . 15)) (PSECTOR9 51 (BITS . 15)) (PSECTOR9 52 (BITS . 15)) (PSECTOR9 53 (BITS . 15)) (PSECTOR9 54 (BITS . 15)) (PSECTOR9 55 (BITS . 15)) (PSECTOR9 56 (BITS . 15)) (PSECTOR9 57 (BITS . 15)) (PSECTOR9 58 (BITS . 15)) (PSECTOR9 59 (BITS . 15)) (PSECTOR9 60 (BITS . 15)) (PSECTOR9 61 (BITS . 15)) (PSECTOR9 62 (BITS . 15)) (PSECTOR9 63 (BITS . 15))) '64) (/DECLAREDATATYPE 'PMPAGE '(WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PMPAGE 0 (BITS . 15)) (PMPAGE 1 (BITS . 15)) (PMPAGE 2 SWAPPEDFIXP) (PMPAGE 4 (BITS . 15)) (PMPAGE 5 SWAPPEDFIXP) (PMPAGE 7 (BITS . 15)) (PMPAGE 8 (BITS . 15)) (PMPAGE 9 (BITS . 15)) (PMPAGE 10 (BITS . 15)) (PMPAGE 11 (BITS . 15)) (PMPAGE 12 (BITS . 15)) (PMPAGE 13 (BITS . 15)) (PMPAGE 14 (BITS . 15)) (PMPAGE 15 (BITS . 15)) (PMPAGE 16 (BITS . 15)) (PMPAGE 17 (BITS . 15)) (PMPAGE 18 (BITS . 15)) (PMPAGE 19 (BITS . 15)) (PMPAGE 20 (BITS . 15)) (PMPAGE 21 (BITS . 15)) (PMPAGE 22 (BITS . 15)) (PMPAGE 23 (BITS . 15)) (PMPAGE 24 (BITS . 15)) (PMPAGE 25 (BITS . 15)) (PMPAGE 26 (BITS . 15)) (PMPAGE 27 (BITS . 15)) (PMPAGE 28 (BITS . 15)) (PMPAGE 29 (BITS . 15)) (PMPAGE 30 (BITS . 15)) (PMPAGE 31 (BITS . 15)) (PMPAGE 32 (BITS . 15)) (PMPAGE 33 (BITS . 15)) (PMPAGE 34 (BITS . 15)) (PMPAGE 35 (BITS . 15)) (PMPAGE 36 (BITS . 15)) (PMPAGE 37 (BITS . 15)) (PMPAGE 38 (BITS . 15)) (PMPAGE 39 (BITS . 15)) (PMPAGE 40 (BITS . 15)) (PMPAGE 41 (BITS . 15)) (PMPAGE 42 (BITS . 15)) (PMPAGE 43 (BITS . 15)) (PMPAGE 44 (BITS . 15)) (PMPAGE 45 (BITS . 15)) (PMPAGE 46 (BITS . 15)) (PMPAGE 47 (BITS . 15)) (PMPAGE 48 (BITS . 15)) (PMPAGE 49 (BITS . 15)) (PMPAGE 50 (BITS . 15)) (PMPAGE 51 (BITS . 15)) (PMPAGE 52 (BITS . 15)) (PMPAGE 53 (BITS . 15)) (PMPAGE 54 (BITS . 15)) (PMPAGE 55 (BITS . 15)) (PMPAGE 56 (BITS . 15)) (PMPAGE 57 (BITS . 15)) (PMPAGE 58 (BITS . 15)) (PMPAGE 59 (BITS . 15)) (PMPAGE 60 (BITS . 15)) (PMPAGE 61 (BITS . 15)) (PMPAGE 62 (BITS . 15)) (PMPAGE 63 (BITS . 15)) (PMPAGE 64 (BITS . 15)) (PMPAGE 65 (BITS . 15)) (PMPAGE 66 (BITS . 15)) (PMPAGE 67 (BITS . 15)) (PMPAGE 68 (BITS . 15)) (PMPAGE 69 (BITS . 15)) (PMPAGE 70 (BITS . 15)) (PMPAGE 71 (BITS . 15)) (PMPAGE 72 (BITS . 15)) (PMPAGE 73 (BITS . 15)) (PMPAGE 74 (BITS . 15)) (PMPAGE 75 (BITS . 15)) (PMPAGE 76 (BITS . 15)) (PMPAGE 77 (BITS . 15)) (PMPAGE 78 (BITS . 15)) (PMPAGE 79 (BITS . 15)) (PMPAGE 80 (BITS . 15)) (PMPAGE 81 (BITS . 15)) (PMPAGE 82 (BITS . 15)) (PMPAGE 83 (BITS . 15)) (PMPAGE 84 (BITS . 15)) (PMPAGE 85 (BITS . 15)) (PMPAGE 86 (BITS . 15)) (PMPAGE 87 (BITS . 15)) (PMPAGE 88 (BITS . 15)) (PMPAGE 89 (BITS . 15)) (PMPAGE 90 (BITS . 15)) (PMPAGE 91 (BITS . 15)) (PMPAGE 92 (BITS . 15)) (PMPAGE 93 (BITS . 15)) (PMPAGE 94 (BITS . 15)) (PMPAGE 95 (BITS . 15)) (PMPAGE 96 (BITS . 15)) (PMPAGE 97 (BITS . 15)) (PMPAGE 98 (BITS . 15)) (PMPAGE 99 (BITS . 15)) (PMPAGE 100 (BITS . 15)) (PMPAGE 101 (BITS . 15)) (PMPAGE 102 (BITS . 15)) (PMPAGE 103 (BITS . 15)) (PMPAGE 104 (BITS . 15)) (PMPAGE 105 (BITS . 15)) (PMPAGE 106 (BITS . 15)) (PMPAGE 107 (BITS . 15)) (PMPAGE 108 (BITS . 15)) (PMPAGE 109 (BITS . 15)) (PMPAGE 110 (BITS . 15)) (PMPAGE 111 (BITS . 15)) (PMPAGE 112 (BITS . 15)) (PMPAGE 113 (BITS . 15)) (PMPAGE 114 (BITS . 15)) (PMPAGE 115 (BITS . 15)) (PMPAGE 116 (BITS . 15)) (PMPAGE 117 (BITS . 15)) (PMPAGE 118 (BITS . 15)) (PMPAGE 119 (BITS . 15)) (PMPAGE 120 (BITS . 15)) (PMPAGE 121 (BITS . 15)) (PMPAGE 122 (BITS . 15)) (PMPAGE 123 (BITS . 15)) (PMPAGE 124 (BITS . 15)) (PMPAGE 125 (BITS . 15)) (PMPAGE 126 (BITS . 15)) (PMPAGE 127 (BITS . 15)) (PMPAGE 128 (BITS . 15)) (PMPAGE 129 SWAPPEDFIXP) (PMPAGE 131 (BITS . 15)) (PMPAGE 132 SWAPPEDFIXP) (PMPAGE 134 (BITS . 15)) (PMPAGE 135 (BITS . 15)) (PMPAGE 136 (BITS . 15)) (PMPAGE 137 (BITS . 15)) (PMPAGE 138 (BITS . 15)) (PMPAGE 139 (BITS . 15)) (PMPAGE 140 (BITS . 15)) (PMPAGE 141 (BITS . 15)) (PMPAGE 142 (BITS . 15)) (PMPAGE 143 (BITS . 15)) (PMPAGE 144 (BITS . 15)) (PMPAGE 145 (BITS . 15)) (PMPAGE 146 (BITS . 15)) (PMPAGE 147 (BITS . 15)) (PMPAGE 148 (BITS . 15)) (PMPAGE 149 (BITS . 15)) (PMPAGE 150 (BITS . 15)) (PMPAGE 151 (BITS . 15)) (PMPAGE 152 (BITS . 15)) (PMPAGE 153 (BITS . 15)) (PMPAGE 154 (BITS . 15)) (PMPAGE 155 (BITS . 15)) (PMPAGE 156 (BITS . 15)) (PMPAGE 157 (BITS . 15)) (PMPAGE 158 (BITS . 15)) (PMPAGE 159 (BITS . 15)) (PMPAGE 160 (BITS . 15)) (PMPAGE 161 (BITS . 15)) (PMPAGE 162 (BITS . 15)) (PMPAGE 163 (BITS . 15)) (PMPAGE 164 (BITS . 15)) (PMPAGE 165 (BITS . 15)) (PMPAGE 166 (BITS . 15)) (PMPAGE 167 (BITS . 15)) (PMPAGE 168 (BITS . 15)) (PMPAGE 169 (BITS . 15)) (PMPAGE 170 (BITS . 15)) (PMPAGE 171 (BITS . 15)) (PMPAGE 172 (BITS . 15)) (PMPAGE 173 (BITS . 15)) (PMPAGE 174 (BITS . 15)) (PMPAGE 175 (BITS . 15)) (PMPAGE 176 (BITS . 15)) (PMPAGE 177 (BITS . 15)) (PMPAGE 178 (BITS . 15)) (PMPAGE 179 (BITS . 15)) (PMPAGE 180 (BITS . 15)) (PMPAGE 181 (BITS . 15)) (PMPAGE 182 (BITS . 15)) (PMPAGE 183 (BITS . 15)) (PMPAGE 184 (BITS . 15)) (PMPAGE 185 (BITS . 15)) (PMPAGE 186 (BITS . 15)) (PMPAGE 187 (BITS . 15)) (PMPAGE 188 (BITS . 15)) (PMPAGE 189 (BITS . 15)) (PMPAGE 190 (BITS . 15)) (PMPAGE 191 (BITS . 15)) (PMPAGE 192 (BITS . 15)) (PMPAGE 193 (BITS . 15)) (PMPAGE 194 (BITS . 15)) (PMPAGE 195 (BITS . 15)) (PMPAGE 196 (BITS . 15)) (PMPAGE 197 (BITS . 15)) (PMPAGE 198 (BITS . 15)) (PMPAGE 199 (BITS . 15)) (PMPAGE 200 (BITS . 15)) (PMPAGE 201 (BITS . 15)) (PMPAGE 202 (BITS . 15)) (PMPAGE 203 (BITS . 15)) (PMPAGE 204 (BITS . 15)) (PMPAGE 205 (BITS . 15)) (PMPAGE 206 (BITS . 15)) (PMPAGE 207 (BITS . 15)) (PMPAGE 208 (BITS . 15)) (PMPAGE 209 (BITS . 15)) (PMPAGE 210 (BITS . 15)) (PMPAGE 211 (BITS . 15)) (PMPAGE 212 (BITS . 15)) (PMPAGE 213 (BITS . 15)) (PMPAGE 214 (BITS . 15)) (PMPAGE 215 (BITS . 15)) (PMPAGE 216 (BITS . 15)) (PMPAGE 217 (BITS . 15)) (PMPAGE 218 (BITS . 15)) (PMPAGE 219 (BITS . 15)) (PMPAGE 220 (BITS . 15)) (PMPAGE 221 (BITS . 15)) (PMPAGE 222 (BITS . 15)) (PMPAGE 223 (BITS . 15)) (PMPAGE 224 (BITS . 15)) (PMPAGE 225 (BITS . 15)) (PMPAGE 226 (BITS . 15)) (PMPAGE 227 (BITS . 15)) (PMPAGE 228 (BITS . 15)) (PMPAGE 229 (BITS . 15)) (PMPAGE 230 (BITS . 15)) (PMPAGE 231 (BITS . 15)) (PMPAGE 232 (BITS . 15)) (PMPAGE 233 (BITS . 15)) (PMPAGE 234 (BITS . 15)) (PMPAGE 235 (BITS . 15)) (PMPAGE 236 (BITS . 15)) (PMPAGE 237 (BITS . 15)) (PMPAGE 238 (BITS . 15)) (PMPAGE 239 (BITS . 15)) (PMPAGE 240 (BITS . 15)) (PMPAGE 241 (BITS . 15)) (PMPAGE 242 (BITS . 15)) (PMPAGE 243 (BITS . 15)) (PMPAGE 244 (BITS . 15)) (PMPAGE 245 (BITS . 15)) (PMPAGE 246 (BITS . 15)) (PMPAGE 247 (BITS . 15)) (PMPAGE 248 (BITS . 15)) (PMPAGE 249 (BITS . 15)) (PMPAGE 250 (BITS . 15)) (PMPAGE 251 (BITS . 15)) (PMPAGE 252 (BITS . 15)) (PMPAGE 253 (BITS . 15)) (PMPAGE 254 (BITS . 15)) (PMPAGE 255 (BITS . 15))) '256) (/DECLAREDATATYPE 'PLPAGE '(WORD WORD WORD SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PLPAGE 0 (BITS . 15)) (PLPAGE 1 (BITS . 15)) (PLPAGE 2 (BITS . 15)) (PLPAGE 3 SWAPPEDFIXP) (PLPAGE 5 SWAPPEDFIXP) (PLPAGE 7 SWAPPEDFIXP) (PLPAGE 9 SWAPPEDFIXP) (PLPAGE 11 SWAPPEDFIXP) (PLPAGE 13 SWAPPEDFIXP) (PLPAGE 15 (BITS . 15)) (PLPAGE 16 (BITS . 15)) (PLPAGE 17 (BITS . 15)) (PLPAGE 18 (BITS . 15)) (PLPAGE 19 (BITS . 15)) (PLPAGE 20 (BITS . 15)) (PLPAGE 21 (BITS . 15)) (PLPAGE 22 (BITS . 15)) (PLPAGE 23 (BITS . 15)) (PLPAGE 24 (BITS . 15)) (PLPAGE 25 (BITS . 15)) (PLPAGE 26 (BITS . 15)) (PLPAGE 27 (BITS . 15)) (PLPAGE 28 (BITS . 15)) (PLPAGE 29 (BITS . 15)) (PLPAGE 30 (BITS . 15)) (PLPAGE 31 (BITS . 15)) (PLPAGE 32 (BITS . 15)) (PLPAGE 33 (BITS . 15)) (PLPAGE 34 (BITS . 15)) (PLPAGE 35 (BITS . 15)) (PLPAGE 36 (BITS . 15)) (PLPAGE 37 (BITS . 15)) (PLPAGE 38 (BITS . 15)) (PLPAGE 39 (BITS . 15)) (PLPAGE 40 (BITS . 15)) (PLPAGE 41 (BITS . 15)) (PLPAGE 42 (BITS . 15)) (PLPAGE 43 (BITS . 15)) (PLPAGE 44 (BITS . 15)) (PLPAGE 45 (BITS . 15)) (PLPAGE 46 (BITS . 15)) (PLPAGE 47 (BITS . 15)) (PLPAGE 48 (BITS . 15)) (PLPAGE 49 (BITS . 15)) (PLPAGE 50 (BITS . 15)) (PLPAGE 51 (BITS . 15)) (PLPAGE 52 (BITS . 15)) (PLPAGE 53 (BITS . 15)) (PLPAGE 54 (BITS . 15)) (PLPAGE 55 (BITS . 15)) (PLPAGE 56 (BITS . 15)) (PLPAGE 57 (BITS . 15)) (PLPAGE 58 (BITS . 15)) (PLPAGE 59 (BITS . 15)) (PLPAGE 60 (BITS . 15)) (PLPAGE 61 (BITS . 15)) (PLPAGE 62 (BITS . 15)) (PLPAGE 63 (BITS . 15)) (PLPAGE 64 (BITS . 15)) (PLPAGE 65 (BITS . 15)) (PLPAGE 66 (BITS . 15)) (PLPAGE 67 (BITS . 15)) (PLPAGE 68 (BITS . 15)) (PLPAGE 69 (BITS . 15)) (PLPAGE 70 (BITS . 15)) (PLPAGE 71 (BITS . 15)) (PLPAGE 72 (BITS . 15)) (PLPAGE 73 (BITS . 15)) (PLPAGE 74 (BITS . 15)) (PLPAGE 75 (BITS . 15)) (PLPAGE 76 (BITS . 15)) (PLPAGE 77 (BITS . 15)) (PLPAGE 78 (BITS . 15)) (PLPAGE 79 (BITS . 15)) (PLPAGE 80 (BITS . 15)) (PLPAGE 81 (BITS . 15)) (PLPAGE 82 (BITS . 15)) (PLPAGE 83 (BITS . 15)) (PLPAGE 84 (BITS . 15)) (PLPAGE 85 (BITS . 15)) (PLPAGE 86 (BITS . 15)) (PLPAGE 87 (BITS . 15)) (PLPAGE 88 (BITS . 15)) (PLPAGE 89 (BITS . 15)) (PLPAGE 90 (BITS . 15)) (PLPAGE 91 (BITS . 15)) (PLPAGE 92 (BITS . 15)) (PLPAGE 93 (BITS . 15)) (PLPAGE 94 (BITS . 15)) (PLPAGE 95 (BITS . 15)) (PLPAGE 96 (BITS . 15)) (PLPAGE 97 (BITS . 15)) (PLPAGE 98 (BITS . 15)) (PLPAGE 99 (BITS . 15)) (PLPAGE 100 (BITS . 15)) (PLPAGE 101 (BITS . 15)) (PLPAGE 102 (BITS . 15)) (PLPAGE 103 (BITS . 15)) (PLPAGE 104 (BITS . 15)) (PLPAGE 105 (BITS . 15)) (PLPAGE 106 (BITS . 15)) (PLPAGE 107 (BITS . 15)) (PLPAGE 108 (BITS . 15)) (PLPAGE 109 (BITS . 15)) (PLPAGE 110 (BITS . 15)) (PLPAGE 111 (BITS . 15)) (PLPAGE 112 (BITS . 15)) (PLPAGE 113 (BITS . 15)) (PLPAGE 114 (BITS . 15)) (PLPAGE 115 (BITS . 15)) (PLPAGE 116 (BITS . 15)) (PLPAGE 117 (BITS . 15)) (PLPAGE 118 (BITS . 15)) (PLPAGE 119 (BITS . 15)) (PLPAGE 120 (BITS . 15)) (PLPAGE 121 (BITS . 15)) (PLPAGE 122 (BITS . 15)) (PLPAGE 123 (BITS . 15)) (PLPAGE 124 (BITS . 15)) (PLPAGE 125 (BITS . 15)) (PLPAGE 126 (BITS . 15)) (PLPAGE 127 (BITS . 15)) (PLPAGE 128 (BITS . 15)) (PLPAGE 129 (BITS . 15)) (PLPAGE 130 (BITS . 15)) (PLPAGE 131 (BITS . 15)) (PLPAGE 132 (BITS . 15)) (PLPAGE 133 (BITS . 15)) (PLPAGE 134 (BITS . 15)) (PLPAGE 135 (BITS . 15)) (PLPAGE 136 (BITS . 15)) (PLPAGE 137 (BITS . 15)) (PLPAGE 138 (BITS . 15)) (PLPAGE 139 (BITS . 15)) (PLPAGE 140 (BITS . 15)) (PLPAGE 141 (BITS . 15)) (PLPAGE 142 (BITS . 15)) (PLPAGE 143 (BITS . 15)) (PLPAGE 144 (BITS . 15)) (PLPAGE 145 (BITS . 15)) (PLPAGE 146 (BITS . 15)) (PLPAGE 147 (BITS . 15)) (PLPAGE 148 (BITS . 15)) (PLPAGE 149 (BITS . 15)) (PLPAGE 150 (BITS . 15)) (PLPAGE 151 (BITS . 15)) (PLPAGE 152 (BITS . 15)) (PLPAGE 153 (BITS . 15)) (PLPAGE 154 (BITS . 15)) (PLPAGE 155 (BITS . 15)) (PLPAGE 156 (BITS . 15)) (PLPAGE 157 (BITS . 15)) (PLPAGE 158 (BITS . 15)) (PLPAGE 159 (BITS . 15)) (PLPAGE 160 (BITS . 15)) (PLPAGE 161 (BITS . 15)) (PLPAGE 162 (BITS . 15)) (PLPAGE 163 (BITS . 15)) (PLPAGE 164 (BITS . 15)) (PLPAGE 165 (BITS . 15)) (PLPAGE 166 (BITS . 15)) (PLPAGE 167 (BITS . 15)) (PLPAGE 168 (BITS . 15)) (PLPAGE 169 (BITS . 15)) (PLPAGE 170 (BITS . 15)) (PLPAGE 171 (BITS . 15)) (PLPAGE 172 (BITS . 15)) (PLPAGE 173 (BITS . 15)) (PLPAGE 174 (BITS . 15)) (PLPAGE 175 (BITS . 15)) (PLPAGE 176 (BITS . 15)) (PLPAGE 177 (BITS . 15)) (PLPAGE 178 (BITS . 15)) (PLPAGE 179 (BITS . 15)) (PLPAGE 180 (BITS . 15)) (PLPAGE 181 (BITS . 15)) (PLPAGE 182 (BITS . 15)) (PLPAGE 183 (BITS . 15)) (PLPAGE 184 (BITS . 15)) (PLPAGE 185 (BITS . 15)) (PLPAGE 186 (BITS . 15)) (PLPAGE 187 (BITS . 15)) (PLPAGE 188 (BITS . 15)) (PLPAGE 189 (BITS . 15)) (PLPAGE 190 (BITS . 15)) (PLPAGE 191 (BITS . 15)) (PLPAGE 192 (BITS . 15)) (PLPAGE 193 (BITS . 15)) (PLPAGE 194 (BITS . 15)) (PLPAGE 195 (BITS . 15)) (PLPAGE 196 (BITS . 15)) (PLPAGE 197 (BITS . 15)) (PLPAGE 198 (BITS . 15)) (PLPAGE 199 (BITS . 15)) (PLPAGE 200 (BITS . 15)) (PLPAGE 201 (BITS . 15)) (PLPAGE 202 (BITS . 15)) (PLPAGE 203 (BITS . 15)) (PLPAGE 204 (BITS . 15)) (PLPAGE 205 (BITS . 15)) (PLPAGE 206 (BITS . 15)) (PLPAGE 207 (BITS . 15)) (PLPAGE 208 (BITS . 15)) (PLPAGE 209 (BITS . 15)) (PLPAGE 210 (BITS . 15)) (PLPAGE 211 (BITS . 15)) (PLPAGE 212 (BITS . 15)) (PLPAGE 213 (BITS . 15)) (PLPAGE 214 (BITS . 15)) (PLPAGE 215 (BITS . 15)) (PLPAGE 216 (BITS . 15)) (PLPAGE 217 (BITS . 15)) (PLPAGE 218 (BITS . 15)) (PLPAGE 219 (BITS . 15)) (PLPAGE 220 (BITS . 15)) (PLPAGE 221 (BITS . 15)) (PLPAGE 222 (BITS . 15)) (PLPAGE 223 (BITS . 15)) (PLPAGE 224 (BITS . 15)) (PLPAGE 225 (BITS . 15)) (PLPAGE 226 (BITS . 15)) (PLPAGE 227 (BITS . 15)) (PLPAGE 228 (BITS . 15)) (PLPAGE 229 (BITS . 15)) (PLPAGE 230 (BITS . 15)) (PLPAGE 231 (BITS . 15)) (PLPAGE 232 (BITS . 15)) (PLPAGE 233 (BITS . 15)) (PLPAGE 234 (BITS . 15)) (PLPAGE 235 (BITS . 15)) (PLPAGE 236 (BITS . 15)) (PLPAGE 237 (BITS . 15)) (PLPAGE 238 (BITS . 15)) (PLPAGE 239 (BITS . 15)) (PLPAGE 240 (BITS . 15)) (PLPAGE 241 (BITS . 15)) (PLPAGE 242 (BITS . 15)) (PLPAGE 243 (BITS . 15)) (PLPAGE 244 (BITS . 15)) (PLPAGE 245 (BITS . 15)) (PLPAGE 246 (BITS . 15)) (PLPAGE 247 (BITS . 15)) (PLPAGE 248 (BITS . 15)) (PLPAGE 249 (BITS . 15)) (PLPAGE 250 (BITS . 15)) (PLPAGE 251 (BITS . 15)) (PLPAGE 252 (BITS . 15)) (PLPAGE 253 (BITS . 15)) (PLPAGE 254 (BITS . 15))) '256) (/DECLAREDATATYPE 'PFLE '(SWAPPEDFIXP WORD WORD WORD) '((PFLE 0 SWAPPEDFIXP) (PFLE 2 (BITS . 15)) (PFLE 3 (BITS . 15)) (PFLE 4 (BITS . 15))) '6) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS DISKADDRESS ((CYLINDER (LRSH DATUM 16)) (HEAD (LRSH (LOGAND DATUM 65535) 8)) (SECTOR (LOGAND DATUM 255))) (CREATE (IPLUS (LLSH CYLINDER 16) (LLSH HEAD 8) SECTOR))) (DATATYPE FLOPPYIOCB ((\BUFFERLOLOC WORD) (\BUFFERHILOC WORD) (NIL WORD) (SECTORLENGTHDIV2 WORD) (TROYORIBM BITS 12) (DENSITY BITS 4) (DISKADDRESS FIXP) (SECTORCOUNT WORD) (FLOPPYRESULT WORD) (SAMEPAGE FLAG) (COMMAND BITS 15) (SUBCOMMAND WORD) (SECTORLENGTHDIV4 BITS 8) (ENCODEDSECTORLENGTH BITS 8) (SECTORSPERTRACK BITS 8) (GAP3 BITS 8) (NIL 3 WORD)) (CREATE (PROGN (\FLOPPY.SETUP.IOCB DATUM IBMD512) (replace (FLOPPYIOCB DISKADDRESS) of DATUM with (CREATE DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 1)) DATUM)) [ACCESSFNS (($COMMAND (SELECT (fetch (FLOPPYIOCB COMMAND) of DATUM) (C.NOP 'NOP) (C.READSECTOR 'READSECTOR) (C.WRITESECTOR 'WRITESECTOR) (C.WRITEDELETEDSECTOR 'WRITEDELETEDSECTOR) (C.READID 'READID) (C.FORMATTRACK 'FORMATTRACK) (C.RECALIBRATE 'RECALIBRATE) (C.INITIALIZE 'INITIALIZE) (C.ESCAPE 'ESCAPE) '?)) ($SUBCOMMAND (SELECT (fetch (FLOPPYIOCB SUBCOMMAND) of DATUM) (SC.NOP 'NOP) (SC.DISKCHANGECLEAR 'DISKCHANGECLEAR) '?)) ($FLOPPYRESULT (\FLOPPY.TRANSLATEFLOPPYRESULT (fetch (FLOPPYIOCB FLOPPYRESULT) of DATUM))) ($TROYORIBM (SELECT (fetch (FLOPPYIOCB TROYORIBM) of DATUM) (IBM 'IBM) (TROY 'TROY) '?)) ($DENSITY (SELECT (fetch (FLOPPYIOCB DENSITY) of DATUM) (SINGLE 'SINGLE) (DOUBLE 'DOUBLE) '?)) ($ENCODEDSECTORLENGTH (SELECT (fetch (FLOPPYIOCB ENCODEDSECTORLENGTH) of DATUM) (B128 128) (B256 256) (B512 512) (B1024 1024) '?)) [BUFFER (\VAG2 (fetch (FLOPPYIOCB \BUFFERHILOC) of DATUM) (fetch (FLOPPYIOCB \BUFFERLOLOC) of DATUM)) (PROGN (replace (FLOPPYIOCB \BUFFERLOLOC) of DATUM with (\LOLOC NEWVALUE)) (replace (FLOPPYIOCB \BUFFERHILOC) of DATUM with (\HILOC NEWVALUE] (CYLINDER (fetch (DISKADDRESS CYLINDER) of (fetch (FLOPPYIOCB DISKADDRESS) of DATUM))) (HEAD (fetch (DISKADDRESS HEAD) of (fetch (FLOPPYIOCB DISKADDRESS) of DATUM))) (SECTOR (fetch (DISKADDRESS SECTOR) of (fetch (FLOPPYIOCB DISKADDRESS) of DATUM]) (BLOCKRECORD FLOPPYRESULT ((DOOROPENED FLAG) (MPERROR FLAG) (TWOSIDED FLAG) (DISKID FLAG) (ERROR FLAG) (NIL FLAG) (RECALIBRATEERROR FLAG) (DATALOST FLAG) (NOTREADY FLAG) (WRITEPROTECT FLAG) (DELETEDDATA FLAG) (RECORDNOTFOUND FLAG) (CRCERROR FLAG) (TRACK0 FLAG) (NIL FLAG) (BUSY FLAG)) (BLOCKRECORD FLOPPYRESULT ((WORD WORD))) [ACCESSFNS ([$DISKID (COND ((fetch (FLOPPYRESULT DISKID) of DATUM) 'SA850) (T 'SA800] [MPCODE (COND ((NOT (fetch (FLOPPYRESULT MPERROR) of DATUM)) 0) (T (LOGXOR (fetch (FLOPPYRESULT WORD) of DATUM) (LLSH 1 14] (MPMESSAGE (SELECTQ (fetch (FLOPPYRESULT MPCODE) of DATUM) (0 NIL) (580 "Domino NoValidCommand Error") (581 "Domino UnImplFloppyCmd Error") (582 "Domino InvalidEscapeCmd Error") (583 "Domino CommandTrack Error") (584 "Domino TrackToBig Error") (585 "Domino BadDmaChannel Error") (586 "Domino NoDmaEndCount1 Error") (587 "Domino NoDmaEndCount2 Error") (597 "Domino Error In NOOP Patch") (598 "Domino Error in Reset Patch") (CONCAT "Domino Error " (fetch (FLOPPYRESULT MPCODE) of DATUM]) (DATATYPE PSECTOR9 ((SEAL WORD) (VERSION WORD) (CYLINDERS WORD) (TRACKSPERCYLINDER WORD) (SECTORSPERTRACK WORD) (PFILELISTSTART WORD) (PFILELISTFILEID SWAPPEDFIXP) (PFILELISTLENGTH WORD) (ROOTFILEID SWAPPEDFIXP) (NIL WORD) (PILOTMICROCODE WORD) (DIAGNOSTICMICROCODE WORD) (GERM WORD) (PILOTBOOTFILE WORD) (FIRSTALTERNATESECTOR WORD) (COUNTBADSECTORS WORD) (NEXTUNUSEDFILEID SWAPPEDFIXP) (CHANGING FLAG) (NIL BITS 15) (\LABELLENGTH WORD) (\LABEL 40 BYTE) (NIL 22 WORD)) SEAL _ SEAL.PSECTOR9 VERSION _ VERSION.PSECTOR9 CYLINDERS _ \FLOPPY.CYLINDERS TRACKSPERCYLINDER _ \FLOPPY.TRACKSPERCYLINDER SECTORSPERTRACK _ \FLOPPY.SECTORSPERTRACK [ACCESSFNS ((INTACT (AND (IEQP (fetch (PSECTOR9 SEAL) of DATUM) SEAL.PSECTOR9) (ILEQ (fetch (PSECTOR9 \LABELLENGTH) of DATUM) 106))) [$LABEL [MKATOM (CREATE STRINGP BASE _ (fetch (PSECTOR9 \LABELBASE) of DATUM) LENGTH _ (IMIN LABELMAXLENGTH.PSECTOR9 (fetch (PSECTOR9 \LABELLENGTH ) of DATUM] (LET ((VALUE (MKSTRING NEWVALUE))) (* ;;  "NOTE: Can't do SETQ NEWVALUE with record package.") (COND ((IGREATERP (NCHARS VALUE) LABELMAXLENGTH.PSECTOR9) (CL:CERROR "Use %"~A%" as the label" "~*%"~A%" is too long for a floppy label." (SUBSTRING VALUE 1 LABELMAXLENGTH.PSECTOR9) VALUE))) (replace (PSECTOR9 \LABELLENGTH) of DATUM with (IMIN LABELMAXLENGTH.PSECTOR9 (NCHARS VALUE))) (RPLSTRING (CREATE STRINGP BASE _ (fetch (PSECTOR9 \LABELBASE) of DATUM) LENGTH _ (fetch (PSECTOR9 \LABELLENGTH ) of DATUM)) 1 (SUBSTRING VALUE 1 (fetch (PSECTOR9 \LABELLENGTH ) of DATUM] (\LABELBASE (\ADDBASE DATUM 22]) (DATATYPE PMPAGE ( (* ;; "MARKER PAGE for a pilot file") (SEAL WORD) (VERSION WORD) (* ; "Previous marker page entry ") (PLENGTH SWAPPEDFIXP) (PTYPE WORD) (PFILEID SWAPPEDFIXP) (PFILETYPE WORD) (NIL 121 WORD) (* ; "Next marker page entry ") (NLENGTH SWAPPEDFIXP) (NTYPE WORD) (NFILEID SWAPPEDFIXP) (NFILETYPE WORD) (* ;  "Numeric file type (? jds 10/27/87)") (NIL 121 WORD)) SEAL _ SEAL.PMPAGE VERSION _ VERSION.PMPAGE [ACCESSFNS ((INTACT (IEQP (fetch (PMPAGE SEAL) of DATUM) SEAL.PMPAGE)) ($PTYPE (\FLOPPY.TRANSLATEPMPAGEETYPE (fetch (PMPAGE PTYPE) of DATUM))) ($PFILETYPE (\FLOPPY.TRANSLATEFILETYPE (fetch (PMPAGE PFILETYPE) of DATUM))) ($NTYPE (\FLOPPY.TRANSLATEPMPAGEETYPE (fetch (PMPAGE NTYPE) of DATUM))) ($NFILETYPE (\FLOPPY.TRANSLATEFILETYPE (fetch (PMPAGE NFILETYPE) of DATUM]) (DATATYPE PLPAGE ((SEAL WORD) (VERSION WORD) (MESATYPE WORD) (* Offset 6 *) (\CREATIONDATE SWAPPEDFIXP) (\WRITEDATE SWAPPEDFIXP) (PAGELENGTH SWAPPEDFIXP) (HUGEPAGESTART SWAPPEDFIXP) (HUGEPAGELENGTH SWAPPEDFIXP) (HUGELENGTH SWAPPEDFIXP) (\NAMELENGTH WORD) (NAMEMAXLENGTH WORD) (* Offset 17 *) (\NAME 50 WORD) (* Offset 67 *) (UFO1 WORD) (UFO2 WORD) (DATAVERSION WORD) (\TYPE WORD) (NIL 183 WORD) (\BYTESIZE WORD)) SEAL _ SEAL.PLPAGE VERSION _ VERSION.PLPAGE MESATYPE _ 65535 NAMEMAXLENGTH _ NAMEMAXLENGTH.PLPAGE UFO1 _ 2 UFO2 _ 187 DATAVERSION _ VERSION.DATA \TYPE _ 1 [ACCESSFNS ((INTACT (AND (IEQP (fetch (PLPAGE SEAL) of DATUM) SEAL.PLPAGE) (ILEQ (fetch (PLPAGE \NAMELENGTH) of DATUM) NAMEMAXLENGTH.PLPAGE))) [$NAME [MKATOM (CREATE STRINGP BASE _ (fetch (PLPAGE \NAMEBASE) of DATUM) LENGTH _ (IMIN 100 (fetch (PLPAGE \NAMELENGTH) of DATUM] (PROG (VALUE) (* NOTE%: Can't do SETQ NEWVALUE  with record package.  *) (SETQ VALUE (MKSTRING NEWVALUE)) (replace (PLPAGE \NAMELENGTH) of DATUM with (IMIN NAMEMAXLENGTH.PLPAGE (NCHARS VALUE))) (RPLSTRING (CREATE STRINGP BASE _ (fetch (PLPAGE \NAMEBASE) of DATUM) LENGTH _ (fetch (PLPAGE \NAMELENGTH) of DATUM)) 1 (SUBSTRING VALUE 1 (fetch (PLPAGE \NAMELENGTH) of DATUM] (\NAMEBASE (\ADDBASE DATUM 17)) (CREATIONDATE (GDATE (fetch (PLPAGE ICREATIONDATE) of DATUM)) (replace (PLPAGE ICREATIONDATE) of DATUM with (IDATE NEWVALUE ))) (ICREATIONDATE (\FLOPPY.MTL.IDATE (fetch (PLPAGE \CREATIONDATE) of DATUM)) (replace (PLPAGE \CREATIONDATE) of DATUM with ( \FLOPPY.LTM.IDATE NEWVALUE))) (WRITEDATE (GDATE (fetch (PLPAGE IWRITEDATE) of DATUM)) (replace (PLPAGE IWRITEDATE) of DATUM with (IDATE NEWVALUE)) ) (IWRITEDATE (\FLOPPY.MTL.IDATE (fetch (PLPAGE \WRITEDATE) of DATUM)) (replace (PLPAGE \WRITEDATE) of DATUM with ( \FLOPPY.LTM.IDATE NEWVALUE))) [LENGTH [COND ((ILESSP (IPLUS (fetch (PLPAGE HUGEPAGESTART) of DATUM) (fetch (PLPAGE PAGELENGTH) of DATUM)) (fetch (PLPAGE HUGEPAGELENGTH) of DATUM)) (ITIMES 512 (fetch (PLPAGE PAGELENGTH) of DATUM))) (T (IDIFFERENCE (fetch (PLPAGE HUGELENGTH) of DATUM) (ITIMES 512 (fetch (PLPAGE HUGEPAGESTART) of DATUM] (PROGN (* Works for ordinairy  (not huge) files. *) (replace (PLPAGE PAGELENGTH) of DATUM with (IQUOTIENT (IPLUS NEWVALUE 511) 512)) (replace (PLPAGE HUGELENGTH) of DATUM with NEWVALUE) (replace (PLPAGE HUGEPAGELENGTH) of DATUM with (fetch (PLPAGE PAGELENGTH) of DATUM] [TYPE (SELECT (fetch (PLPAGE \TYPE) of DATUM) (1 'TEXT) (2 'BINARY) 'TEXT) (SELECTQ (COND ((LISTP NEWVALUE) (CAR NEWVALUE)) (T NEWVALUE)) (TEXT (replace (PLPAGE \TYPE) of DATUM with 1)) (PROGN (* Everything else BINARY.  *) (replace (PLPAGE \TYPE) of DATUM with 2] (\VALUE DATUM (\BLT DATUM NEWVALUE 256]) (BLOCKRECORD PFILELIST ((SEAL WORD) (VERSION WORD) (NENTRIES WORD) (MAXENTRIES WORD)) [ACCESSFNS ((INTACT (IEQP (fetch (PFILELIST SEAL) of DATUM) SEAL.PFILELIST)) (NPAGES (FOLDHI (IPLUS 4 (ITIMES 5 (fetch (PFILELIST MAXENTRIES) of DATUM))) 256)) (\FIRSTPFLE (\ADDBASE DATUM 4]) (DATATYPE PFLE ((FILEID SWAPPEDFIXP) (TYPE WORD) (START WORD) (LENGTH WORD)) [ACCESSFNS (($TYPE (\FLOPPY.TRANSLATEFILETYPE (fetch (PFLE TYPE) of DATUM) )) (\VALUE DATUM (\BLT DATUM NEWVALUE 5]) ) (/DECLAREDATATYPE 'FLOPPYIOCB '(WORD WORD WORD WORD (BITS 12) (BITS 4) FIXP WORD WORD FLAG (BITS 15) WORD (BITS 8) (BITS 8) (BITS 8) (BITS 8) WORD WORD WORD) '((FLOPPYIOCB 0 (BITS . 15)) (FLOPPYIOCB 1 (BITS . 15)) (FLOPPYIOCB 2 (BITS . 15)) (FLOPPYIOCB 3 (BITS . 15)) (FLOPPYIOCB 4 (BITS . 11)) (FLOPPYIOCB 4 (BITS . 195)) (FLOPPYIOCB 5 FIXP) (FLOPPYIOCB 7 (BITS . 15)) (FLOPPYIOCB 8 (BITS . 15)) (FLOPPYIOCB 9 (FLAGBITS . 0)) (FLOPPYIOCB 9 (BITS . 30)) (FLOPPYIOCB 10 (BITS . 15)) (FLOPPYIOCB 11 (BITS . 7)) (FLOPPYIOCB 11 (BITS . 135)) (FLOPPYIOCB 12 (BITS . 7)) (FLOPPYIOCB 12 (BITS . 135)) (FLOPPYIOCB 13 (BITS . 15)) (FLOPPYIOCB 14 (BITS . 15)) (FLOPPYIOCB 15 (BITS . 15))) '16) (/DECLAREDATATYPE 'PSECTOR9 '(WORD WORD WORD WORD WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD SWAPPEDFIXP FLAG (BITS 15) WORD BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PSECTOR9 0 (BITS . 15)) (PSECTOR9 1 (BITS . 15)) (PSECTOR9 2 (BITS . 15)) (PSECTOR9 3 (BITS . 15)) (PSECTOR9 4 (BITS . 15)) (PSECTOR9 5 (BITS . 15)) (PSECTOR9 6 SWAPPEDFIXP) (PSECTOR9 8 (BITS . 15)) (PSECTOR9 9 SWAPPEDFIXP) (PSECTOR9 11 (BITS . 15)) (PSECTOR9 12 (BITS . 15)) (PSECTOR9 13 (BITS . 15)) (PSECTOR9 14 (BITS . 15)) (PSECTOR9 15 (BITS . 15)) (PSECTOR9 16 (BITS . 15)) (PSECTOR9 17 (BITS . 15)) (PSECTOR9 18 SWAPPEDFIXP) (PSECTOR9 20 (FLAGBITS . 0)) (PSECTOR9 20 (BITS . 30)) (PSECTOR9 21 (BITS . 15)) (PSECTOR9 22 (BITS . 7)) (PSECTOR9 22 (BITS . 135)) (PSECTOR9 23 (BITS . 7)) (PSECTOR9 23 (BITS . 135)) (PSECTOR9 24 (BITS . 7)) (PSECTOR9 24 (BITS . 135)) (PSECTOR9 25 (BITS . 7)) (PSECTOR9 25 (BITS . 135)) (PSECTOR9 26 (BITS . 7)) (PSECTOR9 26 (BITS . 135)) (PSECTOR9 27 (BITS . 7)) (PSECTOR9 27 (BITS . 135)) (PSECTOR9 28 (BITS . 7)) (PSECTOR9 28 (BITS . 135)) (PSECTOR9 29 (BITS . 7)) (PSECTOR9 29 (BITS . 135)) (PSECTOR9 30 (BITS . 7)) (PSECTOR9 30 (BITS . 135)) (PSECTOR9 31 (BITS . 7)) (PSECTOR9 31 (BITS . 135)) (PSECTOR9 32 (BITS . 7)) (PSECTOR9 32 (BITS . 135)) (PSECTOR9 33 (BITS . 7)) (PSECTOR9 33 (BITS . 135)) (PSECTOR9 34 (BITS . 7)) (PSECTOR9 34 (BITS . 135)) (PSECTOR9 35 (BITS . 7)) (PSECTOR9 35 (BITS . 135)) (PSECTOR9 36 (BITS . 7)) (PSECTOR9 36 (BITS . 135)) (PSECTOR9 37 (BITS . 7)) (PSECTOR9 37 (BITS . 135)) (PSECTOR9 38 (BITS . 7)) (PSECTOR9 38 (BITS . 135)) (PSECTOR9 39 (BITS . 7)) (PSECTOR9 39 (BITS . 135)) (PSECTOR9 40 (BITS . 7)) (PSECTOR9 40 (BITS . 135)) (PSECTOR9 41 (BITS . 7)) (PSECTOR9 41 (BITS . 135)) (PSECTOR9 42 (BITS . 15)) (PSECTOR9 43 (BITS . 15)) (PSECTOR9 44 (BITS . 15)) (PSECTOR9 45 (BITS . 15)) (PSECTOR9 46 (BITS . 15)) (PSECTOR9 47 (BITS . 15)) (PSECTOR9 48 (BITS . 15)) (PSECTOR9 49 (BITS . 15)) (PSECTOR9 50 (BITS . 15)) (PSECTOR9 51 (BITS . 15)) (PSECTOR9 52 (BITS . 15)) (PSECTOR9 53 (BITS . 15)) (PSECTOR9 54 (BITS . 15)) (PSECTOR9 55 (BITS . 15)) (PSECTOR9 56 (BITS . 15)) (PSECTOR9 57 (BITS . 15)) (PSECTOR9 58 (BITS . 15)) (PSECTOR9 59 (BITS . 15)) (PSECTOR9 60 (BITS . 15)) (PSECTOR9 61 (BITS . 15)) (PSECTOR9 62 (BITS . 15)) (PSECTOR9 63 (BITS . 15))) '64) (/DECLAREDATATYPE 'PMPAGE '(WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD SWAPPEDFIXP WORD SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PMPAGE 0 (BITS . 15)) (PMPAGE 1 (BITS . 15)) (PMPAGE 2 SWAPPEDFIXP) (PMPAGE 4 (BITS . 15)) (PMPAGE 5 SWAPPEDFIXP) (PMPAGE 7 (BITS . 15)) (PMPAGE 8 (BITS . 15)) (PMPAGE 9 (BITS . 15)) (PMPAGE 10 (BITS . 15)) (PMPAGE 11 (BITS . 15)) (PMPAGE 12 (BITS . 15)) (PMPAGE 13 (BITS . 15)) (PMPAGE 14 (BITS . 15)) (PMPAGE 15 (BITS . 15)) (PMPAGE 16 (BITS . 15)) (PMPAGE 17 (BITS . 15)) (PMPAGE 18 (BITS . 15)) (PMPAGE 19 (BITS . 15)) (PMPAGE 20 (BITS . 15)) (PMPAGE 21 (BITS . 15)) (PMPAGE 22 (BITS . 15)) (PMPAGE 23 (BITS . 15)) (PMPAGE 24 (BITS . 15)) (PMPAGE 25 (BITS . 15)) (PMPAGE 26 (BITS . 15)) (PMPAGE 27 (BITS . 15)) (PMPAGE 28 (BITS . 15)) (PMPAGE 29 (BITS . 15)) (PMPAGE 30 (BITS . 15)) (PMPAGE 31 (BITS . 15)) (PMPAGE 32 (BITS . 15)) (PMPAGE 33 (BITS . 15)) (PMPAGE 34 (BITS . 15)) (PMPAGE 35 (BITS . 15)) (PMPAGE 36 (BITS . 15)) (PMPAGE 37 (BITS . 15)) (PMPAGE 38 (BITS . 15)) (PMPAGE 39 (BITS . 15)) (PMPAGE 40 (BITS . 15)) (PMPAGE 41 (BITS . 15)) (PMPAGE 42 (BITS . 15)) (PMPAGE 43 (BITS . 15)) (PMPAGE 44 (BITS . 15)) (PMPAGE 45 (BITS . 15)) (PMPAGE 46 (BITS . 15)) (PMPAGE 47 (BITS . 15)) (PMPAGE 48 (BITS . 15)) (PMPAGE 49 (BITS . 15)) (PMPAGE 50 (BITS . 15)) (PMPAGE 51 (BITS . 15)) (PMPAGE 52 (BITS . 15)) (PMPAGE 53 (BITS . 15)) (PMPAGE 54 (BITS . 15)) (PMPAGE 55 (BITS . 15)) (PMPAGE 56 (BITS . 15)) (PMPAGE 57 (BITS . 15)) (PMPAGE 58 (BITS . 15)) (PMPAGE 59 (BITS . 15)) (PMPAGE 60 (BITS . 15)) (PMPAGE 61 (BITS . 15)) (PMPAGE 62 (BITS . 15)) (PMPAGE 63 (BITS . 15)) (PMPAGE 64 (BITS . 15)) (PMPAGE 65 (BITS . 15)) (PMPAGE 66 (BITS . 15)) (PMPAGE 67 (BITS . 15)) (PMPAGE 68 (BITS . 15)) (PMPAGE 69 (BITS . 15)) (PMPAGE 70 (BITS . 15)) (PMPAGE 71 (BITS . 15)) (PMPAGE 72 (BITS . 15)) (PMPAGE 73 (BITS . 15)) (PMPAGE 74 (BITS . 15)) (PMPAGE 75 (BITS . 15)) (PMPAGE 76 (BITS . 15)) (PMPAGE 77 (BITS . 15)) (PMPAGE 78 (BITS . 15)) (PMPAGE 79 (BITS . 15)) (PMPAGE 80 (BITS . 15)) (PMPAGE 81 (BITS . 15)) (PMPAGE 82 (BITS . 15)) (PMPAGE 83 (BITS . 15)) (PMPAGE 84 (BITS . 15)) (PMPAGE 85 (BITS . 15)) (PMPAGE 86 (BITS . 15)) (PMPAGE 87 (BITS . 15)) (PMPAGE 88 (BITS . 15)) (PMPAGE 89 (BITS . 15)) (PMPAGE 90 (BITS . 15)) (PMPAGE 91 (BITS . 15)) (PMPAGE 92 (BITS . 15)) (PMPAGE 93 (BITS . 15)) (PMPAGE 94 (BITS . 15)) (PMPAGE 95 (BITS . 15)) (PMPAGE 96 (BITS . 15)) (PMPAGE 97 (BITS . 15)) (PMPAGE 98 (BITS . 15)) (PMPAGE 99 (BITS . 15)) (PMPAGE 100 (BITS . 15)) (PMPAGE 101 (BITS . 15)) (PMPAGE 102 (BITS . 15)) (PMPAGE 103 (BITS . 15)) (PMPAGE 104 (BITS . 15)) (PMPAGE 105 (BITS . 15)) (PMPAGE 106 (BITS . 15)) (PMPAGE 107 (BITS . 15)) (PMPAGE 108 (BITS . 15)) (PMPAGE 109 (BITS . 15)) (PMPAGE 110 (BITS . 15)) (PMPAGE 111 (BITS . 15)) (PMPAGE 112 (BITS . 15)) (PMPAGE 113 (BITS . 15)) (PMPAGE 114 (BITS . 15)) (PMPAGE 115 (BITS . 15)) (PMPAGE 116 (BITS . 15)) (PMPAGE 117 (BITS . 15)) (PMPAGE 118 (BITS . 15)) (PMPAGE 119 (BITS . 15)) (PMPAGE 120 (BITS . 15)) (PMPAGE 121 (BITS . 15)) (PMPAGE 122 (BITS . 15)) (PMPAGE 123 (BITS . 15)) (PMPAGE 124 (BITS . 15)) (PMPAGE 125 (BITS . 15)) (PMPAGE 126 (BITS . 15)) (PMPAGE 127 (BITS . 15)) (PMPAGE 128 (BITS . 15)) (PMPAGE 129 SWAPPEDFIXP) (PMPAGE 131 (BITS . 15)) (PMPAGE 132 SWAPPEDFIXP) (PMPAGE 134 (BITS . 15)) (PMPAGE 135 (BITS . 15)) (PMPAGE 136 (BITS . 15)) (PMPAGE 137 (BITS . 15)) (PMPAGE 138 (BITS . 15)) (PMPAGE 139 (BITS . 15)) (PMPAGE 140 (BITS . 15)) (PMPAGE 141 (BITS . 15)) (PMPAGE 142 (BITS . 15)) (PMPAGE 143 (BITS . 15)) (PMPAGE 144 (BITS . 15)) (PMPAGE 145 (BITS . 15)) (PMPAGE 146 (BITS . 15)) (PMPAGE 147 (BITS . 15)) (PMPAGE 148 (BITS . 15)) (PMPAGE 149 (BITS . 15)) (PMPAGE 150 (BITS . 15)) (PMPAGE 151 (BITS . 15)) (PMPAGE 152 (BITS . 15)) (PMPAGE 153 (BITS . 15)) (PMPAGE 154 (BITS . 15)) (PMPAGE 155 (BITS . 15)) (PMPAGE 156 (BITS . 15)) (PMPAGE 157 (BITS . 15)) (PMPAGE 158 (BITS . 15)) (PMPAGE 159 (BITS . 15)) (PMPAGE 160 (BITS . 15)) (PMPAGE 161 (BITS . 15)) (PMPAGE 162 (BITS . 15)) (PMPAGE 163 (BITS . 15)) (PMPAGE 164 (BITS . 15)) (PMPAGE 165 (BITS . 15)) (PMPAGE 166 (BITS . 15)) (PMPAGE 167 (BITS . 15)) (PMPAGE 168 (BITS . 15)) (PMPAGE 169 (BITS . 15)) (PMPAGE 170 (BITS . 15)) (PMPAGE 171 (BITS . 15)) (PMPAGE 172 (BITS . 15)) (PMPAGE 173 (BITS . 15)) (PMPAGE 174 (BITS . 15)) (PMPAGE 175 (BITS . 15)) (PMPAGE 176 (BITS . 15)) (PMPAGE 177 (BITS . 15)) (PMPAGE 178 (BITS . 15)) (PMPAGE 179 (BITS . 15)) (PMPAGE 180 (BITS . 15)) (PMPAGE 181 (BITS . 15)) (PMPAGE 182 (BITS . 15)) (PMPAGE 183 (BITS . 15)) (PMPAGE 184 (BITS . 15)) (PMPAGE 185 (BITS . 15)) (PMPAGE 186 (BITS . 15)) (PMPAGE 187 (BITS . 15)) (PMPAGE 188 (BITS . 15)) (PMPAGE 189 (BITS . 15)) (PMPAGE 190 (BITS . 15)) (PMPAGE 191 (BITS . 15)) (PMPAGE 192 (BITS . 15)) (PMPAGE 193 (BITS . 15)) (PMPAGE 194 (BITS . 15)) (PMPAGE 195 (BITS . 15)) (PMPAGE 196 (BITS . 15)) (PMPAGE 197 (BITS . 15)) (PMPAGE 198 (BITS . 15)) (PMPAGE 199 (BITS . 15)) (PMPAGE 200 (BITS . 15)) (PMPAGE 201 (BITS . 15)) (PMPAGE 202 (BITS . 15)) (PMPAGE 203 (BITS . 15)) (PMPAGE 204 (BITS . 15)) (PMPAGE 205 (BITS . 15)) (PMPAGE 206 (BITS . 15)) (PMPAGE 207 (BITS . 15)) (PMPAGE 208 (BITS . 15)) (PMPAGE 209 (BITS . 15)) (PMPAGE 210 (BITS . 15)) (PMPAGE 211 (BITS . 15)) (PMPAGE 212 (BITS . 15)) (PMPAGE 213 (BITS . 15)) (PMPAGE 214 (BITS . 15)) (PMPAGE 215 (BITS . 15)) (PMPAGE 216 (BITS . 15)) (PMPAGE 217 (BITS . 15)) (PMPAGE 218 (BITS . 15)) (PMPAGE 219 (BITS . 15)) (PMPAGE 220 (BITS . 15)) (PMPAGE 221 (BITS . 15)) (PMPAGE 222 (BITS . 15)) (PMPAGE 223 (BITS . 15)) (PMPAGE 224 (BITS . 15)) (PMPAGE 225 (BITS . 15)) (PMPAGE 226 (BITS . 15)) (PMPAGE 227 (BITS . 15)) (PMPAGE 228 (BITS . 15)) (PMPAGE 229 (BITS . 15)) (PMPAGE 230 (BITS . 15)) (PMPAGE 231 (BITS . 15)) (PMPAGE 232 (BITS . 15)) (PMPAGE 233 (BITS . 15)) (PMPAGE 234 (BITS . 15)) (PMPAGE 235 (BITS . 15)) (PMPAGE 236 (BITS . 15)) (PMPAGE 237 (BITS . 15)) (PMPAGE 238 (BITS . 15)) (PMPAGE 239 (BITS . 15)) (PMPAGE 240 (BITS . 15)) (PMPAGE 241 (BITS . 15)) (PMPAGE 242 (BITS . 15)) (PMPAGE 243 (BITS . 15)) (PMPAGE 244 (BITS . 15)) (PMPAGE 245 (BITS . 15)) (PMPAGE 246 (BITS . 15)) (PMPAGE 247 (BITS . 15)) (PMPAGE 248 (BITS . 15)) (PMPAGE 249 (BITS . 15)) (PMPAGE 250 (BITS . 15)) (PMPAGE 251 (BITS . 15)) (PMPAGE 252 (BITS . 15)) (PMPAGE 253 (BITS . 15)) (PMPAGE 254 (BITS . 15)) (PMPAGE 255 (BITS . 15))) '256) (/DECLAREDATATYPE 'PLPAGE '(WORD WORD WORD SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((PLPAGE 0 (BITS . 15)) (PLPAGE 1 (BITS . 15)) (PLPAGE 2 (BITS . 15)) (PLPAGE 3 SWAPPEDFIXP) (PLPAGE 5 SWAPPEDFIXP) (PLPAGE 7 SWAPPEDFIXP) (PLPAGE 9 SWAPPEDFIXP) (PLPAGE 11 SWAPPEDFIXP) (PLPAGE 13 SWAPPEDFIXP) (PLPAGE 15 (BITS . 15)) (PLPAGE 16 (BITS . 15)) (PLPAGE 17 (BITS . 15)) (PLPAGE 18 (BITS . 15)) (PLPAGE 19 (BITS . 15)) (PLPAGE 20 (BITS . 15)) (PLPAGE 21 (BITS . 15)) (PLPAGE 22 (BITS . 15)) (PLPAGE 23 (BITS . 15)) (PLPAGE 24 (BITS . 15)) (PLPAGE 25 (BITS . 15)) (PLPAGE 26 (BITS . 15)) (PLPAGE 27 (BITS . 15)) (PLPAGE 28 (BITS . 15)) (PLPAGE 29 (BITS . 15)) (PLPAGE 30 (BITS . 15)) (PLPAGE 31 (BITS . 15)) (PLPAGE 32 (BITS . 15)) (PLPAGE 33 (BITS . 15)) (PLPAGE 34 (BITS . 15)) (PLPAGE 35 (BITS . 15)) (PLPAGE 36 (BITS . 15)) (PLPAGE 37 (BITS . 15)) (PLPAGE 38 (BITS . 15)) (PLPAGE 39 (BITS . 15)) (PLPAGE 40 (BITS . 15)) (PLPAGE 41 (BITS . 15)) (PLPAGE 42 (BITS . 15)) (PLPAGE 43 (BITS . 15)) (PLPAGE 44 (BITS . 15)) (PLPAGE 45 (BITS . 15)) (PLPAGE 46 (BITS . 15)) (PLPAGE 47 (BITS . 15)) (PLPAGE 48 (BITS . 15)) (PLPAGE 49 (BITS . 15)) (PLPAGE 50 (BITS . 15)) (PLPAGE 51 (BITS . 15)) (PLPAGE 52 (BITS . 15)) (PLPAGE 53 (BITS . 15)) (PLPAGE 54 (BITS . 15)) (PLPAGE 55 (BITS . 15)) (PLPAGE 56 (BITS . 15)) (PLPAGE 57 (BITS . 15)) (PLPAGE 58 (BITS . 15)) (PLPAGE 59 (BITS . 15)) (PLPAGE 60 (BITS . 15)) (PLPAGE 61 (BITS . 15)) (PLPAGE 62 (BITS . 15)) (PLPAGE 63 (BITS . 15)) (PLPAGE 64 (BITS . 15)) (PLPAGE 65 (BITS . 15)) (PLPAGE 66 (BITS . 15)) (PLPAGE 67 (BITS . 15)) (PLPAGE 68 (BITS . 15)) (PLPAGE 69 (BITS . 15)) (PLPAGE 70 (BITS . 15)) (PLPAGE 71 (BITS . 15)) (PLPAGE 72 (BITS . 15)) (PLPAGE 73 (BITS . 15)) (PLPAGE 74 (BITS . 15)) (PLPAGE 75 (BITS . 15)) (PLPAGE 76 (BITS . 15)) (PLPAGE 77 (BITS . 15)) (PLPAGE 78 (BITS . 15)) (PLPAGE 79 (BITS . 15)) (PLPAGE 80 (BITS . 15)) (PLPAGE 81 (BITS . 15)) (PLPAGE 82 (BITS . 15)) (PLPAGE 83 (BITS . 15)) (PLPAGE 84 (BITS . 15)) (PLPAGE 85 (BITS . 15)) (PLPAGE 86 (BITS . 15)) (PLPAGE 87 (BITS . 15)) (PLPAGE 88 (BITS . 15)) (PLPAGE 89 (BITS . 15)) (PLPAGE 90 (BITS . 15)) (PLPAGE 91 (BITS . 15)) (PLPAGE 92 (BITS . 15)) (PLPAGE 93 (BITS . 15)) (PLPAGE 94 (BITS . 15)) (PLPAGE 95 (BITS . 15)) (PLPAGE 96 (BITS . 15)) (PLPAGE 97 (BITS . 15)) (PLPAGE 98 (BITS . 15)) (PLPAGE 99 (BITS . 15)) (PLPAGE 100 (BITS . 15)) (PLPAGE 101 (BITS . 15)) (PLPAGE 102 (BITS . 15)) (PLPAGE 103 (BITS . 15)) (PLPAGE 104 (BITS . 15)) (PLPAGE 105 (BITS . 15)) (PLPAGE 106 (BITS . 15)) (PLPAGE 107 (BITS . 15)) (PLPAGE 108 (BITS . 15)) (PLPAGE 109 (BITS . 15)) (PLPAGE 110 (BITS . 15)) (PLPAGE 111 (BITS . 15)) (PLPAGE 112 (BITS . 15)) (PLPAGE 113 (BITS . 15)) (PLPAGE 114 (BITS . 15)) (PLPAGE 115 (BITS . 15)) (PLPAGE 116 (BITS . 15)) (PLPAGE 117 (BITS . 15)) (PLPAGE 118 (BITS . 15)) (PLPAGE 119 (BITS . 15)) (PLPAGE 120 (BITS . 15)) (PLPAGE 121 (BITS . 15)) (PLPAGE 122 (BITS . 15)) (PLPAGE 123 (BITS . 15)) (PLPAGE 124 (BITS . 15)) (PLPAGE 125 (BITS . 15)) (PLPAGE 126 (BITS . 15)) (PLPAGE 127 (BITS . 15)) (PLPAGE 128 (BITS . 15)) (PLPAGE 129 (BITS . 15)) (PLPAGE 130 (BITS . 15)) (PLPAGE 131 (BITS . 15)) (PLPAGE 132 (BITS . 15)) (PLPAGE 133 (BITS . 15)) (PLPAGE 134 (BITS . 15)) (PLPAGE 135 (BITS . 15)) (PLPAGE 136 (BITS . 15)) (PLPAGE 137 (BITS . 15)) (PLPAGE 138 (BITS . 15)) (PLPAGE 139 (BITS . 15)) (PLPAGE 140 (BITS . 15)) (PLPAGE 141 (BITS . 15)) (PLPAGE 142 (BITS . 15)) (PLPAGE 143 (BITS . 15)) (PLPAGE 144 (BITS . 15)) (PLPAGE 145 (BITS . 15)) (PLPAGE 146 (BITS . 15)) (PLPAGE 147 (BITS . 15)) (PLPAGE 148 (BITS . 15)) (PLPAGE 149 (BITS . 15)) (PLPAGE 150 (BITS . 15)) (PLPAGE 151 (BITS . 15)) (PLPAGE 152 (BITS . 15)) (PLPAGE 153 (BITS . 15)) (PLPAGE 154 (BITS . 15)) (PLPAGE 155 (BITS . 15)) (PLPAGE 156 (BITS . 15)) (PLPAGE 157 (BITS . 15)) (PLPAGE 158 (BITS . 15)) (PLPAGE 159 (BITS . 15)) (PLPAGE 160 (BITS . 15)) (PLPAGE 161 (BITS . 15)) (PLPAGE 162 (BITS . 15)) (PLPAGE 163 (BITS . 15)) (PLPAGE 164 (BITS . 15)) (PLPAGE 165 (BITS . 15)) (PLPAGE 166 (BITS . 15)) (PLPAGE 167 (BITS . 15)) (PLPAGE 168 (BITS . 15)) (PLPAGE 169 (BITS . 15)) (PLPAGE 170 (BITS . 15)) (PLPAGE 171 (BITS . 15)) (PLPAGE 172 (BITS . 15)) (PLPAGE 173 (BITS . 15)) (PLPAGE 174 (BITS . 15)) (PLPAGE 175 (BITS . 15)) (PLPAGE 176 (BITS . 15)) (PLPAGE 177 (BITS . 15)) (PLPAGE 178 (BITS . 15)) (PLPAGE 179 (BITS . 15)) (PLPAGE 180 (BITS . 15)) (PLPAGE 181 (BITS . 15)) (PLPAGE 182 (BITS . 15)) (PLPAGE 183 (BITS . 15)) (PLPAGE 184 (BITS . 15)) (PLPAGE 185 (BITS . 15)) (PLPAGE 186 (BITS . 15)) (PLPAGE 187 (BITS . 15)) (PLPAGE 188 (BITS . 15)) (PLPAGE 189 (BITS . 15)) (PLPAGE 190 (BITS . 15)) (PLPAGE 191 (BITS . 15)) (PLPAGE 192 (BITS . 15)) (PLPAGE 193 (BITS . 15)) (PLPAGE 194 (BITS . 15)) (PLPAGE 195 (BITS . 15)) (PLPAGE 196 (BITS . 15)) (PLPAGE 197 (BITS . 15)) (PLPAGE 198 (BITS . 15)) (PLPAGE 199 (BITS . 15)) (PLPAGE 200 (BITS . 15)) (PLPAGE 201 (BITS . 15)) (PLPAGE 202 (BITS . 15)) (PLPAGE 203 (BITS . 15)) (PLPAGE 204 (BITS . 15)) (PLPAGE 205 (BITS . 15)) (PLPAGE 206 (BITS . 15)) (PLPAGE 207 (BITS . 15)) (PLPAGE 208 (BITS . 15)) (PLPAGE 209 (BITS . 15)) (PLPAGE 210 (BITS . 15)) (PLPAGE 211 (BITS . 15)) (PLPAGE 212 (BITS . 15)) (PLPAGE 213 (BITS . 15)) (PLPAGE 214 (BITS . 15)) (PLPAGE 215 (BITS . 15)) (PLPAGE 216 (BITS . 15)) (PLPAGE 217 (BITS . 15)) (PLPAGE 218 (BITS . 15)) (PLPAGE 219 (BITS . 15)) (PLPAGE 220 (BITS . 15)) (PLPAGE 221 (BITS . 15)) (PLPAGE 222 (BITS . 15)) (PLPAGE 223 (BITS . 15)) (PLPAGE 224 (BITS . 15)) (PLPAGE 225 (BITS . 15)) (PLPAGE 226 (BITS . 15)) (PLPAGE 227 (BITS . 15)) (PLPAGE 228 (BITS . 15)) (PLPAGE 229 (BITS . 15)) (PLPAGE 230 (BITS . 15)) (PLPAGE 231 (BITS . 15)) (PLPAGE 232 (BITS . 15)) (PLPAGE 233 (BITS . 15)) (PLPAGE 234 (BITS . 15)) (PLPAGE 235 (BITS . 15)) (PLPAGE 236 (BITS . 15)) (PLPAGE 237 (BITS . 15)) (PLPAGE 238 (BITS . 15)) (PLPAGE 239 (BITS . 15)) (PLPAGE 240 (BITS . 15)) (PLPAGE 241 (BITS . 15)) (PLPAGE 242 (BITS . 15)) (PLPAGE 243 (BITS . 15)) (PLPAGE 244 (BITS . 15)) (PLPAGE 245 (BITS . 15)) (PLPAGE 246 (BITS . 15)) (PLPAGE 247 (BITS . 15)) (PLPAGE 248 (BITS . 15)) (PLPAGE 249 (BITS . 15)) (PLPAGE 250 (BITS . 15)) (PLPAGE 251 (BITS . 15)) (PLPAGE 252 (BITS . 15)) (PLPAGE 253 (BITS . 15)) (PLPAGE 254 (BITS . 15))) '256) (/DECLAREDATATYPE 'PFLE '(SWAPPEDFIXP WORD WORD WORD) '((PFLE 0 SWAPPEDFIXP) (PFLE 2 (BITS . 15)) (PFLE 3 (BITS . 15)) (PFLE 4 (BITS . 15))) '6) ) (DEFINEQ (\FLOPPY.TRANSLATEFLOPPYRESULT [LAMBDA (FLOPPYRESULT) (* kbr%: "23-Jul-84 01:08") (SELECT (LOGAND FLOPPYRESULT R.WRITEERRORMASK) (R.WRITEPROTECT 'WRITEPROTECT) (SELECT (LOGAND FLOPPYRESULT R.READERRORMASK) (R.OK 'OK) (R.BUSY 'BUSY) (R.CRCERROR 'CRCERROR) (R.DATALOST 'DATALOST) (R.DOOROPENED 'DOOROPENED) (R.DOORISOPEN 'DOORISOPEN) (R.DOORISOPEN2 'DOORISOPEN) (R.NOTREADY 'NOTREADY) (R.RECALIBRATEERROR 'RECALIBRATERROR) (R.RECORDNOTFOUND 'RECORDNOTFOUND) (R.WRITEPROTECT 'WRITEPROTECT) 'UNKNOWNERROR]) (\FLOPPY.SEVERE.ERROR [LAMBDA (MESSAGE) (* kbr%: "22-Mar-86 18:09") (* FLOPPY just tried to do something  that would have crashed lisp.  *) (PROG NIL (ERROR "Floppy: Severe Error!" MESSAGE) (COND (\DOVEFLOPPY.TRACEFLG (STOPTEST]) (\FLOPPY.TRANSLATEPMPAGEETYPE [LAMBDA (PMPAGEETYPE) (* kbr%: "23-Jul-84 01:08") (SELECT PMPAGEETYPE (PMPAGEETYPE.FREE 'FREE) (PMPAGEETYPE.FILE 'FILE) (PMPAGEETYPE.PFILELIST 'PFILELIST) (PMPAGEETYPE.BADSECTORS 'BADSECTORS) '?]) (\FLOPPY.TRANSLATEFILETYPE [LAMBDA (FILETYPE) (* kbr%: "23-Jul-84 01:08") (SELECT FILETYPE (FILETYPE.FREE 'FREE) (2048 'UNASSIGNED) (2049 'DIRECTORY) (2050 'ATVMSTRANSACTION) (2051 'BACKSTOPLOG) (FILETYPE.FILE 'FILE) (2053 'CLEARINGHOUSEBACKUPFILE) (FILETYPE.PFILELIST 'PFILELIST) (2055 'BACKSTOPDEBUGGER) (2066 'BACKSTOPDEBUGGEE) '?]) (\FLOPPY.MTL.FIXP [LAMBDA (X) (* kbr%: "23-Jul-84 01:08") (* Mesa FIXP to Lisp FIXP.  *) (ROT X 16 32]) (\FLOPPY.LTM.FIXP [LAMBDA (X) (* kbr%: "23-Jul-84 01:08") (* Lisp FIXP to Mesa FIXP.  *) (ROT X 16 32]) (\FLOPPY.MTL.IDATE [LAMBDA (X) (* kbr%: "23-Jul-84 01:08") (* Mesa IDATE to Lisp IDATE.  *) (LOGXOR -2147483648 X]) (\FLOPPY.LTM.IDATE [LAMBDA (X) (* kbr%: "23-Jul-84 01:08") (* Lisp IDATE to Mesa IDATE.  *) (LOGXOR -2147483648 X]) ) (* ; "`HEAD' *") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ IBMS128 0) (RPAQQ IBMS256 1) (RPAQQ IBMS512 2) (RPAQQ IBMS1024 3) (RPAQQ IBMD128 4) (RPAQQ IBMD256 5) (RPAQQ IBMD512 6) (RPAQQ IBMD1024 7) (CONSTANTS (IBMS128 0) (IBMS256 1) (IBMS512 2) (IBMS1024 3) (IBMD128 4) (IBMD256 5) (IBMD512 6) (IBMD1024 7)) ) ) (RPAQ? \FLOPPY.DEBUG NIL) (RPAQ? \FLOPPY.CYLINDERS 77) (RPAQ? \FLOPPY.TRACKSPERCYLINDER 2) (RPAQ? \FLOPPY.SECTORSPERTRACK 15) (RPAQ? \FLOPPYMPERRORS 0) (RPAQ? \FLOPPYMPERRORSFLG NIL) (RPAQ? \FLOPPY.MOUNTEDP.DOVETIME NIL) (RPAQ? \FLOPPY.MOUNTEDP.DOVEANSWER NIL) (DEFINEQ (\FLOPPY.TRANSLATESETUP [LAMBDA (SETUP) (* kbr%: "22-Jul-84 22:34") (SELECT SETUP (IBMS128 'IBMS128) (IBMS256 'IBMS256) (IBMS512 'IBMS512) (IBMS1024 'IBMS1024) (IBMD128 'IBMD128) (IBMD256 'IBMD256) (IBMD512 'IBMD512) (IBMD1024 'IBMD1024) (SHOULDNT]) (\FLOPPY.SETUP.IOCB [LAMBDA (FLOPPYIOCB SETUP) (* ; "Edited 11-Jun-87 17:17 by jds") (* ;  "Change setup (i.e. manufacturer, density, and sectorlength info) of FLOPPYIOCB to SETUP. *") (PROG (SECTORLENGTH DENSITY ENCODEDSECTORLENGTH SECTORSPERTRACK GAP3) (SETQ SECTORLENGTH (\FLOPPY.SECTORLENGTH SETUP)) (SETQ DENSITY (\FLOPPY.DENSITY SETUP)) (SETQ ENCODEDSECTORLENGTH (\FLOPPY.ENCODEDSECTORLENGTH SETUP)) (SETQ SECTORSPERTRACK (\FLOPPY.SECTORSPERTRACK SETUP)) (SETQ GAP3 (\FLOPPY.GAP3 SETUP)) (* ;  "UNINTERRUPTABLY because mislaid FLOPPYIOCBs FLOPPYRESULT in 500 PMPAGE series hard crashes. *") (UNINTERRUPTABLY (replace (FLOPPYIOCB SECTORLENGTHDIV2) of FLOPPYIOCB with (LRSH SECTORLENGTH 1)) (replace (FLOPPYIOCB DENSITY) of FLOPPYIOCB with DENSITY) (replace (FLOPPYIOCB TROYORIBM) of FLOPPYIOCB with IBM) (replace (FLOPPYIOCB SECTORLENGTHDIV4) of FLOPPYIOCB with (LRSH SECTORLENGTH 2)) (replace (FLOPPYIOCB ENCODEDSECTORLENGTH) of FLOPPYIOCB with ENCODEDSECTORLENGTH ) (replace (FLOPPYIOCB SECTORSPERTRACK) of FLOPPYIOCB with SECTORSPERTRACK) (replace (FLOPPYIOCB GAP3) of FLOPPYIOCB with GAP3)) (RETURN FLOPPYIOCB]) (\FLOPPY.CHECK.FLOPPYIOCB [LAMBDA (FLOPPYIOCB) (* kbr%: " 7-Aug-85 19:20") (* Check FLOPPYIOCB is legal--A  better debugging tool than  bletcherous flashing PMPAGE codes.  *) (PROG (SETUP) (* Check command *) (COND ((OR (NOT (MEMB (fetch (FLOPPYIOCB COMMAND) of FLOPPYIOCB) (LIST C.NOP C.INITIALIZE C.RECALIBRATE C.READSECTOR C.WRITESECTOR C.FORMATTRACK))) (NOT (IEQP (fetch (FLOPPYIOCB SUBCOMMAND) of FLOPPYIOCB) SC.NOP))) (* We're not supporting anything  besides these. *) (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Command"))) (* Check diskaddress *) (create DISKADDRESS CYLINDER _ (fetch (FLOPPYIOCB CYLINDER) of FLOPPYIOCB) HEAD _ (fetch (FLOPPYIOCB HEAD) of FLOPPYIOCB) SECTOR _ (fetch (FLOPPYIOCB SECTOR) of FLOPPYIOCB)) (* Check buffer *) (COND ([NOT (OR (AND (fetch (FLOPPYIOCB BUFFER) of FLOPPYIOCB) (IEQP (fetch (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB) 1)) (AND (NULL (fetch (FLOPPYIOCB BUFFER) of FLOPPYIOCB)) (ZEROP (fetch (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB))) (AND (IEQP (fetch (FLOPPYIOCB COMMAND) of FLOPPYIOCB) C.FORMATTRACK) (ILEQ (IPLUS (fetch (FLOPPYIOCB CYLINDER) of FLOPPYIOCB) (fetch (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB)) \FLOPPY.CYLINDERS] (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Buffer"))) (* Check setup *) (COND ((OR (IEQP (fetch (FLOPPYIOCB TROYORIBM) of FLOPPYIOCB) TROY) (fetch (FLOPPYIOCB SAMEPAGE) of FLOPPYIOCB)) (* We're not supporting these.  *) (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Setup 1"))) (SETQ SETUP (SELECTC (fetch (FLOPPYIOCB DENSITY) of FLOPPYIOCB) (SINGLE (SELECTC (fetch (FLOPPYIOCB ENCODEDSECTORLENGTH) of FLOPPYIOCB ) (B128 IBMS128) (B256 IBMS256) (B512 IBMS512) (B1024 IBMS1024) (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Setup 2"))) (DOUBLE (SELECTC (fetch (FLOPPYIOCB ENCODEDSECTORLENGTH) of FLOPPYIOCB ) (B128 IBMD128) (B256 IBMD256) (B512 IBMD512) (B1024 IBMD1024) (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Setup 2"))) (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Setup 2"))) (COND ([OR (NOT (IEQP (fetch (FLOPPYIOCB SECTORLENGTHDIV2) of FLOPPYIOCB) (IQUOTIENT (\FLOPPY.SECTORLENGTH SETUP) 2))) (NOT (IEQP (fetch (FLOPPYIOCB SECTORLENGTHDIV4) of FLOPPYIOCB) (IQUOTIENT (\FLOPPY.SECTORLENGTH SETUP) 4))) (NOT (IEQP (fetch (FLOPPYIOCB SECTORSPERTRACK) of FLOPPYIOCB) (\FLOPPY.SECTORSPERTRACK SETUP))) (IGREATERP (fetch (FLOPPYIOCB SECTOR) of FLOPPYIOCB) (fetch (FLOPPYIOCB SECTORSPERTRACK) of FLOPPYIOCB)) (NOT (IEQP (fetch (FLOPPYIOCB GAP3) of FLOPPYIOCB) (\FLOPPY.GAP3 SETUP] (\FLOPPY.SEVERE.ERROR "Illegal FLOPPYIOCB Setup 3"]) (\FLOPPY.DENSITY [LAMBDA (SETUP) (* ; "Edited 11-Jun-87 17:17 by jds") (* ;; "zConvert from an encoded setup code to a density value: 0 for single, 8 for double.") (SELECT SETUP ((IBMS128 IBMS256 IBMS512 IBMS1024) SINGLE) ((IBMD128 IBMD256 IBMD512 IBMD1024) DOUBLE) (SHOULDNT]) (\FLOPPY.SECTORLENGTH [LAMBDA (SETUP) (* kbr%: "22-Jul-84 22:34") (SELECT SETUP ((IBMS128 IBMD128) 128) ((IBMS256 IBMD256) 256) ((IBMS512 IBMD512) 512) ((IBMS1024 IBMD1024) 1024) (SHOULDNT]) (\FLOPPY.ENCODEDSECTORLENGTH [LAMBDA (SETUP) (* kbr%: "22-Jul-84 22:34") (SELECT SETUP ((IBMS128 IBMD128) B128) ((IBMS256 IBMD256) B256) ((IBMS512 IBMD512) B512) ((IBMS1024 IBMD1024) B1024) (SHOULDNT]) (\FLOPPY.GAP3 [LAMBDA (SETUP) (* kbr%: "22-Jul-84 22:34") (SELECT SETUP (IBMS128 27) (IBMS256 42) (IBMS512 58) (IBMS1024 75) (IBMD128 26) (IBMD256 54) (IBMD512 84) (IBMD1024 116) (SHOULDNT]) (\FLOPPY.SECTORSPERTRACK [LAMBDA (SETUP) (* kbr%: "22-Jul-84 22:34") (SELECT SETUP (IBMS128 26) (IBMS256 15) (IBMS512 8) (IBMS1024 4) (IBMD128 36) (IBMD256 26) (IBMD512 15) (IBMD1024 8) (SHOULDNT]) (\FLOPPY.RUN [LAMBDA (FLOPPYIOCB NOERROR) (* kbr%: "11-Oct-85 15:21") (* Returns T if command successfully  completed. *) (PROG (RETRYFLG) RETRY (RESETLST (RESETSAVE (\FLOPPY.LOCK.BUFFER FLOPPYIOCB) (LIST (FUNCTION \FLOPPY.UNLOCK.BUFFER) FLOPPYIOCB)) (* IOP acts when it sees nonzero  NEXT field of CSB.  *) (while (NOT (ZEROP (fetch (IOPAGE DLFLOPPYCMD) of \IOPAGE))) do (* Since we're monitor locked, this  particular loop shouldnt be  necessary. *) (BLOCK)) (UNINTERRUPTABLY (\BLT \FLOPPYIOCB FLOPPYIOCB FLOPPYIOCB.SIZE) (replace (IOPAGE DLFLOPPYCMD) of \IOPAGE with \FLOPPYIOCBADDR)) (while (NOT (ZEROP (fetch (IOPAGE DLFLOPPYCMD) of \IOPAGE))) do (BLOCK))) (COND ((NOT (OR (fetch (FLOPPYRESULT ERROR) of \FLOPPYRESULT) (fetch (FLOPPYRESULT MPERROR) of \FLOPPYRESULT))) (RETURN T)) ((fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT) (* Note%: ERROR flag is on whenever  DOOROPENED is on. *) (* Door opened. Always an error at  this deep a level.  (Otherwise user could switch  floppies on stream.) *) (\FLOPPY.ERROR) (* Abandon command.  *) (RETURN NIL)) [[AND (OR (fetch (FLOPPYRESULT RECORDNOTFOUND) of \FLOPPYRESULT) (fetch (FLOPPYRESULT RECALIBRATEERROR) of \FLOPPYRESULT)) (NOT RETRYFLG) (NOT (MEMB (fetch (FLOPPYIOCB COMMAND) of FLOPPYIOCB) (LIST C.INITIALIZE C.RECALIBRATE C.NOP] (* Try one more time after  initializing and recalibrating.  *) (\FLOPPY.INITIALIZE NOERROR) (COND ((NOT (fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT)) (\FLOPPY.RECALIBRATE NOERROR] [(fetch (FLOPPYRESULT MPERROR) of \FLOPPYRESULT) (SETQ \FLOPPYMPERRORS (ADD1 \FLOPPYMPERRORS)) (* These should only be generated by still undiagnosed bugs living in IOP  assembly language code. Reissuing command seems to work.  *) [COND (\FLOPPYMPERRORSFLG (\FLOPPY.BREAK (fetch (FLOPPYRESULT MPMESSAGE) of \FLOPPYRESULT] (COND [RETRYFLG (COND (NOERROR (RETURN NIL)) (T (\FLOPPY.BREAK (fetch (FLOPPYRESULT MPMESSAGE) of \FLOPPYRESULT ] ((FMEMB (fetch (FLOPPYRESULT MPERROR) of \FLOPPYRESULT) '(597 598)) (* These 597 and 598 pseudo mpcodes were installed by Mitch Lichtenberg to  avoid FLOPPY sometimes crashing the Dandelion with MPC 1108, espesicially when  RS232 is also running. See AR291. Supposedly helps to wait 1 or 2 seconds after  this kind of spurious error. *) (BLOCK 2000] [(fetch (FLOPPYRESULT CRCERROR) of \FLOPPYRESULT) (* Cyclic Redundancy Check.  Reissuing command seems to work.  *) (COND (RETRYFLG (COND (NOERROR (RETURN NIL)) (T (\FLOPPY.BREAK 'CRCERROR] (NOERROR (* Abandon command.  Calling routine will handle  (or ignore) error.  *) (RETURN NIL)) (T (* Hit the user with the bad news.  *) (\FLOPPY.ERROR))) (SETQ RETRYFLG T) (GO RETRY]) (\FLOPPY.ERROR [LAMBDA NIL (* ; "Edited 28-Oct-87 14:53 by jds") (* ;; "Indicate to the user that an error happened in the FLOPPY drive or driver code.") (PROG ($FLOPPYRESULT) (SETQ $FLOPPYRESULT (\FLOPPY.TRANSLATEFLOPPYRESULT (fetch (FLOPPYRESULT WORD) of \FLOPPYRESULT))) [COND ((EQ $FLOPPYRESULT 'DOOROPENED) (* ;;  "Floppy drive door solenoids will lock drive door in place after a DOOROPENED error.") (* ;; "DISKCHANGECLEAR done before break to unlock the door and allow user to remedy if no floppy present.") (\FLOPPY.CLOSE) (\FLOPPY.INITIALIZE) (COND ((NOT (fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT)) (\FLOPPY.RECALIBRATE] (\FLOPPY.INITIALIZE) (\FLOPPY.BREAK $FLOPPYRESULT) (COND ((MEMB $FLOPPYRESULT '(DOOROPENED DOORISOPEN)) (\FLOPPY.CLOSE))) (* ;  "INITIALIZE again, since user may open floppy drive door during break. *") (\FLOPPY.INITIALIZE) (COND ((NOT (fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT)) (\FLOPPY.RECALIBRATE]) (\FLOPPY.LOCK.BUFFER [LAMBDA (FLOPPYIOCB) (* ; "Edited 11-Jun-87 11:09 by jds") (* ;; "Lock floppy buffer down.") (PROG (BUFFER COUNT) (* ;; "NOTE: This routine insures each floppy buffer page has been referenced before being sent to the IOP. If the IOP sees a CP page hasn't been referenced, the IOP forces a fatal 510 crash. *") (COND ((MEMB (fetch (FLOPPYIOCB COMMAND) of FLOPPYIOCB) (LIST C.READSECTOR C.WRITESECTOR)) (SETQ BUFFER (fetch (FLOPPYIOCB BUFFER) of FLOPPYIOCB)) (SETQ COUNT (fetch (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB)) (\TEMPLOCKPAGES BUFFER COUNT) (* ; "Lock the buffer") (* ;; "Fatal 510 error possible without this loop:") (for J from 0 to (SUB1 COUNT) do (* ;;  "Force a reference to each buffer page.") (\PUTBASE BUFFER (ITIMES 256 J) (\GETBASE BUFFER (ITIMES 256 J]) (\FLOPPY.UNLOCK.BUFFER [LAMBDA (FLOPPYIOCB) (* ; "Edited 11-Jun-87 11:10 by jds") (* ;; "Unlock floppy buffer.") (PROG (BUFFER COUNT) (COND ((MEMB (fetch (FLOPPYIOCB COMMAND) of FLOPPYIOCB) (LIST C.READSECTOR C.WRITESECTOR)) (SETQ BUFFER (fetch (FLOPPYIOCB BUFFER) of FLOPPYIOCB)) (SETQ COUNT (fetch (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB)) (\TEMPUNLOCKPAGES BUFFER COUNT]) (\FLOPPY.PREPAREFORCRASH [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (PROG NIL (* Prepare for the worst by duMPing all pertinent records to screen before  doing \FLOPPY.RUN in case we crash *) (\FLOPPY.DEBUGBLOCKS) (SAVEVM) (COND ([NOT (MEMBER (PROMPTFORWORD "Proceed?" NIL NIL PROMPTWINDOW) '(NIL "y" "Y" "yes" "YES"] (RESET]) (\FLOPPY.COMMAND [LAMBDA (FLOPPYIOCB COMMAND SUBCOMMAND NOERROR) (* kbr%: "22-Jul-84 22:34") (PROG (DISKADDRESS) (SETQ DISKADDRESS (CONSTANT (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 1))) (UNINTERRUPTABLY (replace (FLOPPYIOCB COMMAND) of FLOPPYIOCB with COMMAND) (replace (FLOPPYIOCB SUBCOMMAND) of FLOPPYIOCB with SUBCOMMAND) (replace (FLOPPYIOCB DISKADDRESS) of FLOPPYIOCB with DISKADDRESS) (replace (FLOPPYIOCB BUFFER) of FLOPPYIOCB with NIL) (replace (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB with 0)) (RETURN (\FLOPPY.RUN FLOPPYIOCB NOERROR]) (\FLOPPY.INITIALIZE [LAMBDA (NOERROR) (* ; "Edited 11-Jun-87 17:03 by jds") (* ;; "Initialize a floppy--recalibrate the heads and clear any %"door opened%" bit.") (SELECTQ (MACHINETYPE) (DANDELION (GLOBALRESOURCE \FLOPPY.SCRATCH.FLOPPYIOCB (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.INITIALIZE SC.NOP NOERROR) (* ;; "DISKCHANGECLEAR is needed for KIKU machine. KIKU's INITIALIZE doesn't clear DOOROPENED flag in \FLOPPYRESULT and IOP will not proceed until it is cleared. *") (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.ESCAPE SC.DISKCHANGECLEAR NOERROR))) (DOVE (\DOVEFLOPPY.RESET)) NIL]) (\FLOPPY.NOP [LAMBDA (NOERROR) (* kbr%: "22-Jul-84 22:34") (GLOBALRESOURCE \FLOPPY.SCRATCH.FLOPPYIOCB (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.NOP SC.NOP NOERROR]) (\FLOPPY.RECALIBRATE [LAMBDA (NOERROR) (* kbr%: " 5-Oct-85 20:09") (SELECTQ (MACHINETYPE) (DANDELION (GLOBALRESOURCE \FLOPPY.SCRATCH.FLOPPYIOCB (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.RECALIBRATE SC.NOP NOERROR))) (DOVE T) NIL]) (\FLOPPY.RECOVER [LAMBDA (NOERROR) (* kbr%: "22-Jul-84 22:34") (GLOBALRESOURCE \FLOPPY.SCRATCH.FLOPPYIOCB (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.ESCAPE SC.DISKCHANGECLEAR NOERROR]) (\FLOPPY.TRANSFER [LAMBDA (FLOPPYIOCB COMMAND DISKADDRESS PAGE NOERROR) (* kbr%: "17-Apr-86 18:41") (PROG (MESSAGE ANSWER) (SETQ ANSWER (SELECTQ (MACHINETYPE) (DANDELION (SETQ COMMAND (SELECTQ COMMAND (READ C.READSECTOR) (WRITE C.WRITESECTOR) (SHOULDNT))) (UNINTERRUPTABLY (replace (FLOPPYIOCB COMMAND) of FLOPPYIOCB with COMMAND) (replace (FLOPPYIOCB SUBCOMMAND) of FLOPPYIOCB with SC.NOP) (replace (FLOPPYIOCB DISKADDRESS) of FLOPPYIOCB with DISKADDRESS) (replace (FLOPPYIOCB BUFFER) of FLOPPYIOCB with PAGE) (replace (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB with 1)) (COND ((\FLOPPY.RUN FLOPPYIOCB NOERROR) (* Successful coMPletion.  *) PAGE))) (DOVE (SETQ COMMAND (SELECTQ COMMAND (READ 'READDATA) (WRITE 'WRITEDATA) (SHOULDNT))) (\DOVEFLOPPY.SETCONTEXT (fetch (FLOPPYIOCB $DENSITY) of FLOPPYIOCB) (fetch (FLOPPYIOCB $ENCODEDSECTORLENGTH) of FLOPPYIOCB )) (COND ((EQ COMMAND 'WRITEDATA) (* kbr%: "24-Mar-86 01:36" We're going to write a sector on DOVE floppy, but it  turns out that DOVE floppy drive heads vibrate when they move and 1 in 5000  times you smash your floppy if you try to move and write with the same  operation. We get around this problem by first doing our move during a read  operation, which is safe since we are not modifying floppy during a read.  After completing the read we do a DISMISS to pass a little time between the  read/move and the coming write. I tried running without the DISMISS and do  still find occasional long sequences of MISSINGADDRESSMARKs or DATAERRORs in  the error log in TRACEWINDOW I get with \DOVEFLOPPY.TRACEFLG = T.  After 10 hours of filebanging operations, one of the long sequences finally got  long enough to break FLOPPY. I have not tested yet whether the DISMISS does any  good, but I don't think it can hurt. (WHAT A MESS!) *) (* kbr%: "17-Apr-86 18:38" Message from PURVES.OSBUNORTH AND  MCQUILKIN.OSBUNORTH recomends 40 ms settling time for DOVE floppy drive head  before writing. Therefore (DISMISS 20) changed to  (DISMISS 40) Pray this works. *) (GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER2 (\DOVEFLOPPY.XFERDISK (fetch (DISKADDRESS CYLINDER) of DISKADDRESS) (fetch (DISKADDRESS HEAD) of DISKADDRESS) (fetch (DISKADDRESS SECTOR) of DISKADDRESS ) \FLOPPY.SCRATCH.BUFFER2 'READDATA)) (DISMISS 40))) (SETQ MESSAGE (\DOVEFLOPPY.XFERDISK (fetch (DISKADDRESS CYLINDER ) of DISKADDRESS) (fetch (DISKADDRESS HEAD) of DISKADDRESS ) (fetch (DISKADDRESS SECTOR) of DISKADDRESS ) PAGE COMMAND)) (COND ((EQ MESSAGE 'OK) PAGE) ((NOT NOERROR) (\FLOPPY.BREAK MESSAGE)))) NIL)) (RETURN ANSWER]) (\FLOPPY.READSECTOR [LAMBDA (FLOPPYIOCB DISKADDRESS PAGE NOERROR) (* kbr%: " 7-Aug-85 20:42") (\FLOPPY.TRANSFER FLOPPYIOCB 'READ DISKADDRESS PAGE NOERROR]) (\FLOPPY.WRITESECTOR [LAMBDA (FLOPPYIOCB DISKADDRESS PAGE NOERROR) (* kbr%: " 7-Aug-85 20:42") (\FLOPPY.TRANSFER FLOPPYIOCB 'WRITE DISKADDRESS PAGE NOERROR]) (\FLOPPY.FORMATTRACKS [LAMBDA (FLOPPYIOCB DISKADDRESS KOUNT NOERROR) (* ; "Edited 11-Jun-87 14:41 by jds") (PROG (ANSWER MESSAGE) (SETQ ANSWER (SELECTQ (MACHINETYPE) (DANDELION (UNINTERRUPTABLY (replace (FLOPPYIOCB COMMAND) of FLOPPYIOCB with C.FORMATTRACK) (replace (FLOPPYIOCB SUBCOMMAND) of FLOPPYIOCB with SC.NOP) (replace (FLOPPYIOCB DISKADDRESS) of FLOPPYIOCB with DISKADDRESS) (replace (FLOPPYIOCB BUFFER) of FLOPPYIOCB with NIL) (replace (FLOPPYIOCB SECTORCOUNT) of FLOPPYIOCB with KOUNT)) (\FLOPPY.RUN FLOPPYIOCB NOERROR)) ((DOVE DAYBREAK) (\DOVEFLOPPY.SETCONTEXT (fetch (FLOPPYIOCB $DENSITY) of FLOPPYIOCB) (fetch (FLOPPYIOCB $ENCODEDSECTORLENGTH) of FLOPPYIOCB )) (for I from 0 to (SUB1 KOUNT) do (SETQ MESSAGE (\DOVEFLOPPY.XFERDISK (IPLUS (fetch (DISKADDRESS CYLINDER) of DISKADDRESS) I) (fetch (DISKADDRESS HEAD) of DISKADDRESS ) (fetch (DISKADDRESS SECTOR) of DISKADDRESS) \FLOPPY.SCRATCH.BUFFER 'FORMATTRACK)) (COND ((EQ MESSAGE 'OK) T) ((NOT NOERROR) (\FLOPPY.BREAK MESSAGE)) (T (RETURN NIL))) finally (RETURN T))) NIL)) (RETURN ANSWER]) (\FLOPPY.DISKCHANGECLEAR [LAMBDA (NOERROR) (* kbr%: "25-Apr-85 14:52") (GLOBALRESOURCE \FLOPPY.SCRATCH.FLOPPYIOCB (\FLOPPY.COMMAND \FLOPPY.SCRATCH.FLOPPYIOCB C.ESCAPE SC.DISKCHANGECLEAR NOERROR]) (\FLOPPY.MOUNTEDP [LAMBDA (NOERROR) (* ; "Edited 11-Jun-87 16:57 by jds") (* ;;  "Floppy drive contains floppy, door is shut, door stable since last \FLOPPY.INITIALIZE? *") (PROG (ANSWER) (* ;; "There is apparently no way to test these facts independently. Also, if DOOROPENED bit was set in the past & floppy is now mounted, this routine treats this as unmounted. Some recovery routine must do a \FLOPPY.INITIALIZE as one of its actions to clear this bit. *") (SETQ ANSWER (SELECTQ (MACHINETYPE) (DANDELION (UNINTERRUPTABLY (\FLOPPY.NOP T) (NOT (fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT )))) (DOVE (* ;  "MORE UGLY CRUFT TO GET AROUND DOVE DOOROPEN BITS NOT WORKING. *") (COND ((\DEVICE-OPEN-STREAMS \FLOPPYFDEV) (* ;  "If the user has streams open on {FLOPPY} then the user probably hasn't switched floppies. *") T) ((AND (NOT (STKPOS 'FLOPPY.FORMAT)) (EQ (WITH.MONITOR \FLOPPYLOCK (\DOVEFLOPPY.TRANSFER 20 0 1 \FLOPPY.SCRATCH.BUFFER 'READDATA)) 'TIMEOUT)) (* ;; "Notice that we obtain \FLOPPYLOCK before doing timeing. Since TIMEOUT can happen if floppy is not formatted properly, just say T if we're underneath FLOPPY.FORMAT. *") NIL) (T T))) NIL)) (COND ((OR NOERROR ANSWER) (RETURN ANSWER))) (\FLOPPY.BREAK "Door open(ed) or disk missing"]) (\FLOPPY.CAN.READP [LAMBDA (NOERROR) (* edited%: "23-Jul-84 15:33") (AND (\FLOPPY.EXISTSP NOERROR) (\FLOPPY.MOUNTEDP NOERROR]) (\FLOPPY.CAN.WRITEP [LAMBDA (NOERROR) (* edited%: "23-Jul-84 15:33") (AND (\FLOPPY.EXISTSP NOERROR) (\FLOPPY.MOUNTEDP NOERROR) (\FLOPPY.WRITEABLEP NOERROR]) (\FLOPPY.WRITEABLEP [LAMBDA (NOERROR) (* kbr%: " 7-Aug-85 20:17") (* Floppy is write protected *) (PROG (ANSWER) (* This routine assumes floppy  hardware exists. *) (SETQ ANSWER (SELECTQ (MACHINETYPE) (DANDELION (UNINTERRUPTABLY (\FLOPPY.NOP T) (NOT (OR (fetch (FLOPPYRESULT DOOROPENED) of \FLOPPYRESULT ) (fetch (FLOPPYRESULT WRITEPROTECT) of \FLOPPYRESULT))))) ((DOVE DAYBREAK) (NOT (\DOVEFLOPPY.WRITEPROTECTED))) NIL)) (COND ((OR NOERROR ANSWER) (RETURN ANSWER))) (\FLOPPY.BREAK "Write protected"]) (\FLOPPY.TWOSIDEDP [LAMBDA (NOERROR) (* kbr%: " 7-Aug-85 20:27") (* Floppy drive contains floppy,  door is shut, door stable since last  \FLOPPY.INITIALIZE? *) (PROG (ANSWER) (SETQ ANSWER (SELECTQ (MACHINETYPE) (DANDELION (UNINTERRUPTABLY (\FLOPPY.NOP T) (NOT (fetch (FLOPPYRESULT TWOSIDED) of \FLOPPYRESULT )))) ((DOVE DAYBREAK) T) NIL)) (COND ((OR NOERROR ANSWER) (RETURN ANSWER))) (\FLOPPY.BREAK "Not a two sided floppy"]) (\FLOPPY.DUMP [LAMBDA (DISKADDRESS MODE) (* kbr%: "22-Jul-84 22:34") (PROG (STRING PAGE) [SETQ PAGE (\FLOPPY.READSECTOR \FLOPPY.SCRATCH.FLOPPYIOCB DISKADDRESS (NCREATE 'VMEMPAGEP] (SETQ STRING (create STRINGP BASE _ PAGE LENGTH _ (fetch (FLOPPYIOCB $ENCODEDSECTORLENGTH) of \FLOPPYIOCB ))) (SELECTQ MODE (ASCII (SETQ STRING (ASCIITOASCII STRING))) (EBCDIC (SETQ STRING (EBCDICTOASCII STRING))) (* STRING ok the way it is.  *)) (RETURN STRING]) (\FLOPPY.DEBUG [LAMBDA NIL (* kbr%: " 7-Aug-85 19:36") (PROG NIL (CLOSEINSPECT) (SELECTQ (MACHINETYPE) (DANDELION (WINDOWPROP (INSPECT \FLOPPYIOCB 'FLOPPYIOCB (create POSITION XCOORD _ 20 YCOORD _ 70)) 'TITLE '\FLOPPYIOCB) (WINDOWPROP (INSPECT \FLOPPYRESULT 'FLOPPYRESULT (create POSITION XCOORD _ 290 YCOORD _ 70)) 'TITLE '\FLOPPYRESULT)) ((DOVE DAYBREAK) NIL) NIL]) ) (* ; "`COMMON' *") (RPAQ? \FLOPPYFDEV NIL) (RPAQ? \FLOPPYLOCK NIL) (RPAQ? \FLOPPY.SCRATCH.BUFFER NIL) (RPAQ? \FLOPPY.SCRATCH.BUFFER2 NIL) (RPAQ? \FLOPPY.SCRATCH.FLOPPYIOCB NIL) (RPAQ? \FLOPPY.IBMS128.FLOPPYIOCB NIL) (RPAQ? \FLOPPY.IBMD256.FLOPPYIOCB NIL) (RPAQ? \FLOPPY.IBMD512.FLOPPYIOCB NIL) (RPAQ? \FLOPPYIOCBADDR NIL) (RPAQ? \FLOPPYIOCB NIL) (RPAQ? \FLOPPYRESULT NIL) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\FLOPPY.SCRATCH.FLOPPYIOCB 'RESOURCES '(NEW (create FLOPPYIOCB] [PUTDEF '\FLOPPY.IBMS128.FLOPPYIOCB 'RESOURCES '(NEW (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMS128] [PUTDEF '\FLOPPY.IBMD256.FLOPPYIOCB 'RESOURCES '(NEW (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMD256] [PUTDEF '\FLOPPY.IBMD512.FLOPPYIOCB 'RESOURCES '(NEW (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMD512] [PUTDEF '\FLOPPY.SCRATCH.BUFFER 'RESOURCES '(NEW (\FLOPPY.BUFFER 4] [PUTDEF '\FLOPPY.SCRATCH.BUFFER2 'RESOURCES '(NEW (\FLOPPY.BUFFER 4] ) ) (/SETTOPVAL '\\FLOPPY.SCRATCH.FLOPPYIOCB.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FLOPPY.IBMS128.FLOPPYIOCB.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FLOPPY.IBMD256.FLOPPYIOCB.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FLOPPY.IBMD512.FLOPPYIOCB.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FLOPPY.SCRATCH.BUFFER.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FLOPPY.SCRATCH.BUFFER2.GLOBALRESOURCE NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS FLOPPYSTREAM ((PFALLOC (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (PLPAGE (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (CALLOC (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (FCBS (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)))) (RECORD FILEGENOBJ (NEXTFILEFN FILEINFOFN . GENFILESTATE)) (RECORD GENFILESTATE (ALLOCS DEVICENAME CURRENTALLOC)) ) ) (DEFINEQ (FLOPPY.RESTART [LAMBDA NIL (* ; "Edited 11-Jun-87 17:12 by jds") (* ;  "Initializes floppy code, setting globals and creating file devices. *") (SETQ \FLOPPYLOCK (CREATE.MONITORLOCK 'FLOPPY)) (WITH.MONITOR \FLOPPYLOCK [PROG NIL (SETQ \FLOPPY.SCRATCH.BUFFER (\FLOPPY.BUFFER 4)) (SETQ \FLOPPY.SCRATCH.BUFFER2 (\FLOPPY.BUFFER 4)) (COND (\FLOPPYFDEV (\FLOPPY.FLUSH))) (SETQ \PFLOPPYFDEV NIL) (SETQ \SFLOPPYFDEV NIL) (SETQ \HFLOPPYFDEV NIL) (SETQ \CFLOPPYFDEV NIL) (FLOPPY.MODE 'PILOT) (COND ((\FLOPPY.EXISTSP T) (\FLOPPY.SETUP.HARDWARE])]) (FLOPPY.MODE [LAMBDA (MODE) (* ; "Edited 11-Jun-87 17:12 by jds") (* ;  "Set floppy MODE to one of PILOT HUGEPILOT, or SYSOUT. Indicate current mode if MODE = NIL. *") (WITH.MONITOR \FLOPPYLOCK (PROG (OLDMODE FDEV) RETRY (SETQ OLDMODE (SELECT \FLOPPYFDEV (NIL NIL) (\PFLOPPYFDEV 'PILOT) (\HFLOPPYFDEV 'HUGEPILOT) (\SFLOPPYFDEV 'SYSOUT) (\CFLOPPYFDEV 'CPM) (PROGN (* ;  "Shouldn't happen, but a SHOULDNT here would kill FLOPPY for good. So ignore. *") NIL))) (SELECTQ MODE (PILOT (COND ((NULL \PFLOPPYFDEV) (\PFLOPPY.INIT))) (SETQ FDEV \PFLOPPYFDEV)) (HUGEPILOT (COND ((NULL \HFLOPPYFDEV) (\HFLOPPY.INIT))) (SETQ FDEV \HFLOPPYFDEV)) (SYSOUT (COND ((NULL \SFLOPPYFDEV) (\SFLOPPY.INIT))) (SETQ FDEV \SFLOPPYFDEV)) (CPM (COND ((NULL \CFLOPPYFDEV) (\CFLOPPY.INIT))) (SETQ FDEV \CFLOPPYFDEV)) (NIL (* ; "No change *") (SETQ FDEV \FLOPPYFDEV)) (PROGN (SETQ MODE (LISPERROR "ILLEGAL ARG" MODE)) (GO RETRY))) (COND ((AND \FLOPPYFDEV (NOT (EQ FDEV \FLOPPYFDEV))) (\FLOPPY.CLOSE))) [COND (MODE (UNINTERRUPTABLY (\DEFINEDEVICE 'FLOPPY FDEV) (SETQ \FLOPPYFDEV FDEV))] (RETURN OLDMODE)))]) (\FLOPPY.SETUP.HARDWARE [LAMBDA NIL (* ; "Edited 11-Jun-87 17:17 by jds") (PROG NIL (SELECTQ (MACHINETYPE) (DANDELION (* ; "DANDELION & KIKU drives. *") (* ;; "16 quad aligned words needed for FLOPPYIOCB in the first 64K. Cannibalize last part of \IOCBPAGE located at real address 256 *") (SETQ \FLOPPYIOCBADDR (IPLUS 256 (IDIFFERENCE 256 16))) (SETQ \FLOPPYIOCB (\ADDBASE \IOCBPAGE (IDIFFERENCE 256 16))) (SETQ \FLOPPYRESULT (\ADDBASE \FLOPPYIOCB 8)) (SETQ \FLOPPY.SCRATCH.FLOPPYIOCB (create FLOPPYIOCB)) (SETQ \FLOPPY.IBMS128.FLOPPYIOCB (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMS128)) (SETQ \FLOPPY.IBMD256.FLOPPYIOCB (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMD256)) (SETQ \FLOPPY.IBMD512.FLOPPYIOCB (\FLOPPY.SETUP.IOCB (create FLOPPYIOCB) IBMD512)) (SETQ \FLOPPY.CYLINDERS 77) (SETQ \FLOPPY.TRACKSPERCYLINDER 2) (SETQ \FLOPPY.SECTORSPERTRACK 15) (SETQ \HFLOPPY.MAXPAGES 2250)) (DOVE (* ;  "DAYBREAK B1 low density drives. *") (SETQ \FLOPPY.CYLINDERS 40) (SETQ \FLOPPY.TRACKSPERCYLINDER 2) (SETQ \FLOPPY.SECTORSPERTRACK 9) (SETQ \HFLOPPY.MAXPAGES 684)) (SHOULDNT)) (* ;  "PILOT FLOPPY data begins on cylinder 1 (after cylinder 0) and ends on the last cylinder. *") (SETQ \PFLOPPYFIRSTDATAPAGE (ADD1 (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK ))) (SETQ \PFLOPPYLASTDATAPAGE (ITIMES \FLOPPY.CYLINDERS \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK]) (\FLOPPY.EVENTFN [LAMBDA (FDEV EVENT) (* ; "Edited 20-Oct-87 12:12 by jds") (PROG NIL (COND ((NOT (\FLOPPY.EXISTSP T)) (RETURN))) (SELECTQ EVENT ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\FLOPPY.CLOSE) (\FLOPPY.SETUP.HARDWARE) (\FLOPPY.INITIALIZE) (\PAGED.REVALIDATEFILELST FDEV)) (AFTERDOSAVEVM (\PAGED.REVALIDATEFILELST FDEV)) NIL]) (\FLOPPY.HOSTNAMEP [LAMBDA (NAME FDEV) (* gbn " 2-Jun-85 16:18") (* NAME equals name of floppy FDEV?  *) (AND (type? FDEV FDEV) (EQ NAME (fetch (FDEV DEVICENAME) of FDEV]) (\FLOPPY.ADDDEVICENAME [LAMBDA (FILENAME) (* edited%: "23-Jul-84 15:33") (* Pack floppy FDEV name onto  FILENAME. *) (PACK* '{ (fetch (FDEV DEVICENAME) of \FLOPPYFDEV) '} FILENAME]) (\FLOPPY.ASSUREFILENAME [LAMBDA (FILE NOERROR) (* ; "Edited 12-Nov-87 20:27 by sye") (* Coerce FILE to a litatom  FILENAME. *) (PROG (UNAME FILENAME) RETRY (COND ((type? STREAM FILE) (SETQ FILENAME (fetch (STREAM FULLFILENAME) of FILE))) (T (SETQ FILENAME FILE))) (SETQ UNAME (NLSETQ (UNPACKFILENAME.STRING FILENAME))) (COND ((OR (NULL UNAME) (NULL (CAR UNAME))) [COND (NOERROR (RETURN NIL)) (T (SETQ FILE (LISPERROR "BAD FILE NAME" FILE] (GO RETRY))) (SETQ UNAME (CAR UNAME)) (LISTPUT UNAME 'HOST NIL) (SETQ FILENAME (NLSETQ (PACKFILENAME UNAME))) (COND ([OR (NULL FILENAME) (EQ (CAR FILENAME) (CONSTANT (MKATOM ""] [COND (NOERROR (RETURN NIL)) (T (SETQ FILE (LISPERROR "BAD FILE NAME" FILE] (GO RETRY))) (SETQ FILENAME (CAR FILENAME)) (RETURN FILENAME]) (\FLOPPY.OTHERINFO [LAMBDA (OTHERINFO) (* edited%: "23-Jul-84 15:33") (* Convert OPENFILE OTHERINFO into  alist. *) (for BUCKET in OTHERINFO collect (COND ((LISTP BUCKET) (COND ((LISTP (CDR BUCKET)) (CONS (CAR BUCKET) (CADR BUCKET))) (T BUCKET))) (T (CONS BUCKET T]) (\FLOPPY.LEXASSOC [LAMBDA (KEY ALIST) (* edited%: "23-Jul-84 15:33") (* ASSOC for sorted alist.  *) (for BUCKET in ALIST while (ALPHORDER KEY (CAR BUCKET)) when (EQ KEY (CAR BUCKET)) do (RETURN BUCKET]) (\FLOPPY.LEXPUTASSOC [LAMBDA (KEY VAL ALIST) (* ; "Edited 12-Nov-87 20:25 by sye") (* PUTASSOC for sorted alist.  Returns alist. *) (PROG (BUCKET) (SETQ BUCKET (CAR ALIST)) (COND ((NULL ALIST) (SETQ ALIST (LIST (CONS KEY VAL))) (RETURN ALIST)) ((EQUAL KEY (CAR BUCKET)) (RPLACD BUCKET VAL) (RETURN ALIST)) ((ALPHORDER KEY (CAR BUCKET)) (push ALIST (CONS KEY VAL)) (RETURN ALIST))) [for (TAIL _ ALIST) by (CDR TAIL) as BUCKET in (CDR ALIST) while (CDR TAIL) do (COND ((EQUAL KEY (CAR BUCKET)) (RPLACD BUCKET VAL) (RETURN)) ((ALPHORDER KEY (CAR BUCKET)) (RPLACD TAIL (CONS (CONS KEY VAL) (CDR TAIL))) (RETURN))) finally (RPLACD TAIL (LIST (CONS KEY VAL] (RETURN ALIST]) (\FLOPPY.LEXREMOVEASSOC [LAMBDA (KEY ALIST) (* ; "Edited 12-Nov-87 20:25 by sye") (* Opposite of PUTASSOC for sorted  alist. Returns alist.  *) (PROG (BUCKET) (SETQ BUCKET (CAR ALIST)) [COND ((NULL ALIST) (RETURN ALIST)) ((EQUAL KEY (CAR BUCKET)) (RETURN (CDR ALIST] [for (TAIL _ ALIST) by (CDR TAIL) as BUCKET in (CDR ALIST) while (CDR TAIL) do (COND ((EQUAL KEY (CAR BUCKET)) (RPLACD TAIL (CDDR TAIL)) (RETURN)) ((ALPHORDER KEY (CAR BUCKET)) (RETURN] (RETURN ALIST]) (\FLOPPY.CACHED.READ [LAMBDA (NOERROR FORCE-DECACHE) (* ; "Edited 16-Oct-87 14:58 by jds") (* ;; "Cause or make sure IOP is initialized, floppy is mounted, and (correct) directory is cached for coming read operations *") (PROG (ANSWER) (COND ((OR FORCE-DECACHE (NOT (\FLOPPY.CAN.READP T))) (* ;  "Any cached info is no longer guaranteed to be correct *") (\FLOPPY.CLOSE))) (SETQ ANSWER (AND (\FLOPPY.UNCACHED.READ NOERROR) (\FLOPPY.OPEN NOERROR))) (RETURN ANSWER]) (\FLOPPY.CACHED.WRITE [LAMBDA (NOERROR FORCE-DECACHE) (* ; "Edited 16-Oct-87 14:59 by jds") (* ;; "Cause or make sure IOP is initialized, floppy is mounted, and (correct) directory is cached for coming write operations *") (PROG (ANSWER) (* ;; "In the following COND, we are only verifying that any existing cached info is still correct. Therefore we do not need to use \FLOPPY.CAN.WRITEP here. Write protection will be handled by \FLOPPY.UNCACHED.WRITE below. *") (COND ((OR FORCE-DECACHE (NOT (\FLOPPY.CAN.READP T))) (* ;  "Any cached info is no longer guaranteed to be correct *") (\FLOPPY.CLOSE))) (SETQ ANSWER (AND (\FLOPPY.UNCACHED.WRITE NOERROR) (\FLOPPY.OPEN NOERROR))) (RETURN ANSWER]) (\FLOPPY.OPEN [LAMBDA (NOERROR) (* ; "Edited 4-Sep-87 19:40 by amd") (SELECT \FLOPPYFDEV ((\PFLOPPYFDEV \HFLOPPYFDEV \SFLOPPYFDEV) (\PFLOPPY.OPEN NOERROR)) (\CFLOPPYFDEV (* "Obsolete" (\CFLOPPY.OPEN NOERROR)) ) (SHOULDNT]) (\FLOPPY.CLOSE [LAMBDA NIL (* ; "Edited 11-Jun-87 16:58 by jds") (* ;; "Forcibly close floppy. I.E., mark the floppy as unavailable.") (PROG NIL (* ;  "TBW: This function will go away when a wrong floppy FDEV is implemented. *") (SELECT \FLOPPYFDEV (\PFLOPPYFDEV (replace (PFINFO OPEN) of \PFLOPPYINFO with NIL)) (\HFLOPPYFDEV (replace (PFINFO OPEN) of \HFLOPPYINFO with NIL) (replace (PFINFO OPEN) of \PFLOPPYINFO with NIL)) (\SFLOPPYFDEV (replace (PFINFO OPEN) of \SFLOPPYINFO with NIL) (replace (PFINFO OPEN) of \PFLOPPYINFO with NIL)) (\CFLOPPYFDEV (replace (CINFO OPEN) of \CFLOPPYINFO with NIL)) NIL) (\FLOPPY.FLUSH]) (\FLOPPY.FLUSH [LAMBDA NIL (* hdj "30-Sep-86 15:29") (* ; "Forcibly flush streams. *") (PROG NIL (* ;  "TBW: This function will go away when a wrong floppy FDEV is implemented. *") (COND ((FMEMB (FLOPPY.MODE) '(SYSOUT HUGEPILOT)) (RETURN))) (for STREAM in (\DEVICE-OPEN-STREAMS \FLOPPYFDEV) do (COND ([AND \DOVEFLOPPY.TRACEFLG (NOT (STKPOS 'FLOPPY.FORMAT] (STOPTEST) (BREAK1 NIL T))) (FDEVOP 'UNREGISTERFILE \FLOPPYFDEV \FLOPPYFDEV STREAM) (replace (STREAM STRMBINFN) of STREAM with '\STREAM.NOT.OPEN) (replace (STREAM STRMBOUTFN) of STREAM with '\STREAM.NOT.OPEN) (replace (STREAM ACCESS) of STREAM with NIL]) (\FLOPPY.UNCACHED.READ [LAMBDA (NOERROR) (* kbr%: "19-Jul-85 19:29") (* Initialize IOP, then verify can  read. Return T or NIL.  *) (PROG NIL (COND ((NOT (\FLOPPY.EXISTSP NOERROR)) (* Failed *) (RETURN NIL))) (COND ((NOT (\FLOPPY.CAN.READP T)) (* DOOROPENED bit on, so must  reinitialize IOP & recalibrate *) (\FLOPPY.INITIALIZE NOERROR) (COND ((NOT (\FLOPPY.CAN.READP NOERROR)) (* Failed *) (RETURN NIL))) (\FLOPPY.RECALIBRATE NOERROR))) (* Succeeded *) (RETURN T]) (\FLOPPY.UNCACHED.WRITE [LAMBDA (NOERROR) (* kbr%: " 5-Oct-85 23:52") (* Initialize IOP, then verify can  write. Return T or NIL.  *) (PROG NIL (COND ((NOT (\FLOPPY.EXISTSP NOERROR)) (* Failed *) (RETURN NIL))) (COND ((NOT (\FLOPPY.CAN.WRITEP T)) (* DOOROPENED bit on, so must  reinitialize IOP & recalibrate *) (\FLOPPY.INITIALIZE NOERROR) (COND ((NOT (\FLOPPY.CAN.WRITEP NOERROR)) (* Failed *) (RETURN NIL))) (\FLOPPY.RECALIBRATE NOERROR))) (* Succeeded *) (RETURN T]) (\FLOPPY.EXISTSP [LAMBDA (NOERROR) (* ; "Edited 11-Jun-87 16:57 by jds") (* ;; "Floppy drive hardware exists?") (PROG NIL (COND ((FMEMB (MACHINETYPE) '(DANDELION DOVE)) (RETURN T)) ((NOT NOERROR) (\FLOPPY.BREAK "No floppy drive on this machine"]) (\FLOPPY.BREAK [LAMBDA (MESSAGE) (* ; "Edited 28-Oct-87 14:53 by jds") (* ;;  "Cause a break for the floppy-disk user, giving MESSAGE, or some intelligible form of it.") (PROG NIL (\FLOPPY.MESSAGE MESSAGE T) (COND (\DOVEFLOPPY.TRACEFLG (STOPTEST))) (LISPERROR "HARD DISK ERROR" '{FLOPPY} T]) (\FLOPPY.MESSAGE [LAMBDA (MESSAGE STREAM) (* ; "Edited 28-Oct-87 14:53 by jds") (* ;; "Print the problem message for a floppy error.") (COND ((NULL STREAM) (SETQ STREAM PROMPTWINDOW))) (PROG NIL (FRESHLINE STREAM) (PRIN1 "Floppy: " STREAM) (SELECTQ MESSAGE (RECORDNOTFOUND (* ;  "Sector not found: Bad floppy, or unformatted floppy.") (PRIN1 "Damaged or unformatted disk in drive." STREAM)) (PRIN1 MESSAGE STREAM]) (\FLOPPY.BUFFER [LAMBDA (N) (* ; "Edited 11-Jun-87 17:11 by jds") (* ;; "Allocates N pages worth of buffer.") (\ALLOCBLOCK (ITIMES N CELLSPERPAGE) NIL NIL CELLSPERPAGE]) ) (* ; "`PILOT' *") (RPAQ? \PFLOPPYPSECTOR9 NIL) (RPAQ? \PFLOPPYPFILELIST NIL) (RPAQ? \PFLOPPYINFO NIL) (RPAQ? \PFLOPPYFDEV NIL) (/DECLAREDATATYPE 'PFALLOC '(POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG) '((PFALLOC 0 POINTER) (PFALLOC 2 FULLXPOINTER) (PFALLOC 4 POINTER) (PFALLOC 6 POINTER) (PFALLOC 8 POINTER) (PFALLOC 10 POINTER) (PFALLOC 12 POINTER) (PFALLOC 12 (FLAGBITS . 0)) (PFALLOC 12 (FLAGBITS . 16))) '14) (/DECLAREDATATYPE 'PFINFO '(POINTER POINTER POINTER POINTER POINTER) '((PFINFO 0 POINTER) (PFINFO 2 POINTER) (PFINFO 4 POINTER) (PFINFO 6 POINTER) (PFINFO 8 POINTER)) '10) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE PFALLOC ( (* ;; "Pilot file allocation info?? ") FILENAME (* ; "Name of the file") (PREV FULLXPOINTER) (* ; "? previous file alloc info ?") NEXT (* ; "? next file alloc info ?") START (* ; "? start of file ?") PMPAGE (* ; "? marker page for this file ?") PLPAGE PFLE (WRITEFLG FLAG) (* ; "? File has been written to ?") (DELETEFLG FLAG) (* ; "? File has been deleted ?") ) [ACCESSFNS ((LENGTH (fetch (PMPAGE NLENGTH) of (fetch (PFALLOC PMPAGE) of DATUM))) (END (IPLUS (fetch (PFALLOC START) of DATUM) (fetch (PFALLOC LENGTH) of DATUM) -1)) (FILETYPE (fetch (PMPAGE NFILETYPE) of (fetch (PFALLOC PMPAGE) of DATUM]) (DATATYPE PFINFO (OPEN PFILELIST PFALLOCS DIR PSECTOR9)) (ACCESSFNS PFLOPPYFDEV [(OPEN (fetch (PFINFO OPEN) of (fetch (FDEV DEVICEINFO) of DATUM)) (replace (PFINFO OPEN) of (fetch (FDEV DEVICEINFO) of DATUM) with NEWVALUE)) (PFILELIST (fetch (PFINFO PFILELIST) of (fetch (FDEV DEVICEINFO ) of DATUM)) (PROGN (replace (PFINFO PFILELIST) of (fetch (FDEV DEVICEINFO) of DATUM) with NEWVALUE) (SETQ \PFLOPPYPFILELIST NEWVALUE))) (PFALLOCS (fetch (PFINFO PFALLOCS) of (fetch (FDEV DEVICEINFO ) of DATUM)) (replace (PFINFO PFALLOCS) of (fetch (FDEV DEVICEINFO) of DATUM) with NEWVALUE)) (DIR (fetch (PFINFO DIR) of (fetch (FDEV DEVICEINFO) of DATUM)) (replace (PFINFO DIR) of (fetch (FDEV DEVICEINFO) of DATUM) with NEWVALUE) ) (PSECTOR9 (fetch (PFINFO PSECTOR9) of (fetch (FDEV DEVICEINFO ) of DATUM)) (PROGN (replace (PFINFO PSECTOR9) of (fetch (FDEV DEVICEINFO) of DATUM) with NEWVALUE) (SETQ \PFLOPPYPSECTOR9 NEWVALUE]) ) (/DECLAREDATATYPE 'PFALLOC '(POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG) '((PFALLOC 0 POINTER) (PFALLOC 2 FULLXPOINTER) (PFALLOC 4 POINTER) (PFALLOC 6 POINTER) (PFALLOC 8 POINTER) (PFALLOC 10 POINTER) (PFALLOC 12 POINTER) (PFALLOC 12 (FLAGBITS . 0)) (PFALLOC 12 (FLAGBITS . 16))) '14) (/DECLAREDATATYPE 'PFINFO '(POINTER POINTER POINTER POINTER POINTER) '((PFINFO 0 POINTER) (PFINFO 2 POINTER) (PFINFO 4 POINTER) (PFINFO 6 POINTER) (PFINFO 8 POINTER)) '10) ) (DEFINEQ (\PFLOPPY.INIT [LAMBDA NIL (* ; "Edited 27-Oct-87 13:32 by jds") (PROG NIL (SETQ \PFLOPPYINFO (create PFINFO)) (SETQ \PFLOPPYFDEV (create FDEV DEVICENAME _ 'FLOPPY NODIRECTORIES _ T CLOSEFILE _ (FUNCTION \PFLOPPY.CLOSEFILE) DELETEFILE _ (FUNCTION \PFLOPPY.DELETEFILE) DIRECTORYNAMEP _ (FUNCTION TRUE) EVENTFN _ (FUNCTION \FLOPPY.EVENTFN) GENERATEFILES _ (FUNCTION \PFLOPPY.GENERATEFILES) GETFILEINFO _ (FUNCTION \PFLOPPY.GETFILEINFO) GETFILENAME _ (FUNCTION \PFLOPPY.GETFILENAME) HOSTNAMEP _ (FUNCTION \FLOPPY.HOSTNAMEP) OPENFILE _ (FUNCTION \PFLOPPY.OPENFILE) READPAGES _ (FUNCTION \PFLOPPY.READPAGES) REOPENFILE _ (FUNCTION \PFLOPPY.OPENFILE) SETFILEINFO _ (FUNCTION \PFLOPPY.SETFILEINFO) TRUNCATEFILE _ (FUNCTION \PFLOPPY.TRUNCATEFILE) WRITEPAGES _ (FUNCTION \PFLOPPY.WRITEPAGES) DEVICEINFO _ \PFLOPPYINFO RENAMEFILE _ (FUNCTION \PFLOPPY.RENAMEFILE) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM))) (\MAKE.PMAP.DEVICE \PFLOPPYFDEV]) (\PFLOPPY.OPEN [LAMBDA (NOERROR) (* ; "Edited 12-Aug-88 17:05 by rmk:") (* ;; "Assume floppy mounted. Cache directory info for floppy if not already cached. Return T or NIL. ") (PROG NIL (COND ((fetch (PFLOPPYFDEV OPEN) of \FLOPPYFDEV) (* ; "Already open *") (RETURN T))) (replace (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV with NIL) (replace (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV with NIL) (replace (PFLOPPYFDEV DIR) of \FLOPPYFDEV with NIL) (replace (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV with NIL) (RETURN (COND ((\PFLOPPY.OPEN.PSECTOR9 NOERROR) (\PFLOPPY.OPEN.PFILELIST) (replace (PFLOPPYFDEV OPEN) of \FLOPPYFDEV with T) T]) (\PFLOPPY.OPEN.PSECTOR9 [LAMBDA (NOERROR) (* ; "Edited 12-Aug-88 17:07 by rmk:") (PROG (PSECTOR9) RETRY (SETQ PSECTOR9 (\PFLOPPY.GET.PSECTOR9)) (COND (PSECTOR9 (replace (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV with PSECTOR9) (RETURN T)) (NOERROR (RETURN NIL)) (T (\FLOPPY.BREAK "Not a pilot floppy") (GO RETRY]) (\PFLOPPY.GET.PSECTOR9 [LAMBDA NIL (* edited%: "23-Jul-84 15:34") (* Gets PSECTOR9 of a Pilot floppy.  Returns NIL if not a Pilot floppy.  *) (PROG (PSECTOR9) (* Read PSECTOR9. *) (GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (SETQ PSECTOR9 (\FLOPPY.READSECTOR \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 9) (NCREATE 'PSECTOR9) T))) (* Return answer. *) (COND ((AND PSECTOR9 (fetch (PSECTOR9 INTACT) of PSECTOR9)) (RETURN PSECTOR9)) (T (RETURN NIL]) (\PFLOPPY.OPEN.PFILELIST [LAMBDA NIL (* ; "Edited 27-Oct-87 13:24 by jds") (PROG (PSECTOR9 PFILELIST FILENAME PMPAGE PLPAGE PFALLOC PFALLOCS) RETRY (SETQ PSECTOR9 (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV)) (SETQ PFILELIST (\PFLOPPY.CREATE.PFILELIST (fetch (PSECTOR9 PFILELISTLENGTH) of PSECTOR9))) (replace (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV with PFILELIST) (replace (PSECTOR9 NEXTUNUSEDFILEID) of PSECTOR9 with 1) [for (START _ (ADD1 \PFLOPPYFIRSTDATAPAGE)) by (IPLUS START (fetch (PMPAGE NLENGTH) of PMPAGE) 1) do (SETQ PMPAGE (NCREATE 'PMPAGE)) (\PFLOPPY.READPAGENO (SUB1 START) PMPAGE) (COND ((NOT (fetch (PMPAGE INTACT) of PMPAGE)) (\PFLOPPY.DAMAGED) (SETQ PFALLOCS NIL) (GO RETRY))) [COND ((EQ (fetch (PMPAGE NFILETYPE) of PMPAGE) FILETYPE.FILE) (SETQ PLPAGE (NCREATE 'PLPAGE)) (\PFLOPPY.READPAGENO START PLPAGE) (COND ((NOT (fetch (PLPAGE INTACT) of PLPAGE)) (\PFLOPPY.DAMAGED) (SETQ PFALLOCS NIL) (GO RETRY))) (SETQ FILENAME (fetch (PLPAGE $NAME) of PLPAGE))) (T (SETQ PLPAGE NIL) (SETQ FILENAME (LIST (fetch (PMPAGE $NFILETYPE) of PMPAGE] (SETQ PFALLOC (create PFALLOC FILENAME _ FILENAME START _ START PMPAGE _ PMPAGE PLPAGE _ PLPAGE)) (COND ((NOT (EQ (fetch (PMPAGE NFILETYPE) of PMPAGE) FILETYPE.FREE)) (\PFLOPPY.ADD.TO.PFILELIST PFALLOC))) (push PFALLOCS PFALLOC) (COND ((IEQP START (ADD1 \PFLOPPYLASTDATAPAGE)) (RETURN] (SETQ PFALLOCS (DREVERSE PFALLOCS)) (for PREV in PFALLOCS as NEXT in (CDR PFALLOCS) while NEXT do (replace (PFALLOC NEXT) of PREV with NEXT) (replace (PFALLOC PREV) of NEXT with PREV)) (replace (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV with PFALLOCS) (* ;; "We create the directory last because PACKFILENAME is brittle and it is nice to have the other info already filled in if you have to debug. *") (for PFALLOC in PFALLOCS when (EQ (fetch (PFALLOC FILETYPE) of PFALLOC) FILETYPE.FILE) do (\PFLOPPY.DIR.PUT (fetch (PFALLOC FILENAME) of PFALLOC) 'OLD PFALLOC]) (\PFLOPPY.DAMAGED [LAMBDA NIL (* kbr%: " 2-Sep-85 16:37") (* Tell user floppy needs scavenging  *) (PROG NIL (\FLOPPY.BREAK "Damaged floppy. Needs scavenging."]) (\PFLOPPY.OPENFILE [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 10-May-88 14:30 by jds") (* ;;; "Open a Pilot-floppy file. If OLDSTREAM is provided, we're opening a continuation floppy for a large file.") (* ;; "if file is open in conflicting way, barf") (COND ((AND (NOT OLDSTREAM) (\FILE-CONFLICT (\RECOGNIZE-HACK FILE RECOG FDEV) ACCESS FDEV)) (* ;; "If there is a conflicting stream open on this file -- and we're not setting up a continuation floppy -- then return NIL.") NIL) ((\SFLOPPY.HACK FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM)) (T (* ;; "Either there is no conflicting stream open on this file, or this is a continuation floppy for a big file. Either way, create a stream and fill things in. ") (* ;; "") (PROG (STREAM WAIT PFALLOC FULLFILENAME) (SETQ OTHERINFO (\FLOPPY.OTHERINFO OTHERINFO)) RETRY (COND ((AND (NOT OLDSTREAM) (\FILE-CONFLICT (\RECOGNIZE-HACK FILE RECOG FDEV) ACCESS FDEV)) (* ;; "If there is a conflicting stream open on this file -- and we're not setting up a continuation floppy -- then return NIL.") NIL)) (* ;; "Get STREAM *") (COND ([NULL (NLSETQ (SELECTQ ACCESS (INPUT (\FLOPPY.CACHED.READ NIL (NULL (FETCH (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV )))) (\FLOPPY.CACHED.WRITE NIL (NULL (FETCH (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV] (LISPERROR "FILE WON'T OPEN" FILE) (GO RETRY))) (COND ((NOT (type? STREAM FILE)) (SETQ STREAM (\PFLOPPY.OPENFILE1 FILE RECOG OTHERINFO))) (T (SETQ STREAM FILE))) (COND ((NULL STREAM) (* ;  "FILE NOT FOUND error generated in \OPENFILE when we return NIL. *") (RETURN NIL))) (* ; "Establish ACCESS rights. *") (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) [COND ((NOT (EQ ACCESS 'INPUT)) (* ;; "WRITEFLG indicates whether FILE is currently being written. IPMPAGEossible for more than one stream to point to a file that is being written. *") (SETQ WAIT (CDR (ASSOC 'WAIT OTHERINFO))) (COND (WAIT (while (\PFLOPPY.STREAMS.AGAINST STREAM) do (BLOCK)) (replace (PFALLOC WRITEFLG) of PFALLOC with T)) ((fetch (PFALLOC WRITEFLG) of PFALLOC) (SETQ FULLFILENAME (fetch (STREAM FULLFILENAME) of STREAM)) (SETQ FILE (LISPERROR "FILE WON'T OPEN" FULLFILENAME T)) (GO RETRY))) (* ;  "Use OTHERINFO to establish correct CREATIONDATE etc. *") (for BUCKET in OTHERINFO do (\PFLOPPY.SETFILEINFO STREAM (CAR BUCKET) (CDR BUCKET] (COND ((EQ ACCESS 'OUTPUT) (* ;  "ACCESS = OUTPUT always starts ePMPAGEty. *") (replace (STREAM EPAGE) of STREAM with 0) (replace (STREAM EOFFSET) of STREAM with 0))) (RETURN STREAM]) (\PFLOPPY.OPENFILE1 [LAMBDA (FILE RECOG OTHERINFO) (* ; "Edited 27-Oct-87 13:33 by jds") (WITH.MONITOR \FLOPPYLOCK (PROG (FILENAME EXTENSION PFALLOC PLPAGE IDATE STREAM) RETRY (* ;  "Case where old FILE is being opened for output or appending to be written *") (SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILE)) (SETQ PFALLOC (\PFLOPPY.DIR.GET FILENAME RECOG)) (SETQ STREAM (SELECTQ RECOG ((EXACT OLD/NEW) (COND ((NULL PFALLOC) (\PFLOPPY.OPENNEWFILE FILENAME RECOG OTHERINFO)) (T (\PFLOPPY.OPENOLDFILE PFALLOC)))) (NEW (COND ((NULL PFALLOC) (\PFLOPPY.OPENNEWFILE FILENAME RECOG OTHERINFO)))) ((OLD OLDEST) (\PFLOPPY.OPENOLDFILE PFALLOC)) (SHOULDNT))) (COND ((NULL STREAM) (SELECTQ RECOG ((NEW OLD/NEW) (SETQ FILENAME (LISPERROR "FILE WON'T OPEN" FILENAME T))) (PROGN (* ;  "'FILE NOT FOUND' error is generated in \OPENFILE by our returning NIL *") (RETURN NIL))) (GO RETRY))) (RETURN STREAM)))]) (\PFLOPPY.OPENOLDFILE [LAMBDA (PFALLOC) (* edited%: "23-Jul-84 15:34") (PROG (PLPAGE STREAM) (COND ((NULL PFALLOC) (* Error in calling function.  *) (RETURN NIL))) (SETQ PLPAGE (fetch (PFALLOC PLPAGE) of PFALLOC)) (SETQ STREAM (create STREAM DEVICE _ \FLOPPYFDEV FULLFILENAME _ (\FLOPPY.ADDDEVICENAME (fetch (PFALLOC FILENAME) of PFALLOC)) EPAGE _ (IQUOTIENT (fetch (PLPAGE LENGTH) of PLPAGE) 512) EOFFSET _ (IREMAINDER (fetch (PLPAGE LENGTH) of PLPAGE) 512))) (replace (FLOPPYSTREAM PFALLOC) of STREAM with PFALLOC) (replace (FLOPPYSTREAM PLPAGE) of STREAM with PLPAGE) (RETURN STREAM]) (\PFLOPPY.OPENNEWFILE [LAMBDA (FILENAME RECOG OTHERINFO) (* kbr%: "31-Dec-85 10:26") (PROG (LENGTH PFALLOC PLPAGE IDATE STREAM) (SETQ LENGTH (CDR (ASSOC 'LENGTH OTHERINFO))) [COND (LENGTH (SETQ LENGTH (ADD1 (IQUOTIENT (IPLUS LENGTH 511) 512] (SETQ PFALLOC (\PFLOPPY.ALLOCATE LENGTH)) (\PFLOPPY.DIR.PUT FILENAME RECOG PFALLOC) (* ICREATIONDATE defaults to  IWRITEDATE. TBW%: Should put in  check for length of FILENAME.  *) (SETQ IDATE (IDATE)) [SETQ PLPAGE (create PLPAGE ICREATIONDATE _ IDATE IWRITEDATE _ IDATE TYPE _ (CDR (ASSOC 'TYPE OTHERINFO] (replace (PLPAGE $NAME) of PLPAGE with (fetch (PFALLOC FILENAME) of PFALLOC)) (replace (PFALLOC PLPAGE) of PFALLOC with PLPAGE) (\PFLOPPY.ADD.TO.PFILELIST PFALLOC) (* File is empty *) (SETQ STREAM (create STREAM DEVICE _ \FLOPPYFDEV FULLFILENAME _ (\FLOPPY.ADDDEVICENAME (fetch (PFALLOC FILENAME) of PFALLOC)) EPAGE _ 0 EOFFSET _ 0)) (replace (FLOPPYSTREAM PFALLOC) of STREAM with PFALLOC) (replace (FLOPPYSTREAM PLPAGE) of STREAM with (fetch (PFALLOC PLPAGE) of PFALLOC)) (RETURN STREAM]) (\PFLOPPY.ASSURESTREAM [LAMBDA (FILE) (* edited%: "23-Jul-84 15:34") (PROG (STREAM) RETRY (COND ((type? STREAM FILE) (RETURN FILE))) (SETQ STREAM (\PFLOPPY.OPENFILE1 FILE 'OLD)) (COND ((NULL STREAM) (SETQ FILE (LISPERROR "FILE NOT FOUND" FILE)) (GO RETRY))) (RETURN STREAM]) (\PFLOPPY.GETFILEINFO [LAMBDA (FILE ATTRIBUTE FDEV) (* edited%: "23-Jul-84 15:34") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PLPAGE ANSWER) (\FLOPPY.CACHED.READ) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) [COND (STREAM (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (SETQ ANSWER (\PFLOPPY.GETFILEINFO1 PFALLOC ATTRIBUTE] (RETURN ANSWER)))]) (\PFLOPPY.GETFILEINFO1 [LAMBDA (PFALLOC ATTRIBUTE) (* kbr%: "25-Nov-84 13:02") (* Used by \PFLOPPY.GETFILEINFO &  \PFLOPPY.FILEINFOFN *) (PROG (PLPAGE ANSWER) (SETQ PLPAGE (fetch (PFALLOC PLPAGE) of PFALLOC)) (* Wizard incantations%: PAGELENGTH,  HUGEPAGESTART, HUGEPAGELENGTH,  HUGELENGTH *) (SETQ ANSWER (SELECTQ ATTRIBUTE (WRITEDATE (fetch (PLPAGE WRITEDATE) of PLPAGE)) (CREATIONDATE (fetch (PLPAGE CREATIONDATE) of PLPAGE)) (IWRITEDATE (fetch (PLPAGE IWRITEDATE) of PLPAGE)) (ICREATIONDATE (fetch (PLPAGE ICREATIONDATE) of PLPAGE)) (LENGTH (fetch (PLPAGE LENGTH) of PLPAGE)) (TYPE (fetch (PLPAGE TYPE) of PLPAGE)) (BYTESIZE 8) (MESATYPE (fetch (PLPAGE MESATYPE) of PLPAGE)) (SIZE (fetch (PLPAGE PAGELENGTH) of PLPAGE)) (HUGEPAGESTART (fetch (PLPAGE HUGEPAGESTART) of PLPAGE)) (HUGEPAGELENGTH (fetch (PLPAGE HUGEPAGELENGTH) of PLPAGE)) (HUGELENGTH (fetch (PLPAGE HUGELENGTH) of PLPAGE)) NIL)) (RETURN ANSWER]) (\PFLOPPY.SETFILEINFO [LAMBDA (FILE ATTRIBUTE VALUE) (* ; "Edited 27-Oct-87 13:35 by jds") (* ;; "SETFILEINFO for the floppy device") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PLPAGE SUCCESSFUL) (\FLOPPY.CACHED.WRITE) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) [COND (STREAM (SETQ PLPAGE (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (SETQ SUCCESSFUL T) (SELECTQ ATTRIBUTE (WRITEDATE (replace (PLPAGE WRITEDATE) of PLPAGE with VALUE)) (CREATIONDATE (replace (PLPAGE CREATIONDATE) of PLPAGE with VALUE)) (IWRITEDATE (replace (PLPAGE IWRITEDATE) of PLPAGE with VALUE)) (ICREATIONDATE (replace (PLPAGE ICREATIONDATE) of PLPAGE with VALUE)) (LENGTH (* Treated specially by FILEIO.  *)) (TYPE (replace (PLPAGE TYPE) of PLPAGE with VALUE)) (EOL (replace (STREAM EOLCONVENTION) of STREAM with (SELECTQ VALUE (CR CR.EOLC) (CRLF CRLF.EOLC) (LF LF.EOLC) NIL))) (MESATYPE (replace (PLPAGE MESATYPE) of PLPAGE with VALUE)) (PAGELENGTH (replace (PLPAGE PAGELENGTH) of PLPAGE with VALUE)) (HUGEPAGESTART (replace (PLPAGE HUGEPAGESTART) of PLPAGE with VALUE)) (HUGEPAGELENGTH (replace (PLPAGE HUGEPAGELENGTH) of PLPAGE with VALUE)) (HUGELENGTH (replace (PLPAGE HUGELENGTH) of PLPAGE with VALUE)) (SETQ SUCCESSFUL NIL)) (COND ((OPENP STREAM) (* PLPAGE will be written out to  floppy when STREAM is closed.  *) ) (T (\PFLOPPY.WRITEPAGENO (fetch (PFALLOC START) of (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) PLPAGE] (RETURN SUCCESSFUL)))]) (\PFLOPPY.CLOSEFILE [LAMBDA (FILE) (* hdj "24-Sep-86 10:32") (WITH.MONITOR \FLOPPYLOCK (*) (PROG (STREAM FULLFILENAME) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (\CLEARMAP STREAM) (SETQ FULLFILENAME (\PFLOPPY.CLOSEFILE1 STREAM)) (RETURN FULLFILENAME)))]) (\PFLOPPY.CLOSEFILE1 [LAMBDA (STREAM) (* hdj " 8-May-86 15:36") (* The real CLOSEFILE.  *) (* Part of \PFLOPPY.CLOSEFILE needed  to close subportions of huge files.  *) (PROG (PFALLOC PMPAGE NEXT NPMPAGE FULLFILENAME) (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (SETQ FULLFILENAME (fetch (STREAM FULLFILENAME) of STREAM)) (COND ((EQ (fetch (STREAM ACCESS) of STREAM) 'INPUT) (RETURN FULLFILENAME))) (* Best place to fail is in trying to write PLPAGE.  TBW%: FILE WON'T CLOSE error message? *) (COND ((NULL (\PFLOPPY.WRITEPAGENO (fetch (PFALLOC START) of PFALLOC) (fetch (PFALLOC PLPAGE) of PFALLOC))) (RETURN NIL))) (* Ignore any errors now.  *) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ NEXT (fetch (PFALLOC NEXT) of PFALLOC)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (UNINTERRUPTABLY (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FILE) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FILE) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of PFALLOC)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T) (\PFLOPPY.SAVE.PFILELIST T) (\PFLOPPY.SAVE.PSECTOR9 T)) (* Release STREAM.  *) (replace (PFALLOC WRITEFLG) of PFALLOC with NIL) (RETURN FULLFILENAME]) (\PFLOPPY.DELETEFILE [LAMBDA (FILE FDEV) (* hdj "23-Jun-86 15:10") (WITH.MONITOR \FLOPPYLOCK (PROG (FILENAME PFALLOC PMPAGE NEXT NPMPAGE FULLFILENAME) (\PFLOPPY.OPEN) (SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILE T)) (COND ((NULL FILENAME) (* Bad filename. *) (* Returning NIL means unsuccessful.  *) (RETURN NIL))) (SETQ PFALLOC (\PFLOPPY.DIR.GET FILENAME 'OLDEST)) (COND ((NULL PFALLOC) (* File not found.  *) (* Returning NIL means unsuccessful.  *) (RETURN NIL))) (SETQ FULLFILENAME (\FLOPPY.ADDDEVICENAME (fetch (PFALLOC FILENAME) of PFALLOC))) (COND ((FDEVOP 'OPENP FDEV FILE NIL FDEV) (* file is open -  can't delete it *) (RETURN NIL)) (T (* Carry out deletion.  *) (\PFLOPPY.DIR.REMOVE PFALLOC) (\PFLOPPY.DEALLOCATE PFALLOC) (\PFLOPPY.DELETE.FROM.PFILELIST PFALLOC) (\PFLOPPY.SAVE.PFILELIST))) (RETURN FULLFILENAME)))]) (\PFLOPPY.GENERATEFILES [LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* hdj " 5-Jun-86 12:59") (WITH.MONITOR \FLOPPYLOCK (PROG (ALLOCS FILTER DESIREDVERSION GENFILESTATE PFALLOC VALIST VERSION FILEGENOBJ) (* No floppy gives empty directory so that {FLOPPY} can safely be on  DIRECTORIES search path. *) [COND ((EQ (MACHINETYPE) 'DOVE) (* Patch around DOVE IOP assembly language coded dooropen & diskchangeclear  status flags not working. *) (COND ((NOT (\DEVICE-OPEN-STREAMS \FLOPPYFDEV)) (* Don't have any open streams to DOVE floppy, so assume that user may have  switched floppies. *) (\FLOPPY.CLOSE] [COND ((AND (\FLOPPY.EXISTSP T) (\FLOPPY.CACHED.READ T)) (SETQ FILTER (DIRECTORY.MATCH.SETUP PATTERN)) (SETQ DESIREDVERSION (FILENAMEFIELD PATTERN 'VERSION)) (SETQ ALLOCS (for NBUCKET in (fetch (PFLOPPYFDEV DIR) of \FLOPPYFDEV ) join (for EBUCKET in (CDR NBUCKET) join (COND [(FIXP DESIREDVERSION) [SETQ PFALLOC (CDR (ASSOC DESIREDVERSION (CDR EBUCKET] (COND ((AND PFALLOC (DIRECTORY.MATCH FILTER (fetch (PFALLOC FILENAME) of PFALLOC))) (LIST PFALLOC] ((DIRECTORY.MATCH FILTER (CONCAT (CAR NBUCKET) "." (CAR EBUCKET))) (COND [(NULL DESIREDVERSION) (* Highest version only *) (SETQ VALIST (CDR EBUCKET)) (SETQ VERSION (\PFLOPPY.DIR.VERSION NIL 'OLD VALIST)) (SETQ PFALLOC (CDR (ASSOC VERSION VALIST))) (COND (PFALLOC (LIST PFALLOC] (T (for VBUCKET in (CDR EBUCKET) collect (CDR VBUCKET] [COND ((MEMB 'SORT OPTIONS) (SORT ALLOCS (FUNCTION (LAMBDA (X Y) (UALPHORDER (fetch (PFALLOC FILENAME) of X) (fetch (PFALLOC FILENAME) of Y] (SETQ GENFILESTATE (create GENFILESTATE ALLOCS _ ALLOCS DEVICENAME _ (fetch (FDEV DEVICENAME) of FDEV))) (SETQ FILEGENOBJ (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \PFLOPPY.NEXTFILEFN) FILEINFOFN _ (FUNCTION \PFLOPPY.FILEINFOFN) GENFILESTATE _ GENFILESTATE)) (RETURN FILEGENOBJ)))]) (\PFLOPPY.NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY SCRATCHLIST) (* edited%: "23-Jul-84 15:35") (* Generates next file from  GENFILESTATE or NIL if finished.  Used by \PFLOPPY.GENERATEFILES.  *) (PROG (ALLOCS FILENAME DEVICENAME ANSWER) (SETQ ALLOCS (fetch (GENFILESTATE ALLOCS) of GENFILESTATE)) (COND ((NULL ALLOCS) (RETURN))) (replace (GENFILESTATE CURRENTALLOC) of GENFILESTATE with (CAR ALLOCS)) (replace (GENFILESTATE ALLOCS) of GENFILESTATE with (CDR ALLOCS)) (SETQ FILENAME (fetch (PFALLOC FILENAME) of (CAR ALLOCS))) (SETQ DEVICENAME (fetch (GENFILESTATE DEVICENAME) of GENFILESTATE)) [COND (NAMEONLY (SETQ ANSWER FILENAME)) (T (SETQ ANSWER (CONCAT "{" (fetch (GENFILESTATE DEVICENAME) of GENFILESTATE) "}" FILENAME] (RETURN ANSWER]) (\PFLOPPY.FILEINFOFN [LAMBDA (GENFILESTATE ATTRIBUTE) (* edited%: "23-Jul-84 15:35") (* Get file info for current file in  GENFILESTATE. *) (\PFLOPPY.GETFILEINFO1 (fetch (GENFILESTATE CURRENTALLOC) of GENFILESTATE) ATTRIBUTE]) (\PFLOPPY.RENAMEFILE [LAMBDA (OLDDEVICE OLDFILE NEWDEVICE NEWFILE OLDRECOG NEWRECOG) (* hdj "23-Jun-86 16:51") (if (NEQ OLDDEVICE NEWDEVICE) then (\GENERIC.RENAMEFILE OLDDEVICE OLDFILE NEWDEVICE NEWFILE) else [COND ((NULL OLDRECOG) (SETQ OLDRECOG 'OLD] [COND ((NULL NEWRECOG) (SETQ NEWRECOG 'NEW] (WITH.MONITOR \FLOPPYLOCK (*) (PROG (OLDFILENAME NEWFILENAME PFALLOC PLPAGE FULLFILENAME) (\PFLOPPY.OPEN) (SETQ OLDFILENAME (\FLOPPY.ASSUREFILENAME OLDFILE)) (SETQ NEWFILENAME (\FLOPPY.ASSUREFILENAME NEWFILE)) (if (FDEVOP 'OPENP OLDDEVICE OLDFILENAME NIL OLDDEVICE) then (RETURN)) (SETQ PFALLOC (\PFLOPPY.DIR.GET OLDFILENAME OLDRECOG)) (COND ((OR (NULL PFALLOC) (FDEVOP 'OPENP OLDDEVICE OLDFILENAME 'OLD OLDDEVICE)) (* File not found or open *) (* Returning NIL means unsuccessful.  *) (RETURN NIL))) (\PFLOPPY.DIR.REMOVE PFALLOC) (* TBW%: If new file name too long.  *) (* Store NEWFILENAME on PFALLOC.  *) (\PFLOPPY.DIR.PUT NEWFILENAME NEWRECOG PFALLOC) (* Store NEWFILENAME on PLPAGE.  *) (SETQ PLPAGE (fetch (PFALLOC PLPAGE) of PFALLOC)) (replace (PLPAGE $NAME) of PLPAGE with (fetch (PFALLOC FILENAME ) of PFALLOC)) (* Write changes onto floppy.  *) (\PFLOPPY.WRITEPAGENO (fetch (PFALLOC START) of PFALLOC) PLPAGE) (* Return FULLFILENAME.  *) (SETQ FULLFILENAME (\FLOPPY.ADDDEVICENAME (fetch (PFALLOC FILENAME) of PFALLOC))) (RETURN FULLFILENAME)))]) (\PFLOPPY.STREAMS.AGAINST [LAMBDA (STREAM) (* hdj " 5-Jun-86 13:01") (* Return other open floppy streams  with same PFALLOC.  *) (for F in (\DEVICE-OPEN-STREAMS \FLOPPYFDEV) when (AND (EQ (fetch (FLOPPYSTREAM PFALLOC) of F) (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (NOT (EQ F STREAM))) collect F]) (\PFLOPPY.STREAMS.USING [LAMBDA (PFALLOC) (* hdj " 5-Jun-86 13:01") (* Return open floppy streams with  this PFALLOC. *) (for F in (\DEVICE-OPEN-STREAMS \FLOPPYFDEV) when (EQ (fetch (FLOPPYSTREAM PFALLOC) of F) PFALLOC) collect F]) (\PFLOPPY.READPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* edited%: "23-Jul-84 15:35") (PROG NIL (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\PFLOPPY.READPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\PFLOPPY.READPAGE [LAMBDA (FILE FIRSTPAGE# BUFFER) (* kbr%: "19-Jul-85 14:24") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PFALLOC PAGENO) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (SETQ PAGENO (IPLUS (fetch (PFALLOC START) of PFALLOC) 1 FIRSTPAGE#)) (COND ((IGREATERP FIRSTPAGE# (FOLDLO (SUB1 (\GETEOFPTR STREAM)) BYTESPERPAGE))(* Don't bother to do actual read.  *) (COND ((IGREATERP PAGENO (fetch (PFALLOC END) of PFALLOC)) (* Typically (because of lisp page buffering) we will try to write to PAGENO in  the very near future. It's easier for the user to confront FILE SYSTEM  RESOURCES EXCEEDED if we reallocate now instead of later.  *) (\PFLOPPY.EXTEND PFALLOC))) (RETURN))) (\PFLOPPY.READPAGENO PAGENO BUFFER))) (BLOCK]) (\PFLOPPY.READPAGENO [LAMBDA (PAGENO PAGE NOERROR) (* kbr%: " 7-Aug-85 18:48") (PROG (ANSWER) (* Read page. *) [GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (SETQ ANSWER (COND ((OR (ILESSP PAGENO 1) (IGREATERP PAGENO \PFLOPPYLASTDATAPAGE )) (\FLOPPY.SEVERE.ERROR "Illegal Read Page Number") NIL) (T (\FLOPPY.READSECTOR \FLOPPY.IBMD512.FLOPPYIOCB (  \PFLOPPY.PAGENOTODISKADDRESS PAGENO) PAGE NOERROR] (* Return ANSWER (PAGE or NIL) *) (RETURN ANSWER]) (\PFLOPPY.WRITEPAGENO [LAMBDA (PAGENO PAGE NOERROR) (* kbr%: " 7-Aug-85 18:48") (PROG (ANSWER) (* Write page. *) [GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (SETQ ANSWER (COND ((OR (ILESSP PAGENO 1) (IGREATERP PAGENO \PFLOPPYLASTDATAPAGE )) (\FLOPPY.SEVERE.ERROR "Illegal Write Page Number") NIL) (T (\FLOPPY.WRITESECTOR \FLOPPY.IBMD512.FLOPPYIOCB (  \PFLOPPY.PAGENOTODISKADDRESS PAGENO) PAGE NOERROR] (* Return ANSWER (PAGE or NIL) *) (RETURN ANSWER]) (\PFLOPPY.PAGENOTODISKADDRESS [LAMBDA (PAGENO) (* kbr%: " 7-Aug-85 17:07") (PROG (QUOTIENT CYLINDER HEAD SECTOR DISKADDRESS) (SETQ SECTOR (ADD1 (IREMAINDER (SUB1 PAGENO) \FLOPPY.SECTORSPERTRACK))) (SETQ QUOTIENT (IQUOTIENT (SUB1 PAGENO) \FLOPPY.SECTORSPERTRACK)) (SETQ HEAD (IREMAINDER QUOTIENT \FLOPPY.TRACKSPERCYLINDER)) (SETQ CYLINDER (IQUOTIENT QUOTIENT \FLOPPY.TRACKSPERCYLINDER)) (SETQ DISKADDRESS (create DISKADDRESS SECTOR _ SECTOR HEAD _ HEAD CYLINDER _ CYLINDER)) (RETURN DISKADDRESS]) (\PFLOPPY.DISKADDRESSTOPAGENO [LAMBDA (DISKADDRESS) (* kbr%: " 7-Aug-85 19:26") (PROG (PAGENO) [SETQ PAGENO (IPLUS (fetch (DISKADDRESS SECTOR) of DISKADDRESS) (ITIMES \FLOPPY.SECTORSPERTRACK (IPLUS (fetch (DISKADDRESS HEAD) of DISKADDRESS) (ITIMES \FLOPPY.TRACKSPERCYLINDER (fetch (DISKADDRESS CYLINDER) of DISKADDRESS] (RETURN PAGENO]) (\PFLOPPY.DIR.GET [LAMBDA (FILENAME RECOG) (* ; "Edited 13-Nov-87 13:22 by sye") (PROG (UNAME NALIST EALIST VALIST NAME EXTENSION VERSION PFALLOC) (SETQ FILENAME (\FLOPPY.ASSUREFILENAME FILENAME)) [COND [(NOT (EQ RECOG 'EXACT)) (SETQ UNAME (UNPACKFILENAME.STRING FILENAME)) [SETQ NAME (U-CASE (PACKFILENAME.STRING (LIST 'DIRECTORY (LISTGET UNAME 'DIRECTORY) 'NAME (LISTGET UNAME 'NAME] (SETQ EXTENSION (OR (U-CASE (LISTGET UNAME 'EXTENSION)) "")) [SETQ VERSION (MKATOM (U-CASE (LISTGET UNAME 'VERSION] (SETQ NALIST (fetch (PFLOPPYFDEV DIR) of \FLOPPYFDEV)) [SETQ EALIST (CDR (CL:ASSOC NAME NALIST :TEST #'EQUAL :KEY (FUNCTION MKSTRING] [SETQ VALIST (CDR (CL:ASSOC EXTENSION EALIST :TEST #'EQUAL :KEY (FUNCTION MKSTRING] (SETQ VERSION (\PFLOPPY.DIR.VERSION VERSION RECOG VALIST FILENAME)) (COND ((EQ RECOG 'NEW) (RETURN))) (SETQ PFALLOC (CDR (ASSOC VERSION VALIST] (T (SETQ PFALLOC (for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV ) thereis (EQ (fetch (PFALLOC FILENAME) of PFALLOC) FILENAME] (RETURN PFALLOC]) (\PFLOPPY.DIR.PUT [LAMBDA (FILENAME RECOG PFALLOC) (* ; "Edited 12-Nov-87 20:27 by sye") (PROG (UNAME NALIST EALIST VALIST NAME EXTENSION VERSION) [SETQ FILENAME (OR (\FLOPPY.ASSUREFILENAME FILENAME T) (GENSYM 'BADFILENAME] (SETQ UNAME (UNPACKFILENAME.STRING FILENAME)) [SETQ NAME (U-CASE (PACKFILENAME.STRING (LIST 'DIRECTORY (LISTGET UNAME 'DIRECTORY) 'NAME (LISTGET UNAME 'NAME] (SETQ EXTENSION (OR (U-CASE (LISTGET UNAME 'EXTENSION)) "")) [SETQ VERSION (MKATOM (U-CASE (LISTGET UNAME 'VERSION] (SETQ NALIST (fetch (PFLOPPYFDEV DIR) of \FLOPPYFDEV)) (SETQ EALIST (CDR (SASSOC NAME NALIST))) (SETQ VALIST (CDR (SASSOC EXTENSION EALIST))) (SETQ VERSION (\PFLOPPY.DIR.VERSION VERSION RECOG VALIST)) (LISTPUT UNAME 'VERSION VERSION) (LISTPUT UNAME 'HOST NIL) [SETQ FILENAME (COND ((EQ RECOG 'EXACT) (U-CASE FILENAME)) (T (PACKFILENAME UNAME] (replace (PFALLOC FILENAME) of PFALLOC with FILENAME) (SETQ VALIST (\FLOPPY.LEXPUTASSOC VERSION PFALLOC VALIST)) (SETQ EALIST (\FLOPPY.LEXPUTASSOC EXTENSION VALIST EALIST)) (SETQ NALIST (\FLOPPY.LEXPUTASSOC NAME EALIST NALIST)) (replace (PFLOPPYFDEV DIR) of \FLOPPYFDEV with NALIST) (RETURN PFALLOC]) (\PFLOPPY.DIR.REMOVE [LAMBDA (PFALLOC) (* ; "Edited 13-Nov-87 13:21 by sye") (PROG (FILENAME UNAME NALIST EALIST VALIST NAME EXTENSION VERSION) (SETQ FILENAME (fetch (PFALLOC FILENAME) of PFALLOC)) (SETQ UNAME (UNPACKFILENAME.STRING FILENAME)) [SETQ NAME (U-CASE (PACKFILENAME.STRING (LIST 'DIRECTORY (LISTGET UNAME 'DIRECTORY) 'NAME (LISTGET UNAME 'NAME] (SETQ EXTENSION (OR (U-CASE (LISTGET UNAME 'EXTENSION)) "")) [SETQ VERSION (MKATOM (U-CASE (LISTGET UNAME 'VERSION] (SETQ NALIST (fetch (PFLOPPYFDEV DIR) of \FLOPPYFDEV)) [SETQ EALIST (CDR (CL:ASSOC NAME NALIST :TEST (FUNCTION EQUAL) :KEY (FUNCTION MKSTRING] [SETQ VALIST (CDR (CL:ASSOC EXTENSION EALIST :TEST (FUNCTION EQUAL) :KEY (FUNCTION MKSTRING] (SETQ VERSION (\PFLOPPY.DIR.VERSION VERSION 'OLD VALIST)) (SETQ VALIST (\FLOPPY.LEXREMOVEASSOC VERSION VALIST)) [COND (VALIST (SETQ EALIST (\FLOPPY.LEXPUTASSOC EXTENSION VALIST EALIST)) (SETQ NALIST (\FLOPPY.LEXPUTASSOC NAME EALIST NALIST))) (T (SETQ EALIST (\FLOPPY.LEXREMOVEASSOC EXTENSION EALIST)) (COND (EALIST (SETQ NALIST (\FLOPPY.LEXPUTASSOC NAME EALIST NALIST))) (T (SETQ NALIST (\FLOPPY.LEXREMOVEASSOC NAME NALIST] (replace (PFLOPPYFDEV DIR) of \FLOPPYFDEV with NALIST) (RETURN PFALLOC]) (\PFLOPPY.DIR.VERSION [LAMBDA (VERSION RECOG VALIST FILENAME) (* kbr%: "13-Feb-85 15:39") (PROG (PFALLOC) (SETQ VALIST (for BUCKET in VALIST when (NUMBERP (CAR BUCKET)) collect BUCKET)) [COND ((EQ RECOG 'OLD/NEW) (COND (VALIST (SETQ RECOG 'OLD)) (T (SETQ RECOG 'NEW] [COND ((NULL VERSION) (SELECTQ RECOG (NEW [COND ((NULL VALIST) (SETQ VERSION 1)) (T (SETQ VERSION (CAAR (LAST VALIST))) (COND ((NUMBERP VERSION) (SETQ VERSION (ADD1 VERSION]) (OLD (SETQ VERSION (CAAR (LAST VALIST)))) (OLDEST (SETQ VERSION (CAAR VALIST))) (EXACT (* No version. *)) (SHOULDNT))) ((AND (EQ RECOG 'NEW) FILENAME) (SETQ PFALLOC (\PFLOPPY.DIR.GET FILENAME 'OLD)) (COND (PFALLOC (\PFLOPPY.DIR.REMOVE PFALLOC) (\PFLOPPY.DEALLOCATE PFALLOC) (\PFLOPPY.DELETE.FROM.PFILELIST PFALLOC) (\PFLOPPY.SAVE.PFILELIST] (RETURN VERSION]) (\PFLOPPY.GETFILENAME [LAMBDA (FILE RECOG FDEV) (* ; "Edited 11-Aug-88 09:37 by rmk:") (WITH.MONITOR \FLOPPYLOCK [PROG (UNAME NAME VERSION VALIST PFALLOC) [COND ((type? STREAM FILE) (RETURN (fetch (STREAM FULLFILENAME) of FILE] (COND ((NOT (AND (\FLOPPY.EXISTSP T) (\FLOPPY.CACHED.READ T))) (* ;  "NIL is returned if there is no floppy.") (RETURN NIL))) (OR (NLSETQ (SETQ UNAME (UNPACKFILENAME.STRING FILE))) (RETURN NIL)) (COND ((EQ RECOG 'EXACT) (RETURN FILE))) (* ;  "rmk: Not sure what EXACT is supposed to do") [SETQ NAME (PACKFILENAME.STRING 'DIRECTORY (LISTGET UNAME 'DIRECTORY) 'NAME (LISTGET UNAME 'NAME] (* ; "rmk: for efficiency, directory really should have its own alist indexing level and not be packed with the name. In fact, the best thing would be to have the floppy cache share structure and code with the CORE device") [SETQ VALIST (CDR (CL:ASSOC (OR (LISTGET UNAME 'EXTENSION) "") (CDR (CL:ASSOC NAME (fetch (PFLOPPYFDEV DIR) of FDEV) :TEST #'STRING.EQUAL)) :TEST #'STRING.EQUAL] (SETQ VERSION (LISTGET UNAME 'VERSION)) (SETQ VERSION (AND VERSION (NEQ 0 (NCHARS VERSION)) (MKATOM VERSION))) (* ;  "Version got unpacked as (possibly) empty string instead of number") (SETQ VERSION (\PFLOPPY.DIR.VERSION VERSION RECOG VALIST)) (RETURN (COND ((EQ RECOG 'NEW) (LISTPUT UNAME 'VERSION VERSION) (U-CASE (PACKFILENAME UNAME))) ((SETQ PFALLOC (CDR (ASSOC VERSION VALIST))) (* ;  "INFILEP returns NIL if filename not found ") (* ;  "rmk: Packing the name out of the FDEV might make it easier to implement a 2-floppy system") (\FLOPPY.ADDDEVICENAME (fetch (PFALLOC FILENAME) of PFALLOC])]) (\PFLOPPY.CREATE.PFILELIST [LAMBDA (NPAGES) (* lmm "13-Aug-84 15:46") (PROG (PFILELIST) (* Must be page aligned integral  number of pages. *) (SETQ PFILELIST (\FLOPPY.BUFFER NPAGES)) (replace (PFILELIST SEAL) of PFILELIST with SEAL.PFILELIST) (replace (PFILELIST VERSION) of PFILELIST with VERSION.PFILELIST) (replace (PFILELIST MAXENTRIES) of PFILELIST with (IQUOTIENT (IDIFFERENCE (ITIMES WORDSPERPAGE NPAGES) 4) 5)) (RETURN PFILELIST]) (\PFLOPPY.ADD.TO.PFILELIST [LAMBDA (PFALLOC) (* mjs "29-Nov-84 16:08") (PROG (PSECTOR9 PFILELIST PFLE NENTRIES NPAGES NEWPFILELIST NEXT PMPAGE NPMPAGE NEWMAXENTRIES NEWNPAGES) (SETQ PSECTOR9 (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV)) (SETQ PFILELIST (fetch (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV)) (* Create PFLE. *) (SETQ PFLE (create PFLE FILEID _ (fetch (PSECTOR9 NEXTUNUSEDFILEID) of PSECTOR9) TYPE _ (fetch (PFALLOC FILETYPE) of PFALLOC) START _ (fetch (PFALLOC START) of PFALLOC) LENGTH _ (fetch (PFALLOC LENGTH) of PFALLOC))) (replace (PSECTOR9 NEXTUNUSEDFILEID) of PSECTOR9 with (ADD1 (fetch (PSECTOR9 NEXTUNUSEDFILEID ) of PSECTOR9))) (replace (PFALLOC PFLE) of PFALLOC with PFLE) (* Add PFLE to PFILELIST.  *) (SETQ NENTRIES (fetch (PFILELIST NENTRIES) of PFILELIST)) [COND ((IEQP NENTRIES (fetch (PFILELIST MAXENTRIES) of PFILELIST)) (* First increase size of PFILELIST) (SETQ NPAGES (fetch (PFILELIST NPAGES) of PFILELIST)) (SETQ NEWPFILELIST (\PFLOPPY.CREATE.PFILELIST (ADD1 NPAGES))) (SETQ NEWMAXENTRIES (fetch (PFILELIST MAXENTRIES) of NEWPFILELIST)) (SETQ NEWNPAGES (fetch (PFILELIST NPAGES) of NEWPFILELIST)) (\BLT NEWPFILELIST PFILELIST (ITIMES 256 NPAGES)) (* update the MAXENTRIES field of  the new PFILELIST) (replace (PFILELIST MAXENTRIES) of NEWPFILELIST with NEWMAXENTRIES) (* note%: don't need to update  NPAGES field since it is calculated  from MAXENTRIES field) (SETQ PFILELIST NEWPFILELIST) (SETQ NPAGES NEWNPAGES) (replace (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV with PFILELIST) (* Now allocate larger block on  floppy. *) (SETQ PFALLOC (\PFLOPPY.ALLOCATE NPAGES)) [\PFLOPPY.DEALLOCATE (for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) thereis (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(PFILELIST] (SETQ NEXT (fetch (PFALLOC NEXT) of PFALLOC)) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (SETQ PSECTOR9 (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV)) (UNINTERRUPTABLY (replace (PFALLOC FILENAME) of PFALLOC with '(PFILELIST)) (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.PFILELIST) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.PFILELIST) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.PFILELIST) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.PFILELIST) (replace (PSECTOR9 PFILELISTSTART) of PSECTOR9 with (fetch (PFALLOC START) of PFALLOC)) (replace (PSECTOR9 PFILELISTLENGTH) of PSECTOR9 with NPAGES) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of PFALLOC)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T) (\PFLOPPY.SAVE.PFILELIST T) (\PFLOPPY.SAVE.PSECTOR9 T))] (\MOVEWORDS PFLE 0 PFILELIST (IPLUS 4 (ITIMES 5 NENTRIES)) 5) (replace (PFILELIST NENTRIES) of PFILELIST with (ADD1 NENTRIES]) (\PFLOPPY.DELETE.FROM.PFILELIST [LAMBDA (PFALLOC) (* edited%: "23-Jul-84 15:35") (PROG (PFILELIST PFLE FILEID NENTRIES) (SETQ PFILELIST (fetch (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV)) (SETQ PFLE (fetch (PFALLOC PFLE) of PFALLOC)) (SETQ FILEID (fetch (PFLE FILEID) of PFLE)) (SETQ NENTRIES (fetch (PFILELIST NENTRIES) of PFILELIST)) (* Delete PFLE from PFILELIST.  *) (for I from 1 to NENTRIES when (IEQP [\FLOPPY.MTL.FIXP (\GETBASEFIXP PFILELIST (IPLUS 4 (ITIMES 5 I] FILEID) do (SETQ NENTRIES (SUB1 NENTRIES)) (\MOVEWORDS PFILELIST (IPLUS 4 (ITIMES 5 NENTRIES)) PFILELIST (IPLUS 4 (ITIMES 5 I)) 5) [\ZEROWORDS (\ADDBASE PFILELIST (IPLUS 4 (ITIMES 5 NENTRIES ))) (\ADDBASE PFILELIST (IPLUS 8 (ITIMES 5 NENTRIES] (replace (PFILELIST NENTRIES) of PFILELIST with NENTRIES)) (* TBW%: Could try to shorten  PFILELIST after a delete.  Not a crucial problem.  *) (replace (PFALLOC PFLE) of PFALLOC with NIL]) (\PFLOPPY.SAVE.PFILELIST [LAMBDA (NOERROR) (* kbr%: " 1-Nov-85 18:23") (PROG (PFILELIST) (SETQ PFILELIST (fetch (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV)) (for I from 0 to (SUB1 (fetch (PFILELIST NPAGES) of PFILELIST)) do (\PFLOPPY.WRITEPAGENO (IPLUS (fetch (PSECTOR9 PFILELISTSTART) of (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV)) I) (\ADDBASE PFILELIST (ITIMES I 256)) NOERROR]) (\PFLOPPY.SAVE.PSECTOR9 [LAMBDA (NOERROR) (* edited%: "23-Jul-84 15:35") (PROG NIL (GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (\FLOPPY.WRITESECTOR \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 9) (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV) NOERROR]) (\PFLOPPY.WRITEPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* edited%: "23-Jul-84 15:35") (PROG NIL (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\PFLOPPY.WRITEPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\PFLOPPY.WRITEPAGE [LAMBDA (FILE FIRSTPAGE# BUFFER) (* edited%: "23-Jul-84 15:35") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PFALLOC PAGENO) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (* Put in a check to see that we  have not exceeded our allocation.  *) (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) RETRY (SETQ PAGENO (IPLUS (fetch (PFALLOC START) of PFALLOC) 1 FIRSTPAGE#)) (COND ((IGREATERP PAGENO (fetch (PFALLOC END) of PFALLOC)) (\PFLOPPY.EXTEND PFALLOC) (GO RETRY))) (\PFLOPPY.WRITEPAGENO PAGENO BUFFER))) (BLOCK]) (\PFLOPPY.TRUNCATEFILE [LAMBDA (FILE LASTPAGE LASTOFFSET) (* kbr%: "25-Nov-84 13:25") (WITH.MONITOR \FLOPPYLOCK [PROG (STREAM EPAGE EOFFSET PFALLOC PLPAGE) (* TBW%: Can't extend files only  shorten files with this function as  it stands. *) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (* Split PFALLOC into file block and  free block. *) (SETQ EPAGE (fetch (STREAM EPAGE) of STREAM)) (SETQ EOFFSET (fetch (STREAM EOFFSET) of STREAM)) (COND ((NULL LASTPAGE) (* LASTPAGE = NIL means to truncate  to the current length.  *) (SETQ LASTPAGE EPAGE) (SETQ LASTOFFSET EOFFSET))) (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (replace (PLPAGE LENGTH) of (fetch (PFALLOC PLPAGE) of PFALLOC) with (IPLUS (ITIMES 512 LASTPAGE) LASTOFFSET)) (* Convert remaining pages into free  block. *) (COND ((ZEROP LASTOFFSET) (* Special case LASTOFFSET = 0.0 *) (\PFLOPPY.TRUNCATE PFALLOC (IPLUS 1 LASTPAGE))) (T (\PFLOPPY.TRUNCATE PFALLOC (IPLUS 1 (ADD1 LASTPAGE])]) (\PFLOPPY.FORMAT [LAMBDA (NAME AUTOCONFIRMFLG SLOWFLG) (* ; "Edited 11-Jun-87 17:54 by jds") (* ;; "FORMAT a PILOT-mode floppy.") (* ;; "Return T if formatted, NIL if user abort. *") (PROG (CONFIRM PSECTOR9 PMPAGEA PMPAGEB PMPAGEC PFILELIST PFLE NATTEMPTS (NTIMES 1)) (\FLOPPY.UNCACHED.WRITE) (* ; "Confirmation. *") (SETQ CONFIRM (\PFLOPPY.CONFIRM "Destroy contents of floppy" AUTOCONFIRMFLG T)) (COND ((NOT CONFIRM) (RETURN NIL))) (* ;; "Forcibly close floppy:") (\FLOPPY.CLOSE) (* ;; "Create critical records:") (SETQ PFILELIST (\FLOPPY.BUFFER 2)) (replace (PFILELIST SEAL) of PFILELIST with SEAL.PFILELIST) (replace (PFILELIST VERSION) of PFILELIST with VERSION.PFILELIST) (replace (PFILELIST NENTRIES) of PFILELIST with 1) (replace (PFILELIST MAXENTRIES) of PFILELIST with (IQUOTIENT (IDIFFERENCE 512 4) 5)) (SETQ PFLE (create PFLE FILEID _ 1 TYPE _ FILETYPE.PFILELIST START _ (ADD1 \PFLOPPYFIRSTDATAPAGE) LENGTH _ 2)) (\MOVEWORDS PFLE 0 PFILELIST 4 5) (SETQ PMPAGEA (create PMPAGE PTYPE _ PMPAGEETYPE.FREE PFILEID _ 0 PFILETYPE _ FILETYPE.FREE PLENGTH _ 0 NTYPE _ PMPAGEETYPE.PFILELIST NFILETYPE _ FILETYPE.PFILELIST NFILEID _ 1 NLENGTH _ 2)) [SETQ PMPAGEB (create PMPAGE PTYPE _ PMPAGEETYPE.PFILELIST PFILETYPE _ FILETYPE.PFILELIST PFILEID _ 1 PLENGTH _ 2 NTYPE _ PMPAGEETYPE.FREE NFILETYPE _ FILETYPE.FREE NFILEID _ 0 NLENGTH _ (IDIFFERENCE \PFLOPPYLASTDATAPAGE (IPLUS \PFLOPPYFIRSTDATAPAGE 4] (SETQ PMPAGEC (create PMPAGE PTYPE _ PMPAGEETYPE.FREE PFILEID _ 0 PFILETYPE _ FILETYPE.FREE PLENGTH _ (IDIFFERENCE \PFLOPPYLASTDATAPAGE (IPLUS \PFLOPPYFIRSTDATAPAGE 4)) NTYPE _ PMPAGEETYPE.FREE NFILEID _ 0 NFILETYPE _ FILETYPE.FREE NLENGTH _ 0)) (SETQ PSECTOR9 (create PSECTOR9 PFILELISTSTART _ (ADD1 \PFLOPPYFIRSTDATAPAGE) PFILELISTFILEID _ 1 PFILELISTLENGTH _ 2 ROOTFILEID _ 0 NEXTUNUSEDFILEID _ 2)) (replace (PSECTOR9 $LABEL) of PSECTOR9 with NAME) (* ; "Check floppy can write. *") (SETQ NATTEMPTS 0) RETRY (SETQ NATTEMPTS (ADD1 NATTEMPTS)) (COND ((IGREATERP NATTEMPTS 5) (\FLOPPY.MESSAGE "Couldn't format floppy") (RETURN NIL))) (COND ((NOT (AND (\FLOPPY.INITIALIZE T) (\FLOPPY.WRITEABLEP))) (GO ERROR))) (* ; "Configure floppy. *") [COND ((OR SLOWFLG (NULL PSECTOR9)) (* ; "Format tracks. *") (COND ([NOT (AND (\FLOPPY.INITIALIZE T) (\FLOPPY.RECALIBRATE T) (GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (\FLOPPY.FORMATTRACKS \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 1) 1 T)) (GLOBALRESOURCE \FLOPPY.IBMD256.FLOPPYIOCB (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD256.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 1 SECTOR _ 1) 1 T)) (\FLOPPY.RECALIBRATE T) (GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD512.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 1 HEAD _ 0 SECTOR _ 1) (SUB1 \FLOPPY.CYLINDERS) T) (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD512.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 1 HEAD _ 1 SECTOR _ 1) (SUB1 \FLOPPY.CYLINDERS) T] (GO ERROR))) (* ;; "Check that we can read from each page. We need to do this because FORMATTRACKS (espescially DOVE) is unreliable. If we find a bad page, it usually works to try again a few times. We know from experience that the tendency is for an unformatted floppy to become better the more times you format it. *") (COND ([GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (for I from \PFLOPPYFIRSTDATAPAGE to \PFLOPPYLASTDATAPAGE by (SELECTQ (MACHINETYPE) (DOVE (* ; "WAS 1") 9) (DANDELION (COND ((type? PSECTOR9 CONFIRM) (* ;  "Formatted before. Spot check output of formatting. *") 19) (T (* ;  "Never formatted before. Be more careful. *") 1))) NIL) thereis (NULL (\PFLOPPY.READPAGENO I \FLOPPY.SCRATCH.BUFFER T] (\FLOPPY.MESSAGE "Retrying format." PROMPTWINDOW) (GO ERROR] (* ;; "Write PMPAGEs, PFILELIST, and PSECTOR9. Write PSECTOR9 last. We check for it first when we open floppy. *") (COND ([NOT (AND (\PFLOPPY.WRITEPAGENO \PFLOPPYFIRSTDATAPAGE PMPAGEA T) (\PFLOPPY.WRITEPAGENO (ADD1 \PFLOPPYFIRSTDATAPAGE) PFILELIST T) (\PFLOPPY.WRITEPAGENO (IPLUS \PFLOPPYFIRSTDATAPAGE 2) (\ADDBASE PFILELIST 256) T) (\PFLOPPY.WRITEPAGENO (IPLUS \PFLOPPYFIRSTDATAPAGE 3) PMPAGEB T) (\PFLOPPY.WRITEPAGENO \PFLOPPYLASTDATAPAGE PMPAGEC T) (GLOBALRESOURCE \FLOPPY.IBMS128.FLOPPYIOCB (\FLOPPY.WRITESECTOR \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 9) PSECTOR9 T] (GO ERROR))) (SETQ NTIMES (SUB1 NTIMES)) (COND ((EQ NTIMES 0) (* ; "Successful Return. *") (RETURN T)) (T (GO RETRY))) ERROR (SETQ SLOWFLG T) (COND ((EQ (MACHINETYPE) 'DOVE) (* ;; "DOVEFLOPPY formatting is so flakey that if we find any indication of problems in formatting that we then insist that we keep formatting until we can successfully format twice in a row. *") (SETQ NTIMES 2))) (GO RETRY]) (\PFLOPPY.CONFIRM [LAMBDA (MESSAGE AUTOCONFIRMFLG NOERROR WAIT-TIME) (* ; "Edited 15-Aug-88 11:51 by jds") (PROG (PSECTOR9 STRING ANSWER) RETRY [COND ((OR (NOT NOERROR) (NOT AUTOCONFIRMFLG)) (SETQ PSECTOR9 (\PFLOPPY.GET.PSECTOR9] (COND ((AND (NOT NOERROR) (NULL PSECTOR9)) (\FLOPPY.BREAK "Not a pilot floppy") (GO RETRY))) (COND [(NOT AUTOCONFIRMFLG) [SETQ STRING (COND (PSECTOR9 (CONCAT MESSAGE " " (fetch (PSECTOR9 $LABEL) of PSECTOR9) "? ")) (T (CONCAT MESSAGE "? "] (SELECTQ (ASKUSER WAIT-TIME 'Y STRING) (Y (SETQ ANSWER T)) (N (SETQ ANSWER NIL)) (SHOULDNT)) (* ;  "Now check that user didn't switch floppies during ASKUSER *") (COND ((NOT (\FLOPPY.UNCACHED.WRITE)) (GO RETRY] (T (SETQ ANSWER T))) (COND ((AND (NOT NOERROR) (NOT ANSWER)) (\FLOPPY.BREAK "User confirmation required.") (GO RETRY))) (COND ((AND ANSWER PSECTOR9) (* ;  "Not only indicate confirmation, but also that this is a PILOT floppy. *") (SETQ ANSWER PSECTOR9))) (RETURN ANSWER]) (\PFLOPPY.GET.NAME [LAMBDA NIL (* kbr%: "13-Feb-85 16:24") (PROG NIL (\FLOPPY.CACHED.READ) (\PFLOPPY.OPEN.PSECTOR9) (RETURN (fetch (PSECTOR9 $LABEL) of (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV ]) (\PFLOPPY.SET.NAME [LAMBDA (NAME) (* kbr%: "13-Feb-85 16:24") (PROG NIL (\FLOPPY.CACHED.WRITE) (\PFLOPPY.OPEN.PSECTOR9) (UNINTERRUPTABLY (replace (PSECTOR9 $LABEL) of (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV ) with NAME) (\PFLOPPY.SAVE.PSECTOR9)) (RETURN (fetch (PSECTOR9 $LABEL) of (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV ]) ) (* ; "`ALLOCATE' *") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ MINIMUM.ALLOCATION 5) (RPAQQ DEFAULT.ALLOCATION 50) (CONSTANTS (MINIMUM.ALLOCATION 5) (DEFAULT.ALLOCATION 50)) ) ) (RPAQ? \FLOPPY.ALLOCATIONS.BITMAP NIL) (DEFINEQ (\PFLOPPY.ALLOCATE [LAMBDA (LENGTH) (* kbr%: "22-Jul-84 22:34") (* Return a PFALLOC pointing to a  free block. *) (PROG (FREE PFLENGTH PMPAGE NEXT NPMPAGE) RETRY (SETQ FREE (\PFLOPPY.ALLOCATE.LARGEST)) (COND ((NULL FREE) (\PFLOPPY.GAINSPACE LENGTH) (GO RETRY))) (SETQ PFLENGTH (fetch (PFALLOC LENGTH) of FREE)) [COND [LENGTH (* Required LENGTH.  *) (COND ((ILESSP PFLENGTH LENGTH) (\PFLOPPY.GAINSPACE LENGTH) (GO RETRY)) ((ILESSP PFLENGTH (IPLUS LENGTH MINIMUM.ALLOCATION))) (T (\PFLOPPY.TRUNCATE FREE LENGTH] (T (* Defaulted LENGTH.  *) (COND ((ILESSP PFLENGTH MINIMUM.ALLOCATION) (\PFLOPPY.GAINSPACE MINIMUM.ALLOCATION) (GO RETRY)) ((ILESSP PFLENGTH (IPLUS DEFAULT.ALLOCATION MINIMUM.ALLOCATION))) (T (\PFLOPPY.TRUNCATE FREE DEFAULT.ALLOCATION] (replace (PFALLOC FILENAME) of FREE with '(FILE)) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of FREE)) [COND ((NOT (EQ (fetch (PMPAGE NTYPE) of PMPAGE) PMPAGEETYPE.FILE)) (* Marker pages need to be updated.  *) (SETQ NEXT (fetch (PFALLOC NEXT) of FREE)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (UNINTERRUPTABLY (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FILE) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FILE) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of FREE)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T))] (\PFLOPPY.ALLOCATE.WATCHDOG) (\PFLOPPY.ICHECK) (RETURN FREE]) (\PFLOPPY.ALLOCATE.LARGEST [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (* Return largest free PFALLOC.  *) (PROG (LENGTH ANSWER) (SETQ LENGTH 0) (for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) when (AND (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE)) (IGREATERP (fetch (PFALLOC LENGTH) of PFALLOC) LENGTH)) do (SETQ ANSWER PFALLOC) (SETQ LENGTH (fetch (PFALLOC LENGTH) of PFALLOC))) (\PFLOPPY.ICHECK) (RETURN ANSWER]) (\PFLOPPY.TRUNCATE [LAMBDA (PFALLOC LENGTH) (* kbr%: "22-Jul-84 22:34") (* Trunctate PFALLOC to LENGTH  pages. *) (PROG (PMPAGE NEXT NPMPAGE FREE FPMPAGE TAIL) (* Trivial case = already the right  length. *) (COND ((IGEQ LENGTH (fetch (PMPAGE NLENGTH) of (fetch (PFALLOC PMPAGE) of PFALLOC))) (* No remaining pages, so no free  block. *) (\PFLOPPY.ICHECK) (RETURN))) (* Nontrivial case.  *) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ NEXT (fetch (PFALLOC NEXT) of PFALLOC)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (* Create FREE block.  *) (SETQ FPMPAGE (create PMPAGE PLENGTH _ LENGTH PTYPE _ (fetch (PMPAGE NTYPE) of PMPAGE) PFILETYPE _ (fetch (PMPAGE NFILETYPE) of PMPAGE) NLENGTH _ (IPLUS (fetch (PMPAGE NLENGTH) of PMPAGE) (IMINUS (ADD1 LENGTH))) NTYPE _ PMPAGEETYPE.FREE NFILETYPE _ FILETYPE.FREE)) (SETQ FREE (create PFALLOC FILENAME _ '(FREE) START _ (IPLUS (fetch (PFALLOC START) of PFALLOC) (ADD1 LENGTH)) PMPAGE _ FPMPAGE)) (SETQ TAIL (MEMB PFALLOC (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV))) (UNINTERRUPTABLY (* Fix PMPAGE and NPMPAGE fields.  *) (replace (PMPAGE NLENGTH) of PMPAGE with (fetch (PMPAGE PLENGTH) of FPMPAGE)) (replace (PMPAGE PLENGTH) of NPMPAGE with (fetch (PMPAGE NLENGTH) of FPMPAGE)) (replace (PMPAGE PTYPE) of NPMPAGE with (fetch (PMPAGE NTYPE) of FPMPAGE)) (replace (PMPAGE PFILETYPE) of NPMPAGE with (fetch (PMPAGE NFILETYPE) of FPMPAGE)) (* Insert FREE between PFALLOC and  NEXT. *) (push (CDR TAIL) FREE) (replace (PFALLOC NEXT) of PFALLOC with FREE) (replace (PFALLOC PREV) of FREE with PFALLOC) (replace (PFALLOC NEXT) of FREE with NEXT) (replace (PFALLOC PREV) of NEXT with FREE) (* Write new marker pages out to  floppy. *) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of PFALLOC)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of FREE)) FPMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T)) (\PFLOPPY.ICHECK]) (\PFLOPPY.DEALLOCATE [LAMBDA (PFALLOC) (* kbr%: "22-Jul-84 22:34") (PROG (PMPAGE NEXT NPMPAGE) (replace (PFALLOC PLPAGE) of PFALLOC with NIL) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ NEXT (fetch (PFALLOC NEXT) of PFALLOC)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (UNINTERRUPTABLY (replace (PFALLOC FILENAME) of PFALLOC with '(FREE)) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FREE) (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FREE) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FREE) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FREE) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of PFALLOC)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T)) (\PFLOPPY.ICHECK]) (\PFLOPPY.EXTEND [LAMBDA (PFALLOC) (* kbr%: "22-Jul-84 22:34") (PROG (NEXT PMPAGE NNEXT NNPMPAGE OLDLENGTH LENGTH TAIL NEW START1 START2 PMPAGE1 PMPAGE2 PREV1 PREV2 NEXT1 NEXT2 TAIL1 TAIL2) (SETQ NEXT (fetch (PFALLOC NEXT) of PFALLOC)) (COND ((AND (EQUAL (fetch (PFALLOC FILENAME) of NEXT) '(FREE)) (fetch (PFALLOC NEXT) of NEXT)) (* Cannibalize following free block.  *) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ NNEXT (fetch (PFALLOC NEXT) of NEXT)) (SETQ NNPMPAGE (fetch (PFALLOC PMPAGE) of NNEXT)) (SETQ OLDLENGTH (fetch (PFALLOC LENGTH) of PFALLOC)) (SETQ LENGTH (IPLUS (fetch (PFALLOC START) of NNEXT) (IMINUS (fetch (PFALLOC START) of PFALLOC)) -1)) (SETQ TAIL (MEMB PFALLOC (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV))) (UNINTERRUPTABLY (replace (PMPAGE NLENGTH) of PMPAGE with LENGTH) (replace (PMPAGE PLENGTH) of NNPMPAGE with LENGTH) (replace (PMPAGE PTYPE) of NNPMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE PFILETYPE) of NNPMPAGE with FILETYPE.FILE) (pop (CDR TAIL)) (replace (PFALLOC NEXT) of PFALLOC with NNEXT) (replace (PFALLOC PREV) of NNEXT with PFALLOC) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of PFALLOC)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NNEXT)) NNPMPAGE T)) [COND ((IGREATERP LENGTH (IPLUS OLDLENGTH DEFAULT.ALLOCATION MINIMUM.ALLOCATION)) (\PFLOPPY.TRUNCATE PFALLOC (IPLUS OLDLENGTH DEFAULT.ALLOCATION] (\PFLOPPY.ICHECK) (RETURN))) (* Have to reallocate.  *) (SETQ NEW (\PFLOPPY.ALLOCATE (IPLUS (fetch (PFALLOC LENGTH) of PFALLOC) DEFAULT.ALLOCATION))) (* Copy contents from PFALLOC to  NEW. *) (\FLOPPY.MESSAGE "Reallocating") [GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END) of PFALLOC) as J from (fetch (PFALLOC START) of NEW) do (\PFLOPPY.WRITEPAGENO J (\PFLOPPY.READPAGENO I \FLOPPY.SCRATCH.BUFFER] (\FLOPPY.MESSAGE "Finished Reallocating") (* Make PFALLOC and NEW switch  places in (fetch (PFLOPPYFDEV  PFALLOCS) of \FLOPPYFDEV) *) (\PFLOPPY.DELETE.FROM.PFILELIST PFALLOC) (SETQ START1 (fetch (PFALLOC START) of PFALLOC)) (SETQ START2 (fetch (PFALLOC START) of NEW)) (SETQ PMPAGE1 (fetch (PFALLOC PMPAGE) of PFALLOC)) (SETQ PMPAGE2 (fetch (PFALLOC PMPAGE) of NEW)) (SETQ PREV1 (fetch (PFALLOC PREV) of PFALLOC)) (SETQ PREV2 (fetch (PFALLOC PREV) of NEW)) (SETQ NEXT1 (fetch (PFALLOC NEXT) of PFALLOC)) (SETQ NEXT2 (fetch (PFALLOC NEXT) of NEW)) (SETQ TAIL1 (MEMB PFALLOC (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV))) (SETQ TAIL2 (MEMB NEW (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV))) (UNINTERRUPTABLY (replace (PFALLOC START) of PFALLOC with START2) (replace (PFALLOC START) of NEW with START1) (replace (PFALLOC PMPAGE) of PFALLOC with PMPAGE2) (replace (PFALLOC PMPAGE) of NEW with PMPAGE1) (COND (PREV1 (replace (PFALLOC NEXT) of PREV1 with NEW))) (COND (PREV2 (replace (PFALLOC NEXT) of PREV2 with PFALLOC))) (COND (NEXT1 (replace (PFALLOC PREV) of NEXT1 with NEW))) (COND (NEXT2 (replace (PFALLOC PREV) of NEXT2 with PFALLOC))) (replace (PFALLOC PREV) of PFALLOC with PREV2) (replace (PFALLOC PREV) of NEW with PREV1) (replace (PFALLOC NEXT) of PFALLOC with NEXT2) (replace (PFALLOC NEXT) of NEW with NEXT1) (RPLACA TAIL1 NEW) (RPLACA TAIL2 PFALLOC)) (\PFLOPPY.ADD.TO.PFILELIST PFALLOC) (* Now that PFALLOC points to extended block and NEW points to old block, we  can deallocate NEW. *) (\PFLOPPY.DEALLOCATE NEW) (\PFLOPPY.ICHECK]) (\PFLOPPY.GAINSPACE [LAMBDA (LENGTH) (* kbr%: " 1-Nov-85 16:17") (* Returns after a free block of  length LENGTH has been made  available. *) (PROG (PFALLOCS) RETRY (\PFLOPPY.GAINSPACE.MERGE) (* See if we have a long enough  block yet. *) (COND ((for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) thereis (AND (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE)) (IGEQ (fetch (PFALLOC LENGTH) of PFALLOC) LENGTH))) (RETURN))) (* Punt to user. *) (COND ((AND (IGEQ (FLOPPY.FREE.PAGES) (IPLUS LENGTH MINIMUM.ALLOCATION)) (FLOPPY.COMPACT)) (GO RETRY))) (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" '{FLOPPY} T) (GO RETRY]) (\PFLOPPY.GAINSPACE.MERGE [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (* Merge adjacent free blocks.  *) (PROG (PFALLOCS FREE OTHERS LAST NEXT PMPAGE NPMPAGE LENGTH) (SETQ PFALLOCS (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)) (\PFLOPPY.ICHECK) (do [SETQ FREE (for P in PFALLOCS thereis (AND (EQUAL (fetch (PFALLOC FILENAME) of P) '(FREE)) (fetch (PFALLOC NEXT) of P) (EQUAL (fetch (PFALLOC FILENAME) of (fetch (PFALLOC NEXT) of P)) '(FREE)) (fetch (PFALLOC NEXT) of (fetch (PFALLOC NEXT) of P] (COND ((NULL FREE) (RETURN))) (SETQ OTHERS (for (P _ (fetch (PFALLOC NEXT) of FREE)) by (fetch (PFALLOC NEXT) of P) while (AND (EQUAL (fetch (PFALLOC FILENAME) of P) '(FREE)) (fetch (PFALLOC NEXT) of P)) collect P)) (SETQ LAST (CAR (LAST OTHERS))) (SETQ NEXT (fetch (PFALLOC NEXT) of LAST)) (SETQ PMPAGE (fetch (PFALLOC PMPAGE) of FREE)) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (SETQ LENGTH (IPLUS (fetch (PFALLOC START) of NEXT) (IMINUS (fetch (PFALLOC START) of FREE)) -1)) (UNINTERRUPTABLY (for P in OTHERS do (DREMOVE P PFALLOCS)) (replace (PFALLOC NEXT) of FREE with NEXT) (replace (PFALLOC PREV) of NEXT with FREE) (replace (PMPAGE NLENGTH) of PMPAGE with LENGTH) (replace (PMPAGE PLENGTH) of NPMPAGE with LENGTH) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of FREE)) PMPAGE T) (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE T)) (\PFLOPPY.ICHECK]) (\PFLOPPY.ALLOCATE.WATCHDOG [LAMBDA NIL (* kbr%: "30-Sep-84 10:01") (* Bark bark *) (PROG (FREEPAGES) (COND ((NOT (EQ \FLOPPYFDEV \PFLOPPYFDEV)) (* Must be sysout or huge mode. Having little space after an allocation is what  we expect. *) (RETURN))) (SETQ FREEPAGES (\PFLOPPY.FREE.PAGES)) (COND ((ILESSP FREEPAGES 200) (\FLOPPY.MESSAGE (CONCAT FREEPAGES " pages left."]) (\PFLOPPY.FREE.PAGES [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (* Assume floppy is mounted.  Return number of free pages on  floppy. *) (PROG (ANSWER) (* Answer is calculated as if all free blocks were concentrated into one large  free block. *) (SETQ ANSWER 0) [for PFALLOC in (fetch (PFINFO PFALLOCS) of (fetch (FDEV DEVICEINFO) of \FLOPPYFDEV)) when (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE)) do (* Add in 1 here for overhead pages  that could be reclaimed.  *) (SETQ ANSWER (IPLUS ANSWER 1 (fetch (PFALLOC LENGTH) of PFALLOC] (* Lose 1 for overhead on large free  block. *) (SETQ ANSWER (SUB1 ANSWER)) (RETURN ANSWER]) (\PFLOPPY.LENGTHS [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (for P in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) collect (fetch (PFALLOC LENGTH) of P]) (\PFLOPPY.STARTS [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (for P in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) collect (fetch (PFALLOC START) of P]) (\PFLOPPY.ICHECK [LAMBDA NIL (* hdj " 5-Jun-86 13:00") (* Integrity check.  *) (PROG (STARTS LENGTHS PFALLOCS PMPAGE1 PMPAGE2) (SETQ STARTS (\PFLOPPY.STARTS)) (SETQ LENGTHS (\PFLOPPY.LENGTHS)) (COND ([NOT (EQUAL STARTS (SORT (COPY STARTS] (\FLOPPY.SEVERE.ERROR "Starts Allocation Error"))) (COND ((for L in LENGTHS thereis (ILESSP L 0)) (\FLOPPY.SEVERE.ERROR "Lengths1 Allocation Error"))) (COND ((NOT (IEQP (IPLUS (for L in LENGTHS sum L) (LENGTH LENGTHS)) (IPLUS \PFLOPPYLASTDATAPAGE (IMINUS \PFLOPPYFIRSTDATAPAGE) 1))) (\FLOPPY.SEVERE.ERROR "Lengths2 Allocation Error"))) (SETQ PFALLOCS (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV)) (for P1 in PFALLOCS when [OR (AND (fetch (PFALLOC PREV) of P1) (NOT (MEMB (fetch (PFALLOC PREV) of P1) PFALLOCS))) (AND (fetch (PFALLOC NEXT) of P1) (NOT (MEMB (fetch (PFALLOC NEXT) of P1) PFALLOCS] do (\FLOPPY.SEVERE.ERROR "Links Allocation Error")) (for P1 in PFALLOCS as P2 in (CDR PFALLOCS) when (OR (NOT (EQ (fetch (PFALLOC NEXT) of P1) P2)) (NOT (EQ (fetch (PFALLOC PREV) of P2) P1))) do (\FLOPPY.SEVERE.ERROR "Links2 Allocation Error")) (for P1 in PFALLOCS as P2 in (CDR PFALLOCS) when (NOT (IEQP (IPLUS (fetch (PFALLOC END) of P1) 2) (fetch (PFALLOC START) of P2))) do (  \FLOPPY.SEVERE.ERROR "Lengths3 Allocation Error" )) (* Patch around FUGUE disaster *) [OR 'POSSIBLY.FUGUE.FLOPPY (for P1 in PFALLOCS as P2 in (CDR PFALLOCS) do (SETQ PMPAGE1 (fetch (PFALLOC PMPAGE) of P1)) (SETQ PMPAGE2 (fetch (PFALLOC PMPAGE) of P2)) (COND ([OR (NOT (IEQP (fetch (PMPAGE NLENGTH) of PMPAGE1) (fetch (PMPAGE PLENGTH) of PMPAGE2))) (NOT (IEQP (fetch (PMPAGE NTYPE) of PMPAGE1) (fetch (PMPAGE PTYPE) of PMPAGE2))) (NOT (IEQP (fetch (PMPAGE NFILEID) of PMPAGE1) (fetch (PMPAGE PFILEID) of PMPAGE2))) (NOT (IEQP (fetch (PMPAGE NFILETYPE) of PMPAGE1) (fetch (PMPAGE PFILETYPE) of PMPAGE2] (\FLOPPY.SEVERE.ERROR "PMPAGEs Allocation Error"] (COND ([NOT (FMEMB (FLOPPY.MODE) '(SYSOUT HUGEPILOT] (for F in (\DEVICE-OPEN-STREAMS \FLOPPYFDEV) when [AND (EQ (fetch (STREAM DEVICE) of F) \FLOPPYFDEV) (NOT (MEMB (fetch (FLOPPYSTREAM PFALLOC) of F) (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV] do (\FLOPPY.SEVERE.ERROR "Streams Allocation Error"]) (\PFLOPPY.ALLOCATIONS [LAMBDA NIL (* kbr%: " 7-Aug-85 19:19") (* Debugging fn. Puts up a bitmap  representation of allocations on  floppy. *) (PROG (SECTORSPERCYLINDER REGION) (SETQ SECTORSPERCYLINDER (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK)) [COND ((NULL \FLOPPY.ALLOCATIONS.BITMAP) (SETQ \FLOPPY.ALLOCATIONS.BITMAP (BITMAPCREATE SECTORSPERCYLINDER \FLOPPY.CYLINDERS] (BITBLT NIL NIL NIL \FLOPPY.ALLOCATIONS.BITMAP NIL NIL NIL NIL 'TEXTURE 'REPLACE WHITESHADE ) (for PFALLOC in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE] do (for I from (fetch (PFALLOC START) of PFALLOC) to (fetch (PFALLOC END) of PFALLOC) do (BITMAPBIT \FLOPPY.ALLOCATIONS.BITMAP (IREMAINDER (SUB1 I) SECTORSPERCYLINDER) (IQUOTIENT (SUB1 I) SECTORSPERCYLINDER) 1))) (EDITBM \FLOPPY.ALLOCATIONS.BITMAP]) ) (* ; "`SERVICES' *") (DEFINEQ (FLOPPY.FREE.PAGES [LAMBDA NIL (* kbr%: "22-Jul-84 22:40") (WITH.MONITOR \FLOPPYLOCK (\FLOPPY.CACHED.READ) (SELECTQ (FLOPPY.MODE) ((PILOT HUGEPILOT SYSOUT) (\PFLOPPY.FREE.PAGES)) (CPM (\CFLOPPY.FREE.PAGES)) (SHOULDNT)))]) (FLOPPY.FORMAT [LAMBDA (NAME AUTOCONFIRMFLG SLOWFLG) (* ; "Edited 11-Jun-87 14:35 by jds") (* ;;; "Format a floppy disk for use. Label the floppy with NAME. If AUTOCONFIRMFLG, then don't bother asking the user if he's willing to lose the information on the floppy. If SLOWFLG, then really format it track by track; otherwise, if possible, just rewrite the volume label and clean out the directory.") (WITH.MONITOR \FLOPPYLOCK (SELECTQ (FLOPPY.MODE) ((PILOT HUGEPILOT SYSOUT) (* ;  "For Pilot, HugePilot, and Sysout format floppies, it's the same formatting code:") (\PFLOPPY.FORMAT NAME AUTOCONFIRMFLG SLOWFLG)) (CPM (* ; "Format for CPM use (obsolete):") (\CFLOPPY.FORMAT NAME AUTOCONFIRMFLG SLOWFLG)) (SHOULDNT)))]) (FLOPPY.NAME [LAMBDA (NAME) (* kbr%: "22-Jul-84 22:40") (COND (NAME (FLOPPY.SET.NAME NAME)) (T (FLOPPY.GET.NAME]) (FLOPPY.GET.NAME [LAMBDA NIL (* kbr%: "22-Jul-84 22:40") (WITH.MONITOR \FLOPPYLOCK (SELECTQ (FLOPPY.MODE) ((PILOT HUGEPILOT SYSOUT) (\PFLOPPY.GET.NAME)) (SHOULDNT)))]) (FLOPPY.SET.NAME [LAMBDA (NAME) (* kbr%: "22-Jul-84 22:40") (WITH.MONITOR \FLOPPYLOCK (SELECTQ (FLOPPY.MODE) ((PILOT HUGEPILOT SYSOUT) (\PFLOPPY.SET.NAME NAME)) (SHOULDNT)))]) (FLOPPY.CAN.READP [LAMBDA NIL (* ; "Edited 11-Jun-87 17:03 by jds") (* ;; "Returns T if a floppy is loaded and readable.") (WITH.MONITOR \FLOPPYLOCK (PROG (ANSWER) [COND ((\FLOPPY.EXISTSP T) (SETQ ANSWER (\FLOPPY.MOUNTEDP T)) (COND ((NOT ANSWER) (* ;  "Possibly the user switched floppies. *") (\FLOPPY.CLOSE) (\FLOPPY.INITIALIZE T) (SETQ ANSWER (\FLOPPY.MOUNTEDP T] (RETURN ANSWER)))]) (FLOPPY.CAN.WRITEP [LAMBDA NIL (* ; "Edited 11-Jun-87 16:56 by jds") (* ;; "Returns T if the floppy is available and writeable.") (WITH.MONITOR \FLOPPYLOCK (PROG (ANSWER) [COND ((\FLOPPY.EXISTSP T) (SETQ ANSWER (\FLOPPY.CAN.WRITEP T)) (COND ((NOT ANSWER) (* ;  "Possibly the user switched floppies. *") (\FLOPPY.CLOSE) (\FLOPPY.INITIALIZE T) (SETQ ANSWER (\FLOPPY.CAN.WRITEP T] (RETURN ANSWER)))]) (FLOPPY.WAIT.FOR.FLOPPY [LAMBDA (NEWFLG) (* ; "Edited 29-Jul-87 14:48 by jds") (* ;  "Wait until floppy drive contains (new) floppy.") (WITH.MONITOR \FLOPPYLOCK [PROG NIL (* ;  "NOTE: Wait 2 seconds to guarantee drive door is secure. *") (\FLOPPY.CLOSE) (COND ((EQ (MACHINETYPE) 'DOVE) (SETQ NEWFLG T))) (COND (NEWFLG (SELECTQ (MACHINETYPE) (DANDELION (DISMISS 5000) (until (NOT (FLOPPY.CAN.READP)) do (BLOCK))) (DOVE (* ;  "GODDAMN DAYBREAK DOOROPEN BIT DOESN'T WORK *") (\FLOPPY.MESSAGE "Type any character after inserting new floppy." T) (CLEARBUF T) (\GETKEY)) NIL))) DEBOUNCE (until (FLOPPY.CAN.READP) do (BLOCK)) (COND (NEWFLG (DISMISS 2000))) (COND ((NOT (\FLOPPY.CAN.READP T)) (* ;  "Drive door probably didn't stick. *") (GO DEBOUNCE])]) ) (* ; "`SYSOUT' *") (RPAQ? \SFLOPPYINFO NIL) (RPAQ? \SFLOPPYFDEV NIL) (RPAQ? \HFLOPPY.MAXPAGES NIL) (RPAQ? \SFLOPPY.PAGENO NIL) (RPAQ? \SFLOPPY.FLOPPYNO NIL) (RPAQ? \SFLOPPY.PAGES NIL) (RPAQ? \SFLOPPY.HUGELENGTH NIL) (RPAQ? \SFLOPPY.HUGEPAGELENGTH NIL) (RPAQ? \SFLOPPY.IWRITEDATE NIL) (RPAQ? \SFLOPPY.FLOPPYNAME "Lisp Sysout ") (RPAQ? \SFLOPPY.FILENAME 'lisp.sysout) (RPAQ? \SFLOPPY.RECOG NIL) (RPAQ? \SFLOPPY.OTHERINFO NIL) (RPAQ? \SFLOPPY.SLOWFLG T) (RPAQ? \SFLOPPY.HACK.MODE NIL) (RPAQ? \SFLOPPY.HACK.STREAM NIL) (DEFINEQ (\SFLOPPY.INIT [LAMBDA NIL (* hdj "24-Sep-86 10:53") (PROG NIL (SETQ \SFLOPPYINFO (create PFINFO)) (SETQ \SFLOPPYFDEV (create FDEV DEVICENAME _ 'FLOPPY NODIRECTORIES _ T CLOSEFILE _ (FUNCTION \SFLOPPY.CLOSEHUGEFILE) DELETEFILE _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION TRUE) EVENTFN _ (FUNCTION \FLOPPY.EVENTFN) GENERATEFILES _ (FUNCTION \PFLOPPY.GENERATEFILES) GETFILEINFO _ (FUNCTION \SFLOPPY.GETFILEINFO) GETFILENAME _ (FUNCTION \PFLOPPY.GETFILENAME) HOSTNAMEP _ (FUNCTION \FLOPPY.HOSTNAMEP) OPENFILE _ (FUNCTION \SFLOPPY.OPENHUGEFILE) READPAGES _ (FUNCTION \SFLOPPY.READPAGES) REOPENFILE _ (FUNCTION \SFLOPPY.OPENHUGEFILE) SETFILEINFO _ (FUNCTION NILL) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \SFLOPPY.WRITEPAGES) DEVICEINFO _ \SFLOPPYINFO RENAMEFILE _ (FUNCTION NILL) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) OPENP _ (FUNCTION \GENERIC.OPENP))) (\MAKE.PMAP.DEVICE \SFLOPPYFDEV]) (\SFLOPPY.GETFILEINFO [LAMBDA (FILE ATTRIBUTE FDEV) (* kbr%: "25-Nov-84 13:02") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PLPAGE ANSWER) (\FLOPPY.CACHED.READ) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (SETQ PLPAGE (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (* Wizard incantations%: PAGELENGTH,  HUGEPAGESTART, HUGEPAGELENGTH,  HUGELENGTH *) (SETQ ANSWER (SELECTQ ATTRIBUTE (WRITEDATE (fetch (PLPAGE WRITEDATE) of PLPAGE)) (CREATIONDATE (fetch (PLPAGE CREATIONDATE) of PLPAGE)) (IWRITEDATE (fetch (PLPAGE IWRITEDATE) of PLPAGE)) (ICREATIONDATE (fetch (PLPAGE ICREATIONDATE) of PLPAGE)) (LENGTH (* We want hugelength.  *) (fetch (PLPAGE HUGELENGTH) of PLPAGE)) (TYPE (fetch (PLPAGE TYPE) of PLPAGE)) (BYTESIZE 8) (MESATYPE (fetch (PLPAGE MESATYPE) of PLPAGE)) (PAGELENGTH (fetch (PLPAGE PAGELENGTH) of PLPAGE)) (HUGEPAGESTART (fetch (PLPAGE HUGEPAGESTART) of PLPAGE)) (HUGEPAGELENGTH (fetch (PLPAGE HUGEPAGELENGTH) of PLPAGE)) (HUGELENGTH (fetch (PLPAGE HUGELENGTH) of PLPAGE)) NIL)) (RETURN ANSWER)))]) (\SFLOPPY.OPENHUGEFILE [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* hdj "16-May-86 21:52") (* * if file is open in conflicting way, barf) (if (NOT (\FILE-CONFLICT FILE ACCESS FDEV)) then (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM) RETRY (SELECTQ ACCESS (OUTPUT (SELECTQ RECOG (NEW (* OK. *)) (PROGN (SETQ RECOG (LISPERROR "ILLEGAL ARG" RECOG)) (GO RETRY)))) (INPUT (SELECTQ RECOG (OLD (* OK. *)) (PROGN (SETQ RECOG (LISPERROR "ILLEGAL ARG" RECOG)) (GO RETRY)))) (PROGN (SETQ ACCESS (LISPERROR "ILLEGAL ARG" ACCESS)) (GO RETRY))) (SETQ \SFLOPPY.RECOG RECOG) (SETQ \SFLOPPY.OTHERINFO (\FLOPPY.OTHERINFO OTHERINFO)) [COND ((EQ RECOG 'NEW) (SETQ \SFLOPPY.IWRITEDATE (IDATE)) (SETQ \SFLOPPY.HUGELENGTH (CDR (ASSOC 'LENGTH \SFLOPPY.OTHERINFO))) (COND ((NULL \SFLOPPY.HUGELENGTH) (\FLOPPY.MESSAGE "Can't open file without LENGTH parameter in SYSOUT mode." T) (LISPERROR "FILE WON'T OPEN" ""))) (SETQ \SFLOPPY.HUGEPAGELENGTH (IQUOTIENT (IPLUS \SFLOPPY.HUGELENGTH 511) 512)) (printout T (IQUOTIENT (IPLUS \SFLOPPY.HUGEPAGELENGTH \HFLOPPY.MAXPAGES -1) \HFLOPPY.MAXPAGES) " floppies will be required." T) (RPLACD (OR (ASSOC 'LENGTH \SFLOPPY.OTHERINFO) (PROGN (push \SFLOPPY.OTHERINFO (LIST 'LENGTH)) (CAR \SFLOPPY.OTHERINFO))) (ITIMES \HFLOPPY.MAXPAGES 512)) (SETQ STREAM (\SFLOPPY.OUTPUTFLOPPY \SFLOPPY.FLOPPYNAME \SFLOPPY.FILENAME \SFLOPPY.OTHERINFO))) (T (SETQ STREAM (\SFLOPPY.INPUTFLOPPY \SFLOPPY.FLOPPYNAME \SFLOPPY.FILENAME \SFLOPPY.OTHERINFO] (RETURN STREAM)))]) (\SFLOPPY.WRITEPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* kbr%: "26-Aug-84 11:20") (PROG NIL (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\SFLOPPY.WRITEPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\SFLOPPY.WRITEPAGE [LAMBDA (STREAM FIRSTPAGE# BUFFER) (* kbr%: "26-Aug-84 11:20") (WITH.MONITOR \FLOPPYLOCK (PROG (NEWSTREAM) [COND ((IGEQ \SFLOPPY.PAGENO \HFLOPPY.MAXPAGES) (\SFLOPPY.CLOSEFLOPPY STREAM) (RINGBELLS) [RPLACD (OR (ASSOC 'LENGTH \SFLOPPY.OTHERINFO) (PROGN (push \SFLOPPY.OTHERINFO (LIST 'LENGTH)) (CAR \SFLOPPY.OTHERINFO))) (IMIN (ITIMES \HFLOPPY.MAXPAGES 512) (IDIFFERENCE \SFLOPPY.HUGELENGTH (ITIMES \SFLOPPY.FLOPPYNO \HFLOPPY.MAXPAGES 512] (SETQ STREAM (\SFLOPPY.OUTPUTFLOPPY \SFLOPPY.FLOPPYNAME \SFLOPPY.FILENAME \SFLOPPY.OTHERINFO STREAM] (* Write page \SFLOPPY.PAGENO.  *) (GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (\BLT \FLOPPY.SCRATCH.BUFFER BUFFER 256) (\PFLOPPY.WRITEPAGE STREAM \SFLOPPY.PAGENO \FLOPPY.SCRATCH.BUFFER)) (SETQ \SFLOPPY.PAGENO (ADD1 \SFLOPPY.PAGENO))))]) (\SFLOPPY.READPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* kbr%: "26-Aug-84 11:20") (PROG NIL (COND ((EQ \SFLOPPY.RECOG 'NEW) (RETURN))) (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\SFLOPPY.READPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\SFLOPPY.READPAGE [LAMBDA (STREAM FIRSTPAGE# BUFFER) (* bvm%: "22-Nov-85 01:05") (WITH.MONITOR \FLOPPYLOCK (PROG (NEWSTREAM) [COND ((IGEQ \SFLOPPY.PAGENO \SFLOPPY.PAGES) (\SFLOPPY.CLOSEFLOPPY STREAM) (RINGBELLS) (SETQ STREAM (\SFLOPPY.INPUTFLOPPY \SFLOPPY.FLOPPYNAME \SFLOPPY.FILENAME \SFLOPPY.OTHERINFO STREAM] (* Read page \SFLOPPY.PAGENO.  *) (\PFLOPPY.READPAGE STREAM \SFLOPPY.PAGENO BUFFER) (SETQ \SFLOPPY.PAGENO (ADD1 \SFLOPPY.PAGENO))))]) (\SFLOPPY.CLOSEHUGEFILE [LAMBDA (STREAM) (* hdj "24-Sep-86 10:33") (WITH.MONITOR \FLOPPYLOCK (PROG (FULLFILENAME) (COND ((EQ \SFLOPPY.RECOG 'OLD) (RETURN))) (\CLEARMAP STREAM) (* ;; "Following 2 SETQ's patch around SYSOUT not passing us right HUGELENGTH in orignal OTHERINFO. I think this may be fixed now. *") (COND ((NOT (IEQP (IPLUS (ITIMES 512 (fetch (STREAM EPAGE) of STREAM)) (fetch (STREAM EOFFSET) of STREAM)) \SFLOPPY.HUGELENGTH)) (\FLOPPY.MESSAGE "Warning. Predicted file length disagrees with actual length.") (\FLOPPY.MESSAGE "Proceeding anyway."))) (SETQ \SFLOPPY.HUGELENGTH (IPLUS (ITIMES 512 (fetch (STREAM EPAGE) of STREAM)) (fetch (STREAM EOFFSET) of STREAM))) (SETQ \SFLOPPY.HUGEPAGELENGTH (IQUOTIENT (IPLUS \SFLOPPY.HUGELENGTH 511) 512)) (SETQ FULLFILENAME (\SFLOPPY.CLOSEFLOPPY STREAM T)) (COND ((EQ STREAM \SFLOPPY.HACK.STREAM) (* ; "This was a sysout *") (FLOPPY.MODE \SFLOPPY.HACK.MODE) (SETQ \SFLOPPY.HACK.STREAM NIL))) (RETURN FULLFILENAME)))]) (\SFLOPPY.INPUTFLOPPY [LAMBDA (FLOPPYNAME FILENAME OTHERINFO OLDSTREAM) (* ; "Edited 30-Jul-87 11:24 by jds") (* ;; "Set up to read from a sysout floppy; Prompt for the next floppy, if need be.") (* ;; "Returns a stream open on the file.") (PROG (FLOPPYNAME#I STREAM) [COND ((NULL OLDSTREAM) (SETQ \SFLOPPY.FLOPPYNO 1)) (T (SETQ \SFLOPPY.FLOPPYNO (ADD1 \SFLOPPY.FLOPPYNO] (SETQ FLOPPYNAME#I (CONCAT FLOPPYNAME "#" \SFLOPPY.FLOPPYNO)) (COND ((OR (IGREATERP \SFLOPPY.FLOPPYNO 1) (NOT (\FLOPPY.UNCACHED.READ T))) (printout T "Insert floppy " FLOPPYNAME#I T) (FLOPPY.WAIT.FOR.FLOPPY T))) (SETQ STREAM (\PFLOPPY.OPENFILE FILENAME 'INPUT 'OLD OTHERINFO \FLOPPYFDEV)) (SETQ \SFLOPPY.PAGENO 0) [COND ((NULL STREAM) (* ;  "Couldn't open the file on this floppy. Might be a bad floppy, might be in PILOT mode, etc.") (* ;; "Returning NIL will cause OPENFILE code to signal %"File Not Found%":") (LISPERROR "FILE NOT FOUND" FILENAME) (RETURN NIL)) (OLDSTREAM (* ;  "We're opening a continuation floppy for a big file.") (* ;;  "Fill in fields in the existing stream to mimic this floppy's worth of info:") (replace (FLOPPYSTREAM PFALLOC) of OLDSTREAM with (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (replace (FLOPPYSTREAM PLPAGE) of OLDSTREAM with (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (SETQ STREAM OLDSTREAM)) (T (* ; "Opening a fresh sysout stream. Fill in GLOBAL variables from the directory entry, to control the reading of the file across floppies.") (SETQ \SFLOPPY.HUGELENGTH (fetch (PLPAGE HUGELENGTH) of (fetch (FLOPPYSTREAM PLPAGE ) of STREAM))) (SETQ \SFLOPPY.HUGEPAGELENGTH (fetch (PLPAGE HUGEPAGELENGTH) of (fetch (FLOPPYSTREAM PLPAGE) of STREAM))) (replace (STREAM EPAGE) of STREAM with (IQUOTIENT \SFLOPPY.HUGELENGTH 512 )) (replace (STREAM EOFFSET) of STREAM with (IREMAINDER \SFLOPPY.HUGELENGTH 512] (SETQ \SFLOPPY.PAGES (COND (STREAM (fetch (PLPAGE PAGELENGTH) of (fetch (FLOPPYSTREAM PLPAGE ) of STREAM))) (T 0))) (RETURN STREAM]) (\SFLOPPY.OUTPUTFLOPPY [LAMBDA (FLOPPYNAME FILENAME OTHERINFO OLDSTREAM) (* kbr%: " 5-Aug-86 16:26") (PROG (FLOPPYNAME#I STREAM) [COND ((NULL OLDSTREAM) (SETQ \SFLOPPY.FLOPPYNO 1)) (T (SETQ \SFLOPPY.FLOPPYNO (ADD1 \SFLOPPY.FLOPPYNO] (SETQ FLOPPYNAME#I (CONCAT FLOPPYNAME "#" \SFLOPPY.FLOPPYNO)) (COND ((AND (IEQP \SFLOPPY.FLOPPYNO 1) (\FLOPPY.UNCACHED.READ T)) (* Don't prompt if first floppy  already ready for us.  *) (GO FORMAT))) RETRY (printout T "Insert floppy to become " FLOPPYNAME#I T) (FLOPPY.WAIT.FOR.FLOPPY T) FORMAT (COND ((NOT (\FLOPPY.UNCACHED.WRITE T)) (printout T "Can't proceed. This floppy is writeprotected." T) (GO RETRY)) ((NOT (\PFLOPPY.FORMAT FLOPPYNAME#I NIL \SFLOPPY.SLOWFLG)) (* Didn't format *) (GO RETRY))) (SETQ STREAM (\PFLOPPY.OPENFILE FILENAME 'OUTPUT 'NEW OTHERINFO \FLOPPYFDEV)) (SETQ \SFLOPPY.PAGENO 0) (SETQ \SFLOPPY.PAGES (IQUOTIENT (IPLUS (CDR (ASSOC 'LENGTH OTHERINFO)) 511) 512)) (COND (OLDSTREAM (replace (FLOPPYSTREAM PFALLOC) of OLDSTREAM with (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (replace (FLOPPYSTREAM PLPAGE) of OLDSTREAM with (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (SETQ STREAM OLDSTREAM))) (replace (STREAM FULLFILENAME) of STREAM with (PACK* '{FLOPPY} FILENAME)) (replace (PLPAGE $NAME) of (fetch (FLOPPYSTREAM PLPAGE) of STREAM) with FILENAME) (replace (PFALLOC FILENAME) of (fetch (FLOPPYSTREAM PFALLOC) of STREAM) with FILENAME) (RETURN STREAM]) (\SFLOPPY.CLOSEFLOPPY [LAMBDA (STREAM LASTFLOPPYFLG) (* kbr%: "25-Feb-85 12:18") (* The same as \PFLOPPY.CLOSEFILE  but without releasing STREAM.  Called only by \SFLOPPY.WRITEPAGE.  *) (PROG (PFALLOC PLPAGE PMPAGE NEXT NPMPAGE) (COND ((EQ (\GETACCESS STREAM) 'INPUT) (RETURN))) [\PFLOPPY.TRUNCATEFILE STREAM [COND ((NOT LASTFLOPPYFLG) \HFLOPPY.MAXPAGES) (T (IDIFFERENCE (fetch (STREAM EPAGE) of STREAM) (ITIMES \HFLOPPY.MAXPAGES (SUB1 \SFLOPPY.FLOPPYNO ] (COND ((NOT LASTFLOPPYFLG) 0) (T (fetch (STREAM EOFFSET) of STREAM] (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (SETQ PLPAGE (fetch (PFALLOC PLPAGE) of PFALLOC)) (replace (PLPAGE IWRITEDATE) of PLPAGE with \SFLOPPY.IWRITEDATE) (replace (PLPAGE ICREATIONDATE) of PLPAGE with \SFLOPPY.IWRITEDATE) (replace (PLPAGE HUGEPAGESTART) of PLPAGE with (ITIMES \HFLOPPY.MAXPAGES (SUB1 \SFLOPPY.FLOPPYNO)) ) (replace (PLPAGE HUGEPAGELENGTH) of PLPAGE with \SFLOPPY.HUGEPAGELENGTH) (replace (PLPAGE HUGELENGTH) of PLPAGE with \SFLOPPY.HUGELENGTH) (\PFLOPPY.WRITEPAGENO (fetch (PFALLOC START) of PFALLOC) PLPAGE) (\PFLOPPY.SAVE.PFILELIST) (\PFLOPPY.SAVE.PSECTOR9]) (\SFLOPPY.HACK [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* kbr%: " 2-Dec-84 11:58") (COND ([AND (STKPOS '\COPYSYS) (NOT (EQ (FLOPPY.MODE) 'SYSOUT] (* Sysouting to {FLOPPY} *) (SETQ \SFLOPPY.HACK.MODE (FLOPPY.MODE 'SYSOUT)) (SETQ \SFLOPPY.HACK.STREAM (\SFLOPPY.OPENHUGEFILE FILE ACCESS RECOG OTHERINFO \FLOPPYFDEV OLDSTREAM)) \SFLOPPY.HACK.STREAM) (T (* The usual case is to return NIL  telling OPENFILE fn to proceed  normally *) NIL]) ) (* ; "`HUGE' *") (RPAQ? \HFLOPPYINFO NIL) (RPAQ? \HFLOPPYFDEV NIL) (RPAQ? \HFLOPPY.MAXPAGES NIL) (RPAQ? \HFLOPPY.PAGENO NIL) (RPAQ? \HFLOPPY.FLOPPYNO NIL) (RPAQ? \HFLOPPY.HUGELENGTH NIL) (RPAQ? \HFLOPPY.HUGEPAGELENGTH NIL) (RPAQ? \HFLOPPY.IWRITEDATE NIL) (RPAQ? \HFLOPPY.FLOPPYNAME NIL) (RPAQ? \HFLOPPY.FILENAME NIL) (RPAQ? \HFLOPPY.RECOG NIL) (RPAQ? \HFLOPPY.OTHERINFO NIL) (RPAQ? \HFLOPPY.SLOWFLG T) (DEFINEQ (\HFLOPPY.INIT [LAMBDA NIL (* hdj "24-Sep-86 10:54") (PROG NIL (SETQ \HFLOPPYINFO (create PFINFO)) (SETQ \HFLOPPYFDEV (create FDEV DEVICENAME _ 'FLOPPY NODIRECTORIES _ T CLOSEFILE _ (FUNCTION \HFLOPPY.CLOSEHUGEFILE) DELETEFILE _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION TRUE) EVENTFN _ (FUNCTION \FLOPPY.EVENTFN) GENERATEFILES _ (FUNCTION \PFLOPPY.GENERATEFILES) GETFILEINFO _ (FUNCTION \HFLOPPY.GETFILEINFO) GETFILENAME _ (FUNCTION \PFLOPPY.GETFILENAME) HOSTNAMEP _ (FUNCTION \FLOPPY.HOSTNAMEP) OPENFILE _ (FUNCTION \HFLOPPY.OPENHUGEFILE) READPAGES _ (FUNCTION \HFLOPPY.READPAGES) REOPENFILE _ (FUNCTION \HFLOPPY.OPENHUGEFILE) SETFILEINFO _ (FUNCTION NILL) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \HFLOPPY.WRITEPAGES) DEVICEINFO _ \HFLOPPYINFO RENAMEFILE _ (FUNCTION NILL) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) OPENP _ (FUNCTION \GENERIC.OPENP))) (\MAKE.PMAP.DEVICE \HFLOPPYFDEV]) (\HFLOPPY.GETFILEINFO [LAMBDA (FILE ATTRIBUTE FDEV) (* kbr%: "25-Nov-84 13:03") (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM PLPAGE ANSWER) (\FLOPPY.CACHED.READ) (SETQ STREAM (\PFLOPPY.ASSURESTREAM FILE)) (SETQ PLPAGE (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (* Wizard incantations%: PAGELENGTH,  HUGEPAGESTART, HUGEPAGELENGTH,  HUGELENGTH *) (SETQ ANSWER (SELECTQ ATTRIBUTE (WRITEDATE (fetch (PLPAGE WRITEDATE) of PLPAGE)) (CREATIONDATE (fetch (PLPAGE CREATIONDATE) of PLPAGE)) (IWRITEDATE (fetch (PLPAGE IWRITEDATE) of PLPAGE)) (ICREATIONDATE (fetch (PLPAGE ICREATIONDATE) of PLPAGE)) (LENGTH (* We want hugelength.  *) (fetch (PLPAGE HUGELENGTH) of PLPAGE)) (TYPE (fetch (PLPAGE TYPE) of PLPAGE)) (BYTESIZE 8) (MESATYPE (fetch (PLPAGE MESATYPE) of PLPAGE)) (PAGELENGTH (fetch (PLPAGE PAGELENGTH) of PLPAGE)) (HUGEPAGESTART (fetch (PLPAGE HUGEPAGESTART) of PLPAGE)) (HUGEPAGELENGTH (fetch (PLPAGE HUGEPAGELENGTH) of PLPAGE)) (HUGELENGTH (fetch (PLPAGE HUGELENGTH) of PLPAGE)) NIL)) (RETURN ANSWER)))]) (\HFLOPPY.OPENHUGEFILE [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* hdj "16-May-86 21:50") (* * if file is open in conflicting way, barf) (if (NOT (\FILE-CONFLICT FILE ACCESS FDEV)) then (OR (\SFLOPPY.HACK FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (WITH.MONITOR \FLOPPYLOCK (PROG (STREAM) RETRY (SELECTQ ACCESS (OUTPUT (SELECTQ RECOG (NEW (* OK. *)) (PROGN (SETQ RECOG (LISPERROR "ILLEGAL ARG" RECOG)) (GO RETRY)))) (INPUT (SELECTQ RECOG (OLD (* OK. *)) (PROGN (SETQ RECOG (LISPERROR "ILLEGAL ARG" RECOG)) (GO RETRY)))) (PROGN (SETQ ACCESS (LISPERROR "ILLEGAL ARG" ACCESS)) (GO RETRY))) (SETQ \HFLOPPY.FILENAME (\FLOPPY.ASSUREFILENAME FILE)) (SETQ \HFLOPPY.FLOPPYNAME \HFLOPPY.FILENAME) (SETQ \HFLOPPY.RECOG RECOG) (SETQ \HFLOPPY.OTHERINFO (\FLOPPY.OTHERINFO OTHERINFO)) [COND ((EQ RECOG 'NEW) (SETQ \HFLOPPY.IWRITEDATE (IDATE)) (SETQ \HFLOPPY.HUGELENGTH (CDR (ASSOC 'LENGTH \HFLOPPY.OTHERINFO)) ) (COND ((NULL \HFLOPPY.HUGELENGTH) (\FLOPPY.MESSAGE "Can't open file without LENGTH parameter in HUGE mode." T) (LISPERROR "FILE WON'T OPEN" ""))) (SETQ \HFLOPPY.HUGEPAGELENGTH (IQUOTIENT (IPLUS \HFLOPPY.HUGELENGTH 511) 512)) (printout T (IQUOTIENT (IPLUS \HFLOPPY.HUGEPAGELENGTH \HFLOPPY.MAXPAGES -1) \HFLOPPY.MAXPAGES) " floppies will be required." T) (RPLACD (OR (ASSOC 'LENGTH \HFLOPPY.OTHERINFO) (PROGN (push \HFLOPPY.OTHERINFO (LIST 'LENGTH)) (CAR \HFLOPPY.OTHERINFO))) (ITIMES \HFLOPPY.MAXPAGES 512)) (SETQ STREAM (\HFLOPPY.OUTPUTFLOPPY \HFLOPPY.FLOPPYNAME \HFLOPPY.FILENAME \HFLOPPY.OTHERINFO))) (T (SETQ STREAM (\HFLOPPY.INPUTFLOPPY \HFLOPPY.FLOPPYNAME \HFLOPPY.FILENAME \HFLOPPY.OTHERINFO] (RETURN STREAM)))]) (\HFLOPPY.WRITEPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* kbr%: "26-Aug-84 11:19") (PROG NIL (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\HFLOPPY.WRITEPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\HFLOPPY.WRITEPAGE [LAMBDA (STREAM FIRSTPAGE# BUFFER) (* kbr%: "26-Aug-84 11:20") (WITH.MONITOR \FLOPPYLOCK (PROG (NEWSTREAM) [COND ((IGEQ \HFLOPPY.PAGENO \HFLOPPY.MAXPAGES) (\HFLOPPY.CLOSEFLOPPY STREAM) (RINGBELLS) [RPLACD (OR (ASSOC 'LENGTH \HFLOPPY.OTHERINFO) (PROGN (push \HFLOPPY.OTHERINFO (LIST 'LENGTH)) (CAR \HFLOPPY.OTHERINFO))) (IMIN (ITIMES \HFLOPPY.MAXPAGES 512) (IDIFFERENCE \HFLOPPY.HUGELENGTH (ITIMES \HFLOPPY.FLOPPYNO \HFLOPPY.MAXPAGES 512] (SETQ STREAM (\HFLOPPY.OUTPUTFLOPPY \HFLOPPY.FLOPPYNAME \HFLOPPY.FILENAME \HFLOPPY.OTHERINFO STREAM] (* Write page \HFLOPPY.PAGENO.  *) (GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (\BLT \FLOPPY.SCRATCH.BUFFER BUFFER 256) (\PFLOPPY.WRITEPAGE STREAM \HFLOPPY.PAGENO \FLOPPY.SCRATCH.BUFFER)) (SETQ \HFLOPPY.PAGENO (ADD1 \HFLOPPY.PAGENO))))]) (\HFLOPPY.READPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* kbr%: "26-Aug-84 11:20") (PROG NIL (COND ((EQ \HFLOPPY.RECOG 'NEW) (RETURN))) (for BUFFER in (MKLIST BUFFERS) as I from 0 do (\HFLOPPY.READPAGE STREAM (IPLUS FIRSTPAGE# I) BUFFER]) (\HFLOPPY.READPAGE [LAMBDA (STREAM FIRSTPAGE# BUFFER) (* bvm%: "22-Nov-85 00:21") (WITH.MONITOR \FLOPPYLOCK (PROG (NEWSTREAM) [COND ((IGEQ \HFLOPPY.PAGENO \HFLOPPY.PAGES) (\HFLOPPY.CLOSEFLOPPY STREAM) (RINGBELLS) (SETQ STREAM (\HFLOPPY.INPUTFLOPPY \HFLOPPY.FLOPPYNAME \HFLOPPY.FILENAME \HFLOPPY.OTHERINFO STREAM] (* Read page \HFLOPPY.PAGENO.  *) (\PFLOPPY.READPAGE STREAM \HFLOPPY.PAGENO BUFFER) (SETQ \HFLOPPY.PAGENO (ADD1 \HFLOPPY.PAGENO))))]) (\HFLOPPY.CLOSEHUGEFILE [LAMBDA (STREAM) (* hdj "24-Sep-86 10:34") (WITH.MONITOR \FLOPPYLOCK (PROG (FULLFILENAME) (COND ((EQ \HFLOPPY.RECOG 'OLD) (RETURN))) (\CLEARMAP STREAM) (* ;; "Following 2 SETQ's patch around SYSOUT not passing us right HUGELENGTH in orignal OTHERINFO. I think this may be fixed now. *") (SETQ \HFLOPPY.HUGELENGTH (IPLUS (ITIMES 512 (fetch (STREAM EPAGE) of STREAM)) (fetch (STREAM EOFFSET) of STREAM))) (SETQ \HFLOPPY.HUGEPAGELENGTH (IQUOTIENT (IPLUS \HFLOPPY.HUGELENGTH 511) 512)) (SETQ FULLFILENAME (\HFLOPPY.CLOSEFLOPPY STREAM T)) (RETURN FULLFILENAME)))]) (\HFLOPPY.INPUTFLOPPY [LAMBDA (FLOPPYNAME FILENAME OTHERINFO OLDSTREAM) (* kbr%: " 5-Aug-86 16:26") (PROG (FLOPPYNAME#I STREAM) [COND ((NULL OLDSTREAM) (SETQ \HFLOPPY.FLOPPYNO 1)) (T (SETQ \HFLOPPY.FLOPPYNO (ADD1 \HFLOPPY.FLOPPYNO] (SETQ FLOPPYNAME#I (CONCAT FLOPPYNAME "#" \HFLOPPY.FLOPPYNO)) (COND ((OR (IGREATERP \HFLOPPY.FLOPPYNO 1) (NOT (\FLOPPY.UNCACHED.READ T))) (printout T "Insert floppy " FLOPPYNAME#I T) (FLOPPY.WAIT.FOR.FLOPPY T))) (SETQ STREAM (\PFLOPPY.OPENFILE FILENAME 'INPUT 'OLD OTHERINFO \FLOPPYFDEV)) (SETQ \HFLOPPY.PAGENO 0) (COND ((NULL OLDSTREAM) (SETQ \HFLOPPY.HUGELENGTH (fetch (PLPAGE HUGELENGTH) of (fetch ( FLOPPYSTREAM PLPAGE) of STREAM))) (SETQ \HFLOPPY.HUGEPAGELENGTH (fetch (PLPAGE HUGEPAGELENGTH) of (fetch (FLOPPYSTREAM PLPAGE) of STREAM) )) (replace (STREAM EPAGE) of STREAM with (IQUOTIENT \HFLOPPY.HUGELENGTH 512)) (replace (STREAM EOFFSET) of STREAM with (IREMAINDER \HFLOPPY.HUGELENGTH 512))) (T (replace (FLOPPYSTREAM PFALLOC) of OLDSTREAM with (fetch ( FLOPPYSTREAM PFALLOC) of STREAM)) (replace (FLOPPYSTREAM PLPAGE) of OLDSTREAM with (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (SETQ STREAM OLDSTREAM))) (SETQ \HFLOPPY.PAGES (fetch (PLPAGE PAGELENGTH) of (fetch (FLOPPYSTREAM PLPAGE) of STREAM))) (RETURN STREAM]) (\HFLOPPY.OUTPUTFLOPPY [LAMBDA (FLOPPYNAME FILENAME OTHERINFO OLDSTREAM) (* ; "Edited 25-Mar-87 15:24 by jds") (* ;; "Set up FLOPPYNAME for output to FILENAME??") (PROG (FLOPPYNAME#I STREAM) [COND ((NULL OLDSTREAM) (SETQ \HFLOPPY.FLOPPYNO 1)) (T (SETQ \HFLOPPY.FLOPPYNO (ADD1 \HFLOPPY.FLOPPYNO] (SETQ FLOPPYNAME#I (CONCAT FLOPPYNAME "#" \HFLOPPY.FLOPPYNO)) (COND ((AND (IEQP \HFLOPPY.FLOPPYNO 1) (\FLOPPY.UNCACHED.READ T)) (* ;  "Don't prompt if first floppy already ready for us. *") (GO FORMAT))) RETRY (printout T "Insert floppy to become " FLOPPYNAME#I T) (FLOPPY.WAIT.FOR.FLOPPY T) FORMAT (COND ((NOT (\FLOPPY.UNCACHED.WRITE T)) (printout T "Can't proceed. This floppy is writeprotected." T) (GO RETRY)) ((NOT (\PFLOPPY.FORMAT FLOPPYNAME#I NIL \HFLOPPY.SLOWFLG)) (* ; "Didn't format *") (GO RETRY))) (SETQ STREAM (\PFLOPPY.OPENFILE FILENAME 'OUTPUT 'NEW OTHERINFO \FLOPPYFDEV OLDSTREAM)) (SETQ \HFLOPPY.PAGENO 0) (SETQ \HFLOPPY.PAGES (IQUOTIENT (IPLUS (CDR (ASSOC 'LENGTH OTHERINFO)) 511) 512)) (COND (OLDSTREAM (replace (FLOPPYSTREAM PFALLOC) of OLDSTREAM with (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (replace (FLOPPYSTREAM PLPAGE) of OLDSTREAM with (fetch (FLOPPYSTREAM PLPAGE) of STREAM)) (SETQ STREAM OLDSTREAM))) (RETURN STREAM]) (\HFLOPPY.CLOSEFLOPPY [LAMBDA (STREAM LASTFLOPPYFLG) (* kbr%: "25-Feb-85 12:23") (* The same as \PFLOPPY.CLOSEFILE  but without releasing STREAM.  Called only by \HFLOPPY.WRITEPAGE.  *) (PROG (PFALLOC PLPAGE PMPAGE NEXT NPMPAGE) (COND ((EQ (\GETACCESS STREAM) 'INPUT) (RETURN))) (* At this point \HFLOPPY.PAGENO is  the next page we would write.  *) [\PFLOPPY.TRUNCATEFILE STREAM [COND ((NOT LASTFLOPPYFLG) \HFLOPPY.MAXPAGES) (T (IDIFFERENCE (fetch (STREAM EPAGE) of STREAM) (ITIMES \HFLOPPY.MAXPAGES (SUB1 \HFLOPPY.FLOPPYNO ] (COND ((NOT LASTFLOPPYFLG) 0) (T (fetch (STREAM EOFFSET) of STREAM] (SETQ PFALLOC (fetch (FLOPPYSTREAM PFALLOC) of STREAM)) (SETQ PLPAGE (fetch (PFALLOC PLPAGE) of PFALLOC)) (replace (PLPAGE IWRITEDATE) of PLPAGE with \HFLOPPY.IWRITEDATE) (replace (PLPAGE ICREATIONDATE) of PLPAGE with \HFLOPPY.IWRITEDATE) (replace (PLPAGE HUGEPAGESTART) of PLPAGE with (ITIMES \HFLOPPY.MAXPAGES (SUB1 \HFLOPPY.FLOPPYNO)) ) (replace (PLPAGE HUGEPAGELENGTH) of PLPAGE with \HFLOPPY.HUGEPAGELENGTH) (replace (PLPAGE HUGELENGTH) of PLPAGE with \HFLOPPY.HUGELENGTH) (\PFLOPPY.WRITEPAGENO (fetch (PFALLOC START) of PFALLOC) PLPAGE) (\PFLOPPY.SAVE.PFILELIST) (\PFLOPPY.SAVE.PSECTOR9]) ) (* ; "`SCAVENGE' *") (RPAQ? \FLOPPY.SCAVENGE.IDATE NIL) (DEFINEQ (FLOPPY.SCAVENGE [LAMBDA NIL (* kbr%: "22-Jul-84 22:40") (SETQ \FLOPPY.SCAVENGE.IDATE (IDATE)) (\PFLOPPY.SCAVENGE]) (\PFLOPPY.SCAVENGE [LAMBDA NIL (* kbr%: "22-Jul-84 22:40") (PROG NIL (\FLOPPY.UNCACHED.WRITE) (COND ((NOT (\PFLOPPY.CONFIRM "Scavenge contents of floppy")) (RETURN NIL))) (\FLOPPY.CLOSE) (\PFLOPPY.SCAVENGE.PMPAGES) (\PFLOPPY.SCAVENGE.PLPAGES) (\FLOPPY.CACHED.WRITE) (\PFLOPPY.SCAVENGE.PSECTOR9) (\PFLOPPY.SCAVENGE.PFILELIST) (RETURN T]) (\PFLOPPY.SCAVENGE.PMPAGES [LAMBDA NIL (* kbr%: " 2-Sep-85 21:37") (* Scavenge the marker pages.  *) (PROG (LOCATION PMPAGE NPMPAGE) (SETQ LOCATION \PFLOPPYFIRSTDATAPAGE) (SETQ PMPAGE (\PFLOPPY.SCAVENGE.PMPAGEA)) (while (ILESSP LOCATION \PFLOPPYLASTDATAPAGE) do (SETQ NPMPAGE (  \PFLOPPY.SCAVENGE.PMPAGE.AFTER PMPAGE LOCATION)) (SETQ LOCATION (IPLUS LOCATION (fetch (PMPAGE NLENGTH) of PMPAGE) 1)) (SETQ PMPAGE NPMPAGE)) (\PFLOPPY.WRITEPAGENO \PFLOPPYLASTDATAPAGE PMPAGE]) (\PFLOPPY.SCAVENGE.PMPAGEA [LAMBDA NIL (* kbr%: "11-Sep-85 17:24") (PROG (PMPAGE) (* Try to believe marker page A *) (SETQ PMPAGE (NCREATE 'PMPAGE)) RETRY (COND ((NOT (\PFLOPPY.READPAGENO \PFLOPPYFIRSTDATAPAGE PMPAGE T)) (* Couldn't read this LOCATION.  Assume misformatted track.  *) (GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD512.FLOPPYIOCB (\PFLOPPY.PAGENOTODISKADDRESS LOCATION) 1 T)) (GO RETRY))) (replace (PMPAGE SEAL) of PMPAGE with SEAL.PMPAGE) (replace (PMPAGE VERSION) of PMPAGE with VERSION.PMPAGE) (replace (PMPAGE PLENGTH) of PMPAGE with 0) (replace (PMPAGE PTYPE) of PMPAGE with PMPAGEETYPE.FREE) (replace (PMPAGE PFILETYPE) of PMPAGE with FILETYPE.FREE) (replace (PMPAGE PFILEID) of PMPAGE with 0) (RETURN PMPAGE]) (\PFLOPPY.SCAVENGE.PMPAGE.AFTER [LAMBDA (PPMPAGE PLOCATION) (* kbr%: " 2-Sep-85 23:30") (* Come up with a plausible PMPAGE between  (ADD1 PLOCATION) and \PFLOPPYLASTDATAPAGE inclusive where PPMPAGE at PLOCATION  is the preceding marker page. *) (PROG (PMPAGE LOCATION) (SETQ PMPAGE (NCREATE 'PMPAGE)) (* Hunt for first plausible PMPAGE after PPMPAGE.  Smash PMPAGE into correctness and make PPMPAGE tell the new truth.  *) [for LOCATION from (ADD1 PLOCATION) to \PFLOPPYLASTDATAPAGE do (PRIN1 "." T) (COND ((EQ (IMOD LOCATION 20) 0) (PRIN1 LOCATION T))) (\PFLOPPY.SCAVENGE.PMPAGE.AFTER1 PLOCATION PPMPAGE LOCATION PMPAGE) (COND ((fetch (PMPAGE INTACT) of PMPAGE) (RETURN] (RETURN PMPAGE]) (\PFLOPPY.SCAVENGE.PMPAGE.AFTER1 [LAMBDA (PLOCATION PPMPAGE LOCATION PMPAGE) (* edited%: "23-Mar-86 20:05") (PROG (TRIEDWRITING TRIEDFORMATTING OLDPAGES LENGTH TYPE FILETYPE FILEID) RETRY [COND ((NOT (\PFLOPPY.READPAGENO LOCATION PMPAGE T)) (* Couldn't read this LOCATION.  Assume misformatted track.  *) (COND ((NOT TRIEDWRITING) (for I from 0 to 511 do (\PUTBASEBYTE PMPAGE I (CHARCODE " "))) (\PFLOPPY.WRITEPAGENO LOCATION PMPAGE T) (SETQ TRIEDWRITING T) (GO RETRY)) ((NOT TRIEDFORMATTING) (GLOBALRESOURCE \FLOPPY.IBMD512.FLOPPYIOCB (SETQ DISKADDRESS (  \PFLOPPY.PAGENOTODISKADDRESS LOCATION)) [SETQ OLDPAGES (for SECTOR from 1 to \FLOPPY.SECTORSPERTRACK collect (PROG (OLDPAGE) (SETQ OLDPAGE (NCREATE 'VMEMPAGEP)) (\FLOPPY.READSECTOR \FLOPPY.IBMD512.FLOPPYIOCB (create DISKADDRESS CYLINDER _ (fetch (DISKADDRESS CYLINDER) of DISKADDRESS ) HEAD _ (fetch (DISKADDRESS HEAD) of DISKADDRESS) SECTOR _ SECTOR) OLDPAGE T) (RETURN OLDPAGE] (* Since formatting is unreliable,  repeat format twice in a row.  *) (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD512.FLOPPYIOCB DISKADDRESS 1 T) (\FLOPPY.FORMATTRACKS \FLOPPY.IBMD512.FLOPPYIOCB DISKADDRESS 1 T) (* Restore what we could salvage  before reformatting.  *) (for SECTOR from 1 to \FLOPPY.SECTORSPERTRACK as OLDPAGE in OLDPAGES do (\FLOPPY.WRITESECTOR \FLOPPY.IBMD512.FLOPPYIOCB (create DISKADDRESS CYLINDER _ (fetch (DISKADDRESS CYLINDER) of DISKADDRESS) HEAD _ (fetch (DISKADDRESS HEAD) of DISKADDRESS) SECTOR _ SECTOR) OLDPAGE T))) (SETQ TRIEDFORMATTING T) (GO RETRY)) (T (\FLOPPY.MESSAGE (CONCAT "Couldn't read or reformat page " LOCATION)) (\FLOPPY.MESSAGE "User should not trust this floppy.") (* At this point PMPAGE is blank.  *) (RETURN PMPAGE] (COND ((NOT (OR (fetch (PMPAGE INTACT) of PMPAGE) (IEQP LOCATION \PFLOPPYLASTDATAPAGE))) (RETURN))) (* Force PMPAGE to be a legal marker  page. *) (replace (PMPAGE SEAL) of PMPAGE with SEAL.PMPAGE) (replace (PMPAGE VERSION) of PMPAGE with VERSION.PMPAGE) (SETQ LENGTH (IPLUS LOCATION (IMINUS PLOCATION) -1)) [COND ((ZEROP LENGTH) (SETQ TYPE PMPAGEETYPE.FREE) (SETQ FILETYPE FILETYPE.FREE) (SETQ FILEID 0)) (T (SETQ TYPE (fetch (PMPAGE NTYPE) of PPMPAGE)) (SETQ FILETYPE (fetch (PMPAGE NFILETYPE) of PPMPAGE)) (SETQ FILEID (COND ((EQ TYPE PMPAGEETYPE.PFILELIST) 1) (T 0] (replace (PMPAGE PLENGTH) of PMPAGE with LENGTH) (replace (PMPAGE PTYPE) of PMPAGE with TYPE) (replace (PMPAGE PFILETYPE) of PMPAGE with FILETYPE) (replace (PMPAGE PFILEID) of PMPAGE with FILEID) (* Fix PPMPAGE wrt PMPAGE now *) (replace (PMPAGE NLENGTH) of PPMPAGE with LENGTH) (replace (PMPAGE NTYPE) of PPMPAGE with TYPE) (replace (PMPAGE NFILETYPE) of PPMPAGE with FILETYPE) (replace (PMPAGE NFILEID) of PPMPAGE with FILEID) (\PFLOPPY.WRITEPAGENO PLOCATION PPMPAGE]) (\PFLOPPY.SCAVENGE.PLPAGES [LAMBDA NIL (* kbr%: " 8-Nov-85 11:16") (* Scavenge the leader pages.  *) (PROG (LOCATION NLOCATION PMPAGE NPMPAGE PLPAGE LENGTH START) (SETQ LOCATION \PFLOPPYFIRSTDATAPAGE) (SETQ PMPAGE (NCREATE 'PMPAGE)) (SETQ NPMPAGE (NCREATE 'PMPAGE)) (SETQ PLPAGE (create PLPAGE)) (\PFLOPPY.READPAGENO \PFLOPPYFIRSTDATAPAGE NPMPAGE) (while (ILESSP LOCATION \PFLOPPYLASTDATAPAGE) do (swap PMPAGE NPMPAGE) (SETQ LENGTH (SUB1 (fetch (PMPAGE NLENGTH) of PMPAGE))) (SETQ NLOCATION (IPLUS LOCATION (ADD1 LENGTH) 1)) (\PFLOPPY.READPAGENO NLOCATION NPMPAGE) (COND ((AND (IGEQ LENGTH 0) (OR (IEQP (fetch (PMPAGE NTYPE) of PMPAGE) PMPAGEETYPE.FILE) (IEQP (fetch (PMPAGE NTYPE) of PMPAGE) PMPAGEETYPE.FREE))) (SETQ START (ADD1 LOCATION)) (\PFLOPPY.READPAGENO START PLPAGE) [COND [(for I from 0 to 511 always (EQ (\GETBASEBYTE PLPAGE I) (SELECTQ (MACHINETYPE) (DANDELION (CHARCODE @)) (DOVE 255) NIL))) (* Looks like we haven't written on this page since it was formatted.  Assume we are looking at a free block. *) (COND ((IEQP (fetch (PMPAGE NTYPE) of PMPAGE) PMPAGEETYPE.FILE) (* Become a FREE block.  *) (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FREE) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FREE) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FREE) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FREE) (\PFLOPPY.WRITEPAGENO LOCATION PMPAGE) (\PFLOPPY.WRITEPAGENO NLOCATION NPMPAGE] (T (* Assume there is a whole file or a  partial file to be recovered.  *) [COND ((fetch (PLPAGE INTACT) of PLPAGE) (* Proper beginning of a whole or  truncated file. *) [replace (PLPAGE HUGELENGTH) of PLPAGE with (COND ((EQ (FOLDHI (fetch (PLPAGE HUGELENGTH) of PLPAGE) 512) LENGTH) (* What we expect.  Treat extra bytes on last page as  true garbage. *) (fetch (PLPAGE HUGELENGTH) of PLPAGE)) (T (* Either HUGELENGTH is too big or too small for the number of pages allotted,  so make HUGELENGTH 512 x pages allotted.  *) (ITIMES LENGTH 512] (replace (PLPAGE PAGELENGTH) of PLPAGE with LENGTH) (replace (PLPAGE HUGEPAGESTART) of PLPAGE with 0) (replace (PLPAGE HUGEPAGELENGTH) of PLPAGE with LENGTH)) (T (* Front end of file gone.  *) (replace (PLPAGE \CREATIONDATE) of PLPAGE with \FLOPPY.SCAVENGE.IDATE ) (replace (PLPAGE \WRITEDATE) of PLPAGE with \FLOPPY.SCAVENGE.IDATE ) (replace (PLPAGE HUGELENGTH) of PLPAGE with (ITIMES LENGTH 512)) (replace (PLPAGE PAGELENGTH) of PLPAGE with LENGTH) (replace (PLPAGE HUGEPAGESTART) of PLPAGE with 0) (replace (PLPAGE HUGEPAGELENGTH) of PLPAGE with LENGTH ) (replace (PLPAGE $NAME) of PLPAGE with (GENSYM 'OLDFILE] (replace (PLPAGE SEAL) of PLPAGE with SEAL.PLPAGE) (replace (PLPAGE VERSION) of PLPAGE with VERSION.PLPAGE) (replace (PLPAGE MESATYPE) of PLPAGE with 65535) (replace (PLPAGE NAMEMAXLENGTH) of PLPAGE with NAMEMAXLENGTH.PLPAGE ) (replace (PLPAGE UFO1) of PLPAGE with 2) (replace (PLPAGE UFO2) of PLPAGE with 187) (replace (PLPAGE DATAVERSION) of PLPAGE with VERSION.DATA) (replace (PLPAGE \TYPE) of PLPAGE with 1) (COND ((IEQP (fetch (PMPAGE NTYPE) of PMPAGE) PMPAGEETYPE.FREE) (* Become a FILE block.  *) (replace (PMPAGE NTYPE) of PMPAGE with PMPAGEETYPE.FILE) (replace (PMPAGE NFILETYPE) of PMPAGE with FILETYPE.FILE ) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FILE ) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FILE) (\PFLOPPY.WRITEPAGENO LOCATION PMPAGE) (\PFLOPPY.WRITEPAGENO NLOCATION NPMPAGE] (\PFLOPPY.WRITEPAGENO START PLPAGE))) (SETQ LOCATION NLOCATION]) (\PFLOPPY.SCAVENGE.PSECTOR9 [LAMBDA NIL (* kbr%: " 7-Aug-85 19:27") (PROG (PSECTOR9 PFALLOC) (SETQ PSECTOR9 (fetch (PFLOPPYFDEV PSECTOR9) of \FLOPPYFDEV)) (replace (PSECTOR9 SEAL) of PSECTOR9 with SEAL.PSECTOR9) (replace (PSECTOR9 VERSION) of PSECTOR9 with VERSION.PSECTOR9) (replace (PSECTOR9 CYLINDERS) of PSECTOR9 with \FLOPPY.CYLINDERS) (replace (PSECTOR9 TRACKSPERCYLINDER) of PSECTOR9 with \FLOPPY.TRACKSPERCYLINDER) (replace (PSECTOR9 SECTORSPERTRACK) of PSECTOR9 with \FLOPPY.SECTORSPERTRACK) [SETQ PFALLOC (for P in (fetch (PFLOPPYFDEV PFALLOCS) of \FLOPPYFDEV) thereis (EQUAL (fetch (PFALLOC FILENAME) of P) '(PFILELIST] (COND ((NULL PFALLOC) (\FLOPPY.BREAK "Can't find PFILELIST"))) (replace (PSECTOR9 PFILELISTSTART) of PSECTOR9 with (fetch (PFALLOC START) of PFALLOC)) (replace (PSECTOR9 PFILELISTFILEID) of PSECTOR9 with 1) (replace (PSECTOR9 PFILELISTLENGTH) of PSECTOR9 with (fetch (PFALLOC LENGTH ) of PFALLOC)) (replace (PSECTOR9 ROOTFILEID) of PSECTOR9 with 0) (replace (PSECTOR9 PILOTMICROCODE) of PSECTOR9 with 0) (replace (PSECTOR9 DIAGNOSTICMICROCODE) of PSECTOR9 with 0) (replace (PSECTOR9 GERM) of PSECTOR9 with 0) (replace (PSECTOR9 PILOTBOOTFILE) of PSECTOR9 with 0) (replace (PSECTOR9 FIRSTALTERNATESECTOR) of PSECTOR9 with 0) (replace (PSECTOR9 COUNTBADSECTORS) of PSECTOR9 with 0) (replace (PSECTOR9 CHANGING) of PSECTOR9 with 0) (replace (PSECTOR9 \LABELLENGTH) of PSECTOR9 with (IMIN (fetch (PSECTOR9 \LABELLENGTH ) of PSECTOR9) 20)) (\PFLOPPY.SAVE.PSECTOR9]) (\PFLOPPY.SCAVENGE.PFILELIST [LAMBDA NIL (* kbr%: "22-Jul-84 22:40") (PROG (PFILELIST) (SETQ PFILELIST (fetch (PFLOPPYFDEV PFILELIST) of \FLOPPYFDEV)) (COND ((ILEQ (fetch (PFILELIST NENTRIES) of PFILELIST) 49) (replace (PFILELIST MAXENTRIES) of PFILELIST with 49))) (\PFLOPPY.SAVE.PFILELIST]) ) (* ; "`COPY' *") (DEFINEQ (FLOPPY.TO.FILE [LAMBDA (TOFILE) (* ; "Edited 20-Aug-87 16:45 by jds") (* ;; "Copy the contents of a whole floppy disk to a single file, TOFILE.") (WITH.MONITOR \FLOPPYLOCK (PROG (TOSTREAM PSECTOR9) (while (NOT (\FLOPPY.UNCACHED.READ)) DO (BLOCK)) [SETQ TOSTREAM (OPENSTREAM TOFILE 'OUTPUT 'NEW NIL (LIST '(TYPE BINARY) (LIST 'LENGTH (ITIMES (IPLUS 1 1 (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK (SUB1 \FLOPPY.CYLINDERS ))) 512] (* ; "First page. *") (PRIN1 "PILOT" TOSTREAM) (for I from 6 to 512 do (\BOUT TOSTREAM 0)) (* ; "PSECTOR9 page. *") (GLOBALRESOURCE (\FLOPPY.SCRATCH.BUFFER \FLOPPY.IBMS128.FLOPPYIOCB) (\FLOPPY.READSECTOR \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 9) \FLOPPY.SCRATCH.BUFFER) (\BOUTS TOSTREAM \FLOPPY.SCRATCH.BUFFER 0 512)) (* ; "Remaining pages. *") (GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (for I from \PFLOPPYFIRSTDATAPAGE to \PFLOPPYLASTDATAPAGE do (\PFLOPPY.READPAGENO I \FLOPPY.SCRATCH.BUFFER) (\BOUTS TOSTREAM \FLOPPY.SCRATCH.BUFFER 0 512))) (CLOSEF TOSTREAM)))]) (FLOPPY.FROM.FILE [LAMBDA (FROMFILE) (* edited%: "12-Dec-85 16:54") (WITH.MONITOR \FLOPPYLOCK (PROG (FROMSTREAM PSECTOR9) (SETQ FROMSTREAM (OPENSTREAM FROMFILE 'INPUT 'OLD)) (* GODDAMN FILEIO *) (SETFILEPTR FROMSTREAM 0) RETRY (COND ((NOT (IEQP (GETFILEINFO FROMSTREAM 'LENGTH) (ITIMES (IPLUS 1 1 (ITIMES \FLOPPY.TRACKSPERCYLINDER \FLOPPY.SECTORSPERTRACK (SUB1 \FLOPPY.CYLINDERS ))) 512))) (\FLOPPY.BREAK "Wrong length form FROMFILE") (GO RETRY))) (COND ((NOT (\FLOPPY.UNCACHED.WRITE)) (GO RETRY))) (COND ((NOT (\PFLOPPY.FORMAT)) (GO RETRY))) (* Throw away first page.  *) (for I from 1 to 512 do (\BIN FROMSTREAM)) (* PSECTOR9 page. *) (GLOBALRESOURCE (\FLOPPY.SCRATCH.BUFFER \FLOPPY.IBMS128.FLOPPYIOCB) (\BINS FROMSTREAM \FLOPPY.SCRATCH.BUFFER 0 512) (\FLOPPY.WRITESECTOR \FLOPPY.IBMS128.FLOPPYIOCB (create DISKADDRESS CYLINDER _ 0 HEAD _ 0 SECTOR _ 9) \FLOPPY.SCRATCH.BUFFER)) (* Remaining pages.  *) (GLOBALRESOURCE \FLOPPY.SCRATCH.BUFFER (for I from \PFLOPPYFIRSTDATAPAGE to \PFLOPPYLASTDATAPAGE do (\BINS FROMSTREAM \FLOPPY.SCRATCH.BUFFER 0 512) (\PFLOPPY.WRITEPAGENO I \FLOPPY.SCRATCH.BUFFER))) (CLOSEF FROMSTREAM)))]) ) (* ; "`COMPACT' *") (DEFINEQ (FLOPPY.COMPACT [LAMBDA NIL (* ; "Edited 15-Aug-88 09:48 by jds") (WITH.MONITOR \FLOPPYLOCK (SELECTQ (FLOPPY.MODE) ((PILOT HUGEPILOT SYSOUT) (\PFLOPPY.COMPACT)) (CPM (* ;  "Do nothing for CPM floppies, no longer supported.") NIL) (SHOULDNT)))]) (\PFLOPPY.COMPACT [LAMBDA NIL (* ; "Edited 15-Aug-88 11:51 by jds") (WITH.MONITOR \FLOPPYLOCK (* ;; "COMPACT scattered free blocks into large free block at end of floppy. ") (PROG (PFINFO PFALLOCS) (\FLOPPY.CACHED.WRITE) (* ; "Confirmation. ") (COND ((NOT (\PFLOPPY.CONFIRM "COMPACT contents of floppy" NIL T 20)) (RETURN NIL))) (* ;  "Trivial case = floppy is already COMPACT. *") (SETQ PFINFO (fetch (FDEV DEVICEINFO) of \FLOPPYFDEV)) (SETQ PFALLOCS (fetch (PFINFO PFALLOCS) of PFINFO)) (SELECT [for PFALLOC in PFALLOCS count (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE] (1 (RETURN T)) [2 (COND ((EQUAL [fetch (PFALLOC FILENAME) of (fetch (PFALLOC PREV) of (CAR (LAST PFALLOCS ] '(FREE)) (RETURN T] (* ; "Need to COMPACT. *") ) (* ; "Nontrivial case. *") (\FLOPPY.MESSAGE "COMPACTing floppy") (\PFLOPPY.COMPACT.PFALLOCS) (\PFLOPPY.COMPACT.PSECTOR9) (\PFLOPPY.COMPACT.PFILELIST) (\FLOPPY.MESSAGE "Finished COMPACTing floppy") (RETURN T)))]) (\PFLOPPY.COMPACT.PFALLOCS [LAMBDA NIL (* kbr%: " 7-Aug-85 18:46") (PROG (PFINFO PREV NEXT NPMPAGE LAST) (SETQ PFINFO (fetch (FDEV DEVICEINFO) of \FLOPPYFDEV)) (* PREV = the last block moved. NEXT = block to be moved.  LAST = zero length final block. *) (* Skip blocks that don't need to be  moved. *) [SETQ LAST (CAR (LAST (fetch (PFINFO PFALLOCS) of PFINFO] (SETQ NEXT (CAR (fetch (PFINFO PFALLOCS) of PFINFO))) (while [NOT (EQUAL (fetch (PFALLOC FILENAME) of NEXT) '(FREE] do (SETQ NEXT (fetch (PFALLOC NEXT) of NEXT))) (SETQ PREV (fetch (PFALLOC PREV) of NEXT)) LOOP (* Get NEXT non free block.  *) (while [AND NEXT (EQUAL (fetch (PFALLOC FILENAME) of NEXT) '(FREE] do (SETQ NEXT (fetch (PFALLOC NEXT) of NEXT))) [COND ((NULL NEXT) (* No more non free blocks. PREV cannot be NIL at this point since every floppy  has a non free PFILELIST block. *) (COND ((ILESSP (fetch (PFALLOC END) of PREV) (SUB1 \PFLOPPYLASTDATAPAGE)) (* Create next to LAST free block.  *) (SETQ NPMPAGE (create PMPAGE SEAL _ SEAL.PMPAGE VERSION _ VERSION.PMPAGE PFILEID _ (fetch (PMPAGE NFILEID) of (fetch (PFALLOC PMPAGE) of PREV)) NLENGTH _ (IDIFFERENCE \PFLOPPYLASTDATAPAGE (IPLUS (fetch (PFALLOC END) of PREV) 2)) NTYPE _ PMPAGEETYPE.FREE NFILEID _ 0 NFILETYPE _ FILETYPE.FREE)) (SETQ NEXT (create PFALLOC FILENAME _ '(FREE) START _ (IPLUS (fetch (PFALLOC END) of PREV) 2) PMPAGE _ NPMPAGE NEXT _ LAST)) (replace (PFALLOC PREV) of LAST with NEXT)) ((IEQP (fetch (PFALLOC END) of PREV) (SUB1 \PFLOPPYLASTDATAPAGE)) (* Zero length LAST block.  *) (SETQ NEXT LAST)) ((IEQP (fetch (PFALLOC END) of PREV) \PFLOPPYLASTDATAPAGE) (* No more blocks.  *) (GO EXIT)) (T (SHOULDNT] (\PFLOPPY.COMPACT.PFALLOC PREV NEXT) (SETQ PREV NEXT) (SETQ NEXT (fetch (PFALLOC NEXT) of PREV)) (GO LOOP) EXIT (replace (PFINFO PFALLOCS) of PFINFO with (DREVERSE (for (PFALLOC _ LAST) by (fetch (PFALLOC PREV) of PFALLOC) while PFALLOC collect PFALLOC]) (\PFLOPPY.COMPACT.PFALLOC [LAMBDA (PREV NEXT) (* kbr%: " 1-Nov-85 17:21") (* Smash NEXT PFALLOC start location and fields on NPMPAGE between PREV and  NEXT. Write new NPMPAGE out to floppy. Move contents of NEXT block.  *) (PROG (NPMPAGE NSTART PPMPAGE) (SETQ NPMPAGE (fetch (PFALLOC PMPAGE) of NEXT)) (SETQ NSTART (fetch (PFALLOC START) of NEXT)) (replace (PFALLOC PREV) of NEXT with PREV) (COND (PREV (replace (PFALLOC NEXT) of PREV with NEXT) (replace (PFALLOC START) of NEXT with (IPLUS (fetch (PFALLOC END) of PREV) 2)) (SETQ PPMPAGE (fetch (PFALLOC PMPAGE) of PREV)) (replace (PMPAGE PLENGTH) of NPMPAGE with (fetch (PMPAGE NLENGTH) of PPMPAGE)) (replace (PMPAGE PFILEID) of NPMPAGE with (fetch (PMPAGE NFILEID) of PPMPAGE)) (replace (PMPAGE PTYPE) of NPMPAGE with (fetch (PMPAGE NTYPE) of PPMPAGE)) (replace (PMPAGE PFILETYPE) of NPMPAGE with (fetch (PMPAGE NFILETYPE ) of PPMPAGE))) (T (replace (PFALLOC START) of NEXT with (ADD1 \PFLOPPYFIRSTDATAPAGE)) (replace (PMPAGE PLENGTH) of NPMPAGE with 0) (replace (PMPAGE PFILEID) of NPMPAGE with 0) (replace (PMPAGE PTYPE) of NPMPAGE with PMPAGEETYPE.FREE) (replace (PMPAGE PFILETYPE) of NPMPAGE with FILETYPE.FREE))) [COND ((LITATOM (fetch (PFALLOC FILENAME) of NEXT)) (* Real file, not a file list or  free block. *) (replace (PFLE START) of (fetch (PFALLOC PFLE) of NEXT) with (fetch (PFALLOC START) of NEXT] (\PFLOPPY.WRITEPAGENO (SUB1 (fetch (PFALLOC START) of NEXT)) NPMPAGE) (COND ((EQUAL (fetch (PFALLOC FILENAME) of NEXT) '(FREE)) (RETURN))) (for I from 0 to (SUB1 (fetch (PFALLOC LENGTH) of NEXT)) do (\PFLOPPY.WRITEPAGENO (IPLUS (fetch (PFALLOC START) of NEXT) I) (\PFLOPPY.READPAGENO (IPLUS NSTART I) \FLOPPY.SCRATCH.BUFFER]) (\PFLOPPY.COMPACT.PSECTOR9 [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (PROG (PFINFO PSECTOR9) (SETQ PFINFO (fetch (FDEV DEVICEINFO) of \FLOPPYFDEV)) (SETQ PSECTOR9 (fetch (PFINFO PSECTOR9) of PFINFO)) [replace (PSECTOR9 PFILELISTSTART) of PSECTOR9 with (fetch (PFALLOC START) of (for PFALLOC in (fetch (PFINFO PFALLOCS) of PFINFO) thereis (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(PFILELIST] (\PFLOPPY.SAVE.PSECTOR9]) (\PFLOPPY.COMPACT.PFILELIST [LAMBDA NIL (* kbr%: "22-Jul-84 22:34") (PROG (PFINFO PFILELIST) (SETQ PFINFO (fetch (FDEV DEVICEINFO) of \FLOPPYFDEV)) (SETQ PFILELIST (fetch (PFINFO PFILELIST) of PFINFO)) (replace (PFILELIST NENTRIES) of PFILELIST with 0) (for PFALLOC in (fetch (PFINFO PFALLOCS) of PFINFO) when [NOT (EQUAL (fetch (PFALLOC FILENAME) of PFALLOC) '(FREE] do (\PFLOPPY.ADD.TO.PFILELIST PFALLOC)) (\PFLOPPY.SAVE.PFILELIST]) ) (* ; "`ARCHIVE' *") (DEFINEQ (FLOPPY.ARCHIVE [LAMBDA (FILES NAME) (* kbr%: "18-Jan-86 11:38") [COND ((LITATOM FILES) (* Assume FILES is a directory  pattern. *) (SETQ FILES (DIRECTORY FILES] [COND ((NULL NAME) (SETQ NAME 'ARCHIVE] (PROG (NAME#I FLOPPYFILE SIZE FILE) (for I from 1 while FILES do (SETQ NAME#I (CONCAT NAME '%# I)) (printout T "Insert floppy " NAME#I T) (FLOPPY.WAIT.FOR.FLOPPY (NOT (IEQP I 1))) (FLOPPY.FORMAT NAME#I NIL T) (while FILES do (SETQ FILE (CAR FILES)) (SETQ SIZE (GETFILEINFO FILE 'SIZE)) (COND ((ILESSP (FLOPPY.FREE.PAGES) (IPLUS SIZE 50)) (* Go to next floppy *) (RETURN))) (SETQ FLOPPYFILE (UNPACKFILENAME FILE)) (LISTPUT FLOPPYFILE 'HOST 'FLOPPY) (SETQ FLOPPYFILE (PACKFILENAME FLOPPYFILE)) (COPYFILE FILE FLOPPYFILE) (pop FILES]) (FLOPPY.UNARCHIVE [LAMBDA (HOST/DIRECTORY) (* kbr%: "18-Jan-86 11:50") (PROG (FLOPPYFILES NAME HOST DIRECTORY FILE) (SETQ HOST/DIRECTORY (UNPACKFILENAME HOST/DIRECTORY)) (SETQ HOST (LISTGET HOST/DIRECTORY 'HOST)) (SETQ DIRECTORY (LISTGET HOST/DIRECTORY 'DIRECTORY)) (FLOPPY.WAIT.FOR.FLOPPY) (SETQ NAME (FLOPPY.GET.NAME)) (printout T "Unarchiving floppy " NAME T) (SETQ FLOPPYFILES (DIRECTORY '{FLOPPY}*)) (for FLOPPYFILE in FLOPPYFILES do (SETQ FILE (UNPACKFILENAME FLOPPYFILE)) (LISTPUT FILE 'HOST HOST) (COND (DIRECTORY (LISTPUT FILE 'DIRECTORY DIRECTORY))) (SETQ FILE (PACKFILENAME FILE)) (COPYFILE FLOPPYFILE FILE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FLOPPY.DEBUG \FLOPPY.INSPECTW \FLOPPYFDEV \FLOPPYLOCK \FLOPPYIOCBADDR \FLOPPYIOCB \FLOPPYRESULT \FLOPPY.MODE.BEFORE.EVENT \PFLOPPYPSECTOR9 \PFLOPPYPFILELIST \PFLOPPYINFO \PFLOPPYFDEV \FLOPPY.ALLOCATIONS.BITMAP \SFLOPPYINFO \SFLOPPYFDEV \HFLOPPY.MAXPAGES \SFLOPPY.PAGENO \SFLOPPY.FLOPPYNO \SFLOPPY.HUGELENGTH \SFLOPPY.HUGEPAGELENGTH \SFLOPPY.IWRITEDATE \SFLOPPY.FILENAME \SFLOPPY.RECOG \SFLOPPY.FLOPPYNAME \SFLOPPY.SLOWFLG \HFLOPPYINFO \HFLOPPYFDEV \HFLOPPY.MAXPAGES \HFLOPPY.PAGENO \HFLOPPY.FLOPPYNO \HFLOPPY.HUGELENGTH \HFLOPPY.HUGEPAGELENGTH \HFLOPPY.IWRITEDATE \HFLOPPY.RECOG \HFLOPPY.FILENAME \HFLOPPY.SLOWFLG \FLOPPY.SCAVENGE.IDATE) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FLOPPY.RESTART) ) (PUTPROPS FLOPPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (90522 93853 (\FLOPPY.TRANSLATEFLOPPYRESULT 90532 . 91322) (\FLOPPY.SEVERE.ERROR 91324 . 91831) (\FLOPPY.TRANSLATEPMPAGEETYPE 91833 . 92154) (\FLOPPY.TRANSLATEFILETYPE 92156 . 92655) ( \FLOPPY.MTL.FIXP 92657 . 92948) (\FLOPPY.LTM.FIXP 92950 . 93241) (\FLOPPY.MTL.IDATE 93243 . 93546) ( \FLOPPY.LTM.IDATE 93548 . 93851)) (94590 132702 (\FLOPPY.TRANSLATESETUP 94600 . 94994) ( \FLOPPY.SETUP.IOCB 94996 . 97000) (\FLOPPY.CHECK.FLOPPYIOCB 97002 . 102161) (\FLOPPY.DENSITY 102163 . 102561) (\FLOPPY.SECTORLENGTH 102563 . 102909) (\FLOPPY.ENCODEDSECTORLENGTH 102911 . 103268) ( \FLOPPY.GAP3 103270 . 103605) (\FLOPPY.SECTORSPERTRACK 103607 . 103949) (\FLOPPY.RUN 103951 . 109612) (\FLOPPY.ERROR 109614 . 111089) (\FLOPPY.LOCK.BUFFER 111091 . 112476) (\FLOPPY.UNLOCK.BUFFER 112478 . 113022) (\FLOPPY.PREPAREFORCRASH 113024 . 113517) (\FLOPPY.COMMAND 113519 . 114400) ( \FLOPPY.INITIALIZE 114402 . 115326) (\FLOPPY.NOP 115328 . 115609) (\FLOPPY.RECALIBRATE 115611 . 116068 ) (\FLOPPY.RECOVER 116070 . 116371) (\FLOPPY.TRANSFER 116373 . 122027) (\FLOPPY.READSECTOR 122029 . 122215) (\FLOPPY.WRITESECTOR 122217 . 122405) (\FLOPPY.FORMATTRACKS 122407 . 125385) ( \FLOPPY.DISKCHANGECLEAR 125387 . 125696) (\FLOPPY.MOUNTEDP 125698 . 128015) (\FLOPPY.CAN.READP 128017 . 128215) (\FLOPPY.CAN.WRITEP 128217 . 128458) (\FLOPPY.WRITEABLEP 128460 . 129721) ( \FLOPPY.TWOSIDEDP 129723 . 130808) (\FLOPPY.DUMP 130810 . 131735) (\FLOPPY.DEBUG 131737 . 132700)) ( 135150 155332 (FLOPPY.RESTART 135160 . 136068) (FLOPPY.MODE 136070 . 138285) (\FLOPPY.SETUP.HARDWARE 138287 . 140966) (\FLOPPY.EVENTFN 140968 . 141547) (\FLOPPY.HOSTNAMEP 141549 . 141922) ( \FLOPPY.ADDDEVICENAME 141924 . 142306) (\FLOPPY.ASSUREFILENAME 142308 . 143597) (\FLOPPY.OTHERINFO 143599 . 144447) (\FLOPPY.LEXASSOC 144449 . 144858) (\FLOPPY.LEXPUTASSOC 144860 . 146318) ( \FLOPPY.LEXREMOVEASSOC 146320 . 147385) (\FLOPPY.CACHED.READ 147387 . 148114) (\FLOPPY.CACHED.WRITE 148116 . 149087) (\FLOPPY.OPEN 149089 . 149476) (\FLOPPY.CLOSE 149478 . 150509) (\FLOPPY.FLUSH 150511 . 151606) (\FLOPPY.UNCACHED.READ 151608 . 152607) (\FLOPPY.UNCACHED.WRITE 152609 . 153610) ( \FLOPPY.EXISTSP 153612 . 154012) (\FLOPPY.BREAK 154014 . 154423) (\FLOPPY.MESSAGE 154425 . 155077) ( \FLOPPY.BUFFER 155079 . 155330)) (161415 242222 (\PFLOPPY.INIT 161425 . 163300) (\PFLOPPY.OPEN 163302 . 164313) (\PFLOPPY.OPEN.PSECTOR9 164315 . 164799) (\PFLOPPY.GET.PSECTOR9 164801 . 165944) ( \PFLOPPY.OPEN.PFILELIST 165946 . 169489) (\PFLOPPY.DAMAGED 169491 . 169856) (\PFLOPPY.OPENFILE 169858 . 174362) (\PFLOPPY.OPENFILE1 174364 . 176114) (\PFLOPPY.OPENOLDFILE 176116 . 177294) ( \PFLOPPY.OPENNEWFILE 177296 . 179290) (\PFLOPPY.ASSURESTREAM 179292 . 179746) (\PFLOPPY.GETFILEINFO 179748 . 180263) (\PFLOPPY.GETFILEINFO1 180265 . 182052) (\PFLOPPY.SETFILEINFO 182054 . 185353) ( \PFLOPPY.CLOSEFILE 185355 . 185775) (\PFLOPPY.CLOSEFILE1 185777 . 188214) (\PFLOPPY.DELETEFILE 188216 . 190080) (\PFLOPPY.GENERATEFILES 190082 . 194824) (\PFLOPPY.NEXTFILEFN 194826 . 196074) ( \PFLOPPY.FILEINFOFN 196076 . 196493) (\PFLOPPY.RENAMEFILE 196495 . 199565) (\PFLOPPY.STREAMS.AGAINST 199567 . 200196) (\PFLOPPY.STREAMS.USING 200198 . 200868) (\PFLOPPY.READPAGES 200870 . 201180) ( \PFLOPPY.READPAGE 201182 . 202411) (\PFLOPPY.READPAGENO 202413 . 203999) (\PFLOPPY.WRITEPAGENO 204001 . 205591) (\PFLOPPY.PAGENOTODISKADDRESS 205593 . 206381) (\PFLOPPY.DISKADDRESSTOPAGENO 206383 . 207305) (\PFLOPPY.DIR.GET 207307 . 209039) (\PFLOPPY.DIR.PUT 209041 . 210710) (\PFLOPPY.DIR.REMOVE 210712 . 212547) (\PFLOPPY.DIR.VERSION 212549 . 214083) (\PFLOPPY.GETFILENAME 214085 . 216987) ( \PFLOPPY.CREATE.PFILELIST 216989 . 218088) (\PFLOPPY.ADD.TO.PFILELIST 218090 . 223406) ( \PFLOPPY.DELETE.FROM.PFILELIST 223408 . 225381) (\PFLOPPY.SAVE.PFILELIST 225383 . 226132) ( \PFLOPPY.SAVE.PSECTOR9 226134 . 226680) (\PFLOPPY.WRITEPAGES 226682 . 226994) (\PFLOPPY.WRITEPAGE 226996 . 227912) (\PFLOPPY.TRUNCATEFILE 227914 . 229693) (\PFLOPPY.FORMAT 229695 . 239193) ( \PFLOPPY.CONFIRM 239195 . 240940) (\PFLOPPY.GET.NAME 240942 . 241408) (\PFLOPPY.SET.NAME 241410 . 242220)) (242496 272075 (\PFLOPPY.ALLOCATE 242506 . 245305) (\PFLOPPY.ALLOCATE.LARGEST 245307 . 246242 ) (\PFLOPPY.TRUNCATE 246244 . 250521) (\PFLOPPY.DEALLOCATE 250523 . 251655) (\PFLOPPY.EXTEND 251657 . 257562) (\PFLOPPY.GAINSPACE 257564 . 258902) (\PFLOPPY.GAINSPACE.MERGE 258904 . 262068) ( \PFLOPPY.ALLOCATE.WATCHDOG 262070 . 262685) (\PFLOPPY.FREE.PAGES 262687 . 264191) (\PFLOPPY.LENGTHS 264193 . 264441) (\PFLOPPY.STARTS 264443 . 264689) (\PFLOPPY.ICHECK 264691 . 270239) ( \PFLOPPY.ALLOCATIONS 270241 . 272073)) (272105 277429 (FLOPPY.FREE.PAGES 272115 . 272479) ( FLOPPY.FORMAT 272481 . 273424) (FLOPPY.NAME 273426 . 273619) (FLOPPY.GET.NAME 273621 . 273907) ( FLOPPY.SET.NAME 273909 . 274200) (FLOPPY.CAN.READP 274202 . 274948) (FLOPPY.CAN.WRITEP 274950 . 275707 ) (FLOPPY.WAIT.FOR.FLOPPY 275709 . 277427)) (278033 299163 (\SFLOPPY.INIT 278043 . 279855) ( \SFLOPPY.GETFILEINFO 279857 . 281838) (\SFLOPPY.OPENHUGEFILE 281840 . 284993) (\SFLOPPY.WRITEPAGES 284995 . 285304) (\SFLOPPY.WRITEPAGE 285306 . 286672) (\SFLOPPY.READPAGES 286674 . 287061) ( \SFLOPPY.READPAGE 287063 . 287846) (\SFLOPPY.CLOSEHUGEFILE 287848 . 289403) (\SFLOPPY.INPUTFLOPPY 289405 . 293499) (\SFLOPPY.OUTPUTFLOPPY 293501 . 295995) (\SFLOPPY.CLOSEFLOPPY 295997 . 298340) ( \SFLOPPY.HACK 298342 . 299161)) (299639 318312 (\HFLOPPY.INIT 299649 . 301461) (\HFLOPPY.GETFILEINFO 301463 . 303444) (\HFLOPPY.OPENHUGEFILE 303446 . 307186) (\HFLOPPY.WRITEPAGES 307188 . 307497) ( \HFLOPPY.WRITEPAGE 307499 . 308865) (\HFLOPPY.READPAGES 308867 . 309254) (\HFLOPPY.READPAGE 309256 . 310039) (\HFLOPPY.CLOSEHUGEFILE 310041 . 310942) (\HFLOPPY.INPUTFLOPPY 310944 . 313571) ( \HFLOPPY.OUTPUTFLOPPY 313573 . 315729) (\HFLOPPY.CLOSEFLOPPY 315731 . 318310)) (318382 340817 ( FLOPPY.SCAVENGE 318392 . 318576) (\PFLOPPY.SCAVENGE 318578 . 319124) (\PFLOPPY.SCAVENGE.PMPAGES 319126 . 320432) (\PFLOPPY.SCAVENGE.PMPAGEA 320434 . 321972) (\PFLOPPY.SCAVENGE.PMPAGE.AFTER 321974 . 323023 ) (\PFLOPPY.SCAVENGE.PMPAGE.AFTER1 323025 . 329574) (\PFLOPPY.SCAVENGE.PLPAGES 329576 . 337463) ( \PFLOPPY.SCAVENGE.PSECTOR9 337465 . 340351) (\PFLOPPY.SCAVENGE.PFILELIST 340353 . 340815)) (340843 346090 (FLOPPY.TO.FILE 340853 . 343475) (FLOPPY.FROM.FILE 343477 . 346088)) (346119 357971 ( FLOPPY.COMPACT 346129 . 346621) (\PFLOPPY.COMPACT 346623 . 348576) (\PFLOPPY.COMPACT.PFALLOCS 348578 . 352802) (\PFLOPPY.COMPACT.PFALLOC 352804 . 356268) (\PFLOPPY.COMPACT.PSECTOR9 356270 . 357307) ( \PFLOPPY.COMPACT.PFILELIST 357309 . 357969)) (358000 361349 (FLOPPY.ARCHIVE 358010 . 360223) ( FLOPPY.UNARCHIVE 360225 . 361347))))) STOP \ No newline at end of file diff --git a/sources/FONT b/sources/FONT new file mode 100644 index 00000000..b530eb3f --- /dev/null +++ b/sources/FONT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:29:49" {DSK}medley3.5>sources>FONT.;3 187933 changes to%: (FNS \LOOKUPFONTSINCORE) previous date%: "28-Jun-99 16:22:27" {DSK}medley3.5>sources>FONT.;2) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT FONTCOMS) (RPAQQ FONTCOMS [ (* ;; "font functions ") (FNS CHARWIDTH CHARWIDTHY STRINGWIDTH \CHARWIDTH.DISPLAY \STRINGWIDTH.DISPLAY \STRINGWIDTH.GENERIC) (FNS DEFAULTFONT FONTCLASS FONTCLASSUNPARSE FONTCLASSCOMPONENT SETFONTCLASSCOMPONENT) [COMS (* ;  "Until we pin down the exact interface") (P (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT) (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT] [COMS (* ; "MAPPING FOR DOS FILENAMES ") (INITVARS (*DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) (HELVETICA . HV) (TIMESROMAND . TD) (HELVETICAD . HD) (MODERN . MD) (CLASSIC . CL) (GACHA . GC) (TITAN . TI) (LETTERGOTHIC . LG) (BOLDPS . BP) (TERMINAL . TM) (CLASSICTHIN . CT) (HIPPO . HP) (LOGO . LG) (MATH . MA) (OLDENGLISH . OE) (SYMBOL . SY] (COMS (* ;; "Creation: ") (FNS FONTCREATE \FONT.SYMBOLMEMB \FONT.SYMBOLASSOC \FONT.COMPARESYMBOL)) (COMS (* ;; "Property extraction:") (FNS FONTASCENT FONTDESCENT FONTHEIGHT FONTPROP \AVGCHARWIDTH)) (COMS (* ;; "Bitmap editing/manipulation:") (FNS GETCHARBITMAP PUTCHARBITMAP MOVECHARBITMAP)) (FNS FONTCOPY FONTSAVAILABLE FONTFILEFORMAT FONTP FONTUNPARSE SETFONTDESCRIPTOR CHARCODEP EDITCHAR \STREAMCHARWIDTH \UNITWIDTHSVECTOR \CREATEDISPLAYFONT \CREATECHARSET.DISPLAY \CREATE-REAL-CHARSET.DISPLAY \BUILDSLUGCSINFO \SEARCHDISPLAYFONTFILES \SEARCHFONTFILES \FINDFONTFILE \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR \FONTFILENAME \FONTFILENAME.OLD \FONTFILENAME.NEW \FONTINFOFROMFILENAME \FONTINFOFROMFILENAME.OLD \GETFONTDESC \COERCEFONTDESC \LOOKUPFONT \LOOKUPFONTSINCORE \READDISPLAYFONTFILE) (COMS (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. ") (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)) (INITVARS (*USEOLDFONTDIRECTORIES* NIL)) (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*) (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)") ) (COMS (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)") (INITVARS (CACHEDISPLAYFONTS T)) (GLOBALVARS CACHEDISPLAYFONTS) (* ; "STRIKE format file support") (FNS \READSTRIKEFONTFILE \SFMAKEBOLD \SFMAKEITALIC \SFMAKEROTATEDFONT \SFROTATECSINFO \SFROTATEFONTCHARACTERS \SFFIXOFFSETSAFTERROTATION \SFROTATECSINFOOFFSETS \SFMAKECOLOR) (FNS WRITESTRIKEFONTFILE STRIKECSINFO)) (INITRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) (SYSRECORDS FONTCLASS FONTDESCRIPTOR CHARSETINFO) (INITVARS (\FONTSINCORE) (\DEFAULTDEVICEFONTS) (\UNITWIDTHSVECTOR)) (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\UNITWIDTHSVECTOR))) (CONSTANTS (NORUNCODE 255)) (EXPORT (OPTIMIZERS FONTPROP)) [DECLARE%: DONTCOPY (EXPORT (RECORDS FONTCLASS FONTDESCRIPTOR FONTFACE CHARSETINFO) (MACROS FONTASCENT FONTDESCENT FONTHEIGHT \FGETOFFSET \FSETOFFSET \FGETWIDTH \FSETWIDTH \FGETCHARWIDTH \FSETCHARWIDTH \FGETIMAGEWIDTH \FSETIMAGEWIDTH \GETCHARSETINFO \CREATECSINFOELEMENT \CREATEFONTCHARSETVECTOR) (FUNCTIONS \CREATEKERNELEMENT \FSETLEFTKERN \FGETLEFTKERN) (CONSTANTS (\MAXNSCHAR 65535] (COMS (* ; "NS Character specific code") (FNS \CREATECHARSET) (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG) (INITVARS (DISPLAYFONTCOERCIONS NIL) [MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA) (TERMINAL)) ((MODERN) (CLASSIC)) ((TIMESROMAN) (CLASSIC)) ((HELVETICA) (MODERN)) ((TERMINAL 6) (MODERN 6)) ((TERMINAL 8) (MODERN 8)) ((TERMINAL 10) (MODERN 10)) ((TERMINAL 12) (MODERN 12] [MISSINGDISPLAYFONTCOERCIONS '(((GACHA) (TERMINAL)) ((MODERN) (CLASSIC)) ((TIMESROMAN) (CLASSIC)) ((HELVETICA) (MODERN] (CHARSETERRORFLG NIL) (\DEFAULTCHARSET 0))) (FNS \FONTRESETCHARWIDTHS) [DECLARE%: DONTEVAL@LOAD (INITVARS (DISPLAYFONTEXTENSIONS 'DISPLAYFONT) (DISPLAYFONTDIRECTORIES '( {DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ {dsk}/usr/local/lde/fonts/display/publishing/ ] (MACROS \FGETCHARIMAGEWIDTH \GETFONTDESC \SETCHARSETINFO) (LOCALVARS . T) (PROP FILETYPE FONT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FONTCOPY]) (* ;; "font functions ") (DEFINEQ (CHARWIDTH [LAMBDA (CHARCODE FONT) (* rmk%: "12-Apr-85 09:46") (* ;  "gets the width of a character code in a font/stream") (OR (\CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (LET (TEMP) (COND ((type? FONTDESCRIPTOR FONT) (\FGETCHARWIDTH FONT CHARCODE)) ((SETQ TEMP (\OUTSTREAMARG FONT T)) (* ;  "NIL font goes thru here--primary output file") (IMAGEOP 'IMCHARWIDTH TEMP TEMP CHARCODE)) (T (\FGETCHARWIDTH (FONTCREATE FONT) CHARCODE]) (CHARWIDTHY [LAMBDA (CHARCODE FONT) (* edited%: "18-Mar-86 19:30") (* ;  "Gets the Y-component of the width of a character code in a font.") (OR (\CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (LET (TEMP WY) (COND ((type? FONTDESCRIPTOR FONT) (SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONT))) (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) (T 0))) ((type? STREAM (SETQ TEMP (\OUTSTREAMARG FONT T))) (* ;  "NIL font goes thru here--primary output file") (IMAGEOP 'IMCHARWIDTHY TEMP TEMP CHARCODE)) (T [SETQ WY (ffetch (CHARSETINFO YWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) (FONTCREATE FONT] (COND ((FIXP WY)) (WY (\FGETWIDTH WY (\CHAR8CODE CHARCODE))) (T 0]) (STRINGWIDTH [LAMBDA (STR FONT FLG RDTBL) (* ; "Edited 8-Jan-88 14:41 by Snow") (* ;; "Returns the width of STR according to FONT") (LET (TEMP) (* ;; "Used in \MAPCHARS") (COND [(type? FONTDESCRIPTOR FONT) (\STRINGWIDTH.GENERIC STR FONT (AND FLG (\GTREADTABLE RDTBL)) (\FGETCHARWIDTH FONT (CHARCODE SPACE] [(AND FONT (SETQ TEMP (\OUTSTREAMARG FONT T))) (* ;  "if you gave something for FONT, coerce it to a stream, and call the stringwidth function of it.") (IMAGEOP 'IMSTRINGWIDTH TEMP TEMP STR (AND FLG (\GTREADTABLE RDTBL] (T (SETQ TEMP (FONTCREATE (OR FONT DEFAULTFONT))) (* ; "NIL font will pass thru here. ie, defaultfont is used to do the stringwidth instead of the font of *standard-output*") (\STRINGWIDTH.GENERIC STR TEMP (AND FLG (\GTREADTABLE RDTBL)) (\FGETCHARWIDTH TEMP (CHARCODE SPACE]) (\CHARWIDTH.DISPLAY [LAMBDA (STREAM CHARCODE) (* rmk%: "12-Apr-85 09:42") (* ;  "gets the width of a character code in a display stream. Need to fix up for spacefactor.") (\FGETCHARWIDTH (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM)) CHARCODE]) (\STRINGWIDTH.DISPLAY [LAMBDA (STREAM STR RDTBL) (* ; "Edited 3-Apr-87 12:07 by jop") (* ;; "Returns the width of for the current font/spacefactor in STREAM.") (LET ((DD (ffetch IMAGEDATA of STREAM))) (\STRINGWIDTH.GENERIC STR (ffetch (\DISPLAYDATA DDFONT) of DD) RDTBL (ffetch DDSPACEWIDTH of DD]) (\STRINGWIDTH.GENERIC [LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 3-Apr-87 13:47 by jop") (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces. RDTBL has already been coerced, so no FLG is needed ") (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((WIDTHS . IMAGEWIDTHS) (\FGETWIDTH . \FGETIMAGEWIDTH) (\FGETCHARWIDTH . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))") (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler") (PROG NIL [COND [(LITATOM STR) (if RDTBL then (GO SLOW) else (RETURN (for C WIDTHSBASE CSET inatom STR sum [COND ((NEQ CSET (\CHARSET C)) (SETQ CSET (\CHARSET C)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO CSET FONT ] (COND ((EQ C (CHARCODE SPACE)) SPACEWIDTH) (T (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C] ((STRINGP STR) (RETURN (LET ((TOTAL 0) ESC ESCWIDTH WIDTHSBASE CSET) [COND (RDTBL (* ;  "Count delimiting quotes and internal escapes") (SETQ TOTAL (UNFOLD (\FGETCHARWIDTH FONT (CHARCODE %")) 2)) (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)) (SETQ ESCWIDTH (\FGETCHARWIDTH FONT ESC] [for C instring STR do [COND ((NEQ (\CHARSET C) CSET) (* ;  "Get the widths vector for this character set") (SETQ CSET (\CHARSET C)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO CSET FONT] (add TOTAL (COND ((EQ C (CHARCODE SPACE)) SPACEWIDTH) (T (IPLUS (\FGETWIDTH WIDTHSBASE (\CHAR8CODE C)) (COND ((AND RDTBL (OR (EQ C (CHARCODE %")) (EQ C ESC))) (* ; "String char must be escaped") ESCWIDTH) (T 0] TOTAL] SLOW (* ; "Do the general case here") (RETURN (LET ((TOTALWIDTH 0) WIDTHSBASE CSET (FONT FONT) (SPACEWIDTH SPACEWIDTH)) (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH)) (\MAPPNAME [FUNCTION (LAMBDA (DUMMY CC) (add TOTALWIDTH (COND ((EQ CC (CHARCODE SPACE)) SPACEWIDTH) ((EQ CSET (\CHARSET CC)) (\FGETWIDTH WIDTHSBASE (\CHAR8CODE CC))) (T (SETQ CSET (\CHARSET CC)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO CSET FONT))) (\FGETWIDTH WIDTHSBASE (\CHAR8CODE CC] STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*) TOTALWIDTH]) ) (DEFINEQ (DEFAULTFONT [LAMBDA (DEVICE FONT NOERRORFLG) (* ; "Edited 28-Jul-88 13:15 by rmk:") (* ; "Edited 24-Mar-87 14:41 by FS") (* ;; "Returns the default font for an image type. Really only needed to guarantee validity of the display default font for system critical routines, in case the user has smashed the variable DEFAULTFONT. Note that SETFONTCLASSCOMPONENT and FONTCLASS guarantee that the display component is either NIL or a fontdescriptor.") (* ;; "FS- If FONT provided set the font descriptor. Do not bother to check if NOERRORFLG is NEW. (old code had (AND FONT (EQ NOERRORFLG 'NEW)))") [OR (type? FONTCLASS DEFAULTFONT) (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT] (if FONT then (* ;; "FS- Not clear the fontclass should be smashed, perhaps instead should make a new FONTCLASS and then rebind DEFAULTFONT. Leaving alone for histerical reasons") (SETFONTCLASSCOMPONENT DEFAULTFONT DEVICE FONT) else (* ;; "The code below (not mine!) is messy but is correct (unless weirdness pops up because of deep recursion).") (COND ((\COERCEFONTDESC DEFAULTFONT DEVICE T)) (NOERRORFLG NIL) ((EQ (\DEVICESYMBOL DEVICE T) 'DISPLAY) (* ;; "If getting for the display and the font can't be found perhaps because of garbage in the display field of the DEFAULTFONTCLASS, then the system-guaranteed displayfont. Otherwise, cause the error in the re-coercion. Can never tell when DEVICE is just a symbol.") \GUARANTEEDDISPLAYFONT) ((\COERCEFONTDESC DEFAULTFONT DEVICE]) (FONTCLASS [LAMBDA (NAME FONTLIST CREATEFORDEVICES) (* jds " 9-Sep-86 18:49") (* ;; "This builds D style font classes, which are datatypes containing entries for the various known devices.") (* ;; "Don't actually set up the for devices not inside CREATEFORDEVICES on the theory that any given user presumably doesn't want all the fonts for all the devices. We wait until he actually asks for the font or the fontmaparray, at which point we note that the fields don't contain FD's, so we then apply FONTCREATE. The actual coercion and caching is done inside \COERCEFONTDESC. However, so as to prevent display crashes, if a display component is specified, we always do the fontcreate before we stick it in.") (PROG (F FC FL) (SETQ FL FONTLIST) [SETQ FC (create FONTCLASS FONTCLASSNAME _ NAME PRETTYFONT# _ (OR (FIXP (pop FL)) 1) DISPLAYFD _ (AND (SETQ F (pop FL)) (FONTCREATE F NIL NIL NIL 'DISPLAY)) PRESSFD _ (pop FL) INTERPRESSFD _ (pop FL) OTHERFDS _ (for FSPEC in FL collect (OR (AND (LISTP FSPEC) (ATOM (CAR FSPEC)) (CAR FSPEC)) (ERROR "illegal font class specification" (LIST NAME FONTLIST))) (* ;  "Copy the alist entry so it can be smashed in \COERCEFONTDESC") (CONS (CAR FSPEC) (CAR (LISTP (CDR FSPEC] (for D inside CREATEFORDEVICES do (FONTCREATE FC NIL NIL NIL D)) (RETURN FC]) (FONTCLASSUNPARSE [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* jds "24-Jan-86 11:58") (* ;  "Given a font class, unparse it to a form that might be reparsable") (APPEND (LIST (fetch (FONTCLASS FONTCLASSNAME) of FONTCLASS) (fetch (FONTCLASS PRETTYFONT#) of FONTCLASS) (FONTUNPARSE (ffetch (FONTCLASS DISPLAYFD) of FONTCLASS)) (FONTUNPARSE (ffetch (FONTCLASS PRESSFD) of FONTCLASS)) (FONTUNPARSE (ffetch (FONTCLASS INTERPRESSFD) of FONTCLASS))) (for X in (fetch (FONTCLASS OTHERFDS) of FONTCLASS) collect (LIST (CAR X) (FONTUNPARSE (CDR X]) (FONTCLASSCOMPONENT [LAMBDA (FONTCLASS DEVICE FONT NOERRORFLG) (* rmk%: "14-Sep-84 19:34") (PROG1 (FONTCREATE FONTCLASS NIL NIL NIL DEVICE NOERRORFLG) (* ;  "This works its way down to \COERCEFONTDESC, where it needs to be done quickly") (AND FONT (SETQ FONT (FONTCREATE FONT NIL NIL NIL DEVICE NOERRORFLG)) (SETFONTCLASSCOMPONENT FONTCLASS DEVICE FONT)))]) (SETFONTCLASSCOMPONENT [LAMBDA (FONTCLASS DEVICE FONT) (* ; "Edited 29-Aug-91 12:20 by jds") (PROG ((NEWFONT (FONTCREATE FONT NIL NIL NIL DEVICE))) (* ;; "replaces will barf if FONTCLASS is not a fontclass") (SELECTQ (SETQ DEVICE (FONTPROP NEWFONT 'DEVICE)) (DISPLAY (replace (FONTCLASS DISPLAYFD) of FONTCLASS with NEWFONT)) (INTERPRESS (replace (FONTCLASS INTERPRESSFD) of FONTCLASS with NEWFONT )) (PRESS (replace (FONTCLASS PRESSFD) of FONTCLASS with NEWFONT)) (RPLACD [OR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of FONTCLASS)) (CAR (push (fetch (FONTCLASS OTHERFDS) of FONTCLASS) (CONS DEVICE] NEWFONT)) (RETURN NEWFONT]) ) (* ; "Until we pin down the exact interface") (MOVD 'FONTCLASSCOMPONENT 'FONTCOMPONENT) (MOVD 'SETFONTCLASSCOMPONENT 'SETFONTCOMPONENT) (* ; "MAPPING FOR DOS FILENAMES ") (RPAQ? *DISPLAY-FONT-NAME-MAP* '((TIMESROMAN . TR) (HELVETICA . HV) (TIMESROMAND . TD) (HELVETICAD . HD) (MODERN . MD) (CLASSIC . CL) (GACHA . GC) (TITAN . TI) (LETTERGOTHIC . LG) (BOLDPS . BP) (TERMINAL . TM) (CLASSICTHIN . CT) (HIPPO . HP) (LOGO . LG) (MATH . MA) (OLDENGLISH . OE) (SYMBOL . SY))) (* ;; "Creation: ") (DEFINEQ (FONTCREATE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG CHARSET) (* ; "Edited 10-Oct-88 09:53 by rmk:") (* ; "Edited 28-Jul-88 14:43 by rmk:") (* ; "Edited 10-Nov-87 18:08 by FS") (* ;; "Create a font descriptor for the specified font. If NOERRORFLG, return NIL if the font doesn't exist; otherwise cause an error.") (* ;; "Cache and fonts.widths traffic in uppercase only.") (* ;; "character set is optional and defaults to \DEFAULTCHARSET (0 in our world)") (DECLARE (GLOBALVARS IMAGESTREAMTYPES \DEFAULTCHARSET)) (PROG (FONTX (CHSET (OR CHARSET \DEFAULTCHARSET))) (RETURN (COND ((LISTP FAMILY) (SELECTQ (CAR FAMILY) (FONT (SETQ FONTX (CDR FAMILY))) (CLASS (COND ((LITATOM (CADR FAMILY)) (* ; "litatom class name") (RETURN (FONTCLASS (CADR FAMILY) (CDDR FAMILY) DEVICE))) (T (* ;  "Allows for a font named CLASS--distinguished cause its size is not a litatom") (SETQ FONTX FAMILY)))) (SETQ FONTX FAMILY)) (FONTCREATE (CAR FONTX) (OR (CADR FONTX) SIZE) (OR (CADDR FONTX) FACE) (OR (CADDDR FONTX) ROTATION) (OR (CADR (CDDDR FONTX)) DEVICE) NOERRORFLG CHSET)) ([SETQ FONTX (COND ((type? FONTDESCRIPTOR FAMILY) FAMILY) ((NULL FAMILY) (DEFAULTFONT DEVICE)) ((type? FONTCLASS FAMILY) (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class. Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.") (\COERCEFONTDESC FAMILY DEVICE NOERRORFLG)) ((OR (IMAGESTREAMP FAMILY) (type? WINDOW FAMILY)) (DSPFONT NIL FAMILY] (* ;;  "FAMILY was a spec for a font descriptor, use it and extend it by the other args.") (COND ((OR SIZE FACE ROTATION DEVICE) (FONTCREATE (FONTPROP FONTX 'FAMILY) (OR SIZE (FONTPROP FONTX 'SIZE)) (OR FACE (FONTPROP FONTX 'FACE)) (OR ROTATION (FONTPROP FONTX 'ROTATION)) (OR DEVICE (FONTPROP FONTX 'DEVICE)) NOERRORFLG)) (T FONTX))) (T (PROG (FONTFACE (DEV DEVICE)) RETRY [OR (LITATOM FAMILY) (COND (NOERRORFLG (RETURN)) (T (LISPERROR "ARG NOT LITATOM" FAMILY T] [OR (AND (FIXP SIZE) (IGREATERP SIZE 0)) (COND (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG SIZE] (COND ((NULL ROTATION) (SETQ ROTATION 0)) ((AND (FIXP ROTATION) (IGEQ ROTATION 0))) (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG ROTATION))) [SETQ DEV (COND ((NULL DEVICE) 'DISPLAY) ((AND (LITATOM DEVICE) (NEQ DEVICE T)) (* ; "Maybe wrong case or package, but we bet it's OK and defer expensive coercion until we've failed.") DEV) ((SETQ DEV (\GETSTREAM DEVICE 'OUTPUT T)) (* ;  "T coerces here to primary output") (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of DEV))) ((STRINGP DEVICE) (MKATOM (U-CASE DEVICE))) (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG DEVICE] (* ; "DEV is now guanteed litatom") NEWDEV (* ;  "Check after device since it is device-dependent") (SETQ FONTFACE (OR (\FONTFACE FACE NOERRORFLG DEV) (RETURN NIL))) (* ; "Don't truly coerce to \FONTSYMBOL or \DEVICESYMBOL until we've had a shot at the font cache, since re-interning atoms is so expensive") [RETURN (COND ((\LOOKUPFONT FAMILY SIZE FONTFACE ROTATION DEV)) [(SETQ FONTX (CDR (ASSOC DEV IMAGESTREAMTYPES))) (* ;; "Device is valid, font just doesn't exist. FONTFACE, DEV already canonical. Make FAMILY so, so that each imagestream type doesn't have to.") (SETQ FAMILY (\FONTSYMBOL FAMILY)) (COND ((SETQ FONTX (APPLY* (OR (CADR (ASSOC 'FONTCREATE FONTX) ) (FUNCTION NILL)) FAMILY SIZE FONTFACE ROTATION DEV CHSET)) (* ;; "default creation case. Use fontcreate method from device, build a fontdescriptor and use setfontdescriptor to install it.") (* ;; "OBSOLETEd by the CHARSETINFO code (OR (ffetch FONTIMAGEWIDTHS of FONTX) (freplace FONTIMAGEWIDTHS of FONTX with (ffetch \SFWidths of FONTX)))") (* ;;  "the widths fields in the fontdescriptor are obsolete, and shoudln't be updated here.") (* ;; "We should probably force all device implementations to obey these conventions, then remove these generic updates") (replace (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTX with (\AVGCHARWIDTH FONTX)) (SETFONTDESCRIPTOR FAMILY SIZE FONTFACE ROTATION DEV FONTX)) (T (GO NOTFOUND] ((NEQ DEV (SETQ DEV (U-CASE DEV))) (* ;; "We didn't recognize the device, so check to see whether coercion to U-CASE IL changes anything. Could be slow, but we're heading for an error.") (GO NEWDEV)) (T (GO NOTFOUND] NOTFOUND (COND (NOERRORFLG (RETURN NIL)) (T (ERROR "FONT NOT FOUND (coerced to)" (LIST FAMILY SIZE FONTFACE ROTATION DEV)) (GO RETRY]) (\FONT.SYMBOLMEMB [LAMBDA (USERINPUT LIST) (* ; "Edited 7-Feb-89 15:47 by jds") (for X on LIST when (\FONT.COMPARESYMBOL USERINPUT (CAR X)) do (RETURN X]) (\FONT.SYMBOLASSOC [LAMBDA (USERINPUT LIST) (* ; "Edited 28-Jul-88 16:56 by rmk:") (* ; "Edited 28-Jul-88 15:15 by rmk:") (* ; "Edited 28-Jul-88 15:03 by rmk:") (* ; "Edited 28-Jul-88 14:44 by rmk:") (* ; "Edited 28-Jul-88 14:16 by rmk:") (for X FIRSTC (NC _ (NCHARS USERINPUT)) in LIST first (SETQ FIRSTC (CHCON1 USERINPUT)) [if (AND (IGEQ FIRSTC (CHARCODE a)) (ILEQ FIRSTC (CHARCODE z))) then (SETQ FIRSTC (IDIFFERENCE FIRSTC (IDIFFERENCE (CHARCODE a) (CHARCODE A] when (AND (EQ NC (NCHARS (CAR X))) (EQ FIRSTC (CHCON1 (CAR X))) (\FONT.COMPARESYMBOL USERINPUT (CAR X) NC FIRSTC)) do (RETURN X]) (\FONT.COMPARESYMBOL [LAMBDA (USERINPUT KEY INPUTNC INPUTFIRSTC) (* ;  "Edited 24-May-93 16:45 by sybalsky:mv:envos") (* ;; " An open coded case- and package-insensitive comparison of atom pnames, assuming that KEY is already upper-case but USERINPUT may not be. Maybe there is a simple function that does this.") (* ;; "INPUTNC and INPUTFIRSTC can be passed in if they are common to lots of calls") (COND ((AND (LITATOM USERINPUT) (EQ [CL:AREF *PACKAGE-FROM-INDEX* (fetch (PNAMECELL PACKAGEINDEX) of (PROGN (\PNAMECELL USERINPUT] *INTERLISP-PACKAGE*)) (* ;; "If the user's symbol is in the IL package (which is where all the KEYs are), we can use EQ, which is MUCH faster.") (OR (EQ USERINPUT KEY) (EQ (U-CASE USERINPUT) KEY))) (T (* ;; "Otherwise, we do the comparison character by character.") (AND (EQ (OR INPUTNC (NCHARS USERINPUT)) (NCHARS KEY)) [COND (INPUTFIRSTC (EQ INPUTFIRSTC (CHCON1 KEY))) ((EQ (SETQ INPUTFIRSTC (CHCON1 USERINPUT)) (CHCON1 KEY))) ((AND (IGEQ INPUTFIRSTC (CHARCODE a)) (ILEQ INPUTFIRSTC (CHARCODE z))) (EQ (IDIFFERENCE INPUTFIRSTC (IDIFFERENCE (CHARCODE a) (CHARCODE A))) (CHCON1 KEY] (for CHAR1 inatom USERINPUT as CHAR2 inatom KEY always (OR (EQ CHAR1 CHAR2) (AND (IGEQ CHAR1 (CHARCODE a)) (ILEQ CHAR1 (CHARCODE z)) (EQ CHAR2 (IPLUS CHAR1 (CONSTANT (IDIFFERENCE (CHARCODE A) (CHARCODE a]) ) (* ;; "Property extraction:") (DEFINEQ (FONTASCENT [LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:23") (ffetch \SFAscent of (\GETFONTDESC FONTSPEC]) (FONTDESCENT [LAMBDA (FONTSPEC) (* lmm "19-NOV-82 00:24") (* ; "See comment in FONTASCENT") (ffetch \SFDescent of (\GETFONTDESC FONTSPEC]) (FONTHEIGHT [LAMBDA (FONTSPEC) (* kbr%: " 9-Jan-86 18:29") (fetch (FONTDESCRIPTOR \SFHeight) of (\GETFONTDESC FONTSPEC]) (FONTPROP [LAMBDA (FONT PROP) (* kbr%: "13-May-85 22:36") (SETQ FONT (\GETFONTDESC FONT)) (SELECTQ PROP (HEIGHT (ffetch \SFHeight of FONT)) (ASCENT (ffetch \SFAscent of FONT)) (DESCENT (ffetch \SFDescent of FONT)) (FAMILY (ffetch FONTFAMILY of FONT)) (SIZE (ffetch FONTSIZE of FONT)) (FACE (COPY (ffetch FONTFACE of FONT))) (WEIGHT (ffetch WEIGHT of (ffetch FONTFACE of FONT))) (SLOPE (ffetch SLOPE of (ffetch FONTFACE of FONT))) (EXPANSION (ffetch EXPANSION of (ffetch FONTFACE of FONT))) (FORECOLOR (ffetch FORECOLOR of (ffetch FONTFACE of FONT))) (BACKCOLOR (ffetch BACKCOLOR of (ffetch FONTFACE of FONT))) (ROTATION (ffetch ROTATION of FONT)) (DEVICE (ffetch FONTDEVICE of FONT)) (SPEC (LIST (ffetch FONTFAMILY of FONT) (ffetch FONTSIZE of FONT) (COPY (ffetch FONTFACE of FONT)) (ffetch ROTATION of FONT) (ffetch FONTDEVICE of FONT))) (DEVICESPEC (* ;  "DEVICE fields are for communicating coercions to the particular printing device") [COND ((ffetch FONTDEVICESPEC of FONT) (COPY (ffetch FONTDEVICESPEC of FONT))) (T (FONTPROP FONT 'SPEC]) (DEVICEFACE [COPY (COND ((ffetch FONTDEVICESPEC of FONT) (CADDR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFACE of FONT]) (DEVICESLOPE [fetch SLOPE of (COND ((ffetch FONTDEVICESPEC of FONT) (CADDR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFACE of FONT]) (DEVICEWEIGHT [fetch WEIGHT of (COND ((ffetch FONTDEVICESPEC of FONT) (CADDR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFACE of FONT]) (DEVICEEXPANSION [fetch EXPANSION of (COND ((ffetch FONTDEVICESPEC of FONT) (CADDR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFACE of FONT]) (DEVICESIZE (COND ((ffetch FONTDEVICESPEC of FONT) (CADR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTSIZE of FONT)))) (DEVICEFAMILY (COND ((ffetch FONTDEVICESPEC of FONT) (CAR (ffetch FONTDEVICESPEC of FONT))) (T (ffetch FONTFAMILY of FONT)))) (SCALE (ffetch FONTSCALE of FONT)) (\ILLEGAL.ARG PROP]) (\AVGCHARWIDTH [LAMBDA (FONT) (* rmk%: "27-Nov-84 18:40") (* ;; "Returns the average width of a character, to be used in units-to-characters approximations, as in fixing the linelength") (PROG ((W (CHARWIDTH (CHARCODE A) FONT))) (RETURN (COND ((NEQ 0 W) W) ([NEQ 0 (SETQ W (FIXR (FTIMES 0.6 (FONTPROP FONT 'HEIGHT] W) (T 1]) ) (* ;; "Bitmap editing/manipulation:") (DEFINEQ (GETCHARBITMAP [LAMBDA (CHARCODE FONT) (* ; "Edited 26-Apr-89 21:49 by atm") (* ;  "returns a bitmap of the character CHARCODE from the font descriptor FONTDESC.") (COND ((OR (CHARCODEP CHARCODE) (EQ CHARCODE 256)) (* ;  "bitmap for char 256 is what gets printed if char not found") ) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (* ;  "For strings & litatoms, take the first character") (SETQ CHARCODE (CHCON1 CHARCODE))) ((TYPEP CHARCODE 'CL:CHARACTER) (* ;  "For common-lisp CHARACTERs, convert it to the char code first.") (SETQ CHARCODE (CL:CHAR-INT CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) (PROG (CBM (FONTDESC (\GETFONTDESC FONT)) CSINFO CWDTH CHGHT) (* ;; "fetch the csinfo for the character set of this character. Bitmaps and widths must be fetched from it") (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (* ;; "(\\fgetwidth (|fetch| (charsetinfo widths) |of| csinfo) (\\char8code charcode))") [SETQ CBM (BITMAPCREATE [SETQ CWDTH (if (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) then (\FGETIMAGEWIDTH (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO) (\CHAR8CODE CHARCODE)) else (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO) (\CHAR8CODE CHARCODE] (SETQ CHGHT (FONTPROP FONTDESC 'HEIGHT)) (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO] (BITBLT (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) (\FGETOFFSET (fetch (CHARSETINFO OFFSETS) of CSINFO) (\CHAR8CODE CHARCODE)) 0 CBM 0 0 CWDTH CHGHT) (RETURN CBM]) (PUTCHARBITMAP [LAMBDA (CHARCODE FONT NEWCHARBITMAP NEWCHARDESCENT) (* ; "Edited 27-Apr-89 11:19 by atm") (* ;; "stores the bitmap NEWCHARBITMAP as the character CHARCODE from the font descriptor FONTDESC. If NEWCHARDESCENT is specified, it is the descent of the new bitmap, and things may be moved to accomodate it.") (OR (TYPENAMEP NEWCHARBITMAP 'BITMAP) (\ILLEGAL.ARG NEWCHARBITMAP)) (COND ((CHARCODEP CHARCODE)) ((OR (STRINGP CHARCODE) (LITATOM CHARCODE)) (SETQ CHARCODE (CHCON1 CHARCODE))) (T (\ILLEGAL.ARG CHARCODE))) (PROG* ((FONTDESC (\GETFONTDESC FONT)) (CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) FONTDESC)) (CDESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (CASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (CHEIGHT (IPLUS CDESCENT CASCENT)) (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (CIMWIDTH (if IMWIDTHS then (\FGETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE)) else NIL)) (CWIDTH (OR CIMWIDTH (CHARWIDTH CHARCODE FONTDESC))) (FONTBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) (OFWIDTH (fetch (BITMAP BITMAPWIDTH) of FONTBITMAP)) TEMPBITMAP BWIDTH DW BHEIGHT BASCENT BDESCENT NDESCENT NASCENT NHEIGHT CHAROFFSET (BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of FONTBITMAP))) (* ;; "fetch the ascents and descents of the bitmap and the new maximums.") (SETQ BWIDTH (fetch (BITMAP BITMAPWIDTH) of NEWCHARBITMAP)) (SETQ BHEIGHT (fetch (BITMAP BITMAPHEIGHT) of NEWCHARBITMAP)) (SETQ BDESCENT (OR NEWCHARDESCENT CDESCENT)) (SETQ BASCENT (IDIFFERENCE BHEIGHT BDESCENT)) (SETQ NDESCENT (IMAX BDESCENT CDESCENT)) (SETQ NASCENT (IMAX BASCENT CASCENT)) (SETQ NHEIGHT (IPLUS NDESCENT NASCENT)) (SETQ CHAROFFSET (\FGETOFFSET OFFSETS (\CHAR8CODE CHARCODE))) (* ;; "set up a new target bitmap if any of the parameters have changed.") (COND ((EQ CHAROFFSET (\FGETOFFSET OFFSETS \MAXTHINCHAR)) (* ;; "changing the bitmap for a character which formerly pointed at the slug character. Allocate a new bitmap character bitmap for this.") (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH BWIDTH) NHEIGHT BITSPERPIXEL)) (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) OFWIDTH CHEIGHT) (* ; "copy the old characters over.") (SETQ CHAROFFSET OFWIDTH)) ((NEQ CWIDTH BWIDTH) (* ;; "The bitmaps differ in width; create a new bitmap with things at the right places, then update widths and offsets.") (SETQ DW (IDIFFERENCE BWIDTH CWIDTH)) (* ; "Difference in character widths") (SETQ TEMPBITMAP (BITMAPCREATE (IPLUS OFWIDTH DW) NHEIGHT BITSPERPIXEL))(* ;  "this may also be a taller bitmap if NHEIGHT is larger than CHEIGHT.") (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) CHAROFFSET CHEIGHT) (* ;  "Copy that portion to the left of the character.") (BITBLT FONTBITMAP (IPLUS CHAROFFSET CWIDTH) 0 TEMPBITMAP (IPLUS CHAROFFSET BWIDTH) (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) (ADD1 (IDIFFERENCE OFWIDTH (IPLUS CHAROFFSET CWIDTH))) CHEIGHT) (* ;  "Copy that portion to the right of the new character.") ) ((OR (IGREATERP BASCENT CASCENT) (IGREATERP BDESCENT CDESCENT)) (* ;; "The new character is TALLER than the existing bitmap. Make a larger bitmap.") (SETQ TEMPBITMAP (BITMAPCREATE OFWIDTH NHEIGHT BITSPERPIXEL)) (BITBLT FONTBITMAP 0 0 TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NDESCENT CDESCENT)) OFWIDTH CHEIGHT) (* ;; "Copy the existing bitmap into it, adjusting for a larger descent in the new character (if there is one)") )) (* ;; "copy the new bitmap in and update parameters.") (BITBLT NEWCHARBITMAP 0 0 (OR TEMPBITMAP FONTBITMAP) CHAROFFSET (IMAX 0 (IDIFFERENCE NDESCENT BDESCENT)) BWIDTH BHEIGHT) [COND (TEMPBITMAP (UNINTERRUPTABLY (* ;; "update the parameters for this character set.") (\FSETWIDTH WIDTHS (\CHAR8CODE CHARCODE) BWIDTH) (* ;  "The new character's correct width") (* ;  "Make sure that we update imagewidths also") (if IMWIDTHS then (\FSETIMAGEWIDTH IMWIDTHS (\CHAR8CODE CHARCODE) BWIDTH)) (\FSETOFFSET OFFSETS (\CHAR8CODE CHARCODE) CHAROFFSET) [COND (DW (for I from 0 to \MAXCHAR do (* ;  "Run thru the offsets of later characters, adjusting them for the changed width of this character") (if (IGREATERP (\FGETOFFSET OFFSETS I) CHAROFFSET) then (\FSETOFFSET OFFSETS I (IPLUS DW (\FGETOFFSET OFFSETS I] (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with TEMPBITMAP ) (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with NDESCENT) (replace (CHARSETINFO CHARSETASCENT) of CSINFO with NASCENT ) (* ;; "update the properties for the font as a whole.") [SETQ NASCENT (IMAX NASCENT (FONTPROP FONTDESC 'ASCENT] [SETQ NDESCENT (IMAX NDESCENT (FONTPROP FONTDESC 'DESCENT] (replace (FONTDESCRIPTOR \SFAscent) of FONTDESC with NASCENT) (replace (FONTDESCRIPTOR \SFDescent) of FONTDESC with NDESCENT) (replace (FONTDESCRIPTOR \SFHeight) of FONTDESC with (IPLUS NDESCENT NASCENT)))] (RETURN NEWCHARBITMAP]) (MOVECHARBITMAP [LAMBDA (SRCECODE SRCEFONT DESTCODE DESTFONT CLIP) (* ; "Edited 14-Dec-86 18:04 by Shih") (* ;;; "moves a character from one font to another, clipping if necessary.") (PROG ((SRCEDESC (\GETFONTDESC SRCEFONT)) (DESTDESC (\GETFONTDESC DESTFONT)) SRCEASCENT SRCEDESCENT DESTASCENT DESTDESCENT CHARBITMAP TEMPBITMAP NEWASCENT NEWDESCENT) (SETQ CHARBITMAP (GETCHARBITMAP SRCECODE SRCEFONT)) (SETQ SRCEASCENT (FONTPROP SRCEDESC 'ASCENT)) (SETQ DESTASCENT (FONTPROP DESTDESC 'ASCENT)) (SETQ SRCEDESCENT (FONTPROP SRCEDESC 'DESCENT)) (SETQ DESTDESCENT (FONTPROP DESTDESC 'DESCENT)) [SETQ NEWASCENT (COND (CLIP DESTASCENT) (T (IMAX SRCEASCENT DESTASCENT] [SETQ NEWDESCENT (COND (CLIP DESTDESCENT) (T (IMAX SRCEDESCENT DESTDESCENT] [COND ((OR (NEQ SRCEASCENT NEWASCENT) (NEQ SRCEDESCENT NEWDESCENT)) (SETQ TEMPBITMAP (BITMAPCREATE (BITMAPWIDTH CHARBITMAP) (IPLUS NEWASCENT NEWDESCENT))) (BITBLT CHARBITMAP 0 (IMAX 0 (IDIFFERENCE SRCEDESCENT NEWDESCENT)) TEMPBITMAP 0 (IMAX 0 (IDIFFERENCE NEWDESCENT SRCEDESCENT)) (BITMAPWIDTH CHARBITMAP) (IMIN (IPLUS SRCEASCENT SRCEDESCENT) (IPLUS NEWASCENT NEWDESCENT] (PUTCHARBITMAP DESTCODE DESTFONT (OR TEMPBITMAP CHARBITMAP) NEWDESCENT]) ) (DEFINEQ (FONTCOPY [LAMBDA FONTSPECS (* ; "Edited 10-Nov-87 17:12 by FS") (* ;  "makes a copy of a font changing the specified fields.") (PROG (NOERROR ERROR FAMILY FACE SIZE ROTATION DEVICE OLDFONT) (* ;; "Set NOERROR if we find it as a prop, but set ERROR if we find a PROP which is illegal. Then just return NIL if NOERROR and ERROR, otherwise, call FONTCREATE.") [SETQ OLDFONT (\GETFONTDESC (ARG FONTSPECS 1) (AND (type? FONTCLASS (ARG FONTSPECS 1)) (COND ((AND (EQ FONTSPECS 2) (LISTP (ARG FONTSPECS 2))) (LISTGET (ARG FONTSPECS 2) 'DEVICE)) (T (for I from 2 by 2 to FONTSPECS do (COND ((AND (NEQ I FONTSPECS) (EQ (ARG FONTSPECS I) 'DEVICE)) (RETURN (ARG FONTSPECS (ADD1 I] (SETQ FAMILY (fetch (FONTDESCRIPTOR FONTFAMILY) of OLDFONT)) (SETQ SIZE (fetch (FONTDESCRIPTOR FONTSIZE) of OLDFONT)) (SETQ FACE (fetch (FONTDESCRIPTOR FONTFACE) of OLDFONT)) (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of OLDFONT)) (SETQ DEVICE (fetch (FONTDESCRIPTOR FONTDEVICE) of OLDFONT)) [for I VAL from 2 by 2 to FONTSPECS do [SETQ VAL (COND ((NOT (EQ I FONTSPECS)) (ARG FONTSPECS (ADD1 I] (SELECTQ (ARG FONTSPECS I) (FAMILY (SETQ FAMILY VAL)) (SIZE (SETQ SIZE VAL)) (FACE (SETQ FACE (\FONTFACE VAL))) (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) (ROTATION (SETQ ROTATION VAL)) (DEVICE (SETQ DEVICE VAL)) (NOERROR (SETQ NOERROR VAL)) (COND [(AND (EQ I 2) (EQ FONTSPECS 2) (LISTP (ARG FONTSPECS 2))) (for J on (ARG FONTSPECS 2) by (CDDR J) do (SETQ VAL (CADR J)) (SELECTQ (CAR J) (FAMILY (SETQ FAMILY VAL)) (SIZE (SETQ SIZE VAL)) (FACE (SETQ FACE (\FONTFACE VAL))) (WEIGHT (SETQ FACE (create FONTFACE using FACE WEIGHT _ VAL))) (SLOPE (SETQ FACE (create FONTFACE using FACE SLOPE _ VAL))) (EXPANSION (SETQ FACE (create FONTFACE using FACE EXPANSION _ VAL))) (BACKCOLOR (SETQ FACE (create FONTFACE using FACE BACKCOLOR _ VAL))) (FORECOLOR (SETQ FACE (create FONTFACE using FACE FORECOLOR _ VAL))) (ROTATION (SETQ ROTATION VAL)) (DEVICE (SETQ DEVICE VAL)) (NOERROR (SETQ NOERROR VAL)) (COND (NOERROR (* ;;  "Fell through the SELECTQ, so an illegal PROP. But, if NOERROR, just note the error, otherwise ") (SETQ ERROR T)) (T (\ILLEGAL.ARG (CAR J] (T (if NOERROR then (SETQ ERROR T) else (\ILLEGAL.ARG (ARG FONTSPECS I] (RETURN (if (AND NOERROR ERROR) then NIL else (FONTCREATE FAMILY SIZE FACE ROTATION DEVICE NOERROR]) (FONTSAVAILABLE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHECKFILESTOO?) (* rrb " 7-Nov-84 15:41") (* ;;; "returns a list of the fonts fitting a description that are available. FAMILY SIZE FACE or ROTATION can be * which means get them all. if LOADEDONLYFLG is non-NIL, only fonts in core will be considered.") (DECLARE (GLOBALVARS IMAGESTREAMTYPES)) (PROG (FONTX DEV) [SETQ DEV (COND ((type? STREAM DEVICE) (COND ((LISTP (SETQ DEV (IMAGESTREAMTYPE DEVICE))) (CAR DEV)) (T DEV))) (DEVICE) (T 'DISPLAY] (RETURN (COND ((LISTP FAMILY) (COND ((EQ (CAR FAMILY) 'FONT) (SETQ FONTX (CDR FAMILY))) (T (SETQ FONTX FAMILY))) (FONTSAVAILABLE (CAR FONTX) (OR (CADR FONTX) SIZE) (OR (CADDR FONTX) FACE) (OR (CADDDR FONTX) ROTATION) DEV CHECKFILESTOO?)) ([SETQ FONTX (COND ((type? FONTDESCRIPTOR FAMILY) FAMILY) ((NULL FAMILY) (DEFAULTFONT DEV)) ((type? FONTCLASS FAMILY) (* ;; "We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class. Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.") (* ;  "I don't know what to do in this case- rrb.") (\COERCEFONTDESC FAMILY DEV T)) ((OR (IMAGESTREAMP FAMILY) (type? WINDOW FAMILY)) (DSPFONT NIL FAMILY] (* ;  "FAMILY was a spec for a font descriptor, use it and extend it by the other args.") (FONTSAVAILABLE (FONTPROP FONTX 'FAMILY) (OR SIZE (FONTPROP FONTX 'SIZE)) (OR FACE (FONTPROP FONTX 'FACE)) (OR ROTATION (FONTPROP FONTX 'ROTATION)) (OR DEVICE (FONTPROP FONTX 'DEVICE)) CHECKFILESTOO?)) (T (PROG ((FONTFACE FACE)) RETRY (OR (LITATOM FAMILY) (LISPERROR "ARG NOT LITATOM" FAMILY T)) (OR (AND (FIXP SIZE) (IGREATERP SIZE 0)) (EQ SIZE '*) (\ILLEGAL.ARG SIZE)) [OR (EQ FONTFACE '*) (SETQ FONTFACE (OR (\FONTFACE FACE T) (RETURN NIL] (OR (U-CASEP FAMILY) (SETQ FAMILY (U-CASE FAMILY))) (COND ((NULL ROTATION) (SETQ ROTATION 0)) ((AND (FIXP ROTATION) (IGEQ ROTATION 0))) ((EQ ROTATION '*)) (T (\ILLEGAL.ARG ROTATION))) (RETURN (UNION (\LOOKUPFONTSINCORE FAMILY SIZE FONTFACE ROTATION DEV) (COND ((NOT CHECKFILESTOO?) NIL) [(EQ DEV '*) (* ; "map thru all the devices.") (for EXTANTDEV in IMAGESTREAMTYPES join (APPLY* (OR (CADR (ASSOC 'FONTSAVAILABLE (CDR EXTANTDEV))) (FUNCTION NILL)) FAMILY SIZE FONTFACE ROTATION (CAR EXTANTDEV] (T (* ;  "apply the device font lookup function.") (APPLY* (OR [CADR (ASSOC 'FONTSAVAILABLE (CDR (ASSOC DEV IMAGESTREAMTYPES ] (FUNCTION NILL)) FAMILY SIZE FONTFACE ROTATION DEV]) (FONTFILEFORMAT [LAMBDA (STRM LEAVEOPEN) (* rmk%: "11-Sep-84 17:16") (* ; "Returns the font format of STRM") [OR (OPENP STRM 'INPUT) (SETQ STRM (OPENSTREAM STRM 'INPUT 'OLD] (PROG1 (SELECTC (\WIN STRM) ((LIST (LLSH 1 15) (LOGOR (LLSH 1 15) (LLSH 1 13))) (* ;; "If high bit of type is on, then must be strike. If 2nd bit is on, must be strike-index, and we punt. We don't care about the 3rd bit") (* ;; "first word has high bits (onebit index fixed). Onebit means 'new-style font' , index is 0 for simple strike, 1 for index, and fixed is if all chars have max width. Lisp doesn't care about 'fixed'") 'STRIKE) ((LOGOR (LLSH 16 8) 12) (* ;; "This is the length of a standard index header. Other files could also have this value, but it's a pretty good discriminator") (* ;; "Skip to byte 25; do it with BINS so works for non-randaccessp devices. This skips the standard name header, then look for type 3 in the following header") (FRPTQ 22 (\BIN STRM)) (* ; "(SETFILEPTR STRM 25)") (AND (EQ 3 (LRSH (\BIN STRM) 4)) 'AC)) NIL) (OR LEAVEOPEN (CLOSEF STRM)))]) (FONTP [LAMBDA (X) (* rmk%: "13-Sep-84 09:04") (* ; "is X a FONTDESCRIPTOR?") (COND ((OR (type? FONTDESCRIPTOR X) (type? FONTCLASS X)) X]) (FONTUNPARSE [LAMBDA (FONT) (* kbr%: "25-Feb-86 19:40") (* ;; "Produces a minimal specification of the font or fontclass specification, for dumping by Tedit, imageobjects.") (PROG (FACE SPEC) (SETQ SPEC (COND ((type? FONTDESCRIPTOR FONT) (FONTPROP FONT 'SPEC)) [(type? FONTCLASS FONT) (RETURN (CONS 'CLASS (FONTCLASSUNPARSE FONT] (T (* ;; "Could be a non-instantiated specification in a fontclass, just use it as the spec without creating the font.") FONT))) (OR SPEC (RETURN)) (SETQ FACE (CADDR SPEC)) (* ;  "FACE and rotation can be NIL for a non-fontdescriptor fontclass component") [SETQ FACE (COND ([OR (NULL FACE) (EQUAL FACE '(MEDIUM REGULAR REGULAR] NIL) ((LITATOM FACE) FACE) [(LISTP FACE) (PACK (LIST* (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE) 1) (NTHCHAR (fetch (FONTFACE SLOPE) of FACE) 1) (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE) 1) (COND ((fetch (FONTFACE COLOR) of FACE) (LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE) "-" (fetch (FONTFACE FORECOLOR) of FACE] (T (SHOULDNT] (* ;  "Don't return device, or any trailing defaults") (RETURN (CONS (CAR SPEC) (CONS (CADR SPEC) (COND ([AND (CADDDR SPEC) (NOT (EQ 0 (CADDDR SPEC] (LIST (OR FACE 'MRR) (CADDDR SPEC))) (FACE (CONS FACE]) (SETFONTDESCRIPTOR [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE FONT) (* ; "Edited 1-Aug-88 16:16 by rmk:") (* ; "Edited 5-Mar-87 19:28 by FS") (* ;; "saves a font descriptor under a family/size/face/rotation/device key so that it will be retreived by FONTCREATE. This is a user entry.") (DECLARE (GLOBALVARS \FONTSINCORE)) (SETQ DEVICE (\DEVICESYMBOL DEVICE)) (* ; "Unpackageify") (AND FONT (SETQ FONT (\COERCEFONTDESC FONT DEVICE))) (* ;  "NIL is used to clobber existing font so that next use will reread it.") (SETQ FAMILY (\FONTSYMBOL FAMILY)) (* ; "Unpackageify") (SETQ FACE (\FONTFACE FACE NIL DEVICE)) (OR ROTATION (SETQ ROTATION 0)) (OR (AND (FIXP SIZE) (IGEQ SIZE 0)) (\ILLEGAL.ARG SIZE)) (PROG [(X (OR (FASSOC FAMILY \FONTSINCORE) (CAR (push \FONTSINCORE (LIST FAMILY] [SETQ X (OR (FASSOC SIZE (CDR X)) (CAR (push (CDR X) (LIST SIZE] [SETQ X (OR (SASSOC FACE (CDR X)) (CAR (push (CDR X) (LIST FACE] (* ; "SASSOC cause FACE is listp") [SETQ X (OR (FASSOC ROTATION (CDR X)) (CAR (push (CDR X) (LIST ROTATION] [SETQ X (OR (FASSOC DEVICE (CDR X)) (CAR (push (CDR X) (LIST DEVICE] (RPLACD X FONT) (RETURN FONT]) (CHARCODEP [LAMBDA (CHCODE) (* gbn "22-Jul-85 16:35") (* ;  "is CHCODE a legal character code?") (AND (SMALLP CHCODE) (IGEQ CHCODE 0) (ILEQ CHCODE \MAXNSCHAR]) (EDITCHAR [LAMBDA (CHARCODE FONT) (* rrb "24-MAR-82 12:22") (* ;  "calls the bitmap editor on a character of a font") (PROG ((FONTDESC (\GETFONTDESC FONT))) (RETURN (PUTCHARBITMAP CHARCODE FONTDESC (EDITBM (GETCHARBITMAP CHARCODE FONTDESC]) (\STREAMCHARWIDTH [LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:31") (* ;; "Returns the width that the printed representation of CHARCODE would occupy if printed on STREAM, allowing for the various escape sequences. Used by \ECHOCHAR") (SETQ CHARCODE (LOGAND CHARCODE \CHARMASK)) ((LAMBDA (WIDTHSVECTOR) (* ;; "Note in following that if the DDWIDTHSCACHE exists and has a 0 entry for some character, that may someday mean that the character's glyph simply isn't loaded; e.g., it may want #^A") (SETQ WIDTHSVECTOR (OR (AND (DISPLAYSTREAMP STREAM) (SETQ WIDTHSVECTOR (ffetch IMAGEDATA of STREAM)) (ffetch DDWIDTHSCACHE of WIDTHSVECTOR)) \UNITWIDTHSVECTOR)) (SELECTC (fetch CCECHO of (\SYNCODE (fetch (TERMTABLEP TERMSA) of (OR (TERMTABLEP TTBL) \PRIMTERMTABLE)) CHARCODE)) (INDICATE.CCE ([LAMBDA (CC) (IPLUS (if (IGEQ CHARCODE (CHARCODE %#^@)) then (* ;  "A META charcode -- implies that the 8th bit is non-zero") (SETQ CC (LOADBYTE CHARCODE 0 7)) (\FGETWIDTH WIDTHSVECTOR (CHARCODE %#)) else 0) (if (ILESSP CC (CHARCODE SPACE)) then (* ; "A CONTROL charcode") (add CC (CONSTANT (LLSH 1 6))) (\FGETWIDTH WIDTHSVECTOR (CHARCODE ^)) else 0) (\FGETWIDTH WIDTHSVECTOR CC] CHARCODE)) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF BELL) NIL) (ESCAPE (\FGETWIDTH WIDTHSVECTOR (CHARCODE $))) (TAB (PROG ((SPACEWIDTH (\FGETWIDTH WIDTHSVECTOR (CHARCODE SPACE))) (NEWXPOSITON (DSPXPOSITION NIL STREAM)) TABWIDTH) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) [add NEWXPOSITON (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (IMOD (IDIFFERENCE NEWXPOSITON (DSPLEFTMARGIN NIL STREAM)) TABWIDTH] (RETURN (if (IGREATERP NEWXPOSITON (DSPRIGHTMARGIN NIL STREAM)) then (* ;  "tab was past rightmargin, force cr.") NIL else TABWIDTH)))) (\FGETWIDTH WIDTHSVECTOR CHARCODE))) (REAL.CCE (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) NIL) (ERASECHARCODE NIL) (\FGETWIDTH WIDTHSVECTOR CHARCODE))) (IGNORE.CCE 0) (SHOULDNT]) (\UNITWIDTHSVECTOR [LAMBDA NIL (* JonL " 7-NOV-83 19:23") (SETQ \UNITWIDTHSVECTOR (\ALLOCBLOCK (UNFOLD (IPLUS \MAXCHAR 3) WORDSPERCELL))) (for I from 0 to (IPLUS \MAXCHAR 2) do (\PUTBASE \UNITWIDTHSVECTOR I 1)) \UNITWIDTHSVECTOR]) (\CREATEDISPLAYFONT [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* gbn%: "25-Jan-86 18:02") (PROG [(FONTDESC (create FONTDESCRIPTOR FONTDEVICE _ DEVICE FONTFAMILY _ FAMILY FONTSIZE _ SIZE FONTFACE _ FACE \SFAscent _ 0 \SFDescent _ 0 \SFHeight _ 0 ROTATION _ ROTATION FONTDEVICESPEC _ (LIST FAMILY SIZE FACE ROTATION DEVICE] (RETURN (COND ((\GETCHARSETINFO CHARSET FONTDESC T) FONTDESC) (T NIL]) (\CREATECHARSET.DISPLAY [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* ; "Edited 14-Jan-88 23:42 by FS") (* ;; "Color Stuff removed -FS.") (* ;; "Replace Cond below with") (* ;; "(PROG (XCSINFO)") (* ;; "(SETQ XCSINFO &)") (* ;; "(COND ((FMEMB DEVICE \\COLORDISPLAYSTREAMTYPES) (SETQ XCSINFO (\\SFMAKECOLOR XCSINFO (OR (|fetch| (FONTFACE BACKCOLOR) |of| FACE) 0) (OR (|fetch| (FONTFACE FORECOLOR) |of| FACE) (MAXIMUMCOLOR (\\DISPLAYSTREAMTYPEBPP DEVICE))) (\\DISPLAYSTREAMTYPEBPP DEVICE)))))") (* ;; "(RETURN XCSINFO)))") (* ;;; "tries to build the csinfo required for CHARSET. Does the necessary coercions.") (* ;;; "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (DECLARE (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS)) (* ;; "DISPLAYFONTCOERCIONS is a list of font coercions, in the form ((user-font real-font) (user-font real-font) ...). Each user-font is a list of FAMILY, and optionally SIZE and CHARSET, (e.g., (GACHA) or (GACHA 10) or (GACHA 10 143)), and each real-font is a similar list.") (COND ((PROG1 (for TRANSL in DISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT when (AND (SETQ UFONT (CAR TRANSL)) (EQ FAMILY (CAR UFONT)) (OR (NOT (CADR UFONT)) (EQ SIZE (CADR UFONT))) (OR (NOT (CADDR UFONT)) (EQ CHARSET (CADDR UFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\CREATECHARSET.DISPLAY (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO)) (* ;  "Just recursively call ourselves to handle entries in DISPLAYFONTCOERCIONS") )) (T (* ;; "One weirdness is, if you have a coercion, and the real-font is missing, you can't get a missingfont coercion on the user-font because the real-font missingfont coercion shadows it out.") (\CREATE-REAL-CHARSET.DISPLAY FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG? ]) (\CREATE-REAL-CHARSET.DISPLAY [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* ; "Edited 15-Jan-88 00:02 by FS") (COND [(AND (EQ ROTATION 0) (PROG1 (\READDISPLAYFONTFILE FAMILY SIZE FACE ROTATION 'DISPLAY CHARSET) (* ;  "If it is available, this will force the appropriate file to be read to fill in the charset entry") ] (T (* ;; "if we get here, the font is not directly available, either it needs to be rotated, boldified, or italicised 'by hand'. Past that point, we do not allow DISPLAYFONTCOERCIONS, only MISSINGxxxxDISPLAYFONTCOERCIONS.") (PROG (NEWFONT XFONT XLATEDFAM CSINFO) (RETURN (COND [(NEQ ROTATION 0) (* ;; "to make a rotated font (even if it is bold or whatnot), recursively call fontcreate to get the unrotated font (maybe bold, etc), then call \SFMAKEROTATEDFONT on the csinfo. If its still missing, then search for missing display font coercions (e.g. no avail. charset, *but*, do not recurse (avoid getting into infinite loops). This allows partial permutations of fonts.") (OR (MEMB ROTATION '(90 270)) (ERROR "only implemented rotations are 0, 90 and 270." ROTATION)) (COND ((SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE FACE 0 'DISPLAY CHARSET)) (* ;; "Do not call FONTCREATE here. The user might have modified (via PUTCHARBITMAP, etc.) the in-memory version of the source. This also fixes a bug in which several font descriptors ended up sharing bitmaps or charsetvectors, causing havoc when the user modifies either fontdescriptor.") (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFROTATECSINFO CSINFO ROTATION) else NIL] ((AND (EQ (fetch WEIGHT of FACE) 'BOLD) (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE (create FONTFACE using FACE WEIGHT _ 'MEDIUM) 0 'DISPLAY CHARSET))) (* ;; "if we want a bold font, and the medium weight font is available, build the medium weight version then call \SFMAKEBOLD on the csinfo") (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFMAKEBOLD CSINFO) else NIL)) ((AND (EQ (fetch (FONTFACE SLOPE) of FACE) 'ITALIC) (SETQ XFONT (\CREATEDISPLAYFONT FAMILY SIZE (create FONTFACE using FACE SLOPE _ 'REGULAR) 0 'DISPLAY CHARSET))) (if (SETQ CSINFO (\GETCHARSETINFO CHARSET XFONT T)) then (\SFMAKEITALIC CSINFO) else NIL)) [(AND CHARSET (NOT (EQL 0)) (for TRANSL in MISSINGCHARSETDISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT when (AND (SETQ UFONT (CAR TRANSL)) (EQ FAMILY (CAR UFONT)) (OR (NOT (CADR UFONT)) (EQ SIZE (CADR UFONT))) (OR (NOT (CADDR UFONT)) (EQ CHARSET (CADDR UFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO] ((for TRANSL in MISSINGDISPLAYFONTCOERCIONS bind NEWCSINFO UFONT REALFONT when (AND (SETQ UFONT (CAR TRANSL)) (EQ FAMILY (CAR UFONT)) (OR (NOT (CADR UFONT)) (EQ SIZE (CADR UFONT))) (OR (NOT (CADDR UFONT)) (EQ CHARSET (CADDR UFONT))) (SETQ REALFONT (CADR TRANSL)) (SETQ NEWCSINFO (\CREATE-REAL-CHARSET.DISPLAY (OR (CAR REALFONT) FAMILY) (OR (CADR REALFONT) SIZE) FACE ROTATION DEVICE (OR (CADDR REALFONT) CHARSET) FONTDESC NOSLUG?))) do (RETURN NEWCSINFO))) ((NOT NOSLUG?) (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC) (FONTPROP FONTDESC 'ASCENT) (FONTPROP FONTDESC 'DESCENT) (FONTPROP FONTDESC 'DEVICE]) (\BUILDSLUGCSINFO [LAMBDA (WIDTH ASCENT DESCENT DEVICE SCALE) (* ; "Edited 9-May-93 23:12 by rmk:") (* ;;; "builds a csinfo which contains only the slug (black rectangle) character. Called only for display.") (SETQ SCALE (OR SCALE 1)) (PROG ((CSINFO (create CHARSETINFO CHARSETASCENT _ ASCENT CHARSETDESCENT _ DESCENT)) WIDTHS OFFSETS BITMAP IMAGEWIDTHS) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I WIDTH)) (REPLACE IMAGEWIDTHS OF CSINFO WITH WIDTHS) (replace (CHARSETINFO OFFSETS) of CSINFO with (SETQ OFFSETS ( \CREATECSINFOELEMENT ))) (for I from 0 to \MAXTHINCHAR do (\FSETOFFSET OFFSETS I 0)) [replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (SETQ BITMAP (BITMAPCREATE (ROUND (QUOTIENT WIDTH SCALE)) (ROUND (QUOTIENT (IPLUS ASCENT DESCENT) SCALE] [BLTSHADE BLACKSHADE BITMAP 1 NIL (SUB1 (ROUND (QUOTIENT WIDTH SCALE] (RETURN CSINFO]) (\SEARCHDISPLAYFONTFILES [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 5-Mar-87 18:55 by FS") (* ;; " This function called via APPLY in IMAGESTREAMTYPES.") (* ;; " Returns a list of the fonts that can be read in for displaylike devices. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") (* ;; " Note we *allow* a device that is not 'DISPLAY for guys like 4DISPLAY, 8DISPLAY, 24DISPLAY, and also possibly for FX80, etc. (guys that want DISPLAYFONTS anyway). Should have some hook though for FONTEXTENSIONS, FONTDIRECTORIES??") (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES)) (SELECTQ (SYSTEMTYPE) (D (\SEARCHFONTFILES FAMILY SIZE FACE ROTATION DEVICE DISPLAYFONTDIRECTORIES DISPLAYFONTEXTENSIONS)) (J (* OLD J code from \READDISPLAYFONT  (PROG ((FONTFILE (\FONTFILENAME  FAMILY SIZE FACE)) FONTDESC STRM)  (COND ((SETQ STRM (AND  FONTDIRECTORIES (FINDFILE FONTFILE T  FONTDIRECTORIES)))  (SETQ STRM (OPENSTREAM FONTFILE  (QUOTE INPUT))) (SETQ FONTDESC  (\READJERICHOFONTFILE FAMILY SIZE  FACE STRM)) (CLOSEF STRM)))  (RETURN FONTDESC))) NIL) (SHOULDNT]) (\SEARCHFONTFILES [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE DIRLST EXTLST) (* ; "Edited 14-Sep-96 10:54 by rmk:") (* ; "Edited 6-Oct-89 12:34 by bvm") (* ;; "GENERIC FUNCTION") (* ;; "returns a list of the fonts that can be read in for a device. Rotation is ignored because it is assumed that all devices support 0 90 and 270.") (SETQ FAMILY (\FONTSYMBOL FAMILY)) (SETQ DEVICE (\FONTSYMBOL DEVICE)) (SETQ FACE (\FONTFACE FACE)) (BIND (FILING.ENUEMRATION.DEPTH _ 1) FONTSFOUND THISFONT THISFACE FOR E INSIDE EXTLST DO [FOR DIR INSIDE DIRLST BIND (FILEPATTERN _ (IF (FMEMB E *OLD-FONT-EXTENSIONS*) THEN (\FONTFILENAME.OLD FAMILY SIZE FACE E) ELSE (\FONTFILENAME FAMILY SIZE FACE E))) DO (* ;; "Hack above to handle both old and new font file names. The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup. If set to a list of extensions, just those will be looked up with old-style conventions") (FOR FONTFILE IN (DIRECTORY (PACKFILENAME.STRING 'DIRECTORY DIR 'BODY FILEPATTERN)) WHEN [PROGN (SETQ THISFONT (\FONTINFOFROMFILENAME FONTFILE DEVICE)) (SETQ THISFACE (CADDR THISFONT)) (* ;;  "make sure the face, size, and family really match.") (AND (NOT (MEMBER THISFONT FONTSFOUND)) (OR (EQ FAMILY '*) (EQ FAMILY (CAR THISFONT))) (OR (EQ SIZE '*) (EQ SIZE (CADR THISFONT))) (OR (EQ FACE '*) (EQUAL FACE THISFACE) (AND (OR (EQ (CAR FACE) '*) (EQ (CAR FACE) (CAR THISFACE))) (OR (EQ (CADR FACE) '*) (EQ (CADR FACE) (CADR THISFACE))) (OR (EQ (CADDR FACE) '*) (EQ (CADDR FACE) (CADDR THISFACE] DO (SETQ FONTSFOUND (CONS THISFONT FONTSFOUND] FINALLY (RETURN FONTSFOUND]) (\FINDFONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST) (* ; "Edited 14-Sep-96 10:53 by rmk:") (* ; "Edited 6-Oct-89 11:18 by bvm") (* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup. If set to a list of extensions, just those will be looked up with old-style conventions.") (BIND FONTFILE FOR EXT INSIDE EXTLST WHEN (SETQ FONTFILE (FINDFILE (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*) THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT CHARSET) ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)) T DIRLST)) DO (RETURN FONTFILE]) (\FONTSYMBOL [LAMBDA (X ElseReturnXFlg) (* ; "Edited 28-Jul-88 11:59 by rmk:") (* ; "Edited 24-Mar-87 14:32 by FS") (* ;; "Return a symbol in IL package and is in uppercase. Currently the function IL:U-CASE is believed to do this, but if it changes, this is the font hook. ElseReturnXFlg is if you want an IL symbol if X is a symbol or string, otherwise just X.") (COND ((LITATOM X) (U-CASE X)) ((STRINGP X) (MKATOM (U-CASE X))) (ElseReturnXFlg X) (T (ERROR "Want an IL symbol"]) (\DEVICESYMBOL [LAMBDA (X ElseReturnXFlg) (* ; "Edited 7-Oct-88 20:07 by rmk:") (* ; "Edited 28-Jul-88 14:43 by rmk:") (* ; "Edited 24-Mar-87 14:33 by FS") (* ;; "Return a canonicalized atom good for comparing with DEVICE symbols") (LET ((STRM (\GETSTREAM X 'OUTPUT T))) (COND (STRM (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of STRM))) ((NULL X) 'DISPLAY) (T (* ; "because its used in ASSOC.") (\FONTSYMBOL X ElseReturnXFlg]) (\FONTFACE [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 1-Aug-88 09:44 by rmk:") (* ; "Edited 28-Jul-88 15:50 by rmk:") (* ; "Edited 28-Jul-88 15:49 by rmk:") (* ; "Edited 28-Jul-88 15:41 by rmk:") (* ; "Edited 28-Jul-88 15:38 by rmk:") (* ; "Edited 28-Jul-88 14:44 by rmk:") (* ; "Edited 25-Feb-87 22:58 by FS") (* ;; "Coerces FACE into standard FONTFACE record, usually returns a CONSTANT (so you'd better not RPLACD or REPLACE fields!!)") (PROG (UNKNOWN (WEIGHT 'MEDIUM) (SLOPE 'REGULAR) (EXPANSION 'REGULAR) (OLDFACE FACE)) (* ;; "On error, can signal, or return NIL, or return REGULAR face.") [SETQ UNKNOWN (COND ((EQ NOERRORFLG 'REGULAR) 'REGULAR) (T 'ERROR] [COND ((type? FONTFACE FACE) (* ;; "List Case. Unpack because want to validate fields") (SETQ WEIGHT (fetch (FONTFACE WEIGHT) of FACE)) (SETQ SLOPE (fetch (FONTFACE SLOPE) of FACE)) (SETQ EXPANSION (fetch (FONTFACE EXPANSION) of FACE)) (* ;; "Handle unknown faces") [OR (\FONT.SYMBOLMEMB WEIGHT ' (* BOLD MEDIUM LIGHT)) (SETQ WEIGHT (COND ((\FONT.COMPARESYMBOL WEIGHT 'REGULAR) (* ;; "Clean up WEIGHT REGULAR vs. MEDIUM") (SETQ WEIGHT 'MEDIUM)) (T UNKNOWN] (OR (\FONT.SYMBOLMEMB SLOPE ' (* REGULAR ITALIC)) (SETQ SLOPE UNKNOWN)) (OR (\FONT.SYMBOLMEMB EXPANSION ' (* COMPRESSED REGULAR EXPANDED)) (SETQ EXPANSION UNKNOWN))) ((OR (LITATOM FACE) (STRINGP FACE)) (COND ((NULL FACE) (* ; "Fast vanilla default") ) ((EQ (NCHARS FACE) 3) (* ; "3 char notation case") (SETQ WEIGHT (SELCHARQ (CHCON1 FACE) ((B b) 'BOLD) ((M m R r) 'MEDIUM) ((L l) 'LIGHT) UNKNOWN)) (SETQ SLOPE (SELCHARQ (NTHCHARCODE FACE 2) ((R r) 'REGULAR) ((I i) 'ITALIC) UNKNOWN)) (SETQ EXPANSION (SELCHARQ (NTHCHARCODE FACE 3) ((R r) 'REGULAR) ((C c) 'COMPRESSED) ((E e) 'EXPANDED) UNKNOWN))) ((SELECTQ FACE (BOLD (SETQ WEIGHT 'BOLD)) (ITALIC (SETQ SLOPE 'ITALIC)) (BOLDITALIC (SETQ WEIGHT 'BOLD) (SETQ SLOPE 'ITALIC)) ((STANDARD REGULAR) T) NIL)) ((\FONT.COMPARESYMBOL FACE 'BOLD) (SETQ WEIGHT 'BOLD)) ((\FONT.COMPARESYMBOL FACE 'ITALIC) (SETQ SLOPE 'ITALIC)) ((\FONT.COMPARESYMBOL FACE 'BOLDITALIC) (SETQ WEIGHT 'BOLD) (SETQ SLOPE 'ITALIC)) ((\FONT.SYMBOLMEMB FACE '(STANDARD REGULAR NIL NNN)) (* ; "Vanilla case") ) ((STRPOS "-" FACE) (* ; "Color fontface spec!") (SETQ FACE (\FONTFACE.COLOR FACE NOERRORFLG DEV)) (RETURN FACE)) ((\FONT.SYMBOLMEMB FACE ' (* ***)) (* ; "Wildcard case") (SETQ WEIGHT '*) (SETQ SLOPE '*) (SETQ EXPANSION '*)) (T (* ; "Other litatom error case") (SETQ WEIGHT UNKNOWN) (SETQ SLOPE UNKNOWN) (SETQ EXPANSION UNKNOWN] (if (OR (EQ WEIGHT 'ERROR) (EQ SLOPE 'ERROR) (EQ EXPANSION 'ERROR)) then (if NOERRORFLG then (RETURN NIL) else (\ILLEGAL.ARG OLDFACE))) (* ;; "Avoid consing by returning constant faces (historical: really, would have been better to return MRR, but users have know about this for too long (rmk))") (RETURN (COND ((AND (EQ WEIGHT 'MEDIUM) (EQ SLOPE 'REGULAR) (EQ EXPANSION 'REGULAR)) (* ; "MRR") (CONSTANT (create FONTFACE))) [(AND (EQ WEIGHT 'BOLD) (EQ SLOPE 'REGULAR) (EQ EXPANSION 'REGULAR)) (* ; "BRR") (CONSTANT (create FONTFACE WEIGHT _ 'BOLD] [(AND (EQ WEIGHT 'MEDIUM) (EQ SLOPE 'ITALIC) (EQ EXPANSION 'REGULAR)) (* ; "MIR") (CONSTANT (create FONTFACE SLOPE _ 'ITALIC] [(AND (EQ WEIGHT 'BOLD) (EQ SLOPE 'ITALIC) (EQ EXPANSION 'REGULAR)) (* ; "BIR") (CONSTANT (create FONTFACE WEIGHT _ 'BOLD SLOPE _ 'ITALIC] (T (* ; "Otherwise, cons up") (create FONTFACE WEIGHT _ WEIGHT SLOPE _ SLOPE EXPANSION _ EXPANSION]) (\FONTFACE.COLOR [LAMBDA (FACE NOERRORFLG DEV) (* ; "Edited 28-Jul-88 14:51 by rmk:") (* ; "Edited 28-Jul-88 13:09 by rmk:") (* ; "Edited 24-Mar-87 17:03 by FS") (* ;; "This used to be \FONTFACE. Renamed \FONTFACE.COLOR, and \FONTFACE rewritten. The section below should also be redone") (* ;; "Takes a variety of user specifications and converts them to a standard FONTFACE record.") (* ;; "b/w fontfaces are extended by an optional '-backcolor-forecolor'") (* ;; "the atom NNN is interpreted the same as NIL or MRR to cover up a bug described in AR 3025, the FONTNNN bug") (DECLARE (GLOBALVARS \COLORDISPLAYSTREAMTYPES)) (SETQ DEV (\DEVICESYMBOL DEV)) (PROG (BWFACE POS OLDPOS BITSPERPIXEL BACKCOLOR FORECOLOR ANSWER) (* ;; "First get a FONTFACE ANSWER.") [SETQ ANSWER (COND ((type? FONTFACE FACE) FACE) ((LITATOM FACE) (OR (U-CASEP FACE) (SETQ FACE (U-CASE FACE))) (SETQ POS (STRPOS "-" FACE)) (COND [POS (SETQ BWFACE (SUBATOM FACE 1 (SUB1 POS] (T (SETQ BWFACE FACE))) [SETQ ANSWER (SELECTQ BWFACE ((* ***) (CONSTANT (create FONTFACE WEIGHT _ '* SLOPE _ '* EXPANSION _ '*))) ((NIL MRR STANDARD NNN) (CONSTANT (create FONTFACE))) ((ITALIC MIR) (CONSTANT (create FONTFACE SLOPE _ 'ITALIC))) ((BOLD BRR) (CONSTANT (create FONTFACE WEIGHT _ 'BOLD))) ((BOLDITALIC BIR) (CONSTANT (create FONTFACE WEIGHT _ 'BOLD SLOPE _ 'ITALIC))) (create FONTFACE WEIGHT _ (SELCHARQ (NTHCHARCODE FACE 1) (M 'MEDIUM) (B 'BOLD) (L 'LIGHT) (GO ERROR)) SLOPE _ (SELCHARQ (NTHCHARCODE FACE 2) (R 'REGULAR) (I 'ITALIC) (GO ERROR)) EXPANSION _ (SELCHARQ (NTHCHARCODE FACE 3) (R 'REGULAR) (C 'COMPRESSED) (E 'EXPANDED) (GO ERROR] (COND (POS (* ; "Color FONTFACE. *") (SETQ OLDPOS POS) (SETQ POS (STRPOS "-" FACE (ADD1 OLDPOS))) (COND ((NULL POS) (GO ERROR))) (SETQ BITSPERPIXEL (\DISPLAYSTREAMTYPEBPP DEV)) (SETQ BACKCOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS) (SUB1 POS)) BITSPERPIXEL)) (SETQ OLDPOS POS) (SETQ FORECOLOR (COLORNUMBERP (SUBATOM FACE (ADD1 OLDPOS) -1) BITSPERPIXEL)) (* ;  "COPY ANSWER to avoid smashing constants.") (SETQ ANSWER (COPY ANSWER)) (replace (FONTFACE BACKCOLOR) of ANSWER with BACKCOLOR ) (replace (FONTFACE FORECOLOR) of ANSWER with FORECOLOR ))) ANSWER) (T (GO ERROR] (* ;; "Coerce on or off COLOR.") (SETQ ANSWER (COND ((AND (NOT (FMEMB DEV \COLORDISPLAYSTREAMTYPES)) (fetch (FONTFACE COLOR) of ANSWER)) (SETQ ANSWER (COPY ANSWER)) (replace (FONTFACE COLOR) of ANSWER with NIL) ANSWER) ((AND (FMEMB DEV \COLORDISPLAYSTREAMTYPES) (NULL (fetch (FONTFACE COLOR) of ANSWER))) (SETQ FACE (COPY FACE)) (replace (FONTFACE BACKCOLOR) of ANSWER with 0) (replace (FONTFACE FORECOLOR) of ANSWER with (MAXIMUMCOLOR ( \DISPLAYSTREAMTYPEBPP DEV))) ANSWER) (T ANSWER))) (RETURN ANSWER) ERROR (COND (NOERRORFLG (RETURN NIL)) (T (\ILLEGAL.ARG FACE]) (\FONTFILENAME [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 5-Mar-93 16:10 by rmk:") (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported. New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD") (* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>. This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets). This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*") (SETQ FACE (\FONTFACE FACE)) (* ; "Validate face") (LET* ([SIZEPATT (COND ((EQ SIZE '*) SIZE) ((FIXP SIZE) (if (< SIZE 10) then (CONCAT 0 SIZE) else SIZE)) (T (\ILLEGAL.ARG SIZE] (CSETNAME (COND ((OR (NULL CHARSET) (EQ CHARSET 0)) (* ; "Charset defaults to zero.") "0") ((FIXP CHARSET) (LET ((*PRINT-BASE* 8) (*PRINT-RADIX* NIL)) (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling") (\PRINDATUM.TO.STRING CHARSET))) (T (* ;  "Somebody made the string already?") CHARSET))) [FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE)) (CHCON1 (fetch (FONTFACE SLOPE) of FACE)) (CHCON1 (fetch (FONTFACE EXPANSION) of FACE] (TAIL FACESPEC)) [if (OR (EQ (CAR TAIL) (CHARCODE *)) (EQ (CAR (SETQ TAIL (CDR TAIL))) (CHARCODE *))) then (* ;  "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.") (while (EQ (CADR TAIL) (CHARCODE *)) do (RPLACD TAIL (CDDR TAIL] (* ;; "Fortunately, CONCAT ignores packages.") (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF *USEOLDFONTDIRECTORIES* "" (CONCAT (PROGN (* ;  "Lowercase because it's in a directory name, so maybe Unix will find it sooner?") "c") CSETNAME ">")) FAMILY SIZEPATT "-" (CONCATCODES FACESPEC) "-C" CSETNAME) 'EXTENSION EXTENSION]) (\FONTFILENAME.OLD [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 23-Sep-92 18:22 by jds") (* ;; "Returns old style font file names. They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc. Keep this function around though for user's who don't rename their files.") (* ;  "Returns the name of the file that should contain the information for a font.") (SETQ FACE (\FONTFACE FACE)) (* ; "Force legal canonical face") (SETQ FACE (COND ((AND (EQ (CAR FACE) '*) (EQ (CADR FACE) '*)) (* ;; "Avoid adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime). No need to check compression.") '*) (T FACE))) (PACKFILENAME.STRING 'NAME [PROGN (* ;; "DISPLAYFONT AC WD and the default case") (CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*)) (COND ((EQ SIZE '*) SIZE) ((FIXP SIZE) (COND ((< SIZE 10) (CONCAT 0 SIZE)) (T SIZE))) (T (\ILLEGAL.ARG SIZE))) [COND ((EQ FACE '*) '*) (T (SELECTQ (fetch WEIGHT of FACE) (BOLD (SELECTQ (fetch SLOPE of FACE) (ITALIC "D") "B")) (SELECTQ (fetch SLOPE of FACE) (ITALIC "I") "R"] (COND ((FIXP CHARSET) (LET ((*PRINT-BASE* 8)) (CL:FORMAT NIL "~O" CHARSET))) (T "000"] 'EXTENSION EXTENSION]) (\FONTFILENAME.NEW [LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 30-Mar-87 20:00 by FS") (* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.") (LET (NAME SIZEPATT) (SETQ FACE (\FONTFACE FACE)) (* ; "Validate face") [SETQ SIZEPATT (COND ((EQ SIZE '*) SIZE) ((FIXP SIZE) (if (< SIZE 10) then (CONCAT 0 SIZE) else SIZE)) (T (\ILLEGAL.ARG SIZE] (* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower. Nicely, PACK & CONCAT ignore packages.") (PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-" [COND ((EQUAL FACE ' (* * *) ) '*) (T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT) of FACE) 1) (NTHCHAR (fetch (FONTFACE SLOPE) of FACE) 1) (NTHCHAR (fetch (FONTFACE EXPANSION) of FACE) 1] (COND [(FIXP CHARSET) (LET ((*PRINT-BASE* 8)) (CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET] (CHARSET (CONCAT "-C" CHARSET)) (T "-C0"))) 'EXTENSION EXTENSION]) (\FONTINFOFROMFILENAME [LAMBDA (FONTFILE DEVICE) (* ; "Edited 14-Sep-96 10:23 by rmk:") (* ; "Edited 5-Oct-89 18:28 by bvm") (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE. Rotation is 0 always. Parses both new & old format files.") (LET ((FILENAMELIST (UNPACKFILENAME.STRING FONTFILE)) CH SIZEBEG SIZEND NAME FAMILY SIZE FACE EXT) (SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ;  "find where the name and size are. MUST check for ch nil below or possible infinite loop") (SETQ SIZEBEG (for CH# from 1 when (OR (NUMBERP (SETQ CH (NTHCHAR NAME CH#))) (NULL CH)) do (RETURN CH#))) (* ;; "Get Family") [SETQ FAMILY (MKATOM (U-CASE (SUBSTRING NAME 1 (SUB1 SIZEBEG] (* ;; "Get Size") [SETQ SIZEND (find CH# from SIZEBEG suchthat (NOT (NUMBERP (NTHCHAR NAME CH#] [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND] (if (EQ (NTHCHAR NAME SIZEND) '-) then (SETQ SIZEND (ADD1 SIZEND))) (* ;; "Get Face") (SETQ NAME (U-CASE NAME)) (* ;  "don't need name, but checks for lowercase face") [SETQ FACE (LIST (COND ((STRPOS "B" NAME SIZEND NIL T NIL UPPERCASEARRAY) 'BOLD) ((STRPOS "L" NAME SIZEND NIL T NIL UPPERCASEARRAY) 'LIGHT) (T 'MEDIUM)) (COND ((STRPOS "I" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) 'ITALIC) (T 'REGULAR)) (COND ((STRPOS "E" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) 'EXPANDED) ((STRPOS "C-" NAME SIZEND NIL NIL NIL UPPERCASEARRAY) 'COMPRESSED) (T 'REGULAR] (LIST FAMILY SIZE FACE 0 (COND ((STREAMP DEVICE) (IMAGESTREAMTYPE DEVICE)) ((NULL DEVICE) [SETQ EXT (MKATOM (U-CASE (LISTGET FILENAMELIST 'EXTENSION] (SELECTQ EXT (WD 'INTERPRESS) ((STRIKE AC DISPLAYFONT) 'DISPLAY) EXT)) ((LITATOM DEVICE) (\FONTSYMBOL DEVICE)) (T DEVICE]) (\FONTINFOFROMFILENAME.OLD [LAMBDA (FONTFILE DEVICE) (* ; "Edited 1-Jan-87 01:29 by FS") (* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.") (PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE)) SIZEBEG SIZEND NAME FAMILY SIZE) (SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ;  "find where the name and size are.") (SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#)) do (RETURN CH#))) [SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG] (SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#))) do (RETURN CH#))) [SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND] (RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION) ((DISPLAYFONT AC WD) (LIST (COND ((STRPOS "-B" NAME SIZEND NIL T) 'BOLD) (T 'MEDIUM)) (COND ((STRPOS "-I" NAME SIZEND NIL) 'ITALIC) (T 'REGULAR)) 'REGULAR)) (LIST (COND ((STRPOS "B" NAME SIZEND NIL T) 'BOLD) (T 'MEDIUM)) (COND ((STRPOS "I" NAME SIZEND NIL) 'ITALIC) (T 'REGULAR)) 'REGULAR)) 0 DEVICE]) (\GETFONTDESC [LAMBDA (SPEC DEVICE NOERRORFLG) (* J.Gibbons " 5-Dec-82 16:53") (* ;; "Coerces SPEC to a fontdescriptor") (* ;  "\GETFONTDESC HAS MACRO, BUT OLD CALLS STILL EXIST") (\COERCEFONTDESC SPEC DEVICE NOERRORFLG]) (\COERCEFONTDESC [LAMBDA (SPEC STREAM NOERRORFLG) (* ; "Edited 29-Aug-91 12:19 by jds") (* ;; "Coerces SPEC to a fontdescriptor appropriate for STREAM. Go back thru FONTCREATE for various coercions in order to make sure that the cache gets set up") (DECLARE (GLOBALVARS DEFAULTFONT)) (PROG (FONT DEVICE) [COND ((type? FONTDESCRIPTOR SPEC) (SETQ FONT SPEC)) [(type? FONTCLASS SPEC) [SETQ DEVICE (COND ((NULL STREAM) (* ; "Default is display") (* ;; "COULDN'T THIS BRANCH BE INTENDED TO MEAN 4DISPLAY, 8DISPLAY, 24DISPLAY? PEOPLE PROBABLY SHOULDN'T BE CALLING \COERCEFONTDESC WITH STREAM = NIL.") 'DISPLAY) ((IMAGESTREAMP STREAM) (IMAGESTREAMTYPE STREAM)) ((LITATOM STREAM) (\DEVICESYMBOL STREAM)) (STREAM STREAM) (T (* ;; "I don't think this case should be allowed.") 'DISPLAY] [SETQ FONT (SELECTQ DEVICE (DISPLAY (fetch (FONTCLASS DISPLAYFD) of SPEC)) (INTERPRESS (fetch (FONTCLASS INTERPRESSFD) of SPEC)) (PRESS (fetch (FONTCLASS PRESSFD) of SPEC)) (CDR (SASSOC DEVICE (fetch (FONTCLASS OTHERFDS) of SPEC] (RETURN (COND ((type? FONTDESCRIPTOR FONT) (* ;;  "We don't always create FD's for devices before they are needed, so do it now and save result") FONT) [(NULL FONT) (* ;; "NIL means create FONT but don't cache.") (COND ((AND (FMEMB DEVICE \DISPLAYSTREAMTYPES) (SETQ FONT (\COERCEFONTDESC SPEC 'DISPLAY NOERRORFLG)) (SETQ FONT (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG)) ) (* ;;  "Coerce existing black & white font to color font, but don't cache.") FONT) [(EQ SPEC DEFAULTFONT) (* ;; "Break cycles with NIL in the defaultfont") (COND (NOERRORFLG NIL) ((EQ DEVICE 'DISPLAY) (* ;; "Function DEFAULTFONT guarantees system integrity") (DEFAULTFONT 'DISPLAY)) ((EQUAL DEVICE '(HARDCOPY DISPLAY)) (* ;;  "MAKE DISPLAY-HARDCOPY FONTS default to the corresponding display font, copied....") (FONTCOPY (DEFAULTFONT 'DISPLAY) 'DEVICE STREAM 'NOERROR NOERRORFLG)) (T (ERROR (CONCAT DEVICE " component for DEFAULTFONT undefined"] (T (FONTCREATE DEFAULTFONT NIL NIL NIL STREAM NOERRORFLG] ((SETQ FONT (FONTCREATE FONT NIL NIL NIL STREAM NOERRORFLG)) (* ;; "Might get NIL if NOERRORFLG") (SETFONTCLASSCOMPONENT SPEC DEVICE FONT] ((NULL SPEC) (RETURN (\COERCEFONTDESC DEFAULTFONT STREAM NOERRORFLG))) ((OR (IMAGESTREAMP SPEC) (type? WINDOW SPEC)) (SETQ FONT (DSPFONT NIL SPEC))) (T (* ;; "If called with NOERRORFLG=T (e.g. from DSPFONT) we want to suppress invalid arg errors as well as font not found, so we can move on to other possible coercions.") (RETURN (FONTCREATE SPEC NIL NIL NIL STREAM NOERRORFLG] (* ;; "Here if arg was a fontdescriptor or imagestream") (RETURN (COND ((NULL STREAM) (* ;;  "NIL device doesn't default to display if a fully-specified font was found") FONT) ([OR (EQ STREAM (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT)) (AND (type? STREAM STREAM) (EQ (fetch (IMAGEOPS IMFONTCREATE) of (fetch (STREAM IMAGEOPS) of STREAM)) (fetch (FONTDESCRIPTOR FONTDEVICE) of FONT] FONT) (T (* ;; "Here if doesn't match or if DEVICE is not explicitly a stream.") (FONTCOPY FONT 'DEVICE STREAM 'NOERROR NOERRORFLG]) (\LOOKUPFONT [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 28-Jul-88 17:05 by rmk:") (* ; "Edited 28-Jul-88 17:04 by rmk:") (* ; "Edited 28-Jul-88 14:44 by rmk:") (* ; "Edited 28-Jul-88 14:02 by rmk:") (* ; "Edited 28-Jul-88 13:54 by rmk:") (* ; "Edited 26-Feb-87 00:20 by FS") (* ;; "looks up a font in the internal cache. SASSOC for listp FACE") (DECLARE (GLOBALVARS \FONTSINCORE)) (* ;; "Someone had better have already made FACE canonical") (LET [(X (CDR (FASSOC ROTATION (CDR (SASSOC FACE (CDR (FASSOC SIZE (CDR (OR (FASSOC FAMILY \FONTSINCORE) (\FONT.SYMBOLASSOC FAMILY \FONTSINCORE] (CDR (OR (FASSOC DEVICE X) (\FONT.SYMBOLASSOC DEVICE X]) (\LOOKUPFONTSINCORE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 25-Apr-93 13:07 by rmk:") (* rrb "25-Sep-84 12:10") (* ;;; "returns a list of the fonts that are available in core. * is used to match anything.") (DECLARE (GLOBALVARS \FONTSINCORE)) (for FAMBUCKET in \FONTSINCORE when (OR (EQ FAMILY '*) (EQ FAMILY (CAR FAMBUCKET))) join (for SIZEBUCKET in (CDR FAMBUCKET) when (OR (EQ SIZE '*) (EQ SIZE (CAR SIZEBUCKET))) join (for FACEBUCKET in (CDR SIZEBUCKET) when (OR (EQ FACE '*) (EQUAL FACE (CAR FACEBUCKET))) join (for ROTBUCKET in (CDR FACEBUCKET) when (OR (EQ ROTATION '*) (EQ ROTATION (CAR ROTBUCKET))) join (for DEVBUCKET in (CDR ROTBUCKET) when (AND (OR (EQ DEVICE '*) (EQ DEVICE (CAR DEVBUCKET))) (TYPE? FONTDESCRIPTOR (CDR DEVBUCKET))) collect (LIST (CAR FAMBUCKET) (CAR SIZEBUCKET) (CAR FACEBUCKET) (CAR ROTBUCKET) (CAR DEVBUCKET]) (\READDISPLAYFONTFILE [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET) (* ; "Edited 8-Oct-96 10:17 by rmk:") (* ;  "Edited 30-Sep-96 12:03 by kaplan") (* ; "Edited 2-Jan-87 17:55 by FS") (* ;; "Look for new filename convention, then old file name convention, with extensions. If CACHEDISPLAYFONTS, this keeps a cache of what was read, on the canonical filename's property list, so that NSDISPLAYSIZES and SMALLSCREEN size coercions can be done and undone without always going out to the directories.") (DECLARE (GLOBALVARS DISPLAYFONTEXTENSIONS DISPLAYFONTDIRECTORIES CACHEDISPLAYFONTS)) (BIND FONTFILE CSINFO STRM FIRST (* ;; "Cache is indexed by canonical font file name, without the extension fields.") (CL:WHEN [AND CACHEDISPLAYFONTS (FIND EXT INSIDE DISPLAYFONTEXTENSIONS SUCHTHAT (SETQ CSINFO (GETP (L-CASE (FILENAMEFIELD (IF (FMEMB EXT *OLD-FONT-EXTENSIONS* ) THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT CHARSET) ELSE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET)) 'NAME)) 'CACHEDCHARSET] (RETURN (AND (NEQ CSINFO T) (COPYALL CSINFO)))) FOR EXT INSIDE DISPLAYFONTEXTENSIONS WHEN (SETQ FONTFILE (\FINDFONTFILE FAMILY SIZE FACE ROTATION DEVICE CHARSET DISPLAYFONTDIRECTORIES (LIST EXT))) DO (* ;;  "Cache is indexed by canonical font file name, without the directory or extension fields") (SETQ STRM (OPENSTREAM FONTFILE 'INPUT)) (RESETLST [SETQ CSINFO (SELECTQ (FONTFILEFORMAT STRM T) (STRIKE (RESETSAVE NIL (LIST (FUNCTION CLOSEF) STRM)) (\READSTRIKEFONTFILE STRM FAMILY SIZE FACE)) (AC (* ;; "CLOSEF is guaranteed inside \READACFONTFILE, against the possibility that we have to copy to make randaccessp") (\READACFONTFILE STRM FAMILY SIZE FACE)) (PROG1 (CLOSEF STRM) (* ; "This would get done by RESETSAVE if AC's were read sequentially and we could factor the RESETSAVE") (SHOULDNT))]) (CL:WHEN CACHEDISPLAYFONTS (PUTPROP (L-CASE (FILENAMEFIELD FONTFILE 'NAME)) 'CACHEDCHARSET CSINFO) (SETQ CSINFO (COPYALL CSINFO))) (* ;; "If not a recognizable format, I guess we should keep looking for another possible extension, altho it would also be nice to tell the user that he has a bogus file.") (RETURN CSINFO) FINALLY (* ;; "Didn't find the file, cache T to suppress future lookups") (CL:WHEN CACHEDISPLAYFONTS (PUTPROP (L-CASE (FILENAMEFIELD (IF (FMEMB (CAR (MKLIST DISPLAYFONTEXTENSIONS)) *OLD-FONT-EXTENSIONS*) THEN (\FONTFILENAME.OLD FAMILY SIZE FACE (CAR (MKLIST DISPLAYFONTEXTENSIONS )) CHARSET) ELSE (\FONTFILENAME FAMILY SIZE FACE (CAR (MKLIST DISPLAYFONTEXTENSIONS )) CHARSET)) 'NAME)) 'CACHEDCHARSET T))]) ) (* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. " ) (ADDTOVAR *OLD-FONT-EXTENSIONS* STRIKE) (RPAQ? *USEOLDFONTDIRECTORIES* NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*) ) (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)" ) (* ;; "Establishes DISPLAYFONTFILECACHE to avoid rereading charsets when size coercions are done (e.g. for nsdisplaysizes or smallscreen)" ) (RPAQ? CACHEDISPLAYFONTS T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CACHEDISPLAYFONTS) ) (* ; "STRIKE format file support") (DEFINEQ (\READSTRIKEFONTFILE [LAMBDA (STRM FAMILY SIZE FACE) (* ; "Edited 4-Dec-92 12:11 by jds") (* ;  "STRM has already been determined to be a vanilla strike-format file.") (* ; "returns a charsetinfo") (COND ((NEQ 2 (GETFILEPTR STRM)) (SETFILEPTR STRM 2))) (PROG (CSINFO NUMBCODES RW BITMAP OFFSETS FIRSTCHAR LASTCHAR HEIGHT WIDTHS) (SETQ CSINFO (create CHARSETINFO)) (SETQ FIRSTCHAR (\WIN STRM)) (* ; "minimum ascii code") (SETQ LASTCHAR (\WIN STRM)) (* ; "maximum ascii code") (\WIN STRM) (* ;  "MaxWidth which isn't used by anyone.") (\WIN STRM) (* ;  "number of words in this StrikeBody") (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (\WIN STRM)) (* ;  "ascent in scan lines (=FBBdy+FBBoy)") (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (\WIN STRM)) (* ; "descent in scan-lines (=FBBoy)") (\WIN STRM) (* ;  "offset in bits (<0 for kerning, else 0, =FBBox)") (SETQ RW (\WIN STRM)) (* ; "raster width of bitmap") (* ; "height of bitmap") (* ;; "JDS 12/4/92: Apparently, these fields can be signed values, if all chars, e.g., ride above the base line.") (SETQ HEIGHT (IPLUS (SIGNED (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) 16) (SIGNED (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) 16))) (SETQ BITMAP (BITMAPCREATE (UNFOLD RW BITSPERWORD) HEIGHT)) (\BINS STRM (fetch BITMAPBASE of BITMAP) 0 (UNFOLD (ITIMES RW HEIGHT) BYTESPERWORD)) (* ; "read bits into bitmap") (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with BITMAP) (SETQ NUMBCODES (IPLUS (IDIFFERENCE LASTCHAR FIRSTCHAR) 3)) (* (SETQ OFFSETS (ARRAY  (IPLUS \MAXCHAR 3)  (QUOTE SMALLPOSP) 0 0))) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (* ; "initialise the offsets to 0") (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET OFFSETS I 0)) (* (AIN OFFSETS FIRSTCHAR NUMBCODES  STRM)) (for I from FIRSTCHAR as J from 1 to NUMBCODES do (\FSETOFFSET OFFSETS I (\WIN STRM))) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETWIDTH WIDTHS I 0)) (* (replace WIDTHS of  (CHARSETINFO CSINFO) with  (ARRAY (IPLUS \MAXCHAR 3)  (QUOTE SMALLPOSP) 0 0))) (\FONTRESETCHARWIDTHS CSINFO FIRSTCHAR LASTCHAR) (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO WIDTHS) of CSINFO)) (RETURN CSINFO]) (\SFMAKEBOLD [LAMBDA (CSINFO) (* gbn "25-Jul-85 04:52") (PROG* ((OLDCHARBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (HEIGHT (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) NEWCHARBITMAP OFFSET UNKNOWNOFFSET UNKNOWNWIDTH) (SETQ NEWCHARBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDCHARBITMAP) (fetch BITMAPHEIGHT of OLDCHARBITMAP))) (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXCHAR))) (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXCHAR))) [for I from 0 to \MAXCHAR do (COND ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I)) UNKNOWNOFFSET) (* ;  "if this is the magic charcode with the slug image (charcode 256) then leave it alone") NIL) (T (* ;  "overlap two blts to produce bold effect") (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP OFFSET 0 (\FGETWIDTH WIDTHS I ) HEIGHT 'INPUT 'REPLACE) (BITBLT OLDCHARBITMAP OFFSET 0 NEWCHARBITMAP (ADD1 OFFSET) 0 (SUB1 (\FGETWIDTH WIDTHS I)) HEIGHT 'INPUT 'PAINT] (* ;  "fill in the slug for the magic charcode") (BITBLT OLDCHARBITMAP UNKNOWNOFFSET 0 NEWCHARBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT 'INPUT 'REPLACE) (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWCHARBITMAP]) (\SFMAKEITALIC [LAMBDA (CSINFO) (* gbn "18-Sep-85 17:57") (PROG ((WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (ASCENT (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (DESCENT (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (OLDBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) HEIGHT OFFSET NEWBITMAP WIDTH UNKNOWNOFFSET UNKNOWNWIDTH N M R XN XX YN YX) (SETQ HEIGHT (IPLUS ASCENT DESCENT)) (SETQ NEWBITMAP (BITMAPCREATE (fetch BITMAPWIDTH of OLDBITMAP) (fetch BITMAPHEIGHT of OLDBITMAP))) (SETQ UNKNOWNOFFSET (\FGETOFFSET OFFSETS (ADD1 \MAXTHINCHAR))) (SETQ UNKNOWNWIDTH (\FGETWIDTH WIDTHS (ADD1 \MAXTHINCHAR))) (SETQ N (IDIFFERENCE 0 (IQUOTIENT (IPLUS DESCENT 3) 4))) (SETQ M (IQUOTIENT (IPLUS ASCENT 3) 4)) [for I from 0 to \MAXTHINCHAR do (COND ((EQ (SETQ OFFSET (\FGETOFFSET OFFSETS I)) UNKNOWNOFFSET) (* ;  "if this is the magic charcode with the slug image (charcode 256) then leave it alone") NIL) (T (SETQ WIDTH (\FGETWIDTH WIDTHS I)) (for J from N to M do (SETQ R (IPLUS OFFSET WIDTH)) (SETQ XN (IMIN R (IMAX (IPLUS OFFSET J) 0))) (SETQ XX (IMIN R (IMAX (IPLUS R J) 0))) [SETQ YN (IMAX 0 (IPLUS DESCENT (ITIMES J 4] [SETQ YX (IMIN HEIGHT (IPLUS DESCENT (IPLUS (ITIMES J 4) 4] (COND ((AND (IGREATERP XX XN) (IGREATERP YX YN)) (BITBLT OLDBITMAP OFFSET YN NEWBITMAP XN YN (IDIFFERENCE XX XN) (IDIFFERENCE YX YN) 'INPUT 'REPLACE] (BITBLT OLDBITMAP UNKNOWNOFFSET 0 NEWBITMAP UNKNOWNOFFSET 0 UNKNOWNWIDTH HEIGHT 'INPUT 'REPLACE) (RETURN (create CHARSETINFO using CSINFO CHARSETBITMAP _ NEWBITMAP]) (\SFMAKEROTATEDFONT [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") (* ;; "takes a fontdecriptor and rotates it.") (* ;; "1/5/86 JDS. Masterscope claims nobody calls this. Let's find out....") (HELP "ROTATED fonts need to be fixed for NS Chars & New FONTDESCRIPTOR fields") (* (create FONTDESCRIPTOR using  FONTDESC (SETQ CHARACTERBITMAP  (\SFROTATEFONTCHARACTERS  (fetch (FONTDESCRIPTOR  CHARACTERBITMAP) of FONTDESC)  ROTATION)) (SETQ ROTATION ROTATION)  (SETQ \SFOffsets (  \SFFIXOFFSETSAFTERROTATION FONTDESC  ROTATION)) (SETQ FONTCHARSETVECTOR  (\ALLOCBLOCK (ADD1 \MAXCHARSET) T)))) (* ;; "If you uncomment out the code above, remove this comment and the NIL below") NIL]) (\SFROTATECSINFO [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:38") (* ;; "takes a CHARSETINFO and rotates it and produces a rotated equivalent one.") (create CHARSETINFO using CSINFO CHARSETBITMAP _ (\SFROTATEFONTCHARACTERS (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO) ROTATION) OFFSETS _ (\SFROTATECSINFOOFFSETS CSINFO ROTATION]) (\SFROTATEFONTCHARACTERS [LAMBDA (CHARBITMAP ROTATION) (* ; "Edited 22-Sep-87 10:38 by Snow") (* ;;; "rotate a bitmap either 90 or 270 for fonts.") (CASE ROTATION (0 CHARBITMAP) (90 (ROTATE-BITMAP-LEFT CHARBITMAP)) (180 (ROTATE-BITMAP (ROTATE-BITMAP CHARBITMAP))) (270 (ROTATE-BITMAP CHARBITMAP)))]) (\SFFIXOFFSETSAFTERROTATION [LAMBDA (FONTDESC ROTATION) (* ; "Edited 30-Mar-87 20:35 by FS") (* ;; "adjusts offsets in case where rotation turned things around.") (HELP "NEED TO UPDATE THIS FN TO NSCHARS & NEW FONT FIELDS") (* (COND ((EQ ROTATION 270)  (PROG ((OFFSETS (fetch  (FONTDESCRIPTOR \SFOffsets) of  FONTDESC)) (WIDTHS  (fetch (FONTDESCRIPTOR \SFWidths) of  FONTDESC)) (BITMAPHEIGHT  (BITMAPWIDTH (fetch  (FONTDESCRIPTOR CHARACTERBITMAP) of  FONTDESC))) NEWOFFSETS)  (SETQ NEWOFFSETS (COPYARRAY OFFSETS))  (for CHARCODE from 0 to \MAXCHAR do  (SETA NEWOFFSETS CHARCODE  (IDIFFERENCE BITMAPHEIGHT  (IPLUS (ELT OFFSETS CHARCODE)  (ELT WIDTHS CHARCODE)))))  (* ;  "may be some problem with dummy character representation.")  (RETURN NEWOFFSETS)))  (T (fetch (FONTDESCRIPTOR \SFOffsets)  of FONTDESC)))) (* ;; "If you uncomment out the code above, remove this comment and the NIL below") NIL]) (\SFROTATECSINFOOFFSETS [LAMBDA (CSINFO ROTATION) (* gbn "15-Sep-85 14:36") (* ;  "adjusts offsets in case where rotation turned things around.") (COND ((EQ ROTATION 270) (PROG ((OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (BITMAPHEIGHT (BITMAPWIDTH (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) NEWOFFSETS) (SETQ NEWOFFSETS (\CREATECSINFOELEMENT)) [for CHARCODE from 0 to \MAXCHAR do (\FSETOFFSET NEWOFFSETS CHARCODE (IDIFFERENCE BITMAPHEIGHT (IPLUS (\FGETOFFSET OFFSETS CHARCODE) (\FGETWIDTH WIDTHS CHARCODE] (* ;  "may be some problem with dummy character representation.") (RETURN NEWOFFSETS))) (T (fetch (CHARSETINFO OFFSETS) of CSINFO]) (\SFMAKECOLOR [LAMBDA (BWCSINFO BACKCOLOR FORECOLOR BITSPERPIXEL) (* kbr%: " 6-Feb-86 18:17") (* ;; "makes a csinfo that has a character bitmap that is colorized.") (PROG (CHARACTERBITMAP COLORCSINFO) [COND ((IMAGESTREAMP BITSPERPIXEL) (OR BACKCOLOR (SETQ BACKCOLOR (DSPBACKCOLOR NIL BITSPERPIXEL))) (OR FORECOLOR (SETQ FORECOLOR (DSPCOLOR NIL BITSPERPIXEL))) (SETQ BITSPERPIXEL (IMAGESTREAMTYPE BITSPERPIXEL] [SETQ BITSPERPIXEL (COND ((NUMBERP BITSPERPIXEL) BITSPERPIXEL) (T (\DISPLAYSTREAMTYPEBPP BITSPERPIXEL] (SETQ BACKCOLOR (COLORNUMBERP BACKCOLOR BITSPERPIXEL)) (SETQ FORECOLOR (COLORNUMBERP FORECOLOR BITSPERPIXEL)) (SETQ CHARACTERBITMAP (COLORIZEBITMAP (fetch (CHARSETINFO CHARSETBITMAP) of BWCSINFO ) BACKCOLOR FORECOLOR BITSPERPIXEL)) (SETQ COLORCSINFO (create CHARSETINFO using BWCSINFO CHARSETBITMAP _ CHARACTERBITMAP)) (RETURN COLORCSINFO]) ) (DEFINEQ (WRITESTRIKEFONTFILE [LAMBDA (FONT CHARSET FILENAME) (* ; "Edited 30-Mar-87 20:25 by FS") (* ;; "Write strike FILE using info in FONT, AND CHARSET number.") (* ;; "This code only works if original file was STRIKE. Otherwise, a new CSINFO is dummied up and it is used instead. So, CSINFO when read in might be different than the one written out.") (PROG (STREAM CSINFO FIRSTCHAR LASTCHAR WIDTHS OFFSETS IMWIDTHS MAXWIDTH RASTERWIDTH LENGTH DUMMYCHAR DUMMYOFFSET DUMMYINDEX WIDTH OFFSET CODE MAXCODE) (SETQ MAXCODE 255) (* ; "Max charcode") (SETQ DUMMYINDEX 256) (* ; "Dummy char marker") (COND ((NOT (FONTP FONT)) (LISPERROR "ILLEGAL ARG" FONT))) (COND ((NULL CHARSET) (SETQ CHARSET 0)) ((NOT (AND (IGEQ CHARSET 0) (ILESSP CHARSET \MAXCHARSET))) (LISPERROR "ILLEGAL ARG" CHARSET))) (SETQ CSINFO (STRIKECSINFO (\GETCHARSETINFO CHARSET FONT T))) (* ;  "Guarantee its a STRIKE font CSINFO.") (COND ((NULL CSINFO) (ERROR "Couldn't find charset " CHARSET))) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (* ;; "Index 256 contains a dummy width; use it's value to determine missing chars") (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS DUMMYINDEX)) [SETQ FIRSTCHAR (for I from 0 to MAXCODE thereis (NOT (EQ (\FGETOFFSET OFFSETS I) DUMMYOFFSET] [SETQ LASTCHAR (for I from MAXCODE to 0 by -1 thereis (NOT (EQ (\FGETOFFSET OFFSETS I) DUMMYOFFSET] (SETQ DUMMYCHAR (ADD1 LASTCHAR)) [SETQ STREAM (OPENSTREAM FILENAME 'OUTPUT 'NEW '((TYPE BINARY] (* ;; "") (* ;; "STRIKE Header") (* ;; "") (\WOUT STREAM 32768) (\WOUT STREAM FIRSTCHAR) (\WOUT STREAM LASTCHAR) (SETQ MAXWIDTH 0) [for I from 0 to DUMMYINDEX do (SETQ MAXWIDTH (IMAX MAXWIDTH (\FGETWIDTH WIDTHS I] (\WOUT STREAM MAXWIDTH) (* ;; "") (* ;; "STRIKE Body") (* ;; "") (* ;; "Length of body") (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (SETQ LENGTH (IPLUS 8 (IDIFFERENCE LASTCHAR FIRSTCHAR) (ITIMES (fetch (FONTDESCRIPTOR \SFHeight) of FONT) RASTERWIDTH))) (\WOUT STREAM LENGTH) (* ;; "Ascent, Descent, Xoffset (no longer used) and Rasterwidth.") (\WOUT STREAM (fetch (CHARSETINFO CHARSETASCENT) of CSINFO)) (\WOUT STREAM (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (\WOUT STREAM 0) (* ;  "offset in bits (<0 for kerning, else 0, =FBBox)") (\WOUT STREAM RASTERWIDTH) (* ;; "Bitmap") [\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) 0 (ITIMES 2 RASTERWIDTH (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO] (* ;; "Offsets") (SETQ CODE 0) (\WOUT STREAM CODE) (for I from FIRSTCHAR to DUMMYCHAR do (SETQ OFFSET (\FGETOFFSET OFFSETS I)) (SETQ WIDTH (\FGETWIDTH WIDTHS I)) [COND ((AND (IEQP OFFSET DUMMYOFFSET) (NOT (IEQP I DUMMYCHAR))) (* ; "CODE stays the same.") ) (T (SETQ CODE (IPLUS CODE WIDTH] (\WOUT STREAM CODE)) (CLOSEF STREAM]) (STRIKECSINFO [LAMBDA (CSINFO) (* ; "Edited 27-Apr-89 13:39 by atm") (* ;; "Returns a STRIKE type font descriptor (EQ WIDTHS IMAGEWIDTHS), cause we know how to write those guys out (they read quicker but display slower). If (EQ WIDTHS IMAGEWIDTHS), just return original.") (PROG (WIDTHS OFFSETS IMWIDTHS OLDBM BMWIDTH BMHEIGHT NEWBM NEWOFFSET NEWWIDTH OLDOFFSET DUMMYOFFSET NEWOFFSETS) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ IMWIDTHS (fetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (if (EQ WIDTHS IMWIDTHS) then (RETURN CSINFO)) (SETQ OFFSETS (fetch (CHARSETINFO OFFSETS) of CSINFO)) (SETQ OLDBM (fetch (CHARSETINFO CHARSETBITMAP) of CSINFO)) (SETQ DUMMYOFFSET (\FGETOFFSET OFFSETS 256)) (SETQ BMHEIGHT (BITMAPHEIGHT OLDBM)) [SETQ BMWIDTH (for I from 0 to \MAXTHINCHAR sum (if (IEQP DUMMYOFFSET (\FGETOFFSET OFFSETS I)) then 0 else (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) (\FGETWIDTH WIDTHS I] (* ;; "") (* ;; "Initialize new offsets vector") (* ;; "") (SETQ NEWOFFSETS (\CREATECSINFOELEMENT)) (for I from 0 to (IPLUS \MAXTHINCHAR 2) do (\FSETOFFSET NEWOFFSETS I 0)) (\FSETOFFSET NEWOFFSETS (ADD1 \MAXTHINCHAR) BMWIDTH) (* ;; "") (* ;; "Adjust bitmap with so width = imagewidth, fill offsets") (* ;; "") (SETQ NEWBM (BITMAPCREATE BMWIDTH BMHEIGHT 1)) (SETQ NEWOFFSET 0) [for I from 0 to 255 do (SETQ OLDOFFSET (\FGETOFFSET OFFSETS I)) (if (IEQP DUMMYOFFSET OLDOFFSET) then (\FSETOFFSET NEWOFFSETS I BMWIDTH) else (\FSETOFFSET NEWOFFSETS I NEWOFFSET) (SETQ NEWWIDTH (IMAX (\FGETIMAGEWIDTH IMWIDTHS I) (\FGETWIDTH WIDTHS I))) (BITBLT OLDBM OLDOFFSET 0 NEWBM NEWOFFSET 0 (\FGETWIDTH IMWIDTHS I) BMHEIGHT 'REPLACE) (SETQ NEWOFFSET (IPLUS NEWOFFSET NEWWIDTH] (* ;; "") (* ;; "Make new CSInfo record withs IMAGEWIDTHS, WIDTHS the same") (* ;; "") (SETQ WIDTHS (COPYALL WIDTHS)) [for I from 0 to \MAXTHINCHAR do (\FSETWIDTH WIDTHS I (IMAX (\FGETWIDTH WIDTHS I) (\FGETIMAGEWIDTH IMWIDTHS I] (RETURN (create CHARSETINFO WIDTHS _ WIDTHS OFFSETS _ NEWOFFSETS IMAGEWIDTHS _ WIDTHS CHARSETBITMAP _ NEWBM YWIDTHS _ (fetch (CHARSETINFO YWIDTHS) of CSINFO) CHARSETASCENT _ (fetch (CHARSETINFO CHARSETASCENT) of CSINFO) CHARSETDESCENT _ (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO]) ) (/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) '((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) (FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER)) '12) (/DECLAREDATATYPE 'FONTDESCRIPTOR '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER) '((FONTDESCRIPTOR 0 POINTER) (FONTDESCRIPTOR 2 POINTER) (FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) (FONTDESCRIPTOR 8 (BITS . 15)) (FONTDESCRIPTOR 9 (BITS . 15)) (FONTDESCRIPTOR 10 (BITS . 15)) (FONTDESCRIPTOR 11 (BITS . 15)) (FONTDESCRIPTOR 12 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 16 POINTER) (FONTDESCRIPTOR 18 POINTER) (FONTDESCRIPTOR 20 POINTER) (FONTDESCRIPTOR 22 POINTER) (FONTDESCRIPTOR 24 POINTER) (FONTDESCRIPTOR 26 (BITS . 7)) (FONTDESCRIPTOR 27 (BITS . 15)) (FONTDESCRIPTOR 28 POINTER) (FONTDESCRIPTOR 30 POINTER) (FONTDESCRIPTOR 32 POINTER)) '34) (/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((CHARSETINFO 0 POINTER) (CHARSETINFO 2 POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15)) (CHARSETINFO 12 POINTER)) '14) (ADDTOVAR SYSTEMRECLST (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) (OTHERDEVICEFONTPROPS POINTER) (FONTSCALE POINTER) (\SFFACECODE BITS 8) (FONTAVGCHARWIDTH WORD) (FONTIMAGEWIDTHS POINTER) (FONTCHARSETVECTOR POINTER) (FONTEXTRAFIELD2 POINTER))) (DATATYPE CHARSETINFO (WIDTHS OFFSETS IMAGEWIDTHS CHARSETBITMAP YWIDTHS (CHARSETASCENT WORD) (CHARSETDESCENT WORD) LEFTKERN)) ) (RPAQ? \FONTSINCORE ) (RPAQ? \DEFAULTDEVICEFONTS ) (RPAQ? \UNITWIDTHSVECTOR ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DISPLAYFONTDIRECTORIES \DEFAULTDEVICEFONTS \UNITWIDTHSVECTOR) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\UNITWIDTHSVECTOR) ) (DECLARE%: EVAL@COMPILE (RPAQQ NORUNCODE 255) (CONSTANTS (NORUNCODE 255)) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DEFOPTIMIZER FONTPROP (&REST ARGS) (SELECTQ (AND (EQ (CAADR ARGS) 'QUOTE) (CADADR ARGS)) (ASCENT (LIST 'FONTASCENT (CAR ARGS))) (DESCENT (LIST 'FONTDESCENT (CAR ARGS))) (HEIGHT (LIST 'FONTHEIGHT (CAR ARGS))) 'IGNOREMACRO)) (* "END EXPORTED DEFINITIONS") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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 _ 'MEDIUM SLOPE _ 'REGULAR EXPANSION _ '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)) ) (/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER) '((FONTCLASS 0 (BITS . 7)) (FONTCLASS 2 POINTER) (FONTCLASS 4 POINTER) (FONTCLASS 6 POINTER) (FONTCLASS 8 POINTER) (FONTCLASS 10 POINTER)) '12) (/DECLAREDATATYPE 'FONTDESCRIPTOR '(POINTER POINTER POINTER POINTER WORD WORD WORD WORD SIGNEDWORD SIGNEDWORD SIGNEDWORD SIGNEDWORD POINTER POINTER POINTER POINTER POINTER (BITS 8) WORD POINTER POINTER POINTER) '((FONTDESCRIPTOR 0 POINTER) (FONTDESCRIPTOR 2 POINTER) (FONTDESCRIPTOR 4 POINTER) (FONTDESCRIPTOR 6 POINTER) (FONTDESCRIPTOR 8 (BITS . 15)) (FONTDESCRIPTOR 9 (BITS . 15)) (FONTDESCRIPTOR 10 (BITS . 15)) (FONTDESCRIPTOR 11 (BITS . 15)) (FONTDESCRIPTOR 12 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 13 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 14 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 15 (SIGNEDBITS . 15)) (FONTDESCRIPTOR 16 POINTER) (FONTDESCRIPTOR 18 POINTER) (FONTDESCRIPTOR 20 POINTER) (FONTDESCRIPTOR 22 POINTER) (FONTDESCRIPTOR 24 POINTER) (FONTDESCRIPTOR 26 (BITS . 7)) (FONTDESCRIPTOR 27 (BITS . 15)) (FONTDESCRIPTOR 28 POINTER) (FONTDESCRIPTOR 30 POINTER) (FONTDESCRIPTOR 32 POINTER)) '34) (/DECLAREDATATYPE 'CHARSETINFO '(POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((CHARSETINFO 0 POINTER) (CHARSETINFO 2 POINTER) (CHARSETINFO 4 POINTER) (CHARSETINFO 6 POINTER) (CHARSETINFO 8 POINTER) (CHARSETINFO 10 (BITS . 15)) (CHARSETINFO 11 (BITS . 15)) (CHARSETINFO 12 POINTER)) '14) (DECLARE%: EVAL@COMPILE (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 () `(CL:MAKE-ARRAY (IPLUS \MAXTHINCHAR 3) :ELEMENT-TYPE '(SIGNED-BYTE 16) :INITIAL-ELEMENT 0)) (DEFMACRO \FSETLEFTKERN (LEFTKERNBLOCK INDEX KERNVALUE) `(CL:SETF (CL:AREF ,LEFTKERNBLOCK ,INDEX) ,KERNVALUE)) (DEFMACRO \FGETLEFTKERN (LEFTKERNBLOCK CHAR8CODE) `(CL:AREF ,LEFTKERNBLOCK ,CHAR8CODE)) (DECLARE%: EVAL@COMPILE (RPAQQ \MAXNSCHAR 65535) (CONSTANTS (\MAXNSCHAR 65535)) ) (* "END EXPORTED DEFINITIONS") ) (* ; "NS Character specific code") (DEFINEQ (\CREATECHARSET [LAMBDA (CHARSET FONT NOSLUG?) (* ; "Edited 8-May-93 23:42 by rmk:") (* ; "Edited 4-Dec-92 11:43 by jds") (* ;; "Creates and returns the CHARSETINFO for charset CHARSET in fontdesc FONT, installing it in fonts FONTCHARSETVECTOR") (* ;  "NOSLUG? means don't create an empty (slug) csinfo if the charset is not found, just return NIL") (DECLARE (GLOBALVARS \DISPLAYSTREAMTYPES)) (AND (IGREATERP CHARSET \MAXCHARSET) (\ILLEGAL.ARG CHARSET)) (PROG [CSINFO (CREATEFN (COND ((FMEMB (FONTPROP FONT 'DEVICE) \DISPLAYSTREAMTYPES) (FUNCTION \CREATECHARSET.DISPLAY)) (T (CADR (ASSOC 'CREATECHARSET (CDR (ASSOC (FONTPROP FONT 'DEVICE) IMAGESTREAMTYPES] (* ;; "Create a descriptor of info for that charset, and use it to fill things in.") (COND ([NOT (SETQ CSINFO (APPLY CREATEFN (APPEND (FONTPROP FONT 'DEVICESPEC) (LIST CHARSET FONT NOSLUG?] (* ;  "the create method returned NIL--NOSLUG? must be T.") (RETURN NIL))) (replace \SFAscent of FONT with (IMAX (fetch \SFAscent of FONT) (SIGNED (fetch CHARSETASCENT of CSINFO) 16))) (replace \SFDescent of FONT with (IMAX (fetch \SFDescent of FONT) (SIGNED (ffetch CHARSETDESCENT of CSINFO) 16))) (replace \SFHeight of FONT with (IPLUS (fetch \SFAscent of FONT) (ffetch \SFDescent of FONT))) (* ;  "jtm: height = ascent + descent, not (IMAX fontHeight charSetHeight)") (RETURN (\SETCHARSETINFO (ffetch FONTCHARSETVECTOR of FONT) CHARSET CSINFO]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DISPLAYFONTCOERCIONS MISSINGDISPLAYFONTCOERCIONS MISSINGCHARSETDISPLAYFONTCOERCIONS CHARSETERRORFLG) ) (RPAQ? DISPLAYFONTCOERCIONS NIL) (RPAQ? MISSINGCHARSETDISPLAYFONTCOERCIONS '(((GACHA) (TERMINAL)) ((MODERN) (CLASSIC)) ((TIMESROMAN) (CLASSIC)) ((HELVETICA) (MODERN)) ((TERMINAL 6) (MODERN 6)) ((TERMINAL 8) (MODERN 8)) ((TERMINAL 10) (MODERN 10)) ((TERMINAL 12) (MODERN 12)))) (RPAQ? MISSINGDISPLAYFONTCOERCIONS '(((GACHA) (TERMINAL)) ((MODERN) (CLASSIC)) ((TIMESROMAN) (CLASSIC)) ((HELVETICA) (MODERN)))) (RPAQ? CHARSETERRORFLG NIL) (RPAQ? \DEFAULTCHARSET 0) (DEFINEQ (\FONTRESETCHARWIDTHS [LAMBDA (CSINFO FIRSTCHAR LASTCHAR) (* AJB " 6-Dec-85 14:42") (* ;  "sets the widths array from the offsets array") (PROG ((mincharcode FIRSTCHAR) (maxcharcode LASTCHAR) (offsets (fetch (CHARSETINFO OFFSETS) of CSINFO)) (widths (fetch (CHARSETINFO WIDTHS) of CSINFO)) left right charoffset dummycharoffset dummycharwidth) (SETQ dummycharoffset (\FGETOFFSET offsets (ADD1 maxcharcode))) (SETQ dummycharwidth (IDIFFERENCE (\FGETOFFSET offsets (IPLUS maxcharcode 2)) dummycharoffset)) [for charcode from 0 to \MAXCHAR do (COND ((OR (ILESSP charcode mincharcode) (IGREATERP charcode maxcharcode)) (\FSETOFFSET offsets charcode dummycharoffset) (\FSETWIDTH widths charcode dummycharwidth)) (T (SETQ left (\FGETWIDTH offsets charcode)) (SETQ right (\FGETWIDTH offsets (ADD1 charcode))) (COND ((EQ left right) (\FSETOFFSET offsets charcode dummycharoffset) (\FSETWIDTH widths charcode dummycharwidth)) (T (\FSETWIDTH widths charcode (IDIFFERENCE right left] (\FSETWIDTH widths (ADD1 \MAXCHAR) dummycharwidth) (\FSETOFFSET offsets (ADD1 \MAXCHAR) dummycharoffset]) ) (DECLARE%: DONTEVAL@LOAD (RPAQ? DISPLAYFONTEXTENSIONS 'DISPLAYFONT) (RPAQ? DISPLAYFONTDIRECTORIES '({DSK}/USR/LOCAL/LDE/FONTS/DISPLAY/PRESENTATION/ {dsk}/usr/local/lde/fonts/display/publishing/)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \FGETCHARIMAGEWIDTH MACRO (OPENLAMBDA (FONT CHARCODE) (\FGETWIDTH (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO (\CHARSET CHARCODE) FONT)) (\CHAR8CODE CHARCODE)))) (PROGN (PUTPROPS \GETFONTDESC DMACRO [X (COND ((CDR X) (CONS '\COERCEFONTDESC X)) (T `(\DTEST ,(CAR X) 'FONTDESCRIPTOR]) (PUTPROPS \GETFONTDESC MACRO (= . \COERCEFONTDESC))) (PUTPROPS \SETCHARSETINFO MACRO ((CHARSETVECTOR CHARSET CSINFO) (\RPLPTR CHARSETVECTOR (UNFOLD CHARSET 2) CSINFO))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS FONT FILETYPE :FAKE-COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FONTCOPY) ) (PUTPROPS FONT COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8608 18127 (CHARWIDTH 8618 . 9403) (CHARWIDTHY 9405 . 10775) (STRINGWIDTH 10777 . 11870 ) (\CHARWIDTH.DISPLAY 11872 . 12285) (\STRINGWIDTH.DISPLAY 12287 . 12711) (\STRINGWIDTH.GENERIC 12713 . 18125)) (18128 24510 (DEFAULTFONT 18138 . 19971) (FONTCLASS 19973 . 22135) (FONTCLASSUNPARSE 22137 . 23036) (FONTCLASSCOMPONENT 23038 . 23547) (SETFONTCLASSCOMPONENT 23549 . 24508)) (25184 37916 ( FONTCREATE 25194 . 34461) (\FONT.SYMBOLMEMB 34463 . 34693) (\FONT.SYMBOLASSOC 34695 . 35853) ( \FONT.COMPARESYMBOL 35855 . 37914)) (37955 42579 (FONTASCENT 37965 . 38133) (FONTDESCENT 38135 . 38404 ) (FONTHEIGHT 38406 . 38592) (FONTPROP 38594 . 42037) (\AVGCHARWIDTH 42039 . 42577)) (42626 55265 ( GETCHARBITMAP 42636 . 45526) (PUTCHARBITMAP 45528 . 53585) (MOVECHARBITMAP 53587 . 55263)) (55266 140192 (FONTCOPY 55276 . 60584) (FONTSAVAILABLE 60586 . 65791) (FONTFILEFORMAT 65793 . 67417) (FONTP 67419 . 67718) (FONTUNPARSE 67720 . 70284) (SETFONTDESCRIPTOR 70286 . 71995) (CHARCODEP 71997 . 72358) (EDITCHAR 72360 . 72789) (\STREAMCHARWIDTH 72791 . 76955) (\UNITWIDTHSVECTOR 76957 . 77320) ( \CREATEDISPLAYFONT 77322 . 78075) (\CREATECHARSET.DISPLAY 78077 . 80993) (\CREATE-REAL-CHARSET.DISPLAY 80995 . 88286) (\BUILDSLUGCSINFO 88288 . 89731) (\SEARCHDISPLAYFONTFILES 89733 . 91666) ( \SEARCHFONTFILES 91668 . 94979) (\FINDFONTFILE 94981 . 96172) (\FONTSYMBOL 96174 . 96824) ( \DEVICESYMBOL 96826 . 97695) (\FONTFACE 97697 . 104887) (\FONTFACE.COLOR 104889 . 111809) ( \FONTFILENAME 111811 . 115226) (\FONTFILENAME.OLD 115228 . 118177) (\FONTFILENAME.NEW 118179 . 120436) (\FONTINFOFROMFILENAME 120438 . 123552) (\FONTINFOFROMFILENAME.OLD 123554 . 125831) (\GETFONTDESC 125833 . 126224) (\COERCEFONTDESC 126226 . 131611) (\LOOKUPFONT 131613 . 132957) (\LOOKUPFONTSINCORE 132959 . 135032) (\READDISPLAYFONTFILE 135034 . 140190)) (141096 158146 (\READSTRIKEFONTFILE 141106 . 145634) (\SFMAKEBOLD 145636 . 148032) (\SFMAKEITALIC 148034 . 150937) (\SFMAKEROTATEDFONT 150939 . 152340) (\SFROTATECSINFO 152342 . 152979) (\SFROTATEFONTCHARACTERS 152981 . 153361) ( \SFFIXOFFSETSAFTERROTATION 153363 . 155502) (\SFROTATECSINFOOFFSETS 155504 . 156773) (\SFMAKECOLOR 156775 . 158144)) (158147 166458 (WRITESTRIKEFONTFILE 158157 . 162998) (STRIKECSINFO 163000 . 166456)) (180718 183574 (\CREATECHARSET 180728 . 183572)) (184660 186412 (\FONTRESETCHARWIDTHS 184670 . 186410 ))))) STOP \ No newline at end of file diff --git a/sources/FREEMENU b/sources/FREEMENU new file mode 100644 index 00000000..3233945e --- /dev/null +++ b/sources/FREEMENU @@ -0,0 +1,1459 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED " 6-Dec-94 10:55:40" {DSK}lots>dec94>work>lots>freemenu.;3 209304 + + changes to%: (FNS FM.SKIPNEXT \FM.EDIT-FINDNEXT \FM.EDIT-ITEM \FM.EDIT-PREPARETOEDIT + \FM.EDIT-INSERT \FM.NUMBER-SETUP \FM.EDIT-SETUP \FM.NUMBER-CHANGESTATE) + + previous date%: " 7-Sep-94 14:02:37" {DSK}lots>dec94>work>lots>freemenu.;1) + + +(* ; " +Copyright (c) 1986, 1987, 1988, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT FREEMENUCOMS) + +(RPAQQ FREEMENUCOMS + [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) + FREEMENU) + (COMS (* ; "USER INTERFACE FUNCTIONS") + (MACROS FM.GROUPPROP FM.MENUPROP FM.NWAYPROP) + (OPTIMIZERS FM.ITEMPROP) + (PROP ARGNAMES FM.ITEMPROP FM.GROUPPROP FM.MENUPROP FM.NWAYPROP) + (MACROS \FM.INSUREFM \FM.INSUREWINDOW) + (* ; "RUN TIME TYPE CHECKERS") + (FNS FREEMENU (* ; "ACCESSING FUNCTIONS") + FM.ITEMPROP FM.GETITEM FM.GETSTATE (* ; "CHANGING FUNCTIONS") + FM.HIGHLIGHTITEM FM.CHANGELABEL FM.CHANGESTATE FM.RESETSTATE FM.RESETMENU + FM.RESETSHAPE FM.RESETGROUPS (* ; "MISC FUNCTIONS") + FM.REDISPLAYITEM FM.REDISPLAYMENU FM.SHADE FM.EDITP FM.EDITITEM FM.ENDEDIT + FM.SKIPNEXT FM.WHICHITEM FM.TOPGROUPID)) + (COMS (* ; "CREATION OF FREEMENUS") + (DECLARE%: DONTCOPY (MACROS \FM.ITEMPROP \FM.GROUPPROP \FM.NWAYPROP \FM.MAKEGROUP + \FM.TOPGROUPPROP \FM.DTOPGROUPID \FM.DGROUPPROP + \FM.DTOPGROUPPROP)) + (FNS (* ; "FORMATTING") + \FM.FORMAT \FM.FORMATBYROW \FM.FORMATBYCOLUMN \FM.FORMATBYGRID \FM.FORMATEXPLICIT + \FM.LAYOUTROW \FM.LAYOUTCOLUMN \FM.LAYOUTGRID \FM.JUSTIFYITEMS \FM.JUSTIFYGROUPS + \FM.PUSHGROUP (* ; "ERROR CHECKING") + \FM.CHECKDESCRIPTION \FM.CHECKPROPS (* ; "CREATING") + \FM.CREATEITEM \FM.GETREGIONS \FM.GETBITMAPS \FM.MAKEBITMAP \FM.READUSERDATA + \FM.MAKELINKS \FM.COLLECTNWAYS \FM.SETATTACHPOINT \FM.CREATEW \FM.STARTEDIT) + (INITVARS (\FM.GROUP-ID-COUNTER 0)) + (GLOBALVARS \FM.GROUP-ID-COUNTER) + (DECLARE%: DONTCOPY (MACROS \FM.MAKE-GROUP-ID \FM.SETUPPROPS \FM.SETFORMATPROPS + \FM.CHECKFORBOX \FM.UPDATEFORBOX \FM.UPDATEGRID + \FM.ITEMWIDTH \FM.ITEMHEIGHT \FM.ATTACHPOINT)) + (DECLARE%: DONTCOPY + (CONSTANTS (\FM.FORMAT-TYPES '(ROW COLUMN TABLE EXPLICIT)) + (\FM.DEFAULTFORMAT 'ROW) + (* ; "format keywords") + (\FM.GROUPSPEC 'GROUP) + (\FM.PROPSPEC 'PROPS) + (* ; "key words in description") + (\FM.HJUSTIFY-SPECS '(LEFT CENTER RIGHT)) + (\FM.VJUSTIFY-SPECS '(TOP MIDDLE BOTTOM)) + (* ; "item justification keywords") + (\FM.BOXSPACE 1) + (* ; + "default number of bits between label and box") + (\FM.ROWSPACE 2) + (\FM.COLUMNSPACE 10) + (* ; + "default number of bits between formatted rows and columns") + (\FM.ITEM-TYPES '(MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT + EDITSTART DISPLAY)) + (* ; "known freemenu item types") + (\FM.DESCRIPTION-PROPS '(TYPE LABEL LEFT BOTTOM ID GROUPID STATE + INITSTATE FONT BITMAP REGION MAXREGION + MESSAGE USERDATA LINKS SYSDOWNFN SYSMOVEDFN + SYSSELECTEDFN DOWNFN HELDFN MOVEDFN + SELECTEDFN)) + (* ; + "properties in item description that don't become USERDATA") + )) + (RECORDS FREEMENUITEM)) + (COMS (* ; "FREEMENU WINDOWS") + (DECLARE%: DONTCOPY (MACROS \FM.TRANSPOSE)) + (FNS \FM.OPENFN \FM.REDISPLAYMENU \FM.RESHAPEFN \FM.UNSCROLLWINDOW + \FM.RESETCLIPPINGREGION \FM.FILLWINDOW \FM.INITCORNERSFN \FM.TRANSPOSEHORZ + \FM.TRANSPOSEVERT \FM.UPDATEGROUPEXTENT \FM.WINDOWEXTENT \FM.UPDATEWINDOWEXTENT)) + (COMS (* ; "MOUSE FUNCTIONS") + (DECLARE%: DONTCOPY (MACROS \FM.ONITEM \FM.CHECKREGION)) + (FNS \FM.WINDOWENTRYFN \FM.BUTTONEVENTFN \FM.RIGHTBUTTONFN \FM.DOSELECTION + \FM.MENUHANDLER)) + (COMS (* ; "ITEM SUPPORT FUNCTIONS") + (DECLARE%: DONTCOPY (MACROS \FM.DISPLAYBITMAP \FM.COERCEITEMPTR)) + (FNS \FM.GETITEMPROP \FM.PUTITEMPROP \FM.CGETITEMPROP \FM.CPUTITEMPROP \FM.DISPLAYITEM + \FM.HIGHLIGHTITEM \FM.CHANGELABEL \FM.CHANGESTATE \FM.ENDEDIT \FM.INSUREVISIBLE + \FM.CLEARITEM)) + (COMS (* ; "MOMENTARY ITEM FUNCTIONS") + (FNS \FM.MOMENTARY-SETUP \FM.MOMENTARY-SELECTEDFN)) + (COMS (* ; "TOGGLE ITEM FUNCTIONS") + (FNS \FM.TOGGLE-SETUP \FM.TOGGLE-DOWNFN \FM.TOGGLE-SELECTEDFN \FM.TOGGLE-CHANGESTATE)) + (COMS (* ; "3STATE ITEM FUNCTIONS") + (FNS \FM.3STATE-SETUP \FM.3STATE-SETUPOFFBITMAP \FM.3STATE-DOWNFN \FM.3STATE-SELECTEDFN + \FM.3STATE-CHANGESTATE)) + (COMS (* ; "STATE ITEM FUNCTIONS") + (FNS \FM.STATE-SETUP \FM.STATE-SELECTEDFN \FM.STATE-CHANGESTATE)) + (COMS (* ; "NWAY ITEM FUNCTIONS") + (FNS \FM.NWAY-SETUP \FM.NWAY-MESSAGE \FM.NWAY-DOWNFN \FM.NWAY-MOVEDFN + \FM.NWAY-SELECTEDFN \FM.NWAY-CHANGESTATE)) + (COMS (* ; "NUMBER ITEM FUNCTIONS") + (FNS \FM.NUMBER-SETUP \FM.NUMBER-MESSAGE \FM.NUMBER-SELECTEDFN \FM.NUMBER-CHANGESTATE)) + (COMS (* ; "TITLE ITEM FUNCTIONS") + (FNS \FM.DISPLAY-SETUP)) + (COMS (* ; "EDITSTART ITEM FUNCTIONS") + (FNS \FM.EDITSTART-SETUP \FM.EDITSTART-MESSAGE \FM.EDITSTART-SELECTEDFN)) + (COMS (* ; "EDIT ITEMS") + (DECLARE%: DONTCOPY + (CONSTANTS (\FM.EDIT-TIMEOUT 100000) + (\FM.EDIT-RIGHTENDSPACE 5) + (\FM.EDIT-BLOCKSIZE 50) + (\FM.EDIT-CONTROLCHARS '(9 10 12 13)) + (\FM.EDIT-CONTROLCHARSECHO 255) + (\FM.EDIT-WORDDELIMCHARS '(32 123 125 91 93 60 62 47 92 46 44 59 42 40 41 + 45)) + (* ; + "space { } [ ] < > / \ . , ; * ( ) ---") + )) + (VARS (\FM.EDIT-TTBL)) + (GLOBALVARS \FM.EDIT-TTBL) + (MACROS \FM.EDIT-MAXWIDTH \FM.EDIT-SCROLLAMOUNT) + (FNS \FM.EDIT-SETUP \FM.EDIT-MESSAGE \FM.EDIT-SETUPTTBL \FM.EDIT-ITEM + \FM.EDIT-PREPARETOEDIT \FM.EDIT-FINDNEXT \FM.EDIT-FINDFIRST \FM.EDIT-BACKUP + \FM.EDIT-WORDDELETE \FM.EDIT-INSERT \FM.EDIT-DELETE \FM.EDIT-GETPOINTERINFO + \FM.EDIT-MOVECARET \FM.EDIT-STRDELETE \FM.EDIT-STRINSERT + \FM.EDIT-UPDATEAFTERDELETE)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA FM.ITEMPROP]) + +(PUTPROPS FREEMENU FILETYPE CL:COMPILE-FILE) + +(PUTPROPS FREEMENU MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) + + + +(* ; "USER INTERFACE FUNCTIONS") + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS FM.GROUPPROP MACRO + [ARGS (* access macro to group props of + window. args (WINDOW GROUP PROP + {VALUE})) + (COND + ((NULL (CDDR ARGS)) + (ERROR "Too few arguments to FM.GROUPPROP:" (CONS 'FM.GROUPPROP ARGS))) + [(CDDDR ARGS) + `(LET [(GROUP (CDR (FASSOC ,(CADR ARGS) + (WINDOWPROP (\FM.INSUREWINDOW ,(CAR ARGS)) + 'FM.GROUPS] + (PROG1 (LISTGET GROUP ,(CADDR ARGS)) + (LISTPUT GROUP ,(CADDR ARGS) + ,(CADDDR ARGS)))] + (T `(LISTGET [CDR (FASSOC ,(CADR ARGS) + (WINDOWPROP (\FM.INSUREWINDOW ,(CAR ARGS)) + 'FM.GROUPS] + ,(CADDR ARGS]) + +(PUTPROPS FM.MENUPROP MACRO + [ARGS (* access macro to TOP group props + of window. args (WINDOW PROP {VALUE})) + (COND + ((NULL (CDR ARGS)) + (ERROR "Too few arguments to FM.MENUPROP:" (CONS 'FM.MENUPROP ARGS))) + [(CDDR ARGS) + `(LET [(GROUP (CDAR (WINDOWPROP (\FM.INSUREWINDOW %, (CAR ARGS)) + 'FM.GROUPS] + (PROG1 (LISTGET GROUP %, (CADR ARGS)) + (LISTPUT GROUP %, (CADR ARGS) + %, + (CADDR ARGS)))] + (T `(LISTGET (CDAR (WINDOWPROP (\FM.INSUREWINDOW %, (CAR ARGS)) + 'FM.GROUPS)) + %, + (CADR ARGS]) + +(PUTPROPS FM.NWAYPROP MACRO + [ARGS (* access macro to nway props. + args (WINDOW COLLECTION PROP {VALUE})) + (COND + ((NULL (CDDR ARGS)) + (ERROR "Too few arguments to FM.NWAYPROP:" (CONS 'FM.NWAYPROP ARGS))) + [(CDDDR ARGS) + `(LET [(NWAY (CDR (ASSOC ,(CADR ARGS) + (WINDOWPROP (\FM.INSUREWINDOW ,(CAR ARGS)) + 'FM.NWAYS] + (PROG1 (LISTGET NWAY ,(CADDR ARGS)) + (LISTPUT NWAY ,(CADDR ARGS) + ,(CADDDR ARGS)))] + (T `(LISTGET [CDR (ASSOC ,(CADR ARGS) + (WINDOWPROP (\FM.INSUREWINDOW ,(CAR ARGS)) + 'FM.NWAYS] + ,(CADDR ARGS]) +) + +(DEFOPTIMIZER FM.ITEMPROP (&REST ARGS) + [COND + ((NULL (CDR ARGS)) + (ERROR "Too few arguments to FM.ITEMPROP:" (CONS 'FM.ITEMPROP ARGS) + )) + ((NEQ (CAADR ARGS) + 'QUOTE) + 'IGNOREMACRO) + ((CDDR ARGS) + (\FM.CPUTITEMPROP `(\FM.INSUREFM ,(CAR ARGS)) + (CADR ARGS) + (CADDR ARGS))) + (T (\FM.CGETITEMPROP `(\FM.INSUREFM ,(CAR ARGS)) + (CADR ARGS]) + +(PUTPROPS FM.ITEMPROP ARGNAMES (ITEM PROP {VALUE})) + +(PUTPROPS FM.GROUPPROP ARGNAMES (WINDOW GROUP PROP {VALUE})) + +(PUTPROPS FM.MENUPROP ARGNAMES (WINDOW PROP {VALUE})) + +(PUTPROPS FM.NWAYPROP ARGNAMES (WINDOW COLLECTION PROP {VALUE})) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.INSUREFM MACRO + [ARGS + + (* args (ITEM WINDOW)%. Insure ITEM is freemenuitem. + If WINDOW is supplied, then try to coerce item if necessary.) + + (COND + [(CDR ARGS) (* WINDOW ARGUMENT SUPPLIED) + `(COND + ((type? FREEMENUITEM %, (CAR ARGS)) + %, + (CAR ARGS)) + (T (IF [AND (LISTP %, (CAR ARGS)) + (EQ \FM.GROUPSPEC (CAR %, (CAR ARGS] + THEN (ERROR "Can't describe a local item from top level:" %, + (CAR ARGS)) + ELSE (\FM.COERCEITEMPTR %, (CAR ARGS) + %, + (CADR ARGS] + (T (* NO WINDOW SUPPLIED%: JUST TYPE + CHECK ITEM) + `(COND + ((type? FREEMENUITEM %, (CAR ARGS)) + %, + (CAR ARGS)) + (T (ERROR "Arg must be FreeMenuItem" %, (CAR ARGS]) + +(PUTPROPS \FM.INSUREWINDOW MACRO [(WINDOW) + (COND + ((AND (WINDOWP WINDOW) + (WINDOWPROP WINDOW 'FM.ITEMS)) + WINDOW) + (T (ERROR "Arg must be FreeMenu Window" WINDOW]) +) + + + +(* ; "RUN TIME TYPE CHECKERS") + +(DEFINEQ + +(FREEMENU [LAMBDA (DESCRIPTION TITLE BACKGROUND BORDER) (* jow "17-Apr-86 19:32") (* Create a freemenu from a description.  \FM.FORMAT is the recursive formatter. The defaults are passed to it here.  It returns a list of groups, the first of which is the entire menu.  Each group is a property list, the first item being the ID of the group, with  group properties following.) (SETQ DESCRIPTION (COPY DESCRIPTION)) (* leave users description untouched) (LET ((WINDOW (\FM.CREATEW (\FM.FORMAT DESCRIPTION \FM.DEFAULTFORMAT DEFAULTFONT 0 0 \FM.ROWSPACE \FM.COLUMNSPACE) TITLE BACKGROUND BORDER))) (* \FM.SETATTACHPOINT  (LISTGET (CDAR WINDOW)  (QUOTE ITEMS)) (fetch  (REGION WIDTH) of (LISTGET  (CDAR WINDOW) (QUOTE REGION)))  (fetch (REGION HEIGHT) of  (LISTGET (CDAR WINDOW)  (QUOTE REGION)))) (\FM.MAKELINKS WINDOW) (\FM.COLLECTNWAYS WINDOW) (FM.RESETMENU WINDOW) WINDOW]) + +(FM.ITEMPROP [LAMBDA ARGPTR (* jow " 4-Apr-86 14:57") (COND [(ILESSP ARGPTR 2) (ERROR "Too few arguments to FM.ITEMPROP" (LIST 'FM.ITEMPROP (ARG ARGPTR 1] ((NOT (type? FREEMENUITEM (ARG ARGPTR 1))) (ERROR "FM.ITEMPROP arg must be FreeMenuItem:" (ARG ARGPTR 1))) ((EQ ARGPTR 2) (\FM.GETITEMPROP (ARG ARGPTR 1) (ARG ARGPTR 2))) (T (\FM.PUTITEMPROP (ARG ARGPTR 1) (ARG ARGPTR 2) (ARG ARGPTR 3]) + +(FM.GETITEM [LAMBDA (ID GROUP WINDOW) (* jow "19-Apr-86 22:45") (* find an item in WINDOW based on GROUP and ID which is an item id or label,  If GROUP is NIL, search whole menu.) (\FM.INSUREWINDOW WINDOW) (LET [(ITEMS (if GROUP then (\FM.GROUPPROP WINDOW GROUP 'ITEMS) else (WINDOWPROP WINDOW 'FM.ITEMS] (for ITEM in ITEMS thereis (OR (EQ ID (\FM.ITEMPROP ITEM 'ID)) (EQUAL ID (\FM.ITEMPROP ITEM 'LABEL]) + +(FM.GETSTATE [LAMBDA (WINDOW) (* jow "18-Jun-86 16:29") (* programmer interface%: goes through all items and nway collections, returns  a prop list of id / current state for any state items in the menu.  The current state is the value of the STATE field, or for edit items, the  LABEL. Don't include in state list if STATE is NIL.) (\FM.INSUREWINDOW WINDOW) (LET ((STATELIST (LIST NIL))) [for NWAY in (WINDOWPROP WINDOW 'FM.NWAYS) do (if (LISTGET (CDR NWAY) 'STATE) then (LCONC STATELIST (LIST (CAR NWAY) (LISTGET (CDR NWAY) 'STATE] (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) do (SELECTQ (\FM.ITEMPROP ITEM 'TYPE) ((TOGGLE 3STATE STATE NWAY NUMBER) [if (\FM.ITEMPROP ITEM 'STATE) then (LCONC STATELIST (LIST (OR (\FM.ITEMPROP ITEM 'ID) (\FM.ITEMPROP ITEM 'LABEL)) (\FM.ITEMPROP ITEM 'STATE]) (EDIT [LCONC STATELIST (LIST (\FM.ITEMPROP ITEM 'ID) (\FM.ITEMPROP ITEM 'LABEL]) NIL)) (CAR STATELIST]) + +(FM.HIGHLIGHTITEM [LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 15:05") (* this is the user interface function for highlighting.  Type check and coerce item, then call the real function) (\FM.INSUREWINDOW WINDOW) (SETQ ITEM (\FM.INSUREFM ITEM WINDOW)) (\FM.HIGHLIGHTITEM ITEM WINDOW]) + +(FM.CHANGELABEL [LAMBDA (ITEM NEWLABEL WINDOW UPDATEFLG) (* ; "Edited 28-Dec-87 17:08 by woz") (* ;  "user interface to change the label of an item, and redisplay as necessary.") (\FM.INSUREWINDOW WINDOW) (SETQ ITEM (\FM.INSUREFM ITEM WINDOW)) (LET [(OLDREGION (\FM.ITEMPROP ITEM 'REGION] (\FM.CHANGELABEL ITEM NEWLABEL) (* ; "fill in background") (* ;; "now put item back into its current state. This only applies to particular type items (nway, toggle, 3state), so do the changestate directly, rather than call changestate") (SELECTQ (\FM.ITEMPROP ITEM 'TYPE) ((NWAY TOGGLE) (* ;  "remember each nway item is handled as an individual toggle") (\FM.TOGGLE-CHANGESTATE ITEM (\FM.ITEMPROP ITEM 'STATE))) (3STATE (\FM.3STATE-CHANGESTATE ITEM (\FM.ITEMPROP ITEM 'STATE))) NIL) (if (OR UPDATEFLG (\FM.ITEMPROP ITEM 'CHANGELABELUPDATE)) then (* ; "update groups") (\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW 'FM.GROUPS)) (WINDOWPROP WINDOW 'EXTENT (\FM.WINDOWEXTENT WINDOW)) (\FM.REDISPLAYMENU WINDOW) else (* ; "just redisplay item") (\FM.CLEARITEM ITEM WINDOW OLDREGION) (* ; "fill in background") (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'BITMAP) WINDOW]) + +(FM.CHANGESTATE [LAMBDA (X NEWSTATE WINDOW) (* ; "Edited 28-Dec-87 17:09 by woz") (* ;; "user interface to change the state of any (state) item or nway collection. Redisplay the item if the window is open") (\FM.INSUREWINDOW WINDOW) (if (ASSOC X (WINDOWPROP WINDOW 'FM.NWAYS)) then (* ;  "X specifies an NWAY. Changestate and redisplay.") (LET [(OLDSTATE (\FM.NWAYPROP WINDOW X 'STATE] (if NEWSTATE then (* ; "NIL would mean deselect") (SETQ NEWSTATE (\FM.INSUREFM NEWSTATE WINDOW))) (\FM.CHANGESTATE X NEWSTATE WINDOW) (if OLDSTATE then (\FM.DISPLAYBITMAP OLDSTATE (\FM.ITEMPROP OLDSTATE 'BITMAP) WINDOW)) (if NEWSTATE then (\FM.DISPLAYBITMAP NEWSTATE (\FM.ITEMPROP NEWSTATE 'BITMAP) WINDOW))) else (* ; "treat X as an item") (SETQ X (\FM.INSUREFM X WINDOW)) (IF (FMEMB (\FM.ITEMPROP X 'TYPE) '(EDIT NUMBER)) THEN (* ;; "do this because the doc says changestate works with edit items. maybe a dumb idea. need to let the main changelabel routine take care of the display stuff. ") (FM.CHANGELABEL X NEWSTATE WINDOW) ELSE (\FM.CHANGESTATE X NEWSTATE WINDOW) (\FM.DISPLAYBITMAP X (\FM.ITEMPROP X 'BITMAP) WINDOW]) + +(FM.RESETSTATE [LAMBDA (X WINDOW) (* jow "24-Apr-86 21:27") (* Reset X, an item or nway  collection, to its initial state and  redisplay) (\FM.INSUREWINDOW WINDOW) (LET [(INITSTATE (if (ASSOC X (WINDOWPROP WINDOW 'FM.NWAYS)) then (\FM.NWAYPROP WINDOW X 'INITSTATE) else (\FM.ITEMPROP (\FM.INSUREFM X WINDOW) 'INITSTATE] (FM.CHANGESTATE X INITSTATE WINDOW]) + +(FM.RESETMENU [LAMBDA (WINDOW) (* jow "26-Jun-86 14:43") (* reset each item to its INITSTATE) (\FM.INSUREWINDOW WINDOW) (\FM.ENDEDIT WINDOW T) (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) do (FM.RESETSTATE ITEM WINDOW)) (for NWAY in (WINDOWPROP WINDOW 'FM.NWAYS) do (FM.RESETSTATE (CAR NWAY) WINDOW)) (\FM.REDISPLAYMENU WINDOW]) + +(FM.RESETSHAPE [LAMBDA (WINDOW ALWAYSFLG) (* jow "19-Apr-86 22:50") (* programmer way of reshaping a freemenu window to its minimal extent.  If window is too small, it will be reshaped, without moving the lower left  corner. If window is too big, it will only be reshaped if ALWAYSFLG is T.) (\FM.INSUREWINDOW WINDOW) (if (OR (ILESSP (WINDOWPROP WINDOW 'WIDTH) (WINDOWPROP WINDOW 'FM.MINWIDTH)) (ILESSP (WINDOWPROP WINDOW 'HEIGHT) (WINDOWPROP WINDOW 'FM.MINHEIGHT)) ALWAYSFLG) then (SHAPEW WINDOW (CREATEREGION (fetch (REGION LEFT) of (WINDOWPROP WINDOW 'REGION)) (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION)) (WIDTHIFWINDOW (WINDOWPROP WINDOW 'FM.MINWIDTH) (WINDOWPROP WINDOW 'BORDER)) (HEIGHTIFWINDOW (WINDOWPROP WINDOW 'FM.MINHEIGHT) (WINDOWPROP WINDOW 'TITLE) (WINDOWPROP WINDOW 'BORDER]) + +(FM.RESETGROUPS [LAMBDA (WINDOW GROUPLIST REDISPLAYFLG) (* jow "26-Jun-86 14:45") (* user interface to recalculating  group extents.) (\FM.INSUREWINDOW WINDOW) (\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW 'FM.GROUPS) GROUPLIST) (AND REDISPLAYFLG (\FM.REDISPLAYMENU WINDOW]) + +(FM.REDISPLAYITEM [LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 14:51") (* user interface to displaying an  item.) (\FM.INSUREWINDOW WINDOW) (SETQ ITEM (\FM.INSUREFM ITEM WINDOW)) (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'BITMAP) WINDOW]) + +(FM.REDISPLAYMENU [LAMBDA (WINDOW) (* jow "26-Jun-86 14:45") (* use \FM.REDISPLAYMENU, which has  hooks for updating a particular  region.) (\FM.INSUREWINDOW WINDOW) (\FM.REDISPLAYMENU WINDOW]) + +(FM.SHADE [LAMBDA (X SHADE WINDOW) (* jow "26-Jun-86 14:59") (* X is a group id or an item. Paint shade on top of group or item.) (\FM.INSUREWINDOW WINDOW) (LET [(REGION (OR (\FM.GROUPPROP WINDOW X 'REGION) (\FM.ITEMPROP (\FM.INSUREFM X WINDOW) 'REGION] (if (AND REGION (OPENWP WINDOW)) then (BLTSHADE (TEXTUREP SHADE) WINDOW NIL NIL NIL NIL 'PAINT REGION]) + +(FM.EDITP [LAMBDA (WINDOW) (* jow "19-Apr-86 22:52") (WINDOWPROP (\FM.INSUREWINDOW WINDOW) 'FM.EDITITEM]) + +(FM.EDITITEM [LAMBDA (ITEM WINDOW CLEARFLG) (* jow "20-Oct-86 10:48") (* ;;; "start editing at beginning of item.") (\FM.INSUREWINDOW WINDOW) (SETQ ITEM (\FM.INSUREFM ITEM WINDOW)) (\FM.ENDEDIT WINDOW T) [if CLEARFLG then (* ;  "hack to get EDIT-ITEM to clear item first.") (SETQ CLEARFLG '(RIGHT] (if (OPENWP WINDOW) then (ADD.PROCESS `(\FM.STARTEDIT ',ITEM ',WINDOW ',CLEARFLG) 'NAME 'FREEMENU 'FREEMENU.PROCESS T]) + +(FM.ENDEDIT [LAMBDA (WINDOW WAITFLG) (* jow "24-Apr-86 21:23") (\FM.INSUREWINDOW WINDOW) (\FM.ENDEDIT WINDOW WAITFLG]) + +(FM.SKIPNEXT + [LAMBDA (WINDOW CLEARFLG) (* ; "Edited 6-Dec-94 10:53 by jds") + + (* ;; "SKIP FORWARD to the next editable item, and start editing there. If CLEARFLG, clear the new item's contents as we move there.") + + (* ;; + "This function needs to parallel processing in \EDITSTART-SELECTEDFN, to get the DONEFN right.") + + (COND + [(FM.EDITP WINDOW) + + (* ;; "eval the EDITITEM change in the FREEMENU process, which must be the tty process if editing. This works even if called from the FREEMENU process, eg by LIMITCHARS") + + (LET ((FM.PROCESS (TTY.PROCESS))) + (COND + [(PROCESSPROP FM.PROCESS 'FREEMENU.PROCESS) + (PROCESS.EVAL FM.PROCESS + `(LET ((NEWITEM (\FM.EDIT-FINDNEXT))) + (if NEWITEM + then (SETQ EDITITEM NEWITEM) + (if ',CLEARFLG + then (FM.CHANGELABEL EDITITEM "" WINDOW)) + (\FM.EDIT-PREPARETOEDIT EDITITEM T) + (\FM.INSUREVISIBLE EDITITEM WINDOW) + (SETQ DONEFN (IF (EQ (\FM.ITEMPROP EDITITEM 'TYPE) + 'NUMBER) + THEN (FUNCTION \FM.NUMBER-CHANGESTATE))) + else (\FM.ENDEDIT WINDOW] + (T (ERROR "Can't find freemenu process to do skip-next" FM.PROCESS] + (T (* ; + "not editing, so start with first edit item in menu") + (LET ((EDITITEM (\FM.EDIT-FINDFIRST WINDOW))) + (COND + (EDITITEM (FM.EDITITEM EDITITEM WINDOW CLEARFLG]) + +(FM.WHICHITEM [LAMBDA (WINDOW POSorX Y) (* jow "19-Apr-86 22:54") (* user interface to CHECKREGION. Return the item in WINDOW at  (POSorX, Y) If WINDOW is NIL, use the window the cursor is in, and the cursor  position in that window) (if (OR (WINDOWP WINDOW) (SETQ WINDOW (WHICHW))) then (COND ((POSITIONP POSorX) (\FM.CHECKREGION WINDOW (fetch (POSITION XCOORD) of POSorX) (fetch (POSITION YCOORD) of POSorX))) (POSorX (\FM.CHECKREGION WINDOW POSorX Y)) (T (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW]) + +(FM.TOPGROUPID [LAMBDA (WINDOW) (* jow "19-Apr-86 22:54") (* grab id of top group) (\FM.DTOPGROUPID (WINDOWPROP (\FM.INSUREWINDOW WINDOW) 'FM.GROUPS]) +) + + + +(* ; "CREATION OF FREEMENUS") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.ITEMPROP MACRO [ARGS + + (* access macro to FREEMENUITEM datatype. + args (ITEM PROP {VALUE}) Doesnt force an INSUREFM on the item, so intended for + internal use only. PROP must be a quoted literal.) + + (COND + ((NULL (CDR ARGS)) + (ERROR "Too few arguments to \FM.ITEMPROP:" + (CONS 'FM.ITEMPROP ARGS))) + ((NOT (EQ (CAADR ARGS) + 'QUOTE)) + (ERROR "CANT USE \FM.ITEMPROP UNLESS PROP IS QUOTED")) + ((CDDR ARGS) + (\FM.CPUTITEMPROP (CAR ARGS) + (CADR ARGS) + (CADDR ARGS))) + (T (\FM.CGETITEMPROP (CAR ARGS) + (CADR ARGS]) + +(PUTPROPS \FM.GROUPPROP MACRO + [ARGS + + (* internal access macro to group props of window. + doesn't check for illegal args. args (WINDOW GROUP PROP {VALUE})) + + (COND + ((NULL (CDDR ARGS)) + (ERROR "Too few arguments to FM.GROUPPROP:" (CONS 'FM.GROUPPROP ARGS))) + [(CDDDR ARGS) + `(LET [(GROUP (CDR (FASSOC %, (CADR ARGS) + (WINDOWPROP %, (CAR ARGS) + 'FM.GROUPS] + (PROG1 (LISTGET GROUP %, (CADDR ARGS)) + (LISTPUT GROUP %, (CADDR ARGS) + %, + (CADDDR ARGS)))] + (T `(LISTGET [CDR (FASSOC %, (CADR ARGS) + (WINDOWPROP %, (CAR ARGS) + 'FM.GROUPS] + %, + (CADDR ARGS]) + +(PUTPROPS \FM.NWAYPROP MACRO + [ARGS (* internal access macro to nway + props. doesn't error check args. + args (WINDOW COLLECTION PROP {VALUE})) + (COND + ((NULL (CDDR ARGS)) + (ERROR "Too few arguments to FM.NWAYPROP:" (CONS 'FM.NWAYPROP ARGS))) + [(CDDDR ARGS) + `(LET [(NWAY (CDR (ASSOC %, (CADR ARGS) + (WINDOWPROP %, (CAR ARGS) + 'FM.NWAYS] + (PROG1 (LISTGET NWAY %, (CADDR ARGS)) + (LISTPUT NWAY %, (CADDR ARGS) + %, + (CADDDR ARGS)))] + (T `(LISTGET [CDR (ASSOC %, (CADR ARGS) + (WINDOWPROP %, (CAR ARGS) + 'FM.NWAYS] + %, + (CADDR ARGS]) + +(PUTPROPS \FM.MAKEGROUP MACRO [ARGS (* access macro that will build + group from (ID PROPS)) + `(CONS %, (CAR ARGS) + %, + (CADR ARGS]) + +(PUTPROPS \FM.TOPGROUPPROP MACRO + [ARGS (* access macro to top group of + window. args (WINDOW PROP {VALUE})) + (COND + ((NULL (CDR ARGS)) + (ERROR "BAD ARGS TO \FM.TOPGROUPPROP:" (CONS '\FM.TOPGROUPPROP ARGS))) + [(CDDR ARGS) + `(LET [(GROUP (CDAR (WINDOWPROP (\FM.INSUREWINDOW %, (CAR ARGS)) + 'FM.GROUPS] + (PROG1 (LISTGET GROUP %, (CADR ARGS)) + (LISTPUT GROUP %, (CADR ARGS) + %, + (CADDR ARGS)))] + (T `(LISTGET (CDAR (WINDOWPROP (\FM.INSUREWINDOW %, (CAR ARGS)) + 'FM.GROUPS)) + %, + (CADR ARGS]) + +(PUTPROPS \FM.DTOPGROUPID MACRO ((GROUP) + (CAAR GROUP))) + +(PUTPROPS \FM.DGROUPPROP MACRO [ARGS (* access macro to groups props + directly. args (GROUPS GROUPID PROP + {VALUE})) + (COND + ((NULL (CDDR ARGS)) + (ERROR "BAD ARGS TO \FM.DGROUPPROP" + (CONS '\FM.DGROUPPROP ARGS))) + [(CDDDR ARGS) + `(LET [(GROUP (CDR (FASSOC %, (CADR ARGS) + %, + (CAR ARGS] + (PROG1 (LISTGET GROUP %, (CADDR ARGS)) + (LISTPUT GROUP %, (CADDR ARGS) + %, + (CADDDR ARGS)))] + (T `(LISTGET (CDR (FASSOC %, (CADR ARGS) + %, + (CAR ARGS))) + %, + (CADDR ARGS]) + +(PUTPROPS \FM.DTOPGROUPPROP MACRO [ARGS (* access macro to direct top group. + args (GROUPS PROP {VALUE})) + (COND + ((NULL (CDR ARGS)) + (ERROR "BAD ARGS TO \FM.DTOPGROUPPROP:" + (CONS '\FM.DTOPGROUPPROP ARGS))) + [(CDDR ARGS) + `(PROG1 (LISTGET (CDAR %, (CAR ARGS)) + %, + (CADR ARGS)) + (LISTPUT (CDAR %, (CAR ARGS)) + %, + (CADR ARGS) + %, + (CADDR ARGS)))] + (T `(LISTGET (CDAR %, (CAR ARGS)) + %, + (CADR ARGS]) +) +) +(DEFINEQ + +(\FM.FORMAT [LAMBDA (DESCRIPTION FORMAT FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS) (* jow "28-Oct-86 18:42") (* recursive formatter. MOTHER is this groups mother group id, and ID is this  groups id, and PROPS is this groups property list.  Currently ID and PROPS are unspecified arguments, and are only set by  SETUPPROPS (but they are available as format arguments for later versions???)  Format description based on its requested format in PROPS.  If the format type is not known, treat it as a user specified funtion to do the  desired formatting, and apply it to the description.  (NOT CURRENTLY) LEFT and BOTTOM specify the corner of the groups coordinate  system, and the LEFT and BOTTOM menuprops in the group specify offsets in that  system. If the group is boxed, then offset the group before formatting, and  readjust the extent after formatting to account for the box.  Return a group structure for this group.) (\FM.SETUPPROPS DESCRIPTION '(FORMAT FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)) (LET (GROUPS OLDCORNER BOXOFFSET EXTENT) (\FM.CHECKFORBOX) (SETQ GROUPS (SELECTQ FORMAT (ROW (\FM.FORMATBYROW DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)) (COLUMN (\FM.FORMATBYCOLUMN DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)) (TABLE (\FM.FORMATBYGRID DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)) (EXPLICIT (\FM.FORMATEXPLICIT DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS)) NIL)) (* Hook for user defined format types -  APPLY* (LISTGET PROPS (QUOTE FORMAT)) DESCRIPTION FONT LEFT BOTTOM ROWSPACE  COLUMNSPACE ID) (\FM.JUSTIFYITEMS GROUPS) (\FM.JUSTIFYGROUPS GROUPS) (SETQ EXTENT (\FM.DTOPGROUPPROP GROUPS 'REGION)) (* UPDATEFORBOX macro uses EXTENT) (\FM.UPDATEFORBOX) GROUPS]) + +(\FM.FORMATBYROW [LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS) (* jow "17-Apr-86 18:09") (* Called when row formatting is specified.  ID and PROPS are passed from \FM.FORMAT.  ID is id of this group, and thus passed to MOTHER of each row group.  PROPS is the group proplist to build the group from.  DESCRIPTION is a list of rows, each row a list of item descriptions and groups.  Reverse the rows, then build from bottom up.  Use \FM.LAYOUTROW to lay out the items in a row.) (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (ROWIDS (LIST NIL)) (ROWBOTTOM BOTTOM) GROUPS) (for ROW in (DREVERSE DESCRIPTION) do (SETQ GROUPS (\FM.LAYOUTROW ROW FONT LEFT ROWBOTTOM ROWSPACE COLUMNSPACE ID)) (TCONC ROWIDS (\FM.DTOPGROUPID GROUPS)) [LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP GROUPS 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS 'REGION)) (LCONC GROUPLIST GROUPS) (add ROWBOTTOM (fetch (REGION HEIGHT) of (\FM.DTOPGROUPPROP GROUPS 'REGION)) ROWSPACE)) (LISTPUT PROPS 'ITEMS (DREVERSE (CAR ITEMLIST))) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (DREVERSE (CAR ROWIDS))) (CONS (\FM.MAKEGROUP ID PROPS) (CAR GROUPLIST]) + +(\FM.FORMATBYCOLUMN [LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS) (* ; "Edited 29-Dec-87 14:45 by woz") (* ;; "ID and PROPS are passed from \FM.FORMAT. ID is this groups id, and is passed as the MOTHER of each column. DESCRIPTION is a list of columns, each column a list of items (top to bottom) and groups. \FM.LAYOUTCOLUMN takes a column description and lays out the items. Column formatting requires a second pass, to top justify the columns. This is done by going through the GROUPLIST and pushing up each column as necessary.") (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (COLUMNIDS (LIST NIL)) (COLUMNLEFT LEFT) GROUPS) (for COL in DESCRIPTION do (SETQ GROUPS (\FM.LAYOUTCOLUMN COL FONT COLUMNLEFT BOTTOM ROWSPACE COLUMNSPACE ID)) (TCONC COLUMNIDS (\FM.DTOPGROUPID GROUPS)) [LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP GROUPS 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS 'REGION)) (LCONC GROUPLIST GROUPS) (add COLUMNLEFT (fetch (REGION WIDTH) of (\FM.DTOPGROUPPROP GROUPS 'REGION)) COLUMNSPACE)) (SETQ GROUPLIST (CAR GROUPLIST)) (* ; "list from LCONC pair") [LET ((HEIGHT (fetch (REGION HEIGHT) of EXTENT)) COLHEIGHT) (for COLID in (CAR COLUMNIDS) do (* ;  "go through each column, pushing up each item in the column.") [SETQ COLHEIGHT (fetch (REGION HEIGHT) of (\FM.DGROUPPROP GROUPLIST COLID 'REGION] (if (NEQ COLHEIGHT HEIGHT) then (* ;  "column doesn't reach top, so push up") (\FM.PUSHGROUP COLID GROUPLIST (IDIFFERENCE HEIGHT COLHEIGHT) 'UP] (LISTPUT PROPS 'ITEMS (CAR ITEMLIST)) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (CAR COLUMNIDS)) (CONS (\FM.MAKEGROUP ID PROPS) GROUPLIST]) + +(\FM.FORMATBYGRID [LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS) (* jow " 9-May-86 16:05") (* ID and PROPS are specified by \FM.FORMAT.  ID is this groups id, and thus the MOTHER of each grid row.  DESCRIPTION is a list of rows, each row a list of item descriptions and groups.  Reverse the rows, then build from bottom up.  GRID is the list of columns. Ignore row and item offsets and make the first  column LEFT. This is okay because can achieve the offset by group offset.  \FM.LAYOUTGRID formats each row, and also updates the column grid.  As a second pass, the items in each row are pushed right, to align them with  the calculated grid. This involves extending the extent to include any  item/group that is on the last grid position, otherwise the item/group could  get justified out of the extent.) (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (ROWIDS (LIST NIL)) (GRID (TCONC (LIST NIL) LEFT)) (ROWBOTTOM BOTTOM) GROUPS ROWITEMS ROWREGION ROWDAUGHTERS ALIGNREGION BOX) (for ROWDESC in (REVERSE DESCRIPTION) do (SETQ GROUPS (\FM.LAYOUTGRID ROWDESC FONT GRID ROWBOTTOM ROWSPACE COLUMNSPACE ID)) (TCONC ROWIDS (\FM.DTOPGROUPID GROUPS)) [LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP GROUPS 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP GROUPS 'REGION)) (LCONC GROUPLIST GROUPS) (add ROWBOTTOM (fetch (REGION HEIGHT) of (\FM.DTOPGROUPPROP GROUPS 'REGION)) ROWSPACE)) (SETQ GROUPLIST (CAR GROUPLIST)) (* grab list from LCONC pair) (SETQ ROWIDS (DREVERSE (CAR ROWIDS))) (SETQ GRID (CAR GRID)) (for ROWID in ROWIDS as ROWDESC in DESCRIPTION do (SETQ ROWREGION (\FM.DGROUPPROP GROUPLIST ROWID 'REGION)) (SETQ ROWITEMS (\FM.DGROUPPROP GROUPLIST ROWID 'ITEMS)) (SETQ ROWDAUGHTERS (\FM.DGROUPPROP GROUPLIST ROWID 'DAUGHTERS)) (for ITEMDESC in ROWDESC as GRIDPOS in GRID do (if (EQ \FM.GROUPSPEC (CAR ITEMDESC)) then (SETQ ALIGNREGION (\FM.DGROUPPROP GROUPLIST (CAR ROWDAUGHTERS ) 'REGION)) (SETQ ROWITEMS (CDR (FMEMB [CAR (LAST (\FM.DGROUPPROP GROUPLIST (CAR ROWDAUGHTERS) 'ITEMS] ROWITEMS))) (if (NEQ GRIDPOS (fetch (REGION LEFT) of ALIGNREGION )) then (* need to align a group) (\FM.PUSHGROUP (CAR ROWDAUGHTERS) GROUPLIST (IDIFFERENCE GRIDPOS (fetch (REGION LEFT) of ALIGNREGION)) 'RIGHT)) (SETQ ROWDAUGHTERS (CDR ROWDAUGHTERS)) (* point at next item and group) else (SETQ ALIGNREGION (\FM.ITEMPROP (CAR ROWITEMS) 'MAXREGION)) (replace (REGION LEFT) of (\FM.ITEMPROP (CAR ROWITEMS) 'REGION) with GRIDPOS) (replace (REGION LEFT) of ALIGNREGION with GRIDPOS) (SETQ ROWITEMS (CDR ROWITEMS)) (* point at next item)) finally (EXTENDREGION ROWREGION ALIGNREGION) [if (SETQ BOX (\FM.DGROUPPROP GROUPLIST ROWID 'BOX)) then (add (fetch (REGION WIDTH) of ROWREGION) (IPLUS BOX (\FM.DGROUPPROP GROUPLIST ROWID 'BOXSPACE] (EXTENDREGION EXTENT ROWREGION))) (LISTPUT PROPS 'ITEMS (DREVERSE (CAR ITEMLIST))) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS ROWIDS) (CONS (\FM.MAKEGROUP ID PROPS) GROUPLIST]) + +(\FM.FORMATEXPLICIT [LAMBDA (DESCRIPTION FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID PROPS) (* jow "17-Apr-86 18:10") (* ID and PROPS are specified by \FM.FORMAT.  For an explicitely formatted group, just check that the descriptions are valid,  and figure out the groups extent. If the group is layed out in local  coordinates, replace with menu coordinates.  When a group is encountered within an explicitely formatted group, the LEFT and  BOTTOM specs in the inside group locate its corner.  If the outer group is expressed in group coordinates, then the corner of the  outer group is passed on, so that the inner group will be in the same system.) (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (SUBGROUPIDS (LIST NIL)) (LOCAL (EQ (LISTGET PROPS 'COORDINATES) 'GROUP)) X) (* X holds newly created group or  item.) [for ITEMDESC in DESCRIPTION do (if (EQ \FM.GROUPSPEC (CAR ITEMDESC)) then (* if item is a group, recurse) (if LOCAL then (SETQ X (\FM.FORMAT (CDR ITEMDESC) 'EXPLICIT FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)) else (SETQ X (\FM.FORMAT (CDR ITEMDESC) 'EXPLICIT FONT 0 0 ROWSPACE COLUMNSPACE ID))) (TCONC SUBGROUPIDS (\FM.DTOPGROUPID X)) [LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP X 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP X 'REGION)) (LCONC GROUPLIST X) else (\FM.CHECKDESCRIPTION ITEMDESC) (* check description and left and  bottom specs) (if LOCAL then (* change group coord's into menu  coord's) (SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID)) else (SETQ X (\FM.CREATEITEM ITEMDESC FONT 0 0 ID))) (TCONC ITEMLIST X) (EXTENDREGION EXTENT (\FM.ITEMPROP X 'MAXREGION] (LISTPUT PROPS 'ITEMS (DREVERSE (CAR ITEMLIST))) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (CAR SUBGROUPIDS)) (CONS (\FM.MAKEGROUP ID PROPS) (CAR GROUPLIST]) + +(\FM.LAYOUTROW [LAMBDA (ROW FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS) (* jow "17-Apr-86 18:11") (* MOTHER mother group id. ID and PROPS belong to the group which is this row,  and are currently unspecified on entry (later versions???) Layout the items in  a row starting at LEFT and BOTTOM including any individual item offsets,  leaving COLUMNSPACE bits between items in the row.  Nested groups get default row format. Return a list of groups.) (\FM.SETUPPROPS ROW '(ID FONT LEFT BOTTOM COLUMNSPACE)) (LET (OLDCORNER BOXOFFSET) (\FM.CHECKFORBOX) (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (SUBGROUPIDS (LIST NIL)) (GROUPLEFT LEFT) X) (* X holds newly created group or  item) (for ITEMDESC in ROW do [if (EQ \FM.GROUPSPEC (CAR ITEMDESC)) then (SETQ X (\FM.FORMAT (CDR ITEMDESC) 'ROW FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)) (TCONC SUBGROUPIDS (\FM.DTOPGROUPID X)) [LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP X 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP X 'REGION)) (LCONC GROUPLIST X) else (\FM.CHECKDESCRIPTION ITEMDESC) (SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID)) (TCONC ITEMLIST X) (EXTENDREGION EXTENT (\FM.ITEMPROP X 'MAXREGION] (SETQ LEFT (IPLUS GROUPLEFT (fetch (REGION WIDTH) of EXTENT) COLUMNSPACE))) (\FM.UPDATEFORBOX) (LISTPUT PROPS 'ITEMS (CAR ITEMLIST)) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (CAR SUBGROUPIDS)) (CONS (\FM.MAKEGROUP ID PROPS) (CAR GROUPLIST]) + +(\FM.LAYOUTCOLUMN [LAMBDA (COLUMN FONT LEFT BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS) (* jow "17-Apr-86 18:11") (* MOTHER is mother group id. ID and PROPS belong to the group which is this  row, and are currently unspecified on entry  (later versions???) Called by \FM.FORMATBYCOLUMN to layout the items in a  column. The COLUMN is reversed, so that it is built from bottom up.  Column starts at LEFT, BOTTOM, with ROWSPACE bits between items.  Nested groups default to column format.  The items are returned in the order that they are declared.) (\FM.SETUPPROPS COLUMN '(ID FONT LEFT BOTTOM ROWSPACE)) (LET (OLDCORNER BOXOFFSET) (\FM.CHECKFORBOX) (LET ((EXTENT (CREATEREGION LEFT BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (SUBGROUPIDS (LIST NIL)) (GROUPBOTTOM BOTTOM) X) (* X holds newly created group or  item) (for ITEMDESC in (DREVERSE COLUMN) do [if (EQ \FM.GROUPSPEC (CAR ITEMDESC)) then (SETQ X (\FM.FORMAT (CDR ITEMDESC) 'COLUMN FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID) ) (TCONC SUBGROUPIDS (\FM.DTOPGROUPID X)) [LCONC ITEMLIST (REVERSE (\FM.DTOPGROUPPROP X 'ITEMS] (EXTENDREGION EXTENT (\FM.DTOPGROUPPROP X 'REGION)) (LCONC GROUPLIST X) else (\FM.CHECKDESCRIPTION ITEMDESC) (SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID)) (TCONC ITEMLIST X) (EXTENDREGION EXTENT (\FM.ITEMPROP X 'MAXREGION] (SETQ BOTTOM (IPLUS GROUPBOTTOM (fetch (REGION HEIGHT) of EXTENT) ROWSPACE))) (\FM.UPDATEFORBOX) (LISTPUT PROPS 'ITEMS (DREVERSE (CAR ITEMLIST))) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (DREVERSE (CAR SUBGROUPIDS))) (CONS (\FM.MAKEGROUP ID PROPS) (CAR GROUPLIST]) + +(\FM.LAYOUTGRID [LAMBDA (ROW FONT GRID BOTTOM ROWSPACE COLUMNSPACE MOTHER ID PROPS) (* jow "24-Apr-86 23:15") (* MOTHER is mother group id. ID and PROPS belong to the group which is this  row, and are currently unspecified on entry  (later versions???) ROW is a list of item descriptions.  Layout the items according to GRID, updating GRID as you go.  GRID is a list (built in TCONC format) of column positions, ie the first number  in the list is the left position of the first item in each row, and so on.  GRID will always specify a first column.  For each row, update GRID to accomodate the items in that row, by pushing the  grid right as necessary for new items. Then \FM.FORMATBYGRID will use this grid  to align all items by column.) (\FM.SETUPPROPS ROW '(ID FONT BOTTOM COLUMNSPACE)) (LET ((GRIDLEN (FLENGTH (CAR GRID))) OLDCORNER BOXOFFSET) (if (LISTGET PROPS 'BOX) then (* offset group to allow for box.  Like CHECKFORBOX; slightly different  for GRID.) (OR (LISTGET PROPS 'BOXSHADE) (LISTPUT PROPS 'BOXSHADE BLACKSHADE)) (OR (LISTGET PROPS 'BOXSPACE) (LISTPUT PROPS 'BOXSPACE \FM.BOXSPACE)) (SETQ OLDCORNER (CONS LEFT BOTTOM)) [SETQ BOXOFFSET (IPLUS (LISTGET PROPS 'BOX) (LISTGET PROPS 'BOXSPACE] (\FM.UPDATEGRID 1 (IPLUS (CAAR GRID) BOXOFFSET)) (* shift grid to account for box) (add BOTTOM BOXOFFSET)) (LET ((EXTENT (CREATEREGION (CAAR GRID) BOTTOM 0 0)) (ITEMLIST (LIST NIL)) (GROUPLIST (LIST NIL)) (SUBGROUPIDS (LIST NIL)) (ITEMNUM 0) X GROUPREGION LEFT NEXTLEFT) (for ITEMDESC in ROW do (add ITEMNUM 1) (SETQ LEFT (CAR (FNTH (CAR GRID) ITEMNUM))) (if (EQ \FM.GROUPSPEC (CAR ITEMDESC)) then (SETQ X (\FM.FORMAT (CDR ITEMDESC) 'TABLE FONT LEFT BOTTOM ROWSPACE COLUMNSPACE ID)) (TCONC SUBGROUPIDS (\FM.DTOPGROUPID X)) [LCONC ITEMLIST (COPY (\FM.DTOPGROUPPROP X 'ITEMS] (SETQ GROUPREGION (\FM.DTOPGROUPPROP X 'REGION)) (EXTENDREGION EXTENT GROUPREGION) (LCONC GROUPLIST X) (SETQ LEFT (fetch (REGION LEFT) of GROUPREGION)) (SETQ NEXTLEFT (IPLUS LEFT (fetch (REGION WIDTH) of GROUPREGION ) COLUMNSPACE)) else (\FM.CHECKDESCRIPTION ITEMDESC) (SETQ X (\FM.CREATEITEM ITEMDESC FONT LEFT BOTTOM ID)) (TCONC ITEMLIST X) (SETQ GROUPREGION (\FM.ITEMPROP X 'MAXREGION)) (EXTENDREGION EXTENT GROUPREGION) (SETQ LEFT (fetch (REGION LEFT) of GROUPREGION)) (SETQ NEXTLEFT (IPLUS LEFT (fetch (REGION WIDTH) of GROUPREGION ) COLUMNSPACE))) (\FM.UPDATEGRID ITEMNUM LEFT) (* mark where this one went) (\FM.UPDATEGRID (ADD1 ITEMNUM) NEXTLEFT) (* mark where the next one will go)) (\FM.UPDATEFORBOX) (LISTPUT PROPS 'ITEMS (CAR ITEMLIST)) (LISTPUT PROPS 'REGION EXTENT) (LISTPUT PROPS 'DAUGHTERS (CAR SUBGROUPIDS)) (CONS (\FM.MAKEGROUP ID PROPS) (CAR GROUPLIST]) + +(\FM.JUSTIFYITEMS + [LAMBDA (GROUPS GROUPID) (* ; "Edited 6-Sep-94 18:52 by jds") + + (* ;; "justify the items in group GROUPID, within that item's group's extent. If GROUPID is nil, do top group. This will descend into subgroups, and justify those items within that group.") + + (LET (EXTENT EXTENTLEFT EXTENTBOTTOM ITEMREGION ITEMMAXREGION ITEMWIDTH ITEMHEIGHT THISGROUP + MOTHER) + (OR GROUPID (SETQ GROUPID (CAAR GROUPS))) + (PROG (($$LST1 (LISTGET (CDR (FASSOC GROUPID GROUPS)) + 'ITEMS)) + $$VAL ITEM) + $$LP + [SETQ ITEM (CAR (OR (LISTP $$LST1) + (GO $$OUT] + (COND + ([AND (NOT (LISTGET (FETCHFIELD '(FREEMENUITEM 24 POINTER) + ITEM) + 'HJUSTIFY)) + (NOT (LISTGET (FETCHFIELD '(FREEMENUITEM 24 POINTER) + ITEM) + 'VJUSTIFY] + (GO $$ITERATE))) + [COND + ((NEQ THISGROUP (fetch (FREEMENUITEM FM.GROUPID) of ITEM)) + (SETQ THISGROUP (fetch (FREEMENUITEM FM.GROUPID) of ITEM)) + [COND + [(EQ (LISTGET (CDR (FASSOC THISGROUP GROUPS)) + 'CL:FORMAT) + 'EXPLICIT) + (SETQ EXTENT (\FM.DGROUPPROP GROUPS THISGROUP 'REGION] + (T (SETQ MOTHER (LISTGET (CDR (FASSOC THISGROUP GROUPS)) + 'MOTHER)) + (SETQ EXTENT (LISTGET (CDR (FASSOC MOTHER GROUPS)) + 'REGION] + (SETQ EXTENTLEFT (CAR EXTENT)) + (SETQ EXTENTBOTTOM (CADR EXTENT] + (SETQ ITEMREGION (fetch (FREEMENUITEM FM.REGION) of ITEM)) + (SETQ ITEMMAXREGION (fetch (FREEMENUITEM FM.MAXREGION) of ITEM)) + [COND + ((LISTGET (FETCHFIELD '(FREEMENUITEM 24 POINTER) + ITEM) + 'HJUSTIFY) + (SETQ ITEMWIDTH (CADDR ITEMMAXREGION)) + (CAR (RPLACA ITEMREGION (SELECTQ (LISTGET (FETCHFIELD '(FREEMENUITEM 24 POINTER) + ITEM) + 'HJUSTIFY) + (LEFT EXTENTLEFT) + (CENTER (IPLUS EXTENTLEFT + (IQUOTIENT (IDIFFERENCE + (CADDR EXTENT) + ITEMWIDTH) + 2))) + (RIGHT (IPLUS EXTENTLEFT (IDIFFERENCE + (CADDR EXTENT) + ITEMWIDTH))) + NIL))) + (CAR (RPLACA ITEMMAXREGION (CAR ITEMREGION] + [COND + ((LISTGET (FETCHFIELD '(FREEMENUITEM 24 POINTER) + ITEM) + 'VJUSTIFY) + (SETQ ITEMHEIGHT (CADDDR ITEMMAXREGION)) + (CAR (RPLACA (CDR ITEMREGION) + (SELECTQ (\FM.ITEMPROP ITEM 'VJUSTIFY) + (TOP (IPLUS EXTENTBOTTOM (IDIFFERENCE (CADDDR EXTENT) + ITEMHEIGHT))) + (MIDDLE (IPLUS EXTENTBOTTOM (IQUOTIENT (IDIFFERENCE + (CADDDR EXTENT) + ITEMHEIGHT) + 2))) + (BOTTOM EXTENTBOTTOM) + NIL))) + (CAR (RPLACA (CDR ITEMMAXREGION) + (CADR ITEMREGION] + $$ITERATE + (SETQ $$LST1 (CDR $$LST1)) + (GO $$LP) + $$OUT + (RETURN $$VAL]) + +(\FM.JUSTIFYGROUPS + [LAMBDA (GROUPS GROUPID) (* ; "Edited 6-Sep-94 19:22 by jds") + + (* justify group GROUPID in GROUPS structure. + This will descend into the daughter groups. + If GROUPID is nil, start at the top.) + + (LET (EXTENT MOTHEREXTENT MOTHER HJUST VJUST) + (OR GROUPID (SETQ GROUPID (\FM.DTOPGROUPID GROUPS))) + (SETQ HJUST (\FM.DGROUPPROP GROUPS GROUPID 'HJUSTIFY)) + (SETQ VJUST (\FM.DGROUPPROP GROUPS GROUPID 'VJUSTIFY)) + [COND + ((OR HJUST VJUST) + (SETQ MOTHER (\FM.DGROUPPROP GROUPS GROUPID 'MOTHER)) + (SETQ MOTHEREXTENT (\FM.DGROUPPROP GROUPS MOTHER 'REGION)) + (SETQ EXTENT (\FM.DGROUPPROP GROUPS GROUPID 'REGION)) + (COND + (HJUST (SELECTQ HJUST + (LEFT) + (RIGHT (\FM.PUSHGROUP GROUPID GROUPS (- (fetch (REGION RIGHT) + of MOTHEREXTENT) + (fetch (REGION RIGHT) + of EXTENT)) + 'RIGHT)) + (CENTER) + NIL] + (for DAUGHTER in (\FM.DGROUPPROP GROUPS GROUPID 'DAUGHTERS) + do (\FM.JUSTIFYGROUPS GROUPS DAUGHTER]) + +(\FM.PUSHGROUP [LAMBDA (GROUPID GROUPS AMOUNT DIR) (* jow "12-Apr-86 18:25") (* GROUPS is freemenu groups structure, GROUPID is id of group in GROUPS to  push. If GROUPID is NIL, then push top group.  Push each item by AMOUNT in the DIR direction.  Update the groups region. Currently this function only knows about pushing UP  and RIGHT,) (OR GROUPID (SETQ GROUPID (\FM.DTOPGROUPID GROUPS))) (for ITEM in (\FM.DGROUPPROP GROUPS GROUPID 'ITEMS) do (SELECTQ DIR (UP (add (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM 'REGION)) AMOUNT) [replace (REGION BOTTOM) of (\FM.ITEMPROP ITEM 'MAXREGION) with (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM 'REGION]) (RIGHT (add (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM 'REGION)) AMOUNT) [replace (REGION LEFT) of (\FM.ITEMPROP ITEM 'MAXREGION) with (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM 'REGION]) NIL)) (SELECTQ DIR (UP (add (fetch (REGION BOTTOM) of (\FM.DGROUPPROP GROUPS GROUPID 'REGION)) AMOUNT)) (RIGHT (add (fetch (REGION LEFT) of (\FM.DGROUPPROP GROUPS GROUPID 'REGION)) AMOUNT)) NIL]) + +(\FM.CHECKDESCRIPTION [LAMBDA (ID) (* jow "21-May-86 16:14") (* check the item description for errors.  This is done before creating the item. The general errors are checked first,  and then the type specific errors are checked.  ALSO, if the item is boxed, fill out the description with all of the boxing  info.) (LET [(LABEL (LISTGET ID 'LABEL)) (TYPE (OR (LISTGET ID 'TYPE) 'MOMENTARY] (* ------------------------------  TYPE FIELD) (if (NOT (FMEMB TYPE \FM.ITEM-TYPES)) then (ERROR "Invalid TYPE:" ID)) (* ------------------------------  LABEL FIELD) (if (NOT (OR (AND LABEL (ATOM LABEL)) (STRINGP LABEL) (BITMAPP LABEL))) then (ERROR "Invalid LABEL. Atom, string, or bitmap expected:" ID)) (* ------------------------------  FIXP FIELDS) (for PROP in '(LEFT BOTTOM MAXWIDTH HAXHEIGHT BOX BOXSPACE) do (if [AND (LISTGET ID PROP) (NOT (FIXP (LISTGET ID PROP] then (ERROR (CONCAT "Invalid " PROP ". Fixp expected:") ID))) (* ------------------------------  JUSTIFICATION FIELDS) (if (AND (LISTGET ID 'HJUSTIFY) (NOT (FMEMB (LISTGET ID 'HJUSTIFY) \FM.HJUSTIFY-SPECS))) then (ERROR (CONCAT "Invalid HJUSTIFY. One of " \FM.HJUSTIFY-SPECS " expected:" ID) )) (if (AND (LISTGET ID 'VJUSTIFY) (NOT (FMEMB (LISTGET ID 'VJUSTIFY) \FM.VJUSTIFY-SPECS))) then (ERROR (CONCAT "Invalid VJUSTIFY. One of " \FM.VJUSTIFY-SPECS " expected:" ID) )) (* ------------------------------  TEXTURE FIELDS) (for PROP in '(BACKGROUND BOXSHADE) do (if [AND (LISTGET ID PROP) (NOT (TEXTUREP (LISTGET ID PROP] then (ERROR (CONCAT "Invalid " PROP ". Shade expected:") ID))) (* ------------------------------  HIGHLIGHT FIELD) (if [AND (LISTGET ID 'HIGHLIGHT) [NOT (ATOM (LISTGET ID 'HIGHLIGHT] [NOT (STRINGP (LISTGET ID 'HIGHLIGHT] (NOT (BITMAPP (LISTGET ID 'HIGHLIGHT] then (ERROR "Invalid HIGHLIGHT. Texture or Label expected:" ID)) (* ------------------------------  FUNCTION FIELDS) (for PROP in '(SELECTEDFN DOWNFN HELDFN MOVEDFN) do (if [AND (LISTGET ID PROP) (NOT (ATOM (LISTGET ID PROP))) (NOT (LISTP (LISTGET ID PROP] then (ERROR (CONCAT "Invalid " PROP ". Atomic function name expected:") ID))) (* ------------------------------  TYPE SPECIFIC CHECKS) [if (LISTGET ID 'BOX) then (* fill out box info in description) (OR (LISTGET ID 'BOXSHADE) (LISTPUT ID 'BOXSHADE BLACKSHADE)) (LISTPUT ID 'BOXOFFSET (IPLUS (LISTGET ID 'BOX) (OR (LISTGET ID 'BOXSPACE) \FM.BOXSPACE] (SELECTQ TYPE (3STATE (if [AND (LISTGET ID 'OFF) [NOT (ATOM (LISTGET ID 'OFF] [NOT (STRINGP (LISTGET ID 'OFF] (NOT (BITMAPP (LISTGET ID 'OFF] then (ERROR "Invalid OFF. Texture or Label expected:" ID))) (STATE (if [AND (LISTGET ID 'CHANGESTATE) (NOT (ATOM (LISTGET ID 'CHANGESTATE] then (ERROR "Invalid CHANGESTATE property. Atomic function name expected:" ID)) (if [AND (LISTGET ID 'MENUITEMS) (NOT (LISTP (LISTGET ID 'MENUITEMS] then (ERROR "Invalid MENUITEMS property. List of items expected:" ID))) (NWAY (if (NOT (LISTGET ID 'COLLECTION)) then (ERROR "Unspecified COLLECTION for NWAY item:" ID))) (EDIT (if (BITMAPP LABEL) then (ERROR "Edit item label must be string or atom." ID))) NIL]) + +(\FM.CHECKPROPS [LAMBDA (PROPS) (* jow "28-Oct-86 18:37") (if (AND (LISTGET PROPS 'FORMAT) (NOT (FMEMB (LISTGET PROPS 'FORMAT) \FM.FORMAT-TYPES))) then (ERROR "PROPS Error. Invalid FORMAT:" PROPS)) (for PROP in '(LEFT BOTTOM ROWSPACE COLUMNSPACE BOX BOXSPACE) do (if [AND (LISTGET PROPS PROP) (NOT (FIXP (LISTGET PROPS PROP] then (ERROR (CONCAT "PROPS Error. FIXP expected for " PROP " property:") PROPS))) (for PROP in '(BOXSHADE BACKGROUND) do (if [AND (LISTGET PROPS PROP) (NOT (TEXTUREP (LISTGET PROPS PROP] then (ERROR (CONCAT "PROPS Error. TEXTURE expected for " PROP " property:") PROPS]) + +(\FM.CREATEITEM [LAMBDA (ID FONTDEFAULT LEFT BOTTOM GROUPID) (* jow "17-Apr-86 19:28") (* create an item at position LEFT and BOTTOM as specified by the formatter.  Add item offsets given in the description to this position.  Set the items region to the minimum of the label size and the max size  specified.) (add LEFT (OR (LISTGET ID 'LEFT) 0)) (add BOTTOM (OR (LISTGET ID 'BOTTOM) 0)) (LET* [(TYPE (OR (LISTGET ID 'TYPE) 'MOMENTARY)) (LABEL (LISTGET ID 'LABEL)) (FONT (OR [AND (LISTGET ID 'FONT) (APPLY* (FUNCTION FONTCREATE) (LISTGET ID 'FONT] FONTDEFAULT)) (REGIONS (\FM.GETREGIONS ID LEFT BOTTOM FONT)) (BITMAPS (\FM.GETBITMAPS ID FONT (CAR REGIONS) (CADR REGIONS))) (ITEM (create FREEMENUITEM FM.TYPE _ TYPE FM.LABEL _ LABEL FM.ID _ (LISTGET ID 'ID) FM.GROUPID _ GROUPID FM.INITSTATE _ (LISTGET ID 'INITSTATE) FM.FONT _ FONT FM.BITMAP _ (CAR BITMAPS) FM.HIGHLIGHT _ (CADR BITMAPS) FM.REGION _ (CAR REGIONS) FM.MAXREGION _ (CADDR REGIONS) FM.MESSAGE _ (LISTGET ID 'MESSAGE) FM.LINKS _ (OR (LISTGET ID 'LINKS) (LIST NIL)) FM.DOWNFN _ (OR (LISTGET ID 'DOWNFN) (FUNCTION NILL)) FM.HELDFN _ (OR (LISTGET ID 'HELDFN) (FUNCTION NILL)) FM.MOVEDFN _ (OR (LISTGET ID 'MOVEDFN) (FUNCTION NILL)) FM.SELECTEDFN _ (OR (LISTGET ID 'SELECTEDFN) (FUNCTION NILL] (\FM.READUSERDATA ITEM ID) (APPLY* (PACK* "\FM." TYPE "-SETUP") ITEM REGIONS) (* pass REGIONS to setup fn, since  might need highlightregion, etc.) ITEM]) + +(\FM.GETREGIONS [LAMBDA (ID LEFT BOTTOM FONT) (* jow "19-Apr-86 21:41") (* Called by the formatter to determine the region an item will occupy.  LEFT and BOTTOM are the items proposed position, determined by the formatter.  If the item is boxed, then the region is the region of the box, not the label  in the box. Return a list containing the item region, the highlight region, and  the max region.) (LET* [(WIDTH (\FM.ITEMWIDTH (LISTGET ID 'LABEL) FONT)) (HEIGHT (\FM.ITEMHEIGHT (LISTGET ID 'LABEL) FONT)) (HL (LISTGET ID 'HIGHLIGHT)) (HIGHLIGHT (OR (AND (ATOM HL) (NOT (TEXTUREP HL)) HL) (BITMAPP HL) (STRINGP HL))) (HIGHLIGHTWIDTH (OR (AND HIGHLIGHT (\FM.ITEMWIDTH HIGHLIGHT FONT)) 0)) (HIGHLIGHTHEIGHT (OR (AND HIGHLIGHT (\FM.ITEMHEIGHT HIGHLIGHT FONT)) 0)) (MAXWIDTH (OR (LISTGET ID 'MAXWIDTH) (IMAX WIDTH HIGHLIGHTWIDTH))) (MAXHEIGHT (OR (LISTGET ID 'MAXHEIGHT) (IMAX HEIGHT HIGHLIGHTHEIGHT))) (BOXOFFSET (AND (LISTGET ID 'BOXOFFSET) (ITIMES 2 (LISTGET ID 'BOXOFFSET] (if BOXOFFSET then (SETQ WIDTH (IPLUS BOXOFFSET MAXWIDTH)) (SETQ HEIGHT (IPLUS BOXOFFSET MAXHEIGHT)) (LIST (CREATEREGION LEFT BOTTOM WIDTH HEIGHT) (AND HIGHLIGHT (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)) (CREATEREGION LEFT BOTTOM WIDTH HEIGHT)) else (LIST (CREATEREGION LEFT BOTTOM (IMIN WIDTH MAXWIDTH) (IMIN HEIGHT MAXHEIGHT)) (AND HIGHLIGHT (CREATEREGION LEFT BOTTOM (IMIN HIGHLIGHTWIDTH MAXWIDTH) (IMIN HIGHLIGHTHEIGHT MAXHEIGHT))) (CREATEREGION LEFT BOTTOM MAXWIDTH MAXHEIGHT]) + +(\FM.GETBITMAPS [LAMBDA (ID FONT ITEMREGION HIGHLIGHTREGION) (* jow "18-Apr-86 14:57") (* Figure out the items bitmap and  highlighting requirements.) (LET ((BOX (OR (LISTGET ID 'BOX) 0)) (BOXSHADE (LISTGET ID 'BOXSHADE)) (HIGHLIGHT (LISTGET ID 'HIGHLIGHT)) (WIDTH (fetch (REGION WIDTH) of ITEMREGION)) (HEIGHT (fetch (REGION HEIGHT) of ITEMREGION)) BITMAP HLBITMAP) (SETQ BITMAP (\FM.MAKEBITMAP (LISTGET ID 'LABEL) FONT WIDTH HEIGHT ID)) [COND ((OR (AND HIGHLIGHT (ATOM HIGHLIGHT) (NOT (TEXTUREP HIGHLIGHT))) (STRINGP HIGHLIGHT) (BITMAPP HIGHLIGHT)) (* highlight label specified.) (SETQ HLBITMAP (\FM.MAKEBITMAP HIGHLIGHT FONT (fetch (REGION WIDTH) of HIGHLIGHTREGION ) (fetch (REGION HEIGHT) of HIGHLIGHTREGION) ID))) ((OR (TEXTUREP HIGHLIGHT) (AND (LISTGET ID 'BOX) (NEQ BOXSHADE BLACKSHADE) (SETQ HIGHLIGHT BOXSHADE))) (* highlight texture was specified,  or non-black box with default  highlight (boxshade)) (SETQ HLBITMAP (BITMAPCOPY BITMAP)) (BLTSHADE HIGHLIGHT HLBITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2)) (IDIFFERENCE HEIGHT (ITIMES BOX 2)) 'PAINT)) (T (* invert. Start with bitmap, and  invert region inside box.) (SETQ HLBITMAP (BITMAPCOPY BITMAP)) (BITBLT BITMAP BOX BOX HLBITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2)) (IDIFFERENCE HEIGHT (ITIMES BOX 2)) 'INVERT] (LIST BITMAP HLBITMAP]) + +(\FM.MAKEBITMAP [LAMBDA (LABEL FONT WIDTH HEIGHT ID) (* jow "18-Apr-86 14:29") (* use ID only for boxing info.) (LET ((BOX (LISTGET ID 'BOX)) (BOXOFFSET (OR (LISTGET ID 'BOXOFFSET) 0)) (BITMAP (BITMAPCREATE WIDTH HEIGHT)) CLIPPINGREGION) [SETQ CLIPPINGREGION (CREATEREGION BOXOFFSET BOXOFFSET (IDIFFERENCE WIDTH (ITIMES BOXOFFSET 2)) (IDIFFERENCE HEIGHT (ITIMES BOXOFFSET 2] (if BOX then (* check for boxed item) (BLTSHADE (LISTGET ID 'BOXSHADE) BITMAP) (* do box and background) (BLTSHADE WHITESHADE BITMAP BOX BOX (IDIFFERENCE WIDTH (ITIMES BOX 2)) (IDIFFERENCE HEIGHT (ITIMES BOX 2))) (* copy box into HLBITMAP)) (if (BITMAPP LABEL) then (BITBLT LABEL 0 0 BITMAP BOXOFFSET BOXOFFSET NIL NIL NIL NIL NIL CLIPPINGREGION ) else (LET ((STREAM (DSPCREATE BITMAP))) (DSPFONT FONT STREAM) (DSPXPOSITION BOXOFFSET STREAM) (DSPYPOSITION (IPLUS BOXOFFSET (FONTPROP FONT 'DESCENT)) STREAM) (DSPCLIPPINGREGION CLIPPINGREGION STREAM) (PRIN1 LABEL STREAM))) BITMAP]) + +(\FM.READUSERDATA [LAMBDA (ITEM DESCRIPTION) (* jow "15-Apr-86 16:58") (* scans DESCRIPTION for user props.  Add any prop/value pairs found to  ITEM's userdata list.) (for X on DESCRIPTION by (CDDR X) do (if (NOT (FMEMB (CAR X) \FM.DESCRIPTION-PROPS)) then (LISTPUT (\FM.ITEMPROP ITEM 'USERDATA) (CAR X) (CADR X]) + +(\FM.MAKELINKS [LAMBDA (WINDOW) (* jow "12-Apr-86 19:07") (* go through items and replace link  requests with actual pointers) (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) do (for LINKTAIL ITEMPTR on (CDR (\FM.ITEMPROP ITEM 'LINKS)) by (CDDR LINKTAIL) do (SETQ ITEMPTR (CAR LINKTAIL)) (RPLACA LINKTAIL (\FM.COERCEITEMPTR ITEMPTR WINDOW ITEM ]) + +(\FM.COLLECTNWAYS [LAMBDA (WINDOW) (* jow "17-Apr-86 15:28") (* go through items in menu, building NWAYS structure.  Select the first item in each collection.  NWAYS structure is list of collection proplists, each beginning with id of  collection, and containing STATE of collection, and other user props.) (LET ((NWAYS (LIST NIL)) (NWAYIDS (LIST NIL)) NWAYPROPS ITEMPTR) (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) do (if [AND (EQ (\FM.ITEMPROP ITEM 'TYPE) 'NWAY) (NOT (FMEMB (\FM.ITEMPROP ITEM 'COLLECTION) (CAR NWAYIDS] then (* this is the first nway of this  collection) (TCONC NWAYIDS (\FM.ITEMPROP ITEM 'COLLECTION)) (* setup NWAYPROPS and STATE) (if (\FM.ITEMPROP ITEM 'NWAYPROPS) then (SETQ NWAYPROPS (\FM.ITEMPROP ITEM 'NWAYPROPS)) (LISTPUT NWAYPROPS 'STATE ITEM) else (SETQ NWAYPROPS (LIST 'STATE ITEM))) (* setup INITSTATE) (if (LISTGET NWAYPROPS 'INITSTATE) then (* make link to specified INITSTATE  item) (SETQ ITEMPTR (LISTGET NWAYPROPS 'INITSTATE)) (LISTPUT NWAYPROPS 'INITSTATE (\FM.COERCEITEMPTR ITEMPTR WINDOW ITEM)) else (* MAKE THIS ITEM THE INITSTATE) (LISTPUT NWAYPROPS 'INITSTATE ITEM)) (TCONC NWAYS (\FM.MAKEGROUP (CADR NWAYIDS) NWAYPROPS)) (* this is the selected item) (\FM.TOGGLE-CHANGESTATE ITEM T))) (WINDOWPROP WINDOW 'FM.NWAYS (CAR NWAYS]) + +(\FM.SETATTACHPOINT [LAMBDA (ITEMS WIDTH HEIGHT) (* jow "12-Apr-86 18:02") (* figure out each items attach  point based on its position in  extent) (for ITEM in ITEMS do (\FM.ITEMPROP ITEM 'ATTACHPOINT (\FM.ATTACHPOINT ITEM WIDTH HEIGHT]) + +(\FM.CREATEW [LAMBDA (GROUPS TITLE BACKGROUND BORDER) (* ; "Edited 6-Jan-87 18:32 by woz") (* Create a freemenu window.  Then setup the window with the  necessary freemenu properties.) (LET* ([REGION (COPY (LISTGET (CDAR GROUPS) 'REGION] (WINDOW (CREATEW (CREATEREGION (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (WIDTHIFWINDOW (fetch (REGION WIDTH) of REGION) BORDER) (HEIGHTIFWINDOW (fetch (REGION HEIGHT) of REGION) TITLE BORDER)) TITLE BORDER T))) (WINDOWPROP WINDOW 'WINDOWENTRYFN '\FM.WINDOWENTRYFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN '\FM.BUTTONEVENTFN) (WINDOWPROP WINDOW 'RIGHTBUTTONFN '\FM.RIGHTBUTTONFN) (WINDOWPROP WINDOW 'REPAINTFN '\FM.REDISPLAYMENU) (WINDOWPROP WINDOW 'RESHAPEFN '\FM.RESHAPEFN) (WINDOWPROP WINDOW 'INITCORNERSFN '\FM.INITCORNERSFN) (WINDOWPROP WINDOW 'OPENFN '\FM.OPENFN) (WINDOWPROP WINDOW 'CLOSEFN '\FM.ENDEDIT) (WINDOWPROP WINDOW 'SHRINKFN '\FM.ENDEDIT) (WINDOWPROP WINDOW 'SCROLLFN 'SCROLLBYREPAINTFN) (WINDOWPROP WINDOW 'SCROLLEXTENTUSE '(LIMIT . LIMIT)) (WINDOWPROP WINDOW 'EXTENT REGION) (WINDOWPROP WINDOW 'FM.MINWIDTH (fetch (REGION WIDTH) of REGION)) (WINDOWPROP WINDOW 'FM.MINHEIGHT (fetch (REGION HEIGHT) of REGION)) (WINDOWPROP WINDOW 'FM.BUSY NIL) (WINDOWPROP WINDOW 'FM.BACKGROUND BACKGROUND) (WINDOWPROP WINDOW 'FM.GROUPS GROUPS) (WINDOWPROP WINDOW 'FM.ITEMS (LISTGET (CDAR GROUPS) 'ITEMS)) WINDOW]) + +(\FM.STARTEDIT [LAMBDA (ITEM WINDOW CLEARFLG) (* jow "17-Oct-86 18:35") (RESETLST (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'FM.BUSY NIL)) (WINDOWPROP WINDOW 'FM.BUSY T) (\FM.EDIT-ITEM ITEM WINDOW CLEARFLG T (if (EQ (\FM.ITEMPROP ITEM 'TYPE) 'NUMBER) then (FUNCTION \FM.NUMBER-CHANGESTATE))))]) +) + +(RPAQ? \FM.GROUP-ID-COUNTER 0) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \FM.GROUP-ID-COUNTER) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.MAKE-GROUP-ID MACRO (NIL (CONS (CL:INCF \FM.GROUP-ID-COUNTER) + NIL))) + +(PUTPROPS \FM.SETUPPROPS MACRO ((DESCRIPTION CHANGEPROPS) + (if (EQ \FM.PROPSPEC (CAAR DESCRIPTION)) + then (SETQ PROPS (CDAR DESCRIPTION)) + (RPLNODE2 DESCRIPTION (CDR DESCRIPTION)) + (* yank props out of row) + (\FM.CHECKPROPS PROPS) + (\FM.SETFORMATPROPS CHANGEPROPS) + else (SETQ PROPS (LIST 'ITEMS NIL)) + (SETQ ID (\FM.MAKE-GROUP-ID))) + (LISTPUT PROPS 'MOTHER MOTHER))) + +(PUTPROPS \FM.SETFORMATPROPS MACRO + ((CHANGEPROPS) + (for PROP in CHANGEPROPS + do (SELECTQ PROP + (FORMAT [AND (LISTGET PROPS 'FORMAT) + (SETQ FORMAT (LISTGET PROPS 'FORMAT]) + (FONT [AND (LISTGET PROPS 'FONT) + (SETQ FONT (APPLY* (FUNCTION FONTCREATE) + (LISTGET PROPS 'FONT]) + (LEFT (add LEFT (OR (LISTGET PROPS 'LEFT) + 0))) + (BOTTOM (add BOTTOM (OR (LISTGET PROPS 'BOTTOM) + 0))) + (ROWSPACE [AND (LISTGET PROPS 'ROWSPACE) + (SETQ ROWSPACE (LISTGET PROPS 'ROWSPACE]) + (COLUMNSPACE [AND (LISTGET PROPS 'COLUMNSPACE) + (SETQ COLUMNSPACE (LISTGET PROPS 'COLUMNSPACE]) + (ID (SETQ ID (OR (LISTGET PROPS 'ID) + (\FM.MAKE-GROUP-ID)))) + NIL)))) + +(PUTPROPS \FM.CHECKFORBOX MACRO [NIL (COND + ((LISTGET PROPS 'BOX) + (* offset group to allow for box.) + (OR (LISTGET PROPS 'BOXSHADE) + (LISTPUT PROPS 'BOXSHADE BLACKSHADE)) + (OR (LISTGET PROPS 'BOXSPACE) + (LISTPUT PROPS 'BOXSPACE \FM.BOXSPACE)) + (SETQ OLDCORNER (CONS LEFT BOTTOM)) + [SETQ BOXOFFSET (IPLUS (LISTGET PROPS 'BOX) + (LISTGET PROPS 'BOXSPACE] + (add LEFT BOXOFFSET) + (add BOTTOM BOXOFFSET]) + +(PUTPROPS \FM.UPDATEFORBOX MACRO [NIL (COND + (BOXOFFSET (* group is boxed%: readjust group + region) + (replace (REGION LEFT) of EXTENT + with (CAR OLDCORNER)) + (replace (REGION BOTTOM) of EXTENT + with (CDR OLDCORNER)) + (add (fetch (REGION WIDTH) + of EXTENT) + (ITIMES BOXOFFSET 2)) + (add (fetch (REGION HEIGHT) + of EXTENT) + (ITIMES BOXOFFSET 2]) + +(PUTPROPS \FM.UPDATEGRID MACRO + [(NUM LEFT) + (if (IGREATERP NUM GRIDLEN) + then (* add this col to grid) + (TCONC GRID LEFT) + (add GRIDLEN 1) + else (* this col exists. + check alignment) + (LET ((GRIDTAIL (FNTH (CAR GRID) + NUM))) + (COND + ((IGREATERP LEFT (CAR GRIDTAIL)) (* push grid column over) + (for TAIL on GRIDTAIL bind (AMOUNT _ (IDIFFERENCE + LEFT + (CAR GRIDTAIL))) + do (add (CAR TAIL) + AMOUNT]) + +(PUTPROPS \FM.ITEMWIDTH MACRO ((LABEL FONT) + (if (BITMAPP LABEL) + then (BITMAPWIDTH LABEL) + else (STRINGWIDTH LABEL FONT)))) + +(PUTPROPS \FM.ITEMHEIGHT MACRO [(LABEL FONT) + (if (BITMAPP LABEL) + then (BITMAPHEIGHT LABEL) + else (FONTPROP FONT 'HEIGHT]) + +(PUTPROPS \FM.ATTACHPOINT MACRO + [(ITEM WIDTH HEIGHT) + (LET [(MAXREGION (\FM.ITEMPROP ITEM 'MAXREGION] + (CONS [FIX (FPLUS 0.5 (FQUOTIENT (ITIMES (fetch (REGION WIDTH) of MAXREGION) + (fetch (REGION LEFT) of MAXREGION)) + (IDIFFERENCE WIDTH (fetch (REGION WIDTH) + of MAXREGION] + (FIX (FPLUS 0.5 (FQUOTIENT (ITIMES (fetch (REGION HEIGHT) of MAXREGION) + (fetch (REGION BOTTOM) of MAXREGION)) + (IDIFFERENCE HEIGHT (fetch (REGION HEIGHT) + of MAXREGION]) +) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \FM.FORMAT-TYPES (ROW COLUMN TABLE EXPLICIT)) + +(RPAQQ \FM.DEFAULTFORMAT ROW) + +(RPAQQ \FM.GROUPSPEC GROUP) + +(RPAQQ \FM.PROPSPEC PROPS) + +(RPAQQ \FM.HJUSTIFY-SPECS (LEFT CENTER RIGHT)) + +(RPAQQ \FM.VJUSTIFY-SPECS (TOP MIDDLE BOTTOM)) + +(RPAQQ \FM.BOXSPACE 1) + +(RPAQQ \FM.ROWSPACE 2) + +(RPAQQ \FM.COLUMNSPACE 10) + +(RPAQQ \FM.ITEM-TYPES (MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT EDITSTART DISPLAY)) + +(RPAQQ \FM.DESCRIPTION-PROPS (TYPE LABEL LEFT BOTTOM ID GROUPID STATE INITSTATE FONT BITMAP + REGION MAXREGION MESSAGE USERDATA LINKS SYSDOWNFN SYSMOVEDFN + SYSSELECTEDFN DOWNFN HELDFN MOVEDFN SELECTEDFN)) + + +[CONSTANTS (\FM.FORMAT-TYPES '(ROW COLUMN TABLE EXPLICIT)) + (\FM.DEFAULTFORMAT 'ROW) + (\FM.GROUPSPEC 'GROUP) + (\FM.PROPSPEC 'PROPS) + (\FM.HJUSTIFY-SPECS '(LEFT CENTER RIGHT)) + (\FM.VJUSTIFY-SPECS '(TOP MIDDLE BOTTOM)) + (\FM.BOXSPACE 1) + (\FM.ROWSPACE 2) + (\FM.COLUMNSPACE 10) + (\FM.ITEM-TYPES '(MOMENTARY TOGGLE 3STATE NWAY STATE NUMBER EDIT EDITSTART DISPLAY)) + (\FM.DESCRIPTION-PROPS '(TYPE LABEL LEFT BOTTOM ID GROUPID STATE INITSTATE FONT BITMAP REGION + MAXREGION MESSAGE USERDATA LINKS SYSDOWNFN SYSMOVEDFN + SYSSELECTEDFN DOWNFN HELDFN MOVEDFN SELECTEDFN] +) +) +(DECLARE%: EVAL@COMPILE + +(DATATYPE FREEMENUITEM + (FM.TYPE FM.LABEL FM.ID FM.GROUPID FM.STATE FM.INITSTATE FM.FONT FM.BITMAP FM.HIGHLIGHT + FM.REGION FM.MAXREGION FM.MESSAGE FM.USERDATA FM.LINKS FM.SYSDOWNFN FM.SYSMOVEDFN + FM.SYSSELECTEDFN FM.DOWNFN FM.HELDFN FM.MOVEDFN FM.SELECTEDFN) + FM.USERDATA _ (LIST NIL) + FM.SYSDOWNFN _ (FUNCTION NILL) + FM.SYSMOVEDFN _ (FUNCTION NILL) + FM.SYSSELECTEDFN _ (FUNCTION NILL)) +) + +(/DECLAREDATATYPE 'FREEMENUITEM + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + '((FREEMENUITEM 0 POINTER) + (FREEMENUITEM 2 POINTER) + (FREEMENUITEM 4 POINTER) + (FREEMENUITEM 6 POINTER) + (FREEMENUITEM 8 POINTER) + (FREEMENUITEM 10 POINTER) + (FREEMENUITEM 12 POINTER) + (FREEMENUITEM 14 POINTER) + (FREEMENUITEM 16 POINTER) + (FREEMENUITEM 18 POINTER) + (FREEMENUITEM 20 POINTER) + (FREEMENUITEM 22 POINTER) + (FREEMENUITEM 24 POINTER) + (FREEMENUITEM 26 POINTER) + (FREEMENUITEM 28 POINTER) + (FREEMENUITEM 30 POINTER) + (FREEMENUITEM 32 POINTER) + (FREEMENUITEM 34 POINTER) + (FREEMENUITEM 36 POINTER) + (FREEMENUITEM 38 POINTER) + (FREEMENUITEM 40 POINTER)) + '42) + + + +(* ; "FREEMENU WINDOWS") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.TRANSPOSE MACRO [(POINT OLD NEW) + (FIX (FPLUS 0.5 (FQUOTIENT (FTIMES POINT NEW) + OLD]) +) +) +(DEFINEQ + +(\FM.OPENFN [LAMBDA (WINDOW) (* ; "Edited 19-Jan-87 17:58 by woz") (* ;;; "redisplay the menu when opening, because its state might have been changed while closed. however, if we're under SHAPEW, then punt, and let the reshapefn redisplay, to avoid redundancy.") (\FM.INSUREWINDOW WINDOW) (if (NOT (STKPOS 'SHAPEW1)) then (\FM.REDISPLAYMENU WINDOW]) + +(\FM.REDISPLAYMENU [LAMBDA (WINDOW UPDATEREGION) (* jow "26-Jun-86 14:43") (* RIGHT NOW THIS IS DEPENDENT ON  THE ALIST/PROPLIST STRUCTURE OF  GROUPS.) (if (OPENWP WINDOW) then (LET (REGION BOX BACKGROUND) (\FM.RESETCLIPPINGREGION WINDOW) (* back to full window) (\FM.FILLWINDOW WINDOW (WINDOWPROP WINDOW 'FM.BACKGROUND)) [for GROUP in (WINDOWPROP WINDOW 'FM.GROUPS) do (* blast all boxes and backgrounds) (SETQ GROUP (CDR GROUP)) (if (SETQ BOX (LISTGET GROUP 'BOX)) then (SETQ REGION (LISTGET GROUP 'REGION)) (BLTSHADE (LISTGET GROUP 'BOXSHADE) WINDOW NIL NIL NIL NIL NIL REGION) (BLTSHADE (LISTGET GROUP 'BACKGROUND) WINDOW (IPLUS (fetch (REGION LEFT) of REGION) BOX) (IPLUS (fetch (REGION BOTTOM) of REGION) BOX) (IDIFFERENCE (fetch (REGION WIDTH) of REGION) (IPLUS BOX BOX)) (IDIFFERENCE (fetch (REGION HEIGHT) of REGION ) (IPLUS BOX BOX))) elseif (SETQ BACKGROUND (LISTGET GROUP 'BACKGROUND)) then (BLTSHADE BACKGROUND WINDOW NIL NIL NIL NIL NIL (LISTGET GROUP 'REGION] (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) do (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'BITMAP) WINDOW]) + +(\FM.RESHAPEFN [LAMBDA (WINDOW B OLDREGION) (* jow "25-Apr-86 11:21") (if (NOT (WINDOWPROP WINDOW 'FM.DONTRESHAPE)) then (\FM.ENDEDIT WINDOW T) (LET [(OLDWIDTH (fetch (REGION WIDTH) of OLDREGION)) (OLDHEIGHT (fetch (REGION HEIGHT) of OLDREGION)) (NEWWIDTH (WINDOWPROP WINDOW 'WIDTH)) (NEWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (MINWIDTH (WINDOWPROP WINDOW 'FM.MINWIDTH)) (MINHEIGHT (WINDOWPROP WINDOW 'FM.MINHEIGHT] (COND ((AND (IGEQ OLDWIDTH MINWIDTH) (IGREATERP NEWWIDTH MINWIDTH)) (\FM.TRANSPOSEHORZ WINDOW OLDWIDTH NEWWIDTH)) ((AND (IGREATERP OLDWIDTH MINWIDTH) (ILEQ NEWWIDTH MINWIDTH)) (* transpose to minimal width) (\FM.TRANSPOSEHORZ WINDOW OLDWIDTH MINWIDTH)) ((AND (ILESSP OLDWIDTH MINWIDTH) (IGREATERP NEWWIDTH MINWIDTH)) (* transpose from minimal width) (\FM.TRANSPOSEHORZ WINDOW MINWIDTH NEWWIDTH))) (COND ((AND (IGEQ OLDHEIGHT MINHEIGHT) (IGREATERP NEWHEIGHT MINHEIGHT)) (\FM.TRANSPOSEVERT WINDOW OLDHEIGHT NEWHEIGHT)) ((AND (IGREATERP OLDHEIGHT MINHEIGHT) (ILEQ NEWHEIGHT MINHEIGHT)) (* transpose to minimal height) (\FM.TRANSPOSEVERT WINDOW OLDHEIGHT MINHEIGHT)) ((AND (ILESSP OLDHEIGHT MINHEIGHT) (IGREATERP NEWHEIGHT MINHEIGHT)) (* transpose from minimal height) (\FM.TRANSPOSEVERT WINDOW MINHEIGHT NEWHEIGHT))) (\FM.UPDATEGROUPEXTENT (WINDOWPROP WINDOW 'FM.GROUPS)) (WINDOWPROP WINDOW 'EXTENT (\FM.WINDOWEXTENT WINDOW)) (* grab new extent) )) (\FM.UNSCROLLWINDOW WINDOW) (FM.REDISPLAYMENU WINDOW]) + +(\FM.UNSCROLLWINDOW [LAMBDA (WINDOW) (* jow "12-Apr-86 15:22") (* called after reshaping WINDOW; resets XOFFSET and YOFFSET to unscroll window  Clipping region set back to copy of full WINDOW) (DSPXOFFSET [IPLUS (WINDOWPROP WINDOW 'BORDER) (fetch (REGION LEFT) of (WINDOWPROP WINDOW 'REGION] WINDOW) (DSPYOFFSET [IPLUS (WINDOWPROP WINDOW 'BORDER) (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION] WINDOW) (\FM.RESETCLIPPINGREGION WINDOW]) + +(\FM.RESETCLIPPINGREGION [LAMBDA (WINDOW) (* jow "10-Apr-86 21:52") (* reset the clipping region of  WINDOW to the windows full expanse.) (DSPCLIPPINGREGION (CREATEREGION (IDIFFERENCE (IPLUS (fetch (REGION LEFT) of (WINDOWPROP WINDOW 'REGION)) (WINDOWPROP WINDOW 'BORDER)) (DSPXOFFSET NIL WINDOW)) (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION)) (WINDOWPROP WINDOW 'BORDER)) (DSPYOFFSET NIL WINDOW)) (WINDOWPROP WINDOW 'WIDTH) (WINDOWPROP WINDOW 'HEIGHT)) WINDOW]) + +(\FM.FILLWINDOW [LAMBDA (WINDOW SHADE) (* jow "11-Apr-86 11:51") (* fill entire window up to border with shade.  Rely on clippingregion being full window on entry.  Rely on border space is 2 bits.) (LET ((REGION (DSPCLIPPINGREGION NIL WINDOW))) (RESETLST (RESETSAVE NIL (LIST 'DSPCLIPPINGREGION REGION WINDOW)) (DSPCLIPPINGREGION (CREATEREGION (IDIFFERENCE (fetch (REGION LEFT) of REGION) 2) (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) 2) (IPLUS 4 (fetch (REGION WIDTH) of REGION)) (IPLUS 4 (fetch (REGION HEIGHT) of REGION))) WINDOW) (DSPFILL NIL SHADE NIL WINDOW))]) + +(\FM.INITCORNERSFN [LAMBDA (WINDOW) (* jow " 3-Apr-86 23:35") (* called by SHAPEW to provide the initial corners of the reshape ghost box, in  the form (x1 y1 x2 y2)%, where 1 is fixed and 2 is tracked.  respond with the freemenus MINIMAL SHAPE leaving left, bottom as they are.) (LET [[LEFT (fetch (REGION LEFT) of (WINDOWPROP WINDOW 'REGION] (BOTTOM (fetch (REGION BOTTOM) of (WINDOWPROP WINDOW 'REGION] (LIST LEFT BOTTOM [IPLUS LEFT (WIDTHIFWINDOW (WINDOWPROP WINDOW 'FM.MINWIDTH) (WINDOWPROP WINDOW 'BORDER] (IPLUS BOTTOM (HEIGHTIFWINDOW (WINDOWPROP WINDOW 'FM.MINHEIGHT) (WINDOWPROP WINDOW 'TITLE) (WINDOWPROP WINDOW 'BORDER]) + +(\FM.TRANSPOSEHORZ [LAMBDA (WINDOW OLDWIDTH NEWWIDTH) (* jow "12-Apr-86 18:27") (* transpose left point.) (for ITEM REGION in (WINDOWPROP WINDOW 'FM.ITEMS) do (SETQ REGION (\FM.ITEMPROP ITEM 'REGION)) (replace (REGION LEFT) of REGION with (\FM.TRANSPOSE (fetch (REGION LEFT) of REGION) OLDWIDTH NEWWIDTH)) (replace (REGION LEFT) of (\FM.ITEMPROP ITEM 'MAXREGION) with (fetch (REGION LEFT) of REGION]) + +(\FM.TRANSPOSEVERT [LAMBDA (WINDOW OLDHEIGHT NEWHEIGHT) (* jow "12-Apr-86 18:27") (* transpose bottom point) (for ITEM REGION in (WINDOWPROP WINDOW 'FM.ITEMS) do (SETQ REGION (\FM.ITEMPROP ITEM 'REGION)) (replace (REGION BOTTOM) of REGION with (\FM.TRANSPOSE (fetch (REGION BOTTOM) of REGION) OLDHEIGHT NEWHEIGHT)) (replace (REGION BOTTOM) of (\FM.ITEMPROP ITEM 'MAXREGION) with (fetch (REGION BOTTOM) of REGION]) + +(\FM.UPDATEGROUPEXTENT [LAMBDA (GROUPS GROUPLIST) (* jow "12-Apr-86 18:28") (* THIS DEPENDS ON THE ALIST/PROPLIST GROUP STRUCTURE.  GROUPS is a freemenu group alist structure.  GROUPLIST is a list of group id's to update the extent of.  If GROUPLIST is NIL, then update top group.) [OR GROUPLIST (SETQ GROUPLIST (LIST (\FM.DTOPGROUPID GROUPS] (LET (GROUP REGION DAUGHTERS BOXOFFSET) (for ID in GROUPLIST do (SETQ GROUP (CDR (ASSOC ID GROUPS))) [SETQ REGION (LISTPUT GROUP 'REGION (COPYALL (\FM.ITEMPROP (CAR (LISTGET GROUP 'ITEMS)) 'MAXREGION] [if (SETQ DAUGHTERS (LISTGET GROUP 'DAUGHTERS)) then (* update subgroups first) (\FM.UPDATEGROUPEXTENT GROUPS DAUGHTERS) (for SUBID in DAUGHTERS do (EXTENDREGION REGION (LISTGET (CDR (ASSOC SUBID GROUPS)) 'REGION] [for ITEM in (LISTGET GROUP 'ITEMS) do (EXTENDREGION REGION (\FM.ITEMPROP ITEM 'MAXREGION] (if (LISTGET GROUP 'BOX) then [SETQ BOXOFFSET (IPLUS (LISTGET GROUP 'BOX) (LISTGET GROUP 'BOXSPACE] (add (fetch (REGION LEFT) of REGION) (MINUS BOXOFFSET)) (add (fetch (REGION BOTTOM) of REGION) (MINUS BOXOFFSET)) (add (fetch (REGION WIDTH) of REGION) (IPLUS BOXOFFSET BOXOFFSET)) (add (fetch (REGION HEIGHT) of REGION) (IPLUS BOXOFFSET BOXOFFSET]) + +(\FM.WINDOWEXTENT [LAMBDA (WINDOW) (* jow "24-Apr-86 17:13") (* start with the top groups extent, assumed to be correct, and then extent to  account for any infinite width items. return extended extent) (LET ([EXTENT (COPY (\FM.TOPGROUPPROP WINDOW 'REGION] REGION) (for ITEM in (WINDOWPROP WINDOW 'FM.ITEMS) when (\FM.ITEMPROP ITEM 'INFINITEWIDTH) do (SETQ REGION (\FM.ITEMPROP ITEM 'REGION)) [replace (REGION WIDTH) of REGION with (\FM.ITEMWIDTH (\FM.ITEMPROP ITEM 'LABEL) (\FM.ITEMPROP ITEM 'FONT] (EXTENDREGION EXTENT REGION)) EXTENT]) + +(\FM.UPDATEWINDOWEXTENT [LAMBDA (WINDOW) (* jow "25-Apr-86 11:38") (* CURRENTLY NEVER CALLED, BECAUSE PROBLEMS WITH RECALCULATING MINWIDTH,  MINHEIGHT, BECAUSE THIS ALGORITHM JUST KEEPS ON ADDING.) (* update the window's extent to the menu's region.  If the extent is not entirely visible, then menu has grown.  Update MIN dimensions of menu to allow getting the entire menu visible again.) (WINDOWPROP WINDOW 'EXTENT (\FM.WINDOWEXTENT WINDOW)) (LET [(EXTENT (WINDOWPROP WINDOW 'EXTENT] [if (IGREATERP (fetch (REGION WIDTH) of EXTENT) (WINDOWPROP WINDOW 'WIDTH)) then (WINDOWPROP WINDOW 'FM.MINWIDTH (IPLUS (WINDOWPROP WINDOW 'FM.MINWIDTH) (IDIFFERENCE (fetch (REGION WIDTH) of EXTENT) (WINDOWPROP WINDOW 'WIDTH] (if (IGREATERP (fetch (REGION HEIGHT) of EXTENT) (WINDOWPROP WINDOW 'HEIGHT)) then (WINDOWPROP WINDOW 'FM.MINHEIGHT (IPLUS (WINDOWPROP WINDOW 'FM.MINHEIGHT) (IDIFFERENCE (fetch (REGION HEIGHT) of EXTENT) (WINDOWPROP WINDOW 'HEIGHT]) +) + + + +(* ; "MOUSE FUNCTIONS") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.ONITEM MACRO [(REGION X Y INFINITWIDTH) + (AND (IGEQ Y (fetch (REGION BOTTOM) of REGION)) + (IGEQ X (fetch (REGION LEFT) of REGION)) + [OR INFINITWIDTH (ILESSP X (IPLUS (fetch (REGION LEFT) + of REGION) + (fetch (REGION WIDTH) + of REGION] + (ILESSP Y (IPLUS (fetch (REGION BOTTOM) of REGION) + (fetch (REGION HEIGHT) of REGION]) + +(PUTPROPS \FM.CHECKREGION MACRO [(WINDOW X Y) + (for (ITEM REGION) in (WINDOWPROP WINDOW + 'FM.ITEMS) + eachtime (SETQ REGION (\FM.ITEMPROP ITEM 'REGION)) + thereis (\FM.ONITEM REGION X Y (\FM.ITEMPROP + ITEM + 'INFINITEWIDTH]) +) +) +(DEFINEQ + +(\FM.WINDOWENTRYFN [LAMBDA (WINDOW) (* jow "20-Oct-86 10:51") (* ;;; "THIS SHOULD NEVER GET CALLED NOW, BECAUSE FREEMENU DUMPS THE EDIT WHEN IT LOSES THE TTY.") (* called when buttonevent occurs while editing with the tty process somewhere  else. should give the tty back to freemenu unless the event is right only and  not on an item. in that case, just do the window command menu.  don't worry here about calling buttoneventfn's, because once freemenu gets the  tty back, the edit button handler will notice the event and act properly.) (if [AND (LASTMOUSESTATE (ONLY RIGHT)) (NOT (AND (INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW] then (DOWINDOWCOM WINDOW) else (TTY.PROCESS (WINDOWPROP WINDOW 'PROCESS]) + +(\FM.BUTTONEVENTFN [LAMBDA (WINDOW) (* jow "13-Nov-85 22:08") (TOTOPW WINDOW) (if (AND (NOT (WINDOWPROP WINDOW 'FM.BUSY)) (LASTMOUSESTATE (NOT UP))) then (* ignore button up events and  events when menu is busy) (\FM.MENUHANDLER WINDOW]) + +(\FM.RIGHTBUTTONFN [LAMBDA (WINDOW) (* jow "10-Apr-86 22:38") (* if on an item, and not busy, then process the item selection, else do the  window command menu.) (TOTOPW WINDOW) (if (AND (INSIDEP (DSPCLIPPINGREGION NIL WINDOW) (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW)) (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW))) then (* valid item selected) (if (NOT (WINDOWPROP WINDOW 'FM.BUSY)) then (\FM.MENUHANDLER WINDOW)) else (* not on item) (DOWINDOWCOM WINDOW]) + +(\FM.DOSELECTION [LAMBDA (ITEM WINDOW BUTTONS) (* jow "17-Oct-86 17:06") (* ;;; "run the selectedfns for this ITEM. set busy flag accordingly. ") (RESETLST (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'FM.BUSY NIL)) (WINDOWPROP WINDOW 'FM.BUSY T) (APPLY* (\FM.ITEMPROP ITEM 'SYSSELECTEDFN) ITEM WINDOW BUTTONS) (BLOCK) (APPLY* (\FM.ITEMPROP ITEM 'SELECTEDFN) ITEM WINDOW BUTTONS) (* ;; "return NIL so that result of process can't point to itself.") NIL)]) + +(\FM.MENUHANDLER [LAMBDA (WINDOW SAMEPROCESS) (* jow "20-Oct-86 10:48") (repeatuntil (MOUSESTATE UP) bind (TIMER _ (SETUPTIMER 0)) ITEM LASTITEM BUTTONS PROMPTFLG do (SETQ BUTTONS (DECODEBUTTONS)) (SETQ LASTITEM ITEM) (SETQ ITEM (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW))) (if ITEM then (COND ((NOT LASTITEM) (* moved on new item) (APPLY* (\FM.ITEMPROP ITEM 'SYSDOWNFN) ITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP ITEM 'DOWNFN) ITEM WINDOW BUTTONS) (SETUPTIMER MENUHELDWAIT TIMER) (SETQ PROMPTFLG T)) ((NEQ LASTITEM ITEM) (* jump between items without dead  interval. call last mouseoff, and  new mousedown) (APPLY* (\FM.ITEMPROP LASTITEM 'SYSMOVEDFN) LASTITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP LASTITEM 'MOVEDFN) LASTITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP ITEM 'SYSDOWNFN) ITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP ITEM 'DOWNFN) ITEM WINDOW BUTTONS) (SETUPTIMER MENUHELDWAIT TIMER) (SETQ PROMPTFLG T)) ((AND PROMPTFLG (TIMEREXPIRED? TIMER)) (* held on item long enough) (PRINTOUT (OR (WINDOWPROP WINDOW 'FM.PROMPTWINDOW) PROMPTWINDOW) T (if (STRINGP (\FM.ITEMPROP ITEM 'MESSAGE)) then (\FM.ITEMPROP ITEM 'MESSAGE) else (APPLY* (\FM.ITEMPROP ITEM 'MESSAGE) ITEM WINDOW BUTTONS))) (SETQ PROMPTFLG NIL))) (APPLY* (\FM.ITEMPROP ITEM 'HELDFN) ITEM WINDOW BUTTONS) elseif LASTITEM then (* moved off item) (APPLY* (\FM.ITEMPROP LASTITEM 'SYSMOVEDFN) LASTITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP LASTITEM 'MOVEDFN) LASTITEM WINDOW BUTTONS)) finally (SETQ LASTITEM ITEM) (SETQ ITEM (\FM.CHECKREGION WINDOW (LASTMOUSEX WINDOW) (LASTMOUSEY WINDOW))) (if LASTITEM then (COND ((NEQ LASTITEM ITEM) (* moved off item) (APPLY* (\FM.ITEMPROP LASTITEM 'SYSMOVEDFN) LASTITEM WINDOW BUTTONS) (APPLY* (\FM.ITEMPROP LASTITEM 'MOVEDFN) LASTITEM WINDOW BUTTONS)) (ITEM (if SAMEPROCESS then (\FM.DOSELECTION ITEM WINDOW BUTTONS) else (ADD.PROCESS `(\FM.DOSELECTION ',ITEM ',WINDOW ',BUTTONS) 'NAME 'FREEMENU 'FREEMENU.PROCESS T]) +) + + + +(* ; "ITEM SUPPORT FUNCTIONS") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.DISPLAYBITMAP MACRO [(ITEM BITMAP WINDOW) + (* ; + "take care of background shade and display the item") + (IF (OPENWP WINDOW) + THEN (BLTSHADE (\FM.ITEMPROP ITEM 'BACKGROUND) + WINDOW NIL NIL NIL NIL NIL + (\FM.ITEMPROP ITEM 'MAXREGION)) + (BITBLT BITMAP 0 0 WINDOW + (fetch (REGION LEFT) + of (\FM.ITEMPROP ITEM 'REGION)) + (fetch (REGION BOTTOM) + of (\FM.ITEMPROP ITEM 'REGION)) + NIL NIL NIL 'PAINT]) + +(PUTPROPS \FM.COERCEITEMPTR MACRO [(ITEMPTR WINDOW ITEM) + (LET (GROUPID ITEMID) + [COND + ((LISTP ITEMPTR) + (* pull apart) + (SETQ GROUPID (CAR ITEMPTR)) + (SETQ ITEMID (CADR ITEMPTR] + [COND + ((EQ \FM.GROUPSPEC GROUPID) + (* DOES NOT TYPE CHECK ITEM. + IF USED ITEM MUST BE A FREEMENUITEM.) + (SETQ GROUPID (\FM.ITEMPROP ITEM 'GROUPID] + (OR (FM.GETITEM (OR ITEMID ITEMPTR) + GROUPID WINDOW) + (ERROR "Could not find item:" ITEMPTR]) +) +) +(DEFINEQ + +(\FM.GETITEMPROP [LAMBDA (ITEM PROP) (* jow "11-Apr-86 11:40") (* BACKGROUND (fetch  (FREEMENUITEM FM.BACKGROUND) of ITEM)) (* ATTACHPOINT (fetch  (FREEMENUITEM FM.ATTACHPOINT) of  ITEM)) (SELECTQ PROP (TYPE (fetch (FREEMENUITEM FM.TYPE) of ITEM)) (LABEL (fetch (FREEMENUITEM FM.LABEL) of ITEM)) (ID (fetch (FREEMENUITEM FM.ID) of ITEM)) (GROUPID (fetch (FREEMENUITEM FM.GROUPID) of ITEM)) (STATE (fetch (FREEMENUITEM FM.STATE) of ITEM)) (INITSTATE (fetch (FREEMENUITEM FM.INITSTATE) of ITEM)) (FONT (fetch (FREEMENUITEM FM.FONT) of ITEM)) (BITMAP (fetch (FREEMENUITEM FM.BITMAP) of ITEM)) (HIGHLIGHT (fetch (FREEMENUITEM FM.HIGHLIGHT) of ITEM)) (REGION (fetch (FREEMENUITEM FM.REGION) of ITEM)) (MAXREGION (fetch (FREEMENUITEM FM.MAXREGION) of ITEM)) (MESSAGE (fetch (FREEMENUITEM FM.MESSAGE) of ITEM)) (USERDATA (fetch (FREEMENUITEM FM.USERDATA) of ITEM)) (LINKS (fetch (FREEMENUITEM FM.LINKS) of ITEM)) (SYSDOWNFN (fetch (FREEMENUITEM FM.SYSDOWNFN) of ITEM)) (SYSMOVEDFN (fetch (FREEMENUITEM FM.SYSMOVEDFN) of ITEM)) (SYSSELECTEDFN (fetch (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM)) (DOWNFN (fetch (FREEMENUITEM FM.DOWNFN) of ITEM)) (HELDFN (fetch (FREEMENUITEM FM.HELDFN) of ITEM)) (MOVEDFN (fetch (FREEMENUITEM FM.MOVEDFN) of ITEM)) (SELECTEDFN (fetch (FREEMENUITEM FM.SELECTEDFN) of ITEM)) (LISTGET (fetch (FREEMENUITEM FM.USERDATA) of ITEM) PROP]) + +(\FM.PUTITEMPROP [LAMBDA (ITEM PROP VALUE) (* jow "11-Apr-86 11:41") (* store new value in item field) (* BACKGROUND (PROG1  (fetch (FREEMENUITEM FM.BACKGROUND)  of ITEM) (replace (FREEMENUITEM  FM.BACKGROUND) of ITEM with VALUE))) (* ATTACHPOINT (PROG1  (fetch (FREEMENUITEM FM.ATTACHPOINT)  of ITEM) (replace (FREEMENUITEM  FM.ATTACHPOINT) of ITEM with VALUE))) (SELECTQ PROP (TYPE (ERROR "Can't change the TYPE of an item" VALUE)) (LABEL (PROG1 (fetch (FREEMENUITEM FM.LABEL) of ITEM) (replace (FREEMENUITEM FM.LABEL) of ITEM with VALUE))) (ID (PROG1 (fetch (FREEMENUITEM FM.ID) of ITEM) (replace (FREEMENUITEM FM.ID) of ITEM with VALUE))) (GROUPID (fetch (FREEMENUITEM FM.GROUPID) of ITEM) (replace (FREEMENUITEM FM.GROUPID) of ITEM with VALUE)) (STATE (PROG1 (fetch (FREEMENUITEM FM.STATE) of ITEM) (replace (FREEMENUITEM FM.STATE) of ITEM with VALUE))) (INITSTATE (PROG1 (fetch (FREEMENUITEM FM.INITSTATE) of ITEM) (replace (FREEMENUITEM FM.INITSTATE) of ITEM with VALUE))) (FONT (PROG1 (fetch (FREEMENUITEM FM.FONT) of ITEM) (replace (FREEMENUITEM FM.FONT) of ITEM with VALUE))) (BITMAP (PROG1 (fetch (FREEMENUITEM FM.BITMAP) of ITEM) (replace (FREEMENUITEM FM.BITMAP) of ITEM with VALUE))) (HIGHLIGHT (PROG1 (fetch (FREEMENUITEM FM.HIGHLIGHT) of ITEM) (replace (FREEMENUITEM FM.HIGHLIGHT) of ITEM with VALUE))) (REGION (PROG1 (fetch (FREEMENUITEM FM.REGION) of ITEM) (replace (FREEMENUITEM FM.REGION) of ITEM with VALUE))) (MAXREGION (PROG1 (fetch (FREEMENUITEM FM.MAXREGION) of ITEM) (replace (FREEMENUITEM FM.MAXREGION) of ITEM with VALUE))) (MESSAGE (PROG1 (fetch (FREEMENUITEM FM.MESSAGE) of ITEM) (replace (FREEMENUITEM FM.MESSAGE) of ITEM with VALUE))) (USERDATA (ERROR "Can't change the USERDATA of an item" VALUE)) (LINKS (PROG1 (fetch (FREEMENUITEM FM.LINKS) of ITEM) (replace (FREEMENUITEM FM.LINKS) of ITEM with VALUE))) (SYSDOWNFN (PROG1 (fetch (FREEMENUITEM FM.SYSDOWNFN) of ITEM) (replace (FREEMENUITEM FM.SYSDOWNFN) of ITEM with VALUE))) (SYSMOVEDFN (PROG1 (fetch (FREEMENUITEM FM.SYSMOVEDFN) of ITEM) (replace (FREEMENUITEM FM.SYSMOVEDFN) of ITEM with VALUE))) (SYSSELECTEDFN (PROG1 (fetch (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM) (replace (FREEMENUITEM FM.SYSSELECTEDFN) of ITEM with VALUE))) (DOWNFN (PROG1 (fetch (FREEMENUITEM FM.DOWNFN) of ITEM) (replace (FREEMENUITEM FM.DOWNFN) of ITEM with VALUE))) (HELDFN (PROG1 (fetch (FREEMENUITEM FM.HELDFN) of ITEM) (replace (FREEMENUITEM FM.HELDFN) of ITEM with VALUE))) (MOVEDFN (PROG1 (fetch (FREEMENUITEM FM.MOVEDFN) of ITEM) (replace (FREEMENUITEM FM.MOVEDFN) of ITEM with VALUE))) (SELECTEDFN (PROG1 (fetch (FREEMENUITEM FM.SELECTEDFN) of ITEM) (replace (FREEMENUITEM FM.SELECTEDFN) of ITEM with VALUE))) (PROG1 (LISTGET (fetch (FREEMENUITEM FM.USERDATA) of ITEM) PROP) (LISTPUT (fetch (FREEMENUITEM FM.USERDATA) of ITEM) PROP VALUE))]) + +(\FM.CGETITEMPROP [LAMBDA (ITEM PROP) (* jow "12-Apr-86 16:13") (* macro dispatch function for FM.ITEMPROP.  ITEM is bound to the name of the item to be visited, and PROP is bound to the  expression (QUOTE )%. This function returns the appropriate  fetchfield expression to be compiled. IF THE FREEMENUITEM RECORD IS  CHANGED,THIS FUNCTION MUST BE CHANGED ACCORDINGLY) (* BACKGROUND (BQUOTE  (FETCH (FREEMENUITEM FM.BACKGROUND)  OF (\FM.INSUREFM %, ITEM)))) (* ATTACHPOINT (BQUOTE  (FETCH (FREEMENUITEM FM.ATTACHPOINT)  OF (\FM.INSUREFM %, ITEM)))) (SELECTQ (CADR PROP) (TYPE `(FETCH (FREEMENUITEM FM.TYPE) OF %, ITEM)) (LABEL `(FETCH (FREEMENUITEM FM.LABEL) OF %, ITEM)) (ID `(FETCH (FREEMENUITEM FM.ID) OF %, ITEM)) (GROUPID `(FETCH (FREEMENUITEM FM.GROUPID) OF %, ITEM)) (STATE `(FETCH (FREEMENUITEM FM.STATE) OF %, ITEM)) (INITSTATE `(FETCH (FREEMENUITEM FM.INITSTATE) OF %, ITEM)) (FONT `(FETCH (FREEMENUITEM FM.FONT) OF %, ITEM)) (BITMAP `(FETCH (FREEMENUITEM FM.BITMAP) OF %, ITEM)) (HIGHLIGHT `(FETCH (FREEMENUITEM FM.HIGHLIGHT) OF %, ITEM)) (REGION `(FETCH (FREEMENUITEM FM.REGION) OF %, ITEM)) (MAXREGION `(FETCH (FREEMENUITEM FM.MAXREGION) OF %, ITEM)) (MESSAGE `(FETCH (FREEMENUITEM FM.MESSAGE) OF %, ITEM)) (USERDATA `(FETCH (FREEMENUITEM FM.USERDATA) OF %, ITEM)) (LINKS `(FETCH (FREEMENUITEM FM.LINKS) OF %, ITEM)) (SYSDOWNFN `(FETCH (FREEMENUITEM FM.SYSDOWNFN) OF %, ITEM)) (SYSMOVEDFN `(FETCH (FREEMENUITEM FM.SYSMOVEDFN) OF %, ITEM)) (SYSSELECTEDFN `(FETCH (FREEMENUITEM FM.SYSSELECTEDFN) OF %, ITEM)) (DOWNFN `(FETCH (FREEMENUITEM FM.DOWNFN) OF %, ITEM)) (HELDFN `(FETCH (FREEMENUITEM FM.HELDFN) OF %, ITEM)) (MOVEDFN `(FETCH (FREEMENUITEM FM.MOVEDFN) OF %, ITEM)) (SELECTEDFN `(FETCH (FREEMENUITEM FM.SELECTEDFN) OF %, ITEM)) `(LISTGET (FETCH (FREEMENUITEM FM.USERDATA) OF %, ITEM) (QUOTE %, (CADR PROP]) + +(\FM.CPUTITEMPROP [LAMBDA (ITEM PROP VALUE) (* jow "12-Apr-86 16:10") (* macro dispatch function for FM.ITEMPROP.  ITEM is bound to the name of the item to be visited, PROP is bound to the  expression ((QUOTE )%, and VALUE is bound to the expression to be  evaluated at run time to yield the newvalue.) This function returns the  appropriate prog1 expression to be compiled, which will return the old value,  and set the new value of an item prop. IF THE FREEMENUITEM RECORD IS  CHANGED,THIS FUNCTION MUST BE CHANGED ACCORDINGLY) (* BACKGROUND (BQUOTE  (PROG1 (FETCH (FREEMENUITEM  FM.BACKGROUND) OF (\FM.INSUREFM %,  ITEM)) (REPLACE (FREEMENUITEM  FM.BACKGROUND) OF %, ITEM WITH %,  VALUE)))) (* ATTACHPOINT (BQUOTE  (PROG1 (FETCH (FREEMENUITEM  FM.ATTACHPOINT) OF  (\FM.INSUREFM %, ITEM))  (REPLACE (FREEMENUITEM  FM.ATTACHPOINT) OF %, ITEM WITH %,  VALUE)))) (SELECTQ (CADR PROP) (TYPE (ERROR "FreeMenuItem property TYPE not settable" (LIST 'FM.ITEMPROP ITEM PROP VALUE))) (LABEL `(PROG1 (FETCH (FREEMENUITEM FM.LABEL) OF %, ITEM) (REPLACE (FREEMENUITEM FM.LABEL) OF %, ITEM WITH %, VALUE))) (ID `(PROG1 (FETCH (FREEMENUITEM FM.ID) OF %, ITEM) (REPLACE (FREEMENUITEM FM.ID) OF %, ITEM WITH %, VALUE))) (GROUPID `(PROG1 (FETCH (FREEMENUITEM FM.GROUPID) OF %, ITEM) (REPLACE (FREEMENUITEM FM.GROUPID) OF %, ITEM WITH %, VALUE))) (STATE `(PROG1 (FETCH (FREEMENUITEM FM.STATE) OF %, ITEM) (REPLACE (FREEMENUITEM FM.STATE) OF %, ITEM WITH %, VALUE))) (INITSTATE `(PROG1 (FETCH (FREEMENUITEM FM.INITSTATE) OF %, ITEM) (REPLACE (FREEMENUITEM FM.INITSTATE) OF %, ITEM WITH %, VALUE))) (FONT `(PROG1 (FETCH (FREEMENUITEM FM.FONT) OF %, ITEM) (REPLACE (FREEMENUITEM FM.FONT) OF %, ITEM WITH %, VALUE))) (BITMAP `(PROG1 (FETCH (FREEMENUITEM FM.BITMAP) OF %, ITEM) (REPLACE (FREEMENUITEM FM.BITMAP) OF %, ITEM WITH %, VALUE))) (HIGHLIGHT `(PROG1 (FETCH (FREEMENUITEM FM.HIGHLIGHT) OF %, ITEM) (REPLACE (FREEMENUITEM FM.HIGHLIGHT) OF %, ITEM WITH %, VALUE))) (REGION `(PROG1 (FETCH (FREEMENUITEM FM.REGION) OF %, ITEM) (REPLACE (FREEMENUITEM FM.REGION) OF %, ITEM WITH %, VALUE))) (MAXREGION `(PROG1 (FETCH (FREEMENUITEM FM.MAXREGION) OF %, ITEM) (REPLACE (FREEMENUITEM FM.MAXREGION) OF %, ITEM WITH %, VALUE))) (MESSAGE `(PROG1 (FETCH (FREEMENUITEM FM.MESSAGE) OF %, ITEM) (REPLACE (FREEMENUITEM FM.MESSAGE) OF %, ITEM WITH %, VALUE))) (USERDATA (ERROR "FreeMenuItem property USERDATA not settable" (LIST 'FM.ITEMPROP ITEM PROP VALUE))) (LINKS `(PROG1 (FETCH (FREEMENUITEM FM.LINKS) OF %, ITEM) (REPLACE (FREEMENUITEM FM.LINKS) OF %, ITEM WITH %, VALUE))) (SYSDOWNFN `(PROG1 (FETCH (FREEMENUITEM FM.SYSDOWNFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.SYSDOWNFN) OF %, ITEM WITH %, VALUE))) (SYSMOVEDFN `(PROG1 (FETCH (FREEMENUITEM FM.SYSMOVEDFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.SYSMOVEDFN) OF %, ITEM WITH %, VALUE))) (SYSSELECTEDFN `(PROG1 (FETCH (FREEMENUITEM FM.SYSSELECTEDFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.SYSSELECTEDFN) OF %, ITEM WITH %, VALUE))) (DOWNFN `(PROG1 (FETCH (FREEMENUITEM FM.DOWNFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.DOWNFN) OF %, ITEM WITH %, VALUE))) (HELDFN `(PROG1 (FETCH (FREEMENUITEM FM.HELDFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.HELDFN) OF %, ITEM WITH %, VALUE))) (MOVEDFN `(PROG1 (FETCH (FREEMENUITEM FM.MOVEDFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.MOVEDFN) OF %, ITEM WITH %, VALUE))) (SELECTEDFN `(PROG1 (FETCH (FREEMENUITEM FM.SELECTEDFN) OF %, ITEM) (REPLACE (FREEMENUITEM FM.SELECTEDFN) OF %, ITEM WITH %, VALUE))) `(PROG1 (LISTGET (FETCH (FREEMENUITEM FM.USERDATA) OF %, ITEM) (QUOTE %, (CADR PROP))) (LISTPUT (FETCH (FREEMENUITEM FM.USERDATA) OF %, ITEM) (QUOTE %, (CADR PROP)) %, VALUE))]) + +(\FM.DISPLAYITEM [LAMBDA (ITEM WINDOW) (* jow "26-Jun-86 14:52") (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'BITMAP) WINDOW]) + +(\FM.HIGHLIGHTITEM [LAMBDA (ITEM WINDOW BUTTONS) (* jow "26-Jun-86 14:52") (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'HIGHLIGHT) WINDOW]) + +(\FM.CHANGELABEL [LAMBDA (ITEM NEWLABEL) (* ; "Edited 28-Dec-87 17:03 by woz") (* ;; "change the items label. NEWDESC is a description of the new item. This includes the items USERDATA list, which has in it all of the boxing info necessary for changing the label. Do not redisplay") (OR (OR (ATOM NEWLABEL) (STRINGP NEWLABEL) (BITMAPP NEWLABEL)) (ERROR "CHANGELABEL Error. NEWLABEL must be an atom, string, or bitmap." NEWLABEL)) (LET ((FONT (\FM.ITEMPROP ITEM 'FONT)) [LEFT (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM 'REGION] [BOTTOM (fetch (REGION BOTTOM) of (\FM.ITEMPROP ITEM 'REGION] [NEWDESC (APPEND (LIST 'LABEL NEWLABEL) (\FM.ITEMPROP ITEM 'USERDATA] REGIONS BITMAPS) (SETQ REGIONS (\FM.GETREGIONS NEWDESC LEFT BOTTOM FONT)) (SETQ BITMAPS (\FM.GETBITMAPS NEWDESC FONT (CAR REGIONS) (CADR REGIONS))) (\FM.ITEMPROP ITEM 'LABEL NEWLABEL) (\FM.ITEMPROP ITEM 'REGION (CAR REGIONS)) (\FM.ITEMPROP ITEM 'MAXREGION (CADDR REGIONS)) (\FM.ITEMPROP ITEM 'BITMAP (CAR BITMAPS)) (\FM.ITEMPROP ITEM 'HIGHLIGHT (CADR BITMAPS)) (SELECTQ (\FM.ITEMPROP ITEM 'TYPE) (EDIT (* ; "use maxregion always") (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'MAXREGION))) (NUMBER (* ; "make state a number") (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'MAXREGION)) (\FM.NUMBER-CHANGESTATE ITEM NEWLABEL)) (TOGGLE (* ; "reset state bitmaps") (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP))) (3STATE (* ; "reset state bitmaps") (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP)) (\FM.3STATE-SETUPOFFBITMAP ITEM)) (NWAY (* ; "reset state bitmaps") (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP))) NIL]) + +(\FM.CHANGESTATE [LAMBDA (X NEWSTATE WINDOW) (* ; "Edited 28-Dec-87 17:08 by woz") (* ;; "user interface to change the state of any (state) item or nway collection. Redisplay the item if the window is open") (if (ASSOC X (WINDOWPROP WINDOW 'FM.NWAYS)) then (* ;  "X specifies an NWAY. Changestate and redisplay.") (\FM.NWAY-CHANGESTATE X NEWSTATE WINDOW) else (* ; "treat X as an item") (SELECTQ (\FM.ITEMPROP X 'TYPE) (TOGGLE (\FM.TOGGLE-CHANGESTATE X NEWSTATE)) (3STATE (\FM.3STATE-CHANGESTATE X NEWSTATE)) (STATE (\FM.STATE-CHANGESTATE X NEWSTATE WINDOW)) NIL]) + +(\FM.ENDEDIT [LAMBDA (WINDOW WAITFLG) (* jow " 4-Nov-86 16:09") (* ;;; "used as a closefn for freemenu, as well as for ending edits as necessary during button events. Will kill the edit process and wait as requested. If editing, the freemenu process must be the ttyprocess.") (if (FM.EDITP WINDOW) then (\CARET.DOWN) (SETUPTIMER 0 (WINDOWPROP WINDOW 'FM.EDIT-TIMER)) (LET ((FM.PROCESS (TTY.PROCESS))) (if (PROCESSPROP FM.PROCESS 'FREEMENU.PROCESS) then (if (NEQ (THIS.PROCESS) FM.PROCESS) then (PROCESS.RESULT FM.PROCESS WAITFLG)) else (ERROR "Can't find freemenu process to end editing" FM.PROCESS]) + +(\FM.INSUREVISIBLE [LAMBDA (ITEM WINDOW) (* jow "25-Apr-86 12:04") (if [NOT (SUBREGIONP (DSPCLIPPINGREGION NIL WINDOW) (\FM.ITEMPROP ITEM 'REGION] then (* not all of ITEM is visible%:  ensure that left of item is in  window) (SCROLLW WINDOW [FQUOTIENT (fetch (REGION LEFT) of (\FM.ITEMPROP ITEM 'REGION)) (fetch (REGION WIDTH) of (WINDOWPROP WINDOW 'EXTENT] 0]) + +(\FM.CLEARITEM [LAMBDA (ITEM WINDOW REGION) (* ; "Edited 28-Dec-87 16:50 by woz") (* ;; "clear an item in the window. If INFINITEWIDTH, then clear to edge of window. Don't change the item. REGION defaults to items current region, and may be passed as an arg, in order to clear an 'old' region for the item.") (if (OPENWP WINDOW) then [OR REGION (SETQ REGION (\FM.ITEMPROP ITEM 'REGION] (if (\FM.ITEMPROP ITEM 'INFINITEWIDTH) then (BLTSHADE (\FM.ITEMPROP ITEM 'BACKGROUND) WINDOW (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) NIL (fetch (REGION HEIGHT) of REGION)) else (BLTSHADE (\FM.ITEMPROP ITEM 'BACKGROUND) WINDOW NIL NIL NIL NIL NIL REGION]) +) + + + +(* ; "MOMENTARY ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.MOMENTARY-SETUP [LAMBDA (ITEM) (* jow "17-Apr-86 18:16") (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE "Will select this item when you release the button.")) (\FM.ITEMPROP ITEM 'SYSDOWNFN '\FM.HIGHLIGHTITEM) (\FM.ITEMPROP ITEM 'SYSMOVEDFN '\FM.DISPLAYITEM) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.MOMENTARY-SELECTEDFN]) + +(\FM.MOMENTARY-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "19-Apr-86 22:00") (* setup unhighlighting on the way out by puttin in a resetsave.  we know we got called from \fm.doselection, which RESETLISTs.) (RESETSAVE NIL (LIST '\FM.DISPLAYITEM ITEM WINDOW]) +) + + + +(* ; "TOGGLE ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.TOGGLE-SETUP [LAMBDA (ITEM REGIONS) (* jow "18-Apr-86 12:22") (* toggle items initial state NIL) (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE "Will toggle this item when you release the button.")) (\FM.ITEMPROP ITEM 'SYSDOWNFN (FUNCTION \FM.TOGGLE-DOWNFN)) (\FM.ITEMPROP ITEM 'SYSMOVEDFN (FUNCTION \FM.DISPLAYITEM)) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.TOGGLE-SELECTEDFN)) (* save unhighlighted looks.) (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP)) (* save regions for state changes.) (if [AND (CADR REGIONS) (NOT (EQUAL (CADR REGIONS) (\FM.ITEMPROP ITEM 'REGION] then (\FM.ITEMPROP ITEM 'OFFREGION (\FM.ITEMPROP ITEM 'REGION)) (\FM.ITEMPROP ITEM 'ONREGION (CADR REGIONS]) + +(\FM.TOGGLE-DOWNFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:08") (* display the other state in the window.  Can't just invert item in window, because "highlight" may be shade other than  black.) (if (\FM.ITEMPROP ITEM 'STATE) then (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'UNHIGHLIGHT) WINDOW) else (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'HIGHLIGHT) WINDOW]) + +(\FM.TOGGLE-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 16:54") (* change item to new state.  display already updated) (if (\FM.ITEMPROP ITEM 'STATE) then (\FM.TOGGLE-CHANGESTATE ITEM NIL) else (\FM.TOGGLE-CHANGESTATE ITEM T]) + +(\FM.TOGGLE-CHANGESTATE [LAMBDA (ITEM NEWSTATE) (* jow "18-Apr-86 12:22") (\FM.ITEMPROP ITEM 'STATE NEWSTATE) (if NEWSTATE then (\FM.ITEMPROP ITEM 'BITMAP (\FM.ITEMPROP ITEM 'HIGHLIGHT)) [AND (\FM.ITEMPROP ITEM 'ONREGION) (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'ONREGION] else (\FM.ITEMPROP ITEM 'BITMAP (\FM.ITEMPROP ITEM 'UNHIGHLIGHT)) (AND (\FM.ITEMPROP ITEM 'OFFREGION) (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'OFFREGION]) +) + + + +(* ; "3STATE ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.3STATE-SETUP [LAMBDA (ITEM REGIONS) (* jow "18-Apr-86 14:40") (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE "Will change item to this state when you release the button.")) (\FM.ITEMPROP ITEM 'SYSDOWNFN (FUNCTION \FM.3STATE-DOWNFN)) (\FM.ITEMPROP ITEM 'SYSMOVEDFN (FUNCTION \FM.DISPLAYITEM)) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.3STATE-SELECTEDFN)) (* save the unhighlighted bitmap.) (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP)) (* save regions for state changes.) (if [AND (CADR REGIONS) (NOT (EQUAL (CADR REGIONS) (\FM.ITEMPROP ITEM 'REGION] then (\FM.ITEMPROP ITEM 'NEUTRALREGION (\FM.ITEMPROP ITEM 'REGION)) (\FM.ITEMPROP ITEM 'ONREGION (CADR REGIONS))) (\FM.3STATE-SETUPOFFBITMAP ITEM]) + +(\FM.3STATE-SETUPOFFBITMAP [LAMBDA (ITEM) (* jow "24-Apr-86 23:01") (* used by 3state items to setup  bitmap with OFF looks.) (LET* ((OFF (\FM.ITEMPROP ITEM 'OFF)) (BOX (OR (\FM.ITEMPROP ITEM 'BOX) 0)) (FONT (\FM.ITEMPROP ITEM 'FONT)) (OFFREGION (\FM.ITEMPROP ITEM 'REGION)) ID OFFBITMAP) (COND ((OR (AND OFF (ATOM OFF) (NOT (TEXTUREP OFF))) (STRINGP OFF) (BITMAPP OFF)) (* new label specified.  make anew) (* Set REGION of OFF looks%: build item description that has OFF has its  HIGHLIGHT prop. Then pass to GETREGIONS  (so lie a bit) to get the region of the OFF looks.) [SETQ ID (COPY (\FM.ITEMPROP ITEM 'USERDATA] (LISTPUT ID 'HIGHLIGHT OFF) (SETQ OFFREGION (CADR (\FM.GETREGIONS ID (fetch (REGION LEFT) of OFFREGION) (fetch (REGION BOTTOM) of OFFREGION) FONT))) (SETQ OFFBITMAP (\FM.MAKEBITMAP OFF FONT (fetch (REGION WIDTH) of OFFREGION ) (fetch (REGION HEIGHT) of OFFREGION) ID)) (\FM.ITEMPROP ITEM 'HIGHLIGHT (LIST (\FM.ITEMPROP ITEM 'HIGHLIGHT) OFFBITMAP)) (if [NOT (EQUAL OFFREGION (\FM.ITEMPROP ITEM 'REGION] then (* different region for OFF looks.  Save regions for changing state) (\FM.ITEMPROP ITEM 'NEUTRALREGION (\FM.ITEMPROP ITEM 'REGION)) (\FM.ITEMPROP ITEM 'OFFREGION OFFREGION) (EXTENDREGION (\FM.ITEMPROP ITEM 'MAXREGION) OFFREGION))) ((TEXTUREP OFF) (* paint shade on label) [SETQ OFFBITMAP (BITMAPCOPY (\FM.ITEMPROP ITEM 'BITMAP] (BLTSHADE OFF OFFBITMAP BOX BOX (IDIFFERENCE (fetch (REGION WIDTH) of OFFREGION ) (ITIMES BOX 2)) (IDIFFERENCE (fetch (REGION HEIGHT) of OFFREGION) (ITIMES BOX 2)) 'PAINT) (\FM.ITEMPROP ITEM 'HIGHLIGHT (LIST (\FM.ITEMPROP ITEM 'HIGHLIGHT) OFFBITMAP))) (T (* default%: draw slash on label) [SETQ OFFBITMAP (BITMAPCOPY (\FM.ITEMPROP ITEM 'BITMAP] (LET ((STREAM (DSPCREATE OFFBITMAP))) (DRAWLINE 0 0 (SUB1 (fetch (REGION WIDTH) of OFFREGION)) (IDIFFERENCE (fetch (REGION HEIGHT) of OFFREGION) 2) 2 'REPLACE STREAM) (\FM.ITEMPROP ITEM 'HIGHLIGHT (LIST (\FM.ITEMPROP ITEM 'HIGHLIGHT) OFFBITMAP]) + +(\FM.3STATE-DOWNFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "16-Apr-86 17:58") (* called when mouse down over 3state item.  rotates the state of ITEM on the screen.  The order is OFF -  NIL -  T) (SELECTQ (\FM.ITEMPROP ITEM 'STATE) (OFF (* OFF to NIL) (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'UNHIGHLIGHT) WINDOW)) (T (* T to OFF) (\FM.DISPLAYBITMAP ITEM (CADR (\FM.ITEMPROP ITEM 'HIGHLIGHT)) WINDOW)) (NIL (* NIL to T) (\FM.DISPLAYBITMAP ITEM (CAR (\FM.ITEMPROP ITEM 'HIGHLIGHT)) WINDOW)) NIL]) + +(\FM.3STATE-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:30") (* called when 3state item selected. rotates the state of ITEM and its bitmap.  The order is OFF -  NIL -  T) (SELECTQ (\FM.ITEMPROP ITEM 'STATE) (OFF (* OFF to NIL) (\FM.3STATE-CHANGESTATE ITEM NIL)) (T (* T to OFF) (\FM.3STATE-CHANGESTATE ITEM 'OFF)) (NIL (* NIL to T) (\FM.3STATE-CHANGESTATE ITEM T)) NIL]) + +(\FM.3STATE-CHANGESTATE [LAMBDA (ITEM NEWSTATE) (* jow "18-Apr-86 15:19") (\FM.ITEMPROP ITEM 'STATE NEWSTATE) (SELECTQ NEWSTATE (OFF (* to OFF) [\FM.ITEMPROP ITEM 'BITMAP (CADR (\FM.ITEMPROP ITEM 'HIGHLIGHT] [AND (\FM.ITEMPROP ITEM 'OFFREGION) (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'OFFREGION]) (T (* to T) [\FM.ITEMPROP ITEM 'BITMAP (CAR (\FM.ITEMPROP ITEM 'HIGHLIGHT] [AND (\FM.ITEMPROP ITEM 'ONREGION) (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'ONREGION]) (NIL (* to NIL) (\FM.ITEMPROP ITEM 'BITMAP (\FM.ITEMPROP ITEM 'UNHIGHLIGHT)) [AND (\FM.ITEMPROP ITEM 'NEUTRALREGION) (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'NEUTRALREGION]) NIL]) +) + + + +(* ; "STATE ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.STATE-SETUP [LAMBDA (ITEM) (* jow "28-Oct-86 18:55") (* The item's state is initialized to the first of the menu items.  The subitems list is replaced with a menu of those items.) (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE "Will let you select a value from a pop up menu.")) (\FM.ITEMPROP ITEM 'SYSDOWNFN '\FM.HIGHLIGHTITEM) (\FM.ITEMPROP ITEM 'SYSMOVEDFN '\FM.DISPLAYITEM) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.STATE-SELECTEDFN)) (if (\FM.ITEMPROP ITEM 'MENUITEMS) then (* build menu as specified) (LET [(MENU.ITEMS (\FM.ITEMPROP ITEM 'MENUITEMS)) (MENU.FONT (APPLY (FUNCTION FONTCREATE) (\FM.ITEMPROP ITEM 'MENUFONT] (\FM.ITEMPROP ITEM 'STATE (OR (\FM.ITEMPROP ITEM 'INITSTATE) (CAR MENU.ITEMS))) (\FM.ITEMPROP ITEM 'CHANGESTATE (create MENU ITEMS _ MENU.ITEMS MENUFONT _ MENU.FONT CENTERFLG _ T TITLE _ (OR (\FM.ITEMPROP ITEM 'MENUTITLE) (\FM.ITEMPROP ITEM 'LABEL]) + +(\FM.STATE-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:30") (* Setup highlighting on the way out, to account for CHANGESTATE function and  user selectedfn. If CHANGESTATE is an atom, treat as function name to be  applied to ITEM WINDOW BUTTONS, which must return the new state  (any atom, string, or bitmap) If CHANGESTATE is a menu, pop it up to select new  state. If CHANGESTATE returns NIL, don't change state) (RESETSAVE NIL (LIST '\FM.DISPLAYITEM ITEM WINDOW)) (LET [(NEWSTATE (COND [(type? MENU (\FM.ITEMPROP ITEM 'CHANGESTATE)) (MENU (\FM.ITEMPROP ITEM 'CHANGESTATE] ((\FM.ITEMPROP ITEM 'CHANGESTATE) (APPLY* (\FM.ITEMPROP ITEM 'CHANGESTATE) ITEM WINDOW BUTTONS] (if NEWSTATE then (\FM.STATE-CHANGESTATE ITEM NEWSTATE WINDOW]) + +(\FM.STATE-CHANGESTATE [LAMBDA (ITEM NEWSTATE WINDOW) (* jow "12-Apr-86 18:31") (* changing the state of a STATE item simply changes the label of its display  item.) (\FM.ITEMPROP ITEM 'STATE NEWSTATE) (LET [(DISPLAYITEM (LISTGET (\FM.ITEMPROP ITEM 'LINKS) 'DISPLAY] (if DISPLAYITEM then (FM.CHANGELABEL DISPLAYITEM NEWSTATE WINDOW]) +) + + + +(* ; "NWAY ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.NWAY-SETUP [LAMBDA (ITEM REGIONS) (* jow "24-Apr-86 21:53") (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE (FUNCTION \FM.NWAY-MESSAGE))) (\FM.ITEMPROP ITEM 'SYSDOWNFN (FUNCTION \FM.NWAY-DOWNFN)) (\FM.ITEMPROP ITEM 'SYSMOVEDFN (FUNCTION \FM.NWAY-MOVEDFN)) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.NWAY-SELECTEDFN)) (\FM.ITEMPROP ITEM 'UNHIGHLIGHT (\FM.ITEMPROP ITEM 'BITMAP)) (* save regions for state changes.) (if [AND (CADR REGIONS) (NOT (EQUAL (CADR REGIONS) (\FM.ITEMPROP ITEM 'REGION] then (\FM.ITEMPROP ITEM 'OFFREGION (\FM.ITEMPROP ITEM 'REGION)) (\FM.ITEMPROP ITEM 'ONREGION (CADR REGIONS]) + +(\FM.NWAY-MESSAGE [LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:07") (IF (\FM.NWAYPROP WINDOW (\FM.ITEMPROP ITEM 'COLLECTION) 'DESELECT) THEN (SELECTQ (CAR BUTTONS) (RIGHT "Will turn off this NWAY collection.") ((LEFT MIDDLE) "Will select this item from its NWAY collection.") NIL) ELSE "Will select this item from its NWAY collection."]) + +(\FM.NWAY-DOWNFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:16") (LET* [[NWAY (CDR (ASSOC (\FM.ITEMPROP ITEM 'COLLECTION) (WINDOWPROP WINDOW 'FM.NWAYS] (STATE (LISTGET NWAY 'STATE] (if STATE then (* an item is currently selected%:  unhighlight it) (\FM.DISPLAYBITMAP STATE (\FM.ITEMPROP STATE 'UNHIGHLIGHT) WINDOW)) (if [NOT (AND (EQ (CAR BUTTONS) 'RIGHT) (LISTGET NWAY 'DESELECT] then (* highlight this item unless  deselect group.) (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'HIGHLIGHT) WINDOW]) + +(\FM.NWAY-MOVEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "12-Apr-86 18:16") (LET* [[NWAY (CDR (ASSOC (\FM.ITEMPROP ITEM 'COLLECTION) (WINDOWPROP WINDOW 'FM.NWAYS] (STATE (LISTGET NWAY 'STATE] (if STATE then (* there is an item currently  selected to redisplay) (\FM.DISPLAYBITMAP STATE (\FM.ITEMPROP STATE 'BITMAP) WINDOW)) (if [NOT (AND (EQ (CAR BUTTONS) 'RIGHT) (LISTGET NWAY 'DESELECT] then (* this item was highlighted by  downfn, so redisplay.) (\FM.DISPLAYBITMAP ITEM (\FM.ITEMPROP ITEM 'BITMAP) WINDOW]) + +(\FM.NWAY-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "19-Apr-86 23:07") (if (AND (EQ (CAR BUTTONS) 'RIGHT) (\FM.NWAYPROP WINDOW (\FM.ITEMPROP ITEM 'COLLECTION) 'DESELECT)) then (* group deselected) (\FM.NWAY-CHANGESTATE (\FM.ITEMPROP ITEM 'COLLECTION) NIL WINDOW) else (* new item selected) (\FM.NWAY-CHANGESTATE (\FM.ITEMPROP ITEM 'COLLECTION) ITEM WINDOW]) + +(\FM.NWAY-CHANGESTATE [LAMBDA (COLLECTION NEWSTATE WINDOW) (* jow "19-Apr-86 23:09") (LET [(STATE (\FM.NWAYPROP WINDOW COLLECTION 'STATE] (if (NEQ STATE NEWSTATE) then (* actually have something to change) (if STATE then (* STATE item is unselected) (\FM.TOGGLE-CHANGESTATE STATE NIL)) (if NEWSTATE then (\FM.TOGGLE-CHANGESTATE NEWSTATE T)) (\FM.NWAYPROP WINDOW COLLECTION 'STATE NEWSTATE]) +) + + + +(* ; "NUMBER ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.NUMBER-SETUP + [LAMBDA (ITEM) (* ; "Edited 5-Dec-94 15:48 by jds") + + (* ;; "This is EDIT-SETUP with number specifics added.") + + (OR \FM.EDIT-TTBL (\FM.EDIT-SETUPTTBL)) (* ; + "since have edit item, setup term table") + (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'MAXREGION)) + (* ; "always sensitive on maxregion") + [COND + ([AND (\FM.ITEMPROP ITEM 'BOX) + (NOT (\FM.ITEMPROP ITEM 'MAXWIDTH] (* ; "boxing implies maxwidth") + (\FM.ITEMPROP ITEM 'MAXWIDTH (IDIFFERENCE (fetch (REGION WIDTH) + of (\FM.ITEMPROP ITEM 'REGION)) + (ITIMES 2 (\FM.ITEMPROP ITEM 'BOXOFFSET] + (COND + [(\FM.ITEMPROP ITEM 'MAXWIDTH) (* ; "setup stopwidth") + (\FM.ITEMPROP ITEM 'LABELMAXWIDTH (\FM.ITEMPROP ITEM 'MAXWIDTH] + (T (* ; "make item infinite") + (\FM.ITEMPROP ITEM 'INFINITEWIDTH T))) + (OR (\FM.ITEMPROP ITEM 'MESSAGE) + (\FM.ITEMPROP ITEM 'MESSAGE (FUNCTION \FM.NUMBER-MESSAGE))) + (\FM.ITEMPROP ITEM 'INITSTATE (\FM.ITEMPROP ITEM 'LABEL)) + [COND + [(FMEMB (\FM.ITEMPROP ITEM 'NUMBERTYPE) + '(FLOAT FLOATP)) + (\FM.ITEMPROP ITEM 'SYSLIMITCHARS + '(+ - 1 2 3 4 5 6 7 8 9 0 %.] + (T (\FM.ITEMPROP ITEM 'SYSLIMITCHARS + '(+ - 1 2 3 4 5 6 7 8 9 0] + (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.NUMBER-SELECTEDFN]) + +(\FM.NUMBER-MESSAGE [LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:06") (SELECTQ (CAR BUTTONS) (RIGHT "Will clear this number, then start editing.") ((LEFT MIDDLE) "Will start editing this number at this position.") NIL]) + +(\FM.NUMBER-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* jow "17-Oct-86 18:36") (\FM.EDIT-ITEM ITEM WINDOW BUTTONS NIL (FUNCTION \FM.NUMBER-CHANGESTATE]) + +(\FM.NUMBER-CHANGESTATE + [LAMBDA (ITEM) (* ; "Edited 6-Dec-94 10:02 by jds") + (\FM.ITEMPROP ITEM 'STATE (COND + ([NOT (EQUAL "" (\FM.ITEMPROP ITEM 'LABEL] + (NUMBERP (MKATOM (\FM.ITEMPROP ITEM 'LABEL]) +) + + + +(* ; "TITLE ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.DISPLAY-SETUP [LAMBDA (ITEM) (* jow "17-Apr-86 18:17") (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE ""]) +) + + + +(* ; "EDITSTART ITEM FUNCTIONS") + +(DEFINEQ + +(\FM.EDITSTART-SETUP [LAMBDA (ITEM) (* jow "24-Apr-86 22:00") (OR (\FM.ITEMPROP ITEM 'MESSAGE) (\FM.ITEMPROP ITEM 'MESSAGE (FUNCTION \FM.EDITSTART-MESSAGE))) (\FM.ITEMPROP ITEM 'SYSDOWNFN '\FM.HIGHLIGHTITEM) (\FM.ITEMPROP ITEM 'SYSMOVEDFN '\FM.DISPLAYITEM) (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.EDITSTART-SELECTEDFN]) + +(\FM.EDITSTART-MESSAGE [LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:04") (SELECTQ (CAR BUTTONS) (RIGHT "Will clear first, then start editing.") ((LEFT MIDDLE) "Will start editing.") NIL]) + +(\FM.EDITSTART-SELECTEDFN [LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 28-Dec-87 17:28 by woz") (* ;  "start editing at the beginning of item in the EDIT link.") (\FM.DISPLAYITEM ITEM WINDOW) (LET [(EDITITEM (LISTGET (\FM.ITEMPROP ITEM 'LINKS) 'EDIT] (if (type? FREEMENUITEM EDITITEM) then (\FM.ITEMPROP ITEM 'SELECTEDFN (FUNCTION NILL)) (* ;  "insure editstart item won't have selectedfn side effect, because end of edit is not well defined") (\FM.INSUREVISIBLE EDITITEM WINDOW) (\FM.EDIT-ITEM EDITITEM WINDOW BUTTONS T (IF (EQ (\FM.ITEMPROP EDITITEM 'TYPE) 'NUMBER) THEN (FUNCTION \FM.NUMBER-CHANGESTATE]) +) + + + +(* ; "EDIT ITEMS") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \FM.EDIT-TIMEOUT 100000) + +(RPAQQ \FM.EDIT-RIGHTENDSPACE 5) + +(RPAQQ \FM.EDIT-BLOCKSIZE 50) + +(RPAQQ \FM.EDIT-CONTROLCHARS (9 10 12 13)) + +(RPAQQ \FM.EDIT-CONTROLCHARSECHO 255) + +(RPAQQ \FM.EDIT-WORDDELIMCHARS (32 123 125 91 93 60 62 47 92 46 44 59 42 40 41 45)) + + +[CONSTANTS (\FM.EDIT-TIMEOUT 100000) + (\FM.EDIT-RIGHTENDSPACE 5) + (\FM.EDIT-BLOCKSIZE 50) + (\FM.EDIT-CONTROLCHARS '(9 10 12 13)) + (\FM.EDIT-CONTROLCHARSECHO 255) + (\FM.EDIT-WORDDELIMCHARS '(32 123 125 91 93 60 62 47 92 46 44 59 42 40 41 45] +) +) + +(RPAQQ \FM.EDIT-TTBL NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \FM.EDIT-TTBL) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \FM.EDIT-MAXWIDTH MACRO [NIL (OR LABELMAXWIDTH (IPLUS (WINDOWPROP WINDOW + 'WIDTH) + (fetch (REGION LEFT) + of (DSPCLIPPINGREGION + NIL WINDOW)) + (MINUS LEFT]) + +(PUTPROPS \FM.EDIT-SCROLLAMOUNT MACRO (NIL (IQUOTIENT (WINDOWPROP WINDOW 'WIDTH) + 2))) +) +(DEFINEQ + +(\FM.EDIT-SETUP + [LAMBDA (ITEM) (* ; "Edited 5-Dec-94 15:44 by jds") + + (* ;; "LABELMAXWIDTH is maximum width string can reach. Right now it is set to MAXWIDTH, leaving no right end space.") + + (OR \FM.EDIT-TTBL (\FM.EDIT-SETUPTTBL)) (* ; + "since have edit item, setup term table") + (\FM.ITEMPROP ITEM 'REGION (\FM.ITEMPROP ITEM 'MAXREGION)) + (* ; "always sensitive on maxregion") + [COND + ([AND (\FM.ITEMPROP ITEM 'BOX) + (NOT (\FM.ITEMPROP ITEM 'MAXWIDTH] (* ; "boxing implies maxwidth") + (\FM.ITEMPROP ITEM 'MAXWIDTH (IDIFFERENCE (fetch (REGION WIDTH) + of (\FM.ITEMPROP ITEM 'REGION)) + (ITIMES 2 (\FM.ITEMPROP ITEM 'BOXOFFSET] + (COND + [(\FM.ITEMPROP ITEM 'MAXWIDTH) (* ; "setup stopwidth") + (\FM.ITEMPROP ITEM 'LABELMAXWIDTH (\FM.ITEMPROP ITEM 'MAXWIDTH] + (T (* ; "make item infinite") + (\FM.ITEMPROP ITEM 'INFINITEWIDTH T))) + (OR (\FM.ITEMPROP ITEM 'MESSAGE) + (\FM.ITEMPROP ITEM 'MESSAGE (FUNCTION \FM.EDIT-MESSAGE))) + (\FM.ITEMPROP ITEM 'INITSTATE (\FM.ITEMPROP ITEM 'LABEL)) + (\FM.ITEMPROP ITEM 'SYSSELECTEDFN (FUNCTION \FM.EDIT-ITEM]) + +(\FM.EDIT-MESSAGE [LAMBDA (ITEM WINDOW BUTTONS) (* jow "24-Apr-86 22:05") (SELECTQ (CAR BUTTONS) (RIGHT "Will clear first, then start editing.") ((LEFT MIDDLE) "Will start editing at this position.") NIL]) + +(\FM.EDIT-SETUPTTBL [LAMBDA NIL (* jow "21-Aug-86 12:50") (* creates a new term table in \FM.TTBL with no line buffering or control  character echoing.) (SETQ \FM.EDIT-TTBL (COPYTERMTABLE 'ORIG)) (ECHOMODE NIL \FM.EDIT-TTBL) (for CC from 0 to 31 do (ECHOCONTROL CC 'REAL \FM.EDIT-TTBL]) + +(\FM.EDIT-ITEM + [LAMBDA (EDITITEM WINDOW BUTTONS STARTFLG DONEFN) (* ; "Edited 6-Dec-94 10:16 by jds") + +(* ;;; "called when an edit item gets selected. If STARTFLG is T, start editing the item at the beginning, rather than at the current mouse position.") + + (DECLARE (SPECVARS DONEFN EDITITEM WINDOW)) + (COND + ((EQ (CAR BUTTONS) + 'RIGHT) + (FM.CHANGELABEL EDITITEM "" WINDOW))) + (LET ((TIMEOUT (SETUPTIMER 0)) + FONT BITMAP LEFT DISPLAYLEFT DISPLAYBOTTOM BOXOFFSET CHCODE CHARWIDTH MAXWIDTH STRINGPTR + TAILPTR MOUSEX MOUSEY ITEM ITEMWIDTH LIMITCHARS SYSLIMITCHARS ECHOCHAR STREAM) + (RESETLST (* ; "setup system") + (RESETSAVE (SETTERMTABLE \FM.EDIT-TTBL)) + (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) + (RESETSAVE (CURSOR T)) + (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'FM.EDITITEM NIL)) + (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'FM.EDIT-TIMER NIL)) + (RESETSAVE NIL (LIST 'WINDOWPROP WINDOW 'PROCESS NIL)) + (\FM.EDIT-PREPARETOEDIT EDITITEM STARTFLG) (* ; "setup item info") + (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (* ; + "grab the tty last, so won't have it unless the menu thinks it's editing.") + [do (SETUPTIMER \FM.EDIT-TIMEOUT TIMEOUT) + + (* ;; + "wait for something interesting to happen. while waiting, call tty fns to make caret flash, etc,") + + (until (OR (MOUSESTATE (NOT UP)) + (READP) + (TIMEREXPIRED? TIMEOUT) + (NOT (TTY.PROCESSP))) do (\TTYBACKGROUND)) + [COND + [(NOT (TTY.PROCESSP)) + (RETURN (AND DONEFN (APPLY* DONEFN EDITITEM WINDOW] + [(LASTMOUSESTATE (NOT UP)) + (SETQ BUTTONS (DECODEBUTTONS)) + (SETQ MOUSEX (LASTMOUSEX WINDOW)) + (SETQ MOUSEY (LASTMOUSEY WINDOW)) + (SETQ ITEM (\FM.CHECKREGION WINDOW MOUSEX MOUSEY)) + (COND + ((EQ ITEM EDITITEM) + (SELECTQ (CAR BUTTONS) + (LEFT (\FM.EDIT-MOVECARET)) + (RIGHT (\FM.EDIT-DELETE)) + NIL)) + (ITEM (* ; + "run new buttonfn, in THIS PROCESS.*") + (\CARET.DOWN) + (AND DONEFN (SETQ BUTTONS (APPLY* DONEFN EDITITEM WINDOW))) + (* ; + "just reuse BUTTONS to hold result DONEFN") + (\FM.MENUHANDLER WINDOW T) + (RETURN BUTTONS)) + (T (* ; "let other button events run") + (BLOCK] + ((READP) + (SETQ CHCODE (\GETKEY)) + (SELECTQ CHCODE + (530 (* ; "SKIP-NEXT key") + (AND DONEFN (APPLY* DONEFN EDITITEM WINDOW)) + (FM.SKIPNEXT WINDOW)) + (562 (* ; + "SHIFT-SKIP-NEXT key means clear first") + (AND DONEFN (APPLY* DONEFN EDITITEM WINDOW)) + (FM.SKIPNEXT WINDOW T)) + (SELECTQ (GETSYNTAX CHCODE \FM.EDIT-TTBL) + (CHARDELETE (* ; "backup char,") + (\FM.EDIT-BACKUP)) + (WORDDELETE (* ; "delete word") + (\FM.EDIT-WORDDELETE)) + (\FM.EDIT-INSERT] + (COND + ((TIMEREXPIRED? TIMEOUT) + (RETURN (AND DONEFN (APPLY* DONEFN EDITITEM WINDOW])]) + +(\FM.EDIT-PREPARETOEDIT + [LAMBDA (EDITITEM STARTFLG) (* ; "Edited 5-Dec-94 15:46 by jds") + +(* ;;; "called to prepare edit info, displaystream, and window for EDITITEM. References variables bound in FM.EDIT-ITEM.") + + (\FM.ITEMPROP EDITITEM 'SELECTEDFN (FUNCTION NILL)) (* ; + "insure edit item won't have selectedfn side effect, because end of edit is not well defined") + (WINDOWPROP WINDOW 'FM.EDITITEM EDITITEM) + (WINDOWPROP WINDOW 'FM.EDIT-TIMER TIMEOUT) + (SETQ BOXOFFSET (OR (\FM.ITEMPROP EDITITEM 'BOXOFFSET) + 0)) + (SETQ FONT (\FM.ITEMPROP EDITITEM 'FONT)) + (SETQ BITMAP (\FM.ITEMPROP EDITITEM 'BITMAP)) + (SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM 'LABEL) + FONT)) + (SETQ MAXWIDTH (\FM.ITEMPROP EDITITEM 'MAXWIDTH)) + (SETQ LIMITCHARS (\FM.ITEMPROP EDITITEM 'LIMITCHARS)) + (SETQ SYSLIMITCHARS (\FM.ITEMPROP EDITITEM 'SYSLIMITCHARS)) + (SETQ ECHOCHAR (\FM.ITEMPROP EDITITEM 'ECHOCHAR)) (* setup edit pointer info) + (SETQ STREAM (DSPCREATE BITMAP)) + (LET ((REGION (\FM.ITEMPROP EDITITEM 'REGION)) + POINTER) + (SETQ DISPLAYLEFT (fetch (REGION LEFT) of REGION)) + (SETQ DISPLAYBOTTOM (fetch (REGION BOTTOM) of REGION)) + (SETQ LEFT (IPLUS DISPLAYLEFT BOXOFFSET)) + [SETQ POINTER (COND + (STARTFLG (CONS 1 0)) + (T (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM 'LABEL) + FONT LEFT (LASTMOUSEX WINDOW] + (SETQ STRINGPTR (CAR POINTER)) + (SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER))) (* ; + "setup window x and y position, so caret it right place") + (DSPXPOSITION (IPLUS LEFT (CDR POINTER)) + WINDOW) + (DSPYPOSITION (IPLUS DISPLAYBOTTOM (FONTPROP FONT 'DESCENT) + BOXOFFSET) + WINDOW) (* ; + "setup edit stream, used for printing inserted characters to the bitmap") + (DSPXPOSITION TAILPTR STREAM) + (DSPYPOSITION (IPLUS (FONTPROP FONT 'DESCENT) + BOXOFFSET) + STREAM) + (DSPFONT FONT STREAM]) + +(\FM.EDIT-FINDNEXT + [LAMBDA NIL (* ; "Edited 5-Dec-94 15:33 by jds") + + (* find the next edit item in the freemenu after ITEM. + Return NIL if there isn't another one.) + + (for I in [CDR (FMEMB EDITITEM (WINDOWPROP WINDOW 'FM.ITEMS] + thereis (FMEMB (\FM.ITEMPROP I 'TYPE) + '(EDIT NUMBER]) + +(\FM.EDIT-FINDFIRST [LAMBDA (WINDOW) (* jow "18-Jun-86 17:01") (* start editing the first edit item  in the menu.) (for I in (WINDOWPROP WINDOW 'FM.ITEMS) thereis (EQ (\FM.ITEMPROP I 'TYPE) 'EDIT]) + +(\FM.EDIT-BACKUP [LAMBDA NIL (* jow "24-Apr-86 16:23") (* backup 1 character, if possible) (if (IGREATERP STRINGPTR 1) then (SETQ STRINGPTR (SUB1 STRINGPTR)) (SETQ CHARWIDTH (CHARWIDTH (NTHCHARCODE (\FM.ITEMPROP EDITITEM 'LABEL) STRINGPTR) FONT)) (RELMOVETO (MINUS CHARWIDTH) 0 WINDOW) (RELMOVETO (MINUS CHARWIDTH) 0 STREAM) (if (ILESSP (DSPXPOSITION NIL WINDOW) (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW))) then (SCROLLW WINDOW (\FM.EDIT-SCROLLAMOUNT) 0) (* about to backup off window%:  scroll.)) (BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IDIFFERENCE TAILPTR CHARWIDTH) BOXOFFSET (IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR)) (FONTPROP FONT 'HEIGHT)) (\FM.ITEMPROP EDITITEM 'LABEL (\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM 'LABEL) STRINGPTR STRINGPTR)) (SETQ ITEMWIDTH (IDIFFERENCE ITEMWIDTH CHARWIDTH)) (SETQ TAILPTR (IDIFFERENCE TAILPTR CHARWIDTH)) (\FM.EDIT-UPDATEAFTERDELETE]) + +(\FM.EDIT-WORDDELETE [LAMBDA NIL (* jow "24-Apr-86 16:54") (* called on ^W. The list \FM.EDIT-WRODDELIMCHARS specifies a list of character  codes that stop word delete. Backup over any number of these chars, then any  number of non-delim chars, until get to another delim char, leaving that char  in the string.) (if (NEQ STRINGPTR 1) then (LET ((END (SUB1 STRINGPTR)) (STRING (\FM.ITEMPROP EDITITEM 'LABEL)) (ENDTAILPTR BOXOFFSET)) (while (AND (NEQ END 1) (FMEMB (NTHCHARCODE STRING (SUB1 END)) \FM.EDIT-WORDDELIMCHARS)) do (* move END back to the farthest  sequential delim char) (SETQ END (SUB1 END))) (while (AND (NEQ END 1) (NOT (FMEMB (NTHCHARCODE STRING (SUB1 END)) \FM.EDIT-WORDDELIMCHARS))) do (* move END back to the farthest  sequential non-delim char) (SETQ END (SUB1 END))) (* now END is pointing to the  farthest char to be deleted) [if (NEQ END 1) then (SETQ ENDTAILPTR (IPLUS BOXOFFSET (STRINGWIDTH (SUBSTRING STRING 1 (SUB1 END)) FONT] (BITBLT BITMAP TAILPTR BOXOFFSET BITMAP ENDTAILPTR BOXOFFSET (IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR)) (FONTPROP FONT 'HEIGHT)) (\FM.ITEMPROP EDITITEM 'LABEL (\FM.EDIT-STRDELETE STRING END (SUB1 STRINGPTR ))) (SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM 'LABEL) FONT)) (SETQ STRINGPTR END) (SETQ TAILPTR ENDTAILPTR) (DSPXPOSITION (IPLUS LEFT TAILPTR) WINDOW) (DSPXPOSITION TAILPTR STREAM) (if (ILESSP (DSPXPOSITION NIL WINDOW) (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW))) then (SCROLLW WINDOW (\FM.EDIT-SCROLLAMOUNT) 0) (* about to backup off window%:  scroll.)) (\FM.EDIT-UPDATEAFTERDELETE]) + +(\FM.EDIT-INSERT + [LAMBDA NIL (* ; "Edited 5-Dec-94 15:42 by jds") + + (* ;; "Insert a character into an EDIT or NUMBER freemenu item. Before inserting, check against LIMITCHARS, the user-specified character limit, and against SYSLIMITCHARS, the system-provided limit. For example, on NUMBER items, SYSLIMITCHARS limits type-in to numbers, but the user's LMIITCHARS function might also enable CR as a skip-next character.") + + (COND + ([AND [OR (NOT LIMITCHARS) + (AND (LISTP LIMITCHARS) + (FMEMB (CHARACTER CHCODE) + LIMITCHARS)) + (AND (ATOM LIMITCHARS) + (APPLY* LIMITCHARS EDITITEM WINDOW (CHARACTER CHCODE] + (OR (NOT SYSLIMITCHARS) + (AND (LISTP SYSLIMITCHARS) + (FMEMB (CHARACTER CHCODE) + SYSLIMITCHARS)) + (AND (ATOM SYSLIMITCHARS) + (APPLY* SYSLIMITCHARS EDITITEM WINDOW (CHARACTER CHCODE] + (* ; + "insert a single character, CHCODE into the string") + (SETQ CHARWIDTH (CHARWIDTH CHCODE FONT)) + (COND + ((OR (NOT MAXWIDTH) + (ILEQ (IPLUS ITEMWIDTH CHARWIDTH) + MAXWIDTH)) (* ; "i am going to insert") + (RELMOVETO CHARWIDTH 0 WINDOW) + (COND + ([IGREATERP (DSPXPOSITION NIL WINDOW) + (IPLUS (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL WINDOW)) + (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL WINDOW] + (* ; + "about to type off window: scroll back.") + (add (fetch (REGION WIDTH) of (WINDOWPROP WINDOW 'EXTENT)) + \FM.EDIT-BLOCKSIZE) + (SCROLLW WINDOW (MINUS (\FM.EDIT-SCROLLAMOUNT)) + 0))) + (COND + ((IGREATERP (IPLUS ITEMWIDTH CHARWIDTH) + (BITMAPWIDTH BITMAP)) (* ; + "current bitmap too small, make new one. This won't get done if item is boxed.") + (\FM.ITEMPROP EDITITEM 'BITMAP (BITMAPCREATE (IPLUS (BITMAPWIDTH BITMAP) + \FM.EDIT-BLOCKSIZE) + (BITMAPHEIGHT BITMAP))) + (BITBLT BITMAP 0 0 (\FM.ITEMPROP EDITITEM 'BITMAP) + 0 0) + (SETQ BITMAP (\FM.ITEMPROP EDITITEM 'BITMAP)) + (DSPDESTINATION BITMAP STREAM))) (* ; + "now insert character into bitmap") + (BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IPLUS TAILPTR CHARWIDTH) + BOXOFFSET + (IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR)) + (FONTPROP FONT 'HEIGHT)) + (SETQ ITEMWIDTH (IPLUS ITEMWIDTH CHARWIDTH)) + (COND + ((FMEMB CHCODE \FM.EDIT-CONTROLCHARS) (* ; + "for CR, LF, TAB, etc, echo non control action char") + (PRIN1 (OR ECHOCHAR (CHARACTER \FM.EDIT-CONTROLCHARSECHO)) + STREAM)) + (T (PRIN1 (OR ECHOCHAR (CHARACTER CHCODE)) + STREAM))) + (\CARET.DOWN) + (BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH) + (\FM.ITEMPROP EDITITEM 'LABEL (\FM.EDIT-STRINSERT (\FM.ITEMPROP EDITITEM 'LABEL) + (CHARACTER CHCODE) + STRINGPTR)) + (SETQ STRINGPTR (ADD1 STRINGPTR)) + (SETQ TAILPTR (IPLUS TAILPTR CHARWIDTH)) + (EXTENDREGION (WINDOWPROP WINDOW 'EXTENT) + (CREATEREGION LEFT 0 (IPLUS ITEMWIDTH BOXOFFSET) + 0]) + +(\FM.EDIT-DELETE [LAMBDA NIL (* jow "10-Jun-86 16:12") (* Called when a right button event occurs in ITEM's region, while it is being  edited. Delete the substring of the items string starting at the current  position, and ending at the position of MOUSEX, inclusive.) (\CARET.DOWN) (while (MOUSESTATE (NOT UP)) bind (REGION _ (\FM.ITEMPROP EDITITEM 'REGION)) (INFINITEWIDTH _ (\FM.ITEMPROP EDITITEM 'INFINITEWIDTH)) (BOTTOM _ (IPLUS BOXOFFSET DISPLAYBOTTOM)) (HEIGHT _ (FONTPROP FONT 'HEIGHT)) (PIVOT _ (IPLUS DISPLAYLEFT TAILPTR)) END POINTER OLDPOINTER MOVEDOFF eachtime (SETQ MOUSEX (LASTMOUSEX WINDOW)) (SETQ MOUSEY (LASTMOUSEY WINDOW)) do (if (\FM.ONITEM REGION MOUSEX MOUSEY INFINITEWIDTH) then (SETQ OLDPOINTER POINTER) (SETQ POINTER (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM 'LABEL) FONT LEFT MOUSEX)) [if (OR MOVEDOFF (NOT (EQUAL POINTER OLDPOINTER))) then (SETQ MOVEDOFF NIL) (SETQ END (IPLUS LEFT (CDR POINTER))) (BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH) (if (IGREATERP END PIVOT) then (* highlight from pivot to end) (BLTSHADE BLACKSHADE WINDOW PIVOT BOTTOM (IDIFFERENCE END PIVOT) HEIGHT 'INVERT) else (* highlight from end to pivot) (BLTSHADE BLACKSHADE WINDOW END BOTTOM (IDIFFERENCE PIVOT END) HEIGHT 'INVERT] elseif (NOT MOVEDOFF) then (BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH) (SETQ MOVEDOFF T)) finally (if (AND (\FM.ONITEM REGION MOUSEX MOUSEY INFINITEWIDTH) (NEQ (CAR POINTER) STRINGPTR)) then (if (IGREATERP END PIVOT) then (* from current to right%: pointers  and xpositions remain the same) (BITBLT BITMAP (IPLUS BOXOFFSET (CDR POINTER)) BOXOFFSET BITMAP TAILPTR BOXOFFSET (IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR)) HEIGHT) [\FM.ITEMPROP EDITITEM 'LABEL (\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM 'LABEL) STRINGPTR (SUB1 (CAR POINTER] else (* from current to left%:) (BITBLT BITMAP TAILPTR BOXOFFSET BITMAP (IPLUS BOXOFFSET (CDR POINTER)) BOXOFFSET (IPLUS BOXOFFSET ITEMWIDTH (MINUS TAILPTR)) HEIGHT) (\FM.ITEMPROP EDITITEM 'LABEL (\FM.EDIT-STRDELETE (\FM.ITEMPROP EDITITEM 'LABEL) (CAR POINTER) (SUB1 STRINGPTR))) (SETQ STRINGPTR (CAR POINTER)) (SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER))) (DSPXPOSITION END WINDOW) (DSPXPOSITION TAILPTR STREAM)) (SETQ ITEMWIDTH (STRINGWIDTH (\FM.ITEMPROP EDITITEM 'LABEL) FONT)) (\FM.EDIT-UPDATEAFTERDELETE]) + +(\FM.EDIT-GETPOINTERINFO [LAMBDA (STRING FONT LEFT MOUSEX) (* jow "22-Apr-86 14:58") (* calculate string pointer and tail pointer from mouse location within string.  Assume mousex in window coordinates, not REGION coordinates.  Return as dotted pair (stringptr . tailptr) --  Each character is sensitive 2 bits to the left to allow for mousing between  chars) (SETQ MOUSEX (IDIFFERENCE MOUSEX LEFT)) (LET ((PTR)) (for N (WIDTH _ -2) from 1 to (NCHARS STRING) do (add WIDTH (CHARWIDTH (NTHCHARCODE STRING N) FONT)) (if (IGREATERP WIDTH MOUSEX) then (SETQ PTR N) (RETURN))) (if PTR then (* mouse at PTR in string) (CONS PTR (STRINGWIDTH (OR (SUBSTRING STRING 1 (SUB1 PTR)) "") FONT)) else (* mouse at end of string) (CONS (ADD1 (NCHARS STRING)) (STRINGWIDTH STRING FONT]) + +(\FM.EDIT-MOVECARET [LAMBDA NIL (* jow "10-Sep-86 10:33") (* mouse event has occured at MOUSEX in ITEM's region while editing.  Move the edit caret to that position) (\CARET.DOWN) (SETQ POINTER (\FM.EDIT-GETPOINTERINFO (\FM.ITEMPROP EDITITEM 'LABEL) FONT LEFT MOUSEX)) (DSPXPOSITION (IPLUS LEFT (CDR POINTER)) WINDOW) (* move caret) (SETQ STRINGPTR (CAR POINTER)) (* update edit pointers) (SETQ TAILPTR (IPLUS BOXOFFSET (CDR POINTER))) (DSPXPOSITION TAILPTR STREAM]) + +(\FM.EDIT-STRDELETE [LAMBDA (STRING N M) (* jow "17-Jul-85 00:29") (* delete from characters N through M of STRING.  no bounds checks are made on N and M. returns a new string) (CONCAT (OR (SUBSTRING STRING 1 (SUB1 N)) "") (OR (SUBSTRING STRING (ADD1 M) (NCHARS STRING)) ""]) + +(\FM.EDIT-STRINSERT [LAMBDA (STRING CHAR N) (* jow "17-Jul-85 00:40") (* return new string with CHAR inserted as new character at position N.  just appends CHAR if N is 1 greater than nchars) (CONCAT (OR (SUBSTRING STRING 1 (SUB1 N)) "") CHAR (OR (SUBSTRING STRING N (NCHARS STRING)) ""]) + +(\FM.EDIT-UPDATEAFTERDELETE [LAMBDA NIL (* jow "10-Jun-86 16:09") (* called to update the screen after  a delete has occured.) (\CARET.DOWN) (BLTSHADE WHITESHADE BITMAP (IPLUS BOXOFFSET ITEMWIDTH) BOXOFFSET (IDIFFERENCE (BITMAPWIDTH BITMAP) (IPLUS ITEMWIDTH BOXOFFSET BOXOFFSET)) (FONTPROP FONT 'HEIGHT)) (* whiteout to rightmargin) (BITBLT BITMAP 0 0 WINDOW DISPLAYLEFT DISPLAYBOTTOM MAXWIDTH]) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA FM.ITEMPROP) +) +(PUTPROPS FREEMENU COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (15698 32870 (FREEMENU 15708 . 17262) (FM.ITEMPROP 17264 . 17826) (FM.GETITEM 17828 . +18435) (FM.GETSTATE 18437 . 20018) (FM.HIGHLIGHTITEM 20020 . 20386) (FM.CHANGELABEL 20388 . 22146) ( +FM.CHANGESTATE 22148 . 24025) (FM.RESETSTATE 24027 . 24744) (FM.RESETMENU 24746 . 25318) ( +FM.RESETSHAPE 25320 . 26810) (FM.RESETGROUPS 26812 . 27270) (FM.REDISPLAYITEM 27272 . 27704) ( +FM.REDISPLAYMENU 27706 . 28154) (FM.SHADE 28156 . 28690) (FM.EDITP 28692 . 28864) (FM.EDITITEM 28866 + . 29580) (FM.ENDEDIT 29582 . 29756) (FM.SKIPNEXT 29758 . 31773) (FM.WHICHITEM 31775 . 32567) ( +FM.TOPGROUPID 32569 . 32868)) (40917 97938 (\FM.FORMAT 40927 . 43323) (\FM.FORMATBYROW 43325 . 45089) +(\FM.FORMATBYCOLUMN 45091 . 48947) (\FM.FORMATBYGRID 48949 . 54784) (\FM.FORMATEXPLICIT 54786 . 57941) + (\FM.LAYOUTROW 57943 . 60320) (\FM.LAYOUTCOLUMN 60322 . 62898) (\FM.LAYOUTGRID 62900 . 67666) ( +\FM.JUSTIFYITEMS 67668 . 72308) (\FM.JUSTIFYGROUPS 72310 . 73816) (\FM.PUSHGROUP 73818 . 75342) ( +\FM.CHECKDESCRIPTION 75344 . 80920) (\FM.CHECKPROPS 80922 . 81859) (\FM.CREATEITEM 81861 . 84334) ( +\FM.GETREGIONS 84336 . 86563) (\FM.GETBITMAPS 86565 . 89099) (\FM.MAKEBITMAP 89101 . 90848) ( +\FM.READUSERDATA 90850 . 91550) (\FM.MAKELINKS 91552 . 92245) (\FM.COLLECTNWAYS 92247 . 94747) ( +\FM.SETATTACHPOINT 94749 . 95312) (\FM.CREATEW 95314 . 97448) (\FM.STARTEDIT 97450 . 97936)) (108089 +123474 (\FM.OPENFN 108099 . 108535) (\FM.REDISPLAYMENU 108537 . 111038) (\FM.RESHAPEFN 111040 . 113323 +) (\FM.UNSCROLLWINDOW 113325 . 113945) (\FM.RESETCLIPPINGREGION 113947 . 115040) (\FM.FILLWINDOW +115042 . 116014) (\FM.INITCORNERSFN 116016 . 116907) (\FM.TRANSPOSEHORZ 116909 . 117754) ( +\FM.TRANSPOSEVERT 117756 . 118607) (\FM.UPDATEGROUPEXTENT 118609 . 120903) (\FM.WINDOWEXTENT 120905 . +121846) (\FM.UPDATEWINDOWEXTENT 121848 . 123472)) (124998 132221 (\FM.WINDOWENTRYFN 125008 . 126105) ( +\FM.BUTTONEVENTFN 126107 . 126566) (\FM.RIGHTBUTTONFN 126568 . 127398) (\FM.DOSELECTION 127400 . +127992) (\FM.MENUHANDLER 127994 . 132219)) (134604 155966 (\FM.GETITEMPROP 134614 . 136703) ( +\FM.PUTITEMPROP 136705 . 141157) (\FM.CGETITEMPROP 141159 . 143852) (\FM.CPUTITEMPROP 143854 . 149622) + (\FM.DISPLAYITEM 149624 . 149811) (\FM.HIGHLIGHTITEM 149813 . 150005) (\FM.CHANGELABEL 150007 . +152365) (\FM.CHANGESTATE 152367 . 153271) (\FM.ENDEDIT 153273 . 154141) (\FM.INSUREVISIBLE 154143 . +154937) (\FM.CLEARITEM 154939 . 155964)) (156008 156777 (\FM.MOMENTARY-SETUP 156018 . 156443) ( +\FM.MOMENTARY-SELECTEDFN 156445 . 156775)) (156816 159452 (\FM.TOGGLE-SETUP 156826 . 157894) ( +\FM.TOGGLE-DOWNFN 157896 . 158421) (\FM.TOGGLE-SELECTEDFN 158423 . 158868) (\FM.TOGGLE-CHANGESTATE +158870 . 159450)) (159491 166866 (\FM.3STATE-SETUP 159501 . 160530) (\FM.3STATE-SETUPOFFBITMAP 160532 + . 164241) (\FM.3STATE-DOWNFN 164243 . 165120) (\FM.3STATE-SELECTEDFN 165122 . 165837) ( +\FM.3STATE-CHANGESTATE 165839 . 166864)) (166904 169846 (\FM.STATE-SETUP 166914 . 168352) ( +\FM.STATE-SELECTEDFN 168354 . 169373) (\FM.STATE-CHANGESTATE 169375 . 169844)) (169883 174658 ( +\FM.NWAY-SETUP 169893 . 170736) (\FM.NWAY-MESSAGE 170738 . 171259) (\FM.NWAY-DOWNFN 171261 . 172277) ( +\FM.NWAY-MOVEDFN 172279 . 173298) (\FM.NWAY-SELECTEDFN 173300 . 173966) (\FM.NWAY-CHANGESTATE 173968 + . 174656)) (174697 177292 (\FM.NUMBER-SETUP 174707 . 176458) (\FM.NUMBER-MESSAGE 176460 . 176766) ( +\FM.NUMBER-SELECTEDFN 176768 . 176967) (\FM.NUMBER-CHANGESTATE 176969 . 177290)) (177330 177533 ( +\FM.DISPLAY-SETUP 177340 . 177531)) (177575 179316 (\FM.EDITSTART-SETUP 177585 . 177990) ( +\FM.EDITSTART-MESSAGE 177992 . 178266) (\FM.EDITSTART-SELECTEDFN 178268 . 179314)) (180792 209047 ( +\FM.EDIT-SETUP 180802 . 182332) (\FM.EDIT-MESSAGE 182334 . 182620) (\FM.EDIT-SETUPTTBL 182622 . 183019 +) (\FM.EDIT-ITEM 183021 . 187550) (\FM.EDIT-PREPARETOEDIT 187552 . 189928) (\FM.EDIT-FINDNEXT 189930 + . 190340) (\FM.EDIT-FINDFIRST 190342 . 190803) (\FM.EDIT-BACKUP 190805 . 192477) (\FM.EDIT-WORDDELETE + 192479 . 195905) (\FM.EDIT-INSERT 195907 . 200169) (\FM.EDIT-DELETE 200171 . 205544) ( +\FM.EDIT-GETPOINTERINFO 205546 . 206846) (\FM.EDIT-MOVECARET 206848 . 207536) (\FM.EDIT-STRDELETE +207538 . 207954) (\FM.EDIT-STRINSERT 207956 . 208371) (\FM.EDIT-UPDATEAFTERDELETE 208373 . 209045)))) +) +STOP diff --git a/sources/FREEMENU.TEDIT b/sources/FREEMENU.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..645ca5d289b88d0588faa91efe1762adda862856 GIT binary patch literal 56331 zcmeHwe{kH#b>D%cZBh|zO14u+v7@hP#sV`iLQ$eDD;k9d;y|2*U&b9sscAYq00-c# z!ySBg5J}rX{?lhT6Gt*3(p)J{x+ccg`o9Rr|x{U2kGM=WD ztZGIhPpW=C@9o>&@Atk3P$ZrH(O^j6Zoj*4-@bjn_U+sK-ab4$U9QY0)8+An;=+T; zeDUP{#Z#q9GEYdfCW>RadB&*H(`NmSSo@~hT-g>PkmA1NdR#|O#lG^5Gv$0(3 zHQKFiA{AQo`ig6CuF+dhRvN3T^-jIjOL`YJ>)oWinlyU#jqYgDXe~FlRvN9fWVyYu z!4BPnZm-s>+ZUGCR~o$<5s?aGNm5Ka-bu6ZFu*oiNi8|oXsxu*jV9;T8_Vm-a;=pt z)syySy#h>reT)qs z8y=piJw)tl0U1&_#;ws!mbMzrUb5P0Z=fQ&UG6kCNiGtCu-PA|1M&mGX6-_It7nf$ zb`BQLLKg{Ob{iX;%?l`9>$JBvBa+7TCZfLLHr>toa%0s^8rx>Upvw{n;()J%TALjZ zvD0gS&b4m0z1+b3tbh`j-bQa!=-I}zI$MQ_DPx)etGZtAg0TV!Mc{&r9z3)Gu5z@H z>E%?CFfuj(2U+-aslHx&xPj?HUFnFG6@0R~)mj#slC{bENw4-0k&Up4$e}%bZZZ*{A|`bGMg#fAdjenBB`f%r+XMK zHhc9>3wq??dh^1l)TQ_mZU*VNdthEm91#;I7Z10Of1w#E!k*;-c)0aPEEufk-Rt42_HLACE0>voUF4dMF`q)+*N^G^Z z+-Np>!Xl~(gfh9*M8_2;=Z`aMR7rt8Sf|GsMy0+D8LrS4CnqYqDD8Qkb0<2E^oM>{WvF6rB3!fpO zD6c^Rp|Is^z3Ipj&AG5=tO)AoYsJF8I7d$p?ZB2 z{MZ5UZB9G&HL6;*Ty9Vpx(>Cyyu7su8CG7=GB;xK40I&MNs*NPp`{es7&IFAo^lTk zWizuhX*zATyMiVK12UmR=Qvu_2(AY=TpKrV>9sdM(5$aQt@6_{Ohdh+pGEvfla0p8 zO0(|j)O*V@BSZ|6<%H@Kw-?#dL873-t8o|-npP&L!FE}HhhK}d8^9~N)OCWmrs_f^ygfs zqlqBgp?!1Eb)@RK$ZTIoT3Z`SB=2g!axxbTCcBeNX)wvlPJ-vyD4>>p! z8S7Mp%Spd;hN^)EjV^e_F^f_$j78WZxwl*`%_I}0%E^WDe6>6`d*5(QSt6AqiY&~X zA=6ZgFRVt5TGYfT3=>LITZ_-#Sb-*> z24+Ra1Z>+1V^;9dL}3=_qQ#P_LLxHj94oK~^!<)=SwFvA-=qLRkC6nbD#g*KVC^!= zP_N=83{vj!SsH6lF=|ts17ZfN1Hl-FsbRMea%DG}1{fY;Dn$k?>BY;*5-CXm3-$^M zl~#JG-Ge=&s{^{L@~6V(BlWPH&X+ku6$j4|9S}!|0M{()x5GOi8O-(J!)OwY^f4*f zi!68Gr$iKFNd%SZ)Z%b5($BW2>c$BdQgkrz8cqf>b7FFl?FTvyjK_iJwvPMRrK$|! zNUTUs&P^}Q%=QUPpj+T!kXpD2x`WgRng_I=!V(nvDi#@3)8Pl%5$~F-HM$+K@Qfy% z8m6Gb4ygLV1oksTdfLGd3Qo*z#3?a9XbsrhhVwrLtTDtV5XtD&m$y1yacmQqB|2d$ z*BEQDbpcii43uFSY0WhZg}0n>{h-t7(86TunnR$$FQ|1M0&FKh-YlM4m|L7@SEC@3TCT=__@kRGAtfWm;!;}D#Z6`}ZG@S_nM5GSH$7Jqi!-ITDOLn9sog7VU7VO$C{-#kfcbU!=b7f9y~94${d9SzTs=8eTtGzb z!TG7V+0r~wl21nfQx*q8R7OsE=h|W^Xl$3ZV0XAgawKCJ$)F~vx6ZX5BVEw&_2vrd ziS;f|+}4!=k7^%U+l>KoScRmN*h)1dgLsV=79O=`THf66iAuC#3z51VZp!R{u^ZdDf1QTx~!%y63Umr}M+8AXWkhKJ*Z?0Oqq?@Ovjo z7(ylm4pKMp3O?5m-1SUkL$jgVcSi$6AasZtL=gs|*G>hwNv?IS8ZIC1gBcK?$R zKAF#ZayOowPx77|Mn5M8JlP%q?a&0C^keYcb8kI#_cpM;oW<=@A^+!k)9w29^Xv&? zeMp(+-GvwVjXy^VUpv9S@?;WR-E zI#{@G;_FYne*#Y)fBXBV?8&Lm-v?-)eB|xlA+(piw{O3D^6c}UPw?c#BRB8klSlUK zdlP}7A3OoHLlciYb$H)4p4=Rsocg?A@JQ|1y@hudw!gJ+k85*D{<>fL`8W5;oB8BM z{z5;O$7ccF9bkDv`{qiDk`^vU^@|9$Gd(Xau`s5;?{NiUu@7}z; zJ#-=&{_HJx9{kobzx2Z(`B^-9{By@99zVEUC|^Jl()ELsHj%`6oFvxMYI z`Ka(ieVgi;x$t=kTVnkH?o2nO2V0z;pDIeRtch|LJjpnAqxpDtA~|-)?ROj%JdW{q z1sm0+MBvH-2$+qCGe3K#_+X-Ig`%RJVD-e+0s?aUczePsI=m4C>trR7VAP4Oj&wbh zg*BcJivzHqzWz@RXcIMZNLQ-GYRO@J=;V4E`^L#k{g7+VEk=eGE6E5p=}*rg#5i3Q z+F94wbT3yGh&+SGH+w&-yOm9%>rO{=PLKalq^+LKi=pB%C_ZqeJW-uW?l{gx2UwrsViH{8e~{)H=Av2{H=wJ6YtLb^TNXe+_`)q>r=rL%Dq=zde+Hw zfbc3x`b#h6mOj(|>2I##34a2F?=Ro=!p61~Mx|f=#$7M8`%0hr#9c2mwQ5xN`|Z2F zxz<+~)!yZ*Ms)|4TGe#j>stD?Q=h%>V&V30-S$U?x9z{<@}5I4{eATIwW;#{i-qx< z-+NPG|Nax(dk#Ii52as?O5br}d#LJ4XZOEaICS%SZ!Ns-9SKTb3UzN52!{@$bo((t zc=mb1)zbUm1zgn9=Pq8nSg8HUmv1V(t#}rtFB8HgKhE&s2Uq%ySnInE_ZFTHU3)|I z21{T1+@-yL_W0$(Yq$N_1rPV@2c9YvE`Ayw-h4Dw_b*<1nhx5VkEZH={FT$iXKq}6(?>pY77q>XYp*?BJp9yS zzp(J(%c1l==eACxbnO=^|Nd+!z2(J^KV3Tf)I0V)m4e&;SEoPpz8jYxdooq`4UUby zTp=BPLn-;%WwvlM^V7C?Hk1ySH#Zl5v6!lR=_h0^Zg~3X%K^fBP8^rH7`~Fav&T=L z|K6G1k@WiDPz)9j7Sh1HJd4fwjB^jutd-BZW&>OOB^Q*%6(UpE(r0d;fX=Ht*ewr9RJ zR{)=ReE0s@7cP9e@a+4i3b({{FFsX-)%)?ORNaCroh#h(`gaY9%Y|PN2&`*R$-i3n z@biU~TuA9N&we9Q_etPz34)NSi|;CL`PwtT6pd0p3L#a5FM9`gcq;3e--Y2KLf6QB zN=FHiIf{fQO(MWLN&=l#%>rt)u(rBV~ect zVy??!Lms@!WQ{lYbZFbaX4~$)j3x2lr>MTe)8XHH{lXVe#ePy)?fvs#eqrNx>=FK^ zpT6bZ7dC!>;M3v%@xsP$4t)COzxTq0Umx_83(;A8aM54`4SXwQfRv`hJ4e0KHYu{ZI21$)YDt>l%6%7-u|sa!0KJ+H$7Hw z`3Jwrr!NDtb>{j^{rP|QH03@94Z<}YWVu=k&NFx^)g=Ap3c2p516u@WzU|IWy~SQ!%xQa%S>val z&Ut!GZC|&w#49ZUnZgA3U0=K5ALq7x<-1>cwEW`-Zulp^mV?#t|M^Pw(emMM-0;snpY!yd z%jma!c;vw0+eqpit(s%Al2DE+ZqhES_-~MDkzfUbz@pOJb+b^K) zclOWk*!JRpw%YHj1KJYjKYe`PfVMw4TJ22d*S{;g@ml^IE&89F8N6p_o%8x1TjRX8 z+aI;oIZuyoThqmyr}ymK_Om;-eR9WspV+bO6W7po=YDs_dBAwp?#HyE-4}wvgHpR6 z(~9=Dz#l#p+a0$}Jr%nT{p{yx2zK8?*0!EhiyOu0J6p+}pBk{#Uk^D|YF`HLw^60;wl3qTxsZ)^Dw9snBMYTLC(n?qGSfyr zy5u6pIpoZE>eQR{hml#Y$vfS3Syv);2FIQxF@_6OX^2duCCzCT{vW-Wyn9Ppv+_mD@vEc*di33%TL=$q6 z&LmmX|?2HcLTdjRwR=e3(rp`GadXe1>FPoLWJy zvmTj|1Td4unZ(ZK5ycHjsk2o(P%yWk z8IjC&litvWY`B3vNH^Gnf0DBMBg{OUD~a?ejRu(%wSkFpxz8f{+KC zX2kd(s7w_nN&=(1UPB7969P1K&zWP8*M|*@^puXI7k5&HZGGB;wC4Ft4jQ$hjv{fK zjk3X=OuK}6MLr8)l*zp=16Rgtu;hqJoLlaowc5;~ukzFf{w>v)CDj#8*Kk<9!&5#0 z2Zr~jPQffN1fX60JP#9+H~b)wuikc@LyqfEr>KDaf25;^N;D5n5Ul6^41H%p0=e|? z!MqwloEw`1g*(Zq9K&4&=|ggXa(J%kW7_jZt$|}~IHf0o?Cq~0hP2^usQ~6jY&jt5 z(Q6PcS%xuLL$&;a2bgZj&47-Vb54$lQi{qrexY;)x$x~_Eak_qe}xpNfq97WdsL~-%d6f%P<5v~eGYJgYdA_MBFmD&~#e{KaSU9v&_Z5_LwkbR{Z-~|+kte_5p$A;1D6Dj zkeIkOabk1C`rAt%#i3<8>PBMmU>FlksCRhwJu>%!F~GZ9Fp2=cYP6)t(XK7ko9fDK zw3z~q^FWvf%Z%oMWt?X5rw>ts*HK891OOcL{MC{g9ZqHcSx%BlMvLlV2tXJ)tl!6y zvvB1EE=S5?GpbQFpjs_f*rt z*=wj1+Q(;tWuQ?@;g4d}EL(wixbweINN%cd?wbdK)g4G3ASMoBK8=}3C$diP5s^@* zSzrtGRUBJhPg3VW#uiGGC7i3knUGc) zW#6c6qLLbo^?GxY0)gS$`3ahV^o0cJx$*vczI!?I;CQ(@Q=C`M(C(Z!H9TUM3*a%V{QZILa<14cqKN8I5$HgJ1+w?l4qPRcQy-6R6EKs8dPvbrav_psPKij=785t3I^lgHA-RsDiTlHZ&e4R&wNS8t6Hfd% zn#?ZFjF%Q<72*;cK`fHqIVR*U4;+Y#zBmAK;xtct16s$OUxHEr6T*wwMEi051Z4qH zs5N<`1+)e(cEFk$evv?;zvcLms0_LQe-I_LzwGU)LfnL?h zRl)%?dfN$@PR@+EgZU8Btybe>Td7ciU)c~l=lSA*7aX%zoks?tqcLb*9*O_!RyLv& zvGluTm*tJy+MVl65KWTEg=h<9xQ)QM;@6&z1Ia4v4S&_xt%K`7 zj!1{x+>&#vN$lj(0aMQu>BO_C!))}|^%>Ly=SRllgs*3k`LZK_47yo3{Ybn5rkrn`7XKL;d1fD8|Z^IR-eHQ`S4& z0EkN+fezq0gCnT8*A1S(YBg02he!>f9iTr}O%5m3dyb_>C-4DhT$qkhpmeli8)6f-XM zUb;EgSm6yD%&Et)NoP-WH=;=QFc-gB=ane+7MD&?ay2Z!!Vy~GI|bsHkW{Bw;jaMJ z{&+B$7cfE6FpYE&6|bq1GJgZ}izomZ8M01ItG{5vgn*SPqObt=jqUlgs-8(0pJ#I2Ur6 zT8DvhucFLWgh&p0m(wH%oI_wXyV+-=yaNyNYOfCLGOl^WHwvE@pc>1 zm%2vJEUUs%MZ+gf^FXi2S_(2st=3uF;$kv@&qs2lEnW>Zaff$ULjTHjIv1jqi!<*5 zKV?$h%&|;Vp?PHMgG)dn6t2S*rjWP-rUKrFTsO0f-~dNL^`IllLydCcXb_Y~1{0@# zjL&2$pnp^orYH(vv*qb&*T65M1Rtk3!_p|4Yaa%}8FZZPC+J`=#G)gLP}^8qsYOd! zFmG7*s|Oufn7-vXa1%P=uV0_X&WYT7Kpo8w6@&*Y3Jc`uk&34W8{^jYt8~Z7_Tk2a zV3A>|W+ycmXwyj{%HWhSyKB7oGRNl1_{DYLtSe7%z$`h6r2=EaA<- zTJMNYr;cDRyaZS=EQN9DN9YRl8srTCHh|B}oi6PRJsQ))hu22BB954gvcpyOb&D2*HsJcGhZS6Sx!l9e4Z{ayQ_Jm%hA^(WwSLRlTOVUc zS(Hse#f42!I*K&ckT$Mopl(Ect0c1>oPO7tU-EO5V&0+0dph^XYXi(<&jxH!1z=wt-k==al;O(lt6*NHX@dda z9g4K~+G}g*oKQ-b(nh%zjf%>upg#ofbPg-SErlIbuQ#lzRBw|Y zy0#F%ORrG$T2{lZw)-fnmUDIRC)B^~BC0}G(d^O>lHEwR4-g@Nk->?H@Z6}KZ)|LB z&{*s3l5S+YF;p&<#047G30S}_`UZGKfg?o$N27A>jF(_aq31|OM?P@c7On`a)A_4B zSaIr0KAUvQm$bfx5Ky)V$61WX;08O3*oh@71R+JLf$ZOca=Lff=Y|UprL0S2ub1i= zi*^m41q-MFJ#(CFW{wSSJFe4UhlQLhrIc0OIt_R1@mf$WvE)+B0~QrKkQZhnnci$6kFZzHI zIn%Az^1?>}foP$vJ{V$i0Dy>`=nUSOx`k^Dc_bMwF1@iexO_rfr+LKht%1Kpu{g+_ zEWJV!jtX^x+;0T4hp%J9cT{*^ILD!%+&DUIxkeoKD#=<)S|W@>=9-(FWH1q}+@;k$ zEQB}|ECS~vVr=AnC#jbucZYiVVz(dQ_^%Cl9m83>6Oi+!QkGGS8-N=FdAiM7myWwm43|@W2IWJqR3Yk1aR#^$M^8{{a!2JRB5IHZB!+pfi{_8~5M zLTLO5EK~K2TTQ;vn?EY(imiX=HbVarVK}P3*YG7rinbi0rLRjN7=B_89A$ zRm7bT{!~LApbIlH79~9d=)xZ+xEWz02_Z~*yE~X`-f7uFxE+fA;Rdz~XT~B?9n0+5 z#X`$S1cxbUq4XQjPbIumLWPXivC9>_(MBY+0pq0P^2z~Dj|;GKE6FF7y1jAGK_&#S z*RWYh*FPc`JRQsnn4NV%g1`wnf$Ur+PKZmvkh|_7D-cCaXf)K|kwnZ)uN0`JH=?5F zTrLQpfRt-eEmx=Aeqf^qmFgNr_0qPdC$%t?KE@0*#iluoJ8kgn85nt0(8N2627yov zSW-uF(nA6VNd)L^*a_^J(!NUtb$rFRW+f8@on!Ep@i>_TU1>l5R3L3HVzQfm#p=``F58RHL3GD0=s)3F&eCsS8Q#&cpWaHzrf2-l{1v0&;{z5 zV9!8>SJ^Lu1MW2lpoLo~W!M{bT}^G&uCITxrmO~t0NHOruEr&V=w6lwOb}O1>$aK&t{+Xj%~gqZf9b}^qR6qG)9C>?=zuv5Niw1UVsVEQNLTbx zQqnDs3^5(By(vx&UdF(XDh)sgt%?n1!Ya4S37i9iui?nd^|~ZW5ixamXf=U|2f?cJ zRp6!};Z@R{!h|~2A5Avf5-OU(ucY6KWLR)Kw=LN(ycTp|L7~{P5Id*?yBiA<%N=Iw zBUt7YaHD*I&xN;(NEW8S+-zfe065WEa7-JNRX?|cNFb+q8M}eZ$8>=aqRu|S=N;Lc zI3rPASFBB^nPQ&eKaDDLf^^idKTx7r4-6WoV}*X?bfEB^L@A^o$`>IYTA$QcWPRX_ zZ@|Zp6TF`Z?-65?5Y(j`45tUD7`VKVwM`B4$;>EWwrK9i{q9VGE^v6gusAW+qK6xd zH5Mqrbr&8Bn#V6d;3$@6Cp6{AFJf%Z$T|t_fCRi%ssr)axSW@5c9|gNIbg`RVH$H| z@0{UqLwn8-T8dvM%R+9=>b^{ENj_u0y|vZDdQ4Y4!dLM-b9L#GqM*e&0u zCF|8bKu(4su)TG#p;H|Qma^Zi20{*mqqK4|kRLj*(+`v?aYq@0;L&+8^eV6Cq3|OEerIc5_Q)2HCV<7fb1`<mj+qo-M+ld?yj4gK?0^ z4T%CjsmKqnzc1pp{{__?x^wL@XDZ zLW_@XZOCh5gl0T_!$%@`GV7?zB|NyNbaHBrlu;o{&%NUqN)x(C&8SICpn^?leR;i2 zwWt2AF>^Xagi*GLJ0jZKdsK)wk-^rZI$3<1D zViQYBdG8kZ8@Xvvu^0#xmQjJ)S_4KzAU@M5l(8J!)y8=YakGH~0b|39tw^LwMrJq= z8hfE9DE20J5Ez6Ae*@Wv;+i{RaZ1G0p>wK2@CJNH&K!E<4!k03v>~!c|6zE`>&gff z^dWQ>IIEm}of0(R>|NNTkwT`bNTsNxlmgQJ18+J10#NZbP(&-}s9J)Xyh*@0SYckp znuQS%OM7?f$pumI)7a5)0b`508k;{kOV;LFW1x-^q6MWm zC=$pvl7)-37xhq6wOVZN=gcVN4FCc}a$rY7M0#|Ge4xuw-;6v7e%9C>d6EY*IK>DS z@mQQ?Po*3P;U`Ssa=Q+Bm+C~D|6PnpSLwQWZV8995gw{r?*a%TN{XrZGt24y02qHw zW0$OYFnlsOJy)#GCnMA+{D=@W`bG>K?^(rGjt-Hl_Dx;x`1rhrSaknhG0n`gdeIdw z2W({}U!2*;8imJaG0x2`93Mg80ArG=;ndj_%K9`&j5&L5ugexKqJ^-^3VVirQYah@ zcn8w*Q9y)?WN2Y|IScD0R~Gsv-WfpX$nb&8xa6+>b&Ak8<~5KlegO(wXuOMDM}zTQxwlOTfV|9B`&Y%=Rf zwzkC46<UtZncZus<|u$w2QU~ea{x_O2+3m}scj|32Od0*Af>PhO|9Q3cOe?~ z5+njsE^jVYL9;NN^)En7SEFMM|DugM$qM9TP3aQC$bnJTjrUCZ`N26F%C1<%^B66V z9yr<3QHIO>XuT+zUsC2OG&;0L#@0h)&Y`65+L4z+ag{}fOK1wBu`08DfDChdI!@s@ z-&%BLo=%Z4DV2$QfQrzI7)U?$5F%e&lKH6f^eOtTEx{W?=uuXfWV!e_HBL;!?0P7A z4#6xr!O+Bs9drO~zTh>>{6S^WXgO6HZDr#h#iFw`mzJi30tC; zkD_G6^nu~XU|t=_>XAfAX1TZH8)$QeS3zT7XkkENjQ)o~0>Y7=qnT83^3Yj@=mfYS zvX#M(st^IYhi$p(VeE*ZU>@}k-Irv`#HpZFh)!6B&=WI(JCr(YTFA$O7@kzYnTXJdmu%CM&gOEQx`Y0P7 z?jDM?{5$84xX{@|u)BtL{{dHouNob_=SifM9SEa}lLBL8yoVHoQQ8r6VfT$?>oSKId1(~6_)j%{o zT$z42{Lv*P7%!p)c%`!@+R#!jVNBw4GS(wmK8lyH0H7;w;Mvsu9cOgsVLo-(<^ZBp zxVLL&zN)8NGRb=uO(1WDK{_o5gvCBNy-j04Vvzmd?z;na&f_CVqVRIuC1+H}j-$^r zW4j)Ha*+__KaZ3Nj#u%{x$2KGLtiAdM*ACg?9kbJZ$HML*aP#BHvV_ejOrM3D z?&KcNn(!MuEfJT9XyJ^N4H${sIQ$ImC)FsT{Oe}Poo|4}mz&K}9a0&AP!n^rRlI9- zs)z&lvrrfC(c;5H!ihX5z{8#BgtO(|)F~$eY53s}%5D@$Vn?7=(c5K8h;uT$MZ_eg zjq#t!4$Q$&K3%UNIICvTATd?SwhJKx&e%v&A#2;jx%mP!@dh|CE0{YUC`u355VzSz z5=e^I%W|xW2OuZi2_U(dB-|%q*R1h1QIfM1v%xs7IKwNo4*ZNY{#p7~CuL^ocX+1j zze*)C*71&<%&^efhU-~N=E+5^KemN^NzCF_OHS#LMozdOXvlKZ2qh*HO3Eo9z_X)v zc7=!YGlq+D*&UgDMr;`eQI#B!>=Ox!ftF0Dk{B0w$=QZj6`^Au)0KoW{Eah#vMz*P zUI)K&3z{AJONQ;jLO$i58WD;@kV{{uVDVsGu<#9PJc1;qf~0ijLbFwrV1n}VnQk4vhqY_ii|lUYj~49EUw=! z4@?JX707nB4Wl_#0u%F`qPYy*_s0~Xk3>dAonx<(R$l~89hI`nogqMr#d_bAg+dt< zGo21FpYp5NE0{;$LrDL%r8N~hCz+tg&I+4GOpKLM)5VsPHqsWgf;Er&(YL|l(jKlw z!HMx4VsMT}pnEVdk2oIC%V{Meazl;RJ_JJkAnRyI)y<}G4jeA>jD+Q7{@9;RtGSS3 zqb;tUgxjqmmL$myE6ju2GU>yQlb|?)RgKfhr>aH0o`}Y4@dG&@XsPZ>VRuJHv?7rh zBa`(2-b4UMM7U8Y=sU1E5q7l2Kybr4hkHe3Eb!JiCQB+=;HBaXznEL6)4E8kcMRN- zFdN9Ifj^lc&u3xf0vqLc4c)4sigPMl=nni#f%0XZ#LlZ4gFL3>@D!8J5j>tT6C;W`9P_2)rte+HGiIB|_C=%kjg_$ltsq*y|abqxCc%q=d-ZD0?+=QjONLX{18iY0^sbBp{3;|uZ8M^?bjlEq4BT-AE224(o zYSYE>(sW-<3`%87Q3N~5aSu$o#z5T6h5k`P@iJqF#i#U2^C3en$8yr(R0|pPdm{L{o>W}I`r#M<-fd-O= zX85i_xD-XgN>%rSp~;+FQd8P22A<q3R+fqv_om^TAt_5|go39ypsgf` z(=NzRQm9e~XpB^KK790?WvgPSQ^F*Q3R6cb2G(viWs(m1{ zVA=sXh#|zhP-!LAiICnYvt7Y~6j+lewba6TpMe2dACv`6#T@AgAjMB+a<+6vzd8G~ zI6r~I{*%+EvT8rAxYeB#{vf`7n>PdsJ^5iOm`w;p8;Q#T)ZQLv5~TA`qTMG*Ssz6TQkKF)#q3HNb29vhNVQ)Fc> zQwUD)C6FZnzY4F3qT@GJ>Y4RH58oUdnkPSy-s@CfP^5Rae#C)f{ zhURFGTuTN6O*q-Jx2!~g^171s92lc{fHbH>7!cM3L0OlRAD_39+)h-TM7hEWc%d=H zg60J?=a<@G7b#PkRNB*PGcKeBnehd*98woYWe7uVC0}@puXMJQg+H>H8xWR#jy?=%T>HDMa)M&M0EBj4YY< z6e)t6#ef6U2tGxjW5G3|pSb>&ffV$bOD0{1LZJOI0a6v0ac^QPpQBW}%X}7*gkEv|DIDQV8nMoC)kVSAQ|kV!D622}G23vQbUG~ST3Ry;$P z&T?^8rqxq*Cp^@nPW&YVaF`$uCjL$mNeoP76@nt1XC^1=mL7SybwNI<3d%2U6T<97co?Up$+hkfu7Qr zL|PJ*M%_i(HGLA_O@a93GjkQQQ<|KdE)^GYB&j0TilIZ{AhTfr>+(beCvp6d{Ddok zTC$TWmeQ;V=*4|Ri?XJ*l*~x1=49X!XQ9c0kx0)zl((KuGnCMkXCoJYaSj*SQY*G7 z@N{P^N!x}>szVGT&kF^XODP_-%7G=xo7S=RS>2Wv1Ic(+1w>RqF>raDPTxnZ-I9n! z&s*m)@@l%Jd5W{sV=*&fTh!bqQ86i*8%T9UlBwQEn;)4MWF;^`L$kSU1~4uja>GoD z9f~KD1kGQ0(p^Juq8eoNY0wcCc}eCka4g+U_tuGH7PXxSYSZQ1P;)jA5rO+=}E3E|<-fAf)UO2^--W(t40F zFEJHus-$!6g&&cFiaWg?au)^#lw^&a%=!*FPmM8>k$c&D49B|sB*srz6K|kuqIap|qpxGE~lHo)_Uph_bA%v}F z8r|i3v(~EP#N{wH4QZ_wpw=q$)5QnH`xt=o0_H%H>6~C@_UMTvwZ5t-L`3rZDl^os zyR0V7YK5pvq+C&XX);KlM46W2%6pa!Q8>c-H{WA>z~+8R{dA-5F# zAuYh38Ow!sxTeZ1mJ8Wn4=25fM9h(a3#=Ty#Zo0q*L;Jwp&`_R!=7-(aLT2|gYK$~ z<5d;!m4l$#!mzf2?Yab$ZPPtD3*o{w#U~eV)darK1X5m{nSt@~7qe3Xi!-D`?z+_Z z#67epc@^!9Y5DoNO1tww@?ds85mn~k!@j6lAJrjvsGDVaB_E_b3VbL|PTKW$Xi!oD zyd#3Z8NA=aP7ZNYU_gh5)#K1Cpn$(T((QY4O?5!HU|jr2L}v1N#07Q#U6JTCB-lWO=hkJtF{WpUH+YTV3)Wct^(39iHL!dd1lab24xv;^K61A*oEy&6oVQ zGjaztuDqHkFU}CL(t`EOZA&2uwOOV5Akf99BcRp7Oc9ichy`*SzcT@8j@^BCa>rdq zwBpEAsfZWbol+XPFFc0>5OXB$X>E7xgURvZSJV#JRptmt8-DPvW0{s!91WE2h%<5G zzoU0z+U{1Qj-cfm;sezGt9jpP-j9FijZgf-8=d$C2*lM*{M~o{)x`h*DDYw4j~o#* z@TS78g^|J^6#ii7)xr%d*|Sf|^L~vKZZ6!6dV8eaP+k=&JF;uNA$^0qRn(620Q!o% zVVJ4-LxN)7P+Y|^H|Dpn;$Bo78hSnt0U1!?NL)LYLJsUtvc8dWF8~e=y_yHsSJ!bx zSnO2Yke1Qyiu8!XMTW2^4-0ux_(?ao-Jm+0Z$~R~i~JCYJ%!&M0*HY>#$L)cd2^yo z4Y0>!H^5_sZx+63{HWx}rJjNxiEHQ1q1F?*uqn(X+h7*jp?d@SR`#+JSRRZdE%|+6q5h*pF)~X7F<4X)8tjP*Ye;YKF3#6*gLjGEuu2U`|;Io~xH?d!vWP z4|`xm_Oc~jdR<0u<{|diU-?Aw^so=rqa+S;sT;1*zni;>`5Qi9s|KP z7lQ+AOekL0^g*E}k}3!JAs33TGPonERK*#;iN6Q~d(Lmee!BSYi9kJ2W`PVGzbUjo zl`SY{3p{FU$R>BiHPFkR|IPw-#~S$i=1Z9W8^>qn#y_l@|BfqC{e*BB|2-%o>?hcI z{}5}$Bj_ved}>X+a9M$<$QXtvrPb)8!gRLVJF^AHvjvmcf_t(BKOGkkAJL_T7=*Ae z${I#mFxCx6uZpw;^*{#H@a3xlbxpQH)b@3;74>*Dl&h3VWr2|2NXLS2Wtt4FX9^0l z*#Z%l7=|!gTp&}pV?mMydT*v+=)-XVRgSRZRT~<^hHCwnV$dXl$b!{ifpB_Ua9_4b zDK5CC>1Th}$5jv+C)Q$dAQ*)$!nSd6=x5^s3KpHTD>mQaaydmq@F~!#zNkz_Si|I& zp5ZnNB5Z~}5ErnCNOs)h=i(Z~S5)7XazP)yf;4a5*(NJ-0TC9n zcU>6j@5G>q-oMKhd@@^bJX`QjvjzV!TX17sKqp7Gs*EZucrC6$JW^EQnBU179J9#7 zHJcuSl&O?(%r(w?p-JRyJOnLJuNgG`^WXo$fqpRtP15#FZHhfOE*axBkBfbEaO8j63QTf`QdXQm7OjfYI)&fJ7Tl37_?ftXLlRNF<{=T`{}_WNdRYgdkk!3~ z--??M##gche;yYQ=tNvV!pWQ%^P!+Hm#Iq><^LP`UTAr1YJ_0CCR zK}sDE;eQ*~;E=L4_GEpTp_6eF0{yRX0Y@ZwT$g$MTnw61Fd7$d0Dba*eN+n>!W$4j zcmF5uog*bm*KWT^#LvW_ck>WsjBJ3PlxIZ~Dn6QNX-?-(HkB4Ys^C{jy%VQnd}RED z5cbe!w&01lU^lD>_C>74$QahUc>)6=5y`0-ClnNZH7=n2`(Ru^Ch|1oavAh06jFvi zRfS)q%Gde9sFSK9GDIjZ$5n{iZ^s4KM6c8=Up2jm_Ge?9P%xBT-wct{{Yb9~>mMVe zYo29#ydnam{`&}$mV`6wvD}UCodk(P>Sv$xO0|_T4P;DlQ$^NMV>i$;`^qB9Sk@4r zhs5L=({LOfYw3fJ{m2Mox6XDP$1{K?6p>!}%P%;D(OHt6~{|&1{Fx06j!AucD)@^L#=SDuTM8FvZubMpUzK#Fsp^sXLAJ=VG z;>Y#NR>DybY2qMY2va!m2Z;1giaSy?qsdBlFD96Xry5-o%~Eqn(U3tKhwr9`gjA#( zeuPNYFhxf${`)0*H`oIuff$N)A=60LB#F#0OZ>$8I>KBm{sjKZ%=%XHDAnq$)iHMP z0`0;05>~ku>hHNH?yQgcyMZ1^eNt%MKzr8zO)DYVr0$(@LCWAs8xpBHunOx7^?gT1 zFnK~^iE$v^uZ>_bq3DXE`d|1jGboJ4Cx2okWI37qZ(50s^WM0C*dE`q6uakw=1zWAdFA5bmWgAK&PK5Qj6vA(l>!*Zn$`z|ZtV99ARdLb7Iu8GsU5c#oQKgv$V zXp^mdXWl@2iS=W>e%;SxyZ4iJowtR;$J>Z}VcKmzcT!V@ kDeK-7)Fb3)c+BdUc=g+n>o*Ij01Qz0;;-+$@bTaMzu7UkQ~&?~ literal 0 HcmV?d00001 diff --git a/sources/GAINSPACE b/sources/GAINSPACE new file mode 100644 index 00000000..b9950466 --- /dev/null +++ b/sources/GAINSPACE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "16-May-90 18:05:30" |{DSK}local>lde>lispcore>sources>GAINSPACE.;2| 12014 |changes| |to:| (VARS GAINSPACECOMS) |previous| |date:| " 3-Dec-86 22:18:00" |{DSK}local>lde>lispcore>sources>GAINSPACE.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT GAINSPACECOMS) (RPAQQ GAINSPACECOMS ((DECLARE\: DOEVAL@COMPILE DONTCOPY (RECORDS GAINSPACE) (GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST SMASHPROPSLST1 DWIMWAIT ARCHIVELST LASTHISTORY ARCHIVEFLG LISPXCOMS LISPXHISTORY EDITHISTORY)) (FNS GAINSPACE ERASEPROPS PURGEHISTORY PURGEHISTORY1 PURGEHISTORY2) (VARS SMASHPROPSMENU (SMASHPROPSLST)) (ADDVARS (GAINSPACEFORMS ((CAR LISPXHISTORY) "purge history lists" (PURGEHISTORY RESPONSE) ((Y "es") (N "o") (E . "verything"))) (T "discard definitions on property lists" (SETQ SMASHPROPSLST1 (CONS 'EXPR (CONS 'CODE (CONS 'SUBR SMASHPROPSLST1))) )) (T "discard old values of variables" (SETQ SMASHPROPSLST1 (CONS 'VALUE SMASHPROPSLST1 ))) (T "erase properties" (ERASEPROPS RESPONSE) ((Y "es" EXPLAINSTRING "Yes - you will be asked which properties are to be erased") (N "o") (A "ll" CONFIRMFLG T EXPLAINSTRING "All - all properties on mentioned on SMASHPROPSMENU") (E "dit " EXPLAINSTRING "Edit - you will be allowed to edit a list of property names"))) (CLISPARRAY "erase CLISP translations" (CLRHASH CLISPARRAY)) (CHANGESARRAY "erase changes array" (CLRHASH CHANGESARRAY)) (SYSHASHARRAY "erase system hash array" (CLRHASH)) ((GETPROP 'EDIT 'LASTVALUE) "discard context of last edit" (REMPROP 'EDIT 'LASTVALUE)) (GREETHIST "discard information saved for undoing your greeting" (SETQ GREETHIST )))))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (RECORD GAINSPACE (PRECHECK MESSAGE FORM KEYLST) (SYSTEM)) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GAINSPACEFORMS SMASHPROPSMENU SMASHPROPSLST SMASHPROPSLST1 DWIMWAIT ARCHIVELST LASTHISTORY ARCHIVEFLG LISPXCOMS LISPXHISTORY EDITHISTORY) ) ) (DEFINEQ (gainspace (lambda nil (* |wt:| 30-jul-77 13 35) (setq smashpropslst1 nil) (mapc gainspaceforms (function (lambda (x) (prog (response) (and (neq (position t) 0) (terpri t)) (ersetq (and (eval (|fetch| (gainspace precheck) |of| x)) (neq (setq response (askuser dwimwait 'n (list (|fetch| (gainspace message) |of| x)) (|fetch| (gainspace keylst) |of| x) t)) 'n) (eval (|fetch| (gainspace form) |of| x))))))) ) (cond (smashpropslst1 (terpri t) (prin1 "mapatoms called to erase the indicated properties..." t) (mapatoms (function (lambda (atm) (remproplist atm smashpropslst1)))) (mapc smashpropslst1 (function (lambda (x) (and (listp x) (eval x))))))) '|done|)) (eraseprops (lambda (response) (* |wt:| 30-jul-77 12 43) (setq smashpropslst1 (union smashpropslst1 smashpropslst)) (* |smashpropslst| |lets| |user| |prespecify| |properties| |to| |always| |be|  |smashed,| |and| |not| |to| |ask| |him.|) (selectq response (y (terpri t) (prin1 "indicate which ones: " t) (mapc smashpropsmenu (function (lambda (x) (and (some (cdr x) (function (lambda (x) (and (litatom x) (not (memb x smashpropslst1)) )))) (eq (askuser nil nil (list (car x)) nil t) 'y) (setq smashpropslst1 (union (cdr x) smashpropslst1))))))) ((a e) (setq smashpropslst1 (mapconc smashpropsmenu (function (lambda (x) (append (cdr x)))))) (and (eq response 'e) (edite (sort smashpropslst1)))) (help)))) (purgehistory (lambda (type) (* |wt:| "14-NOV-78 02:03") (resetvars (archiveflg) (selectq type (e (setq archiveflg t)) (y (setq type (askuser nil nil "purge everything, or just the properties, e.g. SIDE, LISPXPRINT, etc. ? " '((y "es - everything" return t) (n "o - just the properties" return 'nil) (e "verything" return t) (j "ust the properties" return 'nil)) t)) (terpri t) (setq archiveflg (eq (askuser nil nil "ARCHIVELST and named commands too ? " nil t) 'y))) (help)) (purgehistory1 lispxhistory type) (purgehistory1 edithistory type) (purgehistory1 lasthistory type) (cond (archiveflg (purgehistory1 archivelst type) (mapc lispxcoms (function (lambda (com) (and (litatom com) (cond (type (remprop com '*history*)) (t (purgehistory2 (caddr (getprop com '*history*)))))) ))))) (return)))) (purgehistory1 (lambda (lst flg) (* dd\: "26-Oct-81 12:48") (cond ((nlistp lst)) (flg (rplaca lst nil)) ((eq lst edithistory) (mapc (car lst) (function (lambda (entry) (* caddr |of| |the| |entry| |is| |used| |for| |saving| |side| |information|  |on| |the| |edito| |history| |list.| |however,| |can't| |just| |rplacd| cdr  |because| |that| |node| |is| |reused| |by| |historysave.|) (rplnode (cddr entry) (constant (character (charcode bell)))))))) (t (mapc (car lst) (function purgehistory2)))))) (purgehistory2 (lambda (entry) (* |wt:| 2-dec-75 15 46) (prog (tem) (cond ((setq tem (listget1 entry '*group*)) (rplacd (cddr entry) (list '*group* tem '*history* (listget1 entry '*history*))) (mapc tem (function purgehistory2))) (t (rplacd (cddr entry) nil)))))) ) (RPAQQ SMASHPROPSMENU (("old values of variables" VALUE) ("function definitions on property lists" EXPR CODE) ("advice information" ADVISED ADVICE READVICE (SETQ ADVISEDFNS NIL)) ("filemaps" FILEMAP) ("clisp information (warning: this will disable clisp!)" ACCESSFN BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS I.S.OPR I.S.TYPE LISPFN SETFN UNARYOP) ("compiler information (warning: this will disable the compiler!)" AMAC BLKLIBRARYDEF CROPS CTYPE GLOBALVAR MACRO MAKE OPD UBOX) ("definitions of named history commands" *HISTORY*) ("context of edits exited via save command" EDIT-SAVE))) (RPAQQ SMASHPROPSLST NIL) (ADDTOVAR GAINSPACEFORMS ((CAR LISPXHISTORY) "purge history lists" (PURGEHISTORY RESPONSE) ((Y "es") (N "o") (E . "verything"))) (T "discard definitions on property lists" (SETQ SMASHPROPSLST1 (CONS 'EXPR (CONS 'CODE (CONS 'SUBR SMASHPROPSLST1)))) ) (T "discard old values of variables" (SETQ SMASHPROPSLST1 (CONS 'VALUE SMASHPROPSLST1))) (T "erase properties" (ERASEPROPS RESPONSE) ((Y "es" EXPLAINSTRING "Yes - you will be asked which properties are to be erased") (N "o") (A "ll" CONFIRMFLG T EXPLAINSTRING "All - all properties on mentioned on SMASHPROPSMENU") (E "dit " EXPLAINSTRING "Edit - you will be allowed to edit a list of property names"))) (CLISPARRAY "erase CLISP translations" (CLRHASH CLISPARRAY)) (CHANGESARRAY "erase changes array" (CLRHASH CHANGESARRAY)) (SYSHASHARRAY "erase system hash array" (CLRHASH)) ((GETPROP 'EDIT 'LASTVALUE) "discard context of last edit" (REMPROP 'EDIT 'LASTVALUE)) (GREETHIST "discard information saved for undoing your greeting" (SETQ GREETHIST))) (PUTPROPS GAINSPACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (3185 9621 (GAINSPACE 3195 . 5141) (ERASEPROPS 5143 . 6702) (PURGEHISTORY 6704 . 8454) ( PURGEHISTORY1 8456 . 9189) (PURGEHISTORY2 9191 . 9619))))) STOP \ No newline at end of file diff --git a/sources/HARDCOPY b/sources/HARDCOPY new file mode 100644 index 00000000..5da0582f --- /dev/null +++ b/sources/HARDCOPY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 22:15:08"  {DSK}kaplan>Local>medley3.5>lispcore>sources>HARDCOPY.;6 104175 changes to%: (VARS HARDCOPYCOMS) (FNS PRINTERS.WHENSELECTEDFN PopUpWindowAndGetList) previous date%: "28-Jun-99 16:36:33" {DSK}kaplan>Local>medley3.5>lispcore>sources>HARDCOPY.;4) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT HARDCOPYCOMS) (RPAQQ HARDCOPYCOMS [(COMS (* ; "exported functionality") (FNS HARDCOPY.SOMEHOW HARDCOPYIMAGEW HARDCOPYIMAGEW.TOFILE HARDCOPYIMAGEW.TOPRINTER HARDCOPYREGION.TOFILE HARDCOPYREGION.TOPRINTER COPY.WINDOW.TO.BITMAP) (* ; "user interface jazz") (INITVARS (ChangeDefaultPrinter)) (FNS MakeMenuOfPrinters PRINTERS.WHENSELECTEDFN MakeMenuOfImageTypes GetNewPrinterFromUser PopUpWindowAndGetAtom PopUpWindowAndGetList NewPrinter GetPrinterName GetImageFile FetchDefaultPrinter) (* ; "filename diddlers") (FNS ExtensionForPrintFileType PRINTFILETYPE.FROM.EXTENSION)) (COMS (* ;  "Interface for PRINTERS and IMAGEFILES") (FNS DEFAULTPRINTER CAN.PRINT.DIRECTLY CONVERT.FILE.TO.TYPE.FOR.PRINTER EMPRESS HARDCOPYW LISTFILES1 PRINTER.BITMAPFILE PRINTER.BITMAPSCALE PRINTER.SCRATCH.FILE PRINTERPROP PRINTERSTATUS PRINTERTYPE PRINTERNAME PRINTFILEPROP PRINTFILETYPE \EXPECTED.FILE.TYPE SEND.FILE.TO.PRINTER) (FNS PRINTERDEVICE) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (PRINTERDEVICE 'LPT] (P (* ; "for backward compatibility") (MOVD? 'NILL 'PRINTERMODE)) (INITVARS (DEFAULTPRINTINGHOST) (DEFAULTPRINTERTYPE 'INTERPRESS) (EMPRESS.SCRATCH) (EMPRESS#SIDES T)) (GLOBALVARS DEFAULTPRINTINGHOST DEFAULTPRINTERTYPE EMPRESS#SIDES PRINTERTYPES PRINTFILETYPES)) (COMS (* ;  "Converting text files to imagestreams") (INITVARS (TEXTDEFAULTTABS (LIST 20320)) (TEXTDEFAULTPAGEREGION (CREATEREGION 2794 1905 18415 24765))) (* ;  "TEXTDEFAULTTABS Hack, mica equivalent of 8 inches") (GLOBALVARS TEXTDEFAULTTABS TEXTDEFAULTPAGEREGION) (FNS TEXTTOIMAGEFILE COPY.TEXT.TO.IMAGE)) (COMS (FNS \BLTSHADE.GENERICPRINTER) (* ;  "hack for printers that can't really BLTSHADE") ) [COMS (* ;  "stuff to support hardcopy streams on the display.") (FNS MAKEHARDCOPYSTREAM UNMAKEHARDCOPYSTREAM HARDCOPYSTREAMTYPE \CHARWIDTH.HDCPYDISPLAY \DSPFONT.HDCPYDISPLAY \DSPRIGHTMARGIN.HDCPYDISPLAY \DSPXPOSITION.HDCPYDISPLAY \DSPYPOSITION.HDCPYDISPLAY \STRINGWIDTH.HDCPYDISPLAY \STRINGWIDTH.HCPYDISPLAYAUX \HDCPYBLTCHAR \HDCPYDISPLAY.FIX.XPOS \HDCPYDISPLAY.FIX.YPOS \HDCPYDISPLAYINIT \HDCPYDSPPRINTCHAR \SLOWHDCPYBLTCHAR \CHANGECHARSET.HDCPYDISPLAY) [DECLARE%: DONTCOPY DOEVAL@COMPILE (EXPORT (CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35] (DECLARE%: DONTCOPY DOEVAL@COMPILE (EXPORT (FUNCTIONS \MICASTOPTS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HDCPYDISPLAYINIT] [COMS (* ;  "Stuff to support MICA-unit hardcopy streams on the display") (FNS MAKEHARDCOPYMODESTREAM UNMAKEHARDCOPYMODESTREAM \BLTSHADE.HCPYMODE \BITBLT.HCPYMODE \BRUSHCONVERT.HCPYMODE \CHANGECHARSET.HCPYMODE \DASHINGCONVERT.HCPYMODE \CHARWIDTH.HCPYMODE \DRAWLINE.HCPYMODE \DRAWCURVE.HCPYMODE \DRAWCIRCLE.HCPYMODE \DRAWELLIPSE.HCPYMODE \DSPFONT.HCPYMODE \DSPLEFTMARGIN.HCPYMODE \DSPLINEFEED.HCPYMODE \DSPRIGHTMARGIN.HCPYMODE \DSPSPACEFACTOR.HCPYMODE \DSPXPOSITION.HCPYMODE \DSPYPOSITION.HCPYMODE \MOVETO.HCPYMODE \FONTCREATE.HCPYMODE.PRESS \CREATECHARSET.HCPYMODE.PRESS \FONTCREATE.HCPYMODE.INTERPRESS \CREATECHARSET.HCPYMODE.INTERPRESS \STRINGWIDTH.HCPYMODE \HCPYMODEBLTCHAR \HCPYMODEDISPLAYINIT \HCPYMODEDSPPRINTCHAR \SLOWHCPYMODEBLTCHAR \SFFixY.HCPYMODE) [ADDVARS (IMAGESTREAMTYPES (PRESSDISPLAY (FONTCREATE \FONTCREATE.HCPYMODE.PRESS) (CREATECHARSET \CREATECHARSET.HCPYMODE.PRESS)) (INTERPRESSDISPLAY (FONTCREATE \FONTCREATE.HCPYMODE.INTERPRESS) (CREATECHARSET \CREATECHARSET.HCPYMODE.INTERPRESS] (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\HCPYMODEDISPLAYINIT] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (* ; "exported functionality") (DEFINEQ (HARDCOPY.SOMEHOW [LAMBDA (WINDOW FILE PRINTERTYPE IMAGETYPE) (* ; "Edited 26-Nov-96 15:59 by rmk:") (* ; "Edited 13-Nov-87 14:16 by Snow") (* ;; "Either run window's HARDCOPYFN or run HARDCOPYW. The HARDCOPYFN can be a list of the form (fn heading) where heading=TITLE means use the window's title, otherwise using the non-nil heading.") (LET ((HARDCOPYFN (WINDOWPROP WINDOW 'HARDCOPYFN)) HEADING) (ALLOW.BUTTON.EVENTS) (COND ((NULL HARDCOPYFN) (* ; "knows how to default") (HARDCOPYW WINDOW FILE NIL NIL NIL PRINTERTYPE)) (T (CL:WHEN (AND (LISTP HARDCOPYFN) (FNTYP (CAR HARDCOPYFN))) (SETQ HEADING (CADR HARDCOPYFN)) (CL:WHEN (EQ HEADING 'TITLE) (SETQ HEADING (WINDOWPROP WINDOW 'TITLE))) (SETQ HARDCOPYFN (CAR HARDCOPYFN))) (CL:WITH-OPEN-STREAM [IMAGESTREAM (OPENIMAGESTREAM FILE (OR IMAGETYPE PRINTERTYPE) (CL:WHEN HEADING `(HEADING ,HEADING))] (APPLY* HARDCOPYFN WINDOW IMAGESTREAM]) (HARDCOPYIMAGEW (LAMBDA (W) (* ; "Edited 26-Aug-87 14:08 by Snow") (* ;;; "hardcopy this window to the DEFAULTPRINTINGHOST") (HARDCOPY.SOMEHOW W)) ) (HARDCOPYIMAGEW.TOFILE [LAMBDA (W) (* ; "Edited 17-Jan-96 10:33 by rmk") (LET ((FILE&TYPE (GetImageFile W))) (if FILE&TYPE then (HARDCOPY.SOMEHOW W (CAR FILE&TYPE) (CDR FILE&TYPE]) (HARDCOPYIMAGEW.TOPRINTER [LAMBDA (W) (* ; "Edited 22-Apr-98 16:19 by rmk:") (* ; "Edited 11-Jul-90 13:55 by jds") (LET ((PRINTERCHOICE (GetPrinterName)) PRINTERTYPE IMAGETYPE) (SETQ PRINTERTYPE (PRINTERTYPE PRINTERCHOICE)) (COND (PRINTERCHOICE (HARDCOPY.SOMEHOW W (CONCAT "{LPT}" PRINTERCHOICE) PRINTERTYPE (OR IMAGETYPE (CAR (PRINTERPROP PRINTERTYPE 'CANPRINT)) PRINTERTYPE]) (HARDCOPYREGION.TOFILE (LAMBDA NIL (* ; "Edited 26-Aug-87 14:08 by Snow") (LET ((FILE&TYPE (GetImageFile))) (if FILE&TYPE then (PROG (REGION) (SPAWN.MOUSE) (PROMPTPRINT "Select a region") (SETQ REGION (GETREGION)) (CLRPROMPT) (HARDCOPYW REGION (CAR FILE&TYPE) NIL NIL NIL (CDR FILE&TYPE)))))) ) (HARDCOPYREGION.TOPRINTER (LAMBDA NIL (* ; "Edited 13-Jul-90 01:57 by jds") (LET ((PRINTERCHOICE (GetPrinterName)) PRINTERTYPE) (COND ((LISTP PRINTERCHOICE) (* ; "Got back a list, which is (TYPE NAME). Break it apart.") (SETQ PRINTERTYPE (CAR PRINTERCHOICE)) (SETQ PRINTERCHOICE (CADR PRINTERCHOICE))) (PRINTERCHOICE (* ; "Got back just a name.") (SETQ PRINTERTYPE (PRINTERTYPE PRINTERCHOICE)))) (COND (PRINTERCHOICE (PROG (REGION) (SPAWN.MOUSE) (PROMPTPRINT "Select a region") (SETQ REGION (GETREGION)) (CLRPROMPT) (HARDCOPYW REGION (PACK* (QUOTE {LPT}) PRINTERCHOICE) NIL NIL NIL (PRINTERTYPE PRINTERCHOICE))))))) ) (COPY.WINDOW.TO.BITMAP (LAMBDA (WINDOW) (* ; "Edited 26-Aug-87 14:09 by Snow") (* ;;; "copies contents of window (including title and border) into a bitmap") (COND ((OPENWP WINDOW) (PROG (REGION SCREEN LEFT BOTTOM WIDTH HEIGHT BITMAP) (SETQ REGION (WINDOWPROP WINDOW (QUOTE REGION))) (SETQ SCREEN (WINDOWPROP WINDOW (QUOTE SCREEN))) (SETQ LEFT (fetch (REGION LEFT) of REGION)) (SETQ BOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ WIDTH (fetch (REGION WIDTH) of REGION)) (SETQ HEIGHT (fetch (REGION HEIGHT) of REGION)) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT (BITSPERPIXEL WINDOW))) (.WHILE.TOP.DS. WINDOW (BITBLT (SCREENBITMAP SCREEN) LEFT BOTTOM BITMAP 0 0 WIDTH HEIGHT)) (RETURN BITMAP))) (T (BITMAPCOPY (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)))))) ) ) (* ; "user interface jazz") (RPAQ? ChangeDefaultPrinter ) (DEFINEQ (MakeMenuOfPrinters [LAMBDA (MENUTITLE) (* ; "Edited 29-May-93 14:18 by rmk:") (* ; "Edited 11-Jul-90 13:35 by jds") (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST)) (CREATE MENU ITEMS _ (APPEND (FOR P INSIDE DEFAULTPRINTINGHOST COLLECT (LIST (COND ((LISTP P) (IF (CADDR P) THEN (CONCAT (CADR P) " " (CADDR P)) ELSE (CADR P))) (T P)) (KWOTE P))) (LIST (LIST "Other..." (KWOTE 'OTHER) "You will be prompted for a printer"))) TITLE _ MENUTITLE WHENSELECTEDFN _ (FUNCTION PRINTERS.WHENSELECTEDFN]) (PRINTERS.WHENSELECTEDFN [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 16-Apr-2018 22:14 by rmk:") (DECLARE (GLOBALVARS ChangeDefaultPrinter)) (* ;; "Fix Menu so that it doesn't ask about changing the default unless you click with middle") (LET ((PRINTERCHOICE (CADR (CADR ITEM))) DEFAULTPRINTER) [COND ((EQ PRINTERCHOICE 'OTHER) (SETQ PRINTERCHOICE (GetNewPrinterFromUser] (CL:WHEN [AND PRINTERCHOICE (NEQ PRINTERCHOICE (SETQ DEFAULTPRINTER (FetchDefaultPrinter ] [NewPrinter PRINTERCHOICE (AND DEFAULTPRINTER (EQ BUTTON 'MIDDLE) (MENU (OR ChangeDefaultPrinter (SETQ ChangeDefaultPrinter (create MENU TITLE _ "Make this the new default?" ITEMS _ '(("Yes" T "Yes, make this the new default printer" ) ("No" NIL "No, don't change it" )) MENUROWS _ 1 CENTERFLG _ T]) PRINTERCHOICE]) (MakeMenuOfImageTypes (LAMBDA (MENUTITLE) (* ; "Edited 26-Aug-87 14:10 by Snow") (* ;;; "type selection; elements of \DISPLAYSTREAMTYPES are temporarily disallowed") (DECLARE (GLOBALVARS IMAGESTREAMTYPES)) (create MENU ITEMS _ (for IMAGETYPE in IMAGESTREAMTYPES bind IMAGETYPENAME collect (PROGN (SETQ IMAGETYPENAME (CAR IMAGETYPE)) (LIST (L-CASE IMAGETYPENAME T) (KWOTE IMAGETYPENAME))) when (AND (ASSOC (QUOTE OPENSTREAM) (CDR IMAGETYPE)) (NOT (FMEMB (CAR IMAGETYPE) \DISPLAYSTREAMTYPES)))) TITLE _ MENUTITLE)) ) (GetNewPrinterFromUser [LAMBDA (PROMPTSTRING) (* ; "Edited 7-Jun-93 15:33 by rmk:") (* ; "Edited 26-Aug-87 14:10 by Snow") (* ;; "Changed from PopUpWindowAndGetAtom, so user can enter PRINTERTYPE PRINTERNAME PREFERREDIMAGETYPE.") (PopUpWindowAndGetList (OR PROMPTSTRING "Printer (CR to abort): "]) (PopUpWindowAndGetAtom [LAMBDA (PROMPTSTRING CANDIDATE) (* ; "Edited 26-Aug-87 14:10 by Snow") (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) [LET* ((FONT (DEFAULTFONT)) [WIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH PROMPTSTRING FONT) (CL:IF CANDIDATE (IPLUS (STRINGWIDTH CANDIDATE FONT) (ITIMES 10 (CHARWIDTH (CHARCODE A) FONT))) (ITIMES 40 (CHARWIDTH (CHARCODE A) FONT)))] (PROMPTW (CREATEW [CREATEREGION (IMIN LASTMOUSEX (IDIFFERENCE SCREENWIDTH WIDTH)) LASTMOUSEY WIDTH (HEIGHTIFWINDOW (FONTPROP FONT 'HEIGHT] NIL NIL T))) (RESETSAVE (OPENW PROMPTW) (LIST (FUNCTION CLOSEW) PROMPTW)) (LET [(RESPONSE (PROMPTFORWORD PROMPTSTRING CANDIDATE NIL PROMPTW NIL NIL (CHARCODE (CR] (AND RESPONSE (PACK* RESPONSE])]) (PopUpWindowAndGetList [LAMBDA (PROMPTSTRING CANDIDATE) (* ; "Edited 16-Apr-2018 22:13 by rmk:") (* ; "Edited 26-Aug-87 14:10 by Snow") (* ;; "Makes both image-type part of LISTP printers show up in menu, so you can see the imagetype in multiple-type printers") (RESETLST (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) [LET* ((FONT (DEFAULTFONT)) [WIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH PROMPTSTRING FONT) (ITIMES 40 (CHARWIDTH (CHARCODE A) FONT] (PROMPTW (CREATEW [CREATEREGION (IMIN LASTMOUSEX (IDIFFERENCE SCREENWIDTH WIDTH)) LASTMOUSEY WIDTH (HEIGHTIFWINDOW (TIMES 2 (FONTPROP FONT 'HEIGHT] NIL NIL T))) (* ;; "Allow room for 2 lines so that TTYIN doesn't hang on page-full") (RESETSAVE (TTYDISPLAYSTREAM PROMPTW)) [RESETSAVE NIL `(CLOSEW ,PROMPTW] (LET ((RESPONSE (TTYIN PROMPTSTRING CANDIDATE NIL '(NORAISE READ) NIL NIL NIL TTYINWORDRDTBL))) (CL:IF (CDR RESPONSE) RESPONSE (CAR RESPONSE))])]) (NewPrinter (LAMBDA (PRINTER NEW-DEFAULT?) (* ; "Edited 11-Jul-90 13:48 by jds") (* ;;; "If Printer is unknown it will be added to DEFAULTPRINTINGHOST. In addition, if NEW-DEFAULT? is true the printer will be pushed to the head of DEFAULTPRINTINGHOST, thus making it the default printer.") (DECLARE (GLOBALVARS DEFAULTPRINTINGHOST)) (CL:WHEN (NOT (LISTP DEFAULTPRINTINGHOST)) (* ; "If DEFAULTPRINTINGHOST Is an atom ") (SETQ DEFAULTPRINTINGHOST (LIST DEFAULTPRINTINGHOST))) (LET* ((PRINTER-NAME (COND ((LISTP PRINTER) (CADR PRINTER)) (T PRINTER))) (MEMBER? (CL:MEMBER PRINTER-NAME DEFAULTPRINTINGHOST :TEST (QUOTE (LAMBDA (PRINTER ENTRY) (STRING-EQUAL PRINTER (CL:IF (LISTP ENTRY) (CADR ENTRY) ENTRY)))))) (ENTRY (CL:IF MEMBER? (CAR MEMBER?) PRINTER))) (CL:IF NEW-DEFAULT? (SETQ DEFAULTPRINTINGHOST (CONS ENTRY (REMOVE ENTRY DEFAULTPRINTINGHOST))) (CL:IF (NOT MEMBER?) (RPLACD (LAST DEFAULTPRINTINGHOST) (CONS ENTRY)))) DEFAULTPRINTINGHOST)) ) (GetPrinterName [LAMBDA NIL (* ; "Edited 29-May-93 13:58 by rmk:") (* ; "Edited 26-Aug-87 14:10 by Snow") (MENU (MakeMenuOfPrinters "Which printer?"]) (GetImageFile [LAMBDA (W) (* ; "Edited 27-Apr-98 16:44 by rmk:") (* ; "Edited 18-Jan-96 11:17 by ") (* ; "Edited 17-Jan-96 10:42 by rmk") (PROG (FILE PRINTFILETYPE FILETYPEMENU) (* ;; "Strip candidate version so overwrites must be explicitly indicated each time. Use previous file as candidate, and if no previous one, apply function associated with the window to the window and the extension associated with the defaultprinting host. Such a function on a TEDIT window, for example, could suggest the image-type file named after the underlying TEDIT file.") [SETQ FILE (PopUpWindowAndGetAtom "File name (Clear to abort): " (OR [AND (WINDOWPROP W 'HARDCOPYFILE) (PACKFILENAME 'VERSION NIL 'BODY (WINDOWPROP W 'HARDCOPYFILE] (AND (WINDOWPROP W 'HARDCOPYFILEFN) (APPLY* (WINDOWPROP W 'HARDCOPYFILEFN) W (CAR (MKLIST (CADR (ASSOC 'EXTENSION (CDR (ASSOC (OR (CADDR (LISTP (DEFAULTPRINTER ))) (PRINTERTYPE)) PRINTFILETYPES] (CL:UNLESS (AND FILE (SETQ FILE (OUTFILEP FILE))) (* ; "Keep directory etc for reuse") (RETURN)) (WINDOWPROP W 'HARDCOPYFILE FILE) (* ;  "Save previous input for next candidate") (SETQ FILETYPEMENU (MakeMenuOfImageTypes "File type?")) (COND ((SETQ PRINTFILETYPE (PRINTFILETYPE.FROM.EXTENSION FILE)) (RETURN (CONS FILE PRINTFILETYPE))) (T (SETQ PRINTFILETYPE (MENU FILETYPEMENU)) (COND ((NULL PRINTFILETYPE) (RETURN)) (T (RETURN (CONS FILE PRINTFILETYPE]) (FetchDefaultPrinter (LAMBDA NIL (* ; "Edited 26-Aug-87 14:11 by Snow") (LET ((P (DEFAULTPRINTER))) (COND ((LISTP P) (CADR P)) (T P)))) ) ) (* ; "filename diddlers") (DEFINEQ (ExtensionForPrintFileType (LAMBDA (TYPE) (* ; "Edited 26-Aug-87 14:11 by Snow") (DECLARE (GLOBALVARS PRINTFILETYPES)) (CAADR (ASSOC (QUOTE EXTENSION) (CDR (ASSOC TYPE PRINTFILETYPES))))) ) (PRINTFILETYPE.FROM.EXTENSION (LAMBDA (FILE) (* ; "Edited 26-Aug-87 14:11 by Snow") (* ; "return the imagestream type corresponding to the extension") (bind (EXT _ (U-CASE (FILENAMEFIELD FILE (QUOTE EXTENSION)))) for TYPE in PRINTFILETYPES when (FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION) (CDR TYPE)))) do (RETURN (CAR TYPE)))) ) ) (* ; "Interface for PRINTERS and IMAGEFILES") (DEFINEQ (DEFAULTPRINTER (LAMBDA NIL (* ; "Edited 26-Aug-87 14:11 by Snow") (COND ((LISTP DEFAULTPRINTINGHOST) (CAR DEFAULTPRINTINGHOST)) (T DEFAULTPRINTINGHOST))) ) (CAN.PRINT.DIRECTLY (LAMBDA (PRINTERTYPE FILETYPE) (* ; "Edited 26-Aug-87 14:11 by Snow") (FMEMB FILETYPE (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT)))) ) (CONVERT.FILE.TO.TYPE.FOR.PRINTER (LAMBDA (FILE FILETYPE PRINTERTYPE HEADING PRINTOPTIONS) (* ; "Edited 29-Dec-88 15:39 by jds") (* ;; "Convert FILE to the kind of hardcopy file (Interpress, Press, 4045HQ, etc) appropriate to PRINTERTYPE.") (SETQ FILETYPE (OR FILETYPE (QUOTE TEXT))) (PROG ((SCRATCH (CLOSEF (OPENFILE (PRINTER.SCRATCH.FILE FILE PRINTERTYPE) (QUOTE OUTPUT) (QUOTE NEW))))) (* ; "Doing the open & close gets us a guaranteed version number, so that all files are truly unique.") (APPLY* (OR (LISTGET (PRINTERPROP PRINTERTYPE (QUOTE CONVERSION)) FILETYPE) (for CANPRINT in (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT)) bind CONVERTER when (SETQ CONVERTER (LISTGET (PRINTFILEPROP CANPRINT (QUOTE CONVERSION)) FILETYPE)) do (RETURN CONVERTER)) (ERROR (CONCAT "Can't convert a " FILETYPE " for a " PRINTERTYPE " printer") (FULLNAME FILE))) FILE SCRATCH (LISTGET PRINTOPTIONS (QUOTE FONTS)) HEADING NIL PRINTOPTIONS) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (SCRATCH) (CLOSEF? SCRATCH) (DELFILE SCRATCH))) SCRATCH)) (RETURN SCRATCH))) ) (EMPRESS (LAMBDA (FILE %#COPIES HOST HEADING %#SIDES PRINTOPTIONS) (* ; "Edited 26-Aug-87 14:17 by Snow") (SEND.FILE.TO.PRINTER FILE HOST (NCONC (COND (HEADING (LIST (QUOTE HEADING) HEADING))) (COND (%#COPIES (LIST (QUOTE %#COPIES) %#COPIES))) (COND (%#SIDES (LIST (QUOTE %#SIDES) %#SIDES))) PRINTOPTIONS))) ) (HARDCOPYW (LAMBDA (WINDOW/BITMAP/REGION FILE HOST SCALEFACTOR ROTATION PRINTERTYPE HARDCOPYTITLE) (* ; "Edited 31-Aug-89 10:05 by jds") (* ;; "Makes a hard copy of a window, bitmap, or region of the screen.") (* ;; "") (* ;; "WINDOW/BITMAP/REGION can be a WINDOW, a REGION, a BITMAP, or NIL = select region. If FILE supplied, output goes there. If HOST supplied, it is printed. If neither FILE nor HOST supplied, default is to print; if HARDCOPYTITLE is supplied it will be used as the document title of the hardcopy file created. If it isn't, 'Window Image' is used.") (PROG (PRINTHOST BITMAP SCREENREGION REGION FULLFILE) (SETQ PRINTHOST HOST) (COND ((WINDOWP WINDOW/BITMAP/REGION) (SETQ BITMAP (COPY.WINDOW.TO.BITMAP WINDOW/BITMAP/REGION))) ((BITMAPP WINDOW/BITMAP/REGION) (SETQ BITMAP WINDOW/BITMAP/REGION)) ((type? REGION WINDOW/BITMAP/REGION) (SETQ BITMAP (SCREENBITMAP)) (SETQ REGION WINDOW/BITMAP/REGION)) (T (SETQ SCREENREGION (GETSCREENREGION)) (SETQ BITMAP (SCREENBITMAP (fetch (SCREENREGION SCREEN) of SCREENREGION))) (SETQ REGION (fetch (SCREENREGION REGION) of SCREENREGION)))) RETRY (COND (PRINTERTYPE (COND (PRINTHOST (COND ((NOT (EQ PRINTERTYPE (PRINTERTYPE PRINTHOST))) (ERROR PRINTHOST (CONCAT "not of printer type " PRINTERTYPE)) (GO RETRY)))) (FILE (* ; "don't need a PRINTHOST if you give a file")) ((SETQ PRINTHOST (find HOST inside DEFAULTPRINTINGHOST suchthat (EQ PRINTERTYPE (PRINTERTYPE HOST))))) (T (ERROR "Can't find a printing host in DEFAULTPRINTINGHOST that is of type " PRINTERTYPE) (GO RETRY)))) (PRINTHOST (SETQ PRINTERTYPE (PRINTERTYPE PRINTHOST))) (DEFAULTPRINTINGHOST (SETQ PRINTHOST (DEFAULTPRINTER)) (SETQ PRINTERTYPE (PRINTERTYPE PRINTHOST))) (FILE (COND ((NOT (SETQ PRINTERTYPE (PRINTFILETYPE FILE T))) (ERROR FILE "Can't tell what kind of print file to produce -- PRINTERTYPE, DEFAULTPRINTERTYPE, DEFAULTPRINTINGHOST all NIL") (GO RETRY)))) (T (ERROR "Can't tell where to send window image -- HOST, DEFAULTPRINTINGHOST are NIL") (GO RETRY))) (COND ((NOT SCALEFACTOR) (SETQ SCALEFACTOR (COND (REGION (PRINTER.BITMAPSCALE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) PRINTERTYPE PRINTHOST)) (T (PRINTER.BITMAPSCALE (fetch (BITMAP BITMAPWIDTH) of BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP) PRINTERTYPE PRINTHOST)))) (COND ((LISTP SCALEFACTOR) (SETQ ROTATION (CDR SCALEFACTOR)) (SETQ SCALEFACTOR (CAR SCALEFACTOR)))))) (SETQ FULLFILE (PRINTER.BITMAPFILE (OR FILE (PRINTER.SCRATCH.FILE)) PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION (OR HARDCOPYTITLE "Window Image"))) (COND ((OR HOST (NULL FILE)) (ADD.PROCESS (BQUOTE (PROGN ((\, (PRINTERPROP PRINTERTYPE (QUOTE SEND))) (QUOTE (\, (COND ((LISTP PRINTHOST) (CADR PRINTHOST)) (T PRINTHOST)))) (QUOTE (\, FULLFILE)) (QUOTE (DELETE (\, (NULL FILE)) DOCUMENT.NAME (\, (OR HARDCOPYTITLE "Window Image"))))) (\, (AND (NULL FILE) (BQUOTE (DELFILE (QUOTE (\, FULLFILE)))))))) (QUOTE NAME) (QUOTE HARDCOPYW)))) (RETURN (AND FILE FULLFILE)))) ) (LISTFILES1 [LAMBDA (FILE PRINTOPTIONS) (* ; "Edited 26-Aug-87 14:17 by Snow") (SEND.FILE.TO.PRINTER FILE NIL PRINTOPTIONS]) (PRINTER.BITMAPFILE (LAMBDA (FILE PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* ; "Edited 26-Aug-87 14:19 by Snow") (* ; "convert a bitmap into a file") (DECLARE (SPECVARS . T)) (EVAL (PRINTERPROP PRINTERTYPE (QUOTE BITMAPFILE)))) ) (PRINTER.BITMAPSCALE (LAMBDA (WIDTH HEIGHT PRINTERTYPE HOST) (* ; "Edited 26-Aug-87 14:19 by Snow") (* ; "could ask the host what size paper it has") (PROG NIL (RETURN (APPLY* (OR (PRINTERPROP PRINTERTYPE (QUOTE BITMAPSCALE)) (RETURN 1)) WIDTH HEIGHT HOST)))) ) (PRINTER.SCRATCH.FILE (LAMBDA (FULLFILE) (* ; "Edited 26-Aug-87 14:20 by Snow") (QUOTE {SCRATCH}PRINTER-SCRATCH-FILE))) (PRINTERPROP (LAMBDA (PRINTERTYPE PROP) (* ; "Edited 26-Aug-87 14:20 by Snow") (for X in PRINTERTYPES when (EQMEMB PRINTERTYPE (CAR X)) do (RETURN (CADR (ASSOC PROP (CDR X)))))) ) (PRINTERSTATUS (LAMBDA (PRINTER) (* ; "Edited 26-Aug-87 14:21 by Snow") (LET ((STATUSFN (PRINTERPROP (PRINTERTYPE PRINTER) (QUOTE STATUS)))) (AND STATUSFN (APPLY* STATUSFN PRINTER)))) ) (PRINTERTYPE [LAMBDA (HOST) (* ; "Edited 27-Apr-98 16:16 by rmk:") (* ;  "Edited 15-Feb-91 14:14 by gadener") (* ;; "Attempt to deduce the printer type of HOST.") (SELECTQ HOST ((NIL LPT) (SETQ HOST (DEFAULTPRINTER))) NIL) (COND [(CAR (LISTP HOST)) (* ;; "Is a pair (type hostname) or maybe a triple of the form (printertype hostname preferred-imagetype). Check that type is one we know about.") (LET ((TYPE (CAR HOST))) (COND ((for X in PRINTERTYPES thereis (EQMEMB TYPE (CAR X))) TYPE) (T (ERROR "Undefined printer-type:" TYPE] ((NULL HOST) DEFAULTPRINTERTYPE) ((GETPROP (MKATOM HOST) 'PRINTERTYPE)) ((GETPROP (SETQ HOST (OR (CANONICAL.HOSTNAME HOST) HOST)) 'PRINTERTYPE)) [(for TYPE in PRINTERTYPES bind FN when (AND (SETQ FN (CDR (ASSOC 'HOSTNAMEP TYPE))) (APPLY* (CAR FN) HOST)) do (* ;  "Try the predicates for each printer type for recognizing their own host names") (RETURN (CAAR TYPE] [(for PRINTER in (MKLIST DEFAULTPRINTINGHOST) do (* ;;  "Try looking for literal match before doing canonical hostname, cause that may be expensive.") (COND ((AND (LISTP PRINTER) (STRING-EQUAL (CADR PRINTER) HOST)) (RETURN (CAR PRINTER] [(for PRINTER in (MKLIST DEFAULTPRINTINGHOST) do (COND ((AND (LISTP PRINTER) (STRING-EQUAL (OR (CANONICAL.HOSTNAME (CADR PRINTER)) (CADR PRINTER)) HOST)) (RETURN (CAR PRINTER] (T DEFAULTPRINTERTYPE]) (PRINTERNAME (LAMBDA (PRINTER-SPEC) (* ; "Edited 26-Nov-86 13:51 by hdj") (* ;; "takes a printer-spec (in form (type printer-name) or just printer-name) and returns printer-name. returns nil for null arg.") (AND PRINTER-SPEC (if (LISTP PRINTER-SPEC) then (CADR PRINTER-SPEC) else PRINTER-SPEC))) ) (PRINTFILEPROP (LAMBDA (PRINTFILETYPE PROP) (* ; "Edited 26-Aug-87 14:22 by Snow") (for X in PRINTFILETYPES when (EQMEMB PRINTFILETYPE (CAR X)) do (RETURN (CADR (ASSOC PROP (CDR X)))))) ) (PRINTFILETYPE [LAMBDA (FILE DONTOPEN) (* ; "Edited 3-Mar-93 14:34 by rmk:") (* ; "Edited 22-Aug-92 14:27 by jds") (* ; "Edited 26-Aug-87 14:22 by Snow") (COND ((IMAGESTREAMP FILE) (IMAGESTREAMTYPE FILE)) (T (LET* [(HOST (FILENAMEFIELD FILE 'HOST)) (TYPE (GETFILEINFO FILE 'TYPE] (COND ((AND TYPE (ASSOC TYPE PRINTFILETYPES)) (* ;; "Type is in PRINTFILETYPES, so it's OK.") TYPE) ((PRINTFILETYPE.FROM.EXTENSION FILE)) [(NOT DONTOPEN) (RESETLST [COND ((STRINGP FILE) (* ;  "Yecch, OPENP of a string interprets string as a string stream!") (SETQ FILE (MKATOM FILE] [COND ((NOT (OPENP FILE 'INPUT)) (* ;  "Open file so testers don't have to repeatedly open and close it") (SETQ FILE (OPENSTREAM FILE 'INPUT)) (RESETSAVE NIL (LIST 'CLOSEF? FILE] [COND ((RANDACCESSP FILE) (for TYPE in PRINTFILETYPES when (CAR (NLSETQ (APPLY* (CADR (ASSOC 'TEST (CDR TYPE))) FILE))) do (RETURN (CAR TYPE])] ((EQ TYPE 'TEXT) (* ;; "This is AFTER the above clauses, so we catch PS files, which are type TEXT. Other formats might be lost as well....") TYPE]) (\EXPECTED.FILE.TYPE [LAMBDA (FILE) (* ; "Edited 28-Jun-99 16:36 by rmk:") (* ; "Edited 27-Oct-90 18:14 by nm") (* ;; "rmk: This is called by SEND.FILE.TO.PRINTER to somehow guess the TYPE parameter of the file in Maiko. I don't see the point of this. Eventually, the call to this function and even its definition should be removed, but nuking it is just as effective.") (AND NIL (EQ \MACHINETYPE \MAIKO) FileTypeConfirmFlg (LET [(HOST (UNPACKFILENAME.STRING FILE 'HOST] (AND (OR (STRING-EQUAL HOST "DSK") (STRING-EQUAL HOST "UNIX")) `((TYPE ,(\UFSGetPrintFileType FILE]) (SEND.FILE.TO.PRINTER [LAMBDA (FILE HOST PRINTOPTIONS) (* ; "Edited 21-Jan-93 11:34 by jds") (* ;; "Returns file name if successful, NIL if not. The RESETLST makes sure the scratch file, if any, is deleted.") (RESETLST [PROG (FULLFILE STRM FILETYPE PRINTERTYPE PFILE) [RESETSAVE NIL `(,(COND [(LISTGET PRINTOPTIONS 'DELETE) (FUNCTION (LAMBDA (STREAM) (CLOSEF? STREAM) (DELFILE (FULLNAME STREAM] (T (FUNCTION CLOSEF?))) ,(SETQ STRM (if (AND (STREAMP FILE) (OPENP FILE 'INPUT)) then (* ;; "Don't re-open it if it was previously open. (Some gibberish here about %"cause caller (PRINTERDEVICE) really wants us to use the same stream, which has the BEINGPRINTED property.%")") FILE else (OPENSTREAM FILE 'INPUT 'OLD (  \EXPECTED.FILE.TYPE FILE] (* ;  "Do we need to convert the FILE ?") (SETQ FULLFILE (FULLNAME (SETQ PFILE STRM))) (* ;  "Do the FULLNAME on the open stream, as FULLNAME sometimes returns NIL on just a filename") (SETQ FILETYPE (PRINTFILETYPE STRM)) (* ;  "Find out what kind of file this is, so we can figure out how to print it.") RETRY [COND [[OR HOST (SETQ HOST (for X on PRINTOPTIONS by (CDDR X) when (MEMB (U-CASE (CAR X)) '(HOST SERVER)) do (RETURN (CADR X] (SETQ PRINTERTYPE (PRINTERTYPE HOST)) (COND ((CAN.PRINT.DIRECTLY PRINTERTYPE FILETYPE) (* ; "IS OK, NO CONVERSION") ) (T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER STRM FILETYPE PRINTERTYPE (LISTGET PRINTOPTIONS 'HEADING) PRINTOPTIONS] ((NULL DEFAULTPRINTINGHOST) (ERROR "DEFAULTPRINTINGHOST and HOST arg are NIL; don't know where to print " FULLFILE) (GO RETRY)) ([AND FILETYPE (for X inside (OR DEFAULTPRINTINGHOST '(NIL)) when (CAN.PRINT.DIRECTLY (SETQ PRINTERTYPE (PRINTERTYPE X)) FILETYPE) do (RETURN (SETQ HOST X] (* ; "no conversion necessary") ) (T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER STRM FILETYPE [SETQ PRINTERTYPE (PRINTERTYPE (SETQ HOST (  DEFAULTPRINTER ] (LISTGET PRINTOPTIONS 'HEADING) PRINTOPTIONS] (COND ([NLISTP (SETQ PFILE (CL:FUNCALL (OR (PRINTERPROP PRINTERTYPE 'SEND) (ERROR (CONCAT "Don't know how to send to a " PRINTERTYPE) HOST)) (COND ((LISTP HOST) (CADR HOST)) (T HOST)) PFILE (APPEND PRINTOPTIONS '(%#COPIES 1) (LIST 'DOCUMENT.NAME FULLFILE] (RETURN FULLFILE)) (T (LISPXPRIN1 (CDR PFILE) T) (LISPXTERPRI T) (RETURN NIL])]) ) (DEFINEQ (PRINTERDEVICE [LAMBDA (NAME) (* ; "Edited 5-Dec-96 11:23 by rmk:") (* ; "Edited 4-Dec-86 16:32 by hdj") (* ;; "This defines an LPT device. An LPT file is a file that gets sent to printer and deleted when it is closed. This must be defined on a CORE device only because we have no way of inheriting the previous CLOSEFILE function that this function is replacing but needs to call internally. We have \CORE.CLOSEFILE explicit in this code.") (LET ((DEV (\CREATECOREDEVICE NAME))) [replace (FDEV OPENFILE) of DEV with (FUNCTION (LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (LET ((STRM (\CORE.OPENFILE NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM))) (* ;; "Mark the original name of the printer on the stream. Unless the user overrides this by changing the PRINTERNAME property, SEND.FILE.TO.PRINTER in the close function will get the user's original spelling, without any case conversions that might otherwise be done by \CORE.OPENFILE. ") (STREAMPROP STRM 'PRINTERNAME (FILENAMEFIELD NAME 'NAME)) STRM] [replace (FDEV CLOSEFILE) of DEV with (FUNCTION (LAMBDA (STREAM) (LET [(SDEV (fetch (STREAM DEVICE) of STREAM)) (PRINTOPTIONS (STREAMPROP STREAM 'PRINTOPTIONS] (* ;;  "Get PRINTOPTIONS property before closing the stream, in case the closing throws them away") (* ;; "") (* ;; "If we could save away and get at the previous CLOSEFILE method (e.g. by an FDEVPROP), this could be replaced by the generic (FDEVOP (QUOTE CLOSEFILE) SDEV STREAM)") (COND [(AND (NOT RESETSTATE) (OPENP STREAM 'OUTPUT) (IGREATERP (GETEOFPTR STREAM) 0)) (* ;; "Close and send to printer only if open for output. If open for input, then we must already have started printing. Don't close until after getting EOF ptr.") (\CORE.CLOSEFILE STREAM) (replace (STREAM ACCESS) of STREAM with NIL) (* ;  "Hack, cause this is usually done later in the generic \CLOSEFILE.") (* ;; "The PRINTERNAME might be marked explicitly on the stream. Otherwise let SEND.FILE.TO.PRINTER choose the host if it is the generic printer LPT, or use the name in the devicename field.") (SEND.FILE.TO.PRINTER STREAM [IF (STREAMPROP STREAM 'PRINTERNAME) ELSEIF (NEQ 'LPT (fetch (FDEV DEVICENAME) of SDEV)) THEN (fetch (FDEV DEVICENAME) of SDEV) ELSE (LET ((NAME (fetch (STREAM FULLNAME) of STREAM)) POS POS2) (AND (SETQ POS (STRPOS "}" NAME)) (SETQ POS2 (STRPOS "." NAME (ADD1 POS))) (SUBATOM NAME (ADD1 POS) (SUB1 POS2] (APPEND '(DELETE T) PRINTOPTIONS '(HEADING T] (T (* ;; "Error while creating the file, if the user had wrapped a RESETLST/CLOSEF around his code. Presumably, he doesn't want the file printed") (\CORE.CLOSEFILE STREAM) (FDEVOP 'DELETEFILE SDEV STREAM SDEV T] (\DEFINEDEVICE NAME DEV) NAME]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (PRINTERDEVICE 'LPT) ) (* ; "for backward compatibility") (MOVD? 'NILL 'PRINTERMODE) (RPAQ? DEFAULTPRINTINGHOST ) (RPAQ? DEFAULTPRINTERTYPE 'INTERPRESS) (RPAQ? EMPRESS.SCRATCH ) (RPAQ? EMPRESS#SIDES T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTPRINTINGHOST DEFAULTPRINTERTYPE EMPRESS#SIDES PRINTERTYPES PRINTFILETYPES) ) (* ; "Converting text files to imagestreams") (RPAQ? TEXTDEFAULTTABS (LIST 20320)) (RPAQ? TEXTDEFAULTPAGEREGION (CREATEREGION 2794 1905 18415 24765)) (* ; "TEXTDEFAULTTABS Hack, mica equivalent of 8 inches") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TEXTDEFAULTTABS TEXTDEFAULTPAGEREGION) ) (DEFINEQ (TEXTTOIMAGEFILE [LAMBDA (FILE IMAGEFILE IMAGETYPE FONTS HEADING TABS OPTIONS) (* ; "Edited 26-Aug-87 14:23 by Snow") (* ;;; "Generic function for converting PSPOOL format text files into image files") (RESETLST [PROG (IMAGESTREAM INPUT-STREAM INPUT-FILENAME) (* ;  "FONTARRAY is an array of font-descriptors") [RESETSAVE [SETQ INPUT-STREAM (OPENSTREAM FILE 'INPUT 'OLD 8 '((SEQUENTIAL T] '(PROGN (CLOSEF? OLDVALUE] (SETQ INPUT-FILENAME (FULLNAME INPUT-STREAM)) (* ;; "Strip off the extension if we are generating the name from the INFILE, so that OPENIMAGESTREAM can pack on the appropriate extension") [RESETSAVE [SETQ IMAGESTREAM (OPENIMAGESTREAM (OR IMAGEFILE (PACKFILENAME 'EXTENSION NIL 'VERSION NIL 'BODY INPUT-FILENAME)) IMAGETYPE (APPEND [AND (NEQ HEADING T) (LIST 'HEADING (OR HEADING (CONCAT INPUT-FILENAME " " (GETFILEINFO INPUT-STREAM 'CREATIONDATE] (APPEND (LIST 'DOCUMENT.NAME INPUT-FILENAME 'TABS TABS 'FONTS FONTS) OPTIONS] '(AND RESETSTATE (DELFILE (CLOSEF? OLDVALUE] (* ; "Make \BIN return NIL on EOS") (COPY.TEXT.TO.IMAGE INPUT-STREAM IMAGESTREAM FONTS TABS) (RETURN (LIST (CLOSEF INPUT-STREAM) (CLOSEF IMAGESTREAM])]) (COPY.TEXT.TO.IMAGE [LAMBDA (INFILE IMAGESTREAM FONTS TABS) (* ; "Edited 8-Feb-96 12:06 by rmk") (* ; "Edited 10-Apr-95 21:23 by rmk:") (* ;; "Copy text to an image stream, obeying PSPOOL control characters") (LET* ((IMAGESTREAM (GETSTREAM IMAGESTREAM 'OUTPUT)) (RIGHTMAR (DSPRIGHTMARGIN NIL IMAGESTREAM)) (FONTARRAY (FONTMAPARRAY FONTS)) (MAXFONT (ARRAYSIZE FONTARRAY)) (INSTRM (GETSTREAM INFILE 'INPUT)) DEFAULTTAB C FC) (replace (STREAM ENDOFSTREAMOP) of INSTRM with (FUNCTION ZERO)) (bind (SHIFTEDCHARSET _ (UNFOLD (ACCESS-CHARSET INSTRM) 256)) do (COND ((AND [EQ 0 (LOGAND 255 (SETQ C (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET] (EOFP INSTRM)) (RETURN)) ((AND RIGHTMAR (> (DSPXPOSITION NIL IMAGESTREAM) RIGHTMAR)) (* ;  "Not to walk off the right edge of the paper") (TERPRI IMAGESTREAM))) (COND ([> C (CONSTANT (APPLY (FUNCTION MAX) (CHARCODE (^F CR LF ^L TAB NULL] (\OUTCHAR IMAGESTREAM C)) (T (SELCHARQ C (^F (* ; "Font shift") (* ;;  "For FX-XP-9 printer:SETXY interpress command to avoid printer's BUG(Take)") (DSPXPOSITION (IPLUS (DSPXPOSITION NIL IMAGESTREAM) 1) IMAGESTREAM) [SELCHARQ (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET)) (^T (* ; "tab to absolute pos.") (COND ((EQ 0 (SETQ FC (\NSIN INSTRM SHIFTEDCHARSET SHIFTEDCHARSET))) (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (\OUTCHAR IMAGESTREAM (CHARCODE ^T)) (AND (\EOFP INSTRM) (RETURN)) (\OUTCHAR IMAGESTREAM FC)) (T (* ;; "TEXTDEFAULTTABS is a hack, since it depends on the units of the stream. Should really be a property of the stream or imagetype, or defined in terms of standard scale") [SETQ FC (IF TABS THEN (OR (CAR (NTH TABS FC)) (ERROR "Undefined absolute tab number" FC)) ELSE (TIMES FC (OR DEFAULTTAB (SETQ DEFAULTTAB (TIMES 8 (CHARWIDTH (CHARCODE SPACE) (FONTCREATE (ELT FONTARRAY 1) NIL NIL NIL IMAGESTREAM] (DSPXPOSITION FC IMAGESTREAM)))) (NULL (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (AND (\EOFP INSTRM) (RETURN)) (\OUTCHAR IMAGESTREAM FC) (* ; "EOS after ^F") ) (COND ((AND (>= MAXFONT FC) (NEQ FC 0)) (DSPFONT (ELT FONTARRAY FC) IMAGESTREAM)) (T (\OUTCHAR IMAGESTREAM (CHARCODE ^F)) (\OUTCHAR IMAGESTREAM C]) (CR (* ;; "Assumes that CR and possibly following LF denote a single EOL, independent of the EOL convention and independent of whether the file was opened binary or text. Originally, this function tried to discriminate, treating an LF in a CR-mode file as a line-feed and a CR in an LF file as a carriage-return. But these formatting effects cannot be guaranteed across text-file transfers (which is all that it makes sense to print), so it is silly to take them seriously. Given that just this information can be lost in text-mode file transfers, we make adopt here the 99%% correct solution, which is to treat all instances of CR, CRLF, and LF as end-of-line.") (TERPRI IMAGESTREAM) (COND ((EQ (CHARCODE LF) (\PEEKBIN INSTRM T)) (BIN INSTRM)))) (TAB (OR (LET* [(LEFTMARGIN (DSPLEFTMARGIN NIL IMAGESTREAM)) (TAB.WIDTH (TIMES (CHARWIDTH (CHARCODE SPACE) IMAGESTREAM) 8)) (CURRENT.X (- (DSPXPOSITION NIL IMAGESTREAM) LEFTMARGIN)) (CURRENT.STOP (- CURRENT.X (REMAINDER CURRENT.X TAB.WIDTH] (NLSETQ (RELMOVETO (- (+ CURRENT.STOP TAB.WIDTH) CURRENT.X) 0 IMAGESTREAM))) (\OUTCHAR IMAGESTREAM C))) (LF (* ; "See comment at CR") (TERPRI IMAGESTREAM)) (NULL (AND (EOFP INSTRM) (RETURN)) (\OUTCHAR IMAGESTREAM C)) (\OUTCHAR IMAGESTREAM C]) ) (DEFINEQ (\BLTSHADE.GENERICPRINTER (LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION SHADESCALE) (* ; "Edited 26-Aug-87 14:23 by Snow") (PROG (FINALREGION SCRATCHBM BMWIDTH BMHEIGHT) (* ;; "do the clipping to reduce the size of the scratch bitmap created. This also keeps Press from doing the wrong thing.") (* ; "don't do anything if clipped region is empty") (OR (SETQ FINALREGION (INTERSECTREGIONS (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT) (DSPCLIPPINGREGION NIL STREAM))) (RETURN)) (AND CLIPPINGREGION (OR (SETQ FINALREGION (INTERSECTREGIONS FINALREGION CLIPPINGREGION)) (RETURN))) (COND ((ZEROP (SETQ BMWIDTH (FIXR (FQUOTIENT (fetch (REGION WIDTH) of FINALREGION) SHADESCALE)))) (RETURN))) (COND ((ZEROP (SETQ BMHEIGHT (FIXR (FQUOTIENT (fetch (REGION HEIGHT) of FINALREGION) SHADESCALE)))) (RETURN))) (SETQ SCRATCHBM (BITMAPCREATE BMWIDTH BMHEIGHT)) (\BLTSHADE.BITMAP TEXTURE SCRATCHBM 0 0 NIL NIL (QUOTE REPLACE)) (BITBLT SCRATCHBM 0 0 STREAM (fetch (REGION LEFT) of FINALREGION) (fetch (REGION BOTTOM) of FINALREGION) NIL NIL (QUOTE INPUT) OPERATION))) ) ) (* ; "hack for printers that can't really BLTSHADE") (* ; "stuff to support hardcopy streams on the display.") (DEFINEQ (MAKEHARDCOPYSTREAM (LAMBDA (DISPLAYSTREAM IMAGETYPE) (* ; "Edited 26-Aug-87 14:23 by Snow") (* ;;; "creates a hardcopy stream from a display stream.") (DECLARE (GLOBALVARS \HDCPYDISPLAYIMAGEOPS)) (PROG ((DS (COND ((DISPLAYSTREAMP DISPLAYSTREAM)) ((WINDOWP DISPLAYSTREAM) (WINDOWPROP DISPLAYSTREAM (QUOTE DSP))) ((NULL DISPLAYSTREAM) (DSPCREATE)) (T (\ILLEGAL.ARG DISPLAYSTREAM))))) (replace (STREAM IMAGEOPS) of DS with \HDCPYDISPLAYIMAGEOPS) (STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE) (OR IMAGETYPE (CAR (PRINTERPROP (PRINTERTYPE) (QUOTE CANPRINT))))) (* ; "set the bout fn to one that updates the mica fields and sets the position from them.") (replace (STREAM STRMBOUTFN) of DS with (FUNCTION \HDCPYDSPPRINTCHAR)) (replace (STREAM OUTCHARFN) of DS with (FUNCTION \HDCPYDSPPRINTCHAR)) (* ; "set the parameters that are different to initialize the mica defined fields.") (DSPFONT (DSPFONT NIL DS) DS) (DSPXPOSITION 0 DS) (DSPYPOSITION 0 DS) (DSPRIGHTMARGIN (DSPRIGHTMARGIN NIL DS) DS) (RETURN DS))) ) (UNMAKEHARDCOPYSTREAM (LAMBDA (DISPLAYSTREAM) (* ; "Edited 26-Aug-87 14:23 by Snow") (* ;;; "returns a hardcopy stream to a display stream.") (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS)) (PROG ((DS (COND ((DISPLAYSTREAMP DISPLAYSTREAM)) ((WINDOWP DISPLAYSTREAM) (WINDOWPROP DISPLAYSTREAM (QUOTE DSP))) (T (\ILLEGAL.ARG DISPLAYSTREAM))))) (COND ((FMEMB (QUOTE HARDCOPY) (IMAGESTREAMTYPE DS))) (T (RETURN DS))) (replace (STREAM IMAGEOPS) of DS with \DISPLAYIMAGEOPS) (STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE) NIL) (* ; "restore the bout fn") (replace (STREAM STRMBOUTFN) of DS with (FUNCTION \DSPPRINTCHAR)) (replace (STREAM OUTCHARFN) of DS with (FUNCTION \DSPPRINTCHAR)) (RETURN DS))) ) (HARDCOPYSTREAMTYPE (LAMBDA (IMAGESTREAM) (* ; "Edited 26-Aug-87 14:24 by Snow") (* ;;; "returns the type of a hard copy stream which is either PRESS or INTERPRESS.") (LET ((STREAM (\OUTSTREAMARG IMAGESTREAM T))) (AND STREAM (STREAMPROP STREAM (QUOTE HARDCOPYIMAGETYPE))))) ) (\CHARWIDTH.HDCPYDISPLAY (LAMBDA (STREAM CHARCODE) (* ; "Edited 26-Aug-87 14:24 by Snow") (* ; "gets the width of a character code in a hardcopy stream. Should be updated for spacefactor") (IQUOTIENT (IPLUS (\FGETCHARIMAGEWIDTH (FONTCREATE (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM)) NIL NIL NIL (STREAMPROP STREAM (QUOTE HARDCOPYIMAGETYPE))) CHARCODE) (CONSTANT IHALFMICASPERPT)) (CONSTANT IMICASPERPT))) ) (\DSPFONT.HDCPYDISPLAY (LAMBDA (HDCPYDSTREAM FONT) (* ; "Edited 12-Jan-88 16:18 by jds") (* ;; "changes the font of a hardcopy display stream. Does what the display does then puts the hardcopy widths where they can be found {FOR NOW USE THE DDCHARIMAGEWIDTHS FIELD}") (LET ((FD (AND FONT (FONTCREATE FONT NIL NIL NIL (STREAMPROP HDCPYDSTREAM (QUOTE HARDCOPYIMAGETYPE)))))) (PROG1 (\DSPFONT.DISPLAY HDCPYDSTREAM FD) (AND FD (PROG ((DD (fetch IMAGEDATA of HDCPYDSTREAM))) (* ; "For now, use a streamprop instead of a special field in the dispay data") (* ; "Scale widths to printer device units, so we don't have to fetch the constants to scale by for every char we print") (replace DDCHARIMAGEWIDTHS of DD with (PROG (W OLDWIDTH (SCALE (FONTPROP FD (QUOTE SCALE))) (CSINFO (\GETCHARSETINFO (fetch (STREAM CHARSET) of HDCPYDSTREAM) FD))) (* ;; "set linefeed from scaled height. This may be off by almost half a pixel per line but it is better than not doing so.") (freplace DDLINEFEED of DD with (IMINUS (FIXR (QUOTIENT (fetch \SFHeight of FD) SCALE)))) (COND ((EQP SCALE (CONSTANT MICASPERPT)) (RETURN (fetch (CHARSETINFO WIDTHS) of CSINFO)))) (SETQ W (\CREATECSINFOELEMENT)) (SETQ OLDWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO)) (SETQ SCALE (FQUOTIENT (CONSTANT MICASPERPT) SCALE)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH W I (FIXR (FTIMES (\FGETWIDTH OLDWIDTH I) SCALE)))) (RETURN W)))))))) ) (\DSPRIGHTMARGIN.HDCPYDISPLAY (LAMBDA (DISPLAYSTREAM XPOSITION) (* ; "Edited 26-Aug-87 14:25 by Snow") (* ;;; "Sets the right margin that determines when a cr is inserted by print for the hardcopy display stream.") (* ;; "mica right margin is kept accurately using 35.27778. Since the updating at each character is done with 35, this may lead to a small error.") (PROG1 (\DSPRIGHTMARGIN.DISPLAY DISPLAYSTREAM XPOSITION) (AND XPOSITION (replace (\DISPLAYDATA DDMICARIGHTMARGIN) of (fetch IMAGEDATA of DISPLAYSTREAM) with (FIX (FTIMES XPOSITION (CONSTANT MICASPERPT))))))) ) (\DSPXPOSITION.HDCPYDISPLAY (LAMBDA (HARDCOPYSTREAM XPOSITION) (* ; "Edited 26-Aug-87 14:25 by Snow") (* ; "updates the mica xposition too.") (PROG1 (\DSPXPOSITION.DISPLAY HARDCOPYSTREAM XPOSITION) (AND XPOSITION (\HDCPYDISPLAY.FIX.XPOS HARDCOPYSTREAM)))) ) (\DSPYPOSITION.HDCPYDISPLAY (LAMBDA (HARDCOPYSTREAM YPOSITION) (* ; "Edited 26-Aug-87 14:25 by Snow") (* ; "updates the mica xposition too.") (PROG1 (\DSPYPOSITION.DISPLAY HARDCOPYSTREAM YPOSITION) (AND YPOSITION (\HDCPYDISPLAY.FIX.YPOS HARDCOPYSTREAM)))) ) (\STRINGWIDTH.HDCPYDISPLAY (LAMBDA (STREAM STR RDTBL) (* ; "Edited 26-Aug-87 14:25 by Snow") (* ; "Returns the width of for the current font/spacefactor in hardcopy stream STREAM.") (LET ((HARDCOPYFD (FONTCREATE (ffetch (\DISPLAYDATA DDFONT) of (ffetch IMAGEDATA of STREAM)) NIL NIL NIL (STREAMPROP STREAM (QUOTE HARDCOPYIMAGETYPE))))) (IQUOTIENT (IPLUS (\STRINGWIDTH.GENERIC STR HARDCOPYFD RDTBL (\FGETCHARIMAGEWIDTH HARDCOPYFD (CHARCODE SPACE))) (CONSTANT IHALFMICASPERPT)) (CONSTANT IMICASPERPT)))) ) (\STRINGWIDTH.HCPYDISPLAYAUX (LAMBDA (STR FONT RDTBL SPACEWIDTH) (* ; "Edited 3-Apr-87 13:48 by jop") (* ;; "Returns the width of STR with SPACEWIDTH for the width of spaces. RDTBL has already been coerced, so no FLG is needed") (* ;; "This is cloned in \STRINGWIDTH.HCPYDISPLAYAUX by straight substitution -- (PUTDEF (QUOTE \STRINGWIDTH.HCPYDISPLAYAUX) (QUOTE FNS) (SUBLIS (QUOTE ((IMAGEWIDTHS . IMAGEWIDTHS) (\FGETIMAGEWIDTH . \FGETIMAGEWIDTH) (\FGETCHARIMAGEWIDTH . \FGETCHARIMAGEWIDTH))) (GETDEF (QUOTE \STRINGWIDTH.GENERIC))))") (* ;; "\MAPPNAME uses WIDTHSBASE CSET TOTALWIDTH FONT SPACEWIDTH free, so these become special in bytecompiler") (PROG NIL (COND ((LITATOM STR) (if RDTBL then (GO SLOW) else (RETURN (for C WIDTHSBASE CSET inatom STR sum (COND ((NEQ CSET (\CHARSET C)) (SETQ CSET (\CHARSET C)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO CSET FONT))))) (COND ((EQ C (CHARCODE SPACE)) SPACEWIDTH) (T (\FGETIMAGEWIDTH WIDTHSBASE (\CHAR8CODE C)))))))) ((STRINGP STR) (RETURN (LET ((TOTAL 0) ESC ESCWIDTH WIDTHSBASE CSET) (COND (RDTBL (* ; "Count delimiting quotes and internal escapes") (SETQ TOTAL (UNFOLD (\FGETCHARIMAGEWIDTH FONT (CHARCODE %")) 2)) (SETQ ESC (fetch (READTABLEP ESCAPECHAR) of RDTBL)) (SETQ ESCWIDTH (\FGETCHARIMAGEWIDTH FONT ESC)))) (for C instring STR do (COND ((NEQ (\CHARSET C) CSET) (* ; "Get the widths vector for this character set") (SETQ CSET (\CHARSET C)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO CSET FONT))))) (add TOTAL (COND ((EQ C (CHARCODE SPACE)) SPACEWIDTH) (T (IPLUS (\FGETIMAGEWIDTH WIDTHSBASE (\CHAR8CODE C)) (COND ((AND RDTBL (OR (EQ C (CHARCODE %")) (EQ C ESC))) (* ; "String char must be escaped") ESCWIDTH) (T 0))))))) TOTAL)))) SLOW (* ; "Do the general case here") (RETURN (LET ((TOTALWIDTH 0) WIDTHSBASE CSET (FONT FONT) (SPACEWIDTH SPACEWIDTH)) (DECLARE (SPECVARS TOTALWIDTH WIDTHSBASE CSET FONT SPACEWIDTH)) (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CC) (add TOTALWIDTH (COND ((EQ CC (CHARCODE SPACE)) SPACEWIDTH) ((EQ CSET (\CHARSET CC)) (\FGETIMAGEWIDTH WIDTHSBASE (\CHAR8CODE CC))) (T (SETQ CSET (\CHARSET CC)) (SETQ WIDTHSBASE (ffetch (CHARSETINFO IMAGEWIDTHS) of (\GETCHARSETINFO CSET FONT))) (\FGETIMAGEWIDTH WIDTHSBASE (\CHAR8CODE CC))))))) STR RDTBL RDTBL *PRINT-LEVEL* *PRINT-LENGTH*) TOTALWIDTH)))) ) (\HDCPYBLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 26-Aug-87 14:26 by Snow") (* ;; "puts a character on a hardcopy display stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") (* ; "knows about the representation of a DisplayStream.") (DECLARE (LOCALVARS . T)) (PROG (LOCAL1 RIGHT LEFT CURX (CHAR8CODE (\CHAR8CODE CHARCODE)) MICARIGHT) (COND ((NEQ (ffetch DDCHARSET of DISPLAYDATA) (\CHARSET CHARCODE)) (\CHANGECHARSET.HDCPYDISPLAY DISPLAYDATA (\CHARSET CHARCODE) DISPLAYSTREAM))) (COND ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) (RETURN (\SLOWHDCPYBLTCHAR CHARCODE DISPLAYSTREAM)))) CRLP (SETQ CURX (ffetch DDXPOSITION of DISPLAYDATA)) (COND ((IGREATERP (SETQ MICARIGHT (IPLUS (ffetch (\DISPLAYDATA DDMICAXPOS) of DISPLAYDATA) (\FGETWIDTH (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of DISPLAYDATA) CHAR8CODE))) (ffetch (\DISPLAYDATA DDMICARIGHTMARGIN) of DISPLAYDATA)) (* ; "would go past right margin, force a cr") (COND ((IGREATERP CURX (ffetch DDLeftMargin of DISPLAYDATA)) (* ; "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* ; "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP))))) (freplace (\DISPLAYDATA DDMICAXPOS) of DISPLAYDATA with MICARIGHT) (* ;; "update the display stream x position. Make sure that there is at least one point width for each character.") (freplace DDXPOSITION of DISPLAYDATA with (IMAX (ADD1 CURX) (IQUOTIENT (IPLUS MICARIGHT (CONSTANT IHALFMICASPERPT)) (CONSTANT IMICASPERPT)))) (* ; "transforms an x coordinate into the destination coordinate.") (SETQ CURX (IPLUS CURX (ffetch DDXOFFSET of DISPLAYDATA))) (SETQ RIGHT (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) (COND ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch DDClippingRight of DISPLAYDATA))) (* ; "character overlaps right edge of clipping region.") (SETQ RIGHT LOCAL1))) (SETQ LEFT (COND ((IGREATERP CURX (SETQ LOCAL1 (ffetch DDClippingLeft of DISPLAYDATA))) CURX) (T LOCAL1))) (RETURN (COND ((AND (ILESSP LEFT RIGHT) (NEQ (fetch PBTHEIGHT of (SETQ LOCAL1 (ffetch DDPILOTBBT of DISPLAYDATA))) 0)) (.WHILE.TOP.DS. DISPLAYSTREAM (freplace PBTDESTBIT of LOCAL1 with LEFT) (freplace PBTWIDTH of LOCAL1 with (IDIFFERENCE RIGHT LEFT)) (freplace PBTSOURCEBIT of LOCAL1 with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DISPLAYDATA) LEFT) CURX)) (\PILOTBITBLT LOCAL1 0)) T))))) ) (\HDCPYDISPLAY.FIX.XPOS (LAMBDA (HARDCOPYSTREAM) (* ; "Edited 26-Aug-87 14:26 by Snow") (* ;;; "updates the mica X position from the x position in the display stream. This is called whenever the X position changes in a hardcopy stream.") (PROG ((DD (fetch IMAGEDATA of HARDCOPYSTREAM))) (replace (\DISPLAYDATA DDMICAXPOS) of DD with (FIX (FTIMES (fetch (\DISPLAYDATA DDXPOSITION) of DD) (CONSTANT MICASPERPT)))))) ) (\HDCPYDISPLAY.FIX.YPOS (LAMBDA (HARDCOPYSTREAM) (* ; "Edited 26-Aug-87 14:26 by Snow") (* ;;; "updates the mica Y position from the Y position in the display stream. This is called whenever the Y position changes in a hardcopy stream.") (PROG ((DD (fetch IMAGEDATA of HARDCOPYSTREAM))) (replace (\DISPLAYDATA DDMICAYPOS) of DD with (FIX (FTIMES (fetch (\DISPLAYDATA DDYPOSITION) of DD) (CONSTANT MICASPERPT)))))) ) (\HDCPYDISPLAYINIT (LAMBDA NIL (* ; "Edited 26-Aug-87 14:26 by Snow") (* ;;; "Initializes global variables for the hardcopy Display device. This device appears to the user as an INTERPRESS or PRESS device meaning units in micas but outputs to the screen. Much of this code was borrowed from the display case.") (DECLARE (GLOBALVARS \HDCPYDISPLAYIMAGEOPS)) (SETQ \HDCPYDISPLAYIMAGEOPS (create IMAGEOPS using \DISPLAYIMAGEOPS IMAGETYPE _ (QUOTE (HARDCOPY DISPLAY)) IMFONT _ (FUNCTION \DSPFONT.HDCPYDISPLAY) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.HDCPYDISPLAY) IMXPOSITION _ (FUNCTION \DSPXPOSITION.HDCPYDISPLAY) IMYPOSITION _ (FUNCTION \DSPYPOSITION.HDCPYDISPLAY) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.HDCPYDISPLAY) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.HDCPYDISPLAY)))) ) (\HDCPYDSPPRINTCHAR (LAMBDA (STREAM CHARCODE) (* ; "Edited 26-Aug-87 14:27 by Snow") (* ;;; "displays a character on a hardcopy display stream. This uses a display font but updates the x position according to hardcopy widths.") (PROG ((DD (fetch IMAGEDATA of STREAM))) (\CHECKCARET STREAM) (RETURN (SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (PROG ((CC CHARCODE)) (add (fetch CHARPOSITION of STREAM) (IPLUS (COND ((IGREATERP CC 127) (* ; "META character") (\HDCPYBLTCHAR (CHARCODE %#) STREAM DD) (SETQ CC (LOGAND CC 127)) 1) (T 0)) (COND ((ILESSP CC 32) (* ; "CONTROL character") (\HDCPYBLTCHAR (CHARCODE ^) STREAM DD) (SETQ CC (LOGOR CC 64)) 1) (T 0)) (PROGN (\HDCPYBLTCHAR CC STREAM DD) 1))))) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF) (\DSPPRINTCR/LF CHARCODE STREAM) (replace CHARPOSITION of STREAM with 0)) (ESCAPE (\HDCPYBLTCHAR (CHARCODE $) STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)) (BELL (* ; "make switching of bits uninterruptable but allow interrupts between flashes.") (SELECTQ (MACHINETYPE) (DANDELION (PLAYTUNE (QUOTE ((880 . 2500))))) (FLASHWINDOW (WFROMDS STREAM)))) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (COND ((IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (fetch DDXPOSITION of DD) (ffetch DDLeftMargin of DD)) TABWIDTH))) DD) (ffetch DDRightMargin of DD)) (* ; "tab was past rightmargin, force cr.") (\DSPPRINTCR/LF (CHARCODE EOL) STREAM))) (* ; "return the number of spaces taken.") (add (fetch CHARPOSITION of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (PROGN (* ; "this case was copied from \DSCCOUT.") (\HDCPYBLTCHAR CHARCODE STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)))) (REAL.CCE (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) (\DSPPRINTCR/LF CHARCODE STREAM) (replace CHARPOSITION of STREAM with 0)) (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A) STREAM) STREAM) (* ; "line buffering routines have already taken care of backing up the position") 0) (PROGN (\HDCPYBLTCHAR CHARCODE STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT))))) ) (\SLOWHDCPYBLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 9-Nov-89 14:37 by gadener") (* ;;; "IS THIS CODE JUST GOING TO DUPLICATE AND GET OUT OF SYNC WITH \SLOWBLTCHAR? KBR 1-FEB-86. *") (* ;;; "THIS HAS BEEN SEPARATED OUT BUT HASN'T BEEN EDITTED TO DO CORRECT THING WRT UPDATING MICA FIELDS.") (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a hardcopy display stream.") (PROG (ROTATION (CHAR8CODE (\CHAR8CODE CHARCODE)) (DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM))) (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT (CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) PILOTBBT DESTBIT WIDTH SOURCEBIT) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) (COND ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ; "past RIGHT margin, force eol") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))))) (* ; "update the x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) (SETQ CURX (\DSPTRANSFORMX CURX DD)) (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) CURX)) (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) (\DSPTRANSFORMX NEWX DD))) (SETQ PILOTBBT (ffetch (\DISPLAYDATA DDPILOTBBT) of DD)) (COND ((AND (ILESSP LEFT RIGHT) (NEQ (ffetch (PILOTBBT PBTHEIGHT) of PILOTBBT) 0)) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination) of DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with DESTBIT) (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with WIDTH) (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with SOURCEBIT) (\PILOTBITBLT PILOTBBT 0)) T)))) (T (* ; "handle rotated fonts") (PROG (YPOS HEIGHTMOVED CSINFO) (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ ROTATION 90) (* ; "don't force CR for rotated fonts.") (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) (* ; "update the display stream x position.") (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO))) YPOS (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) (T (ERROR "Not implemented to rotate by other than 0, 90 or 270")))))))) ) (\CHANGECHARSET.HDCPYDISPLAY (LAMBDA (DISPLAYDATA CHARSET HDCPYDSTREAM) (* ; "Edited 26-Aug-87 14:27 by Snow") (* ;; "Called when the character set information cached in a display stream doesn't correspond to CHARSET Only sets those field that are different from the regular DISPLAY case and uses the regular display case to get the rest.") (\CHANGECHARSET.DISPLAY DISPLAYDATA CHARSET) (PROG ((FD (FONTCREATE (ffetch DDFONT of DISPLAYDATA) NIL NIL NIL (STREAMPROP HDCPYDSTREAM (QUOTE HARDCOPYIMAGETYPE))))) (* ; "For now, use a streamprop instead of a special field in the dispay data") (* ; "Scale widths to micas, so we don't have to fetch the constants to scale by for every char we print") (replace DDCHARIMAGEWIDTHS of DISPLAYDATA with (PROG (W OLDWIDTH (SCALE (FONTPROP FD (QUOTE SCALE))) (CSINFO (\GETCHARSETINFO CHARSET FD))) (SETQ OLDWIDTH (fetch (CHARSETINFO WIDTHS) of CSINFO)) (COND ((EQP SCALE (CONSTANT MICASPERPT)) (RETURN OLDWIDTH))) (SETQ W (\CREATECSINFOELEMENT)) (SETQ SCALE (FQUOTIENT (CONSTANT MICASPERPT) SCALE)) (for I from 0 to \MAXTHINCHAR do (\FSETWIDTH W I (FIXR (FTIMES (\FGETWIDTH OLDWIDTH I) SCALE)))) (RETURN W))))) ) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RPAQ MICASPERPT (FQUOTIENT 2540 72)) (RPAQQ IHALFMICASPERPT 17) (RPAQQ IMICASPERPT 35) (CONSTANTS (MICASPERPT (FQUOTIENT 2540 72)) (IHALFMICASPERPT 17) (IMICASPERPT 35)) ) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (* "FOLLOWING DEFINITIONS EXPORTED") (DEFMACRO \MICASTOPTS (MICAS) [COND ((NUMBERP MICAS) (QUOTIENT MICAS MICASPERPT)) (T `(QUOTIENT ,MICAS MICASPERPT]) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\HDCPYDISPLAYINIT) ) (* ; "Stuff to support MICA-unit hardcopy streams on the display") (DEFINEQ (MAKEHARDCOPYMODESTREAM (LAMBDA (DISPLAYSTREAM IMAGETYPE) (* ; "Edited 1-Apr-88 11:25 by jds") (* ;;; "Creates a hardcopy-mode display stream from a normal one. That stream operates in units of micas, but displays on the screen as usual.") (DECLARE (GLOBALVARS \HCPYMODEDISPLAYIMAGEOPS.PRESS \HCPYMODEDISPLAYIMAGEOPS.INTERPRESS)) (PROG ((DS (COND ((DISPLAYSTREAMP DISPLAYSTREAM)) ((WINDOWP DISPLAYSTREAM) (WINDOWPROP DISPLAYSTREAM (QUOTE DSP))) ((NULL DISPLAYSTREAM) (DSPCREATE)) (T (\ILLEGAL.ARG DISPLAYSTREAM))))) (SELECTQ (OR IMAGETYPE (SETQ IMAGETYPE (CAR (PRINTERPROP (PRINTERTYPE) (QUOTE CANPRINT))))) (PRESS (* ; "Give the stream PRESS-style imageops, so it will deal with press fonts right.") (replace (STREAM IMAGEOPS) of DS with \HCPYMODEDISPLAYIMAGEOPS.PRESS)) (INTERPRESS (* ; "Give the stream INTERPRESS-style operations, so it will deal with Interpress fonts right.") (replace (STREAM IMAGEOPS) of DS with \HCPYMODEDISPLAYIMAGEOPS.INTERPRESS)) NIL) (STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE) IMAGETYPE) (* ; "set the bout fn to one that updates the mica fields and sets the position from them.") (replace (STREAM STRMBOUTFN) of DS with (FUNCTION \HCPYMODEDSPPRINTCHAR)) (* ; "Set the character-printing functions for the stream to the hardcopy-mode ones.") (replace (STREAM OUTCHARFN) of DS with (FUNCTION \HCPYMODEDSPPRINTCHAR)) (* ;;; "set the parameters that are different to initialize the mica defined fields.") (DSPFONT (DSPFONT NIL DS) DS) (* ; "Hardcopy version of the current font...") (DSPXPOSITION 0 DS) (* ; "Reset the X and Y positions to 0") (DSPYPOSITION 0 DS) (STREAMPROP DS (QUOTE DSPRIGHTMARGIN) (DSPRIGHTMARGIN NIL DS)) (* ; "Stash the right margin in points for later restoral") (DSPRIGHTMARGIN (FIXR (FTIMES (OR (DSPRIGHTMARGIN NIL DS) (fetch WIDTH of (DSPCLIPPINGREGION NIL DS))) MICASPERPT)) DS) (* ; "And reuse the right margin") (DSPSPACEFACTOR 1 DS) (RETURN DS))) ) (UNMAKEHARDCOPYMODESTREAM (LAMBDA (DISPLAYSTREAM) (* ; "Edited 26-Aug-87 14:28 by Snow") (* ;;; "returns a hardcopy stream to a display stream.") (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS)) (PROG ((DS (COND ((DISPLAYSTREAMP DISPLAYSTREAM)) ((WINDOWP DISPLAYSTREAM) (WINDOWPROP DISPLAYSTREAM (QUOTE DSP))) (T (\ILLEGAL.ARG DISPLAYSTREAM))))) (COND ((FMEMB (QUOTE HARDCOPY) (IMAGESTREAMTYPE DS)) (* ; "Make sure the stream really WAS a hardcopy-mode stream.")) (T (* ; "It wasn't a hardcopy-mode stream. Don't make any changes") (RETURN DS))) (replace (STREAM IMAGEOPS) of DS with \DISPLAYIMAGEOPS) (* ; "Give it back the usual operations") (STREAMPROP DS (QUOTE HARDCOPYIMAGETYPE) NIL) (* ; "restore the bout fn") (replace (STREAM STRMBOUTFN) of DS with (FUNCTION \DSPPRINTCHAR)) (replace (STREAM OUTCHARFN) of DS with (FUNCTION \DSPPRINTCHAR)) (DSPXPOSITION 0 DS) (DSPYPOSITION 0 DS) (DSPRIGHTMARGIN (OR (STREAMPROP DISPLAYSTREAM (QUOTE DSPRIGHTMARGIN)) (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL DS))) NIL DS) (* ; "Reset the right margin back to points") (RETURN DS))) ) (\BLTSHADE.HCPYMODE (LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 26-Aug-87 14:28 by Snow") (* ;;; "BLTSHADE to a hardcopy-mode display stream") (* ; "Just convert the coordinates and do the normal display thing.") (\BLTSHADE.DISPLAY TEXTURE STREAM (\MICASTOPTS DESTINATIONLEFT) (\MICASTOPTS DESTINATIONBOTTOM) WIDTH HEIGHT OPERATION (\DASHINGCONVERT.HCPYMODE CLIPPINGREGION))) ) (\BITBLT.HCPYMODE (LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 26-Aug-87 14:28 by Snow") (* ;; "BITBLT to a hardcopy-mode display stream. Convert the destination coordinates to micas and do the normal operation.") (\BITBLT.DISPLAY SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM (\MICASTOPTS DESTINATIONLEFT) (\MICASTOPTS DESTINATIONBOTTOM) WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE (\DASHINGCONVERT.HCPYMODE CLIPPINGREGION) CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)) ) (\BRUSHCONVERT.HCPYMODE (LAMBDA (BRUSH) (* ; "Edited 26-Aug-87 14:29 by Snow") (* ; "Convert a brush description from points to micas") (COND ((LISTP BRUSH) (FOR BB IN BRUSH COLLECT (COND ((NUMBERP BB) (\MICASTOPTS BB)) (T BB)))))) ) (\CHANGECHARSET.HCPYMODE (LAMBDA (DISPLAYDATA CHARSET) (* ; "Edited 26-Aug-87 14:29 by Snow") (* ; "Called when the character set information cached in a display stream doesn't correspond to CHARSET") (PROG (BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA)) (CSINFO (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA))) (CSDINFO (\GETCHARSETINFO CHARSET (FONTCOPY (ffetch DDFONT of DISPLAYDATA) (QUOTE DEVICE) (QUOTE DISPLAY))))) (UNINTERRUPTABLY (freplace DDWIDTHSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO)) (freplace DDOFFSETSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO OFFSETS) of CSINFO)) (freplace DDCHARIMAGEWIDTHS of DISPLAYDATA with (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (freplace DDCHARSET of DISPLAYDATA with CHARSET) (SETQ BM (ffetch CHARSETBITMAP of CSINFO)) (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM) BITSPERWORD)) (replace OTHERDEVICEFONTPROPS of (ffetch DDFONT of DISPLAYDATA) with (LIST (QUOTE WIDTHS) (fetch (CHARSETINFO WIDTHS) of CSDINFO) (QUOTE ASCENT) (fetch (CHARSETINFO CHARSETASCENT) of CSDINFO) (QUOTE DESCENT) (fetch (CHARSETINFO CHARSETDESCENT) of CSDINFO) (QUOTE HEIGHT) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CSDINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CSDINFO)))) (* ;; "Cache the DISPLAY info, for the various X- and Y-position updating tasks that affect the display bitmap itself") (COND ((OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA) (ffetch CHARSETASCENT of CSINFO)) (NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA) (ffetch CHARSETDESCENT of CSINFO))) (\SFFixY.HCPYMODE DISPLAYDATA CSINFO)) (T (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (ffetch DDCHARHEIGHTDELTA of DISPLAYDATA))))))))) ) (\DASHINGCONVERT.HCPYMODE (LAMBDA (DASHING) (* ; "Edited 26-Aug-87 14:29 by Snow") (* ;; "Convert a list of numbers from micas to points. Usually this will be a dashing spec, but it might be a REGION as well.") (for DD in DASHING collect (\MICASTOPTS DD))) ) (\CHARWIDTH.HCPYMODE (LAMBDA (STREAM CHARCODE) (* ; "Edited 26-Aug-87 14:29 by Snow") (* ; "gets the width of a character code in a hardcopy stream. Should be updated for spacefactor") (\FGETWIDTH (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of (fetch IMAGEDATA of STREAM)) CHARCODE)) ) (\DRAWLINE.HCPYMODE (LAMBDA (STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR) (* ; "Edited 26-Aug-87 14:29 by Snow") (* ; "Do DRAWLINE for a hardcopy-mode display stream.") (\DRAWLINE.DISPLAY STREAM (\MICASTOPTS X1) (\MICASTOPTS Y1) (\MICASTOPTS X2) (\MICASTOPTS Y2) (IMAX 1 (\MICASTOPTS WIDTH)) OPERATION COLOR)) ) (\DRAWCURVE.HCPYMODE (LAMBDA (STREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 26-Aug-87 14:30 by Snow") (* ;; "Do DRAWCURVE for a hardcopy-mode displaystream. Converts all the mica values to points and uses the usual display version.") (\DRAWCURVE.DISPLAY STREAM (FOR KNOT IN KNOTS COLLECT (CONS (\MICASTOPTS (CAR KNOT)) (\MICASTOPTS (CDR KNOT)))) CLOSED (\BRUSHCONVERT.HCPYMODE BRUSH) (\DASHINGCONVERT.HCPYMODE DASHING))) ) (\DRAWCIRCLE.HCPYMODE (LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* ; "Edited 26-Aug-87 14:30 by Snow") (* ;; "DRAWCIRCLE for a hardcopy-mode display stream. Convert coordinates to points and use the display driver") (\DRAWCIRCLE.DISPLAY STREAM (\MICASTOPTS CENTERX) (\MICASTOPTS CENTERY) (\MICASTOPTS RADIUS) (\BRUSHCONVERT.HCPYMODE BRUSH) (\DASHINGCONVERT.HCPYMODE DASHING))) ) (\DRAWELLIPSE.HCPYMODE (LAMBDA (STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 26-Aug-87 14:30 by Snow") (* ;; "DRAWELLIPSE driver for hardcopy-mode displaystreams. Convert all the values to points from micas, and use the display DRAWELLIPSE.") (\DRAWELLIPSE.DISPLAY STREAM (\MICASTOPTS CENTERX) (\MICASTOPTS CENTERY) (\MICASTOPTS SEMIMINORRADIUS) (\MICASTOPTS SEMIMAJORRADIUS) ORIENTATION (\BRUSHCONVERT.HCPYMODE BRUSH) (\DASHINGCONVERT.HCPYMODE DASHING))) ) (\DSPFONT.HCPYMODE (LAMBDA (HDCPYDSTREAM FONT) (* ; "Edited 20-Apr-88 11:53 by jds") (* ;; "changes the font of a hardcopy display stream. Does what the display does then puts the hardcopy widths where they can be found {FOR NOW USE THE DDCHARIMAGEWIDTHS FIELD}") (PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of HDCPYDSTREAM))) (* ; "save old value to return, smash new value and update the bitchar portion of the record.") (RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD)) (COND (FONT (SETQ XFONT (OR (\GETFONTDESC FONT (fetch IMFONTCREATE of (fetch IMAGEOPS of HDCPYDSTREAM)) T) (FONTCOPY (ffetch DDFONT of DD) FONT))) (* ; "updating font information is fairly expensive operation. Don't bother unless font has changed.") (OR (EQ XFONT OLDFONT) (UNINTERRUPTABLY (freplace DDFONT of DD with XFONT) (freplace DDLINEFEED of DD with (IMINUS (fetch \SFHeight of XFONT))) (* ; "Each line moves down by the font height, by default") (freplace DDSPACEWIDTH of DD with (FIXR (FTIMES (OR (ffetch DDMICAXPOS of DD) 1) (\FGETCHARWIDTH XFONT (CHARCODE SPACE))))) (\SFFixFont HDCPYDSTREAM DD) (* ; "Fix up the font-dependent fields of the DISPLAYSTREAM"))))))))) ) (\DSPLEFTMARGIN.HCPYMODE (LAMBDA (DISPLAYSTREAM XPOSITION) (* ; "Edited 26-Aug-87 14:30 by Snow") (* ;;; "Sets the left margin that determines when a cr is inserted by print for the hardcopy display stream.") (* ;;; "Sets the left margin for a hardcopy-mode displaystream, to determine where CR returns you to.") (PROG1 (\DSPRIGHTMARGIN.DISPLAY DISPLAYSTREAM (AND XPOSITION (FIXR (FQUOTIENT XPOSITION MICASPERPT)))) (* ;; "LATER, WHEN DDLEFTMARGINMICA EXISTS... (AND XPOSITION (replace (\DISPLAYDATA DDMICARIGHTMARGIN) of (fetch IMAGEDATA of DISPLAYSTREAM) with XPOSITION))"))) ) (\DSPLINEFEED.HCPYMODE (LAMBDA (DISPLAYSTREAM DELTAY) (* ; "Edited 26-Aug-87 14:33 by Snow") (* ; "For a hardcopy-mode displaystream, sets the amount that a line feed increases the y coordinate by.") (PROG1 (ffetch DDLINEFEED of (fetch IMAGEDATA of DISPLAYSTREAM)) (AND DELTAY (COND ((NUMBERP DELTAY) (freplace DDLINEFEED of (ffetch IMAGEDATA of DISPLAYSTREAM) with DELTAY)) (T (\ILLEGAL.ARG DELTAY)))))) ) (\DSPRIGHTMARGIN.HCPYMODE (LAMBDA (DISPLAYSTREAM XPOSITION) (* ; "Edited 26-Aug-87 14:32 by Snow") (* ;;; "Sets the right margin that determines when a cr is inserted by print for the hardcopy display stream.") (PROG1 (fetch (\DISPLAYDATA DDMICARIGHTMARGIN) of (fetch IMAGEDATA of DISPLAYSTREAM)) (* ; "Return the old mica value.") (\DSPRIGHTMARGIN.DISPLAY DISPLAYSTREAM (AND XPOSITION (FIXR (FQUOTIENT XPOSITION MICASPERPT)))) (* ; "Set the right margin in display units,") (AND XPOSITION (replace (\DISPLAYDATA DDMICARIGHTMARGIN) of (fetch IMAGEDATA of DISPLAYSTREAM) with XPOSITION)) (* ; "And set the new mica value"))) ) (\DSPSPACEFACTOR.HCPYMODE (LAMBDA (DISPLAYSTREAM FACTOR) (* ; "Edited 1-Apr-88 11:28 by jds") (* ;; "Sets the space factor for a hardcopy-mode displaystream.") (LET ((DDATA (fetch IMAGEDATA of DISPLAYSTREAM))) (PROG1 (fetch (\DISPLAYDATA DDMICAXPOS) of DDATA) (COND ((NUMBERP FACTOR) (replace (\DISPLAYDATA DDMICAXPOS) of DDATA with FACTOR) (replace (\DISPLAYDATA DDSPACEWIDTH) of DDATA with (FIXR (FTIMES FACTOR (CHARWIDTH (CHARCODE SPACE) (fetch (\DISPLAYDATA DDFONT) of DDATA)))))) (T (\ILLEGAL.ARG FACTOR)))))) ) (\DSPXPOSITION.HCPYMODE (LAMBDA (HARDCOPYSTREAM XPOSITION) (* ; "Edited 26-Aug-87 14:32 by Snow") (* ; "Update the X position for a mica-unit hardcopy-mode displaystream") (PROG1 (fetch (\DISPLAYDATA DDXPOSITION) of (fetch IMAGEDATA of HARDCOPYSTREAM)) (* ; "Return the old value...") (\DSPXPOSITION.DISPLAY HARDCOPYSTREAM (AND XPOSITION (FIXR (FQUOTIENT XPOSITION MICASPERPT)))) (* ; "Set up the display right for this mica value") (AND XPOSITION (replace (\DISPLAYDATA DDXPOSITION) of (fetch IMAGEDATA of HARDCOPYSTREAM) with XPOSITION)) (* ; "And remember what it was."))) ) (\DSPYPOSITION.HCPYMODE (LAMBDA (HARDCOPYSTREAM YPOSITION) (* ; "Edited 26-Aug-87 14:35 by Snow") (* ; "Move to a new mica Y position") (LET* ((DD (fetch IMAGEDATA of HARDCOPYSTREAM)) (OLD-POS (ffetch DDYPOSITION of DD))) (COND ((NULL YPOSITION)) ((NUMBERP YPOSITION) (UNINTERRUPTABLY (freplace DDYPOSITION of DD with YPOSITION)) (\INVALIDATEDISPLAYCACHE DD)) (T (\ILLEGAL.ARG YPOSITION))) OLD-POS)) ) (\MOVETO.HCPYMODE (LAMBDA (STREAM X Y) (* ; "Edited 26-Aug-87 14:36 by Snow") (\DSPXPOSITION.HCPYMODE STREAM X) (\DSPYPOSITION.HCPYMODE STREAM Y)) ) (\FONTCREATE.HCPYMODE.PRESS (LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 26-Aug-87 14:36 by Snow") (* ; "Create a font descriptor for a display stream that is mimicing an PRESS device") (PROG* ((DFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY))) (HFONT (create FONTDESCRIPTOR using (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE PRESS)) FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))) (CS0DINFO (\GETCHARSETINFO \DEFAULTCHARSET DFONT))) (replace FONTDEVICE of HFONT with (QUOTE PRESSDISPLAY)) (replace OTHERDEVICEFONTPROPS of HFONT with (LIST (QUOTE WIDTHS) (fetch (CHARSETINFO WIDTHS) of CS0DINFO) (QUOTE ASCENT) (fetch (CHARSETINFO CHARSETASCENT) of CS0DINFO) (QUOTE DESCENT) (fetch (CHARSETINFO CHARSETDESCENT) of CS0DINFO) (QUOTE HEIGHT) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CS0DINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CS0DINFO)))) (* ;; "Cache the DISPLAY info, for the various X- and Y-position updating tasks that affect the display bitmap itself") (RETURN HFONT))) ) (\CREATECHARSET.HCPYMODE.PRESS (LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) (* ; "Edited 26-Aug-87 14:36 by Snow") (* ; "Build the CHARSETINFO for an PRESSDISPLAY font") (PROG* ((DFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY))) (HFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE PRESS))) (CSDINFO (\GETCHARSETINFO CHARSET DFONT)) (CSHINFO (\GETCHARSETINFO CHARSET HFONT)) (CSINFO (CREATE CHARSETINFO USING CSHINFO))) (replace (CHARSETINFO OFFSETS) of CSINFO with (fetch (CHARSETINFO OFFSETS) of CSDINFO)) (* ; "Fill in the right offsets from the display font--into the hcpy font, and its Charset-0 info block") (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (fetch (CHARSETINFO CHARSETBITMAP) of CSDINFO)) (* ; "Likewise the character rasters") (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO IMAGEWIDTHS) of CSDINFO)) (* ; "And the raster widths (as distinct from the nominal mica widths)") (RETURN CSINFO))) ) (\FONTCREATE.HCPYMODE.INTERPRESS (LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* ; "Edited 26-Aug-87 14:36 by Snow") (* ;;; "Create a font descriptor for a display stream that is mimicing an INTERPRESS device") (PROG* ((DFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY))) (HFONT (create FONTDESCRIPTOR using (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE INTERPRESS)) FONTCHARSETVECTOR _ (\CREATEFONTCHARSETVECTOR))) (CS0DINFO (\GETCHARSETINFO \DEFAULTCHARSET DFONT))) (replace FONTDEVICE of HFONT with (QUOTE INTERPRESSDISPLAY)) (replace OTHERDEVICEFONTPROPS of HFONT with (LIST (QUOTE WIDTHS) (fetch (CHARSETINFO WIDTHS) of CS0DINFO) (QUOTE ASCENT) (fetch (CHARSETINFO CHARSETASCENT) of CS0DINFO) (QUOTE DESCENT) (fetch (CHARSETINFO CHARSETDESCENT) of CS0DINFO) (QUOTE HEIGHT) (IPLUS (fetch (CHARSETINFO CHARSETASCENT) of CS0DINFO) (fetch (CHARSETINFO CHARSETDESCENT) of CS0DINFO)))) (* ;; "Cache the DISPLAY info, for the various X- and Y-position updating tasks that affect the display bitmap itself") (RETURN HFONT))) ) (\CREATECHARSET.HCPYMODE.INTERPRESS (LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET FONTDESC) (* ; "Edited 26-Aug-87 14:37 by Snow") (* ;;; "Build the CHARSETINFO for an INTERPRESSDISPLAY font") (PROG* ((DFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE DISPLAY))) (HFONT (FONTCREATE FAMILY SIZE FACE ROTATION (QUOTE INTERPRESS))) (CSDINFO (\GETCHARSETINFO CHARSET DFONT)) (CSHINFO (\GETCHARSETINFO CHARSET HFONT)) (CSINFO (CREATE CHARSETINFO USING CSHINFO))) (replace (CHARSETINFO OFFSETS) of CSINFO with (fetch (CHARSETINFO OFFSETS) of CSDINFO)) (* ; "Fill in the right offsets from the display font--into the hcpy font, and its Charset-0 info block") (replace (CHARSETINFO CHARSETBITMAP) of CSINFO with (fetch (CHARSETINFO CHARSETBITMAP) of CSDINFO)) (* ; "Likewise the character rasters") (replace (CHARSETINFO IMAGEWIDTHS) of CSINFO with (fetch (CHARSETINFO IMAGEWIDTHS) of CSDINFO)) (* ; "And the raster widths (as distinct from the nominal mica widths)") (RETURN CSINFO))) ) (\STRINGWIDTH.HCPYMODE (LAMBDA (STREAM STR RDTBL) (* ; "Edited 26-Aug-87 14:38 by Snow") (* ; "Returns the width of for the current font/spacefactor in hardcopy stream STREAM.") (LET ((WIDTHSBASE (ffetch (\DISPLAYDATA DDCHARIMAGEWIDTHS) of (ffetch IMAGEDATA of STREAM)))) (IQUOTIENT (IPLUS (\STRINGWIDTH.GENERIC STR WIDTHSBASE RDTBL (\FGETWIDTH WIDTHSBASE (CHARCODE SPACE))) (CONSTANT IHALFMICASPERPT)) (CONSTANT IMICASPERPT)))) ) (\HCPYMODEBLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 1-Apr-88 11:35 by jds") (* ;; "puts a character on a hardcopy display stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") (* ; "knows about the representation of a DisplayStream.") (DECLARE (LOCALVARS . T)) (PROG (LOCAL1 RIGHT LEFT CURX MICARIGHT (CHAR8CODE (\CHAR8CODE CHARCODE)) CHARWIDTH) CRLP (COND ((NEQ (ffetch DDCHARSET of DISPLAYDATA) (\CHARSET CHARCODE)) (\CHANGECHARSET.HCPYMODE DISPLAYDATA (\CHARSET CHARCODE)))) (COND ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) (RETURN (\SLOWHCPYMODEBLTCHAR CHARCODE DISPLAYSTREAM)))) (SETQ CURX (FIXR (FQUOTIENT (ffetch DDXPOSITION of DISPLAYDATA) MICASPERPT))) (* ; "Convert the mica-position value to points only at the last minute.") (SETQ CHARWIDTH (COND ((IEQP CHARCODE (CHARCODE SPACE)) (FFETCH DDSPACEWIDTH OF DISPLAYDATA)) (T (\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA)))) (COND ((IGREATERP (SETQ MICARIGHT (IPLUS (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA) CHARWIDTH)) (ffetch (\DISPLAYDATA DDMICARIGHTMARGIN) of DISPLAYDATA)) (* ; "would go past right margin, force a cr") (COND ((IGREATERP CURX (ffetch DDLeftMargin of DISPLAYDATA)) (* ; "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* ; "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP))))) (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with MICARIGHT) (* ;; "update the display stream x position. Make sure that there is at least one point width for each character.") (SETQ CURX (IPLUS CURX (SETQ LOCAL1 (ffetch DDXOFFSET of DISPLAYDATA)))) (* ; "Screen position of the window, generally.") (SETQ RIGHT (IPLUS CURX (\FGETWIDTH (ffetch DDCHARIMAGEWIDTHS of DISPLAYDATA) CHAR8CODE))) (* ; "Right edge of the character's image.") (COND ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch DDClippingRight of DISPLAYDATA))) (* ; "character overlaps right edge of clipping region.") (SETQ RIGHT LOCAL1))) (SETQ LEFT (COND ((IGREATERP CURX (SETQ LOCAL1 (ffetch DDClippingLeft of DISPLAYDATA))) CURX) (T LOCAL1))) (* ; "Left edge of the character, as displayed.") (RETURN (COND ((AND (ILESSP LEFT RIGHT) (NEQ (fetch PBTHEIGHT of (SETQ LOCAL1 (ffetch DDPILOTBBT of DISPLAYDATA))) 0)) (* ; "If the character will appear on screen at all, let's display it.") (.WHILE.TOP.DS. DISPLAYSTREAM (freplace PBTDESTBIT of LOCAL1 with LEFT) (* ; "Set up the destination bit with the screen-relative left edge") (freplace PBTWIDTH of LOCAL1 with (IDIFFERENCE RIGHT LEFT)) (* ; "The display width from the clipped left and right edges") (freplace PBTSOURCEBIT of LOCAL1 with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DISPLAYDATA) LEFT) CURX)) (* ; "And the source bit-offset from the OFFSETs array") (\PILOTBITBLT LOCAL1 0) (* ; "Do the BITBLT")) T))))) ) (\HCPYMODEDISPLAYINIT (LAMBDA NIL (* ; "Edited 1-Apr-88 11:36 by jds") (* ;;; "Initializes global variables for the hardcopy Display device. This device appears to the user as an INTERPRESS or PRESS device meaning units in micas but outputs to the screen. Much of this code was borrowed from the display case.") (DECLARE (GLOBALVARS \HCPYMODEDISPLAYIMAGEOPS.PRESS \HCPYMODEDISPLAYIMAGEOPS.INTERPRESS)) (SETQ \HCPYMODEDISPLAYIMAGEOPS.PRESS (create IMAGEOPS using \DISPLAYIMAGEOPS IMAGETYPE _ (QUOTE (HARDCOPY DISPLAY)) IMFONT _ (FUNCTION \DSPFONT.HCPYMODE) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.HCPYMODE) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.HCPYMODE) IMLINEFEED _ (FUNCTION \DSPLINEFEED.HCPYMODE) IMDRAWLINE _ (FUNCTION \DRAWLINE.HCPYMODE) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.HCPYMODE) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.HCPYMODE) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.HCPYMODE) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.HCPYMODE) IMBLTSHADE _ (FUNCTION \BLTSHADE.HCPYMODE) IMBITBLT _ (FUNCTION \BITBLT.HCPYMODE) IMXPOSITION _ (FUNCTION \DSPXPOSITION.HCPYMODE) IMYPOSITION _ (FUNCTION \DSPYPOSITION.HCPYMODE) IMMOVETO _ (FUNCTION \MOVETO.HCPYMODE) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.HCPYMODE) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.HCPYMODE) IMFONTCREATE _ (FUNCTION PRESSDISPLAY) IMSCALE _ (FUNCTION (LAMBDA NIL (CONSTANT (FQUOTIENT MICASPERINCH 72)))) IMNEWPAGE _ (FUNCTION (LAMBDA (STREAM) (LET ((WINDOW (AND \WINDOWWORLD (WFROMDS STREAM))) WINDOWFN) (COND ((AND WINDOW (SETQ WINDOWFN (WINDOWPROP WINDOW (QUOTE PAGEFULLFN)))) (APPLY* WINDOWFN STREAM)) (T (PAGEFULLFN STREAM))) (CLEARW STREAM)))) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.HCPYMODE))) (SETQ \HCPYMODEDISPLAYIMAGEOPS.INTERPRESS (create IMAGEOPS using \DISPLAYIMAGEOPS IMAGETYPE _ (QUOTE (HARDCOPY DISPLAY)) IMFONT _ (FUNCTION \DSPFONT.HCPYMODE) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.HCPYMODE) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.HCPYMODE) IMLINEFEED _ (FUNCTION \DSPLINEFEED.HCPYMODE) IMDRAWLINE _ (FUNCTION \DRAWLINE.HCPYMODE) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.HCPYMODE) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.HCPYMODE) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.HCPYMODE) IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.HCPYMODE) IMBLTSHADE _ (FUNCTION \BLTSHADE.HCPYMODE) IMBITBLT _ (FUNCTION \BITBLT.HCPYMODE) IMXPOSITION _ (FUNCTION \DSPXPOSITION.HCPYMODE) IMYPOSITION _ (FUNCTION \DSPYPOSITION.HCPYMODE) IMMOVETO _ (FUNCTION \MOVETO.HCPYMODE) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.HCPYMODE) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.HCPYMODE) IMFONTCREATE _ (FUNCTION INTERPRESSDISPLAY) IMSCALE _ (FUNCTION (LAMBDA NIL (CONSTANT (FQUOTIENT MICASPERINCH 72)))) IMNEWPAGE _ (FUNCTION (LAMBDA (STREAM) (LET ((WINDOW (AND \WINDOWWORLD (WFROMDS STREAM))) WINDOWFN) (COND ((AND WINDOW (SETQ WINDOWFN (WINDOWPROP WINDOW (QUOTE PAGEFULLFN)))) (APPLY* WINDOWFN STREAM)) (T (PAGEFULLFN STREAM))) (CLEARW STREAM)))) IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.HCPYMODE)))) ) (\HCPYMODEDSPPRINTCHAR (LAMBDA (STREAM CHARCODE) (* ; "Edited 26-Aug-87 14:39 by Snow") (* ;;; "displays a character on a hardcopy display stream. This uses a display font but updates the x position according to hardcopy widths.") (PROG ((DD (fetch IMAGEDATA of STREAM))) (\CHECKCARET STREAM) (RETURN (SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE)) (INDICATE.CCE (PROG ((CC CHARCODE)) (add (fetch CHARPOSITION of STREAM) (IPLUS (COND ((IGREATERP CC 127) (* ; "META character") (\HCPYMODEBLTCHAR (CHARCODE %#) STREAM DD) (SETQ CC (LOGAND CC 127)) 1) (T 0)) (COND ((ILESSP CC 32) (* ; "CONTROL character") (\HCPYMODEBLTCHAR (CHARCODE ^) STREAM DD) (SETQ CC (LOGOR CC 64)) 1) (T 0)) (PROGN (\HCPYMODEBLTCHAR CC STREAM DD) 1))))) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF) (\DSPPRINTCR/LF CHARCODE STREAM) (replace CHARPOSITION of STREAM with 0)) (ESCAPE (\HCPYMODEBLTCHAR (CHARCODE $) STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)) (BELL (* ; "make switching of bits uninterruptable but allow interrupts between flashes.") (SELECTQ (MACHINETYPE) (DANDELION (PLAYTUNE (QUOTE ((880 . 2500))))) (FLASHWINDOW (WFROMDS STREAM)))) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (COND ((IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (fetch DDXPOSITION of DD) (ffetch DDLeftMargin of DD)) TABWIDTH))) DD) (ffetch DDRightMargin of DD)) (* ; "tab was past rightmargin, force cr.") (\DSPPRINTCR/LF (CHARCODE EOL) STREAM))) (* ; "return the number of spaces taken.") (add (fetch CHARPOSITION of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (PROGN (* ; "this case was copied from \DSCCOUT.") (\HCPYMODEBLTCHAR CHARCODE STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)))) (REAL.CCE (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) (\DSPPRINTCR/LF CHARCODE STREAM) (replace CHARPOSITION of STREAM with 0)) (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A) STREAM) STREAM) (* ; "line buffering routines have already taken care of backing up the position") 0) (PROGN (\HCPYMODEBLTCHAR CHARCODE STREAM DD) (add (fetch CHARPOSITION of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT))))) ) (\SLOWHCPYMODEBLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 26-Aug-87 14:39 by Snow") (* ;;; "IS THIS CODE JUST GOING TO DUPLICATE AND GET OUT OF SYNC WITH \SLOWBLTCHAR? KBR 1-FEB-86. *") (* ;;; "THIS HAS BEEN SEPARATED OUT BUT HASN'T BEEN EDITTED TO DO CORRECT THING WRT UPDATING MICA FIELDS.") (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a hardcopy display stream.") (PROG (ROTATION (CHAR8CODE (\CHAR8CODE CHARCODE)) (DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM))) (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT (CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) PILOTBBT DESTBIT WIDTH SOURCEBIT) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) (COND ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ; "past RIGHT margin, force eol") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))))) (* ; "update the x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) (SETQ CURX (\DSPTRANSFORMX CURX DD)) (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) CURX)) (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) (\DSPTRANSFORMX NEWX DD))) (SETQ PILOTBBT (ffetch (\DISPLAYDATA DDPILOTBBT) of DD)) (COND ((AND (ILESSP LEFT RIGHT) (NEQ (ffetch (PILOTBBT PBTHEIGHT) of PILOTBBT) 0)) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination) of DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with DESTBIT) (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with WIDTH) (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with SOURCEBIT) (\PILOTBITBLT PILOTBBT 0)) T)))) (T (* ; "handle rotated fonts") (PROG (YPOS HEIGHTMOVED CSINFO) (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ ROTATION 90) (* ; "don't force CR for rotated fonts.") (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) (* ; "update the display stream x position.") (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO))) YPOS (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYSTREAM) (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) (T (ERROR "Not implemented to rotate by other than 0, 90 or 270")))))))) ) (\SFFixY.HCPYMODE (LAMBDA (DISPLAYDATA CSINFO) (* ; "Edited 26-Aug-87 14:40 by Snow") (* ;; "makes that part of the bitblt table of a display stream which deals with the Y information consistent. This is called whenever any of the information which effects it changes by the DSPFn eg DSPPosition. If the change affected the clipping region, \SFFixClippingRegion should be called before \SFFixY.HCPYMODE") (* ; "assumes DISPLAYDATA has already been type checked.") (PROG ((PBT (ffetch DDPILOTBBT of DISPLAYDATA)) (FONT (ffetch DDFONT of DISPLAYDATA)) (Y (\DSPTRANSFORMY (\MICASTOPTS (ffetch DDYPOSITION of DISPLAYDATA)) DISPLAYDATA)) TOP CHARTOP BM) (SETQ CHARTOP (IPLUS Y (LISTGET (fetch OTHERDEVICEFONTPROPS of FONT) (QUOTE ASCENT)))) (freplace PBTDEST of PBT with (\ADDBASE (fetch BITMAPBASE of (SETQ BM (ffetch DDDestination of DISPLAYDATA))) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (\SFInvert BM (SETQ TOP (IMAX (IMIN (ffetch DDClippingTop of DISPLAYDATA) CHARTOP) 0)))))) (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of (SETQ BM (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (freplace DDCHARHEIGHTDELTA of DISPLAYDATA with (IMIN (IMAX (IDIFFERENCE CHARTOP TOP) 0) MAX.SMALL.INTEGER))))) (freplace PBTHEIGHT of PBT with (IMAX (IDIFFERENCE TOP (IMAX (IDIFFERENCE Y (freplace DDCHARSETDESCENT of DISPLAYDATA with (LISTGET (fetch OTHERDEVICEFONTPROPS of FONT) (QUOTE DESCENT)))) (ffetch DDClippingBottom of DISPLAYDATA))) 0)))) ) ) (ADDTOVAR IMAGESTREAMTYPES (PRESSDISPLAY (FONTCREATE \FONTCREATE.HCPYMODE.PRESS) (CREATECHARSET \CREATECHARSET.HCPYMODE.PRESS)) (INTERPRESSDISPLAY (FONTCREATE \FONTCREATE.HCPYMODE.INTERPRESS) (CREATECHARSET \CREATECHARSET.HCPYMODE.INTERPRESS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (\HCPYMODEDISPLAYINIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS HARDCOPY COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6265 10449 (HARDCOPY.SOMEHOW 6275 . 7633) (HARDCOPYIMAGEW 7635 . 7787) ( HARDCOPYIMAGEW.TOFILE 7789 . 8097) (HARDCOPYIMAGEW.TOPRINTER 8099 . 8764) (HARDCOPYREGION.TOFILE 8766 . 9064) (HARDCOPYREGION.TOPRINTER 9066 . 9688) (COPY.WINDOW.TO.BITMAP 9690 . 10447)) (10521 21071 ( MakeMenuOfPrinters 10531 . 11756) (PRINTERS.WHENSELECTEDFN 11758 . 13500) (MakeMenuOfImageTypes 13502 . 14020) (GetNewPrinterFromUser 14022 . 14450) (PopUpWindowAndGetAtom 14452 . 15837) ( PopUpWindowAndGetList 15839 . 17405) (NewPrinter 17407 . 18355) (GetPrinterName 18357 . 18637) ( GetImageFile 18639 . 20926) (FetchDefaultPrinter 20928 . 21069)) (21106 21644 ( ExtensionForPrintFileType 21116 . 21309) (PRINTFILETYPE.FROM.EXTENSION 21311 . 21642)) (21699 38083 ( DEFAULTPRINTER 21709 . 21869) (CAN.PRINT.DIRECTLY 21871 . 22027) (CONVERT.FILE.TO.TYPE.FOR.PRINTER 22029 . 23073) (EMPRESS 23075 . 23388) (HARDCOPYW 23390 . 26350) (LISTFILES1 26352 . 26525) ( PRINTER.BITMAPFILE 26527 . 26774) (PRINTER.BITMAPSCALE 26776 . 27041) (PRINTER.SCRATCH.FILE 27043 . 27166) (PRINTERPROP 27168 . 27351) (PRINTERSTATUS 27353 . 27542) (PRINTERTYPE 27544 . 29853) ( PRINTERNAME 29855 . 30157) (PRINTFILEPROP 30159 . 30350) (PRINTFILETYPE 30352 . 32296) ( \EXPECTED.FILE.TYPE 32298 . 33080) (SEND.FILE.TO.PRINTER 33082 . 38081)) (38084 43066 (PRINTERDEVICE 38094 . 43064)) (43849 52443 (TEXTTOIMAGEFILE 43859 . 46049) (COPY.TEXT.TO.IMAGE 46051 . 52441)) ( 52444 53579 (\BLTSHADE.GENERICPRINTER 52454 . 53577)) (53707 72459 (MAKEHARDCOPYSTREAM 53717 . 54721) (UNMAKEHARDCOPYSTREAM 54723 . 55407) (HARDCOPYSTREAMTYPE 55409 . 55688) (\CHARWIDTH.HDCPYDISPLAY 55690 . 56121) (\DSPFONT.HDCPYDISPLAY 56123 . 57528) (\DSPRIGHTMARGIN.HDCPYDISPLAY 57530 . 58107) ( \DSPXPOSITION.HDCPYDISPLAY 58109 . 58370) (\DSPYPOSITION.HDCPYDISPLAY 58372 . 58633) ( \STRINGWIDTH.HDCPYDISPLAY 58635 . 59142) (\STRINGWIDTH.HCPYDISPLAYAUX 59144 . 61476) (\HDCPYBLTCHAR 61478 . 64013) (\HDCPYDISPLAY.FIX.XPOS 64015 . 64435) (\HDCPYDISPLAY.FIX.YPOS 64437 . 64857) ( \HDCPYDISPLAYINIT 64859 . 65636) (\HDCPYDSPPRINTCHAR 65638 . 67798) (\SLOWHDCPYBLTCHAR 67800 . 71303) (\CHANGECHARSET.HDCPYDISPLAY 71305 . 72457)) (73181 103478 (MAKEHARDCOPYMODESTREAM 73191 . 75100) ( UNMAKEHARDCOPYMODESTREAM 75102 . 76180) (\BLTSHADE.HCPYMODE 76182 . 76629) (\BITBLT.HCPYMODE 76631 . 77253) (\BRUSHCONVERT.HCPYMODE 77255 . 77492) (\CHANGECHARSET.HCPYMODE 77494 . 79261) ( \DASHINGCONVERT.HCPYMODE 79263 . 79526) (\CHARWIDTH.HCPYMODE 79528 . 79815) (\DRAWLINE.HCPYMODE 79817 . 80129) (\DRAWCURVE.HCPYMODE 80131 . 80560) (\DRAWCIRCLE.HCPYMODE 80562 . 80957) ( \DRAWELLIPSE.HCPYMODE 80959 . 81471) (\DSPFONT.HCPYMODE 81473 . 82629) (\DSPLEFTMARGIN.HCPYMODE 82631 . 83215) (\DSPLINEFEED.HCPYMODE 83217 . 83627) (\DSPRIGHTMARGIN.HCPYMODE 83629 . 84258) ( \DSPSPACEFACTOR.HCPYMODE 84260 . 84781) (\DSPXPOSITION.HCPYMODE 84783 . 85364) (\DSPYPOSITION.HCPYMODE 85366 . 85771) (\MOVETO.HCPYMODE 85773 . 85925) (\FONTCREATE.HCPYMODE.PRESS 85927 . 86939) ( \CREATECHARSET.HCPYMODE.PRESS 86941 . 87912) (\FONTCREATE.HCPYMODE.INTERPRESS 87914 . 88948) ( \CREATECHARSET.HCPYMODE.INTERPRESS 88950 . 89938) (\STRINGWIDTH.HCPYMODE 89940 . 90374) ( \HCPYMODEBLTCHAR 90376 . 93345) (\HCPYMODEDISPLAYINIT 93347 . 96278) (\HCPYMODEDSPPRINTCHAR 96280 . 98461) (\SLOWHCPYMODEBLTCHAR 98463 . 101977) (\SFFixY.HCPYMODE 101979 . 103476))))) STOP \ No newline at end of file diff --git a/sources/HIST b/sources/HIST new file mode 100644 index 00000000..7652e304 --- /dev/null +++ b/sources/HIST @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "10-Jul-91 12:07:43" |{PELE:MV:ENVOS}SOURCES>HIST.;3| 152184 |changes| |to:| (VARS HISTCOMS) |previous| |date:| "16-May-90 18:10:04" |{PELE:MV:ENVOS}SOURCES>HIST.;2|) ; Copyright (c) 1978, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ; The following program was created in 1978 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 HISTCOMS) (RPAQQ HISTCOMS ((FNS PRINTHISTORY ENTRY# PRINTHISTORY1 PRINTHISTORY2) (FNS EVALQT ENTEREVALQT USEREXEC LISPXREAD LISPXREADBUF LISPXREADP LISPXUNREAD LISPX LISPX/ LISPX/1 LISPXEVAL LISPXSTOREVALUE HISTORYSAVE LISPXFIND LISPXGETINPUT REMEMBER GETEXPRESSIONFROMEVENTSPEC LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1 HISTORYMATCH VALUEOF VALUOF VALUOF-EVENT LISPXUSE LISPXUSE0 LISPXUSE1 LISPXSUBST LISPXUSEC LISPXFIX CHANGESLICE LISPXSTATE LISPXTYPEAHEAD) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (\#REDOCNT 3) (ARCHIVEFLG T) (ARCHIVEFN) (ARCHIVELST '(NIL 0 50 100)) (DISPLAYTERMFLG) (EDITHISTORY '(NIL 0 30 100)) (HERALDSTRING) (LASTEXEC) (LASTHISTORY) (LISPXBUFS) (LISPXHIST) (LISPXHISTORY '(NIL 0 30 100)) (LISPXPRINTFLG T) (LISPXUSERFN) (MAKESYSDATE) (PROMPT#FLG T) (REDOCNT) (SYSOUT.EXT 'SYSOUT) (SYSOUTFILE 'WORK) (SYSOUTGAG) (TOPLISPXBUFS))) (LISPXMACROS SHH RETRIEVE BEFORE AFTER OK REMEMBER\: REMEMBER TYPE-AHEAD ??T) (ADDVARS (LISPXFINDSPLST FROM TO THRU SUCHTHAT ALL AND) (BEFORESYSOUTFORMS (SETQ SYSOUTDATE (DATE)) (PROGN (COND ((NULL FILE) (SETQ FILE SYSOUTFILE)) (T (SETQ SYSOUTFILE (PACKFILENAME 'VERSION NIL 'BODY FILE)))) (COND ((AND (NULL (FILENAMEFIELD FILE 'EXTENSION)) (NULL (FILENAMEFIELD FILE 'VERSION))) (SETQ FILE (PACKFILENAME 'BODY FILE 'EXTENSION SYSOUT.EXT)))))) (RESETFORMS (SETQ READBUF NIL) (SETQ READBUFSOURCE NIL) (SETQ TOPLISPXBUFS (OR (CLBUFS T) TOPLISPXBUFS)) (COND ((EQ CLEARSTKLST T) (COND ((EQ NOCLEARSTKLST NIL) (CLEARSTK)) (T (* |clear| |all| |stack| |pointers| EXCEPT |those| |on| NOCLEARSTKLST.) (MAPC (CLEARSTK T) (FUNCTION (LAMBDA (X) (AND (NOT (FMEMB X NOCLEARSTKLST)) (RELSTK X)))))))) (T (MAPC CLEARSTKLST (FUNCTION RELSTK)) (SETQ CLEARSTKLST NIL)))) (HISTORYSAVEFORMS) (LISPXCOMS  |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix| |forget| |name| |redo| |repeat| |retry| |undo| |use|) (SYSTATS (LISPXSTATS LISPX INPUTS) (UNDOSAVES UNDO SAVES) (UNDOSTATS CHANGES UNDONE) NIL (EDITCALLS CALLS TO EDITOR) (EDITSTATS EDIT COMMANDS) (EDITEVALSTATS COMMANDS INVOLVING EVALUATING A LISP EXPRESSION) (EDITESTATS USES OF AN E COMMAND TYPED IN DIRECTLY) (EDITISTATS USES OF AN I COMMAND TYPED IN DIRECTLY) (EDITUNDOSAVES EDIT UNDO SAVES) (EDITUNDOSTATS EDIT CHANGES UNDONE) NIL (P.A.STATS P.A. COMMANDS) NIL (CLISPIFYSTATS CALLS TO CLISPIFY) NIL (FIXCALLS CALLS TO DWIM) (FIXTIME) (ERRORCALLS WERE DUE TO ERRORS) (DWIMIFYFIXES WERE FROM DWIMIFYING) NIL "OF THOSE DUE TO ERRORS:" (TYPEINFIXES WERE DUE TO ERRORS IN TYPE-IN) (PROGFIXES WERE DUE TO ERRORS IN USER PROGRAMS) (SUCCFIXES1 OF THESE CALLS WERE SUCCESSFUL) NIL "OF THE CALLS DUE TO DWIMIFYING:" (SUCCFIXES2 WERE SUCCESSFUL) NIL (SPELLSTATS OF ALL DWIM CORRECTIONS WERE SPELLING CORRECTIONS) (CLISPSTATS WERE CLISP TRANSFORMATIONS) (INFIXSTATS OF THESE WERE INFIX TRANSFORMATIONS) (IFSTATS WERE IF/THEN/ELSE STATEMENTS) (I.S.STATS WERE ITERATIVE STATEMENTS) (MATCHSTATS WERE PATTERN MATCHES) (RECORDSTATS WERE RECORD OPERATIONS) NIL (SPELLSTATS1 OTHER SPELLING CORRECTIONS\, E.G. EDIT COMMANDS) NIL (RUNONSTATS OF ALL SPELLING CORRECTIONS WERE RUN-ON CORRECTIONS) NIL (VETOSTATS CORRECTIONS WERE VETOED) NIL) (NOCLEARSTKLST)) (APPENDVARS (AFTERSYSOUTFORMS (COND ((LISTP SYSOUTGAG) (EVAL SYSOUTGAG)) (SYSOUTGAG) ((OR (NULL USERNAME) (EQ USERNAME (USERNAME NIL T))) (TERPRI T) (PRIN1 HERALDSTRING T) (TERPRI T) (TERPRI T) (GREET0) (TERPRI T)) (T (LISPXPRIN1 '"****ATTENTION USER " T) (LISPXPRIN1 (USERNAME) T) (LISPXPRIN1 '": this sysout is initialized for user " T) (LISPXPRIN1 USERNAME T) (LISPXPRIN1 '". " T) (LISPXPRIN1 '"To reinitialize, type GREET() " T))) (SETINITIALS))) (P (MAPC SYSTATS (FUNCTION (LAMBDA (X) (AND (LISTP X) (EQ (GETTOPVAL (CAR X)) 'NOBIND) (SETTOPVAL (CAR X) NIL))))) (PUTD 'E)) (COMS (FNS GREET GREET0) (ADDVARS (PREGREETFORMS (DREMOVE GREETFORM RESETFORMS) (SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0))) (SETQ CONSOLETIME0 (CLOCK 0)) (SETQ CPUTIME0 (CLOCK 2))) (POSTGREETFORMS (SETINITIALS) (AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS)))) (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (GREETHIST) (SYSTEMTYPE) (GREETFORM '(LISPXEVAL '(GREET) '_)) (CUTEFLG) (GREETDATES '((" 1-JAN" . "Happy new year") ("12-FEB" . "Happy Lincoln's birthday") ("14-FEB" . "Happy Valentine's day") ("22-FEB" . "Happy Washington's birthday") ("15-MAR" . "Beware the Ides of March") ("17-MAR" . "Happy St. Patrick's day") ("18-MAY" . "It's Victoria Day") (" 1-JUL" . "It's Canada Day") ("31-OCT" . "Trick or Treat") (" 5-NOV" . " it's Guy Fawkes day") ("25-DEC" . "Merry Christmas"))) (USERNAME) (HOSTNAME) (CONSOLETIME 0) (CONSOLETIME0 0) (CPUTIME 0) (CPUTIME0 0) (EDITIME 0) (FIRSTNAME)) (ADDVARS (BEFOREMAKESYSFORMS (SETQ RESETFORMS (CONS GREETFORM RESETFORMS)) (SETQ MAKESYSDATE (DATE)))) (ADDVARS (AFTERMAKESYSFORMS (LISPXEVAL '(GREET) '_))))) (FNS LISPXPRINT LISPXPRIN1 LISPXPRIN2 LISPXPRINTDEF LISPXPRINTDEF0 LISPXSPACES LISPXTERPRI LISPXTAB USERLISPXPRINT LISPXPUT) (GLOBALVARS \#REDOCNT ARCHIVEFLG ARCHIVEFN ARCHIVELST BOUNDPDUMMY BREAKRESETVALSLST CAR/CDRNIL CHCONLST1 CLEARSTKLST CLISPARRAY CLISPCHARS CLISPFLG CLISPTRANFLG CONSOLETIME CONSOLETIME0 CPUTIME CPUTIME0 CTRLUFLG CUTEFLG DISPLAYTERMFLG DWIMFLG EDITHISTORY EDITIME EDITQUIETFLG EDITSTATS EVALQTFORMS FILERDTBL FIRSTNAME GREETDATES GREETHIST HISTORYCOMS HISTORYSAVEFN HISTORYSAVEFORMS HISTSTR0 HISTSTR2 HISTSTR3 IT LASTHISTORY LISP-RELEASE-VERSION LISPXBUFS LISPXCOMS LISPXFINDSPLST LISPXFNS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISPXPRINTFLG LISPXREADFN LISPXSTATS LISPXUSERFN MACSCRATCHSTRING NEWUSERFLG P.A.STATS POSTGREETFORMS PREGREETFORMS PRETTYHEADER RANDSTATE READBUFSOURCE REDOCNT REREADFLG RESETFORMS SYSFILES TOPLISPXBUFS USERHANDLE USERNAME) (VARS (LISP-RELEASE-VERSION 2.0)) (BLOCKS (LISPXFINDBLOCK LISPXFIND LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1 (ENTRIES LISPXFIND HISTORYFIND) (LOCALFREEVARS _FLG L LST Z =FLG HISTORYFLG PREDFLG LINE HISTORY TYPE BACKUP QUIETFLG) (NOLINKFNS HISTORYMATCH LISPXGETINPUT)) (NIL ENTRY# EVALQT GETEXPRESSIONFROMEVENTSPEC GREET GREET0 HISTORYMATCH HISTORYSAVE LISPX LISPX/ LISPX/1 LISPXEVAL LISPXFIND1 LISPXGETINPUT LISPXPRIN1 LISPXPRIN2 LISPXPRINT LISPXPRINTDEF LISPXPRINTDEF0 LISPXPUT LISPXREAD LISPXREADBUF LISPXREADP LISPXSPACES LISPXSTOREVALUE LISPXSUBST LISPXTAB LISPXTERPRI LISPXTYPEAHEAD LISPXUNREAD LISPXUSE LISPXUSE0 LISPXUSE1 LISPXUSEC PRINTHISTORY PRINTHISTORY1 PRINTHISTORY2 USEREXEC USERLISPXPRINT VALUEOF VALUOF (LOCALVARS . T) (SPECVARS LISPXLINE LISPXID LISPXVALUE LISPXLISTFLG HISTORY ID EVENT BREAKRESETVALS VARS GENLST INITLST NAME MESSAGE) (LINKFNS . T) (NOLINKFNS LISPXTYPEAHEAD UNDOLISPX ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0 LISPXSUBST LISPXFIND HISTORYMATCH PRINTHISTORY DISPLAYTERMP LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT PRINTHISTORY1 PRINTHISTORY2 LISPXFIND HISTORYMATCH LISPXGETINPUT LISPXSUBST ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0 LISPXSUBST HISTORYMATCH PRINTHISTORY DISPLAYTERMP LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT LISPXTYEAHEAD UNDOLISPX GREETFILENAME))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA VALUEOF) (NLAML) (LAMA))))) (DEFINEQ (printhistory (lambda (history line skipfn novalues file) (* |wt:| 7-may-76 4 58) (and (eq history edithistory) (setq novalues t)) (* novalues |is| t |for| |printing| edithistory\, |indicates| |not| |to|  |print| |the| |value.| |if| |it| |is| |non-atomic,| |it| |is| \a |form| |which|  |is| |evaluated| |in| printhistory1 |in| |lieu| |of| |printing| |the| |value.|  |This| |form| |can| |also| |be| |obtained| |from| |the| |property| |list| |of|  |the| |entry| |under| |property| |print.|) (prog ((l (car history)) lst helpclock) (setq lst (cond ((null line) (car history)) (t (lispxfind history line 'entries)))) (terpri file) (terpri file) (mapc lst (function (lambda (event) (cond ((and skipfn (apply* skipfn event)) (* i\f skipfn |applied| |to| |this| |entry| |is| t\, |it| |is| |skipped.|) ) (t (prin2 (entry# history event) file t) (prin1 '\. file) (printhistory1 event (cond ((eq novalues t) t) (novalues (apply* novalues event))) file)))))) (terpri file) (terpri file) (return)))) (entry# (lambda (hist x) (cond ((not (igreaterp (setq x (iplus (cadr hist) (iminus (flength (car hist))) (flength (fmemb x (car hist))))) 0)) (iplus x (or (cadddr hist) 100))) (t x)))) (printhistory1 (lambda (event novalues file) (* |lmm| " 1-May-86 13:56") (* i\f novalues |is| t\, |means|  |suppress| |printing| |of| |value.|) (prog ((input (car event)) y tem) (cond ((listp (setq tem (listget1 event '*firstprint*))) (* |used| |by| |the| |editor.|) (tab 5 nil file) (apply (car tem) (cons file (cdr tem))))) (cond ((setq y (cdr (fmemb '*group* event))) (* memb |used| |instead| |of| listget |because| |value| |may| |be| nil\, |e.g.|  |if| |command| |aborted| |because| use |argument| |wasnt| |found.|) (tab 5 nil file) (maprint (listget1 event '*history*) file nil nil nil (function (lambda (x fl) (prin2 x fl t)))) (terpri file) (cond ((car y) (mapc (car y) (function (lambda (event) (printhistory1 event novalues file)))) (cond ((setq tem (listget1 event '*redocnt*)) (tab 5 nil file) (prin1 "... " file) (prin1 (add1 tem) file) (prin1 " times " file))) (return) (* |if| |group| |is| |empty,| |still| |might| |want| |to| |drop| |through|  |and| |print| |input,| |if| |any,| |e.g.|  name |command| |works| |this| |way.|) )))) (cond ((or (null input) (eq (car input) histstr2)) (go lp1))) (tab 5 nil file) (and (setq tem (cadr event)) (prin1 tem file)) lp (cond ((setq y (fmemb histstr0 (listp input))) (setq input (ldiff input y)))) (and input (printhistory2 input file novalues)) (* |shouldnt| |be| |any| |situations| |with| |two| "" \s |in| \a |row,|  |but| |just| |in| |case|) (cond (y (setq input (cdr y)) (spaces 5 file) (go lp))) lp1 (mapc (listget1 event '*lispxprint*) (function (lambda (x) (lispxreprint x file)))) (cond ((listp (setq tem (listget1 event '*print*))) (* |used| |by| |break.|) (tab 5 nil file) (apply (car tem) (cons file (cdr tem)))) (novalues) (t (|for| x |in| (listget (cdddr event) 'lispxvalues) |do| (tab 5 nil file) (showprint x file t))))))) (printhistory2 (lambda (input file novalues) (* |wt:| "14-AUG-78 02:59") (prog (tem) (cond ((nlistp input) (prin1 input file)) ((cddr input) (maprint input file nil nil nil (function (lambda (x fl) (* maprint |does| |an| |apply*| |with| |this| |argument| |on| |the| |thing|  |to| |be| |printed| |and| |the| |fl.|) (showprin2 x fl t))))) ((cdr input) (* apply |input|) (showprin2 (car input) file t) (cond ((null (setq tem (cadr input))) (prin1 (cond (\#rpars ']) (t '|()|)) file)) (t (cond ((or (atom tem) (eq novalues t)) (* i\f novalues |is| t\, |ppobaby| |is| |printing| |editor| |history| |list,|  |so| |print| |the| |space.|) (spaces 1 file))) (showprin2 tem file t)))) (t (* eval |input|) (showprin2 (car input) file t))) (terpri file)))) ) (DEFINEQ (evalqt (lambda (lispxid) (* |lmm| " 9-Jun-85 21:04") (prog nil (cond ((null lispxid) (setqq lispxid _) (enterevalqt))) (freshline t) lp (promptchar lispxid t lispxhistory) (cond ((null (ersetq (lispx (lispxread t t) lispxid))) (setq toplispxbufs (or (clbufs t) toplispxbufs)) (terpri t))) (* |this| |errorset| |is| |so| |that| evalqtforms |dont| |get| |unnecessarily|  |evaluated| |following| |each| |error| |on| |typein.|  |they| |are| |only| |for| |control-d.|) (go lp)))) (enterevalqt (lambda nil (* |lmm| " 7-Nov-86 03:47") (* |;;| "this is not on resetforms, because it is important that it be done first, i.e. before the form specified on resetforms.") (* |;;| " with unwinders it is mainly unnecessary") (* |;;| "with multiple execs, it is probably wrong") (resetrestore nil 'reset) (mapc resetforms (function (lambda (x) (ersetq (eval x))))))) (userexec (lambda (lispxid lispxxmacros lispxxuserfn) (* |Pavel| " 7-Jul-86 11:26") (* |wt:| 28-jul-77 22 1) (resetvars (readbuf readbufsource rereadflg) (cl:when (null lispxid) (setq lispxid '_)) lp (cl:when (> (position t) 0) (cl:terpri t)) (promptchar lispxid t lispxhistory) (ersetq (lispx (lispxread t t) lispxid lispxxmacros lispxxuserfn)) (go lp)))) (lispxread (lambda (file rdtbl) (* ajb "16-Jul-85 15:54") (* * a |generalized| read. i\f readbuf |is| nil\, |performs| |and| apply*  lispxreadfn file. |which| |it| |returns| |as| |its| |value.|  i\f readbuf |is| |not| nil\, "reads" |and| |returns| |the| |next| |expression|  |on| readbuf) (prog (x) lp (cond ((null (and readbuf (setq readbuf (lispxreadbuf readbuf t)))) (setq rereadflg nil) (setq x (cond ((or (eq lispxreadfn 'read) (imagestreamtypep t 'text)) (* s\o |the| |call| |will| |be| |linked,| |so| |the| |user| |can| |break| |on|  |read.|) (read file rdtbl)) (t (apply* lispxreadfn file rdtbl)))) (cond ((and (listp x) ctrluflg) (* |User| |typed| |control-u| |during| |read.|  |The| |assemble| |is| |an| openr.) (setq ctrluflg nil) (cond ((null (nlsetq (edite x))) (* |Exited| |with| stop\, |just| |save| |input| |but| |do| |not| |evaluate|  |or| |execute.|) (setq rereadflg 'abort))))) (return x))) (* rereadflg |is| |later| |used| |to| |compare| |with| |the| |first| |entry|  |on| |the| |history| |list| |to| |see| |if| |the| |reread| |expression| came  |from| |that| |entry.|) (setq x (car readbuf)) (setq readbuf (cdr (setq rereadflg readbuf))) (return x)))) (lispxreadbuf (lambda (rdbuf stripseprsflg) (* |lmm| " 4-NOV-82 23:59") (* |takes| |care| |of| |'cleaning'| |up| |read| |buffer| |by| |stripping| |off|  |extra| "" |and| |processing| |repeated| |reads.|  |used| |by| |promptchar,| |editor,| |lispxread,| |etc.|) (prog (tem) lp (cond ((nlistp rdbuf) (return nil)) ((eq (car rdbuf) histstr0) (* histstr0 |is| \a |delimiter| |for|  |eadline|) (setq rdbuf (cdr rdbuf)) (go lp)) ((eq (car rdbuf) histstr3) (* histstr3 |is| \a |marker| |for| |flagging| |the| |event| |that| |the|  |readbuf| |came| |from|) (setq rdbuf (cddr rdbuf)) (go lp)) ((eq (car rdbuf) histstr2)) (t (return rdbuf))) (setq redocnt (add1 redocnt)) (setq rdbuf (cdr rdbuf)) (setq rdbuf (cond ((setq tem (cond ((numberp (car rdbuf)) (and (igreaterp (car rdbuf) 0) (sub1 (car rdbuf)))) ((eval (car rdbuf)) (car rdbuf)))) (nconc (|for| xx |in| (cadr rdbuf) |until| (eq xx histstr2) |collect| (cond ((nlistp xx) xx) (t (copy xx)))) (cons histstr0 (cons histstr2 (cons tem (cdr rdbuf)))))) ((lispxreadbuf (cddr rdbuf))) (t (prin1 redocnt t) (prin1 " repetitions. " t) nil))) (go lp)))) (lispxreadp (lambda (flg) (* |lmm| " 5-NOV-82 00:00") (* flg |corresponds| |to| |the| flg |argument| |to| readp\, |i.e.|  |if| flg=nil\, |returns| ni\l |if| |just| \a |c.r.|  |waiting.| |if| flg=t\, |returns| t |if| |anything| |waiting|) (cond ((and readbuf (setq readbuf (lispxreadbuf readbuf))) t) ((readp t t) (or flg (neq (peekc t) (constant (character (charcode eol))))))))) (lispxunread (lambda (lst event) (* |lmm| " 5-NOV-82 00:02") (setq readbuf (append lst (cond (event (cons histstr3 (cons event readbuf))) (t (cons histstr0 readbuf))))))) (lispx (lambda (lispxx lispxid lispxxmacros lispxxuserfn lispxflg)(* |lmm| "11-Jul-86 18:01") (* lispx (|for| lisp |eXec|) |is| |designed| |to| |save| |the| |user| |the|  |task| |of| |writing| |an| |exec| |by| |allowing| |him| |to| |easily| |tailor|  lispx |to| |his| |applications.| i\n |this| |way,| |the| |user| |also| |gets|  |the| |benefit| |of| |the| |history| |features| |built| |into| lispx.  lispx |determines| |the| |type| |of| |input,| |performs| |any| |extra| |reads|  |that| |are| |necessary,| |saves| |the| |input|  (\s) |and| |the| |value| |on| |the| |history,| |and| |prints| |and| |returns|  |the| |value.| (lispx |must| |do| |the| |printing| |since| |for| |history|  |commands,| |see| |below,| |nothing| |can| |be| |printed| |until| |the| |next|  |call| |to| lispx.) -  -  |There| |are| |currently| |six| |different| |classes| |of| |inputs:|  (1) eval\, |i.e.| |forms;| (2) apply\, |i.e.|  |functions| |and| |arguments;| (3) |forms| |without| |parentheses,| |i.e.|  |lines,| |usually| |specifying| clisp |transformation,| |e.g.|  for x in |...| i\n |this| |case| |the| |entire| |line| |is| |treated| |as| \a  |form| |and| |EVALed;| (4) |commands,| |similar| |to| |edit| |macros,|  |definitions| |are| |looked| |up| |on| lispxmacros\;  (5) |user| |input,| |as| |determined| |by| |applying| lispxuserfn.  i\f |this| |yields| t\, |the| |value| |of| |the| |event| |is| |the| |value|  |of| lispxvalue\, |which| |must| |be| |set| |by| lispxuserfn\;  |and| (6) |history| |commands.| -  |For| |types| 1 |thru| 5\, lispx |saves| |the| |inputs| |on| |the| |history|  |list| |before| |executing.| |Thus| |even| |if| |the| |operation| |is|  |aborted,| |the| |user| |can| |redo| |it,| |fix| |it,| |etc.|  -  |For| |commands| 1\, 2\, |and| 3\, |the| |function| |name| |is| |looked| |up|  |on| lispxfns. |if| |the| |user| |simply| |wants| \a |different| |function|  |called| |for| |tty| |inputs| |then| |in| |his| |program,| |such| |as| |is|  |the| |case| |with| setq |or| set\, |this| |can| |easily| |be| |done| |by|  |putting| (|fn1| . |fn2|) |on| |the| |list| lispxfns.  -  |For| |commands| |of| |type| 6\, lispx |simply| |unreads| |the| |appropriate|  |information| |and| |exits.| |This| |means| |that| |if| \a |user| |function|  |calls| lispx |when| |it| |cannot| |interpret| |the| |input,| |history|  |operations| |will| |work| |provided| |only| |that| |the| |user| |function|  |obtains| |its| |input| |via| lispxread\, |and| |that| |any| |inputs|  |interpreted| |by| |the| |user| |function| |also| |save| |the| |input| |on|  |the| |history| |list.| |This| |is| |the| |way| break1 |uses| lispx.) (* i\f lispxflg |is| t\, |any| |history| |commands| |are| |executed| |in|  |this| |call| |to| lispx\, |instead| |of| |unreading| |and| |exiting.|  |This| |is| |used| |when| |the| |calling| |function| |knows| |that| |the|  |input| |should| (|must|) |be| |processed| |here,| |for| |example,| |in| |the|  e |command| |from| |the| |editor.| |Without| |this,| e redo |would| |cause|  |the| |input| |referred| |to| |by| |the| redo |command| |to| |be| |interpreted|  |as| |edit| |commands| |instead| |of| lispx |inputs.|  i\f lispxflg |is| |'RETRY,| clock |is| |backed| |up| |to| |force| \a break |on|  |any| |error.|) (and (null lispxxmacros) (setq lispxxmacros lispxmacros)) (and (null lispxxuserfn) lispxuserfn (fgetd 'lispxuserfn) (setqq lispxxuserfn lispxuserfn)) (* i\f lispx |is| |called| |with| |its| |fifth| |argument,| lispxxuserfn\,  |non-NIL,| |it| |is| |applied| (|with| apply*)\.  |Otherwise,| |the| |top| |level| |value| |of| lispxuserfn |is| |checked,| |and|  |if| |non-NIL,| lispxuserfn |itself| |is| |called.|  (|The| |former| |is| |for| |calls| |from| userexec\, |the| |latter|  |corresponds| |to| |the| |old| |way| |of| |doing| |it.|  |Similarly,| |if| lispx |is| |called| |with| |its| |fourth| |argument,|  lispxxmacros\, |non-NIL,| |it| |is| |used| |as| |the| |list| |of| |macros,|  |otherwise| |the| |top| |level| |value| |of| lispxmacros |is| |used.|)) (prog ((helpclock (clock 2)) lispxop lispxlistflg lispxline (lispxhist lispxhist) lispy lispz lispxvalue lispxtem dontsaveflg (helpflag (cond ((eq helpflag 'break!) (* |so| |that| |when| |you| |get| |in| |the| |break,| |doesnt| |always| |break|  |below| |that|) (gettopval 'helpflag)) (t helpflag))) lispxvalues) (declare (specvars helpflag lispxvalue lispxvalues)) (cond ((null lispxx) (* |Spurious| |right| |parentheses|  |or| |bracket.|) (return (print nil t))) ((nlistp lispxx) (setq lispxline (readline t (list lispxx) t)) (* |The| |third| |argument| |specifies| |that| |if| |there| |is| |juut| \a "]"  |or| ")" |on| |the| |line,| |it| |should| |be| |read| |as| \a nil\, |i.e.|  |the| |line| |should| |be| (nil)\. i\t |also| |specifies| |that| |if| |the|  |line| |begins| |with| \a |list| |which| |is| |not| |preceded| |by| |any|  |spaces,| |the| |list| |is| |to| |terminate| |the| |line| |regardless| |of|  |whether| |or| |not| |it| |is| |terminated| |by| \a ].  |Thus| |the| |usr| |can| |type| |fn| (|args|)) (setq lispxx (car lispxline)) (setq lispxline (cdr lispxline)) (* |done| |this| |way| |so| |control-W| |will| |work| |on| |first| |thing|  |read| |from| |inside| |of| |the| |readline.|) ) ((and (null rereadflg) (not (syntaxp (setq lispxtem (chcon1 (lastc t))) 'rightparen t)) (not (syntaxp lispxtem 'rightbracket t)) (cdr (setq lispxline (readline t (list lispxx) t)))) (* |The| |expression| |input| |was| \a |lis,| |although| |it| |was| |not|  |terrnated| |with| \a |right| |parent| |or| |bracket,| |e.g.|  (quote zap\,) |and| |furthermore| |there| |was| |something| |else| |on| |the|  |same| |line,| |so| |treat| |it| |as| |line| |input.|  |This| |enables| |user| |to| |type| (quote foo) :expr) (setq lispxx lispxline))) top (cond ((listp lispxx) (setq lispxop (car lispxx)) (setq lispxline (cdr lispxx)) (* |This| |is| |for| |convenience| |of| |history| |commands:| |regardless| |of|  |whether| |the| |command| |was| |typed| |as| \a |list| |or| \a |line,| lispxop  |is| |always| |the| |name| |of| |the| |command,| lispxline |its| |'arguments'.|  i\f |it| |turns| |out| |that| lispxop |is| |not| \a |history| |command,|  lispxline |will| |be| |set| |back| |to| nil  (|below| notcom)) (setq lispxlistflg t)) ((not (litatom lispxx)) (go notcom) (* |User| |might| |have| |typed| |in| \a |number| |followed| |by| |something|  |else|) ) (t (setq lispxop lispxx))) select (cond ((and rereadflg (eq (setq lispxtem (car (listget1 (caar lispxhistory) '*history*))) 'original))) ((setq lispy (fassoc lispxop lispxxmacros)) (and lispxlistflg (setq lispxline nil)) (* |so| |historysave| |at| do-it |will| |get| |called| |with| |the| |right|  |aaguments.|) (setq dontsaveflg (null (cadr lispy))) (go do-it)) ((setq lispy (fassoc lispxop lispxhistorymacros)) (setq dontsaveflg (null (cadr lispy))) (go redocom))) (selectq lispxop (original (go redocom)) (e (cond ((null lispxline) (go notcom))) (setq lispxx (setq lispxop (car lispxline))) (setq lispxline (cdr lispxline)) (go notcom)) ((retry redo repeat fix use |...|  |redo| |repeat| |use| |fix| |retry|) (go redocom)) ((|name| name) (cond ((null lispxline) (* t\o |allow| |user| |to| |have| name |as| |the| |name| |of| \a |variable.|) (go do-it))) (go redocom)) ((undo |undo|) (and (setq lispxhist (historysave lispxhistory lispxid nil lispxop lispxline)) (frplaca (cddr lispxhist) (undolispx lispxline)))) ((|retry:| retry\:) (and (eq rereadflg 'abort) (error!)) (setq helpflag 'break!) (setq lispxx (car lispxline)) (setq lispxline (cdr lispxline)) (go top)) ((|forget| forget) (and (eq rereadflg 'abort) (error!)) (mapc (cond (lispxline (lispxfind lispxhistory lispxline 'entries)) (t (car lispxhistory))) (function (lambda (x) (undolispx2 x t)))) (print '|forgotten| t t)) (?? (and (eq rereadflg 'abort) (error!)) (printhistory (cond ((eq (car lispxline) '@@) (setq lispxline (cdr lispxline)) archivelst) (t lispxhistory)) lispxline nil nil t)) ((|archive| archive) (and (eq rereadflg 'abort) (error!)) (* |Since| |these| |the| |commands| |do| |not| |call| historysave\, |we| |must|  |check| |for| |control-U| |followed| |by| stop |here.|) (cond (archivelst (frplaca archivelst (nconc (setq lispxtem (lispxfind lispxhistory lispxline 'copies)) (car archivelst))) (frplaca (cdr archivelst) (iplus (cadr archivelst) (flength lispxtem))) (print '|archived| t t)) (t (print '(|no| |archive| |list|) t)))) (go notcom)) (return '\) notcom (cond ((setq lispy (getprop lispxop '*history*)) (* |command| |defined| |by| \a name  |command.|) (cond ((null lispxline) (cond ((and (or (eq lispxid '_) (eq lispxid '\:)) (boundp lispxop)) (* |User| |typed| |command| |followd| |by| |just| |c.r.|  |since| |command| |is| |also| |the| |name| |of| \a |variable,| |thats|  |probably| |what| |he| |wants,| |especially| |since| |he| |can| |always| |say|  redo @ foo) (setq lispy nil)) (t (go redocom)))) ((null (car lispy)) (error lispxop '"doesn't take any arguments")) (t (go redocom))) (setq lispy nil)) ((fmemb lispxop lispxcoms) (* |Since| lispxop |is| |not| |one| |of| |the| |built| |in| |commands,| |and|  |not| |on| lispxmacros\, |presumably| |the| |user| |has| |included| |it| |on|  lispxcoms |because| |he| |is| |going| |to| |process| |it| |in| lispxuserfn.  i\n |any| |event,| |dont| |want| |to| |do| |any| |spelling| |correction.|) (and lispxlistflg (setq lispxline nil)) (go do-it))) (cond (lispxlistflg (* |Input| |is| \a |single| |list.|) (cond ((eq (car lispxx) 'lambda) (setq lispxline (list (lispxread t t)))) (t (and (litatom (car lispxx)) (cond ((or (fgetd (car lispxx)) (getlis (car lispxx) macroprops) (getlis (car lispxx) '(expr filedef clispword))) (and addspellflg (addspell (car lispxx) 2))) ((and dwimflg (setq lispxop (fixspell (car lispxx) 70 lispxcoms nil lispxx))) (setq lispxline (cdr lispxx)) (go select)))) (and lispxlistflg (setq lispxline nil)))) (go do-it)) ((null lispxline) (* |Input| |is| \a |single| |atom.|) (and (litatom lispxx) (cond ((boundp lispxx) (and addspellflg (addspell lispxx 3))) ((and dwimflg (setq lispxop (fixspell lispxx 70 lispxcoms nil t))) (cond ((listp lispxop) (* run-on |spelling| |error.|) (setq lispxline (list (cdr lispxop))) (setq lispxop (cond ((listp (car lispxop)) (* |synonym|) (cadar lispxop)) (t (car lispxop)))))) (setq lispxx lispxop) (go select)))) (go do-it)) ((not (litatom lispxx))) ((fgetd lispxx) (* |put| |on| spellings2 |even| |though| |in| apply |format| |since| |is|  |also| |good| |in| eval |format|) (and addspellflg (addspell lispxx 2))) ((and dwimflg (null (getlis lispxx '(expr filedef))) (setq lispxop (fixspell lispxx 70 lispxcoms nil t))) (cond ((listp lispxop) (setq lispxline (cons (cdr lispxop) lispxline)) (setq lispxop (car lispxop)))) (setq lispxx lispxop) (go select))) do-it (and (null dontsaveflg) (setq lispxhist (historysave lispxhistory lispxid nil lispxx lispxline))) (cond (lispy (setq lispxvalue (car (setq lispxvalues (cl:multiple-value-list (let ((lispxline (cond (lispxlistflg (cdr lispxx)) (t (nlambda.args lispxline))))) (eval (or (cadr lispy) (caddr lispy)) lispxid))))))) ((and lispxxuserfn (cl:funcall lispxxuserfn lispxx lispxline)) (cond (lispxvalues (setq lispxvalue (car lispxvalues))) (t (setq lispxvalues (list lispxvalue))))) (t (setq lispxvalue (car (setq lispxvalues (cl:multiple-value-list (cond ((null lispxline) (* a |form.|) (eval (cond ((nlistp lispxx) lispxx) (t (lispx/ lispxx))) lispxid)) ((or (cdr lispxline) (and clispflg (litatom lispxx) (car lispxline) (litatom (car lispxline)) (neq (setq lispxtem (nthchar (car lispxline) 1)) '-) (fmemb lispxtem clispchars) (neq (argtype lispxx) 3))) (* |The| |special| |checks| |are| |to| |enable| |constructs| |like| foo _t |to|  |work,| |even| |when| foo |is| |also| |the| |name| |of| \a |function,| |i.e.|  |instead| |of| |applying| foo |to| _t\, (|which| |would| |cause| |an| |unusal|  cdr arglist |error|) (foo _ t) |is| |evaluated,| |which| |will| |invoke| dwim.) (cond ((neq (argtype lispxx) 3) (prin1 " = " t) (print (cons lispxx lispxline) t))) (eval (lispx/ (cons lispxx lispxline)) lispxid)) (t (apply (lispx/ lispxx) (lispx/ (car lispxline) lispxx) lispxid))))))))) (and lispxhist (lispxstorevalue lispxhist lispxvalue lispxvalues)) (return (progn (setq it lispxvalue) (|for| x |in| lispxvalues |do| (showprint x t t)) (cl:values-list lispxvalues))) redocom (setq lispxx (cond (lispxlistflg (list lispxx)) (t (cons lispxx lispxline)))) (* |The| |entire| |history| |command.|) (and (null dontsaveflg) (setq lispxhist (historysave lispxhistory lispxid nil nil nil (list '*history* lispxx '*group* nil)))) (selectq lispxop (original (setq lispy (append lispxline))) ( (setq lispy (lispxusec lispxline lispxhistory))) ((|retry| retry) (setq lispy (cons 'retry\: (append (lispxfind lispxhistory lispxline 'input t))))) ((|name| name) (setq lispxtem (cdr (or (setq lispz (or (fmemb '\: lispxline) (fmemb 'in lispxline) (fmemb '|in| lispxline))) lispxline))) (* lispxtem |coresponds| |to| |the| |event| |specification,| lispz |to| |the|  |end| |of| |the| |arguments,| |if| |any.|) (setq lispz (cond ((null lispz) nil) ((cdr (setq lispz (ldiff (cdr lispxline) lispz))) lispz) ((listp (car lispz)) (* |user| |got| |confused| |and| |put| |in| |an| |extra| |set| |of| |parens.|) (car lispz)) (t lispz))) (setq lispy (lispxfind lispxhistory lispxtem 'input t)) (resetvars ((editquietflg t)) (mapc lispz (function (lambda (x) (cond ((not (historymatch lispy (editfpat x t))) (lispxprin1 x t) (maprint lispxtem t '" does not appear in " '\ nil nil t))))))) (/put (car lispxline) '*history* (cons lispz (cons (append lispy) (lispxfind lispxhistory lispxtem 'copies t)))) (* |The| |reason| |for| |storing| |the| |input| |separate| |frm| |the| |event|  (\s) |is| |that| |the| |user| |may| |have| |performed| name foo use -  |meaning| |the| use |input,| |rather| |than| |the| |normal| |input.|  |The| |reason| |for| |the| |append| |is| |that| |lispy| |will| |also| |be|  |the| |input| |portion| |of| |the| |name| |event| |on| |the| |history| |list,|  |and| |we| |want| |it| |not| |to| |be| |smashed| |when| |that| |entry| |is|  |slips| |off| |the| |end| |of| |the| |history| |list.|) (/remprop (car lispxline) 'state) (/setatomval 'lispxcoms (union (list (car lispxline)) lispxcoms)) (/setatomval 'historycoms (union (list (car lispxline)) historycoms)) (cond ((getd (car lispxline)) (maprint (cons (car lispxline) '(|is| |also| |the| |name| |of| \a |function.| |When| |typed| |in,| |its| |interpretation| |as| \a |history| |command| |will| |take| |precedence.|)) t "****Note: " '\ nil nil t))) (print (car lispxline) t t)) ((redo |redo| repeat |repeat|) (cond ((null (some lispxline (function (lambda (x tail) (selectq (car tail) ((while until |while| |until|) (cond ((and (cdr tail) (neq (car (setq lispxtem (nleft lispxline 1 tail)) ) 'f)) (* |backs| |up| |one|) (setq lispxline (and lispxtem (ldiff lispxline (cdr lispxtem)))) (and (null (cddr (setq lispxtem (cdr tail)))) (or (listp (car lispxtem)) (boundp (car lispxtem)) (not (fncheck (car lispxtem) t t t lispxtem))) (setq lispxtem (car lispxtem))) (cond ((or (eq (car tail) 'until) (eq (car tail) '|until|)) (setq lispxtem (list 'not lispxtem))) ) t))) ((times |times|) (cond ((and (null (cdr tail)) (setq lispxtem (nleft lispxline 1 tail)) (neq (car lispxtem) 'f)) (setq lispxline (ldiff lispxline lispxtem )) (setq lispxtem (or (numberp (car lispxtem )) t))))) nil))))) (setq lispxtem (or (eq lispxop 'repeat) (eq lispxop '|repeat|))))) (setq lispy (lispxfind lispxhistory lispxline 'input t)) (cond ((eq lispxid '*) (* |For| |editor.|) (setq lispy (copy lispy))) (t (* |Cant| |allow| |same| |input| |to|  |appear| |twice| |in| |history.|) (setq lispy (append lispy)))) (cond (lispxtem (setq lispy (list histstr2 lispxtem lispy))))) ((fix |fix|) (setq lispy (copy (lispxfind lispxhistory (cond ((setq lispxtem (fmemb '- lispxline)) (* |User| |can| |say| fix -  |and| |give| |the| |commands.| |Then| |he| |doesn't| |have| |to| |wait| |for|  |editor| |to| |print| edit\, |and| |him| |to| |type| ok |at| |the| |end.|  |Also,| |the| |commands| |stored| |on| |the| |history| |list| |in| |this|  |fashion| |can| |be| |reexecuted| |by| \a redo fix |command.|) (ldiff lispxline lispxtem)) (t lispxline)) 'input t))) (setq lispy (cond ((streamprop (getstream t) 'fixfn) (apply* (streamprop (getstream t) 'fixfn) (getstream t) lispy (cdr lispxtem))) (t (lispxfix lispy (cdr lispxtem))))) (* |usually| |defined| |as| |just| \a |call| |to| editl |but| |can| |be|  |advised| |to| |handle| |string| |situations,| |such| |as| |in| bard.  i\f |the| |stream| |has| \a fix |function| apply |it| |instead| |of| |the|  |default|) ) ((use |use|) (setq lispy (lispxuse lispxline lispxhistory lispxhist))) (|...| (cond ((null lispxline) (error '"... what??" '\ t))) (setq lispy (lispxfind lispxhistory nil 'entry t)) (setq lispxtem (cond ((listget1 lispy '...args)) ((setq lispxtem (listget1 lispy 'use-args)) (* |The| caaar |is| |because| car |is| |the| |list| |of| useargs |which| |is|  \a |list| |of| |list| |of| |variables.|) (cons (caaar lispxtem) (cdr lispxtem))) ((setq lispxtem (listget1 lispy '*history*)) (* e.\g. \a |lispxmacro| |or|  |lispxhistorymacro.|) (cons (cadr lispxtem) (lispxgetinput lispxtem (cons lispxtem (cdr lispy))))) (t (setq lispy (lispxfind lispxhistory nil 'input t)) (cons (cond ((or (null (cdr lispy)) (eq (cadr lispy) histstr0)) (* eval |input,| |substitute| |for|  |first| |argument| |which| |is| cadar) (cadar lispy)) ((nlistp (cadr lispy)) (* |e.g.| pp foo) (cadr lispy)) (t (* apply |input.| |e.g.|  load (foo) |substitute| |for| foo) (caadr lispy))) lispy)))) (* lipxtem |is| |now| \a |dotted| |pair| |of| |aagument| |and| |input.|) (nconc lispxhist (list '...args lispxtem)) (setq lispy (lispxuse0 (list lispxline) (list (list (car lispxtem))) (list (cdr lispxtem))))) (setq lispy (cond ((eq (car lispy) lispxop) (* |from| |lispxhistorymacro.|) (eval (or (cadr lispy) (caddr lispy)) lispxid)) ((null (car lispy)) (* |Command| |defined| |by| |name|  |command,| |with| |no| |arguments|) (append (cadr lispy))) (t (* |From| |name| |command.|) (lispxuse0 (list lispxline) (list (car lispy)) (list (cadr lispy))))))) (* lispy |is| |now| |the| |input.|) (and (null rereadflg) (fmemb histstr2 (listp lispy)) (setq redocnt -1)) (* |the| -1 |is| |because| |the| |first| |thing| |that| |will| |happen| |will|  |be| \a |call| |to| |lispxrepeatread| |which| |will| |increment| |redocnt| |to|  0 |the| |check| |is| |made| |here| |instead| |of| |inside| |the| |selectq| |at|  redo |because| |of| |cases| |where| |user| |does| use |on| |an| |event|  |involving| \arepeat |input|) (and lispxhist (frplaca lispxhist lispy)) (cond ((eq lispxop 'name) (* name |is| |handled| |as| \a |history| |command| |so| |that| |the| |command|  |is| |stored| |before| |it| |tries| |to| |do| |the| |lookup,| |and| |to|  |share| |in| |other| |common| |code.| |but| |it| |is| |not| |actually| |redone|  |or| |unread.|) ) (lispxflg (resetvars (readbuf) (lispxunread lispy lispxhist) lp (cond ((null (setq readbuf (lispxreadbuf readbuf))) (return))) (lispx (lispxread t t) lispxid) (go lp))) (t (lispxunread lispy lispxhist))) (return lispxhist)))) (lispx/ (lambda (x fn vars) (* |lmm| "16-FEB-83 06:42") (cond ((or (null lispxfns) (null lispxhistory)) x) (fn (* i\f fn |is| |not| nil\, |it| |is| |the| |name| |of| \a |function| |and| x  |is| |its| |argument| |list.| |Subsitution| |only| |occurs| |for| |functions|  |that| eval\, |such| |as| rpaq\, setq\, |and| \e.) (cond ((nlistp x) (* x |is| |an| (|atomic|) |argument| |list,| |e.g.|  |type| pp foo\, |don't| |substitute| |for| foo.) x) ((selectq (argtype fn) ((1 3) (* |Slightly| |different| |check| |than| |in| lispx/1 |and| dwimify1\, |etc.|  |This| |check| |wants| |to| |know| |whether| |this| |function| |calls| |eval|  |explicitly| |itself.| |The| |others| |say| |are| |the| |aaguments| |evaluated|  |either| |by| |virtue| |of| |it| |being| \a |normal| |function,| |or| |an|  |eval| |call.|) (eqmemb 'eval (getprop fn 'info))) nil) (lispx/1 x t)) (t x))) ((listp x) (* x |is| \a |form.|) (lispx/1 x)) (t (or (cdr (fassoc x lispxfns)) x))))) (lispx/1 (lambda (x tailflg) (* |lmm| " 2-Jul-85 02:20") (and x (prog ((tem1 (car x)) tem2 tem3) (cond ((nlistp x) (return x)) ((listp (car x)) (setq tem1 (lispx/1 (car x))) (go do-cdr))) (cond (tailflg (go do-cdr))) (setq tem1 (or (cdr (fassoc (car x) lispxfns)) (car x))) (selectq (car x) (quote (return x)) ((function f/l) (setq tem2 (lispx/1 (cdr x))) (go do-cdr1)) ((lambda nlambda) (setq tem3 (cadr x)) (prog ((vars (cond ((nlistp tem3) (cons tem3 vars)) (t (append tem3 vars))))) (setq tem2 (lispx/1 (cddr x) t))) (go do-cddr1)) (prog (prog ((vars (nconc (mapcar (cadr x) (function (lambda (x) (cond ((atom x) x) (t (setq tem3 t) (car x)))))) vars))) (setq tem2 (lispx/1 (cddr x) (car x)))) (cond ((null tem3) (go do-cddr1))) (return (cons 'prog (cons (mapcar (cadr x) (function (lambda (x) (cond ((atom x) x) (t (lispx/1 x t)))))) tem2)))) (setq (cond ((fmemb (cadr x) vars) (* |don't| |have| |to| |be| |undoable| |for| |bound| |vriabes,| |e.g.|  |in| mapc\, prog\, |etc.|) (setq tem1 (car x)) (go do-cddr)))) (cond ((and (or (eq (setq tem2 (argtype (car x))) 1) (eq tem2 3)) (not (or (eq (setq tem2 (getprop (car x) 'info)) 'eval) (fmemb 'eval tem2)))) (* d\o |not| |substitute| |unless| |you| |know| |that| |the| |function| |will|  |evaluate| |its| |arguments,| |as| |with| ersetq\, resetvar\, |etc.|  |The| |eason| |for| |not| |just| |returning| |is| |that| |the| |function|  |name| |may| |be| |on| |lispxfns,| |e.g.|  setqq |becomes| savesetqq.) (setq tem2 (cdr x)) (go do-cdr1)) ((and clisparray (null (fgetd (car x))) (setq tem3 (gethash x clisparray))) (return (lispx/1 tem3))) ((null (fgetd (car x))) (* |lispx/| |will| |get| |caaled| |again| |anyway| |after| |it| |is|  |translated,| |and| |if| |we| |do| |substitution| |now,| |may| |change| \a  |setq| |to| savesetq |that| |refers| |to| \a |variable| |bound| |in| \a bind\,  |etc.|) (return x)))) do-cdr (setq tem2 (lispx/1 (cdr x) t)) do-cdr1 (return (cond ((and (eq tem1 (car x)) (eq tem2 (cdr x))) x) (t (cons tem1 tem2)))) do-cddr (setq tem2 (lispx/1 (cddr x) t)) do-cddr1 (return (cond ((and (eq tem1 (car x)) (eq tem2 (cddr x))) x) (t (cons tem1 (cons (cadr x) tem2))))))))) (lispxeval (lambda (lispxform lispxid) (* |Evaluates| lispxform |same| |as| |though| |were| |typed| |in| |to| lispx.  i\f lispxid |not| |given,| _ |is| |used.|) (prog (lispxhist) (or lispxid (setq lispxid '_)) (setq lispxhist (historysave lispxhistory lispxid nil lispxform)) (frplaca (cddr lispxhist) (eval (cond ((nlistp lispxform) lispxform) (t (lispx/ lispxform))) lispxid)) (return (caddr lispxhist))))) (lispxstorevalue (lambda (event value values) (* |lmm| " 1-May-86 12:36") (cond (event (frplaca (cddr event) value) (lispxput 'lispxvalues values nil event))))) (historysave (lambda (history id input1 input2 input3 props) (* |wt:| "18-NOV-78 21:52") (* history |is| |of| |the| |form| (list index size mod) index |is| |between| 0  |and| mod (mod |is| |usually| 100 |or| \a |multiple| |of| 100) |and| |is|  |automatically| |incremented| |each| |time| |an| |entry| |is| |added.|  size |is| |the| |length| |of| list\, |and| |after| list |reaches| |that|  |length,| |old| |entries| |at| |the| |end| |are| |cannibalized| |and| |moved|  |to| |the| |front| |when| |new| |entries| |are| |added.|  |The| |form| |of| |each| |entry| |on| |the| history |list| |is|  (input id value . props) |Value| |is| |initialized| |to| \.) (* |the| |value| |of| |historysave| |is| |the| |corresponding| |event| |or|  |subevent| |in| |the| |case| |of| |gruped| |events.|  |Groups| |are| |represented| |by| |the| |value| |of| |the| |property| *group*  |which| |is| \a |list| |of| |the| |form|  (|event| |event| |...| |event|)\. |each| |subevent| |can| |have| |its| |own|  *group* |property,| |or| history |property,| |etc.|  historysave |automatically| |retrieves| |the| |appropraite| |subevetn,| |no|  |matter| |ho| |nested,| |when| |given| |an| |input| |that| |has| |been|  |reread,| |so| |the| |calling| |functio| |doesnt| |hae| |to| |distinguish|  |between| |new| |input| |and| |reexecution| |of| |input| |whose| |history|  |entry| |has| |alredy| |been| |set| |up.|) (prog ((l (car history)) (index (cadr history)) (size (caddr history)) (mod (or (cadddr history) 100)) (n 0) x y tem) (cond ((or (nlistp history) (and (nlistp (car history)) (car history))) (return nil)) ((and rereadflg (setq x (cdr (fmemb '*group* (cadr (fmemb histstr3 rereadflg)))))) (* |This| |input| |is| |the| |result| |of| \a |history| |command,| |so| |do|  |not| |make| \a |new| |entry.|) (cond ((and (fmemb histstr2 rereadflg) (not (ilessp redocnt \#redocnt))) (cond ((setq tem (cdr (fmemb '*redocnt* (setq x (caar history))))) (frplaca tem redocnt)) (t (nconc x (list '*redocnt* redocnt)))) (return x))) (frplaca x (nconc1 (car x) (setq y (cons (cond (input1 (cons input1 (cons input2 input3))) (input2 (cons input2 input3)) (t input3)) (cons id (cons '\ props)))))) (return y))) (cond ((igreaterp (setq index (add1 index)) mod) (setq index (iplus index (minus mod))))) lp (cond ((cddr l) (add1var n) (setq l (cdr l)) (go lp)) ((igreaterp size (iplus n 2)) (frplaca history (cons (setq x (list nil nil nil)) (car history))) (go smash))) (setq x (cdr l)) (cond ((and archivelst (neq history edithistory) (or (and archivefn (archivefn (caar x) (car x))) (listget1 (car x) '*archive*))) (frplaca archivelst (cons (lispxfind1 (car x)) (car archivelst))) (frplaca (cdr archivelst) (add1 (cadr archivelst))))) (frplacd l nil) (* |Moves| |last| |entry| |to|  |front.|) (frplaca history (frplacd x (car history))) (setq x (car x)) (* x |is| |now| |the| |entry| |to|  |be| |canniablized.|) smash (frplaca (cdr history) index) (cond ((listp id) (* id |is| |the| |new| |entry.|) (frplaca (car history) (setq y id)) (go out)) ((nlistp (setq y (car x))) (* y |is| |now| |the| |input|  |portion| |of| |the| |entry.|) (setq y (cons nil nil)))) (cond (input1 (* |Means| input |is| (input1 input2 . input3) |used| |primarily| |for| apply  input |when| input1 |is| |function| |and| input2 |args.|) (cond ((cdr y) (* |Cannibalize| |previous| |input.|) (frplaca y input1) (frplaca (cdr y) input2) (frplacd (cdr y) input3)) (t (setq y (cons input1 (cons input2 input3)))))) (input2 (* |Means| input |is| (input2 . input3) |used| |primarily| |for| eval input  |when| input2 |is| |form.|) (frplaca y input2) (frplacd y input3)) (t (* |Means| input |is| input3\, |used| |primarily| |for| |line| |inputs,| |such|  |as| history |commands.|) (setq y input3))) (frplaca x y) (frplaca (setq y (cdr x)) id) (cond ((eq (cadr y) '\) (* y |may| |correspond| |to| |an| |event| |that| |has| |not| |yet| |completed|  |but| |will,| |e.g.| |you| |are| |in| \a |break| |and| |have| |performed|  |more| |than| 30 |operations.| |Therefore| y\, |or| |at| |least| |that| |part|  |of| y |beginning| |with| |the| |value| |field,| |should| |not| |be| |used|  |since| |it| |will| |be| |smashed| |wen| |the| |event| |finishes.|) (frplacd y (setq y (cons '\ props)))) (t (frplaca (setq y (cdr y)) '\) (frplacd y props))) (cond (historysaveforms (prog ((event x)) (mapc historysaveforms (function (lambda (x) (ersetq (eval x)))))))) out (cond ((eq id '*) (lispxwatch editstats)) (t (lispxwatch lispxstats))) (cond ((eq rereadflg 'abort) (error!))) (return x)))) (lispxfind (lambda (history line type backup quietflg) (* |wt:| 24-jun-76 14 18) (* quietflg=t |means| |tell| |editor| |not| |to| |print| |messages| |on|  |alt-mode| |matches.| |Used| |by| lispxuse |and| lispxusec.) (cond ((null history) (error '"no history." '\ t))) (* line |specifies| |an| |entry| |or| |entries| |on| history\, |and| type |the|  |desired| |format| |of| |the| |value.| lispxfind |uses| historyfind |to| |get|  |the| |corresponding| |entries,| |and| |then| |decides| |what| |to| |do| |with|  |them.|) (resetvars ((editquietflg (or editquietflg quietflg))) (return (prog ((lst (car history)) (index (cadr history)) (mod (or (cadddr history) 100)) (line0 line) val tem) (cond (backup (* |Used| |when| |want| |to| |refer| |to| history |before| |last| |entry| |was|  |made,| |e.g.| |for| undo |so| undo undo |will| |work.|) (setq lst (cdr lst)) (setq index (sub1 index)))) (cond ((and rereadflg (null (caar lst))) (* |Special| |glitch| |to| |allow| \a |bad| |history| |command| |which|  |contains| |relative| |event| |numbers| |to| |be| |reexecuted| |without|  |changing| |the| |event| |specification| |provided| |it| |is| |done|  |immediately,| |e.g.| |user| |types| use foo for fie in -2\, lispx |types| fie  ? |user| |can| type use fum for fie\, |and| -2 |will| |refer| |to| |the|  |correct| |event.|) (setq lst (cdr lst)) (setq index (sub1 index)))) find (cond ((null line) (setq val (car lst)) (cond ((and (or (eq (caar val) 'undo) (eq (caar val) '|undo|)) (neq (caddr val) '\)) (* s\o |can| |say| undo |then| redo  |or| use.) (setq val (cadr lst)))) (go single)) ((eq (car line) '@@) (* |Archive.|) (return (lispxfind archivelst (cdr line) type)))) lp (setq val (nconc val (lispxfind0 (ldiff line0 (setq line0 (or (fmemb 'and (cdr line0)) (fmemb '|and| (cdr line0)))) ) lst index mod))) (cond ((setq line0 (cdr line0)) (go lp))) group (cond ((null (cdr val)) (setq val (car val)) (go single))) (* val |is| \a |list| |of| |events.|) (and archiveflg (mapc val (function (lambda (x) (lispxput '*archive* t nil x))))) (return (and val (selectq type (input (mapconc val (function (lambda (val) (append (setq tem (lispxgetinput (cond ((null (car val)) (listget1 val '*history*)) (t (car val))) val)) (and (neq (car (last tem)) histstr0) (list histstr0))))))) ((entry entries) val) ((copy copies) (mapcar val (function lispxfind1))) (go bad)))) (* |For| copies |and| entries\, |calling| |function| |expects| \a list |of|  |events,| |for| copy |and| entry |only| |one.|  (|however| |if| |the| |event| |specification| |produces| |more| |than| |one|  |event,| lispxfind |treats| copy |and| entry |the| |same| |as| copies |and|  entries.) entry |is| |used| |by| lispxuse |and| |the| |...|  |Command.| |Entries| |is| |used| |by| forget.  copies |is| |used| |by| name |and| archive.  -  redo |is| |the| |same| |as| input |except| |that| |the| |value| |returned|  |will| |not| |be| |copied| |again,| |so| |it| |must| |be| |copied| |here.|) single (* val |is| \a |single| |event.|) (and archiveflg (lispxput '*archive* t nil val)) (return (and val (selectq type (input (append (setq tem (lispxgetinput (cond ((null (car val)) (listget1 val '*history*)) (t (car val))) val)) (and (neq (car (last tem)) histstr0) (list histstr0)))) (entry val) (entries (list val)) (copy (lispxfind1 val)) (copies (list (lispxfind1 val))) (go bad)))) bad (error type '"- LISPXFIND ?" t)))))) (lispxgetinput (lambda (input event) (* |separate| |function| |so| |can|  |be| |advised|) input)) (remember (lambda (line) (* |wt:| "28-FEB-79 23:52") (markaschanged (getexpressionfromeventspec line) 'expressions))) (getexpressionfromeventspec (lambda (line) (* |wt:| "28-FEB-79 23:49") (prog ((inputlines (lispxfind lispxhistory line 'input t)) next ll) (setq ll (|while| (setq next (fmemb histstr0 inputlines)) |collect| (setq ll (ldiff inputlines next)) (setq inputlines (cdr next)) (cond ((eq (car ll) 'retry\:) (setq ll (cdr ll)))) (setq ll (cond ((null (cdr ll)) (car ll)) (t (selectq (argtype (car ll)) ((1 3) (cons (car ll) (cond ((cddr ll) (cdr ll)) (t (cadr ll))))) (cond ((cddr ll) (error ll "Can't remember")) ((eq (car ll) 'set) (cons 'setq (cons (caadr ll) (mapcar (cdadr ll) (function kwote))))) (t (cons (car ll) (mapcar (cadr ll) (function kwote))))))))) ll)) (return (mkprogn ll))))) (lispxfind0 (lambda (line0 lst index mod) (* |lmm| "10-MAY-81 20:57") (* |Value| |is| \a |list| |of| |entries| |on| |history| |list.|  |lispxfind| |decides| |whatto| |do| |with| |them.|) (prog (historyflg thruflg l1 l2 tem) (cond ((null (cdr line0)) (go out))) (selectq (car line0) (@ (* e.\g. redo @ foo\, |same| |as| |retrieve| foo |and| |then| redo |it,|  |except| |don't| |get| |two| |copies| |of| foo |on| history |list.|) (cond ((null (setq line0 (getprop (setq tem (cadr line0)) '*history*))) (error tem '" ?" t))) (return (cond ((eq type 'input) (* cadr |is| |the| |input,| cddr |the| |events| |themselves.|  |Note| |that| |input| |may| |correspond| |to| |the| |history| |portion,| |e.g.|  |user| |says| name foo use. |The| list list |is| |because| |value| |of|  lspxfind0 |is| |supposed| |to| |be| \a |list| |of| |events.|) (list (list (cadr line0)))) (t (cddr line0))))) ((from |from|) (* |Input| |can| |be| |of| |form| -  from |...| to |...| |or| |...| to |...| -  from |...| thru |...| |or| |...| thru |...|  -  from ...\; to ...\; thru ...\; |or| \a |list| |of| |entries.|) (setq l1 (cdr line0))) ((to thru |to| |thru|) (setq thruflg (or (eq (car line0) 'thru) (eq (car line0) '|thru|))) (setq l2 (historyfind lst index mod (cdr line0) line)) (go ldiff)) ((all |all|) (return (historyfind lst index mod line0 line))) nil) (* a\t |this| |point| |we| |know| |it| |did| |not| |begin| |with| to |or| thru.) (cond ((and (or (setq tem (fmemb 'to line0)) (setq tem (fmemb '|to| line0)) (setq thruflg (setq tem (or (fmemb 'thru line0) (fmemb '|thru| line0))))) (neq (car (nleft line0 1 tem)) 'f)) (setq l1 (historyfind lst index mod (ldiff (or l1 line0) tem) line)) (setq l2 (historyfind lst index mod (cdr tem) line))) (l1 (* |Line| |began| |with| from\, |but| |did| |not| |contain| \a to |or| thru.) (setq l1 (historyfind lst index mod l1 line))) (t (go out))) ldiff (return (cond ((null l1) (and thruflg (setq l2 (cdr l2))) (ldiff lst l2)) ((null l2) (dreverse (cond ((null (cdr l1)) (append lst)) (t (ldiff lst (cdr l1)))))) ((tailp l2 l1) (and thruflg (setq l2 (cdr l2))) (ldiff l1 l2)) (t (and (null thruflg) (setq l2 (cdr l2))) (dreverse (cond ((null (cdr l1)) (append l2)) (t (ldiff l2 (cdr l1)))))))) out (setq tem (car (historyfind lst index mod line0 line))) (return (list (cond ((and historyflg (eq type 'input)) (cons (listget1 tem '*history*) (cdr tem))) (t tem))))))) (lispxfind1 (lambda (x) (* |Produces| \a |copy| |of| \a |history| |entry| |so| |that| |if| |the|  |history| |list| |recycles,| |and| |this| |entry| |is| |cannibalized,| |the|  |value| |of| lispxfind1 |is| |not| |touched.|) (cons (append (car x)) (cons (car (setq x (cdr x))) (cons (car (setq x (cdr x))) (cdr x)))))) (historyfind (lambda (lst index mod eventaddress lispxfindflg) (* |wt:| " 9-SEP-78 23:25") (* |Searches| \a |history| |list| |and| |returns| |the| |tail| |for| |which|  |car| |is| |the| |indicated| |entry.|) (prog ((l lst) (x0 eventaddress) z tem _flg =flg val predflg allflg) lp (selectq (setq z (car eventaddress)) (\\ (setq l (and (equal (caaar lasthistory) (cdr lasthistory)) (car lasthistory)))) ((all |all|) (cond ((null lispxfindflg) (* all |only| |interpreted| |on|  |calls| |from| |lispxfind.|) (error z '" ?" t))) (setq allflg t) (setq eventaddress (cdr eventaddress)) (go lp)) (= (setq =flg t) (setq eventaddress (cdr eventaddress)) (go lp)) (_ (setq _flg t) (setq eventaddress (cdr eventaddress)) (go lp)) ((f \f) (cond ((setq tem (cdr eventaddress)) (* |Otherwise,| f |is| |not| \a |special| |symbol,| |e.g.|  |user| |types| redo f\, |meaning| |search| |for| f |itself.|) (setq eventaddress (cdr eventaddress)) (setq z (car eventaddress)))) (historyfind1)) ((suchthat |suchthat|) (* |What| |follows| suchthat |is| \a |functionto| |be| |applied| |to| |two|  |arguments,| |input| |portion,| |and| |entire| |event,| |and| |if| |true,|  |approves| |that| |event.| |can| |be| |used| |in| |conjuncton| |with| all |or|  _.) (setq predflg t) (setq eventaddress (cdr eventaddress)) (setq z (car eventaddress)) (historyfind1)) (cond ((or _flg =flg (not (numberp z))) (historyfind1) (* |Does| |searching.|) ) ((ilessp z 0) (* |Entries| |on| lst |are| |numbered| |starting| |at| index |and| |decreasing|  |by| 1 |if| z |is| |negative,| |count| |back| |corresponding| |number.|  |if| z |is| |positive,| |count| |forward,| |except| |when| z |is| |first|  |member| |on| x |in| |which| |case| z |is| |the| |absolute| |event| |address,|  |i.e.| z |refers| |to| |the| |index| |that| |would| |be| |printed| |by| |the|  ?? |command.|) (setq l (nth l (iminus z)))) ((neq l lst) (* |move| |forward.|) (setq l (nleft lst (add1 z) l))) ((not (igreaterp z index)) (setq l (cdr (nth l (idifference index z))))) ((igreaterp (setq tem (iplus index mod (iminus z))) 0) (* e.\g. |Suppose| |history| |numbers| |have| |just| |'RECYCLED',| |i.e.|  |current| |history| |is| 5\, |and| |user| |references| 97 |must| |subtract| 97  |from| 105 |to| |find| |how| |far| |back| |the| |entry| |is.|  |The| igreaterp |check| |is| |in| |case| |user| |simply| |typed| |very| |large|  |number.|) (setq l (cdr (nth l tem)))))) (cond ((null l) (cond (allflg (return val)) ((and dwimflg lispxfindflg (some line (function (lambda (eventaddress tail) (and (not (fmemb eventaddress lispxfindsplst)) (fixspell eventaddress 70 lispxfindsplst t tail) ))))) (* o\n |calls| |from| lispxfind\, |attempt| |to| |find| \a |misspelling| |in|  |the| |line,| |and| |if| |so,| |do| \a |retfrom.|) (retfrom 'lispxfind (lispxfind history line type backup quietflg)))) (error z '" ?" t)) ((null (setq eventaddress (cdr eventaddress))) (setq lasthistory (cons l (cons (car (setq tem (caar l))) (cdr tem)))) (* |For| \\ |command.| |Input| |is| |copied| |so| |that| |it| |can| |be| |used|  |as| \a |check| |to| |see| |whether| |this| |particular| |event| |has| |been|  |recycled| |since| |it| |was| |last| |referenced.|) (cond ((null allflg) (return l)) (t (setq val (nconc1 val (car l))) (setq eventaddress x0))))) (setq l (cdr l)) (setq _flg nil) (setq =flg nil) (setq predflg nil) (setq historyflg nil) (go lp)))) (historyfind1 (lambda nil (* |rmk:| "27-MAY-82 23:11") (* |SEarches| |history| |list,| |forward| |or| |backward,| |depending| |on|  _flg\, |looking| |for| z (|bound| |in| |historyfind|)\, |and| |resetting| l  |to| |the| |corresponding| |tail.|) (prog (pat1 pat2 tem pred) (and _flg (cond ((eq l lst) (setq l (last l))) (t (setq l (nleft lst 2 l))))) (cond (predflg) ((and (atom z) (eq (chcon1 z) (charcode _))) (setq pat1 (editfpat (pack (cdr (dunpack z chconlst1))) t))) (t (setq pat2 (editfpat z t)))) lp (cond ((cond ((and (or (eq (setq tem (caaar l)) 'undo) (eq tem '|undo|)) (eq (caddar l) (quote))) (* undo |events| |that| |failed| |to|  |find| |are| |ignored.|) nil) ((and (setq tem (listget1 (car l) '*history*)) pat2 (or (eq pat2 (car tem)) (eq pat2 (car (listp (car tem)))))) (setq historyflg t)) (predflg (apply* z (caar l) (car l))) (pat1 (edit4e pat1 (caaar l))) (t (historymatch (cond (=flg (cond ((fmemb '*history* (car l)) (* |The| |value| |slot| |is| |bell| -  |and| |is| |meaningless.|) (setq l (cdr l)) (go lp1)) ((and (fmemb '*print* (car l)) (or (eq (setq tem (caaar l)) 'ok) (eq tem 'eval))) (* |Although| |the| |value| |of| |this| |event| |may| |match| |the| |pattern,|  |the| |user| |never| |saw| |the| |value| |printed| |out|  (|and| printhistory) |wouldnt| |print| |it| |out.|) (setq l (cdr l)) (go lp1))) (caddar l)) ((and (null rereadflg) (null (caar l))) (listget1 (car l) '*history*)) (t (caar l))) pat2 (car l)))) (return l)) (_flg (setq l (nleft lst 1 l))) (t (setq l (cdr l)))) lp1 (cond ((null l) (return nil))) (go lp)))) (historymatch (lambda (input pat event) (editfindp input pat t))) (valueof (nlambda line (* |wt:| "29-OCT-78 22:25") (* |the| |problem| |is| |how| |to| |decide| |whether| |or| |not| |the| |last|  |event| |is| |to| |be| |considered| |in| |interpreting| |the| |history|  |specificaton.| |if| |the| |use| |typed,|  (valueof -1)\, |he| |obviously| |doesnt| |want| |this| |event| |considered.|  |on| |the| |other| |hand,| |if| |user| |types| |to| |editor|  (i \: (valueof -1)) |he| |does| |want| |mos| |recent| |event| |considered.|  valueof |simply| |uses| |the| |appearance| |of| valueof |in| |the| |event| |as|  |an| |indicator.| |however,| \a |separate| |function| valuof |is| |provided|  |so| |that| |users,| |e.g.| |kaplan,| |can| |define| |lispxmacros| |which|  |effectively| |call| valueof.) (valuof line (editfindp (caaar lispxhistory) 'valueof)))) (valuof (lambda (line backup) (* |lmm| " 1-May-86 23:20") (declare (specvars line backup historyflg)) (prog (y historyflg) (setq y (cond ((null line) (cadar lispxhistory)) (t (car (historyfind (cond (backup (setq y (sub1 (cadr lispxhistory))) (cdar lispxhistory)) (t (setq y (cadr lispxhistory)) (car lispxhistory))) y (or (cadddr lispxhistory) 100) (mklist line)))))) (return (valuof-event y))))) (valuof-event (lambda (y) (* |lmm| " 1-May-86 23:20") (cond ((null (setq line (listget1 y '*group*))) (cl:values-list (listget (cdddr y) 'lispxvalues))) ((null (cdr line)) (valuof-event (car line))) (t (|for| x |in| line |collect| (valuof-event x)))))) (lispxuse (lambda (line history lspxhst) (* |wt:| 18-aug-76 10 31) (prog (expr args vars state lst tem use-args genlst lispxhist) (* lispxhist |rebound| |to| nil |so| esubst |doesn't| |put| |any| |side|  |information| |on| |history.|) (cond ((null line) (error '"use what??" '\ t))) (setq state 'vars) lp (* |Parses| |input| |string| |using|  \a |finite| state |machine.|) (cond ((or (null lst) (null (cdr line)) (null (selectq (car line) ((for |for|) (cond ((eq state 'vars) (setq vars (nconc1 vars lst)) (setq tem (append lst tem)) (setq state 'args) (setq lst nil) t))) ((and |and|) (cond ((eq state 'expr) nil) (t (cond ((eq state 'args) (setq args (nconc1 args lst))) ((eq state 'vars) (* e.\g. |user| |types| use a and b |following| |previous| use |command.|) (setq vars (nconc1 vars lst)))) (setq state 'vars) (setq lst nil) t))) ((in |in|) (cond ((and (eq state 'vars) (null args)) (setq vars (nconc1 vars lst)) (setq tem (append lst tem)) (setq state 'expr) (setq lst nil) t) ((eq state 'args) (setq args (nconc1 args lst)) (setq state 'expr) (setq lst nil) t))) nil))) (setq lst (nconc1 lst (car line))) (cond ((member (car line) tem) (setq genlst (cons (cons (car line) (gensym)) genlst)) (* |This| |enables| use a b for b a\, use a for b and b for a\, |or| use a for  b and b c for a) )))) (cond ((setq line (cdr line)) (go lp))) (selectq state (vars (setq vars (nconc1 vars lst))) (args (setq args (nconc1 args lst))) (expr (setq expr lst)) (help)) (* args |and| vars |are| |lists| |of|  |lists.|) (and (null expr) args (setq expr (list 'f (caar args)))) (* expr |specifies| |expressions| |to| |be| |substituted| into.  e.\g. use foo for fie in fum |or| use foo for fie.  i\n |latter| |case,| |searches| |for| fie.  |The| f |is| |added| |because| |of| |numbers,| |e.g.|  use 3 for 4 |means| |find| 4\, |whereas| use foo for fie in 4 |means| |the| 4th  |expression| |back.|) (and (null args) (setq use-args (cadr (fmemb 'use-args (lispxfind history expr 'entry t t))))) (setq expr (lispxfind history expr 'input t t)) (* expr |now| |is| |the| |expression| (\s) |to| |be| |substituted| |into.|) (cond (args (* |Arguments| |specifically| |named| |by| |user,| |i.e.|  use |...| for |...|) (setq use-args (cons args expr)) (* t\o |be| |saved| |in| |case| |user| |gives| \a |use| |command| |referring|  |to| |this| |event.|) (setq expr (list expr))) (use-args (* |Arguments| |specified| |by|  |other| use |command.|) (setq args (car use-args)) (setq expr (list (cdr use-args))) (cond ((and (cdr args) (null (cdr vars))) (* |User| |types| |command| |of| |the| |form| use a for b and c for d |and|  |follows| |this| |with| use e f.) (setq vars (mapcar (car vars) (function cons)))))) ((or (cdr vars) (cdr (fmemb histstr0 expr))) (* |More| |than| |one| |operation,| |but| |no| args.  |e.g.| use foo in a and b\, |or| |else| |multiple| |arguments| |specified| |in|  |the| |referent| |operation,| |e.g.| |it| |was| |of| |the| |form| use a for b  and c for d.) (error '"for what ?" '\ t)) (t (* e.\g. load (foo) |followed| |by|  use makefile recompile.) (setq tem (cond ((cddr expr) (car expr)) (t (caar expr)))) (setq args (list (list tem))) (setq expr (list expr)))) (setq tem (lispxuse0 vars args expr genlst)) (nconc lspxhst (list 'use-args use-args)) (return tem)))) (lispxuse0 (lambda (vars args expr genlst) (* |wt:| 24-jun-76 14 19) (* |Does| |the| |actual| |substitution| |after| lispxuse |has| |computed| |the|  vars\, args\, |and| exprs. vars |is| \a |list| |of| |lists| |of| |variables,|  |the| |extra| |list| |corresponding| |to| |the| |clauses| |of| |an| and\,  |e.g.| use a b for c and d e for f |would| |have|  ((a b) (d e)) |for| vars\, |and| ((c) (f)) |for| aags.) (prog (val) lp (* |Argument| |names| |have| |either| |been| |supplied| |by| |user| |or|  |obtained| |implicitly| |from| |another| use |command.|) (setq expr (lispxuse1 (car vars) (car args) expr)) (setq vars (cdr vars)) (cond ((setq args (cdr args)) (go lp)) (vars (error '"use what??" '\ t))) (mapc genlst (function (lambda (x) (lispxsubst (car x) (cdr x) expr t)))) (setq val (mapconc expr (function (lambda (x) x)))) (* |Samples:| use a b c d for x y |means| |substitute| a for x and b for y and  |then| |do| |it| |again| |with| c for x and d for y.  |This| |is| |equivalent| |to| use a c for x and b d for y |except| |that|  |first| |case| |can| |be| |followed| |by| use e f |and| |will| |automatically|  |substitute| for x and y. -  use a b c for d and x y z for w |means| |three| |operations,| |with| a for d  and x for w |in| |the| |first,| b for d and y for w |in| |the| |second,| |etc.|  -  use a b c for d and x for y |means| |three| |operations,| |first| |with| a for  d and x for y |second| |with| b for d and x for y |etc.|  |equivalent| |to| use x for y and a b c for d.  -  use a b c for d and x y for z |causes| |error.|  -  use a b for b a |will| |work| |correctly,| |but| use a for b and b for a |will|  |result| |in| |all| |B's| |being| |changed| |to| |A's.|  |The| |general| |rule| |is| |substitution| |proceeds| |from| |left| |to|  |right| |with| |each| |'AND'| |handled| |separately.|  |Whenever| |the| |number| |of| |variables| |exceeds| |the| |number| |of|  |expressions| |available,| |the| |expressions| |multiply.|) (return val)))) (lispxuse1 (lambda (vars args exprs) (prog ((v vars) (a args) (e (copy exprs)) l vflg aflg eflg tem) (setq l e) lp (cond ((and genlst (setq tem (sassoc (car v) genlst)) (strpos ' (car a))) (error '"sorry, that's too hard." (quote) t))) (rplaca e (cond ((eq (car v) '!) (setq v (cdr v)) (lsubst (car v) (car a) (car e))) (t (lispxsubst (or (cdr tem) (car v)) (car a) (car e) t)))) (cond ((null (setq v (cdr v))) (setq vflg t))) (cond ((null (setq a (cdr a))) (setq aflg t))) (cond ((and a v) (go lp)) ((setq e (cdr e)) (go lp1))) (cond ((and (null a) (null v)) (return l))) (setq eflg t) (setq l (nconc l (setq e (copy exprs)))) lp1 (cond ((and eflg vflg aflg) (error '"huh??" (quote) t))) (cond ((null v) (setq v vars))) (cond ((null a) (setq a args))) (go lp)))) (lispxsubst (lambda (x y z charflg) (* |used| |by| |lispx,| |lispxuse| |and| |lispxuse0.|  \a |separate| |function| |so| |can| |be| |advised| |for| |applications|  |involving| |history| |lists| |contaiing| |different| |types| |of| |inputs,|  |e.g.| |strings.|) (cond ((null charflg) (subst x y z)) (t (esubst x y z t))))) (lispxusec (lambda (line history) (* |lmm| " 7-MAY-82 19:30") (* a |short| |version| |of| |the| use |command.|  $ x y |is| |equivalent| |to| use $y$ for $x$.  |user| |can| |also| |say| $ x = y |or| $ x -> y |or| $ y for x.  |User| |can| |specify| |event| |with| in.  |However,| |the| |distributivity| |of| use |command| |is| |not| |allowed.|  (|Note| |that| $ |can| |be| |ued| |even| |if| |character| |editing| |is| |not|  |being| |performed,| |e.g.| $ foo fie |is| |probably| |easier| |to| |type|  |than| use fie for foo.) i\f |the| |event| |referred| |to| |contains| |an|  error |property,| $ |first| |performs| |the| |substitution| |on| |that|  |argument,| |and| |then| |substitues| |the| |corrected| |offender| |into| |the|  |expression.| i\f |the| |user| |omits| \a |second| |argument,| |e.g.|  |types| $ foo\, |the| |substitution| |is| |performed| |for| |the| |offender.|  (i\n |this| |case| |there| |must| |be| |an| error |property.|)) (prog (lispy lispz lispxtem lispx1 lispx2 lispxin lispxhist) (* lispxhist |rebound| |to| nil |so| esubst |doesn't| |put| |any| |side|  |information| |on| |history.|) (cond ((cdr (setq lispxin (fmemb 'in line))) (* |May| |be| |of| |the| |form| $ x in --  |or| $ x y in --. |Note| |that| -- |may| |specify| \a |group.|) (setq line (ldiff line lispxin)) (setq lispy (lispxfind history (setq lispxin (cdr lispxin)) 'entry t t))) ((null (cdr line)) (* |Form| |is| |just| $ x.) (setq lispy (lispxfind history nil 'entry t t)))) (cond ((null (cdr line)) (cond ((setq lispz (cdr (fmemb '*error* lispy))) (setq lispx1 (car line)) (setq lispx2 (car lispz)) (go out)) ((numberp (car line)) (return (lispxusec (cons 'in line) history))) (t (* |Since| |no| |second| |argument| |was| |specified,| |this| |has| |to| |be|  |an| error |correction.| |Note| |that| |it| |may| |have| |been| |of| |the|  |form| $ x |or| $ x in --.) (prin1 '"Unable to figure out what you meant in:" t) (printhistory1 lispy t) (error!))))) (* |Identify| |substituTEE| |and|  |substituTOR.|) (cond ((cddr line) (selectq (cadr line) ((to = ->) (setq lispx1 (caddr line)) (setq lispx2 (car line))) (for (setq lispx1 (car line)) (setq lispx2 (caddr line))) (error (cadr line) '" ?" t))) (t (setq lispx1 (cadr line)) (setq lispx2 (car line)))) (cond ((null lispy) (* |Form| |of| |command| |is| $ x y. |Search| |for| x.) (setq lispxtem (cond ((and (nlistp lispx1) (nlistp lispx2) (not (strpos ' lispx2))) (pack (list ' lispx2 '))) (t lispx2))) (setq lispy (lispxfind history (setq lispxin (list lispxtem)) 'entry t t)))) (setq lispz (cdr (fmemb '*error* lispy))) (* t\o |see| |if| |the| |event| |contains| |an| |error| |property.|  |Note| |that| |even| |if| |the| |user| |identifies| |an| |event| |using| in\,  |if| |the| |event| |contains| |an| |offender,| |the| |character| |substitution|  |takes| |place| |only| |in| |the| |error,| |not| |in| |the| |whole|  |expression.| |See| |comment| |below| |after| editfindp.) out (setq lispy (copy (lispxfind history lispxin 'input t t))) (* |Need| |another| |call| |to| lispxfind |even| |though| |we| |already| |have|  |the| |entry| |because| lispxfind |contains| |smarts| |about| |what| |fields|  |to| |extract,| |e.g.| |did| |use| |say| $ x y in use |or| $ x y in -1\, |etc.|) (cond ((null lispz) (* |The| |user| |is| |using| $ |to| |avoid| |having| |to| |type| |alt-modes|  |around| |his| |patterns,| |otherwise| |this| |is| |essentially| \a  |simplified| use |command.| |therefore| |perform| |the| |substitution| |in|  |the| |input,| |i.e.| lispy) (go out1))) (* |There| |was| |an| |error| |in|  |the| |indicated| |event.|) (setq lispz (car lispz)) (cond ((and (eq lispx2 lispz) (numberp lispx1)) (* $ 1 2 |will| |change| |all| |1's| |to| |2's| |occurring| |inside| |of|  |other| |atoms| |or| |strings.| i\t |will| |not| |change| |the| |number| 1 |to|  |the| |number| 2.0 |Therefore,| |this| |check| |is| |for| |the| |case| |where|  |the| |'bad| |guy'| |was| \a |number,| |and| |the| |user| |was| |typing| |in|  |the| |correct| |number| |in| |the| |form| |of| $ |number.|  |this| |frequently| |happens| |for| |correction| |to| edit |commands,| |e.g.|  |user| |types| (|ri| 1 33) |meaning| (|ri| 1 3) |and| |then| |corrects| |by| $  3) (setq lispxtem lispx1) (and (null editquietflg) (prin2 lispx2 t t) (prin1 '-> t) (print lispx1 t t)) (* |Since| |in| |all| |other| |cases,| esubst |will| |cause| \a |message| |of|  |this| |form| |to| |be| |printed,| |we| |also| |do| |it| |here| |to| |be|  |consistent.|) ) ((null line) (cond ((or (litatom lispz) (stringp lispz)) (* |The| |effect| |of| |this| |is| |to| |cause| |the| |operation| |that|  |caused| |the| |error| |to| |be| |reexecuted| |this| |time| |searching| |for|  |something| |thatis| |'close'| |to| |the| |word| |producing| |the| |error,|  |e.g.| |user| |types| insert -- after condd |and| |system| |types| condd ?  |user| |then| |types| $ |causing| |the| |command| insert --  after condd$$ |to| |be| |executed.|) (setq lispxtem (pack (list lispz ')))) (t (error '" ? " (quote) t)))) ((null (nlsetq (setq lispxtem (esubst lispx1 lispx2 (cond ((listp lispz) (copy lispz)) (t lispz)) nil t)))) (* |The| |indicated| |characters| |do| |not| |appear| |in| lispz\, |the|  |offender.| |Therefore,| |perform| |the| |substitution| |in| |the| |input.|) (go out1))) (cond ((editfindp lispy lispz) (return (subst lispxtem lispz lispy))) (t (prin2 lispz t t) (prin1 '" does not appear in " t) (printhistory1 (list lispy) t) (error!))) out1 (return (esubst lispx1 lispx2 lispy t t))))) (lispxfix (lambda (input coms) (* |wt:| 14-jul-76 14 38) (prog (lispxhist) (return (car (last (editl (cond ((and (eq (cadr input) histstr0) (null (cddr input))) (* |eval| |input,mkae| |the| |current|  |expression| |be| |the| |form|  |itself.|) (list (car input) input)) (t (list input))) coms))))))) (changeslice (lambda (n history l) (* |wt:| "22-NOV-78 23:27") (* |Undoing| \a changslice |involves| |another| |call| |to| changeslice\,  |because| |you| |can't| |just| |replace| |the| |pointers| |because| |of| |the|  |ring| |buffer| |aspect| |of| |the| |history| |list.|  i\n |other| |words,| |the| |place| |where| |events| |was| |deleted| |may| |now|  |be| |the| |beginning| |of| |the| |history| |list.|  |Therefore,| l |represents| |the| |forgotten| |events| |if| |any,| |in| |the|  |case| |that| |the| |history| |list| |is| |being| |enlarged| |by| |virtue| |of|  |undoing| \a changeslice.) (cond ((ilessp n 3) (error n '"is too small")) ((null history) (and lispxhistory (changeslice n lispxhistory)) (and edithistory (changeslice n edithistory))) (t (nconc (car history) l) (* |Add| |forgotten| |events,| |if|  |any.|) (undosave (list 'changeslice (caddr history) history (cdr (setq l (nth (car history) n)))) lispxhist) (frplaca (cddr history) n) (frplaca (cdddr history) (itimes (add1 (iquotient (sub1 n) 100)) 100)) (cond (l (* |Chop| |off| |the| |extra|  |events.|) (frplacd l))))) n)) (lispxstate (lambda (name state) (* state |is| |either| |'BEFORE'| |or|  |'AFTER'|) (prog (x y) (cond ((null (setq x (getp name 'state))) (* |First| |time| state |command|  |used| |with| name.) (cond ((null (setq y (cdr (getp name '*history*)))) (* |The| cdr |is| |because| car  |corresponds| |to| |he| |'arguments'|) (error name '" ?" t)) ((eq state 'after) (return 'was))) (mapc y (function undolispx2)) (/put name 'state (cons 'before lispxhist))) ((eq state (car x)) (return 'was)) (t (undolispx2 x) (/put name 'state (cons state lispxhist)))) (return state)))) (lispxtypeahead (lambda nil (* |wt:| 1-jul-76 14 26) (prog (x l) lp (prin1 '> t) (nlsetq (selectq (setq x (lispxread t t)) ((ok go) (mapc l (function lispxunread)) (retfrom 'lispxtypeahead)) (stop (retfrom 'lispxtypeahead)) (fix (setq l (edite l))) (q (prin1 '\\\\ t) (print (cond ((nlistp (setq x (car l))) x) (t (car x))) t t) (setq l (cdr l))) (?? (mapc (reverse l) (function (lambda (x) (printhistory1 (list x '>) t t))))) (setq l (cons (cond ((or (listp x) (null (readp t))) (list x)) (t (* |The| |extra| |argument| |to| readline |is| |so| |that| \a |line|  |consisting| |of| |just| ]\, |e.g.| foo] |will| |read| |is| |as|  (nil) |instead| |of| nil.) (cons x (readline t nil t)))) l)))) (go lp)))) ) (ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100) (GREETHIST)) (DECLARE\: DONTEVAL@LOAD DOCOPY (RPAQQ \#REDOCNT 3) (RPAQQ ARCHIVEFLG T) (RPAQQ ARCHIVEFN NIL) (RPAQQ ARCHIVELST (NIL 0 50 100)) (RPAQQ DISPLAYTERMFLG NIL) (RPAQQ EDITHISTORY (NIL 0 30 100)) (RPAQQ HERALDSTRING NIL) (RPAQQ LASTEXEC NIL) (RPAQQ LASTHISTORY NIL) (RPAQQ LISPXBUFS NIL) (RPAQQ LISPXHIST NIL) (RPAQQ LISPXHISTORY (NIL 0 30 100)) (RPAQQ LISPXPRINTFLG T) (RPAQQ LISPXUSERFN NIL) (RPAQQ MAKESYSDATE NIL) (RPAQQ PROMPT#FLG T) (RPAQQ REDOCNT NIL) (RPAQQ SYSOUT.EXT SYSOUT) (RPAQQ SYSOUTFILE WORK) (RPAQQ SYSOUTGAG NIL) (RPAQQ TOPLISPXBUFS NIL) ) (ADDTOVAR LISPXHISTORYMACROS (TYPE-AHEAD (LISPXTYPEAHEAD)) (??T NIL (PROG (TEM) (RESETVARS ((PRETTYTRANFLG T)) (RESETFORM (OUTPUT T) (PRINTDEF (COND ((NULL (CDAR (SETQ TEM (LISPXFIND LISPXHISTORY LISPXLINE 'ENTRY)))) (CAAR TEM)) (T (CAR TEM))) NIL T))) (TERPRI T) (RETURN NIL)))) (ADDTOVAR LISPXMACROS (SHH NIL (COND ((OR (CDR (LISTP LISPXLINE)) (AND (FMEMB (LASTC T) '(\) ])) (LITATOM (CAR LISPXLINE)))) (APPLY (CAR LISPXLINE) (COND ((AND (LISTP (CADR LISPXLINE)) (NULL (CDDR LISPXLINE))) (CADR LISPXLINE)) (T (CDR LISPXLINE))))) (T (EVAL (COND (LISPXLINE (CAR LISPXLINE)) (T 'SHH)))))) (RETRIEVE (PROG ((X (GETP (CAR LISPXLINE) '*HISTORY*)) REREADFLG) (COND ((NULL X) (ERROR (CAR LISPXLINE) '" ?" T))) (MAPC (CDDR X) (FUNCTION (LAMBDA (X) (HISTORYSAVE LISPXHISTORY X)))) (RETURN (CAR LISPXLINE)))) (BEFORE (LISPXSTATE (CAR LISPXLINE) 'BEFORE)) (AFTER (LISPXSTATE (CAR LISPXLINE) 'AFTER)) (OK (RETFROM (OR (STKPOS 'USEREXEC) 'LISPX) T T)) (REMEMBER\: (PROG1 (LET (FILEPKGFLG) (EVAL (LISPX/ (CAR LISPXLINE)) LISPXID)) (MARKASCHANGED (CAR LISPXLINE) 'EXPRESSIONS))) (REMEMBER (REMEMBER LISPXLINE))) (ADDTOVAR LISPXCOMS SHH RETRIEVE BEFORE AFTER OK REMEMBER\: REMEMBER TYPE-AHEAD ??T) (ADDTOVAR HISTORYCOMS RETRIEVE TYPE-AHEAD) (ADDTOVAR LISPXFINDSPLST FROM TO THRU SUCHTHAT ALL AND) (ADDTOVAR BEFORESYSOUTFORMS (SETQ SYSOUTDATE (DATE)) (PROGN (COND ((NULL FILE) (SETQ FILE SYSOUTFILE)) (T (SETQ SYSOUTFILE (PACKFILENAME 'VERSION NIL 'BODY FILE)))) (COND ((AND (NULL (FILENAMEFIELD FILE 'EXTENSION)) (NULL (FILENAMEFIELD FILE 'VERSION))) (SETQ FILE (PACKFILENAME 'BODY FILE 'EXTENSION SYSOUT.EXT)))))) (ADDTOVAR RESETFORMS (SETQ READBUF NIL) (SETQ READBUFSOURCE NIL) (SETQ TOPLISPXBUFS (OR (CLBUFS T) TOPLISPXBUFS)) (COND ((EQ CLEARSTKLST T) (COND ((EQ NOCLEARSTKLST NIL) (CLEARSTK)) (T (* |clear| |all| |stack| |pointers| EXCEPT |those| |on| NOCLEARSTKLST.) (MAPC (CLEARSTK T) (FUNCTION (LAMBDA (X) (AND (NOT (FMEMB X NOCLEARSTKLST)) (RELSTK X)))))))) (T (MAPC CLEARSTKLST (FUNCTION RELSTK)) (SETQ CLEARSTKLST NIL)))) (ADDTOVAR HISTORYSAVEFORMS ) (ADDTOVAR LISPXCOMS  |...| ?? FIX FORGET NAME ORIGINAL REDO REPEAT RETRY UNDO USE |fix| |forget| |name| |redo| |repeat| |retry| |undo| |use|) (ADDTOVAR SYSTATS (LISPXSTATS LISPX INPUTS) (UNDOSAVES UNDO SAVES) (UNDOSTATS CHANGES UNDONE) NIL (EDITCALLS CALLS TO EDITOR) (EDITSTATS EDIT COMMANDS) (EDITEVALSTATS COMMANDS INVOLVING EVALUATING A LISP EXPRESSION) (EDITESTATS USES OF AN E COMMAND TYPED IN DIRECTLY) (EDITISTATS USES OF AN I COMMAND TYPED IN DIRECTLY) (EDITUNDOSAVES EDIT UNDO SAVES) (EDITUNDOSTATS EDIT CHANGES UNDONE) NIL (P.A.STATS P.A. COMMANDS) NIL (CLISPIFYSTATS CALLS TO CLISPIFY) NIL (FIXCALLS CALLS TO DWIM) (FIXTIME) (ERRORCALLS WERE DUE TO ERRORS) (DWIMIFYFIXES WERE FROM DWIMIFYING) NIL "OF THOSE DUE TO ERRORS:" (TYPEINFIXES WERE DUE TO ERRORS IN TYPE-IN) (PROGFIXES WERE DUE TO ERRORS IN USER PROGRAMS) (SUCCFIXES1 OF THESE CALLS WERE SUCCESSFUL) NIL "OF THE CALLS DUE TO DWIMIFYING:" (SUCCFIXES2 WERE SUCCESSFUL) NIL (SPELLSTATS OF ALL DWIM CORRECTIONS WERE SPELLING CORRECTIONS) (CLISPSTATS WERE CLISP TRANSFORMATIONS) (INFIXSTATS OF THESE WERE INFIX TRANSFORMATIONS) (IFSTATS WERE IF/THEN/ELSE STATEMENTS) (I.S.STATS WERE ITERATIVE STATEMENTS) (MATCHSTATS WERE PATTERN MATCHES) (RECORDSTATS WERE RECORD OPERATIONS) NIL (SPELLSTATS1 OTHER SPELLING CORRECTIONS\, E.G. EDIT COMMANDS) NIL (RUNONSTATS OF ALL SPELLING CORRECTIONS WERE RUN-ON CORRECTIONS) NIL (VETOSTATS CORRECTIONS WERE VETOED) NIL) (ADDTOVAR NOCLEARSTKLST ) (APPENDTOVAR AFTERSYSOUTFORMS (COND ((LISTP SYSOUTGAG) (EVAL SYSOUTGAG)) (SYSOUTGAG) ((OR (NULL USERNAME) (EQ USERNAME (USERNAME NIL T))) (TERPRI T) (PRIN1 HERALDSTRING T) (TERPRI T) (TERPRI T) (GREET0) (TERPRI T)) (T (LISPXPRIN1 '"****ATTENTION USER " T) (LISPXPRIN1 (USERNAME) T) (LISPXPRIN1 '": this sysout is initialized for user " T) (LISPXPRIN1 USERNAME T) (LISPXPRIN1 '". " T) (LISPXPRIN1 '"To reinitialize, type GREET() " T))) (SETINITIALS)) (MAPC SYSTATS (FUNCTION (LAMBDA (X) (AND (LISTP X) (EQ (GETTOPVAL (CAR X)) 'NOBIND) (SETTOPVAL (CAR X) NIL))))) (PUTD 'E) (DEFINEQ (greet (lambda (name flg) (* |lmm| "11-Dec-85 17:58") (or (ersetq (prog (file) (tab 0 0 t) (setq username (cond ((null name) (username nil t)) (t (cond ((getd 'setusername) (setusername name))) (mkatom name)))) (|for| x |in| pregreetforms |do| (eval x)) (and (setq file (greetfilename t)) (load file 'sysload)) (* |System| |greeting|) (and (setq file (greetfilename username)) (load file t)) (* |User| |greeting|) (|for| x |in| postgreetforms |do| (eval x)) (greet0) (return t))) (printout t "error during GREET..." t)))) (greet0 (lambda nil (* |lmm| "28-DEC-82 08:49") (cond (greetdates (lispxprin1 (prog ((date (date)) hour tem digit) (return (or (and (fixp (setq digit (nthchar date -1))) (or (and (evenp (lrsh digit 1)) (stringp (setq tem (cdr (sassoc (u-case (substring date 1 6)) greetdates))))) (and (evenp digit) (fixp (setq hour (subatom date 11 12))) (cond ((and firstname (ilessp hour 6)) '"You're working late tonight") ((ilessp hour 12) '"Good morning") ((ilessp hour 18) '"Good afternoon") (t '"Good evening"))) (and (evenp digit 3) "Hello"))) '"Hi"))) t) (cond (firstname (lispxprin1 '", " t) (lispxprin1 firstname t))) (lispxprin1 "." t) (lispxterpri t))))) ) (ADDTOVAR PREGREETFORMS (DREMOVE GREETFORM RESETFORMS) (SETQ CONSOLETIME (SETQ CPUTIME (SETQ EDITIME 0))) (SETQ CONSOLETIME0 (CLOCK 0)) (SETQ CPUTIME0 (CLOCK 2))) (ADDTOVAR POSTGREETFORMS (SETINITIALS) (AND EDITCHARACTERS (APPLY 'SETTERMCHARS EDITCHARACTERS))) (DECLARE\: DONTEVAL@LOAD DOCOPY (RPAQQ GREETHIST NIL) (RPAQQ SYSTEMTYPE NIL) (RPAQQ GREETFORM (LISPXEVAL '(GREET) '_)) (RPAQQ CUTEFLG NIL) (RPAQQ GREETDATES ((" 1-JAN" . "Happy new year") ("12-FEB" . "Happy Lincoln's birthday") ("14-FEB" . "Happy Valentine's day") ("22-FEB" . "Happy Washington's birthday") ("15-MAR" . "Beware the Ides of March") ("17-MAR" . "Happy St. Patrick's day") ("18-MAY" . "It's Victoria Day") (" 1-JUL" . "It's Canada Day") ("31-OCT" . "Trick or Treat") (" 5-NOV" . " it's Guy Fawkes day") ("25-DEC" . "Merry Christmas"))) (RPAQQ USERNAME NIL) (RPAQQ HOSTNAME NIL) (RPAQQ CONSOLETIME 0) (RPAQQ CONSOLETIME0 0) (RPAQQ CPUTIME 0) (RPAQQ CPUTIME0 0) (RPAQQ EDITIME 0) (RPAQQ FIRSTNAME NIL) (ADDTOVAR BEFOREMAKESYSFORMS (SETQ RESETFORMS (CONS GREETFORM RESETFORMS)) (SETQ MAKESYSDATE (DATE))) (ADDTOVAR AFTERMAKESYSFORMS (LISPXEVAL '(GREET) '_)) ) (DEFINEQ (lispxprint (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cons 'print (cond (z (list x y z)) (y (list x y)) (x (list x))))) t lispxhist)) (and (null nodoflg) (print x y z)))) (lispxprin1 (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cond ((and (eq y t) (stringp x)) (* |The| |string| |itself| |will| |be| |stored.|  |This| |saves| 3 |cells.|) x) (t (cons 'prin1 (cond (z (list x y z)) (y (list x y)) (x (list x))))))) t lispxhist)) (and (null nodoflg) (prin1 x y z)))) (lispxprin2 (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cond ((and (eq y t) (nlistp x) (not (stringp x))) (* |The| |atm| |will| |be| |stored|) x) (t (cons 'prin2 (cond (z (list x y z)) (y (list x y)) (x (list x))))))) t lispxhist)) (and (null nodoflg) (prin2 x y z)))) (lispxprintdef (lambda (expr file left def tail nodoflg) (* |wt:| 11-may-76 19 59) (* |so| |uer| |can| |prettyprint| |and| |have| |it| |appear| |on| |history|  |list|) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (list 'lispxprintdef0 expr file left def tail)) t lispxhist)) (and (null nodoflg) (lispxprintdef0 expr file left def tail)))) (lispxprintdef0 (lambda (expr file left def tail) (* |wt:| 11-may-76 19 59) (* |this| |function| |is| |necessar| |to| |implement| |lispxprintdef| |because|  |printdef| |itself| |doesnt| |take| \a |file| |argument.|) (resetform (output file) (printdef expr left def tail)))) (lispxspaces (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cond ((and (eq y t) (eq x 1)) '" ") (t (cons 'spaces (cond (y (list x y)) (x (list x))))))) t lispxhist)) (and (null nodoflg) (spaces x y)))) (lispxterpri (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cond ((eq x t) '" ") (t (cons 'terpri (cond (x (list x))))))) t lispxhist)) (and (null nodoflg) (terpri x)))) (lispxtab (lambda (x y z nodoflg) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cons 'tab (cond (z (list x y z)) (y (list x y)) (x (list x))))) t lispxhist)) (and (null nodoflg) (tab x y z)))) (userlispxprint (lambda (x file z nodoflg) (* |wt:| 14-may-76 13 8) (* |this| |defnition| |can| |be| |movd'd| |to| |any| |user| |function| |whose|  |name| |begins| |with| lispx |to| |make| |it| |work| |like| \a |LISPXprining|  |function.| |it| |requires| |that| |the| |file| |argument| |be| |the| |second|  |argument,| |and| |that| |the| |function| |only| |have| |three| |arguments|) ((lambda (pos) (* |This| |has| |the| |avantage| |of|  |working| |both| |compiled|  |andinterpreted.|) (prog (fn) (setq fn (stkname pos)) (relstk pos) (setq fn (cond ((null (strpos 'lispx fn nil nil t)) (help fn)) (t (mkatom (substring fn 6 -1))))) (and lispxprintflg lispxhist (lispxput '*lispxprint* (list (cons fn (nlist x file z))) t lispxhist)) (return (and (null nodoflg) (apply* fn x file z))))) (stknth -1)))) (lispxput (lambda (prop l addflg lst) (prog (y) (and (null lst) (setq lst (caar lispxhistory))) (* |Puts| |property| |at| |top| |level| |of| |entry.|  |Used| |mostly| |for| |calls| |with| prop=error.) (cond ((setq y (cdr (fmemb prop lst))) (frplaca y (cond (addflg (nconc (car y) l)) (t l)))) (t (nconc lst (list prop l)))) (return l)))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \#REDOCNT ARCHIVEFLG ARCHIVEFN ARCHIVELST BOUNDPDUMMY BREAKRESETVALSLST CAR/CDRNIL CHCONLST1 CLEARSTKLST CLISPARRAY CLISPCHARS CLISPFLG CLISPTRANFLG CONSOLETIME CONSOLETIME0 CPUTIME CPUTIME0 CTRLUFLG CUTEFLG DISPLAYTERMFLG DWIMFLG EDITHISTORY EDITIME EDITQUIETFLG EDITSTATS EVALQTFORMS FILERDTBL FIRSTNAME GREETDATES GREETHIST HISTORYCOMS HISTORYSAVEFN HISTORYSAVEFORMS HISTSTR0 HISTSTR2 HISTSTR3 IT LASTHISTORY LISP-RELEASE-VERSION LISPXBUFS LISPXCOMS LISPXFINDSPLST LISPXFNS LISPXHISTORY LISPXHISTORYMACROS LISPXMACROS LISPXPRINTFLG LISPXREADFN LISPXSTATS LISPXUSERFN MACSCRATCHSTRING NEWUSERFLG P.A.STATS POSTGREETFORMS PREGREETFORMS PRETTYHEADER RANDSTATE READBUFSOURCE REDOCNT REREADFLG RESETFORMS SYSFILES TOPLISPXBUFS USERHANDLE USERNAME) ) (RPAQQ LISP-RELEASE-VERSION 2.0) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK\: LISPXFINDBLOCK LISPXFIND LISPXFIND0 LISPXFIND1 HISTORYFIND HISTORYFIND1 (ENTRIES LISPXFIND HISTORYFIND) (LOCALFREEVARS _FLG L LST Z =FLG HISTORYFLG PREDFLG LINE HISTORY TYPE BACKUP QUIETFLG) (NOLINKFNS HISTORYMATCH LISPXGETINPUT)) (BLOCK\: NIL ENTRY# EVALQT GETEXPRESSIONFROMEVENTSPEC GREET GREET0 HISTORYMATCH HISTORYSAVE LISPX LISPX/ LISPX/1 LISPXEVAL LISPXFIND1 LISPXGETINPUT LISPXPRIN1 LISPXPRIN2 LISPXPRINT LISPXPRINTDEF LISPXPRINTDEF0 LISPXPUT LISPXREAD LISPXREADBUF LISPXREADP LISPXSPACES LISPXSTOREVALUE LISPXSUBST LISPXTAB LISPXTERPRI LISPXTYPEAHEAD LISPXUNREAD LISPXUSE LISPXUSE0 LISPXUSE1 LISPXUSEC PRINTHISTORY PRINTHISTORY1 PRINTHISTORY2 USEREXEC USERLISPXPRINT VALUEOF VALUOF (LOCALVARS . T) (SPECVARS LISPXLINE LISPXID LISPXVALUE LISPXLISTFLG HISTORY ID EVENT BREAKRESETVALS VARS GENLST INITLST NAME MESSAGE) (LINKFNS . T) (NOLINKFNS LISPXTYPEAHEAD UNDOLISPX ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0 LISPXSUBST LISPXFIND HISTORYMATCH PRINTHISTORY DISPLAYTERMP LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT PRINTHISTORY1 PRINTHISTORY2 LISPXFIND HISTORYMATCH LISPXGETINPUT LISPXSUBST ARCHIVEFN LISPXFIX LISPXUSE LISPXUSE0 LISPXSUBST HISTORYMATCH PRINTHISTORY DISPLAYTERMP LISPXSTOREVALUE HISTORYSAVEFN ENTEREVALQT LISPXTYEAHEAD UNDOLISPX GREETFILENAME)) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA VALUEOF) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS HIST COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1985 1986 1987 1988 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL (14585 21330 (PRINTHISTORY 14595 . 16385) (ENTRY# 16387 . 16722) (PRINTHISTORY1 16724 . 19893) (PRINTHISTORY2 19895 . 21328)) (21331 129761 (EVALQT 21341 . 22141) (ENTEREVALQT 22143 . 22698) (USEREXEC 22700 . 23335) (LISPXREAD 23337 . 25140) (LISPXREADBUF 25142 . 27368) (LISPXREADP 27370 . 27919) (LISPXUNREAD 27921 . 28214) (LISPX 28216 . 63911) (LISPX/ 63913 . 65367) (LISPX/1 65369 . 70655 ) (LISPXEVAL 70657 . 71281) (LISPXSTOREVALUE 71283 . 71537) (HISTORYSAVE 71539 . 78823) (LISPXFIND 78825 . 86260) (LISPXGETINPUT 86262 . 86475) (REMEMBER 86477 . 86671) (GETEXPRESSIONFROMEVENTSPEC 86673 . 88783) (LISPXFIND0 88785 . 93059) (LISPXFIND1 93061 . 93489) (HISTORYFIND 93491 . 99065) ( HISTORYFIND1 99067 . 102512) (HISTORYMATCH 102514 . 102589) (VALUEOF 102591 . 103616) (VALUOF 103618 . 104508) (VALUOF-EVENT 104510 . 104915) (LISPXUSE 104917 . 111336) (LISPXUSE0 111338 . 114064) ( LISPXUSE1 114066 . 115691) (LISPXSUBST 115693 . 116113) (LISPXUSEC 116115 . 124356) (LISPXFIX 124358 . 125208) (CHANGESLICE 125210 . 127057) (LISPXSTATE 127059 . 128153) (LISPXTYPEAHEAD 128155 . 129759) ) (137892 140620 (GREET 137902 . 139043) (GREET0 139045 . 140618)) (142290 149466 (LISPXPRINT 142300 . 142864) (LISPXPRIN1 142866 . 143750) (LISPXPRIN2 143752 . 144694) (LISPXPRINTDEF 144696 . 145250) ( LISPXPRINTDEF0 145252 . 145615) (LISPXSPACES 145617 . 146303) (LISPXTERPRI 146305 . 146930) (LISPXTAB 146932 . 147490) (USERLISPXPRINT 147492 . 148892) (LISPXPUT 148894 . 149464))))) STOP \ No newline at end of file diff --git a/sources/HLDISPLAY b/sources/HLDISPLAY new file mode 100644 index 00000000..5736515b --- /dev/null +++ b/sources/HLDISPLAY @@ -0,0 +1,1193 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "15-Mar-94 10:48:02" {DSK}nilsson>mnw>HLDISPLAY.;5 206399 + + changes to%: (FNS \GETREGION.CHECKBASEPT DSPYSCREENTOWINDOW DSPXSCREENTOWINDOW + \GETREGION.CHECKOPPT GETGRIDBOXREGION NEAREST/PT/ON/GRID EDITBMBUTTONFN) + + previous date%: "25-Feb-94 14:50:58" {DSK}nilsson>mnw>HLDISPLAY.;4) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1900, 1988, 1989, 1990, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT HLDISPLAYCOMS) + +(RPAQQ HLDISPLAYCOMS + ( (* ; "GRID functions") + (FNS GRID GRIDXCOORD GRIDYCOORD LEFTOFGRIDCOORD BOTTOMOFGRIDCOORD SHADEGRIDBOX) + (* ; + "Low level compatibility and extensions") + (FNS INSIDE?) + [COMS (* ; "Mouse selection code") + (FNS MOUSESTATE-EXPR MOUSESTATE-NAME) + (PROP ARGNAMES MOUSESTATE LASTMOUSESTATE UNTILMOUSESTATE KEYSETSTATE LASTKEYSETSTATE) + (EXPORT (DECLARE%: DOCOPY (MACROS MOUSESTATE LASTMOUSESTATE UNTILMOUSESTATE KEYSETSTATE + LASTKEYSETSTATE)) + (DECLARE%: DONTCOPY (MACROS WITHIN)) + (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS] + (* ; "High Level Display utilities") + (FNS DECODEBUTTONS) + (FNS PTDIFFERENCE PTPLUS) + (COMS (* ; + "User interaction for regions, etc") + (FNS GETPOSITION GETBOXPOSITION DSPYSCREENTOWINDOW DSPXSCREENTOWINDOW GETREGION + \GETREGION.PACKPTS \GETREGION.CHECKBASEPT \GETREGION.CHECKOPPT + \GETREGIONTRACKWITHBOX \UPDATEXYANDBOX GETBOXREGION \TRACKWITHBOX MOVEBOX + DRAWGRAYBOX BLTHLINE BLTVLINE SETCORNER GETSCREENPOSITION GETBOXSCREENPOSITION + GETSCREENREGION GETBOXSCREENREGION) + + (* ;; "Old-medley-window-system versions of generic box/position functions") + + (FNS \MEDW.GETSCREENPOSITION \MEDW.GETBOXSCREENPOSITION \MEDW.GETSCREENREGION) + (FNS GETGRIDBOXREGION \RANGELIMIT) + (FNS MOUSECONFIRM) + (CURSORS MOUSECONFIRMCURSOR)) + (FNS NEAREST/PT/ON/GRID PTON10GRID NEAREST/MULTIPLE) + (EXPORT (MACROS IABS)) + (UGLYVARS DASHEDSHADE) + (GLOBALVARS CROSSHAIRS EXPANDINGBOX FORCEPS BOXCURSOR LOCKEDSPOT OLDEXPANDINGBOX + LowerLeftCursor UpperRightCursor UpperLeftCursor LowerRightCursor) + (CURSORS CROSSHAIRS EXPANDINGBOX FORCEPS BOXCURSOR LOCKEDSPOT OLDEXPANDINGBOX LowerLeftCursor + UpperRightCursor UpperLeftCursor LowerRightCursor) + (FNS \SW2BM COMPOSEREGS TRANSLATEREG) + (COMS (* ; "Bitmap and shade editors") + (FNS EDITBM EDITBMSCROLLFN EDITBMCLOSEFN TILEAREA EDITBMBUTTONFN \EDITBM/PUTUP/DISPLAY + \EDITBMHOWMUCH EDITBMRESHAPEFN EDITBMREPAINTFN UPDATE/SHADE/DISPLAY + UPDATE/BM/DISPLAY/SELECTED/REGION SHOWBUTTON RESETGRID.NEW RESETGRID + \READBMDIMENSIONS EDITSHADE \BITMAPFROMTEXTURE EDITSHADEREPAINTFN GRAYBOXAREA + \SHADEBITS READHOTSPOT WBOX \CLEARBM EDITBMTEXTURE) + (DECLARE%: DONTCOPY (RECORDS BUTTON) + (MACROS BITMASK UPDATE/BM/DISPLAY)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DARKBITSHADE 23130) + (NORMALGRIDSQUARE 16) + (NOTINUSEGRAY 42405) + (EDITBMMENU) + (EDITBMWINDOWMENU) + (GRIDSIZEMENU) + (CLICKWAITTIME 250))) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DARKBITSHADE NORMALGRIDSQUARE + NOTINUSEGRAY EDITBMMENU CLICKWAITTIME)) + (CONSTANTS (GRIDTHICKNESS 2) + (MINGRIDSQUARE 8) + (MAXGRIDWIDTH 199) + (MAXGRIDHEIGHT 175) + (BMWINDOWSHADE 33410))) + (FNS SCALEBM BLTPATTERN BLTPATTERN.REPLACEDISPLAY BLTPATTERN.GENERIC) + (FNS EXPANDBITMAP EXPANDBM SHRINKBITMAP \FAST4BIT) + (FUNCTIONS ROTATE-BITMAP ROTATE-BITMAP-LEFT) + (PROP FILETYPE HLDISPLAY) + (UGLYVARS \4BITEXPANSIONTABLE))) + + + +(* ; "GRID functions") + +(DEFINEQ + +(GRID [LAMBDA (GRIDSPEC WIDTH HEIGHT BORDER DS GRIDSHADE) (* ; "Edited 8-Dec-88 16:12 by SHIH") (* ;; "Draws a grid") (PROG ((X0 (fetch (REGION LEFT) of GRIDSPEC)) (Y0 (fetch (REGION BOTTOM) of GRIDSPEC)) (SQWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) (SQHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) (GRIDSHADE (COND ((TEXTUREP GRIDSHADE)) (T BLACKSHADE))) LINELENGTH TWICEBORDER MAXIMUMCOLOR TOTALHEIGHT GRIDBM TEMPBM) (SETQ TOTALHEIGHT (ITIMES HEIGHT SQHEIGHT)) (COND ((OR (ZEROP BORDER) (NULL BORDER)) (* ; "don't draw anything.") (RETURN)) [(NUMBERP BORDER) (SETQ TWICEBORDER (ITIMES BORDER 2)) (PROGN (* ;; "draw vertical lines use BITBLT so that we don't have to correct for the width of the line since line drawing will put the coordinate in the middle.") (BLTSHADE GRIDSHADE DS X0 Y0 BORDER TOTALHEIGHT 'REPLACE) (for X from (IDIFFERENCE (IPLUS X0 SQWIDTH) BORDER) to (IDIFFERENCE (IPLUS X0 (ITIMES (SUB1 WIDTH) SQWIDTH)) BORDER) by SQWIDTH do (BLTSHADE GRIDSHADE DS X Y0 TWICEBORDER TOTALHEIGHT 'REPLACE)) (BLTSHADE GRIDSHADE DS (IDIFFERENCE (IPLUS X0 (ITIMES WIDTH SQWIDTH)) BORDER) Y0 BORDER TOTALHEIGHT 'REPLACE)) (PROGN (* ; "draw horizontal lines") (BLTSHADE GRIDSHADE DS X0 Y0 (SETQ LINELENGTH (ITIMES WIDTH SQWIDTH)) BORDER 'REPLACE) (for Y from (IDIFFERENCE (IPLUS Y0 SQHEIGHT) BORDER) to (IDIFFERENCE (IPLUS Y0 (ITIMES (SUB1 HEIGHT) SQHEIGHT)) BORDER) by SQHEIGHT do (BLTSHADE GRIDSHADE DS X0 Y LINELENGTH TWICEBORDER 'REPLACE)) (BLTSHADE GRIDSHADE DS X0 (IDIFFERENCE (IPLUS Y0 TOTALHEIGHT) BORDER) LINELENGTH BORDER 'REPLACE] [(EQ BORDER 'POINT) (* ;  "put a point in the lower left corner of each box") (if (WINDOWP DS) then (SETQ TEMPBM (WINDOWPROP DS 'TEMPBM)) (SETQ GRIDBM (WINDOWPROP DS 'GRIDBM)) (if (NOT GRIDBM) then (SETQ GRIDBM (BITMAPCREATE SQWIDTH SQHEIGHT)) (WINDOWPROP DS 'GRIDBM GRIDBM)) (BLTSHADE WHITESHADE GRIDBM 0 0) (* ; "Clear temporary bitmap.") (BLTSHADE BLACKSHADE GRIDBM 0 0 1 1 'REPLACE) (* ; "Put spot down.") (* ; "Fill up temporary bitmap.") (BLTPATTERN GRIDBM 0 0 SQWIDTH SQHEIGHT DS X0 Y0 (ITIMES WIDTH SQWIDTH) (ITIMES HEIGHT SQHEIGHT) 'PAINT TEMPBM) else [SETQ MAXIMUMCOLOR (MAXIMUMCOLOR (BITSPERPIXEL (DSPDESTINATION NIL DS] (* ;; "Crufty slow original code.") (for X from X0 to (IPLUS X0 (ITIMES WIDTH SQWIDTH)) by SQWIDTH do (for Y from Y0 to (IPLUS Y0 TOTALHEIGHT) by SQHEIGHT do (BITMAPBIT DS X Y MAXIMUMCOLOR] (T (\ILLEGAL.ARG BORDER]) + +(GRIDXCOORD [LAMBDA (XPOS GRIDSPEC) (* rrb "21-MAR-83 13:04") (PROG [(GX (IDIFFERENCE XPOS (fetch (REGION LEFT) of GRIDSPEC] (* because (IQUOTIENT -1 2) is 0 instead of -1 like we would like) (RETURN (COND ((IGEQ GX 0) (IQUOTIENT GX (fetch (REGION WIDTH) of GRIDSPEC))) (T (SUB1 (IQUOTIENT GX (fetch (REGION WIDTH) of GRIDSPEC]) + +(GRIDYCOORD [LAMBDA (YPOS GRIDSPEC) (* rrb "21-MAR-83 13:07") (PROG [(GY (IDIFFERENCE YPOS (fetch (REGION BOTTOM) of GRIDSPEC] (* because (IQUOTIENT -1 2) is 0 instead of -1 like we would like) (RETURN (COND ((IGEQ GY 0) (IQUOTIENT GY (fetch (REGION HEIGHT) of GRIDSPEC))) (T (SUB1 (IQUOTIENT GY (fetch (REGION HEIGHT) of GRIDSPEC]) + +(LEFTOFGRIDCOORD [LAMBDA (GRIDX GRIDSPEC) (* rrb "19-MAR-82 09:20") (* returns the Left position of a grid  location.) (IPLUS (fetch (REGION LEFT) of GRIDSPEC) (ITIMES (fetch (REGION WIDTH) of GRIDSPEC) GRIDX]) + +(BOTTOMOFGRIDCOORD [LAMBDA (GRIDY GRIDSPEC) (* rrb "19-MAR-82 09:38") (IPLUS (fetch (REGION BOTTOM) of GRIDSPEC) (ITIMES (fetch (REGION HEIGHT) of GRIDSPEC) GRIDY]) + +(SHADEGRIDBOX [LAMBDA (X Y SHADE OPERATION GRIDSPEC GRIDBORDER DS) (* ; "Edited 1-Sep-87 17:41 by FS") (* shades the interior of a grid box.) (PROG ((BORDER (OR (FIXP GRIDBORDER) 0))) (BLTSHADE SHADE DS (IPLUS (LEFTOFGRIDCOORD X GRIDSPEC) BORDER) (IPLUS (BOTTOMOFGRIDCOORD Y GRIDSPEC) BORDER) (IDIFFERENCE (fetch (REGION WIDTH) of GRIDSPEC) (ITIMES BORDER 2)) (IDIFFERENCE (fetch (REGION HEIGHT) of GRIDSPEC) (ITIMES BORDER 2)) OPERATION) (* if this is POINT grid, set lower  left corner.) (COND ((EQ GRIDBORDER 'POINT) (BITMAPBIT DS (LEFTOFGRIDCOORD X GRIDSPEC) (BOTTOMOFGRIDCOORD Y GRIDSPEC) (MAXIMUMCOLOR (BITSPERPIXEL (DSPDESTINATION NIL DS]) +) + + + +(* ; "Low level compatibility and extensions") + +(DEFINEQ + +(INSIDE? [LAMBDA (BOX X Y) (* rrb "19-MAR-82 09:32") (AND (WITHIN (OR X LASTMOUSEX) (fetch (REGION LEFT) of BOX) (fetch (REGION WIDTH) of BOX)) (WITHIN (OR Y LASTMOUSEY) (fetch (REGION BOTTOM) of BOX) (fetch (REGION HEIGHT) of BOX]) +) + + + +(* ; "Mouse selection code") + +(DEFINEQ + +(MOUSESTATE-EXPR [LAMBDA (EXPR MOUSEONLYFLG) (* rrb " 5-Apr-84 17:05") (* if MOUSEONLYFLG is non-NIL, the testing should be done only on the mouse  buttons. MOUSEONLYFLG will be passed in as T by MOUSESTATE but will get reset  if any of the names are not mouse button names.) (PROG (NAMEMASK (MOUSEBUTTONMASK 7)) (RETURN (COND [(NLISTP EXPR) (COND [(EQ EXPR 'UP) (LIST 'ZEROP (COND (MOUSEONLYFLG (LIST 'LOGAND MOUSEBUTTONMASK ' LASTMOUSEBUTTONS)) (T 'LASTMOUSEBUTTONS] (T (* MOUSEONLYFLG can be ignored on this branch because it is generating code for  the case where the user is listing the button names and if he includes keyset  names you want to include them anyway.) (LIST 'NEQ (LIST 'LOGAND 'LASTMOUSEBUTTONS (MOUSESTATE-NAME EXPR)) 0] ((EQ (CAR EXPR) 'ONLY) (COND ((SETQ NAMEMASK (MOUSESTATE-NAME (CADR EXPR) MOUSEONLYFLG))) ((SETQ NAMEMASK (MOUSESTATE-NAME (CADR EXPR) NIL)) (* non-mouse buttons were named, use  all keys.) (SETQ MOUSEONLYFLG NIL))) (LIST 'EQ (COND (MOUSEONLYFLG (LIST 'LOGAND MOUSEBUTTONMASK 'LASTMOUSEBUTTONS)) (T 'LASTMOUSEBUTTONS)) NAMEMASK)) ([EVERY EXPR (FUNCTION (LAMBDA (X) (AND (ATOM X) (NEQ X 'UP] (* Cant use LOGx trick for UP as it is a disjunct not a key selector) (SELECTQ (CAR EXPR) (OR [LIST 'NEQ 0 (LIST 'LOGAND 'LASTMOUSEBUTTONS (CONS 'LOGOR (MAPCAR (CDR EXPR) (FUNCTION MOUSESTATE-NAME]) (AND [LIST 'EQ (CONS 'LOGOR (MAPCAR (CDR EXPR) (FUNCTION MOUSESTATE-NAME))) (LIST 'LOGAND 'LASTMOUSEBUTTONS (CONS 'LOGOR (MAPCAR (CDR EXPR) (FUNCTION MOUSESTATE-NAME]) (NOT (COND ((CDDR EXPR) (SHOULDNT))) [LIST 'ZEROP (LIST 'LOGAND 'LASTMOUSEBUTTONS (MOUSESTATE-NAME (CADR EXPR]) (HELP (CAR EXPR) " unrecognized mouse key operator"))) (T (CONS (CAR EXPR) (MAPCAR (CDR EXPR) (FUNCTION (LAMBDA (OPT) (MOUSESTATE-EXPR OPT MOUSEONLYFLG]) + +(MOUSESTATE-NAME [LAMBDA (KEYNAME MOUSEONLYFLG) (* rrb "13-JUN-82 11:17") (* return the numeric code for a mouse or keyset key.) (SELECTQ KEYNAME ((LEFT RED) 4) ((RIGHT BLUE) 2) ((YELLOW MIDDLE) 1) (COND ((NOT MOUSEONLYFLG) (* if wants mouse only, return NIL) (SELECTQ KEYNAME (LEFTKEY 128) (LEFTMIDDLEKEY 64) (MIDDLEKEY 32) (RIGHTMIDDLEKEY 16) (RIGHTKEY 8) (HELP KEYNAME " is not a recognized key name."]) +) + +(PUTPROPS MOUSESTATE ARGNAMES (BUTTONFORM)) + +(PUTPROPS LASTMOUSESTATE ARGNAMES (BUTTONFORM)) + +(PUTPROPS UNTILMOUSESTATE ARGNAMES (BUTTONFORM INTERVAL)) + +(PUTPROPS KEYSETSTATE ARGNAMES (BUTTONFORM)) + +(PUTPROPS LASTKEYSETSTATE ARGNAMES (BUTTONFORM)) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS MOUSESTATE MACRO (ARGS (LIST 'PROGN '(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 'PROG [LIST (LIST 'TIMEOUT + (LIST 'IPLUS '(CLOCK 0) + (LIST 'OR (LIST 'NUMBERP + (CADR ARGS)) + 100))) + '(NOWTIME (CLOCK 0] + 'LP + [LIST 'COND (LIST (CONS 'MOUSESTATE + (LIST (CAR ARGS) + T)) + '(RETURN T] + '(COND + ((IGREATERP (CLOCK0 NOWTIME) + TIMEOUT) + (RETURN NIL)) + (T (\BACKGROUND))) + '(GO LP] + (T (LIST 'PROG NIL 'LP + [LIST 'COND (LIST (CONS 'MOUSESTATE + (LIST (CAR ARGS) + T)) + '(RETURN T] + '(\BACKGROUND) + '(GO LP] + +[PUTPROPS KEYSETSTATE MACRO (ARGS (LIST 'PROGN '(GETMOUSESTATE) + (MOUSESTATE-EXPR (CAR ARGS] + +[PUTPROPS LASTKEYSETSTATE MACRO (ARGS (MOUSESTATE-EXPR (CAR ARGS] +) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS WITHIN MACRO ((A B C) + (AND (IGEQ A B) + (ILESSP A (IPLUS B C] +) +) + +(ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS) + +(* "END EXPORTED DEFINITIONS") + + + + +(* ; "High Level Display utilities") + +(DEFINEQ + +(DECODEBUTTONS [LAMBDA (BUTTONSTATE) (DECLARE (GLOBALVARS LASTMOUSEBUTTONS)) (* rrb " 9-JAN-82 14:20") (* return a list of the buttons and keys that are down from a button state.) (OR (SMALLP BUTTONSTATE) (SETQ BUTTONSTATE LASTMOUSEBUTTONS)) (NCONC (AND (NEQ 0 (LOGAND BUTTONSTATE 4)) (CONS 'LEFT)) (AND (NEQ 0 (LOGAND BUTTONSTATE 2)) (CONS 'RIGHT)) (AND (NEQ 0 (LOGAND BUTTONSTATE 1)) (CONS 'MIDDLE)) (AND (NEQ 0 (LOGAND BUTTONSTATE 128)) (CONS 'LEFTKEY)) (AND (NEQ 0 (LOGAND BUTTONSTATE 64)) (CONS 'LEFTMIDDLEKEY)) (AND (NEQ 0 (LOGAND BUTTONSTATE 32)) (CONS 'MIDDLEKEY)) (AND (NEQ 0 (LOGAND BUTTONSTATE 16)) (CONS 'RIGHTMIDDLEKEY)) (AND (NEQ 0 (LOGAND BUTTONSTATE 8)) (CONS 'RIGHTKEY]) +) +(DEFINEQ + +(PTDIFFERENCE [LAMBDA (PT1 PT2) (* rrb "24-JAN-83 14:54") (* adds two positions) (create POSITION XCOORD _ (DIFFERENCE (fetch (POSITION XCOORD) of PT1) (fetch (POSITION XCOORD) of PT2)) YCOORD _ (DIFFERENCE (fetch (POSITION YCOORD) of PT1) (fetch (POSITION YCOORD) of PT2]) + +(PTPLUS [LAMBDA (PT1 PT2) (* rrb "24-JAN-83 14:54") (* adds two positions) (create POSITION XCOORD _ (PLUS (fetch (POSITION XCOORD) of PT1) (fetch (POSITION XCOORD) of PT2)) YCOORD _ (PLUS (fetch (POSITION YCOORD) of PT1) (fetch (POSITION YCOORD) of PT2]) +) + + + +(* ; "User interaction for regions, etc") + +(DEFINEQ + +(GETPOSITION [LAMBDA (WINDOW CURSOR) (* ; "Edited 27-Aug-87 16:56 by FS") (* ; "Get position with cursor") (fetch (SCREENPOSITION POSITION) of (GETSCREENPOSITION WINDOW CURSOR]) + +(GETBOXPOSITION [LAMBDA (BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG) (* ;  "Edited 17-Jan-94 14:01 by sybalsky:mv:envos") (* ;; "gets a box position, returning the lower left corner. During the moving the outline of the box is displayed. If ORGX is given, the box is originally drawn at that location and the nearest corner to the cursor is snapped to the cursor position.") (fetch (SCREENPOSITION POSITION) of (GETBOXSCREENPOSITION BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG]) + +(DSPYSCREENTOWINDOW + [LAMBDA (Y DS) (* ; "Edited 15-Mar-94 10:41 by sybalsky") + (* transforms an y coordinate from + screen coordinates into window + coordinates) + (IDIFFERENCE Y (fetch (\DISPLAYDATA DDYOFFSET) of (\GETDISPLAYDATA DS]) + +(DSPXSCREENTOWINDOW + [LAMBDA (X DS) (* ; "Edited 15-Mar-94 10:41 by sybalsky") + (* transforms an x coordinate from + screen coordinates into window + coordinates) + (IDIFFERENCE X (fetch (\DISPLAYDATA DDXOFFSET) of (\GETDISPLAYDATA DS]) + +(GETREGION [LAMBDA (MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS) (* ;  "Edited 17-Jan-94 14:02 by sybalsky:mv:envos") (* ; "accepts region from the user.") (fetch (SCREENREGION REGION) of (GETSCREENREGION MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS]) + +(\GETREGION.PACKPTS [LAMBDA NIL (* rrb "12-Dec-83 18:01") (* copy from variable into position  for the constraint checks.) (replace (POSITION XCOORD) of BASEPT with BASEX) (replace (POSITION YCOORD) of BASEPT with BASEY) (replace (POSITION XCOORD) of OPPT with OPPX) (replace (POSITION YCOORD) of OPPT with OPPY]) + +(\GETREGION.CHECKBASEPT + [LAMBDA (NEWREGFNS BASEPT) (* ; "Edited 15-Mar-94 10:40 by sybalsky") + + (* ;; + "called by GETREGION to check the constraints imposed on the base point by the user functions.") + + (* ;; "if the new region fns is a list, apply them in order.") + + (bind USERPT for FN in NEWREGFNS do + + (* ;; "call user fn on base pt") + + (* ;; +"copying the user return point is time cnsuming but necessary to isolate the system from user code.") + + (SETQ USERPT (APPLY* FN BASEPT NIL + NEWREGIONFNARG)) + (COND + ((NOT (POSITIONP USERPT)) + (ERROR + "non-POSITION returned by NEWREGIONFN" + USERPT)) + (T (replace (POSITION XCOORD) + of BASEPT + with (fetch (POSITION XCOORD) + of USERPT)) + (replace (POSITION YCOORD) + of BASEPT + with (fetch (POSITION YCOORD) + of USERPT]) + +(\GETREGION.CHECKOPPT + [LAMBDA (MINWID MINHGHT NEWREGFNS BASEPT OPPT) (* ; "Edited 15-Mar-94 10:40 by sybalsky") + + (* called by GETREGION to check the constraints imposed by the minimum sizes + and user functions. It assumes BASEPT and OPPT are POSITIONs set to the fixed + corner BASEPT and moving corner OPPT.) + + (PROG ((BASEX (fetch (POSITION XCOORD) of BASEPT)) + (BASEY (fetch (POSITION YCOORD) of BASEPT)) + (OPPX (fetch (POSITION XCOORD) of OPPT)) + (OPPY (fetch (POSITION YCOORD) of OPPT)) + USERPT) (* check for minimum height and + width constraints.) + (AND [COND + [(IGREATERP BASEX OPPX) + (COND + ((ILESSP (IDIFFERENCE BASEX OPPX) + MINWID) + (SETQ OPPX (IDIFFERENCE BASEX MINWID] + ((ILESSP (IDIFFERENCE OPPX BASEX) + MINWID) + (SETQ OPPX (IPLUS BASEX MINWID] + (replace (POSITION XCOORD) of OPPT with OPPX)) + (AND [COND + [(IGREATERP BASEY OPPY) + (COND + ((ILESSP (IDIFFERENCE BASEY OPPY) + MINHGHT) + (SETQ OPPY (IDIFFERENCE BASEY MINHGHT] + ((ILESSP (IDIFFERENCE OPPY BASEY) + MINHGHT) + (SETQ OPPY (IPLUS BASEY MINHGHT] + (replace (POSITION YCOORD) of OPPT with OPPY)) + (* if the new region fns is a list, + apply them in order.) + (for FN in NEWREGFNS do (SETQ USERPT (APPLY* FN BASEPT OPPT NEWREGIONFNARG)) + (COND + ((NOT (POSITIONP USERPT)) + (ERROR "non-POSITION returned by NEWREGIONFN" USERPT + )) + (T (replace (POSITION XCOORD) of OPPT + with (fetch (POSITION XCOORD) + of USERPT)) + (replace (POSITION YCOORD) of OPPT + with (fetch (POSITION YCOORD) + of USERPT]) + +(\GETREGIONTRACKWITHBOX [LAMBDA NIL (* hdj "19-Sep-86 14:40") (* ;; "tracks a box sized between BASEX BASEY and OPPX OPPY until the left or middle mouse button go down.") (DECLARE (GLOBALVARS \CURSORDESTINATION DASHEDSHADE) (USEDFREE BASEX BASEY OPPX OPPY) (LOCALVARS . T)) (PROG (OLDCURSOR NOERROR XTEMP YTEMP OLDMOUSEX OLDMOUSEY POSTEMP THRUONCE WIDTH HEIGHT DESTINATION MAXX MAXY) (SETQ WIDTH (IDIFFERENCE BASEX OPPX)) (SETQ HEIGHT (IDIFFERENCE BASEY OPPY)) (SETQ DESTINATION \CURSORDESTINATION) (SETQ MAXX (SUB1 (BITMAPWIDTH DESTINATION))) (SETQ MAXY (SUB1 (BITMAPHEIGHT DESTINATION))) (DRAWGRAYBOX OPPX OPPY BASEX BASEY DESTINATION DASHEDSHADE) (* ;; "go thru the loop at least once so that checking of user function against the first point is always done.") [SETQ NOERROR (ERSETQ (until (AND THRUONCE (MOUSESTATE (OR LEFT MIDDLE))) do (SETQ THRUONCE T) (COND ((LASTMOUSESTATE RIGHT) (SETQ OLDCURSOR (CURSOR FORCEPS)) (until (MOUSESTATE (NOT RIGHT))) (CURSOR OLDCURSOR) (* ; "switch to drag nearest corner") [COND ((COND ((IGREATERP BASEX OPPX) (IGREATERP LASTMOUSEX (IQUOTIENT (IPLUS OPPX BASEX) 2))) (T (IGREATERP (IQUOTIENT (IPLUS OPPX BASEX) 2) LASTMOUSEX))) (* ; "switch X") (swap OPPX BASEX) (SETQ WIDTH (IDIFFERENCE BASEX OPPX] [COND ((COND ((IGREATERP BASEY OPPY) (IGREATERP LASTMOUSEY (IQUOTIENT (IPLUS OPPY BASEY) 2))) (T (IGREATERP (IQUOTIENT (IPLUS OPPY BASEY) 2) LASTMOUSEY))) (* ; "switch Y") (swap OPPY BASEY) (SETQ HEIGHT (IDIFFERENCE BASEY OPPY] (\CURSORPOSITION OPPX OPPY)) ((OR (NOT (EQ LASTMOUSEX OLDMOUSEX)) (NOT (EQ LASTMOUSEY OLDMOUSEY))) (* ;  "the cursor has moved, check user constraints.") (SETQ OLDMOUSEX LASTMOUSEX) (SETQ OLDMOUSEY LASTMOUSEY) (* ;  "make sure the base corner {which is opposite the one tracked with the mouse} is on the screen.") [replace (POSITION XCOORD) of BASEPT with (IMAX 0 (IMIN MAXX (IPLUS OLDMOUSEX WIDTH] [replace (POSITION YCOORD) of BASEPT with (IMAX 0 (IMIN MAXY (IPLUS OLDMOUSEY HEIGHT] (\GETREGION.CHECKBASEPT NEWREGFNS BASEPT) (SETQ XTEMP (fetch (POSITION XCOORD) of BASEPT)) (SETQ YTEMP (fetch (POSITION YCOORD) of BASEPT)) (COND ((NOT (AND (IEQP BASEX XTEMP) (IEQP BASEY YTEMP) (EQ \CURSORDESTINATION DESTINATION))) (* ; "move the box") (SETQ XTEMP (IDIFFERENCE XTEMP BASEX)) (SETQ YTEMP (IDIFFERENCE YTEMP BASEY)) (DRAWGRAYBOX OPPX OPPY BASEX BASEY DESTINATION DASHEDSHADE) (SETQ DESTINATION \CURSORDESTINATION) (SETQ MAXX (SUB1 (BITMAPWIDTH DESTINATION))) (SETQ MAXY (SUB1 (BITMAPHEIGHT DESTINATION))) (SETQ OPPX (IPLUS OPPX XTEMP)) (SETQ OPPY (IPLUS OPPY YTEMP)) (SETQ BASEX (IPLUS BASEX XTEMP)) (SETQ BASEY (IPLUS BASEY YTEMP)) (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN ))) (DRAWGRAYBOX OPPX OPPY BASEX BASEY DESTINATION DASHEDSHADE] (DRAWGRAYBOX OPPX OPPY BASEX BASEY DESTINATION DASHEDSHADE) (COND ((NULL NOERROR) (* ; "pass back ^E") (ERROR!]) + +(\UPDATEXYANDBOX [LAMBDA (BASEPTCHANGE? DESTINATION SHADE) (* kbr%: " 3-Feb-86 12:44") (* moves the values in BASEPT and OPPT into the variables BASEX BASEY OPPX OPPY  and updates the image on the screen if it has changed.) (PROG (TEMPX TEMPY) (COND [(EQ DESTINATION \CURSORDESTINATION) (* Cursor destination hasn't changed.  Add to old image. *) [COND (BASEPTCHANGE? (* the base point might have changed,  check it too.) (SETQ TEMPX (fetch (POSITION XCOORD) of BASEPT)) (SETQ TEMPY (fetch (POSITION YCOORD) of BASEPT)) (COND ((NOT (AND (IEQP BASEX TEMPX) (IEQP BASEY TEMPY))) (* move the box) (MOVEBOX OPPX OPPY BASEX BASEY (SETQ BASEX TEMPX) (SETQ BASEY TEMPY) DESTINATION SHADE] (SETQ TEMPX (fetch (POSITION XCOORD) of OPPT)) (SETQ TEMPY (fetch (POSITION YCOORD) of OPPT)) (COND ((NOT (AND (IEQP OPPX TEMPX) (IEQP OPPY TEMPY))) (* move the box) (MOVEBOX BASEX BASEY OPPX OPPY (SETQ OPPX TEMPX) (SETQ OPPY TEMPY) DESTINATION SHADE) (SETCORNER BASEX BASEY OPPX OPPY] (T (* Cursor moved to new screen. Can't get new image by adding to old image.  *) (DRAWGRAYBOX BASEX BASEY OPPX OPPY DESTINATION SHADE) (SETQ BASEX (fetch (POSITION XCOORD) of BASEPT)) (SETQ BASEY (fetch (POSITION YCOORD) of BASEPT)) (SETQ OPPX (fetch (POSITION XCOORD) of OPPT)) (SETQ OPPY (fetch (POSITION YCOORD) of OPPT)) (DRAWGRAYBOX BASEX BASEY OPPX OPPY \CURSORDESTINATION SHADE) (SETCORNER BASEX BASEY OPPX OPPY]) + +(GETBOXREGION [LAMBDA (WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG) (* ;  "Edited 17-Jan-94 14:02 by sybalsky:mv:envos") (* ;; "returns a region width by height positioned where user says.") (fetch (SCREENREGION REGION) of (GETBOXSCREENREGION WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG]) + +(\TRACKWITHBOX [LAMBDA (SHADE) (* ; "Edited 31-Aug-87 12:45 by FS") (* ;; "tracks the cursor with a box from corner ORGX ORGY with dimensions BOXWIDTH and BOXHEIGHT until the left or middle button changes. Implements the convention that the RIGHT button can be used to change corners. Returns non-NIL unless an error occurred. Returns the result by setting freely the variables ORGX ORGY BOXWIDTH BOXHEIGHT") (DECLARE (SPECVARS ORGX ORGY BOXWIDTH BOXHEIGHT)) (PROG (OLDCURSOR ORGLEFTMIDDLE NOERROR MLMASK DESTINATION) [SETQ MLMASK (CONSTANT (LOGOR (MOUSESTATE-NAME 'LEFT) (MOUSESTATE-NAME 'MIDDLE] (SETQ DESTINATION \CURSORDESTINATION) (SETQ ORGLEFTMIDDLE (LOGAND MLMASK LASTMOUSEBUTTONS)) (DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH) (IPLUS ORGY BOXHEIGHT) DESTINATION SHADE) [SETQ NOERROR (ERSETQ (until (PROGN (GETMOUSESTATE) (NOT (EQ (LOGAND MLMASK LASTMOUSEBUTTONS) ORGLEFTMIDDLE))) do (COND ((LASTMOUSESTATE RIGHT) (SETQ OLDCURSOR (CURSOR FORCEPS)) (until (MOUSESTATE (NOT RIGHT))) (CURSOR OLDCURSOR) (* ; "switch to drag nearest corner") [COND ((COND [(IGREATERP BOXWIDTH 0) (IGREATERP LASTMOUSEX (IPLUS ORGX (IQUOTIENT BOXWIDTH 2 ] (T (IGREATERP (IPLUS ORGX (IQUOTIENT BOXWIDTH 2)) LASTMOUSEX))) (* ; "switch X") (SETQ ORGX (IPLUS ORGX BOXWIDTH)) (SETQ BOXWIDTH (IMINUS BOXWIDTH] [COND ((COND [(IGREATERP BOXHEIGHT 0) (IGREATERP LASTMOUSEY (IPLUS ORGY (IQUOTIENT BOXHEIGHT 2] (T (IGREATERP (IPLUS ORGY (IQUOTIENT BOXHEIGHT 2)) LASTMOUSEY))) (* ; "switch Y") (SETQ ORGY (IPLUS ORGY BOXHEIGHT)) (SETQ BOXHEIGHT (IMINUS BOXHEIGHT] (\CURSORPOSITION ORGX ORGY)) (T (COND ((NOT (AND (IEQP ORGX LASTMOUSEX) (IEQP ORGY LASTMOUSEY))) (* ;  "the cursor has moved, move the box by erasing old box and drawing new box. *") (DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH) (IPLUS ORGY BOXHEIGHT) DESTINATION SHADE) (SETQ ORGX LASTMOUSEX) (SETQ ORGY LASTMOUSEY) (SETQ DESTINATION \CURSORDESTINATION) (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN ))) (DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH) (IPLUS ORGY BOXHEIGHT) DESTINATION SHADE] (DRAWGRAYBOX ORGX ORGY (IPLUS ORGX BOXWIDTH) (IPLUS ORGY BOXHEIGHT) DESTINATION SHADE) (COND ((NULL NOERROR) (* ; "pass back ^E") (ERROR!]) + +(MOVEBOX [LAMBDA (X1 Y1 X2 Y2 X3 Y3 DESTINATION SHADE) (* ; "Edited 25-Aug-87 15:52 by FS") (* ;  "moves the opposite corner of a box from {X2,Y2} to {X3,Y3}.") (.WHILE.CURSOR.DOWN. (BLTHLINE Y1 X2 X3 DESTINATION SHADE) (BLTVLINE X1 Y2 Y3 DESTINATION SHADE) (BLTHLINE Y2 X1 X2 DESTINATION SHADE) (BLTHLINE Y3 X1 X3 DESTINATION SHADE) (BLTVLINE X2 Y1 Y2 DESTINATION SHADE) (BLTVLINE X3 Y1 Y3 DESTINATION SHADE]) + +(DRAWGRAYBOX [LAMBDA (X1 Y1 X2 Y2 DESTINATION SHADE) (* kbr%: " 3-Feb-86 12:47") (* Put a gray box in window or bitmap  DESTINATION) (.WHILE.CURSOR.DOWN. (BLTHLINE Y1 X1 X2 DESTINATION SHADE) (BLTVLINE X1 Y1 Y2 DESTINATION SHADE) (BLTHLINE Y2 X1 X2 DESTINATION SHADE) (BLTVLINE X2 Y1 Y2 DESTINATION SHADE]) + +(BLTHLINE [LAMBDA (Y XA XB DESTINATION SHADE) (* ; "Edited 1-Sep-87 17:43 by FS") (BLTSHADE SHADE DESTINATION (IMIN XA XB) Y (IABS (IDIFFERENCE XB XA)) 2 'INVERT]) + +(BLTVLINE [LAMBDA (X YA YB DESTINATION SHADE) (* ; "Edited 1-Sep-87 17:43 by FS") (BLTSHADE SHADE DESTINATION X (IMIN YA YB) 2 (IABS (IDIFFERENCE YB YA)) 'INVERT]) + +(SETCORNER [LAMBDA (X1 Y1 X2 Y2) (* edited%: "26-Jan-86 13:15") (* sets the cursor shape for the box from x1,y1 to x2, y2) (DECLARE (GLOBALVARS LowerLeftCursor LowerRightCursor UpperLeftCursor UpperRightCursor)) (PROG (NEWCURSOR OLDCURSOR) [SETQ NEWCURSOR (COND ((IGREATERP X2 X1) (* moving to left) (COND ((IGREATERP Y2 Y1) (* moving up) UpperRightCursor) (T LowerRightCursor))) (T (* moving to right) (COND ((IGREATERP Y2 Y1) UpperLeftCursor) (T LowerLeftCursor] (* only call cursor if it changes  (less flicker on software cursors)) (SETQ OLDCURSOR (CURSOR)) (COND ((NOT (EQ NEWCURSOR OLDCURSOR)) (CURSOR NEWCURSOR) (\CURSORPOSITION X2 Y2]) + +(GETSCREENPOSITION [LAMBDA (WINDOW CURSOR) (* ;  "Edited 17-Jan-94 14:32 by sybalsky:mv:envos") (* ;; "Get screenposition with cursor. If WINDOW, then screenposition should be on same screen as WINDOW and in WINDOW's coordinate system. *") (OR (NULL WINDOW) (SETQ WINDOW (WFROMDS WINDOW))) (WINDOWOP 'SCGETSCREENPOSITION (COND (WINDOW (FETCH (WINDOW SCREEN) OF WINDOW)) (T \CURSORSCREEN)) WINDOW CURSOR]) + +(GETBOXSCREENPOSITION [LAMBDA (BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG) (* ;  "Edited 17-Jan-94 14:32 by sybalsky:mv:envos") (* ;; "gets a box position, returning the lower left corner. During the moving the outline of the box is displayed. If ORGX is given, the box is originally drawn at that location and the nearest corner to the cursor is snapped to the cursor position.") (WINDOWOP 'SCGETBOXSCREENPOSITION \CURSORSCREEN BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG]) + +(GETSCREENREGION [LAMBDA (MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS) (* ;  "Edited 17-Jan-94 14:32 by sybalsky:mv:envos") (* ; "accepts region from the user.") (* ;; "accepts region from the user. INITCORNERS lets caller specify size of initial ghost box. It is a list of the form (BASEX BASEY OPPX OPPY)") (WINDOWOP 'SCGETSCREENREGION \CURSORSCREEN MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS]) + +(GETBOXSCREENREGION [LAMBDA (WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG) (* ; "Edited 7-Dec-88 16:36 by SHIH") (* ;; "returns a screenregion width by height positioned where user says.") (PROG (SCREENPOS) (SETQ SCREENPOS (GETBOXSCREENPOSITION WIDTH HEIGHT ORGX ORGY WINDOW PROMPTMSG)) (RETURN (create SCREENREGION SCREEN _ (fetch (SCREENPOSITION SCREEN) of SCREENPOS) LEFT _ (fetch (SCREENPOSITION XCOORD) of SCREENPOS) BOTTOM _ (fetch (SCREENPOSITION YCOORD) of SCREENPOS) WIDTH _ WIDTH HEIGHT _ HEIGHT]) +) + + + +(* ;; "Old-medley-window-system versions of generic box/position functions") + +(DEFINEQ + +(\MEDW.GETSCREENPOSITION [LAMBDA (SCREEN WINDOW CURSOR) (* ;  "Edited 17-Jan-94 14:15 by sybalsky:mv:envos") (* ;; "Get screenposition with cursor. If WINDOW, then screenposition should be on same screen as WINDOW and in WINDOW's coordinate system. *") (OR (NULL WINDOW) (SETQ WINDOW (WFROMDS WINDOW))) (RESETFORM (CURSOR (OR CURSOR CROSSHAIRS)) [until (MOUSESTATE LEFT) do (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN ] (* ; "wait until the cursor is down") [COND (WINDOW (until (AND (MOUSESTATE (NOT LEFT)) (EQ \CURSORSCREEN (fetch (WINDOW SCREEN) of WINDOW))) do (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN] (* ;; "if a window was specified, then wait until the left button comes up, or until the cursor leaves the screen of the window") (COND ((NULL WINDOW) (until (MOUSESTATE (NOT LEFT))) (create SCREENPOSITION SCREEN _ LASTSCREEN XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY)) (T (create SCREENPOSITION SCREEN _ LASTSCREEN XCOORD _ (LASTMOUSEX WINDOW) YCOORD _ (LASTMOUSEY WINDOW]) + +(\MEDW.GETBOXSCREENPOSITION [LAMBDA (SCREEN BOXWIDTH BOXHEIGHT ORGX ORGY WINDOW PROMPTMSG) (* ;  "Edited 17-Jan-94 14:18 by sybalsky:mv:envos") (* ;; "gets a box position, returning the lower left corner. During the moving the outline of the box is displayed. If ORGX is given, the box is originally drawn at that location and the nearest corner to the cursor is snapped to the cursor position.") (RESETFORM (CURSOR BOXCURSOR) (PROG ((MOUSEDOWNFLG (MOUSESTATE (OR LEFT MIDDLE))) SHADE) (COND ((AND (FIXP ORGX) (FIXP ORGY)) (* ;  "origin given, move cursor to nearest corner.") [COND ((IGREATERP LASTMOUSEX (IPLUS ORGX (IQUOTIENT BOXWIDTH 2))) (SETQ ORGX (IPLUS ORGX BOXWIDTH)) (SETQ BOXWIDTH (IMINUS BOXWIDTH] [COND ((IGREATERP LASTMOUSEY (IPLUS ORGY (IQUOTIENT BOXHEIGHT 2))) (SETQ ORGY (IPLUS ORGY BOXHEIGHT)) (SETQ BOXHEIGHT (IMINUS BOXHEIGHT] (\CURSORPOSITION ORGX ORGY)) (T (SETQ ORGX LASTMOUSEX) (SETQ ORGY LASTMOUSEY))) (AND PROMPTMSG (PROMPTPRINT PROMPTMSG)) (SETQ SHADE GRAYSHADE) TRACKLP (* ;  "track the cursor with a box ghost until the left or middle button changes.") (\TRACKWITHBOX SHADE) [COND ((AND (NULL MOUSEDOWNFLG) (LASTMOUSESTATE (NOT UP))) (SETQ MOUSEDOWNFLG T) (CURSOR CROSSHAIRS)) ((AND MOUSEDOWNFLG (LASTMOUSESTATE UP)) (AND PROMPTMSG (CLRPROMPT)) (RETURN (COND (WINDOW (create SCREENPOSITION SCREEN _ LASTSCREEN XCOORD _ (DSPXSCREENTOWINDOW (IMIN ORGX (IPLUS ORGX BOXWIDTH )) WINDOW) YCOORD _ (DSPYSCREENTOWINDOW (IMIN ORGY (IPLUS ORGY BOXHEIGHT )) WINDOW))) (T (create SCREENPOSITION SCREEN _ LASTSCREEN XCOORD _ (IMIN ORGX (IPLUS ORGX BOXWIDTH)) YCOORD _ (IMIN ORGY (IPLUS ORGY BOXHEIGHT] (GO TRACKLP]) + +(\MEDW.GETSCREENREGION [LAMBDA (SCREEN MINWIDTH MINHEIGHT INITREGION NEWREGIONFN NEWREGIONFNARG INITCORNERS) (* ;  "Edited 17-Jan-94 14:17 by sybalsky:mv:envos") (* ; "accepts region from the user.") (* ;; "accepts region from the user. INITCORNERS lets caller specify size of initial ghost box. It is a list of the form (BASEX BASEY OPPX OPPY)") (* ;;; "Why is INITCORNERS not two positions? gbn") (RESETFORM (CURSOR EXPANDINGBOX) (PROG (DESTINATION SHADE BASEX BASEY OPPX OPPY OLDMOUSEX OLDMOUSEY INITLEFT INITRIGHT INITBOTTOM INITTOP BASEPT OPPT NEWMOUSEX NEWMOUSEY DOWNFLG BEGCLOCK NOTTIMEDOUT NEWREGFNS) (SETQ BASEPT (create POSITION)) (SETQ OPPT (create POSITION)) (SETQ MINWIDTH (COND ((FIXP MINWIDTH)) (T 0))) (SETQ MINHEIGHT (COND ((FIXP MINHEIGHT)) (T 0))) (SETQ NEWREGFNS (MKLIST NEWREGIONFN)) (SETQ SHADE GRAYSHADE) (SETQ NOTTIMEDOUT T) (SETQ DESTINATION \CURSORDESTINATION) [COND [INITCORNERS (* ; "setup box by initcorners.") (COND ((AND (EQ 4 (LENGTH INITCORNERS)) (for X in INITCORNERS always (FIXP X))) (SETQ BASEX (CAR INITCORNERS)) (SETQ BASEY (CADR INITCORNERS)) (SETQ OPPX (CADDR INITCORNERS)) (SETQ OPPY (CADDDR INITCORNERS))) (T (\ILLEGAL.ARG INITCORNERS] (T (* ;  "start with the cursor in the lower right corner of the ghost box.") (GETMOUSESTATE) (SETQ OPPX LASTMOUSEX) (SETQ OPPY LASTMOUSEY) [COND ((ILESSP (SETQ BASEX (IDIFFERENCE OPPX MINWIDTH)) 0) (* ;; "arrange things so that the whole box if possible is on the screen. If this is not possible, the lower right corner is on the screen.") (SETQ OPPX (SUB1 (IMIN MINWIDTH \CURSORDESTWIDTH))) (SETQ BASEX (IDIFFERENCE OPPX MINWIDTH] (COND ((IGEQ (SETQ BASEY (IPLUS OPPY MINHEIGHT)) \CURSORDESTHEIGHT) (* ;; "if the top corner would be off the screen, move the bottom corner as low as necessary but limited to the bottom of the screen.") (SETQ OPPY (IMAX 0 (IDIFFERENCE \CURSORDESTHEIGHT MINHEIGHT))) (SETQ BASEY (IPLUS OPPY MINHEIGHT] (\CURSORPOSITION OPPX OPPY) (* ;  "wait for the user to put down the first corner.") (\GETREGIONTRACKWITHBOX) [COND ((AND INITREGION (LASTMOUSESTATE MIDDLE))(* ;  "switch the nearest corner of INITREGION to the cursor and track it.") (* ;  "Pull from closest corner, ie. set BASEX,Y to be opposite corner") (SETQ BASEX (COND ((ILESSP (SETQ OPPX LASTMOUSEX) (IQUOTIENT [IPLUS (SETQ INITLEFT (fetch (REGION LEFT) of INITREGION)) (SETQ INITRIGHT (IPLUS INITLEFT (fetch (REGION WIDTH) of INITREGION] 2)) (* ;  "pointing at left half of box, so make origin be in right") INITRIGHT) (T (* ; "pointing at right half of box,") INITLEFT))) (SETQ BASEY (COND ((ILESSP (SETQ OPPY LASTMOUSEY) (IQUOTIENT [IPLUS (SETQ INITBOTTOM (fetch (REGION BOTTOM) of INITREGION)) (SETQ INITTOP (IPLUS INITBOTTOM (fetch (REGION HEIGHT) of INITREGION ] 2)) INITTOP) (T INITBOTTOM] (* ;  "copy from variable into position for the constraint checks.") (\GETREGION.PACKPTS) (\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT OPPT) (SETQ OPPX (fetch (POSITION XCOORD) of OPPT)) (SETQ OPPY (fetch (POSITION YCOORD) of OPPT)) (* ; "Now draw the initial box") (SETQ DESTINATION \CURSORDESTINATION) (DRAWGRAYBOX BASEX BASEY OPPX OPPY DESTINATION SHADE) (SETCORNER BASEX BASEY OPPX OPPY) (SETQ BEGCLOCK (CLOCK 0)) (COND [[ERSETQ (until (PROGN (GETMOUSESTATE) (COND [NOTTIMEDOUT (* ;  "wait to see if user was clicking to mark a corner") (COND ((\CLOCKGREATERP BEGCLOCK CLICKWAITTIME) (SETQ NOTTIMEDOUT NIL] (DOWNFLG (LASTMOUSESTATE UP)) ((LASTMOUSESTATE (NOT UP)) (* ;  "mouse button when down, continue tracking until it goes up.") (SETQ DOWNFLG T) NIL))) do (COND [(LASTMOUSESTATE (AND RIGHT (OR LEFT MIDDLE))) (CURSOR FORCEPS) (until (MOUSESTATE (NOT RIGHT))) (* ; "Switch to nearest corner") (COND ((IGEQ (IABS (IDIFFERENCE LASTMOUSEX OPPX)) (IABS (IDIFFERENCE LASTMOUSEX BASEX))) (swap BASEX OPPX))) (COND ((IGEQ (IABS (IDIFFERENCE LASTMOUSEY OPPY)) (IABS (IDIFFERENCE LASTMOUSEY BASEY))) (swap BASEY OPPY))) (\GETREGION.PACKPTS) (\GETREGION.CHECKBASEPT NEWREGFNS BASEPT) (\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT OPPT) (SETCORNER BASEX BASEY OPPX OPPY) (\UPDATEXYANDBOX T DESTINATION SHADE) (SETQ DESTINATION \CURSORDESTINATION) (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN] ((OR (NOT (EQ LASTMOUSEX OLDMOUSEX)) (NOT (EQ LASTMOUSEY OLDMOUSEY))) (* ;  "the cursor has moved, check user constraints.") (replace (POSITION XCOORD) of OPPT with (SETQ OLDMOUSEX LASTMOUSEX)) (replace (POSITION YCOORD) of OPPT with (SETQ OLDMOUSEY LASTMOUSEY)) (\GETREGION.CHECKOPPT MINWIDTH MINHEIGHT NEWREGFNS BASEPT OPPT) (\UPDATEXYANDBOX NIL DESTINATION SHADE) (SETQ DESTINATION \CURSORDESTINATION) (COND (BACKGROUNDCURSOREXITFN (APPLY* BACKGROUNDCURSOREXITFN] (* ; "erase box image.") (DRAWGRAYBOX BASEX BASEY OPPX OPPY DESTINATION SHADE) (RETURN (create SCREENREGION SCREEN _ \CURSORSCREEN LEFT _ (IMIN BASEX OPPX) BOTTOM _ (IMIN BASEY OPPY) WIDTH _ (IABS (IDIFFERENCE OPPX BASEX)) HEIGHT _ (IABS (IDIFFERENCE BASEY OPPY] (T (* ; "^E take down box.") (DRAWGRAYBOX BASEX BASEY OPPX OPPY DESTINATION SHADE) (ERROR!]) +) +(DEFINEQ + +(GETGRIDBOXREGION + [LAMBDA (MINWIDTH MINHEIGHT GRIDSPEC GRIDINTERIOR WINDOW) + (* ; "Edited 15-Mar-94 10:43 by sybalsky") + + (* ;; "Like GETREGION, it lets you sweep out a region, but only within the grid specified by GRIDSPEC and limited to the interior of GRIDREGION within WINDOW.") + + (LET* [NEWREGION [GRIDREGION (create REGION using GRIDINTERIOR LEFT _ + [\DSPTRANSFORMX (fetch (REGION LEFT) + of GRIDINTERIOR) + (fetch (STREAM IMAGEDATA) + of (WINDOWPROP WINDOW + 'DSP] + BOTTOM _ (\DSPTRANSFORMY + (fetch (REGION BOTTOM) + of GRIDINTERIOR) + (fetch (STREAM IMAGEDATA) + of (WINDOWPROP + WINDOW + 'DSP] + (RAWREGION (GETREGION 0 0 NIL (FUNCTION (LAMBDA (BASEPT OPPT FNARG) + (COND + ((AND OPPT + (INSIDE? + GRIDREGION + (fetch (POSITION XCOORD) + of OPPT) + (fetch (POSITION YCOORD) + of OPPT))) + OPPT) + [OPPT + (CREATEPOSITION + (\RANGELIMIT + (fetch (REGION LEFT) + of GRIDREGION) + (fetch (POSITION XCOORD) + of OPPT) + (fetch (REGION RIGHT) + of GRIDREGION)) + (\RANGELIMIT + (fetch (REGION BOTTOM) + of GRIDREGION) + (fetch (POSITION YCOORD) + of OPPT) + (fetch (REGION TOP) + of GRIDREGION] + ((INSIDE? GRIDREGION + (fetch (POSITION XCOORD + ) + of BASEPT) + (fetch (POSITION YCOORD + ) + of BASEPT)) + BASEPT) + (T + (CREATEPOSITION + (\RANGELIMIT + (fetch (REGION LEFT) + of GRIDREGION) + (fetch (POSITION XCOORD) + of BASEPT) + (fetch (REGION RIGHT) + of GRIDREGION)) + (\RANGELIMIT + (fetch (REGION BOTTOM) + of GRIDREGION) + (fetch (POSITION YCOORD) + of BASEPT) + (fetch (REGION TOP) + of GRIDREGION] + (SETQ NEWREGION (CREATEREGION (GRIDXCOORD (DSPXSCREENTOWINDOW (fetch + (REGION LEFT) + of RAWREGION) + WINDOW) + GRIDSPEC) + (GRIDYCOORD (DSPYSCREENTOWINDOW (fetch (REGION BOTTOM) + of RAWREGION) + WINDOW) + GRIDSPEC) + 0 0)) + (replace (REGION WIDTH) of NEWREGION + with (- (ADD1 (GRIDXCOORD (DSPXSCREENTOWINDOW (fetch (REGION RIGHT) + of RAWREGION) + WINDOW) + GRIDSPEC)) + (fetch (REGION LEFT) of NEWREGION))) + (replace (REGION HEIGHT) of NEWREGION + with (- (ADD1 (GRIDYCOORD (DSPYSCREENTOWINDOW (fetch (REGION TOP) + of RAWREGION) + WINDOW) + GRIDSPEC)) + (fetch (REGION BOTTOM) of NEWREGION))) + NEWREGION]) + +(\RANGELIMIT [LAMBDA (MIN VAL MAX) (IMAX MIN (IMIN MAX VAL]) +) +(DEFINEQ + +(MOUSECONFIRM [LAMBDA (PROMPTSTRING HELPSTRING WINDOW DON'TCLEAR/MAINW) (* bvm%: " 2-May-86 15:19") (* * Changes the cursor to a "little mouse" ;  prints a prompt; and waits for the user to press and then release a mouse  button. If the LEFT was the final one release then return T otherwise return  NIL -- uses PROMPTWINDOW unless provided a window * *) (DECLARE (GLOBALVARS MOUSECONFIRMCURSOR)) (LET ((HELPSTR (COND ((EQ HELPSTRING T) NIL) ((NULL HELPSTRING) "Click LEFT to confirm, RIGHT to abort.") (T HELPSTRING))) PWINDOW) (COND ((EQ PROMPTSTRING T) (SETQ PROMPTSTRING NIL))) (COND [(OR PROMPTSTRING HELPSTR) [FRESHLINE (OR WINDOW (SETQ WINDOW (COND [(WINDOWP DON'TCLEAR/MAINW) (* Open a prompt window from this  window) (SETQ PWINDOW (GETPROMPTWINDOW DON'TCLEAR/MAINW (COND ((NULL PROMPTSTRING) HELPSTR) ((NULL HELPSTR) PROMPTSTRING) (T (CONCAT PROMPTSTRING " " HELPSTR] (T PROMPTWINDOW] [COND (PROMPTSTRING (printout WINDOW PROMPTSTRING) (COND (HELPSTR (SPACES 2 WINDOW] (COND (HELPSTR (printout WINDOW HELPSTR] (T (* Didn't print anything, so don't  clear anything) (SETQ DON'TCLEAR/MAINW T))) (PROG1 (RESETFORM (CURSOR MOUSECONFIRMCURSOR) (until (MOUSESTATE (OR LEFT MIDDLE RIGHT))) (bind (LEFTDOWN _ (LASTMOUSESTATE LEFT)) until (MOUSESTATE UP) do (* If buttons are still down, but not LEFT, user must have changed mind) (SETQ LEFTDOWN (LASTMOUSESTATE LEFT)) finally (RETURN LEFTDOWN))) (COND (PWINDOW (* Close prompt window) (CLOSEW PWINDOW)) ((NULL DON'TCLEAR/MAINW) (CLEARW WINDOW]) +) +(RPAQ MOUSECONFIRMCURSOR (CURSORCREATE (QUOTE #*(16 16)GOOLD@@DELIDELIDELIDELIDELIDELIDELIDD@@DD@@DD@@DD@@DD@@DD@@DGOOL +) (QUOTE NIL) 8 8)) +(DEFINEQ + +(NEAREST/PT/ON/GRID + [LAMBDA (PT GRIDN) (* ; "Edited 15-Mar-94 10:40 by sybalsky") + (* finds the point on a grid of + multiple GRIDN closest to PT.) + (create POSITION + XCOORD _ (NEAREST/MULTIPLE (fetch (POSITION XCOORD) of PT) + GRIDN) + YCOORD _ (NEAREST/MULTIPLE (fetch (POSITION YCOORD) of PT) + GRIDN) smashing PT]) + +(PTON10GRID [LAMBDA (FIXEDPT MOVINGPT) (* rrb " 6-AUG-81 08:45") (* insists that a pt be on a 10 grid) (COND (MOVINGPT (NEAREST/PT/ON/GRID MOVINGPT 10)) (T (NEAREST/PT/ON/GRID FIXEDPT 10]) + +(NEAREST/MULTIPLE [LAMBDA (X N) (* rrb " 6-AUG-81 08:42") (* finds the multiple of N that is nearest to X) (COND ((IGREATERP X 0) (ITIMES (IQUOTIENT (IPLUS X (IQUOTIENT N 2)) N) N)) (T (ITIMES (IQUOTIENT (IDIFFERENCE X (IQUOTIENT N 2)) N) N]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[PUTPROPS IABS MACRO (OPENLAMBDA (A) + (COND + ((IGEQ A 0) + A) + (T (IMINUS A] +) + +(* "END EXPORTED DEFINITIONS") + + +(READVARS-FROM-STRINGS '(DASHEDSHADE) + "({(READBITMAP)(16 16 +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"@@OO%" +%"OO@@%" +%"OO@@%" +%"OO@@%" +%"OO@@%" +%"OO@@%" +%"OO@@%" +%"OO@@%" +%"OO@@%")}) +") +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS CROSSHAIRS EXPANDINGBOX FORCEPS BOXCURSOR LOCKEDSPOT OLDEXPANDINGBOX LowerLeftCursor + UpperRightCursor UpperLeftCursor LowerRightCursor) +) +(RPAQ CROSSHAIRS (CURSORCREATE (QUOTE #*(16 16)@@@@@GL@AMG@CAAHFA@LDA@DLA@FHA@BOOONHA@BLA@FDA@DFA@LCAAHAMG@@GL@ +) (QUOTE NIL) 7 7)) +(RPAQ EXPANDINGBOX (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@H@@@L@@@N@@@O@@@OHNGOLLCONKMO@BDMHBDIHKM@LLC@LNG@F@@@F@@ +) (QUOTE NIL) 0 13)) +(RPAQ FORCEPS (CURSORCREATE (QUOTE #*(16 16)@NG@@JE@@NG@@DB@@FF@@CL@@AH@@AH@@CL@@FF@ALCHBDBDBDBDBDBDBDBDAHAH +) (QUOTE NIL) 7 15)) +(RPAQ BOXCURSOR (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@COOLCOOLC@@LC@@LC@@LC@@LC@@LC@@LC@@LC@@LCOOLCOOL@@@@@@@@ +) (QUOTE NIL) 7 7)) +(RPAQ LOCKEDSPOT (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@COOLCOOLC@@LC@@LCCLLCCLLCCLLCCLLC@@LC@@LCOOLCOOL@@@@@@@@ +) (QUOTE NIL) 7 7)) +(RPAQ OLDEXPANDINGBOX (CURSORCREATE (QUOTE #*(16 16)@@@@OHCNN@@NO@ANKHCJIMGB@ON@@DD@@LF@@DD@@ON@IMGBKHCJO@ANN@@NOHCN +) (QUOTE NIL) 7 7)) +(RPAQ LowerLeftCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@H@@@L@@@L@@@L@@@L@@@L@@@L@@@L@@@L@@@OOL@OON@ +) (QUOTE NIL) 0 0)) +(RPAQ UpperRightCursor (CURSORCREATE (QUOTE #*(16 16)@COO@AOO@@@C@@@C@@@C@@@C@@@C@@@C@@@C@@@C@@@A@@@@@@@@@@@@@@@@@@@@ +) (QUOTE NIL) 15 15)) +(RPAQ UpperLeftCursor (CURSORCREATE (QUOTE #*(16 16)OOL@OOH@L@@@L@@@L@@@L@@@L@@@L@@@L@@@L@@@H@@@@@@@@@@@@@@@@@@@@@@@ +) (QUOTE NIL) 0 15)) +(RPAQ LowerRightCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@A@@@C@@@C@@@C@@@C@@@C@@@C@@@C@@@C@COO@GOO +) (QUOTE NIL) 15 0)) +(DEFINEQ + +(\SW2BM [LAMBDA (P PR Q QR) (* edited%: "26-Jan-86 13:23") (* Switches the areas of P and Q defined by the regions PR and QR respectively) (PROG (PL PH PW PB QL QH QW QB) [COND (PR (SETQ PL (fetch (REGION LEFT) of PR)) (SETQ PB (fetch (REGION BOTTOM) of PR)) (SETQ PH (fetch (REGION HEIGHT) of PR)) (SETQ PW (fetch (REGION WIDTH) of PR))) (T (SETQ PL (SETQ PB 0)) (SETQ PW (fetch (BITMAP BITMAPWIDTH) of P)) (SETQ PH (fetch (BITMAP BITMAPHEIGHT) of P] [COND (QR (SETQ QL (fetch (REGION LEFT) of QR)) (SETQ QB (fetch (REGION BOTTOM) of QR)) (SETQ QW (fetch (REGION WIDTH) of QR)) (SETQ QH (fetch (REGION HEIGHT) of QR))) (T (SETQ QL (SETQ QB 0)) (SETQ QW (fetch (BITMAP BITMAPWIDTH) of Q)) (SETQ QH (fetch (BITMAP BITMAPHEIGHT) of Q] (PROG ((CL (IMAX (IMINUS PL) (IMINUS QL) 0)) (CB (IMAX (IMINUS PB) (IMINUS QB) 0))) (PROG ((XP (IPLUS CL PL)) (YP (IPLUS CB PB)) (XQ (IPLUS CL QL)) (YQ (IPLUS CB QB)) CW CH) (SETQ CW (IMIN (IDIFFERENCE (IMIN (fetch (BITMAP BITMAPWIDTH) of P) (IPLUS PL PW)) XP) (IDIFFERENCE (IMIN (fetch (BITMAP BITMAPWIDTH) of Q) (IPLUS QL QW)) XQ))) (SETQ CH (IMIN (IDIFFERENCE (IMIN (fetch (BITMAP BITMAPHEIGHT) of P) (IPLUS PB PH)) YP) (IDIFFERENCE (IMIN (fetch (BITMAP BITMAPHEIGHT) of Q) (IPLUS QB QH)) YQ))) (UNINTERRUPTABLY (BITBLT P XP YP Q XQ YQ CW CH 'INPUT 'INVERT) (BITBLT Q XQ YQ P XP YP CW CH 'INPUT 'INVERT) (BITBLT P XP YP Q XQ YQ CW CH 'INPUT 'INVERT))]) + +(COMPOSEREGS [LAMBDA (INNER OUTER) (* rrb "19-MAR-82 09:35") (* Converts INNER from OUTER relative coords to same units as OUTER -  inverse of TRANSLATEREGS) (create REGION LEFT _ (IPLUS (fetch (REGION LEFT) of OUTER) (fetch (REGION LEFT) of INNER)) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of OUTER) (fetch (REGION BOTTOM) of INNER)) using INNER]) + +(TRANSLATEREG [LAMBDA (INNER OUTER) (* rrb "19-MAR-82 09:35") (* Translates a nested INNER region to OUTER region relative coordinates) (create REGION LEFT _ (IDIFFERENCE (fetch (REGION LEFT) of INNER) (fetch (REGION LEFT) of OUTER)) BOTTOM _ (IDIFFERENCE (fetch (REGION BOTTOM) of INNER) (fetch (REGION BOTTOM) of OUTER)) WIDTH _ (fetch (REGION WIDTH) of INNER) HEIGHT _ (fetch (REGION HEIGHT) of INNER]) +) + + + +(* ; "Bitmap and shade editors") + +(DEFINEQ + +(EDITBM [LAMBDA (BMSPEC) (* ; "Edited 31-Aug-87 12:28 by FS") (* ;;; "A simple bitmap editor.") (* ;; "The edit part of the display is from 0 to MAXGRIDWIDTH in width and from 0 to MAXGRIDHEIGHT in height. The commands and display area for the bitmap being edited are above the edit region.") (DECLARE (GLOBALVARS \CURSORDESTWIDTH \CURSORDESTHEIGHT)) (PROG (BMW BMWINTERIOR BMWWIDTH BMWHEIGHT WIDTH HEIGHT BM CR ORIGBM GRIDSQUARE BPP ORIGBPP ORIGWIDTH) (* ;  "set ORIGBM to the input bitmap if any and BM to a copy of it for editting.") [COND ((OR (EQ BMSPEC CursorBitMap) (AND (EQ BMSPEC 'CursorBitMap) (SETQ BMSPEC CursorBitMap))) (* ;  "editing cursor, save old value and make changes to the original.") (SETQ ORIGBM (BITMAPCOPY CursorBitMap)) (SETQ BM CursorBitMap)) [(BITMAPP BMSPEC) (SETQ BM (BITMAPCOPY (SETQ ORIGBM BMSPEC] [(LITATOM BMSPEC) (COND ([BITMAPP (SETQ ORIGBM (EVALV BMSPEC 'EDITBM] (* ; "use value.") (SETQ BM (BITMAPCOPY ORIGBM))) (T (SETQ ORIGBM NIL) (SETQ BM (\READBMDIMENSIONS] ((REGIONP BMSPEC) (* ;  "if BMSPEC is a region, treat it as a region of the screen.") (SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC) (fetch (REGION HEIGHT) of BMSPEC) (BITSPERPIXEL \CURSORDESTINATION))) (* ;  "note that bm has initial bits in it.") (SETQ ORIGBM BMSPEC) (BITBLT \CURSORDESTINATION (fetch (REGION LEFT) of BMSPEC) (fetch (REGION BOTTOM) of BMSPEC) BM 0 0 NIL NIL 'INPUT 'REPLACE)) ((WINDOWP BMSPEC) (SETQ ORIGBM BMSPEC) (* ;;  "FS: Seems too big below, why not ClipRegion's Width & Height? That's all that's used...") (SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC 'WIDTH) (WINDOWPROP BMSPEC 'HEIGHT) (BITSPERPIXEL BMSPEC))) (* ;  "open the window and bring it to the top.") (TOTOPW BMSPEC) (SETQ CR (DSPCLIPPINGREGION NIL BMSPEC)) (BITBLT BMSPEC (fetch (REGION LEFT) of CR) (fetch (REGION BOTTOM) of CR) BM 0 0 (fetch (REGION WIDTH) of CR) (fetch (REGION HEIGHT) of CR))) (T (* ; "otherwise create a bitmap") (SETQ BM (\READBMDIMENSIONS] (if (OR (EQ (BITMAPHEIGHT BM) 0) (EQ (BITMAPWIDTH BM) 0)) then (ERROR "Can't edit a bitmap with no bits in it." BMSPEC)) (SETQ BPP (BITSPERPIXEL \CURSORDESTINATION)) (SETQ ORIGBPP (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) [COND ((NOT (EQ BPP ORIGBPP)) (* ;; "save the actual number of bits per pixel and set it to BPP in the bitmap being edited so that it can be BITBLT ed on the screen.") (SETQ ORIGWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) (replace (BITMAP BITMAPBITSPERPIXEL) of BM with BPP) (SETQ WIDTH (IQUOTIENT (ITIMES ORIGBPP ORIGWIDTH) BPP)) (replace (BITMAP BITMAPWIDTH) of BM with WIDTH)) (T (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BM] (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) (* ;;  "Calculate a default window size. Start by calculating the grid size from the bitmap size.") (SETQ GRIDSQUARE (IMAX (IMIN (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES \CURSORDESTWIDTH 2) 3) GRIDTHICKNESS) WIDTH) (IQUOTIENT (IDIFFERENCE (IQUOTIENT (ITIMES \CURSORDESTHEIGHT 2 ) 3) (ITIMES GRIDTHICKNESS 2)) (ADD1 HEIGHT)) NORMALGRIDSQUARE) MINGRIDSQUARE)) (SETQ BMWWIDTH (IMIN (IPLUS (ITIMES GRIDSQUARE WIDTH) GRIDTHICKNESS) (IQUOTIENT (ITIMES \CURSORDESTWIDTH 2) 3))) (SETQ BMWHEIGHT (IMIN (IPLUS (ITIMES HEIGHT (ADD1 GRIDSQUARE)) (ITIMES GRIDTHICKNESS 2) 1) (IQUOTIENT (ITIMES \CURSORDESTHEIGHT 2) 3))) (SETQ BMW (CREATEW (GETBOXREGION (WIDTHIFWINDOW BMWWIDTH) (HEIGHTIFWINDOW BMWHEIGHT T) NIL NIL NIL "Indicate the position for the Bitmap Edit window.") "Bitmap Editor")) (WINDOWPROP BMW 'BM BM) (WINDOWPROP BMW 'SCROLLFN (FUNCTION EDITBMSCROLLFN)) (WINDOWPROP BMW 'RESHAPEFN (FUNCTION EDITBMRESHAPEFN)) (WINDOWPROP BMW 'REPAINTFN (FUNCTION EDITBMREPAINTFN)) (WINDOWPROP BMW 'BUTTONEVENTFN (FUNCTION EDITBMBUTTONFN)) (WINDOWPROP BMW 'CLOSEFN (FUNCTION EDITBMCLOSEFN)) (WINDOWPROP BMW 'XOFFSET 0) (WINDOWPROP BMW 'YOFFSET 0) (WINDOWPROP BMW 'DXOFFSET 0) (WINDOWPROP BMW 'DYOFFSET 0) (WINDOWPROP BMW 'ORIGINALBITMAP ORIGBM) (WINDOWPROP BMW 'FINISHEDFLG NIL) (WINDOWPROP BMW 'COLOR (MAXIMUMCOLOR BPP)) (WINDOWPROP BMW 'GRIDON T) (* ;  "call reshapefn to initialize the display and values") (EDITBMRESHAPEFN BMW NIL NIL NIL (NOT ORIGBM)) (* ;  "start a mouse process in case this process is the mouse process.") (SPAWN.MOUSE) (while (NOT (WINDOWPROP BMW 'FINISHEDFLG)) do (DISMISS 500)) (* ;  "remove the closefn before closing the window.") (WINDOWPROP BMW 'CLOSEFN NIL) (CLOSEW BMW) (COND ((NOT (EQ ORIGBPP BPP)) (replace (BITMAP BITMAPBITSPERPIXEL) of BM with ORIGBPP) (replace (BITMAP BITMAPWIDTH) of BM with ORIGWIDTH))) (RETURN (COND ((EQ T (WINDOWPROP BMW 'FINISHEDFLG)) (* ;  "editor exited via ok, stuff contents into original bitmap.") (COND ((EQ BMSPEC CursorBitMap) (* ;  "editting happened in original, leave it alone.") CursorBitMap) ((REGIONP ORIGBM) (* ; "put it back into the screen.") (BITBLT BM 0 0 \CURSORDESTINATION (fetch (REGION LEFT) of ORIGBM) (fetch (REGION BOTTOM) of ORIGBM) (fetch (REGION WIDTH) of ORIGBM) (fetch (REGION HEIGHT) of ORIGBM) 'INPUT 'REPLACE) BM) ((WINDOWP ORIGBM) (* ; "put it back into the window") (BITBLT BM 0 0 ORIGBM (fetch (REGION LEFT) of CR) (fetch (REGION BOTTOM) of CR) (fetch (REGION WIDTH) of CR) (fetch (REGION HEIGHT) of CR) 'INPUT 'REPLACE) BM) (ORIGBM (BITBLT BM 0 0 ORIGBM 0 0 WIDTH HEIGHT) [COND ((AND BMSPEC (LITATOM BMSPEC)) (* ;  "if spec was an atom without a bm value, set it. in the environment above EDITBM.") (MARKASCHANGED BMSPEC 'VARS) (STKEVAL 'EDITBM (LIST 'SETQQ BMSPEC BM] ORIGBM) (T BM))) (T (* ;  "error exit, if cursor return it to original value.") (COND ((EQ BMSPEC CursorBitMap) (BITBLT ORIGBM NIL NIL CursorBitMap))) (ERROR!]) + +(EDITBMSCROLLFN [LAMBDA (W DX DY) (* ; "Edited 31-Aug-87 13:29 by FS") (* ;  "Do scrolling for the bitmap editor.") (PROG (GRIDSPEC REG WHEIGHT WWIDTH (DXGRID 0) (DYGRID 0) EXTENT EXTENTWIDTH EXTENTHEIGHT GILEFT GIBOTTOM GIHEIGHT GWIDTH GHEIGHT GRIDINTERIOR EBMXLIMIT EBMYLIMIT EBMXOFFSET EBMYOFFSET BM BITMAPWIDTH BITMAPHEIGHT BITSWIDE BITSHIGH DXOFFSET DYOFFSET) (SETQ GRIDSPEC (WINDOWPROP W 'GRIDSPEC)) (SETQ REG (WINDOWPROP W 'REGION)) (SETQ WHEIGHT (WINDOWPROP W 'HEIGHT)) (SETQ WWIDTH (WINDOWPROP W 'WIDTH)) (SETQ GRIDINTERIOR (WINDOWPROP W 'GRIDINTERIOR)) (SETQ EBMXOFFSET (WINDOWPROP W 'XOFFSET)) (SETQ EBMYOFFSET (WINDOWPROP W 'YOFFSET)) (SETQ BM (WINDOWPROP W 'BM)) (SETQ BITMAPWIDTH (fetch BITMAPWIDTH of BM)) (SETQ BITMAPHEIGHT (fetch BITMAPHEIGHT of BM)) (SETQ BITSWIDE (WINDOWPROP W 'BITSWIDE)) (SETQ BITSHIGH (WINDOWPROP W 'BITSHIGH)) (SETQ DXOFFSET (WINDOWPROP W 'DXOFFSET)) (SETQ DYOFFSET (WINDOWPROP W 'DYOFFSET)) (SETQ EBMXLIMIT (IPLUS EBMXOFFSET BITSWIDE)) (SETQ EBMYLIMIT (IPLUS EBMYOFFSET BITSHIGH)) (COND (GRIDSPEC (SETQ GILEFT (fetch (REGION LEFT) of GRIDINTERIOR)) (SETQ GIBOTTOM (fetch (REGION BOTTOM) of GRIDINTERIOR)) (SETQ GIHEIGHT (fetch (REGION HEIGHT) of GRIDINTERIOR)) (SETQ GWIDTH (fetch (REGION WIDTH) of GRIDSPEC)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of GRIDSPEC)) (SETQ EXTENT (WINDOWPROP W 'EXTENT)) (SETQ EXTENTWIDTH (fetch (REGION WIDTH) of EXTENT)) (SETQ EXTENTHEIGHT (fetch (REGION HEIGHT) of EXTENT)) (* ; "Make a horizontal adjustment") (COND ((FLOATP DX) (* ; "Horizontal thumbing") [WINDOWPROP W 'XOFFSET (SETQ EBMXOFFSET (FIX (TIMES (IDIFFERENCE BITMAPWIDTH BITSWIDE) DX] (replace (REGION LEFT) of EXTENT with (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH) BITMAPWIDTH))) (* BLTSHADE WHITESHADE W GILEFT  GIBOTTOM SCREENWIDTH SCREENHEIGHT  (QUOTE REPLACE) GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) ((ILESSP DX 0) (* ; "moving to the left.") (* ;  "determine how many grid points to move.") (SETQ DXGRID (IMIN (GRIDXCOORD (IMINUS DX) GRIDSPEC) (IDIFFERENCE BITMAPWIDTH EBMXLIMIT))) (COND ((NOT (IGREATERP DXGRID 0)) (* ; "right edge is at the right margin") (RETURN))) (WINDOWPROP W 'XOFFSET (SETQ EBMXOFFSET (IPLUS EBMXOFFSET DXGRID))) (* ; "update EXTENT bar") (replace (REGION LEFT) of EXTENT with (IMAX (IMINUS (QUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH ) BITMAPWIDTH)) (IMINUS EXTENTWIDTH))) (* ; "move image to the left.") (BITBLT W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) GIBOTTOM W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT 'INPUT 'REPLACE NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") (BLTSHADE WHITESHADE W (IPLUS GILEFT (TIMES (IDIFFERENCE BITSWIDE DXGRID) GWIDTH)) GIBOTTOM SCREENWIDTH SCREENHEIGHT 'REPLACE GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH (IDIFFERENCE BITSWIDE DXGRID) 0 W)) ((ILESSP 0 DX) (* ;  "determine how many grid point to the left to move.") (SETQ DXGRID (IMIN EBMXOFFSET (GRIDXCOORD DX GRIDSPEC))) (COND ((NOT (IGREATERP DXGRID 0)) (* ; "left edge is at the left margin") (RETURN))) (WINDOWPROP W 'XOFFSET (SETQ EBMXOFFSET (IDIFFERENCE EBMXOFFSET DXGRID))) (* ; "update REGION bar") (replace (REGION LEFT) of EXTENT with (IMIN (IMINUS (IQUOTIENT (TIMES EBMXOFFSET EXTENTWIDTH ) BITMAPWIDTH)) 0)) (* ; "move image to the right.") (BITBLT W GILEFT GIBOTTOM W (IPLUS GILEFT (TIMES DXGRID GWIDTH)) GIBOTTOM SCREENWIDTH SCREENHEIGHT 'INPUT 'REPLACE NIL GRIDINTERIOR) (* ; "clear the newly exposed area.") (BLTSHADE WHITESHADE W GILEFT GIBOTTOM (TIMES DXGRID GWIDTH) GIHEIGHT 'REPLACE) (RESETGRID.NEW BM GRIDSPEC DXGRID BITSHIGH 0 0 W))) (* ; "Make a vertical adjustment") (COND ((FLOATP DY) (* ; "Vertical Thumbing") [WINDOWPROP W 'YOFFSET (SETQ EBMYOFFSET (FIX (TIMES (IDIFFERENCE BITMAPHEIGHT BITSHIGH) (FDIFFERENCE 1.0 DY] (* ; "set EXTENT bar") (replace (REGION BOTTOM) of EXTENT with (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT ) BITMAPHEIGHT))) (* ; "Clear Window") (* BLTSHADE WHITESHADE W GILEFT  GIBOTTOM SCREENWIDTH SCREENHEIGHT  (QUOTE REPLACE) GRIDINTERIOR) (* ;  "Repaint the image using grid function") (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T)) ((ILESSP DY 0) (* ;  "determine how many squares to move down.") (SETQ DYGRID (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) of BM) EBMYLIMIT) (GRIDYCOORD (IMIN GIHEIGHT (IMINUS DY)) GRIDSPEC))) (COND ((NOT (IGREATERP DYGRID 0)) (* ; "top edge is at the top margin") (RETURN))) (WINDOWPROP W 'YOFFSET (SETQ EBMYOFFSET (IPLUS EBMYOFFSET DYGRID))) (replace (REGION BOTTOM) of EXTENT with (IMAX (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) BITMAPHEIGHT)) (IMINUS EXTENTHEIGHT))) (BITBLT W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT)) W GILEFT GIBOTTOM SCREENWIDTH SCREENHEIGHT 'INPUT 'REPLACE NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT  (IPLUS GIBOTTOM (ITIMES  (IDIFFERENCE BITSHIGH DYGRID) GHEIGHT))  SCREENWIDTH SCREENHEIGHT  (QUOTE REPLACE) GRIDINTERIOR) (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 (IDIFFERENCE BITSHIGH DYGRID) W T)) ((ILESSP 0 DY) (* ;  "moving up; determine how may grid squares to move.") (SETQ DYGRID (IMIN EBMYOFFSET (GRIDYCOORD (IMIN GIHEIGHT DY) GRIDSPEC))) (COND ((NOT (IGREATERP DYGRID 0)) (* ;  "bottom edge is at the bottom margin") (RETURN))) (WINDOWPROP W 'YOFFSET (SETQ EBMYOFFSET (IDIFFERENCE EBMYOFFSET DYGRID))) (replace (REGION BOTTOM) of EXTENT with (IMIN (IMINUS (QUOTIENT (TIMES EBMYOFFSET EXTENTHEIGHT) BITMAPHEIGHT)) 0)) (BITBLT W GILEFT GIBOTTOM W GILEFT (IPLUS GIBOTTOM (ITIMES DYGRID GHEIGHT)) SCREENWIDTH SCREENHEIGHT 'INPUT 'REPLACE NIL GRIDINTERIOR) (* BLTSHADE WHITESHADE W GILEFT  GIBOTTOM (fetch (REGION WIDTH) of  GRIDINTERIOR) (ITIMES DYGRID GHEIGHT)  (QUOTE REPLACE)) (RESETGRID.NEW BM GRIDSPEC BITSWIDE DYGRID 0 0 W T))) (* ;; "This call to GRID is unnecessary as the grid dots get filled in earlier.") (* ;; "(COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") [COND ([OR (ILESSP EBMXOFFSET DXOFFSET) (ILESSP EBMYOFFSET DYOFFSET) [IGREATERP (IPLUS EBMXOFFSET BITSWIDE) (IPLUS DXOFFSET (WINDOWPROP W 'BMDISPLAYWIDTH] (IGREATERP (IPLUS EBMYOFFSET BITSHIGH) (IPLUS DYOFFSET (WINDOWPROP W 'BMDISPLAYHEIGHT] (* ;  "Adjust the display region left lower corner so the selected region is near the center.") [WINDOWPROP W 'DXOFFSET (SETQ DXOFFSET (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPWIDTH ) of BM) (WINDOWPROP W 'BMDISPLAYWIDTH)) (IDIFFERENCE (IPLUS EBMXOFFSET (LRSH BITSWIDE 1)) (LRSH (WINDOWPROP W 'BMDISPLAYWIDTH) 1] (WINDOWPROP W 'DYOFFSET (SETQ DYOFFSET (IMAX 0 (IMIN (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT ) of BM) (WINDOWPROP W 'BMDISPLAYHEIGHT) ) (IDIFFERENCE (IPLUS EBMYOFFSET (LRSH BITSHIGH 1)) (LRSH (WINDOWPROP W 'BMDISPLAYHEIGHT) 1] (UPDATE/BM/DISPLAY BM W]) + +(EDITBMCLOSEFN + [LAMBDA (BMW) (* ; "Edited 23-Feb-94 16:07 by turpiN:mv:envos") + + (* ;; "the close function for a bitmap edit window. For now do what a STOP would have done.") + + (* ;; "FS: Assuming this window won't be reused, flush the temporary bm.") + + (WINDOWPROP BMW 'TEMPBM NIL) + (WINDOWPROP BMW 'GRIDBM NIL) + (WINDOWPROP BMW 'FINISHEDFLG 'KILL) + (COND + ((WINDOWPROP BMW 'COORDWIN) + (DETACHWINDOW (WINDOWPROP BMW 'COORDWIN) + BMW) + (CLOSEW (WINDOWPROP BMW 'COORDWIN)) + (WINDOWPROP BMW 'COORDWIN NIL]) + +(TILEAREA [LAMBDA (LFT BTM WDTH HGHT SRCBM WIN) (* ; "Edited 27-Aug-87 21:20 by FS") (* ;;  "lays tiles out in an area of a window. This function only provided for backwards compatibility.") (BLTPATTERN.REPLACEDISPLAY SRCBM 0 0 (BITMAPWIDTH SRCBM) (BITMAPHEIGHT SRCBM) WIN LFT BTM WDTH HGHT]) + +(EDITBMBUTTONFN + [LAMBDA (W) (* ; "Edited 15-Mar-94 10:33 by sybalsky") + (* ; "Edited 5-Mar-92 15:54 by jds") + + (* ;; "inner function of bitmap editor.") + + (DECLARE (GLOBALVARS \CURRENTCURSOR)) + (PROG (GRIDX0 GRIDY0 BITMAPWIDTH BITMAPHEIGHT NEWGRIDSIZE PAINTW ORIGBM GRIDSPEC GRIDINTERIOR BM + BITSWIDE BITSHIGH WREGION XOFFSET YOFFSET DXOFFSET DYOFFSET DISPLAYREGION EXTENT + BITSPERPIXEL CURSORBM) + (SETQ GRIDSPEC (WINDOWPROP W 'GRIDSPEC)) + (SETQ GRIDINTERIOR (WINDOWPROP W 'GRIDINTERIOR)) + (SETQ BM (WINDOWPROP W 'BM)) + (SETQ BITSWIDE (WINDOWPROP W 'BITSWIDE)) + (SETQ BITSHIGH (WINDOWPROP W 'BITSHIGH)) + (SETQ WREGION (WINDOWPROP W 'REGION)) + (SETQ XOFFSET (WINDOWPROP W 'XOFFSET)) + (SETQ YOFFSET (WINDOWPROP W 'YOFFSET)) + (SETQ DXOFFSET (WINDOWPROP W 'DXOFFSET)) + (SETQ DYOFFSET (WINDOWPROP W 'DYOFFSET)) + (SETQ DISPLAYREGION (WINDOWPROP W 'DISPLAYREGION)) + (SETQ EXTENT (WINDOWPROP W 'EXTENT)) + (SETQ GRIDX0 (fetch (REGION LEFT) of GRIDSPEC)) + (SETQ GRIDY0 (fetch (REGION BOTTOM) of GRIDSPEC)) + (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) + (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) + (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)) + (SETQ COLOR (WINDOWPROP W 'COLOR)) + + (* ;; "mark the region of the bitmap that is being editted.") + + (COND + ((INSIDE? GRIDINTERIOR (LASTMOUSEX W) + (LASTMOUSEY W)) + + (* ;; "if cursor is inside, shade it.") + + (\SHADEBITS BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH COLOR)) + ((INSIDE? DISPLAYREGION (LASTMOUSEX W) + (LASTMOUSEY W)) + + (* ;; "Run the menu foe re-windowing into the whole bitmap") + + (SELECTQ [MENU (COND + ((type? MENU EDITBMWINDOWMENU) + EDITBMWINDOWMENU) + ((SETQ EDITBMWINDOWMENU (create MENU + ITEMS _ '((Move 'Move + "Selects a different part of the bitmap to edit." + )) + CENTERFLG _ T] + (Move (* ; + "move the editing window's location on the bitmap.") + (PROG (POS) + [SETQ POS (GETBOXPOSITION BITSWIDE BITSHIGH + [IPLUS 4 (fetch (REGION LEFT) of WREGION) + (- XOFFSET (WINDOWPROP W 'DXOFFSET] + (IPLUS (WINDOWPROP W 'BMDISPLAYBOTTOM) + (- YOFFSET (WINDOWPROP W 'DYOFFSET)) + 4 + (fetch (REGION BOTTOM) of WREGION] + [WINDOWPROP W 'XOFFSET + (SETQ XOFFSET + (IMIN (IDIFFERENCE BITMAPWIDTH BITSWIDE) + (IMAX [IPLUS (WINDOWPROP W 'DXOFFSET) + (- (fetch (POSITION XCOORD) of + POS) + (IPLUS 4 (fetch (REGION LEFT) + of WREGION] + 0] + [WINDOWPROP + W + 'YOFFSET + (SETQ YOFFSET + (IMAX 0 (IMIN (- BITMAPHEIGHT BITSHIGH) + (- (IPLUS (WINDOWPROP W 'DYOFFSET) + (- (fetch (POSITION YCOORD) of POS) + (IPLUS (fetch (REGION BOTTOM) + of WREGION) + 4))) + (WINDOWPROP W 'BMDISPLAYBOTTOM] + (replace (REGION LEFT) of EXTENT + with (IMINUS (QUOTIENT (TIMES XOFFSET (fetch (REGION WIDTH) + of EXTENT)) + BITMAPWIDTH))) + (replace (REGION BOTTOM) of EXTENT + with (IMINUS (QUOTIENT (TIMES YOFFSET (fetch (REGION HEIGHT) + of EXTENT)) + BITMAPHEIGHT))) + [COND + ([OR (ILESSP XOFFSET DXOFFSET) + (ILESSP YOFFSET DYOFFSET) + [IGREATERP (IPLUS XOFFSET BITSWIDE) + (IPLUS DXOFFSET (WINDOWPROP W 'BMDISPLAYWIDTH] + (IGREATERP (IPLUS YOFFSET BITSHIGH) + (IPLUS DYOFFSET (WINDOWPROP W 'BMDISPLAYHEIGHT] + + (* ;; + "Adjust the display region left lower corner so the selected region is near the center.") + + [WINDOWPROP W 'DXOFFSET + (SETQ DXOFFSET + (IMAX 0 (IMIN (- (fetch (BITMAP BITMAPWIDTH) + of BM) + (WINDOWPROP W 'BMDISPLAYWIDTH)) + (- (IPLUS XOFFSET (LRSH BITSWIDE 1)) + (LRSH (WINDOWPROP W 'BMDISPLAYWIDTH) + 1] + (WINDOWPROP W 'DYOFFSET + (SETQ DYOFFSET + (IMAX 0 (IMIN (- (fetch (BITMAP BITMAPHEIGHT) + of BM) + (WINDOWPROP W 'BMDISPLAYHEIGHT)) + (- (IPLUS YOFFSET (LRSH BITSHIGH 1)) + (LRSH (WINDOWPROP W 'BMDISPLAYHEIGHT) + 1] + (* DSPFILL GRIDINTERIOR WHITESHADE + (QUOTE REPLACE) W) + (UPDATE/BM/DISPLAY BM W) + + (* ;; +"FS: More useless code: (COND ((WINDOWPROP W 'GRIDON) (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W)))") + + (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T))) + NIL)) + ((LASTMOUSESTATE LEFT) + (UPDATE/BM/DISPLAY/SELECTED/REGION W) + (SETQ CURSORBM (BITMAPCREATE 16 16 (BITSPERPIXEL BM))) + (BITBLT BM NIL NIL CURSORBM) + [RESETFORM (CURSOR (CURSORCREATE CURSORBM NIL (fetch (CURSOR CUHOTSPOTX) + of \CURRENTCURSOR) + (fetch (CURSOR CUHOTSPOTY) of \CURRENTCURSOR))) + (until (MOUSESTATE (NOT LEFT] + (UPDATE/BM/DISPLAY/SELECTED/REGION W)) + (T + (* ;; "the region being editted is inverted while the menu is active. Each command must make sure that it is recomplemented.") + + (UPDATE/BM/DISPLAY/SELECTED/REGION W) + (SELECTQ [MENU (COND + ((type? MENU EDITBMMENU) + EDITBMMENU) + (T (SETQ EDITBMMENU (create + MENU + ITEMS _ + [APPEND (COND + [(COLORDISPLAYP) + '((Color 'Color + "Choose color to set bits with" + ] + (T NIL)) + '((Paint 'Paint + "Calls the window PAINT command on the bitmap." + ) + (ShowAsTile 'ShowAsTile + "tiles the upper part of the edit window with the bitmap." + ) + (Grid% On/Off 'GridOnOff + "Grid On/Off Switch") + (GridSize_ 'GridSize_ + "Allows setting of the size of a bit in the edit area." + ) + (Reset 'Reset + "Sets the bitmap back to the state at the start of this edit session." + ) + (Clear 'Clear + "Sets the entire bitmap to 0") + (Blacken 'Blacken + "Blacken a region of bits") + (ClearBits 'ClearBits + "Clear a region of bits") + (Show% Coordinates 'ShowCoord + "Toggle coordinate display window, displays on bit-changes" + ) + (Cursor_ 'Cursor_ + "Puts the bitmap into the cursor and exits the editor." + ) + (OK 'OK "Leaves the edit session.") + (Abort 'Abort + "Restores the bitmap to its original values and leaves the editor." + ] + CENTERFLG _ T] + (OK (WINDOWPROP W 'FINISHEDFLG T) + (COND + ((WINDOWPROP W 'COORDWIN) + (DETACHWINDOW (WINDOWPROP W 'COORDWIN) + W) + (CLOSEW (WINDOWPROP W 'COORDWIN)) + (WINDOWPROP W 'COORDWIN NIL)))) + (Abort (WINDOWPROP W 'FINISHEDFLG 'KILL) + (COND + ((WINDOWPROP W 'COORDWIN) + (DETACHWINDOW (WINDOWPROP W 'COORDWIN) + W) + (CLOSEW (WINDOWPROP W 'COORDWIN)) + (WINDOWPROP W 'COORDWIN NIL)))) + (Reset + (* ;; "allow the user to choose between everything or just visible part. This also give the user a chance to change their mind.") + + (COND + ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "RESET how much?") + (VISIBLE [COND + [(SETQ ORIGBM (WINDOWPROP W 'ORIGINALBITMAP)) + (COND + ((REGIONP ORIGBM) + (BITBLT \CURSORDESTINATION + (IPLUS XOFFSET (fetch (REGION LEFT) + of ORIGBM)) + (IPLUS YOFFSET (fetch (REGION BOTTOM) + of ORIGBM)) + BM XOFFSET YOFFSET BITSWIDE BITSHIGH + 'INPUT + 'REPLACE)) + (T (BITBLT ORIGBM XOFFSET YOFFSET BM XOFFSET + YOFFSET BITSWIDE BITSHIGH] + (T (BLTSHADE WHITESHADE BM XOFFSET YOFFSET BITSWIDE + BITSHIGH 'REPLACE] + T) + (WHOLE [COND + [(SETQ ORIGBM (WINDOWPROP W 'ORIGINALBITMAP)) + (COND + ((REGIONP ORIGBM) + (BITBLT \CURSORDESTINATION (fetch (REGION + LEFT) + of ORIGBM) + (fetch (REGION BOTTOM) of ORIGBM) + BM)) + (T (BITBLT ORIGBM NIL NIL BM] + (T (BLTSHADE WHITESHADE BM NIL NIL NIL NIL 'REPLACE] + T) + (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) + NIL)) + (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE + BITSHIGH)))) + (Clear + (* ;; "allow the user to choose between everything or just visible part. This also give the user a chance to change their mind.") + + (COND + ((SELECTQ (\EDITBMHOWMUCH BM BITSWIDE BITSHIGH "CLEAR how much?") + (VISIBLE (BLTSHADE WHITESHADE BM XOFFSET YOFFSET BITSWIDE BITSHIGH + 'REPLACE) + T) + (WHOLE (\CLEARBM BM) + T) + (PROGN (UPDATE/BM/DISPLAY/SELECTED/REGION W) + NIL)) + (DSPFILL GRIDINTERIOR WHITESHADE 'REPLACE W) + (COND + ((WINDOWPROP W 'GRIDON) + (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W))) + (UPDATE/BM/DISPLAY BM W)))) + (Blacken (LET ((REG (GETGRIDBOXREGION 0 0 GRIDSPEC GRIDINTERIOR W))) + (BLTSHADE BLACKSHADE BM (+ (fetch (REGION LEFT) of REG) + XOFFSET) + (+ (fetch (REGION BOTTOM) of REG) + YOFFSET) + (fetch (REGION WIDTH) of REG) + (fetch (REGION HEIGHT) of REG) + 'REPLACE) + (UPDATE/BM/DISPLAY BM W) + (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W))) + (ClearBits (LET ((REG (GETGRIDBOXREGION 0 0 GRIDSPEC GRIDINTERIOR W))) + (BLTSHADE WHITESHADE BM (+ (fetch (REGION LEFT) of REG) + XOFFSET) + (+ (fetch (REGION BOTTOM) of REG) + YOFFSET) + (fetch (REGION WIDTH) of REG) + (fetch (REGION HEIGHT) of REG) + 'REPLACE) + (UPDATE/BM/DISPLAY BM W) + (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W))) + (ShowCoord [LET [(COORDWIN (WINDOWPROP W 'COORDWIN] + (COND + (COORDWIN (DETACHWINDOW COORDWIN W) + (CLOSEW COORDWIN) + (WINDOWPROP W 'COORDWIN NIL)) + (T (ATTACHWINDOW (SETQ COORDWIN + (CREATEW '(0 0 70 32) + "Coordinates" NIL T)) + W + 'TOP + 'LEFT) + (WINDOWPROP W 'COORDWIN COORDWIN]) + (GridOnOff (COND + ((NOT (WINDOWPROP W 'GRIDON)) + (* ; "Turn Grid On") + (WINDOWPROP W 'GRIDON T) + (GRID GRIDSPEC BITSWIDE BITSHIGH 'POINT W) + (UPDATE/BM/DISPLAY BM W) + NIL) + (T (* ; "Turn off grid") + (WINDOWPROP W 'GRIDON NIL) + (* DSPFILL (create REGION LEFT _ 0 + BOTTOM _ 0 WIDTH _ + (ADD1 (fetch (REGION WIDTH) of + GRIDINTERIOR)) HEIGHT _ + (ADD1 (fetch (REGION HEIGHT) of + GRIDINTERIOR))) WHITESHADE + (QUOTE REPLACE) W) + (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 W T) + (UPDATE/BM/DISPLAY BM W) + NIL))) + (GridSize_ (* ; + "sets the grid square size and calls the reshapefn.") + (COND + ([SETQ NEWGRIDSIZE + (NUMBERP (MENU (COND + ((TYPENAMEP GRIDSIZEMENU 'MENU) + GRIDSIZEMENU) + (T (SETQ GRIDSIZEMENU + (create MENU + ITEMS _ + '(3 4 5 6 7 8 12 16 20 24 28 32) + MENUROWS _ 4] + (WINDOWPROP W 'GRIDSQUARE NEWGRIDSIZE) + (EDITBMRESHAPEFN W)))) + (ShowAsTile (* ; "tiles the upper part of the window with the bitmap so the user can see what it would be as a shade.") + (UPDATE/SHADE/DISPLAY BM W)) + (Paint (* ; + "call the window paint command on the contents of the bitmap.") + [SETQ PAINTW (CREATEW (create REGION + LEFT _ (IQUOTIENT (- SCREENWIDTH BITMAPWIDTH) + 2) + BOTTOM _ (IQUOTIENT (- SCREENHEIGHT + BITMAPHEIGHT) + 2) + WIDTH _ (WIDTHIFWINDOW BITMAPWIDTH) + HEIGHT _ (HEIGHTIFWINDOW BITMAPHEIGHT NIL] + (OPENW PAINTW) + (BITBLT BM 0 0 PAINTW) + (PAINTW PAINTW) + (COND + ((MENU (create MENU + ITEMS _ '((YES T + "Will put the newly painted bits back in the bitmap being editted." + ) + (NO NIL + "Will discard the painted bits, not changing the bitmap being editted." + )) + TITLE _ "Put change into bitmap?" + CENTERFLG _ T)) + (BITBLT PAINTW 0 0 BM) + (\EDITBM/PUTUP/DISPLAY W BM GRIDSPEC GRIDINTERIOR BITSWIDE + BITSHIGH))) + (CLOSEW PAINTW) (* ; + "set PAINTW so that space can be reclaimed") + (SETQ PAINTW)) + (Cursor_ (* ; + "Stuffs lower left part of image into the cursor and sets the hotspot.") + (READHOTSPOT BM GRIDSPEC GRIDINTERIOR W) + (* WINDOWPROP W (QUOTE FINISHEDFLG) + T) + ) + (Color (WINDOWPROP W 'COLOR (OR (MENU (COLORMENU BITSPERPIXEL)) + COLOR))) + (UPDATE/BM/DISPLAY/SELECTED/REGION W]) + +(\EDITBM/PUTUP/DISPLAY [LAMBDA (WINDOW BM GRIDSPEC GRIDINTERIOR BITSWIDE BITSHIGH)(* ; "Edited 31-Aug-87 13:05 by FS") (* initializes the display for the  bitmap editor.) (* DSPFILL GRIDINTERIOR WHITESHADE  (QUOTE REPLACE) WINDOW) (* COND ((WINDOWPROP WINDOW  (QUOTE GRIDON)) (GRID GRIDSPEC  BITSWIDE BITSHIGH (QUOTE POINT) WINDOW))) (RESETGRID.NEW BM GRIDSPEC BITSWIDE BITSHIGH 0 0 WINDOW T) (UPDATE/BM/DISPLAY BM WINDOW]) + +(\EDITBMHOWMUCH [LAMBDA (BM EDITWIDTH EDITHEIGHT TITLEQ) (* kbr%: " 2-Sep-85 19:44") (* asks the user how much to clear) (MENU (COND ((OR (IGREATERP (fetch (BITMAP BITMAPWIDTH) of BM) EDITWIDTH) (IGREATERP (fetch (BITMAP BITMAPHEIGHT) of BM) EDITHEIGHT)) (create MENU TITLE _ TITLEQ ITEMS _ '((VisiblePart 'VISIBLE "Operates on just the part visible in the edit region") (WholeBitmap 'WHOLE "Operates on the entire bitmap")) CENTERFLG _ T)) (T (create MENU TITLE _ TITLEQ ITEMS _ '((WholeBitmap 'WHOLE "Operates on the entire bitmap")) CENTERFLG _ T]) + +(EDITBMRESHAPEFN [LAMBDA (BMEDITWINDOW OLDIMAGE OLDREGION OLDSCREENREGION ZEROBMFLG) (* ; "Edited 7-Dec-88 17:00 by SHIH") (* ;; "allows the bitmap edit window to be reshaped to enlarge the editting area. This is also called to set up the image during initialization.") (PROG (BMWINTERIORWIDTH BMWINTERIORHEIGHT EDITAREABITWIDTH EDITAREABITHEIGHT GRIDSQUARE GRIDINTERIOR BITMAPWIDTH BMDISPLAYWIDTH BMDISPLAYBOTTOM BMDISPLAYHEIGHT BITMAPHEIGHT (BM (WINDOWPROP BMEDITWINDOW 'BM)) MINCOMMANDAREAWIDTH EXTENTWIDTH EXTENTHEIGHT TEMPBM) (SETQ MINCOMMANDAREAWIDTH 30) (SETQ BITMAPWIDTH (fetch (BITMAP BITMAPWIDTH) of BM)) (SETQ BITMAPHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BM)) (SETQ BMWINTERIORWIDTH (WINDOWPROP BMEDITWINDOW 'WIDTH)) (* ;;  "leave room at the top for the full size display area. But not more than half of the window.") (SETQ BMWINTERIORHEIGHT (IMAX (IDIFFERENCE (WINDOWPROP BMEDITWINDOW 'HEIGHT) (IPLUS BITMAPHEIGHT GRIDTHICKNESS)) (IQUOTIENT (WINDOWPROP BMEDITWINDOW 'HEIGHT) 2))) (* ;; "if the user hasn't set it, determine the grid size as the largest size which fits the interior but not larger than NORMALGRIDSQUARE nor smaller than MINGRIDSQUARE. If GRIDSQUARE was specified, reset it to NIL so that if reshaped it will be recalculated.") (SETQ GRIDSQUARE (OR (WINDOWPROP BMEDITWINDOW 'GRIDSQUARE NIL) (IMAX (IMIN (IQUOTIENT BMWINTERIORWIDTH BITMAPWIDTH) (IQUOTIENT BMWINTERIORHEIGHT BITMAPHEIGHT) NORMALGRIDSQUARE) MINGRIDSQUARE))) (* ;  "calculate how many bits will be displayed at once.") (SETQ EDITAREABITWIDTH (IMIN (IQUOTIENT BMWINTERIORWIDTH GRIDSQUARE) BITMAPWIDTH)) (WINDOWPROP BMEDITWINDOW 'BITSWIDE EDITAREABITWIDTH) (SETQ EDITAREABITHEIGHT (IMIN (IQUOTIENT BMWINTERIORHEIGHT GRIDSQUARE) BITMAPHEIGHT)) (* ;  "calculate offset of display and command regions at the top of the window.") (WINDOWPROP BMEDITWINDOW 'BITSHIGH EDITAREABITHEIGHT) (SETQ BMDISPLAYBOTTOM (IPLUS (ITIMES GRIDSQUARE EDITAREABITHEIGHT) GRIDTHICKNESS)) (SETQ BMDISPLAYWIDTH (IMIN BITMAPWIDTH (IDIFFERENCE BMWINTERIORWIDTH MINCOMMANDAREAWIDTH))) (* ;; "put the offset --- the lower left coordinate --- in the same place unless the new shape allows more to be shown past the upper right corner.") (WINDOWPROP BMEDITWINDOW 'XOFFSET (IMIN (WINDOWPROP BMEDITWINDOW 'XOFFSET) (IDIFFERENCE BITMAPWIDTH EDITAREABITWIDTH))) (WINDOWPROP BMEDITWINDOW 'YOFFSET (IMIN (WINDOWPROP BMEDITWINDOW 'YOFFSET) (IDIFFERENCE BITMAPHEIGHT EDITAREABITHEIGHT))) (* ; "Center edit square") (SETQ GRIDINTERIOR (create REGION LEFT _ (IQUOTIENT (IDIFFERENCE BMWINTERIORWIDTH (ITIMES EDITAREABITWIDTH GRIDSQUARE )) 2) BOTTOM _ (IQUOTIENT (IDIFFERENCE BMDISPLAYBOTTOM (ITIMES EDITAREABITHEIGHT GRIDSQUARE )) 2) WIDTH _ (ITIMES EDITAREABITWIDTH GRIDSQUARE) HEIGHT _ (ITIMES EDITAREABITHEIGHT GRIDSQUARE))) (WINDOWPROP BMEDITWINDOW 'GRIDINTERIOR GRIDINTERIOR) (WINDOWPROP BMEDITWINDOW 'BMDISPLAYBOTTOM BMDISPLAYBOTTOM) (WINDOWPROP BMEDITWINDOW 'BMDISPLAYWIDTH BMDISPLAYWIDTH) (WINDOWPROP BMEDITWINDOW 'BMDISPLAYHEIGHT (SETQ BMDISPLAYHEIGHT (IDIFFERENCE (WINDOWPROP BMEDITWINDOW 'HEIGHT) BMDISPLAYBOTTOM))) (WINDOWPROP BMEDITWINDOW 'DISPLAYREGION (create REGION LEFT _ 0 BOTTOM _ BMDISPLAYBOTTOM WIDTH _ BMDISPLAYWIDTH HEIGHT _ BMDISPLAYHEIGHT)) (WINDOWPROP BMEDITWINDOW 'GRIDSPEC (create REGION LEFT _ (fetch (REGION LEFT) of GRIDINTERIOR ) BOTTOM _ (fetch (REGION BOTTOM) of GRIDINTERIOR ) WIDTH _ GRIDSQUARE HEIGHT _ GRIDSQUARE)) (SETQ EXTENTHEIGHT (QUOTIENT (TIMES BITMAPHEIGHT (WINDOWPROP BMEDITWINDOW 'HEIGHT)) EDITAREABITHEIGHT)) [SETQ EXTENTWIDTH (IDIFFERENCE (QUOTIENT (TIMES BITMAPWIDTH BMWINTERIORWIDTH) EDITAREABITWIDTH) (WINDOWPROP BMEDITWINDOW 'BORDER] (WINDOWPROP BMEDITWINDOW 'EXTENT (CREATEREGION (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW 'XOFFSET) EXTENTWIDTH) BITMAPWIDTH)) (MINUS (QUOTIENT (TIMES (WINDOWPROP BMEDITWINDOW 'YOFFSET) EXTENTHEIGHT) BITMAPHEIGHT)) EXTENTWIDTH EXTENTHEIGHT)) (* ;; "Build & cache a temporary bitmap.") (* ;; "Could make only (min (bitmapheight bm) (iquotient (bitmapheight window) scale)), except if user changes scale, bitmap might be too small. So, make sufficiently large just to be safe.") (SETQ TEMPBM (WINDOWPROP BMEDITWINDOW 'TEMPBM)) (LET ((TEMPBM.W BMWINTERIORWIDTH) (TEMPBM.H (IMIN BITMAPHEIGHT EDITAREABITHEIGHT))) (if (OR (NOT TEMPBM) (OR (< (BITMAPWIDTH TEMPBM) TEMPBM.W) (< (BITMAPHEIGHT TEMPBM) TEMPBM.H))) then (SETQ TEMPBM (BITMAPCREATE TEMPBM.W TEMPBM.H (FETCH (BITMAP BITMAPBITSPERPIXEL ) OF BM))) (WINDOWPROP BMEDITWINDOW 'TEMPBM TEMPBM))) (EDITBMREPAINTFN BMEDITWINDOW NIL ZEROBMFLG]) + +(EDITBMREPAINTFN [LAMBDA (WIN REGION ZEROBM) (* ; "Edited 8-Dec-88 14:38 by SHIH") (* ;;  "redisplays a bitmap editting window If ZEROBM is non-NIL, it doesn't bother to display the bits.") (PROG [(GRIDSPEC (WINDOWPROP WIN 'GRIDSPEC)) (EDITAREABITWIDTH (WINDOWPROP WIN 'BITSWIDE)) (EDITAREABITHEIGHT (WINDOWPROP WIN 'BITSHIGH)) (BM (WINDOWPROP WIN 'BM] (CLEARW WIN) (* ;  "gray the area above the edit grid that is not bitmap display area.") (BLTSHADE NOTINUSEGRAY WIN (+ (WINDOWPROP WIN 'BMDISPLAYWIDTH) GRIDTHICKNESS) (WINDOWPROP WIN 'BMDISPLAYBOTTOM)) (* ;; "put in the display of the full sized bitmap.") (UPDATE/BM/DISPLAY BM WIN) (* ;; "FS: Now that RESETGRID displays the grid, don't need the call to GRID.") (if ZEROBM then (if (WINDOWPROP WIN 'GRIDON) then (GRID GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 'POINT WIN)) else (RESETGRID.NEW BM GRIDSPEC EDITAREABITWIDTH EDITAREABITHEIGHT 0 0 WIN]) + +(UPDATE/SHADE/DISPLAY [LAMBDA (BM WIN) (* rrb "20-JUN-82 16:53") (* displays BM as if it were a shade.) (PROG [(BOTTOM (WINDOWPROP WIN 'BMDISPLAYBOTTOM] (TILEAREA 0 BOTTOM (WINDOWPROP WIN 'WIDTH) (IDIFFERENCE (WINDOWPROP WIN 'HEIGHT) BOTTOM) BM WIN]) + +(UPDATE/BM/DISPLAY/SELECTED/REGION [LAMBDA (W) (* ; "Edited 1-Sep-87 17:48 by FS") (* Shade the selected region of the  bitmap display area.) (COND ([OR (IGREATERP (fetch (BITMAP BITMAPWIDTH) of (WINDOWPROP W 'BM)) (WINDOWPROP W 'BITSWIDE)) (IGREATERP (fetch (BITMAP BITMAPHEIGHT) of (WINDOWPROP W 'BM)) (WINDOWPROP W 'BITSHIGH] (* only invert the region being editted if it is less than the entire bitmap.) (BLTSHADE BLACKSHADE W (IDIFFERENCE (WINDOWPROP W 'XOFFSET) (WINDOWPROP W 'DXOFFSET)) (IDIFFERENCE (IPLUS (WINDOWPROP W 'BMDISPLAYBOTTOM) (WINDOWPROP W 'YOFFSET)) (WINDOWPROP W 'DYOFFSET)) (WINDOWPROP W 'BITSWIDE) (WINDOWPROP W 'BITSHIGH) 'INVERT]) + +(SHOWBUTTON [LAMBDA (BUTTON DS) (* rrb "27-JUL-81 10:59") (* displays a menu box and its title.) (PROG ((BLOCK (fetch (BUTTON REGION) of BUTTON))) (WBOX BLOCK NIL NIL DS) (* Display the title in the middle of  the box) (CENTERPRINTINREGION (fetch (BUTTON LABEL) of BUTTON) BLOCK DS]) + +(RESETGRID.NEW [LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORIGX ORIGY WINDOW DOCLEARFLG) (* ; "Edited 8-Dec-88 14:36 by SHIH") (* ;; "Copies the contents of a bitmap into the edit display grid of window. ORIGX & Y are used to offest into both bitmap and destination window.") (LET (XOFFSET YOFFSET MAXX MAXY SHADE XSCALE YSCALE TEMPBM) (SETQ XSCALE (fetch (REGION WIDTH) of GRIDSPEC)) (SETQ YSCALE (fetch (REGION HEIGHT) of GRIDSPEC)) (if (NULL ORIGX) then (SETQ ORIGX 0)) (if (NULL ORIGY) then (SETQ ORIGY 0)) (SETQ XOFFSET (WINDOWPROP WINDOW 'XOFFSET)) (SETQ YOFFSET (WINDOWPROP WINDOW 'YOFFSET)) (SETQ MAXX (IPLUS ORIGX WIDTH -1)) (SETQ MAXY (IPLUS ORIGY HEIGHT -1)) (SETQ TEMPBM (WINDOWPROP WINDOW 'TEMPBM)) (* ;; "Use SCALEBM. Bitmap destination must be empty (white).") (if DOCLEARFLG then (BLTSHADE WHITESHADE WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) (CL:* WIDTH XSCALE) (CL:* HEIGHT YSCALE) 'REPLACE)) (SCALEBM BM (+ ORIGX XOFFSET) (+ ORIGY YOFFSET) WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) WIDTH HEIGHT XSCALE YSCALE TEMPBM) (* ;; "Texture the pixels correctly (note that Bltshade has a different meaning on color BMs, so only shade if its B/W). DARKBITSHADE MUST be a number, but try and be robust anyway.") (IF (= 1 (BITSPERPIXEL BM)) THEN (BLTSHADE (if (NUMBERP DARKBITSHADE) then (- -1 DARKBITSHADE) else DARKBITSHADE) WINDOW (LEFTOFGRIDCOORD ORIGX GRIDSPEC) (BOTTOMOFGRIDCOORD ORIGY GRIDSPEC) (CL:* WIDTH XSCALE) (CL:* HEIGHT YSCALE) 'ERASE)) (* ;; "Add grid") (if (WINDOWPROP WINDOW 'GRIDON) then (if (OR (NEQ ORIGX (CAR GRIDSPEC)) (NEQ ORIGY (CADR GRIDSPEC))) then (SETQ GRIDSPEC (COPYALL GRIDSPEC)) (replace (REGION LEFT) of GRIDSPEC with (  LEFTOFGRIDCOORD ORIGX GRIDSPEC)) (replace (REGION BOTTOM) of GRIDSPEC with (  BOTTOMOFGRIDCOORD ORIGY GRIDSPEC ))) (GRID GRIDSPEC WIDTH HEIGHT 'POINT WINDOW]) + +(RESETGRID [LAMBDA (BM GRIDSPEC WIDTH HEIGHT ORGX ORGY W) (* ; "Edited 7-Dec-88 16:58 by SHIH") (* ;; "copies the contents of a bitmap into the edit display grid.") (* ;; "This is no longer called from HLDISPLAY, and is probably obsolete. Thus code commented out, below.") (* ;; "(PROG (XOFFSET YOFFSET MAXX MAXY SHADE) (COND ((NULL ORGX) (SETQ ORGX 0))) (COND ((NULL ORGY) (SETQ ORGY 0))) (SETQ XOFFSET (WINDOWPROP W 'XOFFSET)) (SETQ YOFFSET (WINDOWPROP W 'YOFFSET)) (SETQ MAXX (IPLUS ORGX WIDTH -1)) (SETQ MAXY (IPLUS ORGY HEIGHT -1)) (for Y from ORGY to MAXY do (for X from ORGX to MAXX do (SETQ SHADE (EDITBMTEXTURE BM (IPLUS X XOFFSET) (IPLUS Y YOFFSET))) (SHADEGRIDBOX X Y SHADE 'REPLACE GRIDSPEC (COND ((NULL (WINDOWPROP W 'GRIDON)) 0) (T 'POINT)) W))))") NIL]) + +(\READBMDIMENSIONS [LAMBDA NIL (* gbn%: "26-Jan-86 15:57") (* asks the user for dimensions of a bitmap and creates it.) (PROG (WIDTH HEIGHT) WIDTHLP (PRIN1 "How wide would you like the bitmap to be? " T) (COND ([NOT (NUMBERP (SETQ WIDTH (READ T] (PRIN1 "?" T) (TERPRI T) (GO WIDTHLP)) ((ILESSP WIDTH 1) (PRIN1 "WIDTH must be positive." T) (TERPRI T) (GO WIDTHLP))) HEIGHTLP (PRIN1 "How high would you like the bitmap to be? " T) (COND ([NOT (NUMBERP (SETQ HEIGHT (READ T] (PRIN1 "?" T) (TERPRI T) (GO HEIGHTLP)) ((ILESSP HEIGHT 1) (PRIN1 "HEIGHT must be positive." T) (TERPRI T) (GO HEIGHTLP))) (RETURN (BITMAPCREATE WIDTH HEIGHT (BITSPERPIXEL \CURSORDESTINATION]) + +(EDITSHADE [LAMBDA (SHADE) (* ; "Edited 10-Oct-89 12:08 by jds") (* ;; "a simple shade editor.") (PROG (SHADEBM QUITREGION SHADEREGION BMWIDTH BMHEIGHT GRIDINTERIOR GRIDSPEC X Y SEDW BOXSIZE SHOWREGION) [SETQ SHADEBM (COND ((BITMAPP SHADE) (CREATETEXTUREFROMBITMAP SHADE)) ((FIXP SHADE) (\BITMAPFROMTEXTURE SHADE)) ((EQ SHADE T) (BITMAPCREATE 16 16)) ((NULL SHADE) (BITMAPCREATE 4 4)) (T (\ILLEGAL.ARG SHADE] (SETQ QUITREGION (CREATEREGION 72 150 50 20)) (SETQ SHOWREGION (CREATEREGION 125 150 100 20)) (SETQ SHADEREGION (CREATEREGION 10 185 272 100)) (SETQ SEDW (CREATEW (GETBOXREGION 300 300 NIL NIL NIL "Indicate position of Shade edit window."))) (SETQ BMWIDTH (BITMAPWIDTH SHADEBM)) (SETQ BMHEIGHT (BITMAPHEIGHT SHADEBM)) (SETQ BOXSIZE (IMIN (IQUOTIENT 144 BMHEIGHT) (IQUOTIENT 256 BMWIDTH))) (WINDOWPROP SEDW 'PROCESS (THIS.PROCESS)) (WINDOWPROP SEDW 'REPAINTFN 'EDITSHADEREPAINTFN) (WINDOWPROP SEDW 'QUITREGION QUITREGION) (WINDOWPROP SEDW 'SHOWREGION SHOWREGION) (WINDOWPROP SEDW 'GRIDSPEC (SETQ GRIDSPEC (CREATEREGION (SETQ X (IQUOTIENT (- 292 (ITIMES BOXSIZE BMWIDTH)) 2)) (SETQ Y (IQUOTIENT (- 150 (ITIMES BOXSIZE BMHEIGHT) ) 2)) BOXSIZE BOXSIZE))) [WINDOWPROP SEDW 'GRIDINTERIOR (SETQ GRIDINTERIOR (CREATEREGION X Y (ITIMES BOXSIZE BMWIDTH ) (ITIMES BOXSIZE BMHEIGHT] (WINDOWPROP SEDW 'SHADEBM SHADEBM) (WINDOWPROP SEDW 'SHADEREGION SHADEREGION) (WINDOWPROP SEDW 'XOFFSET 0) (WINDOWPROP SEDW 'YOFFSET 0) (EDITSHADEREPAINTFN SEDW) (RESETLST (RESETSAVE NIL (LIST 'CLOSEW SEDW)) [do (DSPFILL SHADEREGION (COND ((EQ BMWIDTH 4)(* ;  "bitblt doesn't like bitmaps that are not 16 by 16.0") (CREATETEXTUREFROMBITMAP SHADEBM)) (T SHADEBM)) 'TEXTURE SEDW) (until (MOUSESTATE (OR LEFT MIDDLE RIGHT)) do (TOTOPW SEDW) (BLOCK)) (COND [(LASTMOUSESTATE RIGHT) (ERSETQ (DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY] ((EQ 'STOP (until (MOUSESTATE UP) bind (XPIXEL YPIXEL) do (TOTOPW SEDW) [COND [(INSIDE? GRIDINTERIOR (SETQ X (LASTMOUSEX SEDW)) (SETQ Y (LASTMOUSEY SEDW))) (COND ((AND (STRICTLY/BETWEEN (SETQ XPIXEL (GRIDXCOORD X GRIDSPEC)) -1 BMWIDTH) (STRICTLY/BETWEEN (SETQ YPIXEL (GRIDYCOORD Y GRIDSPEC)) -1 BMHEIGHT)) (SHADEGRIDBOX XPIXEL YPIXEL (COND ((LASTMOUSESTATE LEFT) DARKBITSHADE) (T WHITESHADE)) 'REPLACE GRIDSPEC 'POINT SEDW) (BITMAPBIT SHADEBM XPIXEL YPIXEL (COND ((LASTMOUSESTATE LEFT) 1) (T 0] [(INSIDE? QUITREGION X Y) (DSPFILL QUITREGION BLACKSHADE 'INVERT SEDW) (RETURN (until (MOUSESTATE UP) do (COND ((NOT (INSIDE? QUITREGION (LASTMOUSEX SEDW) (LASTMOUSEY SEDW))) (DSPFILL QUITREGION BLACKSHADE 'INVERT SEDW) (RETURN))) finally (DSPFILL QUITREGION BLACKSHADE 'INVERT SEDW) (* ; "close window.") (RETURN 'STOP] ((INSIDE? SHOWREGION X Y) (DSPFILL SHOWREGION BLACKSHADE 'INVERT SEDW) (RETURN (until (MOUSESTATE UP) do (COND ((NOT (INSIDE? SHOWREGION (LASTMOUSEX SEDW) (LASTMOUSEY SEDW))) (DSPFILL SHOWREGION BLACKSHADE 'INVERT SEDW) (RETURN))) finally (DSPFILL SHOWREGION BLACKSHADE 'INVERT SEDW) (* ; "close window.") (PRINTOUT (GETPROMPTWINDOW SEDW 1) T "Texture: " ( CREATETEXTUREFROMBITMAP SHADEBM] (BLOCK))) (RETURN]) (RETURN (COND ((AND (OR (NUMBERP SHADE) (NULL SHADE)) (EQ BMWIDTH 4) (EQ BMHEIGHT 4)) (* ;  "user passed in a number or NIL, give them a number back.") (CREATETEXTUREFROMBITMAP SHADEBM)) (T SHADEBM]) + +(\BITMAPFROMTEXTURE [LAMBDA (FIXP) (* rrb "16-May-84 14:56") (* returns a 4 by 4 bitmap that contains the texture represented by FIXP.) (PROG ((SHADE (BITMAPCREATE 4 4))) [for X from 0 to 3 do (for Y from 0 to 3 do (COND ([NOT (EQ 0 (LOGAND FIXP (\BITMASK (IPLUS (ITIMES (IDIFFERENCE 3 Y) 4) X] (BITMAPBIT SHADE X Y 1] (RETURN SHADE]) + +(EDITSHADEREPAINTFN [LAMBDA (WIN) (* ; "Edited 10-Oct-89 12:04 by jds") (* ;  "redisplays an edit shade window.") (PROG (GRIDSPEC SHADE BMWIDTH BMHEIGHT) (SETQ GRIDSPEC (WINDOWPROP WIN 'GRIDSPEC)) (SETQ SHADE (WINDOWPROP WIN 'SHADEBM)) (SETQ BMWIDTH (BITMAPWIDTH SHADE)) (SETQ BMHEIGHT (BITMAPHEIGHT SHADE)) (SHOWBUTTON (create BUTTON REGION _ (WINDOWPROP WIN 'QUITREGION) LABEL _ 'QUIT HELP _ "Quits") WIN) (SHOWBUTTON (create BUTTON REGION _ (WINDOWPROP WIN 'SHOWREGION) LABEL _ 'Show% Number HELP _ "Displays the texture number for the current shade.") WIN) (GRAYBOXAREA (fetch (REGION LEFT) of GRIDSPEC) (fetch (REGION BOTTOM) of GRIDSPEC) (ITIMES (fetch (REGION WIDTH) of GRIDSPEC) BMWIDTH) (ITIMES (fetch (REGION HEIGHT) of GRIDSPEC) BMHEIGHT) 2 BLACKSHADE WIN) (RESETGRID.NEW SHADE GRIDSPEC BMWIDTH BMHEIGHT 0 0 WIN) (* ;  "GRID GRIDSPEC BMWIDTH BMHEIGHT (QUOTE POINT) WIN") (DSPFILL (WINDOWPROP WIN 'SHADEREGION) SHADE 'TEXTURE WIN]) + +(GRAYBOXAREA [LAMBDA (X Y WIDTH HEIGHT OUTLINESIZE TEXTURE DS) (* ; "Edited 1-Sep-87 17:49 by FS") (* outlines an area with a gray box.) (COND ((FIXP OUTLINESIZE)) ((NULL OUTLINESIZE) (SETQ OUTLINESIZE 1)) (T (\ILLEGAL.ARG OUTLINESIZE))) (BLTSHADE (OR TEXTURE BLACKSHADE) DS (IDIFFERENCE X OUTLINESIZE) (IDIFFERENCE Y OUTLINESIZE) (IPLUS WIDTH (ITIMES 2 OUTLINESIZE)) (IPLUS HEIGHT (ITIMES 2 OUTLINESIZE)) 'REPLACE) (BLTSHADE (DSPTEXTURE NIL DS) DS X Y WIDTH HEIGHT 'REPLACE]) + +(\SHADEBITS [LAMBDA (BM GRIDSPEC GRIDINTERIOR W BITSWIDE BITSHIGH COLOR) (* ;  "Edited 7-Jun-93 11:43 by sybalsky:mv:envos") (* cursor is inside the edit grid, so change the bit in the bitmap, change the  edit grid and redisplay the bitmap.) (PROG (BITSPERPIXEL XPIXEL YPIXEL OTHERCOLOR SHADE OTHERSHADE USECOLOR USESHADE X Y COORDWIN) (SETQ BITSPERPIXEL (BITSPERPIXEL BM)) (SETQ OTHERCOLOR (OPPOSITECOLOR COLOR BITSPERPIXEL)) (COND [(EQ BITSPERPIXEL 1) (COND ((EQ COLOR 1) (SETQ SHADE DARKBITSHADE) (SETQ OTHERSHADE WHITESHADE)) (T (SETQ SHADE WHITESHADE) (SETQ OTHERSHADE DARKBITSHADE] (T (SETQ SHADE COLOR) (SETQ OTHERSHADE OTHERCOLOR))) (until (MOUSESTATE UP) when (AND [NOT (EQ (AND [EQ XPIXEL (SETQ XPIXEL (IMAX 0 (IMIN BITSWIDE (GRIDXCOORD (SETQ X (LASTMOUSEX W)) GRIDSPEC] YPIXEL) (SETQ YPIXEL (IMAX 0 (IMIN BITSHIGH (GRIDYCOORD (SETQ Y (LASTMOUSEY W)) GRIDSPEC] (INSIDE? GRIDINTERIOR X Y)) do (COND ((LASTMOUSESTATE LEFT) (SETQ USECOLOR COLOR) (SETQ USESHADE SHADE)) (T (SETQ USECOLOR OTHERCOLOR) (SETQ USESHADE OTHERSHADE))) [COND ((SETQ COORDWIN (WINDOWPROP W 'COORDWIN)) (CLEARW COORDWIN) (MOVETO 2 4 COORDWIN) (PRINTOUT COORDWIN (IPLUS XPIXEL (WINDOWPROP W 'XOFFSET)) ", " (IPLUS YPIXEL (WINDOWPROP W 'YOFFSET] (BITMAPBIT BM (IPLUS XPIXEL (WINDOWPROP W 'XOFFSET)) (IPLUS YPIXEL (WINDOWPROP W 'YOFFSET)) USECOLOR) (UPDATE/BM/DISPLAY BM W) (SHADEGRIDBOX XPIXEL YPIXEL USESHADE 'REPLACE GRIDSPEC (COND ((NULL (WINDOWPROP W 'GRIDON)) 0) (T 'POINT)) W]) + +(READHOTSPOT [LAMBDA (BM GRIDSPEC GRIDINTERIOR DS) (* ; "Edited 10-Jul-92 16:47 by cat") (* kbr%: "13-Feb-86 15:21") (* reads the hotspot from the cursor  and sets cursor) (UNTILMOUSESTATE UP) (PROG (NOWCURSOR XPIXEL YPIXEL DOWNYET? CURSORBM) (SETQ NOWCURSOR (CURSOR)) (CURSORPOSITION (create POSITION XCOORD _ (IPLUS (LEFTOFGRIDCOORD (SETQ XPIXEL (fetch (CURSOR CUHOTSPOTX) of NOWCURSOR)) GRIDSPEC) (IQUOTIENT (fetch (REGION WIDTH) of GRIDSPEC ) 2)) YCOORD _ (IPLUS (BOTTOMOFGRIDCOORD (SETQ YPIXEL (fetch (CURSOR CUHOTSPOTY ) of NOWCURSOR)) GRIDSPEC) (IQUOTIENT (fetch (REGION HEIGHT) of GRIDSPEC ) 2))) DS) (* SHADEGRIDBOX XPIXEL YPIXEL  NOTINUSEGRAY (QUOTE REPLACE)  GRIDSPEC (QUOTE POINT) DS) (until (PROGN (BLOCK) (GETMOUSESTATE) (AND DOWNYET? (MOUSESTATE UP))) when (INSIDE? GRIDINTERIOR (LASTMOUSEX DS) (LASTMOUSEY DS)) do [OR DOWNYET? (SETQ DOWNYET? (NOT (EQ LASTMOUSEBUTTONS 0] (* COND (XPIXEL (SHADEGRIDBOX XPIXEL  YPIXEL (EDITBMTEXTURE BM XPIXEL  YPIXEL) (QUOTE REPLACE) GRIDSPEC  (QUOTE POINT) DS))) (* SHADEGRIDBOX (SETQ XPIXEL  (GRIDXCOORD (LASTMOUSEX DS) GRIDSPEC))  (SETQ YPIXEL (GRIDYCOORD  (LASTMOUSEY DS) GRIDSPEC))  NOTINUSEGRAY (QUOTE REPLACE)  GRIDSPEC (QUOTE POINT) DS) finally (SETQ CURSORBM (BITMAPCREATE 16 16 (BITSPERPIXEL BM))) (BITBLT BM NIL NIL CURSORBM) (CURSOR (CURSORCREATE CURSORBM NIL XPIXEL YPIXEL]) + +(WBOX [LAMBDA (REG THCK TEXTURE DS) (* ; "Edited 1-Sep-87 17:52 by FS") (* Draws a box around REG with bounding lines of THCKness) (OR THCK (SETQ THCK 2)) (BLTSHADE BLACKSHADE DS NIL NIL NIL NIL 'REPLACE REG) (BLTSHADE (OR TEXTURE (DSPTEXTURE NIL DS)) DS (IPLUS (fetch (REGION LEFT) of REG) THCK) (IPLUS (fetch (REGION BOTTOM) of REG) THCK) (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES 2 THCK)) (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (ITIMES 2 THCK)) 'REPLACE]) + +(\CLEARBM [LAMBDA (BM TXT REG) (* ; "Edited 1-Sep-87 17:53 by FS") (BLTSHADE (OR TXT WHITESHADE) BM NIL NIL NIL NIL 'REPLACE REG]) + +(EDITBMTEXTURE [LAMBDA (BM X Y) (* kbr%: " 9-Jan-86 21:51") (* Texture EDITBM should use to represent pixel  (X . Y) of BM. *) (PROG (COLOR SHADE) (SETQ COLOR (BITMAPBIT BM X Y)) (SETQ SHADE (COND ((EQ (BITSPERPIXEL BM) 1) (COND ((EQ COLOR 1) DARKBITSHADE) (T WHITESHADE))) (T COLOR))) (RETURN SHADE]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RECORD BUTTON (REGION LABEL HELP)) +) + +(DECLARE%: EVAL@COMPILE + +[PUTPROPS BITMASK MACRO ((X) + (LLSH 1 (IDIFFERENCE 15 X] + +[PUTPROPS UPDATE/BM/DISPLAY MACRO ((BM W) + (BITBLT BM (WINDOWPROP W 'DXOFFSET) + (WINDOWPROP W 'DYOFFSET) + W 0 (WINDOWPROP W 'BMDISPLAYBOTTOM) + (WINDOWPROP W 'BMDISPLAYWIDTH) + 1000 NIL 'REPLACE] +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQQ DARKBITSHADE 23130) + +(RPAQQ NORMALGRIDSQUARE 16) + +(RPAQQ NOTINUSEGRAY 42405) + +(RPAQQ EDITBMMENU NIL) + +(RPAQQ EDITBMWINDOWMENU NIL) + +(RPAQQ GRIDSIZEMENU NIL) + +(RPAQQ CLICKWAITTIME 250) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DARKBITSHADE NORMALGRIDSQUARE NOTINUSEGRAY EDITBMMENU CLICKWAITTIME) +) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ GRIDTHICKNESS 2) + +(RPAQQ MINGRIDSQUARE 8) + +(RPAQQ MAXGRIDWIDTH 199) + +(RPAQQ MAXGRIDHEIGHT 175) + +(RPAQQ BMWINDOWSHADE 33410) + + +(CONSTANTS (GRIDTHICKNESS 2) + (MINGRIDSQUARE 8) + (MAXGRIDWIDTH 199) + (MAXGRIDHEIGHT 175) + (BMWINDOWSHADE 33410)) +) +(DEFINEQ + +(SCALEBM [LAMBDA (SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEWIDTH SRCEHEIGHT XSCALE YSCALE TEMPBM) (* ; "Edited 31-Aug-87 10:40 by FS") (* ;; "Magnify a bitmap as per EDITBM. Use smearing algorithm.") (LET ((DESTWIDTH (BITMAPWIDTH DESTBM)) (DESTHEIGHT (BITMAPHEIGHT DESTBM)) XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") (if (NUMBERP SRCEWIDTH) else (SETQ SRCEWIDTH (BITMAPWIDTH SRCEBM))) (if (NUMBERP SRCEHEIGHT) else (SETQ SRCEHEIGHT (BITMAPHEIGHT SRCEBM))) (* ;; "Save effort by considering min of srce and dest.") (SETQ DESTWIDTH (MIN DESTWIDTH (CL:* SRCEWIDTH XSCALE))) (SETQ DESTHEIGHT (MIN DESTHEIGHT (CL:* SRCEHEIGHT YSCALE))) (SETQ SRCEWIDTH (MIN SRCEWIDTH (IQUOTIENT DESTWIDTH XSCALE))) (SETQ SRCEHEIGHT (MIN SRCEHEIGHT (IQUOTIENT DESTHEIGHT YSCALE))) (if TEMPBM then (BLTSHADE WHITESHADE TEMPBM) else (SETQ TEMPBM (BITMAPCREATE DESTWIDTH SRCEHEIGHT))) (* ;; "CALL EXPANDBM twice, once for each direction, because we have a spare bitmap which makes it run faster than a single call to EXPANDBM would (I think).") (* ;; "") (* ;; "Do X Direction Smearing.") (* ;; "============") (EXPANDBM SRCEBM SRCEX SRCEY SRCEWIDTH SRCEHEIGHT TEMPBM 0 0 DESTWIDTH SRCEHEIGHT XSCALE 1 XSCALE 1) (* ;; "") (* ;; "Do Y Direction Smearing.") (* ;; "============") (EXPANDBM TEMPBM 0 0 DESTWIDTH SRCEHEIGHT DESTBM DESTX DESTY DESTWIDTH DESTHEIGHT 1 YSCALE 1 YSCALE) (* ;; "") (* ;; "Return the temporary bitmap for recycling purposes.") TEMPBM]) + +(BLTPATTERN [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH OPER TEMPBM)(* ; "Edited 8-Dec-88 18:52 by SHIH") (* ;; "Fills region of Destination with tiles of Source region, using operation. If Temporary bitmap is provided, use it for optimal performance (this is because bitmaps are much faster to paint than other destinations, e.g. windows).") (PROG (W H RX RW TW TH) (if (NULL SW) then (SETQ SW (BITMAPWIDTH SRCE))) (if (NULL SH) then (SETQ SH (BITMAPHEIGHT SRCE))) (* ;; "") (if (NULL OPER) then (SETQ OPER 'REPLACE)) (* ;  "IRM says OPER defaults to replace") [if TEMPBM then (* ;; "Temp bitmap is only useful if its larger than pattern.") (SETQ TW (BITMAPWIDTH TEMPBM)) (SETQ TH (BITMAPHEIGHT TEMPBM)) (if [OR (AND (<= SW (BITMAPWIDTH SRCE)) (<= SH (BITMAPHEIGHT SRCE)) (>= TW SW) (>= TH SH)) (AND (NEQ OPER 'REPLACE) (>= TW (BITMAPWIDTH SRCE)) (>= TH (BITMAPHEIGHT SRCE] then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH TEMPBM 0 0 TW TH) (* ;; "Allow code to fall through using TEMPBM as source area.") (SETQ SRCE TEMPBM) (SETQ SX 0) (SETQ SY 0) [SETQ SW (MAX SW (ITIMES SW (IQUOTIENT TW SW] (SETQ SH (MAX SH (ITIMES SH (IQUOTIENT TH SH] (if (AND (EQ OPER 'REPLACE) (<= SW (BITMAPWIDTH SRCE)) (<= SH (BITMAPHEIGHT SRCE)) (OR (BITMAPP DEST) (WINDOWP DEST))) then (BLTPATTERN.REPLACEDISPLAY SRCE SX SY SW SH DEST DX DY DW DH) else (* ;; "Even if operation is REPLACE, don't know if destination is inexpensively readable (e.g. Interpress stream. SO, this is the general case here.") (BLTPATTERN.GENERIC SRCE SX SY SW SH DEST DX DY DW DH OPER]) + +(BLTPATTERN.REPLACEDISPLAY [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH) (* ; "Edited 8-Dec-88 16:28 by SHIH") (* ;; "This routine only replaces the destination with the source, and assumes the destination itself can be easily read from and blt'ed to.") (* ;; "Put initial bitmap into destination. Source should not be within destination area, otherwise it will be overwritten.") (LET (RX RY RW RH W H) (* ; "R's are remaining area.") (SETQ W (MIN SW DW)) (SETQ H (MIN SH DH)) (* ;; "Algorithm below whites out extraneous area. General bltpattern routine leaves overlap areas *alone*, so this routine is not consistent when specified-size > source-size (general routine shouldnt come here if so).") (BLTSHADE WHITESHADE DEST DX DY W H 'REPLACE) (BITBLT SRCE SX SY DEST DX DY W H NIL 'REPLACE) (SETQ RX (+ DX W)) (SETQ RW (- DW W)) (* ;; "Now power up until width is full.") (while (> RW 0) do (SETQ W (MIN SW RW)) (BITBLT DEST DX DY DEST RX DY W H NIL 'REPLACE) (SETQ RW (- RW W)) (* ; "Reduce remaining width") (SETQ RX (+ RX W)) (* ; "Set next starting position") (SETQ SW (+ SW SW)) (* ; "Can now use 2x area.")) (* ;; "") (SETQ RY (+ DY H)) (SETQ RH (- DH H)) (SETQ SH H) (SETQ W DW) (* ;; "Now power up until height is full.") (while (> RH 0) do (SETQ H (MIN SH RH)) (BITBLT DEST DX DY DEST DX RY W H NIL 'REPLACE) (SETQ RH (- RH H)) (* ; "Reduce remaining width") (SETQ RY (+ RY H)) (* ; "Set next starting position") (SETQ SH (+ SH SH)) (* ; "Can now use 2x area.")]) + +(BLTPATTERN.GENERIC [LAMBDA (SRCE SX SY SW SH DEST DX DY DW DH OPER) (* ; "Edited 8-Dec-88 16:51 by SHIH") (* ;; "Generically repeat pattern from srce over dest.") (LET (W H RX RW TW TH) (if (NULL SW) then (SETQ SW (BITMAPWIDTH SRCE))) (if (NULL SH) then (SETQ SH (BITMAPHEIGHT SRCE))) (while (> DH 0) do (SETQ H (MIN SH DH)) (* ;; "") (SETQ RW DW) (SETQ RX DX) (* ;; "") (* ;; "Fill rows") (* ;; "") (while (> RW 0) do (SETQ W (MIN SW RW)) (BITBLT SRCE SX SY DEST RX DY W H NIL OPER) (SETQ RW (- RW W)) (SETQ RX (+ RX W))) (* ;; "") (SETQ DH (- DH H)) (SETQ DY (+ DY H]) +) +(DEFINEQ + +(EXPANDBITMAP [LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR) (* ; "Edited 2-Sep-87 17:49 by FS") (* ;; "Returns a new bitmap which is WidthFactor and HeightFactor bigger.") (* ;;  "FS: This slow piece of code has been replaced with a much faster, general one, EXPAND.l ") (LET (WIDTH HEIGHT BITSPERPIXEL NEWWIDTH NEWHEIGHT NEWX NEWY NEWBITMAP) (OR WIDTHFACTOR (SETQ WIDTHFACTOR 1)) (OR HEIGHTFACTOR (SETQ HEIGHTFACTOR 1)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (SETQ NEWWIDTH (ITIMES WIDTHFACTOR WIDTH)) (SETQ NEWHEIGHT (ITIMES HEIGHTFACTOR HEIGHT)) (SETQ NEWBITMAP (BITMAPCREATE NEWWIDTH NEWHEIGHT BITSPERPIXEL)) (* ;; "OLD code commented out here.") (* LET NIL (* Expand in x-direction.  *) (SETQ NEWX 0) (for X from 0 to  (SUB1 WIDTH) do (for I from 1 to  WIDTHFACTOR do (BITBLT BITMAP X 0  NEWBITMAP NEWX 0 1 HEIGHT  (QUOTE INPUT) (QUOTE REPLACE))  (add NEWX 1))) (* Expand in  y-direction. *) (SETQ NEWY  (SUB1 NEWHEIGHT)) (for Y from  (SUB1 HEIGHT) to 0 by -1 do  (for I from 1 to HEIGHTFACTOR do  (BITBLT NEWBITMAP 0 Y NEWBITMAP 0 NEWY  NEWWIDTH 1 (QUOTE INPUT)  (QUOTE REPLACE)) (add NEWY -1)))) (EXPANDBM BITMAP 0 0 WIDTH HEIGHT NEWBITMAP 0 0 NEWWIDTH NEWHEIGHT WIDTHFACTOR HEIGHTFACTOR WIDTHFACTOR HEIGHTFACTOR) NEWBITMAP]) + +(EXPANDBM [LAMBDA (SRCEBM SRCEX SRCEY SRCEW SRCEH DESTBM DESTX DESTY DESTW DESTH XSCALE YSCALE XSPACE YSPACE) (* ; "Edited 28-Aug-87 19:00 by FS") (* ;; "Expands a region of SrceBM by X&Y scale into a region of DestBM, spaced Xspace by YSpace apart (space must be larger than scale). SrceBM cannot be the same bitmap as DestBM. The entire region inside DestBM is cleared.") (PROG (XSTEPS YSTEPS POWER) (* ;; "Check parameters, apply defaults") (if (NUMBERP SRCEX) else (SETQ SRCEX 0)) (if (NUMBERP SRCEY) else (SETQ SRCEY 0)) (if (NUMBERP SRCEW) else (SETQ SRCEW (BITMAPWIDTH SRCEBM))) (if (NUMBERP SRCEH) else (SETQ SRCEH (BITMAPHEIGHT SRCEBM))) (if (NUMBERP DESTX) else (SETQ SRCEX 0)) (if (NUMBERP DESTY) else (SETQ SRCEY 0)) (* ;; "Save effort by considering min of srce and dest.") [SETQ DESTW (IMIN DESTW (CL:* SRCEW (IMAX XSCALE XSPACE] [SETQ DESTH (IMIN DESTH (CL:* SRCEH (IMAX YSCALE YSPACE] [SETQ SRCEW (IMIN SRCEW (+ 1 (IQUOTIENT DESTW (IMAX XSCALE XSPACE] [SETQ SRCEH (IMIN SRCEH (+ 1 (IQUOTIENT DESTH (IMAX YSCALE YSPACE] (BLTSHADE WHITESHADE DESTBM DESTX DESTY DESTW DESTH) (if (AND (EQL XSPACE 1) (EQL YSPACE 1)) then (BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH) (RETURN DESTBM)) (* ;; "") (* ;; "Do X Direction Smearing.") (* ;; "============") (* ;;  "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") (if (EQL XSPACE 1) then (* ;; "Don't fill destination, instead use srce in YSmear loop.") (* ;; "(BITBLT SRCEBM SRCEX SRCEY DESTBM DESTX DESTY SRCEW SRCEH)") else (* ;;  "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") (for I from (SUB1 SRCEW) to 0 by -1 do (BITBLT SRCEBM (+ SRCEX I) SRCEY DESTBM (+ DESTX (CL:* I XSPACE)) DESTY 1 SRCEH))) (* ;; "Now smear by scalefactor. Each step smears out a power of two. LSH is in ucode.") [if (EQL XSCALE 1) else (SETQ POWER 1) (while (<= POWER (LSH XSCALE -1)) do (* ;;  "In the X direction, only need to blt SRCEH bits high, and must shorten W to remain within DESTW") (BITBLT DESTBM DESTX DESTY DESTBM (+ DESTX POWER) DESTY (- DESTW POWER) SRCEH NIL 'PAINT) (SETQ POWER (+ POWER POWER))) (* ;; "Clean up for non power of two.") (if (ZEROP (- XSCALE POWER)) else (BITBLT DESTBM DESTX DESTY DESTBM (+ DESTX (- XSCALE POWER)) DESTY (- DESTW (- XSCALE POWER)) SRCEH NIL 'PAINT] (* ;; "") (* ;; "Do Y Direction Smearing.") (* ;; "============") (* ;;  "Spread out bitmap by spacefactor. Start from far side to avoid overwrite (if srce = dest)") [if (EQL YSPACE 1) else (if (EQL XSPACE 1) then (* ;; "Didn't need to paint in destination, so can avoid second loop by blting from SRCBM instead of DESTBM.") (for J from (SUB1 SRCEH) to 0 by -1 do (BITBLT SRCEBM SRCEX (+ SRCEY J) DESTBM DESTX (+ DESTY (CL:* J YSPACE)) DESTW 1)) else (for J from (SUB1 SRCEH) to 0 by -1 do (BITBLT DESTBM DESTX (+ DESTY J) DESTBM DESTX (+ DESTY (CL:* J YSPACE)) DESTW 1)) (* ;;  "Since we reused DESTBM, parts of the dest have bits in them but shouldn't. So, clear them.") (for J from 0 to SRCEH by YSPACE do (BLTSHADE WHITESHADE DESTBM DESTX (+ DESTY J 1) DESTW (SUB1 YSPACE] (* ;; "Now smear correctly. Each step smears out a power of two. LSH is in ucode.") [if (EQL YSCALE 1) else (SETQ POWER 1) (while (<= POWER (LSH YSCALE -1)) do (BITBLT DESTBM DESTX DESTY DESTBM DESTX (+ DESTY POWER) DESTW (- DESTH POWER) NIL 'PAINT) (SETQ POWER (+ POWER POWER))) (* ;; "Clean up for non power of two.") (if (ZEROP (- YSCALE POWER)) else (BITBLT DESTBM DESTX DESTY DESTBM DESTX (+ DESTY (- YSCALE POWER)) DESTW DESTH NIL 'PAINT] (* ;; "") (* ;; "Return the temporary bitmap for recycling purposes.") DESTBM]) + +(SHRINKBITMAP [LAMBDA (BITMAP WIDTHFACTOR HEIGHTFACTOR DESTINATIONBITMAP)(* hdj "18-Feb-86 14:23") (LET* [(BITSPP (BITSPERPIXEL BITMAP)) (WFACTOR (OR WIDTHFACTOR 4)) (HFACTOR (OR HEIGHTFACTOR 1)) (HEIGHT (BITMAPHEIGHT BITMAP)) (WIDTH (BITMAPWIDTH BITMAP)) (SCRATCH (BITMAPCREATE WIDTH (IQUOTIENT HEIGHT HFACTOR) BITSPP)) (DESTINATION (OR DESTINATIONBITMAP (BITMAPCREATE (IQUOTIENT WIDTH WFACTOR) (IQUOTIENT HEIGHT HFACTOR) BITSPP] [if (AND (EQP WFACTOR 1) (EQP HFACTOR 1)) then (BITBLT BITMAP NIL NIL DESTINATION) else (BLTSHADE 0 DESTINATION) (for Y from 0 to (SUB1 HEIGHT) do (BITBLT BITMAP 0 Y SCRATCH 0 (IQUOTIENT Y HFACTOR) WIDTH 1 'INPUT 'PAINT)) (for X from 0 to (SUB1 WIDTH) do (BITBLT SCRATCH X 0 DESTINATION (IQUOTIENT X WFACTOR) 0 1 HEIGHT 'INPUT 'PAINT] DESTINATION]) + +(\FAST4BIT [LAMBDA (A B N MAP) (* kbr%: "16-May-85 17:14") (* DECLARATIONS%: (BLOCKRECORD NIBBLE  ((N1 BITS 4) (N2 BITS 4)  (N3 BITS 4) (N4 BITS 4)))) (bind AW (I _ 0) for J from 0 do (SETQ AW (\ADDBASE A J)) (OR (IGREATERP N I) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (NIBBLE N1) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (NIBBLE N2) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (NIBBLE N3) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (NIBBLE N4) of AW))) (add I 1]) +) + +(CL:DEFUN ROTATE-BITMAP (SOURCE) + "rotates the bitmap SOURCE by 90 degrees clockwise, returning a new bitmap" + +(* ;;; "This must be compiled to work") + + (* ;; "Rotate a bitmap by 90 degrees clockwise. Uses pilotbitblt hackery for maximum speed and confusion for the reader.") + + (LET* ((SOURCE-HEIGHT (BITMAPHEIGHT SOURCE)) + (DESTINATION (BITMAPCREATE SOURCE-HEIGHT (BITMAPWIDTH SOURCE))) + + (* ;; "The ROTATE-BBT table maps scanlines of the SOURCE bitmap into columns of the DESTINATION bitmap. The topmost scanline (lowest address) maps into the rightmost column of the destination. We proceed from top to bottom in the source, and from right to left in the destination. Refer to the Mesa PrincOps document for a description of Pilot BitBLT, and see also the declaration for the PILOTBBT datatype.") + + (ROTATE-BBT (create PILOTBBT + PBTDISJOINT _ T (* ; "the bitmaps are separate") + PBTDEST _ (ffetch (BITMAP BITMAPBASE) of DESTINATION) + (* ; + "set the destination (held constant)") + PBTSOURCE _ (ffetch (BITMAP BITMAPBASE) of SOURCE) + (* ; + "set the source (incremented by 1 scanline per iteration)") + PBTDESTBPL _ (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH) of + DESTINATION) + BITSPERWORD)(* ; + "the destination is this many bits between scanlines") + PBTSOURCEBPL _ 1 (* ; + "move 1 bit of each source scanline per 1 scanline of the destination") + PBTSOURCEBIT _ 0 (* ; + "start at the first bit of each source scanline (held constant)") + PBTDESTBIT _ (BITMAPWIDTH DESTINATION) + (* ; + "start putting data into the destination on the right edge (pre-decremented) ") + PBTFLAGS _ 0 (* ; + "replace mode (paint might be faster)") + PBTHEIGHT _ (BITMAPHEIGHT DESTINATION) + (* ; "how high the destination is") + PBTWIDTH _ 1 (* ; + "how wide the destination stripe is") + )) + (SOURCE-WORD-WIDTH (ffetch (BITMAP BITMAPRASTERWIDTH) of SOURCE))) + (for I from 1 to SOURCE-HEIGHT do (add (ffetch (PILOTBBT PBTDESTBIT) + of ROTATE-BBT) + -1) + (\PILOTBITBLT ROTATE-BBT 0) + + (* ;; "the line below is slower than need be, but works when the source crosses a segment. A faster way (which breaks on a segment cross) is to say") + + (* ;; + " (|add| (|ffetch| (PILOTBBT PBTSOURCELO) |of| ROTATE-BBT) SOURCE-WORD-WIDTH)") + + (FREPLACE (PILOTBBT PBTSOURCE) + OF ROTATE-BBT + WITH (\ADDBASE (FFETCH + (PILOTBBT PBTSOURCE) + OF ROTATE-BBT) + SOURCE-WORD-WIDTH))) + DESTINATION)) + +(CL:DEFUN ROTATE-BITMAP-LEFT (SOURCE) + "rotates the bitmap SOURCE by 90 degrees counter-clockwise, returning a new bitmap" + +(* ;;; "This must be compiled to work") + + (* ;; "Rotate a bitmap by 90 degrees counter-clockwise. Uses pilotbitblt hackery for maximum speed and confusion for the reader.") + + (LET* ((SOURCE-WIDTH (BITMAPWIDTH SOURCE)) + (DESTINATION (BITMAPCREATE (BITMAPHEIGHT SOURCE) + SOURCE-WIDTH)) + + (* ;; "The ROTATE-BBT table maps columns of the SOURCE bitmap into rows of the DESTINATION bitmap. The rightmost column maps into the topmost row(lowest address) of the destination. We proceed from right to left in the source, and from top to bottom in the destination. Refer to the Mesa PrincOps document for a description of Pilot BitBLT, and see also the declaration for the PILOTBBT datatype. ") + + (ROTATE-BBT (CREATE PILOTBBT + PBTDISJOINT _ T (* ; "the bitmaps are separate") + PBTDEST _ (FFETCH (BITMAP BITMAPBASE) OF DESTINATION) + (* ; + "set the destination (held constant)") + PBTSOURCE _ (FFETCH (BITMAP BITMAPBASE) OF SOURCE) + (* ; "set the source") + PBTDESTBPL _ 1 (* ; + "the destination is this many bits between scanlines") + PBTSOURCEBPL _ (UNFOLD (FFETCH (BITMAP BITMAPRASTERWIDTH) + OF SOURCE) + BITSPERWORD) + (* ; "move a scanline at a time.") + PBTSOURCEBIT _ (BITMAPWIDTH SOURCE) + (* ; + "start getting data at the right edge of the source") + PBTDESTBIT _ 0 (* ; + "start putting data into the destination on the left edge ") + PBTFLAGS _ 0 (* ; + "replace mode (paint might be faster)") + PBTHEIGHT _ (BITMAPHEIGHT SOURCE) + (* ; "how high the stripe is") + PBTWIDTH _ 1 (* ; + "how wide the destination stripe is") + )) + (DEST-WORD-WIDTH (FFETCH (BITMAP BITMAPRASTERWIDTH) OF DESTINATION))) + (FOR I FROM 1 TO SOURCE-WIDTH DO (add (FFETCH (PILOTBBT PBTSOURCEBIT + ) OF + ROTATE-BBT + ) + -1) + (\PILOTBITBLT ROTATE-BBT 0) + + (* ;; "the line below is slower than need be, but works when the source crosses a segment. A faster way (which breaks on a segment cross) is to say") + + (* ;; + " (|add| (|ffetch| (PILOTBBT PBTSOURCELO) |of| ROTATE-BBT) SOURCE-WORD-WIDTH)") + + (FREPLACE (PILOTBBT PBTDEST) + OF ROTATE-BBT + WITH (\ADDBASE (FFETCH + (PILOTBBT PBTDEST) + OF ROTATE-BBT) + DEST-WORD-WIDTH))) + DESTINATION)) + +(PUTPROPS HLDISPLAY FILETYPE CL:COMPILE-FILE) + +(READVARS-FROM-STRINGS '(\4BITEXPANSIONTABLE) + "({Y16 SMALLPOSP 0 0 15 240 255 3840 3855 4080 4095 61440 61455 61680 61695 65280 65295 65520 65535 }) +") +(PUTPROPS HLDISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1900 1988 +1989 1990 1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (5008 12171 (GRID 5018 . 9289) (GRIDXCOORD 9291 . 9796) (GRIDYCOORD 9798 . 10307) ( +LEFTOFGRIDCOORD 10309 . 10746) (BOTTOMOFGRIDCOORD 10748 . 11009) (SHADEGRIDBOX 11011 . 12169)) (12227 +12635 (INSIDE? 12237 . 12633)) (12673 17069 (MOUSESTATE-EXPR 12683 . 16338) (MOUSESTATE-NAME 16340 . +17067)) (20480 21465 (DECODEBUTTONS 20490 . 21463)) (21466 22478 (PTDIFFERENCE 21476 . 21985) (PTPLUS +21987 . 22476)) (22529 50432 (GETPOSITION 22539 . 22847) (GETBOXPOSITION 22849 . 23532) ( +DSPYSCREENTOWINDOW 23534 . 24018) (DSPXSCREENTOWINDOW 24020 . 24504) (GETREGION 24506 . 25055) ( +\GETREGION.PACKPTS 25057 . 25625) (\GETREGION.CHECKBASEPT 25627 . 27570) (\GETREGION.CHECKOPPT 27572 + . 30382) (\GETREGIONTRACKWITHBOX 30384 . 36915) (\UPDATEXYANDBOX 36917 . 39296) (GETBOXREGION 39298 + . 39772) (\TRACKWITHBOX 39774 . 44912) (MOVEBOX 44914 . 45544) (DRAWGRAYBOX 45546 . 46068) (BLTHLINE +46070 . 46320) (BLTVLINE 46322 . 46561) (SETCORNER 46563 . 47829) (GETSCREENPOSITION 47831 . 48444) ( +GETBOXSCREENPOSITION 48446 . 49057) (GETSCREENREGION 49059 . 49715) (GETBOXSCREENREGION 49717 . 50430) +) (50518 67334 (\MEDW.GETSCREENPOSITION 50528 . 52321) (\MEDW.GETBOXSCREENPOSITION 52323 . 55877) ( +\MEDW.GETSCREENREGION 55879 . 67332)) (67335 75073 (GETGRIDBOXREGION 67345 . 74999) (\RANGELIMIT 75001 + . 75071)) (75074 78124 (MOUSECONFIRM 75084 . 78122)) (78265 79634 (NEAREST/PT/ON/GRID 78275 . 78870) +(PTON10GRID 78872 . 79197) (NEAREST/MULTIPLE 79199 . 79632)) (81689 85591 (\SW2BM 81699 . 84397) ( +COMPOSEREGS 84399 . 84953) (TRANSLATEREG 84955 . 85589)) (85633 176284 (EDITBM 85643 . 95768) ( +EDITBMSCROLLFN 95770 . 110923) (EDITBMCLOSEFN 110925 . 111542) (TILEAREA 111544 . 111935) ( +EDITBMBUTTONFN 111937 . 136764) (\EDITBM/PUTUP/DISPLAY 136766 . 137668) (\EDITBMHOWMUCH 137670 . +138656) (EDITBMRESHAPEFN 138658 . 147344) (EDITBMREPAINTFN 147346 . 148665) (UPDATE/SHADE/DISPLAY +148667 . 149114) (UPDATE/BM/DISPLAY/SELECTED/REGION 149116 . 150230) (SHOWBUTTON 150232 . 150790) ( +RESETGRID.NEW 150792 . 154141) (RESETGRID 154143 . 154967) (\READBMDIMENSIONS 154969 . 156006) ( +EDITSHADE 156008 . 164734) (\BITMAPFROMTEXTURE 164736 . 165434) (EDITSHADEREPAINTFN 165436 . 167210) ( +GRAYBOXAREA 167212 . 167895) (\SHADEBITS 167897 . 170862) (READHOTSPOT 170864 . 174729) (WBOX 174731 + . 175455) (\CLEARBM 175457 . 175656) (EDITBMTEXTURE 175658 . 176282)) (177608 185315 (SCALEBM 177618 + . 179684) (BLTPATTERN 179686 . 182204) (BLTPATTERN.REPLACEDISPLAY 182206 . 184295) ( +BLTPATTERN.GENERIC 184297 . 185313)) (185316 197135 (EXPANDBITMAP 185326 . 187850) (EXPANDBM 187852 . +194407) (SHRINKBITMAP 194409 . 195753) (\FAST4BIT 195755 . 197133))))) +STOP diff --git a/sources/HPRINT b/sources/HPRINT new file mode 100644 index 00000000..8c8779ff --- /dev/null +++ b/sources/HPRINT @@ -0,0 +1,352 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 9-Oct-94 13:07:03" {DSK}sources>HPRINT.;2 56339 + + changes to%: (FNS COPYALL) + + previous date%: "28-Jan-93 17:30:35" {DSK}sources>HPRINT.;1) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT HPRINTCOMS) + +(RPAQQ HPRINTCOMS + [(FNS MAKEHVPRETTYCOMS READVARS HPRINT0) + (FUNCTIONS READVARS-FROM-STRINGS READVARS-FROM-STREAM) + (FNS READVAR-FROM-STRING READVARS-FROM-STRING HPRINT-TO-STRING HPRINT-TO-STRINGS) + (FILEPKGCOMS HORRIBLEVARS UGLYVARS) + (FNS HPRINT HPRINT1 HPRINTEND RPTPRINT RPTEND RPTPUT HPRINTSP HPERR HVFWDCDREAD HVBAKREAD + HVREADCHECKGETFN HVREADEND HVRPTREAD HVFWDREAD HREAD HPINITRDTBL HVREADERR HPRINSP) + (FNS COPYALL \COPYDATATYPE HCOPYALL HCOPYALL1) + (FNS EQUALALL EQUALHASH) + (BLOCKS (COPYALL COPYALL (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + (EQUALALL EQUALALL EQUALHASH (RETFNS EQUALHASH) + (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + (NIL HCOPYALL (LOCALVARS . T)) + (HCOPYALL1 HCOPYALL1 (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + (HPRINTBLOCK HPRINT RPTPRINT RPTPUT RPTEND HPRINTEND HPRINT1 HPRINSP HPRINTSP HPERR + (LOCALFREEVARS DATATYPESEEN BACKREFS CELLCOUNT RPTLAST RPTCNT U) + (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY FCHARAR) + (ENTRIES HPRINT HPRINT1)) + (NIL MAKEHVPRETTYCOMS READVAR-FROM-STRING READVARS-FROM-STREAM HPRINT-TO-STRING + READVARS HPINITRDTBL HVFWDCDREAD HVBAKREAD HVRPTREAD HVFWDREAD HREAD HPRINT0 + HVREADERR (NOLINKFNS . T) + (LOCALVARS . T) + (SPECVARS BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL) + (GLOBALVARS FILERDTBL))) + (GLOBALVARS HPRINTHASHARRAY HPRINTRDTBL HPBAKCHAR HPFORWRDCDRCHR HPFORWRDCHR HPFILLCHAR + HPFINALCHAR HPFILLSTRING HPRPTSTRING CIRCLMARKER DONTCOPYDATATYPES ORIGTERMSYNTAX + ORIGECHOCONTROL ORIGDELETECONTROL HPRINTMACROS) + (DECLARE%: EVAL@COMPILE DONTCOPY [VARS HPFORWRDCHR HPFORWRDCDRCHR HPBAKCHAR HPFILLCHAR + HPFINALCHAR (HPFILLSTRING (PACKC (LIST HPBAKCHAR + HPFILLCHAR] + (PROP MACRO HPRINTSTRING HPRINTENDSTR)) + (VARS (HPRINTMACROS) + (HPRINTHASHARRAY) + (HPRINTRDTBL) + (HPRPTSTRING "") + (DONTCOPYDATATYPES) + ORIGDELETECONTROL ORIGTERMSYNTAX ORIGECHOCONTROL) + (ADDVARS (HPRINTREADFNS READBITMAP)) + [ADDVARS (GAINSPACEFORMS ((OR HPRINTHASHARRAY HPRINTRDTBL) + "discard HPRINT initialization" + (PROGN (CLRHASH HPRINTHASHARRAY) + (SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL] + (PROP FILETYPE HPRINT) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA HPRINT0 + READVARS) + (NLAML MAKEHVPRETTYCOMS) + (LAMA]) +(DEFINEQ + +(MAKEHVPRETTYCOMS [NLAMBDA (VARS NO-CIRCLE-FLAG) (* ; "Edited 9-Sep-87 16:52 by amd") (* "The old code" (HPINITRDTBL)  (for X in VARS do (OR  (LITATOM X) (ERROR X  "invalid in HORRIBLEVARS" T)))  (LIST (LIST (QUOTE P)  (CONS (FUNCTION READVARS) VARS))  (LIST (QUOTE E) (CONS  (QUOTE HPRINT0) (if NO-CIRCLE-FLAG  then (CONS 0 VARS) else VARS))))) (HPINITRDTBL) (for X in VARS do (if (NOT (LITATOM X)) then (ERROR X "not a symbol in HORRIBLEVARS" T))) `((P (READVARS-FROM-STRINGS ',VARS ,@(HPRINT-TO-STRINGS (CL:MAPCAR 'GETATOMVAL VARS) NO-CIRCLE-FLAG]) + +(READVARS [NLAMBDA VARS (* lmm%: " 4-JAN-77 23:32:43") (HPINITRDTBL) (PROG (BACKREFS (BACKREFCNT 0) DATATYPESEEN) (OR (EQ (RATOM NIL HPRINTRDTBL) '%() (HVREADERR)) (for VAR in VARS when (LITATOM VAR) do (SAVESET VAR (READ NIL HPRINTRDTBL) T)) (OR (EQ (RATOM NIL HPRINTRDTBL) '%)) (HVREADERR]) + +(HPRINT0 [NLAMBDA VARS (* lmm%: 30-JAN-76 7 36) (HPRINT (for X in (COND ((EQ (CAR VARS) 0) (CDR VARS)) (T VARS)) collect (OR (LITATOM X) (ERROR X "not a var, in HORRIBLEVARS" T)) (GETATOMVAL X)) NIL (EQ (CAR VARS) 0]) +) + +(CL:DEFUN READVARS-FROM-STRINGS (SYMBOLS &REST STRINGS) + (CL:ASSERT (NOT (NULL STRINGS)) + (STRINGS) + "~S must be given at least one string." + 'READVARS-FROM-STRINGS) + (CL:WITH-OPEN-STREAM (STREAM (MAKE-CONCATENATED-STRING-INPUT-STREAM STRINGS)) + (READVARS-FROM-STREAM SYMBOLS STREAM))) + +(CL:DEFUN READVARS-FROM-STREAM (SYMBOLS STREAM) + (HPINITRDTBL) + (PROG (BACKREFS (BACKREFCNT 0) + DATATYPESEEN) + (DECLARE (CL:SPECIAL BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL)) + (CL:MAPC #'(CL:LAMBDA (SYMBOL VALUE) + (SAVESET SYMBOL VALUE T)) + SYMBOLS + (READ STREAM HPRINTRDTBL)))) +(DEFINEQ + +(READVAR-FROM-STRING [LAMBDA (SYMBOL HPRINT-STRING) (* ; "Edited 10-Feb-87 16:39 by Pavel") (CL:WITH-INPUT-FROM-STRING (STREAM HPRINT-STRING) (* ;; "") (HPINITRDTBL) (PROG (BACKREFS (BACKREFCNT 0) DATATYPESEEN) (SAVESET SYMBOL (READ STREAM HPRINTRDTBL) T]) + +(READVARS-FROM-STRING [LAMBDA (SYMBOLS HPRINT-STRING) (* ; "Edited 9-Sep-87 18:22 by amd") (CL:WITH-INPUT-FROM-STRING (STREAM HPRINT-STRING) (READVARS-FROM-STREAM SYMBOLS STREAM]) + +(HPRINT-TO-STRING [LAMBDA (VALUE NO-CIRCLE-FLAG) (* ; "Edited 9-Sep-87 16:21 by amd") (CL:WITH-OUTPUT-TO-STRING (S) (HPRINT VALUE S NO-CIRCLE-FLAG]) + +(HPRINT-TO-STRINGS [LAMBDA (VALUE NO-CIRCLE-FLAG) (* ; "Edited 5-Feb-88 14:42 by amd") (XCL:WITH-COLLECTION (XCL:COLLECT (CL:WITH-OUTPUT-TO-STRING (S) (HANDLER-BIND [(END-OF-FILE #'(CL:LAMBDA (C) (CL:WHEN (AND (EQ (END-OF-FILE-STREAM C) S) (CONDITIONS:FIND-RESTART 'SI::RETRY-OUTCHAR)) (XCL:COLLECT (CL:GET-OUTPUT-STREAM-STRING S)) (CONDITIONS:INVOKE-RESTART 'SI::RETRY-OUTCHAR))] (HPRINT VALUE S NO-CIRCLE-FLAG]) +) +(PUTDEF (QUOTE HORRIBLEVARS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS * (MAKEHVPRETTYCOMS X))) + CONTENTS + (LAMBDA (COM NAME TYPE) + (AND (EQ TYPE 'VARS) + (INFILECOMTAIL COM]) +(PUTDEF (QUOTE UGLYVARS) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (COMS * (MAKEHVPRETTYCOMS X T))) + CONTENTS + (LAMBDA (COM NAME TYPE) + (AND (EQ TYPE 'VARS) + (INFILECOMTAIL COM]) +(DEFINEQ + +(HPRINT [LAMBDA (EXPR FILE UNCIRCULAR DATATYPESEEN) (* ; "Edited 10-Feb-87 15:52 by Pavel") (RESETLST (PROG (BACKREFS (CELLCOUNT 0) SIZE (U UNCIRCULAR)) (RESETSAVE (RADIX 10)) [COND (UNCIRCULAR (* ; "Won't need the hash array")) ([OR (HARRAYP HPRINTHASHARRAY) (HARRAYP (CAR (LISTP HPRINTHASHARRAY] (CLRHASH HPRINTHASHARRAY)) (T (SETQ HPRINTHASHARRAY (HASHARRAY 100] (HPINITRDTBL) (RESETSAVE (OUTPUT FILE)) (RESETSAVE (SETREADTABLE HPRINTRDTBL)) [COND (UNCIRCULAR (HPRINT1 EXPR NIL NIL T)) ((RANDACCESSP (OUTPUT)) (HPRINT1 EXPR) (HPRINTEND)) (T (* ;  "If the byte pointer cannot be reset, want to output to temp file and copy it back") (LET* ((STREAM (OPENSTREAM "{NoDirCore}" 'OUTPUT)) (*STANDARD-OUTPUT* STREAM)) (CL:UNWIND-PROTECT (PROGN (HPRINT1 EXPR) (HPRINTEND) (CL:CLOSE STREAM) (OPENSTREAM STREAM 'INPUT) (COPYBYTES STREAM FILE)) (CL:CLOSE STREAM))] (TERPRI)))]) + +(HPRINT1 [LAMBDA (X CDRFLG NOMACROSFLG NOSPFLG) (* ; "Edited 26-Apr-91 13:39 by jds") (* ;; "Print the potentially self-referential structure EXPR; if CDRFLG then this is the CDR part of a list") (PROG (LASTSEEN HERE TYPE SIZE) (SELECTQ (SETQ TYPE (TYPENAME X)) ((SMALLP LITATOM NEW-ATOM) (* ;  "Atom, small number, are just directly printed") [RETURN (COND [CDRFLG (COND (X (PRIN1 " . ") (PRIN2 X] (T (PRIN2 X]) NIL) (RETURN (COND [(SETQ LASTSEEN (AND (NOT U) (GETHASH X HPRINTHASHARRAY))) (* ;; "Seen before --- Hash value is either byte position of first place seen (negative if CDR pointer) or (bytepos-of-expression . byte-positions-of-backrefs)") (AND CDRFLG (PRIN1 " . ")) (PRIN1 (CONSTANT HPFILLSTRING)) [SETQ HERE (SUB1 (GETFILEPTR (OUTPUT] [PROG ((CN CELLCOUNT)) (while (IGREATERP CN 0) do (PRIN3 (FCHARACTER (CONSTANT HPFILLCHAR))) (* ;; "HPFILLCHAR is 0; there is still a problem in the system of dumping and reading back in (CHARACTER 0)") (SETQ CN (IQUOTIENT CN 10] (COND ((NLISTP LASTSEEN) (* ; "Seen only once before") (PUTHASH X (CAR (SETQ BACKREFS (CONS (LIST LASTSEEN HERE) BACKREFS))) HPRINTHASHARRAY) NIL) (T (* ;  "Seen at least once before --- Add this place to the list") (FRPLACD LASTSEEN (CONS HERE (CDR LASTSEEN] (T (AND CDRFLG (NLISTP X) (PRIN1 " . ")) (COND ((NOT U) (SPACES 1) (PUTHASH X [COND [(AND CDRFLG (LISTP X)) (IMINUS (GETFILEPTR (OUTPUT] (T (GETFILEPTR (OUTPUT] HPRINTHASHARRAY) (SETN CELLCOUNT (ADD1 CELLCOUNT))) ((NOT NOSPFLG) (SPACES 1))) (* ;  "Now, finally get around to printing the thing --- leave space for macro char") (COND [(LISTP X) (COND (CDRFLG (HPRINT1 (CAR X)) (HPRINT1 (CDR X) T)) (T (PRIN1 '"(") (HPRINT1 (CAR X) NIL NIL T) (HPRINT1 (CDR X) T) (PRIN1 '")"] [(AND (NOT NOMACROSFLG) (SETQ HERE (FASSOC TYPE HPRINTMACROS)) (PROG2 (PRIN1 (CONSTANT (CHARACTER HPBAKCHAR)) (OUTPUT)) (APPLY* (CDR HERE) X (OUTPUT)) (HPRINTENDSTR] (T (SELECTQ TYPE ((STRINGP FLOATP FIXP) (* ;  "string, floating point or number") (PRIN2 X)) (ARRAYP (PROG ((SIZE (ARRAYSIZE X)) (RPTCNT 0) (RPTLAST (CONS)) TYP (INDEX (ARRAYORIG X))) (HPRINTSTRING Y) (PRIN2 SIZE) (SPACES 1) (PRIN2 (SETQ TYP (ARRAYTYP X))) (SPACES 1) (PRIN2 INDEX) (SPACES 1) (FRPTQ SIZE (RPTPRINT (ELT X INDEX)) (add INDEX 1)) [AND (FIXP TYP) (NOT (EQP TYP SIZE)) (for I from (ADD1 TYP) to SIZE do (RPTPRINT (ELTD X I] (RPTEND))) (HARRAYP (PROG ((RPTCNT 0) (RPTLAST (CONS)) VALS SIZ) (DECLARE (SPECVARS VALS)) (HPRINTSTRING H) (SETQ SIZ (HARRAYSIZE X)) [PRIN2 (LIST SIZ (HARRAYPROP X 'OVERFLOW] (SPACES 1) (SELECTQ (SYSTEMTYPE) ((TENEX TOPS20) (* ; "bug in Interlisp-10 MAPHASH") [COND ((ILESSP (GCTRP) SIZ) (RESETFORM (MINFS (IMAX (MINFS) SIZ)) (RECLAIM]) NIL) [MAPHASH X (FUNCTION (LAMBDA (V K) (push VALS K] (PRIN2 (FLENGTH VALS)) (SPACES 1) (while VALS do (HPRINTSP (GETHASH (CAR VALS) X)) (HPRINTSP (CAR VALS)) (SETQ VALS (CDR VALS))) (HPRINTENDSTR))) (READTABLEP (* ;  "should dump the READMACROS flag too --- doesn't now and won't until READMACROS takes a RDTBL arg") (PROG ((RPTCNT 0) (RPTLAST (CONS))) (HPRINTSTRING D) (for I in (PRIN2 (for I from 0 to 127 when [NOT (EQUAL (GETSYNTAX I X) (GETSYNTAX I 'ORIG] collect I)) do (RPTPRINT (GETSYNTAX I X))) (RETURN (RPTEND)))) (TERMTABLEP (HPRINTSTRING T) [COND ((GETCONTROL X) (HPRINSP 'CONTROL] [COND ((NOT (GETECHOMODE X)) (HPRINSP 'ECHOMODE] (SELECTQ (GETRAISE X) (T (HPRINSP T)) (0 (HPRINSP 0)) NIL) [COND ((EQ 'NOECHO (GETDELETECONTROL 'ECHO X)) (HPRINSP 'NOECHO] (for PROP in '(CTRLV RETYPE LINEDELETE CHARDELETE EOL) unless (EQUAL (GETSYNTAX PROP X) (GETSYNTAX PROP 'ORIG)) do (HPRINSP PROP) (HPRINSP (GETSYNTAX PROP X))) [for I from 0 to \MAXTHINCHAR do (COND ([NOT (EQUAL (ECHOCHAR I NIL X) (ECHOCHAR I NIL 'ORIG] (HPRINSP (ECHOCHAR I NIL X)) (HPRINSP I] [for PR in '(DELETELINE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL) do (COND ([NOT (EQUAL (DELETECONTROL PR NIL 'ORIG) (SETQ TYPE (DELETECONTROL PR NIL X] (HPRINSP PR) (HPRINSP TYPE] (PRIN2) (* ; "end with a NIL") (HPRINTENDSTR)) (VAG (HPRINTSTRING %#) (PRIN2 (LOC X)) (HPRINTENDSTR)) (BITMAP (HPRINTSTRING %() (PRIN1 "READBITMAP)") (PRINTBITMAP X) (HPRINTENDSTR)) (COND [(SETQ HERE (GETFIELDSPECS TYPE)) [COND ((EQ DATATYPESEEN T) (HPRINTSTRING ~) (PRIN2 TYPE) (SPACES 1)) (T (HPRINTSTRING $) (PRIN2 TYPE) (SPACES 1) (COND ((NOT (FASSOC TYPE DATATYPESEEN)) (SETQ DATATYPESEEN (CONS (CONS TYPE (PRIN2 HERE)) DATATYPESEEN] (PROG ((RPTCNT 0) (RPTLAST (CONS))) (for Y in (GETDESCRIPTORS TYPE) do (RPTPRINT (FETCHFIELD Y X))) (RETURN (RPTEND] (T (HPERR "cannot print this item" X]) + +(HPRINTEND [LAMBDA NIL (* lmm%: "29-NOV-76 16:11:02") (PROG [(HERE (GETFILEPTR (OUTPUT] [SORT BACKREFS (FUNCTION (LAMBDA (X Y) (ILESSP (ABS (CAR X)) (ABS (CAR Y] (for X in BACKREFS as I from 1 do [SETFILEPTR (OUTPUT) (SUB1 (ABS (CAR X] [PRIN3 (COND ((MINUSP (CAR X)) (CONSTANT (CHARACTER HPFORWRDCDRCHR))) (T (CONSTANT (CHARACTER HPFORWRDCHR] (for Z in (DREVERSE (CDR X)) do (SETFILEPTR (OUTPUT) Z) (PRIN3 I) (HPRINTENDSTR T))) (SETFILEPTR (OUTPUT) HERE]) + +(RPTPRINT [LAMBDA (X FLAG) (COND ((OR (EQ X RPTLAST) (AND FLAG (EQP X RPTLAST))) (SETQ RPTCNT (ADD1 RPTCNT))) (T (RPTPUT RPTCNT RPTLAST) (SETQ RPTLAST X) (SETQ RPTCNT 1]) + +(RPTEND [LAMBDA NIL (* lmm%: "29-NOV-76 16:11:40") (RPTPUT RPTCNT RPTLAST) (HPRINTENDSTR]) + +(RPTPUT [LAMBDA (CNT ITEM FLAG) (* lmm "11-SEP-78 03:22") (COND [(AND (ILESSP CNT 4) (OR FLAG (LITATOM ITEM) (SMALLP ITEM))) (FRPTQ CNT (PROGN (PRIN2 ITEM) (PRIN1 '% ] ((ILESSP CNT 2) (FRPTQ CNT (HPRINTSP ITEM))) (T (HPRINTSTRING R) (PRIN2 CNT) (PRIN1 " ") (HPRINT1 ITEM) (HPRINTENDSTR) (SPACES 1]) + +(HPRINTSP [LAMBDA (X) (HPRINT1 X) (PRIN1 " "]) + +(HPERR [LAMBDA (A1 A2) (PRIN1 A1 T) (SPACES 2 T) (PRINT A2 T T) (PRIN2 A2]) + +(HVFWDCDREAD [LAMBDA (FILE RDTBL TCONCPTR) (* Do setq so that if the READ adds things to the BACKREF list, it will still  be correct) (TCONC TCONCPTR NIL) (SETQ BACKREFCNT (ADD1 BACKREFCNT)) (SETQ BACKREFS (CONS (CDR TCONCPTR) BACKREFS)) (FRPLACA (CAR BACKREFS) (READ FILE RDTBL)) TCONCPTR]) + +(HVBAKREAD [LAMBDA (FILE RDTBL BKRF) (* rrb "18-Mar-86 15:40") (PROG (HV HV1 HV2 HV3 (RPTCNT 0) RPTVAL READVAL) READLP (SKIPSEPRS FILE RDTBL) (SELECTQ (SETQ HV (READC FILE)) (} (* ;  "Empty printout from false start for HPRINTMACRO. Next char should be { and be default") (SKIPSEPRS FILE RDTBL) (COND ((EQ '{ (READC FILE)) (GO READLP)) (T (HVREADERR)))) (H (* ; "Hash array") [SETQ READVAL (COND ((EQ (SKIPSEPRS FILE RDTBL) '%() (APPLY (FUNCTION HASHARRAY) (READ FILE RDTBL))) (T (HARRAY (RATOM FILE RDTBL] (AND BKRF (FRPLACA BKRF READVAL)) (FRPTQ (RATOM FILE RDTBL) (PROGN (SETQ HV (READ FILE RDTBL)) (PUTHASH (READ FILE RDTBL) HV READVAL))) (HVREADEND FILE RDTBL)) ((A Y) (* ; "array") [SETQ READVAL (ARRAY (SETQ HV1 (READ FILE RDTBL)) (SETQ HV2 (READ FILE RDTBL)) NIL (SETQ HV3 (SELECTQ HV (Y (READ FILE RDTBL)) 1] (AND BKRF (FRPLACA BKRF READVAL)) (FRPTQ (ARRAYSIZE READVAL) (PROGN (SETA READVAL HV3 (HVRPTREAD FILE RDTBL)) (add HV3 1))) [AND (FIXP HV2) (NOT (IEQP HV1 HV2)) (OR (EQ HV 'Y) (NOT (ZEROP HV2))) (for I from (ADD1 HV2) to HV1 do (SETD READVAL I (HVRPTREAD FILE RDTBL] (HVREADEND FILE RDTBL)) (($ ~) (* ; "DATATYPE") (SETQ HV1 (RATOM FILE RDTBL)) [COND ((EQ HV '~) (* ;  "This should be a previously known datatype not specified in file") (SETQ HV2 (GETDESCRIPTORS HV1))) ([NOT (SETQ HV2 (CDR (FASSOC HV1 DATATYPESEEN] (SETQ HV2 (READ FILE RDTBL)) (OR (NULL (GETFIELDSPECS HV1)) (EQUAL HV2 (GETFIELDSPECS HV1)) (ERROR "attempt to read DATATYPE with different field specification than currently defined" HV1)) (SETQ DATATYPESEEN (CONS (CONS HV1 (SETQ HV2 (/DECLAREDATATYPE HV1 HV2))) DATATYPESEEN] (SETQ READVAL (NCREATE HV1)) (AND BKRF (FRPLACA BKRF READVAL)) (for X in HV2 do (REPLACEFIELD X READVAL (HVRPTREAD FILE RDTBL))) (HVREADEND FILE RDTBL)) (R (* ; "repeat") (AND BKRF (HVREADERR)) (RETURN HPRPTSTRING)) (%# (* ; "Kludge for (VAG smallnumber)") (RETURN (PROG1 (VAG (RATOM FILE RDTBL)) (HVREADEND FILE RDTBL)))) (! (* ; "! --- value cell") (RETURN (AT2VC (RATOM FILE RDTBL)))) (D (* ; "READTABLEP") (SETQ READVAL (COPYREADTABLE 'ORIG)) (AND BKRF (FRPLACA BKRF READVAL)) (for I in (READ FILE RDTBL) do (SETSYNTAX I (HVRPTREAD FILE RDTBL) READVAL)) (HVREADEND FILE RDTBL)) (T (* ; "TERMTABLEP") (SETQ READVAL (COPYTERMTABLE 'ORIG)) (AND BKRF (FRPLACA BKRF READVAL)) (while (SETQ HV (RATOM FILE RDTBL)) do (SELECTQ HV (CONTROL (CONTROL T READVAL)) (ECHOMODE (ECHOMODE NIL READVAL)) ((UPARROW IGNORE REAL SIMULATE) (ECHOCHAR (READ FILE RDTBL) HV READVAL)) ((CTRLV RETYPE LINEDELETE CHARDELETE EOL) [MAPC (READ FILE FILERDTBL) (FUNCTION (LAMBDA (CH) (SETSYNTAX CH HV READVAL]) ((DELETELINE 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL) (DELETECONTROL HV (READ FILE RDTBL) READVAL)) ((T 0) (RAISE HV READVAL)) (NOECHO (DELETECONTROL 'NOECHO NIL READVAL)) (HVREADERR))) (HVREADEND FILE RDTBL)) ((0 1 2 3 4 5 6 7 8 9) (* ;  "immediately followed by a number") (AND BKRF (HVREADERR)) (* ;  "BACK REFERENCE --- shouldn't be forward reference as well") (SETQ HV2 HV) (while (SMALLP (SETQ HV (READC FILE))) do (SETQ HV2 (IPLUS (ITIMES HV2 10) HV))) (RETURN (OR [CAR (FNTH BACKREFS (ADD1 (IDIFFERENCE BACKREFCNT HV2] (HVREADERR)))) (%( (* ;; "form that should be evaluated with its first argument replaced with the file being read. This is the case that handle IMAGEOBJs.") (SETQ READVAL (PROG1 [APPLY (HVREADCHECKGETFN (READ FILE RDTBL)) (CONS FILE (PROGN (* ;; "dump the first argument which is a dummy so that the call that is on the file looks like a realy call.") (CDR (until (PROGN (SKIPSEPRS FILE RDTBL) (EQ (PEEKC FILE) '%))) collect (EVAL (READ FILE RDTBL)) finally (* ; "read the closing (QUOTE ))") (RATOM FILE RDTBL] (HVREADEND FILE RDTBL))) (AND BKRF (FRPLACA BKRF READVAL)) (RETURN READVAL)) (HVREADERR)) (OR (ZEROP RPTCNT) (HVREADERR)) (RETURN READVAL]) + +(HVREADCHECKGETFN [LAMBDA (FN) (* ; "Edited 27-Jan-87 19:41 by rrb") (* ;;  "if in the context of reading an image object, make sure the get function is a known one.") (COND ((EQ FN 'READIMAGEOBJ) (* ; "common case") FN) [(AND (BOUNDP UNDERREADIMAGEOBJ) (EQ UNDERREADIMAGEOBJ T)) (* ;  "This is an HREAD that came from an Image object and hence needs to be safe.") (PROG NIL LP (COND ((OR (MEMB FN HPRINTREADFNS) (ASSOC FN IMAGEOBJGETFNS)) (RETURN FN)) ((NOT (GETD FN)) (* ;  "headed for an undefined function error anyway") (\LISPERROR FN 46 T) (* ;  "user may have loaded a package during the break.") (GO LP)) ((MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " FN ". " FN " is NOT registered. Should I use it anyway?") NIL NIL NIL) (RETURN FN)) (T (ERROR!] (T FN]) + +(HVREADEND [LAMBDA (FILE RDTBL) (* lmm "21-APR-82 11:25") (bind CHAR until (EQ (SETQ CHAR (CHCON1 (READC FILE))) (CONSTANT HPFINALCHAR)) do (OR (SYNTAXP CHAR 'SEPR RDTBL) (HVREADERR]) + +(HVRPTREAD [LAMBDA (FILE RDTBL) (* lmm " 2-APR-82 23:26") (PROG NIL LOOP (COND ((IGREATERP RPTCNT 0) (SETQ RPTCNT (SUB1 RPTCNT)) (RETURN RPTVAL)) ((EQ (SETQ RPTVAL (READ FILE RDTBL)) HPRPTSTRING) (SETQ RPTCNT (READ FILE RDTBL)) (SETQ RPTVAL (READ FILE RDTBL)) (HVREADEND FILE RDTBL) (GO LOOP)) (T (RETURN RPTVAL]) + +(HVFWDREAD [LAMBDA (FILE RDTBL) (* lmm%: "29-NOV-76 15:56:19") (PROG (CH VAL) (SETQ BACKREFCNT (ADD1 BACKREFCNT)) (SETQ BACKREFS (CONS NIL BACKREFS)) LP (SELECTQ (SETQ CH (PEEKC FILE)) (%( (FRPLACA BACKREFS (CONS)) (RETURN (FRPLNODE2 (CAR BACKREFS) (READ FILE RDTBL)))) ((% % ) (READC FILE) (GO LP)) (COND ((EQ CH (CONSTANT (CHARACTER HPBAKCHAR))) (READC FILE) (SETQ VAL (HVBAKREAD FILE RDTBL (SETQ CH BACKREFS))) (OR (CAR CH) (HVREADERR)) (RETURN VAL)) (T (RETURN (CAR (FRPLACA BACKREFS (READ FILE RDTBL]) + +(HREAD [LAMBDA (FILE) (* lmm%: 19 MAY 75 315) (PROG [BACKREFS (BACKREFCNT 0) DATATYPESEEN (FILE (INPUT (INPUT FILE] (OR (READTABLEP HPRINTRDTBL) (HPINITRDTBL)) (RETURN (READ FILE HPRINTRDTBL]) + +(HPINITRDTBL [LAMBDA NIL (* lmm " 5-JAN-78 23:23") (COND ([NOT (READTABLEP (GETATOMVAL 'HPRINTRDTBL] (PROG [(RDTBL (COPYREADTABLE 'ORIG] (SETSYNTAX (CONSTANT HPFORWRDCHR) (LIST 'MACRO (FUNCTION HVFWDREAD)) RDTBL) (SETSYNTAX (CONSTANT HPFORWRDCDRCHR) (LIST 'INFIX (FUNCTION HVFWDCDREAD)) RDTBL) (SETSYNTAX (CONSTANT HPBAKCHAR) (LIST 'MACRO (FUNCTION HVBAKREAD)) RDTBL) (SETSYNTAX (CONSTANT HPFILLCHAR) 'SEPR RDTBL) (SETSYNTAX (CONSTANT HPFINALCHAR) 'SEPR RDTBL) (/SETATOMVAL 'HPRINTRDTBL RDTBL)) T]) + +(HVREADERR [LAMBDA (M1 M2) (ERROR (OR M1 "incorrect format on file") (OR M2 '(in HREAD]) + +(HPRINSP [LAMBDA (X) (* lmm%: "29-NOV-76 17:41:47") (PRIN2 X) (SPACES 1]) +) +(DEFINEQ + +(COPYALL + [LAMBDA (X) (* ; "Edited 9-Oct-94 13:06 by jds") + (COND + ((LISTP X) + (PROG [TAIL (VAL (LIST (COPYALL (CAR X] + (SETQ TAIL VAL) + LP (COND + ((NLISTP (SETQ X (CDR X))) + (AND X (RPLACD TAIL (COPYALL X))) + (RETURN VAL))) + [RPLACD TAIL (SETQ TAIL (CONS (COPYALL (CAR X] + (GO LP))) + ((OR (LITATOM X) + (SMALLP X) + (CL:CHARACTERP X)) + X) + (T + (PROG ((TN (TYPENAME X))) + (RETURN + (COND + ((FMEMB TN DONTCOPYDATATYPES) + X) + (T (SELECTQ TN + (STRINGP (CONCAT X)) + (FLOATP (FPLUS X)) + (FIXP (IPLUS X)) + (HARRAYP (* ; "Hash array") + (PROG [(NH (HASHARRAY (HARRAYSIZE X) + (HARRAYPROP X 'OVERFLOW] + (DECLARE (SPECVARS NH)) + [MAPHASH X (FUNCTION (LAMBDA (X Y) + (PUTHASH (COPYALL Y) + (COPYALL X) + NH] + (RETURN NH))) + (READTABLEP (COPYREADTABLE X)) + (TERMTABLEP (COPYTERMTABLE X)) + (ARRAYP [PROG ((SIZE (ARRAYSIZE X)) + (TYPE (ARRAYTYP X)) + (ORIG (ARRAYORIG X)) + NEW) + (RETURN (PROG1 (SETQ NEW (ARRAY SIZE TYPE NIL ORIG)) + (FRPTQ SIZE (SETA NEW ORIG (COPYALL + (ELT X ORIG))) + (add ORIG 1)))]) + (BITMAP (BITMAPCOPY X)) + (CURSOR + (* ;; "For cursors, must preserve EQ-ness of MASK & IMAGE, to avoid trouble with SOFTCURSOR code being missing.(COPY") + + (LET* [(IM (BITMAPCOPY (FETCH (CURSOR CUIMAGE) OF X))) + (NEW (CURSORCREATE IM [COND + ((EQ (FETCH (CURSOR CUMASK) + OF X) + (FETCH (CURSOR CUIMAGE) + OF X)) + IM) + (T (BITMAPCOPY (FETCH + (CURSOR CUMASK) + OF X] + (FETCH (CURSOR CUHOTSPOTX) OF X) + (FETCH (CURSOR CUHOTSPOTY) OF X) + (COPYALL (FETCH (CURSOR CUDATA) + OF X] + NEW)) + (CCODEP X) + (NIL (\COPYARRAYBLOCK X)) + (\COPYDATATYPE X]) + +(\COPYDATATYPE [LAMBDA (X) (* lmm "21-Apr-85 15:29") (LET* ((NTYP (NTYPX X)) (DTD (\GETDTD NTYP)) (PTRS (fetch DTDPTRS of DTD)) (NEW (CREATECELL NTYP))) (PROG1 NEW (if PTRS then (UNINTERRUPTABLY (\BLT NEW X (fetch DTDSIZE of DTD)) (for P in PTRS do (\ADDREF (\GETBASEPTR NEW P)))) [for P in PTRS do (\RPLPTR NEW P (COPYALL (\GETBASEPTR NEW P] else (\BLT NEW X (fetch DTDSIZE of DTD))))]) + +(HCOPYALL [LAMBDA (X) (* rmk%: " 3-Jan-84 13:16") [COND ([OR (HARRAYP HPRINTHASHARRAY) (HARRAYP (CAR (LISTP HPRINTHASHARRAY] (CLRHASH HPRINTHASHARRAY)) (T (SETQ HPRINTHASHARRAY (HASHARRAY 100] (HCOPYALL1 X]) + +(HCOPYALL1 [LAMBDA (X) (* bvm%: " 7-Feb-85 21:25") (COND ((OR (LITATOM X) (SMALLP X)) X) (T (PROG ((TYPE (TYPENAME X)) SEEN NEW) (RETURN (COND ((FMEMB (SETQ TYPE (TYPENAME X)) DONTCOPYDATATYPES) X) (T (OR (GETHASH X HPRINTHASHARRAY) (SELECTQ TYPE (LISTP (FRPLNODE (PUTHASH X (CONS) HPRINTHASHARRAY) (HCOPYALL1 (CAR X)) (HCOPYALL1 (CDR X)))) (STRINGP (PUTHASH X (CONCAT X) HPRINTHASHARRAY)) (FLOATP (PUTHASH X (FPLUS X) HPRINTHASHARRAY)) (FIXP (PUTHASH X (IPLUS X) HPRINTHASHARRAY)) (ARRAYP (PROG ((SIZE (ARRAYSIZE X)) (TYP (ARRAYTYP X)) (ORIG (ARRAYORIG X))) (* ; "Regular array") (PUTHASH X (SETQ NEW (ARRAY SIZE TYP NIL ORIG)) HPRINTHASHARRAY) (FRPTQ SIZE (SETA NEW ORIG (HCOPYALL1 (ELT X ORIG))) (add ORIG 1)) (RETURN NEW))) (HARRAYP (PUTHASH X [SETQ NEW (HASHARRAY (HARRAYSIZE X) (HARRAYPROP X 'OVERFLOW] HPRINTHASHARRAY) [PROG ((NH NEW)) (DECLARE (SPECVARS NH)) (MAPHASH X (FUNCTION (LAMBDA (X Y) (PUTHASH (HCOPYALL1 Y) (HCOPYALL1 X) NEW] NEW) (READTABLEP (COPYREADTABLE X)) (BITMAP (PUTHASH X (BITMAPCOPY X) HPRINTHASHARRAY)) (TERMTABLEP (COPYTERMTABLE X)) (COND ((SETQ SEEN (GETDESCRIPTORS TYPE)) (PUTHASH X (SETQ NEW (NCREATE TYPE)) HPRINTHASHARRAY) [for FIELD in SEEN do (REPLACEFIELD FIELD NEW (HCOPYALL1 (FETCHFIELD FIELD X] NEW) (T X]) +) +(DEFINEQ + +(EQUALALL [LAMBDA (X Y) (* ; "Edited 28-Jan-93 17:30 by jds") (OR (EQ X Y) (PROG ((TY (TYPENAME Y)) TEM) (RETURN (AND (EQ TY (TYPENAME X)) (SELECTQ TY ((LITATOM NEW-ATOM SMALLP) (* ; "not eq, so not equal") NIL) (FIXP (IEQP X Y)) (FLOATP (EQP X Y)) (LISTP (AND (EQUALALL (CAR X) (CAR Y)) (EQUALALL (CDR X) (CDR Y)))) (STRINGP (STREQUAL X Y)) (ARRAYP [AND (EQ (ARRAYORIG X) (ARRAYORIG Y)) (EQUAL (ARRAYTYP X) (ARRAYTYP Y)) (EQUAL (SETQ TEM (ARRAYSIZE X)) (ARRAYSIZE Y)) (for I from (ARRAYORIG X) as J to TEM always (EQUALALL (ELT X I) (ELT Y I]) (HARRAYP (EQUALHASH X Y)) (READTABLEP (for I from 0 to 127 always (EQUALALL (GETSYNTAX I X) (GETSYNTAX I Y)))) (TERMTABLEP [AND (EQ (GETCONTROL X) (GETCONTROL Y)) (EQ (GETRAISE X) (GETRAISE Y)) (EQ (GETECHOMODE X) (GETECHOMODE Y)) (EQ (GETDELETECONTROL X) (GETDELETECONTROL Y)) [EVERY ORIGTERMSYNTAX (FUNCTION (LAMBDA (Z) (EQUAL (GETSYNTAX (CAR Z) X) (GETSYNTAX (CAR Z) Y] (for I from 0 to 31 always (EQ (ECHOCONTROL I NIL X) (ECHOCONTROL I NIL Y))) (EVERY ORIGDELETECONTROL (FUNCTION (LAMBDA (Z) (EQUAL (DELETECONTROL (CAR Z) NIL X) (DELETECONTROL (CAR Z) NIL Y]) (OR (EQP X Y) (AND (SETQ TY (GETDESCRIPTORS TY)) (for FIELD in TY always (EQUALALL (FETCHFIELD FIELD X) (FETCHFIELD FIELD Y]) + +(EQUALHASH [LAMBDA (AR1 AR2) (DECLARE (SPECVARS AR1 AR2)) (* rmk%: "26-Dec-83 13:33") (* ;  "What does it mean for two hash arrays to be EQUAL?") [PROG (UNMATCHED) (OR (EQUAL (HARRAYPROP AR1 'OVERFLOW) (HARRAYPROP AR2 'OVERFLOW)) (RETURN)) [MAPHASH AR1 (FUNCTION (LAMBDA (VAL KEY) (COND [(LITATOM KEY) (OR (EQUALALL (GETHASH KEY AR2) VAL) (RETFROM (FUNCTION EQUALHASH] (T (SETQ UNMATCHED (CONS KEY UNMATCHED] (MAPHASH AR2 (FUNCTION (LAMBDA (VAL KEY) (COND [(LITATOM KEY) (OR (GETHASH KEY AR1) (RETFROM (FUNCTION EQUALHASH] ([NOT (SOME UNMATCHED (FUNCTION (LAMBDA (Y) (AND (EQUALALL KEY Y) (EQUALALL VAL (GETHASH Y AR1] (RETFROM (FUNCTION EQUALHASH] T]) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY + +(BLOCK%: COPYALL COPYALL (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + +(BLOCK%: EQUALALL EQUALALL EQUALHASH (RETFNS EQUALHASH) + (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + +(BLOCK%: NIL HCOPYALL (LOCALVARS . T)) + +(BLOCK%: HCOPYALL1 HCOPYALL1 (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY)) + +(BLOCK%: HPRINTBLOCK HPRINT RPTPRINT RPTPUT RPTEND HPRINTEND HPRINT1 HPRINSP HPRINTSP HPERR + (LOCALFREEVARS DATATYPESEEN BACKREFS CELLCOUNT RPTLAST RPTCNT U) + (NOLINKFNS . T) + (GLOBALVARS SYSHASHARRAY FCHARAR) + (ENTRIES HPRINT HPRINT1)) + +(BLOCK%: NIL MAKEHVPRETTYCOMS READVAR-FROM-STRING READVARS-FROM-STREAM HPRINT-TO-STRING READVARS + HPINITRDTBL HVFWDCDREAD HVBAKREAD HVRPTREAD HVFWDREAD HREAD HPRINT0 HVREADERR (NOLINKFNS . T) + (LOCALVARS . T) + (SPECVARS BACKREFS BACKREFCNT DATATYPESEEN RPTCNT RPTVAL) + (GLOBALVARS FILERDTBL)) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS HPRINTHASHARRAY HPRINTRDTBL HPBAKCHAR HPFORWRDCDRCHR HPFORWRDCHR HPFILLCHAR HPFINALCHAR + HPFILLSTRING HPRPTSTRING CIRCLMARKER DONTCOPYDATATYPES ORIGTERMSYNTAX ORIGECHOCONTROL + ORIGDELETECONTROL HPRINTMACROS) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(RPAQQ HPFORWRDCHR 94) + +(RPAQQ HPFORWRDCDRCHR 96) + +(RPAQQ HPBAKCHAR 123) + +(RPAQQ HPFILLCHAR 0) + +(RPAQQ HPFINALCHAR 125) + +(RPAQ HPFILLSTRING (PACKC (LIST HPBAKCHAR HPFILLCHAR))) + + +(PUTPROPS HPRINTSTRING MACRO [X (LIST 'PRIN1 (KWOTE (CONCAT (CHARACTER HPBAKCHAR) + (CAR X]) + +(PUTPROPS HPRINTENDSTR MACRO [X (COND + [(CAR X) + '(PRIN3 (CONSTANT (CHARACTER HPFINALCHAR] + (T '(PRIN1 (CONSTANT (CHARACTER HPFINALCHAR]) +) + +(RPAQQ HPRINTMACROS NIL) + +(RPAQQ HPRINTHASHARRAY NIL) + +(RPAQQ HPRINTRDTBL NIL) + +(RPAQ HPRPTSTRING "") + +(RPAQQ DONTCOPYDATATYPES NIL) + +(RPAQQ ORIGDELETECONTROL ((DELETELINE . "## +") + (1STCHDEL . "\") + (NTHCHDEL . "") + (POSTCHDEL . "\") + (EMPTYCHDEL . "## +"))) + +(RPAQQ ORIGTERMSYNTAX ((CTRLV 22) + (RETYPE 18) + (LINEDELETE 17) + (CHARDELETE 1) + (EOL 31))) + +(RPAQQ ORIGECHOCONTROL ((0 . IGNORE) + (1 . IGNORE) + (7 . REAL) + (8 . UPARROW) + (9 . SIMULATE) + (10 . REAL) + (13 . REAL) + (17 . IGNORE) + (18 . IGNORE) + (27 . SIMULATE) + (31 . REAL))) + +(ADDTOVAR HPRINTREADFNS READBITMAP) + +(ADDTOVAR GAINSPACEFORMS [(OR HPRINTHASHARRAY HPRINTRDTBL) + "discard HPRINT initialization" + (PROGN (CLRHASH HPRINTHASHARRAY) + (SETQ HPRINTHASHARRAY (SETQ HPRINTRDTBL]) + +(PUTPROPS HPRINT FILETYPE CL:COMPILE-FILE) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA HPRINT0 READVARS) + +(ADDTOVAR NLAML MAKEHVPRETTYCOMS) + +(ADDTOVAR LAMA ) +) +(PUTPROPS HPRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 +1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (3679 6217 (MAKEHVPRETTYCOMS 3689 . 4976) (READVARS 4978 . 5544) (HPRINT0 5546 . 6215)) +(6942 8870 (READVAR-FROM-STRING 6952 . 7358) (READVARS-FROM-STRING 7360 . 7596) (HPRINT-TO-STRING 7598 + . 7804) (HPRINT-TO-STRINGS 7806 . 8868)) (9681 37913 (HPRINT 9691 . 11321) (HPRINT1 11323 . 22825) ( +HPRINTEND 22827 . 23863) (RPTPRINT 23865 . 24103) (RPTEND 24105 . 24264) (RPTPUT 24266 . 24764) ( +HPRINTSP 24766 . 24830) (HPERR 24832 . 24929) (HVFWDCDREAD 24931 . 25310) (HVBAKREAD 25312 . 33357) ( +HVREADCHECKGETFN 33359 . 34758) (HVREADEND 34760 . 35112) (HVRPTREAD 35114 . 35640) (HVFWDREAD 35642 + . 36496) (HREAD 36498 . 36820) (HPINITRDTBL 36822 . 37656) (HVREADERR 37658 . 37771) (HPRINSP 37773 + . 37911)) (37914 46796 (COPYALL 37924 . 41827) (\COPYDATATYPE 41829 . 42518) (HCOPYALL 42520 . 42830) + (HCOPYALL1 42832 . 46794)) (46797 52716 (EQUALALL 46807 . 51037) (EQUALHASH 51039 . 52714))))) +STOP diff --git a/sources/ICONW b/sources/ICONW new file mode 100644 index 00000000..1c5cf0db --- /dev/null +++ b/sources/ICONW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 18:16:27" {DSK}local>lde>lispcore>sources>ICONW.;2 17074 changes to%: (VARS ICONWCOMS) previous date%: "17-Dec-87 17:45:42" {DSK}local>lde>lispcore>sources>ICONW.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT ICONWCOMS) (RPAQQ ICONWCOMS ( (* ;; "Support for icons with non-rectangluar shape and with custom lettering inside them.") (FNS ICONW ICONW.SHADE \ICONW.REPAINTFN \ICONW.COPYBUTTONEVENTFN) (FNS TITLEDICONW ICONW.TITLE \ICONW.SHOW.TITLE ICONW.PRINT-JUSTIFIED \ICONW.FORMAT.TITLE \ICONW.FORMAT.TITLE1 ICONTITLE) (COMS (* ; "for use as DEFAULTICONFN") (FNS TEXTICON) (INITVARS (DEFAULTTEXTICON))) (RECORDS TITLEDICON) (INITVARS (DEFAULTICONWIDTH 100) (DEFAULTICONFONT (FONTCREATE 'HELVETICA 10))) (DECLARE%: DONTCOPY (RECORDS ICONTITLE) (GLOBALVARS DEFAULTICONWIDTH DEFAULTICONFONT DEFAULTTEXTICON WBorder) (CONSTANTS (ICONSELECTIONSHADE 23130)) (MACROS .COPYKEYDOWNP.)))) (* ;; "Support for icons with non-rectangluar shape and with custom lettering inside them.") (DEFINEQ (ICONW (LAMBDA (ICON MASK POSITION NOOPENFLG) (* bvm%: "26-Aug-85 16:01") (* ;; "creates a window that merges with its background. This is done by putting the background in the original bits, erasing the bits that are on in MASK and then painting the bits from IMAGEBM.") (COND ((NOT (type? POSITION POSITION)) (SETQ POSITION (GETBOXPOSITION (fetch (BITMAP BITMAPWIDTH) of ICON) (fetch (BITMAP BITMAPHEIGHT) of ICON))))) (LET ((ICONW (CREATEW (create REGION LEFT _ (fetch (POSITION XCOORD) of POSITION) BOTTOM _ (fetch (POSITION YCOORD) of POSITION) WIDTH _ (fetch (BITMAP BITMAPWIDTH) of ICON) HEIGHT _ (fetch (BITMAP BITMAPHEIGHT) of ICON)) NIL 0 T))) (WINDOWPROP ICONW (QUOTE RESHAPEFN) (QUOTE DON'T)) (WINDOWPROP ICONW (QUOTE ICONIMAGE) ICON) (WINDOWPROP ICONW (QUOTE ICONMASK) MASK) (WINDOWPROP ICONW (QUOTE AFTERMOVEFN) (FUNCTION \ICONW.REPAINTFN)) (WINDOWPROP ICONW (QUOTE TOTOPFN) (FUNCTION \ICONW.REPAINTFN)) (WINDOWPROP ICONW (QUOTE OPENFN) (FUNCTION \ICONW.REPAINTFN)) (OR NOOPENFLG (OPENW ICONW)) ICONW)) ) (ICONW.SHADE (LAMBDA (WINDOW SHADE) (* ; "Edited 20-Feb-87 11:02 by jds") (AND (WINDOWP WINDOW) (LET (SHADEBM ERASEBM IMAGEBM) (COND (SHADE (COND ((NEQ SHADE WHITESHADE) (* ; "Build an auxiliary bitmap that is shaded the requested shade in all the parts where the image shows") (OR (SETQ SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE))) (WINDOWPROP WINDOW (QUOTE SHADEIMAGE) (SETQ SHADEBM (BITMAPCREATE (fetch (BITMAP BITMAPWIDTH) of (SETQ IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE)))) (fetch (BITMAP BITMAPHEIGHT) of IMAGEBM))))) (BLTSHADE SHADE SHADEBM 0 0 NIL NIL (QUOTE REPLACE)) (COND ((SETQ ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK))) (BITBLT ERASEBM 0 0 SHADEBM 0 0 NIL NIL (QUOTE INVERT) (QUOTE ERASE))))) (T (WINDOWPROP WINDOW (QUOTE SHADEIMAGE) NIL))))) (PROG1 (WINDOWPROP WINDOW (QUOTE ICONSHADE) SHADE) (AND SHADE (OPENWP WINDOW) (\ICONW.REPAINTFN WINDOW)))))) ) (\ICONW.REPAINTFN (LAMBDA (WINDOW) (* bvm%: "31-Jul-85 14:05") (PROG ((IMAGEBM (WINDOWPROP WINDOW (QUOTE ICONIMAGE))) (ERASEBM (WINDOWPROP WINDOW (QUOTE ICONMASK))) (SHADEBM (WINDOWPROP WINDOW (QUOTE SHADEIMAGE))) WIDTH HEIGHT) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGEBM)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGEBM)) (TOTOPW WINDOW T) (* ; "Bring the window to the top without calling its TOTOPFN (i.e., this very fn)") (COND (ERASEBM (* ;; "There's clipping to do, so copy the background, erase bits where the image lies, then OR in the image") (BITBLT (WINDOWPROP WINDOW (QUOTE IMAGECOVERED)) 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE)) (BITBLT ERASEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE ERASE)) (BITBLT IMAGEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE PAINT))) (T (* ; "No clipping, just copy out the original image") (BITBLT IMAGEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE REPLACE)))) (COND (SHADEBM (* ; "The image is to be shaded") (BITBLT SHADEBM 0 0 WINDOW 0 0 WIDTH HEIGHT (QUOTE INPUT) (QUOTE PAINT)))))) ) (\ICONW.COPYBUTTONEVENTFN (LAMBDA (WINDOW) (* ; "Edited 17-Dec-87 17:42 by bvm:") (* ;;; "copy select the window's title (or whatever it says to copy).") (PROG* ((TITLESPEC (WINDOWPROP WINDOW (QUOTE ICONTITLESPEC))) (REG (fetch ICREGION of TITLESPEC)) (LEFT (fetch (REGION LEFT) of REG)) (BOTTOM (fetch (REGION BOTTOM) of REG)) (WIDTH (fetch (REGION WIDTH) of REG)) (HEIGHT (fetch (REGION HEIGHT) of REG)) (SHADE ICONSELECTIONSHADE) (SELECTEDP T) COPYFN) SELECTEDLP (TOTOPW WINDOW) (* ; "Draw a box around the title region") (BLTSHADE SHADE WINDOW LEFT BOTTOM WIDTH 2 (QUOTE INVERT)) (BLTSHADE SHADE WINDOW LEFT (+ BOTTOM 2) 2 (- HEIGHT 4) (QUOTE INVERT)) (BLTSHADE SHADE WINDOW LEFT (+ BOTTOM HEIGHT -2) WIDTH 2 (QUOTE INVERT)) (BLTSHADE SHADE WINDOW (+ LEFT WIDTH -2) (+ BOTTOM 2) 2 (- HEIGHT 4) (QUOTE INVERT)) LP (if (NEQ SELECTEDP (SETQ SELECTEDP (EQ (WHICHW) WINDOW))) then (if SELECTEDP then (* ; "Moved back inside") (GO SELECTEDLP) else (* ; "Moved outside") (\ICONW.REPAINTFN WINDOW))) (* ; "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") (COND (SELECTEDP (\ICONW.REPAINTFN WINDOW) (if (SETQ COPYFN (WINDOWPROP WINDOW (QUOTE COPYFN))) then (* ; " Window says how to copy select") (CL:FUNCALL COPYFN WINDOW) else (BKSYSBUF (fetch ICTITLE of TITLESPEC))))) (until (MOUSESTATE UP) do (BLOCK)) (* ; "Wait for mouse to come up, so we don't get bogus button event afterwards") (RETURN)) ((MOUSESTATE UP) (if (NOT SELECTEDP) then (* ; "Button up, and outside window, so can return") (RETURN) else (* ; "Wait for copy to come up") (GO LP2))) (T (* ; "While button is down, watch where mouse is") (GO LP))))) ) ) (DEFINEQ (TITLEDICONW (LAMBDA (ICON TITLE FONT POSITION NOOPENFLG JUST BREAKCHARS OPERATION) (* ; "Edited 17-Dec-87 17:22 by bvm:") (* ;; "Given a TITLEDICON, create an instance of it with specific text.") (LET (BITS ICONW TITLESPEC REG MASK FORMATTED) (COND ((NOT BREAKCHARS) (SETQ BREAKCHARS (CHARCODE (SPACE)))) ((EQ BREAKCHARS (QUOTE FILE)) (* ; "File name field separators") (SETQ BREAKCHARS (CHARCODE (SPACE - } %: > %. ; /)))) ((NLISTP BREAKCHARS) (SETQ BREAKCHARS (LIST BREAKCHARS)))) (SETQ FONT (FONTCREATE (OR FONT DEFAULTICONFONT))) (SELECTQ OPERATION ((REPLACE INVERT)) (ERASE (SETQQ OPERATION INVERT)) ((NIL PAINT) (SETQQ OPERATION REPLACE)) (\ILLEGAL.ARG OPERATION)) (COND (ICON (SETQ BITS (BITMAPCOPY (fetch (TITLEDICON ICON) of ICON))) (SETQ REG (fetch TITLEREG of ICON)) (SETQ MASK (fetch (TITLEDICON MASK) of ICON))) (T (LET ((TITLEWIDTH (STRINGWIDTH TITLE FONT)) (BORDER WBorder) WIDTH HEIGHT) (* ; "Make a simple rectangle with a border like a window") (SETQ FORMATTED (\ICONW.FORMAT.TITLE TITLE FONT (IMAX DEFAULTICONWIDTH (LRSH TITLEWIDTH 1)) BREAKCHARS)) (* ;; "Try actually formatting the title, expecting about three lines, to see what dimensions the window needs to be") (SETQ WIDTH (WIDTHIFWINDOW (OR (CDR (for X in FORMATTED largest (CDR X))) DEFAULTICONWIDTH) BORDER)) (SETQ HEIGHT (HEIGHTIFWINDOW (TIMES (LENGTH FORMATTED) (FONTPROP FONT (QUOTE HEIGHT))) NIL BORDER)) (SETQ BITS (BITMAPCREATE WIDTH HEIGHT)) (BLTSHADE BLACKSHADE BITS 0 0 WIDTH HEIGHT (QUOTE REPLACE)) (* ; "Fill with black, then white out everything but the border") (COND ((NEQ OPERATION (QUOTE INVERT)) (BLTSHADE WHITESHADE BITS (FOLDHI BORDER 2) (FOLDHI BORDER 2) (- WIDTH BORDER) (- HEIGHT BORDER) (QUOTE REPLACE)))) (SETQ REG (CREATEREGION BORDER BORDER (- WIDTH (LLSH BORDER 1)) (- HEIGHT (LLSH BORDER 1))))))) (SETQ ICONW (ICONW BITS MASK POSITION T)) (WINDOWPROP ICONW (QUOTE ICONTITLESPEC) (SETQ TITLESPEC (create ICONTITLE ICIMAGE _ BITS ICFONT _ FONT ICJUST _ JUST ICREGION _ REG ICBREAKCHARS _ BREAKCHARS ICOPERATION _ OPERATION))) (WINDOWPROP ICONW (QUOTE COPYBUTTONEVENTFN) (FUNCTION \ICONW.COPYBUTTONEVENTFN)) (\ICONW.SHOW.TITLE ICONW TITLESPEC (MKSTRING (OR TITLE " ")) T) (* ; "Create a copy of the icon image, with the text imposed on it.") (* ; "Save it for restoration on open, repaint, &c") (OR NOOPENFLG (OPENW ICONW)) (* ; "Open the window, unless he wants it kept closed.") ICONW)) ) (ICONW.TITLE (LAMBDA (ICONW TITLE) (* bvm%: "30-Aug-85 17:19") (* ;;; "Returns current title of icon, sets new title if TITLE not NIL") (LET ((TITLESPEC (WINDOWPROP ICONW (QUOTE ICONTITLESPEC)))) (COND ((NOT TITLESPEC) (ERROR "Not a titled icon" ICONW)) (T (PROG1 (fetch ICTITLE of TITLESPEC) (COND (TITLE (\ICONW.SHOW.TITLE ICONW TITLESPEC TITLE) (AND (OPENWP ICONW) (\ICONW.REPAINTFN ICONW))))))))) ) (\ICONW.SHOW.TITLE (LAMBDA (ICONW TITLESPEC TEXT NEWFLG) (* ; "Edited 17-Dec-87 15:35 by bvm:") (* ;; "Create a copy of the icon window's image bitmap, complete with text in place according to the TITLESPEC. If NEWFLG, don't bother erasing the text area.") (LET ((JUST (fetch ICJUST of TITLESPEC)) (FONT (fetch ICFONT of TITLESPEC)) (REG (fetch ICREGION of TITLESPEC)) (BITS (BITMAPCOPY (fetch ICIMAGE of TITLESPEC))) (OPERATION (fetch ICOPERATION of TITLESPEC)) (MASK (WINDOWPROP ICONW (QUOTE ICONMASK)))) (* ; "Set up a displaystream so we can print onto the icon's image bitmap") (ICONW.PRINT-JUSTIFIED (DSPCREATE BITS) JUST FONT REG OPERATION (fetch ICBREAKCHARS of TITLESPEC) TEXT NEWFLG) (COND (MASK (BITBLT MASK 0 0 BITS 0 0 (fetch BITMAPWIDTH of BITS) (fetch BITMAPHEIGHT of BITS) (QUOTE INVERT) (QUOTE ERASE)))) (replace ICTITLE of TITLESPEC with TEXT) (WINDOWPROP ICONW (QUOTE ICONIMAGE) BITS) ICONW)) ) (ICONW.PRINT-JUSTIFIED (LAMBDA (STREAM JUST FONT REG OPERATION BREAKCHARS TEXT NEWFLG) (* ; "Edited 10-Nov-87 12:41 by jds") (LET ((OLDCLIP (DSPCLIPPINGREGION REG STREAM)) (REAL-FONT (FONTCOPY FONT (QUOTE DEVICE) STREAM)) LMARG MAXHEIGHT MAXWIDTH MAXLINES WIDTH FORMATTEDLINES FONTHEIGHT TITLEHEIGHT) (DSPFONT REAL-FONT STREAM) (* ; "Set the right font") (DSPOPERATION OPERATION STREAM) (* ; "Don't erase any bits from the icon image--paint the msg") (LINELENGTH 32000 STREAM) (* ; "Avoid trouble with PRIN1") (DSPLEFTMARGIN (SETQ LMARG (fetch (REGION LEFT) of REG)) STREAM) (* ; "Left margin for the message") (DSPRIGHTMARGIN 32700 STREAM) (COND ((NOT NEWFLG) (* ; "Clear anything in the title region") (DSPFILL REG (SELECTQ OPERATION (INVERT BLACKSHADE) WHITESHADE) (QUOTE REPLACE) STREAM))) (SETQ FONTHEIGHT (FONTPROP REAL-FONT (QUOTE HEIGHT))) (* ; "Single line's height") (SETQ MAXHEIGHT (fetch (REGION HEIGHT) of REG)) (* ; "Max height of the title") (SETQ MAXWIDTH (fetch (REGION WIDTH) of REG)) (SETQ FORMATTEDLINES (\ICONW.FORMAT.TITLE TEXT REAL-FONT MAXWIDTH BREAKCHARS (SETQ MAXLINES (IQUOTIENT MAXHEIGHT FONTHEIGHT)))) (SETQ TITLEHEIGHT (ITIMES FONTHEIGHT (FLENGTH FORMATTEDLINES))) (* ; "Height of the message") (MOVETO LMARG (IPLUS (fetch (REGION BOTTOM) of REG) (IDIFFERENCE (IMIN MAXHEIGHT (COND ((EQMEMB (QUOTE TOP) JUST) (* ; "Top-flush title") (fetch (REGION TOP) of REG)) ((EQMEMB (QUOTE BOTTOM) JUST) (* ; "Bottom-flush title") (IPLUS (fetch (REGION BOTTOM) of REG) TITLEHEIGHT)) ((IGREATERP TITLEHEIGHT MAXHEIGHT) MAXHEIGHT) (T (* ; "Centered vertically title") (IDIFFERENCE MAXHEIGHT (LRSH (IDIFFERENCE MAXHEIGHT TITLEHEIGHT) 1))))) (FONTPROP REAL-FONT (QUOTE ASCENT)))) STREAM) (* ; "Move to the left end of the first message line") (bind (NCH _ 0) to MAXLINES as LINE in FORMATTEDLINES do (* ; "FORMATTEDLINES is a list of elements (lastch# . width)") (COND ((NOT (EQMEMB (QUOTE LEFT) JUST)) (* ; "Move to this line's left end") (LET ((LEFTOVER (IDIFFERENCE MAXWIDTH (CDR LINE)))) (RELMOVETO (COND ((EQMEMB (QUOTE RIGHT) JUST) LEFTOVER) (T (LRSH LEFTOVER 1))) 0 STREAM)))) (bind (MAXCHAR _ (CAR LINE)) CH do (* ; "Print the characters -- except the final SPACE on a line, or a CR") (SETQ CH (NTHCHARCODE TEXT (add NCH 1))) (COND ((NOT (AND (EQ NCH (CAR LINE)) (FMEMB CH (CHARCODE (CR SPACE))))) (\OUTCHAR STREAM CH))) repeatuntil (EQ NCH MAXCHAR)) (TERPRI STREAM)) (DSPCLIPPINGREGION OLDCLIP STREAM))) ) (\ICONW.FORMAT.TITLE (LAMBDA (TITLE FONT MAXWIDTH BREAKCHARS MAXLINES) (* bvm%: "27-Aug-85 18:21") (LET ((RESULT (\ICONW.FORMAT.TITLE1 TITLE FONT MAXWIDTH BREAKCHARS))) (COND ((OR (NULL MAXLINES) (GEQ MAXLINES (LENGTH RESULT))) (* ; "It fit, so return it") RESULT) (T (* ; "Try breaking less") (LET ((WASTED 0) (EXCESS 0)) (for I from 1 as LINE in RESULT do (COND ((LEQ I MAXLINES) (add WASTED (IDIFFERENCE MAXWIDTH (CDR LINE)))) (T (add EXCESS (CDR LINE))))) (COND ((AND (LESSP EXCESS WASTED) (GEQ MAXLINES (LENGTH (SETQ RESULT (\ICONW.FORMAT.TITLE1 TITLE FONT MAXWIDTH BREAKCHARS (IDIFFERENCE MAXWIDTH (IQUOTIENT (IDIFFERENCE WASTED EXCESS) MAXLINES))))))) (* ; "Reformatted okay by forcing less wastage per line") RESULT) (T (* ; "Take out all the breaks") (\ICONW.FORMAT.TITLE1 TITLE FONT MAXWIDTH NIL MAXWIDTH)))))))) ) (\ICONW.FORMAT.TITLE1 (LAMBDA (TITLE FONT MAXWIDTH BREAKCHARS MINWIDTH) (* ; "Edited 9-Nov-87 14:01 by bvm:") (LET* ((TITLELEN (NCHARS TITLE)) (DONE (EQ TITLELEN 0)) (FONTHEIGHT (FONTPROP FONT (QUOTE HEIGHT))) (NCH 0) (WIDTHSOFAR 0) TCH CHWIDTH) (until DONE collect (* ; "Gather the icon title, broken into lines which fit.") (bind CH LASTBREAKPOS LASTBREAKWIDTH do (* ; "Run thru the characters one by one.") (COND ((>= NCH TITLELEN) (* ; "That was the last character.") (SETQ DONE T) (RETURN (CONS TITLELEN WIDTHSOFAR))) (T (* ; "Look at the next character.") (SETQ CH (NTHCHARCODE TITLE (add NCH 1))) (COND ((EQ CH (CHARCODE CR)) (* ; "CR forces a new line.") (RETURN (PROG1 (CONS NCH WIDTHSOFAR) (SETQ WIDTHSOFAR 0))))) (COND ((IGREATERP (add WIDTHSOFAR (SETQ CHWIDTH (CHARWIDTH CH FONT))) MAXWIDTH) (* ; "We're past the right margin. Time to stop.") (RETURN (COND ((AND (EQ CH (CHARCODE SPACE)) (FMEMB CH BREAKCHARS)) (* ; "We just happened to end at a space, so it's safe to break here") (PROG1 (CONS NCH (- WIDTHSOFAR CHWIDTH)) (COND ((EQ NCH TITLELEN) (* ; "Title ends in a space, which we will not print, so we're done (otherwise, we'd have nothing to collect for the next line).") (SETQ DONE T)) (T (* ; "Since we're breaking exactly here, we have nothing leftover for the next line.") (SETQ WIDTHSOFAR 0))))) (LASTBREAKPOS (* ; "There is a space we can break the line at. Break there.") (SETQ WIDTHSOFAR (- WIDTHSOFAR LASTBREAKWIDTH)) (CONS LASTBREAKPOS (COND ((EQ (NTHCHARCODE TITLE LASTBREAKPOS) (CHARCODE SPACE)) (- LASTBREAKWIDTH (CHARWIDTH (CHARCODE SPACE) FONT))) (T LASTBREAKWIDTH)))) (T (* ; "There were no spaces on this line. Break after the last character that did fit.") (CONS (SUB1 NCH) (- WIDTHSOFAR (SETQ WIDTHSOFAR CHWIDTH)))))))) (COND ((AND (FMEMB CH BREAKCHARS) (OR (NULL MINWIDTH) (>= WIDTHSOFAR MINWIDTH))) (* ;; "Remember where spaces are, so we can back up and split lines there if possible. Don't split if there isn't enough on the line yet") (SETQ LASTBREAKPOS NCH) (SETQ LASTBREAKWIDTH WIDTHSOFAR))))))))) ) (ICONTITLE (LAMBDA (MSG REG FONT ICONW JUST) (* bvm%: "16-Aug-85 20:20") (* ; "Obsolete entry") (LET ((TITLESPEC (WINDOWPROP ICONW (QUOTE ICONTITLESPEC)))) (COND ((NOT TITLESPEC) (ERROR "Not a titled icon" ICONW)) (T (COND (REG (replace ICREGION of TITLESPEC with REG))) (COND (FONT (replace ICFONT of TITLESPEC with FONT))) (COND (JUST (replace ICJUST of TITLESPEC with JUST))) (\ICONW.SHOW.TITLE ICONW TITLESPEC MSG))))) ) ) (* ; "for use as DEFAULTICONFN") (DEFINEQ (TEXTICON (LAMBDA (WINDOW TEXT) (* bvm%: "18-Mar-86 16:54") (OR (WINDOWP TEXT) (LET* ((ICON (TITLEDICONW DEFAULTTEXTICON (COND (TEXT) ((AND (SETQ TEXT (WINDOWPROP WINDOW (QUOTE TITLE))) (NEQ (NCHARS TEXT) 0)) TEXT) (T (CONCAT "Icon made " (DATE)))) NIL (WINDOWPROP WINDOW (QUOTE ICONPOSITION)))) (REG (WINDOWPROP ICON (QUOTE REGION)))) (WINDOWPROP WINDOW (QUOTE ICONPOSITION) (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG))) (* ; "Remember position for the next shrinkage") ICON))) ) ) (RPAQ? DEFAULTTEXTICON ) (DECLARE%: EVAL@COMPILE (RECORD TITLEDICON (ICON MASK TITLEREG)) ) (RPAQ? DEFAULTICONWIDTH 100) (RPAQ? DEFAULTICONFONT (FONTCREATE 'HELVETICA 10)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD ICONTITLE (ICIMAGE ICTITLE ICFONT ICJUST ICREGION ICBREAKCHARS ICOPERATION)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTICONWIDTH DEFAULTICONFONT DEFAULTTEXTICON WBorder) ) (DECLARE%: EVAL@COMPILE (RPAQQ ICONSELECTIONSHADE 23130) (CONSTANTS (ICONSELECTIONSHADE 23130)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .COPYKEYDOWNP. MACRO [NIL (OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'COPY]) ) ) (PUTPROPS ICONW COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1416 6115 (ICONW 1426 . 2449) (ICONW.SHADE 2451 . 3332) (\ICONW.REPAINTFN 3334 . 4419) (\ICONW.COPYBUTTONEVENTFN 4421 . 6113)) (6116 15604 (TITLEDICONW 6126 . 8525) (ICONW.TITLE 8527 . 8933 ) (\ICONW.SHOW.TITLE 8935 . 9853) (ICONW.PRINT-JUSTIFIED 9855 . 12287) (\ICONW.FORMAT.TITLE 12289 . 13117) (\ICONW.FORMAT.TITLE1 13119 . 15172) (ICONTITLE 15174 . 15602)) (15646 16193 (TEXTICON 15656 . 16191))))) STOP \ No newline at end of file diff --git a/sources/ICONW.TEDIT b/sources/ICONW.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..c0624b6536ed7b2d85743277b17ff9642b7f1088 GIT binary patch literal 10934 zcmd5>U2_{(8J3&2G!*gGG87nw!!Vu5jG{Vjz97&U#g=0c*)ozG6FQxCB^_CdSG$_s zRa}>Q{sav7y<>(uenW5h4P0`;O)nVA^StL{S60%v3B%MATdTA0dB5N1eb33YYPHku zAE-|IZm-#Us1BN2_nY@xeYMxzKWuiY*Pimez17`6BGtWK^I*5V)#vkNvwE{y9ZbVa z;a{NU!RRD7)+(8($s!)*VG?I*lB8<52%~WrAFFH@M3FiT<8gADkuFGwVV(x*naZZY zT-Vh+4dYQb2iciyU1VAX;6HM_vMDG|$jq|2qr!%6)Kxy!pe+Oksa8>VqQNLn)KIH1 zew3W(v6`gG44d<57;}@NB|H0~jpf;>He(S2oOJY?UMsWK&tOFTe&XX)OuBXq!u}-17^FYC>4tWz*JDrBPe(dhkDRv6| z5CV?VWC7cVpsPaEg~$J)SnMTv6)onObCY43!n*#252o=|@_;0G&jQV3aQcmv4-K zjwTFgX_Jjc=tK$ET#b_1JkmK55>Xi?i!{@q+(9nu4+Flct8k*ul7-5VyYMbpLlbq% zphrn^l1c7~7A5!9z#xcKG8#pTF~VX}7-?g?>rEUkkUBY(0)^x$176Zv&2@?l$u*4j zn+&s(nMNl)hUU#EOT5an`Ozzb^oDM%v=Y-8K2721JRE681?Ev;$)?d1{%3V) z6x0~v8`ZW{>nPO-JB`d44tUmuc?3BDG*Z(5ntc3m9_EqGu3WjJvINOL57OLKgGqaC zKm||W5zkP6Xu`Ch469ZSrxXr>M5_bBh{!QJoVLLP&NHu(VU6l$wYo)pnZcqyL9Qks zr`mgfOQ2={zB=gk+kQ^ zj4&?ZWUlehsMZGUL8rBC0|10pvY>Xl`-8$)1>0X8_6N%R-0iiR_qTSNy}m+>dQHab z2~m>7L(URbo-0)FaG}e^Of+pENRJnQ`dqpYox>80Gho_C8YznnVL|MT1H>bB;7mB0 zmb!}v0aGu8UShDMgw&rn(j-m*hR1}}QV%rSOqW2*MUzB=j>Bvo1=8)vUz{arxj+hX zg-n56)&eNM$bh$KxVDvn$*fv4H3)NkM3Ir$`96!Cwbo`TR+(wS~a>MSzS$agqjA(pe|C3AOIxj?gs`y^{Gy;MtVXlK?k4%n!&raQCAzxW(t=6Wu(RD0NG5F;f7xO&J7CWUpv+E< zswFFNwll2;bAtFx5G=2k9C@Thkq%PRE^SnY8g2)OVoVY=L!iTa$zhNtZy^mdiO4Hl zXW7U+VaJZTZS5>RmwPaomY1P{dOr%Hg(U8FYo~eG88BLATNq<3k?h#j(Ibt95~yn% z)<4EvC^k$nqp<{_*9@2wqSvC8#sF1Fj5WGYhH>%Ek`sbF*8;29gp5VyP?aI@9DNvd z4bV?93uti^zH@Z4_C;YPy~dLu5Mu}{Km-~VUzY5x5oETy+bvb=A2hdG>W}LJcL>&a zEHhYLRQH-dEMhYVaS$G^H;OK!E zh_vQd0Z#=;Z4P7Xtm;&THZ*aSz%l7*$U&KDX9nQ&v4?~mlt1bR9W&HGqIyZb`lZ@w zcUo$u13Rbr;05f^TE&=P>uBZ1ZU(?F<4I$F9P22YVem{dQ^+1e1jb=Hk^_~h%#ew2 zve_5a^ScFxBN@qkecLoP$@`iqDNY$VW_{S=!p!feH4e(LIS3582e7U?7U5H-$u(YHNmC=SOlQKBN?4h)X~MdE@n zj23uLOTrYcwm<=8+LNN4l5czeL8}KJA)`zh`806gA|Q7aC@d2LSPW2=7BH51^;!oV z6i{7~it5M?ZWSKbiay?NQ7kK4h7F{LGi%6#Fy<{9tWOiuN zd&M~2FoT@~C6N zW*-8^!W0fA#)SB)#AX(p0C~(hm@*<7%bw>s#A@C=x^D;p_bCi!f(h@}A_ zqUOBDio;BdO9W)U53^(?7~o215o6Y6JtR2zq?)G)COGvm31i}c)R(g_TCa7L4TVt_ z;Xc}J4_fj~vUuB^e2OC>AUT$EzqyAxr_7W+II%ZM2CB2O48w_wKfuGF3rfz6sL&C$ zb?(Z*=zIlbAXzsIQt1B>w+)0V$sJl|S@XD{gRz4x*<#K#7^h&U&Sehdj^ij90;3)U zX&4OAsmnv!zO*k8nGtT#`i%^4Jc`*zmy7(ql!|h4M$uSMv(sIUX28#J`RNcMDktO#!B*94GYg zhK2d>K@lEr`;k?U!5q3u@ms{fn5PD!fWL;aHr8?LnM1UCZ6TNui_B{R4264SR$+m!6pNr2uynP36{N(S>ejsiS4O6K>Dj*|iqNaFpPdMQ(4Ym=Q>%LqNh*jy^o-N&ZL&64c^6`X`y%Idz-{IQ>;y7-TvanT$T} zTWN1IMh||ZBcMvvWKE-x=T#oCRLArtMKF8mZX<)ECPde^0$hQGIa&|;E7AiOsM;NG zu<6>y)p_0!1YIvnGJbrDBmgRX`%FTd(Vrv2d7#Wci2*{GZGm4nq0#KJ1-Ol=@aIwu z|NSsfwb}u%(NIYWPl$iN{o9u60G*&TENpk%I4P=Hv)8=a-db1vL9;h#@89FDpQyJt z)^P+^8|vn@O?B&MoA_3fO^#u&+39xg_f_rJhs|vnRx_uBVc-NS)=JKP6F@s8=Da5-_*y^jECYSTcGTX>k5i*-oCBgzPV1Fv9{Z4Zo@!hf&DUg2+lj*E-imx_HEu$ zH*Q>LAN22c$;fQHb#wFFPC-vbK%xMh_;2GnoO;_RwT_)%C`_QgcvR$6^`#2S=B0kLoF*$wel{>&ROYry-Eom3z0Of@9EgZ%dyqBI#bQylmPSQc-@OOtJP=vj+af+SeaL_wC25 z*}Zu4-OA^Nu$0299S5(0+dQ_fK->Yw)mFp!i z`#XNUiU6of@0?qx{I$G5C04~1ne)V$F?Qb|CkiDGTJm|EiX5~SyN&!5Bqd8p3FNbJ z3cryr7?)Ng9hX)lE?lXSSa@IynZE88{H7nRtlV%bUifQn#S8a2o{u-n zD_CUXVs8tV2Y^kmne$(yp!vC_e z@?*C`UFfRsy9Ej3l75ave8N9o8|jl=kx+A!B$f~wzH8SUU&m$3EqLwz;Z`K!m$>+q zk)sjbr1_Rx@ibnxUkO)e4%~`U$7iimXU(VN3W@h{*KzSH-YUNmI2y<14{pIps_eQI zZ&c=1Jk6VKg>0S+F(mQCN8m*M&x{x=J}VHzTjFV)`88*VH*MRk_)Wg{{mT1KrZEPT za7S=rDRVuW6>Wa%_SOURCES>IDLER.;3| 39952 changes to%: (VARS IDLERCOMS) (FNS \IDLERKEYACTION) previous date%: "16-May-90 18:17:31" |{PELE:MV:ENVOS}SOURCES>IDLER.;2|) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IDLERCOMS) (RPAQQ IDLERCOMS ([COMS (* ;; "Basic idling facility") (FNS IDLE IDLE.SET.OPTION IDLE.SHOW.OPTIONS IDLE.SHOW.OPTION \IDLER \IDLE.WAIT \OK.TO.IDLE? \IDLE.TIME \IDLE.OUT \IDLE.EXIT? \IDLE.PROMPT.WATCHER \IDLE.EXIT.ABORT \IDLE.PROMPTING.WINDOW \IDLE.IS.PREVIOUS \IDLE.ISMEMBER \IDLE.AUTHENTICATE \IDLERKEYACTION) (INITVARS (IDLE.PROFILE '(TIMEOUT 0)) (* ;  "so that it doesn't start idling during the loadup") (\IDLING) (CH.DEFAULT.DOMAIN) (DEFAULTREGISTRY) (IDLE.KEYACTIONTABLE)) (ADDVARS (SYSTEMINITVARS (IDLE.PROFILE ALLOWED.LOGINS NIL FORGET NIL TIMEOUT 0 DISPLAYFN IDLE.BOUNCING.BOX SAVEVM 10 AUTHENTICATE T LOGIN.TIMEOUT 30) ) (* ; "the real default") (IDLE.SUSPEND.PROCESS.NAMES MOUSE) (IDLE.RESETVARS (PUPTRACEFLG NIL) (XIPTRACEFLG NIL))) (GLOBALVARS IDLE.PROFILE \IDLING \LASTUSERACTION IDLE.RESETVARS IDLE.SUSPEND.PROCESS.NAMES CH.DEFAULT.DOMAIN DEFAULTREGISTRY \AFTERLOGINFNS SAVINGCURSOR \VMEM.INHIBIT.WRITE \IDLE.PASSWORD.SET) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (FONTCREATE 'TIMESROMAND 36)) [ADDVARS (BACKGROUNDFNS \IDLE.OUT) (BackgroundMenuCommands (Idle '(IDLE) "Enter Idle mode" (SUBITEMS ("Show Profile" '(IDLE.SHOW.OPTIONS) "Print current idle options in prompt window") ("Set Timeout" '(IDLE.SET.OPTION 'TIMEOUT) "Set how long before idling started" (SUBITEMS ("Never" (IDLE.SET.OPTION 'TIMEOUT 0) "Never spontaneously enter idle mode"))) ("Choose Display" '(IDLE.SET.OPTION 'DISPLAYFN) "Choose idle display") ("Forget" '(IDLE.SHOW.OPTION 'FORGET) "Erase password when leaving idle mode?" (SUBITEMS ("Do" '(IDLE.SET.OPTION 'FORGET T) "Erase password upon exiting idle mode") ("Don't" '(IDLE.SET.OPTION 'FORGET NIL) "Retain password through idle mode (unless someone logs in)" ))) ["Allowed Logins" '(IDLE.SHOW.OPTION 'ALLOWED.LOGINS) "Who can exit idle mode" (SUBITEMS ("Unlocked" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'UNLOCKED) "No login required to exit idle mode") ("Locked" '(IDLE.SET.OPTION 'ALLOWED.LOGINS '(T)) "Only the current user may exit idle mode") ("Any Login" '(IDLE.SET.OPTION 'ALLOWED.LOGINS '(*)) "Any user may exit, but require login") ("Group" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'ADD) "Only allow specific users and/or groups to exit" (SUBITEMS ("Include Previous User" '(IDLE.SET.OPTION 'ALLOWED.LOGINS T) "If current user exits, check old password") ("Add Member" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'ADD) "Add a group or username") ("Remove Member" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'REMOVE) "Remove a group or username"] ("Authenticate" '(IDLE.SHOW.OPTION 'AUTHENTICATE) "Authenticate user upon exiting idle mode?" (SUBITEMS ("Do" '(IDLE.SET.OPTION 'AUTHENTICATE T) "User will be authenticated upon exiting idle mode" ) ("Unix" '(IDLE.SET.OPTION 'AUTHENTICATE 'UNIX) "User will be authenticated in Unix upon exiting idle mode" ) ("NS" '(IDLE.SET.OPTION 'AUTHENTICATE 'NS) "User will be authenticated in XNS upon exiting idle mode" ) ("GV" '(IDLE.SET.OPTION 'AUTHENTICATE 'GV) "User will be authenticated in Grapevine upon exiting idle mode" ) ("Don't" '(IDLE.SET.OPTION 'AUTHENTICATE NIL) "Accept any password--no authentication check"] [VARS (BackgroundMenu) (\IDLING.OVER (CREATE.EVENT '\IDLING.OVER] (P (\DAYTIME0 \LASTUSERACTION] (COMS (* ;; "Default idle display") (FNS IDLE.BOUNCING.BOX IDLE.BITMAP) [INITVARS (IDLE.BOUNCING.BOX (BITMAPCOPY LOGOBITMAP)) (IDLE.FUNCTIONS '(("Bouncing Box" 'IDLE.BOUNCING.BOX) ("Bouncing Username" '(LAMBDA (W) (IDLE.BOUNCING.BOX W (USERNAME NIL NIL T] (GLOBALVARS IDLE.FUNCTIONS IDLE.BOUNCING.BOX)))) (* ;; "Basic idling facility") (DEFINEQ (IDLE [LAMBDA (FROMTIMEOUT) (* ; "Edited 20-Nov-87 11:22 by Snow") (COND ((NOT \IDLING) (OR (FNTYP (LISTGET IDLE.PROFILE 'DISPLAYFN)) (LISTPUT IDLE.PROFILE 'DISPLAYFN 'IDLE.BOUNCING.BOX)) (\CARET.DOWN) (SETQ \IDLING T) (ADD.PROCESS (LIST '\IDLER (KWOTE FROMTIMEOUT)) 'RESTARTABLE T 'NAME 'IDLE 'KEYACTION (\IDLERKEYACTION]) (IDLE.SET.OPTION [LAMBDA (OPTION X) (* drc%: " 3-Jan-86 11:47") (CLEARW PROMPTWINDOW) (IDLE.SHOW.OPTION OPTION "Old") (LET ((OLD.OPTION (LISTGET IDLE.PROFILE OPTION))) (LISTPUT IDLE.PROFILE OPTION (SELECTQ OPTION (DISPLAYFN (OR X (MENU (create MENU ITEMS _ IDLE.FUNCTIONS)) OLD.OPTION)) (TIMEOUT (LET [(MINS (OR X (if (FGETD 'RNUMBER) then (RNUMBER "Idle Timeout (in minutes)" NIL NIL NIL T) else (MKATOM (PROMPTFORWORD "Idle Timeout:" NIL NIL PROMPTWINDOW NIL 'TTY] (if (NULL MINS) then OLD.OPTION elseif (AND (SMALLP MINS) (GREATERP MINS 0)) then MINS else NIL))) (ALLOWED.LOGINS (SELECTQ X (UNLOCKED NIL) (T (UNION (LIST T) OLD.OPTION)) (ADD (LET [(GROUP (PROMPTFORWORD "Add to allowed login list:" NIL NIL PROMPTWINDOW NIL 'TTY] (TERPRI PROMPTWINDOW) (COND ((NULL GROUP) OLD.OPTION) ([OR (NOT (LISTGET IDLE.PROFILE 'AUTHENTICATE)) (STREQUAL GROUP "*") (STREQUAL GROUP "T") (PROGN (PRINTOUT PROMPTWINDOW "Checking..") (COND ([OR (AND CH.DEFAULT.DOMAIN (STRPOS ":" GROUP) (CH.LOOKUP.OBJECT GROUP)) (AND DEFAULTREGISTRY (LISTP (GV.READENTRY GROUP] (PRINTOUT PROMPTWINDOW "..ok" T) T) (T (EQ 'Y (RESETFORM (TTYDISPLAYSTREAM PROMPTWINDOW) (ASKUSER NIL NIL " no such name/group. Add anyway? " ] (CONS GROUP (LISTP OLD.OPTION))) (T OLD.OPTION)))) (REMOVE (AND OLD.OPTION (REMOVE (MENU (create MENU TITLE _ "Remove group " CENTERFLG _ T ITEMS _ OLD.OPTION)) OLD.OPTION))) (OR (LISTP X) OLD.OPTION))) X))) (IDLE.SHOW.OPTION OPTION "New"]) (IDLE.SHOW.OPTIONS [LAMBDA NIL (* bvm%: "16-Oct-85 00:23") (FRESHLINE PROMPTWINDOW) (for TAIL on IDLE.PROFILE by (CDDR TAIL) do (IDLE.SHOW.OPTION (CAR TAIL) NIL (COND ((CDDR TAIL) ", ") (T "."]) (IDLE.SHOW.OPTION [LAMBDA (OPTION STRING SEPR) (* bvm%: "16-Oct-85 00:23") (LET ((VALUE (LISTGET IDLE.PROFILE OPTION))) (OR SEPR (FRESHLINE PROMPTWINDOW)) (COND (STRING (printout PROMPTWINDOW STRING " "))) (OR SEPR (printout PROMPTWINDOW "Idle ")) (printout PROMPTWINDOW (SELECTQ OPTION (ALLOWED.LOGINS "Allowed Logins") (L-CASE OPTION T)) ": " (SELECTQ OPTION ((SAVEVM TIMEOUT) (COND [(AND (SMALLP VALUE) (GREATERP VALUE 0)) (CONCAT VALUE " minute" (COND ((EQ VALUE 1) "") (T "s"] (T "never"))) (ALLOWED.LOGINS (COND ((LISTP VALUE) (SUBPAIR '(T *) '("" "") VALUE)) (T "Unlocked"))) (MKSTRING VALUE))) (COND (SEPR (printout PROMPTWINDOW SEPR)) (T (TERPRI PROMPTWINDOW]) (\IDLER (LAMBDA (FROMTIMEOUT) (* ; "Edited 29-Jun-88 14:36 by drc:") (* ;; "This is the main idling loop. ") (RESETLST (RESETSAVE NIL (QUOTE (SETTOPVAL \IDLING NIL))) (PROG ((START.TIME (ALTO.TO.LISP.DATE \LASTUSERACTION)) W SAVEVM.TIMER IDLE.PROCESS NO.ERROR EXIT? INTERRUPTED.STRING IDLING.KEYACTIONS) (COND ((NOT (\OK.TO.IDLE?)) (* ; "Somebody in password prompt, better not idle") (RETURN))) (SETQ \IDLE.PASSWORD.SET) (COND ((EQ (LISTGET IDLE.PROFILE (QUOTE FORGET)) (QUOTE FIRST)) (* ;; "do things like dump cache listings and flush files to servers *before* passwords get smashed") (\USEREVENT (QUOTE BEFORESAVEVM)) (\DEVICEEVENT (QUOTE BEFORESAVEVM)) (\USEREVENT (QUOTE AFTERDOSAVEVM)) (\DEVICEEVENT (QUOTE AFTERDOSAVEVM)))) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL (NOTIFY.EVENT \IDLING.OVER))))) (for X in IDLE.SUSPEND.PROCESS.NAMES bind PROC do (* ; "Turn off things like CROCK, LAFITEMAILWATCH, SPACEWINDOW, REMINDERS") (COND ((SETQ PROC (FIND.PROCESS X)) (PROCESS.EVAL PROC (QUOTE (\IDLE.WAIT)))))) (RESETSAVE (GCGAG NIL)) (RESETSAVE \AFTERLOGINFNS NIL) (* ; "So that SETPASSWORD doesn't trigger any activity") (for X in IDLE.RESETVARS do (* ; "turn off things like pup-trace, xiptrace and the like") (RESETSAVE (SETTOPVAL (CAR X) (EVAL (CADR X))) (LIST (FUNCTION SETTOPVAL) (CAR X) (GETTOPVAL (CAR X))))) (* ; "so that mouse buttons will trigger READP") (COND ((EQ (LISTGET IDLE.PROFILE (QUOTE FORGET)) (QUOTE FIRST)) (SETQ \IDLE.PASSWORD.SET (QUOTE CLEAR)) (SETPASSWORD NIL (USERNAME NIL NIL T) ""))) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (* ;; "Note that IDLE has set up our KEYACTION table (in the add.process) to ignore interrupts and make mouse clicks trigger readp.") (RESETSAVE (CHANGENAME (QUOTE \LOGIN.READ) (QUOTE PROVIDE.PROMPTING.WINDOW) (QUOTE \IDLE.PROMPTING.WINDOW)) (QUOTE (CHANGENAME \LOGIN.READ \IDLE.PROMPTING.WINDOW PROVIDE.PROMPTING.WINDOW))) (COND ((OR (AND FROMTIMEOUT (NOT (LET ((TIMEOUT (LISTGET IDLE.PROFILE (QUOTE TIMEOUT)))) (AND (SMALLP TIMEOUT) (\SECONDSCLOCKGREATERP \LASTUSERACTION (TIMES TIMEOUT 60)))))) (NOT (\OK.TO.IDLE?))) (* ;; "Check again if it's ok, since somebody could have fallen into a password prompter between then and now. Anybody who does after this is ok, because the CHANGENAME above is now in effect. Also check timeout again, in case there was a user interaction during the BEFORESAVEVM stuff") (RETURN))) (CLEARW PROMPTWINDOW) (SETQ W (CREATEW WHOLESCREEN NIL 0 T)) (RESETSAVE NIL (LIST (FUNCTION CLOSEW) W)) (RESETSAVE (CURSOR (CURSORCREATE (BITMAPCREATE 0 0)))) (CASE (MACHINETYPE) (DORADO (* ;; "this is the only way we can get the background border to be black on a dorado") (RESETSAVE (VIDEOCOLOR T)))) (IF (VIDEOCOLOR) THEN (* ;; "make sure border is black") (RESETSAVE (CHANGEBACKGROUNDBORDER WHITESHADE)) (OPENW W) ELSE (DSPOPERATION (QUOTE ERASE) W) (DSPTEXTURE BLACKSHADE W) (RESETSAVE (CHANGEBACKGROUNDBORDER BLACKSHADE)) (CLEARW W)) (COND ((AND (SMALLP (LISTGET IDLE.PROFILE (QUOTE SAVEVM))) (\FLUSHVMOK? (QUOTE SAVEVM) T)) (* ; "Set up timer to go off when a SAVEVM should be done. Don't do it if it's not safe") (SETQ SAVEVM.TIMER (SETUPTIMER (TIMES (LISTGET IDLE.PROFILE (QUOTE SAVEVM)) 60000))))) (SETQ IDLE.PROCESS (ADD.PROCESS (CONS (LISTGET IDLE.PROFILE (QUOTE DISPLAYFN)) (CONS W (LISTGET IDLE.PROFILE (QUOTE DISPLAY.DATA)))) (QUOTE NAME) (QUOTE IDLE.DISPLAY))) (RESETSAVE NIL (LIST (FUNCTION DEL.PROCESS) IDLE.PROCESS)) (BLOCK) (* ; "Let the demo get started first") WAIT.FOR.CHAR (COND ((NOT (READP T T)) (BLOCK 250) (\DIRTYBACKGROUND) (COND ((\SAVEVMBACKGROUND) (SETQ SAVEVM.TIMER))) (COND ((OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT))) (AND (PROCESSP IDLE.PROCESS) (SUSPEND.PROCESS IDLE.PROCESS)) (CLEARW PROMPTWINDOW) (PRINTOUT PROMPTWINDOW (USERNAME NIL NIL T) " Idle " (\IDLE.TIME START.TIME) T) (until (NOT (OR (KEYDOWNP (QUOTE LSHIFT)) (KEYDOWNP (QUOTE RSHIFT)))) do (BLOCK 250)) (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS)))) (COND ((AND SAVEVM.TIMER (NOT \VMEM.INHIBIT.WRITE) (TIMEREXPIRED? SAVEVM.TIMER)) (COND ((\FLUSHVMOK? (QUOTE SAVEVM) T) (* ; "if SAVEVM not allowed forget it forever") (RESETFORM (CURSOR SAVINGCURSOR) (NLSETQ (SAVEVM))))) (SETQ SAVEVM.TIMER))) (TTY.PROCESS (THIS.PROCESS)) (* ; "Keep us the tty process, even if someone else tries for it") (GO WAIT.FOR.CHAR))) (COND ((PROCESSP IDLE.PROCESS) (SUSPEND.PROCESS IDLE.PROCESS))) (SETQ NO.ERROR (NLSETQ (SETQ EXIT? (\IDLE.EXIT?)))) (COND ((NOT NO.ERROR) (SETQ INTERRUPTED.STRING "ERROR while checking Allowed Logins") (SETPASSWORD NIL (USERNAME NIL NIL T) "") (SETQ \IDLE.PASSWORD.SET (QUOTE CLEAR))) ((NOT EXIT?) (SETQ INTERRUPTED.STRING (CONCAT "Someone tried to use the machine at " (DATE (DATEFORMAT NO.DATE)))) (AND IDLE.PROCESS (WAKE.PROCESS IDLE.PROCESS)) (CLEARBUF T) (GO WAIT.FOR.CHAR))) EXIT (CLOSEW W) (FRESHLINE PROMPTWINDOW) (AND INTERRUPTED.STRING (PRINTOUT PROMPTWINDOW INTERRUPTED.STRING T)) (PRINTOUT PROMPTWINDOW "Idle time " (\IDLE.TIME START.TIME)))) (COND (\IDLE.PASSWORD.SET (* ; "Notify anyone who cares about login change, since we suppressed it earlier") (MAPC \AFTERLOGINFNS (FUNCTION APPLY*))))) ) (\IDLE.WAIT [LAMBDA NIL (AWAIT.EVENT \IDLING.OVER) (while \IDLING do (BLOCK 500]) (\OK.TO.IDLE? [LAMBDA NIL (* bvm%: " 4-Dec-85 15:05") (RESETLST (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK T T]) (\IDLE.TIME [LAMBDA (START.TIME) (* bvm%: "15-Oct-85 23:35") (LET [(GONE (IDIFFERENCE (IDATE) START.TIME)) (ONEDAY (CONSTANT (IDIFFERENCE (IDATE "2-Jan-80 00:00:00") (IDATE "1-Jan-80 00:00:00"] (COND ((ILESSP GONE ONEDAY) (* ; "Express in hours:min:sec") (GDATE (IPLUS (IDATE "1-Jan-80 00:00:00") GONE) (DATEFORMAT NO.DATE))) (T (CONCAT (SETQ GONE (QUOTIENT GONE ONEDAY)) " day" (COND ((GREATERP GONE 1) "s.") (T "."]) (\IDLE.OUT [LAMBDA NIL (* bvm%: "16-Sep-85 18:34") (AND (NOT \IDLING) (LET [(TIMEOUT (LISTGET IDLE.PROFILE 'TIMEOUT] (AND (SMALLP TIMEOUT) (GREATERP TIMEOUT 0) (\SECONDSCLOCKGREATERP \LASTUSERACTION (TIMES TIMEOUT 60)) (IDLE T]) (\IDLE.EXIT? (LAMBDA NIL (* ; "Edited 22-Nov-88 15:25 by drc:") (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW)) (CLEARBUF T) (PROG ((GROUP (LISTGET IDLE.PROFILE (QUOTE ALLOWED.LOGINS))) (AUTHTYPE (LISTGET IDLE.PROFILE (QUOTE AUTHENTICATE))) (TIMEOUT (LISTGET IDLE.PROFILE (QUOTE LOGIN.TIMEOUT))) (NAME (USERNAME NIL NIL T)) PWD WATCHER) (COND ((NLISTP GROUP) (* ; "no login check at all") (COND ((LISTGET IDLE.PROFILE (QUOTE FORGET)) (SETPASSWORD NIL NAME ""))) (RETURN T))) (COND ((EQ 0 (NCHARS NAME)) (* ; "Not logged in, so don't complain about anything") (RETURN T))) (OBTAIN.MONITORLOCK \GETPASSWORD.LOCK NIL T) (* ; "Lock out anyone else trying to prompt for a password") (CLEARW PROMPTWINDOW) (* ; "prompt for password, maybe new username") (SETQ PWD (COND ((AND (EQUAL GROUP (QUOTE (T))) NAME) (* ; "Only previous user allowed to login") (PROMPTFORWORD (CONCAT NAME " password:") NIL NIL NIL (QUOTE *) TIMEOUT)) (T (if TIMEOUT then (* ; "spawn process to watch for login. Done this way rather than timeout in \LOGIN.READ because we want to blow away timed-out password prompt, too.") (RESETSAVE NIL (LIST (QUOTE DEL.PROCESS) (SETQ WATCHER (ADD.PROCESS (BQUOTE (\IDLE.PROMPT.WATCHER (QUOTE (\, (THIS.PROCESS))) (\, TIMEOUT)))))))) (PROG1 (CDR (SETQ NAME (CAR (NLSETQ (\LOGIN.READ NIL NAME NIL NIL (QUOTE NS)))))) (SETQ NAME (MKSTRING (CAR NAME))) (if WATCHER then (DEL.PROCESS WATCHER)))))) (* ; "decide whether NAME and PWD are in GROUP") (RETURN (COND ((NULL PWD) NIL) ((AND (OR (MEMB T GROUP) (MEMB (QUOTE *) GROUP)) (\IDLE.IS.PREVIOUS NAME PWD (EQUAL GROUP (QUOTE (T))))) (* ;; "Previous user is allowed to login. Also, if only allowed login is old user, but old password is unknown, allow it") T) ((\IDLE.ISMEMBER GROUP NAME PWD) (COND ((OR (NULL AUTHTYPE) (\IDLE.AUTHENTICATE NAME PWD AUTHTYPE (NOT (MEMB T GROUP)) PROMPTWINDOW)) (SETPASSWORD NIL NAME PWD) (SETQ \IDLE.PASSWORD.SET T) T) (T (DISMISS 5000) (* ; "Let the error message be visible") NIL))) (T (PRINTOUT PROMPTWINDOW "login incorrect" T) (DISMISS 5000) (* ; "Let the error message be visible") NIL)))))) ) (\IDLE.PROMPT.WATCHER [LAMBDA (PROC TIMEOUT) (* ; "Edited 3-Apr-87 13:56 by bvm:") (* ;; "Aborts proc if it goes for longer than TIMEOUT (in seconds) with no user action") (do [DISMISS (TIMES 1000 (IMAX 1 (- TIMEOUT (- (\DAYTIME0 (create FIXP)) \LASTUSERACTION] (* ; "Dismiss until expected timeout") (if (\SECONDSCLOCKGREATERP \LASTUSERACTION TIMEOUT) then (PROCESS.EVAL PROC '(\IDLE.EXIT.ABORT)) (RETURN]) (\IDLE.EXIT.ABORT [LAMBDA NIL (* ; "Edited 3-Apr-87 13:37 by bvm:") (* ;; "Abort process if still sitting under login reader") (if (RELSTK (STKPOS '\LOGIN.READ)) then (ERROR!]) (\IDLE.PROMPTING.WINDOW [LAMBDA (TITLE) (* bvm%: " 5-Nov-85 23:10") (* ;;; "Replaces PROVIDE.PROMPTING.WINDOW in \LOGIN.READ while idle is on") (RESETSAVE (INTERRUPTCHAR 5 'ERROR)) (* ; "Allow ^E to abort prompt") (COND ((NEQ (PROCESSPROP (THIS.PROCESS) 'NAME) 'IDLE) (OR \IDLE.PASSWORD.SET (SETQ \IDLE.PASSWORD.SET T)) (RESETSAVE (TTYDISPLAYSTREAM PROMPTWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (RESETSAVE (SUSPEND.PROCESS 'IDLE) '(WAKE.PROCESS IDLE)) (RESETSAVE (SUSPEND.PROCESS 'IDLE.DISPLAY) '(WAKE.PROCESS IDLE.DISPLAY]) (\IDLE.IS.PREVIOUS [LAMBDA (NAME PWD NULLOK) (* ; "Edited 26-Jan-89 22:38 by NSato.fx") (* ;;; "if the new name is the same as the old name, and the old global password wasn't forgotten, then allow the old password") (AND (NEQ \IDLE.PASSWORD.SET 'CLEAR) (LET* [(PREVIOUS.USERNAME (USERNAME NIL NIL T)) (PASSWORDADDR (EMPASSWORDLOC)) (OLDPWD (if (NEQ PASSWORDADDR 0) then (GetBcplString (EMPOINTER PASSWORDADDR] (if (ZEROP (NCHARS OLDPWD)) then (SETQ OLDPWD)) (if (AND (EQ (MACHINETYPE) 'MAIKO) (NOT OLDPWD)) then (* ;; "when Maiko is first booted the password is empty but we can check w/ UNIX to see if this is the same user s.t. ") (* ;;  "UNIX only looks at first 8 chars of username, so ignore any extra chars typed.") (if (> (NCHARS PREVIOUS.USERNAME) 8) then (SETQ PREVIOUS.USERNAME (SUBSTRING PREVIOUS.USERNAME 1 8))) (if (> (NCHARS NAME) 8) then (SETQ NAME (SUBSTRING NAME 1 8))) (AND (STRING-EQUAL PREVIOUS.USERNAME NAME) (SUBRCALL CHECKBCPLPASSWORD NAME PWD)) else (AND (STRING-EQUAL PREVIOUS.USERNAME NAME) (COND (OLDPWD (STRING-EQUAL OLDPWD PWD)) (T (* ; "there was no password") NULLOK]) (\IDLE.ISMEMBER [LAMBDA (GROUP NAME PWD) (* ; "Edited 26-Dec-86 20:31 by cutting") (OR [for X in GROUP thereis (COND ((EQ X T) (STRING-EQUAL NAME (USERNAME))) ((STRPOS "*" X) T) ((STRPOS ":" X) (EQUAL.CH.NAMES (PARSE.NSNAME NAME) (PARSE.NSNAME X))) (T (STRING-EQUAL X (COND ((OR (NULL DEFAULTREGISTRY) (STRPOS "." NAME) (NOT (STRPOS "." X))) NAME) (T (CONCAT NAME "." DEFAULTREGISTRY] (for X in GROUP thereis (COND ((EQ X T) NIL) ((AND DEFAULTREGISTRY (STRPOS "^." X)) (PRINTOUT T "..." X "?...") (SELECTQ (GV.ISMEMBERCLOSURE X (\CHECKNAME NAME)) (T (PRINTOUT T "ok.") T) (NIL (PRINTOUT T "no.") NIL) (BadRName (PRINTOUT T "not a GV group") NIL) T)) ((AND CH.DEFAULT.DOMAIN (STRPOS ":" X)) (PRINTOUT T "..." X "?...") (SELECTQ (CH.ISMEMBER (PARSE.NSNAME X) 'MEMBERS 'MEMBERS (CH.LOOKUP.OBJECT NAME)) (T (PRINTOUT T "ok.") T) (NIL (PRINTOUT T "no.") NIL) (ERROR (PRINTOUT T "not an NS group") NIL) T]) (\IDLE.AUTHENTICATE (LAMBDA (NAME PWD TYPE IFALLDOWN OUTPUT) (* ; "Edited 10-Jun-88 02:30 by drc:") (LET ((NS (AND (NEQ TYPE (QUOTE GV)) (NEQ TYPE (QUOTE UNIX)) CH.DEFAULT.DOMAIN)) (GV (AND (NEQ TYPE (QUOTE NS)) (NEQ TYPE (QUOTE UNIX)) DEFAULTREGISTRY)) (UNIX (AND (NEQ TYPE (QUOTE NS)) (NEQ TYPE (QUOTE GV)) (EQ (MACHINETYPE) (QUOTE MAIKO)))) CODE) (printout OUTPUT T "Authenticating " NAME " ... ") (COND ((EQ TYPE T) (* ;; "use heuristics to determine authentication type") (COND ((STRPOS ":" NAME) (* ; "probably wanted NS login") (SETQ GV) (SETQ UNIX) (SETQ NS T)) ((AND (STRPOS "." NAME) DEFAULTREGISTRY) (* ; "probably wanted GV login") (SETQ UNIX) (SETQ NS) (SETQ GV T))))) (OR (AND UNIX (EQ (MACHINETYPE) (QUOTE MAIKO)) (COND ((SUBRCALL CHECKBCPLPASSWORD NAME PWD) (SETQ CODE T)) (T (SETQ CODE (QUOTE Bad% login)) NIL))) (AND NS (EQ T (SETQ CODE (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS (CONS NAME (\ENCRYPT.PWD (CONCAT PWD)))))))) (AND GV (SETQ CODE (GV.AUTHENTICATE NAME (\ENCRYPT.PWD (CONCAT PWD)))))) (SELECTQ CODE (AllDown (printout OUTPUT "All authentication servers down" T) IFALLDOWN) ((T NIL) (printout OUTPUT "ok.") T) ((SimpleKeyDoesNotExist CredentialsInvalid BadRName BadPassword Bad% login) (printout OUTPUT CODE) NIL) (PROGN (printout OUTPUT T "Odd response from authenticator: " CODE) T)))) ) (\IDLERKEYACTION [LAMBDA NIL (* ; "Edited 23-Mar-92 13:20 by jds") (* ;; "Constructs a KEYACTION table for the IDLER process, by taking the (machine-dependent) original table and smashing the mouse buttons so that they transmit characters that cause the idler to wake up, and disabling the interrupts") (LET ((TABLE (KEYACTIONTABLE IDLE.KEYACTIONTABLE))) (* ;; "Construct a new one each time, on the theory that this will get the most recent notion of the original keyactions on the machine most recently migrated to.") (KEYACTION 'LEFT '((18 18) 18 18) TABLE) (KEYACTION 'MIDDLE '((18 18) 18 18) TABLE) (KEYACTION 'RIGHT '((18 18) 18 18) TABLE) (replace (KEYACTION INTERRUPTLIST) of TABLE with NIL) (* ; "Turn off the interrupts") TABLE]) ) (RPAQ? IDLE.PROFILE '(TIMEOUT 0)) (RPAQ? \IDLING ) (RPAQ? CH.DEFAULT.DOMAIN ) (RPAQ? DEFAULTREGISTRY ) (RPAQ? IDLE.KEYACTIONTABLE ) (ADDTOVAR SYSTEMINITVARS (IDLE.PROFILE ALLOWED.LOGINS NIL FORGET NIL TIMEOUT 0 DISPLAYFN IDLE.BOUNCING.BOX SAVEVM 10 AUTHENTICATE T LOGIN.TIMEOUT 30)) (ADDTOVAR IDLE.SUSPEND.PROCESS.NAMES MOUSE) (ADDTOVAR IDLE.RESETVARS (PUPTRACEFLG NIL) (XIPTRACEFLG NIL)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IDLE.PROFILE \IDLING \LASTUSERACTION IDLE.RESETVARS IDLE.SUSPEND.PROCESS.NAMES CH.DEFAULT.DOMAIN DEFAULTREGISTRY \AFTERLOGINFNS SAVINGCURSOR \VMEM.INHIBIT.WRITE \IDLE.PASSWORD.SET) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (FONTCREATE 'TIMESROMAND 36) (ADDTOVAR BACKGROUNDFNS \IDLE.OUT) (ADDTOVAR BackgroundMenuCommands [Idle '(IDLE) "Enter Idle mode" (SUBITEMS ("Show Profile" '(IDLE.SHOW.OPTIONS) "Print current idle options in prompt window") ("Set Timeout" '(IDLE.SET.OPTION 'TIMEOUT) "Set how long before idling started" (SUBITEMS ("Never" (IDLE.SET.OPTION 'TIMEOUT 0) "Never spontaneously enter idle mode"))) ("Choose Display" '(IDLE.SET.OPTION 'DISPLAYFN) "Choose idle display") ("Forget" '(IDLE.SHOW.OPTION 'FORGET) "Erase password when leaving idle mode?" (SUBITEMS ("Do" '(IDLE.SET.OPTION 'FORGET T) "Erase password upon exiting idle mode") ("Don't" '(IDLE.SET.OPTION 'FORGET NIL) "Retain password through idle mode (unless someone logs in)" ))) ["Allowed Logins" '(IDLE.SHOW.OPTION 'ALLOWED.LOGINS) "Who can exit idle mode" (SUBITEMS ("Unlocked" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'UNLOCKED) "No login required to exit idle mode") ("Locked" '(IDLE.SET.OPTION 'ALLOWED.LOGINS '(T)) "Only the current user may exit idle mode") ("Any Login" '(IDLE.SET.OPTION 'ALLOWED.LOGINS '(*)) "Any user may exit, but require login") ("Group" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'ADD) "Only allow specific users and/or groups to exit" (SUBITEMS ("Include Previous User" '(IDLE.SET.OPTION 'ALLOWED.LOGINS T) "If current user exits, check old password") ("Add Member" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'ADD) "Add a group or username") ("Remove Member" '(IDLE.SET.OPTION 'ALLOWED.LOGINS 'REMOVE) "Remove a group or username"] ("Authenticate" '(IDLE.SHOW.OPTION 'AUTHENTICATE) "Authenticate user upon exiting idle mode?" (SUBITEMS ("Do" '(IDLE.SET.OPTION 'AUTHENTICATE T) "User will be authenticated upon exiting idle mode") ("Unix" '(IDLE.SET.OPTION 'AUTHENTICATE 'UNIX) "User will be authenticated in Unix upon exiting idle mode" ) ("NS" '(IDLE.SET.OPTION 'AUTHENTICATE 'NS) "User will be authenticated in XNS upon exiting idle mode" ) ("GV" '(IDLE.SET.OPTION 'AUTHENTICATE 'GV) "User will be authenticated in Grapevine upon exiting idle mode" ) ("Don't" '(IDLE.SET.OPTION 'AUTHENTICATE NIL) "Accept any password--no authentication check"]) (RPAQQ BackgroundMenu NIL) (RPAQ \IDLING.OVER (CREATE.EVENT '\IDLING.OVER)) (\DAYTIME0 \LASTUSERACTION) ) (* ;; "Default idle display") (DEFINEQ (IDLE.BOUNCING.BOX [LAMBDA (WINDOW BOX WAIT) (* ; "Edited 3-Sep-87 18:55 by jds") (* ;; "Bounce a window around the screen.") (OR WAIT (SETQ WAIT 1000)) (OR BOX (SETQ BOX IDLE.BOUNCING.BOX)) (RESETLST (LET ((MAXX (WINDOWPROP WINDOW 'WIDTH)) (MAXY (WINDOWPROP WINDOW 'HEIGHT)) ORIGBOX X Y BITMAP) [for TAIL on [SETQ BOX (COND ((LISTP BOX) (* ; "don't want to trash user's box") (COPY BOX)) (T (LIST BOX] unless (WINDOWP (CAR TAIL)) do (* ; "Precompute everything but windows") (RPLACA TAIL (IDLE.BITMAP NIL (CAR TAIL] (SETQ ORIGBOX BOX) (while T do (SETQ BITMAP (IDLE.BITMAP BITMAP (CAR BOX))) (SETQ BOX (OR (CDR BOX) ORIGBOX)) (* ; "rotate it") [SETQ X (RAND (IDIFFERENCE MAXX (BITMAPWIDTH BITMAP] [SETQ Y (RAND (IDIFFERENCE MAXY (BITMAPHEIGHT BITMAP] (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT) (BLOCK WAIT) (BITBLT BITMAP 0 0 WINDOW X Y NIL NIL NIL 'INVERT]) (IDLE.BITMAP [LAMBDA (BITMAP BOX) (* lmm "18-Jan-86 03:01") (COND ((BITMAPP BOX) BOX) ((WINDOWP BOX) (LET* ((REGION (WINDOWPROP BOX 'REGION)) (WIDTH (fetch (REGION WIDTH) of REGION)) (HEIGHT (fetch (REGION HEIGHT) of REGION))) (OR (AND (BITMAPP BITMAP) (EQ (BITMAPWIDTH BITMAP) WIDTH) (EQ (BITMAPHEIGHT BITMAP) HEIGHT)) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT))) (TOTOPW BOX) (BITBLT (SCREENBITMAP) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) BITMAP) BITMAP)) [(LISTP BOX) (OR (BITMAPP (CAR BOX)) (CAR (RPLACA BOX (IDLE.BITMAP NIL (CAR BOX] (T (LET ((FONT (OR (FONTCREATE 'TIMESROMAND 36 NIL NIL NIL T) (PROGN (* ;  "Shouldn't happen unless somebody flushed TIMESROMAND 36 -- don't want to break") (FONTCREATE 'HELVETICA 12 NIL NIL NIL T)) DEFAULTFONT)) DSP) (COND ((NOT (AND (OR (STRINGP BOX) (LITATOM BOX)) (NEQ (NCHARS BOX) 0))) (SETQ BOX "Xerox Lisp"))) (SETQ BITMAP (BITMAPCREATE (STRINGWIDTH BOX FONT) (FONTHEIGHT FONT))) (SETQ DSP (DSPCREATE BITMAP)) (DSPFONT FONT DSP) (MOVETO 0 (DIFFERENCE (FONTHEIGHT FONT) (FONTASCENT FONT)) DSP) (PRIN3 BOX DSP) BITMAP]) ) (RPAQ? IDLE.BOUNCING.BOX (BITMAPCOPY LOGOBITMAP)) (RPAQ? IDLE.FUNCTIONS '[("Bouncing Box" 'IDLE.BOUNCING.BOX) ("Bouncing Username" '(LAMBDA (W) (IDLE.BOUNCING.BOX W (USERNAME NIL NIL T]) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS IDLE.FUNCTIONS IDLE.BOUNCING.BOX) ) (PUTPROPS IDLER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7561 30612 (IDLE 7571 . 8016) (IDLE.SET.OPTION 8018 . 11322) (IDLE.SHOW.OPTIONS 11324 . 11892) (IDLE.SHOW.OPTION 11894 . 13350) (\IDLER 13352 . 18468) (\IDLE.WAIT 18470 . 18573) ( \OK.TO.IDLE? 18575 . 18747) (\IDLE.TIME 18749 . 19535) (\IDLE.OUT 19537 . 19914) (\IDLE.EXIT? 19916 . 22009) (\IDLE.PROMPT.WATCHER 22011 . 22673) (\IDLE.EXIT.ABORT 22675 . 22959) (\IDLE.PROMPTING.WINDOW 22961 . 23700) (\IDLE.IS.PREVIOUS 23702 . 25594) (\IDLE.ISMEMBER 25596 . 28199) (\IDLE.AUTHENTICATE 28201 . 29526) (\IDLERKEYACTION 29528 . 30610)) (35906 39471 (IDLE.BOUNCING.BOX 35916 . 37472) ( IDLE.BITMAP 37474 . 39469))))) STOP \ No newline at end of file diff --git a/sources/IL-ERROR-STUFF b/sources/IL-ERROR-STUFF new file mode 100644 index 00000000..1e640ee7 --- /dev/null +++ b/sources/IL-ERROR-STUFF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 18:18:52" |{DSK}local>lde>lispcore>sources>IL-ERROR-STUFF.;2| 12984 |changes| |to:| (VARS IL-ERROR-STUFFCOMS) |previous| |date:| " 2-Mar-88 16:39:33" |{DSK}local>lde>lispcore>sources>IL-ERROR-STUFF.;1| ) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT IL-ERROR-STUFFCOMS) (RPAQQ IL-ERROR-STUFFCOMS ((FNS HELP SHOULDNT ERROR ERRORX INTERRUPT FAULTEVAL FAULTAPPLY OLDFAULT1 ERRORMESS ERRORMESS1 SMARTARGLIST \\SIMPLIFY.CL.ARGLIST) (INITVARS (HELPDEPTH 7) (BREAKDELIMITER " ") (HELPTIME 1000) (HELPCLOCK) (NLSETQGAG T) (*MACROEXPAND-HOOK* 'CL:FUNCALL) (COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO))) (* |;;| "for backward compatibility. Used currently by window mouse handler") (VARS (NBREAKS 0)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA ERRORX))))) (DEFINEQ (help (lambda (mess1 mess2) (* \; "Edited 5-Feb-88 14:38 by amd") "Used to signify 'I don't know what I should do'" (conditions:invoke-debugger (make-condition 'simple-condition :format-string "Help!~@{~@[ ~A~]~}" :format-arguments (list mess1 mess2))))) (shouldnt (lambda (mess) (* \; "Edited 9-Mar-87 11:41 by jrb:") (help "Shouldn't happen:" mess))) (error (lambda (mess1 mess2 nobreak) (* \; "Edited 18-Jan-88 19:05 by amd") (declare (globalvars nlsetqgag)) (cond ((and nobreak (neq helpflag 'break!)) (* \; "An ERROR! cum message.") (signal (errm-to-condition 17 (cons mess1 mess2))) (errormess1 mess1 mess2) (error!)) (t (seterrorn 17 (cons mess1 mess2)) (errorx *last-condition*))))) (errorx (cl:lambda (&optional erxm) (* \; "Edited 7-Apr-87 18:12 by amd") (and erxm (not (typep erxm (quote condition))) (seterrorn (car erxm) (cadr erxm))) (resetlst (let ((errorpos (find-debugger-entry-frame (quote errorx) t))) (declare (cl:special errorpos)) (resetsave nil (list (quote relstk) errorpos)) (proceed-case (cl:error *last-condition*) (proceed (condition) :report "Retry execution" (envapply (stkname errorpos) (stkargs errorpos) (stknth 1 errorpos errorpos) errorpos t t)))))) ) (interrupt (lambda (intfn) (* \; "Edited 24-Nov-86 19:16 by amd") (debugger :condition (make-condition (quote si::interrupt) :function intfn))) ) (faulteval (lambda (faultx) (declare (localvars . t)) (* \; "Edited 12-Mar-87 09:56 by jds") (prog (tem tem2) (cond ((listp faultx) (cond ((litatom (setq tem (car faultx))) (cond ((and (setq tem2 (getmacroprop tem compilermacroprops)) (not (equal faultx (setq tem2 (macroexpansion faultx tem2))))) (cond (clisparray (puthash faultx (or (listp tem2) (list (quote progn) tem2)) clisparray))) (return (\\eval tem2))) ((setq tem2 (get tem (quote macro-fn))) (return (\\eval (cl:funcall *macroexpand-hook* tem2 faultx nil)))) (t (setq tem (getd (car faultx))))))) (cond ((and (listp tem) (fmemb (car tem) lambdasplst)) (return (\\evalformaslambda faultx)))))) (return (cond ((and dwimflg (getd (quote newfault1))) (newfault1 faultx)) (t (oldfault1 faultx)))))) ) (faultapply (lambda (faultfn faultargs) (* \; "Edited 24-Feb-87 14:26 by amd") (cond ((ccodep faultfn) (* |;;| " hack to handle case where microcode doesn't know how to FUNCALL a CCODEP") (spreadapply (quote \\interpreter-dummy) (uninterruptably (putd (quote \\interpreter-dummy) faultfn t) faultargs))) (t (prog ((def (cond ((cl:symbolp faultfn) (getd faultfn)) (t faultfn))) %lexical-environment%) retry (cond ((typep def (quote closure)) (* \; "an interpreted closure ") (setq %lexical-environment% (closure-environment def)) (setq def (closure-function def)) (go retry))) (return (prog (tran tranfn) (or (and (listp def) (fmemb (car def) lambdasplst)) (go out)) (cond ((or (setq tran (gethash def clisparray)) (and (setq tranfn (car (cdr (assoc (car def) lambdatranfns)))) (listp (setq tran (cl:funcall tranfn def))) (progn (and clisparray (puthash def tran clisparray)) t))) (* |;;| "either in CLISPARRAY or translated by lambda-tran") (setq def tran)) (%lexical-environment% (* |;;| "found the environment")) (t (go out))) (return (apply def faultargs)) out (return (cond ((and dwimflg (getd (quote newfault1))) (newfault1 faultfn faultargs t)) (t (oldfault1 faultfn faultargs t)))))))))) ) (oldfault1 (lambda (faultx faultargs faultapplyflg) (* |lmm| " 6-Nov-86 02:10") (cl:cerror "Re-execute" (cond (faultapplyflg (make-condition (quote undefined-function-in-apply) :name faultx :arguments faultargs)) ((nlistp faultx) (make-condition (quote unbound-variable) :name faultx)) (t (make-condition (quote undefined-function) :name (car faultx))))) (cond (faultapplyflg (cl:apply faultx faultargs)) (t (eval faultx)))) ) (errormess (lambda (u) (* \; "Edited 24-Nov-86 13:46 by amd") (* |;;| "Replaces ERRORM.") (* |;;| "merged FAULT2 printing in, driven off of extra information on ERRORN - rrb 7/83") (let ((condition (cond ((null u) *last-condition*) ((typep u (quote condition)) u) (t (errm-to-condition (car u) (cadr u)))))) (cond ((and lispxhistory (not (typep condition (quote storage-condition)))) (lispxput (quote *error*) (cl:type-of condition)))) (* "Used to be:" (cond (lispxprintflg (prog ((extrames (caddr u))) (lispxterpri t) (lispxprin1 (errorstring (car u)) t) (lispxterpri t) (lispxprin2 (cadr u) t) (cond ((listp extrames) (* |;;| "in top level unbound atoms this is the litatom NORMAL for which nothing should print.") (lispxprin1 (quote " {in ") t) (lispxprin2 (car extrames) t t) (lispxprin1 (quote "}") t) (cond ((cdr extrames) (lispxprin1 (quote " in ") t) (lispxprin2 (cdr extrames) t t))))) (lispxterpri t))) (t (errorm u)))) (cl:princ condition *error-output*))) ) (errormess1 (lambda (mess1 mess2 mess3) (* \; "Edited 2-Mar-88 16:36 by amd") (* |;;| "Prints messages for help and error") (prog (badguy message) (cond ((and (null mess1) (null mess2)) (print mess3 *standard-output* t) (return))) (prin1 mess1 *standard-output*) (cond ((or (atom mess1) (stringp mess2)) (spaces 1 *standard-output*)) (t (terpri *standard-output*))) (cond ((stringp mess2) (prin1 mess2 *standard-output*) (terpri *standard-output*)) (t (print mess2 *standard-output* t)))))) (smartarglist (lambda (fn explainflg tail) (* \; "Edited 15-Jan-88 18:34 by bvm:") (* |;;| "Provide the argument list for the function named FN. FN may also be a macro, in which case its arg list is fake, but returned anyhow.") (* |;;| "FN can also be the actual (LAMBDA --) form.") (prog (tem def otherdef) (cond ((not (litatom fn)) (* \; "Got a lambda form to return the arglist for") (return (cond ((and explainflg (listp fn) (eq (car fn) (quote cl:lambda))) (* \; "We're in EXPLAIN mode, and it was a common lisp function, so hack up the CL arg list") (\\simplify.cl.arglist (cadr fn))) (t (* \; "Otherwise, just return the conventional arg list") (arglist fn)))))) retry (cond ((setq tem (get fn (quote broken))) (* |;;| "It's a broken function, so get the REAL function's arg list & return it:") (return (smartarglist tem explainflg))) ((setq tem (getlis fn (quote (argnames)))) (* |;;| "gives user an override. Also provides a way of supplying args for nospread fns, whose Interlisp \"arglist\" is uninteresting, or whose Common Lisp arglist would otherwise vanish upon being compiled by the Interlisp compiler. We use GETLIS rather than GET, so that user can force the arglist to appear to be NIL, even if it isn't really.") (* |;;| "Arg names are used for two purposes: explaining, as with ?=, and breaking/advising. For nospread functions, want the latter to be a legitimate arglist. The format used for this is (NIL explainForm . validForm). Note that this alternative form is unambiguous, since NIL can never be an argument name") (return (cond ((or (nlistp (setq tem (cadr tem))) (not (null (car tem)))) tem) (explainflg (cadr tem)) (t (cddr tem))))) ((exprp (setq def (or (get fn (quote advised)) (getd fn) (get fn (quote expr))))) (* \; "Have an interpreted def lying around") (selectq (car (listp def)) ((nlambda lambda) (* \; "Nice Interlisp forms--return args directly") (return (cadr def))) (cl:lambda (* \; "Can handle these if explaining, but first simplify") (cl:when explainflg (return (\\simplify.cl.arglist (cadr def))))) nil)) ((and explainflg (setq otherdef (getdef fn (quote functions) (quote current) (quote (noerror nocopy)))) (selectq (car otherdef) ((defmacro cl:defun) t) ((defdefiner defcommand) (|pop| otherdef)) nil)) (* |;;| "The FN (or macro) has an in-core source definition. Gather the arg list from that, as most authoritative:") (return (\\simplify.cl.arglist (cl:third (remove-comments otherdef)))))) (cond ((and (or def (setq def (get fn (quote code)))) (or (exprp def) (ccodep def))) (* |;;| "The function has a definition in force, or there's a back-up compiled or source definition that's worth consulting.") (cond ((or (not explainflg) (neq (argtype def) 3)) (* \; "If EXPLAINFLG is true and we have an NLAMBDA*, then there might be a macro with a more interesting arg list--hold off.") (return (arglist def explainflg))) ((and (ccodep def) (listp (setq tem (arglist def explainflg)))) (* \; "Had an interesting stored arglist.") (return tem))))) (return (cond ((and explainflg (setq tem (getmacroprop fn compilermacroprops))) (* \; "If we're explaining, then we might be able to get an interesting arg list out of a macro") (selectq (car (listp tem)) ((lambda nlambda openlambda) (* \; "These have conventional args in second position") (cadr tem)) (= (* \; "Get args for synonym") (smartarglist (cdr tem) explainflg)) (cond ((listp (setq tem (car tem))) (* \; "Substitution macro--TEM is now the arg list") (cond ((cdr (last tem)) (* \; "Last element is a tail. Turn (A B . C) into (A B ... C). Following depends on APPEND working this way on improper lists") (append tem (list (quote |...|) (cdr (last tem))))) (t tem))) (def (* \; "No args, or computed macro (either of the form CompilerFN or (args . expansionFn)). Fall back on the definition above") (arglist def explainflg))))) ((and (not def) (setq tem (fncheck fn t nil t tail)) (neq tem fn)) (setq fn tem) (go retry)) (t (arglist fn explainflg)))))) ) (\\simplify.cl.arglist (lambda (lst) (* |lmm| "28-Sep-86 12:07") (|bind| section |for| x |in| lst |collect| (cl:if (listp x) (case section (&optional (car x)) (&key (cond ((listp (car x)) (caar x)) (t (car x)))) (t (* \; " assume destructuring") x)) (case x (&aux (go $$out)) ((&aux &optional &key &body &rest &environment) (setq section x)) (t x))))) ) ) (RPAQ? HELPDEPTH 7) (RPAQ? BREAKDELIMITER " ") (RPAQ? HELPTIME 1000) (RPAQ? HELPCLOCK ) (RPAQ? NLSETQGAG T) (RPAQ? *MACROEXPAND-HOOK* 'CL:FUNCALL) (RPAQ? COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO)) (* |;;| "for backward compatibility. Used currently by window mouse handler") (RPAQQ NBREAKS 0) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ERRORX) ) (PRETTYCOMPRINT IL-ERROR-STUFFCOMS) (RPAQQ IL-ERROR-STUFFCOMS ((FNS HELP SHOULDNT ERROR ERRORX INTERRUPT FAULTEVAL FAULTAPPLY OLDFAULT1 ERRORMESS ERRORMESS1 SMARTARGLIST \\SIMPLIFY.CL.ARGLIST) (INITVARS (HELPDEPTH 7) (BREAKDELIMITER " ") (HELPTIME 1000) (HELPCLOCK) (NLSETQGAG T) (*MACROEXPAND-HOOK* 'CL:FUNCALL) (COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO))) (* |;;| "for backward compatibility. Used currently by window mouse handler") (VARS (NBREAKS 0)) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS IL-ERROR-STUFF COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1303 11373 (HELP 1313 . 1664) (SHOULDNT 1666 . 1768) (ERROR 1770 . 2236) (ERRORX 2238 . 2738) (INTERRUPT 2740 . 2889) (FAULTEVAL 2891 . 3652) (FAULTAPPLY 3654 . 4854) (OLDFAULT1 4856 . 5286) (ERRORMESS 5288 . 6261) (ERRORMESS1 6263 . 7037) (SMARTARGLIST 7039 . 11012) ( \\SIMPLIFY.CL.ARGLIST 11014 . 11371))))) STOP \ No newline at end of file diff --git a/sources/IMAGEIO b/sources/IMAGEIO new file mode 100644 index 00000000..677fce1d --- /dev/null +++ b/sources/IMAGEIO @@ -0,0 +1,296 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:33:59" {DSK}medley3.5>sources>IMAGEIO.;2 79184 changes to%: (FNS OPENIMAGESTREAM) previous date%: "22-Apr-94 15:19:02" {DSK}medley3.5>sources>IMAGEIO.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IMAGEIOCOMS) (RPAQQ IMAGEIOCOMS [(FNS IMAGESTREAMP IMAGESTREAMTYPE IMAGESTREAMTYPEP OPENIMAGESTREAM \GOOD.DASHLST) (INITVARS (IMAGESTREAMTYPES NIL)) (FNS DRAWDASHEDLINE) (FNS DSPBACKCOLOR DSPBOTTOMMARGIN DSPCOLOR DSPCLIPPINGREGION DSPRESET DSPFONT DSPLEFTMARGIN DSPLINEFEED DSPOPERATION DSPRIGHTMARGIN DSPTOPMARGIN DSPSCALE DSPSPACEFACTOR DSPXPOSITION DSPYPOSITION DSPROTATE DSPPUSHSTATE DSPPOPSTATE DSPDEFAULTSTATE DSPSCALE2 DSPTRANSLATE) (FNS DSPNEWPAGE DRAWBETWEEN DRAWCIRCLE DRAWARC DRAWCURVE DRAWELLIPSE DRAWLINE DRAWPOLYGON DRAWPOINT FILLPOLYGON DRAWTO FILLCIRCLE MOVETO RELDRAWTO BITMAPIMAGESIZE SCALEDBITBLT) (FNS \DRAWPOINT.GENERIC \DRAWPOLYGON.GENERIC \DRAWCIRCLE.GENERIC \DRAWELLIPSE.GENERIC) (FNS \IMAGEIOINIT \NOIMAGE.DSPFONT \UNIMPIMAGEOP) [COMS (* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions.") (FNS INSURE.BRUSH BRUSHP \POSSIBLECOLOR NEGSHADE) (DECLARE%: DONTCOPY EVAL@COMPILE (RESOURCES SYSTEMBRUSH)) (INITRESOURCES SYSTEMBRUSH) (FNS DASHINGP INSURE.DASHING) (DECLARE%: DONTCOPY (EXPORT (RECORDS BRUSH))) (DECLARE%: DONTCOPY (CONSTANTS (MICASPERPT (FQUOTIENT 635 18] (DECLARE%: DONTCOPY (EXPORT (MACROS IMAGEOP) (RECORDS IMAGEOPS) (GLOBALVARS \NOIMAGEOPS))) (INITRECORDS IMAGEOPS) (SYSRECORDS IMAGEOPS) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\IMAGEIOINIT))) [COMS (* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout") (INITVARS (\COLORDISPLAYSTREAMTYPES '(4DISPLAY 8DISPLAY 24DISPLAY)) (\DISPLAYSTREAMTYPES (CONS 'DISPLAY \COLORDISPLAYSTREAMTYPES))) (FNS \DisplayEventFn \DISPLAYINIT \4DISPLAYINIT \8DISPLAYINIT \24DISPLAYINIT \DISPLAYSTREAMTYPEBPP) (ALISTS (IMAGESTREAMTYPES DISPLAY 4DISPLAY 8DISPLAY 24DISPLAY)) (GLOBALVARS DisplayFDEV \4DISPLAYFDEV \8DISPLAYFDEV \24DISPLAYFDEV) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA IMAGESTREAMP]) (DEFINEQ (IMAGESTREAMP [LAMBDA NARGS (* ; "Edited 18-Jan-87 17:25 by bvm:") (PROG ([STREAM (AND (IGREATERP NARGS 0) (SELECTQ (ARG NARGS 1) (T \TERM.OFD) (NIL *STANDARD-OUTPUT*) (ARG NARGS 1] STYPE) (OR (type? STREAM STREAM) (RETURN)) (SETQ STYPE (fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of STREAM))) (RETURN (AND (COND ((EQ NARGS 2) (for X inside (ARG NARGS 2) always (EQMEMB X STYPE))) (T STYPE)) STREAM]) (IMAGESTREAMTYPE [LAMBDA (STREAM) (* rmk%: "20-AUG-83 17:28") (fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of (\STREAMARG STREAM]) (IMAGESTREAMTYPEP [LAMBDA (STREAM STYPE) (* AJB "16-Jul-85 15:31") (* ;;; "Returns T if STREAM is an imagestream of type STYPE") (LET ((S (SELECTQ STREAM ((T NIL) (\GETSTREAM STREAM 'OUTPUT T)) STREAM))) (AND (type? STREAM S) (for X inside STYPE always (EQMEMB X (fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of S]) (OPENIMAGESTREAM [LAMBDA (FILE IMAGETYPE OPTIONS) (* ; "Edited 1-Jun-93 12:32 by rmk:") (* ; "Edited 11-Jan-91 16:05 by jds") (* ;; "Opens an IMAGETYPE imagestream, or if NIL, an imagestream of a type that FILE (perhaps from DEFAULTPRINTINGHOST) can print directly. If FILE is an the LPT device, then the type of the corresponding printer is used. If FILE is NIL, then an LPT file on a printer from default printinghost is used, so the file will be printed on closing.") (DECLARE (GLOBALVARS IMAGESTREAMTYPES)) (LET (LPTNAME LPTP (DEFPRINTER (OR (CAR (LISTP DEFAULTPRINTINGHOST)) DEFAULTPRINTINGHOST))) (SETQ FILE (\CONVERT-PATHNAME FILE)) [COND ((AND (NULL FILE) (NEQ IMAGETYPE 'DISPLAY)) (* ;  "YUCK! TAKE THIS OUT WHEN WE FIGURE OUT DISPLAY IMAGESTREAMS BETTER") (SETQ LPTP T) (SETQ FILE '{LPT})) ((STREAMP FILE)) ((EQ (FILENAMEFIELD FILE 'HOST) 'LPT) (SETQ LPTP T) (LET (POS) (* ;; "This should be (FILENAMEFIELD FILE 'NAME) except that FILENAMEFIELD won't accept : as part of the name, thinks it marks a device field. This code is borrowed from PRINTERDEVICE") (AND (SETQ POS (STRPOS "}" FILE)) (SETQ LPTNAME (SUBATOM FILE (ADD1 POS) (SUB1 (OR (STRPOS "." FILE (ADD1 POS)) 0] [COND [(NULL IMAGETYPE) (* ;; "Get the image type from FILE if it is an LPT file, otherwise choose the image type from the first printer on DEFAULTPRINTINGHOST") (* ;; "Assume that it will be printed on the defaultprintinghost if it is an ordinary filename. If defaultprinter is a list, chooses the preferred-file-type if it is specified, otherwise uses the first of the printer type's CANPRINT property. ") (SETQ IMAGETYPE (COND ((PRINTFILETYPE.FROM.EXTENSION FILE)) [(AND (NOT LPTNAME) (CADDR (LISTP DEFPRINTER] [(CAR (MKLIST (PRINTERPROP (PRINTERTYPE (OR LPTNAME DEFPRINTER)) 'CANPRINT] (T (ERROR "Can't determine IMAGETYPE for " FILE] [LPTNAME (OR (EQMEMB IMAGETYPE (PRINTERPROP (PRINTERTYPE LPTNAME) 'CANPRINT)) (ERROR (CONCAT "Printer " LPTNAME " can't print " IMAGETYPE " files"] (LPTP (* ;  "This includes the NIL FILE case, cause of initial coercion") (FOR P INSIDE DEFAULTPRINTINGHOST WHEN (EQMEMB IMAGETYPE (PRINTERPROP (PRINTERTYPE P) 'CANPRINT)) DO (SETQ LPTNAME (PRINTERNAME P)) (SETQ FILE (PACKFILENAME 'HOST 'LPT 'NAME LPTNAME)) (RETURN) FINALLY (ERROR (CONCAT "Can't find a printer on DEFAULTPRINTINGHOST that can print " IMAGETYPE " files"] (LET ((STREAM (APPLY* (OR [CADR (ASSOC 'OPENSTREAM (CDR (ASSOC IMAGETYPE IMAGESTREAMTYPES] (ERROR "No open function for " IMAGETYPE " streams")) [COND ((OR LPTP (STREAMP FILE) (EQ IMAGETYPE 'DISPLAY)) FILE) (T (* ;  "Stick on default extension from PRINTFILETYPES") (PACKFILENAME 'BODY FILE 'EXTENSION (OR [CAR (CADR (ASSOC 'EXTENSION (CDR (ASSOC IMAGETYPE PRINTFILETYPES ] IMAGETYPE] OPTIONS))) (IF LPTNAME THEN (STREAMPROP STREAM 'PRINTERNAME LPTNAME)) STREAM]) (\GOOD.DASHLST [LAMBDA (DASHING BRUSH) (* rrb " 9-Sep-86 16:16") (* ;;; "massage the DASHING parameter to mesh well with the size of the BRUSH") (PROG [(DASHLST (INSURE.DASHING DASHING)) (BRUSHSIZE (COND ((LITATOM BRUSH) (* ;  "handles NULL and function name case.") 1) ((BITMAPP BRUSH) (IQUOTIENT (IPLUS 2 (BITMAPHEIGHT BRUSH) (BITMAPWIDTH BRUSH)) 2)) ((NUMBERP BRUSH) (* ;  "brush can be a number meaning ROUND and it hasn't been coerced yet.") (FIXR BRUSH)) (T (fetch (BRUSH BRUSHSIZE) of BRUSH] [COND ((AND DASHLST (GREATERP BRUSHSIZE 1)) (* ;  "adjust the dashing to take into account the brush size.") [COND ((ODDP (LENGTH DASHLST)) (* ;  "even out the DASHLST because on and off are handled differently.") (SETQ DASHLST (APPEND DASHLST DASHLST] (SETQ DASHLST (bind NOWOFF for NDASH in DASHLST collect (COND (NOWOFF (SETQ NOWOFF NIL) (TIMES NDASH BRUSHSIZE)) ((SETQ NOWOFF T) (* ;  "make the on case be 1 for the first one and brushsize for every one after that.") (ADD1 (TIMES (SUB1 NDASH) BRUSHSIZE] (RETURN DASHLST]) ) (RPAQ? IMAGESTREAMTYPES NIL) (DEFINEQ (DRAWDASHEDLINE [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 26-Jul-90 16:24 by matsuda") [COND ((NOT (EQ WIDTH 0)) (PROG ((DASHON T) DASHTAIL DASHCNT (ADJACENT (IDIFFERENCE X2 X1)) (OPPOSITE (IDIFFERENCE Y2 Y1)) (LENGTHDRAWN 0) DASHLST NEWX NEWY LINELENGTH SINE COSINE) [SETQ LINELENGTH (FIX (SQRT (IPLUS (ITIMES ADJACENT ADJACENT) (ITIMES OPPOSITE OPPOSITE] (* ;  "expand the dashing by the width.") (SETQ DASHLST (bind NOWOFF for NDASH in DASHING collect (TIMES NDASH WIDTH))) (SETQ DASHTAIL DASHLST) (SETQ SINE (FQUOTIENT OPPOSITE LINELENGTH)) (SETQ COSINE (FQUOTIENT ADJACENT LINELENGTH)) (while (ILESSP (PLUS LENGTHDRAWN (CAR DASHTAIL)) LINELENGTH) do (SETQ DASHCNT (CAR DASHTAIL)) (SETQ DASHTAIL (CDR DASHTAIL)) (add LENGTHDRAWN DASHCNT) (SETQ NEWX (FPLUS X1 (FTIMES COSINE DASHCNT))) (SETQ NEWY (FPLUS Y1 (FTIMES SINE DASHCNT))) (* ;; "Old code incorrect: (COND (DASHON (DRAWLINE X1 Y1 NEWX NEWY WIDTH OPERATION STREAM COLOR)) (T (RELMOVETO NEWX NEWY STREAM)))") (if DASHON then (DRAWLINE X1 Y1 NEWX NEWY WIDTH OPERATION STREAM COLOR)) (SETQ DASHON (NOT DASHON)) (SETQ X1 NEWX) (SETQ Y1 NEWY) (COND ((NULL DASHTAIL) (SETQ DASHTAIL DASHLST))) finally (* ; "do last partial segment") (if DASHON then (DRAWLINE X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR] (MOVETO X2 Y2 STREAM]) ) (DEFINEQ (DSPBACKCOLOR [LAMBDA (COLOR STREAM) (* rmk%: "12-Sep-84 09:53") (* ;  "Switches background color on stream") (IMAGEOP 'IMBACKCOLOR (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM COLOR]) (DSPBOTTOMMARGIN [LAMBDA (YPOSITION STREAM) (* rmk%: "26-Jun-84 13:56") (* ;  "Sets the Y position that forces a new page") (IMAGEOP 'IMBOTTOMMARGIN (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM YPOSITION]) (DSPCOLOR [LAMBDA (COLOR STREAM) (* rmk%: "12-Sep-84 09:53") (* ;  "Switches foreground color on stream") (IMAGEOP 'IMCOLOR (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM COLOR]) (DSPCLIPPINGREGION [LAMBDA (REGION STREAM) (* bvm%: " 4-Sep-85 20:57") (* ;  "Set the clipping region for an imagestream") (AND REGION (NOT (type? REGION REGION)) (\ILLEGAL.ARG REGION)) (COND (STREAM (* ;  "special check done for NIL to stop default to primary output file.") (IMAGEOP 'IMCLIPPINGREGION (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM REGION)) (T (\ILLEGAL.ARG STREAM]) (DSPRESET [LAMBDA (STREAM) (* jds "11-Jan-85 16:54") (* ; "resets a display stream") (IMAGEOP 'IMRESET (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM]) (DSPFONT [LAMBDA (FONT STREAM) (* rmk%: " 2-SEP-83 10:50") (* ;  "sets the font that an image stream uses to print characters.") (IMAGEOP 'IMFONT (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM FONT]) (DSPLEFTMARGIN [LAMBDA (XPOSITION STREAM) (* rmk%: " 2-SEP-83 10:50") (* ;  "Sets the the position that a carriage return returns to") (IMAGEOP 'IMLEFTMARGIN (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM XPOSITION]) (DSPLINEFEED [LAMBDA (DELTAY STREAM) (* rmk%: " 2-SEP-83 10:50") (* ; "Sets the Xposition of STREAM") (IMAGEOP 'IMLINEFEED (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM DELTAY]) (DSPOPERATION [LAMBDA (OPERATION STREAM) (* rmk%: "12-Sep-84 09:56") (* ;  "sets the operation field of a stream") (IMAGEOP 'IMOPERATION (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM OPERATION]) (DSPRIGHTMARGIN [LAMBDA (XPOSITION STREAM) (* rmk%: " 2-SEP-83 10:51") (* ;  "Sets the right margin that determines when a cr is inserted by print.") (IMAGEOP 'IMRIGHTMARGIN (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM XPOSITION]) (DSPTOPMARGIN [LAMBDA (YPOSITION STREAM) (* rmk%: "26-Jun-84 13:55") (* ;  "Sets the Y position that a newpage starts at") (IMAGEOP 'IMTOPMARGIN (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM YPOSITION]) (DSPSCALE [LAMBDA (SCALE STREAM) (* rmk%: "16-Jun-84 14:48") (* ;  "Returns (and eventually will set) the current scale of STREAM.") (IMAGEOP 'IMSCALE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM SCALE]) (DSPSPACEFACTOR [LAMBDA (FACTOR STREAM) (* rmk%: "27-Nov-84 18:57") (* ; "Sets the space factor of STREAM") (AND FACTOR (OR (GREATERP FACTOR 0) (\ILLEGAL.ARG FACTOR))) (IMAGEOP 'IMSPACEFACTOR (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM FACTOR]) (DSPXPOSITION [LAMBDA (XPOSITION STREAM) (* rmk%: " 2-SEP-83 10:51") (* ; "Sets the Xposition of STREAM") (IMAGEOP 'IMXPOSITION (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM XPOSITION]) (DSPYPOSITION [LAMBDA (YPOSITION STREAM) (* rmk%: " 2-SEP-83 10:51") (* ; "Sets the Yposition of STREAM") (IMAGEOP 'IMYPOSITION (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM YPOSITION]) (DSPROTATE [LAMBDA (ROTATION STREAM) (* hdj "22-Oct-85 12:15") (* ; "Sets the rotation of STREAM") (IMAGEOP 'IMROTATE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM ROTATION]) (DSPPUSHSTATE [LAMBDA (STREAM) (* hdj "25-Nov-85 11:49") (* ;;; "push a new graphics context for STREAM") (IMAGEOP 'IMPUSHSTATE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM]) (DSPPOPSTATE [LAMBDA (STREAM) (* hdj "25-Nov-85 11:50") (* ;;; "pop a the graphics context for STREAM") (IMAGEOP 'IMPOPSTATE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM]) (DSPDEFAULTSTATE [LAMBDA (STREAM) (* hdj "30-Dec-85 17:39") (* ;;; "push a new graphics context for STREAM") (IMAGEOP 'IMDEFAULTSTATE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM]) (DSPSCALE2 [LAMBDA (Sx Sy STREAM) (* hdj " 2-Jan-86 18:38") (* ; "Sets the scaling of STREAM") (IMAGEOP 'IMSCALE2 (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM Sx Sy]) (DSPTRANSLATE [LAMBDA (Tx Ty STREAM) (* hdj " 2-Jan-86 18:37") (* ; "Sets the translation of STREAM") (IMAGEOP 'IMTRANSLATE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM Tx Ty]) ) (DEFINEQ (DSPNEWPAGE [LAMBDA (STREAM) (* jds " 9-Feb-86 17:18") (* ;;; "Start a new page on the image stream STREAM.") (AND (STREAMPROP (SETQ STREAM (\OUTSTREAMARG STREAM)) 'BEFORENEWPAGEFN) (APPLY* (STREAMPROP STREAM 'BEFORENEWPAGEFN) STREAM)) (* ;  "Let the stream's creator get control before and after the page break, if he wants it.") (IMAGEOP 'IMNEWPAGE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM) (AND (STREAMPROP STREAM 'AFTERNEWPAGEFN) (APPLY* (STREAMPROP STREAM 'AFTERNEWPAGEFN) STREAM]) (DRAWBETWEEN + [LAMBDA (PT1 PT2 WIDTH OPERATION STREAM COLOR DASHING) + (* ; "Edited 14-Feb-94 11:06 by nilsson") + (* ; "draws a line bewteen two points") + (OR (POSITIONP PT1) + (ERROR "Point1 not POSITIONP")) + (OR (POSITIONP PT2) + (ERROR "Point2 not POSITIONP")) + (IMAGEOP 'IMDRAWLINE (SETQ STREAM (\OUTSTREAMARG STREAM)) + STREAM + (fetch XCOORD of PT1) + (fetch YCOORD of PT1) + (fetch XCOORD of PT2) + (fetch YCOORD of PT2) + WIDTH OPERATION COLOR DASHING]) (DRAWCIRCLE [LAMBDA (CENTERX CENTERY RADIUS BRUSH DASHING STREAM) (* rrb "30-Oct-85 14:22") (* ; "Generic DRAWCIRCLE") (COND ((LESSP RADIUS 0) (\ILLEGAL.ARG RADIUS)) ((EQP RADIUS 0) NIL) (T (IMAGEOP 'IMDRAWCIRCLE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM CENTERX CENTERY RADIUS (INSURE.BRUSH BRUSH STREAM) (INSURE.DASHING DASHING]) (DRAWARC [LAMBDA (CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING STREAM) (* rrb "31-Oct-85 09:18") (* ;; "Draws an arc of a given brush and dashing. NDEGREES can be either positive (counterclockwise) or negative (clockwise).") (IMAGEOP 'IMDRAWARC (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES (INSURE.BRUSH BRUSH STREAM) (INSURE.DASHING DASHING]) (DRAWCURVE [LAMBDA (KNOTS CLOSED BRUSH DASHING STREAM) (* edited%: "31-Mar-86 20:07") (* ;  "draws a spline curve with a given brush.") (LET ((VALIDBRUSH BRUSH)) (if (NOT (BRUSHP BRUSH)) then (SETQ VALIDBRUSH (INSURE.BRUSH BRUSH STREAM))) (IMAGEOP 'IMDRAWCURVE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM KNOTS CLOSED VALIDBRUSH (INSURE.DASHING DASHING)) (if (NEQ VALIDBRUSH BRUSH) then (FREERESOURCE SYSTEMBRUSH VALIDBRUSH]) (DRAWELLIPSE [LAMBDA (CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING STREAM) (* rrb "30-Oct-85 14:26") (* ;; "Draws an ellipse. At ORIENTATION 0, the semimajor axis is horizontal, the semiminor axis vertical. Orientation is positive in the counterclockwise direction. The current location in the stream is left at the center of the ellipse.") (DECLARE (LOCALVARS . T)) (IMAGEOP 'IMDRAWELLIPSE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION (INSURE.BRUSH BRUSH STREAM) (INSURE.DASHING DASHING]) (DRAWLINE [LAMBDA (X1 Y1 X2 Y2 WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 6-Feb-87 15:06 by FS") (* ;; "Some streams allow WIDTH to be a BRUSH, display currently does not") (IMAGEOP 'IMDRAWLINE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING]) (DRAWPOLYGON [LAMBDA (POINTS CLOSED BRUSH DASHING STREAM) (* ; "Edited 13-Jan-88 21:00 by FS") (* ;; "draws a polygon with a given brush. Change so BRUSH can be just number, and passed through? Then display can you better drawline. Other streams?") (IMAGEOP 'IMDRAWPOLYGON (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM POINTS CLOSED (INSURE.BRUSH BRUSH STREAM) (INSURE.DASHING DASHING]) (DRAWPOINT [LAMBDA (X Y BRUSH STREAM OPERATION) (* ; "Edited 24-Aug-87 16:25 by FS") (* ;;  "draws a brush point at position X Y. Doc says brush can be a BM (only fn so documented).") (IMAGEOP 'IMDRAWPOINT (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM X Y (OR (BITMAPP BRUSH) (INSURE.BRUSH BRUSH STREAM)) OPERATION]) (FILLPOLYGON [LAMBDA (POINTS TEXTURE STREAM OPERATION WINDNUMBER) (* rrb " 5-Mar-86 15:39") (* ;  "fills a polygon with a given texture") (COND ((NOT (OR (EQUAL WINDNUMBER 0) (EQUAL WINDNUMBER 1))) (SETQ WINDNUMBER 1))) (IMAGEOP 'IMFILLPOLYGON (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM POINTS TEXTURE (OR OPERATION (DSPOPERATION NIL STREAM)) WINDNUMBER]) (DRAWTO [LAMBDA (X Y WIDTH OPERATION STREAM COLOR DASHING) (* hdj " 7-Nov-84 14:03") (* ;; "draws a line fro the current position of STREAM to absolute position X,Y.") (IMAGEOP 'IMDRAWLINE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM (IMAGEOP 'IMXPOSITION STREAM STREAM) (IMAGEOP 'IMYPOSITION STREAM STREAM) X Y WIDTH OPERATION COLOR DASHING]) (FILLCIRCLE [LAMBDA (CENTERX CENTERY RADIUS TEXTURE STREAM) (* rmk%: " 2-SEP-83 10:54") (IMAGEOP 'IMFILLCIRCLE (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM CENTERX CENTERY RADIUS TEXTURE]) (MOVETO [LAMBDA (X Y STREAM) (* rmk%: "17-Sep-84 17:59") (* ;  "sets both the X and Y positions in a Stream") (IMAGEOP 'IMMOVETO (SETQ STREAM (\OUTSTREAMARG STREAM)) STREAM X Y]) (RELDRAWTO [LAMBDA (DX DY WIDTH OPERATION STREAM COLOR DASHING) (* ; "Edited 22-Apr-87 12:43 by rrb") (* ;  "Draws a vector from the current position") (PROG (ORIGX ORIGY (STRM (\OUTSTREAMARG STREAM))) (RETURN (COND ((NOT (AND (ZEROP DX) (ZEROP DY))) (* ;  "documented to not draw anything if DX and DY are both 0") (IMAGEOP 'IMDRAWLINE STRM STRM (SETQ ORIGX (IMAGEOP 'IMXPOSITION STRM STRM)) (SETQ ORIGY (IMAGEOP 'IMYPOSITION STRM STRM)) (IPLUS ORIGX DX) (IPLUS ORIGY DY) WIDTH OPERATION COLOR DASHING]) (BITMAPIMAGESIZE [LAMBDA (BITMAP DIMENSION STREAM) (* hdj "19-Dec-84 11:57") (IMAGEOP 'IMBITMAPSIZE STREAM STREAM BITMAP DIMENSION]) (SCALEDBITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SCALE) (* ; "Edited 29-Mar-89 18:32 by snow") (* ;; "Changed to pass thru the DESTINATIONLEFT and DESTINATIONBOTTOM arguments as NIL is significantly different than 0. NIL means %"put the bitmap at the current position.%" --was") (IMAGEOP 'IMSCALEDBITBLT DESTINATION SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION (if CLIPPINGREGION then (fetch (REGION LEFT) of CLIPPINGREGION) else 0) (if CLIPPINGREGION then (fetch (REGION BOTTOM) of CLIPPINGREGION) else 0) (OR SCALE 1]) ) (DEFINEQ (\DRAWPOINT.GENERIC [LAMBDA (STREAM X Y BRUSH OPERATION) (* hdj "19-Nov-86 15:12") (* ;; "generic version of drawpoint that calls drawline. Used as the default.") (DRAWLINE X Y X Y (fetch (BRUSH BRUSHSIZE) of BRUSH) OPERATION STREAM (fetch (BRUSH BRUSHCOLOR) of BRUSH]) (\DRAWPOLYGON.GENERIC [LAMBDA (STREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 31-Mar-88 18:35 by FS") (* ;; "generic version of drawpolygon that calls drawline. Used as the default.") (if POINTS then (bind (COLOR _ (fetch (BRUSH BRUSHCOLOR) of BRUSH)) for PTAIL on POINTS while (CDR PTAIL) do (DRAWLINE (fetch (POSITION XCOORD) of (CAR PTAIL)) (ffetch (POSITION YCOORD) of (CAR PTAIL)) (fetch (POSITION XCOORD) of (CADR PTAIL)) (ffetch (POSITION YCOORD) of (CADR PTAIL)) BRUSH NIL STREAM COLOR DASHING) finally (COND ((NULL (CDR POINTS)) (* ; "only one point") (DRAWPOINT (fetch (POSITION XCOORD) of (CAR POINTS)) (ffetch (POSITION YCOORD) of (CAR POINTS)) BRUSH STREAM NIL)) ((AND CLOSED (CDDR POINTS)) (* ; "draw the closing line.") (DRAWLINE (fetch (POSITION XCOORD) of (CAR PTAIL)) (ffetch (POSITION YCOORD) of (CAR PTAIL)) (fetch (POSITION XCOORD) of (CAR POINTS)) (ffetch (POSITION YCOORD) of (CAR POINTS)) BRUSH NIL STREAM COLOR DASHING]) (\DRAWCIRCLE.GENERIC [LAMBDA (STREAM CENTERX CENTERY RADIUS BRUSH DASHING) (* ; "Edited 13-Apr-88 14:03 by FS") (* ;; "Approximate ellipse with cubic spline. Generic in the sense that if the stream supports splines, then this code will work (only as good as the approximation).. -FS.") (* ;; "") (* ;; "Could have instead provided Pitteway's algorithm, but would have had to handle dashing, brushes, etc.") (* ;; "") (* ;; "Could also have simply called \DRAWELLIPSE.GENERIC.") (PROG [(R2RAD (FIXR (FTIMES RADIUS (CONSTANT (FQUOTIENT (SQRT 2) 2] (DRAWCURVE (LIST (CREATEPOSITION (IPLUS CENTERX RADIUS) CENTERY) (CREATEPOSITION (IPLUS CENTERX R2RAD) (IPLUS CENTERY R2RAD)) (CREATEPOSITION CENTERX (IPLUS CENTERY RADIUS)) (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD) (IPLUS CENTERY R2RAD)) (CREATEPOSITION (IDIFFERENCE CENTERX RADIUS) CENTERY) (CREATEPOSITION (IDIFFERENCE CENTERX R2RAD) (IDIFFERENCE CENTERY R2RAD)) (CREATEPOSITION CENTERX (IDIFFERENCE CENTERY RADIUS)) (CREATEPOSITION (IPLUS CENTERX R2RAD) (IDIFFERENCE CENTERY R2RAD))) T BRUSH DASHING STREAM]) (\DRAWELLIPSE.GENERIC [LAMBDA (STREAM CENTERX CENTERY SEMIMINORRADIUS SEMIMAJORRADIUS ORIENTATION BRUSH DASHING) (* ; "Edited 13-Apr-88 14:03 by FS") (* ;; "Approximate ellipse with cubic spline. Generic in the sense that if the stream supports splines, then this code will work (only as good as the approximation).. -FS.") (* ;; "not a great approximation for degenerate ellipses (e.g. minorrad. 1, majorrad 200), but seems to be more numerically stable than Pitteway's algorithm (in \DrawEllipse.Display)") (PROG ((SINOR (COND (ORIENTATION (SIN ORIENTATION)) (T 0.0))) (COSOR (COND (ORIENTATION (COS ORIENTATION)) (T 1.0))) (ROOT2DIV2 (CONSTANT (FQUOTIENT (SQRT 2) 2))) MAJORXOFFSET MAJORYOFFSET MINORXOFFSET MINORYOFFSET) (SETQ MAJORXOFFSET (FTIMES COSOR SEMIMAJORRADIUS)) (SETQ MAJORYOFFSET (FTIMES SINOR SEMIMAJORRADIUS)) (SETQ MINORXOFFSET (FTIMES SINOR SEMIMINORRADIUS)) (SETQ MINORYOFFSET (FTIMES COSOR SEMIMINORRADIUS)) (SETQ EXTRAXOFFSET (CL:* ROOT2DIV2 (- MAJORXOFFSET MINORXOFFSET))) (SETQ EXTRAYOFFSET (CL:* ROOT2DIV2 (+ MAJORYOFFSET MINORYOFFSET))) (SETQ VERSOXOFFSET (CL:* ROOT2DIV2 (+ MAJORXOFFSET MINORXOFFSET))) (SETQ VERSOYOFFSET (CL:* ROOT2DIV2 (- MAJORYOFFSET MINORYOFFSET))) (DRAWCURVE (LIST (CREATEPOSITION (+ CENTERX MAJORXOFFSET) (+ CENTERY MAJORYOFFSET)) (CREATEPOSITION (+ CENTERX EXTRAXOFFSET) (+ CENTERY EXTRAYOFFSET)) (CREATEPOSITION (- CENTERX MINORXOFFSET) (+ CENTERY MINORYOFFSET)) (CREATEPOSITION (- CENTERX VERSOXOFFSET) (- CENTERY VERSOYOFFSET)) (CREATEPOSITION (- CENTERX MAJORXOFFSET) (- CENTERY MAJORYOFFSET)) (CREATEPOSITION (- CENTERX EXTRAXOFFSET) (- CENTERY EXTRAYOFFSET)) (CREATEPOSITION (+ CENTERX MINORXOFFSET) (- CENTERY MINORYOFFSET)) (CREATEPOSITION (+ CENTERX VERSOXOFFSET) (+ CENTERY VERSOYOFFSET))) T BRUSH DASHING STREAM) (MOVETO CENTERX CENTERY STREAM]) ) (DEFINEQ (\IMAGEIOINIT [LAMBDA NIL (* rrb "17-Sep-86 15:09") (DECLARE (GLOBALVARS \NOIMAGEOPS)) (* ;  "most of the functions are filled with NILL from the record declaration for IMAGEOPS") (SETQ \NOIMAGEOPS (create IMAGEOPS IMAGETYPE _ NIL IMXPOSITION _ [FUNCTION (LAMBDA (STREAM POS) (LET ((OPOS (POSITION STREAM))) (PROG1 OPOS (COND (POS (SPACES (DIFFERENCE POS OPOS) STREAM))))] IMYPOSITION _ [FUNCTION (LAMBDA (STREAM N) (PROG1 (AND \#DISPLAYLINES (NEQ \CURRENTDISPLAYLINE -1) (DIFFERENCE \#DISPLAYLINES \CURRENTDISPLAYLINE)) [COND (N (\UNIMPIMAGEOP STREAM 'DSPYPOSITION])] IMFONT _ (FUNCTION \NOIMAGE.DSPFONT) IMLEFTMARGIN _ (FUNCTION ZERO) IMRIGHTMARGIN _ [FUNCTION (LAMBDA (STREAM N) (LINELENGTH N STREAM] IMLINEFEED _ [FUNCTION (LAMBDA (STREAM DY) (PROG1 -1 [AND DY (COND ((NEQ DY -1) (ERROR DY "Illegal DSPLINEFEED for terminal" ])] IMSPACEFACTOR _ [FUNCTION (LAMBDA (STREAM) (\UNIMPIMAGEOP STREAM 'DSPSPACEFACTOR] IMFONTCREATE _ [FUNCTION (LAMBDA (STREAM) (\UNIMPIMAGEOP STREAM 'FONTCREATE] IMSTRINGWIDTH _ [FUNCTION (LAMBDA (STREAM STR RDTBL) (NCHARS STR RDTBL RDTBL] IMCHARWIDTH _ [FUNCTION (LAMBDA NIL 1] IMCHARSET _ [FUNCTION (LAMBDA (STREAM CHARSET) (* ;; "If we had another illegal character set value, then we could simply fix it so that the character set didn't match anything, which would cause the character set shift to be put out on the next character") (COND ((\IOMODEP STREAM 'OUTPUT T) (\BOUT STREAM NSCHARSETSHIFT) (COND ((EQ CHARSET T) (\BOUT STREAM NSCHARSETSHIFT) (\BOUT STREAM 0)) (T (\BOUT STREAM CHARSET] IMDRAWPOLYGON _ (FUNCTION NILL) IMDRAWPOINT _ (FUNCTION NILL]) (\NOIMAGE.DSPFONT [LAMBDA (STREAM FONT) (* ; "Edited 28-Oct-87 20:10 by jds") (* ;; "DSPFONT method for non-image streams: Put out font-change characters.") (LET ((OLDFONT (ffetch IMAGEDATA of STREAM))) (PROG1 OLDFONT [AND (NEQ OLDFONT 0) (LET [(FONTN (OR (SMALLP FONT) (AND (type? FONTCLASS FONT) (fetch (FONTCLASS PRETTYFONT#) of FONT] (COND ((AND FONTN (NEQ FONTN OLDFONT)) (* ;; "must be an outchar so that if the file is run-coded, the font change characters will come out in charset 0.") (COND ((NEQ FONTN 0) (\OUTCHAR STREAM (CONSTANT (CHCON1 FONTESCAPECHAR))) (\OUTCHAR STREAM FONTN))) (freplace IMAGEDATA of STREAM with FONTN])]) (\UNIMPIMAGEOP [LAMBDA (STREAM OP) (* rmk%: "26-Jun-84 13:28") (ERROR STREAM (CONCAT "does not support " OP]) ) (* ;; "stuff to support the checking and defaulting of arguments in the device independent drawing functions." ) (DEFINEQ (INSURE.BRUSH [LAMBDA (BRUSH STREAM NOERRORFLG) (* ; "Edited 13-Jan-88 20:59 by FS") (* ;; "returns a full brush if BRUSH is interpretable as a brush") (COND ((BRUSHP BRUSH)) ((NUMBERP BRUSH) (LET ((SYSTEMBRUSH (NEWRESOURCE SYSTEMBRUSH))) (replace (BRUSH BRUSHSHAPE) of SYSTEMBRUSH with 'ROUND) (freplace (BRUSH BRUSHSIZE) of SYSTEMBRUSH with BRUSH) (freplace (BRUSH BRUSHCOLOR) of SYSTEMBRUSH with (DSPCOLOR NIL STREAM)) SYSTEMBRUSH)) ((NULL BRUSH) (* ;  "Defaults to ROUND, 1 screen point and the current stream color") (LET ((SYSTEMBRUSH (NEWRESOURCE SYSTEMBRUSH))) (replace (BRUSH BRUSHSHAPE) of SYSTEMBRUSH with 'ROUND) (freplace (BRUSH BRUSHCOLOR) of SYSTEMBRUSH with (DSPCOLOR NIL STREAM)) (freplace (BRUSH BRUSHSIZE) of SYSTEMBRUSH with (DSPSCALE NIL STREAM)) (* ;  "the default brush should be 1 screen point wide.") SYSTEMBRUSH)) (NOERRORFLG NIL) (T (\ILLEGAL.ARG BRUSH]) (BRUSHP [LAMBDA (BRUSH?) (* rrb "13-Feb-86 17:37") (* ;; "checks if BRUSH? is a legal brush") (DECLARE (GLOBALVARS KNOWN.BRUSHES)) (COND ((LITATOM BRUSH?) (* ;  "the name of a function to be applied at each point.") (AND (\DEFINEDP BRUSH?) BRUSH?)) ([AND (MEMB (CAR (LISTP BRUSH?)) KNOWN.BRUSHES) [NUMBERP (CAR (LISTP (CDR BRUSH?] (OR (NULL (CDDR BRUSH?)) (AND [OR [\POSSIBLECOLOR (CAR (LISTP (CDDR BRUSH?] (NULL (CAR (LISTP (CDDR BRUSH?] (NULL (CDDDR BRUSH?] BRUSH?]) (\POSSIBLECOLOR [LAMBDA (COLOR?) (* ; "Edited 28-Jan-93 13:05 by jds") (* ;; "could COLOR? be a color indicator. True if it is a number in the right range or a LITATOM that could be a name.") (SELECTQ (TYPENAME COLOR?) ((LITATOM NEW-ATOM) COLOR?) ((SMALLP FIXP) (AND (IGEQ COLOR? 0) (ILEQ COLOR? (MASK.1'S 0 24)) COLOR?)) (LISTP (OR (RGBP COLOR?) (HLSP COLOR?))) NIL]) (NEGSHADE [LAMBDA (SHADE) (* ; "Edited 2-Mar-88 20:58 by FS") (* ;; "Keep arithmetic small if possible. This is used in Interpress, possibly other places") (if (NUMBERP SHADE) then (if (< SHADE 0) then SHADE else (- SHADE 65535 1)) else SHADE]) ) (DECLARE%: DONTCOPY EVAL@COMPILE (DECLARE%: EVAL@COMPILE [PUTDEF 'SYSTEMBRUSH 'RESOURCES '(NEW (CREATE BRUSH) FREE (PUSH \SYSTEMBRUSHES (PROG1 . ARGS)) GET (OR (POP \SYSTEMBRUSHES) (NEWRESOURCE SYSTEMBRUSH)) INIT (SETQ \SYSTEMBRUSHES NIL] ) ) (SETQ \SYSTEMBRUSHES NIL) (DEFINEQ (DASHINGP [LAMBDA (DASHING) (* rrb "30-Oct-85 11:33") (* ;; "return DASHING if it is a legal DASHING Note that NIL is a legal dashing and this will return NIL.") (AND (LISTP DASHING) (for X in DASHING always (NUMBERP X)) DASHING]) (INSURE.DASHING [LAMBDA (DASHING NOERRORFLG) (* rrb "30-Oct-85 11:35") (* ;; "checks to make sure DASHING is a legal dashing spec.") (COND (DASHING (COND ((DASHINGP DASHING)) (NOERRORFLG NIL) (T (\ILLEGAL.ARG DASHING]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RECORD BRUSH (BRUSHSHAPE BRUSHSIZE BRUSHCOLOR) BRUSHSHAPE _ 'ROUND BRUSHSIZE _ 1) ) (* "END EXPORTED DEFINITIONS") ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQ MICASPERPT (FQUOTIENT 635 18)) (CONSTANTS (MICASPERPT (FQUOTIENT 635 18))) ) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS IMAGEOP MACRO [ARGS (CONS 'SPREADAPPLY* (CONS (COND [(EQ (CAR (LISTP (CAR ARGS))) 'QUOTE) (LIST 'fetch (LIST 'IMAGEOPS (CADAR ARGS)) 'of (LIST 'fetch '(STREAM IMAGEOPS) 'of (CADR ARGS] (T (HELP "IMAGEOP - OPNAME not quoted:" ARGS))) (CDDR ARGS]) ) (DECLARE%: EVAL@COMPILE (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 'IMXPOSITION STREAM STREAM X) (IMAGEOP '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)) ) (/DECLAREDATATYPE 'IMAGEOPS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((IMAGEOPS 0 POINTER) (IMAGEOPS 2 POINTER) (IMAGEOPS 4 POINTER) (IMAGEOPS 6 POINTER) (IMAGEOPS 8 POINTER) (IMAGEOPS 10 POINTER) (IMAGEOPS 12 POINTER) (IMAGEOPS 14 POINTER) (IMAGEOPS 16 POINTER) (IMAGEOPS 18 POINTER) (IMAGEOPS 20 POINTER) (IMAGEOPS 22 POINTER) (IMAGEOPS 24 POINTER) (IMAGEOPS 26 POINTER) (IMAGEOPS 28 POINTER) (IMAGEOPS 30 POINTER) (IMAGEOPS 32 POINTER) (IMAGEOPS 34 POINTER) (IMAGEOPS 36 POINTER) (IMAGEOPS 38 POINTER) (IMAGEOPS 40 POINTER) (IMAGEOPS 42 POINTER) (IMAGEOPS 44 POINTER) (IMAGEOPS 46 POINTER) (IMAGEOPS 48 POINTER) (IMAGEOPS 50 POINTER) (IMAGEOPS 52 POINTER) (IMAGEOPS 54 POINTER) (IMAGEOPS 56 POINTER) (IMAGEOPS 58 POINTER) (IMAGEOPS 60 POINTER) (IMAGEOPS 62 POINTER) (IMAGEOPS 64 POINTER) (IMAGEOPS 66 POINTER) (IMAGEOPS 68 POINTER) (IMAGEOPS 70 POINTER) (IMAGEOPS 72 POINTER) (IMAGEOPS 74 POINTER) (IMAGEOPS 76 POINTER) (IMAGEOPS 78 POINTER) (IMAGEOPS 80 POINTER) (IMAGEOPS 82 POINTER) (IMAGEOPS 84 POINTER) (IMAGEOPS 86 POINTER) (IMAGEOPS 88 POINTER) (IMAGEOPS 90 POINTER) (IMAGEOPS 92 POINTER) (IMAGEOPS 94 POINTER)) '96) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NOIMAGEOPS) ) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'IMAGEOPS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((IMAGEOPS 0 POINTER) (IMAGEOPS 2 POINTER) (IMAGEOPS 4 POINTER) (IMAGEOPS 6 POINTER) (IMAGEOPS 8 POINTER) (IMAGEOPS 10 POINTER) (IMAGEOPS 12 POINTER) (IMAGEOPS 14 POINTER) (IMAGEOPS 16 POINTER) (IMAGEOPS 18 POINTER) (IMAGEOPS 20 POINTER) (IMAGEOPS 22 POINTER) (IMAGEOPS 24 POINTER) (IMAGEOPS 26 POINTER) (IMAGEOPS 28 POINTER) (IMAGEOPS 30 POINTER) (IMAGEOPS 32 POINTER) (IMAGEOPS 34 POINTER) (IMAGEOPS 36 POINTER) (IMAGEOPS 38 POINTER) (IMAGEOPS 40 POINTER) (IMAGEOPS 42 POINTER) (IMAGEOPS 44 POINTER) (IMAGEOPS 46 POINTER) (IMAGEOPS 48 POINTER) (IMAGEOPS 50 POINTER) (IMAGEOPS 52 POINTER) (IMAGEOPS 54 POINTER) (IMAGEOPS 56 POINTER) (IMAGEOPS 58 POINTER) (IMAGEOPS 60 POINTER) (IMAGEOPS 62 POINTER) (IMAGEOPS 64 POINTER) (IMAGEOPS 66 POINTER) (IMAGEOPS 68 POINTER) (IMAGEOPS 70 POINTER) (IMAGEOPS 72 POINTER) (IMAGEOPS 74 POINTER) (IMAGEOPS 76 POINTER) (IMAGEOPS 78 POINTER) (IMAGEOPS 80 POINTER) (IMAGEOPS 82 POINTER) (IMAGEOPS 84 POINTER) (IMAGEOPS 86 POINTER) (IMAGEOPS 88 POINTER) (IMAGEOPS 90 POINTER) (IMAGEOPS 92 POINTER) (IMAGEOPS 94 POINTER)) '96) (ADDTOVAR SYSTEMRECLST (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)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\IMAGEIOINIT) ) (* ;; "Implementation of display stream resident `files.' Done here cause it might matter that the display device get defined early so that its event fn will be evaluated as the last thing before logout" ) (RPAQ? \COLORDISPLAYSTREAMTYPES '(4DISPLAY 8DISPLAY 24DISPLAY)) (RPAQ? \DISPLAYSTREAMTYPES (CONS 'DISPLAY \COLORDISPLAYSTREAMTYPES)) (DEFINEQ (\DisplayEventFn [LAMBDA (FDEV EVENT) (* bvm%: "25-MAY-83 12:32") (SELECTQ EVENT (BEFORELOGOUT (DISPLAYBEFOREEXIT 'LOGOUT)) (AFTERLOGOUT (DISPLAYAFTERENTRY 'LOGOUT)) (BEFOREMAKESYS (DISPLAYBEFOREEXIT 'MAKESYS)) (AFTERMAKESYS (DISPLAYAFTERENTRY 'MAKESYS)) ((BEFORESYSOUT BEFORESAVEVM) (DISPLAYBEFOREEXIT 'SYSOUT)) ((AFTERSYSOUT AFTERSAVEVM) (DISPLAYAFTERENTRY 'SYSOUT)) NIL]) (\DISPLAYINIT + [LAMBDA NIL (* ; "Edited 19-Apr-94 04:36 by sybalsky") + + (* ;; "Initializes global variables for the Display device") + + (* ;; "Display Streams are referred to only by themselves so they do not need directory operations. Most of the fields in the DisplayDevice are empty to avoid something bad happening.") + + (DECLARE (GLOBALVARS DisplayFDEV \DISPLAYIMAGEOPS \DisplayDeviceMethods \DisplayDeviceData)) + (SETQ \DisplayDeviceMethods (create WSOPS)) + (SETQ \DisplayDeviceData + (create WSDATA + WSDESTINATION _ "Destination" + WSREGION _ (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ 1024 + HEIGHT _ 808))) + (SETQ \DISPLAYIMAGEOPS (create IMAGEOPS + IMAGETYPE _ 'DISPLAY + IMFONT _ (FUNCTION \DSPFONT.DISPLAY) + IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) + IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) + IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) + IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) + IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) + IMCLOSEFN _ (FUNCTION NILL) + IMDRAWCURVE _ (FUNCTION \DRAWCURVE.DISPLAY) + IMFILLCIRCLE _ '\FILLCIRCLE.DISPLAY + IMDRAWLINE _ (FUNCTION \DRAWLINE.DISPLAY) + IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.DISPLAY) + IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.DISPLAY) + IMFILLPOLYGON _ (FUNCTION POLYSHADE.DISPLAY) + IMBITBLT _ (FUNCTION \BITBLT.DISPLAY) + IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.DISPLAY) + IMBLTSHADE _ (FUNCTION \BLTSHADE.DISPLAY) + IMNEWPAGE _ (FUNCTION \NEWPAGE.DISPLAY) + IMSCALE _ [FUNCTION (LAMBDA NIL 1] + IMSPACEFACTOR _ (FUNCTION NILL) + IMFONTCREATE _ 'DISPLAY + IMCOLOR _ (FUNCTION NILL) + IMBACKCOLOR _ (FUNCTION \BACKCOLOR.DISPLAY) + IMOPERATION _ (FUNCTION \DSPOPERATION.DISPLAY) + IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.DISPLAY) + IMCHARWIDTH _ (FUNCTION \CHARWIDTH.DISPLAY) + IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.DISPLAY) + IMRESET _ (FUNCTION \DSPRESET.DISPLAY) + IMDRAWARC _ (FUNCTION \DRAWARC.DISPLAY) + IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.DISPLAY) + IMDRAWPOINT _ (FUNCTION \DRAWPOINT.DISPLAY) + IMBLTCHAR _ (FUNCTION \MEDW.BLTCHAR) + IMXOFFSET _ (FUNCTION \MEDW.XOFFSET) + IMYOFFSET _ (FUNCTION \MEDW.YOFFSET))) + (SETQ DisplayFDEV (create FDEV + DEVICENAME _ 'DISPLAY + RESETABLE _ NIL + RANDOMACCESSP _ NIL + PAGEMAPPED _ NIL + CLOSEFILE _ (FUNCTION NILL) + DELETEFILE _ (FUNCTION NILL) + GETFILEINFO _ (FUNCTION NILL) + OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) + NAME] + READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + SETFILEINFO _ (FUNCTION NILL) + GENERATEFILES _ (FUNCTION \GENERATENOFILES) + TRUNCATEFILE _ (FUNCTION NILL) + WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) + NAME] + REOPENFILE _ [FUNCTION (LAMBDA (NAME) + NAME] + EVENTFN _ (FUNCTION \DisplayEventFn) + DIRECTORYNAMEP _ (FUNCTION NILL) + HOSTNAMEP _ (FUNCTION NILL) + BIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BOUT _ (FUNCTION \DSPPRINTCHAR) + PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) + BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) + WINDOWOPS _ \DisplayDeviceMethods + WINDOWDATA _ \DisplayDeviceData + DEVICEINFO _ (create DISPLAYSTATE))) + (\DEFINEDEVICE 'LFDISPLAY DisplayFDEV]) (\4DISPLAYINIT + [LAMBDA NIL (* ; "Edited 22-Apr-94 15:17 by sybalsky") + (DECLARE (GLOBALVARS \4DISPLAYIMAGEOPS \4DISPLAYFDEV)) + (SETQ \4DISPLAYIMAGEOPS (create IMAGEOPS + IMAGETYPE _ '4DISPLAY + IMFONT _ (FUNCTION \DSPFONT.DISPLAY) + IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) + IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) + IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) + IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) + IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) + IMCLOSEFN _ (FUNCTION NILL) + IMDRAWCURVE _ (FUNCTION \DRAWCURVE.DISPLAY) + IMFILLCIRCLE _ '\FILLCIRCLE.DISPLAY + IMDRAWLINE _ (FUNCTION \DRAWLINE.DISPLAY) + IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.DISPLAY) + IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.DISPLAY) + IMBITBLT _ (FUNCTION \BITBLT.DISPLAY) + IMBLTSHADE _ (FUNCTION \BLTSHADE.DISPLAY) + IMNEWPAGE _ (FUNCTION \NEWPAGE.DISPLAY) + IMSCALE _ [FUNCTION (LAMBDA NIL 1] + IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.DISPLAY) + IMFONTCREATE _ '4DISPLAY + IMCOLOR _ (FUNCTION \DSPCOLOR.DISPLAY) + IMBACKCOLOR _ (FUNCTION \DSPBACKCOLOR.DISPLAY) + IMOPERATION _ (FUNCTION \DSPOPERATION.DISPLAY) + IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.DISPLAY) + IMCHARWIDTH _ (FUNCTION \CHARWIDTH.DISPLAY) + IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.DISPLAY) + IMRESET _ (FUNCTION \DSPRESET.DISPLAY) + IMDRAWARC _ (FUNCTION \DRAWARC.DISPLAY) + IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.DISPLAY) + IMDRAWPOINT _ (FUNCTION \DRAWPOINT.DISPLAY) + IMBLTCHAR _ (FUNCTION \MEDW.BLTCHAR) + IMXOFFSET _ (FUNCTION \MEDW.XOFFSET) + IMYOFFSET _ (FUNCTION \MEDW.YOFFSET))) + (SETQ \4DISPLAYFDEV (create FDEV + DEVICENAME _ '4DISPLAY + RESETABLE _ NIL + RANDOMACCESSP _ NIL + PAGEMAPPED _ NIL + CLOSEFILE _ (FUNCTION NILL) + DELETEFILE _ (FUNCTION NILL) + GETFILEINFO _ (FUNCTION NILL) + OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) + NAME] + READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + SETFILEINFO _ (FUNCTION NILL) + GENERATEFILES _ (FUNCTION \GENERATENOFILES) + TRUNCATEFILE _ (FUNCTION NILL) + WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) + NAME] + REOPENFILE _ [FUNCTION (LAMBDA (NAME) + NAME] + EVENTFN _ (FUNCTION NILL) + DIRECTORYNAMEP _ (FUNCTION NILL) + HOSTNAMEP _ (FUNCTION NILL) + BIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BOUT _ (FUNCTION \DSPPRINTCHAR) + PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) + BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) + DEVICEINFO _ (create DISPLAYSTATE) + WINDOWOPS _ NIL)) + (\DEFINEDEVICE NIL \4DISPLAYFDEV]) (\8DISPLAYINIT + [LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky") + (DECLARE (GLOBALVARS \8DISPLAYIMAGEOPS \8DISPLAYFDEV)) + (SETQ \8DISPLAYIMAGEOPS (create IMAGEOPS + IMAGETYPE _ '8DISPLAY + IMFONT _ (FUNCTION \DSPFONT.DISPLAY) + IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) + IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) + IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) + IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) + IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) + IMCLOSEFN _ (FUNCTION NILL) + IMDRAWCURVE _ (FUNCTION \DRAWCURVE.BIGBM) + IMFILLCIRCLE _ (FUNCTION \FILLCIRCLE.BIGBM) + IMDRAWLINE _ (FUNCTION \DRAWLINE.DISPLAY) + IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.BIGBM) + IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.BIGBM) + IMBITBLT _ (FUNCTION \BITBLT.DISPLAY) + IMBLTSHADE _ (FUNCTION \BLTSHADE.DISPLAY) + IMNEWPAGE _ (FUNCTION \NEWPAGE.DISPLAY) + IMSCALE _ [FUNCTION (LAMBDA NIL 1] + IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.DISPLAY) + IMFONTCREATE _ '8DISPLAY + IMCOLOR _ (FUNCTION \DSPCOLOR.DISPLAY) + IMBACKCOLOR _ (FUNCTION \DSPBACKCOLOR.DISPLAY) + IMOPERATION _ (FUNCTION \DSPOPERATION.DISPLAY) + IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.DISPLAY) + IMCHARWIDTH _ (FUNCTION \CHARWIDTH.DISPLAY) + IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.DISPLAY) + IMRESET _ (FUNCTION \DSPRESET.DISPLAY) + IMDRAWARC _ (FUNCTION \DRAWARC.DISPLAY) + IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.DISPLAY) + IMDRAWPOINT _ (FUNCTION \DRAWPOINT.DISPLAY) + IMBLTCHAR _ (FUNCTION \MEDW.BLTCHAR) + IMXOFFSET _ (FUNCTION \MEDW.XOFFSET) + IMYOFFSET _ (FUNCTION \MEDW.YOFFSET))) + (SETQ \8DISPLAYFDEV (create FDEV + DEVICENAME _ '8DISPLAY + RESETABLE _ NIL + RANDOMACCESSP _ NIL + PAGEMAPPED _ NIL + CLOSEFILE _ (FUNCTION NILL) + DELETEFILE _ (FUNCTION NILL) + GETFILEINFO _ (FUNCTION NILL) + OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) + NAME] + READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + SETFILEINFO _ (FUNCTION NILL) + GENERATEFILES _ (FUNCTION \GENERATENOFILES) + TRUNCATEFILE _ (FUNCTION NILL) + WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) + NAME] + REOPENFILE _ [FUNCTION (LAMBDA (NAME) + NAME] + EVENTFN _ (FUNCTION NILL) + DIRECTORYNAMEP _ (FUNCTION NILL) + HOSTNAMEP _ (FUNCTION NILL) + BIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BOUT _ (FUNCTION \DSPPRINTCHAR) + PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) + BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) + DEVICEINFO _ (create DISPLAYSTATE) + WINDOWOPS _ NIL)) + (\DEFINEDEVICE NIL \8DISPLAYFDEV]) (\24DISPLAYINIT + [LAMBDA NIL (* ; "Edited 22-Apr-94 15:18 by sybalsky") + (DECLARE (GLOBALVARS \24DISPLAYIMAGEOPS \24DISPLAYFDEV)) + (SETQ \24DISPLAYIMAGEOPS (create IMAGEOPS + IMAGETYPE _ '24DISPLAY + IMFONT _ (FUNCTION \DSPFONT.DISPLAY) + IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) + IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) + IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) + IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) + IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) + IMCLOSEFN _ (FUNCTION NILL) + IMDRAWCURVE _ (FUNCTION \DRAWCURVE.DISPLAY) + IMFILLCIRCLE _ '\FILLCIRCLE.DISPLAY + IMDRAWLINE _ (FUNCTION \DRAWLINE.DISPLAY) + IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.DISPLAY) + IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.DISPLAY) + IMBITBLT _ (FUNCTION \BITBLT.DISPLAY) + IMBLTSHADE _ (FUNCTION \BLTSHADE.DISPLAY) + IMNEWPAGE _ (FUNCTION \NEWPAGE.DISPLAY) + IMSCALE _ [FUNCTION (LAMBDA NIL 1] + IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.DISPLAY) + IMFONTCREATE _ '24DISPLAY + IMCOLOR _ (FUNCTION \DSPCOLOR.DISPLAY) + IMBACKCOLOR _ (FUNCTION \DSPBACKCOLOR.DISPLAY) + IMOPERATION _ (FUNCTION \DSPOPERATION.DISPLAY) + IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.DISPLAY) + IMCHARWIDTH _ (FUNCTION \CHARWIDTH.DISPLAY) + IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.DISPLAY) + IMRESET _ (FUNCTION \DSPRESET.DISPLAY) + IMDRAWARC _ (FUNCTION \DRAWARC.DISPLAY) + IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.DISPLAY) + IMDRAWPOINT _ (FUNCTION \DRAWPOINT.DISPLAY) + IMBLTCHAR _ (FUNCTION \MEDW.BLTCHAR) + IMXOFFSET _ (FUNCTION \MEDW.XOFFSET) + IMYOFFSET _ (FUNCTION \MEDW.YOFFSET))) + (SETQ \24DISPLAYFDEV (create FDEV + DEVICENAME _ '24DISPLAY + RESETABLE _ NIL + RANDOMACCESSP _ NIL + PAGEMAPPED _ NIL + CLOSEFILE _ (FUNCTION NILL) + DELETEFILE _ (FUNCTION NILL) + GETFILEINFO _ (FUNCTION NILL) + OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) + NAME] + READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + SETFILEINFO _ (FUNCTION NILL) + GENERATEFILES _ (FUNCTION \GENERATENOFILES) + TRUNCATEFILE _ (FUNCTION NILL) + WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) + GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) + NAME] + REOPENFILE _ [FUNCTION (LAMBDA (NAME) + NAME] + EVENTFN _ (FUNCTION NILL) + DIRECTORYNAMEP _ (FUNCTION NILL) + HOSTNAMEP _ (FUNCTION NILL) + BIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BOUT _ (FUNCTION \DSPPRINTCHAR) + PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) + BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) + BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) + DEVICEINFO _ (create DISPLAYSTATE) + WINDOWOPS _ NIL)) + (\DEFINEDEVICE NIL \24DISPLAYFDEV]) (\DISPLAYSTREAMTYPEBPP [LAMBDA (DISPLAYSTREAMTYPE) (* kbr%: " 6-Feb-86 18:14") (SELECTQ DISPLAYSTREAMTYPE (DISPLAY 1) (4DISPLAY 4) (8DISPLAY 8) (24DISPLAY 24) (SHOULDNT]) ) (ADDTOVAR IMAGESTREAMTYPES (DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) (4DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) (8DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)) (24DISPLAY (OPENSTREAM OPENDISPLAYSTREAM) (FONTCREATE \CREATEDISPLAYFONT) (FONTSAVAILABLE \SEARCHDISPLAYFONTFILES))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DisplayFDEV \4DISPLAYFDEV \8DISPLAYFDEV \24DISPLAYFDEV) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\DISPLAYINIT) (\4DISPLAYINIT) (\8DISPLAYINIT) (\24DISPLAYINIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA IMAGESTREAMP) ) (PUTPROPS IMAGEIO COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3354 12111 (IMAGESTREAMP 3364 . 4196) (IMAGESTREAMTYPE 4198 . 4411) (IMAGESTREAMTYPEP 4413 . 5048) (OPENIMAGESTREAM 5050 . 10004) (\GOOD.DASHLST 10006 . 12109)) (12146 14443 ( DRAWDASHEDLINE 12156 . 14441)) (14444 21784 (DSPBACKCOLOR 14454 . 14826) (DSPBOTTOMMARGIN 14828 . 15213) (DSPCOLOR 15215 . 15579) (DSPCLIPPINGREGION 15581 . 16286) (DSPRESET 16288 . 16568) (DSPFONT 16570 . 16934) (DSPLEFTMARGIN 16936 . 17317) (DSPLINEFEED 17319 . 17619) (DSPOPERATION 17621 . 17998) (DSPRIGHTMARGIN 18000 . 18383) (DSPTOPMARGIN 18385 . 18764) (DSPSCALE 18766 . 19133) (DSPSPACEFACTOR 19135 . 19528) (DSPXPOSITION 19530 . 19835) (DSPYPOSITION 19837 . 20142) (DSPROTATE 20144 . 20439) ( DSPPUSHSTATE 20441 . 20687) (DSPPOPSTATE 20689 . 20932) (DSPDEFAULTSTATE 20934 . 21186) (DSPSCALE2 21188 . 21479) (DSPTRANSLATE 21481 . 21782)) (21785 30586 (DSPNEWPAGE 21795 . 22487) (DRAWBETWEEN 22489 . 23191) (DRAWCIRCLE 23193 . 23689) (DRAWARC 23691 . 24208) (DRAWCURVE 24210 . 24887) ( DRAWELLIPSE 24889 . 25675) (DRAWLINE 25677 . 26067) (DRAWPOLYGON 26069 . 26524) (DRAWPOINT 26526 . 26945) (FILLPOLYGON 26947 . 27513) (DRAWTO 27515 . 27933) (FILLCIRCLE 27935 . 28158) (MOVETO 28160 . 28524) (RELDRAWTO 28526 . 29443) (BITMAPIMAGESIZE 29445 . 29616) (SCALEDBITBLT 29618 . 30584)) (30587 37626 (\DRAWPOINT.GENERIC 30597 . 30944) (\DRAWPOLYGON.GENERIC 30946 . 33254) (\DRAWCIRCLE.GENERIC 33256 . 34914) (\DRAWELLIPSE.GENERIC 34916 . 37624)) (37627 43013 (\IMAGEIOINIT 37637 . 41770) ( \NOIMAGE.DSPFONT 41772 . 42847) (\UNIMPIMAGEOP 42849 . 43011)) (43136 46260 (INSURE.BRUSH 43146 . 44520) (BRUSHP 44522 . 45312) (\POSSIBLECOLOR 45314 . 45865) (NEGSHADE 45867 . 46258)) (46820 47504 ( DASHINGP 46830 . 47160) (INSURE.DASHING 47162 . 47502)) (57806 78002 (\DisplayEventFn 57816 . 58326) ( \DISPLAYINIT 58328 . 63754) (\4DISPLAYINIT 63756 . 68393) (\8DISPLAYINIT 68395 . 73034) ( \24DISPLAYINIT 73036 . 77743) (\DISPLAYSTREAMTYPEBPP 77745 . 78000))))) STOP \ No newline at end of file diff --git a/sources/IMPLICIT-KEY-HASH b/sources/IMPLICIT-KEY-HASH new file mode 100644 index 00000000..0244baf1 --- /dev/null +++ b/sources/IMPLICIT-KEY-HASH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "16-May-90 18:22:09" IL:|{DSK}local>lde>lispcore>sources>IMPLICIT-KEY-HASH.;2| 13907 IL:|changes| IL:|to:| (IL:VARS IL:IMPLICIT-KEY-HASHCOMS) IL:|previous| IL:|date:| "24-Jan-88 16:54:16" IL:|{DSK}local>lde>lispcore>sources>IMPLICIT-KEY-HASH.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:IMPLICIT-KEY-HASHCOMS) (IL:RPAQQ IL:IMPLICIT-KEY-HASHCOMS ((IL:STRUCTURES IMPLICIT-KEY-HASH-TABLE) (IL:VARIABLES *DELETED-IMPLICIT-HASH-SLOT*) (IL:FUNCTIONS MAKE-IMPLICIT-KEY-HASH-TABLE GET-IMPLICIT-KEY-HASH PUT-IMPLICIT-KEY-HASH IMPLICIT-KEY-MAP-HASH CLEAR-IMPLICIT-KEY-HASH IMPLICIT-KEY-REHASH ADJUST-IMPLICIT-KEY-HASH) (IL:FUNCTIONS GET-IK-VALUE PUT-IK-VALUE GET-IK-KEY REPROBE 16BIT-+) (IL:SETFS GET-IMPLICIT-KEY-HASH GET-IK-VALUE) (FILE-ENVIRONMENTS "IMPLICIT-KEY-HASH"))) (DEFSTRUCT (IMPLICIT-KEY-HASH-TABLE (:CONC-NAME IK-HASH-) (:CONSTRUCTOR %MAKE-IK-HASH-TABLE) (:COPIER NIL) (:PREDICATE NIL) (:FAST-ACCESSORS T)) BASE (LAST-INDEX 0 :TYPE (UNSIGNED-BYTE 16)) (NUM-SLOTS 0 :TYPE (UNSIGNED-BYTE 16)) (NUM-KEYS 0 :TYPE (UNSIGNED-BYTE 16)) (NULL-SLOTS 0 :TYPE (UNSIGNED-BYTE 16)) KEY-ACCESSOR) (DEFVAR *DELETED-IMPLICIT-HASH-SLOT* "Unique string") (DEFUN MAKE-IMPLICIT-KEY-HASH-TABLE (&OPTIONAL (MIN-KEYS 20) (KEY-ACCESSOR :FIRST)) (IL:* IL:|;;| "Does eq hashing") (LET* ((NUM-SLOTS (IL:* IL:|;;| "num-slots is always a power of two") (DO ((IDEAL-SIZE (ASH (TRUNCATE (1- MIN-KEYS) 3) 2)) (I 8 (+ I I))) ((> I IDEAL-SIZE) I))) (LOGICAL-SLOTS (IL:* IL:|;;| "75% of NUM-SLOTS") (+ (ASH NUM-SLOTS -1) (ASH NUM-SLOTS -2)))) (%MAKE-IK-HASH-TABLE :BASE (IL:\\ALLOCBLOCK NUM-SLOTS IL:PTRBLOCK.GCT) :LAST-INDEX (1- NUM-SLOTS) :NUM-SLOTS LOGICAL-SLOTS :NUM-KEYS 0 :NULL-SLOTS LOGICAL-SLOTS :KEY-ACCESSOR KEY-ACCESSOR))) (DEFUN GET-IMPLICIT-KEY-HASH (ITEM IK-HASH-TABLE) (IF (NOT (TYPEP IK-HASH-TABLE 'IMPLICIT-KEY-HASH-TABLE)) (ERROR "Not an implicit key hash table: ~s" IK-HASH-TABLE)) (IL:* IL:|;;| "Do first index outside of loop, so don't have to do setup on fast case") (PROG* ((BITS (IL:\\EQHASHINGBITS ITEM)) (LIMIT (IK-HASH-LAST-INDEX IK-HASH-TABLE)) (INDEX (LOGAND BITS LIMIT)) (BASE (IK-HASH-BASE IK-HASH-TABLE)) (VALUE (GET-IK-VALUE BASE INDEX)) (KEY-ACCESSOR (IK-HASH-KEY-ACCESSOR IK-HASH-TABLE)) (DELETED-INDICATOR *DELETED-IMPLICIT-HASH-SLOT*) REPROBE) (COND ((EQ VALUE DELETED-INDICATOR) (IL:* IL:|;;| "Deleted slot -- continue") ) (VALUE (IL:* IL:|;;| "Slot is occupied ") (IF (EQ ITEM (GET-IK-KEY VALUE KEY-ACCESSOR)) (GO FOUND) (IL:* IL:|;;| "Else try again") )) (T (IL:* IL:|;;| "Null slot") (RETURN NIL))) (IL:* IL:|;;| "Compute reprobe interval") (SETQ REPROBE (REPROBE BITS LIMIT)) LP (IL:* IL:|;;| "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND") (SETQ INDEX (LOGAND (16BIT-+ INDEX REPROBE) LIMIT)) (SETQ VALUE (GET-IK-VALUE BASE INDEX)) (COND ((EQ VALUE DELETED-INDICATOR) (IL:* IL:|;;| "Deleted slot -- continue") ) (VALUE (IL:* IL:|;;| "Slot is occupied ") (IF (EQ ITEM (GET-IK-KEY VALUE KEY-ACCESSOR)) (GO FOUND) (IL:* IL:|;;| "Else try again") )) (T (IL:* IL:|;;| "Null slot") (RETURN NIL))) (GO LP) FOUND (RETURN VALUE))) (DEFUN PUT-IMPLICIT-KEY-HASH (ITEM IK-HASH-TABLE NEW-VALUE) (IL:* IL:|;;| "Puthash nil is equivalent to remhash for these tables") (IF (NOT (TYPEP IK-HASH-TABLE 'IMPLICIT-KEY-HASH-TABLE)) (ERROR "Not an implicit key hash table: ~s" IK-HASH-TABLE)) (PROG ((BITS (IL:\\EQHASHINGBITS ITEM)) (LIMIT (IK-HASH-LAST-INDEX IK-HASH-TABLE)) (BASE (IK-HASH-BASE IK-HASH-TABLE)) (KEY-ACCESSOR (IK-HASH-KEY-ACCESSOR IK-HASH-TABLE)) (DELETED-INDICATOR *DELETED-IMPLICIT-HASH-SLOT*) INDEX VALUE FIRST-INDEX REPROBE DELETED-SLOT-INDEX) PHTOP (IL:* IL:|;;| "Handle first probe outside loop in case it wins") (SETQ INDEX (LOGAND BITS LIMIT)) (SETQ VALUE (GET-IK-VALUE BASE INDEX)) (COND ((EQ VALUE DELETED-INDICATOR) (IL:* IL:|;;| "Found a deleted slot -- continue lookup") (SETQ DELETED-SLOT-INDEX INDEX)) (VALUE (IL:* IL:|;;| "Slot is occupied") (IF (EQ ITEM (GET-IK-KEY VALUE KEY-ACCESSOR)) (GO FOUND) (IL:* IL:|;;| "else try again") )) (T (IL:* IL:|;;| "Empty slot") (GO ADDNEWENTRY))) (IL:* IL:|;;| "Chase reprobe chain") (SETQ FIRST-INDEX INDEX) (SETQ REPROBE (REPROBE BITS LIMIT)) LP (SETQ INDEX (LOGAND (16BIT-+ INDEX REPROBE) LIMIT)) (WHEN (EQ INDEX FIRST-INDEX) (IL:* IL:|;;| "We don't allow full occupancy, so if we get to the beginning without finding an empty slot, we must have found a deleted one") (SETQ INDEX (OR DELETED-SLOT-INDEX (ERROR "No vacant slot in Implicit key hash table: ~s" IK-HASH-TABLE))) (GO ADDNEWENTRY)) (SETQ VALUE (GET-IK-VALUE BASE INDEX)) (COND ((EQ VALUE DELETED-INDICATOR) (IL:* IL:|;;| "Found a deleted slot -- continue lookup") (SETQ DELETED-SLOT-INDEX INDEX)) (VALUE (IL:* IL:|;;| "Slot is occupied") (IF (EQ ITEM (GET-IK-KEY VALUE KEY-ACCESSOR)) (GO FOUND) (IL:* IL:|;;| "else try again") )) (T (IL:* IL:|;;| "Empty slot") (IF DELETED-SLOT-INDEX (SETQ INDEX DELETED-SLOT-INDEX)) (GO ADDNEWENTRY))) (GO LP) FOUND (IL:UNINTERRUPTABLY (SETF (GET-IK-VALUE BASE INDEX) (OR NEW-VALUE DELETED-INDICATOR)) (IF (NULL NEW-VALUE) (DECF (IK-HASH-NUM-KEYS IK-HASH-TABLE)))) (RETURN NEW-VALUE) ADDNEWENTRY (IL:* IL:|;;| "Didn't find this item in table.") (IF (NULL NEW-VALUE) (IL:* IL:|;;| "Nothing to add") (RETURN NEW-VALUE)) (WHEN (EQ 0 (IK-HASH-NULL-SLOTS IK-HASH-TABLE)) (IL:UNINTERRUPTABLY (LET* ((NUM-SLOTS (IK-HASH-NUM-SLOTS IK-HASH-TABLE)) (NEW-ARRAY (IMPLICIT-KEY-REHASH IK-HASH-TABLE (MAKE-IMPLICIT-KEY-HASH-TABLE (IL:* IL:|;;| "1.5 times NUM-SLOTS") (+ NUM-SLOTS (ASH (1+ NUM-SLOTS) -1)) KEY-ACCESSOR)))) (SETQ IK-HASH-TABLE (ADJUST-IMPLICIT-KEY-HASH IK-HASH-TABLE NEW-ARRAY)) (IL:* IL:|;;| "update local state") (SETQ LIMIT (IK-HASH-LAST-INDEX IK-HASH-TABLE)) (SETQ BASE (IK-HASH-BASE IK-HASH-TABLE)) (IL:* IL:|;;| "Non-NIL DELSLOT is an index into the old array") (SETQ DELETED-SLOT-INDEX NIL))) (GO PHTOP)) (IL:UNINTERRUPTABLY (IF (NOT (EQ INDEX DELETED-SLOT-INDEX)) (DECF (IK-HASH-NULL-SLOTS IK-HASH-TABLE))) (INCF (IK-HASH-NUM-KEYS IK-HASH-TABLE)) (SETF (GET-IK-VALUE BASE INDEX) NEW-VALUE)) (RETURN NEW-VALUE))) (DEFUN IMPLICIT-KEY-MAP-HASH (FN IK-HASH-TABLE) (IF (NOT (TYPEP IK-HASH-TABLE 'IMPLICIT-KEY-HASH-TABLE)) (ERROR "Not an implicit key hash table: ~s" IK-HASH-TABLE)) (LET* ((BASE (IK-HASH-BASE IK-HASH-TABLE)) (LAST-INDEX (1+ (IK-HASH-LAST-INDEX IK-HASH-TABLE))) (LAST-ADDRESS (IL:\\ADDBASE (IL:\\ADDBASE BASE LAST-INDEX) LAST-INDEX)) (KEY-ACCESSOR (IK-HASH-KEY-ACCESSOR IK-HASH-TABLE)) (NULL-SLOT-INDICATOR *DELETED-IMPLICIT-HASH-SLOT*) VALUE) (LOOP (IF (EQ BASE LAST-ADDRESS) (RETURN NIL)) (SETQ VALUE (IL:\\GETBASEPTR BASE 0)) (IF (AND VALUE (NOT (EQ VALUE NULL-SLOT-INDICATOR))) (FUNCALL FN VALUE (GET-IK-KEY VALUE KEY-ACCESSOR))) (SETQ BASE (IL:\\ADDBASE BASE 2))))) (DEFUN CLEAR-IMPLICIT-KEY-HASH (IK-HASH-TABLE) (IF (NOT (TYPEP IK-HASH-TABLE 'IMPLICIT-KEY-HASH-TABLE)) (ERROR "Not an implicit key hash table: ~s" IK-HASH-TABLE)) (LET* ((BASE (IK-HASH-BASE IK-HASH-TABLE)) (LAST-INDEX (1+ (IK-HASH-LAST-INDEX IK-HASH-TABLE))) (LAST-ADDRESS (IL:\\ADDBASE (IL:\\ADDBASE BASE LAST-INDEX) LAST-INDEX))) (IL:UNINTERRUPTABLY (LOOP (IF (EQ BASE LAST-ADDRESS) (RETURN NIL)) (IL:\\RPLPTR BASE 0 NIL) (SETQ BASE (IL:\\ADDBASE BASE 2))) (SETF (IK-HASH-NULL-SLOTS IK-HASH-TABLE) (IK-HASH-NUM-SLOTS IK-HASH-TABLE)) (SETF (IK-HASH-NUM-KEYS IK-HASH-TABLE) 0)) IK-HASH-TABLE)) (DEFUN IMPLICIT-KEY-REHASH (FROM-TABLE TO-TABLE) (IF (NOT (TYPEP FROM-TABLE 'IMPLICIT-KEY-HASH-TABLE)) (ERROR "Not an implicit key hash table: ~s" FROM-TABLE)) (CLEAR-IMPLICIT-KEY-HASH TO-TABLE) (IF (NOT (< (IK-HASH-NUM-SLOTS FROM-TABLE) (IK-HASH-NUM-SLOTS TO-TABLE))) (ERROR "To table too small: ~s" TO-TABLE)) (LET* ((FROM-BASE (IK-HASH-BASE FROM-TABLE)) (FROM-LAST-INDEX (1+ (IK-HASH-LAST-INDEX FROM-TABLE))) (LAST-ADDRESS (IL:\\ADDBASE (IL:\\ADDBASE FROM-BASE FROM-LAST-INDEX) FROM-LAST-INDEX)) (KEY-ACCESSOR (IK-HASH-KEY-ACCESSOR FROM-TABLE)) (NULL-SLOT-INDICATOR *DELETED-IMPLICIT-HASH-SLOT*) VALUE) (LOOP (IF (EQ FROM-BASE LAST-ADDRESS) (RETURN TO-TABLE)) (SETQ VALUE (IL:\\GETBASEPTR FROM-BASE 0)) (IF (AND VALUE (NOT (EQ VALUE NULL-SLOT-INDICATOR))) (PUT-IMPLICIT-KEY-HASH (GET-IK-KEY VALUE KEY-ACCESSOR) TO-TABLE VALUE)) (SETQ FROM-BASE (IL:\\ADDBASE FROM-BASE 2))))) (DEFUN ADJUST-IMPLICIT-KEY-HASH (OLD-IK-TABLE NEW-IK-TABLE) (IL:UNINTERRUPTABLY (SETF (IK-HASH-BASE OLD-IK-TABLE) (IK-HASH-BASE NEW-IK-TABLE)) (SETF (IK-HASH-LAST-INDEX OLD-IK-TABLE) (IK-HASH-LAST-INDEX NEW-IK-TABLE)) (SETF (IK-HASH-NUM-SLOTS OLD-IK-TABLE) (IK-HASH-NUM-SLOTS NEW-IK-TABLE)) (SETF (IK-HASH-NUM-KEYS OLD-IK-TABLE) (IK-HASH-NUM-KEYS NEW-IK-TABLE)) (SETF (IK-HASH-NULL-SLOTS OLD-IK-TABLE) (IK-HASH-NULL-SLOTS NEW-IK-TABLE)) (SETF (IK-HASH-KEY-ACCESSOR OLD-IK-TABLE) (IK-HASH-KEY-ACCESSOR NEW-IK-TABLE))) OLD-IK-TABLE) (DEFMACRO GET-IK-VALUE (BASE INDEX) `(IL:\\GETBASEPTR ,BASE (IL:LLSH ,INDEX 1))) (DEFMACRO PUT-IK-VALUE (BASE INDEX NEW-VALUE) `(IL:\\RPLPTR ,BASE (IL:LLSH ,INDEX 1) ,NEW-VALUE)) (DEFMACRO GET-IK-KEY (VALUE KEY-ACCESSOR) (ONCE-ONLY (VALUE KEY-ACCESSOR) `(IF (EQ KEY-ACCESSOR :FIRST) (IL:\\GETBASEPTR ,VALUE 0) (FUNCALL ,KEY-ACCESSOR ,VALUE)))) (DEFMACRO REPROBE (BITS LAST-INDEX) `(LOGIOR (LOGAND (LOGXOR ,BITS (IL:LRSH ,BITS 8)) (MIN 63 ,LAST-INDEX)) 1)) (DEFMACRO 16BIT-+ (A B) `(IL:\\LOLOC (IL:\\ADDBASE ,A ,B))) (DEFSETF GET-IMPLICIT-KEY-HASH PUT-IMPLICIT-KEY-HASH) (DEFSETF GET-IK-VALUE PUT-IK-VALUE) (DEFINE-FILE-ENVIRONMENT "IMPLICIT-KEY-HASH" :READTABLE "XCL" :PACKAGE "XCL" :COMPILER :COMPILE-FILE) (IL:PUTPROPS IL:IMPLICIT-KEY-HASH IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/INSPECT b/sources/INSPECT new file mode 100644 index 00000000..b4af5df8 --- /dev/null +++ b/sources/INSPECT @@ -0,0 +1,35 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "21-Apr-2018 08:08:07" {DSK}kaplan>Local>medley3.5>lispcore>sources>INSPECT.;7 115481 changes to%: (VARS INSPECTCOMS) previous date%: "21-Apr-2018 07:33:25" {DSK}kaplan>Local>medley3.5>lispcore>sources>INSPECT.;6) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1991, 1993, 1995, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT INSPECTCOMS) (RPAQQ INSPECTCOMS [(COMS (* ;; "functions to implement an item window. An ITEM window is a window that contains SELECTABLEITEMS. An item from the window is selected using the left button. The middle button will then bring up a menu of commands that can be applyed to the selected item. An INSPECTW is a special type of ITEMW that maintains properties and their values for a datum. It is used by the inspector.") (FNS INSPECTW.CREATE INSPECTW.REPAINTFN INSPECTW.REDISPLAY \INSPECTW.VALUE.MARGIN INSPECTW.REPLACE INSPECTW.SELECTITEM \INSPECTW.REDISPLAYPROP INSPECTW.FETCH INSPECTW.PROPERTIES DECODE.WINDOW.ARG DEFAULT.INSPECTW.PROPCOMMANDFN DEFAULT.INSPECTW.VALUECOMMANDFN DEFAULT.INSPECTW.TITLECOMMANDFN \SELITEM.FROM.PROPERTY \INSPECT.COMPUTE.TITLE LEVELEDFORM MAKEWITHINREGION) (FNS ITEMW.REPAINTFN \ITEM.WINDOW.BUTTON.HANDLER \ITEM.WINDOW.SELECTION.HANDLER \INSPECTW.COMMAND.HANDLER ITEM.WINDOW.SET.STACK.ARG REPLACESTKARG IN/ITEM? \ITEMW.DESELECTITEM \ITEMW.SELECTITEM \ITEMW.CLEARSELECTION \ITEMW.FLIPITEM PRINTANDBOX PRINTATBOX ITEMOFPROPERTYVALUE) (FNS \ITEM.WINDOW.COPY.HANDLER \ITEMW.FLIPCOPY BKSYSBUF.GENERAL) (RECORDS SELECTABLEITEM) (VARS (MAXINSPECTARRAYLEVEL 300) (MAXINSPECTCDRLEVEL 50) MinSpaceBetweenProperyAndValue MaxInspectorPropertyValueWidth MaxValueLeftMargin PropertyLeftMargin)) (COMS (* ; "functions for the inspector") (FNS INSPECT \APPLYINSPECTMACRO INSPECT/BITMAP INSPECT/DATATYPE INSPECTABLEFIELDNAMES REMOVEDUPS INSPECT/ARRAY INSPECT/TOP/LEVEL/LIST INSPECT/PROPLIST NONSYSPROPNAMES INSPECT/LISTP ALISTP PROPLISTP INSPECT/ALIST ASSOCGET /ASSOCPUT INSPECT/PLIST INSPECT/TYPERECORD INSPECT/AS/RECORD SELECT.LIST.INSPECTOR STANDARDEDITE NTHTOPLEVELELT SETNTHTOPLEVELELT DEDITE FINDRECDECL FINDSYSRECDECL MAKE-INSPECTOR-PROFILE CONFIRM-SET) (GLOBALVARS INSPECTMACROS INSPECTALLFIELDSFLG SetPropertyMenu SetStackMenu InspectMenu PropertyLeftMargin MaxValueLeftMargin INSPECTPRINTLEVEL InspectBitmapMenu ItemWCommandMenu InspectPropsMenu MAXINSPECTARRAYLEVEL MAXINSPECTCDRLEVEL MaxInspectorWindowWidth MaxInspectorWindowHeight INSPECT.HUNK.COMMANDS USERRECLST SYSPROPS IT MinSpaceBetweenProperyAndValue MaxInspectorPropertyValueWidth) (INITVARS (INSPECTALLFIELDSFLG T) (MaxInspectorWindowWidth 330) (MaxInspectorWindowHeight 606)) (VARS INSPECTPRINTLEVEL) (* ;; "To deal with profiles in spawned processes") (MACROS EVAL.AS.PROCESS.WITH.PROFILE WITH-INSPECTOR-ENV)) (COMS (* ; "Atom inspector") (FNS INSPECT/ATOM SELECT.ATOM.ASPECT INSPECT/AS/FUNCTION SELECT.FNS.EDITOR)) (COMS (* ; "Compiled code inspector") (FNS INSPECTCODE \TEDIT.INSPECTCODE \INSPECT/CODE/RESHAPEFN \INSPECT/CODE/REPAINTFN)) (COMS (* ; "Hash table inspector") (FNS INSPECT/HARRAYP HARRAYKEYS INSPECTW.GETHASH INSPECTW.PUTHASH)) [COMS (* ; "Readtable, termtable inspectors") (FNS RDTBL\NONOTHERCODES GETSYNTAXPROP SETSYNTAXPROP GETTTBLPROP SETTTBLPROP) (ADDVARS (INSPECTMACROS (READTABLEP RDTBL\NONOTHERCODES GETSYNTAXPROP SETSYNTAXPROP) (TERMTABLEP (CHARDELETE WORDDELETE LINEDELETE RETYPE CTRLV EOL RAISE ECHOMODE LINEDELETESTR 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL ECHODELS? CONTROL 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) GETTTBLPROP SETTTBLPROP] (COMS (* ; "Hunk inspector") (FNS INSPECT/AS/BLOCKRECORD INSPECT/TYPELESS LIST-ALL-BLOCKRECORDS INSPECT/HUNK \INSPECT.DATATYPE.RAW.FETCH \INSPECT.FETCH.8 \INSPECT.FETCH.32 \INSPECT.FETCH.CHAR \INSPECT.FETCH.FATCHAR \INSPECT.FETCH.PTR \INSPECT.STORE.8 \INSPECT.STORE.16 \INSPECT.STORE.32 \INSPECT.STORE.CHAR \INSPECT.STORE.FATCHAR \INSPECT.STORE.PTR INSPECT/MAKE/CCODEP) (INITVARS (INSPECT.HUNK.COMMANDS '(("As 8-bit array" '(8 \GETBASEBYTE \INSPECT.STORE.8) ) ("As 16-bit array" '(16 \GETBASE \INSPECT.STORE.16)) ("As 32-bit array" '(32 \INSPECT.FETCH.32 \INSPECT.STORE.32)) ("As Character array" '(8 \INSPECT.FETCH.CHAR \INSPECT.STORE.CHAR)) ("As Fat Character array" '(16 \INSPECT.FETCH.FATCHAR \INSPECT.STORE.FATCHAR ]) (* ;; "functions to implement an item window. An ITEM window is a window that contains SELECTABLEITEMS. An item from the window is selected using the left button. The middle button will then bring up a menu of commands that can be applyed to the selected item. An INSPECTW is a special type of ITEMW that maintains properties and their values for a datum. It is used by the inspector." ) (DEFINEQ (INSPECTW.CREATE [LAMBDA (DATUM PROPERTIES FETCHFN STOREFN PROPCOMMANDFN VALUECOMMANDFN TITLECOMMANDFN TITLE SELECTIONFN WHERE PROPPRINTFN) (* ; "Edited 5-Aug-87 09:52 by jop") (* ;; "Creates a window with an item list made up of properties and values") (LET ((PROFILE (MAKE-INSPECTOR-PROFILE))) (WITH-INSPECTOR-ENV PROFILE (PROG [WINDOW VALUE PROPMENU VALUEMENU VALUEMARGIN SELITEMS MAXVALUEWIDTH (IWFONT (DEFAULTFONT 'DISPLAY)) (PROPERTIESLST (COND ((OR (NULL PROPERTIES) (LISTP PROPERTIES)) PROPERTIES) (T (* ;  "allow PROPERTIES to be a function") (APPLY* PROPERTIES DATUM] (SETQ VALUEMARGIN (\INSPECTW.VALUE.MARGIN (COND (PROPPRINTFN (for PROP in PROPERTIESLST collect (APPLY* PROPPRINTFN PROP DATUM))) (T PROPERTIESLST)) IWFONT)) (SETQ MAXVALUEWIDTH (COND (PROPERTIESLST (IMIN (IMAX (bind X for PROP in PROPERTIESLST largest (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) IWFONT T) finally (RETURN $$EXTREME)) 16) MaxInspectorPropertyValueWidth)) (T (* ; "no fields to inspect") 30))) (SETQ WINDOW (DECODE.WINDOW.ARG WHERE (IPLUS VALUEMARGIN MAXVALUEWIDTH) (IMIN MaxInspectorWindowHeight (ITIMES (COND (PROPERTIESLST (LENGTH PROPERTIESLST)) (T 1)) (FONTHEIGHT IWFONT))) (\INSPECT.COMPUTE.TITLE TITLE DATUM))) (DSPFONT IWFONT WINDOW) (DSPRIGHTMARGIN 50000 WINDOW) (* ;  "for now, can't handle multiple PROPCOMMANDFN output. Put right margin way out.") (WINDOWPROP WINDOW 'DATUM DATUM) (* ;  "initialize the properties of the window.") (WINDOWPROP WINDOW 'STOREFN STOREFN) (WINDOWPROP WINDOW 'FETCHFN FETCHFN) (WINDOWPROP WINDOW 'PROPCOMMANDFN PROPCOMMANDFN) (WINDOWPROP WINDOW 'VALUECOMMANDFN VALUECOMMANDFN) (WINDOWPROP WINDOW 'INSPECTWTITLE TITLE) (WINDOWPROP WINDOW 'TITLECOMMANDFN TITLECOMMANDFN) (WINDOWPROP WINDOW 'SELECTIONFN SELECTIONFN) (WINDOWPROP WINDOW 'PROPERTIES PROPERTIES) (WINDOWPROP WINDOW 'PROPPRINTFN PROPPRINTFN) (WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION \ITEM.WINDOW.BUTTON.HANDLER)) (WINDOWPROP WINDOW 'COPYBUTTONEVENTFN (FUNCTION \ITEM.WINDOW.COPY.HANDLER)) (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION INSPECTW.REPAINTFN)) (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (* ;; "when we create the window, record the read print environment so that the window methods can use the same one, rather than inheriting form the mouse process. ") (WINDOWPROP WINDOW 'PROFILE PROFILE) (RETURN (INSPECTW.REDISPLAY WINDOW NIL VALUEMARGIN]) (INSPECTW.REPAINTFN [LAMBDA (WINDOW REGION) (* ; "Edited 8-Apr-87 16:36 by jop") (* ;; "repaints the selectable items in (an inspect window. This knows that the items are stored in increasing order.)") (* ; " restore the profile that was used when the inspector was instantiated, so that packages, escapes etc. are the same.") [WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (COND [REGION (* ;  "only clip to region if a region is given.") (PROG ((SELITEMS (WINDOWPROP WINDOW 'SELECTABLEITEMS)) (WREG (DSPCLIPPINGREGION NIL WINDOW)) LINEBASE SELECTABLEITEMREGION PROPPRINTFN) (SETQ LINEBASE (fetch (REGION TOP) of WREG)) ABOVELP (* ; "skip those above the window.") (COND ((NULL SELITEMS) (RETURN)) ((IGREATERP (fetch (REGION BOTTOM) of (fetch ( SELECTABLEITEM SELECTABLEITEMREGION ) of (CAR SELITEMS)) ) LINEBASE) (SETQ SELITEMS (CDR SELITEMS)) (GO ABOVELP))) (* ; "determine the bottom line base") (SETQ LINEBASE (fetch (REGION BOTTOM) of WREG)) PRINTLP (* ;  "print them as long as they are visible.") (COND ((NULL SELITEMS) (RETURN)) ((IGREATERP [fetch (REGION PTOP) of (SETQ SELECTABLEITEMREGION (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of (CAR SELITEMS] LINEBASE) (* ;  "still possibly visible, check for horizontal fit before printing.") (COND ((REGIONSINTERSECTP REGION SELECTABLEITEMREGION) (PRINTATBOX [COND [[AND (EQ (fetch (SELECTABLEITEM ITEMINFOTYPE) of (CAR SELITEMS)) 'PROPERTY) (WINDOWPROP WINDOW 'DATUM) (SETQ PROPPRINTFN (WINDOWPROP WINDOW 'PROPPRINTFN] (* ;  "hook for property print functions Should be cleaned up.") (APPLY* PROPPRINTFN (fetch (SELECTABLEITEM ITEMINFO) of (CAR SELITEMS)) (WINDOWPROP WINDOW 'DATUM] (T (fetch (SELECTABLEITEM ITEMINFO) of (CAR SELITEMS] WINDOW SELECTABLEITEMREGION))) (SETQ SELITEMS (CDR SELITEMS)) (GO PRINTLP] (T (* ;  "if no region, use other repaintfn to repaint them all.") (ITEMW.REPAINTFN WINDOW] (* ;  "if there is a selected item, flip it too in case some of it was in the newly exposed area.") (AND (WINDOWPROP WINDOW 'CURRENTITEM) (\ITEMW.FLIPITEM (WINDOWPROP WINDOW 'CURRENTITEM) WINDOW]) (INSPECTW.REDISPLAY [LAMBDA (WINDOW PROPS VALUEMARGIN) (* ; "Edited 8-Apr-87 16:39 by jop") (* ;  "redisplays an itemw to get the newly updated fields.") (COND [PROPS (COND ((NLISTP PROPS) (\INSPECTW.REDISPLAYPROP WINDOW PROPS)) (T (for PROP in PROPS do (\INSPECTW.REDISPLAYPROP WINDOW PROP] (T (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (PROPERTIES (INSPECTW.PROPERTIES WINDOW)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (PROPCOMMANDFN (WINDOWPROP WINDOW 'PROPCOMMANDFN)) (VALUECOMMANDFN (WINDOWPROP WINDOW 'VALUECOMMANDFN)) (PROPPRINTFN (WINDOWPROP WINDOW 'PROPPRINTFN)) PROPERTY-PNAMES VALUE PROPMENU VALUEMENU SELITEMS) (SETQ PROPERTY-PNAMES (COND (PROPPRINTFN (for PROP in PROPERTIES collect (APPLY* PROPPRINTFN PROP DATUM) )) (T PROPERTIES))) [SETQ VALUEMARGIN (OR VALUEMARGIN (\INSPECTW.VALUE.MARGIN PROPERTY-PNAMES (DSPFONT NIL WINDOW] (* ; "remove old selected item if any") (\ITEMW.DESELECTITEM NIL WINDOW) (CLEARW WINDOW) (WINDOWPROP WINDOW 'TITLE (\INSPECT.COMPUTE.TITLE (WINDOWPROP WINDOW 'INSPECTWTITLE) DATUM WINDOW)) (* ;; "might be faster to only print and determine positions for the ones that are visible and keep track of which haven't been seen yet but this is easier for now.") (MOVETOUPPERLEFT WINDOW (DSPCLIPPINGREGION NIL WINDOW)) [WINDOWPROP WINDOW 'SELECTABLEITEMS (SETQ SELITEMS (for PROP in PROPERTIES as PROPNAME in PROPERTY-PNAMES join (COND [PROPNAME (LIST (create SELECTABLEITEM SELECTABLEITEMREGION _ (PRINTANDBOX PROPNAME WINDOW PropertyLeftMargin) COMMANDFN _ (OR PROPCOMMANDFN (FUNCTION DEFAULT.INSPECTW.PROPCOMMANDFN)) ITEMINFO _ PROP ITEMINFOTYPE _ 'PROPERTY) (create SELECTABLEITEM SELECTABLEITEMREGION _ (PRINTANDBOX (COND ((NLSETQ (SETQ VALUE (APPLY* FETCHFN DATUM PROP))) VALUE) (T (* ; "error during access.") (SETQ VALUE "** error during access **"))) WINDOW VALUEMARGIN MinSpaceBetweenProperyAndValue) COMMANDFN _ (OR VALUECOMMANDFN (FUNCTION DEFAULT.INSPECTW.VALUECOMMANDFN)) ITEMINFO _ VALUE ITEMINFOTYPE _ (CONS PROP] (T (* ;  "if property name returns NIL, print value in middle") (CONS (create SELECTABLEITEM SELECTABLEITEMREGION _ (PRINTANDBOX (COND ((NLSETQ (SETQ VALUE (APPLY* FETCHFN DATUM PROP))) VALUE) (T (* ; "error during access.") (SETQ VALUE "** error during access **" ))) WINDOW (LRSH VALUEMARGIN 1)) COMMANDFN _ (OR VALUECOMMANDFN (FUNCTION DEFAULT.INSPECTW.VALUECOMMANDFN )) ITEMINFO _ VALUE ITEMINFOTYPE _ (CONS PROP] (WINDOWPROP WINDOW 'EXTENT (PROG [(NOWEXTENT (COND [SELITEMS (create REGION using (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of (CAR SELITEMS] (T (* ;  "don't have any items; make extent empty.") (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 0 HEIGHT _ 0] (for SELITEM in (CDR SELITEMS) do (EXTENDREGION NOWEXTENT (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of SELITEM))) (RETURN NOWEXTENT))) (* ;  "limit scrolling so that it won't go off the top.") (WINDOWPROP WINDOW 'SCROLLEXTENTUSE 'LIMIT) (RETURN WINDOW]) (\INSPECTW.VALUE.MARGIN [LAMBDA (PROPS FONT) (* ; "Edited 2-Feb-87 17:15 by jop") (* ;; "returns the x position in which the values of the properties should print.") (IMIN (IPLUS (IMAX (MAXSTRINGWIDTH PROPS FONT T) 16) MinSpaceBetweenProperyAndValue PropertyLeftMargin) MaxValueLeftMargin]) (INSPECTW.REPLACE [LAMBDA (INSPECTW PROPERTY NEWVALUE) (* ; "Edited 22-Jun-87 17:43 by jop") (PROG [(DATUM (WINDOWPROP INSPECTW 'DATUM)) (STOREFN (WINDOWPROP INSPECTW 'STOREFN] (OR STOREFN (ERROR INSPECTW " does not have a STOREFN.")) (OR DATUM (ERROR INSPECTW " doesn't have a DATUM")) [LET ((XCL:*EVAL-FUNCTION* 'CL:EVAL)) (* ;; "Use cl:eval, since it wouldn't choke on compiled closures") (EXEC-EVAL (LIST STOREFN (KWOTE DATUM) (KWOTE PROPERTY) (KWOTE NEWVALUE] (RETURN (\INSPECTW.REDISPLAYPROP INSPECTW PROPERTY]) (INSPECTW.SELECTITEM [LAMBDA (INSPECTW PROPERTY VALUEFLG) (* ; "Edited 3-Feb-87 16:41 by jop") (* ;; "makes a selection in an inspect window. If another item is selected, it is deselected. If VALUEFLG is non-NIL, the value of the property is selected, otherwise the property name is selected. If PROPERTY is NIL, any selected item is deselected and no item is selected. Returns the previously selected item structure.") (PROG [(PREVIOUS (WINDOWPROP INSPECTW 'CURRENTITEM] (AND PREVIOUS (\ITEMW.DESELECTITEM PREVIOUS INSPECTW)) (AND PROPERTY (\ITEMW.SELECTITEM (COND (VALUEFLG (ITEMOFPROPERTYVALUE PROPERTY INSPECTW)) (T (\SELITEM.FROM.PROPERTY INSPECTW PROPERTY))) INSPECTW)) (RETURN PREVIOUS]) (\INSPECTW.REDISPLAYPROP [LAMBDA (WINDOW PROPERTY) (* ; "Edited 10-Apr-87 16:31 by jop") (* ;; "refetches and displays a property of an inspect window. This is called when a property has changed, to update the display.") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (LET ((DATUM (WINDOWPROP WINDOW 'DATUM)) (OLDVALUEITEM (ITEMOFPROPERTYVALUE PROPERTY WINDOW)) (NEWVALUE (INSPECTW.FETCH WINDOW PROPERTY)) ITEMSELECTED? NEWVALUEREGION) (OR DATUM (ERROR WINDOW " doesn't have a DATUM")) (OR OLDVALUEITEM (ERROR "No value for a property in an INSPECTW" WINDOW)) (* ;  "if value being replace is selected, deselect it and reselect it when finished") (COND ((EQ OLDVALUEITEM (WINDOWPROP WINDOW 'CURRENTITEM)) (SETQ ITEMSELECTED? T) (\ITEMW.DESELECTITEM OLDVALUEITEM WINDOW))) (replace ITEMINFO of OLDVALUEITEM with NEWVALUE) (* ; "erase old stuff") (DSPFILL (fetch (SELECTABLEITEM SELECTABLEITEMREGION) of OLDVALUEITEM) (DSPTEXTURE NIL WINDOW) 'REPLACE WINDOW) (PROG1 [SETQ NEWVALUEREGION (replace (SELECTABLEITEM SELECTABLEITEMREGION) of OLDVALUEITEM with (PRINTATBOX NEWVALUE WINDOW (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of OLDVALUEITEM ] (EXTENDEXTENT WINDOW NEWVALUEREGION) (COND (ITEMSELECTED? (\ITEMW.SELECTITEM OLDVALUEITEM WINDOW))))]) (INSPECTW.FETCH [LAMBDA (INSPECTW PROPERTY) (* ; "Edited 3-Feb-87 16:51 by jop") (* ;; "retrieves the property value from an inspect window") (APPLY* (OR (WINDOWPROP INSPECTW 'FETCHFN) (ERROR INSPECTW " doesn't have a FETCHFN")) (OR (WINDOWPROP INSPECTW 'DATUM) (ERROR INSPECTW " doesn't have a DATUM")) PROPERTY]) (INSPECTW.PROPERTIES [LAMBDA (INSPECTW) (* ; "Edited 3-Feb-87 16:52 by jop") (* ;; "gets the list of properties from an INSPECTW.") (PROG [(PROPERTIES (WINDOWPROP INSPECTW 'PROPERTIES] (RETURN (COND ((OR (NULL PROPERTIES) (LISTP PROPERTIES)) PROPERTIES) (T (* ;  "allow PROPERTIES to be a function") (APPLY* PROPERTIES (WINDOWPROP INSPECTW 'DATUM]) (DECODE.WINDOW.ARG [LAMBDA (WHERESPEC WIDTH HEIGHT TITLE BORDER NOOPENFLG)(* ; "Edited 3-Feb-87 16:48 by jop") (* ;; "standard useful routine for decoding a window specification arg. WHERESPEC can be a window, a region, a position or NIL. If WHERESPEC is a window, the other args are ignored. This allows programs to override defaults by explicitly providing a window. If a position or NIL, WIDTH and HEIGHT are the dimensions of the new window. The returned window will be entirely on the screen, dimensions permitting.") (COND ((WINDOWP WHERESPEC) WHERESPEC) (T (CREATEW (COND ((REGIONP WHERESPEC) (MAKEWITHINREGION WHERESPEC)) [(AND (NUMBERP WIDTH) (NUMBERP HEIGHT)) (COND [(POSITIONP WHERESPEC) (MAKEWITHINREGION (CREATEREGION (fetch (POSITION XCOORD) of WHERESPEC) (fetch (POSITION YCOORD) of WHERESPEC ) (WIDTHIFWINDOW WIDTH BORDER) (HEIGHTIFWINDOW HEIGHT TITLE BORDER] (T (GETBOXREGION (WIDTHIFWINDOW WIDTH BORDER) (HEIGHTIFWINDOW HEIGHT TITLE BORDER) NIL NIL NIL (CONCAT "Specify position for " TITLE] (T NIL)) TITLE BORDER NOOPENFLG]) (DEFAULT.INSPECTW.PROPCOMMANDFN [LAMBDA (PROPERTY DATUM INSPECTW) (* ; "Edited 1-Dec-96 20:16 by rmk:") (* ; "Edited 22-Jun-87 16:41 by jop") (* ;; "allows the user to select a menu item to change the property in an inspect window.") (SELECTQ [MENU (COND ((type? MENU SetPropertyMenu) SetPropertyMenu) (T (SETQ SetPropertyMenu (create MENU ITEMS _ '((Set 'SET "Allows a new value to be entered" ) (Inspect 'INSPECT] (SET [ERSETQ (PROG ((OLDVALUEITEM (ITEMOFPROPERTYVALUE PROPERTY INSPECTW)) (PWINDOW (GETPROMPTWINDOW INSPECTW 3)) NEWVALUE) (RESETLST (RESETSAVE (\ITEMW.FLIPITEM OLDVALUEITEM INSPECTW) (LIST '\ITEMW.FLIPITEM OLDVALUEITEM INSPECTW)) (RESETSAVE (TTYDISPLAYSTREAM PWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLEARBUF T T) (printout T "Eval> ") (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) (* ;  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T)) (REMOVEPROMPTWINDOW INSPECTW) (RETURN (INSPECTW.REPLACE INSPECTW PROPERTY NEWVALUE]) (INSPECT (INSPECT PROPERTY)) NIL]) (DEFAULT.INSPECTW.VALUECOMMANDFN [LAMBDA (VALUE PROPERTY DATUM WINDOW) (* ; "Edited 28-Jan-93 16:50 by jds") (* ;; "allows the user to choose a way to inspect a value in a window") (SELECTQ (TYPENAME VALUE) ((LITATOM NEW-ATOM) (COND (VALUE (INSPECT/ATOM VALUE T)) (T (printout PROMPTWINDOW T "Can't inspect NIL.") (until (MOUSESTATE UP)) (CLRPROMPT)))) (BITMAP (INSPECT/BITMAP VALUE)) ((FIXP SMALLP FLOATP) (printout PROMPTWINDOW T "Can't Inspect " VALUE) (until (MOUSESTATE UP)) (CLRPROMPT)) (LISTP (* ;  "find out how to inspect the list.") (INSPECT/LISTP VALUE)) (SELECTQ [MENU (COND ((type? MENU InspectMenu) InspectMenu) (T (SETQ InspectMenu (create MENU ITEMS _ '((Inspect 'INSPECT/VALUE] (INSPECT/VALUE (INSPECT VALUE)) NIL]) (DEFAULT.INSPECTW.TITLECOMMANDFN [LAMBDA (INSPECTW DATUM) (* rrb "18-Apr-84 17:57") (SELECTQ [MENU (COND ((type? MENU ItemWCommandMenu) ItemWCommandMenu) (T (SETQ ItemWCommandMenu (create MENU ITEMS _ '((ReFetch 'REFETCH "ReFetches and redisplays the object's fields" ) (IT_datum 'SETIT "sets the variable IT to the object inspected in this window." ) (IT_selection 'SETITTOSEL "sets the variable IT to the item selected in this window." ] (REFETCH (INSPECTW.REDISPLAY INSPECTW)) (SETIT (SETQ IT DATUM)) (SETITTOSEL (COND [(WINDOWPROP INSPECTW 'CURRENTITEM) (SETQ IT (fetch (SELECTABLEITEM ITEMINFO) of (WINDOWPROP INSPECTW 'CURRENTITEM] (T (PROMPTPRINT "No item has been selected from this window.")))) NIL]) (\SELITEM.FROM.PROPERTY [LAMBDA (INSPECTW PROPERTY) (* rrb " 6-MAR-82 17:50") (for SELITEM in (WINDOWPROP INSPECTW 'SELECTABLEITEMS) when (AND (EQ (fetch (SELECTABLEITEM ITEMINFO) of SELITEM) PROPERTY) (EQ (fetch (SELECTABLEITEM ITEMINFOTYPE) of SELITEM) 'PROPERTY)) do (RETURN SELITEM]) (\INSPECT.COMPUTE.TITLE [LAMBDA (TITLE DATUM WINDOW) (* ; "Edited 18-Mar-87 15:23 by jrb:") (* ;  "computes the title for an inspectw from its title field and its datum.") (PROG (VALUE) (RETURN (COND ((NULL TITLE) (CONCAT (LET ((*PRINT-LEVEL* 3) (*PRINT-LENGTH* 4)) (CL:PRINC-TO-STRING DATUM)) " Inspector")) ((EQ TITLE 'DON'T) (* ; "no title") NIL) ((LITATOM TITLE) (* ;  "it is a function to compute the title.") (COND ((NEQ (SETQ VALUE (APPLY* TITLE DATUM WINDOW)) 'DON'T) VALUE) (T NIL))) (T TITLE]) (LEVELEDFORM [LAMBDA (EXP CARLEV CDRLEV) (* ; "Edited 3-Feb-87 16:35 by jop") (* ;; "returns a copy of EXP that is abbreviated at CARLEV depth in the car direction and CDRLEV depth in the CDR direction") (COND ((NLISTP EXP) EXP) ((EQ CARLEV 0) '&) (T (CONS (LEVELEDFORM (CAR EXP) (SUB1 CARLEV) CDRLEV) (COND [(EQ CDRLEV 0) (COND ((CDR EXP) '(--] (T (LEVELEDFORM (CDR EXP) CARLEV (SUB1 CDRLEV]) (MAKEWITHINREGION [LAMBDA (REGION LIMITREGION) (* ; "Edited 3-Feb-87 16:53 by jop") (* ;; "moves REGION so that it is entirely on the screen.") (DECLARE (GLOBALVARS WHOLEDISPLAY)) (PROG [X (LIMITREGION (COND (LIMITREGION (OR (REGIONP LIMITREGION) (\ILLEGAL.ARG LIMITREGION))) (T WHOLEDISPLAY] [COND ((ILESSP (fetch (REGION LEFT) of REGION) (SETQ X (fetch (REGION LEFT) of LIMITREGION))) (replace (REGION LEFT) of REGION with X)) ((IGREATERP (fetch (REGION PRIGHT) of REGION) (SETQ X (fetch (REGION PRIGHT) of LIMITREGION))) (replace (REGION LEFT) of REGION with (IMAX 0 (IDIFFERENCE (SUB1 X) (fetch (REGION WIDTH) of REGION] [COND ((ILESSP (fetch (REGION BOTTOM) of REGION) (SETQ X (fetch (REGION BOTTOM) of LIMITREGION))) (replace (REGION BOTTOM) of REGION with X)) ((IGREATERP (fetch (REGION PTOP) of REGION) (SETQ X (fetch (REGION PTOP) of LIMITREGION))) (replace (REGION BOTTOM) of REGION with (IMAX 0 (IDIFFERENCE (SUB1 X) (fetch (REGION HEIGHT) of REGION] (RETURN REGION]) ) (DEFINEQ (ITEMW.REPAINTFN [LAMBDA (WINDOW REGION) (* ; "Edited 3-Feb-87 16:31 by jop") (* ;  "repaints the selectable items in a window.") [for SELITEM in (WINDOWPROP WINDOW 'SELECTABLEITEMS) bind SELECTABLEITEMREGION do (COND ((REGIONSINTERSECTP REGION (SETQ SELECTABLEITEMREGION (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of SELITEM)) ) (PRINTATBOX (fetch (SELECTABLEITEM ITEMINFO) of SELITEM) WINDOW SELECTABLEITEMREGION] (* ;  "if there is a selected item, flip it too in case some of it was in the newly exposed area.") (AND (WINDOWPROP WINDOW 'CURRENTITEM) (\ITEMW.FLIPITEM (WINDOWPROP WINDOW 'CURRENTITEM) WINDOW]) (\ITEM.WINDOW.BUTTON.HANDLER [LAMBDA (WINDOW) (* ; "Edited 3-Feb-87 16:45 by jop") (* ;; "handles button events for item windows. Basically calls left or middle button handler.") (COND ((LASTMOUSESTATE LEFT) (\ITEM.WINDOW.SELECTION.HANDLER WINDOW)) ((LASTMOUSESTATE MIDDLE) (\INSPECTW.COMMAND.HANDLER WINDOW]) (\ITEM.WINDOW.SELECTION.HANDLER [LAMBDA (WINDOW) (* ; "Edited 2-Feb-87 17:25 by jop") (* ;; "selects an ITEM from the window. If there is an item selected already, it is deselected. An ITEM is a list whose CAR is a region.") (PROG ((SELECTABLEITEMS (WINDOWPROP WINDOW 'SELECTABLEITEMS)) NOW PREVIOUS BUTTON OLDPOS REG) (COND ((NULL SELECTABLEITEMS) (* ; "no items, don't do anything.") (RETURN))) (* ; "note which button is down.") (COND ((LASTMOUSESTATE LEFT) (SETQ BUTTON 'LEFT)) ((LASTMOUSESTATE MIDDLE) (SETQ BUTTON 'MIDDLE)) (T (* ; "no button down, not interested.") (RETURN))) (TOTOPW WINDOW) (SETQ REG (WINDOWPROP WINDOW 'REGION)) (* ; "note current item selection.") [SETQ NOW (IN/ITEM? SELECTABLEITEMS (SETQ OLDPOS (CURSORPOSITION NIL WINDOW] (SETQ PREVIOUS (WINDOWPROP WINDOW 'CURRENTITEM)) FLIP (* ; "turn off old selection.") (\ITEMW.DESELECTITEM PREVIOUS WINDOW) (\ITEMW.SELECTITEM (SETQ PREVIOUS NOW) WINDOW) LP (* ;  "wait for a button up or move out of region") (GETMOUSESTATE) (COND ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* ; "button up, return") (AND NOW (WINDOWPROP WINDOW 'SELECTIONFN) (APPLY* (WINDOWPROP WINDOW 'SELECTIONFN) [COND ((EQ 'PROPERTY (fetch (SELECTABLEITEM ITEMINFOTYPE) of NOW)) (fetch (SELECTABLEITEM ITEMINFO) of NOW)) (T (CAR (fetch (SELECTABLEITEM ITEMINFOTYPE) of NOW] (NEQ (fetch (SELECTABLEITEM ITEMINFOTYPE) of NOW) 'PROPERTY) WINDOW)) (RETURN)) ((NOT (INSIDE? REG LASTMOUSEX LASTMOUSEY)) (* ; "outside of region, return") (\ITEMW.DESELECTITEM PREVIOUS WINDOW) (RETURN)) ([EQ PREVIOUS (SETQ NOW (IN/ITEM? SELECTABLEITEMS (CURSORPOSITION NIL WINDOW OLDPOS] (GO LP)) (T (GO FLIP]) (\INSPECTW.COMMAND.HANDLER [LAMBDA (INSPECTW) (* ; "Edited 8-Apr-87 16:40 by jop") (* ;; "the user has middle buttoned in an ITEM window. Apply the selected item's COMMANDFN to the selected item and the window. Often the commandfn will put up another menu.") (WITH-INSPECTOR-ENV (WINDOWPROP INSPECTW 'PROFILE) (COND [(INSIDEP (DSPCLIPPINGREGION NIL INSPECTW) (LASTMOUSEX INSPECTW) (LASTMOUSEY INSPECTW)) (* ; "inside of interior") (PROG ((SELITEM (WINDOWPROP INSPECTW 'CURRENTITEM)) COMMANDFN INFO) (RETURN (COND [SELITEM (COND ((NULL (SETQ COMMANDFN (fetch (SELECTABLEITEM COMMANDFN) of SELITEM))) (* ; "special case of NIL command fn") (PROMPTPRINT "There is no change function for this window.")) ((STRINGP COMMANDFN) (PROMPTPRINT COMMANDFN)) (T (* ;; "check to see if the selected item is a property or a value. This distinction is because the value one needs an extra argument. The selected item is considered to be a property if it is one of the properties of the window.") (ERSETQ (COND ((EQ (SETQ INFO (fetch (SELECTABLEITEM ITEMINFOTYPE) of SELITEM)) 'PROPERTY) (* ;  "the selected item is a property. Call the command fn in property form.") (APPLY* COMMANDFN (fetch (SELECTABLEITEM ITEMINFO) of SELITEM) (WINDOWPROP INSPECTW 'DATUM) INSPECTW)) (T (* ;; "the selected item is a value Call the command fn in value form. For values, the item info type is a cons whose CAR is the property") (APPLY* COMMANDFN (fetch (SELECTABLEITEM ITEMINFO) of SELITEM) (CAR INFO) (WINDOWPROP INSPECTW 'DATUM) INSPECTW] (T (PROMPTPRINT "This is the command button. You must select an item with the left button before choosing a command." ) (until (MOUSESTATE UP)) (CLRPROMPT] (T (* ;  "inside border or title Call the window's TITLECOMMANDFN") (APPLY* (OR (WINDOWPROP INSPECTW 'TITLECOMMANDFN) (FUNCTION DEFAULT.INSPECTW.TITLECOMMANDFN)) INSPECTW (WINDOWPROP INSPECTW 'DATUM]) (ITEM.WINDOW.SET.STACK.ARG [LAMBDA (VARNAME FRAME WINDOW) (* ; "Edited 3-Feb-87 16:52 by jop") (* ;; "the PropCommandFn for itemw windows onto stack frames.") (SELECTQ [MENU (COND ((type? MENU SetStackMenu) SetStackMenu) (T (SETQ SetStackMenu (create MENU ITEMS _ '((Set 'SET "Changes the value of this stack variable" ] (SET (OR (STACKP FRAME) (\ILLEGAL.ARG FRAME)) [ERSETQ (PROG ((OLDVALUEITEM (ITEMOFPROPERTYVALUE VARNAME WINDOW)) NEWVALUE) (* ; "decode the argument position") (* ;; "insist that the arg being set has a real name. following is the code to allow any var to be set: (SETQ ARGN (COND ((FRAMESCAN VARNAME FRAME)) ((STRPOS VARNAME '*arg' 1 T) (COND ((SMALLP (SUBATOM VARNAME 5 -1))) (T (PROMPTPRINT 'Can't set that arg.') (RETURN)))) ((STRPOS VARNAME '*prg' 1 T) (COND ((SETQ ARGN (SMALLP (SUBATOM VARNAME 5 -1))) (IPLUS ARGN (STKNARGS FRAME))) (T (PROMPTPRINT 'Can't set that arg.') (RETURN))))))") (COND ((FRAMESCAN VARNAME FRAME)) (T (PROMPTPRINT "Can't set that arg.") (RETURN))) (RESETLST (RESETSAVE (\ITEMW.FLIPITEM OLDVALUEITEM WINDOW) (LIST '\ITEMW.FLIPITEM OLDVALUEITEM WINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLRPROMPT) (printout T "Enter the new value for " VARNAME "." T "The expression read will be EVALuated." T "> ") (SETQ NEWVALUE (EVAL (READ T T)))) (RETURN (INSPECTW.REPLACE WINDOW VARNAME NEWVALUE]) NIL]) (REPLACESTKARG [LAMBDA (FRAMESPEC WHICHSPEC NEWVALUE) (* ; "Edited 3-Feb-87 16:54 by jop") (* ;; "StoreFn for the ITEMW that inspects back trace frames.") (COND ((NULL (CDR WHICHSPEC)) (* ;  "this is a dummy which is a function name. it has no value") NIL) ((LISTP FRAMESPEC) (REPLACESTKARG (CAR (NTH FRAMESPEC (CAR WHICHSPEC))) (CDR WHICHSPEC) NEWVALUE)) (T (PROG NIL (OR (STACKP FRAMESPEC) (\ILLEGAL.ARG FRAMESPEC)) (RETURN (SETSTKARG (COND ((LISTP WHICHSPEC) (* ; "CAR is name, CADR is offset") (CADR WHICHSPEC)) ((FRAMESCAN WHICHSPEC FRAMESPEC)) (T (PROMPTPRINT "Can't set that arg.") (RETURN))) FRAMESPEC NEWVALUE]) (IN/ITEM? [LAMBDA (ITEMS POS) (* rrb "28-AUG-83 12:18") (PROG ((XPOS (fetch XCOORD of POS)) (YPOS (fetch YCOORD of POS))) (RETURN (for ITEM in ITEMS when (AND (fetch (SELECTABLEITEM SELECTABLEITEMREGION) of ITEM) (INSIDE? (fetch (SELECTABLEITEM SELECTABLEITEMREGION ) of ITEM) XPOS YPOS)) do (RETURN ITEM]) (\ITEMW.DESELECTITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 3-Feb-87 15:46 by jop") (* ;; "deselects ITEM from window") (AND ITEM (\ITEMW.FLIPITEM ITEM WINDOW)) (WINDOWPROP WINDOW 'CURRENTITEM NIL]) (\ITEMW.SELECTITEM [LAMBDA (ITEM WINDOW) (* ; "Edited 3-Feb-87 15:46 by jop") (* ;; "selects an ITEM in WINDOW") (AND ITEM (\ITEMW.FLIPITEM ITEM WINDOW)) (WINDOWPROP WINDOW 'CURRENTITEM ITEM]) (\ITEMW.CLEARSELECTION [LAMBDA (INSPECTW) (* ; "Edited 3-Feb-87 16:56 by jop") (* ;; "clears the selection from an inspect window") (PROG [(CURRENTITEM (WINDOWPROP INSPECTW 'CURRENTITEM] (AND CURRENTITEM (\ITEMW.DESELECTITEM CURRENTITEM INSPECTW)) (RETURN INSPECTW]) (\ITEMW.FLIPITEM [LAMBDA (ITEM DS) (* ; "Edited 3-Feb-87 15:46 by jop") (* ;; "flips the region of an item") (LET ((REG (fetch (SELECTABLEITEM SELECTABLEITEMREGION) of ITEM))) (BLTSHADE BLACKSHADE DS (fetch LEFT of REG) (fetch BOTTOM of REG) (fetch WIDTH of REG) (fetch HEIGHT of REG) 'INVERT]) (PRINTANDBOX [LAMBDA (EXP STREAM LFTMARGIN MINSPACE) (* ; "Edited 4-May-87 14:35 by jop") (* ;; "prints EXP on WINDOW starting at LFTMARGIN and returns the box taken by the characters. Leaves at least MINSPACE points.") (* ;; "set the left margin so that at least nothing will CR past it. This does not handle multiple line values.") (PROG ((STRM (\OUTSTREAMARG STREAM)) PREVRM PREVLM YSTART YEND HGHT) (SETQ PREVRM (DSPRIGHTMARGIN 50000 STRM)) (* ;  "so that it won't auto carrage return.") (SETQ PREVLM (DSPLEFTMARGIN LFTMARGIN STRM)) (AND (FIXP MINSPACE) (RELMOVETO MINSPACE 0 STRM)) (COND ((IGREATERP (DSPXPOSITION NIL STRM) LFTMARGIN) (TERPRI STRM))) (DSPXPOSITION LFTMARGIN STRM) (SETQ YSTART (DSPYPOSITION NIL STRM)) (RETURN (PROG1 [create REGION LEFT _ LFTMARGIN BOTTOM _ [PROGN (CL:PRIN1 EXP STRM) (IDIFFERENCE (SETQ YEND (DSPYPOSITION NIL STRM)) (FONTPROP STRM 'DESCENT] HEIGHT _ (IPLUS (SETQ HGHT (IDIFFERENCE YSTART YEND)) (FONTPROP STRM 'HEIGHT)) WIDTH _ (COND ((IGREATERP HGHT 0) (* ;  "printing the thing did an overflow; use at least the width of the window.") (IMAX (IDIFFERENCE (DSPXPOSITION NIL STRM) LFTMARGIN) (IDIFFERENCE (fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL STRM) ) LFTMARGIN))) (T (IDIFFERENCE (DSPXPOSITION NIL STRM) LFTMARGIN] (DSPRIGHTMARGIN PREVRM STRM) (DSPLEFTMARGIN PREVLM STRM))]) (PRINTATBOX [LAMBDA (EXP WINDOW OLDBOX) (* ; "Edited 3-Feb-87 16:31 by jop") (* ;; "prints EXP in place of what used to be in oldbox and returns the new box.") (DSPFILL OLDBOX NIL 'REPLACE WINDOW) (MOVETO (fetch LEFT of OLDBOX) (IDIFFERENCE (fetch PTOP of OLDBOX) (FONTPROP (DSPFONT NIL WINDOW) 'ASCENT)) WINDOW) (PRINTANDBOX EXP WINDOW (fetch LEFT of OLDBOX]) (ITEMOFPROPERTYVALUE [LAMBDA (PROPERTY WINDOW) (* ; "Edited 3-Feb-87 16:53 by jop") (* ;; "returns the selectableitem structure that corresponds to the value of a property in an inspectw. Knows the way INSPECTW are created.") (CADR (MEMB (\SELITEM.FROM.PROPERTY WINDOW PROPERTY) (WINDOWPROP WINDOW 'SELECTABLEITEMS]) ) (DEFINEQ (\ITEM.WINDOW.COPY.HANDLER [LAMBDA (WINDOW) (* ; "Edited 2-Feb-87 17:27 by jop") (* ;; "copy selects an ITEM from the window. An ITEM is an instance of record SELECTABLEITEM.") (PROG ((SELECTABLEITEMS (WINDOWPROP WINDOW 'SELECTABLEITEMS)) CURRENTITEM SMASHPOS NEWITEM) (COND ((NULL SELECTABLEITEMS) (* ; "no items, don't do anything.") (RETURN))) LP (TOTOPW WINDOW) (* ; "note current item selection.") [SETQ NEWITEM (IN/ITEM? SELECTABLEITEMS (SETQ SMASHPOS (CURSORPOSITION NIL WINDOW] [COND ((NEQ CURRENTITEM NEWITEM) (COND (CURRENTITEM (* ; "turn off old selection.") (\ITEMW.FLIPCOPY CURRENTITEM WINDOW))) (COND ((SETQ CURRENTITEM NEWITEM) (\ITEMW.FLIPCOPY CURRENTITEM WINDOW] (* ;  "wait for a button up or move out of region") LP2 (BLOCK) (COND ((NOT (.COPYKEYDOWNP.)) (* ; "Finished, copy selected item") [COND (CURRENTITEM (\ITEMW.FLIPCOPY CURRENTITEM WINDOW) (BKSYSBUF.GENERAL (fetch (SELECTABLEITEM ITEMINFO) of CURRENTITEM ] (RETURN)) ((MOUSESTATE UP) (* ; "button up, no action") (GO LP2)) (T (GO LP]) (\ITEMW.FLIPCOPY [LAMBDA (ITEM DS) (* ; "Edited 3-Feb-87 16:56 by jop") (* ;; "flips the copy selection region of an item") (LET ((REG (fetch (SELECTABLEITEM SELECTABLEITEMREGION) of ITEM))) (BLTSHADE GRAYSHADE DS (fetch LEFT of REG) (fetch BOTTOM of REG) (fetch WIDTH of REG) 2 'INVERT]) (BKSYSBUF.GENERAL [LAMBDA (OBJECT) (* ; "Edited 10-Jul-91 13:25 by jds") (* ;;  "Does a slightly more intelligent BKSYSBUF than just stuffing the print name as characters") (LET ((TYPE (TYPENAME OBJECT))) (SELECTQ TYPE ((STRINGP LITATOM NEW-ATOM) (BKSYSBUF OBJECT T)) (LISTP (bind (SEPR _ '%() do (BKSYSBUF SEPR) (SETQ SEPR '% ) (BKSYSBUF.GENERAL (CAR OBJECT)) repeatuntil (NLISTP (SETQ OBJECT (CDR OBJECT))) finally (COND (OBJECT (* ; "Dotted cdr") (BKSYSBUF " . ") (BKSYSBUF.GENERAL OBJECT))) (BKSYSBUF '%)))) (COND ((NUMBERP OBJECT) (BKSYSBUF OBJECT)) (T (RESETVARS ((PRXFLG T)) (LET ((*PRINT-BASE* 8) (*PRINT-RADIX* T)) (BKSYSBUF (LIST '\VAG2 (\HILOC OBJECT) (\LOLOC OBJECT)) T]) ) (DECLARE%: EVAL@COMPILE (RECORD SELECTABLEITEM (SELECTABLEITEMREGION COMMANDFN ITEMINFO ITEMINFOTYPE)) ) (RPAQQ MAXINSPECTARRAYLEVEL 300) (RPAQQ MAXINSPECTCDRLEVEL 50) (RPAQQ MinSpaceBetweenProperyAndValue 8) (RPAQQ MaxInspectorPropertyValueWidth 250) (RPAQQ MaxValueLeftMargin 250) (RPAQQ PropertyLeftMargin 2) (* ; "functions for the inspector") (DEFINEQ (INSPECT [LAMBDA (ITEM ASTYPE WHERE) (* ; "Edited 1-Dec-96 21:09 by rmk:") (* ; "Edited 2-Feb-87 17:09 by jop") (* ;; "sets up a window that allows inspection.") (DECLARE (SPECVARS WHERE)) (LET ((ITEMTYPE (TYPENAME ITEM)) IWINDOW INSPECTINFO) (CL:SETQ IWINDOW (COND (ASTYPE (* ;  "if ASTYPE is given, always inspect it as that type. This provides a way of overriding macros.") (INSPECT/DATATYPE ITEM ASTYPE WHERE)) [(SETQ INSPECTINFO (for IMACRO in INSPECTMACROS when (COND [(LISTP (CAR IMACRO)) (COND ((EQ (CAAR IMACRO) 'FUNCTION) (APPLY* (CADAR IMACRO) ITEM)) (T (ERROR "ERROR in INSPECTMACROS specification" IMACRO] (T (EQ (CAR IMACRO) ITEMTYPE))) do (RETURN IMACRO))) (COND ((LISTP (CDR INSPECTINFO)) (* ;  "inspect information is a list of arguments to INSPECTW.CREATE") (\APPLYINSPECTMACRO ITEM (CDR INSPECTINFO) WHERE)) (T (* ;  "if inspect information is an atom, apply it to the ITEM.") (APPLY* (CDR INSPECTINFO) ITEM (CAR INSPECTINFO) WHERE] [ITEM (SELECTQ ITEMTYPE (LITATOM (INSPECT/ATOM ITEM NIL WHERE)) (LISTP (* ;  "find out how to inspect the list.") (INSPECT/LISTP ITEM WHERE)) (ARRAYP (INSPECT/ARRAY ITEM NIL WHERE)) (HARRAYP (INSPECT/HARRAYP ITEM WHERE)) (BITMAP (INSPECT/BITMAP ITEM WHERE)) (CCODEP (INSPECTCODE ITEM WHERE)) (NIL (INSPECT/TYPELESS ITEM WHERE)) (LET [(DTD (\GETDTD (NTYPX ITEM] (COND ((fetch DTDHUNKP of DTD) (INSPECT/HUNK ITEM WHERE (fetch DTDGCTYPE of DTD) (fetch DTDSIZE of DTD))) (T (INSPECT/DATATYPE ITEM NIL WHERE] (T (printout PROMPTWINDOW T "Can't Inspect NIL.") NIL))) (CL:WHEN (WINDOWP IWINDOW) (* ;  "Mark it as an inspect window, so that utilities such as WDWHACKS can recognize it") (WINDOWPROP IWINDOW 'INSPECTWINDOW T))]) (\APPLYINSPECTMACRO [LAMBDA (DATUM ARGLST WHERE) (* ; "Edited 3-Feb-87 15:18 by jop") (* ;; "function that calls INSPECTW.CREATE when given the inspect macro information. Separate because of difficulty of interpreting WHERE argument.") (PROG ((ARGS ARGLST)) (RETURN (INSPECTW.CREATE DATUM (pop ARGS) (pop ARGS) (pop ARGS) (pop ARGS) (pop ARGS) (pop ARGS) (pop ARGS) (pop ARGS) (COND (ARGS (* ;  "WHERE argument must be evaluated.") (EVAL ARGS)) (T WHERE)) (pop ARGS]) (INSPECT/BITMAP [LAMBDA (BITMAP WHERE) (* ; "Edited 2-Feb-87 17:07 by jop") (* ;; "asks whether to use the bitmap editor or not") (SELECTQ [MENU (COND ((type? MENU InspectBitmapMenu) InspectBitmapMenu) (T (SETQ InspectBitmapMenu (create MENU ITEMS _ '((fields 'FIELDS "Inspects the fields of the bitmap" ) (contents 'CONTENTS "Edits the contents of the bitmap." ] (FIELDS (INSPECT/DATATYPE BITMAP 'BITMAP WHERE)) (CONTENTS (EVAL.AS.PROCESS (LIST 'EDITBM BITMAP))) NIL]) (INSPECT/DATATYPE [LAMBDA (DATUM TYPE WHERE) (* ; "Edited 1-Dec-96 20:15 by rmk:") (* ; "Edited 7-Aug-87 10:21 by jop") (* ;; "creates an inspector window for datatype or record instance DATUM") (LET (SYSREC DEC) (COND [(AND TYPE (SETQ DEC (RECLOOK TYPE] ((AND TYPE (SETQ DEC (SYSRECLOOK1 TYPE))) (SETQ SYSREC T)) ((SETQ DEC (FINDRECDECL DATUM))) ((SETQ DEC (FINDSYSRECDECL DATUM)) (SETQ SYSREC T))) (COND (DEC (* ;  "The fetchfn and storefn would be more attractive if we had lexical closures") (INSPECTW.CREATE DATUM (INSPECTABLEFIELDNAMES DEC (NULL INSPECTALLFIELDSFLG) ) `[LAMBDA (INSTANCE FIELD) (RECORDACCESS FIELD INSTANCE ',DEC] [if SYSREC then `[LAMBDA (INSTANCE FIELD NEWVALUE) (AND (CONFIRM-SET) (RECORDACCESS FIELD INSTANCE ',DEC '/REPLACE NEWVALUE] else `(LAMBDA (INSTANCE FIELD NEWVALUE) (RECORDACCESS FIELD INSTANCE ',DEC '/REPLACE NEWVALUE] NIL NIL (if (EQ (CAR DEC) 'BLOCKRECORD) then (* ;;  "To this by hand to avoid being fooled by invalid lisp pointers") (CL:FORMAT NIL "<~a @ ~o,~o>" TYPE (\HILOC DATUM) (\LOLOC DATUM))) NIL WHERE)) ([SETQ DEC (fetch DTDDESCRS of (\GETDTD (NTYPX DATUM] (* ;  "No user-level declaration, but we can at least fetch raw fields out of it") (INSPECTW.CREATE DATUM (for I to (LENGTH DEC) collect I) `[LAMBDA (FIELD INSTANCE) (\INSPECT.DATATYPE.RAW.FETCH FIELD INSTANCE ',DEC] NIL "System datatype: Cann't set any fields" NIL NIL NIL NIL WHERE)) ((AND (LISTP DATUM) (SELECTQ TYPE (ALIST (CL:WHEN (ALISTP DATUM) (INSPECT/ALIST DATUM WHERE) T) (ALISTP DATUM)) (PLIST (CL:WHEN (PROPLISTP DATUM) (INSPECT/PLIST DATUM WHERE) T)) (LIST (INSPECT/TOP/LEVEL/LIST DATUM WHERE) T) NIL))) (T (printout PROMPTWINDOW T "No declaration for " DATUM T "Can not inspect.") NIL]) (INSPECTABLEFIELDNAMES [LAMBDA (DECL TOPONLYFLG) (* ; "Edited 3-Feb-87 16:51 by jop") (* ;; "returns the list of record field names suitable for inspecting. This is everything unless TOPONLYFLG is T which is the case for system records.") (COND (TOPONLYFLG (for FIELDNAME in (CDR (RECORDFIELDNAMES DECL T)) when (AND FIELDNAME (NLISTP FIELDNAME)) collect FIELDNAME)) (T (REMOVEDUPS (RECORDFIELDNAMES DECL]) (REMOVEDUPS [LAMBDA (LST) (* ; "Edited 3-Feb-87 16:54 by jop") (* ;; "removes the duplicate entries from LST.") (INTERSECTION LST LST]) (INSPECT/ARRAY [LAMBDA (ARRAY BEGINOFFSET WHERE) (* ; "Edited 2-Feb-87 17:06 by jop") (* ;; "inspects an array") (COND [(ARRAYP ARRAY) (PROG [(FIRSTELT (OR (NUMBERP BEGINOFFSET) (ARRAYORIG ARRAY] (RETURN (INSPECTW.CREATE ARRAY (for I from FIRSTELT to (SUB1 (IMIN (IPLUS (ARRAYORIG ARRAY) (ARRAYSIZE ARRAY)) (IPLUS FIRSTELT MAXINSPECTARRAYLEVEL))) collect I) (FUNCTION ELT) (FUNCTION /SETA) NIL NIL NIL NIL NIL WHERE] (T (printout PROMPTWINDOW T ARRAY " not an array") NIL]) (INSPECT/TOP/LEVEL/LIST [LAMBDA (LST WHERE) (* ; "Edited 2-Feb-87 17:02 by jop") (* ;; "inspects one level of a list structure via numbered fields.") (COND ((LISTP LST) (INSPECTW.CREATE LST [for I from 1 to MAXINSPECTCDRLEVEL as X on LST collect I finally (COND (X (NCONC1 $$VAL (COND ((NLISTP X) '|...|) (T '&&] (FUNCTION NTHTOPLEVELELT) (FUNCTION SETNTHTOPLEVELELT) NIL NIL NIL NIL NIL WHERE)) (T (printout PROMPTWINDOW T LST " not a LISTP") NIL]) (INSPECT/PROPLIST [LAMBDA (ATOM ALLPROPSFLG WHERE) (* ; "Edited 3-Feb-87 16:51 by jop") (* ;; "opens an inspect window onto the properties of ATOM") (PROG [(PROPS (COND (ALLPROPSFLG (PROPNAMES ATOM)) (T (NONSYSPROPNAMES ATOM] (RETURN (COND (PROPS (INSPECTW.CREATE ATOM (COND (ALLPROPSFLG (FUNCTION PROPNAMES)) (T (FUNCTION NONSYSPROPNAMES))) (FUNCTION GETPROP) (FUNCTION /PUTPROP) NIL NIL NIL NIL NIL WHERE)) (T (PROMPTPRINT (COND (ALLPROPSFLG "No properties") (T "No non-system properties"))) NIL]) (NONSYSPROPNAMES [LAMBDA (ATM) (* ; "Edited 3-Feb-87 16:53 by jop") (* ;; "returns the properties an atom has that are not SYSPROPS") (for PROP in (PROPNAMES ATM) when (NOT (FMEMB PROP SYSPROPS)) collect PROP]) (INSPECT/LISTP [LAMBDA (LST WHERE) (* ; "Edited 2-Feb-87 17:05 by jop") (* ;; "asks how the user wants to inspect a list and calls the appropriate function.") (APPLY* (OR (SELECT.LIST.INSPECTOR LST) (FUNCTION NILL)) LST WHERE]) (ALISTP [LAMBDA (LST) (* ; "Edited 3-Feb-87 16:48 by jop") (* ;; "is LST in alist format?") (for ELT in LST always (LISTP ELT]) (PROPLISTP [LAMBDA (LST) (* ; "Edited 3-Feb-87 16:54 by jop") (* ;; "is lst a property list format? Assumes that property names are litatoms.") (AND LST (PROG ((LSTPTR LST)) LP (COND ((NULL LSTPTR) (RETURN T)) ((NLISTP LSTPTR) (RETURN NIL)) ((AND (LITATOM (CAR LSTPTR)) (LISTP (CDR LSTPTR))) (SETQ LSTPTR (CDDR LSTPTR)) (GO LP)) (T (RETURN NIL]) (INSPECT/ALIST [LAMBDA (ALST WHERE) (* ; "Edited 2-Feb-87 17:04 by jop") (* ;; "opens an inspect window onto an ALIST.") (INSPECTW.CREATE ALST (for X in ALST collect (CAR X)) (FUNCTION ASSOCGET) (FUNCTION /ASSOCPUT) NIL NIL NIL NIL NIL WHERE]) (ASSOCGET [LAMBDA (ALST KEY) (* ; "Edited 2-Feb-87 17:04 by jop") (* ;; "gets the value associated with a key on an ALST.") (CDR (ASSOC KEY ALST]) (/ASSOCPUT [LAMBDA (ALST KEY VAL) (* ; "Edited 2-Feb-87 17:04 by jop") (* ;;  "defined to change the order of arguments from what inspector gives to what /PUTASSOC wants.") (/PUTASSOC KEY VAL ALST]) (INSPECT/PLIST [LAMBDA (PLST WHERE) (* ; "Edited 2-Feb-87 17:05 by jop") (* ;; "opens an inspect window onto an ALIST.") (INSPECTW.CREATE PLST (for X in PLST by (CDDR X) collect X) (FUNCTION LISTGET) (FUNCTION /LISTPUT) NIL NIL NIL NIL NIL WHERE]) (INSPECT/TYPERECORD [LAMBDA (X WHERE) (* ; "Edited 2-Feb-87 17:05 by jop") (* ;; "inspects X assuming it is a typerecord instance.") (INSPECT X (CAR X) WHERE]) (INSPECT/AS/RECORD [LAMBDA (INSTANCE WHERE) (* ; "Edited 2-Feb-87 17:03 by jop") (* ;; "offers the user a choice of record types to inspect INSTANCE with.") (PROG (RECORD) (RETURN (AND [SETQ RECORD (MENU (create MENU ITEMS _ (SORT (for RECDEC in USERRECLST when (FMEMB (CAR RECDEC) '(TYPERECORD RECORD)) collect (CADR RECDEC))) WHENHELDFN _ (FUNCTION (LAMBDA (ITEM) (PROMPTPRINT "Will inspect the list as if it were an instance of this record type." ] (INSPECT INSTANCE RECORD WHERE]) (SELECT.LIST.INSPECTOR [LAMBDA (LST) (* ; "Edited 2-Feb-87 17:05 by jop") (* ;; "gives the user a choice of how to edit a list.") (MENU (create MENU ITEMS _ [APPEND '((DisplayEdit 'DEDITE "Edit it with the display editor") (TtyEdit 'STANDARDEDITE "Edit it with the standard editor") (Inspect 'INSPECT/TOP/LEVEL/LIST "Inspect the top level with an inspect window") ("As a record" 'INSPECT/AS/RECORD "Prompts further for the record type of this LIST.")) [COND [(ALISTP LST) '(("As an ALIST" 'INSPECT/ALIST "Inspects the list as a A-List"] ((PROPLISTP LST) '(("As a PLIST" 'INSPECT/PLIST "Inspects the list as a property list."] (PROG [(RECDEC (RECLOOK (CAR LST] (RETURN (COND ((AND RECDEC (EQ (CAR RECDEC) 'TYPERECORD)) (* ;  "this is likely to be an instance of the typed record.") (CONS (LIST (CONCAT "As a " (CAR LST)) ''INSPECT/TYPERECORD (CONCAT "Inspects the selected list as an instance of " (CAR LST] CENTERFLG _ T]) (STANDARDEDITE [LAMBDA (EXPR COMS ATM TYPE IFCHANGEDFN) (* ; "Edited 3-Feb-87 16:55 by jop") (* ;; "version of EDITE that always calls the standard editor.") (RESETFORM (EDITMODE 'STANDARD) (EDITE EXPR COMS ATM TYPE IFCHANGEDFN]) (NTHTOPLEVELELT [LAMBDA (LST N) (* ; "Edited 3-Feb-87 16:53 by jop") (* ;; "returns the Nth element.") (COND ((EQ N '|...|) (CDR (LAST LST))) ((EQ N '&&) (NTH LST (ADD1 MAXINSPECTCDRLEVEL))) (T (CAR (NTH LST N]) (SETNTHTOPLEVELELT [LAMBDA (LST N NEWVALUE) (* ; "Edited 3-Feb-87 16:55 by jop") (* ;; "sets the nth top level eltment of LST to NEWVALUE") (* ;; "undoable but it will almost certainly be undone in the wrong place.") (COND ((EQ N '|...|) (/RPLACD (LAST LST) NEWVALUE)) ((EQ N '&&) (PROMPTPRINT "Can't set the tail.") (* ;  "return current value for printing.") (NTH LST (ADD1 MAXINSPECTCDRLEVEL))) (T (PROG NIL (RETURN (/RPLACA (OR (NTH LST N) (RETURN)) NEWVALUE]) (DEDITE [LAMBDA (EXPR WHERE) (* ; "Edited 24-Sep-87 09:50 by jop") (LET ((*EDITMODE* 'DISPLAY)) (EDITE EXPR NIL NIL NIL NIL '(:DONTWAIT :DISPLAY]) (FINDRECDECL [LAMBDA (DATUM) (* ; "Edited 3-Feb-87 16:49 by jop") (* ;; "find the datatype declaration for a datum.") (PROG (TYPENAME DECL) (RETURN (AND [SETQ DECL (RECLOOK (SETQ TYPENAME (COND ((LISTP DATUM) (CAR DATUM)) (T (TYPENAME DATUM] (TYPENAMEP DATUM TYPENAME) DECL]) (FINDSYSRECDECL [LAMBDA (DATUM) (* ; "Edited 3-Feb-87 16:49 by jop") (* ;; "find the datatype declaration for a if it is a system datatype.") (PROG (TYPENAME DECL) (AND (SETQ TYPENAME (TYPENAME DATUM)) (SETQ DECL (SYSRECLOOK1 TYPENAME)) (TYPENAMEP DATUM TYPENAME) (RETURN DECL]) (MAKE-INSPECTOR-PROFILE [LAMBDA (NAME) (* ; "Edited 4-Feb-87 15:35 by jop") (LET ((P-NAME (OR NAME "INSPECTOR PROFILE"))) (XCL:MAKE-PROFILE P-NAME '(XCL:*EVAL-FUNCTION* XCL:*EVAL-FUNCTION*) '(*PRINT-CASE* *PRINT-CASE*) '(*READTABLE* *READTABLE*) '(*PACKAGE* *PACKAGE*]) (CONFIRM-SET [LAMBDA NIL (* ; "Edited 7-Aug-87 09:53 by jop") (MOUSECONFIRM "This is a potentially dangerous operation."]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS INSPECTMACROS INSPECTALLFIELDSFLG SetPropertyMenu SetStackMenu InspectMenu PropertyLeftMargin MaxValueLeftMargin INSPECTPRINTLEVEL InspectBitmapMenu ItemWCommandMenu InspectPropsMenu MAXINSPECTARRAYLEVEL MAXINSPECTCDRLEVEL MaxInspectorWindowWidth MaxInspectorWindowHeight INSPECT.HUNK.COMMANDS USERRECLST SYSPROPS IT MinSpaceBetweenProperyAndValue MaxInspectorPropertyValueWidth) ) (RPAQ? INSPECTALLFIELDSFLG T) (RPAQ? MaxInspectorWindowWidth 330) (RPAQ? MaxInspectorWindowHeight 606) (RPAQQ INSPECTPRINTLEVEL (2 . 5)) (* ;; "To deal with profiles in spawned processes") (DECLARE%: EVAL@COMPILE (PUTPROPS EVAL.AS.PROCESS.WITH.PROFILE MACRO [ARGS (LET ((PROFILE (CAR ARGS)) (FORM (CADR ARGS))) `(EVAL.AS.PROCESS (LIST 'XCL:WITH-PROFILE (LIST 'QUOTE ,PROFILE) ,FORM]) (PUTPROPS WITH-INSPECTOR-ENV MACRO [ARGS (LET ((PROFILE (CAR ARGS)) (FORMS (CDR ARGS))) `(XCL:WITH-PROFILE ,PROFILE (LET ((*PRINT-LEVEL* (CAR INSPECTPRINTLEVEL)) (*PRINT-LENGTH* (CDR INSPECTPRINTLEVEL))) ,@FORMS]) ) (* ; "Atom inspector") (DEFINEQ (INSPECT/ATOM [LAMBDA (ATM ALWAYSASKFLG WHERE) (* ; "Edited 1-Sep-87 10:47 by woz") (* ;; "asks which aspect to inspect and inspects it.") (LET ((ASPECTS (TYPESOF ATM NIL NIL '?)) (OFFER-INSPECT-CODE? (CCODEP ATM)) (PROFILE (MAKE-INSPECTOR-PROFILE)) TYPETOINSPECT) [COND ((NONSYSPROPNAMES ATM) (* ;  "add the property list to selectable aspects.") (push ASPECTS 'PROPS)) ((AND (NULL ASPECTS) (GETPROPLIST ATM)) (* ;  "If there is nothing else to inspect about this atom, offer its propertylist.") (SETQ ASPECTS '(PROPS] [COND ((AND (MEMB 'VARS ASPECTS) (LITATOM (EVALV ATM))) (* ;  "break the loop that can result from inspecting something that has an atom as its value") (SETQ ASPECTS (REMOVE 'VARS ASPECTS] (COND ((NOT ASPECTS) (PRINTOUT PROMPTWINDOW T ATM " does not have any aspect to inspect.") NIL) ((EQUAL ASPECTS '(VARS)) (INSPECT (EVALV ATM))) ([SETQ TYPETOINSPECT (COND ((AND (NULL (CDR ASPECTS)) (EQ (CAR ASPECTS) 'PROPS)) (* ;; "if there is only one aspect and determining how to inspect that aspect gives the user a chance to quit, don't force a selection at the aspect level.") 'PROPS) (T (SELECT.ATOM.ASPECT ATM ALWAYSASKFLG ASPECTS OFFER-INSPECT-CODE?] (* ;; "the functions applyed by this EVAL must evalaute their arguments. EDITF works because it is happy to take (QUOTE FN) as an argument too.") (SELECTQ TYPETOINSPECT (PROPS (* ;  "ask what method to use to inspect it.") (SELECTQ [MENU (COND ((type? MENU InspectPropsMenu) InspectPropsMenu) (T (SETQ InspectPropsMenu (create MENU ITEMS _ '(("EDITP" :EDITP "Calls EDITP on the atom." ) ("Inspect Props" :INSPECT "Inspects the property list with an inspect window." ] (:EDITP (* ;; "IL:EDITP is an NLambda yuk NoSpread yuk") [EVAL.AS.PROCESS.WITH.PROFILE PROFILE `(EDITP ,ATM]) (:INSPECT [EVAL.AS.PROCESS.WITH.PROFILE PROFILE `(INSPECT/PROPLIST ',ATM NIL ',WHERE]) NIL)) (:INSPECTCODE (INSPECTCODE ATM WHERE)) (EVAL.AS.PROCESS.WITH.PROFILE PROFILE `(ED ',ATM '(:DONTWAIT :DISPLAY ,TYPETOINSPECT]) (SELECT.ATOM.ASPECT [LAMBDA (ATOM ALWAYSASKFLG ASPECTS OFFER-INSPECT-CODE?)(* ; "Edited 1-Sep-87 10:48 by woz") (* ;; "Returns a file package type name corresponding to the type of ATOM. The user is asked to choose if there is more than one or If ALWAYSASKFLG is non-NIL. If OFFER-INSPECT-CODE? is set then let Inspect Code be an option in the menu, and return :INSPECTCODE to let the caller know that code rather than filemanager definition is wanted.") (LET [(ASPECTS (OR ASPECTS (TYPESOF ATOM NIL NIL '?] (COND ((NULL ASPECTS) NIL) ((OR ALWAYSASKFLG (CDR ASPECTS)) (* ; "ASPECTS is in menu item format") (MENU (create MENU ITEMS _ (CL:IF OFFER-INSPECT-CODE? (CONS '("Inspect Code" :INSPECTCODE "Shows the compiled code.") ASPECTS) ASPECTS) TITLE _ (CONCAT "Which defn of " ATOM "?") CENTERFLG _ T))) (T (CAR ASPECTS]) (INSPECT/AS/FUNCTION + [LAMBDA (ATM STKP WINDOW) (* ; + "Edited 19-Sep-95 13:57 by sybalsky:mv:envos") + + (* ;; "calls an editor on function ATM. STKP and WINDOW are the stack pointer and window of the break in which this inspect command was called") + + (LET ((EDITOR (SELECT.FNS.EDITOR ATM)) + FRAME CODEBASE PROC) + (AND EDITOR + (if (EQ EDITOR 'INSPECTCODE) + then (COND + ([AND (STACKP STKP) + (NOT (fetch (FX INVALIDP) of (SETQ FRAME + (fetch (STACKP EDFXP) + of STKP] + (INSPECTCODE (COND + ((EQ (\GET-COMPILED-CODE-BASE ATM) + (SETQ CODEBASE (fetch (FX FNHEADER) + of FRAME))) + ATM) + (T + + (* ;; "Function executing in this frame is not the one in the definition cell of its name, so fetch the real code. Have to pass a CCODEP") + + (MAKE-COMPILED-CLOSURE CODEBASE))) + NIL NIL NIL (fetch (FX PC) of FRAME))) + (T (INSPECTCODE ATM))) + else (LET [[PROC (AND WINDOW (WINDOWPROP WINDOW 'PROCESS] + (EDITORARGS (if (EQ EDITOR 'ED) + then (LIST ATM '(METHOD-FNS FUNCTIONS FNS + :DONTWAIT :DISPLAY)) + else (LIST ATM] + (if PROC + then (PROCESS.APPLY PROC EDITOR EDITORARGS) + else (CL:APPLY EDITOR EDITORARGS]) (SELECT.FNS.EDITOR [LAMBDA (FN) (* ; "Edited 1-Sep-87 10:49 by woz") (* ;;  "gives the user a menu choice of editors. Return the name of the editor function to apply.") (MENU (create MENU ITEMS _ [APPEND [COND ((CCODEP FN) '(("Inspect Code" 'INSPECTCODE "Shows the compiled code."] '(("Display Edit" 'ED "Edit it with the display editor") ("Tty Edit" 'EF "Edit it with the standard editor"] CENTERFLG _ T]) ) (* ; "Compiled code inspector") (DEFINEQ (INSPECTCODE [LAMBDA (FN WHERE LVFLG RADIX PC CODEPRINTER) (* ; "Edited 4-Feb-87 15:41 by jop") (* ;; "creates a window that shows the compiled code of a function.") (COND ((GETD 'OPENTEXTSTREAM) (* ; "Use smarter inspector") (\TEDIT.INSPECTCODE FN WHERE LVFLG RADIX PC CODEPRINTER)) (T (COND ((NOT (CCODEP FN)) (ERROR "Not a compiled function" FN))) (LET [(WINDOW (DECODE.WINDOW.ARG WHERE 400 320 (CONCAT FN " Code Window"] (WINDOWPROP WINDOW 'DATUM FN) (WINDOWPROP WINDOW 'REPAINTFN (FUNCTION \INSPECT/CODE/REPAINTFN)) (WINDOWPROP WINDOW 'RESHAPEFN (FUNCTION \INSPECT/CODE/RESHAPEFN)) (WINDOWPROP WINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (WINDOWPROP WINDOW 'PROFILE (MAKE-INSPECTOR-PROFILE)) (* ;  "call the reshapefn to note the upper left corner and the extent.") (\INSPECT/CODE/RESHAPEFN WINDOW]) (\TEDIT.INSPECTCODE [LAMBDA (FN WHERE LVFLG RADIX PC CODEPRINTER) (* ; "Edited 3-Feb-87 16:56 by jop") (PROG ((STREAM (OPENSTREAM '{NODIRCORE} 'BOTH)) WINDOW SEL) (APPLY* (OR CODEPRINTER (FUNCTION PRINTCODE)) FN LVFLG RADIX STREAM NIL PC) [SETQ STREAM (OPENTEXTSTREAM STREAM [SETQ WINDOW (DECODE.WINDOW.ARG WHERE 400 280 (COND ((OR (LITATOM FN) (NOT (CCODEP FN))) (CONCAT "Code for " FN)) (T (CONCAT (COND (PC "Code for frame ") (T "CCODEP named ")) (fetch (COMPILED-CLOSURE FRAMENAME) of FN] NIL NIL '(READONLY T PROMPTWINDOW DON'T] (COND ((AND PC (SETQ SEL (TEDIT.FIND STREAM "----------" 1))) (* ; "Highlight location of PC") (TEDIT.SETSEL STREAM (IMAX 1 (IDIFFERENCE SEL 100)) 0 'LEFT) (TEDIT.NORMALIZECARET STREAM))) [COND ((DEFINEDP 'TEXTICON) (* ; "Override TEdit's icon") (WINDOWPROP WINDOW 'ICONFN (FUNCTION TEXTICON] (RETURN FN]) (\INSPECT/CODE/RESHAPEFN [LAMBDA (WIN OLDIMAGE OLDREGION) (* ; "Edited 3-Feb-87 15:35 by jop") (* ;; "reshapes a code inspection window.") (* ;; "set the upper left corner for the repaintfn, call the repaintfn and note the Y position for the extent.") (PROG [WHEIGHT BOTTOM (FONT (fetch DDFONT of (fetch IMAGEDATA of (WINDOWPROP WIN 'DSP] [WINDOWPROP WIN 'REGIONUPPERLEFT (create POSITION XCOORD _ 0 YCOORD _ (SUB1 (IDIFFERENCE (SETQ WHEIGHT (WINDOWPROP WIN 'HEIGHT)) (FONTPROP FONT 'ASCENT] (\INSPECT/CODE/REPAINTFN WIN) (WINDOWPROP WIN 'EXTENT (create REGION LEFT _ 0 BOTTOM _ [SETQ BOTTOM (IPLUS (DSPYPOSITION NIL WIN) (FONTPROP FONT 'ASCENT] WIDTH _ (WINDOWPROP WIN 'WIDTH) HEIGHT _ (IDIFFERENCE WHEIGHT BOTTOM]) (\INSPECT/CODE/REPAINTFN [LAMBDA (WIN) (* ; "Edited 8-Apr-87 16:40 by jop") (* ;; "moves to the window's upper left corner and prints the code for the function in WIN.") (WITH-INSPECTOR-ENV (WINDOWPROP WIN 'PROFILE) (PROG [(UPPERLEFT (WINDOWPROP WIN 'REGIONUPPERLEFT] (MOVETO (fetch (POSITION XCOORD) of UPPERLEFT) (fetch (POSITION YCOORD) of UPPERLEFT) WIN) (* ;;  "should be changed to pass WIN as a parameter when PRINTCODE is changed to take file argument.") (PRINTCODE (WINDOWPROP WIN 'DATUM) NIL 8 WIN]) ) (* ; "Hash table inspector") (DEFINEQ (INSPECT/HARRAYP [LAMBDA (HARRAY WHERE) (* ; "Edited 2-Feb-87 17:06 by jop") (* ;; "opens an inspect window onto the elements of HARRAY") (PROG ((PROPS (HARRAYKEYS HARRAY))) (RETURN (COND (PROPS (INSPECTW.CREATE HARRAY (FUNCTION HARRAYKEYS) (FUNCTION INSPECTW.GETHASH) (FUNCTION INSPECTW.PUTHASH) NIL NIL NIL NIL NIL WHERE)) (T (PROMPTPRINT "No keys in that Hash array.") NIL]) (HARRAYKEYS [LAMBDA (HARRAY) (* ; "Edited 3-Feb-87 16:50 by jop") (* ;; "returns a list of all of the keys in a Hash array.") (PROG (ITEMLST) [MAPHASH HARRAY (FUNCTION (LAMBDA (HASHEDVALUE HASHITEM) (SETQ ITEMLST (CONS HASHITEM ITEMLST] (RETURN ITEMLST]) (INSPECTW.GETHASH [LAMBDA (HARRAY ITEM) (* ; "Edited 3-Feb-87 16:51 by jop") (* ;; "version of GETHASH that switches the order of arguments.") (GETHASH ITEM HARRAY]) (INSPECTW.PUTHASH [LAMBDA (HARRAY ITEM VALUE) (* ; "Edited 3-Feb-87 16:52 by jop") (* ;; "version of PUTHASH that switches the order of arguments.") (/PUTHASH ITEM VALUE HARRAY]) ) (* ; "Readtable, termtable inspectors") (DEFINEQ (RDTBL\NONOTHERCODES [LAMBDA (RT) (* ; "Edited 20-Apr-2018 17:08 by rmk:") (* ; "Edited 3-Feb-87 16:54 by jop") (* ;; "returns the character codes that are not OTHER.") (LET (RESULT) (DECLARE (SPECVARS RESULT)) (\MAPCHARTABLE [FUNCTION (LAMBDA (VAL KEY) (CL:WHEN (NEQ (GETSYNTAX KEY RT) 'OTHER) (PUSH RESULT KEY] (fetch READSA of (\GTREADTABLE RT T))) RESULT]) (GETSYNTAXPROP [LAMBDA (RDTBL CH) (* ; "Edited 3-Feb-87 16:49 by jop") (* ;; "version of GETSYNTAX that has arguments in the right order for inspector") (GETSYNTAX CH RDTBL]) (SETSYNTAXPROP [LAMBDA (RDTBL CH CLASS) (* ; "Edited 3-Feb-87 16:55 by jop") (* ;; "version of SETSYNTAX that has arguments in the right order for inspector") (SETSYNTAX CH CLASS RDTBL]) (GETTTBLPROP [LAMBDA (TTBL PROP) (* ; "Edited 3-Feb-87 16:50 by jop") (* ;; "inspector function that returns the value of the property from a terminal table. Combines several miscellaneous parts of the terminal table into a uniform interface.") (COND ((NUMBERP PROP) (ECHOCONTROL PROP NIL TTBL)) ((FMEMB PROP '(CHARDELETE WORDDELETE LINEDELETE RETYPE CTRLV EOL)) (CAR (GETSYNTAX PROP TTBL))) ((FMEMB PROP '(1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL)) (DELETECONTROL PROP NIL TTBL)) ((EQ PROP 'LINEDELETESTR) (DELETECONTROL 'LINEDELETE NIL TTBL)) ((EQ PROP 'ECHODELS?) (EQ (GETDELETECONTROL 'ECHO TTBL) 'ECHO)) ((EQ PROP 'CONTROL) (GETCONTROL TTBL)) ((EQ PROP 'RAISE) (GETRAISE TTBL)) ((EQ PROP 'ECHOMODE) (GETECHOMODE TTBL]) (SETTTBLPROP [LAMBDA (TTBL PROP NEWVALUE) (* ; "Edited 3-Feb-87 16:55 by jop") (* ;; "inspector function that sets the value of the property from a terminal table. Combines several miscellaneous parts of the terminal table into a uniform interface.") (COND ((NUMBERP PROP) (ECHOCONTROL PROP NEWVALUE TTBL)) ((FMEMB PROP '(CHARDELETE WORDDELETE LINEDELETE RETYPE CTRLV EOL)) (SETSYNTAX NEWVALUE PROP TTBL)) ((FMEMB PROP '(1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL)) (DELETECONTROL PROP NEWVALUE TTBL)) ((EQ PROP 'LINEDELETESTR) (DELETECONTROL 'LINEDELETE NEWVALUE TTBL)) ((EQ PROP 'ECHODELS?) (DELETECONTROL (COND (NEWVALUE 'ECHO) (T 'NOECHO)) NIL TTBL)) ((EQ PROP 'CONTROL) (CONTROL NEWVALUE TTBL)) ((EQ PROP 'RAISE) (RAISE NEWVALUE TTBL)) ((EQ PROP 'ECHOMODE) (ECHOMODE NEWVALUE TTBL]) ) (ADDTOVAR INSPECTMACROS (READTABLEP RDTBL\NONOTHERCODES GETSYNTAXPROP SETSYNTAXPROP) (TERMTABLEP (CHARDELETE WORDDELETE LINEDELETE RETYPE CTRLV EOL RAISE ECHOMODE LINEDELETESTR 1STCHDEL NTHCHDEL POSTCHDEL EMPTYCHDEL ECHODELS? CONTROL 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31) GETTTBLPROP SETTTBLPROP)) (* ; "Hunk inspector") (DEFINEQ (INSPECT/AS/BLOCKRECORD [LAMBDA (INSTANCE WHERE CHOICES) (* ; "Edited 3-Feb-87 16:50 by jop") (* ;; "offers the user a choice of record types to inspect INSTANCE with.") (LET (RECNAME) (COND ([NULL (OR CHOICES (SETQ CHOICES (LIST-ALL-BLOCKRECORDS] (printout PROMPTWINDOW T "Can't Inspect " INSTANCE)) ([SETQ RECNAME (MENU (create MENU ITEMS _ CHOICES WHENHELDFN _ (FUNCTION (LAMBDA (ITEM) (PROMPTPRINT "Will inspect the list as if it were a " ITEM] (INSPECT INSTANCE RECNAME WHERE]) (INSPECT/TYPELESS [LAMBDA (ITEM WHERE) (* ; "Edited 2-Feb-87 17:08 by jop") (* ;; "Inspects an object that is typeless. Check very carefully to see if it might be an arrayblock, in which case we can try to inspect it as some kind of array. Otherwise, we might be able to interpret it as some block record.") (LET (HDR TRLR) (COND ((AND (type? ARRAYBLOCK ITEM) [\VALIDADDRESSP (SETQ HDR (\ADDBASE ITEM (IMINUS \ArrayBlockHeaderWords] (EQ (fetch (ARRAYBLOCK PASSWORD) of HDR) \ArrayBlockPassword) (fetch (ARRAYBLOCK INUSE) of HDR) (\VALIDADDRESSP (SETQ TRLR (fetch (ARRAYBLOCK TRAILER) of HDR))) (EQ (fetch (ARRAYBLOCK PASSWORD) of TRLR) \ArrayBlockPassword)) (INSPECT/HUNK ITEM WHERE (fetch (ARRAYBLOCK GCTYPE) of HDR) (IDIFFERENCE (UNFOLD (fetch (ARRAYBLOCK ARLEN) of HDR) WORDSPERCELL) \ArrayBlockOverheadWords))) (T (INSPECT/AS/BLOCKRECORD ITEM WHERE]) (LIST-ALL-BLOCKRECORDS [LAMBDA NIL (* bvm%: "16-Jun-86 11:22") (for RECDEC in USERRECLST when (EQ (CAR RECDEC) 'BLOCKRECORD) collect (CADR RECDEC]) (INSPECT/HUNK [LAMBDA (DATUM WHERE GCTYPE SIZE) (* ; "Edited 7-Aug-87 10:07 by jop") (* ;; "Inspects a typeless DATUM, which is either a hunk or an array block, with indicated GCTYPE and SIZE in words.") (PROG (ELTSPEC BLOCKRECS) [SELECTC GCTYPE (CODEBLOCK.GCT (* ; "Compiled code lives here") (RETURN (INSPECTCODE (INSPECT/MAKE/CCODEP DATUM) WHERE))) (PTRBLOCK.GCT (* ;  "Pointers live here, so size is unambiguous") (SETQ ELTSPEC '(32 \INSPECT.FETCH.PTR \INSPECT.STORE.PTR))) (PROGN (* ;  "Completely unboxed, so we don't know how to interpret it") (COND ([NULL (SETQ ELTSPEC (MENU (create MENU ITEMS _ (COND ((SETQ BLOCKRECS (  LIST-ALL-BLOCKRECORDS )) (CONS '("As BLOCKRECORD" 'BLOCKRECORD) INSPECT.HUNK.COMMANDS)) (T INSPECT.HUNK.COMMANDS)) CENTERFLG _ T] (RETURN NIL)) ((EQ ELTSPEC 'BLOCKRECORD) (RETURN (INSPECT/AS/BLOCKRECORD DATUM WHERE BLOCKRECS] (* ;;; "At this point ELTSPEC is a list of (itemsize fetchfn storefn). Create an inspector that inspects the appropriate number of items, based on the size") (INSPECTW.CREATE DATUM (for I from 0 to (IMIN (SUB1 (IQUOTIENT (UNFOLD SIZE BITSPERWORD) (CAR ELTSPEC))) MAXINSPECTARRAYLEVEL) collect I) (CADR ELTSPEC) (CADDR ELTSPEC) NIL NIL NIL NIL NIL WHERE]) (\INSPECT.DATATYPE.RAW.FETCH [LAMBDA (INSTANCE FIELD DESCRS) (* ; "Edited 3-Feb-87 16:55 by jop") (* ;; "Used to fetch fields of datatype where we have only the field descriptors, not the original user declaration") (FETCHFIELD (CAR (NTH DESCRS FIELD)) INSTANCE]) (\INSPECT.FETCH.8 [LAMBDA (INSTANCE FIELD) (* bvm%: "16-Jun-86 11:35") (\GETBASEBYTE INSTANCE FIELD]) (\INSPECT.FETCH.32 [LAMBDA (INSTANCE FIELD) (* bvm%: "16-Jun-86 11:35") (\GETBASEFIXP INSTANCE (UNFOLD FIELD WORDSPERCELL]) (\INSPECT.FETCH.CHAR [LAMBDA (INSTANCE FIELD) (* bvm%: "16-Jun-86 11:36") (CHARACTER (\GETBASEBYTE INSTANCE FIELD]) (\INSPECT.FETCH.FATCHAR [LAMBDA (INSTANCE FIELD) (* bvm%: "16-Jun-86 11:36") (CHARACTER (\GETBASE INSTANCE FIELD]) (\INSPECT.FETCH.PTR [LAMBDA (INSTANCE FIELD) (* bvm%: "16-Jun-86 13:53") (\GETBASEPTR INSTANCE (UNFOLD FIELD WORDSPERCELL]) (\INSPECT.STORE.8 [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:04 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.8 INSTANCE FIELD (\GETBASEBYTE INSTANCE FIELD))) (\PUTBASEBYTE INSTANCE FIELD NEWVALUE]) (\INSPECT.STORE.16 [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:27 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.16 INSTANCE FIELD (\GETBASE INSTANCE FIELD))) (\PUTBASE INSTANCE FIELD NEWVALUE]) (\INSPECT.STORE.32 [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:05 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.32 INSTANCE FIELD (\INSPECT.FETCH.32 INSTANCE FIELD))) (\PUTBASEFIXP INSTANCE (UNFOLD FIELD WORDSPERCELL) NEWVALUE]) (\INSPECT.STORE.CHAR [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:05 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.8 INSTANCE FIELD (\GETBASEBYTE INSTANCE FIELD))) (\PUTBASEBYTE INSTANCE FIELD (CHARCODE.DECODE NEWVALUE]) (\INSPECT.STORE.FATCHAR [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:27 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.16 INSTANCE FIELD (\GETBASE INSTANCE FIELD))) (\PUTBASE INSTANCE FIELD (CHARCODE.DECODE NEWVALUE]) (\INSPECT.STORE.PTR [LAMBDA (INSTANCE FIELD NEWVALUE) (* ; "Edited 7-Aug-87 10:27 by jop") (if (CONFIRM-SET) then (UNDOSAVE (LIST '\INSPECT.STORE.PTR INSTANCE FIELD (\GETBASEPTR INSTANCE FIELD))) (\RPLPTR INSTANCE (UNFOLD FIELD WORDSPERCELL) NEWVALUE]) (INSPECT/MAKE/CCODEP [LAMBDA (CODE) (* bvm%: " 7-Jul-86 16:25") (MAKE-COMPILED-CLOSURE CODE]) ) (RPAQ? INSPECT.HUNK.COMMANDS '[("As 8-bit array" '(8 \GETBASEBYTE \INSPECT.STORE.8)) ("As 16-bit array" '(16 \GETBASE \INSPECT.STORE.16)) ("As 32-bit array" '(32 \INSPECT.FETCH.32 \INSPECT.STORE.32)) ("As Character array" '(8 \INSPECT.FETCH.CHAR \INSPECT.STORE.CHAR)) ("As Fat Character array" '(16 \INSPECT.FETCH.FATCHAR \INSPECT.STORE.FATCHAR]) (PUTPROPS INSPECT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1991 1993 1995 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7014 42742 (INSPECTW.CREATE 7024 . 11779) (INSPECTW.REPAINTFN 11781 . 17317) ( INSPECTW.REDISPLAY 17319 . 26191) (\INSPECTW.VALUE.MARGIN 26193 . 26596) (INSPECTW.REPLACE 26598 . 27306) (INSPECTW.SELECTITEM 27308 . 28298) (\INSPECTW.REDISPLAYPROP 28300 . 30730) (INSPECTW.FETCH 30732 . 31155) (INSPECTW.PROPERTIES 31157 . 31798) (DECODE.WINDOW.ARG 31800 . 33528) ( DEFAULT.INSPECTW.PROPCOMMANDFN 33530 . 35548) (DEFAULT.INSPECTW.VALUECOMMANDFN 35550 . 36808) ( DEFAULT.INSPECTW.TITLECOMMANDFN 36810 . 38500) (\SELITEM.FROM.PROPERTY 38502 . 38944) ( \INSPECT.COMPUTE.TITLE 38946 . 40072) (LEVELEDFORM 40074 . 40793) (MAKEWITHINREGION 40795 . 42740)) ( 42743 60044 (ITEMW.REPAINTFN 42753 . 43973) (\ITEM.WINDOW.BUTTON.HANDLER 43975 . 44390) ( \ITEM.WINDOW.SELECTION.HANDLER 44392 . 47059) (\INSPECTW.COMMAND.HANDLER 47061 . 51062) ( ITEM.WINDOW.SET.STACK.ARG 51064 . 53268) (REPLACESTKARG 53270 . 54369) (IN/ITEM? 54371 . 55253) ( \ITEMW.DESELECTITEM 55255 . 55519) (\ITEMW.SELECTITEM 55521 . 55783) (\ITEMW.CLEARSELECTION 55785 . 56140) (\ITEMW.FLIPITEM 56142 . 56615) (PRINTANDBOX 56617 . 59126) (PRINTATBOX 59128 . 59645) ( ITEMOFPROPERTYVALUE 59647 . 60042)) (60045 63650 (\ITEM.WINDOW.COPY.HANDLER 60055 . 61776) ( \ITEMW.FLIPCOPY 61778 . 62237) (BKSYSBUF.GENERAL 62239 . 63648)) (64042 86517 (INSPECT 64052 . 68315) (\APPLYINSPECTMACRO 68317 . 69299) (INSPECT/BITMAP 69301 . 70336) (INSPECT/DATATYPE 70338 . 73581) ( INSPECTABLEFIELDNAMES 73583 . 74104) (REMOVEDUPS 74106 . 74311) (INSPECT/ARRAY 74313 . 75350) ( INSPECT/TOP/LEVEL/LIST 75352 . 76311) (INSPECT/PROPLIST 76313 . 77288) (NONSYSPROPNAMES 77290 . 77586) (INSPECT/LISTP 77588 . 77910) (ALISTP 77912 . 78121) (PROPLISTP 78123 . 78763) (INSPECT/ALIST 78765 . 79120) (ASSOCGET 79122 . 79333) (/ASSOCPUT 79335 . 79600) (INSPECT/PLIST 79602 . 79965) ( INSPECT/TYPERECORD 79967 . 80207) (INSPECT/AS/RECORD 80209 . 81333) (SELECT.LIST.INSPECTOR 81335 . 83380) (STANDARDEDITE 83382 . 83665) (NTHTOPLEVELELT 83667 . 83983) (SETNTHTOPLEVELELT 83985 . 84745) (DEDITE 84747 . 84954) (FINDRECDECL 84956 . 85539) (FINDSYSRECDECL 85541 . 85942) ( MAKE-INSPECTOR-PROFILE 85944 . 86329) (CONFIRM-SET 86331 . 86515)) (87849 95938 (INSPECT/ATOM 87859 . 91839) (SELECT.ATOM.ASPECT 91841 . 92985) (INSPECT/AS/FUNCTION 92987 . 95273) (SELECT.FNS.EDITOR 95275 . 95936)) (95979 101378 (INSPECTCODE 95989 . 97135) (\TEDIT.INSPECTCODE 97137 . 99095) ( \INSPECT/CODE/RESHAPEFN 99097 . 100636) (\INSPECT/CODE/REPAINTFN 100638 . 101376)) (101416 102901 ( INSPECT/HARRAYP 101426 . 102053) (HARRAYKEYS 102055 . 102434) (INSPECTW.GETHASH 102436 . 102663) ( INSPECTW.PUTHASH 102665 . 102899)) (102950 106081 (RDTBL\NONOTHERCODES 102960 . 103643) (GETSYNTAXPROP 103645 . 103884) (SETSYNTAXPROP 103886 . 104131) (GETTTBLPROP 104133 . 105051) (SETTTBLPROP 105053 . 106079)) (106560 114943 (INSPECT/AS/BLOCKRECORD 106570 . 107453) (INSPECT/TYPELESS 107455 . 108701) ( LIST-ALL-BLOCKRECORDS 108703 . 108978) (INSPECT/HUNK 108980 . 111586) (\INSPECT.DATATYPE.RAW.FETCH 111588 . 111914) (\INSPECT.FETCH.8 111916 . 112065) (\INSPECT.FETCH.32 112067 . 112238) ( \INSPECT.FETCH.CHAR 112240 . 112403) (\INSPECT.FETCH.FATCHAR 112405 . 112567) (\INSPECT.FETCH.PTR 112569 . 112740) (\INSPECT.STORE.8 112742 . 113048) (\INSPECT.STORE.16 113050 . 113350) ( \INSPECT.STORE.32 113352 . 113787) (\INSPECT.STORE.CHAR 113789 . 114115) (\INSPECT.STORE.FATCHAR 114117 . 114439) (\INSPECT.STORE.PTR 114441 . 114788) (INSPECT/MAKE/CCODEP 114790 . 114941))))) STOP \ No newline at end of file diff --git a/sources/INSPECT-CLOSURE b/sources/INSPECT-CLOSURE new file mode 100644 index 00000000..719edad6 --- /dev/null +++ b/sources/INSPECT-CLOSURE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 18:23:44" |{DSK}local>lde>lispcore>sources>INSPECT-CLOSURE.;2| 5126 |changes| |to:| (VARS INSPECT-CLOSURECOMS) |previous| |date:| " 3-Feb-88 15:15:04" |{DSK}local>lde>lispcore>sources>INSPECT-CLOSURE.;1|) ; Copyright (c) 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT INSPECT-CLOSURECOMS) (RPAQQ INSPECT-CLOSURECOMS ( (* |;;;| "A nicer inspector for lexical closures.") (FUNCTIONS INSPECT-CLOSURE CLOSURE-PROPERTIES CLOSURE-FETCHFN CLOSURE-STOREFN) (ADDVARS (INSPECTMACROS ((FUNCTION CLOSURE-P) . INSPECT-CLOSURE))))) (* |;;;| "A nicer inspector for lexical closures.") (CL:DEFUN INSPECT-CLOSURE (CLOSURE TYPE WHERE) (INSPECTW.CREATE CLOSURE (CLOSURE-PROPERTIES CLOSURE) 'CLOSURE-FETCHFN 'CLOSURE-STOREFN NIL NIL NIL NIL NIL NIL #'(CL:LAMBDA (PROP DATUM) (CL:IF (NULL (CDR PROP)) NIL (CAR PROP))))) (CL:DEFUN CLOSURE-PROPERTIES (CLOSURE) "Make up a property description for a closure." (* |;;| "Does not list fields that aren't present in the closure. Tags the fields present with a dummy field, which the inspect module is kind enough to provide.") (LIST* '("function" FUNCTION) (* \; "The function in the closure.") (CL:MAPCAN (* \;  "Here we compute the properties from the environment.") #'(CL:LAMBDA (SUB-ENV-NAME SUB-ENV-GET &OPTIONAL (SUB-ENV (CL:FUNCALL SUB-ENV-GET ( CLOSURE-ENVIRONMENT CLOSURE)))) (CL:WHEN SUB-ENV (* \;  "Only display if there's something in this part of the environment.") (LIST* `(,(CL:STRING-DOWNCASE (CL:SYMBOL-NAME SUB-ENV-NAME))) (* \; "Dummy field printed in middle.") (CL:DO ((PLIST SUB-ENV (CDDR PLIST)) (PROP-SPECS NIL)) ((NULL PLIST) PROP-SPECS) (CL:PUSH `(,(CL:FIRST PLIST) ,SUB-ENV-NAME) PROP-SPECS))))) '(VARS FUNCTIONS BLOCKS TAGBODIES) '(ENVIRONMENT-VARS ENVIRONMENT-FUNCTIONS ENVIRONMENT-BLOCKS ENVIRONMENT-TAGBODIES)))) (CL:DEFUN CLOSURE-FETCHFN (CLOSURE PROP) (COND ((NULL (CDR PROP)) (CAR PROP)) ((EQ (CADR PROP) 'FUNCTION) (CLOSURE-FUNCTION CLOSURE)) (T (LET (ACCESSOR) (CL:IF (SETQ ACCESSOR (CDR (CL:ASSOC (CADR PROP) '((VARS . ENVIRONMENT-VARS) (FUNCTIONS . ENVIRONMENT-FUNCTIONS) (BLOCKS . ENVIRONMENT-BLOCKS) (TAGBODIES . ENVIRONMENT-TAGBODIES)) :TEST 'EQ))) (CL:GETF (CL:FUNCALL ACCESSOR (CLOSURE-ENVIRONMENT CLOSURE)) (CAR PROP))))))) (CL:DEFUN CLOSURE-STOREFN (CLOSURE PROP VALUE) (COND ((NULL (CDR PROP)) NIL) ((EQ (CADR PROP) 'FUNCTION) (CL:SETF (CLOSURE-FUNCTION CLOSURE) VALUE)) (T (LET (ACCESSOR) (CL:IF (SETQ ACCESSOR (CDR (CL:ASSOC (CADR PROP) '((VARS . ENVIRONMENT-VARS) (FUNCTIONS . ENVIRONMENT-FUNCTIONS) (BLOCKS . ENVIRONMENT-BLOCKS) (TAGBODIES . ENVIRONMENT-TAGBODIES)) :TEST 'EQ))) (LET ((PLIST (CL:FUNCALL ACCESSOR (CLOSURE-ENVIRONMENT CLOSURE)))) (CL:SETF (CL:GETF PLIST (CAR PROP)) VALUE))))))) (ADDTOVAR INSPECTMACROS ((FUNCTION CLOSURE-P) . INSPECT-CLOSURE)) (PUTPROPS INSPECT-CLOSURE COPYRIGHT ("Venue & Xerox Corporation" 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/INTERPRESS b/sources/INTERPRESS new file mode 100644 index 00000000..4799b26a --- /dev/null +++ b/sources/INTERPRESS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 21:56:38"  {DSK}kaplan>Local>medley3.5>lispcore>sources>INTERPRESS.;6 226422 changes to%: (VARS INTERPRESSCOMS) previous date%: "28-Jun-99 16:33:05" {DSK}kaplan>Local>medley3.5>lispcore>sources>INTERPRESS.;3) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT INTERPRESSCOMS) (RPAQQ INTERPRESSCOMS [(COMS (* ; "Literal interface") [DECLARE%: DONTCOPY (* ;  "Change or remove when full IP-82 exists on printers") (CONSTANTS (ENCODING 'IP-82] [INITVARS (CHARACTERCODEVERSION 'XC1-1-1) (INTERPRESSVERSION "2.1") (PRINTSERVICE 10.0) (DEFAULTINTERPRESSMEDIUM '(PAPER (KNOWN.SIZE "US.LETTER"] (VARS KNOWN.MEDIA.SIZES) [COMS (DECLARE%: DONTCOPY (CONSTANTS * RATIONALS) (* ;  "MICASPERINCH is used by HARDCOPY") (EXPORT (CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100))) (CONSTANTS (\INTERPRESSSCALE (FQUOTIENT MICASPERINCH POINTSPERINCH)) (MicasToDev (FQUOTIENT 300 MICASPERINCH] (FNS APPENDBYTE.IP APPENDIDENTIFIER.IP APPENDINT.IP APPENDINTEGER.IP APPENDLARGEVECTOR.IP APPENDNUMBER.IP APPENDOP.IP APPENDRATIONAL.IP APPENDSEQUENCEDESCRIPTOR.IP BYTESININT.IP)) (COMS (* ; "Operator interface") (FNS ARCTO.IP BEGINMASTER.IP BEGINPAGE.IP BEGINPREAMBLE.IP CLIPRECTANGLE.IP CONCAT.IP CONCATT.IP ENDMASTER.IP ENDPAGE.IP ENDPREAMBLE.IP FGET.IP FILLRECTANGLE.IP FILLTRAJECTORY.IP FILLNGON.IP FSET.IP GETFRAMEVAR.IP INITIALIZEMASTER.IP INITIALIZECOLOR.IP ISET.IP GETCP.IP LINETO.IP MASKSTROKE.IP MOVETO.IP ROTATE.IP SCALE.IP SCALE2.IP SETCOLOR.IP SETRGB.IP SETCOLORLV.IP SETCOLOR16.IP SETFONT.IP SETSPACE.IP SETXREL.IP SETX.IP SETXY.IP SETXYREL.IP SETY.IP SETYREL.IP SHOW.IP TRAJECTORY.IP TRANS.IP TRANSLATE.IP)) (COMS (* ; "DIG interface") (FNS \CHANGE-VISIBLE-REGION.IP \PAPERSIZE.IP HEADINGOP.IP) (FNS DEFINEFONT.IP FONTNAME.IP INTERPRESS.BITMAPSCALE INTERPRESS.OUTCHARFN INTERPRESSFILEP MAKEINTERPRESS NEWLINE.IP NEWPAGE.IP NEWPAGE?.IP OPENIPSTREAM SETUPFONTS.IP SHOWBITMAP.IP \BITMAPSIZE.IP SHOWBITMAP1.IP SHOWSHADE.IP \BITBLT.IP \SCALEDBITBLT.IP \BLTSHADE.IP \CHARWIDTH.IP \CLOSEIPSTREAM \DRAWARC.IP \DRAWCURVE.IP \DRAWPOINT.IP \DSPCOLOR.IP ENSURE.RGB \IPCURVE2 \CLIPCURVELINE.IP \DRAWLINE.IP \CLIPLINE \DSPBOTTOMMARGIN.IP \DSPFONT.IP \DSPLEFTMARGIN.IP \DSPLINEFEED.IP \DSPRIGHTMARGIN.IP \DSPSPACEFACTOR.IP \DSPTOPMARGIN.IP \DSPXPOSITION.IP \DSPROTATE.IP \PUSHSTATE.IP \POPSTATE.IP \DEFAULTSTATE.IP \DSPTRANSLATE.IP \DSPSCALE2.IP \DSPYPOSITION.IP FILLCIRCLE.IP \FILLPOLYGON.IP \DRAWPOLYGON.IP \FIXLINELENGTH.IP \MOVETO.IP \SETBRUSH.IP \STRINGWIDTH.IP \DSPCLIPPINGREGION.IP \DSPOPERATION.IP)) (COMS (* ;  "Patch controller for the %"Bonnet%" printer bug that loses X,Y position when you do a DSPFONT") (INITVARS (*INTERPRESS-PRINTER-DSPFONT-PATCH* NIL))) (COMS (* ; "image state") (FNS IP-TOS POP-IP-STACK PUSH-IP-STACK) (RECORDS IPSTATE)) (FNS \CREATECHARSET.IP \CHANGECHARSET.IP) (FNS \INTERPRESSINIT) (FNS SCALEREGION) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (\SPLINESTEP.IP 16.0))) [DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS IPPAGEREGION.ROT180 IPPAGEREGION.ROT270 [DEFAULTPAGEREGION (SCALEREGION 2540 (CREATEREGION 1.1 0.75 (- 7.5 1.1) (- 10.5 0.75] (DEFAULTLANDPAGEREGION (SCALEREGION 2540 (CREATEREGION 0.75 1.1 (- 10.5 0.75) (- 7.5 1.1] (* ; "Interpress encoding values") (DECLARE%: DONTCOPY (CONSTANTS MAXSEGSPERTRAJECTORY) (CONSTANTS * NONPRIMS) (CONSTANTS * SEQUENCETYPES) (CONSTANTS * IPTYPES) (CONSTANTS * OPERATORS) (CONSTANTS * TOKENFORMATS) (CONSTANTS * IMAGERVARIABLES) (CONSTANTS * STROKEENDS) (CONSTANTS * IP82CONSTANTS)) (DECLARE%: DONTCOPY (MACROS APPENDBYTE.IP APPENDOP.IP .IPFONTNAME. APPENDINT.IPMACRO APPENDINTEGER.IPMACRO \IMAGEPATH.IP \WIDTHFROMBRUSH \VISIBLE.IP) (RECORDS IPSTREAM INTERPRESSDATA)) (INITRECORDS IPSTREAM INTERPRESSDATA) (FNS INTERPRESSBITMAP) (ALISTS (IMAGESTREAMTYPES INTERPRESS)) (* ;; "HOSTNAMEP is NILL for DOCUPRINT instead of NSPRINTER.HOSTNAMEP, since that predicate merely tests for colon in the name. DOCUPRINT printers are only recognized from their PRINTERTYPE property, which must be on their CANONICAL.HOSTNAME. Preference is for INTERPRESS (CANPRINT ordering), for backward compatibility. But printer can be put on DEFAULTPRINTINGHOST twice, with the type CONSed on to the name, to give the user dynamic selection.") [ADDVARS [PRINTERTYPES ((DOCUPRINT) (CANPRINT (INTERPRESS POSTSCRIPT)) (HOSTNAMEP NILL) (STATUS NSPRINTER.STATUS) (PROPERTIES NSPRINTER.PROPERTIES) (SEND NSPRINT) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))) ((INTERPRESS 8044) (CANPRINT (INTERPRESS)) (HOSTNAMEP NSPRINTER.HOSTNAMEP) (STATUS NSPRINTER.STATUS) (PROPERTIES NSPRINTER.PROPERTIES) (SEND NSPRINT) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE] (PRINTFILETYPES (INTERPRESS (TEST INTERPRESSFILEP) (EXTENSION (IP IPR INTERPRESS)) (CONVERSION (TEXT MAKEINTERPRESS TEDIT \TEDIT.HARDCOPY] (INITVARS (DEFAULT.INTERPRESS.BITMAP.ROTATION 90)) (ALISTS (SYSTEMINITVARS INTERPRESSFONTDIRECTORIES)) [INITVARS (INTERPRESSFONTEXTENSIONS '(WD)) (INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>")) (INTERPRESSPRINTWHEELFAMILIES '(BOLDPS ELITE LETTERGOTHIC MASTER PICA PSBOLD SCIENTIFIC SPOKESMAN TITAN TREND TRENDPS TROJAN VINTAGE)) (INTERPRESSFAMILYALIASES '(LOGO LOGOTYPES-XEROX] (COMS (* ; "NS Character Encoding") (FNS NSMAP \COERCEASCIITONSFONT \CREATEINTERPRESSFONT \SEARCHINTERPRESSFONTS) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (noInfoCode 32768))) (INITVARS (ASCIITONSTRANSLATIONS)) (* ;  "Catch the GACHA10 and any BI coercions to MODERN") (ADDVARS (ASCIITONSTRANSLATIONS (TIMESROMAN NIL CLASSIC) (GACHA NIL TERMINAL) (HELVETICA) (CLASSIC) (GACHA) (TIMESROMAN) (LOGO NIL LOGOTYPES) (HIPPO HIPPOTONSARRAY CLASSIC) (CYRILLIC CYRILLICTONSARRAY CLASSIC) (SYMBOL \SYMBOLTONSARRAY MODERN))) (UGLYVARS \SYMBOLTONSARRAY HIPPOTONSARRAY CYRILLICTONSARRAY)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INTERPRESSINIT))) (DECLARE%: EVAL@COMPILE DONTCOPY (P (LOADDEF 'SYSTEMBRUSH 'RESOURCES 'IMAGEIO) (LOADDEF 'BRUSH 'RECORDS 'IMAGEIO]) (* ; "Literal interface") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ ENCODING IP-82) (CONSTANTS (ENCODING 'IP-82)) ) ) (RPAQ? CHARACTERCODEVERSION 'XC1-1-1) (RPAQ? INTERPRESSVERSION "2.1") (RPAQ? PRINTSERVICE 10.0) (RPAQ? DEFAULTINTERPRESSMEDIUM '(PAPER (KNOWN.SIZE "US.LETTER"))) (RPAQQ KNOWN.MEDIA.SIZES (("US.LETTER" (216 279)) ("US.LEGAL" (216 356)) ("A0" (841 1189)) ("A1" (594 841)) ("A2" (420 594)) ("A3" (297 420)) ("A4" (210 297)) ("A5" (148 210)) ("A6" (105 148)) ("A7" (74 105)) ("A8" (52 74)) ("A9" (37 52)) ("A10" (26 37)) ("ISO.B0" (1000 1414)) ("ISO.B1" (707 1000)) ("ISO.B2" (500 707)) ("ISO.B3" (353 500)) ("ISO.B4" (250 353)) ("ISO.B5" (176 250)) ("ISO.B6" (125 176)) ("ISO.B7" (88 125)) ("ISO.B8" (62 88)) ("ISO.B9" (44 62)) ("ISO.B10" (31 44)) ("JIS.B0" (1030 1456)) ("JIS.B1" (728 1030)) ("JIS.B2" (515 728)) ("JIS.B3" (364 515)) ("JIS.B4" (257 364)) ("JIS.B5" (182 257)) ("JIS.B6" (128 182)) ("JIS.B7" (91 128)) ("JIS.B8" (64 91)) ("JIS.B9" (45 64)) ("JIS.B10" (32 45)))) (DECLARE%: DONTCOPY (RPAQQ RATIONALS ((METERSPERRAVENSPOT 1/11811) (MICASPERSCREENPOINT 127/4) (SCREENPOINTSPERMICA 4/127) (MICASPERPOINT 635/18) (POINTSPERINCH 72) (POINTSPERMICA 18/635) (POINTSPERMETER 360000/127) (METERSPERPOINT 127/360000) (MICASPERMETER 100000) (METERSPERMICA 1/100000) (RATZERO 0) (RATONE 1) (RAVENSPOTSPERINCH 300) (MICASPERRAVENSPOT 127/15) (RAVENSPOTSPERMICA 15/127) (ONEHALF 1/2))) (DECLARE%: EVAL@COMPILE (RPAQQ METERSPERRAVENSPOT 1/11811) (RPAQQ MICASPERSCREENPOINT 127/4) (RPAQQ SCREENPOINTSPERMICA 4/127) (RPAQQ MICASPERPOINT 635/18) (RPAQQ POINTSPERINCH 72) (RPAQQ POINTSPERMICA 18/635) (RPAQQ POINTSPERMETER 360000/127) (RPAQQ METERSPERPOINT 127/360000) (RPAQQ MICASPERMETER 100000) (RPAQQ METERSPERMICA 1/100000) (RPAQQ RATZERO 0) (RPAQQ RATONE 1) (RPAQQ RAVENSPOTSPERINCH 300) (RPAQQ MICASPERRAVENSPOT 127/15) (RPAQQ RAVENSPOTSPERMICA 15/127) (RPAQQ ONEHALF 1/2) (CONSTANTS (METERSPERRAVENSPOT 1/11811) (MICASPERSCREENPOINT 127/4) (SCREENPOINTSPERMICA 4/127) (MICASPERPOINT 635/18) (POINTSPERINCH 72) (POINTSPERMICA 18/635) (POINTSPERMETER 360000/127) (METERSPERPOINT 127/360000) (MICASPERMETER 100000) (METERSPERMICA 1/100000) (RATZERO 0) (RATONE 1) (RAVENSPOTSPERINCH 300) (MICASPERRAVENSPOT 127/15) (RAVENSPOTSPERMICA 15/127) (ONEHALF 1/2)) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RPAQQ MICASPERINCH 2540) (RPAQQ MICASPERMILLIMETER 100) (CONSTANTS (MICASPERINCH 2540) (MICASPERMILLIMETER 100)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQ \INTERPRESSSCALE (FQUOTIENT MICASPERINCH POINTSPERINCH)) (RPAQ MicasToDev (FQUOTIENT 300 MICASPERINCH)) (CONSTANTS (\INTERPRESSSCALE (FQUOTIENT MICASPERINCH POINTSPERINCH)) (MicasToDev (FQUOTIENT 300 MICASPERINCH))) ) ) (DEFINEQ (APPENDBYTE.IP [LAMBDA (STREAM BYTE) (* rmk%: "21-JUN-82 23:30") (\BOUT STREAM BYTE]) (APPENDIDENTIFIER.IP [LAMBDA (STREAM STRING) (* jds "14-Mar-84 10:42") (* ;; "Put an identifier into the IP file. NB that the characters in the identifier are ASCII, NOT NS CHARACTERS!!!!") (APPENDSEQUENCEDESCRIPTOR.IP STREAM SEQIDENTIFIER (NCHARS STRING)) (for C instring (MKSTRING STRING) do (\BOUT STREAM C]) (APPENDINT.IP [LAMBDA (STREAM NUM LENGTH) (* lmm " 2-May-85 21:13") (for I from (SUB1 LENGTH) to 0 by -1 do (APPENDBYTE.IP STREAM (LOADBYTE NUM (UNFOLD I BITSPERBYTE) BITSPERBYTE]) (APPENDINTEGER.IP [LAMBDA (STREAM N) (* ; "Edited 13-Jan-88 01:32 by FS") (COND ((AND (ILEQ -4000 N) (ILEQ N 28767)) (APPENDINT.IPMACRO STREAM (IPLUS N 4000) 2)) (T (PROG ((LEN (BYTESININT.IP N))) (APPENDSEQUENCEDESCRIPTOR.IP STREAM SEQINTEGER LEN) (APPENDINT.IP STREAM N LEN]) (APPENDLARGEVECTOR.IP [LAMBDA (STREAM ARRAY) (* rmk%: "25-JUN-82 22:26") (* ;; "Appends a large vector stored as an Interlisp array. NUMELEMENTS is not an argument, since we assume that the caller can pass a SUBARRAY if he so intends.") (PROG (INTSIZE (ASIZE (ARRAYSIZE ARRAY)) (AORIG (ARRAYORIG ARRAY))) [SETQ INTSIZE (for I from AORIG to (SUB1 (IPLUS ASIZE AORIG)) largest (BYTESININT.IP (ELT ARRAY I] (APPENDSEQUENCEDESCRIPTOR.IP STREAM SEQLARGEVECTOR (ADD1 (ITIMES ASIZE INTSIZE))) (for I from AORIG to (SUB1 (IPLUS ASIZE AORIG)) do (APPENDINT.IP STREAM (ELT ARRAY I) INTSIZE]) (APPENDNUMBER.IP [LAMBDA (STREAM R) (* ; "Edited 13-Jan-88 01:22 by FS") (COND ((FIXP R) (APPENDINTEGER.IPMACRO STREAM R)) (T (OR (TYPEP R 'RATIO) (SETQ R (CL:RATIONAL R))) (APPENDRATIONAL.IP STREAM (CL:NUMERATOR R) (CL:DENOMINATOR R]) (APPENDOP.IP [LAMBDA (STREAM OP) (* rmk%: "22-JUN-82 01:28") (COND ((OR (ILESSP OP 0) (IGREATERP OP 8191)) (ERROR "Invalid Interpress operator code:" OP))) (COND ((ILEQ OP 31) (APPENDBYTE.IP STREAM (LOGOR SHORTOP OP))) (T (APPENDBYTE.IP STREAM (LOGOR LONGOP (FOLDLO OP 256))) (APPENDBYTE.IP STREAM (MOD OP 256]) (APPENDRATIONAL.IP [LAMBDA (STREAM N D) (* rmk%: "20-JUL-82 23:45") (PROG [(I (IMAX (BYTESININT.IP N) (BYTESININT.IP D] (APPENDSEQUENCEDESCRIPTOR.IP STREAM SEQRATIONAL (UNFOLD I 2)) (APPENDINT.IP STREAM N I) (APPENDINT.IP STREAM D I]) (APPENDSEQUENCEDESCRIPTOR.IP [LAMBDA (STREAM TYPE LENGTH) (* edited%: "30-MAY-83 23:19") (COND ((OR (ILESSP TYPE 0) (IGREATERP TYPE 31)) (ERROR "Invalid Interpress type" TYPE))) (COND ([OR (ILESSP LENGTH 0) (IGREATERP LENGTH (CONSTANT (SUB1 (EXPT 2 24] (ERROR "Interpress sequence length too long" LENGTH))) (COND ((ILESSP LENGTH 256) (* ;  "Short sequence, with one byte of length") (APPENDBYTE.IP STREAM (LOGOR SHORTSEQUENCE TYPE)) (APPENDBYTE.IP STREAM LENGTH)) (T (* ;  "Long sequence, with 3 bytes of length") (APPENDBYTE.IP STREAM (LOGOR LONGSEQUENCE TYPE)) (APPENDINT.IP STREAM LENGTH 3]) (BYTESININT.IP [LAMBDA (N) (* rmk%: "20-OCT-82 17:28") (FOLDHI (ADD1 (INTEGERLENGTH N)) BITSPERBYTE]) ) (* ; "Operator interface") (DEFINEQ (ARCTO.IP [LAMBDA (IPSTREAM X1 Y1 X2 Y2) (* ; "Edited 1-Feb-89 15:42 by FS") (* ;; "Relative (like MOVETO) circular (in world coordinates) arc, passing through current x, y, and x1,y1 and x2,y2.") (* ;; "") (* ;; "This operation may not be supported in most Xerox implementations of Interpress, I believe this is not part of Interpress2.1 (INTERPRESSVERSION).") (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP X1) (FIXR X1)) (T X1))) (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP Y1) (FIXR Y1)) (T Y1))) (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP X2) (FIXR X2)) (T X2))) (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP Y2) (FIXR Y2)) (T Y2))) (APPENDOP.IP IPSTREAM ARCTO]) (BEGINMASTER.IP [LAMBDA (IPSTREAM) (* jds " 4-Dec-84 17:58") (APPENDOP.IP IPSTREAM BEGINMASTER]) (BEGINPAGE.IP [LAMBDA (IPSTREAM) (* FS " 4-Mar-86 14:23") (APPENDOP.IP IPSTREAM BEGINPAGE) (replace IPPAGESTATE of (fetch IPDATA of IPSTREAM) with 'PAGE]) (BEGINPREAMBLE.IP [LAMBDA (IPSTREAM) (* rmk%: "13-JUL-82 17:39") (APPENDOP.IP IPSTREAM BEGINPREAMBLE) (replace IPPAGESTATE of (fetch IPDATA of IPSTREAM) with 'PREAMBLE]) (CLIPRECTANGLE.IP [LAMBDA (IPSTREAM X Y W H) (* ; "Edited 1-Feb-89 16:39 by FS") (* ;; "Not supported in Interpress2.1") (APPENDNUMBER.IP IPSTREAM X) (APPENDNUMBER.IP IPSTREAM Y) (APPENDNUMBER.IP IPSTREAM W) (APPENDNUMBER.IP IPSTREAM H) (APPENDOP.IP IPSTREAM CLIPRECTANGLE]) (CONCAT.IP [LAMBDA (IPSTREAM) (* rmk%: " 7-JUN-83 17:41") (APPENDOP.IP IPSTREAM CONCAT]) (CONCATT.IP [LAMBDA (IPSTREAM) (* rmk%: " 7-JUL-82 00:08") (APPENDOP.IP IPSTREAM CONCATT]) (ENDMASTER.IP [LAMBDA (IPSTREAM) (* jds " 4-Dec-84 17:58") (* ;  "Put out the token to end the master") (APPENDOP.IP IPSTREAM ENDMASTER]) (ENDPAGE.IP [LAMBDA (IPSTREAM) (* FS " 4-Mar-86 14:23") (SHOW.IP IPSTREAM) (APPENDOP.IP IPSTREAM ENDPAGE) (replace IPPAGESTATE of (fetch IPDATA of IPSTREAM) with NIL]) (ENDPREAMBLE.IP [LAMBDA (IPSTREAM) (* FS " 4-Mar-86 14:24") (PROG ((IPDATA (fetch IPDATA of IPSTREAM))) (replace IPPREAMBLEFONTS of IPDATA with (DREVERSE (fetch IPPAGEFONTS of IPDATA))) (* ;  "Reverse on tenuous assumption that first fonts are more frequent") (replace IPPREAMBLENEXTFRAMEVAR of IPDATA with (fetch IPNEXTFRAMEVAR of IPDATA)) (APPENDOP.IP IPSTREAM ENDPREAMBLE) (replace IPPAGESTATE of IPDATA with NIL]) (FGET.IP [LAMBDA (IPSTREAM FINDEX) (* rmk%: " 7-JUL-82 00:09") (APPENDNUMBER.IP IPSTREAM FINDEX) (APPENDOP.IP IPSTREAM FGET]) (FILLRECTANGLE.IP [LAMBDA (IPSTREAM LEFT BOTTOM WIDTH HEIGHT) (* ; "Edited 1-Feb-89 16:04 by FS") (* ;;; "Append clipped rectangle description using current Interpress state") (* ;; "FS: This clipping code is wrong. You aren't guaranteed this functions args are device units (300dpi), so converting micas to device units is wrong. They happen to be so (from CIRCSHADE.IP & POLYSHADE.IP), but there may be other callers.") (LET* ((IPDATA (fetch (STREAM IMAGEDATA) of IPSTREAM)) [SCALED-VISTOP (FIXR (TIMES MicasToDev (fetch (INTERPRESSDATA IPVISTOP) of IPDATA] [SCALED-VISBOTTOM (FIXR (TIMES MicasToDev (fetch (INTERPRESSDATA IPVISBOTTOM) of IPDATA] [SCALED-VISLEFT (FIXR (TIMES MicasToDev (fetch (INTERPRESSDATA IPVISLEFT) of IPDATA] [SCALED-VISRIGHT (FIXR (TIMES MicasToDev (fetch (INTERPRESSDATA IPVISRIGHT) of IPDATA] TOP RIGHT) [if (> WIDTH 0) then (SETQ RIGHT (IMIN SCALED-VISRIGHT (+ LEFT WIDTH))) (SETQ LEFT (IMAX LEFT SCALED-VISLEFT)) else (SETQ RIGHT (IMIN LEFT SCALED-VISRIGHT)) (SETQ LEFT (IMAX SCALED-VISLEFT (+ WIDTH LEFT] [if (> HEIGHT 0) then (SETQ TOP (IMIN SCALED-VISTOP (+ BOTTOM HEIGHT))) (SETQ BOTTOM (IMAX BOTTOM SCALED-VISBOTTOM)) else (SETQ TOP (IMIN BOTTOM SCALED-VISTOP)) (SETQ BOTTOM (IMAX SCALED-VISBOTTOM (+ HEIGHT BOTTOM] (SETQ WIDTH (- RIGHT LEFT)) (SETQ HEIGHT (- TOP BOTTOM)) (if (AND (> WIDTH 0) (> HEIGHT 0)) then (APPENDINTEGER.IP IPSTREAM LEFT) (APPENDINTEGER.IP IPSTREAM BOTTOM) (APPENDINTEGER.IP IPSTREAM WIDTH) (APPENDINTEGER.IP IPSTREAM HEIGHT) (APPENDOP.IP IPSTREAM MASKRECTANGLE]) (FILLTRAJECTORY.IP [LAMBDA (IPSTREAM POINTS) (* ; "Edited 2-Feb-89 17:38 by FS") (* ;; "Fills a single trajectory. This is not a particularly useful or interesting function, you should be calling \FILLPOLYGON.IP instead.") (TRAJECTORY.IP IPSTREAM POINTS) (APPENDINTEGER.IP IPSTREAM 1) (* ; "number of trajectories") (APPENDOP.IP IPSTREAM MAKEOUTLINE) (APPENDOP.IP IPSTREAM MASKFILL]) (FILLNGON.IP [LAMBDA (IPSTREAM NPOINTS RADIUS CENTERX CENTERY TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:19 by FS") (* ;; "Create and fill a regular polygon (standing on its tip). Since its convex, we can use the primitive IP operator to do the job. Note there is no clipping in this routine.") (* ;; "Could have used FILLTRAJECTORY.IP, but this function CONSes less. Could have walked 1/8 of circle and used symmetry, but what the heck.......") (LET (BASEANGLE ANGLE X Y) (* ;; "Try to avoid limitations of printers. Anything more than 64 or so looks for all intents and purposes like a circle anyway.") (if (IGREATERP NPOINTS MAXSEGSPERTRAJECTORY) then (SETQ NPOINTS MAXSEGSPERTRAJECTORY)) (SETQ BASEANGLE (FQUOTIENT 360 NPOINTS)) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (* ; "Save state (to undo SETCOLOR)") (APPENDOP.IP IPSTREAM {) (SETCOLOR.IP IPSTREAM TEXTURE OPERATION) (MOVETO.IP IPSTREAM CENTERX (IPLUS CENTERY RADIUS)) (* ; "handle 0 point specially") (* ;; "Note that the trajectory is not closed, IP spec says outlines get closed anyway.") (for I from 1 to (SUB1 NPOINTS) do (SETQ ANGLE (TIMES I BASEANGLE)) (* ;  "Since these are micas, we can avoid some floating point by forcing values to be integer") [SETQ X (IPLUS CENTERX (TIMES RADIUS (SIN ANGLE] [SETQ Y (IPLUS CENTERY (TIMES RADIUS (COS ANGLE] (LINETO.IP IPSTREAM X Y)) (APPENDINTEGER.IP IPSTREAM 1) (* ; "number of trajectories") (APPENDOP.IP IPSTREAM MAKEOUTLINE) (APPENDOP.IP IPSTREAM MASKFILL) (APPENDOP.IP IPSTREAM }) (* ; "restore state") NIL]) (FSET.IP [LAMBDA (IPSTREAM FINDEX) (* rmk%: " 7-JUL-82 00:08") (APPENDNUMBER.IP IPSTREAM FINDEX) (APPENDOP.IP IPSTREAM FSET]) (GETFRAMEVAR.IP [LAMBDA (IPSTREAM) (* rmk%: "18-AUG-83 17:50") (PROG [(FV (fetch IPNEXTFRAMEVAR of (fetch IPDATA of IPSTREAM] (replace IPNEXTFRAMEVAR of (fetch IPDATA of IPSTREAM) with (ADD1 FV)) (RETURN FV]) (INITIALIZEMASTER.IP [LAMBDA (IPSTREAM) (* jds "10-Jan-85 15:48") [for I from 1 do (\BOUT IPSTREAM (OR (NTHCHARCODE NOVERSIONENCODINGSTRING I) (RETURN] [for I from 1 do (\BOUT IPSTREAM (OR (NTHCHARCODE INTERPRESSVERSION I) (RETURN] (\BOUT IPSTREAM (CHARCODE SPACE]) (INITIALIZECOLOR.IP [LAMBDA (IPSTREAM) (* hdj "23-Jan-86 19:20") (LET ((COLORMODELOP.FVAR (GETFRAMEVAR.IP IPSTREAM)) (IPDATA (fetch (STREAM IMAGEDATA) of IPSTREAM))) (* ;; "create data for the color model operator --- colors will range from 0 to 255") (APPENDINTEGER.IP IPSTREAM 255) (APPENDINTEGER.IP IPSTREAM 1) (APPENDOP.IP IPSTREAM MAKEVEC) (* ;; "name of color model") (APPENDIDENTIFIER.IP IPSTREAM "Xerox") (APPENDIDENTIFIER.IP IPSTREAM "Research") (APPENDIDENTIFIER.IP IPSTREAM "RGBLinear") (APPENDINTEGER.IP IPSTREAM 3) (APPENDOP.IP IPSTREAM MAKEVEC) (* ;; "create the color model") (APPENDOP.IP IPSTREAM FINDCOLORMODELOPERATOR) (APPENDOP.IP IPSTREAM DO) (* ;; "store it in the preamble's frame") (FSET.IP IPSTREAM COLORMODELOP.FVAR) (* ;; "remember which fvar it is in") (replace (INTERPRESSDATA IPCOLORMODEL) of IPDATA with COLORMODELOP.FVAR]) (ISET.IP [LAMBDA (IPSTREAM IVAR) (* rmk%: "18-Oct-84 12:52") (* ;; "Sets the imager variable IVAR to the top of stack") (APPENDINTEGER.IP IPSTREAM IVAR) (APPENDOP.IP IPSTREAM ISET]) (GETCP.IP [LAMBDA (IPSTREAM) (* hdj "27-Nov-85 17:30") (* ;;; "Pushes current X & Y onto stack") (APPENDOP.IP IPSTREAM GETCP]) (LINETO.IP [LAMBDA (IPSTREAM X Y) (* rmk%: "19-Oct-84 08:50") (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP X) (FIXR X)) (T X))) (APPENDNUMBER.IP IPSTREAM (COND ((FLOATP Y) (FIXR Y)) (T Y))) (APPENDOP.IP IPSTREAM LINETO]) (MASKSTROKE.IP [LAMBDA (IPSTREAM) (* rmk%: "14-Jun-84 16:00") (APPENDOP.IP IPSTREAM MASKSTROKE]) (MOVETO.IP [LAMBDA (IPSTREAM X Y) (* hdj "18-Oct-85 15:58") (APPENDNUMBER.IP IPSTREAM X) (APPENDNUMBER.IP IPSTREAM Y) (APPENDOP.IP IPSTREAM MOVETO]) (ROTATE.IP [LAMBDA (IPSTREAM S) (* rmk%: " 6-JUN-83 18:02") (APPENDNUMBER.IP IPSTREAM S) (APPENDOP.IP IPSTREAM ROTATE]) (SCALE.IP [LAMBDA (IPSTREAM S) (* rmk%: "15-Jun-84 12:21") (APPENDNUMBER.IP IPSTREAM S) (APPENDOP.IP IPSTREAM SCALE.OP]) (SCALE2.IP [LAMBDA (IPSTREAM X Y) (* lmm "10-JUN-83 15:28") (APPENDNUMBER.IP IPSTREAM X) (APPENDNUMBER.IP IPSTREAM Y) (APPENDOP.IP IPSTREAM SCALE2]) (SETCOLOR.IP [LAMBDA (IPSTREAM SHADE OPERATION SCALE ANGLE) (* ; "Edited 21-Sep-88 14:41 by jds") (if (AND (STREAMPROP IPSTREAM 'COLOR) (LISTP SHADE) (RGBP (CADR SHADE))) then (* ; "the dosavesimplebody is in POLYSHADE.IP. For now, insist that the CDR be RGB if color is desired") (SETRGB.IP IPSTREAM (CAADR SHADE) (CADR (CADR SHADE)) (CADDR (CADR SHADE))) (SETQ SHADE (CAR SHADE))) (if (LITATOM SHADE) then (* ;; "Not sure what to do in LITATOM case") (SETQ SHADE BLACKSHADE)) [COND ((NOT OPERATION) (* ;  " OPERATION got defaulted to whatever the stream's op is, but we need to know here.") (SETQ OPERATION (DSPOPERATION NIL IPSTREAM] (* ;; "FS: Below this point, integers are considered TEXTURES, not COLORS.") (if [AND (OR (EQ SHADE BLACKSHADE) (EQ (NEGSHADE SHADE) BLACKSHADE)) (OR (EQ OPERATION 'REPLACE) (EQ OPERATION 'PAINT] then (* ;; "Most common case, optimized") (APPENDINTEGER.IP IPSTREAM 1) (APPENDOP.IP IPSTREAM SETGRAY) elseif [AND (OR (EQ SHADE WHITESHADE) (EQ (NEGSHADE SHADE) WHITESHADE)) (OR (EQ OPERATION 'REPLACE) (EQ OPERATION 'PAINT] then (* ;; "Probably rare, but optimize anyway") (APPENDINTEGER.IP IPSTREAM 0) (APPENDOP.IP IPSTREAM SETGRAY) else (* ;; "Patch around Print Service 8.0 bugs") (if (EQUAL PRINTSERVICE 8.0) then (SETCOLOR16.IP IPSTREAM SHADE OPERATION SCALE ANGLE) else (SETCOLORLV.IP IPSTREAM SHADE OPERATION SCALE ANGLE]) (SETRGB.IP [LAMBDA (IPSTREAM RED GREEN BLUE) (* hdj " 3-Feb-86 12:00") (LET [(COLORMODEL.FVAR (fetch IPCOLORMODEL of (fetch IMAGEDATA of IPSTREAM] (* hdj "23-Jan-86 19:21") (* ;; "force out any stored chars so they get colored") (SHOW.IP IPSTREAM) (* ;; "push RED GREEN BLUE vector") (APPENDINTEGER.IP IPSTREAM RED) (APPENDINTEGER.IP IPSTREAM GREEN) (APPENDINTEGER.IP IPSTREAM BLUE) (APPENDINTEGER.IP IPSTREAM 3) (APPENDOP.IP IPSTREAM MAKEVEC) (* ;; "apply the color operator") (FGET.IP IPSTREAM COLORMODEL.FVAR) (APPENDOP.IP IPSTREAM DO) (* ;; "set current color to result") (ISET.IP IPSTREAM COLOR.IMVAR)) NIL]) (SETCOLORLV.IP [LAMBDA (IPSTREAM SHADE OPERATION SCALE ANGLE) (* ; "Edited 23-Feb-87 14:20 by FS") (* ;; "OSD's Print Service 9.0 supports large vector arrays for MAKESAMPLEDBLACK, with power-of-2 scale factors up to eight, Also note that bitmap gets rotated -90 degrees, Non-power-of-two values are rounded.") (* ;; "Note that OSD's Print Service 9.0 has an INCOMPATIBLE change to MAKESAMPLEDBLACK.") (* ;; "I changed this to set SCALE and ANGLE from texture if they are not given. The 8044 only allows 4x4 textures at the same scale at the screen. A 4x4 will get a scale of 4 so that it looks like it does on the screen. A 16x16 will get a scale of 1 so that all of it appears albeit at 1/4 the size. rrb 7-mar-86") (* ;; "FS- Note this is a general method; Common optimizations probably should be performed outside of here (e.g. SETCOLOR.IP)") (PROG (SCRATCHBM (DIM 16)) (COND ((EQ OPERATION 'ERASE) (* ;  "for now, simulate ERASE by painting white") (SETQ SCRATCHBM (BITMAPCREATE DIM DIM)) (SETQ OPERATION 'REPLACE)) ((AND (BITMAPP SHADE) (EQ (BITMAPWIDTH SHADE) 16) (EQ (BITMAPHEIGHT SHADE) 16)) (* ; "16x16 texture case.") (SETQ SCRATCHBM SHADE)) (T (* ; "all other textures") [COND ((NOT (NUMBERP SCALE)) (COND ((NUMBERP SHADE) (* ;; "make numbered textures be at screen scale and bitmap textures be at closer to printer scale. This at least allows ways of users getting different effects.") (SETQ SCALE 4] (* ;  "Move the shade into the scratch bitmap, that's dim wide, so we can tell Interpress about it") (SETQ SCRATCHBM (BITMAPCREATE DIM DIM)) (BITBLT NIL 0 0 SCRATCHBM 0 0 DIM DIM 'TEXTURE 'REPLACE SHADE))) (APPENDNUMBER.IP IPSTREAM DIM) (* ; "X Pixels") (APPENDNUMBER.IP IPSTREAM DIM) (* ; "Y Pixels") (APPENDINTEGER.IP IPSTREAM 1) (* ; "Samples per pixel") (APPENDINTEGER.IP IPSTREAM 1) (* ; "Max Sample Value") (APPENDINTEGER.IP IPSTREAM 1) (* ; "'Interleaved' samples") (SCALE.IP IPSTREAM 1) (* ; "Transform datum to pixel array") (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQLARGEVECTOR (IPLUS 1 (ITIMES DIM DIM))) (* ; "Header for Vector type") (APPENDBYTE.IP IPSTREAM 1) (* ; "bytes / sample") (* ; "samples / scanline") (* ;; "Now put put the bitmap -- each line must be a 32-bit multiple long") [for Y from (SUB1 DIM) to 0 by -1 do (for X from 0 to (SUB1 DIM) do (\BOUT IPSTREAM (BITMAPBIT SCRATCHBM X Y] (* ; "put out the bits") (APPENDOP.IP IPSTREAM MAKEPIXELARRAY) (* ; "make the pixel array") (SCALE.IP IPSTREAM (OR (NUMBERP SCALE) 1)) (* ;  "the 8044 scans bitmaps from top to bottom rather than left to right so rotate it.") (ROTATE.IP IPSTREAM (OR (NUMBERP ANGLE) -90)) (CONCAT.IP IPSTREAM) (APPENDINTEGER.IP IPSTREAM (SELECTQ OPERATION (REPLACE 0) (PAINT 1) 1)) (* ;  "0 is white bits opaque, 1 is white bits clear") (APPENDOP.IP IPSTREAM MAKESAMPLEDBLACK) (ISET.IP IPSTREAM COLOR.IMVAR) (RETURN NIL]) (SETCOLOR16.IP [LAMBDA (IPSTREAM SHADE OPERATION SCALE ANGLE) (* FS " 2-Aug-85 00:54") (* ;;; "OSD's Print Service 8.0 only supports 16x16 pixel arrays for MAKESAMPLEDBLACK, with power-of-2 scale factors up to eight, Also note that bitmap gets rotated -90 degrees, Non-power-of-two values are rounded, PSD's interpress is allegedly more restrictive") (* ;;; "Note this version is correct for PS 8.0, by implementing the incorrect PS 8.0 method. Won't work for later versions") (PROG (SCRATCHBM BMBASE NBYTES (DIM 16)) (COND ((NOT (NUMBERP SCALE)) (SETQ SCALE 1))) (COND ((NOT (NUMBERP ANGLE)) (SETQ ANGLE 0))) (SETQ NBYTES (IQUOTIENT (ITIMES DIM DIM) 8)) (SETQ SCRATCHBM (BITMAPCREATE DIM DIM)) (SETQ BMBASE (fetch (BITMAP BITMAPBASE) of SCRATCHBM)) (BITBLT NIL 0 0 SCRATCHBM 0 0 DIM DIM 'TEXTURE 'REPLACE SHADE) (* ;  "Move the shade into the scratch bitmap, that's dim wide, so we can tell Interpress about it") (APPENDNUMBER.IP IPSTREAM DIM) (* ; "X Pixels") (APPENDNUMBER.IP IPSTREAM DIM) (* ; "Y Pixels") (APPENDINTEGER.IP IPSTREAM 1) (* ; "Samples per pixel") (APPENDINTEGER.IP IPSTREAM 1) (* ; "Max Sample Value") (APPENDINTEGER.IP IPSTREAM 1) (* ; "'Interleaved' samples") (SCALE.IP IPSTREAM 1) (* ; "Transform datum to pixel array") (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQPACKEDPIXELVECTOR (IPLUS 4 NBYTES)) (* ; "Header for Vector type") (APPENDINT.IP IPSTREAM 1 2) (* ; "bits / sample") (APPENDINT.IP IPSTREAM DIM 2) (* ; "samples / scanline") (* ;; "Now put put the bitmap -- each line must be a 32-bit multiple long") (\BOUTS IPSTREAM BMBASE 0 NBYTES) (* ; "put out the bits") (APPENDOP.IP IPSTREAM MAKEPIXELARRAY) (* ; "make the pixel array") (SCALE.IP IPSTREAM SCALE) (ROTATE.IP IPSTREAM ANGLE) (CONCAT.IP IPSTREAM) (APPENDINTEGER.IP IPSTREAM (SELECTQ OPERATION (REPLACE 0) (PAINT 1) 1)) (* ;  "0 is white bits opaque, 1 is white bits clear") (APPENDOP.IP IPSTREAM MAKESAMPLEDBLACK) (ISET.IP IPSTREAM COLOR.IMVAR) (RETURN NIL]) (SETFONT.IP [LAMBDA (IPSTREAM FONTNUM) (* rmk%: "20-AUG-83 14:03") (APPENDNUMBER.IP IPSTREAM FONTNUM) (APPENDOP.IP IPSTREAM SETFONT) (PROG ((IPDATA (fetch IPDATA of IPSTREAM))) (replace IPFONT of IPDATA with (for X in (fetch IPPAGEFONTS of IPDATA) when (EQ FONTNUM (CDR X)) do (RETURN (CAR X)) finally (ERROR "Undefined font number"]) (SETSPACE.IP [LAMBDA (IPSTREAM SPACEWIDTH) (* rmk%: "11-Dec-83 21:12") (APPENDNUMBER.IP IPSTREAM SPACEWIDTH) (APPENDOP.IP IPSTREAM SPACE]) (SETXREL.IP [LAMBDA (IPSTREAM DX) (* ; "Edited 11-Aug-88 15:24 by rmk:") (* ; "Move by DX in the X direction") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (APPENDNUMBER.IP IPSTREAM DX) (APPENDOP.IP IPSTREAM SETXREL) (SETQ DX (change (fetch IPXPOS of IPDATA) (+ DX DATUM))) [replace IPCHARVISIBLEP of IPDATA with (AND (>= DX (fetch IPVISLEFT of IPDATA)) (>= (fetch IPYPOS of IPDATA) (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= (fetch IPYPOS of IPDATA) (fetch IPMAXVISIBLEBASELINE of IPDATA] (replace IPCORRECTSTARTX of IPDATA with (fetch IPXPOS of IPDATA]) (SETX.IP [LAMBDA (IPSTREAM X) (* ; "Edited 11-Aug-88 14:23 by rmk:") (* ; "Move to X, without changing Y.") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (COND ((NUMBERP X) (APPENDINTEGER.IP IPSTREAM (DIFFERENCE X (fetch IPXPOS of IPDATA))) (APPENDOP.IP IPSTREAM SETXREL)) (T (APPENDNUMBER.IP IPSTREAM X) (* ;  "If not a fixp, let the rational/floating substraction be done by the printer") (APPENDNUMBER.IP IPSTREAM (fetch IPYPOS of IPDATA)) (APPENDOP.IP IPSTREAM SETXY))) [replace IPCHARVISIBLEP of IPDATA with (AND (>= X (fetch IPVISLEFT of IPDATA)) (>= (fetch IPYPOS of IPDATA) (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= (fetch IPYPOS of IPDATA) (fetch IPMAXVISIBLEBASELINE of IPDATA] (replace IPXPOS of IPDATA with X) (replace IPCORRECTSTARTX of IPDATA with X]) (SETXY.IP [LAMBDA (IPSTREAM X Y) (* ; "Edited 11-Aug-88 14:04 by rmk:") (* ; "Move to (X,Y) on the page.") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (APPENDNUMBER.IP IPSTREAM X) (APPENDNUMBER.IP IPSTREAM Y) (APPENDOP.IP IPSTREAM SETXY) [replace IPCHARVISIBLEP of IPDATA with (AND (>= X (fetch IPVISLEFT of IPDATA)) (>= Y (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= Y (fetch IPMAXVISIBLEBASELINE of IPDATA] (replace IPXPOS of (fetch IPDATA of IPSTREAM) with X) (replace IPCORRECTSTARTX of IPDATA with X) (* ;  "Remember our last location, so we can CORRECT character widths.") (replace IPYPOS of IPDATA with Y]) (SETXYREL.IP [LAMBDA (IPSTREAM DX DY) (* ; "Edited 11-Aug-88 15:24 by rmk:") (* ; "Move by (DX,DY) on the page.") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (APPENDNUMBER.IP IPSTREAM DX) (APPENDNUMBER.IP IPSTREAM DY) (APPENDOP.IP IPSTREAM SETXYREL) (SETQ DX (change (fetch IPXPOS of IPDATA) (+ DATUM DX))) (SETQ DY (change (fetch IPYPOS of IPDATA) (+ DATUM DY))) [replace IPCHARVISIBLEP of IPDATA with (AND (>= DX (fetch IPVISLEFT of IPDATA)) (>= DY (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= DY (fetch IPMAXVISIBLEBASELINE of IPDATA] (* ;  "Remember the new X location so we can CORRECT character widths") (replace IPCORRECTSTARTX of IPDATA with DX]) (SETY.IP [LAMBDA (IPSTREAM Y) (* ; "Edited 11-Aug-88 14:05 by rmk:") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (COND ((NUMBERP Y) [APPENDINTEGER.IP IPSTREAM (FIXR (DIFFERENCE Y (fetch IPYPOS of IPDATA] (APPENDOP.IP IPSTREAM SETYREL)) (T (APPENDNUMBER.IP IPSTREAM (fetch IPXPOS of IPDATA)) (* ;  "If not a fixp, let the rational/floating substraction be done by the printer") (APPENDNUMBER.IP IPSTREAM Y) (APPENDOP.IP IPSTREAM SETXY))) [replace IPCHARVISIBLEP of IPDATA with (AND (>= (fetch IPXPOS of IPDATA) (fetch IPVISLEFT of IPDATA)) (>= Y (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= Y (fetch IPMAXVISIBLEBASELINE of IPDATA] (replace IPYPOS of IPDATA with Y]) (SETYREL.IP [LAMBDA (IPSTREAM DY) (* ; "Edited 11-Aug-88 15:26 by rmk:") (LET ((IPDATA (fetch IPDATA of IPSTREAM))) (APPENDNUMBER.IP IPSTREAM DY) (APPENDOP.IP IPSTREAM SETYREL) (SETQ DY (change (fetch IPYPOS of IPDATA) (+ DY DATUM))) (replace IPCHARVISIBLEP of IPDATA with (AND (>= (fetch IPXPOS of IPDATA) (fetch IPVISLEFT of IPDATA)) (>= DY (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= DY (fetch IPMAXVISIBLEBASELINE of IPDATA]) (SHOW.IP [LAMBDA (IPSTREAM MOVING?) (* ; "Edited 9-Dec-87 19:02 by jds") (* ;; "Shows a string buffered away in SHOWSTREAM") (* ;; "If MOVING? is true, we're going to be doing a positioning operation, so there's no point to correcting single characters.") (PROG ((IPDATA (ffetch IPDATA of IPSTREAM)) LEN SHOWSTREAM) (SETQ SHOWSTREAM (ffetch IPSHOWSTREAM of IPDATA)) (SETQ LEN (\GETFILEPTR SHOWSTREAM)) (COND ((IGREATERP LEN 0) (* ;  "Only bother if there ARE characters to put out.") (COND ((OR (IGREATERP LEN 1) (NOT MOVING?)) (* ;  "Let's assume that a single character won't get too far off.") (APPENDNUMBER.IP IPSTREAM (- (ffetch IPXPOS of IPDATA) (ffetch IPCORRECTSTARTX of IPDATA))) (* ;  "Set up the measures for the CORRECT op, so the characters come out the right width") (APPENDINTEGER.IP IPSTREAM 0) (APPENDOP.IP IPSTREAM SETCORRECTMEASURE) (APPENDOP.IP IPSTREAM CORRECT) (APPENDOP.IP IPSTREAM {) (* ;  "Put the SHOW inside a block, so the CORRECT will affect it.") )) (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQSTRING LEN) (COPYBYTES SHOWSTREAM IPSTREAM 0 LEN) (APPENDOP.IP IPSTREAM SHOW) (COND ((OR (IGREATERP LEN 1) (NOT MOVING?)) (* ;  "Let's assume that a single character won't get too far off.") (APPENDOP.IP IPSTREAM }) (* ;  "End of the block affected by the CORRECT") )) (\SETFILEPTR SHOWSTREAM 0) (* ;  "Clear out the holding stream for characters") (COND ((NOT (IEQP (fetch NSCHARSET of IPDATA) 0)) (* ;  "If we're not in charset zero, change back to it.") (\CHANGECHARSET.IP IPDATA 0))) (freplace IPCORRECTSTARTX of IPDATA with (ffetch IPXPOS of IPDATA)) (* ;  "And notice our new real location for future CORRECTs.") ]) (TRAJECTORY.IP [LAMBDA (IPSTREAM POINTS) (* FS "19-Jul-85 11:53") (MOVETO.IP IPSTREAM (fetch XCOORD of (CAR POINTS)) (fetch YCOORD of (CAR POINTS))) (for P in (CDR POINTS) do (LINETO.IP IPSTREAM (fetch XCOORD of P) (fetch YCOORD of P]) (TRANS.IP [LAMBDA (IPSTREAM) (* rmk%: "27-Mar-85 14:24") (* ;; "This translates the origin to the current position.") (APPENDOP.IP IPSTREAM TRANS.IPOP]) (TRANSLATE.IP [LAMBDA (IPSTREAM X Y) (* rmk%: "21-JUL-82 13:23") (APPENDNUMBER.IP IPSTREAM X) (APPENDNUMBER.IP IPSTREAM Y) (APPENDOP.IP IPSTREAM TRANSLATE]) ) (* ; "DIG interface") (DEFINEQ (\CHANGE-VISIBLE-REGION.IP [LAMBDA (IPDATA VISIBLE-REGION) (* ; "Edited 18-Aug-88 16:17 by hdj") (* ;; "Unpacks parameters of the visible region") (LET ((FONT (ffetch IPFONT of IPDATA))) (freplace (INTERPRESSDATA IPVISLEFT) of IPDATA with (ffetch (REGION LEFT) of VISIBLE-REGION)) (freplace (INTERPRESSDATA IPVISRIGHT) of IPDATA with (ffetch (REGION RIGHT) of VISIBLE-REGION)) (freplace (INTERPRESSDATA IPVISTOP) of IPDATA with (ffetch (REGION TOP) of VISIBLE-REGION)) (freplace (INTERPRESSDATA IPVISBOTTOM) of IPDATA with (ffetch (REGION BOTTOM ) of VISIBLE-REGION)) (freplace (INTERPRESSDATA IPVISIBLEREGION) of IPDATA with VISIBLE-REGION) (freplace IPMAXVISIBLEBASELINE of IPDATA with (- (ffetch IPVISTOP of IPDATA) (ffetch (FONTDESCRIPTOR \SFAscent) of FONT))) [if (ffetch IPCLIPINCLUSIVE of IPDATA) then (* ;; "include characters that cross the bottom of the clipping region") [freplace IPMINVISIBLEBASELINE of IPDATA with (ADD1 (- (ffetch IPVISBOTTOM of IPDATA) (ffetch (FONTDESCRIPTOR \SFAscent) of FONT] else (freplace IPMINVISIBLEBASELINE of IPDATA with (+ (ffetch IPVISBOTTOM of IPDATA) (ffetch (FONTDESCRIPTOR \SFDescent) of FONT] [replace IPCHARVISIBLEP of IPDATA with (AND (>= (fetch IPXPOS of IPDATA) (fetch IPVISLEFT of IPDATA)) (>= (ffetch IPYPOS of IPDATA ) (ffetch IPMINVISIBLEBASELINE of IPDATA)) (<= (ffetch IPYPOS of IPDATA ) (ffetch IPMAXVISIBLEBASELINE of IPDATA] (freplace IPMINCHARRIGHT of IPDATA with (MIN (ffetch IPVISRIGHT of IPDATA) (ffetch IPRIGHT of IPDATA]) (\PAPERSIZE.IP [LAMBDA (IPSTREAM MEDIUM) (* ; "Edited 15-Aug-88 09:28 by rmk:") (OR MEDIUM (SETQ MEDIUM DEFAULTINTERPRESSMEDIUM)) (LET [(PSIZE (COND ((AND (EQ (CAR MEDIUM) 'PAPER) (SELECTQ (CAR (SETQ MEDIUM (CADR MEDIUM))) (KNOWN.SIZE (CADR (CL:ASSOC (CADR MEDIUM) KNOWN.MEDIA.SIZES :TEST 'STRING-EQUAL))) (OTHER.SIZE (CADR MEDIUM)) NIL))) (T (ERROR "UNRECOGNIZED PRINTING MEDIUM"](* ; " Scale millimeters to micas") (LIST (TIMES MICASPERMILLIMETER (CAR PSIZE)) (TIMES MICASPERMILLIMETER (CADR PSIZE]) (HEADINGOP.IP [LAMBDA (IPSTREAM HEADING) (* hdj "18-Oct-85 15:46") (* ;; "Stores the HEADINGOP operator as frame-variable 0 in the preamble.") (PROG ((IPDATA (fetch IPDATA of IPSTREAM))) (APPENDOP.IP IPSTREAM MAKESIMPLECO) (APPENDOP.IP IPSTREAM {) (COND (HEADING [SETXY.IP IPSTREAM (fetch IPLEFT of IPDATA) (DIFFERENCE (fetch IPTOP of IPDATA) (FONTPROP (fetch IPHEADINGFONT of IPDATA) 'ASCENT] (SETFONT.IP IPSTREAM HEADINGFONTNUMBER) (PRIN3 HEADING IPSTREAM) (SHOW.IP IPSTREAM) (RELMOVETO MICASPERINCH 0 IPSTREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " IPSTREAM) (* ;  "Show the page number argument (from stack)") (TERPRI IPSTREAM) (* ;  "Skip 2 lines--have to pick up the linefeed from the heading font") (TERPRI IPSTREAM))) (APPENDOP.IP IPSTREAM }) (FSET.IP IPSTREAM (replace IPHEADINGOPVAR of IPDATA with (GETFRAMEVAR.IP IPSTREAM]) ) (DEFINEQ (DEFINEFONT.IP [LAMBDA (IPSTREAM FONT) (* bvm%: "22-Oct-86 13:20") (LET ((IPDATA (fetch IPDATA of IPSTREAM)) FRAMEVAR) (for N from 0 as ID in (FONTNAME.IP FONT) do (APPENDIDENTIFIER.IP IPSTREAM ID) finally (APPENDINTEGER.IP IPSTREAM N) (APPENDOP.IP IPSTREAM MAKEVEC)) (APPENDOP.IP IPSTREAM FINDFONT) [SCALE.IP IPSTREAM (TIMES MICASPERPOINT (FONTPROP FONT 'DEVICESIZE] (APPENDOP.IP IPSTREAM MODIFYFONT) (SETQ FRAMEVAR (GETFRAMEVAR.IP IPSTREAM)) (FSET.IP IPSTREAM FRAMEVAR) (CAR (push (fetch IPPAGEFONTS of IPDATA) (CONS FONT FRAMEVAR]) (FONTNAME.IP [LAMBDA (FONTDESC) (* jds "17-Jul-85 11:00") (* ;; "Convert a Lisp font name to the proper NS font name") (DECLARE (GLOBALVARS INTERPRESSPRINTWHEELFAMILIES INTERPRESSFAMILYALIASES)) (PROG (FACE NAME) [COND ((EQ 'ITALIC (FONTPROP FONTDESC 'DEVICESLOPE)) (SETQ FACE '(-Italic] [COND ((EQ 'BOLD (FONTPROP FONTDESC 'DEVICEWEIGHT)) (push FACE '-Bold] (SETQ NAME (FONTPROP FONTDESC 'DEVICEFAMILY)) [AND (MEMB NAME INTERPRESSPRINTWHEELFAMILIES) (SETQ NAME (PACK* NAME '-PRINTWHEEL] [COND ((MEMB NAME INTERPRESSFAMILYALIASES) (SETQ NAME (LISTGET INTERPRESSFAMILYALIASES NAME] [COND (FACE (SETQ NAME (PACK (CONS NAME FACE] (RETURN (LIST 'XEROX CHARACTERCODEVERSION NAME]) (INTERPRESS.BITMAPSCALE [LAMBDA (WIDTH HEIGHT) (* lmm " 3-OCT-83 21:31") (PROG [(RATIO (MIN (FQUOTIENT (TIMES POINTSPERINCH 9.5) WIDTH) (FQUOTIENT (TIMES POINTSPERINCH 7.5) HEIGHT] (RETURN (COND ((GEQ RATIO 1) 1) ((GEQ RATIO 0.5) 0.5) ((GEQ RATIO 0.25) 0.25) (T RATIO]) (INTERPRESS.OUTCHARFN [LAMBDA (IPSTREAM CHARCODE) (* ; "Edited 6-Jan-89 23:03 by jds") (* ;; "The \OUTCHAR method for interpress streams. Print a character, taking account of margins and visible region, and things like ^L.") (LET* ((IPDATA (ffetch IPDATA of IPSTREAM)) [NSCODE (COND ((\FATCHARCODEP CHARCODE) CHARCODE) (T (\GETBASE (ffetch NSTRANSTABLE of IPDATA) CHARCODE] (OLD-CSET (ffetch NSCHARSET of IPDATA))) [COND ((NEQ (\CHARSET NSCODE) OLD-CSET) (* ;; "Switch character set so that we get the right char width, but DON'T write out the charset-shift sequence, in case the character gets clipped.") (\CHANGECHARSET.IP IPDATA (\CHARSET NSCODE] (* ;; "Select on NSCODE, since ^L etc might be graphic in some ascii fonts:") (SELCHARQ NSCODE (EOL (NEWLINE.IP IPSTREAM)) (LF (\DSPXPOSITION.IP IPSTREAM (PROG1 (\DSPXPOSITION.IP IPSTREAM) (NEWLINE.IP IPSTREAM)))) (^L (DSPNEWPAGE IPSTREAM)) (PROG (CHAR-WIDTH NEWXPOS) (* ;  "Have to switch charset before fetching width from cache, even though we might later clip") [SETQ CHAR-WIDTH (COND ((EQ NSCODE (CHARCODE SPACE)) (ffetch IPSPACEWIDTH of IPDATA)) (T (\FGETWIDTH (ffetch IPWIDTHSCACHE of IPDATA) (\CHAR8CODE NSCODE] (SETQ NEWXPOS (+ (ffetch IPXPOS of IPDATA) CHAR-WIDTH)) RETRY (* ;  "Return to here if we have to emit a newline before printing") (COND ((AND (fetch IPCHARVISIBLEP of IPDATA) (<= NEWXPOS (fetch IPMINCHARRIGHT of IPDATA))) (* ;; "Char vis means starting pos is inside the character clipping region. Minright is the min of the right margin and clipping right, so we're OK if we end up left of that") (* ; "This is the common case we've optimized for: char starts and ends visible and before right margin") (freplace IPXPOS of IPDATA with NEWXPOS) [COND ((NEQ (\CHARSET NSCODE) OLD-CSET) (\BOUT (ffetch IPSHOWSTREAM of IPDATA) NSCHARSETSHIFT) (* ; "Switch character set") (\BOUT (ffetch IPSHOWSTREAM of IPDATA) (\CHARSET NSCODE)) (* ;;  "have to repeat this, since we may have done a CR before printing it.") (\CHANGECHARSET.IP IPDATA (\CHARSET NSCODE] (\BOUT (ffetch IPSHOWSTREAM of IPDATA) (\CHAR8CODE NSCODE)) (RETURN)) ((> NEWXPOS (ffetch IPRIGHT of IPDATA)) (* ;;  "Failed visible or micharright, if over right margin, do newline and try again, otherwise clip ") (NEWLINE.IP IPSTREAM) (* ;  "This will reset the IPCHARVISIBLEP") (SETQ NEWXPOS (+ (ffetch IPXPOS of IPDATA) CHAR-WIDTH)) (* ;  "Retry to print if we ended up unclipped and within the margin, otherwise fall thru to clip") (AND (<= NEWXPOS (ffetch IPMINCHARRIGHT of IPDATA)) (GO RETRY))) ((AND (ffetch IPCLIPINCLUSIVE of IPDATA) (< (ffetch IPXPOS of IPDATA) (ffetch IPVISRIGHT of IPDATA)) (>= NEWXPOS (ffetch IPVISRIGHT of IPDATA))) (* ;;  "We're clipping him, but he wants the straddling character left visible. Print it.") (freplace IPXPOS of IPDATA with NEWXPOS) [COND ((NEQ (\CHARSET NSCODE) (ffetch NSCHARSET of IPDATA)) (\BOUT (ffetch IPSHOWSTREAM of IPDATA) NSCHARSETSHIFT) (* ; "Switch character set") (\BOUT (ffetch IPSHOWSTREAM of IPDATA) (\CHARSET NSCODE)) (* ;;  "have to repeat this, since we may have done a CR before printing it.") (\CHANGECHARSET.IP IPDATA (\CHARSET NSCODE] (\BOUT (ffetch IPSHOWSTREAM of IPDATA) (\CHAR8CODE NSCODE)) (RETURN)) (T (* ;; "Nothing printed; have to reset the charset.") (\CHANGECHARSET.IP IPDATA OLD-CSET))) (SHOW.IP IPSTREAM T) (* ; "Either failed CHARVIS, or failed both VISRIGHT and IPRIGHT, so not in clipping region. Just move X position") (SETX.IP IPSTREAM NEWXPOS]) (INTERPRESSFILEP [LAMBDA (FILE NOOPEN) (* jds "18-Feb-85 09:41") (* ;; "Returns fullname of FILE if it looks like an Interpress file") (OR (EQ (GETFILEINFO FILE 'FILETYPE) FILETYPE.INTERPRESS) (RESETLST [PROG (STRM) [COND ((SETQ STRM (\GETSTREAM FILE 'INPUT T)) (OR (RANDACCESSP STRM) (RETURN)) (RESETSAVE NIL (LIST 'SETFILEPTR STRM (GETFILEPTR STRM))) (SETFILEPTR STRM 0)) (NOOPEN (RETURN)) (T (RESETSAVE (SETQ STRM (OPENSTREAM FILE 'INPUT 'OLD 8)) '(PROGN (CLOSEF? OLDVALUE] (RETURN (for I from 1 to (CONSTANT (NCHARS NOVERSIONENCODINGSTRING)) when (OR (EOFP STRM) (NEQ (NTHCHARCODE NOVERSIONENCODINGSTRING I) (BIN STRM))) do (RETURN NIL) finally (RETURN (FULLNAME STRM])]) (MAKEINTERPRESS [LAMBDA (FILE IPFILE FONTS HEADING TABS OPTIONS) (* jds " 9-May-85 16:28") (TEXTTOIMAGEFILE FILE IPFILE 'INTERPRESS FONTS HEADING TABS OPTIONS]) (NEWLINE.IP [LAMBDA (IPSTREAM) (* jds " 9-Feb-86 17:37") (* ;  "Doesn't check for page overflow--wait until something is actually shown.") (SHOW.IP IPSTREAM) (PROG (NEWYPOS (IPDATA (ffetch IPDATA of IPSTREAM))) (SETQ NEWYPOS (PLUS (ffetch IPYPOS of IPDATA) (ffetch IPLINEFEED of IPDATA))) (COND ((LESSP NEWYPOS (fetch IPBOTTOM of IPDATA)) (DSPNEWPAGE IPSTREAM)) (T (SETXY.IP IPSTREAM (ffetch IPLEFT of IPDATA) NEWYPOS]) (NEWPAGE.IP [LAMBDA (IPSTREAM) (* ; "Edited 25-Nov-87 18:20 by jds") (* ;;; "Start a new page in an interpress stream") (PROG (CFONT HFONT ROTATION XOFFSET YOFFSET (IPDATA (fetch IPDATA of IPSTREAM))) (SETQ CFONT (fetch IPFONT of IPDATA)) (* ;; "Save current font and make IPFONT be NIL, indicating that there is no actual font at the beginning of a page") (replace IPFONT of IPDATA with NIL) (SELECTQ (fetch IPPAGESTATE of IPDATA) (PAGE (ENDPAGE.IP IPSTREAM)) (PREAMBLE (ENDPREAMBLE.IP IPSTREAM)) NIL) (BEGINPAGE.IP IPSTREAM) (replace IPPAGEFONTS of IPDATA with (fetch IPPREAMBLEFONTS of IPDATA)) (replace IPNEXTFRAMEVAR of IPDATA with (fetch IPPREAMBLENEXTFRAMEVAR of IPDATA)) (SCALE.IP IPSTREAM METERSPERMICA) (* ;  "Establish mica page coordinate system") (CONCATT.IP IPSTREAM) (COND ([NOT (ZEROP (SETQ ROTATION (fetch IPROTATION of IPDATA] (* ; "Take care of any rotation") (ROTATE.IP IPSTREAM ROTATION) (CONCATT.IP IPSTREAM))) (COND ([OR [NOT (ZEROP (SETQ XOFFSET (fetch IPXOFFSET of IPDATA] (NOT (ZEROP (SETQ YOFFSET (fetch IPYOFFSET of IPDATA] (* ; "Take care of any translations") (TRANSLATE.IP IPSTREAM XOFFSET YOFFSET) (CONCATT.IP IPSTREAM))) [COND [(fetch IPHEADING of IPDATA) (* ;  "If there's a page heading, do something about it.") (SETQ HFONT (fetch IPHEADINGFONT of IPDATA)) (\DSPFONT.IP IPSTREAM HFONT) (* ; "Set up heading font") (SELECTQ ENCODING (FULLIP-82 (PRIN3 (add (fetch IPPAGENUM of IPDATA) 1) IPSTREAM) (FGET.IP IPSTREAM (fetch IPHEADINGOPVAR of (fetch IPDATA of IPSTREAM))) (* ; "Get the heading operator") (APPENDOP.IP IPSTREAM DOSAVE)) (IP-82 [SETXY.IP IPSTREAM (fetch IPLEFT of IPDATA) (DIFFERENCE (fetch IPTOP of IPDATA) (FONTPROP HFONT 'ASCENT] (DSPFONT HFONT IPSTREAM) (PRIN3 (fetch IPHEADING of IPDATA) IPSTREAM) (RELMOVETO MICASPERINCH 0 IPSTREAM) (* ; "Skip an inch before page number") (PRIN3 "Page " IPSTREAM) (PRIN3 (add (fetch IPPAGENUM of IPDATA) 1) IPSTREAM) (NEWLINE.IP IPSTREAM) (* ; "Skip 2 lines") (NEWLINE.IP IPSTREAM)) (SHOULDNT)) (* ;; "SETXY can't be done in HEADINGOP, cause the ascent of the current font is not known at image-time. We set it in terms of our current font, even though that hasn't yet be re-setup in the imager.") (SETYREL.IP IPSTREAM (IMINUS (FONTPROP CFONT 'ASCENT] (T (SETXY.IP IPSTREAM (fetch IPLEFT of IPDATA) (DIFFERENCE (fetch IPTOP of IPDATA) (FONTPROP CFONT 'ASCENT] (* ;  "Now we set the imagers font to our (previous) current font, to override heading") (APPENDINTEGER.IP IPSTREAM 25) (* ;  "Set up so that CORRECTs don't have to be exact.") (APPENDINTEGER.IP IPSTREAM 0) (APPENDOP.IP IPSTREAM SETCORRECTTOLERANCE) (COND ((NOT (EQP 1 (ffetch IPSPACEFACTOR of IPDATA))) (* ;  "Imager variables revert to initial values") (APPENDNUMBER.IP IPSTREAM (ffetch IPSPACEFACTOR of IPDATA)) (ISET.IP IPSTREAM AMPLIFYSPACE))) (\DSPFONT.IP IPSTREAM CFONT]) (NEWPAGE?.IP [LAMBDA (IPSTREAM) (* hdj "18-Oct-85 15:38") (* ;  "Are we about to overflow the page?") (COND ((LESSP (fetch IPYPOS of (fetch IPDATA of IPSTREAM)) (fetch IPBOTTOM of (fetch IPDATA of IPSTREAM))) (NEWPAGE.IP IPSTREAM]) (OPENIPSTREAM [LAMBDA (IPFILE OPTIONS) (* ; "Edited 29-May-93 13:19 by rmk:") (* ; "Edited 18-Aug-88 16:13 by hdj") (* ;; "Opens an interpress stream, which user can OUTCHAR to. The FONTS option can be a list of fonts to be set up in the preamble. Headings will be printed in the first font in that list. If that list is NIL, then the stream is initialized with the INTERPRESS DEFAULTFONT") (DECLARE (GLOBALVARS DEFAULTPAGEREGION \IPIMAGEOPS \NOIMAGEOPS PRINTER.DEFAULT.SCAN.DIRECTION PRINTER.SCAN.DIRECTIONS.LIST) (USEDFREE SERVER)) (* ;  "FVAR SERVER may be appeared in TEDIT.HARDCOPY") (LET* [(OPTION NIL) [IPSTREAM (OPENSTREAM IPFILE 'OUTPUT 'NEW NIL '((TYPE INTERPRESS] (MARGINREGION (COND ([type? REGION (SETQ OPTION (LISTGET OPTIONS 'REGION] OPTION) ((LISTGET OPTIONS 'LANDSCAPE) (* ;  "Landscape printing: Set up things sideways.") DEFAULTLANDPAGEREGION) (T DEFAULTPAGEREGION))) [IPDATA (create INTERPRESSDATA IPPAGEREGION _ MARGINREGION IPLEFT _ (fetch (REGION LEFT) of MARGINREGION) IPRIGHT _ (fetch (REGION RIGHT) of MARGINREGION) IPTOP _ (fetch (REGION TOP) of MARGINREGION) IPBOTTOM _ (fetch (REGION BOTTOM) of MARGINREGION) IPSHOWSTREAM _ (PROG1 (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW) (* ;; "Make sure the fileptr of the following is zero (GETRESOURCE \IPSHOWSTREAM) (and free this in CLOSEIPSTREAM)") ) IPDOCNAME _ (LISTGET OPTIONS 'DOCUMENT.NAME) IPCLIPINCLUSIVE _ (LISTGET OPTIONS 'CLIP.INCLUSIVE] (PAPERSIZE (\PAPERSIZE.IP IPSTREAM (LISTGET OPTIONS 'MEDIUM] (* ; "Set up initial margins without calling functions to insure coercions and side-effects until everything is initialized. Note that linelength is initialized when font is set") (COND ((OR (NEQ \NOIMAGEOPS (fetch (IPSTREAM IMAGEOPS) of IPSTREAM)) (NEQ 0 (GETEOFPTR IPSTREAM))) (ERROR "can't convert existing file to Interpress" (FULLNAME IPSTREAM)) (* ;  "GETEOFPTR might bomb on some streams") )) (replace (STREAM OUTCHARFN) of IPSTREAM with (FUNCTION INTERPRESS.OUTCHARFN)) (freplace (IPSTREAM IMAGEOPS) of IPSTREAM with \IPIMAGEOPS) (freplace (IPSTREAM IPDATA) of IPSTREAM with IPDATA) [COND ((LISTGET OPTIONS 'LANDSCAPE) (* ; "For landscape printing, set up the default rotation and Y translate, and swap the papersize width and height") (replace (INTERPRESSDATA IPROTATION) of IPDATA with 90) (freplace (INTERPRESSDATA IPYOFFSET) of IPDATA with -21590) (swap (CAR PAPERSIZE) (CADR PAPERSIZE] (STREAMPROP IPSTREAM 'PAPERSIZE (COPY PAPERSIZE)) (STREAMPROP IPSTREAM 'CLIP.INCLUSIVE (LISTGET OPTIONS 'CLIP.INCLUSIVE)) (replace IPPAGEFRAME of IPDATA with (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (CAR PAPERSIZE) HEIGHT _ (CADR PAPERSIZE))) (* ;  "Region created so can use INTERSECTREGIONS to compute visible region") (INITIALIZEMASTER.IP IPSTREAM) (BEGINMASTER.IP IPSTREAM) (BEGINPREAMBLE.IP IPSTREAM) (COND ((SETQ OPTION (LISTGET OPTIONS 'HEADING)) (replace IPHEADING of IPDATA with OPTION) (SELECTQ ENCODING (FULLIP-82 (HEADINGOP.IP IPSTREAM OPTION)) (GETFRAMEVAR.IP IPSTREAM))) (T (GETFRAMEVAR.IP IPSTREAM))) (* ; "initialize the stack") (* ;; "Allocate framevar 0, for heading op if there is one, otherwise for nothing. This means that the fonts will be in framevars that correspond to their position in PREAMBLEFONTS. MAKEINTERPRESS relies on this.") (SETUPFONTS.IP IPSTREAM (LISTGET OPTIONS 'FONTS)) (* ;  " Initially clips to the page, after font installed") (\DSPCLIPPINGREGION.IP IPSTREAM (fetch (INTERPRESSDATA IPPAGEFRAME) of IPDATA)) (COND ((LISTGET OPTIONS 'COLOR) (INITIALIZECOLOR.IP IPSTREAM) (STREAMPROP IPSTREAM 'COLOR T))) (PUSH-IP-STACK IPSTREAM (create IPSTATE)) (NEWPAGE.IP IPSTREAM) (* ;  "NEWPAGE automatically closes the preamble") (* ;;  "We need to set up the scan direction spec, so that polygon filling doesn't crash printers.") [LET [(PRINTSERVERNAME (OR (AND (BOUNDP 'SERVER) SERVER) (LISTGET OPTIONS 'SERVER) (AND (EQ 'LPT (FILENAMEFIELD IPSTREAM 'HOST)) (LET (POS (FILE (FULLNAME IPSTREAM))) (* ;; "This should be (FILENAMEFIELD FILE 'NAME) except that FILENAMEFIELD won't accept : as part of the name, thinks it marks a device field. This code is borrowed from PRINTERDEVICE") (AND (SETQ POS (STRPOS "}" FILE)) (SUBSTRING FILE (ADD1 POS) (SUB1 (OR (STRPOS "." FILE (ADD1 POS)) 0] (* ;  "Puts the printer's scan direction into the stream. ") (CL:WHEN PRINTSERVERNAME (STREAMPROP IPSTREAM 'P.SCAN.DIRECTION (OR (CDR (CL:ASSOC (NSNAME.TO.STRING (PARSE.NSNAME PRINTSERVERNAME) ) PRINTER.SCAN.DIRECTIONS.LIST :TEST #'STRING-EQUAL)) PRINTER.DEFAULT.SCAN.DIRECTION)))] IPSTREAM]) (SETUPFONTS.IP [LAMBDA (IPSTREAM FONTS) (* rmk%: "15-Sep-84 02:16") (* ;; "Sets up preamble fonts, and sets heading font. Leaves IPFONT as NIL. This means that \DSPFONT.IP of the heading font will establish that as the current font when the preamble is closed and the first page opens. NIL. Note that the preamble can't set the font imager variable.") (for F (IPDATA _ (fetch IPDATA of IPSTREAM)) inside (OR FONTS DEFAULTFONT) do (SETQ F (FONTCREATE F NIL NIL NIL 'INTERPRESS)) (DEFINEFONT.IP IPSTREAM F) (COND (IPDATA (* ;  "Take first font as heading font, and make it look like old current font on first NEWPAGE") (replace IPFONT of IPDATA with F) (replace IPHEADINGFONT of IPDATA with F) (SETQ IPDATA NIL]) (SHOWBITMAP.IP [LAMBDA (IPSTREAM BITMAP REGION SCALE ROTATION) (* ; "Edited 14-Jan-88 01:09 by FS") (* ;; "Puts out bit map with lower-left corner at current position. If given, REGION is a clipping region on the bitmap.") (* ;; "Brain damaged, %"lower-left corner%"?! What does rotation mean then, is the resulting image always (viewed from static observer holding paper) in the NorthEast quadrant wrt x,y (rotated about its center and output), or not (rotated about x,y)?? It didn't work either way, so I rewrote it (in showbitmap1.ip) to do the former. -FS.") (SHOW.IP IPSTREAM) (PROG (XPIXELS YPIXELS XBYTES) [COND [REGION (* ;  "Clip the incoming bitmap to the specified region.") (COND ([SETQ REGION (INTERSECTREGIONS REGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (fetch BITMAPWIDTH of BITMAP) HEIGHT _ (fetch BITMAPHEIGHT of BITMAP] (SETQ XPIXELS (fetch WIDTH of REGION)) (SETQ YPIXELS (fetch HEIGHT of REGION))) (T (* ;  "The clipping region doesn't overlap this bitmap. Punt.") (RETURN] (T (SETQ XPIXELS (fetch BITMAPWIDTH of BITMAP)) (SETQ YPIXELS (fetch BITMAPHEIGHT of BITMAP] (SETQ XBYTES (CEIL (FOLDHI XPIXELS BITSPERBYTE) BYTESPERCELL)) (* ;  "Lines must be padded to multiples of 32bits (cells)") (COND ((IGREATERP XBYTES MAXLONGSEQUENCEBYTES) (* ;  "We should really start breaking it up in the X direction as well") (ERROR "Bitmap line too long for Interpress printing")) ((ZEROP XBYTES) (* ;  "Don't want to do anything if the bitmap is zero wide or high.") (RETURN)) ((ZEROP YPIXELS) (* ;  "Don't want to do anything if the bitmap is zero wide or high.") (RETURN))) (* ; "put out to avoid moire patterns") (SETQ SCALE (COND (SCALE (TIMES SCALE (FQUOTIENT 2540 75))) (T (FQUOTIENT 2540 75))) (* ;  "Go to unit of 4 raven spots ~= 1 screen point") ) (bind LEFT (NEXTROW _ 0) (BOTTOM _ 0) (HEIGHT _ YPIXELS) (MAXYPIXELSPERCHUNK _ (IQUOTIENT MAXLONGSEQUENCEBYTES XBYTES)) while (IGREATERP YPIXELS 0) first [COND (REGION (* ;; "We're displaying a subsection of the bitmap. Set up the fields that let SHOWBITMAP1.IP pick bits from the right place") (SETQ LEFT (fetch LEFT of REGION)) (SETQ BOTTOM (fetch BOTTOM of REGION] do (* ;; "The bitmap is put out in chunks, from top to bottom -- corresponding to the order that the bits appear in memory.") (SHOWBITMAP1.IP IPSTREAM BITMAP LEFT NEXTROW XPIXELS (IMIN YPIXELS MAXYPIXELSPERCHUNK) SCALE ROTATION HEIGHT XBYTES BOTTOM) (SETQ YPIXELS (IDIFFERENCE YPIXELS MAXYPIXELSPERCHUNK)) (SETQ NEXTROW (IPLUS NEXTROW MAXYPIXELSPERCHUNK)) (* ;; "This is the next row of the bitmap (counting from the top of the region to be displayed) to go to the file.") ]) (\BITMAPSIZE.IP [LAMBDA (STREAM BITMAP DIMENSION) (* rrb "11-Mar-86 10:03") (* ;; "returns the height a bitmap will have on an interpress device. This is reduced in scale by 4 to avoid moire patterns on the 8044 by using (FQUOTIENT 2540 75) rather than MICASPERPT") (SELECTQ DIMENSION (WIDTH (TIMES (BITMAPWIDTH BITMAP) (CONSTANT (FQUOTIENT 2540 75)))) (HEIGHT (TIMES (BITMAPHEIGHT BITMAP) (CONSTANT (FQUOTIENT 2540 75)))) (NIL [CONS (TIMES (BITMAPWIDTH BITMAP) (CONSTANT (FQUOTIENT 2540 75))) (TIMES (BITMAPHEIGHT BITMAP) (CONSTANT (FQUOTIENT 2540 75]) (\ILLEGAL.ARG DIMENSION]) (SHOWBITMAP1.IP [LAMBDA (IPSTREAM BITMAP LEFT FIRSTROW XPIXELS YPIXELS SCALEFACTOR ROTATION HEIGHT XBYTES REGIONBOTTOM) (* ; "Edited 14-Jan-88 00:52 by FS") (* ;; "Move a segment of bitmap to an INTERPRESS file.") (* ;; "FIRSTROW is the row count -- STARTING FROM THE TOP OF THE BITMAP AS ZERO -- for the first row to be displayed.") (* ;; "By the time we get here, XBYTES should have been raised to the next multiple of 32-bits-worth, since that's the required width of packed pixel vectors.") (PROG [(TOTALBYTES (ITIMES XBYTES YPIXELS)) (SCRATCHBM (BITMAPCREATE (CEIL XPIXELS BITSPERCELL) 1)) (BMBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BITMAP) (ITIMES (IDIFFERENCE (IPLUS HEIGHT (OR REGIONBOTTOM 0)) (IPLUS FIRSTROW YPIXELS)) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP] (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (* ;  "Start the SIMPLEBODY for displaying this part of the bitmap.") (TRANS.IP IPSTREAM) (* ;  "Translate to the current position") (APPENDNUMBER.IP IPSTREAM YPIXELS) (* ;  "For the master, this is the number of pixels in the slow direction") (APPENDNUMBER.IP IPSTREAM (CEIL XPIXELS BITSPERCELL)) (* ;  "Number of pixels in the master's fast direction") (APPENDINTEGER.IP IPSTREAM 1) (* ; "Reserved for future expansion") (APPENDINTEGER.IP IPSTREAM 1) (APPENDINTEGER.IP IPSTREAM 1) (* ;; "Adjusts segment (move in X because bitmap is rotated (see below)). Push this segment up to its 'true' height -- i.e., The first segment gets pushed up all the way (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-#ofRowsIn1stSeg (to account for the first segment), and so on.") (TRANSLATE.IP IPSTREAM (IDIFFERENCE 0 (IPLUS FIRSTROW YPIXELS)) 0) (* ;; "Bitmaps are really shown on their sides (fast scan direction), hanging from the upper left corner.") (SETQ ROTATION (IMOD (OR ROTATION 0) 360)) (if (EQL ROTATION 90) elseif (OR (EQL ROTATION 0) (EQL ROTATION 180) (EQL ROTATION 270)) then (ROTATE.IP IPSTREAM (- ROTATION 90)) (CONCAT.IP IPSTREAM) else (ERROR ROTATION "rotation by other than multiples of 90 degrees not implemented" )) (SCALE.IP IPSTREAM SCALEFACTOR) (* ;  "Scale the bitmap to its final size") (CONCAT.IP IPSTREAM) (APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQPACKEDPIXELVECTOR (IPLUS 4 TOTALBYTES)) (APPENDINT.IP IPSTREAM 1 2) (APPENDINT.IP IPSTREAM (CEIL XPIXELS BITSPERCELL) 2) (* ;; "Now put out the bitmap -- each line must be a 32-bit multiple long") (for Y (XWORDS _ (FOLDHI XBYTES BYTESPERWORD)) from 1 to YPIXELS do (BITBLT BITMAP (OR LEFT 0) (IDIFFERENCE (IPLUS (OR REGIONBOTTOM 0) FIRSTROW YPIXELS) Y) SCRATCHBM 0 0 XPIXELS 1 'INPUT 'REPLACE) (\BOUTS IPSTREAM (fetch (BITMAP BITMAPBASE) of SCRATCHBM) 0 (CEIL XBYTES BYTESPERCELL))) (APPENDOP.IP IPSTREAM MAKEPIXELARRAY) (APPENDOP.IP IPSTREAM MASKPIXEL) (APPENDOP.IP IPSTREAM }]) (SHOWSHADE.IP [LAMBDA (IPSTREAM SHADE REGION OPERATION SCALE ANGLE) (* ; "Edited 15-Aug-88 09:30 by rmk:") (* ;;; "Puts out bit map with lower-left corner at current position. REGION is a clipping region on the bitmap.") (SHOW.IP IPSTREAM) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (SETCOLOR.IP IPSTREAM SHADE OPERATION SCALE ANGLE) (APPENDINTEGER.IP IPSTREAM (fetch (REGION LEFT) of REGION)) (APPENDINTEGER.IP IPSTREAM (fetch (REGION BOTTOM) of REGION)) (APPENDINTEGER.IP IPSTREAM (fetch (REGION WIDTH) of REGION)) (APPENDINTEGER.IP IPSTREAM (fetch (REGION HEIGHT) of REGION)) (APPENDOP.IP IPSTREAM MASKRECTANGLE) (APPENDOP.IP IPSTREAM }]) (\BITBLT.IP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 5-Aug-88 14:37 by rmk:") (* ;;; "what this does: because there is no device-supported clipping in IP2.1, we are forced to do it ourselves. We transform the bitmap region into IP space, do the clipping there, then transform it back. Most of the ugliness comes from doing arithmetic on regions, which is always big and messy") (LET* [(OLDX (\DSPXPOSITION.IP DESTINATION)) (OLDY (\DSPYPOSITION.IP DESTINATION)) (DESTINATIONLEFT (OR DESTINATIONLEFT OLDX)) (DESTINATIONBOTTOM (OR DESTINATIONBOTTOM OLDY)) (SOURCE-REGION NIL) (STREAMSCALE (DSPSCALE NIL DESTINATION)) (DESTWIDTH (TIMES STREAMSCALE WIDTH)) (DESTHEIGHT (TIMES STREAMSCALE HEIGHT)) (DESTINATIONREGION (INTERSECTREGIONS (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM DESTWIDTH DESTHEIGHT) (ffetch (INTERPRESSDATA IPVISIBLEREGION) of (ffetch (IPSTREAM IMAGEDATA) of DESTINATION] (if CLIPPINGREGION then (SETQ DESTINATIONREGION (INTERSECTREGIONS DESTINATIONREGION CLIPPINGREGION))) (* ;; "transform the clipping region into source coord space") (if DESTINATIONREGION then (\MOVETO.IP DESTINATION (fetch (REGION LEFT) of DESTINATIONREGION) (fetch (REGION BOTTOM) of DESTINATIONREGION)) [SETQ SOURCE-REGION (CREATEREGION (PLUS CLIPPEDSOURCELEFT (FIXR (QUOTIENT (DIFFERENCE (fetch (REGION LEFT) of DESTINATIONREGION ) DESTINATIONLEFT) STREAMSCALE))) (PLUS CLIPPEDSOURCEBOTTOM (FIXR (QUOTIENT (DIFFERENCE (fetch (REGION BOTTOM) of DESTINATIONREGION ) DESTINATIONBOTTOM) STREAMSCALE))) (FIXR (QUOTIENT (fetch (REGION WIDTH) of DESTINATIONREGION ) STREAMSCALE)) (FIXR (QUOTIENT (fetch (REGION HEIGHT) of DESTINATIONREGION) STREAMSCALE] (SHOWBITMAP.IP DESTINATION SOURCEBITMAP SOURCE-REGION 1) (\MOVETO.IP DESTINATION OLDX OLDY) (* ; "") T else NIL]) (\SCALEDBITBLT.IP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATION-LEFT DESTINATION-BOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 19-Aug-88 11:02 by hdj") (* ;; "Print a clipped and scaled bitmap.") (LET* [(OLDX (\DSPXPOSITION.IP DESTINATION)) (OLDY (\DSPYPOSITION.IP DESTINATION)) (DESTINATION-LEFT (OR DESTINATION-LEFT OLDX)) (DESTINATION-BOTTOM (OR DESTINATION-BOTTOM OLDY)) (SOURCE-REGION NIL) (STREAM-SCALE (DSPSCALE NIL DESTINATION)) (DESTINATION-REGION (INTERSECTREGIONS (CREATEREGION DESTINATION-LEFT DESTINATION-BOTTOM (TIMES SCALE STREAM-SCALE WIDTH) (TIMES SCALE STREAM-SCALE HEIGHT)) (ffetch (INTERPRESSDATA IPVISIBLEREGION) of (ffetch (IPSTREAM IMAGEDATA) of DESTINATION] (if CLIPPINGREGION then (SETQ DESTINATION-REGION (INTERSECTREGIONS DESTINATION-REGION CLIPPINGREGION)) ) (* ;; "transform the clipping region into source coord space") (if DESTINATION-REGION then (\MOVETO.IP DESTINATION (fetch (REGION LEFT) of DESTINATION-REGION ) (fetch (REGION BOTTOM) of DESTINATION-REGION)) [SETQ SOURCE-REGION (CREATEREGION (+ CLIPPEDSOURCELEFT (FIXR (QUOTIENT (- (fetch (REGION LEFT) of DESTINATION-REGION ) DESTINATION-LEFT) STREAM-SCALE))) (+ CLIPPEDSOURCEBOTTOM (FIXR (QUOTIENT (- (fetch (REGION BOTTOM) of DESTINATION-REGION) DESTINATION-BOTTOM) STREAM-SCALE))) (FIXR (QUOTIENT (fetch (REGION WIDTH) of DESTINATION-REGION ) (TIMES SCALE STREAM-SCALE))) (FIXR (QUOTIENT (fetch (REGION HEIGHT) of DESTINATION-REGION) (TIMES SCALE STREAM-SCALE] (SHOWBITMAP.IP DESTINATION SOURCEBITMAP SOURCE-REGION SCALE) (\MOVETO.IP DESTINATION OLDX OLDY) (* ; "") T else NIL]) (\BLTSHADE.IP [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 5-Aug-88 14:37 by rmk:") (PROG [(DESTREGION (INTERSECTREGIONS (ffetch (INTERPRESSDATA IPVISIBLEREGION) of (ffetch (IPSTREAM IMAGEDATA) of STREAM)) (CREATEREGION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT] (if (NOT DESTREGION) then (RETURN)) (if CLIPPINGREGION then (SETQ DESTREGION (INTERSECTREGIONS DESTREGION CLIPPINGREGION))) (if (NOT DESTREGION) then (RETURN)) (OR OPERATION (SETQ OPERATION (DSPOPERATION NIL STREAM))) (COND ((> PRINTSERVICE 8.0) (SHOWSHADE.IP STREAM (INSURE.B&W.TEXTURE TEXTURE) DESTREGION OPERATION)) (T (* ;  "until 8044s can print scaled textures without crashing") (\BLTSHADE.GENERICPRINTER TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION \INTERPRESSSCALE]) (\CHARWIDTH.IP [LAMBDA (STREAM CHARCODE) (* rmk%: "12-Apr-85 09:42") (* ;; "Gets the width of CHARCODE in an Interpress STREAM, observing spacefactor") (COND ((EQ CHARCODE (CHARCODE SPACE)) (ffetch IPSPACEWIDTH of (ffetch IMAGEDATA of STREAM))) (T (\FGETCHARWIDTH (ffetch IPFONT of (ffetch IMAGEDATA of STREAM)) CHARCODE]) (\CLOSEIPSTREAM [LAMBDA (IPSTREAM) (* rmk%: "27-JUL-83 19:48") (SELECTQ (fetch IPPAGESTATE of (fetch IPDATA of IPSTREAM)) (PAGE (ENDPAGE.IP IPSTREAM)) (PREAMBLE (ENDPREAMBLE.IP IPSTREAM)) NIL) (ENDMASTER.IP IPSTREAM]) (\DRAWARC.IP [LAMBDA (STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING) (* rrb " 4-Oct-85 17:24") (* ;  "draws an arc on an interpress file") (\DRAWARC.GENERIC STREAM CENTERX CENTERY RADIUS STARTANGLE NDEGREES BRUSH DASHING]) (\DRAWCURVE.IP [LAMBDA (IPSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 5-Aug-88 16:45 by rmk:") (* ;; "draws a spline curve with a given brush--except that dashing is currently ignored, and the curve is done with straight lines.") [COND ((LISTP KNOTS) (* ;  "to allow the brush color to have the correct scope") (LET (K) [OR (CDR KNOTS) (SETQ KNOTS (LIST (CAR KNOTS) (CAR KNOTS] (* ; "The funny case of a single knot") (COND ((AND (NULL DASHING) (EQ 2 (LENGTH KNOTS))) (* ;  "There were only two knots, and no dashing.") (OR (type? POSITION (SETQ K (CAR KNOTS))) (ERROR "bad knot" K)) (\DRAWLINE.IP IPSTREAM (fetch XCOORD of K) (fetch YCOORD of K) [fetch XCOORD of (COND ((type? POSITION (SETQ K (CADR KNOTS))) K) (T (ERROR "bad knot" K] (fetch YCOORD of K) BRUSH)) (T (* ;  "Otherwise, use the full-strength curve drawer.") (SHOW.IP IPSTREAM T) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (\IPCURVE2 IPSTREAM (PARAMETRICSPLINE KNOTS CLOSED) DASHING BRUSH) (* ;  "This leaves the current position at the endpoint of the curve.") (APPENDOP.IP IPSTREAM }) (SETQ K (CAR (LAST KNOTS))) (SETXY.IP IPSTREAM (fetch XCOORD of K) (fetch YCOORD of K] IPSTREAM]) (\DRAWPOINT.IP [LAMBDA (IPSTREAM X Y BRUSH OPERATION) (* ; "Edited 8-Aug-88 15:55 by rmk:") (* ; "draws a single point.") (SHOW.IP IPSTREAM) (* ;  "to allow the brush color to have the correct scope") (if (BITMAPP BRUSH) then (* ;; "Awful crufty case, must support it because it's documented. ") (LET ((WIDTH (BITMAPWIDTH BRUSH)) (HEIGHT (BITMAPHEIGHT BRUSH))) (* ;; "Call toplevel guy so don't need to set up clipping nonsense") (BITBLT BRUSH 0 0 IPSTREAM [- X (ITIMES WIDTH (CONSTANT (IQUOTIENT MICASPERPT 2] [- Y (ITIMES HEIGHT (CONSTANT (IQUOTIENT MICASPERPT 2] WIDTH HEIGHT OPERATION)) else (\DRAWLINE.IP IPSTREAM X Y X Y BRUSH OPERATION)) IPSTREAM]) (\DSPCOLOR.IP [LAMBDA (IPSTREAM COLOR) (* edited%: "31-Mar-86 15:36") (if (STREAMPROP IPSTREAM 'COLOR) then (* ;  "this is an interpress stream which can interpret color, otherwise dspcolor is a no-op") (if COLOR then (LET* ((IPDATA (fetch IPDATA of IPSTREAM)) (RGB (ENSURE.RGB COLOR))) (replace (INTERPRESSDATA IPCOLOR) of IPDATA with RGB) (SETRGB.IP IPSTREAM (CAR RGB) (CADR RGB) (CADDR RGB))) else (fetch (INTERPRESSDATA IPCOLOR) of (fetch IPDATA of IPSTREAM ]) (ENSURE.RGB [LAMBDA (COLOR NOERRORFLG?) (* edited%: "31-Mar-86 21:41") (* ;; "returns an rgb triple or errors (NIL if NOERRORFLG). Acceptable input is RGB, HLS, or litatom on COLORNAMES") (LET ((RGB COLOR)) (COND ((LITATOM COLOR) (if (SETQ RGB (\LOOKUPCOLORNAME COLOR)) then (pop RGB))) ((HLSP RGB) (HLSTORGB RGB))) (if (NOT (RGBP RGB)) then (if NOERRORFLG? then NIL else (ERROR "Illegal color" COLOR)) else RGB]) (\IPCURVE2 [LAMBDA (IPSTREAM SPLINE DASHING BRUSH) (* ; "Edited 8-Aug-88 15:13 by rmk:") (* ;;; "Given an Interpress stream, and a spline in the form of derivatives for each segment, and a brush to draw with, draw line segments to paint the curve.") (* ;;; "NB: The endpoints of line segments are placed only to 1/300in accuracy, since that's all the accuracy our printers have. This speeds things up by a factor of 8 or more.") (* ;; "Changed to step in micas \SPLINESTEP.IP, initially 16 (approx. 1/2 pt.). Used to be 8 (approx. screen resolution)") (PROG ((XPOLY (create POLYNOMIAL)) (X'POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y'POLY (create POLYNOMIAL)) (X (fetch (SPLINE SPLINEX) of SPLINE)) (Y (ffetch (SPLINE SPLINEY) of SPLINE)) (X' (ffetch (SPLINE SPLINEDX) of SPLINE)) (Y' (ffetch (SPLINE SPLINEDY) of SPLINE)) (X'' (ffetch (SPLINE SPLINEDDX) of SPLINE)) (Y'' (ffetch (SPLINE SPLINEDDY) of SPLINE)) (X''' (ffetch (SPLINE SPLINEDDDX) of SPLINE)) (Y''' (ffetch (SPLINE SPLINEDDDY) of SPLINE)) (%#KNOTS (ffetch %#KNOTS of SPLINE)) (IPXPOS (ELT (ffetch (SPLINE SPLINEX) of SPLINE) 1)) (IPYPOS (ELT (ffetch (SPLINE SPLINEY) of SPLINE) 1)) IX IY DX DY XT YT X'T Y'T NEWXT NEWYT XDIFF YDIFF XWALLDT YWALLDT DUPLICATEKNOT EXTRANEOUS TT NEWT DELTA DASHON DASHLST DASHCNT IPDATA SEG# SPLINESTEP HALFWIDTH LEFT RIGHT BOTTOM TOP SPLINEDIFF VISIBLEP PREVX PREVY) (SETQ SPLINESTEP (FIX \SPLINESTEP.IP)) (SETQ HALFWIDTH (FQUOTIENT (\WIDTHFROMBRUSH BRUSH MICASPERPOINT) 2)) (SETQ SPLINEDIFF \SPLINESTEP.IP) (SETQ DASHON T) (* ;; "These are initialized outside the prog-bindings cause the compiler can't hack so many initialized variables") (SETQ DASHLST DASHING) (* ;  "Make a circular list of dashing intervals, so that we can just CDR down it to find dashings.") (SETQ DASHCNT (CAR DASHING)) (SETQ SEG# 0) (SETQ IPDATA (fetch IMAGEDATA of IPSTREAM)) (SETQ LEFT (+ (fetch IPVISLEFT of IPDATA) HALFWIDTH)) (SETQ RIGHT (- (fetch IPVISRIGHT of IPDATA) HALFWIDTH)) (SETQ BOTTOM (+ (fetch IPVISBOTTOM of IPDATA) HALFWIDTH)) (SETQ TOP (- (fetch IPVISTOP of IPDATA) HALFWIDTH)) (* ;  "NOTE; Don't need to keep IPDATA up to date") (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) (if VISIBLEP then (MOVETO.IP IPSTREAM IPXPOS IPYPOS)) (* ;  "Move to the curve's starting point") (SETQ TT 0.0) (* ;  "We paint each segment by walking the parameter TT from 0.0 to 1.0") (SETQ DELTA 1024) (SETQ IX (FIXR IPXPOS)) (SETQ IY (FIXR IPYPOS)) [for KNOT# from 1 to (SUB1 %#KNOTS) do (* ; "Draw each segment in turn") (LOADPOLY XPOLY X'POLY (ELT X''' KNOT#) (ELT X'' KNOT#) (ELT X' KNOT#) (ELT X KNOT#)) (LOADPOLY YPOLY Y'POLY (ELT Y''' KNOT#) (ELT Y'' KNOT#) (ELT Y' KNOT#) (ELT Y KNOT#)) (SETQ XT (POLYEVAL TT XPOLY 3)) (* ;  "XT _ X (t) --Evaluate the next point") (SETQ YT (POLYEVAL TT YPOLY 3)) (* ; "YT _ Y (t)") (COND [(NOT (IEQP KNOT# (SUB1 %#KNOTS))) (* ;  "This isn't the last knot. Check to see if the next knot in line is a duplicated knot.") (SETQ DUPLICATEKNOT (AND (EQP (ELT X (ADD1 KNOT#)) (ELT X (IPLUS KNOT# 2))) (EQP (ELT Y (ADD1 KNOT#)) (ELT Y (IPLUS KNOT# 2] (T (SETQ DUPLICATEKNOT NIL))) [until (GEQ TT 1.0) do (* ;  "Run the parameter TT from 0 to 1 for this segment") (SETQ X'T (POLYEVAL TT X'POLY 2)) (* ; "X'T _ X' (t)") (SETQ Y'T (POLYEVAL TT Y'POLY 2)) (* ; "Y'T _ Y' (t)") (COND ((EQP X'T 0.0) (* ; "Prevent divide-by-zero") (SETQ X'T 5.0E-4))) (COND ((EQP Y'T 0.0) (* ; "Prevent divide-by-zero") (SETQ Y'T 5.0E-4))) [COND ((FGREATERP X'T 0.0) (SETQ DX DELTA)) (T (SETQ DX (IMINUS DELTA] [COND ((FGREATERP Y'T 0.0) (SETQ DY DELTA)) (T (SETQ DY (IMINUS DELTA] (SETQ XWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IX DX) XT) X'T)) (SETQ YWALLDT (FQUOTIENT (FDIFFERENCE (IPLUS IY DY) YT) Y'T)) (* ;  "Decide which of dX or dY is changing faster, and use that as the limiting value") [COND ((FLESSP XWALLDT YWALLDT) (SETQ NEWT (FPLUS TT XWALLDT)) (SETQ DY (IDIFFERENCE (FIXR (FPLUS YT (FTIMES XWALLDT Y'T))) IY))) (T (SETQ NEWT (FPLUS TT YWALLDT)) (SETQ DX (IDIFFERENCE (FIXR (FPLUS XT (FTIMES YWALLDT X'T))) IX] (COND ([AND (FGTP NEWT 1.0) (OR DUPLICATEKNOT (EQ KNOT# (SUB1 %#KNOTS] (* ;; "If we've run TT past 1, or if this knot is duplicated (meaning make a discontinuity in x' & y') then draw straight to the end point.") (SETQ NEWT 1.0))) (SETQ NEWXT (POLYEVAL NEWT XPOLY 3)) (* ; "New XT _ X (new t)") (SETQ NEWYT (POLYEVAL NEWT YPOLY 3)) (* ; "New YT _ Y (new t)") (SETQ XDIFF (ABS (FDIFFERENCE (IPLUS IX DX) NEWXT))) (* ;  "Find out how close we come to the ideal") (SETQ YDIFF (ABS (FDIFFERENCE (IPLUS IY DY) NEWYT))) (COND ((AND (IGREATERP DELTA 8) (OR (FGREATERP XDIFF SPLINESTEP) (FGREATERP YDIFF SPLINESTEP))) (* ;; "We're more than a printer dot off, and we still have room to make the DX or DY smaller. Do so & try again.") (SETQ DELTA (LRSH DELTA 1))) (T (* ;  "This is as close as we can come. Draw the line segment.") (COND ((IGREATERP (add SEG# 1) MAXSEGSPERTRAJECTORY) (* ;; "Our printers limit the number of segments in a single TRAJECTORY; make sure we respect their limitations") (\IMAGEPATH.IP BRUSH IPSTREAM) (SETQ SEG# 0) (MOVETO.IP IPSTREAM IPXPOS IPYPOS))) (SETQ PREVX IPXPOS) (SETQ IPXPOS (PLUS IPXPOS DX)) (SETQ PREVY IPYPOS) (SETQ IPYPOS (PLUS IPYPOS DY)) (* ; "Now check clipping") (if VISIBLEP then (if (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) then (* ;  "Super-common case: both ends visible, draw the line") (LINETO.IP IPSTREAM IPXPOS IPYPOS) else (* ; "Starts visible, goes out") (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM T IPSTREAM ) (\IMAGEPATH.IP BRUSH IPSTREAM) (* ; "Curve is now invisible") (SETQ SEG# 0)) else (if (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) then (* ;  " Starts invisible, comes in. MOVETO is done in \CLIPCURVELINE.IP") (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM NIL IPSTREAM) else (* ;  " Both ends invisible, could be visible in middle") (if (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM NIL IPSTREAM) then (* ;  " Drew a segment disconnected from rest of curve") (\IMAGEPATH.IP BRUSH IPSTREAM)) (SETQ SEG# 0) (* ;  "SEG# goes to 0 whenever we end up outside") )) (SETQ IX (IPLUS IX DX)) (SETQ IY (IPLUS IY DY)) (SETQ TT NEWT) (SETQ XT NEWXT) (SETQ YT NEWYT) (COND ((AND (ILESSP DELTA 1024) (OR (FLESSP XDIFF 4.0) (FLESSP YDIFF 4.0))) (* ;  "If we were REAL close, we can relax a bit, and try moving farther next time.") (SETQ DELTA (LLSH DELTA 1] (SETQ TT (FDIFFERENCE TT 1.0)) (* ;; "Having moved past a knot, back the value of the parameter TT back down. However, don't set it to 0.0--let's try to keep the line going from where it got to in passing the last knot.") (COND (DUPLICATEKNOT (* ;; "This next knot is a duplicate. Skip over it, and start from the following knot. This will avoid odd problems trying to go nowhere while obeying the constraints of X' and Y' at that knot--since it's a duplicate, X' and Y' are discontinuous there.") (add KNOT# 1] (if VISIBLEP then (* ;  "Only need to clean up if we're now inside") (* ; "FS- Unfortunately no OPER.") (\IMAGEPATH.IP BRUSH IPSTREAM]) (\CLIPCURVELINE.IP [LAMBDA (X1 Y1 X2 Y2 LEFT RIGHT TOP BOTTOM PT1VISP IPSTREAM) (* ; "Edited 8-Aug-88 12:48 by rmk:") (* ;; "Called when the line between X1,Y1 X2,Y2 is known not to be entirely in the clipping region defined by LEFT RIGHT TOP BOTTOM, which have already been adjusted by the halfwidth of the brush. If any part of the line is visible, it shows that segment, returns T if anything was shown for any cleanup operators.") (* ;; " If PT1VISP and some part is visible, it knows that the initial part of the segment is visible and the final part is invisible. If not PT1VISP and something is shown, then it knows that a MOVETO is necessary to the beginning of the segment.") (PROG (CA1 CA2 DX DY SWAPPED) (* ;; "switch points so that X1 is less than X2.") (if (> X1 X2) then (SETQ CA1 X1) (SETQ X1 X2) (SETQ X2 CA1) (SETQ CA1 Y1) (SETQ Y1 Y2) (SETQ Y2 CA1) (SETQ SWAPPED T)) (SETQ DX (- X2 X1)) (SETQ DY (- Y2 Y1)) (* ;  "determine the sectors in which the points fall.") (SETQ CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) (SETQ CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM)) CLIPLP (COND ((NEQ 0 (LOGAND CA1 CA2)) (* ;  "line is entirely out of clipping region") (RETURN NIL)) ((EQ 0 (PLUS CA1 CA2)) (* ; "line is now completely visible") (if SWAPPED then (OR PT1VISP (MOVETO.IP IPSTREAM X2 Y2)) (LINETO.IP IPSTREAM X1 Y1) else (OR PT1VISP (MOVETO.IP IPSTREAM X1 Y1)) (* ; " If PT1 wasn't visible, then we have to move to the point where the line enters the region. We can also assume that we are at the start of the trajectory, since caller does the setup") (LINETO.IP IPSTREAM X2 Y2)) (RETURN T))) [COND ((NEQ CA1 0) (* ;; "now move point X1 Y1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") (COND ((GREATERP CA1 7) (* ; "y1 less than bottom") (* ;  "calculate the least X for which Y will be at bottom.") [SETQ X1 (PLUS X1 (FTIMES DX (FQUOTIENT (- BOTTOM Y1) DY] (SETQ Y1 BOTTOM)) ((GREATERP CA1 3) (* ; "y1 is greater than top") [SETQ X1 (PLUS X1 (FTIMES DX (FQUOTIENT (- TOP Y1) DY] (SETQ Y1 TOP)) (T (* ; "x1 is less than left") [SETQ Y1 (PLUS Y1 (FTIMES DY (FQUOTIENT (- LEFT X1) DX] (SETQ X1 LEFT))) (SETQ CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM))) (T (* ;  "now move point X2 Y2 so that one of the coordinates is on one of the boundaries") (COND ((GREATERP CA2 7) (* ; "y2 less than bottom") [SETQ X2 (PLUS X2 (FTIMES DX (FQUOTIENT (- BOTTOM Y2) DY] (SETQ Y2 BOTTOM)) ((GREATERP CA2 3) (* ; "y2 is greater than top") [SETQ X2 (- X2 (FTIMES DX (FQUOTIENT (- Y2 TOP) DY] (SETQ Y2 TOP)) (T (* ; "x2 is greater than right") [SETQ Y2 (- Y2 (FTIMES DY (FQUOTIENT (- X2 RIGHT) DX] (SETQ X2 RIGHT))) (SETQ CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM] (GO CLIPLP]) (\DRAWLINE.IP [LAMBDA (IPSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 8-Aug-88 15:15 by rmk:") (COND (DASHING (* ;  "added dashing hack --- rrb 27-sept-85") (DRAWDASHEDLINE X1 Y1 X2 Y2 WIDTH OPERATION IPSTREAM COLOR DASHING)) (T (* ;; "RRB: A temporary interface function until we resolve the color/endshape/operation conflicts in the D.I.G. argument structure. Arguments are assumed to be in micas.") (SHOW.IP IPSTREAM T) [LET ((IPDATA (ffetch (IPSTREAM IMAGEDATA) of IPSTREAM)) (W (\WIDTHFROMBRUSH WIDTH MICASPERPOINT)) HALFWIDTH) (* ;; "FS: do quick and dirty test to avoid consing in the common case. Since Interpress line ends cannot extend past WIDTH, and since line joints presumably cannot be made this way (not a polyline), simply grow line by WIDTH (which is conservatively more than actual WIDTH/2)") (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (* ;  "If totally clipped, this is a waste") (COND ((AND (< (fetch (INTERPRESSDATA IPVISLEFT) of IPDATA) (- (MIN X1 X2) W)) (< (fetch (INTERPRESSDATA IPVISBOTTOM) of IPDATA) (- (MIN Y1 Y2) W)) (< (+ (MAX X1 X2) W) (fetch (INTERPRESSDATA IPVISRIGHT) of IPDATA)) (< (+ (MAX Y1 Y2) W) (fetch (INTERPRESSDATA IPVISTOP) of IPDATA))) (* ;; "Completely in clip region, common simple case. ") (MOVETO.IP IPSTREAM X1 Y1) (LINETO.IP IPSTREAM X2 Y2) (\IMAGEPATH.IP (COND ((BRUSHP WIDTH) WIDTH) (T (LIST 'BUTT WIDTH COLOR))) IPSTREAM OPERATION)) (T (* ;; "Must do more careful clipping in this case.") (SETQ HALFWIDTH (FQUOTIENT W 2)) (COND ((\CLIPCURVELINE.IP X1 Y1 X2 Y2 (+ (fetch IPVISLEFT of IPDATA) HALFWIDTH) (- (fetch IPVISRIGHT of IPDATA) HALFWIDTH) (- (fetch IPVISTOP of IPDATA) HALFWIDTH) (+ (fetch IPVISBOTTOM of IPDATA) HALFWIDTH) NIL IPSTREAM) (\IMAGEPATH.IP (COND ((BRUSHP WIDTH) WIDTH) (T (LIST 'BUTT WIDTH COLOR))) IPSTREAM OPERATION] (APPENDOP.IP IPSTREAM }) (SETXY.IP IPSTREAM X2 Y2]) (\CLIPLINE [LAMBDA (X1 Y1 X2 Y2 WIDTH CLIPREG) (* ; "Edited 8-Aug-88 11:18 by rmk:") (* ;; "No longer called by Interpress, but may be called by someone else.") (* ;; "Clips the line X1 Y1 to X2 Y2 to the region CLIPREG leaving room for a brush WIDTH wide. If any part of the line is visible, it returns (LIST newX1 NewY1 NewX2 NewY2)") (PROG ((HALFWIDTH (FQUOTIENT WIDTH 2)) LEFT RIGHT BOTTOM TOP CA1 CA2 DX DY) (* ;; "set LEFT, RIGHT, BOTTOM, TOP to the boundaries of the clipping region compensating for the brush width.") (SETQ LEFT (+ (fetch (REGION LEFT) of CLIPREG) HALFWIDTH)) (SETQ RIGHT (- (fetch (REGION RIGHT) of CLIPREG) HALFWIDTH)) (SETQ BOTTOM (+ (fetch (REGION BOTTOM) of CLIPREG) HALFWIDTH)) (SETQ TOP (- (fetch (REGION TOP) of CLIPREG) HALFWIDTH)) (* ;  "switch points so that X1 is less than X2.") (COND ((GREATERP X1 X2) (SETQ CA1 X1) (SETQ X1 X2) (SETQ X2 CA1) (SETQ CA1 Y1) (SETQ Y1 Y2) (SETQ Y2 CA1))) (SETQ DX (DIFFERENCE X2 X1)) (SETQ DY (DIFFERENCE Y2 Y1)) (* ;  "determine the sectors in which the points fall.") (SETQ CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM)) (SETQ CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM)) CLIPLP [COND ((NOT (EQ 0 (LOGAND CA1 CA2))) (* ;  "line is entirely out of clipping region") (RETURN NIL)) ((EQ 0 (PLUS CA1 CA2)) (* ; "line is completely visible") (* ; "reuse the variable CA1") (RETURN (LIST (FIXR X1) (FIXR Y1) (FIXR X2) (FIXR Y2] [COND ((NEQ CA1 0) (* ;; "now move point X1 Y1 so that one of the coordinates is on one of the boundaries. Which boundary is done first was copied from BCPL.") (COND ((GREATERP CA1 7) (* ; "y1 less than bottom") (* ;  "calculate the least X for which Y will be at bottom.") [SETQ X1 (PLUS X1 (FTIMES DX (FQUOTIENT (DIFFERENCE BOTTOM Y1) DY] (SETQ Y1 BOTTOM)) ((GREATERP CA1 3) (* ; "y1 is greater than top") [SETQ X1 (PLUS X1 (FTIMES DX (FQUOTIENT (DIFFERENCE TOP Y1) DY] (SETQ Y1 TOP)) (T (* ; "x1 is less than left") [SETQ Y1 (PLUS Y1 (FTIMES DY (FQUOTIENT (DIFFERENCE LEFT X1) DX] (SETQ X1 LEFT))) (SETQ CA1 (\CLIPCODE X1 Y1 LEFT RIGHT TOP BOTTOM))) (T (* ;  "now move point X2 Y2 so that one of the coordinates is on one of the boundaries") (COND ((GREATERP CA2 7) (* ; "y2 less than bottom") [SETQ X2 (PLUS X2 (FTIMES DX (FQUOTIENT (DIFFERENCE BOTTOM Y2) DY] (SETQ Y2 BOTTOM)) ((GREATERP CA2 3) (* ; "y2 is greater than top") [SETQ X2 (DIFFERENCE X2 (FTIMES DX (FQUOTIENT (DIFFERENCE Y2 TOP) DY] (SETQ Y2 TOP)) (T (* ; "x2 is greater than right") [SETQ Y2 (DIFFERENCE Y2 (FTIMES DY (FQUOTIENT (DIFFERENCE X2 RIGHT) DX] (SETQ X2 RIGHT))) (SETQ CA2 (\CLIPCODE X2 Y2 LEFT RIGHT TOP BOTTOM] (GO CLIPLP]) (\DSPBOTTOMMARGIN.IP [LAMBDA (IPSTREAM YPOSITION) (* rmk%: "26-Jun-84 14:01") (PROG1 (fetch IPBOTTOM of (fetch IMAGEDATA of IPSTREAM)) (COND (YPOSITION (replace IPBOTTOM of (fetch IMAGEDATA of IPSTREAM) with YPOSITION)))) ]) (\DSPFONT.IP [LAMBDA (IPSTREAM FONT) (* ; "Edited 21-Aug-91 16:33 by jds") (* ;; "Change fonts (or return the current font) for an IP stream") (PROG (OLDFONT FRAMEVAR (IPDATA (ffetch IMAGEDATA of IPSTREAM))) (SETQ OLDFONT (ffetch IPFONT of IPDATA)) (AND (NULL FONT) (RETURN OLDFONT)) (SHOW.IP IPSTREAM) (* ; "ALWAYS do the show, so that font changes force recomputation of the exact position in the printer.") (COND ([EQ OLDFONT (SETQ FONT (OR (\GETFONTDESC FONT 'INTERPRESS) (FONTCOPY OLDFONT FONT] (* ;  "There was no change, or he was only asking for the old font. Just return it.") (RETURN OLDFONT))) [SETQ FRAMEVAR (CDR (OR (ASSOC FONT (ffetch IPPAGEFONTS of IPDATA)) (DEFINEFONT.IP IPSTREAM FONT] (* ;  "Get the font number to go in the file") (APPENDINTEGER.IP IPSTREAM FRAMEVAR) (APPENDOP.IP IPSTREAM SETFONT) (freplace IPFONT of IPDATA with FONT) (* ; "Remember the new font") (\CHANGECHARSET.IP IPDATA \DEFAULTCHARSET) [freplace IPSPACEWIDTH of IPDATA with (FIXR (TIMES (ffetch IPSPACEFACTOR of IPDATA) (\FGETWIDTH (ffetch IPWIDTHSCACHE of IPDATA ) (CHARCODE SPACE] (* ;  "Set the linefeed distance to be one point more than the font height") [freplace IPLINEFEED of IPDATA with (IDIFFERENCE (CONSTANT (IMINUS (IQUOTIENT MICASPERINCH POINTSPERINCH ))) (FONTPROP FONT 'HEIGHT] (freplace NSTRANSTABLE of IPDATA with (ffetch OTHERDEVICEFONTPROPS of FONT)) (\FIXLINELENGTH.IP IPSTREAM) (freplace IPMAXVISIBLEBASELINE of IPDATA with (- (ffetch IPVISTOP of IPDATA) (ffetch (FONTDESCRIPTOR \SFAscent) of FONT))) (freplace IPMINVISIBLEBASELINE of IPDATA with (+ (ffetch IPVISBOTTOM of IPDATA) (ffetch (FONTDESCRIPTOR \SFDescent) of FONT))) [replace IPCHARVISIBLEP of IPDATA with (AND (>= (fetch IPXPOS of IPDATA ) (fetch IPVISLEFT of IPDATA)) (>= (fetch IPYPOS of IPDATA ) (fetch IPMINVISIBLEBASELINE of IPDATA)) (<= (fetch IPYPOS of IPDATA ) (fetch IPMAXVISIBLEBASELINE of IPDATA] (AND *INTERPRESS-PRINTER-DSPFONT-PATCH* (\MOVETO.IP IPSTREAM (fetch IPXPOS of IPDATA) (fetch IPYPOS of IPDATA))) (RETURN OLDFONT]) (\DSPLEFTMARGIN.IP [LAMBDA (IPSTREAM XPOSITION) (* rmk%: " 4-Oct-84 10:34") (PROG1 (ffetch IPLEFT of (ffetch IMAGEDATA of IPSTREAM)) (COND (XPOSITION (freplace IPLEFT of (ffetch IMAGEDATA of IPSTREAM) with XPOSITION) (\FIXLINELENGTH.IP IPSTREAM))))]) (\DSPLINEFEED.IP [LAMBDA (IPSTREAM DELTAY) (* rmk%: " 4-Oct-84 09:26") (* ;  "sets the amount that a line feed increases the y coordinate by.") (PROG ((IPDATA (ffetch IMAGEDATA of IPSTREAM))) (RETURN (PROG1 (ffetch IPLINEFEED of IPDATA) [AND DELTAY (COND ((NUMBERP DELTAY) (freplace IPLINEFEED of IPDATA with DELTAY)) (T (\ILLEGAL.ARG DELTAY])]) (\DSPRIGHTMARGIN.IP [LAMBDA (IPSTREAM XPOSITION) (* ; "Edited 11-Aug-88 15:44 by rmk:") (LET ((IPDATA (ffetch IPDATA of IPSTREAM))) (PROG1 (ffetch IPRIGHT of IPDATA) (COND (XPOSITION (freplace IPRIGHT of IPDATA with XPOSITION) (freplace IPMINCHARRIGHT of IPDATA with (MIN (fetch IPVISRIGHT of IPDATA) (ffetch IPRIGHT of IPDATA))) (\FIXLINELENGTH.IP IPSTREAM))))]) (\DSPSPACEFACTOR.IP [LAMBDA (STREAM FACTOR) (* ; "Edited 23-Mar-88 21:04 by jds") (PROG ((IPDATA (ffetch IMAGEDATA of STREAM))) (RETURN (PROG1 (ffetch IPSPACEFACTOR of IPDATA) (COND (FACTOR [freplace IPSPACEWIDTH of IPDATA with (FIXR (TIMES FACTOR (CHARWIDTH (CHARCODE SPACE) (ffetch IPFONT of IPDATA] (* ;  "Doing the multiply first will insure that FACTOR is a number") (freplace IPSPACEFACTOR of IPDATA with FACTOR) (SHOW.IP STREAM) (APPENDNUMBER.IP STREAM FACTOR) (ISET.IP STREAM AMPLIFYSPACE))))]) (\DSPTOPMARGIN.IP [LAMBDA (IPSTREAM YPOSITION) (* rmk%: "26-Jun-84 14:01") (PROG1 (fetch IPTOP of (fetch IMAGEDATA of IPSTREAM)) (COND (YPOSITION (replace IPTOP of (fetch IMAGEDATA of IPSTREAM) with YPOSITION ))))]) (\DSPXPOSITION.IP [LAMBDA (IPSTREAM XPOSITION) (* jds "14-Feb-86 12:13") (* ;;; "DSPXPOSITION method for interpress streams") (PROG1 (fetch IPXPOS of (fetch IPDATA of IPSTREAM)) [COND ([AND XPOSITION (NOT (EQP XPOSITION (fetch IPXPOS of (fetch IPDATA of IPSTREAM] (SHOW.IP IPSTREAM T) (* (SETX.IP IPSTREAM XPOSITION)) (* ;; "Until our view of the printer's position is accurate, we can't rely on what we think the Xposition is, hence must be sure not to do a SETXREL.") (SETXY.IP IPSTREAM XPOSITION (fetch IPYPOS of (fetch IPDATA of IPSTREAM ])]) (\DSPROTATE.IP [LAMBDA (IPSTREAM ROTATION) (* hdj "12-Nov-85 12:16") (ROTATE.IP IPSTREAM ROTATION) (CONCATT.IP IPSTREAM]) (\PUSHSTATE.IP [LAMBDA (IPSTREAM) (* hdj " 3-Jan-86 11:10") (* ;;; "push a new context onto the stack") (LET ((XVar# (GETFRAMEVAR.IP IPSTREAM)) (YVar# (GETFRAMEVAR.IP IPSTREAM)) (State (IP-TOS IPSTREAM))) (replace (IPSTATE XPOS) of State with XVar#) (replace (IPSTATE YPOS) of State with YVar#) (* *) (GETCP.IP IPSTREAM) (FSET.IP IPSTREAM XVar#) (FSET.IP IPSTREAM YVar#) (* *) (SHOW.IP IPSTREAM) (PUSH-IP-STACK IPSTREAM (create IPSTATE)) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {]) (\POPSTATE.IP [LAMBDA (IPSTREAM) (* hdj " 3-Jan-86 11:10") (* ;;; "pop the current context") (SHOW.IP IPSTREAM) (APPENDOP.IP IPSTREAM }) (POP-IP-STACK IPSTREAM) (* ;; "restore X & Y pos") (LET ((State (IP-TOS IPSTREAM))) (FGET.IP IPSTREAM (fetch (IPSTATE XPOS) of State)) (FGET.IP IPSTREAM (fetch (IPSTATE YPOS) of State)) (APPENDOP.IP IPSTREAM SETXY]) (\DEFAULTSTATE.IP [LAMBDA (IPSTREAM) (* hdj "30-Dec-85 17:18") (* ;;; "establish meter coordinate system") (SCALE.IP IPSTREAM 1) (ISET.IP IPSTREAM CURRENTTRANS]) (\DSPTRANSLATE.IP [LAMBDA (IPSTREAM Tx Ty) (* hdj "12-Nov-85 12:22") (TRANSLATE.IP IPSTREAM Tx Ty) (CONCATT.IP IPSTREAM]) (\DSPSCALE2.IP [LAMBDA (IPSTREAM Sx Sy) (* hdj "12-Nov-85 12:23") (SCALE2.IP IPSTREAM Sx Sy) (CONCATT.IP IPSTREAM]) (\DSPYPOSITION.IP [LAMBDA (IPSTREAM YPOSITION) (* rmk%: "18-Jun-84 14:14") (PROG1 (fetch IPYPOS of (fetch IPDATA of IPSTREAM)) (COND (YPOSITION (SHOW.IP IPSTREAM) (SETY.IP IPSTREAM YPOSITION))))]) (FILLCIRCLE.IP [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:12 by FS") (* ;; "Interpress2.1 doesn't support ARCTO, so must either approximate a circle (as here), or scan convert it (e.g. CIRCSHADE.IP)") (* ;; "This code does not generate as nicely %"round%" circles as circshade.ip (the difference is visible to the naked eye). However, this code should be better for landscape printing, for code which uses pushstate/popstate, and for printers which scan in the X direction (e.g. Fuji Xerox XP-9), because it generates a simpler master.") (* ;; "Wimp out and display regular N-gon. For smaller circles, can use fewer points? Could also render two half circles (thus allowing twice the number of points since there are two trajectories), but what the heck.") (* ;; "Note also the clipping code isn't integrated with this (nor TRAJECTORY.IP, or others).") (FILLNGON.IP STREAM 90 RADIUS CENTERX CENTERY TEXTURE OPERATION]) (\FILLPOLYGON.IP [LAMBDA (STREAM POINTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 2-Feb-89 17:39 by FS") (* ;;; "INTERPRESS 2.1 (OSD) subset allows convex polygons.This routine not used in DIG due to convexity requirement, but provided for true interpress printers") (LET (NUMPATHS) (APPENDOP.IP STREAM DOSAVESIMPLEBODY) (* ;  "push state (because change color)") (APPENDOP.IP STREAM {) (SETCOLOR.IP STREAM TEXTURE OPERATION) (if (LISTP (CAAR POINTS)) then (* ;; "Multiple trajectories, put them out.") (SETQ NUMPATHS (LENGTH POINTS)) (FOR TRAJECTORY IN POINTS DO (TRAJECTORY.IP STREAM TRAJECTORY)) else (SETQ NUMPATHS 1) (TRAJECTORY.IP STREAM POINTS)) (APPENDINTEGER.IP STREAM NUMPATHS) (IF (EQ WINDNUMBER 0) THEN (APPENDOP.IP STREAM MAKEOUTLINE) ELSE (APPENDOP.IP STREAM MAKEOUTLINEODD)) (APPENDOP.IP STREAM MASKFILL) (APPENDOP.IP STREAM }]) (\DRAWPOLYGON.IP [LAMBDA (IPSTREAM POINTS CLOSED BRUSH DASHING) (* ; "Edited 8-Aug-88 15:11 by rmk:") (* ;; "draws a polygon on a interpress stream.") (COND (DASHING (* ;  "do dashing with the generic function until dashing is added to interpress standard.") (\DRAWPOLYGON.GENERIC IPSTREAM POINTS CLOSED BRUSH DASHING)) (T (* ;; "NEEDS TO WATCH OUT FOR MAX#SEGMENTS AND CLIPPING (SEE \IPCURVE2)") (PROG ((HALFWIDTH (FQUOTIENT (\WIDTHFROMBRUSH BRUSH MICASPERPOINT) 2)) (IPDATA (fetch IMAGEDATA of IPSTREAM)) (SEG# 0) IPXPOS IPYPOS LASTPT LEFT RIGHT BOTTOM TOP VISIBLEP PREVX PREVY) (* ;  "Arguments are assumed to be in micas.") (OR POINTS (RETURN)) (AND CLOSED (NULL (CDDR POINTS)) (SETQ CLOSED NIL)) (* ;  " Don't bother closing a straight line") (SETQ LEFT (+ (fetch IPVISLEFT of IPDATA) HALFWIDTH)) (SETQ RIGHT (- (fetch IPVISRIGHT of IPDATA) HALFWIDTH)) (SETQ BOTTOM (+ (fetch IPVISBOTTOM of IPDATA) HALFWIDTH)) (SETQ TOP (- (fetch IPVISTOP of IPDATA) HALFWIDTH)) (SETQ IPXPOS (fetch (POSITION XCOORD) of (CAR POINTS))) (SETQ IPYPOS (fetch (POSITION YCOORD) of (CAR POINTS))) (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) (SHOW.IP IPSTREAM) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (APPENDOP.IP IPSTREAM {) (if VISIBLEP then (MOVETO.IP IPSTREAM IPXPOS IPYPOS)) (for PTS on (CDR POINTS) do (COND ((IGREATERP (add SEG# 1) MAXSEGSPERTRAJECTORY) (* ;; "Our printers limit the number of segments in a single TRAJECTORY; make sure we respect their limitations") (\IMAGEPATH.IP BRUSH IPSTREAM) (SETQ SEG# 0) (MOVETO.IP IPSTREAM IPXPOS IPYPOS))) (SETQ PREVX IPXPOS) (SETQ PREVY IPYPOS) (SETQ IPXPOS (fetch (POSITION XCOORD) of (CAR PTS))) (SETQ IPYPOS (fetch (POSITION YCOORD) of (CAR PTS))) (if VISIBLEP then (if (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) then (* ;  "Super-common case: both ends visible, draw the line") (LINETO.IP IPSTREAM IPXPOS IPYPOS) else (* ; "Starts visible, goes out") (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM T IPSTREAM) (\IMAGEPATH.IP BRUSH IPSTREAM) (* ; "Curve is now invisible") (SETQ SEG# 0)) else (if (SETQ VISIBLEP (\VISIBLE.IP IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM)) then (* ;  " Starts invisible, comes in. MOVETO is done in \CLIPCURVELINE.IP") (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM NIL IPSTREAM) else (* ;  " Both ends invisible, could be visible in middle") (if (\CLIPCURVELINE.IP PREVX PREVY IPXPOS IPYPOS LEFT RIGHT TOP BOTTOM NIL IPSTREAM) then (* ;  " Drew a segment disconnected from rest of curve") (\IMAGEPATH.IP BRUSH IPSTREAM)) (SETQ SEG# 0) (* ;  "SEG# goes to 0 whenever we end up outside") )) (if (AND CLOSED (NULL (CDR PTS))) then (* ;  " fake a return to the beginning to close") (SETQ PTS (LIST NIL (CAR POINTS))) (SETQ CLOSED NIL))) (if VISIBLEP then (\SETBRUSH.IP IPSTREAM BRUSH) (* ;  "Only need to clean up if we're now inside") (* ; "FS- Unfortunately no OPER.") (\IMAGEPATH.IP BRUSH IPSTREAM)) (APPENDOP.IP IPSTREAM }) (SETXY.IP IPSTREAM IPXPOS IPYPOS]) (\FIXLINELENGTH.IP [LAMBDA (IPSTREAM) (* hdj "18-Oct-85 15:47") (* ;; "IPSTREAM is known to be a stream of type interpress. Called by RIGHTMARGIN LEFTMARGIN and \SFFIXFONT to update the LINELENGTH field in the stream. also called when the stream is created.") (PROG (LLEN (IPDATA (ffetch IMAGEDATA of IPSTREAM))) (freplace (STREAM LINELENGTH) of IPSTREAM with (COND ((IGREATERP [SETQ LLEN (FIXR (QUOTIENT (DIFFERENCE (ffetch IPRIGHT of IPDATA) (ffetch IPLEFT of IPDATA)) (ffetch FONTAVGCHARWIDTH of (ffetch IPFONT of IPDATA] 1) LLEN) (T 10]) (\MOVETO.IP [LAMBDA (IPSTREAM X Y) (* jds "11-Feb-86 14:47") (* ;;; "Do MOVETO for interpress streams") (SHOW.IP IPSTREAM T) (* ;  "First, close out what we had been doing.") (SETXY.IP IPSTREAM X Y]) (\SETBRUSH.IP [LAMBDA (IPSTREAM BRUSH OPERATION) (* ; "Edited 6-Aug-88 13:17 by rmk:") (* ;; "Sets the stroke shape parameters.") (* ;; "FS: I modified this function to simply call SETCOLOR.IP, since its probably the %"right%" thing to do. This function also should set the Operation, since e.g. \Drawline.ip never uses Operation and this is the place to do it.") (PROG (WIDTH SHAPE COLOR) [COND ((LISTP BRUSH) (SETQ SHAPE (CAR BRUSH)) (SETQ WIDTH (OR (CAR (LISTP (CDR BRUSH))) MICASPERPOINT))) (T (SETQ SHAPE 'ROUND) (SETQ WIDTH (OR BRUSH MICASPERPOINT] (APPENDNUMBER.IP IPSTREAM WIDTH) (ISET.IP IPSTREAM STROKEWIDTH) (APPENDNUMBER.IP IPSTREAM (SELECTQ SHAPE (ROUND ROUND) (SQUARE SQUARE) (BUTT BUTT) ROUND)) (ISET.IP IPSTREAM STROKEEND) (* ;; "This was the old code here, new code is below.") (* ;; " (if (AND (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH)) (STREAMPROP IPSTREAM 'COLOR)) then ; set the color (SETQ RGB (ENSURE.RGB COLOR)) (SETRGB.IP IPSTREAM (CAR RGB) (CADR RGB) (CADDR RGB)))") (SETQ COLOR (fetch (BRUSH BRUSHCOLOR) of BRUSH)) (* ;; "If no color provided, presumably a previous routine has set the DSPCOLOR.") (if COLOR then (IF (AND (NUMBERP COLOR) (<= 0 COLOR)) THEN (* ;;  "Avoid the conflict between textures and color numbers, for positive integers") NIL ELSE (SETCOLOR.IP IPSTREAM COLOR OPERATION]) (\STRINGWIDTH.IP [LAMBDA (STREAM STRING RDTBL) (* rmk%: "12-Apr-85 09:39") (* ;; "Returns the width of STRING in the interpress STREAM, observing spacefactor") (\STRINGWIDTH.GENERIC STRING (ffetch IPFONT of (ffetch IMAGEDATA of STREAM)) RDTBL (ffetch IPSPACEWIDTH of (ffetch IMAGEDATA of STREAM]) (\DSPCLIPPINGREGION.IP [LAMBDA (STREAM REGION) (* ; "Edited 21-Sep-88 21:20 by jds") (* ;; "Fetches and sets the clipping region field rather than the page region. Setting the clipping region also changes the visible region.") (LET ((IPDATA (fetch (STREAM IMAGEDATA) of STREAM))) (PROG1 (create REGION using (fetch (INTERPRESSDATA IPClippingRegion) of IPDATA)) (AND REGION (UNINTERRUPTABLY (replace (INTERPRESSDATA IPClippingRegion) of IPDATA with REGION) (\CHANGE-VISIBLE-REGION.IP IPDATA REGION) (* ; "Changed to NOT intersect it with the notional page frame, since that's not yet well-defined (you can't yet tell if you're printing landscape, e.g.)") (* ;; "OLD CODE: (\CHANGE-VISIBLE-REGION.IP IPDATA (INTERSECTREGIONS REGION (fetch (INTERPRESSDATA IPPAGEFRAME) of IPDATA)))") )))]) (\DSPOPERATION.IP [LAMBDA (IPSTREAM OPERATION) (* rrb " 6-Mar-86 16:16") (* ;  "sets the operation field of a interpress stream") (PROG ((IPDATA (ffetch IMAGEDATA of IPSTREAM))) (RETURN (PROG1 (ffetch (INTERPRESSDATA IPOPERATION) of IPDATA) [AND OPERATION (COND ((FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) (freplace (INTERPRESSDATA IPOPERATION) of IPDATA with OPERATION)) (T (\ILLEGAL.ARG OPERATION])]) ) (* ; "Patch controller for the %"Bonnet%" printer bug that loses X,Y position when you do a DSPFONT" ) (RPAQ? *INTERPRESS-PRINTER-DSPFONT-PATCH* NIL) (* ; "image state") (DEFINEQ (IP-TOS [LAMBDA (IPSTREAM) (* hdj "30-Dec-85 17:30") (LET [(STACK (STREAMPROP IPSTREAM 'STACK] (if STACK then (CAR STACK) else (ERROR "Stack is empty" IPSTREAM]) (POP-IP-STACK [LAMBDA (IPSTREAM) (* hdj "30-Dec-85 17:30") (LET [(STACK (STREAMPROP IPSTREAM 'STACK] (if STACK then (STREAMPROP IPSTREAM 'STACK (CDR STACK)) else (ERROR "Stack is empty" IPSTREAM]) (PUSH-IP-STACK [LAMBDA (IPSTREAM OBJECT) (* hdj "30-Dec-85 17:31") (STREAMPROP IPSTREAM 'STACK (CONS OBJECT (STREAMPROP IPSTREAM 'STACK]) ) (DECLARE%: EVAL@COMPILE (RECORD IPSTATE (XPOS YPOS)) ) (DEFINEQ (\CREATECHARSET.IP [LAMBDA (FAMILY PSIZE FACE ROTATION DEVICE CHARSET FONTDESC NOSLUG?) (* ; "Edited 8-Apr-88 09:54 by jds") (* ;;; "Build the CHARSETINFO for an Interpress NS font. If we can't find widths info for that font, return NIL") (* ;;; "Widths array is fully allocated, with zeroes for characters with no information. An array is not allocated for fixed WidthsY. DEVICE is PRESS or INTERPRESS") (DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES \ASCIITONS)) (RESETLST (* ;  "RESETLST to make sure the fontfiles get closed") (PROG (WFILE WSTRM FIXEDFLAGS RELFLAG FIRSTCHAR LASTCHAR TEM WIDTHS WIDTHSY FBBOX CHARSETHEIGHT (NSMICASIZE (FIXR (FQUOTIENT (ITIMES PSIZE 2540) 72))) (CSINFO (create CHARSETINFO))) (SETQ WIDTHS (fetch (CHARSETINFO WIDTHS) of CSINFO)) [COND ((SETQ WFILE (\FINDFONTFILE FAMILY PSIZE FACE NIL NIL CHARSET INTERPRESSFONTDIRECTORIES INTERPRESSFONTEXTENSIONS)) (* ;;; "Look thru INTERPRESSFONTDIRECTORIES for a file that describes the font requested. Only continue if we can find one.") [RESETSAVE (SETQ WSTRM (OPENSTREAM WFILE 'INPUT 'OLD)) '(PROGN (CLOSEF? OLDVALUE] [COND ((RANDACCESSP WSTRM) (SETFILEPTR WSTRM 0)) (T (COPYBYTES WSTRM (SETQ WSTRM (OPENSTREAM '{NODIRCORE} 'BOTH 'NEW] (SETQ RELFLAG (\POSITIONFONTFILE WSTRM NSMICASIZE FIRSTCHAR LASTCHAR NIL)) (* ;; "\POSITIONFONTFILE sets FIRSTCHAR LASTCHAR as well as positioning the font file at the beginning of the widths") (* ;; "Fill in the widths, and return a flag telling whether the widths are absolute, or are type-size relative. 0 => relative") ) (T (* ;  "Can't find a file to describe this font;") (RETURN (COND (NOSLUG? (* ;  "the caller just wants NIL back to signal that nothing was found") NIL) (T (\BUILDSLUGCSINFO (fetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONTDESC) (FONTPROP FONTDESC 'ASCENT) (FONTPROP FONTDESC 'DESCENT) (FONTPROP FONTDESC 'DEVICE] (SETQ RELFLAG (ZEROP RELFLAG)) (* ;  "Convert the flag to a logical value") (SETFILEPTR WSTRM (UNFOLD (\FIXPIN WSTRM) BYTESPERWORD)) (* ;; "Read the location of the WD segment for this font (we're in the directory part of the file now), and go there.") (SETQ FBBOX (SIGNED (\WIN WSTRM) BITSPERWORD)) (* ;  "replace (FONTDESCRIPTOR FBBOX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ;  "Get the max bounding width for the font") (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (IMINUS (SIGNED (\WIN WSTRM) BITSPERWORD))) (* ; "Descent is -FBBOY") (\WIN WSTRM) (* ;  "replace (FONTDESCRIPTOR FBBDX) of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ; "And the standard kern value (?)") (SETQ CHARSETHEIGHT (SIGNED (\WIN WSTRM) BITSPERWORD)) (* ;  "replace \SFHeight of FD with (SIGNED (\WIN WSTRM) BITSPERWORD)") (* ; "Height is FBBDY") [COND (RELFLAG (* ;  "Dimensions are relative, must be scaled") (* ;; "replace (FONTDESCRIPTOR FBBOX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBOX) of FD) NSMICASIZE) 1000)") (replace (CHARSETINFO CHARSETDESCENT) of CSINFO with (IQUOTIENT (ITIMES (fetch (CHARSETINFO CHARSETDESCENT) of CSINFO) NSMICASIZE) 1000)) (* ;; "replace (FONTDESCRIPTOR FBBDX) of FD with (IQUOTIENT (ITIMES (fetch (FONTDESCRIPTOR FBBDX) of FD) NSMICASIZE) 1000)") (SETQ CHARSETHEIGHT (IQUOTIENT (ITIMES CHARSETHEIGHT NSMICASIZE) 1000] (replace (CHARSETINFO CHARSETASCENT) of CSINFO with (IDIFFERENCE CHARSETHEIGHT (fetch CHARSETDESCENT of CSINFO))) (SETQ FIXEDFLAGS (LRSH (\BIN WSTRM) 6)) (* ; "The fixed flags") (\BIN WSTRM) (* ; "Skip the spares") [COND ((EQ 2 (LOGAND FIXEDFLAGS 2)) (* ; "This font is fixed width.") (SETQ TEM (\WIN WSTRM)) (* ;  "Read the fixed width for this font") [COND ((AND RELFLAG (NOT (ZEROP TEM))) (* ;  "If it's size relative, scale it.") (SETQ TEM (IQUOTIENT (ITIMES TEM NSMICASIZE) 1000] (for I from FIRSTCHAR to LASTCHAR do (* ;  "Fill in the char widths table with the width.") (\FSETWIDTH WIDTHS I TEM))) (T (* ;  "Variable width font, so we have to read widths.") (* ;  "AIN WIDTHS FIRSTCHAR (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) WSTRM") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I noInfoCode)) [\BINS (\GETOFD WSTRM 'INPUT) WIDTHS (UNFOLD FIRSTCHAR BYTESPERWORD) (IMIN (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) BYTESPERWORD) (IDIFFERENCE (GETFILEINFO WSTRM 'LENGTH) (GETFILEPTR WSTRM] (* ; "Read the X widths.") (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHS I)) do (* ;  "For chars that have no width info, let width be zero.") (\FSETWIDTH WIDTHS I 0)) (COND (RELFLAG (* ;  "If the widths are size-relative, scale them.") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHS I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHS I) NSMICASIZE) 1000] [COND [(EQ 1 (LOGAND FIXEDFLAGS 1)) (COND ((ILESSP (GETFILEPTR WSTRM) (GETEOFPTR WSTRM)) (SETQ WIDTHSY (\WIN WSTRM))) (T (* ;  "STAR FONT FILES LIKE TO LEAVE OFF THE Y WIDTH.") (SETQ WIDTHSY 0))) (* ;  "The fixed width-Y for this font; the width-Y field is a single integer in the FD") (replace (CHARSETINFO YWIDTHS) of CSINFO with (COND ((AND RELFLAG (NOT (ZEROP WIDTHSY))) (IQUOTIENT (ITIMES WIDTHSY NSMICASIZE) 1000)) (T WIDTHSY] (T (* ;  "Variable Y-width font. Fill it in as above") (SETQ WIDTHSY (replace (CHARSETINFO YWIDTHS) of CSINFO with ( \CREATECSINFOELEMENT ))) (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I noInfoCode)) (\BINS (\GETOFD WSTRM 'INPUT) WIDTHSY (UNFOLD FIRSTCHAR BYTESPERWORD) (UNFOLD (ADD1 (IDIFFERENCE LASTCHAR FIRSTCHAR)) BYTESPERWORD)) (* ; "Read the Y widths") (for I from FIRSTCHAR to LASTCHAR when (EQ noInfoCode (\FGETWIDTH WIDTHSY I)) do (* ;  "Let any characters with no width info be zero height") (\FSETWIDTH WIDTHSY I 0)) (COND (RELFLAG (* ;  "If the widths are size-relative, scale them.") (for I from FIRSTCHAR to LASTCHAR do (\FSETWIDTH WIDTHSY I (IQUOTIENT (ITIMES (\FGETWIDTH WIDTHSY I) NSMICASIZE) 1000] (RETURN CSINFO)))]) (\CHANGECHARSET.IP [LAMBDA (IPDATA CHARSET) (* gbn " 1-Oct-85 17:45") (* ;; "Called when the character set information cached in a display stream doesn't correspond to CHARSET") (PROG* ((FONT (ffetch IPFONT of IPDATA)) (CSINFO (\GETCHARSETINFO CHARSET FONT))) (* ;; "since the call to \getcharsetinfo has NOSLUG? = NIL, we know that we will get a reasonable character set back") (UNINTERRUPTABLY (freplace IPWIDTHSCACHE of IPDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO)) (freplace NSCHARSET of IPDATA with CHARSET))]) ) (DEFINEQ (\INTERPRESSINIT [LAMBDA NIL (* ; "Edited 9-Dec-88 11:49 by jds") (DECLARE (GLOBALVARS \IPIMAGEOPS \ASCIITONS \ASCIITOSTAR)) (SETQ \IPIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'INTERPRESS IMCLOSEFN _ (FUNCTION \CLOSEIPSTREAM) IMXPOSITION _ (FUNCTION \DSPXPOSITION.IP) IMYPOSITION _ (FUNCTION \DSPYPOSITION.IP) IMFONT _ (FUNCTION \DSPFONT.IP) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.IP) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.IP) IMLINEFEED _ (FUNCTION \DSPLINEFEED.IP) IMDRAWLINE _ (FUNCTION \DRAWLINE.IP) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.IP) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.GENERIC) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.GENERIC) IMFILLCIRCLE _ (FUNCTION CIRCSHADE.IP) IMBLTSHADE _ (FUNCTION \BLTSHADE.IP) IMBITBLT _ (FUNCTION \BITBLT.IP) IMNEWPAGE _ (FUNCTION NEWPAGE.IP) IMMOVETO _ (FUNCTION \MOVETO.IP) IMSCALE _ [FUNCTION (LAMBDA NIL (* ;  "should this be a ratio instead of a float?") (CONSTANT (FQUOTIENT MICASPERINCH POINTSPERINCH] IMTERPRI _ (FUNCTION NEWLINE.IP) IMBOTTOMMARGIN _ (FUNCTION \DSPBOTTOMMARGIN.IP) IMTOPMARGIN _ (FUNCTION \DSPTOPMARGIN.IP) IMFONTCREATE _ 'INTERPRESS IMSPACEFACTOR _ (FUNCTION \DSPSPACEFACTOR.IP) IMCOLOR _ (FUNCTION \DSPCOLOR.IP) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.IP) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.IP) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.IP) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.IP) IMFILLPOLYGON _ (FUNCTION POLYSHADE.IP) IMDRAWARC _ (FUNCTION \DRAWARC.IP) IMPUSHSTATE _ (FUNCTION \PUSHSTATE.IP) IMPOPSTATE _ (FUNCTION \POPSTATE.IP) IMROTATE _ (FUNCTION \DSPROTATE.IP) IMSCALE2 _ (FUNCTION \DSPSCALE2.IP) IMTRANSLATE _ (FUNCTION \DSPTRANSLATE.IP) IMDEFAULTSTATE _ (FUNCTION \DEFAULTSTATE.IP) IMOPERATION _ (FUNCTION \DSPOPERATION.IP) IMBITMAPSIZE _ (FUNCTION \BITMAPSIZE.IP) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.IP) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.IP))) (* ;; "FS: Removed left arrow mapping - (%"_%" 0 172)") (* ;; " JDS: Removed old bullet mapping (183 239 102)") (LET [(MAPPINGS '(("-" 33 62) ("^" 0 173) ("$" 0 164) ("^N" 0 197) ("^S" 239 37) ("^V" 239 36) ("^X" 0 45) ("^O" 239 45) ("^\" 239 44) ("^Y" 239 46) ("^D" 0 200) ("^G" 0 169) ("^H" 0 161) ("^B" 0 191) (96 0 185) (155 239 36) (156 239 37) ("^^" 0 184] (* ;; "Translation table for standard ascii to NS. Last 5 are backquote, en dash, em dash, bullet, and finally the %"backward compatible%" package delimiter, rendered as the divide sign.") (SETQ \ASCIITONS (NSMAP NIL MAPPINGS)) (* ;  "Map from ASCII to printer character code (XC1-1-1 NS Encoding standard)") (SETQ \ASCIITOSTAR (NSMAP NIL (CDR MAPPINGS))) (* ;; "Map from ASCII to wedged OSD screen & .WD file character coding (alleged to be XC2-x-x, soon to come). The difference is that `-' maps to itself for width purposes.") ) NIL]) ) (DEFINEQ (SCALEREGION [LAMBDA (SCALE REGION) (* rmk%: "21-JUL-82 13:06") (* ; "Scales a region") (create REGION LEFT _ (FIX (FTIMES SCALE (fetch (REGION LEFT) of REGION))) BOTTOM _ (FIX (FTIMES SCALE (fetch (REGION BOTTOM) of REGION))) WIDTH _ (FIX (FTIMES SCALE (fetch (REGION WIDTH) of REGION))) HEIGHT _ (FIX (FTIMES SCALE (fetch (REGION HEIGHT) of REGION]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? \SPLINESTEP.IP 16.0) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? IPPAGEREGION.ROT180 NIL) (RPAQ? IPPAGEREGION.ROT270 NIL) (RPAQ? DEFAULTPAGEREGION (SCALEREGION 2540 (CREATEREGION 1.1 0.75 (- 7.5 1.1) (- 10.5 0.75)))) (RPAQ? DEFAULTLANDPAGEREGION (SCALEREGION 2540 (CREATEREGION 0.75 1.1 (- 10.5 0.75) (- 7.5 1.1)))) ) (* ; "Interpress encoding values") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ MAXSEGSPERTRAJECTORY 100) (CONSTANTS MAXSEGSPERTRAJECTORY) ) (RPAQQ NONPRIMS ((BEGINMASTER 102) (ENDMASTER 103) (PAGEINSTRUCTIONS 105) ({ 106) (} 107))) (DECLARE%: EVAL@COMPILE (RPAQQ BEGINMASTER 102) (RPAQQ ENDMASTER 103) (RPAQQ PAGEINSTRUCTIONS 105) (RPAQQ { 106) (RPAQQ } 107) (CONSTANTS (BEGINMASTER 102) (ENDMASTER 103) (PAGEINSTRUCTIONS 105) ({ 106) (} 107)) ) (RPAQQ SEQUENCETYPES ((SEQADAPTIVEPIXELVECTOR 12) (SEQCOMMENT 6) (SEQCOMPRESSPIXELVECTOR 10) (SEQCONTINUED 7) (SEQIDENTIFIER 5) (SEQINSERTFILE 11) (SEQINTEGER 2) (SEQLARGEVECTOR 8) (SEQPACKEDPIXELVECTOR 9) (SEQRATIONAL 4) (SEQSTRING 1))) (DECLARE%: EVAL@COMPILE (RPAQQ SEQADAPTIVEPIXELVECTOR 12) (RPAQQ SEQCOMMENT 6) (RPAQQ SEQCOMPRESSPIXELVECTOR 10) (RPAQQ SEQCONTINUED 7) (RPAQQ SEQIDENTIFIER 5) (RPAQQ SEQINSERTFILE 11) (RPAQQ SEQINTEGER 2) (RPAQQ SEQLARGEVECTOR 8) (RPAQQ SEQPACKEDPIXELVECTOR 9) (RPAQQ SEQRATIONAL 4) (RPAQQ SEQSTRING 1) (CONSTANTS (SEQADAPTIVEPIXELVECTOR 12) (SEQCOMMENT 6) (SEQCOMPRESSPIXELVECTOR 10) (SEQCONTINUED 7) (SEQIDENTIFIER 5) (SEQINSERTFILE 11) (SEQINTEGER 2) (SEQLARGEVECTOR 8) (SEQPACKEDPIXELVECTOR 9) (SEQRATIONAL 4) (SEQSTRING 1)) ) (RPAQQ IPTYPES ((COLOR.IPTYPE 7) (IDENTIFIER.IPTYPE 2) (NUMBER.IPTYPE 1) (OPERATOR.IPTYPE 4) (OUTLINE.IPTYPE 9) (PIXELARRAY.IPTYPE 6) (TRAJECTORY.IPTYPE 8) (TRANSFORMATION.IPTYPE 5) (VECTOR.IPTYPE 3))) (DECLARE%: EVAL@COMPILE (RPAQQ COLOR.IPTYPE 7) (RPAQQ IDENTIFIER.IPTYPE 2) (RPAQQ NUMBER.IPTYPE 1) (RPAQQ OPERATOR.IPTYPE 4) (RPAQQ OUTLINE.IPTYPE 9) (RPAQQ PIXELARRAY.IPTYPE 6) (RPAQQ TRAJECTORY.IPTYPE 8) (RPAQQ TRANSFORMATION.IPTYPE 5) (RPAQQ VECTOR.IPTYPE 3) (CONSTANTS (COLOR.IPTYPE 7) (IDENTIFIER.IPTYPE 2) (NUMBER.IPTYPE 1) (OPERATOR.IPTYPE 4) (OUTLINE.IPTYPE 9) (PIXELARRAY.IPTYPE 6) (TRAJECTORY.IPTYPE 8) (TRANSFORMATION.IPTYPE 5) (VECTOR.IPTYPE 3)) ) (RPAQQ OPERATORS ((ABS 200) (ADD 201) (AND 202) (ARCTO 403) (CEILING 203) (CLIPRECTANGLE 419) (CONCAT 165) (CONCATT 168) (COPY 183) (CORRECT 110) (CORRECTMASK 156) (CORRECTSPACE 157) (COUNT 188) (DIV 204) (DO 231) (DOSAVE 232) (DOSAVEALL 233) (DOSAVESIMPLEBODY 120) (DUP 181) (EQ 205) (ERROR.IPOP 600) (EXCH 185) (FGET 20) (FINDCOLOR 423) (FINDCOLORMODELOPERATOR 422) (FINDCOLOROPERATOR 421) (FINDDECOMPRESSOR 149) (FINDFONT 147) (FLOOR 206) (FSET 21) (GE 207) (GETCP 159) (GETPROP 287) (GT 208) (IF 239) (IFCOPY 240) (IFELSE 241) (IGET 18) (ISET 19) (LINETO 23) (LINETOX 14) (LINETOY 15) (MAKEGRAY 425) (MAKEOUTLINE 417) (MAKEOUTLINEODD 416) (MAKEPIXELARRAY 450) (MAKESAMPLEDBLACK 426) (MAKESAMPLEDCOLOR 427) (MAKESIMPLECO 114) (MAKEPIXELARRAY 450) (MAKEVEC 283) (MAKEVECLU 282) (MARK 186) (MASKFILL 409) (MASKPIXEL 452) (MASKRECTANGLE 410) (MASKSTROKE 24) (MASKTRAPEZOIDX 411) (MASKTRAPEZOIDY 412) (MASKUNDERLINE 414) (MASKVECTOR 441) (MERGEPROP 288) (MOD 209) (MODIFYFONT 148) (MOVE 169) (MOVETO 25) (MUL 210) (NEG.IPOP 211) (NOP 1) (NOT 212) (OR 213) (POP 180) (REM 216) (ROLL 184) (ROTATE 163) (ROUND.IPOP 217) (SCALE.OP 164) (SCALE2 166) (SETCORRECTMEASURE 154) (SETCORRECTTOLERANCE 155) (SETFONT 151) (SETGRAY 424) (SETXREL 12) (SETXY 10) (SETXYREL 11) (SETYREL 13) (SHAPE.IPOP 285) (SHOW 22) (SHOWANDXREL 146) (SPACE 16) (STARTUNDERLINE 413) (SUB 214) (TRANS.IPOP 170) (TRANSLATE 162) (TRUNC 215) (TYPE.OP 220) (UNMARK 187) (UNMARK0 192))) (DECLARE%: EVAL@COMPILE (RPAQQ ABS 200) (RPAQQ ADD 201) (RPAQQ AND 202) (RPAQQ ARCTO 403) (RPAQQ CEILING 203) (RPAQQ CLIPRECTANGLE 419) (RPAQQ CONCAT 165) (RPAQQ CONCATT 168) (RPAQQ COPY 183) (RPAQQ CORRECT 110) (RPAQQ CORRECTMASK 156) (RPAQQ CORRECTSPACE 157) (RPAQQ COUNT 188) (RPAQQ DIV 204) (RPAQQ DO 231) (RPAQQ DOSAVE 232) (RPAQQ DOSAVEALL 233) (RPAQQ DOSAVESIMPLEBODY 120) (RPAQQ DUP 181) (RPAQQ EQ 205) (RPAQQ ERROR.IPOP 600) (RPAQQ EXCH 185) (RPAQQ FGET 20) (RPAQQ FINDCOLOR 423) (RPAQQ FINDCOLORMODELOPERATOR 422) (RPAQQ FINDCOLOROPERATOR 421) (RPAQQ FINDDECOMPRESSOR 149) (RPAQQ FINDFONT 147) (RPAQQ FLOOR 206) (RPAQQ FSET 21) (RPAQQ GE 207) (RPAQQ GETCP 159) (RPAQQ GETPROP 287) (RPAQQ GT 208) (RPAQQ IF 239) (RPAQQ IFCOPY 240) (RPAQQ IFELSE 241) (RPAQQ IGET 18) (RPAQQ ISET 19) (RPAQQ LINETO 23) (RPAQQ LINETOX 14) (RPAQQ LINETOY 15) (RPAQQ MAKEGRAY 425) (RPAQQ MAKEOUTLINE 417) (RPAQQ MAKEOUTLINEODD 416) (RPAQQ MAKEPIXELARRAY 450) (RPAQQ MAKESAMPLEDBLACK 426) (RPAQQ MAKESAMPLEDCOLOR 427) (RPAQQ MAKESIMPLECO 114) (RPAQQ MAKEPIXELARRAY 450) (RPAQQ MAKEVEC 283) (RPAQQ MAKEVECLU 282) (RPAQQ MARK 186) (RPAQQ MASKFILL 409) (RPAQQ MASKPIXEL 452) (RPAQQ MASKRECTANGLE 410) (RPAQQ MASKSTROKE 24) (RPAQQ MASKTRAPEZOIDX 411) (RPAQQ MASKTRAPEZOIDY 412) (RPAQQ MASKUNDERLINE 414) (RPAQQ MASKVECTOR 441) (RPAQQ MERGEPROP 288) (RPAQQ MOD 209) (RPAQQ MODIFYFONT 148) (RPAQQ MOVE 169) (RPAQQ MOVETO 25) (RPAQQ MUL 210) (RPAQQ NEG.IPOP 211) (RPAQQ NOP 1) (RPAQQ NOT 212) (RPAQQ OR 213) (RPAQQ POP 180) (RPAQQ REM 216) (RPAQQ ROLL 184) (RPAQQ ROTATE 163) (RPAQQ ROUND.IPOP 217) (RPAQQ SCALE.OP 164) (RPAQQ SCALE2 166) (RPAQQ SETCORRECTMEASURE 154) (RPAQQ SETCORRECTTOLERANCE 155) (RPAQQ SETFONT 151) (RPAQQ SETGRAY 424) (RPAQQ SETXREL 12) (RPAQQ SETXY 10) (RPAQQ SETXYREL 11) (RPAQQ SETYREL 13) (RPAQQ SHAPE.IPOP 285) (RPAQQ SHOW 22) (RPAQQ SHOWANDXREL 146) (RPAQQ SPACE 16) (RPAQQ STARTUNDERLINE 413) (RPAQQ SUB 214) (RPAQQ TRANS.IPOP 170) (RPAQQ TRANSLATE 162) (RPAQQ TRUNC 215) (RPAQQ TYPE.OP 220) (RPAQQ UNMARK 187) (RPAQQ UNMARK0 192) (CONSTANTS (ABS 200) (ADD 201) (AND 202) (ARCTO 403) (CEILING 203) (CLIPRECTANGLE 419) (CONCAT 165) (CONCATT 168) (COPY 183) (CORRECT 110) (CORRECTMASK 156) (CORRECTSPACE 157) (COUNT 188) (DIV 204) (DO 231) (DOSAVE 232) (DOSAVEALL 233) (DOSAVESIMPLEBODY 120) (DUP 181) (EQ 205) (ERROR.IPOP 600) (EXCH 185) (FGET 20) (FINDCOLOR 423) (FINDCOLORMODELOPERATOR 422) (FINDCOLOROPERATOR 421) (FINDDECOMPRESSOR 149) (FINDFONT 147) (FLOOR 206) (FSET 21) (GE 207) (GETCP 159) (GETPROP 287) (GT 208) (IF 239) (IFCOPY 240) (IFELSE 241) (IGET 18) (ISET 19) (LINETO 23) (LINETOX 14) (LINETOY 15) (MAKEGRAY 425) (MAKEOUTLINE 417) (MAKEOUTLINEODD 416) (MAKEPIXELARRAY 450) (MAKESAMPLEDBLACK 426) (MAKESAMPLEDCOLOR 427) (MAKESIMPLECO 114) (MAKEPIXELARRAY 450) (MAKEVEC 283) (MAKEVECLU 282) (MARK 186) (MASKFILL 409) (MASKPIXEL 452) (MASKRECTANGLE 410) (MASKSTROKE 24) (MASKTRAPEZOIDX 411) (MASKTRAPEZOIDY 412) (MASKUNDERLINE 414) (MASKVECTOR 441) (MERGEPROP 288) (MOD 209) (MODIFYFONT 148) (MOVE 169) (MOVETO 25) (MUL 210) (NEG.IPOP 211) (NOP 1) (NOT 212) (OR 213) (POP 180) (REM 216) (ROLL 184) (ROTATE 163) (ROUND.IPOP 217) (SCALE.OP 164) (SCALE2 166) (SETCORRECTMEASURE 154) (SETCORRECTTOLERANCE 155) (SETFONT 151) (SETGRAY 424) (SETXREL 12) (SETXY 10) (SETXYREL 11) (SETYREL 13) (SHAPE.IPOP 285) (SHOW 22) (SHOWANDXREL 146) (SPACE 16) (STARTUNDERLINE 413) (SUB 214) (TRANS.IPOP 170) (TRANSLATE 162) (TRUNC 215) (TYPE.OP 220) (UNMARK 187) (UNMARK0 192)) ) (RPAQQ TOKENFORMATS ((SHORTOP 128) (LONGOP 160) (SHORTNUMBER 0) (SHORTSEQUENCE 192) (LONGSEQUENCE 224))) (DECLARE%: EVAL@COMPILE (RPAQQ SHORTOP 128) (RPAQQ LONGOP 160) (RPAQQ SHORTNUMBER 0) (RPAQQ SHORTSEQUENCE 192) (RPAQQ LONGSEQUENCE 224) (CONSTANTS (SHORTOP 128) (LONGOP 160) (SHORTNUMBER 0) (SHORTSEQUENCE 192) (LONGSEQUENCE 224)) ) (RPAQQ IMAGERVARIABLES ((DCSCPX 0) (DCSCPY 1) (CORRECTMX 2) (CORRECTMY 3) (CURRENTTRANS 4) (PRIORITYIMPORTANT 5) (MEDIUMXSIZE 6) (MEDIUMYSIZE 7) (FIELDXMIN 8) (FIELDYMIN 9) (FIELDXMAX 10) (FIELDYMAX 11) (SHOWVEC 12) (COLOR.IMVAR 13) (NOIMAGE 14) (STROKEWIDTH 15) (STROKEEND 16) (UNDERLINESTART 17) (AMPLIFYSPACE 18) (CORRECTPASS 19) (CORRECTSHRINK 20) (CORRECTTX 21) (CORRECTTY 22))) (DECLARE%: EVAL@COMPILE (RPAQQ DCSCPX 0) (RPAQQ DCSCPY 1) (RPAQQ CORRECTMX 2) (RPAQQ CORRECTMY 3) (RPAQQ CURRENTTRANS 4) (RPAQQ PRIORITYIMPORTANT 5) (RPAQQ MEDIUMXSIZE 6) (RPAQQ MEDIUMYSIZE 7) (RPAQQ FIELDXMIN 8) (RPAQQ FIELDYMIN 9) (RPAQQ FIELDXMAX 10) (RPAQQ FIELDYMAX 11) (RPAQQ SHOWVEC 12) (RPAQQ COLOR.IMVAR 13) (RPAQQ NOIMAGE 14) (RPAQQ STROKEWIDTH 15) (RPAQQ STROKEEND 16) (RPAQQ UNDERLINESTART 17) (RPAQQ AMPLIFYSPACE 18) (RPAQQ CORRECTPASS 19) (RPAQQ CORRECTSHRINK 20) (RPAQQ CORRECTTX 21) (RPAQQ CORRECTTY 22) (CONSTANTS (DCSCPX 0) (DCSCPY 1) (CORRECTMX 2) (CORRECTMY 3) (CURRENTTRANS 4) (PRIORITYIMPORTANT 5) (MEDIUMXSIZE 6) (MEDIUMYSIZE 7) (FIELDXMIN 8) (FIELDYMIN 9) (FIELDXMAX 10) (FIELDYMAX 11) (SHOWVEC 12) (COLOR.IMVAR 13) (NOIMAGE 14) (STROKEWIDTH 15) (STROKEEND 16) (UNDERLINESTART 17) (AMPLIFYSPACE 18) (CORRECTPASS 19) (CORRECTSHRINK 20) (CORRECTTX 21) (CORRECTTY 22)) ) (RPAQQ STROKEENDS ((SQUARE 0) (BUTT 1) (ROUND 2))) (DECLARE%: EVAL@COMPILE (RPAQQ SQUARE 0) (RPAQQ BUTT 1) (RPAQQ ROUND 2) (CONSTANTS (SQUARE 0) (BUTT 1) (ROUND 2)) ) (RPAQQ IP82CONSTANTS ((BEGINPREAMBLE {) (ENDPREAMBLE }) (BEGINPAGE {) (ENDPAGE }) (ENCODINGSTRING "Interpress/Xerox/1.0 ") (NOVERSIONENCODINGSTRING "Interpress/Xerox/") (MAXLONGSEQUENCEBYTES (SUB1 (EXPT 2 16))) (FILETYPE.INTERPRESS 4361))) (DECLARE%: EVAL@COMPILE (RPAQ BEGINPREAMBLE {) (RPAQ ENDPREAMBLE }) (RPAQ BEGINPAGE {) (RPAQ ENDPAGE }) (RPAQ ENCODINGSTRING "Interpress/Xerox/1.0 ") (RPAQ NOVERSIONENCODINGSTRING "Interpress/Xerox/") (RPAQ MAXLONGSEQUENCEBYTES (SUB1 (EXPT 2 16))) (RPAQQ FILETYPE.INTERPRESS 4361) (CONSTANTS (BEGINPREAMBLE {) (ENDPREAMBLE }) (BEGINPAGE {) (ENDPAGE }) (ENCODINGSTRING "Interpress/Xerox/1.0 ") (NOVERSIONENCODINGSTRING "Interpress/Xerox/") (MAXLONGSEQUENCEBYTES (SUB1 (EXPT 2 16))) (FILETYPE.INTERPRESS 4361)) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS APPENDBYTE.IP DMACRO (= . \BOUT)) (PUTPROPS APPENDOP.IP MACRO [OPENLAMBDA (STREAM OP) (COND ((CONSTANT (OR (ILESSP OP 0) (IGREATERP OP 8191))) (ERROR "Invalid Interpress operator code:" OP))) (COND ((CONSTANT (ILEQ OP 31)) (APPENDBYTE.IP STREAM (LOGOR SHORTOP OP))) (T (APPENDBYTE.IP STREAM (LOGOR LONGOP (FOLDLO OP 256))) (APPENDBYTE.IP STREAM (MOD OP 256]) (PUTPROPS .IPFONTNAME. DMACRO ((FAMILY) (SELECTQ FAMILY (TIMESROMAN 'CLASSIC) (HELVETICA 'MODERN) (LOGO 'LOGOTYPES) (GACHA 'TERMINAL) FAMILY))) (PUTPROPS APPENDINT.IPMACRO MACRO [OPENLAMBDA (STREAM NUM LENGTH) (for I from (SUB1 LENGTH) to 0 by -1 do (APPENDBYTE.IP STREAM (LOADBYTE NUM (UNFOLD I BITSPERBYTE) BITSPERBYTE]) (PUTPROPS APPENDINTEGER.IPMACRO MACRO [OPENLAMBDA (STREAM N) (COND ((AND (ILEQ -4000 N) (ILEQ N 28767)) (APPENDINT.IPMACRO STREAM (IPLUS N 4000) 2)) (T (PROG ((LEN (BYTESININT.IP N))) (APPENDSEQUENCEDESCRIPTOR.IP STREAM SEQINTEGER LEN) (APPENDINT.IP STREAM N LEN]) (PUTPROPS \IMAGEPATH.IP MACRO ((BRUSH STREAM OPERATION) (\SETBRUSH.IP IPSTREAM BRUSH OPERATION) (MASKSTROKE.IP IPSTREAM))) (PUTPROPS \WIDTHFROMBRUSH MACRO ((BRUSH DEFAULT) (* ;  "Extracts width from brush, defaulting to DEFAULT for unrecognized values") (COND [(LISTP BRUSH) (CAR (LISTP (CDR BRUSH] ((NUMBERP BRUSH) BRUSH) (T DEFAULT)))) (PUTPROPS \VISIBLE.IP MACRO (OPENLAMBDA (X Y LEFT RIGHT TOP BOTTOM) (* ;  " T if the point X,Y is inside the specified region") (AND (IGEQ X LEFT) (ILEQ X RIGHT) (IGEQ Y BOTTOM) (ILEQ Y TOP)))) ) (DECLARE%: EVAL@COMPILE (RECORD IPSTREAM STREAM (SUBRECORD STREAM) [ACCESSFNS ((IPDATA (fetch (STREAM IMAGEDATA) of DATUM) (replace (STREAM IMAGEDATA) of DATUM with NEWVALUE)) (SHOWSTREAM (fetch (IPSTREAM IPDATA) of DATUM) (replace (IPSTREAM IPDATA) of DATUM with NEWVALUE] (TYPE? (type? INTERPRESSDATA of (fetch (STREAM IMAGEDATA) of DATUM)))) (DATATYPE INTERPRESSDATA (IPHEADING IPHEADINGFONT (IPXPOS POINTER) (IPYPOS POINTER) IPFONT IPPREAMBLEFONTS IPPAGEFONTS IPWIDTHSCACHE IPCOLOR (IPLINEFEED POINTER) IPPAGESTATE IPSHOWSTREAM IPPAGEREGION IPDOCNAME (IPLEFT POINTER) (IPBOTTOM POINTER) (IPRIGHT POINTER) (IPTOP POINTER) (IPPAGENUM WORD) (IPPREAMBLENEXTFRAMEVAR BYTE) (IPNEXTFRAMEVAR BYTE) (IPHEADINGOPVAR BYTE) (NSCHARSET BYTE) (NSTRANSTABLE POINTER) (IPCORRECTSTARTX POINTER (* ;  "Used with IPXPOS to compute width for CORRECTing char strings during SHOW.") ) (IPSPACEFACTOR POINTER) (IPSPACEWIDTH POINTER) (* ;  "cached width of space, taking space factor into account") (IPROTATION POINTER) (* ; "Default rotation in which this document is to be printed: Set up witn ROTATE and CONCATT at the start of each new page.") (IPXOFFSET POINTER) (* ;  "Default X offset, akin to the rotation. Used to do landscape printing") (IPYOFFSET POINTER) (* ; "Default Y offset.") (IPClippingRegion POINTER) (* ;  "Clipping region, intersected with pageframe to determine the visible region") (IPCOLORMODEL WORD) (* ;  "preamble fvar in which we have stored the color model we are using (for post-IP 2.1 ONLY)") (IPOPERATION POINTER) (* ;  "used to keep the current operation mode PAINT, REPLACE, ERASE or INVERT.") (IPVISLEFT POINTER) (* ; "Boundaries of stream's visible region, namely, the intersection of the clipping region and the page frame") (IPVISRIGHT POINTER) (IPVISTOP POINTER) (IPVISBOTTOM POINTER) (IPPAGEFRAME POINTER) (* ; "The physical page size as a mica region, can't be changed in midstream. Used to determine the visible region") (IPMAXVISIBLEBASELINE POINTER) (* ;  "The cached maximum character baseline for the current visible page region") (IPMINVISIBLEBASELINE POINTER) (* ;  "The cached minimum character baseline for the current visible page region") (IPVISIBLEREGION POINTER) (* ;  "Region corresponding to IPVISLEFT etc., to be passed to clipping functions") (IPCHARVISIBLEP POINTER) (* ; "True if current pos is inside character clipping region, reset when X,Y is changed or font is changed") (IPMINCHARRIGHT POINTER) (* ; "Min of right margin and clipping right, special tests needed only if new position is beyond this. Reset when margin or clipping region is changed") (IPCLIPINCLUSIVE POINTER) (* ; "True if page should include characters that cross the right or bottom edges of the clipping region") ) IPXPOS _ 0 IPYPOS _ 0 IPNEXTFRAMEVAR _ 0 IPSPACEFACTOR _ 1 IPROTATION _ 0 IPXOFFSET _ 0 IPYOFFSET _ 0 IPCOLORMODEL _ 0 IPOPERATION _ 'PAINT IPCLIPINCLUSIVE _ NIL) ) (/DECLAREDATATYPE 'INTERPRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD BYTE BYTE BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((INTERPRESSDATA 0 POINTER) (INTERPRESSDATA 2 POINTER) (INTERPRESSDATA 4 POINTER) (INTERPRESSDATA 6 POINTER) (INTERPRESSDATA 8 POINTER) (INTERPRESSDATA 10 POINTER) (INTERPRESSDATA 12 POINTER) (INTERPRESSDATA 14 POINTER) (INTERPRESSDATA 16 POINTER) (INTERPRESSDATA 18 POINTER) (INTERPRESSDATA 20 POINTER) (INTERPRESSDATA 22 POINTER) (INTERPRESSDATA 24 POINTER) (INTERPRESSDATA 26 POINTER) (INTERPRESSDATA 28 POINTER) (INTERPRESSDATA 30 POINTER) (INTERPRESSDATA 32 POINTER) (INTERPRESSDATA 34 POINTER) (INTERPRESSDATA 36 (BITS . 15)) (INTERPRESSDATA 37 (BITS . 7)) (INTERPRESSDATA 37 (BITS . 135)) (INTERPRESSDATA 38 (BITS . 7)) (INTERPRESSDATA 38 (BITS . 135)) (INTERPRESSDATA 40 POINTER) (INTERPRESSDATA 42 POINTER) (INTERPRESSDATA 44 POINTER) (INTERPRESSDATA 46 POINTER) (INTERPRESSDATA 48 POINTER) (INTERPRESSDATA 50 POINTER) (INTERPRESSDATA 52 POINTER) (INTERPRESSDATA 54 POINTER) (INTERPRESSDATA 39 (BITS . 15)) (INTERPRESSDATA 56 POINTER) (INTERPRESSDATA 58 POINTER) (INTERPRESSDATA 60 POINTER) (INTERPRESSDATA 62 POINTER) (INTERPRESSDATA 64 POINTER) (INTERPRESSDATA 66 POINTER) (INTERPRESSDATA 68 POINTER) (INTERPRESSDATA 70 POINTER) (INTERPRESSDATA 72 POINTER) (INTERPRESSDATA 74 POINTER) (INTERPRESSDATA 76 POINTER) (INTERPRESSDATA 78 POINTER)) '80) ) (/DECLAREDATATYPE 'INTERPRESSDATA '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD BYTE BYTE BYTE BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((INTERPRESSDATA 0 POINTER) (INTERPRESSDATA 2 POINTER) (INTERPRESSDATA 4 POINTER) (INTERPRESSDATA 6 POINTER) (INTERPRESSDATA 8 POINTER) (INTERPRESSDATA 10 POINTER) (INTERPRESSDATA 12 POINTER) (INTERPRESSDATA 14 POINTER) (INTERPRESSDATA 16 POINTER) (INTERPRESSDATA 18 POINTER) (INTERPRESSDATA 20 POINTER) (INTERPRESSDATA 22 POINTER) (INTERPRESSDATA 24 POINTER) (INTERPRESSDATA 26 POINTER) (INTERPRESSDATA 28 POINTER) (INTERPRESSDATA 30 POINTER) (INTERPRESSDATA 32 POINTER) (INTERPRESSDATA 34 POINTER) (INTERPRESSDATA 36 (BITS . 15)) (INTERPRESSDATA 37 (BITS . 7)) (INTERPRESSDATA 37 (BITS . 135)) (INTERPRESSDATA 38 (BITS . 7)) (INTERPRESSDATA 38 (BITS . 135)) (INTERPRESSDATA 40 POINTER) (INTERPRESSDATA 42 POINTER) (INTERPRESSDATA 44 POINTER) (INTERPRESSDATA 46 POINTER) (INTERPRESSDATA 48 POINTER) (INTERPRESSDATA 50 POINTER) (INTERPRESSDATA 52 POINTER) (INTERPRESSDATA 54 POINTER) (INTERPRESSDATA 39 (BITS . 15)) (INTERPRESSDATA 56 POINTER) (INTERPRESSDATA 58 POINTER) (INTERPRESSDATA 60 POINTER) (INTERPRESSDATA 62 POINTER) (INTERPRESSDATA 64 POINTER) (INTERPRESSDATA 66 POINTER) (INTERPRESSDATA 68 POINTER) (INTERPRESSDATA 70 POINTER) (INTERPRESSDATA 72 POINTER) (INTERPRESSDATA 74 POINTER) (INTERPRESSDATA 76 POINTER) (INTERPRESSDATA 78 POINTER)) '80) (DEFINEQ (INTERPRESSBITMAP [LAMBDA (OUTPUTFILE BITMAP SCALEFACTOR REGION ROTATION TITLE) (* ; "Edited 14-Jan-88 02:08 by FS") (* ; "Print a bitmap into an IP file") (PROG (IPSTREAM W H) (SETQ IPSTREAM (OPENIMAGESTREAM (OR OUTPUTFILE '{SCRATCH}IPBITMAP.SCRATCH) 'INTERPRESS)) [SETQ W (COND (REGION (fetch (REGION WIDTH) of REGION)) (T (fetch (BITMAP BITMAPWIDTH) of BITMAP] [SETQ H (COND (REGION (fetch (REGION HEIGHT) of REGION)) (T (fetch (BITMAP BITMAPHEIGHT) of BITMAP] (COND (TITLE (RELMOVETO (IDIFFERENCE (TIMES 4 MICASPERINCH) (STRINGWIDTH TITLE IPSTREAM)) 0 IPSTREAM) (PRIN1 TITLE IPSTREAM))) (* ;  "Try to center around within the pageframe margins") [COND (SCALEFACTOR (SETQ W (TIMES W SCALEFACTOR)) (SETQ H (TIMES H SCALEFACTOR] (* ;; "These transformations are wrong!") (SELECTQ (SETQ ROTATION (IMOD (OR ROTATION DEFAULT.INTERPRESS.BITMAP.ROTATION) 360)) (0 (SETQ W (- W)) (SETQ H (- H))) (180) (90 (SETQ H (PROG1 (- W) (SETQ W H)))) (270 (SETQ W (PROG1 (- H) (SETQ H W)))) (ERROR ROTATION "rotation by other than multiples of 90 degrees not implemented")) [\MOVETO.IP IPSTREAM [+ (TIMES MICASPERINCH 4.25) (TIMES W (CONSTANT (FQUOTIENT 635 36] (+ (TIMES MICASPERINCH 5.5) (TIMES H (CONSTANT (FQUOTIENT 635 36] (* ;; "Position so that the bitmap's image is centered on the paper ((635 / 36) = half the micas in a point)") (SHOWBITMAP.IP IPSTREAM BITMAP REGION SCALEFACTOR ROTATION) (RETURN (CLOSEF IPSTREAM]) ) (ADDTOVAR IMAGESTREAMTYPES (INTERPRESS (OPENSTREAM OPENIPSTREAM) (FONTCREATE \CREATEINTERPRESSFONT) (FONTSAVAILABLE \SEARCHINTERPRESSFONTS) (CREATECHARSET \CREATECHARSET.IP))) (* ;; "HOSTNAMEP is NILL for DOCUPRINT instead of NSPRINTER.HOSTNAMEP, since that predicate merely tests for colon in the name. DOCUPRINT printers are only recognized from their PRINTERTYPE property, which must be on their CANONICAL.HOSTNAME. Preference is for INTERPRESS (CANPRINT ordering), for backward compatibility. But printer can be put on DEFAULTPRINTINGHOST twice, with the type CONSed on to the name, to give the user dynamic selection." ) (ADDTOVAR PRINTERTYPES ((DOCUPRINT) (CANPRINT (INTERPRESS POSTSCRIPT)) (HOSTNAMEP NILL) (STATUS NSPRINTER.STATUS) (PROPERTIES NSPRINTER.PROPERTIES) (SEND NSPRINT) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE))) ((INTERPRESS 8044) (CANPRINT (INTERPRESS)) (HOSTNAMEP NSPRINTER.HOSTNAMEP) (STATUS NSPRINTER.STATUS) (PROPERTIES NSPRINTER.PROPERTIES) (SEND NSPRINT) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (ADDTOVAR PRINTFILETYPES (INTERPRESS (TEST INTERPRESSFILEP) (EXTENSION (IP IPR INTERPRESS)) (CONVERSION (TEXT MAKEINTERPRESS TEDIT \TEDIT.HARDCOPY)))) (RPAQ? DEFAULT.INTERPRESS.BITMAP.ROTATION 90) (ADDTOVAR SYSTEMINITVARS (INTERPRESSFONTDIRECTORIES {DSK})) (RPAQ? INTERPRESSFONTEXTENSIONS '(WD)) (RPAQ? INTERPRESSFONTDIRECTORIES '("{Erinyes}Fonts>")) (RPAQ? INTERPRESSPRINTWHEELFAMILIES '(BOLDPS ELITE LETTERGOTHIC MASTER PICA PSBOLD SCIENTIFIC SPOKESMAN TITAN TREND TRENDPS TROJAN VINTAGE)) (RPAQ? INTERPRESSFAMILYALIASES '(LOGO LOGOTYPES-XEROX)) (* ; "NS Character Encoding") (DEFINEQ (NSMAP [LAMBDA (ZERODEFAULT MAP) (* bvm%: "23-Oct-86 12:52") (LET ((TABLE (ARRAY 256 'WORD 0 0))) (OR ZERODEFAULT (for I from 0 to 255 do (SETA TABLE I I))) [for X in MAP do (SETA TABLE (OR (FIXP (CAR X)) (CHARCODE.DECODE (CAR X))) (LOGOR (LLSH (CADR X) 8) (CADDR X] TABLE]) (\COERCEASCIITONSFONT [LAMBDA (ASCIITONSMAPARRAY ASCIITONSFIXARRAY ASCIIFAMILY NSFAMILY SIZE FONTFACE ROTATION DEVICE) (* gbn "12-Sep-85 15:10") (* ;; "Produces an ascii font with the proper widths for the ns-character correspondences defined by ASCIITONSMAPARRAY") (* ;; "ASCIITONSFIXARRAY is for temporary problems with font compatibility between printer and widths/screen. in OS5.0 fonts") (PROG (CHARSETDIR [ASCIITONSMAP (fetch (ARRAYP BASE) of (\DTEST (OR ASCIITONSFIXARRAY ASCIITONSMAPARRAY) 'ARRAYP] (FD (\CREATESTARFONT NSFAMILY SIZE FONTFACE ROTATION DEVICE))) (OR FD (RETURN NIL)) [SETQ CHARSETDIR (CONS (CONS 0 (\GETCHARSETINFO 0 FD] [bind NSCODE CS for I from 0 to 255 unless (OR (EQ I (SETQ NSCODE (\GETBASE ASCIITONSMAP I))) (ASSOC (SETQ CS (\CHARSET NSCODE)) CHARSETDIR)) do (* ;  "Run thru the translate table looking for non-0 charsets. Add their width info to the directory") (push CHARSETDIR (CONS CS (COND ((\GETCHARSETINFO CS FD)) (T (* ;  "There isn't any info for that character. Warn the guy, but continue.") (FRESHLINE PROMPTWINDOW) (printout PROMPTWINDOW "Warning: Information about character set " .I3.8 CS " missing from font " ASCIIFAMILY %, SIZE ".") NIL] (* ;  "Return if one of the fonts couldn't be found") [bind CHARSETINFO NSCODE (WIDTHS _ (fetch (CHARSETINFO WIDTHS) of (\GETCHARSETINFO 0 FD))) for I from 0 to 255 unless (EQ I (SETQ NSCODE (\GETBASE ASCIITONSMAP I))) when (SETQ CHARSETINFO (CDR (ASSOC (\CHARSET NSCODE) CHARSETDIR))) do (* ; "For each non-ASCII character, look for width info in the right NS place. If none, use zero width.") (\FSETWIDTH WIDTHS I (\FGETWIDTH (fetch (CHARSETINFO WIDTHS) of CHARSETINFO ) (\CHAR8CODE NSCODE] [replace OTHERDEVICEFONTPROPS of FD with (fetch (ARRAYP BASE) of (\DTEST ASCIITONSMAPARRAY 'ARRAYP] [COND ((NEQ NSFAMILY ASCIIFAMILY) (* ;; "Update the font deacriptor so it looks like it's really for the family the guy wanted. Also save the info we used to get here.") (replace FONTFAMILY of FD with ASCIIFAMILY) (replace FONTDEVICESPEC of FD with (LIST NSFAMILY SIZE FONTFACE ROTATION DEVICE] (RETURN FD]) (\CREATEINTERPRESSFONT [LAMBDA (FAMILY SIZE FONTFACE ROTATION DEVICE) (* ; "Edited 17-Feb-87 16:49 by FS") (* ;; "Creates a font descriptor for an NS font for hardcopy. Tries first on the assumption that he gave us the NS font name;") (DECLARE (GLOBALVARS \ASCIITONS \ASCIITOSTAR ASCIITONSTRANSLATIONS)) (* ;; "Test removal of \ASCIITOSTAR from \COERCEASCIITONSFONT, forces use of \ASCIITONS") (if (\COERCEASCIITONSFONT \ASCIITONS NIL FAMILY FAMILY SIZE FONTFACE ROTATION DEVICE) elseif (for TRANSL in ASCIITONSTRANSLATIONS bind NEWFONT when (AND (EQ FAMILY (CAR TRANSL)) (SETQ NEWFONT (\COERCEASCIITONSFONT (COND ((NULL (CADR TRANSL)) \ASCIITONS) ((LITATOM (CADR TRANSL)) (EVAL (CADR TRANSL))) (T (CADR TRANSL))) (COND ((NULL (CADR TRANSL)) \ASCIITOSTAR) (T NIL)) FAMILY (OR (CADDR TRANSL) 'MODERN) SIZE FONTFACE ROTATION DEVICE))) do (RETURN NEWFONT]) (\SEARCHINTERPRESSFONTS [LAMBDA (FAMILY PSIZE FACE ROTATION) (* ; "Edited 2-Jan-87 17:07 by FS") (DECLARE (GLOBALVARS INTERPRESSFONTDIRECTORIES INTERPRESSFONTEXTENSIONS)) (\SEARCHFONTFILES FAMILY PSIZE FACE ROTATION 'INTERPRESS INTERPRESSFONTDIRECTORIES INTERPRESSFONTEXTENSIONS]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ noInfoCode 32768) (CONSTANTS (noInfoCode 32768)) ) ) (RPAQ? ASCIITONSTRANSLATIONS ) (* ; "Catch the GACHA10 and any BI coercions to MODERN") (ADDTOVAR ASCIITONSTRANSLATIONS (TIMESROMAN NIL CLASSIC) (GACHA NIL TERMINAL) (HELVETICA) (CLASSIC) (GACHA) (TIMESROMAN) (LOGO NIL LOGOTYPES) (HIPPO HIPPOTONSARRAY CLASSIC) (CYRILLIC CYRILLICTONSARRAY CLASSIC) (SYMBOL \SYMBOLTONSARRAY MODERN)) (READVARS-FROM-STRINGS '(\SYMBOLTONSARRAY HIPPOTONSARRAY CYRILLICTONSARRAY) "({Y256 SMALLPOSP 0 0 0 180 42 0 61287 177 61309 61282 61283 61284 61285 0 184 0 0 61296 61298 61273 61272 8549 8550 0 0 61054 61305 61275 61274 8546 61299 0 0 0 174 173 175 61266 61250 61251 61303 61261 61263 0 0 61262 {R4 0} 8551 61258 61259 61281 0 61292 172 61365 61364 61290 61351 {R5 0} 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 61271 61270 0 61366 61367 61238 61239 61362 61363 61360 61361 123 125 61234 61235 61052 8514 61243 61242 8740 8742 61308 35 0 61301 {R 4 0} 167 61232 61233 182 64 211 163 164 {R128 0} } {Y256 SMALLPOSP 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 164 37 38 39 40 41 42 43 44 8510 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 9793 9794 9809 9797 9798 9818 9796 9802 9804 9728 9805 9806 9807 9808 9810 9811 9803 9813 9814 9816 9817 9728 9821 9819 9820 9801 91 92 93 173 172 185 9825 9826 9841 9829 9830 9850 9828 9834 9836 9847 9837 9838 9839 9840 9842 9843 9835 9845 9846 9848 9849 9728 9853 9851 9852 9833 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 61220 61221 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 61286 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 } {Y256 SMALLPOSP 0 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 10023 37 38 39 40 41 10041 43 44 8510 46 47 48 49 10095 51 10071 53 10088 55 10089 57 58 59 171 61 187 63 10047 10017 10018 10046 10021 10022 10038 10020 10049 10026 10027 10028 10029 10030 10031 10032 10033 10039 10034 10035 10036 10037 10019 10024 10045 10048 10025 10090 9984 10091 10044 10092 9984 10065 10066 10110 10069 10070 10086 10068 10097 10074 10075 10076 10077 10078 10079 10080 10081 10087 10082 10083 10084 10085 10067 10072 10093 10096 10073 10042 9984 10043 10040 9984 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 10094 144 145 146 147 148 149 150 151 152 153 154 61220 61221 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 61286 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 }) ") (DECLARE%: DONTEVAL@LOAD DOCOPY (\INTERPRESSINIT) ) (DECLARE%: EVAL@COMPILE DONTCOPY (LOADDEF 'SYSTEMBRUSH 'RESOURCES 'IMAGEIO) (LOADDEF 'BRUSH 'RECORDS 'IMAGEIO) ) (PUTPROPS INTERPRESS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 1991 1993 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (13200 17741 (APPENDBYTE.IP 13210 . 13346) (APPENDIDENTIFIER.IP 13348 . 13739) ( APPENDINT.IP 13741 . 14192) (APPENDINTEGER.IP 14194 . 14619) (APPENDLARGEVECTOR.IP 14621 . 15421) ( APPENDNUMBER.IP 15423 . 15779) (APPENDOP.IP 15781 . 16220) (APPENDRATIONAL.IP 16222 . 16578) ( APPENDSEQUENCEDESCRIPTOR.IP 16580 . 17564) (BYTESININT.IP 17566 . 17739)) (17777 55249 (ARCTO.IP 17787 . 18993) (BEGINMASTER.IP 18995 . 19149) (BEGINPAGE.IP 19151 . 19387) (BEGINPREAMBLE.IP 19389 . 19640) (CLIPRECTANGLE.IP 19642 . 20009) (CONCAT.IP 20011 . 20157) (CONCATT.IP 20159 . 20307) (ENDMASTER.IP 20309 . 20632) (ENDPAGE.IP 20634 . 20891) (ENDPREAMBLE.IP 20893 . 21717) (FGET.IP 21719 . 21903) ( FILLRECTANGLE.IP 21905 . 24116) (FILLTRAJECTORY.IP 24118 . 24615) (FILLNGON.IP 24617 . 27014) (FSET.IP 27016 . 27200) (GETFRAMEVAR.IP 27202 . 27520) (INITIALIZEMASTER.IP 27522 . 27979) (INITIALIZECOLOR.IP 27981 . 29149) (ISET.IP 29151 . 29403) (GETCP.IP 29405 . 29595) (LINETO.IP 29597 . 30107) ( MASKSTROKE.IP 30109 . 30263) (MOVETO.IP 30265 . 30483) (ROTATE.IP 30485 . 30668) (SCALE.IP 30670 . 30854) (SCALE2.IP 30856 . 31074) (SETCOLOR.IP 31076 . 33222) (SETRGB.IP 33224 . 34142) (SETCOLORLV.IP 34144 . 38644) (SETCOLOR16.IP 38646 . 41592) (SETFONT.IP 41594 . 42290) (SETSPACE.IP 42292 . 42485) ( SETXREL.IP 42487 . 43814) (SETX.IP 43816 . 45461) (SETXY.IP 45463 . 46965) (SETXYREL.IP 46967 . 48556) (SETY.IP 48558 . 50147) (SETYREL.IP 50149 . 51343) (SHOW.IP 51345 . 54397) (TRAJECTORY.IP 54399 . 54797) (TRANS.IP 54799 . 55019) (TRANSLATE.IP 55021 . 55247)) (55280 61308 (\CHANGE-VISIBLE-REGION.IP 55290 . 58951) (\PAPERSIZE.IP 58953 . 59774) (HEADINGOP.IP 59776 . 61306)) (61309 166856 ( DEFINEFONT.IP 61319 . 62185) (FONTNAME.IP 62187 . 63117) (INTERPRESS.BITMAPSCALE 63119 . 63681) ( INTERPRESS.OUTCHARFN 63683 . 69855) (INTERPRESSFILEP 69857 . 71018) (MAKEINTERPRESS 71020 . 71204) ( NEWLINE.IP 71206 . 71938) (NEWPAGE.IP 71940 . 76906) (NEWPAGE?.IP 76908 . 77387) (OPENIPSTREAM 77389 . 85103) (SETUPFONTS.IP 85105 . 86097) (SHOWBITMAP.IP 86099 . 90761) (\BITMAPSIZE.IP 90763 . 91540) ( SHOWBITMAP1.IP 91542 . 95824) (SHOWSHADE.IP 95826 . 96623) (\BITBLT.IP 96625 . 100829) ( \SCALEDBITBLT.IP 100831 . 104476) (\BLTSHADE.IP 104478 . 105815) (\CHARWIDTH.IP 105817 . 106267) ( \CLOSEIPSTREAM 106269 . 106596) (\DRAWARC.IP 106598 . 107045) (\DRAWCURVE.IP 107047 . 109343) ( \DRAWPOINT.IP 109345 . 110382) (\DSPCOLOR.IP 110384 . 111335) (ENSURE.RGB 111337 . 112001) (\IPCURVE2 112003 . 126512) (\CLIPCURVELINE.IP 126514 . 131212) (\DRAWLINE.IP 131214 . 134796) (\CLIPLINE 134798 . 139498) (\DSPBOTTOMMARGIN.IP 139500 . 139916) (\DSPFONT.IP 139918 . 145502) (\DSPLEFTMARGIN.IP 145504 . 145964) (\DSPLINEFEED.IP 145966 . 146633) (\DSPRIGHTMARGIN.IP 146635 . 147432) ( \DSPSPACEFACTOR.IP 147434 . 148519) (\DSPTOPMARGIN.IP 148521 . 148957) (\DSPXPOSITION.IP 148959 . 149946) (\DSPROTATE.IP 149948 . 150126) (\PUSHSTATE.IP 150128 . 150890) (\POPSTATE.IP 150892 . 151397) (\DEFAULTSTATE.IP 151399 . 151632) (\DSPTRANSLATE.IP 151634 . 151815) (\DSPSCALE2.IP 151817 . 151992) (\DSPYPOSITION.IP 151994 . 152295) (FILLCIRCLE.IP 152297 . 153380) (\FILLPOLYGON.IP 153382 . 154607) (\DRAWPOLYGON.IP 154609 . 160880) (\FIXLINELENGTH.IP 160882 . 162096) (\MOVETO.IP 162098 . 162462) ( \SETBRUSH.IP 162464 . 164474) (\STRINGWIDTH.IP 164476 . 164879) (\DSPCLIPPINGREGION.IP 164881 . 166057 ) (\DSPOPERATION.IP 166059 . 166854)) (167048 167803 (IP-TOS 167058 . 167318) (POP-IP-STACK 167320 . 167615) (PUSH-IP-STACK 167617 . 167801)) (167864 180428 (\CREATECHARSET.IP 167874 . 179665) ( \CHANGECHARSET.IP 179667 . 180426)) (180429 185034 (\INTERPRESSINIT 180439 . 185032)) (185035 185593 ( SCALEREGION 185045 . 185591)) (211509 213815 (INTERPRESSBITMAP 211519 . 213813)) (216047 222703 (NSMAP 216057 . 216639) (\COERCEASCIITONSFONT 216641 . 220495) (\CREATEINTERPRESSFONT 220497 . 222362) ( \SEARCHINTERPRESSFONTS 222364 . 222701))))) STOP \ No newline at end of file diff --git a/sources/IOCHAR b/sources/IOCHAR new file mode 100644 index 00000000..08456e13 --- /dev/null +++ b/sources/IOCHAR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "10-Aug-2020 21:44:38" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;5 90419 changes to%: (FNS FILEPOS FFILEPOS) previous date%: "11-Nov-2018 12:12:53" {DSK}kaplan>Local>medley3.5>lispcore>sources>IOCHAR.;4) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2018, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT IOCHARCOMS) (RPAQQ IOCHARCOMS [(COMS (FNS CHCON UNPACK DCHCON DUNPACK) (FNS UALPHORDER ALPHORDER CONCAT CONCATCODES PACKC PACK PACK* \PACK.ITEM STRPOS) (FUNCTIONS XCL:PACK XCL:PACK*) (GLOBALVARS \SIGNFLAG \PRINTRADIX) (DECLARE%: DONTCOPY (MACROS \CATRANSLATE))) (COMS (FNS STRPOSL MAKEBITTABLE) (DECLARE%: DONTCOPY (RESOURCES \STRPOSLARRAY)) (INITRESOURCES \STRPOSLARRAY)) (COMS (FNS CASEARRAY UPPERCASEARRAY) (P (MOVD? 'SETA 'SETCASEARRAY) (MOVD? 'ELT 'GETCASEARRAY)) [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (\TRANSPARENT (CASEARRAY)) (UPPERCASEARRAY (UPPERCASEARRAY] (DECLARE%: EVAL@COMPILE (PROP GLOBALVAR UPPERCASEARRAY) DONTCOPY (GLOBALVARS \TRANSPARENT))) (COMS (FNS FILEPOS FFILEPOS \SETUP.FFILEPOS) (DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR) (CONSTANTS (\MAX.PATTERN.SIZE 128) (\MIN.PATTERN.SIZE 3) (FILEPOS.SEGMENT.SIZE 32768) (\MIN.SEARCH.LENGTH 100))) (INITRESOURCES \FFDELTA1 \FFDELTA2 \FFPATCHAR)) [COMS (* ;; "DATE Functions") (FNS DATE DATEFORMAT GDATE IDATE \IDATESCANTOKEN \IDATE-PARSE-MONTH \OUTDATE \OUTDATE-STRING \RPLRIGHT \UNPACKDATE \PACKDATE \DTSCAN \ISDST? \CHECKDSTCHANGE) (OPTIMIZERS DATEFORMAT) (* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)") (INITVARS (\TimeZoneComp 8) (\BeginDST 98) (\EndDST 304) (\DayLightSavings T)) (ADDVARS (TIME.ZONES (8 "PST" "PDT") (7 "MST" "MDT") (6 "CST" "CDT") (5 "EST" "EDT") (0 "GMT" "BST") (0 "UT") (-1 "MET" "MET DST") (-2 "EET" "EET DST"))) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES) (CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4] (LOCALVARS . T) (PROP FILETYPE IOCHAR) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DATEFORMAT) (NLAML) (LAMA PACK* CONCAT]) (DEFINEQ (CHCON (LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (\GETBASECHAR FATP BASE I))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST))) ) (UNPACK (LAMBDA (X FLG RDTBL) (* bvm%: "24-Mar-86 16:29") (PROG (BASE OFFST LEN \CHCONLST \CHCONLSTAIL FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) collect (FCHARACTER (\GETBASECHAR FATP BASE I)))) SLOWCASE (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (SETQ CODE (FCHARACTER CODE)) (* ; "Open code COLLECT") (COND (\CHCONLSTAIL (FRPLACD \CHCONLSTAIL (SETQ \CHCONLSTAIL (LIST CODE)))) (T (SETQ \CHCONLST (SETQ \CHCONLSTAIL (LIST CODE))))))) X FLG RDTBL) (RETURN \CHCONLST))) ) (DCHCON (LAMBDA (X SCRATCHLIST FLG RDTBL) (* ; "Edited 24-Dec-86 14:04 by jds") (* ;;; "Unpack the character codes that make up the print-representation of X into the scratch list SCRATCHLIST. If FLG, use the PRIN2-pname. Do the printing according to RDTBL readtable, if supplied.") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (* ; "LITATOM case: Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (* ; "STRING case: Set up the indexing info for the \GETBASECHAR loop below.") (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (* ;; "Copy the characters from the string/atom-pname into the list") (ADDTOSCRATCHLIST (\GETBASECHAR FATP BASE I)))) SLOWCASE (* ;; "Slow case: Use \MAPPNAME to generate the characters, and grab onto them.") (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST CODE))) X FLG RDTBL))))) ) (DUNPACK (LAMBDA (X SCRATCHLIST FLG RDTBL) (* bvm%: "24-Mar-86 16:30") (SCRATCHLIST SCRATCHLIST (PROG (BASE OFFST LEN FATP) (COND (FLG (GO SLOWCASE))) (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X))) (T (GO SLOWCASE))) (RETURN (for I from OFFST to (IPLUS OFFST LEN -1) do (ADDTOSCRATCHLIST (FCHARACTER (\GETBASECHAR FATP BASE I))))) SLOWCASE (RETURN (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (ADDTOSCRATCHLIST (FCHARACTER CODE)))) X FLG RDTBL))))) ) ) (DEFINEQ (UALPHORDER (LAMBDA (ARG1 B) (* rmk%: " 2-Apr-85 11:20") (ALPHORDER ARG1 B UPPERCASEARRAY))) (ALPHORDER (LAMBDA (A B CASEARRAY) (* rmk%: "27-Mar-85 17:43") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (CABASE ABASE ALEN AOFFSET AFATP BBASE BLEN BOFFSET BFATP C1 C2) (COND ((LITATOM A) (SETQ ABASE (ffetch (LITATOM PNAMEBASE) of A)) (SETQ AOFFSET 1) (SETQ ALEN (ffetch (LITATOM PNAMELENGTH) of A)) (SETQ AFATP (ffetch (LITATOM FATPNAMEP) of A))) ((STRINGP A) (SETQ ABASE (ffetch (STRINGP BASE) of A)) (SETQ AOFFSET (ffetch (STRINGP OFFST) of A)) (SETQ ALEN (ffetch (STRINGP LENGTH) of A)) (SETQ AFATP (ffetch (STRINGP FATSTRINGP) of A))) (T (RETURN (COND ((NUMBERP A) (* ; "Numbers are less than all other types") (OR (NOT (NUMBERP B)) (NOT (GREATERP A B)))) ((OR (NUMBERP B) (LITATOM B) (STRINGP B)) NIL) (T T))))) (COND ((LITATOM B) (SETQ BBASE (ffetch (LITATOM PNAMEBASE) of B)) (SETQ BOFFSET 1) (SETQ BLEN (ffetch (LITATOM PNAMELENGTH) of B)) (SETQ BFATP (ffetch (LITATOM FATPNAMEP) of B))) ((STRINGP B) (SETQ BBASE (ffetch (STRINGP BASE) of B)) (SETQ BOFFSET (ffetch (STRINGP OFFST) of B)) (SETQ BLEN (ffetch (STRINGP LENGTH) of B)) (SETQ BFATP (ffetch (STRINGP FATSTRINGP) of B))) (T (* ; "Only numbers are 'less than' atoms and strings") (RETURN (NOT (NUMBERP B))))) (SETQ CABASE (fetch (ARRAYP BASE) of (SETQ CASEARRAY (\DTEST (OR CASEARRAY \TRANSPARENT) (QUOTE ARRAYP))))) (RETURN (for I (CAFAT _ (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE _ (fetch (ARRAYP LENGTH) of CASEARRAY)) from 0 do (COND ((IGEQ I ALEN) (RETURN (COND ((EQ ALEN BLEN) (QUOTE EQUAL)) (T (QUOTE LESSP))))) ((IGEQ I BLEN) (RETURN NIL)) ((EQ (SETQ C1 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR AFATP ABASE (IPLUS I AOFFSET)))) (SETQ C2 (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR BFATP BBASE (IPLUS I BOFFSET)))))) ((ILESSP C1 C2) (RETURN (QUOTE LESSP))) (T (* ; "Greater") (RETURN NIL))))))) ) (CONCAT (LAMBDA N (* rmk%: "26-Mar-85 19:08") (PROG ((J N) (LEN 0) (POS 1) S NM FATSEENP) L1 (COND ((NEQ J 0) (COND ((STRINGP (SETQ NM (ARG N J))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM)))) ((LITATOM NM) (OR FATSEENP (SETQ FATSEENP (ffetch (LITATOM FATPNAMEP) of NM)))) (T (SETARG N J (SETQ NM (MKSTRING NM))) (OR FATSEENP (SETQ FATSEENP (ffetch (STRINGP FATSTRINGP) of NM))))) (SETQ LEN (IPLUS LEN (NCHARS NM))) (SETQ J (SUB1 J)) (GO L1))) (SETQ S (ALLOCSTRING LEN NIL NIL FATSEENP)) L2 (COND ((NEQ J N) (SETQ J (ADD1 J)) (RPLSTRING S POS (ARG N J)) (SETQ POS (IPLUS POS (NCHARS (ARG N J)))) (GO L2))) (RETURN S))) ) (CONCATCODES (LAMBDA (CHARCODES) (* bvm%: " 6-May-84 21:56") (PROG ((STR (ALLOCSTRING (LENGTH CHARCODES)))) (for X in CHARCODES as I from 1 do (RPLCHARCODE STR I X)) (RETURN STR))) ) (PACKC [LAMBDA (X) (* ; "Edited 11-Nov-2018 12:12 by rmk:") (* rmk%: "11-Apr-85 15:35") (* ;; "Takes character codes in X, stuffs them into the \PNAMESTRING, and then calls \MKATOM.") (* ;; "The previous version uses HASFAT as the storage format even if the characters turned out to be all thin. For unknown reasons, this caused existing atoms not to be matched if they had non-ascii thin characters, even") (* ;; " though \MKATOM tried to figure out what the truth.") (* ;; "But that was a bad optimization, involved an extra pass in every case. Better to start by assuming thin (0-255) characters and store them as bytes, then upgrade the storage format when the first fat code is seen. No extra work for the most common 0-255. If a code is outside of that range (e.g. Japanese), chances are that it will appear early in the sequence, so little work to be done to expand the storage format for previously stored characters.") (* ;; "The end-result: the storage format and characters are always consistent, HASFAT is accurate for both, and \MKATOM doesn't have to second-guess.") (* ;; "Note: after init, the code for \MKATOM is in PACKAGE-STARTUP ") (WITH-RESOURCE (\PNAMESTRING) (BIND HASFAT (PBASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) for N from 0 as C in X do (AND (IGREATERP N \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (IF HASFAT THEN (* ;;  "We already saw a fat, and upgraded the storage format. Continue") (\PUTBASEFAT PBASE N C) ELSEIF (ILEQ C \MAXTHINCHAR) THEN (* ;; "Still seeing only thin characters. Continue") (\PUTBASETHIN PBASE N C) ELSE (* ;; "First fat, perhaps there are previous thins to convert. Go backwards so we don't smash the early ones") (for NN from (SUB1 N) to 0 by -1 DO (\PUTBASEFAT PBASE NN (\GETBASETHIN PBASE NN))) (\PUTBASEFAT PBASE N C) (SETQ HASFAT T)) finally (RETURN (\MKATOM PBASE 0 N HASFAT]) (PACK (LAMBDA (X) (* ; "Edited 21-Mar-88 15:29 by bvm") (AND X (NLISTP X) (\ILLEGAL.ARG X)) (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) ITEM) LP (COND ((NULL X) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (COND ((OR (STRINGP (SETQ ITEM (CAR X))) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ X (LISTP (CDR X))) (GO LP)))) ) (PACK* (LAMBDA U (* ; "Edited 21-Mar-88 15:29 by bvm") (DECLARE (SPECVARS PACK.INDEX \PNAMESTRING)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((PACK.INDEX 1) (M 1) ITEM) LP (COND ((IGREATERP M U) (RETURN (\MKATOM (fetch (STRINGP XBASE) of \PNAMESTRING) 0 (SUB1 PACK.INDEX) \FATPNAMESTRINGP)))) (SETQ ITEM (ARG U M)) (COND ((AND (NULL *PACKAGE*) (LITATOM ITEM)) (* ;; "If we're in that nasty region of the INIT process before packages have been turned on, then we want to be careful to strip off any pseudo-package prefixes in the symbol's pname. We use the utility NAMESTRING-CONVERSION-CLAUSE from LLPACKAGE for this search.") (LET* ((BASE (ffetch (CL:SYMBOL PNAMEBASE) of ITEM)) (LEN (ffetch (CL:SYMBOL PNAMELENGTH) of ITEM)) (FATP (ffetch (CL:SYMBOL FATPNAMEP) of ITEM)) (CLAUSE (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP))) (COND ((NULL CLAUSE) (* ; "Nothing special to do; this symbol didn't match any of the conversion clauses.") (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (* ; "The symbol matched a clause. We should use only that part of the symbol that comes after the matching prefix.") (LET ((PREFIX-LENGTH (ffetch (STRINGP LENGTH) (CL:FIRST CLAUSE)))) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (IDIFFERENCE (NCHARS ITEM) PREFIX-LENGTH)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) (SUBSTRING ITEM (IPLUS 1 PREFIX-LENGTH)))))))) ((OR (STRINGP ITEM) (LITATOM ITEM)) (RPLSTRING \PNAMESTRING (PROG1 PACK.INDEX (AND (IGREATERP (add PACK.INDEX (NCHARS ITEM)) (ADD1 \PNAMELIMIT)) (LISPERROR "ATOM TOO LONG"))) ITEM)) (T (\PACK.ITEM ITEM))) (SETQ M (ADD1 M)) (GO LP)))) ) (\PACK.ITEM (LAMBDA (ITEM) (* ; "Edited 21-Mar-88 15:30 by bvm") (DECLARE (USEDFREE PACK.INDEX \PNAMESTRING)) (* ;;; "Slow case for PACK and PACK* -- append characters of ITEM to \PNAMESTRING, updating PACK.INDEX accordingly") (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (AND (IGREATERP PACK.INDEX \PNAMELIMIT) (LISPERROR "ATOM TOO LONG")) (\PNAMESTRINGPUTCHAR (fetch (STRINGP BASE) of \PNAMESTRING) (SUB1 PACK.INDEX) CODE) (add PACK.INDEX 1))) ITEM)) ) (STRPOS (LAMBDA (PAT STRING START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) (* ; "Edited 6-Jan-88 12:44 by jds") (DECLARE (GLOBALVARS \TRANSPARENT)) (PROG (PATLEN PATBASE PATOFFST STRINGLEN STRINGBASE STRINGOFFST MAXI JMAX 1stPATchar jthPATchar STRFAT PATFAT) (COND ((LITATOM PAT) (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PAT)) (SETQ PATOFFST 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PAT)) (SETQ PATFAT (fetch (LITATOM FATPNAMEP) of PAT))) (T (OR (STRINGP PAT) (SETQ PAT (MKSTRING PAT))) (SETQ PATBASE (fetch (STRINGP BASE) of PAT)) (SETQ PATOFFST (fetch (STRINGP OFFST) of PAT)) (SETQ PATLEN (fetch (STRINGP LENGTH) of PAT)) (SETQ PATFAT (fetch (STRINGP FATSTRINGP) of PAT)))) (COND ((LITATOM STRING) (SETQ STRINGBASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ STRINGOFFST 1) (SETQ STRINGLEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING))) (T (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ STRINGBASE (fetch (STRINGP BASE) of STRING)) (SETQ STRINGOFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRINGLEN (fetch (STRINGP LENGTH) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING)))) (COND ((IGEQ 0 (SETQ MAXI (ADD1 (IDIFFERENCE STRINGLEN PATLEN)))) (* ; "Who's he kidding? The PATTERN length is greater than the STRING length") (RETURN))) (COND ((NULL START) (SETQ START (COND (BACKWARDSFLG MAXI) (T 1)))) ((ILESSP START 0) (add START (ADD1 STRINGLEN)) (COND ((ILESSP START 1) (RETURN)))) ((IGREATERP START MAXI) (RETURN))) (* ; "Normalize start to a 1-origin index between 1 and LEN") (COND ((ILEQ PATLEN 0) (RETURN (AND TAIL START)))) (* ; "Null pattern matches anything -- but (STRPOS %"%" %"%") is NIL unless TAIL is T.") (AND SKIP (SETQ SKIP (CHCON1 SKIP))) (COND ((NULL CASEARRAY) (SETQ CASEARRAY \TRANSPARENT)) ((NOT (AND (ARRAYP CASEARRAY) (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of CASEARRAY)) (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))))) (\ILLEGAL.ARG CASEARRAY))) (* ; "Oh, for a LET here!") (add STRINGOFFST -1) (add PATOFFST -1) (RETURN (PROG ((CAOFFST (fetch (ARRAYP OFFST) of CASEARRAY)) (CABASE (fetch (ARRAYP BASE) of CASEARRAY)) (CAFAT (EQ \ST.POS16 (fetch (ARRAYP TYP) of CASEARRAY))) (CASIZE (fetch (ARRAYP LENGTH) of CASEARRAY)) (OFFST.I (IPLUS STRINGOFFST START (COND (BACKWARDSFLG 1) (T -1)))) (LASTI (IPLUS STRINGOFFST (COND (ANCHOR START) (BACKWARDSFLG 1) (T MAXI)))) (JSTART (IPLUS PATOFFST 2)) (JMAX (IPLUS PATOFFST PATLEN))) (* ; "Remember! START is a 1-origin index") (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") (OR (EQ 0 CAOFFST) (ERROR "CASEARRAY can't be a sub-array: " CASEARRAY)) (SETQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE (ADD1 PATOFFST)))) LP (COND ((COND (BACKWARDSFLG (ILESSP (add OFFST.I -1) LASTI)) (T (IGREATERP (add OFFST.I 1) LASTI))) (RETURN)) ((AND (OR (EQ 1stPATchar SKIP) (EQ 1stPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE OFFST.I)))) (for J from JSTART to JMAX as K from (ADD1 OFFST.I) always (OR (EQ SKIP (SETQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR PATFAT PATBASE J)))) (EQ jthPATchar (\CATRANSLATE CABASE CASIZE CAFAT (\GETBASECHAR STRFAT STRINGBASE K)))))) (RETURN (IDIFFERENCE (COND (TAIL (IPLUS OFFST.I PATLEN)) (T OFFST.I)) STRINGOFFST)))) (GO LP) (* ; "Fall out thru bottom if didn't find it"))))) ) ) (CL:DEFUN XCL:PACK (NAMES &OPTIONAL (PACKAGE *PACKAGE*)) (* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the given package with a print name equal to the concatenation of the of the NAMES. ") (CL:INTERN (CONCATLIST NAMES) PACKAGE)) (CL:DEFUN XCL:PACK* (&REST NAMES) (* ;;; "NAMES should be a list of symbols and strings. A new symbol is created in the current package with a print name equal to the concatenation of the of the NAMES. ") (CL:INTERN (CONCATLIST NAMES))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SIGNFLAG \PRINTRADIX) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \CATRANSLATE MACRO (OPENLAMBDA (CABASE CASIZE CAFAT CHAR) (COND ((ILEQ CHAR CASIZE)(* ;  "If it's in the table, use the table value") (\GETBASEBYTE CABASE CHAR)) (T (* ;  "Off the end -- assume it's itself") CHAR)))) ) ) (DEFINEQ (STRPOSL (LAMBDA (A STRING START NEG BACKWARDSFLG) (* edited%: "18-Mar-86 17:20") (* ;; "Given a list of charcodes, A, find the first one in STRING.") (GLOBALRESOURCE \STRPOSLARRAY (PROG (BASE OFFST LEN I LASTI STRFAT CH) (OR (type? CHARTABLE A) (SETQ A (MAKEBITTABLE A NIL \STRPOSLARRAY))) (if (LITATOM STRING) then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING)) (SETQ OFFST 1) (SETQ STRFAT (fetch (LITATOM FATPNAMEP) of STRING)) else (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ BASE (fetch (STRINGP BASE) of STRING)) (SETQ LEN (fetch (STRINGP LENGTH) of STRING)) (SETQ OFFST (fetch (STRINGP OFFST) of STRING)) (SETQ STRFAT (fetch (STRINGP FATSTRINGP) of STRING))) (if (NULL START) then (SETQ START (if BACKWARDSFLG then LEN else 1)) elseif (ILESSP START 0) then (add START (ADD1 LEN)) (if (ILESSP START 1) then (RETURN)) elseif (IGREATERP START LEN) then (RETURN)) (* ; "Normalize start to a 1-origin index between 1 and LEN") (add OFFST -1) (* ; "Bias the OFFST since START is 1-origin and the loop deals in 0-origin") (SETQ NEG (if NEG then (* ; "Convert NEG to match the correct value returned by \SYNCODE") 0 else 1)) (SETQ I (IPLUS OFFST START)) (SETQ LASTI (IPLUS OFFST (if BACKWARDSFLG then (add I 1) 1 else (add I -1) LEN))) (* ; "There will be at least one pass thru the following loop, or else we would have (RETURN) before now") LP (if (if BACKWARDSFLG then (ILESSP (add I -1) LASTI) else (IGREATERP (add I 1) LASTI)) then (RETURN) elseif (EQ NEG (\SYNCODE A (\GETBASECHAR STRFAT BASE I))) then (RETURN (IDIFFERENCE I OFFST))) (GO LP)))) ) (MAKEBITTABLE [LAMBDA (L NEG A) (* ; "Edited 29-Apr-91 23:02 by jds") [COND [(type? CHARTABLE A) (* ; "Clear it") (\ZEROBYTES A 0 \MAXTHINCHAR) (if (fetch (CHARTABLE NSCHARHASH) of A) then (CLRHASH (fetch (CHARTABLE NSCHARHASH) of A] (T (SETQ A (create CHARTABLE] (for X in L do (\SETSYNCODE A (OR (SMALLP X) (CHCON1 X)) 1)) (* ; "Invert 1 and 0 if NEG") [AND NEG (for I from 0 to \MAXCHAR do (\SETSYNCODE A I (LOGXOR 1 (\SYNCODE A I] A]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\STRPOSLARRAY 'RESOURCES '(NEW (NCREATE 'CHARTABLE] ) ) (/SETTOPVAL '\\STRPOSLARRAY.GLOBALRESOURCE NIL) (DEFINEQ (CASEARRAY (LAMBDA (OLDAR) (* lmm "20-MAR-81 10:21") (COND (OLDAR (COPYARRAY OLDAR)) (T (PROG ((AR (ARRAY 256 (QUOTE BYTE) 0 0))) (for I from 0 to 255 do (SETA AR I I)) (RETURN AR))))) ) (UPPERCASEARRAY (LAMBDA NIL (* rmk%: " 2-Apr-85 11:22") (OR (ARRAYP UPPERCASEARRAY) (LET ((CA (CASEARRAY))) (for I from (CHARCODE a) to (CHARCODE z) do (SETCASEARRAY CA I (IDIFFERENCE I (CONSTANT (IDIFFERENCE (CHARCODE a) (CHARCODE A)))))) (SETQ UPPERCASEARRAY CA)))) ) ) (MOVD? 'SETA 'SETCASEARRAY) (MOVD? 'ELT 'GETCASEARRAY) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ \TRANSPARENT (CASEARRAY)) (RPAQ UPPERCASEARRAY (UPPERCASEARRAY)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS UPPERCASEARRAY GLOBALVAR T) DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TRANSPARENT) ) ) (DEFINEQ (FILEPOS [LAMBDA (STR FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 10-Aug-2020 21:44 by rmk:") (* Pavel "12-Oct-86 15:13") (* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file") (* ;; "NB: this function now works on non-PAGEMAPPED files. It must use only IO functions that respect that.") (PROG ((SKIPCHAR (AND SKIP (CHCON1 SKIP))) [CA (fetch (ARRAYP BASE) of (COND [CASEARRAY (COND ((AND (ARRAYP CASEARRAY) (EQ (fetch (ARRAYP TYP) of CASEARRAY ) \ST.BYTE)) CASEARRAY) (T (CASEARRAY CASEARRAY] (T \TRANSPARENT] (STREAM (\GETSTREAM FILE 'INPUT)) CHAR FIRSTCHAR STRBASE STRINDEX PATLEN PATINDEX ORGFILEPTR LASTINDEX STARTBYTE ENDBYTE BIGENDBYTE STARTSEG ENDSEG) (CL:WHEN (EQ :UTF8 (\EXTERNALFORMAT STREAM)) (SETQ STR (XTOUSTRING STR))) [COND ((LITATOM STR) (SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STR)) (SETQ STRINDEX 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of STR))) (T (OR (STRINGP STR) (SETQ STR (MKSTRING STR))) (SETQ STRBASE (fetch (STRINGP BASE) of STR)) (SETQ STRINDEX (fetch (STRINGP OFFST) of STR)) (SETQ PATLEN (fetch (STRINGP LENGTH) of STR] (* ;  "calculate start addr and set file ptr.") [SETQ STARTBYTE (COND (START (COND ((NOT (AND (FIXP START) (IGEQ START 0))) (LISPERROR "ILLEGAL ARG" START))) (SETQ ORGFILEPTR (\GETFILEPTR STREAM)) (\SETFILEPTR STREAM START) START) (T (SETQ ORGFILEPTR (\GETFILEPTR STREAM] (* ;  "calculate the character address of the character after the last possible match.") [SETQ ENDBYTE (ADD1 (COND ((NULL END) (* ; "Default is end of file") (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN)) ((IGEQ END 0) (* ; "Absolute byte pointer given") (IMIN END (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN))) ((IGREATERP PATLEN (IMINUS END)) (* ;  "END is too far, use eof less length") (IDIFFERENCE (\GETEOFPTR STREAM) PATLEN)) (T (IDIFFERENCE (IPLUS (\GETEOFPTR STREAM) END 1) PATLEN] (* ;; "use STARTBYTE and ENDBYTE instead of START and END because vm functions shouldn't change their arguments.") (COND ((IGEQ STARTBYTE ENDBYTE) (* ; "nothing to search") (GO FAILED))) (SETQ LASTINDEX PATLEN) SKIPLP (* ;  "set the first character to FIRSTCHAR, handling leading skips.") (COND ((EQ LASTINDEX 0) (* ; "null case") (GO FOUNDIT)) ((EQ (SETQ FIRSTCHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE STRINDEX))) SKIPCHAR) (* ;  "first character in pattern is skip.") (SETQ LASTINDEX (SUB1 LASTINDEX)) (\BIN STREAM) (* ; "Move forward a character.") (add STRINDEX 1) (add STARTBYTE 1) (GO SKIPLP))) (SETQ LASTINDEX (IPLUS LASTINDEX STRINDEX)) (* ;  "Used for end of pattern check, comparing against current INDEX") [COND ((SMALLP ENDBYTE) (SETQ STARTSEG (SETQ ENDSEG 0))) (T (* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary (can get around that here by decrementing everyone, but can't in FFILEPOS). Note that STARTBYTE and ENDBYTE are never actually used as file ptrs, just for counting.") (SETQ ENDSEG (FOLDLO ENDBYTE FILEPOS.SEGMENT.SIZE)) (SETQ BIGENDBYTE (IMOD ENDBYTE FILEPOS.SEGMENT.SIZE)) (SETQ STARTSEG (FOLDLO STARTBYTE FILEPOS.SEGMENT.SIZE)) (SETQ STARTBYTE (IMOD STARTBYTE FILEPOS.SEGMENT.SIZE)) (SETQ ENDBYTE (COND ((EQ STARTSEG ENDSEG) BIGENDBYTE) (T (* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets") FILEPOS.SEGMENT.SIZE] FIRSTCHARLP (* ;; "STARTBYTE is the possible beginning of a match. the file ptr of the file is always at STARTBYTE position when the FIRSTCHAR loop is passed.") (COND ((EQ STARTBYTE ENDBYTE) (* ; "end of this part of search") (COND ((EQ STARTSEG ENDSEG) (* ; "failed") (GO FAILED))) (* ;  "Finished this segment, roll over into new one") (SETQ STARTBYTE 0) (* ;  "= STARTBYTE-FILEPOS.SEGMENT.SIZE") [COND ((EQ (add STARTSEG 1) ENDSEG) (* ;  "Entering final segment, so set ENDBYTE to actual end instead of segment end") (COND ((EQ (SETQ ENDBYTE BIGENDBYTE) 0) (GO FAILED] (GO FIRSTCHARLP)) ((NEQ FIRSTCHAR (\GETBASEBYTE CA (\BIN STREAM))) (add STARTBYTE 1) (GO FIRSTCHARLP))) (SETQ PATINDEX STRINDEX) MATCHLP (* ;  "At this point, STR is matched thru offset PATINDEX") (COND ((EQ (SETQ PATINDEX (ADD1 PATINDEX)) LASTINDEX) (* ; "matched for entire length") (GO FOUNDIT)) ((OR (EQ (SETQ CHAR (\GETBASEBYTE CA (\GETBASEBYTE STRBASE PATINDEX))) (\GETBASEBYTE CA (\BIN STREAM))) (EQ CHAR SKIPCHAR)) (* ;  "Char from file matches char from STR") (GO MATCHLP)) (T (* ;  "Match failed, so we have to start again with first char") (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM) (IDIFFERENCE PATINDEX STRINDEX))) (* ;; "Back up over the chars we have just read in trying to match, less one. I.e. go back to one past the previous starting point") (add STARTBYTE 1) (GO FIRSTCHARLP))) FOUNDIT (* ;  "set fileptr, adjust for beginning skips and return proper value.") [COND ((NOT TAIL) (* ;  "Fileptr wants to be at start of string") (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM) PATLEN] (RETURN (\GETFILEPTR STREAM)) FAILED (* ;  "return the fileptr to its initial position.") (\SETFILEPTR STREAM ORGFILEPTR) (RETURN NIL]) (FFILEPOS [LAMBDA (PATTERN FILE START END SKIP TAIL CASEARRAY) (* ; "Edited 10-Aug-2020 21:44 by rmk:") (* ;; "RMK: Added coercion from internal XCCS string to UTF8 if searching a UTF8 file") (* Pavel "12-Oct-86 15:20") (PROG ([STREAM (\GETSTREAM (OR FILE (INPUT] PATBASE PATOFFSET PATLEN ORGFILEPTR STARTOFFSET ENDOFFSET BIGENDOFFSET STARTSEG ENDSEG EOF ) (COND (SKIP (* ; "Slow case--use FILEPOS") (GO TRYFILEPOS)) ((NOT (fetch PAGEMAPPED of (fetch (STREAM DEVICE) of STREAM))) (* ;  "This is a non-page-oriented file. Use FILEPOS instead.") (GO TRYFILEPOS))) (* ;  "calculate start addr and set file ptr.") (CL:WHEN (EQ :UTF8 (\EXTERNALFORMAT STREAM)) (SETQ PATTERN (XTOUSTRING PATTERN))) [COND ((LITATOM PATTERN) (SETQ PATBASE (fetch (LITATOM PNAMEBASE) of PATTERN)) (SETQ PATOFFSET 1) (SETQ PATLEN (fetch (LITATOM PNAMELENGTH) of PATTERN))) (T (OR (STRINGP PATTERN) (SETQ PATTERN (MKSTRING PATTERN))) (SETQ PATBASE (fetch (STRINGP BASE) of PATTERN)) (SETQ PATOFFSET (fetch (STRINGP OFFST) of PATTERN)) (SETQ PATLEN (fetch (STRINGP LENGTH) of PATTERN] (COND ((OR (IGREATERP PATLEN \MAX.PATTERN.SIZE) (ILESSP PATLEN \MIN.PATTERN.SIZE)) (GO TRYFILEPOS))) (SETQ ORGFILEPTR (\GETFILEPTR STREAM)) (SETQ STARTOFFSET (IPLUS (COND (START (COND ((NOT (AND (FIXP START) (IGEQ START 0))) (LISPERROR "ILLEGAL ARG" START))) START) (T ORGFILEPTR)) (SUB1 PATLEN))) (* ;  "STARTOFFSET is the address of the character corresponding to the last character of PATTERN.") (SETQ EOF (\GETEOFPTR STREAM)) (* ;  "calculate the character address of the character after the last possible match.") [SETQ ENDOFFSET (COND ((NULL END) (* ; "Default is end of file") EOF) (T (IMIN (IPLUS (COND ((ILESSP END 0) (IPLUS EOF END 1)) (T END)) PATLEN) EOF] (* ;; "use STARTOFFSET and ENDOFFSET instead of START and END because vm functions shouldn't change their arguments.") (COND ((IGEQ STARTOFFSET ENDOFFSET) (* ; "nothing to search") (RETURN)) ((ILESSP (IDIFFERENCE ENDOFFSET STARTOFFSET) \MIN.SEARCH.LENGTH) (* ;  "too small to make FFILEPOS worthwhile") (GO TRYFILEPOS))) (\SETFILEPTR STREAM STARTOFFSET) [RETURN (GLOBALRESOURCE (\FFDELTA1 \FFDELTA2 \FFPATCHAR) (PROG ((CASE (fetch (ARRAYP BASE) of (COND [CASEARRAY (COND ((AND (ARRAYP CASEARRAY) (EQ (fetch (ARRAYP TYP) of CASEARRAY) \ST.BYTE)) CASEARRAY) (T (CASEARRAY CASEARRAY] (T \TRANSPARENT)))) (DELTA1 (fetch (ARRAYP BASE) of \FFDELTA1)) (DELTA2 (fetch (ARRAYP BASE) of \FFDELTA2)) (PATCHAR (fetch (ARRAYP BASE) of \FFPATCHAR)) (MAXPATINDEX (SUB1 PATLEN)) CHAR CURPATINDEX LASTCHAR INC) (* ;; "Use Boyer-Moore string search algorithm. Use two auxiliary tables, DELTA1 and DELTA2, to tell how far ahead to move in the file when a partial match fails. DELTA1 contains, for each character code, the distance of that character from the right end of the pattern, or PATLEN if the character does not occur in the pattern. DELTA2 contains, for each character position in the pattern, how far ahead to move such that the partial substring discovered to the right of the position now matches some other substring (to the left) in the pattern. PATCHAR is just PATTERN translated thru CASEARRAY") (\SETUP.FFILEPOS PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE) [COND ((SMALLP ENDOFFSET) (SETQ STARTSEG (SETQ ENDSEG 0))) (T (* ;; "The search will be in the large integers at least part of the time, so split the start and end fileptrs into hi and lo parts. The `segment' size we choose is smaller than 2^16 so that we are still smallp near the boundary. Note that STARTOFFSET and ENDOFFSET are never actually used as file ptrs, just for counting.") (SETQ ENDSEG (FOLDLO ENDOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ BIGENDOFFSET (MOD ENDOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ STARTSEG (FOLDLO STARTOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ STARTOFFSET (MOD STARTOFFSET FILEPOS.SEGMENT.SIZE)) (SETQ ENDOFFSET (COND ((EQ STARTSEG ENDSEG) BIGENDOFFSET) (T (* ;; "In different segments, so we'll have to search all the way to the end of this seg; hence, `end' is currently as big as it gets") FILEPOS.SEGMENT.SIZE] (SETQ LASTCHAR (GETBASEBYTE PATCHAR MAXPATINDEX)) FIRSTCHARLP (COND [(IGEQ STARTOFFSET ENDOFFSET) (* ; "End of this chunk") (COND ((EQ STARTSEG ENDSEG) (* ; "failed") (GO FAILED)) (T (* ;  "Finished this segment, roll over into new one") (add STARTSEG 1) (SETQ STARTOFFSET (IDIFFERENCE STARTOFFSET FILEPOS.SEGMENT.SIZE)) (COND ((EQ STARTSEG ENDSEG) (SETQ ENDOFFSET BIGENDOFFSET))) (GO FIRSTCHARLP] ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM))) LASTCHAR) (add STARTOFFSET (SETQ INC (GETBASEBYTE DELTA1 CHAR))) (OR (EQ INC 1) (\INCFILEPTR STREAM (SUB1 INC))) (* ;  "advance file pointer accordingly (\BIN already advanced it one)") (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 MAXPATINDEX)) MATCHLP (COND ((ILESSP CURPATINDEX 0) (GO FOUNDIT))) (\DECFILEPTR STREAM 2) (* ; "back up to read previous char") (COND ((NEQ (SETQ CHAR (GETBASEBYTE CASE (\BIN STREAM))) (GETBASEBYTE PATCHAR CURPATINDEX)) (* ;  "Mismatch, advance by greater of delta1 and delta2") (add STARTOFFSET (IDIFFERENCE (SETQ INC (IMAX (GETBASEBYTE DELTA1 CHAR) (GETBASEBYTE DELTA2 CURPATINDEX))) (IDIFFERENCE MAXPATINDEX CURPATINDEX))) (OR (EQ INC 1) (\INCFILEPTR STREAM (SUB1 INC))) (GO FIRSTCHARLP))) (SETQ CURPATINDEX (SUB1 CURPATINDEX)) (GO MATCHLP) FOUNDIT (* ;  "set fileptr, adjust for beginning skips and return proper value.") (\INCFILEPTR STREAM (COND (TAIL (* ; "Put fileptr at end of string") (SUB1 PATLEN)) (T (* ;  "back up over the last char we looked at, i.e. the first char of string") -1))) (RETURN (\GETFILEPTR STREAM)) FAILED (* ;  "return the fileptr to its initial position.") (\SETFILEPTR STREAM ORGFILEPTR) (RETURN NIL] TRYFILEPOS (RETURN (FILEPOS PATTERN STREAM START END SKIP TAIL CASEARRAY]) (\SETUP.FFILEPOS (LAMBDA (PATBASE PATOFFSET PATLEN PATCHAR DELTA1 DELTA2 CASE) (* jop%: "25-Sep-86 11:44") (* ;;; "Set up PATCHAR, DELTA1 and DELTA2 arrays from string. This is a separate function currently so I can gather stats on it") (PROG ((PATLEN,PATLEN (IPLUS (LLSH PATLEN BITSPERBYTE) PATLEN)) (MAXPATINDEX (SUB1 PATLEN)) CHAR) (for I from 0 to (FOLDLO \MAXCHAR BYTESPERWORD) do (PUTBASE DELTA1 I PATLEN,PATLEN)) (* ;; "DELTA1 initially all PATLEN, the default for chars not in the pattern. I assume array is word-aligned") (for I from 0 to MAXPATINDEX do (PUTBASEBYTE PATCHAR I (SETQ CHAR (GETBASEBYTE CASE (GETBASEBYTE PATBASE (IPLUS PATOFFSET I))))) (* ; "Translate STR now so we don't have to do it repeatedly") (PUTBASEBYTE DELTA1 CHAR (IDIFFERENCE MAXPATINDEX I)) (* ; "DELTA1 = how far ahead to move when we mismatch with this char")) (* ;; "Now set up DELTA2. Scan pattern backwards. For each character, we want to find the rightmost reoccurrence of the substring consisting of the chars to the right of the current char. This is slightly different than Boyer-Moore, in that we do not insist that it be the rightmost reoccurrence that is not preceded by the current char. Small difference, noticeable only in patterns that contain multiple occurrences of tails of the pattern. The following loop calculates DELTA2 in almost the obvious way, using the observation that DELTA2 is strictly increasing (by our definition) as the pattern index decreases. This algorithm is potentially quadratic, as it amounts to searching a string (PATTERN, backwards) for a given substring in the 'dumb' way; fortunately, it is rarely so in practice for 'normal' patterns") (for P from (SUB1 MAXPATINDEX) to 0 by -1 bind (LASTD2 _ 1) (LASTMATCHPOS _ MAXPATINDEX) do (PUTBASEBYTE DELTA2 P (SETQ LASTD2 (COND ((OR (IGEQ LASTD2 PATLEN) (EQ (GETBASEBYTE PATCHAR (IDIFFERENCE MAXPATINDEX LASTD2)) (GETBASEBYTE PATCHAR (ADD1 P)))) (* ;; "The last time around we matched a terminal substring somehow, and now the next char matches the char before that substring, so DELTA2 is just one more, i.e. the match continues. Once we've overflowed the pattern, the 'match' continues trivially") (ADD1 LASTD2)) (T (do (SETQ LASTMATCHPOS (SUB1 LASTMATCHPOS)) repeatuntil (for I from MAXPATINDEX to (ADD1 P) by -1 as J from LASTMATCHPOS to 0 by -1 always (EQ (GETBASEBYTE PATCHAR I) (GETBASEBYTE PATCHAR J)))) (* ; "Substring from P+1 onward matches substring that ends at LASTMATCHPOS") (IPLUS (IDIFFERENCE MAXPATINDEX LASTMATCHPOS) (IDIFFERENCE MAXPATINDEX P))))))))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\FFDELTA1 'RESOURCES '(NEW (ARRAY (ADD1 \MAXCHAR) 'BYTE] [PUTDEF '\FFDELTA2 'RESOURCES '(NEW (ARRAY \MAX.PATTERN.SIZE 'BYTE] [PUTDEF '\FFPATCHAR 'RESOURCES '(NEW (ARRAY \MAX.PATTERN.SIZE 'BYTE] ) (DECLARE%: EVAL@COMPILE (RPAQQ \MAX.PATTERN.SIZE 128) (RPAQQ \MIN.PATTERN.SIZE 3) (RPAQQ FILEPOS.SEGMENT.SIZE 32768) (RPAQQ \MIN.SEARCH.LENGTH 100) (CONSTANTS (\MAX.PATTERN.SIZE 128) (\MIN.PATTERN.SIZE 3) (FILEPOS.SEGMENT.SIZE 32768) (\MIN.SEARCH.LENGTH 100)) ) ) (/SETTOPVAL '\\FFDELTA1.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FFDELTA2.GLOBALRESOURCE NIL) (/SETTOPVAL '\\FFPATCHAR.GLOBALRESOURCE NIL) (* ;; "DATE Functions") (DEFINEQ (DATE (LAMBDA (FORMAT) (* raf "16-Oct-86 17:16") (\OUTDATE (\UNPACKDATE) FORMAT))) (DATEFORMAT (NLAMBDA FORMAT (* raf "16-Oct-86 17:17") (CONS (QUOTE DATEFORMAT) FORMAT))) (GDATE (LAMBDA (DATE FORMAT STRPTR) (* raf "16-Oct-86 17:17") (\OUTDATE (\UNPACKDATE DATE) FORMAT STRPTR))) (IDATE [LAMBDA (STR DEFAULTTIME) (* ; "Edited 17-Apr-2018 10:05 by rmk:") (* ; "Edited 4-May-89 18:22 by bvm") (* ;; "RMK: Fixed so that year < 100 heuristic is changed to add 2000 if < 50, 1900 if >= 50. Y2K guess for 2-digit years") (if (NULL STR) then (DAYTIME) else (PROG ((*STR* (MKSTRING STR)) (*POS* 1) MONTH DAY YEAR HOUR MINUTES SECONDS N1 N2 CH DLS TIMEZONE) (DECLARE (CL:SPECIAL *STR* *POS*)) TOP (OR (SETQ N1 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE) (* ; "Okay to put inside date") (add *POS* 1)) ("," (if (LISTP N1) then (* ;  "Assume str was something like Mon, Apr 1.... Trash the day.") (add *POS* 1) (GO TOP))) ("." (if (LISTP N1) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (OR (SETQ N2 (\IDATESCANTOKEN)) (RETURN NIL)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ((/ - SPACE %,) (add *POS* 1)) ("." (if (LISTP N2) then (* ; "Abbreviated month?") (add *POS* 1))) NIL) (if [NOT (FIXP (SETQ YEAR (\IDATESCANTOKEN] then (RETURN NIL) elseif (< YEAR 100) then (* ; "Y2K heuristic") (add YEAR (if (< YEAR 50) THEN 2000 ELSE 1900)) elseif (OR (< YEAR 1900) (> YEAR 2037)) then (* ; "out of range") (RETURN NIL)) (* ; "Now figure out day and month") (if (FIXP N2) then (* ; "Must be month-day") (SETQ DAY N2) (SETQ MONTH N1) elseif (FIXP (SETQ DAY N1)) then (* ; "day-month") (SETQ MONTH N2) else (RETURN NIL)) (if (FIXP MONTH) then (if (OR (< MONTH 1) (> MONTH 12)) then (* ; "invalid month") (RETURN NIL)) elseif (SETQ MONTH (\IDATE-PARSE-MONTH MONTH)) else (RETURN NIL)) (if (OR (< DAY 1) (> DAY (SELECTQ MONTH ((9 4 6 11) (* ; "30 days hath September...") 30) (2 (if (EVENP YEAR 4) then 29 else 28)) 31))) then (RETURN NIL)) (while (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE SPACE)) do (* ; "Skip spaces") (add *POS* 1)) (SELCHARQ (NTHCHARCODE *STR* *POS*) ("," (* ; "Ok to terminate date with comma") (add *POS* 1)) (NIL (* ;  "No time. Ok if DEFAULTTIME passed in") (if (NULL DEFAULTTIME) then (RETURN NIL)) (SETQ SECONDS (IREMAINDER DEFAULTTIME 60)) (SETQ MINUTES (IREMAINDER (SETQ DEFAULTTIME (IQUOTIENT DEFAULTTIME 60)) 60)) (SETQ HOUR (IQUOTIENT DEFAULTTIME 60)) (GO DONE)) NIL) (* ;; "Now scan time") (if [NOT (FIXP (SETQ HOUR (\IDATESCANTOKEN] then (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm") (add *POS* 1) (OR (FIXP (SETQ MINUTES (\IDATESCANTOKEN))) (RETURN NIL)) (if (EQ (SETQ CH (NTHCHARCODE *STR* *POS*)) (CHARCODE %:)) then (* ; "hh:mm:ss") (add *POS* 1) (OR (FIXP (SETQ SECONDS (\IDATESCANTOKEN))) (RETURN NIL)) (SETQ CH (NTHCHARCODE *STR* *POS*))) else (* ;  "break apart time given without colon") (SETQ MINUTES (IREMAINDER HOUR 100)) (SETQ HOUR (IQUOTIENT HOUR 100))) [if CH then (* ; "There's more") [while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] [if [AND (FMEMB CH (CHARCODE (A P a p))) (FMEMB (NTHCHARCODE *STR* (ADD1 *POS*)) (CHARCODE (M m))) (FMEMB (NTHCHARCODE *STR* (+ *POS* 2)) (CHARCODE (SPACE - NIL] then (* ; "AM or PM appended") (if (NOT (< HOUR 13)) then (* ; "bogus") (RETURN NIL)) (if (EQ HOUR 12) then (* ; "wrap to zero") (SETQ HOUR 0)) (if (FMEMB CH (CHARCODE (P p))) then (* ; "PM = 12 hours later") (add HOUR 12)) (SETQ CH (NTHCHARCODE *STR* (add *POS* 2))) (while (EQ CH (CHARCODE SPACE)) do (* ; "Skip spaces") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] (* ;; "Now check for time zone") [if [AND (EQ CH (CHARCODE -)) (ALPHACHARP (NTHCHARCODE *STR* (ADD1 *POS*] then (* ;  "Some obsolete date forms gave time zone separated from time by hyphen") (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] (SELCHARQ CH ((+ -) (* ; "Explicit offset +-hhmm from GMT") (add *POS* 1) (if [NOT (FIXP (SETQ TIMEZONE (\IDATESCANTOKEN] then (RETURN NIL)) [CL:MULTIPLE-VALUE-BIND (H M) (CL:TRUNCATE TIMEZONE 100) (SETQ TIMEZONE (if (EQ M 0) then H else (* ; "Non-hour timezone. Use ratios.") (+ H (/ M 60] (if (EQ CH (CHARCODE +)) then (* ;  "we represent time zones the other way around, so have to negate") (SETQ TIMEZONE (- TIMEZONE)))) (if (AND CH (ALPHACHARP CH)) then (* ; "Perhaps symbolic time zone") (PROG ((START *POS*)) LP (if [NULL (SETQ CH (NTHCHARCODE *STR* (add *POS* 1] elseif (ALPHACHARP CH) then (GO LP) elseif (EQ CH (CHARCODE SPACE)) then (* ;  "Space may terminate, except that some time zones have space in middle, e.g., EET DST.") (if (AND (SETQ CH (NTHCHARCODE *STR* (ADD1 *POS*))) (ALPHACHARP CH)) then (add *POS* 1) (GO LP)) else (* ; "Non-alphabetic in timezone") (RETURN NIL)) (* ;; "Potential time zone from START to before POS") (SETQ TIMEZONE (SUBSTRING *STR* START (SUB1 *POS*))) (RETURN (SETQ TIMEZONE (for ZONE in TIME.ZONES bind DST do (if (STRING-EQUAL TIMEZONE (CADR ZONE)) then (RETURN (CAR ZONE)) elseif (AND (SETQ DST (CADDR ZONE)) (STRING-EQUAL TIMEZONE DST)) then (* ;  "The daylight equivalent is off by one hour") (RETURN (SUB1 (CAR ZONE] DONE (RETURN (AND (< HOUR 24) (< MINUTES 60) (OR (NOT SECONDS) (< SECONDS 60)) (\PACKDATE YEAR (SUB1 MONTH) DAY HOUR MINUTES (OR SECONDS 0) TIMEZONE]) (\IDATESCANTOKEN [LAMBDA NIL (* ; "Edited 4-May-89 15:20 by bvm") (DECLARE (CL:SPECIAL *STR* *POS*)) (* ;; "Returns next token in STR, starting at POS. Is either an integer or list of alphabetic charcodes. Skips blanks") (PROG (RESULT CH) LP (SETQ CH (NTHCHARCODE *STR* *POS*)) (RETURN (COND ((NULL CH) NIL) ((EQ CH (CHARCODE SPACE)) (* ; "Skip leading spaces") (add *POS* 1) (GO LP)) ((DIGITCHARP CH) (SETQ RESULT (- CH (CHARCODE 0))) [while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (DIGITCHARP CH)) do (SETQ RESULT (+ (- CH (CHARCODE 0)) (TIMES RESULT 10] RESULT) ((ALPHACHARP CH) (CONS (UCASECODE CH) (while (AND (SETQ CH (NTHCHARCODE *STR* (add *POS* 1))) (ALPHACHARP CH)) collect (UCASECODE CH]) (\IDATE-PARSE-MONTH [LAMBDA (MONTH) (* ; "Edited 4-May-89 14:54 by bvm") (* ;; "MONTH is a list of upper case character codes. Figure out which month (1-12) we mean. We require that MONTH be at least 3 characters long and a prefix of month name") (* ;; "These ugly macros produce code, essentially a decision tree, that walks down the list of char codes looking for exactly the right ones.") (CL:MACROLET [[DISCRIMINATE (FORMS) (* ;; "The entry -- start MINCHARS at 3 and turn the month names into char codes. FORMS is quoted list to workaround masterscope stupidity") `(DISCRIMINATE-1 3 ,@(FOR F IN (CADR FORMS) COLLECT (CONS (CHCON (CAR F)) (CDR F] [DISCRIMINATE-1 (MINCHARS &BODY FORMS) (IF (NULL (CDR FORMS)) THEN (* ; "only one case") `[COND ((DISCRIMINATE-2 ,MINCHARS ,(CAAR FORMS)) ,@(CDAR FORMS] ELSE (* ;  "Discriminate on the first code and recur on the tails") (LIST* 'CASE `(CAR CODEVAR) (WHILE FORMS BIND REST C COLLECT (SETQ REST (CL:REMOVE (SETQ C (CAAAR FORMS)) FORMS :KEY 'CAAR)) `(,C (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-1 ,(SUB1 MINCHARS) ,@(FOR F IN (CL:SET-DIFFERENCE FORMS (SETQ FORMS REST)) COLLECT (CONS (CDAR F) (CDR F] (DISCRIMINATE-2 (MINCHARS MATCHLST) (* ;; "True if codes match MATCHLST, with prefix at least MINCHARS long.") (IF (NULL MATCHLST) THEN `(NULL CODEVAR) ELSE (LET [(CODE `(AND (EQ (CAR CODEVAR) ,(POP MATCHLST)) (PROGN (SETQ CODEVAR (CDR CODEVAR)) (DISCRIMINATE-2 ,(SUB1 MINCHARS) ,MATCHLST] (IF (<= MINCHARS 0) THEN (* ; "Ok to match null") `(OR (NULL CODEVAR) ,CODE) ELSE (* ; "Must match exactly so far") CODE] (LET ((CODEVAR MONTH)) (* ;  "This LET is solely to allow more compact code (PVAR_ is one byte less than IVARX_)") (DISCRIMINATE '(("JANUARY" 1) ("FEBRUARY" 2) ("MARCH" 3) ("APRIL" 4) ("MAY" 5) ("JUNE" 6) ("JULY" 7) ("AUGUST" 8) ("SEPTEMBER" 9) ("OCTOBER" 10) ("NOVEMBER" 11) ("DECEMBER" 12]) (\OUTDATE [LAMBDA (UD FORMAT STRING) (* ; "Edited 3-May-2018 00:02 by rmk:") (DESTRUCTURING-BIND (YEAR MONTH DAY HOUR MINUTE SECOND DST WDAY) UD (LET ((SEPR (CHARCODE -)) (HOUR.LENGTH 2) SIZE S N NO.DATE NO.TIME NO.LEADING.SPACES TIME.ZONE TIME.ZONE.LENGTH YEAR.LENGTH MONTH.LENGTH DAY.LENGTH WDAY.LENGTH NO.SECONDS NUMBER.OF.MONTH MONTH.LONG MONTH.LEADING YEAR.LONG DAY.OF.WEEK DAY.SHORT CIVILIAN.TIME) (if (NOT FORMAT) then NIL elseif (NEQ (CAR (LISTP FORMAT)) 'DATEFORMAT) then (LISPERROR "ILLEGAL ARG" FORMAT) else (for TOKEN in FORMAT do (SELECTQ TOKEN (NO.DATE (SETQ NO.DATE T)) (NO.TIME (SETQ NO.TIME T)) (NUMBER.OF.MONTH (SETQ NUMBER.OF.MONTH T)) (YEAR.LONG (SETQ YEAR.LONG T)) (MONTH.LONG (SETQ MONTH.LONG T)) (MONTH.LEADING (SETQ MONTH.LEADING T)) (SLASHES (SETQ SEPR (CHARCODE /))) (SPACES (SETQ SEPR (CHARCODE SPACE))) (NO.LEADING.SPACES (SETQ NO.LEADING.SPACES T)) (TIME.ZONE (SETQ TIME.ZONE (OR [LISTP (CDR (if (FIXP \TimeZoneComp) then (ASSOC \TimeZoneComp TIME.ZONES) else (* ; "Ugh, not a small integer") (CL:ASSOC \TimeZoneComp TIME.ZONES :TEST '=] \TimeZoneComp))) (NO.SECONDS (SETQ NO.SECONDS T)) (DAY.OF.WEEK (SETQ DAY.OF.WEEK T)) (DAY.SHORT (SETQ DAY.SHORT T)) (CIVILIAN.TIME (SETQ CIVILIAN.TIME T)) NIL))) (SETQ YEAR.LONG T) (* ; "RMK: Y2K") [SETQ SIZE (+ (if NO.DATE then 0 else (+ (if MONTH.LEADING then (SETQ SEPR (CHARCODE SPACE)) (SETQ NUMBER.OF.MONTH NIL) (* ; "Will use a comma") 1 else 0) (SETQ MONTH.LENGTH (if NUMBER.OF.MONTH then (* ; "Month input is zero-based") (if (AND (< (add MONTH 1) 10) NO.LEADING.SPACES) then 1 else 2) else [SETQ MONTH (CL:NTH MONTH '("January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December"] (if MONTH.LONG then (NCHARS MONTH) else 3))) (SETQ DAY.LENGTH (if (AND (OR NO.LEADING.SPACES MONTH.LEADING) (< DAY 10)) then 1 else 2)) (SETQ YEAR.LENGTH (if (OR YEAR.LONG (> YEAR 1999)) then 4 else (SETQ YEAR (IREMAINDER YEAR 100)) 2)) (if DAY.OF.WEEK then [SETQ DAY.OF.WEEK (CL:NTH WDAY '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"] [+ 3 (SETQ WDAY.LENGTH (if DAY.SHORT then (* ; "3 letters plus %" ()%"") 3 else (NCHARS DAY.OF.WEEK] else 0) 2)) (if NO.TIME then 0 else (+ (if NO.DATE then 5 else 6) (if NO.SECONDS then 0 else 3) (if CIVILIAN.TIME then (* ; "Use AM/PM") (SETQ CIVILIAN.TIME (if (> HOUR 11) then (* ; "PM") (if (> HOUR 12) then (add HOUR -12)) (CHARCODE p) else (if (EQ HOUR 0) then (SETQ HOUR 12)) (CHARCODE a))) (if (AND (< HOUR 10) NO.LEADING.SPACES) then (SETQ HOUR.LENGTH 1) else 2) else 0) (if (NULL TIME.ZONE) then 0 elseif (NUMBERP TIME.ZONE) then (* ; "Use the -0800 format") 6 else (* ;  "Depends on dst: (normal dst). If missing, we are forced to use numeric format") (SETQ TIME.ZONE (OR (if DST then (CADR TIME.ZONE) else (CAR TIME.ZONE)) \TimeZoneComp)) (ADD1 (SETQ TIME.ZONE.LENGTH (NCHARS TIME.ZONE] (SETQ S (ALLOCSTRING SIZE (CHARCODE SPACE))) (if (NOT NO.DATE) then (if MONTH.LEADING then (* ; "Month day, year") (RPLSTRING S 1 MONTH) (SETQ N MONTH.LENGTH) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N (if (< DAY 10) then 1 else 2)) DAY 1) (RPLCHARCODE S (add N 1) (CHARCODE ",")) else (* ; "Daymonthyear") (\RPLRIGHT S (SETQ N DAY.LENGTH) DAY 1) (RPLCHARCODE S (add N 1) SEPR) (if NUMBER.OF.MONTH then (\RPLRIGHT S (add N MONTH.LENGTH) MONTH MONTH.LENGTH) else (\OUTDATE-STRING S N MONTH (NOT MONTH.LONG)) (add N MONTH.LENGTH))) (RPLCHARCODE S (add N 1) SEPR) (\RPLRIGHT S (add N YEAR.LENGTH) YEAR 2) (OR NO.TIME (add N 1)) [if DAY.OF.WEEK then (* ;  "Day of week at very end in parens") (LET [(START (SUB1 (- SIZE WDAY.LENGTH] (RPLCHARCODE S START (CHARCODE "(")) (\OUTDATE-STRING S START DAY.OF.WEEK DAY.SHORT) (RPLCHARCODE S SIZE (CHARCODE ")"] else (SETQ N 0)) [if (NOT NO.TIME) then (\RPLRIGHT S (add N HOUR.LENGTH) HOUR (if CIVILIAN.TIME then 1 else 2)) (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) MINUTE 2) (if (NOT NO.SECONDS) then (RPLCHARCODE S (ADD1 N) (CHARCODE %:)) (\RPLRIGHT S (add N 3) SECOND 2)) (if CIVILIAN.TIME then (RPLCHARCODE S (ADD1 N) CIVILIAN.TIME) (RPLCHARCODE S (add N 2) (CHARCODE m))) (if TIME.ZONE then (if (NUMBERP TIME.ZONE) then (* ; "+0800 etc") (if DST then (* ;  "Daylight savings is in effect, so time zone is off by an hour") (SETQ TIME.ZONE (SUB1 TIME.ZONE))) (RPLCHARCODE S (+ N 2) (if (<= TIME.ZONE 0) then (* ;  "East of GMT, which is denoted + in this notation") (SETQ TIME.ZONE (- TIME.ZONE)) (CHARCODE +) else (CHARCODE -))) (if (FIXP TIME.ZONE) then (* ; "integral number of hours") (\RPLRIGHT S (+ N 4) TIME.ZONE 2) (RPLSTRING S (+ N 5) "00") else (CL:MULTIPLE-VALUE-BIND (H M) (CL:TRUNCATE TIME.ZONE) (\RPLRIGHT S (+ N 4) H 2) (\RPLRIGHT S (+ N 6) (ROUND (TIMES M 60)) 2))) else (RPLSTRING S (+ N 2) TIME.ZONE] (if STRING then (SUBSTRING S 1 -1 STRING) else S]) (\OUTDATE-STRING [LAMBDA (S N STRING SHORTP) (* ; "Edited 18-May-89 18:38 by bvm") (* ;; "Append STRING to S, using only the first 3 chars if SHORTP is true. N is the index of the last char appended to S. Returns new N") (if SHORTP then (* ; "Use only first 3 chars") (for I from 1 to 3 do (RPLCHARCODE S (+ N I) (NTHCHARCODE STRING I))) else (RPLSTRING S (ADD1 N) STRING]) (\RPLRIGHT (LAMBDA (S AT N MINDIGITS) (* bvm%: "21-NOV-83 17:19") (RPLCHARCODE S AT (IPLUS (CHARCODE 0) (IREMAINDER N 10))) (COND ((OR (IGREATERP MINDIGITS 1) (IGEQ N 10)) (\RPLRIGHT S (SUB1 AT) (IQUOTIENT N 10) (SUB1 MINDIGITS))))) ) (\UNPACKDATE [LAMBDA (D) (* ; "Edited 4-May-89 18:18 by bvm") (* ;; "Converts an internal Lisp date D into a list of integers (Year Month Day Hours Minutes Seconds daylightp DayOfWeek). D defaults to current date. --- DayOfWeek is zero for Monday --- --- D is first converted to the alto standard, a 32-bit unsigned integer, representing the number of seconds since jan 1, 1901-Gmt. We have to be a little tricky in our computations to avoid the sign bit.") (SETQ D (OR D (DAYTIME))) (PROG ((CHECKDLS \DayLightSavings) (DQ (IQUOTIENT (LRSH (LISP.TO.ALTO.DATE D) 1) 30)) MONTH SEC HR DAY4 YDAY WDAY YEAR4 TOTALDAYS MIN DLS FRAC) (* ;  "DQ is number of minutes since day 0, getting us past the sign bit problem.") (SETQ SEC (IMOD [+ D (CONSTANT (- 60 (IMOD MIN.FIXP 60] 60)) (SETQ MIN (IREMAINDER DQ 60)) (* ;; "Now we can adjust to the current time zone. Since this might cause DQ to go negative, first add in 4 years worth of hours, making the base date be Jan 1, 1897") [LET ((ZONE \TimeZoneComp)) (if (NOT (FIXP ZONE)) then (* ;  "Gack, a non-hour offset. Use the integer here, then adjust the minutes, etc.") (CL:MULTIPLE-VALUE-SETQ (ZONE FRAC) (CL:FLOOR ZONE))) (SETQ HR (IREMAINDER (SETQ DQ (- (+ (IQUOTIENT DQ 60) (CONSTANT (ITIMES 24 \4YearsDays))) ZONE)) 24)) (if FRAC then (SETQ FRAC (ROUND (TIMES FRAC -60))) (* ;  "Minutes to add (time zones are never below the minute offset)") (CL:MULTIPLE-VALUE-SETQ (FRAC MIN) (CL:FLOOR (+ MIN FRAC) 60)) (if (NEQ FRAC 0) then (* ; "Adjust the hours") (CL:MULTIPLE-VALUE-SETQ (FRAC HR) (CL:FLOOR (+ HR FRAC) 24] (SETQ TOTALDAYS (IQUOTIENT DQ 24)) (if FRAC then (* ;  "For non-integral time zones, here's the last of the leftover.") (add TOTALDAYS FRAC)) DTLOOP (SETQ DAY4 (IREMAINDER TOTALDAYS \4YearsDays)) (* ;  "DAY4 = number of days since last leap year day 0") [SETQ DAY4 (+ DAY4 (CDR (\DTSCAN DAY4 '((789 . 3) (424 . 2) (59 . 1) (0 . 0](* ;  "pretend every year is a leap year, adding one for days after Feb 28") (SETQ YEAR4 (IQUOTIENT TOTALDAYS \4YearsDays)) (* ;  "YEAR4 = number of years til that last leap year / 4") (SETQ YDAY (IREMAINDER DAY4 366)) (* ;  "YDAY is the ordinal day in the year (jan 1 = zero)") (SETQ WDAY (IREMAINDER (+ TOTALDAYS 3) 7)) (if (AND CHECKDLS (SETQ DLS (\ISDST? YDAY HR WDAY))) then (* ;; "This date is during daylight savings, so add 1 hour. Third arg is day of the week, which we determine by taking days mod 7 plus offset. Monday = zero in this scheme. Jan 1 1897 was actually a Friday (not Thursday=3), but we're cheating--1900 was not a leap year") (if (> (SETQ HR (ADD1 HR)) 23) then (* ;; "overflowed into the next day. This case is too hard (we might have overflowed the month, for example), so just go back and recompute") (SETQ TOTALDAYS (ADD1 TOTALDAYS)) (SETQ HR 0) (SETQ CHECKDLS NIL) (GO DTLOOP))) [SETQ MONTH (\DTSCAN YDAY '((335 . 11) (305 . 10) (274 . 9) (244 . 8) (213 . 7) (182 . 6) (152 . 5) (121 . 4) (91 . 3) (60 . 2) (31 . 1) (0 . 0] (* ;  "Now return year, month, day, hr, min, sec") (RETURN (LIST (+ 1897 (ITIMES YEAR4 4) (IQUOTIENT DAY4 366)) (CDR MONTH) (ADD1 (- YDAY (CAR MONTH))) HR MIN SEC DLS WDAY]) (\PACKDATE [LAMBDA (YR MONTH DAY HR MIN SEC TIMEZONE) (* ; "Edited 22-Mar-88 05:33 by jds") (* ;;  "Packs indicated date into a single integer in Lisp date format. Returns NIL on errors.") (PROG (YDAY DAYSSINCEDAY0) (COND ((NOT (AND YR MONTH DAY HR MIN SEC)) (* ; "Values missing") (RETURN))) (SETQ DAYSSINCEDAY0 (+ (SETQ YDAY (+ (SELECTQ MONTH (0 0) (1 31) (2 59) (3 90) (4 120) (5 151) (6 181) (7 212) (8 243) (9 273) (10 304) (11 334) NIL) (SUB1 DAY))) (TIMES 365 (SETQ YR (- YR 1901))) (IQUOTIENT YR 4))) [COND ((> MONTH 1) (* ; "After February 28") (add YDAY 1) (* ;  "Day-of-year for dst is based on 366-day year") (COND ((AND (EQ 3 (IREMAINDER YR 4)) (NEQ YR -1)) (* ; "It is a leap year, so real day count also incremented. Note that YR is years since 1901 at this point") (add DAYSSINCEDAY0 1] (COND ((OR (< DAYSSINCEDAY0 -1) (< (add HR (TIMES 24 DAYSSINCEDAY0) (COND (TIMEZONE) ((AND \DayLightSavings (\ISDST? YDAY HR (IREMAINDER (+ DAYSSINCEDAY0 1) 7))) (* ;; "Subtract one to go from daylight to standard time. This time we computed weekday based on day 0 = Jan 1, 1901, which was a Tuesday = 1") (SUB1 \TimeZoneComp)) (T \TimeZoneComp))) 0)) (* ;; "Earlier than day 0 -- second check is needed because day 0 west of GMT is sometime during Dec 31, 1900") (RETURN))) (RETURN (+ SEC (PROGN (* ;; "Add the seconds to the converted date, rather than the raw one, and use LLSH instead of multiplying by 60, to avoid creating a bignum") (ALTO.TO.LISP.DATE (LLSH (TIMES 30 (+ MIN (TIMES 60 HR))) 1]) (\DTSCAN (LAMBDA (X L) (* lmm%: 22 NOV 75 1438) (PROG NIL LP (COND ((IGREATERP (CAAR L) X) (SETQ L (CDR L)) (GO LP))) (RETURN (CAR L)))) ) (\ISDST? (LAMBDA (YDAY HOUR WDAY) (* ; "Edited 27-Oct-87 18:51 by bvm:") (* ;; "Returns true if YDAY, HOUR is during the daylight savings period. WDAY is day of week, zero = Monday. YDAY is the ordinal day of the year, pretending it is a leap year, with zero = Jan 1.") (* ;; "Unfortunately, \BeginDST and \EndDST are 1-based and so documented, so we have to convert to zero base inside here.") (AND (\CHECKDSTCHANGE (add YDAY 1) HOUR WDAY \BeginDST) (NOT (\CHECKDSTCHANGE YDAY HOUR WDAY \EndDST)))) ) (\CHECKDSTCHANGE (LAMBDA (YDAY HOUR WDAY DSTDAY) (* bvm%: " 2-NOV-80 15:34") (* ;; "Tests to see if YDAY, HOUR is after the start of daylight (or standard) time. WDAY is the day of the week, Monday=zero. DSTDAY is the last day of the month in which time changes, as a YDAY, usually Apr 30 or Oct 31") (COND ((IGREATERP YDAY DSTDAY) (* ; "Day is in the next month already") T) ((ILESSP YDAY (IDIFFERENCE DSTDAY 6)) (* ; "day is at least a week before end of month, so time hasn't changed yet") NIL) ((EQ WDAY 6) (* ;; "It's Sunday, so time changes today at 2am. Check for hour being past that. Note that there is a hopeless ambiguity when the time is between 1:00 and 2:00 am the day that DST goes into effect, as that hour happens twice") (IGREATERP HOUR 1)) (T (* ; "okay if last Monday (YDAY-WDAY) is less than a week before end of month") (IGREATERP (IDIFFERENCE YDAY WDAY) (IDIFFERENCE DSTDAY 6))))) ) ) (DEFOPTIMIZER DATEFORMAT (&REST X) (KWOTE (CONS 'DATEFORMAT X))) (* ;; "Because DST begins the FIRST weekend in April now, \BeginDST changed from 120 to 98 as of 4/3/87 (JDS) Note: this only affects standalone users--those with time servers automatically get correct local info (bvm)" ) (RPAQ? \TimeZoneComp 8) (RPAQ? \BeginDST 98) (RPAQ? \EndDST 304) (RPAQ? \DayLightSavings T) (ADDTOVAR TIME.ZONES (8 "PST" "PDT") (7 "MST" "MDT") (6 "CST" "CDT") (5 "EST" "EDT") (0 "GMT" "BST") (0 "UT") (-1 "MET" "MET DST") (-2 "EET" "EET DST")) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \BeginDST \EndDST \DayLightSavings TIME.ZONES) ) (DECLARE%: EVAL@COMPILE (RPAQ \4YearsDays (ADD1 (ITIMES 365 4))) [CONSTANTS (\4YearsDays (ADD1 (ITIMES 365 4] ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS IOCHAR FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA DATEFORMAT) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PACK* CONCAT) ) (PUTPROPS IOCHAR COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 2018 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3507 7301 (CHCON 3517 . 4367) (UNPACK 4369 . 5263) (DCHCON 5265 . 6532) (DUNPACK 6534 . 7299)) (7302 18817 (UALPHORDER 7312 . 7408) (ALPHORDER 7410 . 9213) (CONCAT 9215 . 9860) ( CONCATCODES 9862 . 10048) (PACKC 10050 . 12653) (PACK 12655 . 13234) (PACK* 13236 . 14958) (\PACK.ITEM 14960 . 15415) (STRPOS 15417 . 18815)) (18819 19108 (XCL:PACK 18819 . 19108)) (19110 19360 (XCL:PACK* 19110 . 19360)) (20078 22469 (STRPOSL 20088 . 21714) (MAKEBITTABLE 21716 . 22467)) (22631 23108 ( CASEARRAY 22641 . 22831) (UPPERCASEARRAY 22833 . 23106)) (23430 47032 (FILEPOS 23440 . 33352) ( FFILEPOS 33354 . 44467) (\SETUP.FFILEPOS 44469 . 47030)) (47820 89067 (DATE 47830 . 47916) (DATEFORMAT 47918 . 48010) (GDATE 48012 . 48123) (IDATE 48125 . 59796) (\IDATESCANTOKEN 59798 . 61077) ( \IDATE-PARSE-MONTH 61079 . 64775) (\OUTDATE 64777 . 77525) (\OUTDATE-STRING 77527 . 78142) (\RPLRIGHT 78144 . 78382) (\UNPACKDATE 78384 . 84175) (\PACKDATE 84177 . 87497) (\DTSCAN 87499 . 87641) (\ISDST? 87643 . 88150) (\CHECKDSTCHANGE 88152 . 89065))))) STOP \ No newline at end of file diff --git a/sources/LEAF b/sources/LEAF new file mode 100644 index 00000000..b23edd67 --- /dev/null +++ b/sources/LEAF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:41:31" {DSK}lde>lispcore>sources>LEAF.;2 745474Q changes to%: (RECORDS SEQUINPACKET SEQUIN LOOKUPFILEDATA LEAFDATA LEAFERRORDATA LEAFPARAMSDATA LEAFPACKET LEAFINFOBLOCK LEAFSTREAM LEAFDEVICE PUPFILESERVER) previous date%: " 4-Jan-93 23:36:15" {DSK}lde>lispcore>sources>LEAF.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LEAFCOMS) (RPAQQ LEAFCOMS ( (* ;;; "Support for the Leaf random-access filing protocol") (E (RESETSAVE (RADIX 8))) (COMS (* ;; "SEQUIN protocol") (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * SEQUINCOMS) (FILES (LOADCOMP) TCPHTE)) (INITRECORDS SEQUIN) (SYSRECORDS SEQUIN) (FNS CLOSESEQUIN INITSEQUIN GETSEQUIN PUTSEQUIN) (FNS \SEQUIN.CONTROL \SEQUIN.PUT \SEQUIN.PROCESS \SEQUIN.CLOSE \SEQUIN.FLUSH.CONNECTION \SEQUIN.CLEANUP \SEQUIN.FLUSH.RETRANSMIT \SEQUIN.COMPARE \SEQUIN.HANDLE.INPUT \SEQUIN.OUT.OF.THE.BLUE \SEQUIN.HANDLE.ACK \SEQUIN.RETRANSMIT \SEQUIN.RETRANSMITNEXT)) (COMS (* ;; "LEAF device operations") (FNS \LEAF.CLOSEFILE \LEAF.DELETEFILE \LEAF.DEVICEP \LEAF.RECONNECT \LEAF.DIRECTORYNAMEP \LEAF.GENERATEFILES \LEAF.GETFILE \PARSE.REMOTE.FILENAME \LEAF.STRIP.QUOTES \LEAF.GETFILEDATES \LEAF.GETFILEINFO \LEAF.GETFILEINFO.OPEN \LEAF.GETFILENAME \LEAF.OPENFILE \LEAF.READFILENAME \LEAF.ADD.QUOTES \LEAF.READFILEPROP \LEAF.READPAGES \LEAF.REQUESTPAGE \LEAF.LOOKUPCACHE CLEAR.LEAF.CACHE LEAF.ASSURE.FINISHED \LEAF.FORCEOUTPUT \LEAF.FLUSH.CACHE \LEAF.RENAMEFILE \LEAF.REOPENFILE \LEAF.CREATIONDATE \LEAF.SETCREATIONDATE \LEAF.SETFILEINFO \LEAF.SETFILETYPE \LEAF.SETVALIDATION \LEAF.TRUNCATEFILE \LEAF.WRITEPAGES)) (COMS (* ;; "Main routing point for LEAF pups") (FNS \SENDLEAF)) (COMS (* ;; "Managing LEAF connections") (FNS \OPENLEAFCONNECTION \LEAF.BREAKCONNECTION \CLOSELEAFCONNECTION \LEAF.EVENTFN) (* ;  "This generic fn ought to be on FILEIO") (FNS BREAKCONNECTION)) (COMS (* ;; "Functions called when various SEQUIN events occur") (FNS \LEAF.ACKED \LEAF.FIX.BROKEN.SEQUIN \LEAF.REPAIR.BROKEN.PUP \LEAF.USE.NEW.CONNECTION \LEAF.RESENDPUPS \LEAF.HANDLE.INPUT \LEAF.OPENERRORHANDLER \LEAF.TIMEDIN \LEAF.TIMEDOUT \LEAF.NOT.RESPONDING \LEAF.TIMEDOUT.EXCESSIVE \LEAF.ABORT.FROMMENU \LEAF.STREAM.IN.QUEUE \LEAF.IDLE \LEAF.MAYBE.FLUSH.CACHE \LEAF.WHENCLOSED \LEAF.IDLE?)) (ADDVARS (NETWORKOSTYPES)) (COMS (* ;; "Miscellaneous and error handling") (FNS \ADDLEAFSTRING \FIXPASSWORD \GETLEAFSTRING \IFSERRORSTRING \LEAF.ERROR \LEAF.DIRECTORYNAMEONLY GETHOSTINFO GETOSTYPE EXPANDING-PAGEFULLFN) (VARS (DEFAULT.OSTYPE 'IFS)) (GLOBALVARS DEFAULT.OSTYPE)) (COMS (* ;; "LookUpFile stuff") (FNS \IFS.LOOKUPFILE) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * LOOKUPFILECOMS))) [COMS (FNS \LEAFINIT) (DECLARE%: DONTEVAL@LOAD (P (\LEAFINIT] (COMS (FNS PRINTLEAF) (ALISTS (PUPPRINTMACROS 176))) (INITVARS (LEAFDEBUGFLG) (LEAFABORTREGION '(417 616 399 192)) (\MAXLEAFTRIES 4) (NOFILEPROPERROR) (DEFAULTFILETYPE 'TEXT) (\SOCKET.LEAF 35) (\SEQUIN.TIMEOUTMAX 10000) (\LEAF.IDLETIMEOUT 1800000) (\LEAF.CACHETIMEOUT 90000) (\LEAF.MAXCACHE 10) (\LEAF.RECOVERY.TIMEOUT 600000) (\LEAF.MAXLOOKAHEAD 4) (\FTPAVAILABLE) (UNIXFTPFLG) (NONLEAFHOSTS) (*UPPER-CASE-FILE-NAMES* T)) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * LEAFCOMPILETIMECOMS)) (INITRECORDS PUPFILESERVER) (SYSRECORDS PUPFILESERVER))) (* ;;; "Support for the Leaf random-access filing protocol") (* ;; "SEQUIN protocol") (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ SEQUINCOMS ((RECORDS SEQUINPACKET SEQUIN) (CONSTANTS * SEQUINOPS) (CONSTANTS * SEQUINSTATES) (CONSTANTS (\SC.EQUAL 0) (\SC.PREVIOUS 1) (\SC.DUPLICATE 2) (\SC.AHEAD 3) (\SC.OUTOFRANGE 4) (\PT.SEQUIN 260Q) (\SS.NOSOCKET 10Q) (\SEQUIN.DEFAULT.ALLOCATION 12Q) (\SEQUIN.DEFAULT.RETRANSMITMAX 5)) (MACROS SEQUINOP))) (DECLARE%: EVAL@COMPILE (ACCESSFNS SEQUINPACKET ((SEQUINSTART (fetch PUPBASE of DATUM))) (BLOCKRECORD SEQUINSTART ((NIL 2 WORD) (* ; "Pup length, typeword") (ALLOCATE BYTE) (RECEIVESEQ BYTE) (SEQCONTROL BYTE) (SENDSEQ BYTE) (* ;  "Sequin uses ID fields of PUP for control info") ))) (DATATYPE SEQUIN ( (* ;; "First: stuff used by SEQUIN level") (SEQNAME POINTER) (* ; "Name of partner") (SEQFRNPORT POINTER) (* ; "Foreign socket") (SEQSOCKET POINTER) (* ; "Local socket") (SEQSTATE BYTE) (* ; "Sequin connection state") (MYSENDSEQ BYTE) (* ;  "Number I will next send. These must be byte fields so that they will wrap around correctly!") (MYRECEIVESEQ BYTE) (* ;  "Number I next expect to receive, i.e. Partner's Send number of first unacked packet") (LASTACKEDSEQ BYTE) (* ;  "Last Receive seq from partner: all packets with sequence numbers before this one have been acked") (SEQOUTALLOC WORD) (* ;  "Output allocation: the number of packets I may send without their being acked") (SEQINALLOC WORD) (* ;  "Input allocation: what I tell my partner") (SEQMAXALLOC WORD) (* ;  "The largest I will let output allocation get") (%#UNACKEDSEQS WORD) (* ;  "Number of data packets we have sent for which no acks have been received") (SEQINPUTQLENGTH WORD) (* ;  "Number of packets in input (done) queue") (SEQTIMEOUT WORD) (* ; "Timeout before retransmission") (SEQBASETIMEOUT WORD) (* ;  "Timeout for this connection in general") (SEQRETRANSMITMAX WORD) (* ;  "How many times to retransmit before complaining") (%#SEQRESTARTS WORD) (* ; "Some statistical info...") (%#SEQRETRANSMITS WORD) (%#SEQDUPLICATES WORD) (%#SEQTIMEOUTS WORD) (%#SEQTURNOVERS WORD) (SEQRETRANSMITQ POINTER) (* ; "Sequin output queue") (SEQTIMER POINTER) (SEQPROCESS POINTER) (SEQIGNOREDUPLICATES FLAG) (SEQRETRANSMITTING FLAG) (SEQCLOSEME FLAG) (SEQCLOSEDFORLOGOUT FLAG) (SEQLASTRESTARTTIMER POINTER) (* ;  "Allows for some aging of the connection timeout") (SEQLASTRESTART POINTER) (SEQRETRANSMITNEXT POINTER) (SEQEVENT POINTER) (* ;  "Signaled when there is input, state changed, or allocation changed") (SEQLOCK POINTER) (* ; "Monitor lock for this structure") (* ;; "Second-level functions invoked by SEQUIN") (SEQACKED POINTER) (* ;  "(PUP SEQUIN) called when PUP is acked") (SEQINPUT POINTER) (* ;  "(PUP SEQUIN) called when PUP arrives as input data") (SEQBROKEN POINTER) (* ; "(SEQUIN PUP) called when a BROKEN sequin arrives (PUP = NIL) or attempt to send PUP on broken connection") (SEQABORTED POINTER) (* ;  "(SEQUIN) called when PUP arrives with outlandish sequence numbers") (SEQTIMEDOUT POINTER) (* ;  "(SEQUIN) called when about to retransmit SEQRETRANSMITMAX times") (SEQCLOSED POINTER) (* ;  "(SEQUIN) called when a connection is flushed, but before its retransmit queue is flushed") (SEQIDLETIMEOUTCOMPUTER POINTER) (* ; "Computes timeout before calling SEQIDLEFN when no activity on connection. T means forever, NIL means don't") (SEQIDLEFN POINTER) (* ;  "Called when nothing otherwise is happening, after timeout of SEQIDLETIMEOUT") (* ;; "Stuff used by clients of SEQUIN, in particular, LEAF") (SEQDONEQ POINTER) (* ;  "Sequins acked but kept around for further handling") (NIL POINTER) (NIL POINTER) (LEAFCACHEDFILE POINTER) (* ;  "Last file accessed, to speed up repeated lookups of same name") (LEAFCACHETIMER POINTER) (* ; "To timeout the cache") (LEAFCACHEHITS WORD) (LEAFCACHEMISSES WORD) (LEAFTIMEOUTCOUNT WORD) (LEAFCLOSING FLAG) (LEAFOPENCLOSELOCK POINTER) (* ;  "Monitor lock to keep GETFILE and CLOSEFILE from stepping on each other") (LEAFABORTBUTTONWINDOW POINTER) (LEAFABORTSTATUS POINTER) (LEAFTIMEOUTSTATUS POINTER) (SEQTIMEDIN POINTER) (NIL POINTER) (SEQOPENERRORHANDLER POINTER) (* ;  "(SEQUIN PUP) called on errors trying to open connection") ) SEQSTATE _ \SS.UNOPENED SEQOUTALLOC _ 1 SEQINALLOC _ \SEQUIN.DEFAULT.ALLOCATION SEQRETRANSMITMAX _ \SEQUIN.DEFAULT.RETRANSMITMAX SEQRETRANSMITQ _ (NCREATE 'SYSQUEUE) SEQTIMEOUT _ \ETHERTIMEOUT SEQBASETIMEOUT _ \ETHERTIMEOUT SEQTIMER _ (\CREATECELL \FIXP) SEQLASTRESTARTTIMER _ (\CREATECELL \FIXP) SEQMAXALLOC _ 12Q SEQACKED _ (FUNCTION NILL) SEQBROKEN _ (FUNCTION NILL) SEQABORTED _ (FUNCTION NILL) SEQABORTED _ (FUNCTION NILL) SEQTIMEDOUT _ (FUNCTION NILL) SEQCLOSED _ (FUNCTION NILL) SEQIDLETIMEOUTCOMPUTER _ (FUNCTION NILL) SEQIDLEFN _ (FUNCTION NILL) SEQTIMEDIN _ (FUNCTION NILL) SEQOPENERRORHANDLER _ (FUNCTION NILL) (SYNONYM SEQDONEQ (INPUTQ))) ) (/DECLAREDATATYPE 'SEQUIN '(POINTER POINTER POINTER BYTE BYTE BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 207Q)) (SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 207Q)) (SEQUIN 10Q (BITS . 17Q)) (SEQUIN 11Q (BITS . 17Q)) (SEQUIN 12Q (BITS . 17Q)) (SEQUIN 13Q (BITS . 17Q)) (SEQUIN 14Q (BITS . 17Q)) (SEQUIN 15Q (BITS . 17Q)) (SEQUIN 16Q (BITS . 17Q)) (SEQUIN 17Q (BITS . 17Q)) (SEQUIN 20Q (BITS . 17Q)) (SEQUIN 21Q (BITS . 17Q)) (SEQUIN 22Q (BITS . 17Q)) (SEQUIN 23Q (BITS . 17Q)) (SEQUIN 24Q (BITS . 17Q)) (SEQUIN 26Q POINTER) (SEQUIN 30Q POINTER) (SEQUIN 32Q POINTER) (SEQUIN 32Q (FLAGBITS . 0)) (SEQUIN 32Q (FLAGBITS . 20Q)) (SEQUIN 32Q (FLAGBITS . 40Q)) (SEQUIN 32Q (FLAGBITS . 60Q)) (SEQUIN 34Q POINTER) (SEQUIN 36Q POINTER) (SEQUIN 40Q POINTER) (SEQUIN 42Q POINTER) (SEQUIN 44Q POINTER) (SEQUIN 46Q POINTER) (SEQUIN 50Q POINTER) (SEQUIN 52Q POINTER) (SEQUIN 54Q POINTER) (SEQUIN 56Q POINTER) (SEQUIN 60Q POINTER) (SEQUIN 62Q POINTER) (SEQUIN 64Q POINTER) (SEQUIN 66Q POINTER) (SEQUIN 70Q POINTER) (SEQUIN 72Q POINTER) (SEQUIN 74Q POINTER) (SEQUIN 76Q POINTER) (SEQUIN 25Q (BITS . 17Q)) (SEQUIN 100Q (BITS . 17Q)) (SEQUIN 101Q (BITS . 17Q)) (SEQUIN 76Q (FLAGBITS . 0)) (SEQUIN 102Q POINTER) (SEQUIN 104Q POINTER) (SEQUIN 106Q POINTER) (SEQUIN 110Q POINTER) (SEQUIN 112Q POINTER) (SEQUIN 114Q POINTER) (SEQUIN 116Q POINTER)) '120Q) (RPAQQ SEQUINOPS ((\SEQUIN.DATA 0) (\SEQUIN.ACK 1) (\SEQUIN.NOOP 2) (\SEQUIN.RESTART 3) (\SEQUIN.OPEN 5) (\SEQUIN.BREAK 6) (\SEQUIN.OBSOLETE.CLOSE 7) (\SEQUIN.DESTROY 11Q) (\SEQUIN.DALLYING 12Q) (\SEQUIN.QUIT 13Q) (\SEQUIN.BROKEN 14Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \SEQUIN.DATA 0) (RPAQQ \SEQUIN.ACK 1) (RPAQQ \SEQUIN.NOOP 2) (RPAQQ \SEQUIN.RESTART 3) (RPAQQ \SEQUIN.OPEN 5) (RPAQQ \SEQUIN.BREAK 6) (RPAQQ \SEQUIN.OBSOLETE.CLOSE 7) (RPAQQ \SEQUIN.DESTROY 11Q) (RPAQQ \SEQUIN.DALLYING 12Q) (RPAQQ \SEQUIN.QUIT 13Q) (RPAQQ \SEQUIN.BROKEN 14Q) (CONSTANTS (\SEQUIN.DATA 0) (\SEQUIN.ACK 1) (\SEQUIN.NOOP 2) (\SEQUIN.RESTART 3) (\SEQUIN.OPEN 5) (\SEQUIN.BREAK 6) (\SEQUIN.OBSOLETE.CLOSE 7) (\SEQUIN.DESTROY 11Q) (\SEQUIN.DALLYING 12Q) (\SEQUIN.QUIT 13Q) (\SEQUIN.BROKEN 14Q)) ) (RPAQQ SEQUINSTATES ((\SS.UNOPENED 0) (\SS.OPEN 1) (\SS.DALLYING 2) (\SS.ABORT 3) (\SS.DESTROYED 4) (\SS.TIMEDOUT 5) (\SS.CLOSING 6) (\SS.OPENING 7) (\SS.CLOSED 10Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \SS.UNOPENED 0) (RPAQQ \SS.OPEN 1) (RPAQQ \SS.DALLYING 2) (RPAQQ \SS.ABORT 3) (RPAQQ \SS.DESTROYED 4) (RPAQQ \SS.TIMEDOUT 5) (RPAQQ \SS.CLOSING 6) (RPAQQ \SS.OPENING 7) (RPAQQ \SS.CLOSED 10Q) (CONSTANTS (\SS.UNOPENED 0) (\SS.OPEN 1) (\SS.DALLYING 2) (\SS.ABORT 3) (\SS.DESTROYED 4) (\SS.TIMEDOUT 5) (\SS.CLOSING 6) (\SS.OPENING 7) (\SS.CLOSED 10Q)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \SC.EQUAL 0) (RPAQQ \SC.PREVIOUS 1) (RPAQQ \SC.DUPLICATE 2) (RPAQQ \SC.AHEAD 3) (RPAQQ \SC.OUTOFRANGE 4) (RPAQQ \PT.SEQUIN 260Q) (RPAQQ \SS.NOSOCKET 10Q) (RPAQQ \SEQUIN.DEFAULT.ALLOCATION 12Q) (RPAQQ \SEQUIN.DEFAULT.RETRANSMITMAX 5) (CONSTANTS (\SC.EQUAL 0) (\SC.PREVIOUS 1) (\SC.DUPLICATE 2) (\SC.AHEAD 3) (\SC.OUTOFRANGE 4) (\PT.SEQUIN 260Q) (\SS.NOSOCKET 10Q) (\SEQUIN.DEFAULT.ALLOCATION 12Q) (\SEQUIN.DEFAULT.RETRANSMITMAX 5)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS SEQUINOP MACRO ((SEQ OP . ARGS) (APPLY* (fetch (SEQUIN OP) of SEQ) . ARGS] ) (FILESLOAD (LOADCOMP) TCPHTE) ) (/DECLAREDATATYPE 'SEQUIN '(POINTER POINTER POINTER BYTE BYTE BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SEQUIN 0 POINTER) (SEQUIN 2 POINTER) (SEQUIN 4 POINTER) (SEQUIN 6 (BITS . 7)) (SEQUIN 6 (BITS . 207Q)) (SEQUIN 7 (BITS . 7)) (SEQUIN 7 (BITS . 207Q)) (SEQUIN 10Q (BITS . 17Q)) (SEQUIN 11Q (BITS . 17Q)) (SEQUIN 12Q (BITS . 17Q)) (SEQUIN 13Q (BITS . 17Q)) (SEQUIN 14Q (BITS . 17Q)) (SEQUIN 15Q (BITS . 17Q)) (SEQUIN 16Q (BITS . 17Q)) (SEQUIN 17Q (BITS . 17Q)) (SEQUIN 20Q (BITS . 17Q)) (SEQUIN 21Q (BITS . 17Q)) (SEQUIN 22Q (BITS . 17Q)) (SEQUIN 23Q (BITS . 17Q)) (SEQUIN 24Q (BITS . 17Q)) (SEQUIN 26Q POINTER) (SEQUIN 30Q POINTER) (SEQUIN 32Q POINTER) (SEQUIN 32Q (FLAGBITS . 0)) (SEQUIN 32Q (FLAGBITS . 20Q)) (SEQUIN 32Q (FLAGBITS . 40Q)) (SEQUIN 32Q (FLAGBITS . 60Q)) (SEQUIN 34Q POINTER) (SEQUIN 36Q POINTER) (SEQUIN 40Q POINTER) (SEQUIN 42Q POINTER) (SEQUIN 44Q POINTER) (SEQUIN 46Q POINTER) (SEQUIN 50Q POINTER) (SEQUIN 52Q POINTER) (SEQUIN 54Q POINTER) (SEQUIN 56Q POINTER) (SEQUIN 60Q POINTER) (SEQUIN 62Q POINTER) (SEQUIN 64Q POINTER) (SEQUIN 66Q POINTER) (SEQUIN 70Q POINTER) (SEQUIN 72Q POINTER) (SEQUIN 74Q POINTER) (SEQUIN 76Q POINTER) (SEQUIN 25Q (BITS . 17Q)) (SEQUIN 100Q (BITS . 17Q)) (SEQUIN 101Q (BITS . 17Q)) (SEQUIN 76Q (FLAGBITS . 0)) (SEQUIN 102Q POINTER) (SEQUIN 104Q POINTER) (SEQUIN 106Q POINTER) (SEQUIN 110Q POINTER) (SEQUIN 112Q POINTER) (SEQUIN 114Q POINTER) (SEQUIN 116Q POINTER)) '120Q) (ADDTOVAR SYSTEMRECLST (DATATYPE SEQUIN ((SEQNAME POINTER) (SEQFRNPORT POINTER) (SEQSOCKET POINTER) (SEQSTATE BYTE) (MYSENDSEQ BYTE) (MYRECEIVESEQ BYTE) (LASTACKEDSEQ BYTE) (SEQOUTALLOC WORD) (SEQINALLOC WORD) (SEQMAXALLOC WORD) (%#UNACKEDSEQS WORD) (SEQINPUTQLENGTH WORD) (SEQTIMEOUT WORD) (SEQBASETIMEOUT WORD) (SEQRETRANSMITMAX WORD) (%#SEQRESTARTS WORD) (%#SEQRETRANSMITS WORD) (%#SEQDUPLICATES WORD) (%#SEQTIMEOUTS WORD) (%#SEQTURNOVERS WORD) (SEQRETRANSMITQ POINTER) (SEQTIMER POINTER) (SEQPROCESS POINTER) (SEQIGNOREDUPLICATES FLAG) (SEQRETRANSMITTING FLAG) (SEQCLOSEME FLAG) (SEQCLOSEDFORLOGOUT FLAG) (SEQLASTRESTARTTIMER POINTER) (SEQLASTRESTART POINTER) (SEQRETRANSMITNEXT POINTER) (SEQEVENT POINTER) (SEQLOCK POINTER) (SEQACKED POINTER) (SEQINPUT POINTER) (SEQBROKEN POINTER) (SEQABORTED POINTER) (SEQTIMEDOUT POINTER) (SEQCLOSED POINTER) (SEQIDLETIMEOUTCOMPUTER POINTER) (SEQIDLEFN POINTER) (SEQDONEQ POINTER) (NIL POINTER) (NIL POINTER) (LEAFCACHEDFILE POINTER) (LEAFCACHETIMER POINTER) (LEAFCACHEHITS WORD) (LEAFCACHEMISSES WORD) (LEAFTIMEOUTCOUNT WORD) (LEAFCLOSING FLAG) (LEAFOPENCLOSELOCK POINTER) (LEAFABORTBUTTONWINDOW POINTER) (LEAFABORTSTATUS POINTER) (LEAFTIMEOUTSTATUS POINTER) (SEQTIMEDIN POINTER) (NIL POINTER) (SEQOPENERRORHANDLER POINTER))) ) (DEFINEQ (CLOSESEQUIN [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:51 by jds") (* ;;; "Function called to initiate a close connection for a sequin.") (PROG NIL (\SEQUIN.CLOSE SEQUIN) BLK (AWAIT.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN) \ETHERTIMEOUT) (SELECTC (fetch (SEQUIN SEQSTATE) of SEQUIN) (\SS.CLOSED (RETURN T)) (\SS.CLOSING NIL) (RETURN NIL)) (GO BLK]) (INITSEQUIN [LAMBDA (SEQUIN PROCNAME) (* ; "Edited 24-May-91 14:51 by jds") (replace (SEQUIN SEQSOCKET) of SEQUIN with (OPENPUPSOCKET)) (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.UNOPENED) (replace (SEQUIN SEQLOCK) of SEQUIN with (CREATE.MONITORLOCK PROCNAME)) (replace (SEQUIN SEQEVENT) of SEQUIN with (CREATE.EVENT PROCNAME)) (replace (SEQUIN MYSENDSEQ) of SEQUIN with 0) (replace (SEQUIN MYRECEIVESEQ) of SEQUIN with 0) (replace (SEQUIN LASTACKEDSEQ) of SEQUIN with 0) (replace (SEQUIN SEQOUTALLOC) of SEQUIN with 1) (replace (SEQUIN %#UNACKEDSEQS) of SEQUIN with 0) (replace (SEQUIN %#SEQRESTARTS) of SEQUIN with 0) (replace (SEQUIN %#SEQDUPLICATES) of SEQUIN with 0) (replace (SEQUIN %#SEQTIMEOUTS) of SEQUIN with 0) (replace (SEQUIN %#SEQRETRANSMITS) of SEQUIN with 0) (replace (SEQUIN %#SEQTURNOVERS) of SEQUIN with 0) (replace (SEQUIN SEQPROCESS) of SEQUIN with (ADD.PROCESS (LIST '\SEQUIN.PROCESS SEQUIN) 'NAME PROCNAME 'RESTARTABLE 'SYSTEM 'AFTEREXIT 'DELETE]) (GETSEQUIN [LAMBDA (SEQUIN) (* bvm%: "10-APR-83 13:26") (* ;;; "Function to receive sequin packets on SEQUIN.") (PROG (PACKET) CL:LOOP (COND ((SETQ PACKET (\DEQUEUE (fetch (SEQUIN INPUTQ) of SEQUIN))) (* (add (fetch (SEQUIN INPUTC) of  SEQUIN) -1)) (* (SEQUIN/CONTROL SEQUIN  \SEQUIN.ACK)) (RETURN PACKET)) ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPEN) (BLOCK) (GO CL:LOOP)) (T (RETURN]) (PUTSEQUIN [LAMBDA (SEQUIN OPUP DONTWAIT) (* ; "Edited 24-May-91 14:52 by jds") (PROG1 (WITH.MONITOR (fetch (SEQUIN SEQLOCK) of SEQUIN) (until (AND (SELECTC (fetch (SEQUIN SEQSTATE) of SEQUIN) (\SS.OPEN (replace (SEQUINPACKET SEQCONTROL) of OPUP with \SEQUIN.DATA) T) (\SS.UNOPENED (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.OPENING) (replace (SEQUINPACKET SEQCONTROL) of OPUP with \SEQUIN.OPEN) T) (\SS.OPENING NIL) (RETURN (PUTSEQUIN (OR (SEQUINOP SEQUIN SEQBROKEN SEQUIN OPUP) (RETURN OPUP)) OPUP))) (ILESSP (fetch (SEQUIN %#UNACKEDSEQS) of SEQUIN) (fetch (SEQUIN SEQOUTALLOC) of SEQUIN)) (ILEQ (fetch (SEQUIN SEQINPUTQLENGTH) of SEQUIN) (fetch (SEQUIN SEQINALLOC) of SEQUIN)) (COND ((NOT (fetch (SEQUIN SEQRETRANSMITTING) of SEQUIN)) T) (T (* ;; "Should never happen, because \SEQUIN.PROCESS does not relinquish the lock. Test is here for debugging") (COND (LEAFDEBUGFLG (HELP "lock obtained while retransmitting" SEQUIN))) NIL))) do (COND (DONTWAIT (RETURN))) (MONITOR.AWAIT.EVENT (fetch (SEQUIN SEQLOCK) of SEQUIN) (fetch (SEQUIN SEQEVENT) of SEQUIN) \ETHERTIMEOUT) finally (\SEQUIN.PUT SEQUIN OPUP T) (RETURN SEQUIN))) (BLOCK]) ) (DEFINEQ (\SEQUIN.CONTROL [LAMBDA (SEQUIN CONTROL PUP) (* ; "Edited 23-Dec-87 16:42 by bvm:") (* ;;; "Routine to send a control sequin of type CONTROL to the other end") [COND (PUP (* ;  "Clear source net,host,socket so that SENDPUP will fill them in with the truth.") (\CLEARBYTES (LOCF (fetch PUPSOURCE of PUP)) 0 6)) (T (SETQ PUP (ALLOCATE.PUP] (replace PUPLENGTH of PUP with \PUPOVLEN) (replace (SEQUINPACKET SEQCONTROL) of PUP with CONTROL) (\SEQUIN.PUT SEQUIN PUP]) (\SEQUIN.PUT [LAMBDA (SEQUIN PUP ISDATA) (* ; "Edited 24-May-91 14:52 by jds") (replace PUPTYPE of PUP with \PT.SEQUIN) (replace PUPDEST of PUP with (CAR (fetch (SEQUIN SEQFRNPORT) of SEQUIN))) (replace PUPDESTSOCKET of PUP with (CDR (fetch (SEQUIN SEQFRNPORT) of SEQUIN) )) (UNINTERRUPTABLY (PROG ((SENDSEQ (fetch (SEQUIN MYSENDSEQ) of SEQUIN))) (replace (SEQUINPACKET RECEIVESEQ) of PUP with (fetch (SEQUIN MYRECEIVESEQ ) of SEQUIN)) (replace (SEQUINPACKET SENDSEQ) of PUP with SENDSEQ) [COND (ISDATA [replace (SEQUIN MYSENDSEQ) of SEQUIN with (COND ((EQ SENDSEQ 377Q) (add (fetch (SEQUIN %#SEQTURNOVERS) of SEQUIN) 1) 0) (T (ADD1 SENDSEQ] (* ;; "Data packets increment the send sequence, and we have to keep them around for possible retransmission") (replace EPREQUEUE of PUP with (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN)) (add (fetch (SEQUIN %#UNACKEDSEQS) of SEQUIN) 1)) (T (replace EPREQUEUE of PUP with 'FREE] (replace (SEQUINPACKET ALLOCATE) of PUP with (fetch (SEQUIN SEQINALLOC) of SEQUIN)) (SENDPUP (fetch (SEQUIN SEQSOCKET) of SEQUIN) PUP) (\CLOCK0 (fetch (SEQUIN SEQTIMER) of SEQUIN)) (* ;; "Make sure the SEQUIN watcher runs. It might be in its long idle phase, and if no packets arrive on its socket, it won't wake up to notice that remote host is not responding") (WAKE.PROCESS (fetch (SEQUIN SEQPROCESS) of SEQUIN))))]) (\SEQUIN.PROCESS [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (DECLARE (SPECVARS SEQUIN)) (WITH.MONITOR (fetch (SEQUIN SEQLOCK) of SEQUIN) (RESETSAVE NIL (LIST (FUNCTION \SEQUIN.CLEANUP) SEQUIN)) [PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION (LAMBDA NIL (INSPECT SEQUIN] (PROG ((SOC (fetch (SEQUIN SEQSOCKET) of SEQUIN)) (RETRANSQ (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN)) (CNT 0) RETRANSMITINCREMENT PUP SOCEVENT TIMEOUT REASON) (COND ((NOT SOC) (* ; "Sequin was killed") (RETURN))) (SETQ SOCEVENT (PUPSOCKETEVENT SOC)) LP [COND ((fetch (SEQUIN SEQCLOSEME) of SEQUIN) (RETURN)) ((SETQ PUP (GETPUP SOC)) (SELECTC (fetch PUPTYPE of PUP) (\PT.SEQUIN (COND ((\SEQUIN.HANDLE.INPUT SEQUIN PUP) (* ; "Something interesting happened") ))) (\PT.ERROR [COND ((EQ PUPTRACEFLG 'PEEK) (PRINTPUP PUP 'GET] [COND ((NEQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPENING) (SELECTC (fetch ERRORPUPCODE of PUP) (\PUPE.NOSOCKET (* ;  "Connection was open and went away?") (SEQUINOP SEQUIN SEQBROKEN SEQUIN)) NIL)) ((SETQ REASON (SEQUINOP SEQUIN SEQOPENERRORHANDLER SEQUIN PUP)) (RELEASE.PUP PUP) (RETURN (\SEQUIN.FLUSH.CONNECTION SEQUIN \SS.ABORT REASON] (RELEASE.PUP PUP)) (RELEASE.PUP PUP))) ((fetch (SEQUIN SEQRETRANSMITTING) of SEQUIN) (\SEQUIN.RETRANSMITNEXT SEQUIN)) ((EQ (MONITOR.AWAIT.EVENT (fetch (SEQUIN SEQLOCK) of SEQUIN) SOCEVENT (OR (SETQ TIMEOUT (AND (EQ (fetch (SEQUIN %#UNACKEDSEQS) of SEQUIN) 0) (NEQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.CLOSING) (SEQUINOP SEQUIN SEQIDLETIMEOUTCOMPUTER SEQUIN))) (fetch (SEQUIN SEQTIMEOUT) of SEQUIN))) PSTAT.TIMEDOUT) (* ; "Nothing urgent happening") (COND (TIMEOUT (SEQUINOP SEQUIN SEQIDLEFN SEQUIN)) (T (* ; "Waiting for acks") (COND ((\CLOCKGREATERP (fetch (SEQUIN SEQTIMER) of SEQUIN) (fetch (SEQUIN SEQTIMEOUT) of SEQUIN)) (* ;  "Haven't seen anything in a while, so prod the other end") (INCLEAFSTAT (fetch (SEQUIN %#SEQTIMEOUTS) of SEQUIN)) [COND ((NEQ (fetch (SEQUIN MYRECEIVESEQ) of SEQUIN) (fetch (SEQUIN SEQLASTRESTART) of SEQUIN)) (* ;  "This is the first time we've had trouble at this sequence") (SETQ CNT 1) (SETQ RETRANSMITINCREMENT (IMAX 3720Q (LRSH (fetch (SEQUIN SEQTIMEOUT ) of SEQUIN) 1))) (replace (SEQUIN SEQLASTRESTART) of SEQUIN with (fetch (SEQUIN MYRECEIVESEQ) of SEQUIN)) (SETUPTIMER 0 (fetch (SEQUIN SEQLASTRESTARTTIMER) of SEQUIN)) ) (T (SEQUINOP SEQUIN SEQTIMEDOUT SEQUIN (add CNT 1)) (COND ((fetch (SEQUIN SEQCLOSEME) of SEQUIN) (* ;  "In case SEQTIMEDOUT closed the connection") (RETURN] (COND ((ILESSP (fetch (SEQUIN SEQTIMEOUT) of SEQUIN) \SEQUIN.TIMEOUTMAX) (add (fetch (SEQUIN SEQTIMEOUT) of SEQUIN) RETRANSMITINCREMENT))) (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.CLOSING) (\SEQUIN.CONTROL SEQUIN \SEQUIN.DESTROY)) ((EQ (fetch (SEQUIN %#UNACKEDSEQS) of SEQUIN) 1) (* ;  "Only one thing in queue, just resend it") (\SEQUIN.RETRANSMIT SEQUIN)) (T (* ;  "All our stuff is acked, but client is still waiting for something; or more than one thing") (\SEQUIN.CONTROL SEQUIN \SEQUIN.NOOP] (BLOCK) (GO LP)))]) (\SEQUIN.CLOSE [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (WITH.MONITOR (fetch (SEQUIN SEQLOCK) of SEQUIN) (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPEN) (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.CLOSING) (\SEQUIN.CONTROL SEQUIN \SEQUIN.DESTROY) T)))]) (\SEQUIN.FLUSH.CONNECTION [LAMBDA (SEQUIN FINALSTATE REASON) (* ; "Edited 24-May-91 14:52 by jds") (* ;;; "Close a sequin connection") (PROG ((PROC (fetch (SEQUIN SEQPROCESS) of SEQUIN))) (COND ((NULL PROC) (* ; "Cleanup has already been done") (RETURN))) (\SEQUIN.FLUSH.RETRANSMIT SEQUIN) (replace (SEQUIN SEQSTATE) of SEQUIN with (OR FINALSTATE \SS.ABORT)) (NOTIFY.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN)) (CLOSEPUPSOCKET (fetch (SEQUIN SEQSOCKET) of SEQUIN)) (replace (SEQUIN SEQSOCKET) of SEQUIN with NIL) (replace (SEQUIN SEQPROCESS) of SEQUIN with NIL) (SEQUINOP SEQUIN SEQCLOSED SEQUIN FINALSTATE REASON) (COND ((NEQ PROC (THIS.PROCESS)) (DEL.PROCESS PROC)) (T (replace (SEQUIN SEQCLOSEME) of SEQUIN with T]) (\SEQUIN.CLEANUP [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (* ;; "Called via RESETSAVE by Sequin process to perform cleanup if the sequin watcher is killed unexpectedly. Important thing is that we not do this on HARDRESET") (SELECTQ RESETSTATE ((ERROR RESET) (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPEN) (\SEQUIN.CONTROL SEQUIN \SEQUIN.BROKEN))) (\SEQUIN.FLUSH.CONNECTION SEQUIN \SS.ABORT)) NIL]) (\SEQUIN.FLUSH.RETRANSMIT [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (PROG ((REPUP (fetch (SEQUIN SEQRETRANSMITNEXT) of SEQUIN))) (COND (REPUP (replace (SEQUIN SEQRETRANSMITNEXT) of SEQUIN with NIL) (while REPUP do (\ENQUEUE (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN) (PROG1 REPUP (SETQ REPUP (fetch EPLINK of REPUP)))]) (\SEQUIN.COMPARE [LAMBDA (X Y) (* bvm%: " 6-Jan-85 00:14") (* ;;; "Function to return sequence comparison on received pups") (PROG ((DIF (LOGAND (IDIFFERENCE X Y) 377Q))) (RETURN (COND ((EQ DIF 0) \SC.EQUAL) ((EQ DIF 377Q) \SC.PREVIOUS) ((IGEQ DIF 300Q) \SC.DUPLICATE) ((ILEQ DIF 100Q) \SC.AHEAD) (T \SC.OUTOFRANGE]) (\SEQUIN.HANDLE.INPUT [LAMBDA (SEQUIN PUP) (* ; "Edited 24-May-91 14:52 by jds") (* ;;; "Function to handle input pup. Checks that sequence numbers are sensible, takes appropriate action if retransmission needed or releases packets that are hereby acked. Hands new data packets off to next-level protocol") (PROG (ALLOC NEWACKSEQ) (COND ((NEQ (fetch (PUP PUPTYPE) of PUP) \PT.SEQUIN) (RELEASE.PUP PUP) (RETURN)) ((EQ (fetch (SEQUINPACKET SEQCONTROL) of PUP) \SEQUIN.BROKEN) (SEQUINOP SEQUIN SEQBROKEN SEQUIN) (RELEASE.PUP PUP) (RETURN))) (SELECTC (\SEQUIN.COMPARE (fetch (SEQUINPACKET SENDSEQ) of PUP) (fetch (SEQUIN MYRECEIVESEQ) of SEQUIN)) (\SC.OUTOFRANGE (RETURN (\SEQUIN.OUT.OF.THE.BLUE SEQUIN PUP))) (\SC.AHEAD (* ;  "Partner got ahead, ask for retransmission from MYRECEIVESEQ") (COND ((NEQ (fetch (SEQUINPACKET SEQCONTROL) of PUP) \SEQUIN.RESTART) (* ;; "Don't get into a RESTART loop! Do the retransmit requested by partner and hope that things get better") (\SEQUIN.CONTROL SEQUIN \SEQUIN.RESTART) (RELEASE.PUP PUP) (RETURN)))) (\SC.DUPLICATE (* ; "Nothing new, drop it") (GO DUPLICATE)) (\SC.PREVIOUS (* ;  "Retransmission of last packet is simple way to get restart") (COND ((NOT (fetch (SEQUIN SEQIGNOREDUPLICATES) of SEQUIN)) (replace (SEQUINPACKET SEQCONTROL) of PUP with \SEQUIN.RESTART )) ((EQ (fetch (SEQUINPACKET SEQCONTROL) of PUP) \SEQUIN.DALLYING) (* ;; "KLUDGE!!! To work around bug in Twenex Leaf server. Remove this when server is fixed for enough people") NIL) (T (GO DUPLICATE)))) NIL) [COND [(EQ (SETQ ALLOC (fetch (SEQUINPACKET ALLOCATE) of PUP)) 0) (COND ((ILESSP (fetch (SEQUIN SEQINPUTQLENGTH) of SEQUIN) 1) (* ;; "Allocation = 0 normally defaults to 1; however, in rare cases, my partner has actually decremented its allocation below 1, meaning I can't send ANY packets.") (SETQ ALLOC 1] ((IGREATERP ALLOC (fetch (SEQUIN SEQMAXALLOC) of SEQUIN)) (SETQ ALLOC (fetch (SEQUIN SEQMAXALLOC) of SEQUIN] [COND ((NEQ (fetch (SEQUIN SEQOUTALLOC) of SEQUIN) ALLOC) (replace (SEQUIN SEQOUTALLOC) of SEQUIN with ALLOC) (* ;  "Our allocation changed, maybe someone is waiting to send") (NOTIFY.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN] (SELECTC (\SEQUIN.COMPARE (SETQ NEWACKSEQ (fetch (SEQUINPACKET RECEIVESEQ) of PUP)) (fetch (SEQUIN LASTACKEDSEQ) of SEQUIN)) (\SC.OUTOFRANGE (RETURN (\SEQUIN.OUT.OF.THE.BLUE SEQUIN PUP))) ((LIST \SC.DUPLICATE \SC.PREVIOUS) (GO DUPLICATE)) (\SC.AHEAD (* ;  "Release packets acked by this pup") (\SEQUIN.HANDLE.ACK SEQUIN NEWACKSEQ)) NIL) (SELECTC (fetch (SEQUINPACKET SEQCONTROL) of PUP) (\SEQUIN.DATA (UNINTERRUPTABLY (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPENING) (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.OPEN))) (add (fetch (SEQUIN MYRECEIVESEQ) of SEQUIN) 1) (SEQUINOP SEQUIN SEQINPUT PUP SEQUIN) (NOTIFY.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN))) (COND ((NEQ (fetch (SEQUIN SEQTIMEOUT) of SEQUIN) (fetch (SEQUIN SEQBASETIMEOUT) of SEQUIN)) (replace (SEQUIN SEQTIMEOUT) of SEQUIN with (fetch (SEQUIN SEQBASETIMEOUT) of SEQUIN)) (SEQUINOP SEQUIN SEQTIMEDIN SEQUIN))) (* ;  "Set timeout back to normal now that we have a response") (RETURN T)) (\SEQUIN.RESTART (INCLEAFSTAT (fetch (SEQUIN %#SEQRESTARTS) of SEQUIN)) (\SEQUIN.RETRANSMIT SEQUIN)) (\SEQUIN.DALLYING (* ; "Only sequin Users get this") (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.CLOSING) (\SEQUIN.CONTROL SEQUIN \SEQUIN.QUIT) (\SEQUIN.FLUSH.CONNECTION SEQUIN \SS.CLOSED)))) (\SEQUIN.DESTROY (* ;  "Only sequin Servers get this or QUIT") (\SEQUIN.CONTROL SEQUIN \SEQUIN.DALLYING) (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.DALLYING)) (\SEQUIN.QUIT (COND ((EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.DALLYING) (\SEQUIN.FLUSH.CONNECTION SEQUIN \SS.CLOSED)))) NIL) (RELEASE.PUP PUP) (RETURN T) DUPLICATE (INCLEAFSTAT (fetch (SEQUIN %#SEQDUPLICATES) of SEQUIN)) (RELEASE.PUP PUP) (RETURN]) (\SEQUIN.OUT.OF.THE.BLUE [LAMBDA (SEQUIN PUP) (* bvm%: "27-JUL-83 22:29") (* ;;; "Called when PUP arrives on SEQUIN with outlandish sequence numbers") (* * (replace (SEQUIN SEQSTATE) of SEQUIN with \SS.ABORT)  (\SEQUIN.CONTROL SEQUIN \SEQUIN.BROKEN)  (SEQUINOP SEQUIN SEQABORTED SEQUIN) (RELEASE.PUP PUP)) NIL]) (\SEQUIN.HANDLE.ACK [LAMBDA (SEQUIN ACKSEQ) (* ; "Edited 24-May-91 14:52 by jds") (* ;;; "Function to dispose of Pups on the output queue which have been acknowledged by a Receive sequence of ACKSEQ") (bind (QUEUE _ (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN)) NEWACKSEQ PUP do (* ;  "All packets up to ACKSEQ-1 are now acknowledged") (COND ((NULL (SETQ PUP (\QUEUEHEAD QUEUE))) (* ;  "Pup hasn't come back from transmission yet; wait") (COND ((fetch (SEQUIN SEQRETRANSMITTING) of SEQUIN) (* ;  "Pup hasn't come back yet because we haven't sent it! Send another") (\SEQUIN.RETRANSMITNEXT SEQUIN))) (BLOCK)) ((UNINTERRUPTABLY (\DEQUEUE QUEUE) (add (fetch (SEQUIN %#UNACKEDSEQS) of SEQUIN) -1) (replace (SEQUIN LASTACKEDSEQ) of SEQUIN with (SETQ NEWACKSEQ (LOGAND (ADD1 (fetch (SEQUINPACKET SENDSEQ) of PUP)) 377Q))) (SEQUINOP SEQUIN SEQACKED PUP SEQUIN) (EQ NEWACKSEQ ACKSEQ)) (RETURN]) (\SEQUIN.RETRANSMIT [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (* ;;; "Routine to retransmit output sequins") (OR (fetch (SEQUIN SEQRETRANSMITTING) of SEQUIN) (PROG ((QUEUE (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN))) (COND ((NULL (fetch SYSQUEUEHEAD of QUEUE)) (RETURN T))) (while (NEQ (LOGAND (ADD1 (fetch (SEQUINPACKET SENDSEQ) of (fetch SYSQUEUETAIL of QUEUE))) 377Q) (fetch (SEQUIN MYSENDSEQ) of SEQUIN)) do (* ;; "Not all of our packets have been transmitted yet; don't restart now or our retransmit queue will get out of order") (BLOCK)) (UNINTERRUPTABLY (replace (SEQUIN SEQRETRANSMITNEXT) of SEQUIN with (fetch SYSQUEUEHEAD of QUEUE)) (replace SYSQUEUEHEAD of QUEUE with (replace SYSQUEUETAIL of QUEUE with NIL)) (* ;  "Detach chain of pups from retransmit queue so that they can return there normally") (replace (SEQUIN SEQRETRANSMITTING) of SEQUIN with T))]) (\SEQUIN.RETRANSMITNEXT [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:52 by jds") (PROG ((NEXTPUP (fetch (SEQUIN SEQRETRANSMITNEXT) of SEQUIN))) (replace EPREQUEUE of NEXTPUP with (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN)) (replace (SEQUINPACKET RECEIVESEQ) of NEXTPUP with (fetch (SEQUIN MYRECEIVESEQ ) of SEQUIN)) (replace (SEQUINPACKET ALLOCATE) of NEXTPUP with (fetch (SEQUIN SEQINALLOC) of SEQUIN)) [SENDPUP (fetch (SEQUIN SEQSOCKET) of SEQUIN) (PROG1 NEXTPUP (OR (replace (SEQUIN SEQRETRANSMITNEXT) of SEQUIN with (fetch EPLINK of NEXTPUP)) (replace (SEQUIN SEQRETRANSMITTING) of SEQUIN with NIL)))] (add (fetch (SEQUIN %#SEQRETRANSMITS) of SEQUIN) 1]) ) (* ;; "LEAF device operations") (DEFINEQ (\LEAF.CLOSEFILE [LAMBDA (STREAM CONNECTION LEAFHANDLE FORCE)(* ;  "Edited 2-Nov-92 03:35 by sybalsky:mv:envos") (* ;;; "Closes the file open on this LEAF connection. CONNECTION and LEAFHANDLE are obtained from STREAM if necessary; else STREAM may be NIL") (PROG (OPUP DATA (INTERNAL CONNECTION)) [COND (STREAM (\CLEARMAP STREAM) (OR (SETQ CONNECTION (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM)) (LISPERROR "FILE NOT OPEN" STREAM)) (COND ((WITH.MONITOR (fetch (SEQUIN LEAFOPENCLOSELOCK) of CONNECTION) [COND ((EQ (fetch (SEQUIN SEQSTATE) of CONNECTION) \SS.OPEN) (COND [(AND (NOT FORCE) (NOT (DIRTYABLE STREAM))) (* ;  "Don't really close it; keep it around in case someone wants to look at it again soon") (OR INTERNAL (replace (LEAFSTREAM LEAFREALLYOPEN) of STREAM with NIL)) (* ;; "If this is a call from CLOSEF then mark the stream as `really' closed, so that we know we can close it later") (LET ((CACHE (fetch (SEQUIN LEAFCACHEDFILE) of CONNECTION ))) (COND ((NULL CACHE) (* ;  "No cache before, so just make this the cached file") (replace (SEQUIN LEAFCACHEDFILE) of CONNECTION with STREAM) T) ((EQ CACHE STREAM) (* ;  "Closing the already cached file? Do nothing") T) ((EQ (fetch (STREAM FULLFILENAME) of STREAM) (fetch (STREAM FULLFILENAME) of CACHE)) (* ;; "Two streams open on the same file. Could happen if STREAM was opened with an incomplete filename. Always prefer to keep the originally cached file around, so fall thru now and close STREAM") NIL) (T (replace (SEQUIN LEAFCACHEDFILE) of CONNECTION with STREAM) (COND ((fetch (LEAFSTREAM LEAFREALLYOPEN) of CACHE) T) (T (* ;  "Close the formerly cached stream if Lisp thinks it is closed") (SETQ STREAM CACHE) NIL] ((EQ STREAM (fetch (SEQUIN LEAFCACHEDFILE) of CONNECTION)) (* ;  "We are about to close the cached stream") (replace (SEQUIN LEAFCACHEDFILE) of CONNECTION with NIL]) (RETURN))) (SETQ LEAFHANDLE (fetch (LEAFSTREAM LEAFHANDLE) of STREAM] (COND ((EQ (fetch (SEQUIN SEQSTATE) of CONNECTION) \SS.OPEN) (* ;  "Don't bother sending anything if the connection is already gone") (SETQ OPUP (ALLOCATE.PUP)) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.CLOSE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with LEAFHANDLE) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.CLOSEREQUEST) (* ; "Note: don't give the stream to the sequin if we are quietly closing the cache, because we don't want this to result in a bogus not responding error") (\SENDLEAF CONNECTION OPUP (AND (NEQ FORCE :CACHE) STREAM) NIL T))) (COND (STREAM (* ; "no good anymore") (OR INTERNAL (replace (LEAFSTREAM LEAFREALLYOPEN) of STREAM with NIL)) (replace (LEAFSTREAM LEAFPAGECACHE) of STREAM with NIL) (replace (LEAFSTREAM LEAFCONNECTION) of STREAM with NIL]) (\LEAF.DELETEFILE [LAMBDA (FILENAME DEV) (* ;  "Edited 2-Nov-92 03:35 by sybalsky:mv:envos") (PROG ((OPUP (ALLOCATE.PUP)) (STREAM (\LEAF.GETFILE DEV FILENAME 'OUTPUT 'OLDEST T 'NODATES)) DATA IPUP) (RETURN (COND (STREAM (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.DELETE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.CLOSEREQUEST ) (COND ((SETQ IPUP (\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM)) (RELEASE.PUP IPUP) (replace (LEAFSTREAM LEAFCONNECTION) of STREAM with NIL) (* ;  "The leaf file connection is now gone") (fetch (STREAM FULLFILENAME) of STREAM]) (\LEAF.DEVICEP [LAMBDA (HOST LEAFDEV) (* ; "Edited 26-Apr-90 11:56 by nm") (* ;;; "Returns the device corresponding to this HOST, or NIL if it is an illegal leaf host") (PROG (NAME DEVICE SEQUIN CONN) (RETURN (COND ([AND (STRPOS "DSK" HOST 1 NIL T NIL UPPERCASEARRAY) (for I from 4 to (NCHARS HOST) always (SMALLP (NTHCHAR HOST I] (* ;  "Kludge: Name of form DSKn: don't bother") NIL) ((STRPOS '%: HOST) (* ;  "NS host, skip it. Would be nice to have more orderly name tests") NIL) ((AND (EQL \MACHINETYPE \MAIKO) (STRPOS "UNIX" HOST 1 NIL T NIL UPPERCASEARRAY)) (* ;  "Maiko uses UNIX as a name of local file system.") NIL) ((NULL (SETQ NAME (\CANONICAL.HOSTNAME HOST))) NIL) ((NULL LEAFDEV) (* ;  "Called as predicate, don't try to open one") NAME) ((AND (NEQ NAME HOST) (SETQ DEVICE (\GETDEVICEFROMNAME NAME T T))) DEVICE) ((NULL (SETQ SEQUIN (\OPENLEAFCONNECTION NAME))) NIL) ((type? SEQUIN SEQUIN) [\DEFINEDEVICE NAME (SETQ DEVICE (\MAKE.PMAP.DEVICE (create FDEV DEVICENAME _ NAME CLOSEFILE _ (FUNCTION \LEAF.CLOSEFILE) DELETEFILE _ (FUNCTION \LEAF.DELETEFILE) GETFILEINFO _ (FUNCTION \LEAF.GETFILEINFO) OPENFILE _ (FUNCTION \LEAF.OPENFILE) READPAGES _ (FUNCTION \LEAF.READPAGES) WRITEPAGES _ (FUNCTION \LEAF.WRITEPAGES) SETFILEINFO _ (FUNCTION \LEAF.SETFILEINFO) TRUNCATEFILE _ (FUNCTION \LEAF.TRUNCATEFILE) GETFILENAME _ (FUNCTION \LEAF.GETFILENAME) REOPENFILE _ (FUNCTION \LEAF.REOPENFILE) GENERATEFILES _ (FUNCTION \LEAF.GENERATEFILES) EVENTFN _ (FUNCTION \LEAF.EVENTFN) DIRECTORYNAMEP _ (FUNCTION \LEAF.DIRECTORYNAMEP) HOSTNAMEP _ (FUNCTION NILL) RENAMEFILE _ (FUNCTION \LEAF.RENAMEFILE) DEVICEINFO _ (create PUPFILESERVER PFSNAME _ NAME PFSOSTYPE _ (GETHOSTINFO NAME 'OSTYPE) PFSLEAFSEQUIN _ SEQUIN) FORCEOUTPUT _ (FUNCTION \LEAF.FORCEOUTPUT) OPENP _ (FUNCTION \GENERIC.OPENP ) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM) BREAKCONNECTION _ (FUNCTION \LEAF.BREAKCONNECTION] DEVICE) ((AND \FTPAVAILABLE (SETQ CONN (\FTP.OPEN.CONNECTION NAME))) (\RELEASE.FTPCONNECTION CONN) \FTPFDEV]) (\LEAF.RECONNECT [LAMBDA (DEVICE OLDONLY) (* ; "Edited 24-May-91 15:11 by jds") (WITH.MONITOR \LEAFCONNECTIONLOCK [PROG ((INFO (fetch DEVICEINFO of DEVICE)) SEQUIN) (RETURN (COND ((AND (SETQ SEQUIN (fetch (PUPFILESERVER PFSLEAFSEQUIN) of INFO)) (EQ (fetch (SEQUIN SEQSTATE) of SEQUIN) \SS.OPEN)) SEQUIN) ([AND (NOT OLDONLY) (type? SEQUIN (SETQ SEQUIN (\OPENLEAFCONNECTION (fetch (PUPFILESERVER PFSNAME) of INFO] (replace (PUPFILESERVER PFSLEAFSEQUIN) of INFO with SEQUIN) SEQUIN])]) (\LEAF.DIRECTORYNAMEP [LAMBDA (HOST/DIR DEV) (* ; "Edited 24-May-91 15:11 by jds") (* ;; "True if HOST/DIR is a valid host/directory specification, NIL if not. We do this by trying to open an unlikely filename on the dir and see if the error we get is 'file not found' or 'invalid directory'") (LET (INFO) (COND ((NULL (UNPACKFILENAME.STRING HOST/DIR 'DIRECTORY)) (* ; "No directory field--assume is malformed. Don't do GETFILE below, since that packfilename could coerce a non-directory into a directory") NIL) ((CL:MEMBER HOST/DIR (fetch (PUPFILESERVER PFSKNOWNDIRS) of (SETQ INFO (fetch DEVICEINFO of DEV))) :TEST (if (EQ (fetch (PUPFILESERVER PFSOSTYPE) of INFO) 'UNIX) then (* ; "Stupid case-sensitive") 'CL:STRING= else 'STRING-EQUAL)) (* ;  "We already know this directory is ok") T) ((\LEAF.GETFILE DEV (PACKFILENAME.STRING 'DIRECTORY HOST/DIR 'NAME "QXZRYU") 'INPUT 'OLD T 'DIRECTORY) (push (fetch (PUPFILESERVER PFSKNOWNDIRS) of INFO) HOST/DIR) (* ;  "Returning T tells the caller to canonicalize the host name for me") T]) (\LEAF.GENERATEFILES [LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* bvm%: "28-Apr-84 00:02") (OR (AND \FTPAVAILABLE (\FTP.GENERATEFILES DEVICE PATTERN DESIREDPROPS OPTIONS)) (\GENERATENOFILES DEVICE PATTERN DESIREDPROPS OPTIONS]) (\LEAF.GETFILE [LAMBDA (DEVICE FILENAME ACCESS RECOG NOERROR OPTION OLDSTREAM REALLYOPEN) (* ;  "Edited 2-Nov-92 03:35 by sybalsky:mv:envos") (* ;;; "Opens FILENAME for indicated ACCESS and RECOG, returning a STREAM, optionally smashing DEADSTREAM, on the resulting file, which is now open. If NOERROR is T, returns NIL on errors; if NOERROR is FIND, returns NIL only on file not found errors. OPTION specifies special way to not really open the file; choices are --- NAME -- used to get a full file name: in this case, the fullname is returned, and the file is closed on exit --- DIRECTORY -- FILENAME is a directory specification, not a 'real' filename. Return NIL if the directory doesn't exist, T if it does.") (PROG ((DEVINFO (fetch DEVICEINFO of DEVICE)) CONNECTION MODE FILELENGTH CACHEDSTREAM LEAFHANDLE HOST REMOTENAME NAME/PASS OUTCOME CONNECTNAME/PASS OPUP IPUP DATA) (COND ((SETQ HOST (\PARSE.REMOTE.FILENAME FILENAME NOERROR DEVICE)) (SETQ REMOTENAME (CDR HOST)) (SETQ HOST (CAR HOST))) (T (RETURN))) (SETQ CONNECTION (fetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO)) TOP (OR CONNECTION (SETQ CONNECTION (\LEAF.RECONNECT DEVICE)) (RETURN)) (COND ([AND (fetch (SEQUIN LEAFCACHEDFILE) of CONNECTION) (SETQ OUTCOME (WITH.MONITOR (fetch (SEQUIN LEAFOPENCLOSELOCK) of CONNECTION) [AND (SETQ CACHEDSTREAM (fetch (SEQUIN LEAFCACHEDFILE) of CONNECTION) ) (SELECTQ ACCESS ((NONE INPUT) (COND ((AND (NOT OLDSTREAM) (EQ (fetch (STREAM FULLFILENAME) of CACHEDSTREAM ) FILENAME) (COND ((NOT REALLYOPEN) T) ((fetch (LEAFSTREAM LEAFREALLYOPEN) of CACHEDSTREAM) (* ;  "Asking for a new REAL opening of the file, so don't use cache") NIL) (T (replace (LEAFSTREAM LEAFREALLYOPEN) of CACHEDSTREAM with T) T))) (* ;  "We already have this file open, and its open state is correct") (SELECTQ OPTION (NAME FILENAME) (DATES (\LEAF.GETFILEDATES CACHEDSTREAM) CACHEDSTREAM) CACHEDSTREAM)))) (COND ((NOT (fetch (LEAFSTREAM LEAFREALLYOPEN) of CACHEDSTREAM) ) (* ;  "Close the cached file in case it is the one we are now trying to open for write") (replace (SEQUIN LEAFCACHEDFILE) of CONNECTION with NIL) (\LEAF.CLOSEFILE CACHEDSTREAM T NIL T) NIL])] (RETURN OUTCOME))) (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST)) RETRY (SETQ OPUP (ALLOCATE.PUP)) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (\CLEARBYTES DATA 0 \LEN.OPENREQUEST) (replace (LEAFDATA OPCODE) of DATA with \LEAFOP.OPEN) (replace (LEAFDATA OPENMODE) of DATA with (+ (SELECTQ ACCESS ((INPUT NONE) \LEAF.READBIT) ((OUTPUT APPEND BOTH) (+ \LEAF.WRITEBIT \LEAF.EXTENDBIT)) (LISPERROR "ILLEGAL ARG" ACCESS)) (SELECTQ RECOG (OLD \LEAF.DEFAULT.HIGHEST) (OLD/NEW (+ \LEAF.DEFAULT.HIGHEST \LEAF.CREATEBIT)) (NEW (+ \LEAF.DEFAULT.NEXT \LEAF.CREATEBIT)) (OLDEST \LEAF.DEFAULT.LOWEST) (NIL (SELECTQ ACCESS (OUTPUT (+ \LEAF.DEFAULT.NEXT \LEAF.CREATEBIT)) ((INPUT NONE) \LEAF.DEFAULT.HIGHEST) (+ \LEAF.DEFAULT.HIGHEST \LEAF.CREATEBIT))) (LISPERROR "ILLEGAL ARG" RECOG)) \LEAF.EXPLICIT.ANY)) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.OPENREQUEST) (\ADDLEAFSTRING OPUP (CAR NAME/PASS)) (\ADDLEAFSTRING OPUP (CDR NAME/PASS) T) (\ADDLEAFSTRING OPUP (CAR CONNECTNAME/PASS)) (* ; "Connect name") (\ADDLEAFSTRING OPUP (CDR CONNECTNAME/PASS) T) (* ; "Connect password") (\ADDLEAFSTRING OPUP REMOTENAME) [RETURN (COND ((SETQ IPUP (\SENDLEAF CONNECTION OPUP (if (EQ OPTION 'DIRECTORY) then (* ;  "Don't reveal that silly name if connection fails to respond") T else FILENAME) T)) (PROG1 [SELECTC (SETQ OUTCOME (fetch (LEAFPACKET LEAFSTATUS) of IPUP)) (\LEAF.GOODSTATUS (SETQ FILELENGTH (fetch (LEAFDATA FILEADDRESS) of (fetch PUPCONTENTS of IPUP)) ) (SETQ LEAFHANDLE (fetch (LEAFDATA HANDLE) of (fetch PUPCONTENTS of IPUP)) ) [COND ((EQ OPTION 'DIRECTORY) (* ;  "just wanted to know if directory is valid. Obviously is") (\LEAF.CLOSEFILE NIL CONNECTION LEAFHANDLE) T) (T (COND ((NOT (PROG1 OLDSTREAM (OR OLDSTREAM (SETQ OLDSTREAM (create STREAM DEVICE _ DEVICE))) (replace (LEAFSTREAM LEAFCONNECTION) of OLDSTREAM with CONNECTION) (replace (LEAFSTREAM LEAFHANDLE) of OLDSTREAM with LEAFHANDLE))) (replace (STREAM FULLFILENAME) of OLDSTREAM with (OR (\LEAF.READFILENAME OLDSTREAM DEVINFO) FILENAME))) (T (replace (LEAFSTREAM LEAFPAGECACHE) of OLDSTREAM with NIL))) [COND ((EQ ACCESS 'OUTPUT) (* ;  "Note: OUTPUT means there is no file to start with! so EOF=0") (replace (STREAM EPAGE) of OLDSTREAM with (replace (STREAM EOFFSET) of OLDSTREAM with 0))) (T (replace (STREAM EPAGE) of OLDSTREAM with (fetch (BYTEPTR PAGE) of FILELENGTH )) (replace (STREAM EOFFSET) of OLDSTREAM with (fetch (BYTEPTR OFFSET) of FILELENGTH] (COND ((EQ OPTION 'NAME) (PROG1 (fetch (STREAM FULLFILENAME) of OLDSTREAM ) (\LEAF.CLOSEFILE OLDSTREAM T))) (T (COND ((OR (EQ OPTION 'DATES) (NEQ ACCESS 'NONE)) (\LEAF.GETFILEDATES OLDSTREAM T))) OLDSTREAM]) (\PASSWORD.ERRORS (* ; "password error") (COND ((SETQ NAME/PASS (\FIXPASSWORD OUTCOME CONNECTION)) (GO RETRY)) (T (GO CAUSE.ERROR)))) (\CONNECT.PASSWORD.ERRORS (* ; "Connect info bad, try again") (COND ([SETQ CONNECTNAME/PASS (\FIXPASSWORD OUTCOME CONNECTION (OR (CAR CONNECTNAME/PASS) (\LEAF.DIRECTORYNAMEONLY FILENAME] (GO RETRY)) (T (GO CAUSE.ERROR)))) ((CONS \IFSERROR.INVALID.DIRECTORY \IFSERROR.MALFORMED) (COND ((OR (EQ OPTION 'DIRECTORY) NOERROR) NIL) (T (\LEAF.ERROR IPUP FILENAME CONNECTION)))) (\LEAF.BROKEN.STATUS (SETQ CONNECTION) (GO TOP)) (COND ((EQ OPTION 'DIRECTORY) (* ;  "Open didn't barf on invalid directory, so I assume at least that much was okay") T) [(EQ OUTCOME \IFSERROR.PROTECTION) (COND ([AND (NULL (CDR CONNECTNAME/PASS)) (SETQ CONNECTNAME/PASS (\FIXPASSWORD OUTCOME CONNECTION (  \LEAF.DIRECTORYNAMEONLY FILENAME] (* ;; "File protected, but we got a connect password. Don't do this if we already had a connect password, since then the error is 'incorrect connect password' and this protection error means there's no hope") (GO RETRY)) (T (GO CAUSE.ERROR] ((OR (EQ NOERROR T) (EQ OUTCOME \IFSERROR.FILE.NOT.FOUND)) NIL) (T (\LEAF.ERROR IPUP FILENAME CONNECTION] (RELEASE.PUP IPUP] CAUSE.ERROR (RELEASE.PUP IPUP) (RETURN (COND ((NEQ NOERROR T) (SELECTC OUTCOME (\IFSERROR.FILE.NOT.FOUND NIL) ((CONS \IFSERROR.PROTECTION \CONNECT.PASSWORD.ERRORS) (LISPERROR "PROTECTION VIOLATION" FILENAME)) (LISPERROR "FILE WON'T OPEN" FILENAME]) (\PARSE.REMOTE.FILENAME [LAMBDA (FILENAME NOERROR DEVICE) (* ; "Edited 11-Jan-88 16:12 by bvm") (* ;; "Parses FILENAME as a dotted pair of host and device-specific name, the latter something we can give to the remote host") (PROG ((OSTYPE (fetch (LEAFDEVICE PFSOSTYPE) of DEVICE)) FIELDS HOST REMOTENAME DEV DIR NAME EXT VERSION VALUE QUOTEP) (SETQ FIELDS (UNPACKFILENAME.STRING FILENAME NIL NIL OSTYPE)) (SETQ QUOTEP (STRPOS "'" FILENAME)) (for TAIL on FIELDS by (CDDR TAIL) do (SETQ VALUE (CADR TAIL)) (if (AND QUOTEP (STRPOS "'" VALUE)) then (* ;; "Remove quotes. This is a hack to let people quote funny chars somehow. It's pretty limited, since we don't know how to quote them coming back.") (SETQ VALUE (\LEAF.STRIP.QUOTES VALUE))) (SELECTQ (CAR TAIL) (HOST [SETQ HOST (OR (\CANONICAL.HOSTNAME VALUE) (RETURN (AND (NOT NOERROR) (ERROR "Host not found" HOST]) (DEVICE (SETQ DEV VALUE)) (DIRECTORY (SETQ DIR VALUE)) (NAME (SETQ NAME VALUE)) (EXTENSION (SETQ EXT VALUE)) (VERSION (SETQ VERSION VALUE)) NIL)) [if (NULL HOST) then (RETURN (AND (NEQ NOERROR T) (LISPERROR "BAD FILE NAME" FILENAME] (COND ((SETQ HOST (\CANONICAL.HOSTNAME HOST))) (NOERROR (RETURN NIL)) (T (ERROR "Host not found" HOST))) (* ;; "Convert name to native syntax") (RETURN (CONS HOST (CONCATLIST (NCONC (AND DEV (LIST DEV)) (AND DIR (SELECTQ OSTYPE (UNIX (LIST "/" DIR "/")) (VMS (LIST "[" DIR "]")) (LIST "<" DIR ">"))) (LIST NAME) (if (AND EXT (NEQ 0 (NCHARS EXT))) then (LIST "." EXT) else (SELECTQ OSTYPE ((TENEX TOPS20 VMS) (* ;  "even extensionless files have a dot") (LIST ".")) NIL)) (AND VERSION (NEQ 0 (NCHARS VERSION)) (LIST (SELECTQ OSTYPE (TOPS20 ".") ((IFS UNIX) (* ; "Unix? you ask. Well, the Leaf server doesn't seem to understand semicolon, even though that's how the files are stored!") "!") ";") VERSION]) (\LEAF.STRIP.QUOTES [LAMBDA (NAME) (* ; "Edited 11-Jan-88 16:13 by bvm") (* ;; "Remove quotes from file NAME, since remote devices never understand our quoting convention (actually, there isn't one in the Leaf protocol). Currently, we only remove quotes that look like they're quoting something interesting.") (CONCATCODES (for (TAIL _ (CHCON NAME)) by (CDR TAIL) while TAIL collect (if (AND (EQ (CAR TAIL) (CHARCODE "'")) (CDR TAIL)) then (* ; "skip quote") (SETQ TAIL (CDR TAIL))) (CAR TAIL]) (\LEAF.GETFILEDATES [LAMBDA (STREAM FLG) (* ; "Edited 24-May-91 15:07 by jds") (PROG ((INFOBLK (fetch (LEAFSTREAM LEAFINFO) of STREAM)) START) (COND [(NOT INFOBLK) (replace (LEAFSTREAM LEAFINFO) of STREAM with (SETQ INFOBLK (create LEAFINFOBLOCK] ((NOT FLG) (RETURN INFOBLK))) [COND ((SETQ START (\LEAF.READFILEPROP STREAM 0 (UNFOLD 3 BYTESPERCELL))) (* ;  "Get 3 info dates from IFS leader") (\BLT INFOBLK (CDR START) (UNFOLD 3 WORDSPERCELL)) (RELEASE.PUP (CAR START))) (T (* ; "Can't read leader page dates") (\CLEARBYTES INFOBLK 0 (UNFOLD 3 BYTESPERCELL] (\LEAF.SETVALIDATION STREAM) (RETURN INFOBLK]) (\LEAF.GETFILEINFO [LAMBDA (STREAM ATTRIBUTE DEV) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (COND ((type? STREAM STREAM) (* ; "Handle open case easily") (\LEAF.GETFILEINFO.OPEN STREAM ATTRIBUTE)) (T (PROG (DEVINFO SEQUIN RESULT) [COND ((FMEMB ATTRIBUTE '(CREATIONDATE ICREATIONDATE)) (* ;; "Use the LOOKUPFILE protocol. Would like to have LENGTH here, too, but might disagree with Leaf due to race conditions; e.g. LENGTH of a file that I just had closed could get an old length") (COND ((AND [SETQ SEQUIN (fetch (PUPFILESERVER PFSLEAFSEQUIN) of (SETQ DEVINFO (fetch DEVICEINFO of DEV] (SETQ RESULT (fetch (SEQUIN LEAFCACHEDFILE) of SEQUIN)) (EQ (fetch (STREAM FULLFILENAME) of RESULT) STREAM)) (* ; "A name we know about") (RETURN (\LEAF.GETFILEINFO.OPEN RESULT ATTRIBUTE))) ((NEQ (SETQ RESULT (\IFS.LOOKUPFILE STREAM 'OLD ATTRIBUTE DEVINFO)) '?) (RETURN RESULT] (* ;; "To get attributes, have to open file, read them, then close.") (RETURN (COND ((SETQ STREAM (\LEAF.GETFILE DEV STREAM 'NONE 'OLD)) (PROG1 (\LEAF.GETFILEINFO.OPEN STREAM ATTRIBUTE) (\LEAF.CLOSEFILE STREAM T]) (\LEAF.GETFILEINFO.OPEN [LAMBDA (STREAM ATTRIBUTE) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (SELECTQ ATTRIBUTE (LENGTH (create BYTEPTR PAGE _ (fetch (STREAM EPAGE) of STREAM) OFFSET _ (fetch (STREAM EOFFSET) of STREAM))) (CREATIONDATE (GDATE (\LEAF.GETFILEINFO.OPEN STREAM 'ICREATIONDATE))) (WRITEDATE (GDATE (\LEAF.GETFILEINFO.OPEN STREAM 'IWRITEDATE))) (READDATE (GDATE (\LEAF.GETFILEINFO.OPEN STREAM 'IREADDATE))) (ICREATIONDATE (ALTO.TO.LISP.DATE (fetch (LEAFINFOBLOCK LFCREATIONDATE) of (\LEAF.GETFILEDATES STREAM)))) (IWRITEDATE (ALTO.TO.LISP.DATE (fetch (LEAFINFOBLOCK LFWRITEDATE) of (  \LEAF.GETFILEDATES STREAM)))) (IREADDATE (ALTO.TO.LISP.DATE (fetch (LEAFINFOBLOCK LFREADDATE) of (  \LEAF.GETFILEDATES STREAM)))) ((TYPE BYTESIZE) [PROG (FT (BYTESIZE 10Q)) [SETQ FT (COND [(SETQ FT (\LEAF.READFILEPROP STREAM \OFFSET.FILETYPE \LEN.FILETYPE&SIZE)) (* ; "FT = (pup . base)") (PROG1 (SELECTC (\GETBASE (CDR FT) 0) (\FT.UNKNOWN NIL) (\FT.TEXT 'TEXT) (\FT.BINARY (SETQ BYTESIZE (\GETBASE (CDR FT) 1)) 'BINARY) '?) (RELEASE.PUP (CAR FT)))] (T '?] (RETURN (COND ((EQ ATTRIBUTE 'BYTESIZE) BYTESIZE) (T FT]) (AUTHOR [LET ((BASE (\LEAF.READFILEPROP STREAM \OFFSET.AUTHOR \LEN.AUTHOR))) (AND BASE (PROG1 (GetBcplString (CDR BASE)) (RELEASE.PUP (CAR BASE)))]) ((BACKUPDATE IBACKUPDATE) [LET ((BASE (\LEAF.READFILEPROP STREAM \OFFSET.BACKUPDATE \LEN.DATE)) DT) (COND (BASE (SETQ DT (fetch (LEAFINFOBLOCK LFCREATIONDATE) of (CDR BASE))) (RELEASE.PUP (CAR BASE)) (if (NEQ DT 0) then (* ; "Zero means it hasn't been") (SETQ DT (ALTO.TO.LISP.DATE DT)) (if (EQ ATTRIBUTE 'IBACKUPDATE) then DT else (GDATE DT]) NIL]) (\LEAF.GETFILENAME [LAMBDA (NAME RECOG DEV) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (PROG ((DEVINFO (fetch DEVICEINFO of DEV)) SEQUIN RESULT) (RETURN (OR [COND ((AND (SETQ SEQUIN (fetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO)) (SETQ RESULT (fetch (SEQUIN LEAFCACHEDFILE) of SEQUIN)) (EQ (fetch (STREAM FULLFILENAME) of RESULT) NAME)) (* ; "A name we know about") NAME) ((AND (NEQ RECOG 'NEW) (NEQ (SETQ RESULT (\IFS.LOOKUPFILE NAME RECOG 'NAME DEVINFO)) '?)) RESULT) (T (\LEAF.GETFILE DEV NAME 'NONE RECOG T 'NAME] (SELECTQ RECOG ((NEW OLD/NEW) (\GENERIC.OUTFILEP NAME DEV)) NIL]) (\LEAF.OPENFILE [LAMBDA (FILENAME ACCESS RECOG OTHERINFO DEV) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (PROG ((DEVINFO (fetch DEVICEINFO of DEV)) STREAM TYPE BYTESIZE OLDHANDLE CRDATE PROPS SEQUIN EOL) [COND ((type? STREAM FILENAME) (* ;  "Hmm? trying to reopen, perhaps?") (COND ((fetch (STREAM ACCESS) of FILENAME) (RETURN (LISPERROR "FILE WON'T OPEN" FILENAME))) (T (SETQ FILENAME (fetch (STREAM FULLFILENAME) of (SETQ OLDHANDLE FILENAME] (for X in OTHERINFO do (* ;  "Check device-dependent parameters") (SELECTQ [CAR (OR (LISTP X) (SETQ X (LIST X T] ((TYPE FILETYPE) (* ;  "Set the file TYPE (TEXT or BINARY)") (SETQ TYPE (CDR X))) (BYTESIZE (SETQ BYTESIZE (OR (FIXP (CADR X)) (\ILLEGAL.ARG X)))) (CREATIONDATE (SETQ CRDATE (IDATE (CADR X)))) (ICREATIONDATE (SETQ CRDATE (OR (FIXP (CADR X)) (\ILLEGAL.ARG X)))) (DON'T.CHANGE.DATE (* ;; "Don't change create date. In order to do this, we have to look at the current date of the file, save it, then rewrite when we open the file for real") (COND ((AND (NEQ ACCESS 'INPUT) (SETQ OLDHANDLE (\LEAF.GETFILE DEV FILENAME 'NONE 'OLD T 'DATES OLDHANDLE))) (SETQ FILENAME (fetch (STREAM FULLFILENAME) of OLDHANDLE)) (SETQ CRDATE (\LEAF.CREATIONDATE OLDHANDLE)) (\LEAF.CLOSEFILE OLDHANDLE NIL NIL T)))) (SEQUENTIAL (* ; "Hook for FTP") (COND ((AND (CADR X) \FTPAVAILABLE (OR (NEQ (fetch (PUPFILESERVER PFSOSTYPE) of DEVINFO) 'UNIX) UNIXFTPFLG) (SETQ STREAM (\FTP.OPENFILE FILENAME ACCESS RECOG OTHERINFO))) (RETURN)))) (EOL (SETQ EOL (SELECTQ (CADR X) (CR CR.EOLC) (LF LF.EOLC) (CRLF CRLF.EOLC) (\ILLEGAL.ARG X)))) (push PROPS X))) [COND (STREAM) ((SETQ STREAM (\LEAF.GETFILE DEV FILENAME ACCESS RECOG 'FIND NIL OLDHANDLE T)) (* ; "Returns NIL if file not found") (COND (CRDATE (\LEAF.SETCREATIONDATE STREAM CRDATE)) (T (\LEAF.GETFILEDATES STREAM))) (COND ([AND (NEQ ACCESS 'INPUT) (COND (TYPE (* ; "Type NIL overrides default") (SETQ TYPE (CAR TYPE))) (T (AND (SETQ TYPE DEFAULTFILETYPE) (EQ (fetch (STREAM EPAGE) of STREAM) 0) (EQ (fetch (STREAM EOFFSET) of STREAM) 0] (* ;; "Set file type if explicitly requested, or if this is a new output file and there is a global default") (\LEAF.SETFILETYPE STREAM TYPE BYTESIZE))) (SETQ SEQUIN (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM)) (COND ((IGREATERP (fetch (SEQUIN LEAFCACHEHITS) of SEQUIN) 77777Q) (* ; "Keep counters from overflowing") (replace (SEQUIN LEAFCACHEHITS) of SEQUIN with 0) (replace (SEQUIN LEAFCACHEMISSES) of SEQUIN with 0))) (COND ((IGREATERP (fetch (SEQUIN %#SEQTIMEOUTS) of SEQUIN) 77777Q) (replace (SEQUIN %#SEQRESTARTS) of SEQUIN with 0) (replace (SEQUIN %#SEQTIMEOUTS) of SEQUIN with 0) (replace (SEQUIN %#SEQDUPLICATES) of SEQUIN with 0))) (replace (STREAM CBUFSIZE) of STREAM with 0) (* ;  "For the benefit of uCode and PageMapped fns") (replace (STREAM CBUFPTR) of STREAM with NIL) (replace (STREAM EOLCONVENTION) of STREAM with (OR EOL (SELECTQ (fetch (PUPFILESERVER PFSOSTYPE) of DEVINFO) ((TENEX TOPS20) CRLF.EOLC) (UNIX LF.EOLC) CR.EOLC] (RETURN STREAM]) (\LEAF.READFILENAME [LAMBDA (STREAM DEVINFO) (* ; "Edited 24-May-91 15:11 by jds") (LET ([REMOTENAME (LET ((NAMEBASE (\LEAF.READFILEPROP STREAM \OFFSET.FILENAME \MAXLEN.FILENAME))) (* ; "Returns (pup . base)") (AND NAMEBASE (PROG1 (GetBcplString (CDR NAMEBASE)) (RELEASE.PUP (CAR NAMEBASE)))] (OSTYPE (fetch (PUPFILESERVER PFSOSTYPE) of DEVINFO))) (COND ((NOT REMOTENAME) (* ;  "Some hosts may refuse us the name") NIL) (T [SETQ REMOTENAME (CL:APPLY (FUNCTION PACKFILENAME.STRING) 'HOST (fetch (SEQUIN SEQNAME) of (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM)) (UNPACKFILENAME.STRING (\LEAF.ADD.QUOTES REMOTENAME 'IFS) NIL NIL (if (EQ OSTYPE 'UNIX) then (* ;  "Kludge: call it an IFS, since current Unix servers return ! for the version.") 'IFS else OSTYPE] (if *UPPER-CASE-FILE-NAMES* then (MKATOM (U-CASE REMOTENAME)) else REMOTENAME]) (\LEAF.ADD.QUOTES [LAMBDA (NAME OSTYPE) (* ; "Edited 11-Jan-88 16:32 by bvm") (* ;; "The only funny char we know about is quote, so quote all the quotes with a quote.") (bind (N _ 1) I PIECES while (SETQ I (STRPOS "'" NAME N)) do (push PIECES "'" (SUBSTRING NAME N I)) (SETQ N (ADD1 I)) finally (if (AND (EQ OSTYPE 'IFS) (SETQ I (STRPOS ".!" NAME N))) then (* ; "Yet another piece of nonsense: for IFS file ending in dot, we'd better quote the dot, lest it be discarded") (push PIECES "'" (SUBSTRING NAME N (SUB1 I))) (SETQ N I)) (RETURN (if PIECES then (if (<= N (NCHARS NAME)) then (push PIECES (SUBSTRING NAME N))) (CONCATLIST (DREVERSE PIECES)) else (* ; "nothing got quoted") NAME]) (\LEAF.READFILEPROP [LAMBDA (STREAM OFFSET LEN) (* ; "Edited 24-May-91 15:07 by jds") (* ;; "Read a chunk of the IFS leader page starting at OFFSET for LEN bytes. Returns a dotted pair, car of which is the reply pup and CDR is a pointer inside it to the desired data") (PROG ((CONNECTION (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM)) (OPUP (ALLOCATE.PUP)) DATA IPUP) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.READ \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (IDIFFERENCE OFFSET \BYTES.PER.TRIDENT.PAGE)) (replace (LEAFDATA SIGNEXTEND) of DATA with 0) (replace (LEAFDATA DATALENGTH) of DATA with LEN) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.FILEREQUEST) (SETQ IPUP (\SENDLEAF CONNECTION OPUP STREAM NOFILEPROPERROR)) (RETURN (COND ((EQ (fetch (LEAFPACKET LEAFSTATUS) of IPUP) \LEAF.GOODSTATUS) (CONS IPUP (\ADDBASE (fetch PUPCONTENTS of IPUP) (FOLDLO \LEN.READANSWER BYTESPERWORD]) (\LEAF.READPAGES [LAMBDA (STREAM FIRSTPAGE BUFFERLIST) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (for BUF inside BUFFERLIST as PAGE# from FIRSTPAGE bind LEN sum [COND ((.PAGE.IS.AFTER.EOF. STREAM PAGE#) (* ; "after end of file") (SETQ LEN 0)) (T (PROG (OPUP IPUP DATA) RETRY (SETQ OPUP (\LEAF.REQUESTPAGE STREAM PAGE# T)) (for NEWPAGE# from (ADD1 PAGE#) as I to (fetch (LEAFSTREAM LEAFCACHECNT) of STREAM) until (.PAGE.IS.AFTER.EOF. STREAM NEWPAGE#) do (* ;  "Ask for pages immediately following this one, too") (\LEAF.REQUESTPAGE STREAM NEWPAGE#)) (until (NEQ (SETQ IPUP (fetch EPUSERFIELD of OPUP)) STREAM) do (AWAIT.EVENT [fetch (SEQUIN SEQEVENT) of (OR (fetch (LEAFSTREAM LEAFCONNECTION ) of STREAM) (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLFILENAME ) of STREAM] \ETHERTIMEOUT)) (RELEASE.PUP OPUP) (COND ((AND (NEQ IPUP \LEAF.BROKEN.STATUS) (NEQ (fetch (LEAFDATA LEAFOPCODE) of (SETQ DATA (fetch PUPCONTENTS of IPUP))) \LEAFOP.ERROR)) (SETQ LEN (- (fetch (LEAFDATA LEAFLENGTH) of DATA) \LEN.READANSWER)) (\BLT BUF (\ADDBASE DATA (FOLDLO \LEN.READANSWER BYTESPERWORD)) (FOLDHI LEN BYTESPERWORD)) (RELEASE.PUP IPUP) (RETURN LEN)) ((NOT (READABLE STREAM)) (LISPERROR "FILE NOT OPEN" (fetch (STREAM FULLFILENAME) of STREAM))) ((NEQ IPUP \LEAF.BROKEN.STATUS) (\LEAF.ERROR IPUP (fetch (STREAM FULLFILENAME) of STREAM) (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP)) (T (HELP "Failed to read page of file" (fetch (STREAM FULLFILENAME) of STREAM)) (GO RETRY] [COND ((< LEN BYTESPERPAGE) (\CLEARBYTES BUF LEN (- BYTESPERPAGE LEN] LEN]) (\LEAF.REQUESTPAGE [LAMBDA (STREAM PAGE# IMMEDIATE) (* ; "Edited 24-May-91 15:07 by jds") (* ;; "Requests PAGE# of STREAM, possibly finding it in the cache first. If IMMEDIATE is true, then we want the page now, and it should be removed from the cache and returned; otherwise it is completely optional whether we ask for the page at all or what we return") (PROG ((CACHE (\LEAF.LOOKUPCACHE STREAM PAGE# IMMEDIATE)) OPUP DATA) [COND ((CDR CACHE) (* ; "Cache hit!") [COND (IMMEDIATE (INCLEAFSTAT (fetch (SEQUIN LEAFCACHEHITS) of (fetch (LEAFSTREAM LEAFCONNECTION ) of STREAM))) (COND ((ILESSP (fetch (LEAFSTREAM LEAFCACHECNT) of STREAM) \LEAF.MAXLOOKAHEAD) (* ;  "Reward STREAM for being sequential") (add (fetch (LEAFSTREAM LEAFCACHECNT) of STREAM) 1] (RETURN (CDR CACHE] [COND (IMMEDIATE (* ;  "Cache miss, so we probably aren't very sequential; be more cautious") (replace (LEAFSTREAM LEAFCACHECNT) of STREAM with 1) (INCLEAFSTAT (fetch (SEQUIN LEAFCACHEMISSES) of (fetch (LEAFSTREAM LEAFCONNECTION ) of STREAM] [SETQ DATA (fetch PUPCONTENTS of (SETQ OPUP (ALLOCATE.PUP] (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.READ \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (create BYTEPTR PAGE _ PAGE# OFFSET _ 0)) (replace (LEAFDATA READWRITEMODE) of DATA with \LEAFMODE.DONTEXTEND) (* ;  "i.e. don't attempt to read past EOF, in case this is the last page") (replace (LEAFDATA DATALENGTH) of DATA with BYTESPERPAGE) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.FILEREQUEST) (RETURN (COND ((\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM T 'GO (NOT IMMEDIATE)) (AND CACHE (RPLACD CACHE OPUP)) OPUP]) (\LEAF.LOOKUPCACHE [LAMBDA (STREAM PAGE# DELETE) (* ; "Edited 24-May-91 15:07 by jds") (* ;; "Looks up PAGE# in STREAM's cache. If it finds an entry, it returns it and, if DELETE is true, deletes it from the cache; otherwise if DELETE is NIL, it inserts a new empty entry for PAGE#") (for I from 0 bind (CACHE _ (fetch (LEAFSTREAM LEAFPAGECACHE) of STREAM)) PREV while CACHE do [COND ((IEQP (CAAR CACHE) PAGE#) [COND ((NOT DELETE) (* ; "Don't remove entry from cache") ) (PREV (RPLACD PREV (CDR CACHE))) (T (replace (LEAFSTREAM LEAFPAGECACHE ) of STREAM with (CDR CACHE] (RETURN (CAR CACHE] (SETQ CACHE (CDR (SETQ PREV CACHE))) finally [COND ((NOT DELETE) (SETQ CACHE (LIST (CONS PAGE# NIL))) (COND [PREV (RPLACD PREV CACHE) (COND ((IGREATERP I \LEAF.MAXCACHE) (* ; "Throw out old cache entries") (replace (LEAFSTREAM LEAFPAGECACHE) of STREAM with (CDR (fetch (LEAFSTREAM LEAFPAGECACHE) of STREAM] (T (replace (LEAFSTREAM LEAFPAGECACHE) of STREAM with CACHE] (RETURN (CAR CACHE]) (CLEAR.LEAF.CACHE [LAMBDA (HOST) (* ; "Edited 24-May-91 15:11 by jds") (COND (HOST (PROG ([DEVICE (OR (\GETDEVICEFROMNAME HOST T T) (AND (SETQ HOST (\CANONICAL.HOSTNAME HOST)) (\GETDEVICEFROMNAME HOST T T] CONNECTION DEVINFO) (RETURN (COND ((AND DEVICE (type? PUPFILESERVER (SETQ DEVINFO (fetch DEVICEINFO of DEVICE))) (SETQ CONNECTION (ffetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO)) (fetch (SEQUIN LEAFCACHEDFILE) of CONNECTION)) (\LEAF.FLUSH.CACHE CONNECTION]) (LEAF.ASSURE.FINISHED [LAMBDA (STREAM) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (PROG [(SEQUIN (fetch (LEAFSTREAM LEAFCONNECTION) of (SETQ STREAM (\DTEST STREAM 'STREAM] TOP [COND ((type? SEQUIN SEQUIN) (WITH.MONITOR (fetch (SEQUIN SEQLOCK) of SEQUIN) (bind PUP until [AND [OR [NOT (SETQ PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQDONEQ) of SEQUIN] (while PUP never (PROG1 (EQ (fetch EPUSERFIELD of PUP) STREAM) (SETQ PUP (fetch EPLINK of PUP)))] (OR [NOT (SETQ PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN] (while PUP never (PROG1 (EQ (fetch EPUSERFIELD of PUP) STREAM) (SETQ PUP (fetch EPLINK of PUP)))] do (* ;  "Not quite right, because it doesn't catch stuff in the retransmit queue") (MONITOR.AWAIT.EVENT (fetch (SEQUIN SEQLOCK) of SEQUIN) (fetch (SEQUIN SEQEVENT) of SEQUIN) \ETHERTIMEOUT))) (COND ((NEQ (fetch (LEAFSTREAM LEAFERRORCNT) of STREAM) 0) (ERROR "Waiting for operation on broken file to finish" (fetch (STREAM FULLFILENAME ) of STREAM)) (GO TOP] (RETURN T]) (\LEAF.FORCEOUTPUT [LAMBDA (STREAM) (* bvm%: "11-Jul-84 11:31") (\PAGED.FORCEOUTPUT STREAM) (LEAF.ASSURE.FINISHED STREAM]) (\LEAF.FLUSH.CACHE [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 15:07 by jds") (WITH.MONITOR (fetch (SEQUIN LEAFOPENCLOSELOCK) of SEQUIN) [LET ((CACHE (fetch (SEQUIN LEAFCACHEDFILE) of SEQUIN))) (COND ((NULL CACHE) NIL) ((fetch (LEAFSTREAM LEAFREALLYOPEN) of CACHE) (replace (SEQUIN LEAFCACHEDFILE) of SEQUIN with NIL) NIL) (T (\LEAF.CLOSEFILE CACHE SEQUIN NIL :CACHE) (fetch (SEQUIN SEQNAME) of SEQUIN])]) (\LEAF.RENAMEFILE [LAMBDA (OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE) (* hdj " 8-May-86 15:20") (OR (AND \FTPAVAILABLE (OR (NEQ (GETHOSTINFO (fetch (FDEV DEVICENAME) of OLD-DEVICE) 'OSTYPE) 'UNIX) UNIXFTPFLG) (\FTP.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE)) (\GENERIC.RENAMEFILE OLD-DEVICE OLDFILE NEW-DEVICE NEWFILE]) (\LEAF.REOPENFILE [LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV STREAM) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (* ;;; "Called after, say, a LOGOUT to restore the file to its old state. We reopen the file and return a new file handle") (PROG (NEWSTREAM OLDINFO NEWINFO OLDDATES) [COND ((NEQ ACCESS 'INPUT) (* ;; "Problem: when we reopen the file for write, we change the write and creation dates, so our caller thinks the file has been modified. So first open the file for read and look at the dates, and if they're the same as the old filehandle's, prepare to restore them") (COND ((SETQ NEWSTREAM (\LEAF.GETFILE FDEV NAME 'NONE 'OLD T 'DATES)) [COND ((AND [IEQP (fetch (LEAFINFOBLOCK LFCREATIONDATE) of (SETQ OLDINFO (fetch (LEAFSTREAM LEAFINFO) of STREAM))) (fetch (LEAFINFOBLOCK LFCREATIONDATE) of (SETQ NEWINFO (fetch (LEAFSTREAM LEAFINFO) of NEWSTREAM] (IEQP (fetch (LEAFINFOBLOCK LFWRITEDATE) of OLDINFO) (fetch (LEAFINFOBLOCK LFWRITEDATE) of NEWINFO))) (* ;  "Creation and write dates are indeed the same") (SETQ OLDDATES (\LEAF.CREATIONDATE NEWSTREAM] (\LEAF.CLOSEFILE NEWSTREAM NIL NIL T)) (T (* ;  "If we can't even find the file, there's no hope") (RETURN NIL] [COND ((AND (SETQ NEWSTREAM (\LEAF.GETFILE FDEV NAME ACCESS RECOG T NIL NEWSTREAM)) OLDDATES) (* ;  "Change the filedates to the old dates") (\LEAF.SETCREATIONDATE NEWSTREAM OLDDATES) (* ;; "And smash the validation of the old handle to be the new validation. This is sort of a cheat, but it works to fool \REVALIDATEFILE") (replace (STREAM VALIDATION) of STREAM with (fetch (STREAM VALIDATION) of NEWSTREAM] (RETURN NEWSTREAM]) (\LEAF.CREATIONDATE [LAMBDA (STREAM) (* ; "Edited 24-May-91 15:08 by jds") (ALTO.TO.LISP.DATE (fetch (LEAFINFOBLOCK LFCREATIONDATE) of (fetch (LEAFSTREAM LEAFINFO) of STREAM]) (\LEAF.SETCREATIONDATE [LAMBDA (STREAM DATE) (* ; "Edited 24-May-91 15:08 by jds") (* ;  "DATE is integer in Lisp date format") (PROG ((INFOBLK (\LEAF.GETFILEDATES STREAM)) (FILEDATE (LISP.TO.ALTO.DATE DATE)) (OPUP (ALLOCATE.PUP)) DATA) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.WRITE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (IDIFFERENCE 0 \BYTES.PER.TRIDENT.PAGE)) (* ;  "negative address into leader page") (replace (LEAFDATA SIGNEXTEND) of DATA with 0) (replace (LEAFDATA DATALENGTH) of DATA with \LEN.DATE) (replace (LEAFDATA LEAFFILEDATE) of DATA with FILEDATE) (replace (LEAFDATA LEAFLENGTH) of DATA with (IPLUS \LEN.FILEREQUEST \LEN.DATE)) (\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM NIL T) (replace (LEAFINFOBLOCK LFCREATIONDATE) of INFOBLK with FILEDATE) (\LEAF.SETVALIDATION STREAM) (* ;  "Since validation depends on file dates") (RETURN T]) (\LEAF.SETFILEINFO [LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* bvm%: "12-SEP-83 14:16") (PROG ((WASOPEN (type? STREAM STREAM))) (SELECTQ ATTRIBUTE (CREATIONDATE (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (ICREATIONDATE (OR (FIXP VALUE) (LISPERROR "NON-NUMERIC ARG" VALUE))) (TYPE) (RETURN)) (RETURN (COND ([OR WASOPEN (SETQ STREAM (\LEAF.GETFILE DEV STREAM 'NONE 'OLD] (PROG1 (SELECTQ ATTRIBUTE (TYPE (\LEAF.SETFILETYPE STREAM VALUE)) (\LEAF.SETCREATIONDATE STREAM VALUE)) (COND ((NOT WASOPEN) (\LEAF.CLOSEFILE STREAM T))))]) (\LEAF.SETFILETYPE [LAMBDA (STREAM TYPE BYTESIZE) (* ; "Edited 24-May-91 15:08 by jds") (* ;  "Sets 'type' of file to TEXT or BINARY") (PROG ((OPUP (ALLOCATE.PUP)) DATA) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.WRITE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (IDIFFERENCE \OFFSET.FILETYPE \BYTES.PER.TRIDENT.PAGE)) (* ;  "negative address into leader page") (replace (LEAFDATA SIGNEXTEND) of DATA with 0) (replace (LEAFDATA DATALENGTH) of DATA with \LEN.FILETYPE&SIZE) (* ;  "Patch: IFS code has bug that only lets me do a write with length=4 here") [COND ((LISTP TYPE) (* ;  "E.g. (BINARY 16). Does anyone else know about this?") (SETQ BYTESIZE (FIXP (CADR TYPE))) (SETQ TYPE (CAR TYPE] (replace (LEAFDATA LEAFFILETYPE) of DATA with (SELECTQ TYPE (TEXT \FT.TEXT) (NIL \FT.UNKNOWN) \FT.BINARY)) (replace (LEAFDATA LEAFBYTESIZE) of DATA with (OR BYTESIZE 10Q)) (replace (LEAFDATA LEAFLENGTH) of DATA with (IPLUS \LEN.FILEREQUEST \LEN.FILETYPE&SIZE)) (\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM NIL T) (RETURN TYPE]) (\LEAF.SETVALIDATION [LAMBDA (STREAM) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (* ;;; "Set the VALIDATION field of STREAM based on the file's write and creation dates") (replace (STREAM VALIDATION) of STREAM with (\MAKENUMBER (fetch (LEAFINFOBLOCK LOCREATE) of (fetch (LEAFSTREAM LEAFINFO) of STREAM)) (fetch (LEAFINFOBLOCK LOWRITE) of (fetch (LEAFSTREAM LEAFINFO) of STREAM]) (\LEAF.TRUNCATEFILE [LAMBDA (STREAM LASTPAGE LASTOFF) (* ; "Edited 24-May-91 15:08 by jds") (* ;;; "Truncate file by doing a zero-length write with the EOF bit set") (COND (LASTPAGE (* ;  "Don't bother if defaulting, we have already set correct length if so") (PROG ((OPUP (ALLOCATE.PUP)) DATA) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.WRITE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (create BYTEPTR PAGE _ LASTPAGE OFFSET _ LASTOFF)) (replace (LEAFDATA EOFBIT) of DATA with 1) (replace (LEAFDATA DATALENGTH) of DATA with 0) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.FILEREQUEST) (\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM NIL T) (RETURN STREAM]) (\LEAF.WRITEPAGES [LAMBDA (STREAM FIRSTPAGE BUFFERLIST) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (COND ((fetch (STREAM REVALIDATEFLG) of STREAM) (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write. Otherwise, it is possible to see a change to the file but no change to the creationdate") (\LEAF.SETCREATIONDATE STREAM (IDATE)) (replace (STREAM REVALIDATEFLG) of STREAM with NIL))) (for BUF inside BUFFERLIST as PAGE# from FIRSTPAGE do (\LEAF.LOOKUPCACHE STREAM PAGE# T) (* ;  "Invalidate any read-ahead of this page") (PROG ((OPUP (ALLOCATE.PUP)) DATA LEN) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (replace (LEAFDATA OPWORD) of DATA with (LLSH \LEAFOP.WRITE \OPCODE.SHIFT)) (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) (replace (LEAFDATA FILEADDRESS) of DATA with (create BYTEPTR PAGE _ PAGE# OFFSET _ 0)) [replace (LEAFDATA DATALENGTH) of DATA with (SETQ LEN (COND ((NEQ PAGE# (fetch (STREAM EPAGE) of STREAM)) BYTESPERPAGE) (T (* ;  "On last page, only write as much as we really have") (replace (LEAFDATA EOFBIT) of DATA with 1) (fetch (STREAM EOFFSET) of STREAM] (\BLT (\ADDBASE DATA (FOLDLO \LEN.FILEREQUEST BYTESPERWORD)) BUF (FOLDHI LEN BYTESPERWORD)) (replace (LEAFDATA LEAFLENGTH) of DATA with (IPLUS \LEN.FILEREQUEST LEN)) (\SENDLEAF (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) OPUP STREAM NIL T]) ) (* ;; "Main routing point for LEAF pups") (DEFINEQ (\SENDLEAF [LAMBDA (SEQUIN PUP FILENAME NOERROR NOREPLY DONTWAIT) (* ;  "Edited 2-Nov-92 03:36 by sybalsky:mv:envos") (PROG (RESULT) TOP (OR SEQUIN (RETURN (LISPERROR "FILE NOT OPEN" FILENAME))) (COND ((AND (type? STREAM FILENAME) (NEQ (fetch (LEAFSTREAM LEAFERRORCNT) of FILENAME) 0)) (ERROR "Attempt to operate on broken file. Do not proceed until the problem has been resolved." (fetch (STREAM FULLFILENAME) of FILENAME)) (GO TOP))) (replace EPUSERFIELD of PUP with FILENAME) [replace (LEAFPACKET LEAFFLAGS) of PUP with (LOGOR (COND (NOERROR \LF.ALLOWERRORS) (T 0)) (COND ((EQ NOREPLY T) 0) (T \LF.WANTANSWER] (replace PUPLENGTH of PUP with (IPLUS (fetch (LEAFDATA LEAFLENGTH) of (fetch PUPCONTENTS of PUP)) \PUPOVLEN)) (RETURN (COND ((NULL (PUTSEQUIN SEQUIN PUP DONTWAIT)) NIL) (NOREPLY T) (T (until (NEQ (fetch EPUSERFIELD of PUP) FILENAME) do (AWAIT.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN) \ETHERTIMEOUT)) (SETQ RESULT (fetch EPUSERFIELD of PUP)) (COND ((EQ RESULT \LEAF.BROKEN.STATUS) PUP) (T (replace (LEAFPACKET LEAFSTATUS) of RESULT with (COND ((EQ (fetch (LEAFDATA LEAFOPCODE) of (fetch PUPCONTENTS of RESULT)) \LEAFOP.ERROR) (fetch (LEAFERRORDATA LEAFERRORCODE) of (fetch PUPCONTENTS of RESULT))) (T \LEAF.GOODSTATUS))) (RELEASE.PUP PUP) RESULT]) ) (* ;; "Managing LEAF connections") (DEFINEQ (\OPENLEAFCONNECTION [LAMBDA (HOST) (* ; "Edited 24-May-91 15:04 by jds") (PROG (PROTOCOLS IFSPORT NAME/PASS) [COND ([OR (MEMB HOST NONLEAFHOSTS) (AND [LISTP (SETQ PROTOCOLS (GETHOSTINFO HOST 'PROTOCOLS] (NOT (MEMB 'LEAF PROTOCOLS] (RETURN \LEAF.NEVER.OPENED)) ((NOT (SETQ IFSPORT (BESTPUPADDRESS HOST PROMPTWINDOW))) (RETURN)) ((EQ (CDR IFSPORT) 0) (SETQ IFSPORT (CONS (CAR IFSPORT) \SOCKET.LEAF] (SETQ NAME/PASS (\INTERNAL/GETPASSWORD HOST)) (RETURN (WITH.MONITOR \LEAFCONNECTIONLOCK (* ; "NOTE: Implicit RESETLST") (PROG (CONN RESULT DATA OPUP) [SETQ CONN (create SEQUIN SEQNAME _ HOST SEQFRNPORT _ IFSPORT SEQACKED _ (FUNCTION \LEAF.ACKED) SEQINPUT _ (FUNCTION \LEAF.HANDLE.INPUT) SEQBROKEN _ (FUNCTION \LEAF.FIX.BROKEN.SEQUIN) SEQABORTED _ (FUNCTION \LEAF.FIX.BROKEN.SEQUIN) SEQTIMEDOUT _ (FUNCTION \LEAF.TIMEDOUT) SEQTIMEDIN _ (FUNCTION \LEAF.TIMEDIN) SEQCLOSED _ (FUNCTION \LEAF.WHENCLOSED) SEQIDLEFN _ (FUNCTION \LEAF.IDLE) SEQIDLETIMEOUTCOMPUTER _ (FUNCTION \LEAF.IDLE?) SEQOPENERRORHANDLER _ (FUNCTION \LEAF.OPENERRORHANDLER) SEQDONEQ _ (NCREATE 'SYSQUEUE) LEAFCACHETIMER _ (\CREATECELL \FIXP) SEQIGNOREDUPLICATES _ T LEAFOPENCLOSELOCK _ (CREATE.MONITORLOCK (CONCAT HOST "#LEAFOPEN" ] (INITSEQUIN CONN (PACK* HOST "#LEAF")) (replace (SEQUIN LEAFCACHEHITS) of CONN with 0) (replace (SEQUIN LEAFCACHEMISSES) of CONN with 0) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (SEQUIN) (AND RESETSTATE (\SEQUIN.CLOSE SEQUIN] CONN)) RETRY (PROGN (SETQ OPUP (ALLOCATE.PUP))(* ; "Build a LEAF RESET op") (SETQ DATA (fetch PUPCONTENTS of OPUP)) (\CLEARBYTES DATA 0 \LEN.RESETLEAF) (replace (LEAFDATA LEAFOPCODE) of DATA with \LEAFOP.RESET ) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.RESETLEAF ) (\ADDLEAFSTRING OPUP (CAR NAME/PASS)) (\ADDLEAFSTRING OPUP (CDR NAME/PASS) T) (replace PUPLENGTH of OPUP with (+ (fetch (LEAFDATA LEAFLENGTH) of DATA) \PUPOVLEN))) (replace EPUSERFIELD of OPUP with NIL) (replace (LEAFPACKET LEAFFLAGS) of OPUP with (LOGOR \LF.ALLOWERRORS \LF.WANTANSWER )) (PUTSEQUIN CONN OPUP) (until (SELECTC (fetch (SEQUIN SEQSTATE) of CONN) (\SS.OPENING (* ; "still waiting for an answer") NIL) (\SS.OPEN (* ;  "Connection has become open, or already was if this is a retry") (SETQ RESULT (fetch EPUSERFIELD of OPUP))) (PROGN (* ; "Some bad state") (SETQ RESULT (fetch EPUSERFIELD of OPUP)) T)) do (AWAIT.EVENT (fetch (SEQUIN SEQEVENT ) of CONN) \ETHERTIMEOUT)) (SELECTC RESULT ((LIST NIL \LEAF.BROKEN.STATUS) (RETURN NIL)) (\LEAF.NEVER.OPENED (RETURN \LEAF.NEVER.OPENED)) NIL) (COND ((EQ (fetch (LEAFDATA LEAFOPCODE) of (fetch PUPCONTENTS of RESULT)) \LEAFOP.ERROR) (SELECTC (SETQ RESULT (PROG1 (fetch (LEAFERRORDATA LEAFERRORCODE) of (fetch PUPCONTENTS of RESULT)) (RELEASE.PUP RESULT))) (\PASSWORD.ERRORS (* ; "Password error") (COND ((SETQ NAME/PASS (\FIXPASSWORD RESULT CONN)) (GO RETRY)))) NIL) (\SEQUIN.CLOSE CONN) (RETURN NIL))) (RELEASE.PUP RESULT) (LET [(TIMEOUT (TIMES 2 (IQUOTIENT \LEAF.IDLETIMEOUT 11610Q] (* ;; "Build a LEAF PARAMS op, making the connection timeout be twice the time that we would time it out ourselves (so as to reduce the likelihood that the server would kill us without our consent).") (SETQ OPUP (ALLOCATE.PUP)) (SETQ DATA (fetch PUPCONTENTS of OPUP)) (\CLEARBYTES DATA 0 \LEN.LEAFPARAMS) (replace (LEAFDATA LEAFOPCODE) of DATA with \LEAFOP.PARAMS) (replace (LEAFDATA LEAFLENGTH) of DATA with \LEN.LEAFPARAMS ) (replace (LEAFPARAMSDATA LEAFPCONNTIMEOUT) of DATA with TIMEOUT) (replace (LEAFPARAMSDATA LEAFPLOCKTIMEOUT) of DATA with TIMEOUT) (* ;  "Make lock timeout the same, so we don't have silly lock broken stuff to worry about.") (replace PUPLENGTH of OPUP with (+ \LEN.LEAFPARAMS \PUPOVLEN))) (replace EPUSERFIELD of OPUP with NIL) (replace (LEAFPACKET LEAFFLAGS) of OPUP with \LF.ALLOWERRORS) (PUTSEQUIN CONN OPUP) (RETURN CONN)))]) (\LEAF.BREAKCONNECTION [LAMBDA (HOST DEVICE FAST) (* ; "Edited 24-May-91 15:12 by jds") (* ;;; "Breaks connection to host, if there is one. Returns T if it broke something, NIL if there was nothing to break. If FAST is true, does not attempt to cleanly close any files open on the host") (LET (CONNECTION FILES DEVINFO) (COND ((AND (type? PUPFILESERVER (SETQ DEVINFO (fetch DEVICEINFO of DEVICE))) (SETQ CONNECTION (fetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO))) [COND ((SETQ FILES (FDEVOP 'OPENP DEVICE NIL NIL DEVICE)) (COND (FAST (for S in FILES do (FDEVOP 'UNREGISTERFILE DEVICE DEVICE S))) (T (MAPC FILES (FUNCTION CLOSEF] (\CLOSELEAFCONNECTION CONNECTION DEVICE]) (\CLOSELEAFCONNECTION [LAMBDA (CONN DEVICE) (* ; "Edited 24-May-91 14:53 by jds") (PROG1 [COND ((CLOSESEQUIN CONN) (fetch (SEQUIN SEQNAME) of CONN)) (T (LIST (fetch (SEQUIN SEQNAME) of CONN) 'aborted] (replace (LEAFDEVICE PFSLEAFSEQUIN) of DEVICE with NIL))]) (\LEAF.EVENTFN [LAMBDA (FDEV EVENT-TYPE) (* ; "Edited 24-May-91 15:12 by jds") (* ;;; "Called before LOGOUT etc to clean up any leaf connections we have open") (PROG ((DEVINFO (fetch DEVICEINFO of FDEV)) CONNECTION SOC) (SELECTQ EVENT-TYPE ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT) (COND ((SETQ CONNECTION (fetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO)) (\FLUSH.OPEN.STREAMS FDEV) (* ;; "Would like to have a monitor on this to prevent other processes from writing files now, but it can't be the main sequin lock") (\CLOSELEAFCONNECTION CONNECTION FDEV)))) ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) (COND ((SETQ CONNECTION (fetch (PUPFILESERVER PFSLEAFSEQUIN) of DEVINFO)) (\SEQUIN.FLUSH.CONNECTION CONNECTION \SS.ABORT))) (COND ((NOT (FDEVOP 'OPENP FDEV NIL NIL FDEV)) (* ;; "Association between hostname and host goes away over logout, so flush it. If there is a file open on it, however, assume it's okay") (\REMOVEDEVICE FDEV))) (COND ((SETQ SOC (fetch (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO)) (CLOSEPUPSOCKET SOC) (replace (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO with NIL))) (replace (PUPFILESERVER PFSLOOKUPFILELOCK) of DEVINFO with NIL) (* ; "revalidate open files") (\PAGED.REVALIDATEFILELST FDEV)) NIL]) ) (* ; "This generic fn ought to be on FILEIO") (DEFINEQ (BREAKCONNECTION [LAMBDA (HOST FAST) (* ; "Edited 23-Dec-87 12:29 by bvm:") (* ;;; "User entry. Breaks connection to host, if there is one, or all hosts if host = t. Returns name of any device that handled it. If FAST is true, may not attempt to cleanly close any files open on the host") (LET (DEVICE BREAKFN) (COND ((EQ HOST T) (for DEV in \FILEDEVICES when (AND (SETQ BREAKFN (fetch BREAKCONNECTION of DEV)) (CL:FUNCALL BREAKFN (fetch DEVICENAME of DEV) DEV FAST)) collect (fetch DEVICENAME of DEV))) ((AND [OR (SETQ DEVICE (\GETDEVICEFROMNAME HOST T T)) (AND (SETQ HOST (CANONICAL.HOSTNAME HOST)) (SETQ DEVICE (\GETDEVICEFROMNAME HOST T T] (SETQ BREAKFN (fetch BREAKCONNECTION of DEVICE)) (CL:FUNCALL BREAKFN (fetch DEVICENAME of DEVICE) DEVICE FAST)) (fetch DEVICENAME of DEVICE]) ) (* ;; "Functions called when various SEQUIN events occur") (DEFINEQ (\LEAF.ACKED [LAMBDA (PUP SEQUIN) (* ; "Edited 24-May-91 14:53 by jds") (* ;; "Called when a packet has been acked") (\ENQUEUE (fetch (SEQUIN SEQDONEQ) of SEQUIN) PUP) (add (fetch (SEQUIN SEQINPUTQLENGTH) of SEQUIN) 1]) (\LEAF.FIX.BROKEN.SEQUIN [LAMBDA (SEQUIN PUP) (* ; "Edited 24-May-91 15:08 by jds") (* ;;  "Called when BROKEN received. Try to open a new connection, and transfer everything over") (PROG ((STATE (fetch (SEQUIN SEQSTATE) of SEQUIN)) (RETRANSQ (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN)) (ACKEDQ (fetch (SEQUIN SEQDONEQ) of SEQUIN)) (DEVICE (\GETDEVICEFROMNAME (fetch (SEQUIN SEQNAME) of SEQUIN))) UNANSWEREDPUPS AFFECTEDFILES NEWCONNECTION STRM) (\SEQUIN.FLUSH.RETRANSMIT SEQUIN) (COND (PUP (* ;  "Attempt to send PUP on a broken connection") (GO GET.NEW.CONNECTION))) [COND ((SETQ UNANSWEREDPUPS (fetch SYSQUEUEHEAD of ACKEDQ)) (* ;  "There were acked but not answered packets, so process them ahead of the unacked ones") (replace EPLINK of (fetch SYSQUEUETAIL of ACKEDQ) with (fetch SYSQUEUEHEAD of RETRANSQ)) (replace SYSQUEUEHEAD of ACKEDQ with (replace SYSQUEUETAIL of ACKEDQ with NIL))) (T (SETQ UNANSWEREDPUPS (fetch SYSQUEUEHEAD of RETRANSQ] (SELECTC STATE (\SS.OPENING (* ;; "Probably means we crashed on this local machine a while back using exactly the same socket number, so leaf thinks we're confused. This virtually never happens now that we choose Pup sockets more cleverly") (COND ((AND UNANSWEREDPUPS (NOT (fetch EPLINK of UNANSWEREDPUPS)) (EQ (fetch (LEAFDATA LEAFOPCODE) of (fetch PUPCONTENTS of UNANSWEREDPUPS )) \LEAFOP.RESET)) [replace (SEQUIN SEQSOCKET) of SEQUIN with (PROG1 (OPENPUPSOCKET) (* ; "Get a new socket and try again") (CLOSEPUPSOCKET (fetch (SEQUIN SEQSOCKET) of SEQUIN)))] (replace PUPSOURCESOCKET of UNANSWEREDPUPS with 0) (* ;  "Let SENDPUP fill in the new socket") (RETURN (\SEQUIN.RETRANSMIT SEQUIN))) (T (GO FAILURE)))) ((LIST \SS.OPEN \SS.CLOSING) (COND ((NULL UNANSWEREDPUPS) (* ;  "No activity has gone unanswered here, so safe to just abort the connection") (\SEQUIN.FLUSH.CONNECTION SEQUIN) (RETURN T)))) (GO FAILURE)) (* ;; "This SEQUIN is bad, probably because of a file server crash (or we were idle a long time and it timed us out) so flush it and try to establish a new one, retransmitting anything that wasn't yet answered") (replace SYSQUEUEHEAD of RETRANSQ with (replace SYSQUEUETAIL of RETRANSQ with NIL)) (* ;  "Detach old queues of packets from dead connection") (printout PROMPTWINDOW "[Connection with " (fetch (SEQUIN SEQNAME) of SEQUIN) " crashed; " "trying to establish new connection...") GET.NEW.CONNECTION (SETQ AFFECTEDFILES (for STREAM in (FDEVOP 'OPENP DEVICE NIL NIL DEVICE) collect STREAM when (EQ (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) SEQUIN))) RETRY.NEW.CONNECTION [COND ([SETQ NEWCONNECTION (\LEAF.RECONNECT DEVICE (AND (EQ (fetch (SEQUIN LEAFABORTSTATUS) of SEQUIN) 'ABORT) (NOT (\CLOCKGREATERP (fetch (SEQUIN SEQTIMER) of SEQUIN) \LEAF.RECOVERY.TIMEOUT] (* ;  "Succeeded in getting a new connection, so restore files") (\SEQUIN.FLUSH.CONNECTION SEQUIN) [COND ((AND \WINDOWWORLD (NOT (HASTTYWINDOWP))) (* ;; "Assure that output from what follows has enough space to print. Note that this does not actually open the window (though it may create it). Also, we don't care about restoration on exit, because this process is doomed anyway.") (WINDOWPROP T 'PAGEFULLFN (FUNCTION EXPANDING-PAGEFULLFN] (COND (PUP (* ;  "Attempt to send PUP on a broken connection") (AND AFFECTEDFILES (\PAGED.REVALIDATEFILELST DEVICE)) (RETURN (\LEAF.REPAIR.BROKEN.PUP SEQUIN PUP))) ((NOT (SETQ UNANSWEREDPUPS (\LEAF.USE.NEW.CONNECTION NEWCONNECTION UNANSWEREDPUPS AFFECTEDFILES))) (printout PROMPTWINDOW "done]" T) (RETURN T] (COND ((NULL (fetch (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN)) (\SEQUIN.FLUSH.CONNECTION SEQUIN)) ((forDuration 165140Q do (COND ((EQ (fetch (SEQUIN LEAFABORTSTATUS) of SEQUIN) 'ABORT) (\SEQUIN.FLUSH.CONNECTION SEQUIN) (RETURN T))) (AWAIT.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN) 11610Q)) (RETURN)) (T (GO RETRY.NEW.CONNECTION))) (* ;; "Either failed to make the new connection or something happened to the file") FAILURE [ERROR "File server connection has been broken--cannot complete file operation(s). (RETURN) to try again to get a new connection." (COND ((AND PUP (SETQ STRM (fetch EPUSERFIELD of PUP))) (.NAMEORSTREAM. STRM)) (T (fetch (SEQUIN SEQNAME) of SEQUIN] (GO RETRY.NEW.CONNECTION]) (\LEAF.REPAIR.BROKEN.PUP [LAMBDA (OLDSEQUIN PUP) (* ;  "Edited 2-Nov-92 03:37 by sybalsky:mv:envos") (* ;; "PUP is a pup that we were trying to send on a dead sequin. If we have since established the new connection, there is a new sequin in PUP's stream, and we can patch the pup. Returns the new connection, or NIL if it can't") (PROG ((STREAM (fetch EPUSERFIELD of PUP)) NEWCONNECTION DATA) [COND ((OR (NULL STREAM) (NOT (type? STREAM STREAM))) (* ; "Not much to go on") ) ((AND (SETQ NEWCONNECTION (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM)) (NEQ NEWCONNECTION OLDSEQUIN) (SELECTC (fetch (LEAFDATA LEAFOPCODE) of (SETQ DATA (fetch PUPCONTENTS of PUP))) ((LIST \LEAFOP.READ \LEAFOP.WRITE \LEAFOP.TRUNCATE \LEAFOP.DELETE \LEAFOP.CLOSE) (* ;  "These operations all have their handle in the same place") (replace (LEAFDATA HANDLE) of DATA with (fetch (LEAFSTREAM LEAFHANDLE) of STREAM)) T) NIL)) (RETURN NEWCONNECTION)) (T (ERROR "File server connection broken" (OR (fetch (STREAM FULLFILENAME) of STREAM) STREAM] (replace (LEAFPACKET LEAFSTATUS) of PUP with \LEAF.BROKEN.STATUS) (RETURN NIL]) (\LEAF.USE.NEW.CONNECTION [LAMBDA (SEQUIN UNSENTPUPS AFFECTEDFILES) (* ;  "Edited 2-Nov-92 03:37 by sybalsky:mv:envos") (PROG (BUSYFILES OPCODE OLDSTREAM PUP DATA GOODPUPS BADPUPS RESENDPUPS) (while UNSENTPUPS do [SETQ PUP (COND ((LISTP UNSENTPUPS) (* ;  "We're given a list of packets, so hand them back one at a time.") (POP UNSENTPUPS)) (T (* ;  "Given a single packet, follow the normal queue line field.") (PROG1 UNSENTPUPS (SETQ UNSENTPUPS (fetch EPLINK of UNSENTPUPS)))] (replace EPLINK of PUP with NIL) (SELECTC [SETQ OPCODE (fetch (LEAFDATA LEAFOPCODE) of (SETQ DATA (fetch PUPCONTENTS of PUP] ((LIST \LEAFOP.READ \LEAFOP.WRITE \LEAFOP.TRUNCATE \LEAFOP.DELETE) (* ;  "These operations all have their handle in the same place") (COND ((SETQ OLDSTREAM (fetch EPUSERFIELD of PUP)) (pushnew AFFECTEDFILES OLDSTREAM) (pushnew BUSYFILES OLDSTREAM) (push GOODPUPS PUP)) (T (* ; "Shouldn't happen") (push BADPUPS PUP)))) (\LEAFOP.CLOSE [COND ((SETQ OLDSTREAM (fetch EPUSERFIELD of PUP)) (COND ((FMEMB OLDSTREAM BUSYFILES) (* ;  "There are other operations on this file, so include the close") (push GOODPUPS PUP)) ((DIRTYABLE OLDSTREAM) (push BUSYFILES OLDSTREAM)) (T (* ;  "Closing a file open only for read; don't bother") (SETQ AFFECTEDFILES (DREMOVE OLDSTREAM AFFECTEDFILES]) (\LEAFOP.OPEN (* ;; "just trying to open a file, so should work fine with the new connection; however, \LEAF.GETFILE needs to know to use the new connection, so easier to just mark it broken here") (replace (LEAFPACKET LEAFSTATUS) of PUP with \LEAF.BROKEN.STATUS)) (push BADPUPS PUP))) (for STREAM in (UNION BUSYFILES AFFECTEDFILES) when (DIRTYABLE STREAM) do (printout T T "*****Warning: " (fetch (STREAM FULLFILENAME) of STREAM) " was open for write during a file server crash; data may be lost" T T)) (COND (AFFECTEDFILES (SETQ AFFECTEDFILES (\PAGED.REVALIDATEFILES AFFECTEDFILES)) (* ;  "Reopen those files, make sure they still exist and haven't been modified") )) [for PUP in GOODPUPS do (* ; "Do operation with new handle") (COND ((FMEMB (SETQ OLDSTREAM (fetch EPUSERFIELD of PUP)) AFFECTEDFILES) (replace (LEAFDATA HANDLE) of (fetch PUPCONTENTS of PUP) with (fetch (LEAFSTREAM LEAFHANDLE) of OLDSTREAM)) (push RESENDPUPS PUP)) (T (push BADPUPS PUP] [COND (RESENDPUPS (ADD.PROCESS (LIST '\LEAF.RESENDPUPS (KWOTE SEQUIN) (KWOTE RESENDPUPS] (RETURN BADPUPS]) (\LEAF.RESENDPUPS [LAMBDA (SEQUIN PUPS) (* bvm%: "17-APR-83 18:10") (while PUPS do (replace PUPSOURCESOCKET of (CAR PUPS) with 0) (PUTSEQUIN SEQUIN (pop PUPS]) (\LEAF.HANDLE.INPUT [LAMBDA (PUP SEQUIN) (* ; "Edited 24-May-91 15:08 by jds") (* ;  "Called when a data sequin arrives") (PROG ((PUPDATA (fetch PUPCONTENTS of PUP)) DONEPUP DONEPUPDATA ERROR OPCODE STREAM) (* ;; "Under current scheme, where every requesting packet is responded to by exactly one packet, we 'know' that PUP matches up with the head of SEQDONEQ. The error checking here is thus for protocol violation and is optional") (SETQ DONEPUP (\DEQUEUE (fetch (SEQUIN SEQDONEQ) of SEQUIN))) [COND ((NOT DONEPUP) (RETURN (SHOULDNT "Leaf lost a packet somewhere!"] (add (fetch (SEQUIN SEQINPUTQLENGTH) of SEQUIN) -1) [COND ((EQ (fetch (LEAFDATA ANSWERBIT) of PUPDATA) 0) (HELP "Leaf Protocol violation--will terminate connection" (fetch (SEQUIN SEQNAME) of SEQUIN)) (RETURN (RELEASE.PUP PUP] (COND ((EQ (SETQ OPCODE (fetch (LEAFDATA LEAFOPCODE) of PUPDATA)) \LEAFOP.ERROR) (SETQ OPCODE (fetch (LEAFERRORDATA LEAFERROROPCODE) of PUPDATA)) (SETQ ERROR T))) (COND ((AND (NEQ (fetch (LEAFDATA LEAFOPCODE) of (SETQ DONEPUPDATA (fetch PUPCONTENTS of DONEPUP ))) OPCODE) LEAFDEBUGFLG) (* ;  "Protocol violation, but the buggy Vax server does this") (HELP "Answer does not match head of done queue" PUP)) ([AND ERROR (NOT (fetch (LEAFPACKET LEAFALLOWERRORS) of DONEPUP)) (NOT (AND (EQ OPCODE \LEAFOP.CLOSE) (EQ (fetch (LEAFERRORDATA LEAFERRORCODE) of PUPDATA) \IFSERROR.BAD.HANDLE] (* ;; "Last clause says that if we were closing the file and got a bad handle error, to ignore it -- this typically happens if two files try to close the same file simultaneously") (replace (LEAFPACKET LEAFSTATUS) of PUP with (fetch (LEAFERRORDATA LEAFERRORCODE) of DONEPUPDATA)) (SETQ STREAM (fetch EPUSERFIELD of DONEPUP)) (COND ((type? STREAM STREAM) (add (fetch (LEAFSTREAM LEAFERRORCNT) of STREAM) 1))) (replace EPUSERFIELD of DONEPUP with PUP) (ADD.PROCESS (LIST (FUNCTION \LEAF.ERROR) PUP (KWOTE STREAM) SEQUIN DONEPUP))) ((fetch (LEAFPACKET LEAFANSWERWANTED) of DONEPUP) (* ;; "Match the request with its response; requestor will watch this slot. Eventually change this to a NOTIFY") (replace EPUSERFIELD of DONEPUP with PUP)) (T (RELEASE.PUP PUP) (RELEASE.PUP DONEPUP]) (\LEAF.OPENERRORHANDLER [LAMBDA (SEQUIN PUP) (* ; "Edited 24-May-91 14:54 by jds") (SELECTC (fetch ERRORPUPCODE of PUP) (\PUPE.NOSOCKET (printout PROMPTWINDOW T "[No Leaf Server on " (fetch (SEQUIN SEQNAME) of SEQUIN )) (COND (\FTPAVAILABLE (printout PROMPTWINDOW "; trying FTP..."))) (printout PROMPTWINDOW "]") \SS.NOSOCKET) (\PUPE.NOROUTE (printout PROMPTWINDOW T "[No route to " (fetch (SEQUIN SEQNAME) of SEQUIN) "]") T) NIL]) (\LEAF.TIMEDIN [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:54 by jds") (COND ((fetch (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN) (CLOSEW (fetch (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN)) (replace (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN with NIL) (replace (SEQUIN LEAFABORTSTATUS) of SEQUIN with NIL))) (replace (SEQUIN LEAFTIMEOUTSTATUS) of SEQUIN with NIL]) (\LEAF.TIMEDOUT [LAMBDA (SEQUIN CNT) (* ; "Edited 24-May-91 14:54 by jds") (* ; "The SEQTIMEDOUT fn for LEAF") (COND ((EQ (fetch (SEQUIN LEAFABORTSTATUS) of SEQUIN) 'ABORT) (\SEQUIN.CONTROL SEQUIN \SEQUIN.BROKEN) (\SEQUIN.FLUSH.CONNECTION SEQUIN)) ((>= CNT \MAXLEAFTRIES) (PROG ((TRIES (fetch (SEQUIN LEAFTIMEOUTSTATUS) of SEQUIN)) (STATE (fetch (SEQUIN SEQSTATE) of SEQUIN)) PUP) (if (NULL TRIES) then (* ; "First time partner is slow") (SELECTC STATE (\SS.OPENING (* ; "can't open connection") (\LEAF.NOT.RESPONDING SEQUIN :OPEN PROMPTWINDOW) (\SEQUIN.FLUSH.CONNECTION SEQUIN)) (\SS.OPEN (if (SETQ PUP (\LEAF.STREAM.IN.QUEUE SEQUIN)) then (* ; "Something is going on worth mentioning. If the only thing in the queue is us trying to close the cache, say, we keep quiet") (\LEAF.NOT.RESPONDING SEQUIN PUP PROMPTWINDOW) (COND (PUPTRACEFLG (\LEAF.NOT.RESPONDING SEQUIN PUP PUPTRACEFILE) (TERPRI PUPTRACEFILE))) (replace (SEQUIN LEAFTIMEOUTSTATUS) of SEQUIN with CNT))) (\SS.CLOSING [COND ((NULL (SETQ PUP (\LEAF.STREAM.IN.QUEUE SEQUIN T))) (* ;  "Safe to abort connection, since no information left to be acked") (COND (PUPTRACEFLG (printout PUPTRACEFILE T "[File server connection to " (fetch (SEQUIN SEQNAME) of SEQUIN) " aborted]"))) (RETURN (\SEQUIN.FLUSH.CONNECTION SEQUIN] (\LEAF.NOT.RESPONDING SEQUIN PUP PROMPTWINDOW)) NIL) elseif (EQ CNT (+ TRIES \MAXLEAFTRIES)) then (* ;  "Enough, already, better let us get out") (\LEAF.TIMEDOUT.EXCESSIVE SEQUIN CNT]) (\LEAF.NOT.RESPONDING [LAMBDA (SEQUIN REASON OUTSTREAM) (* ; "Edited 24-May-91 14:54 by jds") (* ;; "Alearts user that connection not responding. REASON is from some unacked packet in the queue, or :OPEN if trying to open the connection.") (printout OUTSTREAM T "[" (fetch (SEQUIN SEQNAME) of SEQUIN) " not responding") (SELECTQ REASON (T (* ;  "T means those silly nonsense name directory requests")) (:OPEN (printout OUTSTREAM " to Leaf connection attempt")) (printout OUTSTREAM " for " (.NAMEORSTREAM. REASON))) (printout OUTSTREAM "]"]) (\LEAF.TIMEDOUT.EXCESSIVE [LAMBDA (SEQUIN CNT) (* ;  "Edited 2-Nov-92 03:37 by sybalsky:mv:envos") (AND (WINDOWWORLDP) (PROG ([W (CREATEW (MAKEWITHINREGION LEAFABORTREGION) (CONCAT "Leaf Abort window for " (fetch (SEQUIN SEQNAME) of SEQUIN] (PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQDONEQ) of SEQUIN))) (FIRSTTIME T) READFILES WRITEFILES X DATA PAGE FULLNAME) (replace (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN with W) (printout W (fetch (SEQUIN SEQNAME) of SEQUIN) " is not responding." T) (PROG NIL LP [COND [(NULL PUP) (COND (FIRSTTIME (SETQ FIRSTTIME NIL) (SETQ PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQRETRANSMITQ ) of SEQUIN))) (GO LP)) (T (for ENTRY in WRITEFILES do (printout W T "Writing page") (COND ((CDDR ENTRY) (PRIN1 "s" W))) (MAPRINT (CDR ENTRY) W " " NIL ", ") (printout W " of " (CAR ENTRY))) (RETURN] ([AND (SETQ X (fetch EPUSERFIELD of PUP)) (OR (NOT (type? STREAM X)) (SETQ FULLNAME (fetch (STREAM FULLFILENAME) of X] (COND ((AND (type? STREAM X) (SELECTC (fetch (LEAFDATA LEAFOPCODE) of (fetch PUPCONTENTS of PUP)) (\LEAFOP.WRITE (SETQ PAGE (IPLUS (FOLDLO (fetch (LEAFDATA LOADDR) of (SETQ DATA (fetch PUPCONTENTS of PUP))) BYTESPERPAGE) (LLSH (SIGNED (fetch (LEAFDATA JUSTHIADDR) of DATA) BITSPERWORD) 7))) T) ((LIST \LEAFOP.CLOSE \LEAFOP.TRUNCATE) (AND (DIRTYABLE X) (SETQ PAGE 'EOF))) NIL)) (for ENTRY in WRITEFILES do [COND ((EQ (CAR ENTRY) FULLNAME) (RETURN (RPLACD ENTRY (CONS PAGE (CDR ENTRY] finally (push WRITEFILES (LIST FULLNAME PAGE))) (pushnew READFILES FULLNAME)) ((AND FULLNAME (NOT (FMEMB FULLNAME READFILES))) (printout W T "Reading " FULLNAME) (push READFILES FULLNAME] (SETQ PUP (fetch EPLINK of PUP)) (GO LP)) (printout W T T "... will keep trying." T "If you do not wish to wait for the server to resume operation, you can abort the connection by clicking ABORT below" T) (ADDMENU (create MENU ITEMS _ '(ABORT) WHENSELECTEDFN _ (FUNCTION \LEAF.ABORT.FROMMENU)) W (create POSITION XCOORD _ (IQUOTIENT (IDIFFERENCE (WINDOWPROP W 'WIDTH) (STRINGWIDTH 'ABORT MENUFONT)) 2) YCOORD _ 12Q)) (WINDOWPROP W 'SEQUIN SEQUIN) (WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (WINDOWPROP WINDOW 'SEQUIN NIL]) (\LEAF.ABORT.FROMMENU [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 24-May-91 14:54 by jds") (PROG ((WINDOW (WFROMMENU MENU)) SEQUIN) (COND ([AND WINDOW (SETQ SEQUIN (WINDOWPROP WINDOW 'SEQUIN] (SHADEITEM 'ABORT MENU GRAYSHADE) (replace (SEQUIN LEAFABORTSTATUS) of SEQUIN with 'ABORT) (NOTIFY.EVENT (fetch (SEQUIN SEQEVENT) of SEQUIN]) (\LEAF.STREAM.IN.QUEUE [LAMBDA (SEQUIN IMPORTANT) (* ;  "Edited 2-Nov-92 03:37 by sybalsky:mv:envos") (* ;; "Examines queue of SEQUIN requests that have not yet been answered, and returns one that has a stream associated with it. If IMPORTANT is true, only returns one with 'important' operations pending: write request, or close request for a file that is open for write") (PROG ((PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQDONEQ) of SEQUIN))) (FIRSTTIME T) DEFAULT X) LP (COND [(NULL PUP) (COND (FIRSTTIME (SETQ FIRSTTIME NIL) (SETQ PUP (fetch SYSQUEUEHEAD of (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN))) (GO LP)) (T (RETURN DEFAULT] ((AND (SETQ X (fetch EPUSERFIELD of PUP)) (OR (NOT (type? STREAM X)) (fetch (STREAM FULLFILENAME) of X)) (if (NOT IMPORTANT) then (if (EQ X T) then (* ;  "Directorynamep silliness, only use it if it's the only choice") (SETQ DEFAULT T) NIL else T) elseif (type? STREAM X) then (SELECTC (fetch (LEAFDATA LEAFOPCODE) of (fetch PUPCONTENTS of PUP)) ((LIST \LEAFOP.WRITE \LEAFOP.TRUNCATE) (* ; "Always important") T) (\LEAFOP.CLOSE (* ; "Closing an output file?") (DIRTYABLE X)) NIL))) (RETURN X))) (SETQ PUP (fetch EPLINK of PUP)) (GO LP]) (\LEAF.IDLE [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 15:08 by jds") (* ;; "Called after a suitable timeout with no activity on connection") (COND [(fetch (SEQUIN LEAFCACHEDFILE) of SEQUIN) (ADD.PROCESS (LIST (FUNCTION \LEAF.MAYBE.FLUSH.CACHE) (KWOTE SEQUIN] ((for STREAM in (fetch (FDEV OPENFILELST) of (\GETDEVICEFROMNAME (fetch (SEQUIN SEQNAME) of SEQUIN))) thereis (EQ (fetch (LEAFSTREAM LEAFCONNECTION) of STREAM) SEQUIN)) (* ;  "Keep activity on this connection") (\SEQUIN.CONTROL SEQUIN \SEQUIN.NOOP)) (T (replace (SEQUIN LEAFCLOSING) of SEQUIN with T) (\SEQUIN.CLOSE SEQUIN]) (\LEAF.MAYBE.FLUSH.CACHE [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:54 by jds") (* ;; "Called when leaf connection has been idle a while and there is a file in the cache. Only flush it if we can get the lock; else try again later. This keeps this process from hanging (and identical ones accumulating) in the case where the connection is wedged.") (if (OBTAIN.MONITORLOCK (fetch (SEQUIN LEAFOPENCLOSELOCK) of SEQUIN) T T) then (\LEAF.FLUSH.CACHE SEQUIN]) (\LEAF.WHENCLOSED [LAMBDA (SEQUIN FINALSTATE REASON) (* ; "Edited 24-May-91 15:12 by jds") (PROG ((CODE (COND ((EQ REASON \SS.NOSOCKET) \LEAF.NEVER.OPENED) (T \LEAF.BROKEN.STATUS))) PUP DEV) (replace (SEQUIN LEAFCACHEDFILE) of SEQUIN with NIL) (* ;  "Break this potential circular link") (COND ((fetch (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN) (CLOSEW (fetch (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN)) (replace (SEQUIN LEAFABORTBUTTONWINDOW) of SEQUIN with NIL))) (while (SETQ PUP (\DEQUEUE (fetch (SEQUIN SEQDONEQ) of SEQUIN))) do (replace (LEAFPACKET LEAFSTATUS) of PUP with CODE)) (while (SETQ PUP (\DEQUEUE (fetch (SEQUIN SEQRETRANSMITQ) of SEQUIN))) do (replace (LEAFPACKET LEAFSTATUS) of PUP with CODE)) (replace (SEQUIN SEQINPUTQLENGTH) of SEQUIN with 0) (AND (SETQ DEV (\GETDEVICEFROMNAME (fetch (SEQUIN SEQNAME) of SEQUIN) T T)) (EQ (fetch (PUPFILESERVER PFSLEAFSEQUIN) of (SETQ DEV (fetch DEVICEINFO of DEV))) SEQUIN) (replace (PUPFILESERVER PFSLEAFSEQUIN) of DEV with NIL]) (\LEAF.IDLE? [LAMBDA (SEQUIN) (* ; "Edited 24-May-91 14:54 by jds") (* ;; "Tells SEQUIN process how long to block when it otherwise has nothing to do, i.e. no packets remain unacked") (COND ((NEQ (fetch (SEQUIN SEQINPUTQLENGTH) of SEQUIN) 0) (* ; "Still waiting for something") NIL) ((fetch (SEQUIN LEAFCACHEDFILE) of SEQUIN) \LEAF.CACHETIMEOUT) (T (* ; "For now, wait forever") \LEAF.IDLETIMEOUT]) ) (ADDTOVAR NETWORKOSTYPES ) (* ;; "Miscellaneous and error handling") (DEFINEQ (\ADDLEAFSTRING [LAMBDA (PUP STRING DECODE) (* ; "Edited 24-May-91 14:58 by jds") (PROG ((PUPBASE (fetch PUPCONTENTS of PUP)) LEAFLEN STRLEN STRBASE STROFF PUPSTRBASE NEWLENGTH) (SETQ LEAFLEN (CEIL (fetch (LEAFDATA LEAFLENGTH) of PUPBASE) BYTESPERWORD)) (* ;  "Round Length up to next word--strings must be word-aligned") [COND ((NULL STRING) (SETQ STRLEN 0)) ((LITATOM STRING) (SETQ STRBASE (fetch (LITATOM PNAMEBASE) of STRING)) (SETQ STROFF 1) (SETQ STRLEN (fetch (LITATOM PNAMELENGTH) of STRING))) (T (OR (STRINGP STRING) (SETQ STRING (MKSTRING STRING))) (SETQ STRBASE (fetch (STRINGP BASE) of STRING)) (SETQ STROFF (fetch (STRINGP OFFST) of STRING)) (SETQ STRLEN (fetch (STRINGP LENGTH) of STRING] (COND ((IGREATERP (SETQ NEWLENGTH (IPLUS LEAFLEN STRLEN BYTESPERWORD)) \MAX.PUPLENGTH) (ERROR "PUP OVERFLOW" PUP))) (\PUTBASE (SETQ PUPSTRBASE (\ADDBASE PUPBASE (FOLDLO LEAFLEN BYTESPERWORD))) 0 STRLEN) (SETQ PUPSTRBASE (\ADDBASE PUPSTRBASE 1)) (COND ((EQ STRLEN 0)) [DECODE (for I from 0 to (SUB1 STRLEN) do (\PUTBASEBYTE PUPSTRBASE I (\DECRYPT.PWD.CHAR (\GETBASEBYTE STRBASE (IPLUS I STROFF] (T (\MOVEBYTES STRBASE STROFF PUPSTRBASE 0 STRLEN))) (replace (LEAFDATA LEAFLENGTH) of PUPBASE with NEWLENGTH]) (\FIXPASSWORD [LAMBDA (ERRCODE CONNECTION DIRECTORY) (* ; "Edited 24-May-91 14:54 by jds") (* ;; "Called when a username or password error occurs. ERRCODE is the IFS errorcode (name or password error). Attempts to get new name and/or password for use on CONNECTION. If DIRECTORY is specified, it is a connect error to that directory") (\INTERNAL/GETPASSWORD (fetch (SEQUIN SEQNAME) of CONNECTION) (NEQ ERRCODE \IFSERROR.PROTECTION) DIRECTORY (SELECTC ERRCODE (\IFSERROR.PASSWORD "Incorrect password") ((LIST \IFSERROR.USERNAME \IFSERROR.NEED.USERNAME) "Invalid username") (\IFSERROR.CONNECTPASSWORD "Incorrect connect password") (\IFSERROR.CONNECTNAME "Invalid connect name") (\IFSERROR.PROTECTION "Protection violation") (\IFSERROR.NO.LOGIN "Can't login as files-only directory") "Unknown error"]) (\GETLEAFSTRING [LAMBDA (ADDR) (* bvm%: "30-MAR-83 17:39") (* ;; "Retrieves the IFS string starting at ADDR. IFS string has length in its first word") (PROG ((LEN (\GETBASE ADDR 0))) (RETURN (AND (IGREATERP LEN 0) (\GETBASESTRING ADDR 2 LEN]) (\IFSERRORSTRING [LAMBDA (CODE FILENAME CONNECTION) (* ; "Edited 24-May-91 14:54 by jds") (* ;; "Returns the error string associated with IFS error CODE. FILENAME is the name of the file that caused the error (used for recursion break); CONNECTION is the leaf connection on which the error occurred") (COND ((NOT (AND FILENAME (STRING.EQUAL FILENAME \IFSERRORFILENAME))) (LET* ([ERR-MSG-STREAM (CAR (NLSETQ (OPENSTREAM (SETQ \IFSERRORFILENAME (PACK* '{ (COND (CONNECTION (fetch (SEQUIN SEQNAME) of CONNECTION )) (T \CONNECTED.HOST)) "}IFS.ERRORS")) 'INPUT] (ERR-FILE-NAME (FULLNAME ERR-MSG-STREAM)) (EOL (FCHARACTER (CHARCODE EOL))) (START NIL) (LEN NIL) (RESULT NIL)) (* ;; "This is a text file containing entries that look like '$$ ' . Entries can extend over one line. Entries are sorted by error code, but I don't make use of that knowledge in the brute force procedure below") (COND (ERR-MSG-STREAM (SETQ \IFSERRORFILENAME ERR-FILE-NAME) (* ;  "In case an error happens while scanning file, update this var to correct value") (PROG1 (COND ((SETQ START (FFILEPOS (CONCAT EOL "$$" CODE " ") ERR-MSG-STREAM 0 NIL NIL T)) (SETQ LEN (IDIFFERENCE (OR (FFILEPOS (CONCAT EOL "$$") ERR-MSG-STREAM START) (GETEOFPTR ERR-MSG-STREAM)) START)) (* ; "Length of entry") (SETQ RESULT (ALLOCSTRING LEN)) (SETFILEPTR ERR-MSG-STREAM START) (for I from 1 to LEN do (RPLCHARCODE RESULT I (\BIN ERR-MSG-STREAM ))) RESULT)) (CLOSEF ERR-MSG-STREAM]) (\LEAF.ERROR [LAMBDA (PUP FILENAME CONNECTION SENTPUP) (* ;  "Edited 2-Nov-92 03:37 by sybalsky:mv:envos") (PROG ((DATA (fetch PUPCONTENTS of PUP)) ERRCODE MSG) (RETURN (SELECTC (SETQ ERRCODE (fetch (LEAFERRORDATA LEAFERRORCODE) of DATA)) (\IFSERROR.FILE.NOT.FOUND (LISPERROR "FILE NOT FOUND" FILENAME)) (\IFSERROR.MALFORMED (LISPERROR "BAD FILE NAME" FILENAME)) (\IFSERROR.ALLOCATION (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" FILENAME)) (\IFSERROR.BAD.HANDLE (ERROR "Leaf Error: Bad Handle. This shouldn't happen: Lisp and the server have different ideas about which file they are talking about. All operations to this file are now suspended. See a wizard if possible." (fetch (STREAM FULLFILENAME) of FILENAME))) (PROGN [SETQ MSG (SELECTC ERRCODE (\IFSERROR.BUSY "File busy") (\IFS.ERROR.BROKEN.LEAF "Leaf Broken--a file you had open was accessed by another user while it was idle.") (CONCAT "Leaf error: " (OR [AND (IGREATERP (fetch PUPLENGTH of PUP) \SHORT.ERROR.PUPLEN) (\GETLEAFSTRING (LOCF (fetch (LEAFERRORDATA LEAFERRORMSG) of DATA] (\IFSERRORSTRING ERRCODE FILENAME CONNECTION) ERRCODE] (COND ((EQ (fetch (LEAFERRORDATA LEAFERROROPCODE) of DATA) \LEAFOP.OPEN) (printout PROMPTWINDOW T MSG T) (LISPERROR "FILE WON'T OPEN" FILENAME)) (T (ERROR MSG FILENAME]) (\LEAF.DIRECTORYNAMEONLY [LAMBDA (FILENAME) (* bvm%: "19-NOV-81 11:34") (PROG ((DIR (FILENAMEFIELD FILENAME 'DIRECTORY)) N) (RETURN (COND ((SETQ N (STRPOS '> DIR)) (SUBATOM DIR 1 (SUB1 N))) (T DIR]) (GETHOSTINFO [LAMBDA (HOST ATTRIBUTE) (* ; "Edited 10-Oct-90 17:39 by gadener") (SETQ HOST (MKATOM (U-CASE HOST))) (PROG (NSFLG (INFO (ASSOC HOST NETWORKOSTYPES)) VAL) (COND (INFO (* ; " already know about this host") ) [(SETQ NSFLG (STRPOS '%: HOST)) (* ; " default NS information") (SETQ INFO '(NIL . NS] [(AND (BOUNDP \IPFLG) \IPFLG) (* ; "Check for IP info") (SETQ HOST (\DOMAIN.NAME.QUALIFY.FULLY HOST)) (SETQ INFO (CONS NIL (fetch (HOSTS.TXT.ENTRY HTE.OS.TYPE) of (GETHASH HOST \IP.HOSTNAMES ] [(AND (NEQ HOST (SETQ HOST (CANONICAL.HOSTNAME HOST))) (* ; "Check for NS and PUP info") (SETQ INFO (ASSOC HOST NETWORKOSTYPES] (DEFAULT.OSTYPE (SETQ INFO (CONS NIL DEFAULT.OSTYPE))) (T (RETURN))) (RETURN (OR (SELECTQ ATTRIBUTE ((OS OSTYPE) (* ; " get OS type") (COND ((LISTP (CDR INFO)) (LISTGET (CDR INFO) 'OSTYPE)) (T (CDR INFO)))) (LOGINFO [COND ((SETQ VAL (ASSOC HOST NETWORKLOGINFO)) (CDR VAL)) (T (CDR (ASSOC (COND ((LISTP (CDR INFO)) (LISTGET (CDR INFO) 'OSTYPE)) (T (CDR INFO))) NETWORKLOGINFO]) (PROTOCOLS (COND ((LITATOM (CDR INFO)) (SELECTQ (CDR INFO) (IFS '(LEAF PUPFTP CHAT LOOKUPFILE)) NIL)))) NIL) (AND (LISTP (CDR INFO)) (LISTGET (CDR INFO) ATTRIBUTE]) (GETOSTYPE [LAMBDA (HOST) (* bvm%: "31-OCT-83 17:08") (GETHOSTINFO HOST 'OSTYPE]) (EXPANDING-PAGEFULLFN [LAMBDA (W) (* ; "Edited 14-Apr-87 22:25 by bvm:") (* ;; "Hack for getting a window large enough to hold everything you want to display without having to make it big enough in the first place. This function is intended to be the PAGEFULLFN on the window that is your process's ttydisplaystream. As soon as the window fills up, it grows the window on the bottom to show more. The number of lines it expands by is given by the window's EXPANDING-INCREMENT property, defaults to 4.") (LET ((OLDREGION (WINDOWREGION W)) [INCREMENT (TIMES (OR (WINDOWPROP W 'EXPANDING-INCREMENT) 4) (- (DSPLINEFEED NIL W] (CURRENTHEIGHT \#DISPLAYLINES)) [SHAPEW W (create REGION using OLDREGION HEIGHT _ (+ INCREMENT (fetch (REGION HEIGHT) of OLDREGION)) BOTTOM _ (IMAX 0 (- (fetch (REGION BOTTOM) of OLDREGION) INCREMENT] (* ;; "The SHAPEW resets height parameters as if window cleared. We want display to believe that the pagefullfn never happened, so that we can expand again the next time we hit bottom.") (SETQ \CURRENTDISPLAYLINE CURRENTHEIGHT]) ) (RPAQQ DEFAULT.OSTYPE IFS) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULT.OSTYPE) ) (* ;; "LookUpFile stuff") (DEFINEQ (\IFS.LOOKUPFILE [LAMBDA (NAME RECOG ATTRIBUTE DEVINFO) (* ; "Edited 24-May-91 15:12 by jds") (* ;;; "Attempt to use the LookupFile protocol to get full filename") (PROG ((RESULT '?) (HOSTNAME (fetch (PUPFILESERVER PFSNAME) of DEVINFO)) (OSTYPE (fetch (PUPFILESERVER PFSOSTYPE) of DEVINFO)) REMOTENAME SEMI NAME/PASS START DOT ROOTNAME INFO IPUP OPUP PUPSOC DIREND LOCK) (COND ([OR (NEQ (NTHCHARCODE NAME 1) (CHARCODE {)) (NOT (SETQ START (STRPOS '} NAME 2] (RETURN))) (COND ((NOT (SETQ LOCK (fetch (PUPFILESERVER PFSLOOKUPFILELOCK) of DEVINFO))) (* ; "First time to do this") (replace (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO with (SETQ PUPSOC ( OPENPUPSOCKET ))) (replace (PUPFILESERVER PFSLOOKUPFILELOCK) of DEVINFO with (SETQ LOCK ( CREATE.MONITORLOCK "LookUpFile")) ) (replace (PUPFILESERVER PFSLOOKUPFAILCNT) of DEVINFO with 0)) ((NOT (SETQ PUPSOC (fetch (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO))) (RETURN RESULT))) [SETQ ROOTNAME (SUBSTRING NAME (ADD1 START) (COND ([SETQ SEMI (OR (STRPOS '; NAME (ADD1 START)) (STRPOS '! NAME (ADD1 START] (PROG1 (SUB1 SEMI) (COND ((EQ SEMI (NCHARS NAME)) (* ; "Not really a version there") (SETQ SEMI NIL))))] (while (SETQ DOT (STRPOS '> ROOTNAME DIREND)) do (SETQ DIREND (ADD1 DOT))) [COND ((NOT DIREND) (SETQ DIREND (IMINUS (NCHARS ROOTNAME))) (SETQ ROOTNAME (CONCAT '< (CAR (\INTERNAL/GETPASSWORD HOSTNAME)) '> ROOTNAME] (COND [(SETQ DOT (STRPOS '%. ROOTNAME DIREND)) (* ;  "Name ends in dot, but is only %"extensionless%" if the dot isn't quoted") (SETQ DOT (AND (EQ DOT (NCHARS ROOTNAME)) (NEQ (NTHCHARCODE ROOTNAME (SUB1 DOT)) (CHARCODE "'"] (T (SETQ ROOTNAME (CONCAT ROOTNAME '%.)) (SETQ DOT T))) (* ;  "DOT now T if filename is extensionless. ROOTNAME is everything but the version") [SETQ REMOTENAME (COND [(EQ (SETQ OSTYPE (GETHOSTINFO HOSTNAME 'OSTYPE)) 'TENEX) (* ;  "Our filenames are already Tenex style") (COND ((OR SEMI (NEQ RECOG 'OLDEST)) ROOTNAME) (T (CONCAT ROOTNAME ";-2"] [SEMI (* ; "Use ! for version delimiter") (CONCAT (COND (DOT (SUBSTRING ROOTNAME 1 -2)) (T ROOTNAME)) (COND ((EQ OSTYPE 'TOPS20) '%.) (T '!)) (SUBSTRING NAME (ADD1 SEMI] ((EQ OSTYPE 'TOPS20) (COND ((EQ RECOG 'OLDEST) (CONCAT ROOTNAME ".-2")) (T ROOTNAME))) (T (SETQ REMOTENAME (COND (DOT (SUBSTRING ROOTNAME 1 -2)) (T ROOTNAME))) (COND ((EQ RECOG 'OLDEST) (CONCAT REMOTENAME "!L")) (T REMOTENAME] (WITH.MONITOR LOCK (SETUPPUP (SETQ OPUP (ALLOCATE.PUP)) HOSTNAME \SOCKET.LOOKUPFILE \PT.LOOKUPFILE NIL PUPSOC) (\PUTPUPSTRING OPUP (if (STRPOS "'" REMOTENAME) then (\LEAF.STRIP.QUOTES REMOTENAME) else REMOTENAME)) [to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS PUPSOC OPUP NIL T)) do (SELECTC (fetch PUPTYPE of IPUP) (\PT.LOOKUPFILEREPLY [RETURN (SETQ RESULT (SELECTQ ATTRIBUTE ((NAME NIL) (SETQ REMOTENAME (CONCAT '{ HOSTNAME '} ROOTNAME '; (fetch (LOOKUPFILEDATA LOOKUPVERSION) of IPUP))) (if *UPPER-CASE-FILE-NAMES* then (MKATOM (U-CASE REMOTENAME )) else REMOTENAME)) (CREATIONDATE (GDATE (ALTO.TO.LISP.DATE (fetch (LOOKUPFILEDATA LOOKUPCREATIONDATE ) of IPUP)) )) (ICREATIONDATE (ALTO.TO.LISP.DATE (fetch (LOOKUPFILEDATA LOOKUPCREATIONDATE ) of IPUP))) (LENGTH (fetch (LOOKUPFILEDATA LOOKUPLENGTH) of IPUP)) (\ILLEGAL.ARG ATTRIBUTE]) (\PT.LOOKUPFILEERROR (* ; "No such file") (RETURN (SETQ RESULT NIL))) (\PT.ERROR (COND ((EQ (fetch ERRORPUPCODE of IPUP) \PUPE.NOSOCKET) (* ; "No such socket") (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE)) (replace (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO with NIL) (CLOSEPUPSOCKET PUPSOC) (RETURN)))) NIL) (RELEASE.PUP IPUP) finally (SETQ IPUP) (COND (PUPTRACEFLG "LookupFile timed out" T)) (COND ((AND (fetch (PUPFILESERVER PFSLOOKUPFAILCNT) of DEVINFO) (> (add (fetch (PUPFILESERVER PFSLOOKUPFAILCNT ) of DEVINFO) 1) 4)) (replace (PUPFILESERVER PFSLOOKUPFILESOCKET) of DEVINFO with NIL) (CLOSEPUPSOCKET PUPSOC] (AND IPUP (RELEASE.PUP IPUP)) (COND ((NEQ RESULT '?) (replace (PUPFILESERVER PFSLOOKUPFAILCNT) of DEVINFO with NIL)))) (RETURN RESULT]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ LOOKUPFILECOMS ((CONSTANTS \PT.LOOKUPFILE \PT.LOOKUPFILEREPLY \PT.LOOKUPFILEERROR \SOCKET.LOOKUPFILE) (RECORDS LOOKUPFILEDATA) (GLOBALVARS \LOOKUPFILE.HOSTINFO))) (DECLARE%: EVAL@COMPILE (RPAQQ \PT.LOOKUPFILE 200Q) (RPAQQ \PT.LOOKUPFILEREPLY 201Q) (RPAQQ \PT.LOOKUPFILEERROR 202Q) (RPAQQ \SOCKET.LOOKUPFILE 61Q) (CONSTANTS \PT.LOOKUPFILE \PT.LOOKUPFILEREPLY \PT.LOOKUPFILEERROR \SOCKET.LOOKUPFILE) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS LOOKUPFILEDATA ((LOOKUPFILEBASE (fetch PUPCONTENTS of DATUM))) (BLOCKRECORD LOOKUPFILEBASE ((LOOKUPVERSION WORD) (LOOKUPCREATIONDATE FIXP) (LOOKUPLENGTH FIXP)))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LOOKUPFILE.HOSTINFO) ) ) (DEFINEQ (\LEAFINIT [LAMBDA NIL (* bvm%: "12-SEP-83 15:39") (SETQ \LEAFCONNECTIONLOCK (CREATE.MONITORLOCK 'LEAF)) (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ 'LEAF RESETABLE _ T RANDOMACCESSP _ T PAGEMAPPED _ T HOSTNAMEP _ (FUNCTION \LEAF.DEVICEP) EVENTFN _ (FUNCTION NILL) DELETEFILE _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILEINFO _ (FUNCTION \ILLEGAL.DEVICEOP) OPENFILE _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ (FUNCTION \ILLEGAL.DEVICEOP) GENERATEFILES _ (FUNCTION \ILLEGAL.DEVICEOP) DIRECTORYNAMEP _ (FUNCTION \ILLEGAL.DEVICEOP) RENAMEFILE _ (FUNCTION \ILLEGAL.DEVICEOP]) ) (DECLARE%: DONTEVAL@LOAD (\LEAFINIT) ) (DEFINEQ (PRINTLEAF [LAMBDA (PUP) (* ; "Edited 24-May-91 14:59 by jds") (* ;;; "Prints a LEAF pup. Called from PRINTPUP") (PROG ((LENGTH (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN)) DATA OP START HI LO MACRO NBYTES) (COND ((EQ (fetch (SEQUINPACKET SEQCONTROL) of PUP) \SEQUIN.DATA) (printout NIL "SequinData")) (T (printout NIL "SequinOp = ") (PRINTCONSTANT (fetch (SEQUINPACKET SEQCONTROL) of PUP) SEQUINOPS NIL "\SEQUIN."))) (printout NIL ", alloc = " .P2 (fetch (SEQUINPACKET ALLOCATE) of PUP) ", recv = " .P2 (fetch (SEQUINPACKET RECEIVESEQ) of PUP) ", send = " .P2 (fetch (SEQUINPACKET SENDSEQ) of PUP) T) [COND ((IGREATERP LENGTH 0) (SETQ DATA (fetch PUPCONTENTS of PUP)) (printout NIL "Leaf") (COND ((SETQ OP (SELECTC (fetch (LEAFDATA LEAFOPCODE) of DATA) (\LEAFOP.OPEN "Open") (\LEAFOP.CLOSE "Close") (\LEAFOP.READ "Read") (\LEAFOP.WRITE "Write") (\LEAFOP.ERROR "Error") NIL)) (printout NIL OP)) (T (printout NIL "Op = ") (PRINTCONSTANT (fetch (LEAFDATA LEAFOPCODE) of DATA) LEAFOPCODES NIL "\LEAFOP."))) (COND ((EQ (fetch (LEAFDATA ANSWERBIT) of DATA) 1) (printout NIL " (ans)"))) (COND ((AND (EQ (fetch (LEAFDATA OPCODE) of DATA) \LEAFOP.WRITE) (EQ (fetch (LEAFDATA EOFBIT) of DATA) 1)) (printout NIL " (eof)"))) (COND ((NEQ (fetch (LEAFDATA LEAFLENGTH) of DATA) LENGTH) (printout NIL ", length = " .P2 (fetch (LEAFDATA LEAFLENGTH) of DATA) " [but Pup Length = header + " .P2 LENGTH "!]"))) (printout NIL ", Handle = " .P2 (fetch (LEAFDATA HANDLE) of DATA)) (COND ([AND (IGREATERP LENGTH (SETQ START 4)) (SETQ MACRO (SELECTC (fetch (LEAFDATA LEAFOPCODE) of DATA) (\LEAFOP.OPEN [COND ((EQ (fetch (LEAFDATA ANSWERBIT) of DATA) 0) '("Mode: " WORDS 6 " Login: " CHARS IFSSTRING ; BYTES IFSSTRING " Connect: " CHARS IFSSTRING ; BYTES IFSSTRING " File: " CHARS IFSSTRING)) (T '("FileLength = " INTEGER 10Q |...|]) (\LEAFOP.RESET '("Login: " CHARS IFSSTRING BYTES)) ((LIST \LEAFOP.READ \LEAFOP.WRITE) (SETQ HI (SIGNED (fetch (LEAFDATA JUSTHIADDR) of DATA) 13Q)) (SETQ LO (fetch (LEAFDATA LOADDR) of DATA)) (SETQ NBYTES (fetch (LEAFDATA DATALENGTH) of DATA)) [COND [(AND (EVENP NBYTES BYTESPERPAGE) (IGEQ HI 0)) [printout NIL ", Page " .P2 (SETQ LO (IPLUS (FOLDLO LO BYTESPERPAGE) (LLSH HI 7] (COND ((IGREATERP NBYTES BYTESPERPAGE) (printout NIL " thru " .P2 (IPLUS LO (FOLDLO NBYTES BYTESPERPAGE) -1] (T (printout NIL T .P2 NBYTES " bytes from " .P2 (\MAKENUMBER (UNSIGNED HI BITSPERWORD) LO] [COND ((SELECTC (fetch (LEAFDATA LEAFOPCODE) of DATA) (\LEAFOP.WRITE (EQ (fetch (LEAFDATA ANSWERBIT) of DATA) 0)) (IGREATERP LENGTH 12Q)) (SETQ START 12Q) '("Data: " CHARS 24Q |...|]) (\LEAFOP.ERROR '("Error op: " WORDS 6 "Error handle: " 10Q IFSSTRING)) '(BYTES] (TERPRI) (PRINTPACKETDATA DATA START MACRO LENGTH)) (T (TERPRI] (TERPRI)) PUP]) ) (ADDTOVAR PUPPRINTMACROS (260Q . PRINTLEAF)) (RPAQ? LEAFDEBUGFLG ) (RPAQ? LEAFABORTREGION '(641Q 1150Q 617Q 300Q)) (RPAQ? \MAXLEAFTRIES 4) (RPAQ? NOFILEPROPERROR ) (RPAQ? DEFAULTFILETYPE 'TEXT) (RPAQ? \SOCKET.LEAF 43Q) (RPAQ? \SEQUIN.TIMEOUTMAX 23420Q) (RPAQ? \LEAF.IDLETIMEOUT 6673500Q) (RPAQ? \LEAF.CACHETIMEOUT 257620Q) (RPAQ? \LEAF.MAXCACHE 12Q) (RPAQ? \LEAF.RECOVERY.TIMEOUT 2223700Q) (RPAQ? \LEAF.MAXLOOKAHEAD 4) (RPAQ? \FTPAVAILABLE ) (RPAQ? UNIXFTPFLG ) (RPAQ? NONLEAFHOSTS ) (RPAQ? *UPPER-CASE-FILE-NAMES* T) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ LEAFCOMPILETIMECOMS ((RECORDS LEAFDATA LEAFERRORDATA LEAFPARAMSDATA LEAFPACKET LEAFINFOBLOCK LEAFSTREAM LEAFDEVICE PUPFILESERVER) (MACROS .NAMEORSTREAM. .PAGE.IS.AFTER.EOF. INCLEAFSTAT) (CONSTANTS * LEAFOPCODES) (CONSTANTS * IFSERRORS) (CONSTANTS (\PT.LEAF 260Q) (\PT.ERROR 4) (\LEAFOP.ANSWERBIT 2000Q) (\LEAF.READBIT 100000Q) (\LEAF.WRITEBIT 40000Q) (\LEAF.EXTENDBIT 20000Q) (\LEAF.MULTIBIT 10000Q) (\LEAF.CREATEBIT 4000Q) (\LEAF.DEFAULT.LOWEST 200Q) (\LEAF.DEFAULT.HIGHEST 400Q) (\LEAF.DEFAULT.NEXT 600Q) (\LEAF.EXPLICIT.ANY 3000Q) (\LEAF.EXPLICIT.OLD 1000Q) (\LEAF.EXPLICIT.NEXT.OR.OLD 2000Q) (\LEN.RESETLEAF 4) (\LEN.LEAFPARAMS 10Q) (\LEN.NOOPREQUEST 2) (\LEN.OPENREQUEST 6) (\LEN.FILEREQUEST 12Q) (\LEN.CLOSEREQUEST 4) (\LEN.READANSWER 12Q) (\OPCODE.SHIFT 13Q) (\LEN.CLOSEREQUEST 4) (\MAXLEN.FILENAME 144Q) (\OFFSET.FILENAME (TIMES 2 400Q)) (\BYTES.PER.TRIDENT.PAGE 4000Q) (\LEN.DATE 4) (\LEAFMODE.DONTEXTEND 2) (\LEN.FILETYPE&SIZE 4) (\OFFSET.FILETYPE 1250Q) (\OFFSET.BACKUPDATE 1244Q) (\OFFSET.AUTHOR 1174Q) (\LEN.AUTHOR 50Q) (\SHORT.ERROR.PUPLEN 36Q) (\LEAF.GOODSTATUS 177776Q) (\LF.ALLOWERRORS 2) (\LF.WANTANSWER 1) (\LEAF.BROKEN.STATUS 177771Q) (\LEAF.NEVER.OPENED 177773Q)) (CONSTANTS (\FT.TEXT 1) (\FT.BINARY 2) (\FT.UNKNOWN 0)) (LOCALVARS . T) (GLOBALVARS \LEAFDEVICE \SOCKET.LEAF LEAFDEBUGFLG PUPTRACEFLG NOFILEPROPERROR NETWORKOSTYPES LEAFOPCODES SEQUINOPS DEFAULTFILETYPE \LEAF.IDLETIMEOUT \LEAF.CACHETIMEOUT \LEAF.MAXLOOKAHEAD \OPENFILES \LEAF.MAXCACHE \LEAFCONNECTIONLOCK \FTPAVAILABLE UNIXFTPFLG \SEQUIN.TIMEOUTMAX LEAFABORTREGION \MAXLEAFTRIES \LEAF.RECOVERY.TIMEOUT NONLEAFHOSTS \FTPFDEV))) (DECLARE%: EVAL@COMPILE (BLOCKRECORD LEAFDATA ((OPWORD WORD) (HANDLE WORD) (FILEADDRESS FIXP) (DATALENGTH WORD) (LEAFFIRSTDATAWORD WORD)) (* ;  "Format of typical file operation request.") (BLOCKRECORD LEAFDATA ((LEAFOPCODE BITS 5) (ANSWERBIT BITS 1) (LEAFLENGTH BITS 12Q) (NIL WORD) (READWRITEMODE BITS 2) (EOFBIT BITS 1) (NIL BITS 2) (JUSTHIADDR BITS 13Q) (LOADDR WORD)) (* ;  "Details of the file address format") (SYNONYM LEAFOPCODE (OPCODE))) (BLOCKRECORD LEAFDATA ((NIL 2 WORD) (SIGNEXTEND BITS 5) (NIL BITS 33Q)) (* ; "more details") ) (BLOCKRECORD LEAFDATA ((NIL 2 WORD) (OPENMODE WORD)) (* ; "format of OPEN file request") ) (BLOCKRECORD LEAFDATA ((NIL 5 WORD) (LEAFFILETYPE WORD) (LEAFBYTESIZE WORD)) (* ; "For accessing the file's TYPE") ) (BLOCKRECORD LEAFDATA ((NIL 5 WORD) (LEAFFILEDATE FIXP)) (* ;  "Format of SETFILEINFO of CREATIONDATE request") )) (BLOCKRECORD LEAFERRORDATA ((NIL WORD) (LEAFERRORCODE WORD) (* ; "Error subcode in ERROR leafop") (LEAFERROROPCODE BITS 5) (* ;  "The OPCODE in the Leaf packet provoking the error") (NIL BITS 13Q) (LEAFERRORHANDLE WORD) (* ; "The handle in the provoking op") (LEAFERRORMSG WORD) (* ;  "Actually IFSSTRING starting here") )) (BLOCKRECORD LEAFPARAMSDATA ((NIL WORD) (LEAFPMAXDATALENGTH WORD) (LEAFPLOCKTIMEOUT WORD) (* ;  "File Lock timeout, in units of 5 seconds") (LEAFPCONNTIMEOUT WORD) (* ;  "Overall connection timeout, same units") )) (ACCESSFNS LEAFPACKET ((LEAFSTATUS (fetch EPUSERFIELD of DATUM) (replace EPUSERFIELD of DATUM with NEWVALUE)) (LEAFFLAGS (fetch EPFLAGS of DATUM) (replace EPFLAGS of DATUM with NEWVALUE)) (LEAFANSWERWANTED (NEQ (LOGAND (fetch EPFLAGS of DATUM) \LF.WANTANSWER) 0)) (LEAFALLOWERRORS (NEQ (LOGAND (fetch EPFLAGS of DATUM) \LF.ALLOWERRORS) 0)))) (BLOCKRECORD LEAFINFOBLOCK ((LFCREATIONDATE FIXP) (LFWRITEDATE FIXP) (LFREADDATE FIXP)) (* ; "just like leader page") (BLOCKRECORD LEAFINFOBLOCK ((HICREATE WORD) (LOCREATE WORD) (HIWRITE WORD) (LOWRITE WORD) (HIREAD WORD) (LOREAD WORD)) (* ; "for VALIDATION use") ) (CREATE (\ALLOCBLOCK 3))) (ACCESSFNS LEAFSTREAM ((LEAFCONNECTION (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (LEAFHANDLE (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (LEAFPAGECACHE (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (LEAFINFO (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE)) (LEAFREALLYOPEN (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (LEAFCACHECNT (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (LEAFERRORCNT (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE)))) (ACCESSFNS LEAFDEVICE ((PUPFILESERVER (fetch DEVICEINFO of DATUM) (replace DEVICEINFO of DATUM with NEWVALUE)))) (DATATYPE PUPFILESERVER ( (* ;; "Info common to various pup protocols used on a file server, independent of whether a connection is now open") (NIL BYTE) (PFSNAME POINTER) (PFSADDRESS POINTER) (* ; "Pup address") (PFSOSTYPE POINTER) (PFSLEAFFLG POINTER) (* ;  "Indicates something about whether LEAF is available") (PFSLEAFSEQUIN POINTER) (* ;  "Pointer to SEQUIN for open leaf connection") (PFSLEAFTIMER POINTER) (* ;  "Timeout for handling dead servers") (PFSLOOKUPFILESOCKET POINTER) (* ;  "The Pup socket for LookupFile requests") (PFSLOOKUPFILELOCK POINTER) (* ; "Lock to secure it") (PFSLOOKUPFAILCNT POINTER) (* ;  "Counter used until we know the service exists") (PFSKNOWNDIRS POINTER) (* ;  "List of directories known to exist on this host (for DIRECTORYNAMEP)") (NIL POINTER))) ) (/DECLAREDATATYPE 'PUPFILESERVER '(BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 10Q POINTER) (PUPFILESERVER 12Q POINTER) (PUPFILESERVER 14Q POINTER) (PUPFILESERVER 16Q POINTER) (PUPFILESERVER 20Q POINTER) (PUPFILESERVER 22Q POINTER) (PUPFILESERVER 24Q POINTER) (PUPFILESERVER 26Q POINTER)) '30Q) (DECLARE%: EVAL@COMPILE [PUTPROPS .NAMEORSTREAM. MACRO (OPENLAMBDA (FILENAME) (COND ((type? STREAM FILENAME) (fetch FULLFILENAME of FILENAME)) (T FILENAME] [PUTPROPS .PAGE.IS.AFTER.EOF. MACRO (OPENLAMBDA (STREAM PAGE#) (AND (IGEQ PAGE# (fetch EPAGE of STREAM)) (OR (NOT (IEQP (fetch EPAGE of STREAM) PAGE#)) (EQ (fetch EOFFSET of STREAM) 0] [PUTPROPS INCLEAFSTAT MACRO ((X) (change X (IPLUS16 DATUM 1] ) (RPAQQ LEAFOPCODES ((\LEAFOP.ERROR 0) (\LEAFOP.OPEN 1) (\LEAFOP.CLOSE 2) (\LEAFOP.DELETE 3) (\LEAFOP.LENGTH 4) (\LEAFOP.TRUNCATE 5) (\LEAFOP.READ 6) (\LEAFOP.WRITE 7) (\LEAFOP.RESET 10Q) (\LEAFOP.NOOP 11Q) (\LEAFOP.TELNET 12Q) (\LEAFOP.PARAMS 13Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \LEAFOP.ERROR 0) (RPAQQ \LEAFOP.OPEN 1) (RPAQQ \LEAFOP.CLOSE 2) (RPAQQ \LEAFOP.DELETE 3) (RPAQQ \LEAFOP.LENGTH 4) (RPAQQ \LEAFOP.TRUNCATE 5) (RPAQQ \LEAFOP.READ 6) (RPAQQ \LEAFOP.WRITE 7) (RPAQQ \LEAFOP.RESET 10Q) (RPAQQ \LEAFOP.NOOP 11Q) (RPAQQ \LEAFOP.TELNET 12Q) (RPAQQ \LEAFOP.PARAMS 13Q) (CONSTANTS (\LEAFOP.ERROR 0) (\LEAFOP.OPEN 1) (\LEAFOP.CLOSE 2) (\LEAFOP.DELETE 3) (\LEAFOP.LENGTH 4) (\LEAFOP.TRUNCATE 5) (\LEAFOP.READ 6) (\LEAFOP.WRITE 7) (\LEAFOP.RESET 10Q) (\LEAFOP.NOOP 11Q) (\LEAFOP.TELNET 12Q) (\LEAFOP.PARAMS 13Q)) ) (RPAQQ IFSERRORS ((\IFSERROR.BAD.CHARACTER 312Q) (\IFSERROR.MALFORMED '(311Q 312Q)) (\IFSERROR.FILE.NOT.FOUND 317Q) (\IFSERROR.PROTECTION 320Q) (\IFSERROR.BUSY 321Q) (\IFSERROR.INVALID.DIRECTORY 322Q) (\IFSERROR.ALLOCATION 323Q) (\IFSERROR.USERNAME 330Q) (\IFSERROR.PASSWORD 331Q) (\IFSERROR.NO.LOGIN 332Q) (\PASSWORD.ERRORS '(330Q 331Q 332Q 337Q)) (\IFSERROR.CONNECTNAME 333Q) (\IFSERROR.CONNECTPASSWORD 334Q) (\CONNECT.PASSWORD.ERRORS '(333Q 334Q)) (\IFSERROR.NEED.USERNAME 337Q) (\IFS.ERROR.BROKEN.LEAF 1751Q) (\IFSERROR.BAD.HANDLE 1763Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \IFSERROR.BAD.CHARACTER 312Q) (RPAQQ \IFSERROR.MALFORMED (311Q 312Q)) (RPAQQ \IFSERROR.FILE.NOT.FOUND 317Q) (RPAQQ \IFSERROR.PROTECTION 320Q) (RPAQQ \IFSERROR.BUSY 321Q) (RPAQQ \IFSERROR.INVALID.DIRECTORY 322Q) (RPAQQ \IFSERROR.ALLOCATION 323Q) (RPAQQ \IFSERROR.USERNAME 330Q) (RPAQQ \IFSERROR.PASSWORD 331Q) (RPAQQ \IFSERROR.NO.LOGIN 332Q) (RPAQQ \PASSWORD.ERRORS (330Q 331Q 332Q 337Q)) (RPAQQ \IFSERROR.CONNECTNAME 333Q) (RPAQQ \IFSERROR.CONNECTPASSWORD 334Q) (RPAQQ \CONNECT.PASSWORD.ERRORS (333Q 334Q)) (RPAQQ \IFSERROR.NEED.USERNAME 337Q) (RPAQQ \IFS.ERROR.BROKEN.LEAF 1751Q) (RPAQQ \IFSERROR.BAD.HANDLE 1763Q) (CONSTANTS (\IFSERROR.BAD.CHARACTER 312Q) (\IFSERROR.MALFORMED '(311Q 312Q)) (\IFSERROR.FILE.NOT.FOUND 317Q) (\IFSERROR.PROTECTION 320Q) (\IFSERROR.BUSY 321Q) (\IFSERROR.INVALID.DIRECTORY 322Q) (\IFSERROR.ALLOCATION 323Q) (\IFSERROR.USERNAME 330Q) (\IFSERROR.PASSWORD 331Q) (\IFSERROR.NO.LOGIN 332Q) (\PASSWORD.ERRORS '(330Q 331Q 332Q 337Q)) (\IFSERROR.CONNECTNAME 333Q) (\IFSERROR.CONNECTPASSWORD 334Q) (\CONNECT.PASSWORD.ERRORS '(333Q 334Q)) (\IFSERROR.NEED.USERNAME 337Q) (\IFS.ERROR.BROKEN.LEAF 1751Q) (\IFSERROR.BAD.HANDLE 1763Q)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PT.LEAF 260Q) (RPAQQ \PT.ERROR 4) (RPAQQ \LEAFOP.ANSWERBIT 2000Q) (RPAQQ \LEAF.READBIT 100000Q) (RPAQQ \LEAF.WRITEBIT 40000Q) (RPAQQ \LEAF.EXTENDBIT 20000Q) (RPAQQ \LEAF.MULTIBIT 10000Q) (RPAQQ \LEAF.CREATEBIT 4000Q) (RPAQQ \LEAF.DEFAULT.LOWEST 200Q) (RPAQQ \LEAF.DEFAULT.HIGHEST 400Q) (RPAQQ \LEAF.DEFAULT.NEXT 600Q) (RPAQQ \LEAF.EXPLICIT.ANY 3000Q) (RPAQQ \LEAF.EXPLICIT.OLD 1000Q) (RPAQQ \LEAF.EXPLICIT.NEXT.OR.OLD 2000Q) (RPAQQ \LEN.RESETLEAF 4) (RPAQQ \LEN.LEAFPARAMS 10Q) (RPAQQ \LEN.NOOPREQUEST 2) (RPAQQ \LEN.OPENREQUEST 6) (RPAQQ \LEN.FILEREQUEST 12Q) (RPAQQ \LEN.CLOSEREQUEST 4) (RPAQQ \LEN.READANSWER 12Q) (RPAQQ \OPCODE.SHIFT 13Q) (RPAQQ \LEN.CLOSEREQUEST 4) (RPAQQ \MAXLEN.FILENAME 144Q) (RPAQ \OFFSET.FILENAME (TIMES 2 400Q)) (RPAQQ \BYTES.PER.TRIDENT.PAGE 4000Q) (RPAQQ \LEN.DATE 4) (RPAQQ \LEAFMODE.DONTEXTEND 2) (RPAQQ \LEN.FILETYPE&SIZE 4) (RPAQQ \OFFSET.FILETYPE 1250Q) (RPAQQ \OFFSET.BACKUPDATE 1244Q) (RPAQQ \OFFSET.AUTHOR 1174Q) (RPAQQ \LEN.AUTHOR 50Q) (RPAQQ \SHORT.ERROR.PUPLEN 36Q) (RPAQQ \LEAF.GOODSTATUS 177776Q) (RPAQQ \LF.ALLOWERRORS 2) (RPAQQ \LF.WANTANSWER 1) (RPAQQ \LEAF.BROKEN.STATUS 177771Q) (RPAQQ \LEAF.NEVER.OPENED 177773Q) (CONSTANTS (\PT.LEAF 260Q) (\PT.ERROR 4) (\LEAFOP.ANSWERBIT 2000Q) (\LEAF.READBIT 100000Q) (\LEAF.WRITEBIT 40000Q) (\LEAF.EXTENDBIT 20000Q) (\LEAF.MULTIBIT 10000Q) (\LEAF.CREATEBIT 4000Q) (\LEAF.DEFAULT.LOWEST 200Q) (\LEAF.DEFAULT.HIGHEST 400Q) (\LEAF.DEFAULT.NEXT 600Q) (\LEAF.EXPLICIT.ANY 3000Q) (\LEAF.EXPLICIT.OLD 1000Q) (\LEAF.EXPLICIT.NEXT.OR.OLD 2000Q) (\LEN.RESETLEAF 4) (\LEN.LEAFPARAMS 10Q) (\LEN.NOOPREQUEST 2) (\LEN.OPENREQUEST 6) (\LEN.FILEREQUEST 12Q) (\LEN.CLOSEREQUEST 4) (\LEN.READANSWER 12Q) (\OPCODE.SHIFT 13Q) (\LEN.CLOSEREQUEST 4) (\MAXLEN.FILENAME 144Q) (\OFFSET.FILENAME (TIMES 2 400Q)) (\BYTES.PER.TRIDENT.PAGE 4000Q) (\LEN.DATE 4) (\LEAFMODE.DONTEXTEND 2) (\LEN.FILETYPE&SIZE 4) (\OFFSET.FILETYPE 1250Q) (\OFFSET.BACKUPDATE 1244Q) (\OFFSET.AUTHOR 1174Q) (\LEN.AUTHOR 50Q) (\SHORT.ERROR.PUPLEN 36Q) (\LEAF.GOODSTATUS 177776Q) (\LF.ALLOWERRORS 2) (\LF.WANTANSWER 1) (\LEAF.BROKEN.STATUS 177771Q) (\LEAF.NEVER.OPENED 177773Q)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \FT.TEXT 1) (RPAQQ \FT.BINARY 2) (RPAQQ \FT.UNKNOWN 0) (CONSTANTS (\FT.TEXT 1) (\FT.BINARY 2) (\FT.UNKNOWN 0)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LEAFDEVICE \SOCKET.LEAF LEAFDEBUGFLG PUPTRACEFLG NOFILEPROPERROR NETWORKOSTYPES LEAFOPCODES SEQUINOPS DEFAULTFILETYPE \LEAF.IDLETIMEOUT \LEAF.CACHETIMEOUT \LEAF.MAXLOOKAHEAD \OPENFILES \LEAF.MAXCACHE \LEAFCONNECTIONLOCK \FTPAVAILABLE UNIXFTPFLG \SEQUIN.TIMEOUTMAX LEAFABORTREGION \MAXLEAFTRIES \LEAF.RECOVERY.TIMEOUT NONLEAFHOSTS \FTPFDEV) ) ) (/DECLAREDATATYPE 'PUPFILESERVER '(BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PUPFILESERVER 0 (BITS . 7)) (PUPFILESERVER 2 POINTER) (PUPFILESERVER 4 POINTER) (PUPFILESERVER 6 POINTER) (PUPFILESERVER 10Q POINTER) (PUPFILESERVER 12Q POINTER) (PUPFILESERVER 14Q POINTER) (PUPFILESERVER 16Q POINTER) (PUPFILESERVER 20Q POINTER) (PUPFILESERVER 22Q POINTER) (PUPFILESERVER 24Q POINTER) (PUPFILESERVER 26Q POINTER)) '30Q) (ADDTOVAR SYSTEMRECLST (DATATYPE PUPFILESERVER ((NIL BYTE) (PFSNAME POINTER) (PFSADDRESS POINTER) (PFSOSTYPE POINTER) (PFSLEAFFLG POINTER) (PFSLEAFSEQUIN POINTER) (PFSLEAFTIMER POINTER) (PFSLOOKUPFILESOCKET POINTER) (PFSLOOKUPFILELOCK POINTER) (PFSLOOKUPFAILCNT POINTER) (PFSKNOWNDIRS POINTER) (NIL POINTER))) ) (PUTPROPS LEAF COPYRIGHT ("Venue & Xerox Corporation" 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3706Q 3707Q 3710Q 3711Q)) (DECLARE%: DONTCOPY (FILEMAP (NIL (55721Q 71017Q (CLOSESEQUIN 55733Q . 56752Q) (INITSEQUIN 56754Q . 62060Q) (GETSEQUIN 62062Q . 63573Q) (PUTSEQUIN 63575Q . 71015Q)) (71020Q 154423Q (\SEQUIN.CONTROL 71032Q . 72303Q) ( \SEQUIN.PUT 72305Q . 77330Q) (\SEQUIN.PROCESS 77332Q . 114606Q) (\SEQUIN.CLOSE 114610Q . 115475Q) ( \SEQUIN.FLUSH.CONNECTION 115477Q . 117510Q) (\SEQUIN.CLEANUP 117512Q . 120643Q) ( \SEQUIN.FLUSH.RETRANSMIT 120645Q . 122102Q) (\SEQUIN.COMPARE 122104Q . 123243Q) (\SEQUIN.HANDLE.INPUT 123245Q . 141222Q) (\SEQUIN.OUT.OF.THE.BLUE 141224Q . 142047Q) (\SEQUIN.HANDLE.ACK 142051Q . 146303Q) (\SEQUIN.RETRANSMIT 146305Q . 151653Q) (\SEQUIN.RETRANSMITNEXT 151655Q . 154421Q)) (154474Q 420376Q ( \LEAF.CLOSEFILE 154506Q . 167557Q) (\LEAF.DELETEFILE 167561Q . 173344Q) (\LEAF.DEVICEP 173346Q . 210335Q) (\LEAF.RECONNECT 210337Q . 212254Q) (\LEAF.DIRECTORYNAMEP 212256Q . 215567Q) ( \LEAF.GENERATEFILES 215571Q . 216203Q) (\LEAF.GETFILE 216205Q . 252644Q) (\PARSE.REMOTE.FILENAME 252646Q . 262052Q) (\LEAF.STRIP.QUOTES 262054Q . 263545Q) (\LEAF.GETFILEDATES 263547Q . 265742Q) ( \LEAF.GETFILEINFO 265744Q . 271321Q) (\LEAF.GETFILEINFO.OPEN 271323Q . 300142Q) (\LEAF.GETFILENAME 300144Q . 302361Q) (\LEAF.OPENFILE 302363Q . 316434Q) (\LEAF.READFILENAME 316436Q . 322347Q) ( \LEAF.ADD.QUOTES 322351Q . 324773Q) (\LEAF.READFILEPROP 324775Q . 330044Q) (\LEAF.READPAGES 330046Q . 337203Q) (\LEAF.REQUESTPAGE 337205Q . 346115Q) (\LEAF.LOOKUPCACHE 346117Q . 353053Q) (CLEAR.LEAF.CACHE 353055Q . 355025Q) (LEAF.ASSURE.FINISHED 355027Q . 362160Q) (\LEAF.FORCEOUTPUT 362162Q . 362454Q) ( \LEAF.FLUSH.CACHE 362456Q . 363662Q) (\LEAF.RENAMEFILE 363664Q . 364636Q) (\LEAF.REOPENFILE 364640Q . 372213Q) (\LEAF.CREATIONDATE 372215Q . 373052Q) (\LEAF.SETCREATIONDATE 373054Q . 376567Q) ( \LEAF.SETFILEINFO 376571Q . 400453Q) (\LEAF.SETFILETYPE 400455Q . 405237Q) (\LEAF.SETVALIDATION 405241Q . 407576Q) (\LEAF.TRUNCATEFILE 407600Q . 412773Q) (\LEAF.WRITEPAGES 412775Q . 420374Q)) ( 420461Q 426570Q (\SENDLEAF 420473Q . 426566Q)) (426644Q 457325Q (\OPENLEAFCONNECTION 426656Q . 450764Q ) (\LEAF.BREAKCONNECTION 450766Q . 452572Q) (\CLOSELEAFCONNECTION 452574Q . 453434Q) (\LEAF.EVENTFN 453436Q . 457323Q)) (457414Q 462177Q (BREAKCONNECTION 457426Q . 462175Q)) (462303Q 574667Q ( \LEAF.ACKED 462315Q . 463024Q) (\LEAF.FIX.BROKEN.SEQUIN 463026Q . 502766Q) (\LEAF.REPAIR.BROKEN.PUP 502770Q . 507062Q) (\LEAF.USE.NEW.CONNECTION 507064Q . 522707Q) (\LEAF.RESENDPUPS 522711Q . 523321Q) ( \LEAF.HANDLE.INPUT 523323Q . 532633Q) (\LEAF.OPENERRORHANDLER 532635Q . 534260Q) (\LEAF.TIMEDIN 534262Q . 535245Q) (\LEAF.TIMEDOUT 535247Q . 543562Q) (\LEAF.NOT.RESPONDING 543564Q . 545134Q) ( \LEAF.TIMEDOUT.EXCESSIVE 545136Q . 557603Q) (\LEAF.ABORT.FROMMENU 557605Q . 560534Q) ( \LEAF.STREAM.IN.QUEUE 560536Q . 565131Q) (\LEAF.IDLE 565133Q . 567173Q) (\LEAF.MAYBE.FLUSH.CACHE 567175Q . 570266Q) (\LEAF.WHENCLOSED 570270Q . 573456Q) (\LEAF.IDLE? 573460Q . 574665Q)) (575012Q 630625Q (\ADDLEAFSTRING 575024Q . 600672Q) (\FIXPASSWORD 600674Q . 603031Q) (\GETLEAFSTRING 603033Q . 603563Q) (\IFSERRORSTRING 603565Q . 611752Q) (\LEAF.ERROR 611754Q . 617253Q) (\LEAF.DIRECTORYNAMEONLY 617255Q . 617776Q) (GETHOSTINFO 620000Q . 625276Q) (GETOSTYPE 625300Q . 625517Q) (EXPANDING-PAGEFULLFN 625521Q . 630623Q)) (631032Q 655617Q (\IFS.LOOKUPFILE 631044Q . 655615Q)) (657560Q 661707Q (\LEAFINIT 657572Q . 661705Q)) (661765Q 675022Q (PRINTLEAF 661777Q . 675020Q))))) STOP \ No newline at end of file diff --git a/sources/LISP-PACKAGE b/sources/LISP-PACKAGE new file mode 100644 index 00000000..5d4cecb6 --- /dev/null +++ b/sources/LISP-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "LISP") (IL:FILECREATED "16-May-90 18:44:49" IL:{DSK}local>lde>lispcore>sources>LISP-PACKAGE.;2 1900 IL:changes IL:to%: (IL:VARS IL:LISP-PACKAGECOMS) IL:previous IL:date%: "20-Mar-87 12:50:03" IL:{DSK}local>lde>lispcore>sources>LISP-PACKAGE.;1 ) (IL:* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:LISP-PACKAGECOMS) (IL:RPAQQ IL:LISP-PACKAGECOMS ( (IL:* IL:;;; "This file should eventually contain the entire external description of the LISP package, which is currently in package-startup. It exports a few fixup and non-critical symbols right now.") (IL:P (XCL:DEFPACKAGE "LISP" (:USE) (:PREFIX-NAME "CL") (:NICKNAMES "CL" "COMMON-LISP") (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE SPEED SPACE SAFETY COMPILATION-SPEED))) (IL:* IL:;; "Arrange for the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:LISP-PACKAGE))) (IL:* IL:;;; "This file should eventually contain the entire external description of the LISP package, which is currently in package-startup. It exports a few fixup and non-critical symbols right now." ) (XCL:DEFPACKAGE "LISP" (:USE) (:PREFIX-NAME "CL") (:NICKNAMES "CL" "COMMON-LISP") (:EXPORT SIGNED-BYTE UNSIGNED-BYTE LAMBDA VARIABLE STRUCTURE SPEED SPACE SAFETY COMPILATION-SPEED)) (IL:* IL:;; "Arrange for the proper makefile environment") (IL:PUTPROPS IL:LISP-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "LISP")) (IL:PUTPROPS IL:LISP-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/LISPBCPLFILES.DM b/sources/LISPBCPLFILES.DM new file mode 100644 index 0000000000000000000000000000000000000000..b4a5edfb94fd5dd60dd85e2faa9be5055c129600 GIT binary patch literal 192713 zcmb@v3y`E)R^Qj4z;=06IItcDY~!!1duOwztE(%ksvlE5-P84)uIYMBRrPC|o+T?Q zt1Gv&GIKJss=H@cFqQ;T2t`<-6^O@TObA;*hyY=PL6VIvV-^QtNm%ki2yn2$|;s_n*^FMjtI z|Jdf4Gar1}nIC>|=~A-2U+*S+^+qju)~WY;wPv!{X&odhD;u+$v#VQ4tC>trUtFDi zc=6g)GC4Ifd39!Da(KA*yjSZqD~;sQ@Zo%Gw>H0Dt3Dmx>Q$;w*Nvz`{?C1RL#rZpP^Bas~ zYwP~{=ECs8^41*&wY|K(yuLQPu(dI_es^2{Zq9Bm4!=3OeS2|pYkPKkYxvE@?G0L6 z+@8C;w6wT6yt2Htv9!Flymfncb$xU3-sJ-=#|v zMaX|>#Y>mU+3EmDwi%z71#WfwWf#H0&bkDLKxlUK14cA z-Ak9Q0ED^e;bTbmp|vkvx>`ic53Qkb0{@AK!KbQVlT)>FMEEbQ+GKuzoLChg{Pe%; zUB&;>8klarzVCU5C6fLGYj=@yHRZSyrQ1uY`<3RCTCz~9)(&=R zouoW9mXu$+Hk~Bp$(eFF*;q|>UL;4AX0lpqG;00zRx2+kXjRHqW%_C|YgOiImBVCf zzgBM?uhU^j7aaGoVtMBBwPb@0@$RQTq{p~yu&sU;8Q>bXpPdaZ@pUUz(VB)nN+!RFwM#&>JgMtpf^XSYxaApFI@FtXL_ z)G7y7H^%`D4YAfqyVI)Hb`LwXF37M~Z`O8`{aU9sJaoT$J-Oe#o&=8Nda~50boaNa zom#DVJt-0ce&=`$;pxy;t>7VGbC$Ud58YZ2d=}>CcnJ{x$#oU1R+=l!usb~T zIL`_m1H@sswmUpz4Cu2;?|LE{EpG98^6^@ybv>D-qI$@!hrMmEoa{!ydq$Z?w8K{kvc3+^_HU_W9nabZg)lZ{Mu-c-Uz9 zl{{lpjxuX!ptO(eAO4>$(y_29WS+T z^K;3KQM)O$&5Z?DT9;KMj%$+SQu9LTWK|)Z1g%yjVD&4EYudS-l)`f zB@2YQ0O6~b2R6`5k;5Cf+~3FJ;UVGJN-KHR>g@W+doA(43lmATbUP~q z4JSjwG{&;MUrY8{4aAFj^GULgxRHPnt!Lfju$$1#Uabe|>rtwCXymrFmo$W`F4k1? zTMXjF2_{cefzn2fU5>LhjQmj!TuFtNjzn>T%s<6(rm ztwcMs1R9U!Kiin=qr=0M=5BJoTB`0_n`v2o`?o+YOO2yBCOb-hN0mlv4|IBDD5XKE zF+OBeA(no{Hl{GUCtz5)+PevI-PYp#?b*%w^@T;FR?DoY8sU_viC%Qx2>4pxYqomX z6s*)}`mNhalEY@B*6kW?0SI$HVFX6=9c7jD+UShE2=&sP25?g9WDrU&&PT#k3KVB7 zIX^o(mP~l394pAqAf1DQ23Z$@Fn5^1{Or{D;_xY+8zo3a&6^6uv~*=+l-;M*zcP_L z=hQst)~Y~r{7S+@*T&q}$X=zr$~ptr`|MhvNoZ{&6}d6J2d*F(>kQ=jfBzZKo7(52QSt{+roO&X@q;mBnaahPshNE zO}NdPAAWi8`&8?DDby%FDw@^wAwQ`f)kH&$jCFOcXe5@#Pd*gOeTx2%r2j0olVl=QEh)gkgi#?$lW3UC8!+B|V99E6F&02sZQnc5K== zZ{C|7KdS84MSS<_&y&M;vRmEZgyvxzn^m+G%dWi?` z&6_$>$DfIX=%*}s01v2>J34P9J@E;X-+ie4*xxuu@j<0c>p5~fpjhrCy^%~$Ob;lM zLbVSX$NLON?hVn8#?t_|MoVoTo+vy=_mb{atVOUt52 ztk1S1OH;TtmVkCT!Qo1>D%vn%7bb>@VG|ae8JN(cY!{WA#=mpM-$6*>c*V3#sP96$6t= zGC6}5;-uPn*sfQ5Eh#<1h^dOwV>(p~^!Ln8Is8+F#d+(n!F*knLG9OOE>E1QDAeR21p z)>`W*Al^jOT};kg1_*!Q-<%v+d!ti3s<)7I&>%$RNfJg}cGZdWACogvQLmI!_~aBI zLb9zFIUNY(*HJFdCiTtx>@Vi@=AsKSjK9$!&Ait4AYjWG*;^< zaaLc1ez(~(Raa>|^$F&b9O;|cYHz)%@tGa~?U33}e<#C3OO3_~J>Xf=;Np*++BlV{2vk-1>X$#Si5?zky-8#H3+M}RO z@L8)lleq#Klt#}^&|3i|9e0^qrzS=vsQ_7xF#I${gP90vD`m90@EH)$W}@w|{AG-c zW2}d$!LV#dHrk|%-nqK(2Q<~g-=n0;`X=S_#N^Z;ygg^3+4?+z!uL-sV2ZzS=tM?^TZPYs2gDN0ZYe^->lKdwdTSnQ? z?u=PGeWipdZCXOx^ZG>?arkj zY6nI~joS@_*Ul_{)u^TFf_c^=Lt;zT1O1O-Ss0ao`PaTcp`=J}N;LR6PM48j#KZILW8+ASAX(V6N>gEnQ{zlVWF_ zWWm&>1rwRRQY!~uAz$|1IpadV{qChpVmdK@)Zw&IgF@`6DPN3>YIiqzT6?k6s=&vf zEqE#{qquP-wOtOf-6Z8}%5IY}j`4D8>j+RDHhHe$kOiI(Y!PKIeC*-3nUR@@rR} zk7Ht3&JdF_HRoDueeX`~MVIBeI;ja?na+mCIHBs-q;GcpwQV&C>u;oB|oDJ*lR=56MjX_<` zjTPg-T?uimr}}cPJfZO(Xn9b6^AkHq>sd1`Q26YJWBx2<*0u=7_6(toMa3H?I>b*Y zcPB7$4pFX~y_g;zsvdT_t&Qecc=ZCiSBnV`!kR^*a>wf^&IM! z^&IK~sam&6`Q+Rb<$IMKo&mzYe-}_vu(4;~%G5`kR=WTghE#&{AFRVE9H;cddYqb|7gKUrxoP@ubocjq{Ibb*@;@Y8#t-w`n=3pEFvCN)x6~zo z(W5#6E_zfKfJKjj2T;+YzyVN(hgRoQ4VdUr)c}beRSk&16mHG)=%7HnzJ9blJ7+Hh zij^gQq{_mg#^Ruu+tO?0 zZS%`OLKESq0fn#Y^LO-7BKMGbJvR;aXyP>#ZMl^<prt+qr{GLMt{VJxY$wxH1p~498A>(>2*3E1a#0u_ zDmZDP+Si%ny7HXFNfj@BXKq1Ef!qvKFbd=8cM zj?44|EKw?7yJBq!kr3lOLM#7WZ0@%9_&18_s};NfOb(YAEUFO2^i_@+Zy*jTn_3qj zT=_g^W~uM))v9?BIA>Io_+6N*OW*6=xx>A^np`EK3PL7Fycf)`!(0%c=yhprk#K9f z*EvAD_1)SghV;D00FvX-Ex;;^J2oI0*m$v4dv$15XLTkoUr8Z_S$-F_>b|v!%!;&%hbb*=cc`#xjDd_K z*hkc8mnU~<08_!MJ+vrhfOmXy4+dkiI5skWhG`ImV-VL4`5Ii$c{=cA#XvRS8yrJu z!i?xZ6(D@;u7h?!`6)1?*p@Uu0}3)W=ECsTS{?bRykN;0ns`fm5McVk?m@`J>M5oV z`JjTawJm>x;5L9|8J88Sq^8^;SB(`gnc<0XP(!|z5%r)2Imc+?CXy;VE*zOuXjs&6 zj=-?T(qa>)p^BRsd5?-J>CpyU*o$WsWL~<&Py!G>@f*9ix+FWcNyc599mZU+E$5Jr z!xvTwL+B&p0-?6e{=Z?i*j!2>Q%ARNs^*$z6FqyKZ?ENA#EYu4uuxV zQL1$v&ghw{`FYqNayGHil3E}4o!#LdFa^H~6d-}+}}t-9OnYO8Sqaa@A5pfIw8 z;UN6UPWRQV3yr<&Npk+{c{+bdPi;M2)YDTvON%#ez6cy?Rew?da)~DwmwE@+|&S4eap@ z?0AHIR+)0v*;MR|E-4^Jj}pejsp<_Ce`Fu9)9?dA{8W7%=!1pcvzJ^L_iUk_Ykfbct|;i0)LO0O)b z!*As2{2O}O(336n9X*X|%=h$kS6>(O^opJq_4G}8Ij;5=dvEsg@#4f_jmXXC$1*WH8 zJsO{_UmsU5b9#D9@00WMJkJA!@A-?!8){&Q7f1m-A{?mT*{rj^g=S7#Xye*d^@57O z&yz9v{15}L4p;TT#+00Y^;P}2O)2aDp?E^l;FPH!nV7=2CvaMPd%CkLo-2L=2xq_3>%xQicX4C! zyM4mvg~Q0|E*`Xd=2)Sz*hkc$r~vGvF>a~y@P6f~+%)-gj5{oqMTH>4NeQ@S>JGqY z6B@ufmeQrXlW`}bW4Rw=p+nv++(tXmsJZ3f7Fuv~1dr?rBPzZF2>-!X!p9^ZO+p)D zRx0@Mxq>9dIsp{WONx)Ii}V0B)DoLzT9BUjA=i`)4a)}+%N)9Nc{ydQl7K85ym-Z+ zgDz#C3NaD~T#=40*~)Tpt5f<~`p+SFS?1Ca2rD4zsxK-#J|a?d`#ZtbBp7s_Pq8Nz+3;8RoC9=GkPJq{55)^8U!x(eFoleT)n zFcs*-BnzdALEGJeD`Z!S=TFWib^8*WNNUgc;?$z}MJhAZd&Q8TNx4^&9DjB;wgOT; zH=h#6B({?j^sQ#;xhc!DDz>p05^HOIXT4|G(ad{ASk|o7qyfg6?`|6)T=)f8cl4Q$ z$`_{}-8G$5v2GL|MQXiF%0Qo`fA=%B-8^QiN88UL^|hnU24$W? zJFgs!X1GK@0AcEPg~r||uo}4#W;BBQfqyo>=VK zKp}Lvg@d$e^fadvC`D{!%2*18>j#P4ygvDXpH{%``GvCDiTFM$bq zclDWnE6DllY`u)J$uC%--T74j2%EQU`PJZ{zjS7WY4@#C)~O+*47ATvJYlRUl^8hp zxJ0?BGfURU);6wB?rU*{avxHN4X7j#*{Y^9G8GnR1rUDiBMKd{Sa5)FtCVYV8B!M@ zUU`QrC|?DOAmmW!YIBJ(SJ9G6pG zj8X~V`=S!d>Qf~zE|}YPszz#Z0291)pwnzWjkcR|gX(2e>4f@CCbO$9WgWCRC*}Y3 z3R+b)msFlq&{bvXaIdHs#tDzpJE@{ZwbN?#q*6S=>up+f+lPS7EXNff2UEdC_>y`BG6-S~Pj+Tp!l5tcr5}LHy6M4B0(y+B zbk9$>#77s()Twn0fa0P6@_;20{j?;j3tK@e7G{zzf502XqXNN`K|kMW&UNao2#K_Q z7GZjMrhIaBB)J;V5wW@%odCkm!%*czV#_n-lU+Oe+6caqsr_ksW{@!_r{&gixN6=A z(XdYDk#sLgaeL4mF=~O;Me1Jnm#`EXY@AeGK0M@s6!%agQbcD0dW6YoG?G^Pa(OIr z&-%u`+pHWcwL02`Rq=w^Q8eMgm zdozkmY0fmo61gs%0}4_p!A$a?Gq_x`5r>ZO&+_RKy?G#m-pHs}pUj4U3@HwT&sAb{ zE6o~~0aRnMDq!Uih^D44dzoB_8kAs3@fANgZqA+ytwwtv@o+ZJJP`cl4zNve&GmKD`$i1=y3wTuT^bQHyliQ%2Vwvrv zRK_2i`R$GGp)M%%Xh?xDu1C&=eVUD<8>SMxSt!}?@JlB0$XvPB!l*SAe`cX*wJ^hb z8*x~1Jn{_l&huSdcaO2qTejSGJnbPq3B>m{=zN((0h>!${@uPu!NufMUG+h9spwj32AS)Aa0TX%^0U*B5;E(y{XF* zN88lNgf?F}n#0qo1h1cbJmhP->EBONXfs_-pRS@G4U_JwK+V@?*bo2K&rC(q{_FHajx3RBK%t-fBZ?aI+J=`;zpH&?m z0ti3yZ6e?AN!i7d?3~tVWA(gur@Jz2b^mq-yIS&k5K{Ii@Ud!jTo+T9@U#QEVrw*gI4E- z?f#qz-p$U-VjT}~`HmcD@E!!OWf|Y9bugs^gxCK2ykUD4=1u#70p3s3P+?*2zvV_8WEX^fnILp@4Q1hItImi_LcrYljTZ4f5_2e?55% zQ!-)frVDX3HW9nu@Si$4 zXvPM^6${2z3WD~>2?mKj)9)1OV5|?H!>@+dmQMh)Q`u~89#S5|J26Ez51ep@Db7TOplq1i+UBk32u%n&*5x z9j=I4aQF!32|e$c6GLL&l_&!xXR)>$4Jdbaq2R@0&z-HV!u0ED0U>b}|B$f!XH7ALTDaX6*p(+?$X87zRxjpIcO zycl}AF#y`Y;+zERM2_;6`WE|Q`SPfi+TxLoiS$6t5SSd+UGd4m^3aukLxqeFs3}c9 z4Mai=g3GJ&jSvG$?hFlJOWUFGD{M*dvy|VIW1?T#4jv61Fim1pv>JRCV}+VsDi8}( z7bYZA2Rlhkzne98250=jC94!SBtp0yB&G~TizjalB!EEW-qz3p97MY0GCP0KyM^!zc(Qhjv@8Y@T7HX|%1cn_04A^SLd; zz~fsBe}W>U5iqLR$S573f+9!KeQ<+HDF|gbL{lQp`*Jv3z;5#{G4}6b7rz@d%p#;z znxFi!2F>(LERm;&mD9EnkP51o>~#42PleNg?n*`KhK+ z)is)MCKHlzXB+ZjAaymAo8UN?w{P6+YDk=tRDj~i8Wtj9+9-=_^XA8I>P%FjAxlmv zjsLOl^xAW4k!BqJvM8VOOfqs?&e*{0sfP!RsJG%@4Cf&xXar37FIM0~JoM)!g{KJI zi4~`*I9Cb1Am$;x@;L9Zrr(ebi_rjO+SiY>`p>Yme+#Ic>%BVZZ%s3Vl zl!G`6nw~`gc}R{*`J>H&9-&IB>?NAoJ?wUdRyN;a@y=Z-PfT5b+Zx~6M3Eahm>Ftx zKB<>$dO6IG8QiaWP<345Do3-`siC3k7Br5MCqaMF-A7=rRB?8pS$Lt{T+!j7Pad>M zxi*CuZ*^yeCe-%g+Ja=(c&G-k_51d}scK^DH!QFgg^w@Pe`P> z9SdMLWvB-%qYTBP`g9^>UiL&QIXN?VvKlQfv-U-xbf`cuAd++ z9sBQZ|K(HE&XkAHOQL{~d0(nL?9^JFCnQ6955(Dp#0iiRMQTY@xibZRIeVuOIxtUC8f;G(h;e4{`|r16@Up(#hoDAa=VNS?$bBq~h~2 zHF9ymEFEAv@A8RChMY6{u@Lc7CeAa$^@oZQ2MGV#>TK$b9d|`uXyti;r2ZyxhIf%a zA@A*Z3vS}b-E^AozuAeRx_!~!#Fg{~dZ(Tqs!tTPIV5JuF46#Q0VfJOp2_ZRw;JVM z1%%JXY)*_AWhKRlm<}R2f`bwQGDcWvb7V)K$*=Wxt+@mcK6;Mg;U`Z^=#rNZ25G>w z%hH_@s}rSbF?u@JqO?f5J&Q!;T$g^qg&>1rUsAmQlC2=ucL_U(;kJZ#Vui6aw>h{M z>PX9b?fKTh{DFNFzo0jqDf0&ev>}_Xp@oG|9{D-1r{eJ$pzp5tjrvYUStfOAdb&h8 zwzr-hwii*=)s@3<3m|;t5pmLVQX!Na^6Tpn9v4xh*kfpTWtmeV-`;Aaiaxle(BA7w zP+|LFlAUWFco26g$YZJ#-ePN=L;IATSUiyOIi!zvpegZ#(G!v5L<&mh*A;pi#?(i* z<^7;On3K9h#Utc9AYfYbLSeD$52iNz2@t+((#tG#pT_rS6GRhk`^<(5|)bzP*lcF{R!o_ zC1nr+DE0iDxmhxu_$%)8A|wwjx8*JN4B+X{n~DAD4xq&u}Iuv(#D9yJWDB-EMNU9Ebx9T82qqXBqhRrJA8j!|XRVn300r1J7eBM59){PB`33z*e}_dLt)qREciN2na)xE~o5 zb8iKelw{9rh@EEQRe4^h|*UK$RL^Lxsj zha=EElqTCD5OcS($1QQ<4v}}w|MQ*MmH|HLmMQEIpFfjowwmUC<}N{~t^m~$8;PMS zPl5DVEshZ#x$t?ALw!9&5lAZHGpe8@9uThjM#g!#1=ysJtNj zMhx~++YrRKn~Bxxcx{KEV=zD};C%B%^suiP1`rUEk&%J5&={f}oWpmRjj~UmdjL$4 z=48K|AlO(V{^Csw)|(yopaKv+0z!GJPj=g)Cov2WSgFXQw~e5sZio#Lm1Ka|!uDX5 zNG7ItUP_~LYow5}pcS)P!CLLsIt{GN62HfJh;h{={yvgMEi+uR!rxS$FuS0q6WGB9 za;c&9WyJwaHud|2Fo6IlfvyxXGng}Hs&2(=NMVdW|Ed(LE!P_IueyiKijIqmiJ@tQ zhP2z$cBo^7&eXZheT2ZOEaLkou?v2?jIU~71K2?vw(_yA-$HI5b0%ZleC z{wvqJIDWL_$(}{G^^J_<6Uud(G_nj~o6Ql;&729dfiX}0XmJ77{t@@{5@8jDl5Ql@ zzNF-8>IibvG;N{?eU#`@?MOGR9he9RzxQi$v!{;qLzj$vrs00J&u~db5q1FYW4duG+r$0S z)eUMdomi%EFwM2<$)o#OxF*IFE*>SS4*RN+yOp*g)d$*a1~aNGqw^A=g-6{sj@P8* zB$`o8WV16ni7@l1Nv+$1`s~_GxB$xRGWlMm=7q*o2NId zCQL=xnaBQ#%X`BYfQ7!GdgeE*ncI&OYMZl!tWnxBH)2b+m&L-sOQMAr{+TNR1J_j0 zOX@-#1`;czH7}5z6#z;g6?uyWBv~D_5uFXEqNO*s+Iij#ApD6xJ3Lh1Q#9#bf^eEn zX)I;;M=iS}oQ=UL%8|G4u#tF%WN$v;EFdEYV@m`bp0e0M z`Z}GXCTJ3P!B&(_w>VP=mH+^R1+$<=k9vY*_9}qz>kOojGfXRVfE&Ng255UuP(;rO z(ge>TH81OvvyrwEsR~va+n`*{uN-BWcOUZ}R~BIK-IfUpbXqOHWPBG3B$(i$)NOGj z7l6+%XRwVGrIhj6LZMm*7Fp^yV|Y4gT$MOX89#6T8^p*hZH^_YEBbF2Xa6=tj{mm# z&px6P{wMke#hU(^)cEwr?8lO3y)pPdeAE9lV9X+z<)CCj>g6C?7@Mo61asL+TopsB zq@v<%*QcDuCMjiQAP17iuxj(C`o3fncfAIr)4pc5lk@C#M5)8Bq{#V?u%%vjD2DOd7V+ZT@@{SC z&`l6FPHA35zGdDq^Qw~HS(r>$@*W-G5F(j@r8PQ+@EsR>uO%Nlt#Zn8+G6KK42l$9 zS;D-)lX?JxgGSple^A6Ogr|X(J=RbBb~d23%AHlXBfkN{_y>lwr|E?gv)4VToAl$C zI(Ds_i9aW`Y&1PxMNOGMqveIFvELM{+L90VG2D@ z14&{Cx$WL8`gZEU3aBssG@VN}+ zis^wE$*i^sf}|WfjPu=%SJn(fzu5@QNc z)z_hD{-be`Mj;-y)1e--@vP|jL^Lm5W*onM1D z;}Ak={xlLRXCo7Zf|xjj3r#t%pw9z##Zm;#-i)v+*iVuh0O8;HMUzUfg`~tb-OwM8 z)!v)Q%TyZ8!19~1d`AzdhV{hqZ^!cQ&J@nr6Dx2NmLD!VGkLQP_%fi1U_5@` zY}r9OjuC_N10ejF31}#Og24-|B*6-yHOS+KJGwhTH$4j< zQ3thGcKV|aw&`Wll~Z0M0C0}uXu7O~fguHKp;21{#T4g9>uwg7)F6(}7zdarpdU!U z1;yX}$%oc~UKO`{qzHHpQsw-m6N-hlD3U_E522jR7|^{<{&>e(i(~)?e9WC?;=eKQ z+|dCc&IBsYpWv6}l`=NY3RQK5o~im!Z=fdK%^1_+5vLzdOszvUTb%X00>y9yk$xTLgSHEl19R*uN%KYnj{bNlY>3PT?^ zA4mT#eZnvQE}hepo1v*frj+2K=*6~`pLYzqbki(_X7H+<7XefwvNXD z;WvL=y1f&N;%I9NZbs=@*WK21^N&wFf%r{=V%0lQpX2_cW$E~ zIG;Ece0Rm}m@I7~_G!nHt2JOu0O9Lj6rm&%Y@{ev5<8Z04MSk1;G*n#TKrRfn)ZK#WfCOV%GN6d{d%vAdNZe3s-09YlKuXgVAIldydPljw4(` zH_wIZ=M?*_J~$UypgJNnrwIC9aGWGDrm?caF=a)KZYtc&0xUl94HoR`_RVF5Mk4-l zucFlcG}LYp-yt^>hQgmCq&p62n@eAc4|yWB?Pz*vTBzr1Ih(ACqKKdrGnYo!+y`Xt z$=;&v#l0wX!J(jjgp(n3E_u$+W*>hXx+0g&%x>EiH2{0e8EmGJrk|1;qTps!G86<8 ze&LHUzAth4f>x2u=xb<8i00EIu2eVWeXyjORjT6gs;KvAAV`I|$pBSM)4X85nzkG| z(oQlXYY!!)k`FO_a0wlv1}GK*(?!;<8VH(JC5GwqyvQ}I0jf5b(ARD{85&m0b%5~0 zU$>VX2WRb+bA)z?OM7a1O_(|1SwJtRpMfG)%)E?A6z2(rvDZHja(QPk5 zub(G%ss2nI0fd!z*1R`(DhU+%?usp)*r83R5BAzyMnJrcoP(f^Cotbdm%^kJp{?6j z`qhcz#!~K#7$Te0$!HO-l*a&|=+Stl*UqzPH>R_5o>+>96->X#(FYK(Sn8%w%?qRf7>=?;* zIS$|!Flw>?KmZwW?x(hD9#C7?=vTC(=r7}1ET=yJ;cx$Ok0X<<9wiJ83D3-aFLNZ` z8xREBEA->uI~Y1+)9ff9rxP~V>1{l9?Ah;SMtTbi*cPSZfAIoDRf{e;b3eSmQDbKIN)DYZ?PYcDCeg>{?3tb$QKZUMIZii(_UbogS2l z9Jh8}gY1i&69Dr^zYRk+&C(Jj9C{@janQmOwHWfNAtv0H&vCrwNYq^r=2X-5*f4M_ z9z~>dUZfFHf@=%LwONLDbdgb@3xx(H$9qP_QobKvJDkX;q}_-Jm=!4~z z&6tLvk3G#+;TVS}{12RC#PNQ<(Kv3_H;4Jc>ksD`&G#1|Ec_tF;b@r$Smk_uj_K{^ z;BzkQ6qf`ZtoA#SUxGihhgTR1m?JMMY;Mgm=_6YA#^rsZz(`bI_-;UVyLO9Q&IOy$ zN*P(QunEzOV=ozkW}7R;8sOc5(g<`6Vk>(?;shK_ zX)*7MZE`0k^u@wk4vH9drK0O1E8Stn9$;`b=L_r5q_blMK6w_+7yPm}=` zrvHgj5xmZTY9HF3y0fN)aBFCdgZF8J=Ofz(`#o; z_F90J6I!bN$Ytl4EtNmuGEq4_j)U7Wytmj5KcJ$K1RMzde!DMF=#s?f2=k$B7^r)t zO?Hyt<@>dz^3~ViRV`=6z6`SOeOE|gRkAFyr8MivMSh>awrk=`SP_6~qG$jUZv}9n zLArQap6HaW?E-|vL`x|uaoCQi)-#i8Q|UZJ%$ViO&_)6fd3s9qaVik~6c8g#+0$fd ztgYdcrveE&QjSv?X#R`4X%>c1a9~EdkWvgFJpTJzcKT|2^2Zd&DI*hJx0I>P`~)Mm z4(xYLijjWX6sl;#mQozb7~`Wb!hK8z3<1AU{>$B%Tku1(!wIytA%zntVJFK!O!u3L zfN~FOSHEx_VogRy?O4$b*qXU8h|M})#eB$~s45i}I9??o9QMsZZEXidgi6k^55NX1 zgS^^JdJ`PM272mDo)z(SNB7vdUdNj8-N>tJlDe$5DF39Rz7@C*IEvnFxyKp?Yd`5i z=T=DO5ekJyve04aAr}yKp4Jl%>h<5y=;RejL7z;@4nLmz_y5o2L z`VA7txMtbHA^j5!utdjLMTb>djrB>bP5E}cFd5=kb%$=*{2#M|#jj~&UNCs$v(}O* z=53(4F&h#aFJk&GZwhjp4Y4q$Vpq9oXiURjYbiBQ)+%jJH{{g#p2eTxpadt{pJq*@ z%FVuVqUlANVl>fBc(#jIDr`hhSg}LL5@M9oi~i)kkY>vjDaqICONe1P98Z%F<5*7N zm!#4?_^{h1r*c_v0m4`O{g)2e5@Af{a{`|>X9$dAnn>cx%=BqfhDd!k347w1JFd-K zK3(RGENf(}s+%THmE;m2y!B{c`r|m&bU|TMkEcJ*uW*)v(uSeL$E@-R!w5+x0kn< z*VoX;@Ik7LdyCll2vyvi-Cjgtb9-_Aj&5n*nBCgCzrMKu#RCYx{pZzPkb|*h5c&@z zMk;aw)0MJ{QWVJ2Cs?o=A(Zc0kt|0O!RcaL?lyN?T;{cSU=MVU9Zrv(`r@KAPCJP-nQlv*x)4(L2FkNOx>2QlpFd?a0!PMg%eE07(S;Xqc}-#BERtTg_1M9B`E4=nC_H!=}Ss@lxCW`JTs}| zhAjZC_|QC6>6w$wRB7&CJ5`dakYGMd()8NQHxj4J9IeUL&ZkeR*o695^4?i~UZme)- zu9THvsQPGIr{?g`12MR!&9H-T_mG^P=_{o*IDUq02}q3HD&*me3SGXiB)O1kS0fe| zaN^;5>%p6Tr$s*PkgM~QDn{C!^rR)VPe=<%s)Sn)wrV{y-E4A->xT(sbNaQZ_xjgf z6~-K z0m!ObN~%xIo5Xpk+^z{AC$OpulT%YRarBqqrvIxf&)i~1hYKVD(1igEp}kWVR4Cfq z-QmCd-u8c%-{zKkt{jk2V+b|oZ7eJ{0M1-H4y=EfgOI%w`+}E?^wsVZci=%CX~Lj@ zqyXXB*PCKMGPj@u?Fd2UjOPKSj<-WmTXd=qa2HMa7|Nq2;tN(?!FK(kKi9j@1^~eMR5#pCB}AHt8(0UYMOg(pX!Vv*KDC z8;HF{v_>CpYZKFeyshm)MoE@wU)lm^ZK2YQ@R+V7%&etL0vLi_%KsiCJ;uI9GC-DF zIBK)W)H5y{gSv47fe`^Fp6*zyJ7#)+SC0pd_K}+tQWFB0@Z0}Kup@{W;V=3rf}_&P zGs0|}>P4x)Y0IX(en=XtEh&M~dxV9i>LjxhYY)!*{TJNDapjuMGWl(w=n(?0k<%;CxRXpQeYsE?+$wB&5<>%o zU;YD|ESIQ;a}Aw~W9wKtb|z*!gK5nM`%26z?Y4EZ4OtPhB{50cGjYp+=OC47erW=) z=@yxy(A36c(4pq>ww-{;M=QVo%?LbX3(jU>wWM(>sGD3xL@;7aG;1v6%#p_sUF)FA zHwX~^=*<|=I@n&Kg{O}Jwv=dsQHg+WK9(SqF}e&vqIC5rJ>g0t6o?esw6)Qn0hX21 zXomyf1%oExtEh`pR?lRW;(wo{R)C9A8$?M`f@Iv-ycWg1dDHgp_`U)Hzw+%$NR9@R z&eaQcyz?Kq@ygXBSKjtEJ0v#e8wgmVn1z<)a@AcRMT3#) zf|h(~)Tq1DCRVK5Lnj&t76MGLMaG8Qd}%f6e)s~iXo}PpRKX>>ixn;??}NR(d2?fF zyd4j3nPb1>uiof8(ep)pL|IF;6LA=S<_L|OH<{~rd+%+;V0G=Yf$v2Cf`^qQLwkXs zxQp$>w(Rus0_m%L*ruY5Z$PJ1+bkXfno+-EAfRBz_LaJwDqihUNT>I2I*At>n7Dc$ zApE~yowFa2j3?fK!xZR*gOA=azD%uZVROt`i9YlyZh4DZXoiF|Y<%a~O7*eCc(_uX zEpB#siIjb8Zb6eF91a$`j3UtBvAKh=4HTXnG}PeFaFcykYw)TRK5>(Dcmg{nOk*v4 zY3~RVo_;$vYiIpR5HRCYG)hzaw|A`Bcw!j+YwwsPmiE^%$BA%5GTJ+=;oS0gT*TNC zDsrb-9yY+$L}nuo{TV@|wvF5jDCBCx-wJ7l6V$c#C-o_QK*od)x;C91v3&nXtPkTf z%>NLVYZ#gxPNP`i0YDf&8~7aOckoQJeO5J#9)_+k7LUbZfMP%_`B4ew5NiO~<(|UT zh;q>q{p}DBdJqx|YPC%|gNwzYb_iawkgNbLGYkExh+HPvIu;cyS5;lJNUO$iqtFmd zKWs{|ZQXTSd%b6voyHlQT-36CWn7}RW^H{AHii|qFjso%W25ui5g>fw@y(lQ-JX?Y zZEWg>R(G5CYr9XJJq=FDwAqJ}IY?>Y<7zlX7y9`|l#K}mJyTLBy)n|1&al)FFKyZ- zC(tvueTt)Tb)L4(G5La_;<+TYX?eXg07|wL^9Q@5rd-{AMR+Cgqf0_BfDgEBWhJZ7 z(5*pD)HYUH+$np5<33(^C5#)ipfu4h?$`hW5zC3Un3s3zYBYbaor)-g&5b93>vXLl zIzE9|@S0tzW6mfEnDD!QeL0xB0!8VgC;FJJl~a@fD-8(J)zw`nt!f>HUS2k_uvl&a z0s|YK`@m7y!?rHwnZ+wgWde-WG(`{K#Loc1Oj&>@{~rc=1|@*d`&)l#x>~2-KvQu% z2#f&uC8Urtg#o(>ItV9>-WH*5N=bh4=ak&4KyAn!Nd7$Ypz0v{?ZP&#rf%jL-t-+`g`{6A-FQ`T2?lVg#SiL=lRx=;08#1rWaa8()g=)G#Vtl-CDU@w{tB zK+|<|4JQparKq29ga}>2w~UMcqznTc0n&C;a#7FGi%eG}HBo7=@#F;TaD}ja=fqw3 z;LK|Nn6_VaG8u6YL%hM+Ph|8QH%0ChY+#Vr4Hi4I7ut{(Bd` z!_>p|HLxxHfWdSjf5R;Nw`sEaQx!^(ca9jfs%q_B*aENbPrigB#LM1k+bXWE=z|TRKX|K3*+>g1i9%B6Kmfv zHNwG4Rt@~sS6{WD45UH);KgYod5Ag?+AURV1w)jjj}+Gd8)Bm;@a3LW(#P;z`QOPBg$nWG<(L|ZOolh(uN@}T0{k|vBxp+qJE zjIdSrLc%Dxv@C}p1Y_@pz+s*L^x%mL=9W}uQ-s0>iPNE8Y{VDjh&wh!u}%8!5t@h{ z=B9;EUgJ(8M5v*q2dK)LPXWR|{NL5J-t6cNKd$LVHT-x@KQ_Vu>1gS}(rvEPM8VyJ zsjd0=db;p>CB80C6y7hz_iTp9i>R3gtI7@a=|38PYfBJDF>4@jb5;MM76JU^P)P)g zS5++6PU9&^p#x;Dp@ipv1pvRV204~Kz;(HL?oT0l$ zQo(f76;*NC!61RWVyArgk0HKfDJJK5~xnS2`VxQ`}00*oIr&CUQ{(pb>g@8G{em#e&$rk|$3I8BjXPJoX?@ZSCAV8&~R=RCZS`tmKzxF6)ZF?_G_o#!DOU*@pYvWn+gex_YV+XRKU$>oGo2 zr!>&J=UW&wR~c~)`{_Ia(q3~{(Bp}f@>RLX0)(00B-;YWVBB0--$7R&zcw?)O;jfs z=?7O1CVKcm{L!LA*~{<03anj$kxW_Nj3ErXUCN3_16BN_6pQD(jTMsMEr>p>OZ!Jvl+!%SU(!io!<32i-B4tt=9Y0?F zxlRKJ=X=k4Tb|%6_ffG}i_g&p1{mwEr*Jh*I_e|bzX4r(ClTHN%o(ps8k;BlIH~pm#>D^4rp$M)J zvGmkru7rMM-dqg)05Rxp6Cj+sfoddoG3oW> zY3&6gy``h$&JOrNa0@@vd%)eRQrCXlTipjvE(`J*)^V9UG;BA&1Aa8{B6kLYImBQ% zYN3!+aD{f#?K;2dVHT!G{vdwegQ2xu#kGWOQoHnieYdCNU-=zoXg1__<*=W`x8H>~ z1PGhMFo&uy7@m*EMeBC^2`QE8=)iac1^?#v{LHNR3@ z$3$rrqZTZQ{vm73QiDZ9Qeag`BT+#crd=K#Bj3o`Znf!=7L3@-=9!sf#{yvp{***% zM2AZ2L_vd@cSF7z?Y9})u_28nW5{;qkvW;Kksq&>F=jYzF#j1#AA*vr?f}9UKF91Z zwwdpyg;v|)NaC?wq#RrL>xjZD;)bz@wsR?l z7-w$lFr9eBSS}*zW;vBggy?wJW;Sn|M+qC!Pk``WeqG64au+b~hlfJJ@Dc}W8bcvAb%iin)$@ws^HltN_41Xg zJbOk@o4e%`&0G?K9^zRAq0AHAOG~H2g_N`SA60vu#wA;hQP&!9IKr59ODZxNYP&g8 z4iF+n7b{YAh}%7OnKni=UekkOR`=_Bz4RjO4vT0f#nJ;ryWx^1V6mpO032#g@%_KX736g=`k zB}ZV|9Oed6cA)t{OvaKy?hLMGgwFC)*$qSi)eQ|ox2-Cb>APpaL~Ua)Sg;69!Itn z#h2x%*_el%TDqRE`a7T;EeL2EX}6Pt0aB}~3kIT$i5+(VMYgh{g2AN0K-Pdbo9#H4 z?W`nX{L$oPYm`S{I{{YgRpeE|T<&JI1g%Mf)}){X8*T_?p&!~dl^h7}rPU-tAEDb| z272_)Y(1oVbd|XG1twhi&)<2F)nr>7O({*rxhWn;BnQD5DT9cN3t@l{)AG32Bu7=D zV^j z#EwerSc!L30_W(XIw?&Vu695=|94gHT`Tv7wIq77Uu(3pBC{$oYen?v7@txQu@;B9 z2Io|I&PwaimpKofZr1X=%FbI^J&s7hN6vw)06_Q$A1tWUf|b&v_n%w-bS{f3xM&6S zIAZ5?!gZ2agG(y1WJUCtM?znW+*-V)vTs>gJ=!ve7f?k<4Q(@KY^ew$pniBs6Vt@3YMc|B$$ae;45L5++8cD z$85kR9%tR(Q@MLqPLJNb(ZJTuCt(Y+lJ`~ezLnJD$o)#=X)rHX6^N9Gjr{dk##VH&y}ZQ`*(l`oAoJ-7J5*mASAC|Z6+zLtiQQ_cRSezCrExo zVn=R7CQ;PcSD{q46W8ykB8D8PMrRVFCb|Eay358O1yad{mGkRJH-o?2F%X+5lW86W zSsTmq=g-xyV#_}Li+yMU+ZQLX^1dD7d+5T>&&n2fetr<-?;`|_h;_G!vU4_M?SJDM zb8u6S6|OA((vrrV!Iy0q*P7{r-bhBUIU=8rz?S)*QB@V7X4u-)@88_;w6V7> zdShB$V{QlR!PK|ibpnP6O44%wQITG7*IsOLI|K7J34smB3Pe8+cJ#1lm1ODX_9}hgOk8X9ryQ%+FEHgOmid+4D}fF z@l{MQ``-H!0$|(49J1?j7K=dy5{V!J{z0T_eIznx2I||C1quKVe&RDV2@0{nhdvaI z#|9FtD1(M^ek@cPE9tEI)C`=u2Lf@!xHxbKP%GDa>cc`dy#nDr=^!{i9y%D09hitg z>!G9m&Fe>jmPvay<|DnPJzOnut6A905K>tIAWwlacaH0qSRf?X!JR(qxz(X+SThf>eGoO7L_e;%%M+`+1zuoSzNlowEeW1~Cyg&Cl(; zrPMGA5Psy3rPk5X_WH)X*%kBj7|RaGLHySFxzNvP*-agS-5h~nF#SaG{CsG0{(Z(B z35AG1V=)((fs|<>)LMw-u`uI7Cw?H9KBR?3fNY%#d^j}Anq=3?olKDVG8l%?Jk9Om)_rn;*RAxHJzEpZ4Ckls>4tdBYVlO z-VkS|l6_(Dy%zxCKm3Z!N{)3i&%W!}aC$F;Pc)^2HnLvjUkyOmyI~M_ z;|e&1S}P)*sbT{B=}Iwnr8Q;Po*aFJ2fT3&6?NiT*j?hj4K#vu?r${~5v1iNtfnsf z3PtoD6Ba_qAZm6m4DTLr2MB-Ueois*hdHnV(xNUoA{XtT9`A=9@8>liQC#;U&-SuA zALWjan0RLZkROINAA)+vj%quoZ6~H)J%i}z`Hx#80O9MtW=tT7@5IHEHVI? zj#*xGd(>46))6b5;0L zM$G8!n|M5#~GlvIY5a7D3r-NE4bBv=%KIRQi zp1R~K+ zNFj#WknF8J!a%@U!XWm0a+OgC6X{dMt%lp+e0)KLkV4m8hXS%0*sMRhV(iy`0Yk&{ zcB5XcOC%+oLWP#S>n4gbm&r-GjS&2QhB-?nrf*~!RB$7I#M zwKd^+-(;#1B@D4vMF>^-85bnu({Z0v0uS7#a-rr9a~p47O9EHWRC-~rP+&wf&~z;# zv!Z5mojT(Opm%CATnWmyft7pi-~gi-mSl=Q5@GzEpR?ZaHgsO38(9(sHOnahFftp% zu2e!gMbp-*?N}W#r)plaajQxMkw)I(ZRVb2QE|2EzLHEJ@0-soV4&;7?F-%lPqcmOY`CT!n>uo?~5sP^puUtfbrU%~x6 zoeyFFmL=o>X*k88@C$Usz5)t5p|A4Jeu&T-!SFKZ1whzv7+~00SrVff2n#rl*7O~% z6*>2-`ybWq5n3lan{a(l&}Imz5JiGhd92KJ^A;Y<2_RysU4?Gk+C zKFFf}oMa;W#nDBSMBQW>ws|ahhVCgz@md4y$xd5@ps%js6p5WQwEe-E|6$?(-0kYE zBSN6b0TV#mK~g93B?@Ipf)KTiVXUx z$xzB)KaOEuhNB_Z_xFAC$NsFvdcF0Nz)6tLzH+OPd_vk{X0&HX$1<-@xag_orlm=wH2;9stB- z){~rP*Vv{JH)e%TgKBtCYz^)n_Aha-aBij%0|?c-F~Wp!j?|-uY>y)1X++73ZXtYz zfEx2l_81c%O&UcPLxDtCbkv3jImERPwuG??$W%p02gQG-+0^e5-sF)+S=^FGImJw{ z#a{|z%7r>@i6|4N#I&lB}z%Z1P>UR*;4w^mudLdXk1_!nOs9QQIPCzMym`EzVjcdunDyka$ZQxn>LMjA(qIH!I>Umj0O8y1wY7T zoRnk~WT|KVHg!$YCt#L3q`50vl&i>qs$QL>h|rXt-MlFm81@W#4d4asGlGcJa5h4{ zFrA$23zE$WZ3rMGmMIrb_tHkTl=r)HZgyqmSW^r^qY2WmNq(!8+gRT+Wxn5GCbLp3 z)M!P0_Dj25UfW)LbJ0{2S=_!&Gw#T#$r519Lx!OkN#nLYXaIfs9*Bho!e?n^dm{kI zT95y^-+fRTd4FkTeRg|;E0xGmu%m03zxQA7nT;^?`z4IUS>a0KS%nA{bCnKlSWll4 zM{j)(9A!aM&<77gan6to8nKBX!+_b%&Dn=R%QL8|Q0b^xsr0y3)r2|J#ahn5cR(f_83;wgS ztQ}hdkRasPzVTdH>e4pcBTfm{=i*Hhgm|4>2v?6hAbi;f9K=MyGDVjQALY|rh7amcbmAFs z^z4-(*TojFxTITqpkQuQFrQeCYrEbt+&>B}12*_B;>u?pILJGCk;^bb2aeZ|Ok$}% zC_Q`qb3@%`KClV?e`K^l@WdWN$OJoi&T7lZ-5^-K-d)2jkOy9sO{Tyzcw$@Es zCthUBlO7Zfmg0XoBHfaJ&S!ZI-;(8p5o|<{6UPhfzL3o3Rx$z*{*Ftm$8p!vw+LbE z@P+{3*R5<RsY)_c(@ko1AV~TrO^dM{v=h%R9Diy|H4ScYgb{G^nX-@C7@y)Xs`RWM@poMmF92cx zKdp2aHGTxjS%agHyeSB{&apxGsOlaZXEX$@rhBq$(Pe}ApGo8DOEKnWtz<9^oI88?Yd+fNc`)sue9_S%oC-ZR5gY%X9wpU z#fWkbD?~gh$9D9~^(7!UO0P#!yX=&9^bbED8)45nbfbRyTO2M^20AujP81`UrpX#f zUI~^4PyQ-pE;4E46_wbmxag6CvTzk&Qr9`sys`uAeT(8)q#SpvU3P8>hhAaC!AIK0 zgg&c{Zkf9C3!4xR%rd?-GDq{)c_-obnj?b_!q}wk4QULarn10QP+>KZP|$FTg@Mub zYZ61&-h};XU`>+r*oBCvEL@&bqukK_fb>H{K4M;Be~6$=E0UHi;;P;GETzilzo9V3 z7ExjrnP2O?@rJVxKE$2Y6N0!j>fGSs9)8K#1cP*V`VmLSqYcnL{(rQ+4RD=VTHo2B zip&UB2}=Umkj>O>_t0}?$!bZq`$IkMZb`Pf&DgS#)V2pR1NykKHI}aK=t}a(%w$Q5 zOp#h(LnXixn1oHHNRfmWr6GlDl8uZfrOCl+TZ{GoO9my zy^?G<8&uuC_rCA>e9m*8^L!sX1o-Vu0;_(Zkv4)CDSbZ&TdY>-Su+Veb4I`#Fb)h_ zbnbbJW==b4bG^j@!q5B+X5+_mN0~Y{*`sw#fkWO)>rUi1H?w3;t!C5XMYDV6H2CKo z6jafOOC79S!cZ*7i4-*I)NM;`mrn5&-t!=7@O1(WfV;r|PzElC6iJVi0AkIBrF0Dt z-uQ9SkAa^l1#~nIVpmF)b~a&KmAp*t7*H{wr88~Z*qhxUkzw+{QuDbMpIKq52^tgX zhFU>#`|xHl!I=N!IJzmRQYQ_>fiaWa5dlhO;jk#=vkBotwWHQq9GxYBOM&7hQR>0-%gQon5ixeDL~f|8Ul{a&JL`APg<`9KzQ!Efj;}AG4!bHl!7diY?Pu| z7g>fQ3l#b23hG>p)@y6w$QxDH?F2`vE7{#}C8EW9jbG3M-!fwq%#{TSYsRIHIV96f zZV;hA&Lna#7kAq-s(HACf|D!&=uqGzQTnIm6I#o%D1foR8LhOsI?`C)8jMx__clx! zziW`Nwt^?4%7mF0p*F-kj2cAMcZJe5~%we{AU5Q~S+Qk2}LPGgm5D(N#QSqQYpF z4Rk&!17#ARQnzQO+*R6J+F$wamNHaa3(Y&Ja2aK~hDcvaxHq|XM#1qdGTSmfD9lEs zh{`SL)56!g$6M3sn?f4C`d#JcNcncU&sP!mV}{gHq`aKmDB?KC)(1@MeD5?d=rKs$ z3ofJ+Yk8flwUXb#Kb$roD_{vg_}-ruef4GopVm5iq3&E! z_Ku=O*P(4C1zU#VJ7Aq=sQZ?TC^K`6UptugXXYlotu}TKlmpf(flxe;x86|lQ5@r? zM#YFHF34aOf^F=6DcD64^^N;tHea-x*^K$lS6l5_i4ZSfzn&G3&V`zgu_2~M$upDr zy>5B*`!g?~4#+1oFPVl(e^6@fJts(8IHFS~H=n5df|{tu6vWer1=7 z`y-?8&Mds%FD4NvGZ$fvZO7d6S!j)?9p18Z@VnNpg0GO(%G$ zp)VDx*RfYbP)<$K(xNOF6kJW4Btl#G<~;Zag|~M`u8ii;2RsTL%; zK~qHr0iY(N!DXgX)mZ8i39J|{%NO;PoSYnG+Ejeiqa2+o%O^m8#55&MIF4&pNgdCb zoF^iV{tOyJD^M7K(EY|5nPD+erzt=sIw!JCE9Kqgg?{&#JK?!kPXW>KJX98ymx`3d z+lP=aR-5j2KYTzSH0CFEp6CGs$V!Tu#vxY#v5f^?(>LfLy+Df%U zx2WZ<;0h2v{iFE|8zqp3w`$izmcqH72hC2Pc{&;3sbtza5dY9LRx=Om9gv(KxRB%43$I|Rx&8G}N znEgTNk;b60kDOQ9%Af$ues`Dj%|}-i@*oKEE`bm7!A^y8xq=D3JMrnUMIkcM!jYbp zx4{`*ua-s~?Wh&Vcm!K*l?j<;->B}m$V!~{#Q{#c7>l7Ov@@%Q5fI>OJo2eh(1-uZyKnx4g-dS-&Y4FlhvQ+4im4PC~%WUAROI z1bu3;2al=b=dZl7?Cm`s8#FaTh5^-aGhbxdQaJVf+hD5h?gBOJc1j`CEVuXV@Wl%} zG_`ViB1bPh31PXgVZ5rfyaMfSL%G%9urT2VKTY*)s&8MtxGcM5UmhA`t@O((-ciKy zs91cDi{jB^R?7>b+SZlReqc^0l2~)>!xfjy!AbEPH1ujUfQu_cw7YY@rH(`So`Mk1 zjp)pCw(yryj>ILL8G$Pq1OTIX8Ne&cIf-a7b#!;-+SuH^8Ja>#fUxufY9mw6HrM^J zO*{@IhFAw$kZ7K$`J`=}5G!G~M<&9xK-MmDSVIEN#r}(afpcU61!Q^El>YynV!@XtT3E`k)T z-?<<^ipcP13{&6XLs@)13yLMK&V-6hBf5tU3No0TE+;tZfb<8QXJeK`z@}j?ALEl& z9qz)98A4LzBnX->7B^O0LBc!Wj1GMJgT!x^r_4+n^Mh`i{SGEpU=TQPgw#WMe+S(R zcM*W_eK$$t*Xf3)(-0r$r9TMk zS~aM((WPzoNZl-b!us9r?dP~{!LB4~Hth`RG-sd(49kqNPQo}&oc)A1+4|wjM7;nm zPYo*MqVYLe`SzT&mce}%6mS|&PI1?dcY;G%XrU87L;}hN(-Q>t43I(aq}d3_0O397 zoE$?B)$qwHSC9aY|= z&$8ug+ox;(0P&Ibq9B3)v}uK8_h5TFY&e;Ps@DMsv)>UXl?e#r6e%d%p0X0y^UV!9 zvr)M!vroINupAy-(SrQO z_s9&mnnh|GZL>`*W@JS&kzrA_X%vc4O+|%DE*2$NO_^8*Ta2VtD$P8ceWf%ix*>{G z2zBukREVdrIf!00;{1)fBR$m$Okf?SJ3#oU3mY{S2oAR_tHvPVk8asIx*!N{ZWo0X zCuYwQZr7SD8PZgia(!gtbdE~sdYOw#bR$&u<+jo#y-$aymDq8>G@Zi40(MXL2OKCJ zF;#Q1g!3bP?$L5OjBCZt&~|Y@)4^dvUwNwhpvgR|gMsMSO(gD zd$q443nfD0DGhAl0E(<;l&l_F(JIDd0YzBY&5h2^@grrGtm-PLxaq-i-S&cv?TD>x zfRM0Ij3R((Akw;_FjE_F^dZIt$1ce&v=&s2olpjex=hT{uZ-x{!_kGLzG+bT7rf=P z$&%pV^>NT&#dSktRunHgQrk2aMHGigmnr*&7l_KB9^-Kd zs>_BBUbVN7T6`GS6_qiK)M@}E$^MvRJyh6H+1s{+4%=}Z2;k; zpO4(<$@vnx2a0WLf!c5j8jCl!jQWMM7Erge{Zf~VV{KiYB-xIiapRaGVc*yC1^Q4V zodyX;Wudb4vId6$3!Ez?d^2s)^$f-Wv$mjP&QNR+q#8gPxhjX)_y?c~KLWu5=)CpR zx$B?hbqg3Wp>?Q&KOC6jAqJ(fD92iv#-=O(NGZAA&k+=NzV34!LGg|MD+EI1s(L$4 zPI)|2eUZ^BakfQ+8!;4$G?6#g6-lK#r1R&3Aq7y#r@e7+&bg`VK7V3NfCUt^W_MaS zKp{mHq}y|f1OAZ~n!V@RwYztwrb!^Yc*3PF^9mYf)Yq?G6#Mlze%R^6YWEY8(ih)+ zLO}?Vm^lB~c5)Oh!RB}|Bq(s7PW`UH$4nsrn5G|B@sMKokrxjY;Fp+;$r6w91efuY z>I@nnywYamsPH15g*$N`bFEFOUR|lvxD}^_G(2YF$K8u_Obo>_x8B4(I6~eO4-pTR zi9X;~9Bw>KuUZxnH6!Tf_Ji!hiz`cU=u7njgUuGf3CCQPwgA zz0FHu*qq9=ENAn$3a-{~gg}VQh<@_F;xE=o>7>&H%U|Iz7)!dI;AjZP3|?aL;tw9N zc3BF+0hvy6{?vY*odO8oM_;ey+)+5@4;>$F5cidH>mpGN0*u`|U*;NNb=$mur3zxO zheeJ*Nf)l<$OOmt4-e@MZ>l37Ir+x1x3VYOIx9(DW zV_`)(Q;lZu!xO|k#7!TbDT%Mu_fdG`O`HOk{N^9xy36QHh;PrA}D!*`&&Dls`!l)1?EUZ zk{+yee0zB79xk1YToh=knd{{9XYhBx(uouQPKTH(Jlt$J!xgG$b5khExY}-;yWKT? zpQfn5GUmWxDe(ulUkWx1QH(FjE<}Y4-K-VAl`FT~ZUrnB?>8bI^u|}FcBV!U0E~FF zr@z!;RLPy?LX;g?gDs82j0ykV@{qOavQK7`)Sh`G<&|>d)}ky5yVxcqrVq2TyRB}J zcwi$i9O+_BHB^XX`xH4p`$~^1e1`oNa3kFZ5fU)zU5wJYD-)J6;c=&xlk6my5`b{( z6I$S;SVe=t46a2damf#ajphQ;9SVWZtUWlRPrJ!G zVq^c#E&^J{YwGH@B*DN7YjzTDlU`(fkca^*uAx0}Cg6#{g_;TMI3JE;Yg`N!eZ~&U z2-;lUhKLHZ9M&N*OF!@ztoB%bdaHGN7c?T&IS7*1vdCnMCUl-Tx@d${?HjoW6!*~q z_zo){cC_SB4?4|TRm#3V8?~ZnDbqqwrroX({XWPotdJrUjf=5YwGx8rV>H#&W?8EIns5=j2VVNdU;} ze9TNb2cRCL-GueS3V$84Gdyn>VjTnAUBlxS2UItbtWJ&~lgi&=>!D+o=Z)MD&Id4) z+D5Iy4@sHNm9D!M29~5VLO87SINGB$eIcrXDPY1Eetv7~f_07k0a{KwX}yYmTZ>f{ zGdbQGIaB--Sdg4)KvEF$CNj`E2Lkq^(v%8?CRjt^|I;syDvd$)7t&8bLP2YR<1Hz; zR4(MWQi4WkfJ0Y%NuW@1o5m_2v$gkllMQ-o%G*Th$^Qc&9DF%WAT(ipiJ;Vk^4kG& z1IFHrzu(YJR=`I=*swSj%9*+XgpdDF6I%+PkB4)eX9k(&eg=#acLpA#-4YijLoc|% z{XzW8l?*TvTI?cw!x)oMq9uOc{%V<^!0qc22OL;Pksi7hmCQ_N`||uEvAb4V@bx+& zIve~Z+1{KoWnb>DS9Qpn-Ny-?vBa~i*{H^#MZ;_c5dP2mVgR+l#ExFS8m#30C_%hp zY1=ZcjSajzYtVb)@sr&rn5e51UACf`t>nQ$clA&n{V*)pjp9GS!9DkQJiFMA2$oF1 zeZ0^1;x6pG6>kl#sqk8F^sK?{9GzH|$6KxCyIZ};1G90kv-2Q%+lLb;ccs)$W;GgX zGp3fp!m-wS<(1jRmGSEU;ZObAV$@qZU>ahf4|`2+*;)^-x$|u2JhCg-=15^*Yy=6$3@&}MHGl@&q5zg-+J`-n zpo^CYy(%~C~~A7%x~ zB5K`V)OxN|Lx=n|4y{Dm++#yLq8SM%{l(5+T05_QE(5J*6_Wem_5)#-6@#fPKV4f= zq?xarRYd5wzpHC=5+|LpPwWFg_^j}ZiU*A_Vrg&NEUshBwuML(}Sqh zq*aiO75Iuxu8Q8hCxs^*l0duKTE2AU5=oih?ZkLskKS6BI|Yo0-goY=qXL48Yr5qR z4DhHH6K53Mh6k}|OM40d=?5`5Qt#rWNa&mD0fb-pJDS18ayQaRHETJLYn{fGvM1H4 z@~_saEY|OhIjLsmuWR*mQnucZptGVpb|*}5@oF&UwTdX)ccdj0lAs0bwb~RKsp5^;B(`I+I5GE zT3sH?X)tBNI-zcr=(SdpjDDXiyIW>2Whsm<#TiTzMLO%WEmiED>R`*wrYXI_9zsJ3* z_4*vAHr!I&u`>b?u6*X${Z_y0y-|IgeZAF}lYMHVQN22ZtJx=l6ohHiPJRd~X8MAd zv{qas6BQTCMjIVDeF z;k8*d<|A&*K((-8>BIOTST%1upH*hZ;CkQ&}0O>B<{jdBc6B)7&&l#BqnTp9H;!uFcAXwByfS_s?@->8jl)u zUNsxc3g(b(AP%!S?tmu%Ve|4)WC_N;o=Xrch!icY>K=hA9Hn-A3Xg(^y_{}^0_5HdKP@V~_0;|S z^Wl``HnP2y&9ASG+P2fv3D0ZzSwn)s&0g(w#b7ysD9;ws|K{lhTS%|H zml;adt=>L9$6Vjn%2LrfYGQfh6{Y-Qx-2wV7N^hUBy&gepbb{jJ)2a+F8I>)xs&ah z&1$yDo~tTO<&1NW?ys^YMqQbN{u7CZ&(@N!9kJ=vdp;&T9){49&58B8UvhvjGRftq zVTL4m#KcP{nqTV`kF!FaeWdMHS<|(yCeB{<)+2J%0fg^gY+WUawSz_KHrvs6U?;QU z$%edSK#XfJj6#^JV9J~~GR%j58j0p>w<_hlY8U{k1j{t0e2a!$#mfcJHp2mg2mgIl`EBQEi@uMT zIXyocBK=LGRyGl0T4W5?M+QF@wnpeme3?U&&d^TGPDbWBtfs|+nljimGO__fY-vxP zmkl5+|BHU-?&bNMR+X1lCHToqdV+x$QdldW?T&E+pXvx>V9c>dpa@l>1_}86 zj~^)aGDj>La%6DrCt>#R5Kfua7I2UBh1T=BVIgCoMrZuH=GbC0+oqN2a_Sh04m-8v zjnSUJ*>okBE7z^ie6JyT>6&Ij-6<}l#^U0E%oEhifuGZ|ZQhqmhLwl9W--HYd=gUu zcb{kbf=@dR&gwdJ-GuIQv@h)gqpvFwmjS|$&8knW@`!*$Tp$_-;H@xH#8Du?poo;T zw-h<^m<_&QYAm!=*7;cGVM;WB@PTXHKH-t6zI=-A%Ib${DdtB~Btq(yVP0@L@L=V9 z>v^e*`WUZn_17U6aFeOi{aW!a>B1KO%*zgMa6?q=a1B9s$y{#TfRccke zWc5)PbQ17Dt_qn{)|w)XT?q)QnQk4KU{Ur3TvzXm*@r_4qS_+Cq0=hP#)e`6gKo6Q zIUlUDldl_PVgy>Qq0}sE!$lKP|9^yP`bRu8!xpFm*qC`>y{w5+LP}Ev@(0&R zHMtd66rx(w`I~Xk#r*yKu1`m1%K&SeWv8=>*{f%-KZN$OTeyJVWJGNIafAR^_o__FUS5IXMjc%r9c+Wz)G@ z{S2kR{7n{&eU3yX*M+;%SvnvZy!7^_t$Y%TSVq%(eC=tesR?rr2wMC1xJyzb9hP3k zKm72x`1Mtec?ZS_s3!1jVrgKh_~{dXpOp?MK-p63tnu6xnv=(T4ssAW;I+-$T4Umy zW%%T}m2gGCB|R%*ETm}E0O6BA>Y*rYV4Iup3w=xbL$p?IRIe1rWVs>Z76?-7}W!|=PxtI0a z3q)~mm-vB3H?o~#0wvN&HGJ;c`(h5uu&hI*&Qysily?3Qh;T;B%g!WK9qJ($*4TSHnO|K26R zSss9Co!hAxRb8Q-p2u2)34iZhvP^8sQk;|`1(7vdQI143+BwZ{8wia;FjlqRwukF5 zp1*n1m&B07knf9!q(iFDCWcb`*GR^tRrf)1?+p5#Rf{yQeg%4LC;s(nYq0M%_pRz@ zrmFfuNe0H zlobmr4P}mC4$Ifx1PB`=TGsXwOqXFI|N0K&W85VSYDcSIbebc^#r4~_?1 zYz2d<0i{}vW1y4(<3)Lm$u?}+s;ZQ&{+wh@7FN28*I9%J5Ga*&TUvD&?J>2egeCm+ z6g$$LP*Xt9yRB@m25JF>PyE?|4W9RQGVHhku`ia(+pG^O#s-o&Un8=S@xW_TTqxGK z?OetW{1byF%Dtti29z}=&O)uiBJ(TMrzU0^o$A7pWEj-&jDs4|b}yja<1E)kxUJXI7opz}-+iJuK|S+8K0;Nr$qK>$@GONXiTU(7 z4#NhGhOZEK3TH6_sSX;fDT2FmR~WR3VL&P+;lZm8*9zP(ao}VpBg@{|#q&-8QpGEP zdrq!+;$xyVlf7YS3`M){TDr5^Bd-moyh2h2#>|-9o090+`SQyASnGo@p*uS)h%+$U z6UX>%e;!{I1J*}WoOa=~CH5Wx};_Cil;0ncB9KEM=38~2#z{7<$cp&qr{?mBnjTRs!n<)5lRTP<5FUw z^V9&s``-EPIU=LqJ)^Ou66!*Y1Xrbp7CO{N;8$MRHw*t7!<4+{L3maI;{AA0L5F7! z9HTD@E&5~I`Y%Bez!-da6QC(aSrWS-&mYufv&k6L#NImUmhWeruqkZ~V{f`AGxiQZ z_{@JNG=L6k4=|R3?J+RkF>L*-i0XKz{R$jDix{VY}wj4u**kvO3u!Y*3Zb<`6X;;++xRogm+tJ(7?-Bo^q#Zd(HhUNRv;hzG@yq(((WX<|VPX`@A+S0au{=v>OP)iMUArZ>Tp zYVF|&AkU`lB7ljtjNt%;ANX}A!O60f=RG^G{i>OzwU6m|;DR;Iz#En~YLMk%Yc9{C zmZwyKb9PF$Hh?&zmPgKTbDNuawKave8A5nAQMyvu3^3DWGnmSW9S9ejVzbts)4 zK!G^tdBXCEaasvh1ny16jD^?Dpv2Niiv0CI4X2?Ij?o0p*?gVD5g$BVC4klSL=XbP zsfF!+I~s7s*hb(?niQoCG!!^ca=AWDiM!M5G74}@(7@csxY7df%~Yb=V^L~^7c@kh z;981C*e64s-0h()un6-sG%2)BxI)pQ=llT^*}c!fjrq8k}&R*!kzZ4XPLjB-2-XB5EmR4Ehp(b zxK(Swo^&__<(KF(Ma(~-A{Aa&jgTaXE$L(BR$(<&TA1*|$5%O5Rgp&{q;Bry_Mfj6 zF1+i>#Uq;6v$7y05qDtx+J{=XZtoCG-IV;$-9irLAHC8N22KNba<;jcJ~t0Xw2+%b z+O%|yDN$r-I=g7rH(Q-m=N|~f3aI0yDv#?6ziXbsTm2B77Gx3UzR{2a)t_Oh4%@wW zZ+B7ms{JFzzOjGu@PovnWJ;}$YNW+MLZui@9ShV)>2TgXx(x$?e*_L~Y?aB4$0tn# zrtEtGbvjqt5hl6N8Letyh&!EXeds`{u8sl~H~-Cc)pb=xxRa1d4SG>Ph_!85JqkTs zq{I1}-TV9A+d5%cg@7?i_ulTF9MBNu(CMlb=tg^i`_ja~RNh|}#(6v`jlyE}3%66@ zAYG>8CdjiEy1rXUn~0WQb_2BXB<85%z?AbzOlTj6Tqg*@10_zSKrM}B(zh3U?$-ra z2Z*x5H8rEsl{Bqbo)3@)E3UmFgZ%_*Mi-ety%i} zlgdS~f9+8Bo>{$Ij;dH*0lrAJwPcbW0=MRv>&u1*M>2HPZ#7kW!?L^y3D3BPYI%i}jUy@4t%QBBKD-Noqq{FDxsu8AVJ$xx-i>%J z`j!OsaK@seXR9E?v3>C739v5jfPEw(;gQOS#s(YB0% z`j=1yApFr68KzY%^EWGQ)ctD>Few!b3!@-bETfwzF2hFPQoUbR z!GN-P)L`&8PtxB!1%HbHT3>4;WC5uYeb!f4yM`naX>k+HO_mHW70ay{F@-U;w#K&X z)Gi?lo}##b=bPq>-2nc*kaiSk0O8ADhJ`2z66&wf(G2bY@0uQX?O_!H*VPH2G@)se z%1FbgFfUk$-vZ)6EZE&ms?YnpC`L@w4>eJ&dLSx-AGfKd%?ApD4N1N|!~`VJmlUcSP|?G==VoZ{$;U3$CSpWP9aP7pO>9 zmN`!Jl~jl7Ohc&HAPzxyltBI=CgCP{uFp{yN1U!120Sm5X2>!?`0L-C@E|PsK7ld7 z!Er4xG16t$COgXg&|yG#G0CWcUs@u!tV*0V{7dt08NzA$9-vP;0~IJh6Ly5$cUl(_ zZ=XKhl0fKfSa74?#0?!j019xRSm4U%P$_#YJ)FlNM89U=0|>wIR}*GHG*2F3`_w_# zooRH;yPP#cie~Gl%cKWR4=uY7g-uq^(@Q8ch$?0eAB7;Xt+d9mt(59F_CrcEn^!e2 zXxbrW6tpZymQ|{2F}kB4(p67C`I*VlG{Ox1qsu(F$g%#~R9>$3hqQC0E`OG&)7s+k zTfOZ_=V8SyCnVfbppIETnn-Rlt1dbQH;Z2mTSWZ7C=K$q4Z(3yfw**P+)nNUNdnEP z2Q}{bYu_i@Z5$JuAa^J1(x(Y{v^_fy6d-)wpXn&Vb8xh;*6>Yn>ZlJ6dR%eB-ziPL zJj4H0AgN{!J2Ic&)zrg<6(tmf0abGU23M;k3a6Eb{#New zU>_}{MCB*IA?(H^W$hvghIEhoAG3-7{6SLwg58I_j|iY3GbMz z00Lh`T~)()+tZ$bEUXx4Q~lx5XK2KPkP8-8Vt!N1 zFBG5I^skwuRaac;vi-3X_kawHbx^6@Opt18qRZ01;J;mUJV){QAr$mdcjMZo8!&vx zx}NUS8&Ej*u$mWtHMj_cjO(7Qic zwiw@491qSboi2+pG<4KgAY2k&$I`apR*&t}ucOzhQ-Co4y;tU)qVAZUUsr>V?YP+J zkL@>fOE>qs{ci5p3>{%Ko{nj5_WHO#B4o1hP&bz78k_Y!^k@N>22hFse+)c|Z-X}# zRKrS=-hDN0J4`&%p2ryoAiU$#5#qc4AW}A{!!Qfg`V4P9o#(MeQ*KUTIvfe3h)Ub? z0znetyaINz(}9CV_N<)F2U|v*@=3nqjJ*j{USHi?TgBwSAHegdGv~3um+Ym(Xhi^| zW6#uHy;f4tvqd9MQJ-a5dz?E52%qy*{*jrU!Qm8@_UwGDrKTJvICFer14GdmFKVne zqe<%hqpeIbdYrpl(k+dA(*qqI=vs)U8Q zDH$MK`NBH6)cJ?6EDZ74B&#BP>+H(*-;(jL5BiFUk#e`0A2ER9?Z{4{ZY`N1hT9`) z6ETKiPAht3i99JoqT%exvFnZ$pmF+63#Y|sXm(!o@`tdc&D*m&`?ySr0O60lBNF8_ z(k0fU%D0m&G1*`xU)QoFhB_$*%YrHYVyv5F+XOMqL4TR;)ma(bC~=yRI5GIl(3$Hk zm4k}PG#yi{@+D?&5u;b$B#|W%VocT8kO_WoJ+=edGkrMxA(&{T)wAoxZo&bjHS zlVfV?)lz&&3C5Y4CP&}m2}uU)6$cU&Mt;A^bC1sNm&SUH%VOo2Gj)Cp%>0Z0I)%oZ zo#t+XC+b@vH7|OuQzSH;m_GMpW4`K?j+0f*$?0>CNywN+Tq203h>HWnlXN>deSYGJ zrdy(iQZ7U)zchWm76b$k{`pUC!*F+75sovkwpAohWJ9EZv(sl!h_ynF6BGAEq$np#=(ht|h0DTe4i|=M;?_j;Nn^Uw3z9L7tMNn# z2uYdWy1&TH4bqAcD0FYN$9C)QDx=?$IN05H+QTg#*4n-zO+#Z34G+!8M@4CV*c`O= zfQZp~a*AMXa9j_UWQ{MA&y5VBoekYPfpkTj2Yqt?>kPRS*5T_J5X|VyElp<&L*B#A zmtj7Q{4X zOI`fym9e<$R-UQo$gSl0@&TwUq+X(u9#-ou$fnlxVs2YLNZ^C+{^%^uUXIzoIQHb2v1THk(WhmRmrtWCC&iduvu#I8|4}d3HHtup@g!c792opBxBBx)_YxNZ`0m3i6zxDk23Efaqua{z(uI?W6JJOU-Jx|}3qW$RoJR%*I zgQ?1c7bkeq+n-t6wdnB7B%|-`U)tM4WVq0J=A7rUuq#jto@&*P08H)KBr}LP*Vlx? zlZ;(24*JUQ^1|8QYX(O=42Q+}7a{`?zVnMrXzw7GFOgLlXwVOZSO7o7=w+cTUziL&6Rz z!vn;K6lR_rHaJI2gg~Gg!-Eutc~n5GU_6`^TJGHKd1-GAo6J(nxutL^pr=<}ncwd* ztZ{&__OojQ(Cw~!ybS%a`NDMw3NF4l96&(#fb#x*BujSL@M}BXB4e%iqK#2)lbbl) zD4}F*k&Fg$^2~1SEA2~K&GW;xgNmELw>RpgPy&Xs=$2DkpPQI?`4L~BOiFc-lCqKTa~nBNU>-~Kp|aModK)Y9az5;%bl7&y#TJNDXVY_JS@4%*if?I zD~(awugVt9jBrL8lSS;O?(mJJD{9Ts$}6wHWPr@Qan+_s_>=)11VhIlrUTGwK9!-_ zQ@4C3a#M)V!2}|8ICWl6;5b#a-iFWAW*dHVOdFhw%_bz>%H{!Y99Pz87{J5oudWkg zGpJ*x1j^s$x^QN94IuoZdxtK2rVLo=)ymyD<*Bf}{1}b)#m4{;cBI(d7{xIit|>|P z2e&k~#0BFfAAa&y^h~ld*e~3FMM^X_2@qzF=|&G+QfgdZyR@yQPC}tN7$9NH7BCd_ z9LUT`I|@Sib;wjpc5Ev+1}As4GJ@US2iset(LR=+)&*Lsc)ALIV(t_zu+!L&wit`T z2vU)YU5f|xb9)1=POa2NXN}Cx zqDm)~Uvq_e6J;)q?$^vn({_``0SG^OIvBKy)gG9wYhKA&yBoZ9yo4D2;Qj>1wwh6IzFSW< zMNe~gynnDJd-rf5?Jg2VD%m1U!yzY?*pi}4gTzRR-1tf6Di}83@GuLM5bl~zqRGUt zwKBc0dXtPpB_^3+@?K70A6fbI9m;P=O&V}BIW9yVZ)R=fit5*q?l$o(J4vn4D0J#& zxDZl3?V(X22^;kbAx1_V@g59Pd_K`)DJlTMJN{Fih5Wr)s1y#Lgcv$FTVID>u1B$MVnlqPqgf$+?f`nsI64#$L3`EGZ0#okRwl)0%Pku&lDw+T> z9_me7M|Nv|Bdt{YRJ*rk=PTj2Ifyz^aaj{csUoku^43$ob^85vZa}u$EdGA6%C%hX zXc3>}-rV8*;DrzTVjN-Rt*AR*d4;FTlCp~7t+ci!I-RL~y^1E$6p7N#Id$l=t z;nKA=vJ4FRiG|#~tHB%Z8gq|*M5{*>(4m)m>UaP0fBoD?t%3foAA<)=y1S%-jxxUo z74(2gm>X}VrXP`^sjf|KYOi0Io;>?Rir_)*^?9jepGboYZIfR#*Tb+y{+GWYoo-TL zKbcO~S)D3HGAihkvq9A-I)epc8{IK{`%5pPygomD?#V{{`>uhW{f#HmK)>LTOaDDR z@n{XSHt{UCW;9gJ*FmzzgZba1UYh(6q1Y>m>60|gkJkq$O)r?R|EKzoRN~4;2uCE9 zbDd?A{yMssmKt@m4BtKktxkgwv&-Ptv*s3gRV^jGav`Z|=27}lL3Ey^r^xwpH9e^6 ztDiw#DI8nUjK^C>REg*@rmTOhRQLelU;NXKmPrgsQsdXD%b>=zuJbg9T(pkIt06fE zo_p@hf5tyYaEjnGW&)B5y~8pX14d@72BCGuzVJ zx41n+s)laIc6>y&)gF3&h49*|Zo7l3NoZtpFD^iK70Fj#R;}=WU?gsB$Ub4@jo+35 zaeWu#=6Z^9R|ZW*W6GuoL&{h>y*pfywzrCCjToo&2A?{;+j}rv$Mj&4)SIqfjJkzw z9T^@#e0+IoRH(Mij50+`VBXd4C@f8Rol0l% z;kcrH7v%uLcYR&R8bx9_u}YK}Zd&Q*rDhaa@NO3?>}6! zWP^nUY#>AHjkyze>pI0CscM$X$Wq|JTIWVptmgGc+ytcp`X zVA<{6UEN?!i^C0q1`z({N005b4jCkeeO8ln^CZOKD;|re(dO|)9|j51ir0C;QoJyJ zc{258M_Sds8J^$XN;X5-&(dfUIGKygjiHLGw^u=?gw|xVs||W!NHAUifjgAoHDS5x z^pMeobjWk~vdzo_qSlgQ;jJ1?uknX9Dyn^IH4w{$4#W4DG9xqDXf>s#H0LinzdEOr z$4>bCBp!(oGUZVS1F-XL$LdNEgrts5jOOG;7@y@Fs_vRywZ*8?gaU*w_+%=MRFD|+ zvM9w$Q?`J$F_`s1VbmfhqeHn)25Xdfu&@IUQ;P@#m4v{0Ccd|{YNu+R4^TXBmZHnb zcu+5Atxt{NuI$mRwlvV0!44Pq?njV4^wqEY?bOFwR{+Ah|M4zb46C{vxgjB0`4+II zE7zFlBNNOA^T04;VUiqOIEqN97L?Vw)%5jg0s?Yip>oT>Hx6`z8=tJh;V(m+b6D4v zEJ9l9f!4FwOTe7QmVX}8i%~lHwneO0c**V`>~$>-zV*~+|L;GmoLLewmgV}AoLm0V zUw-K&ix%H@8m#jhWS8z1jx5-EIpOxu4PcS&AN62Sde@XGRm?cjLly&0bd4x%@#MM8 zQrEJ&HmY5Ow^GvD-L?L%zHxol8UY$vY6-?x{v?yrQ`rxt(EysJ&h0%V)Ud}*POVxP z;>nu-N@w-JVO)z}L)ggn;8cC7W_7pZ3)MttUGd~Ph5hCh&mwU=q7K>@Lf*q;>Z_X~^VbnH7=m4738GeU$)0{lydwX@d=!XjX{X!+8rIQ2#i{|Wy(DRu|VJGPf51lB%Xv! zU{~+@7a+r%q1;nRrOFj7wcZck1}>Z2J_HE&e?#{+wxq5VwP?&2KIw8{597S{s5zdY zy|x;YQyd)#~t1YQ*2kmbbHcUlp~T3_?gIStxke2ruAq}L+f_#&Cvk_ zECWLq458&oo^hj5i5gbBH0I8g0j}IkcNP(r0O6P4%!-r@-Q$`bJE3E&Ttmm#LywgD z<#4jsU%1@n6+$69v#)SyoBTqhs8eubbq6L0xCWFlKUV8orXoNBIc?$w=HVr+@Mg#N zNo?E4OLSAt@bYis=_UaL^%cWkc1!u;|J5YERCwyDLEQ(j+Cwh89aYy57PwhaYn?)9 zm>8$FB1O!vISDLYzB{{zss#T}E0PvCP1UR;DF{Y0n`g4zx*WeYoy-WXdwsXZ1;@S^ zFfkU~8bd4cQUCD47Cj+eK<9PEMoV7+(6#w_qy?hA7BDT_L4e~=Tc2ma1vEgTAQd5W zhJX8%UlReoxqYwId+VupeEuidu~O~D@sX&-Q@{I7Z+!i)`uLc5E8v~paQH#%p&33z zbZa2_h2#zkY!D^vMRa>rAP`ujE7p`2@9eRIGg&K+cqwQ3M62~e?N;E5v{92BN#xK- z^srP+G@FX&r*U>ns-~)9!vlyZ@ApMP0K_vg(|TuLk?R@fpdtr_PXJw7RPp*EZ2SF7 z8wdod0jm6!ci}6Lp5rwvR=D-d6pzqNA1+cy2YfU?88p)kA{jy?BAf?06-96O+HMa8 z@1A%T>9xoJKp^b`Gz4{1^&k^I@2{ z1$7RS#y1{CWnD$!Kni(PKQlGSa1IvdV$gnoLsI8ZZWp)(KJ_2I{anm(>a4rg^D>vI zv+nug4&FzE@T>OOaBMdqg7J6a0i6|U_RSvd!<{+h7>(k-)m91*tu_z$I;_0WsOi%M ztnOYqEK=Zkogmv`MPema$yZA1+?Yh0QIMWc7#QK9UhMw%E|8&ztCyGO2zgyucGA=; z*Yq~~N%zc-vx!%C&_tEJp{HnV?|kfgyf^;YkI=G#ZKi8Hc4D6?r=5`ItpU`vj~G^9 zv1)gkPfnjb`$RshR?r4Rko2S{--TZ9G4!2R)!c4(c5kcjSB14}_}p@d zx2_OpZ+z#EKWH7z`(I~cV!D%sXF9^5Wj<>b7oxP)=R0eARt=XiKR7 z>gb9_Q1f`=lGX*{f^M~VG&d?P?sd48_W&9$9uy#4Y;(KO!EHrf1_MlOZaOdbB2=}X zkX=i~mTjJSq-XG;2G;mkab*HfX3C~pHfIz_{tw$S?0uKF@p&$fPHL*5 zzV_()fbROWt9T51hHK_LRj6-$nCnzd%*jvI-X2`SDB{m_*6%8v(7*eFRyIGQ^%ch| z?Qh{+%LM`XNUmK-PKb%zbMbagnsA*Io+F%3{3R+*i%`Z@ISdy*xpphSwS)cM0ifK& zOZes1%HBa&Zq_24@vIJm?DPwF3}ehS0^5i0Tfx^^hYuqWm4~F8oy+%!OH)x`1M!Xn z)vF-t3lJWD&RsyP?uUmOKvijzb1}HCkuep=(yW)2F2t;AwsGfm2yp>!<2JQ*g_7)V zUdv!aQdYg!+%V_#1%J`euQgxN-Lt85x^FM3P-^VCFLh@CW?nVO>~qK6mPQ=kwI+r~ zd9wGnh{@OD6clLhk5F*vIe_ple*un=0%9;YX)PtGtdZKwigqhu82)zps-fa2na6*o zJhbt%)(Hu%)Jy8XN8Ua272!|oNa3oT8XR2dI7sAyxyzgEq;!^#iJ)mxbS7sJF|=If z$>ow_ZZw|(=oRti#u7mI&h0{QwhvbdJ!!198ZoFJ$Vgl56=;cSlwj~&PPwq`;Y$+p zsJVSOvnT%$NR=LGdA2TC=k*d?GLX{fce^NCxmg;`2T@=u0~Mr8Jz4RFPeHm+)EQ+L!At!bIFLX&bp#^s<}Q@ zM~{xh(y2&c47MP3IisLgmexaFZ&jO3D4h4QD+{%avH;ffxSc|wO z(#Hu$gPI(MUsbi&TRL`4(KW?3WnJ0?p*)s3g>}F|SxcLh9Xi?o3_$pquT|9oK9TXV zY(-r^*b`@#!CIXcJc;wNBBMIpOH(X_6#5!Nb9rLdr*RETs2Y`th}%G{N5Cl4ldmRv z^w-+yY#hb?rOI-kBswe0{kWXHNEl)$D3=Cv10ej9{~&tpDT&%vGMoMCOJ^*8oWM~x z4Z6O5_s1TLJxtIngsdDPNr&K7Vn)XtoMG_v$cm5G{Y)jEx4W)uUlP3+J)UkobN|7^ z7Wq@3QPz3=r7Q&#)73VxZ*y=+=GsPtRh`4`KHS-!4JZKNzxd6lpZ={zeW7Z|`I;KV zj$CYDAGFCQ?p&d%jA2`Mp_DF3e|MqvFwLjxuDs`M`Cii2ROPaBSAOClO+8{rXC@61 zfba!hA7FuR#ZJ3mt<{lnlxqXq)hMt+JcJ+4Se3hOB70T*!4p6-d!-c~w#~KW5ce&T zeAkp2D2%G!(zhlAV&Ac|OaC&r7~QQ{fsN?KPc}3__;Y{P{1N2W6a!q*#;h~=<~oQ? zX5~8RQYTblDn)X{%;}5Q>MN?NF#M9e1=1GC`H>_ajFq<^!<|nrL7tC5j%i1VfxZvu z_0Gp~We#K*pS^>s+0n_?M->13vCz5=4)#eTksviTWQzR&2tV^#7~CrQ73x1h+WY6cXe{k`sCv2Yk{^f0QNcD@mn2=|;_fyBklMXe_`K*vV ze(cqVWfcqk4xLV&=rqWceXA%|GRO~DARGpB{5PTU1>%*O1+lkgNE_5ZJwJW63=$w* z`s#YcdS^uq6t)jQI}P{di4vI44S(G%aL?g_n@wlZx|D^m|eZaCs1Nq|gWie>9 zBD2nJPj(7l8u5o-PwtGAzxd|z($MmanH7%yXB;g!G(@O6a$}^-5`Gclcd)&IlK(c$ zMAW#5Q=zLoKRGe=f~o}K>LxAUvChR^II!gQFUr983}w%{EGmlrb3yp6*pnNBjY)*Y za|s;PmX|JF8NR+aJv20a*yGDoe484MmDjJe2UEkA()6SA;qGu?fq$*?!>c&WtDS@H z+Hi#oJlX*h-u3=|FF$3?^|ap|4zy4k{heO?%I);sjtgWQp;CW`d&k#?jV7vgu#TsC z!WCZct#98QE*QgueS$1%7^80YhZENDL$b(l;Eo4D{9mFZ#u-X%^z^7gBR%Th?FncL z0vgMGeNnX2{!vJ+!{`znHVGwNS?AYWOW)Vo<(8L&a zneB~LzLc+%yyoeLc6vjsh1;KMAFhhQltlcfPFS|81NEt<&yER$hlj8`_W6OTES_Ge zKLwYe;6szuYmZTb&}dY4dMLtMHKcTQ-`QH@5NC7j>eC}L=kt;DBA$P&fMHEp?SAVg z8pAwcjEq)*di1auNnj8QfK3wUvx{UWl;|$E$JKN-^|0`(4xC3ozeQPTSdse=)}CQy zCdc~Sy;zWO`?z_?kkBZIgTsjh1;26o+i1_aHr8B#@CSZwqZKct&`_iWh;mk-O*<)O z1g`J;GEjCEE;f*fq-4ZYta;ws!U9RS8iByE@s69Lx~B2gS6E2$;Eitae1hk9w$L=U zIsK7!g&dP(uZ?%mp{w2`?=yj;V12R=_f*6xCdyq{T?eaMo-zh&We^F>27#)sws%uk z0O9eI4=g9BXXN-w*6TX&U%9z*b!axe3=x1wagkfRH4|J<364~qHiFPOdT28@%{JZf))oZE zSwe=Gc)%?q50$t~Y6G2Me|58y^L8a9^7N*(*Z^VeryDeGVBL+1-OlaaF$*5FaJtp# z8ElLt5dCx?Zr)V&xVC${isn9oOs2j;KMJDvw2NqTTF0a|=Sfto+71u%zG2G!IznV3 zq&5J;>Z_)AA~jmu{?4Nozpn)efVXw0I0b*$GLJ$ z`V@e0@2(v1hK*C4Mp-+lafu#5f1jrY2|8`V4jEITX`TY7IbP%0GawNsQSFm!fmtv- z^;(@iUFZEC42_AB&bM|~y1AE~i9>!Yt%@q)zraws?4H$(H6kGi;breG?p2)TsiCe& zv@AMu-COOq6xTQNs|(AQUthR%aaasOZYxdZxaN>~XilZmc{e$h0H$X_4=2VFzb3?; z^pA85PK*U(7cC3_G}{lORBrd=n|h`t{W8OR@5C$oryP7{=7Mt)A9NhW&6Lk)dYtnU zWBsxj!l$^Rj+qyTG63P)cgNX4+Xrjr4PZG0dDql%;3;$zO>=6mtAJkWf!;}%D4H-p zRhgLCruO=}moYPhZ<1|^3p7zCVgPZ-tCkY}lB=ri5`>Jd9*QP>!^PArOvy3L zqO5<sW7O4Qu>L3)FH3yvhcIxGfYuVf71NoKX9fuq48x?hxUxaBrN2Y+U5gk>S8epF9x5 zX=ZNXIdKcwkx@-S>SBn>W=a9Tc^XeMOvYR5`^enV8dZVgyh;@~bX;LlZ1bnzdTcHC zf~4w7=`@}aPpt)<=U1r1!82h=3M*?4dSGLNY%XqB4OM-gJ3h@p&eiGtR3N z9R$GXeW$<9-rLwZG(2!TWJA#**Mb9JT)mL{{KmejF!Q{^46v(&SHk^hfzfM3&%_WO zQg2Hf<4=BM9n3W^gqJmFqO4Y;Ern+vnEt@_e>oOldWaD}!72pwpRja5ox;O{fDWn` zC&%5*q*3d+*7*6C&dbALT_xcEUpzMv1@5eFhYKU&2)HWhn5YDN+wYUK)>h8bXE`hT zceXb7@gPUUy@+oeRugdO;_h}2wE!f4e|qRTJ|&r&u)Xm(i)}AAf#>nnI~U9Ifc!$| zpzr_@LH!o0ln+RRxP^22FDOX@4$a1$`96DzE&o)bQK_6`IhDPX$i@6bx+)btmkmYclKK^ z#+XE@>T|A*p)TFFq0SgB*4b;Y?jvPbq(KUGf`s4L^Ptv7zsE9j+f&(Ht+QiO8prl7 zK72X;%U`U7MrQlVRjyJQtspK#zuqt%;LqwDbUBgS$3$FOcYz_j7lv zBQgoMa#_Bz#P4_soEimT;@%zN4=M*%mS#t)0%_AOZXIsvq6+vQ>1udttxG(H>AHCN z`o-aR$*+Y=udiHEp{!-#!OY4f(o$UFnijnU2>-*wOTb`dCLi@zuU+RffTUfyIFpYB zeN8F_YWeH(!V)>k`Jt0z`F((J?%GxT0NH3PohSO5Dym&;4%AqpD_?STk=N#z82ROk zm)fgf$(p6`J=q&U7JQB^`wtIma*d&?^{KIyOIPW=3|n6;RS+H!2ohgOJ1+2@PBF6uk!B=k5!c4OcsaKVYamRB=xw?Sa>ZR&qV6P^abqSZRqd ziVw{$h8kR1YH&6b*SN$Z0P829rb{JPy|XM!zO?Er6uR+pQHtyQmLK^wZG{nViP!v4 zAG7Iud9kFY^zR3$W^OAt^tudiZ*V{g95<;r-Ca{>yCT3roK z_P>px;}r1p)x-90{bm!E+9&Ft>tl!Hby%8qTmz4>EVEEx^(qt!W5Iz#wENWAI6$X# zpjjKxm^P(LC$Zlo#G^cJACjjWZlSG3+0+`1NN9QXCvyXNp=8NU4NTEMeoTD^Ue(Rj za<1!IHTah_s0^{%OLCXxmjx9{ha~mPFB9l-u}-7GPc6T-Jwk2jFWV*b_RFl{&OdyVzV2;fKe{V10L2*2_vkSxjy+j8M}NNGKst&mS8`}by-hJ}L(?|62R_fqFJGNM?Q{1d)cKX2$QK=}4=tcv&!W{`Ge#ZTgt6owdwcQAs7IfB zo42t~#Fp2f`Ds+9;-)CH_%9S@sF4U@+z>NM@J3($J$9E;WD(rv{uYJ}ddJ3U2w-fo>ey(Ok7LLwv_ zZAfzaiyzD-r%t0f*3xco)055YW&*IPYeZx3tbIM^oD*$S6!?h=oUaK5=V@ zoW1b1>$>D3%?p*r#yzog%CjL^6Ph91T3T#hkKMeqh}^x$B&+@3=&suSse*StbvChR z)$4HT!pR^n0EA!q_RvhbY}Q7@ThykJmw1pWXu)YXzi!l#9Q}x?vw$eoV*Y8awLRCC znjFaMgZy|RWFsvRC&U`?m*u~`)tB~1pu7hQEv7iOX-EXr%~;J;SU9Fzp1@(%CU;YJ z9{$F+l)YWl4^PsisX*4r(yjn&c2ELyP4m$lPrS4)L_@2+Oih@ZjYWc8ZVWb`gHJL{ z0ojnb--j|idYAy=6A!XBBohr_cXX`z<>SU`LfDoC*ei%a;Q&n?R57dSTD6u~>4#wxwx+@a?}Sl66n|V;E9wI*cUKY1$%>rBw1TjB<|B7R@h@;%q|~4the;>pH59 z-KC3=+=JWz3(e7Px*2mEP?6AAJ|N_%w0?Jn-C@wms)=0g_5%Z1n^?GD<*g}y1Bxb8 zinE5+^2t|FDcS)D|MY*;`BWe5v6!tcYW84Hs1A~|Q%8aFk#JE6mG{RC6^`j-vmwjC z6uH}$F6vPM3}JOF)Y+*s(qbBo(&507f-Vrn*Vx$198<2~hh1`JuBg|;EuzqYq-{?C z${Ke4tRM~$?v5}yOOP2*%%^9y`zx)%X_(8%(>T%ebPT{?S87Pa3I0SNqg?K+zzqIp z0AvjI3E`C#j^>Vx>Y3Y{i@A>yu-B=IC$p=asNvyJx{V`A~z^#d7P-!A`Z}dC{ zR<-fJ9bf?~`q0tx1~LvwhW7h_6qrQ((sa>!;@SoJWcOQ(mZV=D0 zt2Dz|JCgFGyP*hHPSFu4u>it{|2W4o9gB?-H&Ix2<#!1Um-Xd43WnqEAR@83piG*V zwdd9qwWFN0JP$UAhMe@uYSz620>g{M-0qCu9*1G)R1>G;G~$-#?sgum?ZO|7j58U6 z@a}0i%E!^__d4qetLPo8j$Br0x&8_c0gWtfglfp7<`0ka2140h8A7qTHb)#?sSvIQMzJ?TV&TJ+F>9 z5LP|wJwn6Bx(^R~RGE%Wg+ekzM=T)oh+4D=PaMEPG!zw|%C?fJvHt$u{=<$>tA<5X zQ_y~lAYYvcoM+1770hYUfC5mRXhs)ZKUJdoArG+}nKYh{5lWNFicT64Sqqh72#%o# z2*3Hw*{~M$3{%v35e);@972^gx+n#UXDr%2S6 z@y*B;^!g0ArK#?9&UEf~*2yka?faU(;c5Pchc%Vynwlbz(H>(z`kQB-A701)a4ys3 z6>WJkOT_(UN+X9>Ii#J~CBgHnc*w?P5bZm55H4Ey!;kOXqsQRdjl&F8Xd7pLpzPS$ zp#4b%&Je0I`Aq!n@{~29;mLSPFyY~gk7q28;VIL=kLM}V%LXq%Ffm&_NkbBLD-JF5 z05{A}7LZi@P(I&%*w*BUtWl^K%7I>_XQ(YjmT;Q<u3Mk-2o<33JO-a(oqad zCUXZ`Z{||t2+C~C(WKc(4fnYDnDV4yU=xE`XlTft{ZqLN{^q~2hWymi1WHIn?iU!F{*Qlh1#OK2CsIZU z4z{}-7kIyPTS^|dD!alk@lFf)8;4uZ1riCWhGnOe@PX1Osrgsj+0{3fS6Z`|TJx6) zpNH7pYF)WD_r7prKn*3^mRl1;KdJi-9OrO-F*kp!g#iU~k`P`UaUrmC4-{F@l%U_* zAyYVRK0U$}U8E3a{i<-kl7~Obb*GnpF&o0Up+7UT?eU7V(c#6ShMc2SQgOlnD zFZdA&)vwPu;d(rL!TmGYH;Nu8%rjC4RbD+f&}74MSZulH+bqxi)*5rDO@J$jmoCi< z#8#Us4U96nT)e!r@_s#4LKi<|vQC*XHKlT)cegq6+Kp83hso zrV5D`?U$`Z5?nWmZK(!j!4d{`QtMBSvseWuYz60(fRvX45+748(}JB)i|J;EQixF~ zf_3rgtk7xs@|RsQ%!Z{f-;?*{t=4O(+==Mt-?U~>AifhHrKbm**GWyF&!t5^mli`I zNVLW7ZBFX9p8DKBa23u`>P^iuS=MG#emMxoFPm`u#8)sl@B5Sl<>KiwZ+1-Grba;r zSL|ftONz^gz!RcpFd3Ctjw9Q=S@msGme&u+JY_RN3b%<~F~*&*8LA%B>p=dMiRtq% zwuCM>Kl7-&8VBbarY@p%==p>|pCh0uhO$yw0VO#x-_ZmtS64p-73g7%6!%|2DAeBM>2Jf{CTqETd!0O9GNjKFE^_fh4yBxsEwsh(G)k{}J<>IB%Q)%-#UeW1JuFfo~ zrFebVYwh*2Nr(onTwY$Bzr1jHnbdc5iPAGG-Z|*({vi&L8R~8L#!0x{iX;%1Uk3>9 z{%4W6E*gj}<=%6~wE7FPdVYIlclYi=Pg9Hcn5;A-Y{IKO&Qx|$JRfQ4rY#&&$YRY= z*SU{iK{=aZQlxM$XckkxpZGx%=n#o!eMJ|Ok-SAk_H{)sT=Cj+&CZFp0V1F*6mc6P z6W7c)dwVrd;o2Q{n_P?pBLLx-|D7|B;O}YYOHE6+PHuN1ZBwZ79nY9^o}`wqA(9Gf zxmeM1FXn$#rYRM_C=(U{Al>jk($$KWcgPDM@u9P^OfDPNX%@P|mn^wk9`V);o$ICMK(R!7`2HXj)wU({Pt?DUZ>Tt46m}?lLu=`5MiC zu!z!D{s1T%KvCYLJcYs^V|18Km2iN|KN!^tS6+2c>>ogvS)Z9h?nd-80gv>>OR3z# zuBvzL>q;;Qaot_RV}4s#a7MUz`63#ho@oJqMf!D7IDw>a=-U-U<<;o5!6$+r%n5)AfBuiq9&AH3^pkLiD;jjM9~5FwP>Wv~UsiFw zdQ+;2c}8_G#}}ajbI-60#3{Hes*=#CZT*s%H#>z8#=uy@UaSeXuP<7Pz>_KrM1H-r z7`rIF#MU&#x(G=9RHaXUxy(GKHnawII78z*7tsba&Gr>ro=< zpYWfNS`v`R-2Tq%FgU2J)w{#6Otxjz;1ODnGCB@>S3?;_mvxbrkKWEn*QdSe$e7!{g!ngc;?-T8TG|Sqk7IwR5Oi?!N&=cFr zxjoQVesDp;76KUNy@N7T;NU(6L0E4eY)`PY$M6HT zl!&91QR*DzbKsb zgwO>HG3CI5f+vTz5e!-19GS#WP(oWr&j(~=Gj|L~u|#kEG2z)QeyQ+b@7ZT2$u`Pm zQX*y~vC`W#HRvX^FHKyuvA5H^#IQ5>(q6o}(vQ?Ld|Q)uz$oPPz3)XZ9hcPUe(A>b zxPFPe=5D{xNS_OC`9AF~&b)pJhB-ClN{#lWw92J!HHxT~M$#h%rx;B`yyPYdQ+Ny= zAhiGOETe5-Cj0c#{LI{?s9Sz&1f#B!n#nprJsV@yv>l3i?eWdHN@^~ES|Zz5 z&_fZw1U}1galRFCF&z+zl(9!0xXf#@5d^;L-UM{H7&|I4GOf%pTqjEvlCX5Ums@wZ zlGenpiYjC+B05Z$q^)(p@)Fe{n0WQA?&dDzd`)$@dym>%+VsLXskQ-8loemxR^eyqpIKu<(Mz92 z;5p;Eks#`&HxkR{%wUnNa%k8lI~tF3fhnUQ7dS_`E$WO3B=Xg@e?$(ReYcJ zxiAH{i{vODy4sXs2wiRH50gpd3G|04(@&(Wo|=4gy6e)bFZin`33}WGf2C#`ue7{i z&}Xmvo@O!K)U@dSXdCzS{q>_U_7eRD%z%0!a|>wUX>c@ zMi+I`I_j~dEAv^Y1m}C4KI!F_oLjhxA~h!^E17Wy6fXebtNtPSsnF>(#`d2@Z6XdY zDGAKTXDGx$bj#`klq^1TI1U}(329(c`<1f5XA^`UtciqUt{9b#L~x8M9PsAHeUwZq zDcsHj5(07?Yh1nq4}$;C?N-5Xmxi`@*8zml8}Mp^s#zrXrXh9R6}@nmYrRq20o37H zo7|u*s3fBY^C>1Uh1ac&D;#^$OF-H3G~pWBPy_Mt`4P9wBM>Oix=Dw1r$!=xzHj}; zu5MmJ6*dxc=O#mCsi0m00LzAatM?d~jR-uJ`G^9>?&c|^yieAPo>fFv1vhnnUDjQNTH!;TodtrOxW?T_h z`48k{>)`)>myfNb-v)qV60be+z#>56V*G`wm6l81&`VmmvB3CaAOHPiPebvw8GOPER5$$Am1Zr z?Nh!oFcQaC%%T9{Fa6vjE6XOEE`&*D&65|Z4(jDj4+&M77t0+JxQU!(fPNHzu>5$d z<_u!>#m;8atch^O@*fQ=Oxy&_(@K*MO<;Zr`sZw(qt*5 zTdv09W<$6kvgEwkOB03GJ3cWpYB2cEA(o^`JI}HbHcMcs-FkpGQKx%jYhxeXMAq>R z7`GxTrPz%{Se*s(|Gh~vfCX*~9J~N{MuWz#Fg)}IH@sb4y}h+Q@p7wtpR9eyO39^` zGNitYDv{%3)=F=HnSKF;S9+VF8$rNgV?YeC4$FPo%_wGn#b2#Q^v?%iw@D zX}}~oJcLOsz$A5yam$d}-Lr+3e^QzS-}ey9Fl2-uSQ4(ps2dFj;hI+k1rA#QcwCo6 z_)Q$x^0<;^EHAXc`*q5e$K@+F1&VJY>s(#!86#l|#7yn1-p^0U z`(9^beo^mPD60Y};b+Y|ieMoYS7xu+@96@P5{LBV{^s1BgYI2<-_U?AW!~&HJ)yX# z3HNR-lQ2q3w-==?(;{Qg-rf~Mj4P71@9hJ{EpGk^9Jg@*hq(}cxFb`)*j+oJ&o8cA z!--6eS7)wVAz6Wyx79Ttg^YD}+RN`>zPzBjVC1Kv&mPWa{M*~f3E^+) z98bmMD4$Z)kbuTneY9~k;SD_fHw1)FJuLq4tF7lQ+an&O6FeeYU2UO1M}?Gq=21yS z(oT+hoD)cG&3g2Axu!#C*&h$1X|?|~tqRTaEuiNFuVs0L-xHA#>wtd5SAirbUhvFB zy^>a~g05E={bdGZB5>%~vbROs`R+R1-2?I+X=6+C!!C!LqHtroFg}2=!rdmye1tBq zMrskgq#qf^<}TZs9dhVdU<(1yYzEG3skp?@f4{TPx&{Qo1vZwEmJbdgwD6iHX3c!chKo6v|rDQ zLDoX35J32bMQ=E3o%)+#Jz5(nKHaq%e~Pe5GLHbptVbz8Y2_#r2)Q1E)Rths^}g;#|9 zQZ~>sY=3q5)D_ZW!i1mwRQ-`hYMMzUa>XX)YSOC~3t%p`B-+N2#zEe8t?;WVg!lMH z%3{@fCc?C)rboOL*v-+@)TfeSwGy`)6`mww{rF4E}*z z=J;|>qL{=LN)Y+4Oc$g72QQUX_jwLlzMLf`fWIg;P$^D%n)LIjbE&|&sVP0-%?p!N z$!DhUQ$45W_E^en7mwfrtq|7boe$N57YVe+Qw4lr`?h&6eC@N2T3VS8yTs7+ z`wFboGUFxAcoDKP0hC5mk95aEjYDh8CHUA|CSnK=0m6@nEo?1|sv$0;W7a|Erb4e< zG_#ma%6$_U1VQQ)jj$z+E8;PgBuVb??12Ejd53w#On6KWd;4NARnClNo05T2#b5p8 z0gql?#(~xiAPA?54Ze&{8y9H^gq^PR5*Vub>!#c4JE?CgBm)Rnz67Y60WzkAxf=6s zFu^_2{on55T(F^_pw*4l2P^=sX9^o@;xkm50gT7c6I4NzXZbk$P=Q1$wmY53K(xAj zPmRz9CBwBuDrHe03$F^aaPa21gD$C^PEIEq zf&fm6=aUNBA=~0&^Wf#Q<+@0fhGNd_XNZ?^D0GOLAeIpgvbjhqgwu z=8YCt)U=x8Dn%>T?m!Q+1`K_jTDo^qy~S%#&oVuogP|0-#TIU6loW=QRPUf1&+Wu zOjK!^3?CK%K0}cMX3Sv21#kyeGJ5kE+E8$qnHVm}Y|=cs(PBl?v{w^sxY}ok>(sjK zcEIZNxsm4(wu3HezYVt6Zaf$T2p@V0pM6;~?UbPJ+DwGqF-O!X46+ddp7y=n5`%AT zw3t<2=jc1;)92D$-2c5dZ?&M+P-*BUL*yS(R!Fyh#_xC#bk@^wDbZw;_$cY0BJ}yO zK7AI%^*$g*0)%h^uLWnB|hGjI;HF&rA+o`eZdrdKI|=}}$sMsi6F|9Q^HqL0uB&ZB*%ms2ZbUbJkZ z{p`($ewwb;eWMBSgX)c;(4&lhiiB}*XiAZ-JPvok4}kE)oWm}wb(ac&Urltv##%SA z4%xCvsrdY2Zh_h%I=nAitQ>b<81aS@K~j8&7NKUG25*a;rNK!J|leW%yNgL_QnHCrFPMlE- ztdtv0?E}5q8!;SSkdv+0u3XuzsUXc>gO~~tupKcna^sTaUv4R#`|H~WeI-#oa3R>niCOeTSeM%X(LbQ(h>o-`c^}HbS&{Nk)T-LGJIu`VPK_<`T4? z;VYY#fh|clMFk+si}XYQ;Y*&*$|6=a8AA*}DX?V40Hp`IVvErjvnf=UpD{(&SPXx7 z!tj*KNEGF^abP^_=%@|Y&?-N-7nZnRf@`*+1(&`@UWJNq#7|Y0-wvT)UZ>*Eni?#v6 z5B)724vn>^5X@Iix)-f7Bk5(Oa}{S?aWoQPE-445H5fWlQ*DXQ_V!WLQ~^@yq*O^e z*@8*j+af0dO8sb4yG;&9ySEj z!Nvf>FWlvTp<$(d8)z`dxDi0z9oH?Vk4)mgL~I}oCk!q2SabV28%%6cwnezIBPHe19>I=H)iI3&Ae?!i zz)YWNAr1r;40|{YAeeeH6wjX^+KB=1(=f-1qVyfOGWmSnwj3uq;BVlh17QQtZ4V#H zTY{mDo~1OQJ(0SwvGvNxJ!lmZ6A+}#L@*C1tmSz`B0j~~P5#`HFi9-{gt2d^b+5C2 z^7+#w_<&<^(?a~6t^135t8hc+kI)d4D@FP7 zxy*vBe62nq?=8!qnFAM^0)(&ne=Qql;oj1o1Vl4fcq78NTj4INKoGu|rr%o&0D0`f zFhT){D-V6Mn4Qi}krf)y^KlXi8y9dnHnBcO4U_@KKVy^{wU1k!D`%zJkLUJb2?S|* z7m7<4+xV>7lEP&bApFXE#L*A&@L1mjQWoy@3gX}ER7IW-_k;3t=t$iz|n z6~_Z|DHIe<3zQ3;egBSapD3-JM(7R)2CA3t1LcYz9~T#=BSw%}v1I24Qb;;4lai<| z#z1-{O7Ou5l7>hw)s;5>s?~Q)Ui`C!AAs;5zZxeCiR8zL?apxiD)|qGhEA=Z+gsb+ z^(n`~?RA($HayUx+xY*QI~Ul>v%9{J2(4n8TZ9logfzW7y9xGq{G8XWXJ>Z&+;zvV z*q(i4m`$#IuVL6bApG)2BLkF7^^NC3ULGy^wM5nH)STH}u_=c=R0=(A-n5=1IaIdc8gT{i ziE%)FPM;(Vqt=oNITPd0$fj6Mf5v{=HV&`W^nmmV7+kpLR6G09x#b&UV@wCkj4>Y7 zq6|Rz%?Y8;p%GxLs=iBN7@XMXZ&#}AMOSsA6{L>K(@)3CW3#O}w7z=zGKY#mkMclG zLXla`rEElP_Vf8=dBM$#dbMuD+OZ_`j-Xn)Fu<#2H>hIPpkYCi3xBlD*(BTXR`Vb= z+#9|F=`wj=P^7QovuhzCwF=XvT~>0%wf$|FA*!*$yHOfRyo4PSfQxhm^(9>R6$H%d zx2Ngm1DoYL2ZS7+(7~X8VJpxpxlt7Kp#SvmsRclmo+;-Qkf;?4R!CJ$vcyP*1S$0j zApEm`wGGGta{sYX)l3M4u`qNLq||7Dr>Q>M1g-bWI8>9aHHe3u z9p;%6zXa7vma8CKTAP_&;jrLw*Az3P$vlf*Dj=loTdK&Sy(KRuIZTLC+-vPKQT6>I zf*3QWiwKcSf-bY$6Ez|(8IH_uvqSFM0qWN`*KzQ}jk2TBgbPdxu5m4qB_y>bOI92+ zja{6D`V-D|YHF0{H@L6W>%>F|JmfS;*$+_@6Ec}>1Kij< zz)~lyRBJo+D3KCcwdG1fIqbSGP@KU7?a}6K^Xt?sVMs|q>p0DTM6-mvW*(Bf+yKJU zpPZdpn&Zoy*=5SLNfg=Oxe<%7+s0l}SLBxq1_bp$Crve5fYjnVYJpe-&O((QISvHd zprk*@1aUzY6b_D~ee!wAO-+Q_K6)&x?a(M2yfZ^*g~rf7w3%Vh%%qLEH}vH&kp>9w z{bYA&`#LyK-K+%2f+8*LHE!<0YZQwjE!hIv5z>qsdaN$UMJmA^kS~lwsqPr8+fqM+ zR>tE5tBQ^~HAJyF{P;M;RV$zBw;y@8F7Z?_&j1*LPvUr0Ky-xv%HPj%b69M9oJ-`mWAx7kjKYVJ_~XxTl$08s|OCv5cG1 zDNup`Bp6mRnjyyzNOueCA@)#38s&`O`!Pq7T6F_8f67&}yQDU zXGUT=3B5()wSVw+wptPexOkXx$h^2*T8OawP( z97f%IB(Wzzw#f1i=d65TL=SN@QiHF@>DzGGb{>CR6%Fyo1w1INIJ$sAtm_z4NWs=V z@k0s{Kx@}yO%eK9=GqI46Of^!hAc4)3QeW+XG@rFdw7cwEFc~Nb?%Ej>aU)`1)GND z{0_s#%yd1uhy3P}mx&<-8gE0kP?+skw8@u2u5+_NC2CtlM6~DIx-~}#vCm@yM!i_f zcI)=^_mpshVnh=cz0TH-_64snkcgqQ^mUA>Z%RQ?SA0J;8dxt?Qt$&gdjQ_sqShG* z4lQViWT1u-1@=z2ye>%6jQ{nIFLnuF z!riy)t}1z7i%6Mx!wen`Ue@rMd;x7J!jt!1t>CE;{pBXknXz={w(8Jj2Re4<@UdjBS{D}?!U@Tg6`gpyLR zr6VA5DY7wYgR`Y)W^7SzX^NFRTLMK8f_A{dLi&oQ1qd5YnsE>s6e(sK==W^08Ms45 zm=nQPnlFc_K4;TzVO7Ko%E~{AIyxW}2DiM_p*tzECm2Hi4TdS6afOqS-DM(wrh~_DkfegBj$v_r%iP2M%%zi z0#FbLOl6FG5U88FSvWbPNO6;c!kRv>?7WjHQgQcL=*pYhUG zMgGsp$(oGJM6$UC6zGUqzy?5iVe_0)r%zT-A5}bB_p(v7)?`)85;VbeG-@@d1>1fH z2=tBG0FlX>%-Bmv=u|a=QS6u1)9WXGz-G{7Et|zz?Pd*Q1(_-ccvNQK2M9m?4;cXC z`I>!GAVT5S2)!3VwF~BwUGy3B)hgoZB6FHTtC1dffcIEx(8>;l3tkl~oxq`+%}s*k zW!-C_Kjl^)iI#QB(;%J)rSrL(3-HjXF7VTyjXj$qik@f8F@o>ROhXT$60{(KA- za(D!IvM{o|5p^?E)uok*qg$cJ0O6m!$+~@PORTysAvHXjh8e!)Lz~$rx}gjUu3^sP zZj742z*%+7klhMEfbz_~AVe|>XLB~H;588~K1tb!e>5iYB*(#07JZ805;@IncM|zVPBqZ7<@yxYRz5?DwDU_ zp>ry|9;&hMj-bNAIifQkKsA3T#S}xG9NxO+T52EEi(E?>j~-w=-kEcGdVEe1i2%ZX zeaq_j1fh&qm(83cXs(Yc5c6uQhJ*HF6sI@V+ExwM2Iu>cKpNYw7-NEUg5dJfs>17f zOTnD5{C#m|W@Q@reYE!J?8x-|#I>2{F(YWQ@+PG5=**Fsex5EXlsa=RtjKdrR_?!q z^fY;qnN&OPmFHu`DT_saI-F%R%R=~?^4PIMpPF5{iuTRj(mKE6;z6X0(?%5KNzwUz zdj1+ipW&8YSzi?nZQb+DO)osV`dpDS8WNTJw6Gi$eC>NDzT|uU57)FVN%U=N42D9% zFp#y?n%b~tVcQ1RSRI5q|I#;}HqYYk-nMPOGY8xHYjH1**H4DqKyeYqZT09N<#X^u zYVnuNmt#>iY+2emb+>S;d}nLsOWjg{9;b|$bvlY=pQ~Z ze6S7zMW7nLpvCrR*eir&Si)gNrxOxt4Ei%PtKHJi+c23A(Norg2FrJL2Bw9baP(;89;A*2_)C^^hKKRqd>zY$~kt8Q`L;A-O{4}-UyX|dwzwZnygZ>4lobY z15()H-05?ibIEpng#xfcl^)+cN{*_|z8`Ym^{7y|mu}Zv8^LeZ)Rq^ki&Uwh6ZWH( z$I=yJPBMwPx39bJVylPu=)}y5hT&ed?&hZOs)}HMuO@mRYoP)Vo|x#lwy-old39=) zuZn$hZAx+KK?1o~;MY2dj)EQpvh0q%jB}fCvl-oz?29rST0HuQU`8&B1YF{Q6wV|% zhx)}m7TPty*MVuE7Ul9+uAp|WT7T7E61!t21DFSIZb;ha4yHKaO4A4@=yR&BBuapB ziAkbb`|ZYy@NuK(0mA#f6;V}@uJH77(XtaCzWDf{zc8kQB4ZEw%E*B&5G`cpPsBwAd8DjO9?w=qsL z&Bpdk*kZN9-JmIvsze}Ldq*^nnopH}Wyb#4ZUahGZplRD~3XG{KT%=c|>H)CDQU(ZvXQDz+ zXFrL2-HuzL6BL?II`gBI6NgR%QJ9e{s{3=CI7Sy7RV)T3)npPPY}?t+25Rmc=&j7P z4ptZ*Qr}fjADa$N=F7zd&N<&Tx0q zjpajQ!SkmzFXs^2b6_y5H-TM6Ctyzr%_2G~6;GUYJk-nYHTJ~j(%j&5f)J<|oAuaf zMsURd0?qUu$QM`VCjlW0JLMpEEGPh4fd-Z=yGYzDuVI><8*A)eMr#4WZ~UqR3M!GW z6F10$1*sbaEq@Bw(Bb?j5a}4eD9n{g^IIv1uvZ~^p@^q({Fg7!O$}~aBDw*G;0%gV zgJ4k4sbb+}bT;xOCEXe22sDdVI7>F{P>QQss$9xv#7jUo-(2zm0fcMUyBeI}2#30# zMJ$6RMz*=(gUUC|5_yTblcYrP5y3M@NS?0xM%ag7CZD=&+8x_OG-MG#AMV&qC}|F} zK)=Pl{ovi0LEMCKAkyEN?O;*`fC0k4JFg%!(U%#@g+y|_wIj#)nmA(};7yuoC+i@S zW6yyGjhlJ9j2qlnt=JVsO5$x?#8Z^03t@)Uos(U1?S#D_j!VFnK31g50Iw;Z&CRxG zGhiW0xwQQ3c08n3m_17MRV-Ll=48@ZSBqe1q(Ig!fbg-Ot5tDw+cO)rK(m$4SHCW< zGv(U~t`&$&JT86%+mQxBe@*fXm*P0gEFyb0#scalc7c+?M$#u|FHgG0_N2*`)}-x6 z@N8UJ-5T_|iIxRC2qln~U|1;zCiFD6Zk(6(tUhBQyVVruzO$}AKNu)%^Dn=Tc@%G~ zp8EB2S_5_|gFNU$)zixufV+39%|wW0nEJtKaQLWmdK?>;bc|H0W?)yMQx9R+h>eF}}yScH){3r&~{rtJv7QDON~}P+>64+mclg*Cj@z=8h@8 zgL};2CCoRw>}e2obEEd+zrqlh7`k0DC6IlH%%R6Vnp+sAt+3N-!R~nkLvFUxJ{&xS zN|TD=T;?wCS+~hyCP+)HvUYVycw^c>17FdQSHuYnX_n@|cpX!K8+G=z0%6(2{agE} z@oLD08D_8Rp^d{G$hb9y7Q3~{4VY*9XxBQDm0iR(5YH`uFx^y9>T=$HPuFpZBKc*V z*ts3B=htx6ZU<;fa?p#U&aj?FUp{MUbm$_<@OJdyW=s+Ie3UlGtYqj)=*6iW zyt&=!0yQYOkVvEmm2~~iYDxrdWX*{79UbnBg9dh*1yK|R7zj&=Pz6{=GBYRB$4_1p z=PilGQK*|rrRps={836!EH}^Qt6sGQIb$CH)*zWeNR59 ztpvENsr%}I@>Y-61C@u%n{gV*mnZ|oVf|#rX!t|9Ow(&SBBHH$e0}*8qX*EXyW7#0`$lAVEWshvERO6wH0Ab)8@~*wd zD#N_(sOHkxsq3gbCxf}esRdxG3K8_VOJZsY2%Vg4?IRiy6V6eYc)=n9UZmn;>S}Mw zUl>jV{Iq^dBlN=(Lt;4XVh+BvA}7t{K!;c}iJ&89b8$$Z4iLWg*Mhf_upusOKbF<# zAZiBow%t9uH_mpt=!;;r`;FaZAXVq^Pm}@I$-i5kcaA!_fR?Wk`xfHwUS&j?C7th# z3voqego1WEHlj7j_#_|~QjQ>vx8?!DJ3bz4 zh9v7_J_?6|MDC0F-|FYCB{D{tcW?T7x~dTcQW?S7F)tzNS^_K6<6}VfdMT+Gaw*hN z*LfiOvi~DWc5Lz|Eu-k}pL zB9Xe~=AUS1aX=?Vq+*nX3n>QSFme=OI6q=WQ2#X5;chYydb#0>@nBCk^6TlzB{w z?4O+TklpN4wsO+eB6Cwe>_WO!NXMmO9vx`gfHO%-t_3TDv~qpN60uP}#KSjrF)xgv zi5lXRr1B9yN0mndn%0pw&$cCZQ`6cgHrnX0_1G;??F74tDUX>yD3?YM`rSBCZ*?C=oz*PX0U@r z*Weuz+22u67-z8aQ|Ov5ql5KPsl-Caq(mM?wU%H5Ok)Y2)Hb2AhR(dI{yI z<|wd6L@GML(V7rII3-g(1|xW3+MJ?#-l31Hex{S3&drv`yi%rhL-x! zpXkCMCEHzBrCLKHClla33o{{{71e-FVe{0RfQo-o_NK*OLfvNo!Z*K?<#>#+aA}WZ z7shtt%u{`;#Vl_zkYz2vp61pF6C?}G994?0b;FZbF}$Zn71m%{ zB-Q}SOvlar^>v&lwa1v)!gzm(nt@Ib)u9D6$+SOlN#My5mJfuKoB-i{Kjrulr%G4F z=9c(k_o8S;gJg$ewN%ZNGVY(9N}%=KDMnw2B8asjk6mYut%p)WmwW^y%R6}k3aJ+$LUo(5W{~egyW623)NoFcDhOxq(@5zu%9d9LgEeYGI0VZdP9~% zFHWE^AFQ>vPQ3c<|E<@r9(e4H7ppHyk*@SX?x5E_rW|AmD!6W5vr$PcK00cp!~M`9 z4B%kpA}Gi90>(+ZiSnat^}|gxW-NqrQgz;}eToA6OOr6_h>W=GXFc3jo{WBU?~aA$ z&r9aUJ{AxEtXUV0VCyqFcJ_R{1)x#eM=99A&y4P^if4xW>Qa$;3r`d7N}v?D_m>~N zkX@EjD!FuP7g`?67S|n|u||hw33V<7@Gq5|L<)(Kv^SaxhUopnx>JY?(Zf{-SwVWs zMzHSMB;bmzk*wJVQRnx}YDq|SDo$S$vfQ|d$+q3{kw<h2-`9*aLjz5U$TD@nrwKIq6r%9k+SJf`e&Z&T50XZ;NV73`m4gP}TEG8N< zA%I@7urV#hmD=RZ$+DL&)%V-GJ@XT@P#F8eVB|c(YKMC+a`RN}7Tyc`SBiIQ#VnO$ zvDrAgMp*gz~$hssWUg460CFv-@ZIOR}mn_h&sa$6!K#AX0x>xJX&z@ z5Q)?sLMs5_{2!K}HP$m+5&Q%%JyYR|Dhv}bW;BYeBk#yq&){ZL7jh3SC@Vlab?Ov8 zb+G6BFZ!4~rrbK5&hG8D5Q@t38%q~aZc`f?7${t+sOMunbhHP&TUZ&_Alfnm5WBLC zp)M6ey67p+G|eW)JoQ=+=a)G5MC7N0gf@~6xD5uSJRdvEI$?$={dmvFX@KzCKUAfe z_PbT4eS4Eo32X$`2)h?K-?g>FJ=}XdsTma~mKT+)Mc&%md1LGfECWh2uO2bh>TFk3 z!&s~#cGQv7E2a-hHe9vpvEJmmqGB9u0lrSc6cU3(9U@x^eXF`KAoF*t?&y930h7+2 zIX!B?l&K#&O_^=dS%C2Gzl)_6ySGjZ{5Zh82e?uaVpgLADq!~&9U85Va?{%7c%ymI z?3p-$*(ds|<6DJk1Sc)CMR3JzIYL1dvd)QUAoQ8mjZZey0qua~_~fwZh&c=Hm_;>zq+rA0EQ1Jq`n`8|xVz;gAsK%pKX?1p)hzJ8U$Li)~@9ptwFt ziOM>Nai+3D0FbY)-WP41?+}qTI5==dshKi?PQ8ef4Cb+o14XSe$TA%3NtDC! zR%6lHoL-pHmN*F$fdpNH8C+*y{1ihW0Jc`$SY-|`1*;JjB`q@@hAFD5%O+xuAfBIdqX% zW-a`e4H{M;CS}>M11$yt5PsqNt#u32-3fQ@QZ4dYwrY`7)TvAF%Hzc>R7vG5cBNjC zPgz1zXTH{YnhYX&T0ToE=Ub5(UAexHl;tx+-~wKTX2FtlK3I|hgrEPiysxD)Bi=%} z42eY>9sLlT4)ucs;61k>BE{&y@=c$@67Xw4d;~+V3X6c$oxqJaf%EGxM~=7_E6ha4auxb@Bo!kqmTM%2U03k&s8k?8 zdA{zQ_~J#s&7znz^RB4Xi{0VY*Zhou>w~Wob%!2R*TXgGBKxMcZbIA!rUt9ib(Gxo zaN0;$i2}xsJI1t6EbbC@Ub~7hXF7ku3npdxfJuMKgAeL(J6%xlG1c-ofx`!MeFJCM zn&OYDF+oaOlx@0$ZlXP4S30oYnn~y$4wJCI(Naq_y#SMqA!g)^2M4PQAw`GgHt)|v z6F#7LXl-Mj^|QMt{*rH!@^RAGS%+_JlCrzMJv1{kH}rgU15f~u+a^hOiyck4O?B3GF8+5Tz%r)dBCrUF)PyP@>##*RSkU-AT&PG+P)KB zd77{fvx`(w_DO)k$n7MyGg6(Onk5r37_olnVNJssku!)1)b(bAe^$nGyey-UZg`=I zm8DWX-a|K)kv9&~1|1#^zWka{--|D=E?I@EnP~3Gn#BaZ;n#97 zNY=cnsIFq5ZR^R%UUu<$?CEv;}Co;v#Py7TH3{{ zt?%$!!a1dZv2Xf{W+yUw?yR8E1s{e#THBH1&@i-s#*Nj`lV{bFZ^Q-p@T%i-^S6#& zP7o@%gYvON=MbGzN}IQBKLR$hn}8mt+Y%O~8T6DrD3eXhvXH?Z@13~1^JxT<6Q0C` z`?O`X4Thst2jYAG3qt3k)m}+&%8epu{I&Q0u%X?J*5S{CenM*4RyhV%q}wgINA%3t z$c65{f|XT-C?57-o92da+;%gmtD+5=TJ!BsUMwDTHAxBlEK6;*VzKsM{hj6)+Fy`#XIU)II6=?-QiTJbR=jO4|daH4?w%0`Vr@_ z%r6Qj0Aw{8s>ho*0vA@V_R6u#{BYRH%Q)dd05-P?@-Imohi^%ibg19op{r#GiJ)X) z%51q4zb9`J*ck&08}{HE-#zlw=u;PZM=m^tqpaU( zB(5LC=v&GM5I*n&pj}p(?WcnX0Ky)XJ&N3AuPf-XIW?u6yvH2cvh<}u%klCnSh`z% zc1i!How4*1Yf`V*^hFP8e+dcNv(uxt?ffN{O8Zs#Xj@jE5g@$2CvPu4!y70cKQVrT>@%d>t|@|c(9Iq(?t@>V+epD$ZazXzCQ1WT>~vHo9|eo z%G8KWRO?|qi3zoEEG9iG>aHsWm*t5aiSt(9%0SBt0357umHJ-MJe{^#0toN>1G7PB zYpOia-)*k6WE-1|h6^5a46|d1jc{>gVtIv{6<{i@l{EGwh(SSAU0hjlxeVD^77kzJ z=LLY(Omp*g z(ZECaGp~cmyvvXhxO)jpMJ%dzo@#942-Mn^$g)z|*xMNzm0Q zi<{MNU={V0$dPia5fF_tP-)5BzvY*uvXlJYymf}W{lLU&QK`B_=$s7s(zY)!(g0!O zJBhqP-ep!|3pv+rV(;|qEr?1}d$#0C=>=&6bIV^Gn@edd&?P4dLiExnvGyH_ZGnsx z0PwcLqnM$NzO}29TXh`|lq+zp%91g#hf0WVwtfJF7j9U)8P8$dv8+deM8ufsW?;P2 z3p{r-y-4kAFQDjy@!Xm{gKZm{5y(rlr%->7-&fM^Q$8tK!EjiLgD%#C0NC*$`Z^7GGe7Y;%? zAF*@Hf!~E<`1^@hzisF0`whZx9~5OwU#jDCtBVsatxiwOtqx8s+w0q|O<$XiFRQcj z)605^tD3Hc$Jl{{U`g25jlB_nLp22vprZ5=tI{4tCVn=>UGaGIDiw($LqU*=qo?4t z%5^w%ym$R{OfeYiWp+{DXtu6Hh@dhxJ+m@6WseHvjtjKjR%Yk< z(Z*tlJS#4XKCP@07-!y|2-f0-ol?oF1JYexy8{;u8C~CEg0e#ms-1UCem~Q5;^p7^ zT6U=F^e($Gi_zpyT<_SpZ1F4Gdr()1%Z}|t_RxL>^^&+AzGz~_@@qS>wRxqSvc7dC zEj%59cWP2j(fC*W{$0b3Pke;E#gxIu5kx;0+sNk#`LoRM6aseS>;U?rfhW&ZN6uqD zfgOZ4CCqU;#jr`O6f7DD&N4DGc5W2Y0+sNymCgqp;@ecN24%-nZOB@+FqtwZ%<;lgV*@b7x2#x=#*~dpJc7yin zOH0#MX+@VPJUhJ{6GkgDbE`|M@%2n)e06a?zMZYi&90lNPF_{OBPE?h*Kb$N%EMm+9j;7cV)V+={Hm*9 zmF8FAmVK|3d9;!_3|Z;X3un(%j2y)_xuTc9%FNw8d69kUlP-%=t-y#6&+gZD-RjgT z@Z1wKMK zo*(yHx~;mi6;COuSkjcIN=7U8o_!`*7SWkfhI18#&mtwuGGCNG&*Y~uDv*TX-}21( z?O=?r0iLhKYkmR3+kbZ@mOiJl zQ>$CvTW*`Yn6~O^*4fqRIY{2@RDm+o$h8}Z7nskoQX9?D;5L?d@ ztWP0`o+VhHJYiG`_^8nxXqw_`S%M>=Cj`T8<+JV-f$%J=b;#2^=$)lnuhhqdYxCNg zRxH&4W`Xzs!Z&>6s-;^0Jp7)$TlWG1oxD0D<>ce%y^FIelSTo@m!BQ6Wb0ANOR^2< zysv|pdwF^VDrET`7FcrIy;?>SFId&mb#uO|`Z*w=H;E`etos zw@gYb(ZbVVH_Np&(4fS2#cXiFX#Va0p>cUfQH*5d8nZT$@nIXYe ztG>CRa4HtVFYvQi5ny6F95exiA#nFXqoYP|;B58+k#=S&IFd)oVJa{N4f zdW*Xok&O>yQe4|sMBab(wb<6~vBtQwm3y4z$J-)MvO6r}8Mi}UxArbyo?ji@*}MC) z$}hAkhf>I8t{OIea4U@v0hF$_)6$ynE#~9$Wl)yaLC$^&F3(_|LG@XRd@y!zrwryG zQo@M{UHf8fsDN=G0iWzk?1jW(tQX~>hmLdr;otm)3?l7XJ8}d!0gkK6_w>{A{5xnx zHZdeMiKue&=?KOO<$J`4h$94?33Eu#0i1raKk1c9g*Y-KA8x?|22$uIlLx<;s zurKk?il{RSEj*L5KZA057YfEDmd52@F?&8d4*=nJK2VwrVoznm2Z1IPzzQ5@l0lh`=muEA+7L5yu%Y{-v_dHFg`bZ6j63&603& z*W`bg#p1af3E$xvOSzbU;c&H2Y*oK$iS)*tM51%TQyy+2p($he`wf7weVtzEqLE@` z5lYclNng@)H)^2SEFuhOx4BVyLqUEY0)gwO!u-{R_R9_JPQ8Sc5YdIcEX}=Uf(sCS z;-ei6JkV=Kb&n#tN6_0uyuAN?l`@^P;dCbY;A{)!3aw7Mm#B)M5;tUA_~dApZ-qw< z3?RJe=Z^Y#|MWB=Q^q<(O3glK@2`1I?%(3!9H0Ai0EBbjdOLKvV@}cnOLLdg3|m)5 zl{=QXf(_^|QtU%J(qFsH2q1jfpO!d;f-)qU$A)CvU$O1nZ|Cbo*$yh(rHu!qtC0pC zLsO66AX5c?iJDCpK=_rn+f(3XI=f#cq;ROmZB!GOrNEC97mceb5XkRw{LrD_+=#ee zMUKDOAKQ!oT}q2InQZYfkz~?@R;}BsEyrCz5!PWGTX};xVqdTrE=4Um!@u%3yk8cj z#Q8cwVxeVG3{EcL0s~jWHF(@%Qn#fJ!+_(dM#tuy9DS)pe(c4N;(FjiT2LG!%GDlU zq19j9ts3YO+#YC?0tg@aox{ZDK~oZ8w6j-17wuI?*1zVYQHZrC zG57a<%je^GU|>l{1AFshfj!zXDQ}gDEa!++rp%iDZdCagQtZCN9ftydu>1*--(1WB zPDM0Mgt0r(irMH%T#-kStD|TYOmiw~e4!X~5#1dlCu_iR2-mJS2w*UIIPzq`H=t;67R5`4kz!NIPniil({`}Bi}*qpYjeuq zVbzv)mLvAEQrFY|koKdr2OQbyQ~?i1A7=o<2fz10_k!c|rJW**=8DZix3mj#in)y_ zXP?^@h$oA)DaN_AzxoXXAl&O|1p-0;5{>vg@azELSN_ZG?t5ScSRVOH+u6~=kfU}5O6U8b36e7I-Ku|}jqXt} z?f~H@xfVKf!hRxUrg#M9N=dK1= zbM8<+#FrDspy+KxdKyVpBuZ?Z;~Ycudj*womwxU@tED=7Y%qJb0Ky;t`6jWJGU03K zs7w8c%Tm}K%3#Ne!~0}M z0Y`g*D2f3A!t4ITbMbF^03;aI$tUrM$xb!!5MuRd)M-}>r=GN9l?OzjLu{GX7*X-i z8*6L3R=v4f9kq=)lJ2Z~ErR*QSHtA?8Zza+K=(dBWu@EK9 z6n%y9Dz^2qU`L;ujf`ns-2#*?3Nha%e4Qd6lth;(DRT}^>}!q{^~}3eGRV5 z{w2hFt4VMjbb46oAW>f@Ij9&@8z)`msG-vr%mweOa1^^VNxNLlzF_4fskw#q3hrUGrqWf=E)n}!@c9dd9Eu!f4?bb-{avVL+z7;%e`jI=R_Z&qiKW+>C~4e+RxLIR0xm0Agz5cjcvDy08O=)-eXLDN$?DYz` zFO}ao9QQ?cc{`|~vBo|cEw{Xw(7xy*FOf3*gUlSAQ(**@4}`0%S-zblh-@hKSsh8c z9u?Yk-J%v2g*^zh!%@Ulx2#=mmQJRwu*Z${h1TBmc5DBpmc!TFT5jP%L@3A$7*aIW zkwZS$ItaQ_PnI2pQ5x@bpc&QPNLvtG$|DilnUS8UJ{9pREg*up%wS7EFdL$8$zz|; zio~XX7^!<8)_~uGZXqw^>?L6v;YVn>MwwGREMpOsyD1 zM@ET^I2z*p^y;n((B{$zPJT_Hn|%BvA0v^Gx3bFn zyRDcuaR6?&-<_&n6VCWmI`WG&zxgJMva)@kAVjeS{SwkvMkc!Lqm9lF`7haawBS;< zQzK8s%S;t)N#7uA^k9a8wRCGd!>!@v#T-zhs-w}##f9gWS4nd~vCmc3O0Az7wadi- z!k5p6ZWKMJuhok7wS9p}+;!_#F3<`KwS@&wWv#u3L?n*rl+07~*#jZTlgd8pT7>PJ zWNvL>dsgH=W4Y~87kyv=VjCO?2Z+UsoW#IW7X~dUwN8kz+PcrRP3h=47!O%02m<4i zqm>PwV__))NVJu3XQ;5joK0-*rM509IT2WL#LMP zg;TN76?f)kp~67>y@^d$1nalgtaEwp8^X%8uz6>#)O|fe4Q0oq+Yq0u)B(cZIq4sa zqLY4p_&jDD8$do8@BsPJoCIrClQWAjhAAk1Y+TsB3Y=_XrZQFEh0NfAc`!rYggc&iw_n#Tjl=Z!} zcVLvjsBm_H3p4g6y%}|~N<{kmD#`>W3wv$|0E5o2v*_1>M2qR$CZfWP3ZUT`C_yNB zuINeV(ysLrwDzslUV!k-NzQ#$ZW;E>z5Ljxkg78&MB@@{uVY~d#;%t8D)si|%RCGk zo?bF&r!=sgel*j&(>esKB5SeWo*VAA_hi8vcFgqAiRh&;t%eDP#JzV_N3Z_rdrY9y zXksv4%eDrMj^$3>+B-F>sHE)R8r^_l&35xtlNH=gPJr-R@6g>z!3-tr=df}hSK3Hz z4=qN#qp)r0*U~1RdcEFknZv;{YAe{UsdoATPYg6K**R)AOZT0N56=0d`~ewM!kKd$ zTSKHM&T1HjeGos-2m3w%N=#0qnw;T}Ko1!W4tiELfbfMoHkZD`aq(IE-408Lq}N(h zXF4Du4EF_*EmkagO2K-~3d)R(Htep8O`bgvbrUtA#0+)}-T{3kC$Jg1%jyj;iB|3O zYYgz{CYDfbJ5@_k@f#KOyeQ7sVQbYEOCn=V5l%rCB`6XR44+su`AYQF0}#IG4SB9h zrA%p@#$T{c1?+cj;u0c{NI;Q`6m6wqk+HZG&oS{(VW?*4T#zPlAM8y?1Wo7JIuU5d{Ib@ zQ#d132-ixK%CSb7Xs^g?lulz((qjXo8EH`p`&7tIglvp_(`qn?SQ(p*$JD`o{bPMJ z7##>g8Egu(FhP{88hHN*(gZ3?BvE5RR$=B{#ZZAyp2-dXB^&_==U-P!dF?NTW$EB% z$Ky2}23~tjN0(sVO=oReN~ML_R~&;&A8ip2bY$%ggm)d?_5*z}Aj~lJepL0Hio0+KTvHCm`Ufk2h4ikY+%Cse^P|OQej^Sdq;U^=9}g8om}6_yJsu~Z=R`3XpwPPrjvT2MtXeJD;Cj6P&3eWBlq5`Mw}{IVf-j?+y(~ zlo+q)XATO+!C0-nBZ!yLrw6mzd`%+>6ge=bnh56Tvv5rS2tWPx_ib6Uxl{UTWO!=D z4aJb*AuUVr(Mdu8%D5k0&G^udl?oBmy<_w?2!yAQ^5qKlF2n&K{Lg=RUmzTt0fJ-8 z&7u|=YaXL#c|_^GgI1NJgay%d@&Ag%b3rDCenXNJRU(bLDfduhBmYP4&}d;Nfu@Ta zE;j9ogGTivMWr`5S>su(T@cj18hC}kmd1sZ%$J1_yWj2nfm9+-qE@8orUoRml zA~rE;3MICWjv2-pnl>+@RMfjgO`D1@aqT##3GnQ(;i##CquTL)W#h-y@ECAu#KUQAyMspJiu5-HitVnLT(k^d-(P$yuW)@sF5rH(& z8y99caZB=4Az~LKf&vA)YaNRV$T$pEis~#34$~>Zro`JTRRR$H-lmY`MsbWK!=obQ zL2t*z3bb*v^@G^wI-g}YzZU!e2(8s}@$PSiADm%yMlj^GoBpS;DVQY}@;r>yRtBg65@eV#m23w(xK`qGUf&%p zK2UvN!q0x9T=2NJh!1HPt{Q!GR3lDeP~0%lD6nIqbVTf1k_ekBT0)vNJEw%xLd>Yw zRLYf5m&~5Pi3>pZ%UWLQr5R@ndZJWAF~=^`P(3=7nv>+P z1EY*be;@=%vkee_?{a!O>fyCenWO5+(<4H~K?Hp2!qMiXUi&i}P(%iUjYvjr3gN^} z%+im40v`VnG4>FENT2fUz$nyfo2~mo;B%NLfbiivT^oqA6$kNom@R`%m@U)!xB!O~ zM6_{Ao%(kbY;tv;1U}>sq90_N2^Cy-Y^X5c;-cOGQ$U@$01)2$qZiit2I`M+<#Kvi zYMD%({(*wUZZr^IB+}>`GNsAqpI-n7fBU^%G2w{Bh#)eC@sUOIpGV49iYqL*D}k(E z#!040le}9mn4KkjK}?kxMYmfb6Qz7RKwyH&h+7)Kasq@e{>IE->u>=VuNV{BQEi;X zxF2=dhElV>0d*G``}UVHF*3P&M2K0Ka2Zi_D=&bs_y>P=bEuVXQyk|=cVyi}0D#AP z0$`B_GOYEF6dUr|!y)JZ;pgim%y)b@10MsHG#zEx%p-#t7%L;#2BtSj{9uZf!}5nG zPA!Z@DS?cS3Bs%skO>K%IJG(^yN|uvS~xn#gSKGa-gy#OPBN+&WMZc=0)*3lzxu?f zmA+F?h7!uz+`1Hz-I)&>;4jz%m$4dSgFxyWuLqi2eM2;by8M)Wcs21ysGe$Mg=PR& zyCFF(HH|u?6~d1vPR)%)TWYs!kuhm=$$HRV#;#I*bkDAUms#2-F+{d%x`UOD zDWC{4MeDRgkJyh%R@qs2-NW+HQopY6IgmoOHmE3U2b)-QHSX%ZUThCA#3~PjhF2xD z^tuaN1Qg@^V&I_JPYR=>Z053UY2^lWjm)ILh(1@T5x9L+pHHyELeN!rY|{ z=^?Fmp=2M6EZ%GB7b0gdXi|~R%B^Qzs?OGh%Es5UGSy-zX5TRAV4Q9W!_=Z~GDBx2 zYFCG*@Gr@dHb47^84Fjir^-?BC9S+L3YJ3a=C>YNi)%8F%wSr>Tw+5MWAbF33oJ!( zBF!Yi5f)jVd`OwAdu&w03F8PuFio377nBP9juo5cP1sog*lPj^ANx8h6)C?_jm4`+ zj)Tl0tMn}h7NUyGZfy@V*ZUFY>H#6dl6#?HcBzR%`!o(#r&`s8#Z{wXc9(XT->6ck zvhsDeb{HKM?QyAc_0}dAB5Xk4Fd7X+4bVW=M9hjC-3|c4{99##DU#=UjYuR_6^U4c zavzG3jQS>eC2k=p@`?`0hLo6YyV8U}9Bb7z1QN2m#>>!wkzr)qO!(kpQ_U7c%`nrY zrCuh^HgCzsyqC=VoQ?F;Yo=!-Sc2<8MjF03Q{3N8n9xLw8N9|p15%5tBcI8#Py*R8C^7^9z@J_bu#&G6syiF z4S89C9hr@EmXyF0_ox!f(YjwKtkXn-ycR$~Y(2S;T-a7(w@A))fbjYz1Vys}7p6(x zF7|FCZUvWWi~A8t9&&2($XL?DL`1VBPwc;SN8e1anm3+F5QN6sbt%d_ZCw+~!xNBp9^F-HnZWT0m4sSR;W8@{EFf)+hW;1z!bL6m+Fq`a?}y6 z$ex4{nGwUVXp&^U4f&DWf@Zh2ynqsIo3&by^Z0mdZKo~Nwr^G8QDJ=5rko}AC(aVp z7%CDP9w>*r)!nz-pnx0-6ASd+pEX znv8KSc}!4?1T@c@KIUQ$5Wi^iMs}n&e*_zK0$>n5d~TKx0O5~*xpb7a7duZM#*as= za58Hk>G3toZYvyDyKIAis4r+OviJcLB7IN^&WJ_2Hne=NiJ3aAt89w`2tV)!5M4E} zn3Tmf27uV0N;KX&HMXWhSvybG8EFW6ocf+cu~_z_^cPWAnasXJXT;88#urVXEb$ z0tkQlHtTe1&jzy_6~O6Ss3HTlk3AlM_6FDK_;-~1==`$b2C+ixK_1qd&G>7xrB zQ@L*5ix{3a;X!1;X4YnlD_mI<9Fr01wUus8^$^pwW^j4jyh*TC4ntU=aSD>Rrn+uB zhazB_1PbTegqwjA-S%N(;beP^oL=M9be?1^2mJsD|L?02#>GwiaQ=czt~c*equR~1 zV%{{?^!N$)rVe-y>SAR=hru9t=UBa$;=CHZW-Xh7$F6>dvLB0 z4ON})hh=7#uu(YI=c6_=N;^z5cs>QUh_j9WS#f}H^M^tmR!M)gZcMnUs@_Ff$wp)x zs%jH_I51J6XN%S1eomkX+~$=@lw{j;Yx=d18tV~z?Z0oSB4=#hcARBpQ1jYWe^E(f zcsXHk4dE@{4vFE_!_25Zx~^PhC|c>c65jmxt!NBXbx-O@r6+cR(mksBU6dunN6UJ8 z@5Fch#HVpM>LHtj2@BQfr+?&PHC8_iC*0Fh`pA3y8XNalocal>lde>lispcore>sources>LLARITH.;2| 74517 |changes| |to:| (VARS LLARITHCOMS) |previous| |date:| "29-Dec-89 17:06:53" |{DSK}local>lde>lispcore>sources>LLARITH.;1|) ; Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. ; The following program was created in 1982 but has not been published ; within the meaning of the copyright law, is furnished under license, ; and may not be used, copied and/or disclosed except in accordance ; with the terms of said license. (PRETTYCOMPRINT LLARITHCOMS) (RPAQQ LLARITHCOMS ((COMS (* \; "OPCODES") (FNS IDIFFERENCE IGREATERP IQUOTIENT) (* |;;|  "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith") (FNS \\SLOWIPLUS2 \\SLOWPLUS2 \\SLOWIDIFFERENCE \\SLOWDIFFERENCE \\SLOWIGREATERP \\SLOWLLSH1 \\SLOWLLSH8 \\SLOWLOGAND2 \\SLOWLOGOR2 \\SLOWLOGXOR2 \\SLOWLRSH1 \\SLOWLRSH8 \\SLOWITIMES2 \\SLOWTIMES2 \\SLOWIQUOTIENT \\SLOWQUOTIENT)) (COMS (* \;  "IPLUS and IDIFFERENCE that smash result into their first arg") (FNS \\BOXIPLUS \\BOXIDIFFERENCE)) (* \; "subfunctions") (FNS \\MAKENUMBER) (FNS OVERFLOW) (INITVARS (\\OVERFLOW T)) (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) (MIN.FIXP -2147483648) (\\SIGNBIT 32768)) (FNS \\GETBASEFIXP \\PUTBASEFIXP \\PUTBASEFIXP.UFN) (EXPORT (DECLARE\: DONTCOPY (RECORDS FIXP) (CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767)) (* |;;| "Unbox changed to handle ratios") (MACROS .UNBOX. .NEGATE. .LLSH1. .LRSH1. .BOXIPLUS.))) (DECLARE\: DONTCOPY (MACROS OLD.UNBOX.)) (* |;;| "Eqp modified to be like =") (FNS EQP FIX IQUOTIENT IREMAINDER LLSH LRSH LSH RSH \\RSH) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS NBITS.OR.LESS .SUBSMALL. \\IQUOTREM)) (* \;  "Machine independent arithmetic functions") (* |;;| "MINUSP redefined in cmlarith ") (FNS MINUSP ILESSP IMINUS IPLUS ITIMES LOGAND LOGOR LOGXOR SUB1 ZEROP ADD1 GCD IEQP INTEGERLENGTH) (* |;;| "abs, difference, greaterp, plus, lessp, and times redefined in cmlarith. ") (* |;;| "quotient and minus modified to handle ratios") (* |;;| "remainder remains as is") (FNS ABS DIFFERENCE GREATERP PLUS QUOTIENT REMAINDER LESSP MINUS TIMES) (FNS FMINUS FREMAINDER) (FNS RANDSET RAND EXPT) (DECLARE\: DONTEVAL@LOAD DOCOPY (VARS (RANDSTATE) (\\TOL 9.9999925E-6))) (GLOBALVARS RANDSTATE \\TOL) (COMS (FNS |PutUnboxed| \\PUTFIXP \\PUTSWAPPEDFIXP \\HINUM \\LONUM) (EXPORT (DECLARE\: DONTCOPY (MACROS |PutUnboxed|)))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA MIN MAX IMIN IMAX FMIN FMAX TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS)) ) (* |;;| "ODDP redefined in cmlarith") (COMS (FNS POWEROFTWOP IMOD ODDP) (DECLARE\: DONTCOPY (MACROS .2^NP.))) (COMS (* \; "MIN and MAX") (FNS FLESSP FMAX FMIN GEQ IGEQ ILEQ IMAX IMIN LEQ MAX MIN) (DECLARE\: EVAL@COMPILE (ADDVARS (GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT)))) (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (LOCALVARS . T)))) (* \; "OPCODES") (DEFINEQ (idifference (lambda (x y) (* |lmm| "11-FEB-82 14:02") ((opcodes idifference) x y))) (igreaterp (lambda (x y) (* |lmm| "11-FEB-82 14:02") ((opcodes igreaterp) x y))) (iquotient (lambda (x y) (* |lmm| "11-FEB-82 14:02") ((opcodes iquotient) x y))) ) (* |;;| "\\slowplus2 \\slowdifference \\slowtimes2 \\slowquotient are redefined in cmlarith") (DEFINEQ (\\slowiplus2 (lambda (x y) (* \; "Edited 8-Apr-87 11:23 by jop") (\\callme 'iplus) (prog (hx lx hy ly signx) (.unbox. x hx lx (go retbig)) (.unbox. y hy ly (go retbig)) (setq signx (igreaterp hx max.pos.hinum)) (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") (setq lx (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)))) (cond ((and (eq signx (igreaterp hy max.pos.hinum)) (neq signx (igreaterp hx max.pos.hinum))) (* \;  "overflow occurs if X and Y are same sign, but result is opposite sign") (go retbig))) (return (\\makenumber hx lx)) retbig (return (\\bignum.plus x y))))) (\\slowplus2 (lambda (x y) (* \; "Edited 8-Apr-87 11:24 by jop") (* |;;| "UFN for PLUS Microcode generally handles the case of two args both FIXPs") (\\callme 'plus) (prog nil lp (return (cond ((or (floatp x) (floatp y)) (fplus x y)) ((not (fixp x)) (setq x (lisperror "NON-NUMERIC ARG" x t)) (go lp)) ((not (fixp y)) (setq y (lisperror "NON-NUMERIC ARG" y t)) (go lp)) (t (iplus x y))))))) (\\slowidifference (lambda (x y) (* \; "Edited 8-Apr-87 11:24 by jop") (\\callme 'idifference) (prog (hx lx hy ly signx) (.unbox. x hx lx (go retbig)) (.unbox. y hy ly (go retbig)) (* |;;|  "Allow this unboxing before the following test so that error checking will be performed on Y") (cond ((eq y 0) (return (\\makenumber hx lx)))) (.negate. hy ly) (setq signx (igreaterp hx max.pos.hinum)) (cond ((cond ((and (zerop ly) (eq hy \\signbit)) (* \;  "Y = -Y = Min.integer. Overflow occurs if X is positive") (setq hx (logxor hx hy)) (not signx)) (t (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") (setq lx (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)))) (* \;  "overflow occurs if X and Y are same sign, but result is opposite sign") (and (eq signx (igreaterp hy max.pos.hinum)) (neq signx (igreaterp hx max.pos.hinum))))) (go retbig))) (return (\\makenumber hx lx)) retbig (return (\\bignum.difference x y))))) (\\slowdifference (lambda (x y) (* \; "Edited 8-Apr-87 11:24 by jop") (* |;;| "UFN for DIFFERENCE Microcode generally handles the case of two args both FIXPs") (\\callme 'difference) (prog nil lp (return (cond ((or (floatp x) (floatp y)) (fdifference x y)) ((not (fixp x)) (setq x (lisperror "NON-NUMERIC ARG" x t)) (go lp)) ((not (fixp y)) (setq y (lisperror "NON-NUMERIC ARG" y t)) (go lp)) (t (idifference x y))))))) (\\slowigreaterp (lambda (x y) (* |lmm| "12-Apr-85 07:35") (\\callme 'igreaterp) (prog (hx lx hy ly) (.unbox. x hx lx (go retbig)) (.unbox. y hy ly (go retbig)) (return (cond ((eq hx hy) (igreaterp lx ly)) (t (igreaterp (logxor hx \\signbit) (logxor hy \\signbit))))) retbig (return (eq 1 (\\bignum.compare x y)))))) (\\slowllsh1 (lambda (x) (* |lmm| "13-OCT-82 15:27") (prog (lo hi) (.unbox. x hi lo) (return (\\makenumber (iplus (llsh (logand hi 32767) 1) (cond ((igreaterp lo 32767) 1) (t 0))) (llsh (logand lo 32767) 1)))))) (\\slowllsh8 (lambda (x) (* |lmm| "13-OCT-82 15:28") (prog (hi lo) (.unbox. x hi lo) (return (\\makenumber (iplus (llsh (logand hi 255) 8) (lrsh lo 8)) (llsh (logand lo 255) 8)))))) (\\slowlogand2 (lambda (x y) (* |lmm| "12-Apr-85 07:44") (\\callme 'logand) (prog (xh xl yh yl) (.unbox. x xh xl (go retbig)) (.unbox. y yh yl (go retbig)) (return (\\makenumber (logand xh yh) (logand xl yl))) retbig (return (\\bignum.logand x y))))) (\\slowlogor2 (lambda (x y) (* |lmm| "12-Apr-85 07:48") (\\callme 'logor) (prog (xh xl yh yl) (.unbox. x xh xl (go retbig)) (.unbox. y yh yl (go retbig)) (return (\\makenumber (logor xh yh) (logor xl yl))) retbig (return (\\bignum.logor x y))))) (\\slowlogxor2 (lambda (x y) (* |lmm| "12-Apr-85 07:51") (\\callme 'logxor) (prog (xh xl yh yl) (.unbox. x xh xl (go retbig)) (.unbox. y yh yl (go retbig)) (return (\\makenumber (logxor xh yh) (logxor xl yl))) retbig (return (\\bignum.logxor x y))))) (\\slowlrsh1 (lambda (x) (* |JonL| "27-Sep-84 22:59") (prog (hi lo) (.unbox. x hi lo) (return (\\makenumber (lrsh hi 1) (iplus (lrsh lo 1) (cond ((eq 0 (logand hi 1)) 0) (t 32768)))))))) (\\slowlrsh8 (lambda (x) (* |lmm| "13-OCT-82 15:29") (prog (hi lo) (.unbox. x hi lo) (return (\\makenumber (lrsh hi 8) (iplus (llsh (logand hi 255) 8) (lrsh lo 8))))))) (\\slowitimes2 (lambda (x y) (* \; "Edited 8-Apr-87 11:26 by jop") (\\callme 'itimes) (cond ((or (eq x 0) (eq y 0)) 0) (t (prog (hx hy lx ly sign (hr 0) (lr 0) carry) (.unbox. x hx lx (go retbig)) (.unbox. y hy ly (go retbig)) (cond ((igreaterp hx max.pos.hinum) (|if| (equal x min.fixp) |then| (go retbig)) (.negate. hx lx) (setq sign t))) (cond ((igreaterp hy max.pos.hinum) (|if| (equal y min.fixp) |then| (go retbig)) (.negate. hy ly) (setq sign (not sign)))) (cond ((neq hy 0) (cond ((neq hx 0) (go over))) (|swap| lx ly) (|swap| hx hy))) mlp (cond ((oddp (prog1 ly (setq ly (lrsh ly 1)))) (cond ((igreaterp lr (idifference max.small.integer lx)) (* \; "low parts overflow") (* \;  "make the low word be the less significant bits and return the carry.") (setq lr (idifference lr (idifference max.small.integer (sub1 lx)))) (setq carry 1)) (t (* \;  "no carry just add the low halves.") (setq lr (iplus lr lx)) (setq carry 0))) (* |;;| "the low order part of the answer has been set and CARRY is the numeric value of the carry from the low part either 0 or 1") (cond ((igreaterp (setq hr (iplus hr hx carry)) max.pos.hinum) (cond ((and (eq ly 0) sign (eq hr (add1 max.pos.hinum)) (eq lr 0)) (return min.fixp))) (go over))))) (cond ((zerop ly) (go ret))) (cond ((igeq hx (lrsh (add1 max.pos.hinum) 1)) (go overtest))) (.llsh1. hx lx) (go mlp) overtest (cond ((and (eq hx (lrsh (add1 max.pos.hinum) 1)) (zerop lx) sign (eq ly 1) (eq hr 0) (eq lr 0)) (* \; "odd special case") (return min.fixp))) over (go retbig) ret (cond (sign (.negate. hr lr))) (return (\\makenumber hr lr)) retbig (return (\\bignum.times x y))))))) (\\slowtimes2 (lambda (x y) (* |lmm| "21-Aug-84 16:22") (* ufn |for| times |Microcode| |generally| |handles| |the| |case| |of| |two|  |args| |both| fixp\s) (\\callme 'times) (prog nil lp (return (cond ((or (floatp x) (floatp y)) (ftimes x y)) ((not (fixp x)) (setq x (lisperror "NON-NUMERIC ARG" x t)) (go lp)) ((not (fixp y)) (setq y (lisperror "NON-NUMERIC ARG" y t)) (go lp)) (t (itimes x y))))))) (\\slowiquotient (lambda (x y) (* |lmm| " 2-Jul-84 17:12") (\\callme 'iquotient) (\\iquotrem x y x) x)) (\\slowquotient (lambda (x y) (* \; "Edited 8-Apr-87 11:26 by jop") (* |;;| "UFN for QUOTIENT Microcode generally handles the case of two args both FIXPs") (\\callme 'quotient) (prog nil lp (return (cond ((or (floatp x) (floatp y)) (fquotient x y)) ((not (fixp x)) (setq x (lisperror "NON-NUMERIC ARG" x t)) (go lp)) ((not (fixp y)) (setq y (lisperror "NON-NUMERIC ARG" y t)) (go lp)) (t (iquotient x y))))))) ) (* \; "IPLUS and IDIFFERENCE that smash result into their first arg") (DEFINEQ (\\boxiplus (lambda (x y) (* \; "Edited 8-Apr-87 11:27 by jop") (* |;;| "UFN for BOXIPLUS ipcode") (.boxiplus. x y))) (\\boxidifference (lambda (x y) (* \; "Edited 8-Apr-87 11:27 by jop") (prog ((hx (\\getbase x 0)) (lx (\\getbase x 1)) hy ly) (.unbox. y hy ly) (.negate. 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)))) ) (* \; "subfunctions") (DEFINEQ (\\makenumber (lambda (n0 n1) (* \; "Edited 8-Apr-87 11:28 by jop") (* |;;| "used as punt case for arith opcodes which create large numbers") (setq n1 (.coerce.to.smallposp. n1)) (selectc (setq n0 (.coerce.to.smallposp. n0)) (0 n1) (65535 (* \; "This is a word's worth of 1 bits") (\\vag2 |\\SmallNegHi| n1)) (|create| fixp hinum _ n0 lonum _ n1)))) ) (DEFINEQ (overflow (lambda (flg) (* |lmm:| 14-jan-76 1 6) (prog1 \\overflow (setq \\overflow (selectq flg (nil nil) (t t) 0))))) ) (RPAQ? \\OVERFLOW T) (DECLARE\: EVAL@COMPILE (RPAQQ MAX.SMALLP 65535) (RPAQQ MIN.SMALLP -65536) (RPAQQ MAX.FIXP 2147483647) (RPAQQ MIN.FIXP -2147483648) (RPAQQ \\SIGNBIT 32768) (CONSTANTS (MAX.SMALLP 65535) (MIN.SMALLP -65536) (MAX.FIXP 2147483647) (MIN.FIXP -2147483648) (\\SIGNBIT 32768)) ) (DEFINEQ (\\getbasefixp (lambda (base offst) (* |lmm| " 5-Jan-85 23:11") ((lambda (|\\NewBaseAddr|) (\\makenumber (\\getbase |\\NewBaseAddr| 0) (\\getbase |\\NewBaseAddr| 1))) (\\addbase base offst)))) (\\putbasefixp (lambda (base offst val) (* |lmm| " 5-Jan-85 23:16") (prog (hi lo) (.xunbox. val hi lo) (\\putbase base offst hi) (\\putbase base (add1 offst) lo) val (return val)))) (\\putbasefixp.ufn (lambda (base val offst) (* |lmm| " 5-Jan-85 23:25") (prog (hi lo) (.xunbox. val hi lo) (\\putbase base offst hi) (\\putbase base (add1 offst) lo) val (return val)))) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE\: DONTCOPY (DECLARE\: EVAL@COMPILE (BLOCKRECORD FIXP ((HINUM WORD) (LONUM WORD)) (CREATE (CREATECELL \\FIXP)) (TYPE? (EQ (NTYPX DATUM) \\FIXP))) ) (DECLARE\: EVAL@COMPILE (RPAQQ MAX.SMALL.INTEGER 65535) (RPAQQ MAX.POS.HINUM 32767) (CONSTANTS (MAX.SMALL.INTEGER 65535) (MAX.POS.HINUM 32767)) ) (DECLARE\: EVAL@COMPILE (PUTPROPS .UNBOX. MACRO (ARGS (LET ((ARG-FORM (CAR ARGS)) (HIGH-VAR (CADR ARGS)) (LOW-VAR (CADDR ARGS)) (BIGNUM-FORM (CADDDR ARGS))) `(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 'RATIO) (SETQ ,ARG-FORM (IQUOTIENT (CL::RATIO-NUMERATOR ,ARG-FORM) (CL::RATIO-DENOMINATOR ,ARG-FORM))) (GO UBLP)) ,@(COND (BIGNUM-FORM `(((CL:INTEGERP ,ARG-FORM) ,BIGNUM-FORM))) (T `(((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)))) ) ) (* "END EXPORTED DEFINITIONS") (DECLARE\: DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS OLD.UNBOX. MACRO ((V HV LV BIGNUMFORM) (PROG NIL UBLP (SELECTC (NTYPX V) (\\FIXP (SETQ HV (|ffetch| (FIXP HINUM) |of| V)) (SETQ LV (|ffetch| (FIXP LONUM) |of| V))) (\\SMALLP (COND ((ILEQ 0 V) (SETQ HV 0) (SETQ LV V)) (T (SETQ HV 65535) (SETQ LV (\\LOLOC V))))) (\\FLOATP (SETQ V (\\FIXP.FROM.FLOATP V)) (GO UBLP)) (|if| (TYPENAMEP V 'BIGNUM) |then| (|if| 'BIGNUMFORM |then| BIGNUMFORM |else| (SETQ V (\\LISPERROR V "ARG NOT FIXP" T)) (GO UBLP)) |else| (SETQ V (LISPERROR "NON-NUMERIC ARG" V T)) (GO UBLP)))))) ) ) (* |;;| "Eqp modified to be like =") (DEFINEQ (EQP (LAMBDA (X Y) (* \; "Edited 7-Dec-88 09:04 by jds") (COND ((EQ X Y) T) ((AND (FIXP X) (FIXP Y)) (IEQP X Y)) ((AND (OR (FLOATP X) (FIXP X)) (OR (FLOATP Y) (FIXP Y))) (FEQP X Y)) ((AND (NUMBERP X) (NUMBERP Y)) (= X Y)) (T (\\EXTENDED.EQP X Y))))) (fix (lambda (n) (* \; "Edited 8-Apr-87 11:30 by jop") (* |;;| "FIX compiles open") (iplus n 0))) (iquotient (lambda (x y) (* |lmm| "11-FEB-82 14:02") ((opcodes iquotient) x y))) (iremainder (lambda (x y) (* |edited:| "29-APR-82 05:01") (\\iquotrem x y nil y) y)) (llsh (lambda (x n) (* |lmm| "13-OCT-82 15:30") (cond ((igreaterp 0 n) (lrsh x (iminus n))) (t (prog (xhi xlo) (.unbox. x xhi xlo) (cond ((igreaterp n 31) (return 0))) (cond ((igreaterp n 15) (setq xhi xlo) (setq xlo 0) (setq n (idifference n 16)))) (cond ((igreaterp n 7) (setq xhi (iplus (llsh (logand xhi 255) 8) (lrsh xlo 8))) (setq xlo (llsh (logand xlo 255) 8)) (setq n (idifference n 8)))) (frptq n (setq xhi (logand xhi max.pos.hinum)) (.llsh1. xhi xlo)) (return (\\makenumber xhi xlo))))))) (lrsh (lambda (x n) (* \; "Edited 8-Apr-87 11:30 by jop") (* |;;|  "assumes case where n is constant and 8 or 1 handled in microcode or by \\SLOWLRSHn") (cond ((igreaterp 0 n) (llsh x (iminus n))) (t (prog (xhi xlo) (.unbox. x xhi xlo) (cond ((igreaterp n 31) (return 0))) (cond ((igreaterp n 15) (setq xlo xhi) (setq xhi 0) (setq n (idifference n 16)))) (cond ((igreaterp n 7) (setq xlo (iplus (lrsh xlo 8) (llsh (logand xhi 255) 8))) (setq xhi (lrsh xhi 8)) (setq n (idifference n 8)))) (frptq n (.lrsh1. xhi xlo)) (return (\\makenumber xhi xlo))))))) (LSH (LAMBDA (X N) (* \; "Edited 7-Apr-89 16:19 by jds") (* |;;| "Arithmetic left shift. Since this punts on the dorado, and RSH is optimized to be LSH for the Sun, we have to use \\RSH here (the bottoming-out version of RSH).") (COND ((ILEQ N 0) (COND ((EQ N 0) X) (T (\\RSH X (IMINUS N))))) ((EQ X 0) 0) ((IGREATERP N (CONSTANT (INTEGERLENGTH MAX.FIXP))) (\\BIGNUM.LSH X N)) (T (FRPTQ N (SETQ X (IPLUS X X))) X)))) (RSH (LAMBDA (X N) (* \; "Edited 7-Apr-89 16:20 by jds") (* |;;| "Arithmetic Right-shift. There's an optimizer on this function, so just call the underlying implementation.") (\\RSH X N))) (\\RSH (LAMBDA (X N) (* \; "Edited 7-Apr-89 16:21 by jds") (* |;;|  "This is the version of RSH where things bottom out if LSH doesn't handle all the possible cases.") (COND ((IGREATERP 0 N) (LSH X (IMINUS N))) ((EQ X 0) 0) (T (PROG (XHI XLO) (.UNBOX. X XHI XLO (GO RETBIG)) (COND ((IGREATERP N 31) (RETURN (COND ((IGREATERP XHI 32767) (* \; "X WAS NEGATIVE") -1) (T 0))))) (COND ((IGREATERP N 15) (SETQ XLO XHI) (SETQ XHI (COND ((IGREATERP XHI 32767) 65535) (T 0))) (SETQ N (IDIFFERENCE N 16)))) (COND ((IGREATERP N 7) (SETQ XLO (IPLUS (LRSH XLO 8) (LLSH (LOGAND XHI 255) 8))) (SETQ XHI (IPLUS (LRSH XHI 8) (COND ((IGREATERP XHI 32767) 65280) (T 0)))) (SETQ N (IDIFFERENCE N 8)))) (FRPTQ N (SETQ XLO (IPLUS (LRSH XLO 1) (COND ((EQ 0 (LOGAND XHI 1)) 0) (T 32768)))) (SETQ XHI (IPLUS (LRSH XHI 1) (LOGAND XHI 32768)))) (RETURN (\\MAKENUMBER XHI XLO)) RETBIG (RETURN (\\BIGNUM.LSH X (IMINUS N)))))))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS NBITS.OR.LESS MACRO ((X N) (ILESSP X (CONSTANT (LLSH 1 N))))) (PUTPROPS .SUBSMALL. MACRO ((X Y) (* \;  "Subtract Y from X, returning the borrow out of the next word") (COND ((ILEQ Y X) (SETQ X (IDIFFERENCE X Y)) 0) (T (SETQ X (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X)))) 1)))) (PUTPROPS \\IQUOTREM MACRO ((X Y QUO REM) (PROG (HX LX HY LY SIGNQUOTIENT SIGNREMAINDER (CNT 0) (HZ 0) (LZ 0)) (.UNBOX. X HX LX (GO RETBIG)) (.UNBOX. Y HY LY (GO RETBIG)) (COND ((IGREATERP HX MAX.POS.HINUM) (.NEGATE. HX LX) (SETQ SIGNQUOTIENT (SETQ SIGNREMAINDER T)))) (* \; "Remainder has sign of dividend") (COND ((IGREATERP HY MAX.POS.HINUM) (.NEGATE. HY LY) (SETQ SIGNQUOTIENT (NOT SIGNQUOTIENT)))) (COND ((NEQ HX 0) (GO BIGDIVIDEND)) ((NEQ HY 0) (* \;  "Y is big, X is small, so result is 0") (GO DONE)) ((EQ 0 LX) (GO RET0)) ((EQ 0 LY) (GO DIVZERO)) ((EQ LY 1) (SETQ LZ LX) (SETQ LX 0) (GO DONE))) (* \;  "here we are dividing small X by small Y, and we know Y gt 1") LP1 (* \;  "shift Y left until it is as big as X, and count how many times") (COND ((AND (ILESSP LY LX) (ILEQ LY MAX.POS.HINUM)) (SETQ LY (LLSH LY 1)) (SETQ CNT (ADD1 CNT)) (GO LP1))) LP2 (* |;;| "now start dividing Y into X by subtracting and shifting, ending up with Y shifted back where it started") (COND ((ILEQ LY LX) (SETQ LX (IDIFFERENCE LX LY)) (* \;  "Y divides X once, so add bit into quotient") (SETQ LZ (ADD1 LZ)))) (SETQ LY (LRSH LY 1)) (SETQ CNT (SUB1 CNT)) (COND ((IGEQ CNT 0) (SETQ LZ (LLSH LZ 1)) (GO LP2))) (GO DONE) BIGDIVIDEND (* \;  "X is big, so result may be big. Algorithm is same as above, but everything is doubled in length") (COND ((EQ 0 HY) (COND ((EQ 0 (SETQ HY LY)) (GO DIVZERO)) ((AND SIGNREMAINDER (NULL SIGNQUOTIENT) (EQ 1 LY) (EQ HX \\SIGNBIT) (EQ 0 LX)) (* \;  "Means that X is MIN.FIXP and Y is -1") (GO RETBIG))) (SETQ LY 0) (SETQ CNT 16)) ((AND SIGNREMAINDER (NULL SIGNQUOTIENT) (EQ 0 LX) (EQ HX \\SIGNBIT) (EQ 0 HY) (EQ 1 LY))(* \;  "Means that X is MIN.FIXP and Y is -1") (GO RETBIG))) BIGLP (COND ((AND (OR (AND (EQ HY HX) (ILESSP LY LX)) (ILESSP HY HX)) (ILESSP HY MAX.POS.HINUM)) (.LLSH1. HY LY) (SETQ CNT (ADD1 CNT)) (GO BIGLP))) BIGLP2 (COND ((OR (ILESSP HY HX) (AND (EQ HY HX) (ILEQ LY LX))) (* \;  "Y divides X, so subtract Y from X and put a bit in quotient") (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY) (.SUBSMALL. LX LY))) (SETQ LZ (ADD1 LZ)) (* \;  "note that this never overflows, because of the preceding left shift") )) (.LRSH1. HY LY) (SETQ CNT (SUB1 CNT)) (COND ((IGEQ CNT 0) (.LLSH1. HZ LZ) (GO BIGLP2))) DONE (COND ('REM (* \; "remainder is left in X") (COND (SIGNREMAINDER (.NEGATE. HX LX))) (SETQ REM (\\MAKENUMBER HX LX)))) (COND ('QUO (COND (SIGNQUOTIENT (.NEGATE. HZ LZ))) (SETQ QUO (\\MAKENUMBER HZ LZ)))) (RETURN) DIVZERO (SELECTQ \\OVERFLOW (T (ERROR "DIVIDE BY ZERO" Y)) (GO RET0)) RET0 (COND ('REM (SETQ REM 0))) (COND ('QUO (SETQ QUO 0))) (RETURN) RETBIG (|if| 'QUO |then| (SETQ QUO (\\BIGNUM.QUOTIENT X Y))) (|if| 'REM |then| (SETQ REM (\\BIGNUM.REMAINDER X Y))) (RETURN)))) ) ) (* \; "Machine independent arithmetic functions") (* |;;| "MINUSP redefined in cmlarith ") (DEFINEQ (minusp (lambda (x) (* fs "22-Nov-86 20:47") (*  "Replaced by Roach (via MOVD) in CMLARITH to handle RATIOS") (cond ((floatp x) (fgreaterp 0.0 x)) (t (igreaterp 0 x))))) (ilessp (lambda (x y) (igreaterp y x))) (iminus (lambda (x) (idifference 0 x))) (iplus (lambda n (* \; "Edited 8-Apr-87 11:34 by jop") (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns IPLUS calls into sequences of opcodes") (selectq n (2 (iplus (arg n 1) (arg n 2))) (1 (iplus (arg n 1))) (0 (iplus)) (prog ((r (iplus (arg n 1) (arg n 2) (arg n 3))) (j 4)) lp (cond ((ileq j n) (setq r (iplus r (arg n j))) (setq j (add1 j)) (go lp))) (return r))))) (itimes (lambda n (* \; "Edited 8-Apr-87 11:34 by jop") (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns ITIMES calls into sequences of opcodes") (selectq n (2 (itimes (arg n 1) (arg n 2))) (1 (itimes (arg n 1))) (0 (itimes)) (prog ((r (itimes (arg n 1) (arg n 2) (arg n 3))) (j 4)) lp (cond ((ileq j n) (setq r (itimes r (arg n j))) (setq j (add1 j)) (go lp))) (return r))))) (logand (lambda n (* \; "Edited 8-Apr-87 11:34 by jop") (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGAND calls into sequences of opcodes") (selectq n (2 (logand (arg n 1) (arg n 2))) (1 (logand (arg n 1))) (0 (logand)) (prog ((r (logand (arg n 1) (arg n 2) (arg n 3))) (j 4)) lp (cond ((ileq j n) (setq r (logand r (arg n j))) (setq j (add1 j)) (go lp))) (return r))))) (logor (lambda n (* \; "Edited 8-Apr-87 11:34 by jop") (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGOR calls into sequences of opcodes") (selectq n (2 (logor (arg n 1) (arg n 2))) (1 (logor (arg n 1))) (0 (logor)) (prog ((r (logor (arg n 1) (arg n 2) (arg n 3))) (j 4)) lp (cond ((ileq j n) (setq r (logor r (arg n j))) (setq j (add1 j)) (go lp))) (return r))))) (logxor (lambda n (* \; "Edited 8-Apr-87 11:35 by jop") (* |;;| "called only by interpreted code --- this defn relies on fact that compiler turns LOGXOR calls into sequences of opcodes") (selectq n (2 (logxor (arg n 1) (arg n 2))) (1 (logxor (arg n 1))) (0 (logxor)) (prog ((r (logxor (arg n 1) (arg n 2) (arg n 3))) (j 4)) lp (cond ((ileq j n) (setq r (logxor r (arg n j))) (setq j (add1 j)) (go lp))) (return r))))) (sub1 (lambda (x) (* \; "Edited 8-Apr-87 11:35 by jop") (idifference x 1))) (zerop (lambda (x) (* |Pavel| " 6-Oct-86 22:13") (cond ((eq x 0) t) ((floatp x) (\\fzerop x))))) (add1 (lambda (x) (* \; "Edited 8-Apr-87 11:35 by jop") (iplus x 1))) (gcd (lambda (n1 n2) (* \; "Edited 8-Apr-87 11:35 by jop") (* |;;| "Greatest common divisor, using Euler's Method") (cond ((eq 0 n2) n1) ((minusp n2) (* \; "GCD is always positive") (gcd (minus n2) n1)) (t (gcd n2 (iremainder n1 n2)))))) (ieqp (lambda (x y) (* |JonL| " 1-May-84 22:23") (eq 0 (idifference x y)))) (integerlength (lambda (x) (* \; "Edited 8-Apr-87 11:37 by jop") (selectc (ntypx x) (\\smallp (cond ((ilessp x 0) (setq x (idifference 0 x)))) (cond ((nbits.or.less x 16) (cond ((nbits.or.less x 8) (cond ((nbits.or.less x 4) (cond ((nbits.or.less x 2) (cond ((nbits.or.less x 1) (cond ((eq x 0) 0) (t 1))) (t 2))) ((nbits.or.less x 3) 3) (t 4))) ((nbits.or.less x 6) (cond ((nbits.or.less x 5) 5) (t 6))) ((nbits.or.less x 7) 7) (t 8))) ((nbits.or.less x 12) (cond ((nbits.or.less x 10) (cond ((nbits.or.less x 9) 9) (t 10))) ((nbits.or.less x 11) 11) (t 12))) ((nbits.or.less x 14) (cond ((nbits.or.less x 13) 13) (t 14))) ((nbits.or.less x 15) 15) (t 16))) (t (shouldnt)))) (\\fixp (prog ((hx (|fetch| (fixp hinum) |of| x))) (cond ((igreaterp hx max.pos.hinum) (* \; "So X is negative") ((lambda (lx) (cond ((and (eq hx \\signbit) (eq lx 0)) (* \;  "So X is EQP to the minimum FIXP integer") (return (constant bits.per.fixp))) (t (.negate. hx lx)))) (|fetch| (fixp lonum) |of| x)))) (return (cond ((eq hx 0) (* |;;| "This bizarre case shouldn't really happen, but I wouldn't like to rule it out -- a non-normalized FIXP that realy should be a SMALLP") (integerlength (|fetch| (fixp lonum) |of| x))) (t (iplus (integerlength hx) bitsperword)))))) (cond ((typenamep x 'bignum) (\\bignum.integerlength x)) (t (cl::%not-integer-error x)))))) ) (* |;;| "abs, difference, greaterp, plus, lessp, and times redefined in cmlarith. ") (* |;;| "quotient and minus modified to handle ratios") (* |;;| "remainder remains as is") (DEFINEQ (abs (lambda (x) (* fs "22-Nov-86 20:58") (*  "Replaced in CMLARITH to handle RATIOS") (cl:ctypecase x ((or integer float) (cond ((< x 0) (- 0 x)) (t x))) (ratio (cond ((< (cl:numerator x) 0) (%make-ratio (- 0 (cl:numerator x)) (cl:denominator x))) (t x))) (complex (%complex-abs x))))) (difference (lambda (x y) (* \; "Edited 8-Apr-87 11:39 by jop") ((opcodes difference) x y))) (greaterp (lambda (x y) (* \; "Edited 8-Apr-87 11:39 by jop") (cond ((and (fixp x) (fixp y)) (igreaterp x y)) (t (fgreaterp x y))))) (plus (lambda n (* \; "Edited 8-Apr-87 11:39 by jop") (* |;;| "Microcode generally handles the case of two args both FIXPs") (prog (r (j 0)) lp (cond ((neq j n) (setq j (add1 j)) (setq r (cond ((and (fixp (arg n j)) (not (floatp r))) (iplus (or r 0) (arg n j))) (t (fplus (or r 0.0) (arg n j))))) (go lp))) (return r)))) (quotient (lambda (x y) (* \; "Edited 12-Feb-87 14:59 by jop") (* |lmm:| 17-dec-75 25 36) (cond ((and (fixp x) (fixp y)) (iquotient x y)) ((or (floatp x) (floatp y)) (fquotient x y)) (t (/ x y))))) (remainder (lambda (x y) (* |lmm:| 17-dec-75 21 30) (cond ((and (fixp x) (fixp y)) (iremainder x y)) (t (fremainder x y))))) (lessp (lambda (x y) (* \; "Edited 8-Apr-87 11:40 by jop") (cond ((and (fixp y) (fixp x)) (igreaterp y x)) (t (fgreaterp y x))))) (minus (lambda (x) (* \; "Edited 1-Mar-87 18:10 by jop") (cond ((floatp x) (fdifference 0.0 x)) (t (difference 0 x))))) (times (lambda n (* \; "Edited 8-Apr-87 11:40 by jop") (prog (r (j 0)) lp (cond ((neq j n) (setq j (add1 j)) (setq r (cond ((and (fixp (arg n j)) (not (floatp r))) (itimes (or r 1) (arg n j))) (t (ftimes (or r 1.0) (arg n j))))) (go lp))) (return r)))) ) (DEFINEQ (fminus (lambda (x) (* |lmm| " 5-MAR-80 23:12") (fdifference 0.0 x))) (fremainder (lambda (x y) (* |rrb| "24-APR-80 10:37") (fdifference x (ftimes (float (fix (fquotient x y))) y)))) ) (DEFINEQ (randset (lambda (x) (* \; "Edited 8-Apr-87 11:40 by jop") (prog (rs rs1 rs2) (cond ((null x) (go out)) ((eq x t) (* \; "initialize with clock") (setq rs1 (clock)) (setq rs2 (idate))) ((and (fixp (cdr (listp x))) (fixp (car x))) (* \;  "user supplies initialization, old-style") (setq rs1 (car x)) (setq rs2 (cdr x))) ((and (eq (length x) 55) (every x (function fixp))) (setq rs (mapcar x (function (lambda (n) (iplus n))))) (go xx)) (t (error '"ARG NOT PREVIOUS VALUE OF RANDSET" x))) (prog ((\\overflow 0)) (declare (specvars \\overflow)) (setq rs (mapcar '(53375 47430 1274 55702 61592 27723 11236 16824 35838 62289 11525 37822 34676 105 58750 27759 9988 4217 56951 30292 24550 1397 54588 54264 43300 3862 39006 11386 52259 1055 955 16320 19910 58470 3263 64657 1704 17373 56820 17255 51637 47962 26272 4464 2884 51773 39422 64835 57733 34919 5315 12110 15116 10133 10816) (function (lambda (z) (setq rs1 (logand rs1 65535)) (logxor z (setq rs2 (prog1 (logand (iplus (itimes rs1 19869) rs1) 65535) (setq rs1 rs2))))))))) xx (frplacd (last rs) rs) (setq randstate (cons rs (fnth rs 31))) out (return (|for| x |in| (car randstate) |as| i |from| 1 |to| 55 |collect| x))))) (RAND (LAMBDA (LOWER UPPER) (* \; "Edited 3-Sep-87 19:03 by jds") (* |;;| "This function implements the XRAND subroutine described in Stanford memo STAN-CS-77-601, Analysis of Additive Random Number Generators, by John F. Reiser, on p 28.0 Rather than storing the X values in an array and computing indexes I and J, however, I have elected to retain state in a circular list of 51 elements. RANDSTATE is (CONS X (NTH X 31)); each time RAND is called, both CAR and CDR of RANDSTATE are CDR'ed to effectively increment the index. In addition, the numbers are stored as 16 bit binary fractions (i.e. the decimal point is on the left of the 16-bit quantity)") (PROG (I J) (OR (LISTP RANDSTATE) (PROGN (RANDSET T) RANDSTATE)) (SETQ I (CDAR RANDSTATE)) (SETQ J (CDDR RANDSTATE)) (RPLNODE RANDSTATE I J) (RPLACA I (LOGAND (IDIFFERENCE (CAR I) (CAR J)) MAX.SMALLP))) (COND ((NOT UPPER) (COND ((NULL LOWER) (* \;  "both UPPER and LOWER nil. Return number (0 (\\, MAX.SMALLP)) --- not documented") (CAAR RANDSTATE)) ((ZEROP LOWER) (* \; "(RAND 0) = 0") 0) ((FIXP LOWER) (* \; "(RAND n) = (RAND 0 n-1)") (IREMAINDER (CAAR RANDSTATE) LOWER)) (T (* \;  "(RAND N) N floating. Return (RAND 0 N)") (FTIMES LOWER (FQUOTIENT (CAAR RANDSTATE) (CONSTANT (FLOAT (ADD1 MAX.SMALLP)))))))) ((AND (FIXP LOWER) (FIXP UPPER)) (OR (IGREATERP UPPER LOWER) (|swap| UPPER LOWER)) (SETQ UPPER (IDIFFERENCE UPPER LOWER)) (COND ((IGREATERP UPPER MAX.SMALLP) (IPLUS (IMOD (\\MAKENUMBER (CAAR RANDSTATE) (CADAR RANDSTATE)) (ADD1 UPPER)) LOWER)) (T (IPLUS (IREMAINDER (CAAR RANDSTATE) (ADD1 UPPER)) LOWER)))) (T (FPLUS (FTIMES (FDIFFERENCE UPPER LOWER) (FQUOTIENT (CAAR RANDSTATE) (CONSTANT (FLOAT (ADD1 MAX.SMALLP))))) LOWER))))) (expt (lambda (a n) (* \; "Edited 8-Apr-87 11:41 by jop") (cond ((fixp n) (cond ((fixp a) (cond ((not (igreaterp n 0)) (cond ((eq 0 n) 1) (t (fexpt a n)))) ((eq 0 a) 0) (t (* |;;| "Integer EXPonentiation -- works by clever bit-dissection method") (prog ((v 1)) lp (cond ((oddp n) (setq v (times a v)))) (cond ((eq 0 (setq n (rsh n 1))) (return v))) (setq a (times a a)) (go lp))))) ((feqp 0.0 (setq a (float a))) (cond ((eq 0 n) 1.0) (t 0.0))) (t (* |;;| "Real EXPonentiation -- works by clever bit-dissection method") (prog ((v 1.0)) (cond ((ilessp n 0) (setq a (fquotient 1.0 a)) (setq n (iminus n)))) lp (cond ((oddp n) (setq v (times a v)))) (cond ((eq 0 (setq n (lrsh n 1))) (return v))) (setq a (times a a)) (go lp))))) (t (fexpt a n))))) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (RPAQQ RANDSTATE NIL) (RPAQQ \\TOL 9.9999925E-6) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS RANDSTATE \\TOL) ) (DEFINEQ (|PutUnboxed| (lambda (ptr num) (* |JonL| "25-JUL-83 02:29") (\\putfixp ptr num))) (\\putfixp (lambda (ptr num) (* |lmm| "11-DEC-80 15:10") (prog (hi lo) (.unbox. num hi lo) (|replace| (fixp hinum) |of| ptr |with| hi) (|replace| (fixp lonum) |of| ptr |with| lo) (return num)))) (\\putswappedfixp (lambda (ptr num) (* \; "Edited 8-Apr-87 11:41 by jop") (* |;;| "store in MESA order rather than LISP order") (prog (hi lo) (.unbox. num hi lo) (|replace| (fixp lonum) |of| ptr |with| hi) (|replace| (fixp hinum) |of| ptr |with| lo) (return num)))) (\\hinum (lambda (num) (* |lmm| "12-APR-81 22:01") (prog (hi lo) (.unbox. num hi lo) (return hi)))) (\\lonum (lambda (num) (* |lmm| "12-APR-81 22:02") (prog (hi lo) (.unbox. num hi lo) (return lo)))) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE\: DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS |PutUnboxed| DMACRO (= . \\PUTFIXP)) ) ) (* "END EXPORTED DEFINITIONS") (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA MIN MAX IMIN IMAX FMIN FMAX TIMES PLUS LOGXOR LOGOR LOGAND ITIMES IPLUS) ) (* |;;| "ODDP redefined in cmlarith") (DEFINEQ (poweroftwop (lambda (x) (declare (localvars . t)) (* \; "Edited 8-Apr-87 11:42 by jop") (* |;;| "Non-NIL iff arg is some power of 2") (|if| (and (eq (systemtype) 'd) (not (smallp x))) |then| (and (fixp x) (igreaterp x 0) (|if| (eq (logand x (constant (sub1 (expt 2 16)))) 0) |then| (poweroftwop (rsh x 16)) |else| (and (eq (rsh x 16) 0) (.2^np. (logand x (sub1 (expt 2 16))))))) |else| (|if| (igreaterp x 0) |then| (.2^np. x))))) (imod (lambda (x n) (* |lmm| "20-OCT-82 15:07") (cond ((igeq (setq x (iremainder x n)) 0) x) (t (iplus n x))))) (oddp (cl:lambda (cl:number &optional (modulus 2)) (* |lmm| "22-May-86 17:26") (not (zerop (cl:mod cl:number modulus))))) ) (DECLARE\: DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS .2^NP. MACRO (OPENLAMBDA (X) (EQ (LOGAND X (SUB1 X)) 0))) ) ) (* \; "MIN and MAX") (DEFINEQ (flessp (lambda (x y) (fgreaterp y x))) (fmax (lambda k (* |bvm:| "14-Feb-85 23:48") (cond ((eq k 0) min.float) (t (prog ((j 1) (x (float (arg k 1))) y) (or (numberp x) (errorx (list 10 x))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((fgreaterp (setq y (float (arg k j))) x) (setq x y))) (go lp)))))) (fmin (lambda k (* |bvm:| "14-Feb-85 23:49") (cond ((eq k 0) max.float) (t (prog ((j 1) (x (float (arg k 1))) y) (or (numberp x) (errorx (list 10 x))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((fgreaterp x (setq y (float (arg k j)))) (setq x y))) (go lp)))))) (geq (lambda (x y) (not (lessp x y)))) (igeq (lambda (x y) (not (ilessp x y)))) (ileq (lambda (x y) (not (igreaterp x y)))) (imax (lambda k (* |bvm:| "14-Feb-85 23:49") (cond ((eq k 0) min.integer) (t (prog ((j 1) (x (arg k 1))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((ilessp x (arg k j)) (setq x (arg k j)))) (go lp)))))) (imin (lambda k (* |bvm:| "14-Feb-85 23:49") (cond ((eq k 0) max.integer) (t (prog ((j 1) (x (arg k 1))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((igreaterp x (arg k j)) (setq x (arg k j)))) (go lp)))))) (leq (lambda (x y) (not (greaterp x y)))) (max (lambda k (* |lmm| "12-Apr-85 08:42") (cond ((eq k 0) min.integer) (t (prog ((j 1) (x (arg k 1)) y) (or (numberp x) (errorx (list 10 x))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((greaterp (setq y (arg k j)) x) (setq x y))) (go lp)))))) (min (lambda k (* |lmm| "12-Apr-85 08:42") (cond ((eq k 0) max.integer) (t (prog ((j 1) (x (arg k 1)) y) (or (numberp x) (errorx (list 10 x))) lp (cond ((eq j k) (return x))) (add1var j) (cond ((greaterp x (setq y (arg k j))) (setq x y))) (go lp)))))) ) (DECLARE\: EVAL@COMPILE (ADDTOVAR GLOBALVARS MAX.INTEGER MIN.INTEGER MAX.FLOAT MIN.FLOAT) ) (DECLARE\: DONTCOPY DOEVAL@COMPILE DONTEVAL@LOAD (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS LLARITH COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4408 4876 (IDIFFERENCE 4418 . 4570) (IGREATERP 4572 . 4724) (IQUOTIENT 4726 . 4874)) ( 4979 19091 (\\SLOWIPLUS2 4989 . 6522) (\\SLOWPLUS2 6524 . 7239) (\\SLOWIDIFFERENCE 7241 . 9497) ( \\SLOWDIFFERENCE 9499 . 10243) (\\SLOWIGREATERP 10245 . 10785) (\\SLOWLLSH1 10787 . 11378) ( \\SLOWLLSH8 11380 . 11814) (\\SLOWLOGAND2 11816 . 12216) (\\SLOWLOGOR2 12218 . 12613) (\\SLOWLOGXOR2 12615 . 13015) (\\SLOWLRSH1 13017 . 13471) (\\SLOWLRSH8 13473 . 13845) (\\SLOWITIMES2 13847 . 17437) ( \\SLOWTIMES2 17439 . 18177) (\\SLOWIQUOTIENT 18179 . 18353) (\\SLOWQUOTIENT 18355 . 19089)) (19170 20589 (\\BOXIPLUS 19180 . 19387) (\\BOXIDIFFERENCE 19389 . 20587)) (20620 21196 (\\MAKENUMBER 20630 . 21194)) (21197 21516 (OVERFLOW 21207 . 21514)) (21871 22749 (\\GETBASEFIXP 21881 . 22159) ( \\PUTBASEFIXP 22161 . 22451) (\\PUTBASEFIXP.UFN 22453 . 22747)) (31874 38017 (EQP 31884 . 32337) (FIX 32339 . 32532) (IQUOTIENT 32534 . 32682) (IREMAINDER 32684 . 32835) (LLSH 32837 . 33917) (LRSH 33919 . 35027) (LSH 35029 . 35636) (RSH 35638 . 35901) (\\RSH 35903 . 38015)) (47923 56685 (MINUSP 47933 . 48304) (ILESSP 48306 . 48359) (IMINUS 48361 . 48414) (IPLUS 48416 . 49159) (ITIMES 49161 . 49911) ( LOGAND 49913 . 50663) (LOGOR 50665 . 51408) (LOGXOR 51410 . 52160) (SUB1 52162 . 52307) (ZEROP 52309 . 52500) (ADD1 52502 . 52641) (GCD 52643 . 53083) (IEQP 53085 . 53227) (INTEGERLENGTH 53229 . 56683)) (56887 60328 (ABS 56897 . 57610) (DIFFERENCE 57612 . 57773) (GREATERP 57775 . 58010) (PLUS 58012 . 58681) (QUOTIENT 58683 . 59074) (REMAINDER 59076 . 59302) (LESSP 59304 . 59536) (MINUS 59538 . 59749) (TIMES 59751 . 60326)) (60329 60682 (FMINUS 60339 . 60473) (FREMAINDER 60475 . 60680)) (60683 67332 ( RANDSET 60693 . 62940) (RAND 62942 . 65665) (EXPT 65667 . 67330)) (67494 68755 (|PutUnboxed| 67504 . 67649) (\\PUTFIXP 67651 . 67968) (\\PUTSWAPPEDFIXP 67970 . 68385) (\\HINUM 68387 . 68569) (\\LONUM 68571 . 68753)) (69183 70426 (POWEROFTWOP 69193 . 70036) (IMOD 70038 . 70260) (ODDP 70262 . 70424)) ( 70671 74183 (FLESSP 70681 . 70730) (FMAX 70732 . 71325) (FMIN 71327 . 71893) (GEQ 71895 . 71947) (IGEQ 71949 . 72003) (ILEQ 72005 . 72062) (IMAX 72064 . 72523) (IMIN 72525 . 72987) (LEQ 72989 . 73044) ( MAX 73046 . 73626) (MIN 73628 . 74181))))) STOP \ No newline at end of file diff --git a/sources/LLARRAYELT b/sources/LLARRAYELT new file mode 100644 index 00000000..f546409a --- /dev/null +++ b/sources/LLARRAYELT @@ -0,0 +1,2968 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "15-Sep-94 11:08:59" {DSK}sources>LLARRAYELT.;7 155360 + + changes to%: (RECORDS ARRAYP) + + previous date%: "28-Jul-94 13:41:50" {DSK}sources>LLARRAYELT.;6) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLARRAYELTCOMS) + +(RPAQQ LLARRAYELTCOMS + [(COMS (* ; + "Because we use the UNLESSINEW macro in this file, we need it when compiling.") + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) + RENAMEMACROS))) + (PROPS (LLARRAYELT FILETYPE)) + (COMS (* ; "ARRAY entries") + (FNS AIN AOUT ARRAY ARRAYSIZE ARRAYTYP ARRAYORIG COPYARRAY) + (DECLARE%: DONTCOPY (MACROS ARRAYSIZE)) + (FNS ELT ELTD SETA SETD SUBARRAY)) + [COMS (* ; "HASHARRAY entries") + (FNS HARRAY HASHARRAY HARRAYP HARRAYPROP HARRAYSIZE CLRHASH MAPHASH GETHASH PUTHASH + CL::PUTHASH REMHASH \HASHRECLAIM \HASHACCESS REHASH \COPYHARRAYP + \HASHTABLE.DEFPRINT) + (FNS STRINGHASHBITS STRING-EQUAL-HASHBITS) + (FNS \STRINGHASHBITS-UFN \STRING-EQUAL-HASHBITS-UFN) + (DECLARE%: DONTCOPY (EXPORT (RECORDS HARRAYP) + (MACROS \EQHASHINGBITS)) + (RECORDS HASHSLOT) + (MACROS \FIRSTINDEX \HASHSLOT \REPROBE) + (CONSTANTS (CELLSPERSLOT 2)) + (GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY)) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT] + (INITRECORDS HARRAYP) + (SYSRECORDS HARRAYP) + (VARS (\HASH.NULL.VALUE '\Hash\Null\Value\] + (COMS (* ; "System entries for CODE") + (FNS \CODEARRAY \FIXCODENUM \FIXCODEPTR \FIXCODESYM)) + (COMS (* ; "Internal") + (DECLARE%: DONTCOPY (MACROS EQPTR BUCKETINDEX FREEBLOCKCHAIN.N) + (CONSTANTS \MAXBUCKETINDEX) + (* ; + "\ADDBASE2 and \ADDBASE4 do \ADDBASE of 2*N and 4*N without boxing") + (EXPORT (MACROS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER \BYTELT \BYTESETA + \WORDELT) + (CONSTANTS * BLOCKGCTYPECONSTANTS) + (CONSTANTS * ARRAYCONSTANTS) + (CONSTANTS * ARRAYTYPES) + (CONSTANTS \MAX.CELLSPERHUNK) + (CONSTANTS (\IN.MAKEINIT)) + (RECORDS SEQUENCEDESCRIPTOR ARRAYP ARRAYBLOCK) + (GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?)) + (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN)) + (FNS \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.OLD \ALLOCBLOCK.NEW \PREFIXALIGNMENT? + \MAKEFREEARRAYBLOCK \DELETEBLOCK? \LINKBLOCK \MERGEBACKWARD \MERGEFORWARD + \ARRAYBLOCKMERGER \#BLOCKDATACELLS \COPYARRAYBLOCK \RECLAIMARRAYBLOCK + \ADVANCE.ARRAY.SEGMENTS) + (ADDVARS (\MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK))) + (FNS \BYTELT \BYTESETA \WORDELT) + (FNS \ARRAYTYPENAME) + (VARS (\ARRAYMERGING T)) + (GLOBALVARS \ARRAYMERGING) + (COMS (* ; "for STORAGE") + (FNS \SHOW.ARRAY.FREELISTS) + (INITVARS (\ABSTORAGETABLE NIL)) + (GLOBALVARS \ABSTORAGETABLE) + (DECLARE%: DONTCOPY (RECORDS SAFTABLE))) + (COMS (* ; "Debugging and RDSYS") + (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1) + (INITVARS (ARRAYBLOCKCHECKING)) + (GLOBALVARS ARRAYBLOCKCHECKING))) + (COMS (* ; "Basic hunking") + (FNS \ALLOCHUNK) + (VARS \HUNK.PTRSIZES) + (* ; + "Compiler needs \HUNK.PTRSIZES for creating closure environments") + (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS HUNKSIZEFROMNUMBER)) + (CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES) + (GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE + \PTRHUNK.TYPENUM.TABLE)) + (COMS + (* ;; "Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage") + + (VARS (\HUNKREJECTS)) + (GLOBALVARS \HUNKREJECTS))) + [COMS (* ; "for MAKEINIT") + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK + FILEPATCHBLOCK) + (COMS (* ; "Hunk Initialization") + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING + \SETUP.TYPENUM.TABLE)) + (DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtArrayPage) + (\HUNKING?)) + (INITPTRS (\FREEBLOCKBUCKETS) + (\ArrayFrLst) + (\ArrayFrLst2) + (\UNBOXEDHUNK.TYPENUM.TABLE) + (\CODEHUNK.TYPENUM.TABLE) + (\PTRHUNK.TYPENUM.TABLE)) + (INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? + \ALLOCBLOCK \MAIKO.ALLOCBLOCK \ALLOCBLOCK.NEW + \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK + \ALLOCHUNK) + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE + FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK) + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS + \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE)) + (MKI.SUBFNS (\IN.MAKEINIT . T) + (\ALLOCBLOCK.OLD . NILL) + (\MERGEFORWARD . NILL) + (\FIXCODENUM . I.FIXUPNUM) + (\FIXCODESYM . I.FIXUPSYM) + (\FIXCODEPTR . I.FIXUPPTR) + (\CHECKARRAYBLOCK . NILL) + (\ARRAYMERGING PROGN NIL)) + (EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER + BUCKETINDEX FREEBLOCKCHAIN.N) + (RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE + \PARSEARRAYSPACE1)) + (RD.SUBFNS (EQPTR . EQUAL) + (ARRAYBLOCKCHECKING . T)) + (RDPTRS (\FREEBLOCKBUCKETS)) + (RDVALS (\ArrayFrLst) + (\ArrayFrLst2))) + EVAL@COMPILE + (ADDVARS (DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE + FILEBLOCKTRAILER FILECODEBLOCK FILEPATCHBLOCK) + (DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS + \TURN.ON.HUNKING \SETUP.TYPENUM.TABLE] + (COMS (* ; "Debugging aids") + (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \ArrayFrLst) + (CONSTANTS \ArrayBlockPassword) + (ADDVARS (DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK))) + (FNS \HUNKFIT? \AB.NEXT \AB.BACK)) + (LOCALVARS . T) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA CL::PUTHASH + HARRAYPROP]) + + + +(* ; "Because we use the UNLESSINEW macro in this file, we need it when compiling.") + +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (SOURCE) + RENAMEMACROS) +) + +(PUTPROPS LLARRAYELT FILETYPE :BCOMPL) + + + +(* ; "ARRAY entries") + +(DEFINEQ + +(AIN + [LAMBDA (APTR INDEX N FILE) (* ; "Edited 23-Nov-86 16:44 by jop:") + + (* ;; "Reads N elements into APTR starting at INDEX. INDEX and N are in terms of the array's indexing units") + + (COND + ((NOT (OR (STRINGP APTR) + (ARRAYP APTR))) + (LISPERROR "ILLEGAL ARG" APTR)) + ((IGREATERP 0 INDEX) + (LISPERROR "ILLEGAL ARG" INDEX))) + (LET (BASE LENGTH OFFST TYP ORIG STBYTE) + (if (STRINGP APTR) + then (SETQ BASE (ffetch (STRINGP BASE) of APTR)) + (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR)) + (SETQ OFFST (ffetch (STRINGP OFFST) of APTR)) + (SETQ TYP (ffetch (STRINGP TYP) of APTR)) + (SETQ ORIG 1) + else (SETQ BASE (ffetch (ARRAYP BASE) of APTR)) + (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR)) + (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR)) + (SETQ TYP (ffetch (ARRAYP TYP) of APTR)) + (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR))) + (SETQ STBYTE (IDIFFERENCE INDEX ORIG)) + (COND + ((ILESSP (SELECTC TYP + ((LIST \ST.BYTE \ST.CODE) + LENGTH) + (\ST.POS16 (SETQ OFFST (UNFOLD OFFST BYTESPERWORD)) + (SETQ N (UNFOLD N BYTESPERWORD)) + (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD)) + (UNFOLD LENGTH BYTESPERWORD)) + ((LIST \ST.INT32 \ST.FLOAT) + (SETQ OFFST (UNFOLD OFFST BYTESPERCELL)) + (SETQ N (UNFOLD N BYTESPERCELL)) + (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL)) + (UNFOLD LENGTH BYTESPERCELL)) + (\ST.BIT) + (LISPERROR "ILLEGAL ARG" APTR)) + (IPLUS STBYTE N)) + (LISPERROR "ILLEGAL ARG" APTR))) + (\BINS (\GETOFD FILE 'INPUT) + BASE + (IPLUS STBYTE OFFST) + N) + APTR]) + +(AOUT + [LAMBDA (APTR INDEX N FILE) (* ; "Edited 23-Nov-86 16:49 by jop:") + (* ; + "INDEX and N are in terms of the array's indexing unit") + (COND + ((NOT (OR (STRINGP APTR) + (ARRAYP APTR))) + (LISPERROR "ILLEGAL ARG" APTR)) + ((IGREATERP 0 INDEX) + (LISPERROR "ILLEGAL ARG" INDEX))) + + (* ;; "Used to be in terms of the block record SEQUENCEDESCRIPTOR, but changed to refer explicitly to arrayp's and stringp's since stringp's no longer look like arrayp's") + + (LET (BASE LENGTH OFFST TYP ORIG STBYTE) + (if (STRINGP APTR) + then (SETQ BASE (ffetch (STRINGP BASE) of APTR)) + (SETQ LENGTH (ffetch (STRINGP LENGTH) of APTR)) + (SETQ OFFST (ffetch (STRINGP OFFST) of APTR)) + (SETQ TYP (ffetch (STRINGP TYP) of APTR)) + (SETQ ORIG 1) + else (SETQ BASE (ffetch (ARRAYP BASE) of APTR)) + (SETQ LENGTH (ffetch (ARRAYP LENGTH) of APTR)) + (SETQ OFFST (ffetch (ARRAYP OFFST) of APTR)) + (SETQ TYP (ffetch (ARRAYP TYP) of APTR)) + (SETQ ORIG (ffetch (ARRAYP ORIG) of APTR))) + (SETQ STBYTE (IDIFFERENCE INDEX ORIG)) (* ; + "Standardize units before comparing") + (COND + ((ILESSP (SELECTC TYP + ((LIST \ST.BYTE \ST.CODE) + LENGTH) + (\ST.POS16 (SETQ N (UNFOLD N BYTESPERWORD)) + (SETQ STBYTE (UNFOLD STBYTE BYTESPERWORD)) + (SETQ OFFST (UNFOLD OFFST BYTESPERWORD)) + (UNFOLD LENGTH BYTESPERWORD)) + ((LIST \ST.INT32 \ST.FLOAT) + (SETQ N (UNFOLD N BYTESPERCELL)) + (SETQ STBYTE (UNFOLD STBYTE BYTESPERCELL)) + (SETQ OFFST (UNFOLD OFFST BYTESPERCELL)) + (UNFOLD LENGTH BYTESPERCELL)) + (LISPERROR "ILLEGAL ARG" APTR)) + (IPLUS STBYTE N)) + (LISPERROR "ILLEGAL ARG" APTR))) + (\BOUTS (\GETOFD FILE 'OUTPUT) + BASE + (IPLUS STBYTE OFFST) + N) + APTR]) + +(ARRAY + [LAMBDA (SIZE TYPE INITVAL ORIG ALIGN) (* JonL "20-Sep-84 19:46") + + (* ;; "extension of the normal VM definition of an array to allow many different TYPEs, and also allows ORIG of 0") + + (SETQ SIZE (FIX SIZE)) + (COND + ((OR (IGREATERP 0 SIZE) + (IGREATERP SIZE \MaxArrayLen)) + (LISPERROR "ILLEGAL ARG" SIZE))) (* ; + "Coerce floats at outset; \ALLOCARRAY wants fixp") + (PROG (AP TYP GCTYPE (NCELLS SIZE)) + [SETQ TYP (SELECTQ TYPE + (BYTE (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL)) + \ST.BYTE) + ((SMALLP SMALLPOSP WORD) + (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL)) + \ST.POS16) + ((NIL POINTER FLAG) + (SETQ GCTYPE PTRBLOCK.GCT) + \ST.PTR) + ((0 DOUBLEPOINTER) (* ; + "INTERLISP-10 style arrays--each element is 2 cells") + (SETQ NCELLS (UNFOLD SIZE 2)) + (SETQ GCTYPE PTRBLOCK.GCT) + \ST.PTR2) + (FIXP \ST.INT32) + (FLOATP [COND + (INITVAL (SETQ INITVAL (FLOAT INITVAL] + \ST.FLOAT) + (BIT (SETQ NCELLS (FOLDHI SIZE BITSPERCELL)) + \ST.BIT) + (SIGNEDWORD \ST.INT32) + (COND + ((EQ SIZE TYPE) (* ; "= FIXP") + \ST.INT32) + ((AND (LISTP TYPE) + (EQ (CAR TYPE) + 'BITS)) + (COND + ((IGREATERP (CADR TYPE) + 16) + \ST.INT32) + ((IGREATERP (CADR TYPE) + 8) + (SETQ NCELLS (FOLDHI SIZE WORDSPERCELL)) + \ST.POS16) + ((IGREATERP (CADR TYPE) + 1) + (SETQ NCELLS (FOLDHI SIZE BYTESPERCELL)) + \ST.BYTE) + (T (SETQ NCELLS (FOLDHI SIZE BITSPERCELL)) + \ST.BIT))) + (T (\ILLEGAL.ARG TYPE] + (SETQ AP (create ARRAYP + TYP _ TYP + LENGTH _ SIZE + ORIG _ (SELECTQ ORIG + ((0 1) + ORIG) + (NIL 1) + (LISPERROR "ILLEGAL ARG" ORIG)) + OFFST _ 0 + BASE _ (\ALLOCBLOCK NCELLS GCTYPE NIL ALIGN))) + [AND INITVAL + (PROG ((BASE (fetch (ARRAYP BASE) of AP)) + (NWORDS (SUB1 (UNFOLD NCELLS WORDSPERCELL))) + LASTWORD2BASE) + (SETQ LASTWORD2BASE (\ADDBASE BASE (SUB1 NWORDS))) + (SELECTC TYP + (\ST.BYTE (OR (EQ 0 INITVAL) + (PROGN (\PUTBASE LASTWORD2BASE 1 + (create WORD + HIBYTE _ INITVAL + LOBYTE _ INITVAL)) + (\BLT BASE (\ADDBASE BASE 1) + NWORDS)))) + (\ST.POS16 (OR (EQ 0 INITVAL) + (PROGN (\PUTBASE LASTWORD2BASE 1 INITVAL) + (\BLT BASE (\ADDBASE BASE 1) + NWORDS)))) + (\ST.INT32 [OR (EQ 0 INITVAL) + (PROGN (\PUTBASEFIXP LASTWORD2BASE 0 INITVAL) + (\BLT BASE (\ADDBASE BASE WORDSPERCELL) + (SUB1 NWORDS]) + ((LIST \ST.PTR \ST.PTR2) (* ; + "Remove \ST.FLOAT when FLOATP is no longer stored in PTR mode.") + [PROG ((P BASE)) + (FRPTQ NCELLS (\RPLPTR P 0 INITVAL) + (SETQ P (\ADDBASE P WORDSPERCELL]) + (\ST.FLOAT [OR (FEQP 0.0 INITVAL) + (PROGN (\PUTBASEFLOATP LASTWORD2BASE 0 INITVAL) + (\BLT BASE (\ADDBASE BASE WORDSPERCELL) + (SUB1 NWORDS]) + (\ST.BIT (OR (EQ 0 INITVAL) + (PROGN (\PUTBASE LASTWORD2BASE 1 MASKWORD1'S) + (\BLT BASE (\ADDBASE BASE 1) + NWORDS)))) + (SHOULDNT] + (RETURN AP]) + +(ARRAYSIZE + [LAMBDA (X) (* JonL " 4-NOV-83 12:44") + (\MACRO.MX (ARRAYSIZE X]) + +(ARRAYTYP + [LAMBDA (ARRAY) (* rmk%: "30-Dec-83 13:12") + + (* ;; "This is a VM function which returns valid 2nd argument to ARRAY") + + (SELECTC (fetch (ARRAYP TYP) of (\DTEST ARRAY 'ARRAYP)) + (\ST.BYTE 'BYTE) + (\ST.PTR2 'DOUBLEPOINTER) + (\ST.PTR 'POINTER) + (\ST.POS16 'SMALLPOSP) + (\ST.CODE (* ; "not valid 2nd arg to ARRAY") + 'CODE) + (\ST.INT32 'FIXP) + (\ST.FLOAT 'FLOATP) + (\ST.BIT 'BIT) + (SHOULDNT]) + +(ARRAYORIG + [LAMBDA (ARRAY) (* rmk%: "30-Dec-83 13:12") + (fetch (ARRAYP ORIG) of (\DTEST ARRAY 'ARRAYP]) + +(COPYARRAY + [LAMBDA (ARRAY) (* JonL "16-Oct-84 20:38") + (COND + [(HARRAYP ARRAY) + (PROG [(NHARRAY (HASHARRAY (HARRAYSIZE ARRAY] + (\COPYHARRAYP ARRAY NHARRAY) + (RETURN (REHASH ARRAY NHARRAY] + (T (PROG (NEWARRAY INDEX (ORIG (ARRAYORIG ARRAY)) + (TYPE (ARRAYTYP ARRAY)) + (SIZE (ARRAYSIZE ARRAY))) + (SETQ NEWARRAY (ARRAY SIZE TYPE NIL ORIG)) + (SETQ INDEX ORIG) + (FRPTQ SIZE (SETA NEWARRAY INDEX (ELT ARRAY INDEX)) + (add INDEX 1)) + (SELECTQ TYPE + ((DOUBLEPOINTER) + (SETQ INDEX ORIG) + (FRPTQ SIZE (SETD NEWARRAY INDEX (ELTD ARRAY INDEX)) + (add INDEX 1))) + NIL) + (RETURN NEWARRAY]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS ARRAYSIZE DMACRO ((A) + (ffetch (ARRAYP LENGTH) of (\DTEST A 'ARRAYP] +) +) +(DEFINEQ + +(ELT + [LAMBDA (A N) (* lmm " 7-Jun-84 17:53") + (\DTEST A 'ARRAYP) + (PROG [(BASE (fetch (ARRAYP BASE) of A)) + (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A] + (COND + ((OR (IGREATERP 0 N0) + (IGEQ N0 (fetch (ARRAYP LENGTH) of A))) + (LISPERROR "ILLEGAL ARG" N))) + (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A))) + (RETURN (SELECTC (fetch (ARRAYP TYP) of A) + ((LIST \ST.PTR \ST.PTR2) + (\GETBASEPTR (\ADDBASE2 BASE N0) + 0)) + (\ST.INT32 (SETQ BASE (\ADDBASE2 BASE N0)) + (\MAKENUMBER (\GETBASE BASE 0) + (\GETBASE BASE 1))) + ((LIST \ST.BYTE \ST.CODE) + (\GETBASEBYTE BASE N0)) + (\ST.POS16 (\GETBASE BASE N0)) + (\ST.BIT (LOGAND (LRSH (\GETBASE BASE (FOLDLO N0 BITSPERWORD)) + (IDIFFERENCE (SUB1 BITSPERWORD) + (IMOD N0 BITSPERWORD))) + 1)) + (\ST.FLOAT (\GETBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL))) + (LISPERROR "ILLEGAL ARG" A]) + +(ELTD + [LAMBDA (A N) (* rmk%: "30-Dec-83 13:13") + (\DTEST A 'ARRAYP) + (SELECTC (fetch (ARRAYP TYP) of A) + (\ST.PTR2 (PROG [(BASE (fetch (ARRAYP BASE) of A)) + (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A] + (COND + ((OR (IGREATERP 0 N0) + (IGEQ N0 (fetch (ARRAYP LENGTH) of A))) + (LISPERROR "ILLEGAL ARG" N))) + (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A))) + (RETURN (\GETBASEPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH) + of A)) + N0) + 0)))) + (ELT A N]) + +(SETA + [LAMBDA (A N V) (* bvm%: " 6-Feb-85 15:54") + (COND + ([fetch (ARRAYP READONLY) of (SETQ A (\DTEST A 'ARRAYP] + (LISPERROR "ILLEGAL ARG" A))) + (PROG [(BASE (fetch (ARRAYP BASE) of A)) + (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A] + (COND + ((OR (ILESSP N0 0) + (IGEQ N0 (fetch (ARRAYP LENGTH) of A))) + (LISPERROR "ILLEGAL ARG" N))) + (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A))) + (RETURN (SELECTC (fetch (ARRAYP TYP) of A) + ((LIST \ST.PTR \ST.PTR2) + (\RPLPTR (\ADDBASE2 BASE N0) + 0 V)) + (\ST.INT32 (* ; "32-bit 2's complement integers") + (\PUTBASEFIXP (\ADDBASE2 BASE N0) + 0 V)) + ((LIST \ST.BYTE \ST.CODE) + (\PUTBASEBYTE BASE N0 V)) + (\ST.POS16 (* ; "Unsigned 16-bit numbers") + (\PUTBASE BASE N0 V)) + (\ST.BIT [\PUTBASE BASE (FOLDLO N0 BITSPERWORD) + (COND + [(EQ 0 V) + (LOGAND (\GETBASE BASE (FOLDLO N0 BITSPERWORD)) + (LOGXOR (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD) + (IMOD N0 BITSPERWORD))) + (SUB1 (LLSH 1 BITSPERWORD] + (T (LOGOR (\GETBASE BASE (FOLDLO N0 BITSPERWORD)) + (LLSH 1 (IDIFFERENCE (SUB1 BITSPERWORD) + (IMOD N0 BITSPERWORD] + V) + (\ST.FLOAT (\PUTBASEFLOATP BASE (UNFOLD N0 WORDSPERCELL) + (FLOAT V))) + (LISPERROR "ILLEGAL ARG" A]) + +(SETD + [LAMBDA (A N V) (* rmk%: "30-Dec-83 13:14") + (\DTEST A 'ARRAYP) + (SELECTC (fetch (ARRAYP TYP) of A) + (\ST.PTR2 (COND + ((fetch (ARRAYP READONLY) of A) + (LISPERROR "ILLEGAL ARG" A))) + (PROG [(BASE (fetch (ARRAYP BASE) of A)) + (N0 (IDIFFERENCE N (fetch (ARRAYP ORIG) of A] + (COND + ((OR (IGREATERP 0 N0) + (IGEQ N0 (fetch (ARRAYP LENGTH) of A))) + (LISPERROR "ILLEGAL ARG" N))) + (SETQ N0 (IPLUS N0 (fetch (ARRAYP OFFST) of A))) + (\RPLPTR (\ADDBASE2 (\ADDBASE2 BASE (fetch (ARRAYP LENGTH) of A)) + N0) + 0 V) + (RETURN V))) + (SETA A N V]) + +(SUBARRAY + [LAMBDA (X N M OLD NEWORIG) (* rmk%: "30-Dec-83 13:15") + (\DTEST X 'ARRAYP) + (PROG ((LEN (fetch (ARRAYP LENGTH) of X)) + (ORIG (fetch (ARRAYP ORIG) of X)) + (N1 N) + (M1 M)) (* ; + "N1 and M1 so don't reset user arg") + [COND + ((IGREATERP 0 N1) (* ; "Coerce the first index") + (SETQ N1 (IPLUS N1 LEN 1] + [COND + ((NULL M1) (* ; "Now coerce the second index") + (SETQ M1 LEN)) + ((IGREATERP 0 M1) + (SETQ M1 (IPLUS M1 LEN 1] (* ; + "Go uninterruptable to protect the OLD~=NIL case.") + (RETURN (AND (IGEQ N1 ORIG) + (ILEQ N1 M1) + (ILEQ M1 LEN) + (UNINTERRUPTABLY + (create ARRAYP smashing (OR (ARRAYP OLD) + (create ARRAYP)) + BASE _ (fetch (ARRAYP BASE) of X) + LENGTH _ (ADD1 (IDIFFERENCE M1 N1)) + TYP _ (fetch (ARRAYP TYP) of X) + OFFST _ (IDIFFERENCE (IPLUS (fetch + (ARRAYP OFFST) + of X) + N1) + ORIG) + ORIG _ ORIG))]) +) + + + +(* ; "HASHARRAY entries") + +(DEFINEQ + +(HARRAY + [LAMBDA (MINKEYS) (* rmk%: " 3-Jan-84 13:09") + + (* ;; "For backward compatibility--produces a non-growing hasharray") + + (HASHARRAY MINKEYS 'ERROR]) + +(HASHARRAY + [LAMBDA (MINKEYS OVERFLOW HASHBITSFN EQUIVFN RECLAIMABLE REHASH-THRESHOLD) + (* ; "Edited 3-Oct-91 13:35 by jds") + + (* ;; "MINKEYS is the number of required slots; actual number of slots is greater by the vacancy factor REHASH-THRESHOLD default 0.75 --- MINKEYS is first adjusted by the vacancy factor, then bumped up to the next highest power of 2, so that hashkey can be computed with LOGAND instead of IREMAINDER.") + + [COND + ((FIXP REHASH-THRESHOLD) (* ; "Scale it") + (SETQ REHASH-THRESHOLD (AND (FIXP OVERFLOW) + (ILESSP REHASH-THRESHOLD OVERFLOW) + (FQUOTIENT REHASH-THRESHOLD OVERFLOW] + (LET ((PHYSLOTS (OR (bind [IDEALSIZE _ (IMAX MINKEYS + (IMIN (- (FOLDLO \MaxArrayNCells CELLSPERSLOT) + 2) + (COND + (REHASH-THRESHOLD + (FIXR (FQUOTIENT (SUB1 MINKEYS) + REHASH-THRESHOLD))) + (T (LLSH (IQUOTIENT (SUB1 MINKEYS) + 3) + 2] find I from 8 + to 16384 by I suchthat (IGREATERP I IDEALSIZE)) + [for I from [IMAX MINKEYS (IMIN 32749 (- (FOLDLO \MaxArrayNCells + CELLSPERSLOT) + 2) + (COND + (REHASH-THRESHOLD + (FIXR (FQUOTIENT (SUB1 MINKEYS) + REHASH-THRESHOLD))) + (T (LLSH (IQUOTIENT (SUB1 MINKEYS) + 3) + 2] to 32749 + suchthat + + (* ;; "Find a prime table-size between our ideal and the maximum, which is 32749 (largest prime < array limit)") + + (for J from 2 to (FIXR (SQRT I)) + never (ZEROP (IREMAINDER I J] + 32768)) + LOGSLOTS NCELLS) + (SETQ NCELLS (UNFOLD PHYSLOTS CELLSPERSLOT)) + (COND + ((IGREATERP NCELLS \MaxArrayNCells) + (ERROR "HARRAY TOO LARGE" MINKEYS)) + (T [SETQ LOGSLOTS (COND + (REHASH-THRESHOLD (FIXR (FTIMES REHASH-THRESHOLD PHYSLOTS))) + (T (IPLUS (LRSH PHYSLOTS 1) + (LRSH PHYSLOTS 2] (* ; + "Number of logical slots is REHASH-THRESHOLD * number of physical slots") + (create HARRAYP + HARRAYPBASE _ (\ALLOCBLOCK NCELLS PTRBLOCK.GCT) + LASTINDEX _ (SUB1 PHYSLOTS) + RECLAIMABLE _ RECLAIMABLE + OVERFLOWACTION _ OVERFLOW + NUMSLOTS _ LOGSLOTS + NULLSLOTS _ LOGSLOTS + NUMKEYS _ 0 + HASHBITSFN _ HASHBITSFN + EQUIVFN _ EQUIVFN]) + +(HARRAYP + [LAMBDA (X) (* rmk%: "21-Dec-83 22:20") + (AND (type? HARRAYP X) + X]) + +(HARRAYPROP + [LAMBDA NARGS (* bvm%: "21-Jan-86 11:02") + (* ; + "Nospread so we can tell whether a new value was specified") + (PROG ((HARRAY (AND (IGREATERP NARGS 0) + (ARG NARGS 1))) + (PROP (AND (IGREATERP NARGS 1) + (ARG NARGS 2))) + (NEWVALP (IGREATERP NARGS 2)) + HA NEWVALUE) + (SETQ HA (\DTEST HARRAY 'HARRAYP)) (* ; + "Keep HARRAY explicitly so can tell LISTP case") + (AND NEWVALP (SETQ NEWVALUE (ARG NARGS 3))) + [RETURN (SELECTQ PROP + (SIZE (AND NEWVALP (GO CANTUPDATE)) + (HARRAYSIZE HA)) + (OVERFLOW [COND + [(LISTP HARRAY) (* ; + "For compatibility with old code that would enlist the hasharray") + (PROG1 (CDR HARRAY) + (AND NEWVALP (RPLACD HARRAY NEWVALUE)))] + (T (PROG1 (fetch (HARRAYP OVERFLOWACTION) of HA) + (AND NEWVALP (replace (HARRAYP OVERFLOWACTION) + of HA with NEWVALUE)))]) + (NUMKEYS (AND NEWVALP (GO CANTUPDATE)) + (fetch (HARRAYP NUMKEYS) of HA)) + (EQUIVFN (PROG1 (fetch (HARRAYP EQUIVFN) of HA) + [AND NEWVALP (COND + ((NEQ (fetch (HARRAYP NUMKEYS) + of HA) + 0) (* ; + "Absurd to change equivalence relation in midstream") + (GO CANTUPDATE)) + (T (replace (HARRAYP EQUIVFN) of + HA + with NEWVALUE])) + (RECLAIMABLE (PROG1 (fetch (HARRAYP RECLAIMABLE) of HA) + (AND NEWVALP (replace (HARRAYP RECLAIMABLE) + of HA with NEWVALUE)))) + (HASHBITSFN (PROG1 (fetch (HARRAYP HASHBITSFN) of HA) + [AND NEWVALP (COND + ((NEQ (fetch (HARRAYP NUMKEYS) + of HA) + 0) + (GO CANTUPDATE)) + (T (replace (HARRAYP HASHBITSFN) + of HA with NEWVALUE])) + (PROG1 (LISTGET (SETQ HARRAY (fetch (HARRAYP HASHUSERDATA) of + HA)) + PROP) + [AND NEWVALP (COND + ((NULL HARRAY) + (replace (HARRAYP HASHUSERDATA) of HA + with (LIST PROP NEWVALUE))) + (T (LISTPUT HARRAY PROP NEWVALUE])] + CANTUPDATE + (ERROR "Can't update this hash array property" PROP]) + +(HARRAYSIZE + [LAMBDA (HARRAY) (* rmk%: "21-Dec-83 23:33") + (fetch NUMSLOTS of (\DTEST HARRAY 'HARRAYP]) + +(CLRHASH + [LAMBDA (HARRAY) (* bvm%: "21-Jan-86 11:32") + (PROG ((HA (\DTEST HARRAY 'HARRAYP)) + SLOT) + (SETQ SLOT (fetch HARRAYPBASE of HA)) + (UNINTERRUPTABLY + (bind [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT + SLOT + (fetch (HARRAYP + LASTINDEX) + of HA] + do (replace (HASHSLOT KEY) of SLOT with NIL) + (replace (HASHSLOT VALUE) of SLOT with NIL) + repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT)) + LASTSLOT)) + (replace (HARRAYP NULLSLOTS) of HA with (fetch (HARRAYP + NUMSLOTS) + of HA)) + (replace (HARRAYP NUMKEYS) of HA with 0)) + (RETURN HARRAY]) + +(MAPHASH + [LAMBDA (HARRAY MAPHFN) (* bvm%: "21-Jan-86 11:28") + (DECLARE (LOCALVARS . T)) + (LET ((HA (\DTEST HARRAY 'HARRAYP)) + SLOT) + (SETQ SLOT (fetch HARRAYPBASE of HA)) + (bind V [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) of (\HASHSLOT SLOT + (fetch (HARRAYP + LASTINDEX) + of HA] + (NULLVALUE _ \HASH.NULL.VALUE) when (SETQ V (fetch (HASHSLOT VALUE) + of SLOT)) + do (APPLY* MAPHFN (AND (NEQ V NULLVALUE) + V) + (fetch (HASHSLOT KEY) of SLOT)) + repeatuntil (EQ (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT)) + LASTSLOT) finally (RETURN HARRAY]) + +(GETHASH + [LAMBDA (ITEM HARRAY DEFAULT RETURNMVS) (* ; "Edited 26-Feb-91 13:07 by jds") + +(* ;;; "RETURNMVS, if true return multiple values, else don't.") + + (PROG ((HA (\DTEST HARRAY 'HARRAYP)) + INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS EQFN ABASE VALUE) + [SETQ BITS (COND + ((SETQ BITS (fetch (HARRAYP HASHBITSFN) of HA)) + (APPLY* BITS ITEM)) + (T (\EQHASHINGBITS ITEM] + (SETQ INDEX (\FIRSTINDEX BITS HA)) (* ; + "Do first index outside of loop, so don't have to do setup on fast case") + (SETQ ABASE (fetch HARRAYPBASE of HA)) + (SETQ SLOT (\HASHSLOT ABASE INDEX)) + [COND + ((SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT)) + (* ; "Slot is occupied") + (COND + ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))) + (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA)) + (APPLY* EQFN ITEM SKEY))) + (GO FOUND))) (* ; "else try again") + ) + [(NULL (fetch (HASHSLOT KEY) of SLOT)) (* ; "Null slot") + (RETURN (COND + (RETURNMVS (CL:VALUES DEFAULT NIL)) + (T DEFAULT] + (T (* ; + "Deleted slot: null value, non-nil key") + (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA] + (* ; "Perhaps we hit right on") + (SETQ FIRSTINDEX INDEX) + (SETQ REPROBE (\REPROBE BITS HA)) (* ; "Compute reprobe interval") + (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA))) + LP (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE) + LIMIT)) + + (* ;; "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND") + + (COND + ((EQ INDEX FIRSTINDEX) (* ; + "Should never happen, since we don't allow full occupancy") + (SHOULDNT "Hashing in full hash table"))) + (SETQ SLOT (\HASHSLOT ABASE INDEX)) + (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)) + [COND + [(SETQ VALUE (fetch (HASHSLOT VALUE) of SLOT)) + (* ; "Slot is occupied") + (COND + ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)) + ITEM) + (AND EQFN (APPLY* EQFN ITEM SKEY))) (* ; "Found it") + (GO FOUND] + ((NULL (fetch (HASHSLOT KEY) of SLOT)) (* ; "Empty slot") + (RETURN (COND + (RETURNMVS (CL:VALUES DEFAULT NIL)) + (T DEFAULT] + (GO LP) + FOUND + (RETURN (COND + (RETURNMVS (CL:VALUES (AND (NEQ VALUE \HASH.NULL.VALUE) + VALUE) + T)) + (T (AND (NEQ VALUE \HASH.NULL.VALUE) + VALUE]) + +(PUTHASH + [LAMBDA (KEY VAL HARRAY) (* raf "22-Aug-86 16:55") + +(* ;;; "Store new value VAL, or remove old value if VAL = NIL") + + (\HASHACCESS KEY VAL HARRAY (NULL VAL)) + VAL]) + +(CL::PUTHASH + (CL:LAMBDA (KEY CL:HASH-TABLE VALUE &OPTIONAL (EXTRA NIL EXTRA-P)) + (* ; "Edited 23-Mar-87 12:00 by bvm:") + + (* ;; "SETF inverse for CL:GETHASH. Subtlety is that CL:GETHASH has an optional arg DEFAULT, so if you passed one of those 3-argument forms to SETF, you'd get 4 arguments in this call. In this case, the fourth argument is the new value and you should ignore the third.") + + (CL:CHECK-TYPE CL:HASH-TABLE CL:HASH-TABLE) + (\HASHACCESS KEY (CL:IF EXTRA-P + EXTRA + VALUE) + CL:HASH-TABLE NIL) + VALUE)) + +(REMHASH + [LAMBDA (KEY HARRAY) (* bvm%: "20-Jan-86 18:54") + (\HASHACCESS KEY NIL HARRAY T]) + +(\HASHRECLAIM + [LAMBDA (HARRAY) (* bvm%: "21-Jan-86 11:36") + +(* ;;; "Remove from HARRAY any keys whose ref cnt is 1") + + (PROG ((HA (\DTEST HARRAY 'HARRAYP)) + SLOT) + (SETQ SLOT (fetch (HARRAYP HARRAYPBASE) of HA)) + (UNINTERRUPTABLY + (bind KEY [LASTSLOT _ (fetch (HASHSLOT NEXTSLOT) + of (\HASHSLOT SLOT (fetch (HARRAYP LASTINDEX) + of HA] + (NUMDELETED _ 0) when (AND (SETQ KEY (fetch (HASHSLOT KEY) of SLOT)) + (NEQ KEY T) + (\EQREFCNT1 KEY)) + do (* ; + "Slot is occupied with key with ref cnt 1, so delete it") + (replace (HASHSLOT KEY) of SLOT with T) + (replace (HASHSLOT VALUE) of SLOT with NIL) + (add NUMDELETED 1) repeatuntil (EQ LASTSLOT (SETQ SLOT + (fetch (HASHSLOT + NEXTSLOT) + of SLOT))) + finally (replace (HARRAYP NUMKEYS) of HA + with (IDIFFERENCE (fetch (HARRAYP NUMKEYS) of HA) + NUMDELETED)))) + (RETURN HARRAY]) + +(\HASHACCESS + [LAMBDA (ITEM VAL HARRAY REMOVE) (* ; "Edited 26-Feb-91 13:16 by jds") + +(* ;;; "Add or remove something from hash array HARRAY -- REMOVE = T means remove the item, which is necessarily distinct from adding a VAL = NIL") + + (PROG ((HA (\DTEST HARRAY 'HARRAYP)) + DELSLOT INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT BITS HASHBITSFN EQFN ABASE) + [SETQ BITS (COND + ((SETQ HASHBITSFN (fetch (HARRAYP HASHBITSFN) of HA)) + (APPLY* HASHBITSFN ITEM)) + (T (\EQHASHINGBITS ITEM] + PHTOP + (SETQ INDEX (\FIRSTINDEX BITS HA)) (* ; + "Handle first probe outside loop in case it wins") + (SETQ ABASE (fetch HARRAYPBASE of HA)) + (SETQ SLOT (\HASHSLOT ABASE INDEX)) + [COND + ((fetch (HASHSLOT VALUE) of SLOT) (* ; "Slot is occupied") + (COND + ((OR (EQ ITEM (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT))) + (AND (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA)) + (APPLY* EQFN ITEM SKEY))) + (GO FOUND))) (* ; "else try again") + ) + ((NULL (fetch (HASHSLOT KEY) of SLOT)) (* ; "Null slot") + (GO ADDNEWENTRY)) + (T (* ; + "Deleted slot: null value, non-nil key") + (SETQ DELSLOT SLOT) + (SETQ EQFN (fetch (HARRAYP EQUIVFN) of HA] + (SETQ FIRSTINDEX INDEX) + (SETQ REPROBE (\REPROBE BITS HA)) + (SETQ LIMIT (ADD1 (fetch (HARRAYP LASTINDEX) of HA))) + LP (SETQ INDEX (IREMAINDER (IPLUS INDEX REPROBE) + LIMIT)) + (COND + ((EQ INDEX FIRSTINDEX) + + (* ;; "We don't allow full occupancy, so if we get to the beginning without finding an empty slot, we must have found a deleted one") + + (SETQ SLOT (OR DELSLOT (ERROR "No vacant slot in hasharray"))) + (GO ADDNEWENTRY))) + (SETQ SLOT (\HASHSLOT ABASE INDEX)) + [COND + [(fetch (HASHSLOT VALUE) of SLOT) (* ; "Slot is occupied") + (COND + ((OR (EQ (SETQ SKEY (fetch (HASHSLOT KEY) of SLOT)) + ITEM) + (AND EQFN (APPLY* EQFN ITEM SKEY))) (* ; "Found it") + (GO FOUND] + (T (COND + ((NULL (fetch (HASHSLOT KEY) of SLOT)) + + (* ;; "NIL as both key and value means empty slot. New entry goes here, unless there was an earlier deleted slot") + + (AND DELSLOT (SETQ SLOT DELSLOT)) + (GO ADDNEWENTRY)) + ((NULL DELSLOT) (* ; + "Key non-NIL but value NIL means deleted.") + (SETQ DELSLOT SLOT] + (GO LP) + FOUND + (UNINTERRUPTABLY + [COND + (REMOVE (* ; + "Deleted slots are noted by value = NIL and key non-NIL") + (replace (HASHSLOT KEY) of SLOT with T) + (replace (HASHSLOT VALUE) of SLOT with NIL) + (add (fetch (HARRAYP NUMKEYS) of HA) + -1)) + (T + (* ;; "If writing value NIL must write distinguished non-NIL value. Ultimately, this should be a non-interned symbol, so that nobody could mistakenly type it (!) but it still wouldn't be ref counted (in present world)") + + (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE]) + (RETURN T) + ADDNEWENTRY + (* ; + "Didn't find this item in table. If REMOVE is T, nothing to do.") + (COND + (REMOVE (RETURN NIL))) + (COND + ((EQ 0 (fetch (HARRAYP NULLSLOTS) of HA)) + (COND + ((fetch (HARRAYP RECLAIMABLE) of HA) + (* ; + "Before rehashing, remove anything with ref cnt 1") + (\HASHRECLAIM HA))) + (SETQ HARRAY (HASHOVERFLOW (OR HARRAY SYSHASHARRAY))) + (SETQ HA (\DTEST HARRAY 'HARRAYP)) + + (* ;; "ERRORX2 doesn't handle SYSHASHARRAY specially; on 10, SYSHASHARRAY is rehashed directly in PUTHASH, without going through ERRORX2 and independent of the normal LISTP conventions.") + + (SETQ DELSLOT NIL) (* ; + "Non-NIL DELSLOT is a pointer into the old array") + (GO PHTOP))) + (UNINTERRUPTABLY + (OR (EQ SLOT DELSLOT) + (add (fetch (HARRAYP NULLSLOTS) of HA) + -1)) + (add (fetch (HARRAYP NUMKEYS) of HA) + 1) + (replace (HASHSLOT KEY) of SLOT with ITEM) + (replace (HASHSLOT VALUE) of SLOT with (OR VAL \HASH.NULL.VALUE))) + (RETURN VAL]) + +(REHASH + [LAMBDA (OLDAR NEWAR) (* rmk%: "26-Dec-83 11:50") + (CLRHASH NEWAR) + (PROG [SLOT LASTSLOT V (APTR1 (\DTEST OLDAR 'HARRAYP] (* ; "This is maphash expanded out") + (SETQ SLOT (fetch HARRAYPBASE of APTR1)) + (SETQ LASTSLOT (\ADDBASE4 SLOT (fetch (HARRAYP LASTINDEX) of APTR1))) + LP (COND + ((SETQ V (fetch (HASHSLOT VALUE) of SLOT)) + (PUTHASH (fetch (HASHSLOT KEY) of SLOT) + V NEWAR))) + (COND + ((EQ SLOT LASTSLOT) + (RETURN NEWAR))) + (SETQ SLOT (fetch (HASHSLOT NEXTSLOT) of SLOT)) + (GO LP]) + +(\COPYHARRAYP + [LAMBDA (SOURCE TARGET) (* rmk%: "31-Dec-83 13:58") + + (* ;; "Copies all properties of SOURCE into TARGET; called from HASHOVERFLOW") + + (replace NULLSLOTS of TARGET with (fetch NULLSLOTS of SOURCE)) + (replace LASTINDEX of TARGET with (fetch LASTINDEX of SOURCE)) + (replace HARRAYPBASE of TARGET with (fetch HARRAYPBASE of SOURCE)) + (replace OVERFLOWACTION of TARGET with (fetch OVERFLOWACTION of SOURCE)) + (replace NUMSLOTS of TARGET with (fetch NUMSLOTS of SOURCE)) + (replace NUMKEYS of TARGET with (fetch NUMKEYS of SOURCE]) + +(\HASHTABLE.DEFPRINT + [LAMBDA (CL:HASH-TABLE STREAM) (* ; "Edited 23-Mar-87 11:38 by bvm:") + + (* ;; "For benefit of common lisp, print harrayp by name %"hash table%", for example, #") + + [.SPACECHECK. STREAM (CONSTANT (+ (NCHARS "") + (PROGN (* ; "Longest address is `177,177777'") + 10] + (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) + (\SOUT ")) (* ; + "Return T to say we printed it ourselves") + T]) +) +(DEFINEQ + +(STRINGHASHBITS + [LAMBDA (STRING) (* ; "Edited 2-Mar-89 14:11 by jds") + (MISCN STRINGHASHBITS STRING]) + +(STRING-EQUAL-HASHBITS + [LAMBDA (STRING) (* ; "Edited 2-Mar-89 14:14 by jds") + +(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.") + +(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.") + + (MISCN STRING-EQUAL-HASHBITS STRING]) +) +(DEFINEQ + +(\STRINGHASHBITS-UFN + [LAMBDA (INDEX ARGCOUNT ARG-PTR) (* ; "Edited 2-Mar-89 14:06 by jds") + + (* ;; "UFN for the STRINGHASHBITS MISCN opcode. Computes a hash index for strings and symbols, so identical string CONTENTS hash to the same place.") + + (LET ((STRING (\GETBASEPTR ARG-PTR 0))) + (for C inpname STRING bind (HASHBITS _ 0) + do (* ; + "This is similar to the atom hash algorithm") + [SETQ HASHBITS (IPLUS16 C (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS + (LLSH (LOGAND HASHBITS + 4095) + 2))) + (LLSH (LOGAND HASHBITS 255) + 8] finally (RETURN HASHBITS]) + +(\STRING-EQUAL-HASHBITS-UFN + [LAMBDA (INDEX ARGCOUNT ARG-PTR) (* ; "Edited 2-Mar-89 14:09 by jds") + +(* ;;; "A hashbits function for the hash equivalence STRING-EQUAL.") + +(* ;;; "This is similar to the atom hash algorithm, but we OR in 40Q to cause uppercase and lowercase chars to have the same codes.") + + (LET ((STRING (\GETBASEPTR ARG-PTR 0))) + (for C inpname STRING bind (HASHBITS _ 0) + do [SETQ HASHBITS (IPLUS16 (LOGOR C 32) + (IPLUS16 (SETQ HASHBITS (IPLUS16 HASHBITS + (LLSH (LOGAND HASHBITS 4095) + 2))) + (LLSH (LOGAND HASHBITS 255) + 8] finally (RETURN HASHBITS]) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(DATATYPE HARRAYP ((NULLSLOTS WORD) (* ; + "Number of NIL-NIL slots, which break chains") + (LASTINDEX WORD) (* ; "Slot offset of last slot. Used in probe computations computations. Microcode support for \ADDBASE4 would help") + (HARRAYPBASE POINTER) + (RECLAIMABLE FLAG) (* ; + "True if keys can go away when no other refs") + (OVERFLOWACTION POINTER) + (NUMSLOTS WORD) (* ; + "The maximum number of logical slots--returned by HARRAYSIZE") + (NUMKEYS WORD) (* ; + "The number of distinct keys in the array") + (HASHBITSFN POINTER) + (EQUIVFN POINTER) + (HASHUSERDATA POINTER))) +) + +(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER) + '((HARRAYP 0 (BITS . 15)) + (HARRAYP 1 (BITS . 15)) + (HARRAYP 2 POINTER) + (HARRAYP 2 (FLAGBITS . 0)) + (HARRAYP 4 POINTER) + (HARRAYP 6 (BITS . 15)) + (HARRAYP 7 (BITS . 15)) + (HARRAYP 8 POINTER) + (HARRAYP 10 POINTER) + (HARRAYP 12 POINTER)) + '14) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \EQHASHINGBITS MACRO (OPENLAMBDA (X) (* ; + "Spread out objects whose low bits are in small arithmetic progression, esp atoms") + (LOGXOR (\HILOC X) + (LOGXOR (LLSH (LOGAND (\LOLOC X) + 8191) + 3) + (LRSH (\LOLOC X) + 9] +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD HASHSLOT ((KEY POINTER) + (VALUE POINTER)) + [ACCESSFNS ((NEXTSLOT (\ADDBASE DATUM (UNFOLD WORDSPERCELL CELLSPERSLOT]) +) + +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \FIRSTINDEX MACRO ((BITS APTR1) + (IREMAINDER BITS (ADD1 (fetch (HARRAYP LASTINDEX) of APTR1] + +(PUTPROPS \HASHSLOT MACRO (= . \ADDBASE4)) + +(PUTPROPS \REPROBE MACRO ((BITS HA) + (LOGOR [IREMAINDER (LOGXOR BITS (LRSH BITS 8)) + (IMIN 64 (ADD1 (fetch (HARRAYP LASTINDEX) + of HA] + 1))) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ CELLSPERSLOT 2) + + +(CONSTANTS (CELLSPERSLOT 2)) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \HASH.NULL.VALUE SYSHASHARRAY) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(DEFPRINT 'HARRAYP '\HASHTABLE.DEFPRINT) +) + +(/DECLAREDATATYPE 'HARRAYP '(WORD WORD POINTER FLAG POINTER WORD WORD POINTER POINTER POINTER) + '((HARRAYP 0 (BITS . 15)) + (HARRAYP 1 (BITS . 15)) + (HARRAYP 2 POINTER) + (HARRAYP 2 (FLAGBITS . 0)) + (HARRAYP 4 POINTER) + (HARRAYP 6 (BITS . 15)) + (HARRAYP 7 (BITS . 15)) + (HARRAYP 8 POINTER) + (HARRAYP 10 POINTER) + (HARRAYP 12 POINTER)) + '14) +(ADDTOVAR SYSTEMRECLST + +(DATATYPE HARRAYP ((NULLSLOTS WORD) + (LASTINDEX WORD) + (HARRAYPBASE POINTER) + (RECLAIMABLE FLAG) + (OVERFLOWACTION POINTER) + (NUMSLOTS WORD) + (NUMKEYS WORD) + (HASHBITSFN POINTER) + (EQUIVFN POINTER) + (HASHUSERDATA POINTER))) +) + +(RPAQQ \HASH.NULL.VALUE \Hash\Null\Value\) + + + +(* ; "System entries for CODE") + +(DEFINEQ + +(\CODEARRAY + [LAMBDA (NBYTES INITONPAGE) (* lmm "15-Aug-84 11:51") + (PROG NIL + + (* ;; "NBYTES is the number of bytes required, INITONPAGE is the number of CELLS which must reside on same page") + + (COND + ((OR (IGREATERP 0 NBYTES) + (IGREATERP NBYTES 65535)) + (LISPERROR "ILLEGAL ARG" NBYTES))) (* ; + "dolphin requires code blocks aligned quadword") + (RETURN (create ARRAYP + TYP _ \ST.CODE + BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) + CODEBLOCK.GCT INITONPAGE CELLSPERQUAD) + LENGTH _ NBYTES + ORIG _ 0]) + +(\FIXCODENUM + [LAMBDA (CA BN NUM MASK) (* ; "Edited 7-Jan-91 13:29 by jds") + (DECLARE (IGNORE MASK)) (* ; + "MASK is used by the renamed version of this function.") + + (* ;; "Do fixup for a 2-byte number in the code stream. Used for type numbers only, for now.") + + (PROG ((BASE (fetch (ARRAYP BASE) of CA))) + (\PUTBASEBYTE BASE BN (LOGAND 255 NUM)) + (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN)) + (LOGOR (\GETBASEBYTE BASE BN) + (LRSH NUM 8))) + (RETURN NUM]) + +(\FIXCODEPTR + [LAMBDA (CA BN PTR MASK) (* ; + "Edited 12-Nov-92 17:03 by sybalsky:mv:envos") + (DECLARE (IGNORE MASK)) (* ; + "MASK is used by the renamed version of this function.") + (PROG ((BASE (fetch (ARRAYP BASE) of CA)) + (LO (\LOLOC PTR))) + (UNINTERRUPTABLY + (\ADDREF PTR) + (\PUTBASEBYTE BASE BN (LOGAND LO 255)) + (\PUTBASEBYTE BASE (SUB1 BN) + (LRSH LO 8)) + (\PUTBASEBYTE BASE (IDIFFERENCE BN 2) + (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2)) + (LOGAND (\HILOC PTR) + 255))) + (\PUTBASEBYTE BASE (IDIFFERENCE BN 3) + (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3)) + (LRSH (\HILOC PTR) + 8)))) + (RETURN PTR]) + +(\FIXCODESYM + [LAMBDA (CA BN SYM MASK) (* ; + "Edited 13-Nov-92 04:56 by sybalsky:mv:envos") + (DECLARE (IGNORE MASK)) (* ; + "MASK is used by the renamed version of this function.") + + (* ;; "Perform fix-up for a symbol in an IL-Compiled function -- either 2 or 4 bytes, depending on the architecture.") + + (* ;; "CA -- the code array") + + (* ;; "BN -- byte number of the low-order byte to be fixed up") + + (* ;; "SYM -- the symbol, expressed as a FIXP or a NEW-ATOM.") + + (NEW-SYMBOL-CODE (PROG (HIBYTE NUM (BASE (fetch (ARRAYP BASE) of CA))) + + (* ;; "For 3-byte-symbol machines, handle 3 bytes worth of atom number.") + + [COND + ((SMALLP SYM) + (SETQ NUM SYM) + (SETQ HIBYTE 0)) + ((FIXP SYM) + (SETQ NUM (LOGAND SYM 65535)) + (SETQ HIBYTE (LRSH SYM 16))) + (T (SETQ NUM (\LOLOC SYM)) + (SETQ HIBYTE (\HILOC SYM] + (UNINTERRUPTABLY + (\PUTBASEBYTE BASE BN (LOGAND NUM 255)) + (\PUTBASEBYTE BASE (SUB1 BN) + (LOGAND (LRSH NUM 8) + 255)) + (\PUTBASEBYTE BASE (IDIFFERENCE BN 2) + (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 2)) + (LOGAND HIBYTE 255))) + (\PUTBASEBYTE BASE (IDIFFERENCE BN 3) + (LOGOR (\GETBASEBYTE BASE (IDIFFERENCE BN 3)) + (LRSH HIBYTE 8)))) + (RETURN (+ (LLSH HIBYTE 16) + NUM))) + (PROG ((NUM (\LOLOC SYM)) + (BASE (fetch (ARRAYP BASE) of CA))) + + (* ;; "2-BYTE case: Just fill it in.") + + (\PUTBASEBYTE BASE BN (LOGAND 255 NUM)) + (\PUTBASEBYTE BASE (SETQ BN (SUB1 BN)) + (LOGOR (\GETBASEBYTE BASE BN) + (LRSH NUM 8))) + (RETURN NUM]) +) + + + +(* ; "Internal") + +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS EQPTR DMACRO (= . EQ)) + +(PUTPROPS BUCKETINDEX MACRO ((N) + (IMIN (INTEGERLENGTH N) + \MAXBUCKETINDEX))) + +[PUTPROPS FREEBLOCKCHAIN.N MACRO ((N) + (\ADDBASE2 \FREEBLOCKBUCKETS (BUCKETINDEX N] +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \MAXBUCKETINDEX 30) + + +(CONSTANTS \MAXBUCKETINDEX) +) + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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))) +(DECLARE%: EVAL@COMPILE + +(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)))) +(DECLARE%: EVAL@COMPILE + +(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))) +(DECLARE%: EVAL@COMPILE + +(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)) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \MAX.CELLSPERHUNK 64) + + +(CONSTANTS \MAX.CELLSPERHUNK) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \IN.MAKEINIT NIL) + + +(CONSTANTS (\IN.MAKEINIT)) +) +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD SEQUENCEDESCRIPTOR ((ORIG BITS 1) + (NIL BITS 1) + (READONLY FLAG) + (NIL BITS 1) + (BASE POINTER) + (TYP BITS 4) + (NIL BITS 4) + (LENGTH BITS 24) + (OFFST FIXP))) + +(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)))) +) + +(/DECLAREDATATYPE 'ARRAYP '((BITS 1) + (BITS 1) + FLAG + (BITS 1) + POINTER + (BITS 4) + (BITS 4) + (BITS 24) + FIXP) + '((ARRAYP 0 (BITS . 0)) + (ARRAYP 0 (BITS . 16)) + (ARRAYP 0 (FLAGBITS . 32)) + (ARRAYP 0 (BITS . 48)) + (ARRAYP 0 POINTER) + (ARRAYP 2 (BITS . 3)) + (ARRAYP 2 (BITS . 67)) + (ARRAYP 2 (LONGBITS . 135)) + (ARRAYP 4 FIXP)) + '6) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \NxtArrayPage \FREEBLOCKBUCKETS \HUNKING?) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \ArrayFrLst \ArrayFrLst2 \RECLAIM.COUNTDOWN) +) +) +(DEFINEQ + +(\ALLOCBLOCK + [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* bvm%: " 7-Feb-85 15:30") + + (* ;; "NCELLS is number of cells wanted not counting overhead cell. For code arrays, INITONPAGE is number of cells to be kept on a single page. It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty. --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed. NIL defaults to UNBOXEDBLOCK.GCT") + + (DECLARE (GLOBALVARS \ArrayFrLst)) + (COND + ((ILESSP NCELLS \ArrayBlockLinkingCells) + (COND + ((ILESSP NCELLS 0) + (\ILLEGAL.ARG NCELLS))) + (SETQ NCELLS \ArrayBlockLinkingCells)) + ((IGREATERP NCELLS \MaxArrayNCells) + (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; + "NCELLS is number of data cells; remember for allocation counter below") + (SELECTQ GCTYPE + (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT)) + (T (SETQ GCTYPE PTRBLOCK.GCT)) + NIL) (* ; + "This SELECTQ can be removed when all callers are upgraded to constants") + (COND + ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) + (IGREATERP INITONPAGE CELLSPERPAGE))) + (\ILLEGAL.ARG INITONPAGE))) + (COND + ((NULL ALIGN)) + ((OR (ILESSP ALIGN 0) + (IGREATERP ALIGN CELLSPERPAGE)) + (\ILLEGAL.ARG ALIGN)) + ((ILEQ ALIGN 1) + (SETQ ALIGN)) + ((AND INITONPAGE (PROGN (* ; + "Some check for consistency between ALIGN and INITONPAGE is needed here") + NIL)) + (ERROR "INITONPAGE and ALIGN too high"))) + (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK) + (\ALLOCHUNK NCELLS GCTYPE INITONPAGE ALIGN)) + (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)) + ABLOCK) + RETRY + (UNINTERRUPTABLY + (* ; "Comment PPLossage") + (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN) + (\ALLOCBLOCK.NEW ARLEN GCTYPE INITONPAGE ALIGN) + (PROGN (FRPTQ 10 (RECLAIM)) + + (* ;; "We're probably out of array space; our last chance is to collect and hope something shows up on the free list.") + + (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN)) + (GO FULL))) (* ; + "ABLOCK now points to the beginning of the actual block of storage to be used") + (replace (ARRAYBLOCK INUSE) of ABLOCK with T) + (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of + ABLOCK) + with T) + (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE) + (\CHECKARRAYBLOCK ABLOCK NIL) + (.INCREMENT.ALLOCATION.COUNT. NCELLS) (* ; + "NCELLS because CREATEREF accounts for overhead cell") + (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords)) + (\CREATEREF ABLOCK) + (RETURN ABLOCK)) + FULL + (LISPERROR "ARRAYS FULL" NIL T) (* ; + "User might release something, so retry.") + (GO RETRY]) + +(\MAIKO.ALLOCBLOCK + [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* ; "Edited 29-Jun-90 12:17 by ON") + + (* ;; "Maiko specific \ALLOCBLOCK. Does not decrement \RECLAIM.COUNTDOWN.") + + (* ;; "NCELLS is number of cells wanted not counting overhead cell. For code arrays, INITONPAGE is number of cells to be kept on a single page. It might be necessary to flag a block with an aligned indicator, to help a compacting garbage collector preserve the align proprty. --- Does not assume that caller is uninterruptable --- Returns NIL if NCELLS = 0 --- GCTYPE is one of the constants PTRBLOCK.GCT, CODEBLOCK.GCT, UNBOXEDBLOCK.GCT, indicating any special behavior to be performed when the block is reclaimed. NIL defaults to UNBOXEDBLOCK.GCT") + + (DECLARE (GLOBALVARS \ArrayFrLst)) + (COND + ((ILESSP NCELLS \ArrayBlockLinkingCells) + (COND + ((ILESSP NCELLS 0) + (\ILLEGAL.ARG NCELLS))) + (SETQ NCELLS \ArrayBlockLinkingCells)) + ((IGREATERP NCELLS \MaxArrayNCells) + (\LISPERROR NCELLS "ARRAY STORAGE BLOCK TOO LARGE")))(* ; + "NCELLS is number of data cells; remember for allocation counter below") + (SELECTQ GCTYPE + (NIL (SETQ GCTYPE UNBOXEDBLOCK.GCT)) + (T (SETQ GCTYPE PTRBLOCK.GCT)) + NIL) (* ; + "This SELECTQ can be removed when all callers are upgraded to constants") + + (* ;; "Maiko doesn't have to worry about INITONPAGE. ----- '90/06/29 on.") + + (* ;; "(COND ((AND INITONPAGE (OR (ILESSP INITONPAGE 0) (IGREATERP INITONPAGE CELLSPERPAGE))) (\ILLEGAL.ARG INITONPAGE)))") + + (COND + ((NULL ALIGN)) + ((OR (ILESSP ALIGN 0) + (IGREATERP ALIGN CELLSPERPAGE)) + (\ILLEGAL.ARG ALIGN)) + ((ILEQ ALIGN 1) + (SETQ ALIGN)) + ((AND INITONPAGE (PROGN (* ; + "Some check for consistency between ALIGN and INITONPAGE is needed here") + NIL)) + (ERROR "INITONPAGE and ALIGN too high"))) + (OR (AND \HUNKING? (ILEQ NCELLS \MAX.CELLSPERHUNK) (* ; + "Maiko doesn't have to worry about INITONPAGE so call \ALLOCHUNK with arg INITONPAGE as NIL.") + (\ALLOCHUNK NCELLS GCTYPE NIL ALIGN)) + (PROG ((ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells)) + ABLOCK) + RETRY + (UNINTERRUPTABLY + (* ; "Comment PPLossage") + (SETQ ABLOCK (OR (\ALLOCBLOCK.OLD ARLEN GCTYPE NIL ALIGN) + (\ALLOCBLOCK.NEW ARLEN GCTYPE NIL ALIGN) + (PROGN (FRPTQ 10 (RECLAIM)) + + (* ;; "We're probably out of array space; our last chance is to collect and hope something shows up on the free list.") + + (\ALLOCBLOCK.OLD ARLEN GCTYPE INITONPAGE ALIGN)) + (GO FULL))) (* ; + "ABLOCK now points to the beginning of the actual block of storage to be used") + (replace (ARRAYBLOCK INUSE) of ABLOCK with T) + (replace (ARRAYBLOCK INUSE) of (fetch (ARRAYBLOCK TRAILER) of + ABLOCK) + with T) + (replace (ARRAYBLOCK GCTYPE) of ABLOCK with GCTYPE) + (\CHECKARRAYBLOCK ABLOCK NIL) + (.CHECK.ALLOCATION.COUNT. NCELLS) + (SETQ ABLOCK (\ADDBASE ABLOCK \ArrayBlockHeaderWords)) + (PROG1 (\DELREF ABLOCK) + (.CHECK.ALLOCATION.COUNT. 1)) + (RETURN ABLOCK)) + FULL + (LISPERROR "ARRAYS FULL" NIL T) (* ; + "User might release something, so retry.") + (GO RETRY]) + +(\ALLOCBLOCK.OLD + [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (* bvm%: "15-Feb-85 11:01") + + (* ;; "Returns a block of the right size and alignment, or NIL if one couldn't be found.") + + (for BKTI from (BUCKETINDEX ARLEN) to \MAXBUCKETINDEX bind ABLOCK + when (AND (SETQ ABLOCK (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI) + 0)) + (bind (1STBLOCK.IN.FREECHAIN _ ABLOCK) + USABLELEN REMAINDERLEN PREFIXLEN + repeatuntil (EQ (SETQ ABLOCK (fetch (ARRAYBLOCK FWD) of ABLOCK)) + 1STBLOCK.IN.FREECHAIN) + when (PROGN [COND + ((OR (NEQ (fetch (ARRAYBLOCK PASSWORD) of ABLOCK) + \ArrayBlockPassword) + (NEQ (fetch (ARRAYBLOCK PASSWORD) + of (fetch (ARRAYBLOCK TRAILER) + of ABLOCK)) + \ArrayBlockPassword)) + (RETURN (\MP.ERROR \MP.BADARRAYBLOCK "Bad Array Block" + ABLOCK] + (SETQ PREFIXLEN (COND + ((OR ALIGN INITONPAGE) + (\PREFIXALIGNMENT? ARLEN INITONPAGE + ALIGN GCTYPE ABLOCK)) + (T 0))) + (IGEQ (SETQ USABLELEN (IDIFFERENCE (fetch (ARRAYBLOCK + ARLEN) + of ABLOCK) + PREFIXLEN)) + ARLEN)) + do (\CHECKARRAYBLOCK ABLOCK T T) + (\DELETEBLOCK? ABLOCK) (* ; "take it off the free list") + [COND + ((NEQ PREFIXLEN 0) (* ; + "We must split off a bit initially, in order to preserve the INITONPAGE request") + (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK ABLOCK PREFIXLEN)) + (SETQ ABLOCK (\ADDBASE2 ABLOCK PREFIXLEN] + (SETQ REMAINDERLEN (IDIFFERENCE USABLELEN ARLEN)) + (COND + [(IGREATERP REMAINDERLEN (COND + (\HUNKING? (IPLUS \MAX.CELLSPERHUNK + \ArrayBlockOverheadCells + )) + (T 0))) + (* ; + "Split off any extra space from the end of the block.") + (\MERGEFORWARD (\LINKBLOCK (\MAKEFREEARRAYBLOCK + (\ADDBASE2 ABLOCK ARLEN) + REMAINDERLEN] + (\HUNKING? (* ; + "Coerce the length upwards so as not to have a runt block") + (SETQ ARLEN USABLELEN))) + (COND + ((OR (NEQ PREFIXLEN 0) + (NEQ USABLELEN ARLEN)) (* ; + "If we changed the length of the block, store the new length now") + (\MAKEFREEARRAYBLOCK ABLOCK ARLEN))) + (\CHECKARRAYBLOCK ABLOCK T) + (\CLEARCELLS (\ADDBASE ABLOCK \ArrayBlockHeaderWords) + (IDIFFERENCE ARLEN \ArrayBlockOverheadCells)) + (* ; "clear out old garbage") + (* ; "signal that we found one") + (RETURN T))) do (RETURN ABLOCK]) + +(\ALLOCBLOCK.NEW + [LAMBDA (ARLEN GCTYPE INITONPAGE ALIGN) (* ; "Edited 25-Apr-94 15:09 by jds") + (DECLARE (GLOBALVARS \ArrayFrLst \NxtArrayPage)) + + (* ;; "Patch up a new section of memory beginning at the end of current arrayspace, and make it a freeblock for subsequent usage. Also used to increment to the next page/segment boundary when allocating code arrays") + + (PROG (FINALWORD FINALPAGE NEXTFREEBLOCK PREFIXLEN) + RETRY + [COND + ([AND (OR INITONPAGE ALIGN) + (NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE ALIGN GCTYPE + \ArrayFrLst](* ; + "Gobble up a modest amount of space in order to insure correct alignment.") + (COND + ((SETQ PREFIXLEN (\ALLOCBLOCK.NEW PREFIXLEN)) + (\MERGEBACKWARD PREFIXLEN) (* ; + "Problem: what happens if array space switch happened inside this \ALLOCBLOCK.NEW ?") + ) + (T (RETURN] + (SETQ FINALWORD (\ADDBASE (\ADDBASE \ArrayFrLst ARLEN) + (SUB1 ARLEN))) + + (* ;; "FINALWORD is pointer to the last word of the new block. The new \ArrayFrLst will be one past that, i.e., at (\ADDBASE2 \ArrayFrLst ARLEN) -- The double \ADDBASE avoids large integer arithmetic and computing FINALWORD first avoids negative arguments to \ADDBASE") + + (SETQ NEXTFREEBLOCK (\ADDBASE FINALWORD 1)) + [COND + ((IGREATERP (SETQ FINALPAGE (fetch (POINTER PAGE#) of FINALWORD)) + (IDIFFERENCE \NxtMDSPage \GUARDSTORAGEFULL)) + (* ; + "Make sure that there are enough pages to satisfy this request before we make any global changes.") + (SELECTQ (\CHECKFORSTORAGEFULL (ADD1 (IDIFFERENCE FINALPAGE \NxtArrayPage))) + (T (* ; "Is ok, go ahead")) + (0 (* ; "Is ok, but \NxtArrayPage moved.") + (GO RETRY)) + (RETURN NIL] + + (* ;; "\NxtArrayPage is the page after the page of FINALWORD, the next one that needs to be \NEWPAGEd. \ArrayFrLst's page will be (SUB1 \NxtArrayPage) except when it is allowed to be EQ to the first word on \NxtArrayPage") + + [until (IGREATERP \NxtArrayPage FINALPAGE) + do (\MAKEMDSENTRY \NxtArrayPage 0) + (\NEW2PAGE (create POINTER + PAGE# _ \NxtArrayPage)) + (UNLESSINEW (\PUTBASEFIXP \NxtArrayPage 0 (IPLUS \NxtArrayPage 2)) + (SETQ \NxtArrayPage (IPLUS \NxtArrayPage 2] + (RETURN (PROG1 (\MAKEFREEARRAYBLOCK \ArrayFrLst ARLEN) + (SETQ.NOREF \ArrayFrLst NEXTFREEBLOCK]) + +(\PREFIXALIGNMENT? + [LAMBDA (ARLEN INITONPAGE ALIGN GCTYPE BASE) (* Pavel "16-Oct-86 14:15") + + (* ;; "how many cells must be added to to the base address of BASE to get a block whose first data word is aligned according to ALIGN and which has its first INITONPAGE cells all on one page") + + (PROG ((DAT (fetch (POINTER CELLINSEGMENT) of (\ADDBASE BASE \ArrayBlockHeaderWords))) + (ADJUSTMENT 0) + FUDGE) + + (* ;; "DAT will hold the cell-in-segment offset of the first dataword of the arrayblock; it is this first dataword which must be aligned etc rather than the true beginning of the block.") + + LP (COND + ((AND ALIGN (NEQ (SETQ FUDGE (IREMAINDER DAT ALIGN)) + 0)) (* ; + "Not aligned, so adjust first for that.") + (add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE ALIGN FUDGE))) + (add DAT FUDGE))) + (COND + ((AND INITONPAGE (NEQ (FLOOR DAT CELLSPERPAGE) + (FLOOR (IPLUS DAT INITONPAGE -1) + CELLSPERPAGE))) (* ; + "There aren't INITONPAGE cells on the page, so go to next page boundary") + [add ADJUSTMENT (SETQ FUDGE (IDIFFERENCE CELLSPERPAGE (IMOD DAT CELLSPERPAGE] + (add DAT FUDGE) + + (* ;; "No need to realign at this point. ALIGN must be a power of two, so it's either an alignment less than CELLSPERPAGE, in which case this page boundary satisfies it, or it's a multiple of CELLSPERPAGE, in which case the first COND satisfied it and we didn't have to touch it in this COND") + + )) + (COND + ([AND (EQ GCTYPE CODEBLOCK.GCT) + (IGREATERP (IDIFFERENCE ARLEN \ArrayBlockOverheadCells) + (SETQ FUDGE (IDIFFERENCE CELLSPERSEGMENT (SETQ DAT (IMOD DAT + CELLSPERSEGMENT] + + (* ;; "Code arrays cannot cross segment boundaries. Note that ARLEN includes the overhead cells, hence the extra subtraction.") + + (add ADJUSTMENT FUDGE) + (add DAT FUDGE) + + (* ;; "No need to re-check the alignment since ALIGN and INITONPAGE are both guaranteed satisified by a block starting on a segment boundary") + + )) + + (* ;; "The following code claims to prevent splitting off too small a block, but it's not clear this is intrinsically bad, and the code does not appear to do anything rational. -- bvm --- (COND ((AND (NEQ ADJUSTMENT 0) \HUNKING? (IGREATERP (SETQ FUDGE (IDIFFERENCE (IPLUS \MAX.CELLSPERHUNK \ArrayBlockOverheadCells) ADJUSTMENT)) 0) (PROGN (* * Account for potential merging backwards when this initial piece is split off.) (AND (EQ (fetch (ARRAYBLOCK PASSWORD) of (SETQ PREVTRAILER (\ADDBASE BASE (IMINUS \ArrayBlockTrailerCells)))) \ArrayBlockPassword) (NOT (fetch (ARRAYBLOCK INUSE) of PREVTRAILER)) (ILESSP (fetch (ARRAYBLOCK ARLEN) of PREVTRAILER) FUDGE)))) (* Just to ensure that we don't break up a large arrayblocks into two pieces one of which is too small to be usable.) (add ADJUSTMENT FUDGE) (SETQ DAT (IPLUS DAT FUDGE)) (* Go around again, since this function wouldn't have been called unless one of INITONPAGE or ALIGN were non-null.) (GO LP)))") + + (RETURN ADJUSTMENT]) + +(\MAKEFREEARRAYBLOCK + [LAMBDA (BLOCK LENGTH) (* lmm "25-Jul-84 13:07") + (replace (ARRAYBLOCK ABFLAGS) of BLOCK with \FreeArrayFlagWord) + (replace (ARRAYBLOCK ARLEN) of BLOCK with LENGTH) + (replace (ARRAYBLOCK ABFLAGS) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) + with \FreeArrayFlagWord) + (replace (ARRAYBLOCK ARLEN) of (fetch (ARRAYBLOCK TRAILER) of BLOCK) with + LENGTH) + BLOCK]) + +(\DELETEBLOCK? + [LAMBDA (BASE) (* bvm%: "15-Feb-85 11:04") + (COND + ((AND (IGEQ (fetch (ARRAYBLOCK ARLEN) of BASE) + \MinArrayBlockSize) + (fetch (ARRAYBLOCK FWD) of BASE)) (* ; + "Allegedly, BASE has been 'checked' before coming here.") + (PROG [(F (fetch (ARRAYBLOCK FWD) of BASE)) + (B (fetch (ARRAYBLOCK BKWD) of BASE)) + (FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE] + (COND + ((EQ BASE F) + (COND + ((EQ BASE (\GETBASEPTR FBL 0)) + (\PUTBASEPTR FBL 0 NIL)) + (T (\MP.ERROR \MP.BADDELETEBLOCK "deleting last block # FREEBLOCKLIST"))) + (RETURN)) + ((EQ BASE (\GETBASEPTR FBL 0)) + (\PUTBASEPTR FBL 0 F))) + (replace (ARRAYBLOCK BKWD) of F with B) + (replace (ARRAYBLOCK FWD) of B with F]) + +(\LINKBLOCK + [LAMBDA (BASE) (* JonL "16-Jan-85 02:46") + + (* ;; "Add BASE to the free list. Assumes that BASE is a well-formed free block.") + + [COND + (\FREEBLOCKBUCKETS (COND + ((ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE) + \MinArrayBlockSize) + (\CHECKARRAYBLOCK BASE T)) + (T (PROG ((FBL (FREEBLOCKCHAIN.N (fetch ARLEN of BASE))) + FREEBLOCK) + (SETQ FREEBLOCK (\GETBASEPTR FBL 0)) + (COND + ((NULL FREEBLOCK) + (replace (ARRAYBLOCK FWD) of BASE with BASE) + (replace (ARRAYBLOCK BKWD) of BASE with BASE)) + (T (replace (ARRAYBLOCK FWD) of BASE with + FREEBLOCK + ) + (replace (ARRAYBLOCK BKWD) of BASE + with (fetch (ARRAYBLOCK BKWD) of FREEBLOCK + )) + (replace (ARRAYBLOCK FWD) of (fetch + (ARRAYBLOCK BKWD) + of FREEBLOCK) + with BASE) + (replace (ARRAYBLOCK BKWD) of FREEBLOCK + with BASE))) + (\PUTBASEPTR FBL 0 BASE) + (\CHECKARRAYBLOCK BASE T T] + BASE]) + +(\MERGEBACKWARD + [LAMBDA (BASE) (* bvm%: " 6-Feb-85 16:53") + + (* ;; "Caller is uninterruptable and asserts that a non-NIL BASE is a free but unlinked arrayblock. We return a linked (if possible) block, either BASE itself or an enlarged previous free block that is linked (if possible) and includes the BASE storage.") + + (PROG (ARLEN PARLEN PBASE PTRAILER SPLIT) + [COND + ((NULL BASE) + (RETURN NIL)) + ([OR (NOT \ARRAYMERGING) + (EQ BASE \ARRAYSPACE) + (EQ BASE \ARRAYSPACE2) + (fetch (ARRAYBLOCK INUSE) of (SETQ PTRAILER (\ADDBASE BASE (IMINUS + \ArrayBlockTrailerWords + ] + + (* ;; "If this is the absolute 'first' block of array space, then there is nothing behind it to merge; similarly, if the block behind it is in use, then don't merge.") + + (RETURN (\LINKBLOCK BASE] + [SETQ PBASE (\ADDBASE2 BASE (IMINUS (fetch (ARRAYBLOCK ARLEN) of PTRAILER] + (\CHECKARRAYBLOCK PBASE T) + (\DELETEBLOCK? PBASE) + (RETURN (\ARRAYBLOCKMERGER PBASE BASE]) + +(\MERGEFORWARD + [LAMBDA (BASE) (* bvm%: "15-Feb-85 11:18") + + (* ;; "BASE is a free and linked (if possible) block. Merge with the next block if it is free and not too big. Caller must be uninterruptable.") + + (PROG (NBASE NBINUSE) + (COND + ((OR (NOT \ARRAYMERGING) + (NULL BASE) + (\CHECKARRAYBLOCK BASE T T) + (EQ (SETQ NBASE (\ADDBASE2 BASE (fetch (ARRAYBLOCK ARLEN) of BASE))) + \ArrayFrLst) + (EQ NBASE \ArrayFrLst2) + [\CHECKARRAYBLOCK NBASE (NOT (SETQ NBINUSE (fetch (ARRAYBLOCK INUSE) + of NBASE] + NBINUSE) + (RETURN NIL))) (* ; + "Note that if we ever get to here, both blocks have been 'checked'") + (\DELETEBLOCK? NBASE) + (\DELETEBLOCK? BASE) + (\ARRAYBLOCKMERGER BASE NBASE]) + +(\ARRAYBLOCKMERGER + [LAMBDA (BASE NBASE) (* bvm%: "13-Feb-85 14:57") + +(* ;;; "BASE and NBASE are two consecutive unlinked freeblocks. (Called only after the two blocks have been 'checked')") + + (PROG ((ARLEN (fetch (ARRAYBLOCK ARLEN) of BASE)) + (NARLEN (fetch (ARRAYBLOCK ARLEN) of NBASE)) + SECONDBITE MINBLOCKSIZE SHAVEBACK) + (SETQ SECONDBITE (IDIFFERENCE \MaxArrayBlockSize ARLEN)) + (COND + ((IGREATERP NARLEN SECONDBITE) + + (* ;; "check if sum of NARLEN+ARLEN is leq maximum. (Written this way to stay within small number range.) If not, then break up into two freeblocks since one can't hold all the cells.") + + (SETQ ARLEN \MaxArrayBlockSize) + (SETQ NARLEN (IDIFFERENCE NARLEN SECONDBITE)) + + (* ;; "Normal overflow case is just to make the first block as big as possible, then leave the rest in the second block. So the code above adds to ARLEN and subtracts from NARLEN an equal amount to achieve the desired split. However, check that the remaining NBASE block is not too small") + + (COND + ([ILESSP NARLEN (SETQ MINBLOCKSIZE (COND + (\HUNKING? (IPLUS \ArrayBlockOverheadCells + \MAX.CELLSPERHUNK)) + (T \MinArrayBlockSize] + + (* ;; "Decrease ARLEN and SECONDBITE by the amount it will take to get NARLEN up to MINBLOCKSIZE -- SHAVEBACK is negative") + + (SETQ SHAVEBACK (IDIFFERENCE NARLEN (SETQ NARLEN MINBLOCKSIZE))) + (add ARLEN SHAVEBACK) + (add SECONDBITE SHAVEBACK))) + + (* ;; "Okay, make a tail of the second block into a free block of its own") + + (\LINKBLOCK (\MAKEFREEARRAYBLOCK (\ADDBASE2 NBASE SECONDBITE) + NARLEN)) + (SETQ NARLEN 0))) + (RETURN (\LINKBLOCK (\MAKEFREEARRAYBLOCK BASE (IPLUS ARLEN NARLEN]) + +(\#BLOCKDATACELLS + [LAMBDA (DATAWORD) (* JonL "20-Sep-84 19:07") + + (* ;; "DATAWORD is a pointer as would be returned by \ALLOCBLOCK Returns the number of cells available to the caller. Compiled closed so that we can change internal representations without clients needing to be recompiled.") + + (PROG ((TYPENO (NTYPX DATAWORD))) + (RETURN (COND + [(EQ 0 TYPENO) + (COND + ((type? ARRAYBLOCK DATAWORD) + (IDIFFERENCE (fetch (ARRAYBLOCK ARLEN) of (\ADDBASE DATAWORD + (IMINUS + \ArrayBlockHeaderWords + ))) + \ArrayBlockOverheadCells)) + (T (\ILLEGAL.ARG DATAWORD] + (T (OR (AND (OR \HUNKING? (fetch DTDHUNKP of (\GETDTD TYPENO))) + (HUNKSIZEFROMNUMBER TYPENO)) + (\ILLEGAL.ARG DATAWORD]) + +(\COPYARRAYBLOCK + [LAMBDA (OLD) (* ; "Edited 3-Mar-87 22:28 by bvm:") + (LET [(HEADER (\ADDBASE OLD (IMINUS \ArrayBlockHeaderWords] + (COND + [(AND (IEQ \ArrayBlockPassword (fetch PASSWORD of HEADER)) + (fetch (ARRAYBLOCK INUSE) of HEADER)) + (LET* ((LEN (- (fetch (ARRAYBLOCK ARLEN) of HEADER) + \ArrayBlockOverheadCells)) + (TYP (fetch (ARRAYBLOCK GCTYPE) of HEADER)) + (NEW (\ALLOCBLOCK LEN TYP))) + (PROG1 NEW + (SELECTC TYP + (PTRBLOCK.GCT (* ; + "Have to reference count the pointers as we copy") + (FRPTQ LEN (\RPLPTR NEW 0 (COPYALL (\GETBASEPTR OLD 0))) + (SETQ NEW (\ADDBASE NEW WORDSPERCELL)) + (SETQ OLD (\ADDBASE OLD WORDSPERCELL)))) + (CODEBLOCK.GCT (* ; + "should increment references from code") + (\COPYCODEBLOCK NEW OLD (UNFOLD LEN WORDSPERCELL))) + (\BLT NEW OLD (UNFOLD LEN WORDSPERCELL))))] + (T (* ; "Not an array block") + OLD]) + +(\RECLAIMARRAYBLOCK + [LAMBDA (P) (* ; "Edited 8-Jan-88 18:31 by jop") + + (* ;; "Called to reclaim objects of type 0. This is called with interrupts turned off. Returns T to tell GC that we reclaimed it.") + + (PROG ((B (\ADDBASE P (IMINUS \ArrayBlockHeaderWords))) + (RECLAIM-P T)) + + (* ;; "B points to arrayblock header, P to first and subsequent data words") + + (IF (OR (< (\HILOC P) + \FirstArraySegment) + (NOT (IEQ \ArrayBlockPassword (fetch PASSWORD of B))) + (NOT (fetch (ARRAYBLOCK INUSE) of B))) + THEN + + (* ;; "RAID instead of \GCERROR because this error is continuable with ^N.") + + (\MP.ERROR \MP.BADARRAYRECLAIM + "Bad array block reclaimed--continue with ^N but save state ASAP") + (RETURN T)) + (SELECTC (fetch (ARRAYBLOCK GCTYPE) of B) + (PTRBLOCK.GCT (* ; "Release all pointers") + (for old P (TRAILER _ (fetch (ARRAYBLOCK TRAILER) + of B)) by (\ADDBASE P + WORDSPERCELL) + until (EQ P TRAILER) do (\RPLPTR P 0 NIL))) + (CODEBLOCK.GCT (* ; "Release literals") + + (* ;; "Since \reclaimcodeblock is a finalization function -- returns nil if do reclaim and t if don't reclaim") + + (SETQ RECLAIM-P (NOT (\RECLAIMCODEBLOCK P)))) + NIL) + [IF RECLAIM-P + THEN (\MERGEFORWARD (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK B + (fetch ARLEN of B] + + (* ;; "Always tell GC that we have reclaimed it") + + (RETURN T]) + +(\ADVANCE.ARRAY.SEGMENTS + [LAMBDA (NXTPAGE) (* ; "Edited 4-Jan-93 02:08 by jds") + +(* ;;; "Called when the first 8mb are exhausted, and we want to switch array space into the next area, starting with page NXTPAGE -- have to first clean up what's left in the old area") + + (PROG (NCELLSLEFT) + (SETQ.NOREF \ArrayFrLst2 (COND + ((IGEQ [SETQ NCELLSLEFT + (IPLUS (UNFOLD (SUB1 (IDIFFERENCE \NxtArrayPage + (fetch (POINTER PAGE#) + of \ArrayFrLst))) + CELLSPERPAGE) + (IDIFFERENCE CELLSPERPAGE (fetch + (POINTER CELLINPAGE) + of \ArrayFrLst] + \MinArrayBlockSize) + (* ; + "Make the rest of the already allocated array space into a small block") + (\MERGEBACKWARD (\MAKEFREEARRAYBLOCK \ArrayFrLst + NCELLSLEFT)) + (create POINTER + PAGE# _ \LeastMDSPage)) + (T \ArrayFrLst))) + [SETQ.NOREF \ARRAYSPACE2 (SETQ.NOREF \ArrayFrLst (create POINTER + PAGE# _ (\PUTBASEFIXP \NxtArrayPage + 0 NXTPAGE] + (* ; + "Return code to tell \ALLOCBLOCK.NEW to notice the new arrangement") + (RETURN 0]) +) + +(ADDTOVAR \MAIKO.MOVDS (\MAIKO.ALLOCBLOCK \ALLOCBLOCK)) +(DEFINEQ + +(\BYTELT + [LAMBDA (A J) (* JonL "20-Sep-84 20:01") + + (* ;; "A special function for system accesses to 0-origin byte arrays, of which syntax-tables are the primary example. This compiles open into a GETBASEBYTE, with no checking for argument validity!") + + (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP] + (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A)) + (EQ \ST.CODE (fetch (ARRAYP TYP) of A] + (LISPERROR "ILLEGAL ARG" A)) + (OR (IGREATERP (fetch (ARRAYP LENGTH) of A) + J) + (LISPERROR "ILLEGAL ARG" J)) + (\GETBASEBYTE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J]) + +(\BYTESETA + [LAMBDA (A J V) (* JonL "20-Sep-84 20:01") + + (* ;; "A special function for system setting of 0-origin byte arrays, of which syntax-tables are the primary example. This compiles open into a GETBASEBYTE, with no checking for argument validity! --- NOTE: The value is undefined, not V!") + + (OR [AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP] + (OR (EQ \ST.BYTE (fetch (ARRAYP TYP) of A)) + (EQ \ST.CODE (fetch (ARRAYP TYP) of A] + (LISPERROR "ILLEGAL ARG" A)) + (OR (IGREATERP (fetch (ARRAYP LENGTH) of A) + J) + (LISPERROR "ILLEGAL ARG" J)) + (AND (fetch (ARRAYP READONLY) of A) + (LISPERROR "ILLEGAL ARG" A)) + (\PUTBASEBYTE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J) + V]) + +(\WORDELT + [LAMBDA (A J) (* JonL "20-Sep-84 20:02") + + (* ;; "A special function for system accesses to 0-origin word arrays, This compiles open into a GETBASE, with no checking for argument validity!") + + (OR (AND [EQ 0 (fetch (ARRAYP ORIG) of (SETQ A (\DTEST A 'ARRAYP] + (EQ \ST.POS16 (fetch (ARRAYP TYP) of A))) + (LISPERROR "ILLEGAL ARG" A)) + (OR (IGREATERP (fetch (ARRAYP LENGTH) of A) + J) + (LISPERROR "ILLEGAL ARG" J)) + (\GETBASE (fetch (ARRAYP BASE) of A) + (IPLUS (fetch (ARRAYP OFFST) of A) + J]) +) +(DEFINEQ + +(\ARRAYTYPENAME + [LAMBDA (X) (* rmk%: "21-Dec-83 14:55") + + (* ;; + "This is called from the VM function TYPENAME to determine the 'logical' type of the array X") + + (SELECTC (fetch (ARRAYP TYP) of X) + (\ST.CODE 'CCODEP) + 'ARRAYP]) +) + +(RPAQQ \ARRAYMERGING T) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \ARRAYMERGING) +) + + + +(* ; "for STORAGE") + +(DEFINEQ + +(\SHOW.ARRAY.FREELISTS + [LAMBDA (SIZESLST) (* bvm%: "12-Feb-85 15:25") + (COND + ((OR SIZESLST (SETQ SIZESLST STORAGE.ARRAYSIZES)) + (RESETFORM (RECLAIMMIN MAX.SMALLP) + (PROG ((TABLE \ABSTORAGETABLE) + (N (LENGTH SIZESLST)) + (TOTAL 0) + FBL ABLOCK ARLEN) + [COND + ((OR (NOT (\BLOCKDATAP TABLE)) + (IGEQ N (FOLDLO (\#BLOCKDATACELLS TABLE) + 2))) + + (* ;; "Need bigger table if someone has enlarged SIZESLST since last time. There are 2 cells per table entry") + + (SETQ \ABSTORAGETABLE (SETQ TABLE (\ALLOCBLOCK (UNFOLD (IPLUS N 4) + 2) + UNBOXEDBLOCK.GCT] + (\CLEARCELLS TABLE (\#BLOCKDATACELLS TABLE)) + [for BKTI from 0 to \MAXBUCKETINDEX + do (COND + ((SETQ FBL (\GETBASEPTR (\ADDBASE2 \FREEBLOCKBUCKETS BKTI) + 0)) + (SETQ ABLOCK FBL) + (repeatuntil (EQ FBL (SETQ ABLOCK (fetch (ARRAYBLOCK + FWD) + of ABLOCK))) + do (add TOTAL (SETQ ARLEN (fetch (ARRAYBLOCK ARLEN) + of ABLOCK))) + (for (SAFENTRY _ TABLE) + by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL)) + as X in SIZESLST + when (OR (NULL X) + (ILEQ ARLEN X)) + do (add (fetch SAFITEMS of SAFENTRY) + 1) + (add (fetch SAFCELLS of SAFENTRY) + ARLEN) + (RETURN] + (printout NIL T " variable-datum free list: " T) + (for (SAFENTRY _ TABLE) by (\ADDBASE SAFENTRY (TIMES 2 WORDSPERCELL)) + as X in SIZESLST do (COND + (X (printout NIL "le " X)) + (T (printout NIL "others "))) + (printout NIL 10 .I8 (fetch SAFITEMS + of SAFENTRY) + " items; " .I8 (fetch SAFCELLS + of SAFENTRY) + " cells." T)) + (printout NIL T "Total cells free: " .I8 TOTAL " total pages: " .I4 + (FOLDHI TOTAL CELLSPERPAGE) + T T]) +) + +(RPAQ? \ABSTORAGETABLE NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \ABSTORAGETABLE) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD SAFTABLE ((SAFITEMS WORD) + (NIL WORD) + (SAFCELLS FIXP))) +) +) + + + +(* ; "Debugging and RDSYS") + +(DEFINEQ + +(\CHECKARRAYBLOCK + [LAMBDA (BASE FREE ONFREELIST) (* bvm%: "13-Feb-85 14:50") + (COND + (ARRAYBLOCKCHECKING (PROG (ERROR TRAILER) + (COND + ((NEQ (fetch (ARRAYBLOCK PASSWORD) of BASE) + \ArrayBlockPassword) + (SETQ ERROR "ARRAYBLOCK Password wrong")) + ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE) + (NOT FREE)) + (SETQ ERROR "ARRAYBLOCK INUSE bit set wrong")) + ((UNLESSRDSYS (AND FREE (NEQ (\REFCNT BASE) + 1)) + NIL) + (SETQ ERROR "Free ARRAYBLOCK with RefCnt not 1")) + ((NEQ (fetch (ARRAYBLOCK PASSWORD) + of (SETQ TRAILER (fetch (ARRAYBLOCK TRAILER) + of BASE))) + \ArrayBlockPassword) + (SETQ ERROR "ARRAYBLOCK Trailer password wrong")) + ((NEQ (fetch (ARRAYBLOCK ARLEN) of BASE) + (fetch (ARRAYBLOCK ARLEN) of TRAILER)) + (SETQ ERROR "ARRAYBLOCK Header and Trailer length don't match")) + ((NEQ (fetch (ARRAYBLOCK INUSE) of BASE) + (NOT FREE)) + (SETQ ERROR "ARRAYBLOCK Trailer INUSE bit set wrong")) + ((OR (NOT ONFREELIST) + (ILESSP (fetch (ARRAYBLOCK ARLEN) of BASE) + \MinArrayBlockSize)) + (* ; + "Remaining tests only for blocks on free list") + (RETURN)) + ((OR (NOT (EQPTR (fetch (ARRAYBLOCK FWD) + of (fetch (ARRAYBLOCK BKWD) + of BASE)) + BASE)) + (NOT (EQPTR (fetch (ARRAYBLOCK BKWD) + of (fetch (ARRAYBLOCK FWD) + of BASE)) + BASE))) + (SETQ ERROR "ARRAYBLOCK links fouled")) + [(bind (FBL _ (FREEBLOCKCHAIN.N (fetch (ARRAYBLOCK ARLEN) + of BASE))) + ROVER first (OR (SETQ ROVER (\GETBASEPTR FBL 0)) + (RETURN (SETQ ERROR + "Free block's bucket empty") + )) + do (AND (EQPTR ROVER BASE) + (RETURN)) + (\CHECKARRAYBLOCK ROVER T) + repeatuntil (EQ (SETQ ROVER (fetch (ARRAYBLOCK FWD) + of ROVER)) + (\GETBASEPTR FBL 0] + (T (* ; "Everything ok") + (RETURN))) + (UNLESSRDSYS (\MP.ERROR \MP.BADARRAYBLOCK ERROR BASE T) + (ERROR BASE ERROR)) + (RETURN ERROR]) + +(\PARSEARRAYSPACE + [LAMBDA (FN) (* bvm%: "16-Apr-86 17:05") + (COND + ((NEQ \ArrayFrLst2 \ARRAYSPACE2) (* ; "Array space is in two chunks") + (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst2) + (\PARSEARRAYSPACE1 FN \ARRAYSPACE2 \ArrayFrLst)) + (T (\PARSEARRAYSPACE1 FN \ARRAYSPACE \ArrayFrLst]) + +(\PARSEARRAYSPACE1 + [LAMBDA (FN START END) (* bvm%: " 9-Jan-85 17:10") + (for (ROVER _ START) repeatuntil [EQPTR END (SETQ ROVER (\ADDBASE2 ROVER + (fetch (ARRAYBLOCK + ARLEN) + of ROVER] + do (\CHECKARRAYBLOCK ROVER (NOT (fetch (ARRAYBLOCK INUSE) of ROVER)) + (AND (NOT (fetch (ARRAYBLOCK INUSE) of ROVER)) + (fetch (ARRAYBLOCK FWD) of ROVER))) + (AND FN (APPLY* FN ROVER (fetch (ARRAYBLOCK ARLEN) of ROVER) + (fetch (ARRAYBLOCK INUSE) of ROVER) + (fetch (ARRAYBLOCK GCTYPE) of ROVER]) +) + +(RPAQ? ARRAYBLOCKCHECKING ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS ARRAYBLOCKCHECKING) +) + + + +(* ; "Basic hunking") + +(DEFINEQ + +(\ALLOCHUNK + [LAMBDA (NCELLS GCTYPE INITONPAGE ALIGN) (* bvm%: "13-Jun-86 15:21") + (COND + ([AND ALIGN (OR (IGREATERP ALIGN \MAX.CELLSPERHUNK) + (NOT (FMEMB ALIGN (SELECTC GCTYPE + (UNBOXEDBLOCK.GCT + (CONSTANT (for X in \HUNK.UNBOXEDSIZES + when (AND (IGREATERP X 1) + (ILEQ X + \MAX.CELLSPERHUNK) + (POWEROFTWOP X)) + collect X))) + (PTRBLOCK.GCT (CONSTANT (for X in \HUNK.PTRSIZES + when (AND (IGREATERP + X 1) + (ILEQ X + \MAX.CELLSPERHUNK + ) + (POWEROFTWOP + X)) + collect X))) + (CODEBLOCK.GCT (CONSTANT (LIST CELLSPERQUAD))) + NIL] (* ; + "Certify that the alignment request is legitimate.") + (ERROR "Oddball alignment request" ALIGN))) + (PROG ((TYPENUM.TABLE (SELECTC GCTYPE + (UNBOXEDBLOCK.GCT + \UNBOXEDHUNK.TYPENUM.TABLE) + (CODEBLOCK.GCT \CODEHUNK.TYPENUM.TABLE) + (PTRBLOCK.GCT \PTRHUNK.TYPENUM.TABLE) + (SHOULDNT))) + (FAILCNT 0) + DTNUMBER HUNK HUNKSIZE ONPAGE STRADDLERS) + BEG [do (SETQ DTNUMBER (\GETBASEBYTE TYPENUM.TABLE NCELLS)) + (SETQ HUNKSIZE (HUNKSIZEFROMNUMBER DTNUMBER)) + repeatuntil (OR (NOT ALIGN) + (EQ 0 (IREMAINDER (FOLDLO (fetch DTDSIZE of (\GETDTD + DTNUMBER) + ) + WORDSPERCELL) + ALIGN)) + (COND + ((IGREATERP (SETQ NCELLS (ADD1 HUNKSIZE)) + \MAX.CELLSPERHUNK) + (GO LOSE)) + (T + + (* ;; "We're allowed to chunk up the size of the request in order to meet the alignment; ultimately we should top off at \MAX.CELLSPERHUNK") + + NIL] + LP (SETQ HUNK (CREATECELL DTNUMBER)) + (COND + ([OR (NULL INITONPAGE) + (ILESSP INITONPAGE (SETQ ONPAGE (IDIFFERENCE CELLSPERPAGE (fetch (POINTER + CELLINPAGE) + of HUNK] + (* ; + "Ah, happy case -- all constraints satisfied") + (RETURN HUNK))) + + (* ;; "Sigh, gotta try to get one with more of the initial `run' of cells on the same page.") + + (COND + (\IN.MAKEINIT (* ; "Lose! Only code has an INITONPAGE requirement, and makeinit does not allocate code via \ALLOCBLOCK") + (HELP "Call to \ALLOCBLOCK with non-NIL INITONPAGE demand" INITONPAGE)) + (T (COND + ([AND (EQ GCTYPE CODEBLOCK.GCT) + (ILEQ (IQUOTIENT (ITIMES 10 ONPAGE) + HUNKSIZE) + (COND + ((ILEQ HUNKSIZE 24) + 60) + ((ILEQ HUNKSIZE 50) + 50) + (T 30] + + (* ;; "If the percentage of the page-straddling codehunk that is on the first page is too small, then just toss this loser into the `black hole' This heuristic is based on empirical data taken about Sep 1984 which observed the ratio of `on-page' requirements to code length.") + + (\ADDREF HUNK)) + (T (* ; + "So that a GC doesn't sneak in and put it back on the freelist too soon.") + (push STRADDLERS HUNK))) + (COND + ((IGREATERP (add FAILCNT 1) + 16) (* ; + "Put a limit to this nonsense of trying to find a non-page-straddling hunk!") + (GO LOSE)) + ((EQ FAILCNT 8) (* ; + "After too many failures with this size of hunk, try the next container size up.") + (SETQ NCELLS (ADD1 HUNKSIZE)) + (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS))) + (GO BEG))) + (GO LP))) + LOSE + (AND STRADDLERS (SETQ \HUNKREJECTS (NCONC STRADDLERS \HUNKREJECTS))) + (RETURN]) +) + +(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64)) + + + +(* ; "Compiler needs \HUNK.PTRSIZES for creating closure environments") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS HUNKSIZEFROMNUMBER MACRO ((NTYPX) + (FOLDLO (fetch DTDSIZE of (\GETDTD NTYPX)) + WORDSPERCELL))) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \HUNK.UNBOXEDSIZES + (1 2 3 4 5 6 7 8 9 10 12 14 16 20 24 28 32 40 48 64)) + +(RPAQQ \HUNK.CODESIZES (12 16 20 24 28 32 36 42 50 64)) + +(RPAQQ \HUNK.PTRSIZES (2 4 5 6 7 8 10 12 16 24 32 42 64)) + + +(CONSTANTS \HUNK.UNBOXEDSIZES \HUNK.CODESIZES \HUNK.PTRSIZES) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \HUNKING? \UNBOXEDHUNK.TYPENUM.TABLE \CODEHUNK.TYPENUM.TABLE \PTRHUNK.TYPENUM.TABLE) +) +) + + + +(* ;; +"Keep a list of all the hunks rejected due to poor page-straddling alignment, or to code falling off the end of a doublepage" +) + + +(RPAQQ \HUNKREJECTS NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \HUNKREJECTS) +) + + + +(* ; "for MAKEINIT") + +(DEFINEQ + +(PREINITARRAYS + [LAMBDA NIL (* bvm%: " 9-Jan-85 16:50") + + (* ;; "This is called only at the very beginning of MAKEINIT. \ARRAYspace and \ARRAYbase are INITCONSTANTS. This sets up the array allocator so that MAKEINIT can do, e.g., string allocations.") + + (DECLARE (GLOBALVARS \ArrayFrLst \ArrayFrLst2 \NxtArrayPage)) + (SETQ.NOREF \ArrayFrLst (\VAG2 \FirstArraySegment 0)) + (SETQ.NOREF \ArrayFrLst2 \ARRAYSPACE2) + (SETQ.NOREF \NxtArrayPage (PAGELOC \ArrayFrLst]) + +(POSTINITARRAYS + [LAMBDA (AFTERCODEPTR CODESTARTPAGE CODENEXTPAGE) (* bvm%: " 7-Feb-85 15:30") + + (* ;; "Called only from MAKEINIT after all code and data has been copied to the new image. AFTERCODEPTR is a pointer to the first word after the last code byte. CODESTARTPAGE is the page at which MAKEINIT code arrays being. This function makes sure that any unused space between the strings and the beginning of the code gets linked in as free arrayblocks.") + + (SETQ \FREEBLOCKBUCKETS (\ALLOCBLOCK (ADD1 \MAXBUCKETINDEX))) + (PROG [(EXTRACELLS (IDIFFERENCE (UNFOLD CODESTARTPAGE CELLSPERPAGE) + (IPLUS (UNFOLD (fetch SEGMENT# of \ArrayFrLst) + CELLSPERSEGMENT) + (fetch CELLINSEGMENT of \ArrayFrLst] + + (* ;; "First, tell the makeiniter how many pages were left over in the string space. He may want to adjust the constants to keep this down to just a couple of pages.") + + (COND + ((IGREATERP EXTRACELLS \MaxArrayBlockSize) + (printout T T T "POSTINITARRAYS: You pre-allocated too much string space." T 19 + "MKI.CODESTARTOFFSET on MAKEINIT should be reduced by about " + (IDIFFERENCE (FOLDLO EXTRACELLS CELLSPERPAGE) + 10) + "." T) + (HELP)) + ((IGEQ EXTRACELLS \MinArrayBlockSize) (* ; + "We don't allow more than one array-block extra.") + (printout T T T "POSTINITARRAYS: There were " (FOLDLO EXTRACELLS CELLSPERPAGE) + " allocated but unused array pages." T T)) + (T (printout T T "POSTINITARRAYS: String space overflowed into code-arrays" T 19 + "You should add at least " (ADD1 (FOLDLO (IMINUS EXTRACELLS) + CELLSPERPAGE)) + " to MKI.CODESTARTOFFSET on MAKEINIT." T) + (HELP))) (* ; + "Cause those pages to get allocated") + (\LINKBLOCK (\ALLOCBLOCK.NEW EXTRACELLS)) + (SETQ.NOREF \ArrayFrLst AFTERCODEPTR) (* ; + "\NxtArrayPage is the next page that needs to be NEWPAGEd") + (SETQ.NOREF \NxtArrayPage CODENEXTPAGE) + (for VP from (PAGELOC \ARRAYSPACE) to (PAGELOC \NxtArrayPage) + by (FOLDLO \MDSIncrement WORDSPERPAGE) do (\MAKEMDSENTRY VP 0]) + +(FILEARRAYBASE + [LAMBDA NIL (* rmk%: "15-MAR-82 21:55") + (\ADDBASE \ARRAYSPACE (LOCAL (IPLUS (UNFOLD MKI.CODESTARTOFFSET WORDSPERPAGE) + (FOLDLO (IDIFFERENCE (GETFILEPTR (OUTPUT)) + MKI.FirstDataByte) + BYTESPERWORD]) + +(FILEBLOCKTRAILER + [LAMBDA (BLOCKINFO) (* rmk%: "18-NOV-82 09:49") + + (* ;; + "Sets up block trailer, assuming file is currently positioned just past the last dataword") + + (BOUT16 OUTX \UsedArrayFlagWord) + (BOUT16 OUTX BLOCKINFO]) + +(FILECODEBLOCK + [LAMBDA (NCELLS INITONPAGE) (* JonL "20-Sep-84 13:29") + + (* ;; "sort of like CODEARRAY at MAKEINIT time for allocating space on the file; this code borrowed from CODEARRAY and \ALLOCBLOCK. Returns ARLEN, which is then passed to FILEBLOCKTRAILER to set trailer length.") + + (PROG (PREFIXLEN (ARLEN (IPLUS NCELLS \ArrayBlockOverheadCells))) + + (* ;; "ARLEN is the number of cells in the array . INITONPAGE is number of cells which must reside on same page") + + (COND + ([NEQ 0 (SETQ PREFIXLEN (\PREFIXALIGNMENT? ARLEN INITONPAGE CELLSPERQUAD + CODEBLOCK.GCT (FILEARRAYBASE] + + (* ;; "Check page first, cause if we did segment first and succeeded but then failed on page, we would have to check segment again.") + + (FILEPATCHBLOCK PREFIXLEN))) + (BOUT16 OUTX \CodeArrayFlagWord) + (BOUT16 OUTX ARLEN) + (RETURN ARLEN]) + +(FILEPATCHBLOCK + [LAMBDA (ARLEN) (* rmk%: "18-NOV-82 09:50") + + (* ;; "like \PATCHBLOCK for array allocation on files at MAKEINIT time") + + (LOCAL (BOUT16 OUTX \FreeArrayFlagWord)) (* ; "in-use bit off, password set") + (LOCAL (BOUT16 OUTX ARLEN)) (* ; "number of cells in this block") + [COND + ((IGREATERP ARLEN \ArrayBlockHeaderCells) (* ; + "Assumes that header and trailer look alike, so that we only need one instance for a tiny block.") + (LOCAL (BOUTZEROS (UNFOLD (IDIFFERENCE ARLEN \ArrayBlockOverheadCells) + BYTESPERCELL))) (* ; "zeros for data words") + (LOCAL (BOUT16 OUTX \FreeArrayFlagWord)) (* ; "Set up trailer") + (LOCAL (BOUT16 OUTX ARLEN] + NIL]) +) + + + +(* ; "Hunk Initialization") + +(DEFINEQ + +(\SETUP.HUNK.TYPENUMBERS + [LAMBDA NIL (* ; "Edited 4-Mar-87 11:04 by bvm:") + +(* ;;; "Called before datatype table is initialized. We add to the list of initial datatypes (\built-in-system-types) entries for all the hunk types we will want.") + +(* ;;; "Note: the compiler knows about the pointer hunk names, so it is important to coordinate any future changes to \HUNK.PTRSIZES with the compiler.") + + (SETQ INITIALDTDCONTENTS (APPEND \BUILT-IN-SYSTEM-TYPES (\COMPUTE.HUNK.TYPEDECLS + \HUNK.PTRSIZES PTRBLOCK.GCT + '\PTRHUNK) + (\COMPUTE.HUNK.TYPEDECLS \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT + '\UNBOXEDHUNK) + (\COMPUTE.HUNK.TYPEDECLS \HUNK.CODESIZES CODEBLOCK.GCT + '\CODEHUNK]) + +(\COMPUTE.HUNK.TYPEDECLS + [LAMBDA (SIZELST GCTYPE PREFIX) (* ; "Edited 4-Mar-87 11:03 by bvm:") + + (* ;; "Add type entries to INITIALDTDCONTENTS for the hunks in SIZELST of type GCTYPE. PREFIX is the start of the name, e.g., \PTRHUNK. Entries are of the form (name size ptrs finalization)") + + (ALLOCAL (for HUNKSIZE in SIZELST BIND (FINAL _ (AND (EQ GCTYPE CODEBLOCK.GCT) + '\RECLAIMCODEBLOCK)) + until (> HUNKSIZE \MAX.CELLSPERHUNK) + collect (LIST (PACK* PREFIX HUNKSIZE) + (UNFOLD HUNKSIZE WORDSPERCELL) + (COND + ((EQ GCTYPE PTRBLOCK.GCT) + (* ; + "Compute DTDPTRS list, i.e., which fields are pointers (all of them)") + (for I from 0 by 2 + to (SUB1 (UNFOLD HUNKSIZE WORDSPERCELL)) collect + I))) + FINAL]) + +(\TURN.ON.HUNKING + [LAMBDA NIL (* bvm%: "13-Jun-86 17:27") + +(* ;;; "create all the datatypes, and the tables used to calculate a hunk datatype number from the allocation size request.") + + (SETQ \UNBOXEDHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.UNBOXEDSIZES UNBOXEDBLOCK.GCT + '\UNBOXEDHUNK)) + (SETQ \CODEHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.CODESIZES CODEBLOCK.GCT + '\CODEHUNK)) + (SETQ \PTRHUNK.TYPENUM.TABLE (\SETUP.TYPENUM.TABLE \HUNK.PTRSIZES PTRBLOCK.GCT '\PTRHUNK)) + (SETQ \HUNKING? T]) + +(\SETUP.TYPENUM.TABLE + [LAMBDA (SIZELST GCTYPE PREFIX) (* ; "Edited 5-Mar-87 10:12 by bvm:") + +(* ;;; "Create a table that maps from number of cells desired to the closest hunk size that fits for a given GCTYPE. SIZELST is list of sizes in cells. PREFIX is the datatype name prefix for this kind of hunk.") + + (for I from 0 to \MAX.CELLSPERHUNK bind (HUNKSIZE _ -1) + (SIZEL _ SIZELST) + (TABLE _ (\ALLOCBLOCK + (FOLDHI (IPLUS 4 \MAX.CELLSPERHUNK + ) + BYTESPERCELL) + UNBOXEDBLOCK.GCT)) + TNAME DTD DTNUMBER + do [COND + ((IGREATERP I HUNKSIZE) (* ; + "Advance to next quantum range in the SIZELST") + (SETQ HUNKSIZE (OR (FIXP (pop SIZEL)) + \MAX.CELLSPERHUNK)) + (SETQ TNAME (PACK* PREFIX HUNKSIZE)) + (COND + ((for old DTNUMBER from 1 as TYPE in (LOCAL + INITIALDTDCONTENTS + ) + when (EQ (LOCAL (CAR TYPE)) + TNAME) do + + (* ;; "Find the type number that has been assigned to this hunk type. Ordinarily would use \TYPENUMBERFROMNAME, but atoms haven't been initialized yet, so we can only talk locally") + + (RETURN DTNUMBER)) + (SETQ DTD (\GETDTD DTNUMBER)) + (replace DTDGCTYPE of DTD with GCTYPE) + (replace DTDHUNKP of DTD with T)) + (T (HELP "No type declaration for" TNAME] + (\PUTBASEBYTE TABLE I DTNUMBER) finally (RETURN TABLE]) +) +(DECLARE%: DONTCOPY + +(ADDTOVAR INITVALUES (\NxtArrayPage) + (\HUNKING?)) + +(ADDTOVAR INITPTRS (\FREEBLOCKBUCKETS) + (\ArrayFrLst) + (\ArrayFrLst2) + (\UNBOXEDHUNK.TYPENUM.TABLE) + (\CODEHUNK.TYPENUM.TABLE) + (\PTRHUNK.TYPENUM.TABLE)) + +(ADDTOVAR INEWCOMS (FNS \#BLOCKDATACELLS \PREFIXALIGNMENT? \ALLOCBLOCK \MAIKO.ALLOCBLOCK + \ALLOCBLOCK.NEW \MAKEFREEARRAYBLOCK \MERGEBACKWARD \LINKBLOCK \ALLOCHUNK) + (FNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER FILECODEBLOCK + FILEPATCHBLOCK) + (FNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING + \SETUP.TYPENUM.TABLE)) + +(ADDTOVAR MKI.SUBFNS (\IN.MAKEINIT . T) + (\ALLOCBLOCK.OLD . NILL) + (\MERGEFORWARD . NILL) + (\FIXCODENUM . I.FIXUPNUM) + (\FIXCODESYM . I.FIXUPSYM) + (\FIXCODEPTR . I.FIXUPPTR) + (\CHECKARRAYBLOCK . NILL) + (\ARRAYMERGING PROGN NIL)) + +(ADDTOVAR EXPANDMACROFNS \ADDBASE2 \ADDBASE4 HUNKSIZEFROMNUMBER BUCKETINDEX FREEBLOCKCHAIN.N) + +(ADDTOVAR RDCOMS (FNS \CHECKARRAYBLOCK \PARSEARRAYSPACE \PARSEARRAYSPACE1)) + +(ADDTOVAR RD.SUBFNS (EQPTR . EQUAL) + (ARRAYBLOCKCHECKING . T)) + +(ADDTOVAR RDPTRS (\FREEBLOCKBUCKETS)) + +(ADDTOVAR RDVALS (\ArrayFrLst) + (\ArrayFrLst2)) +EVAL@COMPILE + +(ADDTOVAR DONTCOMPILEFNS PREINITARRAYS POSTINITARRAYS FILEARRAYBASE FILEBLOCKTRAILER + FILECODEBLOCK FILEPATCHBLOCK) + +(ADDTOVAR DONTCOMPILEFNS \SETUP.HUNK.TYPENUMBERS \COMPUTE.HUNK.TYPEDECLS \TURN.ON.HUNKING + \SETUP.TYPENUM.TABLE) +) + + + +(* ; "Debugging aids") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \ArrayFrLst) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \ArrayBlockPassword 5461) + + +(CONSTANTS \ArrayBlockPassword) +) + + +(ADDTOVAR DONTCOMPILEFNS \HUNKFIT? \AB.NEXT \AB.BACK) +) +(DEFINEQ + +(\HUNKFIT? + [LAMBDA (N) (* JonL "15-Jan-85 00:48") + + (* ;; "Show how an MDS unit of 2 pages would accomodate chunks of size N cells.") + + (printout NIL T "Hunk size = " N " cells, " (IQUOTIENT (FOLDLO \MDSIncrement WORDSPERCELL) + N) + " fit in a MDS unit with " + (IREMAINDER (FOLDLO \MDSIncrement WORDSPERCELL) + N) + " cells left over." T .TAB 8 "('unit' is split with " (IREMAINDER CELLSPERPAGE N) + " cells kept on first page)" T) + T]) + +(\AB.NEXT + [LAMBDA (ABHI ABLO) (* JonL "10-Sep-84 05:04") + + (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of; alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.") + + (* ;; "Returns a 4-list; size of the next block, whether or not it is free, and the \HILOC and the \LOLOC of that block") + + [COND + [(AND (LISTP ABHI) + (NULL ABLO)) + [COND + ((AND (EQ 4 (LENGTH ABHI)) + (FIXP (CAR ABHI)) + (SELECTQ (CADR ABHI) + ((INUSE FREE) + T) + NIL)) (* ; + "Result is output of \AB.NEXT itself") + (SETQ ABHI (CDDR ABHI] + (COND + ((EQ 2 (LENGTH ABHI)) (* ; "A 2-list of \HILOC and \LOLOC") + (SETQ ABLO (CADR ABHI)) + (SETQ ABHI (CAR ABHI] + ((OR (EQ ABHI \ArrayFrLst) + (type? ARRAYBLOCK ABHI)) + (SETQ ABLO (\LOLOC ABHI)) + (SETQ ABHI (\HILOC ABHI] + (OR (IGEQ ABHI 0) + (ERROR "Negative segment number?" ABHI)) + (AND (IGREATERP ABHI (\HILOC \ArrayFrLst)) + (ERROR "Segment number too high?" ABHI)) + (OR (IGEQ ABLO 0) + (ERROR "Negative offset number?" ABLO)) + (PROG (PW SIZE SIZE.WORDS (ABADDR (\VAG2 ABHI ABLO))) + [PROGN (* ; "Checking on current block") + (SETQ PW (\GETBASE ABADDR 0)) + [COND + ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13)) + (SETQ ABADDR) + (ERROR "Array Password not found at this loc" (LIST ABHI ABLO] + (SETQ SIZE.WORDS (UNFOLD (SETQ SIZE (\GETBASE ABADDR 1)) + WORDSPERCELL)) + (COND + [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 2)) + 3 13)) + (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO) + (SETQ ABADDR] + ((NEQ SIZE (\GETBASE ABADDR (IDIFFERENCE SIZE.WORDS 1))) + (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO) + (SETQ ABADDR] + (SETQ ABADDR (\ADDBASE ABADDR SIZE.WORDS)) + (SETQ PW (\GETBASE ABADDR 0)) + [COND + ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13)) + (SETQ ABADDR) + (ERROR "Array Password not found at this loc" (LIST ABHI ABLO] + (RETURN (LIST (\GETBASE ABADDR 1) + (COND + ((ODDP PW) + 'INUSE) + (T 'FREE)) + (\HILOC ABADDR) + (\LOLOC ABADDR]) + +(\AB.BACK + [LAMBDA (ABHI ABLO) (* JonL " 9-Sep-84 16:28") + + (* ;; "ABHI and ABLO form the \HILOC and \LOLOC of some arrayblock which we want to 'go' to the predecessor of; alternatively, ABHI can be a list of these two address parts, or just a random arrayblock address.") + + (* ;; "Returns a 4-list; size of the block we are starting from, whether or not it is free, and the \HILOC and the \LOLOC of the predecessor block") + + [COND + [(AND (LISTP ABHI) + (NULL ABLO)) + [COND + ((AND (EQ 4 (LENGTH ABHI)) + (FIXP (CAR ABHI)) + (SELECTQ (CADR ABHI) + ((INUSE FREE) + T) + NIL)) (* ; + "Result is output of \AB.BACK itself") + (SETQ ABHI (CDDR ABHI] + (COND + ((EQ 2 (LENGTH ABHI)) (* ; "A 2-list of \HILOC and \LOLOC") + (SETQ ABLO (CADR ABHI)) + (SETQ ABHI (CAR ABHI] + ((OR (EQ ABHI \ArrayFrLst) + (type? ARRAYBLOCK ABHI)) + (SETQ ABLO (\LOLOC ABHI)) + (SETQ ABHI (\HILOC ABHI] + (OR (IGEQ ABHI 0) + (ERROR "Negative segment number?" ABHI)) + (AND (IGREATERP ABHI (\HILOC \ArrayFrLst)) + (ERROR "Segment number too high?" ABHI)) + (OR (IGEQ ABLO 0) + (ERROR "Negative offset number?" ABLO)) + (PROG (PW SIZE (ABADDR (\ADDBASE (\VAG2 ABHI ABLO) + -2))) + (SETQ PW (\GETBASE ABADDR 0)) + [COND + ((NEQ \ArrayBlockPassword (LOADBYTE PW 3 13)) + (SETQ ABADDR) + (ERROR "Array Password not found just below this" (LIST ABHI ABLO] + (SETQ SIZE (\GETBASE ABADDR 1)) + [SETQ ABADDR (\ADDBASE ABADDR (IMINUS (UNFOLD (SUB1 SIZE) + WORDSPERCELL] + [COND + [(NEQ \ArrayBlockPassword (LOADBYTE (\GETBASE ABADDR 0) + 3 13)) + (ERROR "Array Password not found just below this" (PROG1 (LIST ABHI ABLO) + (SETQ ABADDR] + ((NEQ SIZE (\GETBASE ABADDR 1)) + (ERROR "Header and Trailer lengths disagree" (PROG1 (LIST ABHI ABLO) + (SETQ ABADDR] + (RETURN (LIST SIZE (COND + ((ODDP PW) + 'INUSE) + (T 'FREE)) + (\HILOC ABADDR) + (\LOLOC ABADDR]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA CL::PUTHASH HARRAYPROP) +) +(PUTPROPS LLARRAYELT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 +1990 1991 1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (9739 22117 (AIN 9749 . 12022) (AOUT 12024 . 14626) (ARRAY 14628 . 20213) (ARRAYSIZE +20215 . 20355) (ARRAYTYP 20357 . 20953) (ARRAYORIG 20955 . 21122) (COPYARRAY 21124 . 22115)) (22283 +29928 (ELT 22293 . 23722) (ELTD 23724 . 24649) (SETA 24651 . 26908) (SETD 26910 . 27904) (SUBARRAY +27906 . 29926)) (29963 55572 (HARRAY 29973 . 30193) (HASHARRAY 30195 . 34218) (HARRAYP 34220 . 34369) +(HARRAYPROP 34371 . 38406) (HARRAYSIZE 38408 . 38573) (CLRHASH 38575 . 39947) (MAPHASH 39949 . 41078) +(GETHASH 41080 . 44660) (PUTHASH 44662 . 44893) (CL::PUTHASH 44895 . 45607) (REMHASH 45609 . 45754) ( +\HASHRECLAIM 45756 . 47539) (\HASHACCESS 47541 . 53303) (REHASH 53305 . 54029) (\COPYHARRAYP 54031 . +54761) (\HASHTABLE.DEFPRINT 54763 . 55570)) (55573 56129 (STRINGHASHBITS 55583 . 55740) ( +STRING-EQUAL-HASHBITS 55742 . 56127)) (56130 58192 (\STRINGHASHBITS-UFN 56140 . 57246) ( +\STRING-EQUAL-HASHBITS-UFN 57248 . 58190)) (62479 67574 (\CODEARRAY 62489 . 63319) (\FIXCODENUM 63321 + . 63986) (\FIXCODEPTR 63988 . 65048) (\FIXCODESYM 65050 . 67572)) (79255 114491 (\ALLOCBLOCK 79265 . +83264) (\MAIKO.ALLOCBLOCK 83266 . 87458) (\ALLOCBLOCK.OLD 87460 . 92331) (\ALLOCBLOCK.NEW 92333 . +95339) (\PREFIXALIGNMENT? 95341 . 98884) (\MAKEFREEARRAYBLOCK 98886 . 99481) (\DELETEBLOCK? 99483 . +100588) (\LINKBLOCK 100590 . 102716) (\MERGEBACKWARD 102718 . 104079) (\MERGEFORWARD 104081 . 105178) +(\ARRAYBLOCKMERGER 105180 . 107365) (\#BLOCKDATACELLS 107367 . 108603) (\COPYARRAYBLOCK 108605 . +110173) (\RECLAIMARRAYBLOCK 110175 . 112304) (\ADVANCE.ARRAY.SEGMENTS 112306 . 114489)) (114553 116986 + (\BYTELT 114563 . 115362) (\BYTESETA 115364 . 116305) (\WORDELT 116307 . 116984)) (116987 117321 ( +\ARRAYTYPENAME 116997 . 117319)) (117444 121138 (\SHOW.ARRAY.FREELISTS 117454 . 121136)) (121451 +127201 (\CHECKARRAYBLOCK 121461 . 125836) (\PARSEARRAYSPACE 125838 . 126247) (\PARSEARRAYSPACE1 126249 + . 127199)) (127335 133601 (\ALLOCHUNK 127345 . 133599)) (134779 140675 (PREINITARRAYS 134789 . 135330 +) (POSTINITARRAYS 135332 . 138050) (FILEARRAYBASE 138052 . 138464) (FILEBLOCKTRAILER 138466 . 138761) +(FILECODEBLOCK 138763 . 139779) (FILEPATCHBLOCK 139781 . 140673)) (140712 146136 ( +\SETUP.HUNK.TYPENUMBERS 140722 . 141758) (\COMPUTE.HUNK.TYPEDECLS 141760 . 143040) (\TURN.ON.HUNKING +143042 . 143714) (\SETUP.TYPENUM.TABLE 143716 . 146134)) (148399 155000 (\HUNKFIT? 148409 . 149024) ( +\AB.NEXT 149026 . 152221) (\AB.BACK 152223 . 154998))))) +STOP diff --git a/sources/LLBASIC b/sources/LLBASIC new file mode 100644 index 00000000..ea3ba430 --- /dev/null +++ b/sources/LLBASIC @@ -0,0 +1,2219 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "31-Jan-98 09:55:50" {DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLBASIC.;13 118684 + + changes to%: (RECORDS PNAMEINDEX) + + previous date%: "31-Jan-98 09:30:10" +{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLBASIC.;12) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994, 1995, 1998 by Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. +") + +(PRETTYCOMPRINT LLBASICCOMS) + +(RPAQQ LLBASICCOMS + ((FNS LISTP LITATOM FIXP SMALLP NLISTP ARRAYP FLOATP NUMBERP STACKP) + (FUNCTIONS ATOM) + (DECLARE%: DONTCOPY (EXPORT (MACROS CHECK \StatsZero \StatsAdd1 IPLUS16 SMALLPOSP SETXVAR + SETQ.NOREF IEQ) + (CONSTANTS WordsPerPage)) + (TEMPLATES SPREADAPPLY* SPREADAPPLY SETQ.NOREF)) + (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FREELISTENTRY HASHENTRY)) + [COMS (* ; "atoms") + (FNS GETTOPVAL SETTOPVAL FSETVAL \SETGLOBALVAL.UFN \SETFVAR.UFN GETPROPLIST \ATOMCELL + SETPROPLIST) + (COMS (MACROS \PROPCELL) + (OPTIMIZERS \ATOMCELL GETPROPLIST SETPROPLIST)) + (FNS \MKATOM \CREATE.SYMBOL \MKATOM.FULL \INITATOMPAGE) + (FNS MAPATOMS ATOMHASH#PROBES \SFLHASHLOOKUP) + (MACROS MDSTYPE# .ALLOCATED.PER.PAGE.) + (COMS (* ; "For MAKEINIT & TeleRaid") + + (* ;; "This code has one major shortcoming which will not normally turn up. If the local and remote sysouts conflict in their package setups it is possible for this code to return symbols interned in what for the teleraid'ing machine would be the correct package, but for the remote machine is in fact incorrect. This warrents a warning in the documentation. The problem lies in the fact that you *cannot* uncopy a symbol correctly between two machines with incompatible package setups. An example of such a situation would be where on one machine the package FOO inherits BAR, and on the other BAR is present directly in FOO. BAR's package cell will be different in both cases. Two solutions come to mind; both would break the VSAVEWORK feature. The first would be to UNCOPY symbols into special %"remote symbol%" objects. The second is to create uninterned symbols with the correct name and smash their package cell to be that of a correctly named package. Both of these schemes would require special reading and printing code.") + + (MACROS READSYS.HAS.PACKAGES) + (VARS READSYS.PACKAGE.FROM.NAME READSYS.PACKAGE.FROM.INDEX) + (FNS INITATOMS COPYATOM UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME + SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL + PACKAGE.NAME)) + (COMS (* ; "See \PNAMELIMIT comment below") + (VARS (\PNAMELIMIT 255)) + (INITVARS (\PNAMES.IN.BLOCKS?))) + (COMS + (* ;; "Flag for the closure cache") + + (INITVARS (SI::*CLOSURE-CACHE-ENABLED*)) + (GLOBALVARS SI::*CLOSURE-CACHE-ENABLED*)) + (FNS \DEFINEDP PUTD \PUTD GETD PUTDEFN GETDEFN) + (FNS \STKMIN) + (INITVARS (\OPSTACKEFFECT) + (\OPLENGTH)) + (GLOBALVARS \OPSTACKEFFECT \OPLENGTH) + (VARS (COMPILEATPUTDFLG)) + (DECLARE%: DONTCOPY (EXPORT (RECORDS LITATOM CL:SYMBOL VALINDEX VCELL DEFINITIONCELL + FNHEADER PNAMECELL PACKAGEINDEX PNAMEBASE PNAMEINDEX + ) + (RECORDS NEW-ATOM) + (MACROS \DEFCELL \VALCELL \PNAMECELL) + (MACROS \ATOMVALINDEX \ATOMDEFINDEX \ATOMPNAMEINDEX + \ATOMPROPINDEX \INDEXATOMPNAME \INDEXATOMVAL + \INDEXATOMDEF \ATOMNUMBER) + (GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst + \OneCharAtomBase \PNAMES.IN.BLOCKS? \SCRATCHSTRING + COMPILEATPUTDFLG) + (CONSTANTS (\PNAMELIMIT 255) + (\CharsPerPnPage 512)) + (CONSTANTS (\NEWATOM-PNAMEOFFSET 0) + (\NEWATOM-VALOFFSET 2) + (\NEWATOM-DEFOFFSET 4) + (\NEWATOM-PLISTOFFSET 6) + (\NEWATOM-TYPE# 21)) + + + (* ;; "\PNAMELIMIT is exported but needs to also be a VARS on this file to get it copied. Note that both commands must be edited together. ") + + + (* ;; + "\NEWATOM-xxxxOFFSET is word offset in NEWATOM . -- '90/07/19 ON") +)) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS COMPUTE.ATOM.HASH ATOM.HASH.REPROBE) + (ADDVARS (DONTCOMPILEFNS INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM + SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL + LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME GETDEFN + PUTDEFN FSETVAL] + (COMS (* ; + "for executing boot expressions when first run") + (FNS \RESETSYSTEMSTATE INITIALEVALQT SIMPLEPRINT) + (GLOBALVARS RESETFORMS BOOTFILES)) + (COMS (* ; "stats") + (FNS PAGEFAULTS \SETTOTALTIME \SERIALNUMBER)) + (COMS (* ; + "Fast functions for moving and clearing storage") + (FNS \BLT \MOVEBYTES \CLEARWORDS \CLEARBYTES \CLEARCELLS) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .CLEARNWORDS.)) + (COMS (* ; "Obsolete") + (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS \MOVEWORDS))) + (FNS \MOVEWORDS \ZEROBYTES \ZEROWORDS))) + (LOCALVARS . T) + [DECLARE%: DONTCOPY (* ; "For MAKEINIT & TeleRaid") + (ADDVARS (INITVALUES (\AtomFrLst 0)) + (INITPTRS (\OneCharAtomBase NIL) + (\SCRATCHSTRING)) + (INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT) + (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES \STKMIN) + (FNS COPYATOM INITATOMS)) + (EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL + \PNAMECELL \PROPCELL \INDEXATOMPNAME) + (MKI.SUBFNS (\PARSE.NUMBER . NILL) + (\MKATOM.FULL . NILL) + (\ATOMDEFINDEX . I.ATOMNUMBER) + (\ATOMVALINDEX . I.ATOMNUMBER) + (\ATOMPROPINDEX . I.ATOMNUMBER) + (\ATOMPNAMEINDEX . I.ATOMNUMBER) + (\ATOMCELL . I.\ATOMCELL) + (\GETBASEFIXP . I.GETBASEFIXP) + (\PUTBASEFIXP . I.PUTBASEFIXP) + (SETQ.NOREF . SETQ) + (SETTOPVAL . I.FSETVAL)) + (RD.SUBFNS (\PARSE.NUMBER . NILL) + (\ATOMDEFINDEX . VATOMNUMBER) + (\ATOMPROPINDEX . VATOMNUMBER) + (\ATOMVALINDEX . VATOMNUMBER) + (SETQ.NOREF . SETQ) + (\INDEXATOMPNAME . VATOM) + (\INDEXATOMVAL . VATOM) + (\INDEXATOMDEF . VATOM) + (\ATOMNUMBER . VATOMNUMBER) + (\CREATE.SYMBOL . VNOSUCHATOM)) + (RDCOMS (FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME + SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE + FIND.SYMBOL PACKAGE.NAME \MKATOM GETTOPVAL GETPROPLIST SETTOPVAL + GETDEFN \ATOMCELL) + (FNS LISTP) + (VARS (COPYATOMSTR))) + (RD.SUBFNS (\RPLPTR . VPUTBASEPTR)) + (RDVALS (\AtomFrLst] + (PROP FILETYPE LLBASIC))) +(DEFINEQ + +(LISTP + [LAMBDA (X) (* bvm%: "30-Jan-85 10:56") + (* ; "usually done in microcode") + (AND (EQ (NTYPX X) + \LISTP) + (COND + ((EQ CDRCODING 0) + T) + (T (* ; + "Check that it is not a list page header. This is mostly for benefit of teleraid") + (NEQ (fetch (POINTER WORDINPAGE) of X) + 0))) + X]) + +(LITATOM + [LAMBDA (X) (* ; "Edited 12-Feb-91 16:14 by jds") + (* ; "compiles open to NTYPX check") + ((OPCODES COPY TYPEMASK.N 64 EQ) + X]) + +(FIXP + [LAMBDA (X) (* lmm "10-MAR-81 15:08") + (* ; "compiles open to TYPEPs") + (\TYPEMASK.UFN X (LRSH \TT.FIXP 8]) + +(SMALLP + [LAMBDA (X) (* lmm "10-MAR-81 15:10") + (* ; "compiles open to TYPEP") + (SELECTC (NTYPX X) + (\SMALLP X) + NIL]) + +(NLISTP + [LAMBDA (X) (* lmm "10-MAR-81 15:07") + (* ; "compiles open") + (NOT (LISTP X]) + +(ARRAYP + [LAMBDA (X) (* lmm "10-MAR-81 15:11") + (* ; "compiles open to TYPEP") + (SELECTC (NTYPX X) + (\ARRAYP X) + NIL]) + +(FLOATP + [LAMBDA (X) (* lmm "10-MAR-81 15:11") + (* ; "compiles open to TYPEP") + (SELECTC (NTYPX X) + (\FLOATP X) + NIL]) + +(NUMBERP + [LAMBDA (X) (* lmm "10-MAR-81 15:12") + (\TYPEMASK.UFN X (LRSH \TT.NUMBERP 8]) + +(STACKP + [LAMBDA (X) (* lmm "10-MAR-81 15:13") + (SELECTC (NTYPX X) + (\STACKP X) + NIL]) +) + +(DEFINLINE ATOM (X) + (OR (NULL X) + (AND (\TYPEMASK.UFN X 8) + T))) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[PUTPROPS CHECK MACRO (ARGS (COND + [(AND (BOUNDP 'CHECK) + CHECK) + (CONS 'PROGN (for I in ARGS + collect (LIST 'OR I + (LIST 'RAID + (KWOTE (LIST + '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 `(SETQ.NOREF %, (CADAR X) + %, + (CADR X] + (PUTPROPS SETXVAR DMACRO (X (OR (AND (EQ (CAAR X) + 'QUOTE) + (LITATOM (CADAR X))) + (SHOULDNT)) + (GLOBALVARS \VALSPACE) + (LIST 'SETQ.NOREF (CADAR X) + (CADR X] + +(PUTPROPS SETQ.NOREF DMACRO ((VAR VAL) + (\PUTBASEPTR (LOCF (fetch (LITATOM VALUE) of 'VAR)) + 0 VAL))) + +(PROGN (PUTPROPS IEQ MACRO ((X Y) + (IEQP X Y))) + (PUTPROPS IEQ DMACRO (= . EQ))) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ WordsPerPage 256) + + +(CONSTANTS WordsPerPage) +) + +(* "END EXPORTED DEFINITIONS") + + + +(SETTEMPLATE 'SPREADAPPLY* NIL) + +(SETTEMPLATE 'SPREADAPPLY NIL) + +(SETTEMPLATE 'SETQ.NOREF NIL) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD FREELISTENTRY ((FREELINK FULLXPOINTER))) + +(BLOCKRECORD HASHENTRY ((NIL WORD) + (HASHFIRSTOFFSET WORD) + (HASHPAGE# FIXP) + (HASHLASTFREE FULLXPOINTER)) + [ACCESSFNS HASHENTRY (HASHMASK (fetch HASHFIRSTOFFSET of DATUM) + (PROGN (replace HASHPAGE# of DATUM + with MAX.SMALLP) + (replace HASHFIRSTOFFSET + of DATUM with NEWVALUE]) +) +) + + + +(* ; "atoms") + +(DEFINEQ + +(GETTOPVAL + [LAMBDA (X) (* edited%: " 3-Apr-85 16:38") + (fetch (LITATOM VALUE) of X]) + +(SETTOPVAL + [LAMBDA (ATM VAL) (* edited%: " 3-Apr-85 19:37") + (SELECTQ ATM + (NIL (AND VAL (LISPERROR "ATTEMPT TO SET NIL OR T" VAL))) + (T (OR (EQ VAL T) + (LISPERROR "ATTEMPT TO SET NIL OR T" VAL))) + (replace (LITATOM VALUE) of ATM with (UNLESSRDSYS VAL (\COPY VAL]) + +(FSETVAL + [LAMBDA (ATM VAL) (* edited%: " 3-Apr-85 19:36") + (* ; + "SETTOPVAL without error checks for MAKEINIT only") + (replace (LITATOM VALUE) of ATM with VAL]) + +(\SETGLOBALVAL.UFN + [LAMBDA (V A) (* bvm%: " 6-Jun-85 11:54") + (replace (VALINDEX VALUE) of A with V]) + +(\SETFVAR.UFN + [LAMBDA (V VCELL) (* edited%: " 3-Apr-85 16:40") + (replace (VCELL VALUE) of VCELL with V]) + +(GETPROPLIST + [LAMBDA (ATM) (* edited%: " 3-Apr-85 16:40") + (\GETBASEPTR (\PROPCELL ATM) + 0]) + +(\ATOMCELL + [LAMBDA (X N) (* ; + "Edited 9-Nov-92 14:18 by sybalsky:mv:envos") + (LET ((ATOMNO (\ATOMDEFINDEX X))) + (COND + (NIL (* ; "OLD VERSION") + (EQ (\HILOC ATOMNO) + 0) (* ; "Xerox Lisp traditional symbol") + (LET [(LOC (SELECTC N + (\DEF.HI (\ATOMDEFINDEX ATOMNO)) + (\VAL.HI (\ATOMVALINDEX ATOMNO)) + (\PLIST.HI (\ATOMPROPINDEX ATOMNO)) + (\PNAME.HI (\ATOMPNAMEINDEX ATOMNO)) + (SHOULDNT] + (\ADDBASE (\VAG2 N LOC) + LOC))) + [(FIXP ATOMNO) (* ; "Xerox Lisp traditional symbol") + (LET [(LOC (SELECTC N + (\DEF.HI \NEWATOM-DEFOFFSET) + (\VAL.HI \NEWATOM-VALOFFSET) + (\PLIST.HI \NEWATOM-PLISTOFFSET) + (\PNAME.HI \NEWATOM-PNAMEOFFSET) + (SHOULDNT] + (\ADDBASE \OLDATOMSPACE (IPLUS LOC (ITIMES 10 ATOMNO] + (T (* ; + "New symbol that appears after traditional symbol runs out.") + (LET [(OFFSET (SELECTC N + (\DEF.HI \NEWATOM-DEFOFFSET) + (\VAL.HI \NEWATOM-VALOFFSET) + (\PLIST.HI \NEWATOM-PLISTOFFSET) + (\PNAME.HI \NEWATOM-PNAMEOFFSET) + (SHOULDNT] + (\ADDBASE ATOMNO OFFSET]) + +(SETPROPLIST + [LAMBDA (ATM LST) (* edited%: " 3-Apr-85 16:41") + (replace (LITATOM PROPLIST) of ATM with LST]) +) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \PROPCELL MACRO ((ATOM) + (\ATOMCELL ATOM (CONSTANT \PLIST.HI] +) + +(DEFOPTIMIZER \ATOMCELL (&REST X) + [LET [(CE (CONSTANTEXPRESSIONP (CADR X] + (COND + [CE `((OPCODES ATOMCELL.N %, (CAR CE)) + %, + (CAR X] + (T 'IGNOREMACRO]) + +(DEFOPTIMIZER GETPROPLIST (X) + `(\GETBASEPTR (\PROPCELL ,X) + 0)) + +(DEFOPTIMIZER SETPROPLIST (ATM LST) + `(\RPLPTR (\PROPCELL ,ATM) + 0 + ,LST)) +(DEFINEQ + +(\MKATOM + [LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (* bvm%: " 3-Aug-86 15:24") + (PROG ([FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST + to (SUB1 (IPLUS OFFST LEN)) + suchthat (IGREATERP (\GETBASEFAT BASE I) + \MAXTHINCHAR] + HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) + + (* ;; "Because FATCHARSEENP is used in an EQ check later, it must be NIL or T only, hence the (NOT (NULL ...))") + + (COND + ((EQ LEN 0) (* ; + "The Zero-length atom has hash code zero") + (SETQ HASH 0) + (SETQ FIRSTBYTE 255) + (GO LP))) + (SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST) + (NTHCHARCODE BASE OFFST))) (* ; + "Grab the first character of the atom") + [UNLESSRDSYS (COND + [(AND (EQ LEN 1) + (ILEQ FIRSTCHAR \MAXTHINCHAR) + \OneCharAtomBase) (* ; + "The one-character atoms live in well known places, no need to hash") + (RETURN (COND + ((IGREATERP FIRSTCHAR (CHARCODE "9")) + (\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10))) + ((IGEQ FIRSTCHAR (CHARCODE "0")) + (* ; + "These one-character atoms are integers. Sigh") + (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) + (T (\ADDBASE \OneCharAtomBase FIRSTCHAR] + ((AND (NOT NONNUMERICP) + (ILEQ FIRSTCHAR (CHARCODE "9")) + (SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE))) + (* ; + "\PARSE.NUMBER returns a number or NIL") + (RETURN HASHENT] (* ; "Calculate first probe") + (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) + + (* ;; "First byte is used to compute hash and reprobe. Use lower order byte of first character, since chances are that has the most information") + + (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP) (* ; + "Build a hash value for this atom from the PNAME") + LP (* ; + "Top of the probe-and-compare-PNAMEs loop.") + [COND + ((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH))) + + (* ;; "HASHENT is one greater than the atom number, so that atom zero can be stored. Go from atom number to pname, compare strings") + + (COND + ((UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH) + of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE) + of (SETQ ATM# (SUB1 HASHENT] + LEN) + [EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE + PNAMEFATPADDINGBYTE + ) + of PNBASE)) + + (* ;; "Extra memory references to get the FATPNAMEP bit, so do a quick and dirty heuristic, based on the fact that the second byte of a fatpname is always 0--wouldn't be worth it if the fatbit were more easily accessible") + + ) + (ffetch (LITATOM FATPNAMEP) + of (\ADDBASE \ATOMSPACE ATM#] + (COND + [FATCHARSEENP (* ; + "FATCHARSEENP=T now implies that both the probe and target are fat") + (for B1 from 1 to LEN as B2 + from OFFST always + (* ; + "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same") + (EQ (\GETBASEFAT PNBASE B1) + (\GETBASEFAT BASE B2] + [FATP (* ; + "The incoming string is fat, but there are no fat characters in the PNAME.") + (for B1 from 1 to LEN as B2 from + OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASEFAT BASE B2] + (T (* ; + "Both the incoming string of chars and the PNAME are thin.") + (for B1 from 1 to LEN as B2 from OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASETHIN BASE B2] + (EQ (\INDEXATOMPNAME (SETQ ATM# (SUB1 HASHENT))) + BASE)) + (RETURN (\ADDBASE \ATOMSPACE ATM#))) + (T (* ; +"Doesn't match, so reprobe. Want reprobe to be variable, preferably independent of primary probe.") + [SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH + FIRSTBYTE] + (GO LP] (* ; "Not found, must make new atom") + (RETURN (UNINTERRUPTABLY + (LET ((NEWATOM (\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP))) + [UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM] + NEWATOM))]) + +(\CREATE.SYMBOL + [LAMBDA (BASE OFFSET LEN FATP FATCHARSEENP) (* ; "Edited 8-Feb-93 16:48 by jds") + +(* ;;; "Creates a new symbol whose pname is as indicated. FATP means the presented string is fat, while FATCHARSEENP means that there actually is a fat char in there (otherwise we will store a thin pname) --- Must be called UNINTERRUPTABLY and the caller is responsible for interning the symbol wherever it belongs") + + (* ;; "WARNING: Changes here (e.g., to where we seitch over to bigatoms) need to be reflected in MAPATOMS, too.") + + (LET ([PNBASE (\ALLOCBLOCK (COND + (FATCHARSEENP (* ; + "Allocate us a bunch of word-sized chars in pname space") + (FOLDHI (ADD1 LEN) + WORDSPERCELL)) + (T (* ; "Allocation is in CELLS") + (FOLDHI (ADD1 LEN) + BYTESPERCELL] + PB CPP ATM) + [COND + ((IGEQ (SETQ ATM \AtomFrLst) + 12287) + + (* ;; "used to be:") + + (IGEQ (SETQ ATM \AtomFrLst) + \MaxAtomFrLst) (* ; + "This test WAS fast (it used to be EQ), with the old, painful result:") + (* ; + "(\MP.ERROR \MP.ATOMSFULL %"No more atoms left%")") + + (* ;; "Now, just create us a NEW-ATOM, and keep going:") + + (SETQ ATM (CREATECELL \NEW-ATOM)) + (REPLACE (VALINDEX VALUE) OF ATM WITH 'NOBIND)) + ((EVENP ATM 256) (* ; + "Can fit 256 new atoms into 10 pages.") + + (* ;; "Old Condition:") + + (EVENP ATM \MDSIncrement) (* ; + "MDS pages are allocated in two-page chunks now") + + (* ;; "THE ITIEMS 10 IS NEW FOR BIGVM:") + + (LET [(PN (ITIMES 10 (FOLDLO ATM WORDSPERPAGE] + (COND + ((NEW-SYMBOL-CODE NIL (IGEQ PN (IDIFFERENCE \LastAtomPage 1))) + + (* ;; "This used to cause the %"You're running out of atoms%" error.") + + (\MKATOM.FULL))) + (\MAKEMDSENTRY (FOLDLO ATM WORDSPERPAGE) + (LOGOR \TT.NOREF \TT.SYMBOLP \TT.ATOM \LITATOM)) + (* ; "Make entry in MDS type table") + (\INITATOMPAGE PN) (* ; + "Make Def'n, TopVal, and Plist pages exist, and initialize") + ] + (replace (PNAMEINDEX PNAMEBASE) of ATM with PNBASE) + (* ; + "PNAME starts on byte 1 always --- byte 0 is the length") + (COND + (FATCHARSEENP (\BLT (\ADDBASE PNBASE 1) + (\ADDBASE BASE OFFSET) + LEN)) + [FATP (for I from OFFSET as J from 1 to LEN + do (\PUTBASETHIN PNBASE J (\GETBASEFAT BASE I] + (T (\MOVEBYTES BASE OFFSET PNBASE 1 LEN))) + (replace (PNAMEBASE PNAMELENGTH) of PNBASE with LEN) + (COND + ((NOT \IN.MAKEINIT) (* ; + "Make the pname block permanent, since the replace above did not addref it") + (\ADDREF PNBASE))) + (SETQ \AtomFrLst (ADD1 \AtomFrLst)) + + (* ;; "If it's an old atom (so ATM is an atom#), change it to a LITATOM:") + + (AND (FIXP ATM) + (SETQ ATM (\ADDBASE \ATOMSPACE ATM))) + (COND + (FATCHARSEENP (freplace (LITATOM FATPNAMEP) of ATM with T))) + ATM]) + +(\MKATOM.FULL + [LAMBDA NIL (* bvm%: " 7-May-86 12:25") + +(* ;;; "Cause a STORAGEFULL interrupt on the first atom of the penultimate page -- that should give 'early' warning.") + + (DECLARE (GLOBALVARS \STORAGEFULL \INTERRUPTSTATE)) + (COND + ((NOT \STORAGEFULL) + (SETQ \STORAGEFULL T) + (replace STORAGEFULL of \INTERRUPTSTATE with T) + (SETQ \PENDINGINTERRUPT T))) + NIL]) + +(\INITATOMPAGE + [LAMBDA (PN) (* ; + "Edited 28-Oct-92 15:47 by sybalsky:mv:envos") + (COND + [NIL (PROG ((OFFSET (UNFOLD PN WORDSPERPAGE)) + VALBASE) + + (* ;; "PN is the page number of the first atom. OFFSET is the first atom. Have to double that to get offsets in \DEFSPACE etc. Atoms, like everything, are allocated in double pages, so the 4 spaces have to be allocated in quad pages") + + (* ;; "assumes CCODEP bit in definition cell is default 'OFF' , so it's ok to have all def pages zero to start") + + (\NEW4PAGE (\ADDBASE2 \PNPSPACE OFFSET)) + (\NEW4PAGE (\ADDBASE2 \DEFSPACE OFFSET)) + (\NEW4PAGE (\ADDBASE2 \PLISTSPACE OFFSET)) + (\NEW4PAGE (SETQ VALBASE (\ADDBASE2 \VALSPACE OFFSET))) + (FRPTQ (ITIMES CELLSPERPAGE 4) (* ; + "Initialize value pages to value NOBIND") + (\PUTBASEPTR VALBASE 0 (EVQ 'NOBIND)) + (SETQ VALBASE (\ADDBASE VALBASE WORDSPERCELL] + (T + (* ;; "New, big-VM code: Allocate 10 pages in PNPspace at a crack, to hold 256 atoms.") + + (LET ((OFFSET (UNFOLD PN WORDSPERPAGE)) + (ATM (UNFOLD (IQUOTIENT PN 10) + WORDSPERPAGE)) + VALBASE) + + (* ;; "Create the new pages in what used to be PNAME space:") + + (for I from 0 to 9 as OFF from OFFSET by WORDSPERPAGE + do (\NEWPAGE (\ADDBASE \OLDATOMSPACE OFF))) + + (* ;; "Make all the atoms' values be NOBIND:") + + (for I from 0 to 255 as OFF from OFFSET by 10 + do (\PUTBASEPTR \OLDATOMSPACE (IPLUS OFF \NEWATOM-VALOFFSET) + 'NOBIND]) +) +(DEFINEQ + +(MAPATOMS + [LAMBDA (FN) (* ; "Edited 29-Mar-95 15:22 by sybalsky") + + (* ;; "8-FEB-92 JDS: We now switch over into big-atom mode at 12288 (changes in \CREATE.SYMBOL should be lected here)") + + (PROG ((A 0) + (DTD (\GETDTD \NEW-ATOM))) + (for old A from 0 to (IMIN \AtomFrLst 12286) + do (APPLY* FN (\INDEXATOMPNAME A))) + (COND + ((IGREATERP \AtomFrLst 12286) + (LET* ((SIZE (fetch DTDSIZE of DTD)) + (ATOM# A) + (FIRSTFREE (fetch DTDFREE of DTD)) + (LASTFREE (create POINTER + PAGE# _ (LOGAND (fetch (POINTER PAGE#) of FIRSTFREE) + 65534))) + [LASTFREE2 (create POINTER + PAGE# _ (ADD1 (LOGAND (fetch (POINTER PAGE#) of + FIRSTFREE + ) + 65534] + RESULT FIRSTPAGE LASTPAGE LIMIT) + (COND + ((.ALLOCATED.PER.PAGE. SIZE) + (SETQ LASTPAGE (SUB1 \PagesPerMDSUnit)) + (SETQ LIMIT WORDSPERPAGE)) + (T (SETQ LASTPAGE 0) + (SETQ LIMIT \MDSIncrement))) + [for MDSPAGE# from 0 by \PagesPerMDSUnit + while (<= MDSPAGE# \MAXVMPAGE) when (EQ (MDSTYPE# MDSPAGE#) + \NEW-ATOM) + do + + (* ;; + "Now collect all pointers not on free list. This code parallels \INITMDSPAGE") + + (AND (IEQP MDSPAGE# 13602) + (HELP)) + (for N from 0 to LASTPAGE + do (SETQ FIRSTPAGE (create POINTER + PAGE# _ (IPLUS N MDSPAGE#))) + (for (DISP _ 0) while (<= (add DISP SIZE) + LIMIT) + as (DATUMBASE _ FIRSTPAGE) by (\ADDBASE DATUMBASE + SIZE) + when (OR (AND (NEQ FIRSTPAGE LASTFREE) + (NEQ FIRSTPAGE LASTFREE2)) + (for (FREE _ FIRSTFREE) + by (\GETBASEPTR FREE 0) while FREE + never (EQ DATUMBASE FREE))) + do (APPLY* FN DATUMBASE) + (add ATOM# 1] + NIL]) + +(ATOMHASH#PROBES + [LAMBDA (STRING) (* bvm%: " 8-Jul-86 21:50") + +(* ;;; "Looks up STRING (a string or litatom) in atom hash table. If found, returns number of probes needed to find it, a minimum of one. If not found, returns NIL") + + (PROG (DESIREDATOM# BASE OFFST LEN FIRSTBYTE FIRSTCHAR HASH HASHENT PNBASE REPROBE FATCHARSEENP + FATP) + [COND + ((LITATOM STRING) + (SETQ BASE (ffetch (LITATOM PNAMEBASE) of STRING)) + (SETQ OFFST 1) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of STRING)) + (SETQ FATP (SETQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP) of STRING))) + (SETQ DESIREDATOM# (\LOLOC STRING))) + (T [SETQ BASE (ffetch (STRINGP BASE) of (SETQ STRING (MKSTRING STRING] + (SETQ OFFST (ffetch (STRINGP OFFST) of STRING)) + (SETQ LEN (ffetch (STRINGP LENGTH) of STRING)) + [COND + ((SETQ FATP (ffetch (STRINGP FATSTRINGP) of STRING)) + (SETQ FATCHARSEENP (for C infatstring STRING + when (IGREATERP C \MAXTHINCHAR) + do (RETURN T] + (OR (ILEQ LEN \PNAMELIMIT) + (RETURN] + (SETQ FIRSTCHAR (\GETBASECHAR FATP BASE OFFST)) + (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) + (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP) + (RETURN (for PROBES from 1 until (EQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable + HASH))) + do (COND + ([COND + (DESIREDATOM# (EQ DESIREDATOM# (SUB1 HASHENT))) + (T (AND (EQ [fetch (PNAMEBASE PNAMELENGTH) + of (SETQ PNBASE (fetch (PNAMEINDEX + PNAMEBASE) + of (SUB1 HASHENT] + LEN) + [EQ FATCHARSEENP (ffetch (LITATOM FATPNAMEP) + of (\ADDBASE \OLDATOMSPACE + (SUB1 HASHENT] + (COND + [FATCHARSEENP (* ; + "FATCHARSEENP=T now implies that both the probe and target are fat") + (for B1 from 1 to LEN as B2 + from OFFST + always + (* ; + "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same") + (EQ (\GETBASEFAT PNBASE B1) + (\GETBASEFAT BASE B2] + [FATP (* ; + "The incoming string is fat, but there are no fat characters in the PNAME.") + (for B1 from 1 to LEN as B2 + from OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASEFAT BASE B2] + (T (* ; + "Both the incoming string of chars and the PNAME are thin.") + (for B1 from 1 to LEN as B2 + from OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASETHIN BASE B2] + (RETURN PROBES))) (* ; +"Doesn't match, so reprobe. Want reprobe to be variable, preferably independent of primary probe.") + (SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE + HASH FIRSTBYTE]) + +(\SFLHASHLOOKUP + [LAMBDA (PAGE# HASHTABLE INSERT) (* JonL "28-Dec-84 19:33") + (bind (MASK _ (fetch HASHMASK of HASHTABLE)) + PROBE HASHENT first (SETQ PROBE (LOGAND (LLSH PAGE# 2) + MASK)) + do [COND + ((IEQP (fetch HASHPAGE# of (SETQ HASHENT (\ADDBASE HASHTABLE PROBE))) + PAGE#) + (RETURN HASHENT)) + ((EQ 0 (fetch HASHPAGE# of HASHENT)) + (RETURN (COND + (INSERT (replace HASHPAGE# of HASHENT with PAGE#) + HASHENT] + (SETQ PROBE (LOGAND (IPLUS PROBE 4) + MASK]) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS MDSTYPE# MACRO ((PAGE#) + (LOGAND (\GETBASE \MDSTypeTable (LRSH PAGE# 1)) + \TT.TYPEMASK))) + +[PUTPROPS .ALLOCATED.PER.PAGE. MACRO (OPENLAMBDA (SIZE) (* Maybe change this some day to a + fetch of a flag from the DTD) + (AND (IGEQ (LISPVERSION) + 37384) + (ILESSP (IREMAINDER WORDSPERPAGE SIZE) + (LRSH SIZE 1)) + (ILESSP SIZE WORDSPERPAGE] +) + + + +(* ; "For MAKEINIT & TeleRaid") + + + + +(* ;; +"This code has one major shortcoming which will not normally turn up. If the local and remote sysouts conflict in their package setups it is possible for this code to return symbols interned in what for the teleraid'ing machine would be the correct package, but for the remote machine is in fact incorrect. This warrents a warning in the documentation. The problem lies in the fact that you *cannot* uncopy a symbol correctly between two machines with incompatible package setups. An example of such a situation would be where on one machine the package FOO inherits BAR, and on the other BAR is present directly in FOO. BAR's package cell will be different in both cases. Two solutions come to mind; both would break the VSAVEWORK feature. The first would be to UNCOPY symbols into special %"remote symbol%" objects. The second is to create uninterned symbols with the correct name and smash their package cell to be that of a correctly named package. Both of these schemes would require special reading and printing code." +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS READSYS.HAS.PACKAGES MACRO (NIL (NEQ 1 READSYS.PACKAGE.FROM.NAME))) +) + +(RPAQQ READSYS.PACKAGE.FROM.NAME 1) + +(RPAQQ READSYS.PACKAGE.FROM.INDEX 1) +(DEFINEQ + +(INITATOMS + [LAMBDA NIL (* ; "Edited 11-Dec-86 14:41 by Pavel") + + (* ;; "called only under MAKEINIT to initialize the making of atoms") + + (CREATEPAGES \AtomHashTable \AtomHTpages) + (SETQ \SCRATCHSTRING (ALLOCSTRING \PNAMELIMIT)) (* ; "\SCRATCHSTRING created in remote space simply to make renaming simple. Could smash it to NIL inside init.sysout") + (* (CREATEPAGES \PNCHARSSPACE 1)) + (COPYATOM NIL) (* ; "NIL is atom 0") + (COPYATOM 'NOBIND) (* ; "atom 1") + + (* ;; "Now make the single character atoms -- all thin chars except the digits") + + (for C from 0 to 255 when (OR (ILESSP C (CHARCODE 0)) + (IGREATERP C (CHARCODE 9))) + do (COPYATOM (CHARACTER C))) + (SETQ \OneCharAtomBase (\ADDBASE \ATOMSPACE 2)) (* ; + "= (CHARACTER 0) -- for FCHARACTER") + (COPYATOM (FUNCTION \EVALFORM)) (* ; "atom 256-10+2 = 248") + (COPYATOM (FUNCTION \GC.HANDLEOVERFLOW)) (* ; "atom 249") + (COPYATOM (FUNCTION \DTEST.UFN)) (* ; "atom 250") + (COPYATOM (FUNCTION \OVERFLOWMAKENUMBER)) (* ; "atom 251") + (COPYATOM (FUNCTION \MAKENUMBER)) (* ; "atom 252") + (COPYATOM (FUNCTION \SETGLOBAL.UFN)) (* ; "atom 253") + (COPYATOM (FUNCTION \SETFVAR.UFN)) (* ; "atom 254") + (COPYATOM (FUNCTION \GCMAPTABLE)) (* ; "atom 255") + (COPYATOM (FUNCTION \INTERPRETER)) (* ; "atom 256") + (OR (EQ (\ATOMDEFINDEX (FUNCTION \INTERPRETER)) + 256) + (HELP (FUNCTION \INTERPRETER) + " not atom 400Q"]) + +(COPYATOM + [LAMBDA (X) (* ; "Edited 6-Jan-88 17:33 by amd") + + (* ;; "this function is only for the use of MAKEINIT, which passes it a local atom to be translated into an atom in the remote sysout.") + + [ALLOCAL (LET ((PKG (CL:SYMBOL-PACKAGE X))) (* ; + "SYMBOL-PACKAGE and *INTERLISP-PACKAGE* both NIL in non-package world") + (if (NEQ PKG *INTERLISP-PACKAGE*) + then + + (* ;; "Kludge time. We don't yet have the machinery to create packages in the init.sysout, so anything that isn't an Interlisp symbol has to be turned into a flat-space symbol with appropriate prefix") + + (if (EQ PKG *KEYWORD-PACKAGE*) + then (* ; + "keywords eval to self, so also set top val") + (MKI.DSET X X) + (SETQ X (CONCAT ":" X)) + elseif (EQ PKG *LISP-PACKAGE*) + then + + (* ;; + "Symbol lives in CL and not available in IL, so add prefix") + + (SETQ X (CONCAT "CL::" X)) + elseif (NULL PKG) + then + + (* ;; "This is an uninterned symbol, so add #: prefix.") + + (SETQ X (CONCAT "#:" X)) + elseif (CL:STRING= (CL:PACKAGE-NAME PKG) + "SYSTEM") + then + + (* ;; "SYSTEM = SI package. All internal for now.") + + (SETQ X (CONCAT "SI::" X)) + ELSEIF (CL:STRING= (CL:PACKAGE-NAME PKG) + "CONDITIONS") + THEN + + (* ;; + "Make it internal. The xcl-package stuff will export the right ones when it starts up.") + + (SETQ X (CONCAT "CONDITIONS::" X)) + ELSEIF (CL:STRING= (CL:PACKAGE-NAME PKG) + "XEROX-COMMON-LISP") + THEN + + (* ;; + "Make it internal. The xcl-package stuff will export the right ones when it starts up.") + + (SETQ X (CONCAT "XCL::" X)) + ELSEIF (CL:STRING= (CL:PACKAGE-NAME PKG) + "COMPILER") + THEN + + (* ;; + "Make it internal. The compiler-package stuff will export the right ones when it starts up.") + + (SETQ X (CONCAT "COMPILER::" X)) + ELSEIF (CL:STRING= (CL:PACKAGE-NAME PKG) + "FASL") + THEN + + (* ;; + "Make it internal. The fasl-package stuff will export the right ones when it starts up.") + + (SETQ X (CONCAT "FASL::" X)) + else (HELP + "Can only translate symbols in IL, CL, XCL, CONDITIONS, SI, COMPILER, FASL and keywords" + X] + (LET ((N (LOCAL (NCHARS X))) + (BASE (FFETCH (STRINGP BASE) OF \SCRATCHSTRING)) + (OFFST (FFETCH (STRINGP OFFST) OF \SCRATCHSTRING))) + (* ; + "\SCRATCHSTRING is initialized in INITATOMS") + [FOR I FROM 1 TO N DO (\PUTBASEBYTE BASE (LOCAL (IPLUS OFFST I -1)) + (LOCAL (NTHCHARCODE X I] + (\ATOMDEFINDEX (\MKATOM BASE OFFST N]) + +(UNCOPYATOM + [LAMBDA (N) (* ; "Edited 6-Mar-87 11:55 by raf") + +(* ;;; "This is used only by VATOM (in READSYS) to turn atom numbers into similar local atoms. Note that it would be very difficult to create correctly exported symbols due to conflicts between the local and remote package setups.") + + (PROG (ATOM.NAME PACKAGE.NAME) + + (* ;; "Uncopy the atom name") + + (SETQ ATOM.NAME (SYMBOL.PNAME N)) + + (* ;; "Find and uncopy the package name") + + (SETQ PACKAGE.NAME (IF (READSYS.HAS.PACKAGES) + THEN (PACKAGE.NAME (SYMBOL.PACKAGE N)) + ELSE "INTERLISP")) + (RETURN (MAKE.LOCAL.ATOM PACKAGE.NAME ATOM.NAME]) + +(MAKE.LOCAL.ATOM + [LAMBDA (PKG.NAME ATM.NAME) (* ; "Edited 17-Feb-87 16:20 by raf") + +(* ;;; "There are potential cases in which package setup differences between the local and remote machines will intern names in different packages. For example, if in the local package the name is an inherited symbol, but remotely the name is directly present in the paackage (shadowed symbol have the same problem). This is mildly troublesome, however any solution would break VSAVEWORK. In future it would be best to create a remote-symbol structure and pass that around.") + + (ALLOCAL (CL:INTERN ATM.NAME (OR (CL:FIND-PACKAGE PKG.NAME) + (CL:MAKE-PACKAGE PKG.NAME :USES NIL]) + +(SYMBOL.VALUE + [LAMBDA (SYMBOL) (* ; "Edited 22-Dec-92 17:05 by jds") + + (* ;; "Get a symbol's value. This is for RDSYS only.") + + (LET [(LOC (OLD.FIND.SYMBOL SYMBOL 1 (LOCAL (NCHARS SYMBOL] + (COND + (NIL + (* ;; "OLD VERSION") + + (\GETBASEPTR (VADDBASE (VVAG2 12 LOC) + LOC) + 0)) + (T + (* ;; "NEW VERSION") + + (\GETBASEPTR (VADDBASE (VVAG2 \ATOM.HI 0) + (IPLUS (ITIMES (LOGAND LOC 65535) + 10) + \NEWATOM-VALOFFSET)) + 0]) + +(SYMBOL.PNAME + [LAMBDA (N BUFFER) (* ; "Edited 22-Dec-92 16:32 by jds") + +(* ;;; "Uncopy the pname of symbol number N into a string and return it.") + + [ALLOCAL (SETQ BUFFER (OR BUFFER (ALLOCSTRING \PNAMELIMIT] + (PROG (ADDR LEN) + + (* ;; "Uncopy the atom name") + + [COND + (NIL (SETQ ADDR (\GETBASEPTR (\ADDBASE2 \PNPSPACE N) + 0))) + (T (SETQ ADDR (\GETBASEPTR (\ADDBASE (\VAG2 \ATOM.HI 0) + (IPLUS (ITIMES (LOGAND N 65535) + 10) + \NEWATOM-PNAMEOFFSET)) + 0] + (SETQ LEN (\GETBASEBYTE ADDR 0)) + [for I from 1 to LEN do (LOCAL (RPLSTRING BUFFER I (FCHARACTER ( + \GETBASEBYTE + ADDR I] + (RETURN (LOCAL (SUBSTRING BUFFER 1 LEN]) + +(SYMBOL.PACKAGE + [LAMBDA (N) (* ; + "Edited 8-Nov-92 02:16 by sybalsky:mv:envos") + +(* ;;; "Given a symbol number, return a pointer to its remote package.") + + (PROG [(INDEX (COND + (NIL (* ; "OLD WAY") + (LRSH (\GETBASE (\ADDBASE2 \PNPSPACE N) + 0) + 8)) + (NIL (T (LRSH (\GETBASE (\ADDBASE \OLDATOMSPACE (IPLUS (ITIMES 10 N) + \NEWATOM-PNAMEOFFSET 8)) + 0) + 8))) + (T (fetch (LITATOM PACKAGEINDEX) of N] + (RETURN (COND + ((EQ INDEX *UNINTERNED-PACKAGE-INDEX*) + NIL) + (T (\GETBASEPTR (ffetch (ONED-ARRAY BASE) of READSYS.PACKAGE.FROM.INDEX) + (LLSH INDEX 1]) + +(OLD.FIND.SYMBOL + [LAMBDA (BASE OFFST LEN FATP NONNUMERICP) (* ; "Edited 17-Feb-87 16:43 by raf") + (PROG ([FATCHARSEENP (AND FATP (NOT (NULL (for I from OFFST + to (SUB1 (IPLUS OFFST LEN)) + suchthat (IGREATERP (\GETBASEFAT BASE I) + \MAXTHINCHAR] + HASH HASHENT ATM# PNBASE FIRSTCHAR FIRSTBYTE REPROBE) + + (* ;; "Because FATCHARSEENP is used in an EQ check later, it must be NIL or T only, hence the (NOT (NULL ...))") + + (COND + ((EQ LEN 0) (* ; + "The Zero-length atom has hash code zero") + (SETQ HASH 0) + (SETQ FIRSTBYTE 255) + (GO LP))) + (SETQ FIRSTCHAR (UNLESSRDSYS (\GETBASECHAR FATP BASE OFFST) + (NTHCHARCODE BASE OFFST))) (* ; + "Grab the first character of the atom") + [UNLESSRDSYS (COND + [(AND (EQ LEN 1) + (ILEQ FIRSTCHAR \MAXTHINCHAR) + \OneCharAtomBase) (* ; + "The one-character atoms live in well known places, no need to hash") + (RETURN (COND + ((IGREATERP FIRSTCHAR (CHARCODE "9")) + (\ADDBASE \OneCharAtomBase (IDIFFERENCE FIRSTCHAR 10))) + ((IGEQ FIRSTCHAR (CHARCODE "0")) + (* ; + "These one-character atoms are integers. Sigh") + (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) + (T (\ADDBASE \OneCharAtomBase FIRSTCHAR] + ((AND (NOT NONNUMERICP) + (ILEQ FIRSTCHAR (CHARCODE "9")) + (SETQ HASHENT (\PARSE.NUMBER BASE OFFST LEN FATP 10 \ORIGREADTABLE))) + (* ; + "\PARSE.NUMBER returns a number or NIL") + (RETURN HASHENT] (* ; "Calculate first probe") + (SETQ FIRSTBYTE (LOGAND FIRSTCHAR 255)) + + (* ;; "First byte is used to compute hash and reprobe. Use lower order byte of first character, since chances are that has the most information") + + (COMPUTE.ATOM.HASH BASE OFFST LEN FIRSTBYTE FATP) (* ; + "Build a hash value for this atom from the PNAME") + LP (* ; + "Top of the probe-and-compare-PNAMEs loop.") + [COND + ((NEQ 0 (SETQ HASHENT (\GETBASE \AtomHashTable HASH))) + + (* ;; "HASHENT is one greater than the atom number, so that atom zero can be stored. Go from atom number to pname, compare strings") + + (COND + ([UNLESSRDSYS [AND (EQ [ffetch (PNAMEBASE PNAMELENGTH) + of (SETQ PNBASE (ffetch (PNAMEINDEX PNAMEBASE) + of (SETQ ATM# (SUB1 HASHENT] + LEN) + [EQ FATCHARSEENP (AND (PROG1 (EQ 0 (ffetch (PNAMEBASE + PNAMEFATPADDINGBYTE + ) + of PNBASE)) + + (* ;; "Extra memory references to get the FATPNAMEP bit, so do a quick and dirty heuristic, based on the fact that the second byte of a fatpname is always 0--wouldn't be worth it if the fatbit were more easily accessible") + + ) + (ffetch (LITATOM FATPNAMEP) + of (\ADDBASE \ATOMSPACE ATM#] + (COND + [FATCHARSEENP (* ; + "FATCHARSEENP=T now implies that both the probe and target are fat") + (for B1 from 1 to LEN as B2 + from OFFST always + (* ; + "Loop thru the characters in the putative atom and the existing PNAME, to see if they're the same") + (EQ (\GETBASEFAT PNBASE B1) + (\GETBASEFAT BASE B2] + [FATP (* ; + "The incoming string is fat, but there are no fat characters in the PNAME.") + (for B1 from 1 to LEN as B2 from + OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASEFAT BASE B2] + (T (* ; + "Both the incoming string of chars and the PNAME are thin.") + (for B1 from 1 to LEN as B2 from OFFST + always (EQ (\GETBASETHIN PNBASE B1) + (\GETBASETHIN BASE B2] + (LOCAL (STREQUAL (LOCAL (CL:SYMBOL-NAME BASE)) + (SYMBOL.PNAME (SETQ ATM# (SUB1 HASHENT] + (UNLESSRDSYS (RETURN (\ADDBASE \ATOMSPACE (SUB1 ATM#))) + (RETURN ATM#))) + (T (* ; +"Doesn't match, so reprobe. Want reprobe to be variable, preferably independent of primary probe.") + [SETQ HASH (IPLUS16 HASH (OR REPROBE (SETQ REPROBE (ATOM.HASH.REPROBE HASH + FIRSTBYTE] + (GO LP] (* ; "Not found, must make new atom") + (RETURN (UNINTERRUPTABLY + (LET ((NEWATOM (\CREATE.SYMBOL BASE OFFST LEN FATP FATCHARSEENP))) + [UNLESSRDSYS (\PUTBASE \AtomHashTable HASH (ADD1 (\ATOMPNAMEINDEX NEWATOM] + NEWATOM))]) + +(LOOKUP-SYMBOL + [LAMBDA (TABLE STRING SXHASH ENTRY-HASH) (* ; "Edited 17-Feb-87 10:43 by raf") + +(* ;;; "Find where the symbol named String is stored in Table. Index is returned, or NIL if it is not present. Length and Hash are the length and sxhash of String. Entry-Hash is the entry-hash of the string and length.%"") + + (LET* ((VEC (\GETBASEPTR TABLE 0)) (* ; "CL::PACKAGE-HASHTABLE-TABLE") + (HASH (\GETBASEPTR TABLE 2)) (* ; "CL::PACKAGE-HASHTABLE-HASH") + (LEN (FFETCH (ONED-ARRAY TOTAL-SIZE) OF VEC)) + (* ; "CL:ARRAY-TOTAL-SIZE") + [H2 (ADD1 (IREMAINDER SXHASH (IDIFFERENCE LEN 2] (* ; "REHASH-FACTOR") + ) + (DECLARE (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 8)) + HASH) + (TYPE (CL:SIMPLE-ARRAY (CL:UNSIGNED-BYTE 16)) + VEC)) + (PROG ((INDEX-VAR (IREMAINDER SXHASH LEN)) + SYMBOL-NUMBER EHASH) + (IF NIL + THEN (CL:FORMAT T "Probe @ ~s~%%" INDEX-VAR)) + LOOP + (SETQ EHASH (\GETBASEBYTE (FFETCH (ONED-ARRAY BASE) OF HASH) + INDEX-VAR)) (* ; "CL:AREF") + [COND + [(EQL EHASH ENTRY-HASH) + (IF NIL + THEN (CL:FORMAT T "Entry hash MATCHES~%%")) + (LET [(SYMBOL-NAME (SYMBOL.PNAME (SETQ SYMBOL-NUMBER + (\GETBASE (FFETCH (ONED-ARRAY BASE) + OF VEC) + INDEX-VAR] + (* ; "CL:AREF") + (IF NIL + THEN (CL:FORMAT T "Got symbol index~%%")) + + (* ;; "pname length is first byte of pname") + + (COND + ((LOCAL (STREQUAL SYMBOL-NAME STRING)) + (IF NIL + THEN (CL:FORMAT T " found~%%")) + (GO DOIT)) + (T (IF NIL + THEN (CL:FORMAT T "Didn't match~%%"] + ((EQL 0 EHASH) + (IF NIL + THEN (CL:FORMAT T "Hit deleted entry (no match)~%%")) + (SETQ INDEX-VAR NIL) + (GO DOIT)) + (T (IF NIL + THEN (CL:FORMAT T "Entry hash does not match~%%"] + (SETQ INDEX-VAR (IREMAINDER (IPLUS INDEX-VAR H2) + LEN)) (* ; "SYMBOL-HASH-REPROBE") + (IF NIL + THEN (CL:FORMAT T "Reprobe @ ~s~%%" INDEX-VAR)) + (GO LOOP) + DOIT + (RETURN SYMBOL-NUMBER]) + +(FIND.PACKAGE + [LAMBDA (NAME) (* ; "Edited 6-Mar-87 11:50 by raf") + +(* ;;; "Given a name, find the package with that name or nickname. This is a specialized, macroexpanded and de-optimized version of IL:GETHASH") + + (PROG ((ITEM (LOCAL (MKSTRING NAME))) + (HA READSYS.PACKAGE.FROM.NAME) + BITS INDEX SLOT SKEY FIRSTINDEX REPROBE LIMIT ABASE VALUE) + (SETQ BITS (STRINGHASHBITS ITEM)) + (SETQ INDEX (LOGAND BITS (ffetch (HARRAYP LASTINDEX) of HA))) + (* ; "\FIRSTINDEX") + (SETQ ABASE (ffetch HARRAYPBASE of HA)) + (SETQ FIRSTINDEX INDEX) + (SETQ REPROBE (LOGOR (LOGAND (LOGXOR BITS (LRSH BITS 8)) + (IMIN 63 (FFETCH (HARRAYP LASTINDEX) OF HA))) + 1)) (* ; "\REPROBE") + (SETQ LIMIT (ffetch (HARRAYP LASTINDEX) of HA)) + LP (SETQ SLOT (\ADDBASE4 ABASE INDEX)) (* ; "\HASHSLOT") + (COND + [(SETQ VALUE (ffetch (HASHSLOT VALUE) of SLOT)) + (* ; "Slot is occupied") + (SETQ SKEY (V\UNCOPY (ffetch (HASHSLOT KEY) of SLOT))) + (COND + ((STREQUAL ITEM SKEY) (* ; "Found it") + (GO FOUND] + ((NULL (ffetch (HASHSLOT KEY) of SLOT)) (* ; "Empty slot") + (RETURN NIL))) + (SETQ INDEX (LOGAND (IPLUS16 INDEX REPROBE) + LIMIT)) (* ; "Since table size is a power of two, any wraparound in the IPLUS16 will be consistent with the LOGAND") + (COND + ((EQ INDEX FIRSTINDEX) (* ; + "Should never happen, since we don't allow full occupancy") + (SHOULDNT "Hashing in full hash table"))) + (GO LP) + FOUND + (RETURN (AND (NEQ VALUE \HASH.NULL.VALUE) + VALUE]) + +(FIND.SYMBOL + [LAMBDA (STRING PACKAGE) (* ; "Edited 16-Feb-87 15:59 by raf") + +(* ;;; +"Given a string, find a symbol by that name. This is macroexpanded and altered code from LLPACKAGE") + + (LET* ((LENGTH (LOCAL (FFETCH (STRINGP LENGTH) OF STRING))) + [HASH (COND + ((EQL 0 LENGTH) + 0) + (T (PROG* ((TERMINUS LENGTH) + (HASH (LLSH (LOCAL (NTHCHARCODE STRING 1)) + 8)) + (CHAR# 2)) + A0355 + [COND + ((IGREATERP CHAR# TERMINUS) + (RETURN (PROGN HASH] + (PROGN) + [SETQ HASH (IPLUS16 (IPLUS16 (SETQ HASH (IPLUS16 HASH + (LLSH (LOGAND HASH 4095) + 2))) + (LLSH (LOGAND HASH 255) + 8)) + (LOCAL (NTHCHARCODE STRING CHAR#] + (SETQ CHAR# (ADD1 CHAR#)) + (GO A0355] (* ; "SYMBOL-HASH") + (EHASH (IPLUS (IREMAINDER (LOGXOR LENGTH HASH (RSH HASH 8) + (RSH HASH 16) + (RSH HASH 19)) + 254) + 2)) (* ; "ENTRY-HASH") + (SYM) + (WHERE) + (DONE)) + [COND + ((NOT (\GETBASEPTR PACKAGE 14)) (* ; "CL::%%PACKAGE-EXTERNAL-ONLY") + (IF NIL + THEN (PRINT "Checking INTERNAL symbols")) + (LET ((INDEX (LOOKUP-SYMBOL (\GETBASEPTR PACKAGE 16) + STRING HASH EHASH))) (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS") + (COND + (INDEX (SETQ SYM INDEX) + (SETQ WHERE :INTERNAL) + (SETQ DONE T] + [COND + ((NOT DONE) + (IF NIL + THEN (PRINT "Checking EXTERNAL symbols")) + (LET ((INDEX (LOOKUP-SYMBOL (\GETBASEPTR PACKAGE 18) + STRING HASH EHASH))) (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS") + (COND + (INDEX (SETQ SYM INDEX) + (SETQ WHERE :EXTERNAL) + (SETQ DONE T] + [COND + ((NOT DONE) + (IF NIL + THEN (CL:FORMAT T "Checking USE'd packages~%%")) + (LET ((HEAD (\GETBASEPTR PACKAGE 2)) (* ; "CL::%%PACKAGE-TABLES") + ) + (PROG ((PREV HEAD) + (TABLE (CDR HEAD))) + USED-PACKAGE-LOOP + [COND + ((OR DONE (NULL TABLE)) + (RETURN (PROGN (CL:VALUES NIL NIL] + [PROGN (LET ((INDEX (LOOKUP-SYMBOL (CAR TABLE) + STRING HASH EHASH))) + (* ; "CL::%%PACKAGE-INTERNAL-SYMBOLS") + (COND + (INDEX (COND + ((NEQ PREV HEAD) + (LET* ((A0347 PREV) + (A0346 (CDR A0347)) + (A0349 TABLE) + (A0348 (CDR A0349)) + (A0351 HEAD) + (A0350 (CDR A0351))) + (CDR (RPLACD A0347 A0348)) + (CDR (RPLACD A0349 A0350)) + (CDR (RPLACD A0351 TABLE)) + A0346))) + (SETQ SYM INDEX) + (SETQ WHERE :INHERITED) + (SETQ DONE T)) + (T] + (PROGN (SETQ PREV (PROG1 TABLE + (PROGN (SETQ TABLE (CDR TABLE)) + NIL))) + NIL) + (GO USED-PACKAGE-LOOP] + (LOCAL (CL:VALUES SYM WHERE]) + +(PACKAGE.NAME + [LAMBDA (RMPKG) (* ; "Edited 12-Feb-87 17:29 by raf") + (AND RMPKG (\UNCOPY (\GETBASEPTR RMPKG 4]) +) + + + +(* ; "See \PNAMELIMIT comment below") + + +(RPAQQ \PNAMELIMIT 255) + +(RPAQ? \PNAMES.IN.BLOCKS? ) + + + +(* ;; "Flag for the closure cache") + + +(RPAQ? SI::*CLOSURE-CACHE-ENABLED* ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS SI::*CLOSURE-CACHE-ENABLED*) +) +(DEFINEQ + +(\DEFINEDP + [LAMBDA (A) (* edited%: " 3-Apr-85 19:45") + (AND (LITATOM A) + (fetch (LITATOM DEFPOINTER) of A) + T]) + +(PUTD + [LAMBDA (FN DEF FLG) (* ; "Edited 2-May-94 14:47 by sybalsky") + (PROG1 DEF + [COND + ((NOT (LITATOM FN)) + (\ILLEGAL.ARG FN)) + ((NOT (OR (LISTP DEF) + (NULL DEF) + (TYPEP DEF 'COMPILED-CLOSURE) + (ARRAYP DEF))) + (\ILLEGAL.ARG DEF)) + ((AND (NULL FLG) + (TYPEP DEF 'COMPILED-CLOSURE) + (NEQ (fetch (COMPILED-CLOSURE FRAMENAME) of DEF) + FN)) (* ; + "Definition being stored has a different frame name, so fix it") + (SETQ DEF (\RENAMEDFN DEF FN] + (\PUTD FN DEF))]) + +(\PUTD + [LAMBDA (FN DEF) (* lmm " 7-Nov-86 03:54") + (LET ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN))) + (UNINTERRUPTABLY + (PROG ((DVAL DEF) + CODEBASE) + (COND + [(TYPEP DVAL 'COMPILED-CLOSURE) + (SETQ CODEBASE (fetch (COMPILED-CLOSURE FNHEADER) of DVAL)) + (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL) + (COND + ((fetch (COMPILED-CLOSURE ENVIRONMENT) of DVAL) + (* ; + "Full closure, have to store it as non-ccodep") + (replace CCODEP of DCELL with NIL) + (GO CLOSURE)) + (T (* ; "Strip out code base") + (SETQ DVAL CODEBASE] + ((AND (ARRAYP DVAL) + (EQ (fetch (ARRAYP TYP) of DVAL) + \ST.CODE)) (* ; + "Code array -- only from the code reader or compiler") + (SETQ CODEBASE (SETQ DVAL (fetch (ARRAYP BASE) of DVAL))) + (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL)) + (T (GO EXPR))) + CODE + (replace (DEFINITIONCELL CCODEP) of DCELL with T) + CLOSURE + (replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch + (FNHEADER ARGTYPE) + of CODEBASE)) + (replace (DEFINITIONCELL FASTP) of DCELL with + (EQ 0 (fetch (FNHEADER NTSIZE + ) + of CODEBASE))) + (replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL) + (RETURN DEF) + EXPR + (replace (DEFINITIONCELL DEFCELLFLAGS) of DCELL with 0) + (replace (DEFINITIONCELL DEFPOINTER) of DCELL with DVAL) + (RETURN DEF)))]) + +(GETD + [LAMBDA (A) (* ; "Edited 7-Jan-88 15:47 by jop") + (IF (LITATOM A) + THEN (LET* ((A (fetch (LITATOM DEFINITIONCELL) of A)) + (DEF (fetch (DEFINITIONCELL DEFPOINTER) of A))) + (COND + ((NOT (fetch (DEFINITIONCELL CCODEP) of A)) + DEF) + (SI::*CLOSURE-CACHE-ENABLED* (SI::GET-CACHE-CLOSURE DEF)) + (T (create COMPILED-CLOSURE + FNHEADER _ DEF]) + +(PUTDEFN + [LAMBDA (FN CA SIZE) (* edited%: " 3-Apr-85 19:55") + (* ; + "special version of PUTD that runs only at MAKEINIT time") + (PROG ((DCELL (fetch (LITATOM DEFINITIONCELL) of FN)) + [BLOCKINFO (PROGN + (* ;; "Reserve enough space. FILECODEBLOCK leaves file pointing at first data word, so BASE is set to that below. BLOCKINFO is used for setting block trailer.") + + (FILECODEBLOCK (FOLDHI SIZE BYTESPERCELL) + (fetch (CODEARRAY ALIGNED) of CA] + (BASE (FILEARRAYBASE))) + (replace (DEFINITIONCELL DEFPOINTER) of DCELL with BASE) + (replace (DEFINITIONCELL ARGTYPE) of DCELL with (fetch (CODEARRAY ARGTYPE) + of CA)) + (replace (DEFINITIONCELL FASTP) of DCELL with (EQ (fetch (CODEARRAY NTSIZE) + of CA) + 0)) + (replace (DEFINITIONCELL CCODEP) of DCELL with T) + (replace (DEFINITIONCELL PSEUDOCODEP) of DCELL with NIL) + [COND + ((FMEMB FN LOCKEDFNS) + (\LOCKCELL DCELL 1) + (\LOCKCELL BASE (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE) + (FOLDHI SIZE BYTESPERWORD)) + WORDSPERPAGE] + [COND + ((EQ FN (LOCAL (FUNCTION \RESETSTACK))) (* ; + "special kludge to remember where \RESETSTACK is in the MAKEINIT") + (SETQ RESETPTR (FILEARRAYBASE)) + (SETQ RESETPC (fetch (CODEARRAY STARTPC) of CA] + (AOUT CA 0 SIZE OUTX 'CODE) + (BOUTZEROS (MODUP SIZE BYTESPERCELL)) + (FILEBLOCKTRAILER BLOCKINFO]) + +(GETDEFN + [LAMBDA (A) (* lmm "20-AUG-81 12:17") + (fetch (LITATOM DEFPOINTER) of A]) +) +(DEFINEQ + +(\STKMIN + [LAMBDA (CODE CODEISBLOCK PRINT) + (DECLARE (LOCALVARS . T)) (* ; "Edited 10-Nov-88 17:01 by jds") + + (* ;; "compute minimum stack space to run in this function, for either D-machine (which checks at every opcode) or Maiko (which only checks at a selected number of opcodes.") + + (* ;; "this function is tightly coded because it is executed every function loaded") + + (ALLOCAL + (PROGN + + (* ;; "can be run renamed but will work on local space.") + + [if (NOT \OPSTACKEFFECT) + then + (SETQ \OPSTACKEFFECT (\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) + (SETQ \OPLENGTH (\ALLOCBLOCK (FOLDHI 256 BYTESPERCELL))) + [for I from 0 to 255 + do + (\PUTBASEBYTE + \OPSTACKEFFECT I + (- 2 (LET ((OP (\FINDOP I)) + LEVADJ) + (SELECTQ (fetch (OPCODE OPCODENAME) + OP) + ((FN0 FN1 FN2 FN3 FN4 FNX SWAP NOP APPLYFN RETURN) + 2) + ((UNBIND DUNBIND UNWIND POP.N) + -1) + ((BIND SUBRCALL MISCN) + 1) + (OR (NUMBERP (if (LISTP (SETQ LEVADJ (fetch (OPCODE + LEVADJ) + OP))) + then (SETQ LEVADJ (CAR LEVADJ)) + else LEVADJ)) + (SELECTQ LEVADJ + ((CJUMP NCJUMP) (* ; "these only check if they jump") + -1) + ((JUMP) + 2) + (PROGN 2] + (for I from 0 to 255 do (\PUTBASEBYTE \OPLENGTH I + (ADD1 (OR (CADDR (\FINDOP I)) + -1] + [IF (NOT CODEISBLOCK) + THEN (SETQ CODE (OR (\GET-COMPILED-CODE-BASE CODE) + (fetch (ARRAYP BASE) + CODE] + (LLSH (PROG (MAX OP STKE (PC (fetch (FNHEADER STARTPC) + CODE)) + (DEPTH (IPLUS (IMAX (fetch (FNHEADER NA) of CODE) + 0) + 8 + (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE)) + CELLSPERQUAD) + 4))) + (SETQ MAX (PLUS DEPTH 8)) + + (* ;; + "this PROG computes the depth in cells. The llsh around converts it to D-machine words.") + + (* ;; "the initial maximum is the actual size of the frame, plus 4 extra cells for space to store info in case of an overflow. The default maximum is 8 more than that. By walking the code, it finds if there are any other runs that would increase it beyond that. At jumps or %"Maiko check%" opcodes, the depth is reset to 0. ") + + LP (if (EQ 0 (SETQ OP (\GETBASEBYTE CODE PC))) + then + + (* ;; "end of the function") + + (RETURN MAX)) + + (* ;; "the following is for debugging") + + (AND PRINT (CL:FORMAT T "~%%~3o: ~3o d<~3d> mx<~3d>" PC OP DEPTH MAX)) + (SELECTQ (SETQ STKE (- 2 (\GETBASEBYTE \OPSTACKEFFECT OP))) + (2 + (* ;; "special code indicating that this opcode checks the stack level") + + (AND PRINT (PRIN1 "*")) + (SETQ DEPTH 0)) + (add DEPTH STKE)) + (if (GREATERP DEPTH MAX) + then (SETQ MAX DEPTH)) + (CL:INCF PC (\GETBASEBYTE \OPLENGTH OP)) + (GO LP)) + 1]) +) + +(RPAQ? \OPSTACKEFFECT ) + +(RPAQ? \OPLENGTH ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \OPSTACKEFFECT \OPLENGTH) +) + +(RPAQQ COMPILEATPUTDFLG NIL) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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]) +) +(DECLARE%: EVAL@COMPILE + +(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))) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS \DEFCELL MACRO ((ATOM) + (\ATOMCELL ATOM \DEF.HI))) + +(PUTPROPS \VALCELL MACRO ((ATOM) + (\ATOMCELL ATOM \VAL.HI))) + +(PUTPROPS \PNAMECELL MACRO ((ATOM) + (\ATOMCELL ATOM \PNAME.HI))) +) +(DECLARE%: EVAL@COMPILE + +[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)) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \NxtPnByte \CurPnPage \NxtAtomPage \AtomFrLst \OneCharAtomBase \PNAMES.IN.BLOCKS? + \SCRATCHSTRING COMPILEATPUTDFLG) +) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \PNAMELIMIT 255) + +(RPAQQ \CharsPerPnPage 512) + + +(CONSTANTS (\PNAMELIMIT 255) + (\CharsPerPnPage 512)) +) +(DECLARE%: EVAL@COMPILE + +(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)) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS COMPUTE.ATOM.HASH MACRO ((BASE OFFST LEN FIRSTBYTE FATP) + (* ; + "Sets variable HASH to atom hash of indicated string") + (SETQ HASH (LLSH FIRSTBYTE 8)) + (for CHAR# from (ADD1 OFFST) + to (SUB1 (IPLUS OFFST LEN)) + do (SETQ HASH + (IPLUS16 (IPLUS16 (SETQ HASH + (IPLUS16 HASH + (LLSH (LOGAND HASH 4095) + 2))) + (LLSH (LOGAND HASH 255) + 8)) + (UNLESSRDSYS (COND + (FATP (LOGAND (\GETBASEFAT + BASE CHAR#) + 255)) + (T (\GETBASETHIN BASE CHAR#))) + (NTHCHARCODE BASE CHAR#] + +[PUTPROPS ATOM.HASH.REPROBE MACRO ((HASH FIRSTBYTE) + (LOGAND 63 (LOGOR 1 (LOGXOR FIRSTBYTE HASH] +) + + +(ADDTOVAR DONTCOMPILEFNS + INITATOMS COPYATOM UNCOPYATOM READATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME + SYMBOL.PACKAGE OLD.FIND.SYMBOL LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME + GETDEFN PUTDEFN FSETVAL) +) + + + +(* ; "for executing boot expressions when first run") + +(DEFINEQ + +(\RESETSYSTEMSTATE + [LAMBDA NIL (* rmk%: " 5-JUN-81 17:32") + (\KEYBOARDON T) + (\RESETTERMINAL]) + +(INITIALEVALQT + [LAMBDA NIL (* bvm%: "21-APR-83 12:02") + (DECLARE (GLOBALVARS BOOTFILES)) + (\SETIOPOINTERS) + (PROG ((RL BOOTFILES) + FL L) + (OR RL (RETURN)) + (SIMPLEPRINT "evaluating initial expressions: +") (* ; + "BOOTFILES is the list of boot files in reverse order") + R (SETQ FL (CONS (CAR RL) + FL)) + (COND + ((SETQ RL (CDR RL)) + (GO R))) + L1 [COND + ([LISTP (SETQ L (GETTOPVAL (CAR FL] + (SIMPLEPRINT (CAR FL)) (* Print the name of the bootfile) + (DSPBOUT (CHARCODE CR)) + (PROG NIL + L2 [EVAL (PROG1 (CAR L) + (SETTOPVAL (CAR FL) + (SETQ L (CDR L))))] + (AND (LISTP L) + (GO L2))) + (SETTOPVAL (CAR FL) + 'NOBIND] + (COND + ((SETQ FL (CDR FL)) + (GO L1))) + (SETQ BOOTFILES NIL) + (INTERPRET.REM.CM) (* See if command line has anything + to say) + ) (* ; + "Value is T so that correct value is returned when this is called from within COPYSYS0") + T]) + +(SIMPLEPRINT + [LAMBDA (X N) (* bvm%: "13-Feb-85 22:25") + (COND + [(OR (LITATOM X) + (STRINGP X)) + (for I from 1 to (NCHARS X) do (DSPBOUT (NTHCHARCODE X I] + ((LISTP X) + (COND + ((EQ N 0) + (SIMPLEPRINT "&")) + (T (DSPBOUT (CHARCODE %()) + (PROG NIL + LP [SIMPLEPRINT (CAR X) + (SETQ N (COND + ((SMALLPOSP N) + (SUB1 N)) + (T 3] + (COND + ((EQ N 0) + (SIMPLEPRINT " --)")) + ((NULL (SETQ X (CDR X))) + (SIMPLEPRINT ")")) + ((NLISTP X) + (SIMPLEPRINT " . ") + (SIMPLEPRINT X) + (SIMPLEPRINT ")")) + (T (SIMPLEPRINT " ") + (GO LP]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS RESETFORMS BOOTFILES) +) + + + +(* ; "stats") + +(DEFINEQ + +(PAGEFAULTS + [LAMBDA NIL (* rrb "13-NOV-80 15:36") + (DECLARE (GLOBALVARS \MISCSTATS)) + (fetch PAGEFAULTS of \MISCSTATS]) + +(\SETTOTALTIME + [LAMBDA NIL (* JonL "17-Dec-83 00:23") + (* ; + "updates the total time field of the misc stats page.") + (\BOXIPLUS (LOCF (fetch TOTALTIME of \MISCSTATS)) + (CLOCKDIFFERENCE (fetch STARTTIME of \MISCSTATS]) + +(\SERIALNUMBER + [LAMBDA NIL (* rmk%: " 9-JUN-81 14:49") + (fetch (IFPAGE SerialNumber) of \InterfacePage]) +) + + + +(* ; "Fast functions for moving and clearing storage") + +(DEFINEQ + +(\BLT + [LAMBDA (DBASE SBASE NWORDS) (* lmm "30-Mar-85 05:43") + (* ; + "Generally in ucode -- must guarantee transferral by moving high-order address first") + (PROG [(NN (CONSTANT (EXPT 2 14] + (RETURN (COND + ((GREATERP NWORDS NN) (* ; + "dorado has microcode only for up to 2^15") + (\BLT (\ADDBASE DBASE NN) + (\ADDBASE SBASE NN) + (DIFFERENCE NWORDS NN)) + (\BLT DBASE SBASE NN)) + (T (for I from (SUB1 NWORDS) by -1 to 0 + do (\PUTBASE DBASE I (\GETBASE SBASE I))) + DBASE]) + +(\MOVEBYTES + [LAMBDA (SBASE SBYTE DBASE DBYTE NBYTES) (* rmk%: "23-OCT-82 14:24") + (* ; + "Simple version for bootstrapping") + (COND + ((IGREATERP NBYTES 0) + (PROG ((SB (\ADDBASE SBASE (FOLDLO SBYTE BYTESPERWORD))) + (DB (\ADDBASE DBASE (FOLDLO DBYTE BYTESPERWORD))) + SBN DBN NWORDS) + (COND + [(EQ (SETQ SBN (IMOD SBYTE BYTESPERWORD)) + (SETQ DBN (IMOD DBYTE BYTESPERWORD))) (* ; "Can move words") + (COND + ((EQ SBN 1) + (\PUTBASEBYTE DB 1 (\GETBASEBYTE SB 1)) + (SETQ DB (\ADDBASE DB 1)) + (SETQ SB (\ADDBASE SB 1)) + (add NBYTES -1))) + (\BLT DB SB (SETQ NWORDS (FOLDLO NBYTES BYTESPERWORD))) + (COND + ((EQ (IMOD NBYTES BYTESPERWORD) + 1) + (\PUTBASEBYTE (\ADDBASE DB NWORDS) + 0 + (\GETBASEBYTE (\ADDBASE SB NWORDS) + 0] + (T (FRPTQ NBYTES (\PUTBASEBYTE DB (PROG1 DBN (add DBN 1)) + (\GETBASEBYTE SB (PROG1 SBN (add SBN 1]) + +(\CLEARWORDS + [LAMBDA (BASE NWORDS) (* bvm%: "20-Feb-85 12:30") + (PROG1 BASE + (while (IGREATERP NWORDS 32767) do + + (* ;; "BLT wants NWORDS to be small. We play it safe by keeping the count smaller than 2^15, avoiding a Dorado uCode bug") + + (.CLEARNWORDS. BASE 32768) + (SETQ BASE (\ADDBASE BASE 32768)) + (SETQ NWORDS (IDIFFERENCE NWORDS 32768))) + (COND + ((IGREATERP NWORDS 0) + (.CLEARNWORDS. BASE NWORDS))))]) + +(\CLEARBYTES + [LAMBDA (BASE OFFST NBYTES) (* bvm%: "29-Jan-85 18:56") + (COND + ((IGREATERP NBYTES 0) + (COND + ((ODDP OFFST) + (\PUTBASEBYTE BASE OFFST 0) + (add OFFST 1) + (add NBYTES -1))) (* ; "OFFST is now even") + (SETQ BASE (\ADDBASE BASE (FOLDLO OFFST BYTESPERWORD))) + (COND + ((ODDP NBYTES) (* ; "Final byte to be zeroed") + (\PUTBASEBYTE BASE (SUB1 NBYTES) + 0))) (* ; + "Now all we have to do is zero the word-aligned part in the middle") + (\CLEARWORDS BASE (FOLDLO NBYTES BYTESPERWORD]) + +(\CLEARCELLS + [LAMBDA (BASE NCELLS) (* bvm%: "20-Feb-85 12:51") + [while (IGEQ NCELLS (FOLDLO 32767 WORDSPERCELL)) do + (* ; + "Keep the BLTs small. See \CLEARWORDS") + (.CLEARNWORDS. BASE 32768) + (SETQ BASE (\ADDBASE BASE 32768)) + (SETQ NCELLS (IDIFFERENCE NCELLS + (FOLDLO 32768 + WORDSPERCELL + ] + (COND + ((IGREATERP NCELLS 0) + (SETQ NCELLS (UNFOLD NCELLS WORDSPERCELL)) + (.CLEARNWORDS. BASE NCELLS]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(PUTPROPS .CLEARNWORDS. MACRO (OPENLAMBDA (BASE NWORDS) + + (* ;; "Clear NWORDS words starting at base. Assumes NWORDS is smallp and greater than zero. Compiler refuses to optimize out an IGREATERP test here, so push back to caller") + + (\PUTBASE BASE (SUB1 NWORDS) + 0) + [COND + ((NEQ NWORDS 1) + (\BLT BASE (\ADDBASE BASE 1) + (SUB1 NWORDS] + NIL)) +) +) + + + +(* ; "Obsolete") + +(DECLARE%: EVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS \MOVEWORDS MACRO (OPENLAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) + (\BLT (\ADDBASE DBASE DOFFSET) + (\ADDBASE SBASE SOFFSET) + NWORDS))) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DEFINEQ + +(\MOVEWORDS + [LAMBDA (SBASE SOFFSET DBASE DOFFSET NWORDS) (* bvm%: "15-JUN-82 13:56") + (\BLT (\ADDBASE DBASE DOFFSET) + (\ADDBASE SBASE SOFFSET) + NWORDS]) + +(\ZEROBYTES + [LAMBDA (BASE FIRST LAST) (* bvm%: "29-Jan-85 19:12") + (\CLEARBYTES BASE FIRST (ADD1 (IDIFFERENCE LAST FIRST]) + +(\ZEROWORDS + [LAMBDA (BASE ENDBASE) (* bvm%: "29-Jan-85 12:54") + (while (IGREATERP (\HILOC ENDBASE) + (\HILOC BASE)) do (\CLEARWORDS BASE (IDIFFERENCE (SUB1 WORDSPERSEGMENT) + (\LOLOC BASE))) + (\PUTBASE (\VAG2 (\HILOC BASE) + (SUB1 WORDSPERSEGMENT)) + 0 0) (* ; + "Done this way to avoid non-SMALLP arithmetic when (\LOLOC BASE) = 0") + (SETQ BASE (\VAG2 (ADD1 (\HILOC BASE)) + 0))) + (PROG [(DIF (IDIFFERENCE (\LOLOC ENDBASE) + (\LOLOC BASE] + (COND + ((IGEQ DIF 0) + (\PUTBASE BASE 0 0) + (\CLEARWORDS (\ADDBASE BASE 1) + DIF]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +(DECLARE%: DONTCOPY + +(ADDTOVAR INITVALUES (\AtomFrLst 0)) + +(ADDTOVAR INITPTRS (\OneCharAtomBase NIL) + (\SCRATCHSTRING)) + +(ADDTOVAR INEWCOMS (FNS FSETVAL SETPROPLIST PUTDEFN \BLT) + (FNS \MKATOM \CREATE.SYMBOL \INITATOMPAGE \MOVEBYTES \STKMIN) + (FNS COPYATOM INITATOMS)) + +(ADDTOVAR EXPANDMACROFNS SMALLPOSP COMPUTE.ATOM.HASH ATOM.HASH.REPROBE \DEFCELL \VALCELL + \PNAMECELL \PROPCELL \INDEXATOMPNAME) + +(ADDTOVAR MKI.SUBFNS (\PARSE.NUMBER . NILL) + (\MKATOM.FULL . NILL) + (\ATOMDEFINDEX . I.ATOMNUMBER) + (\ATOMVALINDEX . I.ATOMNUMBER) + (\ATOMPROPINDEX . I.ATOMNUMBER) + (\ATOMPNAMEINDEX . I.ATOMNUMBER) + (\ATOMCELL . I.\ATOMCELL) + (\GETBASEFIXP . I.GETBASEFIXP) + (\PUTBASEFIXP . I.PUTBASEFIXP) + (SETQ.NOREF . SETQ) + (SETTOPVAL . I.FSETVAL)) + +(ADDTOVAR RD.SUBFNS (\PARSE.NUMBER . NILL) + (\ATOMDEFINDEX . VATOMNUMBER) + (\ATOMPROPINDEX . VATOMNUMBER) + (\ATOMVALINDEX . VATOMNUMBER) + (SETQ.NOREF . SETQ) + (\INDEXATOMPNAME . VATOM) + (\INDEXATOMVAL . VATOM) + (\INDEXATOMDEF . VATOM) + (\ATOMNUMBER . VATOMNUMBER) + (\CREATE.SYMBOL . VNOSUCHATOM)) + +(ADDTOVAR RDCOMS + (FNS UNCOPYATOM MAKE.LOCAL.ATOM SYMBOL.VALUE SYMBOL.PNAME SYMBOL.PACKAGE OLD.FIND.SYMBOL + LOOKUP-SYMBOL FIND.PACKAGE FIND.SYMBOL PACKAGE.NAME \MKATOM GETTOPVAL GETPROPLIST + SETTOPVAL GETDEFN \ATOMCELL) + (FNS LISTP) + (VARS (COPYATOMSTR))) + +(ADDTOVAR RD.SUBFNS (\RPLPTR . VPUTBASEPTR)) + +(ADDTOVAR RDVALS (\AtomFrLst)) +) + +(PUTPROPS LLBASIC FILETYPE CL:COMPILE-FILE) +(PUTPROPS LLBASIC COPYRIGHT ( +"Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" + 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993 1994 1995 1998)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (9820 12218 (LISTP 9830 . 10413) (LITATOM 10415 . 10682) (FIXP 10684 . 10921) (SMALLP +10923 . 11178) (NLISTP 11180 . 11393) (ARRAYP 11395 . 11650) (FLOATP 11652 . 11907) (NUMBERP 11909 . +12055) (STACKP 12057 . 12216)) (15995 19501 (GETTOPVAL 16005 . 16161) (SETTOPVAL 16163 . 16532) ( +FSETVAL 16534 . 16881) (\SETGLOBALVAL.UFN 16883 . 17054) (\SETFVAR.UFN 17056 . 17226) (GETPROPLIST +17228 . 17388) (\ATOMCELL 17390 . 19319) (SETPROPLIST 19321 . 19499)) (20325 34368 (\MKATOM 20335 . +27567) (\CREATE.SYMBOL 27569 . 31866) (\MKATOM.FULL 31868 . 32345) (\INITATOMPAGE 32347 . 34366)) ( +34369 43358 (MAPATOMS 34379 . 37686) (ATOMHASH#PROBES 37688 . 42551) (\SFLHASHLOOKUP 42553 . 43356)) ( +45385 74528 (INITATOMS 45395 . 47439) (COPYATOM 47441 . 51860) (UNCOPYATOM 51862 . 52659) ( +MAKE.LOCAL.ATOM 52661 . 53408) (SYMBOL.VALUE 53410 . 54190) (SYMBOL.PNAME 54192 . 55353) ( +SYMBOL.PACKAGE 55355 . 56469) (OLD.FIND.SYMBOL 56471 . 63826) (LOOKUP-SYMBOL 63828 . 67022) ( +FIND.PACKAGE 67024 . 69226) (FIND.SYMBOL 69228 . 74357) (PACKAGE.NAME 74359 . 74526)) (74802 81505 ( +\DEFINEDP 74812 . 75015) (PUTD 75017 . 75815) (\PUTD 75817 . 78533) (GETD 78535 . 79167) (PUTDEFN +79169 . 81347) (GETDEFN 81349 . 81503)) (81506 85926 (\STKMIN 81516 . 85924)) (104646 107529 ( +\RESETSYSTEMSTATE 104656 . 104813) (INITIALEVALQT 104815 . 106420) (SIMPLEPRINT 106422 . 107527)) ( +107624 108423 (PAGEFAULTS 107634 . 107828) (\SETTOTALTIME 107830 . 108247) (\SERIALNUMBER 108249 . +108421)) (108487 113398 (\BLT 108497 . 109395) (\MOVEBYTES 109397 . 110841) (\CLEARWORDS 110843 . +111537) (\CLEARBYTES 111539 . 112343) (\CLEARCELLS 112345 . 113396)) (114545 115996 (\MOVEWORDS 114555 + . 114758) (\ZEROBYTES 114760 . 114932) (\ZEROWORDS 114934 . 115994))))) +STOP diff --git a/sources/LLBFS b/sources/LLBFS new file mode 100644 index 00000000..48a69a18 --- /dev/null +++ b/sources/LLBFS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Dec-92 01:31:53" |{PELE:MV:ENVOS}SOURCES>LLBFS.;3| 76536 changes to%: (RECORDS CB DSKOBJ) previous date%: "16-May-90 18:58:12" |{PELE:MV:ENVOS}SOURCES>LLBFS.;2|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLBFSCOMS) (RPAQQ LLBFSCOMS [(COMS (* ; "Low-level subr calls") (FNS \INITBFS \TESTPARTITION \ACTONDISKPAGES \WRITEDISKPAGES \DISKERROR M44.SIGNAL.DISK.ERROR) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS .SETUPDISKBUFFERS. DISKWRITEACTION? DISKREADACTION?) (PROP DOPVAL .DISKPARTINSTR.) (CONSTANTS * DISKCOMMANDS) (CONSTANTS * DISKERRORS) (* ;  "Some of these are also used by MOD44IO") (RECORDS DISKREQUEST ALTODSKOBJ DDHEADER CB DISKLABEL REALDA SHORTCB FP DSKOBJ \M44LeaderPage M44STREAM FID) (CONSTANTS (\FILLINDA 65534) (\EOFDA 65535) (\LENFP 5) (\FP.DIRECTORYP 32768) (\INITPROPPTR 6866) (\DDBITTABSTART 32) (\NBYTES.DISKINFO 12) (\OFFSET.DISKLASTSERIAL# 8) (\NWORDS.DSKOBJ 36)) (GLOBALVARS \EMUDISKBUFEND \EMUDISKBUFFERS \EMUSCRATCH \EMUSWAPBUFFERS \EXTRAISFBUF \ISFMAP \ISFMAXCHUNK \ISFSCRATCHCAS \ISFSCRATCHDAS \#DISKBUFFERS \MAXDISKDAs \#SWAPBUFFERS \SYSDISK \ISFCHUNKSIZE \MAINDISK \DISKREQUESTBLOCK \SWAPREQUESTBLOCK \DISKDEBUG \MAXSWAPBUFFERS \SPAREDISKWRITEBUFFER \FREEPAGEFID \#EMUBUFFERS \EMUBUFFERS \LASTVMEMFILEPAGE \SWAPDSK1 \SWAPDSK2 \XVmemFmapBase \XVmemFmapHighBase \XVmemDiskBase \XVmem \M44.READY))) [COMS (* ; "Super low level") (FNS \ACTONVMEMPAGES \WRITEVMEMPAGES \DOACTONDISKPAGES \DOWRITEDISKPAGES \CHECKFREEPAGE \DODISKCOMMAND \GETDISKCB \CLEARCB \CLEANUPDISKQUEUE \VIRTUALDISKDA \REALDISKDA) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS * CBSTATUSCONSTANTS) (CONSTANTS * IDISKCOMMANDS) (CONSTANTS (\EM.DISKCOMMAND 337) (\EM.DISKADDRESS 339) (\FIXEDLENDISKREQUEST 42) (\DEFAULTDASTORAGELENGTH 60) (\LENCB 6) (\LENDSKOBJ 34) (\LENSHORTCB 18)) (CONSTANTS (\CB.PENDING 1) (\CB.FREE 0] [COMS (* ; "At MAKEINIT time") (FNS MAKEINITBFS) (DECLARE%: DONTCOPY (ADDVARS (INITPTRS (\MAINDISK) (\SWAPDSK1) (\SWAPDSK2) (\SWAPREQUESTBLOCK) (\DISKREQUESTBLOCK) (\FREEPAGEFID)) (INEWCOMS (FNS MAKEINITBFS))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS MAKEINITBFS] (COMS (* ; "Swap stuff") (FNS \M44ACTONVMEMFILE \LOOKUPFMAP \M44EXTENDVMEMFILE \M44DOEXTENDVMEMFILE \EXTENDISFMAP) (* ; "Extended vmem stuff") (FNS \EXTENDEDVMEMINIT \INITIALIZESWAPDISK \WHICHPART \SWAPDISKERROR) (* ; "For debugging and user info") (FNS DESCRIBE-VIRTUAL-MEMORY \PRINTFMAP) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS ISFMAP) (CONSTANTS (\ISFMAPOFFSET 18))) (INITVARS (\DISKDEBUG) (\MAXSWAPBUFFERS 1) (\M44.READY)) (ADDVARS (\SYSTEMCACHEVARS \M44.READY))) (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS ERROR RAID \M44ACTONVMEMFILE \ACTONVMEMFILESUBR \ACTONVMEMPAGES \CLEANUPDISKQUEUE \CLEARCB \DISKERROR \DOACTONDISKPAGES \DODISKCOMMAND \EXTENDISFMAP \M44DOEXTENDVMEMFILE \GETDISKCB \INITBFS \INSUREVMEMFILE \LISPERROR \LOOKUPFMAP \REALDISKDA \VIRTUALDISKDA \CLEARWORDS \TESTPARTITION \EXTENDEDVMEMINIT \WHICHPART \INITIALIZESWAPDISK \SWAPDISKERROR) (LOCKEDVARS \DISKREQUESTBLOCK \SWAPREQUESTBLOCK \MAINDISK \SWAPDSK1 \SWAPDSK2 \ISFCHUNKSIZE \EMUSCRATCH \EMUDISKBUFFERS \EMUSWAPBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS \#DISKBUFFERS \InterfacePage \ISFMAP \ISFSCRATCHCAS \ISFSCRATCHDAS \SYSDISK \#SWAPBUFFERS \MAXDISKDAs \DISKDEBUG \SPAREDISKWRITEBUFFER \#EMUBUFFERS \EMUBUFFERS \LASTVMEMFILEPAGE \XVmem \XVmemFmapBase \XVmemFmapHighBase \XVmemDiskBase]) (* ; "Low-level subr calls") (DEFINEQ (\INITBFS (LAMBDA (BASE NWORDS AFTER) (* ; "Edited 16-Feb-87 10:26 by Briggs") (PROG ((DSK \MAINDISK) CBSTART CB DD) (* ;; "BASE is the start of a chunk of space running for NWORDS words for disk scratch use. Divvy it up as follows: first page as scratch buffer for \WRITEDISKPAGES, then short CB's for disk ops, then miscellaneous scratch for copying DA and CA arrays") (PROGN (* ; "For \WRITEDISKPAGES") (SETQ \SPAREDISKWRITEBUFFER BASE) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (SETQ NWORDS (IDIFFERENCE NWORDS WORDSPERPAGE))) (PROGN (* ; "Fill in pieces of \MAINDISK") (OR (SETQ \SYSDISK (EMPOINTER (fetch (IFPAGE SYSDISK) of \InterfacePage))) (RAID "Can't find sysDisk")) (SETQ DD (fetch DDHEADER of \SYSDISK)) (SETQ CB (SETQ CBSTART (fetch CBQUEUE of DSK))) (do (* ; "Allocate Short CB's for disk controller") (replace SHORTCB of CB with BASE) (SETQ BASE (\ADDBASE BASE \LENSHORTCB)) (SETQ NWORDS (IDIFFERENCE NWORDS \LENSHORTCB)) (SETQ CB (fetch CBNEXT of CB)) repeatuntil (EQ CB CBSTART)) (replace ddPOINTER of DSK with (LOCF (fetch (ALTODSKOBJ DDLASTSERIAL#) of \SYSDISK))) (* ; "Make some fields indirect thru alto record for now") (replace ALTODSKOBJ of DSK with \SYSDISK) (PROGN (replace NDISKS of DSK with (fetch DD#DISKS of DD)) (* ; "Copy some constant fields from alto") (replace NTRACKS of DSK with (fetch DD#TRACKS of DD)) (replace NHEADS of DSK with (fetch DD#HEADS of DD)) (replace NSECTORS of DSK with (fetch DD#SECTORS of DD))) (replace RETRYCOUNT of DSK with 8) (AND AFTER (replace DDDIRTY of DSK with (replace DDVALID of DSK with NIL)))) (PROGN (SETQ \EMUSCRATCH BASE) (SETQ \MAXDISKDAs (IQUOTIENT (IDIFFERENCE NWORDS (IPLUS \LENFP 8)) 2))) (COND ((SETQ \ISFMAP (EMPOINTER (fetch (IFPAGE ISFMAP) of \InterfacePage))) (SETQ \ISFSCRATCHCAS (\ADDBASE (SETQ \ISFSCRATCHDAS (\ADDBASE \ISFMAP (IPLUS (fetch ISFEND of \ISFMAP) (PROGN (* ; "Leave a little room for off-by-one error in BCPL code") 2)))) (IPLUS (fetch ISFCHUNKSIZE of \ISFMAP) 2))) (SETQ \ISFCHUNKSIZE (fetch ISFCHUNKSIZE of \ISFMAP)) (replace DISKVERSION of \SWAPREQUESTBLOCK with (fetch FPVERSION of \ISFMAP)) (* ; "Fill in disk label info for all Lisp.virtualmem requests; this will be changed by the disk io routine if we are running with extended virtual memory") (\BLT (LOCF (fetch DISKSERIAL# of \SWAPREQUESTBLOCK)) \ISFMAP WORDSPERCELL) (replace RETURNONCHECKERROR of \SWAPREQUESTBLOCK with NIL)) (T (RAID "No ISF map"))) (* ;;; "initialization necessary for extended virtual memory feature n.h.briggs 6-feb-87") (\EXTENDEDVMEMINIT))) ) (\TESTPARTITION (LAMBDA (NUM) (* bvm%: "13-Feb-85 19:41") (PROG ((HERE (.DISKPARTINSTR. 0))) (RETURN (COND ((NEQ (.DISKPARTINSTR. (\DTEST NUM (QUOTE SMALLP))) 0) (* ; "Partition switch succeeded, now restore original partition") (.DISKPARTINSTR. HERE) T))))) ) (\ACTONDISKPAGES (LAMBDA (DSK BUFFERS DAs DAorigin FID FIRSTPAGE LASTPAGE ACTION LASTNUMCHARSCONS LASTACTION ReturnOnCheckError HINTLASTPAGE CAs) (* bvm%: "13-Feb-85 19:35") (* ;; "performs indicated ACTION on pages FIRSTPAGE thru LASTPAGE of DSK (a disk object) for file whose alto id is FID. Returns page number of last page acted on, which may be less than LASTPAGE if end of file was encountered. BUFFERS is either NIL (don't care about the data) or else a buffer or list of buffers of data to be read/written. DAs is a vector of virtual disk addresses (words) for pages of the file, per alto conventions. DAorigin indicates which page (\GETBASE DAs 0) corresponds to; it should be no greater than FIRSTPAGE. LASTACTION, if supplied, is performed instead of ACTION on LASTPAGE. HINTLASTPAGE is hint of the last page of file, to avoid chaining beyond the end of file. NUMCHARSCONS, if supplied, is a list, car of which will be smashed with the NUMCHARS field of the last page acted on (this in lieu of multiple value return). If ReturnOnCheckError is true, returns (--- (I + 64)), where I was the last page successfully acted on") (PROG (EMBLOCK EMBUFS EMCAs EMDAs EMFID EMFIXEDCA RESULT STREAM LASTNC) (COND ((EQ DSK \SYSDISK) (SETQ DSK \MAINDISK))) (COND ((type? STREAM FID) (SETQ STREAM FID) (SETQ FID (fetch (ARRAYP BASE) of (fetch FID of FID))))) RETRY (UNINTERRUPTABLY (\CLOCK0 (LOCF (fetch DISKTEMP0 of \MISCSTATS))) (* ; "Note starting time") (PROG ((REQUEST \DISKREQUESTBLOCK)) (.SETUPDISKBUFFERS. ACTION) (replace RETURNONCHECKERROR of REQUEST with ReturnOnCheckError) (replace DISKACTION of REQUEST with ACTION) (replace LASTDISKACTION of REQUEST with (COND ((AND LASTACTION (NEQ LASTACTION 0)) LASTACTION) (T ACTION))) (SETQ RESULT (\MISCAPPLY* (FUNCTION \DOACTONDISKPAGES) DSK REQUEST)) (SETQ LASTNC (fetch CURRENTNUMCHARS of REQUEST))) (COND ((AND BUFFERS (NEQ LASTNC BYTESPERPAGE) (IGEQ RESULT 0) (DISKREADACTION? (OR (AND (EQ RESULT LASTPAGE) LASTACTION) ACTION))) (* ; "Zero out everything past the last byte") (PROG ((BUF (OR EMFIXEDCA (EMPOINTER (\GETBASE EMCAs RESULT))))) (\CLEARBYTES BUF LASTNC (IDIFFERENCE BYTESPERPAGE LASTNC))))) (COND ((NOT (EMADDRESSP DAs)) (* ; "Possibly update the user's DAs from the emulator copy") (\BLT DAs EMDAs (IPLUS LASTPAGE 2 (IMINUS DAorigin))))) (* ; "If action was read, now copy from emu buffers into user buffers") (COND ((LISTP BUFFERS) (for BUF in BUFFERS as (CA _ EMCAs) by (\ADDBASE CA 1) as N from FIRSTPAGE when (AND BUF (NOT (EMADDRESSP BUF)) (DISKREADACTION? (OR (AND (EQ N LASTPAGE) LASTACTION) ACTION))) do (\BLT BUF (\VAG2 0 (\GETBASE CA 0)) WORDSPERPAGE))) ((AND BUFFERS (NOT (EMADDRESSP BUFFERS)) (DISKREADACTION? ACTION)) (\BLT BUFFERS EMFIXEDCA WORDSPERPAGE))) (\BOXIPLUS (LOCF (fetch DISKIOTIME of \MISCSTATS)) (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch DISKTEMP1 of \MISCSTATS))) (LOCF (fetch DISKTEMP0 of \MISCSTATS)))) (* ; "Note total time spent here")) (COND ((ILESSP RESULT 0) (\DISKERROR (IMINUS RESULT) STREAM LASTNC) (GO RETRY)) (T (COND (LASTNUMCHARSCONS (COND ((LISTP LASTNUMCHARSCONS) (RPLACA LASTNUMCHARSCONS LASTNC)) (T (\PUTBASE LASTNUMCHARSCONS 0 LASTNC))))) (RETURN (SIGNED RESULT BITSPERWORD)))))) ) (\WRITEDISKPAGES (LAMBDA (DSK BUFFERS DAs DAorigin FID FIRSTPAGE LASTPAGE LASTACTION LASTNUMCHARSCONS LASTNUMCHARS HINTLASTPAGE CAs) (* bvm%: "19-Jan-85 16:24") (* ;; "Write pages FIRSTPAGE thru LASTPAGE of DSK (a disk object) for file whose alto id is FID. Returns page number of last page acted on. BUFFERS is either NIL (don't care about the data) or else a buffer or list of buffers of data to be written. DAs is a vector of virtual disk addresses (words) for pages of the file, per alto conventions. DAorigin indicates which page (\GETBASE DAs 0) corresponds to; it should be no greater than FIRSTPAGE. LASTACTION, if supplied, is performed instead of ACTION on LASTPAGE. HINTLASTPAGE is hint of the last page of file, to avoid chaining beyond the end of file. NUMCHARSCONS, if supplied, is a list, car of which will be smashed with the NUMCHARS field of the last page acted on (this in lieu of multiple value return). LASTNUMCHARS is the nchars field to be written for LASTPAGE") (PROG (EMBLOCK EMBUFS EMCAs EMDAs EMFID EMFIXEDCA RESULT STREAM) (COND ((EQ DSK \SYSDISK) (SETQ DSK \MAINDISK))) (COND ((type? STREAM FID) (SETQ STREAM FID) (SETQ FID (fetch (ARRAYP BASE) of (fetch FID of FID))))) (\OPENDISKDESCRIPTOR DSK) RETRY (UNINTERRUPTABLY (\CLOCK0 (LOCF (fetch DISKTEMP0 of \MISCSTATS))) (SETQ RESULT (PROG ((REQUEST \DISKREQUESTBLOCK)) (.SETUPDISKBUFFERS. \DC.WRITED) (replace DISKNOALLOC of REQUEST with (EQ LASTACTION (UNSIGNED -1 BITSPERWORD))) (replace DISKWRITELASTNUMCHARS of REQUEST with (OR LASTNUMCHARS BYTESPERPAGE)) (RETURN (\MISCAPPLY* (FUNCTION \DOWRITEDISKPAGES) DSK REQUEST)))) (COND ((NOT (EMADDRESSP DAs)) (\BLT DAs EMDAs (IPLUS LASTPAGE 2 (IMINUS DAorigin))))) (\BOXIPLUS (LOCF (fetch DISKIOTIME of \MISCSTATS)) (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch DISKTEMP1 of \MISCSTATS))) (LOCF (fetch DISKTEMP0 of \MISCSTATS)))) (* Note total time spent)) (COND ((ILESSP RESULT 0) (\DISKERROR (IMINUS RESULT) STREAM) (GO RETRY)) (T (RETURN (SIGNED RESULT BITSPERWORD)))))) ) (\DISKERROR (LAMBDA (ERRCODE STREAM LASTNC) (* bvm%: "12-Mar-85 03:44") (COND (STREAM (M44.SIGNAL.DISK.ERROR ERRCODE (fetch FULLFILENAME of STREAM))) (T (while T do (SELECTC ERRCODE (\DSK.HARD.ERROR (RAID "Hard Disk Error in Lisp.virtualmem. Page = " (fetch (DSKOBJ CURRENTDISKPAGE) of \MAINDISK))) (\DSK.FULL.ERROR (RAID "Disk Full")) (RAID "Unknown disk error in Lisp.virtualmem" ERRCODE)))))) ) (M44.SIGNAL.DISK.ERROR (LAMBDA (ERRCODE FILENAME) (* bvm%: "17-Jan-85 17:46") (* ;; "This is a separate function, without a backslash, so that user can OK from the break, in which case we return OK from here, telling caller to try again") (COND (ERRCODE (bind (EC _ (PROG1 ERRCODE (SETQ ERRCODE NIL))) while T do (SELECTC EC (\DSK.HARD.ERROR (LISPERROR "HARD DISK ERROR" FILENAME T)) (\DSK.FULL.ERROR (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" FILENAME T)) (ERROR "Disk Error" FILENAME)))) (T (QUOTE OK)))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS .SETUPDISKBUFFERS. MACRO ((ACTION) (* bvm%: "15-OCT-82 17:28") (SETQ EMBUFS \EMUDISKBUFFERS) (SETQ EMBLOCK \EMUSCRATCH) [COND ((ILESSP DAorigin (SUB1 FIRSTPAGE)) [SETQ DAs (\ADDBASE DAs (SUB1 (IDIFFERENCE FIRSTPAGE DAorigin] [AND CAs (SETQ CAs (\ADDBASE CAs (SUB1 (IDIFFERENCE FIRSTPAGE DAorigin] (SETQ DAorigin (SUB1 FIRSTPAGE] [SETQ EMDAs (COND ((EMADDRESSP DAs) DAs) (T (\BLT EMBLOCK DAs (IPLUS LASTPAGE 2 (IMINUS DAorigin))) (PROG1 EMBLOCK [SETQ EMBLOCK (\ADDBASE EMBLOCK (IPLUS LASTPAGE 2 (IMINUS DAorigin]) ] [COND [CAs (SETQ EMCAs (\ADDBASE CAs (IMINUS DAorigin] [(AND (LISTP BUFFERS) (OR (CDR BUFFERS) (PROGN (SETQ BUFFERS (CAR BUFFERS)) (* ;  "Treat singleton BUFFER as nonlist") NIL))) (SETQ EMCAs (\ADDBASE EMBLOCK (IMINUS FIRSTPAGE))) (for BUF in BUFFERS as N from FIRSTPAGE bind FIXEDBUF do [\PUTBASE EMBLOCK 0 (COND ((AND BUF (EMADDRESSP BUF)) (\LOLOC BUF)) ((AND (NULL BUF) FIXEDBUF)) (T (PROG1 (\LOLOC EMBUFS) [COND ((DISKWRITEACTION? (OR (AND (EQ N LASTPAGE) LASTACTION) ACTION)) (COND (BUF (\BLT EMBUFS BUF WORDSPERPAGE)) (T (\CLEARWORDS EMBUFS WORDSPERPAGE) (SETQ FIXEDBUF (\LOLOC EMBUFS] (SETQ EMBUFS (\ADDBASE EMBUFS WORDSPERPAGE)) (COND ((PTRGTP EMBUFS \EMUDISKBUFEND) (ERROR "Attempt to act on too many disk pages"))))] (SETQ EMBLOCK (\ADDBASE EMBLOCK 1] (T (SETQ EMFIXEDCA (COND ((AND BUFFERS (EMADDRESSP BUFFERS)) BUFFERS) (T [COND ((DISKWRITEACTION? ACTION) (* ;  "If writing, copy data into buffer") (COND (BUFFERS (\BLT EMBUFS BUFFERS WORDSPERPAGE)) (T (\CLEARWORDS EMBUFS WORDSPERPAGE] EMBUFS] (replace DISKCAS of REQUEST with EMCAs) (replace FIXEDDISKBUFFER of REQUEST with EMFIXEDCA) (replace DISKDAS of REQUEST with (\ADDBASE EMDAs (IMINUS DAorigin))) (replace DISKVERSION of REQUEST with (fetch FPVERSION of FID)) (\BLT (LOCF (fetch DISKSERIAL# of REQUEST)) FID WORDSPERCELL) (* ; "Fill in serial number for label") (replace DISKFIRSTPAGE of REQUEST with FIRSTPAGE) (replace DISKLASTPAGE of REQUEST with LASTPAGE) (replace DISKHINTLASTPAGE of REQUEST with (OR HINTLASTPAGE 0)))) (PUTPROPS DISKWRITEACTION? MACRO ((ACTION) (* bvm%: "15-OCT-82 17:06") (SELECTC ACTION ((LIST \DC.WRITEHLD \DC.WRITELD \DC.WRITED) T) NIL))) (PUTPROPS DISKREADACTION? MACRO ((ACTION) (* bvm%: "15-OCT-82 17:06") (ILESSP ACTION \DC.WRITEHLD))) ) (PUTPROPS .DISKPARTINSTR. DOPVAL (1 SUBRCALL 8 1)) (RPAQQ DISKCOMMANDS ((\DC.READHLD 54784) (\DC.READLD 54785) (\DC.READD 54786) (\DC.WRITEHLD 54787) (\DC.WRITELD 54788) (\DC.WRITED 54789) (\DC.SEEKONLY 54790) (\DC.NOOP 54791) (\DC.RESTORE 54891))) (DECLARE%: EVAL@COMPILE (RPAQQ \DC.READHLD 54784) (RPAQQ \DC.READLD 54785) (RPAQQ \DC.READD 54786) (RPAQQ \DC.WRITEHLD 54787) (RPAQQ \DC.WRITELD 54788) (RPAQQ \DC.WRITED 54789) (RPAQQ \DC.SEEKONLY 54790) (RPAQQ \DC.NOOP 54791) (RPAQQ \DC.RESTORE 54891) (CONSTANTS (\DC.READHLD 54784) (\DC.READLD 54785) (\DC.READD 54786) (\DC.WRITEHLD 54787) (\DC.WRITELD 54788) (\DC.WRITED 54789) (\DC.SEEKONLY 54790) (\DC.NOOP 54791) (\DC.RESTORE 54891)) ) (RPAQQ DISKERRORS ((\DSK.HARD.ERROR 1101) (\DSK.FULL.ERROR 1102))) (DECLARE%: EVAL@COMPILE (RPAQQ \DSK.HARD.ERROR 1101) (RPAQQ \DSK.FULL.ERROR 1102) (CONSTANTS (\DSK.HARD.ERROR 1101) (\DSK.FULL.ERROR 1102)) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD DISKREQUEST ((DISKDAS FULLXPOINTER) (* ; "Vector of DAs to be acted on") (DISKCAS FULLXPOINTER) (FIXEDDISKBUFFER FULLXPOINTER) (DISKERRORCODE FULLXPOINTER) (CBCLEANUPFN FULLXPOINTER) (DISKFIRSTPAGE WORD) (DISKLASTPAGE WORD) (DISKHINTLASTPAGE WORD) (DISKVERSION WORD) (* ;  "These 3 words are for the disk label") (DISKSERIAL# FIXP) (DISKACTION WORD) (LASTDISKACTION WORD) (CURRENTNUMCHARS WORD) (LASTPAGEACTEDON WORD) (DISKWRITELASTNUMCHARS WORD) (RETURNONCHECKERROR FLAG) (DISKNOALLOC FLAG) (NIL BITS 14) (DISKCASTORAGE 20 WORD) (DISKDASTORAGE 60 WORD) (* ; "Or as much as you want") ) [ACCESSFNS ((DISKFID (LOCF (fetch DISKVERSION of DATUM] (CREATE (\ALLOCBLOCK (FOLDHI (IPLUS \FIXEDLENDISKREQUEST 60) WORDSPERCELL)))) (BLOCKRECORD ALTODSKOBJ ((NIL 8 WORD) (* ;  "Alto functions to implement generic ops") (DSKFPSYSDIR WORD) (* ; "Short pointer to SYSDIR FP") (NIL 2 WORD) (* ; "More alto fns") (DSKFPWORKINGDIR WORD) (* ;  "Short pointer to FP of 'working' dir") (DSKNAMEWORKINGDIR WORD) (* ; "Short pointer to bcpl string") (DSKLNPAGESIZE WORD) (* ; "ln[pagesize-in-words]") (NIL 3 WORD) (* ; "More alto cruft") (DSKKD WORD) (* ; "Short pointer to DDHEADER") (DSKFPDISKDESCRIPTOR WORD) (* ;  "Short pointer to DiskDescriptor FP") (DSKDRIVE# WORD) (DSKRETRYCOUNT WORD) (DSKTOTALERRORS WORD) (DSKLENCBZ WORD) (DSKLENCB WORD) (DSKDDHEADER 16 WORD) (* ; "Overlays DDHEADER") (NIL 2 WORD) (DSKDDMGR WORD) (* ;  "DD manager, for \FLUSHDISKDESCRIPTOR") (DSKLASTVDA WORD) (* ;  "VDA of last page allocated, for biasing search") (DSKSYSDIRBLK 5 WORD) (DSKDDBLK 5 WORD) (DSKWDBLK 5 WORD) (NIL 20 WORD) (* ; "WorkingDir name") (DSKDDVDAS 17 WORD) (* ; "VDAs for the data part of DD") ) [ACCESSFNS ALTODSKOBJ ((DDHEADER (LOCF (fetch DSKDDHEADER of DATUM]) (BLOCKRECORD DDHEADER ((DD#DISKS WORD) (DD#TRACKS WORD) (DD#HEADS WORD) (DD#SECTORS WORD) (DDLASTSERIAL# FIXP) (NIL WORD) (DDBTSIZE WORD) (* ; "Size of bittable in words") (DDDEFAULTVERSIONSKEPT WORD) (DDFREEPAGES WORD) (NIL 6 WORD))) (BLOCKRECORD CB ((CBQSTATUS BITS 4) (CBNEXT POINTER) (* ; "Link to next one") (SHORTCB POINTER) (* ;  "In alto space, what disk actually uses") (CBPAGENO WORD) (* ;  "The page number we intended to act on with this CB") ) (CREATE (\ALLOCBLOCK 3))) (BLOCKRECORD DISKLABEL ((DLNEXT WORD) (DLPREVIOUS WORD) (NIL WORD) (DLNUMCHARS WORD) (DLPAGENO WORD) (DLFID 3 WORD) (* ;  "Version followed by 2-word serial number") )) (ACCESSFNS REALDA ((SECTOR (LRSH DATUM 12)) (TRACK (LOGAND (LRSH DATUM 3) 511)) (HEAD (LOGAND (LRSH DATUM 2) 1)) (DISK (LOGAND (LRSH DATUM 1) 1)) (RESTORE (LOGAND DATUM 1)))) (BLOCKRECORD SHORTCB ((CBLINK WORD) (* ;  "Short pointer to next in command chain, or zero") (CBSTATUS WORD) (CBCOMMAND WORD) (CBHEADERADDR WORD) (* ;  "Short pointer to header record, normally CBHEADER") (CBLABELADDR WORD) (* ;  "Short pointer to label record, normally either in this CB or in the next cb in chain") (CBDATAADDR WORD) (* ; "Short pointer to buffer of data") (CBWAKEUPS WORD) (* ; "These two are always zero") (CBERRWAKEUPS WORD) (CBHEADER WORD) (CBDA WORD) (* ;  "Address of this disk block. May be filled in by previous access's label pointing at my CBHEADER") (CBLABNEXT WORD) (* ;  "Start of label field, if my CBLABELADDR points here") (CBLABPREV WORD) (CBLABBLANK WORD) (CBLABNUMCHARS WORD) (CBLABPAGENO WORD) (CBLABVERSION WORD) (CBLABSN1 WORD) (CBLABSN2 WORD) (CBTRUEPAGENO WORD) (* ;  "From here on is alto stuff that Lisp doesn't care about") (CBCBZ WORD) (CBNEXTSHORTCB WORD)) (BLOCKRECORD SHORTCB ((NIL WORD) (CBSECTOR BITS 4) (CBDONE BITS 4) (CBSEEKFAIL BITS 1) (CBSEEKING BITS 1) (CBNOTREADY BITS 1) (CBDATALATE BITS 1) (CBNOTRANSFER BITS 1) (CBCHECKSUMERR BITS 1) (CBFINALSTATUS BITS 2) (CBSEAL BYTE) (CBACTION BYTE))) (BLOCKRECORD SHORTCB ((NIL WORD) (NIL WORD) (CBSHORTSEAL BITS 5) (CBPARTITION BITS 3) (NIL BYTE)))) (BLOCKRECORD FP ((FPSERIAL# FIXP) (FPVERSION WORD) (NIL WORD) (FPLEADERVDA WORD)) (BLOCKRECORD FP ((FPSERIALHI WORD) (FPSERIALLO WORD) (NIL 3 WORD)))) (BLOCKRECORD DSKOBJ ((ddPOINTER FULLXPOINTER) (* ;; "Either points at word 2 of this structure, or at DSKOBJ:LASTSERIAL#, so that we can maintain some fields in parallel with alto OS for awhile. The next 6 words are arranged exactly as in the alto KDH structure, at least those fields we care about") (ddLASTSERIAL# FIXP) (* ; "Last serial number given a file") (NIL WORD) (ddBITTABLESIZE WORD) (* ;  "Size of disk descriptor's bit table in words") (NIL WORD) (ddFREEPAGES WORD) (DSKPARTITION BITS 4) (* ; "0 or explicit partition pointer") (ALTODSKOBJ XPOINTER) (* ;  "Pointer to alto BFSDSK structure, or NIL for disks other than current partition") (SAWCHECKERROR FLAG) (DISKERRORCNT BITS 3) (SYSDIROFD POINTER) (* ; "Stream onto SYSDIR.;1") (DDDIRTY FLAG) (* ;  "true if diskdescriptor needs writing") (DDVALID FLAG) (* ;  "True if DISKDESCRIPTOROFD field is ok. Invalidated on logout, etc") (DSKPASSWORDOK FLAG) (* ;  "True after password for this partition, if any, has been validated") (NIL BITS 1) (DISKDESCRIPTOROFD POINTER) (* ; "Stream onto DiskDescriptor.;1") (CBQUEUE POINTER) (* ;  "Stuff for management of command blocks. No ref count because must not fault") (CBFREEPTR FULLXPOINTER) (CBPENDINGPTR FULLXPOINTER) (CBLASTPTR FULLXPOINTER) (CURRENTDAS FULLXPOINTER) (* ;  "Vector of DAs currently being acted on") (DISKREQUEST FULLXPOINTER) (DISKDEVICENAME POINTER) (* ; "For retrieving the FDEV") (DISKLASTPAGEALLOC WORD) (* ; "Bias for new page search") (* ; "Pointer to request subrecord") (CURRENTDISKPAGE WORD) (TOTALDISKERRORS WORD) (NDISKS WORD) (* ;  "Shape of disk. Info taken from disk descriptor") (NTRACKS WORD) (NHEADS WORD) (NSECTORS WORD) (RETRYCOUNT WORD)) (CREATE (\ALLOCBLOCK 18)) ddPOINTER _ NIL (BLOCKRECORD ddPOINTER ((DISKLASTSERIAL# FIXP) (NIL WORD) (DISKBITTABLESIZE WORD) (NIL WORD) (DISKFREEPAGES WORD)))) (BLOCKRECORD \M44LeaderPage ((TimeCreate FIXP) (TimeWrite FIXP) (TimeRead FIXP) (NameCharCount BYTE) (NameChars 39 BYTE) (LeaderProps 210 WORD) (Spares 10 WORD) (PropertyPtr WORD) (ConsecutiveHint FLAG) (NIL BITS 7) (ChangeSerialNumber BYTE) (FIDDirectoryHint 5 WORD) (LastPageAddress WORD) (LastPageNumber WORD) (LastPageByteCount WORD)) (BLOCKRECORD \M44LeaderPage ((NIL WORD) (TimeCreateLo WORD) (NIL WORD) (TimeWriteLo WORD) (NIL FIXP) (NIL 20 WORD) (NIL 210 WORD) (NIL 10 WORD) (PropertyBegin BYTE) (PropertyLength BYTE))) (CREATE (NCREATE 'VMEMPAGEP))) (ACCESSFNS M44STREAM ((FID (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (FILEPAGEMAP (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (LASTMAPPEDPAGE (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (DIRINFO (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE)) (LEADERPAGE (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (LastPage (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (LastOffset (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE))) (ACCESSFNS M44STREAM ((DIRHOLEPTR (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE) ) (* ; "In dir stream only") )) (CREATE (create STREAM)) LASTMAPPEDPAGE _ -1 LastPage _ 0 LastOffset _ 0) (ACCESSFNS FID ((W0 (\WORDELT DATUM 0) (SETA DATUM 0 NEWVALUE)) (W1 (\WORDELT DATUM 1) (SETA DATUM 1 NEWVALUE)) (W2 (\WORDELT DATUM 2) (SETA DATUM 2 NEWVALUE)) (W3 (\WORDELT DATUM 3) (SETA DATUM 3 NEWVALUE)) (W4 (\WORDELT DATUM 4) (SETA DATUM 4 NEWVALUE)) (FIDBLOCK (fetch (ARRAYP BASE) of DATUM))) (CREATE (ARRAY 5 'SMALLPOSP 0 0))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \FILLINDA 65534) (RPAQQ \EOFDA 65535) (RPAQQ \LENFP 5) (RPAQQ \FP.DIRECTORYP 32768) (RPAQQ \INITPROPPTR 6866) (RPAQQ \DDBITTABSTART 32) (RPAQQ \NBYTES.DISKINFO 12) (RPAQQ \OFFSET.DISKLASTSERIAL# 8) (RPAQQ \NWORDS.DSKOBJ 36) (CONSTANTS (\FILLINDA 65534) (\EOFDA 65535) (\LENFP 5) (\FP.DIRECTORYP 32768) (\INITPROPPTR 6866) (\DDBITTABSTART 32) (\NBYTES.DISKINFO 12) (\OFFSET.DISKLASTSERIAL# 8) (\NWORDS.DSKOBJ 36)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \EMUDISKBUFEND \EMUDISKBUFFERS \EMUSCRATCH \EMUSWAPBUFFERS \EXTRAISFBUF \ISFMAP \ISFMAXCHUNK \ISFSCRATCHCAS \ISFSCRATCHDAS \#DISKBUFFERS \MAXDISKDAs \#SWAPBUFFERS \SYSDISK \ISFCHUNKSIZE \MAINDISK \DISKREQUESTBLOCK \SWAPREQUESTBLOCK \DISKDEBUG \MAXSWAPBUFFERS \SPAREDISKWRITEBUFFER \FREEPAGEFID \#EMUBUFFERS \EMUBUFFERS \LASTVMEMFILEPAGE \SWAPDSK1 \SWAPDSK2 \XVmemFmapBase \XVmemFmapHighBase \XVmemDiskBase \XVmem \M44.READY) ) ) (* ; "Super low level") (DEFINEQ (\ACTONVMEMPAGES (LAMBDA (DSK BUFFERS DAs DAorigin FIRSTPAGE LASTPAGE ACTION LASTACTION HINTLASTPAGE CAs) (* bvm%: "13-Feb-85 19:00") (PROG ((REQUEST \SWAPREQUESTBLOCK)) (replace FIXEDDISKBUFFER of REQUEST with (COND (CAs (replace DISKCAS of REQUEST with (\ADDBASE CAs (IMINUS DAorigin))) NIL) (T BUFFERS))) (replace DISKDAS of REQUEST with (\ADDBASE DAs (IMINUS DAorigin))) (replace DISKFIRSTPAGE of REQUEST with FIRSTPAGE) (replace DISKLASTPAGE of REQUEST with LASTPAGE) (replace DISKHINTLASTPAGE of REQUEST with (OR HINTLASTPAGE 0)) (replace DISKACTION of REQUEST with ACTION) (replace LASTDISKACTION of REQUEST with (COND ((AND LASTACTION (NEQ LASTACTION 0)) LASTACTION) (T ACTION))) (RETURN (\DOACTONDISKPAGES DSK REQUEST)))) ) (\WRITEVMEMPAGES (LAMBDA (DSK BUFFERS DAs DAorigin FID FIRSTPAGE LASTPAGE LASTNUMCHARS HINTLASTPAGE CAs) (* bvm%: "13-Feb-85 19:02") (* ;;; "\WRITEDISKPAGES inside the junk context. Used by \M44DOEXTENDVMEMFILE") (CHECK (NOT \INTERRUPTABLE)) (PROG ((REQUEST \DISKREQUESTBLOCK)) (COND (CAs (replace DISKCAS of REQUEST with (\ADDBASE CAs (IMINUS DAorigin))))) (replace FIXEDDISKBUFFER of REQUEST with BUFFERS) (replace DISKDAS of REQUEST with (\ADDBASE DAs (IMINUS DAorigin))) (replace DISKVERSION of REQUEST with (fetch FPVERSION of FID)) (\BLT (LOCF (fetch DISKSERIAL# of REQUEST)) FID WORDSPERCELL) (* ; "Fill in serial number for label") (replace DISKFIRSTPAGE of REQUEST with FIRSTPAGE) (replace DISKLASTPAGE of REQUEST with LASTPAGE) (replace DISKHINTLASTPAGE of REQUEST with (OR HINTLASTPAGE 0)) (replace DISKNOALLOC of REQUEST with NIL) (replace DISKWRITELASTNUMCHARS of REQUEST with (OR LASTNUMCHARS BYTESPERPAGE)) (RETURN (\DOWRITEDISKPAGES DSK REQUEST)))) ) (\DOACTONDISKPAGES (LAMBDA (DSK REQUEST CLEANUPFN) (* bvm%: "30-DEC-82 13:08") (PROG ((CAS (fetch DISKCAS of REQUEST)) (DAS (fetch DISKDAS of REQUEST)) (FIRSTPAGE (fetch DISKFIRSTPAGE of REQUEST)) (LASTPAGE (fetch DISKLASTPAGE of REQUEST)) (BUFFER (fetch FIXEDDISKBUFFER of REQUEST)) (HINTLASTPAGE (fetch DISKHINTLASTPAGE of REQUEST)) (RETURNONCHECKERROR (fetch RETURNONCHECKERROR of REQUEST)) CURRENTPAGE CB NEXTCB RESULT THISACTION) (replace DISKREQUEST of DSK with REQUEST) (replace CURRENTDAS of DSK with DAS) (replace DISKERRORCNT of DSK with 0) (replace SAWCHECKERROR of DSK with NIL) (replace CBCLEANUPFN of REQUEST with CLEANUPFN) (COND ((OR (NOT HINTLASTPAGE) (ILESSP HINTLASTPAGE FIRSTPAGE) (IGREATERP HINTLASTPAGE LASTPAGE)) (SETQ HINTLASTPAGE LASTPAGE))) (SETQ CURRENTPAGE FIRSTPAGE) (* ;; "HINTLASTPAGE is used, if reasonable, to terminate activity before LASTPAGE so that we do not chain off the end and seek to cylinder 0, a typical BFS bug. If the hint is wrong, we just resume from there, having wasted a disk rotation") RETRY (replace CBLASTPTR of DSK with NIL) (replace CBFREEPTR of DSK with (replace CBPENDINGPTR of DSK with (fetch CBQUEUE of DSK))) (SETQ CB (\GETDISKCB DSK)) (* ; "Should never return NIL") (SETQ RESULT HINTLASTPAGE) (for PAGENO from CURRENTPAGE to HINTLASTPAGE until (COND ((EQ (\GETBASE DAS PAGENO) \EOFDA) (* ; "At end of file, do no more") (SETQ RESULT (SUB1 PAGENO)) T)) do (SETQ THISACTION (COND ((EQ PAGENO LASTPAGE) (fetch LASTDISKACTION of REQUEST)) (T (fetch DISKACTION of REQUEST)))) (COND ((AND RETURNONCHECKERROR (fetch SAWCHECKERROR of DSK)) (* ; "No disk activity now, because cleanup waited for disk to stop") (replace LASTPAGEACTEDON of REQUEST with (SUB1 PAGENO)) (RETURN (SETQ RESULT (LOGAND (IMINUS (IPLUS PAGENO -1 64)) 65535))))) (COND ((NEQ THISACTION \DC.NOOP) (COND ((NULL (SETQ NEXTCB (\GETDISKCB DSK))) (GO FAILURE))) (replace (CB CBLABELADDR) of CB with (\LOLOC (COND ((EQ (\GETBASE DAS (ADD1 PAGENO)) \FILLINDA) (* ;; "Chain to next cb, so that the next field from the label of CB is written into the diskaddress field of NEXTCB") (LOCF (fetch (CB CBDA) of NEXTCB))) (T (LOCF (fetch (CB CBLABNEXT) of NEXTCB)))))) (\DODISKCOMMAND DSK CB (OR BUFFER (EMPOINTER (\GETBASE CAS PAGENO))) (\GETBASE DAS PAGENO) PAGENO THISACTION) (SETQ CB NEXTCB))) finally (COND ((AND (fetch CBFREEPTR of DSK) (NEQ (fetch CBFREEPTR of DSK) (fetch CBNEXT of CB))) (RAID "Inconsistency in CBFREEPTR" CB))) (replace CBFREEPTR of DSK with CB) (* ; "'Put back' the last CB, since it is never used for a command") (do (* ; "Wait for commands to complete") (SELECTQ (\CLEANUPDISKQUEUE DSK) (NIL (GO FAILURE)) (T (RETURN)) NIL)) (COND ((AND (NEQ RESULT LASTPAGE) (NEQ (\GETBASE DAS (ADD1 RESULT)) \EOFDA)) (* ; "Stopped before LASTPAGE because of a bad hint. Ignore hint and continue") (SETQ HINTLASTPAGE LASTPAGE) (SETQ CURRENTPAGE (ADD1 RESULT)) (GO RETRY))) (replace LASTPAGEACTEDON of REQUEST with RESULT)) (RETURN RESULT) FAILURE (COND ((ILEQ (fetch DISKERRORCNT of DSK) (fetch RETRYCOUNT of DSK)) (SETQ CURRENTPAGE (fetch CURRENTDISKPAGE of DSK)) (GO RETRY))) (RETURN (IMINUS \DSK.HARD.ERROR)))) ) (\DOWRITEDISKPAGES (LAMBDA (DSK REQUEST) (* bvm%: "17-Jan-85 17:06") (PROG ((CAS (fetch DISKCAS of REQUEST)) (DAS (fetch DISKDAS of REQUEST)) (FIRSTPAGE (fetch DISKFIRSTPAGE of REQUEST)) (LASTPAGE (fetch DISKLASTPAGE of REQUEST)) (BUFFER (fetch FIXEDDISKBUFFER of REQUEST)) CURRENTPAGE CB FIRSTNEWPAGE NEXTNEWPAGE LASTVDA LAB) (COND ((NOT (fetch DISKNOALLOC of REQUEST)) (* ; "First try \ACTONDISKPAGES for any existing pages") (COND ((EQ (\GETBASE DAS FIRSTPAGE) \FILLINDA) (* ; "This happens from createfile, no pages exist yet") (SETQ FIRSTNEWPAGE FIRSTPAGE)) (T (COND ((EQ (\GETBASE DAS (ADD1 FIRSTPAGE)) \EOFDA) (* ;; "FIRSTPAGE is the last existing page of the file, so we will have to rewrite its label anyway later on, so don't do anything now")) (T (* ;; "Some of these pages may not need to have their labels written, so see how far we can get with just \ACTONDISKPAGES ...") (replace DISKACTION of REQUEST with (replace LASTDISKACTION of REQUEST with \DC.WRITED)) (replace RETURNONCHECKERROR of REQUEST with NIL) (SETQ FIRSTPAGE (\DOACTONDISKPAGES DSK REQUEST)) (COND ((AND (EQ FIRSTPAGE LASTPAGE) (EQ (fetch DISKWRITELASTNUMCHARS of REQUEST) (fetch CURRENTNUMCHARS of REQUEST))) (* ; "All pages acted on, and byte count does not need to be changed") (RETURN LASTPAGE)) ((ILESSP FIRSTPAGE 0) (* ; "Error") (RETURN FIRSTPAGE))))) (SETQ FIRSTNEWPAGE (ADD1 FIRSTPAGE)))) (COND ((ILEQ FIRSTNEWPAGE LASTPAGE) (* ;; "Need to allocate new pages. For this, we need a spare buffer for reading the new pages to make sure they are free pages") (replace FIXEDDISKBUFFER of REQUEST with \SPAREDISKWRITEBUFFER) (replace DISKACTION of REQUEST with (replace LASTDISKACTION of REQUEST with \DC.READLD)) (SETQ NEXTNEWPAGE FIRSTNEWPAGE) (do (SETQ LASTVDA (\GETBASE DAS (SUB1 NEXTNEWPAGE))) (for I from NEXTNEWPAGE to LASTPAGE do (COND ((NOT (SETQ LASTVDA (\ASSIGNDISKPAGE DSK LASTVDA))) (* ; "Disk full. Back out the pages we have assigned so far") (for J from FIRSTNEWPAGE to (SUB1 I) do (\M44MARKPAGEFREE DSK (\GETBASE DAS J)) (\PUTBASE DAS J \FILLINDA)) (GO DISKFULL))) (\PUTBASE DAS I LASTVDA)) (* ; "Now check that the pages are really free") (replace DISKFIRSTPAGE of REQUEST with NEXTNEWPAGE) (\DOACTONDISKPAGES DSK REQUEST (FUNCTION \CHECKFREEPAGE)) (* ;; "\CHECKFREEPAGE checks to make sure the page is really free, and if it is, stores its address in DAS. We now march thru DAS, compacting toward the front all the pages that are really free, then iterate allocating more if necessary") (for I from NEXTNEWPAGE to LASTPAGE when (NEQ (SETQ LASTVDA (\GETBASE DAS I)) \FILLINDA) do (\PUTBASE DAS NEXTNEWPAGE LASTVDA) (add NEXTNEWPAGE 1)) repeatuntil (IGREATERP NEXTNEWPAGE LASTPAGE)))))) (replace DISKREQUEST of DSK with REQUEST) (replace CURRENTDAS of DSK with DAS) (replace DISKERRORCNT of DSK with 0) (replace SAWCHECKERROR of DSK with NIL) (replace CBCLEANUPFN of REQUEST with NIL) (SETQ CURRENTPAGE FIRSTPAGE) RETRY (replace CBLASTPTR of DSK with NIL) (replace CBFREEPTR of DSK with (replace CBPENDINGPTR of DSK with (fetch CBQUEUE of DSK))) (for PAGENO from CURRENTPAGE to LASTPAGE do (COND ((NULL (SETQ CB (\GETDISKCB DSK))) (GO FAILURE))) (COND ((OR (AND (EQ PAGENO LASTPAGE) (NEQ (fetch DISKWRITELASTNUMCHARS of REQUEST) BYTESPERPAGE)) (EQ (\GETBASE DAS (ADD1 PAGENO)) \FILLINDA)) (* ; "Mark end of file after this page") (\PUTBASE DAS (ADD1 PAGENO) \EOFDA))) (* ; "Set up label with next and previous disk addresses, numchars") (SETQ LAB (LOCF (fetch (CB CBLABNEXT) of CB))) (replace DLNEXT of LAB with (\REALDISKDA DSK (\GETBASE DAS (ADD1 PAGENO)))) (replace DLPREVIOUS of LAB with (\REALDISKDA DSK (\GETBASE DAS (SUB1 PAGENO)))) (replace DLNUMCHARS of LAB with (COND ((EQ PAGENO LASTPAGE) (fetch DISKWRITELASTNUMCHARS of REQUEST)) (T BYTESPERPAGE))) (replace (CB CBLABELADDR) of CB with (\LOLOC LAB)) (\DODISKCOMMAND DSK CB (OR BUFFER (EMPOINTER (\GETBASE CAS PAGENO))) (\GETBASE DAS PAGENO) PAGENO \DC.WRITELD) finally (do (* ; "Wait for commands to complete") (SELECTQ (\CLEANUPDISKQUEUE DSK) (NIL (GO FAILURE)) (T (RETURN)) NIL))) (replace LASTPAGEACTEDON of REQUEST with LASTPAGE) (RETURN LASTPAGE) FAILURE (COND ((ILEQ (fetch DISKERRORCNT of DSK) (fetch RETRYCOUNT of DSK)) (SETQ CURRENTPAGE (fetch CURRENTDISKPAGE of DSK)) (GO RETRY))) (RETURN (IMINUS \DSK.HARD.ERROR)) DISKFULL (RETURN (IMINUS \DSK.FULL.ERROR)))) ) (\CHECKFREEPAGE (LAMBDA (DSK CB) (* bvm%: " 9-DEC-82 13:41") (* ;; "Check that CB got a free page, i.e. one whose file id is all -1") (PROG ((FID (LOCF (fetch DLFID of (EMPOINTER (fetch (CB CBLABELADDR) of CB)))))) (FRPTQ 3 (PROGN (COND ((NEQ (\GETBASE FID 0) (UNSIGNED -1 BITSPERWORD)) (* ; "Oops, bittable was wrong, so nullify this guy's address in caller") (\PUTBASE (fetch (DSKOBJ DISKDAS) of DSK) (fetch (CB CBPAGENO) of CB) \FILLINDA) (RETURN))) (SETQ FID (\ADDBASE FID 1)))) (RETURN T))) ) (\DODISKCOMMAND (LAMBDA (DSK CB BUFFER VDA PAGENO ACTION NEXTCB) (* bvm%: "13-Feb-85 19:42") (PROG ((SHORTCB (fetch SHORTCB of CB)) LA NEXT LASTCB STATUS) (replace CBHEADERADDR of SHORTCB with (\LOLOC (LOCF (fetch CBHEADER of SHORTCB)))) (replace CBDATAADDR of SHORTCB with (\LOLOC BUFFER)) (COND ((EQ (SETQ LA (fetch CBLABELADDR of SHORTCB)) 0) (* ; "Fill this in only if caller hasn't") (replace CBLABELADDR of SHORTCB with (SETQ LA (\LOLOC (COND (NEXTCB (LOCF (fetch (CB CBDA) of NEXTCB))) (T (LOCF (fetch (CB CBLABNEXT) of CB))))))))) (SETQ LA (EMPOINTER LA)) (\BLT (LOCF (fetch DLFID of LA)) (fetch (DSKOBJ DISKFID) of DSK) 3) (* ; "Set serial number for label check") (replace DLPAGENO of LA with PAGENO) (replace CBPAGENO of CB with PAGENO) (COND ((NEQ VDA \FILLINDA) (replace CBDA of SHORTCB with (\REALDISKDA DSK VDA)))) (replace CBCOMMAND of SHORTCB with (IPLUS (SELECTC ACTION (\DC.READHLD \IDC.READHLD) (\DC.READLD \IDC.READLD) (\DC.READD \IDC.READD) (\DC.WRITEHLD \IDC.WRITEHLD) (\DC.WRITELD \IDC.WRITELD) (\DC.WRITED \IDC.WRITED) (\DC.SEEKONLY \IDC.SEEKONLY) (\DC.RESTORE (replace CBDA of SHORTCB with (ADD1 (LOGAND (fetch CBDA of SHORTCB) 61440))) (* ; "Track _ 0, Restore _ 1, so command is seek to track zero") \IDC.SEEKONLY) (RAID "Invalid disk action" ACTION)) (LLSH (fetch DSKPARTITION of DSK) 8))) (SETQ LASTCB (EMGETBASE \EM.DISKCOMMAND)) (COND ((NEQ LASTCB 0) (* ; "Disk is busy, queue CB up at end") (while (NEQ (SETQ NEXT (fetch CBLINK of (EMPOINTER LASTCB))) 0) do (SETQ LASTCB NEXT)) (replace CBLINK of (EMPOINTER LASTCB) with (\LOLOC SHORTCB)))) (COND ((AND (EQ (EMGETBASE \EM.DISKCOMMAND) 0) (OR (EQ LASTCB 0) (EQ (fetch CBDONE of SHORTCB) 0))) (* ;; "No CB's queued, so ours is the only one, and it hasn't been done yet. Careful here! If the last disk command got an error, we don't want to do this. Also true if last disk command was never executed, which means that some earlier command got an error") (COND ((OR (NOT (SETQ LASTCB (fetch CBLASTPTR of DSK))) (AND (NEQ (SETQ STATUS (LOGAND (fetch (CB CBSTATUS) of LASTCB) \CBS.GOODMASK)) 0) (EQ (LOGAND STATUS \CBS.ERRORBITS) 0))) (EMPUTBASE \EM.DISKCOMMAND (\LOLOC SHORTCB)))))) (replace CBQSTATUS of CB with \CB.PENDING) (replace CBLASTPTR of DSK with CB) (\BOXIPLUS (LOCF (fetch DISKOPS of \MISCSTATS)) 1))) ) (\GETDISKCB (LAMBDA (DSK) (* bvm%: "24-NOV-82 18:12") (* ;; "Gets a new CB, clearing it out, or returns NIL if there are errors. In latter case, caller should retry starting with CURRENTPAGE (set freely by \CLEANUPDISKQUEUE)") (PROG (CB) LP (RETURN (COND ((SETQ CB (fetch CBFREEPTR of DSK)) (replace CBFREEPTR of DSK with (COND ((EQ (fetch CBNEXT of CB) (fetch CBPENDINGPTR of DSK)) (* ; "Circular buffer; when pointers are equal means everyone is free. Free = NIL means nobody is free") NIL) (T (fetch CBNEXT of CB)))) (\CLEARCB CB) CB) ((NOT (\CLEANUPDISKQUEUE DSK)) (* ; "an error occurred") NIL) (T (* ; "A CB was returned to the free queue") (GO LP)))))) ) (\CLEARCB (LAMBDA (CB) (* bvm%: "13-Feb-85 19:19") (\CLEARWORDS (fetch SHORTCB of CB) \LENSHORTCB) (replace CBQSTATUS of CB with \CB.FREE) CB) ) (\CLEANUPDISKQUEUE (LAMBDA (DSK) (* bvm%: "13-Feb-85 19:42") (* ;; "Called to process pending CB's. If queue is empty and all is quiet, returns T. Returns NIL on errors, after running error routine. Otherwise, returns a finished CB, which has also been placed on \FREEDISKCBS by this action") (PROG ((CB (fetch CBPENDINGPTR of DSK)) (FREE (fetch CBFREEPTR of DSK)) SHORTCB LABEL LVDA) (COND ((EQ CB FREE) (RETURN T))) LP (* ; "Wait for disk to finish something") (SETQ SHORTCB (fetch SHORTCB of CB)) (COND ((EQ (fetch CBDONE of SHORTCB) 0) (* ; "Command not done yet") (COND ((AND (EQ (EMGETBASE \EM.DISKCOMMAND) 0) (EQ (fetch CBDONE of SHORTCB) 0)) (* ; "Disk queue was flushed for some reason. Fake an error") (COND ((NEQ (fetch CBQSTATUS of CB) \CB.PENDING) (RETURN (RAID "No free CB's"))) (T (replace CBSTATUS of SHORTCB with \CBS.FAKEERROR))))) (* ; "Here is where some day we could block to let another process run") (GO LP))) (* ; "We now have CB free from the disk controller") (replace CBPENDINGPTR of DSK with (fetch CBNEXT of CB)) (COND ((EQ CB (fetch CBLASTPTR of DSK)) (replace CBLASTPTR of DSK with NIL))) (* ; "Remove from pending queue") (replace CBSHORTSEAL of SHORTCB with 0) (* ; "Invalidate it as a disk command, just in case") (COND ((NOT FREE) (replace CBFREEPTR of DSK with (SETQ FREE CB)))) (* ; "Now clean up the transfer") (COND ((EQ (fetch RESTORE of (fetch CBDA of SHORTCB)) 1) (* ; "This is our command, not user's, so nothing to cleanup") (RETURN CB))) (COND ((NEQ (LOGAND (fetch CBSTATUS of SHORTCB) \CBS.GOODMASK) \CBS.GOOD) (* ; "Error occurred") (repeatuntil (EQ (EMGETBASE \EM.DISKCOMMAND) 0)) (* ; "Wait for disk to stop spinning") (COND ((NEQ (fetch TOTALDISKERRORS of DSK) MAX.SMALL.INTEGER) (* ; "Keep this count for debugging") (add (fetch TOTALDISKERRORS of DSK) 1))) (RETURN (COND ((IGREATERP (add (fetch DISKERRORCNT of DSK) 1) (fetch RETRYCOUNT of DSK)) (* ; "Hard error") (COND (\DISKDEBUG (* ; "Error is normally fielded in a more benign place") (RAID "Hard Disk Error. ^N to continue" CB)))) (T (COND ((EQ (fetch CBFINALSTATUS of SHORTCB) \CBS.CHECKERROR) (replace SAWCHECKERROR of DSK with T))) (replace CURRENTDISKPAGE of DSK with (fetch CBPAGENO of CB)) (COND ((IGREATERP (fetch DISKERRORCNT of DSK) (LRSH (fetch RETRYCOUNT of DSK) 1)) (* ; "Half the tolerable errors. Initiate a Restore to let disk recalibrate") (EMPUTBASE \EM.DISKADDRESS (UNSIGNED -1 BITSPERWORD)) (* ; "This forces a seek") (\DODISKCOMMAND DSK (\GETDISKCB DSK) NIL (\VIRTUALDISKDA DSK (fetch CBDA of SHORTCB)) (fetch CURRENTDISKPAGE of DSK) \DC.RESTORE))) NIL))))) (SETQ LABEL (EMPOINTER (fetch CBLABELADDR of SHORTCB))) (replace (DSKOBJ CURRENTNUMCHARS) of DSK with (fetch DLNUMCHARS of LABEL)) (replace DISKERRORCNT of DSK with 0) (replace SAWCHECKERROR of DSK with NIL) (COND ((fetch (DSKOBJ CBCLEANUPFN) of DSK) (APPLY* (fetch (DSKOBJ CBCLEANUPFN) of DSK) DSK CB)) (T (SETQ LVDA (\ADDBASE (fetch CURRENTDAS of DSK) (SUB1 (fetch CBPAGENO of CB)))) (COND ((EQ (\GETBASE LVDA 2) \FILLINDA) (* ; "Fill in Next address") (\PUTBASE LVDA 2 (\VIRTUALDISKDA DSK (fetch DLNEXT of LABEL))))) (COND ((EQ (\GETBASE LVDA 0) \FILLINDA) (* ; "Fill in Previous address") (\PUTBASE LVDA 0 (\VIRTUALDISKDA DSK (fetch DLPREVIOUS of LABEL))))))) (RETURN CB))) ) (\VIRTUALDISKDA (LAMBDA (DSK REALDA) (* bvm%: "13-Feb-85 19:43") (* ; "Converts a real disk address into a virtual one") (COND ((EQ REALDA 0) \EOFDA) (T (IPLUS (ITIMES (IPLUS (ITIMES (IPLUS (ITIMES (fetch DISK of REALDA) (fetch NTRACKS of DSK)) (fetch TRACK of REALDA)) (fetch NHEADS of DSK)) (fetch HEAD of REALDA)) (fetch NSECTORS of DSK)) (fetch SECTOR of REALDA))))) ) (\REALDISKDA (LAMBDA (DSK VDA) (* bvm%: "18-NOV-82 21:16") (* ;; "Returns a real disk address for given virtual address") (COND ((EQ VDA \EOFDA) 0) (T (PROG ((NSECTORS (fetch NSECTORS of DSK)) (NHEADS (fetch NHEADS of DSK)) (NTRACKS (fetch NTRACKS of DSK))) (RETURN (IPLUS (LLSH (IREMAINDER VDA NSECTORS) 12) (LLSH (IREMAINDER (SETQ VDA (IQUOTIENT VDA NSECTORS)) NHEADS) 2) (LLSH (IREMAINDER (SETQ VDA (IQUOTIENT VDA NHEADS)) NTRACKS) 3) (LLSH (IQUOTIENT VDA NTRACKS) 1))))))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ CBSTATUSCONSTANTS ((\CBS.ERRORBITS 183) (\CBS.GOODMASK 4023) (\CBS.GOOD 3840) (\CBS.FAKEERROR 3841) (\CBS.CHECKERROR 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \CBS.ERRORBITS 183) (RPAQQ \CBS.GOODMASK 4023) (RPAQQ \CBS.GOOD 3840) (RPAQQ \CBS.FAKEERROR 3841) (RPAQQ \CBS.CHECKERROR 2) (CONSTANTS (\CBS.ERRORBITS 183) (\CBS.GOODMASK 4023) (\CBS.GOOD 3840) (\CBS.FAKEERROR 3841) (\CBS.CHECKERROR 2)) ) (RPAQQ IDISKCOMMANDS ((\IDC.READHLD 18432) (\IDC.READLD 18496) (\IDC.READD 18512) (\IDC.WRITEHLD 18600) (\IDC.WRITELD 18536) (\IDC.WRITED 18520) (\IDC.SEEKONLY 18434))) (DECLARE%: EVAL@COMPILE (RPAQQ \IDC.READHLD 18432) (RPAQQ \IDC.READLD 18496) (RPAQQ \IDC.READD 18512) (RPAQQ \IDC.WRITEHLD 18600) (RPAQQ \IDC.WRITELD 18536) (RPAQQ \IDC.WRITED 18520) (RPAQQ \IDC.SEEKONLY 18434) (CONSTANTS (\IDC.READHLD 18432) (\IDC.READLD 18496) (\IDC.READD 18512) (\IDC.WRITEHLD 18600) (\IDC.WRITELD 18536) (\IDC.WRITED 18520) (\IDC.SEEKONLY 18434)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \EM.DISKCOMMAND 337) (RPAQQ \EM.DISKADDRESS 339) (RPAQQ \FIXEDLENDISKREQUEST 42) (RPAQQ \DEFAULTDASTORAGELENGTH 60) (RPAQQ \LENCB 6) (RPAQQ \LENDSKOBJ 34) (RPAQQ \LENSHORTCB 18) (CONSTANTS (\EM.DISKCOMMAND 337) (\EM.DISKADDRESS 339) (\FIXEDLENDISKREQUEST 42) (\DEFAULTDASTORAGELENGTH 60) (\LENCB 6) (\LENDSKOBJ 34) (\LENSHORTCB 18)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \CB.PENDING 1) (RPAQQ \CB.FREE 0) (CONSTANTS (\CB.PENDING 1) (\CB.FREE 0)) ) ) (* ; "At MAKEINIT time") (DEFINEQ (MAKEINITBFS (LAMBDA NIL (* ; "Edited 5-Nov-87 16:54 by bvm:") (* ;; "Called at MAKEINIT time to create bfs structures") (PROGN (* ; "Create disk structures for up to 3 virtual memory partitions.") (\LOCKWORDS (SETQ \MAINDISK (create DSKOBJ)) \NWORDS.DSKOBJ) (replace DISKDEVICENAME of \MAINDISK with (EVQ (QUOTE DSK))) (\LOCKWORDS (SETQ \SWAPDSK1 (create DSKOBJ)) \NWORDS.DSKOBJ) (\LOCKWORDS (SETQ \SWAPDSK2 (create DSKOBJ)) \NWORDS.DSKOBJ)) (PROGN (* ; "Disk request blocks for use by swapper and file system") (\LOCKWORDS (SETQ \SWAPREQUESTBLOCK (create DISKREQUEST)) (+ \FIXEDLENDISKREQUEST \DEFAULTDASTORAGELENGTH)) (\LOCKWORDS (SETQ \DISKREQUESTBLOCK (create DISKREQUEST)) (+ \FIXEDLENDISKREQUEST \DEFAULTDASTORAGELENGTH))) (to 3 bind PREV (FIRSTCB _ (create CB)) first (\LOCKWORDS (SETQ PREV FIRSTCB) \LENCB) do (\LOCKWORDS (SETQ PREV (create CB CBNEXT _ PREV)) \LENCB) finally (replace CBNEXT of FIRSTCB with PREV) (* ; "note queue is now circular") (replace CBQUEUE of \MAINDISK with FIRSTCB)) (SETQ \FREEPAGEFID (\ALLOCBLOCK 3)) (* ; "FP or FID for free disk page is all -1") (for I from 0 to 4 do (\PUTBASE \FREEPAGEFID I (UNSIGNED -1 BITSPERWORD)))) ) ) (DECLARE%: DONTCOPY (ADDTOVAR INITPTRS (\MAINDISK) (\SWAPDSK1) (\SWAPDSK2) (\SWAPREQUESTBLOCK) (\DISKREQUESTBLOCK) (\FREEPAGEFID)) (ADDTOVAR INEWCOMS (FNS MAKEINITBFS)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS MAKEINITBFS) ) (* ; "Swap stuff") (DEFINEQ (\M44ACTONVMEMFILE (LAMBDA (FIRSTPAGE BUFFER NPAGES WRITEFLG) (* ; "Edited 5-Nov-87 17:21 by bvm:") (PROG ((LASTPAGE (IPLUS FIRSTPAGE NPAGES -1)) (DAs \ISFSCRATCHDAS) (CAs \ISFSCRATCHCAS) (PAGE FIRSTPAGE) (BUF BUFFER) CHUNK RESULT) (if \XVmem then (* ;; "extended virtual memory is in use") (while (IGREATERP NPAGES 0) bind DISKRELATIVEPAGE WHICHPART ISFMAP do (SETQ ISFMAP (EMPOINTER (\GETBASE \XVmemFmapBase (SETQ WHICHPART (\WHICHPART PAGE))))) (if (EQ NPAGES 1) then (* ; "common case") (SETQ CHUNK 1) else (SETQ CHUNK (IMIN NPAGES \ISFCHUNKSIZE)) (if (IGREATERP (IPLUS PAGE (SUB1 CHUNK)) (\GETBASE \XVmemFmapHighBase WHICHPART)) then (* ; "oops -- trying to cross partition boundary in this chunk. Take the easy way out and step by ones until past the boundary.") (SETQ CHUNK 1))) (SETQ DISKRELATIVEPAGE (if (EQ WHICHPART 0) then PAGE else (* ;; "need to adjust page number based on which partition.") (ADD1 (IDIFFERENCE PAGE (\GETBASE \XVmemFmapHighBase (SUB1 WHICHPART)))))) (for I from 0 to (SUB1 CHUNK) do (\PUTBASE CAs I (\LOLOC BUF)) (\PUTBASE DAs I (\LOOKUPFMAP (IPLUS DISKRELATIVEPAGE I) ISFMAP)) (SETQ BUF (\ADDBASE BUF WORDSPERPAGE))) (\PUTBASE DAs CHUNK \FILLINDA) (\BLT (LOCF (fetch DISKSERIAL# of \SWAPREQUESTBLOCK)) ISFMAP WORDSPERCELL) (* ; "Fill in disk label for this partition's vmem") (COND ((ILESSP (SETQ RESULT (\ACTONVMEMPAGES (\GETBASEPTR \XVmemDiskBase (LLSH WHICHPART 1)) NIL DAs DISKRELATIVEPAGE DISKRELATIVEPAGE (IPLUS DISKRELATIVEPAGE CHUNK -1) (COND (WRITEFLG \DC.WRITED) (T \DC.READD)) NIL NIL CAs)) 0) (\SWAPDISKERROR (IMINUS RESULT) (\GETBASEPTR \XVmemDiskBase (LLSH WHICHPART 1))))) (SETQ NPAGES (IDIFFERENCE NPAGES CHUNK)) (SETQ PAGE (IPLUS PAGE CHUNK))) else (* ;; "not using extended virtual memory ") (AND (IGEQ LASTPAGE (\GETBASE \ISFMAP (fetch ISFLAST of \ISFMAP))) (EQ (\LOOKUPFMAP FIRSTPAGE) \FILLINDA) (RETURN (RAID "Can't complete swap operation--page not in isf map"))) (while (IGREATERP NPAGES 0) do (SETQ CHUNK (IMIN NPAGES \ISFCHUNKSIZE)) (for I from 0 to (SUB1 CHUNK) do (\PUTBASE CAs I (\LOLOC BUF)) (\PUTBASE DAs I (\LOOKUPFMAP (IPLUS PAGE I))) (SETQ BUF (\ADDBASE BUF WORDSPERPAGE))) (\PUTBASE DAs CHUNK \FILLINDA) (COND ((ILESSP (SETQ RESULT (\ACTONVMEMPAGES \MAINDISK NIL DAs PAGE PAGE (IPLUS PAGE CHUNK -1) (COND (WRITEFLG \DC.WRITED) (T \DC.READD)) NIL NIL CAs)) 0) (\SWAPDISKERROR (IMINUS RESULT)))) (SETQ NPAGES (IDIFFERENCE NPAGES CHUNK)) (SETQ PAGE (IPLUS PAGE CHUNK)))) (RETURN LASTPAGE))) ) (\LOOKUPFMAP (LAMBDA (PAGE ISFMAP) (* ; "Edited 5-Nov-87 16:30 by bvm:") (* ;; "Return virtual DA for partition-relative page number PAGE by searching the run table in ISFMAP, which defaults to the global \isfmap in the non-xvmem case. With extended vmem, caller already figured out which partition the absolute page number belongs to.") (PROG ((LO \ISFMAPOFFSET) HI MID) (if (NOT ISFMAP) then (* ;; "non-xvmem case, worry about perversities.") (if (EQ PAGE (fetch ISFONEPAGE of \ISFMAP)) then (* ; "This is in case runtable overflows") (RETURN (fetch ISFONEDA of \ISFMAP))) (if (IGEQ PAGE (\GETBASE \ISFMAP (fetch ISFLAST of \ISFMAP))) then (* ; "Should never happen") (RETURN \FILLINDA)) (SETQ ISFMAP \ISFMAP)) (SETQ HI (fetch ISFLAST of ISFMAP)) (while (IGREATERP HI (IPLUS LO 2)) do (SETQ MID (FLOOR (FOLDLO (IPLUS LO HI) 2) 2)) (* ; "Do binary chop on map. Page numbers are all at even offsets") (if (IGEQ PAGE (\GETBASE ISFMAP MID)) then (SETQ LO MID) else (SETQ HI MID))) (SETQ LO (\ADDBASE ISFMAP LO)) (RETURN (IPLUS (\GETBASE LO 1) (IDIFFERENCE PAGE (\GETBASE LO 0)))))) ) (\M44EXTENDVMEMFILE (LAMBDA (LASTPAGE) (* ; "Edited 5-Nov-87 16:58 by bvm:") (* ;;; "Extends vmem to at least LASTPAGE in length, returns T unless it wants to defer doing this til later.") (* ;; "Extending the vmem seems like a bad thing to do these days, since people usually make the vmem the size they want in the first place. Also, with multiple-partition vmems, we never want to extend. And finally, there is evidence that there is some buggy code in here somewhere.") (* ;; "If we ever revive this code, go back to Lyric sources.") T) ) (\M44DOEXTENDVMEMFILE (LAMBDA (LASTPAGE) (* ; "Edited 5-Nov-87 17:11 by bvm:") (* ;; "Called when LASTPAGE is not in the ISF map. Might simply need to look up some new pages; if we have already scanned the whole file, however, we will need to extend the file itself. Returns error code on failure. If LASTPAGE is NIL just reads to the end of the vmem file") (* ;; "This function is currently only used to find the end of the vmem, and even that function can be tossed if we require Bcpl version 26400. If you want to revive old functionality, look back to the Lyric sources.") (AND LASTPAGE (SHOULDNT)) (PROG ((SCRATCHBUF \SPAREDISKWRITEBUFFER) (DAs \ISFSCRATCHDAS) (LASTNEEDEDPAGE LASTPAGE) (LASTFULLPAGE (SUB1 (\GETBASE \ISFMAP (fetch ISFLAST of \ISFMAP)))) FIRSTDA NP LASTPAGEREAD LASTPAGEADDR LASTPAGEOFFSET EXTENDED) (* ;; "Use \SPAREDISKWRITEBUFFER as a scratch buf, assuming this is not called while \DOWRITEDISKPAGES is happening (because \DOWRITEDISKPAGES is locked). If it turns out we actually need to invoke \DOWRITEDISKPAGES ourselves, then we better not have been writing the disk anyway, in which case we steal a different disk buffer") (while T do (SETQ NP (IDIFFERENCE \ISFCHUNKSIZE 2)) (\PUTBASE DAs 0 (COND ((EQ LASTFULLPAGE 0) \EOFDA) (T (\LOOKUPFMAP (SUB1 LASTFULLPAGE))))) (\PUTBASE DAs 1 (\LOOKUPFMAP LASTFULLPAGE)) (* ; "Will operate on LASTFULLPAGE plus as many remaining pages as desired. NP is number of new pages") (for I from 2 to (IPLUS NP 2) do (\PUTBASE DAs I \FILLINDA)) (* ; "\FILLINDA for NP starting at first unknown page. Last one is bonus") (COND ((ILESSP (SETQ LASTPAGEREAD (\ACTONVMEMPAGES \MAINDISK SCRATCHBUF DAs (SUB1 LASTFULLPAGE) LASTFULLPAGE (IPLUS LASTFULLPAGE NP) \DC.READD NIL (fetch ISFHINTLASTPAGE of \ISFMAP))) 0) (\DISKERROR (IMINUS LASTPAGEREAD)))) (SETQ LASTPAGEOFFSET (IPLUS (IDIFFERENCE LASTPAGEREAD LASTFULLPAGE) 2)) (* ; "Offset in DAs of one past LASTPAGEREAD") (COND ((OR (NEQ (fetch CURRENTNUMCHARS of \SWAPREQUESTBLOCK) BYTESPERPAGE) (EQ (\GETBASE DAs LASTPAGEOFFSET) \EOFDA)) (* ;; "Read to EOF. The second condition should never be needed, but if file is malformed at the end we would be in trouble") (COND ((ILEQ LASTPAGEOFFSET 3) (* ; "No pages were acted on, so extend simply") (RETURN NIL)) (T (* ;; "Too hard to do both. Fill in part of map now, and extend the file on the next iteration. Number of good pages read was LASTPAGEREAD-1-LASTFULLPAGE") (SETQ NP (IDIFFERENCE LASTPAGEOFFSET 3)))))) (for I from 1 to NP do (\EXTENDISFMAP (IPLUS LASTFULLPAGE I) (\GETBASE DAs (ADD1 I)))) (SETQ LASTFULLPAGE (IPLUS LASTFULLPAGE NP)) (SETQ EXTENDED T)) (COND ((AND EXTENDED (NEQ (fetch ISFREWRITE of \ISFMAP) 0)) (* ; "Write map back onto file") (PROG ((CAs \ISFSCRATCHCAS)) (\PUTBASE DAs 0 \EOFDA) (\PUTBASE DAs 1 (fetch ISFDA0 of \ISFMAP)) (\PUTBASE DAs 2 (fetch ISFDA1 of \ISFMAP)) (\PUTBASE DAs 3 (fetch ISFDA2 of \ISFMAP)) (\PUTBASE CAs 1 (\LOLOC SCRATCHBUF)) (\PUTBASE CAs 2 (\LOLOC \ISFMAP)) (* ; "Set up to write first data page of file") (\ACTONVMEMPAGES \MAINDISK NIL DAs -1 1 1 \DC.WRITED NIL NIL CAs)))) (SETQ \LASTVMEMFILEPAGE (SUB1 (\GETBASE \ISFMAP (fetch ISFLAST of \ISFMAP)))) (* ; "Update pointer to true end, return NIL to signal success") (RETURN NIL))) ) (\EXTENDISFMAP (LAMBDA (PAGE DA) (* bvm%: "14-Feb-85 23:29") (* ;; "extend map to include the knowledge that DA is address of PAGE") (PROG ((LASTOFFSET (fetch ISFLAST of \ISFMAP)) LASTPAGE LASTMAP) (replace ISFONEPAGE of \ISFMAP with PAGE) (replace ISFONEDA of \ISFMAP with DA) (SETQ LASTMAP (\ADDBASE \ISFMAP (IDIFFERENCE LASTOFFSET 2))) (* ; "LASTMAP points at the last Page, DA pair in map") (COND ((NEQ (SETQ LASTPAGE (\GETBASE LASTMAP 2)) PAGE) (RETURN))) (COND ((EQ DA (IPLUS (\GETBASE LASTMAP 1) (IDIFFERENCE LASTPAGE (\GETBASE LASTMAP 0)))) (* ; "Still in same chunk") (\PUTBASE LASTMAP 2 (ADD1 LASTPAGE))) (T (* ; "Start new chunk") (COND ((EQ LASTOFFSET (fetch ISFEND of \ISFMAP)) (* ; "No more space in map") (RETURN)) (T (\PUTBASE LASTMAP 3 DA) (* ; "DA corresponding to LASTPAGE=PAGE") (\PUTBASE LASTMAP 4 (ADD1 LASTPAGE)) (replace ISFLAST of \ISFMAP with (IPLUS LASTOFFSET 2)))))) (RETURN T))) ) ) (* ; "Extended vmem stuff") (DEFINEQ (\EXTENDEDVMEMINIT (LAMBDA NIL (* ; "Edited 5-Nov-87 16:50 by bvm:") (* ;; "Initialize structures used by extended Dorado virtual memory. \XVmem is set to NIL if not present.") (if (fetch (IFPAGE XVmemFmapBase) of \InterfacePage) then (* ;; "check to see if Lisp.run had initialized the pointers to the ISFmaps, a good hint about whether we have the correct version of Lisp.run.") (* ;; "convenient references to items in the interface page") (SETQ \XVmemFmapBase (LOCF (fetch (IFPAGE XVmemFmapBase) of \InterfacePage))) (SETQ \XVmemFmapHighBase (LOCF (fetch (IFPAGE XVmemFmapHighBase) of \InterfacePage))) (SETQ \XVmemDiskBase (LOCF (fetch (IFPAGE XVmemDiskBase) of \InterfacePage))) (* ;; "record the last file page where the system expects to find it") (SETQ \LASTVMEMFILEPAGE (IMAX (\GETBASE \XVmemFmapHighBase 0) (\GETBASE \XVmemFmapHighBase 1) (\GETBASE \XVmemFmapHighBase 2))) (* ;; "fill in the Lisp disk objects for the extra swap partitions. These must have been previously created and locked down.") (\INITIALIZESWAPDISK \SWAPDSK1 1) (\INITIALIZESWAPDISK \SWAPDSK2 2) (* ;; "store pointers to the disk devices in the disk array in the Interface page") (\PUTBASEPTR \XVmemDiskBase 0 \MAINDISK) (\PUTBASEPTR \XVmemDiskBase 2 \SWAPDSK1) (\PUTBASEPTR \XVmemDiskBase 4 \SWAPDSK2) (* ;; "check to see whether it is worth turning on the extended vmem -- there must be some extra files present.") (SETQ \XVmem (NEQ (\GETBASE \XVmemFmapHighBase 1) 0)) else (PROGN (* ; "Using old Lisp.run, have to figure out how big vmem file is") (\M44DOEXTENDVMEMFILE)) (SETQ \XVmem NIL))) ) (\INITIALIZESWAPDISK (LAMBDA (DISK ISFindex) (* ; "Edited 5-Nov-87 15:48 by bvm:") (* ;; "called by \EXTENDEDVMEMINIT to initialize the various disk objects it uses.") (\BLT DISK \MAINDISK \NWORDS.DSKOBJ) (* ; "start with the main disk, but be careful--some of these fields are ref-counted") (\PUTBASEPTR (LOCF (fetch SYSDIROFD of DISK)) 0 NIL) (\PUTBASEPTR (LOCF (FETCH DISKDESCRIPTOROFD OF DISK)) 0 NIL) (replace ALTODSKOBJ of DISK with (EMPOINTER (fetch (ISFMAP ISFDISK) of (EMPOINTER (\GETBASE \XVmemFmapBase ISFindex))))) (replace ddPOINTER of DISK with (LOCF (fetch (ALTODSKOBJ DDLASTSERIAL#) of (fetch ALTODSKOBJ of DISK)))) (replace DSKPARTITION of DISK with (LRSH (fetch DSKDRIVE# of (fetch ALTODSKOBJ of DISK)) 1)) (replace DISKDEVICENAME of DISK with NIL)) ) (\WHICHPART (LAMBDA (PAGE) (* ; "Edited 16-Feb-87 10:28 by Briggs") (if (ILEQ PAGE (\GETBASE \XVmemFmapHighBase 0)) then 0 elseif (ILEQ PAGE (\GETBASE \XVmemFmapHighBase 1)) then 1 elseif (ILEQ PAGE (\GETBASE \XVmemFmapHighBase 2)) then 2 else (RAID "Attempting to access a page not in ISFmap [extended virtual memory]" PAGE))) ) (\SWAPDISKERROR (LAMBDA (ERRCODE DISK) (* ; "Edited 5-Nov-87 15:50 by bvm:") (while T do (SELECTC ERRCODE (\DSK.HARD.ERROR (RAID (if (EQ DISK \MAINDISK) then "Hard disk error in primary Lisp.VirtualMem" elseif (EQ DISK \SWAPDSK1) then "Hard disk error in first Lisp.XVirtualMem" else "Hard disk error in second Lisp.XVirtualMem") (fetch (DSKOBJ CURRENTDISKPAGE) of DISK))) (RAID (if (EQ DISK \MAINDISK) then "Unknown disk error in primary Lisp.VirtualMem" elseif (EQ DISK \SWAPDSK1) then "Unknown disk error in first Lisp.XVirtualMem" else "Unknown disk error in second Lisp.XVirtualMem") ERRCODE)))) ) ) (* ; "For debugging and user info") (DEFINEQ (DESCRIBE-VIRTUAL-MEMORY (LAMBDA NIL (* ; "Edited 6-Nov-87 16:45 by bvm:") (if (NEQ \MACHINETYPE \DORADO) then (printout NIL "This is not a Dorado!") else (LET ((NOBCPL (NEQ (fetch (IFPAGE XVmemFmapBase) of \InterfacePage) (\LOLOC \ISFMAP))) (VMSIZE (VMEMSIZE))) (CL:FORMAT T "The extended virtual memory Lisp.run has ~@[not ~]been installed.~%%" NOBCPL) (CL:FORMAT T "There are currently ~D of ~D pages of virtual memory in use.~%%" VMSIZE \LASTVMEMFILEPAGE) (CL:UNLESS NOBCPL (for I from 0 to 2 bind ISFMAP when (NEQ 0 (\GETBASE (LOCF (fetch (IFPAGE XVmemFmapHighBase) of \InterfacePage)) I)) do (SETQ ISFMAP (EMPOINTER (\GETBASE (LOCF (fetch (IFPAGE XVmemFmapBase) of \InterfacePage)) I))) (if (EQ I 0) then (PRIN1 "The primary partition") else (CL:FORMAT T "Secondary partition ~D" (fetch (DSKOBJ DSKPARTITION) of (\GETBASEPTR (LOCF (fetch (IFPAGE XVmemDiskBase) of \InterfacePage)) (UNFOLD I WORDSPERCELL))))) (CL:FORMAT T " has ~D pages in ~D segment~:P.~%%" (- (\GETBASE ISFMAP (fetch (ISFMAP ISFLAST) of ISFMAP)) (CL:IF (EQ I 0) 2 1)) (IQUOTIENT (- (fetch ISFLAST of ISFMAP) \ISFMAPOFFSET) 2))) (if (NEQ 0 (\WHICHPART VMSIZE)) then (printout T "A sysout cannot be made because secondary partitions are in use" T))))) (CL:VALUES)) ) (\PRINTFMAP (LAMBDA (ISFMAP) (* ; "Edited 6-Nov-87 16:32 by bvm:") (if (SMALLP ISFMAP) then (SETQ ISFMAP (EMPOINTER (\GETBASE \XVmemFmapBase ISFMAP)))) (CL:FORMAT T "ISFmap of ~D segments:~%%" (IQUOTIENT (- (fetch ISFLAST of ISFMAP) \ISFMAPOFFSET) 2)) (for OFF from \ISFMAPOFFSET to (- (fetch ISFLAST of ISFMAP) 2) by 2 bind START END VDA do (CL:FORMAT T "Pages [~D..~D] at vda [~O..~O]B~%%" (SETQ START (\GETBASE ISFMAP OFF)) (SETQ END (SUB1 (\GETBASE ISFMAP (+ OFF 2)))) (SETQ VDA (\GETBASE ISFMAP (+ OFF 1))) (+ VDA (- END START))))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD ISFMAP ((NIL 5 WORD) (* ; "First 5 words are a FP") (ISFDA0 WORD) (* ;  "DA's of the first 3 pages of file") (ISFDA1 WORD) (ISFDA2 WORD) (ISFSEAL WORD) (ISFDISK WORD) (* ; "points to a DSKOBJ for file") (NIL WORD) (* ; "ZONE") (ISFLAST WORD) (* ; "offset of last entry in map") (ISFEND WORD) (* ; "Offset of end of space for map") (ISFONEPAGE WORD) (* ; "Last page# added to map") (ISFONEDA WORD) (* ; "its DA") (ISFREWRITE WORD) (* ;  "non-zero if map should be rewritten when file is extended") (ISFCHUNKSIZE WORD) (* ;  "if file needs to be extended, do so in this size unit") (ISFHINTLASTPAGE WORD) (* ; "Hint of last page") (ISFMAPSTART WORD) (* ;; "Map entries follow. Each is two words: the page number of the start of a run, followed by the vda of that first page") )) ) (DECLARE%: EVAL@COMPILE (RPAQQ \ISFMAPOFFSET 18) (CONSTANTS (\ISFMAPOFFSET 18)) ) ) (RPAQ? \DISKDEBUG ) (RPAQ? \MAXSWAPBUFFERS 1) (RPAQ? \M44.READY ) (ADDTOVAR \SYSTEMCACHEVARS \M44.READY) (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS ERROR RAID \M44ACTONVMEMFILE \ACTONVMEMFILESUBR \ACTONVMEMPAGES \CLEANUPDISKQUEUE \CLEARCB \DISKERROR \DOACTONDISKPAGES \DODISKCOMMAND \EXTENDISFMAP \M44DOEXTENDVMEMFILE \GETDISKCB \INITBFS \INSUREVMEMFILE \LISPERROR \LOOKUPFMAP \REALDISKDA \VIRTUALDISKDA \CLEARWORDS \TESTPARTITION \EXTENDEDVMEMINIT \WHICHPART \INITIALIZESWAPDISK \SWAPDISKERROR) (LOCKEDVARS \DISKREQUESTBLOCK \SWAPREQUESTBLOCK \MAINDISK \SWAPDSK1 \SWAPDSK2 \ISFCHUNKSIZE \EMUSCRATCH \EMUDISKBUFFERS \EMUSWAPBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS \#DISKBUFFERS \InterfacePage \ISFMAP \ISFSCRATCHCAS \ISFSCRATCHDAS \SYSDISK \#SWAPBUFFERS \MAXDISKDAs \DISKDEBUG \SPAREDISKWRITEBUFFER \#EMUBUFFERS \EMUBUFFERS \LASTVMEMFILEPAGE \XVmem \XVmemFmapBase \XVmemFmapHighBase \XVmemDiskBase)))) ) (PUTPROPS LLBFS COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6747 15689 (\INITBFS 6757 . 9287) (\TESTPARTITION 9289 . 9553) (\ACTONDISKPAGES 9555 . 12760) (\WRITEDISKPAGES 12762 . 14768) (\DISKERROR 14770 . 15172) (M44.SIGNAL.DISK.ERROR 15174 . 15687 )) (39206 56182 (\ACTONVMEMPAGES 39216 . 39952) (\WRITEVMEMPAGES 39954 . 40925) (\DOACTONDISKPAGES 40927 . 44074) (\DOWRITEDISKPAGES 44076 . 48416) (\CHECKFREEPAGE 48418 . 48920) (\DODISKCOMMAND 48922 . 51221) (\GETDISKCB 51223 . 51891) (\CLEARCB 51893 . 52041) (\CLEANUPDISKQUEUE 52043 . 55318) ( \VIRTUALDISKDA 55320 . 55696) (\REALDISKDA 55698 . 56180)) (58189 59369 (MAKEINITBFS 58199 . 59367)) ( 59751 68034 (\M44ACTONVMEMFILE 59761 . 62222) (\LOOKUPFMAP 62224 . 63312) (\M44EXTENDVMEMFILE 63314 . 63863) (\M44DOEXTENDVMEMFILE 63865 . 67117) (\EXTENDISFMAP 67119 . 68032)) (68071 71389 ( \EXTENDEDVMEMINIT 68081 . 69667) (\INITIALIZESWAPDISK 69669 . 70443) (\WHICHPART 70445 . 70778) ( \SWAPDISKERROR 70780 . 71387)) (71434 73235 (DESCRIBE-VIRTUAL-MEMORY 71444 . 72688) (\PRINTFMAP 72690 . 73233))))) STOP \ No newline at end of file diff --git a/sources/LLBIGNUM b/sources/LLBIGNUM new file mode 100644 index 00000000..a6dd16f6 --- /dev/null +++ b/sources/LLBIGNUM @@ -0,0 +1,235 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 1-Jan-99 21:45:52" {DSK}disk3>lispcore3.0>sources>LLBIGNUM.;2 41438 + + changes to%: (FNS \INITBIGNUMS) + + previous date%: "19-Jan-93 10:44:45" {DSK}disk3>lispcore3.0>sources>LLBIGNUM.;1) + + +(* ; " +Copyright (c) 1985, 1986, 1987, 1990, 1993, 1999 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLBIGNUMCOMS) + +(RPAQQ LLBIGNUMCOMS + [(COMS (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BIGNUM)) + (INITRECORDS BIGNUM) + (CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) + (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) + [DECLARE%: EVAL@COMPILE (ADDVARS (CHARACTERNAMES (INFINITY 8551] + (ADDVARS (GLOBALVARS MIN.INTEGER MAX.INTEGER \BIG.0 \BIG.1))) + (COMS (* ; "entries") + (FNS \BIGNUM.COMPARE \BIGNUM.DIFFERENCE \BIGNUM.INTEGERLENGTH \BIGNUM.LOGAND + \BIGNUM.LOGOR \BIGNUM.LOGXOR \BIGNUM.PLUS \BIGNUM.LSH \BIGNUM.TIMES + \BIGNUM.QUOTIENT \BIGNUM.REMAINDER \BIGNUM.TO.FLOAT) + (FNS FINITEP INFINITEP)) + (COMS (* ; "internal functions") + (FNS \BIGNUM.TO.INT \BN.2TH \BN.ABS \BN.DIFFERENCE \BN.DIVIDE \BN.FLOAT \BN.IGNN + BIGNUM.DEFPRINT \BN.INTEGERLENGTH \BN.LOGAND \BN.LOGANDC2 \BN.LOGOR \BN.LOGXOR + \BN.MINUS \BN.PLUS2 \BN.SIGN \BN.TIMES2 \BN.COMPAREN \BN.D2TH \BN.FROM.FIXP + \BN.ICANON \BN.IDIVIDE \BN.ISUM0 \BN.ISUM1 \BN.MADD \BN.TO.FIXP \BN.NZEROS \BN.QRS + \BN.SIGN \BN.TH2B \BN.TH2D)) + (COMS (FNS \INITBIGNUMS) + (* ; "MAKERATIONAL needs work") + + (* ;; "needs work: MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT LOADBYTE DEPOSITBYTE IMODLESSP IMODPLUS IMODDIFFERENCE ROT") + + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INITBIGNUMS]) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +(DATATYPE BIGNUM (ELEMENTS) + (INIT (DEFPRINT 'BIGNUM 'BIGNUM.DEFPRINT))) +) + +(/DECLAREDATATYPE 'BIGNUM '(POINTER) + '((BIGNUM 0 POINTER)) + '2) + +(DEFPRINT 'BIGNUM 'BIGNUM.DEFPRINT) +) + +(/DECLAREDATATYPE 'BIGNUM '(POINTER) + '((BIGNUM 0 POINTER)) + '2) + +(DEFPRINT 'BIGNUM 'BIGNUM.DEFPRINT) +(DECLARE%: EVAL@COMPILE + +(RPAQQ \BIGNUM.THETA 10000) + +(RPAQ \BIGNUM.BETA (EXPT 2 14)) + +(RPAQ \BIGNUM.BETA1 (SUB1 \BIGNUM.BETA)) + + +(CONSTANTS \BIGNUM.THETA (\BIGNUM.BETA (EXPT 2 14)) + (\BIGNUM.BETA1 (SUB1 \BIGNUM.BETA))) +) +(DECLARE%: EVAL@COMPILE + +(ADDTOVAR CHARACTERNAMES (INFINITY 8551)) +) + +(ADDTOVAR GLOBALVARS MIN.INTEGER MAX.INTEGER \BIG.0 \BIG.1) + + + +(* ; "entries") + +(DEFINEQ + +(\BIGNUM.COMPARE [LAMBDA (X Y) (* lmm "15-Apr-85 17:36") (COND ((EQ X MIN.INTEGER) (COND ((EQ Y MIN.INTEGER) 0) (T -1))) ((EQ X MAX.INTEGER) (COND ((EQ Y MAX.INTEGER) 0) (T 1))) ((EQ Y MIN.INTEGER) 1) ((EQ Y MAX.INTEGER) -1) (T (\BN.COMPAREN (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.DIFFERENCE [LAMBDA (X Y) (* lmm "12-Apr-85 08:38") (\BN.TO.FIXP (\BN.DIFFERENCE (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.INTEGERLENGTH [LAMBDA (X) (* lmm "12-Apr-85 08:01") (\BN.INTEGERLENGTH (\BN.FROM.FIXP X]) + +(\BIGNUM.LOGAND [LAMBDA (X Y) (* kbr%: "16-Sep-86 12:28") (COND ((OR (EQ X 0) (EQ Y 0)) 0) ((OR (INFINITEP X) (INFINITEP Y)) (ERROR "Can't do logical operations with infinity")) [(LESSP Y 0) (COND [(LESSP X 0) (DIFFERENCE -1 (LOGOR (LOGNOT X) (LOGNOT Y] (T (\BN.TO.FIXP (\BN.LOGANDC2 (\BN.FROM.FIXP X) (\BN.FROM.FIXP (DIFFERENCE -1 Y] ((LESSP X 0) (\BIGNUM.LOGAND Y X)) (T (\BN.TO.FIXP (\BN.LOGAND (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.LOGOR [LAMBDA (X Y) (* kbr%: "16-Sep-86 12:29") (COND ((EQ X 0) Y) ((EQ Y 0) X) ((OR (INFINITEP X) (INFINITEP Y)) (ERROR "Can't do logical operations with infinity")) [(AND (GREATERP X 0) (GREATERP Y 0)) (\BN.TO.FIXP (\BN.LOGOR (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y] (T (* stupid slow but maybe working definition.  Problem is that logors of negatives are difficult in current representation) (DIFFERENCE -1 (LOGAND (DIFFERENCE -1 X) (DIFFERENCE -1 Y]) + +(\BIGNUM.LOGXOR [LAMBDA (X Y) (* kbr%: "16-Sep-86 12:29") (COND ((EQ X 0) Y) ((EQ Y 0) X) ((OR (INFINITEP X) (INFINITEP Y)) (ERROR "Can't do logical operations with infinity")) [(LESSP X 0) (COND ((LESSP Y 0) (LOGXOR (DIFFERENCE -1 X) (DIFFERENCE -1 Y))) (T (* stupid dumb but working  definition) (\BIGNUM.DIFFERENCE (\BIGNUM.LOGOR X Y) (\BIGNUM.LOGAND X Y] ((LESSP Y 0) (\BIGNUM.LOGXOR Y X)) (T (\BN.TO.FIXP (\BN.LOGXOR (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.PLUS [LAMBDA (X Y) (* lmm "12-Apr-85 08:03") (\BN.TO.FIXP (\BN.PLUS2 (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.LSH [LAMBDA (X N) (* ; "Edited 23-Feb-87 16:09 by jrb:") (COND ((EQ X 0) 0) ((EQ N MIN.INTEGER) (COND ((INFINITEP X) (ERROR "Can't shift infinity minus infinity places")) (T 0))) ((INFINITEP X) X) ((EQ N MAX.INTEGER) (COND ((EQ X 0) 0) ((IGREATERP X 0) MAX.INTEGER) (T MIN.INTEGER))) [(IGEQ N 0) (SETQ X (\BN.FROM.FIXP X)) (* ; "Don't smash original input") [if (>= N 14) then (while (>= N 14) do (SETQ N (IDIFFERENCE N 14)) (SETQ X (CONS 0 X] (\BN.TO.FIXP (\BN.TIMES2 X (\BN.FROM.FIXP (EXPT 2 N] [(IGREATERP X 0) (SETQ X (\BN.FROM.FIXP X)) (* ; "Don't smash original input") [if (<= N -14) then (while (<= N -14) do (SETQ N (IPLUS N 14)) (SETQ X (CDR X] (\BIGNUM.QUOTIENT (create BIGNUM ELEMENTS _ X) (EXPT 2 (IMINUS N] (T (* ;; "RIGHTSHIFT A NEGATIVE - result must be adjusted if not a bignum") (SETQ X (MINUS (\BIGNUM.LSH (MINUS X) N))) (if (NOT (type? BIGNUM X)) then (SETQ X (SUB1 X))) X]) + +(\BIGNUM.TIMES [LAMBDA (X Y) (* lmm "12-Apr-85 08:03") (\BN.TO.FIXP (\BN.TIMES2 (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.QUOTIENT [LAMBDA (X Y) (* kbr%: "16-Sep-86 12:30") (COND ((EQ Y MAX.INTEGER) (COND ((INFINITEP X) (ERROR "Can't divide infinity by infinity")) (T 0))) ((EQ Y MIN.INTEGER) (COND ((INFINITEP X) (ERROR "Can't divide infinity by infinity")) (T 0))) ((EQ X MAX.INTEGER) (COND ((EQ Y 0) (ERROR "Can't divide infinity by 0")) ((IGREATERP Y 0) MAX.INTEGER) (T MIN.INTEGER))) ((EQ X MIN.INTEGER) (COND ((EQ Y 0) (ERROR "Can't divide infinity by 0")) ((IGREATERP Y 0) MIN.INTEGER) (T MAX.INTEGER))) (T (\BN.TO.FIXP (CAR (\BN.DIVIDE (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.REMAINDER [LAMBDA (X Y) (* kbr%: "16-Sep-86 12:30") (COND ((OR (INFINITEP X) (INFINITEP Y)) (ERROR "Can't take remainder with infinity")) (T (\BN.TO.FIXP (CDR (\BN.DIVIDE (\BN.FROM.FIXP X) (\BN.FROM.FIXP Y]) + +(\BIGNUM.TO.FLOAT [LAMBDA (X) (* lmm "12-Apr-85 08:06") (* called by \FLOAT) (\BN.FLOAT (\BN.FROM.FIXP X]) +) +(DEFINEQ + +(FINITEP [LAMBDA (CL:NUMBER) (* kbr%: "16-Sep-86 12:24") (NOT (OR (EQ CL:NUMBER MAX.INTEGER) (EQ CL:NUMBER MIN.INTEGER]) + +(INFINITEP [LAMBDA (CL:NUMBER) (* kbr%: "16-Sep-86 12:25") (OR (EQ CL:NUMBER MAX.INTEGER) (EQ CL:NUMBER MIN.INTEGER]) +) + + + +(* ; "internal functions") + +(DEFINEQ + +(\BIGNUM.TO.INT [LAMBDA (X) (* lmm " 9-Jan-86 15:30") (COND ((NULL (CDR X)) (CAR X)) (T (IPLUS (CAR X) (ITIMES \BIGNUM.BETA (\BIGNUM.TO.INT (CDR X]) + +(\BN.2TH [LAMBDA (A) (* lmm " 9-Jan-86 15:31") (PROG (L B) [while A do (PROGN (SETQ L (\BN.QRS A \BIGNUM.THETA)) (SETQ A (CAR L)) (SETQ B (CONS (CDR L) B] (RETURN B]) + +(\BN.ABS [LAMBDA (U) (* lmm "20-JUL-84 02:00") (COND ((ILESSP (\BN.SIGN U) 0) (\BN.MINUS U)) (T U]) + +(\BN.DIFFERENCE [LAMBDA (U V) (* lmm "20-JUL-84 01:33") (\BN.PLUS2 U (\BN.MINUS V]) + +(\BN.DIVIDE [LAMBDA (A B FLG) (* lmm " 9-Jan-86 15:33") (PROG (M N K SA ST C D W E F B1 B2 A1 A2 A3 QHAT C1 R1 R2 U V Q X IP BIP L1 L2) [COND ((OR (NULL A) (NULL B)) (RETURN (CONS \BIG.0 A] (COND ((CDR B) (GO LL1))) (SETQ BIP (\BN.QRS A (CAR B))) [RETURN (CONS (CAR BIP) (AND (NEQ FLG 'QUOTIENT) (\BN.FROM.FIXP (CDR BIP] LL1 (SETQ M (FLENGTH A)) (SETQ N (FLENGTH B)) (SETQ K (IDIFFERENCE M N)) [COND ((ILESSP K 0) (RETURN (CONS \BIG.0 A] (SETQ SA (\BN.SIGN A)) (SETQ U B) (for i from 1 to (IDIFFERENCE N 1) do (SETQ U (CDR U))) (SETQ C (CAR U)) (SETQ ST 1) [COND ((ILESSP C 0) (PROGN (SETQ ST -1) (SETQ C (IMINUS C] (SETQ D (IQUOTIENT \BIGNUM.BETA (IPLUS C 1))) (SETQ W (ITIMES SA ST)) [SETQ A (\BN.TIMES2 A (\BN.FROM.FIXP (ITIMES SA D] [SETQ B (\BN.TIMES2 B (\BN.FROM.FIXP (ITIMES ST D] (SETQ U A) (SETQ L1 NIL) [for I from 1 to (IPLUS K 1) do (PROGN (SETQ L1 (CONS U L1)) (SETQ U (CDR U] (SETQ L2 L1) (for I from 1 to (IDIFFERENCE N 2) do (SETQ L2 (CONS U L2)) (SETQ U (CDR U))) [COND ((NULL (CDR U)) (RPLACD U (CONS 0 NIL] (SETQ U B) (for I from 1 to (IDIFFERENCE N 2) do (SETQ U (CDR U))) (SETQ B2 (CAR U)) (SETQ U (CDR U)) (SETQ B1 (CAR U)) L10 (SETQ U (CAR L2)) (SETQ A3 (CAR U)) (SETQ U (CDR U)) (SETQ A2 (CAR U)) (SETQ U (CDR U)) (SETQ A1 (CAR U)) (SETQ U (CDR U)) [COND ((IGEQ A1 B1) (SETQ QHAT \BIGNUM.BETA1)) (T (SETQ QHAT (IQUOTIENT (IPLUS (ITIMES A1 \BIGNUM.BETA) A2) B1] L12 (SETQ IP (\BN.IDIVIDE (ITIMES QHAT B1) \BIGNUM.BETA)) (SETQ R1 (IDIFFERENCE A1 (CAR IP))) (SETQ R2 (IDIFFERENCE A2 (CDR IP))) [COND ((ILESSP R2 0) (PROGN (SETQ R2 (IPLUS R2 \BIGNUM.BETA)) (SETQ R1 (IDIFFERENCE R1 1] (COND ((IGREATERP R1 0) (GO L13))) (SETQ IP (\BN.IDIVIDE (ITIMES QHAT B2) \BIGNUM.BETA)) (SETQ R1 (IDIFFERENCE R2 (CAR IP))) (COND ((IGREATERP R1 0) (GO L13))) (SETQ R2 (IDIFFERENCE A3 (CDR IP))) [COND ((OR (ILESSP R1 0) (ILESSP R2 0)) (PROGN (SETQ QHAT (IDIFFERENCE QHAT 1)) (GO L12] L13 (SETQ U (CAR L1)) (SETQ V B) (SETQ C1 0) L14 (SETQ E (IMINUS QHAT)) (SETQ IP (\BN.IDIVIDE (ITIMES E (CAR V)) \BIGNUM.BETA)) (SETQ V (CDR V)) (SETQ E (CAR IP)) (SETQ A1 (CAR U)) (SETQ IP (\BN.IDIVIDE (IPLUS C1 (IPLUS A1 (CDR IP))) \BIGNUM.BETA)) (SETQ A1 (CDR IP)) (SETQ C1 (CAR IP)) [COND ((ILESSP A1 0) (PROGN (SETQ A1 (IPLUS A1 \BIGNUM.BETA)) (SETQ C1 (IDIFFERENCE C1 1] (SETQ C1 (IPLUS C1 E)) (RPLACA U A1) (SETQ X U) (SETQ U (CDR U)) (COND (V (GO L14))) (SETQ A1 (IPLUS (CAR U) C1)) (SETQ U (CDR U)) (RPLACD X \BIG.0) (COND ((EQ A1 0) (GO L17))) (SETQ U (CAR L1)) (SETQ V B) (SETQ C1 0) (SETQ QHAT (IDIFFERENCE QHAT 1)) L16 (SETQ A1 (CAR U)) (SETQ B1 (CAR V)) (SETQ V (CDR V)) (SETQ IP (\BN.IDIVIDE (IPLUS C1 (IPLUS A1 B1)) \BIGNUM.BETA)) (RPLACA U (CDR IP)) (SETQ U (CDR U)) (COND (V (GO L16))) L17 [COND ((OR (NEQ QHAT 0) Q) (SETQ Q (CONS (ITIMES W QHAT) Q] (SETQ L1 (CDR L1)) (SETQ U (CAR L2)) (SETQ L2 (CDR L2)) (COND (L1 (GO L10))) (RETURN (CONS Q (AND (NEQ FLG 'QUOTIENT) (CAR (\BN.QRS A (ITIMES SA D]) + +(\BN.FLOAT [LAMBDA (X) (* kbr%: "16-Sep-86 12:21") (COND ((NULL X) 0.0) [(LISTP X) (FPLUS (CAR X) (FTIMES \BIGNUM.BETA (\BN.FLOAT (CDR X] ((OR (EQ X 'MAX.INTEGER) (EQ X 'MIN.INTEGER)) (* KBR%: After some consideration, I've decided that it would be best that  rational infinities and floating point infinities be kept distinct in the same  way that we consider 1 distinct from 1.0.  This is an admission that the systems of Lisp rationals and Lisp floating point  numbers are two disjoint sets of Lisp expressions.  The semantics of these expressions--what they denote--is slightly more than the  rational numbers we attach to them. These expressions should be viewed as  denoting a pair consisting of a rational number and an atom recording the type  of the expression. A Lisp rational X denotes the pair  (X CL:RATIONAL) and a Lisp floating point number X denotes  (X FLOAT) in our mind. The FLOAT operation is an injection that changes an  expression denoting a pair (X CL:RATIONAL) into an expression denoting a pair  (X FLOAT)%. Arithmetic on these expressions is typed arithmetic with rounding  of the results in the case of FLOATPs according to IEEE spec.  Let's suppose that MAX.INTEGER and MAX.FLOAT are Lisp expressions denoting the  respective rational and floating point infinities.  (We now know with the advent of Common Lisp that MAX.INTEGER and MIN.INTEGER  should have been called MAX.RATIONAL and MIN.RATIONAL) Then rules of floating  point coercion can continue to make sense%:  (EQL (/ MAX.INTEGER) 0) (EQL (/ MAX.FLOAT) 0.0)  (EQL (EXPT 2 MAX.INTEGER) MAX.INTEGER) (EQL  (EXPT 2.0 MAX.INTEGER) MAX.FLOAT) (EQL (EXPT 2 MAX.FLOAT) MAX.FLOAT)  (EQL (EXPT 2.0 MAX.FLOAT) MAX.FLOAT) etc.  But if we tried to make rational infinities and floating point infinities  identical, then we would have to arbitrarily decide in an unnatural way whether  (EQL (/ MAX.INTEGER) 0) or (EQL (/ MAX.FLOAT) 0.0) is true, etc.  Recommendation%: Currently Xerox Lisp does not support floating point  infinities. Larry Masinter added rational infinities.  If there is a desire to add floating point infinities at some point in the  future, then I recommend that rational and floating point infinities be kept  distinct. *) (* * Error because Xerox Lisp does not support floating point infinities  (at this time)%. *) (ERROR "Can't float integer infinity.")) (T (SHOULDNT]) + +(\BN.IGNN [LAMBDA (U) (* lmm " 9-Jan-86 15:30") (COND ((NULL U) NIL) ((ILESSP U \BIGNUM.BETA) (LIST U)) (T (PROG (Y) (SETQ Y (IQUOTIENT U \BIGNUM.BETA)) (SETQ U (IDIFFERENCE U (ITIMES Y \BIGNUM.BETA))) (RETURN (CONS U (\BN.FROM.FIXP Y]) + +(BIGNUM.DEFPRINT [LAMBDA (BIGN STREAM) (* kbr%: "16-Sep-86 12:31") (COND [(INFINITEP BIGN) (* Distinguished integers  smaller/larger than any others.  Print using "evaluate at read time"  syntax) (CONS (CONCAT (CHARACTER (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) ".") (COND ((EQ BIGN MIN.INTEGER) 'MIN.INTEGER) (T 'MAX.INTEGER] (T (LET* ((RADIX (\CHECKRADIX *PRINT-BASE*)) [TH (SELECTQ RADIX (10 10000) (8 4096) (bind (TH _ RADIX) NEWTH while (LEQ (SETQ NEWTH (TIMES TH RADIX)) \BIGNUM.BETA) do (SETQ TH NEWTH) finally (RETURN TH] (CHARS (\BN.TH2D (bind (ELS _ (fetch (BIGNUM ELEMENTS) of BIGN)) L B while ELS do (SETQ L (\BN.QRS ELS TH)) (SETQ ELS (CAR L)) (SETQ B (CONS (CDR L) B)) finally (RETURN B)) RADIX TH))) [COND (*PRINT-RADIX* (* need radix qualifier) (COND ((AND (EQ RADIX 8) (NOT (fetch (READTABLEP COMMONLISP) of *READTABLE*))) (NCONC1 CHARS (CHARCODE Q))) (T [push CHARS (SELECTQ RADIX (8 (CHARCODE o)) (16 (CHARCODE x)) (2 (CHARCODE b)) (PROGN (push CHARS (CHARCODE r)) [COND ((IGEQ RADIX 10) (push CHARS (IPLUS (CHARCODE 0) (IMOD RADIX 10))) (SETQ RADIX (IQUOTIENT RADIX 10] (IPLUS RADIX (CHARCODE 0] (push CHARS (fetch (READTABLEP HASHMACROCHAR) of *READTABLE* ] (.SPACECHECK. STREAM (LENGTH CHARS)) (for C in CHARS do (\OUTCHAR STREAM C)) (* Return T to show we have done it  ourselves) T]) + +(\BN.INTEGERLENGTH [LAMBDA (X) (* kbr%: "16-Sep-86 12:31") (COND ((NULL X) 0) [(LISTP X) (COND [(CDR X) (IPLUS (CONSTANT (INTEGERLENGTH (SUB1 \BIGNUM.BETA))) (\BN.INTEGERLENGTH (CDR X] (T (INTEGERLENGTH (CAR X] ((INFINITEP X) MAX.INTEGER) (T (SHOULDNT]) + +(\BN.LOGAND [LAMBDA (B1 B2) (* lmm "20-Jul-84 11:13") (COND ((NULL B1) NIL) ((NULL B2) NIL) (T (PROG (B) (SETQ B (\BN.LOGAND (CDR B1) (CDR B2))) (SETQ B1 (LOGAND (CAR B1) (CAR B2))) (COND ((AND (NULL B) (EQ B1 0)) (RETURN B))) (RETURN (CONS B1 B]) + +(\BN.LOGANDC2 [LAMBDA (B1 B2) (* lmm "14-May-86 10:47") (COND ((NULL B1) NIL) ((NULL B2) B1) (T (PROG (B) (SETQ B (\BN.LOGANDC2 (CDR B1) (CDR B2))) [SETQ B1 (LOGAND (CAR B1) (DIFFERENCE -1 (CAR B2] (COND ((AND (NULL B) (EQ B1 0)) (RETURN B))) (RETURN (CONS B1 B]) + +(\BN.LOGOR [LAMBDA (B1 B2) (* lmm "21-JUL-84 23:57") (COND ((NULL B1) B2) ((NULL B2) B1) (T (CONS (LOGOR (CAR B1) (CAR B2)) (\BN.LOGOR (CDR B1) (CDR B2]) + +(\BN.LOGXOR [LAMBDA (B1 B2) (* lmm "21-JUL-84 23:59") (COND ((NULL B1) B2) ((NULL B2) B1) (T (CONS (LOGXOR (CAR B1) (CAR B2)) (\BN.LOGXOR (CDR B1) (CDR B2]) + +(\BN.MINUS [LAMBDA (U) (* kbr%: "11-Sep-86 15:00") (COND ((NULL U) NIL) [(LISTP U) (CONS (IMINUS (CAR U)) (\BN.MINUS (CDR U] ((EQ U 'MAX.INTEGER) 'MIN.INTEGER) ((EQ U 'MIN.INTEGER) 'MAX.INTEGER) (T (SHOULDNT]) + +(\BN.PLUS2 [LAMBDA (U V) (* kbr%: "11-Sep-86 15:26") (COND ((NULL U) V) ((NULL V) U) [(AND (LISTP U) (LISTP V)) (PROG (L) (SETQ L (IDIFFERENCE (FLENGTH U) (FLENGTH V))) [COND [(ILESSP L 0) (SETQ U (APPEND U (\BN.NZEROS (IDIFFERENCE 0 L] ((IGREATERP L 0) (SETQ V (APPEND V (\BN.NZEROS L] (RETURN (COND ((EQ (\BN.SIGN U) (\BN.SIGN V)) (\BN.ISUM0 U V)) (T (\BN.ISUM1 U V] ((EQ U 'MAX.INTEGER) (COND ((EQ V 'MIN.INTEGER) (ERROR "Can't add plus infinity to minus infinity")) (T U))) ((EQ U 'MIN.INTEGER) (COND ((EQ V 'MAX.INTEGER) (ERROR "Can't add plus infinity to minus infinity")) (T U))) (T V]) + +(\BN.SIGN [LAMBDA (U) (* kbr%: "11-Sep-86 15:22") (COND [(ATOM U) (COND ((NULL U) 0) ((EQ U 'MAX.INTEGER) 1) ((EQ U 'MIN.INTEGER) -1) (T (SHOULDNT] ((IGREATERP (CAR U) 0) 1) ((ILESSP (CAR U) 0) -1) (T (\BN.SIGN (CDR U]) + +(\BN.TIMES2 [LAMBDA (U V) (* kbr%: "11-Sep-86 15:19") (PROG (TAIL U1 W W1 W2 L C AP BP) [COND [(NULL U) (COND ((OR (EQ V 'MAX.INTEGER) (EQ V 'MIN.INTEGER)) (ERROR "Can't multiply infinity and zero.")) (T (RETURN NIL] [(EQ U 'MAX.INTEGER) (COND ((NULL V) (ERROR "Can't multiply infinity and zero.")) ((EQ (\BN.SIGN V) 1) (RETURN U)) (T (RETURN 'MIN.INTEGER] ((EQ U 'MIN.INTEGER) (COND ((NULL V) (ERROR "Can't multiply infinity and zero.")) ((EQ (\BN.SIGN V) 1) (RETURN U)) (T (RETURN 'MAX.INTEGER] (SETQ TAIL (LIST 0 0)) (SETQ L (IPLUS (FLENGTH U) (IDIFFERENCE (FLENGTH V) 2))) (SETQ W TAIL) (for I from 1 to L do (SETQ W (CONS 0 W))) (SETQ W1 W) A (SETQ U1 U) (SETQ W2 W1) (SETQ C 0) B (SETQ AP (\BN.IDIVIDE (ITIMES (CAR U1) (CAR V)) \BIGNUM.BETA)) (SETQ BP (\BN.IDIVIDE (IPLUS (CAR W2) (IPLUS (CDR AP) C)) \BIGNUM.BETA)) (RPLACA W2 (CDR BP)) (SETQ C (IPLUS (CAR AP) (CAR BP))) (SETQ W2 (CDR W2)) (SETQ U1 (CDR U1)) (COND (U1 (GO B))) (RPLACA W2 C) (SETQ W1 (CDR W1)) (SETQ V (CDR V)) (COND (V (GO A))) (COND ((EQ C 0) (RPLACD TAIL NIL))) (RETURN W]) + +(\BN.COMPAREN [LAMBDA (U V) (* lmm "12-Apr-85 08:33") (PROG ((SU 0) (SV 0) (ST 0) (S 0)) [COND [(EQ (SETQ SU (\BN.SIGN U)) 0) (RETURN (IMINUS (\BN.SIGN V] ((EQ (SETQ SV (\BN.SIGN V)) 0) (RETURN SU)) ((NEQ (SETQ S (IDIFFERENCE SU SV)) 0) (RETURN (COND ((IGREATERP S 0) 1) ((ILESSP S 0) -1) (T (SHOULDNT] A (COND ((NEQ (SETQ ST (IDIFFERENCE (CAR U) (CAR V))) 0) (SETQ S ST))) (SETQ V (CDR V)) (SETQ U (CDR U)) (COND [(NULL U) (RETURN (COND (V (IMINUS SU)) (T (COND ((IGREATERP S 0) 1) ((ILESSP S 0) -1) (T 0] (V (GO A)) (T (RETURN SU]) + +(\BN.D2TH [LAMBDA (U) (* lmm " 9-Jan-86 15:31") (PROG (B S V BI M AI) (COND ((NULL U) (RETURN B))) [COND [(OR (EQ (CAR U) '+) (EQ (CAR U) '-)) (PROGN (SETQ S (CAR U)) (SETQ U (CDR U] (T (SETQ S '+] (COND ((NULL U) (RETURN B))) (SETQ U (SETQ V (REVERSE U))) L2 (SETQ BI 0) (SETQ M 1) [while (AND U (ILESSP M \BIGNUM.THETA)) do (PROGN (SETQ AI (CAR U)) (SETQ U (CDR U)) (SETQ BI (IPLUS (ITIMES AI M) BI)) (SETQ M (ITIMES 10 M] [COND ((EQ S '-) (SETQ BI (IMINUS BI] (SETQ B (CONS BI B)) (COND (U (GO L2))) (RETURN B]) + +(\BN.FROM.FIXP [LAMBDA (U) (* kbr%: "11-Sep-86 14:54") (COND ((type? BIGNUM U) (fetch (BIGNUM ELEMENTS) of U)) ((OR (NULL U) (EQ U 0)) NIL) ((LISTP U) U) [(ILESSP U 0) (COND ((EQUAL U MIN.FIXP) (\BN.DIFFERENCE (\BN.FROM.FIXP (IPLUS U \BIGNUM.THETA)) (\BN.FROM.FIXP \BIGNUM.THETA))) (T (\BN.MINUS (\BN.IGNN (IMINUS U] (T (\BN.IGNN U]) + +(\BN.ICANON [LAMBDA (U SIGN) (* jrb%: " 6-Nov-86 15:30") (PROG ((U0 U) U1 (CARRY 0) B) A (SETQ B (IPLUS (CAR U) CARRY)) (SETQ CARRY (COND ((AND (IGREATERP SIGN 0) (ILESSP B 0)) -1) ((AND (ILESSP SIGN 0) (IGREATERP B 0)) 1) (T 0))) (SETQ B (IDIFFERENCE B (ITIMES CARRY \BIGNUM.BETA))) (RPLACA U B) (*  "U1 points to the high-order non-zero bignum node") (COND ((NEQ B 0) (SETQ U1 U))) B [COND ((CDR U) (SETQ U (CDR U)) (GO A)) (T (*  "If U1 is not eq to U here, we have high-order zero nodes in this bignum") (CL:IF (NEQ U1 U) (RPLACD U1 NIL] (RETURN U0]) + +(\BN.IDIVIDE [LAMBDA (A B) (* lmm "20-JUL-84 01:37") (CONS (IQUOTIENT A B) (IREMAINDER A B]) + +(\BN.ISUM0 [LAMBDA (U V) (* lmm " 9-Jan-86 15:30") (PROG ((CARRY 0) RES BP) A (SETQ BP (\BN.IDIVIDE (IPLUS (CAR U) (IPLUS (CAR V) CARRY)) \BIGNUM.BETA)) (SETQ CARRY (CAR BP)) (SETQ RES (CONS (CDR BP) RES)) (SETQ U (CDR U)) (SETQ V (CDR V)) (COND (V (GO A))) [COND ((NEQ CARRY 0) (SETQ RES (CONS CARRY RES] (RETURN (REVERSE RES]) + +(\BN.ISUM1 [LAMBDA (U V) (* lmm "20-JUL-84 02:22") (PROG (C S RES) (SETQ C 0) (SETQ S 0) A (SETQ C (IPLUS (CAR U) (CAR V))) (COND ((NEQ C 0) (SETQ S C))) (SETQ RES (CONS C RES)) (SETQ U (CDR U)) (SETQ V (CDR V)) (COND (V (GO A))) (RETURN (COND ((EQ S 0) NIL) (T (\BN.ICANON (DREVERSE RES) (COND ((ILESSP S 0) -1) (T 1]) + +(\BN.MADD [LAMBDA (A B C) (* lmm " 9-Jan-86 15:30") (PROG (H TT TTT IP IPP) (SETQ TT A) (SETQ H 0) L2 (SETQ IP (\BN.IDIVIDE (ITIMES B (CAR TT)) \BIGNUM.BETA)) (SETQ IPP (\BN.IDIVIDE (IPLUS C (IPLUS (CDR IP) H)) \BIGNUM.BETA)) (RPLACA TT (CDR IPP)) (SETQ H (CAR IP)) (SETQ C (CAR IPP)) (SETQ TTT TT) (SETQ TT (CDR TT)) (COND (TT (GO L2))) (SETQ C (IPLUS C H)) (COND ((EQ C 0) (RETURN A))) (RPLACD TTT (CONS C (CDR TTT))) (RETURN A]) + +(\BN.TO.FIXP [LAMBDA (X) (* kbr%: "11-Sep-86 14:58") (COND [(LISTP X) (COND ((OR (EQ (\BN.COMPAREN X (CONSTANT (\BN.FROM.FIXP MAX.FIXP))) 1) (EQ (\BN.COMPAREN X (CONSTANT (\BN.FROM.FIXP MIN.FIXP))) -1)) (create BIGNUM ELEMENTS _ X)) (T (\BIGNUM.TO.INT X] ((NULL X) 0) ((EQ X 'MAX.INTEGER) MAX.INTEGER) ((EQ X 'MIN.INTEGER) MIN.INTEGER) (T (SHOULDNT]) + +(\BN.NZEROS [LAMBDA (N) (* lmm "20-JUL-84 02:30") (for I from 1 to N collect 0]) + +(\BN.QRS [LAMBDA (B I) (* lmm " 9-Jan-86 15:30") (PROG (D CP C1 C2) [COND ((NULL B) (RETURN (CONS B 0] (COND ((EQ I 0) (ERROR " QRS DIV BY 0 "))) (SETQ B (REVERSE B)) (SETQ C1 0) A (SETQ C2 (CAR B)) (SETQ CP (\BN.IDIVIDE (IPLUS (ITIMES C1 \BIGNUM.BETA) C2) I)) [COND ((OR D (NOT (EQ (CAR CP) 0))) (SETQ D (CONS (CAR CP) D] (SETQ B (CDR B)) (SETQ C1 (CDR CP)) [COND ((NULL B) (RETURN (CONS D C1] (GO A]) + +(\BN.SIGN [LAMBDA (U) (* kbr%: "11-Sep-86 15:22") (COND [(ATOM U) (COND ((NULL U) 0) ((EQ U 'MAX.INTEGER) 1) ((EQ U 'MIN.INTEGER) -1) (T (SHOULDNT] ((IGREATERP (CAR U) 0) 1) ((ILESSP (CAR U) 0) -1) (T (\BN.SIGN (CDR U]) + +(\BN.TH2B [LAMBDA (U) (* lmm " 9-Jan-86 15:31") (PROG (AI B) (COND ((NULL U) (RETURN B))) (SETQ AI (CAR U)) (SETQ U (CDR U)) (SETQ B (CONS AI B)) [while U do (PROGN (SETQ AI (CAR U)) (SETQ U (CDR U)) (SETQ B (\BN.MADD B \BIGNUM.THETA AI] (RETURN B]) + +(\BN.TH2D [LAMBDA (A RADIX TH) (* bvm%: "15-Apr-86 14:28") (* * A is a list of integers obtained by repeatedly dividing some bignum by TH,  which is a power of RADIX, hopefully chosen to keep the integers small.  The elements of A concatenated thus make up the print name of the bignum in the  indicated RADIX. Convert the list to a series of character codes by computing  the print names of each subpart) (OR RADIX (SETQ RADIX 10)) (COND ((NULL A) (LIST (CHARCODE 0))) (T (for AI in A bind (MAXFACTOR _ (IQUOTIENT TH RADIX)) DIGIT RESULT do [for (M _ MAXFACTOR) by (IQUOTIENT M RADIX) repeatuntil (EQ M 1) do (SETQ DIGIT (IQUOTIENT AI M)) (SETQ AI (IDIFFERENCE AI (ITIMES DIGIT M))) (COND ((OR RESULT (NEQ DIGIT 0)) (push RESULT (COND ((GEQ (SETQ DIGIT (ABS DIGIT)) 10) (* Use alphabetics for digits  greater than 9) (IPLUS (IDIFFERENCE DIGIT 10) (CHARCODE A))) (T (IPLUS DIGIT (CHARCODE 0] finally (RETURN (COND ((IGREATERP (CAR A) 0) (REVERSE RESULT)) (T (* Negative bignum) (CONS (CHARCODE -) (REVERSE RESULT]) +) +(DEFINEQ + +(\INITBIGNUMS + [LAMBDA NIL (* JDS "1-JAN-99 22:00") + + (* ;; "Initialize the BIGNUM datatype.") + + (* ;; "First, set up the type info so that newly created BIGNUM pages are correct.") + + (\SETTYPEMASK (\TYPENUMBERFROMNAME 'BIGNUM) + (LOGOR \TT.FIXP \TT.NUMBERP \TT.ATOM)) + + (* ;; "Now create some initial bignums for later use:") + + (SETQ \BIG.0 (\BN.FROM.FIXP 0)) (* ; "BIGNUM of 0") + (SETQ \BIG.1 (\BN.FROM.FIXP 1)) (* ; "BIGNUM of 1") + (SETQ MIN.INTEGER (create BIGNUM + ELEMENTS _ 'MIN.INTEGER)) + (SETQ MAX.INTEGER (create BIGNUM + ELEMENTS _ 'MAX.INTEGER]) +) + + + +(* ; "MAKERATIONAL needs work") + + + + +(* ;; +"needs work: MASK.1'S MASK.0'S BITTEST BITSET BITCLEAR LOGNOT LOADBYTE DEPOSITBYTE IMODLESSP IMODPLUS IMODDIFFERENCE ROT" +) + +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\INITBIGNUMS) +) +(PUTPROPS LLBIGNUM COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993 1999)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2909 9796 (\BIGNUM.COMPARE 2919 . 3420) (\BIGNUM.DIFFERENCE 3422 . 3650) ( +\BIGNUM.INTEGERLENGTH 3652 . 3819) (\BIGNUM.LOGAND 3821 . 4589) (\BIGNUM.LOGOR 4591 . 5324) ( +\BIGNUM.LOGXOR 5326 . 6213) (\BIGNUM.PLUS 6215 . 6432) (\BIGNUM.LSH 6434 . 8017) (\BIGNUM.TIMES 8019 + . 8238) (\BIGNUM.QUOTIENT 8240 . 9178) (\BIGNUM.REMAINDER 9180 . 9552) (\BIGNUM.TO.FLOAT 9554 . 9794) +) (9797 10175 (FINITEP 9807 . 9993) (INFINITEP 9995 . 10173)) (10211 40300 (\BIGNUM.TO.INT 10221 . +10473) (\BN.2TH 10475 . 10859) (\BN.ABS 10861 . 11066) (\BN.DIFFERENCE 11068 . 11218) (\BN.DIVIDE +11220 . 16135) (\BN.FLOAT 16137 . 19004) (\BN.IGNN 19006 . 19392) (BIGNUM.DEFPRINT 19394 . 22989) ( +\BN.INTEGERLENGTH 22991 . 23418) (\BN.LOGAND 23420 . 23956) (\BN.LOGANDC2 23958 . 24510) (\BN.LOGOR +24512 . 24825) (\BN.LOGXOR 24827 . 25143) (\BN.MINUS 25145 . 25500) (\BN.PLUS2 25502 . 26588) ( +\BN.SIGN 26590 . 27036) (\BN.TIMES2 27038 . 29091) (\BN.COMPAREN 29093 . 30382) (\BN.D2TH 30384 . +31579) (\BN.FROM.FIXP 31581 . 32143) (\BN.ICANON 32145 . 33362) (\BN.IDIVIDE 33364 . 33525) (\BN.ISUM0 + 33527 . 34192) (\BN.ISUM1 34194 . 34927) (\BN.MADD 34929 . 35708) (\BN.TO.FIXP 35710 . 36321) ( +\BN.NZEROS 36323 . 36480) (\BN.QRS 36482 . 37289) (\BN.SIGN 37291 . 37737) (\BN.TH2B 37739 . 38222) ( +\BN.TH2D 38224 . 40298)) (40301 41091 (\INITBIGNUMS 40311 . 41089))))) +STOP diff --git a/sources/LLCHAR b/sources/LLCHAR new file mode 100644 index 00000000..7b7b404b --- /dev/null +++ b/sources/LLCHAR @@ -0,0 +1,217 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Nov-2018 13:08:04" {DSK}kaplan>Local>medley3.5>lispcore>sources>LLCHAR.;2 77794 changes to%: (FNS U-CASE L-CASE) previous date%: "12-Jan-94 10:12:34" {DSK}kaplan>Local>medley3.5>lispcore>sources>LLCHAR.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1994, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLCHARCOMS) (RPAQQ LLCHARCOMS ((FNS ALLOCSTRING MKATOM SUBATOM CHARACTER \PARSE.NUMBER \INVALID.DOTTED.SYMBOL \INVALID.INTEGER \MKINTEGER MKSTRING \PRINDATUM.TO.STRING BKSYSBUF NCHARS NTHCHARCODE RPLCHARCODE \RPLCHARCODE NTHCHAR RPLSTRING SUBSTRING GNC GNCCODE GLC GLCCODE STREQUAL STRING.EQUAL STRINGP CHCON1 U-CASE L-CASE U-CASEP \SMASHABLESTRING \MAKEWRITABLESTRING \SMASHSTRING \FATTENSTRING) (COMS (* ;  "Temporary until low level system is changed to call STRING.EQUAL again") (P (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T) (MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T))) (FNS \GETBASESTRING \PUTBASESTRING \PUTBASESTRINGFAT GetBcplString SetBcplString) (DECLARE%: DONTCOPY (EXPORT (RECORDS STRINGP) (GLOBALVARS \OneCharAtomBase) (RESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING) (CONSTANTS (\FATPNAMESTRINGP T)) (MACROS \PNAMESTRINGPUTCHAR) (OPTIMIZERS FCHARACTER) (I.S.OPRS inpname inatom instring) (* ;  "For use when the inner-loop test in the generic operators is too expensive") (I.S.OPRS infatatom inthinatom infatstring inthinstring) (MACROS \CHARCODEP \FATCHARCODEP \THINCHARCODEP) (* ; "For benefit of Masterscope") (MACROS \GETBASEFAT \GETBASETHIN \PUTBASEFAT \PUTBASETHIN) (MACROS \PUTBASECHAR \GETBASECHAR) (MACROS \CHARSET \CHAR8CODE) (CONSTANTS (\CHARMASK 255) (\MAXCHAR 255) (\MAXTHINCHAR 255) (\MAXFATCHAR 65535) (\MAXCHARSET 255) (NSCHARSETSHIFT 255) (%#STRINGPWORDS 4)) (MACROS \NATOMCHARS \NSTRINGCHARS))) (INITRESOURCES \NUMSTR \NUMSTR1 \PNAMESTRING) (P (MOVD? 'CHARACTER 'FCHARACTER NIL T)) [COMS (FNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY) (* ; "For MAKEINIT") (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)) (* "So %%COPY-ONED-ARRAY will compile properly") (INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)) (EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT \PUTBASECHAR) (DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY] (DECLARE%: DONTCOPY EVAL@COMPILE (LOCALVARS . T)) (* ;; "Arrange for the proper compiler") (PROP FILETYPE LLCHAR))) (DEFINEQ (ALLOCSTRING +(LAMBDA (N INITCHAR OLD FATFLG) (* jop%: "23-Sep-86 17:44") (SETQ N (FIX N)) (* ; "Coerce floats at the outset") (COND ((OR (ILESSP N 0) (IGREATERP N \MaxArrayLen)) (LISPERROR "ILLEGAL ARG" N))) (COND ((NULL INITCHAR) (SETQ INITCHAR 0)) ((\CHARCODEP INITCHAR)) (T (SETQ INITCHAR (CHCON1 INITCHAR)))) (LET ((FATP (OR FATFLG (IGREATERP INITCHAR \MAXTHINCHAR))) STRINGBASE) (* ; "Allocate the block before going uninterruptable in the smashing case.") (SETQ STRINGBASE (\ALLOCBLOCK (COND (FATP (FOLDHI N WORDSPERCELL)) (T (FOLDHI N BYTESPERCELL))))) (COND ((STRINGP OLD) (UNINTERRUPTABLY (create STRINGP smashing OLD LENGTH _ N BASE _ STRINGBASE TYP _ (COND (FATP \ST.POS16) (T \ST.BYTE))))) (T (SETQ OLD (create STRINGP LENGTH _ N BASE _ STRINGBASE TYP _ (COND (FATP \ST.POS16) (T \ST.BYTE)))))) (COND ((NEQ 0 INITCHAR) (* ; "\ALLOCBLOCK always zeros the block, so don't need to initialize then") (COND (FATP (for I from 0 to (SUB1 N) do (\PUTBASEFAT STRINGBASE I INITCHAR))) (T (for I from 0 to (SUB1 N) do (\PUTBASETHIN STRINGBASE I INITCHAR))))))) OLD) +) (MKATOM +(LAMBDA (X) (* jop%: "23-Sep-86 16:30") (COND ((STRINGP X) (\MKATOM (ffetch (STRINGP BASE) of X) (ffetch (STRINGP OFFST) of X) (LET ((LEN (ffetch (STRINGP LENGTH) of X))) (COND ((IGREATERP LEN \PNAMELIMIT) (LISPERROR "ATOM TOO LONG" X)) (T LEN))) (ffetch (STRINGP FATSTRINGP) of X))) ((OR (LITATOM X) (NUMBERP X)) X) (T (PACK* X)))) +) (SUBATOM +(LAMBDA (X N M) (* jop%: "23-Sep-86 17:47") (PROG (BASE OFFST LEN FATP (N1 N) (M1 M)) (* ; "N1 and M1 so don't reset user arg.") (COND ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X))) (T (SETQ LEN (OR (STRINGP X) (MKSTRING X))) (* ; "Don't reset user arg") (SETQ BASE (ffetch (STRINGP BASE) of LEN)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of LEN)) (SETQ OFFST (ffetch (STRINGP OFFST) of LEN)) (SETQ LEN (ffetch (STRINGP LENGTH) of LEN)))) (COND ((IGREATERP 0 N1) (* ; "Coerce the first index") (SETQ N1 (IPLUS N1 LEN 1)))) (COND ((NULL M1) (* ; "Coerce the second") (SETQ M1 LEN)) ((IGREATERP 0 M1) (SETQ M1 (IPLUS M1 LEN 1)))) (RETURN (AND (IGREATERP N1 0) (ILEQ N1 M1) (ILEQ M1 LEN) (\MKATOM BASE (IPLUS OFFST N1 -1) (COND ((IGREATERP (SETQ LEN (ADD1 (IDIFFERENCE M1 N1))) \PNAMELIMIT) (LISPERROR "ATOM TOO LONG" X)) (T LEN)) FATP))))) +) (CHARACTER +(LAMBDA (N) (* jop%: "23-Sep-86 17:45") (OR (\CHARCODEP N) (SETQ N (\ILLEGAL.ARG N))) (COND ((IGREATERP N \MAXTHINCHAR) (* ; "The character we're getting is NOT a thin character -- do it the hard way") (WITH-RESOURCE (\PNAMESTRING) (\PNAMESTRINGPUTCHAR (ffetch (STRINGP XBASE) of \PNAMESTRING) 0 N) (\MKATOM (ffetch (STRINGP XBASE) of \PNAMESTRING) 0 1 \FATPNAMESTRINGP))) ((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)))) +) (\PARSE.NUMBER +(LAMBDA (BASE BN LEN FATP RADIX RDTBL) (* ; "Edited 12-Feb-87 19:21 by bvm:") (* ;;; "Attempt to create a numeric atom out of the chars in BASE from BN for LEN characters (fat or thin, depending on FATP). Return NIL if the chars do not form a legal number when read in this read table.") (DECLARE (GLOBALVARS \ORIGREADTABLE)) (if (NULL RDTBL) then (SETQ RDTBL *READTABLE*)) (PROG ((I BN) (END (IPLUS BN LEN)) (STATE (QUOTE INIT)) (COMMONLISP (AND (NEQ RDTBL \ORIGREADTABLE) (fetch (READTABLEP COMMONLISP) of RDTBL))) COMMONLISPY MAXDIGIT MAXALPHADIGIT C SIGN START ENDFRAC DECPT EXPSTART NEGFRAC SIGDIGITS EXP10 SEENALPHADIGITS SEENBOGUSDIGITS) (* ; "The test for \origreadtable is a kludge so that \MKATOM can work before read tables are set up. \MKATOM calls us with RDTBL = \origreadtable, which is initially NOBIND. ") (if (NULL RADIX) then (SETQ RADIX (if COMMONLISP then *READ-BASE* else 10))) (if (GREATERP RADIX 10) then (* ; "can have alphabetic digits for large bases") (SETQ MAXALPHADIGIT (IPLUS (CHARCODE A) (IDIFFERENCE RADIX 11))) (SETQ MAXDIGIT (CHARCODE 9)) else (SETQ MAXDIGIT (IPLUS (CHARCODE 0) (SUB1 RADIX)))) (SETQ COMMONLISPY (OR COMMONLISP (AND (NEQ RDTBL \ORIGREADTABLE) (fetch (READTABLEP COMMONNUMSYNTAX) of RDTBL)))) LP (* ;; "Scan string to see what we have: a decimal integer, octal integer, or floating-point number. Once we know which we have, we can pack up the value quickly") (if (EQ I END) then (RETURN (SELECTQ STATE ((INITDIGIT AFTERQ AFTERMIDDLEDOT) (if (NOT START) then (* ; "saw no non-zero digits") 0 elseif SEENBOGUSDIGITS then (* ; "Some digits were not valid in this radix, so object is not a number. Note that there is no suffix in this case, so i is correct.") (\INVALID.INTEGER BASE START I SIGN RADIX FATP) else (\MKINTEGER BASE START (if (NEQ STATE (QUOTE INITDIGIT)) then (* ; "string ended in Q or dot") (SUB1 I) else I) (EQ SIGN (QUOTE -)) RADIX FATP))) ((INFRACTION INEXPONENT) (if SIGDIGITS then (if (NOT ENDFRAC) then (SETQ ENDFRAC I) (SETQ NEGFRAC (EQ SIGN (QUOTE -)))) (if (IGREATERP SIGDIGITS MAX.DIGITS.ACCURACY) then (* ;; "Too many digits--we will overflow. Only take as many as we can handle. Don't worry about looking at the n+1'st digit for rounding, since it won't make any difference (there are many fewer sig bits in a floatp than in a fixp)") (SETQ ENDFRAC (IPLUS START MAX.DIGITS.ACCURACY)) (if (AND (IGREATERP DECPT START) (ILESSP DECPT ENDFRAC)) then (add ENDFRAC 1))) (SETQ EXP10 (if EXPSTART then (\MKINTEGER BASE EXPSTART I (EQ SIGN (QUOTE -)) 10 FATP) else 0)) (* ; "the explicit exponent") (\FLOATINGSCALE (\MKINTEGER BASE START ENDFRAC NEGFRAC 10 FATP) (IPLUS EXP10 (IDIFFERENCE DECPT ENDFRAC) (if (ILESSP DECPT ENDFRAC) then (* ; "don't count the position the dec pt occupies") 1 else 0))) else (* ; "we saw only zeros") (FLOAT 0))) NIL))) (SETQ STATE (OR (SELCHARQ (SETQ C (\GETBASECHAR FATP BASE I)) (- (AND (NOT SIGN) (SELECTQ STATE ((INIT AFTERE) (SETQ SIGN (QUOTE -)) STATE) NIL))) (+ (AND (NOT SIGN) (SELECTQ STATE ((INIT AFTERE) (SETQ SIGN (QUOTE +)) STATE) NIL))) (%. (SETQ DECPT I) (SELECTQ STATE (INIT (QUOTE AFTERINITIALDOT)) (INITDIGIT (if SEENALPHADIGITS then (* ; "Can't have decimal point in other radices") NIL elseif COMMONLISP then (* ; "Could be decimal integer") (SETQ RADIX 10) (SETQ SEENBOGUSDIGITS NIL) (* ; "digits bigger than radix not an error any more") (QUOTE AFTERMIDDLEDOT) else (QUOTE INFRACTION))) (AFTERINITIALDOT (* ; "Two dots in a row. If symbol is ALL dots, then we have to signal an error.") (if (AND COMMONLISP (NOT SIGN) (for J from (ADD1 I) to (SUB1 END) always (EQ (\GETBASECHAR FATP BASE J) (CHARCODE %.)))) then (\INVALID.DOTTED.SYMBOL BASE BN LEN FATP) else (* ; "not all dots, started with sign, or in Interlisp read table, where it's ok -- just not a number") NIL)) NIL)) (COND ((AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9))) (* ; "digit") (SELECTQ STATE ((INIT INITDIGIT) (IF (> C MAXDIGIT) THEN (* ; "not a digit in this radix. However, number could turn out to be decimal (integer or float), so keep going.") (SETQ SEENBOGUSDIGITS T)) (if SIGDIGITS then (add SIGDIGITS 1) elseif (NEQ C (CHARCODE 0)) then (* ; "record where first significant digit happens") (SETQ START I) (SETQ SIGDIGITS 1)) (QUOTE INITDIGIT)) ((INFRACTION AFTERINITIALDOT AFTERMIDDLEDOT) (* ; "Scanning fractional part") (if SIGDIGITS then (add SIGDIGITS 1) elseif (NEQ C (CHARCODE 0)) then (SETQ SIGDIGITS 1) (SETQ START I)) (QUOTE INFRACTION)) (AFTERE (SETQ EXPSTART I) (QUOTE INEXPONENT)) (INEXPONENT (QUOTE INEXPONENT)) NIL)) ((IGREATERP C (CHARCODE z)) (* ; "Out in the wilderness") NIL) (T (* ; "Some other non-digit") (if (AND COMMONLISPY (IGEQ C (CHARCODE a))) then (SETQ C (IDIFFERENCE C (IDIFFERENCE (CHARCODE a) (CHARCODE A))))) (if (AND MAXALPHADIGIT (IGEQ C (CHARCODE A)) (ILEQ C MAXALPHADIGIT) (NOT DECPT)) then (* ; "Letter is a digit in this base") (SELECTQ STATE ((INIT INITDIGIT) (SETQ SEENALPHADIGITS T) (if SIGDIGITS then (add SIGDIGITS 1) else (SETQ START I) (SETQ SIGDIGITS 1)) (QUOTE INITDIGIT)) NIL) elseif (EQ C (CHARCODE Q)) then (* ; "Interlisp octal specifier -- perhaps should only do this if not common lisp") (SELECTQ STATE (INITDIGIT (SETQ RADIX 8) (SETQ SEENBOGUSDIGITS NIL) (* ; "It is possible that we should check to see if all the digits are really octal digits, but that's a pain, and we never did it before in Interlisp.") (QUOTE AFTERQ)) NIL) elseif (AND (OR (EQ C (CHARCODE E)) (AND COMMONLISPY (FMEMB C (CHARCODE (D F L S))))) (NOT SEENALPHADIGITS)) then (* ; "Exponent marker. Someday there will be differences among some of these") (SELECTQ STATE ((INITDIGIT INFRACTION AFTERMIDDLEDOT) (* ; "We've seen digits and/or a fraction") (OR DECPT (SETQ DECPT I)) (SETQ ENDFRAC I) (SETQ NEGFRAC (EQ SIGN (QUOTE -))) (SETQ SIGN NIL) (QUOTE AFTERE)) NIL) elseif (AND (EQ C (CHARCODE /)) COMMONLISPY) then (* ; "Ratio marker. Must only have seen digits and possibly sign so far") (if (AND (EQ STATE (QUOTE INITDIGIT)) (NEQ (ADD1 I) END) (for J from (ADD1 I) to (SUB1 END) always (* ; "test remaining digits valid for this radix") (AND (IGEQ (SETQ C (\GETBASECHAR FATP BASE J)) (CHARCODE 0)) (OR (ILEQ C MAXDIGIT) (AND MAXALPHADIGIT (IGEQ C (CHARCODE A)) (ILEQ (if (IGEQ C (CHARCODE a)) then (IDIFFERENCE C (IDIFFERENCE (CHARCODE a) (CHARCODE A))) else C) MAXALPHADIGIT)))))) then (RETURN (if START then (/ (\MKINTEGER BASE START I (EQ SIGN (QUOTE -)) RADIX FATP) (\MKINTEGER BASE (ADD1 I) END NIL RADIX FATP)) else (* ; "saw no non-zero digits") 0))))))) (RETURN NIL))) (SETQ I (ADD1 I)) (GO LP))) +) (\INVALID.DOTTED.SYMBOL +(LAMBDA (BASE START LEN FATP) (* ; "Edited 12-Feb-87 18:56 by bvm:") (* ;;; "Called from number parser when scanning a token that is all dots. Value returned from here is NIL to treat it as a quoted symbol or any other non-null value you'd like to return.") (CL:CERROR "Treat the dots as if they were escaped" "Invalid symbol consisting entirely of dots ~S" (\GETBASESTRING BASE START LEN FATP)) NIL) +) (\INVALID.INTEGER +(LAMBDA (BASE START END SIGN RADIX FATP) (* ; "Edited 12-Feb-87 19:39 by bvm:") (* ;;; "Called when scanning a token that is all digits, but some digits are not valid in this read base. Value returned from here is NIL to treat it as a symbol or a number (the default proceed case says to interpret in decimal).") (CL:CERROR "Treat the number as if in decimal radix" "Invalid integer %"~@[~A~]~A%" in read base ~D" SIGN (\GETBASESTRING BASE (if FATP then (* ;; "yecch. start arg to \getbasestring is always byte offset, whether it's fat or not. start arg to \parse.number is character number (and usually zero, apparently).") (UNFOLD START BYTESPERWORD) else START) (- END START) FATP) RADIX) (\MKINTEGER BASE START END (EQ SIGN (QUOTE -)) 10 FATP)) +) (\MKINTEGER + [LAMBDA (BASE START END NEG RADIX FATP) (* ; "Edited 13-Oct-87 11:10 by jrb:") + +(* ;;; "Return integer whose Ascii characters run from START to END off BASE. If NEG is true, negate it. RADIX is the base. String is assumed to contain only digits valid in RADIX -- no error checking. For benefit of floating routines, dec pt is ignored.") + +(* ;;; "JRB - Modified per BvM suggestion to accumulate three digits at a time (three digits insures largest legal radix (36) won't overflow a smallp). The bottom of the loop goes to great lengths to avoid computing RADIX^2 and RADIX^3 unless it absolutely has to.") + + (PROG ((VAL 0) + LOOPVAL CH I RADIX2 RADIX3) + LP (if (EQ START END) + then (RETURN VAL)) + (SETQ LOOPVAL 0) + (SETQ I 3) + (while (AND (NOT (EQ START END)) + (NOT (EQ I 0))) + do (SETQ CH (\GETBASECHAR FATP BASE START)) + (if (NEQ CH (CHARCODE ".")) + then (* ; "ignore dec pt") + + [SETQ CH (if (IGEQ CH (CHARCODE A)) + then (* ; + "Large radix digit. Could be lowercase, so zap the 40q bit") + + (IPLUS 10 (IDIFFERENCE (LOGAND CH 95) + (CHARCODE A))) + else (IDIFFERENCE CH (CHARCODE 0] + (SETQ LOOPVAL (if NEG + then (IDIFFERENCE (ITIMES LOOPVAL RADIX) + CH) + else (IPLUS (ITIMES LOOPVAL RADIX) + CH))) + (SETQ I (SUB1 I))) + (SETQ START (ADD1 START))) + (SETQ VAL (if (EQ VAL 0) + then LOOPVAL + else [OR RADIX3 (SETQ RADIX3 (ITIMES RADIX (SETQ RADIX2 (ITIMES RADIX RADIX] + (IPLUS (ITIMES VAL (SELECTQ I + (0 RADIX3) + (1 RADIX2) + (2 RADIX) + 1)) + LOOPVAL))) + (GO LP]) (MKSTRING +(LAMBDA (X FLG RDTBL) (* ; "Edited 10-Feb-87 19:09 by bvm:") (* ; "Coerce X to be a string. The string will be FAT if X is") (DECLARE (GLOBALVARS PRXFLG)) (OR (COND ((NOT FLG) (* ; "The simple case -- just gather up the characters in the item") (COND ((STRINGP X) (* ; "Strings coerce to themselves") X) ((LITATOM X) (* ; "LITATOMs have a new descriptor created, pointing to the same characters.") (create STRINGP XBASE _ (ffetch (LITATOM PNAMEBASE) of X) LENGTH _ (ffetch (LITATOM PNAMELENGTH) of X) OFFST _ 1 XREADONLY _ T TYP _ (COND ((ffetch (LITATOM FATPNAMEP) of X) \ST.POS16) (T \ST.BYTE)))) ((CL:CHARACTERP X) (* ; "CL characters are one-character strings") (ALLOCSTRING 1 (CL:CHAR-CODE X)))))) (LET ((BASE (COND (PRXFLG (\CHECKRADIX *PRINT-BASE*)) (T 10)))) (LET ((*PRINT-ESCAPE* FLG) (*READTABLE* (COND (FLG (\GTREADTABLE RDTBL)) (T *READTABLE*))) (*PRINT-RADIX* (AND FLG (NEQ BASE 10))) (*PRINT-BASE* BASE) (*PRINT-LENGTH*) (*PRINT-LEVEL*)) (* ;; "General case: internally print the name, gather up the characters") (\PRINDATUM.TO.STRING X))))) +) (\PRINDATUM.TO.STRING +(LAMBDA (X) (* ; "Edited 9-Dec-86 11:04 by jrb:") (* ;;; "Produces a string that is the result of printing X according the current settings of *PRINT-ESCAPE* etc.") (SELECTC (NTYPX X) ((LIST \FIXP \SMALLP \FLOATP) (* ; "We know how to print numbers without extra steps") (GLOBALRESOURCE (\NUMSTR \NUMSTR1) (LET ((STR (COND ((FLOATP X) (\CONVERT.FLOATING.NUMBER X \NUMSTR \NUMSTR1)) (T (\CONVERTNUMBER X *PRINT-BASE* NIL (AND *PRINT-RADIX* *READTABLE*) \NUMSTR \NUMSTR1))))) (RPLSTRING (ALLOCSTRING (NCHARS STR)) 1 STR)))) (LET ((FATSTRINGP) (STRINGLEN 0) (STRINDEX 0) STRINGPTR *PRINT-CIRCLE-HASHTABLE* (*PRINT-CIRCLE-NUMBER* 1) THERE-ARE-CIRCLES) (DECLARE (CL:SPECIAL *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES)) (* ; "If *print-circle* is on, need to scan the structure") (IF *PRINT-CIRCLE* THEN (SETQ *PRINT-CIRCLE-HASHTABLE* (CL:MAKE-HASH-TABLE)) (PRINT-CIRCLE-SCAN X) (IF (NOT THERE-ARE-CIRCLES) THEN (SETQ *PRINT-CIRCLE-HASHTABLE* NIL))) (* ;; "First count up the characters and their fatness") (\MAPPNAME.INTERNAL (FUNCTION (LAMBDA (DUMMY CODE) (COND ((GREATERP CODE \MAXTHINCHAR) (SETQ FATSTRINGP T))) (add STRINGLEN 1))) X) (* ;; "We print structures TWICE here, so we need to reset *PRINT-CIRCLE-HASHTABLE* and *PRINT-CIRCLE-NUMBER* if circles are being printed") (if *PRINT-CIRCLE-HASHTABLE* then (SETQ *PRINT-CIRCLE-NUMBER* 1) (CL:MAPHASH (CL:FUNCTION (LAMBDA (KEY VAL) (if (NUMBERP VAL) then (CL:SETF (CL:GETHASH KEY *PRINT-CIRCLE-HASHTABLE*) (QUOTE T2))))) *PRINT-CIRCLE-HASHTABLE*)) (* ;; "Then print X again actually storing the characters into the string") (SETQ STRINGPTR (ALLOCSTRING STRINGLEN NIL NIL FATSTRINGP)) (\MAPPNAME.INTERNAL (FUNCTION (LAMBDA (DUMMY CODE) (COND ((EQ STRINDEX (ffetch (STRINGP LENGTH) of STRINGPTR)) (* ; "Help! NCHARS and \MAPPNAME disagree.") (SETQ STRINGPTR (CONCAT STRINGPTR " ")))) (add STRINDEX 1) (COND ((ffetch (STRINGP FATSTRINGP) of STRINGPTR) (* ; "Fat string; just smash the character in.") (\PUTBASEFAT (fetch (STRINGP BASE) of STRINGPTR) (IPLUS (fetch (STRINGP OFFST) of STRINGPTR) STRINDEX -1) CODE)) ((ILEQ CODE \MAXTHINCHAR) (* ; "Thin char and String; just smash the char in") (\PUTBASETHIN (fetch (STRINGP BASE) of STRINGPTR) (IPLUS (fetch (STRINGP OFFST) of STRINGPTR) STRINDEX -1) CODE)) (T (* ;; "Need to fatten the string, then smash in the char. This shouldn't happen unless X gets printed different the two times!") (\FATTENSTRING STRINGPTR) (\PUTBASEFAT (fetch (STRINGP BASE) of STRINGPTR) (IPLUS (fetch (STRINGP OFFST) of STRINGPTR) STRINDEX -1) CODE))))) X) STRINGPTR))) +) (BKSYSBUF +(LAMBDA (X FLG RDTBL) (* jop%: "23-Sep-86 17:31") (PROG NIL (if (NOT FLG) then (COND ((LITATOM X) (RETURN (for C inatom X do (BKSYSCHARCODE C)))) ((STRINGP X) (RETURN (for C instring X do (BKSYSCHARCODE C)))) (T NIL))) (LET ((*READTABLE* *READTABLE*) (*PACKAGE* *PACKAGE*) TTY) (if FLG then (if RDTBL then (* ; "Use the explicit read table we were given") (SETQ *READTABLE* (\GTREADTABLE RDTBL)) elseif (NEQ (SETQ TTY (TTY.PROCESS)) (THIS.PROCESS)) then (* ; "Print it using the read environment of the destination tty") (SETQ *READTABLE* (PROCESS.EVALV TTY (QUOTE *READTABLE*))) (SETQ *PACKAGE* (PROCESS.EVALV TTY (QUOTE *PACKAGE*))))) (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (BKSYSCHARCODE CODE))) X FLG RDTBL))) X) +) (NCHARS +(LAMBDA (X FLG RDTBL) (* jop%: "24-Sep-86 23:06") (* ;;; "Return the number of characters in (the print name of) X. If FLG, then return the number of characters in the PRIN2 version, according to RDTBL.") (PROG ((NCHARCNT 0)) (COND ((LITATOM X) (if (NOT FLG) then (* ; "Too hairy to figure out package count") (RETURN (ffetch (LITATOM PNAMELENGTH) of X)))) ((STRINGP X) (RETURN (IPLUS (ffetch (STRINGP LENGTH) of X) (COND (FLG (* ;; "2 for the enclosing quotes and an escape to quote every double quote char or escape in the string body") (IPLUS 2 (for C instring X bind (ESC _ (ffetch (READTABLEP ESCAPECHAR) of (\GTREADTABLE RDTBL))) count (OR (EQ C (CHARCODE %")) (EQ C (CHARCODE LF)) (EQ C ESC))))) (T 0)))))) (* ; "Slow case...") (\MAPPNAME (FUNCTION (LAMBDA NIL (add NCHARCNT 1))) X FLG RDTBL) (RETURN NCHARCNT))) +) (NTHCHARCODE +(LAMBDA (X N FLG RDTBL) (* jop%: "23-Sep-86 16:34") (PROG (BASE OFFST FATP LEN (M N)) (COND (FLG (GO SLOWCASE)) (T (COND ((STRINGP X) (SETQ BASE (ffetch (STRINGP BASE) of X)) (SETQ LEN (ffetch (STRINGP LENGTH) of X)) (SETQ OFFST (ffetch (STRINGP OFFST) of X)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X))) ((LITATOM X) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of X)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X)) (SETQ OFFST 1) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X))) (T (GO SLOWCASE))))) (COND ((ILESSP M 0) (* ; "Negative index counts from end") (SETQ M (IPLUS M LEN 1)))) (RETURN (COND ((OR (ILESSP M 1) (IGREATERP M LEN)) (* ; "out of range") NIL) (T (* ; "The -1 is cause strings have ORIG=1") (\GETBASECHAR FATP BASE (SUB1 (IPLUS OFFST M)))))) SLOWCASE (COND ((EQ M 0) (RETURN)) ((ILESSP M 0) (AND (ILESSP (SETQ M (IPLUS M (NCHARS X FLG RDTBL) 1)) 1) (RETURN)))) (\MAPPNAME (FUNCTION (LAMBDA (DUMMY CODE) (COND ((EQ (SETQ M (SUB1 M)) 0) (RETFROM (QUOTE NTHCHARCODE) CODE))))) X FLG RDTBL) (RETURN))) +) (RPLCHARCODE +(LAMBDA (X N CHAR) (* jop%: "23-Sep-86 16:36") (COND ((STRINGP X) (PROG ((LEN (ffetch (STRINGP LENGTH) of X))) (\SMASHABLESTRING X (\FATCHARCODEP CHAR)) (COND ((ILESSP N 0) (* ; "address from end") (SETQ N (IPLUS N LEN 1)))) (COND ((OR (ILESSP N 1) (IGREATERP N LEN)) (LISPERROR "ILLEGAL ARG" N))) (* ; "We assume that ORIG is 1 because X is a string") (\PUTBASECHAR (ffetch (STRINGP FATSTRINGP) of X) (ffetch (STRINGP BASE) of X) (IPLUS (ffetch (STRINGP OFFST) of X) (SUB1 N)) CHAR) (RETURN X))) (T (RPLCHARCODE (MKSTRING X) N CHAR)))) +) (\RPLCHARCODE +(LAMBDA (X N CHAR) (* jop%: "23-Sep-86 16:50") (* ;;; "System version: does error checking interpreted. Compiles open as \PUTBASEFAT or \PUTBASETHIN. N must be positive, X must be a real not READONLY string") (COND ((OR (NOT (STRINGP X)) (ffetch (STRINGP READONLY) of X)) (* ; "X has to be a string, and can't be READONLY (e.g. a litatom's pname)") (LISPERROR "ILLEGAL ARG" X)) ((OR (ILEQ N 0) (IGREATERP N (ffetch (STRINGP LENGTH) of X))) (* ; "The position arg has to be inside the string's length") (LISPERROR "ILLEGAL ARG" N)) ((NOT (\CHARCODEP CHAR)) (* ; "CHAR has to be a charcode") (LISPERROR "ILLEGAL ARG" CHAR)) ((AND (IGREATERP CHAR \MAXTHINCHAR) (NOT (ffetch (STRINGP FATSTRINGP) of X))) (* ; "If the char's fat, and the string isn't, coerce it to fatness.") (\SMASHABLESTRING X T))) (\PUTBASECHAR (ffetch (STRINGP FATSTRINGP) of X) (ffetch (STRINGP BASE) of X) (IPLUS (ffetch (STRINGP OFFST) of X) (SUB1 N)) CHAR) X) +) (NTHCHAR +(LAMBDA (X N FLG RDTBL) (* jop%: "23-Sep-86 17:17") (LET ((CODE (NTHCHARCODE X N FLG RDTBL))) (AND CODE (FCHARACTER CODE)))) +) (RPLSTRING +(LAMBDA (X N Y) (* ; "Edited 24-Sep-87 11:49 by bvm:") (PROG ((OLDSTRING (OR (STRINGP X) (MKSTRING X))) (REP Y) OBASE OLEN RBASE RLEN ROFFST POS FIRSTNEW RFAT) (SETQ OLEN (ffetch (STRINGP LENGTH) of OLDSTRING)) (COND ((LITATOM REP) (SETQ RBASE (ffetch (LITATOM PNAMEBASE) of REP)) (SETQ ROFFST 1) (SETQ RLEN (ffetch (LITATOM PNAMELENGTH) of REP)) (SETQ RFAT (ffetch (LITATOM FATPNAMEP) of REP))) (T (OR (STRINGP REP) (SETQ REP (MKSTRING REP))) (SETQ RBASE (ffetch (STRINGP BASE) of REP)) (SETQ ROFFST (ffetch (STRINGP OFFST) of REP)) (SETQ RLEN (ffetch (STRINGP LENGTH) of REP)) (SETQ RFAT (ffetch (STRINGP FATSTRINGP) of REP)))) (COND ((> (+ RLEN (SETQ POS (COND ((> N 0) (SUB1 N)) (T (+ OLEN N))))) OLEN) (LISPERROR "ILLEGAL ARG" (if (> POS OLEN) then (* ; "actually, the index is wrong, without even considering the replacement") N else Y)))) (\SMASHABLESTRING OLDSTRING RFAT) (* ; "Make sure the string is writeable and of the appropriate width") (SETQ OBASE (ffetch (STRINGP BASE) of OLDSTRING)) (* ; "Note: OBASE might have changed, so not fetched until now") (SETQ FIRSTNEW (+ POS (ffetch (STRINGP OFFST) of OLDSTRING))) (* ; "Now can smash chars from RBASE into OBASE starting at position FIRSTNEW") (COND (RFAT (* ; "Fat into fat. \SMASHABLESTRING* above ensured that OLDSTRING is now fat") (\BLT (\ADDBASE OBASE FIRSTNEW) (\ADDBASE RBASE ROFFST) RLEN)) ((ffetch (STRINGP FATSTRINGP) of OLDSTRING) (* ; "Smashing thin string into a fat one") (for I from ROFFST to (SUB1 (+ ROFFST RLEN)) as J from FIRSTNEW do (\PUTBASEFAT OBASE J (\GETBASETHIN RBASE I)))) (T (* ; "Thin into thin is just byte blt") (\MOVEBYTES RBASE ROFFST OBASE FIRSTNEW RLEN))) (RETURN OLDSTRING))) +) (SUBSTRING +(LAMBDA (X N M OLDPTR) (* jop%: "23-Sep-86 17:48") (PROG ((OLDSTRING X) (START N) (END M) FATP BASE OFFST LEN) (* ; "OLDSTRING START and END so don't reset user args") (COND ((LITATOM OLDSTRING) (SETQ BASE (ffetch (LITATOM PNAMEBASE) of OLDSTRING)) (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of OLDSTRING)) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of OLDSTRING)) (SETQ OFFST 1)) (T (OR (STRINGP OLDSTRING) (SETQ OLDSTRING (MKSTRING OLDSTRING))) (SETQ BASE (ffetch (STRINGP BASE) of OLDSTRING)) (SETQ LEN (ffetch (STRINGP LENGTH) of OLDSTRING)) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of OLDSTRING)) (SETQ OFFST (ffetch (STRINGP OFFST) of OLDSTRING)))) (COND ((ILESSP START 0) (* ; "Coerce the first index") (SETQ START (IPLUS START LEN 1)))) (COND ((NULL END) (* ; "Now coerce the second index") (SETQ END LEN)) ((ILESSP END 0) (SETQ END (IPLUS END LEN 1)))) (RETURN (COND ((AND (IGREATERP START 0) (ILEQ START END) (ILEQ END LEN)) (UNINTERRUPTABLY (COND ((STRINGP OLDPTR) (create STRINGP smashing OLDPTR READONLY _ (LITATOM OLDSTRING) BASE _ BASE TYP _ (COND (FATP \ST.POS16) (T \ST.BYTE)) LENGTH _ (ADD1 (IDIFFERENCE END START)) OFFST _ (IPLUS START OFFST -1))) (T (SETQ OLDPTR (create STRINGP READONLY _ (LITATOM OLDSTRING) BASE _ BASE TYP _ (COND (FATP \ST.POS16) (T \ST.BYTE)) LENGTH _ (ADD1 (IDIFFERENCE END START)) OFFST _ (IPLUS START OFFST -1)))))) OLDPTR))))) +) (GNC +(LAMBDA (X) (* jop%: "23-Sep-86 16:26") (LET ((CODE (GNCCODE X))) (AND CODE (FCHARACTER CODE))))) (GNCCODE +(LAMBDA (X) (* jop%: "23-Sep-86 16:27") (COND ((STRINGP X) (LET ((LEN (fetch (STRINGP LENGTH) of X)) (OFFST (fetch (STRINGP OFFST) of X))) (COND ((NOT (EQ 0 LEN)) (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X) (ffetch (STRINGP BASE) of X) OFFST) (UNINTERRUPTABLY (freplace (STRINGP OFFST) of X with (ADD1 OFFST)) (freplace (STRINGP LENGTH) of X with (SUB1 LEN)))))))) (T (NTHCHARCODE X 1)))) +) (GLC +(LAMBDA (X) (* jop%: "23-Sep-86 16:25") (LET ((CODE (GLCCODE X))) (AND CODE (FCHARACTER CODE))))) (GLCCODE +(LAMBDA (X) (* jop%: "23-Sep-86 16:26") (COND ((STRINGP X) (LET ((LEN (SUB1 (fetch (ARRAY-HEADER FILL-POINTER) of X)))) (COND ((NOT (EQ -1 LEN)) (PROG1 (\GETBASECHAR (ffetch (STRINGP FATSTRINGP) of X) (ffetch (STRINGP BASE) of X) (IPLUS LEN (ffetch (STRINGP OFFST) of X))) (UNINTERRUPTABLY (freplace (ARRAY-HEADER FILL-POINTER-P) of X with T) (freplace (ARRAY-HEADER FILL-POINTER) of X with LEN))))))) (T (NTHCHARCODE X -1)))) +) (STREQUAL + [LAMBDA (X Y) (* ; + "Edited 12-Jan-94 10:07 by sybalsky:mv:envos") + (DECLARE (LOCALVARS . T)) + (AND (STRINGP X) + (STRINGP Y) + (PROG ((LEN (ffetch (STRINGP LENGTH) of X))) + (COND + ((NEQ LEN (ffetch (STRINGP LENGTH) of Y)) + (RETURN))) + (RETURN (PROG ((BASEX (ffetch (STRINGP BASE) of X)) + (BNX (ffetch (STRINGP OFFST) of X)) + (FATPX (ffetch (STRINGP FATSTRINGP) of X)) + (BASEY (ffetch (STRINGP BASE) of Y)) + (BNY (ffetch (STRINGP OFFST) of Y)) + (FATPY (ffetch (STRINGP FATSTRINGP) of Y))) + (COND + ((OR (NEQ 0 BNX) + (NEQ 0 BNY) + FATPX FATPY) + (GO SLOWLP))) + LP (COND + ((EQ 0 LEN) + (RETURN T))) + (add LEN -1) + (COND + ((NEQ (\GETBASEBYTE BASEX LEN) + (\GETBASEBYTE BASEY LEN)) + (RETURN))) + (GO LP) + SLOWLP + (COND + ((EQ 0 LEN) + (RETURN T)) + ((NEQ (\GETBASECHAR FATPX BASEX BNX) + (\GETBASECHAR FATPY BASEY BNY)) + (RETURN)) + (T (add BNX 1) + (add BNY 1) + (add LEN -1) + (GO SLOWLP]) (STRING.EQUAL + [LAMBDA (X Y) (* ; + "Edited 12-Jan-94 10:01 by sybalsky:mv:envos") + +(* ;;; "True if X and Y are equal atoms or strings without respect to alphabetic case") + + (PROG (CABASE LEN BASEX OFFSETX FATPX BASEY OFFSETY FATPY C1 C2) + (COND + ((LITATOM X) + (SETQ LEN (ffetch (LITATOM PNAMELENGTH) of X)) + (SETQ BASEX (ffetch (LITATOM PNAMEBASE) of X)) + (SETQ OFFSETX 1) + (SETQ FATPX (ffetch (LITATOM FATPNAMEP) of X))) + ((STRINGP X) + (SETQ LEN (ffetch (STRINGP LENGTH) of X)) + (SETQ BASEX (ffetch (STRINGP BASE) of X)) + (SETQ OFFSETX (ffetch (STRINGP OFFST) of X)) + (SETQ FATPX (ffetch (STRINGP FATSTRINGP) of X))) + ((SETQ X (MKSTRING X)) + (SETQ LEN (ffetch (STRINGP LENGTH) of X)) + (SETQ BASEX (ffetch (STRINGP BASE) of X)) + (SETQ OFFSETX (ffetch (STRINGP OFFST) of X)) + (SETQ FATPX (ffetch (STRINGP FATSTRINGP) of X))) + (T (RETURN NIL))) + (COND + ((LITATOM Y) + (COND + ((NEQ LEN (ffetch (LITATOM PNAMELENGTH) of Y)) + (RETURN))) + (SETQ BASEY (ffetch (LITATOM PNAMEBASE) of Y)) + (SETQ OFFSETY 1) + (SETQ FATPY (ffetch (LITATOM FATPNAMEP) of Y))) + ((STRINGP Y) + (COND + ((NEQ LEN (ffetch (STRINGP LENGTH) of Y)) + (RETURN))) + (SETQ BASEY (ffetch (STRINGP BASE) of Y)) + (SETQ OFFSETY (ffetch (STRINGP OFFST) of Y)) + (SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y))) + ((SETQ Y (MKSTRING Y)) + (COND + ((NEQ LEN (ffetch (STRINGP LENGTH) of Y)) + (RETURN))) + (SETQ BASEY (ffetch (STRINGP BASE) of Y)) + (SETQ OFFSETY (ffetch (STRINGP OFFST) of Y)) + (SETQ FATPY (ffetch (STRINGP FATSTRINGP) of Y))) + (T (RETURN NIL))) + [COND + ((NEQ (ffetch (ARRAYP TYP) of (\DTEST UPPERCASEARRAY 'ARRAYP)) + \ST.BYTE) (* ; + "Someone smashed UPPERCASEARRAY ?") + (SETQ UPPERCASEARRAY (UPPERCASEARRAY] + (SETQ CABASE (ffetch (ARRAYP BASE) of UPPERCASEARRAY)) + (RETURN (COND + [(OR FATPX FATPY) (* ; "Slow case") + (for BNX from OFFSETX as BNY from OFFSETY as I to + LEN + always (PROGN (SETQ C1 (\GETBASECHAR FATPX BASEX BNX)) + (SETQ C2 (\GETBASECHAR FATPY BASEY BNY)) + (COND + ((OR (IGREATERP C1 \MAXTHINCHAR) + (IGREATERP C2 \MAXTHINCHAR)) + (* ; "Fat chars not alphabetic") + (EQ C1 C2)) + (T (EQ (\GETBASEBYTE CABASE C1) + (\GETBASEBYTE CABASE C2] + (T (for BNX from OFFSETX as BNY from OFFSETY as I + to LEN always (EQ (\GETBASEBYTE CABASE (\GETBASETHIN BASEX BNX)) + (\GETBASEBYTE CABASE (\GETBASETHIN BASEY BNY]) (STRINGP +(LAMBDA (OBJECT) (* jop%: "24-Sep-86 22:58") (AND (%%STRINGP OBJECT) OBJECT))) (CHCON1 +(LAMBDA (X) (* jop%: "23-Sep-86 17:45") (* ;;; "This is opencoded NTHCHARCODE* for the case where N=1 and FLG=NIL") (COND ((STRINGP X) (AND (NEQ (fetch (STRINGP LENGTH) of X) 0) (\GETBASECHAR (fetch (STRINGP FATSTRINGP) of X) (fetch (STRINGP BASE) of X) (fetch (STRINGP OFFST) of X)))) ((LITATOM X) (AND (NEQ (ffetch (LITATOM PNAMELENGTH) of X) 0) (\GETBASECHAR (ffetch (LITATOM FATPNAMEP) of X) (ffetch (LITATOM PNAMEBASE) of X) 1))) (T (NTHCHARCODE X 1)))) +) (U-CASE [LAMBDA (X) (* ; "Edited 11-Nov-2018 13:06 by rmk:") (* ; "Edited 10-Feb-87 19:12 by bvm:") (COND [(LITATOM X) (WITH-RESOURCE (\PNAMESTRING) (* ;; "RMK: This was set up to call \MKATOM with the characters in a fat-string array, even if the original atom was a thin atom. Then \MKATOM is suppose to sort it out. But case-changing in the ASCII range doesn't coerce between fat and thin. So this should use the format of the original atom, not rely on \MKATOM to correct.") (for C CHANGEFLG (FATP _ (FETCH (LITATOM FATPNAMEP) OF X)) (BASE _ (ffetch (STRINGP BASE) of \PNAMESTRING)) inatom X as I from 0 do (\PUTBASECHAR FATP BASE I (COND [(AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (SETQ CHANGEFLG (IPLUS C (IDIFFERENCE (CHARCODE A) (CHARCODE a] (T C))) finally (RETURN (COND ((OR CHANGEFLG (NEQ (CL:SYMBOL-PACKAGE X) *INTERLISP-PACKAGE*)) (\MKATOM BASE 0 I FATP)) (T (* ;  "Don't bother calling \MKATOM if X already uppercase and interned in IL") X] ((STRINGP X) (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X)) instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING ( \NSTRINGCHARS X) NIL NIL FATP)) (SETQ BASE (ffetch (STRINGP XBASE) of NEWSTRING)) do (\PUTBASECHAR FATP BASE I (COND [(AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))) (IPLUS C (IDIFFERENCE (CHARCODE A) (CHARCODE a] (T C))) finally (RETURN NEWSTRING))) [(LISTP X) (CONS (U-CASE (CAR X)) (AND (CDR X) (U-CASE (CDR X] (T X]) (L-CASE [LAMBDA (X FLG) (* ; "Edited 11-Nov-2018 13:07 by rmk:") (* ; "Edited 10-Feb-87 19:12 by bvm:") (* ;; "RMK: See comment in U-CASE") (COND [(LITATOM X) (WITH-RESOURCE (\PNAMESTRING) (for C CHANGEFLG (FATP _ (FETCH (LITATOM FATPNAMEP) OF X)) (BASE _ (ffetch (STRINGP XBASE) of \PNAMESTRING)) inatom X as I from 0 do [COND [(AND (IGEQ C (CHARCODE A)) (ILEQ C (CHARCODE Z))) (COND (FLG (SETQ FLG NIL)) (T (SETQ CHANGEFLG (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE a) (CHARCODE A] ([AND FLG (AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z] (SETQ FLG NIL) (SETQ CHANGEFLG (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A) (CHARCODE a] (\PUTBASECHAR FATP BASE I C) finally (RETURN (COND ((OR CHANGEFLG (NEQ (CL:SYMBOL-PACKAGE X) *INTERLISP-PACKAGE*)) (\MKATOM BASE 0 I FATP)) (T (* ;  "Don't bother calling \MKATOM if X already lowercase and interned in IL") X] ((STRINGP X) (for C BASE NEWSTRING (FATP _ (ffetch (STRINGP FATSTRINGP) of X)) instring X as I from 0 first (SETQ NEWSTRING (ALLOCSTRING ( \NSTRINGCHARS X) NIL NIL FATP)) (SETQ BASE (ffetch (STRINGP BASE) of NEWSTRING)) do [COND [(AND (IGEQ C (CHARCODE A)) (ILEQ C (CHARCODE Z))) (COND (FLG (SETQ FLG NIL)) (T (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE a) (CHARCODE A] ([AND FLG (AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z] (SETQ FLG NIL) (SETQ C (IPLUS C (IDIFFERENCE (CHARCODE A) (CHARCODE a] (\PUTBASECHAR FATP BASE I C) finally (RETURN NEWSTRING))) [(LISTP X) (CONS (L-CASE (CAR X) FLG) (AND (CDR X) (L-CASE (CDR X) FLG] (T X]) (U-CASEP +(LAMBDA (X) (* jop%: "23-Sep-86 16:43") (COND ((LITATOM X) (for C inatom X never (AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))))) ((STRINGP X) (for C instring X never (AND (IGEQ C (CHARCODE a)) (ILEQ C (CHARCODE z))))) ((LISTP X) (AND (U-CASEP (CAR X)) (OR (NULL (CDR X)) (U-CASEP (CDR X))))) (T T))) +) (\SMASHABLESTRING +(LAMBDA (STR FATP) (* gbn "18-Apr-85 00:39") (* ;; "Ensures that FATP characters can be smashed into STR") (COND ((ffetch (STRINGP READONLY) of STR) (\MAKEWRITABLESTRING STR (OR FATP (ffetch (STRINGP FATSTRINGP) of STR)))) ((AND FATP (NOT (ffetch (STRINGP FATSTRINGP) of STR))) (\FATTENSTRING STR))) STR) +) (\MAKEWRITABLESTRING +(LAMBDA (STR NEWFATP) (* jop%: "23-Sep-86 16:44") (* ;;; "takes a string pointing at a readonly pname and changes the string to point to a block of writable memory of the appropriate width") (%%MAKE-ARRAY-WRITEABLE STR) (if (AND NEWFATP (NOT (ffetch (STRINGP FATSTRINGP) of STR))) then (%%MAKE-STRING-ARRAY-FAT STR)) STR) +) (\SMASHSTRING +(LAMBDA (DEST POS SOURCE NC) (* jop%: "23-Sep-86 16:51") (* ;;; "copy NC characters from the string SOURCE to the string DEST starting at character POS (counting from 0) of DEST. If NC=NIL, length of SOURCE is used. DEST is presumed to be not READONLY, long enough for the smash, and to be fat if SOURCE contains any fat characters--the caller must guarantee this.") (* ; "Only caller so far is \RSTRING2 in the reader") (OR NC (SETQ NC (ffetch (STRINGP LENGTH) of SOURCE))) (add POS (ffetch (STRINGP OFFST) of DEST)) (COND ((ffetch (STRINGP FATSTRINGP) of DEST) (* ; "The destination is fat.") (COND ((ffetch (STRINGP FATSTRINGP) of SOURCE) (* ; "The source is also; just copy the characters straight across") (\BLT (\ADDBASE (ffetch (STRINGP BASE) of DEST) POS) (\ADDBASE (ffetch (STRINGP BASE) of SOURCE) (ffetch (STRINGP OFFST) of SOURCE)) NC)) (T (* ; "Have to do thin-to-fat conversion") (bind (DBASE _ (ffetch (STRINGP BASE) of DEST)) for C inthinstring SOURCE as DESTCH# from POS as SRCH# from 1 to NC do (* ; "Run thru chars 1..NC (or len) of the source, moving them into the destination") (\PUTBASEFAT DBASE DESTCH# C))))) ((ffetch (STRINGP FATSTRINGP) of SOURCE) (* ; "Assume that SOURCE is FATP with no fat characters. This is a guarantee made by \RSTRING2.") (bind (DBASE _ (ffetch (STRINGP BASE) of DEST)) for C infatstring SOURCE as DESTCH# from POS as SRCH# from 1 to NC do (* ; "Run thru chars 1..NC (or len) of the source, moving them into the destination") (AND (IGREATERP C \MAXTHINCHAR) (SHOULDNT)) (* ; "If we find an unexpected fat character, complain!") (\PUTBASETHIN DBASE DESTCH# C))) (T (* ; "The source and destination are both thin. Just copy characters.") (\MOVEBYTES (ffetch (STRINGP BASE) of SOURCE) (ffetch (STRINGP OFFST) of SOURCE) (ffetch (STRINGP BASE) of DEST) POS NC))) DEST) +) (\FATTENSTRING +(LAMBDA (STR) (* jop%: "11-Sep-86 18:00") (%%MAKE-STRING-ARRAY-FAT STR))) ) (* ; "Temporary until low level system is changed to call STRING.EQUAL again") (MOVD? 'STRING.EQUAL 'STRING-EQUAL NIL T) (MOVD? 'STRING.EQUAL 'CL::SIMPLE-STRING-EQUAL NIL T) (DEFINEQ (\GETBASESTRING +(LAMBDA (BASE BYTEOFFSET NCHARS FATP) (* jop%: "23-Sep-86 17:50") (* ;;; "Makes a string consisting of NCHARS characters starting at BYTEOFFSET from BASE -- note that caller must know whether the string is fat (see \PUTBASESTRING); BYTEOFFSET is always a byte offset in either case") (LET ((STR (ALLOCSTRING NCHARS NIL NIL FATP))) (\MOVEBYTES BASE BYTEOFFSET (fetch (STRINGP BASE) of STR) (fetch (STRINGP OFFST) of STR) (COND (FATP (UNFOLD NCHARS BYTESPERWORD)) (T NCHARS))) STR)) +) (\PUTBASESTRING +(LAMBDA (BASE BYTEOFFSET SOURCE FATP) (* jop%: "23-Sep-86 16:48") (* ;; "In addition to putting the bytes into memory, this guy returns the number of characters `written' , since the source may not be a STRINGP, but will be coerced to one.") (* ;; "Not clear what this fn should do with fat strings. Caller is using this fn to store raw characters into some random location, so must make some assumption about the format they are stored in. Hence if there's a fat string, but FATP is false, we don't know what to do") (COND ((STRINGP SOURCE) (COND (FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (ffetch (STRINGP BASE) of SOURCE) (ffetch (STRINGP OFFST) of SOURCE) (ffetch (STRINGP LENGTH) of SOURCE) (ffetch (STRINGP FATSTRINGP) of SOURCE))) ((ffetch (STRINGP FATSTRINGP) of SOURCE) (for CH infatstring SOURCE as OFFSET from BYTEOFFSET do (COND ((ILEQ CH \MAXTHINCHAR) (\PUTBASEBYTE BASE OFFSET CH)) (T (ERROR "Fat string in \PUTBASESTRING" SOURCE)))) (ffetch (STRINGP LENGTH) of SOURCE)) (T (\MOVEBYTES (ffetch (STRINGP BASE) of SOURCE) (ffetch (STRINGP OFFST) of SOURCE) BASE BYTEOFFSET (SETQ SOURCE (ffetch (STRINGP LENGTH) of SOURCE))) SOURCE))) ((LITATOM SOURCE) (COND (FATP (\PUTBASESTRINGFAT BASE BYTEOFFSET (ffetch (LITATOM PNAMEBASE) of SOURCE) 1 (ffetch (LITATOM PNAMELENGTH) of SOURCE) (ffetch (LITATOM FATPNAMEP) of SOURCE))) ((ffetch (LITATOM FATPNAMEP) of SOURCE) (for CH infatatom SOURCE as OFFSET from BYTEOFFSET do (COND ((ILEQ CH \MAXTHINCHAR) (\PUTBASEBYTE BASE OFFSET CH)) (T (ERROR "Fat string in \PUTBASESTRING" SOURCE)))) (ffetch (LITATOM PNAMELENGTH) of SOURCE)) (T (\MOVEBYTES (ffetch (LITATOM PNAMEBASE) of SOURCE) 1 BASE BYTEOFFSET (SETQ SOURCE (ffetch (LITATOM PNAMELENGTH) of SOURCE))) SOURCE))) (T (\PUTBASESTRING BASE BYTEOFFSET (MKSTRING SOURCE) FATP)))) +) (\PUTBASESTRINGFAT +(LAMBDA (DBASE DBYTEOFFSET SBASE SOFFSET LEN FATP) (* jop%: " 8-Sep-86 21:02") (* ;;; "Store a fat string at byte offset from DBASE. SBASE and SOFFSET are in the source's units (bytes or words)") (COND (FATP (\MOVEBYTES SBASE (UNFOLD SOFFSET BYTESPERWORD) DBASE DBYTEOFFSET (UNFOLD LEN BYTESPERWORD))) (T (* ; "Store thin string in fat format") (for I from 0 to (SUB1 LEN) as DOFF from DBYTEOFFSET by 2 do (\PUTBASETHIN DBASE DOFF 0) (\PUTBASETHIN DBASE (ADD1 DOFF) (\GETBASETHIN SBASE (IPLUS SOFFSET I)))))) LEN) +) (GetBcplString +(LAMBDA (BASE ATOMFLG) (* jop%: "23-Sep-86 17:46") (* ;; "Returns as a Lisp string the Bcpl string stored at BS. Format is one byte length, follwed by chars. If ATOMFLG is true, returns result as an atom") (LET ((L (\GETBASEBYTE BASE 0)) S) (COND ((AND ATOMFLG (ILEQ L \PNAMELIMIT)) (\MKATOM BASE 1 L)) (T (SETQ S (\GETBASESTRING BASE 1 L)) (COND (ATOMFLG (* ; "Let MKATOM handle the error") (MKATOM S)) (T S)))))) +) (SetBcplString +(LAMBDA (BASE STR) (* bvm%: " 5-Jul-85 21:50") (LET ((L (NCHARS STR))) (COND ((IGREATERP L 255) (LISPERROR "ILLEGAL ARG" BASE)) (T (\PUTBASEBYTE BASE 0 L) (\PUTBASESTRING BASE 1 STR))) BASE)) +) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \OneCharAtomBase) ) (DECLARE%: EVAL@COMPILE [PUTDEF '\NUMSTR 'RESOURCES '(NEW (ALLOCSTRING 128] [PUTDEF '\NUMSTR1 'RESOURCES '(NEW (CONCAT] [PUTDEF '\PNAMESTRING 'RESOURCES '(NEW (ALLOCSTRING \PNAMELIMIT NIL NIL \FATPNAMESTRINGP] ) (DECLARE%: EVAL@COMPILE (RPAQQ \FATPNAMESTRINGP T) (CONSTANTS (\FATPNAMESTRINGP T)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \PNAMESTRINGPUTCHAR MACRO ((BASE OFFSET CODE) (* ;  "For stuffing chars into resource \PNAMESTRING") (\PUTBASECHAR \FATPNAMESTRINGP BASE OFFSET CODE))) ) (DEFOPTIMIZER FCHARACTER (NUM) `([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)) (DECLARE%: EVAL@COMPILE (I.S.OPR 'inpname NIL '[SUBPAIR '($$END $$BODY $$FATP $$BASE $$OFFSET) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) `(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 'inatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END $$FATP) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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 'instring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE $$FATP) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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) ) (DECLARE%: EVAL@COMPILE (I.S.OPR 'infatatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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 'inthinatom NIL '[SUBPAIR '($$OFFSET $$BODY $$BASE $$END) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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 'infatstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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 'inthinstring NIL '[SUBPAIR '($$BODY $$END $$OFFSET $$BASE) (LIST (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR) (GETDUMMYVAR)) '(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) ) (DECLARE%: EVAL@COMPILE (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)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \GETBASEFAT MACRO (= . \GETBASE)) (PUTPROPS \GETBASETHIN MACRO (= . \GETBASEBYTE)) (PUTPROPS \PUTBASEFAT MACRO (= . \PUTBASE)) (PUTPROPS \PUTBASETHIN MACRO (= . \PUTBASEBYTE)) ) (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \CHARSET MACRO ((CHARCODE) (LRSH CHARCODE 8))) (PUTPROPS \CHAR8CODE MACRO ((CHARCODE) (LOGAND CHARCODE 255))) ) (DECLARE%: EVAL@COMPILE (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)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \NATOMCHARS DMACRO ((AT) (fetch (LITATOM PNAMELENGTH) of AT))) (PUTPROPS \NSTRINGCHARS DMACRO ((S) (fetch (STRINGP LENGTH) of S))) ) (* "END EXPORTED DEFINITIONS") ) (/SETTOPVAL '\\NUMSTR.GLOBALRESOURCE NIL) (/SETTOPVAL '\\NUMSTR1.GLOBALRESOURCE NIL) (/SETTOPVAL '\\PNAMESTRING.GLOBALRESOURCE NIL) (MOVD? 'CHARACTER 'FCHARACTER NIL T) (DEFINEQ (%%COPY-ONED-ARRAY +(LAMBDA (LOCAL-ARRAY) (* jop%: "24-Sep-86 17:51") (PROG ((SIZE (LOCAL (ffetch (ONED-ARRAY TOTAL-SIZE) of LOCAL-ARRAY))) (BASE (LOCAL (ffetch (ONED-ARRAY BASE) of LOCAL-ARRAY))) (OFFSET (LOCAL (ffetch (ONED-ARRAY OFFSET) of LOCAL-ARRAY))) (TYPENUMBER (LOCAL (ffetch (ONED-ARRAY TYPE-NUMBER) of LOCAL-ARRAY))) NCELLS REMOTE-ARRAY REMOTE-BASE) (if (NEQ OFFSET 0) then (ERROR "Can't copy an array with non-zero offset")) (if (EQ (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER) PTRBLOCK.GCT) then (ERROR "Can't copy pointer arrays")) (SETQ NCELLS (FOLDHI (ITIMES (IPLUS SIZE OFFSET) (%%TYPENUMBER-TO-BITS-PER-ELEMENT TYPENUMBER)) BITSPERCELL)) (SETQ REMOTE-ARRAY (create ONED-ARRAY BASE _ (\ALLOCBLOCK NCELLS) STRING-P _ (%%CHAR-TYPE-P TYPENUMBER) FILL-POINTER-P _ (LOCAL (ffetch (ONED-ARRAY FILL-POINTER-P) of LOCAL-ARRAY)) TYPE-NUMBER _ TYPENUMBER FILL-POINTER _ (LOCAL (ffetch (ONED-ARRAY FILL-POINTER) of LOCAL-ARRAY)) TOTAL-SIZE _ SIZE)) (SETQ REMOTE-BASE (ffetch (ONED-ARRAY BASE) of REMOTE-ARRAY)) (for I from 0 to (SUB1 (LLSH NCELLS 1)) do (\PUTBASE REMOTE-BASE I (LOCAL (\GETBASE BASE I)))) (RETURN REMOTE-ARRAY))) +) (%%COPY-STRING-TO-ARRAY +(LAMBDA (LOCAL-STRING) (* jop%: "24-Sep-86 17:51") (* ;;; "Only handles thin strings") (PROG ((SIZE (LOCAL (NCHARS LOCAL-STRING))) REMOTE-BASE REMOTE-ARRAY) (SETQ REMOTE-BASE (\ALLOCBLOCK (FOLDHI (ITIMES SIZE 8) BITSPERCELL))) (SETQ REMOTE-ARRAY (create ONED-ARRAY BASE _ REMOTE-BASE STRING-P _ T TYPE-NUMBER _ %%THIN-CHAR-TYPENUMBER FILL-POINTER _ SIZE TOTAL-SIZE _ SIZE)) (for I from 0 to (SUB1 SIZE) do (\PUTBASEBYTE REMOTE-BASE I (LOCAL (NTHCHARCODE LOCAL-STRING (ADD1 I))))) (RETURN REMOTE-ARRAY))) +) ) (* ; "For MAKEINIT") (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (FNS ALLOCSTRING %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY)) (ADDTOVAR INEWCOMS (FILES (SYSLOAD FROM VALUEOF DIRECTORIES) CMLARRAY-SUPPORT)) (ADDTOVAR EXPANDMACROFNS \PUTBASETHIN \PUTBASEFAT \CHARCODEP \GETBASECHAR \GETBASETHIN \GETBASEFAT \PUTBASECHAR) (ADDTOVAR DONTCOMPILEFNS %%COPY-ONED-ARRAY %%COPY-STRING-TO-ARRAY) ) (DECLARE%: DONTCOPY EVAL@COMPILE (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (* ;; "Arrange for the proper compiler") (PUTPROPS LLCHAR FILETYPE :FAKE-COMPILE-FILE) (PUTPROPS LLCHAR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1994 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4114 46325 (ALLOCSTRING 4124 . 5196) (MKATOM 5198 . 5544) (SUBATOM 5546 . 6518) ( CHARACTER 6520 . 7132) (\PARSE.NUMBER 7134 . 13696) (\INVALID.DOTTED.SYMBOL 13698 . 14129) ( \INVALID.INTEGER 14131 . 14906) (\MKINTEGER 14908 . 17475) (MKSTRING 17477 . 18549) ( \PRINDATUM.TO.STRING 18551 . 21148) (BKSYSBUF 21150 . 21885) (NCHARS 21887 . 22721) (NTHCHARCODE 22723 . 23755) (RPLCHARCODE 23757 . 24312) (\RPLCHARCODE 24314 . 25266) (NTHCHAR 25268 . 25407) (RPLSTRING 25409 . 27103) (SUBSTRING 27105 . 28486) (GNC 28488 . 28594) (GNCCODE 28596 . 29011) (GLC 29013 . 29119) (GLCCODE 29121 . 29562) (STREQUAL 29564 . 31678) (STRING.EQUAL 31680 . 35738) (STRINGP 35740 . 35831) (CHCON1 35833 . 36305) (U-CASE 36307 . 39530) (L-CASE 39532 . 43388) (U-CASEP 43390 . 43708) ( \SMASHABLESTRING 43710 . 44038) (\MAKEWRITABLESTRING 44040 . 44388) (\SMASHSTRING 44390 . 46229) ( \FATTENSTRING 46231 . 46323)) (46510 50025 (\GETBASESTRING 46520 . 47023) (\PUTBASESTRING 47025 . 48829) (\PUTBASESTRINGFAT 48831 . 49370) (GetBcplString 49372 . 49809) (SetBcplString 49811 . 50023)) (75312 76991 (%%COPY-ONED-ARRAY 75322 . 76454) (%%COPY-STRING-TO-ARRAY 76456 . 76989))))) STOP \ No newline at end of file diff --git a/sources/LLCODE b/sources/LLCODE new file mode 100644 index 00000000..478d4a63 --- /dev/null +++ b/sources/LLCODE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:45:33" {DSK}lde>lispcore>sources>LLCODE.;2 63025 changes to%: (RECORDS COMPILED-CLOSURE CODEARRAY OPCODE UFNENTRY) previous date%: " 5-Jan-93 00:05:55" {DSK}lde>lispcore>sources>LLCODE.;1) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLCODECOMS) (RPAQQ LLCODECOMS [ (* ;; "THIS FILE IS DUPLICATED on Sources> and Sources>2-byte>, with the latter being the old 2-byte-atom version. IF YOU CHANGE THIS ONE, CHANGE THE OTHER ONE!") [COMS (* ; "reading in compiled code") (FNS DCODERD DCODESKIP \ALLOC.CODE.BLOCK \REALNAMEP \RENAMEDFN) (DECLARE%: DONTEVAL@LOAD DOCOPY [VARS (CODERDTBL (COPYREADTABLE 'ORIG] (P (SETSYNTAX 25 '[MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL] CODERDTBL) (SETSYNTAX 124 '(MACRO ALWAYS READVBAR) CODERDTBL) (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL))) (GLOBALVARS CODERDTBL FILERDTBL) (COMS (* ;; "CODEINDICATOR is the token the compiler puts out in front of compiled definitions. To switch to an incompatible compiled code version, choose a new value for CODEINDICATOR. If old compiled code is still loadable in the new system, retain the CODEREADER prop for an indicators that are still loadable.") (* ;; "CODEINDICATOR changed to :D6 4/6/90 by JDS for Medley 1.15, because of additional opcodes emitted by compiler.") (* ;; "CODEINDICATOR changed to :D7 by JDS 3/4/91 for Medley 1.3, because of 3-byte atoms. Old CODEREADER properties removed at the same time.") (* ;; "Changed to :D8 by JDS 11/12/92 for Medley 2.1/3.0 because of 4-byte pointers/4-byte atoms. Old CODEREADER property removed as well, since old code is not readable.") (VARS (CODEINDICATOR ':D8)) (GLOBALVARS CODEINDICATOR) (PROP CODEREADER * (LIST CODEINDICATOR] [COMS (* ; "Compiled CLOSURE type") (FNS MAKE-COMPILED-CLOSURE \CCLOSURE.DEFPRINT \GET-COMPILED-DEFINITION \GET-COMPILED-CODE-BASE EQDEFP) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS COMPILED-CLOSURE) (CONSTANTS \COMPILED-CLOSURE) (MACROS \EXTENDED.EQP))) (INITRECORDS COMPILED-CLOSURE) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'COMPILED-CLOSURE '\CCLOSURE.DEFPRINT] [COMS (* ; "utilities") (FNS \FINDOP OP#) (* ;;  "List of opcodes known to the system. Used to drive the compilers and build the UFN table.") (* ;; "Format of an entry: (op# name #-extra-bytes ?? stack-effect ") (VARS \OPCODES) (ADDVARS (\OPCODEARRAY)) (GLOBALVARS \OPCODEARRAY \OPCODES) (DECLARE%: EVAL@COMPILE DONTCOPY (FNS WORDSPERNAMEENTRY) (EXPORT (MACROS DPUTCODE MCODEP) (MACROS CODELT CODELT2 CODESETA2 CODESETA) (MACROS BYTESPERNAMEENTRY BYTESPERNTOFFSETENTRY GETNAMEENTRY GETNTFLAGS GETNTOFFSET GETNTOFFSETENTRY GETNTTAG SETNAMEENTRY WORDSPERNTOFFSETENTRY NTSLOT-OFFSET) (FUNCTIONS NEW-SYMBOL-CODE) (OPTIMIZERS BIG-VMEM-CODE SETSTKNAMEENTRY SETSTKNTOFFSETENTRY GETSTKNAMEENTRY GETSTKNTOFFSETENTRY WORDSPERNAMEENTRY SETSTKNTOFFSET SETSTKNAME-RAW SETSTKNTOFFSET-RAW NEW-SYMBOL-CODE MAKE-NTENTRY NULL-NTENTRY) (OPTIMIZERS NTSLOT-VARTYPE) (RECORDS CODEARRAY) (RECORDS OPCODE) (GLOBALVARS \OPCODES) (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK) (CONSTANTS \NT.IVARCODE \NT.PVARCODE \NT.FVARCODE] [COMS (* ; "ufns") (FNS INITUFNTABLE \SETUFNENTRY \GETUFNENTRY) (FNS \UNKNOWN.UFN) [DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "To go into the INIT") (* ;; "INITIALIZE THE TARGET ARCHITECTURE.") (INITVARS (COMPILER::*TARGET-ARCHITECTURE* '(:4-BYTE :3-BYTE)) (COMPILER::*HOST-ARCHITECTURE* '(:4-BYTE :3-BYTE] (DECLARE%: DONTCOPY (RECORDS UFNENTRY) (ADDVARS (INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS INITUFNTABLE] [COMS (* ; "for MAKEINIT and READSYS") (DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS DCODERD) [VARS \OPCODES (CODERDTBL (COPYREADTABLE 'ORIG] (P (SETSYNTAX (CHARCODE ^Y) '[MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL] CODERDTBL) (SETSYNTAX (CHARCODE %|) '(MACRO ALWAYS READVBAR) CODERDTBL) (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL))) (MKI.SUBFNS (\CODEARRAY . SCRATCHARRAY) (DPUTCODE . I.PUTDEFN) (CODERDTBL . I.CODERDTBL) (SETSTKNTOFFSET . I.SETSTKNTOFFSET) (WORDSPERNAMEENTRY . I.WORDSPERNAMEENTRY)) (EXPANDMACROFNS CODELT CODELT2 CODESETA CODESETA2 DPUTCODE MCODEP BYTESPERNAMEENTRY BYTESPERNTOFFSETENTRY WORDSPERNAMEENTRY) (RD.SUBFNS (CODELT . VGETBASEBYTE) (CODESETA . VPUTBASEBYTE)) (RDCOMS (FNS \GET-COMPILED-CODE-BASE] (PROP FILETYPE LLCODE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA OP#) (NLAML) (LAMA]) (* ;; "THIS FILE IS DUPLICATED on Sources> and Sources>2-byte>, with the latter being the old 2-byte-atom version. IF YOU CHANGE THIS ONE, CHANGE THE OTHER ONE!" ) (* ; "reading in compiled code") (DEFINEQ (DCODERD [LAMBDA (FN) (* ; "Edited 28-Jan-91 15:45 by jds") (* ;; "Read a function definition from an LCOM file.") (* ;; "Much of this code is duplicated in DASSEM.DSTOREFNDEF (in file DLAP). Any changes to the codeblock format or this function's behavior should be mirrored there.") (READC) (LET ((INSTREAM (GETSTREAM NIL 'INPUT)) (*READTABLE* (if (EQ *READTABLE* FILERDTBL) then (* ;  "old style file, read code with different read table!") CODERDTBL else (* ; "read code in same readtable") *READTABLE*))) (PROG ((NAMETABLE (PROG1 (READ) (READC))) (CODELEN (IPLUS (LLSH (\BIN INSTREAM) 8) (\BIN INSTREAM))) (NLOCALS (\BIN INSTREAM)) (NFREEVARS (\BIN INSTREAM)) (ARGTYPE (\BIN INSTREAM)) (NARGS (\BIN INSTREAM)) (NTSIZE 0) (FRAMENAME FN) REALSIZE STARTPC NTWORDS CA FVAROFFSET LOCALARGS STARTLOCALS LOCALSIZE) [COND ((EQ (CAR NAMETABLE) 'NAME) (SETQ FRAMENAME (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE] [COND ((EQ (CAR NAMETABLE) 'L) (SETQ LOCALARGS (CADR NAMETABLE)) (SETQ NAMETABLE (CDDR NAMETABLE] [COND (NAMETABLE (* ;  "NAMETABLE now is a sequence of flat triples, one per name to be stored in nametable") (on NAMETABLE by CDDDR do (add NTSIZE 1)) (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NTSIZE (CONSTANT (WORDSPERNAMEENTRY] WORDSPERQUAD] [SETQ NTWORDS (COND (NAMETABLE (IPLUS NTSIZE NTSIZE)) (T (CONSTANT WORDSPERQUAD] (* ;; "NameTable must end in quadword which ends in 0; thus, round down and add a quad. NTWORDS is the number of words allocated for nametable") (SETQ STARTPC (UNFOLD (IPLUS (fetch (CODEARRAY OVERHEADWORDS) of T) NTWORDS) BYTESPERWORD)) (* ;  "initial pc for the function: after fixed header and double nametable") [COND (LOCALARGS (SETQ STARTLOCALS STARTPC) (* ;  "Insert an extra nametable between the real one and the start pc where we store localvar args") (SETQ LOCALSIZE (CEIL [ADD1 (UNFOLD (FOLDLO (FLENGTH LOCALARGS) 2) (CONSTANT (WORDSPERNAMEENTRY] (IQUOTIENT WORDSPERQUAD 2))) (* ;  "Number of words in half this nametable: must end in zero, when doubled is quad-aligned") (SETQ LOCALSIZE (UNFOLD LOCALSIZE BYTESPERWORD)) (* ; "size in bytes now") (add STARTPC (UNFOLD LOCALSIZE 2] (SETQ REALSIZE (CEIL (IPLUS STARTPC CODELEN) BYTESPERQUAD)) (SETQ CA (\CODEARRAY REALSIZE (CEIL (ADD1 (FOLDHI STARTPC BYTESPERCELL)) CELLSPERQUAD))) (AIN CA STARTPC CODELEN INSTREAM) (* ;; "Now build the name table, which has two parallel parts: the names, and where to find them on the stack") (for X on NAMETABLE by (CDDDR X) as NT1 from (IPLUS (SUB1 (BYTESPERNAMEENTRY)) (UNFOLD (fetch (CODEARRAY OVERHEADWORDS) of T) BYTESPERWORD)) by (BYTESPERNAMEENTRY) bind (NTBYTESIZE _ (UNFOLD NTSIZE BYTESPERWORD)) do (\FIXCODESYM CA NT1 (CADDR X) -1) (* ;  "Insert the name into first half of table") (SETSTKNTOFFSET CA (IPLUS NT1 NTBYTESIZE) (SELECTQ (CAR X) (P (CONSTANT (LLSH \NT.PVARCODE 14))) (F [OR FVAROFFSET (SETQ FVAROFFSET (UNFOLD (FOLDLO NT1 (CONSTANT ( BYTESPERNAMEENTRY ))) (CONSTANT (  WORDSPERNAMEENTRY ] (* ;  "Save word offset of first FVAR in nametable, so ucode can easily access FVAR n") (CONSTANT (LLSH \NT.FVARCODE 14))) (I (CONSTANT (LLSH \NT.IVARCODE 14))) (SHOULDNT)) (CADR X)) (* ;  "Code type and index into second half") ) [COND (LOCALARGS (* ;  "Build invisible name table for locals") (for X on LOCALARGS by (CDDR X) as NT from (IPLUS (SUB1 (BYTESPERNAMEENTRY)) STARTLOCALS) by (CONSTANT (BYTESPERNAMEENTRY)) do (\FIXCODESYM CA NT (CADR X) -1) (* ; "Name in first half") (SETSTKNTOFFSET CA (IPLUS NT LOCALSIZE) (CONSTANT (LLSH \NT.IVARCODE 14)) (CAR X)) (* ; "index in second half")] (PROGN (* ; "Fill in function header") (replace (CODEARRAY NA) of CA with (COND ((EQ ARGTYPE 2) -1) (T NARGS))) (replace (CODEARRAY PV) of CA with (SUB1 (FOLDHI (IPLUS NLOCALS NFREEVARS) CELLSPERQUAD))) (replace (CODEARRAY STARTPC) of CA with STARTPC) (replace (CODEARRAY ARGTYPE) of CA with ARGTYPE) (replace (CODEARRAY FRAMENAME) of CA with FRAMENAME) (replace (CODEARRAY NTSIZE) of CA with NTSIZE) (replace (CODEARRAY NLOCALS) of CA with NLOCALS) (replace (CODEARRAY FVAROFFSET) of CA with (OR FVAROFFSET 0)) (replace (CODEARRAY FIXED) of CA with T)) (* ;; "Now read fixups: 3 lists in plist format of function fixups, symbol fixups and random pointer fixups.") (for X on (READ) by (CDDR X) do (\FIXCODESYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) (for X on (READ) by (CDDR X) do (\FIXCODESYM CA (IPLUS (CAR X) STARTPC) (CADR X) -1)) [for X on (READ) by (CDDR X) do (\FIXCODEPTR CA (IPLUS (CAR X) STARTPC) (EVQ (CADR X] (DPUTCODE FN CA (IPLUS STARTPC CODELEN]) (DCODESKIP [LAMBDA (FN FLG) (* bvm%: " 2-Oct-86 21:39") (* ;;; "If FLG is true then copy code from input to output, else just skip code on input. For copy case, source and destination read tables must be the same!") (PROG ((INSTREAM (GETSTREAM NIL 'INPUT)) (RDTBL (if (EQ *READTABLE* FILERDTBL) then (* ;  "old style file, read code with different read table!") CODERDTBL else (* ; "read code in same readtable") *READTABLE*)) CODELEN START) (READC INSTREAM) (* ; "Skip EOL after code indicator") [COND (FLG (* ;  "In both cases, scan over the code. When FLG is true, we will copy when done") (SETQ START (GETFILEPTR INSTREAM] (SKREAD INSTREAM) (* ; "Skip localvar args") (READC INSTREAM) (SETQ CODELEN (IPLUS (LLSH (\BIN INSTREAM) 8) (\BIN INSTREAM))) (\BIN INSTREAM) (\BIN INSTREAM) (\BIN INSTREAM) (\BIN INSTREAM) (SETFILEPTR INSTREAM (IPLUS (GETFILEPTR INSTREAM) CODELEN)) (* ; "Skip the code itself") (SKREAD INSTREAM NIL RDTBL) (* ; "Skip 3 lists of fixups") (SKREAD INSTREAM NIL RDTBL) (SKREAD INSTREAM NIL RDTBL) (READC INSTREAM RDTBL) (COND (FLG (* ;  "copy it all to destination. We assume reader environments are the same") (PRIN4 FN) (PRIN3 " ") (PRIN4 CODEINDICATOR) (TERPRI) (COPYBYTES INSTREAM NIL START (GETFILEPTR]) (\ALLOC.CODE.BLOCK [LAMBDA (NBYTES INITONPAGE) (* bvm%: " 8-Jul-86 17:09") (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) CODEBLOCK.GCT INITONPAGE CELLSPERQUAD]) (\REALNAMEP [LAMBDA (X) (* lmm "15-OCT-81 00:16") (AND (NEQ X 'ERRORSET) (NEQ (NTHCHAR X 1) '\]) (\RENAMEDFN [LAMBDA (DEF FN) (* ; "Edited 3-Mar-87 22:32 by bvm:") (* ;; "Used by PUTD when doing movds from one function to another") (LET* [[CODEBASE (fetch (COMPILED-CLOSURE FNHEADER) of (\DTEST DEF 'COMPILED-CLOSURE] (WORDSIZE (UNFOLD (\#BLOCKDATACELLS CODEBASE) WORDSPERCELL)) (NEWCA (\ALLOC.CODE.BLOCK (UNFOLD WORDSIZE BYTESPERWORD) (CEIL (ADD1 (FOLDHI (fetch (FNHEADER STARTPC) of CODEBASE) BYTESPERCELL)) CELLSPERQUAD] (\COPYCODEBLOCK NEWCA CODEBASE WORDSIZE FN) (create COMPILED-CLOSURE using DEF FNHEADER _ NEWCA]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ CODERDTBL (COPYREADTABLE 'ORIG)) (SETSYNTAX 25 '[MACRO (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL] CODERDTBL) (SETSYNTAX 124 '(MACRO ALWAYS READVBAR) CODERDTBL) (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CODERDTBL FILERDTBL) ) (* ;; "CODEINDICATOR is the token the compiler puts out in front of compiled definitions. To switch to an incompatible compiled code version, choose a new value for CODEINDICATOR. If old compiled code is still loadable in the new system, retain the CODEREADER prop for an indicators that are still loadable." ) (* ;; "CODEINDICATOR changed to :D6 4/6/90 by JDS for Medley 1.15, because of additional opcodes emitted by compiler." ) (* ;; "CODEINDICATOR changed to :D7 by JDS 3/4/91 for Medley 1.3, because of 3-byte atoms. Old CODEREADER properties removed at the same time." ) (* ;; "Changed to :D8 by JDS 11/12/92 for Medley 2.1/3.0 because of 4-byte pointers/4-byte atoms. Old CODEREADER property removed as well, since old code is not readable." ) (RPAQQ CODEINDICATOR :D8) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CODEINDICATOR) ) (PUTPROPS :D8 CODEREADER (DCODERD . DCODESKIP)) (* ; "Compiled CLOSURE type") (DEFINEQ (MAKE-COMPILED-CLOSURE [LAMBDA (CODEBASE ENVIRONMENT) (* bvm%: " 7-Jul-86 11:32") (create COMPILED-CLOSURE FNHEADER _ CODEBASE ENVIRONMENT _ ENVIRONMENT]) (\CCLOSURE.DEFPRINT [LAMBDA (CLOSURE STREAM) (* bvm%: " 7-Jul-86 15:50") (* ;;; "Print closure object as, for example, #") (LET [(NAME (fetch (COMPILED-CLOSURE FRAMENAME) of CLOSURE)) (TYPE (COND ((fetch (COMPILED-CLOSURE ENVIRONMENT) of CLOSURE) "Closure") (T "Function"] (.SPACECHECK. STREAM (IPLUS (CONSTANT (NCHARS "")) (PROGN (* ;  "Longest stack address is 177,177777") 10) (COND ((OR (LITATOM NAME) (STRINGP NAME)) (NCHARS NAME (LITATOM NAME))) (T (SETQ NAME) 0)) 1)) (\OUTCHAR STREAM (fetch (READTABLEP HASHMACROCHAR) of *READTABLE*)) (\SOUT ")) T]) (\GET-COMPILED-DEFINITION [LAMBDA (X) (* bvm%: "11-Jul-86 16:28") (* ;;; "X is an object denoting a function somehow. If it represents a compiled function, return a CLOSURE object for it") (PROG NIL [COND ((LITATOM X) (COND ((PROG1 (fetch (LITATOM CCODEP) of X) (SETQ X (fetch (LITATOM DEFPOINTER) of X))) (RETURN (MAKE-COMPILED-CLOSURE X] (RETURN (AND (type? COMPILED-CLOSURE X) X]) (\GET-COMPILED-CODE-BASE [LAMBDA (X) (* bvm%: "11-Jul-86 16:26") (* ;;; "X is an object denoting a function somehow. If it represents a compiled function, return its code base") (PROG NIL [COND ((LITATOM X) (COND ((PROG1 (fetch (LITATOM CCODEP) of X) (SETQ X (fetch (LITATOM DEFPOINTER) of X))) (RETURN X] (RETURN (AND (EQ (NTYPX X) \COMPILED-CLOSURE) (fetch (COMPILED-CLOSURE FNHEADER) of X]) (EQDEFP [LAMBDA (CA1 CA2) (* bvm%: " 7-Jul-86 22:36") (* ;;  "determines whether two code arrays CA1 and CA2 are equivalent (same except for framename)") (COND ((AND (TYPEP CA1 'COMPILED-CLOSURE) (TYPEP CA2 'COMPILED-CLOSURE) (EQ (fetch (COMPILED-CLOSURE ENVIRONMENT) of CA1) (fetch (COMPILED-CLOSURE ENVIRONMENT) of CA2))) (SETQ CA1 (fetch (COMPILED-CLOSURE FNHEADER) of CA1)) (SETQ CA2 (fetch (COMPILED-CLOSURE FNHEADER) of CA2)) (for I from 0 to (SUB1 (UNFOLD (IMIN (\#BLOCKDATACELLS CA1) (\#BLOCKDATACELLS CA2)) WORDSPERCELL)) always (OR (EQ (\GETBASE CA1 I) (\GETBASE CA2 I)) [EQ I (INDEXF (fetch (FNHEADER %#FRAMENAME] (EQ I (ADD1 (INDEXF (fetch (FNHEADER %#FRAMENAME]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (DATATYPE COMPILED-CLOSURE (FNHEADER ENVIRONMENT)) ) (/DECLAREDATATYPE 'COMPILED-CLOSURE '(POINTER POINTER) '((COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER)) '4) (DECLARE%: EVAL@COMPILE (RPAQQ \COMPILED-CLOSURE 13) (CONSTANTS \COMPILED-CLOSURE) ) (DECLARE%: EVAL@COMPILE [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] ) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'COMPILED-CLOSURE '(POINTER POINTER) '((COMPILED-CLOSURE 0 POINTER) (COMPILED-CLOSURE 2 POINTER)) '4) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'COMPILED-CLOSURE '\CCLOSURE.DEFPRINT) ) (* ; "utilities") (DEFINEQ (\FINDOP [LAMBDA (OPNAME FLG) (* lmm "22-Mar-85 10:20") (ALLOCAL (PROGN [OR \OPCODEARRAY (PROGN (SETQ \OPCODEARRAY (ARRAY 256 'POINTER NIL 0)) (for X in \OPCODES do (PUTPROP (fetch OPCODENAME of X) 'DOPCODE X) (if (LISTP (fetch OP# of X)) then (for I from (CAR (fetch OP# of X)) to (CADR (fetch OP# of X)) by 1 do (SETA \OPCODEARRAY I X)) else (SETA \OPCODEARRAY (fetch OP# of X) X] (OR (COND ((LITATOM OPNAME) (GETPROP OPNAME 'DOPCODE)) ((FIXP OPNAME) (ELT \OPCODEARRAY OPNAME))) (AND FLG (ERROR OPNAME FLG]) (OP# [NLAMBDA X (* lmm "12-FEB-82 23:50") (CAR (\FINDOP (CAR X]) ) (* ;; "List of opcodes known to the system. Used to drive the compilers and build the UFN table.") (* ;; "Format of an entry: (op# name #-extra-bytes ?? stack-effect ") (RPAQQ \OPCODES ((0 -X- 0) (1 CAR 0 T 0 \CAR.UFN) (2 CDR 0 T 0 \CDR.UFN) (3 LISTP 0 T 0 LISTP) (4 NTYPX 0 T 0 NTYPX) (5 TYPEP 1 TYPEP 0 \TYPEP.UFN) (6 DTEST 4 ATOM 0 \DTEST.UFN) (7 UNWIND 2 T (UNWIND 1) \UNWIND.UFN) (8 FN0 4 FN 1) (9 FN1 4 FN 0) (10 FN2 4 FN -1) (11 FN3 4 FN -2) (12 FN4 4 FN -3) (13 FNX 5 FNX FNX) (14 APPLYFN 0 T -1) (15 CHECKAPPLY* 0 T 0 \CHECKAPPLY* (4K 12K)) (16 RETURN 0 T (JUMP 1) \HARDRETURN) (17 BIND 2) (18 UNBIND 0) (19 DUNBIND 0) (20 RPLPTR.N 1 T -1 \RPLPTR.UFN (4K)) (21 GCREF 1 T 0 \HTFIND) (22 ASSOC 0 T -1 ASSOC (4K DORADO)) (23 GVAR_ 4 ATOM 0 \SETGLOBALVAL.UFN) (24 RPLACA 0 T -1 \RPLACA.UFN 4K) (25 RPLACD 0 T -1 \RPLACD.UFN 4K) (26 CONS 0 T -1 \CONS.UFN) (27 CMLASSOC 0 T -1 CL::%%SIMPLE-ASSOC (4K DORADO)) (28 FMEMB 0 T -1 FMEMB (4K DORADO)) (29 CMLMEMBER 0 T -1 CL::%%SIMPLE-MEMBER (4K DORADO)) (30 FINDKEY 1 T 0 \FINDKEY.UFN) (31 CREATECELL 0 T 0 \CREATECELL 4K) (32 BIN 0 T 0 \BIN 4K) (33 BOUT 0 T -1 \BOUT (4K DORADO)) (34 POPDISP 0 T 0 \POPDISP.UFN (4K DORADO)) (35 RESTLIST 1 T -1 \RESTLIST.UFN) (36 MISCN 2 T 1 \MISCN.UFN (DORADO DLION DBREAK)) (37 unused) (38 RPLCONS 0 T -1 \RPLCONS (4K DORADO)) (39 LISTGET 0 T -1 LISTGET (4K DORADO)) (40 unused) (41 unused) (42 unused) (43 unused) (44 EVAL 0 T 0 \EVAL) (45 ENVCALL 0 T (JUMP 0) \ENVCALL.UFN) (46 TYPECHECK 0 T 0 \TYPECHECK.UFN) (47 STKSCAN 0 T 0 \STKSCAN) (48 BUSBLT 1 (WORDSOUT BYTESOUT BYTESOUTSWAPPED NYBBLESOUT WORDSIN BYTESIN BYTESINSWAPPED NYBBLESINSWAPPED) -3 \BUSBLT.UFN (4K DORADO)) (49 MISC8 1 (IBLT1 IBLT2) -7 \MISC8.UFN (4K DORADO)) (50 UBFLOAT3 1 (POLY MATRIX.3X3 MATRIX.4X4 MATRIX.133 MATRIX.331 MATRIX.144 MATRIX.441 UBASET1) (-2 1) \UNBOXFLOAT3 (4K DORADO)) (51 TYPEMASK.N 1 T 0 \TYPEMASK.UFN) (52 RDPROLOGPTR 0 T 0 RAID (4K DORADO)) (53 RDPROLOGTAG 0 T 0 RAID (4K DORADO)) (54 WRTPTR&TAG 0 T -2 RAID (4K DORADO)) (55 WRTPTR&0TAG 0 T -1 RAID (4K DORADO)) (56 MISC7 1 (PSEUDOCOLOR \FASTBITMAPBIT) -6 \MISC7.UFN (4K DORADO)) (57 DOVEMISC 1 (READIW WRITEIO WRITEMP RDTIMER BYTESWAP LOCKMEM NOTIFYIOP SETWP) (0 -1 0 0 0 -3 0 0)) (58 EQL 0 T -1 EQL) (59 DRAWLINE 0 T -8 \DRAWLINE.UFN (4K DORADO)) (60 STORE.N 1 T 0 \STORE.N.UFN) (61 COPY.N 1 T 1 \COPY.N.UFN) (62 RAID 0 T 0 RAID T) (63 \RETURN 0 T 0 \RETURN) ((64 70) IVAR 0 IVAR 1) (71 IVARX 1 IVAR 1) ((72 78) PVAR 0 PVAR 1) (79 PVARX 1 PVAR 1) ((80 86) FVAR 0 FVAR 1) (87 FVARX 1 FVAR 1) ((88 94) PVAR_ 0 PVAR 0) (95 PVARX_ 1 PVAR 0) (96 GVAR 4 ATOM 1) (97 ARG0 0 T 0 \ARG0 T) (98 IVARX_ 1 IVAR 0) (99 FVARX_ 1 FVAR 0) (100 COPY 0 T 1) (101 MYARGCOUNT 0 T 1 \MYARGCOUNT T) (102 MYALINK 0 T 1) (103 ACONST 4 ATOM 1) (104 %'NIL 0 T 1) (105 %'T 0 T 1) (106 %'0 0 T 1) (107 %'1 0 T 1) (108 SIC 1 SIC 1) (109 SNIC 1 SNIC 1) (110 SICX 2 SICX 1) (111 GCONST 4 GCONST 1) (112 unused) (113 READFLAGS 0 T 0 \READFLAGS) (114 READRP 0 T 0 \READRP) (115 WRITEMAP 0 T -2 \WRITEMAP DORADO) (116 READPRINTERPORT 0 T 1 \READPRINTERPORT.UFN 4K) (117 WRITEPRINTERPORT 0 T 0 \WRITEPRINTERPORT.UFN 4K) (118 PILOTBITBLT 0 T -1 \PILOTBITBLT) (119 RCLK 0 T 0 \RCLKSUBR) (120 MISC1 1 (error INPUT OUTPUT error error error error error error RWMUFMAN) 0 \MISC1.UFN) (121 MISC2 1 (?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?10) -1 \MISC2.UFN) (122 RECLAIMCELL 0 T 0 \GCRECLAIMCELL DORADO) (123 GCSCAN1 0 T 0 \GCSCAN1) (124 GCSCAN2 0 T 0 \GCSCAN2) (125 SUBRCALL 2 SUBRCALL) (126 CONTEXTSWITCH 0 T 0 \CONTEXTSWITCH) (127 RETCALL 4 FNX (JUMP 1) \RETCALL) ((128 143) JUMP 0 JUMP JUMP NIL) ((144 159) FJUMP 0 JUMP CJUMP NIL) ((160 175) TJUMP 0 JUMP CJUMP NIL) (176 JUMPX 1 JUMPX JUMP) (177 JUMPXX 2 JUMPXX JUMP) (178 FJUMPX 1 JUMPX CJUMP) (179 TJUMPX 1 JUMPX CJUMP) (180 NFJUMPX 1 JUMPX NCJUMP) (181 NTJUMPX 1 JUMPX NCJUMP) (182 AREF1 0 T -1 %%AREF1 (4K DORADO)) (183 ASET1 0 T -2 %%ASET1 (4K DORADO)) ((184 190) PVAR_^ 0 PVAR -1 NIL) (191 POP 0 T -1) (192 POP.N 1 T (POP.N 1) \POP.N.UFN) (193 ATOMCELL.N 1 T 0 \ATOMCELL) (194 GETBASEBYTE 0 T -1 \GETBASEBYTE) (195 INSTANCEP 4 ATOM 0 \INSTANCEP.UFN NIL) (196 BLT 0 T -2 \BLT) (197 MISC10 1 T -9 \MISC10.UFN (4K DORADO)) (198 P-MISC2 1 (GET-NEXT-RUN) -1 \P-MISC2.UFN) (199 PUTBASEBYTE 0 T -2 \PUTBASEBYTE) (200 GETBASE.N 1 T 0) (201 GETBASEPTR.N 1 T 0) (202 GETBITS.N.FD 2 T 0) (203 unused) (204 CMLEQUAL 0 T -1 CL:EQUAL (4K 12K DORADO)) (205 PUTBASE.N 1 T -1 \PUTBASE.UFN) (206 PUTBASEPTR.N 1 T -1 \PUTBASEPTR.UFN) (207 PUTBITS.N.FD 2 T -1 \PUTBITS.UFN) (208 ADDBASE 0 T -1 \ADDBASE) (209 VAG2 0 T -1 \VAG2) (210 HILOC 0 T 0) (211 LOLOC 0 T 0) (212 PLUS2 0 T -1 \SLOWPLUS2 *) (213 DIFFERENCE 0 T -1 \SLOWDIFFERENCE *) (214 TIMES2 0 T -1 \SLOWTIMES2 *) (215 QUOTIENT 0 T -1 \SLOWQUOTIENT *) (216 IPLUS2 0 T -1 \SLOWIPLUS2) (217 IDIFFERENCE 0 T -1 \SLOWIDIFFERENCE) (218 ITIMES2 0 T -1 \SLOWITIMES2) (219 IQUOTIENT 0 T -1 \SLOWIQUOTIENT) (220 IREMAINDER 0 T -1 IREMAINDER) (221 IPLUS.N 1 T 0 \SLOWIPLUS2 (4K 12K)) (222 IDIFFERENCE.N 1 T 0 \SLOWIDIFFERENCE (4K 12K)) (223 BASE-< 0 T -1 \BASE-<.UFN (4K 12K DORADO)) (224 LLSH1 0 T 0 \SLOWLLSH1) (225 LLSH8 0 T 0 \SLOWLLSH8) (226 LRSH1 0 T 0 \SLOWLRSH1) (227 LRSH8 0 T 0 \SLOWLRSH8) (228 LOGOR2 0 T -1 \SLOWLOGOR2) (229 LOGAND2 0 T -1 \SLOWLOGAND2) (230 LOGXOR2 0 T -1 \SLOWLOGXOR2) (231 LSH 0 T -1 LSH T) (232 FPLUS2 0 T -1 \SLOWFPLUS2 4K) (233 FDIFFERENCE 0 T -1 \SLOWFDIFFERENCE 4K) (234 FTIMES2 0 T -1 \SLOWFTIMES2 4K) (235 FQUOTIENT 0 T -1 \SLOWFQUOTIENT 4K) (236 UBFLOAT2 1 (UFADD UFSUB UFISUB UFMULT UFDIV UFGREAT UFMAX UFMIN UFREM UBAREF1) (-1 1) \UNBOXFLOAT2 (4K DORADO)) (237 UBFLOAT1 1 (BOX UNBOX UFABS UFNEGATE UFIX) (0 1) \UNBOXFLOAT1 (4K DORADO)) (238 AREF2 0 T -2 %%AREF2 (4K DORADO)) (239 ASET2 0 T -3 %%ASET2 (4K DORADO)) (240 EQ 0 T -1) (241 IGREATERP 0 T -1 \SLOWIGREATERP) (242 FGREATERP 0 T -1 \SLOWFGREATERP) (243 GREATERP 0 T -1 GREATERP) (244 EQUAL 0 T -1 EQUAL) (245 MAKENUMBER 0 T -1 \MAKENUMBER 4K) (246 BOXIPLUS 0 T -1 \BOXIPLUS 4K) (247 BOXIDIFFERENCE 0 T -1 \BOXIDIFFERENCE 4K) (248 FLOATBLT 1 (FLOATWRAP FLOATUNWRAP FLOAT FIX FPLUS FDIFFERENCE FDIFFERENCE FPLUSABS ABSDIFFERENCE ABSFPLUS FTIMES) -3 \FLOATBLT (4K DORADO)) (249 FFTSTEP 0 T -1 \FFTSTEP (4K DORADO)) (250 MISC3 1 (EXPONENT MAGNITUDE FLOAT COMP BLKFMAX BLKFMIN BLKFABSMAX BLKFABSMIN FLOATTOBYTE ARRAYREAD LINES-EQUAL-P) -2 \MISC3.UFN (4K DORADO)) (251 MISC4 1 (ARRAY.TIMES ARRAY.PERM ARRAY.PLUS ARRAY.DIFFERENCE ARRAY.MAGIC 3MATCH BMBIT ARRAYWRITE) -3 \MISC4.UFN) (252 UPCTRACE 0 T 0 NILL (4K 12K)) (253 SWAP 0 T 0) (254 NOP 0 T 0) (255 = 0 T -1 CL::%%= (4K DORADO)))) (ADDTOVAR \OPCODEARRAY ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \OPCODEARRAY \OPCODES) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DEFINEQ (WORDSPERNAMEENTRY [LAMBDA NIL (* ; "Edited 25-Jan-91 00:00 by jds") (* ;; "Run-time equivalent of the optimizer; this must match it in result (but use COMPILER::*TARGET-ARCHITECTURE* here where you'd use (COMPILER::ENV-TARGET-ARCHITECTURE ENV) there).") (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) 2) ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*)) 2) (T 1]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE [PUTPROPS DPUTCODE MACRO ((FN CA SIZE) (SELECTQ (SYSTEMTYPE) (D (DEFC FN CA)) (/PUTPROP FN 'DCODE CA] [PUTPROPS MCODEP MACRO ((X) (OR (ARRAYP X) (AND (LITATOM X) (ARRAYP (SELECTQ (SYSTEMTYPE) (D (GETD X)) (GETPROP X 'DCODE] ) (DECLARE%: EVAL@COMPILE (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))) ) (DECLARE%: EVAL@COMPILE (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") `,NEW-SYMBOL-FORM) (T `,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)) `,NEW-SYMBOL-FORM) (T `,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)) `(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 `(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)) `(\PUTBASEFIXP ,BASE ,OFFSET ,VAL] (T `(\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)) `(\GETBASEPTR ,BASE ,OFFSET] (T `(\GETBASE ,BASE ,OFFSET]) (DEFOPTIMIZER GETSTKNTOFFSETENTRY (BASE OFFSET &ENVIRONMENT ENV) [COND [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(\GETBASEFIXP ,BASE ,OFFSET] (T `(\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)) `(PROGN 2)) ((AND CROSSCOMPILING (FMEMB :3-BYTE-INIT ( COMPILER::ENV-TARGET-ARCHITECTURE ENV))) `(PROGN 2)) (T `(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)) `(PROGN (\FIXCODENUM ,BASE (IDIFFERENCE ,OFFSET BYTESPERWORD) ,TYPE) (\FIXCODENUM ,BASE ,OFFSET ,VAL] (T `(\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)) `(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 `(\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)) `(PROGN (\PUTBASE ,BASE ,OFFSET ,TYPE) (\PUTBASE ,BASE (IPLUS ,OFFSET 1) ,VAL] (T `(\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)) `,NEW-SYMBOL-FORM) (T `,OLD-SYMBOL-FORM]) (DEFOPTIMIZER MAKE-NTENTRY (TYPE OFFSET &ENVIRONMENT ENV) [COND [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `(IPLUS (CONSTANT (LLSH ,TYPE 16)) ,OFFSET] (T `(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)) `(NULL ,VALUE] (T `(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)) `(LOGAND 49153 (LRSH ,X 16] (T `(LOGAND ,X 49152]) (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (RECORD OPCODE (OP# OPCODENAME OPNARGS OPPRINT LEVADJ UFNFN UNIMPL)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \OPCODES) ) (DECLARE%: EVAL@COMPILE (RPAQQ PVARCODE 32768) (RPAQQ FVARCODE 49152) (RPAQQ IVARCODE 0) (RPAQQ VARCODEMASK 49152) (CONSTANTS PVARCODE FVARCODE IVARCODE VARCODEMASK) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NT.IVARCODE 0) (RPAQQ \NT.PVARCODE 2) (RPAQQ \NT.FVARCODE 3) (CONSTANTS \NT.IVARCODE \NT.PVARCODE \NT.FVARCODE) ) (* "END EXPORTED DEFINITIONS") ) (* ; "ufns") (DEFINEQ (INITUFNTABLE [LAMBDA NIL (* ;  "Edited 19-Nov-92 15:28 by sybalsky:mv:envos") (CREATEPAGES \UFNTable \UFNTableSize NIL T) (for I from 0 to 255 do (\SETUFNENTRY I '\UNKNOWN.UFN 0 0)) (for X in \OPCODES when (fetch (OPCODE UFNFN) of X) do (\SETUFNENTRY (PROG ((OP (fetch (OPCODE OP#) of X))) (RETURN (if (LISTP OP) then (CAR OP) else OP))) (fetch (OPCODE UFNFN) of X) [COND ((LISTP (fetch (OPCODE LEVADJ) of X)) (CADR (fetch (OPCODE LEVADJ) of X))) (T (IDIFFERENCE (IPLUS 1 (COND ((EQ (fetch (OPCODE OPNARGS) of X) 0) 0) (T 1))) (fetch (OPCODE LEVADJ) of X] (SELECTQ (fetch (OPCODE OPNARGS) of X) (0 0) (1 1) (2 2) (3 (* ;; "Changed by JDS from (3 1) 12/26/90 as part of 3-byte-atom change. I dunno why this was (3 1), since there were no UFNing args with 3-byte args???") 3) (4 4) (5 5) (SHOULDNT]) (\SETUFNENTRY [LAMBDA (INDEX FN NARGS NEXTRA) (* lmm " 7-Jun-85 14:08") (SETQ INDEX (\ADDBASE (\ADDBASE \UFNTable INDEX) INDEX)) (change (fetch (UFNENTRY FNINDEX) of INDEX) (\ATOMDEFINDEX FN)) (change (fetch (UFNENTRY NEXTRA) of INDEX) NEXTRA) (change (fetch (UFNENTRY NARGS) of INDEX) NARGS]) (\GETUFNENTRY [LAMBDA (OP) (* hdj "17-Jun-85 13:08") (LET [(INDEX (\ADDBASE2 \UFNTable (if (LITATOM OP) then (fetch (OPCODE OP#) of (\FINDOP OP)) else OP] (\VAG2 0 (fetch (UFNENTRY FNINDEX) of INDEX]) ) (DEFINEQ (\UNKNOWN.UFN [LAMBDA NIL (* bvm%: "23-Mar-84 15:52") (\MP.ERROR \MP.UNKNOWN.UFN "Compiler/microcode error: unknown UFN"]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ? COMPILER::*TARGET-ARCHITECTURE* '(:4-BYTE :3-BYTE)) (RPAQ? COMPILER::*HOST-ARCHITECTURE* '(:4-BYTE :3-BYTE)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD UFNENTRY ( (* ;; "Describes a 32-bit entry in the %"UFN Table%", \UFNTable, which is used to find the function to call when an opcode isn't implemented in microcode.") (FNINDEX WORD) (* ;  " LO 16 bits of the symbol # for the UFN") (NEXTRA BYTE) (* ;  "[Previously unused] HI 8 bits of the UFN symbol number.") (NARGS BYTE) (* ; "# of arguments to the UFN.") )) ) (ADDTOVAR INEWCOMS (FNS INITUFNTABLE \SETUFNENTRY)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS INITUFNTABLE) ) (* ; "for MAKEINIT and READSYS") (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (FNS DCODERD) [VARS \OPCODES (CODERDTBL (COPYREADTABLE 'ORIG] (P (SETSYNTAX (CHARCODE ^Y) '[MACRO (LAMBDA (FILE RDTBL) (EVALFORMAKEINIT (READ FILE RDTBL] CODERDTBL) (SETSYNTAX (CHARCODE %|) '(MACRO ALWAYS READVBAR) CODERDTBL) (READTABLEPROP CODERDTBL 'USESILPACKAGE NIL))) (ADDTOVAR MKI.SUBFNS (\CODEARRAY . SCRATCHARRAY) (DPUTCODE . I.PUTDEFN) (CODERDTBL . I.CODERDTBL) (SETSTKNTOFFSET . I.SETSTKNTOFFSET) (WORDSPERNAMEENTRY . I.WORDSPERNAMEENTRY)) (ADDTOVAR EXPANDMACROFNS CODELT CODELT2 CODESETA CODESETA2 DPUTCODE MCODEP BYTESPERNAMEENTRY BYTESPERNTOFFSETENTRY WORDSPERNAMEENTRY) (ADDTOVAR RD.SUBFNS (CODELT . VGETBASEBYTE) (CODESETA . VPUTBASEBYTE)) (ADDTOVAR RDCOMS (FNS \GET-COMPILED-CODE-BASE)) ) (PUTPROPS LLCODE FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA OP#) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LLCODE COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8002 20957 (DCODERD 8012 . 17562) (DCODESKIP 17564 . 19768) (\ALLOC.CODE.BLOCK 19770 . 19982) (\REALNAMEP 19984 . 20164) (\RENAMEDFN 20166 . 20955)) (22303 26487 (MAKE-COMPILED-CLOSURE 22313 . 22535) (\CCLOSURE.DEFPRINT 22537 . 24162) (\GET-COMPILED-DEFINITION 24164 . 24766) ( \GET-COMPILED-CODE-BASE 24768 . 25407) (EQDEFP 25409 . 26485)) (27830 29261 (\FINDOP 27840 . 29127) ( OP# 29129 . 29259)) (40788 41305 (WORDSPERNAMEENTRY 40798 . 41303)) (57602 60228 (INITUFNTABLE 57612 . 59401) (\SETUFNENTRY 59403 . 59841) (\GETUFNENTRY 59843 . 60226)) (60229 60424 (\UNKNOWN.UFN 60239 . 60422))))) STOP \ No newline at end of file diff --git a/sources/LLCOLOR b/sources/LLCOLOR new file mode 100644 index 00000000..70bea0ea --- /dev/null +++ b/sources/LLCOLOR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP") (FILECREATED "16-Jan-87 17:37:34" {ERIS}LISPCORE>LLCOLOR.;3 132573 changes to%: (FNS \CreateColorScreenBitMap COLORMAPCREATE) previous date%: " 5-Jun-86 23:33:11" {ERIS}LISPCORE>LLCOLOR.;2) (* " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLCOLORCOMS) (RPAQQ LLCOLORCOMS [(FNS COLORDISPLAY COLORMAPBITS \CreateColorScreenBitMap \CREATECOLORDISPLAYFDEV COLORMAP SCREENCOLORMAP SCREENCOLORMAPENTRY ROTATECOLORMAP RGBCOLORMAP CMYCOLORMAP GRAYCOLORMAP COLORSCREENBITMAP \COLORDISPLAYBITS COLORSCREEN SHOWCOLORTESTPATTERN) (INITVARS (COLORMONITORTYPE 'CONRAC)) (FNS \STARTCOLOR \STOPCOLOR \SENDCOLORMAPENTRY) (FNS COLORMAPCREATE COLORLEVEL COLORNUMBERP COLORFROMRGB INTENSITIESFROMCOLORMAP SETCOLORINTENSITY) (FNS \FAST8BIT \MAP4 \MAP8) (FNS \GETCOLORBRUSH) (FNS \DRAWCOLORLINE1 \DRAW4BPPCOLORLINE \DRAW8BPPCOLORLINE \DRAW24BPPCOLORLINE) (DECLARE%: DONTCOPY DOEVAL@COMPILE (MACROS .DRAW4BPPLINEX. .DRAW8BPPLINEX .DRAW24BPPLINEX .DRAW4BPPLINEY. .DRAW8BPPLINEY .DRAW24BPPLINEY)) (FNS \BWTOCOLORBLT \4BITLINEBLT \8BITLINEBLT \24BITLINEBLT \GETBASE24 \PUTBASE24 COLORTEXTUREFROMCOLOR# \BITMAPWORD) (FNS COLORIZEBITMAP UNCOLORIZEBITMAP) (INITVARS (\1COLORMENU NIL) (\4COLORMENU NIL) (\8COLORMENU NIL)) (FNS COLORMENU CURSORCOLOR) (RECORDS RGB HLS) (DECLARE%: DONTCOPY (RECORDS NIBBLES ONEOFFSETBITACCESS TWOOFFSETBITACCESS THREEOFFSETBTACCESS 2BITNIBBLES ODD2BITNIBBLES)) (CONSTANTS (BITSPERWORD 16)) (INITVARS (\COLORDISPLAYFDEV) (\4COLORMAP (CMYCOLORMAP 2 1 1 4)) (\8COLORMAP (CMYCOLORMAP 3 3 2 8)) (\COLORDISPLAYBITS) (ColorScreenBitMap) (\COLORSCREEN)) (FNS PSEUDOCOLOR \PSEUDOCOLOR.BITMAP \PSEUDOCOLOR.UFN) (GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP) (P (* NOTE%: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *) (SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL) (SETQ MENUFONT (FONTCREATE 'HELVETICA 10))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (COLORDISPLAY [LAMBDA (ONOFF TYPE) (* kbr%: " 5-Jun-86 20:53") (* Turn hardware TYPE color display on  or off. *) (PROG (OLDONOFF OLDTYPE DISPLAYSTATE DISPLAYINFO) [COND (\COLORDISPLAYFDEV (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of \COLORDISPLAYFDEV)) (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of \COLORDISPLAYFDEV)) (SETQ OLDONOFF (fetch (DISPLAYSTATE ONOFF) of DISPLAYSTATE)) (SETQ OLDTYPE (fetch (DISPLAYINFO DITYPE) of DISPLAYINFO)) (COND ((NULL TYPE) (SETQ TYPE OLDTYPE] [COND ((EQ ONOFF 'ON) (COND ((EQ OLDONOFF 'ON) (* Color display already on.  *) (COLORDISPLAY 'OFF) (COLORDISPLAY 'ON TYPE)) ((SETQ \COLORDISPLAYFDEV (\CREATECOLORDISPLAYFDEV TYPE)) (* Color display is off, turn it on.  *) (\STARTCOLOR \COLORDISPLAYFDEV))) (SCREENCOLORMAP (SCREENCOLORMAP)) (COND ((OR (NULL \COLORSCREEN) (NOT (EQ TYPE OLDTYPE))) (SETQ \COLORSCREEN (CREATESCREEN (COLORSCREENBITMAP))) (WINDOWWORLD 'ON \COLORSCREEN) (* Besides being a test pattern, SHOWCOLORTESTPATTERN changes a solid field of  color into a striped pattern. Some color cards have trouble holding a solid  field of color without variation steady.  *) (SHOWCOLORTESTPATTERN 10))) (SETQ BACKGROUNDCURSOREXITFN 'CURSOREXIT)) ((EQ ONOFF 'OFF) (COND ((NOT (EQ OLDONOFF 'OFF)) (* Color display is on, turn it off.  *) (SETQ BACKGROUNDCURSOREXITFN NIL) [COND ((NOT (EQ \CURSORSCREEN \MAINSCREEN)) (* Move cursor off \COLORSCREEN.  *) (CURSORSCREEN \MAINSCREEN (IQUOTIENT (fetch (SCREEN SCWIDTH) of \MAINSCREEN) 2) (IQUOTIENT (fetch (SCREEN SCHEIGHT) of \MAINSCREEN) 2] (\STOPCOLOR \COLORDISPLAYFDEV] (RETURN OLDONOFF]) (COLORMAPBITS [LAMBDA (COLORMAP) (* kbr%: " 5-Jun-85 20:47") (INTEGERLENGTH (SUB1 (ARRAYSIZE COLORMAP]) (\CreateColorScreenBitMap [LAMBDA (FDEV) (* ; "Edited 16-Jan-87 17:17 by gbn") (* Creates color display bitmap  ColorScreenBitMap for FDEV) (DECLARE (GLOBALVARS ColorScreenBitMap)) (PROG (DISPLAYINFO WIDTH HEIGHT BITSPERPIXEL) (SETQ DISPLAYINFO (fetch (FDEV WINDOWDATA) of FDEV)) (SETQ WIDTH (fetch (DISPLAYINFO DIWIDTH) of DISPLAYINFO)) (SETQ HEIGHT (fetch (DISPLAYINFO DIHEIGHT) of DISPLAYINFO)) (SETQ BITSPERPIXEL (fetch (DISPLAYINFO DIBITSPERPIXEL) of DISPLAYINFO)) (SETQ ColorScreenBitMap (create BITMAP BITMAPBASE _ (\COLORDISPLAYBITS WIDTH HEIGHT BITSPERPIXEL) BITMAPRASTERWIDTH _ (FOLDHI (ITIMES WIDTH BITSPERPIXEL) BITSPERWORD) BITMAPWIDTH _ WIDTH BITMAPHEIGHT _ HEIGHT BITMAPBITSPERPIXEL _ BITSPERPIXEL)) (RETURN ColorScreenBitMap]) (\CREATECOLORDISPLAYFDEV [LAMBDA (TYPE) (* kbr%: "15-Feb-86 14:48") (PROG (DISPLAYINFO WSOPS) (SETQ DISPLAYINFO (ASSOC TYPE \DISPLAYINFOALIST)) (SETQ WSOPS (fetch (DISPLAYINFO DIWSOPS) of DISPLAYINFO)) (COND ((NULL DISPLAYINFO) (RETURN \COLORDISPLAYFDEV))) [COND ((NULL \COLORDISPLAYFDEV) (SETQ \COLORDISPLAYFDEV (\CREATEDISPLAY 'COLORDISPLAY] (replace (FDEV WINDOWDATA) of \COLORDISPLAYFDEV with DISPLAYINFO) (replace (FDEV EVENTFN) of \COLORDISPLAYFDEV with (fetch (WSOPS EVENTFN) of WSOPS)) (replace (FDEV WINDOWOPS) of \COLORDISPLAYFDEV with WSOPS) (\CreateColorScreenBitMap \COLORDISPLAYFDEV) (RETURN \COLORDISPLAYFDEV]) (COLORMAP [LAMBDA (BITSPERPIXEL NEWCOLORMAP) (* kbr%: "21-Aug-85 21:06") (* Change system colormap to  NEWCOLORMAP returning OLDCOLORMAP *) (PROG (OLDCOLORMAP) (SETQ OLDCOLORMAP (SELECTQ BITSPERPIXEL (4 \4COLORMAP) (8 \8COLORMAP) NIL)) [COND (NEWCOLORMAP (SELECTQ BITSPERPIXEL (4 (SETQ \4COLORMAP NEWCOLORMAP)) (8 (SETQ \8COLORMAP NEWCOLORMAP)) NIL) (COND ((AND \COLORDISPLAYFDEV (EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of \COLORDISPLAYFDEV )) 'ON) (EQ (BITSPERPIXEL (COLORSCREENBITMAP)) BITSPERPIXEL)) (for I from 0 to (SUB1 (ARRAYSIZE NEWCOLORMAP)) do (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV I (ELT NEWCOLORMAP I] (RETURN OLDCOLORMAP]) (SCREENCOLORMAP [LAMBDA (NEWCOLORMAP) (* kbr%: "21-Aug-85 21:12") (COLORMAP (BITSPERPIXEL (COLORSCREENBITMAP)) NEWCOLORMAP]) (SCREENCOLORMAPENTRY [LAMBDA (COLOR RGB) (* kbr%: " 5-Jun-86 19:40") (SETA (SCREENCOLORMAP) COLOR RGB) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB]) (ROTATECOLORMAP [LAMBDA (STARTCOLOR THRUCOLOR) (* kbr%: " 5-Jun-86 23:20") (PROG (COLORMAP RGB) (SETQ COLORMAP (SCREENCOLORMAP)) (COND ((NULL STARTCOLOR) (SETQ STARTCOLOR 0))) [COND ((NULL THRUCOLOR) (SETQ THRUCOLOR (SUB1 (ARRAYSIZE COLORMAP] (SETQ RGB (ELT COLORMAP THRUCOLOR)) (for COLOR from STARTCOLOR to THRUCOLOR do (swap RGB (ELT COLORMAP COLOR)) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR (ELT COLORMAP COLOR]) (RGBCOLORMAP [LAMBDA (REDBITS GREENBITS BLUEBITS BITSPERPIXEL) (* kbr%: "13-Aug-85 16:49") (* creates a color map with the specified number of bits allocated per primary  color. Always has the RED bits on the left.) (PROG (NRED NGREEN NBLUE REDS GREENS BLUES COLORMAP) (SETQ NRED (SUB1 (EXPT 2 REDBITS))) (SETQ NGREEN (SUB1 (EXPT 2 GREENBITS))) (SETQ NBLUE (SUB1 (EXPT 2 BLUEBITS))) [SETQ REDS (for I from 0 to NRED collect (FIXR (FQUOTIENT (ITIMES 255 I) NRED] [SETQ GREENS (for I from 0 to NGREEN collect (FIXR (FQUOTIENT (ITIMES 255 I) NGREEN] [SETQ BLUES (for I from 0 to NBLUE collect (FIXR (FQUOTIENT (ITIMES 255 I) NBLUE] (SETQ COLORMAP (COLORMAPCREATE [for I from 1 to (EXPT 2 (IDIFFERENCE BITSPERPIXEL (IPLUS REDBITS GREENBITS BLUEBITS))) join (for RED in REDS join (for GREEN in GREENS join (for BLUE in BLUES collect (create RGB RED _ RED GREEN _ GREEN BLUE _ BLUE] BITSPERPIXEL)) (RETURN COLORMAP]) (CMYCOLORMAP [LAMBDA (CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL) (* kbr%: "13-Aug-85 16:46") (PROG (COLORMAP MAXCOLOR) (SETQ COLORMAP (RGBCOLORMAP CYANBITS MAGENTABITS YELLOWBITS BITSPERPIXEL)) (SETQ MAXCOLOR (SUB1 (ARRAYSIZE COLORMAP))) [for I from 0 to (IQUOTIENT MAXCOLOR 2) do (swap (ELT COLORMAP I) (ELT COLORMAP (IDIFFERENCE MAXCOLOR I] (RETURN COLORMAP]) (GRAYCOLORMAP [LAMBDA (BITSPERPIXEL) (* kbr%: "11-Jul-85 19:20") (* creates a gray color map *) (PROG (MAXCOLOR GRAYS COLORMAP) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) [SETQ GRAYS (for I from MAXCOLOR to 0 by -1 collect (FIXR (FQUOTIENT (ITIMES 255 I) MAXCOLOR] (SETQ COLORMAP (COLORMAPCREATE (for GRAY in GRAYS collect (create RGB RED _ GRAY GREEN _ GRAY BLUE _ GRAY)) BITSPERPIXEL)) (RETURN COLORMAP]) (COLORSCREENBITMAP [LAMBDA NIL (* rrb "22-OCT-82 14:01") (* returns the color screen bitmap) ColorScreenBitMap]) (\COLORDISPLAYBITS [LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* kbr%: "18-Aug-85 17:09") (* returns a pointer to the bits that the color board needs.) (DECLARE (GLOBALVARS \COLORDISPLAYBITS)) (PROG (NPAGES) (* TBW%: If you come through this function a second time with different screen  params won't you get screwed half the time? *) [COND ((NULL \COLORDISPLAYBITS) (* 2 extra pages needed for  DORADOCOLOR microcode bug.  *) (SETQ NPAGES (IPLUS (FOLDHI (ITIMES (FOLDHI (ITIMES WIDTH BITSPERPIXEL) BITSPERWORD) HEIGHT) WORDSPERPAGE) 2)) (* \ALLOCBLOCK can't hack bitmaps of the size of the 1132 color screen) (SETQ \COLORDISPLAYBITS (COND ((IGREATERP (UNFOLD NPAGES CELLSPERPAGE) \MaxArrayNCells) (OR (\ALLOCPAGEBLOCK NPAGES) (ERROR "No room for color screen of size" NPAGES))) (T (\ALLOCBLOCK (UNFOLD NPAGES CELLSPERPAGE) NIL NIL CELLSPERPAGE] (RETURN \COLORDISPLAYBITS]) (COLORSCREEN [LAMBDA NIL (* kbr%: " 2-Feb-86 15:02") \COLORSCREEN]) (SHOWCOLORTESTPATTERN [LAMBDA (SIZE) (* kbr%: "15-Feb-86 15:16") (* Put a color test pattern on the color display.  SIZE is the size of the stripes that will be put up.  *) (PROG (DESTINATION WIDTH HEIGHT BITSPERPIXEL COLORS NCOLORS) (OR (NUMBERP SIZE) (SETQ SIZE 10)) (SETQ DESTINATION (COLORSCREENBITMAP)) (SETQ WIDTH (BITMAPWIDTH DESTINATION)) (SETQ HEIGHT (BITMAPHEIGHT DESTINATION)) (SETQ BITSPERPIXEL (BITSPERPIXEL DESTINATION)) (BLTSHADE MINIMUMSHADE DESTINATION) (SETQ COLORS (for BUCKET in COLORNAMES collect (CAR BUCKET))) (SETQ NCOLORS (LENGTH COLORS)) (for COLOR from 0 as LEFT from 10 by 80 to WIDTH do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS] DESTINATION LEFT 410 60 60)) (for COLOR from 1 as LEFT from 10 by 80 to WIDTH do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD COLOR NCOLORS] DESTINATION LEFT 330 60 60)) (for HORIZCOLOR from 0 as BOTTOM from 0 to 300 by SIZE do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD HORIZCOLOR NCOLORS] DESTINATION 0 BOTTOM WIDTH SIZE 'REPLACE) finally (for VERTCOLOR from 0 as LEFT from 0 to WIDTH by (ITIMES SIZE 2) do (BLTSHADE [CAR (NTH COLORS (ADD1 (IMOD VERTCOLOR NCOLORS] DESTINATION LEFT 0 SIZE BOTTOM 'REPLACE]) ) (RPAQ? COLORMONITORTYPE 'CONRAC) (DEFINEQ (\STARTCOLOR [LAMBDA (FDEV) (* kbr%: " 1-Jul-85 13:41") (WSOP 'STARTCOLOR FDEV]) (\STOPCOLOR [LAMBDA (FDEV) (* kbr%: " 1-Jul-85 13:40") (WSOP 'STOPCOLOR FDEV]) (\SENDCOLORMAPENTRY [LAMBDA (FDEV COLOR# RGB) (* kbr%: " 1-Jul-85 19:43") (* changes the window world background  to SHADE) (WSOP 'SENDCOLORMAPENTRY FDEV COLOR# RGB]) ) (DEFINEQ (COLORMAPCREATE [LAMBDA (INTENSITIES BITSPERPIXEL) (* ; "Edited 16-Jan-87 17:36 by gbn") (PROG (COLORMAP) (SELECTQ BITSPERPIXEL (4 [COND ((NULL INTENSITIES) (SETQ COLORMAP (CMYCOLORMAP 2 1 1 BITSPERPIXEL))) (T (SETQ COLORMAP (ARRAY 16 NIL NIL 0)) (for COLOR from 0 to 15 as RGB in INTENSITIES do (SETA COLORMAP COLOR RGB]) (8 [COND ((NULL INTENSITIES) (SETQ COLORMAP (CMYCOLORMAP 3 3 2 BITSPERPIXEL))) (T (SETQ COLORMAP (ARRAY 256 NIL NIL 0)) (for COLOR from 0 to 255 as RGB in INTENSITIES do (SETA COLORMAP COLOR RGB]) (24 (SETQ COLORMAP NIL)) (\ILLEGAL.ARG BITSPERPIXEL)) (RETURN COLORMAP]) (COLORLEVEL [LAMBDA (COLOR PRIMARY NEWLEVEL) (* kbr%: " 5-Jun-86 19:58") (PROG (RGB OLDVALUE) (SETQ RGB (ELT (SCREENCOLORMAP) COLOR)) (SETQ OLDVALUE (SELECTQ PRIMARY (RED (fetch (RGB RED) of RGB)) (GREEN (fetch (RGB GREEN) of RGB)) (BLUE (fetch (RGB BLUE) of RGB)) (\ILLEGAL.ARG PRIMARY))) (COND (NEWLEVEL (SELECTQ PRIMARY (RED (replace (RGB RED) of RGB with NEWLEVEL)) (GREEN (replace (RGB GREEN) of RGB with NEWLEVEL)) (BLUE (replace (RGB BLUE) of RGB with NEWLEVEL)) (SHOULDNT)) (\SENDCOLORMAPENTRY \COLORDISPLAYFDEV COLOR RGB))) (RETURN OLDVALUE]) (COLORNUMBERP [LAMBDA (COLOR# BITSPERPIXEL NOERRFLG) (* kbr%: "21-Aug-85 21:22") (* returns the color number from a  color.) (PROG (RGB) (COND [(FIXP COLOR#) (RETURN (COND ((AND (IGEQ COLOR# 0) (ILEQ COLOR# (MAXIMUMCOLOR BITSPERPIXEL)) COLOR#)) (NOERRFLG NIL) (T (\ILLEGAL.ARG COLOR#] [(LITATOM COLOR#) (RETURN (COND ((SETQ RGB (\LOOKUPCOLORNAME COLOR#)) (* recursively look up color number) (COLORNUMBERP (CDR RGB) BITSPERPIXEL NOERRFLG)) (NOERRFLG NIL) (T (ERROR "Unknown color name" COLOR#] ((HLSP COLOR#) (* HLS form convert to RGB) (SETQ RGB (HLSTORGB COLOR#))) ((RGBP COLOR#) (* check for RGB or HLS) (SETQ RGB COLOR#)) (NOERRFLG (RETURN NIL)) (T (\ILLEGAL.ARG COLOR#))) (RETURN (COND ((COLORFROMRGB RGB BITSPERPIXEL)) (NOERRFLG NIL) (T (ERROR COLOR# "not available in color map"]) (COLORFROMRGB [LAMBDA (RGB BITSPERPIXEL) (* kbr%: "15-Feb-86 11:16") (* looks in the colormap for a color that has RGB levels) (PROG (COLOR COLORMAP) (COND ((EQ BITSPERPIXEL 24) (* Assuming subtractive system in  which white=0. *) [SETQ COLOR (LOGOR (LLSH (IDIFFERENCE 255 (fetch (RGB RED) of RGB)) 16) (LLSH (IDIFFERENCE 255 (fetch (RGB GREEN) of RGB)) 8) (IDIFFERENCE 255 (fetch (RGB BLUE) of RGB] (RETURN COLOR))) (SETQ COLORMAP (COLORMAP BITSPERPIXEL)) (SETQ COLOR (for COLOR from 0 to (SUB1 (ARRAYSIZE COLORMAP)) thereis (EQUAL (ELT COLORMAP COLOR) RGB))) (RETURN COLOR]) (INTENSITIESFROMCOLORMAP [LAMBDA (COLORMAP) (* kbr%: "21-Aug-85 21:17") (* returns the intensity levels of the primary colors from a colormap.  This list can be passed into COLORMAPCREATE to get an equivalent colormap.) (for I from 0 to (SUB1 (ARRAYSIZE COLORMAP)) collect (ELT COLORMAP I]) (SETCOLORINTENSITY [LAMBDA (COLORMAP COLOR# INTENSITIES) (* rrb "13-DEC-82 13:15") (* sets the intensity levels of a color number in a color map.  Does not return the previous setting.) (PROG (RGB) (SETQ RGB INTENSITIES) LP (COND [(NULL RGB) (SETQ RGB '(0 0 0] ((RGBP RGB)) ((HLSP RGB) (SETQ RGB (HLSTORGB RGB))) ((SETQ RGB (CDR (\LOOKUPCOLORNAME RGB))) (GO LP)) (T (\ILLEGAL.ARG RGB))) (COLORLEVEL COLORMAP COLOR# 'RED (fetch (RGB RED) of RGB)) (COLORLEVEL COLORMAP COLOR# 'GREEN (fetch (RGB GREEN) of RGB)) (COLORLEVEL COLORMAP COLOR# 'BLUE (fetch (RGB BLUE) of RGB]) ) (DEFINEQ (\FAST8BIT [LAMBDA (A B N MAP) (* edited%: "10-SEP-82 16:14") (bind AW (I _ 0) for J from 0 do (SETQ AW (\ADDBASE A J)) (OR (IGREATERP N I) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN1) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN2) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN3) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN4) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN5) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN6) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN7) of AW))) (OR (IGREATERP N (add I 1)) (RETURN)) (\PUTBASE B I (ELT MAP (fetch (2BITNIBBLES EN8) of AW))) (add I 1]) (\MAP4 [LAMBDA (|0C| |1C|) (* edited%: "10-SEP-82 15:50") (SETQ |0C| (COND (|0C| (COLORNUMBERP |0C| 4)) (T 0))) (* Mask out but 4 bits) (SETQ |1C| (COND (|1C| (COLORNUMBERP |1C| 4)) (T 15))) (PROG (MAP) (SETQ MAP (ARRAY 16 'SMALLPOSP 0 0)) [for I from 0 to 15 do (SETA MAP I (for J from 0 to 3 sum (LLSH (COND ((ZEROP (LOGAND I (LLSH 1 J))) |0C|) (T |1C|)) (ITIMES J 4] (RETURN MAP]) (\MAP8 [LAMBDA (|0C| |1C|) (* edited%: "10-SEP-82 15:50") (* returns an array of words that contain the destination bitmap should contain  if a black and white bitmap is blown up to an 8 bit per pixel bitmap.) (SETQ |0C| (COND (|0C| (COLORNUMBERP |0C| 8)) (T 0))) (* make sure color numbers are given.) (SETQ |1C| (COND (|1C| (COLORNUMBERP |1C| 8)) (T 255))) (PROG (MAP) (SETQ MAP (ARRAY 4 'SMALLPOSP 0 0)) [for I from 0 to 3 do (SETA MAP I (LOGOR (COND ((ZEROP (LOGAND I 1)) |0C|) (T |1C|)) (LLSH (COND ((ZEROP (LOGAND I 2)) |0C|) (T |1C|)) 8] (RETURN MAP]) ) (DEFINEQ (\GETCOLORBRUSH [LAMBDA (BRUSH COLOR NBITS) (* rrb "21-DEC-82 20:46") (* produces a colorbitmap that is 1's where ever the brush bitmap would be 1) (COND ((AND (BITMAPP BRUSH) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BRUSH) NBITS)) BRUSH) (T (COLORIZEBITMAP [COND ((LISTP BRUSH) (\BRUSHBITMAP (fetch (BRUSH BRUSHSHAPE) of BRUSH) (fetch (BRUSH BRUSHSIZE) of BRUSH))) (T (\BRUSHBITMAP 'ROUND (OR BRUSH 1] 0 COLOR NBITS]) ) (DEFINEQ (\DRAWCOLORLINE1 [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH NBITS COLOR) (* rrb "10-OCT-82 12:33") (DECLARE (LOCALVARS . T)) (COND ((EQ NBITS 4) (\DRAW4BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR)) (T (\DRAW8BPPCOLORLINE X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR]) (\DRAW4BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* kbr%: "22-Jul-85 09:16") (DECLARE (LOCALVARS . T)) (* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching  either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE.  Arranged so that the clipping routines can determine what the exact location of  the end point of the clipped line is wrt line drawing coordinates eg.  amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be  moved in that direction.) (PROG (MAPPTR MASK COLORMASK COLORMASKORG WORDOFFSET) (SETQ COLORMASKORG (LLSH COLOR 12)) (* keep word offset from bitmapbase so that the YINC can be negative or  positive. Used to use \ADDBASE directly but negative case was not in micro code  and ran much slower.) [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 2] (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET)) (SETQ MASK (\4BITMASK X0)) (SETQ COLORMASK (LLSH COLOR (LLSH (IDIFFERENCE 3 (LOGAND X0 3)) 2))) (SETQ X0 0) (SETQ Y0 0) (COND ((IGEQ DX DY) (* X is the fastest mover.) (.DRAW4BPPLINEX. MODE)) (T (* Y is the fastest mover.) (.DRAW4BPPLINEY. MODE]) (\DRAW8BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* kbr%: "22-Jul-85 09:18") (DECLARE (LOCALVARS . T)) (* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching  either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE.  Arranged so that the clipping routines can determine what the exact location of  the end point of the clipped line is wrt line drawing coordinates eg.  amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be  moved in that direction.) (PROG (MAPPTR STARTBYTE WORDOFFSET) (* keep word offset from bitmapbase so that the YINC can be negative or  positive. Used to use \ADDBASE directly but negative case was not in micro code  and ran much slower.) [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3] (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET)) (SETQ STARTBYTE (LOGAND X0 1)) (SETQ X0 0) (SETQ Y0 0) (COND ((IGEQ DX DY) (* X is the fastest mover.) (.DRAW8BPPLINEX MODE)) (T (* Y is the fastest mover.) (.DRAW8BPPLINEY MODE]) (\DRAW24BPPCOLORLINE [LAMBDA (X0 Y0 XLIMIT YLIMIT DX DY CDL YINC MODE BITMAPBASE RASTERWIDTH COLOR) (* kbr%: "15-Feb-86 23:00") (DECLARE (LOCALVARS . T)) (* draws a color line starting at X0,Y0 at a slope of DX/DY until reaching  either XLIMIT or YLIMIT with an initial overflow bucket size of CDL in MODE.  Arranged so that the clipping routines can determine what the exact location of  the end point of the clipped line is wrt line drawing coordinates eg.  amount in overflow bucket. XLIMIT and YLIMIT are the number of points to be  moved in that direction.) (PROG (MAPPTR STARTBYTE WORDOFFSET) (* keep word offset from bitmapbase so that the YINC can be negative or  positive. Used to use \ADDBASE directly but negative case was not in micro code  and ran much slower.) [SETQ WORDOFFSET (IPLUS (ITIMES Y0 RASTERWIDTH) (FOLDLO X0 (CONSTANT (LRSH BITSPERWORD 3] (SETQ MAPPTR (\ADDBASE BITMAPBASE WORDOFFSET)) (SETQ STARTBYTE (LOGAND X0 1)) (SETQ X0 0) (SETQ Y0 0) (COND ((IGEQ DX DY) (* X is the fastest mover.) (.DRAW24BPPLINEX MODE)) (T (* Y is the fastest mover.) (.DRAW24BPPLINEY MODE]) ) (DECLARE%: DONTCOPY DOEVAL@COMPILE (DECLARE%: EVAL@COMPILE [PUTPROPS .DRAW4BPPLINEX. MACRO ((MODE) (PROG (INSIDEBITS OUTSIDEBITS) (until (IGREATERP X0 XLIMIT) do (* main loop) (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR))) (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK) (fetch (BITMAPWORD BITS) of MAPPTR))) [replace (BITMAPWORD BITS) of MAPPTR with (SELECTQ MODE (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS) OUTSIDEBITS)) (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS ) OUTSIDEBITS)) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) (LOGOR COLORMASK OUTSIDEBITS] [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC ] [COND [(ZEROP (SETQ MASK (LRSH MASK 4))) (* crossed word boundary) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (SETQ COLORMASK COLORMASKORG) (SETQ MASK (CONSTANT (\4BITMASK 0] (T (SETQ COLORMASK (LRSH COLORMASK 4] (SETQ X0 (ADD1 X0] [PUTPROPS .DRAW8BPPLINEX MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (GO 0LP] [PUTPROPS .DRAW24BPPLINEX MACRO ((MODE) (PROG NIL (* main loop) LP (\PUTBASE24 MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASE24 MAPPTR 0 ))) (INVERT (LOGXOR COLOR (\GETBASE24 MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASE24 MAPPTR 0 ))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX)) (SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET] (GO LP] [PUTPROPS .DRAW4BPPLINEY. MACRO ((MODE) (PROG (INSIDEBITS OUTSIDEBITS) (until (IGREATERP Y0 YLIMIT) do (* main loop) (SETQ INSIDEBITS (LOGAND MASK (fetch (BITMAPWORD BITS) of MAPPTR))) (SETQ OUTSIDEBITS (LOGAND (LOGNOT MASK) (fetch (BITMAPWORD BITS) of MAPPTR))) [replace (BITMAPWORD BITS) of MAPPTR with (SELECTQ MODE (ERASE (LOGOR (LOGAND COLORMASK INSIDEBITS) OUTSIDEBITS)) (INVERT (LOGOR (LOGXOR COLORMASK INSIDEBITS) OUTSIDEBITS)) (PAINT (LOGOR (LOGOR COLORMASK INSIDEBITS ) OUTSIDEBITS)) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) (LOGOR COLORMASK OUTSIDEBITS] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (COND [(ZEROP (SETQ MASK (LRSH MASK 4))) (* crossed word boundary) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (SETQ COLORMASK COLORMASKORG) (SETQ MASK (CONSTANT (\4BITMASK 0] (T (SETQ COLORMASK (LRSH COLORMASK 4] [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (SETQ Y0 (ADD1 Y0] [PUTPROPS .DRAW8BPPLINEY MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (GO 1LP))) (GO 0LP) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (GO 0LP))) (GO 1LP] [PUTPROPS .DRAW24BPPLINEY MACRO ((MODE) (PROG NIL (COND ((EQ STARTBYTE 1) (GO 1LP))) 0LP (* main loop) (\PUTBASEBYTE MAPPTR 0 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 0))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 0))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 0))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC ] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) (GO 1LP))) (GO 0LP) 1LP (\PUTBASEBYTE MAPPTR 1 (SELECTQ MODE (ERASE (LOGAND COLOR (\GETBASEBYTE MAPPTR 1))) (INVERT (LOGXOR COLOR (\GETBASEBYTE MAPPTR 1))) (PAINT (LOGOR COLOR (\GETBASEBYTE MAPPTR 1))) (PROGN (* case is REPLACE. Legality of OPERATION has been checked by \CLIPANDDRAWLINE1) COLOR))) (COND ((IGREATERP (SETQ Y0 (ADD1 Y0)) YLIMIT) (RETURN))) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (IPLUS WORDOFFSET YINC ] (COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (* moved enough in Y to move a point in X) (COND ((IGREATERP (SETQ X0 (ADD1 X0)) XLIMIT) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY)) [SETQ MAPPTR (\ADDBASE BITMAPBASE (SETQ WORDOFFSET (ADD1 WORDOFFSET ] (GO 0LP))) (GO 1LP] ) ) (DEFINEQ (\BWTOCOLORBLT [LAMBDA (SOURCEBWBM SLEFT SBOTTOM DESTCOLORBM DLEFT DBOTTOM WIDTH HEIGHT 0COLOR 1COLOR DESTNBITS) (* kbr%: "15-Feb-86 11:06") (* blits from a black and white bitmap into a color bitmap which has DESTNBITS  bits per pixel. DESTCOLORBM is a pointer to the color bitmap.) (* assumes all datatypes and bounds  have been checked) (SELECTQ DESTNBITS (4 [PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF NBITS DESALIGNLEFT SCR) (SETQ MAP (fetch (ARRAYP BASE) of (\MAP4 0COLOR 1COLOR))) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (SETQ DESWRD (FOLDLO DLEFT 4)) (SETQ DESOFF (MOD DLEFT 4)) (SETQ NBITS 4) (* DESTCOLORBM is used to allow one bit per pixel bitblt operations on the  bitmap.) [COND ((NOT (EQ 0 DESOFF)) (* save the left bits of the destination bitmap so it can be word aligned.) (SETQ SCR (BITMAPCREATE 4 HEIGHT 4)) (BITBLT DESTCOLORBM (SETQ DESALIGNLEFT (LLSH DESWRD 2)) DBOTTOM SCR 0 0 DESOFF HEIGHT 'INPUT 'REPLACE] (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\4BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW) SRCWRD)) SRCOFFSET (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD)) WIDTH MAP 0COLOR 1COLOR)) (COND (DESALIGNLEFT (* move the color bits to the right and restore the saved color bits.) (BITBLT DESTCOLORBM DESALIGNLEFT DBOTTOM DESTCOLORBM (IPLUS DESALIGNLEFT DESOFF) DBOTTOM WIDTH HEIGHT 'INPUT 'REPLACE) (BITBLT SCR 0 0 DESTCOLORBM DESALIGNLEFT DBOTTOM DESOFF HEIGHT 'INPUT 'REPLACE]) (8 (PROG (MAP SRCBASE SRCHEIGHT SRCRW SRCWRD SRCOFFSET DESBASE DESHEIGHT DESRW DESWRD DESOFF) (SETQ MAP (fetch (ARRAYP BASE) of (\MAP8 0COLOR 1COLOR))) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ SRCWRD (FOLDLO SLEFT BITSPERWORD)) (SETQ SRCOFFSET (MOD SLEFT BITSPERWORD)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (SETQ DESWRD (FOLDLO DLEFT 2)) (SETQ DESOFF (MOD DLEFT 2)) (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\8BITLINEBLT (\ADDBASE SRCBASE (IPLUS (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW) SRCWRD)) SRCOFFSET (\ADDBASE DESBASE (IPLUS (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW) DESWRD)) DESOFF WIDTH MAP 0COLOR 1COLOR)))) (24 (PROG (SRCBASE SRCHEIGHT SRCRW DESBASE DESHEIGHT DESRW) (SETQ SRCBASE (fetch (BITMAP BITMAPBASE) of SOURCEBWBM)) (SETQ SRCHEIGHT (fetch (BITMAP BITMAPHEIGHT) of SOURCEBWBM)) (SETQ SRCRW (fetch (BITMAP BITMAPRASTERWIDTH) of SOURCEBWBM)) (SETQ DESBASE (fetch (BITMAP BITMAPBASE) of DESTCOLORBM)) (SETQ DESHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTCOLORBM)) (SETQ DESRW (fetch (BITMAP BITMAPRASTERWIDTH) of DESTCOLORBM)) (for LINECOUNTER from 1 to HEIGHT do (* linecounter goes from 1 to height because bitmaps are stored internally with  top first so subtracting height is necessary to get offset of line and the 1  corrects for height difference.) (\24BITLINEBLT (\ADDBASE SRCBASE (ITIMES (IDIFFERENCE SRCHEIGHT (IPLUS LINECOUNTER SBOTTOM)) SRCRW)) SLEFT (\ADDBASE DESBASE (ITIMES (IDIFFERENCE DESHEIGHT (IPLUS LINECOUNTER DBOTTOM)) DESRW)) DLEFT WIDTH 0COLOR 1COLOR)))) (SHOULDNT]) (\4BITLINEBLT [LAMBDA (SBASE SBITOFFSET DBASE WIDTH MAPBASE 0COLOR 1COLOR) (* rrb "15-OCT-82 09:28") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table. Destination bit offset is assumed to be 0 because \BWTOCOLORBLT  arranges things so that it is.) (SELECTQ (MOD SBITOFFSET 4) (0 (* case of moving even aligned bits.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or 12) (COND ((AND (EQ SBITOFFSET 0) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LOGAND (\GETBASEBYTE DBASE 0) 15) (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (0 (fetch (NIBBLES N1) of SBASE)) (4 (fetch (NIBBLES N2) of SBASE)) (8 (fetch (NIBBLES N3) of SBASE)) (fetch (NIBBLES N4) of SBASE] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) [COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 16) (SETQ SBITOFFSET 0) (SETQ SBASE (\ADDBASE SBASE 1] (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (NIBBLES N1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (NIBBLES N2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (NIBBLES N3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (NIBBLES N4) of SBASE))) (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16 bits.) (GO ONEWRDLP]) (1 (* moving bits that are aligned with 1 extra bit in the following word of the  source.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 0, 4, 8 or 12) (COND ((AND (EQ SBITOFFSET 1) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (1 (fetch (ONEOFFSETBITACCESS BITS1TO4 ) of SBASE)) (5 (fetch (ONEOFFSETBITACCESS BITS5TO8 ) of SBASE)) (9 (fetch (ONEOFFSETBITACCESS BITS9TO12) of SBASE)) (LOGOR (LLSH (fetch ( ONEOFFSETBITACCESS BITS13TO15) of SBASE) 1) (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 17) (* SBASE has already been incremented as part of fetching the last 4 bits.) (SETQ SBITOFFSET 1))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS1TO4) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS5TO8) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ONEOFFSETBITACCESS BITS9TO12) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ONEOFFSETBITACCESS BITS13TO15) of SBASE) 1) (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16 bits.) (GO ONEWRDLP]) (2 (* moving bits that are aligned with 2 extra bits in the following word of the  source.) [PROG NIL ONEWRDLP (* SBITOFFSET is either 2, 6, 10 or 14) (COND ((AND (EQ SBITOFFSET 2) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR]) (PROGN (* first two bits are always in this  word.) [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET ))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (LOGAND SWORDCONTENTS (\BITMASK (ADD1 SBITOFFSET ] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (COND ((EQ SBITOFFSET 14) (* the next one is in the next word if the offset is 14) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (2 (fetch (TWOOFFSETBITACCESS BITS2TO5 ) of SBASE)) (6 (fetch (TWOOFFSETBITACCESS BITS6TO9 ) of SBASE)) (10 (fetch (TWOOFFSETBITACCESS BITS10TO13) of SBASE)) (LOGOR (LLSH (fetch ( TWOOFFSETBITACCESS BITS14TO15) of SBASE) 2) (fetch (TWOOFFSETBITACCESS BITS0TO1) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 18) (* SBASE has already been incremented as part of fetching the last 4 bits.) (SETQ SBITOFFSET 2))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS2TO5) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS6TO9) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (TWOOFFSETBITACCESS BITS10TO13) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (TWOOFFSETBITACCESS BITS14TO15) of SBASE) 2) (fetch (TWOOFFSETBITACCESS BITS0TO1) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16 bits.) (GO ONEWRDLP]) (PROG NIL (* moving bits that are aligned with 3 extra bits in the following word of the  source.) ONEWRDLP (* SBITOFFSET is either 3, 7, 11 or 15) (COND ((AND (EQ SBITOFFSET 3) (IGREATERP WIDTH (SUB1 BITSPERWORD))) (* go to center loop.) (GO LP)) ((IGREATERP 4 WIDTH) [PROG (SWORDCONTENTS) (SETQ SWORDCONTENTS (\GETBASE SBASE 0)) (SELECTQ WIDTH (0) (1 (PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET) )) 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASEBYTE DBASE 0) 15)))) (2 [PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET ))) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next bit is in the next word if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD ) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR]) (PROGN (* first two bits are always in this  word.) [\PUTBASEBYTE DBASE 0 (LOGOR (LLSH (COND ((ZEROP (LOGAND SWORDCONTENTS (\BITMASK SBITOFFSET)) ) 0COLOR) (T 1COLOR)) 4) (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next bit is in the next word if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT0OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR] (\PUTBASEBYTE DBASE 1 (LOGOR (LLSH (COND ([ZEROP (COND ((EQ SBITOFFSET 15) (* the next one is in the next word if the offset is 15) (fetch (TWOOFFSETBITACCESS BIT1OFNEXTWORD) of SBASE)) (T (LOGAND SWORDCONTENTS (\BITMASK (IPLUS SBITOFFSET 2] 0COLOR) (T 1COLOR)) 4) (LOGAND (\GETBASE DBASE 0) 15] (RETURN)) (T (* move 4 bits from source to  destination.) [\PUTBASE DBASE 0 (\GETBASE MAPBASE (SELECTQ SBITOFFSET (3 (fetch (THREEOFFSETBTACCESS BITS3TO6) of SBASE)) (7 (fetch (THREEOFFSETBTACCESS BITS7TO10) of SBASE)) (11 (fetch (THREEOFFSETBTACCESS BITS11TO14) of SBASE)) (LOGOR (LLSH (fetch (ODD2BITNIBBLES BIT15) of SBASE) 3) (fetch (THREEOFFSETBTACCESS BITS0TO2) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 4)) (COND ((EQ (SETQ SBITOFFSET (IPLUS SBITOFFSET 4)) 19) (* SBASE has already been incremented as part of fetching the last 4 bits.) (SETQ SBITOFFSET 3))) (GO ONEWRDLP))) LP (COND ((IGREATERP WIDTH (SUB1 BITSPERWORD)) (* move a source word's worth of bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS3TO6) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS7TO10) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (THREEOFFSETBTACCESS BITS11TO14) of SBASE))) [\PUTBASE DBASE 3 (\GETBASE MAPBASE (LOGOR (LLSH (fetch (ODD2BITNIBBLES BIT15) of SBASE) 3) (fetch (THREEOFFSETBTACCESS BITS0TO2) of (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBASE (\ADDBASE DBASE 4)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD)) (GO LP)) (T (* finish off last less than 16 bits.) (GO ONEWRDLP]) (\8BITLINEBLT [LAMBDA (SBASE SBITOFFSET DBASE DBITOFFSET WIDTH MAPBASE 0COLOR 1COLOR) (* edited%: "16-SEP-82 19:36") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table.) [COND ((EQ 1 DBITOFFSET) (* move the first bit specially to get to word boundary in destination.) (\PUTBASEBYTE DBASE 1 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) [COND ((EQ (SETQ SBITOFFSET (ADD1 SBITOFFSET)) BITSPERWORD) (* SBITOFFSET flowed onto next word.) (SETQ SBITOFFSET 0) (SETQ SBASE (\ADDBASE SBASE 1] (SETQ DBITOFFSET 0) (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (SUB1 WIDTH] (COND ((ZEROP (MOD SBITOFFSET 2)) (* case of moving even aligned bits.) (PROG NIL LP [COND ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD)) (EQ SBITOFFSET 0)) (* move a source word's worth of bits.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN4) of SBASE))) (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN5) of SBASE))) (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN6) of SBASE))) (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN7) of SBASE))) (\PUTBASE DBASE 7 (\GETBASE MAPBASE (fetch (2BITNIBBLES EN8) of SBASE))) (SETQ DBASE (\ADDBASE DBASE 8)) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))) ((EQ WIDTH 0) (RETURN)) ((EQ WIDTH 1) (* move last bit specially) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (RETURN)) (T (* move the rest of the first word or last word two at a time.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 1 (COND ([ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR))) (SETQ DBASE (\ADDBASE DBASE 1)) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (COND ((EQ SBITOFFSET 14) (SETQ SBASE (\ADDBASE SBASE 1)) (SETQ SBITOFFSET 0)) (T (SETQ SBITOFFSET (IPLUS SBITOFFSET 2] (GO LP))) (T (* moving odd aligned bits.) (PROG NIL LP [COND ((AND (IGREATERP WIDTH (SUB1 BITSPERWORD)) (EQ SBITOFFSET 1)) (* move a source word's worth of bits. move the 1th thru 15th bits in the first  word plus the 0th bit in the next word.) (\PUTBASE DBASE 0 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT1) of SBASE))) (\PUTBASE DBASE 1 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT2) of SBASE))) (\PUTBASE DBASE 2 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT3) of SBASE))) (\PUTBASE DBASE 3 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT4) of SBASE))) (\PUTBASE DBASE 4 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT5) of SBASE))) (\PUTBASE DBASE 5 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT6) of SBASE))) (\PUTBASE DBASE 6 (\GETBASE MAPBASE (fetch (ODD2BITNIBBLES ODD2BIT7) of SBASE))) (\PUTBASEBYTE DBASE 14 (COND ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE)) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 15 (COND ([ZEROP (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] 0COLOR) (T 1COLOR))) (SETQ DBASE (\ADDBASE DBASE 8)) (SETQ WIDTH (IDIFFERENCE WIDTH BITSPERWORD))) ((EQ WIDTH 0) (RETURN)) ((EQ WIDTH 1) (* move last bit specially) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (RETURN)) ((EQ SBITOFFSET 15) (* case of moving one bit from each of two words in the slow case.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (fetch (ODD2BITNIBBLES BIT15) of SBASE)) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE (SETQ SBITOFFSET 1) (COND ([ZEROP (fetch (ODD2BITNIBBLES BIT0) of (SETQ SBASE (\ADDBASE SBASE 1] 0COLOR) (T 1COLOR))) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (SETQ DBASE (\ADDBASE DBASE 1))) (T (* move the rest of the first word or the rest of last word two at a time.) (\PUTBASEBYTE DBASE 0 (COND ((ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK SBITOFFSET))) 0COLOR) (T 1COLOR))) (\PUTBASEBYTE DBASE 1 (COND ([ZEROP (LOGAND (\GETBASE SBASE 0) (\BITMASK (ADD1 SBITOFFSET] 0COLOR) (T 1COLOR))) (SETQ SBITOFFSET (IPLUS SBITOFFSET 2)) (SETQ WIDTH (IDIFFERENCE WIDTH 2)) (SETQ DBASE (\ADDBASE DBASE 1] (GO LP]) (\24BITLINEBLT [LAMBDA (SBASE SLEFT DBASE DLEFT WIDTH 0COLOR 1COLOR) (* kbr%: "15-Feb-86 10:56") (* moves one line of a black and white bitmap into a color bitmap using a  mapping table.) (PROG NIL (for SX from SLEFT to (IPLUS SLEFT WIDTH -1) as DX from DLEFT do (\PUTBASE24 DBASE DX (COND ([ZEROP (LOGAND (\GETBASE SBASE (FOLDLO SX BITSPERWORD)) (\BITMASK (LOGAND SX 15] 0COLOR) (T 1COLOR]) (\GETBASE24 [LAMBDA (X D) (* kbr%: "13-Feb-86 21:07") (* Get Dth 24bit pixel from packed X.  *) (PROG (DWORD ANSWER) (SETQ DWORD (FOLDLO (ITIMES 24 D) BITSPERWORD)) [SETQ ANSWER (SELECTQ (LOGAND D 1) (0 (* Get nibbles 1 0 of DWORD and nibble 1 of following word.  *) (LOGOR (LLSH (\GETBASE X DWORD) 8) (LRSH (\GETBASE X (ADD1 DWORD)) 8))) (PROGN (* Get nibble 0 of DWORD and nibbles 1 0 of following word.  *) (LOGOR (LLSH (LOGAND (\GETBASE X DWORD) (MASK.1'S 0 8)) 16) (\GETBASE X (ADD1 DWORD] (RETURN ANSWER]) (\PUTBASE24 [LAMBDA (X D V) (* kbr%: "13-Feb-86 21:19") (* Set Dth 24bit pixel from packed X.  *) (PROG (DWORD) (SETQ DWORD (FOLDLO (ITIMES 24 D) BITSPERWORD)) (SELECTQ (LOGAND D 1) (0 (* Replace nibbles 1 0 of DWORD and nibble 1 of following word.  *) (\PUTBASE X DWORD (LRSH V 8)) [\PUTBASE X (ADD1 DWORD) (LOGOR (LLSH (LOGAND V (MASK.1'S 0 8)) 8) (LOGAND (\GETBASE X DWORD) (MASK.1'S 0 8]) (PROGN (* Replace nibble 0 of DWORD and nibbles 1 0 of following word.  *) (\PUTBASE X DWORD (LOGOR (LOGAND (\GETBASE X DWORD) (LLSH (MASK.1'S 0 8) 8)) (LRSH V 16))) (\PUTBASE X (ADD1 DWORD) (LOGAND V (MASK.1'S 0 16]) (COLORTEXTUREFROMCOLOR# [LAMBDA (COLOR# BITSPERPIXEL) (* kbr%: "27-Feb-86 16:48") (* returns a TEXTURE that is COLOR# tessellated in a pattern to put down  BITSPERPIXEL per pixel color) (PROG (TEXTURE) (COND ((type? BITMAP COLOR#) (* already is a texture.) (RETURN COLOR#))) (SETQ COLOR# (COLORNUMBERP COLOR# BITSPERPIXEL)) (SETQ TEXTURE (SELECTQ BITSPERPIXEL (4 (PROG (TEXTUREBITMAP BITPATTERN) (SETQ TEXTUREBITMAP (BITMAPCREATE 4 4 4)) (SETQ BITPATTERN (LOGOR (LLSH COLOR# 12) (LLSH COLOR# 8) (LLSH COLOR# 4) COLOR#)) (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN)) (RETURN TEXTUREBITMAP))) (8 (PROG (TEXTUREBITMAP BITPATTERN) (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 8)) (SETQ BITPATTERN (LOGOR (LLSH COLOR# 8) COLOR#)) (for I from 0 to 3 do (\BITMAPWORD TEXTUREBITMAP I BITPATTERN)) (RETURN TEXTUREBITMAP))) (24 (* This isn't right, but at least it won't break you.  *) (PROG (TEXTUREBITMAP BITMAPBASE) (SETQ TEXTUREBITMAP (BITMAPCREATE 2 4 24)) (SETQ BITMAPBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBITMAP)) (for I from 0 to 7 do (\PUTBASE24 BITMAPBASE I COLOR#)) (RETURN TEXTUREBITMAP))) (ERROR "Only 4, 8 and 24 bits per pixel implemented."))) (RETURN TEXTURE]) (\BITMAPWORD [LAMBDA (BM WORDN NEWBITS) (* edited%: " 8-SEP-82 10:54") (* puts a words worth of bits into the WORDNth word of a bitmap.) (\PUTBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BM) WORDN) 0 (LOGAND NEWBITS WORDMASK]) ) (DEFINEQ (COLORIZEBITMAP [LAMBDA (BITMAP 0COLOR 1COLOR BITSPERPIXEL) (* kbr%: "15-Feb-86 10:13") (* creates a copy of BITMAP that is in color form allowing BITSPERPIXEL per  pixel. 0COLOR and 1COLOR are the color numbers that get translated from 0 and 1  respectively.) (PROG (COLORBITMAP) (SETQ COLORBITMAP (BITMAPCREATE (fetch (BITMAP BITMAPWIDTH) of BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP) BITSPERPIXEL)) (\BWTOCOLORBLT BITMAP 0 0 COLORBITMAP 0 0 (fetch (BITMAP BITMAPWIDTH) of BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP) (COLORNUMBERP 0COLOR BITSPERPIXEL) (COLORNUMBERP 1COLOR BITSPERPIXEL) BITSPERPIXEL) (RETURN COLORBITMAP]) (UNCOLORIZEBITMAP [LAMBDA (BITMAP COLORMAP) (* kbr%: " 2-Sep-85 19:21") (PROG (BITSPERPIXEL MAXCOLOR MAXX MAXY BWBITMAP TABLE RGB R G B BIT BASE BWBASE RASTERWIDTH BWRASTERWIDTH WORD) (SETQ MAXX (SUB1 (fetch (BITMAP BITMAPWIDTH) of BITMAP))) (SETQ MAXY (SUB1 (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (SETQ COLORMAP (OR COLORMAP (COLORMAP BITSPERPIXEL))) (SETQ MAXCOLOR (MAXIMUMCOLOR BITSPERPIXEL)) (SETQ BWBITMAP (BITMAPCREATE (ADD1 MAXX) (ADD1 MAXY) 1)) (SETQ TABLE (\ALLOCBLOCK (FOLDHI (ADD1 MAXCOLOR) 2))) (for I from 0 to MAXCOLOR do (SETQ RGB (ELT COLORMAP I)) (SETQ R (fetch (RGB RED) of RGB)) (SETQ G (fetch (RGB GREEN) of RGB)) (SETQ B (fetch (RGB BLUE) of RGB)) (SETQ BIT (IDIFFERENCE 1 (IQUOTIENT (IPLUS R G B) 384))) (\PUTBASE TABLE I BIT)) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (SETQ BWBASE (fetch (BITMAP BITMAPBASE) of BWBITMAP)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BWRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BWBITMAP)) (SELECTQ BITSPERPIXEL (4 [for Y from 0 to MAXY do (SETQ WORD 0) [for X from 0 to MAXX do [SETQ WORD (LOGOR (LLSH WORD 1) (\GETBASE TABLE (\GETBASENYBBLE BASE X] (COND ((EQ (LOGAND X 15) 15) (\PUTBASE BWBASE (FOLDLO X 16) WORD) (SETQ WORD 0] (COND ((NOT (EQ (LOGAND MAXX 15) 15)) [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15] (\PUTBASE BWBASE (FOLDLO MAXX 16) WORD))) (COND ((NOT (EQ Y MAXY)) (SETQ BASE (\ADDBASE BASE RASTERWIDTH)) (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH]) (8 [for Y from 0 to MAXY do (SETQ WORD 0) [for X from 0 to MAXX do [SETQ WORD (LOGOR (LLSH WORD 1) (\GETBASE TABLE (\GETBASEBYTE BASE X] (COND ((EQ (LOGAND X 15) 15) (\PUTBASE BWBASE (FOLDLO X 16) WORD) (SETQ WORD 0] (COND ((NOT (EQ (LOGAND MAXX 15) 15)) [SETQ WORD (LLSH WORD (IDIFFERENCE 15 (LOGAND MAXX 15] (\PUTBASE BWBASE (FOLDLO MAXX 16) WORD))) (COND ((NOT (EQ Y MAXY)) (SETQ BASE (\ADDBASE BASE RASTERWIDTH)) (SETQ BWBASE (\ADDBASE BWBASE BWRASTERWIDTH]) NIL) (RETURN BWBITMAP]) ) (RPAQ? \1COLORMENU NIL) (RPAQ? \4COLORMENU NIL) (RPAQ? \8COLORMENU NIL) (DEFINEQ (COLORMENU [LAMBDA (BITSPERPIXEL) (* kbr%: " 5-Jun-85 18:24") (* Make a BITSPERPIXEL color menu.  *) (PROG (MENU ITEMS MENUCOLUMNS MENUROWS BITMAP) (* Try to find old menu.  *) (SETQ MENU (SELECTQ BITSPERPIXEL (1 \1COLORMENU) (4 \4COLORMENU) (8 \8COLORMENU) (\ILLEGAL.ARG BITSPERPIXEL))) (COND (MENU (RETURN MENU))) (* Calculate menu items.  *) (SETQ ITEMS (SELECTQ BITSPERPIXEL (1 (for COLOR from 0 to 1 as SHADE in (LIST WHITESHADE BLACKSHADE) collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 32 32)) (BLTSHADE SHADE BITMAP) BITMAP) COLOR))) (4 (for COLOR from 0 to 15 collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 16 16 4)) (BLTSHADE COLOR BITMAP) BITMAP) COLOR))) (8 (for COLOR from 0 to 255 collect (LIST (PROGN (SETQ BITMAP (BITMAPCREATE 8 8 8)) (BLTSHADE COLOR BITMAP) BITMAP) COLOR))) (SHOULDNT))) (SETQ MENUROWS (SELECTQ BITSPERPIXEL (1 1) (4 4) (8 16) (SHOULDNT))) (SETQ MENUCOLUMNS (SELECTQ BITSPERPIXEL (1 2) (4 4) (8 16) (SHOULDNT))) (SETQ MENU (create MENU ITEMS _ ITEMS MENUROWS _ MENUROWS MENUCOLUMNS _ MENUCOLUMNS MENUBORDERSIZE _ 1)) (SELECTQ BITSPERPIXEL (1 (SETQ \1COLORMENU MENU)) (4 (SETQ \4COLORMENU MENU)) (8 (SETQ \8COLORMENU MENU)) (SHOULDNT)) (RETURN MENU]) (CURSORCOLOR [LAMBDA (COLOR) (* edited%: " 4-Jun-85 15:56") (PROG (IMAGE MASK) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of \CURRENTCURSOR)) (SETQ MASK (fetch (CURSOR CUMASK) of \CURRENTCURSOR)) (BLTSHADE COLOR IMAGE) (BITBLT MASK NIL NIL IMAGE NIL NIL NIL NIL 'INVERT 'ERASE]) ) (DECLARE%: EVAL@COMPILE (RECORD RGB (RED GREEN BLUE)) (RECORD HLS (HUE LIGHTNESS SATURATION)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD NIBBLES ((N1 BITS 4) (N2 BITS 4) (N3 BITS 4) (N4 BITS 4))) (BLOCKRECORD ONEOFFSETBITACCESS ((BIT0 BITS 1) (BITS1TO4 BITS 4) (BITS5TO8 BITS 4) (BITS9TO12 BITS 4) (BITS13TO15 BITS 3))) (BLOCKRECORD TWOOFFSETBITACCESS ((BITS0TO1 BITS 2) (BITS2TO5 BITS 4) (BITS6TO9 BITS 4) (BITS10TO13 BITS 4) (BITS14TO15 BITS 2) (BIT0OFNEXTWORD BITS 1) (BIT1OFNEXTWORD BITS 1) (BITS2TO15OFNEXTWORD BITS 14))) (BLOCKRECORD THREEOFFSETBTACCESS ((BITS0TO2 BITS 3) (BITS3TO6 BITS 4) (BITS7TO10 BITS 4) (BITS11TO14 BITS 4) (BIT15 BITS 1))) (BLOCKRECORD 2BITNIBBLES ((EN1 BITS 2) (EN2 BITS 2) (EN3 BITS 2) (EN4 BITS 2) (EN5 BITS 2) (EN6 BITS 2) (EN7 BITS 2) (EN8 BITS 2))) (BLOCKRECORD ODD2BITNIBBLES ((BIT0 BITS 1) (ODD2BIT1 BITS 2) (ODD2BIT2 BITS 2) (ODD2BIT3 BITS 2) (ODD2BIT4 BITS 2) (ODD2BIT5 BITS 2) (ODD2BIT6 BITS 2) (ODD2BIT7 BITS 2) (BIT15 BITS 1))) ) ) (DECLARE%: EVAL@COMPILE (RPAQQ BITSPERWORD 16) (CONSTANTS (BITSPERWORD 16)) ) (RPAQ? \COLORDISPLAYFDEV ) (RPAQ? \4COLORMAP (CMYCOLORMAP 2 1 1 4)) (RPAQ? \8COLORMAP (CMYCOLORMAP 3 3 2 8)) (RPAQ? \COLORDISPLAYBITS ) (RPAQ? ColorScreenBitMap ) (RPAQ? \COLORSCREEN ) (DEFINEQ (PSEUDOCOLOR [LAMBDA (TABLE DESTINATION LEFT BOTTOM WIDTH HEIGHT) (* kbr%: " 2-Sep-85 19:08") (DECLARE (LOCALVARS . T)) (PROG (left top bottom right width height DESTDD DESTSTRM) (COND ((NULL LEFT) (SETQ LEFT 0))) (COND ((NULL BOTTOM) (SETQ BOTTOM 0))) (* left, right top and bottom are the limits in destination taking into account  Clipping Regions. Clip to region in the arguments of this call.) [COND [(type? BITMAP DESTINATION) (SETQ left 0) (SETQ bottom 0) (SETQ right (SUB1 (fetch (BITMAP BITMAPWIDTH) of DESTINATION))) (SETQ top (SUB1 (fetch (BITMAP BITMAPHEIGHT) of DESTINATION] ((SETQ DESTDD (\GETDISPLAYDATA DESTINATION)) (SETQ DESTSTRM DESTINATION) (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ LEFT (\DSPTRANSFORMX LEFT DESTDD)) (SETQ BOTTOM (\DSPTRANSFORMY BOTTOM DESTDD)) (PROGN (* compute limits based on clipping  regions.) (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD] (COND ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION) 8)) (ERROR "Pseudocolor only implemented for 8 bitsperpixel bitmaps" DESTINATION))) [PROGN (SETQ left (IMAX LEFT left)) (SETQ bottom (IMAX BOTTOM bottom)) [COND (WIDTH (* WIDTH is optional) (SETQ right (IMIN (IPLUS LEFT WIDTH) right] (COND (HEIGHT (* HEIGHT is optional) (SETQ top (IMIN (IPLUS BOTTOM HEIGHT) top] (* Clip and translate coordinates.) (SETQ width (IPLUS right (IMINUS left) 1)) (SETQ height (IPLUS top (IMINUS bottom) 1)) (COND (DESTSTRM (.WHILE.TOP.DS. DESTSTRM (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom width height))) (T (\PSEUDOCOLOR.BITMAP TABLE DESTINATION left bottom width height]) (\PSEUDOCOLOR.BITMAP [LAMBDA (TABLE BITMAP LEFT BOTTOM WIDTH HEIGHT) (* kbr%: "10-Jul-85 22:33") (\PSEUDOCOLOR.UFN (fetch (ARRAYP BASE) of TABLE) BITMAP LEFT BOTTOM WIDTH 0 HEIGHT]) (\PSEUDOCOLOR.UFN [LAMBDA (TABLEBASE BITMAP LEFT BOTTOM WIDTH ZERO HEIGHT) (* kbr%: "10-Jul-85 22:37") (* * Substitutes colors according to TABLEBASE within region of 8 bitsperpixel  BITMAP. *) (PROG (BASE RASTERWIDTH BMHEIGHT TOP RIGHT ROWBASE) (SETQ BASE (fetch (BITMAP BITMAPBASE) of BITMAP)) (SETQ RASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)) (SETQ BMHEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) (SETQ RIGHT (IPLUS LEFT WIDTH -1)) (SETQ BOTTOM (ITIMES RASTERWIDTH (IDIFFERENCE (SUB1 BMHEIGHT) BOTTOM))) [SETQ TOP (IDIFFERENCE BOTTOM (ITIMES RASTERWIDTH (SUB1 HEIGHT] (for Y from TOP to BOTTOM by RASTERWIDTH do (SETQ ROWBASE (\ADDBASE BASE Y)) (for X from LEFT to RIGHT do (\PUTBASEBYTE ROWBASE X (\GETBASE TABLEBASE (\GETBASEBYTE ROWBASE X]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \COLORDISPLAYFDEV \COLORDISPLAYBITS ColorScreenBitMap \4COLORMAP \8COLORMAP) ) (* NOTE%: This is very bad. I shouldn't have to and don't really want to do the following, but since about March 86, someone did something really nonstandard wrt Helvetica fonts so that the in core versions are not equal to what is stored on file. The SETFONTDESCRIPTOR and friends undoes this kludge which has never been explained to LISPCORE^ by the person who brain damaged Helvetica this way. If I don't undo this kludge by someone else, then color menus come out wrong. *) (SETFONTDESCRIPTOR 'HELVETICA 10 'MRR 0 'DISPLAY NIL) (SETQ MENUFONT (FONTCREATE 'HELVETICA 10)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS LLCOLOR COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986 1987)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3207 18386 (COLORDISPLAY 3217 . 6189) (COLORMAPBITS 6191 . 6356) ( \CreateColorScreenBitMap 6358 . 7673) (\CREATECOLORDISPLAYFDEV 7675 . 8562) (COLORMAP 8564 . 10070) ( SCREENCOLORMAP 10072 . 10270) (SCREENCOLORMAPENTRY 10272 . 10503) (ROTATECOLORMAP 10505 . 11219) ( RGBCOLORMAP 11221 . 13160) (CMYCOLORMAP 13162 . 13675) (GRAYCOLORMAP 13677 . 14611) (COLORSCREENBITMAP 14613 . 14855) (\COLORDISPLAYBITS 14857 . 16531) (COLORSCREEN 16533 . 16665) (SHOWCOLORTESTPATTERN 16667 . 18384)) (18425 19070 (\STARTCOLOR 18435 . 18577) (\STOPCOLOR 18579 . 18719) ( \SENDCOLORMAPENTRY 18721 . 19068)) (19071 24987 (COLORMAPCREATE 19081 . 20071) (COLORLEVEL 20073 . 21058) (COLORNUMBERP 21060 . 22650) (COLORFROMRGB 22652 . 23733) (INTENSITIESFROMCOLORMAP 23735 . 24142) (SETCOLORINTENSITY 24144 . 24985)) (24988 29172 (\FAST8BIT 24998 . 27006) (\MAP4 27008 . 27888) (\MAP8 27890 . 29170)) (29173 29901 (\GETCOLORBRUSH 29183 . 29899)) (29902 35269 (\DRAWCOLORLINE1 29912 . 30387) (\DRAW4BPPCOLORLINE 30389 . 32136) (\DRAW8BPPCOLORLINE 32138 . 33700) ( \DRAW24BPPCOLORLINE 33702 . 35267)) (62160 115864 (\BWTOCOLORBLT 62170 . 69727) (\4BITLINEBLT 69729 . 101780) (\8BITLINEBLT 101782 . 109928) (\24BITLINEBLT 109930 . 110611) (\GETBASE24 110613 . 111838) ( \PUTBASE24 111840 . 113189) (COLORTEXTUREFROMCOLOR# 113191 . 115507) (\BITMAPWORD 115509 . 115862)) ( 115865 121666 (COLORIZEBITMAP 115875 . 116807) (UNCOLORIZEBITMAP 116809 . 121664)) (121754 125017 ( COLORMENU 121764 . 124625) (CURSORCOLOR 124627 . 125015)) (127329 131618 (PSEUDOCOLOR 127339 . 130272) (\PSEUDOCOLOR.BITMAP 130274 . 130507) (\PSEUDOCOLOR.UFN 130509 . 131616))))) STOP \ No newline at end of file diff --git a/sources/LLDATATYPE b/sources/LLDATATYPE new file mode 100644 index 00000000..6450c234 --- /dev/null +++ b/sources/LLDATATYPE @@ -0,0 +1,1175 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 16:57:50" {DSK}medley3.5>sources>LLDATATYPE.;2 95620 changes to%: (FNS TYPENAME) previous date%: " 2-Feb-95 16:27:02" {DSK}medley3.5>sources>LLDATATYPE.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1999 by VENUE, Oakland, CA. All rights reserved. ") (PRETTYCOMPRINT LLDATATYPECOMS) (RPAQQ LLDATATYPECOMS ((COMS (* ;  "Because we use the UNLESSINEW macro in this file, we need it when compiling.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) RENAMEMACROS))) (COMS (* ; "Storage management") (FNS NTYPX \TYPEMASK.UFN \TYPEP.UFN \ALLOCMDSPAGE \ALLOCPAGEBLOCK \ALLOCVIRTUALPAGEBLOCK \MAPMDS \CHECKFORSTORAGEFULL \DOSTORAGEFULLINTERRUPT \SET.STORAGE.STATE \SETTYPEMASK \ADVANCE.STORAGE.STATE \NEW2PAGE \MAKEMDSENTRY \INITMDSPAGE \ASSIGNDATATYPE1 \RESOLVE.TYPENUMBER \TYPENUMBERFROMNAME CREATECELL \CREATECELL) (* ;;  "For NEW_STORAGE option was set in Maiko, then \maiko.set.storage.state is active") (FNS \MAIKO.SET.STORAGE.STATE) [P (AND (EQ \MACHINETYPE \MAIKO) (MOVD '\MAIKO.SET.STORAGE.STATE '\SET.STORAGE.STATE] (INITVARS (CROSSCOMPILING) (ASSIGNDATATYPE.ASKUSERWAIT 300) (\STORAGEFULLSTATE) (\STORAGEFULL)) (GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL \SYSTEMCACHEVARS \NxtArrayPage) (SPECVARS ASSIGNDATATYPE.ASKUSERWAIT)) (COMS (* ; "fetch and replace") (FNS FETCHFIELD REPLACEFIELD BOXCOUNT CONSCOUNT \DTEST \TYPECHECK \DTEST.UFN \INSTANCEP.UFN \INSTANCE-P \TYPECHECK.UFN GETDESCRIPTORS GETSUPERTYPE GETFIELDSPECS NCREATE NCREATE2 REPLACEFIELDVAL PUTBASEPTRX /REPLACEFIELD TYPENAME TYPENAMEP \TYPENAMEFROMNUMBER \BLOCKDATAP USERDATATYPES DATATYPEP DATATYPES) (P (MOVD? 'FETCHFIELD 'FFETCHFIELD NIL T) (MOVD? 'REPLACEFIELD 'FREPLACEFIELD NIL T) (MOVD? 'REPLACEFIELDVAL 'FREPLACEFIELDVAL NIL T)) (OPTIMIZERS TYPENAMEP \INSTANCE-P)) [COMS (* ; "STORAGE") (FNS STORAGE STORAGE.LEFT \STORAGE.TYPE \STLINP \STMDSTYPE \STMDS.APPROX \STORAGE.HUNKTYPE) (DECLARE%: DONTCOPY (RECORDS HUNKSTAT)) (INITVARS (STORAGE.ARRAYSIZES '(4 16 64 256 1024 4096 16384 NIL] (DECLARE%: (EXPORT (OPTIMIZERS PUTBASEPTRX) (CONSTANTS \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STACKP \VMEMPAGEP \STREAM \NEW-ATOM) (* ;;  "This is the list of datatypes whos type #s must be known to microcode or to C.") (* ;; "It is used in \SETUP.HUNK.TYPENUMBERS (in LLARRAYELT) to create the list INITIALDTDCONTENTS for INITDATATYPES.") (* ;;  "Changes to this lit need to be reflected in C and maybe in microcode.") (VARS \BUILT-IN-SYSTEM-TYPES)) DONTCOPY (EXPORT (RECORDS DTD) (MACROS \GETDTD) (OPTIMIZERS \TYPEMASK.UFN) (CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL) (GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage \MDSFREELISTPAGE \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE \PENDINGINTERRUPT)) (CONSTANTS * STORAGEFULLSTATES)) [COMS (* ; "for MAKEINIT") (FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES) (DECLARE%: DONTCOPY (ADDVARS (INITVALUES (\NxtMDSPage \FirstMDSPage) (\LeastMDSPage \FirstMDSPage) (\SecondMDSPage \DefaultSecondMDSPage) (\SecondArrayPage \DefaultSecondArrayPage) (\MDSFREELISTPAGE) (\MaxSysTypeNum 0) (\MaxTypeNumber)) (INITPTRS (\FINALIZATION.FUNCTIONS)) (INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \INITMDSPAGE \ASSIGNDATATYPE1 \TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE ) (FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES) (VARS \BUILT-IN-SYSTEM-TYPES)) (RDCOMS (FNS NTYPX TYPENAME \TYPENAMEFROMNUMBER)) (RDVALS (\MaxTypeNumber)) (RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X) 'ARRAYP)) (EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS \PUTBITS \TESTBITS GETBASEBITS PUTBASEBITS FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL REPLACEFIELDVAL NCREATE) (MKI.SUBFNS (\GCDISABLED . NILL) (CREATECELL . I.\CREATECELL) (\CHECKFORSTORAGEFULL . NILL))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES] (LOCALVARS . T) (PROP FILETYPE LLDATATYPE) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) DTDECLARE)))) (* ; "Because we use the UNLESSINEW macro in this file, we need it when compiling.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) RENAMEMACROS) ) (* ; "Storage management") (DEFINEQ (NTYPX + [LAMBDA (X) (* JonL "10-Nov-84 21:51") + (* ; + "usually done in microcode --- this def used by MAKEINIT too") + (LOGAND [\GETBASE \MDSTypeTable (FOLDLO (fetch (POINTER PAGE#) of X) + (CONSTANT (IQUOTIENT \MDSIncrement WORDSPERPAGE] + \TT.TYPEMASK]) (\TYPEMASK.UFN + [LAMBDA (X N) (* lmm "22-Mar-85 16:37") + (COND + ((NEQ 0 (LOGAND N (LRSH [\GETBASE \MDSTypeTable (FOLDLO (fetch (POINTER PAGE#) + of X) + (CONSTANT (IQUOTIENT \MDSIncrement + WORDSPERPAGE] + 8))) + X]) (\TYPEP.UFN + [LAMBDA (X N) (* lmm "22-Mar-85 10:07") + (COND + ((EQ (NTYPX X) + N) + X]) (\ALLOCMDSPAGE + [LAMBDA (TYP) (* ; "Edited 25-Apr-94 10:39 by jds") + (PROG (VP VPTR) + BEG [COND + [(SETQ VP \MDSFREELISTPAGE) + (SETQ VPTR (create POINTER + PAGE# _ VP)) + (PROG ((NXT (\GETBASEPTR VPTR 0))) + (COND + ((AND NXT (NOT (SMALLP NXT))) + (\MP.ERROR \MP.BADMDSFREELIST "MDS Free Page link bad. ^N to continue" + (PROG1 \MDSFREELISTPAGE (SETQ \MDSFREELISTPAGE))) + (GO BEG)) + (T (SETQ \MDSFREELISTPAGE NXT] + (T (\CHECKFORSTORAGEFULL) + (SETQ VP \NxtMDSPage) + [UNLESSINEW (\PUTBASEFIXP \NxtMDSPage 0 (IDIFFERENCE VP (FOLDLO \MDSIncrement + PAGESPERSEGMENT))) + (SETQ \NxtMDSPage (IDIFFERENCE VP (FOLDLO \MDSIncrement PAGESPERSEGMENT] + (* ; "Allocates 2 MDS pages") + (SETQ VPTR (create POINTER + PAGE# _ VP)) + (\NEWPAGE (\ADDBASE (\NEWPAGE VPTR) + WORDSPERPAGE] + (\MAKEMDSENTRY VP TYP) + (RETURN VPTR]) (\ALLOCPAGEBLOCK + [LAMBDA (NPAGES) (* ejs%: "11-Aug-85 15:02") + (UNINTERRUPTABLY + + (* ;; "Allocates a continguous chunk of NPAGES pages. Currently there is no provision for giving them back.") + + (LET ((RESULT (\ALLOCVIRTUALPAGEBLOCK NPAGES))) + (COND + (RESULT (to NPAGES as (BASE _ RESULT) by (\ADDBASE BASE WORDSPERPAGE) + do (* ; + "Allocate the new pages. Leave them having the default type, namely type 0, don't refcnt") + (\NEWPAGE BASE)) + RESULT))))]) (\ALLOCVIRTUALPAGEBLOCK + [LAMBDA (NPAGES) (* ; "Edited 4-Jan-93 02:03 by jds") + (UNINTERRUPTABLY + + (* ;; "Allocates a continguous chunk of NPAGES virtual pages. Does not actually allocate the memory, just removes them from the set of pages that the allocator will use") + + (PROG (FIRSTPAGE) + (COND + ([ILEQ (IPLUS \NxtArrayPage \GUARDSTORAGEFULL) + (SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \NxtMDSPage \PagesPerMDSUnit) + (SETQ NPAGES (CEIL NPAGES \PagesPerMDSUnit] + (* ; "Plenty of space") + (\PUTBASEFIXP \NxtMDSPage 0 (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit))) + [(NEQ (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE)) + \SFS.SWITCHABLE) + (COND + ([AND (EQ \STORAGEFULLSTATE \SFS.ARRAYSWITCHED) + (ILESSP (IPLUS \SecondArrayPage \GUARDSTORAGEFULL) + (SETQ FIRSTPAGE (IDIFFERENCE (IPLUS \SecondMDSPage \PagesPerMDSUnit + ) + NPAGES] + + (* ;; "Arrays have been switched, but we're still allocating MDS in low space. Just bump the variable that says where MDS in high space will start") + + (\PUTBASEFIXP \SecondMDSPage 0 (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit))) + (T (* ; "Can't switch to the higher area") + (RETURN NIL] + ((ILESSP \NxtArrayPage FIRSTPAGE) (* ; + "Safe to go ahead anyway. We'll be pretty short of space in the first 8mb, but it's switchable") + (\PUTBASEFIXP \NxtMDSPage 0 (IDIFFERENCE FIRSTPAGE \PagesPerMDSUnit))) + ((ILESSP (IPLUS (SETQ FIRSTPAGE \SecondArrayPage) + NPAGES) + \SecondMDSPage) + + (* ;; "There is space in upper area. So advance the pointer that says where array space will start when we switch later on") + + (\PUTBASEFIXP \SecondArrayPage 0 (IPLUS FIRSTPAGE NPAGES)) + (replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535)) + (T (RETURN NIL))) + (RETURN (create POINTER + PAGE# _ FIRSTPAGE))))]) (\MAPMDS +(LAMBDA (TYPE FN) (* ; "Edited 19-Oct-94 09:29 by sybalsky") (* ;;; "Applies FN to each virtual page number that is of type TYPE, or to all MDS pages if TYPE is NIL") (OR (NULL TYPE) (FIXP TYPE) (SETQ TYPE (\TYPENUMBERFROMNAME TYPE))) (CHECK (EQ (FOLDLO \MDSIncrement PAGESPERSEGMENT) 2)) (* ; "I'd put this FOLDLO as the increment in the FOR below, but the translation is atrocious") (for I from 0 to (COND ((EQ \STORAGEFULLSTATE \SFS.FULLYSWITCHED) 1) (T 0)) bind TYP do (* ;; "This is pretty grody because of the two different regions MDS can live in. Could just do everything from (IMIN \NxtMDSPage \LeastMDSPage) to \MaxMDSPage but waste time on the stuff in between") (for VP from (COND ((EQ I 0) (IMIN \NxtMDSPage \LeastMDSPage)) (T \NxtMDSPage)) by 2 to (COND ((EQ I 0) \DefaultSecondArrayPage) (T \MaxMDSPage)) do (* ;; "We could just access \MDSTypeTable directly here, but since NTYPX should be ucoded, we benefit by 'modularizing' this access.") (COND ((OR (EQ (SETQ TYP (NTYPX (create POINTER PAGE# _ VP))) TYPE) (AND (NULL TYPE) (NEQ TYP 0) (NEQ TYP \SMALLP))) (SPREADAPPLY* FN VP)))))) +) (\CHECKFORSTORAGEFULL + [LAMBDA (NPAGES) (* ; "Edited 4-Jan-93 02:04 by jds") + (DECLARE (GLOBALVARS \INTERRUPTSTATE \PENDINGINTERRUPT)) + +(* ;;; "Take appropriate action if storage is getting full. NPAGES is size of attempted allocation or NIL for MDS requests. Complications here because array space and MDS grow toward each other in two separate areas: the first 8MB of vmem and the remaining 24MB. Some machines cannot use the latter, so have to signal storage full when the first fills up. Other machines have to know when to switch over. Array space usually gets switched to the high segment before MDS, since MDS can eat the lo space in small increments all the way to the end --- Returns T if storage is ok, 0 if storage is ok but \NxtArrayPage changed, and NIL if storage is nearly full") + + (UNINTERRUPTABLY + [PROG (PAGESLEFT) + (RETURN (COND + ((OR (ILESSP (SETQ PAGESLEFT (IPLUS (IDIFFERENCE \NxtMDSPage \NxtArrayPage) + \PagesPerMDSUnit)) + \GUARDSTORAGEFULL) + NPAGES) + (SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE)) + ((LIST \SFS.NOTSWITCHABLE \SFS.FULLYSWITCHED) + (COND + ((ILESSP PAGESLEFT 0) + (while T do (\MP.ERROR \MP.MDSFULL + "Storage completely full"))) + ((AND (ILEQ PAGESLEFT \GUARD1STORAGEFULL) + (NEQ \STORAGEFULL 0)) + (SETQ \STORAGEFULL 0) + (\MP.ERROR \MP.MDSFULLWARNING + "Space getting VERY full. Please save and reload a.s.a.p. Type control-N to continue now." + )) + ((NOT \STORAGEFULL) + (SETQ \STORAGEFULL T) (* ; "Note this is uninterruptable") + (replace STORAGEFULL of \INTERRUPTSTATE with + T) + (SETQ \PENDINGINTERRUPT T))) + (\DORECLAIM) + NIL) + (\SFS.SWITCHABLE (* ; + "We have verified that we can use the full 32MB, but haven't switched there yet") + (OR [COND + [(NULL NPAGES) (* ; "Want MDS") + (COND + ((ILEQ PAGESLEFT 0) + (\PUTBASEFIXP \LeastMDSPage 0 \NxtArrayPage) + (\PUTBASEFIXP \NxtMDSPage 0 \SecondMDSPage) + (\ADVANCE.STORAGE.STATE \SFS.FULLYSWITCHED) + (\ADVANCE.ARRAY.SEGMENTS \SecondArrayPage] + (T (* ; "Want array space") + (COND + ((IGREATERP NPAGES PAGESLEFT) + (* ; + "Have to switch array space over, but leave MDS to fill the rest of the low pages") + (\PUTBASEFIXP \LeastMDSPage 0 \NxtArrayPage) + (\ADVANCE.STORAGE.STATE \SFS.ARRAYSWITCHED) + (\ADVANCE.ARRAY.SEGMENTS \SecondArrayPage] + T)) + (\SFS.ARRAYSWITCHED + (COND + ((ILESSP \NxtMDSPage \LeastMDSPage) + (* ; + "Finally used up lo MDS, so switch over to hi") + (\PUTBASEFIXP \NxtMDSPage 0 \SecondMDSPage) + (\ADVANCE.STORAGE.STATE \SFS.FULLYSWITCHED) + T) + ((AND NPAGES (IGEQ (IPLUS NPAGES \GUARDSTORAGEFULL) + (IDIFFERENCE \SecondMDSPage \NxtArrayPage))) + + (* ;; "MDS still in lo area, arrays in hi area, and we're asking for too big an array! Unlikely, but handle it as a storage full case") + + NIL) + (T T))) + (SHOULDNT])]) (\DOSTORAGEFULLINTERRUPT + [LAMBDA NIL (* bvm%: "13-Feb-85 16:28") + (replace STORAGEFULL of \INTERRUPTSTATE with NIL) + (PROG ((HELPFLAG 'BREAK!)) + (LISPERROR "STORAGE FULL" '"save your work & reload a.s.a.p." T]) (\SET.STORAGE.STATE + [LAMBDA NIL (* bvm%: "12-Aug-85 14:46") + (PROG1 (SETQ \STORAGEFULLSTATE (COND + ((SELECTC \MACHINETYPE + (\DOLPHIN NIL) + (\DANDELION (NEQ 0 (fetch (IFPAGE DL24BitAddressable) + of \InterfacePage))) + T) (* ; "we can use high addresses") + \SFS.SWITCHABLE) + (T \SFS.NOTSWITCHABLE))) + (push \SYSTEMCACHEVARS '\STORAGEFULLSTATE) (* ; + "Want to recompute this if we come back from logout") + )]) (\SETTYPEMASK + [LAMBDA (NTYPX BITS) + (PROG ((DTD (\GETDTD NTYPX))) + (change (fetch DTDTYPEENTRY of DTD) + (LOGOR DATUM BITS)) + (\MAPMDS NTYPX (FUNCTION (LAMBDA (PAGE) + (\PUTBASE \MDSTypeTable (SETQ PAGE (FOLDLO PAGE + (IQUOTIENT + \MDSIncrement + + WORDSPERPAGE + ))) + (LOGOR (\GETBASE \MDSTypeTable PAGE) + BITS]) (\ADVANCE.STORAGE.STATE + [LAMBDA (FLG) (* bvm%: " 9-Jan-85 15:30") + + (* ;; "Bump the flag that tells what state storage allocation is in with respect to the 8MB -- 32MB distinction. Also remove flag from \SYSTEMCACHEVARS since it can no longer get recomputed") + + (SETQ \STORAGEFULLSTATE FLG) + (replace (IFPAGE FullSpaceUsed) of \InterfacePage with 65535) + (SETQ \SYSTEMCACHEVARS (DREMOVE '\STORAGEFULLSTATE \SYSTEMCACHEVARS]) (\NEW2PAGE + [LAMBDA (BASE) (* edited%: " 6-SEP-83 16:05") + (\NEWPAGE (\ADDBASE (\NEWPAGE BASE) + WORDSPERPAGE]) (\MAKEMDSENTRY + [LAMBDA (VP V) (* ; + "Edited 25-Oct-92 23:12 by sybalsky:mv:envos") + + (* ;; "Set up the MDE-type-table entry for page VP. Set the bits in V (e.g., the bit that says %"I'm a number%")") + + (\PUTBASE \MDSTypeTable (LRSH VP 1) + (COND + ((\GCDISABLED) + (LOGOR \TT.NOREF V)) + (T V]) (\INITMDSPAGE + [LAMBDA (BASE SIZE PREV) (* bvm%: " 6-Jan-85 22:24") + +(* ;;; "chain free list thru page at BASE of items SIZE long --- return last element") + + (PROG ((SLOP (IREMAINDER WORDSPERPAGE SIZE)) + NPAGES LIMIT) + + (* ;; "Refinement, mostly for benefit of hunking: try to keep objects from straddling page boundaries. SLOP is how much is left over on a page after you have filled it with objects. If this SLOP is less than half the size of an object, then you can start your next allocation at the beginning of the next page without any loss. Thus, the algorithm here either allocates several pages individually, or treats the entire expanse as one big block to slice up. Computation here assumes \MDSIncrement is 2 pages. Might want to have the AND test actually be a flag in the DTD once and for all") + + (COND + ((AND (NEQ SLOP 0) + (ILESSP SLOP (LRSH SIZE 1)) + (ILESSP SIZE WORDSPERPAGE)) (* ; + "Make everyone start at page boundaries. Third condition needed for datatypes bigger than a page") + (SETQ NPAGES (IQUOTIENT \MDSIncrement WORDSPERPAGE)) + (SETQ LIMIT WORDSPERPAGE)) + (T (SETQ NPAGES 1) + (SETQ LIMIT \MDSIncrement))) + (to NPAGES do (for (DISP _ 0) while (ILEQ (add DISP SIZE) + LIMIT) + do (\PUTBASEPTR BASE 0 PREV) + (SETQ PREV BASE) + (SETQ BASE (\ADDBASE BASE SIZE))) + (SETQ BASE (\ADDBASE BASE SLOP))) + (RETURN PREV]) (\ASSIGNDATATYPE1 + [LAMBDA (NAME DESCRIPTORS SIZE SPECS PTRFIELDS SUPERTYPE) + (* ; "Edited 2-Apr-91 00:32 by sybalsky") + +(* ;;; "Declare type NAME to have the indicated DESCRIPTORS, SIZE (in words), SPECS (type specifiers for FETCHFIELD), PTRFIELDS (list of offsets of fields that contain reference-counted pointers) and SUPERTYPE (a type number that shares an initial prefix of DESCRIPTORS with us, or NIL). Returns two values: the type number assigned, and whether the type was redeclared in the process.") + + (PROG ((NTYPX (\TYPENUMBERFROMNAME NAME)) + (SUPERTYPENUMBER (COND + (SUPERTYPE (OR (\TYPENUMBERFROMNAME SUPERTYPE) + (ERROR SUPERTYPE + ":INCLUDEd datatype but not currently declared") + )) + (T 0))) + DTD REDECLARED NEWTYPENUM NEWDTD) + [COND + (NTYPX (* ; + "a datatype of this name already allocated") + (SETQ DTD (\GETDTD NTYPX)) + (COND + ((AND (EQUAL PTRFIELDS (fetch DTDPTRS of DTD)) + (EQUAL SIZE (fetch DTDSIZE of DTD))) + (* ; "has same shape, can reuse DTD") + (replace DTDDESCRS of DTD with DESCRIPTORS) + (replace DTDSUPERTYPE of DTD with SUPERTYPENUMBER) + (RETURN NTYPX)) + ((EQ (fetch DTDSIZE of DTD) + 0) (* ; + "Type name to number is assigned, but no declaration yet -- proceed to allocate this type number") + ) + ([OR (EQ CROSSCOMPILING T) + (AND CROSSCOMPILING (NEQ 'Y (ASKUSER 30 (SELECTQ CROSSCOMPILING + (Y 'Y) + 'N) + (LIST (COND + (SIZE + "OK TO REDECLARE DATATYPE " + ) + (T + "OK to deallocate DATATYPE " + )) + NAME] + (* ; "don't redeclare") + (RETURN NTYPX)) + ((IGREATERP NTYPX \MaxSysTypeNum) (* ; + "Can redeclare 'user' types, i.e., anything not in the makeinit") + (SETQ REDECLARED T)) + (T (* ; "can't mess with sys types") + (ERROR "ILLEGAL DATA TYPE" NAME] + + (* ;; "If we get this far, we're about to create a for-real new datatype (we may need to deallocate the old version of this one...)") + + (COND + ((NOT SIZE) (* ; + "only called to deallocate old datatype") + ) + (T (COND + ((AND (EQ \MaxTypeNumber \EndTypeNumber) + (OR (NULL NTYPX) + REDECLARED)) + (LISPERROR "DATA TYPES FULL" NAME))) + (UNINTERRUPTABLY + [COND + ((OR (NULL NTYPX) + REDECLARED) (* ; + "Bump the global count of types assigned, and grab the latest.") + (SETQ NEWTYPENUM (add \MaxTypeNumber 1)) + (SETQ NEWDTD (\GETDTD NEWTYPENUM)) (* ; "Build a new DTD for it.") + (COND + ((IGEQ (IPLUS (fetch WORDINPAGE of NEWDTD) + \DTDSize) + WORDSPERPAGE) (* ; + "if this is the last one which would fit on a page, create a new page") + (\NEWPAGE (\ADDBASE NEWDTD \DTDSize) + T))) + (COND + [REDECLARED + + (* ;; "When redeclaring a datatype, have to change the type of all old instances to be a new obsoleted type so that the garbage collector will still collect them properly. Keep the original type number, because the name -> type number mapping has already happened to compiled code") + + (LET ([NEWTYPEENTRY (LOGOR NEWTYPENUM (LOGAND (fetch + DTDTYPEENTRY + of DTD) + (LOGNOT \TT.TYPEMASK] + FOUNDSOME) + [\MAPMDS NTYPX (FUNCTION (LAMBDA (PAGE) + (\MAKEMDSENTRY PAGE + NEWTYPEENTRY) + (SETQ FOUNDSOME T] + (COND + ((NOT FOUNDSOME) + + (* ;; "Optimization: if no objects of the old type have been allocated (or all have been reclaimed and the pages detyped), then don't need a new type number for them") + + (add \MaxTypeNumber -1)) + (T (replace DTDDESCRS of DTD with NIL) + (replace DTDTYPESPECS of DTD with NIL) + (\BLT NEWDTD DTD \DTDSize) + + (* ;; "Copy old DTD to new. Be careful about the pointer fields -- we haven't incremented their reference counts. Those fields are DTDDESCRS, DTDTYPESPECS and DTDPTRS, the first two of which we have conveniently smashed to NIL before copying.") + + (\ADDREF (fetch DTDPTRS of NEWDTD)) + (replace DTDOBSOLETE of NEWDTD with T) + (replace DTDTYPEENTRY of NEWDTD with + NEWTYPEENTRY + ) + [replace DTDNAME of NEWDTD + with (NEW-SYMBOL-CODE (PACK* "Obsolete-" NAME) + (\ATOMPNAMEINDEX (PACK* "Obsolete-" + NAME] + (replace DTDFREE of DTD with NIL) + (* ; + "Replacement type has no free list--just the old type, now in NEWDTD") + ] + (T (* ; "Normal case of a new type") + (SETQ NTYPX NEWTYPENUM) + (replace DTDNAME of (SETQ DTD NEWDTD) + with (NEW-SYMBOL-CODE NAME (\ATOMPNAMEINDEX NAME] + (COND + ((NEQ SIZE 0) (* ; + "If the datum takes up any space, remember what it looks like inside") + (replace DTDSIZE of DTD with SIZE) + (replace DTDDESCRS of DTD with (COPY DESCRIPTORS)) + (replace DTDTYPESPECS of DTD with (COPY SPECS)) + (replace DTDPTRS of DTD with PTRFIELDS) + (replace DTDSUPERTYPE of DTD with SUPERTYPENUMBER) + (replace DTDTYPEENTRY of DTD with NTYPX) + (* ; + "The type-masked type#, for fast type checking") + )) + + (* ;; + "NOTE: If the redeclared type has subtypes, we have to redeclare them, too!") + + ) + (RETURN (CL:VALUES NTYPX REDECLARED]) (\RESOLVE.TYPENUMBER + [LAMBDA (TYPENAME) (* bvm%: "13-Jun-86 16:11") + +(* ;;; "For the loader. Returns a type number for TYPENAME, possibly allocating a new type number (but not declaring it) if the type does not yet exist.") + + (COND + ((AND TYPENAME (LITATOM TYPENAME)) + (OR (\TYPENUMBERFROMNAME TYPENAME) + (\ASSIGNDATATYPE1 TYPENAME NIL 0))) + (T (\ILLEGAL.ARG TYPENAME]) (\TYPENUMBERFROMNAME + [LAMBDA (TYPE) (* ; "Edited 2-Apr-91 15:48 by sybalsky") + (AND TYPE (BIND (INDEX _ (NEW-SYMBOL-CODE TYPE (\ATOMPNAMEINDEX TYPE))) for I + from 1 to \MaxTypeNumber do (COND + ((EQ INDEX (fetch DTDNAME + of (\GETDTD I))) + (RETURN I]) (CREATECELL + [LAMBDA (TYP) (* lmm "10-DEC-82 15:49") + (\CREATECELL TYP]) (\CREATECELL + [LAMBDA (TYP) (* ; "Edited 25-Apr-94 10:37 by jds") + (COND + ((AND (NEQ CDRCODING 0) + (EQ TYP \LISTP)) + (RAID "CREATECELL \LISTP"))) + + (* ;; "For the real sysout, this must be the opcode CREATECELL, so we don't have to have the lisp versi9ons of NEWPAGE &c track the C. JDS 4/25/94") + + (UNLESSINEW (CREATECELL TYP) + (LET ((DTD (\GETDTD TYP)) + NEWCELL) + (while (EQ (fetch DTDSIZE of DTD) + 0) do (ERROR "Attempt to CREATE a type not declared yet" + (\TYPENAMEFROMNUMBER TYP))) + (UNINTERRUPTABLY + (COND + ((SETQ NEWCELL (fetch DTDFREE of DTD)) + (CHECK (EQ TYP (NTYPX NEWCELL))) + (replace DTDFREE of DTD with (\GETBASEPTR NEWCELL 0)) + (\StatsAdd1 (LOCF (fetch DTDOLDCNT of DTD))) + (LET [(CNT (SUB1 (fetch DTDSIZE of DTD] + (* ; "Clear object") + (\PUTBASE NEWCELL CNT 0) + (\BLT NEWCELL (\ADDBASE NEWCELL 1) + CNT)) + (\CREATEREF NEWCELL) + NEWCELL) + (T + (* ;; "Free list exhausted. Replenish it, then do a CREATECELL, hopefully getting the microcode to do most of the work.") + + (* ;; "Note: it is possible, albeit unlikely, that \ALLOCMDSPAGE will eventually cause a CREATECELL to occur. Hence, DTD:DTDFREE might possibly be non-NIL by the time we get back here, which is why it is included below.") + + (* ;; "Don't understand this remark -- if CREATECELL gets called for this type before we have stored DTDFREE then are we just hoping the recursion eventually stops? Remark might apply for the old implementation where CREATECELL for a random type fixes everyone's free list, but again I'm not sure why. -bvm 5/86") + + (replace DTDFREE of DTD with (\INITMDSPAGE + (\ALLOCMDSPAGE (fetch + DTDTYPEENTRY + of + DTD)) + (fetch DTDSIZE of DTD) + (fetch DTDFREE of DTD))) + (CREATECELL TYP))))]) ) (* ;; "For NEW_STORAGE option was set in Maiko, then \maiko.set.storage.state is active") (DEFINEQ (\MAIKO.SET.STORAGE.STATE + [LAMBDA NIL (* ; "Edited 24-May-90 19:11 by Takeshi") + (COND + ((EQ (FETCH (IFPAGE DL24BitAddressable) OF \InterfacePage) + 0) + (SETQ \STORAGEFULLSTATE \SFS.NOTSWITCHABLE)) + (T (SETQ \STORAGEFULLSTATE \SFS.SWITCHABLE))) + (PUSH \SYSTEMCACHEVARS '\STORAGEFULLSTATE) + \STORAGEFULLSTATE]) ) (AND (EQ \MACHINETYPE \MAIKO) (MOVD '\MAIKO.SET.STORAGE.STATE '\SET.STORAGE.STATE)) (RPAQ? CROSSCOMPILING ) (RPAQ? ASSIGNDATATYPE.ASKUSERWAIT 300) (RPAQ? \STORAGEFULLSTATE ) (RPAQ? \STORAGEFULL ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CROSSCOMPILING \STORAGEFULLSTATE \STORAGEFULL \SYSTEMCACHEVARS \NxtArrayPage) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS ASSIGNDATATYPE.ASKUSERWAIT) ) (* ; "fetch and replace") (DEFINEQ (FETCHFIELD + [LAMBDA (DESCRIPTOR DATUM) (* edited%: " 7-JUN-83 10:23") + + (* ;; "retrieves a data field from a user data structure.") + + (PROG ((TN (fetch fdTypeName of DESCRIPTOR)) + (OFFSET (fetch fdOffset of DESCRIPTOR))) + (AND TN (SETQ DATUM (\DTEST DATUM TN))) + (RETURN (SELECTQ (fetch fdType of DESCRIPTOR) + ((POINTER XPOINTER FULLPOINTER FULLXPOINTER) + (\GETBASEPTR DATUM OFFSET)) + (FLOATP (MAKEFLOATNUMBER (\GETBASE DATUM OFFSET) + (\GETBASE (\ADDBASE DATUM 1) + OFFSET))) + (FIXP (\MAKENUMBER (\GETBASE DATUM OFFSET) + (\GETBASE (ADDBASE DATUM 1) + OFFSET))) + (SWAPPEDFIXP (\MAKENUMBER (\GETBASE (\ADDBASE DATUM 1) + OFFSET) + (\GETBASE DATUM OFFSET))) + (PROG ((FT (fetch fdType of DESCRIPTOR)) + (OFF OFFSET)) + (RETURN (SELECTQ (CAR FT) + (BITS (LOGAND (LRSH (\GETBASE DATUM OFF) + (BitFieldShift (CDR FT))) + (BitFieldMask (CDR FT)))) + (SIGNEDBITS ([LAMBDA (N WIDTH) + (COND + [[IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH] + (SUB1 (IDIFFERENCE N + (SUB1 (LLSH 1 WIDTH] + (T N] + (LOGAND (LRSH (\GETBASE DATUM OFF) + (BitFieldShift (CDR FT))) + (BitFieldMask (CDR FT))) + (BitFieldWidth (CDR FT)))) + (LONGBITS (\MAKENUMBER (LOGAND (LRSH (\GETBASE DATUM OFF) + (BitFieldShift + (CDR FT))) + (BitFieldMask (CDR FT))) + (\GETBASE (ADDBASE DATUM 1) + OFF))) + (FLAGBITS (NEQ (LOGAND (\GETBASE DATUM OFF) + (BitFieldShiftedMask (CDR FT))) + 0)) + (LISPERROR "ILLEGAL ARG" DESCRIPTOR]) (REPLACEFIELD + [LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* lmm " 1-Jan-85 23:09") + (* ; + "replace a field in a user data structure. return coerced value.") + (PROG ((OFFSET (fetch fdOffset of DESCRIPTOR)) + (FT (fetch fdType of DESCRIPTOR)) + (TN (fetch fdTypeName of DESCRIPTOR)) + SHIFT MASK) + (AND TN (SETQ DATUM (\DTEST DATUM TN))) + (RETURN + (SELECTQ FT + ((POINTER FULLPOINTER) + (\RPLPTR DATUM OFFSET NEWVALUE)) + (XPOINTER (* ; "no ref count, hi bits used") + (PUTBASEPTRX DATUM OFFSET NEWVALUE)) + (FULLXPOINTER (\PUTBASEPTR DATUM OFFSET NEWVALUE)) + (FLOATP (\PUTBASEFLOATP DATUM OFFSET NEWVALUE)) + (FIXP (\PUTFIXP (\ADDBASE DATUM OFFSET) + NEWVALUE) + NEWVALUE) + (SWAPPEDFIXP (\PUTSWAPPEDFIXP (\ADDBASE DATUM OFFSET) + NEWVALUE) + NEWVALUE) + (SELECTQ (CAR FT) + (BITS (LOGAND (LRSH (\PUTBASE DATUM OFFSET + (LOGOR [LOGAND (\GETBASE DATUM OFFSET) + (LOGXOR 65535 + (LLSH (SETQ MASK + (BitFieldMask (CDR FT))) + (SETQ SHIFT + (BitFieldShift (CDR FT] + (LLSH (LOGAND NEWVALUE MASK) + SHIFT))) + SHIFT) + MASK)) + (SIGNEDBITS ([LAMBDA (X) + (COND + [[IGREATERP X (SUB1 (LLSH 1 (SUB1 (BitFieldWidth (CDR FT] + (SUB1 (IDIFFERENCE X (SUB1 (LLSH 1 (BitFieldWidth (CDR FT] + (T X] + (LOGAND + (LRSH + (\PUTBASE + DATUM OFFSET + (LOGOR [LOGAND (\GETBASE DATUM OFFSET) + (LOGXOR 65535 (LLSH (SETQ MASK (BitFieldMask + (CDR FT))) + (SETQ SHIFT (BitFieldShift + (CDR FT] + (LLSH (LOGAND [LOGAND NEWVALUE + (SUB1 (LLSH 1 (BitFieldWidth + (CDR FT] + MASK) + SHIFT))) + SHIFT) + MASK))) + (FLAGBITS (\PUTBASE DATUM OFFSET (LOGOR [LOGAND + (\GETBASE DATUM OFFSET) + (LOGXOR 65535 + (LLSH (SETQ MASK + (BitFieldMask (CDR FT))) + (SETQ SHIFT + (BitFieldShift (CDR FT] + (LLSH (LOGAND (COND + (NEWVALUE 65535) + (T 0)) + MASK) + SHIFT))) + (AND NEWVALUE T)) + (LONGBITS (PROG (LO HI) + (.UNBOX. NEWVALUE HI LO) + (UNINTERRUPTABLY + (\PUTBASE DATUM OFFSET + (LOGOR [LOGAND (\GETBASE DATUM OFFSET) + (LOGXOR 65535 + (LLSH (SETQ MASK + (BitFieldMask (CDR FT))) + (SETQ SHIFT + (BitFieldShift (CDR FT] + (LLSH (LOGAND HI MASK) + SHIFT))) + (\PUTBASE DATUM (ADD1 OFFSET) + LO))) + NEWVALUE) + (LISPERROR "ILLEGAL ARG" DESCRIPTOR]) (BOXCOUNT + [LAMBDA (TYPE N) (* lmm "20-OCT-81 20:27") + (PROG [(DTD (\GETDTD (OR (SMALLP TYPE) + (COND + ((NULL TYPE) + \FIXP) + (T (\TYPENUMBERFROMNAME TYPE] + (RETURN (PROG1 (fetch DTDCNT of DTD) + (AND (NUMBERP N) + (replace DTDCNT of DTD with N)))]) (CONSCOUNT + [LAMBDA (N) (* lmm "13-MAY-80 23:02") + (BOXCOUNT \LISTP N]) (\DTEST + [LAMBDA (OBJ TYPE) (* lmm "22-Mar-85 12:29") + (\DTEST.UFN OBJ TYPE]) (\TYPECHECK + [LAMBDA (OBJ TYPE) (* lmm "22-Mar-85 12:29") + (\DTEST.UFN OBJ TYPE]) (\DTEST.UFN + [LAMBDA (OBJ TYPEN) (* gbn " 3-Oct-86 10:49") + + (* ;; "ufn for DTEST opcode ") + + (* ;; "coerce into desired type") + + (PROG ((N (NTYPX OBJ))) + LP (COND + ((EQ (fetch DTDNAME of (\GETDTD N)) + TYPEN) (* ; + "should be happening in microcode") + (RETURN OBJ)) + ([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N] + (GO LP)) + (T (RETURN (SELECTQ (\INDEXATOMPNAME TYPEN) + (FLOATP (\FLOAT OBJ)) + (STREAM (* ; + "Should be able to get at the INPUT/OUTPUT flg--a second arg to \DTEST ?") + (\GETSTREAM OBJ (SELECTQ (STKNTHNAME -1 '\DTEST.UFN) + ((\BINS \BIN BIN) + 'INPUT) + ((\BOUTS \BOUT BOUT) + 'OUTPUT) + NIL))) + (HARRAYP (DECLARE (GLOBALVARS SYSHASHARRAY)) + (COND + [(NULL OBJ) + (COND + (SYSHASHARRAY (\DTEST SYSHASHARRAY 'HARRAYP)) + (T (LISPERROR "ARG NOT HARRAY" OBJ T] + ((AND (LISTP OBJ) + (TYPENAMEP (CAR OBJ) + 'HARRAYP)) + (CAR OBJ)) + (T (LISPERROR "ARG NOT HARRAY" OBJ T)))) + (FONTDESCRIPTOR + (\COERCEFONTDESC OBJ)) + (SMALLP [PROG (HI LO) + (.UNBOX. OBJ HI LO) + (RETURN (OR (SMALLP (\MAKENUMBER HI LO)) + (LISPERROR "ILLEGAL ARG" OBJ T]) + (LISTP (LISPERROR "ARG NOT LIST" OBJ T)) + (LITATOM (LISPERROR "ARG NOT LITATOM" OBJ T)) + (STACKP (LISPERROR "ILLEGAL STACK ARG" OBJ T)) + (READTABLEP (LISPERROR "ILLEGAL READTABLE" OBJ T)) + (TERMTABLEP (LISPERROR "ILLEGAL TERMINAL TABLE" OBJ T)) + (ARRAYP (LISPERROR "ARG NOT ARRAY" OBJ T)) + (\DISPLAYDATA (* ; + "Should be able to get at the stream--a second arg to \DTEST ?") + (ERROR "ARG NOT DISPLAY STREAM" NIL)) + (\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN)) + T]) (\INSTANCEP.UFN + [LAMBDA (OBJ TYPEN) (* ; "Edited 2-Apr-91 00:40 by sybalsky") + +(* ;;; "ufn for INSTANCEP opcode") + + (PROG ((N (NTYPX OBJ))) + LP (NEW-SYMBOL-CODE (COND + ([AND (FIXP TYPEN) + (EQ (\VAG2 \AtomHI TYPEN) + (fetch DTDNAME of (\GETDTD N] + (RETURN T)) + ((EQ (fetch DTDNAME of (\GETDTD N)) + TYPEN) + (RETURN T)) + ([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N] + + (* ;; "recur on the supertype") + + (GO LP)) + (T (RETURN NIL))) + (COND + ((IEQP (fetch DTDNAME of (\GETDTD N)) + TYPEN) + (RETURN T)) + ([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N] + + (* ;; "recur on the supertype") + + (GO LP)) + (T (RETURN NIL]) (\INSTANCE-P + [LAMBDA (OBJECT TYPE) (* gbn "26-Sep-86 17:07") + + (* ;; "should be phased out in favor of calls to typenamep, which shares the definition.") + + (\INSTANCEP.UFN OBJECT (\ATOMPNAMEINDEX TYPE]) (\TYPECHECK.UFN + [LAMBDA (OBJ TYPEN) (* gbn "23-Sep-86 20:06") + + (* ;; "ufn for TYPECHECK opcode --- cause error if not of right type") + + (PROG ((N (NTYPX OBJ))) + LP (COND + ((EQ (fetch DTDNAME of (\GETDTD N)) + TYPEN) + (RETURN OBJ)) + ([NEQ 0 (SETQ N (fetch DTDSUPERTYPE of (\GETDTD N] + (GO LP)) + (T (RETURN (\LISPERROR OBJ (CONCAT "ARG NOT " (\INDEXATOMPNAME TYPEN)) + T]) (GETDESCRIPTORS + [LAMBDA (TYPENAME) (* lmm "21-Apr-85 15:10") + (PROG NIL + (RETURN (fetch DTDDESCRS of (\GETDTD (COND + ((LITATOM TYPENAME) + (OR (\TYPENUMBERFROMNAME TYPENAME) + (RETURN))) + (T (NTYPX TYPENAME]) (GETSUPERTYPE + [LAMBDA (TYPENAME) (* lmm "13-Mar-86 14:36") + + (* ;; "return the name of the supertype (i.e., the :INCLUDEd type) of a datatype if it has one, NIL otherwise") + + (LET ((NX (\TYPENUMBERFROMNAME TYPENAME))) + (COND + (NX (LET [(N (fetch DTDSUPERTYPE of (\GETDTD NX] + (COND + ((NEQ N 0) + (\TYPENAMEFROMNUMBER N)) + (T NIL]) (GETFIELDSPECS + [LAMBDA (TYPENAME) (* rmk%: "28-OCT-81 17:42") + (PROG NIL + (RETURN (COPY (fetch DTDTYPESPECS of (\GETDTD (COND + ((LITATOM TYPENAME) + (OR (\TYPENUMBERFROMNAME + TYPENAME) + (RETURN))) + (T (NTYPX TYPENAME]) (NCREATE + [LAMBDA (TYPE OLDOBJ) (* lmm "14-MAY-80 08:33") + (NCREATE2 (\TYPENUMBERFROMNAME TYPE) + OLDOBJ]) (NCREATE2 + [LAMBDA (NTYPX OLDOBJ) (* bvm%: " 5-Feb-85 16:43") + + (* ;; "a version of NCREATE which has is compiled from calls to NCREATE which have a quoted first arg and an old object. These can use the TYPE number variable in stead of having to look it up.") + + (PROG ((DTD (\GETDTD NTYPX)) + (NEW (CREATECELL NTYPX))) + [COND + ((EQ (NTYPX OLDOBJ) + NTYPX) + (UNINTERRUPTABLY + (\BLT NEW OLDOBJ (fetch DTDSIZE of DTD)) + (for P in (fetch DTDPTRS of DTD) + do (\ADDREF (\GETBASEPTR NEW P))))] + (RETURN NEW]) (REPLACEFIELDVAL + [LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* lmm%: "22-AUG-76 04:18:20") + + (* ;; "used by the record package-- compiles open better than saving datum") + + (REPLACEFIELD DESCRIPTOR DATUM NEWVALUE) + DATUM]) (PUTBASEPTRX + [LAMBDA (DATUM OFFSET NEWVALUE) (* ; "Edited 13-Jan-93 00:13 by jds") + + (* ;; + "Put the new value into an XPOINTER field. As of Medley 2.1/3.0, this is a 28-bit quantity.") + + (UNINTERRUPTABLY + (PUTBASE DATUM OFFSET (LOGOR (LOGAND 61440 (GETBASE DATUM OFFSET)) + (HILOC NEWVALUE))) + (PUTBASE DATUM (ADD1 OFFSET) + (LOLOC NEWVALUE)) + NEWVALUE)]) (/REPLACEFIELD + [LAMBDA (DESCRIPTOR DATUM NEWVALUE) (* lmm%: "23-AUG-76 00:01:53") + [AND LISPXHIST (UNDOSAVE (LIST '/REPLACEFIELD DESCRIPTOR DATUM (FETCHFIELD DESCRIPTOR DATUM] + (REPLACEFIELD DESCRIPTOR DATUM NEWVALUE]) (TYPENAME [LAMBDA (X) (* ; "Edited 28-Jun-99 16:56 by rmk:") (* ; "Edited 28-Jun-99 16:55 by rmk:") (* ; "Edited 11-Nov-98 12:14 by rmk:") (LET ((N (NTYPX X))) (COND ((EQ N \ARRAYP) (\ARRAYTYPENAME X)) ((%%STRINGP X) (* ;  "Common lisp strings report as STRINGP's.") 'STRINGP) ([EQ 'NEW-ATOM (SETQ N (\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N] (* ;; "Large atom space returns NEW-ATOM instead of LITATOM") 'LITATOM) (T N]) (TYPENAMEP + [LAMBDA (DATUM TYPE) (* ; "Edited 18-Dec-86 16:33 by jop") + (COND + ((EQ TYPE 'STRINGP) + (%%STRINGP DATUM)) + (T (\INSTANCEP.UFN DATUM TYPE]) (\TYPENAMEFROMNUMBER + [LAMBDA (N) (* lmm "13-FEB-83 14:13") + (COND + ((ILESSP N (ADD1 \MaxTypeNumber)) + (\INDEXATOMPNAME (fetch DTDNAME of (\GETDTD N]) (\BLOCKDATAP + [LAMBDA (X) (* JonL "22-Sep-84 23:15") + (PROG ((TYPENO (NTYPX X))) + (RETURN (COND + ((EQ 0 TYPENO) + (type? ARRAYBLOCK X)) + (T (fetch DTDHUNKP of (\GETDTD TYPENO]) (USERDATATYPES + [LAMBDA NIL (* rrb "16-JUL-80 13:17") + (DATATYPES T]) (DATATYPEP + [LAMBDA (DATATYPESPEC) (* bvm%: "12-Feb-85 17:29") + + (* ;; "returns the type name of a data type spec if it is a datatype.") + + (COND + [(SMALLP DATATYPESPEC) + (PROG ((DTD (\GETDTD DATATYPESPEC)) + NAME) + (RETURN (AND (NOT (fetch DTDHUNKP of DTD)) + (SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD))) + (NEQ NAME '**DEALLOC**) + NAME] + ((NOT (LITATOM DATATYPESPEC)) + NIL) + ((FMEMB DATATYPESPEC '(CCODEP HARRAYP)) (* ; + "handle subtypes of arrayp specially.") + DATATYPESPEC) + ((for I from 1 to \MaxTypeNumber thereis (EQ (\INDEXATOMPNAME + (fetch DTDNAME + of (\GETDTD I))) + DATATYPESPEC)) + DATATYPESPEC]) (DATATYPES + [LAMBDA (USERSFLG) (* rrb "16-JUL-80 13:20") + (bind N for I from (COND + (USERSFLG (ADD1 \MaxSysTypeNum)) + (T 1)) to \MaxTypeNumber when (SETQ N (DATATYPEP + I)) collect + N]) ) (MOVD? 'FETCHFIELD 'FFETCHFIELD NIL T) (MOVD? 'REPLACEFIELD 'FREPLACEFIELD NIL T) (MOVD? 'REPLACEFIELDVAL 'FREPLACEFIELDVAL NIL T) (DEFOPTIMIZER TYPENAMEP (DATUM TYPE &ENVIRONMENT ENV) (LET [(TYPE-NAME (CL:IF (AND (CL:CONSP TYPE) (EQ (CAR TYPE) 'QUOTE) (CL:SYMBOLP (CADR TYPE))) (CADR TYPE] (CL:IF [AND TYPE-NAME (NOT (EQ TYPE-NAME 'STRINGP] [COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES INSTANCEP 0 0 0 (ATOM \, (CADR TYPE))) ,DATUM] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `((OPCODES INSTANCEP 0 0 (ATOM \, (CADR TYPE))) ,DATUM] (T `((OPCODES INSTANCEP 0 (ATOM \, (CADR TYPE))) ,DATUM] 'COMPILER:PASS))) (DEFOPTIMIZER \INSTANCE-P (&BODY BODY &ENVIRONMENT ENV) (COND [[AND (EQ (CAADR BODY) 'QUOTE) (CL:SYMBOLP (CADR (CADR BODY] (COND [(FMEMB :4-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `([OPCODES INSTANCEP 0 0 0 (ATOM \, (CADR (CADR BODY] ,(CAR BODY] [(FMEMB :3-BYTE (COMPILER::ENV-TARGET-ARCHITECTURE ENV)) `([OPCODES INSTANCEP 0 0 (ATOM \, (CADR (CADR BODY] ,(CAR BODY] (T `([OPCODES INSTANCEP 0 (ATOM \, (CADR (CADR BODY] ,(CAR BODY] (T 'IGNOREMACRO))) (* ; "STORAGE") (DEFINEQ (STORAGE + [LAMBDA (TYPES PAGE-THRESHOLD IN-USE-THRESHOLD) (* ; "Edited 8-Jan-88 14:39 by bvm") + (PROG ((TOTALALLOCMDS (CREATECELL \FIXP)) + (TOTALHUNKS (CREATECELL \FIXP)) + (FREE (CREATECELL \FIXP)) + (HUNKSTATS (from 0 to 2 collect (create HUNKSTAT))) + TYPE TYPENAME DOBLOCKSFLG) + (DECLARE (SPECVARS HUNKSTATS)) + (printout NIL "Type" 17 "Assigned" 30 "Free items" 45 "In use" 55 "Total alloc" T 15 + "pages [items]" T) + (COND + [(AND TYPES (NEQ TYPES T)) + (for TYPE HFLG inside TYPES when [COND + ((FIXP TYPE) + (COND + ((OR (< TYPE 0) + (> TYPE \MaxTypeNumber)) + (* ; + "An explicit type number ought to be 'right'") + (ERROR "Not a type number" TYPE)) + ((EQ TYPE 0) + (SETQ DOBLOCKSFLG T) + NIL) + (T T))) + (T (SETQ TYPE (\TYPENUMBERFROMNAME + TYPE] + do (COND + ((fetch DTDHUNKP of (\GETDTD TYPE)) + (SETQ HFLG T))) + (\STORAGE.TYPE TYPE FREE TOTALALLOCMDS PAGE-THRESHOLD IN-USE-THRESHOLD) + finally (COND + (HFLG (\STORAGE.HUNKTYPE TOTALALLOCMDS PAGE-THRESHOLD + IN-USE-THRESHOLD] + (T (for I from 1 to \MaxTypeNumber + do (\STORAGE.TYPE I FREE TOTALALLOCMDS PAGE-THRESHOLD IN-USE-THRESHOLD)) + (\STORAGE.HUNKTYPE TOTALHUNKS PAGE-THRESHOLD IN-USE-THRESHOLD) + (printout NIL T "TOTAL" 15 .I5 (+ TOTALALLOCMDS TOTALHUNKS) + T T) + (printout NIL "Data Spaces Summary" T) + (printout NIL 30 "Allocated" 50 "Remaining" T) + (printout NIL 32 "Pages" 52 "Pages" T) + (printout NIL "Datatypes (incl. LISTP etc.)" 30 .I8 TOTALALLOCMDS 50 "\" T) + (* ; + "Arrayspace and MDS come out of the same pot, so lump their 'remaining' pages together") + (printout NIL "ArrayBlocks" (COND + ((NOT (= TOTALHUNKS 0)) + " (variable)") + (T "")) + 30 .I8 (SELECTC \STORAGEFULLSTATE + ((LIST \SFS.FULLYSWITCHED \SFS.ARRAYSWITCHED) + (+ (- \LeastMDSPage \FirstArrayPage) + (- \NxtArrayPage \SecondArrayPage))) + (- \NxtArrayPage \FirstArrayPage)) + 50 "--" .I6 (CAR (STORAGE.LEFT)) + T) + (COND + ((NOT (= TOTALHUNKS 0)) + (printout NIL "ArrayBlocks (chunked)" 30 .I8 TOTALHUNKS 50 "/" T))) + + (* ;; "\LastATOMpage marks off atom indexes as if they were word addresses; but the space behind a litatom is one cell in each of the four spaces: DEFSPACE, VALSPACE, PNAMESPACE, and PROPSPACE") + + (\STLINP "Symbols" (TIMES (FOLDHI \AtomFrLst CELLSPERPAGE) + 4) + (TIMES (UNFOLD (ADD1 \LastAtomPage) + WORDSPERCELL) + 4)) + (SETQ DOBLOCKSFLG T))) + (COND + (DOBLOCKSFLG (\SHOW.ARRAY.FREELISTS]) (STORAGE.LEFT + [LAMBDA NIL (* ; + "Edited 18-Aug-93 14:28 by sybalskY:MV:ENVOS") + +(* ;;; "Return a list MDS+Arrays left in 8mb, in 24mb, litatoms left, pnames left and the same as fractions") + + (PROG ((MDSFREE (IPLUS (IDIFFERENCE (SELECTC (OR \STORAGEFULLSTATE (\SET.STORAGE.STATE)) + (\SFS.ARRAYSWITCHED + + (* ;; "There's free space in two places: some leftover MDS in the lo region, and the space beyond allocated arrays in the hi") + + \SecondMDSPage) + \NxtMDSPage) + \NxtArrayPage) + \PagesPerMDSUnit + (SELECTC \STORAGEFULLSTATE + (\SFS.SWITCHABLE (* ; + "We have another 24MB to work with") + (IPLUS (IDIFFERENCE \SecondMDSPage \SecondArrayPage) + \PagesPerMDSUnit)) + (\SFS.ARRAYSWITCHED (* ; + "Account for the space left behind after array allocation moved") + (IPLUS (IDIFFERENCE \NxtMDSPage \LeastMDSPage) + \PagesPerMDSUnit)) + 0) + (for (FREE _ \MDSFREELISTPAGE) + by (SMALLP (\GETBASEPTR (create POINTER + PAGE# _ FREE) + 0)) while FREE sum 1))) + (ATOMTOTAL (ITIMES (UNFOLD (ADD1 \LastAtomPage) + WORDSPERCELL) + 4)) + ATOMSLEFT MDSFRAC) + [SETQ MDSFRAC (FQUOTIENT MDSFREE (IPLUS (IDIFFERENCE (IPLUS \FirstMDSPage \PagesPerMDSUnit) + \FirstArrayPage) + (COND + ((EQ \STORAGEFULLSTATE \SFS.NOTSWITCHABLE) + 0) + (T (IDIFFERENCE (IPLUS \SecondMDSPage + \PagesPerMDSUnit) + \SecondArrayPage] + (RETURN (LIST MDSFREE MDSFRAC (SELECTC \STORAGEFULLSTATE + (\SFS.NOTSWITCHABLE + MDSFRAC) + (\SFS.SWITCHABLE + (FQUOTIENT (IDIFFERENCE (IPLUS \NxtMDSPage + \PagesPerMDSUnit) + \NxtArrayPage) + (IDIFFERENCE (IPLUS \FirstMDSPage + \PagesPerMDSUnit) + \FirstArrayPage))) + 0]) (\STORAGE.TYPE + [LAMBDA (TYPE FREE TOTALALLOCMDS PAGE-THRESHOLD IN-USE-THRESHOLD) + (* ; "Edited 8-Jan-88 14:39 by bvm") + (DECLARE (USEDFREE HUNKSTATS)) + (PROG ((ALLOCMDS 0) + SIZE NAME ALLOC INUSE ITEMSPERMDS INUSEPAGES NPAGESALLOCATED HUNKP DTD STAT) + (DECLARE (SPECVARS ALLOCMDS)) + (SETQ DTD (\GETDTD TYPE)) + (COND + ([NOT (SETQ NAME (\INDEXATOMPNAME (fetch DTDNAME of DTD] + (* ; "Nameless type?") + (RETURN))) + (SETQ HUNKP (fetch DTDHUNKP of DTD)) + (SETQ SIZE (fetch DTDSIZE of DTD)) + (CHECK (EVENP SIZE WORDSPERCELL)) + [SETQ ITEMSPERMDS (SELECTQ NAME + ((LITATOM SMALLP) (* ; "These are not allocated") + (RETURN)) + (LISTP [COND + ((EQ CDRCODING 0) + (IQUOTIENT \MDSIncrement SIZE)) + (T (CONSTANT (FIX (FQUOTIENT \MDSIncrement 2.2]) + (COND + ((EQ SIZE 0) (* ; "Undeclared, or not allocated") + (RETURN)) + (T (IQUOTIENT \MDSIncrement SIZE] + [\MAPMDS TYPE (FUNCTION (LAMBDA NIL + (add ALLOCMDS 1] + (SETQ NPAGESALLOCATED (TIMES ALLOCMDS \PagesPerMDSUnit)) + (COND + ((SETQ HUNKP (fetch DTDHUNKP of DTD)) + (add [fetch (HUNKSTAT NPAGES) + of (SETQ STAT (CAR (NTH HUNKSTATS (ADD1 (fetch DTDGCTYPE + of DTD] + NPAGESALLOCATED)) + (T (\BOXIPLUS TOTALALLOCMDS NPAGESALLOCATED))) + (COND + ((< NPAGESALLOCATED (OR PAGE-THRESHOLD 1)) + (RETURN))) + (\PUTBASEFIXP (\DTEST FREE 'FIXP) + 0 0) + [COND + [(AND (NEQ CDRCODING 0) + (EQ TYPE \LISTP)) (* ; + "CONS pages have a different kind of free list") + (for (LSTPAG _ (create POINTER + PAGE# _ (fetch DTDNEXTPAGE of \LISTPDTD))) + by (create POINTER + PAGE# _ (fetch (CONSPAGE NEXTPAGE) of LSTPAG)) while + LSTPAG + do (\BOXIPLUS FREE (fetch (CONSPAGE CNT) of LSTPAG] + (T (for (PTR _ (fetch DTDFREE of DTD)) by (\GETBASEPTR PTR 0) + while PTR do (CHECK (EQ (NTYPX PTR) + TYPE)) + (\BOXIPLUS FREE 1] + (SETQ INUSE (- (SETQ ALLOC (TIMES ALLOCMDS ITEMSPERMDS)) + FREE)) + (COND + ((fetch DTDHUNKP of DTD) (* ; + "Keep a cumulative table to be printed out at the end of this all by \STORAGE.HUNKTYPE") + (add (fetch (HUNKSTAT NITEMS) of STAT) + ALLOC) + (add (fetch (HUNKSTAT NFREE) of STAT) + FREE) + (add (fetch (HUNKSTAT NINUSE) of STAT) + INUSE) + (add (fetch (HUNKSTAT NALLOCATED) of STAT) + (BOXCOUNT TYPE))) + ((OR (NOT IN-USE-THRESHOLD) + (>= INUSE IN-USE-THRESHOLD)) + (\STMDSTYPE NAME NPAGESALLOCATED ALLOC FREE INUSE (BOXCOUNT TYPE]) (\STLINP + [LAMBDA (STR ALLOC TOT) (* bvm%: " 9-Feb-85 15:23") + (printout NIL STR 30 .I8 ALLOC 50 .I8 (IDIFFERENCE TOT ALLOC) + T]) (\STMDSTYPE + [LAMBDA (NAME NPAGESALLOCATED ALLOC FREE INUSE BOXCOUNT) + (* ; "Edited 8-Jan-88 14:33 by bvm") + (PRIN2 NAME) + (LET ((COL (POSITION)) + NC) + (if (AND (>= COL 15) + (< COL 19) + (> (SETQ COL (- 20 COL (NCHARS NPAGESALLOCATED))) + 0)) + then (* ; "Past the point we allocated for starting the #pages field, but #pages is small, so we can squeak in.") + (SPACES COL) + (printout NIL .I1 NPAGESALLOCATED) + else (printout NIL 15 .I5 NPAGESALLOCATED))) + (if (EQ NAME 'LISTP) + then (* ; + "Indicate that LISTP numbers for total & in use are approximate") + (\STMDS.APPROX ALLOC) + else (printout NIL .I8 ALLOC)) + (printout NIL 30 .I8 FREE 43) + (if (EQ NAME 'LISTP) + then (\STMDS.APPROX INUSE) + else (printout NIL .I8 INUSE)) + (printout NIL 56 .I10 BOXCOUNT T]) (\STMDS.APPROX + [LAMBDA (N) (* ; "Edited 8-Jan-88 14:33 by bvm") + + (* ;; "Print n in an 8-col field preceded by a ~ to indicate approximation") + + (SPACES (- 7 (NCHARS N))) + (printout NIL "~" .I1 N]) (\STORAGE.HUNKTYPE + [LAMBDA (TOTAL PAGE-THRESHOLD IN-USE-THRESHOLD) (* ; "Edited 8-Jan-88 14:39 by bvm") + (DECLARE (USEDFREE HUNKSTATS)) + (PROG (NPAGESALLOCATED STAT) + (for GCTYPE.NAME in [CONSTANT (LIST (LIST UNBOXEDBLOCK.GCT 'UNBOXEDHUNK) + (LIST PTRBLOCK.GCT 'PTRHUNK) + (LIST CODEBLOCK.GCT 'CODEHUNK] + do [SETQ STAT (CAR (NTH HUNKSTATS (ADD1 (CAR GCTYPE.NAME] + (SETQ NPAGESALLOCATED (fetch (HUNKSTAT NPAGES) of STAT)) + (\BOXIPLUS TOTAL NPAGESALLOCATED) + (COND + ((AND (NEQ NPAGESALLOCATED 0) + (OR (NOT PAGE-THRESHOLD) + (>= NPAGESALLOCATED PAGE-THRESHOLD)) + (OR (NOT IN-USE-THRESHOLD) + (>= (fetch (HUNKSTAT NINUSE) of STAT) + IN-USE-THRESHOLD))) + (\STMDSTYPE (CADR GCTYPE.NAME) + NPAGESALLOCATED + (fetch (HUNKSTAT NITEMS) of STAT) + (fetch (HUNKSTAT NFREE) of STAT) + (fetch (HUNKSTAT NINUSE) of STAT) + (fetch (HUNKSTAT NALLOCATED) of STAT]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD HUNKSTAT (NPAGES NITEMS NFREE NINUSE NALLOCATED) NPAGES _ 0 NITEMS _ 0 NFREE _ 0 NINUSE _ 0 NALLOCATED _ 0) ) ) (RPAQ? STORAGE.ARRAYSIZES '(4 16 64 256 1024 4096 16384 NIL)) (DECLARE%: (* "FOLLOWING DEFINITIONS EXPORTED") (DEFOPTIMIZER PUTBASEPTRX (&REST ARGS) (CONS '(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)) (DECLARE%: EVAL@COMPILE (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))) (* "END EXPORTED DEFINITIONS") DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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))]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \GETDTD MACRO ((typeNum) (ADDBASE \DTDSpaceBase (ITIMES typeNum 18)))) ) (DEFOPTIMIZER \TYPEMASK.UFN (&REST X) (LET [(CE (CONSTANTEXPRESSIONP (CADR X] (if CE then `((OPCODES TYPEMASK.N ,(CAR CE)) ,(CAR X)) else 'IGNOREMACRO))) (DECLARE%: EVAL@COMPILE (RPAQQ \GUARDSTORAGEFULL 128) (RPAQQ \GUARD1STORAGEFULL 64) (CONSTANTS \GUARDSTORAGEFULL \GUARD1STORAGEFULL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NxtMDSPage \LeastMDSPage \SecondArrayPage \SecondMDSPage \MDSFREELISTPAGE \MaxSysTypeNum \MaxTypeNumber \STORAGEFULL \INTERRUPTSTATE \PENDINGINTERRUPT) ) (* "END EXPORTED DEFINITIONS") (RPAQQ STORAGEFULLSTATES ((\SFS.NORMAL NIL) (\SFS.NOTSWITCHABLE 1) (\SFS.SWITCHABLE 2) (\SFS.ARRAYSWITCHED 3) (\SFS.FULLYSWITCHED 4))) (DECLARE%: EVAL@COMPILE (RPAQQ \SFS.NORMAL NIL) (RPAQQ \SFS.NOTSWITCHABLE 1) (RPAQQ \SFS.SWITCHABLE 2) (RPAQQ \SFS.ARRAYSWITCHED 3) (RPAQQ \SFS.FULLYSWITCHED 4) (CONSTANTS (\SFS.NORMAL NIL) (\SFS.NOTSWITCHABLE 1) (\SFS.SWITCHABLE 2) (\SFS.ARRAYSWITCHED 3) (\SFS.FULLYSWITCHED 4)) ) ) (* ; "for MAKEINIT") (DEFINEQ (CREATEMDSTYPETABLE + [LAMBDA NIL (* ; "Edited 8-Feb-91 16:10 by jds") + + (* ;; "called only under MAKEINIT to initialize the main data space type table") + + (* ;; "This isn't the only place data-type entries get initialized in the INIT.") + + (* ;; "--\CREATE.SYMBOL takes care of initing atom pages.") + + (* ;; "-- POSTINITARRAYS does some array-space initing") + + (* ;; "-- \ALLOCBLOCK of course creates new pages & inits their entries") + + (* ;; "-- \ALLOCMDSPAGE ditto") + + (CREATEPAGES \MDSTypeTable \MDSTTsize NIL T) + [PROG (VP) + + (* ;; "FIRST SET ALL TO NOREF") + + (SETQ VP 0) + (FRPTQ (UNFOLD \MDSTTsize WORDSPERPAGE) + (\PUTBASE \MDSTypeTable VP \TT.NOREF) + (add VP 1)) + + (* ;; "NOW SET UP SMALLPS") + + [for SEGMENT in (LIST \SmallPosHi \SmallNegHi) + do (for PAGE from 0 to (SUB1 PAGESPERSEGMENT) + by (FOLDLO \MDSIncrement WORDSPERPAGE) + do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD SEGMENT PAGESPERSEGMENT)) + (LOGOR \TT.NOREF \TT.FIXP \TT.NUMBERP \TT.ATOM \SMALLP] + (for PAGE from 0 to (SUB1 PAGESPERSEGMENT) by (FOLDLO \MDSIncrement + WORDSPERPAGE) + do (\MAKEMDSENTRY (LOGOR PAGE (UNFOLD \CHARHI PAGESPERSEGMENT)) + (LOGOR \TT.NOREF \CHARACTERP] + (CREATEPAGES \MISCSTATS (FOLDLO \MDSIncrement WORDSPERPAGE) + NIL T) + (\MAKEMDSENTRY (PAGELOC \MISCSTATS) + (LOGOR \TT.NOREF \TT.FIXP \TT.NUMBERP \TT.ATOM \FIXP]) (INITDATATYPES + [LAMBDA NIL (* ; "Edited 9-Feb-91 17:49 by jds") + +(* ;;; "Called only under MAKEINIT. Create the initial data type table from the info in the list INITIALDTDCONTENTS, whose elements are in type number order and of the form (name size pointer-fields finalization). Called before it is possible to make new atoms, so the DTDNAME field will not be filled in until INITDATATYPENAMES runs. We have to run this before turning on atoms so that we can create strings and pnames.") + + (LET [(NSYSTYPES (ALLOCAL (LENGTH INITIALDTDCONTENTS] + (CREATEPAGES \DTDSpaceBase 1 NIL T) + + (* ;; "First DTD page is locked, probably because CONS microcode touches the listp dtd. Not sure this is essential") + + (CREATEPAGES (\ADDBASE \DTDSpaceBase WORDSPERPAGE) + (SUB1 (FOLDHI (ADD1 (TIMES (ADD1 NSYSTYPES) + \DTDSize)) + WORDSPERPAGE))) + + (* ;; "Create the rest of the pages we will need for initial dtd. They need not be locked. (ADD1 NSYSTYPES) is because nonexistent type zero occupies table space") + + (* ;; "(ADD1 (TIMES ...)) is because you've got to create the next page for DTD's if you allocate the last one on a page. This arose when I icreased the # of system types, and we wound up with NSYSTYPES = 63. Result: Illegal addr in the INIT when it tried to allocate the next DTD. --JDS") + + [for D in (LOCAL INITIALDTDCONTENTS) bind DTD as TYPENO from 1 + do + + (* ;; "Run thru the initial data type decls (the gut-level system datatypes), and declare them in the INIT.DLINIT.") + + (SETQ DTD (\GETDTD TYPENO)) (* ; + "Create a Data-Type-Descriptor for the new type") + [replace DTDTYPEENTRY of DTD + with (LOGOR TYPENO (COND + ([ALLOCAL (FMEMB (CAR D) + '(SMALLP FIXP FLOATP] + \TT.NUMBERP) + (T 0)) + (COND + ([ALLOCAL (FMEMB (CAR D) + '(SMALLP FIXP FLOATP LITATOM NEW-ATOM] + \TT.ATOM) + (T 0)) + (COND + ([ALLOCAL (FMEMB (CAR D) + '(SMALLP FIXP] + \TT.FIXP) + (T 0)) + (COND + ((ALLOCAL (EQ (CAR D) + 'NEW-ATOM)) + (* ; "Add NewAtom Entry '90/07/18 ON") + \TT.NOREF) + (T 0)) + (COND + ([ALLOCAL (FMEMB (CAR D) + '(LITATOM NEW-ATOM] + (* ; "FOR TYPE TESTING BY TYPEMASK.") + (CONSTANT \TT.SYMBOLP)) + (T 0)) + (COND + ((ALLOCAL (NOT (CADR D))) + + (* ;; "no size, no ref. For those types that are really declared later on, \ASSIGNDATATYPE1 will fix DTDTYPEENTRY to be correct") + + \TT.NOREF) + (T 0] (* ; + "Set up the type-mask field with the appropriate meta-type bits") + (COND + ((EQ (CAR D) + 'NEW-ATOM) + + (* ;; "For NEW-ATOM, mark it a subtype of LITATOM.") + + (replace DTDSUPERTYPE of DTD with \LITATOM))) + (COND + ((ALLOCAL (AND (CAR D) + (CADR D))) (* ; "Set the data type's size") + (replace DTDSIZE of DTD with (LOCAL (CADR D] + [COND + ((NEQ CDRCODING 0) + (SETQ.NOREF \LISTPDTD (\GETDTD \LISTP] + (SETQ \MaxSysTypeNum (SETQ \MaxTypeNumber NSYSTYPES)) + NIL]) (INITDATATYPENAMES + [LAMBDA NIL (* ; "Edited 2-Apr-91 02:17 by sybalsky") + +(* ;;; "Called in MAKEINIT after it is ok to create arrays and new atoms. Here we finish initializing the data type tables -- fill in type names and the list of pointers. Also set finalization for built-in types.") + + (* ;; "Because this is running in the INIT, everything really HAS to be atom numbers, so leave the \ATOMPNAMEINDEX call alone in tjhis function.") + + (SETQ \FINALIZATION.FUNCTIONS (\ALLOCBLOCK (ADD1 \EndTypeNumber) + T)) + [for D in (LOCAL INITIALDTDCONTENTS) as NTYPX from 1 + do (LET [(DTD (\GETDTD NTYPX)) + (FINAL (LOCAL (CADDDR D] (* ; + "d = (name size ptrs finalization)") + [replace DTDNAME of DTD with (\ATOMPNAMEINDEX (LOCAL (CAR D] + (* ; + "Smash the name from our world into his") + [replace DTDPTRS of DTD with (COPY (LOCAL (CADDR D] + (* ; "And the list of pointer offsets") + (if FINAL + then (* ; "Set finalization for this type") + (replace DTDFINALIZABLE of DTD with T) + (\PUTBASEPTR \FINALIZATION.FUNCTIONS (UNFOLD NTYPX WORDSPERCELL) + (COPY FINAL] + (PROGN (* ; "Do finalization for array blocks (type 0) specially to avoid incompatible change to BUILT-IN-SYSTEM-TYPES") + (replace DTDFINALIZABLE of (\GETDTD 0) with T) + (\PUTBASEPTR \FINALIZATION.FUNCTIONS 0 (COPY '\RECLAIMARRAYBLOCK]) ) (DECLARE%: DONTCOPY (ADDTOVAR INITVALUES (\NxtMDSPage \FirstMDSPage) (\LeastMDSPage \FirstMDSPage) (\SecondMDSPage \DefaultSecondMDSPage) (\SecondArrayPage \DefaultSecondArrayPage) (\MDSFREELISTPAGE) (\MaxSysTypeNum 0) (\MaxTypeNumber)) (ADDTOVAR INITPTRS (\FINALIZATION.FUNCTIONS)) (ADDTOVAR INEWCOMS (FNS NTYPX \ALLOCMDSPAGE \MAKEMDSENTRY \INITMDSPAGE \ASSIGNDATATYPE1 \TYPENUMBERFROMNAME \CREATECELL \NEW2PAGE) (FNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES) (VARS \BUILT-IN-SYSTEM-TYPES)) (ADDTOVAR RDCOMS (FNS NTYPX TYPENAME \TYPENAMEFROMNUMBER)) (ADDTOVAR RDVALS (\MaxTypeNumber)) (ADDTOVAR RD.SUBFNS (\ARRAYTYPENAME LAMBDA (X) 'ARRAYP)) (ADDTOVAR EXPANDMACROFNS \GETDTD PUTBASEPTRX REPLACEFIELD FETCHFIELD \GETBITS \PUTBITS \TESTBITS GETBASEBITS PUTBASEBITS FFETCHFIELD FREPLACEFIELD FREPLACEFIELDVAL REPLACEFIELDVAL NCREATE) (ADDTOVAR MKI.SUBFNS (\GCDISABLED . NILL) (CREATECELL . I.\CREATECELL) (\CHECKFORSTORAGEFULL . NILL)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS CREATEMDSTYPETABLE INITDATATYPES INITDATATYPENAMES) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS LLDATATYPE FILETYPE CL:COMPILE-FILE) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) DTDECLARE) ) (PUTPROPS LLDATATYPE COPYRIGHT ("VENUE, Oakland, CA" 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (6675 37676 (NTYPX 6685 . 7162) (\TYPEMASK.UFN 7164 . 7688) (\TYPEP.UFN 7690 . 7859) ( \ALLOCMDSPAGE 7861 . 9263) (\ALLOCPAGEBLOCK 9265 . 9971) (\ALLOCVIRTUALPAGEBLOCK 9973 . 12588) ( \MAPMDS 12590 . 13706) (\CHECKFORSTORAGEFULL 13708 . 18854) (\DOSTORAGEFULLINTERRUPT 18856 . 19150) ( \SET.STORAGE.STATE 19152 . 20025) (\SETTYPEMASK 20027 . 20974) (\ADVANCE.STORAGE.STATE 20976 . 21484) (\NEW2PAGE 21486 . 21672) (\MAKEMDSENTRY 21674 . 22120) (\INITMDSPAGE 22122 . 23914) (\ASSIGNDATATYPE1 23916 . 33544) (\RESOLVE.TYPENUMBER 33546 . 34011) (\TYPENUMBERFROMNAME 34013 . 34553) (CREATECELL 34555 . 34688) (\CREATECELL 34690 . 37674)) (37775 38201 (\MAIKO.SET.STORAGE.STATE 37785 . 38199)) ( 38662 60724 (FETCHFIELD 38672 . 41863) (REPLACEFIELD 41865 . 47491) (BOXCOUNT 47493 . 47994) ( CONSCOUNT 47996 . 48130) (\DTEST 48132 . 48265) (\TYPECHECK 48267 . 48404) (\DTEST.UFN 48406 . 51661) (\INSTANCEP.UFN 51663 . 52891) (\INSTANCE-P 52893 . 53156) (\TYPECHECK.UFN 53158 . 53721) ( GETDESCRIPTORS 53723 . 54241) (GETSUPERTYPE 54243 . 54757) (GETFIELDSPECS 54759 . 55396) (NCREATE 55398 . 55570) (NCREATE2 55572 . 56287) (REPLACEFIELDVAL 56289 . 56553) (PUTBASEPTRX 56555 . 57034) ( /REPLACEFIELD 57036 . 57301) (TYPENAME 57303 . 58145) (TYPENAMEP 58147 . 58371) (\TYPENAMEFROMNUMBER 58373 . 58603) (\BLOCKDATAP 58605 . 58925) (USERDATATYPES 58927 . 59059) (DATATYPEP 59061 . 60210) ( DATATYPES 60212 . 60722)) (63086 78237 (STORAGE 63096 . 67517) (STORAGE.LEFT 67519 . 71060) ( \STORAGE.TYPE 71062 . 75122) (\STLINP 75124 . 75310) (\STMDSTYPE 75312 . 76511) (\STMDS.APPROX 76513 . 76781) (\STORAGE.HUNKTYPE 76783 . 78235)) (85121 93820 (CREATEMDSTYPETABLE 85131 . 86920) ( INITDATATYPES 86922 . 91767) (INITDATATYPENAMES 91769 . 93818))))) STOP \ No newline at end of file diff --git a/sources/LLDISPLAY b/sources/LLDISPLAY new file mode 100644 index 00000000..acfcfa96 --- /dev/null +++ b/sources/LLDISPLAY @@ -0,0 +1,1838 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "18-Apr-94 00:20:42" {DSK}nilsson>mnw>LLDISPLAY.;7 267646 + + changes to%: (FNS \BACKCOLOR.DISPLAY DSPTEXTURE \DSPRESET.DISPLAY \MEDW.XOFFSET \MEDW.YOFFSET + DSPXOFFSET DSPYOFFSET) + (VARS LLDISPLAYCOMS) + + previous date%: "25-Feb-94 17:56:47" {DSK}nilsson>mnw>LLDISPLAY.;6) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLDISPLAYCOMS) + +(RPAQQ LLDISPLAYCOMS + [(DECLARE%: DONTCOPY (EXPORT (RECORDS PILOTBBT \DISPLAYDATA DISPLAYSTATE DISPLAYINFO) + (MACROS \GETDISPLAYDATA))) + (* ; + "User-visible records are on ADISPLAY --- must be init'ed here") + (INITRECORDS BITMAP PILOTBBT REGION \DISPLAYDATA) + [COMS (* ; "BITMASKS") + (FNS \FBITMAPBIT \FBITMAPBIT.UFN \NEWPAGE.DISPLAY INITBITMASKS) + (OPTIMIZERS \FBITMAPBIT) + [EXPORT (DECLARE%: DONTCOPY (MACROS \BITMASK \4BITMASK \NOTBITMASK \NOT4BITMASK) + (GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY) + (CONSTANTS (WORDMASK 65535] + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INITBITMASKS] + [COMS (* ; "init cursor") + (FNS \CreateCursorBitMap) + (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CursorBitMap (\CreateCursorBitMap] + [COMS (* ; "bitmap functions.") + (FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY BITMAPCREATE BITMAPBIT + BLTCHAR \BLTCHAR \MEDW.BLTCHAR \CHANGECHARSET.DISPLAY \INDICATESTRING \SLOWBLTCHAR + TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP + \INSUREBITSPERPIXEL MAXIMUMCOLOR OPPOSITECOLOR MAXIMUMSHADE OPPOSITESHADE + \MEDW.BITBLT) + (FUNCTIONS FINISH-READING-BITMAP) + (CONSTANTS (MINIMUMCOLOR 0) + (MINIMUMSHADE 0)) + (P (MOVD 'BITMAPBIT '\BITMAPBIT)) + (DECLARE%: DONTCOPY (EXPORT (MACROS \INVALIDATEDISPLAYCACHE))) + (OPTIMIZERS BITMAPBIT BITMAPP) + (FNS BITMAPBIT.EXPANDER) + (FNS \BITBLT.DISPLAY \BITBLT.BITMAP \BITBLT.MERGE \BLTSHADE.DISPLAY \BLTSHADE.BITMAP) + (FNS + (* ;; "For SunLoadup") + + \BITBLT.BITMAP.SLOW) + (FNS + (* ;; " punt case for C funcs.bitblt_bitmap,bitshade.bitmap") + + \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) + (FNS + (* ;; "from SUMEX-AIM") + + \SCALEDBITBLT.DISPLAY \BACKCOLOR.DISPLAY) + (DECLARE%: DONTCOPY (CONSTANTS (\DisplayWordAlign 16) + (\MaxBitMapWidth 65535) + (\MaxBitMapHeight 65535) + (\MaxBitMapWords 131066)) + (EXPORT (MACROS \DSPGETCHARWIDTH \DSPGETCHARIMAGEWIDTH \DSPGETCHAROFFSET + \CONVERTOP \SFInvert \SFReplicate \SETPBTFUNCTION \BITBLT1)) + (GLOBALVARS \SYSBBTEXTURE \BBSCRATCHTEXTURE \SYSPILOTBBT \PILOTBBTSCRATCHBM)) + (VARS (\BBSCRATCHTEXTURE) + (\PILOTBBTSCRATCHBM)) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? 'BITBLT 'BKBITBLT] + (* ; + "macro for this file so that BITBLT can be broken by users") + (EXPORT (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE + (P (PUTPROP 'BITBLT 'MACRO '(= . BKBITBLT] + (COMS (* ; "display stream functions") + (FNS DISPLAYSTREAMP DSPSOURCETYPE DSPXOFFSET DSPYOFFSET) + (FNS DSPCREATE DSPDESTINATION DSPTEXTURE \DISPLAYSTREAMINCRXPOSITION \SFFixDestination + \SFFixClippingRegion \SFFixFont \SFFIXLINELENGTH + \UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD \SFFixY) + (FNS \MEDW.XOFFSET \MEDW.YOFFSET) + (FNS \DSPCLIPPINGREGION.DISPLAY \DSPFONT.DISPLAY \DISPLAY.PILOTBITBLT + \DSPLINEFEED.DISPLAY \DSPLEFTMARGIN.DISPLAY \DSPOPERATION.DISPLAY + \DSPRIGHTMARGIN.DISPLAY \DSPXPOSITION.DISPLAY \DSPYPOSITION.DISPLAY) + (P (MOVD? '\ILLEGAL.ARG '\COERCETODS) + (MOVD? 'NILL 'WFROMDS) + (MOVD? 'NILL 'WINDOWP) + (MOVD? 'NILL 'INVERTW)) + (INITVARS (PROMPTWINDOW T) + (\WINDOWWORLD NIL) + (\MAINSCREEN NIL))) + [COMS (* ; "Stub for window package") + (INITVARS (\TOPWDS) + (\SCREENBITMAPS)) + (P (MOVD? 'NILL '\TOTOPWDS)) + (DECLARE%: DONTCOPY EVAL@COMPILE (EXPORT (MACROS \INSURETOPWDS .WHILE.TOP.DS. + .WHILE.CURSOR.DOWN.) + (ADDVARS (GLOBALVARS \TOPWDS] + (COMS (* ; "DisplayStream TTY functions") + (FNS TTYDISPLAYSTREAM) + (EXPORT (OPTIMIZERS TTYDISPLAYSTREAM)) + (FNS DSPSCROLL PAGEHEIGHT) + (INITVARS (\CURRENTTTYDEVICE 'BCPLDISPLAY)) + (FNS \DSPRESET.DISPLAY) + (COMS (INITVARS (*DRIBBLE-OUTPUT* NIL)) + (FUNCTIONS \MAYBE-DRIBBLE-CHAR) + (FNS \DSPPRINTCHAR \DSPPRINTCR/LF)) + (FNS \TTYBACKGROUND) + (FNS DSPBACKUP) + (INITVARS (\CARET.UP)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (BELLCNT 2) + (BELLRATE 60) + (\DisplayStoppedForLogout) + (TtyDisplayStream))) + (FNS COLORDISPLAYP) + (FNS DISPLAYBEFOREEXIT DISPLAYAFTERENTRY) + (EXPORT (GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS \DisplayStoppedForLogout + \CARET.UP) + (MACROS \CHECKCARET))) + [COMS (* ; + "transformation related functions.") + (FNS \DSPCLIPTRANSFORMX \DSPCLIPTRANSFORMY \DSPTRANSFORMREGION \DSPUNTRANSFORMY + \DSPUNTRANSFORMX \OFFSETCLIPPINGREGION) + (DECLARE%: DONTCOPY (EXPORT (MACROS \DSPTRANSFORMX \DSPTRANSFORMY \OFFSETBOTTOM + \OFFSETLEFT] + [COMS (* ; "screen related functions") + (FNS UPDATESCREENDIMENSIONS \CreateScreenBitMap) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (UPDATESCREENDIMENSIONS)) + (INITVARS (SCREENHEIGHT 808) + (SCREENWIDTH 1024) + (\OLDSCREENHEIGHT 808) + (\OLDSCREENWIDTH 1024) + (\MaxScreenPage -1) + (ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT)) + (ColorScreenBitMap NIL))) + (GLOBALVARS \OLDSCREENHEIGHT \OLDSCREENWIDTH \MaxScreenPage ScreenBitMap) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (CURSOR.INIT] + [COMS (* ; "initialization") + (INITVARS (\DISPLAYINFOALIST)) + (FNS \CoerceToDisplayDevice \CREATEDISPLAY DISPLAYSTREAMINIT \STARTDISPLAY + \MOVE.WINDOWS.ONTO.SCREEN \UPDATE.PBT.RASTERWIDTHS \STOPDISPLAY \DEFINEDISPLAYINFO + ) + (DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS \UPDATE.PBT.RASTERWIDTHS))) + (EXPORT (MACROS DISPLAYINITIALIZEDP DISPLAYSTARTEDP) + (GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed + WHOLEDISPLAY WHOLESCREEN SCREENWIDTH SCREENHEIGHT)) + (ADDVARS (GLOBALVARS WHOLESCREEN)) + (FNS INITIALIZEDISPLAYSTREAMS) + (DECLARE%: DOCOPY DONTEVAL@LOAD (VARS (\DisplayStarted NIL) + (\LastTTYLines 12)) + (P (INITIALIZEDISPLAYSTREAMS) + (DISPLAYSTREAMINIT 1000] + (PROP FILETYPE LLDISPLAY) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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)) +) + +(/DECLAREDATATYPE 'PILOTBBT + '(WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD) + '((PILOTBBT 0 (BITS . 15)) + (PILOTBBT 1 (BITS . 15)) + (PILOTBBT 2 (BITS . 15)) + (PILOTBBT 3 (SIGNEDBITS . 15)) + (PILOTBBT 4 (BITS . 15)) + (PILOTBBT 5 (BITS . 15)) + (PILOTBBT 6 (BITS . 15)) + (PILOTBBT 7 (SIGNEDBITS . 15)) + (PILOTBBT 8 (BITS . 15)) + (PILOTBBT 9 (BITS . 15)) + (PILOTBBT 10 (BITS . 15)) + (PILOTBBT 11 (BITS . 15)) + (PILOTBBT 12 (BITS . 15)) + (PILOTBBT 13 (BITS . 15)) + (PILOTBBT 14 (BITS . 15)) + (PILOTBBT 15 (BITS . 15))) + '16) + +(/DECLAREDATATYPE '\DISPLAYDATA + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD FLAG XPOINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER WORD WORD POINTER WORD) + '((\DISPLAYDATA 0 POINTER) + (\DISPLAYDATA 2 POINTER) + (\DISPLAYDATA 4 POINTER) + (\DISPLAYDATA 6 POINTER) + (\DISPLAYDATA 8 POINTER) + (\DISPLAYDATA 10 POINTER) + (\DISPLAYDATA 12 POINTER) + (\DISPLAYDATA 14 POINTER) + (\DISPLAYDATA 16 POINTER) + (\DISPLAYDATA 18 POINTER) + (\DISPLAYDATA 20 POINTER) + (\DISPLAYDATA 22 POINTER) + (\DISPLAYDATA 24 POINTER) + (\DISPLAYDATA 26 POINTER) + (\DISPLAYDATA 28 POINTER) + (\DISPLAYDATA 30 POINTER) + (\DISPLAYDATA 32 POINTER) + (\DISPLAYDATA 34 (BITS . 15)) + (\DISPLAYDATA 35 (BITS . 15)) + (\DISPLAYDATA 36 (BITS . 15)) + (\DISPLAYDATA 37 (BITS . 15)) + (\DISPLAYDATA 38 (BITS . 15)) + (\DISPLAYDATA 32 (FLAGBITS . 0)) + (\DISPLAYDATA 40 XPOINTER) + (\DISPLAYDATA 42 POINTER) + (\DISPLAYDATA 44 POINTER) + (\DISPLAYDATA 46 POINTER) + (\DISPLAYDATA 48 POINTER) + (\DISPLAYDATA 50 POINTER) + (\DISPLAYDATA 52 POINTER) + (\DISPLAYDATA 54 POINTER) + (\DISPLAYDATA 56 POINTER) + (\DISPLAYDATA 58 POINTER) + (\DISPLAYDATA 60 POINTER) + (\DISPLAYDATA 62 POINTER) + (\DISPLAYDATA 39 (BITS . 15)) + (\DISPLAYDATA 64 (BITS . 15)) + (\DISPLAYDATA 66 POINTER) + (\DISPLAYDATA 65 (BITS . 15))) + '68) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \GETDISPLAYDATA MACRO (ARGS (COND + [(CADR ARGS) + (SUBPAIR '(STRM STRMVAR) + ARGS + '(\DTEST (fetch (STREAM IMAGEDATA) + of (SETQ STRMVAR (\OUTSTREAMARG + STRM))) + '\DISPLAYDATA] + (T (SUBST (CAR ARGS) + 'STRM + '(\DTEST (fetch (STREAM IMAGEDATA) + of (\OUTSTREAMARG STRM)) + '\DISPLAYDATA] +) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "User-visible records are on ADISPLAY --- must be init'ed here") + + +(/DECLAREDATATYPE 'BITMAP '(POINTER WORD WORD WORD WORD) + '((BITMAP 0 POINTER) + (BITMAP 2 (BITS . 15)) + (BITMAP 3 (BITS . 15)) + (BITMAP 4 (BITS . 15)) + (BITMAP 5 (BITS . 15))) + '6) + +(/DECLAREDATATYPE 'PILOTBBT + '(WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD WORD WORD WORD WORD) + '((PILOTBBT 0 (BITS . 15)) + (PILOTBBT 1 (BITS . 15)) + (PILOTBBT 2 (BITS . 15)) + (PILOTBBT 3 (SIGNEDBITS . 15)) + (PILOTBBT 4 (BITS . 15)) + (PILOTBBT 5 (BITS . 15)) + (PILOTBBT 6 (BITS . 15)) + (PILOTBBT 7 (SIGNEDBITS . 15)) + (PILOTBBT 8 (BITS . 15)) + (PILOTBBT 9 (BITS . 15)) + (PILOTBBT 10 (BITS . 15)) + (PILOTBBT 11 (BITS . 15)) + (PILOTBBT 12 (BITS . 15)) + (PILOTBBT 13 (BITS . 15)) + (PILOTBBT 14 (BITS . 15)) + (PILOTBBT 15 (BITS . 15))) + '16) + +(/DECLAREDATATYPE '\DISPLAYDATA + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD WORD WORD WORD FLAG XPOINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER WORD WORD POINTER WORD) + '((\DISPLAYDATA 0 POINTER) + (\DISPLAYDATA 2 POINTER) + (\DISPLAYDATA 4 POINTER) + (\DISPLAYDATA 6 POINTER) + (\DISPLAYDATA 8 POINTER) + (\DISPLAYDATA 10 POINTER) + (\DISPLAYDATA 12 POINTER) + (\DISPLAYDATA 14 POINTER) + (\DISPLAYDATA 16 POINTER) + (\DISPLAYDATA 18 POINTER) + (\DISPLAYDATA 20 POINTER) + (\DISPLAYDATA 22 POINTER) + (\DISPLAYDATA 24 POINTER) + (\DISPLAYDATA 26 POINTER) + (\DISPLAYDATA 28 POINTER) + (\DISPLAYDATA 30 POINTER) + (\DISPLAYDATA 32 POINTER) + (\DISPLAYDATA 34 (BITS . 15)) + (\DISPLAYDATA 35 (BITS . 15)) + (\DISPLAYDATA 36 (BITS . 15)) + (\DISPLAYDATA 37 (BITS . 15)) + (\DISPLAYDATA 38 (BITS . 15)) + (\DISPLAYDATA 32 (FLAGBITS . 0)) + (\DISPLAYDATA 40 XPOINTER) + (\DISPLAYDATA 42 POINTER) + (\DISPLAYDATA 44 POINTER) + (\DISPLAYDATA 46 POINTER) + (\DISPLAYDATA 48 POINTER) + (\DISPLAYDATA 50 POINTER) + (\DISPLAYDATA 52 POINTER) + (\DISPLAYDATA 54 POINTER) + (\DISPLAYDATA 56 POINTER) + (\DISPLAYDATA 58 POINTER) + (\DISPLAYDATA 60 POINTER) + (\DISPLAYDATA 62 POINTER) + (\DISPLAYDATA 39 (BITS . 15)) + (\DISPLAYDATA 64 (BITS . 15)) + (\DISPLAYDATA 66 POINTER) + (\DISPLAYDATA 65 (BITS . 15))) + '68) + + + +(* ; "BITMASKS") + +(DEFINEQ + +(\FBITMAPBIT [LAMBDA (BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH) (* ; "Edited 6-Oct-89 14:59 by jds") (* ;; "fast version of stuffing a bit into a bitmap.") (\FBITMAPBIT.UFN BASE X Y (SELECTQ OPERATION (INVERT 0) (ERASE 1) (READ 2) 3) HEIGHTMINUS1 RASTERWIDTH]) + +(\FBITMAPBIT.UFN [LAMBDA (BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH) (* ; "Edited 6-Oct-89 15:00 by jds") (* ;; "fast version of stuffing a bit into a bitmap.") (* ;; "UFN FOR MISC6 sub-op 0.") (LET ([WORDBASE (\ADDBASE BASE (IPLUS (ITIMES (IDIFFERENCE HEIGHTMINUS1 Y) RASTERWIDTH) (LRSH X 4] (BITMASK (\BITMASK X))) (PROG1 (COND ((ZEROP (LOGAND BITMASK (fetch (BITMAPWORD BITS) of WORDBASE))) 0) (T 1)) (change (fetch (BITMAPWORD BITS) of WORDBASE) (SELECTQ OPERATION (0 (LOGXOR DATUM BITMASK)) (1 (LOGAND DATUM (\NOTBITMASK X))) (2 (* ;; "Just read the value out.") DATUM) (LOGOR DATUM BITMASK))))]) + +(\NEWPAGE.DISPLAY [LAMBDA (STREAM) (* hdj "10-Dec-84 12:31") (DSPRESET STREAM]) + +(INITBITMASKS [LAMBDA NIL (* rrb "24-SEP-82 15:13") (* ;; "initialization of bit masks for line drawing routines. BITMASK is an array of single bit masks; NOTBITMASK is an array of masks for getting everything except the nth bit.") (SETQ BITMASKARRAY (ARRAY 16 'SMALLPOSP 0 0)) (SETQ NOTBITMASKARRAY (ARRAY 16 'SMALLPOSP 0 0)) (for I from 0 to 15 bind (MASK _ (CONSTANT (EXPT 2 15))) do (SETA BITMASKARRAY I MASK) (SETA NOTBITMASKARRAY I (LOGXOR MASK WORDMASK)) (SETQ MASK (LRSH MASK 1))) (SETQ 4BITMASKARRAY (ARRAY 4 'SMALLPOSP 0 0)) (SETQ NOT4BITMASKARRAY (ARRAY 4 'SMALLPOSP 0 0)) (for I from 0 to 3 bind [MASK _ (CONSTANT (IDIFFERENCE (EXPT 2 16) (EXPT 2 12] do (SETA 4BITMASKARRAY I MASK) (SETA NOT4BITMASKARRAY I (LOGXOR MASK WORDMASK)) (SETQ MASK (LRSH MASK 4]) +) + +(DEFOPTIMIZER \FBITMAPBIT (BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH) + `((OPCODES MISC7 1) + ,BASE + ,X + ,Y + ,[COND + ([OR (AND (LISTP OPERATION) + (EQ (CAR OPERATION) + 'QUOTE] + (SELECTQ (EVAL OPERATION) + (INVERT 0) + (ERASE 1) + (READ 2) + 3)) + (T `(SELECTQ ,OPERATION + (INVERT 0) + (ERASE 1) + (READ 2) + 3] + ,HEIGHTMINUS1 + ,RASTERWIDTH NIL)) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[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] +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ WORDMASK 65535) + + +(CONSTANTS (WORDMASK 65535)) +) +) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(INITBITMASKS) +) + + + +(* ; "init cursor") + +(DEFINEQ + +(\CreateCursorBitMap [LAMBDA NIL (* lmm "13-MAY-82 00:24") (* ;; "creates a BITMAP which points at the cursor bits.") (* ;; "pointer to cursor is stored using hiloc and loloc rather that BITMAPBASE so that it won't be reference counted. It is on an odd boundary.") (create BITMAP BITMAPRASTERWIDTH _ 1 BITMAPWIDTH _ 16 BITMAPHEIGHT _ 16 BITMAPBASE _ \EM.CURSORBITMAP]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ CursorBitMap (\CreateCursorBitMap)) +) + + + +(* ; "bitmap functions.") + +(DEFINEQ + +(BITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 12-Jan-88 23:05 by FS") (DECLARE (LOCALVARS . T)) (* ;; "IRM defined defaults") (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (COND [(EQ SOURCETYPE 'TEXTURE) (COND ((type? BITMAP DESTINATION) (\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)) (T (PROG ((STREAM (\OUTSTREAMARG DESTINATION))) (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION] (T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) [COND [(type? BITMAP SOURCE) (OR SOURCELEFT (SETQ SOURCELEFT 0)) (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) (SETQ SOURCEBM SOURCE) (SETQ CLIPPEDSOURCELEFT SOURCELEFT) (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* ;  "limit the WIDTH and HEIGHT to the source size.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (BITMAP BITMAPWIDTH) of SOURCE) SOURCELEFT))) (T (fetch (BITMAP BITMAPWIDTH) of SOURCE] (SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT ) of SOURCE) SOURCEBOTTOM))) (T (fetch (BITMAP BITMAPHEIGHT) of SOURCE] ((SETQ SOURCEDD (\GETDISPLAYDATA SOURCE)) [OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT) of (ffetch (\DISPLAYDATA DDClippingRegion) of SOURCEDD] [OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM) of (ffetch (\DISPLAYDATA DDClippingRegion ) of SOURCEDD ] (* ;  "do transformations coming out of source") (SETQ SOURCEBM (fetch (\DISPLAYDATA DDDestination) of SOURCEDD)) (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT SOURCEDD)) (fetch (\DISPLAYDATA DDClippingLeft) of SOURCEDD))) (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM SOURCEDD)) (fetch (\DISPLAYDATA DDClippingBottom) of SOURCEDD))) (* ;  "limit the WIDTH and HEIGHT by the source dimensions.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT] [SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop ) of SOURCEDD) CLIPPEDSOURCEBOTTOM))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop) of SOURCEDD) CLIPPEDSOURCEBOTTOM] (* ;  "if texture is not given, use the display stream's.") (OR TEXTURE (SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of SOURCEDD] (COND ((OR (IGEQ 0 WIDTH) (IGEQ 0 HEIGHT)) (* ;  "if either width or height is 0, don't do anything.") (RETURN))) (RETURN (COND [(type? BITMAP DESTINATION) (COND ((WINDOWP SOURCE) (* ;; "bring source window to the top. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) (T (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM] (T (PROG (STREAM) (SETQ STREAM (\OUTSTREAMARG DESTINATION)) (COND ((AND (NEQ SOURCE DESTINATION) (WINDOWP SOURCE)) (* ;; "both source and destination are windows, see if they overlap and use an intermediate bitmap. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") [COND ((WINDOWP DESTINATION) (COND ((WOVERLAPP SOURCE DESTINATION) (RETURN (PROG (SCRATCHBM) (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (BITBLT SOURCEBM SOURCELEFT SOURCEBOTTOM (SETQ SCRATCHBM (BITMAPCREATE WIDTH HEIGHT)) 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)) (RETURN (BITBLT SCRATCHBM 0 0 STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION] (* ;  "bring the source to the top. this should be done uninterruptably but is better than nothing.") (TOTOPW SOURCE))) (IMAGEOP 'IMBITBLT STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM]) + +(BLTSHADE [LAMBDA (TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* rrb " 7-Mar-86 11:26") (DECLARE (LOCALVARS . T)) (COND ((type? BITMAP DESTINATION) (\BLTSHADE.BITMAP TEXTURE DESTINATION (OR DESTINATIONLEFT 0) (OR DESTINATIONBOTTOM 0) WIDTH HEIGHT OPERATION CLIPPINGREGION)) (T (PROG ((STREAM (\OUTSTREAMARG DESTINATION))) (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM (OR DESTINATIONLEFT 0) (OR DESTINATIONBOTTOM 0) WIDTH HEIGHT (OR OPERATION (DSPOPERATION NIL STREAM)) CLIPPINGREGION]) + +(\BITBLTSUB [LAMBDA (PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation Texture WindowXOffset WindowYOffset) (* rrb "13-Feb-86 14:42") (* ;; "rrb 13-Feb-86 Added WindowYOffset and WindowXOffset so that textures could be aligned to the window rather than the underlying Screen bitmap. I only changed the calls in \BLTSHADE.1BITDISPLAY and \BLTSHADE.COLORDISPLAY") (PROG (DBMR SBMR GRAY SOURCEADDR DESTADDR X) (SETQ DBMR (fetch (BITMAP BITMAPRASTERWIDTH) of DestinationBitMap)) (replace (PILOTBBT PBTFLAGS) of PILOTBBT with 0) (replace (PILOTBBT PBTDESTBPL) of PILOTBBT with (UNFOLD DBMR BITSPERWORD)) (SETQ DESTADDR (\ADDBASE (fetch (BITMAP BITMAPBASE) of DestinationBitMap) (ITIMES DBMR DTY))) (* ;  "Combine Destination base and top Y into a single Destination word offset") (replace (PILOTBBT PBTDESTBIT) of PILOTBBT with DLX) (SELECTQ SourceType (TEXTURE (replace (PILOTBBT PBTUSEGRAY) of PILOTBBT with T) (replace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with (MOD (COND (WindowXOffset (IDIFFERENCE DLX WindowXOffset)) (T DLX)) BITSPERWORD)) (* ;; "Source is offset in a gray block where we want to start. Microcode finds the start of the gray block by subtracting PBTGRAYOFFSET from it") (replace (PILOTBBT PBTSOURCEBPL) of PILOTBBT with 0) (* ; "Zero out this word first") [COND [(FIXP Texture) (SETQ GRAY (fetch (BITMAP BITMAPBASE) of \SYSBBTEXTURE)) (replace (PILOTBBT PBTSOURCE) of PILOTBBT with (\ADDBASE GRAY (COND ((OR (EQ (SETQ Texture (LOGAND Texture WORDMASK)) 0) (EQ Texture BLACKSHADE)) (* ;  "special cases of solid texture occur often") (\PUTBASE GRAY 0 Texture) (* ;  "PBTGRAYHEIGHTLESSONE and PBTGRAYOFFSET are both 0 in this case") 0) (T (\PUTBASE GRAY 0 (\SFReplicate (LRSH Texture 12)) ) [\PUTBASE GRAY 1 (\SFReplicate (LOGAND 15 (LRSH Texture 8] [\PUTBASE GRAY 2 (\SFReplicate (LOGAND 15 (LRSH Texture 4] (\PUTBASE GRAY 3 (\SFReplicate (LOGAND 15 Texture ))) (replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of PILOTBBT with 3) (replace (PILOTBBT PBTGRAYOFFSET) of PILOTBBT with (MOD (COND (WindowYOffset (PLUS DTY WindowYOffset )) (T DTY)) 4] (T (* ;  "A bitmap that is 16 bits wide. BITBLT verified this back in interruptable section") [replace (PILOTBBT PBTGRAYHEIGHTLESSONE) of PILOTBBT with (SUB1 (SETQ X (IMIN [ffetch (BITMAP BITMAPHEIGHT) of (SETQ Texture (\DTEST Texture 'BITMAP] 16] [replace (PILOTBBT PBTGRAYOFFSET) of PILOTBBT with (SETQ X (COND (WindowYOffset (MOD (PLUS DTY WindowYOffset) X)) (T (IREMAINDER DTY X] (replace (PILOTBBT PBTSOURCE) of PILOTBBT with (\ADDBASE (ffetch (BITMAP BITMAPBASE) of Texture) X]) (MERGE (RETURN (RAID "Hard bitblt case"))) (PROGN (* ; "INPUT or INVERT") (replace (PILOTBBT PBTUSEGRAY) of PILOTBBT with NIL) (replace (PILOTBBT PBTSOURCEBPL) of PILOTBBT with (UNFOLD (SETQ SBMR (fetch (BITMAP BITMAPRASTERWIDTH) of SourceBitMap)) BITSPERWORD)) (SETQ SOURCEADDR (\ADDBASE (fetch (BITMAP BITMAPBASE) of SourceBitMap) (ITIMES SBMR STY))) (* ;  "Combine Source base and top Y into a single Source word offset") (replace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with SLX) [COND ((NOT (EQ SourceBitMap DestinationBitMap)) (* ;  "Assume distinct bitmaps do not overlap, i.e. that we do not have sub-bitmaps") (replace (PILOTBBT PBTDISJOINT) of PILOTBBT with T)) [(IGREATERP STY DTY) (* ;  "Source > Dest means we can go top to bottom always") (COND ((IGREATERP STY (IPLUS DTY HEIGHT)) (* ;  "Dest ends before source starts, so is completely disjoint") (replace (PILOTBBT PBTDISJOINT) of PILOTBBT with T)) (T (* ;  "Not disjoint, but the items are disjoint") (replace (PILOTBBT PBTDISJOINTITEMS) of PILOTBBT with T] ((IGREATERP DTY (IPLUS STY HEIGHT)) (* ;  "Source ends before dest starts, so is completely disjoint") (replace (PILOTBBT PBTDISJOINT) of PILOTBBT with T)) ([OR (NOT (EQ STY DTY)) (AND (ILESSP SLX DLX) (ILESSP DLX (IPLUS SLX (fetch (PILOTBBT PBTWIDTH) of PILOTBBT ] (* ;; "Not disjoint, with source above dest (bottom to top) or source and dest the same line with source to left of dest (right to left)") (replace (PILOTBBT PBTBACKWARD) of PILOTBBT with T) (* ;  "What's more, the source and dest addresses are to be of the LAST item, and bpl is negative") (* ;  "note SBMR = DBMR if we have gotten this far") [SETQ SOURCEADDR (\ADDBASE SOURCEADDR (SETQ X (ITIMES SBMR (SUB1 HEIGHT] (SETQ DESTADDR (\ADDBASE DESTADDR X)) [replace (PILOTBBT PBTSOURCEBPL) of PILOTBBT with (SETQ X (IMINUS (UNFOLD SBMR BITSPERWORD] (replace (PILOTBBT PBTDESTBPL) of PILOTBBT with X) (COND ((NOT (EQ STY DTY)) (* ; "At least the items are disjoint") (replace (PILOTBBT PBTDISJOINTITEMS) of PILOTBBT with T] (replace (PILOTBBT PBTSOURCE) of PILOTBBT with SOURCEADDR))) (replace (PILOTBBT PBTDEST) of PILOTBBT with DESTADDR) (\SETPBTFUNCTION PILOTBBT SourceType Operation) (RETURN (\PILOTBITBLT PILOTBBT 0]) + +(\GETPILOTBBTSCRATCHBM [LAMBDA (WIDTH HEIGHT) (DECLARE (GLOBALVARS \PILOTBBTSCRATCHBM)) (* bvm%: "24-MAY-82 12:46") (* ;; "Return a scratch bitmap at least WIDTH by HEIGHT. Called only under uninterruptable bitblt, so don't worry about global resource conflicts") (COND ((AND (type? BITMAP \PILOTBBTSCRATCHBM) (ILEQ WIDTH (fetch BITMAPWIDTH of \PILOTBBTSCRATCHBM)) (ILEQ HEIGHT (fetch BITMAPHEIGHT of \PILOTBBTSCRATCHBM))) \PILOTBBTSCRATCHBM) (T (SETQ \PILOTBBTSCRATCHBM (BITMAPCREATE WIDTH HEIGHT]) + +(BITMAPCOPY [LAMBDA (BITMAP) (* rrb "22-DEC-82 11:09") (* ;; "makes a copy of an existing BitMap") (PROG (NEWBITMAP) (BITBLT (SETQ BITMAP (\DTEST BITMAP 'BITMAP)) 0 0 (SETQ NEWBITMAP (BITMAPCREATE (BITMAPWIDTH BITMAP) (ffetch BITMAPHEIGHT of BITMAP) (ffetch BITMAPBITSPERPIXEL of BITMAP))) 0 0 NIL NIL 'INPUT 'REPLACE 0) (RETURN NEWBITMAP]) + +(BITMAPCREATE [LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* kbr%: " 2-Sep-85 18:50") (* ;  "creates a bitmap data structure.") (PROG (RW) (OR (AND (IGEQ WIDTH 0) (ILEQ WIDTH \MaxBitMapWidth)) (\ILLEGAL.ARG WIDTH)) (OR (AND (IGEQ HEIGHT 0) (ILEQ HEIGHT \MaxBitMapHeight)) (\ILLEGAL.ARG HEIGHT)) (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL)) (SETQ RW (FOLDHI (ITIMES WIDTH BITSPERPIXEL) BITSPERWORD)) (RETURN (create BITMAP BITMAPRASTERWIDTH _ RW BITMAPWIDTH _ WIDTH BITMAPHEIGHT _ HEIGHT BITMAPBITSPERPIXEL _ BITSPERPIXEL BITMAPBASE _ (COND ((IGREATERP (SETQ RW (ITIMES RW HEIGHT)) \MaxBitMapWords) (ERROR (ITIMES WIDTH HEIGHT BITSPERPIXEL) "bits in BITMAP -- too big")) (T (\ALLOCBLOCK (FOLDHI RW WORDSPERCELL) NIL (AND (NULL WINDFLG) 0]) + +(BITMAPBIT [LAMBDA (BITMAP X Y NEWVALUE) (* ; "Edited 10-Oct-89 11:17 by jds") (* ;;; "reads and optionally sets a bit in a bitmap. If bitmap is a displaystream, it works on the destination through the coordinate transformations.") (* ;; "version of BITMAPBIT that works for multiple bit per pixel bitmaps.") (PROG (NBITS BITX WORDX OLDVALUE HEIGHT oldword bitmapbase) (RETURN (COND [(type? BITMAP BITMAP) (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) (COND ([OR (IGREATERP 0 X) (IGEQ X (fetch (BITMAP BITMAPWIDTH) of BITMAP)) (IGREATERP 0 Y) (IGEQ Y (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of BITMAP] (* ; "all bitmaps are 0 outside") 0) [(EQ NBITS 1) (* ;; "Special case for single-bit bitmaps, i.e., the display.") (COND ((EQ NEWVALUE 0) (\FBITMAPBIT (fetch (BITMAP BITMAPBASE) of BITMAP) X Y 'ERASE (SUB1 HEIGHT) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))) ((NOT NEWVALUE) (\FBITMAPBIT (fetch (BITMAP BITMAPBASE) of BITMAP) X Y 'READ (SUB1 HEIGHT) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP))) (T (\FBITMAPBIT (fetch (BITMAP BITMAPBASE) of BITMAP) X Y 'PAINT (SUB1 HEIGHT) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP] (T [SETQ bitmapbase (\ADDBASE (fetch (BITMAP BITMAPBASE) of BITMAP) (ITIMES (SUB1 (\SFInvert BITMAP Y)) (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP] [COND (NEWVALUE (* ;  "check NEWVALUE before going uninterruptable.") (COND ([NOT (AND (IGEQ NEWVALUE MINIMUMCOLOR) (ILEQ NEWVALUE (MAXIMUMCOLOR (fetch (BITMAP BITMAPBITSPERPIXEL ) of BITMAP ] (\ILLEGAL.ARG NEWVALUE] (SELECTQ NBITS (1 (SETQ WORDX (FOLDLO X BITSPERWORD)) (* ;; "") (SETQ oldword (\GETBASE bitmapbase WORDX)) (SETQ BITX (\BITMASK X)) [if NEWVALUE then (if (EQ NEWVALUE 0) then (\PUTBASE bitmapbase WORDX (LOGAND oldword (LOGXOR BITX -1)) ) else (\PUTBASE bitmapbase WORDX (LOGOR oldword BITX] (if (EQ 0 (LOGAND oldword BITX)) then 0 else 1)) (4 (SETQ BITX (LSH X 2)) (SETQ WORDX (FOLDLO BITX BITSPERWORD)) (SETQ oldword (\GETBASE bitmapbase WORDX)) (SETQ OLDVALUE (LOGAND oldword (\4BITMASK X))) [COND (NEWVALUE (\PUTBASE bitmapbase WORDX (LOGOR (LOGXOR oldword OLDVALUE) (LLSH NEWVALUE (ITIMES 4 (IDIFFERENCE 3 (LOGAND X 3] (* ;  "move the 4 bit current value to the right most bits.") [LRSH OLDVALUE (ITIMES 4 (IDIFFERENCE 3 (LOGAND X 3]) (8 (SETQ BITX (LSH X 3)) (SETQ WORDX (FOLDLO BITX BITSPERWORD)) [COND ((EQ (LOGAND X 1) 0) (* ; "left half of word") (SETQ oldword (\GETBASE bitmapbase WORDX)) (SETQ OLDVALUE (LOGAND oldword 65280)) [COND (NEWVALUE (\PUTBASE bitmapbase WORDX (LOGOR (LOGXOR oldword OLDVALUE) (LLSH NEWVALUE 8] (SETQ OLDVALUE (LRSH OLDVALUE 8))) (T (* ; "right half of word") (SETQ oldword (\GETBASE bitmapbase WORDX)) (SETQ OLDVALUE (LOGAND oldword 255)) (COND (NEWVALUE (\PUTBASE bitmapbase WORDX (LOGOR (LOGXOR oldword OLDVALUE) NEWVALUE] OLDVALUE) (24 (SETQ BITX (ITIMES X 24)) (SETQ WORDX (FOLDLO BITX BITSPERWORD)) (SETQ OLDVALUE (\GETBASE24 bitmapbase X)) (COND (NEWVALUE (\PUTBASE24 bitmapbase X NEWVALUE))) OLDVALUE) (ERROR "unknown bits per pixel size." NBITS] (T (PROG (TX TY DD) (SETQ DD (\GETDISPLAYDATA BITMAP BITMAP)) (SETQ TX (\DSPCLIPTRANSFORMX X DD)) (SETQ TY (\DSPCLIPTRANSFORMY Y DD)) (RETURN (COND ((AND TX TY) (.WHILE.TOP.DS. BITMAP (SETQ TX (BITMAPBIT (fetch (\DISPLAYDATA DDDestination) of DD) TX TY NEWVALUE))) TX) (T (* ;  "anything outside the clipping region returns 0.") 0]) + +(BLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM) (* rmk%: " 4-Apr-85 11:45") (* ; "user entry --- seldom used") (* ;; "puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") (\BLTCHAR (COND ((\CHARCODEP CHARCODE) CHARCODE) (T (\ILLEGAL.ARG CHARCODE))) DISPLAYSTREAM (\GETDISPLAYDATA DISPLAYSTREAM]) + +(\BLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 25-Feb-94 16:44 by sybalsky") + + (* ;; "puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") + + (* ;; "knows about the representation of a DisplayStream.") + + (IMAGEOP 'IMBLTCHAR (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM)) + CHARCODE DISPLAYSTREAM DISPLAYDATA]) + +(\MEDW.BLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* kbr%: "25-Feb-86 22:25") + + (* ;; "puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by the routines that change it. This is kept in the BitBltTable.") + + (* ;; "knows about the representation of a DisplayStream.") + + (DECLARE (LOCALVARS . T)) + (PROG (LOCAL1 RIGHT LEFT CURX CHAR8CODE) + (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) + CRLP + [COND + ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) + (\CHARSET CHARCODE))) + (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE] + [COND + ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) + (RETURN (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM] + (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) + (SETQ RIGHT (IPLUS CURX (\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA))) + [COND + ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) + (* ; + "would go past right margin, force a cr") + (COND + ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) + (* ; + "don't bother CR if position is at left margin anyway. This also serves to break the loop.") + (\DSPPRINTCR/LF (CHARCODE EOL) + DISPLAYSTREAM) (* ; + "reuse the code in the test of this conditional rather than repeat it here.") + (GO CRLP] (* ; + "update the display stream x position.") + (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX + ( + \DSPGETCHARWIDTH + CHAR8CODE + DISPLAYDATA))) + (* ; + "transforms an x coordinate into the destination coordinate.") + (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) + (SETQ CURX (IPLUS CURX LOCAL1)) + (SETQ RIGHT (IPLUS RIGHT LOCAL1)) + (COND + ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingRight) of + DISPLAYDATA + ))) (* ; + "character overlaps right edge of clipping region.") + (SETQ RIGHT LOCAL1))) + (SETQ LEFT (COND + ((IGREATERP CURX (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingLeft) + of DISPLAYDATA))) + CURX) + (T LOCAL1))) + (RETURN (COND + ((AND (ILESSP LEFT RIGHT) + (NOT (EQ (fetch (PILOTBBT PBTHEIGHT) of (SETQ LOCAL1 + (ffetch (\DISPLAYDATA + DDPILOTBBT) + of DISPLAYDATA))) + 0))) + (.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of LOCAL1 + with LEFT) + (freplace (PILOTBBT PBTWIDTH) of LOCAL1 with (IDIFFERENCE + RIGHT LEFT)) + (freplace (PILOTBBT PBTSOURCEBIT) of LOCAL1 + with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DISPLAYDATA + ) + LEFT) + CURX)) + (\PILOTBITBLT LOCAL1 0)) + T]) + +(\CHANGECHARSET.DISPLAY [LAMBDA (DISPLAYDATA CHARSET) (* gbn "13-Sep-85 11:47") (* ;; "Called when the character set information cached in a display stream doesn't correspond to CHARSET") (PROG [BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA)) (CSINFO (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA] (* ;; "Since we called \GETCHARSETINFO without the NOSLUG? flag, we presume we will get back a CSINFO , even if it is a slug csinfo") (UNINTERRUPTABLY (freplace DDWIDTHSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO WIDTHS ) of CSINFO)) (freplace DDOFFSETSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO OFFSETS) of CSINFO)) (freplace DDCHARIMAGEWIDTHS of DISPLAYDATA with (ffetch (CHARSETINFO IMAGEWIDTHS) of CSINFO)) (freplace DDCHARSET of DISPLAYDATA with CHARSET) (SETQ BM (ffetch CHARSETBITMAP of CSINFO)) (freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM) BITSPERWORD)) [COND ((OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA) (ffetch CHARSETASCENT of CSINFO)) (NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA) (ffetch CHARSETDESCENT of CSINFO))) (\SFFixY DISPLAYDATA CSINFO)) (T (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (ffetch DDCHARHEIGHTDELTA of DISPLAYDATA]) ]) + +(\INDICATESTRING [LAMBDA (CHARCODE) (* jds " 3-Oct-85 16:50") (* ;; "This returns the string of characters by which CHARCODE would be indicated on the display. This could be fixed up to use a global resource passed in from the outside, but this should almost never be called so it doesn't matter (except perhaps when SEEing a compiled file)") (COND [(IGREATERP CHARCODE \MAXTHINCHAR) (* ; "An NS character") (RESETLST (RESETSAVE PRXFLT T) (RESETSAVE (RADIX 8)) (CONCAT '%# (\CHARSET CHARCODE) "," (\CHAR8CODE CHARCODE)))] (T (CONCAT (COND ((IGREATERP CHARCODE 127) (* ; "An old META character") (SETQ CHARCODE (LOGAND CHARCODE 127)) '%#) (T "")) (COND ((ILESSP CHARCODE 32) (* ; "CONTROL character") (SETQ CHARCODE (LOGOR CHARCODE 64)) '^) (T "")) (CHARACTER CHARCODE]) + +(\SLOWBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 8-Nov-89 15:19 by gadener") (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset") (PROG (ROTATION CHAR8CODE DD) (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) (SETQ DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND [(EQ 0 ROTATION) (PROG (NEWX LEFT RIGHT CURX PILOTBBT DESTBIT WIDTH SOURCEBIT) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) [COND ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ; "past RIGHT margin, force eol") (\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD] (* ; "update the x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) (SETQ CURX (\DSPTRANSFORMX CURX DD)) (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) CURX)) (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) (\DSPTRANSFORMX NEWX DD))) (SETQ PILOTBBT (ffetch (\DISPLAYDATA DDPILOTBBT) of DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (ffetch (PILOTBBT PBTHEIGHT) of PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination ) of DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (24 (SETQ DESTBIT (ITIMES 24 DESTBIT)) (SETQ WIDTH (ITIMES 24 WIDTH)) (SETQ SOURCEBIT (ITIMES 24 SOURCEBIT))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (freplace (PILOTBBT PBTDESTBIT) of PILOTBBT with DESTBIT) (freplace (PILOTBBT PBTWIDTH) of PILOTBBT with WIDTH) (freplace (PILOTBBT PBTSOURCEBIT) of PILOTBBT with SOURCEBIT) (\PILOTBITBLT PILOTBBT 0)) T] (T (* ; "handle rotated fonts") (PROG (YPOS HEIGHTMOVED CSINFO) (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) (ffetch (\DISPLAYDATA DDFONT) of DD))) (COND ((EQ ROTATION 90) (* ;  "don't force CR for rotated fonts.") (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) (* ;  "update the display stream x position.") (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)) ) YPOS (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) ((EQ ROTATION 270) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) 0 (\DSPGETCHAROFFSET CHAR8CODE DD) DISPLAYSTREAM (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) HEIGHTMOVED)) (T (ERROR "Not implemented to rotate by other than 0, 90 or 270"]) + +(TEXTUREP [LAMBDA (OBJECT) (* bvm%: "26-MAY-82 17:51") (OR (FIXP OBJECT) (AND (type? BITMAP OBJECT) (EQ (fetch BITMAPRASTERWIDTH of OBJECT) 1) OBJECT]) + +(INVERT.TEXTURE [LAMBDA (TEXTURE SCRATCHBM) (* bvm%: "31-MAY-82 14:41") (COND ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) (T (INVERT.TEXTURE.BITMAP TEXTURE SCRATCHBM]) + +(INVERT.TEXTURE.BITMAP [LAMBDA (BM SCRATCHBM) (* edited%: "15-SEP-82 09:17") (* ;; "Returns a bitmap that is the complement of BM. If SCRATCHBM is supplied, then does it to SCRATCHBM, else creates and returns a new bitmap") (COND ((NEQ (fetch BITMAPRASTERWIDTH of BM) 1) (\ILLEGAL.ARG BM))) (PROG [(NEWBM (COND ((type? BITMAP SCRATCHBM) (COND ((OR (NEQ (fetch BITMAPRASTERWIDTH of SCRATCHBM) 1) (IGREATERP (fetch BITMAPHEIGHT of BM) (fetch BITMAPHEIGHT of SCRATCHBM))) (\ILLEGAL.ARG SCRATCHBM))) SCRATCHBM) (T (BITMAPCREATE BITSPERWORD (fetch BITMAPHEIGHT of BM] (bind (BASE1 _ (fetch BITMAPBASE of BM)) (LASTBASE _ (\ADDBASE (fetch BITMAPBASE of NEWBM) (fetch BITMAPHEIGHT of BM))) for (BASE2 _ (fetch BITMAPBASE of NEWBM)) by (\ADDBASE BASE2 1) until (EQ BASE2 LASTBASE) do (\PUTBASE BASE2 0 (LOGXOR (\GETBASE BASE1 0) WORDMASK)) (SETQ BASE1 (\ADDBASE BASE1 1))) (RETURN NEWBM]) + +(BITMAPWIDTH [LAMBDA (BITMAP) (* kbr%: " 2-Sep-85 19:01") (* ;; "returns the width of a bitmap in pixels") (COND ((type? BITMAP BITMAP) (ffetch (BITMAP BITMAPWIDTH) of BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'WIDTH)) (T (\ILLEGAL.ARG BITMAP]) + +(READBITMAP [LAMBDA (FILE) (* ; "Edited 1-Dec-86 19:29 by Pavel") (* ;;; "reads a bitmap from the input file.") (SKIPSEPRS FILE) (OR (EQ (READC FILE) '%() (ERROR "BAD FORMAT OF BITMAP IN FILE")) (PROG [BASE BM W BITSPERPIXEL (WIDTH (RATOM FILE)) (HEIGHT (RATOM FILE)) (STRM (GETSTREAM FILE 'INPUT] [SETQ BITSPERPIXEL (SELECTQ (SKIPSEPRS STRM) ((%" %)) 1) (PROGN (* ;  "after height can come the bits per pixel.") (RATOM FILE] (SETQ W (FOLDHI (ITIMES BITSPERPIXEL WIDTH) BITSPERWORD)) (SETQ BM (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL)) (SETQ BASE (fetch BITMAPBASE of BM)) (COND ((EQ HEIGHT 0)) [(EQ (SKIPSEPRS STRM) '%") (FRPTQ HEIGHT (SKIPSEPRS STRM) (OR (EQ (\BIN STRM) (CHARCODE %")) (GO BAD)) (FRPTQ W [\PUTBASEBYTE BASE 0 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM) (SUB1 (CHARCODE A))) 4) (IDIFFERENCE (\BIN STRM) (SUB1 (CHARCODE A] [\PUTBASEBYTE BASE 1 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM) (SUB1 (CHARCODE A))) 4) (IDIFFERENCE (\BIN STRM) (SUB1 (CHARCODE A] (SETQ BASE (\ADDBASE BASE 1))) (OR (EQ (\BIN STRM) (CHARCODE %")) (GO BAD] (T (GO BAD))) (SKIPSEPRS STRM) (OR (EQ (\BIN STRM) (CHARCODE %))) (GO BAD)) (RETURN BM) BAD (ERROR "BAD FORMAT OF BITMAP IN FILE"]) + +(\INSUREBITSPERPIXEL [LAMBDA (NBITS) (* kbr%: "10-Aug-85 15:49") (* ;; "determines if NBITS is a legal color bits per pixel.") (SELECTQ NBITS (NIL 1) ((1 4 8 24) NBITS) (\ILLEGAL.ARG NBITS]) + +(MAXIMUMCOLOR [LAMBDA (BITSPERPIXEL) (* kbr%: "29-Jan-86 12:12") (MASK.1'S 0 BITSPERPIXEL]) + +(OPPOSITECOLOR [LAMBDA (COLOR BITSPERPIXEL) (* kbr%: " 5-Jun-85 18:36") (IDIFFERENCE (MAXIMUMCOLOR BITSPERPIXEL) COLOR]) + +(MAXIMUMSHADE [LAMBDA (BITSPERPIXEL) (* kbr%: " 5-Jun-85 18:37") (COND ((EQ BITSPERPIXEL 1) BLACKSHADE) (T (MAXIMUMCOLOR BITSPERPIXEL]) + +(OPPOSITESHADE [LAMBDA (SHADE BITSPERPIXEL) (* kbr%: " 5-Jun-85 18:39") (IDIFFERENCE (MAXIMUMSHADE BITSPERPIXEL) SHADE]) + +(\MEDW.BITBLT + [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) + (* ; "Edited 18-Jan-94 17:01 by nilsson") + (OR (IMAGESTREAMP SOURCE) + (IMAGESTREAMP DESTINATION) + (SHOULDNT "Neither SOURCE nor DESTINATION is an imagestream.")) + (COND + ((BITMAPP SOURCE) + (LET ((DSTWIN (WFROMDS DESTINATION T)) + (DD (\GETDISPLAYDATA DESTINATION))) + (WINDOWOP 'BBTTOWIN (fetch (WINDOW SCREEN) of DSTWIN) + SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM + WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION SOURCELEFT SOURCEBOTTOM) + )) + [(BITMAPP DESTINATION) + (LET* ((SRCWIN (WFROMDS SOURCE T)) + (DD (\GETDISPLAYDATA SOURCE)) + (SOURCELEFTTRANSFORMED (OR (\DSPTRANSFORMX SOURCELEFT DD) + SOURCELEFT)) + (SOURCEBOTTOMTRANSFORMED (OR (\DSPTRANSFORMY SOURCEBOTTOM DD) + SOURCEBOTTOM))) + (WINDOWOP 'BBTFROMWIN (fetch (WINDOW SCREEN) of SRCWIN) + (fetch (\DISPLAYDATA DDDestination) of DD) + SOURCELEFTTRANSFORMED SOURCEBOTTOMTRANSFORMED DESTINATION DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION + (IMAX SOURCELEFTTRANSFORMED (fetch (\DISPLAYDATA DDClippingLeft) + of DD)) + (IMAX SOURCEBOTTOMTRANSFORMED (fetch (\DISPLAYDATA DDClippingBottom) + of DD] + [(EQ (DSPDESTINATION NIL SOURCE) + (DSPDESTINATION NIL DESTINATION)) (* ; + "SOURCE and DESTINATION are on the same SCREEN. Optimized special case.") + + (* ;; "Make sure the windows are open and on top") + + (* ;; "If they are overlapping use an intermediate bitmap, else just shovle bits.") + + (LET* ((SRCWIN (WFROMDS SOURCE T)) + (DD (\GETDISPLAYDATA SOURCE)) + (SOURCELEFTTRANSFORMED (OR (\DSPTRANSFORMX SOURCELEFT DD) + SOURCELEFT)) + (SOURCEBOTTOMTRANSFORMED (OR (\DSPTRANSFORMY SOURCEBOTTOM DD) + SOURCEBOTTOM))) + (\INSURETOPWDS SOURCE) + (WINDOWOP 'BBTWINWIN (fetch (WINDOW SCREEN) of SRCWIN) + (fetch (\DISPLAYDATA DDDestination) of DD) + SOURCELEFTTRANSFORMED SOURCEBOTTOMTRANSFORMED DESTINATION DESTINATIONLEFT + DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION + (IMAX SOURCELEFTTRANSFORMED (fetch (\DISPLAYDATA DDClippingLeft) + of DD)) + (IMAX SOURCEBOTTOMTRANSFORMED (fetch (\DISPLAYDATA DDClippingBottom) + of DD] + (T (SHOULDNT "Invalid argument to \XW.BIBLT"))) + T]) +) + +(CL:DEFUN FINISH-READING-BITMAP (STREAM) + +(* ;;; "The syntax for bitmaps is") + + (* ;; "#*(width height [bits-per-pixel])XXXXXX...") + +(* ;;; "where WIDTH and HEIGHT are the dimensions of the bitmap, BITS-PER-PIXEL can be omitted if it is equal to one, and the X's are single characters between @ and O (in ASCII), each representing four bits. There will be exactly (* (ceiling (* WIDTH BITS-PER-PIXEL) 16) 4) characters for each row of the bitmap and exactly HEIGHT rows. Note that there are no spaces allowed between the * and the (, between the ) and the first X, or anywhere inside the string of X's. Also, the character after the last X must not be of type OTHER.") + +(* ;;; +"When we enter this function, called from HASH-STAR, the stream should be pointing at the (.") + + (LET + ((DIMENSIONS (READ STREAM))) + (CL:ASSERT (CL:LISTP DIMENSIONS) + '(DIMENSIONS) + "BUG: FINISH-READING-BITMAP called with non-list on stream: ~S" DIMENSIONS) + (DESTRUCTURING-BIND + (WIDTH HEIGHT &OPTIONAL (BITS-PER-PIXEL 1) + &REST EXTRAS) + DIMENSIONS (* ; "Parsing the dimensions.") + (IF (OR (NOT (FIXP WIDTH)) + (NOT (FIXP HEIGHT)) + (NOT (FIXP BITS-PER-PIXEL)) + (NOT (NULL EXTRAS))) + THEN (CL:ERROR "Bad bitmap dimension specification: ~S" DIMENSIONS)) + (LET + ((BITMAP NIL) + (BASE NIL) + (QUAD-CHARS-PER-ROW (FOLDHI (CL:* WIDTH BITS-PER-PIXEL) + 16))) + [IF *READ-SUPPRESS* + THEN (CL:DOTIMES (I (CL:* HEIGHT QUAD-CHARS-PER-ROW 4)) + (CL:READ-CHAR STREAM)) + ELSE (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT BITS-PER-PIXEL)) + (SETQ BASE (FETCH BITMAPBASE OF BITMAP)) + (LET [(STREAM (\GETSTREAM STREAM 'INPUT] + (CL:DOTIMES (ROW HEIGHT) + [IF (ZEROP (FETCH (STREAM CHARSET) OF STREAM)) + THEN (* ; "Do it the quicker way") + (CL:DOTIMES (QUAD QUAD-CHARS-PER-ROW) + (LET [(NIB00 (- (\BIN STREAM) + (CHARCODE @))) + (NIB01 (- (\BIN STREAM) + (CHARCODE @))) + (NIB10 (- (\BIN STREAM) + (CHARCODE @))) + (NIB11 (- (\BIN STREAM) + (CHARCODE @] + (IF (OR (NOT (<= 0 NIB00 15)) + (NOT (<= 0 NIB01 15)) + (NOT (<= 0 NIB10 15)) + (NOT (<= 0 NIB11 15))) + THEN (CL:ERROR + "Illegal character in bitmap contents specification." + )) + (\PUTBASEBYTE BASE 0 (LOGOR (LLSH NIB00 4) + NIB01)) + (\PUTBASEBYTE BASE 1 (LOGOR (LLSH NIB10 4) + NIB11))) + (SETQ BASE (\ADDBASE BASE 1))) + ELSE (* ; "Somewhat slower...") + (CL:DOTIMES (QUAD QUAD-CHARS-PER-ROW) + (LET [(NIB00 (- (READCCODE STREAM) + (CHARCODE @))) + (NIB01 (- (READCCODE STREAM) + (CHARCODE @))) + (NIB10 (- (READCCODE STREAM) + (CHARCODE @))) + (NIB11 (- (READCCODE STREAM) + (CHARCODE @] + (IF (OR (NOT (<= 0 NIB00 15)) + (NOT (<= 0 NIB01 15)) + (NOT (<= 0 NIB10 15)) + (NOT (<= 0 NIB11 15))) + THEN (CL:ERROR + "Illegal character in bitmap contents specification." + )) + (\PUTBASEBYTE BASE 0 (LOGOR (LLSH NIB00 4) + NIB01)) + (\PUTBASEBYTE BASE 1 (LOGOR (LLSH NIB10 4) + NIB11))) + (SETQ BASE (\ADDBASE BASE 1)))])] + BITMAP)))) +(DECLARE%: EVAL@COMPILE + +(RPAQQ MINIMUMCOLOR 0) + +(RPAQQ MINIMUMSHADE 0) + + +(CONSTANTS (MINIMUMCOLOR 0) + (MINIMUMSHADE 0)) +) + +(MOVD 'BITMAPBIT '\BITMAPBIT) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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))) +) + +(* "END EXPORTED DEFINITIONS") + +) + +(DEFOPTIMIZER BITMAPBIT (&REST ARGS) + (BITMAPBIT.EXPANDER ARGS)) + +(DEFOPTIMIZER BITMAPP (Y) + `((OPENLAMBDA (X) + (AND (type? BITMAP X) + X)) + ,Y)) +(DEFINEQ + +(BITMAPBIT.EXPANDER [LAMBDA (ARGS) (* hdj "19-Mar-85 12:14") (PROG ((BM (CAR ARGS)) (X (CADR ARGS)) (Y (CADDR ARGS)) NEWVALUE) [COND ((EQ (LENGTH ARGS) 4) (SETQ NEWVALUE (CADDDR ARGS] (RETURN `((OPCODES MISC4 6) ,BM ,X ,Y ,NEWVALUE]) +) +(DEFINEQ + +(\BITBLT.DISPLAY + [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH + HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) + (* ; "Edited 16-Feb-94 10:28 by sybalsky") + (DECLARE (LOCALVARS . T)) + (PROG (SOURCEDD SOURCE SOURCEIMAGEOPS CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) + [COND + [(type? BITMAP SOURCEBITMAP) + (OR SOURCELEFT (SETQ SOURCELEFT 0)) + (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) + (SETQ CLIPPEDSOURCELEFT SOURCELEFT) + (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* ; + "limit the WIDTH and HEIGHT to the source size.") + [SETQ WIDTH (COND + (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (BITMAP BITMAPWIDTH) + of SOURCEBITMAP) + SOURCELEFT))) + (T (fetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP] + (SETQ HEIGHT (COND + (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (BITMAP BITMAPHEIGHT) + of SOURCEBITMAP) + SOURCEBOTTOM))) + (T (fetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP] + ((SETQ SOURCEDD (\GETDISPLAYDATA SOURCEBITMAP)) + (SETQ SOURCE SOURCEBITMAP) + [OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT) of (ffetch + (\DISPLAYDATA + DDClippingRegion + ) of + SOURCEDD + ] + [OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM) + of (ffetch (\DISPLAYDATA + DDClippingRegion) + of SOURCEDD] + (* ; + "do transformations coming out of source") + (SETQ SOURCEBITMAP (fetch (\DISPLAYDATA DDDestination) of SOURCEDD)) + (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT SOURCEDD)) + (fetch (\DISPLAYDATA DDClippingLeft) of SOURCEDD) + )) + (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM + SOURCEDD)) + (fetch (\DISPLAYDATA DDClippingBottom) of + SOURCEDD))) + (* ; + "limit the WIDTH and HEIGHT by the source dimensions.") + [SETQ WIDTH (COND + (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight + ) of SOURCEDD) + CLIPPEDSOURCELEFT))) + (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of + SOURCEDD + ) + CLIPPEDSOURCELEFT] + [SETQ HEIGHT (COND + (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (\DISPLAYDATA + DDClippingTop) + of SOURCEDD) + CLIPPEDSOURCEBOTTOM))) + (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop) of SOURCEDD + ) + CLIPPEDSOURCEBOTTOM] (* ; + "if texture is not given, use the display stream's.") + (OR TEXTURE (SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of SOURCEDD] + (COND + ((OR (IGEQ 0 WIDTH) + (IGEQ 0 HEIGHT)) (* ; + "if either width or height is 0, don't do anything.") + (RETURN))) + (RETURN + (COND + [(type? BITMAP DESTINATION) + (COND + ((WINDOWP SOURCE) + + (* ;; "bring source window to the top. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") + + (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCEBITMAP) + (\BITBLT.BITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION + DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION + TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) + (T (\BITBLT.BITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION + DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION + TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM] + (T (PROG (DESTSTRM) + (SETQ DESTSTRM (\OUTSTREAMARG DESTINATION)) + (COND + ([AND (NEQ SOURCE DESTINATION) + (OR (WINDOWP SOURCE) + (AND SOURCE (WFROMDS SOURCE] + + (* ;; "both source and destination are windows, see if they overlap and use an intermediate bitmap. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window. ALSO use bitmap if the destination is on a different screen.") + + [COND + ((WINDOWP DESTINATION) + (COND + ([AND (WOVERLAPP SOURCE DESTINATION) + (EQ (FETCH (STREAM IMAGEOPS) OF (WINDOWPROP + SOURCE + 'DSP)) + (FETCH (STREAM IMAGEOPS) OF (WINDOWPROP + DESTINATION + 'DSP] + (RETURN (PROG (SCRATCHBM) + (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) + (BITBLT SOURCEBITMAP SOURCELEFT + SOURCEBOTTOM (SETQ SCRATCHBM + (BITMAPCREATE WIDTH + HEIGHT)) + 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)) + (RETURN (BITBLT SCRATCHBM 0 0 DESTSTRM + DESTINATIONLEFT DESTINATIONBOTTOM + WIDTH HEIGHT SOURCETYPE OPERATION + TEXTURE CLIPPINGREGION] + (* ; + "bring the source to the top. this should be done uninterruptably but is better than nothing.") + (TOTOPW SOURCE))) + (COND + ((OR (NOT SOURCE) + (EQ (DSPDESTINATION NIL SOURCE) + (DSPDESTINATION NIL DESTSTRM))) + (PROG (stodx stody left top bottom right DESTDD DESTBITMAP + DESTINATIONNBITS SOURCENBITS MAXSHADE) + (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) + (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) + of DESTDD)) + + (* ;; "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") + + (* ;; "We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.") + + (\INSURETOPWDS DESTSTRM) + (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) + (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) + [PROGN (* ; + "compute limits based on clipping regions.") + (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) + of DESTDD)) + (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) + of DESTDD)) + (SETQ right (fetch (\DISPLAYDATA DDClippingRight) + of DESTDD)) + (SETQ top (fetch (\DISPLAYDATA DDClippingTop) + of DESTDD)) + (COND + (CLIPPINGREGION (* ; + "hard case, two destination clipping regions: do calculations to merge them.") + (PROG (CRLEFT CRBOTTOM) + [SETQ left (IMAX left (SETQ CRLEFT + (\DSPTRANSFORMX + (fetch (REGION LEFT) + of CLIPPINGREGION) + DESTDD] + [SETQ bottom (IMAX bottom + (SETQ CRBOTTOM + (\DSPTRANSFORMY + (fetch (REGION BOTTOM) + of CLIPPINGREGION) + DESTDD] + [SETQ right (IMIN right (IPLUS CRLEFT + (fetch + (REGION WIDTH) + of + CLIPPINGREGION + ] + (SETQ top (IMIN top (IPLUS CRBOTTOM + (fetch (REGION + HEIGHT) + of CLIPPINGREGION + ] + (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) + of DESTBITMAP)) + (SETQ SOURCENBITS (ffetch (BITMAP BITMAPBITSPERPIXEL) + of SOURCEBITMAP)) + [COND + ((NOT (EQ SOURCENBITS DESTINATIONNBITS)) + (COND + ((EQ SOURCENBITS 1) + (SETQ SOURCEBITMAP (COLORIZEBITMAP SOURCEBITMAP 0 + (MAXIMUMCOLOR DESTINATIONNBITS + ) + DESTINATIONNBITS))) + [(EQ DESTINATIONNBITS 1) + (SETQ SOURCEBITMAP (UNCOLORIZEBITMAP SOURCEBITMAP + (COLORMAP DESTINATIONNBITS] + (T + + (* ;; "Between two color bitmaps with different bpp. It seems that NOP is better than breaking. Eventually do some kind of output here, but don't error now. ") + + (RETURN] + + (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") + + [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) + (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) + [COND + (WIDTH (* ; "WIDTH is optional") + (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) + right] + (COND + (HEIGHT (* ; "HEIGHT is optional") + (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) + top] + (* ; "Clip and translate coordinates.") + (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) + (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) + + (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") + + [PROGN (* ; "compute left margin") + (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) + 0)) (* ; "compute bottom margin") + (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom + stody) + 0)) + (* ; "compute right margin") + (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) + of SOURCEBITMAP) + (IDIFFERENCE right stodx) + (IPLUS CLIPPEDSOURCELEFT WIDTH))) + (* ; "compute top margin") + (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) + of SOURCEBITMAP) + (IDIFFERENCE top stody) + (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] + (COND + ((OR (ILEQ right left) + (ILEQ top bottom)) (* ; "there is nothing to move.") + (RETURN))) + (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) + of DESTDD))) + (SETQ MAXSHADE (MAXIMUMSHADE DESTINATIONNBITS)) + (SELECTQ SOURCETYPE + (MERGE (* ; + "Need to use complement of TEXTURE") + [COND + ((AND (LISTP TEXTURE) + (EQ DESTINATIONNBITS 1)) + (* ; + "either a color or a (texture color) filling.") + (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE] + [SETQ TEXTURE (COND + ((NULL TEXTURE) + MAXSHADE) + ((FIXP TEXTURE) + (LOGXOR (LOGAND TEXTURE MAXSHADE) + MAXSHADE)) + [(type? BITMAP TEXTURE) + (INVERT.TEXTURE.BITMAP + TEXTURE + (OR \BBSCRATCHTEXTURE + (SETQ \BBSCRATCHTEXTURE + (BITMAPCREATE 16 16] + ((NOT (EQ DESTINATIONNBITS 1)) + (COLORNUMBERP TEXTURE DESTINATIONNBITS) + ) + (T (\ILLEGAL.ARG TEXTURE] + [COND + ((NOT (EQ DESTINATIONNBITS 1)) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE + DESTINATIONNBITS]) + (TEXTURE [COND + ((EQ DESTINATIONNBITS 1) + (* ; + "either a color or a (texture color) filling.") + (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE]) + NIL) + [COND + ((NOT (EQ DESTINATIONNBITS 1)) + (SETQ left (ITIMES DESTINATIONNBITS left)) + (SETQ right (ITIMES DESTINATIONNBITS right)) + (SETQ stodx (ITIMES DESTINATIONNBITS stodx] + [.WHILE.TOP.DS. DESTSTRM + (PROG (HEIGHT WIDTH DTY DLX STY SLX) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (SETQ WIDTH (IDIFFERENCE right left)) + (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) + (SETQ DLX (IPLUS left stodx)) + (SETQ STY (\SFInvert SOURCEBITMAP top)) + (SETQ SLX left) + (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT + with WIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT + with HEIGHT) + (COND + ((EQ SOURCETYPE 'MERGE) + (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX + STY DESTBITMAP DLX DTY WIDTH HEIGHT + OPERATION TEXTURE)) + (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY + DESTBITMAP DLX DTY HEIGHT SOURCETYPE + OPERATION TEXTURE] + (RETURN T))) + (T (IMAGEOP 'IMBITBLT DESTSTRM SOURCEBITMAP SOURCELEFT SOURCEBOTTOM + DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT + CLIPPEDSOURCEBOTTOM]) + +(\BITBLT.BITMAP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* kbr%: "15-Feb-86 20:21") (DECLARE (LOCALVARS . T)) (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (* ;  "Need to use complement of TEXTURE") (* ; "MAY NOT WORK FOR COLOR CASE.") [SETQ TEXTURE (COND ((NULL TEXTURE) BLACKSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) ((AND (NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS))) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] (T (\ILLEGAL.ARG TEXTURE]) NIL) (COND [(EQ SOURCENBITS DESTINATIONNBITS) (* ;  "going from one to another of the same size.") (SELECTQ DESTINATIONNBITS (4 (* ;  "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") (SETQ left (UNFOLD left 4)) (SETQ right (UNFOLD right 4)) (SETQ stodx (UNFOLD stodx 4)) (* ;  "set texture if it will ever get looked at.") (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (8 (SETQ left (UNFOLD left 8)) (SETQ right (UNFOLD right 8)) (SETQ stodx (UNFOLD stodx 8)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (24 (SETQ left (ITIMES left 24)) (SETQ right (ITIMES right 24)) (SETQ stodx (ITIMES stodx 24)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) NIL) (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY [PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE 'MERGE) (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT SOURCETYPE OPERATION TEXTURE])] [(EQ SOURCENBITS 1) (* ;  "going from a black and white bitmap to a color map") (AND SOURCETYPE (NOT (EQ SOURCETYPE 'INPUT)) (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) (PROG (HEIGHT WIDTH DBOT DLFT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DBOT (IPLUS bottom stody)) (SETQ DLFT (IPLUS left stodx)) (SELECTQ OPERATION ((NIL REPLACE) (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) DESTINATIONNBITS)) (PAINT) (INVERT) (ERASE) (SHOULDNT] (T (* ;  "going from color map into black and white map.") (ERROR "not implemented to blt between bitmaps of different pixel size."))) (RETURN T]) + +(\BITBLT.MERGE [LAMBDA (PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE) (* rmk%: "21-Jun-84 23:10") (* ;; "Can't do MERGE in Pilot bitblt, so simulate by blting source to scratch bitmap, erasing bits not in Texture, then blting scratch to ultimate destination. Note that TEXTURE has already been complemented above in preparation for this") (COND ((AND (EQ OPERATION 'REPLACE) (NEQ SOURCEBITMAP DESTBITMAP)) (* ;  "Don't need a scratch bitmap, just do two blts") (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT 'INPUT 'REPLACE) (* ;  "Blt the source, then erase bits that aren't in TEXTURE") (\BITBLTSUB PILOTBBT NIL NIL NIL DESTBITMAP DLX DTY HEIGHT 'TEXTURE 'ERASE TEXTURE)) (T (PROG (SCRATCH (SCRATCHLEFT (MOD DLX BITSPERWORD)) (SCRATCHTOP (MOD DTY 4))) (SETQ SCRATCH (\GETPILOTBBTSCRATCHBM (IPLUS WIDTH SCRATCHLEFT) (IPLUS HEIGHT SCRATCHTOP))) (* ;  "Get scratch bm, slightly larger than WIDTH and HEIGHT to allow texture to align") (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY SCRATCH SCRATCHLEFT SCRATCHTOP HEIGHT 'INPUT 'REPLACE) (* ; "Blt source into scratch") (\BITBLTSUB PILOTBBT NIL NIL NIL SCRATCH SCRATCHLEFT SCRATCHTOP HEIGHT 'TEXTURE 'ERASE TEXTURE) (* ; "Erase what isn't in TEXTURE") (* ;  "Finally do original operation using the merged source") (\BITBLTSUB PILOTBBT SCRATCH SCRATCHLEFT SCRATCHTOP DESTBITMAP DLX DTY HEIGHT 'INPUT OPERATION]) + +(\BLTSHADE.DISPLAY [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 28-Jan-93 17:33 by jds") (* ; "BLTSHADE to a display stream") (DECLARE (LOCALVARS . T)) (PROG (left top bottom right DESTINATIONBITMAP DESTDD DESTINATIONNBITS) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of STREAM)) (* ;; "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") (* ;; "We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.") (\INSURETOPWDS STREAM) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD)) (COND (CLIPPINGREGION (* ;  "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (SETQ DESTINATIONBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) ((LITATOM NEW-ATOM) (COND ((NULL TEXTURE) (* ;  "NIL case. default texture to background texture.") (ffetch (\DISPLAYDATA DDTexture) of DESTDD)) ((NOT (EQ DESTINATIONNBITS 1)) (* ; "should be a color name") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (\ILLEGAL.ARG TEXTURE))) (T (\ILLEGAL.ARG TEXTURE)))) ((SMALLP FIXP) (LOGAND TEXTURE (MAXIMUMSHADE DESTINATIONNBITS))) (BITMAP TEXTURE) (LISTP (* ;  "should be a list of levels rgb or hls.") (OR (AND (NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS)) (\ILLEGAL.ARG TEXTURE))) (\ILLEGAL.ARG TEXTURE))) [COND ((NOT (EQ DESTINATIONNBITS 1)) (SETQ left (ITIMES DESTINATIONNBITS left)) (SETQ right (ITIMES DESTINATIONNBITS right)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS] [.WHILE.TOP.DS. STREAM (PROG (HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right left)) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP top) HEIGHT 'TEXTURE (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)) TEXTURE (ITIMES DESTINATIONNBITS (fetch (\DISPLAYDATA DDXOFFSET) of DESTDD)) (fetch (\DISPLAYDATA DDYOFFSET) of DESTDD] (RETURN T]) + +(\BLTSHADE.BITMAP [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 28-Jan-93 17:38 by jds") (DECLARE (LOCALVARS . T)) (PROG (left bottom top right DESTINATIONNBITS) (SETQ left 0) (SETQ bottom 0) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTINATIONBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTINATIONBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) (COND ((EQ DESTINATIONNBITS 1) (* ;  "DESTINATIONNBITS is NIL for the case of 1 bit per pixel.") (SETQ DESTINATIONNBITS NIL))) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) ((LITATOM NEW-ATOM) (* ; "includes NIL case") (COND [DESTINATIONNBITS (COND (TEXTURE (* ; "should be a color name") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (\ILLEGAL.ARG TEXTURE))) (T (MAXIMUMCOLOR DESTINATIONNBITS] (TEXTURE (\ILLEGAL.ARG TEXTURE)) (T WHITESHADE))) ((SMALLP FIXP) (COND [DESTINATIONNBITS (* ;; "if fixp use the low order bits as a color number. This picks up the case of BLACKSHADE being used to INVERT.") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (LOGAND TEXTURE (MAXIMUMCOLOR DESTINATIONNBITS] (T (LOGAND TEXTURE BLACKSHADE)))) (BITMAP TEXTURE) (LISTP (* ;  "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") (COND [DESTINATIONNBITS (* ;; "color case: If it is a color, use it; if it is a list that contains a color, use that; otherwise, use the texture") (COND ((COLORNUMBERP TEXTURE)) [(COLORNUMBERP (CAR (LISTP (CDR TEXTURE] ((FIXP (CAR TEXTURE)) (LOGAND (CAR TEXTURE) (MAXIMUMCOLOR DESTINATIONNBITS))) ((TEXTUREP (CAR TEXTURE))) (T (\ILLEGAL.ARG TEXTURE] ((TEXTUREP (CAR TEXTURE))) ((COLORNUMBERP TEXTURE) (TEXTUREOFCOLOR TEXTURE)) (T (\ILLEGAL.ARG TEXTURE)))) (\ILLEGAL.ARG TEXTURE))) (* ; "filling an area with a texture.") [COND (DESTINATIONNBITS (SETQ left (ITIMES DESTINATIONNBITS left)) (SETQ right (ITIMES DESTINATIONNBITS right)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS] (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY (PROG (HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right left)) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP top) HEIGHT 'TEXTURE OPERATION TEXTURE))) (RETURN T]) +) +(DEFINEQ + +(\BITBLT.BITMAP.SLOW [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 11-Apr-90 15:23 by nm") (* ;; "Copy of \BITBLT.BITMAP. Used to smash the definition of \MAIKO.OLDBITBLT.BITMAP. ")  (* kbr%: "15-Feb-86 20:21") (DECLARE (LOCALVARS . T)) (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (* ;  "Need to use complement of TEXTURE") (* ; "MAY NOT WORK FOR COLOR CASE.") [SETQ TEXTURE (COND ((NULL TEXTURE) BLACKSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) ((AND (NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS))) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] (T (\ILLEGAL.ARG TEXTURE]) NIL) (COND [(EQ SOURCENBITS DESTINATIONNBITS) (* ;  "going from one to another of the same size.") (SELECTQ DESTINATIONNBITS (4 (* ;  "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") (SETQ left (UNFOLD left 4)) (SETQ right (UNFOLD right 4)) (SETQ stodx (UNFOLD stodx 4)) (* ;  "set texture if it will ever get looked at.") (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (8 (SETQ left (UNFOLD left 8)) (SETQ right (UNFOLD right 8)) (SETQ stodx (UNFOLD stodx 8)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (24 (SETQ left (ITIMES left 24)) (SETQ right (ITIMES right 24)) (SETQ stodx (ITIMES stodx 24)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) NIL) (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY [PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE 'MERGE) (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT SOURCETYPE OPERATION TEXTURE])] [(EQ SOURCENBITS 1) (* ;  "going from a black and white bitmap to a color map") (AND SOURCETYPE (NOT (EQ SOURCETYPE 'INPUT)) (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) (PROG (HEIGHT WIDTH DBOT DLFT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DBOT (IPLUS bottom stody)) (SETQ DLFT (IPLUS left stodx)) (SELECTQ OPERATION ((NIL REPLACE) (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) DESTINATIONNBITS)) (PAINT) (INVERT) (ERASE) (SHOULDNT] (T (* ;  "going from color map into black and white map.") (ERROR "not implemented to blt between bitmaps of different pixel size."))) (RETURN T]) +) +(DEFINEQ + +(\PUNT.BLTSHADE.BITMAP [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 28-Jan-93 17:38 by jds") (* ;; "This FNS is for a punt case of \BLTSHADE.BITMAP which is implemeted in C ") (* ;  " Stolen from old definition of \BLTSHADE.BITMAP") (DECLARE (LOCALVARS . T)) (PROG (left bottom top right DESTINATIONNBITS) (SETQ left 0) (SETQ bottom 0) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTINATIONBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTINATIONBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) (COND ((EQ DESTINATIONNBITS 1) (* ;  "DESTINATIONNBITS is NIL for the case of 1 bit per pixel.") (SETQ DESTINATIONNBITS NIL))) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) ((LITATOM NEW-ATOM) (* ; "includes NIL case") (COND [DESTINATIONNBITS (COND (TEXTURE (* ; "should be a color name") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (\ILLEGAL.ARG TEXTURE))) (T (MAXIMUMCOLOR DESTINATIONNBITS] (TEXTURE (\ILLEGAL.ARG TEXTURE)) (T WHITESHADE))) ((SMALLP FIXP) (COND [DESTINATIONNBITS (* ;; "if fixp use the low order bits as a color number. This picks up the case of BLACKSHADE being used to INVERT.") (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) (LOGAND TEXTURE (MAXIMUMCOLOR DESTINATIONNBITS] (T (LOGAND TEXTURE BLACKSHADE)))) (BITMAP TEXTURE) (LISTP (* ;  "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") (COND [DESTINATIONNBITS (* ;; "color case: If it is a color, use it; if it is a list that contains a color, use that; otherwise, use the texture") (COND ((COLORNUMBERP TEXTURE)) [(COLORNUMBERP (CAR (LISTP (CDR TEXTURE] ((FIXP (CAR TEXTURE)) (LOGAND (CAR TEXTURE) (MAXIMUMCOLOR DESTINATIONNBITS))) ((TEXTUREP (CAR TEXTURE))) (T (\ILLEGAL.ARG TEXTURE] ((TEXTUREP (CAR TEXTURE))) ((COLORNUMBERP TEXTURE) (TEXTUREOFCOLOR TEXTURE)) (T (\ILLEGAL.ARG TEXTURE)))) (\ILLEGAL.ARG TEXTURE))) (* ; "filling an area with a texture.") [COND (DESTINATIONNBITS (SETQ left (ITIMES DESTINATIONNBITS left)) (SETQ right (ITIMES DESTINATIONNBITS right)) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS] (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY (PROG (HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right left)) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert DESTINATIONBITMAP top) HEIGHT 'TEXTURE OPERATION TEXTURE))) (RETURN T]) + +(\PUNT.BITBLT.BITMAP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* ; "Edited 5-Jun-90 11:59 by Takeshi") (* ;; " This FNS is for a punt case of \BITBLT.BITMAP which is implemeted in C") (* ;; " Stolen from old definition of \BITBLT.BITMAP") (DECLARE (LOCALVARS . T)) (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (* ;  "Need to use complement of TEXTURE") (* ; "MAY NOT WORK FOR COLOR CASE.") [SETQ TEXTURE (COND ((NULL TEXTURE) BLACKSHADE) ((FIXP TEXTURE) (LOGXOR (LOGAND TEXTURE BLACKSHADE) BLACKSHADE)) ((AND (NOT (EQ DESTINATIONNBITS 1)) (COLORNUMBERP TEXTURE DESTINATIONNBITS))) [(type? BITMAP TEXTURE) (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE (SETQ \BBSCRATCHTEXTURE (BITMAPCREATE 16 16] (T (\ILLEGAL.ARG TEXTURE]) NIL) (COND [(EQ SOURCENBITS DESTINATIONNBITS) (* ;  "going from one to another of the same size.") (SELECTQ DESTINATIONNBITS (4 (* ;  "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") (SETQ left (UNFOLD left 4)) (SETQ right (UNFOLD right 4)) (SETQ stodx (UNFOLD stodx 4)) (* ;  "set texture if it will ever get looked at.") (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (8 (SETQ left (UNFOLD left 8)) (SETQ right (UNFOLD right 8)) (SETQ stodx (UNFOLD stodx 8)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) (24 (SETQ left (ITIMES left 24)) (SETQ right (ITIMES right 24)) (SETQ stodx (ITIMES stodx 24)) (AND (EQ SOURCETYPE 'MERGE) (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) NIL) (* ;  "easy case of black and white bitmap into black and white or color to color or texture filling.") (UNINTERRUPTABLY [PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) (COND ((EQ SOURCETYPE 'MERGE) (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)) (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT SOURCETYPE OPERATION TEXTURE])] [(EQ SOURCENBITS 1) (* ;  "going from a black and white bitmap to a color map") (AND SOURCETYPE (NOT (EQ SOURCETYPE 'INPUT)) (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) (PROG (HEIGHT WIDTH DBOT DLFT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DBOT (IPLUS bottom stody)) (SETQ DLFT (IPLUS left stodx)) (SELECTQ OPERATION ((NIL REPLACE) (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) DESTINATIONNBITS)) (PAINT) (INVERT) (ERASE) (SHOULDNT] (T (* ;  "going from color map into black and white map.") (ERROR "not implemented to blt between bitmaps of different pixel size."))) (RETURN T]) +) +(DEFINEQ + +(\SCALEDBITBLT.DISPLAY [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM SCALE) (* ; "Edited 28-Mar-90 18:49 by jds") (LET (BITMAP REGION) (IF (NULL SCALE) THEN (SETQ SCALE 1)) (IF (WINDOWP SOURCEBITMAP) THEN (SETQ REGION (DSPCLIPPINGREGION NIL SOURCEBITMAP)) (IF (NULL WIDTH) THEN (SETQ WIDTH (FETCH (REGION WIDTH) OF REGION))) (IF (NULL HEIGHT) THEN (SETQ HEIGHT (FETCH (REGION HEIGHT) OF REGION))) ELSEIF (BITMAPP SOURCEBITMAP) THEN (IF (NULL WIDTH) THEN (SETQ WIDTH (BITMAPWIDTH SOURCEBITMAP))) (IF (NULL HEIGHT) THEN (SETQ HEIGHT (BITMAPHEIGHT SOURCEBITMAP))) ELSE (SHOULDNT)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM (DSPYPOSITION NIL DESTINATION))) (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT (DSPXPOSITION NIL DESTINATION))) (SETQ BITMAP (BITMAPCREATE WIDTH HEIGHT)) (BITBLT SOURCEBITMAP SOURCELEFT SOURCEBOTTOM BITMAP) (BITBLT (EXPANDBITMAP BITMAP SCALE SCALE) NIL NIL DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM (TIMES WIDTH SCALE) (TIMES HEIGHT SCALE) SOURCETYPE OPERATION TEXTURE CLIPPINGREGION]) + +(\BACKCOLOR.DISPLAY + [LAMBDA (DISPLAYSTREAM TEXTURE) (* ; "Edited 15-Feb-94 16:50 by nilsson") + (PROG (DD BITSPERPIXEL) + (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM)) + (RETURN (PROG1 (fetch (\DISPLAYDATA DDTexture) of DD) + (COND + ((NULL TEXTURE)) + ((AND (BITMAPP TEXTURE) + (EQ (fetch (BITMAP BITMAPRASTERWIDTH) of TEXTURE) + 1) + (ILEQ (BITMAPHEIGHT TEXTURE) + 16)) (* ; "allow small bitmaps") + (freplace (\DISPLAYDATA DDTexture) of DD with TEXTURE)) + ((FIXP TEXTURE) + (freplace (\DISPLAYDATA DDTexture) of DD with (LOGAND TEXTURE + WORDMASK)) + ) + ((NOT (EQ (SETQ BITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) + of (fetch (\DISPLAYDATA + DDDestination) + of DD))) + 1)) + (freplace (\DISPLAYDATA DDTexture) of DD with (COLORNUMBERP + TEXTURE + BITSPERPIXEL))) + (T (\ILLEGAL.ARG TEXTURE))))]) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +(RPAQQ \DisplayWordAlign 16) + +(RPAQQ \MaxBitMapWidth 65535) + +(RPAQQ \MaxBitMapHeight 65535) + +(RPAQQ \MaxBitMapWords 131066) + + +(CONSTANTS (\DisplayWordAlign 16) + (\MaxBitMapWidth 65535) + (\MaxBitMapHeight 65535) + (\MaxBitMapWords 131066)) +) + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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 'INVERT) + (EQ Operation 'ERASE)) + 0) + (T 1] + +(PUTPROPS \BITBLT1 MACRO ((bbt) + (BitBltSUBR bbt))) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \SYSBBTEXTURE \BBSCRATCHTEXTURE \SYSPILOTBBT \PILOTBBTSCRATCHBM) +) +) + +(RPAQQ \BBSCRATCHTEXTURE NIL) + +(RPAQQ \PILOTBBTSCRATCHBM NIL) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MOVD? 'BITBLT 'BKBITBLT) +) + + + +(* ; "macro for this file so that BITBLT can be broken by users") + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE + +(PUTPROP 'BITBLT 'MACRO '(= . BKBITBLT)) +) + +(* "END EXPORTED DEFINITIONS") + + + + +(* ; "display stream functions") + +(DEFINEQ + +(DISPLAYSTREAMP [LAMBDA (X) (* ; "Edited 19-Feb-87 11:03 by rrb") (* ; "Is X a displaystream?") (AND (type? STREAM X) [OR (FMEMB (fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of X)) \DISPLAYSTREAMTYPES) (SOME (fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of X)) (FUNCTION (LAMBDA (STYPE) (FMEMB STYPE \DISPLAYSTREAMTYPES] X]) + +(DSPSOURCETYPE [LAMBDA (SOURCETYPE DISPLAYSTREAM) (* rmk%: "21-AUG-83 22:34") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (fetch DDSOURCETYPE of DD) [COND (SOURCETYPE (OR (FMEMB SOURCETYPE '(INPUT INVERT)) (LISPERROR "ILLEGAL ARG" SOURCETYPE)) (UNINTERRUPTABLY (freplace DDSOURCETYPE of DD with SOURCETYPE) (* ;  "update other fields that depend on operation.") (\SETPBTFUNCTION (fetch DDPILOTBBT of DD) SOURCETYPE (fetch DDOPERATION of DD)))])]) + +(DSPXOFFSET + [LAMBDA (XOFFSET DISPLAYSTREAM) (* ; "Edited 17-Apr-94 23:46 by sybalsky") + + (* ;; "coordinate position is stored in 15 bits in the range -2^15 to +2^15.") + + (IMAGEOP 'IMXOFFSET (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM)) + XOFFSET DISPLAYSTREAM]) + +(DSPYOFFSET + [LAMBDA (YOFFSET DISPLAYSTREAM) (* ; "Edited 17-Apr-94 23:46 by sybalsky") + + (* ;; "coordinate position is stored in 15 bits in the range -2^15 to +2^15.") + + (IMAGEOP 'IMYOFFSET (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM)) + YOFFSET DISPLAYSTREAM]) +) +(DEFINEQ + +(DSPCREATE [LAMBDA (DESTINATION) (* ; "Edited 16-Nov-87 17:32 by jop") (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device") (LET (DSTRM) [COND ((NULL DESTINATION) (SETQ DESTINATION ScreenBitMap)) (T (\DTEST DESTINATION 'BITMAP] (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \DSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \DISPLAYIMAGEOPS DEVICE _ DisplayFDEV ACCESS _ 'OUTPUT)) (* ;  "initial x and y positions are 0 when the data is created.") (DSPFONT DEFAULTFONT DSTRM) (* ;  "dspfont can win since the (default) display imageops are filled in the stream") (DSPDESTINATION DESTINATION DSTRM) (* ;  "dspdestination calls \SFFixFont, which presumes there is a font present.") (DSPFONT DEFAULTFONT DSTRM) (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM) (* ;  "called to cause the updating of the bitblt table from the fields initialized earlier.") DSTRM]) + +(DSPDESTINATION + [LAMBDA (DESTINATION DISPLAYSTREAM) + (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS \4DISPLAYIMAGEOPS \8DISPLAYIMAGEOPS \24DISPLAYIMAGEOPS + \XDISPLAYIMAGEOPS)) (* ; "Edited 28-Oct-93 13:23 by nilsson") + (PROG (DD) + (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)) + (RETURN (PROG1 (ffetch (\DISPLAYDATA DDDestination) of DD) + [COND + (DESTINATION (UNINTERRUPTABLY + (replace (STREAM DEVICE) of DISPLAYSTREAM + with (CL:TYPECASE DESTINATION + (BITMAP (SELECTQ (fetch (BITMAP + BITMAPBITSPERPIXEL + ) + of DESTINATION) + (1 DisplayFDEV) + (4 \4DISPLAYFDEV) + (8 \8DISPLAYFDEV) + (24 \24DISPLAYFDEV) + (SHOULDNT))) + (SCREEN XDisplayFDEV))) + (replace (STREAM IMAGEOPS) of DISPLAYSTREAM + with (CL:TYPECASE DESTINATION + (BITMAP (SELECTQ (fetch (BITMAP + BITMAPBITSPERPIXEL + ) + of DESTINATION) + (1 \DISPLAYIMAGEOPS) + (4 \4DISPLAYIMAGEOPS) + (8 \8DISPLAYIMAGEOPS) + (24 \24DISPLAYIMAGEOPS) + (SHOULDNT))) + (SCREEN \XDISPLAYIMAGEOPS))) + (freplace (\DISPLAYDATA DDDestination) of DD + with DESTINATION) + (CL:TYPECASE DESTINATION + (BITMAP (\SFFixDestination DD DISPLAYSTREAM)) + (SCREEN (* ; "do it by hand"))))])]) + +(DSPTEXTURE + [LAMBDA (TEXTURE DISPLAYSTREAM) (* ; "Edited 15-Feb-94 16:50 by nilsson") + (DSPBACKCOLOR TEXTURE DISPLAYSTREAM]) + +(\DISPLAYSTREAMINCRXPOSITION [LAMBDA (N DD) (* rmk%: "23-AUG-83 14:12") (* ;; "increases the x position by N. This is used internally. Returns the new value.") (add (fetch DDXPOSITION of DD) N]) + +(\SFFixDestination [LAMBDA (DISPLAYDATA DISPLAYSTREAM) (* kbr%: "29-Jan-86 10:59") (* ;; "fixes up those parts of the bitblt array which are dependent upon the destination") (PROG ((PBT (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA)) (BM (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA))) (replace (PILOTBBT PBTDESTBPL) of PBT with (UNFOLD (ffetch (BITMAP BITMAPRASTERWIDTH ) of BM) BITSPERWORD)) (* ;  "line width information will be updated by \SFFixFont") (\SFFixClippingRegion DISPLAYDATA) (\INVALIDATEDISPLAYCACHE DISPLAYDATA) (\SFFixFont DISPLAYSTREAM DISPLAYDATA) (RETURN]) + +(\SFFixClippingRegion [LAMBDA (DISPLAYDATA) (* kbr%: "29-Jan-86 11:01") (* ;; "compute the top, bottom, left and right edges of the clipping region in destination coordinates to save computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the clipping region.") (PROG ((CLIPREG (ffetch (\DISPLAYDATA DDClippingRegion) of DISPLAYDATA)) (BM (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA))) [freplace (\DISPLAYDATA DDClippingRight) of DISPLAYDATA with (IMAX 0 (IMIN (\DSPTRANSFORMX (IPLUS (ffetch (REGION LEFT) of CLIPREG) (ffetch (REGION WIDTH) of CLIPREG) ) DISPLAYDATA) (ffetch (BITMAP BITMAPWIDTH) of BM] (freplace (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMX (ffetch (REGION LEFT) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER)) [freplace (\DISPLAYDATA DDClippingTop) of DISPLAYDATA with (IMAX 0 (IMIN (\DSPTRANSFORMY (IPLUS (ffetch (REGION BOTTOM) of CLIPREG ) (ffetch (REGION HEIGHT) of CLIPREG )) DISPLAYDATA) (ffetch (BITMAP BITMAPHEIGHT) of BM] (freplace (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMY (ffetch (REGION BOTTOM) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER]) + +(\SFFixFont [LAMBDA (DISPLAYSTREAM DISPLAYDATA) (* kbr%: "29-Jan-86 11:03") (* ;; "used to fix up those parts of the bitblt table which depend upon the FONT. DISPLAYDATA is the IMAGEDATA for DISPLAYSTREAM, for convenience.") [PROG [(PILOTBBT (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA)) (FONT (ffetch (\DISPLAYDATA DDFONT) of DISPLAYDATA)) (BITSPERPIXEL (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA] (freplace (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA with (OR (NOT (EQ BITSPERPIXEL 1)) (NOT (EQ (ffetch (FONTDESCRIPTOR ROTATION) of FONT) 0] (\INVALIDATEDISPLAYCACHE DISPLAYDATA) (\SFFIXLINELENGTH DISPLAYSTREAM]) + +(\SFFIXLINELENGTH [LAMBDA (DISPLAYSTREAM) (* ; "Edited 5-Jan-88 12:57 by sye") (* ;; "DISPLAYSTREAM is known to be a stream of type display. Called by RIGHTMARGIN LEFTMARGIN and \SFFIXFONT to update the LINELENGTH field in the stream. also called when the display stream is created.") (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) [freplace (STREAM LINELENGTH) of DISPLAYSTREAM with (IMIN MAX.SMALLP (IMAX 1 (IQUOTIENT (IDIFFERENCE (ffetch (\DISPLAYDATA DDRightMargin) of DD) (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) (fetch FONTAVGCHARWIDTH of (ffetch DDFONT of DD] (* ;; " make sure %%SYNONYM-STREAM-DEVICE was defined (during the LOADUP) before updating ") (* ;; " LINELENGTH fields of DISPLAYSTREAM's synonym streams") (AND (BOUNDP '%%SYNONYM-STREAM-DEVICE) (\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD DISPLAYSTREAM]) + +(\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD [LAMBDA (DISPLAYSTREAM) (* ; "Edited 19-Jan-88 15:48 by amd") (* ;; "copy the value of LINELENGTH field from DISPLAYSTREAM to its synonym streams and any indirect streams built on top of them.") (* ;; "NB: This loses if the indirection is more than one away.") (LET ((NEWLENGTH (ffetch (STREAM LINELENGTH) of DISPLAYSTREAM))) (CL:MAPC #'[LAMBDA (X) (if (AND (BOUNDP (FFETCH (STREAM F1) OF X)) (EQ (CL:SYMBOL-VALUE (FFETCH (STREAM F1) OF X)) DISPLAYSTREAM)) then (freplace (STREAM LINELENGTH) of X with NEWLENGTH) (CL:MAPC #'[LAMBDA (Y) (AND (EQ (ffetch (STREAM F2) of Y) X) (freplace (STREAM LINELENGTH) of Y with NEWLENGTH] (ffetch (FDEV OPENFILELST) of %%ECHO-STREAM-DEVICE)) (CL:MAPC #'[LAMBDA (Y) (AND (EQ (ffetch (STREAM F2) of Y) X) (freplace (STREAM LINELENGTH) of Y with NEWLENGTH] (ffetch (FDEV OPENFILELST) of %%TWO-WAY-STREAM-DEVICE] (ffetch (FDEV OPENFILELST) of %%SYNONYM-STREAM-DEVICE]) + +(\SFFixY [LAMBDA (DISPLAYDATA CSINFO) (* rmk%: " 4-Apr-85 13:50") (* ;; "makes that part of the bitblt table of a display stream which deals with the Y information consistent. This is called from \BLTCHAR whenever a character is being printed and the charset/y-position caches are invalid") (* ;  "assumes DISPLAYDATA has already been type checked.") (PROG ((PBT (ffetch DDPILOTBBT of DISPLAYDATA)) (Y (\DSPTRANSFORMY (ffetch DDYPOSITION of DISPLAYDATA) DISPLAYDATA)) TOP CHARTOP BM) [SETQ CHARTOP (IPLUS Y (freplace DDCHARSETASCENT of DISPLAYDATA with (ffetch CHARSETASCENT of CSINFO] [freplace PBTDEST of PBT with (\ADDBASE (fetch BITMAPBASE of (SETQ BM (ffetch DDDestination of DISPLAYDATA))) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (\SFInvert BM (SETQ TOP (IMAX (IMIN (ffetch DDClippingTop of DISPLAYDATA) CHARTOP) 0] [freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of (SETQ BM (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO))) (ITIMES (ffetch BITMAPRASTERWIDTH of BM) (freplace DDCHARHEIGHTDELTA of DISPLAYDATA with (IMIN (IMAX (IDIFFERENCE CHARTOP TOP) 0) MAX.SMALL.INTEGER] (freplace PBTHEIGHT of PBT with (IMAX (IDIFFERENCE TOP (IMAX (IDIFFERENCE Y (freplace DDCHARSETDESCENT of DISPLAYDATA with (ffetch CHARSETDESCENT of CSINFO))) (ffetch DDClippingBottom of DISPLAYDATA))) 0]) +) +(DEFINEQ + +(\MEDW.XOFFSET + [LAMBDA (XOFFSET DISPLAYSTREAM) (* ; "Edited 17-Apr-94 23:32 by sybalsky") + + (* ;; "Set the X OFFSET for a normal Medley window/display styream.") + + (* ;; "coordinate position is stored in 15 bits in the range -2^15 to +2^15.") + + (COND + [DISPLAYSTREAM (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) + (RETURN (PROG1 (fetch DDXOFFSET of DD) + (COND + ((NULL XOFFSET)) + ((NUMBERP XOFFSET) + (UNINTERRUPTABLY + (freplace DDXOFFSET of DD with XOFFSET) + (\SFFixClippingRegion DD))) + (T (\ILLEGAL.ARG XOFFSET))))] + (T (* ; + "check done specially for NIL so that it won't default to primary output file.") + (\ILLEGAL.ARG DISPLAYSTREAM]) + +(\MEDW.YOFFSET + [LAMBDA (YOFFSET DISPLAYSTREAM) (* rmk%: " 4-Apr-85 13:43") + (COND + [DISPLAYSTREAM (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) + (RETURN (PROG1 (ffetch DDYOFFSET of DD) + (COND + ((NULL YOFFSET)) + ((NUMBERP YOFFSET) + (UNINTERRUPTABLY + (freplace DDYOFFSET of DD with YOFFSET) + (\SFFixClippingRegion DD) + (\INVALIDATEDISPLAYCACHE DD))) + (T (\ILLEGAL.ARG YOFFSET))))] + (T (* ; + "check done specially for NIL so that it won't default to primary output file.") + (\ILLEGAL.ARG DISPLAYSTREAM]) +) +(DEFINEQ + +(\DSPCLIPPINGREGION.DISPLAY [LAMBDA (DISPLAYSTREAM REGION) (* rmk%: " 4-Apr-85 13:44") (* ;; "sets the clipping region of a display stream.") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDClippingRegion of DD) [COND (REGION (OR (type? REGION REGION) (ERROR REGION " is not a REGION.")) (UNINTERRUPTABLY (freplace DDClippingRegion of DD with REGION) (\SFFixClippingRegion DD) (\INVALIDATEDISPLAYCACHE DD))])]) + +(\DSPFONT.DISPLAY [LAMBDA (DISPLAYSTREAM FONT) (* ; "Edited 11-Nov-87 15:36 by FS") (* ;; "sets the font that a display stream uses to print characters. DISPLAYSTREAM is guaranteed to be a stream of type display") (PROG (XFONT OLDFONT DD) (SETQ DD (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (* ;  "save old value to return, smash new value and update the bitchar portion of the record.") (RETURN (PROG1 (SETQ OLDFONT (fetch (\DISPLAYDATA DDFONT) of DD)) [COND (FONT (* ;; "Either FONT is coerceable to a font, or its a proplist of ways to change the current font (see IRM), otherwise an error.") (SETQ XFONT (OR (\COERCEFONTDESC FONT DISPLAYSTREAM T) (FONTCOPY (ffetch (\DISPLAYDATA DDFONT) of DD) (CONS 'NOERROR (CONS T FONT))) (ERROR "FONT NOT FOUND OR ILLEGAL FONTCOPY PARAMETER") )) (* ;  "updating font information is fairly expensive operation. Don't bother unless font has changed.") (OR (EQ XFONT OLDFONT) (UNINTERRUPTABLY (freplace (\DISPLAYDATA DDFONT) of DD with XFONT) (freplace (\DISPLAYDATA DDLINEFEED) of DD with (IMINUS (fetch (FONTDESCRIPTOR \SFHeight) of XFONT))) (* ;  "This will be difference when spacefactor is implemented for the display. ") (freplace (\DISPLAYDATA DDSPACEWIDTH) of DD with (\FGETCHARWIDTH XFONT (CHARCODE SPACE))) (\SFFixFont DISPLAYSTREAM DD))])]) + +(\DISPLAY.PILOTBITBLT [LAMBDA (PILOTBBT N) (* kbr%: "13-Jun-85 16:06") (\PILOTBITBLT PILOTBBT N]) + +(\DSPLINEFEED.DISPLAY [LAMBDA (DISPLAYSTREAM DELTAY) (* rmk%: " 2-SEP-83 10:56") (* ;; "sets the amount that a line feed increases the y coordinate by.") (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDLINEFEED of DD) [AND DELTAY (COND ((NUMBERP DELTAY) (freplace DDLINEFEED of DD with DELTAY)) (T (\ILLEGAL.ARG DELTAY])]) + +(\DSPLEFTMARGIN.DISPLAY [LAMBDA (DISPLAYSTREAM XPOSITION) (* rrb " 3-Oct-85 09:28") (* ;; "sets the xposition that a carriage return returns to.") (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDLeftMargin of DD) [AND XPOSITION (COND ((NUMBERP XPOSITION) (UNINTERRUPTABLY (freplace DDLeftMargin of DD with XPOSITION) (\SFFIXLINELENGTH DISPLAYSTREAM))) (T (\ILLEGAL.ARG XPOSITION])]) + +(\DSPOPERATION.DISPLAY [LAMBDA (DISPLAYSTREAM OPERATION) (* rmk%: "12-Sep-84 09:56") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (fetch DDOPERATION of DD) [COND (OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) (LISPERROR "ILLEGAL ARG" OPERATION)) (UNINTERRUPTABLY (freplace DDOPERATION of DD with OPERATION) (* ;  "update other fields that depend on operation.") (\SETPBTFUNCTION (fetch DDPILOTBBT of DD) (fetch DDSOURCETYPE of DD) OPERATION))])]) + +(\DSPRIGHTMARGIN.DISPLAY [LAMBDA (DISPLAYSTREAM XPOSITION) (* rrb " 3-Oct-85 09:29") (* ;; "Sets the right margin that determines when a cr is inserted by print.") (PROG (OLDRM (DD (fetch IMAGEDATA of DISPLAYSTREAM))) (SETQ OLDRM (ffetch DDRightMargin of DD)) (COND ((NULL XPOSITION)) [(NUMBERP XPOSITION) (* ;  "Avoid fixing linelength if right margin hasn't changed.") (OR (EQUAL XPOSITION OLDRM) (UNINTERRUPTABLY (freplace DDRightMargin of DD with XPOSITION) (\SFFIXLINELENGTH DISPLAYSTREAM))] (T (\ILLEGAL.ARG XPOSITION))) (RETURN OLDRM]) + +(\DSPXPOSITION.DISPLAY [LAMBDA (DISPLAYSTREAM XPOSITION) (* rmk%: " 2-SEP-83 10:56") (* ;; "coordinate position is stored in 15 bits in the range -2^15 to +2^15.") (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) (RETURN (PROG1 (fetch DDXPOSITION of DD) (COND ((NULL XPOSITION)) ((NUMBERP XPOSITION) (freplace DDXPOSITION of DD with XPOSITION) (* ;  "reset the charposition field so that PRINT etc. won't put out eols.") (freplace (STREAM CHARPOSITION) of DISPLAYSTREAM with 0)) (T (\ILLEGAL.ARG XPOSITION))))]) + +(\DSPYPOSITION.DISPLAY [LAMBDA (DISPLAYSTREAM YPOSITION) (* rmk%: " 4-Apr-85 13:45") (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDYPOSITION of DD) (COND ((NULL YPOSITION)) ((NUMBERP YPOSITION) (UNINTERRUPTABLY (freplace DDYPOSITION of DD with YPOSITION) (\INVALIDATEDISPLAYCACHE DD))) (T (\ILLEGAL.ARG YPOSITION))))]) +) + +(MOVD? '\ILLEGAL.ARG '\COERCETODS) + +(MOVD? 'NILL 'WFROMDS) + +(MOVD? 'NILL 'WINDOWP) + +(MOVD? 'NILL 'INVERTW) + +(RPAQ? PROMPTWINDOW T) + +(RPAQ? \WINDOWWORLD NIL) + +(RPAQ? \MAINSCREEN NIL) + + + +(* ; "Stub for window package") + + +(RPAQ? \TOPWDS ) + +(RPAQ? \SCREENBITMAPS ) + +(MOVD? 'NILL '\TOTOPWDS) +(DECLARE%: DONTCOPY EVAL@COMPILE +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[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) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "DisplayStream TTY functions") + +(DEFINEQ + +(TTYDISPLAYSTREAM [LAMBDA (DISPLAYSTREAM) (* ; "Edited 19-Jan-88 11:45 by jds") (* ;; "Makes DISPLAYSTREAM be the ttydisplaystream, and return the old value. Only change it if DISPLAYSTREAM is non-NIL.") (DECLARE (GLOBALVARS \DEFAULTTTYDISPLAYSTREAM)) (PROG1 \TERM.OFD (* ; "Return the pre-existing value") [COND (DISPLAYSTREAM (* ;; "Only try setting it if he really passed in a new value.") (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM)) (OR (DISPLAYSTREAMP DISPLAYSTREAM) (AND (GETD 'TEXTSTREAMP) (TEXTSTREAMP DISPLAYSTREAM)) (\ILLEGAL.ARG DISPLAYSTREAM)) (* ; "Better be a display stream!") (UNINTERRUPTABLY (* ;; "make sure there's something to do") (COND ((NEQ DISPLAYSTREAM \TERM.OFD) (* ;; "First remove the old ttydisplaystream (if any)") [COND ((AND \TERM.OFD (NEQ \TERM.OFD \DEFAULTTTYDISPLAYSTREAM)) (* ;; "make sure caret is off before changing display streams.") (\CHECKCARET) (LET ((WIN (WFROMDS \TERM.OFD T))) (AND WIN (WINDOWPROP WIN '\LINEBUF.OFD \LINEBUF.OFD] (* ;; "Now install the new ttydisplaystream.") (* ;;  "if old T was the primary output, change it to the new ttydisplaystream.") (COND ((EQ *STANDARD-OUTPUT* \TERM.OFD) (SETQ *STANDARD-OUTPUT* DISPLAYSTREAM))) (SETQ \TERM.OFD DISPLAYSTREAM) (* ;;  "save and restore line buffer from the displaystream window if any.") (COND ([EQ *STANDARD-INPUT* (PROG1 \LINEBUF.OFD [PROG (WIN) (SETQ WIN (WFROMDS DISPLAYSTREAM T)) (SETQ \LINEBUF.OFD (OR [COND (WIN (WINDOWPROP WIN 'PROCESS (THIS.PROCESS)) (* ;  "For the PROC world to worry about tty moving") (WINDOWPROP WIN '\LINEBUF.OFD] (\CREATELINEBUFFER])] (* ;  "primary input is line buffer, switch it too.") (SETQ *STANDARD-INPUT* \LINEBUF.OFD))) (SETQ TtyDisplayStream DISPLAYSTREAM) (* ;  "just in case, for backward compatibility") )) (* ;  "change scroll mode of tty stream to scroll.") [COND ((FMEMB (IMAGESTREAMTYPE DISPLAYSTREAM) \DISPLAYSTREAMTYPES) (DSPSCROLL 'ON DISPLAYSTREAM) (* ; "Reset page characteristics.") (PROG (DD) (SETQ DD (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (PAGEHEIGHT (IQUOTIENT (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop) of DD) (fetch (\DISPLAYDATA DDClippingBottom) of DD)) (IABS (fetch (\DISPLAYDATA DDLINEFEED) of DD])])]) +) +(* "FOLLOWING DEFINITIONS EXPORTED") +(DEFOPTIMIZER TTYDISPLAYSTREAM (&REST X) + (COND + ((NULL (CAR X)) + '\TERM.OFD) + (T 'IGNOREMACRO))) + +(* "END EXPORTED DEFINITIONS") + +(DEFINEQ + +(DSPSCROLL [LAMBDA (SWITCHSETTING DISPLAYSTREAM) (* rmk%: "23-AUG-83 13:02") (* ;; "sets the SCROLL characteristics of the font in a display stream. If SWITCHSETTING in ON, when bottom of screen is reached, contents will be blted DSPLineFeed bits.") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (OR (ffetch DDScroll of DD) 'OFF) [AND SWITCHSETTING (freplace DDScroll of DD with (NEQ SWITCHSETTING 'OFF])]) + +(PAGEHEIGHT [LAMBDA (N) (* rrb "23-JUL-83 15:08") (* ;; "sets the page height in lines of the screen.") (PROG1 \#DISPLAYLINES (COND ((NUMBERP N) (SETQ \#DISPLAYLINES N) (SETQ \CURRENTDISPLAYLINE 0))))]) +) + +(RPAQ? \CURRENTTTYDEVICE 'BCPLDISPLAY) +(DEFINEQ + +(\DSPRESET.DISPLAY + [LAMBDA (DISPLAYSTREAM) (* ; "Edited 8-Dec-93 18:09 by nilsson") + (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* ; "resets a display stream") + (LET (CREG FONT FONTASCENT (DD (\DTEST (fetch (STREAM IMAGEDATA) of (SETQ DISPLAYSTREAM + (\OUTSTREAMARG + DISPLAYSTREAM))) + '\DISPLAYDATA)) + (WINDOW (WFROMDS DISPLAYSTREAM T))) + (WXOFFSET (WXOFFSET NIL WINDOW) + WINDOW) + (WYOFFSET (WYOFFSET NIL WINDOW) + WINDOW) + (SETQ CREG (ffetch (\DISPLAYDATA DDClippingRegion) of DD)) + (SETQ FONT (fetch (\DISPLAYDATA DDFONT) of DD)) + (SETQ FONTASCENT (FONTASCENT FONT)) + (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT) + (0 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (ffetch (\DISPLAYDATA DDLeftMargin) + of DD)) + (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (ADD1 (IDIFFERENCE (fetch (REGION TOP) + of CREG) + FONTASCENT)))) + (90 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (IPLUS (fetch (REGION LEFT) + of CREG) + FONTASCENT)) + (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (fetch (REGION BOTTOM) of CREG))) + (270 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE (fetch (REGION RIGHT) + of CREG) + FONTASCENT)) + (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (fetch (REGION TOP) of CREG))) + (ERROR "only supported rotations are 0, 90 and 270")) + (BITBLT NIL NIL NIL DISPLAYSTREAM (fetch (REGION LEFT) of CREG) + (fetch (REGION BOTTOM) of CREG) + (fetch (REGION WIDTH) of CREG) + (fetch (REGION HEIGHT) of CREG) + 'TEXTURE + 'REPLACE + (ffetch (\DISPLAYDATA DDTexture) of DD)) + + (* ;; "if this display stream is the tty display stream of a process, reset the # of lines in that process.") + + (PROG ((X (WFROMDS DISPLAYSTREAM T))) + (COND + ((AND X (SETQ X (WINDOWPROP X 'PROCESS)) + (EQ (PROCESS.TTY X) + DISPLAYSTREAM)) + (PROCESS.EVAL X '(SETQ \CURRENTDISPLAYLINE 0]) +) + +(RPAQ? *DRIBBLE-OUTPUT* NIL) + +(DEFMACRO \MAYBE-DRIBBLE-CHAR (DISPLAY-STREAM CHARCODE) + "if we are dribbling, then dribble this character" + + (* ;; "*DRIBBLE-OUTPUT* is a per-process special.") + + (* ;; "Only dribble if *DRIBBLE-OUTPUT* is not NIL, and IS a stream; the NIL check is for speed, since the STREAMP is something like 30 of the time spent printing to the exec window!!") + + `(AND *DRIBBLE-OUTPUT* (STREAMP *DRIBBLE-OUTPUT*) + (EQ ,DISPLAY-STREAM (TTYDISPLAYSTREAM)) + (\OUTCHAR *DRIBBLE-OUTPUT* ,CHARCODE))) +(DEFINEQ + +(\DSPPRINTCHAR [LAMBDA (STREAM CHARCODE) (* ; "Edited 10-May-88 23:40 by MASINTER") (* ;; "Displays a character on a display stream. Handles dribbling, too.") (PROG ((DD (ffetch (STREAM IMAGEDATA) of STREAM))) (\CHECKCARET STREAM) (\MAYBE-DRIBBLE-CHAR STREAM CHARCODE) (* ; "if dribbling, dribble.") (SELECTC (ffetch (TERMCODE CCECHO) of (\SYNCODE \PRIMTERMSA CHARCODE)) (REAL.CCE (* ;; "All fat characters are defined as REAL according to \SYNCODE, so we don't have worry about any of the special cases") [COND ((IGREATERP CHARCODE (CONSTANT (IMAX (CHARCODE EOL) (CHARCODE CR) (CHARCODE LF) ERASECHARCODE))) (* ;  "This is for sure a printing character; take the fast way out.") (\BLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (T (* ; "Take the slow check.") (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) (\DSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A) STREAM) STREAM) (* ;  "line buffering routines have already taken care of backing up the position") 0) (PROGN (\BLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1]) (INDICATE.CCE (* ;  "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.") (PROG (STR) (SETQ STR (\INDICATESTRING CHARCODE)) (* ; "This isn't right for rotated fonts. But then there should probably be a separate rotated outcharfn") [COND ((IGREATERP (\STRINGWIDTH.DISPLAY STREAM STR) (IDIFFERENCE (ffetch (\DISPLAYDATA DDRightMargin) of DD) (ffetch (\DISPLAYDATA DDXPOSITION) of DD))) (\DSPPRINTCR/LF (CHARCODE EOL) STREAM) (freplace (STREAM CHARPOSITION) of STREAM with (NCHARS STR))) (T (add (ffetch (STREAM CHARPOSITION) of STREAM) (NCHARS STR] (for I from 1 do (\BLTCHAR (OR (NTHCHARCODE STR I) (RETURN)) STREAM DD)))) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF) (\DSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ESCAPE (\BLTCHAR (CHARCODE $) STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (BELL (* ;  "make switching of bits uninterruptable but allow interrupts between flashes.") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK \MAIKO) [PLAYTUNE '((880 . 2500]) (FLASHWINDOW (WFROMDS STREAM)))) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (COND ((IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) TABWIDTH))) DD) (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ;  "tab was past rightmargin, force cr.") (\DSPPRINTCR/LF (CHARCODE EOL) STREAM))) (* ;  "return the number of spaces taken.") (add (ffetch (STREAM CHARPOSITION) of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (PROGN (* ;  "this case was copied from \DSCCOUT.") (\BLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT]) + +(\DSPPRINTCR/LF [LAMBDA (CHARCODE DISPLAY-STREAM) (* ; "Edited 16-Jan-87 17:14 by hdj") (* ;;  "CHARCODE is EOL, CR, or LF. Assumes that DISPLAY-STREAM has been type-checked by \DSPPRINTCHAR.") (* ;; "[Changed to call DSPXPOSITION and DSPYPOSITION instead of \DSPxPOSITION.DISPLAY so that it could be used in the hardcopy display stream case as well. Could go back to other method if efficiency becomes an issue.]") (COND ((EQ DISPLAY-STREAM (TTYDISPLAYSTREAM)) (\STOPSCROLL?) (* ;  "\STOPSCROLL may have turned on the caret.") (\CHECKCARET DISPLAY-STREAM))) (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch (STREAM IMAGEDATA) of DISPLAY-STREAM)) ) (COND ((AND (fetch (\DISPLAYDATA DDSlowPrintingCase) of DD) (NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch (\DISPLAYDATA DDFONT) of DD))) 0)) (PROG ((CLIPREG (ffetch (\DISPLAYDATA DDClippingRegion) of DD)) X) (COND ((EQ CHARCODE (CHARCODE EOL)) (* ; "on LF, no change in X") (COND ((SETQ Y (fetch (\DISPLAYDATA DDEOLFN) of DD)) (* ; "call the eol function for ds.") (APPLY* Y DISPLAY-STREAM))) (DSPYPOSITION (SELECTQ ROTATION (90 (fetch (REGION BOTTOM) of CLIPREG)) (270 (fetch (REGION TOP) of CLIPREG)) (ERROR "Only rotations supported are 0, 90 and 270")) DISPLAY-STREAM))) [SETQ X (IPLUS (fetch (\DISPLAYDATA DDXPOSITION) of DD) (SELECTQ ROTATION (90 (IMINUS (ffetch (\DISPLAYDATA DDLINEFEED) of DD))) (270 (ffetch (\DISPLAYDATA DDLINEFEED) of DD)) (ERROR "Only rotations supported are 0, 90 and 270"] [COND ((AND (fetch (\DISPLAYDATA DDScroll) of DD) (SELECTQ ROTATION (90 (IGREATERP [SETQ AMOUNT/BELOW (IDIFFERENCE (\DSPTRANSFORMX X DD) (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight ) of DD) (fetch (FONTDESCRIPTOR \SFDescent) of (fetch (\DISPLAYDATA DDFONT) of DD] 0)) (270 (IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (fetch (\DISPLAYDATA DDClippingLeft ) of DD) (fetch (FONTDESCRIPTOR \SFDescent) of (fetch (\DISPLAYDATA DDFONT ) of DD))) (\DSPTRANSFORMX X DD))) 0)) (SHOULDNT))) (* ;; "automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of characters will be printed also.") [PROG (LFT WDTH BKGRND DBITMAP HGHT KEPTWIDTH) (SETQ LFT (fetch (\DISPLAYDATA DDClippingLeft) of DD)) (SETQ DBITMAP (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ BTM (fetch (\DISPLAYDATA DDClippingBottom) of DD)) (SETQ HGHT (IDIFFERENCE (ffetch (\DISPLAYDATA DDClippingTop) of DD) BTM)) (SETQ WDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of DD) LFT)) (SETQ BKGRND (ffetch (\DISPLAYDATA DDTexture) of DD)) (.WHILE.TOP.DS. DISPLAY-STREAM (COND ((IGREATERP AMOUNT/BELOW WDTH) (* ;  "scrolling more than the window size, use different method.") (* ;  "clear the window with background.") (BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT 'TEXTURE 'REPLACE BKGRND)) ((EQ ROTATION 90) (BITBLT DBITMAP (IPLUS LFT AMOUNT/BELOW) BTM DBITMAP LFT BTM (SETQ KEPTWIDTH (IDIFFERENCE WDTH AMOUNT/BELOW)) HGHT 'INPUT 'REPLACE) (BITBLT NIL 0 0 DBITMAP (IPLUS LFT KEPTWIDTH) BTM AMOUNT/BELOW HGHT 'TEXTURE 'REPLACE BKGRND)) (T (BITBLT DBITMAP LFT BTM DBITMAP (IPLUS LFT AMOUNT/BELOW) BTM (IDIFFERENCE WDTH AMOUNT/BELOW) HGHT 'INPUT 'REPLACE) (BITBLT NIL 0 0 DBITMAP LFT BTM AMOUNT/BELOW HGHT 'TEXTURE 'REPLACE BKGRND] (SETQ X (SELECTQ ROTATION (90 (IDIFFERENCE X AMOUNT/BELOW)) (IPLUS X AMOUNT/BELOW] (DSPXPOSITION X DISPLAY-STREAM))) (T (COND ((EQ CHARCODE (CHARCODE EOL)) (* ; "on LF, no change in X") (COND ((SETQ Y (fetch (\DISPLAYDATA DDEOLFN) of DD)) (* ; "call the eol function for ds.") (APPLY* Y DISPLAY-STREAM))) (DSPXPOSITION (ffetch (\DISPLAYDATA DDLeftMargin) of DD) DISPLAY-STREAM))) (SETQ Y (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (ffetch (\DISPLAYDATA DDLINEFEED) of DD))) [COND ((AND (fetch (\DISPLAYDATA DDScroll) of DD) (IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM (fetch (\DISPLAYDATA DDClippingBottom ) of DD)) (fetch (FONTDESCRIPTOR \SFDescent) of (fetch ( \DISPLAYDATA DDFONT) of DD))) (\DSPTRANSFORMY Y DD))) 0)) (* ;; "automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of characters will be printed also.") [PROG (LFT WDTH BKGRND DBITMAP HGHT) (SETQ LFT (fetch (\DISPLAYDATA DDClippingLeft) of DD)) (SETQ DBITMAP (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ HGHT (IDIFFERENCE (ffetch (\DISPLAYDATA DDClippingTop) of DD) BTM)) (SETQ WDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of DD) LFT)) (SETQ BKGRND (ffetch (\DISPLAYDATA DDTexture) of DD)) (.WHILE.TOP.DS. DISPLAY-STREAM (COND ((IGREATERP AMOUNT/BELOW HGHT) (* ;  "scrolling more than the window size, use different method.") (* ;  "clear the window with background.") (BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT 'TEXTURE 'REPLACE BKGRND)) (T (BITBLT DBITMAP LFT BTM DBITMAP LFT (IPLUS BTM AMOUNT/BELOW) WDTH (IDIFFERENCE HGHT AMOUNT/BELOW) 'INPUT 'REPLACE) (BITBLT NIL 0 0 DBITMAP LFT BTM WDTH AMOUNT/BELOW 'TEXTURE 'REPLACE BKGRND] (SETQ Y (IPLUS Y AMOUNT/BELOW] (DSPYPOSITION Y DISPLAY-STREAM]) +) +(DEFINEQ + +(\TTYBACKGROUND [LAMBDA NIL (* lmm "30-Dec-85 20:22") (* ;; "called each time through a tty keyboard wait loop. First executes the TTYBACKGROUNDFNS which do things like flashing the caret (and SAVEVM) and then allows other background things to run (including other processes.)") [COND ((EQ (fetch KEYBOARDSTREAM of \LINEBUF.OFD) \KEYBOARD.STREAM) (OR (TTY.PROCESSP) (WAIT.FOR.TTY)) (for X in TTYBACKGROUNDFNS do (APPLY* X] (\BACKGROUND]) +) +(DEFINEQ + +(DSPBACKUP [LAMBDA (WIDTH DISPLAYSTREAM) (* "Pavel" "25-Apr-86 16:37") (COND [[OR (DISPLAYSTREAMP DISPLAYSTREAM) (DISPLAYSTREAMP (SETQ DISPLAYSTREAM (GETSTREAM DISPLAYSTREAM 'OUTPUT] (PROG (FONT ROTATION BLTWIDTH XPOS (DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM))) [SETQ BLTWIDTH (IMIN WIDTH (IDIFFERENCE (SETQ XPOS (fetch DDXPOSITION of DD)) (ffetch DDLeftMargin of DD] (SETQ FONT (fetch DDFONT of DD)) (SETQ ROTATION (COND ((fetch DDSlowPrintingCase of DD) (fetch (FONTDESCRIPTOR ROTATION) of FONT)) (T 0))) (RETURN (COND ((IGREATERP BLTWIDTH 0) (\CHECKCARET DISPLAYSTREAM) [COND ((EQ ROTATION 0) (* ;  "uses DSPXPOSITION so that it works on both display streams and hardcopy display streams.") (DSPXPOSITION (IDIFFERENCE XPOS BLTWIDTH) DISPLAYSTREAM) (BITBLT NIL 0 0 DISPLAYSTREAM (fetch DDXPOSITION of DD) (IDIFFERENCE (ffetch DDYPOSITION of DD) (FONTDESCENT FONT)) BLTWIDTH (FONTHEIGHT FONT) 'TEXTURE 'REPLACE)) ((EQ ROTATION 90) (BITBLT NIL 0 0 DISPLAYSTREAM (IDIFFERENCE (fetch DDXPOSITION of DD) (FONTASCENT FONT)) (add (fetch DDYPOSITION of DD) (IMINUS BLTWIDTH)) (FONTHEIGHT FONT) BLTWIDTH 'TEXTURE 'REPLACE)) ((EQ ROTATION 270) (BITBLT NIL 0 0 DISPLAYSTREAM (IDIFFERENCE (fetch DDXPOSITION of DD) (FONTDESCENT FONT)) (add (fetch DDYPOSITION of DD) BLTWIDTH) (FONTHEIGHT FONT) BLTWIDTH 'TEXTURE 'REPLACE] T] (T (FRPTQ WIDTH (PROGN (BOUT DISPLAYSTREAM (CHARCODE BS)) (BOUT DISPLAYSTREAM (CHARCODE SPACE)) (BOUT DISPLAYSTREAM (CHARCODE BS]) +) + +(RPAQ? \CARET.UP ) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQQ BELLCNT 2) + +(RPAQQ BELLRATE 60) + +(RPAQQ \DisplayStoppedForLogout NIL) + +(RPAQQ TtyDisplayStream NIL) +) +(DEFINEQ + +(COLORDISPLAYP [LAMBDA NIL (* gbn%: "26-Jan-86 16:16") (* ; "is the color display on?") (NOT (NULL ColorScreenBitMap]) +) +(DEFINEQ + +(DISPLAYBEFOREEXIT + [LAMBDA (EXITFN) (* ; "Edited 16-Nov-93 16:22 by nilsson") + (COND + ((DISPLAYSTARTEDP) + + (* ;; "save cursor and background border so that they can be restored by DISPLAYAFTERENTRY when this sysout is restarted.") + + (SETQ \DisplayStoppedForLogout (CONS (CURSOR) + (CHANGEBACKGROUNDBORDER))) + (SELECTQ EXITFN + (LOGOUT (* ; "Shut off display during logout") + (SHOWDISPLAY)) + (MAKESYS (* ; "on MAKESYS, clear screen") + (DSPRESET (TTYDISPLAYSTREAM)) + (CLRPROMPT)) + (SYSOUT NIL) + (SHOULDNT]) + +(DISPLAYAFTERENTRY [LAMBDA (ENTRYFN) (* ; "Edited 29-Jun-88 14:57 by drc:") (* ;; "set address of Cursor bitmap every time because it changes from machine to machine and StartDisplay is a convenient place to reset it.") (replace BITMAPBASE of CursorBitMap with \EM.CURSORBITMAP) (COND (\DisplayStoppedForLogout (\STARTDISPLAY) (VIDEOCOLOR \VideoColor) (* ; "restore videocolor") (* ; "restore the cursor.") (CURSOR (CAR \DisplayStoppedForLogout)) (* ;  "restore the display border. Only does anything on a DANDELION") (CHANGEBACKGROUNDBORDER (CDR \DisplayStoppedForLogout)) (SETQ \DisplayStoppedForLogout NIL))) (* ;  "reset the time that the caret will flash.") (COND ((GETD 'CARETRATE) (* ;; "the caret rate has some global state which depends on the machine dependent clock. This resets the internal state") (CARETRATE (CARETRATE]) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS \DisplayStoppedForLogout \CARET.UP) +) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \CHECKCARET MACRO ((X) + (AND \CARET.UP (\CARET.DOWN X] +) + +(* "END EXPORTED DEFINITIONS") + + + + +(* ; "transformation related functions.") + +(DEFINEQ + +(\DSPCLIPTRANSFORMX [LAMBDA (X DD) (* rmk%: "23-AUG-83 15:03") (* ;; "returns the transformed coordinate value of X in the system of the destination. It also clips according to the clipping region and returns NIL if it falls outside.") (PROG ((TX (\DSPTRANSFORMX X DD))) (RETURN (AND (NOT (IGREATERP (fetch DDClippingLeft of DD) TX)) (IGREATERP (fetch DDClippingRight of DD) TX) TX]) + +(\DSPCLIPTRANSFORMY [LAMBDA (Y DD) (* rmk%: "23-AUG-83 15:09") (* ;; "returns the transformed coordinate value of Y in the system of the destination. It also clips according to the clipping region and returns NIL if it falls outside.") (PROG ((TY (\DSPTRANSFORMY Y DD))) (* ;  "ClippingTop points past the top edge.") (RETURN (AND (NOT (IGREATERP (fetch DDClippingBottom of DD) TY)) (IGREATERP (fetch DDClippingTop of DD) TY) TY]) + +(\DSPTRANSFORMREGION [LAMBDA (REGION DS) (* rrb " 3-DEC-80 18:11") (* ;; "transforms a region into the destination coordinates of the display stream.") (create REGION LEFT _ (\DSPTRANSFORMX (fetch LEFT of REGION) DS) BOTTOM _ (\DSPTRANSFORMY (fetch BOTTOM of REGION) DS) WIDTH _ (fetch WIDTH of REGION) HEIGHT _ (fetch HEIGHT of REGION]) + +(\DSPUNTRANSFORMY [LAMBDA (Y DD) (* rmk%: "23-AUG-83 14:34") (* ;; "transforms a y coordinate from destination coords into the display streams") (IDIFFERENCE Y (fetch DDYOFFSET of DD]) + +(\DSPUNTRANSFORMX [LAMBDA (X DD) (* rmk%: "23-AUG-83 14:25") (* ;; "transforms a x coordinate from destination coords into the display streams") (IDIFFERENCE X (fetch DDXOFFSET of DD]) + +(\OFFSETCLIPPINGREGION [LAMBDA (DD OLDREGION) (* bvm%: "14-Feb-85 00:45") (* ;; "calculates the clipping region from the displaydata of a display stream in destination coordinates. if OLDREGION is given, it is reused.") (PROG ((CREG (fetch DDClippingRegion of DD))) (RETURN (COND (OLDREGION (replace LEFT of OLDREGION with (\DSPTRANSFORMX (fetch LEFT of CREG) DD)) (replace BOTTOM of OLDREGION with (\DSPTRANSFORMY (fetch BOTTOM of CREG) DD)) (replace WIDTH of OLDREGION with (fetch WIDTH of CREG)) (replace HEIGHT of OLDREGION with (fetch HEIGHT of CREG)) OLDREGION) ((AND (EQ (fetch DDXOFFSET of DD) 0) (EQ (fetch DDYOFFSET of DD) 0)) (* ;  "special case of no offset to avoid storage creation.") CREG) (T (create REGION LEFT _ (\DSPTRANSFORMX (fetch LEFT of CREG) DD) BOTTOM _ (\DSPTRANSFORMY (fetch BOTTOM of CREG) DD) WIDTH _ (fetch WIDTH of CREG) HEIGHT _ (fetch HEIGHT of CREG]) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[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))) +) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "screen related functions") + +(DEFINEQ + +(UPDATESCREENDIMENSIONS [LAMBDA NIL (* ; "Edited 23-Apr-88 23:32 by MASINTER") (* ;;; "Sets SCREENWIDTH and SCREENHEIGHT according to machine") (SELECTC \MACHINETYPE ((LIST \DOLPHIN \DORADO \DANDELION) (SETQ SCREENWIDTH 1024) (SETQ SCREENHEIGHT 808)) (\DAYBREAK (SETQ SCREENWIDTH (\DoveDisplay.ScreenWidth)) (SETQ SCREENHEIGHT (\DoveDisplay.ScreenHeight))) (\MAIKO (SETQ SCREENWIDTH (SUBRCALL DSP-SCREENWIDTH)) (SETQ SCREENHEIGHT (SUBRCALL DSP-SCREENHEIGHT))) (SHOULDNT]) + +(\CreateScreenBitMap [LAMBDA (WIDTH HEIGHT) (* bvm%: "10-Aug-85 23:24") (DECLARE (GLOBALVARS \MaxScreenPage)) (* ;; "creates and locks the pages for the display bit map. Returns a BITMAP descriptor for it. Uses the first words of the segment \DISPLAYREGION.") (LET ((RASTERWIDTH (FOLDHI WIDTH BITSPERWORD)) MAXPAGE#) (* ;  "the display microcode needs to have the display fall on \DisplayWordAlign word boundaries.") (COND ((IGREATERP (SETQ MAXPAGE# (SUB1 (FOLDHI (ITIMES RASTERWIDTH HEIGHT) WORDSPERPAGE))) \MaxScreenPage) (* ;; "new screen size is larger, allocate more pages. All pages are locked. NOERROR is true in \NEWPAGE call in case pages are already there, e.g. DLBOOT allocated them.") (for I from (ADD1 \MaxScreenPage) to MAXPAGE# do (\NEWPAGE (\ADDBASE \DISPLAYREGION (UNFOLD I WORDSPERPAGE)) T T)) (SETQ \MaxScreenPage MAXPAGE#))) (COND ((BITMAPP ScreenBitMap) (* ;  "reuse the same BITMAP ptr so that it will stay EQ to the one in user datastructures.") (replace BITMAPBASE of ScreenBitMap with \DISPLAYREGION) (replace BITMAPWIDTH of ScreenBitMap with WIDTH) (replace BITMAPRASTERWIDTH of ScreenBitMap with RASTERWIDTH) (replace BITMAPHEIGHT of ScreenBitMap with HEIGHT) ScreenBitMap) (T (create BITMAP BITMAPBASE _ \DISPLAYREGION BITMAPRASTERWIDTH _ RASTERWIDTH BITMAPWIDTH _ WIDTH BITMAPHEIGHT _ HEIGHT]) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(UPDATESCREENDIMENSIONS) + + +(RPAQ? SCREENHEIGHT 808) + +(RPAQ? SCREENWIDTH 1024) + +(RPAQ? \OLDSCREENHEIGHT 808) + +(RPAQ? \OLDSCREENWIDTH 1024) + +(RPAQ? \MaxScreenPage -1) + +(RPAQ? ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT)) + +(RPAQ? ColorScreenBitMap NIL) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \OLDSCREENHEIGHT \OLDSCREENWIDTH \MaxScreenPage ScreenBitMap) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(CURSOR.INIT) +) + + + +(* ; "initialization") + + +(RPAQ? \DISPLAYINFOALIST ) +(DEFINEQ + +(\CoerceToDisplayDevice [LAMBDA (NameOrDevice) (* hdj " 8-Mar-85 10:29") (DECLARE (GLOBALVARS LastCreatedDisplayDevice)) (LET ((DEV (OR NameOrDevice LastCreatedDisplayDevice))) (COND ((type? FDEV DEV) DEV) (T (OR (\GETDEVICEFROMNAME DEV T T) (ERROR "No color drivers have been loaded"]) + +(\CREATEDISPLAY [LAMBDA (DISPLAYNAME) (* kbr%: " 1-Jul-85 15:23") (* ;;; "create a new display device. Mainly used by device-independent color code") (PROG (FDEV) [SETQ FDEV (create FDEV DEVICENAME _ DISPLAYNAME RESETABLE _ NIL RANDOMACCESSP _ NIL PAGEMAPPED _ NIL CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) NAME] READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) NAME] REOPENFILE _ [FUNCTION (LAMBDA (NAME) NAME] EVENTFN _ (FUNCTION NILL) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) BIN _ (FUNCTION \ILLEGAL.DEVICEOP) BOUT _ (FUNCTION \DSPPRINTCHAR) PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) DEVICEINFO _ (create DISPLAYSTATE ONOFF _ 'OFF] (\DEFINEDEVICE DISPLAYNAME FDEV) (RETURN FDEV]) + +(DISPLAYSTREAMINIT [LAMBDA (N) (* kbr%: "24-Feb-86 12:53") (DECLARE (GLOBALVARS \LastTTYLines \TopLevelTtyWindow)) (* ;; "starts display and sets N lines for tty at top") (\STARTDISPLAY) (SETQ TtyDisplayStream (DSPCREATE)) (PROG (TTYHEIGHT TTYFONTHEIGHT (TTYFONT (DSPFONT NIL TtyDisplayStream))) (SETQ TTYFONTHEIGHT (FONTHEIGHT TTYFONT)) (DSPDESTINATION ScreenBitMap TtyDisplayStream) (* ;; "this is done here so that processes that are created before window world is turned on have an acceptable binding for their tty.") (TERMINAL-OUTPUT (SETQ \TopLevelTtyWindow (SETQ \DEFAULTTTYDISPLAYSTREAM TtyDisplayStream)) ) (RETURN (PROG1 \LastTTYLines (SETQ TTYHEIGHT (ITIMES (COND [(NUMBERP N) (SETQ \LastTTYLines (COND ((IGREATERP (ITIMES N TTYFONTHEIGHT ) SCREENHEIGHT) (* ;  "too many lines, reduce to fit leaving two lines bottom margin.") (IDIFFERENCE (IQUOTIENT SCREENHEIGHT TTYFONTHEIGHT ) 2)) (T N] (T \LastTTYLines)) TTYFONTHEIGHT)) (* ; "put TTY region on top") (DSPYOFFSET (IDIFFERENCE SCREENHEIGHT TTYHEIGHT) TtyDisplayStream) (DSPYPOSITION (FONTDESCENT TTYFONT) TtyDisplayStream) (DSPXOFFSET 0 TtyDisplayStream) (DSPCLIPPINGREGION (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ SCREENWIDTH HEIGHT _ TTYHEIGHT) TtyDisplayStream) (* ;; "called after clipping region for TTYDISPLAYSTREAM has been set so that \#DISPLAYLINES will get set correctly.") (DSPRIGHTMARGIN SCREENWIDTH TtyDisplayStream))]) + +(\STARTDISPLAY [LAMBDA NIL (* kbr%: "19-Jan-86 14:52") (PROG (OLDWINDOWS) (UPDATESCREENDIMENSIONS) [COND ((AND (OR (NOT (EQ SCREENWIDTH \OLDSCREENWIDTH)) (NOT (EQ SCREENHEIGHT \OLDSCREENHEIGHT))) \WINDOWWORLD) (* ;; "Need to move windows around so that they remain on screen, and/or fix the display to account for new raster width") (SETQ OLDWINDOWS (REVERSE (OPENWINDOWS))) (* ; "Returns bottom window first") (COND ((OR (LESSP SCREENWIDTH \OLDSCREENWIDTH) (LESSP SCREENHEIGHT \OLDSCREENHEIGHT)) (* ; "Screen shrank, movement needed") (\MOVE.WINDOWS.ONTO.SCREEN OLDWINDOWS))) (* ;; "Finally, close the windows to save their images. Do this in separate pass from the moving, in case somebody's MOVEFN tried to do something with a window we had closed") (for W in OLDWINDOWS do (\CLOSEW1 W)) (COND ((AND NIL (NOT (EQ SCREENWIDTH \OLDSCREENWIDTH))) (\UPDATE.PBT.RASTERWIDTHS] (UNINTERRUPTABLY (SETQ ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT)) (SHOWDISPLAY (fetch (BITMAP BITMAPBASE) of ScreenBitMap) (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap)) (SETQ \DisplayStarted T)) (SETQ WHOLESCREEN (SETQ WHOLEDISPLAY (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ SCREENWIDTH HEIGHT _ SCREENHEIGHT))) (COND (\MAINSCREEN (replace (SCREEN SCDESTINATION) of \MAINSCREEN with ScreenBitMap) (replace (SCREEN SCWIDTH) of \MAINSCREEN with SCREENWIDTH) (replace (SCREEN SCHEIGHT) of \MAINSCREEN with SCREENHEIGHT))) (SETQ \CURSORDESTINATION ScreenBitMap) (SETQ \CURSORDESTWIDTH SCREENWIDTH) (SETQ \CURSORDESTHEIGHT SCREENHEIGHT) (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap)) [COND (OLDWINDOWS (* ;  "Now that we've created ScreenBitMap with the right raster width, put the windows back up") (CHANGEBACKGROUND WINDOWBACKGROUNDSHADE) (for W in (REVERSE OLDWINDOWS) do (\OPENW1 W] (SETQ \OLDSCREENHEIGHT SCREENHEIGHT) (SETQ \OLDSCREENWIDTH SCREENWIDTH]) + +(\MOVE.WINDOWS.ONTO.SCREEN [LAMBDA (WINDOWS) (* bvm%: "15-Aug-85 15:08") (COND ([for W in WINDOWS thereis (LET ((REG (fetch (WINDOW REG) of W))) (OR (GREATERP (fetch (REGION RIGHT) of REG) SCREENWIDTH) (GREATERP (fetch (REGION TOP) of REG) SCREENHEIGHT] (* ;  "Move all windows some if any are off screen") (LET (XFACTOR YFACTOR REG) (SETQ XFACTOR (FQUOTIENT SCREENWIDTH \OLDSCREENWIDTH)) (SETQ YFACTOR (FQUOTIENT SCREENHEIGHT \OLDSCREENHEIGHT)) (for W in WINDOWS unless (NEQ W (MAINWINDOW W)) do (* ;; "In the case of attached windows, move only the main one, so that attached windows are properly dragged along") (MOVEW (SETQ W (MAINWINDOW W T)) (IMAX 0 (IDIFFERENCE [FIXR (FTIMES XFACTOR (fetch (REGION RIGHT) of (SETQ REG (fetch (WINDOW REG) of W] (fetch (REGION WIDTH) of REG))) (IMAX 0 (IDIFFERENCE (FIXR (FTIMES YFACTOR (fetch (REGION TOP) of REG))) (fetch (REGION HEIGHT) of REG]) + +(\UPDATE.PBT.RASTERWIDTHS [LAMBDA NIL (* bvm%: "11-Aug-85 00:12") (* ;;; "Fix all the cached bitblt tables that think they know what the screen width is") (\MAPMDS 'PILOTBBT (FUNCTION (LAMBDA (PAGENO) (to (FOLDLO \MDSIncrement 16) bind (PBT _ (create POINTER PAGE# _ PAGENO)) do (* ;; "NOTE: We are depending on PILOTBBT structures being 16-word units, and that the first 32-bit field is NOT the one we are smashing. That's so we don't trash links in the free list. In fact, since PBTDESTLO and PBTDESTHI are in the first 32-bit field, we are actually guaranteed by the AND below not to touch any free PILOTBBT structures") (COND ((AND (EQ (fetch (PILOTBBT PBTDESTHI) of PBT) (FOLDLO \VP.DISPLAY PAGESPERSEGMENT)) (EQ (fetch (PILOTBBT PBTDESTLO) of PBT) 0)) (* ; "Destination is screen") (replace (PILOTBBT PBTDESTBPL) of PBT with SCREENWIDTH))) (SETQ PBT (\ADDBASE PBT 16]) + +(\STOPDISPLAY [LAMBDA NIL (* lmm " 7-Jan-86 17:59") (DECLARE (GLOBALVARS \MaxScreenPage)) (* ;; "Turn off Lisp display, go back to bcpl display. Exists only for emergency use") (UNINTERRUPTABLY (SHOWDISPLAY) (\UNLOCKPAGES (fetch BITMAPBASE of ScreenBitMap) (ADD1 \MaxScreenPage)) (SETQ \MaxScreenPage -1) (SETQ \DisplayStarted NIL)) (PAGEHEIGHT 58]) + +(\DEFINEDISPLAYINFO [LAMBDA (DISPLAYINFO) (* kbr%: " 1-Jul-85 17:39") (PROG (BUCKET) (SETQ BUCKET (ASSOC (CAR DISPLAYINFO) \DISPLAYINFOALIST)) (COND (BUCKET (DREMOVE BUCKET \DISPLAYINFOALIST))) (push \DISPLAYINFOALIST DISPLAYINFO]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(ADDTOVAR DONTCOMPILEFNS \UPDATE.PBT.RASTERWIDTHS) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* always initialized now) + T)) + +(PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted)) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed WHOLEDISPLAY WHOLESCREEN + SCREENWIDTH SCREENHEIGHT) +) + +(* "END EXPORTED DEFINITIONS") + + +(ADDTOVAR GLOBALVARS WHOLESCREEN) +(DEFINEQ + +(INITIALIZEDISPLAYSTREAMS [LAMBDA NIL (* lmm " 7-Jan-86 16:51") (SETQ WHOLEDISPLAY (create REGION)) (SETQ \SYSPILOTBBT (create PILOTBBT)) (* ; "For BITBLT") (SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* ;  "For texture handling in \BITBLTSUB") (* ;  "A guaranteed display font is initialized here after pup, font, and bitmap code has been loaded.") (SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE 'GACHA 10 NIL NIL 'DISPLAY)) (SETQ DEFAULTFONT (FONTCLASS 'DEFAULTFONT (LIST 1 \GUARANTEEDDISPLAYFONT]) +) +(DECLARE%: DOCOPY DONTEVAL@LOAD + +(RPAQQ \DisplayStarted NIL) + +(RPAQQ \LastTTYLines 12) + + +(INITIALIZEDISPLAYSTREAMS) + +(DISPLAYSTREAMINIT 1000) +) + +(PUTPROPS LLDISPLAY FILETYPE COMPILE-FILE) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) +(PUTPROPS LLDISPLAY COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 +1989 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (20593 23261 (\FBITMAPBIT 20603 . 21063) (\FBITMAPBIT.UFN 21065 . 22084) ( +\NEWPAGE.DISPLAY 22086 . 22221) (INITBITMASKS 22223 . 23259)) (25222 25731 (\CreateCursorBitMap 25232 + . 25729)) (25848 84908 (BITBLT 25858 . 36248) (BLTSHADE 36250 . 37028) (\BITBLTSUB 37030 . 47165) ( +\GETPILOTBBTSCRATCHBM 47167 . 47782) (BITMAPCOPY 47784 . 48360) (BITMAPCREATE 48362 . 49922) ( +BITMAPBIT 49924 . 58311) (BLTCHAR 58313 . 58929) (\BLTCHAR 58931 . 59433) (\MEDW.BLTCHAR 59435 . 64313 +) (\CHANGECHARSET.DISPLAY 64315 . 67273) (\INDICATESTRING 67275 . 68471) (\SLOWBLTCHAR 68473 . 75569) +(TEXTUREP 75571 . 75841) (INVERT.TEXTURE 75843 . 76117) (INVERT.TEXTURE.BITMAP 76119 . 77654) ( +BITMAPWIDTH 77656 . 78028) (READBITMAP 78030 . 80512) (\INSUREBITSPERPIXEL 80514 . 80809) ( +MAXIMUMCOLOR 80811 . 80952) (OPPOSITECOLOR 80954 . 81133) (MAXIMUMSHADE 81135 . 81346) (OPPOSITESHADE +81348 . 81527) (\MEDW.BITBLT 81529 . 84906)) (91458 91939 (BITMAPBIT.EXPANDER 91468 . 91937)) (91940 +140474 (\BITBLT.DISPLAY 91950 . 115189) (\BITBLT.BITMAP 115191 . 124290) (\BITBLT.MERGE 124292 . +126545) (\BLTSHADE.DISPLAY 126547 . 133647) (\BLTSHADE.BITMAP 133649 . 140472)) (140475 149795 ( +\BITBLT.BITMAP.SLOW 140485 . 149793)) (149796 166177 (\PUNT.BLTSHADE.BITMAP 149806 . 156902) ( +\PUNT.BITBLT.BITMAP 156904 . 166175)) (166178 169618 (\SCALEDBITBLT.DISPLAY 166188 . 167821) ( +\BACKCOLOR.DISPLAY 167823 . 169616)) (173493 175766 (DISPLAYSTREAMP 173503 . 174111) (DSPSOURCETYPE +174113 . 175122) (DSPXOFFSET 175124 . 175443) (DSPYOFFSET 175445 . 175764)) (175767 192014 (DSPCREATE +175777 . 177827) (DSPDESTINATION 177829 . 180932) (DSPTEXTURE 180934 . 181096) ( +\DISPLAYSTREAMINCRXPOSITION 181098 . 181385) (\SFFixDestination 181387 . 182565) (\SFFixClippingRegion + 182567 . 184739) (\SFFixFont 184741 . 185791) (\SFFIXLINELENGTH 185793 . 187289) ( +\UPDATE-SYNONYM-STREAM-LINELENGTH-FIELD 187291 . 189104) (\SFFixY 189106 . 192012)) (192015 194209 ( +\MEDW.XOFFSET 192025 . 193166) (\MEDW.YOFFSET 193168 . 194207)) (194210 202136 ( +\DSPCLIPPINGREGION.DISPLAY 194220 . 194966) (\DSPFONT.DISPLAY 194968 . 197338) (\DISPLAY.PILOTBITBLT +197340 . 197489) (\DSPLINEFEED.DISPLAY 197491 . 198062) (\DSPLEFTMARGIN.DISPLAY 198064 . 198795) ( +\DSPOPERATION.DISPLAY 198797 . 199821) (\DSPRIGHTMARGIN.DISPLAY 199823 . 200668) ( +\DSPXPOSITION.DISPLAY 200670 . 201527) (\DSPYPOSITION.DISPLAY 201529 . 202134)) (206297 211333 ( +TTYDISPLAYSTREAM 206307 . 211331)) (211652 212682 (DSPSCROLL 211662 . 212362) (PAGEHEIGHT 212364 . +212680)) (212727 215749 (\DSPRESET.DISPLAY 212737 . 215747)) (216309 236947 (\DSPPRINTCHAR 216319 . +224157) (\DSPPRINTCR/LF 224159 . 236945)) (236948 237540 (\TTYBACKGROUND 236958 . 237538)) (237541 +240828 (DSPBACKUP 237551 . 240826)) (241012 241268 (COLORDISPLAYP 241022 . 241266)) (241269 243340 ( +DISPLAYBEFOREEXIT 241279 . 242105) (DISPLAYAFTERENTRY 242107 . 243338)) (243701 248233 ( +\DSPCLIPTRANSFORMX 243711 . 244300) (\DSPCLIPTRANSFORMY 244302 . 245027) (\DSPTRANSFORMREGION 245029 + . 245561) (\DSPUNTRANSFORMY 245563 . 245823) (\DSPUNTRANSFORMX 245825 . 246085) ( +\OFFSETCLIPPINGREGION 246087 . 248231)) (249501 252088 (UPDATESCREENDIMENSIONS 249511 . 250140) ( +\CreateScreenBitMap 250142 . 252086)) (252647 265806 (\CoerceToDisplayDevice 252657 . 253070) ( +\CREATEDISPLAY 253072 . 254912) (DISPLAYSTREAMINIT 254914 . 258058) (\STARTDISPLAY 258060 . 260971) ( +\MOVE.WINDOWS.ONTO.SCREEN 260973 . 263165) (\UPDATE.PBT.RASTERWIDTHS 263167 . 264949) (\STOPDISPLAY +264951 . 265443) (\DEFINEDISPLAYINFO 265445 . 265804)) (266398 267159 (INITIALIZEDISPLAYSTREAMS 266408 + . 267157))))) +STOP diff --git a/sources/LLERROR b/sources/LLERROR new file mode 100644 index 00000000..f90b855f --- /dev/null +++ b/sources/LLERROR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 19:17:05" |{DSK}local>lde>lispcore>sources>LLERROR.;2| 1461 |changes| |to:| (VARS LLERRORCOMS) |previous| |date:| "15-Jan-88 16:30:33" |{DSK}local>lde>lispcore>sources>LLERROR.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT LLERRORCOMS) (RPAQQ LLERRORCOMS ((FUNCTIONS SIMPLE-FORMAT) (P (MOVD? 'SIMPLE-FORMAT 'CL:FORMAT)) (STRUCTURES PROCEED-CASE) (VARIABLES SI::NLSETQ-PROCEED-CASE) (PROP FILETYPE LLERROR))) (CL:DEFUN SIMPLE-FORMAT (STREAM &REST ARGS) (CL:WHEN (EQ STREAM T) (CL:SETF STREAM *STANDARD-OUTPUT*)) (CL:DOLIST (X ARGS) (CL:PRINT X STREAM))) (MOVD? 'SIMPLE-FORMAT 'CL:FORMAT) (CL:DEFSTRUCT (PROCEED-CASE (:INCLUDE CONDITIONS:RESTART) (:CONC-NAME "%PROCEED-CASE-"))) (DEFGLOBALPARAMETER SI::NLSETQ-PROCEED-CASE (MAKE-PROCEED-CASE :NAME 'ABORT :SELECTOR 0 :TEST NIL :REPORT "Unwind to ERRORSET") "The prototype proceed-case object for NLSETQ.") (PUTPROPS LLERROR FILETYPE COMPILE-FILE) (PUTPROPS LLERROR COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/LLETHER b/sources/LLETHER new file mode 100644 index 00000000..a241b8c4 --- /dev/null +++ b/sources/LLETHER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:49:30" {DSK}lde>lispcore>sources>LLETHER.;2 139094 changes to%: (RECORDS SYSQUEUE QABLEITEM ETHERPACKET ETHERAUX NDB ROUTING ETHERTRANS CENTICLOCK 3MBENCAPSULATION PBI) previous date%: " 5-Jan-93 00:36:20" {DSK}lde>lispcore>sources>LLETHER.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLETHERCOMS) (RPAQQ LLETHERCOMS [(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) LLNSDECLS)) [COMS (* ;  "Stuff that should be somewhere else!") (INITVARS (ERRORMESSAGESTREAM T) (PROMPTWINDOW T)) (GLOBALVARS ERRORMESSAGESTREAM PROMPTWINDOW) (COMS (* ;  "Queue management for data which can be chain-linked through the first cell") (DECLARE%: DONTCOPY (EXPORT (RECORDS SYSQUEUE QABLEITEM) (MACROS \QUEUEHEAD))) (INITRECORDS SYSQUEUE) (SYSRECORDS SYSQUEUE) (FNS \ENQUEUE \DEQUEUE \QUEUELENGTH \ONQUEUE \UNQUEUE) (* ;  "Queue management constructed by TCONC") (EXPORT (MACROS \DETCONC \ENTCONC \PEEKTCONC] (COMS (* ; "General packet management") (DECLARE%: DONTCOPY (* ;; "Skeletal ether packet. Other users define with respect to") (EXPORT (RECORDS ETHERPACKET ETHERAUX) (CONSTANTS \EPT.PUP \EPT.XIP \3MBTYPE.XIP \10MBTYPE.XIP \EPT.10TO3 \3MBTYPE.10TO3 \EPT.UNKNOWN)) (GLOBALVARS \FREE.PACKET.QUEUE \NEWPACKETCOUNTER)) (INITRECORDS ETHERPACKET) (SYSRECORDS ETHERPACKET) (FNS \ALLOCATE.ETHERPACKET \RELEASE.ETHERPACKET RELEASE.PUP \FLUSH.PACKET.QUEUE \REQUEUE.ETHERPACKET \EP.PUT.AUX) (INITVARS (\FREE.PACKET.QUEUE (NCREATE 'SYSQUEUE)) (\NEWPACKETCOUNTER 5))) [COMS (INITRECORDS NSADDRESS) (INITVARS (\MY.NSHOSTNUMBER NIL) (\MY.NSNETNUMBER NIL) (\MY.NSADDRESS NIL) (*NSADDRESS-FORMAT* NIL)) [P (CL:PROCLAIM '(CL:SPECIAL *NSADDRESS-FORMAT*] (VARS BROADCASTNSHOSTNUMBER) (FNS \SETLOCALNSNUMBERS \LOADNSADDRESS \STORENSADDRESS \PRINTNSADDRESS \NSADDRESS.DEFPRINT \NSADDRESS.PRINT.DECIMAL \LOADNSHOSTNUMBER \STORENSHOSTNUMBER PRINTNSHOSTNUMBER) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (DEFPRINT 'NSADDRESS '\NSADDRESS.DEFPRINT] [COMS (* ; "Assorted Level 0") (FNS \ETHERINIT \ETHEREVENTFN \TIME.NOT.SET \SETETHERFLAGS \FLUSHNDBS \FLUSH.NDB.QUEUE) (FNS \CHECKSUM \HANDLE.RAW.OTHER \HANDLE.RAW.PACKET \ADD.PACKET.FILTER \DEL.PACKET.FILTER) (DECLARE%: DONTCOPY (EXPORT (CONSTANTS (\NULLCHECKSUM 65535))) (GLOBALVARS \PACKET.FILTERS \ETHERLIGHTNING RESTARTETHERFNS)) (INITVARS (\PACKET.FILTERS NIL) (\ETHERLIGHTNING) (RESTARTETHERFNS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\ETHERINIT) (MOVD? 'NILL 'BLOCK) (MOVD? 'NILL '\STASH.PASSWORDS] (COMS (* ; "Assorted routing stuff") (DECLARE%: DONTCOPY (EXPORT (RECORDS NDB ROUTING)) (CONSTANTS \RT.INFINITY) (MACROS ENCAPSULATE.ETHERPACKET TRANSMIT.ETHERPACKET BROADCASTP \CHECK.ROUTING.TABLE) (GLOBALVARS \RT.TIMEOUTINTERVAL \RT.AGEINTERVAL \RT.PURGEFLG \GATEWAYFLG \ROUTING.TABLE.MASK \ROUTING.TABLE.TYPENUM) (GLOBALVARS \3MBFLG \10MBFLG \3MBLOCALNDB \10MBLOCALNDB \LOCALNDBS \NSFLG \IPFLG \NS.ROUTING.TABLE \PUP.ROUTING.TABLE \NS.READY \PUP.READY \IP.READY)) (INITRECORDS NDB) (SYSRECORDS NDB) (FNS ENCAPSULATE.ETHERPACKET TRANSMIT.ETHERPACKET) (* ;; "Routing table management. Table is naked array of specified size (choices are 8, 16, 32, 64, based on availability of pointer hunks for those sizes). These are global vars rather than constants so you can play with them (but you'd better restart ether immediately).") (FNS \AGE.ROUTING.TABLE \ADD.ROUTING.TABLE.ENTRY \CLEAR.ROUTING.TABLE \MAP.ROUTING.TABLE PRINTROUTINGTABLE \ROUTINGTABLE.INFOHOOK) [INITVARS (\RT.TIMEOUTINTERVAL 90000) (\RT.AGEINTERVAL 30000) (\RT.PURGEFLG T) (\GATEWAYFLG NIL) (\ROUTING.TABLE.MASK 31) (\ROUTING.TABLE.TYPENUM (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK ] (INITVARS (\3MBFLG T) (\10MBFLG) (\3MBLOCALNDB) (\10MBLOCALNDB) (\LOCALNDBS) (\NSFLG) (\IPFLG))) (COMS (* ; "10 to 3 translation ugliness") (FNS \TRANSLATE.10TO3 \NOTE.10TO3 \HANDLE.RAW.10TO3) (DECLARE%: DONTCOPY (RECORDS ETHERTRANS) (CONSTANTS \TRANS.OP.REQUEST \TRANS.OP.RESPONSE \TRANS.DATALENGTH) (* ;; "The \TRANS.DATALENGTH includes the space for 10TO3OPERATION and two 3-word/1-word translation pairs.") )) (COMS (* ; "Printing routines for packets") (FNS PRINTPACKET \MAYBEPRINTPACKET PRINT10TO3 PRINTPACKETDATA PRINTPACKETQUEUE TIME.SINCE.PACKET MAKE-NETWORK-TRACE-WINDOW \CHANGE.ETHER.TRACING) (INITVARS (\RAWTRACING)) (ADDVARS (\PACKET.PRINTERS (512 . PRINTPUP) (1537 . PRINT10TO3))) (GLOBALVARS \RAWTRACING \PACKET.PRINTERS PUPTRACEFILE XIPTRACEFILE \RCLKMILLISECOND)) (COMS (* ; "For PUP/XIPTRACETIME, functions to convert time from internal ticks to decimal fractions of a second.") (FNS \CENTICLOCK) [VARS (\CENTICLOCKFACTOR) (\CENTICLOCKBOX (NCREATE 'FIXP] (ADDVARS (\SYSTEMCACHEVARS \CENTICLOCKFACTOR)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX) (RECORDS CENTICLOCK))) (COMS (* ;  "3MB stuff, which is not needed in DandeLion") (FNS \3MBGETPACKET \3MB.CREATENDB \3MBSENDPACKET \3MBWATCHER \3MBENCAPSULATE \3MB.BROADCASTP \3MBFLUSH) (INITVARS (\MAXWATCHERGETS 5)) (DECLARE%: DONTCOPY (RECORDS 3MBENCAPSULATION PBI) (EXPORT (MACROS \SERIALNUMBER)) (CONSTANTS \3MBENCAPSULATION.WORDS \3MBTYPE.PUP) (GLOBALVARS \MAXWATCHERGETS *MAXIMUM-PACKET-SIZE*))) (COMS (* ; "Debugging") (FNS ASSURE.ETHER.ON INITPUPLEVEL1 TURN.ON.ETHER RESTART.ETHER TURN.OFF.ETHER PRINTWORDS) (VARS ROUTINGINFOMACRO) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T))) (COMS (* ; "Opcodes") (FNS \DEVICE.INPUT \DEVICE.OUTPUT \D0.STARTIO) (DECLARE%: DONTCOPY (CONSTANTS * D0DEVICES) (EXPORT (PROP DOPVAL \DEVICE.INPUT \DEVICE.OUTPUT \D0.STARTIO]) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LLNSDECLS) ) (* ; "Stuff that should be somewhere else!") (RPAQ? ERRORMESSAGESTREAM T) (RPAQ? PROMPTWINDOW T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ERRORMESSAGESTREAM PROMPTWINDOW) ) (* ; "Queue management for data which can be chain-linked through the first cell") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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") ))) ) (/DECLAREDATATYPE 'SYSQUEUE '(BYTE POINTER BYTE POINTER) '((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) (SYSQUEUE 4 POINTER)) '6) (DECLARE%: EVAL@COMPILE (PUTPROPS \QUEUEHEAD MACRO ((Q) (fetch (SYSQUEUE SYSQUEUEHEAD) of Q))) ) (* "END EXPORTED DEFINITIONS") ) (/DECLAREDATATYPE 'SYSQUEUE '(BYTE POINTER BYTE POINTER) '((SYSQUEUE 0 (BITS . 7)) (SYSQUEUE 2 POINTER) (SYSQUEUE 1 (BITS . 7)) (SYSQUEUE 4 POINTER)) '6) (ADDTOVAR SYSTEMRECLST (DATATYPE SYSQUEUE ((NIL BYTE) (SYSQUEUEHEAD POINTER) (NIL BYTE) (SYSQUEUETAIL POINTER))) ) (DEFINEQ (\ENQUEUE [LAMBDA (Q ITEM) (* bvm%: "14-Feb-85 21:55") (* ;; "Adds ITEM to tail of Q, which must be a SYSQUEUE datatype. ITEM must be describable by QABLEITEM.") (SETQ Q (\DTEST Q 'SYSQUEUE)) (* ;; "Do this \DTEST first, even though the fetch will also do it, so that no error occurs underneath the UNINTERRUPTABLY") (PROG (TAILEND JUNK) (UNINTERRUPTABLY [COND ((NOT (ffetch SYSQUEUEHEAD of Q)) (* ; "Empty queue") (freplace SYSQUEUEHEAD of Q with ITEM)) ([NULL (fetch QLINK of (SETQ TAILEND (ffetch SYSQUEUETAIL of Q] (* ;  "Normal case, SYSQUEUETAIL should have nothing after it") (freplace QLINK of TAILEND with ITEM)) (T (* ;; "SYSQUEUETAIL has non-null link? Shouldn't happen, but folks who are sloppy about there queues can have this happen. Need to signal an error, but first at least patch the queue up so that while you're sitting in the break you don't have more similar breaks") (SETQ JUNK (LIST* "Tail at:" (LOC TAILEND) "LINK:" (fetch QLINK of TAILEND) "Queue item locations:" (to 100 bind THISITEM (NEXTITEM _ (ffetch SYSQUEUEHEAD of Q)) while (SETQ NEXTITEM (ffetch QLINK of (SETQ THISITEM NEXTITEM)) ) collect (LOC THISITEM) finally (COND (THISITEM (replace QLINK of THISITEM with ITEM] (freplace QLINK of ITEM with NIL) (* ;  "Just for safety -- who knows what garbage may have creeped into the LINK slot of ITEM") (freplace SYSQUEUETAIL of Q with ITEM)) (AND JUNK (ERROR "Tail of queue has non-NIL link ptr" JUNK))) ITEM]) (\DEQUEUE [LAMBDA (Q) (* ; "Edited 28-Aug-91 18:41 by jds") (* ;; "Removes and returns the top item on Q, which should be a SYSQUEUE datatype. Returns NIL if queue is empty.") (SETQ Q (\DTEST Q 'SYSQUEUE)) (* ;; "Do this \DTEST first, even though the fetch will also do it, so that no error occurs underneath the UNINTERRUPTABLY") (UNINTERRUPTABLY (PROG ((ITEM (ffetch SYSQUEUEHEAD of Q))) (if ITEM then (* ;  "First, 'cdr' the link in the queue head") (if (NULL (freplace SYSQUEUEHEAD of Q with (ffetch QLINK of ITEM))) then (* ; "Exhausted queue") (freplace SYSQUEUETAIL of Q with NIL)) (freplace QLINK of ITEM with NIL) (* ;  "Break the connection that ITEM had with the queue.") ) (RETURN ITEM)))]) (\QUEUELENGTH [LAMBDA (Q) (* bvm%: " 4-FEB-83 13:05") (PROG ((X (fetch SYSQUEUEHEAD of Q)) (CNT 0)) LP (OR X (RETURN CNT)) (SETQ X (fetch QLINK of X)) (add CNT 1) (GO LP]) (\ONQUEUE [LAMBDA (ITEM Q) (* bvm%: " 4-FEB-83 13:04") (for (X _ (fetch (SYSQUEUE SYSQUEUEHEAD) of Q)) by (fetch QLINK of X) while X do (RETURN ITEM) when (EQ X ITEM]) (\UNQUEUE [LAMBDA (QUEUE ITEM NOERRORFLG) (* bvm%: " 6-FEB-83 18:27") (* ;;; "Removes ITEM from QUEUE, wherever it may be. Is error if ITEM not in QUEUE unless NOERRORFLG is true") (COND [(UNINTERRUPTABLY [bind (NEXT _ (fetch SYSQUEUEHEAD of QUEUE)) PREV while NEXT do (COND ((EQ NEXT ITEM) (COND [(NULL PREV) (* ; "removing head of queue") (COND ((NULL (replace SYSQUEUEHEAD of QUEUE with (fetch QLINK of ITEM))) (* ; "Exhausted queue") (replace SYSQUEUETAIL of QUEUE with NIL] ((NULL (replace QLINK of PREV with (fetch QLINK of ITEM))) (* ; "Removing last item") (replace SYSQUEUETAIL of QUEUE with PREV))) (replace QLINK of ITEM with NIL) (RETURN ITEM)) (T (SETQ NEXT (fetch QLINK of (SETQ PREV NEXT])] ((NOT NOERRORFLG) (ERROR (LIST ITEM 'not 'on QUEUE]) ) (* ; "Queue management constructed by TCONC") (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE [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)) ) (* "END EXPORTED DEFINITIONS") (* ; "General packet management") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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 'AUXPTR (fetch EPPLIST of DATUM))) (\EP.PUT.AUX DATUM 'AUXPTR NEWVALUE)) (AUXWORD (OR (CDR (ASSOC 'AUXWORD (fetch EPPLIST of DATUM))) 0) (\EP.PUT.AUX DATUM 'AUXWORD NEWVALUE)) (AUXBYTE (OR (CDR (ASSOC 'AUXBYTE (fetch EPPLIST of DATUM))) 0) (\EP.PUT.AUX DATUM 'AUXBYTE NEWVALUE)))) ) (/DECLAREDATATYPE 'ETHERPACKET '(BYTE POINTER BYTE POINTER BYTE POINTER FLAG FLAG (BITS 6) POINTER BYTE POINTER BYTE POINTER WORD WORD FIXP POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((ETHERPACKET 0 (BITS . 7)) (ETHERPACKET 2 POINTER) (ETHERPACKET 1 (BITS . 7)) (ETHERPACKET 4 POINTER) (ETHERPACKET 1 (BITS . 135)) (ETHERPACKET 6 POINTER) (ETHERPACKET 6 (FLAGBITS . 0)) (ETHERPACKET 6 (FLAGBITS . 16)) (ETHERPACKET 0 (BITS . 133)) (ETHERPACKET 8 POINTER) (ETHERPACKET 10 (BITS . 7)) (ETHERPACKET 12 POINTER) (ETHERPACKET 11 (BITS . 7)) (ETHERPACKET 14 POINTER) (ETHERPACKET 16 (BITS . 15)) (ETHERPACKET 17 (BITS . 15)) (ETHERPACKET 18 FIXP) (ETHERPACKET 20 POINTER) (ETHERPACKET 22 (BITS . 15)) (ETHERPACKET 23 (BITS . 15)) (ETHERPACKET 24 (BITS . 15)) (ETHERPACKET 25 (BITS . 15)) (ETHERPACKET 26 (BITS . 15)) (ETHERPACKET 27 (BITS . 15)) (ETHERPACKET 28 (BITS . 15)) (ETHERPACKET 29 (BITS . 15)) (ETHERPACKET 30 (BITS . 15)) (ETHERPACKET 31 (BITS . 15)) (ETHERPACKET 32 (BITS . 15)) (ETHERPACKET 33 (BITS . 15)) (ETHERPACKET 34 (BITS . 15)) (ETHERPACKET 35 (BITS . 15)) (ETHERPACKET 36 (BITS . 15)) (ETHERPACKET 37 (BITS . 15)) (ETHERPACKET 38 (BITS . 15)) (ETHERPACKET 39 (BITS . 15)) (ETHERPACKET 40 (BITS . 15)) (ETHERPACKET 41 (BITS . 15)) (ETHERPACKET 42 (BITS . 15)) (ETHERPACKET 43 (BITS . 15)) (ETHERPACKET 44 (BITS . 15)) (ETHERPACKET 45 (BITS . 15)) (ETHERPACKET 46 (BITS . 15)) (ETHERPACKET 47 (BITS . 15)) (ETHERPACKET 48 (BITS . 15)) (ETHERPACKET 49 (BITS . 15)) (ETHERPACKET 50 (BITS . 15)) (ETHERPACKET 51 (BITS . 15)) (ETHERPACKET 52 (BITS . 15)) (ETHERPACKET 53 (BITS . 15)) (ETHERPACKET 54 (BITS . 15)) (ETHERPACKET 55 (BITS . 15)) (ETHERPACKET 56 (BITS . 15)) (ETHERPACKET 57 (BITS . 15)) (ETHERPACKET 58 (BITS . 15)) (ETHERPACKET 59 (BITS . 15)) (ETHERPACKET 60 (BITS . 15)) (ETHERPACKET 61 (BITS . 15)) (ETHERPACKET 62 (BITS . 15)) (ETHERPACKET 63 (BITS . 15)) (ETHERPACKET 64 (BITS . 15)) (ETHERPACKET 65 (BITS . 15)) (ETHERPACKET 66 (BITS . 15)) (ETHERPACKET 67 (BITS . 15)) (ETHERPACKET 68 (BITS . 15)) (ETHERPACKET 69 (BITS . 15)) (ETHERPACKET 70 (BITS . 15)) (ETHERPACKET 71 (BITS . 15)) (ETHERPACKET 72 (BITS . 15)) (ETHERPACKET 73 (BITS . 15)) (ETHERPACKET 74 (BITS . 15)) (ETHERPACKET 75 (BITS . 15)) (ETHERPACKET 76 (BITS . 15)) (ETHERPACKET 77 (BITS . 15)) (ETHERPACKET 78 (BITS . 15)) (ETHERPACKET 79 (BITS . 15)) (ETHERPACKET 80 (BITS . 15)) (ETHERPACKET 81 (BITS . 15)) (ETHERPACKET 82 (BITS . 15)) (ETHERPACKET 83 (BITS . 15)) (ETHERPACKET 84 (BITS . 15)) (ETHERPACKET 85 (BITS . 15)) (ETHERPACKET 86 (BITS . 15)) (ETHERPACKET 87 (BITS . 15)) (ETHERPACKET 88 (BITS . 15)) (ETHERPACKET 89 (BITS . 15)) (ETHERPACKET 90 (BITS . 15)) (ETHERPACKET 91 (BITS . 15)) (ETHERPACKET 92 (BITS . 15)) (ETHERPACKET 93 (BITS . 15)) (ETHERPACKET 94 (BITS . 15)) (ETHERPACKET 95 (BITS . 15)) (ETHERPACKET 96 (BITS . 15)) (ETHERPACKET 97 (BITS . 15)) (ETHERPACKET 98 (BITS . 15)) (ETHERPACKET 99 (BITS . 15)) (ETHERPACKET 100 (BITS . 15)) (ETHERPACKET 101 (BITS . 15)) (ETHERPACKET 102 (BITS . 15)) (ETHERPACKET 103 (BITS . 15)) (ETHERPACKET 104 (BITS . 15)) (ETHERPACKET 105 (BITS . 15)) (ETHERPACKET 106 (BITS . 15)) (ETHERPACKET 107 (BITS . 15)) (ETHERPACKET 108 (BITS . 15)) (ETHERPACKET 109 (BITS . 15)) (ETHERPACKET 110 (BITS . 15)) (ETHERPACKET 111 (BITS . 15)) (ETHERPACKET 112 (BITS . 15)) (ETHERPACKET 113 (BITS . 15)) (ETHERPACKET 114 (BITS . 15)) (ETHERPACKET 115 (BITS . 15)) (ETHERPACKET 116 (BITS . 15)) (ETHERPACKET 117 (BITS . 15)) (ETHERPACKET 118 (BITS . 15)) (ETHERPACKET 119 (BITS . 15)) (ETHERPACKET 120 (BITS . 15)) (ETHERPACKET 121 (BITS . 15)) (ETHERPACKET 122 (BITS . 15)) (ETHERPACKET 123 (BITS . 15)) (ETHERPACKET 124 (BITS . 15)) (ETHERPACKET 125 (BITS . 15)) (ETHERPACKET 126 (BITS . 15)) (ETHERPACKET 127 (BITS . 15)) (ETHERPACKET 128 (BITS . 15)) (ETHERPACKET 129 (BITS . 15)) (ETHERPACKET 130 (BITS . 15)) (ETHERPACKET 131 (BITS . 15)) (ETHERPACKET 132 (BITS . 15)) (ETHERPACKET 133 (BITS . 15)) (ETHERPACKET 134 (BITS . 15)) (ETHERPACKET 135 (BITS . 15)) (ETHERPACKET 136 (BITS . 15)) (ETHERPACKET 137 (BITS . 15)) (ETHERPACKET 138 (BITS . 15)) (ETHERPACKET 139 (BITS . 15)) (ETHERPACKET 140 (BITS . 15)) (ETHERPACKET 141 (BITS . 15)) (ETHERPACKET 142 (BITS . 15)) (ETHERPACKET 143 (BITS . 15)) (ETHERPACKET 144 (BITS . 15)) (ETHERPACKET 145 (BITS . 15)) (ETHERPACKET 146 (BITS . 15)) (ETHERPACKET 147 (BITS . 15)) (ETHERPACKET 148 (BITS . 15)) (ETHERPACKET 149 (BITS . 15)) (ETHERPACKET 150 (BITS . 15)) (ETHERPACKET 151 (BITS . 15)) (ETHERPACKET 152 (BITS . 15)) (ETHERPACKET 153 (BITS . 15)) (ETHERPACKET 154 (BITS . 15)) (ETHERPACKET 155 (BITS . 15)) (ETHERPACKET 156 (BITS . 15)) (ETHERPACKET 157 (BITS . 15)) (ETHERPACKET 158 (BITS . 15)) (ETHERPACKET 159 (BITS . 15)) (ETHERPACKET 160 (BITS . 15)) (ETHERPACKET 161 (BITS . 15)) (ETHERPACKET 162 (BITS . 15)) (ETHERPACKET 163 (BITS . 15)) (ETHERPACKET 164 (BITS . 15)) (ETHERPACKET 165 (BITS . 15)) (ETHERPACKET 166 (BITS . 15)) (ETHERPACKET 167 (BITS . 15)) (ETHERPACKET 168 (BITS . 15)) (ETHERPACKET 169 (BITS . 15)) (ETHERPACKET 170 (BITS . 15)) (ETHERPACKET 171 (BITS . 15)) (ETHERPACKET 172 (BITS . 15)) (ETHERPACKET 173 (BITS . 15)) (ETHERPACKET 174 (BITS . 15)) (ETHERPACKET 175 (BITS . 15)) (ETHERPACKET 176 (BITS . 15)) (ETHERPACKET 177 (BITS . 15)) (ETHERPACKET 178 (BITS . 15)) (ETHERPACKET 179 (BITS . 15)) (ETHERPACKET 180 (BITS . 15)) (ETHERPACKET 181 (BITS . 15)) (ETHERPACKET 182 (BITS . 15)) (ETHERPACKET 183 (BITS . 15)) (ETHERPACKET 184 (BITS . 15)) (ETHERPACKET 185 (BITS . 15)) (ETHERPACKET 186 (BITS . 15)) (ETHERPACKET 187 (BITS . 15)) (ETHERPACKET 188 (BITS . 15)) (ETHERPACKET 189 (BITS . 15)) (ETHERPACKET 190 (BITS . 15)) (ETHERPACKET 191 (BITS . 15)) (ETHERPACKET 192 (BITS . 15)) (ETHERPACKET 193 (BITS . 15)) (ETHERPACKET 194 (BITS . 15)) (ETHERPACKET 195 (BITS . 15)) (ETHERPACKET 196 (BITS . 15)) (ETHERPACKET 197 (BITS . 15)) (ETHERPACKET 198 (BITS . 15)) (ETHERPACKET 199 (BITS . 15)) (ETHERPACKET 200 (BITS . 15)) (ETHERPACKET 201 (BITS . 15)) (ETHERPACKET 202 (BITS . 15)) (ETHERPACKET 203 (BITS . 15)) (ETHERPACKET 204 (BITS . 15)) (ETHERPACKET 205 (BITS . 15)) (ETHERPACKET 206 (BITS . 15)) (ETHERPACKET 207 (BITS . 15)) (ETHERPACKET 208 (BITS . 15)) (ETHERPACKET 209 (BITS . 15)) (ETHERPACKET 210 (BITS . 15)) (ETHERPACKET 211 (BITS . 15)) (ETHERPACKET 212 (BITS . 15)) (ETHERPACKET 213 (BITS . 15)) (ETHERPACKET 214 (BITS . 15)) (ETHERPACKET 215 (BITS . 15)) (ETHERPACKET 216 (BITS . 15)) (ETHERPACKET 217 (BITS . 15)) (ETHERPACKET 218 (BITS . 15)) (ETHERPACKET 219 (BITS . 15)) (ETHERPACKET 220 (BITS . 15)) (ETHERPACKET 221 (BITS . 15)) (ETHERPACKET 222 (BITS . 15)) (ETHERPACKET 223 (BITS . 15)) (ETHERPACKET 224 (BITS . 15)) (ETHERPACKET 225 (BITS . 15)) (ETHERPACKET 226 (BITS . 15)) (ETHERPACKET 227 (BITS . 15)) (ETHERPACKET 228 (BITS . 15)) (ETHERPACKET 229 (BITS . 15)) (ETHERPACKET 230 (BITS . 15)) (ETHERPACKET 231 (BITS . 15)) (ETHERPACKET 232 (BITS . 15)) (ETHERPACKET 233 (BITS . 15)) (ETHERPACKET 234 (BITS . 15)) (ETHERPACKET 235 (BITS . 15)) (ETHERPACKET 236 (BITS . 15)) (ETHERPACKET 237 (BITS . 15)) (ETHERPACKET 238 (BITS . 15)) (ETHERPACKET 239 (BITS . 15)) (ETHERPACKET 240 (BITS . 15)) (ETHERPACKET 241 (BITS . 15)) (ETHERPACKET 242 (BITS . 15)) (ETHERPACKET 243 (BITS . 15)) (ETHERPACKET 244 (BITS . 15)) (ETHERPACKET 245 (BITS . 15)) (ETHERPACKET 246 (BITS . 15)) (ETHERPACKET 247 (BITS . 15)) (ETHERPACKET 248 (BITS . 15)) (ETHERPACKET 249 (BITS . 15)) (ETHERPACKET 250 (BITS . 15)) (ETHERPACKET 251 (BITS . 15)) (ETHERPACKET 252 (BITS . 15)) (ETHERPACKET 253 (BITS . 15)) (ETHERPACKET 254 (BITS . 15)) (ETHERPACKET 255 (BITS . 15)) (ETHERPACKET 256 (BITS . 15)) (ETHERPACKET 257 (BITS . 15)) (ETHERPACKET 258 (BITS . 15)) (ETHERPACKET 259 (BITS . 15)) (ETHERPACKET 260 (BITS . 15)) (ETHERPACKET 261 (BITS . 15)) (ETHERPACKET 262 (BITS . 15)) (ETHERPACKET 263 (BITS . 15)) (ETHERPACKET 264 (BITS . 15)) (ETHERPACKET 265 (BITS . 15)) (ETHERPACKET 266 (BITS . 15)) (ETHERPACKET 267 (BITS . 15)) (ETHERPACKET 268 (BITS . 15)) (ETHERPACKET 269 (BITS . 15)) (ETHERPACKET 270 (BITS . 15)) (ETHERPACKET 271 (BITS . 15)) (ETHERPACKET 272 (BITS . 15)) (ETHERPACKET 273 (BITS . 15)) (ETHERPACKET 274 (BITS . 15)) (ETHERPACKET 275 (BITS . 15)) (ETHERPACKET 276 (BITS . 15)) (ETHERPACKET 277 (BITS . 15)) (ETHERPACKET 278 (BITS . 15)) (ETHERPACKET 279 (BITS . 15)) (ETHERPACKET 280 (BITS . 15)) (ETHERPACKET 281 (BITS . 15)) (ETHERPACKET 282 (BITS . 15)) (ETHERPACKET 283 (BITS . 15)) (ETHERPACKET 284 (BITS . 15)) (ETHERPACKET 285 (BITS . 15)) (ETHERPACKET 286 (BITS . 15)) (ETHERPACKET 287 (BITS . 15)) (ETHERPACKET 288 (BITS . 15)) (ETHERPACKET 289 (BITS . 15)) (ETHERPACKET 290 (BITS . 15)) (ETHERPACKET 291 (BITS . 15)) (ETHERPACKET 292 (BITS . 15)) (ETHERPACKET 293 (BITS . 15)) (ETHERPACKET 294 (BITS . 15)) (ETHERPACKET 295 (BITS . 15)) (ETHERPACKET 296 (BITS . 15)) (ETHERPACKET 297 (BITS . 15)) (ETHERPACKET 298 (BITS . 15)) (ETHERPACKET 299 (BITS . 15)) (ETHERPACKET 300 (BITS . 15)) (ETHERPACKET 301 (BITS . 15)) (ETHERPACKET 302 (BITS . 15)) (ETHERPACKET 303 (BITS . 15)) (ETHERPACKET 304 (BITS . 15)) (ETHERPACKET 305 (BITS . 15)) (ETHERPACKET 306 (BITS . 15)) (ETHERPACKET 307 (BITS . 15)) (ETHERPACKET 308 (BITS . 15)) (ETHERPACKET 309 (BITS . 15)) (ETHERPACKET 310 (BITS . 15)) (ETHERPACKET 311 (BITS . 15)) (ETHERPACKET 312 (BITS . 15)) (ETHERPACKET 313 (BITS . 15)) (ETHERPACKET 314 (BITS . 15)) (ETHERPACKET 315 (BITS . 15)) (ETHERPACKET 316 (BITS . 15)) (ETHERPACKET 317 (BITS . 15)) (ETHERPACKET 318 (BITS . 15)) (ETHERPACKET 319 (BITS . 15)) (ETHERPACKET 320 (BITS . 15)) (ETHERPACKET 321 (BITS . 15)) (ETHERPACKET 322 (BITS . 15))) '324) (DECLARE%: EVAL@COMPILE (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) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FREE.PACKET.QUEUE \NEWPACKETCOUNTER) ) ) (/DECLAREDATATYPE 'ETHERPACKET '(BYTE POINTER BYTE POINTER BYTE POINTER FLAG FLAG (BITS 6) POINTER BYTE POINTER BYTE POINTER WORD WORD FIXP POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD) '((ETHERPACKET 0 (BITS . 7)) (ETHERPACKET 2 POINTER) (ETHERPACKET 1 (BITS . 7)) (ETHERPACKET 4 POINTER) (ETHERPACKET 1 (BITS . 135)) (ETHERPACKET 6 POINTER) (ETHERPACKET 6 (FLAGBITS . 0)) (ETHERPACKET 6 (FLAGBITS . 16)) (ETHERPACKET 0 (BITS . 133)) (ETHERPACKET 8 POINTER) (ETHERPACKET 10 (BITS . 7)) (ETHERPACKET 12 POINTER) (ETHERPACKET 11 (BITS . 7)) (ETHERPACKET 14 POINTER) (ETHERPACKET 16 (BITS . 15)) (ETHERPACKET 17 (BITS . 15)) (ETHERPACKET 18 FIXP) (ETHERPACKET 20 POINTER) (ETHERPACKET 22 (BITS . 15)) (ETHERPACKET 23 (BITS . 15)) (ETHERPACKET 24 (BITS . 15)) (ETHERPACKET 25 (BITS . 15)) (ETHERPACKET 26 (BITS . 15)) (ETHERPACKET 27 (BITS . 15)) (ETHERPACKET 28 (BITS . 15)) (ETHERPACKET 29 (BITS . 15)) (ETHERPACKET 30 (BITS . 15)) (ETHERPACKET 31 (BITS . 15)) (ETHERPACKET 32 (BITS . 15)) (ETHERPACKET 33 (BITS . 15)) (ETHERPACKET 34 (BITS . 15)) (ETHERPACKET 35 (BITS . 15)) (ETHERPACKET 36 (BITS . 15)) (ETHERPACKET 37 (BITS . 15)) (ETHERPACKET 38 (BITS . 15)) (ETHERPACKET 39 (BITS . 15)) (ETHERPACKET 40 (BITS . 15)) (ETHERPACKET 41 (BITS . 15)) (ETHERPACKET 42 (BITS . 15)) (ETHERPACKET 43 (BITS . 15)) (ETHERPACKET 44 (BITS . 15)) (ETHERPACKET 45 (BITS . 15)) (ETHERPACKET 46 (BITS . 15)) (ETHERPACKET 47 (BITS . 15)) (ETHERPACKET 48 (BITS . 15)) (ETHERPACKET 49 (BITS . 15)) (ETHERPACKET 50 (BITS . 15)) (ETHERPACKET 51 (BITS . 15)) (ETHERPACKET 52 (BITS . 15)) (ETHERPACKET 53 (BITS . 15)) (ETHERPACKET 54 (BITS . 15)) (ETHERPACKET 55 (BITS . 15)) (ETHERPACKET 56 (BITS . 15)) (ETHERPACKET 57 (BITS . 15)) (ETHERPACKET 58 (BITS . 15)) (ETHERPACKET 59 (BITS . 15)) (ETHERPACKET 60 (BITS . 15)) (ETHERPACKET 61 (BITS . 15)) (ETHERPACKET 62 (BITS . 15)) (ETHERPACKET 63 (BITS . 15)) (ETHERPACKET 64 (BITS . 15)) (ETHERPACKET 65 (BITS . 15)) (ETHERPACKET 66 (BITS . 15)) (ETHERPACKET 67 (BITS . 15)) (ETHERPACKET 68 (BITS . 15)) (ETHERPACKET 69 (BITS . 15)) (ETHERPACKET 70 (BITS . 15)) (ETHERPACKET 71 (BITS . 15)) (ETHERPACKET 72 (BITS . 15)) (ETHERPACKET 73 (BITS . 15)) (ETHERPACKET 74 (BITS . 15)) (ETHERPACKET 75 (BITS . 15)) (ETHERPACKET 76 (BITS . 15)) (ETHERPACKET 77 (BITS . 15)) (ETHERPACKET 78 (BITS . 15)) (ETHERPACKET 79 (BITS . 15)) (ETHERPACKET 80 (BITS . 15)) (ETHERPACKET 81 (BITS . 15)) (ETHERPACKET 82 (BITS . 15)) (ETHERPACKET 83 (BITS . 15)) (ETHERPACKET 84 (BITS . 15)) (ETHERPACKET 85 (BITS . 15)) (ETHERPACKET 86 (BITS . 15)) (ETHERPACKET 87 (BITS . 15)) (ETHERPACKET 88 (BITS . 15)) (ETHERPACKET 89 (BITS . 15)) (ETHERPACKET 90 (BITS . 15)) (ETHERPACKET 91 (BITS . 15)) (ETHERPACKET 92 (BITS . 15)) (ETHERPACKET 93 (BITS . 15)) (ETHERPACKET 94 (BITS . 15)) (ETHERPACKET 95 (BITS . 15)) (ETHERPACKET 96 (BITS . 15)) (ETHERPACKET 97 (BITS . 15)) (ETHERPACKET 98 (BITS . 15)) (ETHERPACKET 99 (BITS . 15)) (ETHERPACKET 100 (BITS . 15)) (ETHERPACKET 101 (BITS . 15)) (ETHERPACKET 102 (BITS . 15)) (ETHERPACKET 103 (BITS . 15)) (ETHERPACKET 104 (BITS . 15)) (ETHERPACKET 105 (BITS . 15)) (ETHERPACKET 106 (BITS . 15)) (ETHERPACKET 107 (BITS . 15)) (ETHERPACKET 108 (BITS . 15)) (ETHERPACKET 109 (BITS . 15)) (ETHERPACKET 110 (BITS . 15)) (ETHERPACKET 111 (BITS . 15)) (ETHERPACKET 112 (BITS . 15)) (ETHERPACKET 113 (BITS . 15)) (ETHERPACKET 114 (BITS . 15)) (ETHERPACKET 115 (BITS . 15)) (ETHERPACKET 116 (BITS . 15)) (ETHERPACKET 117 (BITS . 15)) (ETHERPACKET 118 (BITS . 15)) (ETHERPACKET 119 (BITS . 15)) (ETHERPACKET 120 (BITS . 15)) (ETHERPACKET 121 (BITS . 15)) (ETHERPACKET 122 (BITS . 15)) (ETHERPACKET 123 (BITS . 15)) (ETHERPACKET 124 (BITS . 15)) (ETHERPACKET 125 (BITS . 15)) (ETHERPACKET 126 (BITS . 15)) (ETHERPACKET 127 (BITS . 15)) (ETHERPACKET 128 (BITS . 15)) (ETHERPACKET 129 (BITS . 15)) (ETHERPACKET 130 (BITS . 15)) (ETHERPACKET 131 (BITS . 15)) (ETHERPACKET 132 (BITS . 15)) (ETHERPACKET 133 (BITS . 15)) (ETHERPACKET 134 (BITS . 15)) (ETHERPACKET 135 (BITS . 15)) (ETHERPACKET 136 (BITS . 15)) (ETHERPACKET 137 (BITS . 15)) (ETHERPACKET 138 (BITS . 15)) (ETHERPACKET 139 (BITS . 15)) (ETHERPACKET 140 (BITS . 15)) (ETHERPACKET 141 (BITS . 15)) (ETHERPACKET 142 (BITS . 15)) (ETHERPACKET 143 (BITS . 15)) (ETHERPACKET 144 (BITS . 15)) (ETHERPACKET 145 (BITS . 15)) (ETHERPACKET 146 (BITS . 15)) (ETHERPACKET 147 (BITS . 15)) (ETHERPACKET 148 (BITS . 15)) (ETHERPACKET 149 (BITS . 15)) (ETHERPACKET 150 (BITS . 15)) (ETHERPACKET 151 (BITS . 15)) (ETHERPACKET 152 (BITS . 15)) (ETHERPACKET 153 (BITS . 15)) (ETHERPACKET 154 (BITS . 15)) (ETHERPACKET 155 (BITS . 15)) (ETHERPACKET 156 (BITS . 15)) (ETHERPACKET 157 (BITS . 15)) (ETHERPACKET 158 (BITS . 15)) (ETHERPACKET 159 (BITS . 15)) (ETHERPACKET 160 (BITS . 15)) (ETHERPACKET 161 (BITS . 15)) (ETHERPACKET 162 (BITS . 15)) (ETHERPACKET 163 (BITS . 15)) (ETHERPACKET 164 (BITS . 15)) (ETHERPACKET 165 (BITS . 15)) (ETHERPACKET 166 (BITS . 15)) (ETHERPACKET 167 (BITS . 15)) (ETHERPACKET 168 (BITS . 15)) (ETHERPACKET 169 (BITS . 15)) (ETHERPACKET 170 (BITS . 15)) (ETHERPACKET 171 (BITS . 15)) (ETHERPACKET 172 (BITS . 15)) (ETHERPACKET 173 (BITS . 15)) (ETHERPACKET 174 (BITS . 15)) (ETHERPACKET 175 (BITS . 15)) (ETHERPACKET 176 (BITS . 15)) (ETHERPACKET 177 (BITS . 15)) (ETHERPACKET 178 (BITS . 15)) (ETHERPACKET 179 (BITS . 15)) (ETHERPACKET 180 (BITS . 15)) (ETHERPACKET 181 (BITS . 15)) (ETHERPACKET 182 (BITS . 15)) (ETHERPACKET 183 (BITS . 15)) (ETHERPACKET 184 (BITS . 15)) (ETHERPACKET 185 (BITS . 15)) (ETHERPACKET 186 (BITS . 15)) (ETHERPACKET 187 (BITS . 15)) (ETHERPACKET 188 (BITS . 15)) (ETHERPACKET 189 (BITS . 15)) (ETHERPACKET 190 (BITS . 15)) (ETHERPACKET 191 (BITS . 15)) (ETHERPACKET 192 (BITS . 15)) (ETHERPACKET 193 (BITS . 15)) (ETHERPACKET 194 (BITS . 15)) (ETHERPACKET 195 (BITS . 15)) (ETHERPACKET 196 (BITS . 15)) (ETHERPACKET 197 (BITS . 15)) (ETHERPACKET 198 (BITS . 15)) (ETHERPACKET 199 (BITS . 15)) (ETHERPACKET 200 (BITS . 15)) (ETHERPACKET 201 (BITS . 15)) (ETHERPACKET 202 (BITS . 15)) (ETHERPACKET 203 (BITS . 15)) (ETHERPACKET 204 (BITS . 15)) (ETHERPACKET 205 (BITS . 15)) (ETHERPACKET 206 (BITS . 15)) (ETHERPACKET 207 (BITS . 15)) (ETHERPACKET 208 (BITS . 15)) (ETHERPACKET 209 (BITS . 15)) (ETHERPACKET 210 (BITS . 15)) (ETHERPACKET 211 (BITS . 15)) (ETHERPACKET 212 (BITS . 15)) (ETHERPACKET 213 (BITS . 15)) (ETHERPACKET 214 (BITS . 15)) (ETHERPACKET 215 (BITS . 15)) (ETHERPACKET 216 (BITS . 15)) (ETHERPACKET 217 (BITS . 15)) (ETHERPACKET 218 (BITS . 15)) (ETHERPACKET 219 (BITS . 15)) (ETHERPACKET 220 (BITS . 15)) (ETHERPACKET 221 (BITS . 15)) (ETHERPACKET 222 (BITS . 15)) (ETHERPACKET 223 (BITS . 15)) (ETHERPACKET 224 (BITS . 15)) (ETHERPACKET 225 (BITS . 15)) (ETHERPACKET 226 (BITS . 15)) (ETHERPACKET 227 (BITS . 15)) (ETHERPACKET 228 (BITS . 15)) (ETHERPACKET 229 (BITS . 15)) (ETHERPACKET 230 (BITS . 15)) (ETHERPACKET 231 (BITS . 15)) (ETHERPACKET 232 (BITS . 15)) (ETHERPACKET 233 (BITS . 15)) (ETHERPACKET 234 (BITS . 15)) (ETHERPACKET 235 (BITS . 15)) (ETHERPACKET 236 (BITS . 15)) (ETHERPACKET 237 (BITS . 15)) (ETHERPACKET 238 (BITS . 15)) (ETHERPACKET 239 (BITS . 15)) (ETHERPACKET 240 (BITS . 15)) (ETHERPACKET 241 (BITS . 15)) (ETHERPACKET 242 (BITS . 15)) (ETHERPACKET 243 (BITS . 15)) (ETHERPACKET 244 (BITS . 15)) (ETHERPACKET 245 (BITS . 15)) (ETHERPACKET 246 (BITS . 15)) (ETHERPACKET 247 (BITS . 15)) (ETHERPACKET 248 (BITS . 15)) (ETHERPACKET 249 (BITS . 15)) (ETHERPACKET 250 (BITS . 15)) (ETHERPACKET 251 (BITS . 15)) (ETHERPACKET 252 (BITS . 15)) (ETHERPACKET 253 (BITS . 15)) (ETHERPACKET 254 (BITS . 15)) (ETHERPACKET 255 (BITS . 15)) (ETHERPACKET 256 (BITS . 15)) (ETHERPACKET 257 (BITS . 15)) (ETHERPACKET 258 (BITS . 15)) (ETHERPACKET 259 (BITS . 15)) (ETHERPACKET 260 (BITS . 15)) (ETHERPACKET 261 (BITS . 15)) (ETHERPACKET 262 (BITS . 15)) (ETHERPACKET 263 (BITS . 15)) (ETHERPACKET 264 (BITS . 15)) (ETHERPACKET 265 (BITS . 15)) (ETHERPACKET 266 (BITS . 15)) (ETHERPACKET 267 (BITS . 15)) (ETHERPACKET 268 (BITS . 15)) (ETHERPACKET 269 (BITS . 15)) (ETHERPACKET 270 (BITS . 15)) (ETHERPACKET 271 (BITS . 15)) (ETHERPACKET 272 (BITS . 15)) (ETHERPACKET 273 (BITS . 15)) (ETHERPACKET 274 (BITS . 15)) (ETHERPACKET 275 (BITS . 15)) (ETHERPACKET 276 (BITS . 15)) (ETHERPACKET 277 (BITS . 15)) (ETHERPACKET 278 (BITS . 15)) (ETHERPACKET 279 (BITS . 15)) (ETHERPACKET 280 (BITS . 15)) (ETHERPACKET 281 (BITS . 15)) (ETHERPACKET 282 (BITS . 15)) (ETHERPACKET 283 (BITS . 15)) (ETHERPACKET 284 (BITS . 15)) (ETHERPACKET 285 (BITS . 15)) (ETHERPACKET 286 (BITS . 15)) (ETHERPACKET 287 (BITS . 15)) (ETHERPACKET 288 (BITS . 15)) (ETHERPACKET 289 (BITS . 15)) (ETHERPACKET 290 (BITS . 15)) (ETHERPACKET 291 (BITS . 15)) (ETHERPACKET 292 (BITS . 15)) (ETHERPACKET 293 (BITS . 15)) (ETHERPACKET 294 (BITS . 15)) (ETHERPACKET 295 (BITS . 15)) (ETHERPACKET 296 (BITS . 15)) (ETHERPACKET 297 (BITS . 15)) (ETHERPACKET 298 (BITS . 15)) (ETHERPACKET 299 (BITS . 15)) (ETHERPACKET 300 (BITS . 15)) (ETHERPACKET 301 (BITS . 15)) (ETHERPACKET 302 (BITS . 15)) (ETHERPACKET 303 (BITS . 15)) (ETHERPACKET 304 (BITS . 15)) (ETHERPACKET 305 (BITS . 15)) (ETHERPACKET 306 (BITS . 15)) (ETHERPACKET 307 (BITS . 15)) (ETHERPACKET 308 (BITS . 15)) (ETHERPACKET 309 (BITS . 15)) (ETHERPACKET 310 (BITS . 15)) (ETHERPACKET 311 (BITS . 15)) (ETHERPACKET 312 (BITS . 15)) (ETHERPACKET 313 (BITS . 15)) (ETHERPACKET 314 (BITS . 15)) (ETHERPACKET 315 (BITS . 15)) (ETHERPACKET 316 (BITS . 15)) (ETHERPACKET 317 (BITS . 15)) (ETHERPACKET 318 (BITS . 15)) (ETHERPACKET 319 (BITS . 15)) (ETHERPACKET 320 (BITS . 15)) (ETHERPACKET 321 (BITS . 15)) (ETHERPACKET 322 (BITS . 15))) '324) (ADDTOVAR SYSTEMRECLST (DATATYPE ETHERPACKET ((NIL BYTE) (EPLINK POINTER) (EPFLAGS BYTE) (EPUSERFIELD POINTER) (NIL BYTE) (EPPLIST POINTER) (EPTRANSMITTING FLAG) (EPRECEIVING FLAG) (NIL BITS 6) (EPREQUEUE POINTER) (NIL BYTE) (EPSOCKET POINTER) (NIL BYTE) (EPNETWORK POINTER) (EPTYPE WORD) (NIL WORD) (EPTIMESTAMP FIXP) (EPREQUEUEFN POINTER) (NIL 4 WORD) (EPENCAPSULATION 8 WORD) (EPBODY 289 WORD))) ) (DEFINEQ (\ALLOCATE.ETHERPACKET [LAMBDA NIL (* bvm%: "14-Feb-85 21:58") (DECLARE (GLOBALVARS \NEWPACKETCOUNTER)) (PROG ((PACKET (\DEQUEUE \FREE.PACKET.QUEUE))) (RETURN (COND (PACKET (\CLEARWORDS (fetch XIPBASE of PACKET) (FOLDHI \XIPOVLEN BYTESPERWORD)) (* ;  "Clear the header. XIP header is the larger, so this clears for ether pups or xips") PACKET) (T (COND ((ILESSP (SETQ \NEWPACKETCOUNTER (SUB1 \NEWPACKETCOUNTER)) 0) (* ;  "GC doesn't happen often enough, so too many packets tend to get created") (RECLAIM) (SETQ \NEWPACKETCOUNTER 5))) (create ETHERPACKET]) (\RELEASE.ETHERPACKET [LAMBDA (EPKT) (* bvm%: " 3-MAR-83 15:14") (* ;; "Free an ETHERPACKET -- might want to let GC do it, but GC doesn't happen often enough") (\DTEST EPKT 'ETHERPACKET) (COND ([NOT (AND (ffetch EPTRANSMITTING of EPKT) (PROGN (freplace EPREQUEUE of EPKT with 'FREE) (ffetch EPTRANSMITTING of EPKT] (* ;; "Don't free it yet if it's still being transmitted. Test twice in case it finished while we were setting EPREQUEUE") [freplace EPREQUEUE of EPKT with (freplace EPUSERFIELD of EPKT with (freplace EPNETWORK of EPKT with (freplace EPPLIST of EPKT with (freplace EPSOCKET of EPKT with NIL] (\ENQUEUE \FREE.PACKET.QUEUE EPKT))) NIL]) (RELEASE.PUP [LAMBDA (PUP) (* bvm%: " 3-MAR-83 16:14") (\RELEASE.ETHERPACKET PUP]) (\FLUSH.PACKET.QUEUE [LAMBDA (QUEUE) (* bvm%: " 4-FEB-83 14:37") (* ;;; "Releases all packets in QUEUE and returns how many were flushed") (bind PACKET (CNT _ 0) while (SETQ PACKET (\DEQUEUE QUEUE)) do (\RELEASE.ETHERPACKET PACKET) (add CNT 1]) (\REQUEUE.ETHERPACKET [LAMBDA (PACKET) (* bvm%: " 3-MAR-83 15:14") (PROG ((REQUEUE (fetch EPREQUEUE of PACKET))) (SELECTQ REQUEUE ((NIL T)) (FREE (\RELEASE.ETHERPACKET PACKET)) (UNINTERRUPTABLY (COND ((type? SYSQUEUE REQUEUE) (\ENQUEUE REQUEUE PACKET))) (replace EPREQUEUE of PACKET with NIL))]) (\EP.PUT.AUX [LAMBDA (PKT KEY VAL) (* JonL " 8-JUL-82 21:45") (PROG ((PLIST (fetch EPPLIST of PKT)) A) [COND ((NULL (SETQ A (ASSOC KEY PLIST))) [COND ((NEQ KEY 'AUXPTR) ([LAMBDA (CELL) (PutUnboxed CELL VAL) (SETQ VAL CELL] (CREATECELL \FIXP] (push (fetch EPPLIST of PKT) (CONS KEY VAL))) ((EQ KEY 'AUXPTR) (RPLACD A VAL)) (T (PutUnboxed (CDR A) VAL) (SETQ VAL (CDR A] (RETURN VAL]) ) (RPAQ? \FREE.PACKET.QUEUE (NCREATE 'SYSQUEUE)) (RPAQ? \NEWPACKETCOUNTER 5) (/DECLAREDATATYPE 'NSADDRESS '(FIXP WORD WORD WORD WORD) '((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) (NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15))) '6) (RPAQ? \MY.NSHOSTNUMBER NIL) (RPAQ? \MY.NSNETNUMBER NIL) (RPAQ? \MY.NSADDRESS NIL) (RPAQ? *NSADDRESS-FORMAT* NIL) (CL:PROCLAIM '(CL:SPECIAL *NSADDRESS-FORMAT*)) (RPAQQ BROADCASTNSHOSTNUMBER (NSHOSTNUMBER 65535 65535 65535)) (DEFINEQ (\SETLOCALNSNUMBERS [LAMBDA (TYPE) (* bvm%: "14-Feb-85 00:38") [SETQ \MY.NSHOSTNUMBER (COND ((NEQ (LOGOR (fetch (IFPAGE NSHost0) of \InterfacePage) (fetch (IFPAGE NSHost1) of \InterfacePage) (fetch (IFPAGE NSHost2) of \InterfacePage)) 0) (create NSHOSTNUMBER NSHOST0 _ (fetch (IFPAGE NSHost0) of \InterfacePage) NSHOST1 _ (fetch (IFPAGE NSHost1) of \InterfacePage) NSHOST2 _ (fetch (IFPAGE NSHost2) of \InterfacePage))) (T (create NSHOSTNUMBER NSHOST0 _ 0 NSHOST1 _ 5349 NSHOST2 _ (\SERIALNUMBER] (SETQ \MY.NSNETNUMBER 0) (SETQ \MY.NSADDRESS (create NSADDRESS NSHNM0 _ (fetch NSHOST0 of \MY.NSHOSTNUMBER) NSHNM1 _ (fetch NSHOST1 of \MY.NSHOSTNUMBER) NSHNM2 _ (fetch NSHOST2 of \MY.NSHOSTNUMBER]) (\LOADNSADDRESS [LAMBDA (BASE A) (* JonL " 2-AUG-82 00:09") (PROG [(A (if (type? NSADDRESS A) then A else (create NSADDRESS] (\MOVENSADDRESSES BASE A) (RETURN A]) (\STORENSADDRESS [LAMBDA (BASE A) (* JonL " 2-AUG-82 00:11") (\MOVENSADDRESSES (\DTEST A 'NSADDRESS) BASE) A]) (\PRINTNSADDRESS [LAMBDA (BASE FILE) (* ; "Edited 13-Jan-88 12:44 by bvm") (LET [(\THISFILELINELENGTH (LET [(L (fetch (STREAM LINELENGTH) of (SETQ FILE (\GETSTREAM FILE 'OUTPUT] (SELECTC L (0 (* ; "Some default") \LINELENGTH) (MAX.SMALLP (* ; "Infinite") NIL) L] (DECLARE (SPECVARS \THISFILELINELENGTH)) (* ;  "Set up important printing variable, and call the internal printer") (\NSADDRESS.DEFPRINT BASE FILE) ""]) (\NSADDRESS.DEFPRINT [LAMBDA (BASE STREAM) (* ; "Edited 14-Jan-88 17:41 by bvm") (LET ((*PRINT-BASE* (if (EQ *NSADDRESS-FORMAT* :DECIMAL) then 10 else 8)) (SHARP "#") (NET (+ (CL:ASH (\GETBASE BASE 0) 16) (\GETBASE BASE 1))) (SOCKET (\GETBASE BASE 5)) HOST) (SELECTQ *NSADDRESS-FORMAT* ((:DECIMAL :OCTAL) (* ;  "Need to fetch whole 48-bit host number") (SETQ HOST (+ (CL:ASH (\GETBASE BASE 2) 32) (CL:ASH (\GETBASE BASE 3) 16) (\GETBASE BASE 4)))) NIL) [.SPACECHECK. STREAM (+ (if (< SOCKET 8) then (* ;  "Just one socket digit (plus 2 #'s)") 3 else (* ; "Allow up to 6 socket digits") 8) (SELECTQ *NSADDRESS-FORMAT* (:DECIMAL (+ (if (< NET 10000) then (* ;  "Numbers up to 9-999 all take this") 5 else (* ; "Numbers up to 2^32-1") 13) (if (NEQ 0 (\GETBASE BASE 2)) then (* ; "Numbers up to 2^48-1") 19 elseif (NEQ 0 (\GETBASE BASE 3)) then (* ; "Numbers up to 2^32-1") 13 else (* ; "Numbers up to 2^16-1") 6))) (+ (IQUOTIENT (+ (CL:INTEGER-LENGTH NET) 2) 3) (if HOST then (IQUOTIENT (+ (CL:INTEGER-LENGTH HOST) 2) 3) elseif (< (\GETBASE BASE 2) 8) then (* ; "Guess n.nnnnnn.nnnnnn") 15 else (* ; "Guess nnnnnn.nnnnnn.nnnnnn") 19] (if (EQ *NSADDRESS-FORMAT* :DECIMAL) then (if (EQ NET 0) then (* ; "Seems silly to print %"0-000%"") (PRIN3 "0" STREAM) else (\NSADDRESS.PRINT.DECIMAL NET STREAM)) (PRIN3 SHARP STREAM) (\NSADDRESS.PRINT.DECIMAL HOST STREAM) else (PRIN3 NET STREAM) (PRIN3 SHARP STREAM) (if HOST then (* ;  "OCTAL format prints host as one number") (PRIN3 HOST STREAM) else (PRIN3 (\GETBASE BASE 2) STREAM) (PRIN3 "." STREAM) (PRIN3 (\GETBASE BASE 3) STREAM) (PRIN3 "." STREAM) (PRIN3 (\GETBASE BASE 4) STREAM))) (PRIN3 SHARP STREAM) (if (NEQ SOCKET 0) then (* ; "Omit defaulted socket") (PRIN3 SOCKET STREAM)) T]) (\NSADDRESS.PRINT.DECIMAL [LAMBDA (NUM STREAM) (* ; "Edited 13-Jan-88 22:07 by bvm") (* ;; "Print NUM to STREAM in XNS Services decimal format: numbers are in decimal, separated by dashes every 3rd character. Must be at least one dash. Assumes caller bound *PRINT-BASE* to 10.") (while (> NUM 999) bind (ZERO _ "0") PIECES REM do (* ;  "Collect decimal pieces of the whole number") (CL:MULTIPLE-VALUE-SETQ (NUM REM) (CL:TRUNCATE NUM 1000)) (push PIECES REM) finally (if (NULL PIECES) then (* ;  "Less than 4-digit number, so pad with leading 0") (PRIN3 ZERO STREAM) else (PRIN3 NUM STREAM) (* ;  "Leading number need not be padded") (SETQ NUM (pop PIECES))) (do (PRIN3 "-" STREAM) (* ; "Start an internal component") (if (< NUM 100) then (* ; "Pad small numbers to 3 digits") (PRIN3 ZERO STREAM) (if (< NUM 10) then (PRIN3 ZERO STREAM))) (PRIN3 NUM STREAM) (if (NULL PIECES) then (* ; "Done") (RETURN) else (* ;  "Do another piece. Awkward control structure reduces consing for small numbers") (SETQ NUM (pop PIECES]) (\LOADNSHOSTNUMBER [LAMBDA (BASE OLDBOX) (* bvm%: "17-FEB-83 17:07") (COND ((NULL OLDBOX) (create NSHOSTNUMBER NSHOST0 _ (\GETBASE BASE 0) NSHOST1 _ (\GETBASE BASE 1) NSHOST2 _ (\GETBASE BASE 2))) ((type? NSHOSTNUMBER OLDBOX) (replace NSHOST0 of OLDBOX with (\GETBASE BASE 0)) (replace NSHOST1 of OLDBOX with (\GETBASE BASE 1)) (replace NSHOST2 of OLDBOX with (\GETBASE BASE 2)) OLDBOX) (T (ERROR "ARG NOT NSHOSTNUMBER" OLDBOX]) (\STORENSHOSTNUMBER [LAMBDA (BASE NSHNM) (* bvm%: "17-FEB-83 17:07") (COND ((type? NSHOSTNUMBER NSHNM) (\PUTBASE BASE 0 (fetch NSHOST0 of NSHNM)) (\PUTBASE BASE 1 (fetch NSHOST1 of NSHNM)) (\PUTBASE BASE 2 (fetch NSHOST2 of NSHNM))) (T (ERROR "ARG NOT NSHOSTNUMBER" NSHNM))) NSHNM]) (PRINTNSHOSTNUMBER [LAMBDA (NSHOSTNUMBER FILE) (* bvm%: "24-Apr-86 16:16") (printout FILE .I1.8 (fetch NSHOST0 of NSHOSTNUMBER) "." .I1.8 (fetch NSHOST1 of NSHOSTNUMBER) "." .I1.8 (fetch NSHOST2 of NSHOSTNUMBER]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (DEFPRINT 'NSADDRESS '\NSADDRESS.DEFPRINT) ) (* ; "Assorted Level 0") (DEFINEQ (\ETHERINIT [LAMBDA NIL (* ; "Edited 13-Jan-88 14:37 by bvm") (* ;;; "This gets us EVENT action to take care of pup stuff around LOGOUT, etc.") (MOVD '\RELEASE.ETHERPACKET 'RELEASE.PUP NIL T) (MOVD '\ALLOCATE.ETHERPACKET 'ALLOCATE.PUP NIL T) (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ 'ETHER EVENTFN _ (FUNCTION \ETHEREVENTFN) DIRECTORYNAMEP _ 'NILL HOSTNAMEP _ 'NILL]) (\ETHEREVENTFN [LAMBDA (DEV EVENT) (* ; "Edited 15-Jan-88 01:30 by bvm") (SELECTQ EVENT ((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM RESTART) (PROG (NDB TURNOFFNS TIMESET) (SETQ \PUP.READY (SETQ \NS.READY (SETQ \IP.READY))) (\SETETHERFLAGS) (\SETLOCALNSNUMBERS) (\FLUSHNDBS EVENT) [SETQ \3MBLOCALNDB (COND (\3MBFLG (SETQ \LOCALNDBS (\3MB.CREATENDB \3MBFLG] (SETQ \10MBLOCALNDB (COND (\10MBFLG (SETQ NDB (\10MB.CREATENDB \10MBFLG)) (COND (\LOCALNDBS (replace NDBNEXT of \LOCALNDBS with NDB)) (T (SETQ \LOCALNDBS NDB))) NDB))) [for (DB _ \LOCALNDBS) by (fetch NDBNEXT of DB) while DB do (\LOCKWORDS DB (fetch DTDSIZE of (\GETDTD (NTYPX DB] [COND ((OR \NSFLG (SETQ TURNOFFNS \10MBFLG)) (* ;; "Start NS before Pup so that when on 10 we can find out our pup number, which is done via NS protocol") (\NSINIT EVENT) (SETQ TIMESET (\NS.SETTIME] (\STARTPUP EVENT) (OR TIMESET (AND (EQ \PUP.READY T) (\PUP.SETTIME)) [SELECTC \MACHINETYPE (\DANDELION (NEQ 0 (fetch DLTODVALID of \IOPAGE))) (\DAYBREAK (\DoveMisc.TODValid)) (> (IDATE) (CONSTANT (IDATE " 1-JAN-88 12:00"] (\TIME.NOT.SET)) (COND (TURNOFFNS (STOPNS))) (COND (\GATEWAYFLG (\INIT.GATEWAY))) (for FN in RESTARTETHERFNS do (CL:FUNCALL FN EVENT)) T)) ((BEFOREMAKESYS BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM) (COND ((EQ EVENT 'BEFORESAVEVM) (* ;  "Save passwords in place outside vmem to avoid having to reenter them later") (\STASH.PASSWORDS)) (T (* ;  "No need to flush this before SAVEVM") (CLRHASH \ETHERPORTS))) (CLRHASH LOGINPASSWORDS)) NIL]) (\TIME.NOT.SET [LAMBDA NIL (* ; "Edited 13-Jan-88 14:40 by bvm") (* ;; "Called at startup if we fail to set the time. Separate function so you can redefine it to do something interesting, like demand the time") (printout PROMPTWINDOW T "[Time not set]"]) (\SETETHERFLAGS [LAMBDA NIL (* ; "Edited 17-May-88 12:00 by bvm") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK \MAIKO) (SETQ \10MBFLG 0) (SETQ \3MBFLG NIL) (SETQ *MAXIMUM-PACKET-SIZE* (- (TIMES 2 BYTESPERPAGE) (UNFOLD (INDEXF (FETCH EPBODY)) BYTESPERWORD)))) (\DORADO (SETQ \3MBFLG T) (SETQ \10MBFLG NIL) (SETQ *MAXIMUM-PACKET-SIZE* (if (>= (fetch (IFPAGE BVersion) of \InterfacePage ) 11776) then (* ; "This field is valid") (fetch (IFPAGE MAXETHERBYTES) of \InterfacePage ) else (* ; "Old bcpl had this much") 590))) (SHOULDNT]) (\FLUSHNDBS [LAMBDA (EVENT) (* ; "Edited 15-Jan-88 00:30 by bvm") (bind NDB QUEUE while (SETQ NDB \LOCALNDBS) do (SETQ \LOCALNDBS (fetch NDBNEXT of NDB)) (replace NDBNEXT of NDB with NIL) (COND ((EQ EVENT 'RESTART) (CL:FUNCALL (fetch NDBETHERFLUSHER of NDB) NDB))) (DEL.PROCESS (fetch NDBWATCHER of NDB)) (replace NDBWATCHER of NDB with (replace NDBTRANSLATIONS of NDB with NIL)) (COND ((SETQ QUEUE (fetch NDBTQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT 'OUTPUT) (* ;; "Don't do this just yet, because of possible race in \PUPGATELISTENER --- (replace NDBTQ of NDB with NIL)") )) (COND ((SETQ QUEUE (fetch NDBIQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT 'INPUT) (replace NDBIQ of NDB with NIL]) (\FLUSH.NDB.QUEUE [LAMBDA (QUEUE EVENT USE) (* bvm%: " 8-JUL-83 18:10") (* ;;; "Release any packets on this QUEUE, and their IOCB's for USE if EVENT is RESTART") (bind PACKET IOCB while (SETQ PACKET (\DEQUEUE QUEUE)) do (COND ((AND (EQ EVENT 'RESTART) (SETQ IOCB (fetch EPNETWORK of PACKET))) (\RELEASE.IOCB IOCB USE))) (\RELEASE.ETHERPACKET PACKET]) ) (DEFINEQ (\CHECKSUM [LAMBDA (BASE NWORDS INITSUM) (* bvm%: "14-Feb-85 22:20") (PROG ((CHECKSUM (COND (INITSUM (LOGAND INITSUM MASKWORD1'S)) (T 0))) (ADDR BASE) (CNT NWORDS)) (while (IGREATERP CNT 0) do (* ;; "Algorithm: Do 1's complement add of next base word, then rotate sum left one. If result is all ones, then make it zero") (COND ([IGREATERP CHECKSUM (SETQ CHECKSUM (IPLUS16 CHECKSUM (\GETBASE ADDR 0] (* ;  "There was a carry, so add it back in -- 'end around carry'") (add CHECKSUM 1))) [SETQ CHECKSUM (COND ((IGREATERP CHECKSUM 32767) (LOGOR 1 (LLSH (LOGAND CHECKSUM 32767 ) 1))) (T (LLSH CHECKSUM 1] (* ; "ROT") (SETQ ADDR (\ADDBASE ADDR 1)) (SETQ CNT (SUB1 CNT))) (RETURN (COND ((EQ CHECKSUM MASKWORD1'S) 0) (T CHECKSUM]) (\HANDLE.RAW.OTHER [LAMBDA (PACKET RAWTYPE) (* bvm%: "15-FEB-83 18:30") [COND (XIPTRACEFLG (printout XIPTRACEFILE "Dropping packet of unknown encapsulation type: ") (COND (RAWTYPE (printout XIPTRACEFILE "[ = #" .I0.-8 RAWTYPE "]"] (\RELEASE.ETHERPACKET PACKET]) (\HANDLE.RAW.PACKET [LAMBDA (PACKET) (* bvm%: " 8-JUN-83 16:56") (OR (AND (OR (NOT \ETHERLIGHTNING) (NEQ (RAND 0 \ETHERLIGHTNING) 0)) (find FILTER in \PACKET.FILTERS bind (TYPE _ (fetch EPTYPE of PACKET )) suchthat (APPLY* FILTER PACKET TYPE))) (\RELEASE.ETHERPACKET PACKET]) (\ADD.PACKET.FILTER [LAMBDA (FILTER) (* bvm%: "17-FEB-83 15:17") (OR (FMEMB FILTER \PACKET.FILTERS) (SETQ \PACKET.FILTERS (NCONC1 \PACKET.FILTERS FILTER))) FILTER]) (\DEL.PACKET.FILTER [LAMBDA (FILTER) (* bvm%: "17-FEB-83 15:18") (COND ((FMEMB FILTER \PACKET.FILTERS) (SETQ \PACKET.FILTERS (DREMOVE FILTER \PACKET.FILTERS)) T]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RPAQQ \NULLCHECKSUM 65535) (CONSTANTS (\NULLCHECKSUM 65535)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PACKET.FILTERS \ETHERLIGHTNING RESTARTETHERFNS) ) ) (RPAQ? \PACKET.FILTERS NIL) (RPAQ? \ETHERLIGHTNING ) (RPAQ? RESTARTETHERFNS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\ETHERINIT) (MOVD? 'NILL 'BLOCK) (MOVD? 'NILL '\STASH.PASSWORDS) ) (* ; "Assorted routing stuff") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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)) ) (/DECLAREDATATYPE 'NDB '(BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((NDB 0 (BITS . 7)) (NDB 2 POINTER) (NDB 1 (BITS . 7)) (NDB 4 POINTER) (NDB 1 (BITS . 135)) (NDB 6 POINTER) (NDB 0 (BITS . 135)) (NDB 8 POINTER) (NDB 10 (BITS . 7)) (NDB 12 POINTER) (NDB 14 POINTER) (NDB 11 (BITS . 7)) (NDB 16 POINTER) (NDB 18 POINTER) (NDB 20 POINTER) (NDB 22 POINTER) (NDB 24 POINTER) (NDB 26 POINTER) (NDB 28 POINTER) (NDB 30 POINTER) (NDB 32 (BITS . 15)) (NDB 33 (BITS . 15)) (NDB 34 POINTER)) '36) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ \RT.INFINITY 16) (CONSTANTS \RT.INFINITY) ) (DECLARE%: EVAL@COMPILE (PUTPROPS ENCAPSULATE.ETHERPACKET MACRO ((NDB PACKET HOST LENGTH TYPE) (SPREADAPPLY* (fetch NDBENCAPSULATOR of NDB) NDB PACKET HOST LENGTH TYPE))) (PUTPROPS TRANSMIT.ETHERPACKET MACRO ((NDB PACKET) (SPREADAPPLY* (fetch NDBTRANSMITTER of NDB) NDB PACKET))) [PUTPROPS BROADCASTP MACRO ((PACKET) ([LAMBDA (NDB) (AND NDB (APPLY* (fetch NDBBROADCASTP of NDB) PACKET NDB] (fetch EPNETWORK of PACKET] [PUTPROPS \CHECK.ROUTING.TABLE MACRO ((TABLE) (if (NEQ (NTYPX TABLE) \ROUTING.TABLE.TYPENUM) then (CL:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :CULPRIT TABLE :EXPECTED-TYPE 'RoutingTable] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \RT.TIMEOUTINTERVAL \RT.AGEINTERVAL \RT.PURGEFLG \GATEWAYFLG \ROUTING.TABLE.MASK \ROUTING.TABLE.TYPENUM) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \3MBFLG \10MBFLG \3MBLOCALNDB \10MBLOCALNDB \LOCALNDBS \NSFLG \IPFLG \NS.ROUTING.TABLE \PUP.ROUTING.TABLE \NS.READY \PUP.READY \IP.READY) ) ) (/DECLAREDATATYPE 'NDB '(BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER BYTE POINTER POINTER BYTE POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER) '((NDB 0 (BITS . 7)) (NDB 2 POINTER) (NDB 1 (BITS . 7)) (NDB 4 POINTER) (NDB 1 (BITS . 135)) (NDB 6 POINTER) (NDB 0 (BITS . 135)) (NDB 8 POINTER) (NDB 10 (BITS . 7)) (NDB 12 POINTER) (NDB 14 POINTER) (NDB 11 (BITS . 7)) (NDB 16 POINTER) (NDB 18 POINTER) (NDB 20 POINTER) (NDB 22 POINTER) (NDB 24 POINTER) (NDB 26 POINTER) (NDB 28 POINTER) (NDB 30 POINTER) (NDB 32 (BITS . 15)) (NDB 33 (BITS . 15)) (NDB 34 POINTER)) '36) (ADDTOVAR SYSTEMRECLST (DATATYPE NDB ((NETTYPE BYTE) (NDBNEXT POINTER) (NDBPUPNET# BYTE) (NDBNSNET# POINTER) (NDBTASK# BYTE) (NDBBROADCASTP POINTER) (NDBPUPHOST# BYTE) (NDBTRANSMITTER POINTER) (NIL BYTE) (NDBENCAPSULATOR POINTER) (NDBCSB POINTER) (NDBIQLENGTH BYTE) (NDBIQ POINTER) (NDBTQ POINTER) (NDBTRANSLATIONS POINTER) (NDBETHERFLUSHER POINTER) (NDBWATCHER POINTER) (NDBCANHEARSELF POINTER) (NDBIPNET# POINTER) (NDBIPHOST# POINTER) (NDBPUPTYPE WORD) (NIL WORD) (NIL POINTER))) ) (DEFINEQ (ENCAPSULATE.ETHERPACKET [LAMBDA (NDB PACKET PDH NBYTES ETYPE) (* bvm%: "10-JUN-83 12:11") (APPLY* (ffetch NDBENCAPSULATOR of (\DTEST NDB 'NDB)) NDB (\DTEST PACKET 'ETHERPACKET) PDH NBYTES ETYPE]) (TRANSMIT.ETHERPACKET [LAMBDA (NDB PACKET) (* bvm%: "10-JUN-83 12:15") (APPLY* (ffetch NDBTRANSMITTER of (\DTEST NDB 'NDB)) NDB (\DTEST PACKET 'ETHERPACKET]) ) (* ;; "Routing table management. Table is naked array of specified size (choices are 8, 16, 32, 64, based on availability of pointer hunks for those sizes). These are global vars rather than constants so you can play with them (but you'd better restart ether immediately)." ) (DEFINEQ (\AGE.ROUTING.TABLE [LAMBDA (TABLE) (* ; "Edited 14-Jan-88 23:37 by bvm") (* ;; "Call this every now and then to age the entries in a routing table.") (LET (ENTRY BUCKET) (\CHECK.ROUTING.TABLE TABLE) (for I from 0 to \ROUTING.TABLE.MASK do (* ;  "Walk down %"hash%" table, scanning each bucket for entries that have expired") [if (SETQ BUCKET (\GETBASEPTR TABLE 0)) then (for (TAIL _ BUCKET) by (CDR TAIL) while TAIL bind PURGED when (AND (NEQ (fetch RTHOPCOUNT of (SETQ ENTRY (CAR TAIL))) 0) (TIMEREXPIRED? (fetch RTTIMER of ENTRY))) do (* ; "Entry has timed out") (COND ((fetch RTRECENT of ENTRY) (* ; "New entry, make it old") (replace RTRECENT of ENTRY with NIL) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY))) (\RT.PURGEFLG (* ; "Purge old entry") (RPLACA TAIL NIL) (SETQ PURGED T))) finally (if PURGED then (\RPLPTR TABLE 0 (DREMOVE NIL BUCKET] (SETQ TABLE (\ADDBASE TABLE WORDSPERCELL]) (\ADD.ROUTING.TABLE.ENTRY [LAMBDA (TABLE ENTRY) (* ; "Edited 14-Jan-88 23:33 by bvm") (* ;; "Add a new ENTRY to routing table TABLE. TABLE is a naked pointer array whose elements (%"buckets%") are lists of routing entries. Hash from the low bits of the net number to one of these buckets.") (\CHECK.ROUTING.TABLE TABLE) (SETQ TABLE (\ADDBASE TABLE (UNFOLD (LOGAND (fetch RTNET# of ENTRY) \ROUTING.TABLE.MASK) WORDSPERCELL))) (* ; "Compute bucket location") (\RPLPTR TABLE 0 (CONS ENTRY (\GETBASEPTR TABLE 0))) ENTRY]) (\CLEAR.ROUTING.TABLE [LAMBDA (OLDTABLE) (* ; "Edited 14-Jan-88 23:56 by bvm") (* ;; "Restore OLDTABLE to virgin state, or create a fresh one") (if (AND OLDTABLE (EQ (NTYPX OLDTABLE) \ROUTING.TABLE.TYPENUM)) then (* ;  "Clear old table. Second clause checks that someone didn't change the size on us.") (for I from 0 to \ROUTING.TABLE.MASK as (BASE _ OLDTABLE) by (\ADDBASE BASE WORDSPERCELL) do (\RPLPTR BASE 0 NIL)) OLDTABLE else (\CREATECELL \ROUTING.TABLE.TYPENUM]) (\MAP.ROUTING.TABLE [LAMBDA (TABLE MAPFN) (* ; "Edited 14-Jan-88 23:47 by bvm") (* ;; "Call MAPFN for each routing info entry in TABLE. We permit MAPFN to remove the entry.") (\CHECK.ROUTING.TABLE TABLE) (for I from 0 to \ROUTING.TABLE.MASK as (BASE _ TABLE) by (\ADDBASE BASE WORDSPERCELL) do (for ENTRY in (APPEND (\GETBASEPTR BASE 0)) do (CL:FUNCALL MAPFN ENTRY]) (PRINTROUTINGTABLE [LAMBDA (TABLE SORTFLG FILE) (* ; "Edited 15-Jan-88 02:41 by bvm") (SELECTQ TABLE (NS (SETQ TABLE \NS.ROUTING.TABLE)) ((NIL PUP) (SETQ TABLE \PUP.ROUTING.TABLE)) NIL) (\CHECK.ROUTING.TABLE TABLE) (SETQ FILE (\GETSTREAM FILE 'OUTPUT)) (LET ([ENTRIES (for I from 0 to \ROUTING.TABLE.MASK as (BASE _ TABLE) by (\ADDBASE BASE WORDSPERCELL) join (APPEND (\GETBASEPTR BASE 0] [TB (if \10MBLOCALNDB then (* ;; "There is at least one 10mb net on this machine, so gateways can be ns addresses, so leave lots of space. Longest ns address is 0#177777.177777.177777# = 23 chars") (CONSTANT (+ 7 2 (NCHARS "0#177777.177777.177777#") 2)) else (* ;  "Gateways are pup numbers, max 3 digits, but we'll be generous and use 5") (CONSTANT (+ 2 (NCHARS " Net# Gateway "] (DECP (AND (EQ TABLE \NS.ROUTING.TABLE) (EQ *NSADDRESS-FORMAT* :DECIMAL))) GATE NET) (printout FILE " Net#" .CENTER (- TB 2) "Gateway" .TAB (- TB 2) "#Hops Recent?" T) (for ENTRY in (COND (SORTFLG (SORT ENTRIES (if (EQ SORTFLG :HOPS) then (* ; "Sort by hops") [FUNCTION (LAMBDA (X Y) (< (fetch RTHOPCOUNT of X) (fetch RTHOPCOUNT of Y] else (* ; "Sort by net, which is car") T))) (T ENTRIES)) do (SETQ NET (fetch RTNET# of ENTRY)) (if DECP then (SPACES (- 7 (IMAX 4 (NCHARS NET))) FILE) (* ; "Right-justify nets that are shorter than 7 chars in decimal rep. Everything is at least as long as 0-nnn.") (\NSADDRESS.PRINT.DECIMAL NET FILE) else (printout FILE .I7.8 NET)) (COND ((NOT (SETQ GATE (fetch RTGATEWAY# of ENTRY))) (SPACES 4 FILE) (PRIN1 "---" FILE)) ((FIXP GATE) (printout FILE .I7.8 GATE)) (T (SPACES 2 FILE) (PRIN3 GATE FILE))) (printout FILE .TAB TB .I2 (fetch RTHOPCOUNT of ENTRY) (COND ((fetch RTRECENT of ENTRY) " Yes") ((TIMEREXPIRED? (fetch RTTIMER of ENTRY)) " timed out") (T " No")) T))) (TERPRI FILE]) (\ROUTINGTABLE.INFOHOOK [LAMBDA (PROC BUTTON) (* ; "Edited 15-Jan-88 03:08 by bvm") (* ;; "Info hook for gate listener processes. Displays routing table in a window. We keep track of the window so as to reuse it.") (LET ((TYPE (PROCESSPROP PROC :PROTOCOL)) (WINDOW (PROCESSPROP PROC :WINDOW)) (TEDITP (GETD 'OPENTEXTSTREAM)) (FONT (FONTCREATE 'GACHA 8)) TABLE STREAM NUMENTRIES) (SETQ NUMENTRIES (if (SETQ TABLE (SELECTQ TYPE (NS \NS.ROUTING.TABLE) (PUP \PUP.ROUTING.TABLE) NIL)) then (\CHECK.ROUTING.TABLE TABLE) (for I from 0 to \ROUTING.TABLE.MASK as (BASE _ TABLE) by (\ADDBASE BASE WORDSPERCELL) sum (LENGTH (\GETBASEPTR BASE 0))) else (* ; "Some other protocol?") 99)) (if (NOT WINDOW) then [PROCESSPROP PROC :WINDOW (SETQ WINDOW (CREATEW (GETBOXREGION (WIDTHIFWINDOW (TIMES (CHARWIDTH (CHARCODE X) FONT) (if \10MBLOCALNDB then (* ;  "Let it get wide--see PRINTROUTINGTABLE") 50 else 36))) (HEIGHTIFWINDOW (TIMES (FONTPROP FONT 'HEIGHT) (IMIN (ADD1 NUMENTRIES ) (if TEDITP then (* ;  "Doesn't have to be very tall, since we can scroll") 30 else 40))) T)) (CONCAT TYPE " Routing Info"] (WINDOWPROP WINDOW :NAME (PROCESSPROP PROC 'NAME)) (* ;  "Save process by name to avoid worrying about circular links") [WINDOWADDPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (* ;  "Forget the window once it's closed") (PROCESSPROP (WINDOWPROP WINDOW :NAME) :WINDOW NIL] else (CLEARW WINDOW)) [PRINTROUTINGTABLE TYPE (EQ BUTTON 'MIDDLE) (SETQ STREAM (if TEDITP then (* ;  "Faster to write to a core file first") (OPENSTREAM '{NODIRCORE} 'BOTH) else (* ; "Write straight to the window") (DSPFONT FONT WINDOW) (WINDOWPROP WINDOW 'DSP] (if TEDITP then (OPENTEXTSTREAM STREAM WINDOW NIL NIL `(FONT ,FONT READONLY T]) ) (RPAQ? \RT.TIMEOUTINTERVAL 90000) (RPAQ? \RT.AGEINTERVAL 30000) (RPAQ? \RT.PURGEFLG T) (RPAQ? \GATEWAYFLG NIL) (RPAQ? \ROUTING.TABLE.MASK 31) (RPAQ? \ROUTING.TABLE.TYPENUM (\TYPENUMBERFROMNAME (PACK* "\PTRHUNK" (ADD1 \ROUTING.TABLE.MASK)))) (RPAQ? \3MBFLG T) (RPAQ? \10MBFLG ) (RPAQ? \3MBLOCALNDB ) (RPAQ? \10MBLOCALNDB ) (RPAQ? \LOCALNDBS ) (RPAQ? \NSFLG ) (RPAQ? \IPFLG ) (* ; "10 to 3 translation ugliness") (DEFINEQ (\TRANSLATE.10TO3 [LAMBDA (NSADDR NDB) (* ; "Edited 14-Jan-88 19:40 by bvm") (* ;; "Translate from an NSADDR 48-bit address to a PUP host number for the indicated network. If we don't have the translation, we initiate a probe for it and return NIL") (for TRANS in (ffetch NDBTRANSLATIONS of (\DTEST NDB 'NDB)) when (EQNSADDRESS.HOST NSADDR (CAR TRANS)) do (* ; "translation already in cache") (RETURN (CADR TRANS)) finally (* ;;  "Initiate a probe, and return failure for now. Next call may find it in the cache") (LET ((PACKET (\ALLOCATE.ETHERPACKET))) (replace EPTYPE of PACKET with \EPT.10TO3) (freplace TRANSOPERATION of PACKET with \TRANS.OP.REQUEST) (\BLT (LOCF (FETCH BASETRANSNSHOST of PACKET)) (LOCF (FETCH NSHNM0 OF NSADDR)) 3) (\BLT (LOCF (FETCH BASETRANSSENDERNSHOST of PACKET)) (LOCF (FETCH NSHNM0 OF \MY.NSADDRESS)) 3) (freplace TRANSSENDERPUPHOST of PACKET with (ffetch NDBPUPHOST# of NDB)) (ENCAPSULATE.ETHERPACKET NDB PACKET 0 \TRANS.DATALENGTH \EPT.10TO3) (AND XIPTRACEFLG (\MAYBEPRINTPACKET PACKET 'PUT)) (freplace EPREQUEUE of PACKET with 'FREE) (TRANSMIT.ETHERPACKET NDB PACKET)) (RETURN NIL]) (\NOTE.10TO3 [LAMBDA (NSADDR PUPADDRESS NDB) (* ; "Edited 14-Jan-88 19:40 by bvm") (* ;  "Update cache to include this pairing") (for TRANS in (ffetch NDBTRANSLATIONS of (\DTEST NDB 'NDB)) bind (HOST _ (fetch PUPHOST# of PUPADDRESS)) when (EQNSADDRESS.HOST NSADDR (CAR TRANS)) do (* ;  "translation already in cache--update it") (RETURN (RPLACA (CDR TRANS) HOST)) finally (* ; "Add a new translation to cache") (LET ((BOX (create NSADDRESS))) (* ;  "Copy address into an NSADDRESS object") (\BLT (LOCF (FETCH NSHNM0 OF BOX)) (LOCF (FETCH NSHNM0 OF NSADDR)) 3) (push (ffetch NDBTRANSLATIONS of NDB) (LIST BOX HOST (CLOCK 0]) (\HANDLE.RAW.10TO3 [LAMBDA (PACKET TYPE) (* ; "Edited 15-Jan-88 00:47 by bvm") (* ;; "Called when a TRANSLATION packet is received. This is either a packet requesting a 10-to-3 translation, in which case we respond if it is asking about us; or it is a response to a request of ours, in which case we store the info in the cache") (COND ((EQ TYPE \EPT.10TO3) (PROG ((NDB (fetch EPNETWORK of PACKET))) (AND XIPTRACEFLG (\MAYBEPRINTPACKET PACKET 'GET)) [SELECTC (fetch TRANSOPERATION of PACKET) (\TRANS.OP.REQUEST (COND ([AND (EQNSADDRESS.HOST (fetch TRANSNSADDRESS of PACKET) \MY.NSADDRESS) (>= (fetch 3MBLENGTH of PACKET) (+ \3MBENCAPSULATION.WORDS (FOLDHI \TRANS.DATALENGTH BYTESPERWORD ] (* ;  "It's for us, and it's big enough") (\NOTE.10TO3 (fetch TRANSSENDERNSADDRESS of PACKET) (fetch TRANSSENDERPUPHOST of PACKET) NDB) (* ; "Add sender's address to cache") (replace TRANSPUPHOST of PACKET with (fetch NDBPUPHOST# of NDB)) (* ; "Add in the information he wants") (replace TRANSOPERATION of PACKET with \TRANS.OP.RESPONSE) (ENCAPSULATE.ETHERPACKET NDB PACKET (fetch TRANSSENDERPUPHOST of PACKET) \TRANS.DATALENGTH \EPT.10TO3) (* ; "Send back the response") (AND XIPTRACEFLG (NOT (MEMB 'TRANS XIPIGNORETYPES)) (PRINT10TO3 PACKET 'PUT XIPTRACEFILE)) (replace EPREQUEUE of PACKET with 'FREE) (TRANSMIT.ETHERPACKET NDB PACKET) (RETURN)))) (\TRANS.OP.RESPONSE (* ;  "Add the information to the cache") (\NOTE.10TO3 (fetch TRANSNSADDRESS of PACKET) (fetch TRANSPUPHOST of PACKET) NDB)) (COND (XIPTRACEFLG (printout XIPTRACEFILE "Bad 10:3 operation: " (fetch TRANSOPERATION of PACKET) T] (\RELEASE.ETHERPACKET PACKET)) T]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS ETHERTRANS [(TRANSBODY (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD TRANSBODY ((TRANSOPERATION WORD) (* ; "Request or response") (BASETRANSNSHOST 3 WORD) (* ; "Known or desired NS address") (TRANSPUPHOST BYTE) (* ; "Known or desired PUP address") (NIL BYTE) (* ; "Padding") (BASETRANSSENDERNSHOST 3 WORD) (* ; "Sender's info") (TRANSSENDERPUPHOST BYTE) (NIL BYTE)) [ACCESSFNS BASETRANSNSHOST ((TRANSNSHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] (ACCESSFNS BASETRANSSENDERNSHOST ((TRANSSENDERNSHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] [ACCESSFNS ETHERTRANS ([TRANSNSADDRESS (PROGN (* ;  "Kludge to get a pointer that looks like a full ns address") (\ADDBASE DATUM (CONSTANT (+ (INDEXF (FETCH (ETHERPACKET EPBODY) of T)) (INDEXF (FETCH (ETHERTRANS BASETRANSNSHOST ) of T)) -2] (TRANSSENDERNSADDRESS (\ADDBASE DATUM (CONSTANT (+ (INDEXF (FETCH (ETHERPACKET EPBODY) of T)) (INDEXF (FETCH (ETHERTRANS BASETRANSSENDERNSHOST ) of T)) -2] (TYPE? (type? ETHERPACKET DATUM))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TRANS.OP.REQUEST 4161) (RPAQQ \TRANS.OP.RESPONSE 3640) (RPAQQ \TRANS.DATALENGTH 18) (CONSTANTS \TRANS.OP.REQUEST \TRANS.OP.RESPONSE \TRANS.DATALENGTH) ) ) (* ; "Printing routines for packets") (DEFINEQ (PRINTPACKET [LAMBDA (PACKET CALLER FILE PRE.NOTE DOFILTER) (* bvm%: "18-FEB-83 15:25") (PROG ((TYPE (fetch EPTYPE of PACKET)) FN) [COND ((SETQ FN (CDR (FASSOC TYPE \PACKET.PRINTERS))) (RETURN (APPLY* FN PACKET CALLER FILE PRE.NOTE DOFILTER] (OR FILE (SETQ FILE XIPTRACEFILE)) (AND PRE.NOTE (printout FILE T PRE.NOTE)) (AND CALLER (printout FILE CALLER ": ")) (printout FILE "Unknown ether packet type: " TYPE T) (RETURN PACKET]) (\MAYBEPRINTPACKET [LAMBDA (PACKET CALLER FILE PRE.NOTE) (* ; "Edited 3-May-91 17:10 by jds") (PROG ((TYPE (fetch EPTYPE of PACKET)) NDB) (SELECTQ (SELECTC TYPE (\EPT.PUP PUPTRACEFLG) XIPTRACEFLG) (NIL) (PEEK (PRIN1 (SELECTQ CALLER ((GET RAWGET) (COND ((BROADCASTP PACKET) '*) (T '+))) ((PUT RAWPUT) (COND ((BROADCASTP PACKET) '^) (T '!))) '?) (OR FILE (SELECTC TYPE (\EPT.PUP PUPTRACEFILE) XIPTRACEFILE)))) (RAW [SELECTQ CALLER ((RAWGET RAWPUT) (PRINTPACKET PACKET CALLER FILE PRE.NOTE T)) (PRIN1 (SELECTQ CALLER (GET '%#) (PUT '^) '?) (OR FILE (SELECTC TYPE (\EPT.PUP PUPTRACEFILE) XIPTRACEFILE]) (PROGN (PRINTPACKET PACKET CALLER FILE PRE.NOTE T) (BLOCK]) (PRINT10TO3 [LAMBDA (EPKT CALLER FILE PRE.NOTE DOFILTER) (* bvm%: "14-Feb-85 00:38") (COND ((OR (NOT DOFILTER) (NOT (MEMB 'TRANS XIPIGNORETYPES))) (OR FILE (SETQ FILE XIPTRACEFILE)) (FRESHLINE FILE) (COND (PRE.NOTE (PRIN1 PRE.NOTE FILE))) (SELECTC (fetch TRANSOPERATION of EPKT) (\TRANS.OP.REQUEST (printout FILE CALLER " 10:3 trans request for ") (PRINTNSHOSTNUMBER (fetch TRANSNSHOST of EPKT) FILE) (printout FILE " from ") (PRINTNSHOSTNUMBER (fetch TRANSSENDERNSHOST of EPKT) FILE) (printout FILE " = " (fetch TRANSSENDERPUPHOST of EPKT) T)) (\TRANS.OP.RESPONSE (printout FILE CALLER " 10:3 trans response: ") (PRINTNSHOSTNUMBER (fetch TRANSNSHOST of EPKT) FILE) (printout FILE " = " (fetch TRANSPUPHOST of EPKT) T)) (printout FILE CALLER " unknown 10 to 3 translation operation " (fetch TRANSOPERATION of EPKT) T]) (PRINTPACKETDATA [LAMBDA (BASE OFFSET MACRO LENGTH FILE) (* bvm%: "26-MAY-83 12:27") (* ;;; "Prints to FILE the data portion of a packet starting at byte OFFSET (default zero) of BASE for LENGTH bytes according to MACRO. MACRO contains elements describing what format the data is in:") (* ;;; "WORDS, BYTES, CHARS: print as words, numeric bytes or ascii characters ") (* ;;; "IFSSTRING: data is a string whose length is in the first two bytes") (* ;;; ": subsequent commands apply starting at this byte offset") (* ;;; ": commands apply for the next {magnitude} bytes") (* ;;; "...: print ... and quit if you still have data at this point") (* ;;; "REPEAT: rest of macro should be applied repeatedly until data exhausted") (* ;;; "T: end of line") (* ;;; "SEPR: separate items (other than CHARS) with next token") (* ;;; "FINALLY: print next token when you get to the end") (OR OFFSET (SETQ OFFSET 0)) (bind CHAR TMP FINALPRINT REPEATMACRO (SEPR _ ", ") (TILOFFSET _ 0) (DATATYPE _ 'WORDS) (STREAM _ (GETSTREAM FILE 'OUTPUT)) while (ILESSP OFFSET LENGTH) do (while (AND (OR MACRO (SETQ MACRO REPEATMACRO)) (IGEQ OFFSET TILOFFSET)) do [SELECTQ (CAR MACRO) ((WORDS BYTES CHARS INTEGERS) (SETQ DATATYPE (CAR MACRO))) ((WORD BYTE CHAR INTEGER) (SETQ DATATYPE (PACK* (CAR MACRO) 'S))) (IFSSTRING (* ;  "Hack. Data is assumed to be a string whose first word is its length. For Leaf") (SETQ TMP (\GETBASE BASE (FOLDLO OFFSET BYTESPERWORD))) (printout STREAM '{ .P2 TMP '}) (add OFFSET 2) (SETQ TILOFFSET (CEIL (IPLUS OFFSET TMP) BYTESPERWORD)) [COND ((NEQ DATATYPE 'BYTES) (SETQ DATATYPE 'CHARS]) (|...| (PRIN1 '|...| STREAM) (SETQ DATATYPE (SETQ MACRO))) (REPEAT (SETQ REPEATMACRO (CDR MACRO))) (SEPR (SETQ SEPR (CADR MACRO)) (SETQ MACRO (CDR MACRO))) (FINALLY [SETQ FINALPRINT (CAR (SETQ MACRO (CDR MACRO]) (T (TERPRI STREAM)) (COND [(FIXP (CAR MACRO)) (SETQ TILOFFSET (COND ((IGEQ (CAR MACRO) 0) (CAR MACRO)) (T (* ; "Relative") (IDIFFERENCE OFFSET (CAR MACRO] (T (PRIN1 (CAR MACRO) STREAM] (SETQ MACRO (CDR MACRO))) (SELECTQ DATATYPE (WORDS (PRIN2 (\GETBASE BASE (FOLDLO OFFSET BYTESPERWORD)) STREAM) (add OFFSET 2) (COND ((AND SEPR (ILESSP OFFSET LENGTH)) (PRIN1 SEPR STREAM)))) (INTEGERS (PRIN2 (\MAKENUMBER (\GETBASE BASE (SETQ TMP (FOLDLO OFFSET BYTESPERWORD)) ) (\GETBASE BASE (ADD1 TMP))) STREAM) (add OFFSET 4) (COND ((AND SEPR (ILESSP OFFSET LENGTH)) (PRIN1 SEPR STREAM)))) (CHARS [COND ((AND (IGEQ (SETQ CHAR (\GETBASEBYTE BASE OFFSET)) (CHARCODE SPACE)) (ILESSP CHAR 127)) (\OUTCHAR STREAM CHAR)) ((AND (EQ CHAR (CHARCODE CR)) (IGREATERP LENGTH (ADD1 OFFSET)) (EQ (\GETBASEBYTE BASE (ADD1 OFFSET)) (CHARCODE LF))) (PRIN1 "[crlf]" STREAM) (add OFFSET 1)) (T (printout STREAM '%[ CHAR '%]] (add OFFSET 1)) (BYTES (printout STREAM '%[ (\GETBASEBYTE BASE OFFSET) '%]) (add OFFSET 1)) (RETURN)) finally (AND FINALPRINT (PRIN1 FINALPRINT STREAM))) (TERPRI FILE]) (PRINTPACKETQUEUE [LAMBDA (QUEUE CALLER FILE) (* bvm%: "21-APR-83 23:51") (for [PACKET _ (COND ((type? SYSQUEUE QUEUE) (fetch SYSQUEUEHEAD of QUEUE)) (T (\DTEST QUEUE 'ETHERPACKET] by (fetch EPLINK of PACKET) while PACKET do (PRINTPACKET PACKET CALLER FILE]) (TIME.SINCE.PACKET [LAMBDA (PACKET) (* bvm%: "26-OCT-83 15:46") (* ;; "Returns time in milliseconds since PACKET's EPTIMESTAMP was last set") (PROG ((CLK1 (\RCLK (\CREATECELL \FIXP))) (CLK0 (\CREATECELL \FIXP))) (\BLT CLK0 (LOCF (fetch EPTIMESTAMP of PACKET)) WORDSPERCELL) (RETURN (IQUOTIENT (\BOXIDIFFERENCE CLK1 CLK0) \RCLKMILLISECOND]) (MAKE-NETWORK-TRACE-WINDOW [LAMBDA (FLGVAR STREAMVAR TITLE REGION FLG) (* ; "Edited 14-Jan-88 18:06 by bvm") (* ;; "Create a window for controlling network tracing. FLGVAR and STREAMVAR are the variables controlling whether and where tracing occurs. TITLE and REGION are for creating the window, FLG is the initial value of FLGVAR (defaults to T) ") (LET (W DS) [if (WINDOWP (SETQ W (EVALV STREAMVAR))) then (SETQ DS (WINDOWPROP W 'DSP)) elseif [NOT (AND (DISPLAYSTREAMP W) (SETQ W (WFROMDS (SETQ DS W) T] then (SETQ DS (WINDOWPROP (SETQ W (CREATEW REGION TITLE)) 'DSP] (TOTOPW W) (WINDOWPROP W 'FLG&STREAM (CONS FLGVAR STREAMVAR)) [WINDOWPROP W 'BUTTONEVENTFN (FUNCTION (LAMBDA (WINDOW) (* ; "Left or middle changes state") (COND ((LASTMOUSESTATE (NOT UP)) (\CHANGE.ETHER.TRACING WINDOW (CAR (WINDOWPROP WINDOW 'FLG&STREAM] [WINDOWPROP W 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) (* ; "Closing turns off tracing") (DESTRUCTURING-BIND (FLG . STRM) (WINDOWPROP WINDOW 'FLG&STREAM) (COND ((EQ (WINDOWPROP WINDOW 'DSP) (EVALV STRM)) (SET FLG NIL) (SET STRM T] [WINDOWPROP W 'SHRINKFN (FUNCTION (LAMBDA (WINDOW) (* ;  "Turn off tracing while window shrunk") (DESTRUCTURING-BIND (FLG . STRM) (WINDOWPROP WINDOW 'FLG&STREAM) (COND ((EQ (WINDOWPROP WINDOW 'DSP) (EVALV STRM)) (WINDOWPROP WINDOW FLG (EVALV FLG)) (SET FLG NIL] [WINDOWPROP W 'EXPANDFN (FUNCTION (LAMBDA (WINDOW) (* ;  "Restore tracing to previous state") (DESTRUCTURING-BIND (FLG . STRM) (WINDOWPROP WINDOW 'FLG&STREAM) (COND ((EQ (WINDOWPROP WINDOW 'DSP) (EVALV STRM)) (SET FLG (WINDOWPROP WINDOW FLG NIL] (DSPFONT (FONTCREATE 'GACHA 8) DS) (DSPSCROLL T DS) (TOTOPW W) (SET STREAMVAR DS) (SET FLGVAR (OR FLG T]) (\CHANGE.ETHER.TRACING [LAMBDA (WINDOW FLGNAME) (* bvm%: "11-JUL-83 17:14") (printout WINDOW .TAB0 0 "[Tracing " (COND [(LASTMOUSESTATE LEFT) (SELECTQ (EVALV FLGNAME) (NIL (SET FLGNAME T) "On]") (T (SET FLGNAME 'PEEK) "Brief]") (COND ((OR (NOT \RAWTRACING) (EQ (EVALV FLGNAME) 'RAW)) (SET FLGNAME NIL) "Off]") (T (SET FLGNAME 'RAW) "only Raw]"] (T (COND (\RAWTRACING (SETQ \RAWTRACING NIL) "Raw Off]") (T (SETQ \RAWTRACING T) "Raw On]"]) ) (RPAQ? \RAWTRACING ) (ADDTOVAR \PACKET.PRINTERS (512 . PRINTPUP) (1537 . PRINT10TO3)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \RAWTRACING \PACKET.PRINTERS PUPTRACEFILE XIPTRACEFILE \RCLKMILLISECOND) ) (* ; "For PUP/XIPTRACETIME, functions to convert time from internal ticks to decimal fractions of a second." ) (DEFINEQ (\CENTICLOCK [LAMBDA (PACKET) (* bvm%: "26-OCT-83 15:42") (* ;;; "Returns a relative time in centiseconds. If PACKET is given, the time is a translation of its EPTIMESTAMP; otherwise the time is now") (PROG ((CLK \CENTICLOCKBOX)) (COND (PACKET (\BLT CLK (LOCF (fetch EPTIMESTAMP of PACKET)) WORDSPERCELL)) (T (\RCLK CLK))) (replace CENTICLOCKSIGNBIT of CLK with 0) (RETURN (IQUOTIENT CLK (OR \CENTICLOCKFACTOR (SETQ \CENTICLOCKFACTOR (ITIMES 10 \RCLKMILLISECOND ]) ) (RPAQQ \CENTICLOCKFACTOR NIL) (RPAQ \CENTICLOCKBOX (NCREATE 'FIXP)) (ADDTOVAR \SYSTEMCACHEVARS \CENTICLOCKFACTOR) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD CENTICLOCK ((CENTICLOCKSIGNBIT BITS 1) (CENTICLOCKMAGNITUDE BITS 31))) ) ) (* ; "3MB stuff, which is not needed in DandeLion") (DEFINEQ (\3MBGETPACKET [LAMBDA NIL (* bvm%: "26-OCT-83 15:16") (PROG (PACKET) (RETURN (COND ((UNINTERRUPTABLY (PROG ((PBI (\READRAWPBI))) [COND (PBI (SETQ PACKET (\ALLOCATE.ETHERPACKET)) (\BLT (fetch 3MBBASE of PACKET) (fetch PBIRAWSTART of PBI) (ADD1 (fetch PBILENGTH of PBI))) (COND ((NEQ (fetch PBISOCKET of PBI) 0) (HELP "PBI has a socket" PBI] (RETURN PBI))) (\BOXIPLUS (LOCF (fetch NETIOOPS of \MISCSTATS)) 1) (\RCLK (LOCF (fetch EPTIMESTAMP of PACKET))) (replace EPNETWORK of PACKET with \3MBLOCALNDB) (replace EPTYPE of PACKET with (fetch 3MBTYPE of PACKET)) [COND (\RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWGET] PACKET]) (\3MB.CREATENDB [LAMBDA NIL (* bvm%: "15-Feb-85 22:18") (create NDB NDBPUPHOST# _ (\SERIALNUMBER) NDBPUPNET# _ 0 NDBNSNET# _ 0 NETTYPE _ 3 NDBPUPTYPE _ \3MBTYPE.PUP NDBTRANSMITTER _ (FUNCTION \3MBSENDPACKET) NDBENCAPSULATOR _ (FUNCTION \3MBENCAPSULATE) NDBBROADCASTP _ (FUNCTION \3MB.BROADCASTP) NDBETHERFLUSHER _ (FUNCTION NILL) NDBWATCHER _ (ADD.PROCESS '(\3MBWATCHER) 'RESTARTABLE 'SYSTEM 'AFTEREXIT 'DELETE]) (\3MBSENDPACKET [LAMBDA (NDB PACKET) (* ; "Edited 17-May-88 14:34 by bvm") (* ;; "Sends raw seething etherpacket on the 3mb net denoted by NDB") (SETQ PACKET (\DTEST PACKET 'ETHERPACKET)) (LET ((NWORDS (fetch 3MBLENGTH of PACKET)) S) (AND \RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWPUT)) [COND ((> (UNFOLD (- NWORDS \3MBENCAPSULATION.WORDS) BYTESPERWORD) *MAXIMUM-PACKET-SIZE*) (CL:CERROR "Drop the packet" "Attempt to send ~D-byte packet, longer than this machine's packet size limit" (UNFOLD (- NWORDS \3MBENCAPSULATION.WORDS) BYTESPERWORD))) ((OR (NULL \ETHERLIGHTNING) (NEQ (RAND 0 \ETHERLIGHTNING) 0)) (if [NOT (UNINTERRUPTABLY (LET ((PBI (\GETPACKETBUFFER))) (if PBI then (* ;  "Got bcpl buffer, so blt our packet into there and send it off") (\BLT (fetch PBIRAWSTART of PBI) (fetch 3MBBASE of PACKET) (ADD1 NWORDS)) (\WRITERAWPBI PBI) (\BOXIPLUS (LOCF (fetch NETIOOPS of \MISCSTATS)) 1))))] then (* ; "Failed to get a packet buffer") (if [AND \RAWTRACING (SETQ S (SELECTC (fetch EPTYPE of PACKET) (\EPT.PUP (AND PUPTRACEFLG PUPTRACEFILE)) (AND XIPTRACEFLG XIPTRACEFILE] then (PRIN1 'x S] (\REQUEUE.ETHERPACKET PACKET) T]) (\3MBWATCHER [LAMBDA NIL (* bvm%: "26-OCT-83 15:21") (* ;;; "Process that watches the 3mb net and pulls packets in, passing them to the raw packet handler") (PROG ((CNTR 0) PACKET) LP [COND ((SETQ PACKET (\3MBGETPACKET)) (* ; "Got something") (\HANDLE.RAW.PACKET PACKET) (COND ((ILESSP (add CNTR 1) \MAXWATCHERGETS) (* ;  "Hack to get better ether service in lieu of preemption") (GO LP] (BLOCK) (SETQ CNTR 0) (GO LP]) (\3MBENCAPSULATE [LAMBDA (NDB PACKET PDH LENGTH TYPE) (* bvm%: " 7-MAR-83 12:44") (* ;; "Encapsulates packets for 3mb net") (replace 3MBDESTHOST of PACKET with PDH) (replace 3MBSOURCEHOST of PACKET with (fetch NDBPUPHOST# of NDB)) (replace 3MBLENGTH of PACKET with (IPLUS (FOLDHI LENGTH BYTESPERWORD) \3MBENCAPSULATION.WORDS)) (replace 3MBTYPE of PACKET with TYPE) PACKET]) (\3MB.BROADCASTP [LAMBDA (PACKET) (* bvm%: "14-Feb-85 00:38") (EQ (fetch 3MBDESTHOST of PACKET) 0]) (\3MBFLUSH [LAMBDA (ASPROC) (* bvm%: "18-FEB-83 17:10") (PROG NIL LP (RETURN (PROG1 (while (\READRAWPBI) sum 1) (COND (ASPROC (BLOCK 5000) (GO LP))))]) ) (RPAQ? \MAXWATCHERGETS 5) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS 3MBENCAPSULATION [(3MBENCAPSTART (LOCF (fetch (ETHERPACKET EPENCAPSULATION) of DATUM] (BLOCKRECORD 3MBENCAPSTART ((NIL 5 WORD) (* ; "waste space") (3MBLENGTH WORD) (* ;  "Length of packet in words, starting at the next word") (3MBDESTHOST BYTE) (* ; "Immediate destination host") (3MBSOURCEHOST BYTE) (* ; "Us") (3MBTYPE WORD) (* ;  "Type of packet -- PUP or XIP or 10TO3") ) [ACCESSFNS 3MBLENGTH ((3MBBASE (LOCF DATUM] (* ; "What to hand to BCPL") ) (TYPE? (type? ETHERPACKET DATUM))) (BLOCKRECORD PBI ((PBILINK WORD) (PBIQUEUE WORD) (PBISOCKET WORD) (PBINDB WORD) (PBIINPUTP FLAG) (PBIALLNETSP FLAG) (PBINOZEROP FLAG) (NIL BITS 13) (PBITIMER WORD) (PBILENGTH WORD) (PBIENCAPSULATION 2 WORD) (PBIFIRSTPUPWORD 10 WORD) (PBIFIRSTPUPDATAWORD WORD)) [ACCESSFNS PBI ((PBIPUPSTART (LOCF (fetch PBIFIRSTPUPWORD of DATUM))) (PBIPUPDATASTART (LOCF (fetch PBIFIRSTPUPDATAWORD of DATUM))) (PBIRAWSTART (LOCF (fetch PBILENGTH of DATUM]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS \SERIALNUMBER MACRO (NIL (fetch (IFPAGE SerialNumber) of \InterfacePage))) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ \3MBENCAPSULATION.WORDS 2) (RPAQQ \3MBTYPE.PUP 512) (CONSTANTS \3MBENCAPSULATION.WORDS \3MBTYPE.PUP) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \MAXWATCHERGETS *MAXIMUM-PACKET-SIZE*) ) ) (* ; "Debugging") (DEFINEQ (ASSURE.ETHER.ON [LAMBDA (USENS) (* bvm%: " 8-JUL-83 18:31") (OR (THIS.PROCESS) (ERROR "Processes not on!" "" T)) (COND ((NOT \LOCALNDBS) (AND USENS (SETQ \NSFLG T)) (\ETHEREVENTFN)) ((AND USENS (NOT \NSFLG)) (\NSINIT]) (INITPUPLEVEL1 [LAMBDA (FLG) (* bvm%: " 5-MAY-83 23:49") (TURN.OFF.ETHER) (DEL.PROCESS '\3MBFLUSH) (SELECTC \MACHINETYPE (\DANDELION) (\PUPLEVEL1STATE NIL)) (ASSURE.ETHER.ON) (COND (FLG (* ;  "This hack used for Bootstrapping: we got called from \PUPINIT in the evaluation of PUP's coms") (HARDRESET]) (TURN.ON.ETHER [LAMBDA NIL (* bvm%: "26-MAR-83 15:55") (ASSURE.ETHER.ON \NSFLG]) (RESTART.ETHER [LAMBDA NIL (* ; "Edited 15-Jan-88 01:30 by bvm") (PROG (PROC) (AND (SETQ PROC (FIND.PROCESS '\PUPGATELISTENER)) (SUSPEND.PROCESS PROC)) (AND (SETQ PROC (FIND.PROCESS '\NSGATELISTENER)) (SUSPEND.PROCESS PROC))) (\ETHEREVENTFN NIL 'RESTART]) (TURN.OFF.ETHER [LAMBDA NIL (* bvm%: "12-JUL-83 14:03") (BREAKCONNECTION T) (DEL.PROCESS '\PUPGATELISTENER) (DEL.PROCESS '\NSGATELISTENER) (CLOSEPUPSOCKET T) (AND (GETD 'CLOSENSOCKET) (CLOSENSOCKET T)) (\FLUSHNDBS 'RESTART]) (PRINTWORDS [LAMBDA (BASE NWORDS) (* bvm%: "25-MAY-82 21:26") (for I from 0 to (SUB1 NWORDS) do (printout NIL .P2 I ": " .P2 (\GETBASE BASE I) T]) ) (RPAQQ ROUTINGINFOMACRO (1 "Operation = " WORDS 2 "Info: " REPEAT "(" SEPR ", " INTEGER -4 WORDS SEPR ") " -2 FINALLY ")")) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (* ; "Opcodes") (DEFINEQ (\DEVICE.INPUT [LAMBDA (TASKREG) (* bvm%: "12-JUL-82 13:29") ((OPCODES MISC1 1) (\DTEST TASKREG 'SMALLP]) (\DEVICE.OUTPUT [LAMBDA (VALUE TASKREG) (* bvm%: "12-JUL-82 13:29") ((OPCODES MISC2 2) (\DTEST VALUE 'SMALLP) (\DTEST TASKREG 'SMALLP]) (\D0.STARTIO [LAMBDA (BITS) (* bvm%: "12-JUL-82 13:28") ((OPCODES MISC1 0) (\DTEST BITS 'SMALLP]) ) (DECLARE%: DONTCOPY (RPAQQ D0DEVICES ((\DEVICE.3MBETHERIN 7) (\DEVICE.3MBETHEROUT 6) (\DEVICE.10MBETHER 21) (\DEVICE.SA4000 3) (\DEVICE.DISPLAY 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \DEVICE.3MBETHERIN 7) (RPAQQ \DEVICE.3MBETHEROUT 6) (RPAQQ \DEVICE.10MBETHER 21) (RPAQQ \DEVICE.SA4000 3) (RPAQQ \DEVICE.DISPLAY 2) (CONSTANTS (\DEVICE.3MBETHERIN 7) (\DEVICE.3MBETHEROUT 6) (\DEVICE.10MBETHER 21) (\DEVICE.SA4000 3) (\DEVICE.DISPLAY 2)) ) (* "FOLLOWING DEFINITIONS EXPORTED") (PUTPROPS \DEVICE.INPUT DOPVAL (1 MISC1 1)) (PUTPROPS \DEVICE.OUTPUT DOPVAL (2 MISC2 2)) (PUTPROPS \D0.STARTIO DOPVAL (1 MISC1 0)) (* "END EXPORTED DEFINITIONS") ) (PUTPROPS LLETHER COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10827 17692 (\ENQUEUE 10837 . 13482) (\DEQUEUE 13484 . 14811) (\QUEUELENGTH 14813 . 15113) (\ONQUEUE 15115 . 15381) (\UNQUEUE 15383 . 17690)) (51359 55225 (\ALLOCATE.ETHERPACKET 51369 . 52410) (\RELEASE.ETHERPACKET 52412 . 53485) (RELEASE.PUP 53487 . 53632) (\FLUSH.PACKET.QUEUE 53634 . 53985) (\REQUEUE.ETHERPACKET 53987 . 54501) (\EP.PUT.AUX 54503 . 55223)) (55799 67180 ( \SETLOCALNSNUMBERS 55809 . 57194) (\LOADNSADDRESS 57196 . 57488) (\STORENSADDRESS 57490 . 57671) ( \PRINTNSADDRESS 57673 . 58756) (\NSADDRESS.DEFPRINT 58758 . 63703) (\NSADDRESS.PRINT.DECIMAL 63705 . 65836) (\LOADNSHOSTNUMBER 65838 . 66467) (\STORENSHOSTNUMBER 66469 . 66873) (PRINTNSHOSTNUMBER 66875 . 67178)) (67293 74381 (\ETHERINIT 67303 . 67873) (\ETHEREVENTFN 67875 . 70869) (\TIME.NOT.SET 70871 . 71197) (\SETETHERFLAGS 71199 . 72688) (\FLUSHNDBS 72690 . 73868) (\FLUSH.NDB.QUEUE 73870 . 74379)) (74382 77674 (\CHECKSUM 74392 . 76324) (\HANDLE.RAW.OTHER 76326 . 76681) (\HANDLE.RAW.PACKET 76683 . 77195) (\ADD.PACKET.FILTER 77197 . 77429) (\DEL.PACKET.FILTER 77431 . 77672)) (85243 85768 ( ENCAPSULATE.ETHERPACKET 85253 . 85525) (TRANSMIT.ETHERPACKET 85527 . 85766)) (86056 98652 ( \AGE.ROUTING.TABLE 86066 . 88215) (\ADD.ROUTING.TABLE.ENTRY 88217 . 88913) (\CLEAR.ROUTING.TABLE 88915 . 89642) (\MAP.ROUTING.TABLE 89644 . 90172) (PRINTROUTINGTABLE 90174 . 93799) (\ROUTINGTABLE.INFOHOOK 93801 . 98650)) (99137 105922 (\TRANSLATE.10TO3 99147 . 100931) (\NOTE.10TO3 100933 . 102549) ( \HANDLE.RAW.10TO3 102551 . 105920)) (109904 124726 (PRINTPACKET 109914 . 110475) (\MAYBEPRINTPACKET 110477 . 112134) (PRINT10TO3 112136 . 113504) (PRINTPACKETDATA 113506 . 118796) (PRINTPACKETQUEUE 118798 . 119227) (TIME.SINCE.PACKET 119229 . 119714) (MAKE-NETWORK-TRACE-WINDOW 119716 . 123258) ( \CHANGE.ETHER.TRACING 123260 . 124724)) (125097 125912 (\CENTICLOCK 125107 . 125910)) (126367 132467 ( \3MBGETPACKET 126377 . 127797) (\3MB.CREATENDB 127799 . 128514) (\3MBSENDPACKET 128516 . 130699) ( \3MBWATCHER 130701 . 131439) (\3MBENCAPSULATE 131441 . 131989) (\3MB.BROADCASTP 131991 . 132162) ( \3MBFLUSH 132164 . 132465)) (135413 137356 (ASSURE.ETHER.ON 135423 . 135753) (INITPUPLEVEL1 135755 . 136235) (TURN.ON.ETHER 136237 . 136382) (RESTART.ETHER 136384 . 136758) (TURN.OFF.ETHER 136760 . 137078) (PRINTWORDS 137080 . 137354)) (137618 138153 (\DEVICE.INPUT 137628 . 137793) (\DEVICE.OUTPUT 137795 . 137989) (\D0.STARTIO 137991 . 138151))))) STOP \ No newline at end of file diff --git a/sources/LLFAULT b/sources/LLFAULT new file mode 100644 index 00000000..07031b64 --- /dev/null +++ b/sources/LLFAULT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Jan-93 12:26:58" {DSK}sybalsky>3-BYTE-ATOMS>LLFAULT.;1 550130Q changes to%: (VARS \MAXFILEPAGE) (FNS \MAIKO.FAULTINIT) previous date%: " 5-Nov-92 18:39:48" |{PELE:MV:ENVOS}SOURCES>LLFAULT.;8|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLFAULTCOMS) (RPAQQ LLFAULTCOMS [(VARS (FAULTTEST T)) (COMS (* ;  "Bootstrap code, run once when an image is booted") (FNS \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE \MAIKO.NEWPAGE) (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:") (FNS \MAIKO.DO.MOVDS) (ADDVARS (\MAIKO.MOVDS (TRUE \LOCKEDPAGEP) (\MAIKO.NEWPAGE \NEWPAGE) (\MAIKO.NEWPAGE \DONEWPAGE) (NILL \LOCKPAGES) (NILL \DOLOCKPAGES) (NILL \DOTEMPLOCKPAGES) (NILL \TEMPUNLOCKPAGES) (NILL \UNLOCKPAGES) (NILL \WRITEDIRTYPAGE) (NILL \DIRTYBACKGROUND) (ZERO \COUNTREALPAGES) (NILL \SHOWPAGETABLE) (NILL CHECKPAGEMAP) (EVQ \PAGEFAULT) (EVQ \LOADVMEMPAGE) (NILL \LOADVMEMPAGE) (TRUE \MOVEVMEMFILEPAGE) (TRUE \VALIDADDRESSP))) (FNS \DOVE.FAULTINIT \DL.FAULTINIT \DL.NEWFAULTINIT \DL.UNMAPPAGES \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS \CHAIN.UP.RPT)) (COMS (* ; "Pagefault handler") (FNS \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE \LOADVMEMPAGE \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP \SELECTREALPAGE \SPECIALRP \TRANSFERPAGE \UPDATECHAIN)) (COMS (* ;  "Allocating and locking new pages") (FNS \NEWPAGE \DONEWPAGE \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES)) (COMS (* ; "Writing out the vmem") (FNS \FLUSHVM \LOGOUT0 \DOFLUSHVM \RELEASEWORKINGSET \WRITEDIRTYPAGE \WRITEDIRTYPAGE1 \COUNTREALPAGES)) (COMS (* ; "VMEM.PURE.STATE hack") (FNS \DOCOMPRESSVMEM VMEM.PURE.STATE)) (COMS (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages") (FNS 32MBADDRESSABLE \SET.VMEM.FULL.STATE \SET.LASTVMEMFILEPAGE \DOVMEMFULLINTERRUPT \FLUSHVMOK?)) (INITVARS (\UPDATECHAINFREQ 100) (\PAGEFAULTCOUNTER 0) (\DIRTYPAGECOUNTER 0) (\DIRTYPAGEHINT 0) (\LASTACCESSEDVMEMPAGE 0) (\MAXSHORTSEEK 1000) (\MINSHORTSEEK 20) (\MAXCLEANPROBES 20) (\VMEM.INHIBIT.WRITE) (\VMEM.PURE.LIMIT) (\VMEM.FULL.STATE) (\GUARDVMEMFULL 500) (VMEM.COMPRESS.FLG) (\DOFAULTINIT 0) (\VMEMACCESSFN) (\SYSTEMCACHEVARS) (\MAXSWAPBUFFERS 1) (\EXTENDINGVMEMFILE) (\MaxScreenPage 0) (\NEWVMEMPAGEADDED)) (INITVARS (\LASTDIRTYCNT) (\LASTDIRTYFOUND) (\LASTDIRTYSCANPTR) (\DIRTYSEEKMAX 50)) (COMS (* ;  "Errors signaled in the maintenance panel") (FNS \MP.ERROR)) (COMS (* ;  "Debugging code. Some of this also runs renamed for extra TeleRaid help") (FNS \ACTONVMEMFILE \SHOWPAGETABLE CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \PRINTFPTOVP \PRINTVP)) (E (RESETSAVE (RADIX 8))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \ACTONVMEMFILE .VMEM.CONSISTENTP. .LOCKABLERP.) (COMS (* ; "Virtual page flags") (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS \VMAP.NOTFLAGS) (RECORDS VMEMFLAGS) (MACROS LOGNOT16)) (COMS (* ; "RPT constants") (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH) (RECORDS RPT RPT1) (MACROS RPFROMRPT RPTFROMRP NPAGESMACRO)) (COMS (* ; "Virtual to file pagemap") (EXPORT (CONSTANTS \MAXFILEPAGE)) (CONSTANTS \EMPTYPMTENTRY) (RECORDS VP) (MACROS .PAGEMAPBASE.)) (COMS (* ; "FP to VP stuff") (RECORDS FPTOVP) (CONSTANTS \NO.VMEM.PAGE) (MACROS DLRPFROMFP DLFPFROMRP)) (PROP DOPVAL \TOUCHPAGE TIMES3) (COMS (* ; "Locked page table") (MACROS .LOCKEDVPBASE. .LOCKEDVPMASK.)) (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES) (CONSTANTS 2MBPAGES) (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE \MaxScreenPage \NEWVMEMPAGEADDED) (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND) (MACROS RWMufMan) (CONSTANTS (DOLOCKCHECKS NIL))) [COMS (* ;;; "MAKEINIT stuff") (FNS ADDPME CHECKIFPAGE DUMPINITPAGES MAKEROOMFORPME MAPPAGES READPAGEMAP READPAGEMAPBLOCK SETUPPAGEMAP) (DECLARE%: DONTCOPY (MACROS CHECKIF) (ADDVARS (INEWCOMS (FNS DUMPINITPAGES) (VARS INITCONSTANTS) (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES)) (RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \SHOWPAGETABLE \PRINTFPTOVP)) (EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.) (MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE) (\LOCKPAGES . MKI.LOCKPAGES)) (RD.SUBFNS (\NEWPAGE . VNEWPAGE) (\LOCKPAGES . VLOCKPAGES)) (RDPTRS (\REALPAGETABLE)) (RDVALS (\RPTSIZE))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE] (FNS \LOCKFN \LOCKCODE \LOCKVAR \LOCKCELL \LOCKWORDS) [DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE) (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE \MOVEREALPAGE \INVALIDADDR \INVALIDVP \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE \CLEARWORDS \FLUSHVM \DONEWPAGE \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR RAID \DL.NEWFAULTINIT \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL SETTOPVAL) (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER \UPDATECHAINFREQ \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE \MISCSTATS \DEFSPACE \InterfacePage \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage \NEWVMEMPAGEADDED] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA VMEM.PURE.STATE]) (RPAQQ FAULTTEST T) (* ; "Bootstrap code, run once when an image is booted") (DEFINEQ (\FAULTINIT [LAMBDA NIL (* ; "Edited 30-Mar-88 17:30 by Snow") (* ;;; "retrieves some constants from Interface page for the swapper and performs other initialization that must happen immediately. Called when starting up, and also when \FAULTHANDLER context starts, in case init hasn't happened yet, as e.g. from MAKEINIT") (SETQ \MACHINETYPE (fetch MachineType of \InterfacePage)) [PROG NIL (COND ((EQ \MACHINETYPE \MAIKO) (\MAIKO.FAULTINIT) (RETURN NIL))) (OR (NEQ (fetch FPTOVPStart of \InterfacePage) 0) (\MP.ERROR \MP.OBSOLETEVMEM "No FPTOVP")) (COND ((AND (NEQ 0 (fetch (IFPAGE FullSpaceUsed) of \InterfacePage)) (SELECTC \MACHINETYPE (\DORADO NIL) (\DANDELION (EQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage ))) (\DAYBREAK NIL) T)) (\MP.ERROR \MP.32MBINUSE "Sysout contains virtual pages not addressable by machine" ))) (SETQ \LASTDIRTYSCANPTR) (SELECTC \MACHINETYPE (\DANDELION (\DL.FAULTINIT)) (\DAYBREAK (\DOVE.FAULTINIT)) (\D01.FAULTINIT)) (* ;  "Have to set \EM.CURSORBITMAP before faults can happen") (* ;; "But you can't call \SETIOPOINTERS on a Daybreak until after the Dove IO Region is mapped, which happens in \DL.NEWFAULTINIT") (\SETIOPOINTERS) (COND ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage) (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL)) (* ; "Vmem getting full!") (\SET.VMEM.FULL.STATE] (COND ((EQ (PROG1 \DOFAULTINIT (SETQ \DOFAULTINIT NIL)) T) (* ;  "true after \FLUSHVM. Need to rebuild some contexts") (replace (IFPAGE KbdFXP) of \InterfacePage with (\MAKEFRAME (COND ((fetch (LITATOM CCODEP) of '\KEYHANDLER) (FUNCTION \KEYHANDLER)) (T '\DUMMYKEYHANDLER)) \KBDSTACKBASE (IPLUS \KBDSTACKBASE \StackAreaSize) 0 0)) (replace (IFPAGE MiscFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOMISCAPPLY) \MISCSTACKBASE (IPLUS \MISCSTACKBASE \StackAreaSize) 0 0)) T]) (\D01.FAULTINIT [LAMBDA NIL (* bvm%: "20-Oct-86 18:19") (SETQ \VMEMACCESSFN (FUNCTION \M44ACTONVMEMFILE)) (SETQ \REALPAGETABLE (fetch (IFPAGE REALPAGETABLEPTR) of \InterfacePage)) (* ;; "Note: these SETQ's do not reference count, since the values are all smallp's and emulator addresses (in atom space)") (SETQ \RPOFFSET (SIGNED (fetch (IFPAGE RPOFFSET) of \InterfacePage) BITSPERWORD)) (SETQ \RPTSIZE (fetch (IFPAGE RPTSIZE) of \InterfacePage)) (* ;  "Initialize the software clocks from alto emulator") (\BLT (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) (EMADDRESS \RTCSECONDS) (UNFOLD 3 WORDSPERCELL)) [SETQ \RCLKMILLISECOND (CONSTANT (OR (SMALLP \ALTO.RCLKMILLISECOND) (ERROR \ALTO.RCLKMILLISECOND "\ALTO.RCLKMILLISECOND isn't a SMALLP???"] (* ;;; "\ALTO.RCLKMILLISECOND must be a SMALLP here so as not to cause any refcnt or pagefault activity. \RCLKSECOND is large and has to live on \MISCSTATS, since there is no convenient way to lock a random cell.") (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS))) (* ;;; "Note the SETQ.NOREF for \RCLKSECOND in order to guarantee no refcnt'ing (which might pagefault) Note that these LOADBYTE expressions are compiled as constants") (replace (FIXP HINUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 16 16)) (replace (FIXP LONUM) of \RCLKSECOND with (LOADBYTE \ALTO.RCLKSECOND 0 16)) [COND ((AND (EQ \MACHINETYPE \DORADO) (ILEQ 5124 (fetch RVersion of \InterfacePage))) (replace NSHost0 of \InterfacePage with 0) (replace NSHost1 of \InterfacePage with 21898) (replace NSHost2 of \InterfacePage with (IPLUS (MASK.1'S 15 1) (for I (N _ 0) from 1168 to 1175 do (* ;  "Mufflers `2220Q' thru `2227Q' hold the bits of the basic serial number") [SETQ N (IPLUS (LLSH N 1) (COND ((BITTEST (RWMufMan I) (MASK.1'S 15 1)) 0) (T 1] finally (RETURN N] (\CHAIN.UP.RPT) (\D01.ASSIGNBUFFERS]) (\D01.ASSIGNBUFFERS [LAMBDA NIL (* bvm%: "20-Oct-86 18:21") (PROGN (* ; "Assign swap buffer") (SETQ \EMBUFVP (fetch (IFPAGE EMBUFVP) of \InterfacePage)) (SETQ \EMBUFBASE (EMPOINTER (UNFOLD \EMBUFVP WORDSPERPAGE))) (SETQ \EMBUFRP (\READRP \EMBUFVP))) (PROG ((EMBUF (fetch (IFPAGE EMUBUFFERS) of \InterfacePage)) (EMLEN (fetch (IFPAGE EMUBUFLENGTH) of \InterfacePage)) EXTRALEN NPAGES) [add EMLEN (IDIFFERENCE EMBUF (SETQ EMBUF (CEIL EMBUF WORDSPERPAGE] (* ;  "Round up to a page boundary and throw out the excess") (SETQ EXTRALEN (IMOD EMLEN WORDSPERPAGE)) (add EXTRALEN (COND ((ILESSP EXTRALEN 100) (TIMES 2 WORDSPERPAGE)) (T WORDSPERPAGE))) (SETQ NPAGES (FOLDLO (SETQ EMLEN (IDIFFERENCE EMLEN EXTRALEN)) WORDSPERPAGE)) (OR (IGEQ NPAGES 4) (RAID "No swap buffer space")) (SETQ \TELERAIDBUFFER (EMPOINTER EMBUF)) (SETQ \EMUBUFFERS (\ADDBASE \TELERAIDBUFFER WORDSPERPAGE)) (SETQ \#EMUBUFFERS (SETQ NPAGES (SUB1 NPAGES))) (SETQ \#SWAPBUFFERS (IMIN \MAXSWAPBUFFERS (IQUOTIENT NPAGES 2))) (SETQ \#DISKBUFFERS (IDIFFERENCE \#EMUBUFFERS \#SWAPBUFFERS)) (SETQ \EMUDISKBUFFERS \EMUBUFFERS) (SETQ \EMUDISKBUFEND (\ADDBASE \EMUDISKBUFFERS (UNFOLD \#DISKBUFFERS WORDSPERPAGE))) (SETQ \EMUSWAPBUFFERS \EMUDISKBUFEND) (\INITBFS (\ADDBASE \EMUBUFFERS (UNFOLD NPAGES WORDSPERPAGE)) EXTRALEN T]) (\MAIKO.FAULTINIT [LAMBDA NIL (* ; "Edited 2-Jan-93 12:25 by jds") (SETQ \VMEMACCESSFN (FUNCTION NILL)) (* ; "This variable must be the name of function that may be ACTONVMEMFILE that may write back from VP to FP. But , in Katana type, this function may be required (by tt)") (SETQ \IOCBPAGE (create POINTER PAGE# _ \VP.IOCBS)) (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts:") (\MAIKO.DO.MOVDS) (\MAIKO.NEWFAULTINIT) (SETQ \RCLKMILLISECOND 1000) (SETQ \RCLKSECOND 1000000) (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS))) (* ; "Reset base clock ") (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) 0 NIL) (* ; "Clear the seconds timer (by tt)") (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS)) 0 NIL) (* ; "Clear the milliseconds timer") (* SETQ \LASTVMEMFILEPAGE  (fetch (IFPAGE DLLastVmemPage) of  \InterfacePage)) (\SETIOPOINTERS]) (\MAIKO.NEWFAULTINIT [LAMBDA NIL (* ; "Edited 26-Feb-88 14:07 by Osamu Nakamura") (* ;; "We have just started up on a Katana. Boot code (SYSOUT Loader) may map FP to VP(VP is same map to RP). Therefore, in this function, only done the initialization of the gloval variables (particularly, the variables about Buffers). And, there is not /REALPAGETABLE in Katana.") (PROG ((NBUFFERS (IDIFFERENCE \DLBUFFERPAGES 2))) (* ; "Allocate buffers") (\MAIKO.ASSIGNBUFFERS (create POINTER PAGE# _ \VP.BUFFERS) NBUFFERS]) (\MAIKO.ASSIGNBUFFERS [LAMBDA (BASE NPAGES) (* ; "Edited 14-May-88 18:31 by JMTurn") (PROGN (* ;  "Allocate a page to hold name and password, and perhaps other ephemeral things") (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1 ))) (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 33))) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -1)) (PROGN (* ; "Assign swap buffer") (SETQ \EMBUFBASE BASE) (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE)) (SETQ \EMBUFRP \EMBUFVP) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -1)) (PROGN (* ; "Assign ether buffers") (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE) ) (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE)) (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE))) (SETQ \TELERAIDBUFFER BASE) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -3)) (PROGN (* ; "Divvy up buffer space") (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES)) (SETQ \#DISKBUFFERS 0) (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE]) (\M-VMEMSAVE [LAMBDA NIL (* ; "Edited 20-Apr-88 10:28 by MASINTER") (PROG ((SCRATCHBUF \EMUSWAPBUFFERS)) (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T) [COND (\VMEM.PURE.LIMIT (* ;  "Maintaining file consistency: move high water mark up") (COND (VMEM.COMPRESS.FLG (\DOCOMPRESSVMEM))) (SETQ \VMEM.PURE.LIMIT (fetch (IFPAGE NActivePages) of \InterfacePage] (COND ((.VMEM.CONSISTENTP.) (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey)) (* ;  "Invalidate vmem and write out the Interface page") (* ;; "following form doesn't eval for KATANA (\TRANSFERPAGE IFPVP \FirstVmemBlock (RPTFROMRP (\READRP IFPVP)) T NIL)") )) (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey) (\BLT SCRATCHBUF \InterfacePage WORDSPERPAGE) (* ;  "Make its current fx point at user context, i.e. the \FLUSHVM frame") (replace (IFPAGE CurrentFXP) of SCRATCHBUF with (fetch (IFPAGE MiscFXP) of \InterfacePage)) (SUBRCALL VMEMSAVE) (RETURN NIL]) (\MAIKO.NEWPAGE [LAMBDA (BASE NOERROR LOCK?) (* ; "Edited 20-Apr-88 10:28 by MASINTER") (SUBRCALL NEWPAGE BASE]) ) (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:" ) (DEFINEQ (\MAIKO.DO.MOVDS [LAMBDA NIL (* ;  "Edited 2-Nov-92 03:57 by sybalsky:mv:envos") (* ;; "MOVD all the Maiko-specific low-level functions onto their generic counterparts. This function is called from \MAIKO.FAULTINIT when the system is started up, and called explicitly during the LOADUP process to get everything in a state to run the ethernet.") (* ;; "THIS IS WHERE CHANGES SHOULD HAPPEN TO MAKE SUN LOADUPS RUN ON D-MACHINES (BY ADDING A \MAIKO.UNDO.MOVDS CALL AT VMEM SAVING TIME, AND ADDING A SYBMOL TO SAVE THE GENERIC DEFINITION ON TO THE MOVDS LIST.") (FOR PAIR IN \MAIKO.MOVDS DO (* ;; "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc. So that no CONSING happens before all the MOVDs are finished -- prevents new-page allocation.") (LET [(FROMCELL (fetch (LITATOM DEFINITIONCELL) of (CAR PAIR))) (TOCELL (fetch (LITATOM DEFINITIONCELL) of (CADR PAIR] (UNINTERRUPTABLY (replace (DEFINITIONCELL DEFPOINTER) of TOCELL with (fetch (DEFINITIONCELL DEFPOINTER) of FROMCELL)) (replace (DEFINITIONCELL DEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL DEFCELLFLAGS) of FROMCELL)) (replace (DEFINITIONCELL AUXDEFCELLFLAGS) of TOCELL with (fetch (DEFINITIONCELL AUXDEFCELLFLAGS) of FROMCELL)))]) ) (ADDTOVAR \MAIKO.MOVDS (TRUE \LOCKEDPAGEP) (\MAIKO.NEWPAGE \NEWPAGE) (\MAIKO.NEWPAGE \DONEWPAGE) (NILL \LOCKPAGES) (NILL \DOLOCKPAGES) (NILL \DOTEMPLOCKPAGES) (NILL \TEMPUNLOCKPAGES) (NILL \UNLOCKPAGES) (NILL \WRITEDIRTYPAGE) (NILL \DIRTYBACKGROUND) (ZERO \COUNTREALPAGES) (NILL \SHOWPAGETABLE) (NILL CHECKPAGEMAP) (EVQ \PAGEFAULT) (EVQ \LOADVMEMPAGE) (NILL \LOADVMEMPAGE) (TRUE \MOVEVMEMFILEPAGE) (TRUE \VALIDADDRESSP)) (DEFINEQ (\DOVE.FAULTINIT [LAMBDA NIL (* ; "Edited 18-Sep-87 16:01 by bvm:") (DECLARE (GLOBALVARS \RCLKMILLISECOND \RCLKSECOND)) (SETQ \VMEMACCESSFN (FUNCTION \DOVE.ACTONVMEMFILE)) (SETQ \IOCBPAGE (create POINTER PAGE# _ \VP.IOCBS)) (COND ((NOT (.VMEM.CONSISTENTP.)) (\MP.ERROR \MP.INVALIDVMEM))) (SETMAINTPANEL 1188) (\DL.NEWFAULTINIT) (SETMAINTPANEL 1189) (SETQ \RCLKMILLISECOND \DOVE.RCLKMILLISECOND) (SETQ.NOREF \RCLKSECOND (LOCF (fetch RCLKSECOND of \MISCSTATS))) (* ;  "Unfortunately, \DOVE.RCLKSECOND is not smallp") (replace (FIXP HINUM) of \RCLKSECOND with (CONSTANT (\HINUM \DOVE.RCLKSECOND))) (replace (FIXP LONUM) of \RCLKSECOND with (CONSTANT (\LONUM \DOVE.RCLKSECOND))) (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS))) (* ; "Reset base clock") (\DoveMisc.ReadGMT (LOCF (fetch SECONDSCLOCK of \MISCSTATS))) (SETMAINTPANEL 1190) (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS)) 0 NIL) (* ; "Clear the milliseconds timer") (\DoveMisc.ReadHostID (LOCF (fetch NSHost0 of \InterfacePage))) (SETMAINTPANEL 1191) [SETQ \LASTVMEMFILEPAGE (COND (NIL (* ; "For now, don't assume vmem is any bigger than the part in use now. Local file system init will set it to the truth.") (SETQ \VMEM.FULL.STATE 0)(* ; "Flag to keep pages from being written off the end. Setting it now prevents bogus vmem full interrupt at startup time.") (fetch (IFPAGE NActivePages) of \InterfacePage)) (T (* ;  "Microcode is supposed to fill this in") (fetch (IFPAGE DLLastVmemPage) of \InterfacePage] (\DoveDisk.Init) (SETMAINTPANEL 1192) (\DoveDisplay.TurnOn]) (\DL.FAULTINIT [LAMBDA NIL (* bvm%: "20-Oct-86 18:22") (SETQ \VMEMACCESSFN (FUNCTION \DL.ACTONVMEMFILE)) (SETQ \IOCBPAGE (create POINTER PAGE# _ \VP.IOCBS)) (COND ((NOT (.VMEM.CONSISTENTP.)) (\MP.ERROR \MP.INVALIDVMEM))) (\DL.NEWFAULTINIT) (SETQ \RCLKMILLISECOND \DLION.RCLKMILLISECOND) (* ;  "These are fortunately both small") (SETQ \RCLKSECOND \DLION.RCLKSECOND) (\RCLK (LOCF (fetch BASECLOCK of \MISCSTATS))) (* ; "Reset base clock") [COND ((EQ (fetch DLTODVALID of \IOPAGE) 0) (* ;  "Time not valid, so store zero in the clock") (\PUTBASEPTR (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) 0 NIL)) (T (bind TMP (BASE _ (LOCF (fetch SECONDSCLOCK of \MISCSTATS))) do (* ;  "Loop until clock reads the same as we wrote, in case it was being updated") (\PUTBASE BASE 1 (SETQ TMP (fetch DLTODLO of \IOPAGE))) (\PUTBASE BASE 0 (fetch DLTODHI of \IOPAGE)) repeatuntil (EQ (fetch DLTODLO of \IOPAGE) TMP] (\PUTBASEPTR (LOCF (fetch MILLISECONDSCLOCK of \MISCSTATS)) 0 NIL) (* ; "Clear the milliseconds timer") (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE) \DL.PROCESSORBUSY)) (* ; "Wait for IOP readiness") (replace DLPROCESSORCMD of \IOPAGE with \DL.READPID) (* ;  "Ask it to give the processor ID (3 words)") (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE) \DL.PROCESSORBUSY)) (replace NSHost0 of \InterfacePage with (fetch DLPROCESSOR0 of \IOPAGE)) (replace NSHost1 of \InterfacePage with (fetch DLPROCESSOR1 of \IOPAGE)) (replace NSHost2 of \InterfacePage with (fetch DLPROCESSOR2 of \IOPAGE)) (SETQ \LASTVMEMFILEPAGE (fetch (IFPAGE DLLastVmemPage) of \InterfacePage)) (\DL.DISKINIT T]) (\DL.NEWFAULTINIT [LAMBDA NIL (* ; "Edited 21-Oct-87 15:40 by bvm:") (* ;; "We have just started up on a DLion or Daybreak. Boot code has loaded the first n pages of the sysout into pages 2 thru n-3, except for the area covered by the map and IO page, and has built the map accordingly. Our principal task is to build \REALPAGETABLE") (PROG ((NREALPAGES (fetch (IFPAGE NRealPages) of \InterfacePage)) (FIRSTBUFFERRP \RP.STARTBUFFERS) (SCRATCHVP \VP.INITSCRATCH) (SCRATCHBASE (create POINTER PAGE# _ \VP.INITSCRATCH)) FIRSTUSEFULRP IFPAGERP IOCBRP RPTBASE VP RPTPAGES FIRSTRP NDISPLAYPAGES) [do (COND ((for I from 0 to (SUB1 \DLBUFFERPAGES) as (FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP FIRSTBUFFERRP))) by (\ADDBASE FPBASE 1) do (COND ([OR (NOT (fetch FPOCCUPIED of FPBASE)) (\LOCKEDPAGEP (SETQ VP (fetch FPVIRTUALPAGE of FPBASE] (* ;; "Can't use as buffer. This is just a check for consistency; you should pick \RP.STARTBUFFERS so that this isn't a problem") (RETURN T))) (* ;  "Unmap this page so we can use it for buffers") (\WRITEMAP VP 0 \VMAP.VACANT))(* ; "Bad starting place, try again") (add FIRSTBUFFERRP 1)) (T (RETURN] (SETQ FIRSTUSEFULRP (+ FIRSTBUFFERRP \DLBUFFERPAGES)) (PROGN (* ;  "Copy vital info that booting left in page 1") [COND ((EQ \MACHINETYPE \DAYBREAK) (* ;; "Use first buffer page for IOCB page. Used to have to place this in a real page whose page-in-segment number was the same as that of \VP.IOCBS, but that constraint is now lifted for Daybreak.") (SETQ IOCBRP FIRSTBUFFERRP) (add FIRSTBUFFERRP 1)) (T (SETQ IOCBRP (+ (LOGAND (SUB1 (IMIN NREALPAGES 3072)) 65280) \VP.IOCBS)) (* ;; "Put IOCB page near the end of memory, but in the first 1.5 mb so that Burdock can see it. Temporary until Steve fixes swap code to not care what RP contains IOCB's") [SETQ VP (fetch FPVIRTUALPAGE of (\ADDBASE \FPTOVP (DLFPFROMRP IOCBRP] (COND ((\LOCKEDPAGEP VP) (\MP.ERROR \MP.IOCBPAGE)) (T (* ;  "Unmap whoever lived in our target page") (\WRITEMAP VP 0 \VMAP.VACANT] (\WRITEMAP \VP.IOCBS IOCBRP \VMAP.CLEAN) (\WRITEMAP SCRATCHVP 1 \VMAP.CLEAN) (\BLT \IOCBPAGE SCRATCHBASE WORDSPERPAGE)) (PROGN (* ;  "Copy InterfacePage out of segment zero") (\WRITEMAP SCRATCHVP FIRSTBUFFERRP \VMAP.CLEAN) (\BLT SCRATCHBASE \InterfacePage WORDSPERPAGE) (\WRITEMAP \VP.IFPAGE (SETQ IFPAGERP FIRSTBUFFERRP) \VMAP.CLEAN) (add FIRSTBUFFERRP 1)) [PROGN (* ;  "Unmap everything that fell somewhere we can't use") (\DL.UNMAPPAGES (ADD1 \FP.IFPAGE) (DLFPFROMRP \RP.IOPAGE)) (* ;  "real segment zero, map or IOPAGE") (COND ((EQ \MACHINETYPE \DANDELION) (for NEXTBANK0 from 2MBPAGES by 2MBPAGES until (> NEXTBANK0 NREALPAGES) do (* ;; "All the `shadows of the display bank' in higher memory have restricted use; take them out of commission for now") (\DL.UNMAPPAGES NEXTBANK0 (+ NEXTBANK0 PAGESPERSEGMENT -1] (PROGN (* ; "Copy Display into segment zero") [SETQ NDISPLAYPAGES (COND ((EQ \MACHINETYPE \DANDELION) (* ;; "Only lock the standard screen's worth of pages on DLion, even if there are more because the sysout came from wide Daybreak. Only this many need to be in the display bank, besides which there is a cursor bank after the display; the rest can be vanilla locked pages.") \NP.DISPLAY) (T (IMAX \NP.DISPLAY (ADD1 \MaxScreenPage] (* ;  "Number of display pages in use in this image") (for I from 0 to (SUB1 NDISPLAYPAGES) do (\WRITEMAP (+ SCRATCHVP I) (+ \RP.DISPLAY I) \VMAP.CLEAN)) (* ;  "Point scratch area at real segment zero") (\BLT SCRATCHBASE (create POINTER PAGE# _ \VP.DISPLAY) (UNFOLD NDISPLAYPAGES WORDSPERPAGE)) (* ;  "Copy display from wherever boot put it") (for I from 0 to (SUB1 NDISPLAYPAGES) do (\WRITEMAP (+ SCRATCHVP I) 0 \VMAP.VACANT) (\WRITEMAP (+ \VP.DISPLAY I) (+ \RP.DISPLAY I) \VMAP.CLEAN)) (* ;  "Display is now where hardware wants it, so enable display") (replace (IOPAGE DLDISPCONTROL) of \IOPAGE with 0)) (COND ((EQ \MACHINETYPE \DAYBREAK) (* ;  "If on a daybreak, map the I/O region. Have to do this before calling \DoveDisplay.ScreenWidth") (for I from 0 to (SUB1 \DOVEIORGNSIZE) do (\WRITEMAP (+ \VP.DOVEIORGN I ) (+ \RP.DOVEIORGN I) \VMAP.CLEAN)) (\DoveIO.InitializeIORegionPtrs))) [PROG ((RPSIZE (- NREALPAGES (SETQ \RPOFFSET -1))) (FIRSTVP \VP.RPT)) (SETQ FIRSTRP (COND ((OR (> NDISPLAYPAGES \NP.DISPLAY) (AND (EQ \MACHINETYPE \DAYBREAK) (EQ (\DoveDisplay.ScreenWidth) \WIDEDOVEDISPLAYWIDTH))) (* ;; "Sysout was made on a large screen daybreak, or is now being run on one. Need to make sure there is space for all that display") \RP.AFTERDOVEDISPLAY) (T \RP.AFTERDISPLAY))) (* ;  "Construct real page table in segment zero after the display") [COND ((> RPSIZE (CONSTANT (EXPT 2 15))) (* ;  "We only have 15 bits for real page table numbers, so have to sacrifice the rest of memory") (SETQ RPSIZE (CONSTANT (EXPT 2 15] [SETQ RPTPAGES (PROGN (* ;; "This is a way of computing (FOLDHI RPSIZE*3 WORDSPERPAGE) that won't overflow when memory exceeds 10.6MB -- the first term computes RPSIZE*3/256, the second performs the FOLDHI directly on the now much smaller remainder.") (+ (TIMES3 (FOLDLO RPSIZE WORDSPERPAGE)) (FOLDHI (TIMES3 (IMOD RPSIZE WORDSPERPAGE)) WORDSPERPAGE] (COND ((> (+ RPTPAGES FIRSTRP) PAGESPERSEGMENT) (* ;; "No space in bank zero, so put RPT in first segment after 2 megabytes, where the first `shadow' display bank lives. No shadow bank on Daybreak, but this is as good a place as any") (SETQ FIRSTRP (IMIN 2MBPAGES (- NREALPAGES RPTPAGES))) (* ;  "IMIN because we could be on a wide-display Daybreak with small memory") [COND ((> (+ FIRSTVP RPTPAGES) \VP.BUFFERS) (* ;  "Move virtual assignment backwards if necessary") (SETQ FIRSTVP (COND ((< RPTPAGES \VP.BUFFERS) (- \VP.BUFFERS RPTPAGES)) ((<= RPTPAGES PAGESPERSEGMENT) (* ;  "Can't fit real page table in display bank at all, so overlap smallneg space") (UNFOLD \SmallNegHi PAGESPERSEGMENT)) (T (* ;  "Ack, more than 10.6 MB, have to slop over into smallpos space") (- (+ (UNFOLD \SmallNegHi PAGESPERSEGMENT) PAGESPERSEGMENT) RPTPAGES] (\DL.UNMAPPAGES (DLFPFROMRP FIRSTRP) (DLFPFROMRP (+ FIRSTRP RPTPAGES -1))) (* ; "Unmap the pages in which RPT lives. This was already done on DLion, but can't hurt to do it again") )) (for I from 0 to (SUB1 RPTPAGES) do (* ;  "Assign pages to real page table now") (\WRITEMAP (+ FIRSTVP I) (+ FIRSTRP I) \VMAP.CLEAN)) (SETQ \REALPAGETABLE (create POINTER PAGE# _ FIRSTVP)) (\CLEARWORDS \REALPAGETABLE RPSIZE) (\CLEARWORDS (\ADDBASE \REALPAGETABLE RPSIZE) RPSIZE) (\CLEARWORDS (\ADDBASE (\ADDBASE \REALPAGETABLE RPSIZE) RPSIZE) RPSIZE) (* ;  "Clear table in three steps, since 3*RPSIZE overflows after 10MB") (SETQ \RPTSIZE RPSIZE) (COND [(EQ \MACHINETYPE \DANDELION) (for NEXTBANK0 from 2MBPAGES by 2MBPAGES until (> NEXTBANK0 NREALPAGES) do (* ;  "Mark the shadow display bank pages unavailable") (\DL.MARK.PAGES.UNAVAILABLE NEXTBANK0 (+ NEXTBANK0 PAGESPERSEGMENT -1] (T (* ;; "RPT itself occupies unavailable pages; on DLion these were marked unavailable either in segment zero after display or as part of shadow bank") (\DL.MARK.PAGES.UNAVAILABLE FIRSTRP (+ FIRSTRP RPTPAGES -1)) (* ;  "Also, Dove IO region is unavailable") (\DL.MARK.PAGES.UNAVAILABLE \RP.DOVEIORGN (SUB1 (+ \RP.DOVEIORGN \DOVEIORGNSIZE] (PROGN (* ;; "Fill in special cases in RPT -- the display, which is not where FPTOVP says it is, and all the pages that are unavailable for one reason or another. Note: any page marked unavailable here MUST be unmapped by now, either because booting never put it where FPTOVP says it would be, there's no page there to begin with, or there's an explicit call to \WRITEMAP or \DL.UNMAPPAGES to unmap it above") (SETQ RPTBASE \REALPAGETABLE) [for I from 0 to (SUB1 NDISPLAYPAGES) do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH)) (* ; "Fill in Display pages") (replace (RPT VP) of RPTBASE with (+ \VP.DISPLAY I)) (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP (+ \RP.TEMPDISPLAY I] (\DL.MARK.PAGES.UNAVAILABLE NDISPLAYPAGES \RP.IOPAGE) (* ;  "Mark rest of segment zero plus Map and IOPAGE unavailable") ) [PROGN (* ;  "fill in main part of RPT by reading FPTOVP") (for I from (ADD1 \RP.IOPAGE) to (SUB1 NREALPAGES) as [FPBASE _ (\ADDBASE \FPTOVP (DLFPFROMRP (ADD1 \RP.IOPAGE] by (\ADDBASE FPBASE 1) as [RPTBASE _ (fetch RPTRBASE of (RPTFROMRP (ADD1 \RP.IOPAGE ] by (\ADDBASE RPTBASE \RPTENTRYLENGTH) bind (LASTREALPAGE _ (DLRPFROMFP (fetch (IFPAGE NActivePages) of \InterfacePage))) do (* ;; "Fill in rest of RPT from \FPTOVP. Could optimize this a little by special casing the area occupied by the display, but this is simpler") (COND ((fetch (RPT UNAVAILABLE) of RPTBASE)) ((AND (<= I LASTREALPAGE) (fetch FPOCCUPIED of FPBASE) [NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS (SETQ VP (fetch FPVIRTUALPAGE of FPBASE] (EQ I (\READRP VP))) (* ;; "There is a VP assigned to this filepage, and it is still there. False for display that got moved and any real pages that didn't get filled. LASTREALPAGE is in case the real memory is larger than the sysout -- FPTOVP does not exist all the way") (replace (RPT VP) of RPTBASE with VP) (replace (RPT FILEPAGE) of RPTBASE with (DLFPFROMRP I))) (T (replace (RPT EMPTY) of RPTBASE with T] (PROGN (* ;  "Touch up RPT with the exceptions") (SETQ RPTBASE (fetch RPTRBASE of (RPTFROMRP IFPAGERP))) (* ; "Interface Page") (replace (RPT VP) of RPTBASE with \VP.IFPAGE) (replace (RPT FILEPAGE) of RPTBASE with \FP.IFPAGE) (replace (RPT UNAVAILABLE) of (fetch RPTRBASE of (RPTFROMRP IOCBRP)) with T) (* ; "\IOCBPAGE") (\DL.MARK.PAGES.UNAVAILABLE FIRSTBUFFERRP (SUB1 FIRSTUSEFULRP)) (* ;  "buffer pages unavailable to swapper") ) (\CHAIN.UP.RPT) (PROG ((NBUFFERS (- FIRSTUSEFULRP FIRSTBUFFERRP))) (* ; "Allocate buffers") (for I from 0 to (SUB1 NBUFFERS) do (\WRITEMAP (+ \VP.BUFFERS I) (+ FIRSTBUFFERRP I) \VMAP.CLEAN)) (\DL.ASSIGNBUFFERS (create POINTER PAGE# _ \VP.BUFFERS) NBUFFERS]) (\DL.UNMAPPAGES [LAMBDA (FIRSTFP LASTFP) (* bvm%: "14-Jan-84 14:20") (* ;;; "At initialization time, unmap anything that originally lived in filepages FIRSTFP thru LASTFP") (for FP from FIRSTFP to LASTFP as (FPBASE _ (\ADDBASE \FPTOVP FIRSTFP)) by (\ADDBASE FPBASE 1) when (fetch FPOCCUPIED of FPBASE) do (\WRITEMAP (fetch FPVIRTUALPAGE of FPBASE) 0 \VMAP.VACANT]) (\DL.MARK.PAGES.UNAVAILABLE [LAMBDA (FIRSTRP LASTRP) (* bvm%: "14-Jan-84 14:32") (for I from FIRSTRP to LASTRP as (RPTBASE _ (fetch RPTRBASE of (RPTFROMRP FIRSTRP))) by (\ADDBASE RPTBASE \RPTENTRYLENGTH) do (replace (RPT UNAVAILABLE) of RPTBASE with T]) (\DL.ASSIGNBUFFERS [LAMBDA (BASE NPAGES) (* bvm%: "29-Jan-85 19:05") (PROGN (* ;  "Allocate a page to hold name and password, and perhaps other ephemeral things") (\CLEARWORDS BASE WORDSPERPAGE) (replace (IFPAGE UserNameAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 1 ))) (replace (IFPAGE UserPswdAddr) of \InterfacePage with (\LOLOC (\ADDBASE BASE 33))) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -1)) (PROGN (* ; "Assign swap buffer") (SETQ \EMBUFBASE BASE) (SETQ \EMBUFVP (fetch (POINTER PAGE#) of BASE)) (SETQ \EMBUFRP (\READRP \EMBUFVP)) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -1)) (PROGN (* ; "Assign ether buffers") (replace (IFPAGE MDSZoneLength) of \InterfacePage with (UNFOLD 2 WORDSPERPAGE) ) (replace (IFPAGE MDSZone) of \InterfacePage with (\LOLOC BASE)) (SETQ BASE (\ADDBASE BASE (UNFOLD 2 WORDSPERPAGE))) (SETQ \TELERAIDBUFFER BASE) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE)) (add NPAGES -3)) (PROGN (* ; "Divvy up buffer space") (SETQ \#SWAPBUFFERS (SETQ \#EMUBUFFERS NPAGES)) (SETQ \#DISKBUFFERS 0) (SETQ \EMUSWAPBUFFERS (SETQ \EMUBUFFERS BASE]) (\CHAIN.UP.RPT [LAMBDA NIL (* bvm%: "18-Dec-84 16:07") (* ;;; "Maps over the Real Page Table as constructed so far and fleshes it out. Assumes that the table is built, has all its VP and FILEPAGE entries set, and that the empty and unavailable entries are so marked. Finishes the job by chaining together the available pages and setting the LOCKED bits") (PROG ((RPTBASE \REALPAGETABLE) (LASTEMPTY \REALPAGETABLE) (LASTUSED (\ADDBASE \REALPAGETABLE 1)) FIRSTUSED) (SETQ FIRSTUSED LASTUSED) (* ;; "The `entry' \REALPAGETABLE is a dummy that points to the least recently used entry. We use the second word of that dummy as a temporary chain head for the used pages, so that we can put all the empty pages at the front of the queue.") [for I from 1 to (SUB1 \RPTSIZE) do (SETQ RPTBASE (\ADDBASE RPTBASE \RPTENTRYLENGTH)) (COND ((fetch (RPT UNAVAILABLE) of RPTBASE)) ((fetch (RPT EMPTY) of RPTBASE) (replace (RPT NEXTRP) of LASTEMPTY with I) (replace (RPT LOCKED) of RPTBASE with NIL) (SETQ LASTEMPTY RPTBASE)) (T (replace (RPT NEXTRP) of LASTUSED with I) (replace (RPT LOCKED) of RPTBASE with (\LOCKEDPAGEP (fetch (RPT VP) of RPTBASE))) (SETQ LASTUSED RPTBASE] (* ;  "Finally, link the end of empty chain to front of in use chain") (replace (RPT NEXTRP) of LASTEMPTY with (fetch (RPT NEXTRP) of FIRSTUSED )) (replace (RPT NEXTRP) of (SETQ \RPTLAST LASTUSED) with \PAGETABLESTOPFLG) (replace (RPT UNAVAILABLE) of \REALPAGETABLE with T) (* ; "Dummy first entry") ]) ) (* ; "Pagefault handler") (DEFINEQ (\FAULTHANDLER [LAMBDA NIL (* ; "Edited 27-Sep-88 00:47 by jds") (PROG NIL LP [OR (AND \DOFAULTINIT (\FAULTINIT)) (\PAGEFAULT (\VAG2 (LOGAND 255 (fetch (IFPAGE FAULTHI) of \InterfacePage)) (fetch (IFPAGE FAULTLO) of \InterfacePage] (\CONTEXTSWITCH \FAULTFXP) (GO LP]) (\PAGEFAULT [LAMBDA (PTR) (* bvm%: "13-Aug-85 16:38") (\CLOCK0 (LOCF (fetch SWAPTEMP0 of \MISCSTATS))) (* ; "Note time of start") (PROG ((VP (fetch (POINTER PAGE#) of PTR)) FLAGS FILEPAGE) (COND ((fetch (VP INVALID) of VP) (* ;  "Map out of bounds on Dolphin always produces -1 as the vp. Don't know about other machines") (\MP.ERROR \MP.MOB "Page Fault: Map out of bounds" (AND (NEQ VP 65535) PTR) T)) ([NOT (fetch (VMEMFLAGS VACANT) of (SETQ FLAGS (\READFLAGS VP] (\MP.ERROR \MP.RESIDENT "Fault on resident page" PTR T)) ((EQ (SETQ FILEPAGE (\LOOKUPPAGEMAP VP)) 0) (\INVALIDADDR PTR)) (T (COND ((EQ (\HILOC PTR) \STACKHI) (* ;  "should never happen. For debugging") (\MP.ERROR \MP.STACKFAULT "Fault on stack" PTR T))) (\LOADVMEMPAGE VP FILEPAGE))) (COND (\NEWVMEMPAGEADDED (* ;  "Only happens if VMEM.PURE.STATE on") (\ASSURE.FPTOVP.PAGE))) [\BOXIPLUS (LOCF (fetch SWAPWAITTIME of \MISCSTATS)) (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch SWAPTEMP1 of \MISCSTATS))) (LOCF (fetch SWAPTEMP0 of \MISCSTATS] (* ; "Count the time used.") (RETURN PTR]) (\INVALIDADDR [LAMBDA (ADDR) (* bvm%: " 6-AUG-83 22:25") (\MP.ERROR \MP.INVALIDADDR "Invalid address" ADDR T]) (\INVALIDVP [LAMBDA (VP) (* bvm%: " 6-AUG-83 22:25") (\MP.ERROR \MP.INVALIDVP "Invalid VP" VP]) (\FLUSHPAGE [LAMBDA (RPTINDEX FROMFLUSHVM) (* bvm%: "13-Aug-85 16:35") (* ;;; "Write out real page RPTINDEX if it is dirty.") (PROG ((RPTR (fetch RPTRBASE of RPTINDEX)) VP FP NEWFP) (COND ([AND (fetch (RPT OCCUPIED) of RPTR) (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (SETQ VP (fetch (RPT VP) of RPTR] (* ; "Yes, page is dirty") (SETQ FP (fetch (RPT FILEPAGE) of RPTR)) [COND [(AND \VMEM.PURE.LIMIT (NOT FROMFLUSHVM)) (* ;  "Don't sully vmem; write page out beyond the original end of vmem") (COND ((ILEQ FP \VMEM.PURE.LIMIT) (COND ((fetch (RPT LOCKED) of RPTR) (\MP.ERROR \MP.WRITING.LOCKED.PAGE))) (SETQ NEWFP (add (fetch NActivePages of \InterfacePage) 1)) (COND ((IGREATERP NEWFP (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL)) (\SET.VMEM.FULL.STATE))) (SETQ \NEWVMEMPAGEADDED T) (\PUTBASE (.PAGEMAPBASE. VP) 0 NEWFP) (\PUTBASE \FPTOVP NEWFP VP) (\PUTBASE \FPTOVP FP \NO.VMEM.PAGE) (replace (RPT FILEPAGE) of RPTR with (SETQ FP NEWFP] ((.VMEM.CONSISTENTP.) (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey)) (* ;  "Invalidate vmem and write out the Interface page") (SETQ \DIRTYPAGEHINT 0) (* ;  "So that the dirty page background writer wakes up") (PROG ((IFVP (fetch (POINTER PAGE#) of \InterfacePage))) (\TRANSFERPAGE IFVP \FirstVmemBlock (RPTFROMRP (\READRP IFVP)) T NIL] (* ; "Write it out") (COND ((IGREATERP \DIRTYPAGEHINT 0) (add \DIRTYPAGEHINT -1))) (\TRANSFERPAGE VP FP RPTINDEX T NIL]) (\LOADVMEMPAGE [LAMBDA (VPAGE FILEPAGE NEWPAGEFLG LOCK? DONTMOVETOPFLG) (* bvm%: "10-Aug-85 18:08") (* ;; "Fault in virtual page VPAGE known to live in FILEPAGE on the vmem. NEWPAGEFLG is true if the page is new, so should just be cleared, not loaded from vmem file. If LOCK? is true, locks down the page as well. In this case, if on Dandelion, we also check for page wanting to live in a particular real page. If DONTMOVETOPFLG is true, the real page we put this page in is not promoted to the front of the LRU queue of pages") (COND ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ) (\UPDATECHAIN))) (add \PAGEFAULTCOUNTER 1) (PROG ((RPTINDEX (\SELECTREALPAGE FILEPAGE LOCK? DONTMOVETOPFLG)) RPTBASE SPECIALRP) (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX)) [COND ((AND LOCK? (OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK)) (SETQ SPECIALRP (\SPECIALRP VPAGE))) (* ; "Must actually put FILEPAGE into special RP, and thus move old contents of SPECIALRP into RPTINDEX") (LET* ((SRINDEX (RPTFROMRP SPECIALRP)) (SRPTR (fetch RPTRBASE of SRINDEX))) (\MOVEREALPAGE SRINDEX SRPTR RPTINDEX RPTBASE) (SETQ RPTINDEX SRINDEX) (SETQ RPTBASE SRPTR] (* ;  "Fill in new RPTINDEX with appropriate data") (replace (RPT VP) of RPTBASE with VPAGE) (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE) (replace (RPT LOCKED) of RPTBASE with LOCK?) (COND ([AND DOLOCKCHECKS (NOT LOCK?) (EQ (LRSH VPAGE 8) (CONSTANT (\HILOC \PAGEMAP] (\MP.ERROR \MP.MAPNOTLOCKED "Page of page map being loaded but not locked" VPAGE))) (\TRANSFERPAGE VPAGE FILEPAGE RPTINDEX NIL NEWPAGEFLG]) (\MOVEREALPAGE [LAMBDA (SOURCEINDEX SOURCERPT DESTINDEX DESTRPT) (* bvm%: "14-Aug-85 13:53") (* ;;; "Moves the page, if any, currently living in real page table SOURCEINDEX & SOURCERPT into the page indicated by DESTINDEX & DESTRPT. The destination is assumed to have been vacated") (CHECK (NOT (fetch (RPT LOCKED) of SOURCERPT))) (replace (RPT LOCKED) of DESTRPT with NIL) [COND ((fetch (RPT OCCUPIED) of SOURCERPT) (* ;  "Page was not vacant to start with") (LET* ((SOURCEVP (fetch (RPT VP) of SOURCERPT)) (SOURCEFLAGS (\READFLAGS SOURCEVP))) (replace (RPT VP) of DESTRPT with SOURCEVP) (replace (RPT FILEPAGE) of DESTRPT with (fetch (RPT FILEPAGE) of SOURCERPT)) (\WRITEMAP \EMBUFVP (RPFROMRPT DESTINDEX) 0) (* ; "Map buffer to target page") (\BLT \EMBUFBASE (create POINTER PAGE# _ SOURCEVP) WORDSPERPAGE) (* ; "move data to buffer page") (\WRITEMAP \EMBUFVP \EMBUFRP 0) (* ;  "Restore buffer to its proper page") (\WRITEMAP SOURCEVP (RPFROMRPT DESTINDEX) SOURCEFLAGS) (* ; "Set flags and new RP for page") ] DESTINDEX]) (\LOOKUPPAGEMAP [LAMBDA (VP) (* bvm%: "20-Oct-86 18:26") (* ;; "Returns the pagemap entry for VP, which is expected to be in bounds. High bit of result is the lock bit. Zero denotes absence") (LET [(PRIMENTRY (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP] (COND ((EQ PRIMENTRY \EMPTYPMTENTRY) 0) (T (\GETBASE \PAGEMAP (IPLUS PRIMENTRY (fetch (VP SECONDARYKEY) of VP]) (\VALIDADDRESSP [LAMBDA (BASE) (* bvm%: "16-Jun-86 11:30") (NEQ 0 (\LOOKUPPAGEMAP (fetch (POINTER PAGE#) of BASE]) (\LOCKEDPAGEP [LAMBDA (VP TEMP) (* bvm%: "18-Feb-85 18:08") (* ;;; "True if VP is locked. If TEMP is NIL consults only the locked page table; otherwise, also checks for `temporary' locked page") (OR (NEQ 0 (LOGAND (.LOCKEDVPMASK. VP) (\GETBASE (.LOCKEDVPBASE. VP) 0))) (UNLESSRDSYS (AND TEMP (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP))) (fetch (RPT LOCKED) of (fetch RPTRBASE of (RPTFROMRP (\READRP VP]) (\SELECTREALPAGE [LAMBDA (NEWFP LOCK? DONTMOVETOPFLG) (* bvm%: "10-Aug-85 18:08") (* ;; "Selects a real page, flushing it if necessary, and returns the RPT index of the page. NEWFP, if supplied, is the filepage that will be read into here. This might influence page choice by minimizing seek time. LOCK? means caller intends to lock the page, which constrains which real pages it can fall into. The selected page is moved to the back of the LRU queue, so that it won't be selected again soon, unless DONTMOVETOPFLG is true. If DONTMOVETOPFLG is REMOVE then the page is spliced out of the chain forever.") (PROG ((TRIES 0) (CNTR \MAXCLEANPROBES) (DISTANCE \MINSHORTSEEK) PREVRPT PREVINDEX RPTINDEX RPTBASE FP FLAGS) RETRY (SETQ PREVRPT \REALPAGETABLE) (until (EQ (SETQ RPTINDEX (fetch (RPT NEXTRP) of PREVRPT)) \PAGETABLESTOPFLG) do (SETQ RPTBASE (fetch RPTRBASE of RPTINDEX)) [COND ((fetch (RPT EMPTY) of RPTBASE) (RETURN PREVRPT)) ((NOT (fetch (RPT OCCUPIED) of RPTBASE)) (\MP.ERROR \MP.CHAIN.UNAVAIL "UNAVAILABLE page on Chain")) ([AND (NOT (fetch (RPT LOCKED) of RPTBASE)) [NOT (fetch (VMEMFLAGS REFERENCED) of (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTBASE ] (OR (NOT LOCK?) (.LOCKABLERP. (RPFROMRPT RPTINDEX] (* ;; "Page is unlocked and unreferenced, so is good candidate for flushing. LOCK? check is to avoid locking a page into a real page that might be desired by code that cares about real pages") (COND ([OR (NOT (fetch (VMEMFLAGS DIRTY) of FLAGS)) (PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTBASE)) (COND ((SELECTQ \VMEM.INHIBIT.WRITE (NIL [SELECTQ \VMEM.FULL.STATE (NIL (* ; "Normal, can write anything") T) (T (* ;  "Vmem is full and clean, don't write anything") NIL) (PROGN (* ;  "Vmem is full, but sullied, so might as well write anything for which there is space") (AND (ILEQ FP \LASTVMEMFILEPAGE) (OR (NULL \VMEM.PURE.LIMIT) (IGREATERP FP \VMEM.PURE.LIMIT ]) (NEW (* ;  "Only allowed to write old pages, since new pages might just have to get moved a second time") (ILEQ FP \VMEM.PURE.LIMIT)) (PROGN (* ;  "We are forbidden from writing any page") NIL)) (COND ((OR (ILEQ CNTR 0) (NULL NEWFP) (ILESSP (IABS (IDIFFERENCE FP NEWFP)) DISTANCE)) (* ;  "Page is near replacement, or we have given up trying for closeness") T) (T (* ;  "Page is too far away from replacement page") (SETQ CNTR (SUB1 CNTR)) [COND ((ILESSP DISTANCE \MAXSHORTSEEK) (* ; "Get more liberal") (SETQ DISTANCE (LLSH DISTANCE 1] NIL] [COND (DOLOCKCHECKS (COND ((fetch (RPT LOCKED) of RPTBASE) (\MP.ERROR \MP.FLUSHLOCKED "Attempt to displace locked page" RPTBASE)) ((EQ (fetch (RPT VPSEG) of RPTBASE) (CONSTANT (\HILOC \PAGEMAP))) (\MP.ERROR \MP.MAPNOTLOCKED "A page of the page map is not locked" RPTBASE ] (\FLUSHPAGE RPTINDEX) (\WRITEMAP (fetch (RPT VP) of RPTBASE) 0 \VMAP.VACANT) (replace (RPT EMPTY) of RPTBASE with T) (RETURN PREVRPT] (SETQ PREVRPT RPTBASE) (SETQ PREVINDEX RPTINDEX) finally (* ;; "Couldn't find an unreffed page because all pages were touched since last \UPDATECHAIN. Do another, which clears ref bits, and try again") (COND ((EQ TRIES 0) (SETQ TRIES 1) (\UPDATECHAIN)) [(AND (EQ TRIES 1) \VMEM.INHIBIT.WRITE) (SETQ \VMEM.INHIBIT.WRITE) (COND ((AND (NEQ \MACHINETYPE \DANDELION) (NEQ \MACHINETYPE \DAYBREAK)) (* ;; "Don't call RAID on a DLion, since the interface is so bad. Dorado user might want to know that we're smashing \VMEM.INHIBIT.WRITE") (RAID "No clean vmem pages to reuse, must write one. ^N to continue" ] (T (\MP.ERROR \MP.SELECTLOOP "Loop in \SELECTREALPAGE"))) (GO RETRY)) (SELECTQ DONTMOVETOPFLG (NIL (* ;  "Move this page to head of chain, so that it won't be picked again soon") (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP) of RPTBASE)) (* ; "Splice RPTINDEX out of chain") (replace (RPT NEXTRP) of \RPTLAST with RPTINDEX) (* ; "Put new page at end of chain") (replace (RPT NEXTRP) of (SETQ \RPTLAST RPTBASE) with \PAGETABLESTOPFLG)) (REMOVE (* ;  "Splice this page out of chain altogether") (replace (RPT NEXTRP) of PREVRPT with (fetch (RPT NEXTRP) of RPTBASE)) (replace (RPT NEXTRP) of RPTBASE with \PAGETABLESTOPFLG)) NIL) (RETURN RPTINDEX]) (\SPECIALRP [LAMBDA (VP) (* edited%: " 9-Aug-85 17:14") (* ;; "for \DANDELION, some virtual pages must be mapped into special real pages. This function returns the corresponding real page") (SELECTC (FOLDLO VP PAGESPERSEGMENT) ((FOLDLO \VP.STACK PAGESPERSEGMENT) (IPLUS VP (IDIFFERENCE \RP.STACK \VP.STACK))) ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) (IPLUS VP (IDIFFERENCE \RP.DISPLAY \VP.DISPLAY))) NIL]) (\TRANSFERPAGE [LAMBDA (VP FILEPAGE RPTINDEX WRITE? NEWPAGE?) (* MPL "27-Jul-85 21:28") (* ;; "Transfers virtual page VP between page FILEPAGE of the vmem and real page RPTINDEX. WRITE? indicates direction of transfer. If NEWPAGE?, then page does not exist on file, and is simply cleared") (PROG (NEWFLAGS) (COND (WRITE? (FLIPCURSORBAR 15)) (T (FLIPCURSORBAR 0))) (SETQ NEWFLAGS (COND (NEWPAGE? \VMAP.DIRTY) (WRITE? (LOGAND (\READFLAGS VP) (LOGNOT16 \VMAP.DIRTY))) (T 0))) (COND ((AND WRITE? (fetch (RPT LOCKED) of (fetch RPTRBASE of RPTINDEX))) (* ;; "Writing a locked page: can't diddle map, because others might die, so do this in the straightforward way") (\BLT \EMBUFBASE (create POINTER PAGE# _ VP) WORDSPERPAGE) (* ;  "Copy page into buffer, then write the buffer out") (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 T) (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE)) ((NOT NEWPAGE?) (* ;  "Map the buffer page into the target real page, read/write the page, then set the map back") (\WRITEMAP VP 0 \VMAP.VACANT) (* ;  "Unmap VP so that we don't have two virtual pages pointing at same real page") (\WRITEMAP \EMBUFVP (RPFROMRPT RPTINDEX) 0) (* ; "Map buffer to target page") (\ACTONVMEMFILE FILEPAGE \EMBUFBASE 1 WRITE?) (* ; "Do the i/o") (\WRITEMAP \EMBUFVP \EMBUFRP 0) (* ;  "Restore buffer to its proper page") (SETQ \LASTACCESSEDVMEMPAGE FILEPAGE))) (\WRITEMAP VP (RPFROMRPT RPTINDEX) NEWFLAGS) (* ; "Set flags for page") (COND (NEWPAGE? (* ;  "Not on file yet, so clear it. Couldn't do this sooner because the flags weren't set") (\CLEARWORDS (create POINTER PAGE# _ VP) WORDSPERPAGE))) (COND (WRITE? (FLIPCURSORBAR 15) (\BOXIPLUS (LOCF (fetch SWAPWRITES of \MISCSTATS)) 1)) (T (FLIPCURSORBAR 0) (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS)) 1]) (\UPDATECHAIN [LAMBDA NIL (* bvm%: "30-Jul-85 15:20") (* ;  "Sorts the page chain by reference bit") (CHECK (NOT \INTERRUPTABLE)) (PROG ((RPTINDEX (fetch (RPT NEXTRP) of \REALPAGETABLE)) (CHAIN0 \REALPAGETABLE) (CHAIN1 (\ADDBASE \REALPAGETABLE 2)) RPTR VP FLAGS HEAD1) (SETQ HEAD1 CHAIN1) (* ;; "HEAD1 = CHAIN1 is just a holding cell for the second Chain we temporarily create inside here. Use the unused third word of the dummy header entry of \REALPAGETABLE") (replace (RPT NEXTRP) of CHAIN0 with \PAGETABLESTOPFLG) (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG) (do (SETQ RPTR (fetch RPTRBASE of RPTINDEX)) (SETQ VP (fetch (RPT VP) of RPTR)) [SETQ FLAGS (COND ((fetch (RPT EMPTY) of RPTR) 0) (T (\READFLAGS VP] (COND ((OR (fetch (RPT LOCKED) of RPTR) (PROGN (COND ([AND DOLOCKCHECKS (EQ (fetch (RPT VPSEG) of RPTR) (CONSTANT (\HILOC \PAGEMAP] (\MP.ERROR \MP.MAPNOTLOCKED "A page of the page map is not locked" RPTR))) (fetch (VMEMFLAGS REFERENCED) of FLAGS))) (* ;  "Page referenced or locked, put on CHAIN1") (\WRITEMAP VP (RPFROMRPT RPTINDEX) (LOGAND FLAGS (LOGNOT16 \VMAP.REF))) (* ; "Turn off ref bit") (replace (RPT NEXTRP) of CHAIN1 with RPTINDEX) (SETQ CHAIN1 RPTR)) (T (* ;  "Page was not referenced recently, put on CHAIN0") (replace (RPT NEXTRP) of CHAIN0 with RPTINDEX) (SETQ CHAIN0 RPTR))) (SETQ RPTINDEX (fetch (RPT NEXTRP) of RPTR)) (* ; "Look at next page in old chain") repeatuntil (EQ RPTINDEX \PAGETABLESTOPFLG)) (replace (RPT NEXTRP) of CHAIN1 with \PAGETABLESTOPFLG) (* ; "End of the line") (replace (RPT NEXTRP) of CHAIN0 with (fetch (RPT NEXTRP) of HEAD1)) (* ;  "Link end of CHAIN0 to beginning of CHAIN1") (SETQ \RPTLAST (COND ((EQ HEAD1 CHAIN1) (* ; "Nothing on CHAIN1 ??!!") CHAIN0) (T CHAIN1))) (* ;  "Pointer to end of complete chain") (SETQ \DIRTYPAGECOUNTER (SETQ \PAGEFAULTCOUNTER 0]) ) (* ; "Allocating and locking new pages") (DEFINEQ (\NEWPAGE [LAMBDA (BASE NOERROR LOCK?) (* ;  "Edited 24-Oct-92 12:45 by sybalsky:mv:envos") (* ;;; "Creates and returns a new page located at virtual addr BASE") (* ;; "If LOCK?, lock the page into real memory (A NOP on nonXerox machines!)") (UNINTERRUPTABLY (COND [(NOT (\MISCAPPLY* (FUNCTION \DONEWPAGE) BASE LOCK?)) (* ; "Failed, page exists") (COND ((NOT NOERROR) (\MP.ERROR \MP.NEWPAGE "Attempt to allocate already existing page" BASE T))) (COND (LOCK? (\LOCKPAGES BASE 1] ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage) (IDIFFERENCE \LASTVMEMFILEPAGE \GUARDVMEMFULL)) (* ; "Vmem getting full!") (\SET.VMEM.FULL.STATE))) BASE)]) (\DONEWPAGE [LAMBDA (BASE LOCK? INTERNALFLG) (* bvm%: "13-Aug-85 16:32") (* ;;; "Allocates new page at BASE, locking it if LOCK? is true. Returns vmemfile page# on success, NIL if page already exists. Must be run in safe context! because it can cause vmem activity") (AND \DOFAULTINIT (\FAULTINIT)) (* ;  "Only an issue when INIT.SYSOUT starts. Perhaps there is a better place to put this") (PROG ((VP (fetch (POINTER PAGE#) of BASE)) MAPBASE LOCKBASE FILEPAGE NEXTPM ERRCODE) (RETURN (COND ((fetch (VP INVALID) of VP) (\INVALIDVP VP) NIL) (T (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))) (COND ((EQ MAPBASE \EMPTYPMTENTRY) (* ;  "Need to create a new second-level block") (SETQ NEXTPM (fetch (IFPAGE NxtPMAddr) of \InterfacePage)) [COND ((EVENP NEXTPM WORDSPERPAGE) (* ;; "Need a new secondary pagemap page. This recursion is ok, because we know that SETUPPAGEMAP assures that the pagemap pages for all the pages in secondary map space were created at MAKEINIT time") (OR (\DONEWPAGE (\ADDBASE \PAGEMAP NEXTPM) T T) (RETURN (\MP.ERROR \MP.NEWMAPPAGE "\DONEWPAGE failed to allocate new map page"] (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP) NEXTPM) (replace (IFPAGE NxtPMAddr) of \InterfacePage with (IPLUS NEXTPM \PMblockSize)) (SETQ MAPBASE NEXTPM))) [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY) of VP] (COND ((NEQ (\GETBASE MAPBASE 0) 0) (* ; "Page exists") (RETURN NIL))) (SETQ FILEPAGE (add (fetch (IFPAGE NActivePages) of \InterfacePage ) 1)) (replace (IFPAGE NDirtyPages) of \InterfacePage with FILEPAGE) (* ; "Currently a redundant field") [COND (LOCK? (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE)) (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP)) 0 (LOGOR (.LOCKEDVPMASK. VP) (\GETBASE LOCKBASE 0] (\PUTBASE \FPTOVP FILEPAGE VP) (\PUTBASE MAPBASE 0 FILEPAGE) (\LOADVMEMPAGE VP FILEPAGE T LOCK?) (COND (INTERNALFLG (SETQ \NEWVMEMPAGEADDED T)) (T (* ;  "Make sure \FPTOVP extended if necessary") (\ASSURE.FPTOVP.PAGE))) FILEPAGE]) (\ASSURE.FPTOVP.PAGE [LAMBDA NIL (* bvm%: "13-Aug-85 16:29") (* ;; "Called at the end of some swapping operation that added one or more pages to the vmem file, setting \NEWVMEMPAGEADDED true. If we're going to need a new page of \FPTOVP soon, do it now while there's still maneuvering room. The allowance below is for the worst case, which can happen when VMEM.PURE.STATE is on and \NEWPAGE was called needing a new pagemap page as well, in which case we could have as many as the following new vmem pages before we're home safe --- 1: \NEWPAGE added a page --- 2: a page was displaced by the new page and written to the end of the vmem --- 3: a new pagemap page was needed --- 4: it displaced a page to end of vmem --- 5: the new \FPTOVP page below --- 6: a page displaced by same. --- --- Alternatively, it could have been the new \FPTOVP page that needed a new pagemap block. Will never have both needing a new pagemap block, since there are several pagemap blocks per page") (LET ((FILEPAGE (fetch (IFPAGE NActivePages) of \InterfacePage))) (COND ((IGREATERP (IMOD FILEPAGE WORDSPERPAGE) (IDIFFERENCE WORDSPERPAGE 7)) (* ;  "This is a no-op if the page has already been allocated") (\DONEWPAGE (\ADDBASE \FPTOVP (CEIL FILEPAGE WORDSPERPAGE)) T T))) (SETQ \NEWVMEMPAGEADDED NIL]) (\MAKESPACEFORLOCKEDPAGE [LAMBDA (VP FILEPAGE) (* bvm%: "29-Jun-86 17:44") (* ;; "VP is a page to be locked, FILEPAGE its home. Returns a possibly new file page where VP will now live, after having kicked the former resident of the new file page into VP's old FILEPAGE") (PROG (DESIREDFP OLDVP FPBASE) [SETQ DESIREDFP (SELECTC (FOLDLO VP PAGESPERSEGMENT) ((FOLDLO \VP.STACK PAGESPERSEGMENT) (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.STACK) \VP.STACK))) ((FOLDLO \VP.DISPLAY PAGESPERSEGMENT) (* ;  "Display lives in a fixed place in file, but does not land there initially") (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.TEMPDISPLAY) \VP.DISPLAY))) ((FOLDLO \VP.FPTOVP PAGESPERSEGMENT) (* ;  "A new page of FPTOVP has to be continguous on file with other such pages") (IPLUS VP (IDIFFERENCE (DLFPFROMRP \RP.FPTOVP) \VP.FPTOVP))) (COND ((AND (ILEQ FILEPAGE (fetch LastLockedFilePage of \InterfacePage )) (IGREATERP FILEPAGE (DLFPFROMRP \RP.MISCLOCKED))) (* ;  "Page is in a good place already. It probably was once locked, then unlocked") (RETURN FILEPAGE)) (T (* ;  "Put it after all the other locked pages") (add (fetch LastLockedFilePage of \InterfacePage) 1] (COND ((AND (fetch FPOCCUPIED of (SETQ FPBASE (\ADDBASE \FPTOVP DESIREDFP))) (NEQ (SETQ OLDVP (fetch FPVIRTUALPAGE of FPBASE)) VP)) (* ;  "Someone else lives here, so move it out") (\MOVEVMEMFILEPAGE OLDVP DESIREDFP FILEPAGE))) (RETURN DESIREDFP]) (\MOVEVMEMFILEPAGE [LAMBDA (VP OLDFP NEWFP) (* bvm%: "18-Nov-84 14:14") (PROG ((FLAGS (\READFLAGS VP)) RP) (COND ((fetch (VMEMFLAGS VACANT) of FLAGS) (* ;  "Page not resident, so pull it in") (\LOADVMEMPAGE VP OLDFP) (SETQ FLAGS \VMAP.CLEAN)) ((\LOCKEDPAGEP VP) (\MP.ERROR \MP.BADLOCKED "Locked page is in the way" VP))) (\WRITEMAP VP (SETQ RP (\READRP VP)) (LOGOR FLAGS \VMAP.DIRTY)) (* ;  "Mark page dirty, so that it will eventually be written to its new home") (replace (RPT FILEPAGE) of (fetch RPTRBASE of (RPTFROMRP RP)) with NEWFP) (* ; "Tell RPT where VP now lives") (\PUTBASE (.PAGEMAPBASE. VP) 0 NEWFP) (* ; "Tell \PAGEMAP about it") (\PUTBASE \FPTOVP NEWFP VP) (* ; "... and \FPTOVP") ]) (\NEWEPHEMERALPAGE [LAMBDA (BASE NOERROR) (* bvm%: "26-NOV-82 15:40") (* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file") (\MISCAPPLY* (FUNCTION \DONEWEPHEMERALPAGE) BASE NOERROR]) (\DONEWEPHEMERALPAGE [LAMBDA (BASE NOERROR) (* bvm%: "30-Oct-86 16:47") (* ;;; "Creates and returns a new page located at virtual addr BASE, mapping it permanently into some real page but leaving it out of the vmem file") (LET ((VP (fetch (POINTER PAGE#) of BASE)) MAPBASE PREVRP RPTINDEX RPTR) (COND ((fetch (VP INVALID) of VP) (\INVALIDVP VP) NIL) ([OR (AND (NEQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))) \EMPTYPMTENTRY) (NEQ (\GETBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY) of VP))) 0)) (NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP] (* ;  "Page is in the vmem already, so no hope") (COND ((NOT NOERROR) (\MP.ERROR \MP.NEWPAGE "Page already exists " BASE T))) BASE) (T (COND ((IGREATERP \PAGEFAULTCOUNTER \UPDATECHAINFREQ) (\UPDATECHAIN))) (add \PAGEFAULTCOUNTER 1) (SETQ RPTINDEX (\SELECTREALPAGE NIL T 'REMOVE)) (* ; "Find a page to put this in") (SETQ RPTR (fetch RPTRBASE of RPTINDEX)) (* ;  "Fill in new RPTINDEX with appropriate data") (replace (RPT VP) of RPTR with \RPT.UNAVAILABLE) (replace (RPT FILEPAGE) of RPTR with VP) (* ; "For debugging only") (FLIPCURSORBAR 0) (\WRITEMAP VP (RPFROMRPT RPTINDEX) \VMAP.DIRTY) (* ; "Set flags for page") (\CLEARWORDS (create POINTER PAGE# _ VP) WORDSPERPAGE) (* ; "Clear new page") (FLIPCURSORBAR 0) (\BOXIPLUS (LOCF (fetch PAGEFAULTS of \MISCSTATS)) 1) (COND (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE))) BASE]) (\LOCKPAGES [LAMBDA (BASE NPAGES) (* bvm%: "26-NOV-82 15:17") (* ;; "Needs to be done in safe stack context because might cause vmem transfer") (\MISCAPPLY* (FUNCTION \DOLOCKPAGES) BASE NPAGES) BASE]) (\DOLOCKPAGES [LAMBDA (BASE NPAGES) (* ; "Edited 21-Oct-87 15:49 by bvm:") (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#) of BASE)) FILEPAGE MAPBASE RPTBASE RPINDEX RP MASK LOCKBASE do [COND ((fetch (VP INVALID) of VP) (\INVALIDVP VP)) [(EQ (SETQ MAPBASE (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))) \EMPTYPMTENTRY) (\INVALIDADDR (ADDBASE BASE (UNFOLD I WORDSPERPAGE] (T [SETQ MAPBASE (\ADDBASE \PAGEMAP (IPLUS MAPBASE (fetch (VP SECONDARYKEY) of VP] (SETQ FILEPAGE (\GETBASE MAPBASE 0)) (COND ((EQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP)) (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP)) 0))) (* ; "Not locked yet") (COND ((fetch VACANT of (\READFLAGS VP)) (* ;  "Bring locked page into core so we can move it if necessary") (\LOADVMEMPAGE VP FILEPAGE NIL T))) [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP] (SETQ RPTBASE (fetch RPTRBASE of RPINDEX)) [COND ((AND (NOT (.LOCKABLERP. RP)) (NOT (\SPECIALRP VP))) (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now. If \SPECIALRP is true then we know that the page got swapped into the right place, so no need to move it.") (LET* ((NEWINDEX (\SELECTREALPAGE NIL T)) (NEWRPT (fetch RPTRBASE of NEWINDEX))) (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT) (replace (RPT EMPTY) of RPTBASE with T) (* ; "Mark vacated RPT entry empty") (SETQ RPTBASE NEWRPT) (SETQ RP (RPFROMRPT NEWINDEX] (COND ((NEQ FILEPAGE (SETQ FILEPAGE (\MAKESPACEFORLOCKEDPAGE VP FILEPAGE))) (* ;; "Moving to a new page, so have to mark this locked page dirty so that it will eventually get written to its new home") (\WRITEMAP VP RP (LOGOR \VMAP.DIRTY \VMAP.REF)) (replace (RPT FILEPAGE) of RPTBASE with FILEPAGE) (\PUTBASE \FPTOVP FILEPAGE VP) (\PUTBASE MAPBASE 0 FILEPAGE))) (\PUTBASE LOCKBASE 0 (LOGOR MASK (\GETBASE LOCKBASE 0))) (* ; "Set lock bit in page map") (replace (RPT LOCKED) of RPTBASE with T] (add VP 1) finally (COND (\NEWVMEMPAGEADDED (* ;  "If we had to load or rearrange pages, vmem could have gotten bigger if VMEM.PURE.STATE on") (\ASSURE.FPTOVP.PAGE]) (\TEMPLOCKPAGES [LAMBDA (BASE NPAGES) (* bvm%: "10-Aug-85 18:17") (* ;;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages. Information vanishes at logout etc.") (\MISCAPPLY* (FUNCTION \DOTEMPLOCKPAGES) BASE NPAGES]) (\DOTEMPLOCKPAGES [LAMBDA (BASE NPAGES) (* ; "Edited 21-Oct-87 15:49 by bvm:") (* ;; "`Temporarily' locks BASE for NPAGES, i.e. ensures that the swapper will not move the pages. Information vanishes at logout etc. This function must be locked because it manipulates the page table table. Runs in MISC context") (to NPAGES as VP from (fetch (POINTER PAGE#) of BASE) bind RPTBASE RPINDEX RP do (\TOUCHPAGE BASE) (* ; "Touch page in case not resident") [SETQ RPINDEX (RPTFROMRP (SETQ RP (\READRP VP] (SETQ RPTBASE (fetch RPTRBASE of RPINDEX)) [COND ((NOT (.LOCKABLERP. RP)) (* ;; "Page already swapped in, but lives in a real page that might need to get bumped (e.g., for stack), so move it now") (LET* ((NEWINDEX (\SELECTREALPAGE NIL T)) (NEWRPT (fetch RPTRBASE of NEWINDEX))) (\MOVEREALPAGE RPINDEX RPTBASE NEWINDEX NEWRPT) (replace (RPT EMPTY) of RPTBASE with T) (* ; "Mark vacated RPT entry empty") (SETQ RPTBASE NEWRPT] (replace (RPT LOCKED) of RPTBASE with T) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE]) (\TEMPUNLOCKPAGES [LAMBDA (BASE NPAGES) (* bvm%: "30-Jul-85 16:58") (* ;; "Unlocks pages that were locked by \TEMPLOCKPAGES. This function must be locked because it manipulates the page table") (while (IGREATERP NPAGES 0) bind (VP _ (fetch (POINTER PAGE#) of BASE)) RPTR do (UNINTERRUPTABLY (\TOUCHPAGE BASE) (* ;  "Touch page in case not resident. Should only happen if page wasn't locked to begin with") (COND ((AND (NEQ (SETQ RPTR (\READRP VP)) 0) (EQ [fetch (RPT VP) of (SETQ RPTR (fetch RPTRBASE of (RPTFROMRP RPTR] VP)) (COND ([AND DOLOCKCHECKS (EQ (LRSH VP 8) (CONSTANT (\HILOC \PAGEMAP] (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP))) (replace (RPT LOCKED) of RPTR with NIL)) (T (HELP "Page table changed out from under me!" VP)))) (add VP 1) (add NPAGES -1) (SETQ BASE (\ADDBASE BASE WORDSPERPAGE]) (\UNLOCKPAGES [LAMBDA (BASE NPAGES) (* bvm%: "30-Jul-85 16:58") (* ;;; "Unlocks NPAGES virtual pages from BASE onward") (UNINTERRUPTABLY (for I from 0 to (SUB1 NPAGES) bind (VP _ (fetch (POINTER PAGE#) of BASE)) MASK LOCKBASE do (COND ((fetch (VP INVALID) of VP) (\INVALIDVP VP)) ((NEQ 0 (LOGAND (SETQ MASK (.LOCKEDVPMASK. VP)) (\GETBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP)) 0))) (* ;  "Yes, page was locked, so turn the bit off now") (COND ([AND DOLOCKCHECKS (EQ (LRSH VP 8) (CONSTANT (\HILOC \PAGEMAP] (\MP.ERROR \MP.UNLOCKINGMAP "Attempt to unlock map page" VP))) (\PUTBASE LOCKBASE 0 (LOGXOR MASK (\GETBASE LOCKBASE 0))) (* ;  "Update pagemap, then update real page table") (replace (RPT LOCKED) of (fetch RPTRBASE of (RPTFROMRP (\READRP VP))) with NIL))) (add VP 1)))]) ) (* ; "Writing out the vmem") (DEFINEQ (\FLUSHVM [LAMBDA (MAIKO.SYSOUTFILE) (* ; "Edited 6-Jan-89 19:23 by Hayata") (* ;; "Writes out all dirty pages to vmem, making it consistent. Returns NIL now, T if Bcpl starts up the vmem") (COND ((\FLUSHVMOK?) (COND [(EQ \MACHINETYPE \MAIKO) (PROMPTPRINT "Saving sysout, taking mouse down.") (* ;; "check free space.") (\MAIKO.CHECKFREESPACE MAIKO.SYSOUTFILE) (UNINTERRUPTABLY (PROG NIL (SELECTQ (\MISCAPPLY* (FUNCTION \DOFLUSHVM) MAIKO.SYSOUTFILE) (NIL (SETQ \DIRTYPAGEHINT 32767) (RETURN NIL)) (1 (ERROR "Can not find sysout file")) (2 (ERROR "FILE-SYSTEM-RESOURCES-EXCEEDED")) (3 (ERROR "Can not open sysout file")) (4 (ERROR "Can not seek sysout file")) (5 (ERROR "Can not write sysout file")) (6 (ERROR "Connection timed out")) NIL) (SETQ \DOFAULTINIT T) (\CONTEXTSWITCH \FAULTFXP) (for VAR in \SYSTEMCACHEVARS do (SET VAR NIL)) (RETURN T)))] (T (UNINTERRUPTABLY (* ;  "Write stuff out from a safe place") (PROG1 (COND ((\MISCAPPLY* (FUNCTION \DOFLUSHVM)) (* ; "Return from Bcpl startup. Need to rebuild the context, since it was not written out consistently") (SETQ \DOFAULTINIT T) (* ;; "Tell pagefault handler to initialize itself. Want the initialization to happen in Fault context to avoid stack overflow messiness") (\CONTEXTSWITCH \FAULTFXP) (for VAR in \SYSTEMCACHEVARS do (SET VAR NIL)) T)) (SETQ \DIRTYPAGEHINT 32767)))]) (\LOGOUT0 [LAMBDA (FAST) (* ; "Edited 18-Jul-88 04:14 by masinter") [COND ((OR (EQ (fetch MachineType of \InterfacePage) \DORADO) (EQ (fetch MachineType of \InterfacePage) \DOLPHIN)) (* ;; "If we're running on a Dolphin or Dorado, we update the alto's clock. Note that Dandelions and Daybreaks don't have alto clocks, so this wouldn't work on them") (\BLT (EMADDRESS \RTCSECONDS) (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) (UNFOLD 3 WORDSPERCELL] (UNINTERRUPTABLY (OR (AND [OR (NOT FAST) (AND (EQ FAST '?) (NOT (.VMEM.CONSISTENTP.] (\FLUSHVM)) (SELECTC \MACHINETYPE (\DAYBREAK (\DoveMisc.BootButton)) (SUBRCALL LISPFINISH FAST))))]) (\DOFLUSHVM [LAMBDA (MAIKO.SYSOUTFILE) (* ; "Edited 6-Jan-89 19:23 by Hayata") (* ;;; "Write everything out in a resumable way. Value is NIL if returned from directly, T if from saved state. Always invoked via \MISCAPPLY*") (CHECK (NOT \INTERRUPTABLE)) (* ;  "NOTE: need stats gathering off in here. Also avoid touching pages") (PROG ((IFPVP (fetch (POINTER PAGE#) of \InterfacePage)) (SCRATCHBUF \EMUSWAPBUFFERS) IFPRPT) (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with T) (* ; "This will make it look like we have returned from BCPL if caller gets control from the saved state") [COND ((OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK)) (* ;  "Mark all active stack pages dirty, since the microcode doesn't") (for VP from \VP.STACK to (IPLUS \VP.STACK (fetch HIBYTE of (fetch EndOfStack of \InterfacePage ))) as RP from \RP.STACK do (\WRITEMAP VP RP (LOGOR \VMAP.REF \VMAP.DIRTY))) (* ;  "Similarly, the GC table does not get marked dirty") (for VP from \VP.GCTABLE to (IPLUS \VP.GCTABLE (SUB1 \NP.GCTABLE)) as RP from \RP.GCTABLE do (\WRITEMAP VP RP (LOGOR \VMAP.REF \VMAP.DIRTY] [COND ((EQ \MACHINETYPE \MAIKO) (* ;; "update interface pge before writing out sysout") (replace (IFPAGE CurrentFXP) of \InterfacePage with (fetch (IFPAGE MiscFXP) of \InterfacePage )) (RETURN (SUBRCALL VMEMSAVE MAIKO.SYSOUTFILE] [COND (\VMEM.PURE.LIMIT (* ;  "Maintaining file consistency: move high water mark up") (COND (VMEM.COMPRESS.FLG (\DOCOMPRESSVMEM))) (SETQ \VMEM.PURE.LIMIT (fetch (IFPAGE NActivePages) of \InterfacePage] (COND ((.VMEM.CONSISTENTP.) (replace (IFPAGE Key) of \InterfacePage with (LOGNOT16 \IFPValidKey)) (* ;  "Invalidate vmem and write out the Interface page") (\TRANSFERPAGE IFPVP \FirstVmemBlock (RPTFROMRP (\READRP IFPVP)) T NIL))) (SETQ IFPRPT (RPTFROMRP (\READRP IFPVP))) (for RPTINDEX from 1 to (SUB1 \RPTSIZE) do (\FLUSHPAGE RPTINDEX T) unless (EQ RPTINDEX IFPRPT)) (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey) (\BLT SCRATCHBUF \InterfacePage WORDSPERPAGE) (* ;  "Make its current fx point at user context, i.e. the \FLUSHVM frame") (replace (IFPAGE CurrentFXP) of SCRATCHBUF with (fetch (IFPAGE MiscFXP) of \InterfacePage)) (\ACTONVMEMFILE (\LOOKUPPAGEMAP IFPVP) SCRATCHBUF 1 T) (* ;  "Write the page out from a safe place") (RETURN NIL]) (\RELEASEWORKINGSET [LAMBDA NIL (* bvm%: "29-Nov-84 10:56") (COND ((\FLUSHVM) (* ; "Returning from Lisp startup") T) (T (* ; "Unmap any unlocked page") (for RPTINDEX from 1 to (SUB1 \RPTSIZE) bind RPTR when (AND (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE of RPTINDEX))) (NOT (fetch (RPT LOCKED) of RPTR))) do (\WRITEMAP (fetch (RPT VP) of RPTR) (RPFROMRPT RPTINDEX) \VMAP.VACANT) (replace (RPT EMPTY) of RPTR with T]) (\WRITEDIRTYPAGE [LAMBDA (MINDIRTY) (* bvm%: "13-Aug-85 17:51") (COND ((OR (NOT (.VMEM.CONSISTENTP.)) (AND \VMEM.PURE.LIMIT (NEQ \VMEM.PURE.LIMIT -1) (NOT \VMEM.FULL.STATE))) (PROG ((RPTR (OR \LASTDIRTYSCANPTR \REALPAGETABLE)) (NUMDIRTY (OR \LASTDIRTYCNT 0)) (CNT \MAXDIRTYSCANCOUNT) RP FP FLAGS) [COND ((AND (NULL \LASTDIRTYSCANPTR) (IGREATERP (IPLUS (add \DIRTYPAGECOUNTER 1) \PAGEFAULTCOUNTER) \UPDATECHAINFREQ)) (* ;  "Take this time to update the page chain instead") (RETURN (UNINTERRUPTABLY (\MISCAPPLY* (FUNCTION \UPDATECHAIN)))] (OR MINDIRTY (SETQ MINDIRTY 1)) LP [COND [(EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR)) \PAGETABLESTOPFLG) (* ;  "Hit end of chain. Write out what we found if enough were dirty") (COND ((AND (IGEQ NUMDIRTY MINDIRTY) (NEQ NUMDIRTY 0) (SETQ RP \LASTDIRTYFOUND)) (GO GOTPAGE)) (T (SETQ \LASTDIRTYSCANPTR (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL))) [COND ((AND (NEQ NUMDIRTY 0) (ILESSP \DIRTYSEEKMAX (LRSH MAX.SMALL.INTEGER 1))) (* ;  "Failed because page not close enough, so widen the tolerance") (SETQ \DIRTYSEEKMAX (LLSH \DIRTYSEEKMAX 1] (RETURN] ((fetch (RPT EMPTY) of (SETQ RPTR (fetch RPTRBASE of RP))) (* ;  "Page is empty. Should never happen if key is valid") (RETURN)) ((NOT (fetch (RPT LOCKED) of RPTR)) (* ;  "Don't bother writing out locked pages, since they don't help us in our swapping quest") (SETQ FLAGS (\READFLAGS (fetch (RPT VP) of RPTR))) (COND ((NOT (fetch (VMEMFLAGS DIRTY) of FLAGS)) (* ; "Page not dirty; skip") ) [(PROGN (SETQ FP (fetch (RPT FILEPAGE) of RPTR)) (IGREATERP (IABS (IDIFFERENCE (COND ((AND \VMEM.PURE.LIMIT (ILESSP FP \VMEM.PURE.LIMIT )) (* ;  "We'd have to write page to a new place, not here") (fetch (IFPAGE NActivePages) of \InterfacePage)) (T FP)) \LASTACCESSEDVMEMPAGE)) \DIRTYSEEKMAX)) (* ;  "Page too far away, don't write it") (COND ((fetch (VMEMFLAGS REFERENCED) of FLAGS) (* ; "but still count it") (add NUMDIRTY 1] ((IGREATERP FP \LASTVMEMFILEPAGE) (* ; "Can't write it") ) ((fetch (VMEMFLAGS REFERENCED) of FLAGS) (* ;  "Page dirty but referenced. Note it, but keep looking for a better one") (COND ((EQ NUMDIRTY 0) (SETQ \LASTDIRTYFOUND RP))) (add NUMDIRTY 1)) (T (* ; "Dirty, not referenced: do it") (GO GOTPAGE] (COND ((EQ (add CNT -1) 0) (* ;  "Scanned for long enough; don't lock user out") (SETQ \LASTDIRTYSCANPTR RPTR) (SETQ \LASTDIRTYCNT NUMDIRTY) (RETURN))) (GO LP) GOTPAGE (UNINTERRUPTABLY (SETQ \LASTDIRTYSCANPTR (SETQ RPTR (fetch RPTRBASE of RP))) (* ; "Keep traveling pointer") (SETQ \LASTDIRTYCNT (SETQ \LASTDIRTYFOUND NIL)) (COND ((ILEQ (IABS (IDIFFERENCE (fetch (RPT FILEPAGE) of RPTR) \LASTACCESSEDVMEMPAGE)) \DIRTYSEEKMAX) (* ;  "Could fail if swapping since the selection has moved the disk arm too far") (\MISCAPPLY* (FUNCTION \WRITEDIRTYPAGE1) RP RPTR))) (SETQ \DIRTYSEEKMAX \MAXSHORTSEEK)) (RETURN T]) (\WRITEDIRTYPAGE1 [LAMBDA (RP RPTR) (* bvm%: "13-Aug-85 16:41") (* ;  "Write out buffer RP. This fn is locked and called in the misc context") (COND ([AND (NOT (fetch (RPT LOCKED) of RPTR)) (fetch (VMEMFLAGS DIRTY) of (\READFLAGS (fetch (RPT VP) of RPTR] (* ;  "Verify that the page is still a candidate, so previous loop could be interruptable") (\FLUSHPAGE RP) (COND (\NEWVMEMPAGEADDED (\ASSURE.FPTOVP.PAGE]) (\COUNTREALPAGES [LAMBDA (TYPE) (* bvm%: "18-Dec-84 15:31") (SELECTQ TYPE ((DIRTY REF) [PROG [(FLAGBITS (COND ((EQ TYPE 'DIRTY) \VMAP.DIRTY) (T \VMAP.REF] (RETURN (NPAGESMACRO (NEQ (LOGAND (\READFLAGS VP) FLAGBITS) 0]) (LOCKED (NPAGESMACRO (fetch (RPT LOCKED) of RPTR))) (OCCUPIED (NPAGESMACRO T)) (\ILLEGAL.ARG TYPE]) ) (* ; "VMEM.PURE.STATE hack") (DEFINEQ (\DOCOMPRESSVMEM [LAMBDA NIL (* bvm%: " 7-Apr-84 17:53") (* ;;; "Called underneath \DOFLUSHVM to write the pages above the high water mark back to the places vacated below that mark") (PROG ((EMPTYFP (DLFPFROMRP \RP.GCTABLE)) (LASTFP (fetch NActivePages of \InterfacePage)) (OLDVIW \VMEM.INHIBIT.WRITE) VP) [COND ((NULL OLDVIW) (* ;; "Encourage \SELECTREALPAGE to select only `old' file pages for displacement, so that we don't needlessly write the same page twice") (SETQ \VMEM.INHIBIT.WRITE 'NEW] LP (COND ((IGEQ EMPTYFP LASTFP) (SETQ \VMEM.INHIBIT.WRITE OLDVIW) (RETURN))) [COND ((EQ (\GETBASE \FPTOVP EMPTYFP) \NO.VMEM.PAGE) (while (EQ (SETQ VP (\GETBASE \FPTOVP LASTFP)) \NO.VMEM.PAGE) do (SETQ LASTFP (SUB1 LASTFP))) (\MOVEVMEMFILEPAGE VP LASTFP EMPTYFP) (replace NActivePages of \InterfacePage with (SETQ LASTFP (SUB1 LASTFP] (add EMPTYFP 1) (GO LP]) (VMEM.PURE.STATE [LAMBDA FLG (* bvm%: " 7-Apr-84 16:59") (PROG1 (NOT (NULL \VMEM.PURE.LIMIT)) [COND ((IGREATERP FLG 0) (* ;; "Set \VMEM.PURE.LIMIT appropriately. If turning on, and it wasn't on before, set it to -1 so that it takes effect only at the next FLUSHVM") (SETQ \VMEM.PURE.LIMIT (AND (ARG FLG 1) (OR \VMEM.PURE.LIMIT (SETQ \VMEM.PURE.LIMIT -1])]) ) (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages" ) (DEFINEQ (32MBADDRESSABLE [LAMBDA NIL (* ; "Edited 2-May-88 22:03 by MASINTER") (SELECTC \MACHINETYPE (\DORADO T) (\DOLPHIN NIL) (\DAYBREAK T) (NEQ 0 (fetch (IFPAGE DL24BitAddressable) of \InterfacePage]) (\SET.VMEM.FULL.STATE [LAMBDA NIL (* bvm%: "13-Feb-85 20:12") (* ;  "We are running out of vmem, try to extend file. Do this at next convenient time") (COND ((NOT \VMEM.FULL.STATE) (* ; "Get an interrupt to handle this") (replace VMEMFULL of \INTERRUPTSTATE with T) (SETQ \PENDINGINTERRUPT T))) (SETQ \VMEM.FULL.STATE (COND ((ILESSP (fetch (IFPAGE NActivePages) of \InterfacePage) \LASTVMEMFILEPAGE) (* ;  "Not completely full, allow normal things to happen") 0) ((.VMEM.CONSISTENTP.) T) (T 'DIRTY]) (\SET.LASTVMEMFILEPAGE [LAMBDA (N) (* ; "Edited 6-Apr-87 14:09 by bvm:") (* ;; "Called by disk routines when they discover how long the physical vmem is. Currently only used by Dove.") (COND ((IGREATERP (fetch (IFPAGE NActivePages) of \InterfacePage) (IDIFFERENCE (SETQ \LASTVMEMFILEPAGE N) \GUARDVMEMFULL)) (* ; "Vmem getting full!") (\SET.VMEM.FULL.STATE)) (T (* ;  "Vmem ok now (was earlier set to full for safety's sake)") (SETQ \VMEM.FULL.STATE NIL))) N]) (\DOVMEMFULLINTERRUPT [LAMBDA NIL (* ; "Edited 21-Oct-87 13:54 by bvm:") (* ;;; "Called while interruptable when vmem is full or nearly so. Tries to extend vmem file, or gives error if it can't") (COND (\EXTENDINGVMEMFILE (* ;; "Another interrupt happened while we are extending file. Don't try to do this one twice, but repost the interrupt in the hopes that it will happen after vmem extension is finished") (SETQ \PENDINGINTERRUPT T)) (T (RESETVARS ((\EXTENDINGVMEMFILE T)) (* ;; "Used to have code here that tried to extend the vmem file, but even on those that support extension it's flaky, and rarely what you want--people allocate the vmem file to the desired size in the first place, don't want it extended further.") (PROG ((HELPFLAG 'BREAK!)) (replace VMEMFULL of \INTERRUPTSTATE with NIL) (* ;  "Very slight chance of losing the break if ^E right here. Don't know how to fix this") (CL:CERROR "Resume the interrupted computation" (CONCAT "Your virtual memory backing file is " (COND ((>= (fetch (IFPAGE NActivePages) of \InterfacePage ) \LASTVMEMFILEPAGE) "complete") (T "near")) "ly full. Save your work & reload a.s.a.p."]) (\FLUSHVMOK? [LAMBDA (TYPE NOERROR) (* bvm%: " 7-Sep-85 10:48") (* ;;; "Called before any attempt to do a \FLUSHVM to make sure it's ok") (LET [(MSG (COND ((SELECTQ \VMEM.FULL.STATE ((T DIRTY) T) NIL) "-- virtual memory backing file too small") ((AND \VMEM.PURE.LIMIT (NEQ \VMEM.PURE.LIMIT -1) (NOT VMEM.COMPRESS.FLG)) " while VMEM.PURE.STATE is on."] (COND ((NOT MSG) T) (T [COND ((NOT NOERROR) (ERROR [CONCAT "Can't " (OR TYPE (SETQ TYPE 'LOGOUT] MSG (COND ((EQ TYPE 'LOGOUT) " You may (LOGOUT T), which quits without saving state.") (T ""] NIL]) ) (RPAQ? \UPDATECHAINFREQ 100) (RPAQ? \PAGEFAULTCOUNTER 0) (RPAQ? \DIRTYPAGECOUNTER 0) (RPAQ? \DIRTYPAGEHINT 0) (RPAQ? \LASTACCESSEDVMEMPAGE 0) (RPAQ? \MAXSHORTSEEK 1000) (RPAQ? \MINSHORTSEEK 20) (RPAQ? \MAXCLEANPROBES 20) (RPAQ? \VMEM.INHIBIT.WRITE ) (RPAQ? \VMEM.PURE.LIMIT ) (RPAQ? \VMEM.FULL.STATE ) (RPAQ? \GUARDVMEMFULL 500) (RPAQ? VMEM.COMPRESS.FLG ) (RPAQ? \DOFAULTINIT 0) (RPAQ? \VMEMACCESSFN ) (RPAQ? \SYSTEMCACHEVARS ) (RPAQ? \MAXSWAPBUFFERS 1) (RPAQ? \EXTENDINGVMEMFILE ) (RPAQ? \MaxScreenPage 0) (RPAQ? \NEWVMEMPAGEADDED ) (RPAQ? \LASTDIRTYCNT ) (RPAQ? \LASTDIRTYFOUND ) (RPAQ? \LASTDIRTYSCANPTR ) (RPAQ? \DIRTYSEEKMAX 50) (* ; "Errors signaled in the maintenance panel") (DEFINEQ (\MP.ERROR [LAMBDA (CODE STRING ARG1 ARG2) (* mpl "20-Jun-85 11:09") (COND ((OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK)) ((OPCODES RAID) CODE)) (T (RAID STRING ARG1 ARG2]) ) (* ; "Debugging code. Some of this also runs renamed for extra TeleRaid help") (DEFINEQ (\ACTONVMEMFILE [LAMBDA (FILEPAGE BUFFER NPAGES WRITEFLAG) (* MPL "22-Jun-85 20:18") (COND ((EQ \MACHINETYPE \DANDELION) (\DL.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG)) ((EQ \MACHINETYPE \DAYBREAK) (\DOVE.ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG)) (T (\M44ACTONVMEMFILE FILEPAGE BUFFER NPAGES WRITEFLAG]) (\SHOWPAGETABLE [LAMBDA (MODE FILE) (* bvm%: "12-Jul-86 16:55") (PROG ((*PRINT-BASE* 8) (OUTSTREAM (GETSTREAM FILE 'OUTPUT)) (RPTR \REALPAGETABLE) (RP 0) FLAGS VP STATE FIRSTONE LASTONE) (printout OUTSTREAM " RP VP FilePage Status" T) (until (SELECTQ MODE (CHAIN (EQ (SETQ RP (fetch (RPT NEXTRP) of RPTR)) \PAGETABLESTOPFLG)) (NIL (add RP 1) (IGEQ RP \RPTSIZE)) (\ILLEGAL.ARG MODE)) do (SETQ RPTR (fetch RPTRBASE of RP)) (SETQ VP (fetch (RPT VP) of RPTR)) (COND ((AND (NULL MODE) (EQ VP STATE)) (SETQ LASTONE RP)) (T (COND (LASTONE (printout OUTSTREAM "ditto thru " LASTONE T) (SETQ LASTONE NIL))) (SETQ FIRSTONE RP) (SETQ STATE VP) (printout OUTSTREAM |.I7.8| (RPFROMRPT RP)) [COND ((fetch (RPT EMPTY) of RPTR) (PRIN1 " Empty" OUTSTREAM)) ((NOT (fetch (RPT OCCUPIED) of RPTR)) (PRIN1 " Unavailable" OUTSTREAM)) (T (printout OUTSTREAM |.I8.8| VP %,) (\PRINTVP VP OUTSTREAM) (printout OUTSTREAM 28 |.I6.8| (fetch (RPT FILEPAGE) of RPTR) %,,) (COND ((fetch (RPT LOCKED) of RPTR) (COND ((NOT (\LOCKEDPAGEP VP)) (* ; "not permanently locked") (PRIN1 "Temp" OUTSTREAM))) (PRIN1 "Locked " OUTSTREAM))) (UNLESSRDSYS (PROGN (COND ((fetch (VMEMFLAGS REFERENCED) of (SETQ FLAGS (\READFLAGS VP))) (PRIN1 "Ref " OUTSTREAM))) (COND ((fetch (VMEMFLAGS DIRTY) of FLAGS) (PRIN1 "Dirty" OUTSTREAM] (TERPRI OUTSTREAM]) (CHECKPAGEMAP [LAMBDA NIL (* bvm%: "12-Jul-86 16:56") (LET ((*PRINT-BASE* 8) (NUMOCCUPIED 0) (NUMLOCKED 0) (CHAINOCCUPIED 0) (CHAINLOCKED 0) RPTR FPBASE FP VP RP) (CHECKFPTOVP) [for RPTINDEX from 1 to (SUB1 \RPTSIZE) when (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE of RPTINDEX) )) do (add NUMOCCUPIED 1) (SETQ VP (fetch (RPT VP) of RPTR)) (SETQ FP (fetch (RPT FILEPAGE) of RPTR)) (COND ((CHECKFPTOVP1 FP VP RPTINDEX)) ([NEQ VP (fetch FPVIRTUALPAGE of (SETQ FPBASE (\ADDBASE \FPTOVP FP] (printout T "RPT for RP " (RPFROMRPT RPTINDEX) " says VP ") (\PRINTVP VP T) (printout T " lives in FP " FP "; but FP Map says that FP contains ") (\PRINTVP (fetch FPVIRTUALPAGE of FPBASE) T) (printout T T)) ((\LOCKEDPAGEP VP) (add NUMLOCKED 1) (COND ((NOT (fetch (RPT LOCKED) of RPTR)) (printout T "VP " VP ", living in RP " (RPFROMRPT RPTINDEX) " should be locked but isn't." T)) ((IGREATERP FP (DLRPFROMFP (fetch (IFPAGE LastLockedFilePage) of \InterfacePage))) (printout T "VP " VP " is locked, but living in FP " FP ", which is not in the locked page area" T] (PROGN (SETQ RPTR \REALPAGETABLE) (* ; "Check pagetable chain") [while (NEQ (SETQ RP (fetch (RPT NEXTRP) of RPTR)) \PAGETABLESTOPFLG) when (fetch (RPT OCCUPIED) of (SETQ RPTR (fetch RPTRBASE of RP))) do (add CHAINOCCUPIED 1) (COND ((fetch (RPT LOCKED) of RPTR) (add CHAINLOCKED 1] (COND ((ILESSP CHAINOCCUPIED NUMOCCUPIED) (printout T NUMOCCUPIED " occupied pages, but only " CHAINOCCUPIED " are on page chain. " NUMLOCKED " pages are permanently locked; " CHAINLOCKED " pages on chain are locked somehow." T]) (CHECKFPTOVP [LAMBDA NIL (* bvm%: "10-Dec-84 12:39") (for FP from 1 to (fetch NActivePages of \InterfacePage) as (FPBASE _ (\ADDBASE \FPTOVP 1)) by (\ADDBASE FPBASE 1) when (fetch FPOCCUPIED of FPBASE) do (CHECKFPTOVP1 FP (fetch FPVIRTUALPAGE of FPBASE]) (CHECKFPTOVP1 [LAMBDA (FP VP RPTINDEX) (* bvm%: "10-Dec-84 12:36") (PROG ((FP2 (\LOOKUPPAGEMAP VP))) (RETURN (COND ((NEQ FP2 FP) (COND ((UNLESSRDSYS RPTINDEX) (printout T "RPT for RP " (RPFROMRPT RPTINDEX))) (T (printout T "FP map"))) (printout T " says FP " FP " contains VP ") (\PRINTVP VP T) (printout T "; but PageMap says that page is in FP " FP2 T) T]) (\PRINTFPTOVP [LAMBDA (FIRSTPAGE NWORDS TYPEFLG STREAM VPRAWFLG) (* bvm%: "24-Sep-86 11:44") (SETQ STREAM (GETSTREAM STREAM 'OUTPUT)) (OR FIRSTPAGE (SETQ FIRSTPAGE 1)) (OR NWORDS (SETQ NWORDS (fetch (IFPAGE NActivePages) of \InterfacePage))) (LET ((BASE (\ADDBASE \FPTOVP (SUB1 FIRSTPAGE))) (*PRINT-BASE* 8) (LASTVP -2) (NEXTFP (SUB1 FIRSTPAGE)) FIRSTFP FIRSTVP NEXTVP LOCKEDP TYPE NEXTLOCKED NEXTTYPE) (while (IGEQ NWORDS 0) do (add NEXTFP 1) [COND ((EQ NWORDS 0) (SETQ NEXTVP -1)) ((NEQ (SETQ NEXTVP (\GETBASE (SETQ BASE (\ADDBASE BASE 1)) 0)) \NO.VMEM.PAGE) (SETQ NEXTLOCKED (\LOCKEDPAGEP NEXTVP)) (if TYPEFLG then (SETQ NEXTTYPE (TYPENAME (create POINTER PAGE# _ NEXTVP))) (if (NULL NEXTTYPE) then (SETQ NEXTTYPE (SELECTC (LRSH NEXTVP 8) ((LIST \PNAME.HI (CL:1+ \PNAME.HI)) "Pnames") ((LIST \DEF.HI (CL:1+ \DEF.HI)) "Definitions") ((LIST \VAL.HI (CL:1+ \VAL.HI)) "Value cells") ((LIST \PLIST.HI (CL:1+ \PLIST.HI)) "Property lists") ((\HILOC \FPTOVP) "\FPTOVP") (\STACKHI "Stack") ((\HILOC \HTMAIN) "GC Main table") ((\HILOC \HTOVERFLOW) "GC Overflow table") NIL] [COND ([COND ((EQ NEXTVP \NO.VMEM.PAGE) (NEQ LASTVP \NO.VMEM.PAGE)) (T (OR (NEQ NEXTVP (ADD1 LASTVP)) (NEQ NEXTLOCKED LOCKEDP) (NEQ TYPE NEXTTYPE] [COND ((IGEQ LASTVP 0) (COND (FIRSTFP (printout STREAM FIRSTFP "-"))) (printout STREAM (SUB1 NEXTFP) 12) (COND ((EQ LASTVP \NO.VMEM.PAGE) (printout STREAM "empty")) (T (COND (FIRSTFP (if VPRAWFLG then (PRIN1 FIRSTVP STREAM) else (\PRINTVP FIRSTVP STREAM)) (PRIN1 "-" STREAM))) (if VPRAWFLG then (PRIN1 LASTVP STREAM) else (\PRINTVP LASTVP STREAM)) (COND (LOCKEDP (PRIN1 '* STREAM))) (if TYPE then (printout STREAM 32 TYPE] (SETQ FIRSTFP) (TERPRI STREAM) (SETQ FIRSTVP NEXTVP)) (T (* ; "in a run") (OR FIRSTFP (SETQ FIRSTFP (SUB1 NEXTFP] (SETQ LASTVP NEXTVP) (SETQ LOCKEDP NEXTLOCKED) (SETQ TYPE NEXTTYPE) (add NWORDS -1]) (\PRINTVP [LAMBDA (VP STREAM) (* bvm%: "28-MAR-83 12:40") (printout STREAM "{" (LRSH VP 8) "," (LOGAND VP 255) "}"]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \ACTONVMEMFILE MACRO ((X . Y) (SPREADAPPLY* \VMEMACCESSFN X . Y))) (PUTPROPS .VMEM.CONSISTENTP. MACRO (NIL (EQ (fetch (IFPAGE Key) of \InterfacePage) \IFPValidKey))) (PUTPROPS .LOCKABLERP. MACRO [(RP) (OR (NEQ (FOLDLO RP PAGESPERSEGMENT) (FOLDLO \RP.STACK PAGESPERSEGMENT)) (NOT (OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK]) ) (* ; "Virtual page flags") (DECLARE%: EVAL@COMPILE (RPAQQ \VMAP.DIRTY 10000Q) (RPAQQ \VMAP.CLEAN 0) (RPAQQ \VMAP.REF 100000Q) (RPAQQ \VMAP.VACANT 30000Q) (RPAQQ \VMAP.FLAGS 170000Q) (RPAQQ \VMAP.NOTFLAGS 7777Q) (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS \VMAP.NOTFLAGS) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS VMEMFLAGS ((VACANT (EQ (LOGAND DATUM \VMAP.VACANT) \VMAP.VACANT)) (DIRTY (NEQ (LOGAND DATUM \VMAP.DIRTY) 0)) (REFERENCED (NEQ (LOGAND DATUM \VMAP.REF) 0)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS LOGNOT16 MACRO ((X) (LOGXOR X 177777Q))) ) (* ; "RPT constants") (DECLARE%: EVAL@COMPILE (RPAQQ \RPT.EMPTY 177776Q) (RPAQQ \RPT.UNAVAILABLE 177777Q) (RPAQQ \PAGETABLESTOPFLG 0) (RPAQQ \RPTENTRYLENGTH 3) (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH) ) (DECLARE%: EVAL@COMPILE (BLOCKRECORD RPT ((LOCKED FLAG) (NEXTRP BITS 17Q) (VP WORD) (FILEPAGE WORD)) (BLOCKRECORD RPT ((NIL BITS 20Q) (VPSEG BYTE) (VPPAGEINSEG BYTE))) [ACCESSFNS RPT ([EMPTY (EQ (fetch (RPT VP) of DATUM) \RPT.EMPTY) (COND (NEWVALUE (replace (RPT VP) of DATUM with \RPT.EMPTY)) (T (ERROR "Invalid replace of RPT.EMPTY" DATUM] [UNAVAILABLE (EQ (fetch (RPT VP) of DATUM) \RPT.UNAVAILABLE) (COND (NEWVALUE (replace (RPT VP) of DATUM with \RPT.UNAVAILABLE)) (T (ERROR "Invalid replace of RPT.UNAVAILABLE" DATUM] (OCCUPIED (ILESSP (fetch (RPT VP) of DATUM) \RPT.EMPTY]) (ACCESSFNS RPT1 (RPTRBASE (\ADDBASE (\ADDBASE \REALPAGETABLE (LLSH DATUM 1)) DATUM))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS RPFROMRPT MACRO ((RPTINDEX) (IPLUS RPTINDEX \RPOFFSET))) (PUTPROPS RPTFROMRP MACRO ((RP) (IDIFFERENCE RP \RPOFFSET))) (PUTPROPS NPAGESMACRO MACRO ((FORM) (PROG ((RESULT 0) (CNTR \RPTSIZE) (RPTR \REALPAGETABLE) VP) LP (COND ((NEQ (SETQ CNTR (SUB1 CNTR)) 0) (SETQ RPTR (\ADDBASE RPTR \RPTENTRYLENGTH)) (COND ((AND (fetch (RPT OCCUPIED) of RPTR) (PROGN (SETQ VP (fetch (RPT VP) of RPTR)) FORM)) (add RESULT 1))) (GO LP))) (RETURN RESULT)))) ) (* ; "Virtual to file pagemap") (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RPAQQ \MAXFILEPAGE 177776Q) (CONSTANTS \MAXFILEPAGE) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ \EMPTYPMTENTRY 177777Q) (CONSTANTS \EMPTYPMTENTRY) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS VP ((PRIMARYKEY (LRSH DATUM 5)) (SECONDARYKEY (LOGAND DATUM 37Q)) (INVALID (PROGN NIL)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .PAGEMAPBASE. MACRO [OPENLAMBDA (VPAGE) (\ADDBASE \PAGEMAP (IPLUS (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY ) of VPAGE)) (fetch (VP SECONDARYKEY) of VPAGE]) ) (* ; "FP to VP stuff") (DECLARE%: EVAL@COMPILE (BLOCKRECORD FPTOVP ((FPVIRTUALPAGE FIXP)) [ACCESSFNS FPTOVP ((FPOCCUPIED (NEQ (\GETBASE DATUM 0) \NO.VMEM.PAGE]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NO.VMEM.PAGE 177777Q) (CONSTANTS \NO.VMEM.PAGE) ) (DECLARE%: EVAL@COMPILE (PUTPROPS DLRPFROMFP MACRO ((FP) (ADD1 FP))) (PUTPROPS DLFPFROMRP MACRO ((RP) (SUB1 RP))) ) (PUTPROPS \TOUCHPAGE DOPVAL (1 GETBASE.N 0)) (PUTPROPS TIMES3 DOPVAL (1 COPY LLSH1 IPLUS2)) (* ; "Locked page table") (DECLARE%: EVAL@COMPILE (PUTPROPS .LOCKEDVPBASE. MACRO ((VP) (\ADDBASE \LOCKEDPAGETABLE (FOLDLO VP BITSPERWORD)))) (PUTPROPS .LOCKEDVPMASK. MACRO ((VP) (LLSH 1 (IMOD VP BITSPERWORD)))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \MAXDIRTYSCANCOUNT 144Q) (RPAQQ \MINVMEMSPAREPAGES 144Q) (RPAQQ \DLBUFFERPAGES 20Q) (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES) ) (DECLARE%: EVAL@COMPILE (RPAQQ 2MBPAGES 10000Q) (CONSTANTS 2MBPAGES) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE \MaxScreenPage \NEWVMEMPAGEADDED) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND) ) (DECLARE%: EVAL@COMPILE (PUTPROPS RWMufMan DMACRO ((X) ((OPCODES 170Q 11Q) X))) ) (DECLARE%: EVAL@COMPILE (RPAQQ DOLOCKCHECKS NIL) (CONSTANTS (DOLOCKCHECKS NIL)) ) ) (* ;;; "MAKEINIT stuff") (DEFINEQ (ADDPME [LAMBDA (VP NEWPAGEOK) (* bvm%: " 6-Dec-84 14:07") (* ;; "add an entry for VP to the PAGEMAP. Called only under MAKEINIT") (PROG (PX PMP LOCKBASE) [COND ((IEQ (SETQ PMP (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP))) \EmptyPMTEntry) (* ;  "empty entries in the PageMapTBL have 177777q as their value") (COND ((EVENP NEXTPM WORDSPERPAGE) (* ; "must add a new page map page") (SETQ PX (\ADDBASE \PAGEMAP NEXTPM)) (OR NEWPAGEOK (IGREATERP (PAGELOC PX) VP) (HELP "page map needs new page after page map written out")) (\NEWPAGE PX NIL T))) (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP) (SETQ PMP NEXTPM)) (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize] (SETQ PX (IPLUS PMP (fetch (VP SECONDARYKEY) of VP))) (COND ((NEQ (\GETBASE \PAGEMAP PX) 0) (HELP "page already in pagemap" VP)) (T (\PUTBASE \PAGEMAP PX NEXTVMEM) [COND ((LOCKEDPAGEP VP) (* ;  "Set lock bit in locked page table") (\PUTBASE (SETQ LOCKBASE (.LOCKEDVPBASE. VP)) 0 (LOGOR (.LOCKEDVPMASK. VP) (\GETBASE LOCKBASE 0] (SETQ NEXTVMEM (ADD1 NEXTVMEM]) (CHECKIFPAGE [LAMBDA NIL (* mjs "19-Jul-84 13:24") (CHECKIF Key EQUAL \IFPValidKey "Interface page key"]) (DUMPINITPAGES [LAMBDA (CODEFIRSTPAGE CODENEXTPAGE VERSIONS) (* bvm%: "14-Jan-85 12:51") (* ; "called only under MAKEINIT") (ADDPME (PAGELOC \InterfacePage) T) (* ;  "THE INTERFACE PAGE MUST BE THE FIRST PAGE") (for I from CODEFIRSTPAGE to (SUB1 CODENEXTPAGE) do (* ;  "add the pagemap entries for the pages which were written directly to the file") (ADDPME I T)) (MAPPAGES 0 (ADD1 \MAXVMPAGE) (FUNCTION MAKEROOMFORPME)) (MAPPAGES 0 (ADD1 \MAXVMPAGE) (FUNCTION ADDPME)) (PROGN (* ;  "set interface page locations --- stack pointers already set up IN SETUPSTACK") (replace (IFPAGE NxtPMAddr) of \InterfacePage with NEXTPM) (replace (IFPAGE NActivePages) of \InterfacePage with (SUB1 NEXTVMEM)) (replace (IFPAGE NDirtyPages) of \InterfacePage with (SUB1 NEXTVMEM)) (replace (IFPAGE filePnPMP0) of \InterfacePage with (\GETBASE \PAGEMAP 0)) (replace (IFPAGE filePnPMT0) of \InterfacePage with (\GETBASE (.PAGEMAPBASE. (PAGELOC \PageMapTBL)) 0)) [COND (VERSIONS (replace (IFPAGE LVersion) of \InterfacePage with (CAR VERSIONS)) (replace (IFPAGE MinBVersion) of \InterfacePage with (CADDR VERSIONS )) (replace (IFPAGE MinRVersion) of \InterfacePage with (CADR VERSIONS] (replace (IFPAGE Key) of \InterfacePage with \IFPValidKey)) (MAPPAGES 0 (ADD1 \MAXVMPAGE) (FUNCTION DUMPVP)) (ALLOCAL (PROG ((FILE (OUTPUT))) [COND ((NOT (RANDACCESSP FILE)) (* ;  "SYSOUT file is sequential; have to get it random access for this") (OUTPUT (SETQ FILE (OPENFILE (CLOSEF FILE) 'BOTH] (SETFILEPTR FILE MKI.Page0Byte))) (DUMPVP (PAGELOC \InterfacePage]) (MAKEROOMFORPME [LAMBDA (VP) (* bvm%: "29-MAR-83 17:11") (* ;;  "make sure that the pagemap-page for page VP exists; we later will want to add it to the pagemap") (COND ((IEQ (\GETBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP)) \EmptyPMTEntry) (* ;  "empty entries in the PageMapTBL have 177777q as their value") (COND ((EVENP NEXTPM WORDSPERPAGE) (* ; "must add a new page map page") (\NEWPAGE (\ADDBASE \PAGEMAP NEXTPM) NIL T))) (\PUTBASE \PageMapTBL (fetch (VP PRIMARYKEY) of VP) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize]) (MAPPAGES [LAMBDA (BOT TOP FN) (* ;  "Edited 5-Nov-92 15:41 by sybalsky:mv:envos") (* ;; "Map thru all pages from BOT to TOP that exist, skipping the interface page, if it falls into that range. Call FN on the page number.") (PROG ((VP BOT) (IVP (PAGELOC \InterfacePage))) LP (COND ((AND (SETQ VP (MKI.NEXTPAGE VP)) (IGREATERP TOP VP)) (COND ((NOT (IEQ VP IVP)) (APPLY* FN VP))) (SETQ VP (ADD1 VP)) (GO LP]) (READPAGEMAP [LAMBDA NIL (* bvm%: "10-Dec-84 21:54") (* ;  "called only under READSYS -- reads in pagemap so that SETVMPTR can work") (PROG (D) (LOCAL (MAPVMPAGE (fetch (POINTER PAGE#) of \InterfacePage) 1)) (* ; "Install interface page by magic") (* PROGN (SETQ FPSTART  (fetch (IFPAGE LastDominoFilePage)  of \InterfacePage))  (SETQ NPAGES (fetch  (IFPAGE NActivePages) of  \InterfacePage)) (* ;  "Note: have to do these fetches before the SETFILEPTR since they indirectly do SETFILEPTR themselves")  (SETFILEPTR VMEMFILE  (IPLUS (UNFOLD (SUB1  (fetch (IFPAGE FPTOVPStart) of  \InterfacePage)) BYTESPERPAGE)  (UNFOLD FPSTART BYTESPERWORD)))  (for I from FPSTART to NPAGES bind  VP when (NEQ (SETQ VP  (VBIN2)) \NO.VMEM.PAGE) do  (* ; "Read in all of FPTOVP")  (MAPVMPAGE VP (SUB1 I)))) [LOCAL (MAPVMPAGE (PAGELOC \PAGEMAP) (SUB1 (fetch (IFPAGE filePnPMP0) of \InterfacePage] (* ; "map in first page of secondary page map, which is where all the secondary map pages themselves live") (LOCAL (SETVMPTR \PAGEMAP)) (for I from 0 to (SUB1 (FOLDHI PAGESPERSEGMENT \PMblockSize)) as VP from (PAGELOC \PAGEMAP) by \PMblockSize do (* ; "Have to read all the addresses of secondary map pages themselves before we can read their contents") (READPAGEMAPBLOCK VP)) (for J from 0 to (SUB1 \NumPMTpages) as FP from (SUB1 (fetch (IFPAGE filePnPMT0) of \InterfacePage)) do (* ;  "read in all the primary map table pages") (LOCAL (MAPVMPAGE (IPLUS (PAGELOC \PageMapTBL) J) FP))) (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE)) do (COND ((IEQ (SETQ D (GETBASE \PageMapTBL I)) \EmptyPMTEntry)) (T (LOCAL (SETVMPTR (ADDBASE \PAGEMAP D))) (READPAGEMAPBLOCK (UNFOLD I \PMblockSize]) (READPAGEMAPBLOCK [LAMBDA (VP) (* lmm " 4-MAY-82 21:12") (PROG ((B VP) P) (FRPTQ \PMblockSize [COND ((NEQ (SETQ P (VBIN2)) 0) (LOCAL (MAPVMPAGE B (SUB1 P] (SETQ B (ADD1 B]) (SETUPPAGEMAP [LAMBDA NIL (* ;  "Edited 5-Nov-92 16:03 by sybalsky:mv:envos") (* ;  "called only from MAKEINIT to initialize the page map") (PROG NIL (* ; "set up page map") (\NEWPAGE \PAGEMAP NIL T) (* ;  "Create 1 page worth of real page table") (CREATEPAGES \PageMapTBL \NumPMTpages NIL T) (* ; "And the segment table.") (* ;; "init PageMapTBL pages to 177777q:") (for I from 0 to (SUB1 (UNFOLD \NumPMTpages WORDSPERPAGE)) do (\PUTBASE \PageMapTBL I \EmptyPMTEntry)) (SETQ NEXTPM 0) (for I from 0 to (SUB1 (fetch (VP PRIMARYKEY) of \NumPageMapPages)) bind (PAGEMAPKEY _ (fetch (VP PRIMARYKEY) of (PAGELOC \PAGEMAP))) do (* ;; "Assign pagemap pages to cover all pagemap pages, so that \DONEWPAGE can guarantee that when it needs to allocate a new pagemap page, that the pagemap page for the new page already exists") (\PUTBASE \PageMapTBL (IPLUS PAGEMAPKEY I) NEXTPM) (SETQ NEXTPM (IPLUS NEXTPM \PMblockSize))) (SETQ NEXTVMEM \FirstVmemBlock) (* ;  "add entry for InterfacePage which must be on FirstVMemBlock") (CREATEPAGES \LOCKEDPAGETABLE \NumLPTPages NIL T]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CHECKIF MACRO [(FLD COMPARISON VALUE STR) (COND ((NOT (COMPARISON VALUE (fetch (IFPAGE FLD) of \InterfacePage ))) (printout T "Warning: " STR "= " (PROGN VALUE) ", but \InterfacePage says " (fetch (IFPAGE FLD) of \InterfacePage) T]) ) (ADDTOVAR INEWCOMS (FNS DUMPINITPAGES) (VARS INITCONSTANTS) (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES)) (ADDTOVAR RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \SHOWPAGETABLE \PRINTFPTOVP)) (ADDTOVAR EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.) (ADDTOVAR MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE) (\LOCKPAGES . MKI.LOCKPAGES)) (ADDTOVAR RD.SUBFNS (\NEWPAGE . VNEWPAGE) (\LOCKPAGES . VLOCKPAGES)) (ADDTOVAR RDPTRS (\REALPAGETABLE)) (ADDTOVAR RDVALS (\RPTSIZE)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE) ) (DEFINEQ (\LOCKFN [LAMBDA (FN) (* bvm%: "22-NOV-82 17:39") [\LOCKCELL (SETQ FN (fetch (LITATOM DEFINITIONCELL) of (EVQ FN] (COND ((fetch (DEFINITIONCELL CCODEP) of FN) (\LOCKCODE (fetch (DEFINITIONCELL DEFPOINTER) of FN]) (\LOCKCODE [LAMBDA (CODEBLOCK) (* rmk%: "15-Aug-84 13:35") (\LOCKWORDS CODEBLOCK (UNFOLD (\#BLOCKDATACELLS CODEBLOCK) WORDSPERCELL]) (\LOCKVAR [LAMBDA (VAR) (* lmm " 5-APR-82 00:43") (\LOCKCELL (fetch (LITATOM VCELL) of (EVQ VAR]) (\LOCKCELL [LAMBDA (X NPGS) (* bvm%: "22-NOV-82 17:54") (\LOCKPAGES (PAGEBASE X) (OR NPGS 1]) (\LOCKWORDS [LAMBDA (BASE NWORDS) (* bvm%: "22-NOV-82 17:35") (\LOCKPAGES (PAGEBASE BASE) (COND (NWORDS (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BASE) NWORDS) WORDSPERPAGE)) (T 1]) ) (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE) (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE \MOVEREALPAGE \INVALIDADDR \INVALIDVP \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE \CLEARWORDS \FLUSHVM \DONEWPAGE \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR RAID \DL.NEWFAULTINIT \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL SETTOPVAL) (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER \UPDATECHAINFREQ \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE \MISCSTATS \DEFSPACE \InterfacePage \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage \NEWVMEMPAGEADDED)))) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA VMEM.PURE.STATE) ) (PRETTYCOMPRINT LLFAULTCOMS) (RPAQQ LLFAULTCOMS [(VARS (FAULTTEST T)) (COMS (* ;  "Bootstrap code, run once when an image is booted") (FNS \FAULTINIT \D01.FAULTINIT \D01.ASSIGNBUFFERS \MAIKO.FAULTINIT \MAIKO.NEWFAULTINIT \MAIKO.ASSIGNBUFFERS \M-VMEMSAVE \MAIKO.NEWPAGE) (* ;; "For setting up (and maybe eventually removing?) MAIKO-specific versions of the generic low-levle functions:") (FNS \MAIKO.DO.MOVDS) (ADDVARS (\MAIKO.MOVDS (TRUE \LOCKEDPAGEP) (\MAIKO.NEWPAGE \NEWPAGE) (\MAIKO.NEWPAGE \DONEWPAGE) (NILL \LOCKPAGES) (NILL \DOLOCKPAGES) (NILL \DOTEMPLOCKPAGES) (NILL \TEMPUNLOCKPAGES) (NILL \UNLOCKPAGES) (NILL \WRITEDIRTYPAGE) (NILL \DIRTYBACKGROUND) (ZERO \COUNTREALPAGES) (NILL \SHOWPAGETABLE) (NILL CHECKPAGEMAP) (EVQ \PAGEFAULT) (EVQ \LOADVMEMPAGE) (NILL \LOADVMEMPAGE) (TRUE \MOVEVMEMFILEPAGE) (TRUE \VALIDADDRESSP))) (FNS \DOVE.FAULTINIT \DL.FAULTINIT \DL.NEWFAULTINIT \DL.UNMAPPAGES \DL.MARK.PAGES.UNAVAILABLE \DL.ASSIGNBUFFERS \CHAIN.UP.RPT)) (COMS (* ; "Pagefault handler") (FNS \FAULTHANDLER \PAGEFAULT \INVALIDADDR \INVALIDVP \FLUSHPAGE \LOADVMEMPAGE \MOVEREALPAGE \LOOKUPPAGEMAP \VALIDADDRESSP \LOCKEDPAGEP \SELECTREALPAGE \SPECIALRP \TRANSFERPAGE \UPDATECHAIN)) (COMS (* ;  "Allocating and locking new pages") (FNS \NEWPAGE \DONEWPAGE \ASSURE.FPTOVP.PAGE \MAKESPACEFORLOCKEDPAGE \MOVEVMEMFILEPAGE \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE \LOCKPAGES \DOLOCKPAGES \TEMPLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \UNLOCKPAGES)) (COMS (* ; "Writing out the vmem") (FNS \FLUSHVM \LOGOUT0 \DOFLUSHVM \RELEASEWORKINGSET \WRITEDIRTYPAGE \WRITEDIRTYPAGE1 \COUNTREALPAGES)) (COMS (* ; "VMEM.PURE.STATE hack") (FNS \DOCOMPRESSVMEM VMEM.PURE.STATE)) (COMS (* ;; "Handling the backing store getting too full--keep running, but if we overflow, we can never \FLUSHVM because there is no place to write some pages") (FNS 32MBADDRESSABLE \SET.VMEM.FULL.STATE \SET.LASTVMEMFILEPAGE \DOVMEMFULLINTERRUPT \FLUSHVMOK?)) (INITVARS (\UPDATECHAINFREQ 144Q) (\PAGEFAULTCOUNTER 0) (\DIRTYPAGECOUNTER 0) (\DIRTYPAGEHINT 0) (\LASTACCESSEDVMEMPAGE 0) (\MAXSHORTSEEK 1750Q) (\MINSHORTSEEK 24Q) (\MAXCLEANPROBES 24Q) (\VMEM.INHIBIT.WRITE) (\VMEM.PURE.LIMIT) (\VMEM.FULL.STATE) (\GUARDVMEMFULL 764Q) (VMEM.COMPRESS.FLG) (\DOFAULTINIT 0) (\VMEMACCESSFN) (\SYSTEMCACHEVARS) (\MAXSWAPBUFFERS 1) (\EXTENDINGVMEMFILE) (\MaxScreenPage 0) (\NEWVMEMPAGEADDED)) (INITVARS (\LASTDIRTYCNT) (\LASTDIRTYFOUND) (\LASTDIRTYSCANPTR) (\DIRTYSEEKMAX 62Q)) (COMS (* ;  "Errors signaled in the maintenance panel") (FNS \MP.ERROR)) (COMS (* ;  "Debugging code. Some of this also runs renamed for extra TeleRaid help") (FNS \ACTONVMEMFILE \SHOWPAGETABLE CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \PRINTFPTOVP \PRINTVP)) (E (RESETSAVE (RADIX 10Q))) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \ACTONVMEMFILE .VMEM.CONSISTENTP. .LOCKABLERP.) (COMS (* ; "Virtual page flags") (CONSTANTS \VMAP.DIRTY \VMAP.CLEAN \VMAP.REF \VMAP.VACANT \VMAP.FLAGS \VMAP.NOTFLAGS) (RECORDS VMEMFLAGS) (MACROS LOGNOT16)) (COMS (* ; "RPT constants") (CONSTANTS \RPT.EMPTY \RPT.UNAVAILABLE \PAGETABLESTOPFLG \RPTENTRYLENGTH) (RECORDS RPT RPT1) (MACROS RPFROMRPT RPTFROMRP NPAGESMACRO)) (COMS (* ; "Virtual to file pagemap") (EXPORT (CONSTANTS \MAXFILEPAGE)) (CONSTANTS \EMPTYPMTENTRY) (RECORDS VP) (MACROS .PAGEMAPBASE.)) (COMS (* ; "FP to VP stuff") (RECORDS FPTOVP) (CONSTANTS \NO.VMEM.PAGE) (MACROS DLRPFROMFP DLFPFROMRP)) (PROP DOPVAL \TOUCHPAGE TIMES3) (COMS (* ; "Locked page table") (MACROS .LOCKEDVPBASE. .LOCKEDVPMASK.)) (CONSTANTS \MAXDIRTYSCANCOUNT \MINVMEMSPAREPAGES \DLBUFFERPAGES) (CONSTANTS 2MBPAGES) (GLOBALVARS \UPDATECHAINFREQ \REALPAGETABLE \RPTLAST \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \PAGEFAULTCOUNTER \LASTDIRTYCNT \LASTDIRTYFOUND \LASTDIRTYSCANPTR \MACHINETYPE \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYSEEKMAX \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \VMEMACCESSFN \SYSTEMCACHEVARS \LASTVMEMFILEPAGE \EXTENDINGVMEMFILE \MaxScreenPage \NEWVMEMPAGEADDED) (GLOBALVARS \#SWAPBUFFERS \#EMUBUFFERS \#DISKBUFFERS \MAXSWAPBUFFERS \EMUSWAPBUFFERS \EMUBUFFERS \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND) (MACROS RWMufMan) (CONSTANTS (DOLOCKCHECKS NIL))) [COMS (* ;;; "MAKEINIT stuff") (FNS ADDPME CHECKIFPAGE DUMPINITPAGES MAKEROOMFORPME MAPPAGES READPAGEMAP READPAGEMAPBLOCK SETUPPAGEMAP) (DECLARE%: DONTCOPY (MACROS CHECKIF) (ADDVARS (INEWCOMS (FNS DUMPINITPAGES) (VARS INITCONSTANTS) (FNS SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES)) (RDCOMS (FNS READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE \LOCKEDPAGEP \LOOKUPPAGEMAP CHECKPAGEMAP CHECKFPTOVP CHECKFPTOVP1 \SHOWPAGETABLE \PRINTFPTOVP)) (EXPANDMACROFNS CHECKIF .LOCKEDVPBASE. .LOCKEDVPMASK. .PAGEMAPBASE.) (MKI.SUBFNS (\NEWPAGE . MKI.NEWPAGE) (\LOCKPAGES . MKI.LOCKPAGES)) (RD.SUBFNS (\NEWPAGE . VNEWPAGE) (\LOCKPAGES . VLOCKPAGES)) (RDPTRS (\REALPAGETABLE)) (RDVALS (\RPTSIZE))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS DUMPINITPAGES SETUPPAGEMAP ADDPME MAKEROOMFORPME MAPPAGES READPAGEMAP READPAGEMAPBLOCK CHECKIFPAGE] (FNS \LOCKFN \LOCKCODE \LOCKVAR \LOCKCELL \LOCKWORDS) [DECLARE%: DONTCOPY (ADDVARS (INEWCOMS (FNS \LOCKFN \LOCKVAR \LOCKCELL \LOCKWORDS \LOCKCODE) (ALLOCAL (ADDVARS (LOCKEDFNS \FAULTHANDLER \FAULTINIT \DOVE.FAULTINIT \D01.FAULTINIT \DL.FAULTINIT \CHAIN.UP.RPT \MAKESPACEFORLOCKEDPAGE \PAGEFAULT \WRITEMAP \LOOKUPPAGEMAP \LOCKEDPAGEP \LOADVMEMPAGE \MOVEREALPAGE \INVALIDADDR \INVALIDVP \SELECTREALPAGE \TRANSFERPAGE \SPECIALRP \UPDATECHAIN \MARKPAGEVACANT \FLUSHPAGE \CLEARWORDS \FLUSHVM \DONEWPAGE \ASSURE.FPTOVP.PAGE \DONEWEPHEMERALPAGE \WRITEDIRTYPAGE1 \COPYSYS0 \COPYSYS0SUBR \RELEASEWORKINGSET \DOFLUSHVM \DOLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES \MP.ERROR RAID \DL.NEWFAULTINIT \DL.MARK.PAGES.UNAVAILABLE \DL.UNMAPPAGES \DL.ASSIGNBUFFERS \D01.ASSIGNBUFFERS \DOCOMPRESSVMEM \MOVEVMEMFILEPAGE \SET.VMEM.FULL.STATE \HINUM \LONUM \ATOMCELL SETTOPVAL) (LOCKEDVARS \REALPAGETABLE \RPTLAST \PAGEFAULTCOUNTER \UPDATECHAINFREQ \RPOFFSET \RPTSIZE \LOCKEDPAGETABLE \EMBUFBASE \EMBUFVP \EMBUFRP \LASTACCESSEDVMEMPAGE \MAXSHORTSEEK \MAXCLEANPROBES \MINSHORTSEEK \DIRTYPAGECOUNTER \DIRTYPAGEHINT \VMEM.INHIBIT.WRITE \VMEM.PURE.LIMIT \VMEM.FULL.STATE \GUARDVMEMFULL VMEM.COMPRESS.FLG \KBDSTACKBASE \MISCSTACKBASE \DOFAULTINIT \FPTOVP \MACHINETYPE \VMEMACCESSFN \TELERAIDBUFFER \EMUDISKBUFFERS \EMUDISKBUFEND \MAXSWAPBUFFERS \EMUBUFFERS \#EMUBUFFERS \#SWAPBUFFERS \#DISKBUFFERS \RCLKSECOND \RCLKMILLISECOND \VALSPACE \EMUSWAPBUFFERS \EM.CURSORBITMAP \PAGEMAP \PageMapTBL \IOCBPAGE \IOPAGE \MISCSTATS \DEFSPACE \InterfacePage \LASTVMEMFILEPAGE \DoveIORegion \MaxScreenPage \NEWVMEMPAGEADDED] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CHECKPAGEMAP \SHOWPAGETABLE VMEM.PURE.STATE \COUNTREALPAGES \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES \DOLOCKPAGES \LOCKPAGES \LOADVMEMPAGE]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA CHECKPAGEMAP \SHOWPAGETABLE VMEM.PURE.STATE \COUNTREALPAGES \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \DOTEMPLOCKPAGES \DOLOCKPAGES \LOCKPAGES \LOADVMEMPAGE) ) (PUTPROPS LLFAULT COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3705Q 3706Q 3707Q 3710Q 3711Q)) (DECLARE%: DONTCOPY (FILEMAP (NIL (31155Q 64663Q (\FAULTINIT 31167Q . 40416Q) (\D01.FAULTINIT 40420Q . 46045Q) ( \D01.ASSIGNBUFFERS 46047Q . 51614Q) (\MAIKO.FAULTINIT 51616Q . 54403Q) (\MAIKO.NEWFAULTINIT 54405Q . 55632Q) (\MAIKO.ASSIGNBUFFERS 55634Q . 61307Q) (\M-VMEMSAVE 61311Q . 64426Q) (\MAIKO.NEWPAGE 64430Q . 64661Q)) (65063Q 72470Q (\MAIKO.DO.MOVDS 65075Q . 72466Q)) (73627Q 164307Q (\DOVE.FAULTINIT 73641Q . 100234Q) (\DL.FAULTINIT 100236Q . 105327Q) (\DL.NEWFAULTINIT 105331Q . 152043Q) (\DL.UNMAPPAGES 152045Q . 153033Q) (\DL.MARK.PAGES.UNAVAILABLE 153035Q . 153773Q) (\DL.ASSIGNBUFFERS 153775Q . 157516Q ) (\CHAIN.UP.RPT 157520Q . 164305Q)) (164352Q 250664Q (\FAULTHANDLER 164364Q . 165242Q) (\PAGEFAULT 165244Q . 171003Q) (\INVALIDADDR 171005Q . 171261Q) (\INVALIDVP 171263Q . 171522Q) (\FLUSHPAGE 171524Q . 176665Q) (\LOADVMEMPAGE 176667Q . 203040Q) (\MOVEREALPAGE 203042Q . 206302Q) (\LOOKUPPAGEMAP 206304Q . 207276Q) (\VALIDADDRESSP 207300Q . 207570Q) (\LOCKEDPAGEP 207572Q . 210774Q) ( \SELECTREALPAGE 210776Q . 232733Q) (\SPECIALRP 232735Q . 233752Q) (\TRANSFERPAGE 233754Q . 241615Q) ( \UPDATECHAIN 241617Q . 250662Q)) (250746Q 325516Q (\NEWPAGE 250760Q . 252755Q) (\DONEWPAGE 252757Q . 262516Q) (\ASSURE.FPTOVP.PAGE 262520Q . 265472Q) (\MAKESPACEFORLOCKEDPAGE 265474Q . 273076Q) ( \MOVEVMEMFILEPAGE 273100Q . 275521Q) (\NEWEPHEMERALPAGE 275523Q . 276254Q) (\DONEWEPHEMERALPAGE 276256Q . 303474Q) (\LOCKPAGES 303476Q . 304122Q) (\DOLOCKPAGES 304124Q . 313670Q) (\TEMPLOCKPAGES 313672Q . 314401Q) (\DOTEMPLOCKPAGES 314403Q . 317416Q) (\TEMPUNLOCKPAGES 317420Q . 322302Q) ( \UNLOCKPAGES 322304Q . 325514Q)) (325564Q 364701Q (\FLUSHVM 325576Q . 332240Q) (\LOGOUT0 332242Q . 334112Q) (\DOFLUSHVM 334114Q . 344600Q) (\RELEASEWORKINGSET 344602Q . 346372Q) (\WRITEDIRTYPAGE 346374Q . 362140Q) (\WRITEDIRTYPAGE1 362142Q . 363467Q) (\COUNTREALPAGES 363471Q . 364677Q)) (364747Q 370276Q (\DOCOMPRESSVMEM 364761Q . 367277Q) (VMEM.PURE.STATE 367301Q . 370274Q)) (370545Q 402263Q ( 32MBADDRESSABLE 370557Q . 371225Q) (\SET.VMEM.FULL.STATE 371227Q . 373150Q) (\SET.LASTVMEMFILEPAGE 373152Q . 374523Q) (\DOVMEMFULLINTERRUPT 374525Q . 400270Q) (\FLUSHVMOK? 400272Q . 402261Q)) (403737Q 404373Q (\MP.ERROR 403751Q . 404371Q)) (404524Q 434334Q (\ACTONVMEMFILE 404536Q . 405335Q) ( \SHOWPAGETABLE 405337Q . 413040Q) (CHECKPAGEMAP 413042Q . 420724Q) (CHECKFPTOVP 420726Q . 421740Q) ( CHECKFPTOVP1 421742Q . 423131Q) (\PRINTFPTOVP 423133Q . 434016Q) (\PRINTVP 434020Q . 434332Q)) ( 454624Q 504322Q (ADDPME 454636Q . 460205Q) (CHECKIFPAGE 460207Q . 460461Q) (DUMPINITPAGES 460463Q . 466101Q) (MAKEROOMFORPME 466103Q . 467603Q) (MAPPAGES 467605Q . 471004Q) (READPAGEMAP 471006Q . 500163Q) (READPAGEMAPBLOCK 500165Q . 500755Q) (SETUPPAGEMAP 500757Q . 504320Q)) (507431Q 511777Q ( \LOCKFN 507443Q . 510146Q) (\LOCKCODE 510150Q . 510512Q) (\LOCKVAR 510514Q . 510764Q) (\LOCKCELL 510766Q . 511232Q) (\LOCKWORDS 511234Q . 511775Q))))) STOP \ No newline at end of file diff --git a/sources/LLFLOAT b/sources/LLFLOAT new file mode 100644 index 00000000..e050d932 --- /dev/null +++ b/sources/LLFLOAT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 19:26:51" {DSK}local>lde>lispcore>sources>LLFLOAT.;2 99380 changes to%: (VARS LLFLOATCOMS) previous date%: "29-Dec-88 19:29:38" {DSK}local>lde>lispcore>sources>LLFLOAT.;1) (* ; " Copyright (c) 1982, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLFLOATCOMS) (RPAQQ LLFLOATCOMS [(DECLARE%: DONTCOPY (MACROS \HAND.FLOATUNBOX) (EXPORT (MACROS POLYEVAL))) (COMS (FNS \PUTBASEFLOATP \GETBASEFLOATP) (MACROS \PUTBASEFLOATP \GETBASEFLOATP (* ;  " the following deal with raw 32 bit numbers") \.PUTBASE32 \.GETBASE32)) [COMS (FNS FTIMES FPLUS FQUOTIENT FDIFFERENCE FGREATERP FABS) (* ; "UFNs") (FNS \SLOWFDIFFERENCE \SLOWFPLUS2 \SLOWFTIMES2 \SLOWFQUOTIENT \SLOWFGREATERP) (* ;; "Float and \float changed to coerce ratios.") (FUNCTIONS FLOAT) (FNS \FZEROP FEQP \FLOAT \FIXP.FROM.FLOATP FIXR \BOXFPLUSDIF \BOXFQUOTIENT \BOXFTIMES2 \INFINITY \MAKEFLOAT MAKEFLOATNUMBER PutFloat) (PROP DMACRO ZEROP) (FNS SQRT) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (RECORDS FLOATP) (CONSTANTS (MAX.DIGITS.ACCURACY 9))) (CONSTANTS (\8BITS 255) (\MAX.HI.FRAC 127) (\SIGNBIT 32768) (\EXPONENT.BIAS 127) (\HIDDENBIT 128) (\MAX.EXPONENT 255)) (MACROS .FLOATUNBOX. .LLSH1. .LLSH8. .LRSH1. .LRSH8. .LRSHSTICKY. .ADDSMALL2. .ADDSMALL3. .SUBSMALL. .POWEROF2.) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (\UNDERFLOW) (MAX.FLOAT (\INFINITY 0)) (MIN.FLOAT (\INFINITY 1))) (P (MOVD? 'FGREATERP 'FGTP] [COMS (* ;; "unboxed ufns") (FNS \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3) (FNS \MATMULT133 \MATMULT144 \MATMULT331 \MATMULT333 \MATMULT441 \MATMULT444) (* ; "unboxed arg handling") (DECLARE%: DONTCOPY (EXPORT (MACROS \CALLER.ARGS] (COMS (FNS FLOATP.TO.BCPL BCPL.TO.FLOATP) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS BCPLNUM EFPN))) [COMS (VARIABLES INTPOWERS) (FUNCTIONS ENUM-STRING FNUM-STRING FLTSTR FLTINTLOG DIGITSBDP INTTOEXT EXTTOINT SPLIT8 TIMESPOW10 \EXTFTIMES \EXTFQUOTIENT \EXTNORMALIZE \CONVERT.FLOATING.NUMBER \FLOATINGSCALE) (FNS \INIT.POWERS.OF.TEN) (DECLARE%: DONTCOPY (RESOURCES \CFNSTRING) (GLOBALVARS \POWERS.OF.TEN) (MACROS \POWER.OF.TEN)) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITRESOURCES \CFNSTRING) (P (\INIT.POWERS.OF.TEN] (PROP ARGNAMES \UNBOXFLOAT1 \UNBOXFLOAT2 \UNBOXFLOAT3) (PROP FILETYPE LLFLOAT) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FPLUS FTIMES]) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \HAND.FLOATUNBOX MACRO [LAMBDA (X) (* ;; "this doesn't call \FLOATUNBOX because it's used by the UFN case of \FLOATUNBOX. Takes a FLOATP and returns the raw unboxed bits of the value. Must be used with great caution as raw unboxed bits are not allowed in many places.") (\VAG2 (fetch (FLOATP HIWORD) of (SETQ X (FLOAT X))) (fetch (FLOATP LOWORD) of X]) ) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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)))) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\PUTBASEFLOATP [LAMBDA (BASE OFFST VAL) (* Pavel " 6-Oct-86 21:52") (* ;;  "put the floatp VAL at offset OFFST from BASE. Used by REPLACEFIELD of floatp fields") (\FLOATBOX (\.PUTBASE32 BASE OFFST (\FLOATUNBOX VAL]) (\GETBASEFLOATP [LAMBDA (BASE OFFST) (* Pavel " 6-Oct-86 21:52") (* ;; "get the floatp at OFFST from BASE") (\FLOATBOX (\.GETBASE32 BASE OFFST]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \PUTBASEFLOATP DMACRO [(BASE OFFST VAL) (* ;  "put the floatp VAL at offset OFFST from BASE. Used by REPLACEFIELD of floatp fields") (\FLOATBOX (\.PUTBASE32 BASE OFFST (\FLOATUNBOX VAL]) (PUTPROPS \GETBASEFLOATP DMACRO ((BASE OFFST) (* ;  "get the floatp at OFFST from BASE") (\FLOATBOX (\.GETBASE32 BASE OFFST)))) (PUTPROPS \.PUTBASE32 DMACRO (= . \PUTBASEPTR)) (PUTPROPS \.GETBASE32 DMACRO (APPLY* COMP.GETBASE NIL GETBASE.32)) ) (DEFINEQ (FTIMES [LAMBDA N (* JonL "17-May-84 18:35") (PROG (R (J 1)) [COND ((EQ 0 N) (RETURN 1.0)) ((EQ N 1) (RETURN (FLOAT (ARG N 1] (SETQ R (ARG N 1)) LP (COND ((NEQ J N) (SETQ J (ADD1 J)) (* ;  "assumes that FTIMES compiles into opcode that punts into \FTIMES.UFN") (SETQ R (FTIMES R (ARG N J))) (GO LP))) (RETURN R]) (FPLUS [LAMBDA N (* JonL "17-May-84 18:35") (PROG (R (J 1)) [COND ((EQ 0 N) (RETURN 0.0)) ((EQ N 1) (RETURN (FLOAT (ARG N 1] (SETQ R (ARG N 1)) LP (COND ((NEQ J N) (SETQ J (ADD1 J)) (SETQ R (FPLUS R (ARG N J))) (GO LP))) (RETURN R]) (FQUOTIENT [LAMBDA (X Y) (* lmm "11-FEB-82 14:02") ((OPCODES FQUOTIENT) X Y]) (FDIFFERENCE [LAMBDA (X Y) (* lmm "14-MAR-84 22:20") ((OPCODES FDIFFERENCE) X Y]) (FGREATERP [LAMBDA (X Y) (* lmm "17-Oct-84 15:45") (* ;; "to compare two floats, compare signbits, and if they are equal compare the remaining 31 bits of each number as unsigned integers") ((OPCODES FGREATERP) X Y]) (FABS [LAMBDA (X) (* Pavel " 6-Oct-86 21:53") (\FLOATBOX ((OPCODES UBFLOAT1 2) (\FLOATUNBOX X]) ) (* ; "UFNs") (DEFINEQ (\SLOWFDIFFERENCE [LAMBDA (X Y) (* lmm "17-Oct-84 15:42") (\CALLME 'FDIFFERENCE) (\BOXFPLUSDIF X Y T]) (\SLOWFPLUS2 [LAMBDA (X Y) (* lmm "17-Oct-84 15:42") (* ; "UFN for FPLUS") (\CALLME 'FPLUS) (\BOXFPLUSDIF X Y]) (\SLOWFTIMES2 [LAMBDA (X Y) (* lmm "17-Oct-84 15:43") (\CALLME 'FTIMES) (\BOXFTIMES2 X Y]) (\SLOWFQUOTIENT [LAMBDA (X Y) (* lmm "17-Oct-84 15:43") (\CALLME 'FQUOTIENT) (* ; "UFN for FQUOTIENT") (\BOXFQUOTIENT X Y NIL]) (\SLOWFGREATERP [LAMBDA (X Y) (* JonL "17-May-84 18:34") (* ;; "to compare two floats, compare signbits, and if they are equal compare the remaining 31 bits of each number as unsigned integers") (COND [(AND (FLOATP X) (FLOATP Y)) (* ;; "Can speed this up by not unpacking--check signs, then compare remaining 31d bits as unsigned numbers") (PROG ((HX (fetch (FLOATP HIWORD) of X)) (HY (fetch (FLOATP HIWORD) of Y)) SIGNX) (RETURN (COND ((NEQ (SETQ SIGNX (LOGAND HX \SIGNBIT)) (LOGAND HY \SIGNBIT)) (EQ 0 SIGNX)) [(EQ 0 SIGNX) (* ; "numbers are positive") (OR (IGREATERP HX HY) (AND (EQ HX HY) (IGREATERP (fetch LOWORD of X) (fetch LOWORD of Y] (T (* ;  "Numbers are negative, so compare in other direction") (OR (IGREATERP HY HX) (AND (EQ HX HY) (IGREATERP (fetch LOWORD of Y) (fetch LOWORD of X] (T (PROG (HX LX SIGNX EXPX HY LY SIGNY EXPY) (.FLOATUNBOX. X SIGNX EXPX HX LX) (.FLOATUNBOX. Y SIGNY EXPY HY LY) (RETURN (COND ((NEQ SIGNX SIGNY) (EQ 0 SIGNX)) [(EQ 0 SIGNX) (* ; "numbers are positive") (OR (IGREATERP EXPX EXPY) (AND (EQ EXPX EXPY) (OR (IGREATERP HX HY) (AND (EQ HX HY) (IGREATERP LX LY] (T (* ;  "Numbers are negative, so compare in other direction") (OR (IGREATERP EXPY EXPX) (AND (EQ EXPY EXPX) (OR (IGREATERP HY HX) (AND (EQ HY HX) (IGREATERP LY LX]) ) (* ;; "Float and \float changed to coerce ratios.") (CL:DEFUN FLOAT (CL:NUMBER &OPTIONAL CL::OTHER) (\DTEST CL:NUMBER 'FLOATP)) (DEFINEQ (\FZEROP [LAMBDA (X) (* JonL "27-Sep-84 22:20") (* ;; "Support for generic ZEROP macro") (AND [EQ 0 (fetch LOWORD of (\DTEST X 'FLOATP] (EQ 0 (fetch HIWORDNOSIGNBIT of X]) (FEQP [LAMBDA (X Y) (* JonL "17-May-84 20:26") (COND [(AND (FLOATP X) (FLOATP Y)) (* ;; "If they're both floatp already, can essentially compare contents, since floatps are generally normalized.") (* ;  "Last OR clause is to check for comparing a negative zero to a positive zero.") (AND (EQ (fetch LOWORD of X) (fetch LOWORD of Y)) (OR (EQ (fetch HIWORD of X) (fetch HIWORD of Y)) (AND (EQ 0 (fetch HIWORDNOSIGNBIT of X)) (EQ 0 (fetch HIWORDNOSIGNBIT of Y] (T (PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY) (.FLOATUNBOX. X SIGNX EXPX HX LX T) (.FLOATUNBOX. Y SIGNY EXPY HY LY T) (RETURN (AND (EQ HX HY) (EQ LX LY) (EQ EXPX EXPY) (OR (EQ SIGNX SIGNY) (AND (EQ 0 EXPX) (EQ 0 HX) (EQ 0 LX]) (\FLOAT [LAMBDA (X) (* ; "Edited 28-Feb-87 18:42 by jop") (OR (FLOATP X) (SELECTC (NTYPX X) (\FIXP (LET ((HI (fetch (FIXP HINUM) of X)) (LO (fetch (FIXP LONUM) of X)) (SIGN 0)) (COND ((IGREATERP HI MAX.POS.HINUM) (.NEGATE. HI LO) (SETQ SIGN 1))) (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31) HI LO T))) (\SMALLP (LET* [(HI 0) (SIGN 0) (LO (COND ((IGEQ X 0) X) (T (SETQ SIGN 1) (* ; "X is negative--negate it") (COND ((EQ 0 (\LOLOC X)) (* ; "Min small integer") (SETQ HI 1) 0) (T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (\LOLOC X] (\MAKEFLOAT SIGN (IPLUS \EXPONENT.BIAS 31) HI LO T))) (COND ((TYPENAMEP X 'BIGNUM) (\BIGNUM.TO.FLOAT X)) ((TYPEP X 'RATIO) (FQUOTIENT (CL::RATIO-NUMERATOR X) (CL::RATIO-DENOMINATOR X))) (T (CL:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(AND NUMBER (NOT COMPLEX)) :NAME X :VALUE X :MESSAGE "a non-complex number"]) (\FIXP.FROM.FLOATP [LAMBDA (X) (* lmm "19-Sep-85 15:08") (PROG (SIGN EXP HI LO) (.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO)) (SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS))) (* ;  "number of bits to left of binary point") [COND ((ILESSP EXP 0) (RETURN 0)) ([OR (IGREATERP EXP 32) (AND (EQ EXP 32) (OR (EQ 0 SIGN) (NEQ HI \SIGNBIT) (NEQ LO 0] (RETURN (LSH (LET ((VAL (PLUS (LSH HI 16) LO))) (if (EQ SIGN 1) then (MINUS VAL) else VAL)) (DIFFERENCE EXP 32] [COND ((IGEQ (SETQ EXP (IDIFFERENCE 32 EXP)) 16) (SETQ LO (LRSH HI (IDIFFERENCE EXP 16))) (SETQ HI 0)) (T (* ;  "large integer, have to manipulate both halves") (FRPTQ EXP (.LRSH1. HI LO] (COND ((EQ SIGN 1) (.NEGATE. HI LO))) (RETURN (\MAKENUMBER HI LO)) RETZERO (RETURN 0]) (FIXR [LAMBDA (X) (* lmm "22-JUL-84 20:48") (OR (FIXP X) (PROG (SIGN EXP HI LO ROUNDINGBITS) (.FLOATUNBOX. X SIGN EXP HI LO (GO RETZERO)) (SETQ EXP (IDIFFERENCE EXP (SUB1 \EXPONENT.BIAS))) (* ;  "number of bits to left of binary point") [COND ((ILESSP EXP 0) (RETURN 0)) [(IGEQ EXP 32) (* ; "FIX handles this") (RETURN (FIX (FPLUS X 0.5] ([OR (IGREATERP EXP 32) (AND (EQ EXP 32) (OR (EQ 0 SIGN) (NEQ HI \SIGNBIT) (NEQ LO 0] (* ;  "Overflow: number is larger than MAX.FIXP") (RETURN (SELECTQ \OVERFLOW (T (LISPERROR "OVERFLOW" X T)) (COND ((EQ 0 SIGN) MAX.FIXP) (T MIN.FIXP] [COND ((IGEQ EXP 24) (* ;  "No decimal places to worry about, so no rounding, just shift into place") (FRPTQ (IDIFFERENCE 32 EXP) (.LRSH1. HI LO))) (T (* ;; "Shift right until binary point is in the middle of LO, as per \MAKEFLOAT; then decide how to round, and shift right once more") [COND ((IGEQ (SETQ EXP (IDIFFERENCE 24 EXP)) 16) (* ;  "shifting all the way out of the high word") (SETQ LO (LRSH [LOGOR HI (COND ((EQ 0 LO) 0) (T (* ; "Sticky bits") (LRSH \8BITS 1] (IDIFFERENCE EXP 16))) (SETQ HI 0)) (T (* ;  "Shift both halves, keeping sticky bits in LO") (FRPTQ EXP (.LRSHSTICKY. HI LO] (SETQ ROUNDINGBITS (LOGAND LO \8BITS)) (.LRSH8. HI LO) (* ; "Shift the rest of the way") (COND ((OR (IGREATERP ROUNDINGBITS 128) (AND (EQ ROUNDINGBITS 128) (ODDP LO))) (* ;  "Round up if greater than .5, or exactly 0.5 and rounding up will make number even") (COND ((EQ LO MAX.SMALL.INTEGER) (SETQ LO 0) (add HI 1)) (T (add LO 1] (COND ((EQ SIGN 1) (.NEGATE. HI LO))) (RETURN (\MAKENUMBER HI LO)) RETZERO (RETURN 0]) (\BOXFPLUSDIF [LAMBDA (X Y SUBTRACT BOX) (* JonL "17-May-84 18:56") (* ; "Does X-Y if SUBTRACT is true") (PROG (SIGNX EXPX HX LX SIGNY EXPY HY LY EXPDIFF PLEASENORMALIZE CARRY) (.FLOATUNBOX. Y SIGNY EXPY HY LY) [COND (SUBTRACT (SETQ SIGNY (IDIFFERENCE 1 SIGNY] (.FLOATUNBOX. X SIGNX EXPX HX LX (GO RESULTISY)) [COND ((AND (EQ 0 HY) (EQ 0 LY)) (GO DONE)) ((EQ EXPX \MAX.EXPONENT) (* ;; "X = infinity, so result is infinity. This is not quite right if Y is infinity of opposite sign, though") (RETURN (\INFINITY SIGNX BOX))) ((EQ EXPY \MAX.EXPONENT) (RETURN (\INFINITY SIGNY BOX] (SETQ EXPDIFF (IDIFFERENCE EXPX EXPY)) (* ;  "first align the binary points by right-shifting the smaller guy") [COND [(IGREATERP EXPDIFF 0) (COND ((IGREATERP EXPDIFF 31) (* ; "Y would get shifted into oblivion") (GO DONE)) (T (FRPTQ EXPDIFF (.LRSHSTICKY. HY LY] ((NEQ EXPDIFF 0) (COND ((ILESSP EXPDIFF -31) (GO RESULTISY)) (T (FRPTQ (IMINUS EXPDIFF) (.LRSHSTICKY. HX LX)) (SETQ EXPX EXPY] [COND [(EQ SIGNX SIGNY) (* ; "same sign, add magnitudes") (SETQ CARRY (.ADDSMALL2. LX LY)) (COND ((EQ (.ADDSMALL3. HX HY CARRY) 1) (* ;  "there was a carry out of HX, so shift everyone right and stick it back in") (.LRSHSTICKY. HX LX) (add HX \SIGNBIT) (add EXPX 1] (T (* ;  "subtract magnitudes, smaller from larger") (COND ((OR (ILESSP HX HY) (AND (EQ HX HY) (ILESSP LX LY))) (* ; "Y is bigger, so swap") (swap HX HY) (swap LX LY) (SETQ SIGNX SIGNY))) (SETQ PLEASENORMALIZE (NEQ (LOGAND HX \SIGNBIT) 0)) (* ; "thus if neither operand is normalized, we won't waste time normalizing and denormalizing the result") (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY) (.SUBSMALL. LX LY] DONE (RETURN (\MAKEFLOAT SIGNX EXPX HX LX PLEASENORMALIZE BOX)) RESULTISY (RETURN (\MAKEFLOAT SIGNY EXPY HY LY NIL BOX]) (\BOXFQUOTIENT [LAMBDA (X Y BOX) (* lmm "18-DEC-80 13:40") (PROG (SIGNX EXPX HX LX (SIGNY 0) (EXPY 0) HY LY BORROW (HZ 0) (LZ 0)) (.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE)) (.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DIVZERO)) (COND ((EQ EXPX \MAX.EXPONENT) (* ; "X is infinity") (RETURN (\INFINITY SIGNX BOX))) ((EQ EXPY \MAX.EXPONENT) (* ; "Y = infinity, result is zero") (GO DONE))) (* ;; "Divide X -- double length, implicitly extended with zeros -- by Y. At each step, Y is subtracted from X if possible, putting a one bit in the quotient, and then X and the quotient are shifted left. Result is a 32-bit quotient.") (.LRSH1. HX LX) (.LRSH1. HY LY) (* ;  "shift these right one so that we never have to worry about carrying out of the high bit") (FRPTQ 31 (PROGN (.LLSH1. HZ LZ) (* ;  "shift quotient left one as we accumulate it") (COND ((OR (AND (EQ HX HY) (IGEQ LX LY)) (IGREATERP HX HY)) (* ; "X GE Y, so subtract Y") (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY) (.SUBSMALL. LX LY))) (SETQ LZ (ADD1 LZ)) (* ;  "note that this never overflows, because of the left shift we did above") )) (* ;; "now shift dividend left one. After the subtraction the high-order bit must be off, so this works okay") (.LLSH1. HX LX))) (.LLSH1. HZ LZ) (* ;  "left shift result 1 to compensate for the earlier right shifts") [COND ((OR (NEQ HX 0) (NEQ LX 0)) (* ; "set sticky bit") (SETQ LZ (LOGOR LZ 1] DONE (RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY) (IPLUS (IDIFFERENCE EXPX EXPY) \EXPONENT.BIAS) HZ LZ T BOX)) DIVZERO (RETURN (COND ((EQ \OVERFLOW T) (ERROR "FLOATING DIVIDE BY ZERO" Y)) (T (\INFINITY SIGNX BOX]) (\BOXFTIMES2 [LAMBDA (X Y BOX) (* JonL "17-May-84 18:56") (PROG (SIGNX EXPX HX LX (SIGNY 0) (EXPY 0) HY LY (HHY 0) (HHZ 0) (HZ 0) (LZ 0) SAVEHY SAVELY CARRY) (.FLOATUNBOX. X SIGNX EXPX HX LX (GO DONE) T) (.FLOATUNBOX. Y SIGNY EXPY HY LY (GO DONE) T) [COND ((EQ EXPX \MAX.EXPONENT) (* ; "X = infinity") (RETURN (\INFINITY SIGNX BOX))) ((EQ EXPY \MAX.EXPONENT) (RETURN (\INFINITY SIGNY BOX] (* ;; "Multiply the significands. We have two 24-bit integers, so have a 48-bit, 3-word product, stored as {HHZ,HZ,LZ}. Multiplication will be in two steps: multiply LX by {HY,LY}, storing in result, and then multiply HX by {HY,LY}, storing in the top two words. The first multiplication can be omitted in the not uncommon case of a zero low fraction, and the second multiplication is a little bit simpler, since result fits in two words.") (COND ((EQ 0 LX) (GO LP2)) ((EQ 0 LY) (* ; "swap operands to make life easier") (swap HX HY) (swap LX LY) (GO LP2))) (SETQ SAVEHY HY) (* ; "we'll need these for second step") (SETQ SAVELY LY) LP1 (* ; "multiply LX times HY,LY") [COND ((NEQ (LOGAND LX 1) 0) (SETQ CARRY (.ADDSMALL2. LZ LY)) (SETQ CARRY (.ADDSMALL3. HZ HY CARRY)) (SETQ HHZ (IPLUS HHZ HHY CARRY] (COND ((EQ 0 (SETQ LX (LRSH LX 1))) (* ; "done with this step") (SETQ HY SAVEHY) (SETQ LY SAVELY) (GO LP2))) (SETQ HHY (LLSH HHY 1)) (* ; "left shift Y by one") (SETQ HY (LLSH (COND ((IGREATERP HY MAX.POS.HINUM) (add HHY 1) (LOGAND HY MAX.POS.HINUM)) (T HY)) 1)) (SETQ LY (LLSH (COND ((IGREATERP LY MAX.POS.HINUM) (add HY 1) (LOGAND LY MAX.POS.HINUM)) (T LY)) 1)) (GO LP1) LP2 (* ;; "multiply HX times HY,LY, adding into high two words of Z. No overflow here, since HX has at most (and usually exactly) 8 bits") [COND ((NEQ (LOGAND HX 1) 0) (SETQ CARRY (.ADDSMALL2. HZ LY)) (SETQ HHZ (IPLUS HHZ HY CARRY] (COND ((NEQ (SETQ HX (LRSH HX 1)) 0) (.LLSH1. HY LY) (GO LP2))) DONE (* ;; "We now have a 48-bit result in HHZ,HZ,LZ. \MAKEFLOAT can handle it from here. Note that the exponent we give is bumped by 1, because the 'binary point' , which was between the first and second bits, was moved one to the right by multiplying") (RETURN (\MAKEFLOAT (LOGXOR SIGNX SIGNY) (IPLUS EXPX EXPY (IDIFFERENCE 1 \EXPONENT.BIAS)) HHZ HZ T BOX]) (\INFINITY [LAMBDA (SIGN BOX) (* lmm "17-DEC-80 20:32") (* ;; "Returns 'infinity' of the appropriate SIGN (0 or 1), reusing floating BOX if given") (* ;; "For now, don't return true infinity, but rather the largest representable finite number, so that miscellaneous floating-point routines don't die") (OR (FLOATP BOX) (SETQ BOX (create FLOATP))) (replace (FLOATP SIGNBIT) of BOX with SIGN) (replace (FLOATP EXPONENT) of BOX with (SUB1 \MAX.EXPONENT)) (replace (FLOATP HIFRACTION) of BOX with \MAX.HI.FRAC) (replace (FLOATP LOFRACTION) of BOX with 65535) BOX]) (\MAKEFLOAT [LAMBDA (SIGN EXP HI LO NORMALIZE BOX) (* JonL "17-May-84 18:56") (* ;;; "packs up the pieces of a floating point result into a single number box, n the process checking for underflow, rounding, checking overflow. BOX is optional box to reuse. NORMALIZE is true if we should normalize the result first (make sign bit of HI 1); otherwise we assume result is already normalized") (PROG (ROUNDINGBITS) (OR (FLOATP BOX) (SETQ BOX (create FLOATP))) TOP (COND ((AND (EQ 0 HI) (EQ 0 LO)) (replace HIWORD of BOX with (replace LOWORD of BOX with 0)) (RETURN BOX))) [COND (NORMALIZE [COND ((EQ 0 HI) (SETQ HI LO) (SETQ LO 0) (SETQ EXP (IDIFFERENCE EXP 16] (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO) (SETQ EXP (SUB1 EXP] [COND ((ILEQ EXP 0) (* ;  "underflow. Scale by 2^Exponentbias in order to deliver a useful value to the error handler") (SELECTQ \UNDERFLOW (T (RETURN (LISPERROR "FLOATING UNDERFLOW" (\MAKEFLOAT SIGN (IPLUS EXP \EXPONENT.BIAS) HI LO NIL BOX) T))) NIL) (* ;; "If we have to return a result, we must 'denormalize' this number. This gives us a little more time before vanishing to zero") (COND ((ILESSP EXP -24) (* ;  "too small even as denormalized number") (SETQ HI (SETQ LO 0)) (GO TOP)) (T (* ;; "denormalize by shifting right until the exponent is logically 1; final result will have exponent zero, hidden bit zero") (FRPTQ (IDIFFERENCE 1 EXP) (.LRSHSTICKY. HI LO)) (SETQ EXP 0] (SETQ ROUNDINGBITS (LOGAND LO \8BITS)) (* ;  "round result. low order 8 bits are used for rounding") (.LRSH8. HI LO) [COND ([OR (IGREATERP ROUNDINGBITS 128) (AND (EQ ROUNDINGBITS 128) (NOT (EQ 0 (LOGAND LO 1] (* ;; "round up if the left over fraction was greater than 1/2; if it was equal to a half, round to the even result") (COND [(EQ LO MAX.SMALL.INTEGER) (* ; "can't add 1 directly") (SETQ LO 0) (SETQ HI (ADD1 HI)) (COND ((IGREATERP HI (LOGOR \HIDDENBIT \MAX.HI.FRAC)) (* ; "'1.11111--' became '10.000--'") (SETQ HI (LRSH HI 1)) (add EXP 1] (T (SETQ LO (ADD1 LO] [COND ((AND (EQ HI 0) (EQ LO 0)) (* ;; "result is zero. This could have snuck in if we denormalized a number that didn't have enough digits to survive") (GO TOP)) ((IGEQ EXP \MAX.EXPONENT) (* ;; "overflow. If trap enabled, wrap the exponent around to middle of range (divide by 2^exponentbias) to provide a number of possible use to error handler") (SELECTQ \OVERFLOW (T (RETURN (LISPERROR "FLOATING OVERFLOW" (\MAKEFLOAT SIGN (IDIFFERENCE EXP \EXPONENT.BIAS) HI LO NIL BOX) T))) NIL) (RETURN (\INFINITY SIGN BOX] (replace SIGNBIT of BOX with SIGN) (replace EXPONENT of BOX with EXP) (replace HIFRACTION of BOX with HI) (replace LOFRACTION of BOX with LO) (RETURN BOX]) (MAKEFLOATNUMBER [LAMBDA (N0 N1) (* lmm "12-Apr-85 18:19") (* ; "CALLED FROM FETCHFIELD") (LET [(VAL (NCREATE 'FLOATP] (replace (FLOATP HIWORD) of VAL with N0) (replace (FLOATP LOWORD) of VAL with N1) VAL]) (PutFloat [LAMBDA (PTR N) (* lmm "29-Dec-84 11:32") (* ; "used by REPLACEFIELD") (\PUTBASEFLOATP PTR 0 N) N]) ) (PUTPROPS ZEROP DMACRO [OPENLAMBDA (X) (COND ((EQ X 0)) ((FLOATP X) (\FZEROP X]) (DEFINEQ (SQRT [LAMBDA (N) (* lmm "24-Jan-85 19:13") (PROG ((X (FLOAT N)) V) (DECLARE (TYPE FLOATP X V)) (if (FLESSP X 0.0) then (ERROR "SQRT OF NEGATIVE VALUE" N) elseif (NOT (FGREATERP X 0.0)) then (* ; "Trichotomy ==> X = 0.0") (RETURN 0.0)) (SETQ V (create FLOATP EXPONENT _ (LOGAND (IPLUS \EXPONENT.BIAS (LRSH (LOGAND (IDIFFERENCE (fetch (FLOATP EXP) of X) \EXPONENT.BIAS) (MASK.1'S 0 BITSPERWORD)) 1)) \MAX.EXPONENT) HIFRACTION _ (fetch (FLOATP HIFRAC) of X))) (* ;; "Exponent is stored as excess \EXPONENT.BIAS and although the LRSH doesn't really do division by 2 (e.g., when the arg is negative) at least the low-order 8 bits will be right. It doesn't even matter that it may be off-by-one, due to the infamous 'Arithmetic Shifting Considered Harmful' since it is only an estimate.") [FRPTQ 4 (SETQ V (FTIMES 0.5 (FPLUS V (FQUOTIENT X V] (RETURN V]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (RPAQQ MAX.DIGITS.ACCURACY 9) (CONSTANTS (MAX.DIGITS.ACCURACY 9)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (RPAQQ \8BITS 255) (RPAQQ \MAX.HI.FRAC 127) (RPAQQ \SIGNBIT 32768) (RPAQQ \EXPONENT.BIAS 127) (RPAQQ \HIDDENBIT 128) (RPAQQ \MAX.EXPONENT 255) (CONSTANTS (\8BITS 255) (\MAX.HI.FRAC 127) (\SIGNBIT 32768) (\EXPONENT.BIAS 127) (\HIDDENBIT 128) (\MAX.EXPONENT 255)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .FLOATUNBOX. MACRO [(FLONUM SIGN EXP HI LO ZEROFORM DONTSHIFT RESTARTIFINTEGER) (* ;; "Unpacks a floating point number FLONUM into its components. ZEROFORM is evaluated if the number is true zero. The fraction is unpacked into HI and LO, with the binary point implicitly between bits 0 and 1 of HI. If DONTSHIFT is true, the fraction is left in its original state, with 8 bits in HI and 16 in LO. If FLONUM is not floating, it is coerced.") (PROG NIL RETRY [COND ((NOT (FLOATP FLONUM)) (* ;  "Float and normalize the non-floatp") (COND ('RESTARTIFINTEGER (SETQ FLONUM (LISPERROR "NON-NUMERIC ARG" FLONUM T)) (GO RESTARTIFINTEGER)) (T (SELECTC (NTYPX FLONUM) (\FIXP (SETQ HI (fetch (FIXP HINUM) of FLONUM)) (SETQ LO (fetch (FIXP LONUM) of FLONUM)) (SETQ SIGN (COND ((IGREATERP HI MAX.POS.HINUM) (.NEGATE. HI LO) 1) (T 0)))) (\SMALLP (SETQ HI 0) [SETQ LO (COND ((SMALLPOSP FLONUM) (SETQ SIGN 0) FLONUM) (T (SETQ SIGN 1) (* ; "FLONUM is negative--negate it") (COND ((EQ 0 (LOLOC FLONUM)) (* ; "Min small integer") (SETQ HI 1) 0) (T (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (LOLOC FLONUM]) (PROGN (SETQ FLONUM (FLOAT FLONUM)) (GO RETRY))) [COND [(EQ 0 HI) (COND ((EQ 0 LO) (SETQ EXP 0) (PROGN ZEROFORM (RETURN))) (T (SETQ HI LO) (SETQ LO 0) (SETQ EXP (IPLUS \EXPONENT.BIAS 15] ((IGREATERP HI 255) (* ; "Not exact, punt") (SETQ FLONUM (FLOAT FLONUM)) (GO UNPACK)) (T (SETQ EXP (IPLUS \EXPONENT.BIAS 31] [COND ((ILEQ HI 255) (* ; "Do a big shift first.") (.LLSH8. HI LO) (SETQ EXP (IDIFFERENCE EXP 8] (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO) (SETQ EXP (SUB1 EXP))) (COND (DONTSHIFT (.LRSH8. HI LO))) (RETURN] UNPACK (SETQ SIGN (fetch (FLOATP SIGNBIT) of FLONUM)) (SETQ LO (fetch (FLOATP LOFRACTION) of FLONUM)) (SETQ HI (fetch (FLOATP HIFRACTION) of FLONUM)) [COND [(EQ 0 (SETQ EXP (fetch (FLOATP EXPONENT) of FLONUM))) (* ;  "zero or a de-normalized number from underflow") (COND ((AND (EQ 0 HI) (EQ 0 LO)) (* ;  "A zero, regardless of the sign bit zero") ZEROFORM) (T (* ;  "need bias adjust to account for lack of hidden bit") (SETQ EXP 1] ((NEQ EXP \MAX.EXPONENT) (* ;  "might want to check for NaN's here if EXP = \MAX.EXPONENT") (* ;  "OR in the implicit high bit of fraction") (SETQ HI (IPLUS HI \HIDDENBIT] (COND ((NOT DONTSHIFT) (.LLSH8. HI LO]) (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 .LLSH8. MACRO ((HI LO) (* ;  "shift pair left 8, assuming no overflow") (SETQ HI (IPLUS (LLSH HI 8) (LRSH LO 8))) (SETQ LO (LLSH (LOGAND LO \8BITS) 8)))) (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 .LRSH8. MACRO ((HI LO) (SETQ LO (IPLUS (LRSH LO 8) (LLSH (LOGAND HI \8BITS) 8))) (SETQ HI (LRSH HI 8)))) (PUTPROPS .LRSHSTICKY. MACRO ((HI LO) (* ;  "shifts pair right one, but low-order bit is sticky -- if it ever becomes 1, it stays 1") (SETQ LO (LOGOR (LRSH LO 1) (LOGAND LO 1))) [COND ((NEQ (LOGAND HI 1) 0) (SETQ LO (IPLUS LO \SIGNBIT] (SETQ HI (LRSH HI 1)))) (PUTPROPS .ADDSMALL2. MACRO [(X Y) (PROGN (* ;  "does X _ X+Y, returning the carry bit") (COND ((IGREATERP X (IDIFFERENCE MAX.SMALL.INTEGER Y)) [SETQ X (IDIFFERENCE X (IDIFFERENCE MAX.SMALL.INTEGER (SUB1 Y] 1) (T (SETQ X (IPLUS X Y)) 0]) (PUTPROPS .ADDSMALL3. MACRO [(X Y CARRY) (PROGN (* ;  "X _ X+Y+CARRY, returning the new carry bit") (COND ((IGREATERP X (IDIFFERENCE (IDIFFERENCE MAX.SMALL.INTEGER Y) CARRY)) (SETQ X (IDIFFERENCE X (IDIFFERENCE [IDIFFERENCE MAX.SMALL.INTEGER (SUB1 (COND ((EQ Y 0) (PROG1 CARRY (SETQ CARRY 0) )) (T Y] CARRY))) 1) (T (SETQ X (IPLUS X Y CARRY)) 0]) (PUTPROPS .SUBSMALL. MACRO ((X Y) (* ;  "Subtract Y from X, returning the borrow out of the next word") (COND ((ILEQ Y X) (SETQ X (IDIFFERENCE X Y)) 0) (T [SETQ X (ADD1 (IDIFFERENCE MAX.SMALL.INTEGER (IDIFFERENCE Y X] 1)))) (PUTPROPS .POWEROF2. MACRO [OPENLAMBDA (X) (COND ((ILESSP X 16) (LSH 1 X)) (T (LSH (LSH 1 (IDIFFERENCE X 16)) 16]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ \UNDERFLOW NIL) (RPAQ MAX.FLOAT (\INFINITY 0)) (RPAQ MIN.FLOAT (\INFINITY 1)) (MOVD? 'FGREATERP 'FGTP) ) (* ;; "unboxed ufns") (DEFINEQ (\UNBOXFLOAT1 [LAMBDA (OP) (* lmm " 5-Mar-86 11:35") (* ;; "UFN for the unboxed floating 1-arg cases") (\SLOWRETURN) (SELECTQ OP (0 (* ; "BOX") (\CALLER.ARGS (X) (LET [(VAL (NCREATE 'FLOATP] (replace (FLOATP HIWORD) of VAL with (\HILOC X)) (replace (FLOATP LOWORD) of VAL with (\LOLOC X)) VAL))) (1 (* ; "UNBOX") (\CALLER.ARGS (X) (\HAND.FLOATUNBOX X))) (2 (* ; "UFABS") (\CALLER.ARGS ((X FLOATP)) (\FLOATUNBOX (ABS X)))) (3 (* ; "UFNEGATE") (\CALLER.ARGS ((X FLOATP)) (\FLOATUNBOX (FMINUS X)))) (4 (* ; "UFIX") (\CALLER.ARGS ((X FLOATP)) (FIX X))) (HELP "\UNBOXFLOAT1 called with illegal op " OP]) (\UNBOXFLOAT2 [LAMBDA (OP) (* lmm " 7-Mar-85 16:48") (* ;; "UFN for the 2-arg floating cases") (\CALLER.ARGS ((X FLOATP) (Y FLOATP)) (SELECTQ OP (0 (* ; "UFADD") (\HAND.FLOATUNBOX (FPLUS X Y))) (1 (* ; "UFSUB") (\HAND.FLOATUNBOX (FDIFFERENCE X Y))) (2 (* ; "UFISUB") (\HAND.FLOATUNBOX (FDIFFERENCE Y X))) (3 (* ; "UFMULT") (\HAND.FLOATUNBOX (FTIMES X Y))) (4 (* ; "UFDIV") (\HAND.FLOATUNBOX (FQUOTIENT X Y))) (5 (* ; "UFGREAT") (FGREATERP X Y)) (6 (* ; "UFMAX") (\HAND.FLOATUNBOX (FMAX X Y))) (7 (* ; "UFMIN") (\HAND.FLOATUNBOX (FMIN X Y))) (8 (* ; "UFREM") (\HAND.FLOATUNBOX (FREMAINDER X Y))) (HELP "\UNBOXFLOAT2 called with illegal op " OP]) (\UNBOXFLOAT3 [LAMBDA (OP) (* jop%: "29-Aug-86 14:30") (if (EQ 0 OP) then [\CALLER.ARGS ((X FLOATP) COEFFICIENTS DEGREE) (* ; "Polynomial evaluation") (bind (RESULT _ (\GETBASEFLOATP COEFFICIENTS 0)) declare (TYPE FLOATP RESULT) for I from 2 to (LLSH DEGREE 1) by 2 do (SETQ RESULT (FPLUS (FTIMES RESULT X) (\GETBASEFLOATP COEFFICIENTS I))) finally (RETURN (\FLOATUNBOX RESULT] else (\CALLER.ARGS (MATRIX1 MATRIX2 RESULT) (SELECTQ OP (1 (* ; "3 x 3 matrix multiply") (\MATMULT333 MATRIX1 MATRIX2 RESULT)) (2 (* ; "4 x 4 matrix multiply") (\MATMULT444 MATRIX1 MATRIX2 RESULT)) (3 (* ; "(1,3) * (3,3) => (1,3)") (\MATMULT133 MATRIX1 MATRIX2 RESULT)) (4 (* ; "(3,3) * (3,1) => (3,1)") (\MATMULT331 MATRIX1 MATRIX2 RESULT)) (5 (* ; "(1,4) * (4,4) => (1,4)") (\MATMULT144 MATRIX1 MATRIX2 RESULT)) (6 (* ; "(4,4) * (4,1) => (4,1)") (\MATMULT441 MATRIX1 MATRIX2 RESULT)) (HELP "\UNBOXFLOAT3 called with illegal op " OP]) ) (DEFINEQ (\MATMULT133 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:20") (* ;;; "Multiply a 3 vector times a 3 by 3 array") (for K from 0 to 4 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from 0 to 4 by 2 as J from K by 6 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT))) CBASE]) (\MATMULT144 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:20") (* ;;; "Multiply a 4 vector times a 4 by 4 array") (for K from 0 to 6 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from 0 to 6 by 2 as J from K by 8 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT))) CBASE]) (\MATMULT331 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:20") (* ;;; "Multiply a 3 by 3 array by a 3 vector") (for K from 0 to 4 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from (ITIMES K 3) by 2 as J from 0 to 4 by 2 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT))) CBASE]) (\MATMULT333 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:31") (* ;;; "Multiply two 3 by 3 arrays") [bind (K _ 0) for ASTART from 0 to 12 by 6 do (for BSTART from 0 to 4 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from ASTART to (IPLUS ASTART 4) by 2 as J from BSTART by 6 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT)) (SETQ K (IPLUS K 2] CBASE]) (\MATMULT441 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:20") (* ;;; "Multiply a 4 by 4 array by a 4 vector") (for K from 0 to 6 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from (ITIMES K 4) by 2 as J from 0 to 6 by 2 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT))) CBASE]) (\MATMULT444 [LAMBDA (ABASE BBASE CBASE) (* jop%: "29-Aug-86 12:31") (* ;;; "Multiply two 4 by 4 arrays") [bind (K _ 0) for ASTART from 0 to 24 by 8 do (for BSTART from 0 to 6 by 2 do (bind (PRODUCT _ 0.0) declare (TYPE FLOATP PRODUCT) for I from ASTART to (IPLUS ASTART 6) by 2 as J from BSTART by 8 do [SETQ PRODUCT (FPLUS PRODUCT (FTIMES (\GETBASEFLOATP ABASE I) (\GETBASEFLOATP BBASE J] finally (\PUTBASEFLOATP CBASE K PRODUCT)) (SETQ K (IPLUS K 2] CBASE]) ) (* ; "unboxed arg handling") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (PUTPROPS \CALLER.ARGS MACRO [X (LET ((ARGS (CAR X)) (FORMS (CDR X))) `(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 `(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 `(\.GETBASE32 \STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT WORDSPERCELL] (COND [(LISTP X) `(SETQ ,(CAR X) (\FLOATBOX ,FORMS] (T `(SETQ ,X ,FORMS] (\MAKEFREEBLOCK NEXT (TIMES ,(LENGTH ARGS) WORDSPERCELL)) (replace (FX NEXTBLOCK) of AL with NEXT) (PROGN ,@FORMS]) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (FLOATP.TO.BCPL [LAMBDA (FLONUM) (* bvm%: "22-OCT-81 22:31") (* ;;; "Converts a floating point number in IEEE format to an integer in BCPL floating-point format") (OR (FLOATP FLONUM) (SETQ FLONUM (FLOAT FLONUM))) (PROG (RESULT FRAC (EXP (IPLUS (fetch EXPONENT of FLONUM) 2))) (COND ((FEQP FLONUM 0.0) (RETURN 0))) [COND ((IGREATERP EXP 255) (* ;  "Overflow, so just return BCPL infinity") (SETQ EXP 255) (SETQ FRAC 4194303)) (T (SETQ FRAC (LRSH (fetch LONGFRACTION of FLONUM) 1] (SETQ RESULT (create BCPLNUM BCPLEXPONENT _ EXP SIGNIFICANTBIT _ 1 BCPLHIFRACTION _ (LRSH FRAC 16) BCPLLOFRACTION _ (LOGAND FRAC MAX.SMALL.INTEGER))) (RETURN (COND ((EQ (fetch SIGNBIT of FLONUM) 1) (IMINUS RESULT)) (T RESULT]) (BCPL.TO.FLOATP [LAMBDA (BCPLNUM) (* bvm%: "22-OCT-81 22:34") (* ;;  "Converts BCPLNUM, an integer in BCPL floating-point format, to a FLOATP, which is IEEE standard") (PROG (SIGN EXP FRAC) (COND ((ILESSP BCPLNUM 0) (SETQ BCPLNUM (IMINUS BCPLNUM)) (* ;  "In a negative BCPL format, whole number is complemented") (SETQ SIGN 1)) ((IEQP BCPLNUM 0) (* ; "Canonical form for 0.0") (RETURN (FPLUS 0.0))) (T (SETQ SIGN 0))) (COND ((OR (SMALLP BCPLNUM) (NEQ (fetch SIGNIFICANTBIT of BCPLNUM) 1)) (ERROR "Not a valid BCPL flonum" BCPLNUM))) [COND ((ILESSP (SETQ EXP (IDIFFERENCE (fetch BCPLEXPONENT of BCPLNUM) 2)) 0) (* ;; "Underflow. IEEE exponent is off by 2 because the bias is one smaller in IEEE format and we shift the mantissa left one") (RETURN (FPLUS 0.0] (SETQ FRAC (LLSH (fetch RESTOFFRACTION of BCPLNUM) 1)) (RETURN (create FLOATP SIGNBIT _ SIGN EXPONENT _ EXP HIFRACTION _ (LRSH FRAC 16) LOFRACTION _ (LOGAND FRAC MAX.SMALL.INTEGER]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD BCPLNUM ((BCPLSIGNBIT BITS 1) (BCPLEXPONENT BITS 8) (* ; "exponent, biased by 128") (SIGNIFICANTBIT BITS 1) (* ;  "Always 1 in a bcpl num; binary point is to left") (RESTOFFRACTION BITS 22)) (BLOCKRECORD BCPLNUM ((NIL BITS 10) (BCPLHIFRACTION BITS 6) (BCPLLOFRACTION BITS 16))) (CREATE (CREATECELL \FIXP))) (RECORD EFPN (EXP HI LO)) ) ) (CL:DEFVAR INTPOWERS (LET ((AR (CL:MAKE-ARRAY 10))) (* ;; "(MAKE-ARRAY 10 INITIAL-CONTENTS (QUOTE (1 10 100 1000 10000 100000 1000000 10000000 100000000 1000000000)))") (* ;; "This HORRIBLE hack is here because not enough of MAKE-ARRAY is in the loadup to let the above form work right. (The ASETs are written open to avoid the gensyms produced by the stupid SETF expansion.) TBF by BOB BANE") (ASET 1 AR 0) (ASET 10 AR 1) (ASET 100 AR 2) (ASET 1000 AR 3) (ASET 10000 AR 4) (ASET 100000 AR 5) (ASET 1000000 AR 6) (ASET 10000000 AR 7) (ASET 100000000 AR 8) (ASET 1000000000 AR 9) AR)) (CL:DEFUN ENUM-STRING (OUTSTR MANTSTR INTEXP DECPLACES EXPWIDTH) (* ;; "Prints exponential notation observing rounding & exponent spacing") (CL:MACROLET [(STRPUT (C) `(CL:VECTOR-PUSH-EXTEND ,C OUTSTR] [LET ((DIGITS (CL:LENGTH MANTSTR)) (POINTPLACE 1) (INDEX -1) EXPOFFSET) (CL:SETF (CL:FILL-POINTER OUTSTR) 0) (IF DECPLACES THEN (SETQ POINTPLACE (- DIGITS DECPLACES))) (SETQ EXPOFFSET (- DIGITS POINTPLACE)) (* ;; "Print the mantissa") [IF (MINUSP POINTPLACE) (* ; ".0 before mantissa needed") THEN (STRPUT #\.) (CL:DOTIMES (I (- POINTPLACE)) (STRPUT #\0)) (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I))) ELSE (CL:DOTIMES (I POINTPLACE) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (STRPUT #\.) (CL:DOTIMES (I EXPOFFSET) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (IF DECPLACES THEN (CL:DOTIMES (I (- DECPLACES EXPOFFSET)) (STRPUT #\0)) ELSE (IF (EQ 0 EXPOFFSET) THEN (STRPUT #\0) (* ;  "Must print at least one decimal place in this case") ] (* ;; "mantissa done - now for the exponent") (CL:INCF INTEXP EXPOFFSET) (SETQ MANTSTR (WITH-RESOURCES (\NUMSTR \NUMSTR1) (\CONVERTNUMBER (ABS INTEXP) 10 T NIL \NUMSTR \NUMSTR1))) (SETQ DIGITS (CL:LENGTH MANTSTR)) (STRPUT #\E) (IF (MINUSP INTEXP) THEN (STRPUT #\-) ELSE (STRPUT #\+)) (IF EXPWIDTH THEN (CL:DOTIMES (I (- EXPWIDTH DIGITS 2)) (STRPUT #\0))) (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I)))] OUTSTR)) (CL:DEFUN FNUM-STRING (OUTSTR MANTSTR INTEXP DECPLACES) (* ;; "Prints floating decimal output observing # of places required") (CL:MACROLET [(STRPUT (C) `(CL:VECTOR-PUSH ,C OUTSTR] [LET* ((DIGITS (CL:LENGTH MANTSTR)) (POINTPLACE (+ DIGITS INTEXP)) (INDEX -1) PLACESOUT) (CL:SETF (CL:FILL-POINTER OUTSTR) 0) (COND ((NOT (CL:PLUSP POINTPLACE)) (STRPUT #\0) (STRPUT #\.) (CL:DOTIMES (I (- POINTPLACE)) (STRPUT #\0)) (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I))) (SETQ PLACESOUT (- DIGITS POINTPLACE))) ((MINUSP INTEXP) (CL:DOTIMES (I POINTPLACE) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (STRPUT #\.) (CL:DOTIMES (I (- INTEXP)) (STRPUT (CL:CHAR MANTSTR (CL:INCF INDEX)))) (SETQ PLACESOUT (- INTEXP))) (T (CL:DOTIMES (I DIGITS) (STRPUT (CL:CHAR MANTSTR I))) (CL:DOTIMES (I INTEXP) (STRPUT #\0)) (STRPUT #\.) (STRPUT #\0) (SETQ PLACESOUT 1))) (IF DECPLACES THEN (CL:DOTIMES (I (- DECPLACES PLACESOUT)) (STRPUT #\0))] OUTSTR)) (CL:DEFUN FLTSTR (F K) (* ;;; "Returns a string MANT and a fixp EXP such that F = MANT * 10 ** EXP, to K digits. Algorithm copped from %"An Implementation guide to a Proposed Standard for Floating-Point Arithmetic%" by J T Coonen (IEEE Computer Jan. 1980), and modified somewhat. The hack here when printing to unspecified precision is to always generate 7 digits, check to see if that's enough, and then clip trailing zeros from whatever results. This tends to produce more digits than necessary for denormalized numbers, but it makes everything else print a LOT faster.") [IF (= F 0.0) THEN (* ;; "Foo! You have to do it this way because the people who call FLTSTR assume they can smash whatever it returns... It would also be nice if it were documented somewhere that WITH-RESOURCES expands into a PROG1 and therefore can't return multiple-values...") (LET (outstring) (WITH-RESOURCES (\NUMSTR \NUMSTR1) (RPLCHARCODE \NUMSTR 1 (CHARCODE 0)) (SETQ outstring (SUBSTRING \NUMSTR 1 1 \NUMSTR1))) (CL:VALUES outstring 0)) ELSE (PROG (SIGNF FEXP FHI FLO TEXP THI TLO MANT EXP ROUNDINGBITS (LOCALK (CL:IF K (MIN 9 K) 7)) FLOG10 MANTSTRING) (DECLARE (CL:SPECIAL TEXP THI TLO)) (* ;  "used by extended floating multiplier and inttoext") (.FLOATUNBOX. F SIGNF FEXP FHI FLO) (* ;; "Re-normalize ") (if (EQ 0 FHI) then (SETQ FHI FLO) (SETQ FLO 0) (CL:DECF FEXP 16)) (while (EQ 0 (LOGAND FHI \SIGNBIT)) do (.LLSH1. FHI FLO) (CL:DECF FEXP)) (* ;; "find # of digits before decimal point by looking up base 10 log in extpowers") (SETQ FLOG10 (FLTINTLOG FEXP FHI FLO)) MOREDIGITS (SETQ EXP (- FLOG10 LOCALK)) AGAIN (TIMESPOW10 (- EXP) FEXP FHI FLO) (* ; "results in texp thi tlo") (SETQ MANT (EXTTOINT TEXP THI TLO)) (* ;; "Now compare the result to 10**k to check if the exp guess was a good one") (* ;; "This code is in the original algorithm, but I'm not sure it's needed here. What the heck, it's pretty fast...") (* ;; "(cond ((>= mant (cl:1+ (cl:aref intpowers localk))) (cl:incf exp) (go again)) ((eql mant (cl:aref intpowers localk)) (cl:incf exp) (setq mant (cl:aref intpowers (cl:1- localk)))) ((<= mant (cl:1- (cl:aref intpowers (cl:1- localk)))) (cl:decf exp) (go again)))") (* ;; "If K came in NIL, check to see if enough digits have been generated") [if (NOT K) then (INTTOEXT MANT) (* ; " values in texp thi tlo") (TIMESPOW10 EXP TEXP THI TLO) (while (NOT (> TEXP 0)) do (.LRSH1. THI TLO) (CL:INCF TEXP)) (SETQ ROUNDINGBITS (LOGAND TLO 255)) (SETQ TLO (LOGAND TLO 65280)) (* ;; "Round the 32-bit result to 24 bits to try and match F") (if [OR (IGREATERP ROUNDINGBITS 128) (AND (EQ ROUNDINGBITS 128) (NOT (EQ 0 (LOGAND TLO 256] then (if (EQ TLO 65280) then (SETQ TLO 0) (if (EQ THI MAX.SMALL.INTEGER) then (SETQ THI \SIGNBIT) (CL:INCF TEXP) else (CL:INCF THI)) else (CL:INCF TLO 256))) (if (OR (NOT (EQ FEXP TEXP)) (NOT (EQ FHI THI)) (NOT (EQ FLO TLO))) then (CL:INCF LOCALK) (if (< LOCALK 10) then (GO MOREDIGITS] (* ;; "Done! Convert integer mantissa to a string") (WITH-RESOURCES (\NUMSTR \NUMSTR1) (\CONVERTNUMBER MANT 10 T NIL \NUMSTR \NUMSTR1) (SETQ MANTSTRING \NUMSTR1)) (* ;; "If K came in NIL, clip trailing %"0%"s from mantissa string; if it came in bigger than 8, pad the string with 0s.") (if (NOT K) then (LET [(ENDPOINTER (CL:1- (NCHARS MANTSTRING] (while (EQ #\0 (CL:CHAR MANTSTRING ENDPOINTER)) do (GLC MANTSTRING) (CL:INCF EXP) (CL:DECF ENDPOINTER))) else (freplace (ARRAY-HEADER FILL-POINTER-P) of MANTSTRING with T) (freplace (ARRAY-HEADER TOTAL-SIZE) of MANTSTRING with 128) (* ; "So VECTOR-PUSH will work...") (while (IGREATERP K LOCALK) do (CL:VECTOR-PUSH #\0 MANTSTRING) (CL:DECF EXP) (CL:INCF LOCALK))) (RETURN (CL:VALUES MANTSTRING EXP]) (CL:DEFUN FLTINTLOG (FEXP FHI FLO) (DECLARE (GLOBALVARS EXTPOWERS)) [LET ((RESULT (if (NOT (> FEXP 0)) then (LET (TEXP THI TLO) (DECLARE (CL:SPECIAL TEXP THI TLO)) (TIMESPOW10 37 FEXP FHI FLO) (CL:SETQ FEXP TEXP FHI THI FLO TLO) -74) else -37))) (FOR I FROM 76 TO 0 BIND TABENTRY DO (SETQ TABENTRY (CL:AREF EXTPOWERS I)) (IF [OR (> FEXP (FETCH (EFPN EXP) OF TABENTRY)) (AND (EQ FEXP (FETCH (EFPN EXP) OF TABENTRY)) (OR (> FHI (FETCH (EFPN HI) OF TABENTRY)) (AND (EQ FHI (FETCH (EFPN HI) OF TABENTRY)) (>= FLO (FETCH (EFPN LO) OF TABENTRY] THEN (RETURN (IPLUS RESULT I]) (CL:DEFUN DIGITSBDP (F) (LET (SIGNF FEXP FHI FLO) (* ;;; "Returns the number of decimal places before the decimal point F has.") (.FLOATUNBOX. F SIGNF FEXP FHI FLO) (* ;; "Re-normalize ") (if (EQ 0 FHI) then (SETQ FHI FLO) (SETQ FLO 0) (CL:DECF FEXP 16)) (while (EQ 0 (LOGAND FHI \SIGNBIT)) do (.LLSH1. FHI FLO) (CL:DECF FEXP)) (FLTINTLOG FEXP FHI FLO))) (CL:DEFUN INTTOEXT (N) (* ;;; "Takes an integer N and returns a fixp exponent and a two-fixp mantissa (by setting non-locals (texp, thi, tlo)) . Ignores sign of N, range limitations of normal exponent (everything comes back %"normalized%").") (LET ((EXP (IPLUS \EXPONENT.BIAS 31)) HI LO) (if (EQ N 0) then (SETQ TEXP 0) (SETQ THI 0) (SETQ TLO 0) else (.UNBOX. N HI LO) [if (EQ 0 HI) then (SETQ HI LO) (SETQ LO 0) (SETQ EXP (IDIFFERENCE EXP 16)) (while (EQ 0 (LOGAND HI \SIGNBIT)) do (SETQ HI (LLSH1 HI 1)) (SETQ EXP (SUB1 EXP))) else (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO) (SETQ EXP (SUB1 EXP] (SETQ TEXP EXP) (SETQ THI HI) (SETQ TLO LO)))) (CL:DEFUN EXTTOINT (EXP HI LO) (* ;;; "Takes a fixp exponent and a two-fixp mantissa and returns an integer which is the properly rounded integer. Ignores sign and out-of-range numbers.") (SETQ EXP (IDIFFERENCE EXP \EXPONENT.BIAS)) [if (NOT (EQ EXP 31)) then (LET (ROUNDFLAG) [if (< EXP 15) then (SETQ LO HI) (SETQ HI 0) (CL:INCF EXP 16) (SETQ LO (LRSH LO (- 30 EXP))) else (while (NOT (EQ EXP 30)) do (.LRSH1. HI LO) (SETQ EXP (ADD1 EXP] (SETQ ROUNDFLAG (EQ 1 (LOGAND LO 1))) (.LRSH1. HI LO) (if ROUNDFLAG then (if (EQ LO 65535) then (SETQ LO 0) (CL:INCF HI) else (CL:INCF LO] (\MAKENUMBER HI LO)) (DEFMACRO SPLIT8 (IN HI LO) `(CL:SETQ ,HI (LRSH ,IN 8) ,LO (LLSH (LOGAND ,IN 255) 8))) (CL:DEFUN TIMESPOW10 (POWER EXP HI LO) (DECLARE (GLOBALVARS EXTPOWERS)) [LET (TABENTRY CURPOWER) (CL:SETQ TEXP EXP THI HI TLO LO) (WHILE (NOT (EQ 0 POWER)) DO [COND ((> POWER 38) (SETQ CURPOWER 76)) ((< POWER -38) (SETQ CURPOWER 0)) (T (SETQ CURPOWER (+ POWER 38] (SETQ TABENTRY (CL:AREF EXTPOWERS (IABS CURPOWER))) (* ;;  "Results of this land in texp thi tlo (bound above, somewhere...)") (\EXTFTIMES EXP HI LO (fetch (EFPN EXP) TABENTRY) (fetch (EFPN HI) TABENTRY) (fetch (EFPN LO) TABENTRY)) (SETQ EXP TEXP) (SETQ HI THI) (SETQ LO TLO) (CL:DECF POWER (- CURPOWER 38]) (CL:DEFUN \EXTFTIMES (EXPX HX LX EXPY HY LY) (PROG ((SIGNX 0) (SIGNY 0) (HHZ 0) (HZ 0) (LZ 0) CARRY LOW8BITS FOO FOOHI FOOLO) (if (AND (EQ 0 EXPX) (EQ 0 HX) (EQ 0 LX)) then (GO DONE)) (if (AND (EQ 0 EXPY) (EQ 0 HY) (EQ 0 LY)) then (GO DONE)) (COND) (* ;;; "Multiplying two 32-bit operands to get a 32-bit rounded product. Doing the multiplication 8 bits at a time and maintaining a 40-bit or so sum in (HHZ HZ LZ) that holds the lower order products as we go.") (COND ((OR (EQ 0 HY) (EQ 0 LY)) (* ;  "swap operands to make life easier") (swap HX HY) (swap LX LY))) (CL:DOTIMES (I 4) (SETQ LOW8BITS (LOGAND LX 255)) (* ;; "Skip it if 8 bits are 0") (if (NOT (EQ 0 LOW8BITS)) then (SETQ FOO (ITIMES LOW8BITS (LOGAND LY 255))) (SETQ CARRY (.ADDSMALL2. LZ FOO)) (SETQ FOO (ITIMES LOW8BITS (LOGAND HY 255))) (SETQ CARRY (.ADDSMALL3. HZ FOO CARRY)) (SETQ HHZ (IPLUS HHZ CARRY)) (SETQ FOO (ITIMES LOW8BITS (LRSH LY 8))) (SPLIT8 FOO FOOHI FOOLO) (SETQ CARRY (.ADDSMALL2. LZ FOOLO)) (SETQ FOOHI (IPLUS FOOHI CARRY)) (SETQ CARRY (.ADDSMALL2. HZ FOOHI)) (SETQ FOO (ITIMES LOW8BITS (LRSH HY 8))) (SPLIT8 FOO FOOHI FOOLO) (SETQ CARRY (IPLUS CARRY (.ADDSMALL2. HZ FOOLO))) (SETQ HHZ (IPLUS HHZ FOOHI CARRY))) (.LRSH8. HX LX) (* ; "Shift over 8 bits") (* ;; "Don't shift sum the last time") (if (NOT (EQ I 3)) then (.LRSH8. HZ LZ) (SETQ HZ (LOGOR HZ (LLSH HHZ 8))) (SETQ HHZ (LRSH HHZ 8)))) (* ;; "OK, shift (HHZ HZ LZ) over 8 so \EXTNORMALIZE can understand them") (.LLSH8. HHZ HZ) (SETQ HZ (LOGOR HZ (LRSH LZ 8))) (SETQ LZ (LLSH (LOGAND LZ 255) 8)) (* ;; "We now have a 40-bit result in HHZ,HZ,LZ. \EXTNORMALIZE can handle it from here. Note that the exponent we give is bumped by 1, because the 'binary point' , which was between the first and second bits, was moved one to the right by multiplying") DONE (RETURN (\EXTNORMALIZE (IPLUS EXPX EXPY (IDIFFERENCE 1 \EXPONENT.BIAS)) HHZ HZ LZ)))) (CL:DEFUN \EXTFQUOTIENT (EXPX HX LX EXPY HY LY) (PROG ((SIGNX 0) (SIGNY 0) BORROW (HZ 0) (LZ 0)) (if (AND (EQ EXPX 0) (EQ HX 0) (EQ LX 0)) then (GO DONE)) (if (AND (EQ EXPY 0) (EQ HY 0) (EQ LY 0)) then (GO DIVZERO)) (COND ((EQ EXPX \MAX.EXPONENT) (* ; "X is infinity, result is too.") (RETURN (CL:VALUES \MAX.EXPONENT 65535 65535))) ((EQ EXPY \MAX.EXPONENT) (* ; "Y = infinity, result is zero") (GO DONE))) (* ;;; "Divide X -- double length, implicitly extended with zeros -- by Y. At each step, Y is subtracted from X if possible, putting a one bit in the quotient, and then X and the quotient are shifted left. Result is a 32-bit quotient.") (.LRSH1. HX LX) (.LRSH1. HY LY) (* ;  "shift these right one so that we never have to worry about carrying out of the high bit") (FRPTQ 31 (PROGN (.LLSH1. HZ LZ) (* ;  "shift quotient left one as we accumulate it") (COND ((OR (AND (EQ HX HY) (IGEQ LX LY)) (IGREATERP HX HY)) (* ; "X GE Y, so subtract Y") (SETQ HX (IDIFFERENCE (IDIFFERENCE HX HY) (.SUBSMALL. LX LY))) (SETQ LZ (ADD1 LZ)) (* ;  "note that this never overflows, because of the left shift we did above") )) (* ;; "now shift dividend left one. After the subtraction the high-order bit must be off, so this works okay") (.LLSH1. HX LX))) (.LLSH1. HZ LZ) (* ;  "left shift result 1 to compensate for the earlier right shifts") [COND ((OR (NEQ HX 0) (NEQ LX 0)) (* ; "set sticky bit") (SETQ LZ (LOGOR LZ 1] DONE (RETURN (\EXTNORMALIZE (IPLUS (IDIFFERENCE EXPX EXPY) \EXPONENT.BIAS) HZ LZ)) DIVZERO (SETQ TEXP \MAX.EXPONENT) (SETQ THI 65535) (SETQ TLO 65535))) (CL:DEFUN \EXTNORMALIZE (EXP HI LO &OPTIONAL (ROUNDINGBITS 0)) (* ;; "Takes four fixps, one exponent and three mantissa, and returns a normalized, rounded exponent and two fixp mantissa. Does nothing about exponent range or %"denormalization%"; just shifts mantissa, bumps exponent, and rounds") (PROG NIL (COND ((AND (EQ 0 HI) (EQ 0 LO)) (SETQ EXP 0) (GO DONE))) [COND ((EQ 0 HI) (SETQ HI LO) (SETQ LO ROUNDINGBITS) (SETQ ROUNDINGBITS 0) (SETQ EXP (IDIFFERENCE EXP 16] (while (EQ 0 (LOGAND HI \SIGNBIT)) do (.LLSH1. HI LO) (if (NOT (EQ 0 (LOGAND ROUNDINGBITS \SIGNBIT))) then (SETQ LO (ADD1 LO))) (SETQ ROUNDINGBITS (LLSH ROUNDINGBITS 1)) (SETQ EXP (SUB1 EXP))) (* ; "round result.") [COND ([OR (IGREATERP ROUNDINGBITS \SIGNBIT) (AND (EQ ROUNDINGBITS \SIGNBIT) (NOT (EQ 0 (LOGAND LO 1] (* ;; "round up if the left over fraction was greater than 1/2; if it was equal to a half, round to the even result") (COND [(EQ LO MAX.SMALL.INTEGER) (* ; "can't add 1 directly") (SETQ LO 0) (COND ((EQ HI MAX.SMALL.INTEGER) (SETQ HI \SIGNBIT) (add EXP 1] (T (SETQ LO (ADD1 LO] DONE (* ;; "Stuff results in texp thi tlo (bound somewhere above... hopefully...)") (SETQ TEXP EXP) (SETQ THI HI) (SETQ TLO LO))) (CL:DEFUN \CONVERT.FLOATING.NUMBER (F OUTSTR OUTSTRPTR FORMAT) (DECLARE (GLOBALVARS \FLOATFORMAT)) [WITH-RESOURCE (\CFNSTRING) (CL:MACROLET [(STRPUT (C) `(CL:SETF (CL:CHAR OUTSTR (CL:INCF OSINDEX)) ,C] (OR FORMAT (SETQ FORMAT \FLOATFORMAT)) (IF (NOT (CL:CONSP FORMAT)) THEN (SETQ FORMAT NIL)) (LET ((OSINDEX -1) [MINUSFLAG (AND (MINUSP F) (SETQ F (- F] (PADSIZE 0) (PADCHAR #\Space) NUMSTR INTEXP NSWIDTH) [DESTRUCTURING-BIND (WIDTH DECPART EXPPART PAD0 ROUND) (CDR FORMAT) (* ;; "Clip WIDTH to maximum size of buffer strings (128)") (AND WIDTH (IGREATERP WIDTH 128) (SETQ WIDTH 128)) (COND ((NULL EXPPART) (SETQ EXPPART 0))) (COND (PAD0 (SETQ PADCHAR #\0))) (IF [OR (NOT (EQ EXPPART 0)) (AND (NOT (ZEROP F)) (OR (< F 0.001) (>= F 1.0E+7] THEN (* ;; "Exponential required - too big/small or explicitly requested") (IF (AND (NOT ROUND) DECPART) THEN (SETQ ROUND (CL:1+ DECPART))) (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (IF (AND ROUND (NOT DECPART) (* ;  "we might be able to remove some trailing zeros here") (NOT (ZEROP F))) THEN (FOR STREND FROM (CL:1- (CL:LENGTH NUMSTR)) TO 0 BY -1 WHILE (EQ #\0 (CL:CHAR NUMSTR STREND)) DO (GLC NUMSTR) (CL:INCF INTEXP))) (SETQ NUMSTR (ENUM-STRING \CFNSTRING NUMSTR INTEXP DECPART EXPPART)) ELSE (* ;; "Floating decimal printing") [IF (AND (NOT ROUND) DECPART) (* ;;  "Foo! Must compute round from decpart to round to a specific decimal place") THEN (SETQ ROUND (IF (ZEROP F) THEN 1 ELSE (MAX 0 (MIN 9 (+ (CL:TRUNCATE (CL:1+ (CL:LOG F 10))) DECPART] (CL:MULTIPLE-VALUE-SETQ (NUMSTR INTEXP) (FLTSTR F ROUND)) (IF (AND ROUND (NOT DECPART) (* ;  "we might be able to remove some trailing zeros here") (NOT (ZEROP F))) THEN (FOR STREND FROM (CL:1- (CL:LENGTH NUMSTR)) TO 0 BY -1 WHILE (EQ #\0 (CL:CHAR NUMSTR STREND)) DO (GLC NUMSTR) (CL:INCF INTEXP))) (SETQ NUMSTR (FNUM-STRING \CFNSTRING NUMSTR INTEXP DECPART))) (SETQ NSWIDTH (CL:LENGTH \CFNSTRING)) (* ; "Handle padding") [IF (AND WIDTH (> WIDTH NSWIDTH)) THEN (SETQ PADSIZE (- WIDTH NSWIDTH (CL:IF MINUSFLAG 1 0)] (AND PAD0 MINUSFLAG (STRPUT #\-)) (* ; "Minus sign before 0 pad") (CL:DOTIMES (I PADSIZE) (STRPUT PADCHAR)) (AND (NOT PAD0) MINUSFLAG (STRPUT #\-)) (* ; "But after blank pad") (CL:DOTIMES (I NSWIDTH) (STRPUT (CL:CHAR \CFNSTRING I)))] (SUBSTRING OUTSTR 1 (CL:1+ OSINDEX) OUTSTRPTR]) (CL:DEFUN \FLOATINGSCALE (INTMANT INTEXP &OPTIONAL BOX) (* ;;; "Takes an integer mantissa and integer exponent and returns a floating-point number F such that F = intmant * 10**intexp. Smashes it into box if one is supplied") (LET (TEXP THI TLO (SIGN 0)) (DECLARE (CL:SPECIAL TEXP THI TLO)) (IF (MINUSP INTMANT) THEN (SETQ INTMANT (- INTMANT)) (SETQ SIGN 1)) (INTTOEXT INTMANT) (* ; "leaves result in texp thi tlo") (TIMESPOW10 INTEXP TEXP THI TLO) (* ; "ditto") (\MAKEFLOAT SIGN TEXP THI TLO T BOX))) (DEFINEQ (\INIT.POWERS.OF.TEN [LAMBDA NIL (* ; "Edited 14-Jan-87 11:21 by jrb:") (* ;; "Initialize array \POWERS.OF.TEN to values 10^-29 thru 10^+29. I suppose I could have the array cover the entire range of floats, but the range is asymmetric and the numbers start losing significance at the ends, so it's not really worth it. Also initialize the array of 32-bit mantissa powers of 10 used by \convert.floating.number and friends.") (SETQ \POWERS.OF.TEN (ARRAY 59 'POINTER)) (SETQ EXTPOWERS (CL:MAKE-ARRAY 77)) (SETA \POWERS.OF.TEN 30 1.0) (CL:SETF (CL:AREF EXTPOWERS 38) (CREATE EFPN EXP _ \EXPONENT.BIAS HI _ 32768 LO _ 0)) (for I from 1 to 29 bind (POWTEN _ 1.0) do (SETA \POWERS.OF.TEN (IPLUS I 30) (SETQ POWTEN (FTIMES POWTEN 10.0))) (SETA \POWERS.OF.TEN (IDIFFERENCE 30 I) (FQUOTIENT 1.0 POWTEN))) [LET (ENOW EEXP EHI ELO TEXP THI TLO) (DECLARE (CL:SPECIAL TEXP THI TLO)) (* ;; "First generate the powers of ten exactly representable in 32 bits") (for I from 1 to 9 bind (POW10 _ 1) do (INTTOEXT (SETQ POW10 (CL:* POW10 10))) (* ; "Results in texp thi tlo") (CL:SETF (CL:AREF EXTPOWERS (+ 38 I)) (CREATE EFPN EXP _ TEXP HI _ THI LO _ TLO))) (SETQ ENOW (CL:AREF EXTPOWERS (+ 38 9))) (SETQ EEXP (FETCH (EFPN EXP) ENOW)) (SETQ EHI (FETCH (EFPN HI) ENOW)) (SETQ ELO (FETCH (EFPN LO) ENOW)) (for I from 1 to 4 do (TIMESPOW10 I EEXP EHI ELO) (* ; "this does out to 10^13") (CL:SETF (CL:AREF EXTPOWERS (+ I 9 38)) (CREATE EFPN EXP _ TEXP HI _ THI LO _ TLO))) (* ;; "Then use them to generate the others") (SETQ ENOW (CL:AREF EXTPOWERS (+ 38 13))) (SETQ EEXP (FETCH (EFPN EXP) ENOW)) (SETQ EHI (FETCH (EFPN HI) ENOW)) (SETQ ELO (FETCH (EFPN LO) ENOW)) (for I from 1 to 13 do (TIMESPOW10 I EEXP EHI ELO) (* ; "this does out to 10^26") (CL:SETF (CL:AREF EXTPOWERS (+ I 13 38)) (CREATE EFPN EXP _ TEXP HI _ THI LO _ TLO))) (SETQ ENOW (CL:AREF EXTPOWERS (+ 38 26))) (SETQ EEXP (FETCH (EFPN EXP) ENOW)) (SETQ EHI (FETCH (EFPN HI) ENOW)) (SETQ ELO (FETCH (EFPN LO) ENOW)) (for I from 1 to 12 do (TIMESPOW10 I EEXP EHI ELO) (* ; "this does out to 10^38") (CL:SETF (CL:AREF EXTPOWERS (+ I 26 38)) (CREATE EFPN EXP _ TEXP HI _ THI LO _ TLO))) (* ;; "Finally generate all the inverses: 10^-1 - 10^-38") (for I from 1 to 38 do (SETQ ENOW (CL:AREF EXTPOWERS (+ I 38))) (\EXTFQUOTIENT \EXPONENT.BIAS 32768 0 (FETCH (EFPN EXP) ENOW) (FETCH (EFPN HI) ENOW) (FETCH (EFPN LO) ENOW)) (CL:SETF (CL:AREF EXTPOWERS (- 38 I)) (CREATE EFPN EXP _ TEXP HI _ THI LO _ TLO] \POWERS.OF.TEN]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\CFNSTRING 'RESOURCES '(NEW (CL:MAKE-ARRAY 128 :ELEMENT-TYPE 'CL:STRING-CHAR :FILL-POINTER 0 :ADJUSTABLE T] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \POWERS.OF.TEN) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \POWER.OF.TEN MACRO ((N) (ELT \POWERS.OF.TEN (IPLUS N 30)))) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (/SETTOPVAL '\\CFNSTRING.GLOBALRESOURCE NIL) (\INIT.POWERS.OF.TEN) ) (PUTPROPS \UNBOXFLOAT1 ARGNAMES (X OP)) (PUTPROPS \UNBOXFLOAT2 ARGNAMES (X Y OP)) (PUTPROPS \UNBOXFLOAT3 ARGNAMES (X Y Z OP)) (PUTPROPS LLFLOAT FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FPLUS FTIMES) ) (PUTPROPS LLFLOAT COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4985 5534 (\PUTBASEFLOATP 4995 . 5304) (\GETBASEFLOATP 5306 . 5532)) (6219 8066 (FTIMES 6229 . 6826) (FPLUS 6828 . 7277) (FQUOTIENT 7279 . 7424) (FDIFFERENCE 7426 . 7575) (FGREATERP 7577 . 7886) (FABS 7888 . 8064)) (8088 11604 (\SLOWFDIFFERENCE 8098 . 8271) (\SLOWFPLUS2 8273 . 8520) ( \SLOWFTIMES2 8522 . 8683) (\SLOWFQUOTIENT 8685 . 8923) (\SLOWFGREATERP 8925 . 11602)) (11749 35597 ( \FZEROP 11759 . 12046) (FEQP 12048 . 13328) (\FLOAT 13330 . 15085) (\FIXP.FROM.FLOATP 15087 . 16585) ( FIXR 16587 . 20166) (\BOXFPLUSDIF 20168 . 23260) (\BOXFQUOTIENT 23262 . 26051) (\BOXFTIMES2 26053 . 29640) (\INFINITY 29642 . 30391) (\MAKEFLOAT 30393 . 34965) (MAKEFLOATNUMBER 34967 . 35350) (PutFloat 35352 . 35595)) (35850 37443 (SQRT 35860 . 37441)) (50585 55286 (\UNBOXFLOAT1 50595 . 51843) ( \UNBOXFLOAT2 51845 . 53368) (\UNBOXFLOAT3 53370 . 55284)) (55287 59377 (\MATMULT133 55297 . 55916) ( \MATMULT144 55918 . 56537) (\MATMULT331 56539 . 57176) (\MATMULT333 57178 . 57956) (\MATMULT441 57958 . 58595) (\MATMULT444 58597 . 59375)) (61510 64443 (FLOATP.TO.BCPL 61520 . 62830) (BCPL.TO.FLOATP 62832 . 64441)) (93979 98377 (\INIT.POWERS.OF.TEN 93989 . 98375))))) STOP \ No newline at end of file diff --git a/sources/LLGC b/sources/LLGC new file mode 100644 index 00000000..ddea752c --- /dev/null +++ b/sources/LLGC @@ -0,0 +1,296 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "19-Oct-94 12:30:11" {DSK}sources>LLGC.;3 46967 + + changes to%: (VARS LLGCCOMS) + + previous date%: " 9-Feb-93 14:29:47" {DSK}sources>LLGC.;1) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1992, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLGCCOMS) + +(RPAQQ LLGCCOMS ((PROPS (LLGC FILETYPE)) (COMS (* ; "Reference counting") (FNS \HTFIND \GC.HANDLEOVERFLOW \GCMAPTABLE)) (COMS (* ; "Overflowed reference counts") (FNS \GC.ENTER.BIGREFCNT \GC.MODIFY.BIGREFCNT \GC.LOOKUP.BIGREFCNT \GC.BIGREFCNT.MISSING) (GLOBALVARS \HTBIGCOUNT)) (COMS (* ; "GC") (FNS \GCMAPSCAN \GCMAPUNSCAN \GCRECLAIMCELL \FREELISTCELL \GCSCAN1 \GCSCAN2 \REFCNT \EQREFCNT1 \SET.FINALIZATION.FUNCTION)) (COMS (* ; "User entries") (FNS RECLAIM \DORECLAIM \MAIKO.DORECLAIM RECLAIMMIN GCMESS GCGAG GCTRP) (ADDVARS (\MAIKO.MOVDS (\MAIKO.DORECLAIM \DORECLAIM)))) (COMS (* ; "Turning off GC") (FNS DISABLEGC \DISABLEGC1 \MAIKO.DISABLEGC \DOGCDISABLEDINTERRUPT) (ADDVARS (\MAIKO.MOVDS (\MAIKO.DISABLEGC \DISABLEGC1))) (INITVARS (\GCDISABLED)) (GLOBALVARS \GCDISABLED)) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS ADDREF \ADDREF DELETEREF \DELREF SCANREF \STKREF UNSCANREF CREATEREF \CREATEREF .INCREMENT.ALLOCATION.COUNT. .CHECK.ALLOCATION.COUNT. \GCDISABLED) (RECORDS HTOVERFLOW GC HTCOLL)) (RECORDS GCOVFL MDSTYPEWORD GCPTR) (* ;; "WORDSPERGCENTRY should be 1 for non-BIGVM sysouts. Affects offsets into HTMAIN and HTCOLL.") (CONSTANTS \HTBIGENTRYSIZE (\HT2CNT (IPLUS \HT1CNT \HT1CNT)) (\HTCNTSHIFT 10) (\HTNOSTKBIT (LOGXOR 65535 \HTSTKBIT)) (\HTSTK1 (LOGOR \HTSTKBIT \HT1CNT)) (\HTSTKCNT (LOGOR \HTCNTMASK \HTSTKBIT)) \HTHIMASK (\MAXHTCNT 32767) (WORDSPERGCENTRY 2)) (CONSTANTS \HTCOLLTHRESHOLD \HTCOLLMAX) (MACROS .GETLINK. .DELLINK. .FREELINK. .MODENTRY. .NEWENTRY. .GCRECLAIMLP.) (GLOBALVARS \RECLAIMMIN \RECLAIM.COUNTDOWN \GCTIME1 \GCTIME2 \FINALIZATION.FUNCTIONS) (CONSTANTS \ADDREFCASE \DELREFCASE \SCANREFCASE \UNSCANREFCASE)) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (\RECLAIMMIN 3000) (\RECLAIM.COUNTDOWN 3000) (GCMESS T) (\GCTIME1 (CREATECELL \FIXP)) (\GCTIME2 (CREATECELL \FIXP)))) (FNS \GCERROR) (COMS (* ; "for MAKEINIT") (FNS INITGC) (DECLARE%: DONTCOPY (ADDVARS (MKI.SUBFNS (ADDREF . PROGN) (\ADDREF . PROGN) (\DELREF . PROGN) (CREATEREF . PROGN) (\CREATEREF . PROGN) (DELETEREF . PROGN) (.INCREMENT.ALLOCATION.COUNT. . PROGN) (.CHECK.ALLOCATION.COUNT. . PROGN))) (ADDVARS (INEWCOMS (FNS INITGC))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS INITGC)))) (LOCALVARS . T)) +) + +(PUTPROPS LLGC FILETYPE :BCOMPL) + + + +(* ; "Reference counting") + +(DEFINEQ + +(\HTFIND [LAMBDA (PTR CASE) (* ; "Edited 1-Feb-87 15:05 by jop") (* ;; "Modify reference count of the constants ptr according to case --- Returns PTR if result is 0 ref cnt, NIL otherwise --- CASE is one of (\ADDREFCASE \DELREFCASE \SCANREFCASE \UNSCANREFCASE)") (PROG ((PROBE PTR) ENTRY LINK PREV) (CHECK (NOT \INTERRUPTABLE)) [COND ((fetch (MDSTYPEWORD NOREFCNT) of (\ADDBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of PTR) 1))) (* ;  "PTR not to be ref counted. Also true when GC disabled") (RETURN)) (\GCDISABLED (* ; "Shouldn't happen") (RETURN (NILL] (CHECK (EVENP (\LOLOC PTR))) (SETQ ENTRY (\ADDBASE \HTMAIN (LRSH (\LOLOC PROBE) 1))) [COND ((fetch (GC EMPTY) of ENTRY) (* ; "create new entry") (RETURN (.NEWENTRY. ENTRY PTR CASE] (COND ((fetch (GC LINKP) of ENTRY) (* ; "chase down the link") (GO FINDLINK))) [COND ((EQ (\HILOC PTR) (fetch (GC HIBITS) of ENTRY)) (* ; "matches pointer in main table") (RETURN (COND ((.MODENTRY. ENTRY CASE PTR) (replace (GC EMPTY) of ENTRY with T) NIL) ((EQ (fetch (GC STKCNT) of ENTRY) 0) PTR) (T NIL] (* ;;; "new collision") NEWCOLLISION (.GETLINK. LINK) (.GETLINK. PREV) (replace (GC NXTPTR) of PREV with (\LOLOC LINK)) (replace (GC CONTENTS) of PREV with (fetch (GC CONTENTS) of ENTRY)) (CHECK (EVENP (\LOLOC PREV))) (replace (GC LINKPTR) of ENTRY with (\LOLOC PREV)) (replace (GC NXTPTR) of LINK with 0) (replace (GC EMPTY) of LINK with T) (RETURN (.NEWENTRY. LINK PTR CASE)) FINDLINK (SETQ LINK (\ADDBASE \HTCOLL (fetch (GC LINKPTR) of ENTRY))) LINKLOOP (CHECK (SELECTC (fetch (GC HIBITS) of LINK) ((LIST \SmallPosHi \SmallNegHi \AtomHI) NIL) T)) [COND ((EQ (fetch (GC HIBITS) of LINK) (\HILOC PTR)) (* ; "found the link entry") (RETURN (COND ((.MODENTRY. LINK CASE PTR) (* ;  "reference count went to 1, delete list entry") (.DELLINK. LINK PREV ENTRY) NIL) ((EQ 0 (fetch (GC STKCNT) of LINK)) PTR) (T NIL] (SETQ PREV LINK) (COND ((NEQ (SETQ LINK (fetch (GC NXTPTR) of LINK)) 0) (SETQ LINK (\ADDBASE \HTCOLL LINK)) (GO LINKLOOP))) (* ;;; "Didn't find an entry on this chain") (.GETLINK. LINK) (replace (GC NXTPTR) of LINK with 0) (CHECK PREV) (replace (GC NXTPTR) of PREV with (\LOLOC LINK)) (RETURN (.NEWENTRY. LINK PTR CASE]) + +(\GC.HANDLEOVERFLOW [LAMBDA (ARG) (* ; "Edited 2-Feb-87 10:30 by jop") (* ;; "called as PUNT after microcode has put some things in the overflow table") (UNINTERRUPTABLY [PROG ((CELL \HTOVERFLOW) PTR) LP (COND ((SETQ PTR (fetch (HTOVERFLOW PTR) of CELL)) (\HTFIND PTR (fetch (HTOVERFLOW CASE) of CELL)) (replace (HTOVERFLOW CLEAR) of CELL with T) (SETQ CELL (\ADDBASE CELL WORDSPERCELL)) (GO LP))) (PROGN (SETQ PTR (\GETDTD \LISTP)) (COND ((IGREATERP (SETQ CELL (fetch DTDCNT0 of PTR)) 1024) (.INCREMENT.ALLOCATION.COUNT. CELL) (.BOXIPLUS. (fetch DTDCNTLOC of PTR) (fetch DTDCNT0 of PTR)) (replace DTDCNT0 of PTR with 0] ARG)]) + +(\GCMAPTABLE [LAMBDA (ARG) (* ; "Edited 2-Feb-87 10:31 by jop") (DECLARE (GLOBALVARS \MaxTypeNumber)) (* ;; "Called as a punt after microcode has done a CREATECELL and the count got big enough. Used to also be called when free list got empty.") (UNINTERRUPTABLY (* ;  "CREATECELL can also punt ref count ops, so have to handle them first.") [PROG ((CELL \HTOVERFLOW) PTR) LP (COND ((SETQ PTR (fetch (HTOVERFLOW PTR) of CELL)) (\HTFIND PTR (fetch (HTOVERFLOW CASE) of CELL)) (replace (HTOVERFLOW CLEAR) of CELL with T) (SETQ CELL (\ADDBASE CELL WORDSPERCELL)) (GO LP] [COND (NIL (LET* ((DTD (\GETDTD (NTYPX ARG))) (N (fetch DTDCNT0 of DTD))) (.BOXIPLUS. (fetch DTDCNTLOC of DTD) N) (replace DTDCNT0 of DTD with 0) (.INCREMENT.ALLOCATION.COUNT. N))) (T (* ;; "Generally we know that ARG's type caused the punt. At present we clean up EVERY counter so that the cumulative effect of all the different types of CREATECELL contribute to deciding whether to gc. Not sure this is entirely necessary, and it gets slower as more datatypes get allocated. Fortunately, \GCMAPTABLE is only called when the count gets big, so is infrequent.") (bind DTD N for I from 1 to \MaxTypeNumber when (NEQ [SETQ N (fetch DTDCNT0 of (SETQ DTD (\GETDTD I] 0) do (.BOXIPLUS. (fetch DTDCNTLOC of DTD) N) (replace DTDCNT0 of DTD with 0) (.INCREMENT.ALLOCATION.COUNT. N] ARG)]) +) + + + +(* ; "Overflowed reference counts") + +(DEFINEQ + +(\GC.ENTER.BIGREFCNT [LAMBDA (PTR ENTRY) (* ; "Edited 2-Feb-87 10:30 by jop") (* ;; "Called when the ref cnt of PTR is incremented to \MAXHTCNT. PTR is inserted in a simple table pointed to by \HTBIGCOUNT until its ref cnt comes back down") (PROG ((OVENTRY \HTBIGCOUNT) TMP) [COND ((ODDP (\LOLOC PTR)) (* ;  "This should be an error, but accomodate it for now") (SETQ PTR (\ADDBASE PTR -1] LP [SELECTQ (SETQ TMP (fetch OVFLPTR of OVENTRY)) (T (* ; "Deleted entry; reuse it")) (NIL (* ;  "End of table; add new entry at end") [COND ((EVENP (\LOLOC (\ADDBASE OVENTRY \HTBIGENTRYSIZE)) WORDSPERPAGE) (* ; "Need to allocate another page") (\NEWPAGE (\ADDBASE OVENTRY \HTBIGENTRYSIZE]) (COND ((EQ TMP PTR) (\MP.ERROR \MP.BIGREFCNTALREADYPRESENT "PTR already in overflow table" PTR ENTRY) (add (fetch OVFLCNTHI of OVENTRY) 1) (* ; "Assure it lives forever") (RETURN)) (T (SETQ OVENTRY (\ADDBASE OVENTRY \HTBIGENTRYSIZE)) (GO LP] (replace OVFLCNTLO of OVENTRY with \MAXHTCNT) (replace OVFLCNTHI of OVENTRY with 0) (replace OVFLPTR of OVENTRY with PTR) (replace (GC CNT) of ENTRY with \MAXHTCNT]) + +(\GC.MODIFY.BIGREFCNT [LAMBDA (ENTRY CASE PTR) (* ; "Edited 1-Feb-87 15:00 by jop") (* ;; "Called from .MODENTRY. to do one of the 4 reference counting cases on PTR. ENTRY is the gc table entry whose CNT field is \MAXHTCNT") (PROG ((OVENTRY \HTBIGCOUNT) TMP CNT) [COND ((ODDP (\LOLOC PTR)) (* ;  "This should be an error, but accomodate it for now") (SETQ PTR (\ADDBASE PTR -1] LP (COND ((NEQ (SETQ TMP (fetch OVFLPTR of OVENTRY)) PTR) (COND ((NULL TMP) (\GC.BIGREFCNT.MISSING PTR ENTRY) (RETURN))) (SETQ OVENTRY (\ADDBASE OVENTRY \HTBIGENTRYSIZE)) (GO LP))) (SELECTC CASE (\ADDREFCASE (replace OVFLCNTLO of OVENTRY with (COND ((ILESSP (SETQ TMP (fetch OVFLCNTLO of OVENTRY)) MAX.SMALLP) (ADD1 TMP)) (T (add (fetch OVFLCNTHI of OVENTRY) 1) 0)))) (\DELREFCASE (replace OVFLCNTLO of OVENTRY with (COND ((IGEQ (SETQ TMP (SUB1 (fetch OVFLCNTLO of OVENTRY))) \MAXHTCNT) TMP) ((EQ 0 (fetch OVFLCNTHI of OVENTRY)) (* ;  "Ref cnt has fallen below max, bring it out") (replace (GC CNT) of ENTRY with TMP) (replace OVFLPTR of OVENTRY with T) (* ; "mark deleted") TMP) ((ILESSP TMP 0) (add (fetch OVFLCNTHI of OVENTRY) -1) MAX.SMALLP) (T TMP)))) (\SCANREFCASE (replace (GC STKBIT) of ENTRY with T)) (\UNSCANREFCASE (replace (GC STKBIT) of ENTRY with NIL)) NIL) (* ;  "Value is NIL to tell .MODENTRY. that cnt ~= 1") (RETURN NIL]) + +(\GC.LOOKUP.BIGREFCNT [LAMBDA (PTR ENTRY) (* ; "Edited 2-Feb-87 10:31 by jop") (* ;; "Returns ref cnt of PTR from the big table. ENTRY is the main or collision hashtable entry, but is used only for informational purposes to RAID") (PROG ((OVENTRY \HTBIGCOUNT) TMP) [COND ((ODDP (\LOLOC PTR)) (* ;  "This should be an error, but accomodate it for now") (SETQ PTR (\ADDBASE PTR -1] LP (COND ((NEQ PTR (SETQ TMP (fetch OVFLPTR of OVENTRY))) (COND ((NULL TMP) (\GC.BIGREFCNT.MISSING PTR ENTRY) (RETURN \MAXHTCNT))) (SETQ OVENTRY (\ADDBASE OVENTRY \HTBIGENTRYSIZE)) (GO LP))) (RETURN (\MAKENUMBER (fetch OVFLCNTHI of OVENTRY) (fetch OVFLCNTLO of OVENTRY]) + +(\GC.BIGREFCNT.MISSING [LAMBDA (PTR ENTRY) (* JonL "14-Sep-84 00:46") (\MP.ERROR \MP.BIGREFCNTMISSING "PTR refcnt previously overflowed, but not found in table." PTR ENTRY]) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \HTBIGCOUNT) +) + + + +(* ; "GC") + +(DEFINEQ + +(\GCMAPSCAN [LAMBDA NIL (* ; "Edited 2-Feb-87 10:31 by jop") (* ;; "scan gc tables looking for reclaimable items") (PROG (ENTRY PTR (PROBE \HTMAINSIZE) LINK PREV) NEXTENTRY [SETQ ENTRY (\ADDBASE \HTMAIN (SETQ PROBE (OR (\GCSCAN1 PROBE) (RETURN] RETRY (COND ((fetch (GC LINKP) of ENTRY) (* ; "trace down collision table") (SETQ PREV NIL) (SETQ LINK (\ADDBASE \HTCOLL (fetch (GC LINKPTR) of ENTRY))) [PROG NIL LINKLOOP (CHECK (EVENP (\LOLOC LINK)) (SELECTC (fetch (GC HIBITS) of LINK) ((LIST \AtomHI \SmallPosHi \SmallNegHi) NIL) T) (NOT (fetch (GC LINKP) of LINK))) [COND ((EQ (fetch (GC STKCNT) of LINK) 0) (SETQ PTR (\VAG2 (fetch (GC HIBITS) of LINK) (LLSH PROBE 1))) (.DELLINK. LINK PREV ENTRY) (.GCRECLAIMLP. PTR) (COND ((fetch (GC EMPTY) of ENTRY) (GO NEXTENTRY)) (T (GO RETRY] (SETQ PREV LINK) (COND ((NEQ 0 (SETQ LINK (fetch (GC NXTPTR) of LINK))) (SETQ LINK (\ADDBASE \HTCOLL LINK)) (GO LINKLOOP] (GO NEXTENTRY))) (CHECK (SELECTC (fetch (GC HIBITS) of ENTRY) ((LIST \AtomHI \SmallPosHi \SmallNegHi) NIL) T)) (COND ((EQ 0 (fetch (GC STKCNT) of ENTRY)) (* ;  "REF CNT WENT TO 0 -- ERASE ENTRY IN MAIN TABLE, AND RECLAIM POINTER") (SETQ PTR (\VAG2 (fetch (GC HIBITS) of ENTRY) (LLSH PROBE 1))) (replace (GC EMPTY) of ENTRY with T) (.GCRECLAIMLP. PTR))) (GO NEXTENTRY]) + +(\GCMAPUNSCAN [LAMBDA NIL (* ; "Edited 2-Feb-87 10:32 by jop") (* ;; "scan gc tables turning of stack bits") (PROG ((PROBE \HTMAINSIZE) ENTRY) LP [SETQ ENTRY (\ADDBASE \HTMAIN (SETQ PROBE (OR (\GCSCAN2 PROBE) (RETURN] RETRY [COND [(fetch (GC LINKP) of ENTRY) (* ;  "LINK -- trace down collision table") (PROG ((LNK (\ADDBASE \HTCOLL (fetch (GC LINKPTR) of ENTRY))) PREV) SCNLP [COND ((fetch (GC STKBIT) of LNK) (COND ((EQ (fetch (GC CNT) of LNK) 1) (* ;  "Ref count 1 with no stack bit => no entry") (.DELLINK. LNK PREV ENTRY) (* ;  ".DELLINK. smashes the chain, so don't try to follow it further") (GO RETRY)) (T (replace (GC STKBIT) of LNK with NIL] (COND ([NEQ 0 (SETQ LNK (fetch (GC NXTPTR) of (SETQ PREV LNK] (SETQ LNK (\ADDBASE \HTCOLL LNK)) (GO SCNLP] ((fetch (GC STKBIT) of ENTRY) (COND ((EQ (fetch (GC CNT) of ENTRY) 1) (replace (GC EMPTY) of ENTRY with T)) (T (replace (GC STKBIT) of ENTRY with NIL] (GO LP]) + +(\GCRECLAIMCELL [LAMBDA (CELL) (* ; "Edited 25-Mar-87 11:48 by bvm:") (* ;; "Called with CELL a pointer being freed. It has just had its refcount bumped from zero to one. We need to decrement the refcnt of anything it points at, and if possible reclaim any of those that are now at zero count.") (* ;; "This is the new \GCRECLAIMCELL -- old version lives on as \OLDGCRECLAIMCELL if anyone wants the old behavior (uses microcode but doesn't reclaim bushy structures)") (PROG ((PTR CELL) DTD VAL TYPE INDEX DONEXT PTRFIELDS CODE FINAL) LP (CHECK (EQ 1 (\REFCNT PTR))) (SELECTC (SETQ TYPE (NTYPX PTR)) (\LISTP (COND ((EQ CDRCODING 0) (GO NORMAL))) [COND ((EQ (SETQ CODE (fetch CDRCODE of PTR)) \CDR.INDIRECT) (* ; "Dispose of indirection first") (SETQ PTR (PROG1 (fetch CARFIELD of PTR) (\FREELISTCELL PTR))) (SETQ CODE (fetch CDRCODE of PTR)) (CHECK (NEQ CODE \CDR.INDIRECT) (ILEQ CODE \CDR.MAXINDIRECT] [COND (INDEX (* ;  "We've already decremented the CAR, start with the CDR") (SETQ INDEX NIL)) (T (COND ((SETQ VAL (\DELREF (CAR PTR))) (* ;  "CAR went to zero, start working on it") (replace (GCPTR FULLLINKFIELD) of PTR with DONEXT) (replace CDRCODE of PTR with CODE) (* ;  "Keep CDR Code, which was smashed by FULLLINKFIELD") (SETQ DONEXT PTR) (GO DOVAL] (SETQ VAL (\DELREF (CDR PTR))) [COND ((ILEQ CODE \CDR.MAXINDIRECT) (* ; "indirect") (* ; "local indirect") (\FREELISTCELL (\ADDBASE (fetch PAGEBASE of PTR) (LLSH (IDIFFERENCE CODE \CDR.INDIRECT) 1] (\FREELISTCELL PTR) (GO DOVAL)) (if (AND (NOT INDEX) (SETQ FINAL (\GETBASEPTR \FINALIZATION.FUNCTIONS (UNFOLD TYPE WORDSPERCELL))) (CL:FUNCALL FINAL PTR)) then (* ;; "Type has a finalization that can perform cleanups. If returns T, says not to reclaim now. Don't do this when INDEX is true, because in that case we have already half reclaimed the object.") (GO TRYNEXT))) NORMAL (SETQ DTD (\GETDTD TYPE)) (SETQ PTRFIELDS (fetch DTDPTRS of DTD)) (COND (INDEX (* ;; "We have half reclaimed PTR already. INDEX is the cell offset of the first field we haven't decremented yet") (SETQ INDEX (UNFOLD INDEX WORDSPERCELL)) (do (SETQ PTRFIELDS (CDR PTRFIELDS)) (CHECK PTRFIELDS) repeatuntil (EQ (CAR PTRFIELDS) INDEX)) (SETQ INDEX NIL))) [while PTRFIELDS do (COND ([SETQ VAL (\DELREF (\GETBASEPTR PTR (pop PTRFIELDS] (* ; "Suspend work on PTR, go chase VAL") (COND (PTRFIELDS (* ; "There is more to do") (replace (GCPTR FULLLINKFIELD) of PTR with DONEXT) (CHECK (EVENP (CAR PTRFIELDS)) (ILESSP (CAR PTRFIELDS) (UNFOLD (LLSH 1 BITSPERBYTE) WORDSPERCELL))) (replace (GCPTR OFFSETCODE) of PTR with (FOLDLO (CAR PTRFIELDS) WORDSPERCELL)) (* ;  "This assumes that no datatype is longer than 2^8 cells long") (SETQ DONEXT PTR) (GO DOVAL)) (T (* ;  "That was the last pointer field anyway, so finish up") (GO ADDTOFREELIST] ADDTOFREELIST (\PUTBASEPTR PTR 0 (fetch DTDFREE of DTD)) (replace DTDFREE of DTD with PTR) DOVAL (COND (VAL (\ADDREF (SETQ PTR VAL)) (SETQ VAL NIL) (GO LP))) TRYNEXT (COND (DONEXT (SETQ PTR DONEXT) (SETQ DONEXT (fetch (GCPTR LINKFIELD) of PTR)) (SETQ INDEX (fetch (GCPTR OFFSETCODE) of PTR)) (GO LP))) (RETURN NIL]) + +(\FREELISTCELL [LAMBDA (X) (* lmm " 1-JAN-82 23:54") (PROG ((BASE (fetch (POINTER PAGEBASE) of X))) (CHECK (LISTP X) (EVENP (\LOLOC X))) (replace CDRCODE of X with (fetch NEXTCELL of BASE)) (replace NEXTCELL of BASE with (fetch (POINTER WORD#) of X)) (COND ((AND (IGREATERP (add (fetch (CONSPAGE CNT) of BASE) 1) 2) (EQ (fetch NEXTPAGE of BASE) \CONSPAGE.LAST)) (replace NEXTPAGE of BASE with (fetch DTDNEXTPAGE of \LISTPDTD)) (replace DTDNEXTPAGE of \LISTPDTD with (PAGELOC BASE]) + +(\GCSCAN1 [LAMBDA (PROBE) (* ; "Edited 2-Feb-87 10:27 by jop") (PROG (ENT) LP (COND ((ILEQ PROBE 0) (RETURN NIL))) [SETQ ENT (\ADDBASE \HTMAIN (SETQ PROBE (SUB1 PROBE] (COND ([AND (NOT (fetch (GC EMPTY) of ENT)) (OR (fetch (GC LINKP) of ENT) (EQ 0 (fetch (GC STKCNT) of ENT] (RETURN PROBE)) (T (GO LP]) + +(\GCSCAN2 [LAMBDA (PROBE) (* lmm "23-DEC-81 22:48") (PROG NIL LP (COND ((ILEQ PROBE 0) (RETURN NIL)) ((NEQ [LOGAND (CONSTANT (LOGOR \HTSTKBIT 1)) (\GETBASE \HTMAIN (SETQ PROBE (SUB1 PROBE] 0) (RETURN PROBE)) (T (GO LP]) + +(\REFCNT [LAMBDA (PTR) (* ; "Edited 9-Feb-93 14:27 by jds") (PROG (ENTRY LINK CNT) (COND ((fetch (MDSTYPEWORD NOREFCNT) of (\ADDBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of PTR) 1))) (* ; "PTR is not reference counted") (RETURN 1))) (CHECK (EVENP (\LOLOC PTR))) (SETQ ENTRY (\ADDBASE \HTMAIN (UNFOLD (LRSH (\LOLOC PTR) 1) WORDSPERGCENTRY))) [COND ((fetch (GC EMPTY) of ENTRY) (RETURN 1)) ((fetch (GC LINKP) of ENTRY) (* ; "chase down the link") (GO FINDLINK)) ((NEQ (\HILOC PTR) (fetch (GC HIBITS) of ENTRY)) (* ;  "Doesn't match ptr in table, so no entry") (RETURN 1)) ((ILESSP (SETQ CNT (fetch (GC CNT) of ENTRY)) \MAXHTCNT) (RETURN CNT)) (T (* ; "Look in overflow table") (RETURN (\GC.LOOKUP.BIGREFCNT PTR ENTRY] FINDLINK (SETQ LINK (\ADDBASE \HTCOLL (UNFOLD (fetch (GC LINKPTR) of ENTRY) WORDSPERGCENTRY))) LINKLOOP [COND ((EQ (fetch (GC HIBITS) of LINK) (\HILOC PTR)) (* ; "found the link entry") (RETURN (COND ((ILESSP (SETQ CNT (fetch (GC CNT) of LINK)) \MAXHTCNT) CNT) (T (\GC.LOOKUP.BIGREFCNT PTR] (COND ((EQ (SETQ LINK (fetch (GC NXTPTR) of LINK)) 0) (* ;  "Didn't find an entry on this chain") (RETURN 1)) (T (SETQ LINK (\ADDBASE \HTCOLL (UNFOLD LINK WORDSPERGCENTRY))) (GO LINKLOOP]) + +(\EQREFCNT1 [LAMBDA (PTR) (* ; "Edited 9-Feb-93 14:28 by jds") (* ;; "True if PTR's refcnt is definitely one -- this differs from (EQ (\REFCNT PTR) 1) because it is false for objects that are not reference counted, and also for objects whose stack bit is on (during gc)") (PROG (ENTRY LINK) (COND ((fetch (MDSTYPEWORD NOREFCNT) of (\ADDBASE \MDSTypeTable (LRSH (fetch (POINTER PAGE#) of PTR) 1))) (* ;  "PTR is not reference counted--ref cnt is indeterminate") (RETURN NIL))) (CHECK (EVENP (\LOLOC PTR))) (SETQ ENTRY (\ADDBASE \HTMAIN (UNFOLD (LRSH (\LOLOC PTR) 1) WORDSPERGCENTRY))) [COND ((NOT (fetch (GC LINKP) of ENTRY)) (* ;  "Ref cnt is 1 if there's no entry, or this entry is not for PTR") (RETURN (OR (fetch (GC EMPTY) of ENTRY) (NEQ (\HILOC PTR) (fetch (GC HIBITS) of ENTRY] (* ; "chase down the link") (SETQ LINK (\ADDBASE \HTCOLL (UNFOLD (fetch (GC LINKPTR) of ENTRY) WORDSPERGCENTRY))) LINKLOOP (COND ((EQ (fetch (GC HIBITS) of LINK) (\HILOC PTR)) (* ;  "found the link entry, so must not be 1") (RETURN NIL)) ((EQ (SETQ LINK (fetch (GC NXTPTR) of LINK)) 0) (* ;  "Didn't find an entry on this chain") (RETURN T)) (T (SETQ LINK (\ADDBASE \HTCOLL (UNFOLD LINK WORDSPERGCENTRY))) (GO LINKLOOP]) + +(\SET.FINALIZATION.FUNCTION [LAMBDA (TYPE FN) (* ; "Edited 4-Mar-87 11:29 by bvm:") (* ;; "Make FN be the finalization fn for specified TYPE (number or name). Finalization fn is a function of one argument, a pointer whose ref count is zero and about to be reclaimed. Fn returns NIL if ok to reclaim, T if not.") (LET [(TYPENO (OR (FIXP TYPE) (\TYPENUMBERFROMNAME TYPE] (IF (NOT (AND TYPENO (<= TYPENO \MaxTypeNumber))) THEN (\ILLEGAL.ARG TYPE) ELSEIF (NOT (FNTYP FN)) THEN (\ILLEGAL.ARG FN) ELSE (\PUTBASEPTR \FINALIZATION.FUNCTIONS (UNFOLD TYPENO WORDSPERCELL) FN]) +) + + + +(* ; "User entries") + +(DEFINEQ + +(RECLAIM [LAMBDA NIL (* lmm " 1-JUN-81 20:06") (\DORECLAIM) 0]) + +(\DORECLAIM [LAMBDA NIL (DECLARE (GLOBALVARS GCMESS \RECLAIM.COUNTDOWN)) (* lmm "15-OCT-82 12:12") (COND ((NOT (\GCDISABLED)) (UNINTERRUPTABLY (SETQ \RECLAIM.COUNTDOWN NIL) (PROG ((GCTIME1 (CLOCK 2 \GCTIME1))) (AND GCMESS (FLIPCURSOR)) (\CONTEXTSWITCH \GCFXP) (AND GCMESS (FLIPCURSOR)) (\BOXIPLUS (LOCF (fetch GCTIME of \MISCSTATS)) (\BOXIDIFFERENCE (CLOCK 2 \GCTIME2) GCTIME1))) (SETQ \RECLAIM.COUNTDOWN \RECLAIMMIN))]) + +(\MAIKO.DORECLAIM [LAMBDA NIL (* ; "Edited 12-Oct-88 12:01 by krivacic") (SUBRCALL DORECLAIM]) + +(RECLAIMMIN [LAMBDA (N) (* bvm%: " 3-Sep-85 22:20") (PROG1 (OR \RECLAIMMIN T) (COND (N (SETQ \RECLAIM.COUNTDOWN (SETQ \RECLAIMMIN (COND ((AND (NOT \GCDISABLED) (NEQ N T)) (IMIN (IMAX N 100) MAX.SMALL.INTEGER]) + +(GCMESS [LAMBDA (NUM STR) (* lmm " 1-JUN-81 20:08") NIL]) + +(GCGAG [LAMBDA (MESSAGE) (* rrb "11-JUN-81 10:13") (DECLARE (GLOBALVARS GCMESS)) (PROG1 GCMESS (SETQ GCMESS MESSAGE]) + +(GCTRP [LAMBDA NIL (* ; "Edited 2-Feb-87 10:28 by jop") (* ;; "returns the number of storage allocations before the next gc") (OR (FIXP \RECLAIM.COUNTDOWN) 0]) +) + +(ADDTOVAR \MAIKO.MOVDS (\MAIKO.DORECLAIM \DORECLAIM)) + + + +(* ; "Turning off GC") + +(DEFINEQ + +(DISABLEGC [LAMBDA (NOERROR) (* bvm%: " 3-Sep-85 21:49") (UNINTERRUPTABLY (\DISABLEGC1 NOERROR))]) + +(\DISABLEGC1 [LAMBDA (NOERROR) (* ; "Edited 2-Feb-87 10:29 by jop") (* ;; "Do all the things necessary when GC must be turned off") [LET ((TYPEBASE \MDSTypeTable)) (* ;  "Mark every type entry in the world 'don't ref count'") (FRPTQ (UNFOLD \MDSTTsize WORDSPERPAGE) (replace (MDSTYPEWORD NOREFCNT) of TYPEBASE with T) (SETQ TYPEBASE (\ADDBASE TYPEBASE 1] (SETQ \RECLAIM.COUNTDOWN (SETQ \RECLAIMMIN)) (PROGN (COND ((AND (NOT NOERROR) (NOT \GCDISABLED)) (* ;  "Cause an interrupt and warning at next opportune time") (replace GCDISABLED of \INTERRUPTSTATE with T) (SETQ \PENDINGINTERRUPT T))) (SETQ \GCDISABLED T)) NIL]) + +(\MAIKO.DISABLEGC (LAMBDA NIL (* ; "Edited 7-Jun-90 19:04 by nm") (SUBRCALL DISABLEGC))) + +(\DOGCDISABLEDINTERRUPT [LAMBDA NIL (* ; "Edited 2-Feb-87 10:29 by jop") (* ;; "Called while interruptable after GC disabled. So informs user.") (LET ((W (CREATEW (CREATEREGION 300 (IDIFFERENCE SCREENHEIGHT 100) 450 100) "GC Disabled Warning"))) (printout W T "Internal garbage collector tables have overflowed, due to too many pointers with reference count greater than 1. *** The garbage collector is now disabled. *** Save your work and reload as soon as possible.") (replace GCDISABLED of \INTERRUPTSTATE with NIL) (FLASHWINDOW W 4) (HELP "GC Disabled" " Save and reload a.s.a.p."]) +) + +(ADDTOVAR \MAIKO.MOVDS (\MAIKO.DISABLEGC \DISABLEGC1)) + +(RPAQ? \GCDISABLED ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \GCDISABLED) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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))) +) +(DECLARE%: EVAL@COMPILE + +(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.")) +) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: EVAL@COMPILE + +(BLOCKRECORD GCOVFL ((OVFLPTR FULLXPOINTER) (OVFLCNTHI WORD) (OVFLCNTLO WORD))) + +(BLOCKRECORD MDSTYPEWORD ((NOREFCNT FLAG) (NIL BITS 15))) + +(BLOCKRECORD GCPTR ((OFFSETCODE BITS 4) (* ; "What to do next") (LINKFIELD XPOINTER) (* ; "Link to next thing to work on after this")) + (BLOCKRECORD GCPTR ((FULLLINKFIELD FULLXPOINTER)))) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \HTBIGENTRYSIZE 4) + +(RPAQ \HT2CNT (IPLUS \HT1CNT \HT1CNT)) + +(RPAQQ \HTCNTSHIFT 10) + +(RPAQ \HTNOSTKBIT (LOGXOR 65535 \HTSTKBIT)) + +(RPAQ \HTSTK1 (LOGOR \HTSTKBIT \HT1CNT)) + +(RPAQ \HTSTKCNT (LOGOR \HTCNTMASK \HTSTKBIT)) + +(RPAQQ \HTHIMASK 510) + +(RPAQQ \MAXHTCNT 32767) + +(RPAQQ WORDSPERGCENTRY 2) + + +(CONSTANTS \HTBIGENTRYSIZE (\HT2CNT (IPLUS \HT1CNT \HT1CNT)) (\HTCNTSHIFT 10) (\HTNOSTKBIT (LOGXOR 65535 \HTSTKBIT)) (\HTSTK1 (LOGOR \HTSTKBIT \HT1CNT)) (\HTSTKCNT (LOGOR \HTCNTMASK \HTSTKBIT)) \HTHIMASK (\MAXHTCNT 32767) (WORDSPERGCENTRY 2)) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \HTCOLLTHRESHOLD 65528) + +(RPAQQ \HTCOLLMAX 65534) + + +(CONSTANTS \HTCOLLTHRESHOLD \HTCOLLMAX) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS .GETLINK. MACRO ((VAR) (* ; "get a new cell from free list into VAR") (SETQ VAR (fetch (HTCOLL FREEPTR) of \HTCOLL)) (COND ((EQ 0 VAR) (COND ((IGEQ (SETQ VAR (fetch (HTCOLL NEXTFREE) of \HTCOLL)) \HTCOLLTHRESHOLD) (\DISABLEGC1) (COND ((EQ VAR \HTCOLLMAX) (* ; "Don't wrap it around. Should never get here -- stop ref counting if gc is disabled!") (SETQ VAR (IDIFFERENCE VAR 2)))))) (replace (HTCOLL NEXTFREE) of \HTCOLL with (IPLUS VAR 2)) (SETQ VAR (\ADDBASE \HTCOLL VAR))) (T (replace (HTCOLL FREEPTR) of \HTCOLL with (fetch (GC NXTPTR) of (SETQ VAR (\ADDBASE \HTCOLL VAR)))))))) + +(PUTPROPS .DELLINK. MACRO ((LINK PREV ENTRY) (PROGN (COND (PREV (replace (GC NXTPTR) of PREV with (fetch (GC NXTPTR) of LINK))) (T (replace (GC LINKPTR) of ENTRY with (fetch (GC NXTPTR) of LINK)))) (* ; "skip over this guy") (.FREELINK. LINK) (* ; "put him on the free list") (COND ((EQ 0 (fetch (GC NXTPTR) of (SETQ LINK (\ADDBASE \HTCOLL (fetch (GC LINKPTR) of ENTRY))))) (* ; "if there is now only one entry on this chain, put him back on the free list too") (replace (GC CONTENTS) of ENTRY with (fetch (GC CONTENTS) of LINK)) (.FREELINK. LINK)))))) + +(PUTPROPS .FREELINK. DMACRO (OPENLAMBDA (LINKCELL) (* ; "put LINKCELL back on HTCOLL freelist") (replace (GC CONTENTS) of LINKCELL with 0) (replace (GC NXTPTR) of LINKCELL with (fetch (HTCOLL FREEPTR) of \HTCOLL)) (replace (HTCOLL FREEPTR) of \HTCOLL with (\LOLOC LINKCELL)))) + +(PUTPROPS .MODENTRY. DMACRO ((ENTRY CASE PTR) (PROG ((GCCNT (fetch (GC CNT) of ENTRY))) (DECLARE (LOCALVARS GCCNT)) (COND ((NEQ GCCNT \MAXHTCNT) (SELECTC CASE (\ADDREFCASE (COND ((EQ GCCNT (SUB1 \MAXHTCNT)) (\GC.ENTER.BIGREFCNT PTR ENTRY)) (T (replace (GC CNT) of ENTRY with (ADD1 GCCNT))))) (\DELREFCASE (OR (NEQ 0 GCCNT) (\MP.ERROR \MP.DELREF0 "DELREF on PTR with 0 refcnt" PTR ENTRY)) (replace (GC CNT) of ENTRY with (SUB1 GCCNT))) (\SCANREFCASE (replace (GC STKBIT) of ENTRY with T)) (\UNSCANREFCASE (replace (GC STKBIT) of ENTRY with NIL)) (\GCERROR)) (RETURN (EQ (fetch (GC STKCNT) of ENTRY) (LLSH 1 1)))) (T (\GC.MODIFY.BIGREFCNT ENTRY CASE PTR)))))) + +(PUTPROPS .NEWENTRY. MACRO ((ENTRY PTR CASE) (PROGN (CHECK (fetch (GC EMPTY) of ENTRY)) (replace (GC HIBITS) of ENTRY with (\HILOC PTR)) (SELECTC CASE (\ADDREFCASE (replace (GC CNT) of ENTRY with 2) NIL) (\DELREFCASE PTR) (\SCANREFCASE (replace (GC CNT) of ENTRY with 1) (replace (GC STKBIT) of ENTRY with T) NIL) (\GCERROR))))) + +(PUTPROPS .GCRECLAIMLP. DMACRO ((X) (PROG NIL LP (COND ((SETQ X (\GCRECLAIMCELL X)) (\ADDREF X) (GO LP)))))) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \RECLAIMMIN \RECLAIM.COUNTDOWN \GCTIME1 \GCTIME2 \FINALIZATION.FUNCTIONS) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \ADDREFCASE 0) + +(RPAQQ \DELREFCASE 1) + +(RPAQQ \SCANREFCASE 2) + +(RPAQQ \UNSCANREFCASE 3) + + +(CONSTANTS \ADDREFCASE \DELREFCASE \SCANREFCASE \UNSCANREFCASE) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQ? \RECLAIMMIN 3000) + +(RPAQ? \RECLAIM.COUNTDOWN 3000) + +(RPAQ? GCMESS T) + +(RPAQ? \GCTIME1 (CREATECELL \FIXP)) + +(RPAQ? \GCTIME2 (CREATECELL \FIXP)) +) +(DEFINEQ + +(\GCERROR [LAMBDA (REASON FLG) (* lmm " 8-DEC-81 14:21") (PROG NIL (COND ((AND FLG REASON (\GCDISABLED)) (RETURN))) (until (RAID (OR REASON "Bad CASE arg to \HTFIND"))) (DISABLEGC]) +) + + + +(* ; "for MAKEINIT") + +(DEFINEQ + +(INITGC [LAMBDA NIL (* bvm%: "13-Feb-84 18:14") (CREATEPAGES \HTMAIN (FOLDHI \HTMAINSIZE WORDSPERPAGE) T T) (CREATEPAGES \HTOVERFLOW 1 T T) (CREATEPAGES \HTBIGCOUNT 1 T) (CREATEPAGES \HTCOLL 1 NIL T) (CREATEPAGES (\ADDBASE \HTCOLL WORDSPERPAGE) (SUB1 (FOLDHI \HTCOLLSIZE WORDSPERPAGE)) T) (replace (HTCOLL FREEPTR) of \HTCOLL with 0) (replace (HTCOLL NEXTFREE) of \HTCOLL with 2]) +) +(DECLARE%: DONTCOPY + +(ADDTOVAR MKI.SUBFNS (ADDREF . PROGN) (\ADDREF . PROGN) (\DELREF . PROGN) (CREATEREF . PROGN) (\CREATEREF . PROGN) + (DELETEREF . PROGN) (.INCREMENT.ALLOCATION.COUNT. . PROGN) (.CHECK.ALLOCATION.COUNT. . PROGN)) + + +(ADDTOVAR INEWCOMS (FNS INITGC)) +EVAL@COMPILE + +(ADDTOVAR DONTCOMPILEFNS INITGC) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +(PUTPROPS LLGC COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 +1992 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2718 10087 (\HTFIND 2728 . 6676) (\GC.HANDLEOVERFLOW 6678 . 7792) (\GCMAPTABLE 7794 . +10085)) (10132 16691 (\GC.ENTER.BIGREFCNT 10142 . 12050) (\GC.MODIFY.BIGREFCNT 12052 . 15398) ( +\GC.LOOKUP.BIGREFCNT 15400 . 16445) (\GC.BIGREFCNT.MISSING 16447 . 16689)) (16774 34815 (\GCMAPSCAN +16784 . 19275) (\GCMAPUNSCAN 19277 . 21179) (\GCRECLAIMCELL 21181 . 27295) (\FREELISTCELL 27297 . +28144) (\GCSCAN1 28146 . 28670) (\GCSCAN2 28672 . 29071) (\REFCNT 29073 . 31623) (\EQREFCNT1 31625 . +34035) (\SET.FINALIZATION.FUNCTION 34037 . 34813)) (34845 36923 (RECLAIM 34855 . 34991) (\DORECLAIM +34993 . 35635) (\MAIKO.DORECLAIM 35637 . 35789) (RECLAIMMIN 35791 . 36356) (GCMESS 36358 . 36474) ( +GCGAG 36476 . 36660) (GCTRP 36662 . 36921)) (37014 39083 (DISABLEGC 37024 . 37193) (\DISABLEGC1 37195 + . 38207) (\MAIKO.DISABLEGC 38209 . 38302) (\DOGCDISABLEDINTERRUPT 38304 . 39081)) (45561 45875 ( +\GCERROR 45571 . 45873)) (45905 46443 (INITGC 45915 . 46441))))) +STOP diff --git a/sources/LLINTERP b/sources/LLINTERP new file mode 100644 index 00000000..d5862fb1 --- /dev/null +++ b/sources/LLINTERP @@ -0,0 +1,580 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 2-Feb-95 17:31:23" {DSK}sources>LLINTERP.;3 120814 + + changes to%: (VARS LLINTERPCOMS) + + previous date%: "31-Aug-94 14:38:32" {DSK}sources>LLINTERP.;2) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 1995 by Venue & Xerox Corporation. All rights reserved. +The following program was created in 1981 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 LLINTERPCOMS) + +(RPAQQ LLINTERPCOMS + [(COMS (* ; "Compilation pre-requisites") + (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) + LLBASIC LLSTK LLCODE LLPARAMS ACODE))) + [E (* ; + "Don't fontify these common functions") + (SETQ FNSLST + (LDIFFERENCE FNSLST + '(EVALV PROG SET SETQ RETURN GO QUOTE AND OR PROGN COND PROG1 FUNCTION EVAL + APPLY] + (COMS (* ; + "For calling interpreted functions") + (FNS \INTERPRETER \INTERPRETER1 \SETUP-COMPILED-CLOSURE-CALL \STKNAME)) + (COMS (* ; "EVCALL ufn.") + (FNS \ENVCALL.UFN \SETUP-ENVIRONMENT-CALL)) + (COMS (* ; "recursive interpreter") + (FNS EVAL \EVAL \EVALFORM \EVALFORMASLAMBDA \EVALOTHER APPLY APPLY* \CHECKAPPLY* + \CKAPPLYARGS DEFEVAL) + (DECLARE%: DONTCOPY (MACROS .APPLY.)) + (COMS (* ; "Free variable manipulation") + (FNS EVALV \EVALV1 \EVALVAR BOUNDP SET \SETVAR SETQ \STKSCAN \SETFVARSLOT)) + (COMS (* ; "PROG and friends") + (FNS PROG \PROG0 \EVPROG1 RETURN GO EVALA \EVALA ERRORSET + SI::ERRORSET-PRINT-FUNCTION)) + (COMS (* ; + "LET and friends -- need these in the init") + (FNS LET LET* \LET0 \LET*)) + (FNS QUOTE AND OR PROGN COND \EVPROGN PROG1) + (COMS (VARS (\DEFEVALFNS NIL) + (\EVALHOOK)) + (SPECVARS *EVALHOOK*) + (ADDVARS (LAMBDASPLST LAMBDA NLAMBDA CL:LAMBDA OPENLAMBDA)) + (GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY) + (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (CLISPARRAY)) + (P (MOVD? 'SETQ 'SETN NIL T))) + (GLOBALVARS CLISPARRAY)) + [COMS (* ; + "Evaluating in different stack environment") + (FNS ENVEVAL ENVAPPLY FUNCTION \FUNCT1 \MAKEFUNARGFRAME STKEVAL STKAPPLY RETEVAL + RETAPPLY) + (DECLARE%: DONTEVAL@LOAD DOCOPY (* ; + "For bootstrapping, IL:FUNCTION is as good as CL:FUNCTION") + (P (MOVD? 'FUNCTION 'CL:FUNCTION NIL T] + (COMS (* ; "Blip and other stack funniness") + (FNS BLIPVAL SETBLIPVAL BLIPSCAN) + (FNS \REALFRAMEP) + [INITVARS (OPENFNS '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG + ERSETQ NLSETQ RESETFORM RESETLST RESETVARS RPTQ + SAVESETQ SETN UNDONLSETQ XNLSETQ] + (VARS \BLIPNAMES) + (GLOBALVARS BRKINFOLST) + (GLOBALVARS \BLIPNAMES OPENFNS))) + (COMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA READVA + READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM) + (FNS BACKTRACE \BACKTRACE \SCANFORNTENTRY \PRINTSTK \PRINTFRAME \PRINTBF) + (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * RAIDCOMS))) + (COMS (FNS CCODEP EXPRP SUBRP FNTYP ARGTYPE NARGS ARGLIST \CCODEARGLIST \CCODEIVARSCAN) + (COMS (* ; + "Translation machinery for new LAMBDA words") + (PROP VARTYPE LAMBDATRANFNS) + (ALISTS (LAMBDATRANFNS))) + (DECLARE%: DONTCOPY (MACROS \CCODENARGS \CCODEFNTYP \CCODEARGTYPE))) + (COMS (* ; "CONSTANTS mechanism") + (FNS CONSTANTS CONSTANTEXPRESSIONP) + (INITVARS (COMPVARMACROHASH (HASHARRAY 100))) + (* ; "We need this initialized for the INIT, so don't put it off. (It used to start out NIL and get set later)") + (ADDVARS (CONSTANTFOLDFNS PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT + IQUOTIENT IMIN IMAX IABS LLSH LRSH LOGOR LOGXOR LOGAND OR AND)) + (GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS)) + (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T)) + (SPECVARS *TAIL* *FN* *FORM* *ARGVAL*) + (DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (LAMS FAULTEVAL FAULTAPPLY))) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ) + (NLAML FUNCTION RETURN) + (LAMA APPLY* \INTERPRETER]) + + + +(* ; "Compilation pre-requisites") + +(DECLARE%: EVAL@COMPILE DONTCOPY + +(FILESLOAD (LOADCOMP) + LLBASIC LLSTK LLCODE LLPARAMS ACODE) +) + + + +(* ; "For calling interpreted functions") + +(DEFINEQ + +(\INTERPRETER [LAMBDA N (* ; "Edited 21-Jan-91 18:02 by jds") (* ;; "the microcode calls this function instead if it is given an expr or an undefined function to call --- the name of the function/sexpression which is supposed to be called is given as an extra argument") (PROG ((FN (ARG N N)) (NACTUAL (SUB1 N)) (NA 0) DEF ARGLIST NEXTRA NTSIZE TYPE NNILS ENV) (COND ((LITATOM FN) (CHECK (NOT (fetch (LITATOM CCODEP) of FN))) (SETQ DEF (fetch (LITATOM DEFPOINTER) of FN))) (T (SETQ DEF FN))) [COND ((TYPEP DEF 'COMPILED-CLOSURE) (RETURN (\MISCAPPLY* (FUNCTION \SETUP-COMPILED-CLOSURE-CALL) DEF))) ((TYPEP DEF 'CLOSURE) (SETQ ENV (CLOSURE-ENVIRONMENT DEF)) (SETQ DEF (CLOSURE-FUNCTION DEF] (COND ((NLISTP DEF) (GO ERR))) (RETURN (.CALLAFTERPUSHINGNILS. (SELECTQ (CAR DEF) (CL:LAMBDA (RETURN (\INTERPRETER-LAMBDA N DEF ENV FN))) ([LAMBDA NLAMBDA OPENLAMBDA] [SETQ ARGLIST (CAR (OR (LISTP (CDR DEF)) (GO ERR] (SETQ NNILS (IPLUS (SETQ NEXTRA (COND ((LISTP ARGLIST) (* ; "spread function") (for X in ARGLIST do (COND ((OR (NULL (\DTEST X 'LITATOM)) (EQ X T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" X))) (* ; "Process one argument") (SETQ NA (ADD1 NA))) (COND ((IGREATERP NA NACTUAL) (IDIFFERENCE NA NACTUAL)) (T 0))) ((NULL ARGLIST) (* ; "spread function") 0) ((EQ ARGLIST T) (LISPERROR "ATTEMPT TO BIND NIL OR T" ARGLIST)) (T (* ;; "Nospread--needs to bind exactly one variable, the arg name. LAMBDA* also needs to set that arg to the number of actual args, but that can be done by diddling the slot currently occupied by the fn name. Never any 'extra' args to worry about") (\DTEST ARGLIST 'LITATOM) (SETQ NA 1) 0))) (PROG1 (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NA (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (* ;; "round number of nametable entries up to next quadword, leaving room for a zero. add in overhead. NA is now in units of 'cells' since there two words in a cell.") ) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD)))) (FUNARG (GO FUN)) (GO ERR)) (\INTERPRETER1 ARGLIST NNILS NTSIZE NACTUAL NEXTRA FN DEF))) FUN (* ;; "FUNARG -- Interlisp %"closure%" of form (FUNARG fn stackptr). Subsumed by common lisp lexical closures.") [RETURN (PROGN (\SMASHLINK NIL (\STACKARGPTR (CADDR DEF))) (SPREADAPPLY (CADR DEF) (for I from 1 to (SUB1 N) collect (ARG N I] ERR (RETURN (FAULTAPPLY FN (for I from 1 to NACTUAL collect (ARG N I]) + +(\INTERPRETER1 [LAMBDA (ARGLIST NNILS NTSIZE NACTUAL NPVARARGS FN DEF) (* ; "Edited 27-Jan-91 12:48 by jds") (PROG ((*TAIL* (CDDR DEF)) (INTERPFRAME (\MYALINK)) HEADER NT NILSTART) (SETQ HEADER (fetch (FX FNHEADER) of INTERPFRAME)) (* ;  "The function header of code for \INTERPRETER") (* ;; "Build a nametable for INTERPFRAME that identifies the vars in ARGLIST as the NACTUAL IVAR's that were passed to it as arguments plus the NPVARARGS extra NIL's that we implement as PVAR's. We build the nametable out of space that was allocated on the stack by \INTERPRETER pushing many NIL's") (SETQ NT (ADDSTACKBASE (CEIL (+ (SETQ NILSTART (- (fetch (FX NEXTBLOCK) of INTERPFRAME ) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NPVARARGS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "Address of our synthesized nametable: NNILS cells back from the end of INTERPFRAME, leaving space for additional 'PVARs' we are using as extra NIL args, rounded up to quadword") (UNINTERRUPTABLY [COND ((NOT ARGLIST) (* ; "No args, no nametable") ) ((LISTP ARGLIST) (for ARG in ARGLIST as ARG# from 0 as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from (+ (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX ARG)) [SETSTKNTOFFSET-RAW NT NT2 (COND ((< ARG# NACTUAL) IVARCODE) (T (* ;  "Say it's the nth PVAR, where n is out of the range of the real PVARs") PVARCODE)) (COND ((< ARG# NACTUAL) ARG#) (T (* ;  "Say it's the nth PVAR, where n is out of the range of the real PVARs") (IPLUS (FOLDLO (- NILSTART (fetch (FX FIRSTPVAR) of INTERPFRAME)) WORDSPERCELL) (- ARG# NACTUAL] (* ; "(SETSTKNTOFFSET-RAW NT NT2 (COND ((< ARG# NACTUAL) (+ IVARCODE ARG#)) (T ; Say it's the nth PVAR, where n is out of the range of the real PVARs (+ PVARCODE (FOLDLO (- NILSTART (fetch (FX FIRSTPVAR) of INTERPFRAME)) WORDSPERCELL) (- ARG# NACTUAL)))))") ) (* ;  "Note: area is initialize to NIL's (zero), so end of nametable already has its zeroes") ) (T (* ;  "Nospread. Store lone arg in nametable") (SETSTKNAME-RAW NT (fetch (FNHEADER OVERHEADWORDS) of T) (\ATOMVALINDEX ARGLIST)) (SETSTKNTOFFSET-RAW NT (+ (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) IVARCODE (COND ((EQ (CAR DEF) 'NLAMBDA) (* ; "It's the first (and only) arg") 0) (T (* ;  "Use the n+1'st arg, which currently is our framename (FN)") (\PUTBASEPTR \STACKSPACE (+ (fetch (BF IVAR) of (fetch (FX BLINK) of INTERPFRAME)) (UNFOLD NACTUAL WORDSPERCELL)) NACTUAL) (* ;  "set arg's value to be number of real args") NACTUAL] (* ;; "now fix up header of NT") (replace (FNHEADER %#FRAMENAME) of NT with FN) (* ;  "use #FRAMENAME to denote no reference counting") (replace (FNHEADER NTSIZE) of NT with NTSIZE) (replace (FNHEADER NLOCALS) of NT with (fetch (FNHEADER NLOCALS) of HEADER)) (* ;  "Probably doesn't matter, since there are no FVARS in that frame") (* ;  "Do I need to worry about STK, NA, PV, START, ARGTYPE ? --- probably not") (replace (FX NAMETABLE) of INTERPFRAME with NT)) EVLP (* ;;  "Now that we have 'bound' the arguments, just evaluate the forms in the LAMBDA/NLAMBDA as progn") (COND ((CDR *TAIL*) (\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO EVLP)) (T (RETURN (\EVAL (CAR *TAIL*]) + +(\SETUP-COMPILED-CLOSURE-CALL (LAMBDA (CLOSURE) (* bvm%: "21-Jul-86 11:12") (* ;;; "Called in the misc context by \INTERPRETER when the function being called is a closure. Replace the intepreter frame by the frame that would result if we had correctly called the closure in microcode. This is a normal function call of the code body in the closure with the one additional wrinkle that the CLOSURE object is stored in PVAR1.") (LET ((INTERPFRAME (fetch (IFPAGE MiscFXP) of \InterfacePage)) (CODE (fetch (COMPILED-CLOSURE FNHEADER) of CLOSURE)) NA NACTUALS INTERPBF INTERPIVAR INTERPALINK INTERPCLINK SP NEWFX NPVARS STKEND SLOWP OLDBF ENV) (SETQ OLDBF (SETQ INTERPBF (fetch (FX BLINK) of INTERPFRAME))) (SETQ INTERPIVAR (fetch (BF IVAR) of INTERPBF)) (SETQ INTERPALINK (fetch (FX %#ALINK) of INTERPFRAME)) (* ; "Note that this is the 'raw' ALINK -- we never look at it, just update it in new FX") (COND ((SETQ SLOWP (fetch (FX SLOWP) of INTERPFRAME)) (* ;; "Usually false, because \INTERPRETER hasn't had any reason to make itself slow. But it's not uninterruptable, so arbitrary things could happen to it") (SETQ INTERPCLINK (fetch (FX %#CLINK) of INTERPFRAME)))) (SETQ STKEND (fetch (FX NEXTBLOCK) of INTERPFRAME)) (COND ((fetch (BF PADDING) of INTERPBF) (* ; "Forget padding. I don't think anyone pads anymore, except maybe Lisp stack mungers") (SETQ INTERPBF (IDIFFERENCE INTERPBF WORDSPERCELL)))) (SETQ NACTUALS (FOLDLO (IDIFFERENCE INTERPBF INTERPIVAR) WORDSPERCELL)) (SETQ NA (fetch (FNHEADER NA) of CODE)) (COND ((OR SLOWP (ILESSP (IDIFFERENCE STKEND INTERPBF) (fetch (FNHEADER STKMIN) of CODE))) (* ;; "No space for frame, or interpreter frame is slow, do slow case. This computation is quite conservative, since we aren't counting the args") (LET ((NEWSTACK (\FREESTACKBLOCK (IPLUS (fetch (FNHEADER STKMIN) of CODE) (UNFOLD NACTUALS WORDSPERCELL)) INTERPFRAME))) (SETQ STKEND (IPLUS NEWSTACK (fetch (FSB SIZE) of NEWSTACK))) (while (type? FSB STKEND) do (SETQ STKEND (add STKEND (fetch (FSB SIZE) of STKEND)))) (\BLT (ADDSTACKBASE NEWSTACK) (ADDSTACKBASE INTERPIVAR) (UNFOLD NACTUALS WORDSPERCELL)) (SETQ INTERPBF (IPLUS NEWSTACK (UNFOLD NACTUALS WORDSPERCELL))) (COND ((NEQ (fetch (FX USECNT) of INTERPFRAME) 0) (add (fetch (FX USECNT) of INTERPFRAME) -1)) (T (COND ((NEQ (fetch (BF USECNT) of OLDBF) 0) (add (fetch (BF USECNT) of OLDBF) -1)) (T (* ; "Normal slow case, can flush BF") (\MAKEFREEBLOCK INTERPIVAR (IPLUS (IDIFFERENCE OLDBF INTERPIVAR) WORDSPERCELL)))) (* ; "Finally, flush FX. Has to be separate free block because FX and BF not necessarily contiguous") (LET ((START (COND ((EQ OLDBF (fetch (FX DUMMYBF) of INTERPFRAME)) (* ; "Normal contiguous case") INTERPFRAME) (T (* ; "Have to blow away the dummy BF in front of the FX") (fetch (FX DUMMYBF) of INTERPFRAME))))) (\MAKEFREEBLOCK START (IDIFFERENCE (fetch (FX NEXTBLOCK) of INTERPFRAME) START))))) (SETQ INTERPIVAR NEWSTACK) (SETQ SLOWP T)))) (PROGN (* ; "Do argument adjustment. In general we should pop excess args, but there's really no need for that") (COND ((GREATERP NA NACTUALS) (* ; "Push extra NILs for missing args") (FRPTQ (DIFFERENCE NA NACTUALS) (\PUTBASEPTR (STACKADDBASE INTERPBF) 0 NIL) (add INTERPBF WORDSPERCELL))))) (PROGN (* ; "Fix up BF trailer cell") (\PUTBASE \STACKSPACE INTERPBF 0) (* ; "Clear BF flags") (replace (BF IVAR) of INTERPBF with INTERPIVAR) (replace (BF FLAGS) of INTERPBF with \STK.BF) (CHECK (fetch (BF CHECKED) of INTERPBF))) (PROGN (* ;; "Fix up FX header. Some of this work is redundant in the case where NEWFX is the same as the old, but in general we did some arg adjusting or did the slow case") (SETQ NEWFX (IPLUS INTERPBF WORDSPERCELL)) (\PUTBASE \STACKSPACE NEWFX 0) (* ; "Clear FX flags") (replace (FX FLAGS) of NEWFX with \STK.FX) (replace (FX NOPUSH) of NEWFX with T) (* ; "When we return to the user context, don't want any value to appear on stack") (COND (SLOWP (replace (FX %#BLINK) of NEWFX with INTERPBF) (replace (FX %#CLINK) of NEWFX with (OR INTERPCLINK INTERPALINK)) (* ;; "If INTERPCLINK is NIL, the original frame was not SLOW, so ALINK = CLINK and INTERPALINK has its low bit off") (replace (FX %#ALINK) of NEWFX with (LOGOR INTERPALINK 1))) (T (replace (FX %#ALINK) of NEWFX with INTERPALINK))) (replace (FX FNHEADER) of NEWFX with CODE) (replace (FX PC) of NEWFX with (fetch (FNHEADER STARTPC) of CODE))) (PROGN (* ; "Initialize PVAR region") (SETQ SP (fetch (FX FIRSTPVAR) of NEWFX)) (SETQ NPVARS (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE)) CELLSPERQUAD)) (COND ((SETQ ENV (fetch (COMPILED-CLOSURE ENVIRONMENT) of CLOSURE)) (* ; "Set first pvar to closure environment") (\PUTBASEPTR \STACKSPACE SP ENV) (add SP WORDSPERCELL) (add NPVARS -1))) (RPTQ NPVARS (PROGN (* ; "Fill in rest of Pvar region with 'unbound'") (\PUTBASE \STACKSPACE SP 65535) (add SP WORDSPERCELL)))) (PROGN (* ; "Make free block after this frame") (replace (FX NEXTBLOCK) of NEWFX with (add SP (fetch (FX PADDING) of NEWFX))) (* ; "Need extra junk quad after the pvar region") (\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP)) (CHECK (fetch (FX CHECKED) of NEWFX))) (replace (IFPAGE MiscFXP) of \InterfacePage with NEWFX))) ) + +(\STKNAME [LAMBDA (POS) (* ; "Edited 27-Jan-91 14:20 by jds") (* ;; "Get the frame name from the stack frame at POS. If that's an interpreter frame, get it's caller's frame name.") (LET ((NAME (fetch (FX FRAMENAME) of POS))) (if (EQ NAME '\INTERPRETER) then [\GETBASEPTR \STACKSPACE (LET ((BFLINK (fetch (FX BLINK) of POS))) (+ (fetch (BF IVAR) of BFLINK) (TIMES (CL:1- (fetch (BF NARGS) of BFLINK)) WORDSPERCELL] else NAME]) +) + + + +(* ; "EVCALL ufn.") + +(DEFINEQ + +(\ENVCALL.UFN (LAMBDA (\INTERRUPTABLE) (* ; "Edited 18-Apr-88 18:25 by bvm") (\MISCAPPLY* (FUNCTION \SETUP-ENVIRONMENT-CALL))) ) + +(\SETUP-ENVIRONMENT-CALL (LAMBDA NIL (* ; "Edited 4-Aug-88 11:39 by bvm") (* ;;; "Called in the misc context by ufn for ENVCALL, a variant on APPLYFN that takes on the stack: ..args.. #args codeblock environment. Replace the ufn frame by the frame that would result if we had correctly done the call in microcode. This is a normal function call of the codeblock with the one additional wrinkle that the environment is stored in PVAR0.") (LET* ((UFNFX (fetch (IFPAGE MiscFXP) of \InterfacePage)) (UFNNEXT (fetch (FX NEXTBLOCK) of UFNFX)) (UFNBF (fetch (FX BLINK) of UFNFX)) (UFNIVAR (fetch (BF IVAR) of UFNBF)) (CALLER (fetch (FX CLINK) of UFNFX)) (CALLNEXT (fetch (FX NEXTBLOCK) of CALLER)) CODE ENV NA NACTUALS STKEND SLOWP LOCNARGS FREESIZE NEEDEDSIZE ARGSTART NEWSTACK IVAR) (SETQ LOCNARGS (STACKADDBASE (- CALLNEXT (UNFOLD 3 WORDSPERCELL)))) (* ; "Location in caller's stack of number of args, followed by CODEBLOCK and ENV") (SETQ NACTUALS (\GETBASEPTR LOCNARGS 0)) (* ; "Fetch nargs, codeblock and environment from caller's stack") (SETQ ENV (\GETBASEPTR LOCNARGS 4)) (SETQ CODE (\GETBASEPTR LOCNARGS 2)) (SETQ NA (fetch (FNHEADER NA) of CODE)) (* ; "Number args expected") (SETQ NEEDEDSIZE (fetch (FNHEADER STKMIN) of CODE)) (SETQ ARGSTART (- CALLNEXT (UNFOLD (+ NACTUALS 3) WORDSPERCELL))) (* ; "Address of first argument to function") (if (AND (> NACTUALS NA) (>= NA 0)) then (* ; "More args than expected. No need to retain/copy them (and it's best not to, since STKMIN calculation assumes expected args, not lots more)") (SETQ NACTUALS NA)) (if (AND (if (EQ UFNBF (fetch (FX DUMMYBF) of UFNFX)) then (* ; "BF and FX contiguous") T else (* ; "Yecch. Non-contiguous BF and FX. Toss the BF and do slow case") (\MAKEFREEBLOCK UFNIVAR (+ WORDSPERCELL (- UFNBF UFNIVAR))) (SETQ UFNIVAR (fetch (FX DUMMYBF) of UFNFX)) (* ; "For next \makefreeblock -- have to blow away this dummybf") NIL) (EQ UFNIVAR CALLNEXT) (PROGN (* ; "Caller contiguous with ufn frame") (SETQ FREESIZE (- UFNNEXT UFNIVAR)) (bind SZ while (type? FSB UFNNEXT) do (* ; "Add up the lengths of all the contiguous free blocks") (add FREESIZE (SETQ SZ (fetch (FSB SIZE) of UFNNEXT))) (add UFNNEXT SZ)) (> FREESIZE NEEDEDSIZE))) then (* ; "Normal case: there's enough space to build the frame on top of ufn frame. Args are already there (we will lop them from caller's frame), so no copying to do.") (SETQ STKEND UFNNEXT) (SETQ NEWSTACK ARGSTART) else (* ; "Have to make a discontinuous frame elsewhere") (\MAKEFREEBLOCK UFNIVAR (- UFNNEXT UFNIVAR)) (* ; "Discard ufn frame (and dummy bf before it in the non-contiguous case)") (SETQ NEWSTACK (\FREESTACKBLOCK (+ NEEDEDSIZE (UNFOLD NACTUALS WORDSPERCELL)) UFNIVAR)) (* ; "Get a free block big enough for fn plus the args we'll have to copy") (SETQ STKEND (+ NEWSTACK (fetch (FSB SIZE) of NEWSTACK))) (\BLT (STACKADDBASE NEWSTACK) (STACKADDBASE ARGSTART) (UNFOLD NACTUALS WORDSPERCELL)) (* ; "Copy args to new frame") (\MAKEFREEBLOCK ARGSTART (- CALLNEXT ARGSTART)) (* ; "Free up space taken in caller by args") (SETQ SLOWP T)) (SETQ IVAR NEWSTACK) (add NEWSTACK (UNFOLD NACTUALS WORDSPERCELL)) (replace (FX NEXTBLOCK) of CALLER with ARGSTART) (* ; "Shorten caller's frame to account for args removed") (if (>= NA 0) then (* ; "Fill in NIL for defaulted args") (RPTQ (- NA NACTUALS) (\PUTBASEPTR (STACKADDBASE NEWSTACK) 0 NIL) (add NEWSTACK WORDSPERCELL))) (PROGN (* ; "Fix up BF trailer cell") (\PUTBASE (STACKADDBASE NEWSTACK) 0 \STK.BF.WORD) (* ; "Clear BF flags") (replace (BF IVAR) of NEWSTACK with IVAR) (CHECK (fetch (BF CHECKED) of NEWSTACK))) (PROGN (* ;; "Now build the FX header") (add NEWSTACK WORDSPERCELL) (\PUTBASE (STACKADDBASE NEWSTACK) 0 (LLSH \STK.FX \STK.FLAGS.SHIFT)) (* ; "Clear FX flags") (replace (FX NOPUSH) of NEWSTACK with T) (* ; "When we return to the user context, don't want any value to appear on stack") (LET ((ALINK (+ CALLER \#ALINK.OFFSET))) (* ; "ALINK field for fast case") (COND (SLOWP (* ; "Have to make non-contiguous frame slow. Set each piece manually to avoid redundant computation from the computed record fields") (replace (FX %#BLINK) of NEWSTACK with (fetch (FX DUMMYBF) of NEWSTACK)) (replace (FX %#CLINK) of NEWSTACK with ALINK) (replace (FX %#ALINK) of NEWSTACK with (LOGOR ALINK 1)) (* ; "1 is the slow bit")) (T (replace (FX %#ALINK) of NEWSTACK with ALINK)))) (replace (FX FNHEADER) of NEWSTACK with CODE) (replace (FX PC) of NEWSTACK with (fetch (FNHEADER STARTPC) of CODE))) (LET ((SP (fetch (FX FIRSTPVAR) of NEWSTACK)) (NPVARS (UNFOLD (ADD1 (fetch (FNHEADER PV) of CODE)) CELLSPERQUAD))) (* ;; "Fill in rest of FX") (PROGN (* ; "Initialize PVAR region") (if ENV then (* ; "Set first pvar to closure environment") (\PUTBASEPTR (STACKADDBASE SP) 0 ENV) (add SP WORDSPERCELL) (SETQ NPVARS (SUB1 NPVARS))) (RPTQ NPVARS (PROGN (* ; "Fill in rest of Pvar region with 'unbound'") (\PUTBASE (STACKADDBASE SP) 0 65535) (add SP WORDSPERCELL)))) (PROGN (* ; "Make free block after this frame") (replace (FX NEXTBLOCK) of NEWSTACK with (add SP (fetch (FX PADDING) of NEWSTACK))) (* ; "Need extra junk quad after the pvar region") (CHECK (> STKEND SP)) (\MAKEFREEBLOCK SP (- STKEND SP)) (CHECK (fetch (FX CHECKED) of NEWSTACK)))) (replace (IFPAGE MiscFXP) of \InterfacePage with NEWSTACK))) ) +) + + + +(* ; "recursive interpreter") + +(DEFINEQ + +(EVAL (LAMBDA (U \INTERNAL) (DECLARE (SPECVARS \INTERNAL)) (* lmm "19-AUG-81 23:04") (\EVAL U))) + +(\EVAL (LAMBDA (FORM) (* lmm " 3-NOV-81 15:42") (* ;; "ufn for Interlisp EVAL opcode.") (COND ((LISTP FORM) (\EVALFORM FORM)) ((LITATOM FORM) (\EVALVAR FORM)) ((NUMBERP FORM) FORM) (T (\EVALOTHER FORM)))) ) + +(\EVALFORM (LAMBDA (*FORM* TEMP) (DECLARE (SPECVARS *FORM*) (ADDTOVAR LAMS FAULTEVAL)) (* ; "Edited 29-Jun-87 16:42 by amd") (* ;;; "eval of LISTP") (PROG NIL RETRY (COND ((LITATOM (SETQ TEMP (CAR *FORM*))) (COND ((fetch (LITATOM CCODEP) of TEMP) (SELECTQ (fetch (LITATOM ARGTYPE) of TEMP) (1 (GO NLSPREAD)) (3 (GO NLNOSPREAD)) (GO EVLAM))) (T (* ; "EXPR OR UDF") (SETQ TEMP (fetch (LITATOM DEFPOINTER) of TEMP)))))) (* ; "TEMP is now definition of EXPR") (CL:TYPECASE TEMP ((OR COMPILED-CLOSURE CLOSURE) (* ; "falls out")) (CONS (SELECTQ (CAR TEMP) (NLAMBDA (COND ((OR (LISTP (SETQ TEMP (CADR TEMP))) (NULL TEMP)) (GO NLSPREAD)) (T (GO NLNOSPREAD)))) ((CL:LAMBDA LAMBDA OPENLAMBDA)) (GO FAULT))) (T (GO FAULT))) EVLAM (* ;; "THIS FUNCTION'S DEFINITION VERY DEPENDENT ON THE SPECIAL MACRO IN ALAP FOR COMPILING IT. --- SEE CEVALFORM") (RETURN (PROG ((*ARGVAL* 0) (*TAIL* *FORM*) (*FN* (CAR *FORM*))) (DECLARE (SPECVARS *ARGVAL* *FN* *TAIL*)) (RETURN (.EVALFORM.)))) NLSPREAD (RETURN (SPREADAPPLY (CAR *FORM*) (CDR *FORM*))) NLNOSPREAD (RETURN (SPREADAPPLY* (CAR *FORM*) (CDR *FORM*))) FAULT (COND ((AND CLISPARRAY (LISTP (SETQ TEMP (GETHASH *FORM* CLISPARRAY)))) (SETQ *FORM* TEMP) (GO RETRY))) (RETURN (FAULTEVAL *FORM*)))) ) + +(\EVALFORMASLAMBDA (LAMBDA (FAULTX) (* lmm "29-Apr-86 13:06") (PROG ((*ARGVAL* 0) (*TAIL* FAULTX) (*FN* (CAR FAULTX))) (DECLARE (SPECVARS *ARGVAL* *FN* *TAIL*)) (RETURN (.EVALFORM.)))) ) + +(\EVALOTHER (LAMBDA (X) (* lmm "10-MAY-80 17:03") (* ;; "evaluate some other data type (not atom or list)") (PROG NIL (RETURN (SPREADAPPLY* (CDR (OR (FASSOC (TYPENAME X) \DEFEVALFNS) (RETURN X))) X)))) ) + +(APPLY (LAMBDA (U V \INTERNAL) (DECLARE (SPECVARS \INTERNAL)) (* lmm "15-Aug-84 17:53") (.APPLY. U V))) + +(APPLY* (LAMBDA U (* lmm " 5-Jun-86 03:28") (PROG ((DEF (AND (IGREATERP U 0) (ARG U 1)))) LP (COND ((LITATOM DEF) (COND ((fetch (LITATOM CCODEP) of DEF) (COND ((EQ (fetch (LITATOM ARGTYPE) of DEF) 3) (GO NOSPR)) (T (GO SPR)))) (T (* ; "EXPR") (SETQ DEF (OR (LISTP (fetch (LITATOM DEFPOINTER) of DEF)) (GO FAULT)))))) ((CCODEP DEF) (GO SPR)) ((NLISTP DEF) (GO FAULT))) (SELECTQ (CAR DEF) ((LAMBDA CL:LAMBDA) NIL) (FUNARG (* ; "Ignore environment of funarg? This is obsolete anyway.") (SETQ DEF (CADR DEF)) (GO LP)) (NLAMBDA (COND ((AND (CAR (LISTP (CDR DEF))) (NLISTP (CADR DEF))) (GO NOSPR)))) (OPENLAMBDA) (GO FAULT)) SPR (RETURN (SELECTQ U (1 (* ; "no args") (SPREADAPPLY* (ARG U 1))) (2 (* ; "1 arg") (SPREADAPPLY* (ARG U 1) (ARG U 2))) (3 (* ; "2 args") (SPREADAPPLY* (ARG U 1) (ARG U 2) (ARG U 3))) (4 (* ; "3 args") (SPREADAPPLY* (ARG U 1) (ARG U 2) (ARG U 3) (ARG U 4))) (SPREADAPPLY (ARG U 1) (for I from 2 to U collect (ARG U I))))) FAULT (RETURN (FAULTAPPLY DEF (for I from 2 to U collect (ARG U I)))) NOSPR (* ; "NLAMBDA*") (RETURN (SPREADAPPLY* (ARG U 1) (for I from 2 to U collect (ARG U I)))))) ) + +(\CHECKAPPLY* (LAMBDA (FN) (* bvm%: " 7-Jul-86 17:13") (* ;;; "APPLY* compiles open as: [PUSH each arg, PUSH #args, PUSH FN, CHECKAPPLY*, APPLYFN] CHECKAPPLY* should merely return FN in the case where FN is a LAMBDA or a NLAMBDA spread. The only case it needs to handle special is NLAMBDA nospread.") (PROG ((DEF FN)) (COND ((LITATOM DEF) (COND ((NOT (fetch (LITATOM CCODEP) of DEF)) (* ; "EXPR") (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF))) ((EQ (fetch (LITATOM ARGTYPE) of DEF) 3) (GO NOSPR)) (T (RETURN FN)))) ((AND NIL (TYPEP DEF (QUOTE COMPILED-CLOSURE))) (* ;; "Give a symbol this definition so APPLYFN can call it. This is an utter kludge. It can never work with preemptive scheduling, and even without it is vulnerable to an interrupt between CHECKAPPLY* and APPLYFN") (\PUTD (QUOTE *\CHECKAPPLY*\HACK) DEF) (RETURN (QUOTE *\CHECKAPPLY*\HACK)))) (COND ((AND (LISTP DEF) (EQ (CAR DEF) (QUOTE NLAMBDA)) (LISTP (SETQ DEF (CDR DEF))) (CAR DEF) (NLISTP (CAR DEF))) (GO NOSPR)) (T (RETURN FN))) NOSPR (RETURN (LIST (QUOTE LAMBDA) NIL (LIST (QUOTE QUOTE) (SPREADAPPLY* FN (\CKAPPLYARGS))))))) ) + +(\CKAPPLYARGS (LAMBDA NIL (* lmm "10-NOV-81 22:26") (PROG ((FRAME (fetch (FX ALINK) of (\MYALINK))) ACNT PTR VAL) (SETQ ACNT (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE (fetch (FX NEXTBLOCK) of FRAME) WORDSPERCELL)))) (CHECK (SMALLPOSP ACNT)) (FRPTQ ACNT (push VAL (STACKGETBASEPTR (SETQ PTR (IDIFFERENCE PTR WORDSPERCELL))))) (RETURN VAL))) ) + +(DEFEVAL (LAMBDA (TYPE FN) (* edited%: "13-DEC-78 23:18") (PROG ((F (FASSOC TYPE \DEFEVALFNS))) (COND (F (SETQ \DEFEVALFNS (DREMOVE F \DEFEVALFNS)))) (COND (FN (SETQ \DEFEVALFNS (CONS (CONS TYPE FN) \DEFEVALFNS)))) (RETURN (CDR F)))) ) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS .APPLY. MACRO ((U V) (* body for APPLY, used by RETAPPLY + too) + (PROG ((DEF U)) + LP [COND + ((LITATOM DEF) + (COND + ((NOT (fetch (LITATOM CCODEP) of DEF)) + (* EXPR) + (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF))) + ((EQ (fetch (LITATOM ARGTYPE) of DEF) + 3) + (GO NLSTAR)) + (T (GO NORMAL] + [COND + ((LISTP DEF) + (SELECTQ (CAR DEF) + (NLAMBDA (AND (NLISTP (CADR DEF)) + (CADR DEF) + (GO NLSTAR))) + (FUNARG (SETQ DEF (CADR DEF)) + (GO LP)) + NIL)) + ((NULL DEF) + (RETURN (FAULTAPPLY U V] + NORMAL + (RETURN (SPREADAPPLY U V)) + NLSTAR + (* NLAMBDA*) + (RETURN (SPREADAPPLY* U V] +) +) + + + +(* ; "Free variable manipulation") + +(DEFINEQ + +(EVALV (LAMBDA (VAR POS RELFLG) (* lmm " 6-Apr-84 16:37") (* ;; "EVAL of a LITATOM without uba error") (COND (POS (\SMASHLINK NIL (\STACKARGPTR POS)))) (PROG1 (\EVALV1 VAR) (COND (RELFLG (RELSTK POS))))) ) + +(\EVALV1 (LAMBDA (VAR) (* lmm "24-DEC-81 00:08") (COND ((OR (NULL (\DTEST VAR (QUOTE LITATOM))) (EQ VAR T)) VAR) (T (\GETBASEPTR (\STKSCAN VAR) 0)))) ) + +(\EVALVAR (LAMBDA (VAR) (* ; "Edited 30-Jan-87 13:28 by Pavel") (* ;; "EVAL of a LITATOM") (COND ((OR (NULL VAR) (EQ VAR T)) VAR) (T (LET ((VP (\STKSCAN VAR)) VAL) (COND ((EQ (SETQ VAL (\GETBASEPTR VP 0)) (QUOTE NOBIND)) (* ; "Value is NOBIND, even if it was not found as the top-level value. This is consistent with BOUNDP.") (FAULTEVAL VAR)) (T VAL)))))) ) + +(BOUNDP (CL:LAMBDA (CL::VAR) (* ; "Edited 30-Jan-87 16:59 by Pavel") (* ;; "True if VAR is bound or has top level value") (AND (CL:SYMBOLP CL::VAR) (NOT (EQ (\GETBASEPTR (\STKSCAN CL::VAR) 0) (QUOTE NOBIND))))) ) + +(SET (LAMBDA (VAR VALUE) (* lmm "24-FEB-82 16:11") (COND ((NULL VAR) (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE))) (T (PROG ((VP (\STKSCAN (\DTEST VAR (QUOTE LITATOM))))) (COND ((EQ (\HILOC VP) \STACKHI) (\PUTBASEPTR VP 0 VALUE)) ((EQ VAR T) (OR (EQ VALUE T) (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE))) (T (\RPLPTR VP 0 VALUE))) (RETURN VALUE))))) ) + +(\SETVAR (LAMBDA (VAR VALUE) (* lmm "24-FEB-82 16:11") (COND ((NULL VAR) (AND VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE))) (T (PROG ((VP (\STKSCAN (\DTEST VAR (QUOTE LITATOM))))) (COND ((EQ (\HILOC VP) \STACKHI) (\PUTBASEPTR VP 0 VALUE)) ((EQ VAR T) (OR (EQ VALUE T) (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE))) (T (\RPLPTR VP 0 VALUE))) (RETURN VALUE))))) ) + +(SETQ [NLAMBDA U (* lmm "24-DEC-81 00:19") (\SETVAR (CAR U) (PROG ((*TAIL* (CDR U))) (DECLARE (SPECVARS *TAIL*)) (RETURN (PROG1 (\EVAL (CAR *TAIL*)) [PROG NIL (* ;  "(SETQ X Y + 3) must try to eval + in order to get dwim involved.") LP (COND ((LISTP (SETQ *TAIL* (CDR *TAIL*))) (\EVAL (CAR *TAIL*)) (GO LP])]) + +(\STKSCAN [LAMBDA (VAR) (* ; "Edited 27-Jan-91 14:48 by jds") (* ;; "Returns pointer to place where VAR is bound") (PROG ((FX (fetch (FX ALINK) of (\MYALINK))) (ATOM# (\ATOMVALINDEX VAR)) NTSIZE A VARINFO PVAROFFSET NT FVAR) FRAMELP [COND ((fetch (FX INVALIDP) of FX) (* ;  "Reached top of stack without finding a binding") (RETURN (fetch (VALINDEX VCELL) of ATOM#] (SETQ NT (fetch (FX NAMETABLE) of FX)) (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT)) (SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T))) TABLELP [COND ((EQP (SETQ A (GETNAMEENTRY NT 0)) 0) (* ; "End of name table") (GO ENDTABLE)) ((EQP A ATOM#) (* ;  "Found ATOM#. See if it is really bound here") (SELECTC (NTSLOT-VARTYPE (SETQ VARINFO (GETNTOFFSETENTRY NT NTSIZE))) (IVARCODE (* ; "Is bound in BF") (* ; "IVAR") [RETURN (STACKADDBASE (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO)) WORDSPERCELL) (fetch (BF IVAR) of (fetch (FX BLINK) of FX]) (PVARCODE (* ;  "Local may or may not be bound yet") (SETQ PVAROFFSET (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO)) WORDSPERCELL) (fetch (FX FIRSTPVAR) of FX))) [COND ((fetch (PVARSLOT BOUND) of (STACKADDBASE PVAROFFSET)) (* ; "PVAR") (RETURN (STACKADDBASE PVAROFFSET]) (FVARCODE (* ;  "If FVAR is looked up, we can use it.") [SETQ FVAR (ADDSTACKBASE (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO)) WORDSPERCELL) (fetch (FX FIRSTPVAR) of FX] (COND ((fetch (FVARSLOT LOOKEDUP) of FVAR) (SETQ FVAR (fetch (FVARSLOT BINDINGPTR) of FVAR)) (RETURN FVAR)) (T (GO ENDTABLE)))) (SHOULDNT] [SETQ NT (\ADDBASE NT (CONSTANT (WORDSPERNAMEENTRY] (GO TABLELP) ENDTABLE (SETQ FX (fetch (FX ALINK) of FX)) (GO FRAMELP]) + +(\SETFVARSLOT [LAMBDA (VAR NEWBINDING) (* ; "Edited 20-Feb-91 01:07 by jds") (* ;; "Sets the freevar binding slot of VAR in caller's frame to point at NEWBINDING") (PROG ((FX (\MYALINK)) (ATOM# (NEW-SYMBOL-CODE VAR (\ATOMVALINDEX VAR))) NTSIZE A VARINFO NT) (SETQ NT (fetch (FX NAMETABLE) of FX)) (SETQ NTSIZE (fetch (FNHEADER NTSIZE) of NT)) (SETQ NT (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T))) TABLELP (COND ((NULL-NTENTRY (SETQ A (GETSTKNAMEENTRY NT 0))) (* ; "End of name table") (ERROR "Binding slot not found in caller's frame" VAR)) ((AND (EQP A ATOM#) (EQP (NTSLOT-VARTYPE (SETQ VARINFO (GETSTKNTOFFSETENTRY NT NTSIZE))) FVARCODE)) (replace (FVARSLOT BINDINGPTR) of (ADDSTACKBASE (IPLUS (UNFOLD (\LOLOC (NTSLOT-OFFSET VARINFO)) WORDSPERCELL) (fetch (FX FIRSTPVAR) of FX))) with NEWBINDING) (RETURN NEWBINDING))) [SETQ NT (\ADDBASE NT (CONSTANT (WORDSPERNAMEENTRY] (GO TABLELP]) +) + + + +(* ; "PROG and friends") + +(DEFINEQ + +(PROG [NLAMBDA U (* ; "Edited 21-Jan-91 18:33 by jds") (* ;; "PROG unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value") (* ;; "NOTE --- this mechanism might confuse DWIM someday because the arguments inside the PROG are evaluated at a time when the PROG frame is in a very funny state: the 'values' are the variables, and the variables are NIL") (PROG ((NVARS 0) (VARLST (CAR U)) NTSIZE NNILS) (for VAR in VARLST do (* ;  "Count number of vars to bind, check validity") (COND ((OR (NULL (\DTEST (COND ((LISTP VAR) (SETQ VAR (CAR VAR))) (T VAR)) 'LITATOM)) (EQ VAR T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR))) (add NVARS 1)) (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\PROG0 U U NNILS NVARS NTSIZE VARLST]) + +(\PROG0 [LAMBDA (*FIRSTTAIL* *TAIL* NNILS NVARS NTSIZE VARLST) (* ; "Edited 27-Jan-91 14:32 by jds") (DECLARE (SPECVARS *TAIL* *FIRSTTAIL*)) (PROG NIL [COND (VARLST (* ;; "Create a nametable inside progframe where PROG pushed all those nils") (PROG ((PROGFRAME (\MYALINK)) HEADER NT NILSTART) (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME)) (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK) of PROGFRAME) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") [for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL do (* ; "evaluate initial values first") (COND ((LISTP VAR) (PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR] (* ; "then build NT") (UNINTERRUPTABLY (for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of PROGFRAME)) WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (WORDSPERNAMEENTRY) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND ((LISTP VAR) (CAR VAR)) (T VAR] (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)) (replace (FNHEADER %#FRAMENAME) of NT with 'PROG) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (* ;  "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ? --- no") (replace (FX NAMETABLE) of PROGFRAME with NT))] EVLP (COND ((NULL (SETQ *TAIL* (CDR *TAIL*))) (RETURN NIL)) (T (\EVAL (OR (LISTP (CAR *TAIL*)) (GO EVLP))) (GO EVLP]) + +(\EVPROG1 (LAMBDA (*TAIL*) (* lmm "14-MAY-80 13:00") (DECLARE (SPECVARS *TAIL*)) (PROG1 (\EVAL (CAR *TAIL*)) (PROG NIL LP (COND ((LISTP (SETQ *TAIL* (CDR *TAIL*))) (\EVAL (CAR *TAIL*)) (GO LP)))))) ) + +(RETURN (NLAMBDA (FORM) (DECLARE (LOCALVARS . T)) (* bvm%: "10-Nov-86 18:22") (PROG ((MV (CL:MULTIPLE-VALUE-LIST (\EVAL FORM))) (FRAME (\MYALINK))) LP (COND ((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME)) (FUNCTION \PROG0)) (SETQ FRAME (fetch (FX CLINK) of FRAME)) (* ; "Its caller, i.e. PROG") (\SMASHRETURN NIL FRAME) (* ; "Make us return to PROG with this value") (RETURN (CL:VALUES-LIST MV))) ((NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME)))) (GO LP)) (T (LISPERROR "ILLEGAL RETURN"))))) ) + +(GO (NLAMBDA U (* bvm%: "10-Nov-86 18:17") (PROG ((FRAME (\MYALINK)) (LABEL (CAR U)) GOTAIL FIRSTARG) LP (COND ((EQ (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE) of FRAME)) (FUNCTION \PROG0)) (COND ((SETQ GOTAIL (FMEMB LABEL (CDR (STACKGETBASEPTR (SETQ FIRSTARG (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME))))))) (* ;; "first argument of \PROG0 is the actual tail of the prog, which can contain the labels. Second argument is the 'current' *TAIL*") (STACKPUTBASEPTR (IPLUS FIRSTARG WORDSPERCELL) GOTAIL) (* ; "Reset *TAIL* in the \PROG0 frame") (\SMASHRETURN NIL FRAME) (* ; "Fix it so we return to \PROG0 to continue evaluating after label") (RETURN NIL))))) (COND ((NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME)))) (GO LP)) (T (LISPERROR "UNDEFINED OR ILLEGAL GO" LABEL))))) ) + +(EVALA [LAMBDA (X A) (* ; "Edited 21-Jan-91 18:13 by jds") (* ;;; "Evaluate X after spreading alist A on stack") (PROG ((NVARS 0) NTSIZE NNILS TMP) (for VAR in A do (* ;  "Count number of vars to bind, check validity") (COND ((OR [NULL (SETQ TMP (\DTEST (CAR (\DTEST VAR 'LISTP)) 'LITATOM] (EQ TMP T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" TMP))) (add NVARS 1)) (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\EVALA NNILS NVARS NTSIZE X A]) + +(\EVALA [LAMBDA (NNILS NVARS NTSIZE FORM ALIST) (* ; "Edited 27-Jan-91 16:39 by jds") (PROG ((CALLER (\MYALINK)) NILSTART NT HEADER) (* ;; "Create a nametable inside CALLER where EVALA pushed all those nils") (SETQ HEADER (fetch (FX FNHEADER) of CALLER)) (* ;  "The function header of code for EVALA") (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK) of CALLER) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "Address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") (UNINTERRUPTABLY (for PAIR in ALIST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of CALLER)) WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (WORDSPERNAMEENTRY) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) as VALUEOFF from NILSTART by WORDSPERCELL do (PUTBASEPTR \STACKSPACE VALUEOFF (CDR PAIR)) (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (CAR PAIR))) (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)) (* ;; "now fix up header of NT") (replace (FNHEADER %#FRAMENAME) of NT with 'EVALA) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (* ;  "Do I need to worry about STK, NA, PV, START, ARGTYPE ? --- probably not") (replace (FX NAMETABLE) of CALLER with NT)) (RETURN (\EVAL FORM]) + +(ERRORSET (LAMBDA (FORM FLAG) (* ; "Edited 6-Mar-87 14:39 by amd") (* ;; "(proceed-case (handler-bind ...)), but open-coded to aviod a proceed-case literal") (LET (SI::NLSETQ-VALUE) (CL:IF (EQ (LET ((*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*)) (SI::*NLSETQFLAG* (NEQ FLAG T)) (*CONDITION-HANDLER-BINDINGS* (CL:IF FLAG *CONDITION-HANDLER-BINDINGS* (CONS (QUOTE (CL:ERROR . SI::NLSETQHANDLER)) *CONDITION-HANDLER-BINDINGS*)))) (DECLARE (SPECVARS SI::*NLSETQFLAG*)) (CL:CATCH *PROCEED-CASES* (CL:SETQ SI::NLSETQ-VALUE (LIST (\EVAL FORM))) :NORMAL)) :NORMAL) SI::NLSETQ-VALUE NIL))) ) + +(SI::ERRORSET-PRINT-FUNCTION (LAMBDA (DATUM STREAM) (DECLARE (IGNORE DATUM)) (* bvm%: "11-Nov-86 21:40") (PRIN1 "Unwind to ERRORSET" STREAM)) ) +) + + + +(* ; "LET and friends -- need these in the init") + +(DEFINEQ + +(LET [NLAMBDA U (DECLARE (LOCALVARS . T)) (* ; "Edited 21-Jan-91 18:14 by jds") (* ;; "LET unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value") (LET ((NVARS 0) (VARLST (CAR U)) NTSIZE NNILS) (for VAR in VARLST do (* ;  "Count number of vars to bind, check validity") (COND ((OR (NULL (\DTEST (COND ((LISTP VAR) (SETQ VAR (CAR VAR))) (T VAR)) 'LITATOM)) (EQ VAR T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR))) (add NVARS 1)) (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\LET0 (CDR U) NNILS NVARS NTSIZE VARLST]) + +(LET* [NLAMBDA U (DECLARE (LOCALVARS . T)) (* ; "Edited 21-Jan-91 23:02 by jds") (* ;; "LET* unpacks the argument list and changes any EVAL type forms by evaluating the form and then smashing the name and value") (LET* ((NVARS 0) (VARLST (CAR U)) NTSIZE NNILS) (for VAR in VARLST do (* ;  "Count number of vars to bind, check validity") (COND ((OR (NULL (\DTEST (COND ((LISTP VAR) (SETQ VAR (CAR VAR))) (T VAR)) 'LITATOM)) (EQ VAR T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR))) (add NVARS 1)) (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\LET* (CDR U) NNILS NVARS NTSIZE VARLST]) + +(\LET0 [LAMBDA (*TAIL* NNILS NVARS NTSIZE VARLST) (DECLARE (LOCALVARS . T) (SPECVARS *TAIL*)) (* ; "Edited 27-Jan-91 14:35 by jds") (PROG NIL [COND (VARLST (PROG ((PROGFRAME (\MYALINK)) HEADER NT NILSTART) (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME)) (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK ) of PROGFRAME) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") [for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL do (* ; "evaluate initial values first") (COND ((LISTP VAR) (PUTBASEPTR \STACKSPACE VALUEOFF (\EVPROG1 (CDR VAR] (* ; "then build NT") (UNINTERRUPTABLY (for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of PROGFRAME)) WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND ((LISTP VAR) (CAR VAR)) (T VAR] (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)) (replace (FNHEADER %#FRAMENAME) of NT with 'LET) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (* ;  "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ? --- no") (replace (FX NAMETABLE) of PROGFRAME with NT))] EVLP (COND [(NULL (CDR *TAIL*)) (RETURN (\EVAL (CAR *TAIL*] (T (\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO EVLP]) + +(\LET* [LAMBDA (*TAIL* NNILS NVARS NTSIZE VARLST) (DECLARE (LOCALVARS . T) (SPECVARS *TAIL*)) (* ; "Edited 27-Jan-91 14:37 by jds") (PROG NIL [COND (VARLST (PROG ((PROGFRAME (\MYALINK)) HEADER NT NILSTART) (SETQ HEADER (fetch (FX FNHEADER) of PROGFRAME)) (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK ) of PROGFRAME) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") (* ;; "First build the nametable. This differs from LET in that the nametable is built in reverse order and the PVARs are marked unbound before we start evaluating the forms. This way, we get the right semantics of nested LET's.") (UNINTERRUPTABLY (FOR VAR IN VARLST AS VAR# FROM (FOLDLO (IDIFFERENCE NILSTART (FETCH (FX FIRSTPVAR) OF PROGFRAME)) WORDSPERCELL) AS VALUEOFF FROM NILSTART BY WORDSPERCELL AS NT1 FROM (IPLUS (UNFOLD (SUB1 NVARS) (CONSTANT (WORDSPERNAMEENTRY))) (FETCH (FNHEADER OVERHEADWORDS) OF T)) BY (IMINUS (CONSTANT (WORDSPERNAMEENTRY))) AS NT2 FROM (IPLUS (UNFOLD (SUB1 NVARS) (CONSTANT (WORDSPERNAMEENTRY))) (FETCH (FNHEADER OVERHEADWORDS) OF T) NTSIZE) BY (IMINUS (CONSTANT ( WORDSPERNTOFFSETENTRY ))) DO [SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX (COND ((LISTP VAR) (CAR VAR)) (T VAR] (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#) (PUTBASE \STACKSPACE VALUEOFF 65535)) (replace (FNHEADER %#FRAMENAME) of NT with 'LET*) (REPLACE (FNHEADER NTSIZE) OF NT WITH NTSIZE) (* ;  "Do I need to worry about STK, NA, PV, START, ARGTYPE NLOCALS ? --- no") (REPLACE (FX NAMETABLE) OF PROGFRAME WITH NT)) (FOR VAR IN VARLST AS VALUEOFF FROM NILSTART BY WORDSPERCELL DO (* ; "evaluate initial values first") (PUTBASEPTR \STACKSPACE VALUEOFF (IF (LISTP VAR) THEN (\EVPROG1 (CDR VAR)) ELSE NIL] EVLP (COND [(NULL (CDR *TAIL*)) (RETURN (\EVAL (CAR *TAIL*] (T (\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO EVLP]) +) +(DEFINEQ + +(QUOTE (NLAMBDA U (CAR U))) + +(AND (NLAMBDA U (DECLARE (SPECVARS *TAIL*)) (OR (NLISTP U) (PROG ((*TAIL* U)) LP (RETURN (COND ((NLISTP (CDR *TAIL*)) (\EVAL (CAR *TAIL*))) ((\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO LP))))))) ) + +(OR (NLAMBDA U (DECLARE (SPECVARS *TAIL*)) (* lmm " 9-May-86 13:45") (AND (LISTP U) (PROG ((*TAIL* U)) LP (RETURN (COND ((NLISTP (CDR *TAIL*)) (\EVAL (CAR *TAIL*))) (T (OR (\EVAL (CAR *TAIL*)) (PROGN (SETQ *TAIL* (CDR *TAIL*)) (GO LP))))))))) ) + +(PROGN (NLAMBDA U (* ; "MUST be a NLAMBDA* with internal call to EVAL for dwimsake") (DECLARE (SPECVARS *TAIL*)) (AND (LISTP U) (PROG ((*TAIL* U)) LP (COND ((NLISTP (CDR *TAIL*)) (RETURN (\EVAL (CAR *TAIL*)))) (T (\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO LP)))))) ) + +(COND (NLAMBDA U (DECLARE (SPECVARS *TAIL*)) (* lmm "25-APR-80 18:03") (PROG ((*TAIL* U) VAL) LP (RETURN (COND ((NLISTP *TAIL*) (COND (*TAIL* (LISPERROR "UNUSUAL CDR ARG LIST" *TAIL*)) (T NIL))) ((SETQ VAL (\EVAL (CAAR *TAIL*))) (COND ((CDAR *TAIL*) (\EVPROGN (CDAR *TAIL*))) (T VAL))) (T (SETQ *TAIL* (CDR *TAIL*)) (GO LP)))))) ) + +(\EVPROGN (LAMBDA (*TAIL*) (* lmm "18-Feb-86 01:44") (DECLARE (SPECVARS *TAIL*)) (PROG NIL LP (COND ((CDR *TAIL*) (\EVAL (CAR *TAIL*)) (SETQ *TAIL* (CDR *TAIL*)) (GO LP)) (T (RETURN (\EVAL (CAR *TAIL*))))))) ) + +(PROG1 (NLAMBDA U (DECLARE (SPECVARS *TAIL*)) (* lmm "14-MAY-80 12:59") (AND (LISTP U) (PROG ((*TAIL* U)) (RETURN (PROG1 (\EVAL (CAR *TAIL*)) (PROG NIL LP (COND ((LISTP (SETQ *TAIL* (CDR *TAIL*))) (\EVAL (CAR *TAIL*)) (GO LP))))))))) ) +) + +(RPAQQ \DEFEVALFNS NIL) + +(RPAQQ \EVALHOOK NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(SPECVARS *EVALHOOK*) +) + +(ADDTOVAR LAMBDASPLST LAMBDA NLAMBDA CL:LAMBDA OPENLAMBDA) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \DEFEVALFNS \EVALHOOK LAMBDASPLST CLISPARRAY) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQQ CLISPARRAY NIL) + + +(MOVD? 'SETQ 'SETN NIL T) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS CLISPARRAY) +) + + + +(* ; "Evaluating in different stack environment") + +(DEFINEQ + +(ENVEVAL (LAMBDA (FORM APOS CPOS AFLG CFLG) (* bvm%: "18-AUG-81 23:29") (\CALLME (QUOTE *ENV*)) (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS)) (AND CPOS (\STACKARGPTR CPOS))) (COND (AFLG (RELSTK APOS))) (COND (CFLG (RELSTK CPOS))) (\EVAL FORM)) ) + +(ENVAPPLY (LAMBDA (FN ARGS APOS CPOS AFLG CFLG) (* lmm "15-Aug-84 17:53") (\CALLME (QUOTE *ENV*)) (\SMASHLINK NIL (AND APOS (\STACKARGPTR APOS)) (AND CPOS (\STACKARGPTR CPOS))) (COND (AFLG (RELSTK APOS))) (COND (CFLG (RELSTK CPOS))) (.APPLY. FN ARGS)) ) + +(FUNCTION (NLAMBDA (FN ENV) (* bvm%: "11-Nov-86 21:23") (COND (ENV (if NIL then (LIST (QUOTE FUNARG) FN (STKNTH -1 (QUOTE FUNCTION))) else (ERROR "FUNARGs no longer supported--use Common Lisp lexical closures" FN))) (T FN))) ) + +(\FUNCT1 [LAMBDA (NNILS NVARS NTSIZE VARLST) (* ; "Edited 27-Jan-91 14:39 by jds") (PROG ((FUNCTFRAME (\MYALINK)) HEADER NT NILSTART) (SETQ HEADER (fetch (FX FNHEADER) of FUNCTFRAME)) (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK) of FUNCTFRAME) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "NT is address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword") (for VAR in VARLST as VALUEOFF from NILSTART by WORDSPERCELL do (\PUTBASEPTR (ADDSTACKBASE VALUEOFF) 0 (\EVAL VAR))) (* ; "then build NT") (UNINTERRUPTABLY (for VAR in VARLST as VAR# from (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of FUNCTFRAME)) WORDSPERCELL) as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT ( WORDSPERNAMEENTRY )) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR)) (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#)) (replace (FNHEADER %#FRAMENAME) of NT with '*FUNARG*) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (replace (FX NAMETABLE) of FUNCTFRAME with NT)) (RETURN (\MAKESTACKP NIL FUNCTFRAME]) + +(\MAKEFUNARGFRAME [LAMBDA (ENV) (* ; "Edited 21-Jan-91 18:19 by jds") (\CALLME 'FUNARG) (PROG ((NVARS 0) NTSIZE NNILS) (for VAR in ENV do (* ;  "Count number of vars to bind, check validity") (COND ((OR (NULL (\DTEST VAR 'LITATOM)) (EQ VAR T)) (LISPERROR "ATTEMPT TO BIND NIL OR T" VAR))) (add NVARS 1)) (SETQ ENV (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS ) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\FUNCT1 NNILS NVARS NTSIZE ENV))) (* ;  "ENV POINTS TO COPY OF FUNCTION FRAME") (\SMASHLINK (fetch (STACKP EDFXP) of ENV) 0 0) (RETURN ENV]) + +(STKEVAL (LAMBDA (POS FORM FLG INTERNALFLG) (* lmm "25-APR-80 00:08") (\SMASHLINK NIL (\STACKARGPTR POS)) (AND FLG (RELSTK POS)) (\EVAL FORM)) ) + +(STKAPPLY (LAMBDA (POS FN ARGS FLG) (* lmm "15-Aug-84 17:55") (\CALLME (QUOTE *ENV*)) (\SMASHLINK NIL (\STACKARGPTR POS)) (AND FLG (RELSTK POS)) (.APPLY. FN ARGS)) ) + +(RETEVAL (LAMBDA (POS FORM FLG INTERNALFLG) (* bvm%: "11-Nov-86 20:53") (* ;; "Return from POS with the value of evaluating FORM in the dynamic context of POS") (* ;; "Anyone know what INTERNALFLG is for?") (\CALLME (QUOTE *ENV*)) (LET ((FX (\STACKARGPTR POS)) RETURNEE) (if (fetch (FX INVALIDP) of (SETQ RETURNEE (fetch (FX CLINK) of FX))) then (LISPERROR "ILLEGAL STACK ARG" POS)) (\SMASHRETURN NIL FX) (* ; "unwind stack back to POS--we need to keep that dynamic environment") (AND FLG (RELSTK POS)) (CL:MULTIPLE-VALUE-PROG1 (\EVAL FORM) (* ; "finally, return from POS") (SI::UNWIND RETURNEE)))) ) + +(RETAPPLY (LAMBDA (POS FN ARGS FLG) (* bvm%: "11-Nov-86 12:04") (* ;; "Return from POS with the value of applying FN to ARGS in the dynamic context of POS") (\CALLME (QUOTE *ENV*)) (LET ((FX (\STACKARGPTR POS)) RETURNEE) (if (fetch (FX INVALIDP) of (SETQ RETURNEE (fetch (FX CLINK) of FX))) then (LISPERROR "ILLEGAL STACK ARG" POS)) (\SMASHRETURN NIL FX) (* ; "unwind stack back to POS--we need to keep that dynamic environment") (AND FLG (RELSTK POS)) (CL:MULTIPLE-VALUE-PROG1 (.APPLY. FN ARGS) (* ; "finally, return from POS") (SI::UNWIND RETURNEE)))) ) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MOVD? 'FUNCTION 'CL:FUNCTION NIL T) +) + + + +(* ; "Blip and other stack funniness") + +(DEFINEQ + +(BLIPVAL [LAMBDA (BLIPTYP IPOS FLG) (* ; "Edited 18-Feb-91 16:48 by jds") (PROG ([FRAME (COND ((NULL IPOS) (\MYALINK)) (T (\STACKARGPTR IPOS] (A (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP))) I) (SELECTQ BLIPTYP ((*TAIL* *FORM* *FN* *ARGVAL*)) (RETURN (AND (EQ FLG T) 0))) (RETURN (COND ((EQ FLG T) (* ;  "Count number of blips of type BLIPTYP at FRAME") (COND ((NOT (SETQ I (\VAROFFSET FRAME A))) 0) ((EQ BLIPTYP '*ARGVAL*) (* ;  "the value of *ARGVAL* is the number of *ARGVAL* blips in this frame") (OR (\GETBASEPTR \STACKSPACE I) 0)) (T 1))) (T (PROG NIL (OR FLG (SETQ FLG 1)) FRAMELP [COND ((SETQ I (\VAROFFSET FRAME A)) (SELECTQ BLIPTYP (*ARGVAL* [COND ((IGREATERP FLG (SETQ I (OR (\GETBASEPTR \STACKSPACE I) 0))) (* ; "Fewer blips here than FLG") (SETQ FLG (IDIFFERENCE FLG I))) (T (* ;  "Scan the temporary region for the value of the FLG'th *ARGVAL* blip") (RETURN (PROG ((NXT (fetch (FX NEXTBLOCK) of FRAME)) (P (fetch (FX FIRSTTEMP) of FRAME))) LP (CHECK (ILESSP P NXT)) [COND ((EQ (\GETBASEPTR \STACKSPACE P) '*ARGVAL*) (* ;; "\EVALFORM pushes the atom *ARGVAL*, then each argument. We want the FLG'th arg, counting from the end backwards") (add P (UNFOLD (ADD1 (IDIFFERENCE I FLG)) WORDSPERCELL)) (CHECK (ILESSP P NXT)) (RETURN (\GETBASEPTR \STACKSPACE P] (add P WORDSPERCELL) (GO LP]) (COND ((ILESSP (SETQ FLG (SUB1 FLG)) 1) (RETURN (\GETBASEPTR \STACKSPACE I] NEXT (COND ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME] (GO FRAMELP]) + +(SETBLIPVAL [LAMBDA (BLIPTYP IPOS N VAL) (* ; "Edited 18-Feb-91 16:49 by jds") (PROG ([FRAME (COND ((NULL IPOS) (\MYALINK)) (T (\STACKARGPTR IPOS] (A (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP))) I) (SELECTQ BLIPTYP ((*TAIL* *FORM* *FN* *ARGVAL*)) (RETURN)) (COND ((NOT N) (SETQ N 1)) ((ILESSP N 1) (\ILLEGAL.ARG N))) FRAMELP [COND ((SETQ I (\VAROFFSET FRAME A)) (SELECTQ BLIPTYP (*ARGVAL* [COND ((NOT (SETQ I (\GETBASEPTR \STACKSPACE I))) (* ; "No argvals") ) ((IGREATERP N I) (SETQ N (IDIFFERENCE N I))) (T (* ;  "Scan the temporary region for the value of the Nth *ARGVAL* blip") (RETURN (PROG ((NXT (fetch (FX NEXTBLOCK) of FRAME)) (P (fetch (FX FIRSTTEMP) of FRAME))) LP (CHECK (ILESSP P NXT)) [COND ((EQ (\GETBASEPTR \STACKSPACE P) '*ARGVAL*) (* ;  "\EVALFORM pushes the atom *ARGVAL*, then each argument. We want the N'th arg from the end") (add P (UNFOLD (ADD1 (IDIFFERENCE I N)) WORDSPERCELL)) (CHECK (ILESSP P NXT)) (RETURN (\PUTBASEPTR \STACKSPACE P VAL] (add P WORDSPERCELL) (GO LP]) (COND ((ILESSP (SETQ N (SUB1 N)) 1) (* ;  "All other blip types are just the value of the blip binding") (RETURN (\PUTBASEPTR \STACKSPACE I VAL] (COND ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME] (GO FRAMELP]) + +(BLIPSCAN [LAMBDA (BLIPTYP IPOS) (* ; "Edited 18-Feb-91 16:50 by jds") (PROG ([FRAME (COND ((NULL IPOS) (\MYALINK)) (T (\STACKARGPTR IPOS] OFF A) (SETQ A (SELECTQ BLIPTYP ((*FORM* *TAIL* *FN* *ARGVAL*) (NEW-SYMBOL-CODE BLIPTYP (\ATOMVALINDEX BLIPTYP))) (RETURN))) LP (COND ([AND (SETQ OFF (\VAROFFSET FRAME A)) (NOT (AND (EQ BLIPTYP '*ARGVAL*) (NULL (GETBASEPTR \STACKSPACE OFF] (RETURN (\MAKESTACKP NIL FRAME))) ([NOT (fetch (FX INVALIDP) of (SETQ FRAME (fetch (FX CLINK) of FRAME] (GO LP)) (T (RETURN]) +) +(DEFINEQ + +(\REALFRAMEP (LAMBDA (FRAME INTERPFLG) (* lmm " 7-Nov-86 01:53") (LET ((NAME (fetch (FNHEADER FRAMENAME) of (fetch (FX FNHEADER) of FRAME))) BFLINK) (* ;; "note that the selection is on the fnheader's name rather than the nametable name. \REALFRAMEP is thus not affected by SETSTKNAME") (AND (CL:SYMBOLP NAME) (SELECTQ NAME (*ENV* (* ; "*ENV* is used by ENVEVAL etc.") NIL) (\INTERPRETER T) (ERRORSET (NEQ (\STKARG 2 FRAME) (QUOTE INTERNAL))) ((EVAL APPLY) (\SMASHLINK NIL FRAME) (SELECTQ \INTERNAL ((INTERNAL SELECTQ) NIL) T)) (OR (NOT (LITATOM NAME)) (COND ((FMEMB NAME OPENFNS) INTERPFLG) (T (OR (NEQ (CHCON1 NAME) (CHARCODE \)) (EXPRP NAME) (FASSOC NAME BRKINFOLST))))))))) ) +) + +(RPAQ? OPENFNS + '(APPLY* SETQ AND OR COND SELECTQ PROG PROGN PROG1 ARG SETARG ERSETQ NLSETQ RESETFORM RESETLST + RESETVARS RPTQ SAVESETQ SETN UNDONLSETQ XNLSETQ)) + +(RPAQQ \BLIPNAMES (*TAIL* *FORM* *FN* *ARGVALS*)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BRKINFOLST) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \BLIPNAMES OPENFNS) +) +(DEFINEQ + +(RAIDCOMMAND (LAMBDA NIL (* lmm "18-Mar-86 09:52") (DECLARE (USEDFREE ROOTFRAME ALINKS? RAIDIX FRAME# VPRINTLEVEL)) (FRESHLINE T) (PROG (CMD) (SELECTQ (ALLOCAL (SETQ CMD (ASKUSER NIL NIL "@" (QUOTE ((Q "uit [confirm]" CONFIRMFLG T) (% "^N - remote return [confirm]" NOECHOFLG T CONFIRMFLG T RETURN (QUOTE ^N)) (L "isp stack ") (% "Lisp stack " NOECHOFLG T EXPLAINSTRING "^L -- Lisp stack from arbitrary frame or context" RETURN (QUOTE ^L)) (F "rame ") (% "Next frame " EXPLAINSTRING "LF - next frame" RETURN (QUOTE LF)) (^ " Previous frame ") (A "tom top-level value of atom: ") (D "efinition for atom: ") (P "roperty list for atom: ") (V " -- show object at Virtual address: ") (B "lock of storage starting at address: ") (S "how raw stack from address: ") (C "ode for function:") (% "Basic frame at: " EXPLAINSTRING "^F - print basic frame at octal address" RETURN (QUOTE ^F)) (% "frame extension at: " EXPLAINSTRING "^X - print frame extension at octal address" RETURN (QUOTE ^X)) (W "alk stack blocks starting at: ") (K "" EXPLAINSTRING "K -- Set linKtype for stack ops") (_ " Set word at address: ") (% " Set value of atom " EXPLAINSTRING "^V -- Set value of atom" RETURN (QUOTE ^V)) (% "atom number for atom: " EXPLAINSTRING "^O - look up atom" RETURN (QUOTE ^O)) (Z "Zap Print level to: ") (I "nspect InterfacePage [confirm]" CONFIRMFLG T) (U " -- Show remote screen [confirm]" CONFIRMFLG T) (" " "" RETURN NIL) (% " Enter Lisp " EXPLAINSTRING "^Y -- Enter Lisp" RETURN (QUOTE ^Y)))) T))) (^N (RETURN (QUOTE RETURN))) (Q (TERPRI T) (RETURN (QUOTE QUIT))) (NIL) (A (PRINCOPY (GETTOPVAL (READATOM)))) (P (PRINCOPY (GETPROPLIST (READATOM)))) (C (PRINTCODE (READATOM) T RAIDIX)) (V (PRINCOPY (READVA))) (B (PRINTADDRS (READVA) (READOCT " for (number of words): "))) (S (PRINTADDRS (ADDSTACKBASE (READOCT)) (READOCT " for (number of words): "))) (D (PRINTADDRS (fetch (LITATOM DEFINITIONCELL) of (READATOM)) 2)) (^O (PRINTNUM |.I2| (\ATOMVALINDEX (READATOM)) T)) (^V (PROG ((ATM (READATOM))) (printout T " to be ") (SETTOPVAL ATM (READ T T)))) ((L ^L) (RAIDSTACKCMD CMD)) (F (RAIDSHOWFRAME (SETQ FRAME# (PROG1 (READ T T) (READC T))))) (LF (OR FRAME# (SETQ FRAME# 0)) (printout T "(" |.I1| (add FRAME# 1) ")" T) (RAIDSHOWFRAME FRAME#)) (^ (COND ((OR (NULL FRAME#) (ILEQ FRAME# 1)) (printout T "No previous frame" T)) (T (printout T "(" |.I1| (add FRAME# -1) ")" T) (RAIDSHOWFRAME FRAME#)))) (^F (\PRINTBF (READOCT) NIL (FUNCTION PRINCOPY))) (Z (ALLOCAL (LET ((A (PROG1 (READ T T) (READC T))) (D (PROG1 (READ T T) (READC T)))) (COND ((AND (FIXP A) (FIXP D)) (SETQ VPRINTLEVEL (CONS A D))) (T (PRINTOUT T "Must be two integers, car level then cdr level" T) (ERROR!)))))) (W (SHOWSTACKBLOCKS (COND ((EQ (PEEKC T) (QUOTE % )) (READC T) (fetch (IFPAGE StackBase) of \InterfacePage)) (T (READOCT))))) (^X (\PRINTFRAME (READOCT) (QUOTE PRINCOPY))) (^Y (TERPRI T) (USEREXEC (QUOTE :%:))) (K (SETQ ALINKS? (EQ (ASKUSER NIL NIL " Set link type for stack operations to " (QUOTE ((A "links ") (C "links "))) T) (QUOTE A)))) (_ (PROG ((VA (READVA))) (printout T " Currently ") (PRINTNUM |.I7| (GETBASE VA 0) T) (printout T " to be ") (PUTBASE VA 0 (READOCT)))) (I (ALLOCAL (COND ((NULL (GETD (QUOTE INSPECT)))) ((RECLOOK (QUOTE IFPAGE)) (INSPECT (COND ((LISTP VMEMFILE) (VMAPPAGE (fetch (POINTER PAGE#) of \InterfacePage))) (T (PROG ((PAGE (NCREATE (QUOTE VMEMPAGEP)))) (SETVMPTR (VGETTOPVAL (QUOTE \InterfacePage))) (\BINS (GETSTREAM VMEMFILE) PAGE 0 BYTESPERPAGE) (RETURN PAGE)))) (QUOTE IFPAGE))) (T (PRIN1 " Can't -- no record for IFPAGE")))) (TERPRI T)) (U (SHOWREMOTESCREEN)) (HELP)) (RETURN NIL))) ) + +(RAIDSHOWFRAME (LAMBDA (N) (* bvm%: "27-Jan-85 15:27") (PROG ((FRAME (OR ROOTFRAME (RAIDROOTFRAME)))) (FRPTQ (SUB1 N) (COND ((fetch (FX INVALIDP) of (SETQ FRAME (COND (ALINKS? (fetch (FX ALINK) of FRAME)) (T (fetch (FX CLINK) of FRAME))))) (RETURN (printout T N " is beyond the bottom of the stack" T))))) (\BACKTRACE FRAME FRAME T NIL T T NIL (FUNCTION PRINCOPY) NIL RAIDIX))) ) + +(RAIDSTACKCMD (LAMBDA (CMD) (* bvm%: "28-Jan-85 12:16") (DECLARE (USEDFREE FRAME# ROOTFRAME)) (PROG (FRAME) (SETQ FRAME# 0) (COND ((EQ CMD (QUOTE L)) (RAIDROOTFRAME)) (T (SETQ ROOTFRAME (SELECTQ (SETQ FRAME (ASKUSER NIL NIL "in context (? for help): " (QUOTE ((P "age fault") (G "arbage collection") (K "eyboard handler") (H "ard Return") (S "tack manipulator") (R "eset") (M "iscellaneous") (F "rame at location: "))) T)) (P (fetch (IFPAGE FAULTFXP) of \InterfacePage)) (G (fetch (IFPAGE GCFXP) of \InterfacePage)) (K (fetch (IFPAGE KbdFXP) of \InterfacePage)) (H (fetch (IFPAGE HardReturnFXP) of \InterfacePage)) (S (fetch (IFPAGE SubovFXP) of \InterfacePage)) (R (fetch (IFPAGE ResetFXP) of \InterfacePage)) (M (fetch (IFPAGE MiscFXP) of \InterfacePage)) (COND ((AND (ILESSP (SETQ FRAME (READOCT)) WORDSPERPAGE) (ILESSP (\GETBASE \InterfacePage FRAME) (fetch (IFPAGE EndOfStack) of \InterfacePage)) (type? FX (\GETBASE \InterfacePage FRAME))) (\GETBASE \InterfacePage FRAME)) ((type? FX FRAME) FRAME) (T (PRINTNUM |.I7| FRAME) (printout T " not a valid frame." T) (RETURN))))))) (FRESHLINE T) (\BACKTRACE ROOTFRAME NIL T NIL NIL NIL ALINKS? (FUNCTION PRINCOPY) 1 RAIDIX))) ) + +(RAIDROOTFRAME (LAMBDA NIL (* bvm%: "27-Jan-85 15:26") (SETQ ROOTFRAME (PROG1 (COND ((ALLOCAL (LISTP VMEMFILE)) (PRIN1 "in TeleRaid Context" T) (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)) (T (fetch (IFPAGE CurrentFXP) of \InterfacePage))) (TERPRI T)))) ) + +(PRINTADDRS (LAMBDA (BASE CNT) (* bvm%: "13-Feb-85 22:42") (PRIN1 "words from ") (PRINTVA BASE) (PRIN1 " to ") (PRINTVA (\ADDBASE BASE (SUB1 CNT))) (TERPRI) (SPACES 7) (for I from 0 to 7 do (PRINTNUM |.I7| I)) (PROG ((NB (\VAG2 (\HILOC BASE) (FLOOR (\LOLOC BASE) 8))) (LB (\ADDBASE BASE CNT))) (do (COND ((EVENP (\LOLOC NB) 8) (TAB 0 0) (PRINTNUM |.I5| (\LOLOC NB)) (PRIN1 ": "))) (COND ((PTRGTP BASE NB) (SPACES 7)) (T (PRINTNUM |.I7| (\GETBASE NB 0)))) (SETQ NB (\ADDBASE NB 1)) repeatwhile (PTRGTP LB NB)) (TAB 0 0))) ) + +(PRINTVA (LAMBDA (X) (* bvm%: "12-Feb-85 10:41") (PRIN1 "{") (PRINTNUM |.I2| (HILOC X)) (PRIN1 ",") (PRINTNUM |.I2| (LOLOC X)) (PRIN1 "}")) ) + +(READVA (LAMBDA NIL (* lmm "21-AUG-81 12:55") (VAG2 (READOCT) (READOCT)))) + +(READATOM (LAMBDA NIL (* ; "Edited 16-Feb-87 15:44 by raf") (ALLOCAL (PROG1 (HANDLER-BIND ((XCL:MISSING-EXTERNAL-SYMBOL (CL:FUNCTION (LAMBDA (CONDITION) (* ;; "MAKE AN INTERNAL SYMBOL INSTEAD") (CL:INTERN (XCL:MISSING-EXTERNAL-SYMBOL-NAME CONDITION) (XCL:MISSING-EXTERNAL-SYMBOL-PACKAGE CONDITION))))) (XCL:MISSING-PACKAGE (CL:FUNCTION (LAMBDA (CONDITION) (* ;; "FAKE A PACKAGE BY THIS NAME AND MAKE THE SYMBOL IN IT") (CL:INTERN (XCL:MISSING-PACKAGE-SYMBOL-NAME CONDITION) (CL:MAKE-PACKAGE (XCL:MISSING-PACKAGE-PACKAGE-NAME CONDITION) :USE NIL)))))) (CL:READ T)) (READC T)))) ) + +(READOCT (LAMBDA (PROMPT) (* bvm%: "28-Jan-85 11:51") (DECLARE (USEDFREE RAIDIX)) (COND ((AND PROMPT (NOT (READP T))) (printout T PROMPT))) (bind STR while (EQUAL (SETQ STR (RSTRING T T)) "") do (READC T) finally (RETURN (PROG1 (OR (FIXP (SELECTQ RAIDIX (8 (MKATOM (CONCAT STR "Q"))) (16 (bind (N _ 0) CHAR while (SETQ CHAR (GNC STR)) do (SETQ N (IPLUS (ITIMES N 16) (COND ((FIXP CHAR) CHAR) ((AND (IGEQ (SETQ CHAR (CHCON1 CHAR)) (CHARCODE A)) (ILEQ CHAR (CHARCODE F))) (IPLUS (IDIFFERENCE CHAR (CHARCODE A)) 10)) (T (ERROR CHAR (QUOTE ?) T))))) finally (RETURN N))) (SHOULDNT))) (PROGN (PRIN1 "?" T) (ERROR!))) (READC T))))) ) + +(SHOWSTACKBLOCKS (LAMBDA (SCANPTR WAITFLG) (* bvm%: "18-AUG-83 12:05") (* ; "show stack") (PROG ((EASP (fetch EndOfStack of \InterfacePage))) SCAN (SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.FSB (SHOWSTACKBLOCK1 SCANPTR "free block" (fetch (FSB CHECKED) of SCANPTR)) (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) (\STK.GUARD (SHOWSTACKBLOCK1 SCANPTR "guard block" T) (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) (\STK.FX (* ; "frame extension") (SHOWSTACKBLOCK1 SCANPTR "Frame extn = " (fetch (FX CHECKED) of SCANPTR)) (PRIN2 (\UNCOPY (fetch (FX FRAMENAME) of SCANPTR))) (SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR))) (PROG ((ORIG SCANPTR) IVAR) (* ; "must be a basic frame") (while (EQ (fetch (STK FLAGS) of SCANPTR) \STK.NOTFLAG) do (add SCANPTR WORDSPERCELL)) (COND ((NOT (type? BF SCANPTR)) (SHOWSTACKBLOCK1 ORIG "Garbage" T)) (T (SETQ IVAR (fetch (BF IVAR) of SCANPTR)) (COND ((fetch (BF RESIDUAL) of SCANPTR) (SHOWSTACKBLOCK1 SCANPTR "Residual BF" (EQ SCANPTR ORIG)) (PRIN1 " with IVar = ") (PRINTNUM |.I7| IVAR)) (T (SHOWSTACKBLOCK1 SCANPTR "Basic frame" (AND (EQ ORIG IVAR) (fetch (BF CHECKED) of SCANPTR))))) (add SCANPTR WORDSPERCELL))))) (TERPRI) (COND ((IGREATERP SCANPTR EASP) (RETURN))) (AND WAITFLG (READC T)) (GO SCAN))) ) + +(SHOWSTACKBLOCK1 (LAMBDA (PTR STR GOODFLG) (* bvm%: " 6-AUG-83 23:59") (PRINTNUM |.I7| PTR) (SPACES 1) (OR GOODFLG (PRIN1 "[bad] ")) (PRIN1 STR)) ) + +(PRINCOPY (LAMBDA (X) (* bvm%: "24-Jan-86 12:33") (PRINT (\UNCOPY X (LOCAL (CAR VPRINTLEVEL)) (LOCAL (CDR VPRINTLEVEL))) T T)) ) + +(NOSUCHATOM [LAMBDA (ATM) (* ;  "Edited 9-Nov-92 15:24 by sybalsky:mv:envos") (* ;; "Called only under TeleRaid when V\MKATOM fails to find atom ATM. JDS: And in MAKEINIT, ditto. For Makeinit (since Teleraid is essentially dead), changed ERROR! to ERROR.") (printout T "No such atom: " ATM T) (ERROR "No such atom: "]) +) +(DEFINEQ + +(BACKTRACE (LAMBDA (IPOS EPOS FLAGS FILE PRINTFN) (* bvm%: "13-Feb-85 22:42") (RESETFORM (OUTPUT FILE) (\BACKTRACE (\STACKARGPTR (OR IPOS -1)) (\STACKARGPTR (OR EPOS T)) (EQ 0 (LOGAND 8 (OR FLAGS (SETQ FLAGS 0)))) (NEQ 0 (LOGAND FLAGS 1)) (NEQ 0 (LOGAND FLAGS 4)) (NEQ 0 (LOGAND FLAGS 32)) (EQ 0 (LOGAND FLAGS 16)) (OR PRINTFN (FUNCTION PRINT)) NIL))) ) + +(\BACKTRACE (LAMBDA (IPOS EPOS NAMES VARS LOCALS JUNK ALINKS PRINTFN CNT RADIX) (* lmm " 2-Jul-86 13:00") (OR RADIX (SETQ RADIX 8)) (PROG (NARGS NPVARS NAME ARGNAME BLINK (|.I7| (NUMFORMATCODE (LIST (QUOTE FIX) 7 RADIX)))) (DECLARE (SPECVARS |.I7|)) POSLP (COND (CNT (printout NIL |.I3| CNT ": ") (add CNT 1))) (SETQ NAME (\STKNAME IPOS)) (COND (JUNK (TERPRI) (TERPRI) (PRIN1 "Basic frame at ") (PRINTNUM |.I7| (SETQ BLINK (fetch (FX BLINK) of IPOS))) (TERPRI) (\PRINTBF BLINK (fetch (FX NAMETABLE) of IPOS) PRINTFN) (PROGN (TERPRI) (PRIN1 "Frame xtn at ") (PRINTNUM |.I7| IPOS) (PRIN1 ", frame name= ")) (APPLY* PRINTFN NAME) (\PRINTFRAME IPOS PRINTFN)) ((OR VARS LOCALS) (\PRINTBF (fetch (FX BLINK) of IPOS) (fetch (FX NAMETABLE) of IPOS) PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T))) (COND (NAMES (APPLY* PRINTFN NAME) (TERPRI))) (\PRINTFRAME IPOS PRINTFN (COND (LOCALS (QUOTE LOCALS)) (T T)))) (NAMES (APPLY* PRINTFN NAME))) (COND ((AND (NEQ EPOS IPOS) (NOT (fetch (FX INVALIDP) of (SETQ IPOS (COND (ALINKS (fetch (FX ALINK) of IPOS)) (T (fetch (FX CLINK) of IPOS))))))) (GO POSLP))) (RETURN T))) ) + +(\SCANFORNTENTRY [LAMBDA (NMT NTENTRY) (* ; "Edited 18-Feb-91 15:18 by jds") (* ;; "Scan thru the name table pointedto by NMT, looking for the name of the variable with offset entry NTENTRY, which must be in the form appropriate to the architecture (2- or 3-byte).") (bind NM for NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS ) of T) (fetch (FNHEADER NTSIZE) of NMT)) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do (COND ((NULL-NTENTRY (SETQ NM (GETSTKNAMEENTRY NMT NT1))) (RETURN))) (COND ((IEQP NTENTRY (GETSTKNTOFFSETENTRY NMT NT2 )) (RETURN (\INDEXATOMVAL NM]) + +(\PRINTSTK (LAMBDA (I) (* lmm "23-MAY-82 22:09") (PRINTNUM |.I7| I) (PRIN1 ": ") (PRINTNUM |.I7| (GETBASE \STACKSPACE I)) (PRINTNUM |.I7| (GETBASE \STACKSPACE (ADD1 I))) (SPACES 1)) ) + +(\PRINTFRAME [LAMBDA (FRAME PRINTFN VARSONLY) (* ; "Edited 30-Jan-91 01:48 by jds") (PROG ((NMT (fetch (FX NAMETABLE) of FRAME)) (I 0) (FT (fetch (FX FIRSTTEMP) of FRAME)) TMP NLOCALS) [COND ((NOT VARSONLY) (\PRINTSTK FRAME) (PRIN1 "[") (PROGN (PSTKFLD FAST "F, " FAST) (PSTKFLD INCALL "C, " INCALL) (PSTKFLD VALIDNAMETABLE "V, " VALIDNAMETABLE) (PSTKFLD NOPUSH "N, " NOPUSH) (PSTKFLD USECNT "USE=" (NEQ USECNT 0) NIL ", ") (PSTKFLD SLOWP "X, " SLOWP) (PSTKFLD ALINK " alink]" T)) (TERPRI) (PSTK 2 (FNHEADER "[fn header]" T)) (PSTK 4 (NEXTBLOCK "[next, pc]" T)) (PSTK 6 (NAMETABLE "[nametable]" T)) (PSTK 8 (BLINK "[blink, clink]" T] (SETQ NLOCALS (fetch (FNHEADER NLOCALS) of NMT)) [for old I from (fetch (FX FIRSTPVAR) of FRAME) by WORDSPERCELL while (ILESSP I FT) as J from 0 do (OR VARSONLY (\PRINTSTK I)) (COND [(ILESSP J NLOCALS) (COND ((OR (SETQ TMP (\SCANFORNTENTRY NMT (MAKE-NTENTRY PVARCODE J))) (AND (NEQ VARSONLY T) (SETQ TMP "local"))) (COND ((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I)) (AND VARSONLY (SPACES 3)) (PRIN2 TMP) (SPACES 1) (APPLY* PRINTFN (\GETBASEPTR (ADDSTACKBASE I) 0))) ((NOT VARSONLY) (printout NIL TMP " [unbound]" T] ((NOT VARSONLY) (COND ((SETQ TMP (\SCANFORNTENTRY NMT (MAKE-NTENTRY FVARCODE J))) (printout NIL "[fvar " |.P2| TMP " " (COND ((fetch (FVARSLOT LOOKEDUP) of (ADDSTACKBASE I)) (COND ((EQ [SETQ TMP (\HILOC (fetch (FVARSLOT BINDINGPTR) of (ADDSTACKBASE I] \STACKHI) " on stack]") ((NEQ (FLOOR TMP 2) (\HILOC \VALSPACE)) (* ; "See comment in BOUNDP") " non-stack binding]") (T " top value]"))) (T " not looked up]")) T)) (T (printout NIL "[padding]" T] (COND ((NOT VARSONLY) (SETQ FT (fetch (FX NEXTBLOCK) of FRAME)) (for old I by 2 while (ILESSP I FT) do (* ;  "2 = WORDSPERCELL but for doesn't translate correctly with WORDSPERCELL") (\PRINTSTK I) (COND ((fetch (PVARSLOT BOUND) of (ADDSTACKBASE I)) (APPLY* PRINTFN (\GETBASEPTR (ADDSTACKBASE I) 0))) (T (TERPRI]) + +(\PRINTBF [LAMBDA (BL NMT PRINTFN VARSONLY) (* ; "Edited 30-Jan-91 01:49 by jds") [bind NM for I from (fetch (BF IVAR) of BL) by 2 as J from 0 to (SUB1 (fetch (BF NARGS) of BL)) do (OR VARSONLY (\PRINTSTK I)) [COND ([OR (SETQ NM (\SCANFORNTENTRY [OR NMT (RETURN (OR VARSONLY (TERPRI] (MAKE-NTENTRY IVARCODE J))) (AND (NEQ VARSONLY T) (SETQ NM '*local*] (AND VARSONLY (SPACES 3)) (PRIN2 NM) (SPACES 1) (APPLY* PRINTFN (GETBASEPTR \STACKSPACE I] finally (OR VARSONLY (while (ILESSP I BL) do (\PRINTSTK I) (printout NIL "[padding]" T) (add I 2] (COND ((NOT VARSONLY) (\PRINTSTK BL) (COND ((fetch (BF RESIDUAL) of BL) (PRIN1 "residual "))) (COND ((NEQ (fetch (BF USECNT) of BL) 0) (printout NIL "usecnt= " (fetch (BF USECNT) of BL) %,))) (TERPRI]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(RPAQQ RAIDCOMS + ((MACROS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA) + (ADDVARS (RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA + READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY + NOSUCHATOM) + (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK)) + (EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA)) + (ADDVARS (DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS + PRINTVA READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY + NOSUCHATOM)))) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS PSTKFLD MACRO ((FLD STR TEST FMT STR2) + (PROG ((FLD (fetch (FX FLD) of FRAME))) + (DECLARE (LOCALVARS FLD)) + (COND + (TEST (PRIN1 'STR) + (SELECTQ (CONSTANT (NTHCHAR 'STR -1)) + (= (printout NIL %, FLD STR2)) + NIL) + T] + +[PUTPROPS PRINTSTKFIELDS MACRO (FIELDS (CONS 'PROGN (MAPCAR FIELDS (FUNCTION (LAMBDA (X) + (CONS 'PSTKFLD X] + +(PUTPROPS PSTK MACRO ((N . FIELDS) + (\PRINTSTK (IPLUS FRAME N)) + (PRINTSTKFIELDS . FIELDS) + (TERPRI))) + +[PUTPROPS PRINTVA MACRO (LAMBDA (X) + (printout NIL "{" (HILOC X) + "," + (LOLOC X) + "}"] +) + +(ADDTOVAR RDCOMS (FNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA + READVA READOCT READATOM SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY NOSUCHATOM + ) + (FNS \BACKTRACE \STKNAME \PRINTBF \PRINTFRAME \SCANFORNTENTRY \PRINTSTK)) + +(ADDTOVAR EXPANDMACROFNS PSTKFLD PRINTSTKFIELDS PSTK PRINTVA) + +(ADDTOVAR DONTCOMPILEFNS RAIDCOMMAND RAIDSHOWFRAME RAIDSTACKCMD RAIDROOTFRAME PRINTADDRS PRINTVA + READVA READATOM READOCT SHOWSTACKBLOCKS SHOWSTACKBLOCK1 PRINCOPY + NOSUCHATOM) +) +(DEFINEQ + +(CCODEP (LAMBDA (FN) (* ; "Edited 30-Jan-87 13:36 by Pavel") (COND ((LITATOM FN) (COND ((fetch (LITATOM CCODEP) of FN) (NOT (fetch (LITATOM PSEUDOCODEP) of FN))) (T (TYPEP (fetch (LITATOM DEFPOINTER) of FN) (QUOTE COMPILED-CLOSURE))))) (T (CL:COMPILED-FUNCTION-P FN)))) ) + +(EXPRP (LAMBDA (FN) (* lmm "17-FEB-82 23:50") (PROG ((DEF FN)) (COND ((LITATOM DEF) (COND ((fetch (LITATOM CCODEP) of DEF) (RETURN (fetch (LITATOM PSEUDOCODEP) of DEF)))) (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))) (RETURN (COND ((LISTP DEF) T))))) ) + +(SUBRP (LAMBDA (FN) (* lmm "17-AUG-81 21:57") NIL)) + +(FNTYP (LAMBDA (FN) (* bvm%: " 7-Jul-86 16:43") (PROG ((DEF FN)) (COND ((LITATOM DEF) (SETQ DEF (fetch (LITATOM DEFINITIONCELL) of DEF)) (COND ((fetch (DEFINITIONCELL PSEUDOCODEP) of DEF) (SETQ DEF (\PSEUDOCODE.REALDEF DEF))) ((PROG1 (fetch (DEFINITIONCELL CCODEP) of DEF) (SETQ DEF (fetch (DEFINITIONCELL DEFPOINTER) of DEF))) (RETURN (\CCODEFNTYP DEF)))))) (RETURN (COND ((LISTP DEF) (SELECTQ (CAR DEF) (CL:LAMBDA (QUOTE EXPR*)) ((LAMBDA OPENLAMBDA) (COND ((AND (NLISTP (SETQ DEF (CADR DEF))) DEF) (QUOTE EXPR*)) (T (QUOTE EXPR)))) (NLAMBDA (COND ((AND (NLISTP (SETQ DEF (CADR DEF))) DEF) (QUOTE FEXPR*)) (T (QUOTE FEXPR)))) (FUNARG (QUOTE EXPR)) NIL)) ((TYPEP DEF (QUOTE COMPILED-CLOSURE)) (\CCODEFNTYP (fetch (COMPILED-CLOSURE FNHEADER) of DEF))))))) ) + +(ARGTYPE (LAMBDA (FN) (* bvm%: "16-Jul-86 22:47") (LET ((DEF FN)) (CL:TYPECASE DEF (CL:SYMBOL (COND ((PROG1 (fetch (LITATOM CCODEP) of DEF) (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF))) (\CCODEARGTYPE DEF)) (DEF (ARGTYPE DEF)))) (CONS (SELECTQ (CAR DEF) (CL:LAMBDA 2) ((LAMBDA OPENLAMBDA) (COND ((AND (NLISTP (SETQ DEF (CADR DEF))) DEF) 2) (T 0))) (NLAMBDA (COND ((AND (NLISTP (SETQ DEF (CADR DEF))) DEF) 3) (T 1))) (FUNARG (ARGTYPE (CADR DEF))) (SELECTQ (FNTYP DEF) (EXPR 0) (FEXPR 1) (EXPR* 2) (FEXPR* 3) NIL))) (CLOSURE 2) (COMPILED-CLOSURE (\CCODEARGTYPE (fetch (COMPILED-CLOSURE FNHEADER) of DEF)))))) ) + +(NARGS (LAMBDA (FN) (* bvm%: " 7-Jul-86 17:07") (LET ((DEF FN)) (COND ((AND (LITATOM DEF) (PROG1 (fetch (LITATOM CCODEP) of DEF) (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF)))) (\CCODENARGS DEF)) ((LISTP DEF) (SELECTQ (CAR DEF) (CL:LAMBDA 1) ((LAMBDA NLAMBDA OPENLAMBDA) (COND ((NULL (SETQ DEF (CADR DEF))) 0) ((NLISTP DEF) 1) (T (in DEF sum 1)))) (FUNARG (NARGS (CADR DEF))) NIL)) ((TYPEP DEF (QUOTE COMPILED-CLOSURE)) (\CCODENARGS (fetch (COMPILED-CLOSURE FNHEADER) of DEF)))))) ) + +(ARGLIST [LAMBDA (FN SMARTP) (* ; "Edited 15-Jan-88 15:10 by bvm:") (PROG ((DEF FN) TEMP) [COND ((LITATOM DEF) (COND ((PROG1 (fetch (LITATOM CCODEP) of DEF) (SETQ DEF (fetch (LITATOM DEFPOINTER) of DEF))) (RETURN (\CCODEARGLIST DEF SMARTP))) ((NULL DEF) (SETQ DEF (GETPROP FN 'EXPR] [RETURN (COND ((LISTP DEF) (SELECTQ (CAR DEF) (CL:LAMBDA 'U) ([LAMBDA NLAMBDA OPENLAMBDA] (CADR DEF)) (FUNARG (ARGLIST (CADR DEF))) (GO UNDEF))) ((TYPEP DEF 'COMPILED-CLOSURE) (\CCODEARGLIST (fetch (COMPILED-CLOSURE FNHEADER) of DEF) SMARTP)) (T (GO UNDEF] UNDEF (COND ((AND (SETQ DEF (FNCHECK FN T)) (NEQ DEF FN)) (RETURN (ARGLIST DEF))) (T (ERROR '"Args not available:" FN]) + +(\CCODEARGLIST [LAMBDA (FNHD SMARTP) (* ; "Edited 10-May-88 12:18 by MASINTER") (* ;; "Computes the arglist for raw code object FNHD. If SMARTP is true, we're allowed to return a Common Lisp arg list if we find one; otherwise, we have to comply with Interlisp arglist semantics.") (PROG ((N (fetch (FNHEADER NA) of FNHD)) IVARS SIZE LOCALSIZE ENDT) [COND ((EQ N 0) (* ; "No args") (RETURN NIL)) ((AND (< N 0) (NOT SMARTP)) (* ; "LAMBDA*") (RETURN 'U] (SETQ SIZE (fetch (FNHEADER NTSIZE) of FNHD)) [COND ((EQ [SETQ LOCALSIZE (- (FOLDLO (if (fetch (FNHEADER NATIVE) of FNHD) then (- (fetch (FNHEADER STARTPC) of FNHD) 4) else (fetch (FNHEADER STARTPC) of FNHD)) BYTESPERWORD) (SETQ ENDT (+ (fetch (FNHEADER OVERHEADWORDS) of T) (COND ((EQ SIZE 0) (* ;  "No nametable, but there's a quad of zeros there anyway") WORDSPERQUAD) (T (UNFOLD SIZE 2] 0) (* ; "Nothing extra here") ) [(> LOCALSIZE WORDSPERCELL) (* ;  "There is a second nametable between the first and the code.") (SETQ IVARS (\CCODEIVARSCAN FNHD ENDT (FOLDLO LOCALSIZE 2] ((AND (LISTP (SETQ ENDT (\GETBASEPTR FNHD ENDT))) (LISTP (CAR ENDT))) (* ;  "It's exactly a pointer to debugging info, car of which is a stylized arglist") (SETQ ENDT (if (AND (EQ (CAAR ENDT) '&OPTIONAL) (LISTGET (CDR ENDT) :INTERLISP)) then (* ; "The &OPTIONAL, while strictly correct, is misleading, since it's technically true for ALL Interlisp functions.") (CDAR ENDT) else (CAR ENDT))) (RETURN (COND (SMARTP ENDT) (T (* ; "Note that if we got this far, function can't be a nospread (we caught this in the very first COND up above), which means there can't be any &key or &rest") (for X in ENDT unless (EQ X '&OPTIONAL) collect (COND ((STRINGP X) (* ;  "Callers of ARGLIST are expecting to get something that would actually function as one") (MKATOM X)) (T X] [COND ((< N 0) (* ;  "Waited until now to see if there was a stored arglist, but we didn't find one--give up") (RETURN 'U] [COND ((NEQ SIZE 0) (* ; "Scan specials name table") (SETQ IVARS (\CCODEIVARSCAN FNHD (fetch (FNHEADER OVERHEADWORDS) of T) SIZE IVARS] [SETQ IVARS (for I from 0 to (SUB1 N) collect (OR (CDR (ASSOC I IVARS)) (PACK* '*ARG* I] (RETURN (SELECTQ (fetch (FNHEADER ARGTYPE) of FNHD) (3 (CAR IVARS)) IVARS]) + +(\CCODEIVARSCAN [LAMBDA (FNHD START SIZE IVARS) (* ; "Edited 30-Jan-91 02:00 by jds") (* ;; "Search nametable starting at offset START in FNHD for all ivars. Return list of dotted pairs (index . name) consed onto front of IVARS. NTSIZE is size of nt in words") (bind NM CODE for NTOFFSET FROM (UNFOLD START BYTESPERWORD) by (CONSTANT (BYTESPERNAMEENTRY)) while (SETQ NM (\INDEXATOMVAL (GETNAMEENTRY FNHD NTOFFSET))) do (* ;  "Note that entry = 0 => NM = NIL terminates the loop") [COND ((EQP [NTSLOT-VARTYPE (SETQ CODE (GETNTOFFSETENTRY FNHD (IPLUS NTOFFSET (UNFOLD SIZE BYTESPERWORD] IVARCODE) (push IVARS (CONS (NTSLOT-OFFSET CODE) NM] finally (RETURN IVARS]) +) + + + +(* ; "Translation machinery for new LAMBDA words") + + +(PUTPROPS LAMBDATRANFNS VARTYPE ALIST) + +(ADDTOVAR LAMBDATRANFNS ) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \CCODENARGS MACRO ((FNH) + ([LAMBDA (N) + (COND + ((ILESSP N 0) + 1) + (T N] + (fetch (FNHEADER NA) of FNH] + +[PUTPROPS \CCODEFNTYP MACRO ((FNH) + (SELECTQ (\CCODEARGTYPE FNH) + (0 'CEXPR) + (1 'CFEXPR) + (2 'CEXPR*) + 'CFEXPR*] + +(PUTPROPS \CCODEARGTYPE MACRO ((FNH) + (fetch (FNHEADER ARGTYPE) of FNH))) +) +) + + + +(* ; "CONSTANTS mechanism") + +(DEFINEQ + +(CONSTANTS (NLAMBDA VARS (* rmk%: " 3-Jan-84 13:20") (OR COMPVARMACROHASH (SETQ COMPVARMACROHASH (HASHARRAY 100))) (for X in VARS do (COND ((LISTP X) (PUTHASH (CAR X) (LIST (QUOTE CONSTANT) (CADR X)) COMPVARMACROHASH)) (T (PUTHASH X (LIST (QUOTE CONSTANT) X) COMPVARMACROHASH)))) VARS) ) + +(CONSTANTEXPRESSIONP [LAMBDA (FORM) (* ; "Edited 21-Jan-91 23:45 by jds") (COND [(LITATOM FORM) (COND ((OR (NULL FORM) (EQ FORM T)) (LIST FORM)) ((AND COMPVARMACROHASH (SETQ FORM (GETHASH FORM COMPVARMACROHASH))) (CONSTANTEXPRESSIONP FORM] [(LISTP FORM) (SELECTQ (CAR FORM) (QUOTE (CDR FORM)) (FUNCTION (AND (LITATOM (CADR FORM)) (NULL (CDDR FORM)) (CDR FORM))) (CONSTANT [LET (VALUE) [SETQ VALUE (NLSETQ (EVAL (CADR FORM] (COND (VALUE (LIST (CAR VALUE))) (T (SETQ FORM (COMPILER:OPTIMIZE-AND-MACROEXPAND (CADR FORM) *BC-MACRO-ENVIRONMENT* (COMPILER:MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P NIL))) (LIST (EVAL FORM]) (COND [(FMEMB (CAR FORM) CONSTANTFOLDFNS) (for X in (CDR FORM) collect (CAR (OR (CONSTANTEXPRESSIONP X) (RETURN))) finally (RETURN (LIST (APPLY (CAR FORM) $$VAL] ((NOT (GETD (CAR FORM))) (PROG ((MAC (GETMACROPROP (CAR FORM) COMPILERMACROPROPS))) (RETURN (AND MAC [NOT (EQUAL FORM (SETQ FORM (MACROEXPANSION FORM MAC] (CONSTANTEXPRESSIONP FORM] ((NUMBERP FORM) (LIST FORM]) +) + +(RPAQ? COMPVARMACROHASH (HASHARRAY 100)) + + + +(* ; +"We need this initialized for the INIT, so don't put it off. (It used to start out NIL and get set later)" +) + + +(ADDTOVAR CONSTANTFOLDFNS + PLUS IPLUS TIMES ITIMES DIFFERENCE IDIFFERENCE QUOTIENT IQUOTIENT IMIN IMAX IABS LLSH LRSH + LOGOR LOGXOR LOGAND OR AND) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS COMPVARMACROHASH CONSTANTFOLDFNS) +) +(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(SPECVARS *TAIL* *FN* *FORM* *ARGVAL*) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(ADDTOVAR LAMS FAULTEVAL FAULTAPPLY) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA CONSTANTS PROG1 COND PROGN OR AND QUOTE LET* LET GO PROG SETQ) + +(ADDTOVAR NLAML FUNCTION RETURN) + +(ADDTOVAR LAMA APPLY* \INTERPRETER) +) +(PUTPROPS LLINTERP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988 +1990 1991 1992 1994 1995)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (6448 23709 (\INTERPRETER 6458 . 11054) (\INTERPRETER1 11056 . 17624) ( +\SETUP-COMPILED-CLOSURE-CALL 17626 . 22773) (\STKNAME 22775 . 23707)) (23738 29150 (\ENVCALL.UFN 23748 + . 23880) (\SETUP-ENVIRONMENT-CALL 23882 . 29148)) (29189 34066 (EVAL 29199 . 29299) (\EVAL 29301 . +29511) (\EVALFORM 29513 . 30744) (\EVALFORMASLAMBDA 30746 . 30936) (\EVALOTHER 30938 . 31145) (APPLY +31147 . 31254) (APPLY* 31256 . 32371) (\CHECKAPPLY* 32373 . 33478) (\CKAPPLYARGS 33480 . 33823) ( +DEFEVAL 33825 . 34064)) (35868 43313 (EVALV 35878 . 36087) (\EVALV1 36089 . 36244) (\EVALVAR 36246 . +36609) (BOUNDP 36611 . 36827) (SET 36829 . 37195) (\SETVAR 37197 . 37567) (SETQ 37569 . 38241) ( +\STKSCAN 38243 . 41763) (\SETFVARSLOT 41765 . 43311)) (43347 56354 (PROG 43357 . 45873) (\PROG0 45875 + . 49505) (\EVPROG1 49507 . 49710) (RETURN 49712 . 50253) (GO 50255 . 51070) (EVALA 51072 . 53001) ( +\EVALA 53003 . 55596) (ERRORSET 55598 . 56203) (SI::ERRORSET-PRINT-FUNCTION 56205 . 56352)) (56413 +69065 (LET 56423 . 58566) (LET* 58568 . 60716) (\LET0 60718 . 64378) (\LET* 64380 . 69063)) (69066 +70642 (QUOTE 69076 . 69107) (AND 69109 . 69317) (OR 69319 . 69567) (PROGN 69569 . 69848) (COND 69850 + . 70184) (\EVPROGN 70186 . 70399) (PROG1 70401 . 70640)) (71130 78021 (ENVEVAL 71140 . 71390) ( +ENVAPPLY 71392 . 71649) (FUNCTION 71651 . 71881) (\FUNCT1 71883 . 74332) (\MAKEFUNARGFRAME 74334 . +76531) (STKEVAL 76533 . 76681) (STKAPPLY 76683 . 76852) (RETEVAL 76854 . 77458) (RETAPPLY 77460 . +78019)) (78142 85650 (BLIPVAL 78152 . 82053) (SETBLIPVAL 82055 . 84797) (BLIPSCAN 84799 . 85648)) ( +85651 86346 (\REALFRAMEP 85661 . 86344)) (86722 96117 (RAIDCOMMAND 86732 . 90338) (RAIDSHOWFRAME 90340 + . 90723) (RAIDSTACKCMD 90725 . 91906) (RAIDROOTFRAME 91908 . 92170) (PRINTADDRS 92172 . 92698) ( +PRINTVA 92700 . 92845) (READVA 92847 . 92925) (READATOM 92927 . 93509) (READOCT 93511 . 94142) ( +SHOWSTACKBLOCKS 94144 . 95390) (SHOWSTACKBLOCK1 95392 . 95543) (PRINCOPY 95545 . 95677) (NOSUCHATOM +95679 . 96115)) (96118 104746 (BACKTRACE 96128 . 96485) (\BACKTRACE 96487 . 97593) (\SCANFORNTENTRY +97595 . 99225) (\PRINTSTK 99227 . 99414) (\PRINTFRAME 99416 . 103399) (\PRINTBF 103401 . 104744)) ( +107255 116599 (CCODEP 107265 . 107540) (EXPRP 107542 . 107801) (SUBRP 107803 . 107858) (FNTYP 107860 + . 108620) (ARGTYPE 108622 . 109236) (NARGS 109238 . 109725) (ARGLIST 109727 . 110976) (\CCODEARGLIST +110978 . 115374) (\CCODEIVARSCAN 115376 . 116597)) (117516 119747 (CONSTANTS 117526 . 117817) ( +CONSTANTEXPRESSIONP 117819 . 119745))))) +STOP diff --git a/sources/LLKEY b/sources/LLKEY new file mode 100644 index 00000000..04a57a3d --- /dev/null +++ b/sources/LLKEY @@ -0,0 +1,35 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-May-2018 13:32:12" {DSK}kaplan>Local>medley3.5>lispcore>sources>LLKEY.;4 199267 changes to%: (VARS LLKEYCOMS \KEYNAMES) previous date%: " 9-Apr-2000 16:28:23" {DSK}kaplan>Local>medley3.5>lispcore>sources>LLKEY.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1999, 1920, 2000, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLKEYCOMS) (RPAQQ LLKEYCOMS [(COMS (* ; "Access to keyboard") (FNS BKSYSCHARCODE \CLEARSYSBUF \GETKEY \NSYSBUFCHARS \SAVESYSBUF \SYSBUFP \GETSYSBUF \PUTSYSBUF \PEEKSYSBUF) (INITVARS (\LONGSYSBUF)) (INITVARS (\\KEYBOARDWAITBOX.GLOBALRESOURCE)) (DECLARE%: DONTCOPY (RESOURCES \KEYBOARDWAITBOX)) (DECLARE%: DONTCOPY (CONSTANTS (\SYSBUFSIZE 200)) (MACROS \GETREALSYSBUF))) [DECLARE%: DOCOPY DONTEVAL@LOAD (COMS (* ;  "Here because it must be done in init before PROC loaded") (P (MOVD? 'NILL 'CARET] (COMS (* ; "Key handler") (FNS \KEYBOARDINIT \KEYBOARDEVENTFN \ALLOCLOCKED \SETIOPOINTERS \KEYBOARDOFF \KEYBOARDON \KEYHANDLER \KEYHANDLER1 \RESETKEYBOARD \DOMOUSECHORDING \DOTRANSITIONS \DECODETRANSITION MOUSECHORDWAIT \TRACKCURSOR) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) (INITVARS (\MOUSECHORDTICKS) (\MOUSECHORDMILLISECONDS 50)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\KEYBOARDINIT))) [DECLARE%: DONTCOPY (MACROS .NOTELASTUSERACTION) (CONSTANTS ALLUP \CTRLMASK \METABIT) (CONSTANTS * DLMOUSEBITS) (CONSTANTS * DLMOUSESTATES) (CONSTANTS * TRANSITIONFLAGS) (MACROS \TRANSINDEX ARMEDCODE TRANSITIONALTGRCODE TRANSITIONSHIFTCODE TRANSITIONCODE TRANSITIONFLAGS TRANSITIONDEADLIST CHECKFORDEADKEY) (EXPORT (RECORDS KEYACTION) (CONSTANTS \NKEYS)) (RECORDS RING) (COMS (* ;  "can get rid of shiftstate after clients have been fixed") (RECORDS SHIFTSTATE) (GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP)) (CONSTANTS NRINGINDEXWORDS) (CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD)) (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE] (DECLARE%: EVAL@COMPILE (VARS \KEYNAMES)) (* ;; "\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun.") (VARS \ORIGKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DORADOKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS \MAIKOKEYACTIONS \MAIKOKEYACTIONST4 \MAIKO-JLE-KEYACTIONS \TOSHIBA-KEYACTIONS) (VARS (KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL)) (INITVARS (\KEYBOARD.META 256) (\MODIFIED.KEYACTIONS)) (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE) )) (GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META \MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS)) (COMS (* ; "Key interpretation") (FNS KEYACTION KEYACTIONTABLE KEYBOARDTYPE RESETKEYACTION \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS \KEYACTION1 KEYDOWNP KEYNUMBERP \KEYNAMETONUMBER MODIFY.KEYACTIONS METASHIFT SHIFTDOWNP) (* ;  "To support office style 1108 & 1186 keyboards") (FNS SETUP.OFFICE.KEYBOARD) (OPTIMIZERS \KEYNAMETONUMBER) (MACROS \TEMPCOPYTIMER) (* ;  "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.") (DECLARE%: DONTCOPY (EXPORT (OPTIMIZERS KEYDOWNP))) (EXPORT (MACROS XKEYDOWNP KEYDOWNP1 \NEWKEYDOWNP))) (COMS (* ; "A raw keyboard device/stream") (FNS \INIT.KEYBOARD.STREAM) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INIT.KEYBOARD.STREAM))) (EXPORT (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM))) (COMS (* ; "Hook for a periodic interrupt") (FNS \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \PERIODIC.INTERRUPTFRAME) (INITVARS (\KEYBUFFERING) (\PERIODIC.INTERRUPT) (\TIMER.INTERRUPT.PENDING) (\PERIODIC.INTERRUPT.FREQUENCY 77))) (LOCALVARS . T) [COMS (* ;  "cursor and mouse related functions.") (FNS \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN) (FNS CURSOR.INIT \CURSORDESTINATION \SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN CURSORPROP GETCURSORPROP PUTCURSORPROP \CURSORBITSPERPIXEL \CURSORIMAGEPROPNAME \CURSORMASKPROPNAME) (FNS CURSORCREATE CURSOR \CURSOR-VALID-P \CURSORUP \CURSORPOSITION \CURSORDOWN ADJUSTCURSORPOSITION CURSORPOSITION CURSORSCREEN CURSOREXIT FLIPCURSOR FLIPCURSORBAR LASTMOUSEX LASTMOUSEY CREATEPOSITION POSITIONP CURSORHOTSPOT) (PROPS (CURSORPROP ARGNAMES)) (INITVARS (\CURSORHOTSPOTX 0) (\CURSORHOTSPOTY 0) (\CURRENTCURSOR NIL) (\SOFTCURSORWIDTH NIL) (\SOFTCURSORHEIGHT NIL) (\SOFTCURSORP NIL) (\SOFTCURSORUPP NIL) (\SOFTCURSORUPBM NIL) (\SOFTCURSORDOWNBM NIL) (\SOFTCURSORBBT1 NIL) (\SOFTCURSORBBT2 NIL) (\SOFTCURSORBBT3 NIL) (\SOFTCURSORBBT4 NIL) (\SOFTCURSORBBT5 NIL) (\SOFTCURSORBBT6 NIL) (\CURSORSCREEN NIL) (\CURSORDESTINATION NIL) (\CURSORDESTHEIGHT 808) (\CURSORDESTWIDTH 1024) (\CURSORDESTRASTERWIDTH 64) (\CURSORDESTLINE 0) (\CURSORDESTLINEBASE NIL)) (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE) (FNS GETMOUSESTATE \EVENTKEYS) [EXPORT (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) (DECLARE%: EVAL@COMPILE (ADDVARS (GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD] (DECLARE%: DONTCOPY (EXPORT (MACROS \SETMOUSEXY)) (MACROS \XMOUSECOORD \YMOUSECOORD)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOR 'SETCURSOR) (MOVD '\CURSORPOSITION '\SETCURSORPOSITION)) (VARS (\SFPosition (CREATEPOSITION] [COMS (DECLARE%: DONTCOPY (RECORDS KEYBOARDEVENT) (CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS) \KEYBOARDEVENT.SIZE (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383] (COMS (FNS MACHINETYPE SETMAINTPANEL) (* ; "DLion beeper") (FNS BEEPON BEEPOFF)) (EXPORT (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)) (FNS WITHOUT-INTERRUPTS) (COMS (* ;  "Compile locked fns together for locality") (BLOCKS (NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP \DOMOUSECHORDING \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN))) [DECLARE%: DONTCOPY (ADDVARS [INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY \LOCKPAGES \DECODETRANSITION \SMASHLINK \INCUSECOUNT LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE \PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT \DOMOUSECHORDING \KEYBOARDOFF \TRACKCURSOR \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT) (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE \PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY \LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT \EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND ] (RDCOMS (FNS \SETIOPOINTERS] (PROP FILETYPE LLKEY) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML WITHOUT-INTERRUPTS ) (LAMA CURSORPROP METASHIFT MOUSECHORDWAIT]) (* ; "Access to keyboard") (DEFINEQ (BKSYSCHARCODE [LAMBDA (CHAR) (* rrb "30-Dec-83 11:56") (OR (\PUTSYSBUF CHAR) (PROGN (SETQ \LONGSYSBUF (NCONC \LONGSYSBUF (bind C while (SETQ C (\GETREALSYSBUF)) collect C))) (\PUTSYSBUF CHAR]) (\CLEARSYSBUF [LAMBDA (ALLFLG) (* mpl "27-Jun-85 20:04") (DECLARE (GLOBALVARS \PROCESSES)) (COND ((OR ALLFLG (TTY.PROCESSP)) (SETQ \LONGSYSBUF) (replace (RING READ) of \SYSBUFFER with 0))) (COND (ALLFLG (for PROC in \PROCESSES do (replace PROCTYPEAHEAD of PROC with NIL))) ((THIS.PROCESS) (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL]) (\GETKEY [LAMBDA NIL (* lmm "18-Apr-85 00:07") (DECLARE (GLOBALVARS \KEYBOARDWAIT1 \KEYBOARDWAIT2)) (COND [(AND (THIS.PROCESS) (fetch PROCTYPEAHEAD of (THIS.PROCESS))) (pop (fetch PROCTYPEAHEAD of (THIS.PROCESS] (T (WAIT.FOR.TTY) (OR (\GETSYSBUF) (GLOBALRESOURCE (\KEYBOARDWAITBOX) (* Busy-wait loop that gets next  character) (\CLOCK0 \KEYBOARDWAITBOX) (bind C do (COND ((SETQ C (\GETSYSBUF)) (\BOXIPLUS (LOCF (fetch KEYBOARDWAITTIME of \MISCSTATS)) (CLOCKDIFFERENCE \KEYBOARDWAITBOX)) (RETURN C))) (\TTYBACKGROUND) (\WAIT.FOR.TTY]) (\NSYSBUFCHARS [LAMBDA NIL (* JonL " 7-May-84 01:50") (* Tells how many characters can be \GETSYSBUFed.  Used by \SAVESYSBUF.) (IPLUS (LENGTH \LONGSYSBUF) (PROG ((R (fetch (RING READ) of \SYSBUFFER)) (W (fetch (RING WRITE) of \SYSBUFFER))) (RETURN (COND ((EQ 0 R) 0) ((IGREATERP W R) (IDIFFERENCE W R)) (T (IDIFFERENCE W (IDIFFERENCE R \SYSBUFSIZE]) (\SAVESYSBUF [LAMBDA NIL (* JonL " 7-May-84 01:50") (DECLARE (GLOBALVARS \SAVEDSYSBUFFER)) (PROG (TA (BUF \SAVEDSYSBUFFER) (NC (\NSYSBUFCHARS)) (J 0)) [COND ((TTY.PROCESSP) [COND ([AND (THIS.PROCESS) (SETQ TA (fetch PROCTYPEAHEAD of (THIS.PROCESS] (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL) (add NC (LENGTH TA)) [COND ((IGREATERP NC (NCHARS BUF)) (SETQ BUF (ALLOCSTRING NC] (for CH in TA do (RPLCHARCODE BUF (add J 1) CH))) ((IGREATERP NC (NCHARS BUF)) (SETQ BUF (ALLOCSTRING NC] (for I from (ADD1 J) to NC do (* Test on J means that we'll ignore extra chars typed since we got the  length. Test on \GETSYSBUF so we don't get screwed if buffer gets cleared  while during this loop) (RPLCHARCODE BUF I (OR (\GETSYSBUF) (PROGN (SETQ NC (SUB1 I)) (RETURN] (RETURN (AND (NOT (EQ 0 NC)) (SUBSTRING BUF 1 NC]) (\SYSBUFP [LAMBDA NIL (* JonL " 7-May-84 01:52") (OR [AND (TTY.PROCESSP) (OR \LONGSYSBUF (NOT (EQ 0 (fetch (RING READ) of \SYSBUFFER] (AND (THIS.PROCESS) (fetch PROCTYPEAHEAD of (THIS.PROCESS]) (\GETSYSBUF [LAMBDA NIL (* lmm " 9-JUL-83 00:56") (OR (AND \LONGSYSBUF (pop \LONGSYSBUF)) (\GETREALSYSBUF]) (\PUTSYSBUF [LAMBDA (CHAR) (* rmk%: "27-Nov-84 17:51") (PROG ((R (fetch (RING READ) of \SYSBUFFER)) (W (fetch (RING WRITE) of \SYSBUFFER))) (RETURN (COND ((EQ R W) (* Full) NIL) (T (\PUTBASEFAT \SYSBUFFER W CHAR) (AND (EQ 0 R) (replace (RING READ) of \SYSBUFFER with W)) (* Return random non-NIL value to  indicate success for BKSYSBUF) [replace (RING WRITE) of \SYSBUFFER with (COND ((EQ \SYSBUFFER.LAST W) \SYSBUFFER.FIRST) (T (ADD1 W] T]) (\PEEKSYSBUF [LAMBDA (STREAM) (* bvm%: " 8-Feb-85 17:50") (PROG (R) WAIT (until (\SYSBUFP) do (BLOCK)) (RETURN (if (TTY.PROCESSP) then (if \LONGSYSBUF then (CAR \LONGSYSBUF) elseif (NEQ (SETQ R (fetch (RING READ) of \SYSBUFFER)) 0) then (* Here's the vanilla case) (\GETBASEFAT \SYSBUFFER R) else (* Foo an interrupt could have sneaked in here and gobbled down the remaining  characters) (GO WAIT)) elseif (THIS.PROCESS) then (CAR (fetch PROCTYPEAHEAD of (THIS.PROCESS))) else (SHOULDNT]) ) (RPAQ? \LONGSYSBUF ) (RPAQ? \\KEYBOARDWAITBOX.GLOBALRESOURCE ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\KEYBOARDWAITBOX 'RESOURCES '(NEW (CREATECELL \FIXP] ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \SYSBUFSIZE 200) (CONSTANTS (\SYSBUFSIZE 200)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \GETREALSYSBUF MACRO [NIL (PROG ((R (fetch (RING READ) of \SYSBUFFER))) (RETURN (AND (NOT (EQ 0 R)) (PROG1 (\GETBASEFAT \SYSBUFFER R) (AND [EQ (fetch (RING WRITE) of \SYSBUFFER) (replace (RING READ) of \SYSBUFFER with (COND ((EQ \SYSBUFFER.LAST R) \SYSBUFFER.FIRST) (T (ADD1 R] (replace (RING READ) of \SYSBUFFER with 0)))]) ) ) (DECLARE%: DOCOPY DONTEVAL@LOAD (* ; "Here because it must be done in init before PROC loaded") (MOVD? 'NILL 'CARET) ) (* ; "Key handler") (DEFINEQ (\KEYBOARDINIT [LAMBDA NIL (* ; "Edited 19-Nov-87 16:46 by Snow") (DECLARE (GLOBALVARS \SAVEDSYSBUFFER)) (* ;  "Sets up keyboard decoding tables.") (SETQ \CURRENTKEYACTION (SETQ \DEFAULTKEYACTION (KEYACTIONTABLE))) (* ;  "added \commandkeyaction 11-19-87 WAS") (SETQ \COMMANDKEYACTION (KEYACTIONTABLE)) (SETQ \INTERRUPTSTATE (\ALLOCLOCKED 2)) (PROGN (SETQ \SYSBUFFER (\ALLOCBLOCK (FOLDHI (ADD1 \SYSBUFFER.LAST) WORDSPERCELL))) (replace (RING READ) of \SYSBUFFER with 0) (replace (RING WRITE) of \SYSBUFFER with \SYSBUFFER.FIRST)) (SETQ \SAVEDSYSBUFFER (ALLOCSTRING \SYSBUFSIZE NIL NIL T)) (SETQ \LASTUSERACTION (LOCF (fetch LASTUSERACTION of \MISCSTATS))) (PROGN (SETQ \KEYBOARDEVENTQUEUE (\ALLOCLOCKED (FOLDHI (PLUS \KEYBOARDEVENT.LAST \KEYBOARDEVENT.SIZE) WORDSPERCELL))) (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0) (replace (RING WRITE) of \KEYBOARDEVENTQUEUE with \KEYBOARDEVENT.FIRST)) (SETQ \LASTKEYSTATE (create KEYBOARDEVENT)) (SETQ \SHIFTSTATE (create SHIFTSTATE)) (SETQ \MOUSETIMERTEMP (SETUPTIMER 0 NIL 'TICKS)) (MOUSECHORDWAIT \MOUSECHORDMILLISECONDS) (\KEYBOARDON]) (\KEYBOARDEVENTFN [LAMBDA (FDEV EVENT EXTRA) (* ; "Edited 11-Oct-90 09:49 by jds") (DECLARE (GLOBALVARS \KEYBOARD.BEFORETYPE \DORADOKEYACTIONS \DLIONKEYACTIONS \MAIKO.BEFOREKEYTYPE)) (SELECTQ EVENT ((BEFORELOGOUT BEFOREMAKESYS BEFORESYSOUT BEFORESAVEVM) (SETQ \KEYBOARD.BEFORETYPE \MACHINETYPE) (SETQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF \InterfacePage ))) (SETQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE) (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY"))) NIL))) ((AFTERLOGOUT AFTERMAKESYS AFTERSYSOUT AFTERSAVEVM) (* ;  "Restarting a world. If we changed machines, fix up the key actions to match the new machine.") (* ; "(COND ((NEQ \\MACHINETYPE \\KEYBOARD.BEFORETYPE) ; Changed machines. Change Keyactions. (|for| X |in| (\\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS) |do| (KEYACTION (CAR X) (CDR X) \\COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \\DEFAULTKEYACTION)) (MOUSECHORDWAIT (MOUSECHORDWAIT))))") [COND ((OR (NEQ \MACHINETYPE \KEYBOARD.BEFORETYPE) (NEQ \MAIKO.XBEFORE? (SELECTQ (MACHINETYPE) (MAIKO (EQUAL "X" (UNIX-GETPARM "DISPLAY"))) NIL))) (* ;  "Changed machines. Change Keyactions.") [COND ((NEQ (MACHINETYPE) 'MAIKO) (* ;; "Non-SUN, so just change machine-specific key actions:") (for X in (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS) do (KEYACTION (CAR X) (CDR X) \COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \DEFAULTKEYACTION))) (T (* ;;  "On a SUN: Some keyactions contradict %"normal%" ones, so reset them all.") (for X in (APPEND \ORIGKEYACTIONS (  \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS )) do (KEYACTION (CAR X) (CDR X) \COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \DEFAULTKEYACTION] (MOUSECHORDWAIT (MOUSECHORDWAIT))) ((EQ (MACHINETYPE) 'MAIKO) (* ;; "Same machine type. SO only worry if we're on SUNs, where the keyboard type can differ between machines.") (COND ((NEQ \MAIKO.BEFOREKEYTYPE (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of \InterfacePage ))) (for X in (APPEND \ORIGKEYACTIONS (  \KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS )) do (KEYACTION (CAR X) (CDR X) \COMMANDKEYACTION) (KEYACTION (CAR X) (CDR X) \DEFAULTKEYACTION)) (MOUSECHORDWAIT (MOUSECHORDWAIT]) NIL]) (\ALLOCLOCKED [LAMBDA (NCELLS) (* lmm "20-Apr-85 13:08") (* allocate a block of NCELLS cells  and lock it) (PROG [(BLOCK (\ALLOCBLOCK NCELLS NIL (IMIN NCELLS CELLSPERPAGE] (\LOCKCELL BLOCK (FOLDHI (IPLUS (fetch (POINTER WORDINPAGE) of BLOCK) (UNFOLD NCELLS WORDSPERCELL)) WORDSPERPAGE)) (RETURN BLOCK]) (\SETIOPOINTERS [LAMBDA NIL (* ; "Edited 28-Apr-88 01:10 by MASINTER") (SELECTC (SETTOPVAL '\MACHINETYPE (fetch MachineType of \InterfacePage)) ((LIST \DOLPHIN \DORADO) (SETTOPVAL '\EM.MOUSEX (EMADDRESS MOUSEX.EM)) (SETTOPVAL '\EM.MOUSEY (EMADDRESS MOUSEY.EM)) (SETTOPVAL '\EM.CURSORX (EMADDRESS CURSORX.EM)) (SETTOPVAL '\EM.CURSORY (EMADDRESS CURSORY.EM)) (SETTOPVAL '\EM.REALUTILIN (EMADDRESS UTILIN.EM)) (SETTOPVAL '\EM.KBDAD0 (EMADDRESS KBDAD0.EM)) (SETTOPVAL '\EM.KBDAD1 (EMADDRESS KBDAD1.EM)) (SETTOPVAL '\EM.KBDAD2 (EMADDRESS KBDAD2.EM)) (SETTOPVAL '\EM.KBDAD3 (EMADDRESS KBDAD3.EM)) (SETTOPVAL '\EM.KBDAD4 (LOCF (fetch FAKEKBDAD4 of \InterfacePage))) (\PUTBASE \EM.KBDAD4 0 ALLUP) (SETTOPVAL '\EM.KBDAD5 (LOCF (fetch FAKEKBDAD5 OF \InterfacePage))) (\PUTBASE \EM.KBDAD5 0 ALLUP) (SETTOPVAL '\EM.DISPINTERRUPT (EMADDRESS DISPINTERRUPT.EM)) (SETTOPVAL '\EM.CURSORBITMAP (EMADDRESS CURSORBITMAP.EM)) (SETTOPVAL '\EM.DISPLAYHEAD (EMADDRESS DCB.EM)) (SETTOPVAL 'SCREENWIDTH (UNFOLD (fetch ScreenWidth of \InterfacePage) BITSPERWORD))) ((LIST \DANDELION \MAIKO) (SETTOPVAL '\EM.MOUSEX (fetch DLMOUSEXPTR of \IOPAGE)) (SETTOPVAL '\EM.MOUSEY (fetch DLMOUSEYPTR of \IOPAGE)) (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE)) (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE)) (PROGN (SETTOPVAL '\EM.REALUTILIN (fetch DLUTILINPTR of \IOPAGE)) (* ;; "Where the hardware bits live, vs. where the Lisp software sees them after reinterpretation by keyhandler") ) (SETTOPVAL '\EM.KBDAD0 (fetch DLKBDAD0PTR of \IOPAGE)) (SETTOPVAL '\EM.KBDAD1 (fetch DLKBDAD1PTR of \IOPAGE)) (SETTOPVAL '\EM.KBDAD2 (fetch DLKBDAD2PTR of \IOPAGE)) (SETTOPVAL '\EM.KBDAD3 (fetch DLKBDAD3PTR of \IOPAGE)) (SETTOPVAL '\EM.KBDAD4 (fetch DLKBDAD4PTR of \IOPAGE)) (SETTOPVAL '\EM.KBDAD5 (fetch DLKBDAD5PTR of \IOPAGE)) (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE)) (SETTOPVAL '\EM.CURSORBITMAP (fetch DLCURSORBITMAPPTR of \IOPAGE)) (SETTOPVAL '\EM.DISPLAYHEAD NIL) (SETTOPVAL 'SCREENWIDTH (SELECTC \MACHINETYPE (\MAIKO (SUBRCALL DSP-SCREENWIDTH)) 1024))) (\DAYBREAK (PROG ((KBDBASE (\DoveMisc.GetKBDBase))) (SETTOPVAL '\EM.KBDAD0 (\ADDBASE KBDBASE 1)) (SETTOPVAL '\EM.KBDAD1 (\ADDBASE KBDBASE 2)) (SETTOPVAL '\EM.KBDAD2 (\ADDBASE KBDBASE 3)) (SETTOPVAL '\EM.KBDAD3 (\ADDBASE KBDBASE 4)) (SETTOPVAL '\EM.KBDAD4 (\ADDBASE KBDBASE 5)) (SETTOPVAL '\EM.KBDAD5 (\ADDBASE KBDBASE 6)) (SETTOPVAL '\EM.MOUSEX (\DoveMisc.GetMouseXBase)) (SETTOPVAL '\EM.MOUSEY (\DoveMisc.GetMouseYBase)) (SETTOPVAL '\EM.CURSORBITMAP (\DoveDisplay.GetCursorBitmapBase)) (* These three set this way to  prevent address faults) (SETTOPVAL '\EM.DISPINTERRUPT (fetch DLDISPINTERRUPTPTR of \IOPAGE)) (SETTOPVAL '\EM.CURSORX (fetch DLCURSORXPTR of \IOPAGE)) (SETTOPVAL '\EM.CURSORY (fetch DLCURSORYPTR of \IOPAGE)) (PROGN (SETTOPVAL '\EM.REALUTILIN KBDBASE) (* Where the hardware bits live, vs. where the Lisp software sees them after  reinterpretation by keyhandler) ) (SETTOPVAL 'SCREENWIDTH (\DoveDisplay.ScreenWidth)))) (RAID)) (SETTOPVAL '\EM.UTILIN (LOCF (fetch (IFPAGE FAKEMOUSEBITS) of \InterfacePage]) (\KEYBOARDOFF [LAMBDA NIL (* ; "Edited 20-Apr-88 10:28 by MASINTER") (\PUTBASE \EM.DISPINTERRUPT 0 (LOGAND (LOGXOR 65535 \LispKeyMask) (\GETBASE \EM.DISPINTERRUPT 0))) (COND ((EQ \MACHINETYPE \MAIKO) (SUBRCALL KEYBOARDSTATE NIL]) (\KEYBOARDON [LAMBDA (NOCHECK) (* ; "Edited 24-Apr-88 00:03 by MASINTER") (\SETIOPOINTERS) (\PUTBASE \EM.DISPINTERRUPT 0 (LOGOR \LispKeyMask (\GETBASE \EM.DISPINTERRUPT 0))) (COND ((EQ \MACHINETYPE \MAIKO) (SUBRCALL KEYBOARDSTATE T]) (\KEYHANDLER [LAMBDA NIL (* lmm "30-MAR-83 20:40") (\KEYHANDLER1]) (\KEYHANDLER1 [LAMBDA NIL (* ; "Edited 30-Mar-88 10:40 by Snow") (PROG ((OLD0 ALLUP) (OLD1 ALLUP) (OLD2 ALLUP) (OLD3 ALLUP) (OLD4 ALLUP) (OLD5 ALLUP) (OLDU ALLUP) (OLDFAKEU ALLUP) (LOOPCNT 10) (PERIODCNT 60) (MOUSESTATE \DLMOUSE.UP) (MOUSETIMER (LOCF (fetch DLMOUSETIMER of \MISCSTATS))) (MOUSETEMP (LOCF (fetch DLMOUSETEMP of \MISCSTATS))) CURSORX CURSORY YHOT) (SETQ \KEYBUFFERING NIL) (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0) LP (\CONTEXTSWITCH \KbdFXP) [COND (\PERIODIC.INTERRUPT (* eventually can be replaced with  general timer mechanism) (COND ((IGREATERP PERIODCNT 0) (* Continue counting down to zero) (SETQ PERIODCNT (SUB1 PERIODCNT))) ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \PERIODIC.INTERRUPTFRAME)) (* When we've counted down, then keep trying to cause the interrupt, and  reset the counter when it finally happens) (SETQ PERIODCNT (SUB1 (OR \PERIODIC.INTERRUPT.FREQUENCY 1] [COND ((OR (NEQ (\GETBASE \EM.MOUSEX 0) CURSORX) (NEQ (\GETBASE \EM.MOUSEY 0) CURSORY)) (\TRACKCURSOR (SETQ CURSORX (\GETBASE \EM.MOUSEX 0)) (SETQ CURSORY (\GETBASE \EM.MOUSEY 0] [COND ((OR [COND ((OR (NEQ OLDU (\GETBASE \EM.REALUTILIN 0)) (COND ((AND (EQ MOUSESTATE \DLMOUSE.WAITING) (IGREATERP (\BOXIDIFFERENCE (\RCLK MOUSETEMP) MOUSETIMER) 0)) (* Timer expired on seeing both left and right down, so set state to normal) (SETQ MOUSESTATE \DLMOUSE.NORMAL) T))) (SETQ MOUSESTATE (\DOMOUSECHORDING (SETQ OLDU (\GETBASE \EM.REALUTILIN 0)) MOUSESTATE)) (NEQ OLDFAKEU (\GETBASE \EM.UTILIN 0] (NEQ OLD0 (\GETBASE \EM.KBDAD0 0)) (NEQ OLD1 (\GETBASE \EM.KBDAD1 0)) (NEQ OLD2 (\GETBASE \EM.KBDAD2 0)) (NEQ OLD3 (\GETBASE \EM.KBDAD3 0)) (NEQ OLD4 (\GETBASE \EM.KBDAD4 0)) (NEQ OLD5 (\GETBASE \EM.KBDAD5 0))) (COND ((EQ 0 (LOGAND (\GETBASE \EM.KBDAD2 0) 2114)) (* Ctrl-shift-DEL panic interrupt --  switch to TeleRaid immediately) (swap (fetch (IFPAGE TELERAIDFXP) of \InterfacePage) (fetch (IFPAGE KbdFXP) of \InterfacePage)) (\KEYBOARDOFF) (SETQ OLD2 (\GETBASE \EM.KBDAD2 0)) (GO LP))) [PROG ((W (fetch (RING WRITE) of \KEYBOARDEVENTQUEUE)) (R (fetch (RING READ) of \KEYBOARDEVENTQUEUE)) WPTR) (COND ((EQ R W) (* eventqueue full!) (RETURN))) (SETQ WPTR (\ADDBASE \KEYBOARDEVENTQUEUE W)) (\RCLK (LOCF (fetch TIME of WPTR))) [with KEYBOARDEVENT WPTR (PROGN (SETQ W0 (SETQ OLD0 (\GETBASE \EM.KBDAD0 0))) (SETQ W1 (SETQ OLD1 (\GETBASE \EM.KBDAD1 0))) (SETQ W2 (SETQ OLD2 (\GETBASE \EM.KBDAD2 0))) (SETQ W3 (SETQ OLD3 (\GETBASE \EM.KBDAD3 0))) (SETQ W4 (SETQ OLD4 (\GETBASE \EM.KBDAD4 0))) (SETQ W5 (SETQ OLD5 (\GETBASE \EM.KBDAD5 0))) (SETQ WU (SETQ OLDFAKEU (\GETBASE \EM.UTILIN 0] (COND ((EQ R 0) (* Queue was empty) (replace (RING READ) of \KEYBOARDEVENTQUEUE with W))) (replace (RING WRITE) of \KEYBOARDEVENTQUEUE with (COND ((IGEQ W \KEYBOARDEVENT.LAST) \KEYBOARDEVENT.FIRST) (T (IPLUS W \KEYBOARDEVENT.SIZE] (OR \KEYBUFFERING (SETQ \KEYBUFFERING T] [COND [\KEYBUFFERING (COND ((EQ \KEYBUFFERING T) (COND ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \DOBUFFEREDTRANSITIONS)) (SETQ \KEYBUFFERING 'STARTED) (* don't call until  \DOBUFFEREDTRANSITIONS is done) ] (T (COND (\PENDINGINTERRUPT (COND ((\CAUSEINTERRUPT \KbdFXP (FUNCTION \INTERRUPTFRAME)) (SETQ \PENDINGINTERRUPT] [COND ((AND (NEQ \MACHINETYPE \MAIKO) (ILEQ (SETQ LOOPCNT (SUB1 LOOPCNT)) 0)) (* Only do this once in a while) (SETQ LOOPCNT (COND ((\UPDATETIMERS) (* Timer was updated, so do it next time around, too, in case we just came  back from RAID or other bcpl code) 1) (T 20] (COND ([AND NIL \TIMER.INTERRUPT.PENDING (IGREATERP (\BOXIDIFFERENCE (\RCLK (LOCF (fetch DLMOUSETEMP of \MISCSTATS))) (LOCF (fetch DLMOUSETIMER of \MISCSTATS))) 0) (COND ((EQ \TIMER.INTERRUPT.PENDING '\MOUSECHANGE) (SETQ OLDU NIL) T) (T (\CAUSEINTERRUPT \KbdFXP (FUNCTION \TIMER.INTERRUPTFRAME] (SETQ \TIMER.INTERRUPT.PENDING))) (GO LP]) (\RESETKEYBOARD [LAMBDA NIL (* ; "Edited 30-Mar-88 10:07 by Snow") (\SETIOPOINTERS) (* Called with lisp keyboard disabled whenever Lisp is resumed from bcpl  logout or copysys.) (SETQ \KEYBUFFERING NIL) (COND ((OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK) (EQ \MACHINETYPE \MAIKO)) (* Initialize fake mouse bits to all  up) (\PUTBASE \EM.UTILIN 0 ALLUP))) (with KEYBOARDEVENT \LASTKEYSTATE (SETQ W0 (\GETBASE \EM.KBDAD0 0)) (SETQ W1 (\GETBASE \EM.KBDAD1 0)) (SETQ W2 (\GETBASE \EM.KBDAD2 0)) (SETQ W3 (\GETBASE \EM.KBDAD3 0)) (SETQ W4 (\GETBASE \EM.KBDAD4 0)) (SETQ W5 (\GETBASE \EM.KBDAD5 0)) (SETQ WU (\GETBASE \EM.REALUTILIN 0)) (SETQ LOCK (XKEYDOWNP 'LOCK)) (SETQ 1SHIFT NIL) (SETQ 2SHIFT NIL) (SETQ CTRL NIL) (SETQ META NIL) (SETQ FONT NIL) (SETQ USERMODE1 NIL) (SETQ USERMODE2 NIL) (SETQ USERMODE3 NIL) (SETQ MOUSESTATE \DLMOUSE.UP)) (SETQ \TIMER.INTERRUPT.PENDING) (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0) (replace (RING READ) of \SYSBUFFER with 0) (SETQ \LONGSYSBUF) (\DAYTIME0 \LASTUSERACTION) (\KEYBOARDON]) (\DOMOUSECHORDING [LAMBDA (REALUTILIN STATE) (* bvm%: " 9-Oct-85 11:24") (* Handles mouse transitions on a DLion.  REALUTILIN is the actual util word from the processor.  STATE is our internal state. Sets contents of \EM.UTILIN to reflect the  virtual mouse state, which may contain a middle mouse button even where there  is only a two-button mouse. Returns new state) (PROG (LRSTATE) [COND ((OR (NULL \MOUSECHORDTICKS) (EQ (SETQ LRSTATE (LOGXOR (LOGAND REALUTILIN \MOUSE.ALLBITS) \MOUSE.ALLBITS)) 0)) (* Not interpreting chording, or both LEFT and RIGHT are up --  real state and virtual state the same) (SETQ STATE \DLMOUSE.UP)) (T (* Either L or R or both are down, so have to decide about Middle) (SELECTC STATE ((LIST \DLMOUSE.UP \DLMOUSE.WAITING) (SETQ REALUTILIN (LOGOR REALUTILIN \MOUSE.LRBIT)) (* Turn off the L and/or R bits) (COND ((EQ LRSTATE \MOUSE.LRBIT) (* Both L and R down at once, interpret as MIDDLE without waiting) (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT) REALUTILIN)) (SETQ STATE \DLMOUSE.MIDDLE)) ((NEQ STATE \DLMOUSE.WAITING) (* Only one of L and R down. Set timer, and ignore the down bit for now) (\BOXIPLUS (\RCLK (LOCF (fetch DLMOUSETIMER of \MISCSTATS))) \MOUSECHORDTICKS) (SETQ STATE \DLMOUSE.WAITING)))) (\DLMOUSE.MIDDLE (* State is middle and at least one of L and R is still down, so consider it  to be still only middle) (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT) (LOGOR REALUTILIN \MOUSE.LRBIT))) (SELECTC LRSTATE (\MOUSE.LEFTBIT (* Right came up. Henceforth treat  right transparently) (SETQ STATE \DLMOUSE.MIDDLE&RIGHT)) (\MOUSE.RIGHTBIT (* Left came up. Henceforth treat  left transparently) (SETQ STATE \DLMOUSE.MIDDLE&LEFT)) NIL)) (\DLMOUSE.MIDDLE&RIGHT (* Only ignore LEFT) (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT) (LOGOR REALUTILIN \MOUSE.LEFTBIT)))) (\DLMOUSE.MIDDLE&LEFT (* Only ignore RIGHT) (SETQ REALUTILIN (LOGAND (LOGXOR ALLUP \MOUSE.MIDDLEBIT) (LOGOR REALUTILIN \MOUSE.RIGHTBIT)))) (PROGN (* Remaining state is \DLMOUSE.NORMAL which means treat mouse normally, and  the only interesting transition is back to \DLMOUSE.UP) ] (\PUTBASE \EM.UTILIN 0 REALUTILIN) (RETURN STATE]) (\DOTRANSITIONS [LAMBDA (KEYBASE OLD NEW) (* ; "Edited 1-Feb-92 11:59 by jds") (* ;; "OLD and NEW are keyboard state words that are known to have changed. KEYBASE is the number in hardware order of the key corresponding to the first bit in these words. This function figures out the indices of transitioning keys and calls the decoder.") (for I (BITMASK _ (LLSH 1 15)) from 0 to 15 do [OR (EQ 0 (LOGAND BITMASK (LOGXOR OLD NEW))) (\DECODETRANSITION (IPLUS I KEYBASE) (EQ 0 (LOGAND NEW BITMASK] (SETQ BITMASK (LRSH BITMASK 1))) T]) (\DECODETRANSITION [LAMBDA (KEYNUMBER DOWNFLG) (* ; "Edited 19-Nov-87 16:29 by Snow") (* ;; "KEYNUMBER is the key number in the hardware keyboard layout, DOWNFLG is T if the key just went down. PENDINGINTERRUPT, bound in \KEYHANDLER, is set to the decoded character if it is an interrupt.") (.NOTELASTUSERACTION) (PROG ((TI (\TRANSINDEX KEYNUMBER DOWNFLG)) (KEYSTATE \LASTKEYSTATE) ASCIICODE SHIFTED) (SELECTC (TRANSITIONFLAGS \CURRENTKEYACTION TI) (IGNORE.TF (RETURN)) (LOCKSHIFT.TF (* ;  "Take shift action if either Shift or Caps Lock is down") (IF (fetch (KEYBOARDEVENT SHIFTORLOCK) of KEYSTATE) THEN (SETQ SHIFTED T))) (NOLOCKSHIFT.TF (* ;  "Take shift action only when Shift is down") (IF (fetch (KEYBOARDEVENT SHIFT) of KEYSTATE) THEN (SETQ SHIFTED T))) (EVENT.TF (RETURN)) (1SHIFTUP.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with NIL) (RETURN)) (1SHIFTDOWN.TF (replace (KEYBOARDEVENT 1SHIFT) of KEYSTATE with T) (RETURN)) (2SHIFTUP.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with NIL) (RETURN)) (2SHIFTDOWN.TF (replace (KEYBOARDEVENT 2SHIFT) of KEYSTATE with T) (RETURN)) (LOCKUP.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with NIL) (RETURN)) (LOCKDOWN.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with T) (RETURN)) (LOCKTOGGLE.TF (replace (KEYBOARDEVENT LOCK) of KEYSTATE with (NOT (fetch (KEYBOARDEVENT LOCK) of KEYSTATE))) (RETURN)) (CTRLUP.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with NIL) (RETURN)) (CTRLDOWN.TF (replace (KEYBOARDEVENT CTRL) of KEYSTATE with T) (RETURN)) (METAUP.TF (replace (KEYBOARDEVENT META) of KEYSTATE with NIL) (RETURN)) (METADOWN.TF (replace (KEYBOARDEVENT META) of KEYSTATE with T) (RETURN)) (FONTUP.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with NIL) (RETURN)) (FONTDOWN.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with T) (RETURN)) (FONTTOGGLE.TF (replace (KEYBOARDEVENT FONT) of KEYSTATE with (NOT (fetch (KEYBOARDEVENT FONT) of KEYSTATE))) (RETURN)) (USERMODE1UP.TF (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with NIL) (RETURN)) (USERMODE1DOWN.TF (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with T) (RETURN)) (USERMODE1TOGGLE.TF (replace (KEYBOARDEVENT USERMODE1) of KEYSTATE with (NOT (fetch (KEYBOARDEVENT USERMODE1) of KEYSTATE))) (RETURN)) (USERMODE2UP.TF (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with NIL) (RETURN)) (USERMODE2DOWN.TF (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with T) (RETURN)) (USERMODE2TOGGLE.TF (replace (KEYBOARDEVENT USERMODE2) of KEYSTATE with (NOT (fetch (KEYBOARDEVENT USERMODE2) of KEYSTATE))) (RETURN)) (USERMODE3UP.TF (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with NIL) (RETURN)) (USERMODE3DOWN.TF (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with T) (RETURN)) (USERMODE3TOGGLE.TF (replace (KEYBOARDEVENT USERMODE3) of KEYSTATE with (NOT (fetch (KEYBOARDEVENT USERMODE3) of KEYSTATE))) (RETURN)) (SHOULDNT)) (* ;;  "Only the LOCKSHIFT and NOLOCKSHIFT cases make it to here, having set SHIFTED if appropriate.") [SETQ ASCIICODE (COND (SHIFTED (TRANSITIONSHIFTCODE \CURRENTKEYACTION TI)) (T (TRANSITIONCODE \CURRENTKEYACTION TI] [COND ((OR (fetch (KEYBOARDEVENT CTRL) of KEYSTATE) (fetch (KEYBOARDEVENT META) of KEYSTATE) (fetch (KEYBOARDEVENT FONT) of KEYSTATE)) [IF (IGREATERP ASCIICODE 127) THEN (* ;; "Non-ascii interpretation--what is cntrl/meta supposed to mean? Try using the original interpretation. This way we can type ^E or Meta-D even if Russian keyboard is set, but doesn't mess up simple ascii remappings, such as bs->del.") (SETQ ASCIICODE (COND (SHIFTED (TRANSITIONSHIFTCODE \COMMANDKEYACTION TI)) (T (TRANSITIONCODE \COMMANDKEYACTION TI] [COND ((fetch (KEYBOARDEVENT CTRL) of KEYSTATE) (SETQ ASCIICODE (LOGAND ASCIICODE \CTRLMASK] (COND ((AND (OR (fetch (KEYBOARDEVENT META) of KEYSTATE) (fetch (KEYBOARDEVENT FONT) of KEYSTATE)) (ILESSP ASCIICODE \KEYBOARD.META)) (SETQ ASCIICODE (LOGOR ASCIICODE \KEYBOARD.META] (COND ((ASSOC ASCIICODE (fetch INTERRUPTLIST of \CURRENTKEYACTION)) (SETQ PENDINGINTERRUPT T) (replace WAITINGINTERRUPT of \INTERRUPTSTATE with T) (replace INTCHARCODE of \INTERRUPTSTATE with ASCIICODE)) (T (\PUTSYSBUF ASCIICODE]) (MOUSECHORDWAIT [LAMBDA MSECS (* MPL "21-Jun-85 16:31") (DECLARE (GLOBALVARS \RCLKMILLISECOND)) (PROG1 (AND \MOUSECHORDTICKS \MOUSECHORDMILLISECONDS) (COND ((IGREATERP MSECS 0) (SETQ \MOUSECHORDTICKS (AND (ARG MSECS 1) (IMIN MAX.SMALLP (ITIMES (SETQ \MOUSECHORDMILLISECONDS (OR (SMALLP (ARG MSECS 1)) 50)) \RCLKMILLISECOND]) (\TRACKCURSOR [LAMBDA (CURSORX CURSORY) (* ; "Edited 30-Mar-88 11:11 by Snow") (DECLARE (GLOBALVARS \CURSORDESTHEIGHT \CURSORDESTWIDTH)) (.NOTELASTUSERACTION) [COND ((OR [COND ((IGEQ CURSORX (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX)) (* Large cursor values are either out of bounds to the right or are negative  values (16-bit bcpl signed numbers)) (COND [(IGREATERP CURSORX 32767) (* Cursor value is negative) (COND ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORX 65535)) \CURSORHOTSPOTX) 0) (* Cursor pos + hotspot is still off to the left  (the IPLUS is an optimization of (\XMOUSECOORD))%, so clip to effective zero) (SETQ CURSORX (COND ((EQ \MACHINETYPE \DANDELION) (* Temporary workaround) 0) (T (UNSIGNED (IMINUS \CURSORHOTSPOTX) BITSPERWORD] (T (SETQ CURSORX (SUB1 (IDIFFERENCE \CURSORDESTWIDTH \CURSORHOTSPOTX] (IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT HARDCURSORHEIGHT))) (* repeat test so that both X and Y will get clipped each cycle.  This keeps the cursor from moving off the screen.) [COND ((IGEQ CURSORY (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY)) (* Large cursor values are either out of bounds to the bottom or are negative  values (16-bit bcpl signed numbers)) (COND [(IGREATERP CURSORY 32767) (* Cursor value is negative) (COND ((ILESSP (IPLUS (SUB1 (IDIFFERENCE CURSORY 65535)) \CURSORHOTSPOTY) 0) (* Cursor pos + hotspot is still off to the top, so clip to effective zero) (SETQ CURSORY (COND ((OR (EQ \MACHINETYPE \DANDELION) (EQ \MACHINETYPE \DAYBREAK)) (* Temporary workaround) 0) (T (UNSIGNED (IMINUS \CURSORHOTSPOTY) BITSPERWORD] (T (SETQ CURSORY (SUB1 (IDIFFERENCE \CURSORDESTHEIGHT \CURSORHOTSPOTY] (* If need to clip mouse, do so here. \SETMOUSEXY MACRO takes dlion  complexities into account.) (COND ((NEQ \MACHINETYPE \MAIKO) (\SETMOUSEXY CURSORX CURSORY] (COND (\SOFTCURSORUPP (\SOFTCURSORPOSITION CURSORX CURSORY))) (COND ((EQ \MACHINETYPE \DAYBREAK) (* Have to kick DAYBREAK IOP to track the cursor.  *) (\DoveDisplay.SetCursorPosition CURSORX CURSORY))) (\PUTBASE \EM.CURSORX 0 CURSORX) (\PUTBASE \EM.CURSORY 0 CURSORY]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \SUN.TYPE3KEYBOARD 0) (RPAQQ \SUN.TYPE4KEYBOARD 1) (RPAQQ \SUN.JLEKEYBOARD 2) (RPAQQ \TOSHIBA.JIS 7) (CONSTANTS (\SUN.TYPE3KEYBOARD 0) (\SUN.TYPE4KEYBOARD 1) (\SUN.JLEKEYBOARD 2) (\TOSHIBA.JIS 7)) ) (RPAQ? \MOUSECHORDTICKS ) (RPAQ? \MOUSECHORDMILLISECONDS 50) (DECLARE%: DONTEVAL@LOAD DOCOPY (\KEYBOARDINIT) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS .NOTELASTUSERACTION MACRO (NIL (\BLT \LASTUSERACTION (LOCF (fetch SECONDSTMP of \MISCSTATS)) WORDSPERCELL))) ) (DECLARE%: EVAL@COMPILE (RPAQQ ALLUP 65535) (RPAQQ \CTRLMASK 159) (RPAQQ \METABIT 128) (CONSTANTS ALLUP \CTRLMASK \METABIT) ) (RPAQQ DLMOUSEBITS ((\MOUSE.LEFTBIT 4) (\MOUSE.RIGHTBIT 2) (\MOUSE.MIDDLEBIT 1) (\MOUSE.ALLBITS 7) (\MOUSE.LRBIT 6))) (DECLARE%: EVAL@COMPILE (RPAQQ \MOUSE.LEFTBIT 4) (RPAQQ \MOUSE.RIGHTBIT 2) (RPAQQ \MOUSE.MIDDLEBIT 1) (RPAQQ \MOUSE.ALLBITS 7) (RPAQQ \MOUSE.LRBIT 6) (CONSTANTS (\MOUSE.LEFTBIT 4) (\MOUSE.RIGHTBIT 2) (\MOUSE.MIDDLEBIT 1) (\MOUSE.ALLBITS 7) (\MOUSE.LRBIT 6)) ) (RPAQQ DLMOUSESTATES ((\DLMOUSE.UP 0) (\DLMOUSE.WAITING 1) (\DLMOUSE.NORMAL 2) (\DLMOUSE.MIDDLE 3) (\DLMOUSE.MIDDLE&LEFT 4) (\DLMOUSE.MIDDLE&RIGHT 5))) (DECLARE%: EVAL@COMPILE (RPAQQ \DLMOUSE.UP 0) (RPAQQ \DLMOUSE.WAITING 1) (RPAQQ \DLMOUSE.NORMAL 2) (RPAQQ \DLMOUSE.MIDDLE 3) (RPAQQ \DLMOUSE.MIDDLE&LEFT 4) (RPAQQ \DLMOUSE.MIDDLE&RIGHT 5) (CONSTANTS (\DLMOUSE.UP 0) (\DLMOUSE.WAITING 1) (\DLMOUSE.NORMAL 2) (\DLMOUSE.MIDDLE 3) (\DLMOUSE.MIDDLE&LEFT 4) (\DLMOUSE.MIDDLE&RIGHT 5)) ) (RPAQQ TRANSITIONFLAGS (ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF)) (DECLARE%: EVAL@COMPILE (RPAQQ ALTGRDOWN.TF 27) (RPAQQ ALTGRUP.TF 28) (RPAQQ ALTGRTOGGLE.TF 29) (RPAQQ CTRLDOWN.TF 5) (RPAQQ CTRLUP.TF 4) (RPAQQ DEADKEY.TF 30) (RPAQQ IGNORE.TF 0) (RPAQQ EVENT.TF 1) (RPAQQ LOCKDOWN.TF 8) (RPAQQ LOCKSHIFT.TF 2) (RPAQQ LOCKTOGGLE.TF 14) (RPAQQ LOCKUP.TF 7) (RPAQQ NOLOCKSHIFT.TF 3) (RPAQQ 1SHIFTDOWN.TF 6) (RPAQQ 1SHIFTUP.TF 9) (RPAQQ 2SHIFTDOWN.TF 11) (RPAQQ 2SHIFTUP.TF 10) (RPAQQ METADOWN.TF 13) (RPAQQ METAUP.TF 12) (RPAQQ FONTDOWN.TF 24) (RPAQQ FONTUP.TF 25) (RPAQQ FONTTOGGLE.TF 26) (RPAQQ USERMODE1UP.TF 15) (RPAQQ USERMODE1DOWN.TF 16) (RPAQQ USERMODE1TOGGLE.TF 17) (RPAQQ USERMODE2UP.TF 18) (RPAQQ USERMODE2DOWN.TF 19) (RPAQQ USERMODE2TOGGLE.TF 20) (RPAQQ USERMODE3UP.TF 21) (RPAQQ USERMODE3DOWN.TF 22) (RPAQQ USERMODE3TOGGLE.TF 23) (CONSTANTS ALTGRDOWN.TF ALTGRUP.TF ALTGRTOGGLE.TF CTRLDOWN.TF CTRLUP.TF DEADKEY.TF IGNORE.TF EVENT.TF LOCKDOWN.TF LOCKSHIFT.TF LOCKTOGGLE.TF LOCKUP.TF NOLOCKSHIFT.TF 1SHIFTDOWN.TF 1SHIFTUP.TF 2SHIFTDOWN.TF 2SHIFTUP.TF METADOWN.TF METAUP.TF FONTDOWN.TF FONTUP.TF FONTTOGGLE.TF USERMODE1UP.TF USERMODE1DOWN.TF USERMODE1TOGGLE.TF USERMODE2UP.TF USERMODE2DOWN.TF USERMODE2TOGGLE.TF USERMODE3UP.TF USERMODE3DOWN.TF USERMODE3TOGGLE.TF) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \TRANSINDEX MACRO ((KEYNUMBER DOWNFLG) (COND (DOWNFLG (IPLUS \NKEYS KEYNUMBER)) (T KEYNUMBER)))) (PUTPROPS ARMEDCODE MACRO ((TABLE CHAR) (\GETBASEBIT (fetch (KEYACTION ARMED) TABLE) CHAR))) (PUTPROPS TRANSITIONALTGRCODE MACRO ((TABLE CHAR) (\GETBASE (fetch (KEYACTION ALTGRAPHCODES) of TABLE) CHAR))) (PUTPROPS TRANSITIONSHIFTCODE MACRO ((TABLE CHAR) (\GETBASE (fetch (KEYACTION SHIFTCODES) TABLE) CHAR))) (PUTPROPS TRANSITIONCODE MACRO ((TABLE CHAR) (\GETBASE (fetch (KEYACTION CODES) TABLE) CHAR))) (PUTPROPS TRANSITIONFLAGS MACRO ((TABLE CHAR) (\GETBASEBYTE (fetch (KEYACTION FLAGS) TABLE) CHAR))) (PUTPROPS TRANSITIONDEADLIST MACRO ((TABLE CHAR SHIFTED) (\GETBASEPTR (fetch (KEYACTION DEADKEYLIST) of TABLE) (LLSH (COND (SHIFTED (IPLUS CHAR \NKEYS \NKEYS)) (T CHAR)) 1)))) (PUTPROPS CHECKFORDEADKEY MACRO [(KEYCODE TABLE CHAR SHIFTED) (LET ((CODE KEYCODE)) (COND [(IEQP CODE 65535) `(DEADKEY ,(\GETBASEPTR (fetch (KEYACTION DEADKEYLIST) of TABLE) (LLSH (COND (SHIFTED (IPLUS CHAR \NKEYS \NKEYS)) (T CHAR)) 1] (T CODE]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NKEYS 112) (CONSTANTS \NKEYS) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (BLOCKRECORD RING ((READ WORD) (WRITE WORD))) ) (* ; "can get rid of shiftstate after clients have been fixed") (DECLARE%: EVAL@COMPILE (ACCESSFNS SHIFTSTATE [[DUMMYSHIFT (NOT (EQ 0 (LOGAND (\GETBASEBYTE DATUM 0) (LOGOR 1 2] [DUMMY1SHIFT [NOT (EQ 0 (LOGAND 1 (\GETBASEBYTE DATUM 0] (\PUTBASEBYTE DATUM 0 (COND (NEWVALUE (LOGOR 1 (\GETBASEBYTE DATUM 0)) ) (T (LOGAND (\GETBASEBYTE DATUM 0) (LOGXOR \CHARMASK 1] [DUMMY2SHIFT [NOT (EQ 0 (LOGAND 2 (\GETBASEBYTE DATUM 0] (\PUTBASEBYTE DATUM 0 (COND (NEWVALUE (LOGOR 2 (\GETBASEBYTE DATUM 0)) ) (T (LOGAND (\GETBASEBYTE DATUM 0) (LOGXOR \CHARMASK 2] [DUMMYLOCK [NOT (EQ 0 (LOGAND 4 (\GETBASEBYTE DATUM 0] (\PUTBASEBYTE DATUM 0 (COND (NEWVALUE (LOGOR 4 (\GETBASEBYTE DATUM 0)) ) (T (LOGAND (\GETBASEBYTE DATUM 0) (LOGXOR \CHARMASK 4] [DUMMYSHIFTORLOCK (NOT (EQ 0 (\GETBASEBYTE DATUM 0))) (\PUTBASEBYTE DATUM 0 (COND (NEWVALUE (HELP " Can't turn on SHIFTORLOCK" )) (T 0] [DUMMYCTRL (NOT (EQ 0 (\GETBASEBYTE DATUM 1))) (\PUTBASEBYTE DATUM 1 (COND (NEWVALUE 1) (T 0] [DUMMYMETA (NOT (EQ 0 (\GETBASEBYTE DATUM 2))) (\PUTBASEBYTE DATUM 2 (COND (NEWVALUE 1) (T 0] [DUMMYFONT (NEQ 0 (LOGAND (LLSH 1 3) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 3) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 3] [DUMMYUSERMODE1 (NEQ 0 (LOGAND (LLSH 1 0) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 0) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 0] [DUMMYUSERMODE2 (NEQ 0 (LOGAND (LLSH 1 1) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 1) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 1] [DUMMYUSERMODE3 (NEQ 0 (LOGAND (LLSH 1 2) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 2) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 2] [DUMMYALTGRAPH (NEQ 0 (LOGAND (LLSH 1 4) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 4) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 4] (DUMMYDEADKEYPENDING (NEQ 0 (LOGAND (LLSH 1 5) (\GETBASEBYTE DATUM 3))) (\PUTBASEBYTE DATUM 3 (COND (NEWVALUE (LOGOR (LLSH 1 5) (\GETBASEBYTE DATUM 3))) (T (LOGAND (\GETBASEBYTE DATUM 3) (LOGXOR \CHARMASK (LLSH 1 5] (CREATE (\ALLOCBLOCK (FOLDHI 3 BYTESPERCELL)))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SHIFTSTATE \MOUSETIMERTEMP) ) (DECLARE%: EVAL@COMPILE (RPAQQ NRINGINDEXWORDS 2) (CONSTANTS NRINGINDEXWORDS) ) (DECLARE%: EVAL@COMPILE (RPAQ \SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD)) (RPAQ \SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE))) [CONSTANTS (\SYSBUFFER.FIRST (UNFOLD NRINGINDEXWORDS BYTESPERWORD)) (\SYSBUFFER.LAST (IPLUS \SYSBUFFER.FIRST (SUB1 \SYSBUFSIZE] ) ) (DECLARE%: EVAL@COMPILE (RPAQQ \KEYNAMES ((5 %% FIVE) (4 $ FOUR) (6 ~ SIX) (e E) (7 & SEVEN) (d D) (u U) (v V) (0 %) ZERO) (k K) (- %) (p P) (/ ?) (\ %| FONT LOOKS) (LF SAME) (BS <-) (3 %# THREE) (2 @ TWO) (w W) (q Q) (s S) (a A) (9 %( NINE) (i I) (x X) (o O) (l L) (%, <) (%' %") (%] }) (BLANK-MIDDLE OPEN DBK-HELP) (BLANK-TOP KEYBOARD DBK-META) (1 ! ONE) (ESC ESCAPE ->) (TAB =>) (f F) (CTRL PROP'S EDIT) (c C) (j J) (b B) (z Z) (LSHIFT) (%. >) (; %:) (CR <-%|) (_ ^) (DEL DELETE) (SKIP NEXT) (r R) (t T) (g G) (y Y) (h H) (8 * EIGHT) (n N) (m M) (LOCK) (SPACE) (%[ {) (= +) (RSHIFT) (BLANK-BOTTOM STOP) (MOVE) (UNDO) (UTIL0 SUN-KEYPAD=) (UTIL1 SUN-KEYPAD/) (UTIL2 SUPER/SUB) (UTIL3 CASE) (UTIL4 STRIKEOUT) (UTIL5 KEYPAD2) (UTIL6 KEYPAD3 PGDN) (UTIL7 SUN-LF) (PAD1 LEFTKEY CAPSLOCK KEYPAD+) (PAD2 LEFTMIDDLEKEY NUMLOCK KEYPAD-) (PAD3 MIDDLEKEY SCROLLLOCK KEYPAD*) (PAD4 RIGHTMIDDLEKEY BREAK KEYPAD/ SUN-PAUSE) (PAD5 RIGHTKEY DOIT PRTSC) (LEFT RED MOUSERED) (RIGHT BLUE MOUSEBLUE) (MIDDLE YELLOW MOUSEYELLOW) (MARGINS) (K41 KEYPAD7 HOME) (K42 KEYPAD8) (K43 KEYPAD9 PGUP) (K44 KEYPAD4) (K45 KEYPAD5) (K46 SUN-LEFT-SPACE) (K47 KEYPAD6) (K48 RIGHT-COMMAND SUN-RIGHT-SPACE) (COPY) (FIND) (AGAIN) (HELP) (DEF'N EXPAND) (K4E KEYPAD1 END) (ALWAYS-ON-1) (ALWAYS-ON-2) (CENTER) (K52 KEYPAD0 INS) (BOLD) (ITALICS) (UNDERLINE) (SUPERSCRIPT) (SUBSCRIPT) (LARGER SMALLER) (K59 KEYPAD%| KEYPAD.) (K5A KEYPAD\ KEYPAD, SUN-F10) (K5B SUN-F11) (K5C SUN-F12) (DEFAULTS SUN-PROP) (K5E SUN-PRTSC) (K5F SUN-OPEN))) ) (* ;; "\maikokeyactions does not contain keyactions of the form %"2,50%" because it breaks the loadup process on the sun." ) (RPAQQ \ORIGKEYACTIONS ((0 (53 "%%" NOLOCKSHIFT)) (1 (52 "$" NOLOCKSHIFT)) (2 (54 "~" NOLOCKSHIFT)) (3 ("e" "E" LOCKSHIFT)) (4 (55 "&" NOLOCKSHIFT)) (5 ("d" "D" LOCKSHIFT)) (6 ("u" "U" LOCKSHIFT)) (7 ("v" "V" LOCKSHIFT)) (8 (48 ")" NOLOCKSHIFT)) (9 ("k" "K" LOCKSHIFT)) (10 ("-" "-" NOLOCKSHIFT)) (11 ("p" "P" LOCKSHIFT)) (12 ("/" "?" NOLOCKSHIFT)) (13 ("\" "|" NOLOCKSHIFT)) (14 (10 96 NOLOCKSHIFT)) (15 (8 8 NOLOCKSHIFT)) (16 (51 "#" NOLOCKSHIFT)) (17 (50 "@" NOLOCKSHIFT)) (18 ("w" "W" LOCKSHIFT)) (19 ("q" "Q" LOCKSHIFT)) (20 ("s" "S" LOCKSHIFT)) (21 ("a" "A" LOCKSHIFT)) (22 (57 "(" NOLOCKSHIFT)) (23 ("i" "I" LOCKSHIFT)) (24 ("x" "X" LOCKSHIFT)) (25 ("o" "O" LOCKSHIFT)) (26 ("l" "L" LOCKSHIFT)) (27 ("," "<" NOLOCKSHIFT)) (28 ("'" "%"" NOLOCKSHIFT)) (29 ("]" "}" NOLOCKSHIFT)) (30 (194 194 NOLOCKSHIFT)) (31 (193 193 NOLOCKSHIFT)) (32 (49 "!" NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (34 (9 9 NOLOCKSHIFT)) (35 ("f" "F" LOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (37 ("c" "C" LOCKSHIFT)) (38 ("j" "J" LOCKSHIFT)) (39 ("b" "B" LOCKSHIFT)) (40 ("z" "Z" LOCKSHIFT)) (41 1SHIFTDOWN . 1SHIFTUP) (42 ("." ">" NOLOCKSHIFT)) (43 (";" ":" NOLOCKSHIFT)) (44 (13 13 NOLOCKSHIFT)) (45 ("_" "^" NOLOCKSHIFT)) (46 (127 535 NOLOCKSHIFT)) (47 ("(" "[" NOLOCKSHIFT)) (48 ("r" "R" LOCKSHIFT)) (49 ("t" "T" LOCKSHIFT)) (50 ("g" "G" LOCKSHIFT)) (51 ("y" "Y" LOCKSHIFT)) (52 ("h" "H" LOCKSHIFT)) (53 (56 "*" NOLOCKSHIFT)) (54 ("n" "N" LOCKSHIFT)) (55 ("m" "M" LOCKSHIFT)) (56 LOCKDOWN . LOCKUP) (57 (32 32 NOLOCKSHIFT)) (58 ("[" "{" NOLOCKSHIFT)) (59 ("=" "+" NOLOCKSHIFT)) (60 2SHIFTDOWN . 2SHIFTUP) (61 (195 195 NOLOCKSHIFT)) (63 (")" "]" NOLOCKSHIFT)) (77 EVENT . EVENT) (78 EVENT . EVENT) (79 EVENT . EVENT) (102 LOCKDOWN) (103 LOCKUP))) (RPAQQ \DLIONKEYACTIONS ((2 (54 "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (33 ("\" "|" NOLOCKSHIFT)) (45 (96 "~" NOLOCKSHIFT)) (OPEN METADOWN . METAUP) (PROP'S CTRLDOWN . CTRLUP) (SAME METADOWN . METAUP) (FIND ("2,3" "2,43" NOLOCKSHIFT)) (UNDO ("2,4" "2,44" NOLOCKSHIFT)) (STOP (5 7 NOLOCKSHIFT)) (MOVE) (COPY) (AGAIN ("2,10" "2,50" NOLOCKSHIFT)) (CENTER ("2,101" "2,141" NOLOCKSHIFT)) (BOLD ("2,102" "2,142" NOLOCKSHIFT)) (ITALICS ("2,103" "2,143" NOLOCKSHIFT)) (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT)) (SUPERSCRIPT ("2,113" "2,153" NOLOCKSHIFT)) (SUBSCRIPT ("2,114" "2,154" NOLOCKSHIFT)) (LARGER ("2,110" "2,150" NOLOCKSHIFT)) (DEFAULTS ("2,115" "2,155" NOLOCKSHIFT)) (93 (27 "2,64" NOLOCKSHIFT)) (47 ("2,22" "2,62" NOLOCKSHIFT)) (31 ("2,5" "2,45" NOLOCKSHIFT)) (92 ("2,1" "2,41" NOLOCKSHIFT)) (80 ("2,13" "2,53" NOLOCKSHIFT)) (FONT ("2,112" "2,152" NOLOCKSHIFT)))) (RPAQQ \DLIONOSDKEYACTIONS ((56 LOCKTOGGLE))) (RPAQQ \DORADOKEYACTIONS ((2 (54 "~" NOLOCKSHIFT)) (10 ("-" "-" NOLOCKSHIFT)) (13 ("\" "|" NOLOCKSHIFT)) (14 (10 96 NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (45 ("_" "^" NOLOCKSHIFT)))) (RPAQQ \DOVEKEYACTIONS ((2 (54 "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (56 CTRLDOWN . CTRLUP) (65 (27 27 NOLOCKSHIFT)) (71 (39 34 NOLOCKSHIFT)) (93 ("2,24" "2,64" NOLOCKSHIFT)) (108 (96 126 NOLOCKSHIFT)) (DBK-META METADOWN . METAUP) (DBK-HELP ("2,1" "2,41" NOLOCKSHIFT)) (SAME METADOWN . METAUP) (FIND ("2,3" "2,43" NOLOCKSHIFT)) (UNDO ("2,4" "2,44" NOLOCKSHIFT)) (STOP (5 7 NOLOCKSHIFT)) (EDIT ("2,5" "2,45" NOLOCKSHIFT)) (MOVE) (COPY) (AGAIN ("2,10" "2,50" NOLOCKSHIFT)) (CENTER ("2,101" "2,141" NOLOCKSHIFT)) (BOLD ("2,102" "2,142" NOLOCKSHIFT)) (ITALICS ("2,103" "2,143" NOLOCKSHIFT)) (CASE ("2,104" "2,144" NOLOCKSHIFT)) (STRIKEOUT ("2,105" "2,145" NOLOCKSHIFT)) (UNDERLINE ("2,106" "2,146" NOLOCKSHIFT)) (SUPER/SUB ("2,107" "2,147" NOLOCKSHIFT)) (LARGER ("2,110" "2,150" NOLOCKSHIFT)) (MARGINS ("2,111" "2,151" NOLOCKSHIFT)) (LOOKS ("2,112" "2,152" NOLOCKSHIFT)) (CAPSLOCK LOCKTOGGLE) (NUMLOCK ("2,11" "-" NOLOCKSHIFT)) (SCROLLLOCK ("2,12" 180 NOLOCKSHIFT)) (BREAK (2 184 NOLOCKSHIFT)) (DOIT ("2,13" "2,53" NOLOCKSHIFT)) (KEYPAD7 ("2,14" 55 NOLOCKSHIFT)) (KEYPAD8 (173 56 NOLOCKSHIFT)) (KEYPAD9 ("2,15" 57 NOLOCKSHIFT)) (KEYPAD4 (172 52 NOLOCKSHIFT)) (KEYPAD5 ("2,16" 53 NOLOCKSHIFT)) (KEYPAD6 (174 54 NOLOCKSHIFT)) (KEYPAD1 ("2,17" 49 NOLOCKSHIFT)) (KEYPAD2 (175 50 NOLOCKSHIFT)) (KEYPAD3 ("2,20" 51 NOLOCKSHIFT)) (KEYPAD0 ("2,21" 48 NOLOCKSHIFT)) (KEYPAD%| ("|" 46 NOLOCKSHIFT)) (KEYPAD\ ("\" 44 NOLOCKSHIFT)) (47 ("2,22" "2,62" NOLOCKSHIFT)))) (RPAQQ \DOVEOSDKEYACTIONS ((56 LOCKDOWN . LOCKUP) (36 CTRLDOWN . CTRLUP) (CAPSLOCK ("2,5" "2,45" NOLOCKSHIFT)))) (RPAQQ \MAIKOKEYACTIONS ((61 (5 7 NOLOCKSHIFT)) (91 (520 552 NOLOCKSHIFT)) (92 (513 545 NOLOCKSHIFT)) (30 (513 545 NOLOCKSHIFT)) (63 (516 548 NOLOCKSHIFT)) (93 (532 564 NOLOCKSHIFT)) (62) (111 (329 263 NOLOCKSHIFT)) (89) (90 (515 547 NOLOCKSHIFT)) (73 (521 521 NOLOCKSHIFT)) (74 (522 522 NOLOCKSHIFT)) (75 (2 2 NOLOCKSHIFT)) (81 (524 55 NOLOCKSHIFT)) (82 (173 56 NOLOCKSHIFT)) (83 (525 57 NOLOCKSHIFT)) (84 (172 52 NOLOCKSHIFT)) (85 (526 53 NOLOCKSHIFT)) (87 (174 54 NOLOCKSHIFT)) (94 (527 49 NOLOCKSHIFT)) (69 (175 50 NOLOCKSHIFT)) (70 (528 51 NOLOCKSHIFT)) (98 (529 48 NOLOCKSHIFT)) (76 (523 555 NOLOCKSHIFT)) (72 LOCKTOGGLE) (97 (577 609 NOLOCKSHIFT)) (99 (578 610 NOLOCKSHIFT)) (100 (579 611 NOLOCKSHIFT)) (67 (580 612 NOLOCKSHIFT)) (68 (581 613 NOLOCKSHIFT)) (101 (582 614 NOLOCKSHIFT)) (66 (583 615 NOLOCKSHIFT)) (104 (584 616 NOLOCKSHIFT)) (80 (585 617 NOLOCKSHIFT)) (13 (23 21 NOLOCKSHIFT)) (33 (27 27 NOLOCKSHIFT)) (65 (27 27 NOLOCKSHIFT)) (2 (54 94 NOLOCKSHIFT)) (10 (45 95 NOLOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (56 LOCKTOGGLE . IGNORE) (45 (96 126 NOLOCKSHIFT)) (31 METADOWN . METAUP) (14 METADOWN . METAUP) (71 (10 10 NOLOCKSHIFT)) (47 (530 562 NOLOCKSHIFT)) (105 (92 124 NOLOCKSHIFT)))) (RPAQQ \MAIKOKEYACTIONST4 ((61 ("^E" "^G" NOLOCKSHIFT)) (91 ("2,10" "2,50" NOLOCKSHIFT)) (92 ("2,1" "2,41" NOLOCKSHIFT)) (30 ("2,1" "2,41" NOLOCKSHIFT)) (109 ("2,25" "2,65" NOLOCKSHIFT)) (63 ("2,4" "2,44" NOLOCKSHIFT)) (14 METADOWN . METAUP) (93 ("2,24" "2,64" NOLOCKSHIFT)) (62) (111 ("1,111" "1,79" NOLOCKSHIFT)) (89) (90 ("2,3" "2,43" NOLOCKSHIFT)) (73 ("2,11" "2,11" NOLOCKSHIFT)) (74 ("2,12" "2,12" NOLOCKSHIFT)) (75 ("^B" "^B" NOLOCKSHIFT)) (81 ("2,14" 55 NOLOCKSHIFT)) (82 (173 56 NOLOCKSHIFT)) (83 ("2,15" 57 NOLOCKSHIFT)) (84 (172 52 NOLOCKSHIFT)) (85 ("2,16" 53 NOLOCKSHIFT)) (87 (174 54 NOLOCKSHIFT)) (94 ("2,17" 49 NOLOCKSHIFT)) (69 (175 50 NOLOCKSHIFT)) (70 ("2,20" 51 NOLOCKSHIFT)) (98 ("2,21" 48 NOLOCKSHIFT)) (76 ("2,13" "2,13" NOLOCKSHIFT)) (110 ("2,53" "2,53" NOLOCKSHIFT)) (72 LOCKTOGGLE) (97 ("2,101" "2,141" NOLOCKSHIFT)) (99 ("2,102" "2,142" NOLOCKSHIFT)) (100 ("2,103" "2,143" NOLOCKSHIFT)) (67 ("2,104" "2,144" NOLOCKSHIFT)) (68 ("2,105" "2,145" NOLOCKSHIFT)) (101 ("2,106" "2,146" NOLOCKSHIFT)) (66 ("2,107" "2,147" NOLOCKSHIFT)) (104 ("2,110" "2,150" NOLOCKSHIFT)) (80 ("2,111" "2,151" NOLOCKSHIFT)) (106 ("2,113" "2,153" NOLOCKSHIFT)) (107 ("2,114" "2,154" NOLOCKSHIFT)) (108 ("2,115" "2,155" NOLOCKSHIFT)) (13 ("^W" "^U" NOLOCKSHIFT)) (33 ("ESC" "ESC" NOLOCKSHIFT)) (64 IGNORE . IGNORE) (65 (27 27 NOLOCKSHIFT)) (95 IGNORE . IGNORE) (96 IGNORE . IGNORE) (102 IGNORE . IGNORE) (2 ("6" "^" NOLOCKSHIFT)) (10 ("-" "_" NOLOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (56 LOCKTOGGLE . IGNORE) (45 ("`" "~" NOLOCKSHIFT)) (31 METADOWN . METAUP) (71 (10 10 NOLOCKSHIFT)) (47 ("2,22" "2,62" NOLOCKSHIFT)) (86 IGNORE . IGNORE) (88 IGNORE . IGNORE) (105 ("\" "|" NOLOCKSHIFT)))) (RPAQQ \MAIKO-JLE-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT)) (4 ("7" "'" NOLOCKSHIFT)) (8 ("0" "0" NOLOCKSHIFT)) (10 ("\" "_" NOLOCKSHIFT)) (13 ("^W" "^U" NOLOCKSHIFT)) (14 METADOWN . METAUP) (15 (8 8 NOLOCKSHIFT)) (17 ("2" "%"" NOLOCKSHIFT)) (22 ("9" ")" NOLOCKSHIFT)) (28 (":" "*" NOLOCKSHIFT)) (29 ("[" "{" NOLOCKSHIFT)) (30 ("]" "}" NOLOCKSHIFT)) (31 METADOWN . METAUP) (33 ("ESC" "ESC" NOLOCKSHIFT)) (36 CTRLDOWN . CTRLUP) (43 (";" "+" NOLOCKSHIFT)) (45 ("^" "~" NOLOCKSHIFT)) (47 ("2,22" "2,62" NOLOCKSHIFT)) (53 ("8" "(" NOLOCKSHIFT)) (56 LOCKTOGGLE . IGNORE) (58 ("@" "`" NOLOCKSHIFT)) (59 ("-" "=" NOLOCKSHIFT)) (61 ("^E" "^G" NOLOCKSHIFT)) (62) (63 ("2,4" "2,44" NOLOCKSHIFT)) (64 ("2,14" 55 NOLOCKSHIFT)) (65 (27 27 NOLOCKSHIFT)) (66 ("2,107" "2,147" NOLOCKSHIFT)) (67 ("2,104" "2,144" NOLOCKSHIFT)) (69 ("2,13" "2,53" NOLOCKSHIFT)) (70 ("2,20" 51 NOLOCKSHIFT)) (71 (10 10 NOLOCKSHIFT)) (72 (766 766 NOLOCKSHIFT)) (73 ("2,11" "2,11" NOLOCKSHIFT)) (74 ("2,12" "2,12" NOLOCKSHIFT)) (75 ("^B" "^B" NOLOCKSHIFT)) (80 ("2,111" "2,151" NOLOCKSHIFT)) (81 ("2,14" 55 NOLOCKSHIFT)) (82 (173 56 NOLOCKSHIFT)) (83 ("2,15" 57 NOLOCKSHIFT)) (84 (172 52 NOLOCKSHIFT)) (85 ("2,16" 53 NOLOCKSHIFT)) (86 (765 765 NOLOCKSHIFT)) (87 (174 54 NOLOCKSHIFT)) (88 (770 771 NOLOCKSHIFT)) (90 ("2,3" "2,43" NOLOCKSHIFT)) (91 ("2,10" "2,50" NOLOCKSHIFT)) (92 ("2,1" "2,41" NOLOCKSHIFT)) (93 ("2,24" "2,64" NOLOCKSHIFT)) (96 IGNORE . IGNORE) (98 ("2,21" 48 NOLOCKSHIFT)) (99 ("2,102" "2,142" NOLOCKSHIFT)) (101 ("2,106" "2,146" NOLOCKSHIFT)) (102 IGNORE . IGNORE) (103 (767 768 NOLOCKSHIFT)) (104 ("2,110" "2,150" NOLOCKSHIFT)) (105 ("\" "|" NOLOCKSHIFT)) (106 ("2,113" "2,153" NOLOCKSHIFT)) (107 ("2,114" "2,154" NOLOCKSHIFT)) (108 ("2,115" "2,155" NOLOCKSHIFT)) (109 (769 769 NOLOCKSHIFT)) (110 ("2,53" "2,53" NOLOCKSHIFT)) (111 ("1,111" "1,79" NOLOCKSHIFT)))) (RPAQQ \TOSHIBA-KEYACTIONS ((2 ("6" "&" NOLOCKSHIFT)) (4 ("7" "'" NOLOCKSHIFT)) (17 ("2" "%"" NOLOCKSHIFT)) (53 ("8" "(" NOLOCKSHIFT)) (22 ("9" ")" NOLOCKSHIFT)) (8 ("0" "0" NOLOCKSHIFT)) (10 ("-" "=" NOLOCKSHIFT)) (59 ("^" "~" NOLOCKSHIFT)) (45 ("\" "|" NOLOCKSHIFT)) (58 ("@" "`" NOLOCKSHIFT)) (29 ("[" "{" NOLOCKSHIFT)) (105 ("]" "}" NOLOCKSHIFT)) (43 (";" "+" NOLOCKSHIFT)) (28 (":" "*" NOLOCKSHIFT)) (15 (23 95 NOLOCKSHIFT)) (13 (8 8 NOLOCKSHIFT)) (86 METADOWN . METAUP) (73 (530 562 NOLOCKSHIFT)) (88 ("2,24" "2,64" NOLOCKSHIFT)) (98 IGNORE . IGNORE) (75 ("2,11" "2,11" NOLOCKSHIFT)) (110 ("2,12" "2,12" NOLOCKSHIFT)) (74 ("^B" "^B" NOLOCKSHIFT)) (64 ("2,14" 55 NOLOCKSHIFT)) (65 (173 56 NOLOCKSHIFT)) (95 ("2,15" 57 NOLOCKSHIFT)) (81 (172 52 NOLOCKSHIFT)) (82 ("2,16" 53 NOLOCKSHIFT)) (83 (174 54 NOLOCKSHIFT)) (84 ("2,17" 49 NOLOCKSHIFT)) (85 (175 50 NOLOCKSHIFT)) (87 ("2,20" 51 NOLOCKSHIFT)) (94 ("2,21" 48 NOLOCKSHIFT)) (69 ("2,13" "2,53" NOLOCKSHIFT)) (70 LOCKTOGGLE))) (RPAQQ KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS NIL) (RPAQ? \KEYBOARD.META 256) (RPAQ? \MODIFIED.KEYACTIONS ) (DECLARE%: EVAL@COMPILE (ADDTOVAR GLOBALVARS \RCLKSECOND \LASTUSERACTION \LASTKEYSTATE) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SYSBUFFER \LONGSYSBUF \INTERRUPTSTATE \MODIFIED.KEYACTIONS \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING \CURRENTKEYACTION \COMMANDKEYACTION \DEFAULTKEYACTION \TIMER.INTERRUPT.PENDING \ORIGKEYACTIONS \KEYBOARD.META \MOUSECHORDMILLISECONDS \DORADOKEYACTIONS \DLIONKEYACTIONS \DLIONOSDKEYACTIONS \DOVEKEYACTIONS \DOVEOSDKEYACTIONS) ) (* ; "Key interpretation") (DEFINEQ (KEYACTION [LAMBDA (KEYNAME ACTIONS TABLE) (* ; "Edited 19-Nov-87 16:19 by Snow") (LET ((NUMB (OR (SMALLP KEYNAME) (\KEYNAMETONUMBER KEYNAME))) (TABLE (OR TABLE \CURRENTKEYACTION))) (OR (TYPE? KEYACTION TABLE) (\ILLEGAL.ARG TABLE)) (* ;  "Make sure he supplied a valid TABLE argument.") (CONS (\KEYACTION1 (\TRANSINDEX NUMB T) (AND ACTIONS (OR (CAR ACTIONS) 'IGNORE)) TABLE) (\KEYACTION1 (\TRANSINDEX NUMB NIL) (AND ACTIONS (OR (CDR ACTIONS) 'IGNORE)) TABLE]) (KEYACTIONTABLE [LAMBDA (OLD) (* ; "Edited 23-Mar-92 12:44 by jds") (* ;; "Create a fresh key action table (or copy OLD so it can be modified without danger). Returns a fresh keyaction table.") (COND (OLD (* ;; "He supplied an existing table; create a copy of it:") (OR (type? KEYACTION OLD) (\ILLEGAL.ARG OLD)) (* ;  "Make sure the argument IS a key action table.") (create KEYACTION copying OLD)) (T (* ;; "Create a completely fresh table, filled in from \ORIGKEYACTIONS, and the machine-specific exceptions:") (PROG1 (SETQ OLD (create KEYACTION)) (for X in (APPEND (COPY \ORIGKEYACTIONS) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS) KEYBOARD.APPLICATION-SPECIFIC-KEYACTIONS) do (KEYACTION (CAR X) (CDR X) OLD)))]) (KEYBOARDTYPE [LAMBDA NIL (* ; "Edited 6-Nov-95 15:35 by ") (* ; "Edited 17-Feb-95 14:36 by rmk:") (* ;  "Edited 16-Jun-92 11:03 by kaplan") (* ;; "Returns a symbol identifying the currently connected keyboard type. For now, infers it from the machine type, defaults to NIL (= unknown).") (LET ((MT (MACHINETYPE))) (SELECTQ MT (MAIKO (OR [CADR (SASSOC (L-CASE (UNIX-GETENV "LDEKBDTYPE")) '(("type3" SUN3) ("type4" SUN4) ("type5" SUN5] (MKATOM (U-CASE (UNIX-GETENV "LDEKBDTYPE"))) (AND (STREQUAL "dos" (UNIX-GETPARM "ARCH")) 'FULL-IBMPC))) ((DORADO DANDELION DOVE) MT) NIL]) (RESETKEYACTION [LAMBDA (TABLE FROM RESETINTERRUPTS) (* ; "Edited 19-Nov-87 16:55 by Snow") (* ;; "Resets the actions of key transitions in the keyaction table TABLE, copying in the actions from FROM. If RESETINTERRUPTS is true, also copies the interrupt-character settings from FROM.") (DECLARE (GLOBALVARS \DEFAULTKEYACTION)) (* ;; "do some type checking first.") (OR (type? KEYACTION TABLE) (\ILLEGAL.ARG TABLE)) (OR FROM (SETQ FROM \DEFAULTKEYACTION)) (OR (type? KEYACTION FROM) (\ILLEGAL.ARG TABLE)) (* ;; "do the resetting.") (\BLT (fetch (KEYACTION FLAGS) of TABLE) (fetch (KEYACTION FLAGS) of FROM) (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION FLAGS) of TABLE)) 1)) (\BLT (fetch (KEYACTION CODES) of TABLE) (fetch (KEYACTION CODES) of FROM) (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION CODES) of TABLE)) 1)) (\BLT (fetch (KEYACTION SHIFTCODES) of TABLE) (fetch (KEYACTION SHIFTCODES) of FROM) (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION SHIFTCODES) of TABLE)) 1)) [if RESETINTERRUPTS then (\BLT (fetch (KEYACTION ARMED) of TABLE) (fetch (KEYACTION ARMED) of FROM) (LLSH (\#BLOCKDATACELLS (fetch (KEYACTION ARMED) of TABLE)) 1)) (replace (KEYACTION INTERRUPTLIST) of TABLE with (COPY (fetch (KEYACTION INTERRUPTLIST) of FROM] TABLE]) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS [LAMBDA NIL (* ; "Edited 18-Sep-90 22:36 by jds") (* ;;  "Return a list of machine-specific keyactions appropriate to the machine you're running on.") (* ;; "Also take account (on Maiko implementations) of whether we're running under X or not -- the CAPS-LOCK key works differently.") (SELECTC \MACHINETYPE (\DORADO \DORADOKEYACTIONS) (\DANDELION \DLIONKEYACTIONS) (\MAIKO (LET [(CAPS-LOCK-ACTIONS (COND ((EQUAL (UNIX-GETPARM "DISPLAY") "X") '((56 LOCKDOWN . LOCKUP) (72 LOCKDOWN . LOCKUP] (* ;; "If we're running under X windows, CAPS-LOCK-ACTIONS, appended to the normal keyactions, will reset the keyboard appropriately.") (COND ((EQUAL \SUN.TYPE3KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of \InterfacePage))) (APPEND \MAIKOKEYACTIONS CAPS-LOCK-ACTIONS)) ((EQUAL \SUN.TYPE4KEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of \InterfacePage))) (APPEND \MAIKOKEYACTIONST4 CAPS-LOCK-ACTIONS)) ((EQUAL \SUN.JLEKEYBOARD (LOGAND 7 (fetch (IFPAGE DEVCONFIG) of \InterfacePage ))) \MAIKO-JLE-KEYACTIONS) ((EQUAL \TOSHIBA.JIS (LOGAND 7 (FETCH (IFPAGE DEVCONFIG) OF \InterfacePage ))) (* ; "Toshiba JIS") (APPEND \MAIKOKEYACTIONST4 \TOSHIBA-KEYACTIONS)) (T (* ; "default is type3") \MAIKOKEYACTIONS)))) (\DAYBREAK (* ;  "Moving to a daybreak. Need to distinguish among the various kinds of keyboard.") (* ;; "For now, we only distinguish between the office keyboards (1 = US, 2 = Euro, 3 = Japanese, 4 = ADM-3), and some yet-to-be-determined Lisp-keyboard number") (COND ((ILEQ (\DoveMisc.ReadKeyboardType) 4) (* ;  "It's an office keyboard. Set it up right!") (APPEND \DOVEKEYACTIONS \DOVEOSDKEYACTIONS)) (T (* ;  "Lisp keyboard. Leave the Dove keyactions as they were.") \DOVEKEYACTIONS))) NIL]) (\KEYACTION1 [LAMBDA (TI ACTION TABLE) (* ; "Edited 4-Mar-92 13:59 by jds") (PROG1 (SELECTC (TRANSITIONFLAGS TABLE TI) (IGNORE.TF 'IGNORE) ((LIST LOCKSHIFT.TF NOLOCKSHIFT.TF) [LET (CODE) (LIST (CHECKFORDEADKEY (TRANSITIONCODE TABLE TI) TABLE TI NIL) (CHECKFORDEADKEY (TRANSITIONSHIFTCODE TABLE TI) TABLE TI T) (TRANSITIONALTGRCODE TABLE TI) (COND ((EQ LOCKSHIFT.TF (TRANSITIONFLAGS TABLE TI)) 'LOCKSHIFT) (T 'NOLOCKSHIFT]) (EVENT.TF 'EVENT) (CTRLDOWN.TF 'CTRLDOWN) (CTRLUP.TF 'CTRLUP) (DEADKEY.TF (LIST 'DEADKEY (TRANSITIONDEADLIST TABLE TI) (TRANSITIONDEADLIST TABLE TI T))) (1SHIFTDOWN.TF '1SHIFTDOWN) (1SHIFTUP.TF '1SHIFTUP) (2SHIFTDOWN.TF '2SHIFTDOWN) (2SHIFTUP.TF '2SHIFTUP) (LOCKDOWN.TF 'LOCKDOWN) (LOCKUP.TF 'LOCKUP) (LOCKTOGGLE.TF 'LOCKTOGGLE) (METADOWN.TF 'METADOWN) (METAUP.TF 'METAUP) (FONTUP.TF 'FONTUP) (FONTDOWN.TF 'FONTDOWN) (FONTTOGGLE.TF 'FONTTOGGLE) (USERMODE1UP.TF 'USERMODE1UP) (USERMODE1DOWN.TF 'USERMODE1DOWN) (USERMODE1TOGGLE.TF 'USERMODE1TOGGLE) (USERMODE2UP.TF 'USERMODE2UP) (USERMODE2DOWN.TF 'USERMODE2DOWN) (USERMODE2TOGGLE.TF 'USERMODE2TOGGLE) (USERMODE3UP.TF 'USERMODE3UP) (USERMODE3DOWN.TF 'USERMODE3DOWN) (USERMODE3TOGGLE.TF 'USERMODE3TOGGLE) (ALTGRUP.TF 'ALTGRUP) (ALTGRDOWN.TF 'ALTGRDOWN) (ALTGRTOGGLE.TF 'ALTGRTOGGLE) (SHOULDNT)) [SELECTQ ACTION ((NIL NOCHANGE)) (IGNORE (change (TRANSITIONFLAGS TABLE TI) IGNORE.TF)) (EVENT (change (TRANSITIONFLAGS TABLE TI) EVENT.TF)) (CTRLUP (change (TRANSITIONFLAGS TABLE TI) CTRLUP.TF)) (CTRLDOWN (change (TRANSITIONFLAGS TABLE TI) CTRLDOWN.TF)) (1SHIFTUP (change (TRANSITIONFLAGS TABLE TI) 1SHIFTUP.TF)) (1SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI) 1SHIFTDOWN.TF)) (2SHIFTUP (change (TRANSITIONFLAGS TABLE TI) 2SHIFTUP.TF)) (2SHIFTDOWN (change (TRANSITIONFLAGS TABLE TI) 2SHIFTDOWN.TF)) (LOCKUP (change (TRANSITIONFLAGS TABLE TI) LOCKUP.TF)) (LOCKDOWN (change (TRANSITIONFLAGS TABLE TI) LOCKDOWN.TF)) (LOCKTOGGLE (change (TRANSITIONFLAGS TABLE TI) LOCKTOGGLE.TF)) (METAUP (change (TRANSITIONFLAGS TABLE TI) METAUP.TF)) (METADOWN (change (TRANSITIONFLAGS TABLE TI) METADOWN.TF)) (FONTUP (change (TRANSITIONFLAGS TABLE TI) FONTUP.TF)) (FONTDOWN (change (TRANSITIONFLAGS TABLE TI) FONTDOWN.TF)) (FONTTOGGLE (change (TRANSITIONFLAGS TABLE TI) FONTTOGGLE.TF)) (USERMODE1UP (change (TRANSITIONFLAGS TABLE TI) USERMODE1UP.TF)) (USERMODE1DOWN (change (TRANSITIONFLAGS TABLE TI) USERMODE1DOWN.TF)) (USERMODE1TOGGLE (change (TRANSITIONFLAGS TABLE TI) USERMODE1TOGGLE.TF)) (USERMODE2UP (change (TRANSITIONFLAGS TABLE TI) USERMODE2UP.TF)) (USERMODE2DOWN (change (TRANSITIONFLAGS TABLE TI) USERMODE2DOWN.TF)) (USERMODE2TOGGLE (change (TRANSITIONFLAGS TABLE TI) USERMODE2TOGGLE.TF)) (USERMODE3UP (change (TRANSITIONFLAGS TABLE TI) USERMODE3UP.TF)) (USERMODE3DOWN (change (TRANSITIONFLAGS TABLE TI) USERMODE3DOWN.TF)) (USERMODE3TOGGLE (change (TRANSITIONFLAGS TABLE TI) USERMODE3TOGGLE.TF)) (ALTGRUP (change (TRANSITIONFLAGS TABLE TI) ALTGRUP.TF)) (ALTGRDOWN (change (TRANSITIONFLAGS TABLE TI) ALTGRDOWN.TF)) (ALTGRTOGGLE (change (TRANSITIONFLAGS TABLE TI) ALTGRTOGGLE.TF)) (PROG (CODE SHIFTCODE ALTGRCODE ACT DEAD SHIFTDEAD) (COND ([AND [OR (AND (AND (LISTP (CAR (LISTP ACTION))) (EQ (CAAR (LISTP ACTION)) 'DEADKEY)) [SETQ DEAD (for PAIR in (CADAR (LISTP ACTION)) collect (* ;;  "Make sure we'll take string charcode specs in the deadkey list.") (CONS (OR (AND (\CHARCODEP (CAR PAIR)) (CAR PAIR)) (APPLY* (FUNCTION CHARCODE) (CAR PAIR))) (OR (AND (\CHARCODEP (CDR PAIR)) (CDR PAIR)) (APPLY* (FUNCTION CHARCODE) (CDR PAIR] (SETQ CODE 65535)) [\CHARCODEP (SETQ CODE (\GETCHARCODE (CAR (LISTP ACTION] (SETQ CODE (APPLY* (FUNCTION CHARCODE) (CAR (LISTP ACTION] [OR (AND (AND (LISTP (CADR (LISTP ACTION))) (EQ (CAADR (LISTP ACTION)) 'DEADKEY)) [SETQ SHIFTDEAD (for PAIR in (CADADR (LISTP ACTION)) collect (CONS (OR (AND (\CHARCODEP (CAR PAIR)) (CAR PAIR)) (APPLY* (FUNCTION CHARCODE) (CAR PAIR))) (OR (AND (\CHARCODEP (CDR PAIR)) (CDR PAIR)) (APPLY* (FUNCTION CHARCODE) (CDR PAIR] (SETQ SHIFTCODE 65535) (SETQ ACT (CDR ACTION))) [\CHARCODEP (SETQ SHIFTCODE (\GETCHARCODE (CAR (SETQ ACT (LISTP (CDR ACTION] (SETQ SHIFTCODE (APPLY* (FUNCTION CHARCODE) (CAR ACT] (OR (NULL (SETQ ACT (CDR ACT))) (LISTP ACT)) (SELECTQ (CAR ACT) ((LOCKSHIFT T) (change (TRANSITIONFLAGS TABLE TI) LOCKSHIFT.TF)) ((NOLOCKSHIFT NIL) (change (TRANSITIONFLAGS TABLE TI) NOLOCKSHIFT.TF)) (AND [OR [\CHARCODEP (SETQ ALTGRCODE (\GETCHARCODE (CAR ACT] (SETQ ALTGRCODE (APPLY* (FUNCTION CHARCODE) (CAR ACT] (OR (NULL (SETQ ACT (CDR ACT))) (LISTP ACT)) (SELECTQ (CAR ACT) ((LOCKSHIFT T) (change (TRANSITIONFLAGS TABLE TI) LOCKSHIFT.TF)) ((NOLOCKSHIFT NIL) (change (TRANSITIONFLAGS TABLE TI) NOLOCKSHIFT.TF)) NIL] (change (TRANSITIONCODE TABLE TI) CODE) (change (TRANSITIONSHIFTCODE TABLE TI) SHIFTCODE) (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE) (LLSH TI 1) DEAD) (\RPLPTR (fetch (KEYACTION DEADKEYLIST) of TABLE) (LLSH (IPLUS \NKEYS \NKEYS TI) 1) SHIFTDEAD) (AND ALTGRCODE (change (TRANSITIONALTGRCODE TABLE TI) ALTGRCODE))) (T (\ILLEGAL.ARG ACTION])]) (KEYDOWNP [LAMBDA (KEYNAME) (* lmm "18-Apr-85 02:09") (* T if the indicated key is  instantaneously down.) (\NEWKEYDOWNP (\KEYNAMETONUMBER KEYNAME]) (KEYNUMBERP [LAMBDA (X) (* ; "Edited 16-Jan-96 13:16 by rmk") (AND (SMALLP X) (IGEQ X 0) (ILESSP X \NKEYS) X]) (\KEYNAMETONUMBER [LAMBDA (KEYNAME) (* rmk%: " 2-SEP-83 10:29") (DECLARE (GLOBALVARS \KEYNAMES)) (* The fast case is when KEYNAME is  lower-case) (for X N in \KEYNAMES as I from 0 when (EQMEMB KEYNAME X) do (RETURN I) finally (RETURN (OR (AND (NEQ KEYNAME (SETQ N (L-CASE KEYNAME))) (for Y in \KEYNAMES as I from 0 when (EQMEMB N Y) do (RETURN I))) (\ILLEGAL.ARG KEYNAME]) (MODIFY.KEYACTIONS [LAMBDA (KeyActions SaveCurrent?) (* ; "Edited 2-Feb-89 15:38 by GADENER") (PROG1 [if SaveCurrent? then (SETQ \MODIFIED.KEYACTIONS (for ITEM in KeyActions collect (CONS (CAR ITEM) (KEYACTION (CAR ITEM] [for action in KeyActions do (for table in '(\CURRENTKEYACTION \COMMANDKEYACTION) do (KEYACTION (CAR action) (CDR action) (EVAL table])]) (METASHIFT [LAMBDA FLG (* ; "Edited 19-Nov-87 16:59 by Snow") (* ;; "Sets interpretation of swat key to first arg, where T means meta-shift, NIL means original setting. Returns previous setting") (PROG ((METASTATUS '(METADOWN . METAUP)) OLDSETTING) [SETQ OLDSETTING (KEYACTION 'BLANK-BOTTOM (AND (IGREATERP FLG 0) (COND ((EQ (ARG FLG 1) T) METASTATUS) (T (OR (ARG FLG 1) (CDR (ASSOC 'BLANK-BOTTOM \ORIGKEYACTIONS] (RETURN (COND ((EQUAL OLDSETTING METASTATUS) T) (T OLDSETTING]) (SHIFTDOWNP [LAMBDA (SHIFT) (* lmm "18-Apr-85 01:07") (* Tells whether a given shift is  down) (SELECTQ SHIFT (LOCK (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE)) (META (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE)) (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE))) (1SHIFT (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE)) (2SHIFT (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE)) (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT 1SHIFT) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT 2SHIFT) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE))) (CTRL (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE)) (FONT (fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE)) (USERMODE1 (fetch (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE)) (USERMODE2 (fetch (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE)) (USERMODE3 (fetch (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE)) (\ILLEGAL.ARG SHIFT]) ) (* ; "To support office style 1108 & 1186 keyboards") (DEFINEQ (SETUP.OFFICE.KEYBOARD [LAMBDA NIL (* jds " 8-Oct-85 16:27") (SELECTQ (MACHINETYPE) (DANDELION (MODIFY.KEYACTIONS \DLIONOSDKEYACTIONS)) (DOVE (MODIFY.KEYACTIONS \DOVEOSDKEYACTIONS)) NIL]) ) (DEFOPTIMIZER \KEYNAMETONUMBER (&REST X) [LET [(CE (CONSTANTEXPRESSIONP (CAR X] (COND (CE (\KEYNAMETONUMBER (CAR CE))) (T 'IGNOREMACRO]) (DECLARE%: EVAL@COMPILE (PUTPROPS \TEMPCOPYTIMER MACRO ((X) (PROGN (\BLT \MOUSETIMERTEMP (LOCF X) WORDSPERCELL) \MOUSETIMERTEMP))) ) (* ; "Don't copy this optimizer since it expands out to \getbasebit, but do exportit.") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DEFOPTIMIZER KEYDOWNP (KEYNAME) `(\NEWKEYDOWNP (\KEYNAMETONUMBER ,KEYNAME))) (* "END EXPORTED DEFINITIONS") ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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)))) ) (* "END EXPORTED DEFINITIONS") (* ; "A raw keyboard device/stream") (DEFINEQ (\INIT.KEYBOARD.STREAM [LAMBDA NIL (* ; "Edited 4-Sep-87 10:25 by jds") (* ;; "Initialize the %"Keyboard%" device: Set up the FDEV and the prototype keyboard stream in their respective global variables.") (DECLARE (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM)) [\DEFINEDEVICE 'KEYBOARD (SETQ \KEYBOARD.DEVICE (create FDEV DEVICENAME _ 'KEYBOARD CLOSEFILE _ (FUNCTION NILL) EVENTFN _ (FUNCTION \KEYBOARDEVENTFN) BIN _ (FUNCTION \GETKEY) PEEKBIN _ (FUNCTION \PEEKSYSBUF) READP _ (FUNCTION \SYSBUFP) EOFP _ (FUNCTION NILL) GETFILENAME _ (FUNCTION (LAMBDA (X MODE) (if (EQ MODE 'INPUT) then \KEYBOARD.STREAM] (SETQ \KEYBOARD.STREAM (create STREAM USERCLOSEABLE _ NIL USERVISIBLE _ NIL FULLFILENAME _ '{KEYBOARD} DEVICE _ \KEYBOARD.DEVICE ACCESS _ 'INPUT]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\INIT.KEYBOARD.STREAM) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \KEYBOARD.DEVICE \KEYBOARD.STREAM) ) (* "END EXPORTED DEFINITIONS") (* ; "Hook for a periodic interrupt") (DEFINEQ (\DOBUFFEREDTRANSITIONS [LAMBDA (\INTERRUPTABLE) (DECLARE (SPECVARS \INTERRUPTABLE)) (* ; "Edited 1-Feb-92 11:59 by jds") (SETQ \KEYBUFFERING 'INPROGRESS) (LET ((PENDINGINTERRUPT)) (DECLARE (SPECVARS PENDINGINTERRUPT)) (* ; "Used by \DECODETRANSITION") [bind R RPTR until (EQ 0 (SETQ R (fetch (RING READ) of \KEYBOARDEVENTQUEUE)) ) do (SETQ RPTR (\ADDBASE \KEYBOARDEVENTQUEUE R)) (* ; "get pointer to this event") (* ;  "handle simple keyboard words by calling \DOTRANSITIONS for each word") [COND ((NEQ (fetch (KEYBOARDEVENT W0) of RPTR) (fetch (KEYBOARDEVENT W0) of \LASTKEYSTATE )) (\DOTRANSITIONS 0 (fetch (KEYBOARDEVENT W0) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W0) of RPTR)) (replace (KEYBOARDEVENT W0) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W0) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT W1) of RPTR) (fetch (KEYBOARDEVENT W1) of \LASTKEYSTATE )) (\DOTRANSITIONS 16 (fetch (KEYBOARDEVENT W1) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W1) of RPTR)) (replace (KEYBOARDEVENT W1) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W1) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT W2) of RPTR) (fetch (KEYBOARDEVENT W2) of \LASTKEYSTATE )) (\DOTRANSITIONS 32 (fetch (KEYBOARDEVENT W2) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W2) of RPTR)) (replace (KEYBOARDEVENT W2) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W2) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT W3) of RPTR) (fetch (KEYBOARDEVENT W3) of \LASTKEYSTATE )) (\DOTRANSITIONS 48 (fetch (KEYBOARDEVENT W3) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W3) of RPTR)) (replace (KEYBOARDEVENT W3) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W3) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT W4) of RPTR) (fetch (KEYBOARDEVENT W4) of \LASTKEYSTATE )) (\DOTRANSITIONS 80 (fetch (KEYBOARDEVENT W4) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W4) of RPTR)) (replace (KEYBOARDEVENT W4) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W4) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT W5) of RPTR) (fetch (KEYBOARDEVENT W5) of \LASTKEYSTATE )) (\DOTRANSITIONS 96 (fetch (KEYBOARDEVENT W5) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT W5) of RPTR)) (replace (KEYBOARDEVENT W5) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT W5) of RPTR] [COND ((NEQ (fetch (KEYBOARDEVENT WU) of RPTR) (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE )) (\DOTRANSITIONS 64 (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE) (fetch (KEYBOARDEVENT WU) of RPTR)) (replace (KEYBOARDEVENT WU) of \LASTKEYSTATE with (fetch (KEYBOARDEVENT WU) of RPTR] (* ;;; "now remove event from queue") (COND ((EQ [replace (RING READ) of \KEYBOARDEVENTQUEUE with (COND ((IGEQ R \KEYBOARDEVENT.LAST) \KEYBOARDEVENT.FIRST) (T (IPLUS \KEYBOARDEVENT.SIZE R] (fetch (RING WRITE) of \KEYBOARDEVENTQUEUE )) (replace (RING READ) of \KEYBOARDEVENTQUEUE with 0] (PROGN (* ; "update dummy shift state") (replace DUMMY1SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 1SHIFT ) of \LASTKEYSTATE )) (replace DUMMY2SHIFT of \SHIFTSTATE with (fetch (KEYBOARDEVENT 2SHIFT ) of \LASTKEYSTATE )) (replace DUMMYLOCK of \SHIFTSTATE with (fetch (KEYBOARDEVENT LOCK) of \LASTKEYSTATE)) (replace DUMMYCTRL of \SHIFTSTATE with (fetch (KEYBOARDEVENT CTRL) of \LASTKEYSTATE)) (replace DUMMYMETA of \SHIFTSTATE with (fetch (KEYBOARDEVENT META) of \LASTKEYSTATE)) (replace DUMMYFONT of \SHIFTSTATE with (fetch (KEYBOARDEVENT FONT) of \LASTKEYSTATE)) (replace DUMMYUSERMODE1 of \SHIFTSTATE with (fetch (KEYBOARDEVENT USERMODE1) of \LASTKEYSTATE)) (replace DUMMYUSERMODE2 of \SHIFTSTATE with (fetch (KEYBOARDEVENT USERMODE2) of \LASTKEYSTATE)) (replace DUMMYUSERMODE3 of \SHIFTSTATE with (fetch (KEYBOARDEVENT USERMODE3) of \LASTKEYSTATE)) (replace DUMMYALTGRAPH of \SHIFTSTATE with (fetch (KEYBOARDEVENT ALTGRAPH) of \LASTKEYSTATE)) (replace DUMMYDEADKEYPENDING of \SHIFTSTATE with (fetch ( KEYBOARDEVENT DEADKEYPENDING ) of \LASTKEYSTATE) )) (* ;; "Note: there is a window between the test of READ above and the setting of \KEYBUFFERING below where a keyboard transition can be ignored until the next transition causes \KEYBUFFERING to be set again") (COND ((NOT (OR PENDINGINTERRUPT \PENDINGINTERRUPT)) (* ;  "No interrupt noticed this time or on any previous invocation") (SETQ \KEYBUFFERING NIL)) ((NOT (\GETBASEPTR (\STKSCAN '\INTERRUPTABLE) 0)) (* ;  "We're not interruptable, so try again later") (SETQ \PENDINGINTERRUPT T) (SETQ \KEYBUFFERING NIL)) (T (SETQ \PENDINGINTERRUPT NIL) (SETQ \KEYBUFFERING NIL) (LET ((\INTERRUPTABLE T)) (INTERRUPTED]) (\TIMER.INTERRUPTFRAME [LAMBDA NIL (* lmm "22-Apr-85 09:47") (* place holder for periodic  interrupts) (if NIL then (APPLY* \PERIODIC.INTERRUPT) (if \PERIODIC.INTERRUPT then (SETUPTIMER (QUOTIENT (TIMES \PERIODIC.INTERRUPT.FREQUENCY \RCLKSECOND) 77) (LOCF (fetch DLMOUSETIMER of \MISCSTATS)) 'TICKS) (SETQ \TIMER.INTERRUPT.PENDING T]) (\PERIODIC.INTERRUPTFRAME [LAMBDA NIL (DECLARE (GLOBALVARS \PERIODIC.INTERRUPT)) (* lmm "16-Jul-85 16:22") (LET ((FN \PERIODIC.INTERRUPT)) (AND FN (SPREADAPPLY* FN]) ) (RPAQ? \KEYBUFFERING ) (RPAQ? \PERIODIC.INTERRUPT ) (RPAQ? \TIMER.INTERRUPT.PENDING ) (RPAQ? \PERIODIC.INTERRUPT.FREQUENCY 77) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (* ; "cursor and mouse related functions.") (DEFINEQ (\HARDCURSORUP [LAMBDA (NEWCURSOR INVERTFLG) (* ; "Edited 2-Jan-2000 18:10 by kaplan") (* ;  "version of \CURSORUP that knows about the possibility of the cursor being on the color screen.") (PROG (IMAGE) (SETQ \SOFTCURSORP NIL) (SETQ \CURRENTCURSOR NEWCURSOR) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR)) [COND ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE) (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION))) (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION )) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR] (BITBLT IMAGE 0 0 CursorBitMap 0 (IDIFFERENCE HARDCURSORHEIGHT (fetch (BITMAP BITMAPHEIGHT ) of IMAGE)) HARDCURSORWIDTH HARDCURSORHEIGHT (COND (INVERTFLG 'INVERT) (T 'INPUT)) 'REPLACE) (SELECTC \MACHINETYPE (\DAYBREAK (\DoveDisplay.SetCursorShape CursorBitMap)) (\MAIKO (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR) (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR))) NIL]) (\HARDCURSORPOSITION [LAMBDA (XPOS YPOS) (* kbr%: "13-Jun-85 21:24") (* sets cursor position, adjusts for hotspot and tty region limits.  XPOS and YPOS are the screen coordinates of the hotspot location.) (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT)) (* YPOS is reflected around CURSORYMAX because the screen has  (0,0) as the upper left corner. *) (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT) YPOS)) (* Clip coordinates *) (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND ((ILESSP XPOS 0) 0) ((IGEQ XPOS \CURSORDESTWIDTH) (SUB1 \CURSORDESTWIDTH)) (T XPOS)) \CURSORHOTSPOTX) BITSPERWORD)) (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND ((ILESSP YPOS 0) 0) ((IGEQ YPOS \CURSORDESTHEIGHT) (SUB1 \CURSORDESTHEIGHT)) (T YPOS)) \CURSORHOTSPOTY) BITSPERWORD)) [COND ((EQ \MACHINETYPE \DANDELION) (* Temporary workaround) (COND ((IGREATERP YPOS 32767) (SETQ YPOS 0))) (COND ((IGREATERP XPOS 32767) (SETQ XPOS 0] (\SETMOUSEXY XPOS YPOS) (PROGN (* change the cursor position too so that GETMOUSESTATE will get the correct  values if it is called before the next 60 cycle interrupt.) (\PUTBASE \EM.CURSORX 0 XPOS) (\PUTBASE \EM.CURSORY 0 YPOS)) NIL]) (\HARDCURSORDOWN [LAMBDA NIL (* kbr%: "23-Apr-85 18:26") (\CLEARBM (CURSORBITMAP]) ) (DEFINEQ (CURSOR.INIT [LAMBDA NIL (* kbr%: "23-Jan-86 17:34") (PROG (DESTBPL) (* Assorted globals for doing the  color cursor. *) (SETQ \CURSORDESTINATION ScreenBitMap) (SETQ \SOFTCURSORUPBM NIL) (SETQ \SOFTCURSORDOWNBM NIL) (SETQ \CURSORDESTLINE 0) (SETQ \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of ScreenBitMap)) (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of ScreenBitMap)) (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of ScreenBitMap)) (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of ScreenBitMap)) (* Initialize PILOTBBTs.  *) (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD)) (* These PILOTBBTs are the mixing areas for forming the color cursor image.  *) (* Does SCREEN to DOWNBM via INPUT,  REPLACE. *) (SETQ \SOFTCURSORBBT1 (create PILOTBBT PBTSOURCEBPL _ DESTBPL PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 0)) (\LOCKCELL \SOFTCURSORBBT1) (* Does DOWNBM to UPBM via INPUT,  REPLACE. *) (SETQ \SOFTCURSORBBT2 (create PILOTBBT PBTDESTBIT _ 0 PBTSOURCEBIT _ 0 PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 0)) (\LOCKCELL \SOFTCURSORBBT2) (* Does MASK to UPBM via INPUT,  ERASE. *) (SETQ \SOFTCURSORBBT3 (create PILOTBBT PBTDESTBIT _ 0 PBTSOURCEBIT _ 0 PBTDISJOINT _ T PBTSOURCETYPE _ 1 PBTOPERATION _ 1)) (\LOCKCELL \SOFTCURSORBBT3) (* Does IMAGE to UPBM via INPUT,  PAINT. *) (SETQ \SOFTCURSORBBT4 (create PILOTBBT PBTDESTBIT _ 0 PBTSOURCEBIT _ 0 PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 2)) (\LOCKCELL \SOFTCURSORBBT4) (* Does UPBM to SCREEN via INPUT,  REPLACE. *) (SETQ \SOFTCURSORBBT5 (create PILOTBBT PBTDESTBPL _ DESTBPL PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 0)) (\LOCKCELL \SOFTCURSORBBT5) (* Does DOWNBM to SCREEN via INPUT,  REPLACE. *) (SETQ \SOFTCURSORBBT6 (create PILOTBBT PBTDESTBPL _ DESTBPL PBTDISJOINT _ T PBTSOURCETYPE _ 0 PBTOPERATION _ 0)) (\LOCKCELL \SOFTCURSORBBT6) (* Lock things down.  *) ]) (\CURSORDESTINATION [LAMBDA (DESTINATION) (* kbr%: " 2-Sep-85 20:13") (* Change DESTINATION of  \CURRENTCURSOR, assuming it is down.  *) (PROG (DESTBPL) (COND ((NOT (EQ DESTINATION \CURSORDESTINATION)) (UNINTERRUPTABLY [COND ((NOT (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (CURSOR CUIMAGE) of \CURRENTCURSOR )) (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION))) (\CURSORBITSPERPIXEL \CURRENTCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATION] (\SETMOUSEXY 0 0) (\PUTBASE \EM.CURSORX 0 0) (\PUTBASE \EM.CURSORY 0 0) (SETQ \CURSORDESTLINE 0) (SETQ.NOREF \CURSORDESTLINEBASE (fetch (BITMAP BITMAPBASE) of DESTINATION)) (SETQ \CURSORDESTWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) (SETQ \CURSORDESTHEIGHT (fetch (BITMAP BITMAPHEIGHT) of DESTINATION)) (SETQ \CURSORDESTRASTERWIDTH (fetch (BITMAP BITMAPRASTERWIDTH) of DESTINATION )) (SETQ DESTBPL (UNFOLD \CURSORDESTRASTERWIDTH BITSPERWORD)) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT1 with DESTBPL) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT5 with DESTBPL) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT6 with DESTBPL) (SETQ \CURSORDESTINATION DESTINATION))]) (\SOFTCURSORUP [LAMBDA (NEWCURSOR) (* kbr%: " 2-Sep-85 20:15") (* Put soft NEWCURSOR up, assuming soft cursor is down.  *) (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE) (* Get cursor IMAGE & MASK.  *) (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR)) (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR)) (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE)) (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE)) (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)) (* Create new UPBM & DOWNBM caches  if necessary. *) (COND ((NOT (AND (type? BITMAP \SOFTCURSORUPBM) (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM) WIDTH) (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM) HEIGHT) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM) CURSORBITSPERPIXEL))) (SETQ \SOFTCURSORWIDTH WIDTH) (SETQ \SOFTCURSORHEIGHT HEIGHT) (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)) (\TEMPLOCKPAGES UPBMBASE 1) (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)) (\TEMPLOCKPAGES DOWNBMBASE 1) (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE) BITSPERWORD)) (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE) (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE) (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL) (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL))) (* Change PILOTBBTs.  *) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch (BITMAP BITMAPBASE ) of MASK)) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch (BITMAP BITMAPBASE ) of IMAGE)) (* Put up new \CURRENTCURSOR.  *) (SETQ \CURRENTCURSOR NEWCURSOR) (\TEMPLOCKPAGES \CURRENTCURSOR 1) (SETQ \SOFTCURSORP T) (\SOFTCURSORUPCURRENT]) (\SOFTCURSORUPCURRENT [LAMBDA NIL (* kbr%: "18-Aug-85 15:09") (* Put soft \CURRENTCURSOR up, assuming soft cursor is down.  *) (PROG (DISPINTERRUPT X Y XBASE YBASE WIDTH HEIGHT BITSPERPIXEL MINUSDESTRASTERWIDTH DEST DESTBIT SOURCEOFFSET UPBMSOURCE DOWNBMSOURCE SOURCEBIT) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ \SOFTCURSORUPP T) (* Roughly, we want to  (BITBLT CURSOR XBASE YBASE SCREEN X  Y WIDTH HEIGHT) *) (SETQ X (SIGNED (\GETBASE \EM.MOUSEX 0) BITSPERWORD)) (SETQ Y (SIGNED (\GETBASE \EM.MOUSEY 0) BITSPERWORD)) (SETQ XBASE 0) (SETQ YBASE 0) (SETQ WIDTH \SOFTCURSORWIDTH) (SETQ HEIGHT \SOFTCURSORHEIGHT) (* Clip off screen parts of cursor.  *) [COND ((IGREATERP 0 X) (* Some of cursor is to left of  screen. *) (SETQ XBASE (IMINUS X)) (SETQ WIDTH (IDIFFERENCE WIDTH XBASE)) (SETQ X 0)) ((IGREATERP (IPLUS X WIDTH) \CURSORDESTWIDTH) (* Some of cursor is to right of  screen. *) (SETQ WIDTH (IDIFFERENCE \CURSORDESTWIDTH X] (COND ((ILESSP WIDTH 0) (GO EXIT))) [COND ((IGREATERP 0 Y) (* Some of cursor is to above of  screen. *) (SETQ YBASE (IMINUS Y)) (SETQ HEIGHT (IDIFFERENCE HEIGHT YBASE)) (SETQ Y 0)) ((IGREATERP (IPLUS Y HEIGHT) \CURSORDESTHEIGHT) (* Some of cursor is to below of  screen. *) (SETQ HEIGHT (IDIFFERENCE \CURSORDESTHEIGHT Y] (COND ((ILESSP HEIGHT 0) (GO EXIT))) (* These loops reset \CURSORDESTLINEBASE while avoiding large number  arithmetic. *) [COND [(IGREATERP \CURSORDESTLINE Y) (SETQ MINUSDESTRASTERWIDTH (IMINUS \CURSORDESTRASTERWIDTH)) (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (SUB1 \CURSORDESTLINE)) (SETQ.NOREF \CURSORDESTLINEBASE (\ADDBASE \CURSORDESTLINEBASE MINUSDESTRASTERWIDTH] ((ILESSP \CURSORDESTLINE Y) (until (EQ \CURSORDESTLINE Y) do (SETQ \CURSORDESTLINE (ADD1 \CURSORDESTLINE)) (SETQ.NOREF \CURSORDESTLINEBASE (\ADDBASE \CURSORDESTLINEBASE \CURSORDESTRASTERWIDTH] (* Reset PILOTBBTs.  *) (SETQ BITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of \CURRENTCURSOR)) (SETQ X (ITIMES BITSPERPIXEL X)) (SETQ XBASE (ITIMES BITSPERPIXEL XBASE)) (SETQ WIDTH (ITIMES BITSPERPIXEL WIDTH)) (SETQ DEST \CURSORDESTLINEBASE) (SETQ DESTBIT X) (SETQ SOURCEOFFSET (ITIMES YBASE (fetch (BITMAP BITMAPRASTERWIDTH) of \SOFTCURSORUPBM ))) (SETQ UPBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM) SOURCEOFFSET)) (SETQ DOWNBMSOURCE (\ADDBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM) SOURCEOFFSET)) (SETQ SOURCEBIT XBASE) (* TBW%: Most of these fields only need to be set if we are clipping this  time or the previous time we put the cursor up.  *) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT1 with DOWNBMSOURCE) (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT1 with SOURCEBIT) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT1 with DEST) (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT1 with DESTBIT) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT1 with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT1 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT5 with DEST) (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT5 with DESTBIT) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT5 with UPBMSOURCE) (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT5 with SOURCEBIT) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT5 with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT5 with HEIGHT) (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT6 with DEST) (replace (PILOTBBT PBTDESTBIT) of \SOFTCURSORBBT6 with DESTBIT) (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT6 with DOWNBMSOURCE) (replace (PILOTBBT PBTSOURCEBIT) of \SOFTCURSORBBT6 with SOURCEBIT) (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT6 with WIDTH) (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT6 with HEIGHT) (* Save background behind cursor.  *) (\PILOTBITBLT \SOFTCURSORBBT1 0) (* Compute cursor appearance.  UPBM = (OR IMAGE (AND DOWNBM  (NOT MASK))) *) (\PILOTBITBLT \SOFTCURSORBBT2 0) (\PILOTBITBLT \SOFTCURSORBBT3 0) (\PILOTBITBLT \SOFTCURSORBBT4 0) (* Put color cursor up.  *) (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT5 0) EXIT (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT]) (\SOFTCURSORPOSITION [LAMBDA (X Y) (* kbr%: "18-Aug-85 14:50") (* Move soft cursor.  *) (PROG (DISPINTERRUPT) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) [COND ((OR (NOT (EQ (\GETBASE \EM.CURSORX 0) X)) (NOT (EQ (\GETBASE \EM.CURSORY 0) Y))) (COND (\SOFTCURSORUPP (\SOFTCURSORDOWN) (\SOFTCURSORUPCURRENT] (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT]) (\SOFTCURSORDOWN [LAMBDA NIL (* kbr%: " 6-Jul-85 00:09") (* Take COLOR cursor down.  *) (PROG (DISPINTERRUPT) (* \SOFTCURSORUPP must be set to NIL  before BITBLTing. *) (SETQ DISPINTERRUPT (\GETBASE \EM.DISPINTERRUPT 0)) (\PUTBASE \EM.DISPINTERRUPT 0 0) (SETQ \SOFTCURSORUPP NIL) (\SOFTCURSORPILOTBITBLT \SOFTCURSORBBT6 0) (\PUTBASE \EM.DISPINTERRUPT 0 DISPINTERRUPT]) (CURSORPROP [LAMBDA X (* kbr%: "11-Jan-86 20:03") (COND ((IGREATERP X 2) (PUTCURSORPROP (ARG X 1) (ARG X 2) (ARG X 3))) ((EQ X 2) (GETCURSORPROP (ARG X 1) (ARG X 2))) (T (\ILLEGAL.ARG NIL]) (GETCURSORPROP [LAMBDA (CURSOR PROP) (* kbr%: "26-Apr-85 11:18") (LISTGET (fetch (CURSOR CUDATA) of CURSOR) PROP]) (PUTCURSORPROP [LAMBDA (CURSOR PROP VALUE) (* kbr%: "26-Apr-85 11:18") (PROG (OLDDATA OLDVALUE) (SETQ OLDDATA (fetch (CURSOR CUDATA) of CURSOR)) [COND [OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) (COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (COND [(EQ (CAR OLDDATA) PROP) (replace (CURSOR CUDATA) of CURSOR with (CDDR (fetch (CURSOR CUDATA) of CURSOR] (T (FOR TAIL ON (CDR OLDDATA) BY (CDDR TAIL) WHEN (EQ (CADR TAIL) PROP) DO (FRPLACD TAIL (CDDDR TAIL)) (RETURN] (VALUE (replace (CURSOR CUDATA) of CURSOR with (LIST PROP VALUE] (RETURN OLDVALUE]) (\CURSORBITSPERPIXEL [LAMBDA (CURSOR NEWBITSPERPIXEL) (* kbr%: "12-May-85 17:15") (* Swap in NEWBITSPERPIXEL IMAGE and MASK, creating them if necessary.  *) (PROG (OLDBITSPERPIXEL OLDIMAGE OLDMASK WHITE BLACK NEWIMAGE NEWMASK) (SETQ OLDBITSPERPIXEL (fetch (CURSOR CUBITSPERPIXEL) of CURSOR)) (COND ((EQ OLDBITSPERPIXEL NEWBITSPERPIXEL) (RETURN))) (* Save OLDIMAGE and OLDMASK.  *) (SETQ OLDIMAGE (fetch (CURSOR CUIMAGE) of CURSOR)) (SETQ OLDMASK (fetch (CURSOR CUMASK) of CURSOR)) (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME OLDBITSPERPIXEL) OLDIMAGE) (CURSORPROP CURSOR (\CURSORMASKPROPNAME OLDBITSPERPIXEL) OLDMASK) (* Unsave NEWIMAGE and NEWMASK if possible, otherwise create them.  *) [COND [(SETQ NEWIMAGE (CURSORPROP CURSOR (\CURSORIMAGEPROPNAME NEWBITSPERPIXEL))) (* Use cached NEWIMAGE & NEWMASK.  *) (SETQ NEWMASK (CURSORPROP CURSOR (\CURSORMASKPROPNAME NEWBITSPERPIXEL] (T (* Create NEWIMAGE & NEWMASK.  *) (SETQ WHITE (MASK.1'S 0 NEWBITSPERPIXEL)) (SETQ BLACK 0) (SETQ NEWIMAGE (COLORIZEBITMAP (CURSORPROP CURSOR 'IMAGE1) BLACK WHITE NEWBITSPERPIXEL)) (SETQ NEWMASK (COLORIZEBITMAP (CURSORPROP CURSOR 'MASK1) BLACK WHITE NEWBITSPERPIXEL] (replace (CURSOR CUIMAGE) of CURSOR with NEWIMAGE) (replace (CURSOR CUMASK) of CURSOR with NEWMASK]) (\CURSORIMAGEPROPNAME [LAMBDA (BITSPERPIXEL) (* kbr%: "26-Apr-85 11:18") (SELECTQ BITSPERPIXEL (1 'IMAGE1) (4 'IMAGE4) (8 'IMAGE8) (SHOULDNT]) (\CURSORMASKPROPNAME [LAMBDA (BITSPERPIXEL) (* kbr%: "26-Apr-85 11:18") (SELECTQ BITSPERPIXEL (1 'MASK1) (4 'MASK4) (8 'MASK8) (SHOULDNT]) ) (DEFINEQ (CURSORCREATE [LAMBDA (IMAGE MASK HOTSPOTX HOTSPOTY DATA) (* ; "Edited 10-Jul-92 16:32 by cat") (* ; "Edited 31-Jul-87 10:01 by jds") (* ;; "creates a cursor from a bitmap. HOTSPOTX and HOTSPOTY specify the hotspot.") (* ;; "INVARIANTS: the hot spot X and Y must be in the range 0..(width - 1) and 0..(height - 1), respectively.") (PROG (CURSOR) (COND ((OR (FIXP MASK) (POSITIONP MASK)) (* ;; "If Mask is a fixp then we presume this is the old arg list (bitmap x y). the cursor filepkgtype has been changed to write the new arg list. The other is provided for (dubious) compatibility") (SETQ HOTSPOTY HOTSPOTX) (SETQ HOTSPOTX MASK) (SETQ MASK NIL))) (* ;; "Make sure that the image and mask bitmaps are no larger than the hardware cursor, i.e. 16x16 bits [AR 8916 7/31/87]:") (COND ((OR (IGREATERP (BITMAPWIDTH IMAGE) 16) (IGREATERP (BITMAPHEIGHT IMAGE) 16)) (* ; "IMAGE is too big.") (\ILLEGAL.ARG IMAGE)) ((NOT MASK) (* ; "No mask, so it's OK") ) ((OR (IGREATERP (BITMAPWIDTH MASK) 16) (IGREATERP (BITMAPHEIGHT MASK) 16)) (* ; "MASK is too big.") (\ILLEGAL.ARG MASK))) [COND ((POSITIONP HOTSPOTX) (* ;;  "The hot spot can be specified as a position in one arg, rather than X and Y in two:") (SETQ HOTSPOTY (fetch (POSITION YCOORD) of HOTSPOTX)) (SETQ HOTSPOTX (fetch (POSITION XCOORD) of HOTSPOTX] (SETQ CURSOR (create CURSOR CUIMAGE _ IMAGE CUMASK _ (OR MASK IMAGE) CUHOTSPOTX _ (IMAX 0 (IMIN (SUB1 (BITMAPWIDTH IMAGE)) (OR (FIXP HOTSPOTX) 0))) CUHOTSPOTY _ [IMAX 0 (IMIN (SUB1 (BITMAPHEIGHT IMAGE)) (OR (FIXP HOTSPOTY) (SUB1 (BITMAPHEIGHT IMAGE] CUDATA _ DATA)) (RETURN CURSOR]) (CURSOR [LAMBDA (NEWCURSOR INVERTFLG) (* ; "Edited 24-Mar-87 18:30 by jds") (* ;; "Installs NEWCURSOR as the cursor and returns the old cursor state. If INVERTFLG is non-NIL, the cursor image is inverted during installation. If NEWCURSOR is NIL, just returns the current cursor state.") (DECLARE (GLOBALVARS DEFAULTCURSOR \SOFTCURSORP)) (PROG (OLDCURSOR) (SETQ OLDCURSOR \CURRENTCURSOR) (COND ((EQ NEWCURSOR T) (* ;  "If NEWCURSOR is T, use the system default cursor.") (SETQ NEWCURSOR DEFAULTCURSOR))) (COND [(\CURSOR-VALID-P NEWCURSOR \SOFTCURSORP) (* ;  "Only install the cursor if it's a real, valid one.") (\CURSORDOWN) (\CURSORUP NEWCURSOR INVERTFLG) (* ;  "set after adjustment to avoid confusion about hotspot during adjustment.") (SETQ \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR)) (SETQ \CURSORHOTSPOTY (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE) of NEWCURSOR))) (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR] (NEWCURSOR (* ; "NEWCURSOR = NIL means just return the old one, so only error if one got specified that wasn't valid.") (\ILLEGAL.ARG NEWCURSOR))) (RETURN OLDCURSOR]) (\CURSOR-VALID-P [LAMBDA (CURSOR SOFT?) (* ; "Edited 25-Mar-87 09:41 by jds") (* ;; "It returns T if CURSOR is a valid cursor. Validity depends on whether it's meant to be displayed using the cursor hardware or the cursor software.") (* ;; "This is really wed to the D-machine display architecture. ") (AND (CURSORP CURSOR) (COND (SOFT? T) (T (LET ((IMAGE (fetch (CURSOR CUIMAGE) of CURSOR)) (HOTSPOT-X (fetch (CURSOR CUHOTSPOTX) of CURSOR)) (HOTSPOT-Y (fetch (CURSOR CUHOTSPOTY) of CURSOR))) (* ;; "The bitmap must be <= 16x16, and the hot spot must be within the cursor if we're using hardware cursor.") (AND (>= 16 (BITMAPWIDTH IMAGE)) (>= 16 (BITMAPHEIGHT IMAGE)) (<= 0 HOTSPOT-X) (< HOTSPOT-X 16) (<= 0 HOTSPOT-Y) (< HOTSPOT-Y 16]) (\CURSORUP [LAMBDA (NEWCURSOR INVERTFLG) (* kbr%: "18-Aug-85 14:38") (UNINTERRUPTABLY (\CURSORBITSPERPIXEL NEWCURSOR (fetch (BITMAP BITMAPBITSPERPIXEL) of \CURSORDESTINATION )) (COND ((AND (EQ (fetch (CURSOR CUIMAGE) of NEWCURSOR) (fetch (CURSOR CUMASK) of NEWCURSOR)) (ILEQ (fetch (BITMAP BITMAPWIDTH) of (fetch (CURSOR CUIMAGE) of NEWCURSOR)) HARDCURSORWIDTH) (ILEQ (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE) of NEWCURSOR)) HARDCURSORHEIGHT) (EQ \CURSORDESTINATION ScreenBitMap)) (\HARDCURSORUP NEWCURSOR INVERTFLG)) (T (\SOFTCURSORUP NEWCURSOR))) (ADJUSTCURSORPOSITION (IDIFFERENCE \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR)) (IDIFFERENCE (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT) of (fetch (CURSOR CUIMAGE) of NEWCURSOR))) (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR)) \CURSORHOTSPOTY)))]) (\CURSORPOSITION [LAMBDA (XPOS YPOS) (* ; "Edited 19-Mar-98 14:41 by jds") (* sets cursor position, adjusts for hotspot and tty region limits.  XPOS and YPOS are the screen coordinates of the hotspot location.) (DECLARE (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURSORDESTWIDTH \CURSORDESTHEIGHT)) (* YPOS is reflected around CURSORYMAX because the screen has  (0,0) as the upper left corner. *) (SETQ YPOS (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT) YPOS)) (* Clip coordinates *) (SETQ XPOS (UNSIGNED (IDIFFERENCE (COND (NIL (* ;; "Removed 2000/1/3 JDS so mousr cursors work.") (ILESSP XPOS 0) 0) ((IGEQ XPOS \CURSORDESTWIDTH) (SUB1 \CURSORDESTWIDTH)) (T XPOS)) \CURSORHOTSPOTX) BITSPERWORD)) (SETQ YPOS (UNSIGNED (IDIFFERENCE (COND (NIL (ILESSP YPOS 0) 0) ((IGEQ YPOS \CURSORDESTHEIGHT) (SUB1 \CURSORDESTHEIGHT)) (T YPOS)) \CURSORHOTSPOTY) BITSPERWORD)) [COND ((EQ \MACHINETYPE \DANDELION) (* Temporary workaround) (COND ((IGREATERP YPOS 32767) (SETQ YPOS 0))) (COND ((IGREATERP XPOS 32767) (SETQ XPOS 0] (\SETMOUSEXY XPOS YPOS) (COND (\SOFTCURSORP (\SOFTCURSORPOSITION XPOS YPOS))) [PROGN (* change the cursor position too so that GETMOUSESTATE will get the correct  values if it is called before the next 60 cycle interrupt.) (\PUTBASE \EM.CURSORX 0 XPOS) (\PUTBASE \EM.CURSORY 0 YPOS) (COND ((EQ \MACHINETYPE \DAYBREAK) (* Need to notify DAYBREAK IOP to  move cursor. *) (\DoveDisplay.SetCursorPosition XPOS YPOS] NIL]) (\CURSORDOWN [LAMBDA NIL (* kbr%: "12-Jun-85 17:21") (UNINTERRUPTABLY (COND (\SOFTCURSORP (\SOFTCURSORDOWN)) (T (\HARDCURSORDOWN))))]) (ADJUSTCURSORPOSITION [LAMBDA (DELTAX DELTAY) (* kbr%: " 6-Jan-86 11:55") (COND [(POSITIONP DELTAX) (\CURSORPOSITION (IPLUS (fetch (POSITION XCOORD) of DELTAX) (\XMOUSECOORD)) (IPLUS (fetch (POSITION YCOORD) of DELTAX) (\YMOUSECOORD] (T (\CURSORPOSITION (IPLUS (OR DELTAX 0) (\XMOUSECOORD)) (IPLUS (OR DELTAY 0) (\YMOUSECOORD]) (CURSORPOSITION [LAMBDA (NEWPOSITION DISPLAYSTREAM OLDPOSITION) (* kbr%: "13-Feb-86 15:53") (PROG (DD) (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM)) (OR (type? POSITION OLDPOSITION) (SETQ OLDPOSITION (create POSITION))) (freplace (POSITION XCOORD) of OLDPOSITION with (\DSPUNTRANSFORMX (\XMOUSECOORD ) DD)) (freplace (POSITION YCOORD) of OLDPOSITION with (\DSPUNTRANSFORMY (\YMOUSECOORD ) DD)) (COND ((type? POSITION NEWPOSITION) (\CURSORPOSITION (\DSPTRANSFORMX (fetch (POSITION XCOORD) of NEWPOSITION) DD) (\DSPTRANSFORMY (fetch (POSITION YCOORD) of NEWPOSITION) DD))) ((type? SCREENPOSITION NEWPOSITION) (CURSORSCREEN (fetch (SCREENPOSITION SCREEN) of NEWPOSITION) (fetch (SCREENPOSITION XCOORD) of NEWPOSITION) (fetch (SCREENPOSITION YCOORD) of NEWPOSITION))) (NEWPOSITION (\ILLEGAL.ARG NEWPOSITION))) (RETURN OLDPOSITION]) (CURSORSCREEN [LAMBDA (SCREEN XCOORD YCOORD) (* gbn%: "25-Jan-86 16:53") (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos  of cursor on SCREEN) (COND ((NULL XCOORD) (SETQ XCOORD 0))) (COND ((NULL YCOORD) (SETQ YCOORD 0))) (PROG (DESTINATION) (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN)) (\CURSORDOWN) (SETQ \CURSORSCREEN SCREEN) (\CURSORDESTINATION DESTINATION) (\CURSORUP \CURRENTCURSOR) (\CURSORPOSITION XCOORD YCOORD]) (CURSOREXIT [LAMBDA NIL (* gbn%: "25-Jan-86 16:52") (* * called when cursor moves off the screen edge) (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY)) (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2) (SETQ SCREEN LASTSCREEN) (SETQ XCOORD LASTMOUSEX) (SETQ YCOORD LASTMOUSEY) (SETQ SCREEN2 (COND ((EQ SCREEN \MAINSCREEN) \COLORSCREEN) (T \MAINSCREEN))) (* generalize for more than two  screens (or alternate physical  arrangement of screens.)) (COND ((EQ XCOORD 0) (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2) 2))) ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN))) (SETQ XCOORD2 1)) (T (RETURN))) [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2)) ) (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN] (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2]) (FLIPCURSOR + [LAMBDA NIL (* ; "Edited 24-Apr-88 00:04 by MASINTER") + (PROG (ADDR) + (COND + ((NOT \SOFTCURSORP) + (SETQ ADDR \EM.CURSORBITMAP) + (FRPTQ HARDCURSORHEIGHT [\PUTBASE ADDR 0 (LOGXOR (\GETBASE ADDR 0) + (CONSTANT (SUB1 (EXPT 2 HARDCURSORWIDTH + ] + (SETQ ADDR (\ADDBASE ADDR 1))) + (SELECTC \MACHINETYPE + (\DAYBREAK (\DoveDisplay.SetCursorShape)) + (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX) + of \CURRENTCURSOR) + (fetch (CURSOR CUHOTSPOTY) of + \CURRENTCURSOR + )))) + NIL]) (FLIPCURSORBAR + [LAMBDA (N) (* ; "Edited 19-Mar-98 14:23 by jds") + +(* ;;; "Inverts the Nth line of the cursor, N = 0 being the top") + + (COND + ((NOT \SOFTCURSORP) + (\PUTBASE \EM.CURSORBITMAP N (LOGXOR (\GETBASE \EM.CURSORBITMAP N) + MAX.SMALLP)) + (SELECTC \MACHINETYPE + (\DAYBREAK (* ; "Notify IOP") + (\DoveDisplay.SetCursorShape)) + (\MAIKO (AND \CURRENTCURSOR (SUBRCALL DSPCURSOR (fetch (CURSOR CUHOTSPOTX) + of \CURRENTCURSOR) + (fetch (CURSOR CUHOTSPOTY) of + \CURRENTCURSOR + )))) + NIL]) (LASTMOUSEX [LAMBDA (DS) (* rmk%: "30-AUG-83 13:07") (* returns the mouse x position in the coordinates of the DisplayStream DS) (\DSPUNTRANSFORMX LASTMOUSEX (\GETDISPLAYDATA DS]) (LASTMOUSEY [LAMBDA (DS) (* rmk%: "30-AUG-83 13:07") (* returns the mouse y position in the coordinates of the DisplayStream DS) (\DSPUNTRANSFORMY LASTMOUSEY (\GETDISPLAYDATA DS]) (CREATEPOSITION [LAMBDA (XCOORD YCOORD) (* rmk%: " 6-Aug-84 13:43") (create POSITION XCOORD _ (OR XCOORD 0) YCOORD _ (OR YCOORD 0]) (POSITIONP [LAMBDA (X) (* rrb "25-AUG-82 11:04") (* is X a position? For now just a cons check but should be made a datatype.) (AND (LISTP X) (NUMBERP (CAR X)) (NUMBERP (CDR X)) X]) (CURSORHOTSPOT [LAMBDA (NEWPOSITION) (* gbn%: "26-Jan-86 15:36") (* returns the current cursor hot spot and sets the hot spot to NEWPOSITON if  one is given.) (PROG1 (create POSITION XCOORD _ \CURSORHOTSPOTX YCOORD _ \CURSORHOTSPOTY) (COND ((POSITIONP NEWPOSITION) (SETQ \CURSORHOTSPOTX (fetch (POSITION YCOORD) of NEWPOSITION)) (SETQ \CURSORHOTSPOTY (fetch (POSITION YCOORD) of NEWPOSITION]) ) (PUTPROPS CURSORPROP ARGNAMES (NIL (CURSOR PROP {NEWVALUE}) . U)) (RPAQ? \CURSORHOTSPOTX 0) (RPAQ? \CURSORHOTSPOTY 0) (RPAQ? \CURRENTCURSOR NIL) (RPAQ? \SOFTCURSORWIDTH NIL) (RPAQ? \SOFTCURSORHEIGHT NIL) (RPAQ? \SOFTCURSORP NIL) (RPAQ? \SOFTCURSORUPP NIL) (RPAQ? \SOFTCURSORUPBM NIL) (RPAQ? \SOFTCURSORDOWNBM NIL) (RPAQ? \SOFTCURSORBBT1 NIL) (RPAQ? \SOFTCURSORBBT2 NIL) (RPAQ? \SOFTCURSORBBT3 NIL) (RPAQ? \SOFTCURSORBBT4 NIL) (RPAQ? \SOFTCURSORBBT5 NIL) (RPAQ? \SOFTCURSORBBT6 NIL) (RPAQ? \CURSORSCREEN NIL) (RPAQ? \CURSORDESTINATION NIL) (RPAQ? \CURSORDESTHEIGHT 808) (RPAQ? \CURSORDESTWIDTH 1024) (RPAQ? \CURSORDESTRASTERWIDTH 64) (RPAQ? \CURSORDESTLINE 0) (RPAQ? \CURSORDESTLINEBASE NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE) ) (DEFINEQ (GETMOUSESTATE [LAMBDA NIL (* kbr%: " 6-Jul-85 14:16") (* Reads the current state of the  mouse and keyboard) (SETQ LASTMOUSEX (\XMOUSECOORD)) (SETQ LASTMOUSEY (\YMOUSECOORD)) (SETQ LASTMOUSEBUTTONS (LOGXOR (LOGAND (fetch (KEYBOARDEVENT WU) of \LASTKEYSTATE) \MOUSE.ALLBITS) \MOUSE.ALLBITS)) (SETQ LASTKEYBOARD (\EVENTKEYS)) (SETQ LASTSCREEN \CURSORSCREEN) NIL]) (\EVENTKEYS [LAMBDA NIL (* rmk%: " 4-JUN-81 22:58") (* Returns the state of the various keys that are represented in mouse events) (LOGOR (COND ((KEYDOWNP 'LOCK) 128) (T 0)) (COND ((KEYDOWNP 'LSHIFT) 64) (T 0)) (COND ((KEYDOWNP 'CTRL) 32) (T 0)) (COND ((KEYDOWNP 'RSHIFT) 8) (T 0)) (COND ((KEYDOWNP 'BLANK-TOP) 4) (T 0)) (COND ((KEYDOWNP 'BLANK-MIDDLE) 2) (T 0)) (COND ((KEYDOWNP 'BLANK-BOTTOM) 1) (T 0]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (RPAQQ HARDCURSORHEIGHT 16) (RPAQQ HARDCURSORWIDTH 16) (CONSTANTS (HARDCURSORHEIGHT 16) (HARDCURSORWIDTH 16)) ) (DECLARE%: EVAL@COMPILE (ADDTOVAR GLOBALVARS LASTMOUSEX LASTMOUSEY LASTSCREEN LASTMOUSEBUTTONS LASTMOUSETIME LASTKEYBOARD) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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]) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (PUTPROPS \XMOUSECOORD MACRO (NIL (IPLUS \CURSORHOTSPOTX (SIGNED (\GETBASE \EM.CURSORX 0) BITSPERWORD)))) (PUTPROPS \YMOUSECOORD MACRO [NIL (IDIFFERENCE (SUB1 \CURSORDESTHEIGHT) (IPLUS \CURSORHOTSPOTY (SIGNED (\GETBASE \EM.CURSORY 0) BITSPERWORD]) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD 'CURSOR 'SETCURSOR) (MOVD '\CURSORPOSITION '\SETCURSORPOSITION) (RPAQ \SFPosition (CREATEPOSITION)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD KEYBOARDEVENT ((W0 WORD) (W1 WORD) (W2 WORD) (W3 WORD) (WU WORD) (W4 WORD) (W5 WORD) (TIME FIXP) (MOUSESTATE BITS 3) (1SHIFT FLAG) (2SHIFT FLAG) (LOCK FLAG) (CTRL FLAG) (META FLAG) (FONT FLAG) (USERMODE1 FLAG) (USERMODE2 FLAG) (USERMODE3 FLAG) (ALTGRAPH FLAG) (DEADKEYPENDING FLAG) (* ; "T if the last key was a dead (accent) key, and we should generate an accented character if possible.") (NIL BITS 2) (MOUSEX WORD) (MOUSEY WORD) (DEADKEY-ALIST XPOINTER) (* ;  "The ALIST describing accents possible from teh last dead key.") ) (CREATE (\ALLOCBLOCK (FOLDHI \KEYBOARDEVENT.SIZE WORDSPERCELL))) W0 _ ALLUP W1 _ ALLUP W2 _ ALLUP W3 _ ALLUP W4 _ ALLUP W5 _ ALLUP WU _ ALLUP MOUSESTATE _ \DLMOUSE.UP [ACCESSFNS KEYBOARDEVENT ((SIZE (INDEXF (fetch MOUSEY of DATUM))) (SHIFT (OR (fetch (KEYBOARDEVENT 1SHIFT) DATUM) (fetch (KEYBOARDEVENT 2SHIFT) DATUM))) (SHIFTORLOCK (OR (fetch (KEYBOARDEVENT SHIFT) DATUM) (fetch (KEYBOARDEVENT LOCK) DATUM] LOCK _ (XKEYDOWNP 'LOCK) TIME _ 0 DEADKEYPENDING _ NIL) ) (DECLARE%: EVAL@COMPILE (RPAQ \KEYBOARDEVENT.FIRST NRINGINDEXWORDS) (RPAQQ \KEYBOARDEVENT.SIZE 14) (RPAQ \KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383))) [CONSTANTS (\KEYBOARDEVENT.FIRST NRINGINDEXWORDS) \KEYBOARDEVENT.SIZE (\KEYBOARDEVENT.LAST (PLUS \KEYBOARDEVENT.FIRST (TIMES \KEYBOARDEVENT.SIZE 383] ) ) (DEFINEQ (MACHINETYPE [LAMBDA NIL (* ; "Edited 30-Mar-88 10:27 by Snow") (SELECTC (fetch MachineType of \InterfacePage) (\DORADO 'DORADO) (\DANDELION 'DANDELION) (\DAYBREAK (* This is \DAYBREAK internally) 'DOVE) (\MAIKO 'MAIKO) NIL]) (SETMAINTPANEL [LAMBDA (N) (* mpl "21-Jul-85 18:15") (SELECTC \MACHINETYPE (\DANDELION (replace DLMAINTPANEL of \IOPAGE with N)) (\DOLPHIN ((OPCODES MISC1 3) (\DTEST N 'SMALLP))) (\DAYBREAK ((OPCODES DOVEMISC 2) (\DTEST N 'SMALLP))) NIL]) ) (* ; "DLion beeper") (DEFINEQ (BEEPON [LAMBDA (FREQ) (* ; "Edited 10-May-88 18:17 by MASINTER") (SELECTC \MACHINETYPE (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE) 32768) do (BLOCK)) (replace DLBEEPFREQ of \IOPAGE with (IQUOTIENT 1843200 (IMAX FREQ 29))) (replace DLBEEPCMD of \IOPAGE with 32768)) (\DAYBREAK (\DoveMisc.BeepOn FREQ)) (\MAIKO (SUBRCALL KEYBOARDBEEP T FREQ)) (PROGN NIL)) NIL]) (BEEPOFF [LAMBDA NIL (* ; "Edited 10-May-88 18:17 by MASINTER") (SELECTC \MACHINETYPE (\DANDELION (while (IGEQ (fetch DLBEEPCMD of \IOPAGE) 32768) do (BLOCK)) (replace DLBEEPCMD of \IOPAGE with 32769)) (\DAYBREAK (\DoveMisc.BeepOff)) (\MAIKO (SUBRCALL KEYBOARDBEEP NIL NIL)) (PROGN NIL)) NIL]) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY (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) ) (* "END EXPORTED DEFINITIONS") (DEFINEQ (WITHOUT-INTERRUPTS [NLAMBDA (FORM) (* lmm "18-Apr-85 02:53") (PROG (VAL) (\KEYBOARDOFF) (SETQ VAL (DISPLAYDOWN FORM)) (\KEYBOARDON) (RETURN VAL]) ) (* ; "Compile locked fns together for locality") (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL FLIPCURSORBAR \KEYHANDLER \KEYHANDLER1 \TRACKCURSOR \PERIODIC.INTERRUPTFRAME \TIMER.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \DOTRANSITIONS \DECODETRANSITION \EVENTKEYS \HARDCURSORUP \DOMOUSECHORDING \KEYBOARDOFF \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN) ) (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS FLIPCURSORBAR \SETIOPOINTERS \KEYHANDLER \KEYHANDLER1 \CONTEXTAPPLY \LOCKPAGES \DECODETRANSITION \SMASHLINK \INCUSECOUNT LLSH \MAKEFREEBLOCK \DECUSECOUNT \MAKENUMBER \ADDBASE \PERIODIC.INTERRUPTFRAME \DOBUFFEREDTRANSITIONS \TIMER.INTERRUPTFRAME \CAUSEINTERRUPT \DOMOUSECHORDING \KEYBOARDOFF \TRACKCURSOR \HARDCURSORUP \HARDCURSORPOSITION \HARDCURSORDOWN \SOFTCURSORUP \SOFTCURSORUPCURRENT \SOFTCURSORPOSITION \SOFTCURSORDOWN \SOFTCURSORPILOTBITBLT) (LOCKEDVARS \InterfacePage \CURSORHOTSPOTX \CURSORHOTSPOTY \CURRENTCURSOR \SOFTCURSORWIDTH \SOFTCURSORHEIGHT \SOFTCURSORP \SOFTCURSORUPP \SOFTCURSORUPBM \SOFTCURSORDOWNBM \SOFTCURSORBBT1 \SOFTCURSORBBT2 \SOFTCURSORBBT3 \SOFTCURSORBBT4 \SOFTCURSORBBT5 \SOFTCURSORBBT6 \CURSORDESTINATION \CURSORDESTHEIGHT \CURSORDESTWIDTH \CURSORDESTRASTERWIDTH \CURSORDESTLINE \CURSORDESTLINEBASE \PENDINGINTERRUPT \PERIODIC.INTERRUPT \PERIODIC.INTERRUPT.FREQUENCY \LASTUSERACTION \MOUSECHORDTICKS \KEYBOARDEVENTQUEUE \KEYBUFFERING SCREENWIDTH SCREENHEIGHT \TIMER.INTERRUPT.PENDING \EM.MOUSEX \EM.MOUSEY \EM.CURSORX \EM.CURSORY \EM.UTILIN \EM.REALUTILIN \EM.KBDAD0 \EM.KBDAD1 \EM.KBDAD2 \EM.KBDAD3 \EM.DISPINTERRUPT \EM.CURSORBITMAP \EM.KBDAD4 \EM.KBDAD5 \MISCSTATS \RCLKSECOND)))) (ADDTOVAR RDCOMS (FNS \SETIOPOINTERS)) ) (PUTPROPS LLKEY FILETYPE :BCOMPL) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML WITHOUT-INTERRUPTS) (ADDTOVAR LAMA CURSORPROP METASHIFT MOUSECHORDWAIT) ) (PUTPROPS LLKEY COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1989 1990 1992 1999 1920 2000 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (14799 21895 (BKSYSCHARCODE 14809 . 15158) (\CLEARSYSBUF 15160 . 15718) (\GETKEY 15720 . 16895) (\NSYSBUFCHARS 16897 . 17537) (\SAVESYSBUF 17539 . 19151) (\SYSBUFP 19153 . 19457) ( \GETSYSBUF 19459 . 19639) (\PUTSYSBUF 19641 . 20855) (\PEEKSYSBUF 20857 . 21893)) (23192 59371 ( \KEYBOARDINIT 23202 . 24925) (\KEYBOARDEVENTFN 24927 . 29627) (\ALLOCLOCKED 29629 . 30219) ( \SETIOPOINTERS 30221 . 34690) (\KEYBOARDOFF 34692 . 35039) (\KEYBOARDON 35041 . 35353) (\KEYHANDLER 35355 . 35486) (\KEYHANDLER1 35488 . 42806) (\RESETKEYBOARD 42808 . 44317) (\DOMOUSECHORDING 44319 . 47990) (\DOTRANSITIONS 47992 . 48669) (\DECODETRANSITION 48671 . 55360) (MOUSECHORDWAIT 55362 . 56045) (\TRACKCURSOR 56047 . 59369)) (93113 116472 (KEYACTION 93123 . 93967) (KEYACTIONTABLE 93969 . 95151) (KEYBOARDTYPE 95153 . 96255) (RESETKEYACTION 96257 . 98016) (\KEYBOARD.MACHINE-SPECIFIC-KEYACTIONS 98018 . 101425) (\KEYACTION1 101427 . 112048) (KEYDOWNP 112050 . 112385) (KEYNUMBERP 112387 . 112585) (\KEYNAMETONUMBER 112587 . 113281) (MODIFY.KEYACTIONS 113283 . 114144) (METASHIFT 114146 . 115090) ( SHIFTDOWNP 115092 . 116470)) (116535 116831 (SETUP.OFFICE.KEYBOARD 116545 . 116829)) (119841 121553 ( \INIT.KEYBOARD.STREAM 119851 . 121551)) (121818 138195 (\DOBUFFEREDTRANSITIONS 121828 . 137258) ( \TIMER.INTERRUPTFRAME 137260 . 137985) (\PERIODIC.INTERRUPTFRAME 137987 . 138193)) (138449 142526 ( \HARDCURSORUP 138459 . 140341) (\HARDCURSORPOSITION 140343 . 142379) (\HARDCURSORDOWN 142381 . 142524) ) (142527 166587 (CURSOR.INIT 142537 . 146237) (\CURSORDESTINATION 146239 . 148557) (\SOFTCURSORUP 148559 . 153813) (\SOFTCURSORUPCURRENT 153815 . 160851) (\SOFTCURSORPOSITION 160853 . 161618) ( \SOFTCURSORDOWN 161620 . 162328) (CURSORPROP 162330 . 162672) (GETCURSORPROP 162674 . 162862) ( PUTCURSORPROP 162864 . 164019) (\CURSORBITSPERPIXEL 164021 . 166137) (\CURSORIMAGEPROPNAME 166139 . 166363) (\CURSORMASKPROPNAME 166365 . 166585)) (166588 184538 (CURSORCREATE 166598 . 169273) (CURSOR 169275 . 171087) (\CURSOR-VALID-P 171089 . 172176) (\CURSORUP 172178 . 173893) (\CURSORPOSITION 173895 . 176423) (\CURSORDOWN 176425 . 176658) (ADJUSTCURSORPOSITION 176660 . 177238) (CURSORPOSITION 177240 . 178782) (CURSORSCREEN 178784 . 179440) (CURSOREXIT 179442 . 180833) (FLIPCURSOR 180835 . 181961) ( FLIPCURSORBAR 181963 . 182943) (LASTMOUSEX 182945 . 183199) (LASTMOUSEY 183201 . 183455) ( CREATEPOSITION 183457 . 183663) (POSITIONP 183665 . 183949) (CURSORHOTSPOT 183951 . 184536)) (185776 187324 (GETMOUSESTATE 185786 . 186445) (\EVENTKEYS 186447 . 187322)) (193751 194547 (MACHINETYPE 193761 . 194161) (SETMAINTPANEL 194163 . 194545)) (194577 195716 (BEEPON 194587 . 195240) (BEEPOFF 195242 . 195714)) (196167 196430 (WITHOUT-INTERRUPTS 196177 . 196428))))) STOP \ No newline at end of file diff --git a/sources/LLMVS b/sources/LLMVS new file mode 100644 index 00000000..eb63b1b8 --- /dev/null +++ b/sources/LLMVS @@ -0,0 +1,280 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "30-Dec-93 13:47:40" {DSK}export>lispcore>sources>LLMVS.;2 19599 + + changes to%: (MACROS \VALUES) + + previous date%: "25-Feb-91 22:40:14" {DSK}export>lispcore>sources>LLMVS.;1) + + +(* ; " +Copyright (c) 1986, 1987, 1989, 1990, 1991, 1993 by Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLMVSCOMS) + +(RPAQQ LLMVSCOMS [ + +(* ;;; "Runtime support for multiple value passing. This file must be present for compiled multiple values to work.") + + (FNS CL:VALUES CL:VALUES-LIST \MVLIST \SIMULATE.UNBIND) + (DECLARE%: DONTCOPY (MACROS \VALUES \VALUES-UFN) + (LOCALVARS . T)) + (VARIABLES CL:MULTIPLE-VALUES-LIMIT) + + (* ;; "UFNs for the CL:VALUES and CL:VALUES-LIST sub-opcodes of MISCN:") + + (FNS CL::VALUES-UFN CL::VALUES-LIST-UFN) + (PROP FILETYPE LLMVS) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA) + (NLAML) + (LAMA CL:VALUES]) + + + +(* ;;; +"Runtime support for multiple value passing. This file must be present for compiled multiple values to work." +) + +(DEFINEQ + +(CL:VALUES [LAMBDA ARGS (* ; "Edited 30-May-90 16:01 by jds") (* ;; "Return multiple values to a caller.") (\VALUES (for I from 1 to ARGS collect (ARG ARGS I)) (AND (IGEQ ARGS 1) (ARG ARGS 1]) + +(CL:VALUES-LIST [LAMBDA (CL:VALUES) (* ; "Edited 30-May-90 16:02 by jds") (* ;; "Given a list of values, return them as multiple values to a caller.") (\VALUES CL:VALUES (CAR CL:VALUES]) + +(\MVLIST (LAMBDA (X) (LIST X))) + +(\SIMULATE.UNBIND (LAMBDA (FRAME N RETURNER) (* ; "Edited 25-Nov-87 12:54 by bvm:") (* ;; "Simulate the action of N applications of UNBIND occurring in specified FRAME. RETURNER is the frame that will return to FRAME, and hence must be made slow (NIL if my caller). Must be called uninterruptably.") (LET* ((NEXT (fetch (FX NEXTBLOCK) of FRAME)) (SP NEXT) (PVAR0BASE (STACKADDBASE (fetch (FX FIRSTPVAR) of FRAME)))) (TO N DO (do (* ; "Pop stack until a bind mark is encountered") (SETQ SP (- SP WORDSPERCELL)) REPEATUNTIL (fetch BINDMARKP of (STACKADDBASE SP)) FINALLY (* ; "Unbind stuff. Bind mark says how many pvars were bound, and gives the offset of the last of them") (LET ((LASTPVAR (fetch BINDLASTPVAR of (STACKADDBASE SP)))) (to (fetch BINDNVALUES of (STACKADDBASE SP)) do (\PUTBASE PVAR0BASE LASTPVAR 65535) (SETQ LASTPVAR (- LASTPVAR WORDSPERCELL)))))) (replace (FX NEXTBLOCK) of FRAME with SP) (\MAKEFREEBLOCK SP (- NEXT SP)) (* ;; "Now explicitly slow return to FRAME, since we have violated the fast return assumptions by blowing away stack between here and there") (replace (FX FASTP) of (OR RETURNER (\MYALINK)) with NIL))) ) +) +(DECLARE%: DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PUTPROPS + \VALUES MACRO + ((MANY ONE CALLER-FRAME) + (PROG* ((IMMEDIATE-CALLER (OR CALLER-FRAME (\MYALINK))) + (CALLER IMMEDIATE-CALLER) + PREVFRAME) + + (* ;; "NB: THIS MACRO MUST TRACK \VALUES-UFN, EXCEPT FOR THE PC-SETTING CODE. THIS ONE IS USED IN THE FUNCTIONS CL:VALUES AND CL:VALUES-LIST.") + + (* ;; "This macro is used by VALUES and VALUES-LIST to possibly return multiple values. It works by examining the caller to see if the next instruction is MVLIST (currently in the form of a FN1 \MVLIST), which is present in all multiple-value receivers. If so, it bumps the pc past there and returns the MANY expression, whose value is a list of all the values. If it encounters RETURN instead, the call was tail-recursive, so procedure repeats with caller's caller, etc. Otherwise, multiple values are not expected, and the macro returns just ONE value (the first) to the caller.") + + NEWFRAME + (RETURN (PROG ((PC (fetch (FX PC) of CALLER)) + (CODE (fetch (FX FNHEADER) of CALLER)) + (NUNBINDS 0) + BYTE) + NEWPC + [SELECTC (SETQ BYTE (\GETBASEBYTE CODE PC)) + ((LIST (OP# RETURN) + (OP# \RETURN)) (* ; + "Call is tail-recursive, so iterate. \RETURN is for LLBREAKing.") + (SETQ PREVFRAME CALLER) + (SETQ CALLER (fetch (FX CLINK) of CALLER)) + (GO NEWFRAME)) + ((OP# FN1) (* ; "Could be MVLIST") + (SELECTQ [\INDEXATOMDEF + (NEW-SYMBOL-CODE [BIG-VMEM-CODE + [\VAG2 (create WORD + HIBYTE _ + (\GETBASEBYTE CODE + (+ PC 1)) + LOBYTE _ + (\GETBASEBYTE CODE + (+ PC 2))) + (create WORD + HIBYTE _ + (\GETBASEBYTE CODE + (+ PC 3)) + LOBYTE _ + (\GETBASEBYTE CODE + (+ PC 4] + (\VAG2 (\GETBASEBYTE CODE + (+ PC 1)) + (create WORD + HIBYTE _ + (\GETBASEBYTE CODE + (+ PC 2)) + LOBYTE _ + (\GETBASEBYTE CODE + (+ PC 3] + (create WORD + HIBYTE _ (\GETBASEBYTE CODE (+ PC 1)) + LOBYTE _ (\GETBASEBYTE CODE (+ PC 2] + (\MVLIST (* ; + "Bump PC past the call, and return the values list") + (UNINTERRUPTABLY + (COND + ((NEQ NUNBINDS 0) + (* ; + "Sigh. We have to simulate the unbinding, since we need to get past the MVLIST.") + (\SIMULATE.UNBIND CALLER NUNBINDS PREVFRAME) + )) + + (* ;; + "Update the PC to skip over the FN1 opcode 1+(# of bytes in a symbol in the code stream):") + + (replace (FX PC) of CALLER + with (NEW-SYMBOL-CODE (BIG-VMEM-CODE + (+ PC 5) + (+ PC 4)) + (+ PC 3)))) + (RETURN MANY)) + NIL)) + ((OP# UNBIND) (* ; + "UNBIND appears. This preserves the top of stack, so it should also preserve multiple values.") + (add PC 1) + (add NUNBINDS 1) + (GO NEWPC)) + ((OP# JUMPX) (* ; "Follow the jump (yecch)") + (add PC (COND + ((>= (SETQ BYTE (\GETBASEBYTE CODE (+ PC 1))) + 128) + (- BYTE 256)) + (T BYTE))) + (GO NEWPC)) + ((OP# JUMPXX) + (add PC (SIGNED (create WORD + HIBYTE _ (\GETBASEBYTE CODE + (+ PC 1)) + LOBYTE _ (\GETBASEBYTE CODE + (+ PC 2))) + BITSPERWORD)) + (GO NEWPC)) + (LET [(JUMPBASE (CONSTANT (CAAR (\FINDOP 'JUMP] + (COND + ([<= JUMPBASE BYTE (CONSTANT (CADAR (\FINDOP 'JUMP] + (add PC (+ (- BYTE JUMPBASE) + 2)) + (GO NEWPC] + (RETURN ONE] + +[PUTPROPS \VALUES-UFN MACRO + ((MANY ONE CALLER-FRAME RESULT-IVAR) + (PROG* ((IMMEDIATE-CALLER (OR CALLER-FRAME (\MYALINK))) + (CALLER IMMEDIATE-CALLER) + PREVFRAME) + + (* ;; "NB: THIS MACRO MUST TRACK \VALUES, EXCEPT FOR THE PC SETTING CODE. THIS ONE IS USED IN THE UFNs FOR VALUES AND VALUES-LIST.") + + (* ;; "This macro is used by VALUES and VALUES-LIST to possibly return multiple values. It works by examining the caller to see if the next instruction is MVLIST (currently in the form of a FN1 \MVLIST), which is present in all multiple-value receivers. If so, it bumps the pc past there and returns the MANY expression, whose value is a list of all the values. If it encounters RETURN instead, the call was tail-recursive, so procedure repeats with caller's caller, etc. Otherwise, multiple values are not expected, and the macro returns just ONE value (the first) to the caller.") + + NEWFRAME + (RETURN (PROG ((PC (fetch (FX PC) of CALLER)) + (CODE (fetch (FX FNHEADER) of CALLER)) + (NUNBINDS 0) + BYTE) + NEWPC + [SELECTC (SETQ BYTE (\GETBASEBYTE CODE PC)) + ((LIST (OP# RETURN) + (OP# \RETURN)) (* ; + "Call is tail-recursive, so iterate. \RETURN is for LLBREAKing.") + (SETQ PREVFRAME CALLER) + (SETQ CALLER (fetch (FX CLINK) of CALLER)) + (GO NEWFRAME)) + ((OP# FN1) (* ; "Could be MVLIST") + (SELECTQ [\INDEXATOMDEF (create WORD + HIBYTE _ (\GETBASEBYTE + CODE + (+ PC 1)) + LOBYTE _ (\GETBASEBYTE + CODE + (+ PC 2] + (\MVLIST (* ; + "Bump PC past the call, and return the values list") + (LET (VALS) + (SETQ VALS MANY) + + (* ;; "This LET & SETQ forces MANY to be computed before we dink with the stack (which seems to destroy some of the values!)") + + (REPLACE (FX NEXTBLOCK) OF + IMMEDIATE-CALLER + WITH (LOLOC RESULT-IVAR)) + (UNINTERRUPTABLY + (COND + ((NEQ NUNBINDS 0) + (* ; + "Sigh. We have to simulate the unbinding, since we need to get past the MVLIST.") + (\SIMULATE.UNBIND CALLER NUNBINDS + PREVFRAME))) + [COND + ((EQ CALLER IMMEDIATE-CALLER) + + (* ;; "If the immediate caller has the MVLIST, then the PC has already been bumped, courtesy of the microcode.") + + (replace (FX PC) of CALLER + with (+ PC 3))) + (T + (* ;; + "Otherwise, we should skip over the FN1 \MVLIST.") + + (replace (FX PC) of CALLER + with (+ PC 3]) + (SI::UNWIND IMMEDIATE-CALLER) + (RETURN VALS))) + NIL)) + ((OP# UNBIND) (* ; + "UNBIND appears. This preserves the top of stack, so it should also preserve multiple values.") + (add PC 1) + (add NUNBINDS 1) + (GO NEWPC)) + ((OP# JUMPX) (* ; "Follow the jump (yecch)") + (add PC (COND + ((>= (SETQ BYTE (\GETBASEBYTE CODE + (+ PC 1))) + 128) + (- BYTE 256)) + (T BYTE))) + (GO NEWPC)) + ((OP# JUMPXX) + (add PC (SIGNED (create WORD + HIBYTE _ (\GETBASEBYTE CODE + (+ PC 1)) + LOBYTE _ (\GETBASEBYTE CODE + (+ PC 2))) + BITSPERWORD)) + (GO NEWPC)) + (LET [(JUMPBASE (CONSTANT (CAAR (\FINDOP 'JUMP] + (COND + ([<= JUMPBASE BYTE (CONSTANT (CADAR (\FINDOP 'JUMP] + (add PC (+ (- BYTE JUMPBASE) + 2)) + (GO NEWPC] + (RETURN ONE] +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +) + +(CL:DEFCONSTANT CL:MULTIPLE-VALUES-LIMIT 512) + + + +(* ;; "UFNs for the CL:VALUES and CL:VALUES-LIST sub-opcodes of MISCN:") + +(DEFINEQ + +(CL::VALUES-UFN [LAMBDA (CL::INDEX CL::ARGCOUNT CL::ARG-PTR) (* ; "Edited 5-Jun-90 15:21 by jds") (* ;; "This is the UFN for the VALUES MISCN opcode. Its definition must be analogous to that for CL:VALUES, in case anything changes.") (* ;; "* * * * * * *") (* ;; "Architectural note: This function assumes that it is called by an unwind-protect from \miscn.ufn. Therefore, it skips two frames before deciding whether to pass back one valur or many.") (\VALUES-UFN (for I from 0 to (LLSH (SUB1 CL::ARGCOUNT) 1) by 2 collect (\GETBASEPTR CL::ARG-PTR I)) (AND (IGEQ CL::ARGCOUNT 1) (\GETBASEPTR CL::ARG-PTR 0)) (fetch (FX CLINK) of (fetch (FX CLINK) of (\MYALINK))) CL::ARG-PTR]) + +(CL::VALUES-LIST-UFN [LAMBDA (CL::INDEX CL::ARGCOUNT CL::ARG-PTR) (* ; "Edited 5-Jun-90 15:21 by jds") (* ;; "This is the UFN for the VALUES-LIST MISCN opcode. Its definition must be analogous to that for CL:VALUES-LIST, in case anything changes.") (* ;; "* * * * * * *") (* ;; "Architectural note: This function assumes that it is called by an unwind-protect from \miscn.ufn. Therefore, it skips two frames before deciding whether to pass back one value or many.") (LET ((CL:VALUES (\GETBASEPTR CL::ARG-PTR 0))) (\VALUES-UFN CL:VALUES (CAR CL:VALUES) (fetch (FX CLINK) of (fetch (FX CLINK) of (\MYALINK))) CL::ARG-PTR]) +) + +(PUTPROPS LLMVS FILETYPE :FAKE-COMPILE-FILE) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA CL:VALUES) +) +(PUTPROPS LLMVS COPYRIGHT ("Xerox Corporation" 1986 1987 1989 1990 1991 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1405 3160 (CL:VALUES 1415 . 1720) (CL:VALUES-LIST 1722 . 1971) (\MVLIST 1973 . 2008) ( +\SIMULATE.UNBIND 2010 . 3158)) (17594 19305 (CL::VALUES-UFN 17604 . 18560) (CL::VALUES-LIST-UFN 18562 + . 19303))))) +STOP diff --git a/sources/LLNEW b/sources/LLNEW new file mode 100644 index 00000000..f345aeaf --- /dev/null +++ b/sources/LLNEW @@ -0,0 +1,847 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Feb-95 16:21:44" {DSK}sources>LLNEW.;15 69572 changes to%: (RECORDS CONSPAGE) previous date%: "24-Aug-94 10:56:08" {DSK}sources>LLNEW.;14) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1990, 1992, 1993, 1994, 1995 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLNEWCOMS) (RPAQQ LLNEWCOMS ((PROPS (LLNEW FILETYPE)) (DECLARE%: DONTCOPY EVAL@COMPILE (FILES (LOADCOMP) LLCODE)) [COMS (* ; "low level memory access") (FNS \ADDBASE \GETBASE \PUTBASE \PUTBASE.UFN \PUTBASEPTR.UFN \PUTBITS.UFN \GETBASEBYTE \PUTBASEBYTE \GETBASEPTR \PUTBASEPTR \HILOC \LOLOC \VAG2 \RPLPTR \RPLPTR.UFN) (FNS EQ EQL) (PROP BYTEMACRO EQL) (FNS LOC VAG) (FNS CREATEPAGES \NEW4PAGE) (DECLARE%: DONTCOPY (EXPORT (RECORDS POINTER WORD) (MACROS PTRGTP .COERCE.TO.SMALLPOSP. .COERCE.TO.BYTE.)) (ADDVARS (INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE)) (RDCOMS (FNS \CAR.UFN \CDR.UFN) (FNS \COPY \UNCOPY) (FNS \GETBASEBYTE \PUTBASEBYTE)) (INITPTRS (\LISTPDTD)) (MKI.SUBFNS (\ADDBASE . I.ADDBASE) (\GETBASE . I.GETBASE) (\PUTBASE . I.PUTBASE) (\GETBASEPTR . I.GETBASEPTR) (\PUTBASEPTR . I.PUTBASEPTR) (\HILOC . I.HILOC) (\LOLOC . I.LOLOC) (\VAG2 . I.VAG2) (.COERCE.TO.SMALLPOSP. . PROG1) (.COERCE.TO.BYTE. . PROG1) (LOCKEDPAGEP . MKI.LOCKEDPAGEP) (\RPLPTR . I.PUTBASEPTR) (CONS . I.\CONS.UFN)) (RD.SUBFNS (\ADDBASE . VADDBASE) (\GETBASE . VGETBASE) (\PUTBASE . VPUTBASE) (\GETBASEPTR . VGETBASEPTR) (\PUTBASEPTR . VPUTBASEPTR) (\HILOC . VHILOC) (\LOLOC . VLOLOC) (\VAG2 . VVAG2) (.COERCE.TO.SMALLPOSP. . PROG1) (.COERCE.TO.BYTE. . PROG1) (PTRGTP . IGREATERP) (\RPLPTR . VPUTBASEPTR) (CAR . V\CAR.UFN) (CDR . V\CDR.UFN) (CAR/CDRERR . T))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS CREATEPAGES] [COMS (* ; "cons cells") (FNS CONS \CONS.UFN \MAIKO.CONS.UFN CAR \CAR.UFN CDR \CDR.UFN RPLACA \RPLACA.UFN RPLACD \RPLACD.UFN DOCOLLECT \RPLCONS ENDCOLLECT \INITCONSPAGE \NEXTCONSPAGE) (ADDVARS (\MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN))) (FNS \RESTLIST.UFN \FINDKEY.UFN) (INITVARS (CAR/CDRERR 'CDR)) (DECLARE%: DONTCOPY (GLOBALVARS CAR/CDRERR) (EXPORT (RECORDS LISTP CONSPAGE) (CONSTANTS * CONSCONSTANTS)) (MACROS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.) (* ; "for MAKEINIT") (ADDVARS (INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE)) (EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.))) (COMS (* ; "testing out CONSes") (FNS CHECKCONSPAGES \CHECKCONSPAGE) (DECLARE%: DONTCOPY (MACROS !CHECK] [COMS (* ; "other random stuff for makeinit") (FNS MAKEINITFIRST MAKEINITLAST \COPY \UNCOPY) (DECLARE%: DONTCOPY (EXPORT (MACROS LOCAL ALLOCAL)) (ADDVARS (MKI.SUBFNS (CHECK . *) (RAID . HELP) (UNINTERRUPTABLY . PROGN) (\StatsAdd1 . *) (EVQ . I.\COPY) (COPY . I.\COPY)) (RD.SUBFNS (CHECK . *) (RAID . HELP) (UNINTERRUPTABLY . PROGN) (\StatsAdd1 . *) (EVQ . V\COPY) (COPY . V\COPY) (1ST . V\UNCOPY))) (ADDVARS (INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST))) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY] (LOCALVARS . T))) (PUTPROPS LLNEW FILETYPE :BCOMPL) (DECLARE%: DONTCOPY EVAL@COMPILE (FILESLOAD (LOADCOMP) LLCODE) ) (* ; "low level memory access") (DEFINEQ (\ADDBASE + [LAMBDA (X D) (* lmm " 2-NOV-81 18:33") + + (* ;; "usually done in microcode; this version uses only arithmetic and \VAG2") + + (PROG (NH NL (XH (\HILOC X)) + (XL (\LOLOC X))) + (.UNBOX. D NH NL) + (COND + [(IGREATERP XL (IDIFFERENCE MAX.SMALL.INTEGER NL)) + (* ; "carry") + (add XH 1) + (SETQ XL (SUB1 (IDIFFERENCE XL (IDIFFERENCE MAX.SMALL.INTEGER NL] + (T (add XL NL))) + (COND + [(IGREATERP NH MAX.POS.HINUM) + (SETQ XH (SUB1 (IDIFFERENCE XH (IDIFFERENCE MAX.SMALL.INTEGER NH] + (T (add XH NH))) + (RETURN (\VAG2 XH XL]) (\GETBASE + [LAMBDA (X D) (* lmm " 2-NOV-81 18:33") + + (* ;; "usually done in microcode; case where D=0 MUST be done in microcode") + + (\GETBASE (\ADDBASE X D) + 0]) (\PUTBASE + [LAMBDA (X D V) (* lmm "11-FEB-83 07:35") + + (* ;; "usually done in microcode; case where D=0 MUST be handled there") + + (\PUTBASE (\ADDBASE X D) + 0 + (.COERCE.TO.SMALLPOSP. V]) (\PUTBASE.UFN + [LAMBDA (X V D) (* lmm "11-FEB-83 07:35") + + (* ;; "usually done in microcode; case where D=0 MUST be handled there") + + (\PUTBASE (\ADDBASE X D) + 0 + (.COERCE.TO.SMALLPOSP. V]) (\PUTBASEPTR.UFN + [LAMBDA (X V D) (* lmm "10-NOV-81 15:12") + + (* ;; "usually done in microcode; this def uses only PUTBASE, ADDBASE, etc") + + (\PUTBASE X D (\HILOC V)) + (\PUTBASE (\ADDBASE X D) + 1 + (\LOLOC V)) + V]) (\PUTBITS.UFN + [LAMBDA (X V N.FD) (* lmm "11-FEB-83 07:35") + (PROG ((NV (.COERCE.TO.SMALLPOSP. V)) + (WIDTH (ADD1 (LOGAND N.FD 15))) + (FIRST (LRSH (LOGAND N.FD 255) + 4)) + MASK SHIFT) + (SETQ SHIFT (IDIFFERENCE 16 (IPLUS FIRST WIDTH))) + (SETQ MASK (SUB1 (LLSH 1 WIDTH))) + (\PUTBASE (SETQ X (\ADDBASE X (LRSH N.FD 8))) + 0 + (LOGOR (LOGAND (\GETBASE X 0) + (LOGXOR 65535 (LLSH MASK SHIFT))) + (LLSH (LOGAND NV MASK) + SHIFT))) + (RETURN NV]) (\GETBASEBYTE + [LAMBDA (PTR N) (* bvm%: " 5-Feb-85 12:05") + + (* ;; +"usually done in microcode; this def. uses only \GETBASE and arithmetic --- used by MAKEINIT too") + + (COND + [(EVENP N) + (fetch (WORD HIBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD] + (T (fetch (WORD LOBYTE) of (\GETBASE PTR (FOLDLO N BYTESPERWORD]) (\PUTBASEBYTE + [LAMBDA (PTR DISP BYTE) (* JonL "31-Dec-83 23:48") + + (* ;; "usually done in microcode --- this def used by MAKEINIT too") + + (SETQ BYTE (.COERCE.TO.BYTE. BYTE)) + [\PUTBASE PTR (FOLDLO (SETQ DISP (\DTEST DISP 'SMALLP)) + BYTESPERWORD) + (COND + ((EVENP DISP BYTESPERWORD) + (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD)) + HIBYTE _ BYTE)) + (T (create WORD using (\GETBASE PTR (FOLDLO DISP BYTESPERWORD)) + LOBYTE _ BYTE] + BYTE]) (\GETBASEPTR + [LAMBDA (X D) (* ; "Edited 24-Aug-94 09:29 by sybalsky") + + (* ;; + "usually done in microcode; this def. uses GETBASE, VAG2, etc. and handles overflows too") + + (\VAG2 (\GETBASE X D) + (\GETBASE (\ADDBASE X 1) + D]) (\PUTBASEPTR + [LAMBDA (X D V) (* lmm " 2-NOV-81 18:35") + + (* ;; "usually done in microcode; this def uses only PUTBASE, ADDBASE, etc") + + (\PUTBASE X D (\HILOC V)) + (\PUTBASE (\ADDBASE X D) + 1 + (\LOLOC V)) + V]) (\HILOC + [LAMBDA (X) (* lmm "10-MAR-81 15:02") + (* ; "MUST be handled in microcode") + (\HILOC X]) (\LOLOC + [LAMBDA (X) (* lmm "10-MAR-81 15:03") + (* ; "MUST be handled in microcode") + (\LOLOC X]) (\VAG2 + [LAMBDA (H L) (* ; "Edited 24-Aug-94 09:28 by sybalsky") + + (* ;; "case where H is byte and L is smallposp MUST be handled in microcode. Other cases may run error here.") + + (\VAG2 (BIG-VMEM-CODE (.COERCE.TO.SMALLPOSP. H) + (.COERCE.TO.BYTE. H)) + (.COERCE.TO.SMALLPOSP. L]) (\RPLPTR + [LAMBDA (OBJ OFFSET VAL) (* lmm " 3-NOV-81 12:10") + (UNINTERRUPTABLY + (\ADDREF VAL) + (\DELREF (\GETBASEPTR (SETQ OBJ (\ADDBASE OBJ OFFSET)) + 0)) + (\PUTBASEBYTE OBJ 1 (\HILOC VAL)) (* ; + "\PUTBASEPTR smashes the high byte") + (\PUTBASE OBJ 1 (\LOLOC VAL)) + VAL)]) (\RPLPTR.UFN + [LAMBDA (OBJ VAL OFFSET) (* ; "Edited 14-Jan-87 16:34 by Pavel") + +(* ;;; "The UFN is different from the function since the offset (inline) gets pushed last.") + + (LET ((SLOT (\ADDBASE OBJ OFFSET))) + (UNINTERRUPTABLY + + (* ;; "Fix up the reference counts.") + + (\ADDREF VAL) + (\DELREF (\GETBASEPTR SLOT 0)) + + (* ;; "\PUTBASEPTR smashes the high byte, so we use two calls instead.") + + (\PUTBASEBYTE SLOT 1 (\HILOC VAL)) + (\PUTBASE SLOT 1 (\LOLOC VAL)) + + (* ;; "Be sure to return the OBJ; code generated by the new compiler counts on it.") + + OBJ)]) ) (DEFINEQ (EQ + [LAMBDA (X Y) (* lmm "10-MAR-81 15:04") + (* ; "MUST be handled in microcode") + (EQ X Y]) (EQL + [LAMBDA (X Y) (* ; "Edited 6-Jul-87 09:40 by jop") + +(* ;;; "Like EQ except for numbers") + + (COND + ((OR (NOT (CL:NUMBERP X)) + (TYPEP X 'CL:FIXNUM)) + (EQ X Y)) + [(CL:FLOATP X) + + (* ;; + "32 bit compare --- differs from feqp in that the predicate is not true for -0.0 and 0.0") + + (AND (CL:FLOATP Y) + (EQ (fetch LOWORD of X) + (fetch LOWORD of Y)) + (EQ (fetch HIWORD of X) + (fetch HIWORD of Y] + ((CL:INTEGERP X) + (AND (CL:INTEGERP Y) + (IEQP X Y))) + [(TYPEP X 'RATIO) + (AND (TYPEP Y 'RATIO) + (EQL (CL::RATIO-NUMERATOR X) + (CL::RATIO-NUMERATOR Y)) + (EQL (CL::RATIO-DENOMINATOR X) + (CL::RATIO-DENOMINATOR Y] + ((TYPEP X 'COMPLEX) + (AND (TYPEP Y 'COMPLEX) + (EQL (CL::COMPLEX-REALPART X) + (CL::COMPLEX-REALPART Y)) + (EQL (CL::COMPLEX-IMAGPART X) + (CL::COMPLEX-IMAGPART Y]) ) (PUTPROPS EQL BYTEMACRO COMP.EQ) (DEFINEQ (LOC + [LAMBDA (X) (* lmm " 2-NOV-81 18:29") + (* ; + "Return HILOC-LOLOC pair, for easier traffic with RAID. VAG interprets such pairs correctly.") + (CONS (\HILOC X) + (\LOLOC X]) (VAG + [LAMBDA (LOC) (* lmm " 2-NOV-81 18:28") + (* ; "LOC can be a HILOC-LOLOC pair") + (COND + [(LISTP LOC) + (\VAG2 (CAR LOC) + (OR (FIXP (CDR LOC)) + (FIX (CADR LOC] + (T (\VAG2 (\HINUM LOC) + (\LONUM LOC]) ) (DEFINEQ (CREATEPAGES + [LAMBDA (VA N BLANKFLG LOCKFLG) (* bvm%: "29-MAR-83 16:35") + + (* ;; "called only under MAKEINIT --- BLANKFLG means that MAKEINIT won't write on this page, so fake it --- to prevent storage overflow when running on Maxc and init'ing GC table") + + (for I from 0 to (SUB1 N) do (\NEWPAGE (\ADDBASE VA (UNFOLD I WORDSPERPAGE)) + NIL LOCKFLG BLANKFLG)) + VA]) (\NEW4PAGE + [LAMBDA (PTR) (* ; + "Edited 24-Oct-92 12:45 by sybalsky:mv:envos") + + (* ;; "Instantiates a block of 4 new virtual pages, starting with the one at PTR.") + + (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE (\ADDBASE (\NEWPAGE PTR) + WORDSPERPAGE)) + WORDSPERPAGE)) + WORDSPERPAGE]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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))) ) (DECLARE%: EVAL@COMPILE [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] ) (* "END EXPORTED DEFINITIONS") (ADDTOVAR INEWCOMS (FNS \GETBASEBYTE \PUTBASEBYTE CREATEPAGES \NEW4PAGE)) (ADDTOVAR RDCOMS (FNS \CAR.UFN \CDR.UFN) (FNS \COPY \UNCOPY) (FNS \GETBASEBYTE \PUTBASEBYTE)) (ADDTOVAR INITPTRS (\LISTPDTD)) (ADDTOVAR MKI.SUBFNS (\ADDBASE . I.ADDBASE) (\GETBASE . I.GETBASE) (\PUTBASE . I.PUTBASE) (\GETBASEPTR . I.GETBASEPTR) (\PUTBASEPTR . I.PUTBASEPTR) (\HILOC . I.HILOC) (\LOLOC . I.LOLOC) (\VAG2 . I.VAG2) (.COERCE.TO.SMALLPOSP. . PROG1) (.COERCE.TO.BYTE. . PROG1) (LOCKEDPAGEP . MKI.LOCKEDPAGEP) (\RPLPTR . I.PUTBASEPTR) (CONS . I.\CONS.UFN)) (ADDTOVAR RD.SUBFNS (\ADDBASE . VADDBASE) (\GETBASE . VGETBASE) (\PUTBASE . VPUTBASE) (\GETBASEPTR . VGETBASEPTR) (\PUTBASEPTR . VPUTBASEPTR) (\HILOC . VHILOC) (\LOLOC . VLOLOC) (\VAG2 . VVAG2) (.COERCE.TO.SMALLPOSP. . PROG1) (.COERCE.TO.BYTE. . PROG1) (PTRGTP . IGREATERP) (\RPLPTR . VPUTBASEPTR) (CAR . V\CAR.UFN) (CDR . V\CDR.UFN) (CAR/CDRERR . T)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS CREATEPAGES) ) (* ; "cons cells") (DEFINEQ (CONS + [LAMBDA (X Y) (* lmm "11-FEB-82 13:55") + (* ; + "use microcode UFN to get to \CONS.UFN") + ((OPCODES CONS) + X Y]) (\CONS.UFN + [LAMBDA (X Y) (* ; "Edited 8-Dec-92 16:46 by jds") + [COND + ((ZEROP CDRCODING) + (RAID) + (PROG ((CELL (CREATECELL \LISTP))) + (replace (LISTP CAR) of CELL with X) + (replace (LISTP CDR) of CELL with Y) + (RETURN CELL] + (UNINTERRUPTABLY + (\ADDREF X) + (\ADDREF Y) + (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD)) + (.INCREMENT.ALLOCATION.COUNT. 1) + (PROG (CNS.PAGE CELL) + [SETQ CNS.PAGE (COND + ((NOT Y) + [COND + ((AND (SETQ CNS.PAGE (CREATE POINTER + PAGE# _ (FETCH DTDNEXTPAGE + OF \LISTPDTD))) + (IGREATERP (FETCH (CONSPAGE CNT) OF CNS.PAGE) + 0))) + (T (SETQ CNS.PAGE (\NEXTCONSPAGE] + (.MAKECONSCELL. CNS.PAGE X \CDR.NIL)) + ((AND (EQ (NTYPX Y) + \LISTP) + (IGREATERP (fetch (CONSPAGE CNT) + of (SETQ CNS.PAGE (fetch (POINTER + PAGEBASE) + of Y))) + 0) + (SETQ CELL (.FINDCLOSEPRIOR. CNS.PAGE X Y))) + + (* ;; + "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT") + (* .MAKECONSCELL. CNS.PAGE X + (IPLUS \CDR.ONPAGE + (fetch (POINTER DBLWORD#) of Y))) + CELL) + (T (.FINDPAIR. X Y] + (\DELREF CNS.PAGE) + (RETURN CNS.PAGE)))]) (\MAIKO.CONS.UFN + [LAMBDA (X Y) (* ; "Edited 3-Jun-90 21:03 by nm") + + (* ;; "Maiko specific \CONS.UFN. Does not decrement \RECLAIM.COUNTDOWN.") + + [COND + ((ZEROP CDRCODING) + (RAID) + (PROG ((CELL (CREATECELL \LISTP))) + (replace (LISTP CAR) of CELL with X) + (replace (LISTP CDR) of CELL with Y) + (RETURN CELL] + (UNINTERRUPTABLY + (\ADDREF X) + (\ADDREF Y) + (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD)) + (.CHECK.ALLOCATION.COUNT. 1) + (PROG (CNS.PAGE) + [SETQ CNS.PAGE (COND + [(AND (EQ (NTYPX Y) + \LISTP) + (IGREATERP (fetch (CONSPAGE CNT) + of (SETQ CNS.PAGE (fetch (POINTER + PAGEBASE) + of Y))) + 0)) (* ; + "Test for any cells left on page --- NTYPX rather than LISTP test for benefit of MAKEINIT") + (.MAKECONSCELL. CNS.PAGE X (IPLUS \CDR.ONPAGE (fetch + (POINTER DBLWORD#) + of Y] + (T (.MAKECONSCELL. (SETQ CNS.PAGE (\NEXTCONSPAGE)) + X + (COND + ((NULL Y) + \CDR.NIL) + (T (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#) + of (.MAKECONSCELL. + CNS.PAGE Y 0] + (\DELREF CNS.PAGE) + (RETURN CNS.PAGE)))]) (CAR + [LAMBDA (X) (* lmm "11-FEB-82 13:56") + ((OPCODES CAR) + X]) (\CAR.UFN + [LAMBDA (X) (* lmm "18-Jul-84 00:07") + + (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS") + + (\CALLME 'CAR) + (COND + [(LISTP X) + (COND + ((ZEROP CDRCODING) + (fetch (LISTP CAR) of X)) + (T (COND + ((EQ (fetch CDRCODE of X) + \CDR.INDIRECT) + (fetch CARFIELD of (fetch CARFIELD of X))) + (T (fetch CARFIELD of X] + ((NULL X) + NIL) + (T (SELECTQ CAR/CDRERR + (T (LISPERROR "ARG NOT LIST" X)) + ((NIL CDR) + (COND + ((EQ X T) + T) + ((LITATOM X) + NIL) + (T '"{car of non-list}"))) + (COND + ((EQ X T) + T) + ((STRINGP X) + (LISPERROR "ARG NOT LIST" X)) + (T '"{car of non-list}"]) (CDR + [LAMBDA (X) (* lmm "11-FEB-82 13:56") + ((OPCODES CDR) + X]) (\CDR.UFN + [LAMBDA (X) (* lmm "17-Jul-84 22:26") + + (* ;; "most cases handled in microcode --- this code also used by MAKEINIT/READSYS") + + (\CALLME 'CDR) + (COND + [(LISTP X) + (COND + ((ZEROP CDRCODING) + (fetch (LISTP CDR) of X)) + (T (PROG ((Q (fetch CDRCODE of X))) + (RETURN (COND + ((EQ Q \CDR.NIL) + NIL) + ((IGREATERP Q \CDR.ONPAGE) + (\ADDBASE (fetch (POINTER PAGEBASE) of X) + (LLSH (IDIFFERENCE Q \CDR.ONPAGE) + 1))) + ((EQ Q \CDR.INDIRECT) + (\CDR.UFN (fetch CARFIELD of X))) + (T (fetch CARFIELD of (\ADDBASE (fetch PAGEBASE + of X) + (LLSH Q 1] + ((NULL X) + NIL) + (T (SELECTQ CAR/CDRERR + ((T CDR) + (LISPERROR "ARG NOT LIST" X)) + (NIL (COND + ((LITATOM X) + (GETPROPLIST X)) + (T "{cdr of non-list}"))) + (COND + ((STRINGP X) + (LISPERROR "ARG NOT LIST" X)) + (T "{cdr of non-list}"]) (RPLACA + [LAMBDA (X Y) (* lmm "11-FEB-82 13:55") + (* ; "invoke \RPLACA.UFN") + ((OPCODES RPLACA) + X Y]) (\RPLACA.UFN + [LAMBDA (X Y) (* lmm " 1-DEC-81 21:17") + (COND + [(NLISTP X) + (COND + [(NULL X) (* ; "if X is NIL and Y is NIL ok") + (COND + (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y] + (T (LISPERROR "ARG NOT LIST" X] + (T (COND + ((ZEROP CDRCODING) + (replace (LISTP CAR) of X with Y) + X) + (T (UNINTERRUPTABLY + (\DELREF (CAR X)) + (\ADDREF Y) + (replace CARFIELD of (COND + ((EQ (fetch CDRCODE of X) + \CDR.INDIRECT) + (fetch CARFIELD of X)) + (T X)) with Y) + X)]) (RPLACD + [LAMBDA (X Y) (* lmm "11-FEB-82 13:55") + ((OPCODES RPLACD) + X Y]) (\RPLACD.UFN + [LAMBDA (X Y) (* lmm "11-JAN-82 10:15") + (COND + [(NLISTP X) + (COND + [(NULL X) (* ; "if X is NIL and Y is NIL ok") + (COND + (Y (LISPERROR "ATTEMPT TO RPLAC NIL" Y] + (T (LISPERROR "ARG NOT LIST" X] + ((ZEROP CDRCODING) + (replace (LISTP CDR) of X with Y) + X) + (T (UNINTERRUPTABLY + (\DELREF (CDR X)) + (\ADDREF Y) + (PROG (RP.PAGE (RP.Q (fetch CDRCODE of X))) + (COND + ((EQ RP.Q \CDR.INDIRECT) + (SETQ RP.PAGE (fetch CARFIELD of X)) + (CHECK (ILEQ (fetch CDRCODE of RP.PAGE) + \CDR.MAXINDIRECT) + (NEQ (fetch CDRCODE of RP.PAGE) + \CDR.INDIRECT)) + (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of RP.PAGE) + (LLSH (IDIFFERENCE (fetch CDRCODE of RP.PAGE) + \CDR.INDIRECT) + 1))) + (CHECK (LISTP RP.PAGE) + (EQ 0 (fetch CDRCODE of RP.PAGE))) + (replace FULLCARFIELD of RP.PAGE with Y)) + ((ILEQ RP.Q \CDR.MAXINDIRECT) + (SETQ RP.PAGE (\ADDBASE (fetch PAGEBASE of X) + (LLSH (IDIFFERENCE RP.Q \CDR.INDIRECT) + 1))) + (CHECK (LISTP RP.PAGE) + (EQ 0 (fetch CDRCODE of RP.PAGE))) + (replace FULLCARFIELD of RP.PAGE with Y)) + ((NULL Y) + (replace CDRCODE of X with \CDR.NIL)) + [(EQ (SETQ RP.PAGE (fetch PAGEBASE of X)) + (fetch PAGEBASE of Y))(* ; "New CDR on same page") + (replace CDRCODE of X with (IPLUS \CDR.ONPAGE (fetch + (POINTER DBLWORD#) + of Y] + [(IGREATERP (fetch (CONSPAGE CNT) of RP.PAGE) + 0) (* ; "Room on page for cdr cell") + (replace CDRCODE of X with (IPLUS \CDR.INDIRECT + (fetch (POINTER DBLWORD#) + of (.MAKECONSCELL. + RP.PAGE Y 0] + (T [replace FULLCARFIELD of X + with (.MAKECONSCELL. (SETQ RP.PAGE (\NEXTCONSPAGE)) + (fetch CARFIELD of X) + (IPLUS \CDR.INDIRECT (fetch (POINTER DBLWORD#) + of (.MAKECONSCELL. RP.PAGE Y + 0] + (replace CDRCODE of X with \CDR.INDIRECT))) + (RETURN X)))]) (DOCOLLECT + [LAMBDA (ITEM LST) (* lmm%: "30-SEP-76 13:03:33") + (COND + ((NLISTP LST) + (FRPLACD (SETQ LST (LIST ITEM)) + LST)) + (T (CDR (FRPLACD LST (CONS ITEM (CDR LST]) (\RPLCONS + [LAMBDA (LST ITEM) (* bvm%: " 5-Feb-85 22:49") + (* (CDR (RPLACD LST + (CONS ITEM NIL)))) + (COND + [(AND (NEQ CDRCODING 0) + (LISTP LST) + (UNINTERRUPTABLY + + (* ;; "Have to go uninterruptable here so that someone doesn't change the CNT field to zero out from under us") + + [PROG ((CPAGE (fetch (POINTER PAGEBASE) of LST)) + CELL) + (RETURN (COND + ((AND (NEQ (fetch (CONSPAGE CNT) of CPAGE) + 0) + (IGREATERP (fetch CDRCODE of LST) + \CDR.MAXINDIRECT)) + (\ADDREF ITEM) + (\DELREF (CDR LST)) + (SETQ CELL (.MAKECONSCELL. CPAGE ITEM \CDR.NIL)) + (\StatsAdd1 (fetch DTDCNTLOC of \LISTPDTD)) + (.INCREMENT.ALLOCATION.COUNT. 1) + (replace CDRCODE of LST with + (IPLUS \CDR.ONPAGE + (fetch (POINTER + DBLWORD#) + of CELL))) + CELL])] + (T (SETQ ITEM (CONS ITEM NIL)) (* ; + "Have to be careful how this part is written, or compiler will turn it into RPLCONS !") + (RPLACD LST ITEM) + ITEM]) (ENDCOLLECT + [LAMBDA (X Y) (* lmm "21-MAR-81 13:37") + (COND + ((NULL X) + Y) + (T (PROG1 (CDR X) + (RPLACD X Y]) (\INITCONSPAGE + [LAMBDA (BASE LINK) (* ; "Edited 5-May-94 13:26 by jds") + (COND + ((ZEROP CDRCODING) + (RAID)) + (T (* "OLD VERSION:" PROG + ((J (replace (CONSPAGE NEXTCELL) of + BASE with 254)) CELL) LP + (COND ((IGREATERP J 4) + (SETQ CELL (\ADDBASE BASE J)) + (replace (LISTP FULLCARFIELD) of + CELL with NIL) (replace + (LISTP NEXTFREE) of CELL with + (SETQ J (IDIFFERENCE J 2))) + (GO LP))) (replace + (CONSPAGE CNT) of BASE with 126) + (* ; + "if LINK=NIL, stores a 0. This assumes that the pagebase of NIL is NIL") + (replace NEXTPAGE of BASE with + (fetch (POINTER PAGE#) of LINK)) + (RETURN BASE)) + + (* ;; "New, BIGVM, NEWCDRCODING, bit-swapped version.") + + (PROG ((J 254) + CELL) + (replace (CONSPAGE NEXTCELL) of BASE with (LOGXOR J 6)) + LP (COND + ((IGREATERP J 8) + (SETQ CELL (\ADDBASE BASE (LOGXOR J 6))) + (replace (LISTP FULLCARFIELD) of CELL with NIL) + (SETQ J (IDIFFERENCE J 2)) + (replace (LISTP NEXTFREE) of CELL with (LOGXOR J 6)) + (GO LP))) + (replace (CONSPAGE CNT) of BASE with 124) + (* ; + "if LINK=NIL, stores a 0. This assumes that the pagebase of NIL is NIL") + (replace NEXTPAGE of BASE with (fetch (POINTER PAGE#) of LINK)) + (RETURN BASE]) (\NEXTCONSPAGE + [LAMBDA NIL (* ; "Edited 8-Dec-92 01:57 by jds") + (CHECK (NULL \INTERRUPTABLE)) + (PROG ((N (fetch DTDNEXTPAGE of \LISTPDTD)) + PG) + (SETQ PG (\ALLOCMDSPAGE (fetch DTDTYPEENTRY of \LISTPDTD))) + (\INITCONSPAGE PG (\INITCONSPAGE (\ADDBASE PG WORDSPERPAGE) + (CREATE POINTER + PAGE# _ N))) + (replace DTDNEXTPAGE of \LISTPDTD with (PAGELOC PG)) + (RETURN PG]) ) (ADDTOVAR \MAIKO.MOVDS (\MAIKO.CONS.UFN \CONS.UFN)) (DEFINEQ (\RESTLIST.UFN + [LAMBDA (TAIL LASTN FIRSTN) (* bvm%: "31-Aug-86 16:30") + +(* ;;; "Handles &REST args by building a list of the args from FIRSTN thru LASTN, all consed onto the front of TAIL, which could be non-NIL in the case where the microcode has started the job") + + (COND + (TAIL (* ; + "Some already done, better take care of gc") + (\GC.HANDLEOVERFLOW))) + (LET* [(CALLER (\MYALINK)) + (BLINK (fetch (FX BLINK) of CALLER)) + (IVAR (fetch (BF IVAR) of BLINK)) + (BASE (STACKADDBASE (IDIFFERENCE IVAR WORDSPERCELL] + (for I from LASTN to FIRSTN by -1 + do (SETQ TAIL (CONS (\GETBASEPTR BASE (UNFOLD I WORDSPERCELL)) + TAIL)) + + (* ;; "Might want to experiment with stopping after one iteration to let the microcode do the rest of the consing") + finally (RETURN TAIL]) (\FINDKEY.UFN + [LAMBDA (KEY ARGN) (* bvm%: "15-Jul-86 16:51") + +(* ;;; "Searches argument list of current function for an argument EQ to KEY. Search starts at the argument index given as the alpha byte ARGN and examines every other argument. The first arg is numbered 1; i.e., arg(i) is located at ivar0 + 2*(i-1). If KEY is found as arg i, returns i+1 (which is later to be fed to ARG0); otherwise returns NIL.") + + (LET* [(CALLER (\MYALINK)) + (BLINK (fetch (FX BLINK) of CALLER)) + (IVAR (fetch (BF IVAR) of BLINK)) + (NARGS (SUB1 (FOLDLO (IDIFFERENCE BLINK IVAR) + WORDSPERCELL] + (for I from ARGN to NARGS by 2 + as [BASE _ (STACKADDBASE (PLUS IVAR (UNFOLD (SUB1 ARGN) + WORDSPERCELL] + by (\ADDBASE BASE (TIMES 2 WORDSPERCELL)) when (EQ (\GETBASEPTR + BASE 0) + KEY) + do (RETURN (ADD1 I]) ) (RPAQ? CAR/CDRERR 'CDR) (DECLARE%: DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CAR/CDRERR) ) (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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)) (DECLARE%: EVAL@COMPILE (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) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE [PUTPROPS .MAKECONSCELL. MACRO (OPENLAMBDA (PAGE A D) (PROG [(.MK.NEWCELL (\ADDBASE PAGE (fetch (CONSPAGE NEXTCELL) of PAGE] (CHECK (NEQ (fetch (CONSPAGE CNT) of PAGE) 0) (EVENP (fetch (CONSPAGE NEXTCELL) of PAGE))) (replace (CONSPAGE NEXTCELL) of PAGE with (fetch (LISTP NEXTFREE) of .MK.NEWCELL )) (CHECK (EVENP (fetch (CONSPAGE NEXTCELL) of PAGE))) (add (fetch (CONSPAGE CNT) of PAGE) -1) (replace (LISTP FULLCARFIELD) of .MK.NEWCELL with A) (replace (LISTP CDRCODE) of .MK.NEWCELL with D) (RETURN .MK.NEWCELL] [PUTPROPS .FINDCLOSEPRIOR. MACRO (OPENLAMBDA (PG A D) (LET ((CDROFFSET (LOGAND (\LOLOC D) 255)) (OFFSET (fetch (CONSPAGE NEXTCELL) of PG)) CELL PRIOR) (WHILE (NEQ OFFSET 0) DO (COND ((AND (ILEQ OFFSET CDROFFSET) (IGEQ OFFSET (IDIFFERENCE CDROFFSET 14))) (* ;;  "There's a cell close enough. Take it off the chain and return it.") [COND [PRIOR (* ;;  "There was a prior entry in the chain; detach this one.") (REPLACE (LISTP NEXTFREE) OF (\ADDBASE PG PRIOR) WITH (FETCH (LISTP NEXTFREE) OF (SETQ CELL (\ADDBASE PG OFFSET] (T (* ;; "No prior entry; set the conspage's NEXTCELL entry.") (REPLACE (CONSPAGE NEXTCELL) OF PG WITH (FETCH (LISTP NEXTFREE) OF (SETQ CELL (\ADDBASE PG OFFSET] (add (fetch (CONSPAGE CNT) of PG) -1) (replace (LISTP FULLCARFIELD) of CELL with A) (replace (LISTP CDRCODE) of CELL with (LOGOR \CDR.ONPAGE (LRSH (IDIFFERENCE CDROFFSET OFFSET) 1))) (RETURN CELL))) (SETQ PRIOR OFFSET) (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE PG OFFSET] [PUTPROPS .FINDCDRABLEPAIR. MACRO (OPENLAMBDA (PG A D) (LET ((OFFSET (fetch (CONSPAGE NEXTCELL) of PG)) CELL PRIOR PRIORPRIOR) (AND (IGEQ (FETCH (CONSPAGE CNT) OF PG) 2) (WHILE (NEQ OFFSET 0) DO (COND ((AND PRIOR (ILEQ OFFSET PRIOR) (IGEQ OFFSET (IDIFFERENCE PRIOR 14))) (* ;;  "There's a cell close enough. Take it off the chain and return it.") [COND [PRIORPRIOR (* ;;  "There was a prior entry in the chain; detach this one.") (REPLACE (LISTP NEXTFREE) OF (\ADDBASE PG PRIORPRIOR) WITH (FETCH (LISTP NEXTFREE) OF (SETQ CELL (\ADDBASE PG OFFSET] (T (* ;;  "No prior entry; set the conspage's NEXTCELL entry.") (REPLACE (CONSPAGE NEXTCELL) OF PG WITH (FETCH (LISTP NEXTFREE) OF (SETQ CELL (\ADDBASE PG OFFSET] (add (fetch (CONSPAGE CNT) of PG) -2) (\PUTBASEPTR (\ADDBASE PG PRIOR) 0 D) (REPLACE (LISTP FULLCARFIELD) OF CELL WITH A) (REPLACE (LISTP CDRCODE) OF CELL WITH (LRSH (IDIFFERENCE PRIOR OFFSET) 1)) (RETURN CELL))) (SETQ PRIORPRIOR PRIOR) (SETQ PRIOR OFFSET) (SETQ OFFSET (FETCH (LISTP NEXTFREE) OF (\ADDBASE PG OFFSET] [PUTPROPS .FINDPAIR. MACRO (OPENLAMBDA (A D) (LET ((PG (fetch DTDNEXTPAGE of \LISTPDTD)) CELL CPG) [WHILE (IGREATERP PG 0) DO (COND ((SETQ CELL (.FINDCDRABLEPAIR. (SETQ CPG (CREATE POINTER PAGE# _ PG)) A D)) (RETURN CELL)) (T (SETQ PG (FETCH (CONSPAGE NEXTPAGE) OF CPG] (OR CELL (.FINDCDRABLEPAIR. (\NEXTCONSPAGE) A D] ) (ADDTOVAR INEWCOMS (FNS \CONS.UFN \MAIKO.CONS.UFN \INITCONSPAGE \NEXTCONSPAGE)) (ADDTOVAR EXPANDMACROFNS .MAKECONSCELL. .FINDCLOSEPRIOR. .FINDCDRABLEPAIR. .FINDPAIR.) ) (* ; "testing out CONSes") (DEFINEQ (CHECKCONSPAGES + [LAMBDA NIL (* bvm%: "29-Jan-85 22:51") + (COND + ((ZEROP CDRCODING) + NIL) + (T [for (CPAGE _ (create POINTER + PAGE# _ (fetch DTDNEXTPAGE of \LISTPDTD))) + do (COND + ((NULL CPAGE) (* ; "End of free list") + (RETURN)) + ((NEQ (NTYPX CPAGE) + \LISTP) + + (* ;; "Free list not pointing at a cons page. Test is not for LISTP because LISTP is formally defined to be false for list page bases") + + (HELP CPAGE)) + (T (SETQ CPAGE (create POINTER + PAGE# _ (fetch (CONSPAGE NEXTPAGE) of CPAGE] + (\MAPMDS 'LISTP (FUNCTION \CHECKCONSPAGE]) (\CHECKCONSPAGE + [LAMBDA (PN) (* bvm%: "27-Jan-85 14:52") + (* ; "check if page PN is ok") + (PROG ((PTR (create POINTER + PAGE# _ PN)) + NXT CNT) + (SETQ CNT (fetch (CONSPAGE CNT) of PTR)) + (!CHECK (EVENP (SETQ NXT (fetch (CONSPAGE NEXTCELL) of PTR)) + WORDSPERCELL)) + LP (COND + ((IGREATERP CNT 0) + (!CHECK (AND (NEQ NXT 0) + (EVENP (SETQ NXT (fetch (LISTP CDRCODE) of (\ADDBASE PTR NXT)) + ) + WORDSPERCELL))) + (add CNT -1) + (GO LP))) + (!CHECK (EQ NXT 0]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS !CHECK MACRO ((X) (OR X (RAID 'X] ) ) (* ; "other random stuff for makeinit") (DEFINEQ (MAKEINITFIRST + [LAMBDA NIL (* bvm%: "13-Jun-86 15:41") + (CREATEMDSTYPETABLE) + (\SETUP.HUNK.TYPENUMBERS) + (INITDATATYPES) + (PREINITARRAYS) + (\TURN.ON.HUNKING) + (INITATOMS) + (INITDATATYPENAMES) + (INITUFNTABLE) + (INITGC) + (\NEWPAGE \InterfacePage NIL T]) (MAKEINITLAST + [LAMBDA (VERSIONS) (* Pavel "17-Oct-86 12:42") + (SETUPSTACK T) + (MAKEINITBFS) + (PROGN (* ; + "fold in property list and values gathered from boot files") + [SELECTQ (SYSTEMTYPE) + ((D ALTO) + [LOCAL (MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) + (SETPROPLIST A (COPY P] + [LOCAL (MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) + (SETTOPVAL A (COPY (LOCAL (CDR V]) + (PROG (AL GAG) + + (* ;; "the reason this is set up this way is because there is a bug in Interlisp-10 suchthat if a garbage collection happens in the middle of a MAPHASH, some of the values in the hash array may be missed because the garbage collector has moved stuff around and rehashed the data in the array. Thus we are careful to set things up so that no garbage collection happens") + + [ALLOCAL (PROGN [MINFS (IMAX (MINFS) + (ITIMES 2 (ARRAYSIZE (CAR MKI.PLHA))) + (ARRAYSIZE (CAR MKI.TVHA] + (RECLAIM) + (SETQ GAG (GCGAG "[***** GARBAGE COLLECTION - ERROR ******]")) + [MAPHASH MKI.PLHA (FUNCTION (LAMBDA (P A) + (push AL (CONS A P] + (SETQ GAG (GCGAG GAG] + [LOCAL (MAPC AL (FUNCTION (LAMBDA (X) + (SETPROPLIST (CAR X) + (COPY (CDR X] + (ALLOCAL (PROGN (SETQ AL) + (RECLAIM) + (SETQ GAG (GCGAG GAG)) + [MAPHASH MKI.TVHA (FUNCTION (LAMBDA (V A) + (push AL (RPLACA V A] + (GCGAG GAG))) + (LOCAL (MAPC AL (FUNCTION (LAMBDA (X) + (SETTOPVAL (CAR X) + (COPY (CDR X] + (* ; "set most initial variables") + ) + (PROG ((AFL (FILEARRAYBASE))) (* ; + "put output on a double page boundary --- output at least one page") + [LOCAL (BOUTZEROS (IDIFFERENCE (TIMES 2 BYTESPERPAGE) + (UNFOLD (IMOD (\LOLOC AFL) + (TIMES 2 WORDSPERPAGE)) + BYTESPERWORD] + (SETQ MKI.CODELASTPAGE (PAGELOC (FILEARRAYBASE))) + + (* ;; "now we can update the string/array space freelist to point beyond the code area --- We call POSTINITARRAYS with (a) pointer to word after end of compiled code, (b) page number of beginning of compiled code, and (c) page number after compiled code") + + (POSTINITARRAYS AFL (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET) + MKI.CODELASTPAGE)) + [MAPC (ALLOCAL (APPEND INITVALUES INITPTRS)) + (FUNCTION (LAMBDA (X) (* ; + "make sure atoms exist for initial atoms") + (\ATOMVALINDEX (LOCAL (CAR X] + [for X in INITVALUES as A in MKI.VALUES + do (SETQ A (LOCAL (EVALV A))) + (SETTOPVAL (LOCAL (CAR X)) + (COND + ([ALLOCAL (OR (EQ A T) + (EQ A NIL) + (AND (FIXP A) + (IGEQ A -65536) + (ILEQ A 65535] + (COPY A)) + (T (SHOULDNT] + [for X in INITPTRS as A in MKI.PTRS do (SETTOPVAL (LOCAL (CAR X)) + (LOCAL (EVALV A] + (for X in LOCKEDVARS do + + (* ;; "If the variable exists, then we lock it. Otherwise, just print a message and proceed anyway, hoping the fellow knows what he's doing. We don't want to create a new piece of storage at this point because we've already made a note of where our last allocated page is.") + + (IF (GETHASH X MKI.ATOMARRAY) + THEN (\LOCKVAR X) + ELSE (printout T "***Note: Locked var " X + " does not exist, proceeding anyway." T))) + (SETUPPAGEMAP) + (DUMPINITPAGES (IPLUS \FirstArrayPage MKI.CODESTARTOFFSET) + MKI.CODELASTPAGE VERSIONS]) (\COPY + [LAMBDA (X) (* ; "Edited 28-Jan-93 17:42 by jds") + + (* ;; "Prints X into the MAKEINIT / READSYS system") + + (SELECTQ (LOCAL (TYPENAME X)) + ((LITATOM NEW-ATOM) + (UNLESSRDSYS (MKI.ATOM X) + (VATOMNUMBER X T))) + (LISTP (PROG [(R (LOCAL (REVERSE X))) + (V (\COPY (LOCAL (CDR (LOCAL (LAST X] + LP (COND + ((LOCAL (LISTP R)) + (SETQ V (CONS (\COPY (LOCAL (CAR R))) + V)) + (SETQ R (LOCAL (CDR R))) + (GO LP))) + (RETURN V))) + ((FIXP SMALLP) + (PROG (V) + [COND + [(LOCAL (IGREATERP 0 X)) (* ; "negative") + (COND + ((LOCAL (IGREATERP X -65537)) (* ; "small neg") + (RETURN (\ADDBASE \SMALLNEGSPACE (LOCAL (LOGAND X 65535] + ((LOCAL (ILESSP X 65536)) (* ; "small pos") + (RETURN (\ADDBASE \SMALLPOSPSPACE X] + (* ; "need to create a boxed integer") + (SETQ V (CREATECELL \FIXP)) + (\PUTBASE V 0 (LOGOR (COND + ((IGREATERP 0 X) + 32768) + (T 0)) + (LOGAND (LRSH X 16) + 32767))) + (\PUTBASE V 1 (LOGAND X 65535)) + (RETURN V))) + (ONED-ARRAY (%%COPY-ONED-ARRAY X)) + (STRINGP (* ; "For bootstrapping only") + (%%COPY-STRING-TO-ARRAY X)) + (FLOATP (PROG ((VAL (CREATECELL \FLOATP))) + (SELECTQ (SYSTEMTYPE) + ((ALTO D) + (\PUTBASE VAL 0 (LOCAL (\GETBASE X 0))) + (\PUTBASE VAL 1 (LOCAL (\GETBASE X 1)))) + (MKI.IEEE X VAL)) + (RETURN VAL))) + (CHARACTER (\VAG2 \CHARHI (LOCAL (CL:CHAR-CODE X)))) + (ERROR X "can't be copied to remote file"]) (\UNCOPY + [LAMBDA (X CARLVL CDRLVL) (* ; "Edited 18-Mar-87 16:51 by raf") + (SELECTC (NTYPX X) + (\SMALLP (COND + ((EQ (\HILOC X) + \SmallPosHi) + + (* ;; "This test used to be SMALLPOSP until its definition changed to test (IGREATERP X 0), which doesn't work renamed") + + (\LOLOC X)) + (T (IPLUS (\LOLOC X) + -65536)))) + (\FIXP (* ; "INTEGER") + (LOCAL (create FIXP + HINUM _ (ffetch (FIXP HINUM) of X) + LONUM _ (ffetch (FIXP LONUM) of X)))) + (\FLOATP (LOCAL (create FLOATP + HIWORD _ (ffetch (FLOATP HIWORD) of X) + LOWORD _ (ffetch (FLOATP LOWORD) of X)))) + (\LITATOM (VATOM (\LOLOC X))) + (\STRINGP (PROG ((PTR (ffetch (STRINGP BASE) of X)) + (OFFST (ffetch (STRINGP OFFST) of X)) + (LENGTH (ffetch (STRINGP LENGTH) of X)) + (I 1) + STR) (* ; + "Use ffetch to avoid bogus DTEST's in the renamed version") + (SETQ STR (LOCAL (ALLOCSTRING LENGTH))) + (FRPTQ LENGTH [LOCAL (RPLSTRING STR I (LOCAL (FCHARACTER (\GETBASEBYTE + PTR OFFST] + (add I 1) + (add OFFST 1)) + (RETURN STR))) + (\CHARACTERP (LOCAL (\VAG2 \CHARHI (\LOLOC X)))) + (%%ONED-ARRAY (LET ((SIZE (ffetch (ONED-ARRAY TOTAL-SIZE) of X)) + (BASE (ffetch (ONED-ARRAY BASE) of X)) + (OFFSET (ffetch (ONED-ARRAY OFFSET) of X)) + (TYPENUMBER (ffetch (ONED-ARRAY TYPE-NUMBER) of X)) + NCELLS LOCAL-ARRAY LOCAL-BASE) + (if (EQ (%%TYPENUMBER-TO-GC-TYPE TYPENUMBER) + PTRBLOCK.GCT) + then (LOCAL (VTYPEDPOINTER (TYPENAME X) + X)) + else (SETQ NCELLS (FOLDHI (ITIMES (IPLUS SIZE OFFSET) + (%%TYPENUMBER-TO-BITS-PER-ELEMENT + TYPENUMBER)) + BITSPERCELL)) + (SETQ LOCAL-ARRAY (LOCAL (create ONED-ARRAY))) + (SETQ LOCAL-BASE (LOCAL (\ALLOCBLOCK NCELLS))) + (LOCAL (freplace (ONED-ARRAY BASE) of LOCAL-ARRAY + with LOCAL-BASE)) + (LOCAL (freplace (ONED-ARRAY STRING-P) of LOCAL-ARRAY + with (%%CHAR-TYPE-P TYPENUMBER))) + (LOCAL (freplace (ONED-ARRAY FILL-POINTER-P) of + LOCAL-ARRAY + with (ffetch (ONED-ARRAY FILL-POINTER-P) + of X))) + (LOCAL (freplace (ONED-ARRAY TYPE-NUMBER) of LOCAL-ARRAY + with TYPENUMBER)) + (LOCAL (freplace (ONED-ARRAY FILL-POINTER) of LOCAL-ARRAY + with (ffetch (ONED-ARRAY FILL-POINTER) + of X))) + (if (NEQ OFFSET 0) + then (LOCAL (freplace (ONED-ARRAY OFFSET) of + LOCAL-ARRAY + with OFFSET)) + (LOCAL (freplace (ONED-ARRAY DISPLACED-P) + of LOCAL-ARRAY with T))) + (LOCAL (freplace (ONED-ARRAY TOTAL-SIZE) of LOCAL-ARRAY + with SIZE)) + [for I from 0 to (SUB1 (LLSH NCELLS 1)) + do (LOCAL (\PUTBASE LOCAL-BASE I (\GETBASE BASE I] + LOCAL-ARRAY))) + (\LISTP [COND + [(LISTP X) + (COND + ((EQ CDRLVL 0) (* ; "Abbreviate") + '(--)) + (T (LOCAL (CONS [COND + ([OR (EQ CARLVL 0) + (AND (OR (EQ CARLVL 1) + (EQ CDRLVL 1)) + (LISTP (CAR X] + '&) + (T (\UNCOPY (CAR X) + (AND CARLVL (SUB1 CARLVL)) + (AND CDRLVL (SUB1 CDRLVL] + (\UNCOPY (CDR X) + CARLVL + (AND CDRLVL (SUB1 CDRLVL] + (T (* ; + "Redundant LISTP test in case X is list page header") + (ALLOCAL (VTYPEDPOINTER 'LISTP X]) + (0 (LOCAL (VTYPEDPOINTER NIL X))) + (LOCAL (VTYPEDPOINTER (TYPENAME X) + X]) ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS LOCAL MACRO ((X) X)) (PUTPROPS ALLOCAL MACRO ((X) X)) ) (* "END EXPORTED DEFINITIONS") (ADDTOVAR MKI.SUBFNS (CHECK . *) (RAID . HELP) (UNINTERRUPTABLY . PROGN) (\StatsAdd1 . *) (EVQ . I.\COPY) (COPY . I.\COPY)) (ADDTOVAR RD.SUBFNS (CHECK . *) (RAID . HELP) (UNINTERRUPTABLY . PROGN) (\StatsAdd1 . *) (EVQ . V\COPY) (COPY . V\COPY) (1ST . V\UNCOPY)) (ADDTOVAR INEWCOMS (FNS MAKEINITFIRST \COPY MAKEINITLAST)) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS MAKEINITFIRST \COPY MAKEINITLAST \UNCOPY) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS LLNEW COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1990 1992 1993 1994 1995)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5895 12403 (\ADDBASE 5905 . 6712) (\GETBASE 6714 . 6958) (\PUTBASE 6960 . 7236) ( \PUTBASE.UFN 7238 . 7518) (\PUTBASEPTR.UFN 7520 . 7842) (\PUTBITS.UFN 7844 . 8550) (\GETBASEBYTE 8552 . 8979) (\PUTBASEBYTE 8981 . 9672) (\GETBASEPTR 9674 . 10012) (\PUTBASEPTR 10014 . 10332) (\HILOC 10334 . 10558) (\LOLOC 10560 . 10784) (\VAG2 10786 . 11161) (\RPLPTR 11163 . 11640) (\RPLPTR.UFN 11642 . 12401)) (12404 13819 (EQ 12414 . 12632) (EQL 12634 . 13817)) (13858 14608 (LOC 13868 . 14199) (VAG 14201 . 14606)) (14609 15650 (CREATEPAGES 14619 . 15108) (\NEW4PAGE 15110 . 15648)) (20046 38779 (CONS 20056 . 20362) (\CONS.UFN 20364 . 22782) (\MAIKO.CONS.UFN 22784 . 25037) (CAR 25039 . 25166) ( \CAR.UFN 25168 . 26271) (CDR 26273 . 26400) (\CDR.UFN 26402 . 28001) (RPLACA 28003 . 28230) ( \RPLACA.UFN 28232 . 29231) (RPLACD 29233 . 29368) (\RPLACD.UFN 29370 . 33121) (DOCOLLECT 33123 . 33387 ) (\RPLCONS 33389 . 35399) (ENDCOLLECT 35401 . 35609) (\INITCONSPAGE 35611 . 38173) (\NEXTCONSPAGE 38175 . 38777)) (38837 41172 (\RESTLIST.UFN 38847 . 39945) (\FINDKEY.UFN 39947 . 41170)) (51822 53618 (CHECKCONSPAGES 51832 . 52771) (\CHECKCONSPAGE 52773 . 53616)) (53786 68392 (MAKEINITFIRST 53796 . 54134) (MAKEINITLAST 54136 . 59420) (\COPY 59422 . 61925) (\UNCOPY 61927 . 68390))))) STOP \ No newline at end of file diff --git a/sources/LLNS b/sources/LLNS new file mode 100644 index 00000000..ae901ce8 --- /dev/null +++ b/sources/LLNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 10:52:26" {DSK}lde>lispcore>sources>LLNS.;2 96283 changes to%: (RECORDS NSROUTINGINFO PACKETEXCHANGEXIP TIMEXIP) previous date%: " 5-Jan-93 00:53:11" {DSK}lde>lispcore>sources>LLNS.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLNSCOMS) (RPAQQ LLNSCOMS ((COMS (* ; "Xerox Internet Packet stuff.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) LLNSDECLS)) (ADDVARS * (LIST (CONS 'XIPTYPES RAWXIPTYPES))) (ALISTS (XIPERRORMESSAGES 1 2 3 513 514 515 516)) (GLOBALVARS XIPTYPES XIPERRORMESSAGES)) [COMS (* ;  "Parsing and looking up NS addresses") (FNS PARSE-NSADDRESS COERCE-TO-NSADDRESS \COERCE.NS.SOCKET) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;  "Assign these definitions also to obsolete internal names used in earlier software") (P (AND (CCODEP 'PARSE-NSADDRESS) (MOVD 'PARSE-NSADDRESS '\PARSE.NSADDRESSCONSTANT NIL T)) (AND (CCODEP 'COERCE-TO-NSADDRESS) (MOVD 'COERCE-TO-NSADDRESS '\COERCE.TO.NSADDRESS NIL T] (COMS (* ; "NSOCKET") (DECLARE%: DONTCOPY (GLOBALVARS \NSOCKETS \MAX.EPKTS.ON.NSOCKET) (MACROS \NSOCKET.FROM#)) (INITRECORDS NSOCKET) (SYSRECORDS NSOCKET) (FNS OPENNSOCKET CLOSENSOCKET NSOCKETEVENT NSOCKETNUMBER NSOCKETFROMNUMBER \FLUSHNSOCQUEUE) (INITVARS (\NSOCKETS) (\MAX.EPKTS.ON.NSOCKET 16))) (COMS (* ; "assorted level 1 and 2") (FNS \NSINIT STOPNS) (FNS \HANDLE.RAW.XIP \XIPERROR \FORWARD.XIP) (COMS (INITVARS (\NS.CHECKSUMFLG T)) (GLOBALVARS \NS.CHECKSUMFLG)) (FNS GETXIP DISCARDXIPS SENDXIP SWAPXIPADDRESSES \SETXIPCHECKSUM \CLEARXIPHEADER) (FNS \FILLINXIP XIPAPPEND.BYTE XIPAPPEND.WORD XIPAPPEND.CELL XIPAPPEND.STRING XIPAPPEND.IFSSTRING)) (COMS (* ; "XIP routing") (FNS \NSGATELISTENER \HANDLE.NS.ROUTING.INFO \CANONICALIZE.NSADDRESS \ROUTE.XIP \LOCATE.NSNET NSNET.DISTANCE BESTNSADDRESS SORT.NSADDRESSES.BY.DISTANCE \NSNET.CLOSERP) (INITVARS (\NS.ROUTING.TABLE NIL) (\NS.ROUTING.TABLE.RADIUS 4) (\NSROUTER.PROBECOUNT 0) (\NSROUTER.PROBETIMER NIL) (\NSROUTER.PROBEINTERVAL 3000) (\NS.READY NIL) (\NS.READY.EVENT (CREATE.EVENT "NS Ready")) (\NSADDRESS.CACHE NIL)) (ADDVARS (\SYSTEMCACHEVARS \NS.READY)) (DECLARE%: DONTCOPY (RECORDS NSROUTINGINFO) (CONSTANTS \NS.ROUTINGINFO.WORDS \XROUTINGINFO.OP.REQUEST \XROUTINGINFO.OP.RESPONSE) (GLOBALVARS \NS.ROUTING.TABLE \NS.ROUTING.TABLE.RADIUS \NSROUTER.PROBECOUNT \NSROUTER.PROBETIMER \NSROUTER.PROBEINTERVAL \NS.READY \NS.READY.EVENT \NSADDRESS.CACHE))) (COMS (* ;  "Analogous to PUP stuff for tracing activity.") (FNS XIPTRACE) (FNS PRINTXIP PRINTERRORXIP PRINTXIPROUTE PRINTXIPDATA) (INITVARS (XIPTRACEFLG) (XIPTRACEFILE T) (XIPTRACETIME)) (ALISTS (XIPONLYTYPES) (XIPIGNORETYPES) (XIPPRINTMACROS 1 2 3 4)) (PROP VARTYPE XIPPRINTMACROS) (ADDVARS (\PACKET.PRINTERS (1536 . PRINTXIP))) (DECLARE%: DONTCOPY (GLOBALVARS XIPTRACEFLG XIPTRACEFILE XIPIGNORETYPES XIPONLYTYPES XIPTRACETIME XIPPRINTMACROS))) [COMS (* ; "Peeking") (FNS \PEEKNS \MAYBEPEEKNS) (GLOBALVARS \PEEKNSNUMBER) (INITVARS (\PEEKNSNUMBER)) (COMS (FNS \PROMISCUOUS.ON \PROMISCUOUS.OFF) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \ETHERHOSTLOC] (COMS (* ;  "Simple packet exchange protocols") (FNS \GETMISCNSOCKET CREATE.PACKET.EXCHANGE.XIP EXCHANGEXIPS RELEASE.XIP) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (CCODEP '\ALLOCATE.ETHERPACKET) (MOVD '\ALLOCATE.ETHERPACKET 'ALLOCATE.XIP NIL T)) (AND (CCODEP '\RELEASE.ETHERPACKET) (MOVD '\RELEASE.ETHERPACKET 'RELEASE.XIP NIL T] (RECORDS PACKETEXCHANGEXIP) (CONSTANTS (\EXTYPE.REQUEST 1) (\EXTYPE.RESPONSE 2) (\EXTYPE.NEGATIVE 3)) (GLOBALVARS \MISC.NSOCKET \PACKET.EXCHANGE.CNTR) (INITVARS (\MISC.NSOCKET) (\PACKET.EXCHANGE.CNTR 0)) (FNS \LOOKUPPUPNUMBER)) (COMS (* ; "Time service") (FNS NSNETDAYTIME0 \NS.SETTIME) (DECLARE%: DONTCOPY (RECORDS TIMEXIP) (CONSTANTS \TIMESOCKET \TIMEOP.TIMEREQUEST \TIMEOP.TIMERESPONSE \TIMEVERSION \EXTYPE.TIME))) (COMS (* ; "Debugging") (FNS NS.ECHOUSER) (DECLARE%: DONTCOPY (CONSTANTS \XECHO.OP.REQUEST \XECHO.OP.REPLY)) (INITVARS (\DEFAULTECHOSERVER NIL) (\NS.ECHOUSERSOCKET NIL))) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NSINIT))) (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) LLETHER) (LOCALVARS . T)))) (* ; "Xerox Internet Packet stuff.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) LLNSDECLS) ) (ADDTOVAR XIPTYPES (\XIPT.ROUTINGINFO 1) (\XIPT.ECHO 2) (\XIPT.ERROR 3) (\XIPT.EXCHANGE 4) (\XIPT.SPP 5) (\XIPT.PUPLOOKUP 6)) (ADDTOVAR XIPERRORMESSAGES (1 "Bad checksum") (2 "No socket at destination") (3 "Destination congestion") (513 "Gateway: Bad checksum") (514 "Can't get there from here") (515 "Too many hops") (516 "Packet too large to forward")) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XIPTYPES XIPERRORMESSAGES) ) (* ; "Parsing and looking up NS addresses") (DEFINEQ (PARSE-NSADDRESS [LAMBDA (STR DEFAULTSOCKET) (* ; "Edited 13-Jan-88 15:36 by bvm") (* ;;; "If STR is a constant ether address of form net#host#socket, returns an NSADDRESS object, else NIL. DEFAULTSOCKET, if non-NIL, is socket to use if STR omits one.") (if (NOT (STRINGP STR)) then (SETQ STR (MKSTRING STR))) (LET* ((BASE (if (STRPOS "-" STR) then 10 else 8)) (MAXDIGIT (+ BASE (CHARCODE 0) -1)) NET HOST VAL NSHOST ADDR PREV10) (for CH instring STR do (COND [(AND (>= CH (CHARCODE 0)) (<= CH MAXDIGIT)) (* ; "Add digit into value") (SETQ VAL (+ (COND (VAL (TIMES VAL BASE)) (T 0)) (- CH (CHARCODE 0] [(EQ CH (CHARCODE %#)) (* ;  "# terminates net or host number. Do a left shift NET _ HOST _ newval") (COND (NET (* ; "Already have 3 parts?") (RETURN NIL))) (SETQ NET HOST) (SETQ HOST (COND (NSHOST (* ; "Accumulated pieces") (CONS (OR (SMALLP VAL) (RETURN NIL)) NSHOST)) (PREV10 (if VAL then (+ (TIMES 1000 PREV10) VAL) else (* ; "Bad syntax, e.g., 0-123-#") (RETURN NIL))) ((NULL VAL) (* ; "Empty field") 0) (T VAL))) (SETQ VAL (SETQ NSHOST (SETQ PREV10 NIL] ((EQ CH (CHARCODE %.)) (* ;  "Terminates part of a 3-part host number") (if (OR (NEQ BASE 8) (NOT (SMALLP VAL))) then (* ; "Bad syntax") (RETURN NIL) else (* ; "Accumulate host pieces") (push NSHOST VAL) (SETQ VAL NIL))) ((AND (EQ CH (CHARCODE -)) (EQ BASE 10)) (* ; "Decimal separator") (SETQ PREV10 (if PREV10 then (+ (TIMES 1000 PREV10) VAL) else VAL)) (SETQ VAL NIL)) (T (RETURN NIL))) finally (* ;  "Ran out of chars. Save last value parsed, make sure we have at least a net and host") (RETURN (COND ((AND HOST (NULL NSHOST) (NULL PREV10)) (* ; "Must have at least a host field (at least one #), and uncompleted field (socket) must not have components") (SETQ ADDR (create NSADDRESS)) (* ; "All parts start out zero") (replace NSSOCKET of ADDR with (OR (SMALLP (OR VAL DEFAULTSOCKET 0)) (RETURN NIL))) [COND [(LISTP HOST) (* ;  "Host came in a.b.c format. Low part comes first") (replace NSHNM2 of ADDR with (CAR HOST)) (if (SETQ HOST (CDR HOST)) then (replace NSHNM1 of ADDR with (CAR HOST)) (if (SETQ HOST (CDR HOST)) then (replace NSHNM0 of ADDR with (CAR HOST)) (if (CDR HOST) then (* ; "Too many pieces") (RETURN NIL] ((AND HOST (NEQ HOST 0)) (* ; "Need to store a 48-bit number") (replace NSHNM2 of ADDR with (LOGAND HOST MASKWORD1'S) ) (if (NEQ 0 (SETQ HOST (CL:ASH HOST -16))) then (replace NSHNM1 of ADDR with (LOGAND HOST MASKWORD1'S)) (if (NEQ 0 (SETQ HOST (CL:ASH HOST -16))) then (replace NSHNM0 of ADDR with (OR (SMALLP HOST) (RETURN NIL] [COND [(LISTP NET) (* ; "Net in form a.b") (replace NSNETLO of ADDR with (CAR NET)) (if (SETQ NET (CDR NET)) then (replace NSNETHI of ADDR with (CAR NET)) (if (CDR NET) then (* ; "Too many pieces") (RETURN NIL] ((AND NET (NEQ NET 0)) (* ; "Store 32-bit net") (replace NSNETLO of ADDR with (LOGAND NET MASKWORD1'S) ) (if (NEQ 0 (SETQ NET (CL:ASH NET -16))) then (replace NSNETHI of ADDR with (OR (SMALLP NET) (RETURN NIL] ADDR]) (COERCE-TO-NSADDRESS [LAMBDA (HOST DEFAULTSOCKET) (* ; "Edited 17-Aug-92 14:21 by jds") (CL:TYPECASE HOST ((OR LITATOM STRINGP) (OR (\PARSE.NSADDRESSCONSTANT (MKSTRING HOST) DEFAULTSOCKET) (\COERCE.NS.SOCKET (LOOKUP.NS.SERVER HOST) DEFAULTSOCKET))) (LISTP [COND ((type? NSHOSTNUMBER HOST) (create NSADDRESS NSHOSTNUMBER _ HOST NSSOCKET _ (OR DEFAULTSOCKET 0]) (NSADDRESS (\COERCE.NS.SOCKET HOST DEFAULTSOCKET)) (T NIL))]) (\COERCE.NS.SOCKET [LAMBDA (ADDR DEFAULTSOCKET) (* bvm%: "15-Feb-85 01:47") (* ;;; "If DEFAULTSOCKET is non-NIL and ADDR's socket is zero, create a new address with DEFAULTSOCKET as the socket") (COND ((AND ADDR DEFAULTSOCKET (EQ (fetch NSSOCKET of ADDR) 0)) (PROG ((COPYADDR (create NSADDRESS NSSOCKET _ DEFAULTSOCKET))) (\BLT COPYADDR ADDR (SUB1 \#WDS.NSADDRESS)) (RETURN COPYADDR))) (T ADDR]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (AND (CCODEP 'PARSE-NSADDRESS) (MOVD 'PARSE-NSADDRESS '\PARSE.NSADDRESSCONSTANT NIL T)) (AND (CCODEP 'COERCE-TO-NSADDRESS) (MOVD 'COERCE-TO-NSADDRESS '\COERCE.TO.NSADDRESS NIL T)) ) (* ; "NSOCKET") (DECLARE%: DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NSOCKETS \MAX.EPKTS.ON.NSOCKET) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \NSOCKET.FROM# MACRO (OPENLAMBDA (SOCNUM) (for SOC in \NSOCKETS when (EQ SOCNUM (fetch ID# of SOC)) do (RETURN SOC] ) ) (/DECLAREDATATYPE 'NSOCKET '((BITS 4) POINTER WORD WORD FLAG FLAG (BITS 2) POINTER WORD WORD POINTER) '((NSOCKET 0 (BITS . 3)) (NSOCKET 0 POINTER) (NSOCKET 2 (BITS . 15)) (NSOCKET 3 (BITS . 15)) (NSOCKET 4 (FLAGBITS . 0)) (NSOCKET 4 (FLAGBITS . 16)) (NSOCKET 4 (BITS . 33)) (NSOCKET 4 POINTER) (NSOCKET 6 (BITS . 15)) (NSOCKET 7 (BITS . 15)) (NSOCKET 8 POINTER)) '10) (ADDTOVAR SYSTEMRECLST (DATATYPE NSOCKET ((NIL BITS 4) (NSOCLINK POINTER) (ID# WORD) (NSOCHANDLE WORD) (NSOC#OPENP FLAG) (NSOC#CONNECTIONP FLAG) (NIL BITS 2) (INQUEUE POINTER) (INQUEUELENGTH WORD) (NSOC#ALLOCATION WORD) (NSOCEVENT POINTER))) ) (DEFINEQ (OPENNSOCKET [LAMBDA (SKT# IFCLASH) (* bvm%: " 7-Nov-85 17:53") (* ;; "Creates a new local NSOCKET If SKT# is supplied, it is the identifying number (16-bit) of the socket, and an error occurs if that socket is already in use.") (PROG ((ID#EXPLICIT? (FIXP SKT#)) NSOC CLASHP) [COND ((type? NSOCKET SKT#) (SETQ NSOC (OR (\NSOCKET.FROM# (fetch ID# of SKT#)) (PROGN (push \NSOCKETS SKT#) SKT#))) (\FLUSHNSOCQUEUE NSOC)) (T [COND ((NOT ID#EXPLICIT?) (* ;  "Pick a socket that is reasonably random but won't conflict with well-known sockets") (SETQ SKT# (LOGOR 32768 (LOGXOR (RAND) (fetch (FIXP LONUM) of (LOCF (fetch SECONDSCLOCK of \MISCSTATS] (UNINTERRUPTABLY [do (COND ((NOT (SETQ CLASHP (\NSOCKET.FROM# SKT#))) (push \NSOCKETS (SETQ NSOC (create NSOCKET ID# _ SKT#))) (replace NSOCEVENT of NSOC with (CREATE.EVENT NSOC)) (RETURN)) [(NOT ID#EXPLICIT?) (SETQ SKT# (LOGOR 32768 (ADD1 (LOGAND SKT# 32767] (T (RETURN]) (COND (CLASHP (SELECTQ IFCLASH ((T ACCEPT) (\FLUSHNSOCQUEUE (SETQ NSOC CLASHP))) ((DON'T FAIL) (RETURN NIL)) (ERROR "Socket number is already in use" SKT#] (RETURN NSOC]) (CLOSENSOCKET [LAMBDA (NSOC NOERRORFLG) (* bvm%: "26-MAY-83 14:11") (* ;; "Closes a local NSOCKET -- argument = T means close all sockets") (COND [(EQ NSOC T) (while \NSOCKETS do (UNINTERRUPTABLY (\FLUSHNSOCQUEUE (SETQ NSOC (pop \NSOCKETS))) (replace NSOCEVENT of NSOC with NIL))] (T (SETQ NSOC (\DTEST NSOC 'NSOCKET)) (UNINTERRUPTABLY (\FLUSHNSOCQUEUE NSOC) (replace NSOCEVENT of NSOC with NIL) (* ; "Break circular link") (COND ((FMEMB NSOC \NSOCKETS) (SETQ \NSOCKETS (DREMOVE NSOC \NSOCKETS)) T) ((NOT NOERRORFLG) (ERROR NSOC "not an open NS socket"))))]) (NSOCKETEVENT [LAMBDA (NSOC) (* bvm%: "26-MAY-83 14:14") (ffetch NSOCEVENT of (\DTEST NSOC 'NSOCKET]) (NSOCKETNUMBER [LAMBDA (NSOC) (* bvm%: "10-Jun-84 16:10") (ffetch (NSOCKET ID#) of (\DTEST NSOC 'NSOCKET]) (NSOCKETFROMNUMBER [LAMBDA (SOC#) (* bvm%: " 7-AUG-83 01:40") (\NSOCKET.FROM# SOC#]) (\FLUSHNSOCQUEUE [LAMBDA (NSOC) (* bvm%: "11-FEB-83 12:56") (\FLUSH.PACKET.QUEUE (fetch (NSOCKET INQUEUE) of NSOC)) (replace (NSOCKET INQUEUELENGTH) of NSOC with 0) NSOC]) ) (RPAQ? \NSOCKETS ) (RPAQ? \MAX.EPKTS.ON.NSOCKET 16) (* ; "assorted level 1 and 2") (DEFINEQ (\NSINIT [LAMBDA (EVENT MINI) (* ; "Edited 15-Jan-88 00:30 by bvm") (* ;; "Enable NS network. MINI means just enough to broadcast packets and receive answers (used by \LOOKUPPUPNUMBER)") (for SOC in \NSOCKETS do (\FLUSHNSOCQUEUE SOC)) (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.XIP)) [PROG [(PROC (FIND.PROCESS '\NSGATELISTENER] (OR \LOCALNDBS (RETURN)) (COND ((NULL MINI) [COND (\3MBLOCALNDB (* ;  "If we want to talk XIPs on 3mb net, we need to be able to handle translations") (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.10TO3))) (T (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.10TO3] (* ;  "Initiate router probe to find out what our net is") (SETQ \NS.ROUTING.TABLE (\CLEAR.ROUTING.TABLE \NS.ROUTING.TABLE)) (SETQ \NSADDRESS.CACHE (CONS)) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ \NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (* ;  "Tells gate listener to probe for routing when it gets going.") (COND (\GATEWAYFLG (AND PROC (DEL.PROCESS PROC))) (PROC (RESTART.PROCESS PROC)) (T (ADD.PROCESS '(\NSGATELISTENER) 'RESTARTABLE 'SYSTEM 'AFTEREXIT \NS.READY.EVENT))) (SETQ \NSFLG T] (SETQ \NS.READY T) (NOTIFY.EVENT \NS.READY.EVENT]) (STOPNS [LAMBDA NIL (* bvm%: "17-FEB-83 15:57") (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.XIP)) (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.10TO3)) (DEL.PROCESS '\NSGATELISTENER) (CLOSENSOCKET T) (SETQ \NSFLG NIL]) ) (DEFINEQ (\HANDLE.RAW.XIP [LAMBDA (XIP TYPE) (* ; "Edited 16-Jul-90 15:54 by jds") (* ;; "Handles the arrival of a raw XIP. If it is destined for a local socket that has room for it, we queue it up, else release it") (COND ((EQ TYPE \EPT.XIP) [PROG ((MYADDR \MY.NSADDRESS) DESTADDR NSOC CSUM NDB DESTNET MYNET) [COND ((NULL \NS.READY) (RETURN (RELEASE.XIP XIP] (SETQ DESTADDR (LOCF (fetch XIPDESTNET of XIP))) (* ;  "Treat the destination field of XIP like an NSADDRESS. Use FFETCH to avoid bogus type check") [COND ((AND (EQ (ffetch NSHNM2 of DESTADDR) (ffetch NSHNM2 of MYADDR)) (EQ (ffetch NSHNM1 of DESTADDR) (ffetch NSHNM1 of MYADDR)) (EQ (ffetch NSHNM0 of DESTADDR) (ffetch NSHNM0 of MYADDR))) (* ; "Packet addressed to me") ) ((EQ (LOGAND (ffetch NSHNM0 of DESTADDR) (ffetch NSHNM1 of DESTADDR) (ffetch NSHNM2 of DESTADDR)) MASKWORD1'S) (* ;  "Broadcast packet--we'll have a look") ) (T (* ; "Not for us") (RETURN (\FORWARD.XIP XIP] (SETQ NDB (fetch EPNETWORK of XIP)) (* ;; "If it's a packet not connected to any network, ignore it:") (OR NDB (RETURN T)) (SETQ MYNET (fetch NDBNSNET# of NDB)) (* ;; "Now check to see if the NET is reasonable. It should always be, except when someone thinks we're a gateway") [COND ([NOT (COND ((EQ (ffetch NSNETHI of DESTADDR) 0) (* ;  "Small net, easy test: take it if lo half is our number, or is zero, or we are zero") (OR (EQ (SETQ DESTNET (ffetch NSNETLO of DESTADDR)) MYNET) (EQ DESTNET 0) (EQ MYNET 0))) [(SMALLP MYNET) (* ; "Destination is small, but we're not. Only for us if MYNET is zero, in which case need to save DESTNET for later") (AND (EQ MYNET 0) (SETQ DESTNET (ffetch NSNET of DESTADDR] ((AND (EQ (ffetch NSNETLO of DESTADDR) (fetch (FIXP LONUM) of MYNET)) (EQ (ffetch NSNETHI of DESTADDR) (fetch (FIXP HINUM) of MYNET))) (* ; "Large destination is equal to us. No need to box that destination. We are uninterested in destination otherwise (except when MYNET is 0, which is handled in previous clause).") (SETQ DESTNET MYNET] (* ;; "Packet is explicitly for a net other than us. If we don't know our net, or packet doesn't know its, continue on.") (RETURN (\FORWARD.XIP XIP] (COND [[NULL (SETQ NSOC (\NSOCKET.FROM# (fetch XIPDESTSOCKET of XIP] (* ;  "Packets addressed to non-active sockets are just ignored.") (COND (XIPTRACEFLG (PRIN1 '& XIPTRACEFILE))) (LET (XIPBASE) (COND [(AND (EQ (fetch XIPTYPE of XIP) \XIPT.ECHO) (EQ (fetch XIPDESTSOCKET of XIP) \NS.WKS.Echo) (EQ (\GETBASE (SETQ XIPBASE (fetch XIPCONTENTS of XIP)) 0) \XECHO.OP.REQUEST)) (* ; "Play echo server") (COND ([AND (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD] (\XIPERROR XIP \XIPE.CHECKSUM)) (T (\PUTBASE XIPBASE 0 \XECHO.OP.REPLY) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with 'FREE) (SENDXIP NIL XIP] (T (\XIPERROR XIP \XIPE.NOSOCKET] ((IGEQ (fetch (NSOCKET INQUEUELENGTH) of NSOC) (fetch (NSOCKET NSOC#ALLOCATION) of NSOC)) (* ;  "Note that packets are just 'dropped' when the queue overflows.") (\XIPERROR XIP \XIPE.SOCKETFULL)) ([AND \NS.CHECKSUMFLG (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD] (\XIPERROR XIP \XIPE.CHECKSUM)) (T [COND ((EQ DESTNET 0) (* ;  "Fill in unspecified destination net (possibly redundantly with zero)") (replace XIPDESTNET of XIP with MYNET)) ((EQ MYNET 0) (* ;; "Packet of specific destination net has arrived on a socket that we listen to. If we don't know our own net number, assume sender is telling the truth") (replace NDBNSNET# of NDB with DESTNET) (replace NSNET of \MY.NSADDRESS with (SETQ \MY.NSNETNUMBER DESTNET)) (LET [(ENTRY (OR (\LOCATE.NSNET DESTNET T) (\ADD.ROUTING.TABLE.ENTRY \NS.ROUTING.TABLE (create ROUTING RTNET# _ DESTNET] (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) (replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T] (UNINTERRUPTABLY (\ENQUEUE (fetch (NSOCKET INQUEUE) of NSOC) XIP) (add (fetch (NSOCKET INQUEUELENGTH) of NSOC) 1) (NOTIFY.EVENT (fetch NSOCEVENT of NSOC)))] T]) (\XIPERROR [LAMBDA (XIP ERRCODE) (* bvm%: "21-Jun-84 14:49") (* ;;; "Turn packet around into an error packet with given error") (COND ((AND (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER)) (NEQ (fetch XIPTYPE of XIP) \XIPT.ERROR)) (* ;  "Don't respond to errors or to broadcasts!") (PROG (LENGTH) [\BLT (LOCF (fetch ERRORXIPBODY of XIP)) (fetch XIPBASE of XIP) (SETQ LENGTH (IMIN (fetch XIPLENGTH of XIP) (IPLUS \XIPOVLEN 12] (* ;; "Copy header plus some data into data portion. BLT is in the right direction for the overlap to work") (replace ERRORXIPCODE of XIP with ERRCODE) (replace ERRORXIPARG of XIP with 0) (replace XIPLENGTH of XIP with (IPLUS LENGTH \XIPOVLEN (UNFOLD 2 BYTESPERWORD) )) (replace XIPTYPE of XIP with \XIPT.ERROR) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with 'FREE) (SENDXIP NIL XIP))) (T (\RELEASE.ETHERPACKET XIP]) (\FORWARD.XIP [LAMBDA (XIP) (* bvm%: "12-OCT-83 15:44") (* ;; "Called when we receive a XIP not addressed to us. Unless we are a gateway, dump it") (COND (\GATEWAYFLG (\GATEWAY.FORWARD.XIP XIP)) (\PEEKNSNUMBER (\MAYBEPEEKNS XIP)) (T (COND (XIPTRACEFLG (PRINTXIP XIP 'GET NIL "XIP not addressed to this host: "))) (\RELEASE.ETHERPACKET XIP]) ) (RPAQ? \NS.CHECKSUMFLG T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NS.CHECKSUMFLG) ) (DEFINEQ (GETXIP [LAMBDA (NSOC WAIT) (* bvm%: "26-MAY-83 15:48") (PROG ([NSOCQ (ffetch (NSOCKET INQUEUE) of (\DTEST NSOC 'NSOCKET] EPKT TIMER) LP (UNINTERRUPTABLY (AND (SETQ EPKT (\DEQUEUE NSOCQ)) (add (ffetch (NSOCKET INQUEUELENGTH) of NSOC) -1))) (COND [(NULL EPKT) (COND (WAIT (COND ((EQ WAIT T)) [TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN] (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (ffetch NSOCEVENT of NSOC) TIMER T) (GO LP] [(EQ \EPT.XIP (fetch EPTYPE of EPKT)) (AND XIPTRACEFLG (\MAYBEPRINTPACKET EPKT 'GET] (T (AND XIPTRACEFLG (printout XIPTRACEFILE T "Non-XIP packet " EPKT " arrived on " NSOC T)) (SETQ EPKT))) (RETURN EPKT]) (DISCARDXIPS [LAMBDA (NSOC) (* bvm%: "11-FEB-83 12:56") (UNINTERRUPTABLY (\FLUSH.PACKET.QUEUE (fetch (NSOCKET INQUEUE) of NSOC)) (replace (NSOCKET INQUEUELENGTH) of NSOC with 0))]) (SENDXIP [LAMBDA (SOCKET XIP) (* bvm%: "26-OCT-83 16:31") (* ;;  "Returns the XIP arg iff packet can be sent; returns a litatom explaining error otherwise") (replace EPTYPE of XIP with \EPT.XIP) (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (replace XIPTCONTROL of XIP with 0) (until \NS.READY do (AWAIT.EVENT \NS.READY.EVENT)) (PROG (NDB) (\RCLK (LOCF (fetch EPTIMESTAMP of XIP))) (RETURN (COND ((fetch EPTRANSMITTING of XIP) (AND XIPTRACEFLG (printout XIPTRACEFILE "[Put failed--packet already being transmitted]")) 'AlreadyQueued) ((NULL (SETQ NDB (\ROUTE.XIP XIP))) (AND XIPTRACEFLG (PRINTXIPROUTE XIP "[Put fails--no routing]" XIPTRACEFILE) ) (\REQUEUE.ETHERPACKET XIP) 'NoRouting) (T (\SETXIPCHECKSUM XIP) (AND XIPTRACEFLG (\MAYBEPRINTPACKET XIP 'PUT)) (TRANSMIT.ETHERPACKET NDB XIP) NIL]) (SWAPXIPADDRESSES [LAMBDA (XIP) (* bvm%: "28-Nov-83 17:59") (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (PROG ((NDB (\DTEST (ffetch EPNETWORK of XIP) 'NDB)) (DESTSOCKET (ffetch XIPDESTSOCKET of XIP))) (\BLT (LOCF (ffetch XIPDESTNET of XIP)) (LOCF (ffetch XIPSOURCENET of XIP)) \#WDS.NSADDRESS) (freplace XIPSOURCESOCKET of XIP with DESTSOCKET) (freplace XIPSOURCENET of XIP with (ffetch NDBNSNET# of NDB)) (freplace XIPSOURCEHOST of XIP with \MY.NSHOSTNUMBER]) (\SETXIPCHECKSUM [LAMBDA (XIP) (* bvm%: " 6-FEB-83 18:43") (* ;; "Sets the XIPCHECKSUM field of XIP to checksum over its current contents") (replace XIPCHECKSUM of XIP with (COND [\NS.CHECKSUMFLG (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD] (T \NULLCHECKSUM))) T]) (\CLEARXIPHEADER [LAMBDA (XIP) (* bvm%: "15-Feb-85 01:41") (* ; "Clears the header of XIP") (\CLEARWORDS [fetch XIPBASE of (SETQ XIP (\DTEST XIP 'ETHERPACKET] (FOLDHI \XIPOVLEN BYTESPERWORD]) ) (DEFINEQ (\FILLINXIP [LAMBDA (TYPE SOURCENSOCKET DESTHOST DESTSOCKET# DESTNET LENGTH EPKT) (* ; "Edited 13-Jan-88 15:30 by bvm") (* ;; "Sets indicated fields of EPKT to non-NIL args. DESTHOST may be either an NSADDRESS or a NSHOSTNUMBER") (PROG NIL (COND ((NULL EPKT) (SETQ EPKT (\ALLOCATE.ETHERPACKET)) (replace EPTYPE of EPKT with \EPT.XIP) (\CLEARXIPHEADER EPKT) (OR LENGTH (SETQ LENGTH \XIPOVLEN))) (T (SETQ EPKT (\DTEST EPKT 'ETHERPACKET)) (replace EPTYPE of EPKT with \EPT.XIP))) (replace XIPTCONTROL of EPKT with 0) (* ; "Always zero when transmitted") (replace XIPTYPE of EPKT with (OR TYPE 0)) (replace XIPSOURCENSADDRESS of EPKT with (\LOCALNSADDRESS)) (* ; "Will put 0 in the socket field") (AND SOURCENSOCKET (replace XIPSOURCESOCKET of EPKT with (fetch (NSOCKET ID#) of SOURCENSOCKET ))) (replace XIPLENGTH of EPKT with (OR LENGTH \XIPOVLEN)) [COND ((type? NSADDRESS DESTHOST) (replace XIPDESTNSADDRESS of EPKT with DESTHOST) (AND DESTNET (EQ (fetch NSNET of DESTHOST) 0) (replace XIPDESTNET of EPKT with DESTNET)) (AND DESTSOCKET# (EQ (fetch NSSOCKET of DESTHOST) 0) (replace XIPDESTSOCKET of EPKT with DESTSOCKET#))) (T [COND ((type? NSHOSTNUMBER DESTHOST) (* ;  "Just doesn't put anything in the NET or DESTSOCKET# fields") (replace XIPDESTHOST of EPKT with DESTHOST) (AND DESTSOCKET# (replace XIPDESTSOCKET of EPKT with DESTSOCKET#))) (T (replace XIPDESTNSADDRESS of EPKT with (OR (PARSE-NSADDRESS DESTHOST DESTSOCKET#) (\ILLEGAL.ARG DESTHOST] (AND DESTNET (replace XIPDESTNET of EPKT with DESTNET] (RETURN EPKT]) (XIPAPPEND.BYTE [LAMBDA (XIP BYTE OFFSET) (* bvm%: "16-FEB-83 15:09") (* ;; "Make OFFSET'th byte of XIP'S data be BYTE. OFFSET defaults to the end of the packet, in which case the length is updated") (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (PROG [(WHERE (OR OFFSET (IDIFFERENCE (fetch XIPLENGTH of XIP) \XIPOVLEN] (COND ((IGEQ WHERE \MAX.XIPDATALENGTH) (RETURN))) (COND ((NOT OFFSET) (add (fetch XIPLENGTH of XIP) 1))) (\PUTBASEBYTE (fetch XIPCONTENTS of XIP) WHERE BYTE]) (XIPAPPEND.WORD [LAMBDA (XIP WORD OFFSET) (* bvm%: "16-FEB-83 15:11") (* ;; "Make OFFSET'th word of XIP'S data be WORD. OFFSET defaults to the end of the packet, in which case the length is updated") (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (PROG (LENGTH WHERE) [SETQ WHERE (COND (OFFSET (UNFOLD OFFSET BYTESPERWORD)) (T (IDIFFERENCE (SETQ LENGTH (CEIL (fetch XIPLENGTH of XIP) BYTESPERWORD)) \XIPOVLEN] (COND ((IGREATERP (IPLUS WHERE BYTESPERWORD) \MAX.XIPDATALENGTH) (ERROR XIP "Not enough room for another word"))) [COND ((NOT OFFSET) (replace XIPLENGTH of XIP with (IPLUS LENGTH BYTESPERWORD] (\PUTBASE (fetch XIPCONTENTS of XIP) (FOLDLO WHERE BYTESPERWORD) WORD]) (XIPAPPEND.CELL [LAMBDA (XIP CELL OFFSET) (* bvm%: "16-FEB-83 15:13") (* ;; "Word-aligns the beginning, and puts down two words (a 'cell' , or LONG CARDINAL). OFFSET defaults to the end of the packet, in which case the length is updated") (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (PROG (LENGTH WHERE) [SETQ WHERE (COND (OFFSET (UNFOLD OFFSET BYTESPERWORD)) (T (IDIFFERENCE (SETQ LENGTH (CEIL (fetch XIPLENGTH of XIP) BYTESPERWORD)) \XIPOVLEN] (COND ((IGREATERP (IPLUS WHERE BYTESPERCELL) \MAX.XIPDATALENGTH) (ERROR XIP "Not enough room for another word"))) [COND ((NOT OFFSET) (replace XIPLENGTH of XIP with (IPLUS LENGTH BYTESPERCELL] (SETQ WHERE (\ADDBASE (fetch XIPCONTENTS of XIP) (FOLDLO WHERE BYTESPERWORD))) (\PUTBASE WHERE 0 (\HINUM CELL)) (\PUTBASE WHERE 1 (\LONUM CELL]) (XIPAPPEND.STRING [LAMBDA (EPKT STRING OFFST IFSP) (* bvm%: " 4-FEB-83 12:00") (* ;; "Store STRING beginning at OFFST'th byte of XIP. OFFST defaults to end of packet, in which case the packet's XIPLENGTH accordingly. IFSP means to store the string in IFS format -- the length word preceeds the string bytes.") (OR (STRINGP STRING) (LITATOM STRING) (SETQ STRING (MKSTRING STRING))) (PROG ((LEN (NCHARS STRING)) WHERE) (SETQ WHERE (OR OFFST (IDIFFERENCE (fetch XIPLENGTH of EPKT) \XIPOVLEN))) [COND (IFSP (SETQ WHERE (CEIL WHERE BYTESPERWORD)) (COND ((ILESSP \MAX.XIPDATALENGTH (IPLUS WHERE LEN BYTESPERWORD)) (RETURN))) (\PUTBASE (fetch XIPCONTENTS of EPKT) (FOLDLO WHERE BYTESPERWORD) LEN) (add WHERE BYTESPERWORD) (add LEN BYTESPERWORD)) (T (COND ((ILESSP \MAX.XIPDATALENGTH (IPLUS WHERE LEN)) (RETURN] (COND ((NULL OFFST) (add (fetch XIPLENGTH of EPKT) LEN))) (RETURN (\PUTBASESTRING (fetch XIPCONTENTS of EPKT) WHERE STRING]) (XIPAPPEND.IFSSTRING [LAMBDA (XIP STRING OFFST) (* JonL "31-JUL-82 03:40") (* ;; "Store STRING as an IFS string (length word followed by string) beginning at OFFST'th byte of XIP. OFFST defaults to end of packet, in which case the packet's XIPLENGTH is updated accordingly") (XIPAPPEND.STRING XIP STRING OFFST T]) ) (* ; "XIP routing") (DEFINEQ (\NSGATELISTENER [LAMBDA NIL (* ; "Edited 15-Jan-88 03:00 by bvm") (PROG ((NSOC (OPENNSOCKET \NS.WKS.RoutingInformation T)) (TIMER (SETUPTIMER 0)) EVENT XIP BASE) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION \ROUTINGTABLE.INFOHOOK)) (* ;  "For info, print our routing table") (PROCESSPROP (THIS.PROCESS) :PROTOCOL 'NS) (SETQ EVENT (fetch NSOCEVENT of NSOC)) LP (COND ((SETQ XIP (GETXIP NSOC)) (\HANDLE.NS.ROUTING.INFO XIP) (BLOCK)) ((EQ (AWAIT.EVENT EVENT (COND ((> \NSROUTER.PROBECOUNT 0) \NSROUTER.PROBETIMER) (T TIMER)) T) EVENT) (GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE \NS.ROUTING.TABLE) (SETUPTIMER \RT.AGEINTERVAL TIMER))) [COND ((AND (> \NSROUTER.PROBECOUNT 0) (TIMEREXPIRED? \NSROUTER.PROBETIMER)) (* ;  "Routing info desired. Broadcast a routing request on each directly-connected net") [SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (+ \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD] (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (NSROUTINGINFO NET#) of BASE with -1) (replace (NSROUTINGINFO %#HOPS) of BASE with \RT.INFINITY) (SENDXIP NSOC XIP) (SETUPTIMER \NSROUTER.PROBEINTERVAL \NSROUTER.PROBETIMER) (SETQ \NSROUTER.PROBECOUNT (SUB1 \NSROUTER.PROBECOUNT] (GO LP]) (\HANDLE.NS.ROUTING.INFO [LAMBDA (XIP) (* ; "Edited 1-Oct-90 09:57 by jds") (* ; "Processes a routing info XIP") [COND ((EQ (fetch XIPFIRSTDATAWORD of XIP) \XROUTINGINFO.OP.RESPONSE) (* ;  "Unless we're a gateway, we only handle responses") (PROG ((HOSTBASE (LOCF (fetch XIPSOURCENET of XIP))) (NDB (fetch EPNETWORK of XIP)) (LENGTH (SUB1 (FOLDLO (- (fetch XIPLENGTH of XIP) \XIPOVLEN) BYTESPERWORD))) (BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (TABLE \NS.ROUTING.TABLE) (MASK \ROUTING.TABLE.MASK) (RADIUS \NS.ROUTING.TABLE.RADIUS) HOST ENTRY NET HOPS OLDHOPS RN BUCKET NEWTIMER) (COND ((NOT NDB) (* ;; "Not a %"real%" packet -- its NDB field never got filled in, somehow.") (RETURN)) ((EQ (fetch NETTYPE of NDB) 10) (* ; "Host is already in about the right form. Just canonicalize it to make the loop below faster and avoid consing") (SETQ HOST (\CANONICALIZE.NSADDRESS HOSTBASE))) ((SETQ HOST (\TRANSLATE.10TO3 HOSTBASE NDB))(* ;  "Host is in translation table => 3mb number") ) (T (* ; "Unknown (so far) gateway") (RETURN))) (SETQ \NSROUTER.PROBECOUNT 0) (* ;  "We got info from somewhere, so can stop probing") (while (>= LENGTH \NS.ROUTINGINFO.WORDS) do (SETQ HOPS (fetch (NSROUTINGINFO %#HOPS) of BASE)) (SETQ NET (fetch (NSROUTINGINFO NET#LO) of BASE)) (* ;; "Look up this net in the routing table. If we don't have an entry, and it's not a nearby net that we'd want to know about anyway, skip it.") (* ;; "TABLE is a naked array containing buckets of routing entries hashed by the low bits of the net number. Thus, we can often avoid dealing with non-smallp nets altogether if they happen to be uninteresting.") [COND ((OR [AND (SETQ BUCKET (\GETBASEPTR TABLE (UNFOLD (LOGAND NET MASK) WORDSPERCELL))) (COND [(EQ 0 (fetch (NSROUTINGINFO NET#HI) of BASE)) (* ;  "Easy case--specified net is smallp (NET) so can search with eq") (when (EQ (fetch RTNET# of (SETQ ENTRY (CAR BUCKET))) NET) do (RETURN T) repeatwhile (SETQ BUCKET (CDR BUCKET] (T (* ;  "Large net--compare by low and hi to avoid boxing") (when (AND (TYPENAMEP [SETQ RN (fetch RTNET# of (SETQ ENTRY (CAR BUCKET] 'FIXP) (EQ (fetch (FIXP LONUM) of RN) NET) (EQ (fetch (FIXP HINUM) of RN) (fetch (NSROUTINGINFO NET#HI) of BASE))) do (RETURN T) repeatwhile (SETQ BUCKET (CDR BUCKET] (COND ((<= HOPS RADIUS) [\ADD.ROUTING.TABLE.ENTRY TABLE (SETQ ENTRY (create ROUTING RTNET# _ (fetch (NSROUTINGINFO NET#) of BASE) RTTIMER _ (SETUPTIMER 0] T))) (* ;; "Have an entry for this net. Shall we accept the new info?") (COND ((EQ (SETQ OLDHOPS (fetch RTHOPCOUNT of ENTRY)) 0) (* ;  "Don't touch the directly connected net") ) ((COND ((AND (EQ NDB (fetch RTNDB of ENTRY)) (EQ HOST (fetch RTGATEWAY# of ENTRY))) (* ;;  "Same net and gateway, so we'll want to update the hop count") T) ((OR (NOT (fetch RTRECENT of ENTRY)) (< HOPS OLDHOPS)) (* ;; "Shorter route than we had, or the old route was getting out of date. Note we only smash these fields on this arm of the cond, since they're unchanged on the other arm. Smashing there would be slow, especially since NDB's tend to have overflowed ref counts. Also note OLDHOPS is NIL for brand new entry, which is why we check RECENT first.") (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) T)) (replace RTHOPCOUNT of ENTRY with HOPS) (COND ((< HOPS \RT.INFINITY) (* ;  "Hops at infinity means inaccessible, so don't encourage this entry to stick around.") (replace RTRECENT of ENTRY with T) (COND (NEWTIMER (* ;  "Save repeatedly calling the clock--everyone can get the same timer.") (\BLT (fetch RTTIMER of ENTRY) NEWTIMER WORDSPERCELL)) (T (SETQ NEWTIMER (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY] (SETQ LENGTH (- LENGTH \NS.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \NS.ROUTINGINFO.WORDS] (\RELEASE.ETHERPACKET XIP]) (\CANONICALIZE.NSADDRESS [LAMBDA (NSADDR) (* ; "Edited 15-Jan-88 01:54 by bvm") (* ;; "Takes an NSADDRESS or equivalent piece of storage and returns a unique NSADDRESS object for it. Uniqueness guaranteed until the next restart of NS.") (for (PREVTAIL _ \NSADDRESS.CACHE) TAIL HOST while (SETQ TAIL (CDR PREVTAIL)) do (SETQ HOST (CAR TAIL)) (if (EQNSADDRESS.HOST HOST NSADDR) then (* ; "got it. ") [if (NEQ PREVTAIL \NSADDRESS.CACHE) then (* ;  "Promote it to front to speed up next time") (RPLACD \NSADDRESS.CACHE (PROG1 TAIL (RPLACD PREVTAIL (CDR TAIL)) (RPLACD TAIL (CDR \NSADDRESS.CACHE)))] (RETURN HOST)) (SETQ PREVTAIL TAIL) finally (* ; "Make a new entry") (\BLT [LOCF (FETCH NSHNM0 OF (SETQ HOST (create NSADDRESS] (LOCF (FETCH NSHNM0 OF NSADDR)) 3) (push (CDR \NSADDRESS.CACHE) HOST) (RETURN HOST]) (\ROUTE.XIP [LAMBDA (XIP READONLY) (* ; "Edited 14-Jan-88 18:46 by bvm") (* ;; "Encapsulates XIP, choosing the right network and immediate destination host. Returns an NDB for the transmission. Unless READONLY is true, defaults source and destination nets if needed") (PROG ((NET (fetch XIPDESTNET of XIP)) PDH ROUTE NDB) (COND ((EQ 0 NET) (OR (SETQ NDB (OR \10MBLOCALNDB \3MBLOCALNDB)) (RETURN))) ((SETQ ROUTE (\LOCATE.NSNET NET)) (SETQ NDB (fetch RTNDB of ROUTE))) (T (RETURN))) [SETQ PDH (COND ((AND ROUTE (NEQ (fetch RTHOPCOUNT of ROUTE) 0)) (* ; "Go thru this gateway") (fetch RTGATEWAY# of ROUTE)) ((EQ (fetch NETTYPE of NDB) 10) (* ; "Logical dest is also physical") (LOCF (fetch XIPDESTNET of XIP))) ((EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER) (* ; "On 3, broadcast goes to zero") 0) ((\TRANSLATE.10TO3 (LOCF (fetch XIPDESTNET of XIP)) NDB)) (T (RETURN] (replace EPNETWORK of XIP with NDB) (ENCAPSULATE.ETHERPACKET NDB XIP PDH (fetch XIPLENGTH of XIP) \EPT.XIP) [COND ((NOT READONLY) [COND ((EQ 0 NET) (replace XIPDESTNET of XIP with (fetch NDBNSNET# of NDB] (replace XIPSOURCENET of XIP with (fetch NDBNSNET# of NDB] (RETURN NDB]) (\LOCATE.NSNET [LAMBDA (NET DONTPROBE) (* ; "Edited 15-Jan-88 00:23 by bvm") (LET [(BUCKET (\GETBASEPTR \NS.ROUTING.TABLE (UNFOLD (LOGAND NET \ROUTING.TABLE.MASK) WORDSPERCELL] (for DATA in BUCKET when [OR (= (fetch (ROUTING RTNET#) of DATA) NET) (AND (EQ 0 NET) (EQ 0 (fetch (ROUTING RTHOPCOUNT) of DATA] do (RETURN (AND (< (fetch RTHOPCOUNT of DATA) \RT.INFINITY) DATA)) finally (COND ((NOT DONTPROBE) (* ;  "Insert an entry for the net, to be purged in 30 sec if router process hasn't filled it by then") (\RPLPTR \NS.ROUTING.TABLE (UNFOLD (LOGAND NET \ROUTING.TABLE.MASK) WORDSPERCELL) (CONS (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY RTTIMER _ (SETUPTIMER 30000)) BUCKET)) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ \NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (WAKE.PROCESS '\NSGATELISTENER) (BLOCK]) (NSNET.DISTANCE [LAMBDA (NET#) (* bvm%: "29-Jul-84 22:52") [COND ((type? NSADDRESS NET#) (SETQ NET# (fetch NSNET of NET#] (PROG ((ROUTE (\LOCATE.NSNET NET#))) [COND ((NULL ROUTE) (to 4 do (BLOCK \ETHERTIMEOUT) repeatuntil (SETQ ROUTE (\LOCATE.NSNET NET#] (RETURN (COND (ROUTE (fetch RTHOPCOUNT of ROUTE]) (BESTNSADDRESS [LAMBDA (ADDRESSES ERRORSTREAM HOSTNAME) (* bvm%: "29-Jul-84 23:03") (* ;; "Returns an NSADDRESS from the list ADDRESSES that is closest, returning NIL if there is no route. If ERRORSTREAM = ERROR, causes error on failure; otherwise ERRORSTREAM is a stream to print an appropriate error message to before returning NIL. HOSTNAME is optional interesting name of the host being sought") (PROG (MSG) RETRY (COND (ADDRESSES) ((SETQ ADDRESSES (LOOKUP.NS.SERVER HOSTNAME NIL T)) (SETQ HOSTNAME (CAR ADDRESSES)) (SETQ ADDRESSES (CDR ADDRESSES))) (ERRORSTREAM (SETQ MSG "Host not found") (GO ERROR)) (T (RETURN))) [RETURN (for TRY from 1 to 5 bind NOTLOOKEDUP HOPS BESTHOPS BESTADDR ROUTE do (SETQ BESTHOPS \RT.INFINITY) (SETQ NOTLOOKEDUP (SETQ BESTADDR NIL)) [for ADDR in ADDRESSES do (COND ((OR [NOT (SETQ ROUTE (\LOCATE.NSNET (fetch NSNET of ADDR] (IGEQ (SETQ HOPS (fetch RTHOPCOUNT of ROUTE)) \RT.INFINITY)) (SETQ NOTLOOKEDUP T)) ((ILESSP HOPS BESTHOPS) (SETQ BESTHOPS HOPS) (SETQ BESTADDR ADDR] (* ;  "Enter request for routing for all hosts") (COND ((AND BESTADDR (OR (NOT NOTLOOKEDUP) (ILEQ BESTHOPS \NS.ROUTING.TABLE.RADIUS) (IGREATERP TRY 1))) (RETURN BESTADDR))) (BLOCK \ETHERTIMEOUT) finally (COND (ERRORSTREAM (SETQ MSG "No route to host") (GO ERROR] ERROR [OR HOSTNAME (AND ADDRESSES (SETQ HOSTNAME (fetch NSNET of (CAR ADDRESSES] (COND ((EQ ERRORSTREAM 'ERROR) (ERROR MSG HOSTNAME) (GO RETRY)) (T (printout ERRORSTREAM T MSG ": " HOSTNAME) (RETURN]) (SORT.NSADDRESSES.BY.DISTANCE [LAMBDA (HOSTLIST) (* bvm%: "22-Jun-84 18:35") (COND ((NULL (CDR (LISTP HOSTLIST))) HOSTLIST) (T (* ;  "HOSTLIST is a list each of whose elements has a NSADDRESS in its CAR and anything in its CDR.") [for PAIR in HOSTLIST do (\LOCATE.NSNET (fetch (NSADDRESS NSNET) of (CAR PAIR] (* ;  "Enter request for routing for all hosts") (BLOCK) (COND ((NOT (for PAIR in HOSTLIST always (\LOCATE.NSNET (fetch (NSADDRESS NSNET) of (CAR PAIR)) T))) (BLOCK \ETHERTIMEOUT))) (SORT HOSTLIST (FUNCTION \NSNET.CLOSERP]) (\NSNET.CLOSERP [LAMBDA (X Y) (* bvm%: "22-Jun-84 18:17") (PROG ((ROUTEX (\LOCATE.NSNET (fetch (NSADDRESS NSNET) of (CAR X)) T)) ROUTEY) (RETURN (COND ((NULL ROUTEX) NIL) ((SETQ ROUTEY (\LOCATE.NSNET (fetch (NSADDRESS NSNET) of (CAR Y)) T)) (ILESSP (fetch RTHOPCOUNT of ROUTEX) (fetch RTHOPCOUNT of ROUTEY))) (T T]) ) (RPAQ? \NS.ROUTING.TABLE NIL) (RPAQ? \NS.ROUTING.TABLE.RADIUS 4) (RPAQ? \NSROUTER.PROBECOUNT 0) (RPAQ? \NSROUTER.PROBETIMER NIL) (RPAQ? \NSROUTER.PROBEINTERVAL 3000) (RPAQ? \NS.READY NIL) (RPAQ? \NS.READY.EVENT (CREATE.EVENT "NS Ready")) (RPAQ? \NSADDRESS.CACHE NIL) (ADDTOVAR \SYSTEMCACHEVARS \NS.READY) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD NSROUTINGINFO ( (* ;  "Format of each entry in a routing info packet") (NET# FIXP) (%#HOPS WORD)) (BLOCKRECORD NSROUTINGINFO ((NET#HI WORD) (NET#LO WORD)))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NS.ROUTINGINFO.WORDS 3) (RPAQQ \XROUTINGINFO.OP.REQUEST 1) (RPAQQ \XROUTINGINFO.OP.RESPONSE 2) (CONSTANTS \NS.ROUTINGINFO.WORDS \XROUTINGINFO.OP.REQUEST \XROUTINGINFO.OP.RESPONSE) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NS.ROUTING.TABLE \NS.ROUTING.TABLE.RADIUS \NSROUTER.PROBECOUNT \NSROUTER.PROBETIMER \NSROUTER.PROBEINTERVAL \NS.READY \NS.READY.EVENT \NSADDRESS.CACHE) ) ) (* ; "Analogous to PUP stuff for tracing activity.") (DEFINEQ (XIPTRACE [LAMBDA (FLG REGION) (* ; "Edited 14-Jan-88 18:06 by bvm") (MAKE-NETWORK-TRACE-WINDOW 'XIPTRACEFLG 'XIPTRACEFILE "Xerox Internet Packet Traffic" REGION FLG]) ) (DEFINEQ (PRINTXIP [LAMBDA (XIP CALLER FILE PRE.NOTE DOFILTER) (* bvm%: "13-FEB-83 16:10") (OR FILE (SETQ FILE XIPTRACEFILE)) (PROG ((TYPE (fetch XIPTYPE of XIP)) MACRO LENGTH) [COND (DOFILTER (COND ((COND (XIPONLYTYPES (NOT (FMEMB TYPE XIPONLYTYPES))) (XIPIGNORETYPES (FMEMB TYPE XIPIGNORETYPES))) (RETURN (PRIN1 (SELECTQ CALLER ((PUT RAWPUT) '!) ((GET RAWGET) '+) '?) FILE] (AND PRE.NOTE (printout FILE T PRE.NOTE)) (PRINTXIPROUTE XIP CALLER FILE) [COND ((SETQ MACRO (CDR (FASSOC TYPE XIPPRINTMACROS)))(* ;  "Macro is a function to which to dispatch for the printing.") (AND (NLISTP MACRO) (RETURN (RESETFORM (OUTPUT FILE) (APPLY* MACRO XIP FILE] (printout FILE "Length = " .P2 (SETQ LENGTH (fetch XIPLENGTH of XIP)) " bytes" " (header + " .P2 (IDIFFERENCE LENGTH \XIPOVLEN) ")" T "Type = ") (PRINTCONSTANT TYPE XIPTYPES FILE) (TERPRI FILE) (COND ((IGREATERP LENGTH \XIPOVLEN) (* ; "MACRO tells how to print data.") (PRIN1 "Contents: " FILE) (PRINTXIPDATA XIP (OR MACRO '(BYTES 12 |...|)) NIL FILE))) (TERPRI FILE) (RETURN XIP]) (PRINTERRORXIP [LAMBDA (XIP FILE) (* bvm%: "15-Feb-85 01:42") (SETQ XIP (\DTEST XIP 'ETHERPACKET)) (PROG ((ERRCODE (fetch ERRORXIPCODE of XIP)) (ERRARG (fetch ERRORXIPARG of XIP))) [printout FILE "[Error] " (OR (CADR (ASSOC ERRCODE XIPERRORMESSAGES)) (CONCAT '%# (OCTALSTRING ERRCODE] (COND ((NEQ ERRARG 0) (printout FILE ", Parameter " .P2 ERRARG))) (TERPRI FILE]) (PRINTXIPROUTE [LAMBDA (PACKET CALLER FILE) (* bvm%: "15-Feb-85 01:42") (FRESHLINE FILE) (AND CALLER (printout FILE CALLER ": ")) (PROG ((CONTROL (fetch XIPTCONTROL of PACKET)) CSECS) (printout FILE "From " (\PRINTNSADDRESS (LOCF (fetch (XIP XIPSOURCENET) of PACKET)) FILE) " to " (\PRINTNSADDRESS (LOCF (fetch (XIP XIPDESTNET) of PACKET)) FILE)) (COND ((NEQ CONTROL 0) (printout FILE ", Hops = " .P2 CONTROL))) (COND (XIPTRACETIME (printout FILE " [" .I4 (IQUOTIENT (SETQ CSECS (\CENTICLOCK PACKET)) 100) '%. .I2..T (IREMAINDER CSECS 100) "]"))) (TERPRI FILE]) (PRINTXIPDATA [LAMBDA (XIP MACRO OFFSET FILE) (* ; "Edited 13-Jan-88 15:17 by bvm") (* ;;; "Prints DATA part of XIP starting at OFFSET (Default zero) according to MACRO. MACRO contains elements describing what format the data is in (see PRINTPACKETDATA)") (PRINTPACKETDATA (fetch XIPCONTENTS of XIP) OFFSET MACRO (- (fetch XIPLENGTH of XIP) \XIPOVLEN) FILE]) ) (RPAQ? XIPTRACEFLG ) (RPAQ? XIPTRACEFILE T) (RPAQ? XIPTRACETIME ) (ADDTOVAR XIPONLYTYPES ) (ADDTOVAR XIPIGNORETYPES ) (ADDTOVAR XIPPRINTMACROS (1 "Operation = " WORDS 2 "Info: " |...|) (2 "Operation: " WORDS 2 "Data: " CHARS 100 |...|) (3 . PRINTERRORXIP) (4 "ID = " INTEGER 4 "Type = " WORDS 6 BYTES 8)) (PUTPROPS XIPPRINTMACROS VARTYPE ALIST) (ADDTOVAR \PACKET.PRINTERS (1536 . PRINTXIP)) (DECLARE%: DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS XIPTRACEFLG XIPTRACEFILE XIPIGNORETYPES XIPONLYTYPES XIPTRACETIME XIPPRINTMACROS) ) ) (* ; "Peeking") (DEFINEQ (\PEEKNS [LAMBDA (HOST FILE) (* ; "Edited 13-Jan-88 15:18 by bvm") (PROG NIL [COND ((NULL HOST) (\PROMISCUOUS.OFF) (RPTQ 20 (BLOCK)) (* ; "empty the pipe") (SETQ \PEEKNSNUMBER)) (T (COND ((EQ HOST T) (SETQ \PEEKNSNUMBER T)) ((SETQ HOST (COERCE-TO-NSADDRESS HOST)) (SETQ \PEEKNSNUMBER (fetch NSHOSTNUMBER of HOST))) (T (RETURN NIL))) (* ; "Now make us promiscuous") (\PROMISCUOUS.ON) [COND (FILE (SETQ XIPTRACEFILE (OR (OPENP FILE 'OUTPUT) (OPENFILE FILE 'OUTPUT] (OR XIPTRACEFLG (SETQ XIPTRACEFLG T] (RETURN \PEEKNSNUMBER]) (\MAYBEPEEKNS [LAMBDA (XIP) (* bvm%: "12-OCT-83 16:25") [COND ((AND \PEEKNSNUMBER XIPTRACEFLG) (PROG (DIRECTION) (COND ([OR (EQ \PEEKNSNUMBER T) (AND (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER) (NEQ \PEEKNSNUMBER 0)) [COND ((EQNSHOSTNUMBER (fetch XIPSOURCEHOST of XIP) \PEEKNSNUMBER) (SETQ DIRECTION 'PUT] (COND ((EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) \PEEKNSNUMBER) (SETQ DIRECTION 'GET] (PRINTXIP XIP DIRECTION XIPTRACEFILE NIL T] (\RELEASE.ETHERPACKET XIP]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PEEKNSNUMBER) ) (RPAQ? \PEEKNSNUMBER ) (DEFINEQ (\PROMISCUOUS.ON [LAMBDA NIL (* bvm%: "12-OCT-83 15:58") (SELECTQ (fetch NETTYPE of \LOCALNDBS) (3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC) 0 0)) (10 (\10MB.STARTDRIVER \LOCALNDBS T BROADCASTNSHOSTNUMBER)) NIL]) (\PROMISCUOUS.OFF [LAMBDA NIL (* bvm%: "12-OCT-83 15:58") (SELECTQ (fetch NETTYPE of \LOCALNDBS) (3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC) 0 (fetch NDBPUPHOST# of \LOCALNDBS))) (10 (\10MB.STARTDRIVER \LOCALNDBS T T)) NIL]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \ETHERHOSTLOC 392) (CONSTANTS \ETHERHOSTLOC) ) ) (* ; "Simple packet exchange protocols") (DEFINEQ (\GETMISCNSOCKET [LAMBDA NIL (* bvm%: "24-FEB-83 17:51") (* ;; "Opens a socket for miscellaneous services, if we don't have it open yet") (COND ((AND \MISC.NSOCKET (FMEMB \MISC.NSOCKET \NSOCKETS)) \MISC.NSOCKET) (T (SETQ \MISC.NSOCKET (OPENNSOCKET]) (CREATE.PACKET.EXCHANGE.XIP [LAMBDA (NSOCKET DESTHOST DESTSOCKET TYPE) (* bvm%: "15-Jun-84 12:54") (PROG [(XIP (\FILLINXIP \XIPT.EXCHANGE NSOCKET DESTHOST DESTSOCKET 0 (IPLUS \XIPOVLEN (UNFOLD 3 BYTESPERWORD ] (replace (PACKETEXCHANGEXIP PACKETEXCHANGETYPE) of XIP with TYPE) (replace (PACKETEXCHANGEXIP PACKETEXCHANGEID0) of XIP with 0) [replace (PACKETEXCHANGEXIP PACKETEXCHANGEID1) of XIP with (SETQ \PACKET.EXCHANGE.CNTR (\LOLOC (\ADDBASE \PACKET.EXCHANGE.CNTR 1] (RETURN XIP]) (EXCHANGEXIPS [LAMBDA (SOC OUTXIP IDFILTER TIMEOUT) (* bvm%: "12-Jun-84 15:15") (* ;; "Sends out OUTXIP on SOC and waits for a reply, which it puts in INXIP. If IDFILTER is true, only replies with the same ID are accepted. Returns input pup on success, or NIL on failure. TIMEOUT overrides the default timeout.") (OR TIMEOUT (SETQ TIMEOUT \ETHERTIMEOUT)) (DISCARDXIPS SOC) (* ;  "Flush any pups waiting on this socket") (SENDXIP SOC OUTXIP) (bind INXIP (TIMER _ (SETUPTIMER TIMEOUT)) until (TIMEREXPIRED? TIMER) do (\BACKGROUND) (COND ([AND (SETQ INXIP (GETXIP SOC)) (OR (NOT IDFILTER) (IEQP (fetch PACKETEXCHANGEID of INXIP) (fetch PACKETEXCHANGEID of OUTXIP] (RETURN INXIP]) (RELEASE.XIP [LAMBDA (XIP) (* bvm%: "24-FEB-83 18:08") (\RELEASE.ETHERPACKET XIP]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (AND (CCODEP '\ALLOCATE.ETHERPACKET) (MOVD '\ALLOCATE.ETHERPACKET 'ALLOCATE.XIP NIL T)) (AND (CCODEP '\RELEASE.ETHERPACKET) (MOVD '\RELEASE.ETHERPACKET 'RELEASE.XIP NIL T)) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS PACKETEXCHANGEXIP ((PEXBASE (fetch (XIP XIPCONTENTS) of DATUM))) (BLOCKRECORD PEXBASE ((PACKETEXCHANGEID FIXP) (* ;  "Arbitrary id in packet exchange XIP") (PACKETEXCHANGETYPE WORD) (* ; "Protocol-specific type") (PACKETEXCHANGEBODY0 WORD) (* ; "Body starts here") )) (BLOCKRECORD PEXBASE ((PACKETEXCHANGEID0 WORD) (PACKETEXCHANGEID1 WORD))) [ACCESSFNS PACKETEXCHANGEXIP ((PACKETEXCHANGEBODY (LOCF (fetch PACKETEXCHANGEBODY0 of DATUM]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \EXTYPE.REQUEST 1) (RPAQQ \EXTYPE.RESPONSE 2) (RPAQQ \EXTYPE.NEGATIVE 3) (CONSTANTS (\EXTYPE.REQUEST 1) (\EXTYPE.RESPONSE 2) (\EXTYPE.NEGATIVE 3)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \MISC.NSOCKET \PACKET.EXCHANGE.CNTR) ) (RPAQ? \MISC.NSOCKET ) (RPAQ? \PACKET.EXCHANGE.CNTR 0) (DEFINEQ (\LOOKUPPUPNUMBER [LAMBDA (NSNUMBER) (* ejs%: "29-Dec-85 15:13") (* ;;; "Looks up the pup host number for NSNUMBER. These numbers are in gateway's database") (PROG ((SOC (\GETMISCNSOCKET)) OXIP RESULT) (SETQ OXIP (CREATE.PACKET.EXCHANGE.XIP SOC BROADCASTNSHOSTNUMBER \NS.WKS.PUPLOOKUP \EXTYPE.REQUEST)) (replace XIPTYPE of OXIP with \XIPT.PUPLOOKUP) (add (fetch XIPLENGTH of OXIP) (UNFOLD \#WDS.NSHOSTNUMBER BYTESPERWORD)) (\STORENSHOSTNUMBER (fetch PACKETEXCHANGEBODY of OXIP) NSNUMBER) (DISCARDXIPS SOC) (to \MAXETHERTRIES bind INXIP TIMER do (SENDXIP SOC OXIP) (SETQ TIMER (SETUPTIMER \ETHERTIMEOUT TIMER)) repeatuntil (do (BLOCK) (COND [(NULL (SETQ INXIP (GETXIP SOC] ((IEQP (fetch PACKETEXCHANGEID of INXIP) (fetch PACKETEXCHANGEID of OXIP)) (SELECTC (fetch PACKETEXCHANGETYPE of INXIP) (\EXTYPE.RESPONSE (RETURN (PROGN (SETQ RESULT (fetch PACKETEXCHANGEBODY0 of INXIP)) (COND ((AND (EQ 0 (LOGAND RESULT 255)) (NOT (EQUAL NSNUMBER BROADCASTNSHOSTNUMBER)) ) (COND (XIPTRACEFLG (printout XIPTRACEFILE "Impossible NS to Pup translation: " RESULT T))) (SETQ RESULT NIL))) (RELEASE.XIP INXIP) RESULT))) (\EXTYPE.NEGATIVE (COND (XIPTRACEFLG (printout XIPTRACEFILE [\GETBASESTRING (fetch PACKETEXCHANGEBODY of INXIP) 0 (IDIFFERENCE (fetch XIPLENGTH of INXIP) (IPLUS \XIPOVLEN (UNFOLD 3 BYTESPERWORD] T))) (* ;  "For now, ignore negative responses. some gateways are confused") ) NIL) (RELEASE.XIP INXIP)) (T (RELEASE.XIP INXIP))) repeatuntil (TIMEREXPIRED? TIMER))) [COND (XIPTRACEFLG (COND ((NULL RESULT) (printout XIPTRACEFILE "NS to Pup number lookup failed" T)) (T (printout XIPTRACEFILE "Local pup net/host set to " (PORTSTRING RESULT) T] (RELEASE.XIP OXIP) (RETURN RESULT]) ) (* ; "Time service") (DEFINEQ (NSNETDAYTIME0 [LAMBDA NIL (* bvm%: "15-Jun-84 12:41") (* ;;; "Returns a 32-bit unsigned alto time from the network, if possible") (PROG ((SOC (\GETMISCNSOCKET)) OXIP RESULT IXIP) (SETQ OXIP (CREATE.PACKET.EXCHANGE.XIP SOC BROADCASTNSHOSTNUMBER \TIMESOCKET \EXTYPE.TIME)) (replace TIMEOP of OXIP with \TIMEOP.TIMEREQUEST) (replace TIMEVERSION of OXIP with \TIMEVERSION) (add (fetch XIPLENGTH of OXIP) (UNFOLD 2 BYTESPERWORD)) (RETURN (to \MAXETHERTRIES when (SETQ IXIP (EXCHANGEXIPS SOC OXIP T)) do (SELECTC (fetch TIMEOP of IXIP) (\TIMEOP.TIMERESPONSE (RETURN (fetch TIMEVALUE of IXIP))) NIL]) (\NS.SETTIME [LAMBDA (RETFLG) (* bvm%: "15-Feb-85 01:42") (* ;;; "Sets the time from an NS time server if possible. Returns T on success") (PROG ((SOC (\GETMISCNSOCKET)) OXIP RESULT IXIP TIME) (SETQ OXIP (CREATE.PACKET.EXCHANGE.XIP SOC BROADCASTNSHOSTNUMBER \TIMESOCKET \EXTYPE.TIME)) (replace TIMEOP of OXIP with \TIMEOP.TIMEREQUEST) (replace TIMEVERSION of OXIP with \TIMEVERSION) (add (fetch XIPLENGTH of OXIP) (UNFOLD 2 BYTESPERWORD)) (RETURN (to \MAXETHERTRIES when (SETQ IXIP (EXCHANGEXIPS SOC OXIP T)) do (SELECTC (fetch (TIMEXIP TIMEOP) of IXIP) (\TIMEOP.TIMERESPONSE (SETQ TIME (create FIXP HINUM _ (fetch TIMEVALUEHI of IXIP) LONUM _ (fetch TIMEVALUELO of IXIP))) (COND (RETFLG (RETURN TIME))) (SETQ \TimeZoneComp (ITIMES (COND ((EQ (fetch TIMEZONESIGN of IXIP) 0) 1) (T -1)) (fetch TIMEZONEHOURS of IXIP))) (SETQ \BeginDST (fetch TIMEBEGINDST of IXIP)) (SETQ \EndDST (fetch TIMEENDDST of IXIP)) (\SETNEWTIME0 TIME) (RETURN T)) NIL]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS TIMEXIP ((TIMEBODY (fetch (PACKETEXCHANGEXIP PACKETEXCHANGEBODY) of DATUM))) [BLOCKRECORD TIMEBODY ((TIMEVERSION WORD) (* ; "Protocol version") (TIMEOP WORD) (* ; "What kind of request/response") (TIMEVALUE FIXP) (TIMEZONESIGN WORD) (* ;  "0 = west of prime meridian, 1 = east") (TIMEZONEHOURS WORD) (* ; "Hours from prime meridian") (TIMEZONEMINUTES WORD) (* ; "Minutes ...") (TIMEBEGINDST WORD) (* ; "Day of year when DST starts") (TIMEENDDST WORD) (* ; "Day of year when DST stops") ) (BLOCKRECORD TIMEBODY ((NIL 2 WORD) (TIMEVALUEHI WORD) (TIMEVALUELO WORD]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \TIMESOCKET 8) (RPAQQ \TIMEOP.TIMEREQUEST 1) (RPAQQ \TIMEOP.TIMERESPONSE 2) (RPAQQ \TIMEVERSION 2) (RPAQQ \EXTYPE.TIME 1) (CONSTANTS \TIMESOCKET \TIMEOP.TIMEREQUEST \TIMEOP.TIMERESPONSE \TIMEVERSION \EXTYPE.TIME) ) ) (* ; "Debugging") (DEFINEQ (NS.ECHOUSER [LAMBDA (ECHOHOST ECHOSTREAM INTERVAL NTIMES) (* ; "Edited 13-Jan-88 15:26 by bvm") (RESETLST [PROG ((TIMER (SETUPTIMER 0)) (ECHOADDRESS (OR (COERCE-TO-NSADDRESS ECHOHOST \NS.WKS.Echo) (\ILLEGAL.ARG ECHOHOST))) NSOC OXIP IXIP EVENT I XIPBASE ECHOXIPLENGTH OXIPBASE) [RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ NSOC (OPENNSOCKET] (SETQ OXIP (\FILLINXIP \XIPT.ECHO NSOC ECHOADDRESS)) (\PUTBASE (SETQ OXIPBASE (fetch XIPCONTENTS of OXIP)) 0 \XECHO.OP.REQUEST) (\PUTBASE OXIPBASE 1 (SETQ I 1)) [replace XIPLENGTH of OXIP with (SETQ ECHOXIPLENGTH (+ \XIPOVLEN (TIMES 2 BYTESPERWORD] (OR INTERVAL (SETQ INTERVAL 1000)) (OR NTIMES (SETQ NTIMES 1000)) (printout ECHOSTREAM "Echoing to " ECHOADDRESS T) (SETQ ECHOSTREAM (GETSTREAM (OR ECHOSTREAM T) 'OUTPUT)) (SETQ EVENT (fetch NSOCEVENT of NSOC)) LP (SENDXIP NSOC OXIP) (PRIN1 '! ECHOSTREAM) (SETUPTIMER INTERVAL TIMER) (do (COND [(SETQ IXIP (GETXIP NSOC)) (COND ((PROG1 (SELECTC (fetch XIPTYPE of IXIP) (\XIPT.ECHO (COND ((OR (NEQ (fetch XIPLENGTH of IXIP) ECHOXIPLENGTH) (NEQ (\GETBASE (SETQ XIPBASE (fetch XIPCONTENTS of IXIP)) 0) \XECHO.OP.REPLY)) (PRIN1 '? ECHOSTREAM) NIL) ((= (\GETBASE XIPBASE 1) I) (PRIN1 '+ ECHOSTREAM)) (T (PRIN1 "(late)" ECHOSTREAM) NIL))) (\XIPT.ERROR (PRINTERRORXIP IXIP ECHOSTREAM) NIL) (PROGN (PRIN1 '? ECHOSTREAM) NIL)) (RELEASE.XIP IXIP)) (RETURN] (T (AWAIT.EVENT EVENT TIMER T))) repeatuntil (TIMEREXPIRED? TIMER) finally (COND ((fetch EPTRANSMITTING of OXIP) (PRIN1 "[not yet transmitted; maybe transmitter is off]" ECHOSTREAM) )) (PRIN1 '%. ECHOSTREAM)) (COND ((> (OR (EQ NTIMES T) (add NTIMES -1)) 0) (\PUTBASE OXIPBASE 1 (add I 1)) (GO LP])]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \XECHO.OP.REQUEST 1) (RPAQQ \XECHO.OP.REPLY 2) (CONSTANTS \XECHO.OP.REQUEST \XECHO.OP.REPLY) ) ) (RPAQ? \DEFAULTECHOSERVER NIL) (RPAQ? \NS.ECHOUSERSOCKET NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (\NSINIT) ) (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) LLETHER) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS LLNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8986 17681 (PARSE-NSADDRESS 8996 . 16382) (COERCE-TO-NSADDRESS 16384 . 17102) ( \COERCE.NS.SOCKET 17104 . 17679)) (19348 23220 (OPENNSOCKET 19358 . 21504) (CLOSENSOCKET 21506 . 22472 ) (NSOCKETEVENT 22474 . 22641) (NSOCKETNUMBER 22643 . 22815) (NSOCKETFROMNUMBER 22817 . 22959) ( \FLUSHNSOCQUEUE 22961 . 23218)) (23322 25464 (\NSINIT 23332 . 25167) (STOPNS 25169 . 25462)) (25465 35564 (\HANDLE.RAW.XIP 25475 . 33528) (\XIPERROR 33530 . 35098) (\FORWARD.XIP 35100 . 35562)) (35663 40442 (GETXIP 35673 . 37005) (DISCARDXIPS 37007 . 37281) (SENDXIP 37283 . 38553) (SWAPXIPADDRESSES 38555 . 39253) (\SETXIPCHECKSUM 39255 . 40104) (\CLEARXIPHEADER 40106 . 40440)) (40443 48106 ( \FILLINXIP 40453 . 43327) (XIPAPPEND.BYTE 43329 . 44054) (XIPAPPEND.WORD 44056 . 45104) ( XIPAPPEND.CELL 45106 . 46281) (XIPAPPEND.STRING 46283 . 47728) (XIPAPPEND.IFSSTRING 47730 . 48104)) ( 48135 69557 (\NSGATELISTENER 48145 . 50501) (\HANDLE.NS.ROUTING.INFO 50503 . 58743) ( \CANONICALIZE.NSADDRESS 58745 . 60462) (\ROUTE.XIP 60464 . 62447) (\LOCATE.NSNET 62449 . 64225) ( NSNET.DISTANCE 64227 . 64798) (BESTNSADDRESS 64800 . 67644) (SORT.NSADDRESSES.BY.DISTANCE 67646 . 68857) (\NSNET.CLOSERP 68859 . 69555)) (70880 71111 (XIPTRACE 70890 . 71109)) (71112 74945 (PRINTXIP 71122 . 72966) (PRINTERRORXIP 72968 . 73515) (PRINTXIPROUTE 73517 . 74470) (PRINTXIPDATA 74472 . 74943 )) (75643 77550 (\PEEKNS 75653 . 76610) (\MAYBEPEEKNS 76612 . 77548)) (77644 78331 (\PROMISCUOUS.ON 77654 . 77971) (\PROMISCUOUS.OFF 77973 . 78329)) (78503 80888 (\GETMISCNSOCKET 78513 . 78859) ( CREATE.PACKET.EXCHANGE.XIP 78861 . 79730) (EXCHANGEXIPS 79732 . 80743) (RELEASE.XIP 80745 . 80886)) ( 82681 86769 (\LOOKUPPUPNUMBER 82691 . 86767)) (86799 90015 (NSNETDAYTIME0 86809 . 87776) (\NS.SETTIME 87778 . 90013)) (91938 95739 (NS.ECHOUSER 91948 . 95737))))) STOP \ No newline at end of file diff --git a/sources/LLNSDECLS b/sources/LLNSDECLS new file mode 100644 index 00000000..77f391e9 --- /dev/null +++ b/sources/LLNSDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 10:53:19" {DSK}lde>lispcore>sources>LLNSDECLS.;2 13142 changes to%: (RECORDS NSADDRESS NSOCKET XIP ERRORXIP NSHOSTNUMBER) previous date%: "17-Dec-92 12:59:22" {DSK}lde>lispcore>sources>LLNSDECLS.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLNSDECLSCOMS) (RPAQQ LLNSDECLSCOMS [(COMS (* ;  "XIP layout (Xerox Internet Packet)") (RECORDS XIP) (CONSTANTS \XIPOVLEN \MAX.XIPDATALENGTH) (CONSTANTS * RAWXIPTYPES)) (COMS (* ; "NSOCKET datatype") (RECORDS NSOCKET) (* ; "Well-known NS sockets") (CONSTANTS (\NS.WKS.RoutingInformation 1) (\NS.WKS.Echo 2) (\NS.WKS.PUPLOOKUP 9))) (COMS (* ; "ERRORXIP -- overlays XIP") (RECORDS ERRORXIP) (CONSTANTS * XIPERRORCODES)) (COMS (* ; "NSADDRESS") (RECORDS NSADDRESS NSHOSTNUMBER) (MACROS LOADNSHOSTNUMBER STORENSHOSTNUMBER \MOVENSADDRESSES \SWAPNSADDRESSES) (CONSTANTS (\#WDS.NSADDRESS 6) (\#WDS.NSHOSTNUMBER 3)) (MACROS \LOCALNSHOSTNUMBER \LOCALNSNETNUMBER \LOCALNSADDRESS \BLTLOCALHOSTNUMBER) (GLOBALVARS BROADCASTNSHOSTNUMBER \MY.NSADDRESS \MY.NSHOSTNUMBER \MY.NSNETNUMBER) (MACROS EQNSHOSTNUMBER EQNSADDRESS.HOST EQBROADCASTBASE EQNSHOSTBASE) (FNS TRANSLATE.NSH) (ADDVARS (DONTCOMPILEFNS TRANSLATE.NSH]) (* ; "XIP layout (Xerox Internet Packet)") (DECLARE%: EVAL@COMPILE (ACCESSFNS XIP [(XIPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM] [BLOCKRECORD XIPBASE ((XIPCHECKSUM WORD) (XIPLENGTH WORD) (XIPTCONTROL BYTE) (XIPTYPE BYTE) (XIPDESTNET FIXP) (XIPDESTWORD1 3 WORD) (XIPDESTSOCKET WORD) (XIPSOURCENET FIXP) (XIPSOURCEWORD1 3 WORD) (XIPSOURCESOCKET WORD) (XIPFIRSTDATAWORD WORD) (* ; "Start of data") ) [ACCESSFNS XIPLENGTH ((XIPCHECKSUMBASE (LOCF DATUM] [ACCESSFNS XIPFIRSTDATAWORD ((XIPCONTENTS (LOCF DATUM] [ACCESSFNS XIPSOURCEWORD1 ((XIPSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] [ACCESSFNS XIPDESTWORD1 ((XIPDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM)) (\STORENSHOSTNUMBER (LOCF DATUM) NEWVALUE] [ACCESSFNS XIPSOURCENET ((XIPSOURCENSADDRESS (\LOADNSADDRESS (LOCF DATUM)) (\STORENSADDRESS (LOCF DATUM) NEWVALUE] (ACCESSFNS XIPDESTNET ((XIPDESTNSADDRESS (\LOADNSADDRESS (LOCF DATUM)) (\STORENSADDRESS (LOCF DATUM) NEWVALUE] (TYPE? (type? ETHERPACKET DATUM))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \XIPOVLEN 30) (RPAQQ \MAX.XIPDATALENGTH 546) (CONSTANTS \XIPOVLEN \MAX.XIPDATALENGTH) ) (RPAQQ RAWXIPTYPES ((\XIPT.ROUTINGINFO 1) (\XIPT.ECHO 2) (\XIPT.ERROR 3) (\XIPT.EXCHANGE 4) (\XIPT.SPP 5) (\XIPT.PUPLOOKUP 6))) (DECLARE%: EVAL@COMPILE (RPAQQ \XIPT.ROUTINGINFO 1) (RPAQQ \XIPT.ECHO 2) (RPAQQ \XIPT.ERROR 3) (RPAQQ \XIPT.EXCHANGE 4) (RPAQQ \XIPT.SPP 5) (RPAQQ \XIPT.PUPLOOKUP 6) (CONSTANTS (\XIPT.ROUTINGINFO 1) (\XIPT.ECHO 2) (\XIPT.ERROR 3) (\XIPT.EXCHANGE 4) (\XIPT.SPP 5) (\XIPT.PUPLOOKUP 6)) ) (* ; "NSOCKET datatype") (DECLARE%: EVAL@COMPILE (DATATYPE NSOCKET ((NIL BITS 4) (NSOCLINK POINTER) (* ; "So that we can Queue them") (ID# WORD) (NSOCHANDLE WORD) (NSOC#OPENP FLAG) (NSOC#CONNECTIONP FLAG) (NIL BITS 2) (INQUEUE POINTER) (INQUEUELENGTH WORD) (NSOC#ALLOCATION WORD) (NSOCEVENT POINTER)) INQUEUE _ (create SYSQUEUE) NSOC#ALLOCATION _ \MAX.EPKTS.ON.NSOCKET) ) (/DECLAREDATATYPE 'NSOCKET '((BITS 4) POINTER WORD WORD FLAG FLAG (BITS 2) POINTER WORD WORD POINTER) '((NSOCKET 0 (BITS . 3)) (NSOCKET 0 POINTER) (NSOCKET 2 (BITS . 15)) (NSOCKET 3 (BITS . 15)) (NSOCKET 4 (FLAGBITS . 0)) (NSOCKET 4 (FLAGBITS . 16)) (NSOCKET 4 (BITS . 33)) (NSOCKET 4 POINTER) (NSOCKET 6 (BITS . 15)) (NSOCKET 7 (BITS . 15)) (NSOCKET 8 POINTER)) '10) (* ; "Well-known NS sockets") (DECLARE%: EVAL@COMPILE (RPAQQ \NS.WKS.RoutingInformation 1) (RPAQQ \NS.WKS.Echo 2) (RPAQQ \NS.WKS.PUPLOOKUP 9) (CONSTANTS (\NS.WKS.RoutingInformation 1) (\NS.WKS.Echo 2) (\NS.WKS.PUPLOOKUP 9)) ) (* ; "ERRORXIP -- overlays XIP") (DECLARE%: EVAL@COMPILE (ACCESSFNS ERRORXIP ((ERRORXIPBASE (fetch XIPCONTENTS of DATUM))) (BLOCKRECORD ERRORXIPBASE ((ERRORXIPCODE WORD) (ERRORXIPARG WORD) (ERRORXIPBODY WORD) (* ;  "As many words of offending XIP as sender felt like including...") ))) ) (RPAQQ XIPERRORCODES ((\XIPE.CHECKSUM 1) (\XIPE.NOSOCKET 2) (\XIPE.SOCKETFULL 3) (\XIPE.GATEWAY.CHECKSUM 513) (\XIPE.NOROUTE 514) (\XIPE.LOOPED 515) (\XIPE.TOOLARGE 516))) (DECLARE%: EVAL@COMPILE (RPAQQ \XIPE.CHECKSUM 1) (RPAQQ \XIPE.NOSOCKET 2) (RPAQQ \XIPE.SOCKETFULL 3) (RPAQQ \XIPE.GATEWAY.CHECKSUM 513) (RPAQQ \XIPE.NOROUTE 514) (RPAQQ \XIPE.LOOPED 515) (RPAQQ \XIPE.TOOLARGE 516) (CONSTANTS (\XIPE.CHECKSUM 1) (\XIPE.NOSOCKET 2) (\XIPE.SOCKETFULL 3) (\XIPE.GATEWAY.CHECKSUM 513) (\XIPE.NOROUTE 514) (\XIPE.LOOPED 515) (\XIPE.TOOLARGE 516)) ) (* ; "NSADDRESS") (DECLARE%: EVAL@COMPILE (DATATYPE NSADDRESS ((NSNET FIXP) (NSHNM0 WORD) (NSHNM1 WORD) (NSHNM2 WORD) (NSSOCKET WORD)) (ACCESSFNS (NSHOSTNUMBER (\LOADNSHOSTNUMBER (LOCF (fetch NSHNM0 of DATUM))) (\STORENSHOSTNUMBER (LOCF (fetch NSHNM0 of DATUM)) NEWVALUE))) (BLOCKRECORD NSADDRESS ((NSNETHI WORD) (NSNETLO WORD)))) (TYPERECORD NSHOSTNUMBER (NSHOST0 NSHOST1 NSHOST2)) ) (/DECLAREDATATYPE 'NSADDRESS '(FIXP WORD WORD WORD WORD) '((NSADDRESS 0 FIXP) (NSADDRESS 2 (BITS . 15)) (NSADDRESS 3 (BITS . 15)) (NSADDRESS 4 (BITS . 15)) (NSADDRESS 5 (BITS . 15))) '6) (DECLARE%: EVAL@COMPILE (PUTPROPS LOADNSHOSTNUMBER MACRO (= . \LOADNSHOSTNUMBER)) (PUTPROPS STORENSHOSTNUMBER MACRO (= . \STORENSHOSTNUMBER)) (PUTPROPS \MOVENSADDRESSES MACRO ((BASE1 BASE2) (\BLT BASE2 BASE1 \#WDS.NSADDRESS))) [PUTPROPS \SWAPNSADDRESSES MACRO (OPENLAMBDA (BASE1 BASE2) (for I from 0 to (SUB1 \#WDS.NSADDRESS) do (\PUTBASE BASE1 I (PROG1 (\GETBASE BASE2 I) (\PUTBASE BASE2 I (PROGN (\GETBASE BASE1 I))))] ) (DECLARE%: EVAL@COMPILE (RPAQQ \#WDS.NSADDRESS 6) (RPAQQ \#WDS.NSHOSTNUMBER 3) (CONSTANTS (\#WDS.NSADDRESS 6) (\#WDS.NSHOSTNUMBER 3)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \LOCALNSHOSTNUMBER MACRO (NIL \MY.NSHOSTNUMBER)) (PUTPROPS \LOCALNSNETNUMBER MACRO (NIL \MY.NSNETNUMBER)) (PUTPROPS \LOCALNSADDRESS MACRO (NIL \MY.NSADDRESS)) (PUTPROPS \BLTLOCALHOSTNUMBER MACRO ((BASE) (\BLT BASE (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage )) 3))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS BROADCASTNSHOSTNUMBER \MY.NSADDRESS \MY.NSHOSTNUMBER \MY.NSNETNUMBER) ) (DECLARE%: EVAL@COMPILE (PUTPROPS EQNSHOSTNUMBER MACRO (X (TRANSLATE.NSH X))) [PUTPROPS EQNSADDRESS.HOST MACRO (OPENLAMBDA (X Y) (* ;; "True if the 48-bit host components of 2 NSADDRESS's (or pointers to equivalent storage) are the same") (AND (EQ (FFETCH NSHNM2 OF X) (FFETCH NSHNM2 OF Y)) (EQ (FFETCH NSHNM1 OF X) (FFETCH NSHNM1 OF Y)) (EQ (FFETCH NSHNM0 OF X) (FFETCH NSHNM0 OF Y] (PUTPROPS EQBROADCASTBASE MACRO (OPENLAMBDA (X) (EQ (LOGAND (\GETBASE X 0) (\GETBASE X 1) (\GETBASE X 2)) 65535))) [PUTPROPS EQNSHOSTBASE MACRO (OPENLAMBDA (X Y) (AND (type? NSHOSTNUMBER Y) (EQ (\GETBASE X 2) (fetch (NSHOSTNUMBER NSHOST2) of Y)) (EQ (\GETBASE X 1) (fetch (NSHOSTNUMBER NSHOST1) of Y)) (EQ (\GETBASE X 0) (fetch (NSHOSTNUMBER NSHOST0) of Y] ) (DEFINEQ (TRANSLATE.NSH (LAMBDA (ARGS) (* bvm%: "28-Nov-83 17:32") (SETQ ARGS (CDR (DWIMIFY (CONS (QUOTE PROGN) ARGS) T))) (PROG ((ARG1 (CAR ARGS)) (ARG2 (CADR ARGS))) (RETURN (COND ((OR (NLISTP ARG1) (SELECTQ (CAR (SETQ ARG1 (OR (GETHASH ARG1 CLISPARRAY) ARG1))) ((LOADNSHOSTNUMBER \LOADNSHOSTNUMBER) NIL) T)) (LIST (QUOTE EQUAL) ARG1 ARG2)) ((EQ ARG2 (QUOTE BROADCASTNSHOSTNUMBER)) (LIST (QUOTE EQBROADCASTBASE) (CADR ARG1))) (T (LIST (QUOTE EQNSHOSTBASE) (CADR ARG1) ARG2)))))) ) ) (ADDTOVAR DONTCOMPILEFNS TRANSLATE.NSH) (PUTPROPS LLNSDECLS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (12489 12978 (TRANSLATE.NSH 12499 . 12976))))) STOP \ No newline at end of file diff --git a/sources/LLPACKAGE b/sources/LLPACKAGE new file mode 100644 index 00000000..f08e4a2e --- /dev/null +++ b/sources/LLPACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "22-Sep-92 11:47:31" "{Pele:mv:envos}Sources>LLPACKAGE.;25" 82127 IL:|changes| IL:|to:| (IL:FUNCTIONS IL:ADD-SYMBOL) IL:|previous| IL:|date:| "20-May-91 13:07:32" "{Pele:mv:envos}Sources>LLPACKAGE.;24" ) ; Copyright (c) 1986, 1987, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:LLPACKAGECOMS) (IL:RPAQQ IL:LLPACKAGECOMS ( (IL:* IL:|;;| "The Xerox Lisp package system, based on CMU's Spice Lisp") (IL:* IL:|;;| "Internal macros and definitions") (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FUNCTIONS IL:PACKAGE-LISTIFY IL:\\SIMPLE-STRINGIFY IL:SYMBOL-LISTIFY IL:COPY-STRING IL:\\SYMBOL-EQUALBASE)) (IL:FUNCTIONS IL:\\FATCHARSEENP IL:\\PACKAGIFY IL:\\STRING-EQUALBASE IL:NUMERIC-UPCASE IL:\\UPCASEBASE IL:APROPOS-SEARCH) (IL:STRUCTURES PACKAGE-HASHTABLE PACKAGE) (IL:FUNCTIONS PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-SHADOWING-SYMBOLS PACKAGE-USE-LIST PACKAGE-USED-BY-LIST) (IL:FUNCTIONS IL:MAKE-PACKAGE-HASHTABLE PRINT-PACKAGE PRINT-PACKAGE-HASHTABLE) (IL:VARIABLES *PACKAGE* XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* IL:*LISP-PACKAGE* IL:*KEYWORD-PACKAGE* IL:*INTERLISP-PACKAGE* IL:HASHTABLE-SIZE-LIMIT IL:PACKAGE-REHASH-THRESHOLD) (IL:VARIABLES IL:PRIME-HASHTABLE-SIZES) (IL:* IL:|;;| "The package system's version of symbol creation") (IL:FUNCTIONS MAKE-SYMBOL) (IL:* IL:|;;| "Packages are currently implemented using a free byte in the litatom pnamecell. The byte is used as an index into a table.") (IL:VARIABLES IL:*PACKAGE-FROM-NAME* IL:*PACKAGE-FROM-INDEX* XCL:*TOTAL-PACKAGES-LIMIT* IL:*UNINTERNED-PACKAGE-INDEX*) (IL:FUNCTIONS IL:\\PKG-FIND-FREE-PACKAGE-INDEX) (IL:* IL:|;;| "Symbol package cell handlers.") (IL:FUNCTIONS IL:SETF-SYMBOL-PACKAGE SYMBOL-PACKAGE) (IL:* IL:|;;| "Symbol hashing") (IL:FUNCTIONS IL:SYMBOL-HASH IL:REHASH-FACTOR IL:SYMBOL-HASH-REPROBE IL:ENTRY-HASH) (IL:* IL:|;;| "Constructing packages") (IL:FUNCTIONS IL:COUNT-PACKAGE-HASHTABLE IL:INTERNAL-SYMBOL-COUNT IL:EXTERNAL-SYMBOL-COUNT ) (IL:FUNCTIONS IL:ENTER-NEW-NICKNAMES IL:MAKE-PRIME-HASHTABLE-SIZE) (IL:FUNCTIONS MAKE-PACKAGE) (IL:FNS XCL:DEFPACKAGE) (IL:* IL:|;;| "Package manipulations") (IL:FUNCTIONS FIND-PACKAGE USE-PACKAGE IN-PACKAGE XCL:PKG-GOTO RENAME-PACKAGE XCL:DELETE-PACKAGE EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW UNUSE-PACKAGE) (IL:* IL:|;;| "Knowing about the package name space") (IL:FUNCTIONS LIST-ALL-PACKAGES) (IL:* IL:|;;| "Putting symbols into packages") (IL:FUNCTIONS IL:ADD-SYMBOL IL:WITH-SYMBOL) (IL:FUNCTIONS IL:INTERN* IL:FIND-SYMBOL*) (IL:FUNCTIONS INTERN FIND-SYMBOL) (IL:* IL:|;;| "Removing symbols from packages") (IL:FUNCTIONS IL:NUKE-SYMBOL) (IL:FUNCTIONS UNINTERN IL:MOBY-UNINTERN) (IL:* IL:|;;| "Iterations over package symbols") (IL:FUNCTIONS IL:\\INDEXATOMPNAME) (IL:* IL:\;  "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro") (IL:DECLARE\: IL:EVAL@COMPILE (IL:* IL:\;  "These are used in expanding the DO-SYMBOLS macro, which is used in this file.") (IL:FUNCTIONS IL:MAKE-DO-SYMBOLS-VARS IL:MAKE-DO-SYMBOLS-CODE)) (IL:FUNCTIONS DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS DO-ALL-SYMBOLS) (IL:* IL:|;;| "Finding symbols in a package or packages") (IL:FUNCTIONS FIND-ALL-SYMBOLS) (IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST) (IL:* IL:|;;|  "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)") (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL) (IL:FUNCTIONS IL:FIND-EXACT-SYMBOL IL:PACKAGE-NAME-AS-SYMBOL IL:\\FIND.PACKAGE.INTERNAL) (IL:* IL:|;;| "Proper compiler, readtable and package environment") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLPACKAGE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA XCL:DEFPACKAGE) (IL:NLAML) (IL:LAMA))))) (IL:* IL:|;;| "The Xerox Lisp package system, based on CMU's Spice Lisp") (IL:* IL:|;;| "Internal macros and definitions") (IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (DEFMACRO IL:PACKAGE-LISTIFY (IL:OBJ) "Return NIL or a list of packages given NIL or a package-or-string-or-symbol or list thereof, or die trying." `(LET ((IL:THING ,IL:OBJ)) (COND ((NULL IL:THING) NIL) ((IL:LISTP IL:THING) (LET ((IL:RESULT NIL)) (DOLIST (PACKAGE IL:THING IL:RESULT) (PUSH (IL:\\PACKAGIFY PACKAGE) IL:RESULT)))) (T (LIST (IL:\\PACKAGIFY IL:THING)))))) (DEFMACRO IL:\\SIMPLE-STRINGIFY (IL:OBJ) "If OBJ is a non-stringp-string or symbol, make it a stringp." `(LET ((IL:|obj| ,IL:OBJ)) (COND ((IL:STRINGP IL:|obj|) IL:|obj|) ((OR (STRINGP IL:|obj|) (SYMBOLP IL:|obj|)) (IL:MKSTRING IL:|obj|)) (T (IL:ERROR "Not a string or symbol " IL:|obj|))))) (DEFMACRO IL:SYMBOL-LISTIFY (IL:OBJ) "Take a symbol-or-list-of-symbols and return a list, checking types." `(LET ((IL:THING ,IL:OBJ)) (COND ((SYMBOLP IL:THING) (LIST IL:THING)) ((IL:LISTP IL:THING) (DOLIST (IL:S IL:THING) (UNLESS (SYMBOLP IL:S) (IL:ERROR "Not a symbol." IL:S))) IL:THING) (T (IL:ERROR "Neither a symbol nor a list of symbols." IL:THING))))) (DEFMACRO IL:COPY-STRING (STRING) `(IL:CONCAT ,STRING)) (DEFMACRO IL:\\SYMBOL-EQUALBASE (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) "Compare a string, given in base offset length form, to a symbol's pname string" `(AND (EQL ,IL:LENGTH (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| ,SYMBOL)) (DO ((IL:I 0 (IL:ADD1 IL:I)) (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| ,SYMBOL)) (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| ,SYMBOL))) ((EQL IL:I ,IL:LENGTH) T) (IF (NOT (EQL (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE (IL:ADD1 IL:I)) (IL:\\GETBASECHAR ,IL:FATP ,IL:BASE (IL:IPLUS ,IL:OFFSET IL:I)))) (RETURN NIL))))) ) (DEFMACRO IL:\\FATCHARSEENP (IL:BASE IL:OFFSET IL:LEN IL:FATP) `(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET ,IL:LEN)) IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I) IL:\\MAXTHINCHAR)))))) (DEFMACRO IL:\\PACKAGIFY (IL:OBJ) "If OBJ isn't already a package, turn the symbol or string into the package of that name." `(LET ((IL:|obj| ,IL:OBJ)) (OR (COND ((PACKAGEP IL:|obj|) IL:|obj|) ((STRINGP IL:|obj|) (FIND-PACKAGE IL:|obj|)) ((SYMBOLP IL:|obj|) (FIND-PACKAGE (SYMBOL-NAME IL:|obj|))) (T NIL)) (IL:ERROR "Not an existing package, string or symbol " IL:|obj|)))) (DEFMACRO IL:\\STRING-EQUALBASE (STRING IL:BASE IL:OFFSET IL:LENGTH IL:FATP) "Compare a string to another string, with the second given in base offset length form." `(AND (EQL ,IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) ,STRING)) (DO ((IL:I 0 (IL:ADD1 IL:I)) (IL:STRING-BASE (IL:|ffetch| (IL:STRINGP IL:BASE) ,STRING)) (IL:STRING-OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) ,STRING)) (IL:STRING-FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) ,STRING))) ((EQL IL:I ,IL:LENGTH) T) (IF (NOT (EQL (IL:\\GETBASECHAR IL:STRING-FATP IL:STRING-BASE (IL:IPLUS IL:STRING-OFFSET IL:I)) (IL:\\GETBASECHAR ,IL:FATP ,IL:BASE (IL:IPLUS ,IL:OFFSET IL:I)))) (RETURN NIL))))) (DEFMACRO IL:NUMERIC-UPCASE (IL:A) `(LET ((IL:N ,IL:A)) (IF (AND (IL:IGEQ IL:N (IL:CHARCODE "a")) (IL:ILEQ IL:N (IL:CHARCODE "z"))) (IL:IDIFFERENCE IL:N 32) IL:N))) (DEFUN IL:\\UPCASEBASE (IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IL:|for| IL:I IL:|from| IL:OFFSET IL:|to| (IL:IPLUS IL:OFFSET IL:LENGTH) IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:FATP IL:BASE IL:I ))))) (DEFUN IL:APROPOS-SEARCH (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) "The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase." (DO ((IL:INDEX 0 (IL:ADD1 IL:INDEX)) (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL)) (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL)) (IL:TERMINUS (IL:IDIFFERENCE (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL) IL:LENGTH))) ((IL:IGREATERP IL:INDEX IL:TERMINUS) NIL) (IF (DO ((IL:JNDEX IL:OFFSET (IL:ADD1 IL:JNDEX)) (IL:KNDEX IL:INDEX (IL:ADD1 IL:KNDEX)) (IL:TERMINUS (IL:IPLUS IL:LENGTH IL:OFFSET))) ((EQL IL:JNDEX IL:TERMINUS) T) (UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX) (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE (IL:ADD1 IL:KNDEX)))) (RETURN NIL))) (RETURN T)))) (DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE) (:COPIER NIL) (:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE)) "Packages are implemented using a special kind of hashtable (this one). It is an open hashtable with a parallel 8-bit I-vector of hash-codes. The primary purpose of the hash for each entry is to reduce paging by allowing collisions and misses to be detected without paging in the symbol and pname for an entry. If the hash for an entry doesn't match that for the symbol that we are looking for, then we can go on without touching the symbol, pname, or even hastable vector. It turns out that, contrary to my expectations, paging is a very important consideration the design of the package representation. Using a similar scheme without the entry hash, the fasloader was spending more than half its time paging in INTERN. The hash code also indicates the status of an entry. If it zero, the the entry is unused. If it is one, then it is deleted. Double-hashing is used for collision resolution." TABLE HASH SIZE FREE DELETED) (DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-) (:CONSTRUCTOR %MAKE-PACKAGE) (:PREDICATE PACKAGEP) (:PRINT-FUNCTION PRINT-PACKAGE)) INDEX (TABLES (LIST NIL)) NAME NAMESYMBOL NICKNAMES (USE-LIST NIL) (USED-BY-LIST NIL) (EXTERNAL-ONLY NIL) INTERNAL-SYMBOLS EXTERNAL-SYMBOLS (SHADOWING-SYMBOLS NIL)) (DEFUN PACKAGE-NAME (PACKAGE) (%PACKAGE-NAME (IL:\\PACKAGIFY PACKAGE))) (DEFUN PACKAGE-NICKNAMES (PACKAGE) (%PACKAGE-NICKNAMES (IL:\\PACKAGIFY PACKAGE))) (DEFUN PACKAGE-SHADOWING-SYMBOLS (PACKAGE) (%PACKAGE-SHADOWING-SYMBOLS (IL:\\PACKAGIFY PACKAGE))) (DEFUN PACKAGE-USE-LIST (PACKAGE) (%PACKAGE-USE-LIST (IL:\\PACKAGIFY PACKAGE))) (DEFUN PACKAGE-USED-BY-LIST (PACKAGE) (%PACKAGE-USED-BY-LIST (IL:\\PACKAGIFY PACKAGE))) (DEFUN IL:MAKE-PACKAGE-HASHTABLE (IL:SIZE &OPTIONAL (IL:RES (%MAKE-PACKAGE-HASHTABLE))) "Make a package hashtable having a prime number of entries at least as great as (/ size package-rehash-threshold). If Res is supplied, then it is destructively modified to produce the result. This is useful when changing the size, since there are many pointers to the hashtable." (LET ((IL:N (IL:MAKE-PRIME-HASHTABLE-SIZE IL:SIZE))) (DECLARE (TYPE FIXNUM IL:N)) (SETF (PACKAGE-HASHTABLE-TABLE IL:RES) (LIST (MAKE-ARRAY IL:N :ELEMENT-TYPE '(UNSIGNED-BYTE 32)))) (SETF (PACKAGE-HASHTABLE-HASH IL:RES) (LIST (MAKE-ARRAY IL:N :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))) (LET ((IL:SIZE (IF (EQL IL:N IL:HASHTABLE-SIZE-LIMIT) IL:HASHTABLE-SIZE-LIMIT (IL:FIX (IL:FTIMES IL:N IL:PACKAGE-REHASH-THRESHOLD))))) (SETF (PACKAGE-HASHTABLE-SIZE IL:RES) IL:SIZE) (SETF (PACKAGE-HASHTABLE-FREE IL:RES) IL:SIZE)) (SETF (PACKAGE-HASHTABLE-DELETED IL:RES) 0) IL:RES)) (DEFUN PRINT-PACKAGE (PACKAGE STREAM DEPTH) (IL:PRIN3 "#" STREAM)) (DEFUN PRINT-PACKAGE-HASHTABLE (TABLE STREAM DEPTH) (IL:PRIN3 "#" STREAM)) (DEFVAR *PACKAGE* NIL "The current package, in which read symbols are intern'ed.") (DEFVAR XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* '("LISP" "INTERLISP" "XEROX-COMMON-LISP") "Packages whose deletion requires confirmation.") (XCL:DEFGLOBALVAR IL:*LISP-PACKAGE* NIL "Global for internal references to the lisp package.") (XCL:DEFGLOBALVAR IL:*KEYWORD-PACKAGE* NIL "Global for internal references to the keyword package.") (XCL:DEFGLOBALVAR IL:*INTERLISP-PACKAGE* NIL "Global for internal references to the interlisp package.") (DEFCONSTANT IL:HASHTABLE-SIZE-LIMIT 65521 "The maximum (inclusive, prime) limit to the size of a hashtable.") (DEFPARAMETER IL:PACKAGE-REHASH-THRESHOLD 0.5 "The maximum density allowed in a package hashtable") (DEFCONSTANT IL:PRIME-HASHTABLE-SIZES '(7 19 67 113 199 293 397 887 1373 2347 4297 8191 15991 40763 65521) "Some valid (prime) hashtable sizes.") (IL:* IL:|;;| "The package system's version of symbol creation") (DEFUN MAKE-SYMBOL (IL:PRINT-NAME) "Make an uninterned symbol." (IF (NOT (STRINGP IL:PRINT-NAME)) (IL:ERROR "Not a string " IL:PRINT-NAME)) (IL:SETQ IL:PRINT-NAME (IL:MKSTRING IL:PRINT-NAME)) (LET ((IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:PRINT-NAME)) (IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:PRINT-NAME)) (IL:LEN (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:PRINT-NAME)) (IL:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME))) (IL:UNINTERRUPTABLY (IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFST IL:LEN IL:FATP))))) (IL:* IL:|;;| "Packages are currently implemented using a free byte in the litatom pnamecell. The byte is used as an index into a table." ) (XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS 'IL:STREQUAL) "An equal hashtable from package names to packages.") (XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-INDEX* (MAKE-ARRAY 256 ':INITIAL-ELEMENT NIL) "Index to package converter.") (DEFCONSTANT XCL:*TOTAL-PACKAGES-LIMIT* 255 "The total number of packages that the system may have (excluding the 'uninterned' package).") (DEFCONSTANT IL:*UNINTERNED-PACKAGE-INDEX* 0 "Package index value for uninterned symbols. The function \\PKG-FIND-FREE-PACKAGE-INDEX and the constant *UNINTERNED-PACKAGE-INDEX* are arranged so that SYMBOL-PACKAGE can find NIL in the index vector and NIL can also be the free slot marker. *UNINTERNED-PACKAGE-INDEX* must be zero, otherwise change \\PKG-FIND-FREE-PACKAGE-INDEX ." ) (DEFUN IL:\\PKG-FIND-FREE-PACKAGE-INDEX () "Return the next free table index for a package. Starts counting at 1 because 0 is for uninterned symbols." (DO ((IL:I 1 (IL:ADD1 IL:I))) ((EQL IL:I XCL:*TOTAL-PACKAGES-LIMIT*) (ERROR "Package space full" NIL)) (DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX*)) (IF (NULL (AREF IL:*PACKAGE-FROM-INDEX* IL:I)) (RETURN IL:I)))) (IL:* IL:|;;| "Symbol package cell handlers.") (DEFUN IL:SETF-SYMBOL-PACKAGE (IL:OBJ IL:VALUE) (IL:|freplace| (SYMBOL PACKAGE) IL:|of| IL:OBJ IL:|with| IL:VALUE) IL:VALUE) (DEFUN SYMBOL-PACKAGE (SYMBOL) (IL:|ffetch| (SYMBOL PACKAGE) IL:|of| SYMBOL)) (IL:* IL:|;;| "Symbol hashing") (DEFMACRO IL:SYMBOL-HASH (IL:BASE IL:OFFST IL:LEN IL:FATP) "Returns the atom hash of the given string" `(IF (EQL 0 ,IL:LEN) 0 (DO* ((IL:TERMINUS (IL:IPLUS ,IL:OFFST ,IL:LEN)) (IL:HASH (IL:LLSH (IL:UNLESSRDSYS (COND (,IL:FATP (LOGAND (IL:\\GETBASEFAT ,IL:BASE ,IL:OFFST) 255)) (T (IL:\\GETBASETHIN ,IL:BASE ,IL:OFFST))) (IL:NTHCHARCODE ,IL:BASE ,IL:OFFST)) 8) (IL:IPLUS16 (IL:IPLUS16 (IL:SETQ IL:HASH (IL:IPLUS16 IL:HASH (IL:LLSH (LOGAND IL:HASH 4095) 2))) (IL:LLSH (LOGAND IL:HASH 255) 8)) (IL:UNLESSRDSYS (COND (,IL:FATP (LOGAND (IL:\\GETBASEFAT ,IL:BASE IL:CHAR#) 255)) (T (IL:\\GETBASETHIN ,IL:BASE IL:CHAR#))) (IL:NTHCHARCODE ,IL:BASE IL:CHAR#)))) (IL:CHAR# (IL:ADD1 ,IL:OFFST) (IL:ADD1 IL:CHAR#))) ((IL:IGEQ IL:CHAR# IL:TERMINUS) IL:HASH)))) (DEFMACRO IL:REHASH-FACTOR (IL:HASH IL:TABLE-LENGTH) `(IL:ADD1 (IL:IREMAINDER ,IL:HASH (IL:IDIFFERENCE ,IL:TABLE-LENGTH 2)))) (DEFMACRO IL:SYMBOL-HASH-REPROBE (IL:HASH IL:REHASH-FACTOR IL:TABLE-LENGTH) `(IL:IREMAINDER (IL:IPLUS ,IL:HASH ,IL:REHASH-FACTOR) ,IL:TABLE-LENGTH)) (DEFMACRO IL:ENTRY-HASH (IL:STRING-LENGTH SXHASH) "Compute a number from the sxhash of the pname and the length which must be between 2 and 255." `(IL:IPLUS (IL:IREMAINDER (LOGXOR ,IL:STRING-LENGTH ,SXHASH (IL:LRSH ,SXHASH 8) (IL:LRSH ,SXHASH 16) (IL:LRSH ,SXHASH 19)) 254) 2)) (IL:* IL:|;;| "Constructing packages") (DEFMACRO IL:COUNT-PACKAGE-HASHTABLE (IL:TABLE) "Return two values: free elements and total size." `(LET ((IL:SIZE (IL:IDIFFERENCE (PACKAGE-HASHTABLE-SIZE ,IL:TABLE) (PACKAGE-HASHTABLE-DELETED ,IL:TABLE)))) (VALUES (IL:IDIFFERENCE IL:SIZE (PACKAGE-HASHTABLE-FREE ,IL:TABLE)) IL:SIZE))) (DEFUN IL:INTERNAL-SYMBOL-COUNT (PACKAGE) (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE) 0 (IL:COUNT-PACKAGE-HASHTABLE (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)))) (DEFUN IL:EXTERNAL-SYMBOL-COUNT (PACKAGE) (IL:COUNT-PACKAGE-HASHTABLE (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))) (DEFUN IL:ENTER-NEW-NICKNAMES (PACKAGE IL:NICKNAMES) "Enter any new Nicknames for Package into *package-names*. If there is a conflict then give the user a chance to do something about it." (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (CHECK-TYPE IL:NICKNAMES LIST) (DOLIST (IL:N IL:NICKNAMES) (IL:SETQ IL:N (IL:\\SIMPLE-STRINGIFY IL:N)) (LET ((IL:FOUND (IL:GETHASH IL:N IL:*PACKAGE-FROM-NAME*))) (COND ((NOT IL:FOUND) (IL:PUTHASH IL:N PACKAGE IL:*PACKAGE-FROM-NAME*) (PUSH IL:N (%PACKAGE-NICKNAMES PACKAGE))) ((EQ IL:FOUND PACKAGE)) ((IL:STREQUAL (%PACKAGE-NAME IL:FOUND) IL:N) (IL:ERROR (IL:CONCAT IL:N "is already a package name, so it cannot be a nickname for " (%PACKAGE-NAME PACKAGE)))) (T (IL:ERROR (IL:CONCAT IL:N " is already a nickname for " (%PACKAGE-NAME IL:FOUND))) (IL:PUTHASH IL:N PACKAGE IL:*PACKAGE-FROM-NAME*) (PUSH IL:N (%PACKAGE-NICKNAMES PACKAGE))))))) (DEFUN IL:MAKE-PRIME-HASHTABLE-SIZE (IL:N) "Find an appropriate size based on the expected number of elements, N, the rehash threshold and the limit on array size." (LET ((IL:N (IL:LOGOR (IL:FIX (IL:FQUOTIENT IL:N IL:PACKAGE-REHASH-THRESHOLD)) 1))) (DOLIST (IL:X IL:PRIME-HASHTABLE-SIZES IL:HASHTABLE-SIZE-LIMIT) (WHEN (IL:IGEQ IL:X IL:N) (RETURN IL:X))))) (DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP")) NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL) (INTERNAL-SYMBOLS 10) (EXTERNAL-SYMBOLS 10)) "Check for package name conflicts in name and nicknames, then make the package. Do a use-package for each thing in the use list so that checking for conflicting exports among used packages is done." (DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*)) (WHEN (FIND-PACKAGE NAME) (IL:ERROR (IL:CONCAT "Package " NAME " already exists."))) (SETF NAME (IL:MKSTRING NAME)) (SETF PREFIX-NAME (MAKE-SYMBOL (OR PREFIX-NAME NAME))) (LET* ((%PACKAGE-INDEX (IL:\\PKG-FIND-FREE-PACKAGE-INDEX)) (PACKAGE (%MAKE-PACKAGE :NAME NAME :NAMESYMBOL PREFIX-NAME :EXTERNAL-ONLY EXTERNAL-ONLY :INTERNAL-SYMBOLS (IF (NOT EXTERNAL-ONLY) (IL:MAKE-PACKAGE-HASHTABLE INTERNAL-SYMBOLS) NIL) :EXTERNAL-SYMBOLS (IL:MAKE-PACKAGE-HASHTABLE EXTERNAL-SYMBOLS) :INDEX %PACKAGE-INDEX))) (USE-PACKAGE USE PACKAGE) (IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME)) NICKNAMES (CONS PREFIX-NAME NICKNAMES))) (IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*) (SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX) PACKAGE))) (IL:DEFINEQ (xcl:defpackage (il:nlambda il:args (il:* il:\; "Edited 2-Dec-87 10:39 by raf") (il:setq il:args (xcl:remove-comments il:args)) (let ((package (find-package (car il:args)))) (cond ((packagep package) (il:* il:\; "If one already exists, test compatability of package definitions") (il:|for| il:option il:|in| (cdr il:args) il:|do| (let* ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:internal-symbols :external-symbols) nil) (:external-only (if (not (%package-external-only package)) (il:error "Package NOT :external-only as asserted by defpackage: " package))) (:prefix-name (setf (%package-namesymbol package) (make-symbol (car values)))) (:use (use-package values package)) (:nicknames (il:enter-new-nicknames package values)) (:export (export (il:for il:symbol il:in values il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import values package)) ((:shadow :shadowing-import) (let ((il:symbols-to-shadow (il:mapconc values (il:function (il:lambda (symbol) (cond ((not (il:memb symbol (%package-shadowing-symbols package))) (list symbol)))))))) (il:selectq il:key (:shadow (shadow il:symbols-to-shadow package)) (:shadowing-import (shadowing-import il:symbols-to-shadow package)) nil))) (il:error "Bad keyword for defpackage " il:key))))) (t (il:* il:\; "Otherwise, make a new package to spec") (let ((il:post-make-forms nil)) (il:setq package (il:apply (quote make-package) (cons (car il:args) (il:|for| il:option il:|in| (cdr il:args) il:|join| (let ((il:key (cond ((keywordp il:option) il:option) ((il:listp il:option) (car il:option)) (t (il:error "Bad option for defpackage " il:option)))) (values (cond ((keywordp il:option) (list t)) ((il:listp il:option) (cdr il:option)) (t (il:error "Bad option for defpackage " il:option))))) (il:selectq il:key ((:use :nicknames) (list il:key (il:|if| (car values) il:|then| values il:|else| (il:* il:\; "Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP.") nil))) ((:prefix-name :internal-symbols :external-symbols :external-only) (list il:key (car values))) ((:shadow :export :import :shadowing-import) (il:setq il:post-make-forms (cons (cons il:key values) il:post-make-forms)) nil) (il:error "Bad keyword for defpackage " il:key))))))) (il:mapc il:post-make-forms (il:function (il:lambda (il:form) (il:selectq (car il:form) (:shadow (shadow (cdr il:form) package)) (:export (export (il:for il:symbol il:in (cdr il:form) il:collect (il:if (il:litatom il:symbol) il:then il:symbol il:elseif (il:stringp il:symbol) il:then (intern il:symbol package) il:else (il:error "Bad object in :export option of defpackage " il:symbol))) package)) (:import (import (cdr il:form) package)) (:shadowing-import (shadowing-import (cdr il:form) package)) (il:shouldnt "Bogus form on post-make-forms")))))))) (package-name package))) ) ) (IL:* IL:|;;| "Package manipulations") (DEFUN FIND-PACKAGE (IL:NAME) "Given a name, find the package with that name or nickname" (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (IL:GETHASH (IL:MKSTRING IL:NAME) IL:*PACKAGE-FROM-NAME* NIL)) (DEFUN USE-PACKAGE (IL:PACKAGES-TO-USE &OPTIONAL (PACKAGE *PACKAGE*)) "Make a package use (inherit) symbols from others. Checks for name-conflicts." (DECLARE (SPECIAL *PACKAGE*)) (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)) (IL:* IL:|;;| " Loop over each package, use'ing one at a time...") (DOLIST (IL:PKG (IL:PACKAGE-LISTIFY IL:PACKAGES-TO-USE)) (UNLESS (IL:FMEMB IL:PKG (%PACKAGE-USE-LIST PACKAGE)) (LET ((IL:CSET NIL) (IL:SHADOWING-SYMBOLS (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)) (IL:USE-LIST (%PACKAGE-USE-LIST PACKAGE))) (IL:* IL:|;;| "If the number of symbols already available is less than the number to be inherited then it is faster to run the test the other way. This is particularly valuable in the case of a new package use'ing Lisp.") (COND ((IL:ILESSP (IL:IPLUS (IL:INTERNAL-SYMBOL-COUNT PACKAGE) (IL:EXTERNAL-SYMBOL-COUNT PACKAGE) (LET ((IL:RES 0)) (DOLIST (IL:P IL:USE-LIST IL:RES) (INCF IL:RES (IL:EXTERNAL-SYMBOL-COUNT IL:P))))) (IL:EXTERNAL-SYMBOL-COUNT IL:PKG)) (DO-SYMBOLS (IL:SYM PACKAGE) (MULTIPLE-VALUE-BIND (IL:S IL:W) (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM) IL:PKG) (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM)) (NOT (IL:FMEMB IL:SYM IL:SHADOWING-SYMBOLS))) (PUSHNEW IL:SYM IL:CSET :TEST 'EQ)))) (DOLIST (IL:P IL:USE-LIST) (DO-EXTERNAL-SYMBOLS (IL:SYM IL:P) (MULTIPLE-VALUE-BIND (IL:S IL:W) (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM) IL:PKG) (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM)) (NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM) PACKAGE) IL:SHADOWING-SYMBOLS))) (PUSHNEW IL:SYM IL:CSET :TEST 'EQ)))))) (T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL (SYMBOL-NAME IL:SYM) PACKAGE) (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM)) (NOT (IL:FMEMB IL:S IL:SHADOWING-SYMBOLS))) (PUSHNEW IL:S IL:CSET :TEST 'EQ)))))) (WHEN IL:CSET (IL:RESOLVE-USE-PACKAGE-CONFLICT IL:PKG IL:CSET PACKAGE))) (PUSH IL:PKG (%PACKAGE-USE-LIST PACKAGE)) (PUSH (%PACKAGE-EXTERNAL-SYMBOLS IL:PKG) (CDR (%PACKAGE-TABLES PACKAGE))) (PUSH PACKAGE (%PACKAGE-USED-BY-LIST IL:PKG)))) T) (DEFUN IN-PACKAGE (IL:NAME &REST IL:KEYS &KEY IL:NICKNAMES IL:USE) "Like Make-Package, but also makes the created package current." (DECLARE (SPECIAL *PACKAGE*)) (LET ((PACKAGE (FIND-PACKAGE IL:NAME))) (COND (PACKAGE (USE-PACKAGE IL:USE PACKAGE) (IL:ENTER-NEW-NICKNAMES PACKAGE IL:NICKNAMES) (IL:SETQ *PACKAGE* PACKAGE)) (T (IL:SETQ *PACKAGE* (APPLY 'MAKE-PACKAGE IL:NAME IL:KEYS)))))) (DEFUN XCL:PKG-GOTO (XCL::NAME &REST XCL::KEYS) "Like in-package, but confirms creation of new packages." (WHEN (OR (PACKAGEP (FIND-PACKAGE XCL::NAME)) (Y-OR-N-P "Create new package ~a?" XCL::NAME)) (APPLY 'IN-PACKAGE XCL::NAME XCL::KEYS))) (DEFUN RENAME-PACKAGE (PACKAGE IL:NAME &OPTIONAL IL:NICKNAMES IL:PREFIX-NAME) "Change the name if we can, blast any old nicknames and then add in any new ones." (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (SETF IL:NAME (IL:\\SIMPLE-STRINGIFY IL:NAME)) (SETF IL:PREFIX-NAME (MAKE-SYMBOL (OR IL:PREFIX-NAME IL:NAME))) (LET ((IL:FOUND (FIND-PACKAGE IL:NAME))) (UNLESS (OR (NOT IL:FOUND) (EQ IL:FOUND PACKAGE)) (ERROR "A package named ~S already exists." IL:NAME)) (REMHASH (%PACKAGE-NAME PACKAGE) IL:*PACKAGE-FROM-NAME*) (SETF (%PACKAGE-NAME PACKAGE) IL:NAME) (SETF (%PACKAGE-NAMESYMBOL PACKAGE) IL:PREFIX-NAME) (IL:PUTHASH IL:NAME PACKAGE IL:*PACKAGE-FROM-NAME*) (DOLIST (IL:N (%PACKAGE-NICKNAMES PACKAGE)) (REMHASH IL:N IL:*PACKAGE-FROM-NAME*)) (SETF (%PACKAGE-NICKNAMES PACKAGE) NIL) (IL:ENTER-NEW-NICKNAMES PACKAGE IL:NICKNAMES) PACKAGE)) (DEFUN XCL:DELETE-PACKAGE (PACKAGE) (IL:* IL:|;;;| "All other packages unuse this one, all the package's symbols are uninterned and then its name is removed.") (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (WHEN (OR (AND (EQ PACKAGE *PACKAGE*) (NOT (YES-OR-NO-P "About to delete the current package; this is dangerous, are you sure?" ))) (AND (MEMBER (%PACKAGE-NAME PACKAGE) XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* :TEST 'STRING=) (NOT (YES-OR-NO-P "About to delete the ~a package; this is dangerous, are you sure?" (%PACKAGE-NAME PACKAGE))))) (RETURN-FROM XCL:DELETE-PACKAGE NIL)) (DOLIST (XCL::USER (%PACKAGE-USED-BY-LIST PACKAGE)) (UNUSE-PACKAGE PACKAGE XCL::USER)) (DOLIST (XCL::USED (%PACKAGE-USE-LIST PACKAGE)) (UNUSE-PACKAGE XCL::USED PACKAGE)) (XCL:DO-LOCAL-SYMBOLS (SYMBOL PACKAGE) (WHEN (EQ PACKAGE (SYMBOL-PACKAGE SYMBOL)) (UNINTERN SYMBOL PACKAGE))) (REMHASH (%PACKAGE-NAME PACKAGE) IL:*PACKAGE-FROM-NAME*) (DOLIST (IL:NAME (%PACKAGE-NICKNAMES PACKAGE)) (REMHASH IL:NAME IL:*PACKAGE-FROM-NAME*)) (SETF (AREF IL:*PACKAGE-FROM-INDEX* (%PACKAGE-INDEX PACKAGE)) NIL) T) (DEFUN EXPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) "Make the symbols external in the package." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET ((IL:SYMS NIL)) (IL:* IL:|;;| "Punt any symbols that are already external.") (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS)) (MULTIPLE-VALUE-BIND (IL:S IL:W) (IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM) PACKAGE) (UNLESS (OR IL:W (IL:FMEMB IL:SYM IL:SYMS)) (PUSH IL:SYM IL:SYMS)))) (IL:* IL:|;;| "Find symbols and packages with conflicts.") (LET ((IL:USED-BY (%PACKAGE-USED-BY-LIST PACKAGE)) (IL:CPACKAGES NIL) (IL:CSET NIL)) (DOLIST (IL:SYM IL:SYMS) (LET ((IL:NAME (SYMBOL-NAME IL:SYM))) (DOLIST (IL:P IL:USED-BY) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL IL:NAME IL:P) (WHEN (AND IL:W (NOT (EQ IL:S IL:SYM)) (NOT (IL:FMEMB IL:S (%PACKAGE-SHADOWING-SYMBOLS IL:P)))) (PUSHNEW IL:SYM IL:CSET) (PUSHNEW IL:P IL:CPACKAGES)))))) (WHEN IL:CSET (IL:* IL:\; "Resolve conflict") (IL:SETQ IL:SYMS (IL:RESOLVE-EXPORT-CONFLICT PACKAGE IL:CSET IL:CPACKAGES IL:SYMS))) ) (IL:* IL:|;;| "Check that all symbols are available. If not, ask to import them.") (LET ((IL:MISSING NIL) (IL:IMPORTS NIL)) (DOLIST (IL:SYM IL:SYMS) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL (SYMBOL-NAME IL:SYM) PACKAGE) (COND ((NOT (AND IL:W (EQ IL:S IL:SYM))) (PUSH IL:SYM IL:MISSING)) ((EQ IL:W :INHERITED) (PUSH IL:SYM IL:IMPORTS))))) (WHEN IL:MISSING (IL:* IL:\; "Get missing symbols") (IL:RESOLVE-EXPORT-MISSING PACKAGE IL:MISSING)) (WHEN IL:IMPORTS (IL:* IL:\; "Get inherited symbols") (IMPORT IL:IMPORTS PACKAGE))) (IL:* IL:|;;| "And now we export the symbols.") (LET ((IL:INTERNAL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)) (IL:EXTERNAL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))) (DOLIST (IL:SYM IL:SYMS) (IF (NOT (%PACKAGE-EXTERNAL-ONLY PACKAGE)) (IL:NUKE-SYMBOL IL:INTERNAL (SYMBOL-NAME IL:SYM))) (IL:ADD-SYMBOL IL:EXTERNAL IL:SYM))) T)) (DEFUN UNEXPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) "Check that all symbols are available, then move from external to internal." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (WHEN (%PACKAGE-EXTERNAL-ONLY PACKAGE) (IL:ERROR (IL:CONCAT "Can't unexport symbols " IL:SYMBOLS " from an external-only package " PACKAGE))) (LET ((IL:SYMS NIL)) (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS)) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL (SYMBOL-NAME IL:SYM) PACKAGE) (COND ((OR (NOT IL:W) (NOT (EQ IL:S IL:SYM))) (ERROR "~S is not available in the ~A package." IL:SYM (SYMBOL-NAME PACKAGE))) ((EQ IL:W :EXTERNAL) (PUSHNEW IL:SYM IL:SYMS))))) (LET ((IL:INTERNAL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)) (IL:EXTERNAL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))) (DOLIST (IL:SYM IL:SYMS) (IL:ADD-SYMBOL IL:INTERNAL IL:SYM) (IL:NUKE-SYMBOL IL:EXTERNAL (SYMBOL-NAME IL:SYM)))) T)) (DEFUN IMPORT (SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) "Make the symbol internal in the package, noting name conflicts." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET ((SYMS NIL) (CSET NIL)) (DOLIST (SYM (IL:SYMBOL-LISTIFY SYMBOLS)) (MULTIPLE-VALUE-BIND (S W) (FIND-SYMBOL (SYMBOL-NAME SYM) PACKAGE) (COND ((NOT W) (LET ((FOUND (MEMBER SYM SYMS :TEST 'IL:STREQUAL))) (IF FOUND (WHEN (NOT (EQ (CAR FOUND) SYM)) (PUSH SYM CSET)) (PUSH SYM SYMS)))) ((NOT (EQ S SYM)) (PUSH SYM CSET)) ((EQ W :INHERITED) (PUSH SYM SYMS))))) (WHEN CSET (IL:* IL:\; "Display the conflict") (IL:RESOLVE-IMPORT-CONFLICT PACKAGE CSET)) (LET ((HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE) (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)))) (DOLIST (SYM SYMS) (IL:ADD-SYMBOL HASHTABLE SYM) (IF (NULL (SYMBOL-PACKAGE SYM)) (SETF (SYMBOL-PACKAGE SYM) PACKAGE)))) (IF CSET (SHADOWING-IMPORT CSET PACKAGE) T))) (DEFUN SHADOWING-IMPORT (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) "If a conflicting symbol is present, unintern it, otherwise just stick the symbol in." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET ((IL:HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE) (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)))) (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS)) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL (SYMBOL-NAME IL:SYM) PACKAGE) (UNLESS (AND IL:W (EQ IL:S IL:SYM)) (WHEN (OR (EQ IL:W :INTERNAL) (EQ IL:W :EXTERNAL)) (IL:* IL:\;  " If it was shadowed, we don't want Unintern to fail") (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE) (DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))) (UNINTERN IL:S PACKAGE)) (IL:ADD-SYMBOL IL:HASHTABLE IL:SYM)) (PUSHNEW IL:SYM (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))))) T) (DEFUN SHADOW (IL:SYMBOLS &OPTIONAL (PACKAGE *PACKAGE*)) "Hide the existing symbols with new ones in the package." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET ((IL:HASHTABLE (IF (%PACKAGE-EXTERNAL-ONLY PACKAGE) (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)))) (DOLIST (IL:SYM (IL:SYMBOL-LISTIFY IL:SYMBOLS)) (LET ((IL:NAME (SYMBOL-NAME IL:SYM))) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL IL:NAME PACKAGE) (UNLESS (OR (EQ IL:W :INTERNAL) (EQ IL:W :EXTERNAL)) (IL:SETQ IL:S (MAKE-SYMBOL IL:NAME)) (SETF (SYMBOL-PACKAGE IL:S) PACKAGE) (IL:ADD-SYMBOL IL:HASHTABLE IL:S) (PUSHNEW IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))))))) T) (DEFUN UNUSE-PACKAGE (IL:PACKAGES-TO-UNUSE &OPTIONAL (PACKAGE *PACKAGE*)) "Remove some packages from the use (inherit) list of another package." (DECLARE (SPECIAL *PACKAGE*)) (SETF PACKAGE (IL:\\PACKAGIFY PACKAGE)) (DOLIST (IL:P (IL:PACKAGE-LISTIFY IL:PACKAGES-TO-UNUSE)) (SETF (%PACKAGE-USE-LIST PACKAGE) (IL:REMOVE IL:P (%PACKAGE-USE-LIST PACKAGE))) (SETF (%PACKAGE-TABLES PACKAGE) (IL:REMOVE (%PACKAGE-EXTERNAL-SYMBOLS IL:P) (%PACKAGE-TABLES PACKAGE))) (SETF (%PACKAGE-USED-BY-LIST IL:P) (IL:REMOVE PACKAGE (%PACKAGE-USED-BY-LIST IL:P)))) T) (IL:* IL:|;;| "Knowing about the package name space") (DEFUN LIST-ALL-PACKAGES () "Return a list of the names of all existing packages." (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (LET ((IL:RES NIL)) (MAPHASH #'(LAMBDA (IL:K IL:V) (PUSHNEW IL:V IL:RES)) IL:*PACKAGE-FROM-NAME*) IL:RES)) (IL:* IL:|;;| "Putting symbols into packages") (DEFUN IL:ADD-SYMBOL (IL:TABLE SYMBOL) "Add a symbol to a package hashtable. The symbol is assumed not to be present." (LET* ((IL:VEC (PACKAGE-HASHTABLE-TABLE IL:TABLE)) (IL:HASH (PACKAGE-HASHTABLE-HASH IL:TABLE)) (IL:LEN (ARRAY-TOTAL-SIZE (CAR IL:VEC))) (IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE)) (IL:SYMBOL-BASE (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL)) (IL:SYMBOL-LENGTH (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL)) (IL:SYMBOL-FATP (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL)) (SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP)) (IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN))) (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32)) IL:VEC) (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) IL:HASH)) (COND ((<= (PACKAGE-HASHTABLE-FREE IL:TABLE) (IL:LRSH IL:SIZE 2)) (IL:* IL:|;;| "Let each hash table get at most 75% full, so we have a reasonable chance of makeing a clear hash miss in few reprobes. Formerly, there was a BIG performance hit after the initial table overflowed.") (COND ((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT) (IL:* IL:|;;|  "We've spilled over into needing the list-of-tables feature, so add to the list.") (IL:SETQ IL:VEC (IL:NCONC1 IL:VEC (MAKE-ARRAY IL:LEN :ELEMENT-TYPE '(UNSIGNED-BYTE 32)))) (IL:SETQ IL:HASH (IL:NCONC1 IL:HASH (MAKE-ARRAY IL:LEN :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))) (SETF (PACKAGE-HASHTABLE-FREE IL:TABLE) (IL:FIX (IL:FTIMES (PACKAGE-HASHTABLE-SIZE IL:TABLE) IL:PACKAGE-REHASH-THRESHOLD))) (IL:ADD-SYMBOL IL:TABLE SYMBOL)) (T (IL:* IL:|;;|  "The initial table is still smaller than the limit. Increase its size.") (LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE)) (IL:VEC1 (CAR IL:VEC)) (IL:HASH1 (CAR IL:HASH))) (IL:MAKE-PACKAGE-HASHTABLE (IL:ITIMES IL:SIZE 2) IL:TABLE) (IL:ADD-SYMBOL IL:TABLE SYMBOL) (DOTIMES (IL:I IL:LEN) (WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I) 1) (IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1 IL:I)))))) ))) (T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH))) (IL:THIS-VEC (CAR (IL:FLAST IL:VEC)))) (DO ((IL:I (IL:IREMAINDER SXHASH IL:LEN) (IL:SYMBOL-HASH-REPROBE IL:I IL:H2 IL:LEN))) ((IL:ILESSP (AREF IL:THIS-HASH IL:I) 2) (IF (EQL 0 (AREF IL:THIS-HASH IL:I)) (DECF (PACKAGE-HASHTABLE-FREE IL:TABLE)) (DECF (PACKAGE-HASHTABLE-DELETED IL:TABLE))) (SETF (AREF IL:THIS-VEC IL:I) (IL:\\ATOMPNAMEINDEX SYMBOL)) (SETF (AREF IL:THIS-HASH IL:I) (IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH))))))))) (DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE IL:HASH-TABLE-HASH) &BODY IL:FORMS) "Find where the symbol named String is stored in Table. Index-Var is bound to the index, or NIL if it is not present. Symbol-Var is bound to the symbol. Length and Hash are the length and sxhash of String. Entry-Hash is the entry-hash of the string and length." (LET ((IL:VEC (OR IL:HASH-TABLE-TABLE (IL:GENSYM))) (IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM))) (IL:LEN (IL:GENSYM)) (IL:H2 (IL:GENSYM)) (IL:EHASH (IL:GENSYM)) (IL:VECS (IL:GENSYM)) (IL:HASHS (IL:GENSYM)) (IL:LIMIT (IL:GENSYM))) `(LET* ((,IL:VECS (PACKAGE-HASHTABLE-TABLE ,IL:TABLE)) (,IL:HASHS (PACKAGE-HASHTABLE-HASH ,IL:TABLE)) (,IL:LEN (ARRAY-TOTAL-SIZE (CAR ,IL:VECS))) (,IL:H2 (IL:REHASH-FACTOR ,SXHASH ,IL:LEN)) ,IL:VEC ,IL:HASH ,IL:LIMIT) (DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) ,IL:HASH) (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32)) ,IL:VEC)) (PROG (,IL:INDEX-VAR ,IL:SYMBOL-VAR ,IL:EHASH) (IL:* IL:|;;| "Loop thru all the hash tables looking for the symbol.") IL:OUTER-LOOP (IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS)) (IL:* IL:\; "Hashvalues") (IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector") (IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN)) (IL:* IL:\; "Starting probe.") (IL:SETQ ,IL:LIMIT ,IL:LEN) LOOP (IL:* IL:|;;| "Loop thru the entries in a single hash table.") (IL:SETQ ,IL:EHASH (AREF ,IL:HASH ,IL:INDEX-VAR)) (COND ((EQL ,IL:EHASH ,IL:ENTRY-HASH) (IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.") (IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC ,IL:INDEX-VAR))) (WHEN (IL:\\SYMBOL-EQUALBASE ,IL:SYMBOL-VAR ,IL:BASE ,IL:OFFSET ,IL:LENGTH ,IL:FATP) (GO IL:DOIT))) ((EQL 0 ,IL:EHASH) (IL:* IL:\;  "Found an empty hash slot, so it's not in this table.") (COND ((NULL ,IL:HASHS) (IL:* IL:|;;|  "we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.") (IL:SETQ ,IL:INDEX-VAR NIL) (GO IL:DOIT)) (T (GO IL:OUTER-LOOP)))) ((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT))) (IL:* IL:\;  "We.ve been thru the whole table, so it's not in this table.") (COND ((NULL ,IL:HASHS) (IL:* IL:|;;|  "we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.") (IL:SETQ ,IL:INDEX-VAR NIL) (GO IL:DOIT)) (T (GO IL:OUTER-LOOP))))) (IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2 ,IL:LEN)) (GO LOOP) IL:DOIT (RETURN (PROGN ,@IL:FORMS)))))) (DEFUN IL:INTERN* (IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:FATCHARSEENP PACKAGE IL:EXTERNALP) "If the symbol doesn't exist then create it, special-casing the keyword package." (DECLARE (SPECIAL IL:*KEYWORD-PACKAGE*)) (MULTIPLE-VALUE-BIND (SYMBOL IL:WHERE) (IL:FIND-SYMBOL* IL:BASE IL:OFFSET IL:LENGTH IL:FATP PACKAGE) (IF IL:WHERE (VALUES SYMBOL IL:WHERE) (LET ((SYMBOL (IL:UNINTERRUPTABLY (IL:\\CREATE.SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:FATCHARSEENP)))) (SETF (SYMBOL-PACKAGE SYMBOL) PACKAGE) (COND ((EQ PACKAGE IL:*KEYWORD-PACKAGE*) (IL:ADD-SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS IL:*KEYWORD-PACKAGE*) SYMBOL) (SET SYMBOL SYMBOL)) ((OR IL:EXTERNALP (%PACKAGE-EXTERNAL-ONLY PACKAGE)) (IL:ADD-SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) SYMBOL)) (T (IL:ADD-SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) SYMBOL))) (VALUES SYMBOL NIL))))) (DEFUN IL:FIND-SYMBOL* (IL:BASE IL:OFFSET IL:LENGTH IL:FATP PACKAGE) "Check internal and external symbols, then scan down the list of hashtables for inherited symbols. When an inherited symbol is found pull that table to the beginning of the list." (IL:* IL:|;;| "Find a symbol in the package given, if it eexists.") (LET* ((IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP)) (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)) (IL:RESULT (IL:\\CREATECELL IL:\\FIXP)) IL:SYM IL:WHERE (IL:DONE)) (UNLESS (%PACKAGE-EXTERNAL-ONLY PACKAGE) (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6) IL:BASE IL:OFFSET IL:LENGTH IL:FATP (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) IL:RESULT)) (COND ((NOT (IL:IEQP IL:RESULT -1)) (IL:SETQ IL:WHERE :INTERNAL) (IL:SETQ IL:DONE T)))) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL) (WHEN IL:FOUND (IL:* IL:|;;|  "Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))") (IL:SETQ IL:WHERE :INTERNAL) (IL:SETQ IL:DONE T))))) (UNLESS IL:DONE (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6) IL:BASE IL:OFFSET IL:LENGTH IL:FATP (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) IL:RESULT)) (COND ((NOT (IL:IEQP IL:RESULT -1)) (IL:SETQ IL:WHERE :EXTERNAL) (IL:SETQ IL:DONE T)))) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL) (WHEN IL:FOUND (IL:* IL:|;;|  "Was (cl:return-from find-symbol* (cl:values cl:symbol :external))") (IL:SETQ IL:SYM SYMBOL) (IL:SETQ IL:WHERE :EXTERNAL) (IL:SETQ IL:DONE T))))) (UNLESS IL:DONE (LET ((IL:HEAD (%PACKAGE-TABLES PACKAGE))) (DO ((IL:PREV IL:HEAD IL:TABLE) (IL:TABLE (CDR IL:HEAD) (CDR IL:TABLE))) ((OR IL:DONE (NULL IL:TABLE)) (VALUES NIL NIL)) (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6) IL:BASE IL:OFFSET IL:LENGTH IL:FATP (CAR IL:TABLE) IL:RESULT)) (COND ((NOT (IL:IEQP IL:RESULT -1)) (UNLESS (EQ IL:PREV IL:HEAD) (SHIFTF (CDR IL:PREV) (CDR IL:TABLE) (CDR IL:HEAD) IL:TABLE)) (IL:* IL:|;;|  "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))") (IL:SETQ IL:WHERE :INHERITED) (IL:SETQ IL:DONE T)))) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL) (WHEN IL:FOUND (UNLESS (EQ IL:PREV IL:HEAD) (SHIFTF (CDR IL:PREV) (CDR IL:TABLE) (CDR IL:HEAD) IL:TABLE)) (IL:* IL:|;;|  "Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))") (IL:SETQ IL:SYM SYMBOL) (IL:SETQ IL:WHERE :INHERITED) (IL:SETQ IL:DONE T))))))) (VALUES IL:SYM IL:WHERE))) (DEFUN INTERN (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*)) "Intern the name in the package, returning a symbol." (DECLARE (SPECIAL *PACKAGE*)) (IL:SETQ IL:NAME (COND ((IL:STRINGP IL:NAME) IL:NAME) ((STRINGP IL:NAME) (IL:MKSTRING IL:NAME)) (T (IL:ERROR "Not a string " IL:NAME)))) (COND ((NULL PACKAGE) (IL:* IL:\;  "XCL extension, makes uninterned symbols") (MAKE-SYMBOL IL:NAME)) (T (IL:* IL:\;  "Package is at least non-null") (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME)) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME))) (IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFSET IL:LENGTH IL:FATP) PACKAGE NIL))))) (DEFUN FIND-SYMBOL (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*)) "Find a symbol with the given name in a package." (DECLARE (SPECIAL *PACKAGE*)) (IL:SETQ IL:NAME (IL:\\SIMPLE-STRINGIFY IL:NAME)) (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)) (IL:FIND-SYMBOL* (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME) (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME) (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME) (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME) PACKAGE)) (IL:* IL:|;;| "Removing symbols from packages") (DEFUN IL:NUKE-SYMBOL (IL:TABLE STRING) "Mark a symbol in a package-hashtable deleted" (IL:SETQ STRING (IL:MKSTRING STRING)) (LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING)) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING)) (IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP)) (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH))) (IL:WITH-SYMBOL (IL:INDEX SYMBOL IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL IL:TABLE-HASH) (SETF (AREF IL:TABLE-HASH IL:INDEX) 1) (INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE))))) (DEFUN UNINTERN (SYMBOL &OPTIONAL (PACKAGE *PACKAGE*)) "Remove a symbol from a package. If uninterning a shadowing symbol, then a name conflict can result, otherwise just nuke the symbol." (DECLARE (SPECIAL *PACKAGE*)) (IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE)) (LET* ((IL:NAME (SYMBOL-NAME SYMBOL)) (IL:SHADOWING-SYMBOLS (%PACKAGE-SHADOWING-SYMBOLS PACKAGE))) (DECLARE (TYPE LIST IL:SHADOWING-SYMBOLS) (SPECIAL *QUERY-IO*)) (WHEN (IL:FMEMB SYMBOL IL:SHADOWING-SYMBOLS) (LET ((IL:CSET NIL)) (IL:* IL:|;;| "If a name conflict is revealed, give the user a chance to shadowing-import one of the available symbols.") (DOLIST (IL:P (%PACKAGE-USE-LIST PACKAGE)) (MULTIPLE-VALUE-BIND (IL:S IL:W) (IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P) (WHEN IL:W (PUSHNEW IL:S IL:CSET)))) (WHEN (CDR IL:CSET) (IL:* IL:\;  "If there is more than one, handle the conflict") (IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE))) (SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE) (DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ))) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL IL:NAME PACKAGE) (COND ((AND (EQ IL:S SYMBOL) (OR (EQ IL:W :INTERNAL) (EQ IL:W :EXTERNAL))) (IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL) (%PACKAGE-INTERNAL-SYMBOLS PACKAGE) (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)) IL:NAME) (IF (EQ (SYMBOL-PACKAGE SYMBOL) PACKAGE) (SETF (SYMBOL-PACKAGE SYMBOL) NIL)) T) (T NIL))))) (DEFUN IL:MOBY-UNINTERN (SYMBOL PACKAGE) "Like Unintern, but if symbol is inherited chases down the package it is inherited from and uninterns it there. Used for name-conflict resolution. Shadowing symbols are not uninterned since they do not cause conflicts." (UNLESS (IL:FMEMB SYMBOL (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)) (OR (UNINTERN SYMBOL PACKAGE) (LET ((IL:NAME (SYMBOL-NAME SYMBOL))) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL IL:NAME PACKAGE) (WHEN (EQ IL:W :INHERITED) (DOLIST (IL:Q (%PACKAGE-USE-LIST PACKAGE)) (MULTIPLE-VALUE-BIND (IL:U IL:X) (IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:Q) (WHEN IL:X (UNINTERN SYMBOL IL:Q) (IL:RETFROM 'IL:MOBY-UNINTERN T) (IL:* IL:|;;| "Was (cl:return-from moby-unintern t)") ))))))))) (IL:* IL:|;;| "Iterations over package symbols") (DEFUN IL:\\INDEXATOMPNAME (IL:X) (IL:\\INDEXATOMPNAME IL:X)) (IL:* IL:\; "Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro") (IL:DECLARE\: IL:EVAL@COMPILE (DEFUN IL:MAKE-DO-SYMBOLS-VARS () `(,(IL:GENSYM) ,(IL:GENSYM) ,(IL:GENSYM) ,(IL:GENSYM) ,(IL:GENSYM) ,(IL:GENSYM))) (DEFUN IL:MAKE-DO-SYMBOLS-CODE (IL:VARS IL:VAR HASH-TABLE IL:EXIT-FORM IL:FORMS) (LET ((IL:INDEX (FIRST IL:VARS)) (IL:HASH-VECTOR (SECOND IL:VARS)) (IL:HASH (THIRD IL:VARS)) (IL:TERMINUS (FOURTH IL:VARS)) (IL:HASH-VECTOR-LIST (FIFTH IL:VARS)) (IL:TABLE-VECTOR-LIST (SIXTH IL:VARS)) (IL:TOP (IL:GENSYM)) (IL:REAL-TOP (IL:GENSYM))) `((IL:SETQ ,IL:TABLE-VECTOR-LIST (PACKAGE-HASHTABLE-TABLE ,HASH-TABLE)) (IL:SETQ ,IL:HASH-VECTOR-LIST (PACKAGE-HASHTABLE-HASH ,HASH-TABLE)) ,IL:REAL-TOP (IL:SETQ ,IL:INDEX 0) (IL:SETQ ,IL:HASH-VECTOR (IL:POP ,IL:TABLE-VECTOR-LIST)) (IL:SETQ ,IL:HASH (IL:POP ,IL:HASH-VECTOR-LIST)) (IL:SETQ ,IL:TERMINUS (ARRAY-TOTAL-SIZE (THE (SIMPLE-ARRAY (UNSIGNED-BYTE 32)) ,IL:HASH-VECTOR))) ,IL:TOP (IF (EQL ,IL:INDEX ,IL:TERMINUS) (IF (NULL ,IL:TABLE-VECTOR-LIST) ,IL:EXIT-FORM (GO ,IL:REAL-TOP))) (WHEN (IL:IGREATERP (AREF (THE (SIMPLE-ARRAY (UNSIGNED-BYTE 8)) ,IL:HASH) ,IL:INDEX) 1) (IL:SETQ ,IL:VAR (IL:\\INDEXATOMPNAME (AREF ,IL:HASH-VECTOR ,IL:INDEX))) ,@IL:FORMS) (INCF ,IL:INDEX) (GO ,IL:TOP)))) ) (DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) IL:RESULT-FORM) &BODY (IL:CODE IL:DECLS)) "Do-External-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each external symbol in the given Package with Var bound to the current symbol." (LET ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))) `(PROG (,IL:VAR ,@IL:VARS) ,@IL:DECLS ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE) `(RETURN (PROGN (IL:SETQ ,IL:VAR NIL) ,IL:RESULT-FORM)) IL:CODE)))) (DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) IL:RESULT-FORM) &BODY (IL:CODE IL:DECLS)) "Do-Local-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package with Var bound to the current symbol." (LET* ((IL:DONE-INTERNAL (IL:GENSYM)) (IL:DONE-EXTERNAL (IL:GENSYM)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:N-PACKAGE (IL:GENSYM))) `(PROG* ((,IL:N-PACKAGE ,PACKAGE) ,IL:VAR ,@IL:VARS) ,@IL:DECLS (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (GO ,IL:DONE-INTERNAL)) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE) `(GO ,IL:DONE-INTERNAL) IL:CODE) ,IL:DONE-INTERNAL ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE) `(GO ,IL:DONE-EXTERNAL) IL:CODE) ,IL:DONE-EXTERNAL (IL:SETQ ,IL:VAR NIL) (RETURN ,IL:RESULT-FORM)))) (DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) IL:RESULT-FORM) &BODY (IL:CODE IL:DECLS)) "Do-Internal-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package and not exported with Var bound to the current symbol." (LET* ((IL:DONE-INTERNAL (IL:GENSYM)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:N-PACKAGE (IL:GENSYM))) `(PROG* ((,IL:N-PACKAGE ,PACKAGE) ,IL:VAR ,@IL:VARS) ,@IL:DECLS (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (GO ,IL:DONE-INTERNAL)) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE) `(GO ,IL:DONE-INTERNAL) IL:CODE) ,IL:DONE-INTERNAL (IL:SETQ ,IL:VAR NIL) (RETURN ,IL:RESULT-FORM)))) (DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*) IL:RESULT-FORM) &BODY (IL:CODE IL:DECLS)) "Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol accessible in the given Package with Var bound to the current symbol." (LET* ((IL:DONE-INTERNAL (IL:GENSYM)) (IL:DONE-EXTERNAL (IL:GENSYM)) (IL:NEXT-INHERIT (IL:GENSYM)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:N-PACKAGE (IL:GENSYM)) (IL:SHADOWED (IL:GENSYM)) (IL:INHERITS (IL:GENSYM)) (IL:THIS-INHERIT (IL:GENSYM))) `(PROG* ((,IL:N-PACKAGE ,PACKAGE) (,IL:SHADOWED (%PACKAGE-SHADOWING-SYMBOLS ,IL:N-PACKAGE)) (,IL:INHERITS (CDR (%PACKAGE-TABLES ,IL:N-PACKAGE))) ,IL:VAR ,@IL:VARS ,IL:THIS-INHERIT) ,@IL:DECLS (WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE) (GO ,IL:DONE-INTERNAL)) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE) `(GO ,IL:DONE-INTERNAL) IL:CODE) ,IL:DONE-INTERNAL ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE) `(GO ,IL:DONE-EXTERNAL) IL:CODE) ,IL:DONE-EXTERNAL ,IL:NEXT-INHERIT (WHEN (NULL ,IL:INHERITS) (IL:SETQ ,IL:VAR NIL) (RETURN ,IL:RESULT-FORM)) (IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS)) ,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR IL:THIS-INHERIT `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS)) (GO ,IL:NEXT-INHERIT)) `((WHEN (OR (NOT ,IL:SHADOWED) (EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR) ,IL:N-PACKAGE) ,IL:VAR)) ,@IL:CODE)))))) (DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM) &BODY (IL:CODE IL:DECLS)) "Do-All-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each symbol in each package with Var bound to the current symbol." (LET* ((IL:PACKAGE-LOOP (IL:GENSYM)) (IL:TAG (IL:GENSYM)) (IL:PACKAGE-LIST (IL:GENSYM)) (IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)) (IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST)) `(GO ,IL:TAG) IL:CODE)) (IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS (CAR ,IL:PACKAGE-LIST)) `(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST)) (GO ,IL:PACKAGE-LOOP)) IL:CODE))) `(PROG (,IL:PACKAGE-LIST ,IL:VAR ,@IL:VARS) ,@IL:DECLS (IL:SETQ ,IL:PACKAGE-LIST (LIST-ALL-PACKAGES)) ,IL:PACKAGE-LOOP (WHEN (NULL ,IL:PACKAGE-LIST) (IL:SETQ ,IL:VAR NIL) (RETURN ,IL:RESULT-FORM)) (WHEN (%PACKAGE-EXTERNAL-ONLY (CAR ,IL:PACKAGE-LIST)) (GO ,IL:TAG)) ,@IL:INTERNAL-CODE ,IL:TAG ,@IL:EXTERNAL-CODE))) (IL:* IL:|;;| "Finding symbols in a package or packages") (DEFUN FIND-ALL-SYMBOLS (IL:STRING-OR-SYMBOL) "Find every symbol in all packages with the given name." (LET ((STRING (IL:MKSTRING IL:STRING-OR-SYMBOL)) (IL:RES NIL)) (DECLARE (SPECIAL IL:*PACKAGE-FROM-NAME*)) (MAPHASH #'(LAMBDA (IL:K IL:V) (MULTIPLE-VALUE-BIND (IL:S IL:W) (FIND-SYMBOL STRING IL:V) (WHEN IL:W (PUSHNEW IL:S IL:RES)))) IL:*PACKAGE-FROM-NAME*) IL:RES)) (DEFUN IL:BRIEFLY-DESCRIBE-SYMBOL (SYMBOL) "Short form description of a symbol." (FRESH-LINE) (PRIN1 SYMBOL) (WHEN (BOUNDP SYMBOL) (WRITE-STRING ", value: ") (PRIN1 (SYMBOL-VALUE SYMBOL))) (IF (FBOUNDP SYMBOL) (WRITE-STRING " (defined)"))) (DEFUN APROPOS (STRING &OPTIONAL PACKAGE IL:EXTERNAL-ONLY) "Find all symbols matching the string pattern in the given (or current) package. The search can be limited to external symbols only. Prints a short description of each found symbols." (IL:SETQ STRING (IL:COPY-STRING (IL:\\SIMPLE-STRINGIFY STRING))) (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING)) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING))) (IL:\\UPCASEBASE IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IF (NULL PACKAGE) (DO-ALL-SYMBOLS (SYMBOL) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL))) (LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE))) (IF IL:EXTERNAL-ONLY (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL))) (DO-SYMBOLS (SYMBOL PACKAGE) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IL:BRIEFLY-DESCRIBE-SYMBOL SYMBOL))))))) (VALUES)) (DEFUN APROPOS-LIST (STRING &OPTIONAL PACKAGE IL:EXTERNAL-ONLY) "Find all symbols matching the string pattern in the given (or current) package. The search can be limited to external symbols only. Returns a list of the matching symbols." (LET ((STRING (IL:COPY-STRING (IL:\\SIMPLE-STRINGIFY (IL:MKSTRING STRING)))) (LIST 'NIL)) (LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING)) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING))) (IL:\\UPCASEBASE IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (IF (NULL PACKAGE) (DO-ALL-SYMBOLS (SYMBOL) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (PUSH SYMBOL LIST))) (LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE))) (IF IL:EXTERNAL-ONLY (DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (PUSH SYMBOL LIST))) (DO-SYMBOLS (SYMBOL PACKAGE) (IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP) (PUSH SYMBOL LIST))))))) LIST)) (IL:* IL:|;;| "Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)") (DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE) (IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\;  "Convert symbols to strings (for the reader)") (LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING)) (IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING)) (IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING)) (IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| STRING)) (IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP)) (IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)) (IL:RESULT (IL:\\CREATECELL IL:\\FIXP)) IL:SYM) (IL:NEW-SYMBOL-CODE (PROGN (IL:SETQ IL:SYM ((IL:OPCODES IL:SUBRCALL 145 6) IL:BASE IL:OFFSET IL:LENGTH IL:FATP ( %PACKAGE-EXTERNAL-SYMBOLS PACKAGE) IL:RESULT)) (VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1)))) (IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE) IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL) (VALUES SYMBOL IL:FOUND))))) (DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE) "True if name of SYMBOL when looked up in PACKAGE is found and is exactly SYMBOL" (MULTIPLE-VALUE-BIND (IL:FOUNDSYM IL:WHERE) (IL:FIND-SYMBOL* (IL:|ffetch| (SYMBOL IL:PNAMEBASE) IL:|of| SYMBOL) 1 (IL:|ffetch| (SYMBOL IL:PNAMELENGTH) IL:|of| SYMBOL) (IL:|ffetch| (SYMBOL IL:FATPNAMEP) IL:|of| SYMBOL) PACKAGE) (AND IL:WHERE (EQ IL:FOUNDSYM SYMBOL)))) (DEFUN IL:PACKAGE-NAME-AS-SYMBOL (PACKAGE) (%PACKAGE-NAMESYMBOL PACKAGE)) (DEFUN IL:\\FIND.PACKAGE.INTERNAL (IL:BASE IL:OFFSET IL:LEN IL:FATP) (FIND-PACKAGE (IL:\\GETBASESTRING IL:BASE IL:OFFSET IL:LEN IL:FATP))) (IL:* IL:|;;| "Proper compiler, readtable and package environment") (IL:PUTPROPS IL:LLPACKAGE IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:LLPACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA XCL:DEFPACKAGE) (IL:ADDTOVAR IL:NLAML ) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (25052 28345 (XCL:DEFPACKAGE 25065 . 28343))))) IL:STOP \ No newline at end of file diff --git a/sources/LLPARAMS b/sources/LLPARAMS new file mode 100644 index 00000000..3326f475 --- /dev/null +++ b/sources/LLPARAMS @@ -0,0 +1,1705 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8) +(FILECREATED "31-Jan-98 09:16:51" {DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;15 232505Q + + changes to%: (VARS INITCONSTANTS) + + previous date%: "30-Jan-98 12:43:29" +{DSK}disk2>jdstools>lc3>lispcore3.0>sources>LLPARAMS.;14) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1994, 1998 by Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets. All rights reserved. +") + +(PRETTYCOMPRINT LLPARAMSCOMS) + +(RPAQQ LLPARAMSCOMS ( + (* ;; + "This file defines the constants that control how a SYSOUT is laid out.") + + (FNS MAKERECORD) + + (* ;; "When you change the SYSOUT's layout in this file, you must also") + + + (* ;; " Recreate RDSYS in the library, using (DORENAME 'R)") + + + (* ;; + " Recompile DLFIXINIT and anything else that uses the constants defined here.") + + + (* ;; " Recompile LLFAULT. recompile VMEM") + + (DECLARE%: DONTCOPY + (EXPORT (CONSTANTS (WINDFLG T)) + + (* ;; + "INITCONSTANTS are constants (e.g. \LISTPDTD) to be defined at init time.") + + (VARS INITCONSTANTS MISCSTATSLAYOUT IFPAGELAYOUT + MAIKO.IFPAGELAYOUT IOPAGELAYOUT) + [CONSTANTS * (for X in INITCONSTANTS when (FIXP (CADR X)) + collect + (LIST (CAR X) + (CADR X] + (CONSTANTS * \MPERRORS) + (GLOBALVARS * (for X in INITCONSTANTS when + [AND (NEQ (CAR X) + '*) + (NOT (FIXP (CADR X] + collect + (CAR X))) + (P * (LIST (MAKERECORD 'MISCSTATS MISCSTATSLAYOUT) + (COND ((EQ \MACHINETYPE \MAIKO) + (MAKERECORD 'IFPAGE MAIKO.IFPAGELAYOUT)) + (T (MAKERECORD 'IFPAGE IFPAGELAYOUT))) + (MAKERECORD 'IOPAGE IOPAGELAYOUT))) + (MACROS EMADDRESS EMGETBASE EMPUTBASE EMULATORSEGMENT + EMPOINTER EMADDRESSP))) + (PROP MAKEFILE-ENVIRONMENT LLPARAMS))) + + + +(* ;; "This file defines the constants that control how a SYSOUT is laid out.") + +(DEFINEQ + +(MAKERECORD [LAMBDA (NAME LAYOUT) (* bvm%: "29-NOV-82 17:40") (PROG ((I 0) PTRS M NAM) (RETURN `(BLOCKRECORD %, NAME %, [for X in LAYOUT collect (CONS (SETQ NAM (CAR X)) (COND ((EQ NAM '*) (CDR X)) (T (PROG1 [COND [[FIXP (SETQ M (CAR (SETQ X (CDR X] (LIST M (CAR (SETQ X (CDR X] (T (SETQ M (SELECTQ (CAR X) ((FIXP FULLXPOINTER) (OR (EVENP I WORDSPERCELL) (ERROR "Record field not aligned" (CONS NAM X))) 2) (WORD 1) (SHOULDNT))) (LIST (CAR X] [COND ((CADDR X) (SETQ PTRS (CONS (LIST (PACK* NAM 'PTR) `(\ADDBASE DATUM %, I)) PTRS] (add I M))] %,. [AND PTRS `((ACCESSFNS %, NAME %, PTRS] (CREATE (\ALLOCBLOCK %, (FOLDHI I WORDSPERCELL]) +) + + + +(* ;; "When you change the SYSOUT's layout in this file, you must also") + + + + +(* ;; " Recreate RDSYS in the library, using (DORENAME 'R)") + + + + +(* ;; " Recompile DLFIXINIT and anything else that uses the constants defined here.") + + + + +(* ;; " Recompile LLFAULT. recompile VMEM") + +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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 10Q) + (\CHARACTERP 11Q) + (\VMEMPAGEP 12Q NIL VMemPagePType) + (\STREAM 13Q NIL STREAMTYPE) + + (* ;; "TYPE TABLE CONSTANTS - - - - - - - - - - - - - - - - - - - - - -") + + (\TT.TYPEMASK 3777Q TTTypeMask T) + (\TT.NOREF 100000Q NIL T) + (\TT.SYMBOLP 40000Q NIL T) + (\TT.FIXP 20000Q) + (\TT.NUMBERP 10000Q) + (\TT.ATOM 4000Q) + + (* ;; + "page map - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -") + + (\PMblockSize 40Q PMBLOCKSIZE) + (\STATSsize 10Q T) + (\NumPMTpages 10Q) + (\EmptyPMTEntry 177777Q T) + (\FirstVmemBlock 2 T) + (\MAXVMPAGE 377775Q) + (\MAXVMSEGMENT 377Q) + + (* ;; "interface page") + + (\IFPValidKey 12743Q T) + + (* ;; "MDS") + + (\FirstMDSPage 37776Q) + (\MaxMDSPage 1777775Q) + (\DefaultSecondMDSPage 177774Q) + (\MDSIncrement 1000Q) + (\PagesPerMDSUnit 2) + (* ; + "(FOLDLO \MDSIncrement WORDSPERPAGE)") + + (* ;; "arrays") + + (\ARRAYSPACE (56Q 0)) + (\FirstArraySegment 56Q) + (\FirstArrayPage 27000Q) + (\ARRAYSPACE2 (100Q 0)) + (\DefaultSecondArrayPage 40000Q) + + (* ;; "stack block constants") + + (\StackMask 160000Q T T) + (\FxtnBlock 140000Q T T) + (\GuardBlock 160000Q T T) + (\BFBlock 100000Q T T) + (\FreeStackBlock 120000Q T T) + (\NotStackBlock 0) + (* ; "none of the above") + (\MinExtraStackWords 40Q T T) + + (* ;; "backspace kludge") + + (ERASECHARCODE 0 T) + + (* ;; "GC constants") + + (\HT1CNT 2000Q NIL T) + (\HTSTKBIT 1000Q NIL T) + (\HTCNTMASK 176000Q NIL T) + (\HTMAINSIZE 200000Q NIL T) + (\HTCOLLSIZE 4000000Q 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 (25Q 0) + (AHTspace AHTbase)) + (\AtomHTpages 400Q AHTSIZE) + (\LastAtomPage 377Q) + (\MaxAtomFrLst 177777Q) + (\SMALLPOSPSPACE (16Q 0)) + (\SmallPosHi 16Q SMALLPOSspace smallpl) + (\SMALLNEGSPACE (17Q 0)) + (\SmallNegHi 17Q SMALLNEGspace smallneg) + (\NumSmallPages 1000Q) + + (* ;; "PNAME SPACEin the old world; used for initial atoms now.") + + (\PNPSPACE (10Q 0) + (PNPspace PNPbase)) + (\PNAME.HI 10Q) + (\OLDATOMSPACE (54Q 0)) + (* ; "NEW ATOM SPACE") + (\ATOM.HI 54Q) + (* ; "HI PART OF NEW ATOM SPACE") + + (* ;; "Definitions in old atom world") + + (\DEFSPACE (12Q 0) + (DEFspace DEFbase) + (DEFspace DEFbase)) + (\DEF.HI 12Q) + (\VALSPACE (14Q 0) + (TOPVALspace TOPVALbase) + (VALspace VALbase)) + (\VAL.HI 14Q) + (\PLISTSPACE (2 0) + (PLISTspace PLISTbase)) + (\PLIST.HI 2) + (\PAGEMAP (5 0) + (PAGEMAPspace PAGEMAPbase)) + (\NumPageMapPages 400Q) + (\PageMapTBL (24Q 1000Q) + (PMTspace PMTbase)) + (\InterfacePage (24Q 0) + (INTERFACEspace INTERFACEbase) + (INTERFACEspace INTERFACEbase)) + (\IOPAGE (0 177400Q)) + (\DoveIORegion (0 40000Q)) + (\IOCBPAGE (0 400Q)) + (\FPTOVP (2 0)) + (\MDSTypeTable (30Q 0) + (MDSTYPEspace MDSTYPEbase) + (MDSTYPEspace MDSTYPEbase)) + (\MDSTTsize 2000Q T) + (* ; "in Pages") + (\MISCSTATS (24Q 5000Q) + (STATSspace MISCSTATSbase)) + (\UFNTable (24Q 6000Q) + NIL + (STATSspace UFNTablebase)) + (\UFNTableSize 2) + (\DTDSpaceBase (24Q 10000Q) + (DTDspace DTDbase) + (DTDspace DTDbase)) + (\DTDSize 22Q T) + (\LISTPDTD (24Q 10132Q)) + (\EndTypeNumber 3777Q) + (\LOCKEDPAGETABLE (24Q 70000Q)) + (\NumLPTPages 20Q) + (\STACKSPACE (1 0) + (STACKspace NIL) + (STACKspace NIL)) + (\GuardStackAddr 170000Q) + (\LastStackAddr 177776Q) + (\STACKHI 1 T T) + (\HTMAIN (26Q 0) + (HTMAINspace HTMAINbase) + (HTMAINspace HTMAINbase)) + (\HTMAINnpages 400Q T) + (\HTOVERFLOW (27Q 0) + NIL + (NIL HTOVERFLOWbase)) + (\HTBIGCOUNT (27Q 100000Q)) + (\HTCOLL (34Q 0) + NIL + (HTCOLLspace HTCOLLbase)) + (\DISPLAYREGION (22Q 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 16Q T T) + (\TeleRaidFXP 30Q T T) + + (* ;; "emulator segment locations") + + (DCB.EM 420Q) + (DISPINTERRUPT.EM 421Q) + (CURSORBITMAP.EM 431Q) + (KBDAD0.EM 177034Q) + (KBDAD1.EM 177035Q) + (KBDAD2.EM 177036Q) + (KBDAD3.EM 177037Q) + (UTILIN.EM 177030Q) + (CURSORX.EM 426Q) + (CURSORY.EM 427Q) + (MOUSEX.EM 424Q) + (MOUSEY.EM 425Q) + (\LispKeyMask 20000Q T T) + (\BcplKeyMask 10400Q T T) + (* ; "Machine types") + (\MAIKO 3) + (\DOLPHIN 4) + (\DORADO 5) + (\DANDELION 6) + (\DAYBREAK 10Q) + + (* ;; "FOR DLION (AND DAYBREAK)") + + (\VP.DISPLAY 11000Q) + (\NP.DISPLAY 312Q) + (* ; + "for Dorado display 1024x808 pixels / (16 pixels/word x 256 words/page)") + (\NP.WIDEDOVEDISPLAY 363Q) + (* ; + "Wide Dove display 1152x864 pixels") + (\WIDEDOVEDISPLAYWIDTH 2200Q) + (\RP.AFTERDISPLAY 316Q) + (* ; "Includes 4 pages for cursor") + (\RP.AFTERDOVEDISPLAY 363Q) + (* ; "if big screen") + (\RP.DISPLAY 0) + (\RP.TEMPDISPLAY 5001Q) + (\RP.MISCLOCKED 5364Q) + (* ; + "(+ \RP.TEMPDISPLAY \NP.WIDEDOVEDISPLAY)") + (\RP.STACK 1400Q) + (\VP.STACK 400Q) + (\RP.MAP 400Q) + (\NP.MAP 400Q) + (\RP.IOPAGE 1000Q) + (* ; + "The DOVE IOCBPAGE can go anywhere, but should be under the 1mbyte range") + (\RP.DOVEIOCBPAGE 1037Q) + (\RP.DOVEIORGN 1040Q) + (\VP.DOVEIORGN 100Q) + (\DOVEIORGNSIZE 100Q) + (\VP.IOPAGE 377Q) + (\VP.IFPAGE 12000Q) + (\VP.FPTOVP 1000Q) + (\NP.FPTOVP 10000Q) + (\RP.FPTOVP 2000Q) + (\RP.STARTBUFFERS 1200Q) + (\VP.TYPETABLE 14000Q) + (\NP.TYPETABLE 2000Q) + (\RP.TYPETABLE 12000Q) + (\VP.GCTABLE 13000Q) + (\NP.GCTABLE 400Q) + (\RP.GCTABLE 14000Q) + (\VP.GCOVERFLOW 13400Q) + (\NP.GCOVERFLOW 1) + (\RP.GCOVERFLOW 14400Q) + (\FP.IFPAGE 2) + (\VP.IOCBS 1) + (\VP.PRIMARYMAP 12002Q) + (\VP.SECONDARYMAP 2400Q) + (\VP.LPT 12160Q) + (\VP.INITSCRATCH 10Q) + (\VP.RPT 200Q) + (\VP.BUFFERS 332Q) + (* ; "DLion processor commands") + (\DL.PROCESSORBUSY 100000Q) + (\DL.SETTOD 100001Q) + (\DL.READTOD 100002Q) + (\DL.READPID 100003Q) + (\DL.BOOTBUTTON 100004Q))) + +(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 22Q 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 40Q WORD) + (DLIOPHARDWARECONFIG WORD) + (NIL 13Q WORD) + (DLRS232CPARAMETERCSBLO.11 WORD) + (DLRS232CPARAMETERCSBHI.11 WORD) + (DLRS232CSETRS366STATUS.11 16Q WORD) + (NIL 74Q WORD) + (DLMAGTAPE 4 WORD) + (DLETHERNET 14Q WORD NIL T) + (NIL 37Q WORD) + (DLDISPINTERRUPT WORD NIL T) + (DLDISPCONTROL WORD) + (DLDISPBORDER WORD) + (DLCURSORX WORD NIL T) + (DLCURSORY WORD NIL T) + (DLCURSORBITMAP 20Q WORD NIL T))) +(DECLARE%: EVAL@COMPILE + +(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 10Q) + +(RPAQQ \CHARACTERP 11Q) + +(RPAQQ \VMEMPAGEP 12Q) + +(RPAQQ \STREAM 13Q) + +(RPAQQ \TT.TYPEMASK 3777Q) + +(RPAQQ \TT.NOREF 100000Q) + +(RPAQQ \TT.SYMBOLP 40000Q) + +(RPAQQ \TT.FIXP 20000Q) + +(RPAQQ \TT.NUMBERP 10000Q) + +(RPAQQ \TT.ATOM 4000Q) + +(RPAQQ \PMblockSize 40Q) + +(RPAQQ \STATSsize 10Q) + +(RPAQQ \NumPMTpages 10Q) + +(RPAQQ \EmptyPMTEntry 177777Q) + +(RPAQQ \FirstVmemBlock 2) + +(RPAQQ \MAXVMPAGE 377775Q) + +(RPAQQ \MAXVMSEGMENT 377Q) + +(RPAQQ \IFPValidKey 12743Q) + +(RPAQQ \FirstMDSPage 37776Q) + +(RPAQQ \MaxMDSPage 1777775Q) + +(RPAQQ \DefaultSecondMDSPage 177774Q) + +(RPAQQ \MDSIncrement 1000Q) + +(RPAQQ \PagesPerMDSUnit 2) + +(RPAQQ \FirstArraySegment 56Q) + +(RPAQQ \FirstArrayPage 27000Q) + +(RPAQQ \DefaultSecondArrayPage 40000Q) + +(RPAQQ \StackMask 160000Q) + +(RPAQQ \FxtnBlock 140000Q) + +(RPAQQ \GuardBlock 160000Q) + +(RPAQQ \BFBlock 100000Q) + +(RPAQQ \FreeStackBlock 120000Q) + +(RPAQQ \NotStackBlock 0) + +(RPAQQ \MinExtraStackWords 40Q) + +(RPAQQ ERASECHARCODE 0) + +(RPAQQ \HT1CNT 2000Q) + +(RPAQQ \HTSTKBIT 1000Q) + +(RPAQQ \HTCNTMASK 176000Q) + +(RPAQQ \HTMAINSIZE 200000Q) + +(RPAQQ \HTCOLLSIZE 4000000Q) + +(RPAQQ \HTENDFREE 1) + +(RPAQQ \HTFREEPTR 0) + +(RPAQQ \AtomHI 0) + +(RPAQQ \CHARHI 7) + +(RPAQQ \AtomHTpages 400Q) + +(RPAQQ \LastAtomPage 377Q) + +(RPAQQ \MaxAtomFrLst 177777Q) + +(RPAQQ \SmallPosHi 16Q) + +(RPAQQ \SmallNegHi 17Q) + +(RPAQQ \NumSmallPages 1000Q) + +(RPAQQ \PNAME.HI 10Q) + +(RPAQQ \ATOM.HI 54Q) + +(RPAQQ \DEF.HI 12Q) + +(RPAQQ \VAL.HI 14Q) + +(RPAQQ \PLIST.HI 2) + +(RPAQQ \NumPageMapPages 400Q) + +(RPAQQ \MDSTTsize 2000Q) + +(RPAQQ \UFNTableSize 2) + +(RPAQQ \DTDSize 22Q) + +(RPAQQ \EndTypeNumber 3777Q) + +(RPAQQ \NumLPTPages 20Q) + +(RPAQQ \GuardStackAddr 170000Q) + +(RPAQQ \LastStackAddr 177776Q) + +(RPAQQ \STACKHI 1) + +(RPAQQ \HTMAINnpages 400Q) + +(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 16Q) + +(RPAQQ \TeleRaidFXP 30Q) + +(RPAQQ DCB.EM 420Q) + +(RPAQQ DISPINTERRUPT.EM 421Q) + +(RPAQQ CURSORBITMAP.EM 431Q) + +(RPAQQ KBDAD0.EM 177034Q) + +(RPAQQ KBDAD1.EM 177035Q) + +(RPAQQ KBDAD2.EM 177036Q) + +(RPAQQ KBDAD3.EM 177037Q) + +(RPAQQ UTILIN.EM 177030Q) + +(RPAQQ CURSORX.EM 426Q) + +(RPAQQ CURSORY.EM 427Q) + +(RPAQQ MOUSEX.EM 424Q) + +(RPAQQ MOUSEY.EM 425Q) + +(RPAQQ \LispKeyMask 20000Q) + +(RPAQQ \BcplKeyMask 10400Q) + +(RPAQQ \MAIKO 3) + +(RPAQQ \DOLPHIN 4) + +(RPAQQ \DORADO 5) + +(RPAQQ \DANDELION 6) + +(RPAQQ \DAYBREAK 10Q) + +(RPAQQ \VP.DISPLAY 11000Q) + +(RPAQQ \NP.DISPLAY 312Q) + +(RPAQQ \NP.WIDEDOVEDISPLAY 363Q) + +(RPAQQ \WIDEDOVEDISPLAYWIDTH 2200Q) + +(RPAQQ \RP.AFTERDISPLAY 316Q) + +(RPAQQ \RP.AFTERDOVEDISPLAY 363Q) + +(RPAQQ \RP.DISPLAY 0) + +(RPAQQ \RP.TEMPDISPLAY 5001Q) + +(RPAQQ \RP.MISCLOCKED 5364Q) + +(RPAQQ \RP.STACK 1400Q) + +(RPAQQ \VP.STACK 400Q) + +(RPAQQ \RP.MAP 400Q) + +(RPAQQ \NP.MAP 400Q) + +(RPAQQ \RP.IOPAGE 1000Q) + +(RPAQQ \RP.DOVEIOCBPAGE 1037Q) + +(RPAQQ \RP.DOVEIORGN 1040Q) + +(RPAQQ \VP.DOVEIORGN 100Q) + +(RPAQQ \DOVEIORGNSIZE 100Q) + +(RPAQQ \VP.IOPAGE 377Q) + +(RPAQQ \VP.IFPAGE 12000Q) + +(RPAQQ \VP.FPTOVP 1000Q) + +(RPAQQ \NP.FPTOVP 10000Q) + +(RPAQQ \RP.FPTOVP 2000Q) + +(RPAQQ \RP.STARTBUFFERS 1200Q) + +(RPAQQ \VP.TYPETABLE 14000Q) + +(RPAQQ \NP.TYPETABLE 2000Q) + +(RPAQQ \RP.TYPETABLE 12000Q) + +(RPAQQ \VP.GCTABLE 13000Q) + +(RPAQQ \NP.GCTABLE 400Q) + +(RPAQQ \RP.GCTABLE 14000Q) + +(RPAQQ \VP.GCOVERFLOW 13400Q) + +(RPAQQ \NP.GCOVERFLOW 1) + +(RPAQQ \RP.GCOVERFLOW 14400Q) + +(RPAQQ \FP.IFPAGE 2) + +(RPAQQ \VP.IOCBS 1) + +(RPAQQ \VP.PRIMARYMAP 12002Q) + +(RPAQQ \VP.SECONDARYMAP 2400Q) + +(RPAQQ \VP.LPT 12160Q) + +(RPAQQ \VP.INITSCRATCH 10Q) + +(RPAQQ \VP.RPT 200Q) + +(RPAQQ \VP.BUFFERS 332Q) + +(RPAQQ \DL.PROCESSORBUSY 100000Q) + +(RPAQQ \DL.SETTOD 100001Q) + +(RPAQQ \DL.READTOD 100002Q) + +(RPAQQ \DL.READPID 100003Q) + +(RPAQQ \DL.BOOTBUTTON 100004Q) + + +(CONSTANTS (CDRCODING 1) + (\SMALLP 1) + (\FIXP 2) + (\FLOATP 3) + (\LITATOM 4) + (\LISTP 5) + (\ARRAYP 6) + (\STRINGP 7) + (\STACKP 10Q) + (\CHARACTERP 11Q) + (\VMEMPAGEP 12Q) + (\STREAM 13Q) + (\TT.TYPEMASK 3777Q) + (\TT.NOREF 100000Q) + (\TT.SYMBOLP 40000Q) + (\TT.FIXP 20000Q) + (\TT.NUMBERP 10000Q) + (\TT.ATOM 4000Q) + (\PMblockSize 40Q) + (\STATSsize 10Q) + (\NumPMTpages 10Q) + (\EmptyPMTEntry 177777Q) + (\FirstVmemBlock 2) + (\MAXVMPAGE 377775Q) + (\MAXVMSEGMENT 377Q) + (\IFPValidKey 12743Q) + (\FirstMDSPage 37776Q) + (\MaxMDSPage 1777775Q) + (\DefaultSecondMDSPage 177774Q) + (\MDSIncrement 1000Q) + (\PagesPerMDSUnit 2) + (\FirstArraySegment 56Q) + (\FirstArrayPage 27000Q) + (\DefaultSecondArrayPage 40000Q) + (\StackMask 160000Q) + (\FxtnBlock 140000Q) + (\GuardBlock 160000Q) + (\BFBlock 100000Q) + (\FreeStackBlock 120000Q) + (\NotStackBlock 0) + (\MinExtraStackWords 40Q) + (ERASECHARCODE 0) + (\HT1CNT 2000Q) + (\HTSTKBIT 1000Q) + (\HTCNTMASK 176000Q) + (\HTMAINSIZE 200000Q) + (\HTCOLLSIZE 4000000Q) + (\HTENDFREE 1) + (\HTFREEPTR 0) + (\AtomHI 0) + (\CHARHI 7) + (\AtomHTpages 400Q) + (\LastAtomPage 377Q) + (\MaxAtomFrLst 177777Q) + (\SmallPosHi 16Q) + (\SmallNegHi 17Q) + (\NumSmallPages 1000Q) + (\PNAME.HI 10Q) + (\ATOM.HI 54Q) + (\DEF.HI 12Q) + (\VAL.HI 14Q) + (\PLIST.HI 2) + (\NumPageMapPages 400Q) + (\MDSTTsize 2000Q) + (\UFNTableSize 2) + (\DTDSize 22Q) + (\EndTypeNumber 3777Q) + (\NumLPTPages 20Q) + (\GuardStackAddr 170000Q) + (\LastStackAddr 177776Q) + (\STACKHI 1) + (\HTMAINnpages 400Q) + (\D1BCPLspace 0) + (\D0BCPLspace 0) + (\CurrentFXP 0) + (\ResetFXP 1) + (\SubovFXP 2) + (\KbdFXP 3) + (\HardReturnFXP 4) + (\GCFXP 5) + (\FAULTFXP 6) + (\MiscFXP 16Q) + (\TeleRaidFXP 30Q) + (DCB.EM 420Q) + (DISPINTERRUPT.EM 421Q) + (CURSORBITMAP.EM 431Q) + (KBDAD0.EM 177034Q) + (KBDAD1.EM 177035Q) + (KBDAD2.EM 177036Q) + (KBDAD3.EM 177037Q) + (UTILIN.EM 177030Q) + (CURSORX.EM 426Q) + (CURSORY.EM 427Q) + (MOUSEX.EM 424Q) + (MOUSEY.EM 425Q) + (\LispKeyMask 20000Q) + (\BcplKeyMask 10400Q) + (\MAIKO 3) + (\DOLPHIN 4) + (\DORADO 5) + (\DANDELION 6) + (\DAYBREAK 10Q) + (\VP.DISPLAY 11000Q) + (\NP.DISPLAY 312Q) + (\NP.WIDEDOVEDISPLAY 363Q) + (\WIDEDOVEDISPLAYWIDTH 2200Q) + (\RP.AFTERDISPLAY 316Q) + (\RP.AFTERDOVEDISPLAY 363Q) + (\RP.DISPLAY 0) + (\RP.TEMPDISPLAY 5001Q) + (\RP.MISCLOCKED 5364Q) + (\RP.STACK 1400Q) + (\VP.STACK 400Q) + (\RP.MAP 400Q) + (\NP.MAP 400Q) + (\RP.IOPAGE 1000Q) + (\RP.DOVEIOCBPAGE 1037Q) + (\RP.DOVEIORGN 1040Q) + (\VP.DOVEIORGN 100Q) + (\DOVEIORGNSIZE 100Q) + (\VP.IOPAGE 377Q) + (\VP.IFPAGE 12000Q) + (\VP.FPTOVP 1000Q) + (\NP.FPTOVP 10000Q) + (\RP.FPTOVP 2000Q) + (\RP.STARTBUFFERS 1200Q) + (\VP.TYPETABLE 14000Q) + (\NP.TYPETABLE 2000Q) + (\RP.TYPETABLE 12000Q) + (\VP.GCTABLE 13000Q) + (\NP.GCTABLE 400Q) + (\RP.GCTABLE 14000Q) + (\VP.GCOVERFLOW 13400Q) + (\NP.GCOVERFLOW 1) + (\RP.GCOVERFLOW 14400Q) + (\FP.IFPAGE 2) + (\VP.IOCBS 1) + (\VP.PRIMARYMAP 12002Q) + (\VP.SECONDARYMAP 2400Q) + (\VP.LPT 12160Q) + (\VP.INITSCRATCH 10Q) + (\VP.RPT 200Q) + (\VP.BUFFERS 332Q) + (\DL.PROCESSORBUSY 100000Q) + (\DL.SETTOD 100001Q) + (\DL.READTOD 100002Q) + (\DL.READPID 100003Q) + (\DL.BOOTBUTTON 100004Q)) +) + +(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 10Q "Loop in \SELECTREALPAGE") + (\MP.NEWPAGE 11Q "Attempt to allocate already existing page") + (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page") + (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another") + (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box") + (\MP.RESIDENT 15Q "Fault on resident page") + (\MP.STACKFAULT 16Q "Fault on stack") + (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)") + (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T") + (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code") + (\MP.STACKFULL 23Q) + (\MP.MDSFULL 24Q) + (\MP.UNKNOWN.UFN 25Q) + (\MP.ATOMSFULL 26Q) + (\MP.PNAMESFULL 27Q) + (\MP.USECOUNTOVERFLOW 30Q) + (\MP.MDSFULLWARNING 31Q) + (\MP.BADMDSFREELIST 32Q) + (\MP.BADARRAYBLOCK 33Q) + (\MP.BADDELETEBLOCK 34Q) + (\MP.BADARRAYRECLAIM 35Q) + (\MP.BIGREFCNTMISSING 36Q + "PTR refcnt previously overflowed, but not found in table.") + (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table") + (\MP.DELREF0 40Q) + (\MP.PROCERROR 41Q) + (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use") + (\MP.32MBINUSE 43Q) + (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)") + (\MP.STACKRELEASED 45Q) + (\MP.FLUSHLOCKED 46Q) + (\MP.MAPNOTLOCKED 47Q) + (\MP.UNLOCKINGMAP 50Q) + (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper") + (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file"))) +(DECLARE%: EVAL@COMPILE + +(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 10Q "Loop in \SELECTREALPAGE") + +(RPAQ \MP.NEWPAGE 11Q "Attempt to allocate already existing page") + +(RPAQ \MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page") + +(RPAQ \MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another") + +(RPAQ \MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box") + +(RPAQ \MP.RESIDENT 15Q "Fault on resident page") + +(RPAQ \MP.STACKFAULT 16Q "Fault on stack") + +(RPAQ \MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)") + +(RPAQ \MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T") + +(RPAQ \MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code") + +(RPAQQ \MP.STACKFULL 23Q) + +(RPAQQ \MP.MDSFULL 24Q) + +(RPAQQ \MP.UNKNOWN.UFN 25Q) + +(RPAQQ \MP.ATOMSFULL 26Q) + +(RPAQQ \MP.PNAMESFULL 27Q) + +(RPAQQ \MP.USECOUNTOVERFLOW 30Q) + +(RPAQQ \MP.MDSFULLWARNING 31Q) + +(RPAQQ \MP.BADMDSFREELIST 32Q) + +(RPAQQ \MP.BADARRAYBLOCK 33Q) + +(RPAQQ \MP.BADDELETEBLOCK 34Q) + +(RPAQQ \MP.BADARRAYRECLAIM 35Q) + +(RPAQ \MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.") + +(RPAQ \MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table") + +(RPAQQ \MP.DELREF0 40Q) + +(RPAQQ \MP.PROCERROR 41Q) + +(RPAQ \MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use") + +(RPAQQ \MP.32MBINUSE 43Q) + +(RPAQ \MP.TOPUNWOUND 44Q "Unexpected (RETTO T)") + +(RPAQQ \MP.STACKRELEASED 45Q) + +(RPAQQ \MP.FLUSHLOCKED 46Q) + +(RPAQQ \MP.MAPNOTLOCKED 47Q) + +(RPAQQ \MP.UNLOCKINGMAP 50Q) + +(RPAQ \MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper") + +(RPAQ \MP.BADRUNTABLE 52Q "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 10Q "Loop in \SELECTREALPAGE") + (\MP.NEWPAGE 11Q "Attempt to allocate already existing page") + (\MP.NEWMAPPAGE 12Q "\DONEWPAGE failed to allocate new map page") + (\MP.BADLOCKED 13Q "Locked page occupies a file page needed to lock another") + (\MP.CLOCK0 14Q "Arg to CLOCK0 not an integer box") + (\MP.RESIDENT 15Q "Fault on resident page") + (\MP.STACKFAULT 16Q "Fault on stack") + (\MP.VMEMTOOLONG 20Q "Attempt to extend Vmem File beyond fixed limit (8mb)") + (\MP.WRITING.LOCKED.PAGE 21Q "Writing a locked page with UPDATEKEY = T") + (\MP.UNINTERRUPTABLE 22Q "Error in uninterruptable system code") + (\MP.STACKFULL 23Q) + (\MP.MDSFULL 24Q) + (\MP.UNKNOWN.UFN 25Q) + (\MP.ATOMSFULL 26Q) + (\MP.PNAMESFULL 27Q) + (\MP.USECOUNTOVERFLOW 30Q) + (\MP.MDSFULLWARNING 31Q) + (\MP.BADMDSFREELIST 32Q) + (\MP.BADARRAYBLOCK 33Q) + (\MP.BADDELETEBLOCK 34Q) + (\MP.BADARRAYRECLAIM 35Q) + (\MP.BIGREFCNTMISSING 36Q "PTR refcnt previously overflowed, but not found in table.") + (\MP.BIGREFCNTALREADYPRESENT 37Q "PTR already in overflow table") + (\MP.DELREF0 40Q) + (\MP.PROCERROR 41Q) + (\MP.PROCNOFRAME 42Q "Failed to build frame for PROCESS use") + (\MP.32MBINUSE 43Q) + (\MP.TOPUNWOUND 44Q "Unexpected (RETTO T)") + (\MP.STACKRELEASED 45Q) + (\MP.FLUSHLOCKED 46Q) + (\MP.MAPNOTLOCKED 47Q) + (\MP.UNLOCKINGMAP 50Q) + (\MP.SWAPDISKERROR 51Q "Hard Disk Error in swapper") + (\MP.BADRUNTABLE 52Q "Malformed run table for vmem file")) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(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 37Q))) + +(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 53Q))) + +(BLOCKRECORD IOPAGE ((NIL 22Q 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 40Q WORD) + (DLIOPHARDWARECONFIG WORD) + (NIL 13Q WORD) + (DLRS232CPARAMETERCSBLO.11 WORD) + (DLRS232CPARAMETERCSBHI.11 WORD) + (DLRS232CSETRS366STATUS.11 16Q WORD) + (NIL 74Q WORD) + (DLMAGTAPE 4 WORD) + (DLETHERNET 14Q WORD) + (NIL 37Q WORD) + (DLDISPINTERRUPT WORD) + (DLDISPCONTROL WORD) + (DLDISPBORDER WORD) + (DLCURSORX WORD) + (DLCURSORY WORD) + (DLCURSORBITMAP 20Q WORD)) + [ACCESSFNS IOPAGE ((DLCURSORBITMAPPTR (\ADDBASE DATUM 360Q)) + (DLCURSORYPTR (\ADDBASE DATUM 357Q)) + (DLCURSORXPTR (\ADDBASE DATUM 356Q)) + (DLDISPINTERRUPTPTR (\ADDBASE DATUM 353Q)) + (DLETHERNETPTR (\ADDBASE DATUM 300Q)) + (DLKBDAD5PTR (\ADDBASE DATUM 103Q)) + (DLKBDAD4PTR (\ADDBASE DATUM 102Q)) + (DLKBDAD3PTR (\ADDBASE DATUM 101Q)) + (DLKBDAD2PTR (\ADDBASE DATUM 100Q)) + (DLKBDAD1PTR (\ADDBASE DATUM 77Q)) + (DLKBDAD0PTR (\ADDBASE DATUM 76Q)) + (DLUTILINPTR (\ADDBASE DATUM 75Q)) + (DLMOUSEYPTR (\ADDBASE DATUM 74Q)) + (DLMOUSEXPTR (\ADDBASE DATUM 73Q)) + (DLTODLOPTR (\ADDBASE DATUM 70Q)) + (DLMAINTPANELPTR (\ADDBASE DATUM 22Q] + (CREATE (\ALLOCBLOCK 200Q))) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS EMADDRESS MACRO (ARGS ([LAMBDA (ADDR) + (COND + [(EQ \D1BCPLspace \D0BCPLspace) + (LIST (BIG-VMEM-CODE (LIST 'OPCODES 'GCONST 0 0 + (LRSH ADDR 10Q) + (LOGAND ADDR 377Q)) + (LIST 'OPCODES 'GCONST 0 (LRSH ADDR 10Q) + (LOGAND ADDR 377Q] + (T `(\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 '\VAG2 '(fetch (IFPAGE EmulatorSpace) of + \InterfacePage + ) + (CAR X))) + ((ZEROP (CAR X)) + NIL) + (T (LIST '\VAG2 \D0BCPLspace (CAR X] + +[PUTPROPS EMADDRESSP MACRO (X (LIST 'EQ (LIST '\HILOC (CAR X)) + (COND + ((EQ \D1BCPLspace \D0BCPLspace) + \D0BCPLspace) + (T '(fetch (IFPAGE EmulatorSpace) of \InterfacePage] +) + +(* "END EXPORTED DEFINITIONS") + +) + +(PUTPROPS LLPARAMS MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q)) +(PUTPROPS LLPARAMS COPYRIGHT ( +"Syntelligence Systems, Inc. This program or documentation contains confidential information and trade secrets of Syntelligence Systems, Inc. Reverse engineering, reverse compiling and disassembling of object code are prohibited. Use of this program or documentation is governed by written agreement with Syntelligence Systems, Inc. Use of copyright notice is precautionary and does not imply publication or disclosure of trade secrets" + 3675Q 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3706Q 3707Q 3710Q 3712Q 3716Q)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (7177Q 13221Q (MAKERECORD 7211Q . 13217Q))))) +STOP diff --git a/sources/LLREAD b/sources/LLREAD new file mode 100644 index 00000000..0a378e24 --- /dev/null +++ b/sources/LLREAD @@ -0,0 +1,1666 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED " 4-Aug-93 14:43:07" |{PELE:MV:ENVOS}SOURCES>LLREAD.;8| 123882 + + changes to%: (FNS \RSTRING2) + (MACROS \NSIN) + + previous date%: "11-Mar-91 13:34:55" |{PELE:MV:ENVOS}SOURCES>LLREAD.;7|) + + +(* ; " +Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT LLREADCOMS) + +(RPAQQ LLREADCOMS + [(COMS (* ; "Reader entrypoints") + (FNS LASTC PEEKC PEEKCCODE RATOM READ READC READCCODE READP SETREADMACROFLG + SKIPSEPRCODES SKIPSEPRS \NSIN.24BITENCODING.ERROR SKREAD)) + (COMS (* ; "CommonLisp read entry points") + (FNS CL:READ CL:READ-PRESERVING-WHITESPACE CL:READ-DELIMITED-LIST CL:PARSE-INTEGER)) + (COMS (* ; "reading strings") + (FNS RSTRING READ-EXTENDED-TOKEN \RSTRING2)) + (COMS (* ; "Core of the reader") + (FNS \TOP-LEVEL-READ \SUBREAD \SUBREADCONCAT \READ.SYMBOL \INVALID.SYMBOL + \APPLYREADMACRO INREADMACROP)) + (COMS (* ; "Read macro for '") + (FNS READQUOTE)) + (COMS (* ; "# macro") + (FNS READVBAR READHASHMACRO DEFMACRO-LAMBDA-LIST-KEYWORD-P DIGITBASEP READNUMBERINBASE + ESTIMATE-DIMENSIONALITY SKIP.HASH.COMMENT CMLREAD.FEATURE.PARSER)) + (COMS (* ; "Reading characters with #\") + (FNS CHARACTER.READ CHARCODE.DECODE) + (VARS CHARACTERNAMES CHARACTERSETNAMES)) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (CONSTANTS * READTYPES) + (MACROS .CALL.SUBREAD. FIXDOT RBCONTEXT PROPRB \RDCONC) + (EXPORT (MACROS \BACKCHAR \BACKNSCHAR \CHECKEOLC \INCHAR \INCCODE \PEEKCCODE \NSIN + \NSPEEK NUMERIC-CHARSET)) + (SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) + (GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) + [COMS (* ; + "Support for various external formats") + [COMS (* ; "JIS to XCCS conversion table.") + (VARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CODE-MAP* + *HANKAKU-TO-ZENKAKU-CODE-MAP*) + (GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* + *JIS-TO-XCCS-CODE-MAP* *HANKAKU-TO-ZENKAKU-CODE-MAP* + *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* + *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* + *HANKAKU-TO-ZENKAKU-CONV-TABLE* *ZENKAKU-TO-HANKAKU-CONV-TABLE*) + (FNS \MAKE.JIS.TO.XCCS.CONV.TABLE) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\MAKE.JIS.TO.XCCS.CONV.TABLE] + [COMS (* ; "JIS to XCCS converter") + (INITVARS (*REPLACE-NO-FONT-CODE* T) + (*DEFAULT-NOT-CONVERTED-FAT-CODE* 8739)) + (GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.JIS.TO.XCCS + \DO.CONV.JIS.TO.XCCS] + [COMS (* ; "XCCS to JIS converter") + (FNS CONVHANKAKU) + (DECLARE%: DOEVAL@COMPILE DONTCOPY (EXPORT (MACROS \CONV.XCCS.TO.JIS + \DO.CONV.XCCS.TO.JIS \ASCIIP + \NOT.EQUIVALENT.TO.JIS + \CONV.HANKAKU.TO.ZENKAKUP + \CONV.ZENKAKU.KANA] + (COMS (FNS \JISIN \JISPEEK \BACKJISCHAR \SHIFTJISIN \SHIFTJISPEEK \BACKSHIFTJISCHAR + \EUCIN \EUCPEEK \BACKEUCCHAR \THROUGHIN \THROUGHPEEK \BACKTHROUGHCHAR) + (DECLARE%: DOEVAL@COMPILE DONTCOPY + (EXPORT + + (* ;; "XCCS specific macro. Although the decoder and encoder are implemented as functions in general, only for XCCS, they are implemeted as macros for efficiency reason.") + + (MACROS \XCCSIN \XCCSPEEK \BACKXCCSCHAR \XCCSP) + + (* ;; "JIS specific macro") + + (MACROS \EXTRACT.NO.FONT.CODE \EXTARACT.CONV.TABLE + \NOT.EQUIVALENT.TO.XCCS \EXTRACT.SET \EXTRACT.CODE + \CHNAGE.KI.MODE \KIMODEP \HANKAKUP \KANJIP \NOTGAIJIP + \INVALID.TENP \CONV.HANKAKU.KANA \OUTKI \OUTKO) + + (* ;; "Shift-JIS specific macro") + + (MACROS \CONV.SJIS.TO.JIS \CONV.JIS.TO.SJIS \SJIS.KANJI.FIRST.BYTEP + ) + + (* ;; "EUC specific macro") + + (MACROS \EUC.KANJI.FIRST.BYTEP \GAIJIP \EUC.HANKAKUP] + (INITVARS (*SIGNAL-24BIT-NSENCODING-ERROR*) + (*READ-NEWLINE-SUPPRESS*) + (\RefillBufferFn (FUNCTION \READCREFILL))) + (* ; + "Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") + (LOCALVARS . T) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + (ADDVARS (NLAMA) + (NLAML) + (LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST + CL:READ-PRESERVING-WHITESPACE CL:READ]) + + + +(* ; "Reader entrypoints") + +(DEFINEQ + +(LASTC +(LAMBDA (FILE) (* ; "Edited 6-Jan-88 15:31 by jds") (* ;; "Be careful only to do BIN's if we first were able to back up, so that an EOF doesn't happen. This is really an inadequate implementation, because it fails for files that cannot be backed up. Eventually, we must change the character reading functions READ, RATOM, READC to save the last character they read in an STREAM field.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (LASTCCODE (FETCH (STREAM LASTCCODE) OF STREAM))) (* ;; "(FCHARACTER (SELCHARQ C (CR (SELECTC (ffetch EOLCONVENTION of STREAM) (CR.EOLC (CHARCODE EOL)) C)) (LF (SELECTC (ffetch EOLCONVENTION of STREAM) (LF.EOLC (CHARCODE EOL)) (CRLF.EOLC (COND ((EQ (CHARCODE CR) (UNINTERRUPTABLY (AND (\BACKNSCHAR STREAM SHIFTEDCHARSET) (PROG1 (PROGN (\BACKNSCHAR STREAM SHIFTEDCHARSET) (\NSIN STREAM SHIFTEDCHARSET)) (\NSIN STREAM SHIFTEDCHARSET))))) (CHARCODE EOL)) (T C))) C)) (NIL 0) C))") (COND ((IEQP LASTCCODE 65535) NIL) (T (FCHARACTER LASTCCODE))))) +) + +(PEEKC +(LAMBDA (FILE FLG) (* rmk%: "10-Apr-85 11:55") (* ;; "FLG says to proceed as if Control were T--not implemented correctly here NIL") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (FCHARACTER (PEEKCCODE STREAM)))) +) + +(PEEKCCODE +(LAMBDA (FILE NOERROR) (* bvm%: "12-Sep-86 15:19") (LET ((\RefillBufferFn (FUNCTION \PEEKREFILL)) (STREAM (\GETSTREAM FILE (QUOTE INPUT)))) (DECLARE (SPECVARS \RefillBufferFn)) (\PEEKCCODE STREAM NOERROR))) +) + +(RATOM +(LAMBDA (FILE RDTBL) (* ; "Edited 30-Mar-87 17:21 by bvm:") (* ;;; "Like READ except interpret break characters as single character atoms. I.e., always returns an atom") (SETQ RDTBL (\GTREADTABLE RDTBL)) (LET ((*READTABLE* RDTBL) (*PACKAGE* (if (fetch (READTABLEP USESILPACKAGE) of RDTBL) then *INTERLISP-PACKAGE* else *PACKAGE*)) (\RefillBufferFn (FUNCTION \RATOM/RSTRING-REFILL))) (DECLARE (SPECVARS *READTABLE* *PACKAGE* \RefillBufferFn)) (WITH-RESOURCE (\PNAMESTRING) (\SUBREAD (\GETSTREAM FILE (QUOTE INPUT)) (fetch (READTABLEP READSA) of *READTABLE*) RATOM.RT \PNAMESTRING (AND (fetch (READTABLEP CASEINSENSITIVE) of *READTABLE*) (fetch (ARRAYP BASE) of UPPERCASEARRAY)) NIL NIL NIL T)))) +) + +(READ +(LAMBDA (FILE RDTBL FLG) (* ; "Edited 19-Mar-87 18:35 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (*READ-NEWLINE-SUPPRESS* FLG)) (DECLARE (SPECVARS *READTABLE* *READ-NEWLINE-SUPPRESS*)) (* ;; "*READ-NEWLINE-SUPPRESS* is used freely by \FILLBUFFER") (* ;; "Call reader with PRESERVE-WHITESPACE = T, since that's the semantics Interlisp has always had before (though maybe not explicitly stated).") (\TOP-LEVEL-READ FILE NIL NIL NIL T))) +) + +(READC +(LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 15:30 by jds") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (FUNCTION \READCREFILL))) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn)) (FCHARACTER (REPLACE (STREAM LASTCCODE) OF (\INSTREAMARG FILE) WITH (\INCCODE (\INSTREAMARG FILE)))))) +) + +(READCCODE + [LAMBDA (FILE RDTBL) (* ; "Edited 3-Jun-88 01:30 by atm") + +(* ;;; "returns a 16 bit character code. \INCHAR does the EOL conversion and this function converts to a 16 bit value. Saves the character for LASTC as well.") + + (SETQ FILE (\GETSTREAM FILE 'INPUT)) + (FDEVOP 'READCHARCODE (fetch (STREAM DEVICE) of FILE) + FILE RDTBL]) + +(READP +(LAMBDA (FILE FLG) (* rmk%: " 5-Apr-85 09:09") (* ; "The 10 does not do the EOL check on the peeked character.") (LET* ((STREAM (\GETSTREAM FILE (QUOTE INPUT))) (DEVICE (ffetch (STREAM DEVICE) of STREAM))) (COND ((ffetch (FDEV READP) of DEVICE) (FDEVOP (QUOTE READP) DEVICE STREAM FLG)) (T (\GENERIC.READP STREAM FLG))))) +) + +(SETREADMACROFLG +(LAMBDA (FLG) (* rmk%: "25-OCT-83 16:13") (* ; "D doesn't cause the read-macro context error, hence doesn't maintain this flag") NIL) +) + +(SKIPSEPRCODES +(LAMBDA (FILE RDTBL) (* ; "Edited 6-Jan-88 13:09 by jds") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind PREVC C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (SETQ PREVC C) (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (AND PREVC (replace (STREAM LASTCCODE) of STREAM with PREVC)) (RETURN C))) +) + +(SKIPSEPRS +(LAMBDA (FILE RDTBL) (* ; "Edited 11-Sep-87 17:52 by bvm:") (* ;; "Passes over non-separators to peek at the first non-separator on FILE. Returns either last peeked character, or NIL if no non-seprs left in the file.") (bind C SHIFTEDCHARSET (STREAM _ (\GETSTREAM FILE (QUOTE INPUT))) (SA _ (fetch (READTABLEP READSA) of (\GTREADTABLE RDTBL))) (\RefillBufferFn _ (QUOTE \PEEKREFILL)) first (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) declare (SPECVARS \RefillBufferFn) while (EQ SEPRCHAR.RC (\SYNCODE SA (SETQ C (OR (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET T) (RETURN))))) do (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) finally (RETURN (FCHARACTER C)))) +) + +(\NSIN.24BITENCODING.ERROR +(LAMBDA (STREAM) (* bvm%: "12-Mar-86 15:35") (DECLARE (USEDFREE *SIGNAL-24BIT-NSENCODING-ERROR*)) (* ;;; "Called if we see the sequence shift,shift on STREAM -- means shift to 24-bit character set, which we don't support. Usually this just means we're erroneously reading a binary file as text. If this function returns, its value is taken as a character set to shift to") (COND (*SIGNAL-24BIT-NSENCODING-ERROR* (* ; "Only cause error if user/reader cares") (ERROR "24-bit NS encoding not supported" STREAM))) (* ; "Return charset zero") 0) +) + +(SKREAD + [LAMBDA (FILE REREADSTRING RDTBL) (* ; "Edited 6-Apr-88 11:06 by amd") + (LET ((*READ-SUPPRESS* 'SKREAD) + (*READTABLE* (\GTREADTABLE RDTBL)) + (\RBFLG) + (STRM (\GETSTREAM FILE 'INPUT)) + CH) + (DECLARE (CL:SPECIAL *READTABLE* *READ-SUPPRESS* \RBFLG)) + [COND + (REREADSTRING (* ; + "REREADSTRING is string of chars already read.") + (SETQ STRM (CL:MAKE-CONCATENATED-STREAM (CL:MAKE-STRING-INPUT-STREAM (MKSTRING + REREADSTRING + )) + STRM] (* ; + "Because of return requirements, have to preview stream for unbalanced closing bracket/paren") + (if (NULL (SETQ CH (SKIPSEPRCODES STRM))) + then (\EOF.ACTION STRM) + else (SELECTC (PROG1 (\SYNCODE (fetch (READTABLEP READSA) of *READTABLE*) + CH) + (* ;; "Read in suppressed mode. Reader sets \Rbflg free if read ended on unbalanced bracket. Reason we do the READ in all cases is so that we need to consume the unbalanced paren/bracket, just as if we really had read it; however, READ doesn't set \Rbflg for these cases") + + (\TOP-LEVEL-READ STRM NIL NIL NIL T)) + (RIGHTPAREN.RC (* ; "unbalanced right paren") + '%)) + (RIGHTBRACKET.RC (* ; "unbalanced right bracket") + '%]) + (AND \RBFLG '%]]) +) + + + +(* ; "CommonLisp read entry points") + +(DEFINEQ + +(CL:READ +(CL:LAMBDA (&OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) (EOF-ERROR-P T) EOF-VALUE RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (COND (RECURSIVE-P (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. INPUT-STREAM)) (T (\TOP-LEVEL-READ INPUT-STREAM (NOT EOF-ERROR-P) EOF-VALUE)))) +) + +(CL:READ-PRESERVING-WHITESPACE +(CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*) (EOF-ERRORP T) (EOF-VALUE NIL) (RECURSIVEP NIL)) (* ; "Edited 19-Mar-87 18:33 by bvm:") (* ;; "Reads from stream and returns the object read, preserving the whitespace that followed the object.") (COND (RECURSIVEP (* ; "Dive straight into reader using current settings of everything") (.CALL.SUBREAD. STREAM)) (T (\TOP-LEVEL-READ STREAM (NOT EOF-ERRORP) EOF-VALUE NIL T)))) +) + +(CL:READ-DELIMITED-LIST +(CL:LAMBDA (CHAR &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*) RECURSIVE-P) (* ; "Edited 14-Dec-86 18:48 by bvm") (* ;;; "Read a list of elements terminated by CHAR. CHAR must not be a separator char, and ideally should not be a constituent char (if it is, it must be preceded by whitespace for READ-DELIMITED-LIST to work)") (LET ((ENDCODE (OR (FIXP CHAR) (CL:CHAR-CODE CHAR))) (INSTREAM (\GETSTREAM INPUT-STREAM (QUOTE INPUT)))) (if RECURSIVE-P then (* ; "Have to dive into reader without disturbing *CIRCLE-READ-LIST*") (.CALL.SUBREAD. INPUT-STREAM NIL NIL ENDCODE) else (\TOP-LEVEL-READ INPUT-STREAM NIL NIL ENDCODE)))) +) + +(CL:PARSE-INTEGER + [CL:LAMBDA + (STRING &KEY START END (RADIX 10) + JUNK-ALLOWED) (* ; "Edited 8-Feb-91 13:24 by gadener") + (CL:IF (NOT (CL:STRINGP STRING)) + (ERROR "This is not a string : ~S" STRING) + (PROG ((SA (fetch (READTABLEP READSA) of CMLRDTBL)) + (BASE (fetch (STRINGP BASE) of STRING)) + (LEN (fetch (STRINGP LENGTH) of STRING)) + (OFFST (fetch (STRINGP OFFST) of STRING)) + (FATP (fetch (STRINGP FATSTRINGP) of STRING)) + MAXDIGITCODE MAXALPHACODE INDEX STOP CHAR SIGN STARTINT ENDINT ERR) + (SETQ RADIX (\CHECKRADIX RADIX)) + (SETQ INDEX (+ OFFST (if (NULL START) + then 0 + elseif (< START 0) + then (\ILLEGAL.ARG START) + else START))) + (SETQ STOP (+ OFFST (if (NULL END) + then LEN + elseif (OR (> END LEN) + (< END 0)) + then (\ILLEGAL.ARG END) + else END))) + (SETQ MAXDIGITCODE (+ (CHARCODE 0) + RADIX -1)) + (SETQ MAXALPHACODE (AND (> RADIX 10) + (+ (CHARCODE A) + RADIX -11))) + (while (AND (< INDEX STOP) + (EQ (\SYNCODE SA (\GETBASECHAR FATP BASE INDEX)) + SEPRCHAR.RC)) do (* ; "Skip over separators") + (SETQ INDEX (CL:1+ INDEX))) + [COND + ((>= INDEX STOP) (* ; "no characters remain") + (RETURN (COND + (JUNK-ALLOWED (* ; "don't error") + (CL:VALUES NIL STOP)) + (T (SETQ ERR "No non-whitespace characters in integer string: ~S") + (GO FAIL] + + (* ;; "Start parsing a number. Allowed to start with a single sign, then digits in radix, nothing else. Assume collating sequence is (+, -) < digits < uppercase letters < lowercase letters.") + + (do (SETQ CHAR (\GETBASECHAR FATP BASE INDEX)) + (if (<= CHAR MAXDIGITCODE) + then (* ; "sign or digit") + (if (>= CHAR (CHARCODE 0)) + then (* ; " digit") + (OR STARTINT (SETQ STARTINT INDEX)) + elseif (AND (NOT SIGN) + (NOT STARTINT)) + then (* ; + "maybe sign. No good if not at start") + (SELCHARQ CHAR + (- (SETQ SIGN '-)) + (+ (SETQ SIGN '+)) + (RETURN)) + else (RETURN)) + elseif (AND MAXALPHACODE (<= (if (>= CHAR (CHARCODE "a")) + then + (* ; "uppercase it first") + (- CHAR (- (CHARCODE "a") + (CHARCODE "A"))) + else CHAR) + MAXALPHACODE)) + then (* ; "is alphabetic digit") + (OR STARTINT (SETQ STARTINT INDEX)) + else (RETURN)) repeatwhile (< (add INDEX 1) + STOP)) + (SETQ ENDINT INDEX) + (RETURN (CL:VALUES (COND + ([AND STARTINT + (OR JUNK-ALLOWED (EQ INDEX STOP) + (do (if (NEQ (\SYNCODE SA CHAR) + SEPRCHAR.RC) + then + (* ; " junk found") + (RETURN NIL) + elseif (EQ (add INDEX 1) + STOP) + then + (* ; "at end of string, win") + (RETURN T) + else (SETQ CHAR (\GETBASECHAR FATP BASE + INDEX] + (\MKINTEGER BASE STARTINT ENDINT (EQ SIGN '-) + RADIX FATP)) + (JUNK-ALLOWED NIL) + ((NULL STARTINT) + (SETQ ERR "There aren't any digits in this integer string: ~S.") + (GO FAIL)) + (T (SETQ ERR "There is junk in this integer string: ~S.") + (GO FAIL))) + (- INDEX OFFST))) + FAIL + (CL:ERROR ERR (if (OR START END) + then (CL:SUBSEQ STRING (OR START 0) + (OR END LEN)) + else STRING))))]) +) + + + +(* ; "reading strings") + +(DEFINEQ + +(RSTRING +(LAMBDA (FILE RDTBL RSFLG) (* ; "Edited 22-Mar-87 20:53 by bvm:") (LET ((*READTABLE* (\GTREADTABLE RDTBL)) (\RefillBufferFn (QUOTE \RATOM/RSTRING-REFILL)) (*READ-SUPPRESS* NIL)) (DECLARE (SPECVARS *READTABLE* \RefillBufferFn *READ-SUPPRESS*)) (* ;; "It's not clear that *READ-SUPPRESS* is supposed to affect anything other than calls to READ. So play it safe and force \Rstring2 to really read a string.") (WITH-RESOURCE (\PNAMESTRING) (\RSTRING2 (\GETSTREAM FILE (QUOTE INPUT)) (fetch READSA of *READTABLE*) (OR RSFLG T) \PNAMESTRING)))) +) + +(READ-EXTENDED-TOKEN +(LAMBDA (STREAM RDTBL ESCAPE-ALLOWED-P) (* ; "Edited 11-Sep-87 16:23 by bvm:") (* ;; "This is a cross between RSTRING and \SUBREAD. Read a %"token%" from STREAM, as defined by the Common Lisp reader and the syntax in RDTBL. EOF terminates as well. If ESCAPE-ALLOWED-P is true, escapes are honored and if one appears, a second value of T is returned. Otherwise, escapes are treated as vanilla chars and the caller can barf on them itself if it desires.") (SETQ RDTBL (\GTREADTABLE RDTBL)) (WITH-RESOURCE (\PNAMESTRING) (PROG ((CASEBASE (AND (fetch (READTABLEP CASEINSENSITIVE) of RDTBL) (fetch (ARRAYP BASE) of UPPERCASEARRAY))) (PBASE (ffetch (STRINGP XBASE) of \PNAMESTRING)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (J 0) (SA (fetch READSA of RDTBL)) CH SNX ANSLIST ANSTAIL ESCAPE-APPEARED ESCAPING FATSEEN) LP (if (\EOFP STREAM) then (* ; "end of file terminates string just like a sepr/break") (GO FINISH)) (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) (* ; "NOTE: This should really be (\CHECKEOLC (\NSIN --) --), but eol is usually a break or sepr and the \BACKNSCHAR doesn't work right. Fix this when we unread correctly") (SETQ SNX (\SYNCODE SA CH)) (COND ((AND ESCAPE-ALLOWED-P (SELECTC SNX (ESCAPE.RC (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (SETQ ESCAPE-APPEARED T)) (MULTIPLE-ESCAPE.RC (SETQ ESCAPING (NOT ESCAPING)) (SETQ ESCAPE-APPEARED T) (GO LP)) NIL))) (ESCAPING (* ; "eat chars until next |")) ((fetch STOPATOM of SNX) (\BACKNSCHAR STREAM SHIFTEDCHARSET) (GO FINISH)) ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (SETQ CH (\GETBASEBYTE CASEBASE CH)))) (COND ((EQ J \PNAMELIMIT) (* ; "Filled PNSTR so have to save those chars away and start filling up a new buffer") (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL)))) (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL))))) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (COND ((AND (NOT FATSEEN) (IGREATERP CH \MAXTHINCHAR)) (SETQ FATSEEN T))) (SETQ J (ADD1 J)) (GO LP) FINISH (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) 0 \PNAMESTRING J)) (COND (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) (SETQ J (CONCATLIST ANSLIST)))) (RETURN (if ESCAPE-APPEARED then (* ; "do it this way because multiple values are slow") (CL:VALUES J T) else J))))) +) + +(\RSTRING2 + [LAMBDA (STREAM SA RSFLG PNSTR) (* ; + "Edited 4-Aug-93 12:38 by sybalskY:MV:ENVOS") + +(* ;;; "The main string reader. Reads characters from STREAM according to the syntax table SA and returns a string. PNSTR is an instance of the global resource \PNAMESTRING, which we can use all to ourselves as a buffer.") + +(* ;;; "If RSFLG is T then the call is from RSTRING, in which case the string is terminated by a break or sepr in SA. If RSFLG is NIL then the string is terminated by a string delimiter. If RSFLG is SKIP then CR's and the following separator chars are discarded as an otherwise normal string is read") + + (DECLARE (USEDFREE *READTABLE* *READ-SUPPRESS*)) + (PROG ((EOLC (ffetch EOLCONVENTION of STREAM)) + (PBASE (SELECTQ (SYSTEMTYPE) + (VAX PNSTR) + (ffetch (STRINGP XBASE) of PNSTR))) + (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) + 256)) + (J 0) + EOLCHAR CH SNX ANSLIST ANSTAIL LASTC FATSEEN SKIPPING) + (SELECTC EOLC + (CRLF.EOLC (SETQ EOLCHAR (CHARCODE CR))) + (CR.EOLC (SETQ EOLCHAR (CHARCODE CR))) + (LF.EOLC (SETQ EOLCHAR (CHARCODE LF))) + NIL) + RS2LP + (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)) + [COND + ((EQ CH EOLCHAR) + + (* ;; "We just read the stream's EOL character, so we have to turn it into our EOL. Most places do this with \CHECKEOLC, but we can't do that here, because if the eol is CRLF and would terminate the read, \BACKNSCHAR won't work right.") + + (COND + ([AND (EQ RSFLG T) + (fetch STOPATOM of (\SYNCODE SA (CHARCODE CR] + (* ; + "From RSTRING, eol terminates read. Leave eol in buffer") + (\BACKNSCHAR STREAM SHIFTEDCHARSET) + (GO FINISH)) + (T (COND + ((AND (EQ EOLC CRLF.EOLC) + (EQ (\PEEKBIN STREAM T) + (CHARCODE LF))) (* ; "Eat the LF after the CR") + (\BIN STREAM))) + (SETQ CH (CHARCODE CR] + (SETQ SNX (\SYNCODE SA CH)) + (SELECTC SNX + (OTHER.RC (* ; "Normal case, nothing to do")) + (ESCAPE.RC [COND + ((fetch ESCAPEFLG of *READTABLE*) + (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) + EOLC STREAM)) + (COND + ((AND (EQ RSFLG 'SKIP) + (EQ CH (CHARCODE CR))) (* ; + "Strip leading spaces after escaped returns, too, but leave the CR in the string") + (SETQ SKIPPING 0) + (GO PUTCHAR]) + (SELECTQ RSFLG + (NIL (* ; "end check is dbl quote") + (COND + ((EQ SNX STRINGDELIM.RC) (* ; "Got it") + (SETQ LASTC CH) + (GO FINISH)))) + (T (* ; + "if called from RSTRING, end check is break or sepr, and we must leave delim in stream") + (COND + ((fetch STOPATOM of SNX) + (\BACKNSCHAR STREAM SHIFTEDCHARSET) + (GO FINISH)))) + (SKIP (* ; + "Like NIL but strip cr's and leading spaces") + (SELECTC SNX + (STRINGDELIM.RC + (SETQ LASTC CH) + (GO FINISH)) + (SEPRCHAR.RC (* ; "Assume that CR is a sepr") + (COND + [SKIPPING (COND + ((EQ CH (CHARCODE EOL)) + (* ; + "Multiple CR's while skipping are kept") + (COND + ((EQ SKIPPING T) + (* ; + "Turn previous space back into CR. Note that J is guaranteed to be at least 1") + (\PNAMESTRINGPUTCHAR PBASE (SUB1 J) + CH) + (SETQ SKIPPING 0))) + (GO PUTCHAR)) + (T (* ; "Continue skipping seprs") + (GO RS2LP] + ((EQ CH (CHARCODE EOL)) + (* ; + "Turn CR into space and start skipping seprs") + (SETQ SKIPPING T) + (SETQ CH (CHARCODE SPACE)) + (GO PUTCHAR)))) + NIL)) + (SHOULDNT))) + (SETQ SKIPPING NIL) + PUTCHAR + [COND + ((NOT *READ-SUPPRESS*) (* ; "Accumulate character") + (COND + ((EQ J \PNAMELIMIT) (* ; + "Filled PNSTR so have to save those chars away and start filling up a new buffer") + (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) + 0 PNSTR J)) + [COND + [ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL] + (T (SETQ ANSTAIL (SETQ ANSLIST (CONS J NIL] + (SETQ J 0))) + (\PNAMESTRINGPUTCHAR PBASE J CH) + (SETQ LASTC CH) + (COND + ((AND (NOT FATSEEN) + (IGREATERP CH \MAXTHINCHAR)) + (SETQ FATSEEN T))) + (SETQ J (ADD1 J] + (COND + ((OR (NEQ RSFLG T) + (NOT (\EOFP STREAM))) (* ; "in RSTRING (RSFLG=T), if we've read something already, then end of file terminates string just like a sepr/break") + (GO RS2LP))) + FINISH + (AND LASTC (replace (STREAM LASTCCODE) of STREAM with LASTC)) + (RETURN (COND + ((NOT *READ-SUPPRESS*) + (SETQ J (\SMASHSTRING (ALLOCSTRING J NIL NIL FATSEEN) + 0 PNSTR J)) + (COND + (ANSLIST (RPLACD ANSTAIL (SETQ ANSTAIL (CONS J NIL))) + (CONCATLIST ANSLIST)) + (T J]) +) + + + +(* ; "Core of the reader") + +(DEFINEQ + +(\TOP-LEVEL-READ + [LAMBDA (STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) + (* ; "Edited 13-Dec-88 16:28 by jds") + + (* ;; "Entry to the guts of the reader from a place where you may not be already under the reader. CHAR is for READ-DELIMITED-LIST -- it is charcode to terminate read, in which case we are reading a sequence of things instead of a single thing. EOF-SUPPRESS is the opposite of CL:READ's EOF-ERROR-P arg.") + + (* ;; + " I EOF-SUPPRESS, set the stream's EODOFSTREAMOP to retfrom here with EOF-VALUE as its result.") + + (LET ((*PACKAGE* (COND + ((fetch (READTABLEP USESILPACKAGE) of (\DTEST *READTABLE* + 'READTABLEP)) + *INTERLISP-PACKAGE*) + (T *PACKAGE*))) + (\RefillBufferFn (FUNCTION \READREFILL)) + (*CIRCLE-READ-LIST* NIL) + (OLD-EOS-OP (fetch ENDOFSTREAMOP of STREAM))) + (DECLARE (SPECVARS *PACKAGE* \RefillBufferFn *CIRCLE-READ-LIST* EOF-VALUE)) + (CL:UNWIND-PROTECT + (PROGN [AND EOF-SUPPRESS (REPLACE ENDOFSTREAMOP OF STREAM + WITH #'(LAMBDA (STREAM) + (RETFROM '\TOP-LEVEL-READ EOF-VALUE] + (LET ((RESULT (.CALL.SUBREAD. STREAM EOF-SUPPRESS EOF-VALUE CHAR + PRESERVE-WHITESPACE))) + (if *CIRCLE-READ-LIST* + then (* ; + "There were calls to #=, so go fix up all the ## references.") + (HASH-STRUCTURE-SMASH RESULT)) + RESULT)) + (REPLACE ENDOFSTREAMOP OF STREAM WITH OLD-EOS-OP))]) + +(\SUBREAD +(LAMBDA (STREAM SA READTYPE PNSTR CASEBASE EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) (* ; "Edited 7-Jan-88 18:38 by jds") (* ;; "Values of READTYPE are: --- READ.RT for top level of READ, --- NOPROPRB.RT if right-bracket isn't to be propagated -- sublist beginning with left-bracket --- PROPRB.RT if propagation is not suppressed -- sublist beginning with left-paren --- RATOM.RT for call from RATOM") (* ;; "PNSTR is an instance of the global resource \PNAMESTRING, acquired in READ and passed on from level to level. It is released during read-macro applications, then reacquired.") (* ;; "CASEBASE is base of uppercasearray if read table is case-insensitive.") (* ;; "If EOF-SUPPRESS is true, then if we are at end of file we should return EOF-VALUE instead of erroring (we need this because we might actually be sitting before end of file in front of something that reads nothing, e.g., a comment, so caller can't check EOFP itself). Always false on recursive calls.") (* ;; "If CHAR is supplied, it is a character code which, when read (in isolation), should terminate this call to read. Never on when at top-level.") (* ;; "\RBFLG is propagated for top-level calls, in case they are embedded in read-macros. SKREAD also depends on this.") (* ;; "If PRESERVE-WHITESPACE is true, doesn't throw away the whitespace that terminates the read.") (DECLARE (USEDFREE *READTABLE* \RBFLG)) (* ;; "\RDCONC is a macro that adds a new element as specified by its first argument to the current sublist. Its other arguments will be executed instead if we are the top-level call") (PROG ((TOPLEVELP (SELECTC READTYPE ((LIST READ.RT RATOM.RT) T) NIL)) (SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (PBASE (SELECTQ (SYSTEMTYPE) (VAX PNSTR) (ffetch (STRINGP XBASE) of PNSTR))) SNX LST END ELT DOTLOC CH J ESCAPEFLG INVALIDFLG PACKAGE NCOLONS AT-EOF EOF-POSSIBILITY EXTRASEGMENTS LASTC) (if (AND TOPLEVELP (NOT (\INTERMP STREAM))) then (* ;; "EOF is allowed to terminate tokens on direct READ calls. Not if reading from terminal, because \FILLBUFFER made sure to put something at the end.") (SETQ EOF-POSSIBILITY T)) NEWTOKEN (* ;; "Here ready to scan a new token. First skip over separator characters") (SETQ J 0) (SETQ EXTRASEGMENTS (SETQ INVALIDFLG (SETQ ESCAPEFLG (SETQ PACKAGE (SETQ NCOLONS NIL))))) (if (AND EOF-SUPPRESS (NULL (SKIPSEPRCODES STREAM))) then (* ; "caller specified eof-error-p of NIL. Happens only on top-level calls") (RETURN EOF-VALUE)) (SETQ SHIFTEDCHARSET (UNFOLD (ACCESS-CHARSET STREAM) 256)) (* ; "By Skipping Separator Characters,Happens CHARSET-Mode Exchanging. (Solution of AR#114 in FX, edited by tt [Jan-22-'90])") (repeatwhile (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) SEPRCHAR.RC)) (COND ((EQ CH CHAR) (* ; "Read desired terminating char. TOPLEVELP is always false here") (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last char for LASTC.") (RETURN LST)) ((EQ SNX OTHER.RC) (* ; "Start of an atom") (COND ((AND (EQ CH (CHARCODE %.)) (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) (* ;; "An isolated, unescaped dot. This special check on every atom could be eliminated if . had a special SNX code") (SETQ DOTLOC END) (* ; "DOTLOC points to CONS cell one before the dot, NIL for car of list, as desired."))) (GO GOTATOMCHAR)) ((fetch STOPATOM of SNX) (* ; "This character definitely does not start an atom") (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO BREAK)))) ((EQ SNX PACKAGEDELIM.RC) (* ; "Starting a symbol with a package delimiter -- must be a keyword") (SETQ NCOLONS 1) (SETQ PACKAGE *KEYWORD-PACKAGE*) (SETQ ESCAPEFLG T) (GO NEXTATOMCHAR)) ((AND (SELECTC (fetch MACROCONTEXT of SNX) (FIRST.RMC T) (ALONE.RMC (fetch STOPATOM of (\SYNCODE SA (\NSPEEK STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) NIL) (fetch READMACROFLG of *READTABLE*)) (COND ((EQ READTYPE RATOM.RT) (GO SINGLECHARATOM)) (T (GO MACRO)))) (T (* ; "Some character that starts an atom but has non-trivial syntax attributes"))) ATOMLOOP (* ;; "At this point, we are accumulating an atom, and CH does not have syntax OTHER, so we have to check special cases") (SELECTC SNX (ESCAPE.RC (* ; "Take next character to be alphabetic, case exact") (COND ((fetch ESCAPEFLG of *READTABLE*) (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (* ; "No EOFP check needed -- it's an error to have escape char with nothing following") (SETQ ESCAPEFLG T) (GO PUTATOMCHAR)))) (MULTIPLE-ESCAPE.RC (* ;; "Take characters up to next multiple escape to be alphabetic, except that single escape chars still escape the next char") (SETQ ESCAPEFLG T) (bind ESCFLG do (SETQ CH (\CHECKEOLC (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET) (ffetch EOLCONVENTION of STREAM) STREAM)) (COND ((NOT (COND (ESCFLG (SETQ ESCFLG NIL)) (T (SELECTC (SETQ SNX (\SYNCODE SA CH)) (MULTIPLE-ESCAPE.RC (* ; "Finished escaped sequence, resume normal processing") (GO NEXTATOMCHAR)) (ESCAPE.RC (* ; "Pass the next char thru verbatim") (SETQ ESCFLG T)) NIL)))) (* ; "All others are pname chars, quoted") (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "if there have been escapes, can't be a number, so ok to error now.") (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (GO NEWTOKEN))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1)))))) NIL) GOTATOMCHAR (* ;; "CH is a vanilla atom char to accumulate") (COND ((AND CASEBASE (ILEQ CH \MAXTHINCHAR)) (* ; "Uppercase atom characters") (SETQ CH (\GETBASEBYTE CASEBASE CH)))) PUTATOMCHAR (if (NOT *READ-SUPPRESS*) then (COND ((EQ J \PNAMELIMIT) (* ; "Symbol is too long. However, it could just be a bignum, so keep accumulating characters until we have to do something.") (push EXTRASEGMENTS (\SMASHSTRING (ALLOCSTRING J NIL NIL T) 0 PNSTR J)) (SETQ J 0))) (\PNAMESTRINGPUTCHAR PBASE J CH) (add J 1) (SETQ LASTC CH) (* ; "Save CH for LASTC.")) NEXTATOMCHAR (if (AND EOF-POSSIBILITY (SETQ AT-EOF (\EOFP STREAM))) then (* ; "EOF terminates atoms at top level") (GO FINISHATOM) elseif (EQ (SETQ SNX (\SYNCODE SA (SETQ CH (\NSIN STREAM SHIFTEDCHARSET SHIFTEDCHARSET)))) OTHER.RC) then (* ; "normal case tested first--another vanilla constituent char, so keep accumulating atom chars") (GO GOTATOMCHAR) elseif (fetch STOPATOM of SNX) then (* ; "Terminates atom") (GO FINISHATOM) elseif (EQ SNX PACKAGEDELIM.RC) then (GO GOTPACKAGEDELIM) else (GO ATOMLOOP)) FINISHATOM (* ;; "Come here when an atom has been terminated, either by a break/sepr char or by end of file.") (if INVALIDFLG then (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (\INVALID.SYMBOL PBASE J NCOLONS PACKAGE EXTRASEGMENTS)) (SETQ ELT (AND (NOT *READ-SUPPRESS*) (if EXTRASEGMENTS then (* ;; "More than \PNAMELIMIT chars were read. Can't be a symbol, but might be a number. Pack up all the strings we have into a single string and try to parse it as a number.") (SETQ EXTRASEGMENTS (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (OR (AND (NULL (OR PACKAGE ESCAPEFLG NCOLONS)) (\PARSE.NUMBER (fetch (STRINGP BASE) of EXTRASEGMENTS) (fetch (STRINGP OFFST) of EXTRASEGMENTS) (fetch (STRINGP LENGTH) of EXTRASEGMENTS) \FATPNAMESTRINGP)) (LISPERROR "ATOM TOO LONG" EXTRASEGMENTS)) else (\READ.SYMBOL PBASE 0 J \FATPNAMESTRINGP PACKAGE (EQ NCOLONS 1) ESCAPEFLG)))) (replace (STREAM LASTCCODE) of STREAM with CH) (* ; "Save last READ char for LASTC.") (if AT-EOF then (* ; "top-level read, atom terminated by EOF") (RETURN ELT)) (\RDCONC ELT (PROGN (COND ((OR PRESERVE-WHITESPACE (NEQ SNX SEPRCHAR.RC)) (* ; "At top-level, put back the terminating character if preserving whitespace or terminator is significant") (replace (STREAM LASTCCODE) of STREAM with (OR LASTC CH 65535)) (* ; "And LASTC will return the last REAL char read.") (\BACKNSCHAR STREAM SHIFTEDCHARSET))) (RETURN ELT))) (if (EQ SNX SEPRCHAR.RC) then (* ; "Terminated with sepr, go on to next char") (GO NEWTOKEN) elseif (EQ CH CHAR) then (* ; "read terminates here") (replace (STREAM LASTCCODE) of STREAM with CH) (RETURN LST) else (* ; "Terminated with break, jump into the break char code") (GO BREAK)) GOTPACKAGEDELIM (* ;; "Come here if CH is a package delimiter. Note that we have already scanned at least one character of the token, so this must be an interior delim") (COND (*READ-SUPPRESS* (* ; "Don't care about packages")) ((AND (EQ J 0) (NULL EXTRASEGMENTS)) (* ;; "No chars accumulated, so must be 2 colons in a row. Note that the case where we've just started scanning a token happens up at NEWTOKEN") (SETQ LASTC CH) (COND ((AND (EQ NCOLONS 1) (NEQ PACKAGE *KEYWORD-PACKAGE*)) (* ; "Two colons in a row means internal symbol") (SETQ NCOLONS 2)) (T (* ; "Error, e.g., `FOO:::BAZ' or `::BAR'") (SETQ INVALIDFLG T) (GO GOTATOMCHAR)))) ((NULL NCOLONS) (* ; "We have just scanned the package name") (SETQ NCOLONS 1) (SETQ LASTC CH) (SETQ PACKAGE (COND (EXTRASEGMENTS (LISPERROR "ATOM TOO LONG" (\SUBREADCONCAT EXTRASEGMENTS PBASE J)) (SETQ EXTRASEGMENTS NIL)) ((\FIND.PACKAGE.INTERNAL PBASE 0 J \FATPNAMESTRINGP)) (T (* ; "Error, but don't signal yet -- save name as string for benefit of error handlers") (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)))) (SETQ J 0)) (T (* ; "Have alread seen one or more colons, and have scanned more symbol. This colon is an error.") (SETQ LASTC CH) (SETQ INVALIDFLG T) (GO GOTATOMCHAR))) (SETQ ESCAPEFLG T) (* ; "Result MUST be a symbol now") (GO NEXTATOMCHAR) SINGLECHARATOM (* ;; "Come here to create a symbol whose single character is CH -- no package stuff to worry about. This happens mainly for RATOM. We create the single char atom in IL for backward compatibility.") (\PNAMESTRINGPUTCHAR PBASE 0 CH) (SETQ ELT (\READ.SYMBOL PBASE 0 1 \FATPNAMESTRINGP *INTERLISP-PACKAGE*)) (replace (STREAM LASTCCODE) of STREAM with CH) (\RDCONC ELT (RETURN ELT)) (GO NEWTOKEN) (* ;; "End of atom scanning code") BREAK (* ;; "At this point, we have just read a break character, stored in CH") (replace (STREAM LASTCCODE) of STREAM with CH) (SELECTC SNX (LEFTPAREN.RC (* ;; "recursively read a list. If that list (or any of it's non-bracketed sublists) is terminated by a right bracket it terminates our read as well. PROPRB macro worries about right-bracket propagation: if the subread encounters a right bracket (sets \RBFLG), PROPRB returns true. In addition, if we were not called by a left-bracket (READTYPE = NOPROPRB.RT) it sets \RBFLG in caller, thereby propagating the bracket upward.") (COND ((PROG1 (PROPRB (SETQ ELT (\SUBREAD STREAM SA PROPRB.RT PNSTR CASEBASE))) (\RDCONC ELT (RETURN ELT))) (* ;; "PROG1 is true if the subread encountered a right bracket") (FIXDOT) (* ; "Fix dotted pair if necessary") (RETURN LST)))) (LEFTBRACKET.RC (* ;; "recursively read a list, terminated by either right paren or right bracket. In this case, right bracket is not propagated upward--we continue reading elements after it.") (SETQ ELT (\SUBREAD STREAM SA NOPROPRB.RT PNSTR CASEBASE)) (\RDCONC ELT (RETURN ELT))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Terminate one or more lists, return what we have accumulated so far. In the case of Right bracket, if caller did not have the matching left bracket, we have to allow the bracket to close more than one list.") (RETURN (COND (TOPLEVELP (* ;; "Naked right paren/bracket returns NIL. This is sort of bogus in common lisp, but changing it would be a significant change to Interlisp folks.") NIL) (CHAR (* ;; "call from READ-DELIMITED-LIST doesn't want to terminate this way. Could read as NIL and not terminate, but seems best to error.") (CL:ERROR "Unmatched ~A encountered while reading to a ~A" (CL:CODE-CHAR CH) (CL:CODE-CHAR CHAR)) LST) (T (FIXDOT) (AND (EQ SNX RIGHTBRACKET.RC) (NEQ READTYPE NOPROPRB.RT) (SETQ \RBFLG T)) LST)))) (STRINGDELIM.RC (* ;; "Invoke string reader") (SETQ ELT (\RSTRING2 STREAM SA NIL PNSTR)) (\RDCONC ELT (RETURN ELT))) (COND ((OR (EQ SNX BREAKCHAR.RC) (NOT (fetch READMACROFLG of *READTABLE*))) (* ; "A breakchar or a disabled always macro") (GO SINGLECHARATOM)) (T (GO MACRO)))) (GO NEWTOKEN) MACRO (SELECTQ (fetch MACROTYPE of (SETQ SNX (\GETREADMACRODEF CH *READTABLE*))) (MACRO (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (CL:MULTIPLE-VALUE-LIST (\APPLYREADMACRO STREAM SNX)))) (* ; "Ignore right-bracket if macro is called at top-level read")) (COND ((NULL ELT) (* ; "Macro returned zero values, read as nothing")) (T (SETQ ELT (CAR ELT)) (\RDCONC ELT (RETURN ELT))))) (FIXDOT) (* ; "Encountered right bracket if we get here -- return what we have") (RETURN LST)))) (INFIX (* ;; "We give macro TCONC list of what we've accumulated so far--it gets to modify it as it pleases and return it. We continue from there.") (COND ((PROG1 (PROPRB (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX (AND LST (CONS LST END)))))) (COND (TOPLEVELP (* ; "What does INFIX mean at top level?? See IRM") (COND ((AND (LISTP ELT) (CDR ELT)) (* ; "Result is in TCONC format, so it's returnable") (RETURN (COND ((EQ (CDR ELT) (CAR ELT)) (* ; "TCONC list of one element--return the element. This is how INFIX top level macro can return a non-list. ") (CAAR ELT)) (T (CAR ELT))))))) (T (* ; "Reading sublist. Take apart TCONC list and continue.") (SETQ LST (CAR ELT)) (SETQ END (CDR ELT))))) (FIXDOT) (* ; "Macro hit right bracket if we got to here") (RETURN LST)))) (SPLICE (* ;; "Macro returns arbitrary number of values to be spliced inline.") (RBCONTEXT (SETQ ELT (RELEASERESOURCE \PNAMESTRING PNSTR (\APPLYREADMACRO STREAM SNX)))) (* ; "Note: we don't care if there was terminating right-bracket") (* ; "Why? -bvm") (COND ((OR (NULL ELT) TOPLEVELP) (* ;; "On the 10, it actually returns ELT if it is a list and the next token is a closing paren or bracket. Hard to see how to get that behavior--rmk") (GO NEWTOKEN)) ((NLISTP ELT) (* ; "The 10 throws initial non-lists away (What if LST/END aren't set?)") (SETQ ELT (AND LST (LIST (QUOTE %.) ELT))) (SETQ DOTLOC END))) (COND ((NOT *READ-SUPPRESS*) (COND (LST (RPLACD END ELT)) (T (SETQ LST ELT))) (SETQ END (LAST ELT)) (COND ((CDR END) (* ; "A dotted pair") (SETQ DOTLOC END) (RPLACD END (CONS (QUOTE %.) (SETQ END (CONS (CDR END)))))))))) (SHOULDNT)) (GO NEWTOKEN))) +) + +(\SUBREADCONCAT +(LAMBDA (EXTRASEGMENTS PBASE J) (* ; "Edited 16-Jan-87 15:08 by bvm:") (* ;; "Produces a string consisting of all the characters \SUBREAD has been buffering up into a token. Last J chars are stored at PBASE. EXTRASEGMENTS is a list of strings in reverse order in the case that more characters were scanned than the pname string accommodates.") (SETQ PBASE (\GETBASESTRING PBASE 0 J \FATPNAMESTRINGP)) (if EXTRASEGMENTS then (CONCATLIST (NCONC1 (REVERSE EXTRASEGMENTS) PBASE)) else PBASE)) +) + +(\READ.SYMBOL +(LAMBDA (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) (* bvm%: " 3-Aug-86 15:25") (* ;;; "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external. NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped.") (* ;;; "For now a dummy definition") (COND (PACKAGE (* ; "For debugging") (CONCAT PACKAGE (COND (EXTERNALP ":") (T "::")) (\GETBASESTRING BASE OFFSET LEN FATP))) (T (OR (AND (NOT NONNUMERICP) (\PARSE.NUMBER BASE OFFSET LEN FATP)) (\MKATOM BASE OFFSET LEN FATP T))))) +) + +(\INVALID.SYMBOL +(LAMBDA (BASE LEN NCOLONS PACKAGE EXTRASEGMENTS) (* ; "Edited 15-Jan-87 17:33 by bvm:") (* ;;; "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon. If return from here, will read the symbol as though the extra colons were escaped.") (CL:CERROR "Treat the extra colon(s) as if they were escaped" "Invalid symbol syntax in %"~A%"" (CONCAT (if (AND PACKAGE (NEQ PACKAGE *KEYWORD-PACKAGE*)) then (if (STRINGP PACKAGE) then PACKAGE else (CL:PACKAGE-NAME PACKAGE)) else "") (SELECTQ NCOLONS (1 ":") (2 "::") "") (\SUBREADCONCAT EXTRASEGMENTS BASE LEN)))) +) + +(\APPLYREADMACRO +(LAMBDA (STREAM MACDEF ANSCELL) (* bvm%: " 4-May-86 16:38") (* ; "INREADMACROP searches for this framename") (DECLARE (USEDFREE *READTABLE*)) (APPLY* (fetch MACROFN of MACDEF) STREAM *READTABLE* ANSCELL)) +) + +(INREADMACROP +(LAMBDA NIL (* edited%: "26-MAY-79 00:12") (PROG (TEM (\READDEPTH -1)) (DECLARE (SPECVARS \READDEPTH)) (COND ((NULL (SETQ TEM (STKPOS (QUOTE \APPLYREADMACRO)))) (RETURN NIL))) (MAPDL (FUNCTION (LAMBDA (NM POS) (COND ((EQ NM (QUOTE \SUBREAD)) (SETQ \READDEPTH (ADD1 \READDEPTH)))))) TEM) (RELSTK TEM) (RETURN \READDEPTH))) +) +) + + + +(* ; "Read macro for '") + +(DEFINEQ + +(READQUOTE +(LAMBDA (FILE) (* ; "Edited 19-Mar-87 16:10 by bvm:") (LIST (QUOTE QUOTE) (CL:READ FILE T NIL T)))) +) + + + +(* ; "# macro") + +(DEFINEQ + +(READVBAR +(LAMBDA (STREAM RDTBL) (* bvm%: "14-May-86 17:31") (* ;;; "Read Interlisp's | macro. Originally this char was just a sepr in FILERDTBL but was then extended in various hokey ways, because it was the only character plausibly available for redefinition. Today it is extended still further to be Common Lisp # in all the cases not already taken by some other meaning") (SELCHARQ (PEEKCCODE STREAM) (%' (* ; "commonlisp defines #'X to mean (FUNCTION X), but here it's BQUOTE") (READCCODE STREAM) (READBQUOTE STREAM RDTBL)) ((%( { ^) (* ; "Used by HPRINT") (HREAD STREAM)) (%# (READCCODE STREAM) (* ; "|# = Common Lisp #") (READHASHMACRO STREAM RDTBL)) ((EOL TAB SPACE) (* ; "CR or tab, treat as separator") (CL:VALUES)) (PROGN (* ; "Everything else not already preempted by old-style | is interpreted as Common Lisp") (READHASHMACRO STREAM RDTBL)))) +) + +(READHASHMACRO +(LAMBDA (STREAM RDTBL INDEX) (* amd "15-Oct-86 16:36") (* ;;; "Implements the standard # macro dispatch -- reads next character to find out what to do. Can return zero values if we just want to skip something.") (LET ((READFN (COND ((fetch (READTABLEP COMMONLISP) of RDTBL) (* ;; "Kludge: if we have to recursively read something that will not end up as the resulting list structure, use the reader that passes thru CMLTRANSLATE") (FUNCTION CL:READ)) (T (FUNCTION READ)))) NEXTCHAR READVAL) (while (DIGITCHARP (SETQ NEXTCHAR (PEEKCCODE STREAM RDTBL))) do (SETQ INDEX (PLUS (TIMES (OR INDEX 0) 10) (DIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (SELCHARQ NEXTCHAR ("(" (LET ((CONTENTS (APPLY* READFN STREAM))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS))))) (PROGN (* ; "Those cases we left the dispatching char in buffer for convenience of the next read. Now eat it") (SELCHARQ (READCCODE STREAM RDTBL) (%' (LIST (QUOTE FUNCTION) (READ STREAM RDTBL))) (%. (EVAL (APPLY* READFN STREAM))) (%, (LIST (QUOTE LOADTIMECONSTANT) (READ STREAM RDTBL))) (\ (CHARACTER.READ STREAM)) ("*" (* ; "Read bit vector") (LET ((CONTENTS (while (MEMQ (PEEKCCODE STREAM RDTBL) (CHARCODE (0 1))) collect (IDIFFERENCE (READCCODE STREAM RDTBL) (CHARCODE 0))))) (COND (INDEX (FILL-VECTOR (CL:MAKE-ARRAY INDEX :ELEMENT-TYPE (QUOTE BIT)) CONTENTS)) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS :ELEMENT-TYPE (QUOTE BIT)))))) (":" (* ;; "The same thing HASH-COLON does.") (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM RDTBL))) ((O o) (READNUMBERINBASE STREAM 8)) ((B b) (READNUMBERINBASE STREAM 2)) ((X x) (READNUMBERINBASE STREAM 16)) ((R r) (READNUMBERINBASE STREAM INDEX)) ((A a) (LET ((CONTENTS (APPLY* READFN STREAM))) (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY INDEX CONTENTS) :INITIAL-CONTENTS CONTENTS))) ((S s) (CREATE-STRUCTURE (APPLY* READFN STREAM))) ((C c) (DESTRUCTURING-BIND (NUM DEN) (APPLY* READFN STREAM) (COMPLEX NUM DEN))) (+ (* ; "Skip expression if feature not present") (COND ((NOT (CMLREAD.FEATURE.PARSER (READ STREAM RDTBL))) (CL:READ STREAM RDTBL))) (CL:VALUES)) (- (* ; "Skip expression if feature IS present") (COND ((CMLREAD.FEATURE.PARSER (READ STREAM RDTBL)) (CL:READ STREAM RDTBL))) (CL:VALUES)) ("|" (* ; "special comment") (SKIP.HASH.COMMENT STREAM RDTBL) (CL:VALUES)) (< (ERROR "#< construct is un-READ-able" (READ))) ((SPACE TAB NEWLINE PAGE RETURN %)) (ERROR "Illegal read syntax " (CHARCODE.UNDECODE NEXTCHAR))) (%" (* ; "An extension -- read string without cr's and leading spaces") (RSTRING STREAM RDTBL (QUOTE SKIP))) (APPLY* (OR (GET (CHARACTER NEXTCHAR) (QUOTE HASHREADMACRO)) (ERROR "Undefined hashmacro char" NEXTCHAR)) STREAM RDTBL)))))) +) + +(DEFMACRO-LAMBDA-LIST-KEYWORD-P +(LAMBDA (S) (* bvm%: " 3-Nov-86 15:12") (AND (FMEMB S (QUOTE (&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS &AUX &BODY &WHOLE))) T)) +) + +(DIGITBASEP +(LAMBDA (CODE RADIX) (* lmm "11-Jun-85 00:54") (COND ((AND (GEQ CODE (CHARCODE 0)) (LESSP CODE (PLUS (CHARCODE 0) RADIX))) (DIFFERENCE CODE (CHARCODE 0))) ((GREATERP RADIX 10) (COND ((AND (GEQ CODE (CHARCODE a)) (LEQ CODE (CHARCODE z))) (add CODE (DIFFERENCE (CHARCODE A) (CHARCODE a))))) (COND ((AND (GEQ CODE (CHARCODE A)) (LEQ CODE (CHARCODE Z))) (SETQ CODE (PLUS 10 (DIFFERENCE CODE (CHARCODE A)))) (COND ((LESSP CODE RADIX) CODE))))))) +) + +(READNUMBERINBASE +(LAMBDA (STREAM RADIX) (* bvm%: " 4-Nov-86 21:34") (PROG ((BODY (READ-EXTENDED-TOKEN STREAM)) (I 1) CH VAL NUMERATOR SIGN BASE) (* ; "First check for leading sign") (if *READ-SUPPRESS* then (* ; "work is done") (RETURN NIL)) (SELCHARQ (SETQ CH (NTHCHARCODE BODY 1)) (+ (GO NEXTCH)) (- (SETQ SIGN T) (GO NEXTCH)) NIL) LP (if (SETQ BASE (DIGITBASEP CH RADIX)) then (SETQ VAL (+ (TIMES (OR VAL 0) RADIX) BASE)) elseif (EQ CH (CHARCODE "/")) then (* ; "Ratio marker") (if (OR NUMERATOR (NULL VAL)) then (GO MALFORMED)) (SETQ NUMERATOR VAL) (SETQ VAL NIL) else (* ; "Terminated by a character that is not a token delimiter") (GO MALFORMED)) NEXTCH (if (SETQ CH (NTHCHARCODE BODY (add I 1))) then (GO LP) else (* ; "end of token, fall thru")) DONE (if (NULL VAL) then (GO MALFORMED)) (if NUMERATOR then (SETQ VAL (%%/ NUMERATOR VAL))) (RETURN (if SIGN then (- VAL) else VAL)) MALFORMED (RETURN (CL:ERROR "Malformed base ~D rational ~S" RADIX BODY)))) +) + +(ESTIMATE-DIMENSIONALITY +(LAMBDA (RANK CONTENTS) (* bvm%: " 9-May-86 16:06") (COND ((NULL RANK) (ERROR "No rank found while reading array" NIL)) ((EQ RANK 0) NIL) (T (to RANK as (D _ CONTENTS) by (CAR D) collect (LENGTH D))))) +) + +(SKIP.HASH.COMMENT +(LAMBDA (STREAM RDTBL) (* bvm%: "12-Sep-86 21:02") (PROG NIL (* ;; "a tiny fsm that recognizes #| ... |# with possible nestings of itself") LP (SELCHARQ (READCCODE STREAM RDTBL) ("#" (GO SHARP)) ("|" (GO VBAR)) (GO LP)) SHARP (SELCHARQ (READCCODE STREAM RDTBL) ("|" (* ; "#| -- recursively skip nested section") (SKIP.HASH.COMMENT STREAM RDTBL) (GO LP)) ("#" (GO SHARP)) (GO LP)) VBAR (SELCHARQ (READCCODE STREAM RDTBL) ("|" (GO VBAR)) ("#" (* ; "found closing |#") (RETURN)) (GO LP)))) +) + +(CMLREAD.FEATURE.PARSER +(LAMBDA (EXPR) (* bvm%: " 3-Nov-86 15:07") (COND ((CL:CONSP EXPR) (SELECTQ (CAR EXPR) ((:AND AND) (EVERY (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:OR OR) (SOME (CDR EXPR) (FUNCTION CMLREAD.FEATURE.PARSER))) ((:NOT NOT) (NOT (CMLREAD.FEATURE.PARSER (CADR EXPR)))) (ERROR "Bad feature expression" EXPR))) ((FMEMB EXPR *FEATURES*) T))) +) +) + + + +(* ; "Reading characters with #\") + +(DEFINEQ + +(CHARACTER.READ +(LAMBDA (STREAM) (* bvm%: " 4-Nov-86 21:50") (* ;;; "Called by the #\ macro -- reads a character object consisting of the thing next named") (LET ((NEXTCHAR (READCCODE STREAM)) CH) (COND ((OR (NULL (SETQ CH (PEEKCCODE STREAM T))) (fetch STOPATOM of (\SYNCODE (fetch READSA of *READTABLE*) CH))) (* ; "Terminates next, so it's just this char") (CL:CODE-CHAR NEXTCHAR)) (*READ-SUPPRESS* (* ; "don't try to decode it, could be illegal") (READ-EXTENDED-TOKEN STREAM) NIL) (T (* ; "Read a whole name, up to the next break/sepr") (CL:CODE-CHAR (CHARCODE.DECODE (CONCAT (ALLOCSTRING 1 NEXTCHAR) (READ-EXTENDED-TOKEN STREAM)))))))) +) + +(CHARCODE.DECODE +(LAMBDA (C NOERROR) (* ; "Edited 18-Feb-87 22:03 by bvm:") (DECLARE (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES)) (COND ((NOT C) NIL) ((LISTP C) (CONS (CHARCODE.DECODE (CAR C) NOERROR) (CHARCODE.DECODE (CDR C) NOERROR))) ((NOT (OR (ATOM C) (STRINGP C))) (AND (NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))) ((EQ (NCHARS C) 1) (CHCON1 C)) (T (SELCHARQ (CHCON1 C) (^ (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (LOGAND C (LOGNOT 96)))) (%# (* ;; "We use IPLUS instead of LOGOR here because some people want ##char to read as Xerox Meta, i.e., 1,char") (AND (SETQ C (CHARCODE.DECODE (SUBSTRING C 2 -1) NOERROR)) (IPLUS C 128))) (LET ((STR (MKSTRING C))) (for X in CHARACTERNAMES when (STRING.EQUAL (CAR X) STR) do (RETURN (OR (NUMBERP (CADR X)) (CHARCODE.DECODE (CADR X) NOERROR))) finally (RETURN (LET ((POS (STRPOSL (QUOTE (%, - "." "|")) STR)) CH CSET) (* ; "In the form charset,char") (COND ((AND POS (SETQ CH (OR (CL:PARSE-INTEGER STR :START POS :RADIX 8 :JUNK-ALLOWED T) (CHARCODE.DECODE (SUBSTRING STR (ADD1 POS)) NOERROR))) (< CH 256) (>= CH 0)) (* ; "parsed the char part as an octal number or character spec") (if (AND (SETQ CSET (OR (CL:PARSE-INTEGER STR :END (SUB1 POS) :RADIX 8 :JUNK-ALLOWED T) (for PAIR in CHARACTERSETNAMES first (SETQ POS (SUBSTRING STR 1 (SUB1 POS))) when (STRING.EQUAL (CAR PAIR) POS) do (RETURN (CADR PAIR))))) (< CSET 256) (>= CSET 0)) then (* ; "parsed the charset part as an octal number or standard charset name") (LOGOR CH (LLSH CSET 8)) elseif (NOT NOERROR) then (ERROR "BAD CHARACTERSET SPECIFICATION" C))) ((NOT NOERROR) (ERROR "BAD CHARACTER SPECIFICATION" C))))))))))) +) +) + +(RPAQQ CHARACTERNAMES + (("Page" 12) + ("Form" 12) + ("FF" 12) + ("Rubout" 127) + ("Del" 127) + ("Null" 0) + ("Escape" 27) + ("Esc" 27) + ("Bell" 7) + ("Tab" 9) + ("Backspace" 8) + ("Bs" 8) + ("Newline" 13) + ("CR" 13) + ("EOL" 13) + ("Return" 13) + ("Tenexeol" 31) + ("Space" 32) + ("Sp" 32) + ("Linefeed" 10) + ("LF" 10))) + +(RPAQQ CHARACTERSETNAMES (("Greek" 38) + ("Cyrillic" 39) + ("Hira" 36) + ("Hiragana" 36) + ("Kata" 37) + ("Katakana" 37) + ("Kanji" 48))) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(RPAQQ READTYPES (READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT)) +(DECLARE%: EVAL@COMPILE + +(RPAQQ READ.RT NIL) + +(RPAQQ RATOM.RT 1) + +(RPAQQ NOPROPRB.RT T) + +(RPAQQ PROPRB.RT 0) + + +(CONSTANTS READ.RT RATOM.RT NOPROPRB.RT PROPRB.RT) +) + +(DECLARE%: EVAL@COMPILE + +(PUTPROPS .CALL.SUBREAD. MACRO ((STREAM EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE) + (WITH-RESOURCE (\PNAMESTRING) + (\SUBREAD (\GETSTREAM STREAM 'INPUT) + (fetch (READTABLEP READSA) of + *READTABLE* + ) + (COND + (CHAR -1) + (T READ.RT)) + \PNAMESTRING + (AND (fetch (READTABLEP CASEINSENSITIVE) + of *READTABLE*) + (fetch (ARRAYP BASE) of + UPPERCASEARRAY + )) + EOF-SUPPRESS EOF-VALUE CHAR PRESERVE-WHITESPACE + )))) + +(PUTPROPS FIXDOT MACRO [NIL (PROGN (* ; + "Fix a non-first dot followed by a singleton") + (AND DOTLOC (CDDR DOTLOC) + (NULL (CDDDR DOTLOC)) + (RPLACD DOTLOC (CADDR DOTLOC]) + +(PUTPROPS RBCONTEXT MACRO ((X . Y) + ([LAMBDA (\RBFLG) + (DECLARE (SPECVARS \RBFLG)) + (PROGN X . Y) + \RBFLG] + NIL))) + +(PUTPROPS PROPRB MACRO [(X . Y) (* ; + "Propagates the right-bracket flag") + (AND (RBCONTEXT X . Y) + (OR (EQ READTYPE NOPROPRB.RT) + (SETQ \RBFLG T]) + +(PUTPROPS \RDCONC MACRO [(ELT . TOPFORMS) + + (* ;; "Add ELT to the accumulating list to be returned by \SUBREAD. If at top level and no list accumulated, then run TOPFORMS") + + (COND + [LST (RPLACD END (SETQ END (CONS ELT] + (TOPLEVELP . TOPFORMS) + ((NOT *READ-SUPPRESS*) (* ; + "Don't bother consing the result if it's going to be thrown away") + (SETQ END (SETQ LST (CONS ELT]) +) + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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 + ['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 '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 + ('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 + ('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)) +) + +(* "END EXPORTED DEFINITIONS") + + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(SPECVARS *READ-NEWLINE-SUPPRESS* \RefillBufferFn) +) + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*) +) +) + + + +(* ; "Support for various external formats") + + + + +(* ; "JIS to XCCS conversion table.") + + +(RPAQQ *JIS-TO-XCCS-CONV-NO-FONT-TABLE* + ((8484 . 8484) + (8485 . 8485) + (8497 . 9155) + (8798 . 61376) + (8802 . 8802) + (8805 . 64892) + (8806 . 64894) + (8820 . 9148) + (8821 . 9132) + (8822 . 213) + (8830 . 8830) + (10273 . 61189) + (10274 . 61188) + (10275 . 10275) + (10276 . 10276) + (10277 . 10277) + (10278 . 10278) + (10279 . 10279) + (10280 . 10280) + (10281 . 10281) + (10282 . 10282) + (10283 . 61414) + (10284 . 61410) + (10285 . 61409) + (10286 . 10286) + (10287 . 10287) + (10288 . 10288) + (10289 . 10289) + (10290 . 10290) + (10291 . 10291) + (10292 . 10292) + (10293 . 10293) + (10294 . 61411) + (10295 . 10295) + (10296 . 10296) + (10297 . 10297) + (10298 . 10298) + (10299 . 10299) + (10300 . 10300) + (10301 . 10301) + (10302 . 10302) + (10303 . 10303) + (10304 . 10304))) + +(RPAQQ *JIS-TO-XCCS-CODE-MAP* + ((1 (1 33 . 33) + (2 33 . 34) + (3 33 . 35) + (6 0 . 183) + (7 0 . 58) + (8 0 . 59) + (9 0 . 63) + (10 0 . 33) + (11 33 . 43) + (12 33 . 44) + (13 0 . 194) + (14 0 . 193) + (15 0 . 200) + (16 0 . 195) + (18 0 . 204) + (19 33 . 51) + (20 33 . 52) + (21 33 . 53) + (22 33 . 54) + (23 33 . 55) + (24 33 . 56) + (25 33 . 57) + (26 33 . 58) + (27 33 . 59) + (28 33 . 60) + (29 239 . 36) + (30 33 . 62) + (31 0 . 47) + (32 0 . 92) + (33 0 . 126) + (34 33 . 66) + (35 0 . 124) + (36 33 . 68) + (37 33 . 69) + (38 0 . 169) + (39 0 . 39) + (40 0 . 170) + (41 0 . 186) + (42 0 . 40) + (43 0 . 41) + (44 33 . 76) + (45 33 . 77) + (46 0 . 91) + (47 0 . 93) + (48 0 . 123) + (49 0 . 125) + (50 239 . 50) + (51 239 . 51) + (52 0 . 171) + (53 0 . 187) + (54 33 . 86) + (55 33 . 87) + (56 33 . 88) + (57 33 . 89) + (58 33 . 90) + (59 33 . 91) + (60 0 . 43) + (61 0 . 45) + (62 0 . 177) + (63 0 . 180) + (64 0 . 184) + (65 0 . 61) + (66 33 . 98) + (67 0 . 60) + (68 0 . 62) + (69 33 . 101) + (70 33 . 102) + (71 33 . 103) + (72 33 . 104) + (73 33 . 105) + (74 33 . 106) + (75 0 . 176) + (76 33 . 108) + (77 33 . 109) + (78 33 . 110) + (79 0 . 165) + (80 0 . 164) + (81 0 . 162) + (82 0 . 163) + (83 0 . 37) + (84 0 . 35) + (85 0 . 38) + (86 0 . 42) + (87 0 . 64) + (88 0 . 167) + (89 33 . 121) + (90 33 . 122) + (91 33 . 123) + (92 33 . 124) + (93 33 . 125) + (94 33 . 126)) + (2 (1 34 . 33) + (2 34 . 34) + (3 34 . 35) + (4 34 . 36) + (5 34 . 37) + (6 34 . 38) + (7 34 . 39) + (8 34 . 40) + (9 34 . 41) + (10 0 . 174) + (11 0 . 172) + (12 0 . 173) + (13 0 . 175) + (14 34 . 46) + (26 239 . 74) + (27 239 . 76) + (28 239 . 89) + (29 239 . 88) + (30 239 . 91) + (31 239 . 90) + (32 239 . 87) + (33 239 . 86) + (42 239 . 182) + (43 239 . 183) + (44 239 . 106) + (45 239 . 79) + (46 239 . 78) + (47 239 . 181) + (48 239 . 180) + (60 239 . 108) + (61 239 . 112) + (63 239 . 186) + (64 239 . 185) + (65 239 . 114) + (67 239 . 66) + (68 239 . 67) + (71 239 . 113) + (72 239 . 111) + (73 239 . 117) + (74 34 . 106) + (82 241 . 40) + (83 239 . 65) + (87 239 . 48) + (88 239 . 49) + (89 0 . 176)) + (6 (1 38 . 65) + (2 38 . 66) + (3 38 . 68) + (4 38 . 69) + (5 38 . 70) + (6 38 . 73) + (7 38 . 74) + (8 38 . 75) + (9 38 . 76) + (10 38 . 77) + (11 38 . 78) + (12 38 . 79) + (13 38 . 80) + (14 38 . 81) + (15 38 . 82) + (16 38 . 83) + (17 38 . 85) + (18 38 . 86) + (19 38 . 88) + (20 38 . 89) + (21 38 . 90) + (22 38 . 91) + (23 38 . 92) + (24 38 . 93) + (33 38 . 97) + (34 38 . 98) + (35 38 . 100) + (36 38 . 101) + (37 38 . 102) + (38 38 . 105) + (39 38 . 106) + (40 38 . 107) + (41 38 . 108) + (42 38 . 109) + (43 38 . 110) + (44 38 . 111) + (45 38 . 112) + (46 38 . 113) + (47 38 . 114) + (48 38 . 115) + (49 38 . 117) + (50 38 . 118) + (51 38 . 120) + (52 38 . 121) + (53 38 . 122) + (54 38 . 123) + (55 38 . 124) + (56 38 . 125)))) + +(RPAQQ *HANKAKU-TO-ZENKAKU-CODE-MAP* + ((161 . 8483) + (162 . 8534) + (163 . 8535) + (164 . 8482) + (165 . 183) + (166 . 9586) + (167 . 9505) + (168 . 9507) + (169 . 9509) + (170 . 9511) + (171 . 9513) + (172 . 9571) + (173 . 9573) + (174 . 9575) + (175 . 9539) + (176 . 8508) + (177 . 9506) + (178 . 9508) + (179 . 9510) + (180 . 9512) + (181 . 9514) + (182 . 9515) + (183 . 9517) + (184 . 9519) + (185 . 9521) + (186 . 9523) + (187 . 9525) + (188 . 9527) + (189 . 9529) + (190 . 9531) + (191 . 9533) + (192 . 9535) + (193 . 9537) + (194 . 9540) + (195 . 9542) + (196 . 9544) + (197 . 9546) + (198 . 9547) + (199 . 9548) + (200 . 9549) + (201 . 9550) + (202 . 9551) + (203 . 9554) + (204 . 9557) + (205 . 9560) + (206 . 9563) + (207 . 9566) + (208 . 9567) + (209 . 9568) + (210 . 9569) + (211 . 9570) + (212 . 9572) + (213 . 9574) + (214 . 9576) + (215 . 9577) + (216 . 9578) + (217 . 9579) + (218 . 9580) + (219 . 9581) + (220 . 9583) + (221 . 9587) + (222 . 8491) + (223 . 8492))) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *JIS-TO-XCCS-CONV-NO-FONT-TABLE* *JIS-TO-XCCS-CONV-TABLE-LIST* *JIS-TO-XCCS-CODE-MAP* + *HANKAKU-TO-ZENKAKU-CODE-MAP* *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* + *JIS-6KU-TO-XCCS-CONV-TABLE* *XCCS-TO-JIS-CONV-TABLE* *HANKAKU-TO-ZENKAKU-CONV-TABLE* + *ZENKAKU-TO-HANKAKU-CONV-TABLE*) +) +(DEFINEQ + +(\MAKE.JIS.TO.XCCS.CONV.TABLE +(LAMBDA NIL (* ; "Edited 20-Feb-91 19:28 by nm") (* ;;; "The JIS codes which are not equivalent to XCCS reside in 1, 2, 3, 6, 8 and 84 KU. In case of 3 and 84 KU, the corresponding XCCS is calicutated from JIS. In case of 1,2 and 6 KU, we have to prepare conversion tables for each because the mapping between XCCS and JIS are random. 8 KU is treated specially because no displayable font is assigned for 8 KU in XCCS. They are handled with *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "Each conversion table is an byte array of size 188 (94 * 2). 94 is a largest number of TEN. TEN is one origin. Each JIS code is represented with two bytes in the table. The first byte is a character set and the second byte is a character code in XCCS. If both of the first byte and the second byte are 255, it means the JIS code is not defined for the entry. If the first byte is 255 and the second byte is 0, it means a JIS code is defined for the entry and there is a XCCS code corresponding to the JIS code, but no displayable font is assigned for the code in XCCS. In the last case, the real XCCS code is found in *JIS-TO-XCCS-CONV-NO-FONT-TABLE*.") (* ;;; "*HANKAKU-TO-ZENKAKU-CONV-TABLE* holds the mapping between JIS HANAKAKU-KANA code to XCCS. XCCS does not support HANKAKU code.") (SETQ *JIS-1KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-2KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *JIS-6KU-TO-XCCS-CONV-TABLE* (ARRAY 188 (QUOTE BYTE) 255)) (SETQ *XCCS-TO-JIS-CONV-TABLE* (HASHARRAY 256)) (SETQ *HANKAKU-TO-ZENKAKU-CONV-TABLE* (HASHARRAY 64)) (SETQ *ZENKAKU-TO-HANKAKU-CONV-TABLE* (HASHARRAY 64)) (CL:DO ((TABLES (LIST *JIS-1KU-TO-XCCS-CONV-TABLE* *JIS-2KU-TO-XCCS-CONV-TABLE* *JIS-6KU-TO-XCCS-CONV-TABLE*) (CDR TABLES)) (KU (QUOTE (1 2 6)) (CDR KU)) CODEMAP) ((CL:ENDP TABLES)) (SETQ CODEMAP (CDR (ASSOC (CAR KU) *JIS-TO-XCCS-CODE-MAP*))) (for MAP in CODEMAP do (SETA (CAR TABLES) (IDIFFERENCE (UNFOLD (CAR MAP) 2) 1) (CADR MAP)) (SETA (CAR TABLES) (UNFOLD (CAR MAP) 2) (CDDR MAP)))) (bind KU TEN TABLE for ENTRY in *JIS-TO-XCCS-CONV-NO-FONT-TABLE* do (SETQ KU (IDIFFERENCE (FOLDLO (CAR ENTRY) 256) 32)) (SETQ TABLE (SELECTQ KU (1 *JIS-1KU-TO-XCCS-CONV-TABLE*) (2 *JIS-2KU-TO-XCCS-CONV-TABLE*) (6 *JIS-6KU-TO-XCCS-CONV-TABLE*) NIL)) (AND TABLE (SETA TABLE (UNFOLD (IDIFFERENCE (LOGAND 255 (CAR ENTRY)) 32) 2) 0))) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CAR MAP) (CDR MAP) *HANKAKU-TO-ZENKAKU-CONV-TABLE*)) (for MAP in *HANKAKU-TO-ZENKAKU-CODE-MAP* do (PUTHASH (CDR MAP) (CAR MAP) *ZENKAKU-TO-HANKAKU-CONV-TABLE*)) (for MAP in (APPEND (for KU in *JIS-TO-XCCS-CODE-MAP* join (for TEN in (CDR KU) collect (BQUOTE ((\, (LOGOR (UNFOLD (CADR TEN) 256) (CDDR TEN))) \, (LOGOR (UNFOLD (IPLUS (CAR KU) 32) 256) (IPLUS (CAR TEN) 32)))))) *JIS-TO-XCCS-CONV-NO-FONT-TABLE*) do (PUTHASH (CAR MAP) (CDR MAP) *XCCS-TO-JIS-CONV-TABLE*)) (SETQ *JIS-TO-XCCS-CONV-TABLE-LIST* (BQUOTE ((33 \, *JIS-1KU-TO-XCCS-CONV-TABLE*) (34 \, *JIS-2KU-TO-XCCS-CONV-TABLE*) (38 \, *JIS-6KU-TO-XCCS-CONV-TABLE*))))) +) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(\MAKE.JIS.TO.XCCS.CONV.TABLE) +) + + + +(* ; "JIS to XCCS converter") + + +(RPAQ? *REPLACE-NO-FONT-CODE* T) + +(RPAQ? *DEFAULT-NOT-CONVERTED-FAT-CODE* 8739) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS *REPLACE-NO-FONT-CODE* *DEFAULT-NOT-CONVERTED-FAT-CODE*) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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*]) +) + +(* "END EXPORTED DEFINITIONS") + +) + + + +(* ; "XCCS to JIS converter") + +(DEFINEQ + +(CONVHANKAKU +(LAMBDA ARGS (* ; "Edited 8-Feb-91 13:42 by nm") (PROG1 (STREAMPROP (ARG ARGS 1) :HTOZP) (AND (> ARGS 1) (STREAMPROP (ARG ARGS 1) :HTOZP (ARG ARGS 2))))) +) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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*))) +) + +(* "END EXPORTED DEFINITIONS") + +) +(DEFINEQ + +(\JISIN +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:47 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG (CH1 CH2 CH3 (IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0)) RETRY (AND (SETQ CH1 (\BIN STREAM)) (COND ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (SETQ CH2 (\BIN STREAM)) (COND ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Here we have to try the same preocedure again, because bogus duplicated KI/KO sequence might come again!") (SETQ IN16BITFLG T) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (SETQ CH3 (\BIN STREAM)) (COND ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (* ; "Oops. Yes, we have to try again to ignore duplicated KI/KO sequence.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) (IPLUS 1 CHARNUM)))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)) (IPLUS 2 CHARNUM)))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 (\BIN STREAM)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) (IPLUS 1 CHARNUM)))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 (IPLUS 1 CHARNUM)))) (T (RETURN CH1)))))))) +) + +(\JISPEEK +(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:27 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with JIS. Allows the incorrect usage of KI and KO based on the two different JIS, OLDJIS and NEWJIS, because it is very likely that these two different sets of KI and KO are used simultaneously, although it is against a standard! May actually read the KI or KO. ") (* ;;; "If COUNTP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((IN16BITFLG (\KIMODEP STREAM T)) (CHARNUM 0) (CH1 (\PEEKBIN STREAM NOERROR)) CH2 CH3) RETRY (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH1 (CHARCODE ESC)) (* ; "Might be KI or KO.") (\BIN STREAM) (* ; "Consume the first ESC.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH2) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((EQ CH2 (CHARCODE $)) (* ; "Might be KI") (\BIN STREAM) (* ; "Consume the $.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE B)) (EQ CH3 (CHARCODE @))) (* ; "KI") (\CHNAGE.KI.MODE STREAM T T) (AND COUNTP (SETQ CHARNUM (IPLUS CHARNUM 3))) (\BIN STREAM) (* ; "Consume the B or @.") (SETQ IN16BITFLG T) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) ((EQ CH2 (CHARCODE %()) (* ; "Might be KO") (\BIN STREAM) (* ; "Consume the (.") (SETQ CH3 (\PEEKBIN STREAM NOERROR)) (COND ((NULL CH3) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))) ((OR (EQ CH3 (CHARCODE J)) (EQ CH3 (CHARCODE H))) (* ; "KO") (\CHNAGE.KI.MODE STREAM T NIL) (AND COUNTP (SETQ CHARNUM 3)) (\BIN STREAM) (* ; "Consume the J or H.") (SETQ IN16BITFLG NIL) (GO RETRY)) (T (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (IN16BITFLG (* ; "Under processing 16 bit code.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (CHARCODE ESC) CHARNUM))) (T (RETURN (CHARCODE ESC))))))) (IN16BITFLG (* ; "Under processing 16 bit code.") (\BIN STREAM) (* ; "Consume the first byte.") (SETQ CH2 (\PEEKBIN STREAM NOERROR)) (\BACKFILEPTR STREAM) (COND (CH2 (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) CHARNUM))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (COND (COUNTP (RETURN (CL:VALUES NIL CHARNUM))) (T (RETURN NIL)))))) ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA is converted to ZENKAKU-KATAKANA because XCCS does not support HANKAKU-KATAKANA.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) CHARNUM))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ;; "C0, SP, DEL, C1, 10/0, or 15/15 of 0 character set.") (COND (COUNTP (RETURN (CL:VALUES CH1 CHARNUM))) (T (RETURN CH1))))))) +) + +(\BACKJISCHAR +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\KIMODEP STREAM T) (COND ((\BACKFILEPTR STREAM) (AND COUNTP 2)) (T (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0))) +) + +(\SHIFTJISIN +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:49 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that..") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\CONV.SJIS.TO.JIS CH1 (\BIN STREAM)) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 2)) (T (\CONV.JIS.TO.XCCS CH1 CH2)))) (T (* ; "ASCII or HANKAKU-KATAKANA") (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA CH1) 1)) (T (\CONV.HANKAKU.KANA CH1)))) (T (* ; "ASCII") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1))))))))) +) + +(\SHIFTJISPEEK +(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:30 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with Shift-JIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL)))) ((\SJIS.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\CONV.SJIS.TO.JIS CH1 CH2) (* ; "CH1 and CH2 is adjusted to represent JIS code in \CONV.SJIS.TO.JIS.") (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS CH1 CH2) 0))) (T (RETURN (\CONV.JIS.TO.XCCS CH1 CH2))))) (T (* ; "ASCII or HANKAKU-KATAKANA") (RETURN (COND ((\HANKAKUP CH1) (* ; "HANKAKU-KATAKANA") (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH1) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH1))))) (T (* ; "ASCII") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1)))))))))) +) + +(\BACKSHIFTJISCHAR +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:05 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((\BACKFILEPTR STREAM) (COND ((\SJIS.KANJI.FIRST.BYTEP (\PEEKBIN STREAM)) (AND COUNTP 2)) (T (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 0))) +) + +(\EUCIN +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 15:54 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. ") (* ;;; "If COUNP is non-NIL, the number of bytes read is returned as a second value. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (LET ((CH1 (\BIN STREAM)) CH2) (AND CH1 (COND ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127)) 2)) (T (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND (\BIN STREAM) 127))))) ((\EUC.HANKAKUP CH1) (COND (COUNTP (CL:VALUES (\CONV.HANKAKU.KANA (\BIN STREAM)) 2)) (T (\CONV.HANKAKU.KANA (\BIN STREAM))))) ((\GAIJIP CH1) (COND (COUNTP (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127)) 3)) (T (\CONV.JIS.TO.XCCS (LOGAND (\BIN STREAM) 127) (LOGAND (\BIN STREAM) 127))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (CL:VALUES CH1 1)) (T CH1))))))) +) + +(\EUCPEEK +(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 25-Feb-91 16:35 by nm") (* ;;; "Returns a 16 bit XCCS code. Assuming the input character stream is encoded with EUC (Extended Unix Codes). Although EUC is independent of a particular language, the language implemented here is Japanese, thus this should be called as UJIS (Unixnized extended JIS code). JEIDA uses EUC as UJIS. Doesn't do EOL conversion -- \INCHAR or \INCCODE do that.") (PROG ((CH1 (\PEEKBIN STREAM NOERROR)) CH2) (COND ((NULL CH1) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL)))) ((\EUC.KANJI.FIRST.BYTEP CH1) (* ; "Read next byte and compose a kanji character.") (\BIN STREAM) (* ; "Consume the first byte.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) ((\EUC.HANKAKUP CH1) (\BIN STREAM) (* ; "Consume the SS2.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.HANKAKU.KANA CH2) 0))) (T (RETURN (\CONV.HANKAKU.KANA CH2))))) ((\GAIJIP CH1) (\BIN STREAM) (* ; "Consume the SS3.") (COND ((NULL (SETQ CH1 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BIN STREAM) (* ; "Consume the first byte in GAIJI.") (COND ((NULL (SETQ CH2 (\PEEKBIN STREAM NOERROR))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES NIL 0))) (T (RETURN NIL))))) (\BACKFILEPTR STREAM) (\BACKFILEPTR STREAM) (COND (COUNTP (RETURN (CL:VALUES (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)) 0))) (T (RETURN (\CONV.JIS.TO.XCCS (LOGAND CH1 127) (LOGAND CH2 127)))))) (T (* ; "ASCII, C0, C1, SP or DEL") (COND (COUNTP (RETURN (CL:VALUES CH1 0))) (T (RETURN CH1))))))) +) + +(\BACKEUCCHAR +(LAMBDA (STREAM COUNTP) (* ; "Edited 25-Feb-91 17:06 by nm") (COND ((\BACKFILEPTR STREAM) (COND ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "C1, KAINJI, HANKAKU or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\EUC.HANKAKUP (\PEEKBIN STREAM)) (AND COUNTP 2)) ((BITTEST (\PEEKBIN STREAM) (MASK.1'S 7 1)) (* ; "KANJI or GAIJI") (COND ((\BACKFILEPTR STREAM) (COND ((\GAIJIP (\PEEKBIN STREAM)) (AND COUNTP 3)) (T (* ; "KANJI") (\BIN STREAM) (AND COUNTP 2)))) (COUNTP 2))) (T (* ; "C1") (\BIN STREAM) (AND COUNTP 1)))) (COUNTP 1))) (COUNTP 1))) (COUNTP 0))) +) + +(\THROUGHIN +(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:36 by nm") (* ;;; "Read in a single byte from STREAM and returns it without any character conversion, just through as if.") (* ;;; "If COUNP is non-NIL, always 1 is returned as the second value.") (COND (COUNTP (CL:VALUES (\BIN STREAM) 1)) (T (\BIN STREAM)))) +) + +(\THROUGHPEEK +(LAMBDA (STREAM NOERROR COUNTP) (* ; "Edited 26-Feb-91 13:40 by nm") (* ;;; "Returns a 8 bit code without any character conversion, just through as if.") (* ;;; "If COUNTP is non-NIL, always 0 is returned as its second value.") (COND (COUNTP (CL:VALUES (\PEEKBIN STREAM NOERROR) 0)) (T (\PEEKBIN STREAM NOERROR)))) +) + +(\BACKTHROUGHCHAR +(LAMBDA (STREAM COUNTP) (* ; "Edited 26-Feb-91 13:43 by nm") (COND ((\BACKFILEPTR STREAM) 1) (COUNTP 0))) +) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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 'COUNTERVAR (SETQ COUNTERVAR + (IDIFFERENCE + COUNTERVAR 2))) + CHAR) + ((PROGN + (* ; + "2 shift-bytes means not run-encoded") + (AND 'COUNTERVAR + (SETQ COUNTERVAR + (IDIFFERENCE COUNTERVAR + 3))) + (EQ 0 (\BIN STREAM))) + \NORUNCODE) + (T (\NSIN.24BITENCODING.ERROR + STREAM] + (SETQ CHAR (\BIN STREAM)) + (SETQ SCSET (COND + ('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 'COUNTERVAR (SETQ COUNTERVAR (IDIFFERENCE COUNTERVAR 2 + ))) + (LOGOR (UNFOLD CHAR 256) + (\BIN STREAM))) + (CHAR (AND '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 'COUNTERVAR + (SETQ COUNTERVAR + (IDIFFERENCE COUNTERVAR 2)) + ) + CHAR) + ((PROGN + (* ; + "2 shift-bytes means not run-encoded") + (AND 'COUNTERVAR + (SETQ COUNTERVAR + (IDIFFERENCE + COUNTERVAR 3) + )) + (EQ 0 (\BIN STREAM))) + \NORUNCODE) + (T (\NSIN.24BITENCODING.ERROR + STREAM] + [SETQ SCSET (COND + ('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 'COUNTERVAR (add COUNTERVAR 2)) + T) + ('COUNTERVAR (add COUNTERVAR 1] + ('COUNTERVAR (add COUNTERVAR 1]) + +(PUTPROPS \XCCSP MACRO [OPENLAMBDA (ST) + (NOT (ffetch (STREAM NOTXCCS) of (\DTEST ST + 'STREAM]) +) +(DECLARE%: EVAL@COMPILE + +(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 + 'STREAM) + with T)) + (T (freplace (STREAM IN.KANJIIN) + of (\DTEST ST 'STREAM) + with NIL] + (T (COND + (ENTERP (freplace (STREAM OUT.KANJIIN) + of (\DTEST ST 'STREAM) + with T)) + (T (freplace (STREAM OUT.KANJIIN) + of (\DTEST ST '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 'STREAM] + (T (ffetch (STREAM OUT.KANJIIN) + of (\DTEST ST '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)))) +) +(DECLARE%: EVAL@COMPILE + +(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)))) +) +(DECLARE%: EVAL@COMPILE + +(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))) +) + +(* "END EXPORTED DEFINITIONS") + +) + +(RPAQ? *SIGNAL-24BIT-NSENCODING-ERROR* ) + +(RPAQ? *READ-NEWLINE-SUPPRESS* ) + +(RPAQ? \RefillBufferFn (FUNCTION \READCREFILL)) + + + +(* ; +"Top level val of \RefillBufferFn means act like READC--we must be doing a raw BIN (or PEEKBIN?)") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(LOCALVARS . T) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA CONVHANKAKU CL:PARSE-INTEGER CL:READ-DELIMITED-LIST CL:READ-PRESERVING-WHITESPACE + CL:READ) +) +(PUTPROPS LLREAD COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1990 +1991 1993)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (6621 14511 (LASTC 6631 . 7624) (PEEKC 7626 . 7931) (PEEKCCODE 7933 . 8156) (RATOM 8158 + . 8866) (READ 8868 . 9322) (READC 9324 . 9631) (READCCODE 9633 . 10049) (READP 10051 . 10385) ( +SETREADMACROFLG 10387 . 10543) (SKIPSEPRCODES 10545 . 11310) (SKIPSEPRS 11312 . 12004) ( +\NSIN.24BITENCODING.ERROR 12006 . 12581) (SKREAD 12583 . 14509)) (14557 22419 (CL:READ 14567 . 14898) +(CL:READ-PRESERVING-WHITESPACE 14900 . 15358) (CL:READ-DELIMITED-LIST 15360 . 16010) (CL:PARSE-INTEGER + 16012 . 22417)) (22452 33124 (RSTRING 22462 . 23016) (READ-EXTENDED-TOKEN 23018 . 25433) (\RSTRING2 +25435 . 33122)) (33160 51888 (\TOP-LEVEL-READ 33170 . 35157) (\SUBREAD 35159 . 49390) (\SUBREADCONCAT +49392 . 49904) (\READ.SYMBOL 49906 . 50695) (\INVALID.SYMBOL 50697 . 51314) (\APPLYREADMACRO 51316 . +51543) (INREADMACROP 51545 . 51886)) (51922 52048 (READQUOTE 51932 . 52046)) (52073 58440 (READVBAR +52083 . 52946) (READHASHMACRO 52948 . 55724) (DEFMACRO-LAMBDA-LIST-KEYWORD-P 55726 . 55889) ( +DIGITBASEP 55891 . 56349) (READNUMBERINBASE 56351 . 57319) (ESTIMATE-DIMENSIONALITY 57321 . 57553) ( +SKIP.HASH.COMMENT 57555 . 58066) (CMLREAD.FEATURE.PARSER 58068 . 58438)) (58484 60801 (CHARACTER.READ +58494 . 59139) (CHARCODE.DECODE 59141 . 60799)) (81086 84172 (\MAKE.JIS.TO.XCCS.CONV.TABLE 81096 . +84170)) (88113 88298 (CONVHANKAKU 88123 . 88296)) (91404 105185 (\JISIN 91414 . 94418) (\JISPEEK 94420 + . 97979) (\BACKJISCHAR 97981 . 98209) (\SHIFTJISIN 98211 . 99102) (\SHIFTJISPEEK 99104 . 100257) ( +\BACKSHIFTJISCHAR 100259 . 100530) (\EUCIN 100532 . 101761) (\EUCPEEK 101763 . 103809) (\BACKEUCCHAR +103811 . 104387) (\THROUGHIN 104389 . 104716) (\THROUGHPEEK 104718 . 105052) (\BACKTHROUGHCHAR 105054 + . 105183))))) +STOP diff --git a/sources/LLRESTART b/sources/LLRESTART new file mode 100644 index 00000000..268fb834 --- /dev/null +++ b/sources/LLRESTART @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "CONDITIONS") (IL:FILECREATED "16-May-90 20:02:41" IL:|{DSK}local>lde>lispcore>sources>LLRESTART.;2| 1089 IL:|changes| IL:|to:| (IL:VARS IL:LLRESTARTCOMS) IL:|previous| IL:|date:| "13-Jan-88 11:53:33" IL:|{DSK}local>lde>lispcore>sources>LLRESTART.;1|) ; Copyright (c) 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:LLRESTARTCOMS) (IL:RPAQQ IL:LLRESTARTCOMS ((IL:STRUCTURES RESTART) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLRESTART))) (DEFSTRUCT (RESTART (:PRINT-FUNCTION %RESTART-PRINTER)) IL:NAME IL:TAG IL:SELECTOR IL:TEST (IL:REPORT '%RESTART-DEFAULT-REPORTER) INTERACTIVE-FN FUNCTION) (IL:PUTPROPS IL:LLRESTART IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:LLRESTART IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "CONDITIONS")) (IL:PUTPROPS IL:LLRESTART IL:COPYRIGHT ("Venue & Xerox Corporation" 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/LLSTK b/sources/LLSTK new file mode 100644 index 00000000..167ded94 --- /dev/null +++ b/sources/LLSTK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 6-Jan-93 18:07:37" |{PELE:MV:ENVOS}SOURCES>LLSTK.;9| 112417 changes to%: (RECORDS FVARSLOT) previous date%: "17-Dec-92 18:17:01" |{PELE:MV:ENVOS}SOURCES>LLSTK.;8|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLSTKCOMS) (RPAQQ LLSTKCOMS [(DECLARE%: DONTCOPY (EXPORT (RECORDS BF FX FSB STK) (CONSTANTS \#ALINK.OFFSET) (GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW) (MACROS \MYALINK ADDSTACKBASE STACKADDBASE STACKGETBASE STACKGETBASEPTR STACKPUTBASE STACKPUTBASEPTR \MISCAPPLY*) (RECORDS STACKP) (CONSTANTS * STACKTYPES) (CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12))) (CONSTANTS \MAXSAFEUSECOUNT) (RECORDS NAMETABLESLOT FVARSLOT PVARSLOT STKTEMPSLOT BINDMARKSLOT) (CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)) (RECORDS STACKCELL)) (COMS (* ;  "For LAMBDA* and Common Lisp functions.") (FNS \MYARGCOUNT \ARG0 \SETARG0)) (COMS (* ;  "basic spaghetti for allocating, moving and reclaiming stack frames") (FNS \HARDRETURN \DOHARDRETURN \DOGC1 \DOGC \DOHARDRETURN1 \DOSTACKOVERFLOW \MOVEFRAME \INCUSECOUNT \DECUSECOUNT \MAKESTACKP \SMASHLINK \FREESTACKBLOCK \EXTENDSTACK)) (COMS (* ; "Some ugly stack-munging ufns") (FNS \SLOWRETURN \COPY.N.UFN \POP.N.UFN \STORE.N.UFN \UNWIND.UFN)) (COMS (* ; "The unwinder") (FNS SI::NON-LOCAL-GO SI::NON-LOCAL-RETURN SI::NON-LOCAL-RETURN-VALUES SI::INTERNAL-THROW SI::INTERNAL-THROW-VALUES SI::UNWIND-TO-BLIP SI::UNWIND SI::VARIABLE-NAME-IN-FRAME SI::PVAR-VALUE-IN-FRAME) (FNS \DISCARDFRAME \SMASHRETURN)) (COMS (* ; "parsing stack for gc") (FNS \GCSCANSTACK)) (COMS (* ; "setting up stack from scratch") (FNS CLEARSTK HARDRESET RELSTK RELSTKP) (FNS SETUPSTACK \SETUPSTACK1 \MAKEFRAME \RESETSTACK \RESETSTACK0 \SETUPUSERSTACK \SETUPGUARDBLOCK \MAKEFREEBLOCK \REPEATEDLYEVALQT \DUMMYKEYHANDLER \DUMMYTELERAID \CAUSEINTERRUPT \CONTEXTAPPLY \INTERRUPTFRAME \INTERRUPTED \CODEFORTFRAME \DOMISCAPPLY \DOMISCAPPLY1) (INITVARS \SAVED.USER.CONTEXT \NEED.HARDRESET.CLEANUP) (GLOBALVARS \SAVED.USER.CONTEXT \NEED.HARDRESET.CLEANUP)) (COMS (* ; "HARDRESET recovery code") (FNS \GATHER-CLEANUP-FORMS \GATHER-CLEANUP-FORMS1 \GATHER-SPECIAL-BINDINGS \HARDRESET-CLEANUP \HARDRESET-CLEANUP1 \HARDRESET-CLEANUP-RUN) (VARS *HARDRESET-IGNORE-VARS*) (GLOBALVARS *HARDRESET-IGNORE-VARS*)) (COMS (* ; "Ufns for RETCALL") (FNS \DORETCALL \RETCALL)) (INITVARS (STACKTESTING T)) (COMS (* ; "Stack overflow handler") (FNS \DOSTACKFULLINTERRUPT STACK.FULL.WARNING \CLEANUP.STACKFULL) (INITVARS (\PENDINGINTERRUPT) (\STACKOVERFLOW) (AUTOHARDRESETFLG T)) (ADDVARS (RESETFORMS (SETQ \STACKOVERFLOW))) (GLOBALVARS AUTOHARDRESETFLG)) (DECLARE%: DONTCOPY (ADDVARS [INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK) (ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 \MAKEFREEBLOCK \FAULTHANDLER \KEYHANDLER \DUMMYKEYHANDLER \DOTELERAID \DUMMYTELERAID \DOHARDRETURN \DOGC \CAUSEINTERRUPT \INTERRUPTFRAME \CODEFORTFRAME \DOSTACKOVERFLOW \UNLOCKPAGES \DOMISCAPPLY) (LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE \KBDSTACKBASE \MISCSTACKBASE \SAVED.USER.CONTEXT \RUNNING.PROCESS \NEED.HARDRESET.CLEANUP] (EXPANDMACROFNS ADDSTACKBASE STACKADDBASE)) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS SETUPSTACK))) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA SI::INTERNAL-THROW SI::NON-LOCAL-RETURN ]) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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)))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \#ALINK.OFFSET 10) (CONSTANTS \#ALINK.OFFSET) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW) ) (DECLARE%: EVAL@COMPILE (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)))) ) (DECLARE%: EVAL@COMPILE (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)))) (DECLARE%: EVAL@COMPILE (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))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \StackAreaSize 768) (RPAQ \InitStackSize (ITIMES \StackAreaSize 12)) (CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \MAXSAFEUSECOUNT 200) (CONSTANTS \MAXSAFEUSECOUNT) ) (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \NT.IVAR 0) (RPAQQ \NT.PVAR 128) (RPAQQ \NT.FVAR 192) (CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (BLOCKRECORD STACKCELL ((STACKNONPOINTERBITS BITS 8) (STACKHIBITS BITS 8) (STACKLOBITS WORD)) [ACCESSFNS STACKCELL ((VALIDPOINTERP (EQ 0 (fetch (STACKCELL STACKNONPOINTERBITS ) of DATUM))) (VALIDPOINTER (\GETBASEPTR DATUM 0]) ) ) (* ; "For LAMBDA* and Common Lisp functions.") (DEFINEQ (\MYARGCOUNT (LAMBDA NIL (* lmm " 6-OCT-81 23:15") (* ;; "Opcode put out by the compiler in lambda* functions. Returns number of arguments of the caller, to be bound to the lambda* variable. Microcoded on some machines.") (fetch (BF NARGS) of (fetch (FX BLINK) of (\MYALINK)))) ) (\ARG0 (LAMBDA (N) (* lmm " 6-OCT-81 23:15") (* ;; "call to this function put out by compiler when compiling ARG for local argument. Returns Nth argument of parent's frame") (PROG ((BFLINK (fetch (FX BLINK) of (\MYALINK)))) (* ; "BFLINK is the basic frame we are looking at") (CHECK (type? BF BFLINK)) (RETURN (COND ((AND (IGREATERP N 0) (NOT (IGREATERP N (fetch (BF NARGS) of BFLINK)))) (* ; "N must be between 1 and the number of arguments") (GETBASEPTR \STACKSPACE (IPLUS (fetch (BF IVAR) of BFLINK) (LLSH (SUB1 N) 1)))) (T (LISPERROR "ILLEGAL ARG" N)))))) ) (\SETARG0 (LAMBDA (N VAL) (* bvm%: " 5-Feb-85 16:10") (* ;; "call to this function put out by compiler when compiling SETARG for local argument. Sets Nth argument of parent's frame") (PROG ((BFLINK (fetch (FX BLINK) of (\MYALINK)))) (* ; "BFLINK is the basic frame we are looking at") (CHECK (type? BF BFLINK)) (RETURN (COND ((AND (IGREATERP N 0) (NOT (IGREATERP N (fetch (BF NARGS) of BFLINK)))) (* ; "N must be between 1 and the number of arguments") (\PUTBASEPTR (ADDSTACKBASE (IPLUS (fetch (BF IVAR) of BFLINK) (UNFOLD (SUB1 N) WORDSPERCELL))) 0 VAL)) (T (LISPERROR "ILLEGAL ARG" N)))))) ) ) (* ; "basic spaghetti for allocating, moving and reclaiming stack frames") (DEFINEQ (\HARDRETURN (LAMBDA (VAL) (* lmm "20-JUL-81 13:45") (* ;; "Called by the microcode instead of returning to a frame whose use count is greater than one or alink neq clink.") (\CONTEXTSWITCH \HardReturnFXP) VAL) ) (\DOHARDRETURN (LAMBDA NIL (* lmm "27-JUL-81 09:07") (PROG NIL LP (\DOHARDRETURN1 (fetch (IFPAGE HardReturnFXP) of \InterfacePage)) (\CONTEXTSWITCH \HardReturnFXP) (GO LP))) ) (\DOGC1 (LAMBDA NIL (* lmm " 1-SEP-81 00:53") (* ;; "Body of the GC hard context.") (\GCSCANSTACK) (\GCMAPSCAN) (* ; "map thru, releasing entries") (\GCMAPUNSCAN) (* ; "map thru, unmarking stack entries") NIL) ) (\DOGC (LAMBDA NIL (* lmm " 1-SEP-81 00:52") (PROG NIL LP (\DOGC1) (\CONTEXTSWITCH \GCFXP) (GO LP)))) (\DOHARDRETURN1 (LAMBDA (HRFRAME) (* ; "Edited 16-Apr-87 15:00 by bvm:") (* ;; "executed in the hard return context. HRFRAME is the context in which \HARDRETURN was invoked. We want to fix \HARDRETURN's caller to do a return to its caller") (COND ((EQ (fetch (FX FNHEADER FRAMENAME) of HRFRAME) (QUOTE \CONTEXTSWITCH)) (* ;; "We really want to mung \HARDRETURN frame, not \CONTEXTSWITCH. Test is needed in case \CONTEXTSWITCH is microcode") (SETQ HRFRAME (fetch (FX CLINK) of HRFRAME)))) (PROG ((RETURNER (fetch (FX CLINK) of HRFRAME)) RETURNEE AX NEW SIZE RETBF NAMETABLE-ON-STACK) (CHECK (EQ (fetch (FX FNHEADER FRAMENAME) of HRFRAME) (QUOTE \HARDRETURN))) (SETQ RETURNEE (fetch (FX CLINK) of RETURNER)) (CHECK (fetch (FX CHECKED) of RETURNEE) (fetch (FX CHECKED) of RETURNER) (NOT (fetch (FX FASTP) of RETURNER)) (OR (NEQ RETURNEE (fetch (FX ALINK) of RETURNER)) (COND ((NEQ (fetch (FX USECNT) of RETURNEE) 0) (* ; "use count of RETURNEE gt 1, must copy RETURNEE") T) ((type? FSB (SETQ AX (fetch (FX NEXTBLOCK) of RETURNEE))) (* ; "returnee followed by a free block, but that free block is too small") (ILEQ (fetch (FSB SIZE) of AX) \MinExtraStackWords)) (T (* ; "must copy in all other cases") (* was ((EQ AX (fetch (BF IVAR) of (SETQ AX (fetch (FX BLINK) of RETURNER)))) (* ; "returnee followed by RETURNER's BF but it doesn't have a non-zero usecount") (NEQ (fetch (BF USECNT) of AX) 0))) T)))) (COND ((NEQ RETURNEE (SETQ AX (fetch (FX ALINK) of RETURNER))) (* ; "ALINK and CLINK of returner not the same. Fix.") (* ; "Set new ALINK before decrementing count on old value") (replace (FX ALINK) of RETURNER with RETURNEE) (\DECUSECOUNT AX))) (COND ((COND ((NEQ (fetch (FX USECNT) of RETURNEE) 0) (* ; "use count of RETURNEE gt 1, must copy RETURNEE") T) ((type? FSB (SETQ AX (fetch (FX NEXTBLOCK) of RETURNEE))) (* ; "returnee followed by a free block, but that free block is too small") (* ; "Should really require microcode merge the free blocks") (while (type? FSB (SETQ NEW (IPLUS AX (fetch (FSB SIZE) of AX)))) do (add (fetch (FSB SIZE) of AX) (fetch (FSB SIZE) of NEW))) (ILEQ (fetch (FSB SIZE) of AX) \MinExtraStackWords)) ((EQ AX (fetch (BF IVAR) of (SETQ AX (fetch (FX BLINK) of RETURNER)))) (* ; "returnee followed by RETURNER's BF but it doesn't have a non-zero usecount") (NEQ (fetch (BF USECNT) of AX) 0)) (T (* ; "must copy in all other cases") T)) (* ; "Must copy returnee to a new block because there isn't enough room to return a value to it") (FLIPCURSORBAR 5) (SETQ SIZE (IPLUS (fetch (FX SIZE) of RETURNEE) WORDSPERCELL)) (SETQ NEW (\FREESTACKBLOCK SIZE RETURNER (COND ((AND (fetch (FX VALIDNAMETABLE) of RETURNEE) (EQ (fetch (FX NAMETABHI) of RETURNEE) \STACKHI)) (* ; "frame contains a name table, so we care that the alignment of the new block be same as old") (CHECK (LET ((N (fetch (FX NAMETABLO) of RETURNEE))) (AND (> N RETURNEE) (< N (fetch (FX NEXTBLOCK) of RETURNEE))))) (SETQ NAMETABLE-ON-STACK T) (IMOD (- RETURNEE WORDSPERCELL) WORDSPERQUAD))))) (* ; "Find a free stack block") (\BLT (ADDSTACKBASE NEW) (ADDSTACKBASE (IDIFFERENCE RETURNEE WORDSPERCELL)) SIZE) (* ; "copy frame and dummy bf pointer too") (replace (BF RESIDUAL) of NEW with T) (add NEW WORDSPERCELL) (* ; "now NEW points to the FX") (replace (FX NEXTBLOCK) of NEW with (IDIFFERENCE (IPLUS NEW SIZE) WORDSPERCELL)) (replace (FX BLINK) of NEW with (SETQ RETBF (fetch (FX BLINK) of RETURNEE))) (* ; "Point to the real BF, not the residual") (replace (FX USECNT) of NEW with 0) (CHECK (fetch (BF CHECKED) of RETBF)) (COND (NAMETABLE-ON-STACK (* ; "Frame's nametable is on the stack, so it moved at the same time the frame did") (add (fetch (FX NAMETABLO) of NEW) (IDIFFERENCE NEW RETURNEE)))) (add (fetch (BF USECNT) of RETBF) 1) (* ; "increment use count of basic frame of returnee because we made another FX which points to it") (replace (FX FASTP) of RETURNEE with NIL) (\INCUSECOUNT (SETQ AX (fetch (FX CLINK) of RETURNEE))) (* ; "increment use count of CLINK of returnee because we made a copy of returnee") (COND ((NEQ AX (SETQ AX (fetch (FX ALINK) of RETURNEE))) (\INCUSECOUNT AX))) (\DECUSECOUNT RETURNEE) (replace (FX ACLINK) of RETURNER with NEW) (CHECK (fetch (FX CHECKED) of NEW) (fetch (FX CHECKED) of RETURNER)) (SETQ RETURNEE NEW) (FLIPCURSORBAR 5))) (\SMASHLINK HRFRAME RETURNEE RETURNEE))) ) (\DOSTACKOVERFLOW (LAMBDA NIL (* ; "Edited 9-Dec-86 13:59 by bvm:") (PROG NIL (if \NEED.HARDRESET.CLEANUP then (* ;; "Bootstrapping after hardreset mess. Done here so that if death occurs, ^D from Raid will get us back.") (replace (IFPAGE SubovFXP) of \InterfacePage with (fetch (IFPAGE ResetFXP) of \InterfacePage)) (* ; "So that if someone really tries to use this context, a reset will occur--should never happen") (SETQ \RECLAIM.COUNTDOWN NIL) (* ; "inhibit gc") (\GATHER-CLEANUP-FORMS) (replace (IFPAGE SubovFXP) of \InterfacePage with (\SETUPUSERSTACK \NEED.HARDRESET.CLEANUP)) (* ; "Create the initial user stack, then switch back to it. \SETUPUSERSTACK also reenables gc and clears \NEED.HARDRESET.CLEANUP") (\CONTEXTSWITCH \SubovFXP)) LP (replace (IFPAGE SubovFXP) of \InterfacePage with (\MOVEFRAME (fetch (IFPAGE SubovFXP) of \InterfacePage))) (\CONTEXTSWITCH \SubovFXP) (GO LP))) ) (\MOVEFRAME (LAMBDA (OLDFRAME) (* ; "Edited 11-Nov-87 13:00 by bvm") (FLIPCURSORBAR 10) (* ;;; "Called from \DOSTACKOVERFLOW when there isn't enough space to run in OLDFRAME --- Either we're at the end of stack space, in which case we can just extend the stack a bit, or we need to move OLDFRAME to somewhere else that has more free space after it.") (PROG ((NXT (fetch (FX NEXTBLOCK) of OLDFRAME)) OLDSIZE AX NEW NAMETABLE-ON-STACK AT-EOS FREESIZE) TRYFSB (COND ((type? FSB NXT) (* ; "Frame is followed by a free stack block, so maybe it's just not big enough") (if (type? FSB (SETQ NEW (+ NXT (SETQ FREESIZE (fetch (FSB SIZE) of NXT))))) then (* ; "Oh, we just haven't merged our free blocks. Merge and try again. Probably the microcode should be doing this.") (do (add FREESIZE (fetch (FSB SIZE) of NEW)) repeatwhile (type? FSB (SETQ NEW (+ NXT FREESIZE)))) (replace (FSB SIZE) of NXT with FREESIZE) (SETQ NEW OLDFRAME) (GO OUT) elseif (EQ NEW (fetch (IFPAGE EndOfStack) of \InterfacePage)) then (* ;; "Frame is at end of stack. We have a problem here: We'd like to avoid eating up stack when there might be oodles of space earlier in the stack. However, in the case where we really do need more stack, it's painful to search the entire stack fruitlessly for a free block every time the current computation goes a little deeper.") (if (AND (> NEW \GuardStackAddr) (NOT \STACKOVERFLOW)) then (* ; "Compromise: do the search anyway if extending the stack would trigger a stack overflow interrupt.") (SETQ AT-EOS T) elseif (\EXTENDSTACK) then (* ; "Extend succeeded") (SETQ NEW OLDFRAME) (GO OUT))))) (CHECK (fetch (FX CHECKED) of OLDFRAME) (EQ (fetch (FX USECNT) of OLDFRAME) 0) (NOT \INTERRUPTABLE)) (* ;; "Must copy OLDFRAME to a new block because there isn't enough room to run in it. Get a free block big enough to hold the frame.") (SETQ NEW (\FREESTACKBLOCK (SETQ OLDSIZE (+ (fetch (FX SIZE) of OLDFRAME) WORDSPERCELL)) OLDFRAME (COND ((AND (fetch (FX VALIDNAMETABLE) of OLDFRAME) (EQ (fetch (FX NAMETABHI) of OLDFRAME) \STACKHI)) (* ; "frame contains a name table, so we care that the alignment of the new block be same as old") (CHECK (LET ((N (fetch (FX NAMETABLO) of OLDFRAME))) (AND (> N OLDFRAME) (< N (fetch (FX NEXTBLOCK) of OLDFRAME))))) (SETQ NAMETABLE-ON-STACK T) (IMOD (- OLDFRAME WORDSPERCELL) WORDSPERQUAD))))) (if (AND AT-EOS (> NEW OLDFRAME)) then (* ; "Sigh, we had to extend the stack after all. Just do it the easy way. FREESTACKBLOCK returned a guard block--just turn it back into a free block and do the simple extend case.") (replace (FSB FLAGWORD) of NEW with \STK.FSB.WORD) (GO TRYFSB)) (\BLT (ADDSTACKBASE NEW) (ADDSTACKBASE (- OLDFRAME WORDSPERCELL)) OLDSIZE) (* ; "copy frame and dummy bf pointer too") (replace (BF RESIDUAL) of NEW with T) (add NEW WORDSPERCELL) (* ; "now NEW points to the FX") (replace (FX NEXTBLOCK) of NEW with (- (+ NEW OLDSIZE) WORDSPERCELL)) (CHECK (fetch (BF CHECKED) of (fetch (FX BLINK) of OLDFRAME))) (replace (FX BLINK) of NEW with (fetch (FX BLINK) of OLDFRAME)) (* ; "Point at true BF, not residual") (COND (NAMETABLE-ON-STACK (* ; "Frame's nametable is on the stack, so it moved at the same time the frame did") (CHECK (EVENP (- NEW OLDFRAME) WORDSPERQUAD)) (add (fetch (FX NAMETABLO) of NEW) (- NEW OLDFRAME)))) (COND ((fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of OLDFRAME)) (\MAKEFREEBLOCK (- OLDFRAME WORDSPERCELL) OLDSIZE)) (T (\MAKEFREEBLOCK OLDFRAME (- OLDSIZE WORDSPERCELL)))) OUT (FLIPCURSORBAR 10) (* ; "Restore cursor") (RETURN NEW))) ) (\INCUSECOUNT (LAMBDA (FRAME) (* bvm%: "23-Mar-84 18:01") (COND ((NOT (fetch (FX INVALIDP) of FRAME)) (CHECK (NOT \INTERRUPTABLE) (fetch (FX CHECKED) of FRAME)) (COND ((IGREATERP (add (fetch (FX USECNT) of FRAME) 1) \MAXSAFEUSECOUNT) (\MP.ERROR \MP.USECOUNTOVERFLOW "Stack frame use count maximum exceeded" FRAME))) (PROG ((SCANPTR (fetch (FX NEXTBLOCK) of FRAME))) (* ; "scan for BF ptr") (SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.NOTFLAG (until (type? BF (add SCANPTR WORDSPERCELL)))) (\STK.BF) (RETURN)) (CHECK (OR (fetch (BF RESIDUAL) of SCANPTR) (EQ (fetch (BF IVAR) of SCANPTR) (fetch (FX NEXTBLOCK) of FRAME)))) (COND ((type? FX (add SCANPTR WORDSPERCELL)) (CHECK (fetch (FX CHECKED) of SCANPTR)) (replace (FX FASTP) of SCANPTR with NIL)))))) FRAME) ) (\DECUSECOUNT (LAMBDA (FRAME) (* lmm " 4-SEP-81 09:29") (PROG (TEMP ALINK BLINK SIZE CLINK) (CHECK (NOT \INTERRUPTABLE)) TOP (COND ((fetch (FX INVALIDP) of FRAME) (* ; "reached top of stack") (RETURN))) (CHECK (fetch (FX CHECKED) of FRAME)) (COND ((NEQ (fetch (FX USECNT) of FRAME) 0) (* ; "USECNT (= use count + 1) greater than 1, merely decrement it") (add (fetch (FX USECNT) of FRAME) -1) (RETURN FRAME))) (* ; "ok, now free it") (SETQ ALINK (fetch (FX ALINK) of FRAME)) (SETQ BLINK (fetch (FX BLINK) of FRAME)) (SETQ CLINK (fetch (FX CLINK) of FRAME)) (SETQ SIZE (fetch (FX SIZE) of FRAME)) (COND ((fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of FRAME)) (\MAKEFREEBLOCK (IDIFFERENCE FRAME WORDSPERCELL) (IPLUS SIZE WORDSPERCELL))) (T (\MAKEFREEBLOCK FRAME SIZE))) (CHECK (fetch (BF CHECKED) of BLINK)) (COND ((EQ (fetch (BF USECNT) of BLINK) 0) (* ; "frame extension count+1=0 --- release basic frame") (\MAKEFREEBLOCK (fetch (BF IVAR) of BLINK) (fetch (BF SIZE) of BLINK))) (T (* ; "merely decrement extension count") (add (fetch (BF USECNT) of BLINK) -1))) (COND ((NEQ ALINK CLINK) (\DECUSECOUNT ALINK))) (SETQ FRAME CLINK) (GO TOP))) ) (\MAKESTACKP (LAMBDA (ED FX) (* bvm%: " 5-Jun-85 17:21") (* ;; "Create a STACKP cell, possibly reusing ED, and pointing to FX") (UNINTERRUPTABLY (COND ((NEQ FX 0) (\INCUSECOUNT FX))) (COND ((OR (STACKP ED) (TYPENAMEP ED (QUOTE PROCESS))) (LET ((OLDFX (fetch (STACKP EDFXP) of ED))) (COND ((NEQ OLDFX 0) (\DECUSECOUNT OLDFX))))) (T (SETQ ED (CREATECELL \STACKP)) (replace (STACKP STACKP0) of ED with \STACKHI))) (replace (STACKP EDFXP) of ED with FX)) ED) ) (\SMASHLINK (LAMBDA (CALLER ALINK CLINK) (* bvm%: " 5-Feb-85 16:19") (* ; "Smashes caller's ALINK and/or CLINK with ALINK and CLINK") (OR CALLER (SETQ CALLER (\MYALINK))) (UNINTERRUPTABLY (PROG ((OLDALINK (fetch (FX ALINK) of CALLER)) (OLDCLINK (fetch (FX CLINK) of CALLER)) BLINK) (COND (ALINK (COND ((NEQ ALINK (OR CLINK OLDCLINK)) (* ; "Don't increment twice if ALINK comes out same as CLINK") (\INCUSECOUNT ALINK))) (replace (FX ALINK) of CALLER with ALINK))) (COND (CLINK (COND ((OR ALINK (NEQ CLINK OLDALINK)) (* ; "If we're only setting the CLINK, and we're setting it to be the same as the ALINK, don't bump count") (\INCUSECOUNT CLINK))) (replace (FX CLINK) of CALLER with CLINK) (\DECUSECOUNT OLDCLINK))) (* ; "must be careful to increment any use counts before decrementing any") (COND ((AND (NEQ OLDALINK OLDCLINK) ALINK) (\DECUSECOUNT OLDALINK))) (COND ((AND (EQ (OR ALINK (SETQ ALINK OLDALINK)) (OR CLINK (SETQ CLINK OLDCLINK))) (EQ (fetch (FX USECNT) of CLINK) 0) (EQ (SETQ BLINK (fetch (FX BLINK) of CALLER)) (fetch (FX DUMMYBF) of CALLER)) (EQ (fetch (BF IVAR) of BLINK) (fetch (FX NEXTBLOCK) of CLINK)) (EQ (fetch (BF USECNT) of BLINK) 0) (NOT (fetch (FX NOPUSH) of CLINK)) (NOT (fetch (FX INCALL) of CLINK))) (* ;; "We have made CALLER fast again: its alink and clink are same, usecnt of blink and caller are normal, bf is contiguous with CALLER and CALLER's caller") (replace (FX SLOWP) of CALLER with NIL))) (RETURN CALLER)))) ) (\FREESTACKBLOCK (LAMBDA (N START ALIGN) (* ; "Edited 16-Apr-87 14:53 by bvm:") (* ;; "Scan stack space searching for a free block of size at least n, starting scan at start (or beginning of stackspace if START=NIL). The block returned has the quadword alignment requested by ALIGN (0 or 2) if ALIGN is non-NIL.") (PROG ((WANTEDSIZE (IPLUS N \StackAreaSize \MinExtraStackWords)) FREEPTR FREESIZE (EASP (fetch EndOfStack of \InterfacePage)) SCANPTR) (CHECK (OR (NULL START) (IGEQ START (fetch StackBase of \InterfacePage)))) STARTOVER (SETQ SCANPTR (OR START (fetch StackBase of \InterfacePage))) SCAN (SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.FSB (GO FREESCAN)) (\STK.GUARD (COND ((ILESSP SCANPTR EASP) (* ; "Guard block not at end of stack, treat as a free block") (GO FREESCAN))) (* ; "reached end") (COND (START (* ; "had a starting place, just wrap around") (SETQ SCANPTR (fetch StackBase of \InterfacePage)) (GO SCAN)) (T (* ; "Scanned the entire stack --- add a new page") (GO NEWPAGE)))) (\STK.FX (* ; "frame extension") (CHECK (fetch (FX CHECKED) of SCANPTR)) (SETQ SCANPTR (fetch (FX NEXTBLOCK) of SCANPTR))) (PROG ((ORIG SCANPTR)) (* ; "must be a basic frame") (until (type? BF SCANPTR) do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR) \STK.NOTFLAG)) (add SCANPTR WORDSPERCELL)) (CHECK (COND ((fetch (BF RESIDUAL) of SCANPTR) (EQ SCANPTR ORIG)) (T (AND (fetch (BF CHECKED) of SCANPTR) (EQ ORIG (fetch (BF IVAR) of SCANPTR)))))) (add SCANPTR WORDSPERCELL))) NEXT (COND ((NEQ SCANPTR START) (CHECK (ILEQ SCANPTR EASP)) (GO SCAN))) NEWPAGE (COND ((SETQ EASP (\EXTENDSTACK)) (GO STARTOVER)) (T (while T do (\MP.ERROR \MP.STACKFULL "Stack Full -- Type LU to see stack; ^D to flush to top")))) FREESCAN (SETQ FREEPTR SCANPTR) (SETQ FREESIZE (fetch (FSB SIZE) of SCANPTR)) FREE (* ; "Merge free blocks") (SETQ SCANPTR (IPLUS FREEPTR FREESIZE)) (COND ((SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.FSB T) (\STK.GUARD (ILESSP SCANPTR EASP)) NIL) (add FREESIZE (fetch (FSB SIZE) of SCANPTR)) (GO FREE))) (COND ((IGEQ FREESIZE WANTEDSIZE) (* ; "Found a large enough block -- Split the block") (SETQ WANTEDSIZE (COND ((OR (NULL ALIGN) (EQ ALIGN (IMOD FREEPTR WORDSPERQUAD))) (* ; "alignment ok. Assumes that \MinExtraStackWords is multiple of 4") \MinExtraStackWords) (T (* ; "no, adjust alignment") (IPLUS WORDSPERCELL \MinExtraStackWords)))) (SETQ SCANPTR (\SETUPGUARDBLOCK (IPLUS FREEPTR WANTEDSIZE) N)) (* ; "Block to return: desired size (n), properly aligned") (\MAKEFREEBLOCK FREEPTR WANTEDSIZE) (* ; "Leave a little free block before it") (\MAKEFREEBLOCK (IPLUS SCANPTR N) (IDIFFERENCE (IDIFFERENCE FREESIZE WANTEDSIZE) N)) (* ; "and a big free block after") (RETURN SCANPTR)) (T (\MAKEFREEBLOCK FREEPTR FREESIZE))) (GO NEXT))) ) (\EXTENDSTACK (LAMBDA NIL (* bvm%: "18-JAN-83 12:12") (PROG ((EASP (fetch (IFPAGE EndOfStack) of \InterfacePage)) SCANPTR) (RETURN (COND ((ILESSP EASP \LastStackAddr) (if (AND (IGREATERP EASP \GuardStackAddr) (NOT \STACKOVERFLOW)) then (replace STACKOVERFLOW of \INTERRUPTSTATE with T) (SETQ \STACKOVERFLOW (SETQ \PENDINGINTERRUPT T))) (OR (\DONEWPAGE (ADDSTACKBASE (SETQ SCANPTR (IPLUS EASP 2))) T) (\DOLOCKPAGES (ADDSTACKBASE SCANPTR) 1)) (* ;; "Create, if necessary, new page and lock it. Second clause happens when page already existed. \DONEWPAGE instead of \NEWPAGE etc. because we are in a safe context (and might even be in the misc context)") (\MAKEFREEBLOCK SCANPTR (IDIFFERENCE WORDSPERPAGE 2)) (\SETUPGUARDBLOCK (SETQ SCANPTR (IPLUS EASP WORDSPERPAGE)) 2) (replace EndOfStack of \InterfacePage with SCANPTR) (\MAKEFREEBLOCK EASP 2) SCANPTR))))) ) ) (* ; "Some ugly stack-munging ufns") (DEFINEQ (\SLOWRETURN (LAMBDA NIL (* lmm "30-Dec-84 03:31") (* ;; "force caller to slow return") (replace (FX FASTP) of (\MYALINK) with NIL)) ) (\COPY.N.UFN (LAMBDA (ALPHA) (* lmm " 2-Jan-85 01:29") (\.GETBASE32 \STACKSPACE (IDIFFERENCE (fetch (FX NEXTBLOCK) of (\MYALINK)) (IPLUS ALPHA WORDSPERCELL)))) ) (\POP.N.UFN [LAMBDA (N) (* ; "Edited 5-Jul-88 18:08 by amd") (\SLOWRETURN) (LET ((AL (\MYALINK)) NEXT VAL LEN) (SETQ NEXT (fetch (FX NEXTBLOCK) of AL)) [SETQ VAL (\GETBASEPTR \STACKSPACE (SETQ NEXT (IDIFFERENCE NEXT (SETQ LEN (UNFOLD (ADD1 N) WORDSPERCELL] (\MAKEFREEBLOCK NEXT LEN) (replace (FX NEXTBLOCK) of AL with NEXT) (replace (FX NOPUSH) of AL with T]) (\STORE.N.UFN (LAMBDA (VAL ALPHA) (* lmm " 2-Jan-85 01:30") (\.PUTBASE32 \STACKSPACE (IDIFFERENCE (fetch (FX NEXTBLOCK) of (\MYALINK)) (IPLUS ALPHA WORDSPERCELL)) VAL)) ) (\UNWIND.UFN [LAMBDA (N.KEEP) (* ; "Edited 27-Sep-88 11:48 by jds") (* ;;; "UFN for UNWIND opcode. The two bytes are the desired stack depth to unwind to and a flag indicating whether to push TOS when done.") (LET* ((CALLER (\MYALINK)) (NEXT (fetch (FX NEXTBLOCK) of CALLER)) (SP NEXT) (DESIREDSP (IPLUS (IDIFFERENCE (fetch (FX FIRSTPVAR) of CALLER) WORDSPERCELL) (UNFOLD (LRSH N.KEEP 8) WORDSPERCELL))) (PUSHP (NEQ (LOGAND N.KEEP 255) 0)) OLDTOS) [COND (PUSHP (* ; "Save old top of stack") (SETQ OLDTOS (\GETBASEPTR (STACKADDBASE (IDIFFERENCE SP WORDSPERCELL)) 0] (UNINTERRUPTABLY [while (GREATERP (add SP (IMINUS WORDSPERCELL)) DESIREDSP) bind (PVAR0BASE _ (STACKADDBASE (fetch (FX FIRSTPVAR) of CALLER))) when (fetch BINDMARKP of (STACKADDBASE SP)) do (* ; "Unbind stuff. Bind mark says how many pvars were bound, and gives the offset of the last of them") (LET [(LASTPVAR (fetch BINDLASTPVAR of (STACKADDBASE SP] (to (fetch BINDNVALUES of (STACKADDBASE SP)) do (\PUTBASE PVAR0BASE LASTPVAR 65535) (SETQ LASTPVAR (IDIFFERENCE LASTPVAR WORDSPERCELL] (replace (FX NEXTBLOCK) of CALLER with (add DESIREDSP WORDSPERCELL)) (\MAKEFREEBLOCK DESIREDSP (IDIFFERENCE NEXT DESIREDSP)) (COND ((NOT PUSHP) (* ;  "Keep return value from being pushed") (replace (FX NOPUSH) of CALLER with T))) (* ;; "Now explicitly slow return to caller, since we have violated the fast return assumptions by blowing away stack between here and there") (\SLOWRETURN) OLDTOS)]) ) (* ; "The unwinder") (DEFINEQ (SI::NON-LOCAL-GO (LAMBDA (BLIP PC) (* bvm%: " 4-Nov-86 16:30") (* ;;; "Performs a non-local GO. BLIP is the control blip of the target frame; PC is the place to resume execution. We unwind the stack and return to the target frame at the specified PC.") (LET ((TARGET (SI::UNWIND-TO-BLIP BLIP NIL))) (if TARGET then (* ; "Unwound ok. Stack now has me pointing at the BLIP frame. Adjust the pc and return to it.") (replace (FX PC) of TARGET with PC) T else (CL:ERROR (QUOTE ILLEGAL-GO))))) ) (SI::NON-LOCAL-RETURN (LAMBDA BLIP&VALUES (* bvm%: " 4-Nov-86 22:13") (* ;;; "Effective arg list is (BLIP &REST VALUES), done this way to avoid consing. Returns the multiple values VALUES to/from the frame that binds the control blip BLIP. Information in the frame says whether return goes to the frame (at a specified pc) or from it.") (if (SI::UNWIND-TO-BLIP (ARG BLIP&VALUES 1) T) then (* ; "Unwound ok. Stack now has me pointing at the BLIP frame. Return multiple values to it.") (if (EQ BLIP&VALUES 2) then (* ; "given exactly one value, so we can take normal return") (ARG BLIP&VALUES 2) else (CL:VALUES-LIST (for I from 2 to BLIP&VALUES collect (ARG BLIP&VALUES I)))) else (CL:ERROR (QUOTE ILLEGAL-RETURN)))) ) (SI::NON-LOCAL-RETURN-VALUES (CL:LAMBDA (BLIP VALUES) (* bvm%: " 4-Nov-86 22:14") (* ;;; "Returns the multiple values VALUES to/from the frame that binds the control blip BLIP. Information in the frame says whether return goes to the frame (at a specified pc) or from it.") (if (SI::UNWIND-TO-BLIP BLIP T) then (* ; "Unwound ok. Stack now has me pointing at the BLIP frame. Return multiple values to it.") (if (AND VALUES (NULL (CDR VALUES))) then (* ; "fast return of one value") (CAR VALUES) else (CL:VALUES-LIST VALUES)) else (CL:ERROR (QUOTE ILLEGAL-RETURN)))) ) (SI::INTERNAL-THROW (LAMBDA TAG&VALUES (* bvm%: " 4-Nov-86 22:39") (* ;;; "Effective arg list is (TAG &REST VALUES), done this way to avoid consing. THROW's the multiple values VALUES to TAG. TAG is bound as the control blip of the catch frame.") (if (SI::UNWIND-TO-BLIP (ARG TAG&VALUES 1) (QUOTE CL:THROW)) then (* ; "Unwound ok. Stack now has me pointing at the BLIP frame. Return multiple values to it.") (if (EQ TAG&VALUES 2) then (* ; "given exactly one value, so we can take normal return") (ARG TAG&VALUES 2) else (CL:VALUES-LIST (for I from 2 to TAG&VALUES collect (ARG TAG&VALUES I)))) else (CL:ERROR (QUOTE ILLEGAL-THROW) :TAG (ARG TAG&VALUES 1)))) ) (SI::INTERNAL-THROW-VALUES (CL:LAMBDA (TAG VALUES) (* bvm%: " 4-Nov-86 22:14") (* ;;; "THROW's the multiple values VALUES to TAG. TAG is bound as the control blip of the catch frame.") (if (SI::UNWIND-TO-BLIP TAG (QUOTE CL:THROW)) then (* ; "Unwound ok. Stack now has me pointing at the BLIP frame. Return multiple values to it.") (if (AND VALUES (NULL (CDR VALUES))) then (* ; "fast return of one value") (CAR VALUES) else (CL:VALUES-LIST VALUES)) else (CL:ERROR (QUOTE ILLEGAL-THROW) :TAG TAG))) ) (SI::UNWIND-TO-BLIP [LAMBDA (BLIP THROWP UNWINDER) (* ; "Edited 18-Feb-91 16:12 by jds") (* ;;; "Searches stack from caller of UNWINDER backwards for a frame that binds BLIP as its control blip. Returns that frame or that frame's caller, depending on how we are supposed to return (if THROWP is NIL, always return TO the frame; else frame says). Returns NIL on failure to find BLIP. UNWINDER defaults to the caller.") (* ;;; "") (* ;;; "For this implementation, control blips and catch tags are stored in pvar1. The var's name is SI::*CATCH-RETURN-FROM* if control exits the frame, or SI::*CATCH-RETURN-TO* if control is to return to the frame, in which case the frame's special var SI::*CATCH-RETURN-PC* has the pc value.") (bind [TARGET _ (OR UNWINDER (SETQ UNWINDER (\MYALINK] PC until (fetch (FX INVALIDP) of (SETQ TARGET (fetch (FX CLINK) of TARGET))) when (AND (EQ BLIP (\GETBASEPTR (ADDSTACKBASE (+ (fetch (FX FIRSTPVAR) of TARGET) WORDSPERCELL)) 0)) (SELECTQ (SI::VARIABLE-NAME-IN-FRAME TARGET (NEW-SYMBOL-CODE (IPLUS (LLSH PVARCODE 16) 1) (SI::IPLUS PVARCODE 1))) (SI::*CATCH-RETURN-TO* [COND (THROWP (* ;  "we're doing a RETURN/THROW where we accomplish the task like GO") (OR [SMALLP (SETQ PC (SI::PVAR-VALUE-IN-FRAME TARGET (NEW-SYMBOL-CODE 'SI::*CATCH-RETURN-PC* (\ATOMVALINDEX 'SI::*CATCH-RETURN-PC*] (ERROR "Catch return-to frame lacks PC" TARGET] T) (SI::*CATCH-RETURN-FROM* [COND (THROWP (* ;  "if THROW then this is the RETURN-FROM flavor") (* ; "Go one frame further back") (SETQ TARGET (fetch (FX CLINK) of TARGET] T) (PROGN (* ; "blip matches contents of pvar1 but the name is wrong. This is important for THROW, less so for GO and RETURN-FROM.") NIL))) do (SI::UNWIND TARGET 'ERROR UNWINDER) (COND (PC (* ;  "a THROW TO needs a pc adjustment") (replace (FX PC) of TARGET with PC))) (RETURN TARGET]) (SI::UNWIND (LAMBDA (TARGET RESETSTATE UNWINDER) (* bvm%: " 4-Nov-86 22:24") (DECLARE (CL:SPECIAL RESETSTATE)) (* ;;; "Unwinds the stack between UNWINDER and TARGET. UNWINDER defaults to the caller. Returns to caller with it positioned to return to TARGET. RESETSTATE is the value to be seen by RESETSAVEs along the way.") (* ;;; "A TARGET of -1 means unwind the stack until you get to a frame with non-null use count. This is for returning to different stack groups.") (* ;;; "We are assuming that nobody from UNWINDER to here binds specvars (except RESETSTATE).") (if (NEQ TARGET UNWINDER) then (* ; "TARGET and UNWINDER could be indentical in the case where a frame THROWs from itself. ") (LET ((USECNTARGET (MINUSP TARGET)) CLEANUPFN) (OR RESETSTATE (SETQ RESETSTATE (QUOTE ERROR))) (OR UNWINDER (SETQ UNWINDER (\MYALINK))) (for (FRAME _ (fetch (FX CLINK) of UNWINDER)) until (if USECNTARGET then (OR (fetch (FX INVALIDP) of FRAME) (NEQ (fetch (FX USECNT) of FRAME) 0)) else (EQ FRAME TARGET)) do (SETQ CLEANUPFN (AND (EQ (fetch (FX FNHEADER FRAMENAME) of FRAME) (QUOTE SI::*UNWIND-PROTECT*)) (\GETBASEPTR (ADDSTACKBASE (fetch (FX IVAR) of FRAME)) 0))) (* ;; "cleanup forms are stored in first ivar. Go straight to the FNHEADER of the frame, since there is never an interpreted *UNWIND-PROTECT* frame") (SETQ FRAME (\DISCARDFRAME UNWINDER)) (* ; "Discard frame, set FRAME to next ancestor") (if CLEANUPFN then (* ; "only run the cleanup form after we have blown away the frame, so the dynamic bindings are right") (CL:FUNCALL CLEANUPFN)))))) ) (SI::VARIABLE-NAME-IN-FRAME [LAMBDA (FRAME CODE) (* ; "Edited 18-Feb-91 16:09 by jds") (* ;;; "Returns name of the var whose name table encoding is CODE (i.e., xVARCODE+n for xVARn).") (LET ((NT (fetch (FX NAMETABLE) of FRAME)) NAME) (for (NTBASE _ (\ADDBASE NT (fetch (FNHEADER OVERHEADWORDS) of T))) by (\ADDBASE NTBASE (CONSTANT (WORDSPERNAMEENTRY))) as [NT2BASE _ (\ADDBASE NT (+ (fetch (FNHEADER OVERHEADWORDS) of T) (fetch (FNHEADER NTSIZE) of NT] by (\ADDBASE NT2BASE (CONSTANT (WORDSPERNTOFFSETENTRY))) until (NULL-NTENTRY (SETQ NAME (GETSTKNAMEENTRY NTBASE 0))) when (EQP (GETSTKNTOFFSETENTRY NT2BASE 0) CODE) do (RETURN (\INDEXATOMVAL NAME]) (SI::PVAR-VALUE-IN-FRAME [LAMBDA (FRAME ATOM#) (* ; "Edited 18-Feb-91 14:56 by jds") (* ;;; "Returns value of pvar binding of atom number ATOM# in FRAME. FRAME is guaranteed not to be an interpreter frame") (for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) by ( WORDSPERNTOFFSETENTRY ) bind (NT _ (fetch (FX FNHEADER) of FRAME)) TMP NAME until (NULL-NTENTRY (SETQ NAME (GETSTKNAMEENTRY NT OFFSET))) do (COND ([AND (EQP NAME ATOM#) (EQP [NTSLOT-VARTYPE (SETQ TMP (GETSTKNTOFFSETENTRY NT (+ OFFSET (fetch (FNHEADER NTSIZE) of NT] PVARCODE) (fetch (PVARSLOT BOUND) of (SETQ TMP (ADDSTACKBASE (+ (fetch (FX FIRSTPVAR) of FRAME) (UNFOLD (NTSLOT-OFFSET TMP) WORDSPERCELL] (* ; "Found ATOM# in as a bound pvar") (RETURN (fetch (PVARSLOT PVVALUE) of TMP]) ) (DEFINEQ (\DISCARDFRAME (LAMBDA (CHILD) (* bvm "22-Nov-86 15:15") (* ;; "Splice out CHILD's parent. Return its new parent.") (UNINTERRUPTABLY (PROG ((OLDALINK (fetch (FX ALINK) of CHILD)) (OLDCLINK (fetch (FX CLINK) of CHILD)) NEWCLINK BLINK) (if (NEQ OLDALINK OLDCLINK) then (\DECUSECOUNT OLDALINK)) (SETQ NEWCLINK (fetch (FX CLINK) of OLDCLINK)) (replace (FX ACLINK) of CHILD with NEWCLINK) (* ; "Set new A&C links to new parent. This also makes CHILD slow. Now we're ready to wipe out OLDCLINK") (LET ((BLINK (fetch (FX BLINK) of OLDCLINK)) (SIZE (fetch (FX SIZE) of OLDCLINK)) (ALINK (fetch (FX ALINK) of OLDCLINK)) OLDUSECOUNT) (if (NEQ ALINK NEWCLINK) then (* ; "dec usecnt of ALINK of frame we're discarding. Normally ALINK = CLINK = NEWCLINK, so we don't have to touch it") (\DECUSECOUNT ALINK)) (if (EQ (SETQ OLDUSECOUNT (fetch (FX USECNT) of OLDCLINK)) 0) then (* ;; "normal case, this frame really will be discarded. This following code is an optimization of the \INCUSECOUNT + \DECUSECOUNT pair you would get by just doing the straightforward \SMASHLINK.") (COND ((fetch (BF RESIDUAL) of (fetch (FX DUMMYBF) of OLDCLINK)) (* ; "free the dummy bf as well") (\MAKEFREEBLOCK (IDIFFERENCE OLDCLINK WORDSPERCELL) (IPLUS SIZE WORDSPERCELL))) (T (\MAKEFREEBLOCK OLDCLINK SIZE))) (CHECK (fetch (BF CHECKED) of BLINK)) (COND ((EQ (fetch (BF USECNT) of BLINK) 0) (* ; "frame extension count+1=0 so release basic frame") (\MAKEFREEBLOCK (fetch (BF IVAR) of BLINK) (fetch (BF SIZE) of BLINK))) (T (* ; "merely decrement extension count") (add (fetch (BF USECNT) of BLINK) -1))) else (* ;; "Can't discard frame because someone's pointing at it. However, we can chop off its parents, leaving any holder with a stack it can't return to. Also have to decrement use count to account for dropping the pointer to it from CHILD.") (replace (FX USECNT) of OLDCLINK with (SUB1 OLDUSECOUNT)) (replace (FX ACLINK) of OLDCLINK with 0))) (RETURN NEWCLINK)))) ) (\SMASHRETURN (LAMBDA (CALLER FRAME STKP) (* bvm "22-Nov-86 15:34") (* ;; "Modify CALLER's a & c links to make it return to FRAME. If FRAME is an ancestor, we can unwind as we go. If FRAME is not an ancestor, things get fuzzy. If STKP is supplied, it is a stack pointer that should be released afterwards, though we will release it early if possible.") (LET ((MYCALLER (\MYALINK)) DESTPROC) (OR CALLER (SETQ CALLER MYCALLER)) (if (for (FX _ MYCALLER) when (EQ FX FRAME) do (RETURN T) repeatuntil (fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX)))) then (* ; "direct ancestor -- blow away everything in between") (if STKP then (* ;; "Since FRAME is a direct ancestor, it is safe to release stack pointer before unwinding, because its release cannot end up releasing FRAME--we have an implicit pointer to it via the control stack. By releasing STKP now, UNWIND may be able to dispose of more.") (RELSTK STKP)) (SI::UNWIND FRAME NIL CALLER) else (* ; "returning to different stack group. Better be in same process.") (\SMASHLINK NIL FRAME) (SETQ DESTPROC *CURRENT-PROCESS*) (\SMASHLINK NIL MYCALLER) (if (EQ DESTPROC (THIS.PROCESS)) then (* ; "unwind as long as nobody else is pointing at stack") (SI::UNWIND -1 NIL CALLER) (* ; "then return to requested place") (\SMASHLINK CALLER FRAME FRAME) (if STKP then (* ;; "have to release stack pointer AFTER unwinding, because it could be the only pointer to FRAME") (RELSTK STKP)) else (* ; "Trying to return to a different process. This could cause utter confusion.") (CL:ERROR "Attempt to return to a different process: ~A at frame ~S" (PROCESSPROP DESTPROC (QUOTE NAME)) (fetch (FX FNHEADER) of FRAME)))))) ) ) (* ; "parsing stack for gc") (DEFINEQ (\GCSCANSTACK [LAMBDA NIL (* ; "Edited 23-Jun-88 16:06 by rtk") (* ;  "scan stack space calling SCANREF on all pointers") (PROG ((SCANPTR (fetch StackBase of \InterfacePage)) (EASP (fetch EndOfStack of \InterfacePage)) SCANBASE Q) LP (SELECTC (fetch (STK FLAGS) of SCANPTR) (\STK.FX (* ; "frame extension") (PROG (NTEND NEXT) (CHECK (fetch (FX CHECKED) of SCANPTR)) (\STKREF (fetch (FX FNHEADER) of SCANPTR)) [SETQ SCANBASE (ADDSTACKBASE (SETQ Q (fetch (FX FIRSTPVAR) of SCANPTR] (FRPTQ (fetch (FX FNHEADER NLOCALS) of SCANPTR) [COND ((fetch (PVARSLOT BOUND) of SCANBASE) (\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE] (SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL))) (SETQ NEXT (SETQ Q (fetch (FX NEXTBLOCK) of SCANPTR))) (CHECK (IGREATERP NEXT SCANPTR)) [COND ((fetch (FX VALIDNAMETABLE) of SCANPTR) (* ; "Frame has separate nametable.") (COND ((EQ (fetch (FX NAMETABHI) of SCANPTR) \STACKHI) (* ;; "Nametable is on stack. Need to refcnt its framename and skip that section of the stack, since it does not contain pointers") (CHECK (ILEQ (fetch (FX NAMETABLO) of SCANPTR) Q)) (\STKREF (fetch (FNHEADER FRAMENAME) of (fetch (FX NAMETABLE#) of SCANPTR))) (SETQ Q (fetch (FX NAMETABLO) of SCANPTR)) (SETQ NTEND (IPLUS Q (fetch (FNHEADER OVERHEADWORDS) of T) (UNFOLD (fetch (FNHEADER NTSIZE) of (ADDSTACKBASE Q)) 2))) (* ;  "Need to skip the region from Q to NTEND") ) (T (* ;  "Nametable elsewhere, just reference it") (\STKREF (fetch (FX NAMETABLE) of SCANPTR] (SETQ SCANPTR (fetch (FX FIRSTTEMP) of SCANPTR)) SCANTEMPS (SETQ SCANBASE (ADDSTACKBASE SCANPTR)) (while (ILESSP SCANPTR Q) do [COND ((fetch (STACKCELL VALIDPOINTERP) of SCANBASE) (\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE ] (add SCANPTR WORDSPERCELL) (SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL))) (COND (NTEND (* ; "Skip over NT, scan after it") (SETQ SCANPTR NTEND) (SETQ Q NEXT) (SETQ NTEND) (GO SCANTEMPS))) (* ;; "in case this frame was truncated, don't trust the FIRSTTEMP field.") (SETQ SCANPTR NEXT))) (\STK.GUARD (AND (EQ SCANPTR EASP) (RETURN)) (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) (\STK.FSB (if NIL then (* ; "to merge free blocks") (SETQ Q (IPLUS SCANPTR (fetch (FSB SIZE) of SCANPTR))) (CHECK (NEQ SCANPTR Q)) (while (type? FSB Q) do (add (fetch (FSB SIZE) of SCANPTR) (SETQ NV (fetch (FSB SIZE) of Q))) (add Q NV)) (SETQ SCANPTR Q)) (add SCANPTR (fetch (FSB SIZE) of SCANPTR))) (LET ((ORIG SCANPTR)) (* ; "must be a basic frame") (SETQ SCANBASE (ADDSTACKBASE SCANPTR)) (until (type? BF SCANPTR) do (CHECK (EQ (fetch (STK FLAGS) of SCANPTR) \STK.NOTFLAG)) (\STKREF (fetch (STACKCELL VALIDPOINTER) of SCANBASE)) (add SCANPTR WORDSPERCELL) (SETQ SCANBASE (\ADDBASE SCANBASE WORDSPERCELL))) [CHECK (COND ((fetch (BF RESIDUAL) of SCANPTR) (EQ SCANPTR ORIG)) (T (AND (fetch (BF CHECKED) of SCANPTR) (EQ ORIG (fetch (BF IVAR) of SCANPTR] (add SCANPTR WORDSPERCELL))) (GO LP]) ) (* ; "setting up stack from scratch") (DEFINEQ (CLEARSTK (LAMBDA (FLG) (* bvm%: " 5-Feb-85 16:29") (PROG (LST) (\MAPMDS \STACKP (FUNCTION (LAMBDA (PAGE) (PROG ((I 0) (PTR (create POINTER PAGE# _ PAGE)) FX) LPE (COND ((AND (EQ (fetch (STACKP STACKP0) of PTR) \STACKHI) (NEQ (SETQ FX (fetch (STACKP EDFXP) of PTR)) 0)) (SELECTQ FLG (NIL (COND (NIL (* ; "Disallow this, we can't have this global smashing in the process world") (UNINTERRUPTABLY (PROGN (replace (STACKP EDFXP) of PTR with 0) (\DECUSECOUNT FX)))))) (**CLEAR** (* ; "Called by HARDRESET") (replace (STACKP EDFXP) of PTR with 0)) (push LST PTR)))) (COND ((NEQ (SETQ I (IPLUS I WORDSPERCELL)) \MDSIncrement) (SETQ PTR (\ADDBASE PTR WORDSPERCELL)) (GO LPE))))))) (RETURN LST))) ) (HARDRESET (LAMBDA NIL (* bvm%: "12-JAN-82 12:06") (* ;; "this is what Raid's ^D does") (\CONTEXTSWITCH \ResetFXP)) ) (RELSTK (LAMBDA (POS) (* lmm "27-JUL-81 09:42") (AND (STACKP POS) (PROG ((FX (fetch EDFXP of POS))) (COND ((NEQ FX 0) (UNINTERRUPTABLY (\DECUSECOUNT FX) (replace EDFXP of POS with 0)))))) POS) ) (RELSTKP (LAMBDA (X) (* ; "Edited 10-Nov-87 17:39 by bvm") (AND (STACKP X) (LET ((FRAME (fetch EDFXP of X))) (* ;; "Test for stack pointer released explicitly, or if somebody has already returned to/around the frame in question (in which case my clink is zero, but that's ok for T).") (OR (EQ FRAME 0) (AND (fetch (FX INVALIDP) of (fetch (FX CLINK) of FRAME)) (NEQ (fetch (FX FRAMENAME) of FRAME) T)))))) ) ) (DEFINEQ (SETUPSTACK (LAMBDA (INITFLG) (* lmm "22-JUN-83 15:08") (* ;; "INITFLG is on if coming from MAKEINIT. Kludge because fn definitions are not available during MAKEINIT") (CREATEPAGES \STACKSPACE (IQUOTIENT \InitStackSize WordsPerPage) NIL T) (* ; "create initial stack pages") (\SETUPGUARDBLOCK 0 WORDSPERCELL) (* ; "start stack with mini-guard block") (replace (IFPAGE CurrentFXP) of \InterfacePage with (\SETUPSTACK1 WORDSPERCELL 0 0 (IDIFFERENCE \StackAreaSize 2) 0 RESETPC RESETPTR NIL INITFLG)) (replace (IFPAGE ResetFXP) of \InterfacePage with 0) (replace (IFPAGE FAULTFXP) of \InterfacePage with 0) (replace (IFPAGE SubovFXP) of \InterfacePage with 0) (replace (IFPAGE KbdFXP) of \InterfacePage with 0) (\SETUPGUARDBLOCK (IDIFFERENCE \StackAreaSize 2) 2) (replace (IFPAGE StackBase) of \InterfacePage with (\SETUPGUARDBLOCK \StackAreaSize (IDIFFERENCE (IDIFFERENCE \InitStackSize \StackAreaSize) 2))) (replace (IFPAGE EndOfStack) of \InterfacePage with (\SETUPGUARDBLOCK (IDIFFERENCE \InitStackSize 2) 2))) ) (\SETUPSTACK1 (LAMBDA (STKP ALINK CLINK STKEND NARGS PC DEFPTR ARGS INITFLG ARGSLENGTH) (* ; "Edited 6-Apr-88 18:34 by rtk") (COND ((OR INITFLG (IGREATERP (IDIFFERENCE STKEND STKP) (IPLUS (PROG1 (fetch (FNHEADER STKMIN) of DEFPTR) (* ; "Space needed to call this fn")) (PROG1 WORDSPERQUAD (* ; "Extra slop"))))) (* ; "Don't build a frame if there isn't space!") (PROG ((SP STKP)) (if ARGSLENGTH then (SETQ ARGSLENGTH (MIN ARGSLENGTH NARGS)) (\BLT (ADDSTACKBASE SP) ARGS (UNFOLD ARGSLENGTH WORDSPERCELL)) (add SP (TIMES ARGSLENGTH WORDSPERCELL)) (SETQ ARGS)) (FRPTQ NARGS (PUTBASEPTR \STACKSPACE SP (AND ARGS (pop ARGS))) (* ; "store args") (add SP WORDSPERCELL)) (AND (PROG1 (COND ((ODDP SP WORDSPERQUAD) (PUTBASEPTR \STACKSPACE SP NIL) (* ; "Clear out the padding word") (add SP WORDSPERCELL) T)) (replace (STK FLAGWORD) of SP with \STK.BF.WORD)) (replace (BF PADDING) of SP with 1)) (replace (BF IVAR) of SP with STKP) (SETQ STKP (IPLUS SP WORDSPERCELL)) (replace (FX FLAGBYTE) of STKP with (CONSTANT (CL:READ-FROM-STRING "#B11000001"))) (* ;; "flag byte has 110 = fx, fast=nil, native=nil, incall=nil, validnametable=nil, nopush=t") (replace (FX USECNT) of STKP with 0) (replace (FX %#BLINK) of STKP with SP) (replace (FX %#ALINK) of STKP with (IPLUS ALINK \#ALINK.OFFSET 1)) (replace (FX %#CLINK) of STKP with (IPLUS CLINK \#ALINK.OFFSET)) (replace (FX FNHEADER) of STKP with DEFPTR) (replace (FX PC) of STKP with PC) (SETQ SP (fetch (FX FIRSTPVAR) of STKP)) (COND ((NOT INITFLG) (* ; "function definitions not available during MAKEINIT") (RPTQ (UNFOLD (ADD1 (fetch (FNHEADER PV) of DEFPTR)) CELLSPERQUAD) (PROGN (* ; "Fill in Pvar region with `unbound'") (\PUTBASE \STACKSPACE SP 65535) (add SP 2))))) (replace (FX NEXTBLOCK) of STKP with (add SP (fetch (FX PADDING) of STKP))) (* ; "Need extra junk quad after the (null) pvar region") (\MAKEFREEBLOCK SP (IDIFFERENCE STKEND SP)) (RETURN STKP))))) ) (\MAKEFRAME (LAMBDA (FN ST END ALINK CLINK ARGS ARGLOCN) (* lmm " 5-Feb-86 14:44") (CHECK (fetch (LITATOM CCODEP) of FN)) (PROG ((DEF (fetch (LITATOM DEFPOINTER) of FN))) (RETURN (\SETUPSTACK1 ST ALINK CLINK END (COND ((fetch (FNHEADER LSTARP) of DEF) 0) (T (fetch (FNHEADER NA) of DEF))) (fetch (FNHEADER STARTPC) of DEF) DEF ARGS NIL ARGLOCN)))) ) (\RESETSTACK [LAMBDA NIL (* ; "Edited 25-Jan-90 15:18 by jds") (* ;; "Do Hard reset. We get here only by a (\CONTEXTSWITCH \ResetFXP).") (PROG NIL LP (\RESETSTACK0) (\CONTEXTSWITCH \ResetFXP) (GO LP]) (\RESETSTACK0 (LAMBDA NIL (* ; "Edited 9-Dec-86 14:05 by bvm") (PROG ((BASE \StackAreaSize) (RPROC (AND \RUNNING.PROCESS (NULL \NEED.HARDRESET.CLEANUP)))) (if RPROC then (* ;; "Save frame of current process at time of hard reset. All other process frames are stored ok in process handles. \RUNNING.PROCESS is NIL at the beginning of the world or if process world not turned on. Want a frame in user space, not system context space, since only the user stack has interesting bindings to gather.") (SETQ \SAVED.USER.CONTEXT (for I from \ResetFXP to \FAULTFXP bind TMP (OLDBASE _ (fetch (IFPAGE StackBase) of \InterfacePage)) when (< OLDBASE (SETQ TMP (\GETBASE \InterfacePage I))) do (RETURN TMP) finally (* ; "The newer contexts aren't as nice about living in consecutive locations--have to expand out") (RETURN (if (< OLDBASE (SETQ TMP (fetch (IFPAGE TELERAIDFXP) of \InterfacePage))) then TMP elseif (< OLDBASE (SETQ TMP (fetch (IFPAGE MiscFXP) of \InterfacePage))) then TMP))))) (replace (IFPAGE FAULTFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \FAULTHANDLER) BASE (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE HardReturnFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOHARDRETURN) BASE (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE TELERAIDFXP) of \InterfacePage with (\MAKEFRAME (COND ((fetch (LITATOM CCODEP) of (FUNCTION \DOTELERAID)) (FUNCTION \DOTELERAID)) (T (FUNCTION \DUMMYTELERAID))) BASE (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (* ;; "NOTE: Anything below the key handler is considered super uninterruptable") (replace (IFPAGE KbdFXP) of \InterfacePage with (\MAKEFRAME (COND ((fetch (LITATOM CCODEP) of (QUOTE \KEYHANDLER)) (FUNCTION \KEYHANDLER)) (T (QUOTE \DUMMYKEYHANDLER))) (SETQ \KBDSTACKBASE BASE) (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE GCFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOGC) BASE (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE SubovFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOSTACKOVERFLOW) BASE (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE MiscFXP) of \InterfacePage with (\MAKEFRAME (FUNCTION \DOMISCAPPLY) (SETQ \MISCSTACKBASE BASE) (SETQ BASE (IPLUS BASE \StackAreaSize)) 0 0)) (replace (IFPAGE StackBase) of \InterfacePage with BASE) (* ; "StackBase distinguishes system contexts from user stack") (replace (IFPAGE ResetFXP) of \InterfacePage with (if RPROC then (* ;; "We now have enough stack set up that we can fault. Do stack scan for hardreset cleanup in the stackoverflow context (hopefully not used during same!). \NEED.HARDRESET.CLEANUP is flag to stackoverflow context to do something special. It also saves the address at which to start building user stack when finished. We leave old EndOfStack alone until \SETUPUSERSTACK runs and possibly adjusts it.") (SETQ \NEED.HARDRESET.CLEANUP BASE) (if (type? FSB BASE) then (* ; "have to make sure that last context has valid end, one that microcode won't try to merge") (\SETUPGUARDBLOCK BASE 2)) (fetch (IFPAGE SubovFXP) of \InterfacePage) else (\SETUPUSERSTACK BASE))))) ) (\SETUPUSERSTACK [LAMBDA (BASE) (* ; "Edited 5-Apr-90 19:22 by jds") (* ;; "Create initial base of user stack starting in stack space at location BASE. Return the resulting FX.") (PROG1 (\MAKEFRAME (FUNCTION \CODEFORTFRAME) BASE (PROGN [COND ((IGREATERP (SETQ BASE (fetch (IFPAGE EndOfStack) of \InterfacePage )) \InitStackSize) (* ;; "Trim stack back, unlocking pages. This way you don't permanently lock entire stack segment if you get a stack overflow") [\UNLOCKPAGES (ADDSTACKBASE \InitStackSize) (ADD1 (IDIFFERENCE (FOLDLO BASE WORDSPERPAGE) (FOLDLO \InitStackSize WORDSPERPAGE] (replace (IFPAGE EndOfStack) of \InterfacePage with (SETQ BASE (IDIFFERENCE \InitStackSize 2] BASE) 0 0) (\SETUPGUARDBLOCK BASE 2) (SETQ \NEED.HARDRESET.CLEANUP NIL) (* ;; "If we're coming up in the INIT, maybe need to do MAIKO MOVDs NOW:") (AND \DOFAULTINIT (EQ (fetch MachineType of \InterfacePage) \MAIKO) (\CONTEXTSWITCH \FAULTFXP)) (SETQ \RECLAIM.COUNTDOWN \RECLAIMMIN) (* ; "reenable gc") )]) (\SETUPGUARDBLOCK (LAMBDA (STKP LEN) (* lmm "27-JUL-81 09:34") (replace (FSB FLAGWORD) of STKP with \STK.GUARD.WORD) (replace (FSB SIZE) of STKP with LEN) STKP) ) (\MAKEFREEBLOCK (LAMBDA (STK SIZE) (* lmm "27-JUL-81 09:33") (PROGN (* ; "must be careful here, because stack is inconsistent in this region") (replace (FSB SIZE) of STK with SIZE) (replace (FSB FLAGWORD) of STK with \STK.FSB.WORD))) ) (\REPEATEDLYEVALQT (LAMBDA NIL (* lmm "10-JUN-81 16:41") (PROG ((\INTERRUPTABLE T)) LP (\RESETSYSTEMSTATE) (EVALQT) (GO LP))) ) (\DUMMYKEYHANDLER (LAMBDA NIL (* lmm " 4-APR-82 21:47") (* ;; "installed instead of KEYHANDLER by RESETSTACK when KEYHANDLER is not CCODEP, e.g. inside MICROTEST where LLKEY is not loaded") (PROG NIL LP (\CONTEXTAPPLY \KbdFXP (FUNCTION \CAUSEINTERRUPT) \KbdFXP) (\CONTEXTSWITCH \KbdFXP) (GO LP))) ) (\DUMMYTELERAID (LAMBDA NIL (* bvm%: "14-MAR-83 22:09") (PROG NIL LP (\CONTEXTSWITCH \TeleRaidFXP) (GO LP)))) (\CAUSEINTERRUPT (LAMBDA (CNTXT FN) (* bvm%: " 6-APR-83 15:40") (* ;; "Builds a frame for FN (default is \INTERRUPTFRAME) on top of the fx in the CNTXT slot of interface page, returning T on success") (PROG ((FRAME (\GETBASE \InterfacePage CNTXT)) NXT) (COND ((ILESSP FRAME (fetch (IFPAGE StackBase) of \InterfacePage)) (* ;; "I can't actually test \INTERRUPTABLE, because that might fault! I assume that any system context that lives is uninterruptable. This is mainly so I don't build an \INTERRUPTED frame on top of the fault handler. [Used to be test for context lower than the keyboard handler, but this is much safer.]") (* ;; "You might want to allow a RAID interrupt here, but that could be VERY dangerous if a fault is in progress, so best wait.") (RETURN))) (SETQ NXT (fetch (FX NEXTBLOCK) of FRAME)) (CHECK (fetch (FX CHECKED) of FRAME) (type? FSB NXT)) (RETURN (COND ((SETQ FRAME (\MAKEFRAME (OR FN (FUNCTION \INTERRUPTFRAME)) NXT (IPLUS NXT (fetch (FSB SIZE) of NXT)) FRAME FRAME)) (\PUTBASE \InterfacePage CNTXT FRAME) T))))) ) (\CONTEXTAPPLY (LAMBDA (CNTXT FN ARG) (* lmm "13-OCT-81 10:01") (PROG ((MYALINK (\MYALINK))) (\SMASHLINK NIL (GETBASE \InterfacePage CNTXT)) (RETURN (PROG1 (SPREADAPPLY* FN ARG) (\SMASHLINK NIL MYALINK))))) ) (\INTERRUPTFRAME [LAMBDA NIL (* ; "Edited 30-Jan-91 00:23 by jds") (COND (WINDFLG (\INTERRUPTED)) (T (INTERRUPTED]) (\INTERRUPTED (LAMBDA NIL (* lmm " 5-DEC-82 20:53") (COND (\INTERRUPTABLE (INTERRUPTED)) (T (* ; "Wrong, we weren't interruptable after all. Tell keyboard to try again later") (SETQ \PENDINGINTERRUPT T)))) ) (\CODEFORTFRAME [LAMBDA NIL (* ; "Edited 11-Jan-91 14:32 by jds") (\CALLME 'T) (CLEARSTK '**CLEAR**) (INITIALEVALQT) (PROG NIL LP (\REPEATEDLYEVALQT) (GO LP]) (\DOMISCAPPLY (LAMBDA NIL (* bvm%: "30-NOV-82 12:28") (\DOMISCAPPLY1))) (\DOMISCAPPLY1 (LAMBDA NIL (* bvm%: "30-NOV-82 12:29") (* ;;; "Utility context to perform selected operations in a `safe' area of the stack. Use \MISCAPPLY* macro to `call'.") (* ;; "The compiler emits a BIND for the SPREADAPPLY* below, hence we cannot do this at the root of the stack. Sigh [ought to be able to now, yes? --bvm]") (PROG NIL LP (replace (IFPAGE MISCSTACKRESULT) of \InterfacePage with (SPREADAPPLY* (fetch (IFPAGE MISCSTACKFN) of \InterfacePage) (fetch (IFPAGE MISCSTACKARG1) of \InterfacePage) (fetch (IFPAGE MISCSTACKARG2) of \InterfacePage))) (\CONTEXTSWITCH \MiscFXP) (GO LP))) ) ) (RPAQ? \SAVED.USER.CONTEXT NIL) (RPAQ? \NEED.HARDRESET.CLEANUP NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SAVED.USER.CONTEXT \NEED.HARDRESET.CLEANUP) ) (* ; "HARDRESET recovery code") (DEFINEQ (\GATHER-CLEANUP-FORMS (LAMBDA NIL (* bvm%: "27-Sep-86 19:07") (for PROC in \PROCESSES bind FRAME do (SETQ FRAME (fetch PROCFX of PROC)) (replace PROCHARDRESETINFO of PROC with (if (OR (NEQ FRAME 0) (AND (EQ PROC \RUNNING.PROCESS) (SETQ FRAME \SAVED.USER.CONTEXT))) then (\GATHER-CLEANUP-FORMS1 FRAME) else (* ; "no stack but not the running process?") (QUOTE ERROR))))) ) (\GATHER-CLEANUP-FORMS1 [LAMBDA (FRAME) (* ; "Edited 18-Feb-91 16:12 by jds") (bind (EOS _ (fetch (IFPAGE EndOfStack) of \InterfacePage)) (BOS _ (fetch (IFPAGE StackBase) of \InterfacePage)) BINDINGS IVAR FOUND-UNWIND B R NT until (fetch (FX INVALIDP) of FRAME) do [COND ([AND (< FRAME EOS) (> FRAME BOS) (type? FX FRAME) (\VALIDADDRESSP (SETQ NT (fetch (FX NAMETABLE) of FRAME))) [COND ((fetch (FX FASTP) of FRAME) (SETQ IVAR (fetch (FX DUMMYBF) of FRAME)) (* ;  "BF contiguous with FX, assume ok address") T) (T (* ; "expanded out so that we only check validity of BF in the case where there's really a separate one") (AND (< (SETQ IVAR (fetch (FX %#BLINK) of FRAME)) EOS) (>= IVAR BOS) (type? BF IVAR] (\VALIDADDRESSP (SETQ IVAR (ADDSTACKBASE (fetch (BF IVAR) of IVAR] (* ;  "be careful, since stack could be screwed up") (COND ((AND FOUND-UNWIND (SETQ B (\GATHER-SPECIAL-BINDINGS FRAME NT IVAR))) (* ; "Gather up bindings") (push BINDINGS B))) (SELECTQ (fetch (FNHEADER FRAMENAME) of NT) (SI::*UNWIND-PROTECT* (* ;  "cleanup forms are stored in first ivar") (push BINDINGS (LIST NIL (\GETBASEPTR (ADDSTACKBASE (fetch (FX IVAR) of FRAME)) 0))) (SETQ FOUND-UNWIND T)) (\MAKE.PROCESS0 (* ;  "Top of process. If has *RESETFORMS* is implicit RESETLST to take care of") [COND ([AND (NULL FOUND-UNWIND) (SETQ R (SI::PVAR-VALUE-IN-FRAME FRAME (NEW-SYMBOL-CODE 'SI::*RESETFORMS* (\ATOMPNAMEINDEX 'SI::*RESETFORMS*] (* ;  "act as though we saw unwind-protect, then the binding of *RESETFORMS*, and that's all") (RETURN `(((SI::*RESETFORMS* ,R)) (NIL SI::RESETUNWIND]) NIL) (SETQ FRAME (fetch (FX CLINK) of FRAME))) (T (* ; "stack screwed up, so fail") (RETURN 'ERROR] finally (RETURN BINDINGS]) (\GATHER-SPECIAL-BINDINGS [LAMBDA (FRAME NT IVAR) (* ; "Edited 18-Feb-91 14:59 by jds") (* ;;; "Gather up all specials bound in FRAME. NT is frame's name table, IVAR is the start of its BF. In case of duplicate names, only top value need be gathered.") (AND (NEQ (fetch (FNHEADER NTSIZE) of NT) 0) (for OFFSET from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT (WORDSPERNAMEENTRY)) bind TMP NAME BINDINGS CODE until (OR (NULL-NTENTRY (SETQ NAME (GETSTKNAMEENTRY NT OFFSET))) (EQP [SETQ CODE (NTSLOT-VARTYPE (SETQ TMP (GETSTKNTOFFSETENTRY NT (IPLUS OFFSET (fetch (FNHEADER NTSIZE) of NT] FVARCODE)) unless (OR (FMEMB (SETQ NAME (\INDEXATOMVAL NAME)) *HARDRESET-IGNORE-VARS*) (ASSOC NAME BINDINGS)) do (SELECTC CODE (IVARCODE [push BINDINGS (LIST NAME (\GETBASEPTR IVAR (UNFOLD ( NTSLOT-OFFSET TMP) WORDSPERCELL]) (PVARCODE [COND ([fetch (PVARSLOT BOUND) of (SETQ TMP (ADDSTACKBASE (IPLUS (fetch (FX FIRSTPVAR ) of FRAME) (UNFOLD (NTSLOT-OFFSET TMP) WORDSPERCELL] (push BINDINGS (LIST NAME (fetch (PVARSLOT PVVALUE) of TMP]) (PROGN (* ; "trashed name table, bail out") (RETURN T))) finally (RETURN BINDINGS]) (\HARDRESET-CLEANUP [LAMBDA (PROCESS) (* ; "Edited 21-Jan-91 14:10 by jds") (* ;;; "BINDINGS is a list containing all the interesting dynamic bindings of a process, intermixed with cleanup forms from UNWIND-PROTECT frames. Each element is either a list of bindings (pairs) for a single frame, or the pair (NIL cleanupfn) for an UNWIND.PROTECT. The list is in reverse order; i.e., first element corresponds to bottom of stack, and the last element is the first cleanup to run. Our task is to bind all these variables, in the appropriate order, and run the cleanup forms. Cleanup forms cannot do THROWs, because the stack is not around, just the variables.") (PROG ((BINDINGS (fetch PROCHARDRESETINFO of PROCESS)) (NVARS 0) (VARIABLES (LIST NIL)) VARTAIL TABLE NNILS NTSIZE LINEARBINDINGS MASTERLIST VAR VALUE INDEX OLDVAL) (if (NLISTP BINDINGS) then (* ;  "couldn't get cleanups. Might want to signal some error or post a warning here.") (RETURN)) (replace PROCHARDRESETINFO of PROCESS with NIL) [SETQ TABLE (HASHARRAY (TIMES 2 (LENGTH BINDINGS] (SETQ VARTAIL VARIABLES) [for X in BINDINGS do (if (NULL (CAR X)) then (* ;  "a cleanup form. Push the set of variables bound recently, then the cleanup form") (if LINEARBINDINGS then (push MASTERLIST X LINEARBINDINGS)) (SETQ LINEARBINDINGS NIL) else (* ; "a list of binding pairs") (for PAIR in X do (SETQ VALUE (CADR PAIR)) (SETQ OLDVAL (GETHASH (SETQ VAR (CAR PAIR)) TABLE)) (* ;  "hash entries are of the form (index . values)") (if (MEMB VAR LINEARBINDINGS) then (* ;  "a newer binding for same var with no intervening unwind overrides old binding") (RPLACA (CDR OLDVAL) VALUE) else (push LINEARBINDINGS VAR) (if OLDVAL then (RPLACD OLDVAL (CONS VALUE (CDR OLDVAL))) else [SETQ VARTAIL (CDR (RPLACD VARTAIL (CONS VAR NIL] (PUTHASH VAR (LIST (SETQ INDEX (add NVARS 1) ) VALUE) TABLE] (RETURN (.CALLAFTERPUSHINGNILS. (SETQ NNILS (+ NVARS (SETQ NTSIZE (CEIL [ADD1 (UNFOLD NVARS (CONSTANT ( WORDSPERNAMEENTRY ] WORDSPERQUAD)) (FOLDHI (fetch (FNHEADER OVERHEADWORDS) of T) WORDSPERCELL) (SUB1 CELLSPERQUAD))) (\HARDRESET-CLEANUP1 NNILS NVARS NTSIZE MASTERLIST (CDR VARIABLES) TABLE]) (\HARDRESET-CLEANUP1 [LAMBDA (NNILS NVARS NTSIZE MASTERLIST VARIABLES TABLE)(* ; "Edited 30-Jan-91 19:05 by jds") (* ;;; "Construct a name table in caller consisting of the bindings specified by args. NNILS is the number of NILs pushed onto the end of frame, to be used for the bindings themselves and for a name table. NVARS is the number of vars to bind. NTSIZE is the size of the name table in cells. Thus NNILS = NVARS+NTSIZE+name table overhead.") (* ;;; "The variables and bindings themselves are given by the remaining args. VARIABLES is a list of length NVARS containing the variable names. TABLE is a hash table mapping each variable name to a list (index . bindings), where index is the position of the var in VARIABLES (first = 1) and bindings is a list of values for the binding, most recent one first. MASTERLIST is a list whose elements alternate between a cleanup specification in the form (NIL cleanupFn) and a list of variables that were bound at the time.") (* ;;; "Procedure is to bind all the variables to their most recent values. Then walk down MASTERLIST, calling the cleanup fns and %"popping%" the bindings of the indicated variables along the way.") (LET ((CALLER (\MYALINK)) NILSTART NT HEADER VAR0CODE PVARBASE) (* ;; "Create a nametable inside CALLER where HARDRESET-CLEANUP1 pushed all those nils") (SETQ HEADER (fetch (FX FNHEADER) of CALLER)) (* ;  "The function header of code for HARDRESET-CLEANUP") (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch (FX NEXTBLOCK) of CALLER) (UNFOLD NNILS WORDSPERCELL))) (UNFOLD NVARS WORDSPERCELL)) WORDSPERQUAD))) (* ;; "NILSTART is the start of the block of NILs pushed by caller. The first NVARS cells of it will be used for bindings. Following that (rounded up to quadword) comes NT, the address of our synthesized nametable. To our caller, the whole block of NILs looks like dynamic stack, but we will create a name table out of it that pretends the first chunk of it is PVARs. To everyone else the distinction is immaterial.") (SETQ VAR0CODE (SUB1 (FOLDLO (IDIFFERENCE NILSTART (fetch (FX FIRSTPVAR) of CALLER)) WORDSPERCELL))) (* ;; "VAR0CODE is the name table code for our %"zero'th%" var. i.e., the nth var we will bind has code VAR0CODE+n, meaning it appears to be that pvar in the frame.") (SETQ PVARBASE (ADDSTACKBASE (IDIFFERENCE NILSTART WORDSPERCELL))) (* ;; "PVARBASE is the address (PVARSLOT) in which our %"zero'th%" var would be stored. i.e., the nth var we will bind is located at (\ADDBASE PVARBASE (UNFOLD n WORDSPERCELL)).") (UNINTERRUPTABLY (* ;; "Create name table with initial contents") (for VAR in VARIABLES as VAR# from 1 as NT1 from (fetch (FNHEADER OVERHEADWORDS) of T) by (CONSTANT ( WORDSPERNAMEENTRY )) as NT2 from (IPLUS (fetch (FNHEADER OVERHEADWORDS) of T) NTSIZE) by (CONSTANT (WORDSPERNTOFFSETENTRY)) do (\PUTBASEPTR PVARBASE (UNFOLD VAR# WORDSPERCELL) (CADR (GETHASH VAR TABLE))) (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR)) (SETSTKNTOFFSET-RAW NT NT2 PVARCODE (+ VAR0CODE VAR#))) (* ;; "now fix up header of NT") (replace (FNHEADER %#FRAMENAME) of NT with '\HARDRESET-CLEANUP) (replace (FNHEADER NTSIZE) of NT with NTSIZE) (replace (FX NAMETABLE) of CALLER with NT)) (for OP in MASTERLIST bind INFO SLOT NEXT ERRORS-SEEN do [COND [(NULL (CAR OP)) (* ; "a cleanup form") (COND ((\HARDRESET-CLEANUP-RUN (CADR OP)) (SETQ ERRORS-SEEN T] (T (* ; " pop bindings") (for VAR in OP do (SETQ INFO (GETHASH VAR TABLE)) (* ; "INFO = (var# . activebindings)") (COND ((NULL INFO) (HELP "HARDRESET miscalculation -- Trying to unbind var that is not bound" VAR)) (T (SETQ SLOT (\ADDBASE PVARBASE (UNFOLD (CAR INFO) WORDSPERCELL))) (COND ((SETQ NEXT (CDDR INFO)) (* ; " there is another value") (RPLACD INFO NEXT) (replace (PVARSLOT PVVALUE) of SLOT with (CAR NEXT))) (T (* ; "no more values, so unbind it") (REMHASH VAR TABLE) (replace (PVARSLOT BOUND) of SLOT with NIL] finally (RETURN (COND (ERRORS-SEEN 'ERROR) (T T]) (\HARDRESET-CLEANUP-RUN (LAMBDA (CLEANUPFN) (* ; "Edited 1-Jun-88 17:03 by bvm") (* ;; "Actually call a cleanup function. Return T if it caused an error, NIL otherwise. This is a separate fn so that the vars it binds and refers to are not cached inside the caller, who wants to be able to bind and unbind at will.") (HANDLER-BIND ((CL:ERROR (FUNCTION (LAMBDA (C) (RETFROM (QUOTE \HARDRESET-CLEANUP-RUN) T))))) (CL:FUNCALL CLEANUPFN) NIL)) ) ) (RPAQQ *HARDRESET-IGNORE-VARS* (SI::*CLEANUP-FORMS* SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM* SI::*CATCH-RETURN-TO* *FORM* *ARGVAL* *FN* *TAIL* *FIRSTTAIL* \INTERNAL \INTERRUPTABLE SI::*NLSETQFLAG* *PROCEED-CASES*)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *HARDRESET-IGNORE-VARS*) ) (* ; "Ufns for RETCALL") (DEFINEQ (\DORETCALL (LAMBDA (NARGS RETURNER) (* lmm " 5-Feb-86 15:58") (LET* ((RCFRAME (fetch (IFPAGE MiscFXP) of \InterfacePage)) (RETURNER (fetch (FX CLINK) RCFRAME)) (FN (\VAG2 0 (LET ((PC (fetch (FX PC) RETURNER)) (FNHEADER (fetch (FX FNHEADER) RETURNER))) (LOGOR (LSH (\GETBASEBYTE FNHEADER PC) 8) (\GETBASEBYTE FNHEADER (ADD1 PC)))))) (RETURNEE (fetch (FX CLINK) RETURNER)) (ARGLOC (DIFFERENCE (fetch (FX NEXTBLOCK) RETURNER) (UNFOLD NARGS WORDSPERCELL)))) (CHECK (EQ (fetch (FX FNHEADER FRAMENAME) of RCFRAME) (QUOTE \RETCALL)) (AND (LITATOM FN) (CCODEP FN)) (fetch (FX CHECKED) RCFRAME) (fetch (FX CHECKED) RETURNER) (fetch (FX CHECKED) RETURNEE)) (\INCUSECOUNT RETURNEE) (\DECUSECOUNT RCFRAME) (replace (IFPAGE MiscFXP) of \InterfacePage with (LET ((START (\FREESTACKBLOCK 1024 RETURNEE))) (OR (\MAKEFRAME FN START (PLUS START (fetch (FSB SIZE) START)) RETURNEE RETURNEE (ADDSTACKBASE ARGLOC) NARGS) (RAID "couldn't make a frame")))))) ) (\RETCALL (LAMBDA (NARGS) (* lmm " 5-Feb-86 15:05") (\MISCAPPLY* (QUOTE \DORETCALL) NARGS))) ) (RPAQ? STACKTESTING T) (* ; "Stack overflow handler") (DEFINEQ (\DOSTACKFULLINTERRUPT (LAMBDA NIL (* bvm%: " 4-Nov-85 17:34") (replace STACKOVERFLOW of \INTERRUPTSTATE with NIL) (RESETLST (RESETSAVE NIL (LIST (FUNCTION \CLEANUP.STACKFULL))) (STACK.FULL.WARNING T))) ) (STACK.FULL.WARNING (LAMBDA (FLG) (* bvm%: " 4-Nov-85 18:11") (DECLARE (SPECVARS FLG)) (* ; "Otherwise compiler optimizes this away") (COND (FLG (* ;; "True on call from \DOSTACKFULLINTERRUPT and NIL after we get into break. This way user can say OK to resume computation") (SETQ FLG NIL) (PROG ((HELPFLAG (QUOTE BREAK!))) (LISPERROR "STACK OVERFLOW" NIL T))))) ) (\CLEANUP.STACKFULL (LAMBDA NIL (* bvm%: " 5-Nov-85 11:22") (* ;;; "On a RESETSAVE around the stack full break, so that ^ or ^D from the break will do a HARDRESET") (COND ((SELECTQ AUTOHARDRESETFLG (NIL NIL) ((ERROR RESET) (EQ RESETSTATE AUTOHARDRESETFLG)) (SELECTQ RESETSTATE ((ERROR RESET) T) NIL)) (SETQ \STACKOVERFLOW) (HARDRESET)))) ) ) (RPAQ? \PENDINGINTERRUPT ) (RPAQ? \STACKOVERFLOW ) (RPAQ? AUTOHARDRESETFLG T) (ADDTOVAR RESETFORMS (SETQ \STACKOVERFLOW)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS AUTOHARDRESETFLG) ) (DECLARE%: DONTCOPY (ADDTOVAR INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK) (ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 \MAKEFREEBLOCK \FAULTHANDLER \KEYHANDLER \DUMMYKEYHANDLER \DOTELERAID \DUMMYTELERAID \DOHARDRETURN \DOGC \CAUSEINTERRUPT \INTERRUPTFRAME \CODEFORTFRAME \DOSTACKOVERFLOW \UNLOCKPAGES \DOMISCAPPLY) (LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE \KBDSTACKBASE \MISCSTACKBASE \SAVED.USER.CONTEXT \RUNNING.PROCESS \NEED.HARDRESET.CLEANUP)))) (ADDTOVAR EXPANDMACROFNS ADDSTACKBASE STACKADDBASE) EVAL@COMPILE (ADDTOVAR DONTCOMPILEFNS SETUPSTACK) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA SI::INTERNAL-THROW SI::NON-LOCAL-RETURN) ) (PRETTYCOMPRINT LLSTKCOMS) (RPAQQ LLSTKCOMS [(DECLARE%: DONTCOPY (EXPORT (RECORDS BF FX FSB STK) (CONSTANTS \#ALINK.OFFSET) (GLOBALVARS \PENDINGINTERRUPT \KBDSTACKBASE \MISCSTACKBASE \STACKOVERFLOW) (MACROS \MYALINK ADDSTACKBASE STACKADDBASE STACKGETBASE STACKGETBASEPTR STACKPUTBASE STACKPUTBASEPTR \MISCAPPLY*) (RECORDS STACKP) (CONSTANTS * STACKTYPES) (CONSTANTS \StackAreaSize (\InitStackSize (ITIMES \StackAreaSize 12))) (CONSTANTS \MAXSAFEUSECOUNT) (RECORDS NAMETABLESLOT FVARSLOT PVARSLOT STKTEMPSLOT BINDMARKSLOT) (CONSTANTS \NT.IVAR \NT.PVAR \NT.FVAR)) (RECORDS STACKCELL)) (COMS (* ;  "For LAMBDA* and Common Lisp functions.") (FNS \MYARGCOUNT \ARG0 \SETARG0)) (COMS (* ;  "basic spaghetti for allocating, moving and reclaiming stack frames") (FNS \HARDRETURN \DOHARDRETURN \DOGC1 \DOGC \DOHARDRETURN1 \DOSTACKOVERFLOW \MOVEFRAME \INCUSECOUNT \DECUSECOUNT \MAKESTACKP \SMASHLINK \FREESTACKBLOCK \EXTENDSTACK)) (COMS (* ; "Some ugly stack-munging ufns") (FNS \SLOWRETURN \COPY.N.UFN \POP.N.UFN \STORE.N.UFN \UNWIND.UFN)) (COMS (* ; "The unwinder") (FNS SI::NON-LOCAL-GO SI::NON-LOCAL-RETURN SI::NON-LOCAL-RETURN-VALUES SI::INTERNAL-THROW SI::INTERNAL-THROW-VALUES SI::UNWIND-TO-BLIP SI::UNWIND SI::VARIABLE-NAME-IN-FRAME SI::PVAR-VALUE-IN-FRAME) (FNS \DISCARDFRAME \SMASHRETURN)) (COMS (* ; "parsing stack for gc") (FNS \GCSCANSTACK)) (COMS (* ; "setting up stack from scratch") (FNS CLEARSTK HARDRESET RELSTK RELSTKP) (FNS SETUPSTACK \SETUPSTACK1 \MAKEFRAME \RESETSTACK \RESETSTACK0 \SETUPUSERSTACK \SETUPGUARDBLOCK \MAKEFREEBLOCK \REPEATEDLYEVALQT \DUMMYKEYHANDLER \DUMMYTELERAID \CAUSEINTERRUPT \CONTEXTAPPLY \INTERRUPTFRAME \INTERRUPTED \CODEFORTFRAME \DOMISCAPPLY \DOMISCAPPLY1) (INITVARS \SAVED.USER.CONTEXT \NEED.HARDRESET.CLEANUP) (GLOBALVARS \SAVED.USER.CONTEXT \NEED.HARDRESET.CLEANUP)) (COMS (* ; "HARDRESET recovery code") (FNS \GATHER-CLEANUP-FORMS \GATHER-CLEANUP-FORMS1 \GATHER-SPECIAL-BINDINGS \HARDRESET-CLEANUP \HARDRESET-CLEANUP1 \HARDRESET-CLEANUP-RUN) (VARS *HARDRESET-IGNORE-VARS*) (GLOBALVARS *HARDRESET-IGNORE-VARS*)) (COMS (* ; "Ufns for RETCALL") (FNS \DORETCALL \RETCALL)) (INITVARS (STACKTESTING T)) (COMS (* ; "Stack overflow handler") (FNS \DOSTACKFULLINTERRUPT STACK.FULL.WARNING \CLEANUP.STACKFULL) (INITVARS (\PENDINGINTERRUPT) (\STACKOVERFLOW) (AUTOHARDRESETFLG T)) (ADDVARS (RESETFORMS (SETQ \STACKOVERFLOW))) (GLOBALVARS AUTOHARDRESETFLG)) (DECLARE%: DONTCOPY (ADDVARS [INEWCOMS (FNS SETUPSTACK \SETUPSTACK1 \SETUPGUARDBLOCK \MAKEFREEBLOCK) (ALLOCAL (ADDVARS (LOCKEDFNS \RESETSTACK0 \MAKEFRAME \SETUPSTACK1 \MAKEFREEBLOCK \FAULTHANDLER \KEYHANDLER \DUMMYKEYHANDLER \DOTELERAID \DUMMYTELERAID \DOHARDRETURN \DOGC \CAUSEINTERRUPT \INTERRUPTFRAME \CODEFORTFRAME \DOSTACKOVERFLOW \UNLOCKPAGES \DOMISCAPPLY) (LOCKEDVARS \InterfacePage \DEFSPACE \STACKSPACE \KBDSTACKBASE \MISCSTACKBASE \SAVED.USER.CONTEXT \RUNNING.PROCESS \NEED.HARDRESET.CLEANUP] (EXPANDMACROFNS ADDSTACKBASE STACKADDBASE)) EVAL@COMPILE (ADDVARS (DONTCOMPILEFNS SETUPSTACK))) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA SI::INTERNAL-THROW-VALUES SI::INTERNAL-THROW SI::NON-LOCAL-RETURN-VALUES SI::NON-LOCAL-RETURN]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA SI::INTERNAL-THROW-VALUES SI::INTERNAL-THROW SI::NON-LOCAL-RETURN-VALUES SI::NON-LOCAL-RETURN) ) (PUTPROPS LLSTK COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (26973 28438 (\MYARGCOUNT 26983 . 27268) (\ARG0 27270 . 27836) (\SETARG0 27838 . 28436)) (28522 45444 (\HARDRETURN 28532 . 28748) (\DOHARDRETURN 28750 . 28929) (\DOGC1 28931 . 29146) (\DOGC 29148 . 29253) (\DOHARDRETURN1 29255 . 33570) (\DOSTACKOVERFLOW 33572 . 34472) (\MOVEFRAME 34474 . 38001) (\INCUSECOUNT 38003 . 38769) (\DECUSECOUNT 38771 . 39916) (\MAKESTACKP 39918 . 40378) ( \SMASHLINK 40380 . 41833) (\FREESTACKBLOCK 41835 . 44576) (\EXTENDSTACK 44578 . 45442)) (45490 49233 ( \SLOWRETURN 45500 . 45638) (\COPY.N.UFN 45640 . 45805) (\POP.N.UFN 45807 . 46482) (\STORE.N.UFN 46484 . 46658) (\UNWIND.UFN 46660 . 49231)) (49263 60146 (SI::NON-LOCAL-GO 49273 . 49771) ( SI::NON-LOCAL-RETURN 49773 . 50498) (SI::NON-LOCAL-RETURN-VALUES 50500 . 51073) (SI::INTERNAL-THROW 51075 . 51743) (SI::INTERNAL-THROW-VALUES 51745 . 52251) (SI::UNWIND-TO-BLIP 52253 . 55986) (SI::UNWIND 55988 . 57544) (SI::VARIABLE-NAME-IN-FRAME 57546 . 58466) (SI::PVAR-VALUE-IN-FRAME 58468 . 60144)) ( 60147 63781 (\DISCARDFRAME 60157 . 62105) (\SMASHRETURN 62107 . 63779)) (63819 70819 (\GCSCANSTACK 63829 . 70817)) (70866 72307 (CLEARSTK 70876 . 71570) (HARDRESET 71572 . 71693) (RELSTK 71695 . 71893) (RELSTKP 71895 . 72305)) (72308 84299 (SETUPSTACK 72318 . 73336) (\SETUPSTACK1 73338 . 75247) ( \MAKEFRAME 75249 . 75602) (\RESETSTACK 75604 . 75907) (\RESETSTACK0 75909 . 79013) (\SETUPUSERSTACK 79015 . 80719) (\SETUPGUARDBLOCK 80721 . 80887) (\MAKEFREEBLOCK 80889 . 81128) (\REPEATEDLYEVALQT 81130 . 81261) (\DUMMYKEYHANDLER 81263 . 81565) (\DUMMYTELERAID 81567 . 81680) (\CAUSEINTERRUPT 81682 . 82730) (\CONTEXTAPPLY 82732 . 82944) (\INTERRUPTFRAME 82946 . 83140) (\INTERRUPTED 83142 . 83354) ( \CODEFORTFRAME 83356 . 83612) (\DOMISCAPPLY 83614 . 83689) (\DOMISCAPPLY1 83691 . 84297)) (84513 102751 (\GATHER-CLEANUP-FORMS 84523 . 84899) (\GATHER-CLEANUP-FORMS1 84901 . 88530) ( \GATHER-SPECIAL-BINDINGS 88532 . 91506) (\HARDRESET-CLEANUP 91508 . 95965) (\HARDRESET-CLEANUP1 95967 . 102300) (\HARDRESET-CLEANUP-RUN 102302 . 102749)) (103213 104265 (\DORETCALL 103223 . 104165) ( \RETCALL 104167 . 104263)) (104333 105268 (\DOSTACKFULLINTERRUPT 104343 . 104551) (STACK.FULL.WARNING 104553 . 104921) (\CLEANUP.STACKFULL 104923 . 105266))))) STOP \ No newline at end of file diff --git a/sources/LLSUBRS b/sources/LLSUBRS new file mode 100644 index 00000000..b9dcbf8f --- /dev/null +++ b/sources/LLSUBRS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Dec-92 14:28:41" |{PELE:MV:ENVOS}SOURCES>LLSUBRS.;15| 21492 changes to%: (RECORDS MISCN-UFN-ENTRY) previous date%: "21-Feb-92 12:54:44" |{PELE:MV:ENVOS}SOURCES>LLSUBRS.;14|) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1988, 1989, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLSUBRSCOMS) (RPAQQ LLSUBRSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS))) (* ;;; "MISCN Vars & Functions") (EXPORT (VARS \MISCN-TABLE-LIST)) (FUNCTIONS MISCN) (OPTIMIZERS MISCN) (FNS MISCN-NUMBER \MISCN.UFN \UNDEFINED-MISCN-UFN MISCN-COLLECT \GET-MY-BF \INIT-MISCN-TABLE) (PROP ARGNAMES MISCN) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MISCN-UFN-SPEC MISCN-UFN-ENTRY)) (* ;;; " USER-SUBR Vars & Functions") (EXPORT (VARS \USER-SUBR-LIST)) (FUNCTIONS USER-SUBR ADD-USER-SUBR) (FNS \USER-SUBR-UFN \INIT-USER-SUBR-TABLE \UNDEFINED-USER-SUBR-UFN USER-SUBR-NUMBER EQ-TO-CAR EQ-TO-CADR) (PROP ARGNAMES USER-SUBR) (* ;;; "SUBRCALL Vars & Functions") (EXPORT (VARS \INITSUBRS)) (FUNCTIONS SUBRCALL) (OPTIMIZERS SUBRCALL) (FNS SUBRNUMBER) (* ;; "use this to make a subrs.h file for Maiko ") (FNS WRITECALLSUBRS FIX-SUBR-NAME) (PROP ARGNAMES SUBRCALL) (DECLARE%: DONTCOPY (RESOURCES UNIXSTRING)) (INITRESOURCES UNIXSTRING) (FNS \MOREVMEMFILE \WRITEMAP \COPYSYS0SUBR \PUPLEVEL1STATE SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD SUSPEND-LISP UNIX-USERNAME UNIX-FULLNAME UNIX-GETENV UNIX-GETPARM) (IFPROP ARGNAMES SHOWDISPLAY SETSCREENCOLOR \WRITERAWPBI \READRAWPBI RAID \LISPFINISH \GETPACKETBUFFER \GATHERSTATS \DSPRATE DSPBOUT DISKPARTITION \CHECKBCPLPASSWORD) (PROPS (LLSUBRS FILETYPE)))) (DECLARE%: EVAL@COMPILE DONTCOPY (ADDTOVAR DONTCOMPILEFNS SUBRCALL MISCN FIX-SUBR-NAME WRITECALLSUBRS) ) (* ;;; "MISCN Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (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))) (* "END EXPORTED DEFINITIONS") (DEFMACRO MISCN (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER MISCN (NAME &REST ARGS) `((OPCODES MISCN ,(MISCN-NUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (MISCN-NUMBER (LAMBDA (NAME) (* ; "Edited 7-Nov-88 15:21 by krivacic") (CADR (OR (ASSOC NAME \MISCN-TABLE-LIST) (ERROR NAME " not a MISCN index")))) ) (\MISCN.UFN (LAMBDA (ALPHA-BETA) (* ; "Edited 8-Jun-89 16:57 by jds") (* ;; "The UFN for the MISCN opcode.") (DECLARE (GLOBALVARS \MISCN-TABLE)) (* ;; "Get the misc index & number of args from the code stream") (LET ((INDEX (LRSH ALPHA-BETA 8)) (ARG-COUNT (LOGAND ALPHA-BETA 255))) (* ;; "compute the position of the real IVARS on the stack. Create a pointer to these args and pass it to the Handler routine.") (COND ((NOT (AND (BOUNDP (QUOTE \MISCN-TABLE)) \MISCN-TABLE)) (\INIT-MISCN-TABLE))) (LET* ((CALLER (\MYALINK)) (MY-BF (\GET-MY-BF)) (MY-IVAR (fetch (BF IVAR) of MY-BF)) (RESULT-IVAR (- MY-IVAR (LLSH ARG-COUNT 1))) (MY-PARMS-PTR (\VAG2 1 RESULT-IVAR)) (UFN-ENTRY (\ADDBASE \MISCN-TABLE (LLSH INDEX 1)))) (COND ((fetch (MISCN-UFN-ENTRY MISCN-MVS) OF UFN-ENTRY) (* ;; "This UFN can return Multiple values, so we need to preserve them.") (CL:UNWIND-PROTECT (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))) (T (* ;; "He said no MVs are possible, so don't even TRY to preserve them. This is an expanded and cleaned up version of CL:UNWIND-PROTECT, so watch it!") (PROG1 (.UNWIND.PROTECT. (FUNCTION (LAMBDA NIL (replace (BF IVAR) of MY-BF with RESULT-IVAR))) (APPLY* (\GETBASEPTR UFN-ENTRY 0) INDEX ARG-COUNT MY-PARMS-PTR)) (replace (BF IVAR) of MY-BF with RESULT-IVAR) (REPLACE (FX NEXTBLOCK) OF CALLER WITH RESULT-IVAR))))))) ) (\UNDEFINED-MISCN-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 15:56 by krivacic") (PRINTOUT T "index " INDEX ", arg count " ARG-COUNT T) (ERROR (CL:FORMAT T "Undefined MISCN[~d] with ~d args." INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (MISCN-COLLECT (LAMBDA (ARG-COUNT ARG-PTR) (* ; "Edited 3-Nov-88 11:52 by krivacic") (FOR I FROM 0 TO (- ARG-COUNT 1) COLLECT (\GETBASEPTR ARG-PTR (LLSH I 1)))) ) (\GET-MY-BF (LAMBDA NIL (* ; "Edited 3-Nov-88 11:08 by krivacic") (* ;; "Returns the stack index of the caller's BF.") (- (\MYALINK) 2)) ) (\INIT-MISCN-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \MISCN-TABLE-LIST \MISCN-TABLE)) (* ; "Edited 7-Mar-89 09:43 by jds") (LET ((OP-NUMBER 36) (OP-LENGTH 3) BASE) (SETQ \MISCN-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-MISCN-UFN) 0)) (SETQ BASE (FETCH (ARRAYP BASE) OF \MISCN-TABLE)) (for MISCN-ENTRY in \MISCN-TABLE-LIST do (SETA \MISCN-TABLE (CADR MISCN-ENTRY) (CADDR MISCN-ENTRY)) (REPLACE (MISCN-UFN-ENTRY MISCN-MVS) OF (\ADDBASE2 BASE (FETCH (MISCN-UFN-SPEC INDEX) OF MISCN-ENTRY)) WITH (FETCH (MISCN-UFN-SPEC MVS) OF MISCN-ENTRY))) (SETQ \MISCN-TABLE BASE))) ) ) (PUTPROPS MISCN ARGNAMES (NAME &REST ARGS)) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD MISCN-UFN-SPEC ( (* ;;  "This is the description for a MISCN opcode's UFN, as placed in \MISCN-TABLE-LIST.") NAME (* ;  "Name of the MISCN, for the MISCN macro's use.") INDEX (* ; "Sub-opcode index.") UFN-NAME (* ; "Name of the UFN") MVS (* ;  "T if the UFN can returnmultiple values. If this is NIL, MVs WILL NOT BE PRESERVED.") )) (BLOCKRECORD MISCN-UFN-ENTRY ((MISCN-MVS FLAG) (NIL BITS 3) (MISCN-UFN POINTER))) ) ) (* ;;; " USER-SUBR Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ \USER-SUBR-LIST ((DUMMY 10 DUMMY-UFN) (SAMPLE-USER-SUBR 0 SAMPLE-USER-SUBR-UFN))) (* "END EXPORTED DEFINITIONS") (DEFMACRO USER-SUBR (USER-SUBR-NAME &REST ARGS) `(MISCN USER-SUBR ,(USER-SUBR-NUMBER USER-SUBR-NAME) ,@ARGS)) (CL:DEFUN ADD-USER-SUBR (USER-SUBR-NAME USER-SUBR-INDEX USER-SUBR-UFN) (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ;; "Make Sure \USER-SUBR-TABLE is made") (IF (NOT (AND (BOUNDP '\USER-SUBR-TABLE) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (* ;; "See if the Name is already defined") [AND (FASSOC USER-SUBR-NAME \USER-SUBR-LIST) (CL:CERROR "Delete old User-subr" "User-subr ~S already defined" USER-SUBR-NAME) (SETA \USER-SUBR-TABLE (CADR (FASSOC USER-SUBR-NAME \USER-SUBR-LIST)) '\UNDEFINED-USER-SUBR-UFN) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-NAME \USER-SUBR-LIST :TEST 'EQ-TO-CAR] (* ;; "See if the UFN is already defined") [AND (OR (NEQ (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) '\UNDEFINED-USER-SUBR-UFN) (CL:FIND USER-SUBR-INDEX \USER-SUBR-LIST :KEY #'CL:SECOND)) (CL:CERROR "Delete old User-subr" " User-subr index ~d already defined" USER-SUBR-INDEX) (SETQ \USER-SUBR-LIST (CL:REMOVE USER-SUBR-INDEX \USER-SUBR-LIST :TEST 'EQ-TO-CADR] (CL:PUSH (LIST USER-SUBR-NAME USER-SUBR-INDEX (OR USER-SUBR-UFN '\UNDEFINED-USER-SUBR-UFN)) \USER-SUBR-LIST) (\INIT-USER-SUBR-TABLE)) (DEFINEQ (\USER-SUBR-UFN (LAMBDA (INDEX ARG-COUNT ARG-PTR) (DECLARE (GLOBALVARS \USER-SUBR-TABLE)) (* ; "Edited 4-Nov-88 18:43 by krivacic") (IF (NOT (AND (BOUNDP (QUOTE \USER-SUBR-TABLE)) \USER-SUBR-TABLE)) THEN (\INIT-USER-SUBR-TABLE)) (LET ((USER-SUBR-INDEX (\GETBASE ARG-PTR 1))) (* ;; "User SUBR ufn. Index on the User subr indexes") (APPLY* (ELT \USER-SUBR-TABLE USER-SUBR-INDEX) USER-SUBR-INDEX (- ARG-COUNT 1) (\ADDBASE ARG-PTR 2)))) ) (\INIT-USER-SUBR-TABLE (LAMBDA NIL (DECLARE (GLOBALVARS \USER-SUBR-TABLE \USER-SUBR-LIST)) (* ; "Edited 4-Nov-88 18:58 by krivacic") (SETQ \USER-SUBR-TABLE (ARRAY 256 (QUOTE POINTER) (QUOTE \UNDEFINED-USER-SUBR-UFN) 0)) (for SUBR-ENTRY in \USER-SUBR-LIST do (SETA \USER-SUBR-TABLE (CADR SUBR-ENTRY) (CADDR SUBR-ENTRY)))) ) (\UNDEFINED-USER-SUBR-UFN (LAMBDA (USER-SUBR-INDEX ARG-COUNT ARG-PTR) (* ; "Edited 7-Nov-88 14:33 by krivacic") (* ;; "User SUBR ufn. Index on the User subr indexes") (ERROR (CL:FORMAT NIL "Undefined USER-SUBR[~d] with ~d args." USER-SUBR-INDEX ARG-COUNT) (MISCN-COLLECT ARG-COUNT ARG-PTR))) ) (USER-SUBR-NUMBER (LAMBDA (NAME) (* ; "Edited 4-Nov-88 18:42 by krivacic") (CADR (OR (ASSOC NAME \USER-SUBR-LIST) (ERROR NAME " not a USER-SUBR index")))) ) (EQ-TO-CAR (LAMBDA (ITEM LIST) (EQ ITEM (CAR LIST)))) (EQ-TO-CADR (LAMBDA (ITEM LIST) (EQ ITEM (CADR LIST)))) ) (PUTPROPS USER-SUBR ARGNAMES (USER-SUBR-NAME &REST ARGS)) (* ;;; "SUBRCALL Vars & Functions") (* "FOLLOWING DEFINITIONS EXPORTED") (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))) (* "END EXPORTED DEFINITIONS") (DEFMACRO SUBRCALL (NAME &REST ARGS) [LET [(ARGNAMES (MAPCAR ARGS #'(LAMBDA (X) (GENSYM] `(CL:FUNCALL [CL:COMPILE NIL '(LAMBDA ,ARGNAMES ((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGNAMES] ,@ARGS]) (DEFOPTIMIZER SUBRCALL (NAME &REST ARGS) `((OPCODES SUBRCALL ,(SUBRNUMBER NAME) ,(LENGTH ARGS)) ,@ARGS)) (DEFINEQ (SUBRNUMBER [LAMBDA (NAME) (* ; "Edited 5-Feb-92 16:49 by jds") (* ;; "Given a SUBR's NAME or number, return the corresponding subr number.") (LET (NUMBER) (COND ((FIXP NAME) (CL:WARN "SUBR name (~d) is a number; should be abstracted." NAME) NAME) ((CADR (ASSOC NAME \INITSUBRS))) ([SETQ NUMBER (CADR (CL:ASSOC NAME \INITSUBRS :TEST (FUNCTION STRING.EQUAL] (CL:WARN "SUBR name ~s is in wrong package. Using ~d as subr number." NAME NUMBER)) (T (ERROR NAME " not a SUBR"]) ) (* ;; "use this to make a subrs.h file for Maiko ") (DEFINEQ (WRITECALLSUBRS (LAMBDA NIL (* ; "Edited 6-Nov-89 15:39 by jds") (CL:WITH-OPEN-FILE (*STANDARD-OUTPUT* "subrs.h" :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) (CL:FORMAT T "/* This file written from LLSUBRS on ~A */~&" (DATE)) (CL:FORMAT T "/* Do not edit this file! Instead, edit the list \initsubrs */~&") (CL:FORMAT T "/* on the lisp file LLSUBRS and then call WRITECALLSUBRS to */~&") (CL:FORMAT T "/* generate a new version. */~&") (for X in \INITSUBRS do (CL:FORMAT T "#define sb_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* MISCN opcodes */~&") (for X in \MISCN-TABLE-LIST do (CL:FORMAT T "#define miscn_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))) (CL:FORMAT T "~&~&/* Assigned USER SUBR numbers */~&") (for X in \USER-SUBR-LIST do (CL:FORMAT T "#define user_subr_~A 0~O~&" (FIX-SUBR-NAME (CAR X)) (CADR X))))) ) (FIX-SUBR-NAME (LAMBDA (NAME) (* ; "Edited 13-Feb-89 16:17 by jds") (* ;; "Fix up a SUBR name for use as a symbol in the C code, by:") (* ;; "Converting all -'s to _'s") (* ;; "Converting all .'s to _'s") (* ;; "Removing all \'s.") (* ;; "This allows us to use fairly normal Lisp symbols for SUBR names (like \TEDIT.BLTCHAR), while having them translate pleasantly.") (CONCATCODES (DREMOVE (CHARCODE \) (SUBST (CHARCODE _) (CHARCODE %.) (SUBST (CHARCODE _) (CHARCODE -) (CHCON NAME)))))) ) ) (PUTPROPS SUBRCALL ARGNAMES (NAME &REST ARGS)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF 'UNIXSTRING 'RESOURCES '(NEW (ALLOCSTRING 512] ) ) (/SETTOPVAL '\UNIXSTRING.GLOBALRESOURCE NIL) (DEFINEQ (\MOREVMEMFILE (LAMBDA (FILEPAGE) (* ; "Edited 27-Apr-88 13:36 by MASINTER") (SUBRCALL MOREVMEMFILE FILEPAGE))) (\WRITEMAP (LAMBDA (VP RP FLAGS) (* ; "Edited 27-Apr-88 13:37 by MASINTER") (SUBRCALL WRITEMAP VP RP FLAGS))) (\COPYSYS0SUBR (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:36 by MASINTER") (SUBRCALL COPYSYS0SUBR FID))) (\PUPLEVEL1STATE (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL PUPLEVEL1STATE FLG))) (SHOWDISPLAY (LAMBDA (BASE RASTERWIDTH) (* ; "Edited 27-Apr-88 13:40 by MASINTER") (* ;; "comments are done with semicolons one comment is at the right margin, it automatically do you type ") (SUBRCALL SHOWDISPLAY BASE RASTERWIDTH)) ) (SETSCREENCOLOR (LAMBDA (FLG) (* ; "Edited 20-Apr-88 12:37 by MASINTER") (SUBRCALL SETSCREENCOLOR FLG))) (\WRITERAWPBI (LAMBDA (PBI) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL WRITERAWPBI PBI))) (\READRAWPBI (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL READRAWPBI))) (RAID (LAMBDA (MESS1 MESS2 FLG) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL RAID MESS1 MESS2 FLG))) (\LISPFINISH (LAMBDA (DUMMY) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL LISPFINISH DUMMY))) (\GETPACKETBUFFER (LAMBDA NIL (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GETPACKETBUFFER))) (\GATHERSTATS (LAMBDA (FID) (* ; "Edited 20-Apr-88 12:38 by MASINTER") (SUBRCALL GATHERSTATS FID))) (\DSPRATE (LAMBDA (AC0 AC1 AC2) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPRATE AC0 AC1 AC2)) ) (DSPBOUT (LAMBDA (CHARCODE) (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SUBRCALL DSPBOUT CHARCODE))) (DISKPARTITION (LAMBDA NIL (* ; "Edited 20-Apr-88 12:39 by MASINTER") (SELECTQ (MACHINETYPE) ((DORADO DOLPHIN) (SUBRCALL DISKPARTITION)) ((DANDELION DOVE) (\DFSCurrentVolume)) NIL)) ) (\CHECKBCPLPASSWORD (LAMBDA (USER PASSWORD) (* ; "Edited 14-Jun-88 13:33 by drc:") (SUBRCALL CHECKBCPLPASSWORD USER PASSWORD)) ) (SUSPEND-LISP (LAMBDA NIL (* ; "Edited 20-Jun-88 15:24 by greep") (if (EQ (MACHINETYPE) (QUOTE MAIKO)) then (SUBRCALL SUSPEND-LISP) T else NIL)) ) (UNIX-USERNAME (LAMBDA NIL (* ; "Edited 1-Aug-88 23:22 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-USERNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-FULLNAME (LAMBDA NIL (* ; "Edited 18-Jul-88 03:47 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCES UNIXSTRING (if (SUBRCALL UNIX-FULLNAME UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-GETENV (LAMBDA (NAME) (* ; "Edited 1-Aug-88 23:13 by masinter") (if (EQ \MACHINETYPE \MAIKO) then (WITH-RESOURCE UNIXSTRING (if (SUBRCALL UNIX-GETENV (MKSTRING NAME) UNIXSTRING) then (CONCAT (SUBSTRING UNIXSTRING 1 (CL:POSITION #\Null UNIXSTRING))))))) ) (UNIX-GETPARM (LAMBDA (NAME) (* ; "Edited 27-Feb-91 17:11 by nm") (* ;; "Read information from the C emulator. Usually gets info about configuration of the machine we're running on.") (* ;; "Used to use CL:POSITION, but now called in the INIT if you're on a Sun, so I changed it to STRPOS.") (* ;; "SUBRCALL UNIX-GETPARM now returns the length of the string.") (if (EQ \MACHINETYPE \MAIKO) then (LET (LEN) (WITH-RESOURCE UNIXSTRING (SETQ LEN (SUBRCALL UNIX-GETPARM (MKSTRING NAME) UNIXSTRING)) (COND ((SMALLP LEN) (if (> LEN 0) then (CONCAT (SUBSTRING UNIXSTRING 1 LEN)))) (LEN (CONCAT (SUBSTRING UNIXSTRING 1 (SUB1 (STRPOS #\Null UNIXSTRING)))))))))) ) ) (PUTPROPS SHOWDISPLAY ARGNAMES (BASE RASTERWIDTH)) (PUTPROPS SETSCREENCOLOR ARGNAMES (FLG)) (PUTPROPS \WRITERAWPBI ARGNAMES (PBI)) (PUTPROPS \READRAWPBI ARGNAMES NIL) (PUTPROPS RAID ARGNAMES (MESS1 MESS2 FLG)) (PUTPROPS \LISPFINISH ARGNAMES (DUMMY)) (PUTPROPS \GETPACKETBUFFER ARGNAMES NIL) (PUTPROPS \GATHERSTATS ARGNAMES (FID)) (PUTPROPS \DSPRATE ARGNAMES (AC0 AC1 AC2)) (PUTPROPS DSPBOUT ARGNAMES (CHARCODE)) (PUTPROPS DISKPARTITION ARGNAMES NIL) (PUTPROPS \CHECKBCPLPASSWORD ARGNAMES (PASS CL:VECTOR)) (PUTPROPS LLSUBRS FILETYPE CL:COMPILE-FILE) (PUTPROPS LLSUBRS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1988 1989 1990 1991 1992) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (3665 6454 (MISCN-NUMBER 3675 . 3830) (\MISCN.UFN 3832 . 5287) (\UNDEFINED-MISCN-UFN 5289 . 5557) (MISCN-COLLECT 5559 . 5726) (\GET-MY-BF 5728 . 5871) (\INIT-MISCN-TABLE 5873 . 6452)) ( 9128 10493 (\USER-SUBR-UFN 9138 . 9578) (\INIT-USER-SUBR-TABLE 9580 . 9907) (\UNDEFINED-USER-SUBR-UFN 9909 . 10208) (USER-SUBR-NUMBER 10210 . 10371) (EQ-TO-CAR 10373 . 10430) (EQ-TO-CADR 10432 . 10491)) ( 14756 15405 (SUBRNUMBER 14766 . 15403)) (15466 16873 (WRITECALLSUBRS 15476 . 16376) (FIX-SUBR-NAME 16378 . 16871)) (17082 20697 (\MOREVMEMFILE 17092 . 17207) (\WRITEMAP 17209 . 17322) (\COPYSYS0SUBR 17324 . 17429) (\PUPLEVEL1STATE 17431 . 17540) (SHOWDISPLAY 17542 . 17780) (SETSCREENCOLOR 17782 . 17890) (\WRITERAWPBI 17892 . 17995) (\READRAWPBI 17997 . 18092) (RAID 18094 . 18206) (\LISPFINISH 18208 . 18313) (\GETPACKETBUFFER 18315 . 18420) (\GATHERSTATS 18422 . 18525) (\DSPRATE 18527 . 18682) (DSPBOUT 18684 . 18788) (DISKPARTITION 18790 . 18977) (\CHECKBCPLPASSWORD 18979 . 19111) (SUSPEND-LISP 19113 . 19263) (UNIX-USERNAME 19265 . 19515) (UNIX-FULLNAME 19517 . 19768) (UNIX-GETENV 19770 . 20035 ) (UNIX-GETPARM 20037 . 20695))))) STOP \ No newline at end of file diff --git a/sources/LLSYMBOL b/sources/LLSYMBOL new file mode 100644 index 00000000..eea5ac2d --- /dev/null +++ b/sources/LLSYMBOL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") (IL:FILECREATED "11-Jun-90 17:56:50" IL:|{PELE:MV:ENVOS}SOURCES>LLSYMBOL.;5| 9443 IL:|changes| IL:|to:| (IL:VARS IL:LLSYMBOLCOMS) IL:|previous| IL:|date:| " 4-Jun-90 15:10:38" IL:|{PELE:MV:ENVOS}SOURCES>LLSYMBOL.;4| ) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:LLSYMBOLCOMS) (IL:RPAQQ IL:LLSYMBOLCOMS ( (IL:* IL:|;;| "Symbol functions.") (IL:* IL:|;;| "SET , BOUNDP and REMPROP are the same as and shared with Interlisp-D") (IL:* IL:|;;| "Where is the optimizer for CL:GETF?") (IL:FUNCTIONS MAKUNBOUND SYMBOL-NAME SYMBOL-VALUE GET GETF GET-PROPERTIES) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:P (IL:MOVD 'IL:GETPROPLIST 'SYMBOL-PLIST))) (IL:FUNCTIONS FBOUNDP FMAKUNBOUND SYMBOL-FUNCTION IL:SETF-SYMBOL-FUNCTION) (IL:COMS (IL:* IL:|;;| "GENSYM Code") (IL:VARIABLES *GENSYM-COUNTER* *GENSYM-PREFIX* *GENTEMP-COUNTER*) (IL:FUNCTIONS GENSYM GENTEMP)) (IL:FUNCTIONS COPY-SYMBOL IL:MAKE-KEYWORD KEYWORDP) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:LLSYMBOL))) (IL:* IL:|;;| "Symbol functions.") (IL:* IL:|;;| "SET , BOUNDP and REMPROP are the same as and shared with Interlisp-D") (IL:* IL:|;;| "Where is the optimizer for CL:GETF?") (DEFUN MAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Make a symbol unbound.") (IL:* IL:|;;| " Unbound symbols are set to IL:NOBIND") (IF (CONSTANTP SYMBOL) (PROGN (XCL::SET-CONSTANTP SYMBOL NIL) (PROCLAIM `(SPECIAL ,SYMBOL)))) (SET SYMBOL 'IL:NOBIND) SYMBOL) (DEFUN SYMBOL-NAME (SYMBOL) (IF (SYMBOLP SYMBOL) (IL:* IL:|;;| "Make a read-only string header displaced to the pname base") (IL:%MAKE-ONED-ARRAY (IL:|ffetch| (IL:LITATOM IL:PNAMELENGTH) IL:|of| SYMBOL) 'STRING-CHAR NIL (IL:|ffetch| (IL:LITATOM IL:FATPNAMEP) IL:|of| SYMBOL) T NIL (IL:|ffetch| (IL:LITATOM IL:PNAMEBASE) IL:|of| SYMBOL) 1) (ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'SYMBOL :CULPRIT SYMBOL))) (DEFUN SYMBOL-VALUE (SYMBOL) (IL:* IL:|;;| "Like EVALV, but must give error if unbound - uses fact that \\eval has an opcode which hooks into free variable microcode") (IF (SYMBOLP SYMBOL) (IL:\\EVAL SYMBOL) (ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'SYMBOL :CULPRIT SYMBOL))) (DEFUN GET (SYMBOL INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Look on the property list of SYMBOL for the specified INDICATOR. If this is found, return the associated value, else return DEFAULT.") (GETF (IL:GETPROPLIST SYMBOL) INDICATOR DEFAULT)) (DEFUN GETF (PLACE INDICATOR &OPTIONAL (DEFAULT NIL)) (IL:* IL:|;;| "Searches the property list stored in Place for an indicator EQ to Indicator. If one is found, the corresponding value is returned, else the Default is returned.") (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) DEFAULT) (WHEN (EQ (CAR PLIST) INDICATOR) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed property list: ~s" PLACE) (RETURN (CADR PLIST)))))) (DEFUN GET-PROPERTIES (PLACE INDICATOR-LIST) (DO ((PLIST PLACE (CDDR PLIST))) ((NULL PLIST) (VALUES NIL NIL NIL)) (WHEN (MEMBER (CAR PLIST) INDICATOR-LIST :TEST #'EQ) (IF (NOT (CONSP (CDR PLIST))) (ERROR "Malformed p-list: ~s" PLACE) (RETURN (VALUES (CAR PLIST) (CADR PLIST) PLIST)))))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE (IL:MOVD 'IL:GETPROPLIST 'SYMBOL-PLIST) ) (DEFUN FBOUNDP (FN) (AND (SYMBOLP FN) (OR (IL:ARGTYPE FN) (MACRO-FUNCTION FN) (SPECIAL-FORM-P FN)) T)) (DEFUN FMAKUNBOUND (SYMBOL) (IL:* IL:|;;| "Has lots of special knowledge of prop list names") (SETF (SYMBOL-FUNCTION SYMBOL) NIL) (SETF (MACRO-FUNCTION SYMBOL) NIL) (REMPROP SYMBOL 'IL:SPECIAL-FORM) (REMPROP SYMBOL 'IL:CODE) (REMPROP SYMBOL 'IL:EXPR) SYMBOL) (DEFUN SYMBOL-FUNCTION (SYMBOL &AUX (DEF (IL:GETD SYMBOL))) (IL:* IL:|;;| "this function is preformance-critical, as it is used in the compilation of #'FOO => (CL:SYMBOL-FUNCTION 'FOO). Thus, this definition checks for the GETD definition first. It might even be reasonable to open-code the GETD here. It *is* unreasonable to call MACRO-FUNCTION and SPECIAL-FORM-P first.") (COND (DEF) (IL:* IL:\; "GETD returned non-NIL") ((SETQ DEF (MACRO-FUNCTION SYMBOL)) (IL:* IL:\;  "Return something representing the macro's implementation.") (CONS ':MACRO DEF)) ((SETQ DEF (SPECIAL-FORM-P SYMBOL)) (IL:* IL:\;  "Return something representing the special-form's implementation.") (CONS ':SPECIAL-FORM DEF)) (T (ERROR 'XCL:UNDEFINED-FUNCTION :NAME SYMBOL)))) (DEFUN IL:SETF-SYMBOL-FUNCTION (SYMBOL DEFINITION) (IL:* IL:|;;| "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!") (IL:* IL:|;;| " inverse of SYMBOL-FUNCTION") (IL:VIRGINFN SYMBOL T) (COND ((CONSP DEFINITION) (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.") (CASE (CAR DEFINITION) (:MACRO (SETF (MACRO-FUNCTION SYMBOL) (CDR DEFINITION))) (:SPECIAL-FORM (SETF (GET SYMBOL 'IL:SPECIAL-FORM) (CDR DEFINITION))) (T (IL:PUTD SYMBOL DEFINITION T)))) (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR. This isn't quite like Lucid and Symbolics, but it will do for now.") ((AND (SYMBOLP DEFINITION) (NOT (NULL DEFINITION))) (IL:PUTD SYMBOL (IL:GETD DEFINITION) T)) (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure. In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.") (T (IL:PUTD SYMBOL DEFINITION T))) (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions. We only remove the ones that could come from DEFMACRO.") (UNLESS (OR (NULL DEFINITION) (AND (CONSP DEFINITION) (EQ (CAR DEFINITION) :MACRO))) (REMPROP SYMBOL 'IL:MACRO-FN)) DEFINITION) (IL:* IL:|;;| "GENSYM Code") (DEFVAR *GENSYM-COUNTER* 0) (DEFVAR *GENSYM-PREFIX* "G") (DEFVAR *GENTEMP-COUNTER* 0) (DEFUN GENSYM (&OPTIONAL (X NIL X-P)) (IF X-P (ETYPECASE X (STRING (SETQ *GENSYM-PREFIX* X)) (INTEGER (SETQ *GENSYM-COUNTER* X)))) (PROG1 (MAKE-SYMBOL (CONCATENATE 'STRING *GENSYM-PREFIX* (IL:MKSTRING *GENSYM-COUNTER*))) (SETQ *GENSYM-COUNTER* (1+ *GENSYM-COUNTER*)))) (DEFUN GENTEMP (&OPTIONAL (PREFIX "T") (PACKAGE *PACKAGE*)) (IL:* IL:|;;| "*gentemp-counter* holds a good guess for the suffix ") (LET ((COUNTER *GENTEMP-COUNTER*) NAMESTRING) (IL:* IL:\;  "Use IL:MKSTRING rather than princ-to-string, since princ-to-string occurs late in the loadup") (LOOP (SETQ NAMESTRING (CONCATENATE 'STRING PREFIX (IL:MKSTRING COUNTER))) (WHEN (NULL (FIND-SYMBOL NAMESTRING PACKAGE)) (SETQ *GENTEMP-COUNTER* (1+ COUNTER)) (RETURN (INTERN NAMESTRING PACKAGE))) (SETQ COUNTER (1+ COUNTER))))) (DEFUN COPY-SYMBOL (SYM &OPTIONAL COPY-PROPS) (LET ((NEW-SYM (MAKE-SYMBOL (SYMBOL-NAME SYM)))) (WHEN COPY-PROPS (IF (BOUNDP SYM) (SETF (SYMBOL-VALUE NEW-SYM) (SYMBOL-VALUE SYM))) (IF (FBOUNDP SYM) (SETF (SYMBOL-FUNCTION NEW-SYM) (SYMBOL-FUNCTION SYM))) (SETF (SYMBOL-PLIST NEW-SYM) (COPY-LIST (SYMBOL-PLIST SYM)))) NEW-SYM)) (DEFUN IL:MAKE-KEYWORD (SYMBOL) (DECLARE (SPECIAL IL:*KEYWORD-PACKAGE*)) (VALUES (INTERN (SYMBOL-NAME SYMBOL) IL:*KEYWORD-PACKAGE*))) (DEFUN KEYWORDP (OBJECT) (AND (SYMBOLP OBJECT) (EQ (SYMBOL-PACKAGE OBJECT) IL:*KEYWORD-PACKAGE*))) (IL:PUTPROPS IL:LLSYMBOL IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:LLSYMBOL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:LLSYMBOL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/LLTIMER b/sources/LLTIMER new file mode 100644 index 00000000..9ccdcf38 --- /dev/null +++ b/sources/LLTIMER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 20:13:11" {DSK}local>lde>lispcore>sources>LLTIMER.;2 26691 changes to%: (VARS LLTIMERCOMS) previous date%: "13-May-88 15:29:44" {DSK}local>lde>lispcore>sources>LLTIMER.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LLTIMERCOMS) (RPAQQ LLTIMERCOMS ([COMS (* ;;; "Lowest level Clock stuff") (FNS \CLOCK0 \DAYTIME0 \GETINTERNALCLOCK \SETDAYTIME0 CLOCKDIFFERENCE \SECONDSCLOCKGREATERP \CLOCKGREATERP \RCLOCK0) (FNS CLOCK0) (OPTIMIZERS \RCLOCK0) (INITVARS (\RCLKMILLISECOND 1680)) (GLOBALVARS \RCLKSECOND \RCLKMILLISECOND) [COMS (* ;; "Maiko-specific elements") (FNS \MAIKO.DAYTIME \MAIKO.DAYTIME0 \MAIKO.CLOCK0 \MAIKO.CLOCK \MAIKO.COPY-TIME-STATS \MAIKO.SETTIME) (* ;; "The elements of \MAIKO.MOVDS get movd by \MAIKO.FAULTINIT") (ADDVARS (\MAIKO.MOVDS (\MAIKO.DAYTIME DAYTIME) (\MAIKO.DAYTIME0 \DAYTIME0) (\MAIKO.CLOCK0 \CLOCK0) (\MAIKO.CLOCK0 CLOCK0) (\MAIKO.CLOCK CLOCK) (\MAIKO.SETTIME \NS.SETTIME) (\MAIKO.SETTIME \PUP.SETTIME) (\MAIKO.SETTIME SETTIME) (\MAIKO.COPY-TIME-STATS CL::%%COPY-TIME-STATS] (DECLARE%: DONTCOPY (EXPORT (MACROS \UPDATETIMERS) (* ; "Locations in alto emulator") (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))) (* ;; "Locked stuff. Have to lock anything used by pagefault code, including the ufns that they use until all microcodes have them") (ADDVARS (INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \CLOCK0 \GETINTERNALCLOCK \BOXIDIFFERENCE \BOXIPLUS \BLT \SLOWIQUOTIENT) (LOCKEDVARS \RCLKSECOND \RCLKMILLISECOND \MISCSTATS] [COMS (* ; "basic date and time") (FNS CLOCK DAYTIME ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (PROP MACRO ALTO.TO.LISP.DATE LISP.TO.ALTO.DATE] (COMS (* ; "DURATION and TIMER things") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS TIMER.MAKESAFETIMER TIMER.TIMEREXPIRED? EXPAND.SETUPTIMER) (* ;  "Following macro needn't be installed since the function call is fairly slow anyway") (MACROS SETUPTIMER.DATE) (FNS \SETUPTIMERmacrofn))) (COMS (* ;; "macros for dealing with timers") (MACROS SETUPTIMER) (MACROS \TIMER.TIMERP \TIMER.MAKETIMER \TIMER.PLUS \TIMER.DIFFERENCE \TIMER.IN.SECONDS \TIMER.IN.MILLISECONDS \TIMER.IN.TICKS) (FNS \SETUPTIMERmacrofn \CanonicalizeTimerUnits) (FNS SETUPTIMER SETUPTIMER.DATE TIMEREXPIRED? TIME.UNTIL) (VARS (\TIMEREXPIRED.BOX (SETUPTIMER 0))) (GLOBALVARS \TIMEREXPIRED.BOX \RCLKMILLISECOND \RCLKSECOND)) (* ;; "Arrange for the proper compiler.") (PROP FILETYPE LLTIMER))) (* ;;; "Lowest level Clock stuff") (DEFINEQ (\CLOCK0 (LAMBDA (BOX) (* lmm "11-Sep-84 11:58") (* Stores millisecond clock in BOX. Do this by fetching the current millisecond clock and adding in the number of milliseconds since the clock was last updated) (SETQ BOX (\DTEST BOX (QUOTE FIXP))) (UNINTERRUPTABLY (\GETINTERNALCLOCK \OFFSET.MILLISECONDS BOX) (bind (EXCESS _ (LOCF (fetch EXCESSTIMETMP of \MISCSTATS))) while (OR (IGREATERP EXCESS \RCLKSECOND) (ILESSP EXCESS 0)) do (* Excess time. unsigned, is more than a second, so clock has not been updated in ages (perhaps someone sat in Raid for a while) %. We don't want IQUOTIENT here to do a CREATECELL, so do some of the division by subtraction. Instead of \RCLKSECOND, it would really be better to use \RCLKMILLISECOND*MAX.SMALL.INTEGER, but this is a rare case already, so be lazy) (\BOXIPLUS BOX 1000) (\BOXIDIFFERENCE EXCESS \RCLKSECOND) finally (* Now it is safe to use IQUOTIENT) (RETURN (\BOXIPLUS BOX (IQUOTIENT (COND ((IGREATERP EXCESS MAX.SMALL.INTEGER) EXCESS) (T (fetch (FIXP LONUM) of EXCESS))) \RCLKMILLISECOND)))))) ) (\DAYTIME0 (LAMBDA (BOX) (* bvm%: "24-JUN-82 15:39") (UNINTERRUPTABLY (\GETINTERNALCLOCK \OFFSET.SECONDS (\DTEST BOX (QUOTE FIXP))))) ) (\GETINTERNALCLOCK (LAMBDA (CLOCKOFFSET BOX) (* bvm%: "24-JUN-82 15:39") (* Stores in BOX the contents of internal timer denoted by CLOCKOFFSET (0 = SECONDS, 2 = MILLISECONDS) %. Excess time is in EXCESSTIMETEMP. Must be called UNINTERRUPTABLY) (\BLT (LOCF (fetch SECONDSTMP of \MISCSTATS)) (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) (UNFOLD 3 WORDSPERCELL)) (* Copy system clocks into scratch area, so there is no update conflict) (\BLT BOX (\ADDBASE (LOCF (fetch SECONDSTMP of \MISCSTATS)) CLOCKOFFSET) WORDSPERCELL) (* Copy clock to caller) (\BOXIDIFFERENCE (\RCLK (LOCF (fetch EXCESSTIMETMP of \MISCSTATS))) (LOCF (fetch BASETMP of \MISCSTATS))) (* Compute processor time since clock was updated) BOX) ) (\SETDAYTIME0 (LAMBDA (BOX) (* bvm%: " 8-Jul-85 20:39") (* Sets the seconds calendar to contents of BOX) (SETQ BOX (\DTEST BOX (QUOTE FIXP))) (UNINTERRUPTABLY (\RCLK (LOCF (fetch BASETMP of \MISCSTATS))) (* Reset the base; clocks will not be adjusted for at least a second after this) (\BLT (LOCF (fetch SECONDSTMP of \MISCSTATS)) BOX WORDSPERCELL) (LET ((TMP (ITIMES 1000 (fetch (FIXP LONUM) of BOX)))) (* Need to set msecs clock to 1000 * secs clock, but try not to do too much bignum arithmetic...) (replace (FIXP LONUM) of (LOCF (fetch MILLISECONDSTMP of \MISCSTATS)) with (LOGAND TMP MAX.SMALLP)) (replace (FIXP HINUM) of (LOCF (fetch MILLISECONDSTMP of \MISCSTATS)) with (IPLUS16 (LRSH TMP BITSPERWORD) (LOGAND (ITIMES (fetch (FIXP HINUM) of BOX) 1000) MAX.SMALLP)))) (\BLT (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) (LOCF (fetch SECONDSTMP of \MISCSTATS)) (UNFOLD 3 WORDSPERCELL)) (* Finally store them all at once, uninterruptably) (COND ((EQ \MACHINETYPE \DANDELION) (* Tell the iop the new time, too) (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE) \DL.PROCESSORBUSY)) (replace DLPROCESSOR2 of \IOPAGE with (\GETBASE BOX 1)) (replace DLPROCESSOR1 of \IOPAGE with (\GETBASE BOX 0)) (replace DLPROCESSORCMD of \IOPAGE with \DL.SETTOD) (replace DLTODVALID of \IOPAGE with 0) (repeatwhile (IGEQ (fetch DLPROCESSORCMD of \IOPAGE) \DL.PROCESSORBUSY)) (repeatwhile (EQ (fetch DLTODVALID of \IOPAGE) 0)))) (\PROCESS.RESET.TIMERS)) BOX) ) (CLOCKDIFFERENCE (LAMBDA (OLDCLOCK) (* bvm%: "24-JUN-82 15:40") (UNINTERRUPTABLY (IPLUS (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS))) OLDCLOCK)))) ) (\SECONDSCLOCKGREATERP (LAMBDA (OLDCLOCK SECONDS) (* bvm%: " 7-Dec-83 15:27") (UNINTERRUPTABLY (\BLT (LOCF (fetch CLOCKTEMP0 of \MISCSTATS)) (LOCF (fetch SECONDSCLOCK of \MISCSTATS)) WORDSPERCELL) (IGREATERP (\BOXIDIFFERENCE (LOCF (fetch CLOCKTEMP0 of \MISCSTATS)) OLDCLOCK) SECONDS))) ) (\CLOCKGREATERP (LAMBDA (OLDCLOCK MSECS) (* bvm%: "17-Dec-83 16:38") (* * True if more than MSECS milliseconds have elapsed since OLDCLOCK was set) (UNINTERRUPTABLY (IGREATERP (\BOXIDIFFERENCE (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS))) OLDCLOCK) MSECS))) ) (\RCLOCK0 (LAMBDA (BOX) (* JonL "19-APR-83 01:47") (\RCLK (\DTEST BOX (QUOTE FIXP))))) ) (DEFINEQ (CLOCK0 (LAMBDA (BOX) (* bvm%: " 1-APR-83 15:26") (* Store millisecond clock at BOX. Unfortunately, there are still a few folks that call this without a true box, so accomodate them for now) (COND ((EQ (NTYPX BOX) \FIXP) (\CLOCK0 BOX)) (T (\MP.ERROR \MP.CLOCK0 "Call to CLOCK0 with arg not a number box. ^N to continue." BOX) (UNINTERRUPTABLY (\BLT BOX (\CLOCK0 (LOCF (fetch CLOCKTEMP0 of \MISCSTATS))) WORDSPERCELL)) BOX))) ) ) (DEFOPTIMIZER \RCLOCK0 (BOX) `(\RCLK (\DTEST ,BOX 'FIXP))) (RPAQ? \RCLKMILLISECOND 1680) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \RCLKSECOND \RCLKMILLISECOND) ) (* ;; "Maiko-specific elements") (DEFINEQ (\MAIKO.DAYTIME (LAMBDA (BOX) (* ; "Edited 2-May-88 16:20 by MASINTER") (SUBRCALL GETUNIXTIME 5 BOX))) (\MAIKO.DAYTIME0 (LAMBDA (BOX) (* ; "Edited 2-May-88 16:20 by MASINTER") (SUBRCALL GETUNIXTIME 4 BOX))) (\MAIKO.CLOCK0 (LAMBDA (BOX) (* ; "Edited 2-May-88 16:19 by MASINTER") (SUBRCALL GETUNIXTIME 0 BOX))) (\MAIKO.CLOCK (LAMBDA (N BOX) (* ; "Edited 2-May-88 16:11 by MASINTER") (SUBRCALL GETUNIXTIME N BOX))) (\MAIKO.COPY-TIME-STATS (LAMBDA (REFERENCE-BLOCK DESTINIATION-BLOCK) (* ; "Edited 2-May-88 17:16 by MASINTER") (SUBRCALL COPYTIMESTATS REFERENCE-BLOCK DESTINIATION-BLOCK)) ) (\MAIKO.SETTIME [LAMBDA (RETFLG) (* ; "Edited 13-May-88 15:22 by MASINTER") (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG))) (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL))) (\PROCESS.RESET.TIMERS) (DAYTIME]) ) (* ;; "The elements of \MAIKO.MOVDS get movd by \MAIKO.FAULTINIT") (ADDTOVAR \MAIKO.MOVDS (\MAIKO.DAYTIME DAYTIME) (\MAIKO.DAYTIME0 \DAYTIME0) (\MAIKO.CLOCK0 \CLOCK0) (\MAIKO.CLOCK0 CLOCK0) (\MAIKO.CLOCK CLOCK) (\MAIKO.SETTIME \NS.SETTIME) (\MAIKO.SETTIME \PUP.SETTIME) (\MAIKO.SETTIME SETTIME) (\MAIKO.COPY-TIME-STATS CL::%%COPY-TIME-STATS)) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: EVAL@COMPILE (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]) ) (DECLARE%: EVAL@COMPILE (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)) ) (* "END EXPORTED DEFINITIONS") (ADDTOVAR INEWCOMS (ALLOCAL (ADDVARS (LOCKEDFNS \CLOCK0 \GETINTERNALCLOCK \BOXIDIFFERENCE \BOXIPLUS \BLT \SLOWIQUOTIENT) (LOCKEDVARS \RCLKSECOND \RCLKMILLISECOND \MISCSTATS)))) ) (* ; "basic date and time") (DEFINEQ (CLOCK (LAMBDA (N BOX) (* lmm "15-OCT-82 11:44") (SELECTQ (OR N 0) (0 (* time of day in MS) (\CLOCK0 (COND ((type? FIXP BOX) BOX) (T (CREATECELL \FIXP))))) (1 (* time this VM was started) (fetch STARTTIME of \MISCSTATS)) (2 (* run time for this VM) (\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE (\BOXIDIFFERENCE (\CLOCK0 (COND ((type? FIXP BOX) BOX) (T (CREATECELL \FIXP)))) (LOCF (fetch SWAPWAITTIME of \MISCSTATS))) (LOCF (fetch KEYBOARDWAITTIME of \MISCSTATS))) (LOCF (fetch STARTTIME of \MISCSTATS))) (LOCF (fetch GCTIME of \MISCSTATS)))) (3 (* GC TIME) (fetch GCTIME of \MISCSTATS)) (\ILLEGAL.ARG N))) ) (DAYTIME (LAMBDA NIL (* bvm%: " 8-Jul-85 20:01") (ALTO.TO.LISP.DATE (\DAYTIME0 (CREATECELL \FIXP))))) (ALTO.TO.LISP.DATE (LAMBDA (DATE) (* bvm%: "18-FEB-81 00:35") (* DATE is a 32-bit unsigned integer. To avoid signbit lossage, we subtract MIN.INTEGER from DATE, thereby making day 0 in the middle of the range. Do this by toggling the high-order bit to avoid integer overflow.) (LOGXOR DATE -2147483648)) ) (LISP.TO.ALTO.DATE (LAMBDA (DATE) (* bvm%: "18-FEB-81 00:35") (LOGXOR DATE -2147483648))) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (PUTPROPS ALTO.TO.LISP.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (PUTPROPS LISP.TO.ALTO.DATE MACRO ((DATE) (LOGXOR DATE -2147483648))) (* "END EXPORTED DEFINITIONS") ) (* ; "DURATION and TIMER things") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS TIMER.MAKESAFETIMER DMACRO (OPENLAMBDA (TIMER BOX) (\PUTBASEFIXP BOX 0 TIMER) BOX)) (PUTPROPS TIMER.TIMEREXPIRED? DMACRO ((OLDTIMER INTERVAL) (UNINTERRUPTABLY (IGEQ (\BOXIDIFFERENCE OLDTIMER INTERVAL) 0)))) (PUTPROPS EXPAND.SETUPTIMER MACRO (L (\SETUPTIMERmacrofn L T))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS SETUPTIMER.DATE MACRO ((DTS TIMER) (SETUPTIMER (IDIFFERENCE (IDATE DTS) (IDATE)) TIMER 'SECONDS 'SECONDS))) ) (DEFINEQ (\SETUPTIMERmacrofn (LAMBDA (X NOERRORCHKS) (* lmm "12-Apr-85 13:46") (PROG ((INTERVALFORM (CAR X)) (TIMERFORM (CADR X)) (TimerUnits (CONSTANTEXPRESSIONP (CADDR X))) (IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X))) (CLOCKFNNAME)) (if (OR (NULL TimerUnits) (NULL IntervalUnits)) then (* If either of the units are true computibles, then we can't select clock functions at macroexpansion time.) (RETURN (QUOTE IGNOREMACRO))) (SETQ TimerUnits (CANONICAL.TIMERUNITS (CAR TimerUnits))) (SETQ IntervalUnits (if (NULL (CAR IntervalUnits)) then TimerUnits else (CANONICAL.TIMERUNITS (CAR IntervalUnits)))) (* Notice how the following SELECTQ may also modify the code expression for the INTERVALFORM to do any necessary transformations between the specifiend timer units and the specified interval units.) (SETQ CLOCKFNNAME (SELECTQ TimerUnits (TICKS (SELECTQ IntervalUnits ((MILLISECONDS) (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM \RCLKMILLISECOND)))) ((SECONDS) (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM \RCLKSECOND)))) NIL) (QUOTE \TIMER.IN.TICKS)) (MILLISECONDS (SELECTQ IntervalUnits (TICKS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM \RCLKMILLISECOND)))) (SECONDS (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM 1000)))) NIL) (QUOTE \TIMER.IN.MILLISECONDS)) (SECONDS (SELECTQ IntervalUnits (MILLISECONDS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM 1000)))) (TICKS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM \RCLKSECOND)))) NIL) (QUOTE \TIMER.IN.SECONDS)) (SHOULDNT))) (if (NOT NOERRORCHKS) then (SETQ TIMERFORM (if (CONSTANTEXPRESSIONP TIMERFORM) then (QUOTE (\TIMER.MAKETIMER)) else (LET ((FORM (QUOTE (COND ((\TIMER.TIMERP Timer?) Timer?) (T (\TIMER.MAKETIMER)))))) (if (NLISTP TIMERFORM) then (SUBST TIMERFORM (QUOTE Timer?) FORM) else (BQUOTE ((LAMBDA (Timer?) (DECLARE (LOCALVARS Timer?)) %, FORM) %, TIMERFORM))))))) (RETURN (BQUOTE (\TIMER.PLUS (%, CLOCKFNNAME %, TIMERFORM) %, INTERVALFORM))))) ) ) ) (* ;; "macros for dealing with timers") (DECLARE%: EVAL@COMPILE (PUTPROPS SETUPTIMER MACRO (X (\SETUPTIMERmacrofn X))) ) (DECLARE%: EVAL@COMPILE [PROGN (PUTPROPS \TIMER.TIMERP MACRO ((X) (FIXP X))) (PUTPROPS \TIMER.TIMERP DMACRO ((X) (TYPENAMEP X 'FIXP)))] (PUTPROPS \TIMER.MAKETIMER DMACRO (NIL (NCREATE 'FIXP))) (PUTPROPS \TIMER.PLUS DMACRO ((OLDTIMER INTERVAL) (\BOXIPLUS OLDTIMER INTERVAL))) (PUTPROPS \TIMER.DIFFERENCE DMACRO ((TIMER2 TIMER1) (IDIFFERENCE TIMER2 TIMER1))) (PUTPROPS \TIMER.IN.SECONDS DMACRO ((OLDTIMER) (\DAYTIME0 OLDTIMER))) (PUTPROPS \TIMER.IN.MILLISECONDS DMACRO ((OLDTIMER) (\CLOCK0 OLDTIMER))) (PUTPROPS \TIMER.IN.TICKS DMACRO ((OLDTIMER) (\RCLOCK0 OLDTIMER))) ) (DEFINEQ (\SETUPTIMERmacrofn (LAMBDA (X NOERRORCHKS) (* lmm "12-Apr-85 13:46") (PROG ((INTERVALFORM (CAR X)) (TIMERFORM (CADR X)) (TimerUnits (CONSTANTEXPRESSIONP (CADDR X))) (IntervalUnits (CONSTANTEXPRESSIONP (CADDDR X))) (CLOCKFNNAME)) (if (OR (NULL TimerUnits) (NULL IntervalUnits)) then (* If either of the units are true computibles, then we can't select clock functions at macroexpansion time.) (RETURN (QUOTE IGNOREMACRO))) (SETQ TimerUnits (CANONICAL.TIMERUNITS (CAR TimerUnits))) (SETQ IntervalUnits (if (NULL (CAR IntervalUnits)) then TimerUnits else (CANONICAL.TIMERUNITS (CAR IntervalUnits)))) (* Notice how the following SELECTQ may also modify the code expression for the INTERVALFORM to do any necessary transformations between the specifiend timer units and the specified interval units.) (SETQ CLOCKFNNAME (SELECTQ TimerUnits (TICKS (SELECTQ IntervalUnits ((MILLISECONDS) (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM \RCLKMILLISECOND)))) ((SECONDS) (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM \RCLKSECOND)))) NIL) (QUOTE \TIMER.IN.TICKS)) (MILLISECONDS (SELECTQ IntervalUnits (TICKS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM \RCLKMILLISECOND)))) (SECONDS (SETQ INTERVALFORM (BQUOTE (ITIMES %, INTERVALFORM 1000)))) NIL) (QUOTE \TIMER.IN.MILLISECONDS)) (SECONDS (SELECTQ IntervalUnits (MILLISECONDS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM 1000)))) (TICKS (SETQ INTERVALFORM (BQUOTE (IQUOTIENT %, INTERVALFORM \RCLKSECOND)))) NIL) (QUOTE \TIMER.IN.SECONDS)) (SHOULDNT))) (if (NOT NOERRORCHKS) then (SETQ TIMERFORM (if (CONSTANTEXPRESSIONP TIMERFORM) then (QUOTE (\TIMER.MAKETIMER)) else (LET ((FORM (QUOTE (COND ((\TIMER.TIMERP Timer?) Timer?) (T (\TIMER.MAKETIMER)))))) (if (NLISTP TIMERFORM) then (SUBST TIMERFORM (QUOTE Timer?) FORM) else (BQUOTE ((LAMBDA (Timer?) (DECLARE (LOCALVARS Timer?)) %, FORM) %, TIMERFORM))))))) (RETURN (BQUOTE (\TIMER.PLUS (%, CLOCKFNNAME %, TIMERFORM) %, INTERVALFORM))))) ) (\CanonicalizeTimerUnits (LAMBDA (X) (* lmm "12-Apr-85 13:09") (* Generally, the U-CASE versions have been "beat out" by the CANONICAL.TIMERUNITS.FOR.MISC macro; but there are ocasional calls to this function directly such, as in \DURATIONTRAN and the TIMEREXPIRED? macro.) (PROG ((Y X) CONVERTEDP) A (RETURN (SELECTQ Y (TICKS (QUOTE TICKS)) ((NIL MILLISECONDS MS) (QUOTE MILLISECONDS)) (SECONDS (QUOTE SECONDS)) (if (NOT CONVERTEDP) then (SETQ Y (U-CASE Y)) (SETQ CONVERTEDP T) (GO A) else (ERROR (QUOTE |Invalid arg for timer units|) X)))))) ) ) (DEFINEQ (SETUPTIMER (LAMBDA (INTERVAL OldTimer? timerUnits intervalUnits) (* lmm "12-Apr-85 13:19") (SETQ INTERVAL (IPLUS INTERVAL 0)) (* If an error or coercion is to occur on this one, do it before the call to the clock-funciton) (if (NOT (\TIMER.TIMERP OldTimer?)) then (SETQ OldTimer? (\TIMER.MAKETIMER))) (SETQ timerUnits (CANONICAL.TIMERUNITS timerUnits)) (SETQ intervalUnits (if (NULL intervalUnits) then timerUnits else (CANONICAL.TIMERUNITS intervalUnits))) (* Notice that in each wing of the SELECTQ below, the modification to INTERVAL is done before the clock-function call implicit in SETUPTIMER) (SELECTQ timerUnits ((TICKS) (SELECTQ intervalUnits ((MILLISECONDS) (SETQ INTERVAL (ITIMES \RCLKMILLISECOND INTERVAL))) ((SECONDS) (SETQ INTERVAL (ITIMES \RCLKSECOND INTERVAL))) NIL) (EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE TICKS))) ((MILLISECONDS) (SELECTQ intervalUnits ((TICKS) (SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKMILLISECOND))) ((SECONDS) (SETQ INTERVAL (ITIMES 1000 INTERVAL))) NIL) (EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE MILLISECONDS))) ((SECONDS) (SELECTQ intervalUnits ((MILLISECONDS) (SETQ INTERVAL (IQUOTIENT INTERVAL 1000))) ((TICKS) (SETQ INTERVAL (IQUOTIENT INTERVAL \RCLKSECOND))) NIL) (EXPAND.SETUPTIMER INTERVAL OldTimer? (QUOTE SECONDS))) (SHOULDNT))) ) (SETUPTIMER.DATE (LAMBDA (DTS OldTimer?) (* Pavel " 6-Oct-86 21:46") (SETUPTIMER (IDIFFERENCE (IDATE DTS) (IDATE)) OldTimer? (QUOTE SECONDS) (QUOTE SECONDS))) ) (TIMEREXPIRED? (LAMBDA (TIMER ClockValue.or.timerUnits) (* lmm "12-Apr-85 13:19") (COND ((NOT (\TIMER.TIMERP TIMER)) (* Do the check out here so that an error won't happen underneath the UNINTERRUPTABLY) (LISPERROR "ILLEGAL ARG" TIMER)) ((\TIMER.TIMERP ClockValue.or.timerUnits) (* Note that in Interlisp-D the TIMER.TIMEREXPIRED? macro will clobber its first arg.) (TIMER.TIMEREXPIRED? (TIMER.MAKESAFETIMER ClockValue.or.timerUnits \TIMEREXPIRED.BOX) TIMER)) (T (* Distribute thru the SELECTQ this way so that Interlisp-10 compiler can optimize out the boxing. Leave the UNINTERRUPTABLY so that Interlisp-D won't interrupt between putting the value in \TIMEREXPIRED.BOX and the IGEQ test.) (SELECTQ (CANONICAL.TIMERUNITS ClockValue.or.timerUnits) ((TICKS) (TIMER.TIMEREXPIRED? (\TIMER.IN.TICKS \TIMEREXPIRED.BOX) TIMER)) ((MILLISECONDS) (TIMER.TIMEREXPIRED? (\TIMER.IN.MILLISECONDS \TIMEREXPIRED.BOX) TIMER)) ((SECONDS) (TIMER.TIMEREXPIRED? (\TIMER.IN.SECONDS \TIMEREXPIRED.BOX) TIMER)) NIL)))) ) (TIME.UNTIL (LAMBDA (TIMER UNITS) (* lmm "12-Apr-85 13:47") (COND ((NOT (\TIMER.TIMERP TIMER)) (* Do the check out here so that an error won't happen underneath the UNINTERRUPTABLY) (LISPERROR "ILLEGAL ARG" TIMER)) (T (SELECTQ (CANONICAL.TIMERUNITS UNITS) (TICKS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.TICKS \TIMEREXPIRED.BOX))) (MILLISECONDS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.MILLISECONDS \TIMEREXPIRED.BOX))) (SECONDS (\TIMER.DIFFERENCE TIMER (\TIMER.IN.SECONDS \TIMEREXPIRED.BOX))) (SHOULDNT))))) ) ) (RPAQ \TIMEREXPIRED.BOX (SETUPTIMER 0)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TIMEREXPIRED.BOX \RCLKMILLISECOND \RCLKSECOND) ) (* ;; "Arrange for the proper compiler.") (PUTPROPS LLTIMER FILETYPE :FAKE-COMPILE-FILE) (PUTPROPS LLTIMER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4960 9149 (\CLOCK0 4970 . 6016) (\DAYTIME0 6018 . 6157) (\GETINTERNALCLOCK 6159 . 6869) (\SETDAYTIME0 6871 . 8318) (CLOCKDIFFERENCE 8320 . 8493) (\SECONDSCLOCKGREATERP 8495 . 8786) ( \CLOCKGREATERP 8788 . 9055) (\RCLOCK0 9057 . 9147)) (9150 9593 (CLOCK0 9160 . 9591)) (9841 10750 ( \MAIKO.DAYTIME 9851 . 9958) (\MAIKO.DAYTIME0 9960 . 10068) (\MAIKO.CLOCK0 10070 . 10176) (\MAIKO.CLOCK 10178 . 10285) (\MAIKO.COPY-TIME-STATS 10287 . 10465) (\MAIKO.SETTIME 10467 . 10748)) (15179 16321 ( CLOCK 15189 . 15806) (DAYTIME 15808 . 15913) (ALTO.TO.LISP.DATE 15915 . 16224) (LISP.TO.ALTO.DATE 16226 . 16319)) (17753 19722 (\SETUPTIMERmacrofn 17763 . 19720)) (20838 23358 (\SETUPTIMERmacrofn 20848 . 22805) (\CanonicalizeTimerUnits 22807 . 23356)) (23359 26335 (SETUPTIMER 23369 . 24658) ( SETUPTIMER.DATE 24660 . 24824) (TIMEREXPIRED? 24826 . 25827) (TIME.UNTIL 25829 . 26333))))) STOP \ No newline at end of file diff --git a/sources/LOADFNS b/sources/LOADFNS new file mode 100644 index 00000000..d6348593 --- /dev/null +++ b/sources/LOADFNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 17:38:16" {DSK}kaplan>Local>medley3.5>lispcore>sources>LOADFNS.;7 47044 changes to%: (FNS SCANFILE1) previous date%: "16-Apr-2018 17:16:07" {DSK}kaplan>Local>medley3.5>lispcore>sources>LOADFNS.;6) (* ; " Copyright (c) 1983, 1984, 1986, 1987, 1989, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOADFNSCOMS) (RPAQQ LOADFNSCOMS [(FNS LOADFROM LOADBLOCK GETBLOCKDEC LOADCOMP LOADCOMP? LOADVARS LOADEFS LOADFILEMAP LOADFNS LOADFNS-FINDFILE LOADFNS-MAKELIST) (FNS LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1 SCANFILE2 TMPSUBFN RETRYSCAN SCANFILEHELP) (VARS (NOT-FOUNDTAG 'NOT-FOUND%:)) (GLOBALVARS LASTWORD LOADOPTIONS SYSFILES NOT-FOUNDTAG) (LOCALVARS . T) (BLOCKS (SCANFILEBLOCK (ENTRIES LOADFNSCAN TMPSUBFN SCANFILE1) LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1 SCANFILE2 TMPSUBFN (LOCALFREEVARS FNADRLST DICT DICT0 ADR) (SPECVARS VARLST) (RETFNS SCANFILE0]) (DEFINEQ (LOADFROM [LAMBDA (FILE FNS LDFLG) (* wt%: "21-SEP-79 12:03") (* ; "'notices' file.") (PROG1 (LOADFNS FNS FILE LDFLG 'LOADFROM) (AND DWIMFLG FNS (SETQ LASTWORD (COND ((ATOM FNS) FNS) (T (CAR (LAST FNS]) (LOADBLOCK [LAMBDA (FN FILE LDFLG) (* bvm%: "27-Sep-86 15:17") (PROG (TEM) (OR FILE (SETQ FILE (LOADFNS-FINDFILE FN))) (RETURN (AND [SETQ TEM (SUBSET (OR (GETBLOCKDEC FN FILE T) (LIST FN)) (FUNCTION (LAMBDA (FN) (NOT (EXPRP (VIRGINFN FN] (LOADFNS TEM FILE LDFLG]) (GETBLOCKDEC [LAMBDA (FN FILE FNSONLY) (* bvm%: " 7-Oct-86 18:23") (* ;; "Return the block declaration of FILE that contains FN. If FNSONLY is true, returns just a list of the functions in the block.") (OR FILE (SETQ FILE (LOADFNS-FINDFILE FN))) (for BLOCK in (FILECOMSLST FILE 'BLOCKS) when (MEMB FN BLOCK) do (RETURN (if (NULL FNSONLY) then BLOCK elseif (AND (CAR BLOCK) (SUBSET (CDR BLOCK) (FUNCTION LITATOM))) else (* ;  "car of block decl is block name or NIL for no block") (LIST FN]) (LOADCOMP [LAMBDA (FILE LDFLG) (* bvm%: "27-Sep-86 16:32") (RESETLST (LET ((FULLNAME (OR (FINDFILE FILE T) FILE)) BLOCKS ROOT) (DECLARE (SPECVARS BLOCKS)) (* ;  "don't let block declarations get thru") [RESETSAVE NIL (LIST [FUNCTION (LAMBDA (NAME VAL) (* ;  "remove LOADCOMP prop if didn't finish successfully") (AND RESETSTATE (PUTPROP NAME 'LOADCOMP VAL] (SETQ ROOT (NAMEFIELD FULLNAME)) (GETPROP ROOT 'LOADCOMP] (/PUTPROP ROOT 'LOADCOMP FULLNAME) (* ; "Save FULLNAME for LOADCOMP? Do this now rather than after the LOADFNS to avoid circularity if A loadcomp's B and B loadcomp's A.") (LOADFNS T FULLNAME LDFLG 'LOADCOMP]) (LOADCOMP? [LAMBDA (FILE LDFLG) (* ; "Edited 22-Sep-89 16:35 by bvm") (LET* [(FOUND (FINDFILE FILE T)) (FULLNAME (OR FOUND FILE)) (LOADED (GETPROP (NAMEFIELD FULLNAME) 'LOADCOMP] (if [OR (NULL LOADED) (AND FOUND (NOT (STRING-EQUAL LOADED FOUND] then (* ;; "Do the LOADCOMP if one's never been done, or the current version is not the one that was loadcomp'ed before. If can't find a current version, assume the previously loadcomp'ed one is ok.") (LOADCOMP FULLNAME LDFLG)) FULLNAME]) (LOADVARS [LAMBDA (VARS FILE LDFLG) (LOADFNS NIL FILE LDFLG VARS]) (LOADEFS [LAMBDA (FNS FILE) (* wt%: " 9-APR-80 20:27") (LOADFNS FNS FILE 'GETDEF]) (LOADFILEMAP [LAMBDA (FILE) (* wt%: "16-MAY-79 22:05") (* ;; "user wants the full filemap. scan file if necessary. if updatemapflg=T and any changes are made, e.g. map does not exist on file, or is wrong (due to transferring from dorado to maxc), loadfns will rewrite the map") (LOADFNS NIL FILE NIL 'FILEMAP]) (LOADFNS [LAMBDA (FNS FILE LDFLG VARS) (* bvm%: "17-Nov-86 23:28") (* ;;; "All of LOADVARS, LOADCOMP, LOADFILEMAP, LOADFROM come thru here.") (DECLARE (SPECVARS FILE LDFLG VARS)) (* ; "Used free by RETRYSCAN") (RESETLST (PROG ((*PACKAGE* *INTERLISP-PACKAGE*) (DFNFLG DFNFLG) (BUILDMAPFLG BUILDMAPFLG) (FILEPKGFLG FILEPKGFLG) (ADDSPELLFLG ADDSPELLFLG) (LISPXHIST LISPXHIST) (FILECREATEDLST) (PRLST (AND FILEPKGFLG (FILEPKGCHANGES))) INSTREAM FNLST VARLST DONELST ROOTNAME FILEMAP TEM FILEMAPEND FILECREATEDLOC FILENV RESETSAVER MAPUPDATED) (DECLARE (SPECVARS *PACKAGE* DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FNLST VARLST DONELST FILECREATEDLST FILECREATEDLOC)) (* ;  "FILECREATEDLST is set by SCANEXP when it encounters a FILECREATED expression") TOP (COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF) (MEMB LDFLG LOADOPTIONS)) (SETQ DFNFLG LDFLG)) ((AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T))) (SETQ LDFLG TEM) (SETQ DFNFLG LDFLG)) (T (SETQ LDFLG (ERROR "unrecognized load option" LDFLG)) (GO TOP))) (COND ((EQ LDFLG 'SYSLOAD) (SETQ DFNFLG T) (SETQ ADDSPELLFLG NIL) (SETQ BUILDMAPFLG NIL) (SETQ FILEPKGFLG NIL) (SETQ LISPXHIST NIL))) [AND LISPXHIST (COND ((SETQ TEM (FMEMB 'SIDE LISPXHIST)) (FRPLACA (CADR TEM) -1)) (T (LISPXPUT 'SIDE (LIST -1) NIL LISPXHIST] (* ;  "So that UNDOSAVE will keep saving regardless of how many undosaves are involved") (SETQ FNLST (LOADFNS-MAKELIST FNS T)) (* ; "Get list of functions") [COND ((NULL FILE) (* ;  "Infer what file caller meant (this is a feature!)") (SETQ FILE (LOADFNS-FINDFILE (CAR FNLST] RETRY [RESETSAVE NIL (SETQ RESETSAVER (LIST 'CLOSEF? (SETQ INSTREAM (OPENSTREAM FILE 'INPUT] (* ;  "CLOSEF? not CLOSEF because UPDATEFILEMAP might close file for us") (RESETSAVE (INPUT INSTREAM)) (SETQ FILE (FULLNAME INSTREAM)) (* ;  "Gets full file name. Also note that there may have been some error correction done in OPENSTREAM") (COND ((NOT (RANDACCESSP INSTREAM)) (SETQ FILE (ERROR FILE "not a random access file")) (GO RETRY))) (SETFILEPTR INSTREAM 0) (SETQ ROOTNAME (ROOTFILENAME FILE)) (CL:MULTIPLE-VALUE-SETQ (FILENV FILEMAP FILECREATEDLOC FILECREATEDLST) (GET-ENVIRONMENT-AND-FILEMAP INSTREAM)) (SETQ VARLST (SELECTQ VARS (NIL NIL) (VARS (* ;  "Means load, i.e., evaluate, ALL rpaq/rpaqq") 'VARS) (FNS/VARS (LIST (FILECOMS ROOTNAME 'COMS) (FILECOMS ROOTNAME 'BLOCKS))) (LOADCOMP (* ;  "evaluate the EVAL@COMPILE expresions, notice the fns and vars.") (SETQ FNLST T) VARS) (FILEMAP (* ;  "Return the filemap, or build one if not already available") (if (AND FILEMAP (NULL (CAR FILEMAP))) then (RETURN FILEMAP) elseif (NULL BUILDMAPFLG) then (RETURN NIL)) 'FILEMAP) (LOADFROM (* ;; "evaluate all non-defineq expressions, but just return file name as value, i.e. dont bother adding to donelst") 'LOADFROM) (DONTCOPY (* ;  "means load all DECLARE: DONTCOPY expressions") VARS) (LOADFNS-MAKELIST VARS))) (SETQ FILEMAPEND (if FILEMAP then (CAR FILEMAP) else T)) (* ;  "Remember how far the filemap scan got already") [WITH-READER-ENVIRONMENT FILENV (SETQ FILEMAP (LOADFNSCAN FILEMAP)) (* ;;; "SCANFILE0 returns a 'map' for the file. The form of the map is (ADR ADRLST ADRLST ...) where ADR is last address scanned to in file, or NIL if entire file was scanned, or (ADR) where the scan stopped after a function in the middle of a DEFINEQ. Each ADRLST is either of the form (ADR1 ADR2 . FN) or (ADR1 ADR2 (FN ADRX . ADRY) (FN ADRX . ADRY) ...). The first case corresponds to a compiled function, the second to a DEFINEQ. In the first case, ADR1 is the address of the first character AFTER the function name in the file (for use by LAPRD) and ADR2 the address of the first character after the de definition, i.e., after LAPRD or LCSKIP has finished. In the second case, ADR1 is the address of the lef paren before the DEFINEQ, and ADR2 either the address of the first character after the entire DEFINEQ expression, or the address of the first chracter after the last function that was scanned. In (FN ADRX . ADRY), ADR is the address of of the left parentheses before the function name, ADRY the address of the character after the right paren that closes the definition. A map of non-functions is not kept because (a) it would not be of use to MAKEFILE since it always recomputes VARS, and (B) most requests for other than functions require scanning the entire file anyway, e.g. to find all RPAQQ's, and (C) the expressions are usually small compared to DEFINEQ's.") [if FILEMAP then (if (NEQ FILEMAPEND (CAR FILEMAP)) then (* ; "something was added") (PUTFILEMAP FILE FILEMAP FILECREATEDLST) (if (AND UPDATEMAPFLG (UPDATEFILEMAP INSTREAM FILEMAP)) then (SETQ MAPUPDATED T))) (if (AND DWIMFLG (NOT NOSPELLFLG) (LISTP FNLST)) then (* ;  "There are still FNS left that we didn't find") (if (SETQ TEM (for X on FNLST bind [KNOWNFNS _ (for TRIPLE in (CDR FILEMAP) join (* ;  "makes a list of functions found for use for spelling correction.") (if (LISTP (SETQ TEM (CDDR TRIPLE))) then (* ;  "This is for normal source files, where TRIPLE = (start end . fnEntries)") (MAPCAR TEM (FUNCTION CAR)) elseif TEM then (* ;  "For compiled files, TRIPLE = (start end . fn)") (LIST TEM] when (AND (NOT (FMEMB (CAR X) KNOWNFNS)) (FIXSPELL (CAR X) 70 KNOWNFNS NIL X)) collect (* ;; "The FMEMB check is necessary for when VARS=DEFS, as the reason that the function was not removed from FNLST may have been because this was a compiled file.") (CAR X))) then (if MAPUPDATED then (* ; "UPDATEFILEMAP had closed the file") [RPLACA (CDR RESETSAVER) (SETQ INSTREAM (OPENSTREAM FILE 'INPUT] (INPUT INSTREAM)) (SCANFILE1 FILEMAP TEM] (if (AND NOT-FOUNDTAG (LISTP FNLST)) then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG FNLST) DONELST))) (if [AND NOT-FOUNDTAG (LISTP VARLST) (SETQ TEM (if (FNTYP VARLST) then (AND (NULL DONELST) (LIST VARLST)) else (for X in VARLST collect X unless (PROGN (* ;; "Reason for this is if user says LOADVARS (DEFLIST file), then DEFLIST is not removed from VARLST, since you want all such instances.") (for Y in DONELST thereis (if (ATOM X) then (OR (EQ X (CAR Y)) (EQ X (CADR Y))) else (EDIT4E X Y] then (SETQ DONELST (CONS (CONS NOT-FOUNDTAG TEM) DONELST))) (if (EQ LDFLG 'SYSLOAD) then (AND (NOT (MEMB (SETQ ROOTNAME (ROOTFILENAME FILE (CDR FILECREATEDLST))) SYSFILES)) (SETQ SYSFILES (NCONC1 SYSFILES ROOTNAME))) (SMASHFILECOMS ROOTNAME) elseif FILEPKGFLG then (AND (NEQ VARS 'FILEMAP) (NEQ LDFLG 'EXPRESSIONS) (NEQ LDFLG 'GETDEF) (ADDFILE FILE (SELECTQ VARS ((T LOADFROM) 'LOADFNS) (LOADCOMP 'LOADCOMP) 'loadfns) PRLST FILECREATEDLST] (RETURN (if (EQ VARS 'FILEMAP) then FILEMAP elseif (EQ VARS 'LOADFROM) then FILE else (DREVERSE DONELST]) (LOADFNS-FINDFILE [LAMBDA (FN) (* bvm%: "27-Sep-86 15:03") (* ;; "When LOADFNS is not given a file to load from, figure out using WHEREIS") (LET ((DWIMFLG T) (FILEPKGFLG T)) (DECLARE (SPECVARS DWIMFLG FILEPKGFLG)) (OR (EDITLOADFNS? FN) (AND (EQ (NARGS 'WHEREIS) 4) (EDITLOADFNS? FN NIL NIL T)) (ERROR FN '"'s file not found" T]) (LOADFNS-MAKELIST [LAMBDA (LST FNSFLG) (* bvm%: " 2-Oct-86 15:40") (* ;; "Turn FNS or VARS arg to LOADFNS into an actual list of functions/variables to load, or T to load all.") (if (EQ LST T) then (* ;  "Eleanor's option, load every fn found in FILE.") T elseif (NULL LST) then NIL elseif (LITATOM LST) then (LIST LST) elseif (NLISTP LST) then (ERROR '"illegal arg" LST) elseif (NULL FNSFLG) then (* ;  "VARS arg is a list of patterns, so canonicalize them") (for Y in LST collect (EDITFPAT Y)) else (for F in LST when (if (LITATOM F) then T else (LISPXPRIN1 '" isn't a function name -- ignored. ") NIL) collect F]) ) (DEFINEQ (LOADFNSCAN [LAMBDA (DICT) (* wt%: " 7-DEC-79 11:57") (PROG (ADR) (SCANFILE0) (RETURN DICT]) (SCANFILE0 [LAMBDA NIL (* bvm%: "29-Aug-86 23:15") (PROG (NXT NXT1 NXT2 FNADRLST (DICT0 (CDR DICT))) [COND [(NULL DICT) (AND BUILDMAPFLG (SETQ DICT (LIST 0] (FNLST (* ;  "Have some filemap, so go get functions that are on the map") (SCANFILE1 (CDR DICT] (COND ([AND (NULL VARLST) (OR (NULL FNLST) (AND DICT (NULL (CAR DICT] (* ;; "Either all functions were found, or else the entire file having been scaaned, no point in scanning further") (RETURN DICT))) (COND ((AND VARLST (NEQ VARLST 'FILEMAP)) (* ;; "Note that at this point there may or may not be some functions to be scanned for. in any event, since there are VARS to be obtained, we have to start scanning at the beginning, although DICT can be of use to save scanning of DEFINEQ's.") (SETFILEPTR NIL (OR FILECREATEDLOC 0))) ((LISTP (CAR DICT)) (* ;  "The scan stopped in the middle of a DEFINEQ.") (SETFILEPTR NIL (SETQ ADR (CAAR DICT))) [AND BUILDMAPFLG (SETQ FNADRLST (LCONC NIL (CAR (LAST DICT] (SETQ DICT0 NIL) (SCANDEFINEQ T)) (DICT (* ;  "Scan stopped after a compiled function.") (SETFILEPTR NIL (CAR DICT)) (SETQ DICT0 NIL))) PEEKLP (SETQ NXT1 (SKIPSEPRCODES)) (COND [(OR (SYNTAXP NXT1 'LEFTPAREN) (SYNTAXP NXT1 'LEFTBRACKET)) (* ; "Opening paren and bracket.") (SETQ ADR (GETFILEPTR)) (READC) (* ; "Flush the peeked-at paren.") (SETQ NXT1 (RATOM)) (COND ((EQ NXT1 'DEFINEQ) (SCANDEFINEQ)) (T (* ;  "some functions may be inside of declare:'s so have to look at each expression, even if varlst=NIL") (SETQ NXT2 (RATOM)) (* ;  "Corresponds to CADR of the expression. in the file") (SETFILEPTR NIL ADR) (* ;  "file pointer now points to just before the expression..") (SCANEXP NXT1 NXT2 (NEQ VARLST 'LOADCOMP] ((OR (EQ (SETQ NXT (READ)) 'STOP) (NULL NXT)) (* ; "End of file.") (AND (CAR DICT) (RPLACA DICT NIL)) (* ;  "says scan of entire map now complete") (RETURN)) ((LITATOM NXT) (SETQ ADR (GETFILEPTR)) (SCANCOMPILEDFN NXT))) (GO PEEKLP]) (SCANCOMPILEDFN [LAMBDA (FNAME) (* wt%: " 9-APR-80 20:54") (PROG NIL [COND (DICT0 (AND (NOT (EQP (CAAR DICT0) ADR)) [NOT (SETQ DICT0 (SOME DICT0 (FUNCTION (LAMBDA (X) (IEQP ADR (CAR X] (RETRYSCAN)) (* ;; "redudnacy check the SOME is bcause of the (admittedly obsucre but actually happened) case where there are DEFINEQ's inside of a DECLARE:.. in this case, they would appear on the filemap, but DICT0 would not have been stepped because the DEFINIEQ's would not have been seen in the scan.") (SETFILEPTR NIL (CADAR DICT0)) (* ;; "We know this function is not of interest, or it ould have been picked up in SCANFILE1. Furthermore, we know its final address, so no need to LCSKIP") (SETQ DICT0 (CDR DICT0)) (RETURN T)) (BUILDMAPFLG (NCONC1 DICT (SETQ FNADRLST (CONS (GETFILEPTR) (CONS NIL FNAME] [COND [[AND FNLST (NEQ LDFLG 'EXPRESSIONS) (NEQ LDFLG 'GETDEF) (NEQ VARS 'LOADCOMP) (OR (EQ FNLST T) (MEMB FNAME FNLST) (SOME FNLST (FUNCTION (LAMBDA (X) (TMPSUBFN FNAME X] (* ;; "We want FNAME if it is on FNLST, or a SUBFN of anything on FNLST. or if FNLST, is T, i.e. load everything.") (LAPRD FNAME) (SETQ DONELST (CONS FNAME DONELST)) [AND FNADRLST (RPLACA (CDR FNADRLST) (SETQ ADR (GETFILEPTR] (COND ((AND (NEQ FNLST T) (NULL (SETQ FNLST (DREMOVE FNAME FNLST))) (NULL VARLST)) (AND DICT (RPLACA DICT ADR)) (RETFROM 'SCANFILE0] (T (LCSKIP FNAME) (AND FNADRLST (RPLACA (CDR FNADRLST) (GETFILEPTR] (RETURN T]) (SCANDEFINEQ [LAMBDA (CONTINUEFLG) (* bvm%: " 7-Oct-86 18:07") (* ;; "Called with file pointer just after atom DEFINEQ. DICT0, if non-NIL, is the tail of DICT that corresponds to how far we've gotten. I.e., (CAR DICT0) should represent this DEFINEQ.") (PROG (FNAME) (COND (CONTINUEFLG (GO DEFQLP)) ([AND DICT0 (NOT (IEQP (CAAR DICT0) ADR)) (NOT (SETQ DICT0 (find TAIL on DICT0 suchthat (IEQP ADR (CAAR TAIL] (RETRYSCAN))) (* ;; "Double check. the SOME is because of the (admittedly obscure but it happens) case where there are DEFINEQ's inside of a DECLARE:.. in this case, they would appear on the filemap, but DICT0 would not have been stepped because the DEFINEQ's would not have been seen in the scan. Now we know that CAR of DICT0 corrresponds to this DEFINEQ. We process DEFINEQ's the same when there are functions to be found, i.e. when FNLST is non-NIL, as when there aren't any, on the grounds that it takes about as long to do many little SKREAD's as one big SKREAD, and this way we also get to build the map.") [COND ((CADAR DICT0) (* ;; "This entire DEFINEQ was scanned, and ADR is the address of the first character after it. Move file pointer and go on, i.e. dont have to do SKREAD. Note that this applies even if we are looking for functions, i.e. FNLST not NIL, because in this case all functions of interest would have been picked up by SCANFILE1.") (SETFILEPTR NIL (CADAR DICT0)) (SETQ DICT0 (CDR DICT0)) (RETURN T)) (DICT0 (* ;; "The scan previously stopped in the middle of a DEFINEQ. The address of the end of the scan, i.e. (CAAR DICT), corresponds to the character after the last function scanned.") [SETFILEPTR NIL (COND ((LISTP (CAR DICT)) (CAAR DICT)) (T (* ;; "Another redudancy check. If the entire DEFINEQ had been processed, then CADAR of DICT0 would be non-NIL, and caught above. Therefore, processing stopped in the middle of the DEFINEQ, and CAR of DICT should be a list.") (RETRYSCAN] [AND BUILDMAPFLG (SETQ FNADRLST (LCONC NIL (CAR DICT0] (SETQ DICT0 NIL)) (BUILDMAPFLG (SETQ FNADRLST (TCONC NIL ADR)) (TCONC FNADRLST NIL) (NCONC1 DICT (CAR FNADRLST] DEFQLP (SELECTQ (RATOM) (%) (* ; "Closes DEFINEQ.") (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR))) (* ;  "FNADRLST is a ONC format list, hence want to RPLACA CDAR, not just CDR.") (RETURN T)) (%] (SCANFILEHELP)) ((%( %[) (SETQ ADR (SUB1 (GETFILEPTR))) (* ;  "The address of the position of the left paren.") (SETQ FNAME (READ)) (AND FNADRLST (TCONC FNADRLST (LIST FNAME ADR)))) (SCANFILEHELP)) (SETFILEPTR NIL ADR) (* ;; "Positions file pointer at left paren or bracket so if fn/def pair is closed by either right paren or bracket, read or skread will do the right thing.") (COND [(AND FNLST (OR (EQ FNLST T) (MEMB FNAME FNLST))) (SELECTQ VARS (LOADCOMP (AND (NOT (FMEMB FNAME NOFIXFNSLST)) (SETQ NOFIXFNSLST (CONS FNAME NOFIXFNSLST))) (SKREAD)) (SETQ DONELST (NCONC [COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF)) (LIST (READ))) (T (DEFINE (LIST (READ] DONELST))) (AND (NEQ FNLST T) (SETQ FNLST (DREMOVE FNAME FNLST] (T (SKREAD))) (AND FNADRLST (RPLACD (CDADR FNADRLST) (GETFILEPTR))) (* ;; "FNADRLST is a TCONC format, so its CADR is its last element. This is supposed to be of the form (FN ADRX . ADRY). This adds the ADRY.") [COND ((AND (NULL FNLST) (NULL VARLST)) (* ;; "Actually this check only need be made in the case that a function was actually read, i.e. second clause in above COND, but it's cheap enough.") [AND DICT (RPLACA DICT (LIST (ADD1 (GETFILEPTR](* ;  "says scan stopped in middle of defineq") (RETFROM 'SCANFILE0] (GO DEFQLP]) (SCANEXP [LAMBDA (EXP1 EXP2 EVALFLG) (* ; "Edited 16-Apr-2018 17:14 by rmk:") (* ;; "exp1 is car of the expression, exp2 cadr. file pointer is just before opening left paren and scanexp reads expression if it needs to.") (DECLARE (USEDFREE FILECREATEDLST)) (PROG (EXP) (COND ((EQ VARLST 'COMPILING) (* ; "wants whole declare:") (GO YES)) ((EQ EXP1 'DECLARE%:) (COND (EXP (SETFILEPTR NIL ADR))) (* ;  "SKIP OVER THE PAREN AND THE DECLARE:") (RATOM) (RATOM) (if (EQ VARLST 'DONTCOPY) then (SCANDECLARECOLON NIL T) else (SCANDECLARECOLON EVALFLG)) (RETURN T))) (SELECTQ VARLST ((T LOADFROM) (AND EVALFLG (GO YES))) (VARS [AND EVALFLG (COND ((OR (EQ EXP1 'RPAQQ) (EQ EXP1 'RPAQ) (EQ EXP1 'RPAQ?)) (GO YES]) (LOADCOMP (AND EVALFLG (GO YES)) (SELECTQ EXP1 ((RPAQQ RPAQ RPAQ?) (SETQ NOFIXVARSLST (AND (NOT (FMEMB EXP2 NOFIXVARSLST)) (CONS EXP2 NOFIXVARSLST)))) NIL)) (AND (LISTP VARLST) [COND ((FNTYP VARLST) (COND ((NULL (SETQ EXP (APPLY* VARLST EXP1 EXP2))) (* ;  "the functional expression is ree to move filepinter.") (SETFILEPTR NIL ADR) NIL) ((NLISTP EXP) (* ;  "matched, but user elected not to return entire expression") (SETFILEPTR NIL ADR) (SETQ EXP (READ))) (T T))) (T (SOME VARLST (FUNCTION (LAMBDA (X) (COND ((OR (EQ EXP1 X) (EQ EXP2 X))) ((LISTP X) (* ; "edit pattern") [COND ((NULL EXP) (* ;; "The expression on VARLST is a list, which is interpreted as an edit pattern; therefore we have to read the entire expression from the file. Note that this is only done once, i.e., if there are several patterns on VARLST, the expression from the file is read only once.") (SETQ EXP (READ] (EDIT4E X EXP] (GO YES))) (COND ((EQ EXP1 'FILECREATED) [SETQ FILECREATEDLST (NCONC1 FILECREATEDLST (CDR (OR EXP (SETQ EXP (READ] (* ;  "So that ADDFILE will have necessary information when it is called.") (FILECREATED1 (CDR EXP)) (* ;  "does error checking on filecreated expression") ) ((NULL EXP) (SKREAD))) (RETURN T) YES (* ;  "This IS one of the expressions specified by VARLST.") [COND ((NULL EXP) (* ;; "If EXP is non-null, means for some reason it had to be READ, e.g., there was an edit pattern in VARLST. In this case not necessary to SKREAD since we have already passed over that expression.") (SETQ EXP (READ] [COND ((AND (NEQ VARLST 'LOADFROM) (NEQ VARLST 'LOADCOMP)) (SETQ DONELST (CONS EXP DONELST] (COND ((AND (NEQ LDFLG 'EXPRESSIONS) (NEQ LDFLG 'GETDEF)) (EVAL EXP))) (RETURN T]) (SCANDECLARECOLON [LAMBDA (EVALFLG DONTCOPIES) (* bvm%: "30-Aug-86 16:06") (* ;; "handles DECLARE:'s only called for either VARS=COMP, or for looking for specific expression or expresions, e.g. VARS, or edit pattern. For EXPRESSIONS, T, etc., higher call to SCANEXP has already decided what to do.") (PROG ((VARLST (if DONTCOPIES then T else VARLST)) TEM) LP (SETQ ADR (GETFILEPTR)) [SELECTQ (SETQ TEM (RATOM)) ((%( %[) (SETQ ADR (SUB1 (GETFILEPTR))) (* ;; "reason for this is that there may have been some separators before the (, e.g. a space and c.r., and in this case the ADR will not match up with what was stored in the file map, which would be the position just before the (. The right way to do this is of course not to RATOM but to do a loop with peekc until you ee a non-separator and then record the address. however, thi is inefficient and unnecessary since this is the nly case where it matters") (SELECTQ (SETQ TEM (RATOM)) (DEFINEQ (PROG ((ADR ADR)) (SCANDEFINEQ) (* ;; "easier to call scandefineq even if FNS is NIL because it knows how to position file pointer without aving to call skread by using filemap") ) [COND ((AND EVALFLG (EQ VARLST 'LOADCOMP) (EQ FNLST T)) (* ;; "LOADCOMP is handled specially. the SCANDEFINEQ would not have actually done any defining, just scanned for the purposes of constructing the map.") (SETFILEPTR NIL ADR) (SETQ TEM (READ)) (COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF)) (SETQ DONELST (CONS TEM DONELST))) (T (EVAL TEM]) (DECLARE%: (SCANDECLARECOLON EVALFLG DONTCOPIES)) (SCANEXP TEM (PROG1 (RATOM) (SETFILEPTR NIL ADR)) EVALFLG))) ((%) %]) (RETURN T)) (COND (DONTCOPIES (SELECTQ TEM (DONTCOPY (SETQ EVALFLG T)) ((EVAL@COMPILEWHEN) (SKREAD)) (COPYWHEN (SKREAD) (SETQ EVALFLG T)) NIL)) ((NEQ LDFLG 'GETDEF) (* ;  "getdef means ignore tags, find it if its there.") (SELECTQ TEM ((EVAL@COMPILE DOEVAL@COMPILE) (AND (EQ VARLST 'LOADCOMP) (SETQ EVALFLG T))) (DONTEVAL@COMPILE (AND (EQ VARLST 'LOADCOMP) (SETQ EVALFLG NIL))) ((EVAL@LOAD DOEVAL@LOAD) (AND (NEQ VARLST 'LOADCOMP) (SETQ EVALFLG T))) (DONTEVAL@LOAD (AND (NEQ VARLST 'LOADCOMP) (SETQ EVALFLG NIL))) (EVAL@COMPILEWHEN (SETQ TEM (READ)) (AND (EQ VARLST 'LOADCOMP) (SETQ EVALFLG (EVAL TEM)))) (EVAL@LOADWHEN (SETQ TEM (READ)) (AND (NEQ VARLST 'LOADCOMP) (SETQ EVALFLG (EVAL TEM)))) (COPYWHEN (SKREAD)) NIL] (GO LP]) (SCANFILE1 [LAMBDA (DICT LST) (* ; "Edited 16-Apr-2018 17:37 by rmk:") (AND (NULL LST) (SETQ LST FNLST)) (* ;; "looks up functions on LST, if given, but removes them from FNLST. This so can be called directly from LOADFNS.") (PROG ((DICTTAIL DICT) X FNAME TEM) $$LP (COND ((OR (NLISTP DICTTAIL) (NOT LST)) (RETURN NIL))) (SETQ X (CAR DICTTAIL)) (* ;; "X = map entry. For compiled definitions is (start end . fn). For source files, it's (start end . triples), where each triple is (fn start . end).") (COND [(NLISTP (SETQ FNAME (CDDR X))) (* ; "compiled definition.") (COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF) (EQ VARS 'LOADCOMP)) (* ;  "User wants symbolic definitions only.") ) ([OR (EQ LST T) (MEMB FNAME LST) (SOME LST (FUNCTION (LAMBDA (Y) (TMPSUBFN FNAME Y] (* ;  "User wants all functions, this one in particular, or this is a subfn of a desired fn") (SETFILEPTR NIL (CAR X)) (COND ([NOT (OR (EQ (SETQ TEM (READ)) 'BINARY) (GETPROP TEM 'CODEREADER] (* ;; "a file map was built in core, but it isnt right, e.g. user ftped another file by same name since this map was built in core. so remove map and retry") (RETRYSCAN))) (SETFILEPTR NIL (CAR X)) (LAPRD FNAME) (SCANFILE2 FNAME] (T (* ; "DEFINEQ or DEFUN.") (for Y DEFUNFLG in (CDDR X) do (SETQ DEFUNFLG NIL) [COND [(EQ VARS 'LOADCOMP) (AND (NOT (FMEMB (CAR Y) NOFIXFNSLST)) (SETQ NOFIXFNSLST (CONS (CAR Y) NOFIXFNSLST] ((OR (EQ LST T) (MEMB (CAR Y) LST)) (SETFILEPTR NIL (CADR Y)) (COND ([NOT (OR [EQ (CAR Y) (CAR (SETQ TEM (READ] (SETQ DEFUNFLG (AND (EQ (CAR TEM) 'CL:DEFUN) (EQ (CAR Y) (CADR TEM] (ERROR '"filemap does not agree with contents of" (INPUT) T))) (COND ((OR (EQ LDFLG 'EXPRESSIONS) (EQ LDFLG 'GETDEF)) (SCANFILE2 TEM)) (DEFUNFLG (IF (MEMB LDFLG '(PROP ALLPROP)) THEN (PUTDEF (CADR TEM) 'FUNCTIONS TEM) ELSE (EVAL TEM)) (SCANFILE2 (CAR Y))) (T (DEFINE (LIST TEM)) (SCANFILE2 (CAR Y] while LST))) (SETQ DICTTAIL (CDR DICTTAIL)) (GO $$LP]) (SCANFILE2 [LAMBDA (X) (SETQ DONELST (CONS X DONELST)) (AND (NEQ FNLST T) (SETQ FNLST (DREMOVE (COND ((LISTP X) (CAR X)) (T X)) FNLST]) (TMPSUBFN [LAMBDA (X FN) (* bvm%: "28-Aug-86 14:13") (* ;; "This guy wants names like FNAnnnnAmmmm...") (PROG ((N (STRPOS FN X 1 NIL T T)) NX C) (if (OR (NULL N) (NEQ (IREMAINDER (IDIFFERENCE (SETQ NX (ADD1 (NCHARS X))) N) 5) 0)) then (* ;  "X does not start with FN, or end in an integral number of 5 character pieces") (RETURN)) LP (if [OR (NEQ (NTHCHARCODE X N) (CHARCODE A)) (NOT (for I from 1 to 4 always (AND (SETQ C (NTHCHARCODE X (IPLUS I N))) (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9] then (RETURN) elseif (IGEQ (add N 5) NX) then (RETURN T)) (GO LP]) (RETRYSCAN [LAMBDA NIL (* bvm%: "28-Aug-86 17:05") (COND ((GETHASH FILE *FILEMAP-HASH*) (REMHASH FILE *FILEMAP-HASH*) (PRIN1 "something is wrong with the filemap for " T) (PRINT FILE T) (PRIN1 "rebuilding map..." T) (RETFROM 'LOADFNSCAN (LOADFNSCAN))) (T (SCANFILEHELP]) (SCANFILEHELP [LAMBDA NIL (* JonL "15-Dec-83 21:04") (* ;;  "This function used to spit out a 'sermon' about sysouting and informing W. Teitelman.") (PRIN1 '"something is wrong with either the filemap or format of " T) (PRIN1 (INPUT) T) (TERPRI T) (PRIN1 '"Here are some possibilities: (1) you edited the file with a text editor; (2) you printed a DEFINEQ in the file directly, i.e. without using the FNS command; (3) the file got clobbered. If you are convinced it is none of the above, then please inform the 1100Support program." T) (TERPRI T) (PRIN1 '"Note: for (1) and (2), you may still be able to use this file by setting USEMAPFLG to NIL, and then reexecuting the operation that caused this message." T) (TERPRI T) (HELP]) ) (RPAQQ NOT-FOUNDTAG NOT-FOUND%:) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LASTWORD LOADOPTIONS SYSFILES NOT-FOUNDTAG) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: SCANFILEBLOCK (ENTRIES LOADFNSCAN TMPSUBFN SCANFILE1) LOADFNSCAN SCANFILE0 SCANCOMPILEDFN SCANDEFINEQ SCANEXP SCANDECLARECOLON SCANFILE1 SCANFILE2 TMPSUBFN (LOCALFREEVARS FNADRLST DICT DICT0 ADR) (SPECVARS VARLST) (RETFNS SCANFILE0)) ) (PUTPROPS LOADFNS COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1986 1987 1989 1990 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1283 19433 (LOADFROM 1293 . 1766) (LOADBLOCK 1768 . 2276) (GETBLOCKDEC 2278 . 3143) ( LOADCOMP 3145 . 4308) (LOADCOMP? 4310 . 5010) (LOADVARS 5012 . 5092) (LOADEFS 5094 . 5238) ( LOADFILEMAP 5240 . 5644) (LOADFNS 5646 . 17718) (LOADFNS-FINDFILE 17720 . 18236) (LOADFNS-MAKELIST 18238 . 19431)) (19434 46417 (LOADFNSCAN 19444 . 19622) (SCANFILE0 19624 . 23031) (SCANCOMPILEDFN 23033 . 25335) (SCANDEFINEQ 25337 . 30635) (SCANEXP 30637 . 35388) (SCANDECLARECOLON 35390 . 39594) ( SCANFILE1 39596 . 43678) (SCANFILE2 43680 . 43966) (TMPSUBFN 43968 . 45132) (RETRYSCAN 45134 . 45531) (SCANFILEHELP 45533 . 46415))))) STOP \ No newline at end of file diff --git a/sources/LOADFULL.CM b/sources/LOADFULL.CM new file mode 100644 index 00000000..f2f0ba43 --- /dev/null +++ b/sources/LOADFULL.CM @@ -0,0 +1 @@ +////////////////////////////////////////////////////////////////////////// // // L O A D F U L L . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make LISP.SYSOUT and FULL.SYSOUT on {PELE:}Basics>. // ////////////////////////////////////////////////////////////////////////// ftp ERINYES Directory/C LispCore>SOURCES Retrieve/<>A LOADFULL.CM LoadInit.cm LoadFullFromDLInit.cm @LoadInit.CM@ @LoadFullFromDLInit.cm@ \ No newline at end of file diff --git a/sources/LOADFULL.LISP b/sources/LOADFULL.LISP new file mode 100644 index 00000000..d5b39ee1 --- /dev/null +++ b/sources/LOADFULL.LISP @@ -0,0 +1 @@ +(RESETVARS ((IDLE.PROFILE (QUOTE (TIMEOUT NIL)))) (DEL.PROCESS (QUOTE IDLE)) (SETQQ DISPLAYFONTDIRECTORIES ({ERIS}FONTS>)) (SETQQ PRESSFONTWIDTHSFILES ({ERIS}FONTS>FONTS.WIDTHS)) (SETQQ INTERPRESSFONTDIRECTORIES ({ERIS}FONTS>)) (SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL) (SETQQ LOADUPDIRECTORIES ({Eris}Sources> {Eris}Library> {Eris}Internal>Library>)) (LOADUP (QUOTE (GIVE-AND-TAKE CHANGECONTROL CHAT PUPCHAT NSCHAT PRESS PUPPRINT TEDIT HRULE TEDITCHAT READNUMBER EDITBITMAP MAILCLIENT GRAPEVINE NSMAIL LAFITE FILEBROWSER TELERAID GRAPHER SPY AREDIT WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE))) (\DAYTIME0 \LASTUSERACTION) (ENDLOADUP)) STOP \ No newline at end of file diff --git a/sources/LOADFULLFROMDLINIT.CM b/sources/LOADFULLFROMDLINIT.CM new file mode 100644 index 00000000..a8677653 --- /dev/null +++ b/sources/LOADFULLFROMDLINIT.CM @@ -0,0 +1 @@ +////////////////////////////////////////////////////////////////////////// // // L O A D F U L L F R O M D L I N I T . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make the INIT.DLINIT into a LISP.SYSOUT & a FULL.SYSOUT. // ////////////////////////////////////////////////////////////////////////// // IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINITSLOW.CM // LoadFullFromDLInit.cm, edited 8-Mar-87 15:40:50 vanMelle // ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE // bring over files necessary to run INIT.DLINIT. FTP/-E ERINYES Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb; // start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong Lisp {DSK6}Init.DLInit ;" (SETQQ MAKESYSNAME LISPCORE) (PROGN (LOAD (QUOTE \"{Pele:MV:Envos}SOURCES>LOADUP.LISP\")) (HARDRESET)) SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:MAKESYS '\"{Pele:MV:Envos}Basics>LISP.SYSOUT\")) SHH(PROGN (IL:LOAD '\"{Pele:MV:Envos}SOURCES>LOADFULL.LISP\") (IL:MAKESYS '\"{Pele:MV:Envos}Basics>FULL.SYSOUT\") (IL:LOGOUT T)) " \ No newline at end of file diff --git a/sources/LOADFULLFROMDLINITSLOW.CM b/sources/LOADFULLFROMDLINITSLOW.CM new file mode 100644 index 00000000..9058d7f3 --- /dev/null +++ b/sources/LOADFULLFROMDLINITSLOW.CM @@ -0,0 +1 @@ +// IF YOU EDIT THIS FILE, BE SURE TO EDIT LOADFULLFROMDLINIT.CM // LoadFullFromDLInitSlow.cm, edited 8-Mar-87 15:40:50 vanMelle // ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE ^^^ READ ^^^ UPDATE // bring over files necessary to run INIT.DLINIT. FTP/-E ERIS Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb; // start up DLInit. MAKESYSNAME gets set here. The (SPECVARS . T) is because some file in the loadup (unknown) sets it wrong Lisp [ERIS]Next>Init.dlinit ;" (SETQQ MAKESYSNAME LISPCORE) (PROGN (LOAD (QUOTE {ERIS}SOURCES>LOADUP.LISP))(HARDRESET)) SHH(PROGN (IL:ENDLOADUP) (IL:SPECVARS . T) (IL:* IL:MAKESYS '{ERIS}NEXT>LISP.SYSOUT)) SHH(PROGN (IL:LOAD '{ERIS}SOURCES>LOADFULL.LISP) (IL:MAKESYS '{ERIS}NEXT>FULL.SYSOUT) (IL:LOGOUT T)) " \ No newline at end of file diff --git a/sources/LOADFULLFROMLISP.CM b/sources/LOADFULLFROMLISP.CM new file mode 100644 index 00000000..64c731cd --- /dev/null +++ b/sources/LOADFULLFROMLISP.CM @@ -0,0 +1 @@ +// LoadFullFromLisp.cm Edited 24-Feb-87 19:10:47 -- van Melle -- Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.DFASL!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERIS Login/C Dir/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init.null Init.DFASL Lisp [ERIS]Next>Lisp.sysout ;" SHH(PROGN (DELFILE '{DSK}INIT.DFASL) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL;1) ) SHH(LOAD '{ERIS}SOURCES>LOADFULL.LISP) SHH(MAKESYS '{ERIS}NEXT>FULL.SYSOUT] SHH(LOGOUT] " \ No newline at end of file diff --git a/sources/LOADFULLSLOW.CM b/sources/LOADFULLSLOW.CM new file mode 100644 index 00000000..33eaa7e8 --- /dev/null +++ b/sources/LOADFULLSLOW.CM @@ -0,0 +1 @@ +ftp ERIS Directory/C LispCore>SOURCES Retrieve/<>A LOADFULLSLOW.CM LoadInitSlow.cm LoadFullFromDLInitSlow.cm @LoadInitSlow.CM@ @LoadFullFromDLInitSlow.cm@ \ No newline at end of file diff --git a/sources/LOADINIT.CM b/sources/LOADINIT.CM new file mode 100644 index 00000000..3353168f --- /dev/null +++ b/sources/LOADINIT.CM @@ -0,0 +1 @@ +////////////////////////////////////////////////////////////////////////// // // L O A D I N I T . C M // // (C) Copyright 1990, Venue & Fuji Xerox, Ltd. // All Rights Reserved. // // Make the INIT.DLINIT starting sysout for a new loadup. // ////////////////////////////////////////////////////////////////////////// // IF YOU EDIT THIS FILE, EDIT LOADINITSLOW.CM TOO!!!! // Edit November 3, 1987 by vanMelle, note comment ^^ // The path given to the Lisp command below should point to the LispCore sysout cache. // Code that runs after Lisp starts up assures that the cached sysout // is the most recent, and if not, fetches a new one and restarts itself. // Edited so that the most recent patch file is loaded // Updated Lisp version for big physical memory --bvm 11/3/87 Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERINYES Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init-NOGREET Init.DFASL Lisp {DSK7}LispCore.Sysout;" (XCL:RESTORE-PROFILE \"INTERLISP\") (DELFILE '{DSK}INIT.DFASL) (AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL)) (DIRECTORY '{DSK6}INIT.DLINIT;* '(DELETE)) (* Make sure we have a valid sysout) (LET ((DATE (CAR (NLSETQ (GETFILEINFO '{Pele:mv:envos}Saved>FULL.SYSOUT 'ICREATIONDATE))))) (IF (AND DATE (IGREATERP DATE (GETFILEINFO '{DSK7}LispCore.Sysout;1 'ICREATIONDATE))) THEN (* Get new saved sysout) (NLSETQ (PROGN (COPYFILE '{Pele:mv:envos}Saved>FULL.SYSOUT '{DSK7}LispCore.Sysout;1) (COPYFILE '{DSK}REM.CM;1 '{CORE}REM.CM) (* Repeat current command now) (OUTFILE '{DSK}REM.CM;1) (PRIN1 '@LoadInit.cm@) (COPYBYTES (OPENSTREAM '{CORE}REM.CM 'INPUT)) (CLOSEF) (LOGOUT T] (PROGN (* Make old sysout work with new read tables) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE)) (LOAD \"{Pele:mv:envos}NEXT>LOAD-LISPCORE-PATCH\") CONN \"{pele:mv:envos}SOURCES>\" (SETQ DIRECTORIES '(\"{Pele:MV:Envos}SOURCES>\" \"{Pele:MV:Envos}LIBRARY>\" \"{Pele:MV:Envos}INTERNAL>LIBRARY>\")) (SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL) (SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* Get new exports since last loadup) (LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD) (LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD) (* FILESETS has where to get things from) (LOAD 'FILESETS) (FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) (* Versions are Lisp Microcode Bcpl) (PROGN (CNDIR '{CORE}) (IDLE.SET.OPTION 'TIMEOUT 0) (IDLE.SET.OPTION 'SAVEVM 0) (DORENAME 'I) (DLFIXINIT (MAKEINIT '(115000Q 13062Q 25400Q) NIL NIL '(\"{Pele:MV:Envos}SOURCES>\" \"{Pele:MV:Envos}INTERNAL>LIBRARY>\" \"{Pele:MV:Envos}LIBRARY>\")) '{DSK6}INIT.DLINIT \"{Pele:MV:Envos}NEXT>LispDLion.db\" 300) (LOGOUT T]] " \ No newline at end of file diff --git a/sources/LOADINITSLOW.CM b/sources/LOADINITSLOW.CM new file mode 100644 index 00000000..5628c9a8 --- /dev/null +++ b/sources/LOADINITSLOW.CM @@ -0,0 +1 @@ +// LoadInitSlow.cm edited: November 3, 1987 by vanMelle // IF YOU EDIT THIS FILE, EDIT LOADINIT.CM TOO // edit 30-Nov-86 12:06:48 by masinter, merge LOADINIT changes, add comment above // Updated Lisp version for big physical memory --bvm 11/3/87 // The path given to the Lisp command below should point to the LispCore sysout cache. Delete INIT.DFASL!* INIT.SAVE* // otherwise Lisp might read INIT.LISP!2 Copy INIT.SAVE _ INIT.DFASL // save away site file to be restored below FTP/-E ERIS Login/C Directory/C LispCore>Next Ret/<>A Lisp.run DoradoLispMc.eb Ret/S Current>Init-NOGREET Init.DFASL Lisp [ERIS]saved>Full.Sysout;" (XCL:RESTORE-PROFILE \"INTERLISP\") (DELFILE '{DSK}INIT.DFASL) (AND (INFILEP '{DSK}INIT.SAVE) (RENAMEFILE '{DSK}INIT.SAVE '{DSK}INIT.DFASL)) (PROGN (* Make old sysout work with new read tables) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM FILERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM CODERDTBL) (SETSYNTAX (CHARCODE ^^) 'PACKAGEDELIM \\ORIGREADTABLE)) (LOAD '{ERIS}NEXT>LOAD-LISPCORE-PATCH) CONN {ERIS}SOURCES> (SETQ DIRECTORIES '({ERIS}SOURCES> {ERIS}LIBRARY> {ERIS}INTERNAL>LIBRARY>)) (SETQ LITATOM-PACKAGE-CONVERSION-ENABLED NIL) (SETQ *REMOVE-INTERLISP-COMMENTS* NIL) (* Get new exports since last loadup) (LOAD 'CONDITION-PACKAGE.LCOM 'SYSLOAD) (LOAD 'XCL-PACKAGE.LCOM 'SYSLOAD) (* FILESETS has where to get things from) (LOAD 'FILESETS) (FILESLOAD RENAMEFNS MAKEINIT DLFIXINIT CMLARRAY-SUPPORT) (* Versions are Lisp Microcode Bcpl) (PROGN (CNDIR '{CORE}) (IDLE.SET.OPTION 'TIMEOUT 0) (IDLE.SET.OPTION 'SAVEVM 0) (DORENAME 'I) (DLFIXINIT (MAKEINIT '(115000Q 13062Q 25400Q) NIL NIL '({ERIS}SOURCES> {ERIS}LIBRARY>)) '{ERIS}NEXT>INIT.DLINIT '{ERIS}NEXT>LispDLion.db 300) (LOGOUT T]] " \ No newline at end of file diff --git a/sources/LOADUP.LISP b/sources/LOADUP.LISP new file mode 100644 index 00000000..cb9f28c1 --- /dev/null +++ b/sources/LOADUP.LISP @@ -0,0 +1 @@ +(SETQQ COMPILE.EXT LCOM) (SETQ SYSFILES (UNION BOOTLOADEDFILES SYSFILES)) (SETQ BOOTLOADEDFILES) (* "following files are really loaded earlier, this call to LOADUP just cleans up") (LOADUP (QUOTE (ACODE MACHINEINDEPENDENT POSTLOADUP))) (* "establish all package exports early") (LOADUP (QUOTE (LISP-PACKAGE FASL-PACKAGE D-ASSEM-PACKAGE COMPILER-PACKAGE))) (* "turn on FTP so that loadup will be faster") (LOADUP (QUOTE (BSP DPUPFTP))) (* "load FASL loader here, so we can load DFASLs earlier in loadup") (LOADUP (QUOTE (ERROR-RUNTIME CMLARITH CONDITION-HIERARCHY CMLHASH D-ASSEM FASLOAD))) (* "These are needed by any FASL files") (LOADUP (QUOTE (DEFFER-RUNTIME CMLPRINT CLSTREAMS CMLSTRING CMLSYMBOL CMLTYPES CMLSEQCOMMON CMLSEQMAPPERS CMLPATHNAME CMLFILESYS))) (* * * "FASL files may be loaded after this point" * * *) (LOADUP (QUOTE (CMLDEFFER ERROR-RUNTIME-AFTER-FASL WRAPPERS))) (* "early runtime support for Common Lisp and (temporarily) debugger") (LOADUP (QUOTE (STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS))) (LOADUP (QUOTE (COMMON XCLC-RUNTIME CMLTYPES CL-ERROR))) (LOADUP (QUOTE (AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF FONTPROFILE SPELLFILE PRINTFN LOADFNS DMISC DIRECTORY SPELLFILE FILEPKG RESOURCE))) (* "The Byte Compiler (DLAP, BYTECOMPILER, COMPILER) used to be here. Moved after XCL Compiler so that one byte compiler init will work. JDS 10/11/89") (LOADUP (QUOTE (HIST UNDO SPELL DWIM WTFIX CLISP DWIMIFY CLISPIFY RECORD))) (LOADUP (QUOTE (GAINSPACE COROUTINE ARGLIST ASKUSER SYSPRETTY COMMON COMPARE))) (DWIM (QUOTE C)) (* "Kernel Common Lisp files") (LOADUP (QUOTE (CMLSTEP CMLDOC CMLPARSE CMLSETF CMLPRED CMLREAD WALKER CMLSEQFINDER CMLSEQMODIFY CMLSORT DEFSTRUCT CMLMISCIO CMLCOMPILE CMLDESTRUCT CL-ERROR CMLFORMAT CMLENVIRONMENT CMLLOAD CMLFLOAT CMLTIME CMLRAND CMLMODULES))) (LOADUP (QUOTE (PROFILE CMLEXEC EXEC-COMMANDS DEBUGGER IL-ERROR-STUFF DEBUGEDIT))) (LOADUP (QUOTE (ADDARITH))) (LOADUP (QUOTE (CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY MENU WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON LOGOW PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))) (LOADUP (QUOTE (BREAK-AND-TRACE))) (LOADUP (QUOTE (FASDUMP XCL-COMPILER ADVISE))) (* "the bytecompiler and Interlisp compiler interface functions") (LOADUP (QUOTE (DLAP BYTECOMPILER COMPILE))) (LOADUP (QUOTE (DISKDLION DOVEINPUTOUTPUT DOVEDISK DOVEDISPLAY DOVEMISC DOVEETHER DOVEFLOPPY LOCALFILE DSKDISPLAY 10MBDRIVER MAIKOETHER LLNS TRSERVER SPP COURIER NSPRINT CLEARINGHOUSE NSFILING HARDCOPY INTERPRESS FLOPPY IDLER ICONW FREEMENU SEDIT))) (LOADUP (QUOTE (DSK UFS UFSCALLC MAIKOBITBLT))) (LOADUP (QUOTE (TIME))) (LOADUP (QUOTE (XCL-EXTRAS))) (* "CMLPACKAGE pushes onto INSPECTMACROS") (LOADUP (QUOTE (CMLPACKAGE))) (* "Puts ARGNAME properties on CL and XCL functions that IL:SMARTARGLIST can't hack. Keep this last so everything will be defined when it runs") (LOADUP (QUOTE (CMLSMARTARGS))) (LOADUP (QUOTE (IMPLICIT-KEY-HASH CLOSURE-CACHE))) (* "Already enabled, but this time fixes tables that weren't defined in the init") (PACKAGE-ENABLE) STOP \ No newline at end of file diff --git a/sources/LOCALFILE b/sources/LOCALFILE new file mode 100644 index 00000000..cf99018e --- /dev/null +++ b/sources/LOCALFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 10:55:28" {DSK}lde>lispcore>sources>LOCALFILE.;2 285483 changes to%: (RECORDS Page RandomPage FileID VolumeID DiskFileID LVBootFiles RootFileArray LogicalVolumeDescriptor PVBootFiles SubVolumeDesc SubVolumeArray PhysicalVolumeDescriptor LogicalSubVolumeMarker SubVolumeMarkerPage RootDirEntry RootDirEntryArray RootDirectory PageGroup FileDescriptor Label LFDEV DLIONSTREAM LeaderPage GenerateFileState GeneratedFile DIRSEARCHSTATE PARSEDFILENAME ExpandedName DFSFileSpec Key Interval Index BufferArray Buffer \BTREEBUF) previous date%: " 5-Jan-93 01:04:33" {DSK}lde>lispcore>sources>LOCALFILE.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOCALFILECOMS) (RPAQQ LOCALFILECOMS ( (* ;;; "This is the Dandelion/Dove local hard disk file system.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) DISKVMEMDECLS) (FILES MESATYPES) (LOCALVARS . T)) (* ;;; "Declare low-level data types on which all file system modules depend.") (FNS \PFFetchString \PFReplaceString) (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * PILOTFILECOMPILECOMS)) (INITRECORDS PageGroup FileDescriptor) (* ;;; "Define the various modules of the file system.") (COMS * LFCOMS) (COMS * LFDIRECTORYCOMS) (COMS * SCAVENGEDSKDIRECTORYCOMS) (COMS * LFPILOTFILECOMS) (COMS * LFALLOCATIONMAPCOMS) (COMS * LFFILEMAPCOMS) (PROP MAKEFILE-ENVIRONMENT LOCALFILE))) (* ;;; "This is the Dandelion/Dove local hard disk file system.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) DISKVMEMDECLS) (FILESLOAD MESATYPES) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (* ;;; "Declare low-level data types on which all file system modules depend.") (DEFINEQ (\PFFetchString [LAMBDA (startLoc lengthLoc maxLength) (* amd "10-Feb-86 18:25") (* ;;; "Returns a string containing lengthLoc characters read starting from startLoc and capitalized.") (PROG [(STR (ALLOCSTRING (MIN (\GETBASE lengthLoc 0) maxLength] [for POS from 1 to (NCHARS STR) do (RPLCHARCODE STR POS (\GETBASEBYTE startLoc (SUB1 POS] (RETURN STR]) (\PFReplaceString [LAMBDA (startLoc lengthLoc maxLength newString) (* amd "10-Feb-86 18:26") (* ;;; "Writes out newString beginning at startLoc, and indicates the length in the word beginning at lengthLoc.") (SETQ newString (MKSTRING newString)) (PROG ((LENGTH (MIN (NCHARS newString) maxLength))) (* ;; "First write out characters") (for POS from 0 to (SUB1 LENGTH) as CHAR instring newString do (\PUTBASEBYTE startLoc POS CHAR)) (* ;; "Then write out length of string") (\PUTBASE lengthLoc 0 LENGTH) (RETURN newString]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ PILOTFILECOMPILECOMS ( (* ;; "Assorted system constants") (CONSTANTS (pilotVersion 8)) (CONSTANTS (maxPagesPerFile 8388607) (lastPageNumber (SUB1 maxPagesPerFile)) (nullVolumePage 0) (maxLogicalVolumes 10)) (CONSTANTS (hardMicrocode 0) (bftGerm 2)) (* ;; "Interesting Pilot file types.") (CONSTANTS (tUnassigned 0) (tPhysicalVolumeRootPage 1) (tSubVolumeMarkerPage 4) (tLogicalVolumeRootPage 5) (tFreePage 6) (tVolumeAllocationMap 7) (tVolumeFileMap 8) (tRootDirectory 18) (tLispDirectory 10048) (tLispFile 10049) (tDiagnosticMicrocode 65535) (pilotVolume 0) (nonPilotVolume 3)) (* ;;  "Logical volume root page, physical volume root page, and marker page types") (CONSTANTS (logicalVolumeSeal 45771)) (RECORDS Page RandomPage FileID VolumeID DiskFileID LVBootFiles RootFileArray LogicalVolumeDescriptor) (CONSTANTS (physicalVolumeSeal 41610)) (RECORDS PVBootFiles SubVolumeDesc SubVolumeArray PhysicalVolumeDescriptor) (RECORDS LogicalSubVolumeMarker SubVolumeMarkerPage) (MACROS LVEqual SwapIn&Dirty LvBasePageAddr MarkerPageAddr) (* ;; "Volume root directory stuff") (CONSTANTS (rootDirSeal 30167) (rootDirVersion 2) (rootDirMaxEntries 84)) (RECORDS RootDirEntry RootDirEntryArray RootDirectory) (* ;; "Miscellaneous records") (RECORDS PageGroup FileDescriptor) (RECORDS Label) (* ;; "The following are for diagnostic purposes.") (MACROS DISPLAYWORDS DISPLAYLABEL DISPLAYPAGE))) (* ;; "Assorted system constants") (DECLARE%: EVAL@COMPILE (RPAQQ pilotVersion 8) (CONSTANTS (pilotVersion 8)) ) (DECLARE%: EVAL@COMPILE (RPAQQ maxPagesPerFile 8388607) (RPAQ lastPageNumber (SUB1 maxPagesPerFile)) (RPAQQ nullVolumePage 0) (RPAQQ maxLogicalVolumes 10) (CONSTANTS (maxPagesPerFile 8388607) (lastPageNumber (SUB1 maxPagesPerFile)) (nullVolumePage 0) (maxLogicalVolumes 10)) ) (DECLARE%: EVAL@COMPILE (RPAQQ hardMicrocode 0) (RPAQQ bftGerm 2) (CONSTANTS (hardMicrocode 0) (bftGerm 2)) ) (* ;; "Interesting Pilot file types.") (DECLARE%: EVAL@COMPILE (RPAQQ tUnassigned 0) (RPAQQ tPhysicalVolumeRootPage 1) (RPAQQ tSubVolumeMarkerPage 4) (RPAQQ tLogicalVolumeRootPage 5) (RPAQQ tFreePage 6) (RPAQQ tVolumeAllocationMap 7) (RPAQQ tVolumeFileMap 8) (RPAQQ tRootDirectory 18) (RPAQQ tLispDirectory 10048) (RPAQQ tLispFile 10049) (RPAQQ tDiagnosticMicrocode 65535) (RPAQQ pilotVolume 0) (RPAQQ nonPilotVolume 3) (CONSTANTS (tUnassigned 0) (tPhysicalVolumeRootPage 1) (tSubVolumeMarkerPage 4) (tLogicalVolumeRootPage 5) (tFreePage 6) (tVolumeAllocationMap 7) (tVolumeFileMap 8) (tRootDirectory 18) (tLispDirectory 10048) (tLispFile 10049) (tDiagnosticMicrocode 65535) (pilotVolume 0) (nonPilotVolume 3)) ) (* ;; "Logical volume root page, physical volume root page, and marker page types") (DECLARE%: EVAL@COMPILE (RPAQQ logicalVolumeSeal 45771) (CONSTANTS (logicalVolumeSeal 45771)) ) (DECLARE%: EVAL@COMPILE (RECORD Page NIL (CREATE (NCREATE 'VMEMPAGEP)) (TYPE? (TYPENAMEP DATUM 'VMEMPAGEP))) (RECORD RandomPage NIL (TYPE? (EQ (fetch (POINTER WORDINPAGE) of DATUM) 0))) (MESATYPE FileID (2 WORD)) (MESATYPE VolumeID (5 WORD)) (MESARECORD DiskFileID ((fID VolumeID) (firstPage SWAPPEDFIXP) (da SWAPPEDFIXP)) (* Booting information) ) (MESAARRAY LVBootFiles ((0 5)) DiskFileID (* Booting information) ) (MESAARRAY RootFileArray ((6 14)) FileID) (MESARECORD LogicalVolumeDescriptor ((seal WORD) (* Validation ; absolutely must be  first field) (version WORD) (* must be 2nd field) (vID VolumeID) (* ID of This Volume) (labelLength WORD) (* Length of th ASCII name of this  volume) (label 40 BYTE) (* Volume name in AScII) (type WORD) (volumeSize SWAPPEDFIXP) (* Number of pages in this volume) (bootingInfo LVBootFiles) (* Defines 6 PILOT file types) (NIL WORD) (NIL BITS 15) (changing FLAG) (* Change field decls from here on  only) (* boolean _ T) (freePageCount SWAPPEDFIXP) (* Number of free pages remaining) (vamStart SWAPPEDFIXP) (vfmStart SWAPPEDFIXP) (* Relative address of the start of  the volume file map) (lowerBound SWAPPEDFIXP) (volumeRootDirectory SWAPPEDFIXP) (rootFileID RootFileArray) (lastIDAllocated SWAPPEDFIXP) (* Highest numbered File.ID given out on this volume.  We reserve the first set of IDs for Pilot's own use.  In particular, files of type IN PilotRootFileType may have their ID the same as  their File.Type.) (scavengerLogVolume VolumeID) (lastTimeOpendForWrite SWAPPEDFIXP) (NIL 131 WORD) (checksum WORD) (* Must be the last field) ) (ACCESSFNS (LVlabel (\PFFetchString (LOCF (fetch ( LogicalVolumeDescriptor label) of DATUM)) (LOCF (fetch ( LogicalVolumeDescriptor labelLength) of DATUM)) 40) (\PFReplaceString (LOCF (fetch (LogicalVolumeDescriptor label) of DATUM)) (LOCF (fetch (LogicalVolumeDescriptor labelLength) of DATUM)) 40 NEWVALUE))) (CREATE (PROG ((lv (create Page))) (replace (LogicalVolumeDescriptor seal) of lv with logicalVolumeSeal ) (RETURN lv))) (TYPE? (AND (type? Page DATUM) (EQ (fetch (LogicalVolumeDescriptor seal) of DATUM) logicalVolumeSeal)))) ) (DECLARE%: EVAL@COMPILE (RPAQQ physicalVolumeSeal 41610) (CONSTANTS (physicalVolumeSeal 41610)) ) (DECLARE%: EVAL@COMPILE (MESAARRAY PVBootFiles ((0 3)) DiskFileID) (MESARECORD SubVolumeDesc ((lvID VolumeID) (lvSize SWAPPEDFIXP) (lvPage SWAPPEDFIXP) (pvPage SWAPPEDFIXP) (nPages SWAPPEDFIXP))) (MESAARRAY SubVolumeArray ((0 9)) SubVolumeDesc) (MESARECORD PhysicalVolumeDescriptor ((seal WORD) (* Validation) (version WORD) (labelLength WORD) (pvID VolumeID) (bootingInfo PVBootFiles) (* Defines 4 PILOT file types) (label 40 BYTE) (* Ascii name of the volume) (subVolumeCount WORD) (subVolumeMarkerID VolumeID) (* Marker pages belong to this  Pseudo File) (badPageCount SWAPPEDFIXP) (maxBadPages SWAPPEDFIXP) (onLineCount WORD) (subVolumes SubVolumeArray) (* See SubVolumeDesc record for  description of each of six entries  stored here) (NIL 47 WORD) (localTimeParametersValid WORD) (localTimeParameters 2 WORD) (checksum WORD)) (ACCESSFNS (PVlabel (\PFFetchString (LOCF (fetch ( PhysicalVolumeDescriptor label) of DATUM)) (LOCF (fetch ( PhysicalVolumeDescriptor labelLength) of DATUM)) 40) (\PFReplaceString (LOCF (fetch ( PhysicalVolumeDescriptor label) of DATUM)) (LOCF (fetch ( PhysicalVolumeDescriptor labelLength) of DATUM)) 40 NEWVALUE))) (CREATE (PROG ((physicalVol (create Page))) (replace (PhysicalVolumeDescriptor seal) of physicalVol with physicalVolumeSeal) (RETURN physicalVol))) (TYPE? (AND (type? Page DATUM) (EQ (fetch (PhysicalVolumeDescriptor seal) of DATUM) physicalVolumeSeal)))) ) (DECLARE%: EVAL@COMPILE (MESARECORD LogicalSubVolumeMarker ((seal WORD) (version WORD) (labelLength BITS 6) (type BITS 2) (NIL BITS 8) (label 20 WORD) (bootingInfo LVBootFiles) (volumeRootDirectory SWAPPEDFIXP))) (MESARECORD SubVolumeMarkerPage ((logical LogicalSubVolumeMarker) (* Incomplete) ) (CREATE (create Page)) (TYPE? (type? Page DATUM))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS LVEqual MACRO ((a b) (MESAEQUAL (fetch (LogicalVolumeDescriptor vID) of a) (fetch (LogicalVolumeDescriptor vID) of b) VolumeID))) [PUTPROPS SwapIn&Dirty MACRO (OPENLAMBDA (page) (\PUTBASE page 0 (\GETBASE page 0] [PUTPROPS LvBasePageAddr MACRO ((vol) (fetch (SubVolumeDesc pvPage) of (FMESAELT (fetch ( PhysicalVolumeDescriptor subVolumes) of \PhysVolumePage) SubVolumeArray vol] [PUTPROPS MarkerPageAddr MACRO ((vol) (fetch (SubVolumeDesc nPages) of (FMESAELT (fetch ( PhysicalVolumeDescriptor subVolumes) of \PhysVolumePage) SubVolumeArray (OR (FIXP vol) (\PFVolumeNumber vol] ) (* ;; "Volume root directory stuff") (DECLARE%: EVAL@COMPILE (RPAQQ rootDirSeal 30167) (RPAQQ rootDirVersion 2) (RPAQQ rootDirMaxEntries 84) (CONSTANTS (rootDirSeal 30167) (rootDirVersion 2) (rootDirMaxEntries 84)) ) (DECLARE%: EVAL@COMPILE (MESARECORD RootDirEntry ((type WORD) (file SWAPPEDFIXP))) (MESAARRAY RootDirEntryArray ((0 rootDirMaxEntries)) RootDirEntry) (MESARECORD RootDirectory ((seal WORD) (version WORD) (maxEntries WORD) (countEntries WORD) (entries RootDirEntryArray)) (CREATE (PROG ((rootDir (create Page))) (replace (RootDirectory seal) of rootDir with rootDirSeal) (replace (RootDirectory version) of rootDir with rootDirVersion) (replace (RootDirectory maxEntries) of rootDir with rootDirMaxEntries) (RETURN rootDir))) (TYPE? (AND (type? Page DATUM) (EQ (fetch (RootDirectory seal) of DATUM) rootDirSeal)))) ) (* ;; "Miscellaneous records") (DECLARE%: EVAL@COMPILE (DATATYPE PageGroup ((filePage SWAPPEDFIXP) (volumePage SWAPPEDFIXP) (nextFilePage SWAPPEDFIXP))) (DATATYPE FileDescriptor (fileID (* ;  "Can be either a FIXP or a pointer to a VolumeID") (volNum FIXP) (* ; "0..9") (type WORD) (* ; "Pilot file type") (size FIXP) (* ;  "Current number of (Pilot) pages allocated to this file") (PAGEGROUP POINTER) (* ;  "Caches the last PageGroup found for this file") )) ) (/DECLAREDATATYPE 'PageGroup '(SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP) '((PageGroup 0 SWAPPEDFIXP) (PageGroup 2 SWAPPEDFIXP) (PageGroup 4 SWAPPEDFIXP)) '6) (/DECLAREDATATYPE 'FileDescriptor '(POINTER FIXP WORD FIXP POINTER) '((FileDescriptor 0 POINTER) (FileDescriptor 2 FIXP) (FileDescriptor 4 (BITS . 15)) (FileDescriptor 5 FIXP) (FileDescriptor 8 POINTER)) '10) (DECLARE%: EVAL@COMPILE (MESARECORD Label ((fileID SWAPPEDFIXP) (* valid in label of every page) (NIL 3 WORD) (filePageLo WORD) (filePageHi BITS 7) (* 23 bit page number, valid in  label of every page) (* always zero) (pageZeroAttributes BITS 9) (* valid only in label of page 0) (attributesInAllPages WORD) (* valid in label of every page) (dontCare 2 WORD)) (ACCESSFNS (filePage (\MAKENUMBER (fetch (Label filePageHi) of DATUM) (fetch (Label filePageLo) of DATUM)) (PROGN (replace (Label filePageHi) of DATUM with (\HINUM NEWVALUE)) (replace (Label filePageLo) of DATUM with (\LONUM NEWVALUE)) NEWVALUE))) [TYPE? (OR (type? ARRAYBLOCK DATUM) (AND (GETD '\BLOCKDATAP) (\BLOCKDATAP DATUM]) ) (* ;; "The following are for diagnostic purposes.") (DECLARE%: EVAL@COMPILE [PUTPROPS DISPLAYWORDS MACRO (LAMBDA (Start Number) (* ;; "Prints out the first Number words of the object Start") [for I from 0 to (SUB1 Number) do (PRIN1 (\GETBASE Start I)) (PRIN1 " ") (COND ((EQ (IREMAINDER (ADD1 I) 14) 0) (TERPRI] (TERPRI] [PUTPROPS DISPLAYLABEL MACRO (LAMBDA (vol volumePageNumber) (* ;; "Prints the label of the given page.") (PROG ((L (create Label))) (if (type? LogicalVolumeDescriptor vol) then (SETQ vol (\PFVolumeNumber vol))) (\PFTransferPage (IPLUS (LvBasePageAddr vol) volumePageNumber) (create Page) 'VRR L) (DISPLAYWORDS L 10] [PUTPROPS DISPLAYPAGE MACRO (LAMBDA (vol volumePageNumber) (* ;; "Prints out the specified page of the disk.") (PROG ((P (create Page))) (if (type? LogicalVolumeDescriptor vol) then (SETQ vol (\PFVolumeNumber vol))) (\PFTransferPage (IPLUS (LvBasePageAddr vol) volumePageNumber) P 'VRR (create Label)) (DISPLAYWORDS P WORDSPERPAGE] ) ) (/DECLAREDATATYPE 'PageGroup '(SWAPPEDFIXP SWAPPEDFIXP SWAPPEDFIXP) '((PageGroup 0 SWAPPEDFIXP) (PageGroup 2 SWAPPEDFIXP) (PageGroup 4 SWAPPEDFIXP)) '6) (/DECLAREDATATYPE 'FileDescriptor '(POINTER FIXP WORD FIXP POINTER) '((FileDescriptor 0 POINTER) (FileDescriptor 2 FIXP) (FileDescriptor 4 (BITS . 15)) (FileDescriptor 5 FIXP) (FileDescriptor 8 POINTER)) '10) (* ;;; "Define the various modules of the file system.") (RPAQQ LFCOMS ( (* ;;; "This module handles the interface to the device-independent part of the file system: it provides a vector of standard device-specific file system operations. This used to be the sole contents of the file LOCALFILE.") (DECLARE%: EVAL@COMPILE DONTCOPY (* ;; "File system datatypes") (CONSTANTS (lispFileVersion 2) (leaderPageSeal 54321)) (RECORDS LFDEV DLIONSTREAM LeaderPage) (* ;; "Error mechanism") (MACROS DiskError)) (* ;; "Public entry") (FNS CREATEDSKDIRECTORY PURGEDSKDIRECTORY LISPDIRECTORYP VOLUMES VOLUMESIZE) (FNS \DFSCurrentVolume \DFSFreeDiskPages) (FNS \LFEntryPoint \LFNormalizeVolumeName) (* ;; "Device management") (FNS \LFCreateDevice \LFOpenDevice \LFCloseDevice) (GLOBALVARS \LFdevice \LFtopMonitor \LFrunSize) (P (\LFCreateDevice)) (INITVARS (\LFtopMonitor (CREATE.MONITORLOCK 'topMonitor)) (\LFrunSize 20)) (* ;; "Device methods") (FNS \LFOpenFile \LFGetStreamForFile \LFOpenOldFile \LFGenFileID \LFCreateFile \LFMakeLeaderPage \LFUpdateLeaderPage \LFWriteLeaderPage) (FNS \LFCloseFile) (FNS \LFDeleteFile) (FNS \LFReadPages) (FNS \LFWritePages \LFExtendFileIfNecessary \LFExtendFile) (FNS \LFGetFileInfo \LFSetFileInfo) (FNS \LFGetFileName) (FNS \LFEventFn) (FNS \LFDirectoryNameP) (FNS \LFTruncateFile) (FNS \LFRenameFile))) (* ;;; "This module handles the interface to the device-independent part of the file system: it provides a vector of standard device-specific file system operations. This used to be the sole contents of the file LOCALFILE." ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ lispFileVersion 2) (RPAQQ leaderPageSeal 54321) (CONSTANTS (lispFileVersion 2) (leaderPageSeal 54321)) ) (DECLARE%: EVAL@COMPILE (RECORD LFDEV FDEV (SUBRECORD FDEV) [TYPE? (AND (type? FDEV DATUM) (EQ (fetch (FDEV CLOSEFILE) of DATUM) (FUNCTION \LFCloseFile)) (EQ (fetch (FDEV HOSTNAMEP) of DATUM) (FUNCTION NILL]) (RECORD DLIONSTREAM STREAM (SUBRECORD STREAM) [ACCESSFNS ((FILEDESC (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (LEADERPAGE (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (DIRINFO (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE)) (DIRHOLEPTR (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (VOLUME (\PFGetVol (fetch (FileDescriptor volNum) of (fetch (DLIONSTREAM FILEDESC) of DATUM] [TYPE? (AND (type? STREAM DATUM) (type? FileDescriptor (fetch (DLIONSTREAM FILEDESC) of DATUM]) (MESARECORD LeaderPage ((seal WORD) (version WORD) (TimeCreate FIXP) (TimeWrite FIXP) (TimeRead FIXP) (FileID FIXP) (AllocatedPages FIXP) (EofPage FIXP) (EOffSet WORD) (NameLength WORD) (FileName 256 BYTE) (AuthorLength WORD) (AuthorName 64 BYTE) (typeHolder WORD)) (ACCESSFNS (TYPE (SELECTQ (fetch (LeaderPage typeHolder) of DATUM) (0 'TEXT) 'BINARY) (PROGN (replace (LeaderPage typeHolder) of DATUM with (SELECTQ NEWVALUE (TEXT 0) 1)) NEWVALUE))) (ACCESSFNS (fileName (\PFFetchString (LOCF (fetch (LeaderPage FileName ) of DATUM)) (LOCF (fetch (LeaderPage NameLength) of DATUM)) 256) (\PFReplaceString (LOCF (fetch (LeaderPage FileName) of DATUM)) (LOCF (fetch (LeaderPage NameLength) of DATUM)) 256 NEWVALUE))) (ACCESSFNS (author (\PFFetchString (LOCF (fetch (LeaderPage AuthorName ) of DATUM) ) (LOCF (fetch (LeaderPage AuthorLength) of DATUM)) 64) (\PFReplaceString (LOCF (fetch (LeaderPage AuthorName) of DATUM)) (LOCF (fetch (LeaderPage AuthorLength) of DATUM)) 64 NEWVALUE))) (CREATE (PROG ((leader (create Page))) (replace (LeaderPage seal) of leader with leaderPageSeal) (RETURN leader))) (TYPE? (AND (type? Page DATUM) (EQ (fetch (LeaderPage seal) of DATUM) leaderPageSeal)))) ) (DECLARE%: EVAL@COMPILE [PUTPROPS DiskError MACRO ((errorType fileName CONTINUEOKFLG) (PROG ((\INTERRUPTABLE T)) (* * Gross hack to allow the error to show up as a break rather than a 9318) (LISPERROR errorType fileName CONTINUEOKFLG] ) ) (* ;; "Public entry") (DEFINEQ (CREATEDSKDIRECTORY [LAMBDA (volName smashDirectory) (* ; "Edited 8-Jan-87 17:50 by amd") (* ;; "Creates a directory on the specified volume, if possible. If this constitutes the first Lisp directory on the disk, creates the local disk device to run this directory (and any subsequent ones). If smashDirectory, it will smash any old Lisp directory on the volume.") (WITH.MONITOR \LFtopMonitor (PROG ((vol (\LFEntryPoint volName NIL T)) markerPage) (if (NOT (\PFPilotVolumeP vol)) then (ERROR "Non-pilot volume")) (if smashDirectory then (\LFPurgeDirectory vol)) (if (\LFDirectoryP vol) then (ERROR "Directory already created")) (UNINTERRUPTABLY (if [NOT (type? LFDEV (\GETDEVICEFROMNAME 'DSK] then (\LFCreateDevice)) (if (type? LFDEV (\GETDEVICEFROMNAME 'DSK)) then (\LFMakeVolumeDirectory vol) else (\LFMakeVolumeDirectory vol T) (\LFOpenDevice))) (\PFDsplyVolumes)) (PACKFILENAME.STRING 'HOST 'DSK 'DIRECTORY (U-CASE volName)))]) (PURGEDSKDIRECTORY [LAMBDA (volName dontDeleteFiles) (* hdj " 5-Jun-86 12:54") (* ;;; "Purges the Lisp directory on the specified volume. If this is the last valid Lisp directory on the disk, shuts down the local disk device.") (WITH.MONITOR \LFtopMonitor [PROG ((vol (\LFEntryPoint volName NIL T)) (diskDevice (\GETDEVICEFROMHOSTNAME 'DSK)) device) (if (NOT (\PFPilotVolumeP vol)) then (ERROR "Non-pilot volume")) (UNINTERRUPTABLY (* ;; "Close all files open on that directory") (for S in (\DEVICE-OPEN-STREAMS diskDevice) when (AND (type? DLIONSTREAM S) (EQ (fetch (DLIONSTREAM VOLUME) of S) vol)) do (printout PROMPTWINDOW T "Closing " (CLOSEF S))) (* ;; "Delete all files on that directory.") [if (NOT dontDeleteFiles) then (for F in (FILDIR (PACKFILENAME 'HOST 'DSK 'DIRECTORY (fetch (LogicalVolumeDescriptor LVlabel) of vol))) do (printout PROMPTWINDOW T "Deleting " (DELFILE F] (* ;; "Remove the directory") (\LFPurgeDirectory vol) (* ;; "If this was the last Lisp directory, replace the dandelion disk diskDevice with a coredevice. Actually, all you need to do is kill the dlion disk diskDevice and VANILLADISK will take care of the rest") (OR (\LFFindDirectoryVol) (\LFCloseDevice)))])]) (LISPDIRECTORYP [LAMBDA (volumeName) (* amd "10-Feb-86 16:04") (* ;;; "Returns T if volumeName has a valid Lisp directory on it, NIL otherwise.") (WITH.MONITOR \LFtopMonitor (SELECTQ (MACHINETYPE) ((DANDELION DOVE) [PROG ((vol (\LFEntryPoint volumeName NIL T))) (RETURN (NOT (NOT (AND vol (\LFDirectoryP vol]) NIL))]) (VOLUMES [LAMBDA NIL (* amd "10-Feb-86 16:04") (* ;;; "Returns a list of the names of the logical volumes on this machine.") (SELECTQ (MACHINETYPE) ((DANDELION DOVE) (\LFEntryPoint NIL T) [for vol in (\PFGetVols) collect (MKATOM (U-CASE (fetch ( LogicalVolumeDescriptor LVlabel) of vol]) NIL]) (VOLUMESIZE [LAMBDA (volName recompute) (* amd "10-Feb-86 16:04") (* ;;; "Returns the size of the specified volume.") (PROG ((vol (\LFEntryPoint volName))) (RETURN (fetch (LogicalVolumeDescriptor volumeSize) of vol]) ) (DEFINEQ (\DFSCurrentVolume [LAMBDA NIL (* hts%: "13-Feb-85 22:47") (* ;;; "Returns as an atom the name of the volume which contains the currently running virtual memory. Called by DISKPARTITION.") (\LFEntryPoint NIL T) (MKATOM (U-CASE (fetch (LogicalVolumeDescriptor LVlabel) of (\PFCurrentVol]) (\DFSFreeDiskPages [LAMBDA (volName recompute) (* amd "10-Feb-86 16:04") (* ;;; "Returns the number of free pages left on the specified volume. Called by DISKFREEPAGES.") (WITH.MONITOR \LFtopMonitor (PROG ((vol (\LFEntryPoint volName))) (RETURN (\PFFreeDiskPages vol recompute))))]) ) (DEFINEQ (\LFEntryPoint [LAMBDA (volName noVolName dontDefault) (* ; "Edited 8-Jan-87 17:49 by amd") (* ;; "Run at every entry point to the file system. Makes sure everything is set up ok, and makes all entry points share some common code.") (OR (ATOM volName) (STRINGP volName) (\ILLEGAL.ARG volName)) (SELECTQ (MACHINETYPE) ((DANDELION DOVE) NIL) (ERROR "Wrong machinetype")) (\PFEnsureInitialized) (if (NOT (\PFVersionOK)) then (ERROR "Wrong Pilot version on disk")) (if (NOT noVolName) then (PROG [(vol (OR (\PFGetLVPage (\LFNormalizeVolumeName volName)) (AND (NOT volName) (NOT dontDefault) (\LFFindDirectoryVol NIL] (if (NULL vol) then (ERROR "Volume not on local disk")) (RETURN vol]) (\LFNormalizeVolumeName [LAMBDA (volName) (* amd "10-Feb-86 18:14") (* ;;; "If the volume name given is a valid one, returns that; else assumes it is a full file name of some sort, and extracts the volume name from it.") (if (STRPOS "{" volName) then (fetch (PARSEDFILENAME VOL) of (\LFParseFileName volName)) else volName]) ) (* ;; "Device management") (DEFINEQ (\LFCreateDevice [LAMBDA NIL (* hdj "25-Sep-86 13:22") (* ;;; "Creates and remembers the local hard disk file device, but does not open the device or any of its associated directories.") (if (AND (BOUNDP '\LFdevice) (type? LFDEV \LFdevice)) then \LFdevice else (SETQ \LFdevice (\MAKE.PMAP.DEVICE (create FDEV NODIRECTORIES _ T DEVICENAME _ 'DSK CLOSEFILE _ (FUNCTION \LFCloseFile) DELETEFILE _ (FUNCTION \LFDeleteFile) RENAMEFILE _ (FUNCTION \LFRenameFile) TRUNCATEFILE _ (FUNCTION \LFTruncateFile) GETFILEINFO _ (FUNCTION \LFGetFileInfo) GETFILENAME _ (FUNCTION \LFGetFileName) OPENFILE _ (FUNCTION \LFOpenFile) READPAGES _ (FUNCTION \LFReadPages) SETFILEINFO _ (FUNCTION \LFSetFileInfo) WRITEPAGES _ (FUNCTION \LFWritePages) REOPENFILE _ (FUNCTION \LFOpenFile) GENERATEFILES _ (FUNCTION \LFGenerateFiles) EVENTFN _ (FUNCTION \LFEventFn) DIRECTORYNAMEP _ (FUNCTION \LFDirectoryNameP ) HOSTNAMEP _ (FUNCTION NILL) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM ]) (\LFOpenDevice [LAMBDA NIL (* amd "10-Feb-86 18:03") (* ;;; "Opens the local hard disk file system device and returns it if it can be opened; otherwise returns NIL. Device can be opened iff Pilot version is OK and there is at least one valid Lisp directory of the appropriate version on the disk.") (WITH.MONITOR \LFtopMonitor (SELECTQ (MACHINETYPE) ((DANDELION DOVE) (\PFEnsureInitialized) (AND (\PFVersionOK) (for VOL in (\PFGetVols) thereis (\LFCloseDirectory VOL) (AND (\LFDirectoryP VOL))) (\GETDEVICEFROMNAME (\DEFINEDEVICE 'DSK \LFdevice)))) NIL))]) (\LFCloseDevice [LAMBDA NIL (* amd "10-Feb-86 18:04") (* * comment) (WITH.MONITOR \LFtopMonitor (\PFEnsureInitialized T) (\REMOVEDEVICE \LFdevice) (AND (\PFVersionOK) (for VOL in (\PFGetVols) do (\LFCloseDirectory VOL))) NIL)]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LFdevice \LFtopMonitor \LFrunSize) ) (\LFCreateDevice) (RPAQ? \LFtopMonitor (CREATE.MONITORLOCK 'topMonitor)) (RPAQ? \LFrunSize 20) (* ;; "Device methods") (DEFINEQ (\LFOpenFile [LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 21-Aug-88 14:17 by bvm") (* ;; "Open a file.") (LET [(STREAM (WITH.MONITOR \LFtopMonitor (PROG (DATE STREAM IDATE) (* ;; "Normalize creationdate. User can supply a bad creationdate. If normalization is done at a lower level in uninterruptable code, and if IDATE signals an error, the result will be a 9318 crash rather than an error break.") [if (SETQ DATE (OR (FASSOC 'CREATIONDATE OTHERINFO) (FASSOC 'ICREATIONDATE OTHERINFO))) then (SETQ OTHERINFO (CONS [CONS 'CREATIONDATE (OR [SETQ IDATE (if (EQ (CAR DATE) 'CREATIONDATE) then (IDATE (CADR DATE)) else (FIXP (CADR DATE] (\ILLEGAL.ARG (CADR DATE] (REMOVE DATE OTHERINFO] (* ;; "Force everything through GetStreamForFile to (even if it was already a stream) to force the file system to check the directory and rebuild the stream and all info cached in it.") (if (type? DLIONSTREAM FILE) then (SETQ FILE (fetch (DLIONSTREAM FULLFILENAME) of FILE))) (SETQ STREAM (\LFGetStreamForFile FILE RECOG ACCESS (NEQ ACCESS 'INPUT) OTHERINFO OLDSTREAM)) (* ;;  "If GetStreamForFile returned something other than a stream, there was some error; abort.") (if (NOT (type? DLIONSTREAM STREAM)) then (RETURN STREAM)) (if (NOT OLDSTREAM) then (* ; "Don't do this for REOPENFILE") (if (EQ ACCESS 'OUTPUT) then (* ; "File is EMPTY even if it is old") (replace EPAGE of STREAM with (replace EOFFSET of STREAM with 0))) (\LFUpdateLeaderPage STREAM (AND (NOT (FMEMB 'DON'T.CHANGE.DATE OTHERINFO)) ACCESS) IDATE) (* ; "Update access dates.") (if IDATE then (* ;  "Don't be tempted to change it if other things change") (replace NONDEFAULTDATEFLG of STREAM with T))) (* ;; "Set the validation field to be the creation date") (replace (DLIONSTREAM VALIDATION) of STREAM with (fetch (LeaderPage TimeCreate) of (fetch (DLIONSTREAM LEADERPAGE) of STREAM))) (* ;; "Return the stream you've just built.") (RETURN STREAM)))] (COND ((type? DLIONSTREAM STREAM) STREAM) ((NULL STREAM) NIL) ((TYPEP STREAM 'CONDITION) (CL:ERROR STREAM)) (T (CL:ERROR STREAM :PATHNAME FILE]) (\LFGetStreamForFile [LAMBDA (NAME RECOG ACCESS CREATEFLG OTHERINFO OLDSTREAM) (* ; "Edited 20-Aug-88 17:43 by bvm") (* ;; "Creates a STREAM for dsk file NAME, creating it if necessary when CREATEFLG is true.") (PROG ((FILESPEC (\LFFileSpec NAME RECOG)) (volNum NIL) (DIRPTR NIL)) (RETURN (COND ((NULL FILESPEC) (* ;;  "If the file does not have a valid file specification, don't create a stream; just return NIL.") NIL) [(SETQ DIRPTR (fetch (DFSFileSpec FSDIRPTR) of FILESPEC)) (* ;; "If the directory code found a pointer into the directory, then the file already exists; just open it up") (LET [(FULLNAME (\LFFullFileName (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC] (if (AND (NULL OLDSTREAM) (\FILE-CONFLICT FULLNAME ACCESS \LFdevice)) then (* ;  "Busy. Don't check from REOPENFILE") (MAKE-CONDITION 'XCL:FILE-WONT-OPEN :PATHNAME FULLNAME) else (\LFOpenOldFile (create FileDescriptor fileID _ (\LFReadFileID [\LFGetDirectory (SETQ volNum (fetch (ExpandedName VOLNUM ) of (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC] DIRPTR) volNum _ volNum type _ tLispFile) FULLNAME DIRPTR] ((NULL (fetch (ExpandedName VERSION) of (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC))) NIL) ((IGREATERP (fetch (ExpandedName VERSION) of (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC)) MAX.SMALLP) (printout PROMPTWINDOW T "Version number too high") 'XCL:FS-RESOURCES-EXCEEDED) (CREATEFLG (\LFCreateFile (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC) OTHERINFO]) (\LFOpenOldFile [LAMBDA (fileDesc fullFileName directoryPointer) (* ; "Edited 20-Aug-88 18:05 by bvm") (* ;; "Open an old (existing) file and return the resultant stream") (LET* ((leaderPage (create LeaderPage)) (STREAM (create DLIONSTREAM FULLFILENAME _ fullFileName FILEDESC _ fileDesc DIRINFO _ directoryPointer DEVICE _ \LFdevice LEADERPAGE _ leaderPage)) SIZE LASTPAGE OFFSET) (* ;; "Use the volume file map to find out what size the file is; record this in the stream you are building.") (SETQ SIZE (\PFFindFileSize fileDesc)) (replace (FileDescriptor size) of fileDesc with SIZE) (* ;; "Read in the leader page for the file. The leader page has stream-level eof information on it. It also has backing file length info on it. If this latter matches the length found from the vfm, then believe the leader page and use its eof info for the stream; else, the leader page is probably screwed up, so just make the stream's eof be the entire backing file. (This means you won't lose any info, but might gain about half a page of nulls.)") (\PFGetPage fileDesc 0 (\PFFindPageAddr fileDesc 0) leaderPage) (if (EQL (fetch (LeaderPage AllocatedPages) of leaderPage) SIZE) then (SETQ LASTPAGE (fetch EofPage of leaderPage)) (SETQ OFFSET (fetch EOffSet of leaderPage)) else (SETQ LASTPAGE (SUB1 SIZE)) (SETQ OFFSET BYTESPERPAGE)) (replace (DLIONSTREAM EPAGE) of STREAM with LASTPAGE) (replace (DLIONSTREAM EOFFSET) of STREAM with OFFSET) (* ;; "Finally return the stream you've just built") STREAM]) (\LFGenFileID [LAMBDA (vol) (* amd "10-Feb-86 16:04") (* ;;; "Generates and returns a new file ID and updates the ID count for the logical volume") (add (fetch (LogicalVolumeDescriptor lastIDAllocated) of vol) 1]) (\LFCreateFile [LAMBDA (fileName info) (* ; "Edited 20-Aug-88 17:37 by bvm") (* ;; "fileName: UNAME, pages: FIXP (estimated length of file; currently not taken advantage of), info: PLIST") (* ;; "Creates a file by allocating the pages for it and returning a stream to it.") (UNINTERRUPTABLY (PROG ((vol (\PFGetVol (fetch (ExpandedName VOLNUM) of fileName))) stream DIRINDEX) (SETQ stream (create DLIONSTREAM FULLFILENAME _ (\LFFullFileName fileName) FILEDESC _ (create FileDescriptor fileID _ (\LFGenFileID vol) volNum _ (\PFVolumeNumber vol) type _ tLispFile) DEVICE _ \LFdevice)) (* ;; "Make sure there's enough space for the directory entry.") (if [NULL (SETQ DIRINDEX (\LFFindDirHole stream fileName (\LFGetDirectory vol] then (RETURN 'XCL:FS-RESOURCES-EXCEEDED)) (* ;; "Allocate pages for file; this will update size field of FileDescriptor") (if (NULL (\PFNewPages vol (fetch (DLIONSTREAM FILEDESC) of stream) (create PageGroup filePage _ 0 volumePage _ 0 nextFilePage _ \LFrunSize))) then (RETURN 'XCL:FS-RESOURCES-EXCEEDED)) (* ;; "Create leader page for the new file and put it and cache it") (replace (DLIONSTREAM LEADERPAGE) of stream with (\LFMakeLeaderPage (fetch (DLIONSTREAM FILEDESC) of stream) (\LFFileName fileName ) info)) (* ;; "Enter the new file in the directory") (\LFMakeDirEntry stream fileName (\LFGetDirectory vol) DIRINDEX) (RETURN stream)))]) (\LFMakeLeaderPage [LAMBDA (file fileName Info) (* ; "Edited 16-Apr-87 17:55 by jop") (* ;; "Make, put, and return leader page for file") (DECLARE (GLOBALVARS DEFAULTFILETYPE)) (PROG ((TYPE (OR (CADR (FASSOC 'TYPE Info)) DEFAULTFILETYPE)) (CurrentTime (OR (FIXP (CADR (FASSOC 'CREATIONDATE Info))) (IDATE))) (Author (OR (CADR (FASSOC 'AUTHOR Info)) (USERNAME))) (LeaderPage (create LeaderPage))) (replace (LeaderPage TYPE) of LeaderPage with TYPE) (replace (LeaderPage TimeCreate) of LeaderPage with CurrentTime) (replace (LeaderPage TimeWrite) of LeaderPage with CurrentTime) (replace (LeaderPage FileID) of LeaderPage with (fetch (FileDescriptor fileID) of file)) (replace (LeaderPage AllocatedPages) of LeaderPage with (fetch ( FileDescriptor size) of file)) (replace (LeaderPage EofPage) of LeaderPage with 0) (replace (LeaderPage EOffSet) of LeaderPage with 0) (replace (LeaderPage fileName) of LeaderPage with fileName) (replace (LeaderPage author) of LeaderPage with Author) (replace (LeaderPage version) of LeaderPage with lispFileVersion) (\PFPutPage file 0 (\PFFindPageAddr file 0) LeaderPage) (RETURN LeaderPage]) (\LFUpdateLeaderPage [LAMBDA (stream access createDate) (* ; "Edited 20-Aug-88 17:59 by bvm") (UNINTERRUPTABLY (PROG [(leaderPage (fetch (DLIONSTREAM LEADERPAGE) of stream)) (time (AND access (DAYTIME] (* ;; "Update end of file info") (replace (LeaderPage EofPage) of leaderPage with (fetch (STREAM EPAGE) of stream)) (replace (LeaderPage EOffSet) of leaderPage with (fetch (STREAM EOFFSET ) of stream)) (* ;; "Update info saying how many pages have been allocated to the file") (replace (LeaderPage AllocatedPages) of leaderPage with (fetch (FileDescriptor size) of (fetch (DLIONSTREAM FILEDESC) of stream))) (* ;; "Update access times") (SELECTQ access ((OUTPUT BOTH APPEND) (replace (LeaderPage TimeWrite) of leaderPage with time) (replace (LeaderPage TimeCreate) of leaderPage with (OR createDate (SETQ createDate time))) (replace (DLIONSTREAM VALIDATION) of stream with createDate)) NIL) (SELECTQ access ((INPUT BOTH) (replace (LeaderPage TimeRead) of leaderPage with time)) NIL) (* ;; "and write out the refreshed leader page") (\LFWriteLeaderPage stream)))]) (\LFWriteLeaderPage [LAMBDA (stream) (* hts%: " 5-Jan-85 16:15") (PROG ((vol (fetch (DLIONSTREAM VOLUME) of stream)) (fileDesc (fetch (DLIONSTREAM FILEDESC) of stream))) (\PFPutPage fileDesc 0 (\PFFindPageAddr fileDesc 0) (fetch (DLIONSTREAM LEADERPAGE) of stream]) ) (DEFINEQ (\LFCloseFile [LAMBDA (STREAM) (* hdj "25-Sep-86 13:43") (* ;;; "Closes the specified stream.") (WITH.MONITOR \LFtopMonitor (* ;;; "Write out and dispense with buffers for this stream.") (\CLEARMAP STREAM) (if (NEQ (fetch ACCESS of STREAM) 'INPUT) then (* ;;; "Update the stream eof info, trim the backing file so that it is just big enough to hold the stream, and record all the eof info on the stream's leader page. Minimum backing file length for the stream is computed as follows: 1 page for leader page; 1 page because stream pages (in particular EPAGE) are numbered from 0, not 1; EPAGE of stream pages; less 1 page if the EOFFSET is 0") (UNINTERRUPTABLY (\LFTruncateFile STREAM) (\PFTrimHelper (fetch (DLIONSTREAM VOLUME) of STREAM) (fetch (DLIONSTREAM FILEDESC) of STREAM) (PLUS 1 1 (fetch EPAGE of STREAM) (if (EQ (fetch EOFFSET of STREAM) 0) then -1 else 0))) (\LFUpdateLeaderPage STREAM))) (\PFSaveBuffers (fetch (DLIONSTREAM VOLUME) of STREAM)) STREAM)]) ) (DEFINEQ (\LFDeleteFile [LAMBDA (fileName dev) (* hdj "23-Jun-86 16:47") (WITH.MONITOR \LFtopMonitor (PROG ((stream (\LFGetStreamForFile fileName 'OLDEST 'BOTH NIL NIL))) (DECLARE (GLOBALVARS \OPENFILES)) (if (OR (NOT (type? DLIONSTREAM stream)) (FDEVOP 'OPENP dev (fetch FULLFILENAME of stream) NIL dev)) then (RETURN)) (UNINTERRUPTABLY (\LFRemoveDirEntry stream (\LFGetDirectory (fetch (DLIONSTREAM VOLUME) of stream))) (* ;; "Take the entire file out of the BTree and out of the allocation map") (\PFTrimHelper (fetch (DLIONSTREAM VOLUME) of stream) (fetch (DLIONSTREAM FILEDESC) of stream) 0) (* ;; "save buffers") (\PFSaveBuffers (fetch (DLIONSTREAM VOLUME) of stream))) (RETURN (fetch (DLIONSTREAM FULLFILENAME) of stream))))]) ) (DEFINEQ (\LFReadPages [LAMBDA (stream streamFirstPage buffers) (* ; "Edited 22-Oct-87 16:03 by amd") (* ;;  "Reads a bunch of pages from stream, starting at firstPage. Returns number of bytes read.") (* ;; "Modified ' 4-Jul-85 04:47:22' by HTS to extend the backing file whenever it tries to read past the end of the backing file. This generally ensures that data subsequently written on these buffer pages will not be lost if you run out of disk space") (* ;; "If asked to read a page which is off the end of the stream, it will zero the page. Odd though it may seem, reading off the end of the file is reasonable behavior for copybytes: buffer pages must come from somewhere, and copybytes may not have to write the whole page, and in general copybytes does not know whether a page is actually in a file or off the end of it. Seems inefficient, but since reading past eof does not actually require disk access, its not that bad.") (* ;; "Extend backing file if necessary to accomodate buffers.") (\LFExtendFileIfNecessary stream streamFirstPage buffers) (* ;; "Write out the buffers to the backing file.") (for buffer inside buffers as streamPageNumber from streamFirstPage as backingFilePageNumber from (ADD1 streamFirstPage) bind (file _ (fetch (DLIONSTREAM FILEDESC) of stream)) lastStreamPage offset first (\UPDATEOF stream) (SETQ lastStreamPage (PLUS (fetch (DLIONSTREAM EPAGE) of stream) (if (CL:ZEROP (fetch (DLIONSTREAM EOFFSET) of stream)) then -1 else 0))) sum (if (ILEQ streamPageNumber lastStreamPage) then (* ;;  "If page inside stream, then it has presumably already been written; read it in.") (\PFGetPage file backingFilePageNumber (\PFFindPageAddr file backingFilePageNumber) buffer) (* ;;  "If this was the last page in the file, then fill in the trailing bytes with nulls.") (if (EQL streamPageNumber lastStreamPage) then (SETQ offset (fetch (DLIONSTREAM EOFFSET) of stream)) (if (CL:ZEROP offset) then (SETQ offset BYTESPERPAGE) else (\CLEARBYTES buffer offset (DIFFERENCE BYTESPERPAGE offset))) offset else BYTESPERPAGE) else (* ;; "If this was outside the stream, clear the buffer.") (\CLEARWORDS buffer WORDSPERPAGE) 0]) ) (DEFINEQ (\LFWritePages [LAMBDA (stream streamFirstPage buffers) (* ; "Edited 16-Apr-87 16:08 by jop") (* ;; "Writes a bunch of pages to stream, starting at streamFirstPage") (* ;; "Extend backing file if necessary to accomodate buffers.") (if (fetch (STREAM REVALIDATEFLG) of stream) then (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write. Otherwise, it is possible to see a change to the file but no change to the creationdate") (\LFUpdateLeaderPage stream 'OUTPUT) (replace (STREAM REVALIDATEFLG) of stream with NIL)) (\LFExtendFileIfNecessary stream streamFirstPage buffers) (* ;; "Write out the buffers to the backing file.") (for buffer inside buffers as backingFilePageNumber from (ADD1 streamFirstPage) bind (file _ (fetch (DLIONSTREAM FILEDESC) of stream)) do (\PFPutPage file backingFilePageNumber (\PFFindPageAddr file backingFilePageNumber) buffer)) NIL]) (\LFExtendFileIfNecessary [LAMBDA (stream streamFirstPage buffers) (* hts%: "13-Aug-85 14:21") (* ;;; "Extends the backing file for stream to make space for buffers. Must not be called from uninterruptable or monitorlocked code. Causes a continuable error if there are not enough free pages for the extension.") (PROG ((runLength (if (NLISTP buffers) then 1 else (LENGTH buffers))) minBackingFileSize) (* ;; "Backing file (Pilot file) enumeration starts with leader page of file, Lisp stream page enumeration does not include the leader page; hence the first 1.0 Pages are enumerated from 0 but size is enumerated from 1; hence the second 1.0") (SETQ minBackingFileSize (PLUS 1 1 streamFirstPage (SUB1 runLength))) (* ;; "Extend backing file if necessary.") (until (WITH.MONITOR \LFtopMonitor (if (GREATERP minBackingFileSize (fetch (FileDescriptor size) of (fetch (DLIONSTREAM FILEDESC) of stream))) then (\LFExtendFile stream minBackingFileSize) else T)) do (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" (fetch (DLIONSTREAM FULLFILENAME) of stream) T]) (\LFExtendFile [LAMBDA (stream minBackingFileSize) (* hts%: "13-Aug-85 13:07") (* ;;; "Extends the backing file for stream so that its backing file is at least minBackingFileSize.") (PROG ((vol (fetch (DLIONSTREAM VOLUME) of stream)) (fileDesc (fetch (DLIONSTREAM FILEDESC) of stream))) (UNINTERRUPTABLY (OR [\PFNewPages vol fileDesc (create PageGroup filePage _ (fetch (FileDescriptor size) of fileDesc) volumePage _ 0 nextFilePage _ (MAX minBackingFileSize (IPLUS (fetch (FileDescriptor size) of fileDesc) \LFrunSize] (RETURN NIL)) (\UPDATEOF stream) (\LFUpdateLeaderPage stream)) (RETURN stream]) ) (DEFINEQ (\LFGetFileInfo [LAMBDA (stream attribute device) (* ; "Edited 20-Aug-88 17:19 by bvm") (* ;;; "Get the value of the attribute for a file. If stream is a filename, then the file is not open. If stream is a STREAM, then it is open and has valid information in it.") (WITH.MONITOR \LFtopMonitor [AND [OR (type? DLIONSTREAM stream) (type? DLIONSTREAM (SETQ stream (\LFGetStreamForFile stream 'OLD 'INPUT NIL NIL] (PROG ((infoPage (fetch (DLIONSTREAM LEADERPAGE) of stream))) (RETURN (SELECTQ attribute (LENGTH (\UPDATEOF stream) (IPLUS (ITIMES (fetch (STREAM EPAGE) of stream) BYTESPERPAGE) (fetch (STREAM EOFFSET) of stream))) (SIZE (\UPDATEOF stream) (IPLUS (fetch (STREAM EPAGE) of stream) (FOLDHI (fetch (STREAM EOFFSET) of stream) BYTESPERPAGE))) (TYPE (fetch (LeaderPage TYPE) of infoPage)) (WRITEDATE (GDATE (fetch (LeaderPage TimeWrite) of infoPage))) (READDATE (GDATE (fetch (LeaderPage TimeRead) of infoPage))) (CREATIONDATE (GDATE (fetch (LeaderPage TimeCreate) of infoPage ))) (IWRITEDATE (fetch (LeaderPage TimeWrite) of infoPage)) (IREADDATE (fetch (LeaderPage TimeRead) of infoPage)) (ICREATIONDATE (fetch (LeaderPage TimeCreate) of infoPage)) (AUTHOR (fetch (LeaderPage author) of infoPage)) NIL])]) (\LFSetFileInfo [LAMBDA (stream attribute value dev) (* ; "Edited 20-Aug-88 17:18 by bvm") (WITH.MONITOR \LFtopMonitor [AND [OR (type? DLIONSTREAM stream) (type? DLIONSTREAM (SETQ stream (\LFGetStreamForFile stream 'OLD 'INPUT NIL NIL] (PROG ((infoPage (fetch (DLIONSTREAM LEADERPAGE) of stream))) (RETURN (if (SELECTQ attribute (TYPE (replace (LeaderPage TYPE) of infoPage with value)) (CREATIONDATE (replace (LeaderPage TimeCreate) of infoPage with (OR (IDATE value) (\ILLEGAL.ARG value)))) (ICREATIONDATE (replace (LeaderPage TimeCreate) of infoPage with value)) NIL) then (\LFUpdateLeaderPage stream) T])]) ) (DEFINEQ (\LFGetFileName [LAMBDA (FileName Recog Dev) (* amd "10-Feb-86 16:04") (* ;;; "Maps a filename onto a fully specified filename if it exists, or onto NIL if it doesn't exist.") (WITH.MONITOR \LFtopMonitor [LET ((fileSpec (\LFFileSpec FileName Recog))) (AND fileSpec (\LFFullFileName (fetch (DFSFileSpec EXPANDEDNAME) of fileSpec ])]) ) (DEFINEQ (\LFEventFn [LAMBDA (Dev Event) (* ; "Edited 13-Sep-88 16:38 by hayata") (* ;; "Determines dliondisk fdev behaviour across major system events. Must make the file system wake up properly on different machines, or even on the same machine with a different disk partitioning.") (WITH.MONITOR \LFtopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\LFCloseDevice) (\PFEnsureInitialized T) (* ; "force reinitialization") (\LFOpenDevice) (* ; "reopen if possible") [if (DEFINEDP 'DSKDISPLAY) then (DSKDISPLAY (DSKDISPLAY 'CLOSED] (* ;  "handle the DSKDISPLAY window, if there is one") (* ;; "If on an alien machine, make sure you won't attempt to reopen files. Note that if you're still on a dlion or dove, the reopenfile method will not break, but will simply return NIL if the file isn't there (e.g. if someone deleted it since this Lisp image was last run, or if the disk changed).") (SELECTQ (MACHINETYPE) ((DANDELION DOVE) NIL) (LET NIL (replace (FDEV REOPENFILE) of Dev with (FUNCTION NILL)) (\REMOVEDEVICE Dev))) (* ;; "revalidate open streams (should probably move this into the SELECTQ above)") (\PAGED.REVALIDATEFILELST Dev)) ((BEFORELOGOUT BEFORESYSOUT BEFOREMAKESYS BEFORESAVEVM) (* ;;  "BVM claims you should flush open streams associated with this device only before logout") (if (EQ Event 'BEFORELOGOUT) then (\FLUSH.OPEN.STREAMS Dev)) (for vol in (\PFGetVols) when (\LFDirectoryP vol) do (* ; "flush output buffers.") (\PFSaveBuffers vol))) NIL))]) ) (DEFINEQ (\LFDirectoryNameP [LAMBDA (DirSpec) (* amd "10-Feb-86 16:04") (* ;;; "Implements the DIRECTORYNAMEP method for the dlionfs. If DirSpec is a reasonable directory specification, returns the canonical form of that directory; otherwise returns NIL") (* ;;; "DirSpec (a) must parse correctly, (b) must have a proper directory associated with it, and (c) might have a subdirectory nestled in it.") (WITH.MONITOR \LFtopMonitor [LET (PARSED DIR SUBDIREND) (AND (SETQ PARSED (\LFParseFileName DirSpec)) (SETQ DIR (\LFFindDirectoryVol (fetch (PARSEDFILENAME VOL) of PARSED))) (PACKFILENAME.STRING 'HOST 'DSK 'DIRECTORY (U-CASE (fetch ( LogicalVolumeDescriptor LVlabel) of DIR)) 'NAME (AND (SETQ SUBDIREND (FIXP (LASTCHPOS (CHARCODE >) (fetch (PARSEDFILENAME NAME) of PARSED) 1))) (U-CASE (SUBSTRING (fetch (PARSEDFILENAME NAME) of PARSED) 1 SUBDIREND])]) ) (DEFINEQ (\LFTruncateFile [LAMBDA (STREAM PAGE# OFFSET) (* amd "10-Feb-86 16:04") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") (* ;; "Normalize arguments") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (DLIONSTREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (DLIONSTREAM EOFFSET) of STREAM))) (* ;; "If lengthening stream, pad it with nulls.") (UNINTERRUPTABLY (PROG ((FILEPTR (\GETFILEPTR STREAM)) [curEof (PLUS (TIMES (fetch (DLIONSTREAM EPAGE) of STREAM) BYTESPERPAGE) (TIMES (fetch (DLIONSTREAM EOFFSET) of STREAM] (curPages (fetch (LeaderPage AllocatedPages) of (fetch (DLIONSTREAM LEADERPAGE) of STREAM))) (needPages (IQUOTIENT (DIFFERENCE (PLUS (ITIMES (PLUS PAGE# 1) BYTESPERPAGE) OFFSET BYTESPERPAGE) 1) BYTESPERPAGE))) (if (IGREATERP needPages curPages) then (\LFExtendFile STREAM needPages)) (\SETFILEPTR STREAM curEof) (to (DIFFERENCE (PLUS (TIMES PAGE# BYTESPERPAGE) OFFSET) curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR))) (* ;; "Record the new file length") (replace (DLIONSTREAM EPAGE) of STREAM with PAGE#) (replace (DLIONSTREAM EOFFSET) of STREAM with OFFSET) (\LFUpdateLeaderPage STREAM) (\PFSaveBuffers (fetch (DLIONSTREAM VOLUME) of STREAM)) NIL]) ) (DEFINEQ (\LFRenameFile [LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 20-Feb-87 17:59 by amd") (if (NEQ OLD-DEVICE NEW-DEVICE) then (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) else (* ;; "The following test should be in the generic rename function. How come it's here? [bvm: Generic system isn't supposed to know. However, this recognize hack is silly. You should check whether the file is open AFTER you call \LFFileSpec and have obtained its full name, so that you don't have to do recognition twice (in \recognize-hack and \LFFileSpec).]") (if (NOT (FDEVOP 'OPENP OLD-DEVICE (\RECOGNIZE-HACK OLD-NAME 'OLD OLD-DEVICE) NIL OLD-DEVICE)) then (CL:WHEN [NULL (fetch (DFSFileSpec FSDIRPTR) of (\LFFileSpec OLD-NAME 'OLD] (LISPERROR "FILE NOT FOUND" OLD-NAME)) (PROG [[dir (\LFFindDirectory (CADR (\LFParseFileName OLD-NAME] (FILESPEC (\LFFileSpec NEW-NAME 'NEW] (if [EQ dir (\LFFindDirectory (CADR (\LFParseFileName NEW-NAME] then (WITH.MONITOR \LFtopMonitor (LET* ((stream (\LFGetStreamForFile OLD-NAME 'OLD)) (oldPtr (fetch (DLIONSTREAM DIRINFO) of stream)) (newPtr (\LFFindDirHole stream (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC) dir))) (SETQ NEW-NAME (\LFFullFileName (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC))) (if (NULL newPtr) then (SETQ OLD-NAME "FILE SYSTEM RESOURCES EXCEEDED") else (\LFMakeDirEntry stream (fetch (DFSFileSpec EXPANDEDNAME) of FILESPEC) dir newPtr) (replace (DLIONSTREAM DIRINFO) of stream with oldPtr) (\LFRemoveDirEntry stream dir) (replace (DLIONSTREAM DIRINFO) of stream with newPtr) (replace (DLIONSTREAM FULLFILENAME) of stream with NEW-NAME) (replace (LeaderPage fileName) of (fetch (DLIONSTREAM LEADERPAGE) of stream) with (\LFFileName (  \LFUnpackName NEW-NAME))) (replace (LeaderPage TimeWrite) of (fetch (DLIONSTREAM LEADERPAGE) of stream) with (DAYTIME)) (\LFWriteLeaderPage stream)))) (if (EQUAL OLD-NAME "FILE SYSTEM RESOURCES EXCEEDED") then (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" NEW-NAME T) else (RETURN NEW-NAME)) else (RETURN (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME]) ) (RPAQQ LFDIRECTORYCOMS [ (* ;;; "This module handles the Lisp directory part of the file system. The Lisp directory maps literal file names onto Pilot file ID numbers (which can then be looked up in the volume file map). This module used to be in the file LFDIRECTORY.") (* ;; "Known problem: the directory is currently stored as a list rather than a tree, so searches in a large directory take quite some time.") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (directorySize 50)) (RECORDS GenerateFileState GeneratedFile DIRSEARCHSTATE PARSEDFILENAME ExpandedName DFSFileSpec) (MACROS CONDCONCAT) (MACROS PRINTDIRECTORY)) (* ;; "Format of a directory entry is : ") (* ;; "bang (check ; should always contain !) ") (* ;; "type (0 = hole, 1 = file) ") (* ;; "entryLength ") (* ;; "fileID (4 bytes) ") (* ;; "version# (2 bytes) ") (* ;; "filenameLength ") (* ;; "filename (filenameLength bytes)") (* ;; "Routines for mapping file names onto volumes and directories") (FNS \LFFindDirectory \LFFindDirectoryVol \LFParseFileName) (* ;; "Creating and opening directories") (FNS \LFMakeVolumeDirectory \LFDirectoryP \LFPurgeDirectory \LFCloseDirectory) (* ;;  "Functions for making, deleting, and finding entries in a directory.") (FNS \LFMakeDirEntry \LFRemoveDirEntry \LFReadFileID \LFFindDirHole \LFMakeDirHole \LFCheckBang) (FNS \LFDirectorySearch \LFVersions) (FNS \LFFileSpec \LFUnpackName \LFFullFileName \LFFileName) (FNS \LFDirectoryScrambled) (FNS \LFDWIN \LFDWOUT) (* ;; "Directory enumeration") (FNS \LFGenerateFiles \LFFindNextFile \LFSortFiles \LFHighestVersions \LFFindInfo \LFReturnNextFile \LFReturnInfo) (GLOBALVARS \LFtopMonitor) (* ;; "Holding onto directory streams") (FNS \LFGetDirectory \LFPutDirectory \LFCreateDirectories) (GLOBALVARS \LFdirectories) (P (\LFCreateDirectories)) (* ;; "Case array manipulation") (FNS \LFINITCASEARRAY \LFCASEARRAYFETCH) (GLOBALVARS \LFCASEARRAY \DISKNAMECASEARRAY) (INITVARS (\LFCASEARRAY (\LFINITCASEARRAY]) (* ;;; "This module handles the Lisp directory part of the file system. The Lisp directory maps literal file names onto Pilot file ID numbers (which can then be looked up in the volume file map). This module used to be in the file LFDIRECTORY." ) (* ;; "Known problem: the directory is currently stored as a list rather than a tree, so searches in a large directory take quite some time." ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ directorySize 50) (CONSTANTS (directorySize 50)) ) (DECLARE%: EVAL@COMPILE (TYPERECORD GenerateFileState (CURRENTFILE RESTOFFILES ATTRIBUTES)) (TYPERECORD GeneratedFile (FULLNAME NAME VERSION INFO)) (TYPERECORD DIRSEARCHSTATE (DIRPTR CHARLIST)) (TYPERECORD PARSEDFILENAME (VOL NAME VERSION)) (TYPERECORD ExpandedName (VOLNUM CHARLIST VERSION) (* VERSION is the version indicator (either a positive integer or one of OLD,  OLDEST, NEW) -  VOLNUM is the logical volume number, -  and the CHARLIST is a list of characters in the name.) ) (TYPERECORD DFSFileSpec (EXPANDEDNAME FSDIRPTR)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS CONDCONCAT MACRO (ARGS `(CONCATLIST (for STR in %, (CONS 'LIST ARGS) when STR collect STR] ) (DECLARE%: EVAL@COMPILE [PUTPROPS PRINTDIRECTORY MACRO (LAMBDA (STREAM) (* hts%: " 6-Aug-85 12:19") (* * Prints the contents of a Lisp directory --  for debugging.) (SETFILEPTR (\DTEST STREAM 'STREAM) 0) (bind TYPE LENGTH START until (\EOFP STREAM) do (SETQ START (GETFILEPTR STREAM)) (\LFCheckBang STREAM) (SETQ TYPE (BIN STREAM)) (SETQ LENGTH (BIN STREAM)) (if (EQ TYPE 1) then (printout NIL (\WIN STREAM) " " (\WIN STREAM) " " (\WIN STREAM) " " (PACKC (to (BIN STREAM) collect (BIN STREAM))) T)) (SETFILEPTR STREAM (PLUS START (TIMES LENGTH BYTESPERWORD] ) ) (* ;; "Format of a directory entry is : ") (* ;; "bang (check ; should always contain !) ") (* ;; "type (0 = hole, 1 = file) ") (* ;; "entryLength ") (* ;; "fileID (4 bytes) ") (* ;; "version# (2 bytes) ") (* ;; "filenameLength ") (* ;; "filename (filenameLength bytes)") (* ;; "Routines for mapping file names onto volumes and directories") (DEFINEQ (\LFFindDirectory [LAMBDA (VOL) (* amd "10-Feb-86 16:04") (* ;;; "Maps a volume name, descriptor, or number onto the directory stream for that volume. If the volume name is NIL, finds the default directory stream. Opens the directory if it is not already open. If there is no appropriate directory stream, returns NIL.") (SETQ VOL (\LFFindDirectoryVol VOL)) (AND VOL (\LFDirectoryP VOL]) (\LFFindDirectoryVol [LAMBDA (VOL) (* amd "10-Feb-86 16:04") (* ;;; "Maps a volume name, descriptor, or number into the descriptor for that volume provided the volume has a proper Lisp directory on it. If VOL is NIL, finds the descriptor of the volume containing the default Lisp directory. If there is no appropriate volume, returns NIL.") (if VOL then (* ;; "Normalize argument") (COND ((type? LogicalVolumeDescriptor VOL)) ((FIXP VOL) (SETQ VOL (\PFGetVol VOL))) ((OR (ATOM VOL) (STRINGP VOL)) (SETQ VOL (\PFGetLVPage VOL))) (T (SHOULDNT))) (* ;; "Tell whether the specified volume has a proper Lisp directory on it.") (AND VOL (\LFDirectoryP VOL) VOL) else (* ;; "Find the descriptor for the volume with the default Lisp directory on it.") (PROG ((volumes (\PFGetVols)) (currentVol (\PFCurrentVol)) nextVolumes defaultVol) [SETQ nextVolumes (for vols on volumes do (if (EQ currentVol (CAR vols)) then (RETURN (APPEND vols volumes] (RETURN (for vol in nextVolumes thereis (\LFDirectoryP vol]) (\LFParseFileName [LAMBDA (FULLNAME) (* ; "Edited 22-Oct-87 16:06 by amd") (* ;; "Returns the parse of a filename") (PROG (DIRECTORY NAME EXT VERSION ENDVOLNAME) (if (for TAIL on (UNPACKFILENAME.STRING FULLNAME) by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST NIL) (DIRECTORY (SETQ DIRECTORY (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (SETQ VERSION (CADR TAIL))) (RETURN T))) then (RETURN)) (SETQ ENDVOLNAME (STRPOS ">" DIRECTORY)) (RETURN (create PARSEDFILENAME VOL _ [AND DIRECTORY (SUBSTRING DIRECTORY 1 (AND ENDVOLNAME (SUB1 ENDVOLNAME ] NAME _ (CONDCONCAT (AND ENDVOLNAME (SUBSTRING DIRECTORY (ADD1 ENDVOLNAME))) (AND ENDVOLNAME ">") NAME "." EXT) VERSION _ (if (CL:ZEROP (NCHARS VERSION)) then NIL else (MKATOM VERSION]) ) (* ;; "Creating and opening directories") (DEFINEQ (\LFMakeVolumeDirectory [LAMBDA (vol DONTOPEN) (* ; "Edited 9-Jan-87 19:01 by amd") (* ;; "Creates a Lisp directory for vol") (UNINTERRUPTABLY (PROG ((directoryID (\LFGenFileID vol)) file) (* ;; "Allocate and record pages for the directory file") (SETQ file (create FileDescriptor fileID _ directoryID volNum _ (\PFVolumeNumber vol) type _ tLispDirectory size _ 0)) (OR (\PFNewPages vol file (create PageGroup filePage _ 0 volumePage _ 0 nextFilePage _ directorySize)) (DiskError "FILE SYSTEM RESOURCES EXCEEDED")) (\PFSaveBuffers vol) (* ;;  "Make and put a leader page for the directory file; dlionstream created here is just a throwaway") (\LFMakeLeaderPage file (PACKFILENAME.STRING 'NAME 'DIRECTORY 'VERSION 1) NIL) (* ;; "Put pointer to this directory in the volume root directory") (\PFInsertDirectoryID vol tLispDirectory directoryID)) (* ;; "Open up the new directory") (if DONTOPEN then NIL else (\LFDirectoryP vol)))]) (\LFDirectoryP [LAMBDA (vol) (* ; "Edited 22-Oct-87 16:07 by amd") (* ;; "If there is a valid Lisp directory on volume vol, opens it (if it isn't already open) and returns it; otherwise returns NIL. For there to be a valid directory, the volume must be a Pilot volume, there must be a root directory on it with a Lisp directory entry, there must be an openable Lisp directory file, and the leader page of that file must have the correct file system version number on it.") (PROG (directoryID stream) (RETURN (OR (AND (type? DLIONSTREAM (\LFGetDirectory vol)) (\LFGetDirectory vol)) (AND (\PFPilotVolumeP vol) (SETQ directoryID (\PFFindDirectoryID vol tLispDirectory)) (SETQ stream (\LFOpenOldFile (create FileDescriptor fileID _ (\PFFindDirectoryID vol tLispDirectory) volNum _ (\PFVolumeNumber vol) type _ tLispDirectory) (PACKFILENAME 'NAME 'DIRECTORY 'VERSION 1) NIL)) (EQL (fetch (LeaderPage version) of (fetch (DLIONSTREAM LEADERPAGE) of stream)) lispFileVersion) (PROGN (replace ACCESS of stream with 'BOTH) (replace MAXBUFFERS of stream with MAX.SMALLP) (\OPENFILE stream) (\LFPutDirectory vol stream]) (\LFPurgeDirectory [LAMBDA (vol) (* amd "10-Feb-86 16:04") (* ;; "CLose the directory if it is open") (\LFCloseDirectory vol) (* ;; "Take directory off disk if it is there") (PROG ((directoryID (\PFFindDirectoryID vol tLispDirectory)) file) (if directoryID then (\PFRemoveDirectoryID vol tLispDirectory) (SETQ file (create FileDescriptor fileID _ directoryID volNum _ (\PFVolumeNumber vol) type _ tLispDirectory)) (replace (FileDescriptor size) of file with (\PFFindFileSize file)) (\PFTrimHelper vol file 0]) (\LFCloseDirectory [LAMBDA (vol) (* amd "10-Feb-86 16:04") (* ;;; "Remove internal record of directory") (if (\LFGetDirectory vol) then (FORGETPAGES (\LFGetDirectory vol)) (\LFPutDirectory vol NIL]) ) (* ;; "Functions for making, deleting, and finding entries in a directory.") (DEFINEQ (\LFMakeDirEntry [LAMBDA (stream UNAME DirStream POS) (* ; "Edited 22-Oct-87 16:08 by amd") (* ;; "Makes a directory entry for a new file") (PROG ((NC (LENGTH (fetch (ExpandedName CHARLIST) of UNAME))) SIZE) (* ;; "SIZE is how big the directory entry must be. The 10 is 1 byte !, 1 byte type, 1 byte entry length, 4 bytes fileID, 2 bytes version, 1 byte string length (for filename)") (SETQ SIZE (IPLUS NC 10)) (* ;; "Check entry and move to fileID field") (\SETFILEPTR DirStream POS) (\LFCheckBang DirStream) (OR (CL:ZEROP (\BIN DirStream)) (\LFDirectoryScrambled DirStream)) (OR (IGEQ (\BIN DirStream) SIZE) (\LFDirectoryScrambled DirStream)) (UNINTERRUPTABLY (* ;; "Write out fileID") (\LFDWOUT DirStream (fetch (FileDescriptor fileID) of (fetch (DLIONSTREAM FILEDESC) of stream))) (* ;; "Write out version number") (\WOUT DirStream (fetch (ExpandedName VERSION) of UNAME)) (* ;; "Write out filename preceded by number of chars in it (ie, as a bcpl string)") (\BOUT DirStream NC) (for C in (fetch (ExpandedName CHARLIST) of UNAME) do (\BOUT DirStream C)) (* ;; "When everything is ready, finally change the type from hole to file") (\SETFILEPTR DirStream (ADD1 POS)) (\BOUT DirStream 1)) (* ;; "Remember where file is in directory") (replace (DLIONSTREAM DIRINFO) of stream with POS) (* ;; "Write changes to directory file out to disk") (FORCEOUTPUT DirStream]) (\LFRemoveDirEntry [LAMBDA (stream dirStream) (* ; "Edited 22-Oct-87 16:09 by amd") (* ;; "Change type of dir entry to hole and write changed directory pages out to disk") (UNINTERRUPTABLY (\SETFILEPTR dirStream (fetch (DLIONSTREAM DIRINFO) of stream)) (\LFCheckBang dirStream) (\BOUT dirStream 0)) (* ;; "Merge with following hole, if there is one") (UNINTERRUPTABLY [PROG ((ENTRYSIZE (\BIN dirStream)) NEWENTRYSIZE) (\SETFILEPTR dirStream (PLUS (fetch (DLIONSTREAM DIRINFO) of stream) ENTRYSIZE)) (if (NOT (\EOFP dirStream)) then (\LFCheckBang dirStream) (if (CL:ZEROP (\BIN dirStream)) then (SETQ NEWENTRYSIZE (PLUS ENTRYSIZE (\BIN dirStream))) (\SETFILEPTR dirStream (IPLUS (fetch (DLIONSTREAM DIRINFO) of stream) 2)) (if (ILESSP NEWENTRYSIZE 256) then (\BOUT dirStream NEWENTRYSIZE]) (* ;; "Force the altered directory out to disk") (FORCEOUTPUT dirStream]) (\LFReadFileID [LAMBDA (directory position) (* hts%: "11-Jan-85 02:05") (* ;;; "Returns the file ID recorded in the entry beginning at position") (\SETFILEPTR directory position) (* ;; "bang") (\LFCheckBang directory) (* ;; "Make sure its not a hole") (if (NEQ (BIN directory) 1) then (\LFDirectoryScrambled)) (* ;; "Entry length") (\BIN directory) (* ;; "Finally read in the file id") (\LFDWIN directory]) (\LFFindDirHole [LAMBDA (STREAM UNAME DIRSTREAM) (* ; "Edited 22-Oct-87 16:18 by amd") (* ;; "Finds or creates a hole in the directory large enough to fit the entry represented by UNAME. Returns the byte address of the hole if sucessful, NIL otherwise. BYTES is how big the entry must be. The 10 is 1 byte !, 1 byte type, 1 byte entry length, 4 bytes fileID, 2 bytes version, 1 byte string length (for filename)") (bind [BYTES _ (IPLUS 10 (LENGTH (fetch (ExpandedName CHARLIST) of UNAME] (PTR _ (OR (fetch (DLIONSTREAM DIRHOLEPTR) of DIRSTREAM) 0)) ENTRYLENGTH TYPE do (\SETFILEPTR DIRSTREAM PTR) (if (\EOFP DIRSTREAM) then (* ;; "Make a new entry at the end of the file") (RETURN (if (\LFMakeDirHole DIRSTREAM PTR BYTES) then PTR else NIL)) else (\LFCheckBang DIRSTREAM) (SETQ TYPE (\BIN DIRSTREAM)) (SETQ ENTRYLENGTH (\BIN DIRSTREAM)) (if (AND (CL:ZEROP TYPE) (ILEQ BYTES ENTRYLENGTH)) then (* ;; "Entry big enough") (if (IGEQ ENTRYLENGTH (PLUS BYTES 14)) then (* ;; "Too large, so break it apart. (Too large if there is room for another entry with filename of 3 or more chars.)") (UNINTERRUPTABLY (\LFMakeDirHole DIRSTREAM (PLUS PTR BYTES) (DIFFERENCE ENTRYLENGTH BYTES)) (\LFMakeDirHole DIRSTREAM PTR BYTES))) (RETURN PTR))) (SETQ PTR (IPLUS PTR ENTRYLENGTH]) (\LFMakeDirHole [LAMBDA (DIRSTREAM WHERE HOLESIZE) (* ; "Edited 22-Oct-87 16:20 by amd") (* ;; "Makes an empty slot in the directory; this slot will soon be used to hold a directory entry. Returns DIRSTREAM if successful, NIL otherwise.") (PROG [(DIRSIZE (fetch (FileDescriptor size) of (fetch (DLIONSTREAM FILEDESC) of DIRSTREAM] (* ;; "Extends the directory if necessary.") (if (ILEQ (TIMES BYTESPERPAGE (SUB1 DIRSIZE)) (IPLUS WHERE HOLESIZE)) then (if (NULL (\LFExtendFile DIRSTREAM (ADD1 DIRSIZE))) then (RETURN NIL))) (UNINTERRUPTABLY (\SETFILEPTR DIRSTREAM WHERE) (* ;; "Mark beginning of entry") (\BOUT DIRSTREAM (CHARCODE !)) (* ;; "Mark as hole") (\BOUT DIRSTREAM 0) (* ;; "Note size of hole") (\BOUT DIRSTREAM HOLESIZE) (* ;; "Pad rest with nulls.") (to (IDIFFERENCE HOLESIZE 3) do (\BOUT DIRSTREAM 0))) (* ;; "Flush to disk.") (FORCEOUTPUT DIRSTREAM) (RETURN DIRSTREAM]) (\LFCheckBang [LAMBDA (DIRSTREAM) (* amd "10-Feb-86 16:04") (* * comment) (OR (EQ (BIN DIRSTREAM) (CHARCODE !)) (\LFDirectoryScrambled DIRSTREAM]) ) (DEFINEQ (\LFDirectorySearch [LAMBDA (DIRSTREAM TLIST HMIN KINDOFMATCH) (* ; "Edited 22-Oct-87 16:21 by amd") (* ;; "Finds next directory entry for which (CDR TLIST) is a prefix of the filename. Returns NIL if no entry found, else the length of the remaining chars in the entry. Leaves the directory positioned after the char matching the last char of TLIST::1 --- DIRSTREAM is the ofd of the directory file --- TLIST is a list of the form (POS . CHARPAIRS), where POS at entry is a fileptr in the directory file at which to start searching and CHARPAIRS is like the characters pairs of a uname. At exit, TLIST is smashed so that POS is the fileptr just beyond the found entry. --- if HMIN~=NIL, sets STREAM's DIRHOLEPTR to NIL or the fileptr of the first hole of at least HMIN words.") (bind (MATCH _ NIL) (NEXT _ (fetch (DIRSEARCHSTATE DIRPTR) of TLIST)) (CHARLIST _ (fetch (DIRSEARCHSTATE CHARLIST) of TLIST)) THISNAMELENGTH TARGETLENGTH PTR TYP ENTRYLENGTH FILEID VERSION first (if HMIN then (replace (DLIONSTREAM DIRHOLEPTR) of DIRSTREAM with NIL)) (SETQ TARGETLENGTH (LENGTH CHARLIST)) until MATCH do (\SETFILEPTR DIRSTREAM (SETQ PTR NEXT)) (if (\EOFP DIRSTREAM) then (RETURN)) (* ;; "Format of a directory entry is --- bang (check ; should always contain !) --- type (0 = hole, 1 = file) --- entryLength --- fileID (4 bytes) --- version# (2 bytes) --- filenameLength --- filename (filenameLength bytes)") (\LFCheckBang DIRSTREAM) (SETQ TYP (\BIN DIRSTREAM)) (SETQ ENTRYLENGTH (\BIN DIRSTREAM)) (SETQ NEXT (IPLUS PTR ENTRYLENGTH)) [if (CL:ZEROP TYP) then (* ;; "Not a file; if hole is of right length etc., cache its position") (if (AND HMIN (ILEQ HMIN ENTRYLENGTH)) then (replace (DLIONSTREAM DIRHOLEPTR) of DIRSTREAM with PTR) (SETQ HMIN NIL)) else (SETQ FILEID (\LFDWIN DIRSTREAM)) (SETQ VERSION (\WIN DIRSTREAM)) (SETQ THISNAMELENGTH (\BIN DIRSTREAM)) (if (OR (AND (EQ KINDOFMATCH 'EXACT) (EQL THISNAMELENGTH TARGETLENGTH)) (AND (EQ KINDOFMATCH 'PARTIAL) (IGEQ THISNAMELENGTH TARGETLENGTH))) then (SETQ MATCH (for C in CHARLIST always (EQ C (\LFCASEARRAYFETCH (\BIN DIRSTREAM ] finally (* ;; "Leave directory file pointer at beginning of entry") (\SETFILEPTR DIRSTREAM PTR) (* ;; "Remember where next entry is") (replace (DIRSEARCHSTATE DIRPTR) of TLIST with NEXT) (* ;; "Return the number of unmatched chars") (RETURN (IDIFFERENCE THISNAMELENGTH TARGETLENGTH]) (\LFVersions [LAMBDA (UNPACKEDNAME STREAM HMIN) (* ; "Edited 22-Oct-87 16:23 by amd") (* ;; "UNPACKEDNAME is a value of \UNPACKFILENAME. STREAM is the directory ofd. HMIN=T means look for a hole big enough for UNAME, a number N means look for that size hole, NIL means don't look. Returns a list of (version . fileptr) pairs sorted by increasing version. Ptr is a pointer to the beginning of the directory slot for the file.") (bind (TLIST _ (create DIRSEARCHSTATE DIRPTR _ 0 CHARLIST _ (fetch (ExpandedName CHARLIST) of UNPACKEDNAME))) (FIXEDVERSION _ (FIXP (fetch (ExpandedName VERSION) of UNPACKEDNAME))) PTR RESULT version first (OR (NULL FIXEDVERSION) (GREATERP FIXEDVERSION 0) (SETQ FIXEDVERSION NIL)) (if (EQ HMIN T) then (SETQ HMIN 20)) do [if (NULL (\LFDirectorySearch STREAM TLIST HMIN 'EXACT)) then (RETURN (SORT RESULT (FUNCTION (LAMBDA (A B) (LESSP (CAR A) (CAR B] (* ;;  "DirectorySearch leaves directory file ptr at beginning of entry. Record beginning of entry") (SETQ PTR (\GETFILEPTR STREAM)) (* ;; "Read up to version number") (\LFCheckBang STREAM) (* ; "Bang!") (OR (EQL (\BIN STREAM) 1) (\LFDirectoryScrambled)) (* ; "type = file") (\BIN STREAM) (* ; "Entry length") (\LFDWIN STREAM) (* ; "file ID") (* ;; "Read version number") (SETQ version (\WIN STREAM)) (* ;; "Name matches. version is the version number. Cons up a piece of the result. If UNPACKEDNAME has an explicit version, insist on it now") (if FIXEDVERSION then [if (EQL version FIXEDVERSION) then (RETURN (LIST (CONS version PTR] else (* ;; "Merge new element into RESULT") (push RESULT (CONS version PTR))) (* ;; "Stop looking if found a hole") (if (AND HMIN (fetch (DLIONSTREAM DIRHOLEPTR) of STREAM)) then (SETQ HMIN NIL]) ) (DEFINEQ (\LFFileSpec [LAMBDA (NAME RECOG) (* ; "Edited 20-Oct-87 12:34 by amd") (* ;; "This returns a full file specification, with all the information needed to do open, delete, etc. A filespec is a (packedname unpackedname dirptr) triple, with the true version number smashed into the uname. The dirptr is NIL if the file does not currently exist in the directory.") (PROG (dirPtr version versionList (UNPACKEDNAME (\LFUnpackName NAME)) DIRSTREAM) (* ;; "If name didn't unpack properly, return NIL") (OR UNPACKEDNAME (RETURN)) (* ;; "If there is no directory for the specified name, return NIL") (OR DIRSTREAM (SETQ DIRSTREAM (\LFFindDirectory (fetch (ExpandedName VOLNUM) of UNPACKEDNAME))) (RETURN)) (* ;; "Build file specification") [COND ([AND (SETQ versionList (\LFVersions UNPACKEDNAME DIRSTREAM (SELECTQ RECOG ((NEW OLD/NEW) T) NIL))) (SETQ version (SELECTQ (OR (fetch (ExpandedName VERSION) of UNPACKEDNAME) RECOG) ((OLD OLD/NEW) (CAR (LAST versionList))) (NEW (* ;  "A new version, so the DIRPTR is NIL") [LIST (ADD1 (CAAR (LAST versionList]) (OLDEST (CAR versionList)) (ASSOC (fetch (ExpandedName VERSION) of UNPACKEDNAME) versionList] (SETQ dirPtr (CDR version)) (SETQ version (CAR version))) (T (SETQ dirPtr NIL) (* ;  "Since file doesnt exist, recognition mode takes precedence over version number") (SETQ version (SELECTQ (OR RECOG (fetch (ExpandedName VERSION) of UNPACKEDNAME )) ((NEW OLD/NEW) (OR (FIXP (fetch (ExpandedName VERSION) of UNPACKEDNAME )) 1)) ((OLD OLDEST) NIL) (FIXP (fetch (ExpandedName VERSION) of UNPACKEDNAME] (* ;  "We may have to zap a version number that was specified but not found") (replace (ExpandedName VERSION) of UNPACKEDNAME with version) (RETURN (create DFSFileSpec EXPANDEDNAME _ UNPACKEDNAME FSDIRPTR _ dirPtr]) (\LFUnpackName [LAMBDA (name) (* ; "Edited 20-Oct-87 12:34 by amd") (* ;; "Unpacks file name into a UNAME of the form ((VERSION . VOLNUM) . CHARLIST) where VERSION is the version indicator (either a positive integer or one of OLD, OLDEST, NEW) VOLNUM is the logical volume number, and the CHARLIST is a list of characters in the name. Returns NIL if the given name is not valid.") (PROG ((PARSEDNAME (\LFParseFileName name)) VOL charList version) (OR PARSEDNAME (RETURN)) (SETQ VOL (\LFFindDirectoryVol (fetch (PARSEDFILENAME VOL) of PARSEDNAME))) (OR VOL (RETURN)) (SETQ charList (for char instring (fetch (PARSEDFILENAME NAME) of PARSEDNAME ) collect (* ; "check for illegal chars") (SETQ char (\LFCASEARRAYFETCH char)) (if [FMEMB char (LIST 0 (\LFCASEARRAYFETCH (CHARCODE *) ) (\LFCASEARRAYFETCH (CHARCODE ?] then (RETURN NIL)) char)) (OR charList (RETURN)) (SETQ version (fetch (PARSEDFILENAME VERSION) of PARSEDNAME)) (SETQ version (OR (FIXP version) (SELECTQ version (H 'OLD) (L 'OLDEST) (N 'NEW) NIL))) (RETURN (create ExpandedName VOLNUM _ (\PFVolumeNumber VOL) CHARLIST _ charList VERSION _ version]) (\LFFullFileName [LAMBDA (UNPACKEDNAME) (* amd "10-Feb-86 16:04") (* ;;; "Puts together a full file name (including host, directory, subdirectory, name, and version) from a uname") (AND (fetch (ExpandedName VERSION) of UNPACKEDNAME) (PACKFILENAME 'HOST 'DSK 'DIRECTORY [U-CASE (fetch (LogicalVolumeDescriptor LVlabel) of (\PFGetVol (fetch ( ExpandedName VOLNUM) of UNPACKEDNAME] 'NAME (\LFFileName UNPACKEDNAME]) (\LFFileName [LAMBDA (UNPACKEDNAME) (* amd "10-Feb-86 16:04") (* ;;; "Puts together the subdirectory, filename, and version of a file from its uname") (PROG ((CHARLIST (fetch (ExpandedName CHARLIST) of UNPACKEDNAME)) (VERSION (CHCON (OR (FIXP (fetch (ExpandedName VERSION) of UNPACKEDNAME)) 1))) CHARLISTLENGTH NAME) (SETQ CHARLISTLENGTH (LENGTH CHARLIST)) [SETQ NAME (ALLOCSTRING (PLUS CHARLISTLENGTH 1 (LENGTH VERSION] (for I from 1 as CHAR in CHARLIST do (RPLCHARCODE NAME I CHAR)) (RPLCHARCODE NAME (ADD1 CHARLISTLENGTH) (CHARCODE ;)) (for I from (PLUS CHARLISTLENGTH 2) as CHAR in VERSION do (RPLCHARCODE NAME I CHAR)) (RETURN NAME]) ) (DEFINEQ (\LFDirectoryScrambled [LAMBDA (DIRSTREAM) (* hts%: "16-Jan-85 17:01") (* * comment) (printout PROMPTWINDOW "Local directory scrambled: " T [PACKFILENAME.STRING 'HOST 'DSK 'DIRECTORY (U-CASE (fetch ( LogicalVolumeDescriptor LVlabel) of (fetch (DLIONSTREAM VOLUME) of DIRSTREAM] T "Try scavenging the directory.") (DiskError "HARD DISK ERROR"]) ) (DEFINEQ (\LFDWIN [LAMBDA (FILE) (* jds " 3-JAN-83 16:08") (IPLUS (LLSH (\BIN FILE) 24) (LLSH (\BIN FILE) 16) (LLSH (\BIN FILE) 8) (\BIN FILE]) (\LFDWOUT [LAMBDA (FILE NUMBER) (* jds " 3-JAN-83 15:30") (\BOUT FILE (LOGAND 255 (LRSH NUMBER 24))) (\BOUT FILE (LOGAND 255 (LRSH NUMBER 16))) (\BOUT FILE (LOGAND 255 (LRSH NUMBER 8))) (\BOUT FILE (LOGAND 255 NUMBER]) ) (* ;; "Directory enumeration") (DEFINEQ (\LFGenerateFiles [LAMBDA (FDEV PATTERN DESIREDPROPS) (* ; "Edited 22-Oct-87 16:25 by amd") (* ;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR \LFtopMonitor [PROG (PARSED DIRECTORYSTREAM SEARCHSTATE GENFILTER HOST&DIRNAME NEXTFILE FILELIST) [SETQ PARSED (OR (\LFParseFileName PATTERN) (RETURN (\NULLFILEGENERATOR] [SETQ DIRECTORYSTREAM (OR (\LFFindDirectory (fetch (PARSEDFILENAME VOL) of PARSED)) (RETURN (\NULLFILEGENERATOR] (SETQ SEARCHSTATE (create DIRSEARCHSTATE DIRPTR _ 0 CHARLIST _ (for C instring (fetch (PARSEDFILENAME NAME) of PARSED) until (SELCHARQ (SETQ C (\LFCASEARRAYFETCH C)) ((%# *) (* ;; "\LFDirectorySearch currently only checks prefixes, so we truncate at the first * or escape. Also ignore version specifications,") T) NIL) collect C))) [SETQ GENFILTER (DIRECTORY.MATCH.SETUP (CONDCONCAT (fetch (PARSEDFILENAME NAME) of PARSED) ";" (fetch (PARSEDFILENAME VERSION) of PARSED] [SETQ HOST&DIRNAME (PACKFILENAME.STRING 'HOST 'DSK 'DIRECTORY (U-CASE (fetch (LogicalVolumeDescriptor LVlabel) of (fetch (DLIONSTREAM VOLUME) of DIRECTORYSTREAM] (* ;; "Generate a list of all the files that match the spec.") (while (SETQ NEXTFILE (\LFFindNextFile DIRECTORYSTREAM SEARCHSTATE GENFILTER HOST&DIRNAME)) do (push FILELIST NEXTFILE)) (* ;; "Sort the list of files. Not all directory enumeration requests require sorting, but almost all do, so I just sort them all for simplicity.") (\LFSortFiles FILELIST) (* ;; "Highest version enumeration: if the pattern does not have a version, then should return only the highest version of each file. \LFHighestVersions requires that the file list be sorted first.") (if (OR (CL:ZEROP (NCHARS (fetch (PARSEDFILENAME VERSION) of PARSED))) (NULL (fetch (PARSEDFILENAME VERSION) of PARSED))) then (SETQ FILELIST (\LFHighestVersions FILELIST))) (* ;; "Dig up any file info that the caller has indicated he will request. (During the enumeration, the user can ask for any of the file properties in DESIREDPROPS.) This is done here and stored (rather than later when it is actually requested) to avoid the problem of a file having been deleted by another process before its properties could be dug up. Here that is safe, since this is being done under the top-level file system monitorlock.") (\LFFindInfo FILELIST DESIREDPROPS DIRECTORYSTREAM) (* ;; "Finally return the file generator object.") (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \LFReturnNextFile) FILEINFOFN _ (FUNCTION \LFReturnInfo) GENFILESTATE _ (create GenerateFileState CURRENTFILE _ NIL RESTOFFILES _ FILELIST ATTRIBUTES _ DESIREDPROPS])]) (\LFFindNextFile [LAMBDA (directory SEARCHSTATE FILTER HOST&DIRNAME) (* amd "10-Feb-86 16:04") (* ;;; "Finds the next file in directory that matches the specified filter, and returns its name, version, directory position, etc., if there is one.") (bind (ANOTHERENTRY _ NIL) ENTRYSTART VERSION FILENAME CHARS NAMELEN do (SETQ ANOTHERENTRY (\LFDirectorySearch directory SEARCHSTATE NIL 'PARTIAL)) [if ANOTHERENTRY then (* ;;  "\LFDirectorySearch leaves directory file ptr at beginning of entry. Read name and version.") (SETQ ENTRYSTART (\GETFILEPTR directory)) (\LFCheckBang directory) (* ; "bang") (OR (EQ (\BIN directory) 1) (\LFDirectoryScrambled)) (* ; "type") (\BIN directory) (* ; "entry length") (\LFDWIN directory) (* ; "file ID") (SETQ VERSION (\WIN directory)) (* ; "version") (SETQ NAMELEN (\BIN directory)) (SETQ CHARS (to NAMELEN collect (\BIN directory))) (* ; "name") (* ;; "Construct the name of the file") (SETQ FILENAME (\LFFileName (create ExpandedName CHARLIST _ CHARS VERSION _ VERSION] repeatuntil (OR (NOT ANOTHERENTRY) (NOT FILTER) (DIRECTORY.MATCH FILTER FILENAME)) finally (RETURN (if ANOTHERENTRY then (create GeneratedFile FULLNAME _ (CONCAT HOST&DIRNAME FILENAME) NAME _ (SUBSTRING FILENAME 1 NAMELEN) VERSION _ VERSION INFO _ ENTRYSTART) else NIL]) (\LFSortFiles [LAMBDA (FILES) (* amd "10-Feb-86 18:52") (* ;;; "Sorts the list of generated files. Not all requests for directory enumeration require that the files be sorted, but most do, so I just sort them all. Note that in comparing names, you must not compare the version part of the name (hence the SUBSTRING stuff), since ALPHORDER does not get versions in the right order.") [SORT FILES (FUNCTION (LAMBDA (A B) (SELECTQ (UALPHORDER (fetch (GeneratedFile NAME) of A) (fetch (GeneratedFile NAME) of B)) (LESSP T) (EQUAL (LESSP (fetch (GeneratedFile VERSION) of A) (fetch (GeneratedFile VERSION) of B))) NIL] NIL]) (\LFHighestVersions [LAMBDA (FILELIST) (* amd "10-Feb-86 16:04") (* ;;; "Extracts the highest version files from a list of sorted files.") (for FILES on FILELIST when [NOT (AND (LISTP (CDR FILES)) (type? GeneratedFile (CADR FILES)) (STREQUAL (fetch (GeneratedFile NAME) of (CAR FILES)) (fetch (GeneratedFile NAME) of (CADR FILES] collect (CAR FILES]) (\LFFindInfo [LAMBDA (FILES PROPS DIRECTORY) (* amd "10-Feb-86 16:04") (* ;;; "Digs up any file info that the caller has indicated he will request. (During the enumeration, the user can ask for any of the file properties in DESIREDPROPS.) This is done here and stored (rather than later when it is actually requested) to avoid the problem of a file having been deleted by another process before its properties could be dug up. Here that is safe, since this is being done under the top-level file system monitorlock. This info is later read and returned to the user by \LFReturnInfo.") (if (LISTP PROPS) then (bind ENTRYSTART STREAM (BACKWARDPROPS _ (REVERSE PROPS)) for FILE in FILES do (* ;; "Build a stream for the current file; this stream will be used and reused for getting the file attributes. Kind of a weird entry to the OpenFile stuff, but that's because you already have your finger on the directory entry and don't have to bother looking it up again.") (SETQ ENTRYSTART (fetch (GeneratedFile INFO) of FILE)) (replace (GeneratedFile INFO) of FILE with NIL) (SETQ STREAM (\LFOpenOldFile (create FileDescriptor fileID _ (\LFReadFileID DIRECTORY ENTRYSTART) volNum _ (fetch (FileDescriptor volNum) of (fetch (DLIONSTREAM FILEDESC ) of DIRECTORY)) type _ tLispFile) NIL ENTRYSTART)) (replace ACCESS of STREAM with 'INPUT) (* ;; "Now get all the info and save it.") (for ATTRIBUTE in BACKWARDPROPS do (push (fetch (GeneratedFile INFO) of FILE) (GETFILEINFO STREAM ATTRIBUTE]) (\LFReturnNextFile [LAMBDA (GENERATED) (* amd "10-Feb-86 16:04") (* * comment) (if (NULL (fetch (GenerateFileState RESTOFFILES) of GENERATED)) then NIL else (replace (GenerateFileState CURRENTFILE) of GENERATED with (pop (fetch (GenerateFileState RESTOFFILES) of GENERATED))) (fetch (GeneratedFile FULLNAME) of (fetch (GenerateFileState CURRENTFILE) of GENERATED]) (\LFReturnInfo [LAMBDA (GENERATED PROP) (* ; "Edited 20-Aug-88 17:23 by bvm") (* * comment) (for ATTRIB in (fetch (GenerateFileState ATTRIBUTES) of GENERATED) as INFOVAL in (fetch (GeneratedFile INFO) of (fetch (GenerateFileState CURRENTFILE) of GENERATED)) do (if (EQ ATTRIB PROP) then (RETURN INFOVAL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LFtopMonitor) ) (* ;; "Holding onto directory streams") (DEFINEQ (\LFGetDirectory [LAMBDA (vol) (* hts%: " 5-Jan-85 15:49") (ELT \LFdirectories (OR (FIXP vol) (\PFVolumeNumber vol]) (\LFPutDirectory [LAMBDA (vol directory) (* amd "10-Feb-86 16:04") (SETA \LFdirectories (OR (FIXP vol) (\PFVolumeNumber vol)) directory]) (\LFCreateDirectories [LAMBDA NIL (* ; "Edited 22-Oct-87 16:26 by amd") (if [NOT (AND (BOUNDP '\LFdirectories) (type? ARRAYP \LFdirectories) (ZEROP (ARRAYORIG \LFdirectories)) (EQL maxLogicalVolumes (ARRAYSIZE \LFdirectories] then (SETQ \LFdirectories (ARRAY maxLogicalVolumes NIL NIL 0)) (SETQ \PFInitialized NIL)) NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LFdirectories) ) (\LFCreateDirectories) (* ;; "Case array manipulation") (DEFINEQ (\LFINITCASEARRAY [LAMBDA NIL (* ; "Edited 20-Aug-88 18:06 by bvm") (* ;; "\DISKNAMECASEARRAY is a case array set up by mod44io. Unfortunately,it counts > as an illegal filename char, so we need to make a copy with that fixed.") (PROG ((CASEARRAY (COPYARRAY \DISKNAMECASEARRAY))) (\PUTBASEBYTE (fetch (ARRAYP BASE) of CASEARRAY) 27 0) (* ; "ESC") (for C from (CHARCODE "!") to (CHARCODE "9") do (\PUTBASEBYTE (fetch (ARRAYP BASE) of CASEARRAY) C C)) (for C from (CHARCODE "<") to (CHARCODE "`") do (\PUTBASEBYTE (fetch (ARRAYP BASE) of CASEARRAY) C C)) (\PUTBASEBYTE (fetch (ARRAYP BASE) of CASEARRAY) (CHARCODE "|") (CHARCODE "|")) (\PUTBASEBYTE (fetch (ARRAYP BASE) of CASEARRAY) (CHARCODE "~") (CHARCODE "~")) (RETURN CASEARRAY]) (\LFCASEARRAYFETCH [LAMBDA (CHARCODE) (* ; "Edited 20-Oct-87 12:24 by amd") (\GETBASEBYTE (fetch (ARRAYP BASE) of \LFCASEARRAY) CHARCODE]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LFCASEARRAY \DISKNAMECASEARRAY) ) (RPAQ? \LFCASEARRAY (\LFINITCASEARRAY)) (RPAQQ SCAVENGEDSKDIRECTORYCOMS ( (* ;;; "This module contains routines for scavenging the Lisp directory in the event that it should become smashed. It used to be in the file SCAVENGEDSKDIRECTORY.") (* ;; "Directory (LFDIRECTORY) level stuff") (FNS FILENAMEFROMID SCAVENGEDSKDIRECTORY SCAVENGEVOLUME \LFScavFileName \LFScavVersion) (GLOBALVARS \LFtopMonitor) (* ;; "Volume file map (LFFILEMAP) level stuff") (FNS \VFMGenerateFileIDs))) (* ;;; "This module contains routines for scavenging the Lisp directory in the event that it should become smashed. It used to be in the file SCAVENGEDSKDIRECTORY." ) (* ;; "Directory (LFDIRECTORY) level stuff") (DEFINEQ (FILENAMEFROMID [LAMBDA (lowhalf highhalf volumename) (* ; "Edited 5-Feb-88 19:38 by amd") (LET ((stream (\LFFindDirectory volumename)) name) (SETFILEPTR stream 0) (bind start length until (OR name (EOFP stream)) do (SETQ start (GETFILEPTR stream)) (\LFCheckBang stream) [if (AND (EQL (PROG1 (BIN stream) (SETQ length (BIN stream))) 1) (EQL (BIN16 stream) highhalf) (EQL (BIN16 stream) lowhalf)) then (LET ((version (BIN16 stream))) (SETQ name (CONCAT (PACKC (to (BIN stream) collect (BIN stream))) ";" version] (SETFILEPTR stream (PLUS start length))) name]) (SCAVENGEDSKDIRECTORY [LAMBDA (volName SILENT) (* ; "Edited 8-Jan-87 17:55 by amd") (* ;; "If your BTree is intact but your directory is smashed, this routine will scavenge your volume by building a new directory which associates all fileIDs in the BTree with a gensym filename") (WITH.MONITOR \LFtopMonitor [PROG ((vol (\LFEntryPoint volName)) DIRECTORY LISPDIRECTORY LISPFILES) (if (NOT (\PFPilotVolumeP vol)) then (ERROR "Non-pilot volume")) (* ;;  "Find the file ID's of the Lisp directory and all the Lisp files on the specified volume.") (SETQ LISPDIRECTORY (\VFMGenerateFileIDs vol tLispDirectory)) (SETQ LISPFILES (\VFMGenerateFileIDs vol tLispFile)) (* ;; "If there are no Lisp files of any sort on the volume, abort") (if (AND (NULL LISPDIRECTORY) (NULL LISPFILES)) then (RETURN NIL)) (* ;; "This block throws away the old directory and builds a new one. It must be atomic.") (UNINTERRUPTABLY (* ;; "If there is an old directory, get rid of it.") (\LFPurgeDirectory vol) (if (NOT SILENT) then (printout NIL "Deleted old directory." T)) (* ;; "Create a fresh directory") (if (type? LFDEV (\GETDEVICEFROMNAME 'DSK)) then (\LFMakeVolumeDirectory vol) else (\LFMakeVolumeDirectory vol T) (\LFOpenDevice)) (\PFDsplyVolumes) (if (NOT SILENT) then (printout NIL "Created new directory." T)) (* ;;  "For each file in volume file map, enter this fileID into the new directory") (for fileID in LISPFILES do (PROCEED-CASE (PROG ((stream (\LFOpenOldFile (create FileDescriptor fileID _ fileID volNum _ (  \PFVolumeNumber vol) type _ tLispFile) NIL NIL)) DIRINDEX UNAME NAME&VERSION NAME VERSION) (SETQ NAME&VERSION (fetch (LeaderPage fileName) of (fetch (DLIONSTREAM LEADERPAGE) of stream))) (SETQ NAME (\LFScavFileName NAME&VERSION)) (SETQ VERSION (\LFScavVersion NAME&VERSION fileID )) (SETQ UNAME (create ExpandedName VOLNUM _ (\PFVolumeNumber vol) CHARLIST _ NAME VERSION _ VERSION)) (SETQ DIRINDEX (\LFFindDirHole stream UNAME (\LFGetDirectory vol))) (if (NULL DIRINDEX) then (LISPERROR "HARD DISK ERROR" "Can't rebuild directory")) (\LFMakeDirEntry stream UNAME (\LFGetDirectory vol) DIRINDEX) (if (NOT SILENT) then (PRINTOUT NIL "Added " (PACKC NAME) ";" VERSION " to directory." T))) (NIL NIL :REPORT "Skip this file")))) (* ;; "Return the name of the new directory") (RETURN (PACKFILENAME.STRING 'HOST 'DSK 'DIRECTORY (U-CASE (fetch ( LogicalVolumeDescriptor LVlabel) of vol])]) (SCAVENGEVOLUME [LAMBDA (volName) (* hts%: " 4-Jul-85 18:30") (* ;;; "for backward compatibility") (SCAVENGEDSKDIRECTORY volName]) (\LFScavFileName [LAMBDA (NAME&VERSION) (* ; "Edited 22-Oct-87 16:28 by amd") (* ;; "Extract the filename part of NAME&VERSION (ignore version number) and return it as a list of charcode") (PROG ((NAME (for C instring (MKSTRING NAME&VERSION) until (EQL C (CHARCODE ;)) collect C))) (RETURN (if [OR (NULL NAME) (for C in NAME thereis (ZEROP (\LFCASEARRAYFETCH C] then (* ;; "If there is an illegal char in the filename, or the filename is the empty string, gin up a random filename") (CHCON (CONCAT (GENSYM 'TRASHEDFILENAME) ".")) else (* ;; "Otherwise return the filename found") NAME]) (\LFScavVersion [LAMBDA (NAME&VERSION FILEID) (* amd "10-Feb-86 16:04") (* ;;; "Fetch the version number from NAME&VERSION. If it's garbled (ie, isn't a fixp) use the fileID as a version number instead (the fileID will at least give the file a unique version number and so avoid version number clashes)") (OR (SMALLP (FILENAMEFIELD NAME&VERSION 'VERSION)) (SMALLP FILEID) (RAND 1 MAX.SMALLP]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LFtopMonitor) ) (* ;; "Volume file map (LFFILEMAP) level stuff") (DEFINEQ (\VFMGenerateFileIDs [LAMBDA (vol desiredType) (* ; "Edited 22-Oct-87 16:28 by amd") (* ;; "Returns a list of the fileIDs of all the keys in the BTree with type = desiredType") (WITH.MONITOR \VFMmonitor (UNINTERRUPTABLY (\VFMContextSet vol) (bind (currentKey _ (create Key)) until (PROGN (replace (Key filePage) of currentKey with MAX.FIXP) (MESASETQ currentKey (fetch (Interval nextKey) of (\VFMGet currentKey 0)) Key) (EQL (fetch (Key fileID) of currentKey) \VFMmaxID)) when (EQL (fetch (Key type) of currentKey ) desiredType) collect (fetch (Key fileID) of currentKey))))]) ) (RPAQQ LFPILOTFILECOMS ( (* ;;; "This module (together with its two sub-modules, FILEMAP and ALLOCATIONMAP) define the necessary subset of the Pilot file system. This used to be contained in the file LFPILOTFILE.") (* ;; "These functions transfer pages to and from the disk") (FNS \PFGetPhysicalVolumePage) (FNS \PFGetLogicalVolumePage \PFPutLogicalVolumePage) (FNS \PFGetMarkerPage \PFPutMarkerPage) (FNS \PFGetFreePage \PFCreateFreePage) (FNS \PFGetAllocationMapPage \PFPutAllocationMapPage) (FNS \PFGetFileMapPage \PFPutFileMapPage) (FNS \PFGetPage \PFPutPage \PFCreatePage) (FNS \PFTransferFilePage) (FNS \PFTransferPage) [DECLARE%: DONTEVAL@LOAD (P (\LOCKFN '\PFTransferPage] (RESOURCES label) (* ;; "File Descriptor pool for system files") (FNS \PFCreateFileDescriptors \PFInitFileDescriptors) (GLOBALVARS \PFLogicalVolumeFileD \PFMarkerFileD \PFFreeFileD \PFAllocationMapFileD \PFFileMapFileD) (P (\PFCreateFileDescriptors)) (* ;; "Physical volume interface") (FNS \PFCreatePhysicalVolume) (GLOBALVARS \PhysVolumePage) (P (\PFCreatePhysicalVolume)) (* ;; "Interface to logical volumes,") (FNS \PFCreateVols \PFInitializeVols \PFGetVols \PFGetVol \PFVolumeNumber ) (GLOBALVARS \DFSLogicalVolumes \DFSLogicalVolumeHash) (P (\PFCreateVols)) (FNS \PFGetLVPage) (* ;; "Pilot integrity") (FNS \PFVersionOK \PFPilotVolumeP) (* ;; "Pilot initialization") (FNS \PFEnsureInitialized) (GLOBALVARS \PFInitialized) (INITVARS (\PFInitialized NIL) \PFDebugFlag) (P (ADDTOVAR \SYSTEMCACHEVARS \PFInitialized)) (P (\PFEnsureInitialized)) (* ;; "Root directory management") (FNS \PFFindDirectoryID \PFInsertDirectoryID \PFRemoveDirectoryID) (FNS \PFFindRootDirEntry \PFAddRootDirEntry \PFRemoveRootDirEntry \PFFindRootDirEntryNum \PFPatchRootDirEntries) (FNS \PFGetRootDirectory \PFPutRootDirectory \PFCreateRootDirectory \PFPurgeRootDirectory) (FNS \GetRootDirectoryType \PFPutRootDirectoryType) (* ;; "Pilot file management") (FNS \PFNewPages \PFTrimHelper \PFFindPageAddr \PFFindFileSize \PFFreeDiskPages \PFRoomForFile \PFSaveBuffers) (* ;; "Lisp vmem") (FNS \PFCurrentVol) (* ;; "Display stub; real volume display stuff is implemented on a library package called VOLUMEDISPLAY.") (FNS \PFDsplyVolumes))) (* ;;; "This module (together with its two sub-modules, FILEMAP and ALLOCATIONMAP) define the necessary subset of the Pilot file system. This used to be contained in the file LFPILOTFILE." ) (* ;; "These functions transfer pages to and from the disk") (DEFINEQ (\PFGetPhysicalVolumePage [LAMBDA (buffer) (* hts%: " 5-Jan-85 16:14") (\PFTransferPage 0 buffer 'VRR (create Label]) ) (DEFINEQ (\PFGetLogicalVolumePage [LAMBDA (vol frame) (* hts%: "28-Nov-84 16:41") (* * comment) (\PFGetPage (ELT \PFLogicalVolumeFileD (OR (FIXP vol) (\PFVolumeNumber vol))) 0 0 frame]) (\PFPutLogicalVolumePage [LAMBDA (vol frame) (* hts%: "28-Nov-84 16:41") (* * comment) (\PFPutPage (ELT \PFLogicalVolumeFileD (OR (FIXP vol) (\PFVolumeNumber vol))) 0 0 frame]) ) (DEFINEQ (\PFGetMarkerPage [LAMBDA (vol frame) (* hts%: "29-Nov-84 12:26") (* * comment) (OR (FIXP vol) (SETQ vol (\PFVolumeNumber vol))) (\PFGetPage (ELT \PFMarkerFileD vol) (IPLUS (LvBasePageAddr vol) (MarkerPageAddr vol)) (MarkerPageAddr vol) frame]) (\PFPutMarkerPage [LAMBDA (vol frame) (* hts%: "29-Nov-84 12:27") (* * comment) (OR (FIXP vol) (SETQ vol (\PFVolumeNumber vol))) (\PFPutPage (ELT \PFMarkerFileD vol) (IPLUS (LvBasePageAddr vol) (MarkerPageAddr vol)) (MarkerPageAddr vol) frame]) ) (DEFINEQ (\PFGetFreePage [LAMBDA (vol volumePageNumber frame runLength noBreak) (* edited%: " 4-Jul-85 04:34") (* ;;; "Read a free page (or bunch of them) presumably to check their labels.") (\PFGetPage (ELT \PFFreeFileD (OR (FIXP vol) (\PFVolumeNumber vol))) volumePageNumber volumePageNumber frame runLength noBreak]) (\PFCreateFreePage [LAMBDA (vol volumePageNumber frame runLength noBreak) (* edited%: " 3-Jul-85 22:10") (* ;;; "Write a label on a page that says its free") (\PFCreatePage (ELT \PFFreeFileD (OR (FIXP vol) (\PFVolumeNumber vol))) volumePageNumber volumePageNumber frame runLength noBreak]) ) (DEFINEQ (\PFGetAllocationMapPage [LAMBDA (vol volumePageNumber frame) (* hts%: "29-Nov-84 12:39") (* * comment) (\PFGetPage (ELT \PFAllocationMapFileD (OR (FIXP vol) (\PFVolumeNumber vol))) volumePageNumber volumePageNumber frame]) (\PFPutAllocationMapPage [LAMBDA (vol volumePageNumber frame) (* hts%: "29-Nov-84 12:29") (* * comment) (OR (FIXP vol) (SETQ vol (\PFVolumeNumber vol))) (\PFPutPage (ELT \PFAllocationMapFileD vol) volumePageNumber volumePageNumber frame]) ) (DEFINEQ (\PFGetFileMapPage [LAMBDA (vol volumePageNumber frame) (* hts%: "29-Nov-84 12:32") (* * comment) (OR (FIXP vol) (SETQ vol (\PFVolumeNumber vol))) (\PFGetPage (ELT \PFFileMapFileD vol) volumePageNumber volumePageNumber frame]) (\PFPutFileMapPage [LAMBDA (vol volumePageNumber frame) (* hts%: "29-Nov-84 12:32") (* * comment) (OR (FIXP vol) (SETQ vol (\PFVolumeNumber vol))) (\PFPutPage (ELT \PFFileMapFileD vol) volumePageNumber volumePageNumber frame]) ) (DEFINEQ (\PFGetPage [LAMBDA (file filePageNumber volumePageNumber frame runLength noBreak) (* edited%: " 4-Jul-85 03:45") (* ;;; "file: FileDescriptor, filePageNumber: FIXP, volumePageNumber: FIXP, frame: Page") (* ;;; "Reads a page from the disk into frame") (\PFTransferFilePage file filePageNumber volumePageNumber frame 'VVR runLength noBreak]) (\PFPutPage [LAMBDA (file filePageNumber volumePageNumber frame) (* hts%: "28-Nov-84 15:10") (* ;;; "file: FileDescriptor, filePageNumber: FIXP, volumePageNumber: FIXP, frame: Page") (* ;;; "Writes the page in frame onto the disk and checks the label of the disk page") (\PFTransferFilePage file filePageNumber volumePageNumber frame 'VVW]) (\PFCreatePage [LAMBDA (file filePageNumber volumePageNumber frame runLength noBreak) (* edited%: " 3-Jul-85 22:04") (* ;;; "file: FileDescriptor, filePageNumber: FIXP, volumePageNumber: FIXP, frame: Page") (* ;;; "Writes the page in frame onto the disk and writes a new label for it") (\PFTransferFilePage file filePageNumber volumePageNumber frame 'VWW runLength noBreak]) ) (DEFINEQ (\PFTransferFilePage [LAMBDA (file filePageNumber volumePageNumber frame operation runLength noBreak) (* ; "Edited 16-Apr-87 19:53 by amd") (* ;; "file: FileDescriptor, filePageNumber: FIXP, volumePageNumber: FIXP, frame: Page, operation: (VVR VVW VWW)") (* ;; "") (* ;; "Transfers a page to or from the disk. This function, unlike \PFTransferPage, deals in file- and volume-relative page numbers. It builds the correct label to be used for the transfer. NB: The only multi-page transfers occur during file allocation and deallocation. In these cases, FRAME is a junk page that will get written to every page being processed.") (SETQ runLength (OR runLength 1)) (* ;; "Break up the run into chunks of at most 128 pages for the Daybreak. DiskHeadDove$InitIOCB will not create an IOCB with a run length longer than that for some reason. This is the most convenient place to put this patch for now -- ideally the driver should be changed to handle this. The DLion is not adversely affected, since it does cylinder-crossing runs one page at a time anyway.") (for PAGE-OFFSET from 0 by 128 as PAGES-LEFT from runLength by -128 while (IGREATERP PAGES-LEFT 0) do (WITH-RESOURCE label (if (FIXP (fetch (FileDescriptor fileID) of file)) then (replace (Label fileID) of label with (fetch (FileDescriptor fileID) of file)) else (* ;; "Logical volume pages, marker pages, and physical volume pages have a 5-word volume ID for their fileID in a label. This is essentially a loophole to get around the normal declaration of the Label datatype, which expects a 2-word ID") (MESASETQ label (fetch (FileDescriptor fileID) of file) VolumeID)) (replace (Label attributesInAllPages) of label with (fetch (FileDescriptor type) of file)) (replace (Label filePage) of label with (IPLUS filePageNumber PAGE-OFFSET)) (\PFTransferPage (IPLUS (LvBasePageAddr (fetch (FileDescriptor volNum) of file)) volumePageNumber PAGE-OFFSET) frame operation label (MIN PAGES-LEFT 128) noBreak))) NIL]) ) (DEFINEQ (\PFTransferPage [LAMBDA (absoluteDiskAddress buffer mode label runLength noBreak) (* ; "Edited 16-Apr-87 19:48 by amd") (* ;; "Transfers a run of pages to or from the disk. This routine, unlike \PFTransferFilePage, deals in virtual disk addresses and expects the label to be set up correctly.") (if (NULL runLength) then (SETQ runLength 1)) (* ;; "Make sure everything is swapped in to prevent page faulting in low-level disk routines. In addition, buffer must be dirty for disk microcode to treat it right.") (SwapIn&Dirty buffer) (SwapIn&Dirty label) (* ;; "Do the transfer") (LET (DOB STATUS) (UNINTERRUPTABLY (SETQ DOB (\DL.OBTAINNEWDOB)) (with DLION.DOB DOB (SETQ DISKADDRESS absoluteDiskAddress) (SETQ BUFFER buffer) (SETQ RUNLENGTH runLength) (SETQ LABEL label) (SETQ MODE mode)) (\MISCAPPLY* (FUNCTION \DLDISK.EXECUTE) DOB) (SETQ STATUS (fetch (DLION.DOB STATUS) of DOB)) (SETQ DOB (\DL.RELEASEDOB DOB))) (if (AND (NOT noBreak) (NEQ STATUS 'OK)) then (DiskError "HARD DISK ERROR" STATUS)) STATUS]) ) (DECLARE%: DONTEVAL@LOAD (\LOCKFN '\PFTransferPage) ) (DECLARE%: EVAL@COMPILE [PUTDEF 'label 'RESOURCES '(NEW (create Label) GET (CL:LOCALLY (DECLARE (GLOBALVARS \label.GLOBALRESOURCE)) (if \label.GLOBALRESOURCE then (PROG1 \label.GLOBALRESOURCE (\CLEARWORDS \label.GLOBALRESOURCE (MESASIZE Label)) (SETQ \label.GLOBALRESOURCE NIL)) else (NEWRESOURCE label] ) (* ;; "File Descriptor pool for system files") (DEFINEQ (\PFCreateFileDescriptors [LAMBDA NIL (* hts%: " 7-Jan-85 15:15") (* ;;; "Sets up the file descriptors for system files. Should be run at load time (or at least the first time you wake up on a dlion, and before running \PFInitFileDescriptors)") (if [NOT (AND (BOUNDP '\PFLogicalVolumeFileD) (BOUNDP '\PFMarkerFileD) (BOUNDP '\PFFreeFileD) (BOUNDP '\PFAllocationMapFileD) (BOUNDP '\PFFileMapFileD] then (SETQ \PFInitialized NIL) (* ;; "Logical volume descriptors") (SETQ \PFLogicalVolumeFileD (ARRAY maxLogicalVolumes NIL NIL 0)) (for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETA \PFLogicalVolumeFileD volNum (create FileDescriptor volNum _ volNum type _ tLogicalVolumeRootPage size _ 1))) (* ;; "Marker pages") (SETQ \PFMarkerFileD (ARRAY maxLogicalVolumes NIL NIL 0)) (for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETA \PFMarkerFileD volNum (create FileDescriptor volNum _ volNum type _ tSubVolumeMarkerPage size _ 1))) (* ;; "Free pages") (SETQ \PFFreeFileD (ARRAY maxLogicalVolumes NIL NIL 0)) (for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETA \PFFreeFileD volNum (create FileDescriptor fileID _ tFreePage volNum _ volNum type _ tFreePage))) (* ;; "Volume allocation map pages") (SETQ \PFAllocationMapFileD (ARRAY maxLogicalVolumes NIL NIL 0)) (for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETA \PFAllocationMapFileD volNum (create FileDescriptor fileID _ tVolumeAllocationMap volNum _ volNum type _ tVolumeAllocationMap))) (* ;; "Volume file map pages") (SETQ \PFFileMapFileD (ARRAY maxLogicalVolumes NIL NIL 0)) (for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETA \PFFileMapFileD volNum (create FileDescriptor fileID _ tVolumeFileMap volNum _ volNum type _ tVolumeFileMap]) (\PFInitFileDescriptors [LAMBDA NIL (* hts%: "30-Nov-84 13:44") (* ;;; "Fills in the fileID for the system file descriptors whose fileID changes depending on what disk you're running on. This routine should be run every time you wake up on a DLion, but run after you've read in the physical volume page.") (PROG [(lastVolNum (SUB1 (fetch (PhysicalVolumeDescriptor subVolumeCount) of \PhysVolumePage ] (* ;; "Logical volume descriptors") (for volNum from 0 to lastVolNum do (replace (FileDescriptor fileID) of (ELT \PFLogicalVolumeFileD volNum) with (MESASETQ (create VolumeID) (fetch (SubVolumeDesc lvID) of (FMESAELT (fetch (PhysicalVolumeDescriptor subVolumes) of \PhysVolumePage ) SubVolumeArray volNum)) VolumeID))) (* ;; "Marker pages") (for volNum from 0 to lastVolNum do (replace (FileDescriptor fileID) of (ELT \PFMarkerFileD volNum) with (MESASETQ (create VolumeID) (fetch ( PhysicalVolumeDescriptor subVolumeMarkerID ) of \PhysVolumePage ) VolumeID]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PFLogicalVolumeFileD \PFMarkerFileD \PFFreeFileD \PFAllocationMapFileD \PFFileMapFileD) ) (\PFCreateFileDescriptors) (* ;; "Physical volume interface") (DEFINEQ (\PFCreatePhysicalVolume [LAMBDA NIL (* hts%: " 7-Jan-85 15:15") (if (NOT (AND (BOUNDP '\PhysVolumePage) (type? PhysicalVolumeDescriptor \PhysVolumePage))) then (SETQ \PFInitialized NIL) (SETQ \PhysVolumePage (create PhysicalVolumeDescriptor))) NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PhysVolumePage) ) (\PFCreatePhysicalVolume) (* ;; "Interface to logical volumes,") (DEFINEQ (\PFCreateVols [LAMBDA NIL (* ; "Edited 22-Oct-87 16:30 by amd") (* ;; "Creates an array of logical volume page frames. Also creates a hash table which maps logical volumes descriptors onto volume numbers. Both these data structures share logical volume page frames, so only one (the array) need be updated. The conditional ensures that loading a new version of the file system will not smash the logical volume information, unless the data structures are incompatible.") (if (NOT (AND (BOUNDP '\DFSLogicalVolumes) (type? ARRAYP \DFSLogicalVolumes) (ZEROP (ARRAYORIG \DFSLogicalVolumes)) (EQL maxLogicalVolumes (ARRAYSIZE \DFSLogicalVolumes)) (BOUNDP '\DFSLogicalVolumeHash) (HASHARRAYP \DFSLogicalVolumeHash))) then (SETQ \DFSLogicalVolumes (ARRAY maxLogicalVolumes NIL NIL 0)) (SETQ \DFSLogicalVolumeHash (HASHARRAY maxLogicalVolumes)) (bind vol for volNum from 0 to (SUB1 maxLogicalVolumes) do (SETQ vol (create LogicalVolumeDescriptor)) (SETA \DFSLogicalVolumes volNum vol) (PUTHASH vol volNum \DFSLogicalVolumeHash)) (SETQ \PFInitialized NIL)) NIL]) (\PFInitializeVols [LAMBDA NIL (* hts%: "29-Nov-84 12:19") (for volNum from 0 to (SUB1 (fetch (PhysicalVolumeDescriptor subVolumeCount) of \PhysVolumePage)) do (\PFGetLogicalVolumePage volNum (\PFGetVol volNum]) (\PFGetVols [LAMBDA NIL (* hts%: "11-Oct-84 17:19") (for volNum from 0 to (SUB1 (fetch (PhysicalVolumeDescriptor subVolumeCount) of \PhysVolumePage)) collect (\PFGetVol volNum]) (\PFGetVol [LAMBDA (volNum) (* hts%: "11-Oct-84 15:12") (ELT \DFSLogicalVolumes volNum]) (\PFVolumeNumber [LAMBDA (vol) (* hts%: "26-Nov-84 11:52") (* ;;; "vol: LogicalVolumeDescriptor; RETURNS: FIXP in 0..9") (* ;; "Converts vol into a logical volume number, becuase the page reading and writing routines expect a logical volume number rather than the logical volume itself.") (GETHASH vol \DFSLogicalVolumeHash]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \DFSLogicalVolumes \DFSLogicalVolumeHash) ) (\PFCreateVols) (DEFINEQ (\PFGetLVPage [LAMBDA (lvName) (* ; "Edited 8-Jan-87 17:49 by amd") (* ;; "Returns the logical volume page for the volume whose name is lvName. Returns NIL if there is no such volume.") (for vol in (\PFGetVols) thereis (STRING-EQUAL lvName (fetch ( LogicalVolumeDescriptor LVlabel) of vol]) ) (* ;; "Pilot integrity") (DEFINEQ (\PFVersionOK [LAMBDA NIL (* hts%: " 6-Jan-85 18:49") (* ;;; "Checks to see that the disk you are attempting to run on is partitioned in a way the file system can understand") (for vol in (\PFGetVols) always (EQ pilotVersion (fetch ( LogicalVolumeDescriptor version) of vol]) (\PFPilotVolumeP [LAMBDA (vol) (* amd "10-Feb-86 16:04") (* ;;; "Tells whether the volume in question is a pilot or non-pilot volume.") (* ;;; "any volume which is not of type non-Pilot is considered a Pilot volume ") (NEQ (fetch (LogicalVolumeDescriptor type) of vol) nonPilotVolume]) ) (* ;; "Pilot initialization") (DEFINEQ (\PFEnsureInitialized [LAMBDA (FORCEINITIALIZATION) (* amd "10-Feb-86 16:04") (* ;;; "Caches enough of the state of the disk so that the file system can run. Doesn't access the disk unless necessary.") (SELECTQ (MACHINETYPE) ((DANDELION DOVE) (if (OR FORCEINITIALIZATION (NOT \PFInitialized)) then (* ;; "initialize physical volume page cache") (\PFGetPhysicalVolumePage \PhysVolumePage) (* ;; "Use physical volume page to set up disk-specific system file descriptors (for logical volume pages and marker pages)") (\PFInitFileDescriptors) (* ;; "initialize logical volume page cache;") (\PFInitializeVols) (if (\PFVersionOK) then (* ;; "Initialize volume file map and volume allocation map") (\VAMInit) (\VFMInit) (* ;; "Note that this routine has been run") (SETQ \PFInitialized T) (\PFDsplyVolumes) T else (SETQ \PFInitialized NIL)) else (SETQ \PFInitialized T))) (SETQ \PFInitialized T]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PFInitialized) ) (RPAQ? \PFInitialized NIL) (RPAQ? \PFDebugFlag NIL) (ADDTOVAR \SYSTEMCACHEVARS \PFInitialized) (\PFEnsureInitialized) (* ;; "Root directory management") (DEFINEQ (\PFFindDirectoryID [LAMBDA (vol type) (* hts%: "18-Dec-84 16:45") (* ;;; "If on vol there is a directory associated with the specified file type, returns the fileID associated with that directory; else returns NIL") (PROG ((rootDir (create RootDirectory))) (RETURN (if (\PFGetRootDirectory vol rootDir) then (\PFFindRootDirEntry type rootDir) else NIL]) (\PFInsertDirectoryID [LAMBDA (vol type directoryID) (* ; "Edited 9-Jan-87 19:05 by amd") (PROG ((rootDir (create RootDirectory))) (if (NOT (\PFGetRootDirectory vol rootDir)) then (\PFCreateRootDirectory vol rootDir)) (\PFAddRootDirEntry type directoryID rootDir) (\PFPutRootDirectory vol rootDir)) (* ;; "Make sure it gets written out!") (\PFSaveBuffers vol]) (\PFRemoveDirectoryID [LAMBDA (vol type) (* ; "Edited 22-Oct-87 16:31 by amd") (PROG ((rootDir (create RootDirectory))) (if (\PFGetRootDirectory vol rootDir) then (if (ILEQ (fetch (RootDirectory countEntries) of rootDir) 1) then (\PFPurgeRootDirectory vol rootDir) else (\PFRemoveRootDirEntry type rootDir) (\PFPutRootDirectory vol rootDir]) ) (DEFINEQ (\PFFindRootDirEntry [LAMBDA (type rootDir) (* hts%: " 4-Jul-85 18:58") (* ;;; "look through registered directories to find the desired one. Stored as an array of (type directoryFileID) pairs.") (\PFPatchRootDirEntries type rootDir) (LET ((entryNum (\PFFindRootDirEntryNum type rootDir))) (AND entryNum (fetch (RootDirEntry file) of (MESAELT (fetch (RootDirectory entries) of rootDir) RootDirEntryArray entryNum]) (\PFAddRootDirEntry [LAMBDA (type directoryID rootDir) (* hts%: " 4-Jul-85 18:41") (* ;;; "Add specified (type directoryID) pair") (UNINTERRUPTABLY (PROG ((entryNum (fetch (RootDirectory countEntries) of rootDir))) (MESASETA (fetch (RootDirectory entries) of rootDir) RootDirEntryArray entryNum (create RootDirEntry type _ type file _ directoryID)) (replace (RootDirectory countEntries) of rootDir with (ADD1 entryNum))))]) (\PFRemoveRootDirEntry [LAMBDA (type rootDir) (* hts%: " 4-Jul-85 18:58") (* * comment) (UNINTERRUPTABLY (PROG ((nuke (\PFFindRootDirEntryNum type rootDir))) (if nuke then (bind (directories _ (fetch (RootDirectory entries) of rootDir )) for entryNum from (ADD1 nuke) to (fetch (RootDirectory countEntries) of rootDir) do (MESASETA directories RootDirEntryArray (SUB1 entryNum) (MESAELT directories RootDirEntryArray entryNum))) (add (fetch (RootDirectory countEntries) of rootDir) -1))))]) (\PFFindRootDirEntryNum [LAMBDA (type rootDir) (* ; "Edited 22-Oct-87 16:32 by amd") (* ;; "look through registered directories to find the desired one. Stored as an array of (type directoryFileID) pairs.") (bind (directories _ (fetch (RootDirectory entries) of rootDir)) for entryNum from 0 to (SUB1 (fetch (RootDirectory countEntries) of rootDir)) thereis (EQL (fetch (RootDirEntry type) of (MESAELT directories RootDirEntryArray entryNum)) type]) (\PFPatchRootDirEntries [LAMBDA (type rootDir) (* hts%: " 4-Jul-85 18:58") (* ;;; "Quietly patch up an off-by-one that was in Intermezzo.") (\PFRemoveRootDirEntry 0 rootDir) (add (fetch (RootDirectory countEntries) of rootDir) 1]) ) (DEFINEQ (\PFGetRootDirectory [LAMBDA (vol rootDir) (* hts%: " 5-Jan-85 16:26") (* ;;; "Reads in and returns the root directory for the specified volume, provided that it is there; else returns NIL") (if (NEQ (\GetRootDirectoryType vol) tRootDirectory) then NIL else (PROG ((fileD (create FileDescriptor fileID _ tRootDirectory volNum _ (\PFVolumeNumber vol) type _ tRootDirectory size _ 1)) where) (* ;; "find location of root directory page") (SETQ where (\VFMGetPageGroup vol fileD 0)) (OR where (RETURN NIL)) (* ;; "read in root directory page") (\PFGetPage fileD 0 (fetch (PageGroup volumePage) of where) rootDir) (RETURN T]) (\PFPutRootDirectory [LAMBDA (vol rootDir) (* edited%: "20-Jan-85 16:01") (* * comment) (PROG ((fileD (create FileDescriptor fileID _ tRootDirectory volNum _ (\PFVolumeNumber vol) type _ tRootDirectory size _ 1)) where) (* ;; "find location of root directory page") (SETQ where (\VFMGetPageGroup vol fileD 0)) (OR where (DiskError "HARD DISK ERROR" "Can't find volume root directory")) (* ;; "read in root directory page") (\PFPutPage fileD 0 (fetch (PageGroup volumePage) of where) rootDir]) (\PFCreateRootDirectory [LAMBDA (vol rootDir) (* hts%: " 9-Aug-85 12:25") (* * comment) (UNINTERRUPTABLY (PROG ((fileD (create FileDescriptor fileID _ tRootDirectory volNum _ (\PFVolumeNumber vol) type _ tRootDirectory size _ 0))) (OR (\PFNewPages vol fileD (create PageGroup filePage _ 0 nextFilePage _ 1)) (DiskError "FILE SYSTEM RESOURCES EXCEEDED")) (\PFPutRootDirectory vol rootDir) (\PFPutRootDirectoryType vol tRootDirectory)))]) (\PFPurgeRootDirectory [LAMBDA (vol rootDir) (* hts%: " 5-Jan-85 16:15") (* * comment) (UNINTERRUPTABLY (PROG ((fileD (create FileDescriptor fileID _ tRootDirectory volNum _ (\PFVolumeNumber vol) type _ tRootDirectory size _ 1))) (\PFPutRootDirectoryType vol tUnassigned) (\PFTrimHelper vol fileD 0)))]) ) (DEFINEQ (\GetRootDirectoryType [LAMBDA (vol) (* hts%: "18-Dec-84 21:55") (* * comment) (fetch (LogicalVolumeDescriptor volumeRootDirectory) of vol]) (\PFPutRootDirectoryType [LAMBDA (vol directoryID) (* hts%: "18-Dec-84 19:16") (* * comment) (replace (LogicalVolumeDescriptor volumeRootDirectory) of vol with directoryID) (\PFPutLogicalVolumePage vol vol) (PROG ((markerPage (create SubVolumeMarkerPage))) (\PFGetMarkerPage vol markerPage) (replace (LogicalSubVolumeMarker volumeRootDirectory) of markerPage with directoryID ) (\PFPutMarkerPage vol markerPage]) ) (* ;; "Pilot file management") (DEFINEQ (\PFNewPages [LAMBDA (vol file group) (* ; "Edited 22-Oct-87 16:32 by amd") (* ;; "Allocates the specified group of pages for file and records them in the volume file map. Returns file if successful, NIL otherwise.") (bind (startSize _ (fetch (FileDescriptor size) of file)) (currentGroup _ (create PageGroup)) until (EQL (fetch (FileDescriptor size) of file) (fetch (PageGroup nextFilePage) of group)) do (* ;; "Build the group to attempt to allocate next") (replace (PageGroup filePage) of currentGroup with (fetch ( FileDescriptor size) of file)) (replace (PageGroup volumePage) of currentGroup with 0) (replace (PageGroup nextFilePage) of currentGroup with (fetch (PageGroup nextFilePage) of group)) (* ;; "Allocate as many pages of the desired group as possible") (if (NOT (\VAMAllocPageGroup vol file currentGroup)) then (\PFTrimHelper vol file startSize) (RETURN NIL)) (* ;; "Stick the newly allocated group into the volume file map BTree") (\VFMInsertPageGroup vol file currentGroup) (* ;; "Record the newly-increased size of the file") (replace (FileDescriptor size) of file with (fetch (PageGroup nextFilePage) of currentGroup)) (BLOCK) finally (\PFDsplyVolumes) (RETURN file]) (\PFTrimHelper [LAMBDA (vol filePtr targetFileSize) (* ; "Edited 22-Oct-87 16:33 by amd") (* ;; "Shortens or deletes a file by taking entries out of the BTree and out of the allocation map Removes the pages of the file between targetFileSize & actualFileSize") (if (NOT (EQL targetFileSize (fetch (FileDescriptor size) of filePtr))) then (* ;; "Bear trap:") (if (AND \PFDebugFlag (IGREATERP targetFileSize (fetch (FileDescriptor size) of filePtr))) then (LET ((\INTERRUPTABLE T)) (HELP "\PFTrimHelper asked to grow file"))) (bind (group _ (create PageGroup filePage _ targetFileSize volumePage _ nullVolumePage nextFilePage _ (fetch (FileDescriptor size) of filePtr ))) until (PROGN (\VFMDeletePageGroup vol filePtr group) (\VAMFreePageGroup vol filePtr group) (replace (FileDescriptor size) of filePtr with (fetch (PageGroup filePage) of group)) (if (ZEROP (fetch (PageGroup filePage) of group)) then (replace (PageGroup nextFilePage) of group with 0) (\VFMDeletePageGroup vol filePtr group) (\VAMFreePageGroup vol filePtr group) T else (EQL (fetch (PageGroup filePage) of group) targetFileSize))) do (replace (PageGroup nextFilePage) of group with (fetch (PageGroup filePage) of group)) (replace (PageGroup filePage) of group with targetFileSize) (BLOCK)) (\PFDsplyVolumes]) (\PFFindPageAddr [LAMBDA (file filePage) (* ; "Edited 22-Oct-87 16:34 by amd") (* ;; "Tells where page filePage of file is located on the disk. Caches the last pageGroup for the file") (PROG ((PAGEGROUP (fetch (FileDescriptor PAGEGROUP) of file))) (if (OR (NOT (FIXP PAGEGROUP)) (ILESSP filePage (fetch (PageGroup filePage) of PAGEGROUP)) (IGEQ filePage (fetch (PageGroup nextFilePage) of PAGEGROUP))) then (* ;;  "Page group we are after is not in cache; we will have to look it up in the volume file map") (SETQ PAGEGROUP (\VFMGetPageGroup (\PFGetVol (fetch (FileDescriptor volNum) of file)) file filePage)) (OR [AND PAGEGROUP (NOT (ZEROP (fetch (PageGroup volumePage) of PAGEGROUP ] (DiskError "HARD DISK ERROR" "Can't find file page")) (replace (FileDescriptor PAGEGROUP) of file with PAGEGROUP)) (RETURN (IPLUS (fetch (PageGroup volumePage) of PAGEGROUP) filePage (IMINUS (fetch (PageGroup filePage) of PAGEGROUP]) (\PFFindFileSize [LAMBDA (file) (* amd "10-Feb-86 16:04") (* ;;; "Finds the number of pages in the specified file, as recorded in the volume file map.") (fetch (PageGroup filePage) of (\VFMGetPageGroup (\PFGetVol (fetch (FileDescriptor volNum) of file)) file MAX.FIXP]) (\PFFreeDiskPages [LAMBDA (vol recompute) (* amd "10-Feb-86 16:04") (* ;;; "Returns the free page count for the specified volume.") (if recompute then (\VAMRecomputeFreePageCount vol) (\PFDsplyVolumes)) (fetch (LogicalVolumeDescriptor freePageCount) of vol]) (\PFRoomForFile [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:35 by amd") (* ;; "Returns T iff there is room for the specified file on the specified volume. Formula is the same as Pilot uses; it is a little more conservative than necessary. The -5 is the maximum number of file map pages that could split; I don't know what the 15/16th's is about.") (LEQ (DIFFERENCE (fetch (PageGroup nextFilePage) of groupPtr) (fetch (PageGroup filePage) of groupPtr)) (if (EQL tVolumeFileMap (fetch (FileDescriptor type) of filePtr)) then (\PFFreeDiskPages vol) else (IDIFFERENCE (IQUOTIENT (ITIMES (\PFFreeDiskPages vol) 15) 16) 5]) (\PFSaveBuffers [LAMBDA (VOL) (* amd "10-Feb-86 16:04") (* ;;; "Saves out dirty buffers.") (\PFPutLogicalVolumePage VOL VOL) (\VAMBufferSave) (\VFMSaveBuffer]) ) (* ;; "Lisp vmem") (DEFINEQ (\PFCurrentVol [LAMBDA NIL (* ; "Edited 22-Oct-87 16:36 by amd") (* ;; "Returns the logical volume page of the volume which contains the currently running virtual memory. Depends on booting from physical volume boot pointers.") (for vol in (\PFGetVols) thereis (EQL [fetch (DiskFileID da) of (FMESAELT (fetch ( PhysicalVolumeDescriptor bootingInfo ) of \PhysVolumePage ) PVBootFiles (SELECTQ (MACHINETYPE) (DANDELION hardMicrocode) (DOVE bftGerm) (\NOMACHINETYPE] (fetch (DiskFileID da) of (FMESAELT (fetch ( LogicalVolumeDescriptor bootingInfo ) of vol) LVBootFiles (SELECTQ (MACHINETYPE) (DANDELION hardMicrocode) (DOVE bftGerm) (\NOMACHINETYPE]) ) (* ;; "Display stub; real volume display stuff is implemented on a library package called VOLUMEDISPLAY.") (DEFINEQ (\PFDsplyVolumes [LAMBDA NIL (* edited%: " 4-Jul-85 03:14") (* ;;; "Updates the volume display window as necessary.") (if (DEFINEDP '\DSKDISPLAY.UPDATE) then (\DSKDISPLAY.UPDATE]) ) (RPAQQ LFALLOCATIONMAPCOMS ( (* ;;; "Implements the 1108 file system volume file map. Very roughly translates the Pilot file VolAllocMapImpl.mesa. Used to be contained in the separate file LFALLOCATIONMAP. Must be loaded after the PILOTFILE module.") (* ;; "Needed improvement : Restructure interface with FILEIO so that a page can be allocated and written in one fell swoop. MFile/Pilot have a special interface for this.") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (BITSPERPAGE 4096))) (* ;; "Public routines") (FNS \VAMAllocPageGroup \VAMFreePageGroup \VAMInit \VAMRecomputeFreePageCount) (* ;; "Private routines:") (FNS \VAMFilePageNumber \VAMEnoughSpace \VAMFindFreePages \VAMCheckEndOfVol \VAMUpdateVAM \VAMAdjustGroup) (RESOURCES \DFSVAMpage \DFSVAMjunkPage) (GLOBALVARS \VAMmonitor) [INITVARS (\VAMmonitor (CREATE.MONITORLOCK 'VAMmonitor] (* ;; "buffer management") (FNS \VAMGetVAMPageFor \VAMBufferInit \VAMBufferSave \VAMMarkBufferDirty) (GLOBALVARS \VAMbuffer \VAMbufferVolume \VAMbufferVolumePage \VAMbufferDirty) (* ;; "Initialize VAM") (P (\VAMInit)))) (* ;;; "Implements the 1108 file system volume file map. Very roughly translates the Pilot file VolAllocMapImpl.mesa. Used to be contained in the separate file LFALLOCATIONMAP. Must be loaded after the PILOTFILE module." ) (* ;; "Needed improvement : Restructure interface with FILEIO so that a page can be allocated and written in one fell swoop. MFile/Pilot have a special interface for this." ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ BITSPERPAGE 4096) (CONSTANTS (BITSPERPAGE 4096)) ) ) (* ;; "Public routines") (DEFINEQ (\VAMAllocPageGroup [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:38 by amd") (* ;; "Allocates as many of the pages in groupPtr as it can in a contiguous run. Modifies groupPtr so the caller can know what pages and how many were allocated") (WITH.MONITOR \VAMmonitor (UNINTERRUPTABLY (LET [(RUNLENGTH (IDIFFERENCE (fetch (PageGroup nextFilePage) of groupPtr) (fetch (PageGroup filePage) of groupPtr] (if (\VAMEnoughSpace vol filePtr RUNLENGTH) then (* ;; "Look in the free page bitmap to find a contiguous bunch of free pages and mark them taken in the bitmap.") (\VAMFindFreePages vol filePtr groupPtr) (SETQ RUNLENGTH (IDIFFERENCE (fetch (PageGroup nextFilePage) of groupPtr) (fetch (PageGroup filePage) of groupPtr))) (* ;;  "Update free page count and lower bound on the logical volume page") (add (fetch (LogicalVolumeDescriptor freePageCount) of vol) (IMINUS RUNLENGTH)) (replace (LogicalVolumeDescriptor lowerBound) of vol with (IPLUS (fetch (PageGroup volumePage) of groupPtr) RUNLENGTH)) (* ;; "Check all these pages to make sure they are indeed free.") (WITH-RESOURCE \DFSVAMjunkPage (\PFGetFreePage vol (fetch (PageGroup volumePage) of groupPtr) \DFSVAMjunkPage RUNLENGTH)) (* ;; "Finally, clear each page and give it a free page label.") (WITH-RESOURCE \DFSVAMpage (\PFCreatePage filePtr (\VAMFilePageNumber (fetch (FileDescriptor type) of filePtr) (fetch (PageGroup volumePage) of groupPtr) (fetch (PageGroup filePage) of groupPtr)) (fetch (PageGroup volumePage) of groupPtr) \DFSVAMpage RUNLENGTH)) (* ;; "Return T indicating success.") T else (* ;; "Not enough space on the volume: return NIL to indicate failure.") (replace (PageGroup nextFilePage) of groupPtr with (fetch (PageGroup filePage) of groupPtr)) (replace (PageGroup volumePage) of groupPtr with 0) NIL))))]) (\VAMFreePageGroup [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:39 by amd") (* ;; "Frees each page in groupPtr") (WITH.MONITOR \VAMmonitor (UNINTERRUPTABLY [PROG ((group (\VAMAdjustGroup groupPtr))) (* ;  "Adjust to coincide with Pilot's silly '[0, 0)' convention") (* ;; "If no pages to free, just return (runlength <= 0 might upset later code)") (if (IGEQ (fetch (PageGroup filePage) of group) (fetch (PageGroup nextFilePage) of group)) then (RETURN)) (LET [(RUNLENGTH (IDIFFERENCE (fetch (PageGroup nextFilePage) of group) (fetch (PageGroup filePage) of group] (* ;; "First check the page labels to make sure all the pages really do belong to the file we are shortening.") (WITH-RESOURCE \DFSVAMjunkPage (\PFGetPage filePtr (\VAMFilePageNumber (fetch (FileDescriptor type) of filePtr) (fetch (PageGroup volumePage) of group) (fetch (PageGroup filePage) of group)) (fetch (PageGroup volumePage) of group) \DFSVAMjunkPage RUNLENGTH)) (* ;;  "Then clear each page on the disk and give it a new label saying it is a free page.") (WITH-RESOURCE \DFSVAMpage (\PFCreateFreePage vol (fetch (PageGroup volumePage) of group) \DFSVAMpage RUNLENGTH)) (* ;; "Finally mark the pages as free in the free page bitmap.") (to RUNLENGTH as volumePageNumber from (fetch (PageGroup volumePage) of group) do (\VAMUpdateVAM vol filePtr volumePageNumber 'free)) (* ;; "Update free page count and lower bound on the logical volume page") (add (fetch (LogicalVolumeDescriptor freePageCount) of vol) RUNLENGTH)) (replace (LogicalVolumeDescriptor lowerBound) of vol with (IMIN (fetch (PageGroup volumePage) of group) (fetch (LogicalVolumeDescriptor lowerBound) of vol]))]) (\VAMInit [LAMBDA NIL (* hts%: " 5-Jan-85 16:18") (* ;;; "Initializes or reinitializes the volume allocation map") (WITH.MONITOR \VAMmonitor (\VAMBufferInit]) (\VAMRecomputeFreePageCount [LAMBDA (vol) (* amd "10-Feb-86 16:04") (* ;;; "Recomputes the free page count for each volume from scratch; also resets the lower bound pointer") (WITH.MONITOR \VAMmonitor [replace (LogicalVolumeDescriptor freePageCount) of vol with (bind (firstFree _ T) for page from 1 to (fetch (LogicalVolumeDescriptor volumeSize) of vol) count (PROG [(free (ZEROP (\VAMUpdateVAM vol NIL page 'read] (if (AND free firstFree) then (replace (LogicalVolumeDescriptor lowerBound) of vol with page) (SETQ firstFree NIL)) (RETURN free] (\PFPutLogicalVolumePage vol vol) (fetch (LogicalVolumeDescriptor freePageCount) of vol))]) ) (* ;; "Private routines:") (DEFINEQ (\VAMFilePageNumber [LAMBDA (fileType volumePageNumber filePageNumber) (* amd "10-Feb-86 16:04") (* ;;; "Returns the real file page number") (SELECTC fileType (tLispFile filePageNumber) (tLispDirectory filePageNumber) (tVolumeFileMap volumePageNumber) (tRootDirectory 0) (tDiagnosticMicrocode filePageNumber) (SHOULDNT]) (\VAMEnoughSpace [LAMBDA (vol filePtr RUNLENGTH) (* ; "Edited 22-Oct-87 16:40 by amd") (* ;; "Tells whether there's enough space left on the specified volume to allocate RUNLENGTH pages. There should always be room for new volume file map pages. For other kinds of files, the '15/16th's - 5' is the criterion the Pilot people chose. It is a little over-conservative. The -5 is the maximum number of btree splits you can have in the file map; I don't know what the '15/16th's' is for.") (OR (EQL tVolumeFileMap (fetch (FileDescriptor type) of filePtr)) (ILEQ RUNLENGTH (IDIFFERENCE (IQUOTIENT (ITIMES (fetch (LogicalVolumeDescriptor freePageCount) of vol) 15) 16) 5]) (\VAMFindFreePages [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:41 by amd") (* ;; "Scans page allocation bitmap till it finds a chunk of contiguous free pages to partially satisfy the request. Modifies groupPtr accordingly.") (UNINTERRUPTABLY (PROG ((volPage# (fetch (LogicalVolumeDescriptor lowerBound) of vol)) (filePage# (fetch (PageGroup filePage) of groupPtr))) (* ;; "Find first free page and allocate it. lowerBound is supposed to be the first free page on the volume") (until [PROGN (if (IGEQ volPage# (SUB1 (fetch (LogicalVolumeDescriptor volumeSize) of vol))) then (DiskError "HARD DISK ERROR" "FREE PAGE COUNT WRONG")) (ZEROP (\VAMUpdateVAM vol filePtr volPage# 'alloc] do (add volPage# 1)) (* ;; "Note in groupPtr the beginning page of the run we will allocate to this file") (replace (PageGroup volumePage) of groupPtr with volPage#) (* ;;  "Keep allocating until either you've allocated enough or you run out of consecutive free pages") [repeatuntil (PROGN (add volPage# 1) (add filePage# 1) (if (IGEQ volPage# (SUB1 (fetch ( LogicalVolumeDescriptor volumeSize) of vol))) then (DiskError "HARD DISK ERROR" "FREE PAGE COUNT WRONG")) (OR (EQL filePage# (fetch (PageGroup nextFilePage) of groupPtr)) (NEQ 0 (\VAMUpdateVAM vol filePtr volPage# 'alloc] (* ;;; "Note in the PageGroup what the last page allocated actually was, so the caller will know") (replace (PageGroup nextFilePage) of groupPtr with filePage#)))]) (\VAMCheckEndOfVol [LAMBDA (vol volPage#) (* amd "10-Feb-86 16:04") (* ;;; "Checks to make sure you are not about to allocate off the end of the volume.") (if (IGEQ volPage# (SUB1 (fetch (LogicalVolumeDescriptor volumeSize) of vol))) then (DiskError "HARD DISK ERROR" "FREE PAGE COUNT WRONG")) NIL]) (\VAMUpdateVAM [LAMBDA (vol filePtr page allocOrFree) (* hts%: "16-Jan-85 21:08") (* ;;; "vol: LogicalVolumeDescriptor, filePtr: FileDescriptor, page: FIXP, allocOrFree: {alloc, free}") (* ;;; "RETURNS previous value of allocation map for specified page") (* ;;; "Sets (if allocOrFree = alloc) or clears (if allocOrFree = free) the map bit for the specified page") (PROG ((VAMPage# (IQUOTIENT page BITSPERPAGE)) (VAMWord# (IQUOTIENT (IREMAINDER page BITSPERPAGE) BITSPERWORD)) (VAMBit# (IREMAINDER page BITSPERWORD)) VAMPage VAMWord VAMBit result) (SETQ VAMPage (\VAMGetVAMPageFor vol VAMPage#)) (SETQ VAMWord (\GETBASE VAMPage VAMWord#)) (SETQ VAMBit (MASK.1'S (DIFFERENCE 15 VAMBit#) 1)) (SETQ result (if (BITTEST VAMWord VAMBit) then 1 else 0)) (SELECTQ allocOrFree (alloc (SETQ VAMWord (BITSET VAMWord VAMBit)) (\VAMMarkBufferDirty)) (free (SETQ VAMWord (BITCLEAR VAMWord VAMBit)) (\VAMMarkBufferDirty)) (read) (SHOULDNT)) (\PUTBASE VAMPage VAMWord# VAMWord) (RETURN result]) (\VAMAdjustGroup [LAMBDA (groupPtr) (* ; "Edited 22-Oct-87 16:42 by amd") (* ;; "Adjust groupPtr to not delete the last page of the file unless it is a separate request for that specific purpose. This was a silly Pilot convention (now obsolete).") (PROG ((group (create PageGroup using groupPtr))) [if (ZEROP (fetch (PageGroup filePage) of group)) then (if (ZEROP (fetch (PageGroup nextFilePage) of group)) then (replace (PageGroup nextFilePage) of group with 1) else (replace (PageGroup filePage) of group with 1) (replace (PageGroup volumePage) of group with (ADD1 (fetch (PageGroup volumePage) of group] (RETURN group]) ) (DECLARE%: EVAL@COMPILE [PUTDEF '\DFSVAMpage 'RESOURCES '(NEW (create Page] [PUTDEF '\DFSVAMjunkPage 'RESOURCES '(NEW (create Page] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \VAMmonitor) ) (RPAQ? \VAMmonitor (CREATE.MONITORLOCK 'VAMmonitor)) (* ;; "buffer management") (DEFINEQ (\VAMGetVAMPageFor [LAMBDA (vol VAMPage#) (* ; "Edited 22-Oct-87 16:42 by amd") (PROG ((volumePage (IPLUS (fetch (LogicalVolumeDescriptor vamStart) of vol) VAMPage#))) (if (AND (FIXP \VAMbufferVolumePage) (EQ \VAMbufferVolume vol) (EQL \VAMbufferVolumePage volumePage)) then (* ;; "If the desired VAM page is already read in, just return it") (RETURN \VAMbuffer) else (* ;; "Otherwise write out the old VAM page if there is one") (\VAMBufferSave) (UNINTERRUPTABLY (* ;; "Record what the new page is") (SETQ \VAMbufferVolume vol) (SETQ \VAMbufferVolumePage volumePage) (* ;; "and read it in") (\PFGetAllocationMapPage \VAMbufferVolume \VAMbufferVolumePage \VAMbuffer)) (RETURN \VAMbuffer]) (\VAMBufferInit [LAMBDA NIL (* hts%: "16-Jan-85 21:04") (* ;;; "if bufferVolumePage is NIL, GetVAMPageFor will not try to flush an old version of it") (SETQ \VAMbuffer (create Page)) (SETQ \VAMbufferVolume) (SETQ \VAMbufferVolumePage) (SETQ \VAMbufferDirty NIL]) (\VAMBufferSave [LAMBDA NIL (* amd "10-Feb-86 18:13") (* ;;; "Flush last VAM page used") (if (AND (FIXP \VAMbufferVolumePage) \VAMbufferDirty) then (\PFPutAllocationMapPage \VAMbufferVolume \VAMbufferVolumePage \VAMbuffer) (SETQ \VAMbufferDirty NIL]) (\VAMMarkBufferDirty [LAMBDA NIL (* hts%: "16-Jan-85 21:02") (* ;;; "Indicate that the buffer VAM page is dirty and will have to be written out.") (SETQ \VAMbufferDirty T) NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \VAMbuffer \VAMbufferVolume \VAMbufferVolumePage \VAMbufferDirty) ) (* ;; "Initialize VAM") (\VAMInit) (RPAQQ LFFILEMAPCOMS ( (* ;;; "Implements the volume file map, which maps Pilot file ID numbers onto runs of disk pages. Roughly equivalent to the Pilot file VolFileMapImpl.mesa. Must be loaded after the PILOTFILE module. Used to be contained in a separate file called LFFILEMAP.") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS Key Interval Index BufferArray Buffer) (RECORDS \BTREEBUF) (CONSTANTS (maxReadPtr (DIFFERENCE (MESASIZE Buffer) (MESASIZE Index))) (treeDepth 5)) (FNS ShowIntervals)) (INITRECORDS \BTREEBUF) (* ;; "Initialization routines") (FNS \VFMInit) (* ;; "The following are public entry points to the volume file map module") (FNS \VFMDeletePageGroup \VFMGetPageGroup \VFMInsertPageGroup) (* ;; "The following are routines internal to the volume file map module.") (FNS \VFMContextSet \VFMCreateVPage \VFMDelete \VFMDelete1 \VFMDelete2 \VFMFind \VFMFreeVPage \VFMGet \VFMGet1 \VFMInsert \VFMInsert1 \VFMLower \VFMMerge \VFMMerge1 \VFMPutNext \VFMReadNext \VFMSplit \VFMSplit1) (GLOBALVARS \VFMmaxID \VFMmaxKey \VFMnullKey \VFMvolumeHandle \VFMinterval \VFMold \VFMlow \VFMhigh \VFMoldPtr \VFMlowPtr \VFMhighPtr \VFMmonitor) (* ;; "Buffer management") (FNS \VFMGetBufferFor \VFMSaveBuffer \VFMClearBuffers \VFMKillBuffer \VFMCorrectBufferP \VFMMarkBufferDirty) (GLOBALVARS \VFMbufferPool \VFMbufferSize \VFMbuffer \VFMxtraBuffer) (INITVARS (\VFMbufferSize 10)) (* ;; "Interval cache interface") (FNS \VFMCreateIntervals \VFMClearIntervals \VFMGetInterval \VFMBlankInterval) (GLOBALVARS \VFMintervals) (* ;; "BLT routine that doesn't stomp on itself for overlapping intervals") (FNS \VFMSmartBLT) (* ;; "Loading initialization") (FNS \VFMAtLoad) (P (\VFMAtLoad)))) (* ;;; "Implements the volume file map, which maps Pilot file ID numbers onto runs of disk pages. Roughly equivalent to the Pilot file VolFileMapImpl.mesa. Must be loaded after the PILOTFILE module. Used to be contained in a separate file called LFFILEMAP." ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (MESARECORD Key ((fileID SWAPPEDFIXP) (filePage SWAPPEDFIXP) (type WORD))) (MESARECORD Interval ((key Key) (volumePage SWAPPEDFIXP) (nextKey Key))) (MESARECORD Index ((key Key) (volumePage SWAPPEDFIXP))) (MESAARRAY BufferArray [(0 (SUB1 (IQUOTIENT WORDSPERPAGE (MESASIZE Index] Index) (MESARECORD Buffer ((data BufferArray) (used WORD)) (* This is the structure for a BTree  page) (CREATE (create Page)) (TYPE? (type? Page DATUM))) ) (DECLARE%: EVAL@COMPILE (DATATYPE \BTREEBUF ((VOLUME POINTER) (VOLPAGENUM FIXP) (PAGE POINTER) (DIRTY FLAG))) ) (/DECLAREDATATYPE '\BTREEBUF '(POINTER FIXP POINTER FLAG) '((\BTREEBUF 0 POINTER) (\BTREEBUF 2 FIXP) (\BTREEBUF 4 POINTER) (\BTREEBUF 4 (FLAGBITS . 0))) '6) (DECLARE%: EVAL@COMPILE (RPAQ maxReadPtr (DIFFERENCE (MESASIZE Buffer) (MESASIZE Index))) (RPAQQ treeDepth 5) (CONSTANTS (maxReadPtr (DIFFERENCE (MESASIZE Buffer) (MESASIZE Index))) (treeDepth 5)) ) (DEFINEQ (ShowIntervals [LAMBDA (vol) (* ; "Edited 22-Oct-87 12:04 by amd") (bind (intervalCache _ (PROGN (\VFMContextSet vol) (\VFMGetInterval))) interval for level from 0 to 4 do (printout T level ":" T "key: ") (SETQ interval (ELT intervalCache level)) (DISPLAYWORDS (fetch (Interval key) of interval) (MESASIZE Key)) (printout T "volumePage: " (fetch (Interval volumePage) of interval) T) (printout T "nextKey: ") (DISPLAYWORDS (fetch (Interval nextKey) of interval) (MESASIZE Key]) ) ) (/DECLAREDATATYPE '\BTREEBUF '(POINTER FIXP POINTER FLAG) '((\BTREEBUF 0 POINTER) (\BTREEBUF 2 FIXP) (\BTREEBUF 4 POINTER) (\BTREEBUF 4 (FLAGBITS . 0))) '6) (* ;; "Initialization routines") (DEFINEQ (\VFMInit [LAMBDA NIL (* hts%: " 5-Jan-85 16:29") (* ;;; "Minimally reinitialize the volume file map state variables") (WITH.MONITOR \VFMmonitor (UNINTERRUPTABLY (* ;; "Clear out the BTree interval cache") (\VFMClearIntervals) (* ;; "Clear the btree node cache") (\VFMClearBuffers)))]) ) (* ;; "The following are public entry points to the volume file map module") (DEFINEQ (\VFMDeletePageGroup [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:46 by amd") (* ;; "Deletes all or part of a single page group from the volume file map. The page group requested to be deleted need not correspond to a single run of pages on the disk. It can be part of a single run of pages or stretch over several runs of pages. In particular it is possible to delete a page or pages out of the middle of a run of pages (the scavenger uses this capability). The actual page group deleted is returned in the group pointed to by GroupPtr. Thus GroupPtr points to a modifiable hint. Care must be taken by the caller to insure that the page group to be deleted exists. If it doesn't, Bug (pageGroupNotFound) is raised. This procedure implements the following funny features:") (* ;; "1.0 If the page group to be deleted includes parts of more than one run of pages on the disk, only the last run (or that part of the last run requested to be deleted) will be deleted.") (* ;; "2.0 If the page group to be deleted is the last page group left for the file and includes page zero of the file and at least one following page, page zero will not be deleted. This is a special case that facilitates shrinking a file to a zero-length file. VolAllocMapImpl has special case code in FreePageGroup for this also. You can delete this last page of the file by specifying page group '[0..0)' .") (* ;; "3.0 A hole at the beginning of a file is represented as follows: if file F is missing pages (0..n) and the preceding file in the lexicographic ordering is file E of size m, then the interval in the file map representing the hole looks like this: (key: (E, m), volumePage: nullVolumePage, nextKey: (F, n)).") (* ;; "4.0 A hole in the middle of the file (e.g. missing pages (m..n)) looks like this: (key: (F, m), volumePage: nullVolumePage, nextKey: (F, n)).") (* ;; "5.0 This procedure does not care whether the page group being deleted corresponds to a hole in a file or to a real run of pages on the volume, with the exception of a hole at the beginning of a file. If the page group to be deleted is fully contained in a hole at the beginning of the file, Bug (pageGroupNotFound) is raised.") (WITH.MONITOR \VFMmonitor (UNINTERRUPTABLY (PROG ((key (create Key fileID _ (fetch (FileDescriptor fileID) of filePtr) filePage _ (IDIFFERENCE (fetch (PageGroup nextFilePage) of groupPtr) (if (ZEROP (fetch (PageGroup nextFilePage) of groupPtr)) then 0 else 1)) type _ (fetch (FileDescriptor type) of filePtr))) (interval (create Interval)) (fileSize (fetch (FileDescriptor size) of filePtr))) (* ;  "(ASSERT (LEQ (fetch (PageGroup nextFilePage) of groupPtr) fileSize))") (\VFMContextSet vol) (MESASETQ interval (\VFMGet key 0) Interval) (* ;  "get interval containing last page of group") (if (OR (NOT (EQL (fetch (Key fileID) of (fetch (Interval key) of interval)) (fetch (FileDescriptor fileID) of filePtr))) (AND (NOT (EQL (fetch (Key fileID) of (fetch (Interval nextKey) of interval)) (fetch (FileDescriptor fileID) of filePtr))) (EQL (fetch (Interval volumePage) of interval) nullVolumePage))) then (DiskError "HARD DISK ERROR" "Page group not found")) (* ;; "for a zero-length file, interval.nextKey.fileID # filePtr.fileID BUT interval.volumePage # nullVolumePage") [replace (PageGroup filePage) of groupPtr with (replace (Key filePage) of key with (IMAX (fetch (Key filePage) of (fetch (Interval key) of interval)) (fetch (PageGroup filePage) of groupPtr] [replace (PageGroup volumePage) of groupPtr with (if (EQL (fetch (Interval volumePage) of interval) nullVolumePage) then nullVolumePage else (IPLUS (fetch (Interval volumePage) of interval) (IDIFFERENCE (fetch (PageGroup filePage) of groupPtr) (fetch (Key filePage) of (fetch (Interval key) of interval] (replace (PageGroup nextFilePage) of groupPtr with (IMIN (fetch (Key filePage) of (fetch (Interval nextKey) of interval)) (fetch (PageGroup nextFilePage) of groupPtr))) (* ;  "deal with the starting page of the page group first") (if [AND (MESAEQUAL key (fetch (Interval key) of interval) Key) (OR (NOT (EQL (fetch (PageGroup nextFilePage) of groupPtr) fileSize)) (NOT (ZEROP (fetch (Key filePage) of key] then (\VFMDelete key 0)) [if (NOT (ZEROP (fetch (Key filePage) of key))) then (PROG [(previousKey (create Key fileID _ (fetch (FileDescriptor fileID) of filePtr) filePage _ (SUB1 (fetch (Key filePage) of key] (if (EQL (fetch (Key fileID) of (fetch (Interval key) of (\VFMGet previousKey 0))) (fetch (FileDescriptor fileID) of filePtr)) then (* ;  "key.filePage is not the first (existing) page of the file") (\VFMInsert key nullVolumePage 0] (* ;  "now deal with the ending page of the page group") (replace (Key filePage) of key with (fetch (PageGroup nextFilePage) of groupPtr)) (if (EQL (fetch (Key filePage) of key) fileSize) then (\VFMDelete key 0)) (if [AND [NOT (EQL (fetch (Key filePage) of key) (fetch (Key filePage) of (fetch (Interval nextKey) of interval] (EQL (fetch (Key fileID) of key) (fetch (Key fileID) of (fetch (Interval nextKey) of interval] then (\VFMInsert key [if (EQL (fetch (PageGroup volumePage) of groupPtr) nullVolumePage) then nullVolumePage else (IPLUS (fetch (PageGroup volumePage ) of groupPtr) (IDIFFERENCE (fetch (PageGroup nextFilePage ) of groupPtr) (fetch (PageGroup filePage) of groupPtr] 0)))))]) (\VFMGetPageGroup [LAMBDA (vol filePtr filePage) (* ; "Edited 22-Oct-87 16:47 by amd") (* ;; "finds page group containing key (filePage = nextFilePage = size when off end of file)") (WITH.MONITOR \VFMmonitor (UNINTERRUPTABLY (PROG ((key (create Key fileID _ (fetch (FileDescriptor fileID) of filePtr) filePage _ filePage type _ (fetch (FileDescriptor type) of filePtr))) (interval (create Interval))) (\VFMContextSet vol) (MESASETQ interval (\VFMGet key 0) Interval) [RETURN (AND (EQL (fetch (Key fileID) of (fetch (Interval key) of interval)) (fetch (FileDescriptor fileID) of filePtr)) (create PageGroup filePage _ (fetch (Key filePage) of (fetch (Interval key) of interval) ) volumePage _ (fetch (Interval volumePage) of interval) nextFilePage _ (fetch (Key filePage) of (if (EQL (fetch (Key fileID) of (fetch (Interval nextKey) of interval)) (fetch (FileDescriptor fileID) of filePtr)) then (fetch (Interval nextKey) of interval) else (fetch (Interval key) of interval] (* ;  "covers page zero and size requests") )))]) (\VFMInsertPageGroup [LAMBDA (vol filePtr groupPtr) (* ; "Edited 22-Oct-87 16:47 by amd") (* ;; "inserts a pageGroup into B-tree (unordered inserts are merged for rebuild)") (WITH.MONITOR \VFMmonitor (UNINTERRUPTABLY (PROG ((key (create Key fileID _ (fetch (FileDescriptor fileID) of filePtr) filePage _ (fetch (PageGroup filePage) of groupPtr) type _ (fetch (FileDescriptor type) of filePtr))) (interval (create Interval))) (\VFMContextSet vol) (MESASETQ interval (\VFMGet key 0) Interval) (if (MESAEQUAL (fetch (Interval key) of interval) key Key) then (\VFMDelete key 0) (MESASETQ interval (\VFMGet key 0) Interval)) (if [OR [NOT (EQL (IDIFFERENCE (fetch (Key filePage) of key) (fetch (Key filePage) of (fetch (Interval key) of interval))) (IDIFFERENCE (fetch (PageGroup volumePage) of groupPtr ) (fetch (Interval volumePage) of interval] (NOT (EQL (fetch (Key fileID) of key) (fetch (Key fileID) of (fetch (Interval key) of interval] then (* ; "don't merge with previous") (\VFMInsert key (fetch (PageGroup volumePage) of groupPtr) 0) (MESASETQ interval (\VFMGet key 0) Interval)) (replace (Key filePage) of key with (fetch (PageGroup nextFilePage) of groupPtr)) (if [AND (NOT (MESAEQUAL (fetch (Interval nextKey) of interval) key Key)) (NOT (EQL (fetch (PageGroup filePage) of groupPtr) (fetch (PageGroup nextFilePage) of groupPtr] then (\VFMInsert key nullVolumePage 0)) (if [AND (MESAEQUAL (fetch (Interval nextKey) of interval) key Key) (EQL (fetch (Interval volumePage) of (\VFMGet key 0)) (IPLUS (fetch (Interval volumePage) of interval) (IDIFFERENCE (fetch (Key filePage) of (fetch (Interval nextKey) of interval)) (fetch (Key filePage) of (fetch (Interval key) of interval ] then (\VFMDelete key 0) (* ; "merge with following")))))]) ) (* ;; "The following are routines internal to the volume file map module.") (DEFINEQ (\VFMContextSet [LAMBDA (vol) (* ; "Edited 22-Oct-87 12:12 by amd") (* ;; "vol: LogicalVolumeDescriptor") (SETQ \VFMvolumeHandle vol]) (\VFMCreateVPage [LAMBDA NIL (* hts%: " 6-Aug-85 12:44") (* ;;; "Returns SWAPPEDFIXP") (* ; "Internal") (* ;;; "Calls VolAllocMap.AllocPageGroup to get a new page for the vfm B-tree. Returns its volume-relative page number.") (with LogicalVolumeDescriptor \VFMvolumeHandle (PROG [(group (create PageGroup filePage _ 0 volumePage _ 0 nextFilePage _ 1)) (vfmFileD (ELT \PFFileMapFileD (\PFVolumeNumber \VFMvolumeHandle] (OR (\VAMAllocPageGroup \VFMvolumeHandle vfmFileD group) (DiskError "HARD DISK ERROR" "File map Btree split failed.")) (RETURN (fetch (PageGroup volumePage) of group]) (\VFMDelete [LAMBDA (deleteKey deleteLevel) (* hts%: "24-Jan-85 16:23") (* ;;; "key: Key, level: SMALLP") (* ; "Internal") (* ;;; "Deletes the index corresponding to key. Error if no such index. No merging is done here explicitly; it happens as a side-effect of (Find ...)") (DECLARE (SPECVARS deleteKey deleteLevel)) (PROG (firstFlag lastFlag volumePage (nextKey (create Key))) (DECLARE (SPECVARS firstFlag lastFlag volumePage nextKey)) (* ;; "volumePage is the page holding the key (delete if firstFlag AND lastFlag) --- nextKey is the following key; must be slid down over deleted key") (\VFMFind deleteKey deleteLevel (FUNCTION \VFMDelete1)) [if firstFlag then (* ;; "Since this is the first entry in a page, there is a reference to it in the next higher level. If the current page will become empty due to the delete, we simply delete the reference in the higher page. Otherwise we must replace the reference with the new first entry of the current page.") (\VFMDelete deleteKey (ADD1 deleteLevel)) (if lastFlag then (\VFMFreeVPage volumePage) else (\VFMInsert nextKey volumePage (ADD1 deleteLevel] (\VFMFind deleteKey deleteLevel (FUNCTION \VFMDelete2)) (* ; "Get the preceding index") ]) (\VFMDelete1 [LAMBDA NIL (* amd "10-Feb-86 18:16") (* ; "Internal") (* ;;; "Save the following Index in nextKey; set firstFlag, lastFlag, and volumePage. Shift entries if at beginning of page.") (SETQ firstFlag (EQP \VFMlowPtr 0)) (SETQ lastFlag (EQP \VFMhighPtr (fetch (Buffer used) of \VFMbuffer))) (SETQ volumePage (fetch (Interval volumePage) of \VFMinterval)) (MESASETQ nextKey (fetch (Index key) of \VFMhigh) Key) (* (ASSERT (MESAEQUAL  (fetch (Index key) of \VFMlow)  deleteKey Key))) (if (AND firstFlag (NOT lastFlag)) then (\VFMSmartBLT \VFMbuffer (\ADDBASE \VFMbuffer \VFMhighPtr) (replace (Buffer used) of \VFMbuffer with (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMhighPtr))) (\VFMMarkBufferDirty \VFMbuffer]) (\VFMDelete2 [LAMBDA NIL (* hts%: "29-Jan-85 20:50") (* ; "Internal") (* ;;; "Slide the entries down over nextKey, and then reinsert nextKey in place of the deleted entry. Be careful to preserve the correct volumePage.") (replace (Index key) of \VFMhigh with nextKey) (replace (Index volumePage) of \VFMhigh with (fetch (Index volumePage) of \VFMlow)) (MESASETQ \VFMlow \VFMold Index) (SETQ \VFMlowPtr \VFMoldPtr) (\VFMSmartBLT (\ADDBASE \VFMbuffer (IPLUS \VFMlowPtr (MESASIZE Index))) (\ADDBASE \VFMbuffer \VFMhighPtr) (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMhighPtr)) (\VFMPutNext (fetch (Index key) of \VFMhigh) (fetch (Index volumePage) of \VFMhigh) deleteLevel) (replace (Buffer used) of \VFMbuffer with (IDIFFERENCE (IPLUS \VFMlowPtr (fetch (Buffer used) of \VFMbuffer)) \VFMhighPtr)) (\VFMMarkBufferDirty \VFMbuffer]) (\VFMFind [LAMBDA (key level proc) (* ; "Edited 22-Oct-87 12:30 by amd") (* ;; "key: Key, level: SMALLP, proc: FUNCTION") (* ;; "executes proc with context (buffer, low, \VFMhigh) surrounding key (merges too)") (MESASETQ \VFMinterval (\VFMGet key (ADD1 level)) Interval) (SETQ \VFMbuffer (\VFMGetBufferFor (fetch (Interval volumePage) of \VFMinterval))) (* ;; "Initialize reader") (replace (Index key) of \VFMhigh with (fetch (Interval key) of \VFMinterval)) (replace (Index volumePage) of \VFMhigh with nullVolumePage) (MESASETQ \VFMold (MESASETQ \VFMlow \VFMhigh Index) Index) (SETQ \VFMoldPtr (SETQ \VFMlowPtr (SETQ \VFMhighPtr 0))) (* ;; "Scan this page till key is passed") (repeatuntil (\VFMLower key (fetch (Index key) of \VFMhigh)) do (  \VFMReadNext )) (APPLY proc) (if (AND (ILEQ (fetch (Buffer used) of \VFMbuffer) (IQUOTIENT (MESASIZE Buffer) 3)) (NOT (MESAEQUAL (fetch (Interval nextKey) of \VFMinterval) \VFMmaxKey Key))) then (\VFMMerge (fetch (Index key) of \VFMold) level]) (\VFMFreeVPage [LAMBDA (volumePage) (* hts%: " 9-Jan-85 17:31") (* ;;; "volumePage: SWAPPEDFIXP") (* ; "Internal") (* ;;; "calls VolAllocMap.FreePageGroup to free a page of the vfm BTree") (with LogicalVolumeDescriptor \VFMvolumeHandle (PROG [(group (create PageGroup filePage _ volumePage volumePage _ volumePage nextFilePage _ (ADD1 volumePage))) (vfmFileD (ELT \PFFileMapFileD (\PFVolumeNumber \VFMvolumeHandle] (\VAMFreePageGroup \VFMvolumeHandle vfmFileD group))) (\VFMKillBuffer volumePage]) (\VFMGet [LAMBDA (getKey getLevel) (* ; "Edited 22-Oct-87 16:49 by amd") (* ;; "key: Key, level: SMALLP; returns Interval") (DECLARE (SPECVARS getKey getLevel)) (if (GREATERP getLevel treeDepth) then (DiskError "HARD DISK ERROR" "Can't find BTree entry")) (if (EQL getLevel treeDepth) then (* ;;  "If you've run out of interval cache to check, just return the widest possible interval") (create Interval key _ \VFMnullKey volumePage _ (fetch (LogicalVolumeDescriptor vfmStart) of \VFMvolumeHandle ) nextKey _ \VFMmaxKey) else (MESASETQ \VFMinterval (ELT (\VFMGetInterval) getLevel) Interval) (if [OR (\VFMLower getKey (fetch (Interval key) of \VFMinterval)) (NOT (\VFMLower getKey (fetch (Interval nextKey) of \VFMinterval] then (* ;; "If the cached interval for the current level isn't the one you were looking for, then search one level closer to the root of the btree") (\VFMFind getKey getLevel '\VFMGet1)) (ELT (\VFMGetInterval) getLevel]) (\VFMGet1 [LAMBDA NIL (* ; "Edited 22-Oct-87 12:31 by amd") (PROG ((interval (ELT (\VFMGetInterval) getLevel))) (if interval then (replace (Interval key) of interval with (fetch (Index key) of \VFMlow)) (replace (Interval volumePage) of interval with (fetch (Index volumePage) of \VFMhigh)) (replace (Interval nextKey) of interval with (fetch (Index key) of \VFMhigh]) (\VFMInsert [LAMBDA (insertKey insertVolumePage insertLevel) (* ; "Edited 22-Oct-87 14:44 by amd") (* ;; "key: Key, volumePage: PageNumber, level: Level") (* ;; "Inserts an Index containing key and volumePage, calling Split if necessary.") (DECLARE (SPECVARS insertKey insertVolumePage insertLevel)) (PROG (splitFlag) (DECLARE (SPECVARS splitFlag)) (* ;; "Try the insert.") (\VFMFind insertKey insertLevel '\VFMInsert1) (* ;; "If there wasn't enough space to insert, split the page and retry the insertion.") (if splitFlag then (\VFMSplit insertKey insertLevel) (\VFMFind insertKey insertLevel '\VFMInsert1]) (\VFMInsert1 [LAMBDA NIL (* ; "Edited 22-Oct-87 14:44 by amd") (PROG NIL (if (SETQ splitFlag (IGREATERP (fetch (Buffer used) of \VFMbuffer) maxReadPtr)) then (RETURN)) (if (ILESSP \VFMlowPtr (fetch (Buffer used) of \VFMbuffer)) then (\VFMSmartBLT (\ADDBASE \VFMbuffer (IPLUS \VFMlowPtr (TIMES (MESASIZE Index) 2))) (\ADDBASE \VFMbuffer \VFMhighPtr) (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMhighPtr)) (\VFMPutNext insertKey (fetch (Index volumePage) of \VFMhigh) insertLevel) else (\VFMSmartBLT (\ADDBASE \VFMbuffer (IPLUS \VFMlowPtr (MESASIZE Index))) (\ADDBASE \VFMbuffer \VFMhighPtr) (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMhighPtr))) (\VFMPutNext (fetch (Index key) of \VFMhigh) insertVolumePage insertLevel) (replace (Buffer used) of \VFMbuffer with (IDIFFERENCE (IPLUS \VFMlowPtr (fetch (Buffer used) of \VFMbuffer)) \VFMhighPtr)) (\VFMMarkBufferDirty \VFMbuffer]) (\VFMLower [LAMBDA (A B) (* ; "Edited 22-Oct-87 16:49 by amd") (* ;; "a: Key, b: Key; returns BOOLEAN") (* ;; "Compares two keys for ordering: a < b iff a.id < a.id or (a.id = b.id and a.page < b.page) ; any key < maxKey to close key space. Somewhat icky because fileIDs are 32 bit #s where high bit set means high positive number, not negative.") (PROG ((AFILE (fetch (Key fileID) of A)) (BFILE (fetch (Key fileID) of B)) (APAGE (fetch (Key filePage) of A)) (BPAGE (fetch (Key filePage) of B))) (RETURN (OR (if (GEQ AFILE 0) then (if (LESSP BFILE 0) then T else (LESSP AFILE BFILE)) else (if (GEQ BFILE 0) then NIL else (GREATERP AFILE BFILE))) (AND (EQL AFILE BFILE) (OR (ILESSP APAGE BPAGE) (MESAEQUAL B \VFMmaxKey Key]) (\VFMMerge [LAMBDA (mergeKey mergeLevel) (* hts%: "25-Jan-85 12:17") (* ;;; "key: Key, level: SMALLP") (* ; "Internal") (* ;;; "Tries to merge page of oldInterval with next page at same mergeLevel or with root; cannot merge last page of any mergeLevel except rootlevel") (DECLARE (SPECVARS mergeKey mergeLevel)) (PROG (mergeFlag (leftInterval (create Interval)) (rightInterval (create Interval))) (DECLARE (SPECVARS mergeFlag leftInterval rightInterval)) (* ;; "get a valid volumePage") (MESASETQ leftInterval (\VFMGet mergeKey (ADD1 mergeLevel)) Interval) (\VFMFind (fetch (Interval nextKey) of leftInterval) mergeLevel (FUNCTION \VFMMerge1)) (* ; "beware the merging") (* ;; "Get rid of the old reference to the merging page.") (\VFMDelete (fetch (Interval nextKey) of leftInterval) (ADD1 mergeLevel)) (* ;;  "If the page was not actually merged, insert the new Index, else free up the merged page.") (if mergeFlag then (\VFMFreeVPage (fetch (Interval volumePage) of rightInterval)) else (\VFMInsert (fetch (Interval key) of rightInterval) (fetch (Interval volumePage) of rightInterval) (ADD1 mergeLevel]) (\VFMMerge1 [LAMBDA NIL (* ; "Edited 22-Oct-87 16:51 by amd") (PROG (xtraBufferUsed) (MESASETQ rightInterval \VFMinterval Interval) (SETQ \VFMxtraBuffer (\VFMGetBufferFor (fetch (Interval volumePage) of leftInterval ))) (SETQ xtraBufferUsed (fetch (Buffer used) of \VFMxtraBuffer)) (* ;  "xtraBufferUsed used to solve stack modeling error") (if (EQL mergeLevel (SUB1 treeDepth)) then (replace (Buffer used) of \VFMxtraBuffer with 0)) (if (SETQ mergeFlag (ILESSP (IPLUS (fetch (Buffer used) of \VFMbuffer) (fetch (Buffer used) of \VFMxtraBuffer)) (MESASIZE Buffer))) then (* ;; "If merging possible then merge pages. Merge buffer with aux buffer.") (\VFMSmartBLT (\ADDBASE \VFMxtraBuffer xtraBufferUsed) \VFMbuffer (fetch (Buffer used) of \VFMbuffer)) (replace (Buffer used) of \VFMxtraBuffer with (IPLUS (fetch (Buffer used) of \VFMxtraBuffer) (fetch (Buffer used) of \VFMbuffer))) (* ;  "buffer.used remains to prevent Find from attempting a merge") else (* ;; "otherwise balance pages simply to provide hysteresis against futile merge attempts. First find middle.") (while (ILESSP \VFMlowPtr (IQUOTIENT (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) (fetch (Buffer used) of \VFMxtraBuffer)) 2)) do (\VFMReadNext)) (* ;; "move first of \VFMbuffer to xtra") (\VFMSmartBLT (\ADDBASE \VFMxtraBuffer xtraBufferUsed) \VFMbuffer \VFMlowPtr) (* ;; "slide down the rest of \VFMbuffer") (\VFMSmartBLT \VFMbuffer (\ADDBASE \VFMbuffer \VFMlowPtr) (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMlowPtr)) (* ;; "Straighten out end-of-node info.") (replace (Buffer used) of \VFMxtraBuffer with (IPLUS (fetch (Buffer used) of \VFMxtraBuffer) \VFMlowPtr)) (replace (Buffer used) of \VFMbuffer with (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer) \VFMlowPtr)) (* ;; "use \VFMlow to insert while it is still valid") (replace (Interval key) of rightInterval with (fetch (Index key) of \VFMlow))) (* ;; "Finish up.") (\VFMMarkBufferDirty \VFMbuffer) (\VFMMarkBufferDirty \VFMxtraBuffer) (SETQ \VFMxtraBuffer NIL]) (\VFMPutNext [LAMBDA (key volumePage level) (* hts%: "25-Jan-85 15:25") (* ;; "key: Key, volumePage: SWAPPEDFIXP, level: SMALLP") (* ; "Internal") (* ;; "Compresses item in the context of low. Note the side effect on \VFMlow but not on high!! No compression is implemented in this version, but useful one would include: front compression (especially to shrink page groups back to 2 fields)") (MESASETQ \VFMold \VFMlow Index) (SETQ \VFMoldPtr \VFMlowPtr) (replace (Index key) of \VFMlow with key) (replace (Index volumePage) of \VFMlow with volumePage) (MESASETQ (\ADDBASE (fetch (Buffer data) of \VFMbuffer) \VFMlowPtr) \VFMlow Index) (SETQ \VFMlowPtr (IPLUS \VFMoldPtr (MESASIZE Index))) (* ;; "keep cache up to date in the face of changes") (SETA (\VFMGetInterval) level (create Interval key _ (fetch (Index key) of \VFMold) volumePage _ (fetch (Index volumePage) of \VFMlow) nextKey _ (fetch (Index key) of \VFMlow))) (* ;; "Mark buffer dirty") (\VFMMarkBufferDirty \VFMbuffer]) (\VFMReadNext [LAMBDA NIL (* ; "Edited 22-Oct-87 16:52 by amd") (* ;; "Decompresses item at \VFMhigh to become \VFMlow & bumps high. Note the side effect on \VFMlow and not high. No compression is implemented in this version") (OR (ILEQ \VFMhighPtr (fetch (Buffer used) of \VFMbuffer)) (DiskError "HARD DISK ERROR" "Read too far in ReadNext")) (MESASETQ \VFMold \VFMlow Index) (SETQ \VFMoldPtr \VFMlowPtr) (MESASETQ \VFMlow \VFMhigh Index) (SETQ \VFMlowPtr \VFMhighPtr) (if (ILESSP \VFMhighPtr (fetch (Buffer used) of \VFMbuffer)) then (* ; "Loophole") (MESASETQ \VFMhigh (\ADDBASE (fetch (Buffer data) of \VFMbuffer) \VFMhighPtr) Index) (SETQ \VFMhighPtr (IPLUS \VFMhighPtr (MESASIZE Index))) else (* ; "Leave ptr alone") (replace (Index key) of \VFMhigh with \VFMmaxKey) (replace (Index volumePage) of \VFMhigh with nullVolumePage]) (\VFMSplit [LAMBDA (splitKey splitLevel) (* hts%: " 5-Jan-85 16:29") (* ;;; "key: Key, level: SMALLP") (* ; "Internal") (* ;;; "moves half of \DFSVFMbuffer (or root) to xtraBuffer, creating new page of tree") (DECLARE (SPECVARS splitKey splitLevel)) (PROG ((keyStone (create Key)) (page (\VFMCreateVPage))) (* ; "keyStone is the half way mark") (DECLARE (SPECVARS keyStone page)) (\VFMFind splitKey splitLevel (FUNCTION \VFMSplit1)) (\VFMInsert keyStone page (ADD1 splitLevel]) (\VFMSplit1 [LAMBDA NIL (* hts%: "25-Jan-85 12:01") (* ; "Internal") (* ;; "Read in an extra page into which to copy the second half of the current node") (SETQ \VFMxtraBuffer (\VFMGetBufferFor page)) (* ;; "Find the middle of the page to split") (SETQ \VFMhighPtr 0) (replace (Index key) of \VFMhigh with (fetch (Interval key) of \VFMinterval)) (replace (Index volumePage) of \VFMhigh with nullVolumePage) (repeatuntil (IGREATERP \VFMhighPtr (IQUOTIENT (fetch (Buffer used) of \VFMbuffer) 2)) do (\VFMReadNext)) (* ;; "Move the last half of buffer to extra buffer.") (\BLT \VFMxtraBuffer (\ADDBASE (fetch (Buffer data) of \VFMbuffer) \VFMlowPtr) (replace (Buffer used) of \VFMxtraBuffer with (IDIFFERENCE (fetch (Buffer used) of \VFMbuffer ) \VFMlowPtr))) (replace (Buffer used) of \VFMbuffer with \VFMlowPtr) (MESASETQ keyStone (fetch (Index key) of \VFMlow) Key) (* ;; "Mark buffers dirty so that they will be flushed out to disk, and clear the extra buffer holder (just to prevent confusion)") (\VFMMarkBufferDirty \VFMbuffer) (\VFMMarkBufferDirty \VFMxtraBuffer) (SETQ \VFMxtraBuffer NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \VFMmaxID \VFMmaxKey \VFMnullKey \VFMvolumeHandle \VFMinterval \VFMold \VFMlow \VFMhigh \VFMoldPtr \VFMlowPtr \VFMhighPtr \VFMmonitor) ) (* ;; "Buffer management") (DEFINEQ (\VFMGetBufferFor [LAMBDA (VOLPAGENUM) (* ; "Edited 22-Oct-87 16:53 by amd") (* ;; "Try to find btree page in buffer pool. If there, move to front of buffer pool. Otherwise, read in the requred page and put it at the front of the pool. If buffer pool is > maxbufferpoolsize then flush the last page in the pool") (LET ((BUFFER (\VFMKillBuffer VOLPAGENUM)) LAST FLUSH) (if BUFFER then (* ;; "Move buffer to front of buffer list") (push \VFMbufferPool BUFFER) else (* ;; "Create and read in new buffer") (push \VFMbufferPool (SETQ BUFFER (create \BTREEBUF VOLUME _ \VFMvolumeHandle VOLPAGENUM _ VOLPAGENUM PAGE _ (create Buffer) DIRTY _ NIL))) (\PFGetFileMapPage \VFMvolumeHandle VOLPAGENUM (fetch (\BTREEBUF PAGE) of BUFFER)) (* ;; "Shorten buffer pool if necessary") (if [SETQ FLUSH (CDR (SETQ LAST (FNTH \VFMbufferPool \VFMbufferSize] then (RPLACD LAST NIL) (\VFMSaveBuffer T FLUSH))) (* ;; "Finally set the main buffer page to be the selected buffer page.") (fetch (\BTREEBUF PAGE) of BUFFER]) (\VFMSaveBuffer [LAMBDA (notAll whichBuffers evenIfNotDirty) (* ; "Edited 22-Oct-87 16:54 by amd") (* ;;  "Flushes dirty buffers. If notAll is true, then it is to save only the specified buffers") (OR notAll (SETQ whichBuffers \VFMbufferPool)) (for BUF inside whichBuffers when (OR (fetch (\BTREEBUF DIRTY) of BUF) evenIfNotDirty) do (\PFPutFileMapPage (fetch (\BTREEBUF VOLUME) of BUF) (fetch (\BTREEBUF VOLPAGENUM) of BUF) (fetch (\BTREEBUF PAGE) of BUF)) (replace (\BTREEBUF DIRTY) of BUF with NIL]) (\VFMClearBuffers [LAMBDA NIL (* hts%: "16-Nov-84 15:38") (* ;;; "Clear the btree node cache") (SETQ \VFMbufferPool NIL]) (\VFMKillBuffer [LAMBDA (VOLPAGENUM) (* ; "Edited 22-Oct-87 14:53 by amd") (* ;;  "Remove the buffer for a btree node which is being decommissioned. Return the removed buffer.") (if (AND (LISTP \VFMbufferPool) (\VFMCorrectBufferP (CAR \VFMbufferPool) VOLPAGENUM)) then (CL:POP \VFMbufferPool) else (bind CURRENT for PREV on \VFMbufferPool do (if (AND (LISTP (SETQ CURRENT (CDR PREV))) (\VFMCorrectBufferP (CAR CURRENT) VOLPAGENUM)) then (RETURN (PROG1 (CAR CURRENT) (RPLACD PREV (CDR CURRENT)))]) (\VFMCorrectBufferP [LAMBDA (BUFFER VOLPAGENUM) (* ; "Edited 22-Oct-87 16:54 by amd") (* ;; "True iff BUFFER is the right buffer for VOLPAGENUM") (AND (EQL (fetch (\BTREEBUF VOLUME) of BUFFER) \VFMvolumeHandle) (EQL (fetch (\BTREEBUF VOLPAGENUM) of BUFFER) VOLPAGENUM]) (\VFMMarkBufferDirty [LAMBDA (BUFFERPAGE) (* ; "Edited 22-Oct-87 15:13 by amd") (* ;;  "Note that the specified buffer has been written into and will have to be flushed out to disk.") (replace (\BTREEBUF DIRTY) of (for BUF in \VFMbufferPool thereis (EQL BUFFERPAGE (fetch (\BTREEBUF PAGE) of BUF))) with T) NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \VFMbufferPool \VFMbufferSize \VFMbuffer \VFMxtraBuffer) ) (RPAQ? \VFMbufferSize 10) (* ;; "Interval cache interface") (DEFINEQ (\VFMCreateIntervals [LAMBDA NIL (* ; "Edited 22-Oct-87 16:55 by amd") (* ;; "Conditionally create array to hold interval cache for each volume. Conditional so that loadfroming this file will not destroy state.") (* ;; "Interval cache for each volume keeps a finger into the BTree: traces a correct path through the BTree, which need be only partially backtracked (if at all) to find any given interval in the BTree. Saves reading one page at each level of the BTree every time you want to look for an interval.") (if [NOT (AND (BOUNDP '\VFMintervals) (type? ARRAYP \VFMintervals) (ZEROP (ARRAYORIG \VFMintervals)) (EQL maxLogicalVolumes (ARRAYSIZE \VFMintervals] then (SETQ \VFMintervals (ARRAY maxLogicalVolumes NIL NIL 0]) (\VFMClearIntervals [LAMBDA NIL (* hts%: " 5-Jan-85 16:25") (* ;;; "Clears the BTree interval cache so that it will be correctly reinitialized should this lisp image wake up on an alien machine") (for volume from 0 to (SUB1 maxLogicalVolumes) do (SETA \VFMintervals volume NIL]) (\VFMGetInterval [LAMBDA NIL (* ; "Edited 22-Oct-87 12:09 by amd") (* ;; "Returns the interval cache for the current volume. If this interval cache is empty, initializes with a leftmost path through the BTree for that volume.") (PROG ((volNum (\PFVolumeNumber \VFMvolumeHandle))) (RETURN (OR (ELT \VFMintervals volNum) (SETA \VFMintervals volNum (bind (intervalArray _ (ARRAY treeDepth NIL NIL 0)) (BTreePageNum _ (fetch (LogicalVolumeDescriptor vfmStart) of \VFMvolumeHandle)) for level from (SUB1 treeDepth) to 0 by -1 do (SETQ \VFMbuffer (\VFMGetBufferFor BTreePageNum)) [SETQ BTreePageNum (fetch (Interval volumePage) of (SETA intervalArray level (create Interval key _ \VFMnullKey volumePage _ (fetch (Index volumePage ) of \VFMbuffer) nextKey _ (fetch (Index key) of \VFMbuffer] finally (RETURN intervalArray]) (\VFMBlankInterval [LAMBDA NIL (* hts%: "26-Jan-85 18:57") (* ;;; "Returns the interval cache for the current volume. If this interval cache is empty, initializes with a blank set of intervals with InitMap will fill with a leftmost path through the BTree for that volume.") (* ;;; "Should be called by InitMap only.") (PROG ((volNum (\PFVolumeNumber \VFMvolumeHandle))) (RETURN (OR (ELT \VFMintervals volNum) (SETA \VFMintervals volNum (PROG ((intervalCache (ARRAY treeDepth NIL NIL 0))) (for level from 0 to (SUB1 treeDepth) do (SETA intervalCache level (create Interval))) (RETURN intervalCache]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \VFMintervals) ) (* ;; "BLT routine that doesn't stomp on itself for overlapping intervals") (DEFINEQ (\VFMSmartBLT [LAMBDA (DBASE SBASE NWORDS) (* hts%: "24-Jun-84 15:57") (* ;  "This is necessary because \BLT will not copy overlapping intervals correctly in one direction.") (if (AND (PTRGTP SBASE DBASE) (PTRGTP (\ADDBASE DBASE NWORDS) SBASE)) then (for i from 0 to (SUB1 NWORDS) do (\PUTBASE DBASE i (\GETBASE SBASE i))) DBASE else (\BLT DBASE SBASE NWORDS]) ) (* ;; "Loading initialization") (DEFINEQ (\VFMAtLoad [LAMBDA NIL (* hts%: "25-Jan-85 11:50") (* ;;; "Initialize global variables for the volume file map") (SETQ \VFMmaxID -1) (SETQ \VFMmaxKey (create Key fileID _ \VFMmaxID filePage _ lastPageNumber)) (SETQ \VFMnullKey (create Key)) (SETQ \VFMvolumeHandle NIL) (SETQ \VFMinterval (create Interval)) (SETQ \VFMold (create Index)) (SETQ \VFMlow (create Index)) (SETQ \VFMhigh (create Index)) (SETQ \VFMoldPtr 0) (SETQ \VFMlowPtr 0) (SETQ \VFMhighPtr 0) (\VFMCreateIntervals) (SETQ \VFMmonitor (CREATE.MONITORLOCK '\VFMmonitor]) ) (\VFMAtLoad) (PUTPROPS LOCALFILE MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (PUTPROPS LOCALFILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2508 3823 (\PFFetchString 2518 . 3151) (\PFReplaceString 3153 . 3821)) (37577 42374 ( CREATEDSKDIRECTORY 37587 . 38940) (PURGEDSKDIRECTORY 38942 . 40941) (LISPDIRECTORYP 40943 . 41399) ( VOLUMES 41401 . 42081) (VOLUMESIZE 42083 . 42372)) (42375 43128 (\DFSCurrentVolume 42385 . 42760) ( \DFSFreeDiskPages 42762 . 43126)) (43129 44598 (\LFEntryPoint 43139 . 44170) (\LFNormalizeVolumeName 44172 . 44596)) (44634 48390 (\LFCreateDevice 44644 . 47175) (\LFOpenDevice 47177 . 48010) ( \LFCloseDevice 48012 . 48388)) (48619 65957 (\LFOpenFile 48629 . 53033) (\LFGetStreamForFile 53035 . 56588) (\LFOpenOldFile 56590 . 58589) (\LFGenFileID 58591 . 58892) (\LFCreateFile 58894 . 61644) ( \LFMakeLeaderPage 61646 . 63635) (\LFUpdateLeaderPage 63637 . 65562) (\LFWriteLeaderPage 65564 . 65955 )) (65958 67464 (\LFCloseFile 65968 . 67462)) (67465 68700 (\LFDeleteFile 67475 . 68698)) (68701 72135 (\LFReadPages 68711 . 72133)) (72136 76351 (\LFWritePages 72146 . 73350) (\LFExtendFileIfNecessary 73352 . 75079) (\LFExtendFile 75081 . 76349)) (76352 80009 (\LFGetFileInfo 76362 . 78618) ( \LFSetFileInfo 78620 . 80007)) (80010 80501 (\LFGetFileName 80020 . 80499)) (80502 82897 (\LFEventFn 80512 . 82895)) (82898 84456 (\LFDirectoryNameP 82908 . 84454)) (84457 86595 (\LFTruncateFile 84467 . 86593)) (86596 92372 (\LFRenameFile 86606 . 92370)) (99417 102906 (\LFFindDirectory 99427 . 99894) ( \LFFindDirectoryVol 99896 . 101453) (\LFParseFileName 101455 . 102904)) (102957 107926 ( \LFMakeVolumeDirectory 102967 . 104513) (\LFDirectoryP 104515 . 106689) (\LFPurgeDirectory 106691 . 107617) (\LFCloseDirectory 107619 . 107924)) (108012 115808 (\LFMakeDirEntry 108022 . 110144) ( \LFRemoveDirEntry 110146 . 111573) (\LFReadFileID 111575 . 112132) (\LFFindDirHole 112134 . 114249) ( \LFMakeDirHole 114251 . 115566) (\LFCheckBang 115568 . 115806)) (115809 122057 (\LFDirectorySearch 115819 . 119292) (\LFVersions 119294 . 122055)) (122058 129416 (\LFFileSpec 122068 . 125607) ( \LFUnpackName 125609 . 127660) (\LFFullFileName 127662 . 128519) (\LFFileName 128521 . 129414)) ( 129417 130511 (\LFDirectoryScrambled 129427 . 130509)) (130512 131083 (\LFDWIN 130522 . 130798) ( \LFDWOUT 130800 . 131081)) (131123 143716 (\LFGenerateFiles 131133 . 135693) (\LFFindNextFile 135695 . 138035) (\LFSortFiles 138037 . 138971) (\LFHighestVersions 138973 . 139726) (\LFFindInfo 139728 . 142609) (\LFReturnNextFile 142611 . 143205) (\LFReturnInfo 143207 . 143714)) (143830 144768 ( \LFGetDirectory 143840 . 144047) (\LFPutDirectory 144049 . 144278) (\LFCreateDirectories 144280 . 144766)) (144904 146272 (\LFINITCASEARRAY 144914 . 146057) (\LFCASEARRAYFETCH 146059 . 146270)) ( 147394 155759 (FILENAMEFROMID 147404 . 148525) (SCAVENGEDSKDIRECTORY 148527 . 154142) (SCAVENGEVOLUME 154144 . 154339) (\LFScavFileName 154341 . 155297) (\LFScavVersion 155299 . 155757)) (155882 157082 ( \VFMGenerateFileIDs 155892 . 157080)) (161347 161540 (\PFGetPhysicalVolumePage 161357 . 161538)) ( 161541 162183 (\PFGetLogicalVolumePage 161551 . 161865) (\PFPutLogicalVolumePage 161867 . 162181)) ( 162184 162964 (\PFGetMarkerPage 162194 . 162577) (\PFPutMarkerPage 162579 . 162962)) (162965 163751 ( \PFGetFreePage 162975 . 163370) (\PFCreateFreePage 163372 . 163749)) (163752 164430 ( \PFGetAllocationMapPage 163762 . 164106) (\PFPutAllocationMapPage 164108 . 164428)) (164431 165061 ( \PFGetFileMapPage 164441 . 164749) (\PFPutFileMapPage 164751 . 165059)) (165062 166355 (\PFGetPage 165072 . 165506) (\PFPutPage 165508 . 165883) (\PFCreatePage 165885 . 166353)) (166356 169320 ( \PFTransferFilePage 166366 . 169318)) (169321 170724 (\PFTransferPage 169331 . 170722)) (171526 177225 (\PFCreateFileDescriptors 171536 . 174547) (\PFInitFileDescriptors 174549 . 177223)) (177440 177827 ( \PFCreatePhysicalVolume 177450 . 177825)) (177973 180684 (\PFCreateVols 177983 . 179374) ( \PFInitializeVols 179376 . 179734) (\PFGetVols 179736 . 180134) (\PFGetVol 180136 . 180280) ( \PFVolumeNumber 180282 . 180682)) (180798 181433 (\PFGetLVPage 180808 . 181431)) (181467 182492 ( \PFVersionOK 181477 . 182074) (\PFPilotVolumeP 182076 . 182490)) (182531 184076 (\PFEnsureInitialized 182541 . 184074)) (184320 185907 (\PFFindDirectoryID 184330 . 184821) (\PFInsertDirectoryID 184823 . 185316) (\PFRemoveDirectoryID 185318 . 185905)) (185908 189236 (\PFFindRootDirEntry 185918 . 186648) ( \PFAddRootDirEntry 186650 . 187316) (\PFRemoveRootDirEntry 187318 . 188252) (\PFFindRootDirEntryNum 188254 . 188915) (\PFPatchRootDirEntries 188917 . 189234)) (189237 192440 (\PFGetRootDirectory 189247 . 190319) (\PFPutRootDirectory 190321 . 191083) (\PFCreateRootDirectory 191085 . 191899) ( \PFPurgeRootDirectory 191901 . 192438)) (192441 193337 (\GetRootDirectoryType 192451 . 192673) ( \PFPutRootDirectoryType 192675 . 193335)) (193377 202373 (\PFNewPages 193387 . 195900) (\PFTrimHelper 195902 . 198624) (\PFFindPageAddr 198626 . 200206) (\PFFindFileSize 200208 . 200861) (\PFFreeDiskPages 200863 . 201226) (\PFRoomForFile 201228 . 202125) (\PFSaveBuffers 202127 . 202371)) (202401 205162 ( \PFCurrentVol 202411 . 205160)) (205280 205554 (\PFDsplyVolumes 205290 . 205552)) (208010 216668 ( \VAMAllocPageGroup 208020 . 211870) (\VAMFreePageGroup 211872 . 215343) (\VAMInit 215345 . 215574) ( \VAMRecomputeFreePageCount 215576 . 216666)) (216704 223431 (\VAMFilePageNumber 216714 . 217166) ( \VAMEnoughSpace 217168 . 218208) (\VAMFindFreePages 218210 . 220654) (\VAMCheckEndOfVol 220656 . 221039) (\VAMUpdateVAM 221041 . 222414) (\VAMAdjustGroup 222416 . 223429)) (223733 225860 ( \VAMGetVAMPageFor 223743 . 224891) (\VAMBufferInit 224893 . 225238) (\VAMBufferSave 225240 . 225608) ( \VAMMarkBufferDirty 225610 . 225858)) (229940 231474 (ShowIntervals 229950 . 231472)) (231717 232169 ( \VFMInit 231727 . 232167)) (232255 249493 (\VFMDeletePageGroup 232265 . 242991) (\VFMGetPageGroup 242993 . 245548) (\VFMInsertPageGroup 245550 . 249491)) (249578 274646 (\VFMContextSet 249588 . 249791 ) (\VFMCreateVPage 249793 . 250720) (\VFMDelete 250722 . 252344) (\VFMDelete1 252346 . 253587) ( \VFMDelete2 253589 . 255115) (\VFMFind 255117 . 256666) (\VFMFreeVPage 256668 . 257459) (\VFMGet 257461 . 259010) (\VFMGet1 259012 . 259926) (\VFMInsert 259928 . 260697) (\VFMInsert1 260699 . 262597) (\VFMLower 262599 . 263792) (\VFMMerge 263794 . 265395) (\VFMMerge1 265397 . 269561) (\VFMPutNext 269563 . 270890) (\VFMReadNext 270892 . 272112) (\VFMSplit 272114 . 272803) (\VFMSplit1 272805 . 274644)) (274875 279278 (\VFMGetBufferFor 274885 . 276582) (\VFMSaveBuffer 276584 . 277315) ( \VFMClearBuffers 277317 . 277505) (\VFMKillBuffer 277507 . 278351) (\VFMCorrectBufferP 278353 . 278730 ) (\VFMMarkBufferDirty 278732 . 279276)) (279459 283645 (\VFMCreateIntervals 279469 . 280362) ( \VFMClearIntervals 280364 . 280725) (\VFMGetInterval 280727 . 282617) (\VFMBlankInterval 282619 . 283643)) (283795 284472 (\VFMSmartBLT 283805 . 284470)) (284513 285258 (\VFMAtLoad 284523 . 285256)))) ) STOP \ No newline at end of file diff --git a/sources/LOGOW b/sources/LOGOW new file mode 100644 index 00000000..e0989c8d --- /dev/null +++ b/sources/LOGOW @@ -0,0 +1,126 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED " 9-Apr-2000 18:08:21" |{DSK}sybalsky>lispcore>sources>LOGOW.;2| 13624 + + |changes| |to:| (FNS LOGOW) + + |previous| |date:| "12-Jul-91 03:16:46" |{DSK}sybalsky>lispcore>sources>LOGOW.;1|) + + +; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 2000 by Venue. All rights reserved. + +(PRETTYCOMPRINT LOGOWCOMS) + +(RPAQQ LOGOWCOMS ((VARIABLES LOGOW) + (FNS LOGOW) + (VARS LOGOBITMAP (LOGOTITLEFONT (FONTCREATE '(HELVETICA 6))) + (LOGONAMEFONT (FONTCREATE 'HELVETICA 36 'BOLD))) + (ADDVARS (AFTERMAKESYSFORMS (LOGOW NIL))))) + +(CL:DEFVAR LOGOW) +(DEFINEQ + +(LOGOW + (LAMBDA (STRING WHERE TITLE TITLE-LOCATION) (* \; "Edited 12-Jul-91 03:12 by jds") + (CL:WHEN (WINDOWP LOGOW) + (CLOSEW LOGOW)) + (OR STRING (SETQ STRING (CL:STRING-CAPITALIZE MAKESYSNAME))) + (* \; "(LOGOW NIL) gives default") + (OR TITLE-LOCATION (SETQ TITLE-LOCATION :LINE)) + (OR TITLE (SETQ TITLE (CL:FORMAT NIL + "Copyright (c) ~D Venue, Oakland, CA. All Rights Reserved." + (LOADTIMECONSTANT (CL:MULTIPLE-VALUE-BIND (A B C D E YEAR) + (CL:GET-DECODED-TIME) + YEAR))))) + (LET* ((SHADOWDX 2) + (SHADOWDY 2) + (TITLE-BOTTOM-HEIGHT (COND + ((EQ TITLE-LOCATION :BOTTOM) + (* \; + "Magic 4 again, just a little space above the copyright notice.") + (+ (FONTHEIGHT LOGOTITLEFONT) + 4)) + (T 0))) + (LINE (COND + ((EQ TITLE-LOCATION :LINE) + (FONTHEIGHT LOGOTITLEFONT)) + (T 4))) + (SLEN (STRINGWIDTH STRING LOGONAMEFONT)) + (WLEN (+ (MAX SLEN (+ (BITMAPWIDTH LOGOBITMAP) + 2 2) + (STRINGWIDTH TITLE LOGOTITLEFONT)) + (PROG1 (+ 4 4) (* \; "left and right margin") + ))) + (WHT (+ (FONTHEIGHT LOGONAMEFONT) + (PROG1 (+ 4 LINE 4 4) (* \; + "below line, line, above line, above bitmap") + ) + (BITMAPHEIGHT LOGOBITMAP) + TITLE-BOTTOM-HEIGHT)) + (TEMP (BITMAPCREATE WLEN WHT)) + (IMAGE (BITMAPCREATE WLEN WHT)) + (MASK (BITMAPCREATE WLEN WHT)) + (STREAM (DSPCREATE TEMP)) + WINDOW LINEY LINEX TITLEWIDTH) + (BITBLT LOGOBITMAP NIL NIL STREAM (DIFFERENCE WLEN (+ (BITMAPWIDTH LOGOBITMAP) + (PROG1 6 + (* \; "right margin")))) + (+ TITLE-BOTTOM-HEIGHT (FONTHEIGHT LOGONAMEFONT) + 4 LINE 4)) + (DSPFONT LOGONAMEFONT STREAM) + (MOVETO (- WLEN 4 (STRINGWIDTH STRING STREAM)) + (+ (FONTDESCENT LOGONAMEFONT) + TITLE-BOTTOM-HEIGHT) + STREAM) + (PRIN3 STRING STREAM) + (BITBLT STREAM 0 0 IMAGE NIL NIL NIL NIL NIL 'ERASE) + (BITBLT STREAM 0 0 IMAGE SHADOWDX (- SHADOWDY) + NIL NIL NIL 'PAINT) + (BITBLT STREAM 0 0 MASK SHADOWDX (- SHADOWDY) + NIL NIL NIL 'PAINT) + (BITBLT STREAM 0 0 MASK NIL NIL NIL NIL NIL 'PAINT) + (SETQ TITLEWIDTH (STRINGWIDTH TITLE LOGOTITLEFONT)) + (BITBLT NIL NIL NIL IMAGE (SETQ LINEX 6) + (SETQ LINEY (+ TITLE-BOTTOM-HEIGHT (FONTHEIGHT LOGONAMEFONT) + 4)) + (IMAX TITLEWIDTH (BITMAPWIDTH LOGOBITMAP)) + LINE + 'TEXTURE + 'PAINT BLACKSHADE) + (BITBLT NIL NIL NIL MASK LINEX LINEY TITLEWIDTH LINE 'TEXTURE 'PAINT BLACKSHADE) + (SETQ STREAM (DSPCREATE IMAGE)) + (DSPFONT LOGOTITLEFONT STREAM) + (DSPOPERATION 'ERASE STREAM) + (DSPTEXTURE BLACKSHADE STREAM) + (MOVETO (ADD1 LINEX) + (+ (FONTDESCENT LOGOTITLEFONT) + (COND + ((EQ TITLE-LOCATION :BOTTOM) + 0) + (T LINEY))) + STREAM) + (PRIN3 TITLE STREAM) + (SETQ WINDOW (ICONW IMAGE MASK (OR WHERE (CREATEPOSITION (- SCREENWIDTH WLEN) + (- SCREENHEIGHT WHT))))) + (WINDOWPROP WINDOW 'BUTTONEVENTFN 'MOVEW) + (WINDOWPROP WINDOW 'TYPE 'LOGOW) + (WINDOWPROP WINDOW 'CLOSEFN (FUNCTION (LAMBDA NIL + + (* |;;| + "Set LOGOW to NIL when closing the window") + + (SETQ LOGOW NIL)))) + (SETQ LOGOW WINDOW)))) +) + +(RPAQQ LOGOBITMAP #*(288 110)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOL@@COO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOL@@COO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AN@@@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@G@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@@N@@@@CO@@@OL@OH@@GO@@GH@@@OL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@AL@@@@OOL@@OLGOL@@GO@@GH@@COO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@AL@@@AOON@@OLOON@@GO@@GH@@GOOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@CH@@@CN@O@@OMO@N@@GN@@G@@@OHCL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@GH@CH@@@GL@G@@COL@N@@AN@@O@@AO@AL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@G@@@@OH@CH@GOH@N@@AL@@O@@CN@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@G@@@AO@@CH@GO@@N@@CL@@N@@GL@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@N@@@CN@@CH@GL@@N@@CH@@N@@GH@@N@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CL@N@@@CL@@GH@GL@AN@@GH@AN@@G@@AN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CLAL@@@CH@AOH@OH@AL@@G@@AL@@O@@GN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@CLAL@@@CH@GN@@O@@CL@@O@@AL@@N@AOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANCH@@@GH@OH@@O@@CH@@N@@CL@@N@CN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANCH@@@GHCN@@AO@@CH@@N@@CL@AN@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANG@@@@GOOL@@AN@@GH@AN@@CH@AOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ANG@@@@GOO@@@AN@@G@@AL@@GH@AOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AON@@@@GOL@@@CN@@O@NAL@@G@@AOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AON@@@@G@@@@@CL@@NANAL@@O@CIL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AOL@@@@G@@@N@CL@@NCLAL@@O@CIL@@CH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OL@@@@GH@AN@GL@ALCHAN@AO@GIL@@GH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OH@@@@GL@CL@GH@ALO@AN@GO@OAN@@O@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OH@@@@CN@GH@GH@AMN@@OOOOAN@O@AN@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@@@AOOO@@GH@AOL@@GOOCOL@GOOL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@@@@OON@@G@@AOH@@CONCOH@COOH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@COH@@G@@@O@@@AOHAO@@@ON@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) + +(RPAQ LOGOTITLEFONT (FONTCREATE '(HELVETICA 6))) + +(RPAQ LOGONAMEFONT (FONTCREATE 'HELVETICA 36 'BOLD)) + +(ADDTOVAR AFTERMAKESYSFORMS (LOGOW NIL)) +(PUTPROPS LOGOW COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 2000)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (741 5414 (LOGOW 751 . 5412))))) +STOP diff --git a/sources/LispDMC.DM b/sources/LispDMC.DM new file mode 100644 index 0000000000000000000000000000000000000000..e88c9f69050f3a97e7444b1ee3971f6241f9a826 GIT binary patch literal 354892 zcmdSC3v{H}R^K;-m_^yQ?1dMP7$@YLp4@w-Zb{Q6bxSkq+ZU?z=++&*rc~Y27tstQ zsU+3yQkAI3bocNGctH{ZICcVFv12g!kq|Ef0UIa0VlT2tOh_QHv6t-x+q{CoUNP~) zgh#mK_uu=R?@^Mvd!{?Y9^>1p^PR^&`|Pt{XPTdd3{+Z$8K$9moMsbsA?7&bed)g9UTw(>$rK49Q3*^idspJ|LG?O&BrfK=AoF& zptzogqB$6h`mJPpXJ&hK>y4z>P1;?4HL8u3sifIG(9kEX{!uI089vy4J82|T7=VOt z`SM}%usu9Zx~)e;+O=jFZn?GJI@x3V1siTQNh*t#icNZ>IcRr>t$w+jB%1q9Yq-1K z9-R80R0oaae(Pv!yRuuE2WdOQ=Kh0PeM-}|MVLyuz0Kw3uqlKm$-(I4Fe zuCFxi)HipVozcy!0!YBV(d|8~*O~(sys@&et#V2mTOi>hKf0Z)uiRZ(r|JjFKvi!Y zGJ9aqQf&9z-Tkf8fkAfKZ=Z-B4to2elU8@w6wJa|wbMzuBVlcjG+Bz?K4g)!9__bI zhsm&g((WD&rjm!p?fql>e$d*dr_PLq6E>2;us_-#vWf$yd^zz+SNlhcN#o<&E6L4d zqq=l^ZF41AUfEvRTwd91B=wc0t@?7ZTi)1N+O5@Q4hF;Z-c-WWN??j#i|VF&a6qSn zsa&nwZC|Oh9Z2}Sn?ov3C9@zVEg#lSJ5$MA+95v|leNvp%B_`p+TozTuVJrwEqI zxx|vR`tP*(vU_!AW`X}|_f@{vX4OL%EZd*`h34`iSC69W28kWQpUM-0V&MXs)@^*4HEX?#Y6{d|Lp7vYL3=&wp zDEqXNv=0-_g}vLT-&uilZt-io**|%fRU9V~qX&i-kv!fyJRG!ggrY**1sjN+!B)4G zqan2^0Vxm;Kuj_?ZS4d0myV!>L2{LrzAwg`f`t3;It_lH{K0YqRycb#@TElP6KxHW z32?sG?iwQ;X!5?E>2iTvu_85?6z3}+wBKnTATL2%FS(ZNcMx7;dZlXVpfwnR-opv? zF0TR96-a}X*VgT|mh2OvkKqPJ8Kq{ou zOF+WEwKZX%Crg5=6edcAHd27Qmqiz`^|3BLG_qQE_GUm!%Jc!$)&y| z&LuRUoB|;MFmNra(|d?wp_<23)SoV#TQE#^BRg~0ey7!eAGW&(t_MXsza_xjC)ULuU}4>BETB`md2ESX~lcXOD)chHOWdxPOrd3f9gn~`H1 z2SN3F*nB)lMzDl2AcURvVH^1N9@{5Sz>YjYubqi|+{BeMM|N`3K4LGn;OxRT48T5` z5YkshI6&d;&{q$>!pvFzR+*JIpwU9RyVJ5UtYeituvM<>ud%J9C8ZaybW^fu20*3~tBY)|EKE;K zgwiV}M5im0$w}`3ad+PGSrq~QP>k^x{t}y8+jYM)I*7Y*Y=`C1f*x*5e{wn+Iw>!| zC2bZ!CcNh>5ya#QuuZ-?dzA&;!Gh>C`)~$!4cpzM9y~=Y4V34FV&@DL2s$AugQ6TD z)mnw>2kpZ{kWl+YwmG|!{e8mDPOiKGe55FyQd5YJ346{w3|biaQU#;5yLjJJ9lGcBY}kPkdao&rU~ap z!#cb3J8d|GY;M*KIRedeS~jPtvN+CuzvpayY*#`AD~E@ffOw{@BX@$9%V?%~(xQ`w zn6B6qnp<#OKv0(i&Lu0Kj9hI{HkJzqI;Ia~-4Q%yz#2evV_Pmc8L{jjVg9d)5uBbf z$phwgGU^PQ-Bxcj=scdmw%*R9R$!;8;0hdZ*azv3^5H{qMH5PcMVrDB>TBHh<%v$O zDLwMA-#bax_%s>qYis1ME&~|mzW|{i;eT9*Naa)s)bG5+7Q)BMf7Sjr5s?FxUR#e^`^F(O z3jTxE;D(XbR06E+P7*q@n#WDBkD!YX^^rV=8Uuo9M-sST2x^=lDSa3Rrr&A~f-}aX zbhF=Yc8|=m(wvc3rxKV$D0sWyT5Sz+Yf#AI8{i<}8-5dz%B^==@}33E!xJ_%5T?j} zd%zaM%xhtV(yB=Z$Gv|0U0i2SoL0=`P=3vG=+@Lw)iJRGl0TBn&iUr^g6T@q>WIq2 z&$-CclPj}RFi;E*b^TGcES+eB7;}L?44Wn&**Xx4A;!pN#v5pldjr6hc7q;a#zX_4aUk}a$!rcvIC_tYm6LXF+<24|K%_sH305k1F zL(fb?LAG7TNFle(Y^Y?q5|%hr{s=Z&kyOg1@ad+1f_Of1GXnmRe9>+-D@w2Bj47Hs6` znU+F2NE%a9JN^B)4wC68dBl@|`w9Bh_=Ho@(OWb4uo_yFY?x*~o}GXXh#$9Jf)R(*dG#ZEA+V zoVE%=Lpm?i7Z$IF$|d_@P@drLW(OMr9Qs7naZY!^n*l^RC{RE8sGd##0rBc1m<(8h z1LPn$*bz^dc|F=q1_bNGMr`8xMR=e>CHs%}I~1yOES!T8W}fwKh*bCG*!=|P(>k*r z*$Sw}WHeT+FEncdAS|*_LnBFSY=Hzn5^O~?H^f*A2A5@O4tbbyIvzN}qs?eo5J$<* z?W!-z?HYRWZ7fKR7j9Q?)??|-#yHX09Hv3S%eNps4fu4*vo)WZYD@)1{=LzP)+LaL zYcIxSCFH<5|JQm1>Lu16qxj(>+RxV7@DX>2t4vyy)O9A~(f2|Q6D|S`N38>vJVQ$( zMN1vD)Iq|l|FCt0*R_Kk9~UgOm5r%rbzR7?;W~(9o zqiW?wf~mbU^Ll{~=j-KY+H6xZF(3f+ZDB9}*#^Yt0y~%1<=gRKlof0grY%<+FI?#F+Nu0c@N!}4ecIM(~X(Fe30y$ zkqZK8{%jc77D)KC1(-ze$R0|W(*82%M8QIkUrL%;4r6DUl{LDS7fszYiogZ~lZs47 zfja2EdAs4-vaga}4PALZi9mc`C3~7QY$F@R4zS>He zV$140ZDp9rpvPKP(X_C*+du*|gWxz8p_EVBSZVvc1C|dRSa!TngDL=JgCB5s3QIAV z!naGN9bK}8VF3BKZj?t|7GXHTcWy4f;W0?~Q@;)&%GYDMRp8uoB8&!C6f(lMuWLv) zHdqHQr{a-1Vcf?epb_$8kK+*A`|{2lQP%3d)9&}WIwNs6r$7(QG4xJxI-<9OG$>Xr zrcDUK%Wz~tS;heXrdC@T_T|V!8SOcv$OzZ<>B5`?MKt$VS|d^Ol*uMsbJ^v7b07x^ zKmYBl6D@o)wqpl=q$2d#N=wS3Aly~>}EQQOllHLZ$XQpHYM@7iJXa0cKY&j1^1D4y3$0hA9H_*g4G9rRj* z?uX6uinB^n^39`_AC3+WSq6}B>zB;V0w9#~0FnSHo2`^WB0w}7^Tm1pX5IS=HoH9z z#-vJd0;H9Wr`c}XAGY^>>I|(t2h|?2{(YULF&h*#C<1SVq)rdlG?Z%I5Hu9+&|}UG z@e<%6HOD|pT&oGiX-C%F4b1Lmau}p?)e373u`s3qr!{00{lDd5^Fh#eT0+9#Y!9%d zVHB7HF2R7*=7%nFVAe@kB{p{Ek{>kR5iEpe3|nQ%KId4{k^3VKv1Ob7LBJ|T zXF#;oq`JABY;HA@+9c%Bb%mpB5P`b2SGNey89W%k#A>zWz@}?8Gektlg8$z_c z+v@iWXXd9u`Mx3g^vY^R>wFvN=qqQxm{Tv1@SCp-o8IoA_mIdFn2`H!WCM6T2?t|{ zniE37ridtzxRf73PC-`@nN(rU*aH&CFfSBS%{|ftsFxRhU)$dxkbD`$ox+-j?IYK_ z^D4HBneIi*S>wWxi~u6@MaGB@wZRxw3L)-5y5fiU07&?muL4W~AY~x%i(U^_E5RqB zZ14n@Y1^_^M}Lvz$S<%Q6({Y3X%2>4%@docc)wWwVVuu6I~eR^axn}|4I<-2CkPONdvr-f;E@c=83L4w=(B~Viu zxzpQT zcUBK+5k0TeVk4&N22DdmmGG7_ce?7ZU8mYL?V#}Wy7)tb*z6&8#co-y{Ridp>v(lt@lK*Im@^E!7* zTVf_6ZltbjZt5aCG(3yMj9P4i?BV6b*=UM~nr3M8jo8+Y)GJ2Kjt3xnR7+(|t zvq(_OTo?xi3g;W0luM=L%KVdhEtRg!EfgwfUK7R8qbnS|LJF=rpIWR0D?Q7=Ul~T8 zt(+Y>Hy@DjGrwW(?&7XD_+~FaNV(DD$YHP;X1DO#*boG#&2vK1WTi$YNeatr^JnW3 zl$+KoZ}x`7VL<{?+)$T~;aY4=STsCFUQ5LvBz{7Y?o5NxkEo@AV_E1BR%gaVgF;)N zG7k~$z)@fzuCthV1ro0PW#C}L$Y<_>tLe|+v?rqL1Le!p@Bcr-+3M3#B|;Y-;3_pB z7N4(MCN!*X)X}+nUE&z|V_<=c4YpD&NAPocbSPShdM}ez8$|>xw+;t0AmJOo=42m7 z+ucpNLFejE6hj4jsx2+oy8Kc!U~HVq2t@GkVGC)KuAdAo zYeyGpyHuYlP$0*}>8A9d>Uj8kB>jb~?6kT^oFh&^0$3U7qm-GXpG=3z+MFE)Bz*b} z3wawKibK1@3vqHnaGV|IQEOG+D1%N-@_5m2k3+Qe@jr!EF?@4_8*U?_Qw+g)T(NdE zjdddiS#)Ja2Y=duughIK26AlOZDF}_nr#7DF3+uVJK_Ne^-@6V?d*inCuy?Z>goj9 zds|Z^I-R-r0{+4gB)X2fUuu zoH|byUV|$K*D00uYTBm*7SSk-W%F95l6Ra1A;H5z!jIp=JwcFayE8yX@@*j>&N*Ns zQ1YP7MpMp}%;0k5#J%2_EmFptd1)EsSO=SUiXWwXD??TLl-=fX+HDp9upo$~5f}TO$pOfIx}Z3cXk;J-CnTFfP2Ha z)ntf!Q@9!9P&pXgn3gtmPs@~Njztvp_pJ-#TA*jg9r&o!AmOF&aBt6(yI3>x9&pFj zGx7-cAy~XJ!n{M!vevX#YqX5O0y$q!HsneKCs1vxV`q$+35yg%Gev#WPTm-GxYi=S z=yM9^EjEERJZ>R7#~YmK5G4H4zwura0K5HwC*)kQUoL-8KE`T1$jk}ms!8ONeN^;S zV;4H2i2InSqXKoOdk6Tdn{8q_Yjqdcx;6Cq&J1d9bL4k~91C8RKn-Xk( zF~+>8sgg#U*QP7iWwjnze>rI^S;$d3Hk#}j3kZtx8s~4IiPV;gao@tV{GCM3U~0n$ zh@5*Y;3lwyYM5DyHd2Q*(*O({A`x3?Cy~H|j}Nq&XqvDYxg6{C_8)LEPj9p8?OL3# z#G~ZU#DJKnz?kfCsdWGne*K4{W62_g<@m;71BBfHLG9KZu~ao8{KB zItTyQ(xzIZu?p_Nh{LD@HX{a@goN2%A!Z`D8*p4;Nw{MZ?#nLZKuF3*U$-`mFbq9%8+jUo7-8& zUX8BqIp3BahNUu3hm9&C%Z3pioUUiAFaH~fH^+4?y4!$_R`GLHhvKJ@KcBE*c3&Yl z>Xq61_kBcpV_@j6l6!2Kx#~c|r~Pl>EF$$9S6}F|bp67$GBQr6Yx^ zunUOL(p;NIP^4xqHH;Ge9G!m15VPLf=jNXvAOG%OBF@0;c?~0)bDzDPE)!-FIQKan zmKbN83>vklNUwv0Z}}GyEU_n}UNMw`?e(}ATDpr68E|OG$fM9A%Ovp}kxodaL`bR8 z!lxWIV9tF|`obwU%oGnu}&SB+dA#ZR6V7o=rvo|IE!pyY6LVI z@^l*#B>b@}`87$u&S^>P3s_A{E8+I0Z@kE09`Rp=|JX#SZ%pU^=7fuVFwwM|xzJ5v zdmD!!Jku`A!mJ0+t0={5$xriIfP}C5$di?&a;fn)tag8r8_4>rv9pbtp0L}(rE7c$ zCgh+Ug&cWbq@US^zFz)%&obNW&E0B zEh`Sn28Ro=LkB{#*1LjC@YK5}zFazKozzgQ-iEOR#pebduUdb-2Q0cF`zv3sK{gKP zxYobjrZjeFQ%jrSu6pP$e=`SarodJEN9FD6t(Dd4o%P1n8@j3Oqxr?`=aLpj|Dtsf)v!LI7Kq{N*4hURgcx z`;Wk!QyjeGnt9ySak!CaXgAjUWNLfjS57Dk{VgVf&br>6g~Mw3&xa8afqvV=hrlvd zmaxE50GGTS5vx~43BUN|$<>mMT&q@hwpe*NS2?M8Jv*eWS?%kEo(q*{L*=b{;&m%y zl|R(T_dQptCM$2=4Rz-h3LR%4vkR}59MZY5{?gv4Q=vB@yVk%jC(<%Hh9Lt^F$Fb_E9*B2Pk%AjZ(6h zOvoVO0vDI7f~heTFnJ@Hz=9;^fdEW>Gg-`WlxaR7p>>*xWW*l#c#V-i$ge>vxkZC*hpP^>nG(DXEl8ZyLP@fw>G4 zz8-@WhaTq&mtT416&vCeNnacZCRGI`+PGiP89T9bOcs#1-kZDvzSxHM3^(|d{cjL# zr-Z&2rjm$AgPQ3mm`0v3=VHNlkOn0;r7KVo>R^%8>JDb8q1)=`^Z?DQ#^d3HQ1(5Y z$>WKz$mMtuZ09EwHB^kraCOjw$Z-IsVFq*vi#7d={rHvwJn@_6LwRf(VFso=iyzxb zUb+x6`nxlGGsFyvRt^oM6E4Ilj+dxGEcW(3tCHO#mqFxF1?mmp;Nh~b=*TS%C0CLg zMxVny^bk0SDF|KSi#Wxp7jEMkq2}&pKncS?=Tu0d4so0T78(8w5A!A)MXPCKK+71c9l=*5v`Amhd7A3_NaiEV3+F?sZNX zd+hGLU<-ka+(V&la2^w!Y=_TkPK3tGghnerQ&>X_S5!PDH&+y;KyIkZzMvMVA*?BU zR8j8#^e4$4#r~yn8ud9-hJ>|8ICDw~+i2gmHrJrAiFVy9?%EGGcHYF?dGj)SV!zYd zvy@9t%3@-h(7GABbF&uIr`73Mx)h*7o=m+7WwE{%JZACCws?8E!WTKV?*d0EGK@O6 zx9;CKcN3=4fgQ+hx2b3mK>~+PimbzyKd{JE+gf4*ouM3=st$fm2!j=bVG^_4a`z}9 z9kEAD$)j>_^2(b&h~{J)J)1Bc&uoHqwc-0gg9JgKnR(_U;b>PsKr z6<@YPnQOifOT8`|3e(Z=8w4y{^~RMbk_8nN@*GG=_-W`R?6I)yKAAC2t|KS#_As|6 zozWH6=XM+65hqvQxs5gD=Pv=!_{mTm4yBbpCu=m}RVD#@Dk&m{^$l~lm^7fMlwHv(y({?r&HzNcjHWa1W1d0Ti3jX|2vK*vL$9(5(}TuoE&CUB?03 zc^sOM$-oHFd{Ei_>OwrJSRz^7a2(4OYX8HnT!Kp7r8I%}kL%EEkWeL@Y?}HTBVxra z)r8%FNP)sVs}wT#EFLB5i)d6G*`Ua5|6>vzA0&LqSK;ecs;H|H-mc@w<`>Z@4o?}? z07LguareXx&Y_ktAWt|60gS%jK;q6ex#;G9San=?aD*X6+QCA#s#)U)WA z7nUQ9Kgl`)3BNftrj4EX`CiqtKr~9RcaEOs8(G>~j@Y8V$Ch^@+hBMxTze~MXm)lU zR0mtwDJ|Z)iW-h0MHR{)zBZ8C7mBqrKVzQ$5hQ%we=F%0u?PE+OhuWHp8`lt-LnDy zrBwHr-22z`Xe^BmB>eb#@ZuHlZ;GEJjaMA>Jt*w?)jj$PT;#>5doMuK0|}2-b^j*Y z&S4i_sO~X~pg}l(kUd7kMlJvUYY;4#@*@Ul!e%g&Bh?@rZYl;f9whvWo5p0_$aD#B zJ*2we^Jx%1;)MQriUyHE6?r8-j`yuWXuvdAH6U-n$0D z1pnpLAV9*W?Om)!L=6HAoU1`lE)8Ow_U8T-Q5u3i4-zJqpIPR+s0c2JAS|}}azpHMd3-l1#5vU(>IZd1K z&!Hrz`=)8=UR^Uym5GW+0KJ6~fKXGLe|j<6xv5@=c8zaVF&p7>Z8DKYDWbNT!wUocjtK)}wPZa-9!W$omvLYHcvRpzd9m(Nh3g%qO zGovypwLynjfhkeQ~z9y<5zHUuw`Qp zhA0E5^V8o;iAsH*%Mlq+wY|QO+a)NMA|mFi5gX?$L$n-Q{GB6IH*K%(7q-@P8A57zo_}3C-V;_sTa6yazZ0SCUS1u;{a3_a)@EE@$8zPJXz-0 zB*!JhK`%;4H@(OH>e_f&FrGO()BFT(Fo)xUD|TLvUoj6alSpYBvY$w|f+$*EW!s(U zhOn|i2Um0(?)S}k41PwaI=MExDecg-Bk#_G-?(gUS+a%G6brLsv}Uc|Ohr|}U5;a+ z{SG0kik*Vqxd*u0Sd{6GCxqmdz`B@x>4?kYIIfgCc|tC@$ya^D1qPaP<5^Y#A{_Tx zaPtZ7h`KkO0p{UH zy&&bUg&6Gnu$)vRq;UPf^hw z;qF99K2q?ukq`+Voj%i+gux1e-)p0Dy$o{}7`sdE$ieKy~@U#u9?6 z=$TT2qH9b{ANYyOv_TLv%c+Z1Sbn~DKMJptQ<4t<{9de3fEei< z>`?dOi)s21SoCS{=oY#hnGzE=OXWwqY9lOfugV#W;t(CIg7@u-akPXSs!3;XoLm!E zvKs_!ARX_!ztPw?&3R}Gfpy5-M09SZ!bb}vKMrQ=;lzl0(NUC20N^*}=7Uo-!w zp$rD({p8ZDl4Uh{l`L0*QCq#qD}J8nD7`WP7dEUyZGL0p?L?ktp#grQ$%%8(d+=^f zr+-xB8S~G(SH%H|;_VX1gnLl3FX-mE6{&6Z%oNbRILB3{1yMuo%ZR4nHMAvE{U76nrcGng-aDa+XV38ngf1tdQJL-v%Bbo|2qg5~ij7 z2c>{Jc%dErX!y7i=@JkNuK&)0Vcci>O;f#Kt#95GW4-}LcxaV(0yz+Y|0dm~>+jNoF#ruN>`vb4H<`4S(FIgGF_d|b@aM~!q=ALg zR$|(mTMDbejkDLuFKT_*TSvRm`mPUqco=RN)}sV z+gQhnaXV@gTf$1|X&~W`@0cp45tLZzrgbbt%k#8oMCuEN(V()BXcqZ_=5vmev(w}hTQgU1cY`gD?sB5bVfLDxJi|z|oDDh!3E%nGGj+}wL$bc~ z@x&wj&_YOtLZDM1Wy|cB1JUK~j`z9S+wBRLw{@)n)~`^_U5j%dc( zb$i|Eg7(P1nVVly=gj0hvSJxUAh&g2r}!NuqhV@MNa$sk5kW$7%My?Tlm~JH>n00a z0D1HyBWj06gb*@E7-e?-d=e`<+r)HW!^h}OyPPPXwHx`82G?d9vF$8K-BwY4czjrz z3+lx~#k7q&yr-ghrFuwI&vH6Nnxsu8O$br5_&w9D=*@_X^{`G%UsHCS|M|n1bK2|| zthV_z^}WapQhPuSim+>QM}Cp_1u{(etTVuM3t=&1$$Yc<9&Ga4F(yM;*syo~2I5S1 z`P1xv154LVfomzOAQ*JkG~T}%VLO&G*&Bm}+STa=qh#HI`u^|o@E`4+%v;Rq9YJs{ zIZ8BpV<3cNxe03>SqD*}V0d}5p5GA?jUHRD;M7*eBQ)GJF~`~4&SPGUC;k*#i@~rU z;g5dVlOtloQ3q&H6vUKY#%Jk_lU(fipqcRs+S$JuyF{Bd@1q?~gcveSGUr7%1%RDL z{xPnZ$;ZvVcCZqUR>gJ1@9#N%b0C$bxP!3KIzxs#3CDcW4lv+mSQb_(wfUF-To8t^ zULrHuNM@htnq>6m>-tYq$){YWjL8%+Goy{|5aJ1;8oFL z+{seTW03H*-(VB7b~ne>P+f=&;UzipsrakmVP6TXiph-Y4j= zYp!87!ojMWu9iJHYaMj}pFEqzv&BIWTDLq#b(rP(R%0eK+sT+FN;C)w+3A{E5n=@r ze&{dcmOM0M<%1g)*Ex@lityB8oVcuTjJ%R*4=#(^mi)6}tt_4nIqK0xaw>#~xNCkX zAfcWiYh7Au;SA&~vdRh@gP^3@!Z9Otg<$h=Jhd)L_?A;ft8=?5 zw-_|YFD8OHKpVt>cPEdVOoYjnh6brbPP`(}j zy5jgd3s5$bbdSniMdEn8US^T$C_KO>NP$grqK4T@R?|-rK*Hbt9J#-hF(=(I@u(3J zSkq~45T4Qp;S-kV`rz{|gD%>hyw>g0Scjc9I(6OwuS!LqnOr8SbA}4t$F-NT^rHA& z%HrtsLKde14NU$334ieyoX@E^$LILT;T~mUd@ds7nOPit7>je}|6~>y+$+W=f}SQ0 z@yskPI^r+01;@7T6Sx~l_{?ir{OK7MmrJ4YBo^lrbl7cIWn%GnmBqb3?gkRdiJdl! z?_I#+WaRp+(D!VxSF>JTrCn*IM`3Qnlm(mYTAJW z#xaIwU(>DWJw=AbFOabFGSnKZv@pXMLGVPbHU`xgSF@h3Tm)4%6LB?qGG4{MMXu&U zpAedWFm`7jENpG&sbRjyz%PjHV`G37oQTP3{Ul)pa~PoVwYnAe=B z?0D!1wj{o_S$@Tq(l9rbOUC`mpxNJbycE*$o;gr3b}5fRJOT?D?a{}>D{0}8Gu-b! zbB-R61{THv#2&R7F1&$+8~=_1pd-{5gpz4vRL3rlN(|eh=fGZ|2)Fg}w;2zR)8L30 z1xs%#O96A5^E}}4w~lmlZQj~5K{CDsIa{?>yBp|l9rBZ+@_ZzC86^CJpN@BiiZjtA z!%WSWr@JbCN1hjQ2{O9VYv#@-)e&z}kZPIq(7lcv`r%flmi^phw;qjv;thVNZL4!( z<$y=(1vF99*h#HU87SqECwZCkrpkB{GMJfvzH6pLalb6xrwlBr;rZOSK8XpGSjza4R{ z0xrbH=4@s5YRx5&PJtQkJeKy1WpbR~ReZwl{4?imqAj+6yi+^jf7nK6-xJZsR$lG# zzH>wetR_&Su}&9rxE895cG~P`Dj&N)F@2Ih6JHZqOEHg8^a%9U+ z6AGX8Bwb7~Jerm=Wf*&WZ%wGmmxttmJhzu)K)Dm)QUfIXknVVA=M3)uYFwF^H4zZm z)`b6IgkgxsjRY__9ZA53m0)Q%j(Al=5>)8z9WGkb35E)I9l=6$1QCCE-X9sfi2hh; z2eY}~UJ2J(x~foWF@FaX$KcZ8ba6ao`y7{=6E-@`abVb$Wncxilwf7ek?{p2e9jx4 zT`_*|5A$Ix3sG-hxtg9`^*C=kmV?LHXQ)F^^h-N|C-QdG@4`z(LgsTyU-=<|OOLhd z#pW}I<;pBXFCmY;pZf;pGtRO^WJbEiM&%L%=^k@ytFkq-lurh%K+c5C%99wYhqTrk?=fP{biSNB`s z=EW~hcuOj``JLNOXsvXRkW0c3*Vmg1DJvqYrMAAWn(8+SYxiQ84J7=>zZwZR^-iz~ zEDe~!s?e&W&WP|Kvri_c*kIXVrBVvn9sX@RCnx|SK9|MKj-(HqI=$nsRfGz%)n&ue zzXGd+>jo4QM9d4&i;@){GDX(9=o9a5J<>Z+pE~1@x++}4Iht|rF-2oc%b1`tdc%H; zmwNWN9_hgtxF6*l4$s}hEp8FmN|JAjyLMQFAPf#@dPzYH0;%Ka9dBeO@_ZWDyCxn* zCMxlx($xFu#{n8sDfgM3=Cap9jehF31_{6Se~FZE{=euG#RbvE$)>`qpMH*`V9ZhGlAU!;P2fRM6MdYP_vJeN2a=UQS!AmKV0 z&YsAP@N3_;`8gyymB|?*&uznjZ@YCZHRfVMC)HeMMA#k3ktQsGpo#HMm0sReb#57=g}7rPv6tY7MYfANf$$eyObH9 zr1(~ab+yo;tY|hCF~f8`@F2gx-70{kgM|P7*N&a5*eF7A7?bC~>?Hi+K^cHNElTlc z|Lm?eRyMZ9(4MlF+1TqVs|~66`gbyNj-72vLaIY0DkO;&=U-c=dWq?|l~(9E%h)fg zIX%|}34i|N3{QBL0uoi1xB5rTZhT+`!pmv5=8cfWG--CYUg~MMYAp3Q_n3}3A?$_E zb3!>&Zw2TkwbWb3p5s;|8D0O1H?_x}5ZcnfKrpZT#F`W;5Jn9ON}JBPJzI45K$$r| ze6w8QO`WGV3*oX862N9rDj!lRXQWhJJJXFlRuw}r-DTD~xP<)1(*Rud{GK4pk^|>( zsK2zSX#Htb67*uSDat6murM2djFXV_u<0ghSrEp^}nK8-W&(TXRX=I;e!X|Hy z-ha|djP%jvK@ml)(IQ&5n6ZJ87nuMAe8 z>@QxDEZBsE4XoLTem8hZbI+?rcPZ>R!$K~?lu411RT@Wg#&7H(HN#>`>vQ6R#>mRl zI7`x^^o*I%)+7U?JZ}Ds-`5Q4WtZBHTrxkvZ)hor2mp&z* zI?YoEQnQcP6p36S{@LjDQrH|&l2$%@DcIoD>M%zL7bnu)HitqAb4R z#oDdHOEC@tg~9wa%5_d&Hu7*;_`A_Iwab>eid%Q4MoHoUSH_=2MD|X$^OLK*$D~JU z*c$eTq;ZI*qKT*by@zF;Kz-E*=)fmTM>Mw=IR)1;N$a@7XAA*11PUGo(qz!Rft#}j~*;4#)cMRU~w zhU%M)~S&OOV^>+$Y@wD1}AE@dXnB_%vw z{v-k?xccppi1d?iqX}l9J9lmRb3dncJeqcEuTEx`9Z1;t;}$+dFIf*nOywqTv?&=x z#xw9w{>NhrDrD4h(-=nN6xu`rroG=X3!9Y+QXGf+44MUd@^l^I=-ep3fuD9PvGE7W zAABw)bP3s#R2LJ|2~foj?d1_-%k60hW~k>dyY40zrh^&+68`9y%EZwd7$`Jwuq5UO zCO{o*4JPgNv(ms*7MDr~p0c>40}t0XEdNr8XXPfUlVshj-&ra7)Jvr<7hy{=ZEfXR zu7-&=dr&o0s+P+u_#Gby7m`_Nz-{k#@-M_=o?66*Ic|C2G@n^NI4R9=Gf6HcXfNlH znK7@=5I+-#?M~3U{;xpbzPMTQ08ty zJqvAtgiq{TtR;uT#&mha$^%Jo3g#G*A=fbO=~K?nR4N91$h-wybrLr4sJ*4|Tu0sS$)$?|cRH`=0WosPsEb8nrY@+jcNgM*ajh!$$19g9GZS#^WB$|RkcCKIp$Ln;bWIylf#mX8VZfNGBcfE@1a9B(Y!72b>* z3Jwzke4UBXryNy{w?RUQ*jP2R+qKWuP#Zu7NZv3TpunSTXv2)nn88#V@FR>huK$T> z2gTud_d=Kr0Qz(la7Qx&3NG3TWc}#0Ps35QoZn%UGfkhVK2h#~gunX}7xRSprEJ2d zHZFW*{1Q0$G!gWIq)&x&n{nv_Wd-452Z^L^hgY7h*6YVw1X`%lT)q-W`0;hK$4jM0 zs+wk%=jENOvz$D$Vbg5!n7HTG@~*;&3+LAf<9T*?vk)>q#BO>Z(*tsIPO5!GkTPa~ zaw1}|;InkY&zTsmOtcM>=9)pDI zUmS&U>H(2gL82}7g1iWkp3dQUM0(txXa6mmoQ-Sg2iiG_Tl^4YFU&?!$ROd~Kf#}x z=PjOS!=CD)sTgSPE8;azIOhzL4G<1tvmBF9wq>@?_lKrr!YGr;oU=>FJ4-JJD%~FP zPwB?V7-5XMlANI8%A@0OxMg)o-?IOJ+&b}KcsfhIqFnAbmi^M#$K}$IrReYG6iqO+ zGvscFj(!#i4EiJz3fhTeN~*BKE#poz`;Obl?Zd~ONJIM!S`65h7Nv8l!owoZASa(B z?$ovVH5myKM&JDm!Zp_j`KacR8>B*!x9j9$aoq_Vs8W$oR8mv|pDg^KL1CW7M@9yc zXarR;r|mG-Im+M~CSVA*>W>J3u-j9qdo*e$O+DKT66R_Iml1daBi>lHGt)4#%u|d% z+<$T~66)Yd@%6x-b({8RJ&F68YLj9iD3NF85emX=z(Y)HiMoQeIc&f41TN*36?fA; zuc87HO27Gxwlc2^PAs9VtX9`|E-;o8jODCKPP=fEx@aw%3>qrv$;@RroKTb@eo$}X zIvQN@cZ^|zvncO<2$b^EjQ3?j2WbrwzT<{`n%Wx>$!vUgKE4NkzQ|4k72mhWMzO<+ zz80uaqBj(lBb7RSK&2FiZx*!Ti|z9fzDaLt)IbeLo4;a6Vh zLzPeAOgZ^abRPd<#rDAN3C>md8k3Foe!sVjAFqca>jaB)IRtL*`3VQEELbsXK_CeK zl}eTy3|Pk5zjZFBCH`(p%}LrrPYL(1Pq-R1O?L2GTVJ4zJ#`)4UPVJ7q?FGq$F?$GKI8vl*WsG#D&@@evxo?7G2^SOS=v*D-* zFgH!1N_d3M%!5=KjP}BTl{ki|JNRJD%WmW;(;Q!0%fpd$V()f*?r5|FYgRl`j2J`< z!H?d=9STbU3E#Tuel3C~4daVt^1_92nM6*MoRuPls4bf3q>2C9zyNm1Vn*&bLV1bs zT!dzgS<_6$@>ft7qL@wnBtV*5J$|W%({8a9Wtn%yTY-erUTTadb&H(3k@E?ICsudWh&)L|#M# zn2gGIq|98#Q31E?&KXg{zw3ngzCAR)Yy!eb{~7%=X*1skPjS(Vq4_;~X?!$W7pIS$ zmj)y(zRZ0}J-r;gmPKcnPFK#+(a^n7CZ9t|ODfN%rN!BRgm*suoGIni&*#IL-}0M?ZoCRp~l5*rdEe9iY}qAUy5&Q&B8W$qUY zG+g1y6)I5fd_NK#w*ZHt?1GR-{Va-bIxL8AW@!PI;r3`y5iSsy2q)S{nV8l^6!7KA zN&`sv)SKhyGCsTa5%SaVJ!nSB%&5ulq+Vw8HO?rv2X_4(Z6#2i^RrZkh~xCkl_^;x2tKAXjzh z0I$=~f@byzY}E7fc5WO8mTxreQAQ6)_{&Y&mx=&ty7IX{dC+t2>*DTj4;Pb$8B{e( z`=4FR07DzZ<@OF1Jp`|K3Qc61<5}0&a5b!Dzhqv2^xD-*jUF6Bib5maK`P)-i>FgL z0;XCAZQbScI#^>dG|~FLb~U|PtI#O=(lo&jNcf_EAJ+u#rUDGq*tAT9I4wM`&<3;s zT{yoFtUk^n&+mEiA_d_~=u}O=P)mmvVQWEn#14kQc6H$)=?;VJekE$f^~k}5#n)Sq zx#z(;)515y;gh0G32|6GXQ(*vqYZbOzkZ614VL=HL8=^ z4(uf^68A_KYy^p^gjl!uH6(*=7+{MW$PsS!Z8OV

>j!Koo(Mv7*>=gY|@&dVjx3+7Fu2!12a{K z8XSp`i@~ZCeHYdE@^7w_tcC^clEo66ne>~AKoPPi{#4Xe)DCa=}f(dCdbhG7C$-3gTQ;T$SCoC*j;Kp|E{n*U!pM_{Pg(1AID<-DQOtpLic^;;HN|jDvs_zs1rlZ0e~*nQcO}V&szP4)?aY z2v+3Pq!S3iUSdPhduXS>MHU4Tc3(NmT8l7AXD^NfloyPEp&dNdp~=4jj8@y>1B%Q! zm)mBz@Toj$ea1O!hBYTNq*Y+X7oe{wq=O78ioGH{#kC0#UeI~AHlO?M?A7_JvlH`k z*C)T|@U=3(Kl#$9|LV`FP``iYrI*&%cD9#SR(EDj_Fwv~Z~w6eKm5{5;A#4=EjHT2 zPHQ*!84xauJE6@ax6##kKR`;DE_@%7G``6xka9?3qf=ZZO;snU;E<`j{@V3~`xc9H zm881Cvs=9EEsfXWu1O!mAsqIKy({$!4L{cGj+&S+vxvjcbdgB%V#|gGMa0H|bL}dx z$9A)eoB?kaMkKorXVHlsv*raT@^I*XX{`UyY~;$iv$`qnDcJWdxMJ+tQ^TomHObMb%QW2-N^mIR=-CZkkI+tbhX;r>-(x0NY|3&^~LLRxw&?T zc8X|n?>6qGaV*Dqg(aew*VIckFEnMe{Oz5YwawZ(iKcnnIfstQTpXMiZ*Wm(?dlsV z1So3$t6a6zWy}Xk(!0yv5W|SlZed%ziifzh=Y4p%dNf9k*))-vEG-2gzx=VI+XMu-JY_aMax(VaR z-+>h0H0n#&z5oPq<0UN`ATVF98QF5CM+UqM@cUS7G>sxPWf+b@<{kE&{#@VUPkG=zIFx1mj-%D-hzVU=th|<+kSE+aNb1d#xaZ@8E#*ZX*x=gb z?)o;#o5*!@B40QMJiA79BB3dgMp$-sECepEwVDK+DUsBH$kHoRLUCGTJ=EZ)54O2# zJA{0)KGI4awsz7!Xb!CY>gJBPHdqYfnE}JyFS}aj937{OZUP-xgFD+xJGwvmIX_^{ z2BW>*%2WzBnTLQFDjglG5nj6Ri;6P$VYj0I zO>0Q(r0}%4#llq^Yn!)hlCiM1wkf%%D~< z0d#z)G|3JllT>By>O7)0zlt0;ixP^^B@^WTkY6QTzDbbqM@FHt5{p1hC#TDm(GvIh zXZBA#3ju_Hgm;M*0oZ7FYx}32us5cXS!EIq+kid8=bX5NJb}@^%cTsjM8{|zA%@|1 za{uT~lp-m0E5|Mlu5VXi`#UoSC;MDfUcI$ThuKzqc`EyRYNfuL{c7}j>%E6cpcNYB zfV5U)aElu2AYtJz7|glaQ^lGu$3D-QTyCa3H4Hqtf()P+L;&PL*?vD)jet=nzZPIq^OL^JlL zz}1omN-GmcVv*MNJ+P?lVc(cbr4+LjBBBlvhwv|)CfvL1TlH$Ev(;@4yvtcBK+Vp> z=3{miAqIFQJ^JJKdN&{Qq)Naa=$41e+HGf}%$_%j zzUM|!IuM?;6R)T^_SThqX6mac=fKL!uO$wV>T)7tW!JMJlRPw^FOkB%{f-PFmJL(x+>+UU=syh^gHTR;G%|`v>R;J~Qy=3Ag^yX>sx1_g`!A243WpMeKxa=<_ch_4-$SeEK?oJLPY4^ebo~2v3E$n zpv7hdO+919T)QMAzg93>5Ghazq&DjA_3UMAWOFzs4v)aW69#(Qg*)6>p@=UFY{V1X z%CRQnP!%wdkn`&9=B{-7B?TD@H?hDpsaQ})V`MS;3GLKZZmsP!R_e*p*5+M^0%5%) zzmb9^FAbW9txJAgnQXsG3;`1Uv%i9%wGe7Qm+M)+8%xCL=`(m!SVwi{mQzpC^X;sK zc4(%`<)fCI#F%-IeO6_eacKq_smV&==IlKQId4_X_(OzDywmQ@TdAELu?S@PY45Y) zP@UDn_WGF?RvKGaU8M|Yb!EP*72J(YmK_BMybehC zN$LyPaHcPZdqNy5_~Q%R<)jD4Fd;R^aBy1TxaMZkLJ+w+?R*cz3Vt(utUSV4oeeZa z9oJnA*T*{CI6-cB3xE_?H?wRlrv&k`cC50!bWhEdbGXyS2Wz&)Y-lgF`4fNQ7%Isx zx9ayEuzODScQJc!Hg@7K?)$C3l)k z`Zy3OlW4R0><>+|cQi+k@cX|aE6q)3u~+l(`T8{w@T)`{j;wo$8U zAgk``y;bh)x@Xer#|EqS*1EEFh1j&0)q9%_93)z+pn!TGo4sv(Ah})~Bdhl~-O>BJ zctvfjncC`l^%e%ibVT^-y&3H(N{m^1txzci1tfg&=iQsBuCHyfR=J7@3vt_AXC^+T z5@YAy+2+bURw=GH<6)&I*TZ`AbF-l?=JN$&>I+#xEsUGOb8luT6y;#iMh7^D1-ve= zt-3YD7_U^&RQ2!d%lBoymQJWpt1dAc*-HY7)}c#)UEH*c?0mtmcH1waN7zX3opHiD!Q?>z#glGXYOb>f1lWNGWpCgK6u;~H6CtlD<< z7Ik?nP;w--B7gfwQ}gV7{Q>kfxll8``o*aArM>>6-5v4M8j}GFW)h~4)TYWKd75Iy zjagL%JyP;Q(`nv^w+j2DeAz!<|3Xy(U#e2;ulIN-8cO)ouUD(!#$KX2j{Zt(=DVfbTGwHSN9u{eEuQeH2d(xg#-yd@J(k| z^LV&{v2XA=-pO~kh$d`g=Hy#{Ac2Y}a!zW#b5SaXVvz9Vj3hU9LF>DYg@w8otsIVp=;h+AZ zOmtg92e6h0#gGlAb&r&kZMv)1;fe2(SKUUHtk@Wi`^(9fog5&pk)3;AA%8CO%@NS7 zVf1oxgpS#7cBW59ePU=7X=VF$Yy#U$I`^^O#ZkRCu5uWUn2R*40tkfvIR^(TOKLu6 zbSr{cVPE&jWT$7{PNeQeBrN=JiUb3CWz8Bo#`6u=y2^2I-cVcCB4sD(P+Ozn*(Olt zYOh0{Q3VZM#9pMvfIyUnS?k*g|8g?MU(73&<1p0sQy5L%)+OvIbG7GdTlZ{w>diw5 zUw|vqHuN}uh?IguMo$aBFEKOL2xQ4x z?TxrQ7CiH5y3Mhw@A0QteSKwTrG9s183+CrNcfB&*+{UzYPd#SI^)IPTtn}TvRS{k z@c-u2T#BU3rb3wCD|f5wt6Oy(`g04pme~n`K8UQPl2Cu6`o@Y6s}E6{^I>PDv1;1U z+(OheC@r2Vs0lP4`&yGuu+8m2X$F}Z8%8mIw#wCl`KSH~068A+3?G1mTi;0*APho0 zw#UQ4@Bw@n1?zaY-yNQ?)y%^f0Kc`gvsA_8HwcU`I|<>F!*0h)O;4O;+Cc6R%3DjB zonfemjkPr{Y74xXk5N@|o2=ykyY3JpD3oGAj9i^X$$I~}W+wKOE8m@c5 zaij$hx_Y?Le6$3SfrQWcF|*VqA2Ti9G>sM6ajvIG_jqt>NVHG*9{J{!6ONNY2ayW; z$3kI#`8%PcvasN*1$cY=r(`9COYwr{zGvbyhnr!Kk%j{jP9cu)RZ5J+&U0UCx|qt@ zwj^fyz1lh%VazCTG_mVy8Hs8K{{{(;t9bP&c3l-DeDjxRotLWX>yR`a2=7h(iJu;~ zQ#C_mMD(T`t_CFpc&EOZHVczGuT|fIJ6;&Gfc5B@(B4d8DW9`nkZ|`w;44thV*4;V zJTp4m-NY%eb*giSG=#>BbVe2bL+bI4ryVD_@ehu6rKPV{@2oduN5}N!6aEJ-(>~Wi zc4lN{Px?q{eNO1kZ6Y=;*R$+&eVrFQ2nd^;9V$#C$NhQ?_vgoIAx(=)n7r6gUHd zgYrWON~mNg z)ciBY|G#E`hG|fJCaHjg-}z~@AmSO)K4_8agI`bXV|J`LBjuWF+$VxC7n;K$FkeW2 zXo7dzqB!H}C-<3m?;LiwP6tz(?Wr!F#|bi)1UGZ+onr6ck?n0R8_FosTrCA79!xtI z!dc0mU`FNiDwoEcPrmdkKlvdwoe1eV0AzdVz6i(m#-5IaUFD~UR>l^WMEKSwew|Dv zki4wr@}2b+BRjy>9y+gT80yZ_*7AxkKX$Ky8>z53PS&%-Q0O@Nc|9H{-Lhky`-Hfq zEb>z1QaI+bz@=}z^lw_=(%%_{xFtVcXRvc(meK?K5JE7YBnyjkeu9rEFr$bp=U4^! zWgDmxAKzZtsP4RBLZwo%9Q3lv6k`!%J@QdN^Jy>wxq^An#@d}5>XQc6RJ=VgDMS%v zF)0KnWpP97*h=LpqJv@6DTIccn!LU^rzi;a#J~4B3EnsTKiBJZGK#67zRG2`W#K$@ ziqlmSF8(2ZiYZ^2aGf_yfr@b z5>#`QREa;b8d9?O%~(VGjjC+l`((|q0*OW{+~xX)44rK&G$$3MI}Hx|H?&q$VhsPy zgV23$0jE%Fq~cMV(#@^<%IcKq5@D7UD&S4UpgGRn_REG;gvxwYy839?^(VX}&12nL zgh?HQ;#}q0YA939FqjT~tn2V8hiw*UMVWZ*^IKf*7yysMeY;V?Njw$Ym`vn$1K$}Q zU7JX(LzRsxNSOYTuT)np)M?eE>+3!fjqrKic`W}e(jlBc? z3KVslHFo!~3Ij~0HRyL3exp6u*UvcXMyu1RH{0G%z#f*K=(PZLC^LBTOQiFOokC6I zg}G|1YPQ7qlnT}O4HBx~lJ)3Vr^BT;yk?xWN^lp4pVfN3`f;x?8)pt#t!;*~0!gL# zg$8bCwV;Bz>#pq@Jw*#6119Z76c~C=sZC{R&vdZPQSe?rBRGoIR<{lHa&ylGf)clS zqxIPKY`U#J`O;@U+T}a}JwARjZVEOeO&awoDw>4JpIp8ET_#L^^j|NJBl()9xp`#UxyS30!zBM?71U8zbpkcg|e3kezj1Y^@m>!(A z_5pN1#BM=2f9z*a0VKgV<}B?@A93bNY8TUUbe_wJ7W|2H-^BZpZ4NXsL`0u58?qI^-JL zu0j|J%G-0TJkPz*pDh>|bxlWy(9V-|1er9rrlmIw&a7*@3wpU=#DT4;CGb5xAfN{& zh4Ygp&unrc!cndg8r>x33$=p_Bp~4r&kkGZEfPDkMx1&wntL0(8BRqXkG{3q>gB4M zd#SyN((6u#x>`pYhTuuwqPc0q->vTYPg=3G=DOlfvmHHV+49XRaG8(-k3d&1{+~RC zVOm9K;!!ZFhfEK)spmmGZXX>x7@-G<(_T-22`kNic0r4WTsaN}3B$QgCq*k8$Dex; z!(l@C{rMjME+#%poPXd{xkiWMT)A% zYw9H{3VealSJ~J8CWEK{KRc36)UP{Z;q^EhGq|VZ2i39F!{avA?=dMD?d2mll(?W? zLE{RohazbHlk~)ho+aOcNuU|Ma*6K;N(2d)ewzIfH`oLjO9=SyjGVrVm}5jkIumiw ztEC)iicOK`lH!UNUvb=fVT_hdSSPNVyZz)NhH3=?*^MKQth&4cOS@s}Bjl>PuizkGd?QQ1MHa6B1 z8wrCp5C{wdtvqr=|4Hrapik{|D`~miJnC}UqP;)X1SCxTLILYin{B*V97(x$m!B}P z*$AUlOwJmTWh~P5>c_dt(pVWAu`rk&zzN7XmN*8xKCwYuSzQl#rUr4H=2)k+LGd0j zNGM-VY55udU_0$h-#V*VN}c4}rlm3vO~3Mrbb{Pd&K8Ttp1eMH^~x)+Tv=OACa6PL zftUpdgu~9wTMk||e{?}>c*~WBq(&9t?h$1O3yq$JI3np$jfaUn)4~A#y{c<|=ZSrg z@I5onICrYaURXI{O9{r^7$CT|5dw^H3f?bo?4~u018%2YL`V{Kg`Cq7BKKL!X9^PB zhnTkAtz2WVHI6W(6DRoYyqrqY^H(wa%lVr0kk&LxPUhw7n4afcq*xQ*Y+4h0Sbffd zgxx=Y<6(M!7Co`hG31k0H=3flbv!%XF`GNBX*)id*JXg|`ML2vS?si?Z6Rt}pYr+S zN59U*V@+p^T!gbeuZ{J2J%@lwK!A+d>G|v9edZ8g;SeA|7P%6GKl*3$^Wz=o5TJ-4 z;Y%<~&(Evl%ca~ZTn`fyHOq^mx;mAbR@K79=EKCSrmyS*FkGEpxH>lee4qiVY1}$l zFdA4Grvcp!5wfhNqhLW^iRp#Pc%K1TR?}%4kA> znGeXanoa`?MlB2D)G{Ba#cDbYEEu&cj8n^e4yl0#7K~aJm{kF(3pu2^C`^QX;2fux zg&a~X(&jQXwNMM!)F(*z>YKTBUC3cJ5ZA(W>-hQ@W*2gp4aBuzWVkR+h6_2Q2D&oe z-}J&b1uo=}Di0M@wO|yuU=)~#Gaz-2e*^vDAJnvjtNg~2F(_KGnt}d|QkgzAbr%OD z{J>Ym*42mPOa35)l&uA_e?AS1TZE&NlgEkTXO((=i29UrdL01Sm%4wL zIcV>hv~%k*7#GL~?rL!2CUp=~%#}fG%R*b3BWb?i*d8Qo|Eb{mu;U^sS*Gpyt{NuL zQA^jUEtB!EhXvj2>-`R%e#&eNi7RYG-2o=Lo@Dui>?&^%{vS-|VCsekI5p8Yo##W{ z$9C%PvZof4H+eW{>E4Ia(;7ZJ!r{R`?RVKqi=JbaoCd|jWHE8ou{2Qp{y8T*>3Irtg?oZy04BCLB<*GW)7YYMqKvL5#DZS%%m*T8E+vprC0;J)UrZ#kr%4@*pyx6VI#Wh zk;}YA*P|Y+HUEHn-#EZJ;KnY=KnYowcgKq#>iGczCxdTDKA-RfZK;WguS-F#e!tiE z8wj*4r5}=Lk(+2xyKv0N3VHG(h)KNU^177>}sXs=6)ug17MOdZ%>5M zKWUb0ws;Jt&owC0h0zhqer5UFeNvdDg57$@r~XmaL1{Dn)>Xv5L6fLd6YpMJ0pB z#O#sb#+teN(fUvETQ1${KHz1DZeajsIr3t()i$mZpHyK$Ats#@NciYy23idh6C*I= zdqvAuazotLFx;WaymP$fT2lQS{3!t#^%fiy=K_<_lEwM?{geQqc~zPZ^}1l|0Gx|3 zP;JxE_#>dmp7ynqNxrjMA(k_3vU&^SyghteTD>K&F@O1ttO7{*gMVKgbEk59rBqTE z2R!esr`>h&daOmQhhsbshUy>bwh+Gg2$3gX(&Ws$nL>mi%72`ohASR2ecox>O=mfs z-4)H_tyT>*1ai_7-Z+5W7o>1dR@#Vz=Ox9odG*)bkYh`2rwH~cE^p1|+_i`aU3?J} zsZYz-X>ad*hg|7wRGl&_evt?)<>MY2B@FDT#R>oW!>oo;o`}XjY`0HavsO-nlhO7P znx{LKlg2iQiiz}^t_%PF7fEay_V3foFHsQx3d_fF->kik;S8kLkTkE!m+e_T|z$42~!f$%+ zWhYhp*7iCPSnCSK;44lPmn?7lKf5Wa5pX3gid9V(+F>tE?5n1tOh9q9-nNVW>2jIB zSB?-!NQ#8rWzDT&sIEl>2|x0=tfVzr<|S6WCCpnFcn4EBWM(#?EA#uGoaI?Ijfu4S zq`i?gaoC>0gL){YHqhJOmZwPX8}rzoZnc`gLO~@HZ*pLCB8Jxpx2{UBehsPk{XMYQteSn|V z0li>0DadZ|ze~0gA1EgZG|%&zvstbAWUBdOQpMnZMJJkuripZ611?WlscSQ^513#B zcL#CylX{~7HNpRj{;o_6r6|cfIo8}@$i@RPVdsK`Z~L?4UWiN$wQ$Mk0IgEoN~|X^ zVAv0{v2!FPwS&T=tjyFpdbLvK#2CoOaPU%)b_$l!wS1l2x%!Ys+EZdVQWSPyE-W^L z@3h4I%47naavvHZmYNrvZ;thX!jmh_`ipL~yjV4yfQ0Y+&qYY?S_v#I#fjWPIWLa3(k9z>{UDd@ZMIgN zEnGX055mxGJPyfIP2996zZ{%X$mukl^jS(x$9@lgKned{Bh()keBq$FoELlrs#_F) zx}02+rJ_7Vo-3$j+MDKr8qG9e(PUbXMkB-*9;f;HGo&<|YX%3ZP~fhzE~I3NVIWYvL#nlv?Lq8636WrY(A)uW@rV2BtZ zl_hOVC9sa_+1_uAIh{@ERzR+mhQ#;R$U^|r!HF{~5C z|AkF$MhkXhCe0Sb^XyDl^E?yg3=(>uPCjNHF!Cr&rttMy`{6 z!rmb)gfP$FS9lDpdiVzX!VpwYsh=m7B8480;|S>^75Xu33|xeRxz0vUsfe!v^$ltpd5 zaifejkFn!i7$@nZvW-yC@Z1PdHo;!;D7-q0zU$|h84EJMaOh@Ym1pH{(|VFzV3s=C zWNEz69Hc1<1|A9nI<(Wn46$hhiQKU1j9~6fi~=d`#;Yu<<<0+yr=O)ImB(Esi|Tfq zc8qM`c4uzkynrQPHF8QxDWY0sMAAG50i{jLrBfaWPOtY!+n?Bm68_OkT-NdHH!%J& zapm@1sUPy+mg4;#sr1Ie2;DNbKqwUidaEr!(Zom{^*cl8!*{{_uU zJ05i?IGIg@^JPCn#X3+rXHbx^{L3kxp8XFb&ip~Sjt*Zdm2E-$6AVF+!bsU_&i=*4W}x8BP1K@l6( zWK5xy8dsKLDxDOq+InInkqSP6;*<~eI)Mz|Soye=psDmwA@(nwBMgbkk+Lyj1Hcc= zXQIww$9k5UUH~s0E>)8D&Jel#LeW|_1PM_nlgI*)wlhzqZL;aL>l#V=I~FfGYX@DY#{ix`pC{z## z<>A@oR!Si(EffNwZIXveD3?I;5JJKRNJ_#jq_im{gwST&&-ZI|<^8?C_kOW;>AJ-AhJ_9+Y+y;OdI6J8S=o9QDt&sooSv+()ZlkKGdKPCn?CZN zKTJbbelfzr-q@!OR5B09qryeu<{5~D-K{k#YvJ`&FxL_E#=G`2usL*h2rH))US;!A{X-SZd?9srd^7Il@k{OH z&sUTZ_I0G-SZ1Ye>kO6!Y@NGnMC*z|Hg`b$sTFlAs*xUjNRJ$|b!@Bha+`BKRCOOS z?|NQ4sUH-_@Nsc{KRlq{(Nnw~J?ceacVO#voAcYDLc2Cc$_$pJ9DObuldY?UC4|gO zRiaj{nKUxc*BOxXQXe0EzHs^%HO-e_sL5;A_YtJGeU(SoT1CNq*pyOv#C9v{g$vB)b{@Y`e+(>_$?SoSDPI%dTx7BFV>Q)0U#%}OeV zm(rg0OTY<+a@tBg-(7ocX#c_5!4PNZrWn%02wT#v$BE}DO#tCvemRBi;Pf@om#3{D-#yBq?*_35CO5Lv_(R62!wLYxyFWo%K#v$qbKf*HChF0E&a;PKt<53u7=MXOoDY&Vi?BGk zNl5{#27oy6G=W)E?{&5N?Wwhj$qHgeVoTIik@U+T0O8IjGQaN6m*kiXR!mOtz|MR~zYW9O;CfLUNjf{OSCWln#HBMjXKCC)D`ZDWrje{}DuxM| zHn|ts2bcAJ4M|2`cMT z0O7BGp=|<*Wbg3l;b**#Vch<}+=hWoabG6;=T~h#s!zJFih$VNLYafQ0u3P|X)YM0 zBS=StU*84cjS8Fe4im|PzTH@Pc@F!@X@wks@a4-Dk*4zxqXQgrz$1h@u$@0D=kB@@ z<$SEyI>(@gDk3^}*sm=JBYBj+8G-*6O00ryqifVP*S)Lk3u3jF`*FH!3v z@l2_UTfRORsdt0gJMYggwNCnv~p?iHznH?8Al z8&3^1+Dc+%kAbWNAdi!#u?lH2ng|m?`a;Gzk|{AiSD_qZrYc3!VQFGGr9?lHiw+=s z!q;z^WkVT8c8*MU!Z6b5Gy(xDkRB*kqD2W2MqaJe*X`0ol&f&cfUkOQ=Js4e1m$g| zG+LE?6orI7W(HZ<7H4otDC`*8W*Fa1-4o$l2MFSvd1ctgPqikhajm)IBsWMH}lN9U|}{~W8mF~00_VH zd*ZV;4(b1Py@qsMWOYEKkKR5zja6dCaDyv!19(ZPLgu$AxfgPsYu0#|Tvmv;F}|tw zBL8|cp4sWEGZ?%?=*v}Chl=%eG!)YK?%E>)#9IWsY*?-I6W+AJNA(_R72XT4O9>D@ z*nk*F&Iw?uPUvgWYn0aUKOXlqehpF(BBMCrY1I}s3R5Spo8M1(6prjq*2SDpc+gGw zT7g=InM!oR(^jYX1%U8bU#B-l)hS?p@q`zw%D#<0<`wr(c=m>`_)@q$0jCju6+!rn zJksH$R}||Y=~Z|aktPG44oh6I_51sI1d-f6_i2acd>vg!GJy?m_eryvN$_WW-QD6R zKlnyGW1B#>i~*T%Q`AV*&3Z(8mnY_?rKp`GJ%S1U>+e@-_KAPN8I?owmcLbC|(#(h7{stk~iJzi0Ns)8<&Pg_QzH{PV87QR+9>rs+FCTbaiw6iF z{%E-Zb}#|yc?<%TZ#?GratDkYRQTTQpq#!RO~jT?ZBBP^jpN}!)QU3Q!*>*7KMB!r zQiM)`@YApK2m#tPCdW_CD5@0TBC9MdA#Jcw$Cq+bPx^a*@VkxIvN*-eX0B1AL4NnB zBRAO?5Y*XEz3L}gs|VF9-_V_$EJn5$xmeZVRx~x03aGaCa9X%xS~E~ z*6P!Z7_#3i0wB@@#k&VsA9v{i!mobpi2$CXDSCN#+Oa7H-Z?%cD@?Kn%Dconh&j2) zRQx1T)hhpuBid6=Qvt${|2;|BZl4KHxXGaV(ID@8G_^Hpku6%5Q4i6edI?Em=MbRP zaw>J3I#(O;x+WODs7*>>az|Cv$s*`(S-!bJvmCSqKZN3@(ESwZvA?zN$()NX37LHz zT7YMI4aqZ!rGUyXl#-GoyEdd(k`qg22Y~P+KbPVnJA*EepH(0=wkDypvHvySP`y-E zQ^v|E^v~?XFVh-_@UF#|IKWtT@~mSIa&cVZlMnJ@b=frolu2aLSyCmv0PR-#s%qYt^=N}?f!x>XshomFR(z8;o6edylemGw(DTh`1){Z%9 zYqM(5jW3rGndv^5D5xr>lK0_eX8MyQmIkF-g=qo&>wZ^0_DMY@CI}V@{{h0+z12oc z`4fgNO6csj-|%{0h<*Md@@K5mRS16t^HdDtK^HLVWT)j{TP%0DzIJf%2>f?$LQ+aH znIDH~%lP%JZkxn|j;mF<#>Nz?^M&iiH^E2;5N1B})ef<)L~`vFgrP&yy^iP}aZai&EbW zVFr<`XGywzs3L5;7FZocJv86_fl`A*=0>UX{ER?qX;`B6gSbEUl&QoBW@(N$t1^kH zqKPpZ+omAZ+AN&ipm?Ga8P2}To`7Hdk;>T_Hoorscj^tb4Cr2A^a@V zmR{4NzL*fnp$wdej3S$ns8kQ94Na;cC5(`-Jecrje)v8mvyC`T94@hZjx1_s3>$Hc znL%}fvr?rD=V20Z+&pa+Z&U}oHgGY*6Z?I59DCJ^v0OifD7l~bN>H&jWYORXw9*AM zS<)NGuoyjBJrC>kq{E1?SU-HtJ(k?dcS_2LhCpKIJ1A%56soGOc4h$K(}tGj880%& zxPM6qQ>kw2Q?HQn>gS{-`N%~8Q(TM=CQ#oT&QvT`Mg3nRJWPPzYwjDT&uu_tT@?^r zv_UWT_*_CU`s|)rT!DbQU319e-m})lsT(I4#HTCL^p7RgPmWw=5{C0N`-Rl zLz77datn$K5~uSTN`L_*m_Jle63H2^>}PMzJY$Bk79hE58u_tNC_AstylBF=z4yJV zuw#4aq;>f6qH2~eRfR>0a5H6ms;a=*LXe*$0nt_{k-K9EYluP|S^$*>DO+kB2Zjt3 zM|20D0h(7jw;Weit{))$(YF+a-V--r#OVbwU0*!Y=CO2x4FIEN-eVJLF+M{BOT#6*3z{lI+m_&XCipCYgRfmmzvBD_TZE z3CxLXPRku;*of9a&olmP&yP78xLIOy`|hM73)Lrt{AC-@EE?f;n@dqwdH@ceISW)n zDbdP-v$a$>QQW~`?JoYzwVh~6@dczi2i7{%V4#)z+tedw;cWu}gb$vJg_rqSSJ8(F zC>d6o#_Ej%a{-a*U|SJF7(wwfD}+CHQ~}qmu5!!c$O@?RDm>r<*fhycXJy`yTx zfBVrk?Inf>>w_bMV}q9lFH=gD{tV_pu;|GC%2^pG185c|=WcU$I%lgQzpB=Eh`ZEm z9u~yIW6GVI-C0wGYjj-?thE7*#PlU&!VB%xe2W@H1*9@hxPs;^E0KT^_4m0z?%- zbnbQ;!(?@Oj`!=r0>CF{#Cnra=5CL-BfN7Z2p?ZKtHjwO(~BH*NN)h)w{9s3gR)!d z0L2B8c;+F~UZN$viU?<~`l(Dz)yIiR>;6iIyw3Ddma;xbF-0l}TE*9;sMRJOwQo-1 zmT!$)%+ezLHc6R>s|=D4GFRe{%n1O(N3U7{oc1b?kiRRbS7ZX7$CaOX73&`kuV_iE zj16_X*tqD_vAUipPa>OzFJ46K*9s~m%dJ9uDoSOEIAXe%iUYcq88DRxkQ*iw866Ms6HhpDvKPar@QUa7(Diu2tODK8uqXURt}h@PtMc z8P(fPPT7}9AcDx<-}RagltJnnx4`@-=ueqXO{ccP|7iH$pN zDXr+%KBU;uf1M;kR<=xbYv8@Oxb4Y@WNV_I@deRLMyoBj9C1=L#Ca!@1j{@H2y2U} z;sD<=yxU|#S%Cb8sda`@1G{xq1sEH8xW7U9tMh{#)5CqZ#9-|i$O(m=WVNwJ^m@Rp zBI{kBW|<|S*6UG%j4U?yY3?&^20{a!t`Q~?H$`jGcxMcF39ta+sehQDD`n4brTur+ zBnFC_)-=H50dANlx+2M{a=TfHQ?PEAEfVZ1@RKXuKDN3LNdg)oTz4aA9jq)45Hw@I z{2eD152Jj!-~Ipy3ty?>s0_w%0$qC`uV03#S>08?oOpI6hpB!*d?~`a&{+)Qf}5;e zjrL`uwIK|8Gd}JvK@PNeTdk`CZFpG$!Rc@xYGZ#lBbqfvO_jsx<$m&=~Hf-g&zK;rahlRZ>aZrP?Jm1F06KdCJQh zjD~(#R&d*1_nA_yD^Wz?loaK(9PNrPLvw1L$io-J@^#9Jj?I;XzJ5z}y0tXU{15i! z(ZuY+DH)^i)u~w8p>m-9@qZlIs8*LaYS~|$BT_zrcBAHbn}Wo$<(M&vdAR}y)lby)#AF7(ouo&6#2CW`9v{6tJS8b0 zY;~T53JJ`1;_*EmGjqVmaFCnA*%t5MBLxWmNIp5MTmfe#cIkXUnaxTc=Ii5#+>@*TAiU*Q(7i_8yV!jlW+)CaQ{c4q zmL156%Pj4nzBePKU2x4Qik-Yu8$})_1n`f7{2k^W#sd&fr#ze|f(<};^E*1A*B@0u zKcbQYXl)?bV;DeqN^*z8bwy!zhPm*n8Spyp?SUPwD%V zW$oHX6%0;Zeb2{%1StDsHd7EX>dE~BDe1f(uY<4xgn#xG852tC+COQ>XDIAM>LgTk z7GUdD*bKV4U=r3ZwhLT==Vqt;-9u%>!t-6P$&to&kj4|A5op%edLttI142Cc8>8Z75Gg8(q}^I@OHr&vu^}Abj#)R@%ksW|y7#w6j;9?LPbQ6RWfO zLu7q4!L^<34{XN55O^Xs4(}P(S15l-nV)LzZEfFm!dm$VFjxLQuOd7HRye4pK~~tmQu1N=wd%J23QClE=;+0x~|@hwRL!OM@9S(tVkygB}s2sOkQ3)*adEr9ub5Yf=W{u5v-iD zEq!}vlX@^4R`pmmjlD;di>Elv>oU6bt2Q9wAq&9TEPFyK7Ko7sliemli*R_WRQE=2i|Qw%Xq~wRO3D z;gd%#iXu|oWc%)(n`)w)U!7*~JWVYUq~c|Q?%y7@GC{9x#xg7;Zbd9 z%^+gbrWhcc5Gk_HQ#uDA{P|xiYVYi969_0Nrna;703qz)E`uTssx$`}wxz6R@~Um2 z3)A*sV}59*G2GxU4#A9K^F%~Vy~Lbq>0{k|)U6S;AjNldd~~#!FU)ZGP=()GUa~pj z$JMF%#l@FyE|mj?mgEcsKGGOS2rK9>mH>JuS;mh7LSZZk;uAN^AOdCX(f-n1H8Cs5BT?IqN(Vr=^CADR zs(K_Vln*0@kQw~rc`68?s*xQ-R1lzEMSw6yS_TN9=BOQGbU}c#>5c&56Mp%4 zOaKQYCH4vjESxyra_uo-Knkj;Pyr&LaTFaq+Col2kqR8d0-}~{#Lw>Gkcm_^(EVh; zDr~cGJI$-$k2u8at=WmWdG4RSXvi?~H-1JOc;MikJnHhT>*qr4rTLrFS7*j+^Ve!~ zE4AsHOY?J6RNtI_iXT+F<>2v5?A3T{Vm_gWd%<^nM)CeY2jlv~$`ZZn>mTw(l2wV^ z)4(E1iDS$OiVv&^Zw#dbegswR0QuPZXXJVV5L2_o&)#y;6JlXoYhXmNW_Eh5wJWFU z|MEu=Pplk$eAocwYmC6c#%U+#f494jDkmAO0vYh>Jb`_>r>ZwuV73r0U1V@`sDi?aBdZEJ;m8DcKba+B*@$GP< ztx>!bK4%>MNWRgapFTP*O+Wq;`!`%=sfDr#kbik^4d=%l)m@avOI$Rn9$j-NR#j^P zgw5fts4${^1bypqGo0poL#U$s;|0aNTF8p7qOw*RghD%x>H<>Vmd=T4pO`Uvz`~#? z4N2Heg(`&N)sZSFurl5~h2Y3u)wi{?y^lF(QtlA%C2~Pg7O|wPG&TZ~`qfR~nV+1v zI%7pRdv>kE;g8bJ9i%V)Q+_&yZR>I7tJ6T+p5fqe2I|h9nT!L3pZ??Y6%kVJcXHBkwf6S_ZN z-p|oUDmq3j>BT7Y0w8?xKkYtXK{=>lecZGa$}t)#N5{Msc|g6myU%Hj9}*22jZ#6! zaG8)efNsBfO5w2Uc>{#6|5wE~8L5^Qm(Gk=#X!Zcr$8y=T!v0kI4_PQ6m#`6BASPn ziqC-^`Ed}#o(r#b#YN$$)juE5KPI1Gr(B-6K6PysAiVsyyW!}Fy3KbxE`Vcb8j*8E z&E}7Nu)xm|wV6Nm!2(4`)MftI2MYup=`g5=dt_@YadbqrUymIUAiVNLC9aNKIR;mK zU}Jf`(Ql2A^-?J{c{C!;S!ftQc>2@KyB-OdDYPdLGWh*imm}3{1T&Je)Vlax zx+AXK1$;;hU-u+Zv@913dy8xGdN^5eTgo6Y<$k+q@=3WFK&Us1(e-OQoL~dYXOygf zT|*&zb4!&IX#Sg)`@G$ zI9yz(8pOvn34pMF!#Y$%bwXDr4$<{xCG*FdX-;FsPp1nPLaT#fGv;ajRincc3Jtal zmK&@Ns>)#WW6E-ggX2k>)df5a^7twWUIhZJ7o3VjCqNg>e=@kQm*$rm%MG)dXar!Q z*X7ew6}>ow%Q>SQtV)Od(r0^LJK1T4i0!vH=HQ*pWYvLP=>t&c`rQ1J-rqEg|B^iS zZgBF-YZcM(6h0Dw@ExBd3VD)uWMBgA``R|zAcz&Jl$9sn0HWI5f2mq_6(CIg#Wv`k;m@j$9}+yydJyz^jE?BX!>~Ax z%zWef`8?#-e%xT32i%my00@8LA9v&x;}ucvE7=(rrI6nqtxvXHc%w<;AD4o4Vbz+W~kbv>4Yd<5k$8 zNQg(qKsJCmK={NzZ@RM6g)uHV~RuisN5+$6p^egp;#O$s)_IUy5dcaB2Xx z{nYpv(O6u#esf`RX8DQa(GEmFMwqbJv7Rc!$DMe^JbeP| z0tj#U)Q$#;m0*jL54Ivhv@tDRtuj`%#7doZX?M3jqfMiM91+9r(2YZT+;oCt(e~&E z?qDsB{HzxgAiU#T$AS3=(hmICdV~fZj8mhLoub{g_lOcxWRXWc;c-*o(}p!eu{>1k zPW67`bwW&3&CB-c6Iz!vYeR1zqyA9TNjzoT8c3TFQY4E)qzAjr_+w2}ynNlgpWpkM+{=q5{|?L7rT?cBroQM*T3mmNak zHNTnMM}C$s8umFL(8oi0S0Rcik9n~ENXe-V|ELGD?J`BxmNIO;Su2rP@ukN^W1aRY zpL~mx(iQ`;bT-|Ec`)HG|6MQoRS|!JTIUvoxcG|bqc&de-`z)6;f5k$dPj814M`8P zTcoU%7vy151-wqZ{8Fix_r@535Yu>RWoqL3*%&QAc=z37Xo8tn0AI8$1p^qUHhb&( z#KKH9G#x2X*B}%FYE>!;cP;kQ3um{9UE z1u^@^&xTgVV-!rwVxna?uEbf8b<%jph~g|FCASuTJRajOVjVGf1GW_}-=rA!J57q@ z@*EvEElDAeDT}I2CKtP-FzUWUAw;@mq78&rR;XEkaN#qqUmLnUKYNQ>s%FBC$WEJ| zz!q4NS{$eFUSha6U$dcZOkTp z0Vj1y8{WY#yY;|hQ_9sx676w+qQkSdc-v{SkQ_w3KEFsY%9Ud10edJ^N{PWZ`rhuY z2Eerk5I*O8sFEbSmLJ)HfQ64|BR!}<#|-Qh0wB<~T_$@Y9f=`#wMfdW12A5W;iBgP zW-vntNn5=knek3{MQwoaRj0{bX~T5TaD^h(X1J>&i9=A;KMqu*RHgC+o|vD+i=e)U z#GtO6Rs9H7KgmCiK9Zy|zSB@Jz)PPtH(=~;TrSWmS`IZGQ?K8*{7)up-D@6Uo1}=! z`h8n1mxn);&865Y#~Fa|r9T`{T9wPFlO0YW1_Of_GaY`B@?hJLMZ`7KO9;r}14y_r zsjeP!mMh=Vk~A|G@G5eUoYRpj`-chjen3#aR9@Ihe5P^V%raNPEL;9Jt1 z8>&QlvCQ^2t~YqrX4W@x`z{t1H?fS{aMsy&9Yc8riWD|h=H5305Z<>ciYQ52 z_`P7#iJleYBKRW?Vg%Sbd@(d*HEI)f9HBmY%Rb1k=R^YX1w0T)ysN!u4#p{bfzi(h z(B7t%0)*-FBo0x?Qt8)mfd@z4a761wlGe2nh^?8G*3GP39+N+mTj_+L+>r3e`pOb; zsfBqJ0SPJ_wWo)X|Kqaa&Y^*i+i%9!tp{6Tknx5@)D!}CLP3;wCr#I+uA03%bP+Mv zp$!l|_#5=U?dKHjTO$Pl)ONW7(7Ci$fZ%PQTzphOfO~3Cz(*$7`n>?5cq!E#mc4~f z1Ml$>%~A-P4wxl5h)nn}GcGt)x+1AN&W>?it+pcv$^tG z7Mel2lT zTw4@Aog;MD*W#j7{wkR5ls7xEJlD8pNweQNIQ~IPn*AT1iAl5eCBVFJVP*qCP6^u0 z0~*xUMxMX8vblfpxhu8$B{E=@z)F<7)zg4zL+_gVY=;N0Tzt>b&c)|0;fEi;ba}i^ z(rbK>qGGfzJwh!SXv{6ltnkHaLqwhL?Ccl6p0}nL%645?JD>;K$n(JGc?MK!p* zYm=0+hK2ec6R;`$W$ifb-aFjfvyz3on=QQ*A6nljc7ZFwq4nH24N-GOEVHwNp~=PD zBR&DYN&Q$`Ux#NON>N}DSUR9T+e{_BWUr=7QK>YR^oyTkin5iBnW-5%*5@sA+yG%_ zAe_?paNDk#_s-E>aEBNV%aPc#1bWZcq}srRKD+;qYNQTx_q8zDke@21z;o!MUl|{M zuD~en5JOt}bdBX*wdE}@h24Ntv*{!D%KSscptvm)VqJQ^7h@Y4 zJgpb+EpJ|Q>fn1Gurh<%?bPzKt@GNxDAy1<4+?&BL%-SGgibdB!Z&=<>~+Ia>Lp+s z;o6`DI6~`<7i>#_j9v6`73Y^%uGv(F+aR_ev3a2BgsXlA6Z1D~ch*21yD&2CL1wAM zAaa-CAd9VKl|Qfa{tO2Kc6=-$b5~663&BPr4C*bU*{Q$q0ww1+*Y+@H1+Z&_1`R(D zd<|3#tx>>GSk-q^*xh=xd#AYr5Nhw*UdKL7qe=4|;=iS!QE(!v!ygN=dXmK#Z)qtvO2lWzVq`%~mk8VRApMhp2M|90hflj}{FMy7 zxEug@+SiVKu4k|#VDA{v@y$t)gL$E%0fayK6&{H#wDvuo271TttnCX2-0lAWAt$ZE zK?e~2;A8H2D^O40p9H`d9#Np4w%KdoK@#h-TrF=pJ0p_U`4233-}C7tY>-hW$M(r6 z-*z^YKLNs5e?j@lnNd{qs@wI(obOlO)u0GySpih*bcy8* z7^Vs?71vZRC?!Dn_Aj|8oQ3_L0_+DSl)f&w_YUObN5UrYn>)0LY_{_NcM$HZ2K4UQ zBNuqlqPKAM(82h6^BfGe^-vO#D(Il70EBn`z|PT&!?iCuqWZjwOCb+)vW!$Sp@n0j zMmb95Lphi5C>>cDs!c*0YKM9SQN@qBwssfm!BE1BVJ$NDGNVNf=7@r}S5BOpWHzL9 zzjP!$Kk<0j&$W4F0K#vsmS=O8-(TO=={Uzw)-6D^3P5#stUyr43Y>*1sw0mx3R%GB zf@{Xm$P%E#=AVL%fwx6hi{iBPxaC31}$sxPI`4qOt$fWINcX1 zn6|cuS*f+ZxxT&isCGjFaO)mGc+VxWmaRTvIs*jLc+)`RCpra?xr*QdQST5K2U)0{+EwC)f-j^+Mr#pa{B>tZ}HIh zK?J+!F|0qHZia39O)0kTq2HugW{C6-%pj8;TnCH+!tehl1@zAFs{n0K7<;v*+Wi!C zluaut^QLcOa8S89^#vx{OC2)w3A}l0oBp5{z__#4I&?D})&SX|!B6S^JIx^l*To*W zVX7hQ(dI(*&bhT+_1(C~dp0VD&x^c+2!QDTEnD5K@$KW;!Z8|{yeyctbz0tC#Cd&J zc1Otx|K<1kfX3jlct=kt_M>pdMFD{j+H|rm_(b#|TIede;pKJ#J)UMyC3JxBZ{ObB z*Vq{YJMiTU_)$FChAJSAM6i;(!=QX_nX6BIg?oN`0m9$^d!_W={Xp6S%&I^O$CAvg zsM>6JGUU0s|0Yxk5~lebs(2i8{dO08!9pH1Tto+HC+D+vm$+lwQ!vF{0K(h85LFZ{^X@^dme;5n4+XZ2~~+SI-8&h}lsAE&Sfq-|Gc zN{mgB-vHq=o-1E!U)MnW%8HPxq8FcOg#c9xgX;T=Z`2&Hd_Dl5wT)w0^Dr*|tM*Ps z3=a_F@gg`hAAekwTtV*Hs9!QL$IEpbd<9+=TvvZ4 zAbWUp07uyait8h_fhu&ZYI*_Qd}0`E3#jUtE;x9GYf2FY2!sDSb)oLwv$+4-fO@_H zES^gT6k+5CKAKk~`GG3>Mbv7sgm{3SK%K^`E=Tj|Ol&T0Ks*85nzA<}DKn+NB&~Sm zT9hs)aE;#E-8{s5VgTj2Z8V-He}ItX#K(CFnS^3@aTw>iWlFNG&Ebx!qE=J z$WiUA5k1sGabK|126%U)cJW>C{K47{Lohjoug&3TeAOe}y0HtZ>@iD(^#?X5aqjqn zBS`{zByB`Ko{DmKx<+uFWu!u+Ay%Wct2ilMZG*|XWG4U!zdNpV%`e)z{Ay~R3e#^F zSM2^EpL0D4q?2=eVCx9$n*&KUJln7qYhVdN3!$6}jd`^enx4cJf&KD4mKL{;5?TS< z;wA7ud!t9!z+OB;4cI-?@4D>V$XjF zh@;4fGawFRxkzj?iY>&UN;*!04S=xugVZfa9J!+e-&{J?pe(*Qvezdk7E=0 zKhZfvUIU?-i%Vd<|5A$LVGQ;1a1)fGgv`;S7uy%_D=C&OZ)O<-g(J!)M;%bo5@P^_ z=YOlhJS{ZzaTISrWlz2EN=fyOp<-TIr5z)s0@Reor~7^q5lodpV(L7*vX>hffm3(o zC{iXYOY|?I9fD|^QV$SzUVSpW2A^kctjt|KV{+!PlNm4`OZ+;Kxg8ZsJhpNprLsOy z!C$2|0)Bw-%d^LdU&VoE5zLNz&qN!}Fv>d>sr00CEyh$~HZ=-mFtbHH4j-)kPL;s* z1f2lFw|yuSpQj^P8&CC5)v*y9;M2M1BaKvVqsYu_Eszs8B{1Zn(-me;+ z+XIp^^a9IjyX7ZBzvD}Qu=U;X(=u_k&zT4z3s>hCCnx3!h>VZDo`1oj+KfUUJ>-Ny z2RS8Ze1-ZkAwz*WO%p5FQmUU^5cwzMkg3bHA`1#J5J$!yE{*ErXOOJ`!drfP@wUPn zSlw&pp&%x90uzJ#KEMM%DkS8}EECB+5+A`xbffYJ2v9q>k79*~;|`lTXTC&plUQ&> z*nQ=lZd;wCzDeKuPV){Wxat2Qd0znyxLoG9_wJin#y^BTwhlVRoQFAKQhuEwqu(0VUJ*Esbo0W8rdrYmJI)*Du zgswb?_YRKCF61Sg920mA6;F`=xcKxql*c<>ww3g@}0?tjYpGuwQ; z!+|xJ86bi;K-Mhv@iPqCpp7-$ny`)8wvS)9AYvy&m@QQYiI_Jy2mAY!8<_h5T5>Xb_jPS`&RfkL{C|qrK@wjpx^uBGukkT5sJb2a3d8-1CK6Nng1<54 z(g-kN83%$7fb^gw$6Qdb&c$VMvud&K_bLVJdce6}i)vOBVU_6>E(F%SHb)P00EC}E zl8;$n9w0JZZDon}w~F?Ax~YiP7*w`w-#TDVtIJbT11f-W;&>n$6yu78;i1?RZ&p%#Q+hdvqD z5kUCZzfL@wW$!i4MM&xF_m{MqP>Y;PH^&#VGqvXf(0A2^0zng|vSW)QArCD`>}X@k`fx}8LK?rAp%lal>AW~biCP`M-_ z;T9l#{BzRrS@_AQwBO{Nc(pcpZ(EneuVi|$c*hDkIUs{igTVF4oo0HA>5_(Aa$+d3 zexf79rn(sTbmVB0Lw;IM>OO2of3l{It0tidL={rj_H9=q$ z#|f5z0UI=!F5`Yi4Pa5S$P%wTI{^u2Z<8T;ek*hHz}O}!UB}{V4Q(KTydB4~3vh|q zZrPSK&PlAg0KcVj3yfT)wZwb-#T~xqufY;^ogFNX-JFlowm}$qC&<@#uuFt~xRo-d z!W|96YWR9$hpHMx*~G)2;P5TuUKTJ;At47ZOyAi_$9m_rNwQ6q*E$$e>->-@2f@u^ zjEOF%plNH>RRM&*wVS&j1aGQ8X#cG)bLc3~Txh>hLNf&^rKQHiz;*%c*n`%(ISoH$ zNmJ!1JBqFEWO0>8jdHkeu{c>Bs%i7x)|K~`fCLb>&VyJ{E{mrz>4I48+~lbxu@v*< zNN#E)IcVjURa@FF%5o6Dpf|N=(#05IR|R`c(p$N1Y)WDnZ2uX*O(W9DOty9}gau}0 zkwJq4tu8W`zHt%&5PtH9a>1R)$yT9GK}D$2U_F$nBAp;O!OLyN3x9M6hKX2(m$eYL zveXl#9bN2DSILHo;#JzR039cx-Vp-;gg5_m=m%6SZq$uL*eTu=?bTg1tEWJ4>Wiwo zez1A*{Y_~QauJhM$@?x~!&0heU~<|r{fu~vtj=vrl6EH~7N9Fcq@9RJdwTUDN8$_l zWM2D%w>V%%C6pV8_{R3AdP2;ob=v1}iyPh0mG{B}G1{QSKKQjHevOhCkpAGvs+;Z< z>buMHdby{l2N3?&XQ&0Pe8j!MKbWV9_i>}sxoJ`qUqZRK5dKNo8tO^yhp?%un|owUuLJ!QK7-}(U|ZqJPdaS*Uh)*C4u8qf z66!a&t-+#WqX9kj`b*DdI1kpa=7JH^0O4OO-S(K`6e2+nTHdo0$*XEN)fet> z>UHvbJfZZ;5G-n$KEPW{OCrJ@zCWAGmKp%kcga51&?Sqvyh55L^Tk$7_@r!z{$m@ky zh(*t=wMcceS{5dV;+j?^;J1$CU4=a-&a1(=w$3WJR&+5`tmX1`ZHD^{bUJ!#D_}En_;S)#onfGMGPt zgc)?ki$E0<B4VpSVg99`{r1YiLZEwYhJC# zs=Eu$?AF)dSAAtQTpb;TT$UJzS4(WKeKS@q*W*QFhW78YX3cA$^Ip2yn4DOd zxo-X^jm+P3jg_v$QR8a3sPqwryIT&YVk3~Rt1~{T3d;0_KWLP6-3gvPV2&5SdqP%( zMG!qOb=L~Zn3HUIW@%-ip;|a?y8;OR)1OwosPU0YUiGoVJUm21^&|!4&HAY#GTbIBl;WZKMg0~hN}UVQ8bE=1v4|Fl-bBAr zyv0gkD#Z+|1L#F_h3RR5xg16sT`YZ7sqGUhQt1xxb}B}dVF3`{+8T@Rx0Ou_@T5(> zA1!dVUHS)hwtW=E0SE*W(TuVV)nHwzFpavhdu5l=YK5=bwK*yi3woLY>cVfFQ)6Ko zZq*w>6xEp|x_R=Gc4`Y$B_kk;ep*B`?X63Nu1o?DKI=P5G4?FKyNaC^H7MTM3d&U1 za+ayfXNe0jpgwU(2tfGqkCY=4g~wi^iC|^PYi4%XpToI{lP94ZKWGtN5LWhvBvQ{W zf=Exi=Z@_HgunA|2%aFu$VASVB^GvF5gUvBw(AJCs&c=*3yTcbzgJr}3w%CfS>fvd z;RD}@eI$39jzxnqJ>-s{st&wEbZ#;TuP4!fs|>mJctYn zF{ZG?Xs-?!XBFwEMLI9KhhK6_6h-3U+E(NFM!`+>EUoT|SmYmR1_2xDv`6m_8^M+l z0cIv<%XP4_w%*~RwRyKAWV2545!qz|gGPyKs7#L~rcg@SJIW+Z#K{M>MCyS>Zxc8z36%+ ztnQ!GReLQ6uGL4q^0P3@L~vc{NzI@ zY?FTFv_F4ANO>c_-SC&iI{lWmj&{RA1B4GRmVQIW=C*1o(gjzC`IPAz~IwSEc;K)%`;K()s!sq=*5NpM#^p35eL5*Wu7}&64 zMZ{J#_k^rm`VYpO8` z$dx=Uz1LE`sH$ud>pg0E0ffzQ80TM_ zjCw_N)bwe6xojn8BcBj^P&2l^z8f(daAf$72J)X2Bp7s8W)UQ0baB}1LR0B4p<-t7 zofaN3fbbXp)B6^5c5t+}Cu-|OVh8*M5}7e&dNEE#Zn8(K`!0xD`G08(eKf?;cSrjh z)V4MVi`TjfAkXJ(M0G_Im$Iob>^V!h+dZNzx+dG?JE(tbv7x6>=Jr~aQE}Kj3IT4a z)#0bjUiFZpnQN{!ENH5jVTkJ+7EpqW2|XF zPeM~68oi*^ds!NcGY@NJnbTlT+1|r=Xs|$YT3CAo2JLME1jQuf)oL8CGh)XQ3xTL& z7%R~F*|Qb?TD#Lcun%lZ%#Q{R6jFsWXc$E;Xa~+4Rq%Li4PoO{#Vk5#Q`f%-F z_nd)ceT~xWRd{O@-HvdWL$r4=ujNNaD@^lPeyOYMDz)fVw7F%sl4%(pTF{5s7g>Ga zX-lM8jvFN~7`00?I7+)oGg#!{7BAm>gq2FjvvPQU>D{$wr`FKZPnLuH&D!Ml;Uti@ zsxLs(PkZfAco#RUW(5=0|4qr1#r#4d?5tTykjJ7$5WJfP%ZzfH^VHd+$nE_lR1aIR zf5zd_1p?w1?_(0Y@9Z36QcBibx1;YN5H#Esz+UY6+w`jU_~y<{XSzO!_&XJlJu}mo1X2QmpxnfYt|JFgC6Y(6Q22;dlWL?{=jB! z34%Fm^pfiLP>|X+XqGCmi$Gh+#!Lz$n!|>jt_$Y7yU6`pxIo^l6#UAE_)ha&`}hR4u1gNi;{`lp0vEVAe8Y z1yW%lCEF@N^VUCA%rrT9d;74_oC6E9wszBdW{mBiJ$>pH`G3r2DAWYJq43iWEhIggsEm5Ra1t zmo3(1`mm`zXpLiSb#e4&?GPaJeWx)gQ$dYuT~y?}MD})V%T502PIV*a-c{xVbrN)_ zI*KTriI2$c>9H)Lpk(1v2IW@QI$)mNO*|4OE-!r__=3L+5UzijD4s=WXiQ%Y27&g) z=Ddfn*n+?rkuJz4tBzacBz3@s2$arGBHVg&A5Imh6;3`KN*75lvI_Bq3b7P*Y@@-& zf}G-3UTCAPzyqN{#)>_F@CTEMD+v;uDCv+Z@Sz=9=mK?rbCXiKhw65MsI+1d;u;0~ zYgqfGDzta4iWCp{Rwpx;^s>du6#G*6Km9VP!H zThQY!1weS`Q>C^#Jl3XVvBQd{+B-EXdQ;voRn?rv653XWqBjRQFM&|->zjk+0EG86 zr>+(Jn3K|(B-FA)_lS@nC7LH^Vt&4CWjj!$KeSOzJB<=SAZ3j?i?lYyiNodT^+5rI~xLw zD(8Q~A)FchIN#)e?CBW*gwOxlGap10JO^~6@`;ENi3x=pwH>hApDr$Ah-K7sA)?r^ zA0eaj5W;v|7H9d9s3xQdCcWxmHF7TQ2uIa!P6~I`{kh@}SJs->r`HbGpcy?hE`@32 zv3@EB$h5lS?1@*t^Q9vxJq;6Zbxo`(9>Z_s3PrbE0J6QVe5x!ze`|BE|R_(*wyY zFe}jmIz^EM*B3Nd?lVC6weKuFAum{4`RPr%Bi+U9ny#NtSneXQC8}gnEG{Ye7eKD`d?|q zaW&Cz2oS!XYfglCoAWT}(A@3R%Gm6JP8FkAUs@Q;wP10A+EwOG6Z0vK=gMN8v-YK~ ze<`NE%!aY|`Y<2ZL_vv*8&1*X(Ue~OH~8&%2@r^RFiIxX0O9vOV*I_l$`x5u>z&&$ zZN$9pVKLJB_zKUS21PqEe^-U}g49dxGZ4x{Kt(UOSUbrJ(%t3(gf4m)vnk0o@Np~S)tyeccu*7)qNm6q0I^K=0 zcR!GDSr=b6p*iybea1logim?j%DsgRB_kq6-)}_`x{HJtgf*w@(Wwey35r#S-jdK| z9#l!y?UC{UHWe=0bE0c<^%-1z0O9FxIYEFoNF`De4j|jy+9_^H7pm93LZdR7Chb^u z>`o(<$V9k!aS~lSk@c=LAzspO`;o6y!4J12vQ?!(2O$n1eBz%&Jb+3Rl7C49 z-nd&{6+8s9$h88Is&cJ@r}-B*+L5&jPDYw>;^+Wj?|G7kO12rM=sF~=0kS00C=PfxlR7VYj2n3oZRHNjZ#RRVs@0EiSES z)z4nbVnDkDkQKWCReVQk&+%CmgDst+YPeV8lStxN&ykCIR#QZLmBfa~q#RQ5~T&ilEG|={%E5Tg&4ndP!uZJ2y-iEPxcbR`F$+UqlJVGYHD#)q7%^mj1p4eD?u4k9U0c1U zsc6gfncLC_EqX>xK+(M8+hg%%`lFUFtHCI4EOPnhhtwKX!|?0$%oIdX83WgOV3&Gf zH4kJTsnwoW6I`_@MdUK~Tz~&d1a~Y?;!?~4SQckb=pqVwe(0MYN2MSCJ;7%J;JAqp zWUP7uj@c&Of3&-Q25IVqx%&GY1?1KQGpW(Dy78LFfE{e^)0KX8WO%T@HaC0o{k!|C zh&ueuJ>7T>WdcoMd+SIj!Y961oR&PI5dgxynxac&9=XFh__25FUMoVN2opF^sVT$S89XwnPjZxeTuG|Hlj^ zg|$Z)qq*NO{E%POAQKTp7QZti2|)O3UwXnl{P&0?=0ZOMk{p90fkQjR)iK0tFP84K z1R(s**LD(=F~^gxC}L+&L6OJO6LL1XAV?UfrwDT05cqba&=EnbI4$Hu)C7OMQLSvr z00@8OXC8+MCw$+j`gWlsE;qS|7D>+W^uq-{%x`BWBNd8d3n}S^GZ+(7SN;unz$gW%Y*{qpbH*^GXvRrNh+=zdId~4 zEx7;)Kl=YOOgMp7JUJ$8{cMt{GeT6)5;3jYSvu5ve3qj6xBVzl7NguD@5By~!)oN$ zbPv&Rk2p=Af+qgbo$Ny2p$ZW#PhA_5O%VP~lTMcp6jfPa<&jCZ6JV#r)r%z#-~DRs zHTOF&6EfPqVrf@LR9_v!+AgKtzMT{TlLAHS-!gD{^wRk+*m~}aj$VK;boW@ohct}r z(L)PvL8r3fa|LxI?9t{+yAwM0cQ|KygaCzW1t5INpX+m#CzbX@I!!JicZQHwU`Ys@ z#Bn2fTTo(;7Sm@c4?aTEd_1I(-FH!jQoP}SKjm?|5|8*`2x)V2V*11=I1D!`(F|Vq z0rdAEfUgRH8XtdC<8OW_C*JlQO`)Aw;ROPC8xxHglHOYrhckN{i(8BPI-2CAdJA|* zRPfl<`sKUzt0N=N->pA?wLUt^AJ5&jssU(_rm%j?PwxDpDXbShAJarsS^1XnLg4^v z8k4~ENbcnaYkLcnI3c<;>YlDSUhx!fRS{6t7AxZ*#dGG?#C$jy-i|uuV9KC&&GmAv zc4>UrUbf0FxUPK!rF6$OL~1yi2FRMLq-!*1hCulpvnmEQ#&zoP-gYs*?p>WK?@t`v zmD}3$|0z-M97*yZ-AC~jqx_KUjeW_sM=#s9H%R1DKw&;IO4OXh5k>1BDk)-laFaY)|u#b!@ zvM$5KGx%$<5V1%#frz_nD#{R#t0<_z>uxM4hB#7?%I7|~OBr#zv?(5`7@(eDKtYDf z27|l;!7Wd}X3+-vV0q@29VpQQplsTU;|}Eku8fbCb_<3<*QF7F!F9kqd9~-yTUcdt zfBEHwqpgLtJ#uTjL=9g1P|zTMX|<)*t5h`MJoz799++6|jmoxCv5Gp4u-yVPGCl?n zF8(7giSeH19(WK}l;_T6F7lhIaxiKj@wapn_En0C;yGJEn^X!FHX!x5=Wy5qoipr` zY;o2Egf@3yAf;!UW#-ahT%_=n7h374u>lCVK+hFZ)1;M4WFBJ&`s&#Dl~=Tk$z_A1 z@+gX9Ee%k?h6E7)>yP?IQk{kQxs}F}RaywSV}yxpQItY;rQ=Rul&!pYWrZc=OIEJS zeT$=;!6z`=?4^wyiyWcAHQFn zA|ZEqW>%Wy)v4*3d48`<C>( z=+>?3oVui2nU*fnsk~5GhUBl~EcR!Vn*qWdG2wIdb=!qt7|564(}#om+i8nkTNf(Qnv(A72_8MjGv%l+5&Cl2MJO|m~*p6=8z0EJuT8ckmdpln7ul+3>$}NA##HJSvy|g5W*@+7< z6ETNhq^yuijB=Yh^n_7hAqs=nujuQ@e`9Gpo-G#)|&_F{cbW^I#YcScyO1vl@jwi@snU}fbc8dy0dd_`vu>2 zgIYRWUNXm#2ca#B)vy}3zEm~$~~`qEk7*OE*@KUaD|0K(C)oEj6l zJP7rJ_{}IN=z`lFh!r-|lz~$=zY|fh%aGkaIvo~TJfw0GB>Lf>8q&7+8xwQlE^P-F zV^P!&PFi+}fJ)DR;~4$SI%R^-reHDU9{i_Ck*a zV%Fco5szBN$fm> zwb{Ab{12Qt*PmgtB-Y&Q`vf9yUKq#X#HTnY(CU-(=Z0~~5 zv$gV#6qKA12r07Bs4dvrVuKrtEAUJa2e$(_(GLvL;s-kY;+hGv`j{qS) z{FvjdSPG0I`ikZkxhSwTO(DKhbV@N|BLkkLl!>30Oieu_?1_;t9HW>HS)!O|t*AN; zTuQ6Ce1mRfF&l~6ce;ffJI|Un98KlBRP@^3-;sX|plX{GvTa`MMLHbAx_d>8Wh_-WNb7B-Rt|rx>LH z+aPE0+AMo$c6nw-MUJ98lH7SYMMiQ&BqJWkn4Sg*-|?0AC=4iBtNm3=eQr-EK(A4w zJ59YZ_r4iwJK-6zKeZD6B;eF5Q;A-X zm<8GJQY>llf|F{#7iGn)Xp7bK46A_u@EJ>Jsj3n{nEMoLWnf-)6{(O>X}QXYL$;8c z*;|f&*IcL8%KPwntuU~<0O8+0^aZCCMxoG#4rO>)aLyGNweni5b*IVJ-!5oU z>a2fA74i>AVHxkT+nm`{=pn=F$&@ry7LdyChqd_7UN(liF(I2S*6&=`&o1PhO$tET zA~tEk5HvM6xTB@j(KE!uM);pDZsfu(m00@xJ}+9$Ibi5?Eh&*(V`D{ zrpSKz;!Z8zl;i5DL0#SYU?d|?+0E?-2>yS@aM!j~IPG>s3VHvnulzXppm8CDPy5I8V625{yt;|kx3ySLzs!^O-nF4uDe;$62G2>*`R};uURJ)NSN-5=E@Q zy6zp`O6(=#XAc;tv=-^FG2%>NR zM_vz^f@$Q)gt)H~Je?i@p(qYSVuFUQ*Y6x{i47HV@=_ugH=;=5E*Q3E;|)t1*;%{W zdPeW>9|9^}dAs#DYH?Kn;p&%eQfxGQW6e@Dbexo$ep_1v;==Fficc#L9I8!p2bA*zcPo%1P z=5btHzZ+JF8Gkzyh$j4mDi#*U!O5neb}`n0(JRzgw2F=n9NPmElkmq7>iZ3>+XN$n zHo&7eF|k7#o3$hA4(n-E(t%7fwLu8E5GRn)npm3#QUhjd4YZy)f(kuyCgi!a$K`)B zp!Y~JO^CvJG<-U+gkcXHNgUV@#?q}GHJx_Ck+ONPAX{mXDb6=pq6=E5WQ^h^3#Xzm z@gYFpZ3Ih5k4z0A&h26`7)3qC7aVs*Tnp#Q$ZGvcJ7_J;ufjok zV8a0jKlPooc*z^-9e@LD*=UU-EGrAt?8Ex>@Lm%tkIH!w(G@+pUbjdXPJxr4O48OA z0X6R+aB+L9xub}ZKspFcobxK(3Uv)H>rM}B4{aiJtI^hZ$sb%$H8Vwm*45W<3?dae z41~b3>$BKJgN*@%AKsVcZ(GIIHD*xD+h&3_DMBo5<^@?Bcv_S0g*i80+gztCs_E?J zBWclLZA0v-*b*^-bPKfTM%{Jiq_R7D9qr5#C)JIz&lJL~-IJjd&A9Dg@jJ z-)5o-2mM0_4|jKW_Q#Py7q&OnS}TVK%{z!$H%#ZR(<^G5`uGM56B(f$d`~@%n(`XF z@U~#oy0^Ur>mu=>*piQ3QMju6UG_57PHsh8r<-bPyFnFqFI8+Jhl?=`_akYI^b-lB>1R>zs_Jm3e z!4X5{vot_^)Xu{6N?~fL^X`1J%e#Ty4U7$IE{%5R?GP8YDCWVRaYY);f1-8C>|A36 zEy^rTgc4!LrU$UH_4{dEDwhBd=ATCNIuM4u>i?`RH>UKU%zZ)f8ex&a%!crihGB`} zSzm(-cfrn9J{VWN=Q>7ZHowVmTej3L^US|51UFU0;;KB$YmWFFVyTUK6ZWWADHFI| zSmjN70U-S3H$`bBzJLU?M{9<~{nBSvU#(wm*L#GJ6@Jw-NdP&2x`y1D0*vx;=ommmsLz_>e9N z5I*#a+xrVn3nGy~9>dsrQ{53dS(x2G_&4ka5?mXttv|wEhD@G$7DyZqa?<2(cjUBVZM%oA z9kRvo0fd|XRnqe>wV%5Z6pE*NhV2^n4Ljd%;R3F1itAc>mgz#Gc#AqhfbcgyCUMGb zme09AUA|b zL;0`qzTD1TB`QO-5~7RNElq?zXozWCtQc!YSCIQ!=}bt(&m?efPxg3qjThU}CXF_?jM9asb+vdSugf$)96Y<7MYP zJr@M?*5=NZKP1>NR&nG2;i(S?^8taZywrBMG&cxHz>96y!;IaAH$GyBbp$aQI+b=@ z)OKVeK^%RN|8*ZuBHQfkp`}|B%O{P|c#-*;Ul9qsrQmhOLWSW?W z#oT_1+W*WF)7TtxmI8!-jeW@Ul4)9TF1~bgi3?g777Ej!mMv4>?5%5ah3L_4ft$TG zznE=f3)UUPs*J|QM<`y$Fr3}BN7_k9&oeJYyM*IyBeVq5>dl66ZCe2Ac0^hFDoUEi zCzYN+$68e``G5W|A%G2b@s2gQ;>74f2<2IP$*|1tJ@FHVaXJFw)%epa`A3JQ4X#K&Dzv&~cOVJGj9m|Z zx=8)8W$<-c|5?1gLI~T^{KV8m_;(r*;4V=Osv@a3$#*I$f3t_&oNtP4&s$+#$?QKG(VAY8f9;( zsnVADU+{LYX>+Pdd4!)Qmr-NP@A1m{WxF1+(h7R_3)?ZN9rtK|7L13S< z6Y4s`+OhF^nccR$c@YC{^I*Tp z5X>VB%fYtJ3=-`5O_o8|*SEU{d#{hYV|4f(nInaIT|`=|}D#X0HCd?~8efi>qWwUd(nPLuc7ch=0mQ)k_k33q+Rr`+i}eE+XN z6aEm>z>cv^S2Dl?#pqc>iNMyuZd1+_z+*{WYnG`95SHFNa|>olPHdCtZ%nbUDJYkl z9R@usOG>~YLgJyhP(VR4hv8Sx5_v#7NsD+iNiV#sJiVEe0~Wj74M>cD7lnz`-4RP| znn}6=@1ZE#kg+xN9{M2mP(F{sn@z z=?SDOCOq9Z<$Ix2?N9(hAxwr(@RY}-s8SV?@Zdo4!l<=@pm!i&T7g1<@RNN?Tg%3> z8KHwHf?*DPDFkUtzwVTe*iM_MY9j?J@zffs!W0HTkU*^M#SmYc#rH5T#c$;b#H22V z47k|F44I`UeZqMccIO1tPOzk00@6&G3Rqyk*%l%b^7@Q%E!3*gGvx6 zn^bn-rvppJKp8QSn0#^CPt9Cv@wSw&>3$;sb`vwLTECp_ozkP3JA&sksoDqvD+}sT zgOg$&ApHE-CTt016dA_<_&drZ|Dzlpa0c zY>Y!BR8Bu27vulZKaH5L z0)$_@m9aD8l}Jn=4>p^CWR0lfq3eG8YBG2;^?1P}eNvd90wdX z%E?Lt<%~Bi_~U|MR>IOxUprcJ`oag6^@DK_Kehag>q_V#p8`j3f!rWRe6BzW=)v z&L*w7q)Xy+N3RNMGoWdqP05As-EG>c$ATPMC}Th zp>K%!EL!eor((kB4ny>Cr_*)I}#O?)=-)masqodxoW-h^046MzxME$Gq2T_juo zk$^oVORadCLH4~W|F8#gRUZrq13ca+!C z)?>oIeyJ=_^@#G1Z3?fbbO`K$0O8|*Jws6W%{^}ROnR@A#G|ML@In|N5mn+-5+dCNYfRQl5 z=r~z@M0f9prt}UhyROCU%;?~kyK?p~$W0VzNJu$~tVBiF)`^0ED;0>xHHa)qw*nyi z$e*?x$*c+WG`hvif4u^tDIg|l;0Pn0TjEDWo9}dsB7N5at^{2u5E-MToCTZ`AbfDc zd!E{bTU%et>ZutdBHu*fa*;Q3Byr8Gw$m`=v1*Z|6FcZJR$f*&W=I;=nDzlxBXsI; z8_feF{Wf8>k?R+?h^u-e)ufP>gc?d+W2lL#l4t+}C=%_zU9>Rs5TSPAewxYz5WazQ zci)~+Z3d1HCLLJyIk4$*s~1tOEA7K>`#^!d(QrIGV>HXtl3II z$H1gxW{^;zTsWB-gy^VRlre}g=e2OdH;~FXju72lTr0f}jRpwcHfqe=m>W7>NL;A$ zRfe#gafP}h)K%E)1-gPMkOmzw+De0cRSU6EjJ1_(iQ#IBRvWS?xL}jbs|bk-3{gls zKn%K2RgpPNU`<$s3SJOISE$B*WC@;;j9mc;!~ful2kcRu$U-1-CnF4M8LsytzrMg1 z&HJ^rLs@Rb-&)jmMWRK&M4ur$%e1|&uEn4}##@tu6{EJpfIznV8eCGt$xMc#I@eG= zLZx{XT5&#i^YB`jzpR-m`caWf0odL)NlqPc5%Y4s>`q$eN}UXR+(ubpTPvG)mpVq- zd?+fMmD7kGX4qmcT}mT~fw&#i0(YVRBR5N_TXt8pxGqG?Ru`cW zkMu@RhT{zwV^Y%p?XfW|Gpw7hSc<^spGLYeW~~ec>cjd85v4pBW0nHi#%-IL4HLkX zyAdQT>#_qPqvY&jDw2gFx>QJPAsPX_VtR8&TiZS)txh3@|9mUx_YTaRf=)BHS1zzs z2PQAN;Ct>64YK_UNjyFz`p7``3M9_BajdZ^StDPf61CGN>uu)>x_V%^osC~u0W@5w z8xgvdwr&}S7Tw_RPi7~8@UGuk8si4?MTk$mQ3RO=v@A31;_|p*o$GV<9Ni4E(J^j3 z>2SCuNfdcj%jMc8J)Af;l-Iq0BM!twy&MB7@-7#`5CQaM7|uRYry99J*rWVZ!<{h( z;RMJyeTcc&WB}o-F6(eS`6Ijs$?e?VIh*iYpqg8HJKo%YLoxsvwT^zEDkc%k(brcI z^$H_VymQ9s+RRa4i{p{so^a-ljk1|11k~NCu1Qj8godrZV{1f`0))TxG(ktYIA&nP z%#cs-Sj-P(&ET)JHM5w=90+6#^~&48XOTtg`-m4j7b(avp*SY?Px{RSpInSi=CDyN zX}i>k0@)#TPD|?CZLM2b0TpYNI@%hnDN#B8sTwiy5zA)=2w(g!W|qTaF~ymu&a97i z5i~7kSivBtlU}=yP<{vtcZ`ss>!H+(dnD`F0a`GSzE6@;ptqyNgNAL&I5r(LD5ksw z5I*U{el|v16GnJydOWIdi#U#|SnP<1@YB_IkXHo#3x_;};i=W;RR$+Y`A~ia9+Ku( zxs<_v@A>ey5A)^)Y);| ze!A}~M|VIwuZp{e_|-SGzSn9Z+SiKS4|mo!bZmlaJnJCfcutT}2!mP@lMrcN#cM-I zIWf6O{Lv^|0IWDWLe7bSQ`KVY*`&iq7~fQaQrld)oPo$#6hB31N=9ATVa!!w9RfmM z+#trp<2J~$lUTzcNqTUgf^x|p#Y3wc%%Ga_MUZn^`D|4rH@=3-6W@fv*{Ry0R`!<; zF>vo;h?lm4XlqGicPKyrTP3FSK)1(OqrNY)_D4CMaC{@j><%D&=1U^q%h@(r@NvQn zDvoWtEvayn;S7la9@$cGQtd45%f)o3VuRlJ4;GFG(haLkVQZ*S1)^ zHM2~V=gXQPoJ+aVBw)c<@&>b)r`BN#sCedBrRTJQO%a<{meTeGP%G_E8YPE+j%x~0 zgj@$K3n^o~95a&0sx_ut-~=Y;2;4#BMHFH2gelbjdH_X*dS<#GW1$dy%KNRQd zqb&z{;{P9WZvtFtmeqHbXU2dWEzfuv%na_}RhGL;nJKCDo|H=~JG;@EsV;3Py{yVA zby4wBdP<3u-c##Im6;9W0JAmFhBiasY2$$iz{UjNVd-ESgTXTxw-=1V4EA7b6J{8j z!2@9?V8$%n^ZTE3@BQxg^t5E9+P1o*Qu@B{Zs(qR_H*tQq7Dw-_PR)@y+Z~fW|ZXB zc6+zdcoV{7t{#?Y-W633{_3xiloNMXr!GV^qw|u&dql3g{jDu2~5V zgo9P0A_-!|GOz^@{%cIqXxYkYP_#D?GsMG&?U<)PSXZD$fe;VnCP!@(prhs1t+wkA z*$BnVDqWbj=`bK&U=;6Q8J8_0%O-Zr`$AofbHDk70C@-WAtg~EBC218-sfdb2>Z2{ zD%PX8COYzW_ z4qlTq))#UooB|Hyu!p2N<&m|+k)UMpC}^HOy&v7t5Ves15w#3!JI0X?(u&JV($Ul~ zqn1(jMWEmXL_jCC_nEOn#}_ai2^LBlCrQ^p1$L>qW8)hD;WK|A>dWObE2mHm4~m#vDMG$PWb-w5NdRG9M6-=}tsv%FlsGN4AWcEimgIQbw3v<}^KDtp zOk#-8AEM#@$dk;YaekLS`P|>{8+RM4rwdpYB6W`hHDv>UV{&bh*uniN?~~Hj1Mq{f zM@?HSn`zsuwR+plLRAe>OQQ^%4vba1v3UCE=RnP28p3#8h(?VMJZ!`lq+8!Aqt{19 zZq*)KyLI)!*p*w=2iHfgU%O?Y{C1&*hw?vs@go+>fAc?!as2UR7<_i0qonNW?Y%=1 zm{iP&srR@^I$Sixq;)%#DtcJxD+QOZ-84LuMt*b-R1Af$dc-r=S#c}XsNY+$klI1L zs3)_uGBdoW@P*}9hZpm0#Xv5*|jB*lzFm!1mwD|KIxFo?ZWap_Za8A_ z9#QMsL%&(f$B*}=XzN_1n4bfVrN#~_u0$Cfr&@(>KJ&Ida+YWiE>5sb=v#edVp*ce zz9xpQkew2#9qgJa34|u4@lY21A{bI5@_U$+(C}bOF=Yf$0EE^xjiE!wZ7)8kdbWru zl6kn*XTk6w+!rG}@f*<-TuN86=&C6(t^iQo#-hHI+=SyrOU`HMSul1_OjQ@kspW)W z1j&peMT6!2Z5Rv%E@7m65>E~yMUVJa}??KK)m~B08EGL;%8f zeQj=-c*@_Yd!mg$FRO@iwWQ|B2@&$Ai`40i^+f?Xv5Ro}wa6G0IyQEMzAnF7&N2oF zANkFvTzId~129ggCDyCevCqOnlXJ6!j+#YWTPNpxZgB^KVch`+gVJ) zHz3)KZobw}2Na=M=XLJFVX0kH2?~Jl=66UV^w|$xYvbglTqM`>? z`qVXL~3Nf^MJB;$1aMxDc@iAT+))FLD!1rRi!Pq_WBEilz}$x?F73tJ3vM z$*d}Q9YHsZW(U_bM}-I%H$K%0s}gNOxAdD|`!wnrbkx*)*#XqhI>tu1wSC(6rr!G? ze81CHqStTVGt0~IgVb#L1`MLzG)Vk5YSnh&5MMGx@Od!=O&BK<>rv=XnFKk1E+|mW zyUvCzJ-;gDjfE{e4xIqP_kUB*UXFjrG$jyM4j#3KP+AX_d)TQ=nBip7yt|hCJ1{9x z1a(((WflW#q>LiiNc-rT7zEfn#1jZp`l-w2ZTEXB=uB4{0?n>(P*BW(jaF;2)1+>S zl@>$r`Ht7Sj`CIf6sa|dSvK1Z%6rlZAY508K>NutIG&f2j*1qSa@xv=CSOze%;ay5 zz(aVJe{d8UhE{&=GMicC5sBjW1$*o55Y&;9>dMwIUok-V`i~Kbg&8p%Hm`4>6HwvY z%!g=_*hy7angwADht_#<&xKbf5V6mvR26=$Bq$-JJDRLWA`YXJNk4D^2tTrrDi=^G zVUlYT*K9_w%VZis?1Zj*ji0MAKF}iqR4_?IMP{v3X(2IHiEybzP=9|2c(0CKG4}yl z{i}$_W;QO~xmyTAhu}=rj>;;AijBq-j2=xAE$uE9WOs^|p~b5GHKcILQE37l*A)=a%<{W>?Xh9AE%aRSfxLrS1$ zQA3*ztoB5aMWcrKokBr4WB`Eh?=h(lNFE3hXflZeM3NE6ezohwwe2U>D+slW5-LO; zUE)=ig@7Tbw3P0oj>{m`^xW*)$ccNPLJ7!5i#nzS0GIu6r6hPB6{`MW@6(Gk&Egx$B0JSR7oO-a0{pn7dXp|+Vv zR>2IFJX^ExlI3K?1PB9NN|S4bZ!pxB(Ys{5CS<_;?EvAy zupySrmWE6XaABi;h}G0DSjYyDm^3+aYi@CIZt+%SX||%f!1QaZQz=}HMRK}W&2dzX zE)ilZ1JDjTe8`+c1?kh7-^Oh#phm#JigYH}HI_x8DCF1VF2M9hSRA$pZ| zS{9@J?wA7;2@IlWU%LNNmSH-A63M2#cSx~(m8W&FdbhFvu(CEZ(5hZ;)h-TI2PuJj zY4P>kRrf|^j*5Er!yJ@ZwY|>(V+tW7*y#mkNOF@OGkuEzyLG@x@HR972(KL0Fd#z) zQ?tqo=BVoQSBzRH1w58&^%KW53=IP66Y6k>P9t8ek3O2p|#~Xukk*+2{cNXKQ=8p|$CZacY7n5)879E742e3!Vaj1i3adj< zb_l67tp8l93@yT#nVm6ndu@g)*Ww+Mh8C-QMLBvijNYL%O4_b2VGh_mg&e1B)#)ac znjWB_iXOTn)FcRU?*^>=dwDF09{}O2KZAH0q{4Ebk&Y&Zf;Yj%#llXK6nj^;%HkmI zL~}!+e*JT^cTsfKYEXDg5kWj1tiZyp<~m-YU}UgoW+p#Ba!HNPf?xuKUwK-4!V&Um z8=oWUQRY<^YIQhD_+I980p4IGq(%%WASYKh`s9U}&!RD<6(FC{B|!Mn|0M%Tdi@rE z@q=I}6Ibb!AVk~v>G7r6k#X+Zy-Gyeyx?^qXIVNxJc9Vuk|r^*-;}?UWKl>}5)d!y zFEOSz-c7q==u%)4CW{1~0}x*LX*6c9q&=huu#@|SkdWg!@Xau;j~{lkYX zQAn7k2Up4rL4i5*ho-~s-#~&hGH7(ygq|a1dLY1do2KNx4vs<9UbDamtH~GUi0q+b zXu3x)F;sx$J>p(=*6+4N?QoG!s=A-fJ3zSk^UO?{qqfE<@dP^Vq;+Cv2LT#p7l~$C zwGcDFfL@@P7SW0~ROCz(5NQ${PvppHVUb}1V4ZqOWS!f%>BX&mfKtiOWT&ik`|SOU zKssckARyb$dsN|Tk>D)UT!#-w%Di!Wt>f_AAO7e!=s1|;UWEivvCMVc{O9mQeQ9BCiXxzSC3tza=|MlGduijnd`I5|z(-`>Bg7Nfg@^TUv$Z^hFk1BD!3o3+;Hw@P>*~gqEF8g~Z^25( ztzNAabgv-2OH}M<}}nLOb_eeOQUM_8vNv-CDdnWdU#Yc^I{*7Ma1j zHa1lASP7g+?jiT0mBct#LJNTKS>H{O$*ft}Y}R{SP%GT)TBT|Au55d1fJwxP?NaT* ztQUs#)m|H~UClai|31*RK$^l=-|9rzFNHt=dqHBfb_ld1hOAS$ z-PqrFB%LtI?8%oN04|SsZTw0eC!pMfU|N!LcL)%g-(sDTOKS-a)LvDzgHs1CCoU={ zZXetT4tZNZDZF73!};!gZ0EJ)jIWK4`CdExVn*l*vx$d#TOH70pqD1^`&Ls; z%hBrwzIfo^%=%x+?fw?IoSHG{>|u-2M*!gi--mBNyL?Wpxj&C60M|vp3lsJk!U>*b zUG2TuMPp$saB*a448ctITD14^KOEaHK={&&$G$!KB9)4UBN)4h|9b41;@?u0SIdF0 zQbU(2)vHFWRKD1aHz&;L=%~j&=^vh56gjtSF>?Wt+N~(VoIV`eI=%o1Gkfum6aFnE z!nqAFa$tGt-ixmLM3urzIaEZjG>b;1HRQQ@dq^X&f!;U;|#-7$gBq}+ET!#%ai$Y1Xzqr7V zLQ4}fv}ir67utAJzB}={HWu=(4? zC;e$&I#}3P4!21%YCxS8?I&#wBFqII`-iPoob9F&7wC%LGh{JjLJ!0?OqQ5ZjP~8| zdlm}|9}SG4$B1HxV=<4n{+o-0HlzgJ0sk!vdYx`=DyhISPb`;aTSk}fc@pfa8{AZ= zQVeWijQFn))iL%YK~j2fVb?1Q;{;w#ELLVG?#|brfBt!&OGxT*51_Ph2_85F6)c-d z`ov)i2P6t+lRRP^lTHmUmBv}oxc#Av^|{Q!|#Ms>B- zTD3?03ibcyA4am3E|(B)d-D)r$!w3%)_7oN9EP}uB!Do3ozQ6C?Kw0JQMy=dY%+u{ zqXbP!P85wSCwL_rSj>bnxVXMVoR??C7hxD-1G3a_0ECZziS@qH)H-#q)MhI*vECIP8uq2CG%YDvGp;$haudueW()F( z@*3j#!YfNF(}byeZbrUihD@0)jvdhYY=Rhu*rnlCgB{XPVd$D?PCDy37W{#N0DYNX zW*5;m4=g<^j^1i-Dp>jeEw;d#QGoDY{fr^PY|EM~AMB?^6XHnB?9{9yN<1PIEi$n} zgP;>=zvCEou5d5i^GrVW%OVn8JKe%wni< zc?uS}bgID}srZ%j##LONpXGl5;pLw^@k2V|=cW0()3;_SRCce-qK=tc;%>e2%I&4f z+$tD6KR+`)Ucp_mdRv6B^2%KOc4cy|uC^7aWBdfn9vEB2y(eD?z@0AKt@`BnpU}tT z%EaQ-ZTC9(W_m~FFJf{b*?x)4+!8F+Bi;dP?v-TzHhXoB-(1F5oE#{z`JKG9%TKS22 z_gv{9E4-}HpBPT)yvY4nUl`9zGz4%}v7OE^WzM*43{-Bm+JfM4JPg+Q#ln(cR?zIQ z)Z1+?ts@Qr$OIig!R&hP~^Nq1AnS;UEP9{Y#Gkg^?jhvNCFjQIhCzx>%f z+xwE#9Dql-iXdjj)yY{xb=DsiGq|j}Rm0ZwOf7HVjq=Z5r!h5!2IFsAjW*;B4Y&?louq)AAlNa!H9lK6R)dnf0 zvFnc$zIC}kvXel&2~b0o$77=hDF_&TO5YPYs2OQE@oD5kkNnUBNZ!os?Kz_l8~1l2 zvac$!cKPMi!HPUmn=P~W0)!v=P1RN^EUx6$4##i1aJsa=6KNb}LVyA)Cc${Z&yukWhXbeEq>Fq`OkH;+A#v_EWvbBbgDrghusXPUF%%obm4B|-wW6dq?voI%xHUV)JApFi}M6tLKgRNBB z?0&Q9{8}s^_eo1zaoTGnHO2Kr`i^qD^s?WN)2Dc+n5DwRqR{P*4Njir`))E+z?$wg z7@A78DTK}7f;{siO$%deO*X@1$4^)iK=|qp=@RweN{~yi@5o#WJW5j*A{EQ)ugLYd zr##rTDk@C$1;`U%&PUmZ`9=Si@c`3T)}WWSQVn=sG^l0`*n^%U@VsbH%Np=?&jviC z0YLcXoiMM_tQE%Mo~?LZ3^R6q9>dwid#8k(q?32bFNo;%#zVqDMrFIOz-+r4ymKSm z$ERQsV!Kv}20_)9x(yIM`?p5-m3}PsvGRfpzob2Kh^4JOvKw)!eZ*~iit%`YlBs0q z{X?ry-|>hqS8N#)^_=Dp+6Nd5+)OST5gl=Q7)*aK2D32KMlX-X?BPm%3nLBMk1`$M zFxVVA+q*Csi_cO+zjhlJBN>Ne?kaeKpeyRHb1+Tl7*-~Fpps_!48&19ia3-ZHwg}j zNXQkYY3wvx4-U3O7=P*Q6ALC6MTkLiw(TU_#^THm>Jz%QRxeiB;@Q@S*i) zt0-_{b#aphAM_{x+vq$eFOqAsiO8)Aw+@q+4$mRxN4!f?fTTti;DKLCrpE+VlwhhK z=D;qQ~%}@jtd{9jVvzwYRi1ZH!O|rcNCCA8)7lDZr z4Bt9XBs>Ht74TVHsvC&Hf>+j`tl6)0W=4@7(`QOTCmd&$LvAuGXb|DV5CgLW*vhhA9zn6Nbqzrj-MUrPZOT zE=Tdht3QW_hj|c>xt)jE#ULt2#t~GT$Q5Jl7{p!)qd-~a7;zdMk=W>>Xu@CpBWR+^ z8ngYkSCW<`lSafm(k$}dI82MlX&mRfiJQUKN-+W9#A+HIXk%P1giH74!A!WM|G6aB zcUNMW1!J#GHa0N#%k(VH7E!#HX8`p_*d4rxI!gk^^2-3>?VluuSiXdi2VlnZV^V-r zmc%qTgKE60G1(by3$PM~3uW*=@M?Qqgrao%3mGHQgeYQa9r0N%))mOFMC4K&FWf3& zXDUQiFtLEQWZq+OBWj_j(4R0FAoM>u1z}Hq&H0#m$wvD0oe$r#h`$Nxi+wK%Q=+B* zbIFUVBn(aDY+81AM@LWxAbj}6g=Ot<+<-zHw6i0+EKxEmIg9*BXh{eYD2Sa=x)v-l`d#C$ZjlNpA2n`lFbWhwK)QRFlXTo~gWp-)$9hUQ}~4*-+nh0!cm@zshgH zHdb?fn1;q#xj-xrHxpphxBw7-{?{zGY#Sj9W)`FyIU(9OH!;IE&2md}j&3W%zl2Ez z5KGpe{>0&CW1Y+Z+ygY~c7jhFz@roQsPwQOyX9;tXdn9Ev4&ca$JUADu zIE6T@mG2nuv+3d^S{oU!UU|K*PqoKPQo{WfP+zpUvv%Fz_wC#Lsiq|nZnW7V!JsGr z;(ir7B!+na;g5c;Y9qA|T%vLw0o9C-MdBd_f+S>GbAjfW45f(_-l43ii*#-@$sMz) zYJXXv3dcSk3THx*1zBG~K$8zJ4%5cvTV_k%o)bA440aaR0TEaU@|b-9ef56OY8eybW^?@`o=-mtn1r>M|^Hi@L7l4!uQV zMZS{K%H`q_06W|!TbZ6)U9L||&d;ok>XPnAu?#Gu;(uDrF;>s+^eT0_*V!_~_UW71 zRRysNAnrSv)y@MEg1-(R%z(&t`#JYaTxjgqOu5CO%49YWGb79H5Vkp<`rO(605G9`VwzW~BNstt*F z*=A`oZ_O`Fa^rnp-?R9n^Vgwae>NX1MLE?~o zs|OFUBtcXHeKJNzo}<%qUBqkwXktiPXGOL zadWzee5dun!)-YNOA-L)1+f#G1bJ?SawzAM{4sQ(55hbE!jpe!9;o2GG2|UIH+A@$ zoCLM?XT8+%DALH*V=gX+I6(=IZX&|mOcyOCC5X8@DNZk+nfsMo$Mr?z0Xd_&W5Y#4 z6X47M#q_oAEPNCjOA*Hb5dNR<7N@swR7DRu7NLyd-SMyvPfjS}I8p>g(JWILe2Unt zS(Ar&AW0ymZ+Eun(#p{lmhU^+;SA?8?Ns2&enmhz1kS%Xm2+!dK2}IG@~q?XV}S6> zzX!a*7c)+Rd z9LyjWHzC1|O-f2xvMkg_2CIVxHq-P*207-I;XIh96&c?=MUevtA0?3bj6ab5#XEQB zre1>Ns?sKuo7KVc&x_ji?XD?eJ1iy&7{Gv_9y|O&7LO$62stu|G?E+%b>Z+$sfNX1 zC6O%`AdSSB-{FT}%Vq47JlQErUU(71Jl%^2CD%LHbH4_QtUrE|N5 zlduvkv*N)8M9gUARMRNt3+tkrsOnCGNmK2F4QXO0?@bo1OaUta>9X`6yE*i)-g4mu z8A1Vjrhcjykzu1Ar6fF?F62BAB}d0b$Gmg}kf;ytPO|9c?`=R7sItTztc4L&3HyV~ zE!SL*0c7umr}&+|o&d#Vwk~1mCnqhu(eax5Y+fJ}y#SOko3dAuNkmWt!~(Ae1{2RYf7~K%I;yEBbH*S*%DoYZU7d+ydfFQ`J(15_DQ(MwR@$(zdrB z99lZTtXk^dA)d}i z?*o%R=CRMUyy(>H7xbNc@N=BYHX0Byq5(y#@^ib9&u3gbOMc>fni3;ya>`*3Gtvbnm`eiRR< z(U>C;5y{ln2MgmF=9;jjIPG!LF5bmzyT_h2oSgC&;^~8O#WeXbm)?$ncI$(!4;ifE zfpQ@diWQuCPV@l6%Tp!Fm*|UqDjKaPal&Rw2zxxB?K2VMxC$wPbVm5}{VOX=i??#V zukJ1I#d@QK{$<1LTdnFI*G z_^Y!ZCb?X6(Tqj&RTI^U=4b3?%orlm48uB&NdqGlh7pfJT(6ZQ1UiED-Q*(@-atdx z=(LAMGA3u^0dz&6i+ZX0a(@nf7eyO_1w*ykdzth#ya^C~{oCw_hRmT|eEY6v*F`3f zeckk-oCjFPeFd$kqb!gkszt(>03Q=Kj@>+($L}Ht=?>WNLMJbzlM+RGPD0p9eUU7g zOF@v(x;$p6fqk3t0K%XD3Ad&j^hX8$DedY%~ z*T${2;Z?wWbHHX_=yCrrG02vu%utSmVKDv(bjl}D9H1x}l!-{M;{y<0YaT}8d9-_^ zVnF22!+3s8UxcSmPIMOoJ*nhw|{IXpKn%uq2EL z1mPJqiy4eJ{u^0i0uvW@Hk&tH$YOx!tO1A(AbDyIbyOu8x1aK<>OP)`3v7<}w zCT4IycQ)y2bS`YbF;-GY3==O%#7Iz@idElb zeW-Qkva?PCm_alG3(;g16SSu?U37P!>s=mJ_HiMj>mDuWFgjk#D@f1{4v|LX0*U)1 zR206^3-a0zZyl&KUFrxN{;8J<9`K2&utROUmR~{;N?J_F$>8E&yzGS{SVcjLTDr5L zIx;?*R~RVjEW|5w$biGi#H~Y`%zpd6-7YarDgC-G0I_@Le55N{{itF>W8I9RAVb%s z6{(g&xEaD6LOUF6gwmopk+oil;oajSBSj?!fbegBsWSXvy#vg2p9rxG)c?}x-W^?} zas;7{1ho{dj9#XbcK@Y>gWi{nj5}8*$-gVl$S1M~zCt)JpQ?l$A!ZQ_A0kTjG85_X^wmuEtRAu0G<(}r#m-G1D*O@*LtY+f?gfF`l zi!!K+g(7WzAN;yW8>zi_Yid>LrUqc{@+$R>OEdOOU5{c76h6B(wJ_oSb%Oy9j>$|(zTH5QZ)l@(?{yxU<;fLz4Hd{?T zfH1I>b5b9)8GvK_{Jh)?ZK?$UgrE329L*#>b7fTKv1A|eNFZTgWuSdu0m#t@yS<@; z+mL$mjYn4}L9w!)cSzl#>}Kp4``d`NMg1Tos9GP!i0-?NlSC7w_~37d#Kifw*hwx$ zxVl48pddLw3b#Dv6LXVE@z%nFT(%GZ9>A??bZG!mN(+%JOX^7^s?&Uc!U0wZ z8psZuQXfH5eBoCF2!HcNG~Og(y>xA@#tvuLDr)9OAe4a+B8K~1i=+Wpoe%@v)vTEj z*RkL3bWDz6f~xUfu>xt0{U==o62d~P(JEwTPgfUmR;)s;ez77IDKyQ(_cACQd$Y18 z0lJenZ(^|^q~q|hx2xub*B=9Y$FhQl_$BRH<`VW&>5%MtA|~zHsz)kRtols4mROOU zy4qWuc5~;jsjL@9A&kqoMCAhQ0<*brUZ=ok$aNxbJu*g^@C}&{)ksHOyxF+2UBzXB zPk|i18HUfkAKI7BF1J8>;{s{Jc6fZ%22zNB069vDE>_{yc379(iY(d=6Rc@$q`Dr0 zuL=g?D58X0s;hBH7Z*X2NoxqA`W7N~%pe{pze6;kxRE^ZkrK!N!cWa-KzO=e`+Xbg z6LSP^zV)5R20e#OI0K9Wh-JA__&7lL^?#6^C4-=u=B47UnS#6`Hf#s8K+*zH z=rkyycC#~m%U0(u0kcBwY=JfAb>*EUBsp~x>sA@!1A^)wY*`UuyK6Jq<;ypb#>xfR zY=SO+o^Ed2KA`@CXA7zqBI(-e+g#>`o*HV{crUtW1@?h1_K;Fb7Rf;* zye?vtYB^C+8BPdq1~fi5QBMF7K_g&D#O46>ZEmz)gc&s}4|dx30lkfH;{b%u{0z}^ zq~cOvZMH?l?%6mWsvpe?=SNSnNLQzKwPNvQ9& zt4^wJe(HW-(|h-$NTYiwfkSQ-?;ux>w)|2m10SlE$(hq$SK2!*A{M0`iVq3@(L;=V z*xxEvCFn0ua9A+bs3!{u3mZf!+4TA?e9M&Xm!lxXA1D zlgC}R+a#&0cyu~`7sY!8DNoL3t{5+r^K6M(rluoLO&3bwU?o3rP+B!c^-}1I*8@9E z`03u%WBx|&aYO~dl>KzQ_>QC7~3g&Eu}twZi4Y8spPn{Qic!d_K67N~?wMBoZMIxu7LIT2A5y`=dr zhD>)8oK2VxUb#r&P1tr6h}W%2=@pv$Cv5K z2w(fVvc=qX@k-K}2UmJ;6k)*n9C(fab!*%5>6ns0ymuhY?TyMl3HuoStdT6+0gG)K zGYyW2a!Ks~nDokl0HDdyW%Kp_Xx3JjHC(8ptKBK7x3V;eXd_!l(g?Q>7T|+Y38O*K ztbDq8!7G$}4eR!VKG8m9VF3s68e`FyA2><+-TKRtR@giY*vnF=wbW83k4U>h- zx#5Ich(g4-KrjElY7qF1>Jr>k%)*Qhq;nnaI$Yt}PUg774RWMwjDht=bC?MlDDh}} z9#fPs-E9OWtgpPv=K>`#D2zS;VR<_J zEnrZCAp5{Ba4ExJC0_p}U|YuqL)~<9P@(!c%f6ss;XN|pbRE$tYqB8)IKOf$5KajB zmR3Q^Vv4^U-cp@%sU7@=bQ}H%dm_xY+zwb*p)@%Zn1p_E;KtLU)G>hYj_)#%NB7?b zd(r^HR`CWyoZUO!A18qPn&mu-d$Kb?tuD=LVC$eNb9Nz12S1yH+HB$;lD4z4xn?lr z^vHjc?Ajh>NW~0U1qDcBePKJ@d~N|meqdu*t+r3uOVS)wZ6h>G)|QA+c`&%0nVCg^ z@bT{fOUw(U@4JD3O?wlv$*I!TkN2f<*Q$e~gO*7gx7~tKJk3Z4*2th(!GilyC{j$Jx1F{z z7S(b92xFhL`UuSL6>fhp48;WTz-~p6i=d(;{q0?@!5`=Bp0NC3r5e?0ruG<#bD15rbtp!pGneh#UOQw%=aIgP<*d zv3!8AiY_;AfYc5*sW|;f{yld9I1-rIPk;jmfAecH-yQLYT^0u!8$|Rm=C?n*ab$?TNOJnqes7bt#Ikfqp#?PsyUAR_gW17KPROoMp*Q8(g1|N_K99g zIpvvA?&#tWQb!Ruh|bFBAHwrdWJY>0jM3Or`aaWZYNG^jJ-ZnOAng5sje3@4-L6v} zkvh^n*M>SG?2258>KVt0`c4j_T#C?50G(aw73qXj8}+p#x^_Pty zi!&)kO^Vp6{0^7@z$#pKFNRsA@1nw1`o{P|_tJ#!aT=j%E3xC%TFIsR`JaXp|++1d~ zYGO~R2cJ^D)b+f<@y7=B8-4qyb8PP&;8!Fef{kBTA1j^J}ZWa&hE4=R5*o+V)X%1$X0}! z?V}He>yC7@S9P4LZ4?8S$BANN*u|lRd_&X>@IT)NhC?+8}^c?vf_Nti%a7 zk#SXu$pkN*A#PJ^KSscNK$IxL+g_Rqp*0@tcxAknU%W(F!dojdxNKII)9rJO4OKLe z)W(itDQO=*kZ(RtunLa#-RC5Ghoj?H^1HuO!-5HzLq(3Xnvjm*B4X1RWol-A-l7x{ zqCMgoA-5r;Z0w!w^L_~(9m~Qp^UvY?ipVs7f2nJn4t;%sgQ6Y%=B&!B!UZ;D$k)RNw6ZVXA<&0vE!(k5#0p!Zdg10a0k46a0Zw-LNq zLC;&Rsvdf%Tdw#7KB52RSWw4L`)rm~8FS})hbdQFw+OLouH6wj;y?Wce*RS%smOn!YmCqiF!NJ9>$-Ffgkbl`< z<+Etv9%2F$ajaT}ij+m;8slYu(G@0Gn@pX3ClQXe`ps^fqrOq`j)i4^StX_(QKJCi z54WGihOJU@ex`ehd1n%-3JGYAJ1~;kDm$$3BXWqxkE^mJv996p>v*9ZQ#e@*F2049 zlph#*DL-o5SDJ;wKfdqRinN3P+~*Z<-k6j>m&#GqrKcj~KW7z=te9 zvmvubF;r{xN_VJX+<+2~=&{)+?lVC6;eU3@b`_hAOmSjwr*-543Br1H3Q!`~QkBVA z`3Qd&!FnF2$0I3rQM?O(M#0|%O?4uI_|D5g@>PT43(QKY!g}&Y$iV=i{qZB8#eRHX zA7{wM;fc?hq=ISw$Z$8Ura-J(fxh-D=$lHlb)zrLQs@@%czOJoTNTR>=8in!LV@xp z8{2PUn=5*`ckfnxx%A}mV?tKSjl>;(eqNmoc_Z`DtESJCWQT|O`m zwp-Z)7{k(XZEf@loZE(oH8}4Ag!g{R2^)hhwil8 z&BkC^-Atu*4%HefQ(dbBS!<% zG;Z?|+$+YMPiec@ZmBu!kLLH~a%;6)LzMim4Xv`F=xwD9&0tLFUg35zdq1i?>$#5r z;s1NvDfBG9hCt3P&);2rR`LiKa{_jBXP#zL`e!4wvl;<%HFSYqn`eq`JZ$E^@IL^; zKYnt#Rv5`+pFl0a920OE<_3xY?sxQ0lRJTrRMElrn+K1Y*nyit?n(~l#;!u^Bvu`^ zT4wm${t!lDB(41>rG!v-RN|gkI)tff$tM$VCWZD?Lde&c?5S`|LIKe!+@;;KCHJa$ zP>`-B0Ci|qLu{^ZaZsRc2PW>xdijg%4&5UhO_n3nq%Y zqqi7%nA=(RWvZsyZLs(2B~A#H!|-X!Ar(Bt3Z0isO7;+46LY6XLPTKQql`a;UmW1#Em?B`u>S&Oof4Q{)OqAe?AB1+bKO&b z%L0;B)jm*y_uA_gFBzQ%0*=+&9qMdtQ zLRboPhfyezerpy%zme-HU=6XbLK{4StG#7#7(K`a6N=hp8OcXIFJD|^w@}{BZ^&o z2vSko+q+CD%*K?4E^1Ak||I`2Z9=&@@^z}|mxj0gAk)LeWPgyglKVU6oZSdJydBC zEil|1rT`#))JBGfN3S7GP*rsG_QcHqTF;xkQ43Bp+%{N=EiiyLyyHI{*40N??4QdbQSiop)XG%S_DQ#rWwO zBv`<{LhLkOOdx@7d9TIb1ODJ*#jY0wqZt_@0ucVy6T>3wWT)LZ0P^f!fiku%BM@)c zTx;`jO}Bfj>2|RuUTaN2$i`+_1*GC~3fz*`dje|Jz^$>T!>y}l#VvsF_rK$*5p3)z zf(?QF1&)oWia2B=u0Ej`&w65)ECLyJ0k9Hw3H9o>e_=1p+&ihw*SziN zv3I!*MP{Hf)!OUBVYkFF0sR0#_{uM@)>bbLDUgh*%F!K?-fm!%G{Q=*+I8QIQy z%{WeiNZegBl{qD-J=nKnBSiGCZ}b}c`Xp4Fgb&DN1Baf=h zJF!sj#-nN^!GJH=9So#pjN`NGMi#Mk7HA{+lfsH3&J*bv8kSzS!|(X*lY`{ zJ-4tRAYB})7t)=;p#Z}2^;|IOW>ZGUz>YXsLyA%IxO|hRk(( z^Yx(jp*0dyEj_AGUi~JRD)~hnOZAi5u}H?9MPt&&e9{6!r^Vg$(%mmqxfIq@0L}2P zXZV|sS`^H2sNgudjNQ9zA~lJ^kJcS>xMUP8V;&G!0raST+!T1I@;g{l$Y&&p@PVsx z__ZQbZeL6qd<3(O29WeW(PdGq0@L((agWxBTafKbPJ)-Cikzc9Dj-1E`#n>enE`*> zuNRZ@%r0C*bxtEv8q&7Mr9a51ShXXTtB61`qV8ry!V@qn$J`#6H6+Z+FlxxI#_q-` zgG>-7BIQXlmc@g*&mSrTHj(~_O%7Io(EqEH*+G|mZ#V&_x;lEfDVOau*a(+sjr?fn zD6DaRrS?BG2&Hyd_ktm&3!o7mBA9fd;O3pCl_an(ASV$u_4m+j<3Vft;LzO9X5b)g zPA43ciThOAGQ|Qpj_`N{={Fv;Q$gsk0tkPpN`zzrn3yE<OsbjL6Aj*&5p$HFTG4oLr_W1>QEHV7;7!R>{Sc@SmX`2n@8L}mSeqL}S$ zuWujhq*U)&kh-#KcZONkle{*2?6B->fE^(G?kj@5!N>PglsKF{_%Ad$NK%AQG%4^Q z`an5(m6FJ~Q}lYuWvTc%#{xM@*`JdaZ?);|0K~;tk6V1zagX^Lt}tIA@DTL-eh494 z71s;U6?Uw+#Wf&)s$By`FI)-$q4^J3s?9k%=Vt433p1-cl^^G6x zbj6*c3kM+l%Q=>6IakH@2Ohj|xC792hB%lZgQVs%!iV$r;r!s>NX3GXt{?X$suW%FU*`*5UDk>&Yt|)dd+#po%Q+=rgnSN& zbUAD*o15^_-N&lQb_gJ3D=UOV+hza4sFCI4f7KhROyK~E7?Q>i@<|qAyBw)Hhxd`G z2?}iD`T{QG+FlaV?zzw|mxK^Z(qU!6gl8kq1k ze*k*K)f<1Dht_9d1h2c%BE zF_!|35Dwqm)=d>b`b3KD0-wNUAp$t!bV@jD%JY?I5W3N(xm(lRr+6Zgx5*QS1z4$t zCR1Epm2xHpYUGuj05TjQcB-u4Ru3@PEuO=}2@Gdjc$I}e1yY37MJ&h`2m*26UZ)dh zW+chJV^MB0L1+RnavvFhv-8*0vVHyLziw$d5b_o7%Z;>1^~j5Vr&L()MIXR zb!~LFxldu#Y!|_Sq)5$QL}fQTP>&}-iM@}o9B>RWyPn(C7i7mUWpIr%1SK>>(z?@Py+k->7SrXMx*YxkMU!LwdgX8JV;fA656{V z(9LyEcrNuORaE1q^N9-LttG6P^lUiV*wazjSAwI-Vj{OPcts&Y@wC57mv|mwL=lht<@XIfK}_WRNb7MFMJO zUFCNjiR{F2)muSRQ_+(GECRxEkX_xEXn6^wQd<(P0vI4A&Xrq3)z|s_&RR>)n9GP( zA16ljDB_4VD|H^4L6Q$pO0iJTiN59z4>Jhq*Q-=TAyS@l8?J(O0K$K99g8cMa!Rr= zAzNXn$`mI9Ae=KPjh%yi1Z_ze^jG8`YtIysY1q0=q|t-%O6zj1cdXnQQLU6rnsCZB z0to^U5m<#=!;qvj`}*UmE{MjG;Y=YnL5J0CH}{uFQShbm#|-IeN=5%0f39s2wPzWv zhQ*nqDU%RK8eN4skqcas!dyzU3Uy^MGzp46VF_|fIg)?5n1TcY%?t~Xd{Nlai@6_N z$WyH0c7Ryzc7PZ_`0#H9A?j&Id)!<tP=ttJ z#zS29yK~Xz1O91Kn3C-9f=2AEplSoX{v{INxR6r`OLSBdxv_zP78@2pkFUN_S! z`VT<(sc*q_ipJ`Rdy4zpZXGuJXBS4si){kK?EK~PD}ctg;1&P1&Ad7CP7bgf9LJ5C z4=6^Z!Dfol;HgxlKRTdukmJ`=wL376tfN}=oJ$)8paH_?{q?uFntV)KN`jdQcLp>Q zZi?a3GO~=Gw-qLy(QfO`ox4l*IVw$f2+9SHQ6flZ zVtV_{E*sA&79M!E1+8Xg9`I9ws%#suGncyn!XJE-G`eOCd*oGa#DNv7Zjy)KLfT~W z34(l_WKV0#>Bf{<)|9L%y@VZtXLOQhMRO>Mff2EzAVyLNpfyN*%v4+ep?J{#oi}Qu z*Bu!ENZfABhUqO-)kZ~2Ep3mvZX1sT8e zxBi4MThpOr0u3BdQWn=sQ!5Pu=!%Nm)10NmYrHoRoWKn1qymHw|9dQOX2XK{0Xx+a z_HQbK?xs>yg@yNmr^U}DyN&=u0(AB!BoPP#HNX?uK$oqnfD*Z;a!*nI<3M-9Yfoxd zGgHTSr8Z{l<%5UqgKc=R$#AHgN?^cxY2mEe-F&mOiHJ2;Cx$ZB(Myy3GJ}=NRrO;X zM_;R{4vJ{~>-}I+!hDyV6Cg~sYKWK&_uo&Zq5j6)h+NSv0C*n6}g-vn2pdT2FOjt0v)`{_%LrRWnc)Yfv?K@VBMC`q5TZsFLB9ZNgf6kjZ+TCo69CYX zLmaqPsYcEu{i#q46_)Ye2P;>*0tCFuLiTY^$&BFmW|GXCY5Yd?tV_;eLWTel-<0}( zV^6S&I0am_2{%B`Q*`elGGds#l*n9Jv@Nd~aN!Uj{Odm*^>Q$f`VXw6FUc~dZjnTN zqmos~@%0F!t=u$cOY@R}=ZqRsug^45O;5!J)isX!P5z838;W^ze>_n2f?}gVZP>?P zsM+;{0YwxrSBBAHQNkhgin~z@anaZSAl&-PMkS86LRz8ZPXJtL+=TFhj-p8emU?S= z!%*dOG|r(sUIEO+1hy<}QoOUmS|5JU4V8 z!iOZE2MjETdrw28bB;p!Q5Rb*#{NZknV7$8C;TKB$e!@W-rrEbVhmrG!we|^{sEJuRka^r)6p*J{I1Cwt! zqmy~<-+YxSO}M!@&a*OLAgmk^<;J29TTwW0jRV}aF_hKdw6@r=%R$^E+N-odcaZ*k zPWnwsx8m@e1r)QAJQ&heWUG71`SgTToR93ny=Mdve&a{pJUT5TEs06SYIRn#5_~am zOCPi(BpoN;*%1=ZIc_FfgwVfcLA-=6NNqNj7A$mXaY1V)^$FZIzX0%3++<|Laz`2@ zvw=PsWNuDO;J)+}@XG8SF9f@X>L>i`Lw5yK<(P{?Y}n!a@FpxxEWPN|EIDS%JPvd* zt1^e26pbE-OynoPPKePPbg|u8;1?03C;UJVfbc_qD1kAJ*%OL^XqBOOHUK8-mjf{L zX8=rsiQ;H_1joc|-K$5UYGN&&{Mw(Vlve=4=l*m_c2PV{?D!ciEv5t?pRE2=Dbc2K zhd?L*5gjU4R6xR;bPMgFVks;w9i`#K&-tEDOzQ&(pS(mv>Iw$)g@syTGcY`}FdXu4 z8H@YwOsK9`l=v!5$?IF5Fq7Y zqXb$hv#zjgoCl%eZ3_NWEDG{kpTxp64PwvuQ)E`d$bd(z;?R532i1On@Zn9@7#wc+ z8cEW;lVEKY5GE1g2{k*Jm~DswL65K1IhAy>Zqx_PU!xKhNbWOMOUjYo5AU8#MlW?b$Bb}yqDEXtg44Tiz;g^ zFhBpd4#RFDiJN2P>Q!o zY+unmC`3f*pS4s_Bis@ingWC`{|!_{YcJo=agF>c>K@E1)a(nDfChABpb(x(c@a}RU|w?f-}faC$Xa!D+|0^yi5CRR ztOudrYSwSwC7vp2mt8$pV~a#e+sfXo5vB>(t6# z%e(3}x|mNODu%B<#V}N427@nQ2g|Y#&`nzeDcIFwG+1mO3^j%pEhE8@fJ?vbb16sV z4#BZ@UI|W$R~p3K7YVV#S)ya{qgQWlhZdARKiY!xr8616=aX0G+jiicD0q`NzzyjR zkH09KVW@fh=w2G6+EvLm-neA3&S4b3xyL9r%t`lX)S&~qMkADv=IRY|0^G~12n+jl zbE3`37NUaqn7FxL4l8y8R5fMdj%tw_6@mKEs8nuub)8_%^{x5WI91k%Ms6|m#r`)EKIDvL@;t-TYO=Hp`B*P@Lp4-_I`+`R{;}e=HfiJ zx3darnR!yD{iu2J5;(Pov0d&1@4dKRCEYAKJ5!&+UT%AW^kzF7(+8~n8NnuLC*zCD zh7}2X!i2p;qEBLV&wIr{*+njl0TBMs-&j~?QHeCAy>=LaOF|2Poo_P!(nYlJR{mj#Ex z_;pcg?qXLSnn?pmE%!hGnVgw~OQYiCQ8&_%0Ab^IyyO_XDV{_!`UvG4F0O2=Z)aF`MhY|f~WG$ZiT(%!8g2nRd$fO=d21W!9TUQ=-v9Xwp{3VFf z9)k}d2J&N&5^lI6uV$pA1+E?@u^$ zk?fY;=u9C;FQQvLKh6i4iW~@y;M2|dyck42q?q2=QKknFKKxS1L2V|^7gYT>bQ_!! zciuR{1VifiQ!>F45HzDJXJCRyCR65zMH2jJoY+rZ4^{{e9^LB2507Vu)wjwHWoA~% zYLUaUu|xUIQ1G3ca|e}|{iONC&ZEW?OyCcxSv;_A6;?Q^4SyT=Wk7GoLblS{( zhloIzM_m@T;Eh1ODdb`klDQ9=o{wsm23nPcrD?*Ch`vO2e=mpQxU45{>ju48+L%Cz zJ+dalXz#63vG_7~e@YARku6G9Bk|BXh;ge#pOG)iap4zLAt}}Eqy<3WB2ifkWwt^{ z#^be1(njb-c1H!uc82?A`NmFLgvZqYj%Q?6Ne&IWWM|t-ofH7I@>MRUl24*p2#vsL zc}#&bK@yJ?hpo5(o33O(;wVaBq-t}kX_=F>ExiH=pZgKwFs0XpS(FBowm?dldf&u; zi*s$Th?~@nI0z9$rIG2<@XT@xvBWF4OEH|vD!wj7FsrrY$7C^0+pVD;($2w#?H!AL zbz_Ml?uiLe6BmJtyfGqTi_&LzLLl2~o@C$o4@LYnF` zaFD$E6Ic{88ceX=Z||m@h4KU@DK)@eGkEYU7uw5~{0=|O zegNCpXa>;t!cU8CCcb^$+)Rd~+=bKJ7qSq~qYV}scvP+qv9Kd{qTpPdoHNB`o*_W8 zV-YKSt8UWgG3!w1+lf#h(~mEJf_jc351me|A5dORMP|77tgU`*=o~Qt!oU1n3oFVy zG)cI6rAM#wB-pX**_%4r1qwLPEn*@?+87YyB0%fN4$9(OD8vyqy3o{0GFHL|mBqGl z9R;S&N)eeidvg#)9EvI2IZh#FZ(7=&Oz!W&5|AC3dAm$gxX!V&atd=gqR=Z{v+38e zMnDUF0ZLqwl?O5MQrhS3mLO&myls)S?2m*ckC!jwgf^FAf1=KT(8aOT2Q~4xcdUV+ znnmzJ2g^f>6>vfn%e}vAX8~ye6NDrkpGmf8fN-g^zpFBVY=DI}Lm`$RSPnx^DX6^9 zIum^8%R4a&5&I*A%OdwPV5-a5Bj=N!BP1lW7C{MgB!V-?5P6`=IFikOf7dt7k|jbk z-F>dtifmAz>AiU&#|i7T+;F%5z<7)T@dWLYPA+VsP5MQn^`vsJy$jW@=jOTf8kTVfj*_XKhFPJ&H$ znLM^NCgfoz@$}z{5~!h6&p+QUiSdtqZ^kxar%IPNsng}1#=4{I05L3EN`zkVvQDCu z&Buho1dcxLZlKE)XuS_2&fcvO0wxQOQ4vD?HYIBW583TA<9UIOY>+&SA-57w1*a(jEVn#U6}CmZxH7N z*_DVVNc;YVVmX@IW<29&<99iAduK;GYlFZMxj)kb_PJO>eZV#BNI;=E6$to{3p@hW zfx2|b_xKW}MVd3@8b_%rSVV+=O#!OK`N_0WvzTAI>NbkQ7JI=Z+M!ldY@mxrD%BSW zmMLUNfbipg%76o)Ornx$LbP^{7-I#wxiBpfC=gZ%?O;to!e*@xEV@o2GkNk`jh#&t zeZXT^zX%*f9GvpQVzoqs=|@zHAgWwO-n=aXA)p1Kq7Fiz#G2Xo9J>un-Ifufh6pB& zhbTuLm7y5Bn9#}c*&LsPUHf5>S5&@mf|_EkYp~}4Vfw#Az*xKfdMdZth0qocpuW`W zH51RpcnUZWa@e){-b)X%e+z^?{dK)(SoFPG2E!6kjQh zrj@?)sjyo%7?+3=sU@{;kRAm`ku&NDIU!Wd6e}+T(l(z^cBJ#Vtf)SmS8GD*#s@voKn!0RwT@HV06nSm3jAEkO2L3|yCP4W57m7MI1-XzY zQqYR2VBQlb>sA#(DAChM0b)`oB~*~|ZLsaToe&aCD|3)2-uZVfnMXw4j8vIc0z#k` zT;~KrIuDM}P5f6|UmYH~5wdx-@2MO0;jc};2aETc0O3#m1(Va8!PX3beKNVYWG6B~ zq9<+cE^~aU{uA|Km#NDhU0r&L-13MUt1lB2~~6TTLP)6bodojQEYr%pDi$U0M&n3nYa zaPL-}ITwanJd`*_d{%j{Jh+pXy*%X=dsk2JADvv}elw5v3UInjWYpNa38YI_YN z0SNal@I)Ct&=8Dx6hqok$>dmwn=>ZZ^_b&(Fv;Z;L`j>Uo(;Fm0xUDIC)t|`-7R(p z>xM!GblD!g-zJZDuuw(`H&9uijb=ypr4>L?l(hD8?cJfwQ1u%5lEwu^iA3*3)xD^= zT=~TK2&yp_0mQKj(TJB6mn3?ImwXKn{@qoI;Jn$C_%B-{hu`KyK zZI@<+hYahQ&yC}RzGBtg(l=H@D;-OVLRE9iqB9R%W zJ9=W*?#L21Xl)a?22;>-<3wl@UF{rp(NOCcAUyi+tu=bbDWcPveI$@bJ!(yE6OPJ= zMYM!yjR9U92xZ=nm(AY^iWxRsf1aW=lhtT~6+B85%DxTpaMpzAeZNf9XP`R2sBrgt z6yY_ON<{PVU(3V~-OtDAkgP zi^+ZSDVQ0vOGg6;kH6~_fOWm@nR8IojAo%wNO$;IPJ)EulKA4W!)Pcm>!7=_z;j#+ zPdVt7Fh}$U7r)=0TfDoFMe_L5`K971(~-i>Y12N+uJFm{KKj#=BE9h47Qrizq~&!4 zyZ%1AW&VvyZQVbgfJ#QI19_uC`c*7H5e(>MDJXX1V1uY)D8IlFOk>t?uTFsQ^MjSK z*VhSY3FNMH#k{n)Pd)eC{M_u_;obG;e(&1{$N&51o@1~6-G9?JUZ*xWsT=-|FE8oD zQRJ_3dt3Ka$Pcp6*vE!ZgF|!8JzgrVwZq)o+$Urg3osKkHLTO#RpzTMu2(6!_cvOH zD)?NZftryWUmG8}UYS@p(m`>Nb@;6&*=v4&c7ADs@^`7LD)DsQ)zxvz87b$vltIwo5K3cQ(0HN}cVm-QPv$9%WTA3MMG^RPVwEXJuBArNW?X-6o zz{u1GmX@cMre{`pOiITZX01#Qyd%3 zmihouK*oU4>Zt5h7hs*ueT=18#^``Fh+8xD$%)mO(b^)Hoc6sn9h5FY_Llx+sk^w7DjYv>!xA?TDiJ8r zI1nf$fgDnCa;Hs&aF*LuuCdj86m~P3QJ!&D0O3169v0Hi&EHFV9g0mtsr=dyyqV|@ z++MdIUmBAmU~77MB|fTMr2+9BtE)>>@!9C8Jp%!jSC*F3Q>ymyU}QXt>;h2*aq59F5Rui566(hRMUNVX<3)7lhMQ>Lm5YlCX^(sXv}9bKet-1 zre{8v>7}V9fbcorIzK-%RrKnUnpvElS}MQrd95tZPc1F3roIG~OBMCciqo)H1WAbN zeCqd#FJQ5Ld+K(A)fI`7u-cjWMC|a2Pguj;o>&p#NpHf;UY?kLISq8x2b#RQIysN= zV|pHxx)@tr^)VObR;R9~XFg=0zN6|0ApFel+Wud4$gE7Wb@NNNmg{M!ulnHeO?~24 z>d@ix%1WKj-q!$j5>6M9B=I0h?(#o%e z{g{}WPM`XSA6S{G-(6X(47eTi3G8KZWoF_fup+gtUiEHYS()Qj`iW(^M{cBDt%liX zCS*zmT&iAk*saV=%}>lNNM_(nrZEqn=Y6U2h0PDX zFLqtK>aBUY125itUw{9hAIZ@X2NqZkb4m{#S`+mpn+9)UPopEgFj-?(rzRFfg|p6l z8?`R7<5F)vrAM;;T>0frg|nw-+Wz!S)w>OJeRl4irW4jaO8%bkIJ65d)7w!WbWV4L zXN^XE)Vb-o+1Z(unZ+p>anZ)%p;gR**#uR^v95Ttz_E(Q-XK0s&jYTRd_hOWbBEyU zY<;ypQ;;dP_><37KJSOL96@QcXy5?Q!!eh!7CE=KXI4zk`j&$~TQxcBonz<1EFy>L z4>B8L!Ke3!7pPGO(wWqT<2p!f)$2ouCPPSG)pw7NT^%1q{E5siNN#W(%ci-n;0fI& zPA>}>>w~E0LIg#PCKj--zA`*LT$$lIqK=JLSzF%TX&=Nn?5^|4`w!9ds~DjWvuIo! zAG-#}R$Gwh2mc2w0^7}@)x)L&c^6kJHv1N;@a{Gh#}g~Jez7{NG_jD9(Ysl(C%)F* zbw%XViMn`3Ru_R8xgGQx2A?xwlS-;13zI(4{{G38wZ+vrWqb$R1~l=lmND0&mH{R7 zkm+K*YHzb-ZLR=>mtV3&(baJ2@StbQIcumhf$nval&;nOg(>DRwK_SxMZGsBLi&jj z15mTR#kJ9HRlcoaaPC+eaS8o4cuDyQWZ)btWBLQyPV&;~nCd)lA z*HRaLj(c{2zfa35_W=-o?AMTaa7UH;;i&4`udZ!*ra!^5m4(VgN2<4_JDqd)^gp)< zeXG<--|Ux+_&oTr(tLpY_B{W-_|*9(2C~3@a}$>O<`a z*dn4Muf?uXOR)j@T`@Wqi>pieCVoHPY&|&GI<19&727Ny?4QoUw;S?hJH;Ft|%7u&+;~5lp}49`CL4>*AV&V>=uGz_jWCnx62tu zwkP(Uo$A^ue;l{Uw&4`G*mi~`E)`n^5azz?gdLtM?bp)j`!!eW*V0+`YtHuz=u9mw zEG#W%^$b`0SKeG{?tqJrrzQs{S{rL~%Ly?DF>tYDjsPU0G6~TuzP2v220jmOQGCTj z!#4n7YeYS3dEK8m0J7c!@WOZJPcx<)2MusiW$~$WjxFPvh)`GK{{DC1h*_N+ugF3H zQOA~a3w32~5g>fUH`Zr}XJ4Y076s_Jnxwgp#qHp*Gs&@kXoVVjzDb=eOiW?1nyF0B zETgPY<+_4gy0kJ~Sz~|s+2S~kLpO|}u0A2?b$3{2%nJkzR#1)$E}|eOE5mF_jQD)G zUIlFmZL}f>5e6>r)HnsXsga8eW{+RN6MwkZ8Lzy;EW!(C3r8F1IY9WLe|UJ%tC{nR z@ygW1%Jkgg#C+&Y1#gYMmK{6u~3VKg zZ;yE(v@RQJ6R;^}$~*vknu1qk($1tI7y;AfjQJ~N9_O(77^=sY;kdYirgOD|8;DAM zMl~Zd*B&C+>Dh3Ck?PSV72357WwJFD@Pz z3mdE;(526{2o?5K_)ixhd!|1Dkz^*!glCY=0K(6I?5zyfUvG3CnkZEttRf<$znAzM zspQkJsJW$yvn}dr*8>o4eu*0OPjl53W2OtYfiw{rutO2d099lzUv^J*xJA~F0l;3g?){UEpK_jDr*mJ`$cf7)Q zb^8I)YXIRlK1qGCz=X{`-`wW*oMuBRJn=UB-2Q&4f`{a0bN&kv4ft`)Cuk%`E5-naMgX$d>gQpY?N+d(RU%*LkBm&D?m ztp@RoCR^ZeB-%RtS@mV;ybA0_dUa%%TtBv5KptrNXS3Uz?d2Jx<@(6iYfBy4z;|T6 zBn$&!1VH%WKZ%I8*#;LdEItXg`E*`-qW;r91Y^36Y22W5A4gk(Ti09EgH{a zu=Q7Q5mq=>I#HbGVIhAIRq!tDb8NsYr?H$w^m%4r=Xzl(w9x5@5aUd2R37L|B8IwA zB78M^GYB5~qT%06t;9aA(nokN;!LDD@F2RDYZ1)M0}x*O=Q=TzF_gFxsL$}Va5586 zOOb zaGbF>pAJqNh%t~2SIkZ+dV8%ytPClG=dHA%90#6gD3dXRZnmZEL37iM#^Bb-&?pyR ziH1$>Zp^gqlQ%jtqLMMDIfG9~zSNn8w2N4Dus&i1mC=HYbdGHzKbzB0H>*wyiDpgI z5SOkHFnqi%zs*m5nPPPbLYJB|657oyEgOlA4OhiYoTCIrqOXloX_O7>>)WO}jkK>B zrhLXE9s0Q$pn)H~Aiuku>1$_-OD)8R0tmJa$CkR@Zf@qUg)U&67#%Ss?m%qi0R0CE3RFzbT#%HzqU1n{Dq;0)+qRx3%ltJqfcL|rVK7)%1uGf!+tJr86lM8-baP|P%oigL@0pj}O6%r`W zOd_ur7U>xH6|UhPRdIcQ@O^*0M-Le@k8;3_ok3~@W;~si1uriSh)EI4E=BkjyHJq? zI#E-kK)8XZz{=x_ox&tE3Bb=*c<{$cY(+c`;q?qadBjOb$eouNOV54o;@uo zvfVHDFqnyah-m-?$2wq8e{74Le8O(4FW>Uj1bds(lyZ!`wkAy^#+h{m$d@igMdkqr zU+{fTEBhSzo`W;9tGmiM&C)LIxY(IRfy$yYi~(Ehr3)^Wv%ApjG~Q)ire^FT&bH(Z zOCe)|u<+6Nxmb33gPf{##R?Wm3+Yj5Z+&22o3&}bIixb6&5dE^64wC`KK>K&k7xPU zydC!hfx!w!;hBZIG6q`!T!N3p?yOi8(dY-Mwl5^e_EYXP)1N%fFDY5dRX~?kR2{!D z3``L=VVdshZbM;`IXGZ;78tkc*y8thxp;jGJ7pb`7qelfWM2EgXK=q)={=IRl0WE` zSY=c*JH6t>qTA-5?7*AFhp{yIIZB&hqg%}@OxX1~puRk1(7^v>L?G=9b*eV%%iQ!` zAFQ}GA*;7dFSO?l#L&Lyw@dj_B3xPpwAhW=yYJ_w7=`Veq^|>n_x{jZzyOx732r05 ze#ox}On%!r^B8JU1;V|B5sozJ!Zib!7DsA8u!6Gw0`gcR-{3gS0pj9HilSzjAws}2 zfYA2^Z7XCJkj+sT!53U;AP0j09$EW*f1epoQ-mcW%x&y6wa?s}dx)qkgf(>0xhnv4 z(k>iX>*)_p*Z@apqf1Y*0|4Rc_fH>p=*TvJi#@g>B5>FSOl>{4LC3MzX@8mxSUTed zyzO*o0ECa60S3h7n*O0ow%fWz_~OH z7>|UaG(A15xK#`N7a)B5ugk^+>MOJ`2&YQRds8}Pf53TY^+GHot`G%|Un#zt&*W7V z(dAcsdXx@fuS3v6AXdSE89p)(A)gVe9SP~;;{&;-{D48lLz$H@DYLanXSXr*;fM;9 zFrHiPFAj!CXr6GK2N9w|wM~<55$wnZ6QP&QOCZ6mMIvG2O@OfTnN4mFzsQL<4o-H5 zxubQ^Q{uZ92NdNlDL^szfb=)2J^&77jB37E08~{66XW4N0p~U)fbeI2R>O4;(DDuU z_%sX%;LJ{f1yW@I1VJ4HGAO+o4s1bk4A8={}PP0FpSC$$cHbV750@bL3%IU-4E3HaE? zLTXZiwti4oR7G%Jpst(f_R8<`|UQBT%H1a0JU;qu62Qw0aCLC!{|aXEAzU! zxVj-&?0zx-d7A19P})=R*0(PMqn&g^6@c*L->)3=q8G=Zh!p8WNEAkkBy|8YGj?>= zB`6eKDQQKUYjT3&a6B$%^0xLgsI+vE6$xpv#zX;4*_wc892(T^c*QrfE7K;Lw&I9R&0b zvOHtK^7MsUylIVTP7TG5M0@nEJRSE&xC|sRIt~!N=>I-)u#HKFb6wHFHdU|KF&SFo zY$W<5dWc@Z)}u`q7Y>3@8i^>$xp_iUBF~obPUo%=;C!8$cT9UXeMHBBsoWf~5)E+P zhpOCQ1v0cgJF!5ju7=|OG8OqUWk-Xt!{{Hi4|g^kr6eV_7+Y;4JORRm{`)2+38XM| zT`ue{NvIrUY5**TIs7dgNXzoXsS)<8v`b!lV_WLA9X0xxvpsT7DSS?oMtYT2uFbOD z_WcSB-Dr>xeXzC9f|(T7ai?;Y&Zf5ND{QF^r1kTR!T4`+J)`)Ea_hssvkN8CJ5-~p zgzhr=BOfwCA@&^5H`u{7mgX*3j`QV=NU46Q-4CzBYn~~qGoVmaxp&}#A@f&$+kgfC zKX2~>U1^rp_Z8-0%H{^*cm?p-@i*N-tEwcG?v?7L?&_(lE2*U}sicu^m8uay;4`#3{AYS9VTENgF{vfn1OL%@$zyKOcpjICI$=xECS9l37Cg5U>r<{2~3PV zp~>&R_c`bLzN;%$Rjci>>C*ka^PR^&`|S7Gdrrx?d}E!pkp&{kFwM38=(uS9B>{ zu-@7}7#hN=Q((OgpORZCKQ~;~4w`^qtog^Si71P|#S|3Q9w_-h0o3FZOTZQ=1)&5; z;1~gUf!Zr`-TR@IP2IBU^=v6WABGokAal0)f>O9J_&FiLx0j6O6;z)6#9HNYA<_Q8x`N zKS`Sr<<6eZ)fa?&1~Rjdw%o{2E~iGAf>;3I2j*lDLS{rLmP_!}aH!%HU0O$BlC3te zso)Ya(?5xy$iWhYGDxWSB-jleF6J{;&MN3H}v*utWpre*m)nzm)+khNgTU_Pvz4VJT9#V$#X z6OXv3D^7Dj{JYri5)4K8T@kJ9Jd4W98y~oZ@fwp~XaW#!zbuxCZ{h)0I`8>ySCO!! zrAS19KU?x2sQ`c)8;q!hm=S)h&^p8f+bbiUdR{;p_0xn~lUCbF0H2!lC64Uf!;Ud> zz+N~K`dag6X~QLJDi94sjO{3&f6t@@nE|0B$f}P(%i^G-#OZWNG(MEr{1?AheqQ{Q zIaLT_+>Mms=+^hynSc&r1Nha<^d7O%$HLjX^adz-bWih<9ba4R9qMw}_&I4VOwfqBvFh5+H)|Et`Bc;a7dWSIYd2>W8N@eW2#??l1@o1b^r%tYzzgqS2|3m|EesmxF-&?H=<0e4(OMOYG{SXVSOleais zeX9ViPGY)zb<0A>Q-VAl2pJ^q10fyX5anj9)C_Fam5sLu5dPqjn*)Z(8z1Ns0YR8e z9^P+9)1-!-Si;7!G z&9T3vmZ}qnD^cV+vHRQmEhXCCBs)o~th0JgNxD3T_b34sLsq zHv2$$pdZ!~n?gtWX=s(cj2bOs6UB*{4D?*L+{lOMfu$(Q77gj95gB0U2O#|AH+7)2 zoONk{T#GaMj-b)%4DENe+ZNfUHWu1R`qqwxikfDx__LU0Tyye))tBkBJMA@s26Q%k z$2E#i{hr@H2rCPgAb$0#(lT`fFnC8%^;>uEwyDyE=mjDlwM#lJrt?{JA{Sl6lq`}J z==@7JflT*e zPMb!%2mr}8+QtSHriW>;XkJ)AnAf*H%j#fAk0p-hfIcdW<=h+kw8P4k5mse;-|yU!GK3O0D{>$Ruz~+c#!%Q0;T?lMDCqz~k~y4Z=K(~*Ya=y8UYlaz zyD9m&k8CZrrCZCgfw76mhw3n$lA$4qdA_p(khWbN0UJ}}f;=XRlz_t$Bq;~^Q@t`Z zi+GiF#jrOD=<1?rv~GatJmskcnaoJa*8t&1KSj~^rqv0#ESq8Eq-M=7TDpCSq$nyL zoh45Rqi_56OIy567D)cyU9@)jn{r(Gn9v=+|ly@;U~_hqghf9$-S$U zXrC2%uX_o}5v$$MW${S++$NB__-xJwygfESkk^WBCkhU(g|y&XphO&KXo#Fe*^Er1 zB&dPiGi>ZZR%uzE2JG$)#M3G6ro&z-hX z`NE(`axzTmmY0lxTx}<8*;=~H3}=^0iga;auaQqJtXX8Z#Vv z1lh~fJ;fiacmF)OtxWE8H@)>9$RBq~WULLp%#)@WF@q3jL*L9rooh}gh1aunfbf~G zNKNIQ9$8;NQe~ZPbxbC(_4}N;bu5;Qjy z+2>L6f%k^4d_0Q+_nJOFm|!MUG1spH3Sy_voT&u2QM6O8vWG9gQWp2l zB%t+R)T=x^3=fv}84N03fU!wjLqKJ{;SN z;>b9;$9`yf;L=>%B?t8+{qAnNBXi9r`L+SVSAwFL(ynx97gx~y#E|41f6e$=|aJq!Xd<^aeD)82sUt9X6-mi_O+~zW6PL7ylKDJXA zSzglcFjI?IdLvp=Bhg8lz#wT=*2)4vgaxD_f*nsU9+>pmXao)J-alu+?bh~ygfIi zhiLIz>YVn^SImIke!x;TaC)xNtZ{Q`>ZN5Hz67`>N&}O_mHAuC;U#3Q_O7*yz~m73 zymL5vzVhBz)MPvE1B!Yd_iEH%0fhSB)Qt0a_*i3oKMk3g`*b=vH9a%i_Z!~KE%bfU z*gN1kFbsGoY?MrO94ZQ9%ay_toB@0Z$_7fM`bdxq7+ONmfK~wEU9FJ)UM5QR2J|KY zU}WISmeX57+-Gk$xUyqtt0S;5IcYlw{thhOsV`Y{!t~u?`s9ApXzR%Q28?)M`i+A=~sd|F~!zjk9^I4mqxA3}%BVo=YW0bMQ-1Rs|O7*VzQYfrTQMQ=X5(>w83;E(C zAB-@^;wVezO5mLOtUv^=jbjE$XYshN38w)FKl}HXf=+e}-RW~+fyp!}C7nRX zw^H0gL3oR|D1;V(T3}fd(??FYTCa0Q@krag^uYS&4)l@MFOejDvv21hPi)V^A~=26 zgb|uAz;^5c2p|6QpqTG_&8(Olth|(hKJJP*=HI^|lqF zVf$VFWi@uN3&?;?JYWhK~?u)jrk}RZJ-5SZp^yj7UM{VS?o>gl+yuu%~k@&~e z@W*Af*Q-m_`0Co$RTV3_wP07nQ!ed~eAd1H7~Ss7d%usa2Jqm_7Mb<2fy*2%c)vnc2*u8#bi_yV{z&$-XPPsN zt=vvrn(z-NXPRnUpW)db+FQx<(u~XO+ol6WZYlSc0$F=_~*#IsuM%_W*?Hy(gKtVq~Xr zQ@0{ifOc{6OcCK>>t`X`E;l=efX zsGAZqbh%`z+P`rhC|_l;R19FNgRzn=wgpFEP0vm*#O*i%S}V9l=C`S7EFKGkT#n$3 z0a($0g3UDy$zc$X*;M<4c}`0(jbXOY%nt2=YZ!9$?tfaZbugmXz2E&JopdF#0bR3t z$eA?)-V`2B#2IXKl*0Y^Jpxs;?tW{-az}uJClN!P8r}3`hlsc|>}qw`U)*}Ez3--_ z`I`^HH)67(bG5w}_rXksqN2eB&-*z0xrR3qya}w~BOPvlaQ!C|LUw_-uRZ7^`S)_M zqz?2$shGJ!El9Z&fp`|sg=?OEO3C|cbDX1!#XTad>;e$lm(t$s@`z>Ln&XHP4#x2y zweR@s)~cAtJfaC(boPAupYxPx^G%P>`vCK6Z>(%@9^7A%!_D@VC)>M+yD45MghgJ| zI{nb1-r&!OS$qIOy9U~Hvx$-GRRNDxae+>Ufgc@WF+)a>R%Lu@Z*x|OYzp(sXH@>{ zouvOW{pml6r?)>qK%FjZW39`H^;0u0(S(0eC0$IRe&MJ*LaeJ1BG%T_~;)r(Vl?d4( zfbbQy8XC_)0km8_3M2zJ$@Y#c7JNjMl`(`MQ;CBydY!DXcD6(Wqqwz;*q|yAr4Pg} z{mDeTebA)ZT*r57M6w)7Y&}O2oO7M`3Zyvz(^S$p|7uy+kNqokk{zfQV{~5PH;hPr zSqMa{V|ZZGT#j6ad(0g&IiN_2N8ed~w6`I`_@U3{@B>$8-LI1`*8+I8;5+^URkM}% zS0}N$${0-K0g{=&29g1hjI-DNZ-4= z`FH*xyW2xt-(JKKK={`ww@^tQEpsRXXF%DkJ`@>hCnzDui=;(*bKKu29loLnG}&Jo zEeoC;WU=1nQ%Iu#q5fs$A}mue2Y>xEB56Gen;e-V(rEqdOQZJb+m%Ms$7N|0Abie# zSsQqqNZNlt*nskmoU|Wez>k$i>!*`O>$jd*8U+ad^pzx%)=w*v7S50zATKEz56{Wc zXnnaTjpocS9XVIlUSC6_g=)E&=CY|2B(g!BW%{do5YN3$^lUZ@`VXM_qtq@%q3CDJi*lysb01Aih-wm+`+$l(Rr0TBN5&*wUBl6_=g z$W`)_)!B*D(2j|dXvf6crycg`6VeWV@C|>8VByF{151v&aG8L-L$srCW+Zc-K+B(q zc1)a(c1+w-WxSWZ;;GeHrPn%@I$JnIPfa@}inQaH6Z<5O^HU8FzW%4%d#g!`Wlk`) zC=v83DFd`4b;iF}>7cBoU@nBby$vnpDU=j|@H?Ng`gRl*rgoy9GE>r1>{n7z?3Yv& z69?^=3dTUI-T|gyQ0vbWju9vU!r3RXF@j*s(TkzHV>SNNV{SXfAry+ONJZG*U?G-9 zJUy2ELC;hmCpMi~THDn#mC=dMKvx-?^mwfJcqKg+$YbmIZGiB(e|~R!e)|oTI~Y}o z+4OdDvZ2|iM98S>m};jq=b+4~PC;&;_nPeC_Nvv5anrol-9fvOMbK=nXez$)U|6M_ zqM1FMS*d06b7eBL&=_%y5Md}7ac8Vf|$D}B_c z8uv(CPeO|eZP>98?)pxitGey8%%rh%xBnTPy*?t-OL#F{dp^Ug7mTVr1PI^s_a}7I z!9HPr_K~Hs*yYxFH_JPpy4#>eafTJH*dbBI6mN~ZU-9bid5^I@U9PPMuaq~6j4?Ly zr%~TaPfrcvfX<1FB|D~7LV{vkM5YW5sf%D4Kv?^or#8wJwsnZhf(>!lWl|K}2I&ps z^k^kLGR))=mWbG@@Ih(_h8;t`i{qW}H(O}7+ch`!=4*e<0s+DwQbp~g|G8eG-X(=D z-{0OkV5yK@1d3{H(trR{Cc4VrtrB2XYOI{b0#x1X&Z!w8(fym5={Pkb#H4?-U|3HL zM~`bLyG?2})~^*n_{sm38OqKL7YOUP)UPS6CVJL!+(IVG3#lHrl8N4xsNQqmH6tb# zmQwAz7A6=hP-!96<5uDg=i1g1ApF>0VQ*J;C8_W5-dx4<0)(pg+K;q+48om+X(oWE z!)#J156pyi>e@4gd+JnuDt>k_^LjD%BETxX0|=k{3i-9olzP`!7vGi8I6hQD1i4fC zH#H0>Gz}P0oK5J}kt%N*k*r_So?auK^)&T!Da)zFz4*_GowYpxAeqS?EN_2++{KA- z>1S;aAhf?ku`;O%m}X)Y$fYJ%`NE9!GFT845@($aIVCY#H^d6E&Uhe6bT=V#FWD)z;%ffN+cY zAo;>;W0>$m544sxg{r!PxRu^y3rks{R|he!FGmnBn8Rn>x+ZTRuD%z?MzVp{TGzuH zaI9}CUk?_1;9O7NMFa~EBEqEi5moZ{r)DKc+~)ED2*VW>UrI+&IfY#y4|0}^dlJM> zcks>l#kh@w4xF+dkKwNLfwI=7ZLY#;ieE(JQo|Jxg3SwrN(fQtIyRgmokcMDq^82e zV$(tS9R@y;`V8QwiZdJ6qA53f(!_dO2~s*RUMMPjs)y{A1_l|gpr{C!=^Xiw>6A z(}+ZHg(T7}GqR_rT1g*t1_-rZIeCcUTV%3n6wXa|mM7nKI!k>jaAFE+$li#_`fam z>|cmBO79yRjY4pdGCSJ^#Z}wN=A(EVLK&8!pgIIs#%gXOIeF11z6IO~v}RqGgVOZn z6F)oorGpvuo9G4QKjgHxHdaRf!t!?vRtK*RjzCN}zGh^iPIB%1Ky~;M5ic7mZIj)| zE|1{;+<4Hv=#QMZ6KSIk7x9{g4hL(4BeAdC(Kw!6%}70T0~fP8xj1?iS3y6_Jb4kt zw*@FELj@KGFG7wLB%28w2sq+WmLK%Q;|mbZeN(aTK7SkhOknZB^5tF{ycFp$)X%N$^ZZaT9GZgr(tp7RP0X8+;6=XaTUY@QF&{9P`Brp zkwO;=SSE2Aaw3#Vu{qNFmGUaYaRB~eA2tbq@IxQgxv;Uq7Cg3_qRT#??HGNi2hcog zDl0vwN+21Bwp_U|1|D3`u3owHd^R`Dqp_TGc(X}he@cKkx@85{=;$9cbq&CnUYU!Zoj@wIzU-yYazwEb`u~x_+Ck1^r+|_84_uQcWhBmYV16?SW7A0 zk@!^|D5c(qF~@=*>^bS5*mMG=1aC^{WV7T(Qf7WjU9Eh!1dX!`^9z%iRpF%Mj-{F> z+$h@g_S*!T%jFCR`P+I|;59u)Va@|sbka3{OL|YT#Z8q#0&aSiwoJj^16&K~H<5v7 zt3%J$hMwhy%sfCi_|-70nz;o*gu*lfKuK>%%;G_tUe|~wN~H!s2u1iy@{@&pM|S(d zu`~iD9ZE4EX76UEs(}cQwPAFZ!Zrq{H5L=i&3P~tohS|b6GwQL(B z=5R9@#KRWB}9c9g> zL-0x*nd|w);d^kB+DCZYQ|iCH!-K9Pkf%dZgLO+X&Ilpkb>|VCg$>=1sW)t-uc|P| z;`Abxo0}uLD`0d8G%YKvzd71eD}|jM$9Wj zt77HwCe*U~%R z%;Ixt`AQt%4|Jw9N4Cpuf4y!6t|-+_;#OPfFiBG{F5D)qLw8@M|BFjB<iX3}7Gq+FKvijK1tQW~LAJhnL95x_JN54#C5d+ntLW z8M=fWnin0Gb`?DPV&I?uZ<2D2w6y8a>*RcPBmTXydn5eV-DvDiv#KtmhG%uEZl*_? z*UhO{szCJ2C%*Z!-uDNZ)Mx(Dr{9>LZ7eNJ&dn|_^6CbyBqaG>ul--^YIXL^mC1$7 z+GP>i@q;s;_{e8%{V=VlnYjYURf&C9#CZqcL37y{c?XBd*^yt^;vAEX%5!hd-CCZ~ zB`%5wtMTOU((PNNO}^+ie$Y3y7nvqXQiWv$hfWPI;ByD zEnaHS(KIMAG25J&YjQgx-9EFy?TT6U)|uBo{<}6Ou)h;0h7|T-nHvvGO$f!W_=h;c zJVCG41uyiwe)xv{Y_xaUo$$;aynMLFhny!d;v01lXY zxBidvLH3itk+Edfj;mQf4-@4;0B;jF+UH#CUI$SjyUmAfZ@szJ)#7KnFHyi=k6^iL zT_J*g)B|Q{um-RfEbNS6cQoTu_=RG>yRYLfwBb7vhb{=5ypG6h9~ZIP9#F7=;S_w< z;X43Qn%|jEeACCj`p*g&UzB}fnmx|nW=g)-X>r7CuHMaNyR)|0_6O^s0k>5&gr=^U z5wWa)D)-lR4n#95YOS4^SE~{zZ1iU}`r0S`oJQ|y@{UizCTg=6)&Aze-}+n)Uis=j zwig$-ZK;}Td0Xr_e>+V->C7*EjN@ESiHubW zADNV7Id*|Hz_eX*tg_po6(cEj;BQ0i?BMt*hvH`OpkG|irZ}vA=ELEyP^-(3KOM-z z6FdKf-%bb$4~!xden;9+cqEEYdF#xN4tzKt$p}ZG4U;PTGQv^#4K*qJGD1`M?ewMa zAW)jZ6G%=4n1y8qDw)48P@w#w(WuIeGD)u_;t*I86#K6U8-Dr2uLXJrb4&2HzZdIE z_4#G{)4*weIUr-(5&I*;&VCq#>@Q$r{|b)w2jH-O4NUfzfx!L>YuDeRwD!yZW`99; z?cV?a{T(wp70IxkZ*u-1q3D>pq$^%kA}wb=@zJlH-_*)KviKF?Y3Ze81W0Tv!?+G| zU&*qu@tW@2>P2MIl^Z#0zfpO+{G5DQ&>BAzq9tt06h1;bBSu^1C$wcfgz(HKzU^ZV zzDu+J;NaIYdwb1|7Nx1`W-myhkz)8__5utdJm&|txrvSao#}Rm$NpPmgx{5NFZmph z(pu|Tb#&x%EvqR(3)j_kLp;;W`jBMfHUGj0$6x&$%&t$9jLZ8@K;)8j0x~*YtqI1w zN-*YY^30&!=$^1ASJmQF+f5bj%@!KO4D_QYg!U2_5!qR?RFPiR1+5oEUtVO>4=%p& zV%^V`sJ8z#X@5?(?Vs5#`zM#eUU0y?DE7O%ZZ8Wmn)mNbmPy;c@z$CD{*#tlg%%=$ zHfkNAz?vYZZSEFYuwrX4S)C);N!UACtyHqeWlti54}X1`TgPfhQT|? zCz4?bj~;0HM+X3L)P=L@GoSdzcYoUdY54M`KQhN{lDW;o3BVermc}Ga=|QGM2bG5m zyukod9p~~9cr%!z&0JQmUd!%ayBVp>anCN3M@p%z^sDN>lxamjYyMN&oAh(kf09B) zzsAB#OYWuzmkJN6dT_b$pr!{`3J*s0;A-K)m>yj72cF(Z56Hz}6IALjxa|-9#;iRJ zGqbc|_8`p7a*x@AFg@jNvfp8L)5;Wbd$D29!UTD?IJ-Dy@Ti74hG({pYM5rd-dwm- z=gUTbn*I#))1P5d`ZG*Ne};+Z&oBr58HU!MVMP5I2GXAa68aNkgTcW5Cac63zF8O) z!jQi#3|sYa?VG~52qJm&eB`^C?tGDp*`g#ADRJcrpWam|7Bbp3>q`RL8~|9-0SLmQ z@c#3@#;|j4XmxXUW9YU^m9JL9A4Y}z$U6bC7)ThEWm<*mYlN@aCoseWhS)yl;1?5)}6_%k28Y@VR8H}5@nLn`#UZrpfj)&6=lyc&7) z;ohTamFS=1e|c$!bN{Z@iQjR1FMYRnt)m}=`QE68CX0C!P1Sd- zXQ}|~?mB58kk^)31EJzPgFw_udXD;){5HWumb-cX2wqG4{Nn(Zvb= z{3QLaV*Bjv&o37CcX2iDuR$&RxN$=t>>nLqacN;;dTFXYIkl9JvdEumKfQ3PIX;rT zL}{Ki9F_iWb;O@fW;3reU!hKoa-*F?C`zv@&HBXhxWqBL=fo}P^D)aTF zmu7F#M6uNOI&1s)vGUsW^y^ve+O?~L#T)D4QP$bMcRyWY=i$huYga3`7bh21ZjIx! z-BAf0U3B*`#3S{{zq+2mC;dS_Bo8Zdtb82Sij<4SZFM-VXUJlTllF<_kE=D3{4GsQ zF&wu!C`vR`R^C$dG7<&8gsW8t2^`AB~;YcEF0xw14sAKl+V_S zXS@Rlzxex;Y1I&{&Vj`u*k39q?DIIa+qv;dV{R%NxQx0uf)}y}`JU!y#kvYRk&!zX zpJ7~m;}KOz@TU>l;a*miHqhM>m2?##9xT2_wv>7UEB{2wpbQYc{*x8u>SezSu&kfd zm5=M5j%*)7?lmGtp>+%rl6Ffq%r**h!m8gUZMn)is~!N2?>8*rFH>VY3Uete@Kzfc z@WHA*qC<=wFJtXrC9a4d5np1xF>>lHd3kwhc9ty}6NXj*!mB@)U*fpV^p=?)^##RG zPI)2LhO#ZI4a`n*%1F^n0^H{Y9r>rWw(6UmMRLXLD74C2b9~|vaa=Fdbfdxc8waR!PrvmwOUMVziffcFTgE!b8O!>fz)Hcg?MtqT=*~ zvmo*oo?2*Sn7@RCcydPpn+@`s=fvmC=;(YwDNp`19(CRQxzHfu*bZ9)^A`+}!BWwv zoWMF-?1gN3YCuLp!q!5+1N;jR#{b;im2(%YRJ>rK%so(ZGgskR(BvAqUrq| zS+5kKVNN*3AE~~ul|`nnJQgLzPYIf2H&mpIs<@#q>?=+szqd)XIC@jGe(R0a#$l-Z z=H)b8&O%t9q4c&TtKsf~Dnu!)f(&P!HM&v`8<^)V)ttIyxACA!HP})<$G`SP8)}Y7 z0M-rp61-X%8ivv?GVs1^uvR7-q|`M`q3i(vMFJ|I(6GVe*%1ycXW!sovYiugJ%Msb8^*UiLwuDoBmc~VY-#!O%+;Sw`5`Rr8Y)w6x#{g zOW!y9Ekp>1+i`>%F50#rAT(Yl`Ib!>ApG?2UH4go7~z|t7Zse-iF=}*H2>{R8*oD< z0u2LA=a8=BK;h8aPoo#a*IJ2>J$Az>3*V|^@(HN~UckTt!2qlU{5E35CwXiXre z0(;3W)){w1(#!=HB3ca-I3KZYh~Wf44kbed^}Ur0Db8P0A-7c8h`D|8d-tO|AuOsu za*}}UPy#g^ydI*Q09+U?U#?N5u-vdx!>xRM0O2=3_2?p5pDhAXChnHXp$IYiFHT5- zq~p+`R+1Bq0`ASh55dxKR)A7{^K}a%)XcMe>WoReW%F8V6q8hqAB)6_NEfh_bbpkN zvd5f$*d=%k9e32Hyg`#I(7bKq5yaE!}za?so?!_yreK42$M$4{YK!uVd&El=rL< z{k-eFL~V`JVt?#5&A?>JB3Za?s7hbE^V6M7fbh%T(L)M2=@egeK#!dgW$9=<%82lm z2mCGpSGp$ZK7In->agg0TQYi}ROeHR0=SB8AvNRqtEwN#b)E*>2o&{K_0{Y(fbhq} zJHo#ySlp8@kB7+&q@ZfuyboSo!&46CQE|;?C^4x{@8eSTz_?m<;_+<`vTx~$@<17~n zZFacPvkVZP`&KiL4wkUgKLj#XD=C-wi7Gk|T%6nTBcpOYZ8Fhzj+M&*!jFGW&u;eriQsX^y$EqH zOB;>uEWFm9VE{UQ$FZqZuS9&1V!LenKDqt6?K`|oW;ZqQrTGgJ?=T{Ci=cXM2~bS~ zli|um??R$$_?+M+R0mTuM5tPw3pI(oB!p@MEr9Uh&oGb~usq#W!`nUPwLn zK)19UyYGS*D!^=1Dl!6AxzAOg(jv#1Voi-G@B9Tnp4SJKt|+9rq~N; zi;-50V%#WVEh)34#5P7SLtPil0K%Qm%>hT9pkV7zJ;sE!D#NDFM)}BK2bl?KN*HMf zswBUdx2t-iI0*flzO3GXlPSBoBFt=*^;tTWnCyCc(_#ooV4<|tM4ab(W)O62oh7qP zY4;P?^@6}ofmw_>ri=z-(JDBuq(J@9B|FRRyV4ypv(wrd1y271`O1xnh**Hb3l=AI z5W_)GpoJE>*lD@R!$pQ#W@RhH1Mi1x77t~9%rF~*S+WpR*h4Cxy8IWGI51Z9qtak+ zpNedV{L<&xNzy?)$926eM|2wkb5j^v0*Nixr_b!w8;=SNa%~+T{G;>t$vxEE+2{Q0 zAIv?u@k5Jh%IZN}OLmX?DyYN+9%6VfQ`-kxTqTtW6Ae6vqKw&uIh@nlm^!AG^_@T^ zP8=wi@VJA9z1yuH_qj^2uCRwKnd&6;3zRx}&4?@D8Rk<&G*tfiNofasp{a61a-DcZ zJ|e~|SczCig2b?9xFfH0tsM?hE?7r=i)QH}@)Pt)r8m)EJ8H?GR$gTpjMD_;WCV7J zfQauI1X*cAr4$XmRslC+49fmyJ510SlB1*T4wb4#@D%35LCK0@yu^{CXk6<-E5rZV7H;k><*U{%ZzZOD5ch+!QRg6LUA;*hVREg7ccAXo(JT zvgAi4C^!&b3Iq`!yhpC1t_(0fo@`tD+*y*5Cy{9b2fz9gy`ce9Hxp29(z5SFju$@x z!lyL*3kE$;SpZ9QE5XR+BaF$c;G*)6VMqS~I8lk|JP8v52tWVpJ>P=A zTp%}7E*>k{hw&e%f&r#SBu0#KXV^)+=0fchyk@k>YZC1?RxTo8NxaDdGvvMfmC7~hvFivaaf3HoF*5@u~rOWOOhq;|7&{b%;3w=S{ zhl)emA44oodM&c*H#;Tq*G_AuAbrrp&OsghGTDd8XEaC!Z+s-(L%alqqc0w(5JO3x zX!s#k#5Rlo1_%K__|y+MC3C$k%HC*CK+9D;A2Mn83(G^*>k|`A<>p6{SXjQEG9Er{A>!^3)#z+%C)e6mH=29I43~msSw0=5AV*0vQ-E^ z(LOV=G}m@%xTrzk|4xW)dn+p((Fadu#smmMpM4aM!QQ*`++}cxT?S$XCbJg2^T1-D z#{$a|UY`W4oMj6v31UH5HUK53YKh`hJ_8`U`NOB%an!<4s$z18yfkDlYz>)T8O7UN zeI+m7DYfNOPqlR*HyRfkEi2cOkbVFlw7*WI>dLun)h~!#oNVvxvy@js2O=xF{c8Gz z$aKp}!>Pg@N#KH43GyIHj+Z-lJq=DsSwoKst#`_i4dnHPLV=-k@nhwIktAWlLzEWF?Pg!BYtk{@uq>c^`DS z`niQ+#PWroa=QRsFSyHu{0f9Tkm~$IAN}a*PIliz4T*p#kp*tcPWC8?UXJcHK=?O* zge%2OaCzdLeQIH$nr=avxf8d`We{#5nL0IM9{jxJ<*}PaMYS!oe|@`iK!xhkC#MYx z%~w)_<>;tjxuozt93uLM{Htp_i<-K0NvK5nZ4}l_PGWoh@{Uh+LNQC<^W5G80-b{F zkVq_!j(5Vb(X&55YO(#W)xm4yTSJBKqg#_T%`8d;J&B5FZE)YTj5pW{oMWC6TjMMQ zR)FxO|1t?2qY^ku#?#N&1!)NcZd%j@dwg!~eX$^-e=Rxxfvg2)8DlfNKrW)EMTT$) zS&5FRSwPTV#Or0^;1YmE_m{s@#mvJ!Tvryx7K?F6lC2HWNw{SI8Bo|sp*N3clO1Ju zZEu^HHl~XdY`xTKmur~lz>6Aj7Y)aPrUJ%rMw%K95XSyTGkWVF&mUT1QnY!K9QAqS zELZp@iT5KyA%umaCnEF+{d~m_!TdKy+%k#%wNKa=%E*9KF;RXC&-g zM@XbmD3d_2-H80zNIus=B!p#Uk8-6|20y2^+L%ZM0Kz}})!=FIBM)7kjfM{;&pIXA z#f6klGx05fGAeQxrKe!i)eDc^?J;#B7@09EY)0&Pa?f;|5Q4`wKbfn53W0U5D|>fx zP|3~Q^EGQ#-siu*3P_?eUj*gJ=71xD!Ph#SN9h|#jv`gd5l8u)XddPl<{bkbeMFXw zz53kS>LIOsa*vfOq$5N?MR%WwOg2R7W2!uR!1@FPDtK8lhgOM;)y%O{-9!XY%* zhKfKVBFQ2z8VKf)#tl|Fd(a}^DZyN;x?V6CJ_D(cf3~c4vd1mjiB|&%zxa2}!yy}} zz2epuJB25)_xTe5B(szR4BCa~Z3o1=JYCL_Mr+FHXs zj~x5Jk-4NL00eH|L{)*6ILkpBaFN8EoUod36%99s^``r)2bOJ7tR{T+EG1)QGv8_5 zQ|ehMDZnRxTd^gun3RY#4^JqWBpg zN64oyRa-Bb+Z-AoOK*B?vHnqf5VycfX6}r$a%A>)lGu|WY94;$?7A1uhHH!`^YoE% zj4M5-S$WWh+an4TT$0SJgH+{$Z0FLn@wOZ721It*4WDQRpZ(P8{-JCD$AkC5&se?Y1vAkhYc6OFK5@baRu3RkKsJ3R^l7Lr^N-xuw&2VeQ#i z)t3zr>OZFVA}4iy*UqP`I)H zFljc6YLhm(wf4YR_vts7gSXh2*~YPL8=Ncjaf1V4d=}gzofCq3H*j?Mj~g|=?+ z8xGASS&4JEtJQ0@aF;`$Kwe$aK&;?G_9LV3{3Y-20slv4TD(sOZLa(y>uk0U`DSRp z)7scp?1b7yjT z9-p8j{7EEbnTl4j44=4ABya6)?-*@G+Kg6PvtHk7?+x*ekc!scJ>(uTMFWIitGK4s zW1pB(a+WSZhf&A${Z#H5QRM<9J~cIXskIl0U~XPWh=O5+&;xIilxq|GVdtmZ6YEv> zgkS%v(g87(LLh-Ac^Nd2?(5H?puWRvPh>FHlhfj@9*V7Atfej(2;{106o zp)!!aEPjBDWcN=>ALwSq(B-N=Kt?%gdG`($*PwK()k|2W?YgvXZ4!mzF_CtqedzKS zim$&df5WhL@w@zu?tl+nzNB&OZDFF9$cGYcR566FEhDPr@|CyF{F%W|vJbD=3jMxy zOg|EA#_|=D3QZ|U&i!LcL9*~KPsIxJ6ePtF*iZfMNG6inRWgzAg1fe+g+r3U6-7yT zQb}FJh^Z3u482PK;dXsgJc~tiO|sqT%37!UqY7{;H&K!*%<^md7iag-3}iG;8GrM0 z0QP+Mzj|^REwwzoy{*~m?CQE|wjwi`BJDB6tWX+Q>@&c#_>KaG=SoY+Xq}NH5G5W) z>{U%;*~JwYkw<`uA)|0}fzv8p!94f2w(lMK0p{R|sRM*x_^e`Ylx#Gmn}pVkp}g-( zMyR-C#U+_1L!GX-?o*+NoueD_>cgt)9ffm|tClY9%{14o{ zX6{Yh$rj+Q7-}gH7Ka9Bx-e(d>b7cdG~$?g9W7aFTW?jm_hqL4x^D|{acL=t8NNyR z5WXnjg4uEg%Q>37($bIz9~kXv!H_nCL;5(kdysk!6AVhMm&c@+LFwwZrbvx1ye z=vDyXJ(QreLLpJvtA!UxTD;X}1pm{7%F$|BB!JIJv4xE0Q&#y~eN)^rBh^B)`C_eH zfbgROu?j$i(KwX>wdxu?FKx;TnPJq!D?+MJIRK#eqlm@x6@Xtv9Xqa^c-RH?R87H6 zwiI{oS;<`siej(S4+B-|_E#F;{ddW;wvFS_BN`9ab(EM!^S+AE%H~In1zG0?D_j_q zAC3SzL9yPj{44|O#1THTe_qrxLquIJK_ZG9c9; z(KbltdqOuhj6Yq&7wEl+1rQ-exlBF!gn@0vEm;#Uc+v{NTL$0|T?sw%$Arp?Mh|DQQ zh_zD#j#TN$09u56Vn=!D6i^$7l~CEYSvH?07b^?3st?rmBi?YKadWWZ5ya-Hu|0VM zBP8CUN7*HI!bn&o{WdW!Ozi8FVx8P4L9OM6+QQxj@!;H{lo)2uG({LMe`h*J!`4;u zktyY?)~r&#?y+aUH7#7gaAUJEp6w5qwB($0^PV~Zp$>pnfalpCKN>jX4TNzS2K#{x>$Oc}U3K2d=iU?yjDUY3UY!n$G z31%E1p1T7L`i`^K?>EiHt_Q*%dYtiN6;lM6hG2v~!86OMj~cl~xT_>A}pl zg_mn*!!+{Kkfvd~*5E#ZNA{|a8Xb&k5%a0GR z$%yy(R9nv%Ol-}WCc-x=x)e=RW0N3)6w@$~qpTS(*;QS&1WtU?XuH9&oJ_9YiXpKb z47r?O+nj!~kHnf~68DoR#CVCFsx?1U!7NcE-BC8uXLV5D^E#Iy>%>$B3V`rqKWvfy z=H~%945vi5nG37I2b{vS^3vO^v1H6G0j&IHC4!PDBM+|Wf#7YN#IbbyQn=CXF!xG} z!T1Y4hGuL^F7iIPe3e>?@a1U8qyWN$zpbzzzmQ-kRtA`}UI|j-iBtsIjB+8|@l;yJ zF$kET<_O4)QI`5+Re)+??mb9Fz>dT+_Evg@Uz{*1#GyANf$Uq(g|GQUkPnlH$L^PQ zvmVGvemW9z#8(qb&ntCr*eiD-hacw9G2vO{hP;*cBlYTv+!Q`>L#MBu0NQlgXkzYP z#hV|~(WyujnD96L&JaL33e*q|1Hb5`iJ529 z0;CZ|G1!=Kx;6p_xrfeYt5LH}Ki|k(QGliwCs%Y4Lac>{i0()VNH32-u*d_M-0VUK zP_S_^w)-lNoz~PpE0pwAr%53^80L|LM@^Rni+s` zm>G6R$ty2{D@*Nt<(&cuXI==_qAt=anTRC0%)k}sc?q$I6xWLGQIKvuN-HY#Uf802 zE&)<5XvJh`#&=#hflyQUX0FX)k4S1g*$FZq+Q75fd>)){7=pJ>AX~jUJY2253Ohii zCl`-j-AjN&8Bn^d9W){NC=?J@YYM zpU+gAbn;ZSxHwn8fXT502tV*obwAH`zKm1HV57pYBfugk9&?0?b^M|ngM7~cfo5!Q zoDj*dF?9n)(Kw#6U?*j89W)};N*>rZdQ7#3l-p)kc^_+-1 zE~;v5sp10feSq*Kf2NgLO7`3arP_nqKCE*jWWt{l|;{{|3hkM(ojspkp6p|D99X4--Z1pUe(4#bmWADqXYXb^VH#| z5Uv42=iB?PsDeI_!~IxXEQ9k2JX2wRU%gb=qML9H6PZ^_I*}9_ZCt><9u+8n%UTq4$r(M_`CG@e2==4`=3E; z9iIF_Pc#yiiJ;Q}WCf&2A8|?{54Jup)ea}+Qg7{XfbdiJ&&Q{z)M}bem=?FuLBs{j zhrRQ4+X8OAl8*KGsfr z6|mdhgUUtI1)Iz`@~QeJ?`^V=^CU2Gf!NnA+MoiLnm^?J9w8iH8lCXzGUmp9P_(xb z{uUrS|J61?3DAlc%NI0(CT`*dffQKbwhy>7(j~qgal;dokb{Z=h5M}QXm7H`Wt^G_ z*kG4cnufiD=QhttC@v(wRWPgAI91BF=P4$w;NhY@SDKO#eqN^Qu1PTlj1s}(aF$WE zXeUcK@ca{i@RhYkPUw`KLg$P8eWXj(e-mB0MTpq;0kdO~1emz}hp87JrGnVyxwD}L z5H-?U9Z!4kvf@b767^WOE;uN_eo=l11vLvYh3-KV$P{8_s`4#370^ohEX2*~mv3y~ z-*hRGUL+?LnNKdW2EQag_=mq?#!Q!?g6tv3*&z1THh{JZU0xLZgCcf=6if9w<0@^` zLhIFURaZyNRC$ndZ&Fn0g97p^&QIpw4AKfz-Sh}E7Mj?qKvUVLL-}{6oRK-$XW?73 zTBR}^is<$1gNiR0%tqflNB=#IMpA<}l?fpTd8XQ+0=anDCWh5UkENJ4&?n ztcq?0cY)O0HW^p?;{~3O`zgm2aS2aoT^j5Ne0b;Z|iqNr5EVk7pae%P(YZL7Qa?F)l z3P@6^H)3^^NPu(ISiqWq#5@m0U~2gd`B|yIG7S zA|U6MYh;0#)~&9ul?Sphbq$WO#0%{AD*2f^cq&otyY0^1S5b+);Bq%(e6#i$o!0Qy z)Y(Ox0_0UQqer787Fyu=4G^Y()=UQKx9?Y>ypTQ`rV@IZ(;(HVVVJAU>J4=3&T8ET zem9hJZ*vtzVU;8NtZ-hOYZ7~-GQq$5)mK$z+`g;%cVSIEAFAwmpAXf~>Hugyvbwaa zY|TDAY1&`Scv@Z6;5H+Ib!@0i&ugi*292#py>$&BeEes5Zl9c!YpJ4>Y`5rFXSb%3 z+-FftW8Q(1j8JJ3Z=HF^OGlqbDUq1L!Sd4)(itc4g_`jyEB_=@M#pCXz zcPKk^fASADH+Q3Qah0i76ldtXSV0G}CuPy%yj8kmP!|lz3 z`;URt*x)tb8zH6M0<=SK0O7SyhrS-|G6K$TPWpeJO7uMnIk89Cw$>6vjEBjN>DHip ziG2X0ZPp?2O~1@isz(81occ)sQyZjYU+4`WeDsG#1}_a><&oi0J`sFRV*Z6LBVe9D z0&K$Asgni@DBg+8E-DfB>k+A41z}3j8w*-N>z-$qov-1)y=C`{W1dpukwImhy zbtsy>LsByCZduF%Y23y=c7)K1c`LIPIRyPespf>70}wuC&crx9Fzv*e8N<2LSXsVL z$o|75!AnhCjY=kP)GB7@RnW(U1NsQ0zE5{9JfM*C|DjFkYn4urXwl5>>Z+^Fj3-8C zjVu0fdjgd}LZ;`)32yj?*a5FdA88iD&*rme*HbA<#1D z=Va@WP1J+nqe<2Irz(1OQh#Mj5vs?n)crl?Dw3m$CBAh z-LnkCCT)xE*A;#9r?$BQN)P&!BgK*|5bhshgMlsPxOLP>52!kZ?s=0S%=cB?(XI zr=aQ_c>{Tb>|mGlVToG}#JU~R$^zI99_^#Wpa^ua8QhV1?acpn=)ra6 z+bvUrfzof(7ad*1BU>s$j(^A>)mJT1BJ+}TXxN?mD98i`!!Y)+&Rf(orR_7<8|eM{ zCvVnc_DRD@YizH#9yz1QE65OKcF^8v<4B|0^6=SN_hJwRe1K_d|FC;s*5>E`jXooU zYz+>E#!4!H`)yEez*6P%W{*OeyShY@Wwl}KcH0MZb_pmVHYm5X2bswxdQb8I-D)Gd zgiE3LONQ0|;q1UJfTaT}4x1!cRL&^wxgKn@OGEaRV53n+nW}#orV0yyJnx}&$Qhy; z)$$1t7@E8@ikXaSv)DpT2aL!w0^m-zX*rZ^BfL34_}L$E=bD?iwMUwCNGp?h>{*57 z^qaEh5B6BbmQm(NF%^Rlte@!Qn1x_pvYE?IDmW|NbVoT^21c&}p>qW2sYFBwy(!Gl zCr3_MHb!m&8%6^58M0hOaV!Frnj;h!Ih zD8s@@uIiQr2+D372RGr3uY$v*qVI2q z*t>v?J;1=Gt`MmK2OB_``Kh%XVE3YukQxfn%TD_qv7qL?vh7pgT_DAm;c&`fdeM)A z$7FK#V_TI)9_m!tvpQy-tW-|vQ_G-?Q?31JfnwZh_pM#Fep8UM~ZC>m?#FNqr(ORe86s$&krCG z#syFlpOFSSS59CWFV*>V=G4lCw_x!p&fe~?b9~H;oud>$_?$bImM;Uo!V@Q$Llzdy zk>q$Og51akv9#MbFyF%rLrRu#r#ePuPzLG#YI#)gY5!VF4n3IKARcYUz)g1`V96Zn z_*H~P0=2_An&WcJJYn&gM*rPly#V1ae!p!=pY6c-Ve(lHmjeOA={0MhW1nimexYP! zdy#~R^MZ7+>wD04=$wahSRQcWjG~ngzDOY*nTlr|Yd!}Vr-j&a0)-hSF?|aSkji~u zj!YmVBoP2?FDy^CY!*fhUbFK75WeuA@#U7m$+zrTT`(`gw}6gHB3`N{5ZR2NbJ9+b zG{ovq!&f3BF=?rC+5qA6*_~*OCrJTS+CV57uknsNMp{k+7(n=vKbw9P|2RfkE+V^F zGbc9sDy$gdKs55YEPJ=n#?t$$xio?nTd33$GPYRJIT(d3e9*hl&L6zO7(-#JrO!#4;Kyr!vFU(9;O%7Rec)C zqgfbkn$g1pk)GE@NEi)#t(%n;2J1Vm9HTdQtI!pT%(A~c!V#&>!fcedT(t-kaWCmC ziBCRDvMu=H$si)WfcH>gkH85xSQm#BGOrXS0!+wl@X;Y_I%^eA_T*077nMsXa*aH+A#<@SvR`oxX9u{@MKf8fzc)# z6Ai^I{nVEsKiHVc#RajO?RF1c;Af-U_vM08$|q!2pF`bMfx!_wWmm9V{9ubXl17cp^FNGRrOPQzwF4$lTGRffRQ zK>`lz6qyblq5$~~9YvMzY$29=jvj^-opw!gTk>6UQs{#0O3#lj0boJgH#!@!@*8`DUF%rA!w0G1@uw~76J_wY)g|C z4$X3(k`r#&HOM`{Jqm{t3ae~(rc&|Ex|Di^C?HU@l7xJi{;9gMD`@O%^qRwpQ`fy2 zIFsX0w87C*IIZ^k`JC#*Hivo z6wnGAT|qBnwP3R4hvH9ep%_QAU7NN5Z?To_y`D3PFew@!e8wLU z^K3$!Id-K6M<9z(LHV7V=8V(?x74NjfeIA5kWPIce~Pgz^WD%#$gP$HztZ<0VBz~3 z-|Olr1*xO6n+_BzrGP7W7=rLv>Z3dd)%8h~EgkSk4T3OWI(nvjZU6W`g$a4qf{T+Q z*)x{q1zJjIW$C};}QnKU&Z8Inl+OSs=ioOY;9tdw4nq>bC#q;bQ3C@ zRQ*iTfbl*pWB4^ObY}WT0ja^j#JOkp%%YYc5tPfq z!Xy5~BOz)UaSI^)_Ma4FEOTpuUV^oo*Yi@X!H|$3R;iT77Y8aFxsqNPh%dWDKJtB$ z*CL&hP-K#)Q71{R;#o+X+8U_`x~4CkTr$7u46-7+YdQthu`4EtxcS-K)+ki%9WH&+ zRya+-|Jn|BkuZ~?b(phNn6UT$)NHsCR+qLWoaCTEsMp01#ix*qa}WbARX)(2@43bb zLMkwLO%WT@xN?_TU3?MCL^W35{c0Ww7tKM5V7YU&*mv0U@Ip{P_&CaJ1x`smcJ?Ef zf@&lvnyzk+4$~lwItlhVTH^O{aRA}tKghkFNlf2YuBZa3DzxJA7tBQj6cc%Cg@3VY z9Cnp0x{!N6uE*>eWx_0nVcJX|UZkNIa~F1%0TR)io1DhqyMY9`LC^u&V{qJ>&nC5) zY1Suf4Rgygg{EW9-W%;b38+4Ei3t0|LGE~5=Roe^wYzaSPyxa}`N)BJqm3F6K_qqD z+~YGVC~3NQ#N_wLt$08|hNEE~PY~fTwbxa6hOu5P;=-+!rO9P9FYMD&!65tEP`pQY zbBr2#!EjWmO;|(+0l{VDc*7eTpj|doG|VgBZ@5PzQX0cSL|Ju(3F2-;BVH@hwBtcB zz!@NX-iuvP3GH!?A;y4tMli0_!1hB6H3;l3WOFQH2!z@`k=suiArrv9qa5hr8~U=n z8_dXnm51)tgyv)kCLbfned0!zhAR-o;URqce5}~_(wI*iuniD??K{q&Hy}WqbG$bx zg0pd?Yk?~*hlSJTxVb-7V2f?T1zlcWwe#pW86BMQlm<*?Q{A)ztAQAFy_RSQaH!k& zF;wiFDu~`PM2@^#2L>i*A<&B51PHHv7rv0=q4a#)Tr%$2bAYh>4N|!W&Q4kZAdk>C8`S5bZ03A0uiT ze&VUdJcI^dZZ7fU0i$*%DI!cM{RT%JAbjlS&dIZYBv?Cd=RrgWX~TFkvNC?Zo^yi0 zINTZzr`b%^VnIWWFvfyp6MP*Rj8hs!De%aIabsr&g0f&hh@@|tB#kJ=NWv*eP#5w& zo@~3NElk6#A@MuA$qGW`zk6)tf#JTqwu>3I4iJ9&jlE5^CiK_&+SHy=L0xoU>KH;* zPTC?ZxGST(4Z-{(+)c(DBpY?Y?T3Vlahl%ijFEOTxNA!gjS9>g5yo#g`aK}YNDMDG zEo}`fIkgf6H$H7Vt`zS9>LQR69D|AHy49I-Kox{C+wVMCi_HNbe9bDtln0KAJAul@`Ul!h!7xeo`RxzA=&;#YQ4?G_QCwxKD3rVJ;`HHga!y7`MEf%TtP@M ztF__bn&NTgHndEk@(@`j045Z?0)?dd+6*5>dmfkPAoS-7wF#?_$C0MRHK?_>byx;L z-PkT{+V0Gltg;P1KuzDxuf3&G2 zJ{yG|0E7=9FxW=802^1-SBABAOA_OP(O<&ek&kD#*#gho4`E_*={$vFS~i(6MGyYM zTEP{4BURUX{2gXe+1|jY(%||~7B!GS>UNt|TD^uZ#Zi|U1)Cu_8FYfE$tGP4amrva&`W2jfUrCx{X7Ki0{f!CsGKSv--HC09y-Es_R7moq(HXAW1|fDDjdyl0MMh- zB|XF{5&;_5US?}mXbL}g>)@fB^LvPnK}v_wU3{xtMG)CnAL;yEGVB0nbq z!rz`xlv+bu`u>AXc!g1y(7Gn0`v}F^cLsm{E5#M!=9Iq_}f~`2d7p{Z@}7Q^p`1Cd62eJ6F>OuUbC7 zoX4q&szI7?MMj3cLfn%*EZrcV1Uu3dWk{#V(40}-0f3Yw^66w{BEB)zWin`^9)E($ zxVED!HQIBjne*ORQK;d_hFDwl{h=X%u=CqbHt9aCDnaB*(v~)1TJ_;AY|nkDjubg6 z6smf5wO`Cth#xQN$tbzQl|e0|ZbF<~ufulrKej<6lGEM!x5Y;yUcnmCScJ@Us{oRo zj)$2UsVY=8UgME3NOl7C1Q5P^xqo*q*2-nNhbS1tDeR=0GbcWeQ&jMcvNXtm6|e~gDy3C5!Y1rQ7$vKxc&7y$&?9W30G>&_fSoo5Gek^z zT3_yB`+ls#AnTZmzw%CR6- zzhlQD9f{R46wPA5q8jXPf8_gc$q~?0WZ5 z!!@+o_Dxi6b;!t*HeE9OK)q=6km=2ocO3LEiQGRWSP(#jkAG!hX)@~gw$0k&bdc=y z0EE$xhm#pkoQpIi3_@Zz3D%|;tOnNO5|!1YK3HY4dVpEkPMV{<$8LmVdK-Q?Y*&nC zbH#9%IXM|i3oqzszGBXNnIdSt67ch#4~5l*$>pZ}45k#kBq9k44DE;})c(LiB$gJ> z0rle9L53>*Hr>UHVYLycbm`rZwn0F@Y<1yFw73s}eX>WEsSR>Zx;%MKoD+u7*!u){ zl$?&6-jKSZ24=IqNJrJPW{gf0N-R=RU0R=&NrYxnQd?NLNhL^h&Rz!!kYsmx5XWZ__HSR6ForoYAn7QwV#)8;}`n5%-e-Mdvk?1_9skLp}8?B zAVB!$@l=j++Y*>jT98}w1Fkr0$S^l|561D&$umo8h^bqWKe@v)HMcyae6+YHR1H#w zB!6MjyS>mSS5iO$Xn>-txGo>Sv(37_Ny-Rwm*g*j!h-PWd6%mtA3(|$sxknmOl-Ue zU=P-$Ai%c)5*KuLM>|hL-ME+!ZNH8(mKycqB=0VWd9IE7wk^#RRU)RwS`$SIw!neGl zmIeOfNj^I)*F|)f~TFOR)jV%uMhtaycSHyf%%_Wut2DsT0U-ez%g-_H{=T4|n+DKI;~~Rh zP*@Rn44p1Y;SnZLg+Ufd{O*y{&&>!Vo^n-prGNBSl=q8AomOzG838Vv;h-j}9~QQb z1rRZ;5~a<8>9$-}=jm)zr$cnmI{?&dKT9apV!~5aS(78##`EQO+*oGF?kO23#F+ww zM_h>7QfMVny~f^5>1h# zB?Pu1tK>c5K(@YO9ryCfnqHOyU|C7s404zhOu#5;X-Th*7XUl~j`iZ%l+7pUrK=j-Ry-qr3^Y3%7Dn zz38kXqhWE_@a-5wSzpj2FsgG%2Gw;7k>Jung*oNx;0HkXXzRjAX)R`J;$7t||GB_A zQTJrj^cDD17L-gJYQ>BT(75kbPJ@HDXI6#xo(Z+^`cmn&`3ehfFOQ$yYYzonw@dyO zZ`WsiHsdSI*w4k|+j0cY>W0(pSFr83u-Dj@L*(!Wd~rpC|5Z< zHdGaC9>I5I=#7ubjCNK~$sYib&5r!0K?ocm(*QeaoH`*A`&PXK5>){Zk%nN1!bIPH z$e&?Sv1wsaSH@8%bHWh^xPXNXOUb|v*Y&GhP#HT{86ZUmF>513Oa>sF{VU!A{jDn0 zy)*k)RT|-Jv08fP@b(Ly<%**Z9h+%wUGxZDHLcIF^ZA9lGY=1EM(}w~5Fm#w?hFQ9)eklD`#D{E$3|Ex~SN zsLF;q&ZVz;UK`S`7_!C30O6m1>K^ax6tzSOcOE(T0d&kRQQ9}oW*=M$r@gQ%{ZIw) zqA9aJp%J5Ptx*#QBxJSr8x0^{5!E_CRb5B`tRTVKrY0s#6}i)$FMfi0T%xom(O`=i zfERJ01|%wvXLdq(0ltD;zBoHoR^aF#{@5l?YYSZ$(WA?Q(~FPA-1lolnOv2HfWkFdeSUdp zw0dbctCzVB-8!_*nF2OdFJkFd z)~_dVRTyd!6U1{lu7sxT+d{#4$(wm8KPXBerTp3OBF-5=j*VPCj~e1Vi&mV&b{~GH zW*0`$B&-6l&5O_c!kcZT(-uO@Qky`ou!=6*_H@0!G>)K@h5-m~eMm>uHqxA)a?gRN z#tKDay!;~;rTNBcxl3^7vfC<_;ps z!c$9y!7X(9>Sd$?z4ZB2V+#aUyxs~cBo%>KZ>l0Y`P(!Rl2$5P0msU|=jh(M*XpE? z0m28rOSz6wH<$fg`V>hCRRSRihgIB>?vZ*&%QvNE=bHF&5=oEP(f=pnm~BCy$}*?x zm$0OixOsB<<}9R!;!0K-efcIp_;3G^IG8>;qs{Hh$t}tFnj$t*B|d{0K+YwG?dE22W!<3{64XQs$INPyqkwrDGD93ZZ%^PxH{%o*Lo6h zRf%6g+i-qlx2+#wYD7B9nGq$HLI1$ARHQ;=OndBf0wDYke+=zG)e9s}?~FJ}&zc}2 zfm*tUK3kx?d>-9w|CtQjMC5_Y)dA z@6-_XvDxe{H572g+ZnClQo)V~(&|}^jZ$~k6I&BZlDmgnTWYfK`WCd_peesmb)M(J z*h43_sQ}?qE-P9_aQE+fY%_|uHD~7}nOIns+<|L0s|9r0Ey6t=FeHwU-DnX})-;^g zvf5~)*q3#3izqd7Swoz2@(=Y0bQlib(~AM(eD;cR9j7myg$x8Xz(>i^$HFj13H6Qu zh!{o-3@U9T<}w|J#y3I?kmwyDgMGC=-NsjW(AeDt0^nHxBm6{9L8#@~1?W{O?`J1J zXEQ0FAHh{k38kg}Pe~I~6JaJ-XL+veLtT}NSI(Lia+86_B_pQo^$4sK!IM}W0m9!s zA*q-Ps7#CuJ#O}!;s;MU+gd2OnM6|b!t#SS|9p}SIv&p|CY0sA3Zu8n zh@jAg=1QOdlWiS;x9QtabgHcClBv*%e*+LE_xUi~5x;FAEzUr740P58#05yuTdj>* zKrMH8rA3b+ulRxr>Z;$5H`+4FmoX}qlsBVh4=r(;<8RIvZB9nIoFAE2i4cgD7s=#= zB4r^Dh}4$zNntiPjCDH}Ta6zncA6N!?T&G&cx7DrI2(z3vuoMdHkFY0Z>_R%DMf)D zP??N%K$EfxJ_#OS(~IQJTqG|jJQKR3346Yh(zZi0iyuRsK;O;79aRY++SC@M$k;&I z3*d8b>Xrcw-GTw^QFmhu1>`(Zv6Z#%-hob8?zJiUiPm;Z{Q#>`U!A*&pNfhCgkSm) zq;v;OEn#pGZL`R{jBzQaILylX;54=#dTb8xHWo*()-D?$E>QMuGU7wxLJaQv{NGw zF4KfaqFdxdfG_*ANr^tVIV>GOKvBhBOa>$=B58aUHkL8bhr^`d1ZKzzRH{d+V&x8P zQXVo=X9QLNv zkm$Twu47O>R;VSb>;_6DG^7XsOp<_5PU2%Q$(4O+U8s1P5%Gt&MrjH^sM6r zaUtN~;)ztKycIFCJDJVQJK21#m7UBa-I!#vO=cT3gk>`GCK)oBH=W6Bc3N6NShWX& zP!O%Mh&?E_m4aB%1HpQrs6{DwB7*42B7)R{;EAmM{{QQ`pXYwwk4?7IgSsrc^FGgW ze_i)=U*FetC(#i#4qS0jBA33o7}M_zE~3Tumy#=SN?{!hd9V)%ehN90Ah|?2<8%9W zu-#*RcFwO!4M6zox1sfY;{OZwW?x4xk@$iin-XgBgli8(k%i}6km(?S4uvwN&;&+e zH(VQvzB*i%)OCyyl1&*L#M>Ig5Ou1aOCl9bx1@u7Pks;wUKCe4(4I{CmJBeRZLuYw<=La54R3RDs>s&V9hI+BnE2>nfA|eh5adh&0AQO=K#l&pzhG z#9)+w-lhHQmmctZu760$A~zxsuI1fxvjh_Wg!$Lasm#+m=4;!_=lV$Im$Z>llc2Ev z(Kf{tD;xXV;$qu~2Q+?;I7i&>{1xf#;FYB>qFz-9ER-|ZI!UIw9kQvvKDX`$!H8AK z`O-2rUt=;vO$K7o!!UT6oS`1-Ui9q@!0_kb=H;ku4>sNGBQ19AA^_p@_dZJJ98!xj zh3k5B9a(V$5>#)AQ^)j#a9fdypOh!5W)Z3+80q+!v11WxPP!slra)0^!@f9p(-+h< zl-&}t&u|=OFUpMs!|<3s4N?bZ@(wX(WT;W>Y<@V(>Aos3wEK!UQec;-~m0H)j^xT)jMi zaAN<;YVth3qkB+UjSC(}QWU#f1s%LPT$b2vEOj!^VfD-_T8)GkaBFa11VTs0%kpN} zj)}%kthy-NQyMCZ<+6ZjN{woO@XxE$HI>er8819ZODYuo{>cRI$^J=|-NI_hf0HpI z5ti}UmM~YOZyAnB5dbd`WNjm>R*LV&(pHJ%jZLw+grt6sL(QwgP*esgI~W+}9W=A5 z&UqOlPx?`S@Z~R9ax(u5nU{kR2sk%8$u^3$B6}>=5t?cbv$4y(F zH(t*xKC&?qm5qhx!jz4ul)F83OB6CihOFMU8ZN4)mD%jGGa~z|EK6XxZO^PFi9TD1w zKa8-D=We1dntl*y$-$OpybUxdGm82XNNSZiT;|8-pQkj3+x}G0O~R5g@)4hy_VyN9 z3DR^*E1m&p4-o$1CFszaZxgk0w%)so79i`XeG$*wEIVd;$G5H*!-uX?fRs*H0^^0W zCKBCrD(50YqXeO1hJ|HMj#YxTVCvFJ(fxuT>a=K*_KP>`aF*Kka8L0O_G0OV9a_Lo zOFNtGu>tc=-4f8%alQsD(m|$5$ zb2Rj#Ji`zlraKlVX*nP9TOTAOtJ!G(ad^AkC^hIP8=?o7LFzpb?@(RvO#y_T`f=Gj z#~f6Jy+kKdm`jIyO#e|RcF2x}Vu#EFN1XTm=JCP;6TF}z@0hfjQ=Vey;Qm!yo2>>? zwxi-X1nD5yG!1Ji4tXeY6YB#A$9@-~W^_;IW?MiBMk*ELDyRXIxO&W3u^4B$b$%s) z>*GxB70OJQS4s!C#_Ag}56KPI#`I>0IFA1CkXqTq15=#LF^59$ZvuqB`bna$`)7#y z$1>Jlp6A2a-htqYXHdQPO1MP!B(4Jddy5O$bO^eF*Z2Cw;`e)t{T@mwKI_FLTo1k8 z37Xua2_N&B0`&E;hwr#YkUhcmr+d9K>W3a^ORGhig$Gn&kbD=9bp*aovr*T?)oHc;(Lw|CQFrs_t($YYf zEiEB4gndQP(xvBT0qJm)dCHHwcbxgoQM3T-U=xm^Mbay<-zV%vcFj+`tStv|sv3RLgQY`QU6)ah1J&NV?*o>1bejFKfcL)%E<|F%NTFlgb08H#Q z04_ys{uG-Kc#4FiAjGyFLzgtlD4hd{Lir^CD)R~5xPhasRY_Fmxc>Uu$}jYy5K%OI zqqp>Y{598GYu8e>xa<}kGJ<8hNU;}n2XtiR?e&&0QEP9NUq%ibL>^DRr2&Aj^USE8 zaH=Lmg`Pw;_FOXHA5T_)-nb!cEY80SmW2YeJRk?2H0JltRt_g&0))?tZ(w;=w5+k# z(I(c$ieQz5r4GEvS8D6;!ybB;Rj+SboIGZ3${madUN=vlJp-Axo6Nt7#934&4#nBT zgZ|mYrCX%QI&4RTUn(nd=v%RIt4JPu(p`zvJ_6z^HE=KDYb0sF2f#O*6-MKim|)Jk zOi}c_GcSPfxu1LD68k5)t3PP#*pmA^Tbo6J18cd$fI|(gC00tic8veoy%} z$p^%T5=_C0l_JjG90Edg(x|=pSl0qcMYjDU)}l@s9~&f*B&>4%E`^&8%QQ+-Q7S>+ zqppV$si)l`fbivuWIM>98GG2Fv|(4WXt#{^y&y=(;Ty0GzSiR#7 zU$L-vaYxr9ROXmA4=U^gFx~>vqJP+xN?yEg)18z!g^|5rri8Rmg(Az6V)22%>`7z* zkBR00VeKcT%e#}_u&v^LF3^sDO+kevgwQVV^Aw@+l}6fRjJ(*`bux=tIYfpsu|_qI zn=}(;RFiRjn_XN1l>Pz)CqmJl zE%d8Aib1f#zYwnGBr`DiqJ$?JDzq&^Z8$t-*+3@m4#n!Yx_AGIbc7=FG+%EIcJ6|p z*fqi+RXJ%@Zol!q7ZBSn^oq%T@zsX0e2M7TYM4_NtG_qF2sENIwT#xv^^8n| z@`opBZ+}BE8?1%hXwQ}Ep@p`7-LQ}c>Pycmxz$e3>&3N6y9R3BkG-J&voZ4Qi=zrY zv!sqF8byX{$Pab$EEdR2Q?M+p+zX;X(d7fs8}@!~YD4f+uxEvC6gn<0v9V6H2yDs0 z6?aJ>L;RN`UQ`ONc}Wl$a{(@Wo!2l%@__%83L`4;>4-4R8R$uYPfkTnX>DWKjNy4KqX0 z4ugorcV>^a2aAv=g-Ov-U|-YNiI*iFwHrUh$19F%UAw^^+n30Z#tMrkKdy%vb>KS~ z!?jORx=Nph#pT#IHYE^S0&=3bv3n#OH-n@kUSBJFvWS=r5Z=Bv@!F9o!BdkrXvu!M ztW=V*MRugM$1-Vs8#vOar#e9ZCp7giucsF{BL~a^!`&Hx*2&Zv$B<_15E4kwlfY3qke9i`AS!o0 zrSLN8vmg&T2!%i#Qa(zTD02k?Fz2V@5{EQA1y=#W-#xplpc@IgCQsC*&=sS{2?rZz`D|@#+a@PSg4Hv*FYLfb`K~}+ z8{yqb;WeTk&}@jFb0PLI*?1Dj^BF++y^l_KPqa-D##A6+HS3oY@+~b$T;4oT#-R z5dPu!Ct$)8A9YH`B+u;QYUbjPIt4^0QNl@+$PjSgNS@=bhbl`?P?ZqKs%m*Ad8|gO zq(*Dv{AUHrhyL>>t_7--V1lB*YbswXI#|boYw?9*Xuo(v{Xk27k zAZ|}?xVIh<8jDsk%z`sZ1qCt^}B z<>X$9S*ei4>pKAR(f$s~SX4X&#ya6bQu<>u;mt)R()|Sq%j!ac$Qq)j4wzJE+#hA^ zet{k!QSM|c0kOLj9}NqZdI5s=F-VJC`{HBD`QmF(fYH!b2RiyYw|p9E*nhYrh_1}ZR`ZH9Y#G&TRqz*u#IhG5(JnI3s+_zA2;1LU)s=rT^;rwC z^+Zt!+!KKi01#a&Op2*{7181v?Ez3b0N*JhI3VPbzH%p>$rif?Sahx5Wb6jVs-?50 zClcf7AA}U=LnX1ONG38%NO>vz33)jcfbzuG0|A6jeI+0VX_c@UKRVQ~V=S52P3ggx z;}}#8iR6Zf%3;+S2pzkI2$JJj_0}nqmZ{o=9L>8Hv?3%#T*amqc1wRJd6NPrma$ip zl|WBU05m|?{VE&i0oQMiP#7q}u5Vrf2;coPS6R^BhnG<3DM=^;E5iFhc?jU^NP4{| z_m8`Zppzhq^5HDi6rbarq14xrea6tS8$s0N)<4J)qqsmuO&Cp?Wxp25kl96LZ(3PP z5f^2r6B63&5K_2!q+M~;IU>0rqo?~sY*#6mMIw`&a2>n|vu4=2)vxTsS?u_+xft@8l2=M!c}dt zoz=NLx~Y4orXP?ezM)TXV=+&F@H=0XPfIA2fUP*FzZ>VB>+nyGbnwij;F+RX!V!H< zU$X>`5?w1k(63*aNO9Nqj?MvTrb_l`xa&m~;WGvn=1NcMGzzB%XI)CpTFafLDv+(J#EujNnM z_Y%vk7V6U`0ktR+&G|K@Zph`bKF0YbA+uBz3%5_{-u9c^uoOeFKvg$YL$$=` z9}VYSQ{3NTy>qlrS`OOI>O6qoH83LbcvC=&8)q&YMeigN+Qi_0xlMp)^QeU^f85zkhDiLOzx>Q^IQl z%}G^J>}5li3LZs~vZseBB&eo7ODrQ4fk}e>6RD3pF=*rb z$A~Mz@O!000O2Da{y~%cj4oY5G)d5V0zFFe*9u-HxEWUHmLPe6mLdU!qyItts^kqj zBnl}p+3Qj@xxh$i=lI6?u&hqp7}{X?PG$cPo?5IIdPy4B1z7%5pJP~%5lL^1(06nn zDUzJygi{iasMo~DlJO8jgyY}djS$i~AkzKRUn6ps@l3R+rQ#J|W^ll&CCa>!R*o?L zya5nC{kOd?5zc1l&5b*yrKD5D?_x&aQX3f&ZUBn5v0xXfMjT~bdgn~Cvk6YbCdVZx z=K+y8A(=s)wo|ngRL8d}F``VNS#&#rMxIpYKuhmU0P%0eZNj3^Mv$muW8y^=_hWSjpgj9B0mzhg62QNmIFLM$vrO>)irvYB2Vo8p^ zda2T!1HoDa;jS$j$W79wWncidCO7&mk7a9^2v$=%2MGW5W6TY-sWwrXSj{(`b}q3atn}mDOvQI6|~BEG{$>dMCC9t=L_=9!a4;fogM2z93If0 z|F-B}ot-!zA(NDEHsu75!?ue>NSo9g3a~p5MPz0y8p8m>pZ|1anJXR<3k6 z8)m}p60GKMx;%7G5v`a0m#V>(|8hiu0c%4Qssyn`NM*utqz_b^R2Ox<7TT6witQdS zC#O6I$bFtV5llsF4sEhfrz{BF{|GmF zSdb1oD}+M$$d4B&Tf5!}qa4LR;ZXVY3f8T(%SrGEazV*7f1|b&J+8AEb?9(X1FAG> z!1y#40)X(|bMWc+F%wLl=KGiq(q>Q@1ORM-va9S(2lH!`xxlal7`=S)6$K86t*GjO zc8D!ozs-OBC_-C3|MoT|W4VJ2CWFq=*BObcu>iutkH&zZHQKET=wa;Pm&PPAVz_B` zk>?F_279f1h|EJ$@C^=k<}G?R?xTscVHcF}sc&nm9&>;>{cLaD$1rWY3zCmqgc12R z>YL5r!F@}3hQ%g~*^117=B0$rUyh^9OS~B_E*Vo>v_IjplX$jag?fKIf0545fRNma@6aDR zZ;U^l@?@qHDkPsh6;j#|uS8ei(5;8ky6&$#E=od{qxc7ui9_qcNgBTIQWIld9N*!2 z-g7z9XFJ3n&e;%8eEY=@pWR2q41`04*Kx3eZug3*JLcG_Dt-?j9DN7RpKROdx0kD1 z5%X2?@rG!$nYKqlUX;Ah-j)(faMU?J3HVc>JpQ<2!3IC2PEGNC%i6vda7gh&^sB!h zNmgY8Q>>3kmJ6m%E-Wkngwvmh5Pu}uu+U3@;K$V+?CE&s_*0!7lpsEZJo!coiuzQM zd_~|6xn~+*cglinU?#s%-qQP|DJnBuH_6=@zAj6birrCvfuE)HT}(;yn9Rqgi5LCu zGyuZ>uP_(MbC)4uljhQiTJ&1u(o5V`BBU1~ac1TN<}`Wn2!6%3Cnr}6f`$--(yK$c zX78hkHOU0v^Wd#@3BuuE3fTdfM!Vu4QnFqdKGr>w$LenajpcVoDQmvQt7z7;x#>cI z_H*zhK=|P~O72_S*2jv-0+|lBulg?VXeH>swvHTs5F<-=ET+##kJAd*Tcr%f#=wV_ zsm1ctEw-#lLqv7H8s6P>zML&Kb3(nzBdBpif&aYCTcO#!RA!NoK^552hHN? zE3UKj+i%%L=soU`p((hXk%IUO;#x@-a4~8iwd8doCmN@EQ=ZJI{Ag2;*jj0pSOf0S$4Ea++j9nuwD77%OLWkxn#QxdYGi=7=S=cVZp0CU4M52v`IN zr{1}zi^=2`AbtL>WVG_uoYY^<_!Ywiv0m9ebRGMHSjc$D;QP>kY1>^BV#+q^^iPH!> zjZV3db3K}KUF;B1p64dFl~@xBvs{ctgQ-(ox>ez_5|E1xCT&_QZ{ft$SyBo}{%dmD z6rGxyCYg$oqx*F`fbi{`GMH4*d2zh4%}{QAg4|g3qOBTP;>q!L&Z{ql;-+i{Wl8F} zLZMyK%zS~l-`M{0^3})pCL6G+ zJH*$aG|LPn6Rd2FiSg?Fy$^lm*=-rlgs?g!6ejm6Wpfa-u_a?low9|C>|x@ldiEqr z%roQDTbSS^uMh)mnrv3f)=uPq-K+q(4$;Ig1<5zN=0r1GT(f-s%IoN0y1(WM;W#gB zJmCJCXZ~~D_t*U6hmRlcEmKsz`^C)4@Zo{(JGufRr3DI@G_3qJ^D=KJO|!?FmuIfX zWO;nJ?=SMj@m<*a-b1zF$?@CdN-6I6%KTlZ@5A15{$Jl*FVD_DSeSYFlL%Ksl1Mfl zywqc61n5Rcqk77Bj1JQ8PW;4g@&g8*{tYj4;_rRvJI{Y<;_O$UyG*@Y{G$aoKc=l( z^He*T(DrEDG;r(Y&9vq@mM$@s(~b^kqF?pkift4{2%$8kp}<( literal 0 HcmV?d00001 diff --git a/sources/MACHINEINDEPENDENT b/sources/MACHINEINDEPENDENT new file mode 100644 index 00000000..aface2ba --- /dev/null +++ b/sources/MACHINEINDEPENDENT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "27-Feb-91 18:30:38" |{DSK}sybalsky>3-BYTE-ATOM-CHANGES>MACHINEINDEPENDENT.;5| 76520 |changes| |to:| (VARS MACHINEINDEPENDENTCOMS) (FNS HASHOVERFLOW) |previous| |date:| "25-Feb-91 15:09:04" |{DSK}sybalsky>3-BYTE-ATOM-CHANGES>MACHINEINDEPENDENT.;3|) ; Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ; The following program was created in 1983 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 MACHINEINDEPENDENTCOMS) (RPAQQ MACHINEINDEPENDENTCOMS ((COMS (* \; " \"File loader\"") (FNS LOAD? FILESLOAD DOFILESLOAD FINDFILE-WITH-EXTENSIONS) (INITVARS (*COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT)))) (COMS (* \;  "random machine-independent utilities") (FNS DMPHASH HASHOVERFLOW) (DECLARE\: EVAL@COMPILE DONTCOPY (MACROS HASHOVERFLOW.ARRAYTEST HASHOVERFLOW.UPDATEARRAY)) (FNS BKBUFS CHANGENAME CHNGNM CLBUFS DEFINE FNS.PUTDEF EQMEMB EQUALN FNCHECK FNTYP1 LCSKIP MAPRINT MKLIST NAMEFIELD NLIST PRINTBELLS PROMPTCHAR RAISEP READFILE READLINE REMPROPLIST RESETBUFS TAB UNSAVED1 WRITEFILE CLOSE-AND-MAYBE-DELETE UNSAFE.TO.MODIFY) (VARS UNSAFE.TO.MODIFY.FNS) (COMS (* \;  "FILEDATE, for finding out the creation date of source files, from the compiled files.") (* |;;| "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD.") (FNS FILEDATE) (P (MOVD? 'NILL 'FASL-FILEDATE))) (P (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND)) (* \;  "used in FNS.PUTDEF before CMLUNDO loaded") ) (COMS (* \;  "Functions for retrieving and remembering FILEMAPs and file reader environments") (FNS FILEMAP \\PARSE-FILE-HEADER GET-ENVIRONMENT-AND-FILEMAP LOOKUP-ENVIRONMENT-AND-FILEMAP GET-FILEMAP-FROM-FILECREATED \\FILEMAP-HASHOVERFLOW FLUSHFILEMAPS LISPSOURCEFILEP GETFILEMAP PUTFILEMAP UPDATEFILEMAP PRINT-READER-ENVIRONMENT) (INITVARS (*FILEMAP-LIMIT* 20) (*FILEMAP-VERSIONS* 2) (*FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \\FILEMAP-HASHOVERFLOW) (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING.EQUAL)))) (DECLARE\: EVAL@COMPILE DONTCOPY (RECORDS FILEMAPHASH) (GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*))) (COMS (* * LVLPRINT) (FNS LVLPRINT LVLPRIN1 LVLPRIN2 LVLPRIN LVLPRIN0)) (COMS (* \; "used by PRINTOUT") (FNS FLUSHRIGHT PRINTPARA PRINTPARA1)) (COMS (* \; "SUBLIS and friends") (FNS SUBLIS SUBPAIR DSUBLIS)) (COMS (* * CONSTANTS) (FNS CONSTANTOK) (P (MOVD? 'EVQ 'CONSTANT) (MOVD? 'EVQ 'DEFERREDCONSTANT) (MOVD? 'EVQ 'LOADTIMECONSTANT))) (COMS (* * SCRATCHLIST) (PROP MACRO SCRATCHLIST ADDTOSCRATCHLIST) (PROP INFO SCRATCHLIST)) (GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 USERWORDS BELLS CLISPARRAY) (FNS NLAMBDA.ARGS) (DECLARE\: DONTEVAL@LOAD DOCOPY (* \;  "initialization of variables used in many places") (ADDVARS (CLISPARRAY) (CLISPFLG) (CTRLUFLG) (EDITCALLS) (EDITHISTORY) (EDITUNDOSAVES) (EDITUNDOSTATS) (GLOBALVARS) (LCASEFLG) (LISPXBUFS) (LISPXCOMS) (LISPXFNS) (LISPXHIST) (LISPXHISTORY) (LISPXPRINTFLG) (NOCLEARSTKLST) (NOFIXFNSLST) (NOFIXVARSLST) (P.A.STATS) (PROMPTCHARFORMS) (READBUF) (READBUFSOURCE) (REREADFLG) (RESETSTATE) (SPELLSTATS1)) (VARS (CHCONLST '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (CHCONLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (CHCONLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (CLEARSTKLST T) (CLISPTRANFLG 'CLISP\ ) (HISTSTR0 "") (HISTSTR2 "repeat") (HISTSTR3 "from event:") (HISTSTR4 "ignore") (LISPXREADFN 'READ) (USEMAPFLG T)) (P (MAPC '((APPLY BLKAPPLY) (SETTOPVAL SETATOMVAL) (GETTOPVAL GETATOMVAL) (APPLY* BLKAPPLY*) (RPLACA FRPLACA) (RPLACD FRPLACD) (STKNTH FSTKNTH) (STKNAME FSTKNAME) (CHARACTER FCHARACTER) (STKARG FSTKARG) (CHCON DCHCON) (UNPACK DUNPACK) (ADDPROP /ADDPROP) (ATTACH /ATTACH) (DREMOVE /DREMOVE) (DSUBST /DSUBST) (NCONC /NCONC) (NCONC1 /NCONC1) (PUT /PUT) (PUTPROP /PUTPROP) (PUTD /PUTD) (REMPROP /REMPROP) (RPLACA /RPLACA) (RPLACD /RPLACD) (SET /SET) (SETATOMVAL /SETATOMVAL) (SETTOPVAL /SETTOPVAL) (SETPROPLIST /SETPROPLIST) (SET SAVESET) (PRINT LISPXPRINT) (PRIN1 LISPXPRIN1) (PRIN2 LISPXPRIN2) (SPACES LISPXSPACES) (TAB LISPXTAB) (TERPRI LISPXTERPRI) (PRINT SHOWPRINT) (PRIN2 SHOWPRIN2) (PUTHASH /PUTHASH) '* (FNCLOSER /FNCLOSER) (FNCLOSERA /FNCLOSERA) (FNCLOSERD /FNCLOSERD) (EVQ DELFILE) (NILL SMASHFILECOMS) (PUTASSOC /PUTASSOC) (LISTPUT1 PUTL) (NILL I.S.OPR) (NILL RESETUNDO) (NILL LISPXWATCH) 'ADDSTATS (NILL FREEVARS) 'USEDFREE (COPYBYTES COPYCHARS)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X))))) (MAPC '((TIME PRIN1 LISPXPRIN1) (TIME SPACES LISPXSPACES) (TIME PRINT LISPXPRINT) (DEFC PRINT LISPXPRINT) (DEFC PUTD /PUTD) (DEFC PUTPROP /PUTPROP) (DOLINK FNCLOSERD /FNCLOSERD) (DOLINK FNCLOSERA /FNCLOSERA) (DEFLIST PUTPROP /PUTPROP) (SAVEDEF1 PUTPROP /PUTPROP) (MKSWAPBLOCK PUTD /PUTD)) (FUNCTION (LAMBDA (X) (AND (CCODEP (CAR X)) (APPLY 'CHANGENAME X))))) (MAPC '((EVALQT (LAMBDA NIL (PROG (TEM) (RESETRESTORE NIL 'RESET) LP (PROMPTCHAR '_ T) (LISPX (LISPXREAD T T)) (GO LP)))) (LISPX (LAMBDA (LISPXX) (PRINT (AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) (RETURN (COND ((AND (NLISTP LISPXX) (SETQ LISPXLINE (READLINE T NIL T))) (APPLY LISPXX (CAR LISPXLINE ))) (T (EVAL LISPXX)))))) T T))) (LISPXREAD (LAMBDA (FILE RDTBL) (COND (READBUF (PROG1 (CAR READBUF) (SETQ READBUF (CDR READBUF)))) (T (READ FILE RDTBL))))) (LISPXREADP (LAMBDA (FLG) (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) T) (T (READP T FLG))))) (LISPXUNREAD (LAMBDA (LST) (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF))))) (LISPXREADBUF (LAMBDA (RDBUF) (PROG NIL LP (COND ((NLISTP RDBUF) (RETURN NIL)) ((EQ (CAR RDBUF) HISTSTR0) (SETQ RDBUF (CDR RDBUF)) (GO LP)) (T (RETURN RDBUF)))))) (LISPX/ (LAMBDA (X) X)) (LOWERCASE (LAMBDA (FLG) (PROG1 LCASEFLG (RAISE (NULL FLG)) (RPAQ LCASEFLG FLG)))) (FILEPOS (LAMBDA (STR FILE) (PROG NIL LP (COND ((EQ (PEEKC FILE) (NTHCHAR STR 1)) (RETURN T))) (READC FILE) (GO LP)))) (FILEPKGCOM (NLAMBDA NIL NIL))) (FUNCTION (LAMBDA (L) (OR (GETD (CAR L)) (PUTD (CAR L) (CADR L)))))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETBUFS DMPHASH FILESLOAD) (NLAML FILEMAP) (LAMA READFILE NLIST))) (LOCALVARS . T))) (* \; " \"File loader\"") (DEFINEQ (load? (lambda (file ldflg printflg) (* |lmm| " 2-Sep-85 13:15") (|bind| full |until| (setq full (findfile file)) |do| (setq file (lisperror "FILE NOT FOUND" file t)) |finally| (return (|if| (fmemb full loadedfilelst) |then| full |else| (let* ((root (rootfilename full)) (dates (getprop root (quote filedates))) (fileprop (getprop root (quote file)))) (|if| (and dates (|if| (eq (filenamefield full (quote extension)) compile.ext) |then| (and (or (null fileprop) (fmemb (cdar fileprop) (quote (|Compiled| compiled)))) (equal (caar dates) (filedate full t))) |else| (and fileprop (eq (cdar fileprop) t) (or (eq (cdar dates) full) (equal (caar dates) (filedate full)))))) |then| full |else| (load full ldflg printflg))))))) ) (filesload (nlambda files (* |lmm| "10-Dec-84 17:23") (* |;;| "Calls to this are written on files by the FILES command. This function does the load-time evaluation of the command.") (dofilesload (nlambda.args files))) ) (dofilesload (lambda (files) (declare (usedfree ldflg)) (* \; "Edited 4-May-88 14:23 by bvm") (* \; "does the work of FILESLOAD") (|for| file |inside| files |bind| dirs loadoptionsflg forcedext? noerrorflg word full (fn _ (quote load?)) (ext _ :compiled) |first| (cond ((boundp (quote ldflg)) (* |;;| "Under a load; give priority to directory of currently loading file. ") (let ((inputname (fullname *standard-input*))) (|if| (and (neq inputname *standard-input*) (neq inputname t)) |then| (* \; "If reading from terminal or nameless stream, don't do this.") (setq dirs (cons (packfilename.string (quote version) nil (quote name) nil (quote extension) nil (quote body) inputname) (cons t directories))) (setq loadoptionsflg ldflg))))) |join| (cond ((or (litatom file) (stringp file)) (* \; "A file to do something with") (prog nil (cond ((and (eq fn (quote load?)) (getprop (rootfilename file) (quote filedates))) (* \; "Already loaded") (return))) lp (cond ((setq full (selectq ext (nil (* \; "No extension to guide us") (findfile file t dirs)) (:compiled (* \; "Look for some sort of compiled file, or failing that a source") (or (findfile-with-extensions file dirs *compiled-extensions*) (and (not forcedext?) (findfile file t dirs)))) (progn (* \; "Look for explicitly supplied extension") (findfile (packfilename.string (quote body) file (quote extension) ext) t dirs))))) (noerrorflg (return)) ((and (setq file (cl:cerror "Forget about loading ~A" "File ~A not found~@[ on~{ ~A~}~]" file dirs)) (or (litatom file) (stringp file))) (* \; "User RETURNed a new file name") (go lp)) (t (* \; "if proceed from ERROR, blow off loading this file") (return))) (return (list (selectq fn (checkimports (* \; "LOADOPTIONSFLG has a different meaning for imports") (checkimports full t) full) (load? (* \; "already weeded out the ones with filedates") (load full loadoptionsflg)) (cl:funcall fn full loadoptionsflg)))))) (t (|while| (listp file) |do| (selectq (car file) (loadcomp (setqq fn loadcomp?) (setq loadoptionsflg nil) (setq ext nil)) (loadfrom (setqq fn loadfrom) (setq ext nil)) (from (|pop| file) (setq dirs (mklist (cond ((or (eq (setq word (car file)) (quote valueof)) (cond ((and (eq word (quote value)) (eq (cadr file) (quote of))) (|pop| file) t))) (|pop| file) (eval (car file))) ((and (selcharq (chcon1 word) (({ <) nil) t) (boundp (setq word (pack* word (quote directories)))) (setq word (evalv word))) (* \; "KLUDGE: Turns, e.g., (FROM LISPUSERS) into (FROM VALUEOF LISPUSERSDIRECTORIES)") word) (t (car file)))))) (compiled (setq forcedext? t) (setq ext :compiled)) (load (setqq fn load?)) ((extension ext) (setq file (listp (cdr file))) (setq ext (car file))) ((source symbolic) (setq ext nil)) (import (setqq fn checkimports) (setq ext nil)) (noerror (setq noerrorflg t)) (cond ((fmemb (car file) loadoptions) (setq loadoptionsflg (car file))) (t (* \; "invalid option in FILESLOAD") nil))) (|pop| file)) nil)))) ) (findfile-with-extensions (lambda (file dirlst extensions) (* \; "Edited 8-Dec-86 17:57 by bvm") (* |;;;| "Search for FILE on the directories contained in DIRLST, where NIL and T refer to the login and connected dirs, respectively. On each directory, prefer files having extension found in EXTENSIONS in the indicated order. If FILE already has an extension, EXTENSIONS is ignored; if FILE already has a host/dir, DIRLST is ignored.") (|if| file |then| (let ((fields (unpackfilename.string file)) dir&fields hasdirectory hasextension val) (|for| tail |on| fields |by| (cddr tail) |do| (selectq (car tail) (extension (setq hasextension t)) ((host device directory) (setq hasdirectory t)) nil)) (|if| hasdirectory |then| (* \; "Don't search dirs, just look where it says") (|if| hasextension |then| (infilep file) |else| (|for| ext |in| extensions |when| (setq val (infilep (packfilename.string (bquote (extension (\\\, ext) (\\\,@ fields)))))) |do| (return val))) |else| (|for| dir |inside| (|if| (null dirlst) |then| (* \; "If DIRLST is defaulted, always look first on connected dir.") (|if| directories |then| (cons t (remove t directories)) |else| t) |else| (* \; "use explicit DIRLST, ignoring connected dir unless it's on DIRECTORIES") dirlst) |when| (progn (setq dir&fields (selectq dir (nil (* \; "Login dir") (bquote (directory (\\\, (directoryname nil)) (\\\,@ fields)))) (t (* \; "Connected dir") fields) (bquote (directory (\\\, dir) (\\\,@ fields))))) (setq val (|if| hasextension |then| (infilep (packfilename.string dir&fields)) |else| (|for| ext |in| extensions |when| (setq val (infilep (packfilename.string (bquote (extension (\\\, ext) (\\\,@ dir&fields)))))) |do| (return val))))) |do| (return val)))))) ) ) (RPAQ? *COMPILED-EXTENSIONS* (LIST FASL.EXT COMPILE.EXT)) (* \; "random machine-independent utilities") (DEFINEQ (dmphash (nlambda l (* |rmk:| " 6-Apr-84 14:30") (mapc l (function (lambda (arrayname) (declare (specvars arrayname)) (ersetq (prog ((a (evalv arrayname (quote dmphash))) ap) (print (list (quote rpaq) arrayname (cond ((listp a) (setq ap (car a)) (list (quote cons) (list (quote harray) (harraysize ap) (kwote (harrayprop ap (quote overflow)))) (kwote (cdr a)))) (t (list (quote hasharray) (harraysize a) (kwote (harrayprop ap (quote overflow)))))))) (maphash (or ap a) (function (lambda (val item) (print (list (quote puthash) (kwote item) (kwote val) arrayname))))))))))) ) (HASHOVERFLOW (LAMBDA (HARRAY) (* \; "Edited 26-Feb-91 13:16 by jds") (* |;;| "Should be called from PUTHASH on hash overflow, but for implementations where PUTHASH calls ERRORX directly, may be called from ERRORX2 when the offender is a listp. HARRAY is guaranteed to be either HARRAYP or (LIST HARRAYP)") (PROG ((OLDARRAY (HASHOVERFLOW.ARRAYTEST HARRAY)) NEWARRAY NEWSIZE OLDNUMKEYS OVACTION NEWOVFLW) (COND ((LISTP HARRAY) (SETQ OVACTION (CDR HARRAY)) (* |;;| "Get OVERFLOW method from original HARRAY since it would erroneously be ERROR if we got the method from the coerced OLDARRAY") (SETQ NEWOVFLW 'ERROR)) (T (SETQ OVACTION (SETQ NEWOVFLW (HARRAYPROP OLDARRAY 'OVERFLOW))))) (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) (* |;;| "Compute the new array size:") (SETQ NEWSIZE (SELECTQ OVACTION (NIL (* |;;| "SIZE*1.5 --- favor to bbn, since pdp-11 doesnt have floatng point, and LRSH on other systems might be faster than IQUOTIENT") (* |;;|  "[32749 IS THE BIGGEST PRIME < 32765, THE LIMIT ON ARRAY SIZES]") (IMAX (+ OLDNUMKEYS 3) (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) 1))))) (ERROR (|do| (ERRORX (LIST 26 HARRAY)))) (|if| (FLOATP OVACTION) |then| (IMAX (+ OLDNUMKEYS 3) (IMIN 32760 (FIXR (FTIMES OLDNUMKEYS OVACTION)))) |elseif| (FIXP OVACTION) |then| (IMAX (+ OLDNUMKEYS 3) (IMIN 32749 (+ OLDNUMKEYS OVACTION))) |elseif| (AND (FNTYP OVACTION) (NUMBERP (SETQ OVACTION (APPLY* OVACTION HARRAY)))) |then| (|if| (FLOATP OVACTION) |then| (* \;  "recompute NUMKEYS since OVACTION might have removed keys") (IMAX (+ (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) 3) (IMIN 32749 (FIXR (FTIMES OLDNUMKEYS OVACTION)))) |else| OVACTION) |else| (* \; "Default: multiply by 1.5") (SETQ OLDNUMKEYS (HARRAYPROP OLDARRAY 'NUMKEYS)) (IMAX (+ OLDNUMKEYS 3) (IMIN 32749 (+ OLDNUMKEYS (LRSH (CL:1+ OLDNUMKEYS) 1))))))) (SETQ NEWARRAY (REHASH OLDARRAY (HASHARRAY NEWSIZE NEWOVFLW (HARRAYPROP OLDARRAY 'HASHBITSFN) (HARRAYPROP OLDARRAY 'EQUIVFN)))) (HASHOVERFLOW.UPDATEARRAY HARRAY NEWARRAY OLDARRAY) (RETURN HARRAY)))) ) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (PROGN (PUTPROPS HASHOVERFLOW.ARRAYTEST MACRO ((HARRAY) (CAR (OR (LISTP HARRAY) (ERRORX (LIST 27 HARRAY)))))) (PUTPROPS HASHOVERFLOW.ARRAYTEST DMACRO ((HARRAY) (\\DTEST HARRAY 'HARRAYP)))) (PROGN (PUTPROPS HASHOVERFLOW.UPDATEARRAY MACRO ((HARRAY NEWARRAY OLDARRAY) (FRPLACA HARRAY NEWARRAY))) (PUTPROPS HASHOVERFLOW.UPDATEARRAY DMACRO ((HARRAY NEWARRAY OLDARRAY) (\\COPYHARRAYP NEWARRAY OLDARRAY)))) ) ) (DEFINEQ (bkbufs (lambda (bufs id) (* dd\: " 6-Oct-81 15:34") (prog (l s) (cond ((nlistp bufs) (return)) (t (setq l (car bufs)) (setq s (cdr bufs)))) (cond ((readp t) (* |;;| "User types ahead before command causing buffer to be restored was executed. In this case, his type-ahead would come BEFORE the restored buffer, when it should be after it, because the command causing the buffer to be restored had to have been given before the type-ahead.") (printbells) (dobe) (clearbuf t t) (bksysbuf s) (bksysbuf (sysbuf t)) (sysbuf)) (s (bksysbuf s))) (cond (l (and id (prin1 id t)) (* |;;| "ID will be suppressed by LISPX to prevent it being typed in middle of input. Note that anything put back in SYSBUF will be printed (echoed) as it is read.") (prin1 l t) (bklinbuf l))) (return))) ) (changename (lambda (fn from to) (* |wt:| "18-SEP-78 21:29") (cond ((changename1 (getd fn) from to fn) (and filepkgflg (exprp fn) (markaschanged fn (quote fns))) fn))) ) (chngnm (lambda (fn old flg) (prog (new def x y z) (setq fn (fncheck fn nil t)) (* \; "No error, becuase maybe OLD isnt defined yet, e.g. BREAK ((FOO IN FUM)) where FOO not defined.") (setq old (or (fncheck old t t) old)) (setq def (getd (or (getp fn (quote advised)) (getp fn (quote broken)) fn))) (setq new (pack (list old (quote -in-) fn))) (cond (flg (and (null (stkpos new)) (/putd new)) (cond ((setq z (/dremove old (getp fn (quote nameschanged)))) (/put fn (quote nameschanged) z)) (t (/remprop fn (quote nameschanged)))) (/remprop new (quote alias)) (setq y old) (setq x new)) (t (setq y new) (setq x old) (cond ((and (memb old (getp fn (quote nameschanged))) (getd new) (getp new (quote alias))) (return new))))) (cond ((null def) (return (cons def (quote (|not| |defined|))))) ((null (resetvars ((nolinkmess t)) (return (changename1 def x y fn)))) (return (cons x (append (quote (|not| |found| |in|)) (list fn)))))) (cond ((null flg) (cond ((null (setq def (getd old))) (setq def (list (quote nlambda) (gensym))) (print (cons old (quote (|was| |undefined|))) t t))) (/putd new (saved old nil def old)) (/addprop fn (quote nameschanged) old) (/put new (quote alias) (cons fn old)))) (return y))) ) (clbufs (lambda (noclearflg notypeflg buf) (* \; "wt: 10-MAR-77 21 5") (* |;;| "NOCLEARFLG=T means CLEARBUF has already been done, and anything in the buffer now is type-ahead, e.g. calls from EVALQT, and call from BREAK on control-h INTERRUPT.") (* |;;| "NOTYPEFLG=T means user should not be typing ahead. If READP is T, warn him to stop and wait. Occurs when CLBUFS is being done BEFORE some action, e.g. DWIM interaction, loading SYSBUF for EXEC commands, etc. as opposed to AFTER some action, e.g. an error occurred.") (prog (lbuf sbuf) (cond (noclearflg (go skip)) ((and notypeflg (readp t)) (printbells) (dobe))) (clearbuf t t) (setq readbuf buf) skip (setq ctrluflg nil) (* \; "In case user control-e's or control-d's after typing control-u and changing his mind.") (setq lbuf (linbuf t)) (setq sbuf (sysbuf t)) (linbuf) (sysbuf) (cond ((strequal lbuf (quote " ")) (setq lbuf nil))) (return (cond ((or sbuf lbuf) (cons lbuf sbuf))))))) (define (lambda (x type-in) (* |mpl| "15-Jul-85 11:22") (mapcar x (function (lambda (x) (cond ((nlistp x) (error (quote "incorrect defining form") x))) (fns.putdef (car x) (quote fns) (cond ((null (cddr x)) (cadr x)) (t (cons (quote lambda) (cdr x)))) (|if| type-in |then| (quote defined) |else| (quote load))))))) ) (fns.putdef (lambda (name type definition reason) (* \; "Edited 20-Nov-87 14:24 by woz") (prog nil (|if| (or (and definition (nlistp definition)) (not (fmemb (car definition) lambdasplst))) |then| (error definition "Illegal function definition")) (selectq dfnflg ((nil t) (|if| (unsafe.to.modify name "redefine") |then| (error name " not redefined" t))) nil) (|if| (eq reason (quote defined)) |then| (* |;;| "woz: i think this test is wrong; what about CHANGED? SEdit special cases FNS in sedit::completion, and calls FIXEDITDATE directly, but shouldn't have to.") (fixeditdate definition)) (if (and (hasdef name (quote functions)) (neq (car definition) (quote nlambda))) then (* \; "For a while, we can't prevent the use of both a DEFMACRO and NLAMBDA for the same name.") (deldef name (quote functions))) (cond ((or (null dfnflg) (eq dfnflg t)) (cond ((getd name) (virginfn name t) (* |;;| "((EQUAL DEFINITION (GETD NAME)) (RETURN NAME)) Used to be part of the following COND. ripped out because editing out of the function cell wasn't completing fully.") (cond ((null dfnflg) (progn (* \; "if EXEC-FORMAT existed earlier, I'd use it") (lispxprin1 "New fns definition for " t) (lispxprin2 name t) (lispxprin1 ". " t)) (savedef name))))) (cond (addspellflg (addspell name))) (undoably-setf (cl:symbol-function name) definition) (* |;;| "Removed: (REMPROP NAME 'EXPR) because it wasn't saving the definition where UNSAVEDEF could find it.")) (t (* \; "DFNFLG is PROP or ALLPROP. However, treat anything else the same as PROP.") (and addspellflg (addspell name 0)) (cl:unless (eq definition (getd name)) (* |;;| "woz: don't want to have an EXPR property if have the definition in the function cell, so be careful here.") (cl:when (and (or (null reason) (eq reason (quote changed))) (eq definition (getprop name (quote expr)))) (* |;;| "editing a definition out of the saved EXPR property, and since DFNFLG is PROP, let the user know not installed") (lispxprin1 "New fns definition for " t) (lispxprin2 name t) (lispxprin1 " (but not installed). " t)) (/putprop name (quote expr) definition)))) (cond (filepkgflg (markaschanged name (quote fns) reason))) (return name))) ) (eqmemb (lambda (x y) (* |lmm:| 17 apr 75 305) (or (eq x y) (and (listp y) (fmemb x y) t)))) (equaln (lambda (x y depth) (* |wt:| "12-JUN-80 10:57") (* |;;| "like EQUAL but stops, returning T, if depth of car recursion plus depth of cdr recursion ever exceeds DEPTH.") (cond ((eq x y)) ((nlistp x) (cond ((numberp x) (and (numberp y) (eqp x y))) ((stringp x) (strequal x y)) ((stackp x) (eqp x y)))) ((nlistp y) nil) ((and depth (ilessp depth 1)) (quote ?)) (t (selectq (equaln (car x) (car y) (and depth (setq depth (sub1 depth)))) (? (quote ?)) (t (equaln (cdr x) (cdr y) depth)) nil)))) ) (fncheck (lambda (fn noerrorflg spellflg propflg tail) (* |bvm:| "30-OCT-83 21:59") (prog (x block block/fn) top (cond ((not (litatom fn)) (go error)) ((getd fn)) ((getp fn (quote expr)) (and (null propflg) (go error))) ((null dwimflg) (go error)) ((and (car (nlsetq (setq x (or (misspelled? fn 70 userwords spellflg tail (function getd)) (misspelled? fn 70 spellings2 spellflg tail))))) (neq x fn)) (setq fn x) (go top)) ((and (eq (systemtype) (quote d)) (|for| fl |in| (whereis fn) |thereis| (|for| file |inside| (or (getp fl (quote filegroup)) fl) |thereis| (setq block (|find| b |in| (filecomslst file (quote blocks)) |suchthat| (and (car x) (memb fn block)))))) (getd (setq block/fn (pack* (quote \\) (car block) (quote /) fn)))) (* |;;| "In Interlisp-D, get actual name of internal block fn. This is a little odd, since in a truly block-compiled system you couldn't get at the subfns") (setq fn block/fn)) (t (go error))) (and addspellflg (addspell fn 0)) (return fn) error (cond (noerrorflg (return nil))) (setq fn (error fn (quote "not a function") (null (relstk (or (stkpos (quote load)) (stkpos (quote loadfrom))))))) (go top))) ) (fntyp1 (lambda (x) (and clisparray (setq x (gethash x clisparray)) (fntyp x)))) (lcskip (lambda (fn flg) (* |bvm:| "24-Oct-86 17:09") (* |;;| "Skip or copy FN, FLG T to copy") (prog (len la) (|if| (eq (peekccode) (charcode space)) |then| (cond ((eq (setq la (read)) (quote binary)) (return (binskip fn flg nil nil la))) ((setq len (getprop la (quote codereader))) (* \; "Peter's hook for interfacing byte compiler.") (return (apply* (cdr len) fn flg nil nil la))))) (error "Bad or incompatible compiled function" fn))) ) (maprint (lambda (lst file left right sep pfn lspxprntflg) (* |wt:| 15-sep-77 15 43) (resetvars ((lispxprintflg lspxprntflg)) (cond ((null pfn) (setq pfn (function lispxprin1)))) (cond ((null sep) (setq sep (quote \ )))) (cond (left (lispxprin1 left file))) (cond ((nlistp lst) (go exit))) lp (apply* pfn (car lst) file) (cond ((null (setq lst (cdr lst))) (go exit)) ((nlistp lst) (lispxprin1 (quote " . ") file) (apply* pfn lst file) (go exit))) (lispxprin1 sep file) (go lp) exit (cond (right (lispxprin1 right file))))) ) (mklist (lambda (x) (* |lmm:| 21 aug 75 428) (and x (or (listp x) (list x))))) (namefield (lambda (file suffixflg dirflg) (* \; "Edited 5-Dec-90 22:32 by nm") (* |;;| "IF SUFFIXFLG is T, returns name and suffix field, otherwise just NAMEFIELD") (let ((str (cond ((eq dirflg (quote only)) (unpackfilename.string file (quote directory))) ((eq suffixflg (quote only)) (unpackfilename.string file (quote extension))) ((and (null suffixflg) (null dirflg)) (unpackfilename.string file (quote name))) (t (* |;;| "The general case. EXTENSION is fairly icky because UNPACKFILENAME.STRING behaves differently than UNPACKFILENAME, in that it returns a null string instead of NIL for extensionless files") (packfilename.string (quote directory) (and dirflg (unpackfilename.string file (quote directory))) (quote name) (unpackfilename.string file (quote name)) (quote extension) (and suffixflg (setq suffixflg (unpackfilename.string file (quote extension))) (> (nchars suffixflg) 0) suffixflg)))))) (* |;;| "Should not assume the case insensitive file system") (* \| "(if (NOT (U-CASEP STR)) then (SETQ STR (U-CASE STR)))") (mkatom str))) ) (nlist (lambda n (* |bvm:| "14-Feb-85 23:48") (prog (v (i n)) lp (cond ((eq i 0) (return v)) ((or v (arg n i)) (setq v (cons (arg n i) v)))) (setq i (sub1 i)) (go lp))) ) (printbells (lambda nil (* |wt:| 10-mar-77 21 15) (prin3 bells t))) (promptchar (lambda (id flg history) (declare (specvars id history promptstr)) (* |lmm| " 9-Jun-85 20:53") (* |;;| "First checks READBUF, and strips off any leading pseudo-carriage rettursn, and computes the new readbuf for repeated operations. If following this, READBUF is not NIL, never prints ID. Otherwise prints ID if FLG is T, or if READP is NIL. FLG is T for calls from EVALQT and BREAK, NIL from editor.") (prog (n mod promptstr) (cond (flg (and readbuf (setq readbuf (lispxreadbuf readbuf)) (return nil)) (* \; "redoing an event")) ((lispxreadp) (* \; "LISPXREADP returns T if there is anything on this line, but returns NIL if just a c.r.") (return nil))) (cond ((and history prompt#flg) (setq promptstr (cond ((igreaterp (setq n (add1 (cadr history))) (setq mod (or (cadddr history) 100))) (* \; "This event is the roll-over event.") (idifference n mod)) (t n))))) (cond (promptcharforms (* |;;| "gives user a hook for operations to be performed each event, e.g. monitoring functions, checking if typescript window is up etc. also these forms can change what is printed by resetting promptstr and / or id") (mapc promptcharforms (function (lambda (x) (ersetq (eval x))))))) (and promptstr (prin2 promptstr t)) (and id (prin1 id t)))) ) (raisep (lambda (ttbl) (* |wt:| 1-aug-77 14 15) (* |;;| "True if lisp is in mode where it raises lower case inputs to uppercase.") (cond ((raise nil ttbl) (raise t ttbl) t))) ) (readfile (cl:lambda (file &optional rdtbl (endtoken (quote stop)) package) (declare (globalvars loadparameters)) (* \; "Edited 20-Jan-87 16:22 by bvm:") (with-reader-environment *old-interlisp-read-environment* (resetlst (resetsave nil (list (quote closef?) (setq file (openstream file (quote input) nil nil loadparameters)))) (if (eq (skipseprcodes file) (charcode ";")) then (setq *readtable* cmlrdtbl) (setq *package* (cl:find-package "USER"))) (|if| rdtbl |then| (setq *readtable* (\\dtest rdtbl (quote readtablep)))) (|if| package |then| (setq *package* (\\dtest package (quote package)))) (let ((eoftoken "eof") env tem helpclock) (declare (specvars helpclock)) (cl:values (|until| (or (eq (setq tem (cl:read file nil eoftoken)) eoftoken) (eq tem endtoken)) |collect| (|if| (eq (car tem) (quote define-file-info)) |then| (* \; "have to eval this to get the reader environment right for the rest of the file") (set-reader-environment (setq env (\\do-define-file-info file (cdr tem))))) tem) env))))) ) (readline (lambda (rdtbl line lispxflg) (* ajb " 1-Aug-85 14:50") (declare (specvars line lispxflg spaceflg)) (prog ((fl t) tem spaceflg chrcode start) top (cond ((listp readbuf) (go lp2)) ((null (readp t)) (clearbuf t) (* |;;| "This is in case there is a c.r. in the single character buffer. Note that if there were other atoms on the line terminated by a c.r., after readline finished, the c.r. would be gone. Thus this check for consistency.") (return line))) lp (setq spaceflg nil) lp1 (cond ((syntaxp (setq chrcode (chcon1 (setq tem (peekc fl (or rdtbl t))))) (quote eol)) (* \; "C.R.") (readc fl) (cond ((and line spaceflg) (and (eq fl t) (prin1 (quote |...|) t)) (go lp)) (t (go out)))) ((or (syntaxp chrcode (quote rightparen) rdtbl) (syntaxp chrcode (quote rightbracket) rdtbl)) (read fl rdtbl) (and lispxflg (null (cdr line)) (setq line (nconc1 line nil))) (* |;;| "The `]' is treated as NIL if it is the only thing on the line when READLINE is called with LISPXFLG=T. The reason for CDR is that LISPX calls readline giving it the initial atom on the line.") (go out)) ((and (eq chrcode (charcode space)) (syntaxp chrcode (quote sepr) rdtbl)) (* \; "SPACE the syntaxp check is to allow for space being a read macro") (setq spaceflg t) (readc fl) (go lp1))) (setq tem (cond ((or (eq lispxreadfn (quote read)) (imagestreamtypep t (quote text))) (* \; "So the call will be linked, so the user can break on read.") (* \; "TEXTSTREAMS must use READ") (read fl rdtbl)) (t (apply* lispxreadfn fl rdtbl)))) (* |;;| "The reason for not embedding the setq in the ncon1 is that the act of reading may change L, e.g. via a ^W read macro.") (cond ((eq tem histstr4) (* |;;| "fo implemeing read macros that are for effect only. ignore the value returned by read. if we had soft interrupts from iowaits, we wouldnt needs this.") (go lp1))) (setq line (nconc1 line tem)) (cond ((syntaxp (setq tem (chcon1 (lastc fl))) (quote rightbracket) rdtbl) (* |;;| "The reason why readline is driven by the last character insead of doing a peekc before reding is that due to eadmacros, it is possible for several things to be read, e.g. A B C '(FOO) terminated by square bracket should terminate the line. However, it is not sufficient just to check whether the value read is a list or not since `()' and NIL must also be treated differently.") (go out)) ((null (syntaxp tem (quote rightparen) rdtbl)) (go lp)) ((and lispxflg (null spaceflg) (null (cddr line))) (* |;;| "A list terminates the line if if called from LISPX and is both the firt thing on a line and not preceded by a space.") (go out)) (t (and (eq fl t) (prin1 (quote |...|) t)) (go lp))) (go lp) out (cond ((and (listp line) ctrluflg) (* \; "User typed control-u during reading.") (setq ctrluflg nil) (cond ((null (nlsetq (edite line))) (* \; "Exited with a STOP.") (setq rereadflg (quote abort)))))) (cond (start (cond ((neq start (cadadr readbuf)) (shouldnt)) (t (* \; "the rplaca is to handle small numbers") (rplaca (cdadr readbuf) (setn start (getfileptr fl))))) (setfileptr fl -1))) (return line) lp2 (cond ((eq (car readbuf) histstr0) (setq readbuf (cdr readbuf)) (return line)) ((null (setq readbuf (lispxreadbuf readbuf))) (* |;;| "checks for things like HISTSTR2 etc. this can occur if you redo an event contaiing a readline. can also occur under a break if you call a function which calls readline, because break unreads stuff, leaving the `from event' tag on.") (go top))) (setq tem readbuf) (setq readbuf (cdr readbuf)) (setq line (nconc1 line (car tem))) (cond ((null readbuf) (* |;;| "really shouldnt happen, as there should be a `' marker. however, in the case of a fix command, user might delete it.") (return line))) (go lp2))) ) (remproplist (lambda (atm props) (* \; "wt: 30-JUL-77 13 32") (prog (lst lst1 tem) (cond ((null (setq lst1 (setq lst (getproplist atm)))) (return nil))) lp (cond ((nlistp lst1) (go out)) ((not (fmemb (car lst1) props))) ((eq lst1 lst) (setq lst (cddr lst))) ((setq tem (cddr lst1)) (rplnode2 lst1 tem) (go lp)) (t (* \; "the last property, also not the first one.") (rplacd (nleft lst 1 lst1)) (go out))) (setq lst1 (cddr lst1)) (go lp) out (setproplist atm lst) (return))) ) (resetbufs (nlambda forms (* |lmm| " 9-APR-78 00:27") (declare (localvars . t)) (prog (($$bufs (progn (linbuf) (sysbuf) (clbufs nil t readbuf)))) (return (prog1 (apply (function progn) forms (quote internal)) (and $$bufs (bkbufs $$bufs)))))) ) (tab (lambda (pos minspaces file) (prog (x) (cond ((not (igreaterp (iplus (setq x (position file)) (or (numberp minspaces) 1)) pos)) (spaces (idifference pos x) file)) ((eq minspaces t) (* \; "MINSPACES=T means space over to POS unless you are already beyond it.")) (t (terpri file) (spaces pos file))))) ) (unsaved1 (lambda (fn typ) (* |bvm:| "29-Sep-86 23:24") (prog (def prop) top (cond ((not (litatom fn))) ((setq def (cond ((setq prop typ) (get fn typ)) ((get fn (setq prop (quote expr)))) ((get fn (setq prop (quote code)))) ((get fn (setq prop (quote subr)))))) (virginfn fn t) (/remprop fn prop) (cond ((neq dfnflg t) (savedef fn))) (/putd fn def t) (and addspellflg (addspell fn)) (return prop)) ((or (getd fn) (getproplist fn)) (* \; "Not a misspelling") (return (cond (typ (concat "(" typ " not found)")) (t "(nothing found)")))) ((setq prop (fncheck fn t)) (setq fn prop) (go top))) (error fn (quote "not a function")))) ) (writefile (lambda (x file) (* |bvm:| "30-Aug-86 16:45") (* |;;| "X is a list of expression (or an atom that evaluates to a list) X is written on FILE. If X begins with a PRINTDATE expression, a new one is written. Following the PRETTYDEF conventions, if FILE is listed, it is left open. Otherwise a stop is printed and it is closed.") (with-reader-environment *old-interlisp-read-environment* (resetlst (prog (stream opened) (cond ((listp file) (setq file (car file)) (setq opened t))) (resetsave nil (list (function close-and-maybe-delete) (setq stream (openstream file (quote output))))) (resetsave (output stream)) (cond ((atom x) (setq x (eval x)))) (prin1 " (PRIN1 (QUOTE \" WRITEFILE OF ") (prin2 (setq file (fullname stream))) (prin1 " MADE BY ") (prin1 (username)) (prin1 " ON ") (prin1 (date)) (prin1 " \")T) ") (|for| x1 |in| x |do| (printdef x1 nil (eq (car (listp x1)) (quote defineq))) (terpri)) (|if| (null opened) |then| (endfile)) (return file))))) ) (close-and-maybe-delete (lambda (stream) (* \; "Edited 19-Mar-87 16:43 by jrb:") (* |;;;| "For use in RESETSAVE. Closes STREAM, and if happened under error, deletes the file") (|if| (openp stream) |then| (setq stream (closef stream))) (and resetstate (delfile stream))) ) (unsafe.to.modify (lambda (fn option) (* |lmm| "31-Jul-85 02:06") (|if| (fmemb fn unsafe.to.modify.fns) |then| (printout t "Warning: " fn " may be unsafe to " (or option "modify") " -- continue? ") (|if| (eq (|if| (getd (quote askuser)) |then| (askuser dwimwait (quote n)) |else| (read t)) (quote y)) |then| nil |else| t))) ) ) (RPAQQ UNSAFE.TO.MODIFY.FNS (/PUT /PUTD /REMPROP ADDCHAR ADDCHAR ADDSPELL ADVISEWDS ALLOCSTRING APPLY APPLY ASSOC AWAIT.EVENT BITBLT.ERASE BITMAPCOPY BITMAPCREATE BKBITBLT BLOCK BLOCK BLTCHAR BLTCHAR BLTSHADE BREAK BREAK0 BREAK1 CHARSET CHCON1 CLEAR.LINE? CLOCK CLOCKDIFFERENCE CLOSEW CONCAT CREATEW CURSOR CURSORHOTSPOT DELETETO DO.CRLF DRAWLINE DSPBACKUP DSPCLIPPINGREGION DSPCLIPPINGREGION DSPCREATE DSPDESTINATION DSPFILL DSPFONT DSPLEFTMARGIN DSPRIGHTMARGIN DSPSCROLL DSPSOURCETYPE DSPXOFFSET DSPXPOSITION DSPYPOSITION EQLENGTH EQP EQUAL ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE ERRORMESS1 ERRORSET EVAL EVALQT EXPRP FASSOC FILENAMEFIELD FIXR FLIPCURSOR FLAST FMEMB GENSYM GETHASH GETMOUSESTATE GETPROP GETSTREAM GETWINDOWUSERPROP HELP HISTORYSAVE IDATE IMAGESTREAMTYPEP IMOD INIT.CURSOR INTEGERLENGTH INTERRUPTABLE INTERSECTREGIONS IREMAINDER LAST LASTC LISPX LISPX/ LISPXFIND LISPXFIND1 LISPXPRINT LISPXPUT LISPXPUT LISPXREAD LISPXREADBUF LISPXUNREAD LISTGET LISTPUT MEMB MKATOM MKSTRING MONITOR.AWAIT.EVENT MOVETOUPPERLEFT NOTIFY.EVENT NTH NTHCHARCODE OBTAIN.MONITORLOCK OPENW OPENWP OVERFLOW? PACK* PAGEHEIGHT PRIN1 PRIN1 PRIN2 PRIN2 PRIN3 PRIN3 PRINT PRINT PRINTCCODE PRINTLEVEL PROGN PROMPTCHAR PUTWINDOWPROP QUOTE READ CL:READ READLINE READLINE READP REALSTKNTH REGIONP RELEASE.PUP RELSTK RESETRESTORE RESHOWTITLE RETFROM RPLCHARCODE RPLSTRING SETCURSOR SETTERMTABLE SHOWPRIN2 SHOWPRINT SHOWWFRAME SHOWWTITLE SKIPSEPRS SPACES STKPOS STREAMP SUBATOM SUBSTRING SYNTAXP TERPRI TIMEREXPIRED? TIMEREXPIRED? TOTOPW TTBIN TTBITWIDTH TTCRLF TTDELETELINE TTSKREAD TTWAITFORINPUT TTWAITFORINPUT TTYDISPLAYSTREAM TTYIN TTYIN.CLEANUP TTYIN.FINISH TTYIN.READ TTYIN.SETUP TTYIN1 TTYIN1RESTART TTYINREAD TYPENAME UNBREAK0 UNDOSAVE UNPACKFILENAME.STRING WFROMDS WINDOW.MOUSE.HANDLER)) (* \; "FILEDATE, for finding out the creation date of source files, from the compiled files.") (* |;;| "FASL isn't loaded when MACHINEINDEPENDENT is, so we have to fake the FASL checker for now. It's defined in FASLOAD." ) (DEFINEQ (filedate (lambda (file cflg) (* \; "Edited 17-Feb-89 11:26 by jds") (* \; "CFLG IS T FOR COMPILED FILES") (cond (file (car (nlsetq (resetlst (prog (stream oldptr value) (cond ((setq stream (openp file (quote input))) (setq oldptr (getfileptr stream))) (t (* \; "OPENSTREAM used instead of INFILEP to allow for error correction.") (resetsave nil (list (quote closef) (setq stream (openstream file (quote input))))))) (* |;;| "This code used to have some gross kludgery for checking file dates of grouped files during the loadup procedure, now gone -bvm") (cond ((randaccessp stream) (setfileptr stream 0) (cond ((setq value (fasl-filedate stream cflg)) (* |;;| " Aha, a Dfasl file") (* |;;| " Having decided it's a DFASL, FASL-FILEDATE returned the date, and it's in VALUE already.")) (t (* \; "Any other filetype") (setfileptr stream 0) (cl:multiple-value-bind (env form) (\\parse-file-header stream (quote return)) (cond ((and cflg (listp form)) (* \; "First expression is for compiled file, next one is its source") (setq form (with-reader-environment env (read stream))))) (cond ((eq (car (listp form)) (quote filecreated)) (setq value (car (listp (cdr form))))))))))) (cond (oldptr (setfileptr stream oldptr))) (return value)))))))) ) ) (MOVD? 'NILL 'FASL-FILEDATE) (MOVD? 'CL:FMAKUNBOUND 'UNDOABLY-FMAKUNBOUND) (* \; "used in FNS.PUTDEF before CMLUNDO loaded") (* \; "Functions for retrieving and remembering FILEMAPs and file reader environments") (DEFINEQ (filemap (nlambda (filemap) (* |bvm:| "27-Aug-86 23:41") (* |;;;| "Called by the FILEMAP expression at the end of every standard Interlisp file") (declare (usedfree filecreatedlst)) (* \; "FILECREATEDLST bound in LOAD or LOADFNS and set by FILECREATED") (putfilemap (fullname (getstream nil (quote input))) filemap filecreatedlst nil t)) ) (\\parse-file-header (lambda (stream filecreatedfn returnform initialenv) (* |bvm:| " 8-Sep-86 12:37") (* |;;;| "Parses the stuff at front of STREAM, which is assumed positioned at zero, and returns as its first value a reader environment for the file, or NIL if this is not a Lisp source file. If a FILECREATED expression is found, then calls FILECREATEDFN with the file pointer positioned immediately after the symbol FILECREATED, and returns the fn's value as its second value. FILECREATEDFN = RETURN returns the entire FILECREATED expression. Finally, in the case where no FILECREATED expression was found, returns as second value the actual first expression if RETURNFORM is true (this is needed for callers that don't want to lose when the stream is non-randaccess). The first expression on the file is read in the current reader environment. Usually this wants to be IL.") (with-reader-environment (or initialenv *old-interlisp-read-environment*) (selcharq (skipseprcodes stream) (";" (* \; "Assume is common lisp file") *common-lisp-read-environment*) ("(" (* \; "Start of Lisp expression, could be either DEFINE-FILE-INFO or FILECREATED") (prog (env firstsym result here) top (setq here (getfileptr stream)) (readccode stream) (setq firstsym (and (syntaxp (skipseprcodes stream) (quote other)) (ratom stream))) (cond ((and (eq firstsym (quote define-file-info)) (null env)) (setq env (\\do-define-file-info stream (cl:read-delimited-list (charcode ")") stream))) (cond ((and filecreatedfn (eq (skipseprcodes stream) (charcode "("))) (set-reader-environment env) (go top)) (t (* |;;| "Odd case--a DEFINE-FILE-INFO expression but no FILECREATED afterwards or caller doesn't want to see it") (return (cl:values env nil here)))))) (|if| (eq firstsym (quote filecreated)) |then| (or env (setq env *old-interlisp-read-environment*)) (setq result (selectq filecreatedfn (return (cons (quote filecreated) (cl:read-delimited-list (charcode ")") stream))) (nil nil) (cl:funcall filecreatedfn stream))) |elseif| returnform |then| (setq result (cl:read-delimited-list (charcode ")") stream))) (return (cl:values env result here)))) nil))) ) (get-environment-and-filemap (lambda (stream dontcache) (* |bvm:| "26-Sep-86 11:39") (* |;;| "Returns three values: the stream's reader environment, its filemap, either obtained from the file itself, or from its property list, and the byte location where the FILECREATED expression starts.") (let ((full (cond ((streamp stream) (fullname stream)) (t stream))) mapentry map env oldpos) (setq mapentry (gethash full *filemap-hash*)) (cond ((and mapentry (or (setq map (|fetch| fmfilemap |of| mapentry)) (null usemapflg))) (* |;;| "Have all we need. Return the map only if USEMAPFLG is true or the map was obtained by scanning the file") (|replace| fmrecent? |of| mapentry |with| t) (cl:values (|fetch| fmenvironment |of| mapentry) (and map (or usemapflg (not (|fetch| fmfromfile? |of| mapentry))) map) (|fetch| fmfilecreatedloc |of| mapentry) (|fetch| fmfilecreatedlst |of| mapentry))) ((or (not (setq stream (openp stream (quote input)))) (not (randaccessp stream))) (* \; "Out of luck") nil) (t (* \; "Have to read file") (setq oldpos (getfileptr stream)) (setfileptr stream 0) (cl:multiple-value-bind (env newmap fclocation) (\\parse-file-header stream (cond ((and (null map) usemapflg) (function get-filemap-from-filecreated)))) (setfileptr stream oldpos) (cond ((and newmap (not dontcache)) (putfilemap full newmap nil env t fclocation))) (cl:values env (or newmap map) fclocation)))))) ) (lookup-environment-and-filemap (lambda (full rootnamep) (* \; "Edited 4-May-88 15:30 by bvm") (* |;;| "Returns four values: the file's reader environment, its filemap, either obtained from the file itself, or from its property list, the byte location where the FILECREATED expression starts, and the FILECREATEDLST of the file (used by ADDFILE). Unlike GET-ENVIRONMENT-AND-FILEMAP, this function merely looks up cached info. If ROOTNAMEP is true, then FULLNAME is actually a root name, and we want to look up the most recent.") (let ((highest-version -1) mapentry) (|if| rootnamep |then| (maphash *filemap-hash* (function (lambda (entry key) (let (v) (|if| (and (strpos full key nil nil nil nil uppercasearray) (string-equal full (rootfilename key)) (igreaterp (setq v (or (filenamefield key (quote version)) 0)) highest-version)) |then| (setq mapentry entry) (setq highest-version v)))))) |else| (setq mapentry (gethash full *filemap-hash*))) (|if| mapentry |then| (|replace| fmrecent? |of| mapentry |with| t) (cl:values (|fetch| fmenvironment |of| mapentry) (|fetch| fmfilemap |of| mapentry) (|fetch| fmfilecreatedloc |of| mapentry) (|fetch| fmfilecreatedlst |of| mapentry))))) ) (get-filemap-from-filecreated (lambda (stream) (* |bvm:| "29-Aug-86 15:06") (* |;;| "get map from address shown in FILECREATED expression, which is of form (FILECREATED file date mapaddr)") (skread stream) (skread stream) (car (nlsetq (let ((mapaddr (read stream))) (cond ((and (fixp mapaddr) (lessp mapaddr (geteofptr stream)) (progn (setfileptr stream mapaddr) (eq (skipseprcodes stream) (charcode "("))) (eq (car (setq mapaddr (read stream))) (quote filemap))) (cadr mapaddr))))))) ) (\\filemap-hashoverflow (lambda (harray) (* |bvm:| "26-Sep-86 12:11") (* |;;;| "Called when *FILEMAP-HASH* overflows. Trim back old entries") (let ((numentries (harrayprop harray (quote numkeys))) entries) (|if| (> numentries *filemap-limit*) |then| (maphash harray (function (lambda (val key) (* \; "Gather up contents of table") (let ((root (|fetch| fmrootname |of| val)) tem) (|if| (not (setq tem (fassoc root entries))) |then| (|push| entries (setq tem (list root)))) (|push| (cdr tem) (cons (|if| (cdr (|fetch| fmfilecreatedlst |of| val)) |then| (* \; "compiled file, don't keep if there is no other reason to") 0 |else| (filenamefield key (quote version))) (cons key val))))))) (* |;;| "each element of ENTRIES is (root . versions), where each version is (vers# fullname . hashvalue)") (|for| group |in| entries |bind| onfilelst pair nflush dates |do| (setq onfilelst (memb (car group) filelst)) (setq nflush (- (length (cdr group)) *filemap-versions*)) (|for| tail |on| (progn (* \; "Sort files by increasing version") (sort (cdr group) t)) |as| i |from| 1 |do| (setq pair (cdar tail)) (|if| (and (<= i nflush) (or (null (setq dates (get (car group) (quote filedates)))) (not (string.equal (cdar dates) (car pair))))) |then| (* |;;| "flush old versions until we have gotten down to limit. The STRING.EQUAL test is because the \"current version\" of a file might have a lower version number (being on a different directory) than the highest version you have looked at anywhere") (remhash (car pair) harray) (|add| numentries -1) |elseif| (|fetch| fmrecent? |of| (cdr pair)) |then| (* \; "spare recently touched files, but clear the flag") (|replace| fmrecent? |of| (cdr pair) |with| nil) |elseif| (or (not onfilelst) (cdr tail)) |then| (* \; "trim maps not looked at recently, but spare the highest version of anything on filelst") (remhash (car pair) harray) (|add| numentries -1)))) (* |;;| "finally say how big to rehash the array. Normally we want it not to change size.") (imax *filemap-limit* (fixr (ftimes numentries 1.2)))))) ) (flushfilemaps (lambda (rootname) (* |bvm:| "26-Sep-86 11:37") (|if| (eq rootname t) |then| (clrhash *filemap-hash*) |else| (maphash *filemap-hash* (function (lambda (me fullname) (|if| (string-equal (|fetch| fmrootname |of| me) rootname) |then| (remhash fullname *filemap-hash*)))))) rootname) ) (lispsourcefilep (lambda (file) (* |bvm:| "29-Sep-86 23:15") (* |;;;| "If the first few characters of FILE `look like' those output by MAKEFILE then return the alleged address in the file of its FILEMAP expression.") (resetlst (|if| (not (streamp file)) |then| (resetsave nil (list (quote closef) (setq file (openstream file (quote input)))))) (|if| (randaccessp file) |then| (let ((here (getfileptr file))) (prog1 (cl:multiple-value-bind (env map) (\\parse-file-header file (function (lambda (stream) (* \; "Pointed now right after the FILECREATED expression") (car (nlsetq (skread stream) (skread stream) (fixp (read stream))))))) map) (setfileptr file here)))))) ) (getfilemap (lambda (stream fl) (* |bvm:| "27-Aug-86 15:48") (* |;;;| "Value is map for STREAM either obtained from the file itself, or from its property list. STREAM is presumed open. FL is (NAMEFIELD STREAM T)") (and usemapflg (cl:multiple-value-bind (env map) (get-environment-and-filemap stream) map))) ) (putfilemap (lambda (file filemap filcreatedlst env fromfile? fclocation) (* |bvm:| "26-Sep-86 11:51") (* \; "Called from: LOAD LOADFNS PRETTYDEF FILEMAP") (* |;;| "As far as I can tell, the only use for FILCREATEDLST is to tell ADDFILE in LOADFNS that the file is a compiled file") (|if| (null filemap) |then| (remhash file *filemap-hash*) |elseif| buildmapflg |then| (let* ((oldentry (gethash file *filemap-hash*)) (newentry (|create| filemaphash |using| oldentry fmfromfile? _ fromfile? fmrecent? _ t))) (|if| (null oldentry) |then| (|replace| fmrootname |of| newentry |with| (rootfilename file (cdr filcreatedlst)))) (|if| env |then| (|replace| fmenvironment |of| newentry |with| env) |elseif| (null oldentry) |then| (|replace| fmenvironment |of| newentry |with| (make-reader-environment))) (|if| (listp filemap) |then| (|replace| fmfilemap |of| newentry |with| filemap)) (|if| fclocation |then| (|replace| fmfilecreatedloc |of| newentry |with| fclocation)) (|if| filcreatedlst |then| (|replace| fmfilecreatedlst |of| newentry |with| filcreatedlst)) (puthash file newentry *filemap-hash*)))) ) (updatefilemap (lambda (stream filemap) (* |bvm:| "24-Oct-86 17:15") (* |;;;| "Writes new FILEMAP on file currently open as STREAM. If we return T, the stream has been closed. This has little hope of working any more.") (|if| nil |then| (* \; "This has little hope of working any more") (let ((declarestring (concat "(DECLARE: DONTCOPY " "(FILEMAP")) filemaplocadr tem filemapadr filemaploclen fullname) (setfileptr stream 0) (skipseprs stream) (* \; "Could be some font shifts or other garbage") (readc stream) (* \; "Skip paren or bracket") (|if| (and (eq (ratom stream) (quote filecreated)) (progn (skread stream) (* \; "Date") (skread stream) (* \; "Name") (|do| (cond ((eq (setq tem (readccode stream)) (charcode space)) (* \; "found a space") (return t)) ((not (syntaxp tem (quote seprchar))) (* \; "no spaces, lose") (return))))) (fixp (setq filemapadr (progn (* \; "skip over seprs") (setq filemaplocadr (getfileptr stream)) (* \; "Address of first character of file-map location") (prog1 (ratom stream) (setq filemaploclen (idifference (getfileptr stream) filemaplocadr)))))) (setq filemapadr (or (ffilepos declarestring stream (fix (times filemapadr 0.9))) (ffilepos declarestring stream 0))) (eq (progn (skread stream) (ratom stream)) (quote stop)) (ileq (nchars filemapadr t) filemaploclen)) |then| (* |;;| "normally, this will be called so that we are positioned at the filemap. --- check for (FILECREATED & & number --) first to avoid searching compiled files for filemap.") (setq fullname (closef stream)) (|if| (setq stream (car (nlsetq (openstream fullname (quote both) (quote old) nil (quote (don\'t.change.date)))))) |then| (resetlst (resetsave nil (list (quote closef) stream)) (setfileptr stream filemapadr) (prin3 "(DECLARE: DONTCOPY " stream) (setq filemapadr (getfileptr stream)) (prin3 "(FILEMAP " stream) (position stream (constant (nchars "(FILEMAP "))) (let ((*print-radix* 10)) (prin2 filemap stream)) (prin1 "))" stream) (terpri stream) (print (quote stop) stream) (setfileptr stream filemaplocadr) (printnum (list (quote fix) filemaploclen) filemapadr stream) (cond ((neq dfnflg t) (prin3 "****rewrote file map for " t) (print fullname t t))))) t)))) ) (print-reader-environment (lambda (env stream) (* |bvm:| "24-Oct-86 15:53") (* |;;;| "If ENV is not the old default interlisp reader environment, writes a DEFINE-FILE-INFO expression on STREAM that will produce this environment when the file is loaded.") (|if| (not (equal-reader-environment env *old-interlisp-read-environment*)) |then| (let ((*package* *interlisp-package*) (*print-base* 10) pkg) (print (cons (quote define-file-info) (or (|fetch| respec |of| env) (bquote ((\\\,@ (and (setq pkg (|fetch| repackage |of| env)) (bquote (:package (\\\, (cl:package-name pkg)))))) :readtable (\\\, (readtableprop (|fetch| rereadtable |of| env) (quote name))) :base (\\\, (|fetch| rebase |of| env)))))) stream filerdtbl)))) ) ) (RPAQ? *FILEMAP-LIMIT* 20) (RPAQ? *FILEMAP-VERSIONS* 2) (RPAQ? *FILEMAP-HASH* (HASHARRAY *FILEMAP-LIMIT* (FUNCTION \\FILEMAP-HASHOVERFLOW) (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING.EQUAL))) (DECLARE\: EVAL@COMPILE DONTCOPY (DECLARE\: EVAL@COMPILE (RECORD FILEMAPHASH (FMENVIRONMENT FMROOTNAME FMFROMFILE? FMRECENT? FMFILECREATEDLOC FMFILECREATEDLST . FMFILEMAP)) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *FILEMAP-LIMIT* *FILEMAP-VERSIONS* *FILEMAP-HASH*) ) ) (* * LVLPRINT) (DEFINEQ (lvlprint (lambda (x file carlvl cdrlvl tail) (* |wt:| 12-may-76 22 6) (lvlprin2 x file carlvl cdrlvl tail) (terpri file) x) ) (lvlprin1 (lambda (x file carlvl cdrlvl tail) (declare (specvars file prin2flg)) (prog (prin2flg) (lvlprin x carlvl cdrlvl tail) (return x))) ) (lvlprin2 (lambda (x file carlvl cdrlvl tail) (declare (specvars file prin2flg)) (* |wt:| 12-may-76 22 6) (prog ((prin2flg t)) (lvlprin x carlvl cdrlvl tail) (return x))) ) (lvlprin (lambda (x carlvl cdrlvl tail) (* \; "Edited 10-Nov-87 13:10 by jds") (* \; "wt: 12-MAY-76 22 23") (cond ((nlistp x) (cond ((and tail (eq x (cdr (last tail))) (not (memb x tail))) (prin1 (quote "... . ") file) (cond (prin2flg (prin2 x file t)) (t (prin1 x file))) (* |;;| "We use standard system read table for printing on grounds that even if this is going to a file, user is only dumping it with bpnt to look at it, not to read it back in.") (prin1 ")" file)) (prin2flg (prin2 x file t)) (t (prin1 x file)))) (t (prin1 (cond ((and tail (tailp x tail)) (* \; "Tail") (quote "... ")) (t "(")) file) (lvlprin0 x carlvl cdrlvl) (prin1 ")" file)))) ) (lvlprin0 (lambda (x carlvl cdrlvl) (* \; "Edited 10-Nov-87 13:11 by jds") (* \; "LVLPRIN0 is like subprint. it prints the interior segment of a list") (and (eq (car x) clisptranflg) (setq x (cddr x))) (prog ((cdrlvl0 cdrlvl)) (go lp1) lp (cond ((null (setq x (cdr x))) (return)) ((nlistp x) (prin1 (quote " . ") file) (cond (prin2flg (prin2 x file t)) (t (prin1 x file))) (return)) (t (spaces 1 file))) lp1 (cond ((eq cdrlvl 0) (prin1 "--" file) (return)) ((nlistp (car x)) (cond (prin2flg (prin2 (car x) file t t)) (t (prin1 (car x) file)))) ((or (eq carlvl 0) (and cdrlvl0 (eq (sub1 cdrlvl0) 0))) (* \; "the reason for the second check is that why bother to recurse only to print (--). & is better") (prin1 (quote &) file)) ((and (eq file t) (superprinteq (caar x) commentflg) **comment**flg) (prin1 **comment**flg file)) (t (prin1 (quote \() file) (lvlprin0 (car x) (and carlvl (iplus carlvl (cond ((minusp carlvl) 1) (t -1)))) (and cdrlvl0 (sub1 cdrlvl0))) (prin1 (quote \)) file))) (and cdrlvl (setq cdrlvl (sub1 cdrlvl))) (go lp))) ) ) (* \; "used by PRINTOUT") (DEFINEQ (flushright (lambda (pos x min p2flag centerflag file) (* |lmm| "10-Feb-86 12:10") (* |;;| "Right-flushes X at position POS. If P2FLAG, uses PRIN2-pname; if CENTERFLAG, centers X between current position and POS") (setq pos (idifference (cond ((minusp pos) (idifference (position file) pos)) ((zerop pos) (linelength nil file)) (t pos)) (nchars x p2flag))) (cond (centerflag (setq pos (quotient (iplus pos (position file)) 2)))) (tab pos min file) (cond (p2flag (prin2 x file)) (t (prin1 x file)))) ) (printpara (lambda (lmarg rmarg list p2flag parenflag file) (* |rmk:| "22-MAY-81 13:45") (* |;;| "Prints LIST in paragraph format. The first line starts at the current line position, but all subsequent lines begin at LMARG (0 is the left margin, NIL is the current POSITION, negative LMARG is (POSITION) + LMARG). Printing is with PRIN2 if P2FLAG, otherwise PRIN1. The right margin is at column RMARG if RMARG is positive, (LINELENGTH NIL FILE) minus RMARG for RMARG LEQ 0") (declare (specvars lmarg rmarg p2flag file)) (cond ((null lmarg) (setq lmarg (position file))) ((minusp lmarg) (setq lmarg (idifference (position file) lmarg)))) (cond ((ileq rmarg 0) (setq rmarg (iplus rmarg (linelength nil file))))) (position file (printpara1 list (position file) (cond (parenflag 1) (t 0)) (cond (parenflag 1) (t 0))))) ) (printpara1 (lambda (list pos opencount closecount) (* |wt:| " 9-SEP-78 09:54") (* |;;| "PRIN3 and PRIN4 are used here, so we don't have to set and unset LINELENGTH. We keep our own idea of the current line position in POS, which is returned as the value of PRINTPARA1. OPENCOUNT is the number of open parens that must precede the first non-list we print, CLOSECOUNT is the number of close parens that should follow the last non-list we print. They are passed as arguments so that their numbers can be taken into account in deciding whether a non-list fits on the line or not.") (prog ($$val l len (cc 0)) $$lp (setq l (car (or (listp list) (go $$out)))) (* \; "POS is the correct column position at the end of each iteration") (cond ((nlistp (cdr list)) (setq cc closecount))) (* \; "The last iteration. Now we really want to use CLOSECOUNT, so we move it to CC.") (cond ((listp l) (setq pos (printpara1 l pos (add1 opencount) (add1 cc))) (setq opencount 0) (* \; "The lower call printed the open and closed parens, including the ones for this level, if any.") (setq cc 0)) (t (cond ((ilessp rmarg (iplus opencount cc (setq pos (iplus pos (setq len (nchars l p2flag)))))) (terpri file) (* \; "TAB wouldn't work, cause POSITION doesn't know where we are.") (rptq lmarg (prin3 (quote \ ) file)) (setq pos (iplus lmarg len)))) (cond ((igreaterp opencount 0) (rptq opencount (prin3 (quote \() file)) (setq pos (iplus pos opencount)) (setq opencount 0))) (cond (p2flag (prin4 l file)) (t (prin3 l file))))) (cond ((and (igreaterp rmarg (add1 pos)) (listp (cdr list))) (prin3 (quote \ ) file) (setq pos (add1 pos)))) $$iterate (setq list (cdr list)) (go $$lp) $$out (rptq cc (cond ((ilessp rmarg (setq pos (add1 pos))) (terpri file) (* \; "We do the closes one-by-one, in case they won't fit on a line with only 1 atom") (rptq lmarg (prin3 (quote \ ) file)) (prin3 (quote \)) file) (setq pos (add1 lmarg))) (t (prin3 (quote \)) file)))) (return $$val)) pos) ) ) (* \; "SUBLIS and friends") (DEFINEQ (sublis (lambda (alst expr flg) (cond ((listp expr) ((lambda (d a) (cond ((or (neq a (car expr)) (neq d (cdr expr)) flg) (cons a d)) (t expr))) (and (cdr expr) (sublis alst (cdr expr) flg)) (sublis alst (car expr) flg))) (t (let ((y (fassoc expr alst))) (cond (y (cond (flg (copy (cdr y))) (t (cdr y)))) (t expr)))))) ) (subpair (lambda (old new expr flg) (* |lmm| "25-FEB-82 15:29") (cond ((listp expr) ((lambda (d a) (cond ((or (neq a (car expr)) (neq d (cdr expr)) flg) (cons a d)) (t expr))) (and (cdr expr) (subpair old new (cdr expr) flg)) (subpair old new (car expr) flg))) (t (prog nil lp (return (cond ((null old) expr) ((nlistp old) (cond ((eq expr old) (cond (flg (copy new)) (t new))) (t expr))) ((eq expr (car old)) (cond (flg (copy (car new))) (t (car new)))) (t (setq old (cdr old)) (setq new (cdr new)) (go lp)))))))) ) (dsublis (lambda (alst expr flg) (cond ((nlistp expr) (sublis alst expr flg)) (t (let ((a (dsublis alst (car expr) flg))) (or (eq a (car expr)) (rplaca expr a))) (let ((d (dsublis alst (cdr expr) flg))) (or (eq d (cdr expr)) (rplacd expr d))) expr))) ) ) (* * CONSTANTS) (DEFINEQ (constantok (lambda (x depth) (* |lmm| " 1-OCT-78 22:03") (or depth (setq depth 100)) (cond ((or (smallp x) (stringp x) (floatp x)) depth) ((fixp x) (and (not (smallp (iplus x))) depth)) ((litatom x) (and (igreaterp (nchars x) 0) depth)) ((listp x) (and (setq depth (constantok (car x) (sub1 depth))) (constantok (cdr x) depth))))) ) ) (MOVD? 'EVQ 'CONSTANT) (MOVD? 'EVQ 'DEFERREDCONSTANT) (MOVD? 'EVQ 'LOADTIMECONSTANT) (* * SCRATCHLIST) (PUTPROPS SCRATCHLIST MACRO ((SCRATCHLIST . FORMS) ((LAMBDA (!SCRATCHLIST !SCRATCHTAIL) (DECLARE (SPECVARS !SCRATCHLIST !SCRATCHTAIL)) (SETQ !SCRATCHTAIL !SCRATCHLIST) (PROGN . FORMS) (COND ((EQ !SCRATCHTAIL !SCRATCHLIST) NIL) (T (PROG ((L2 (CDR !SCRATCHLIST))) (RPLACD !SCRATCHLIST (PROG1 (CDR !SCRATCHTAIL) (RPLACD !SCRATCHTAIL NIL))) (FRPLACD (FLAST !SCRATCHLIST) L2) (RETURN L2))))) (OR (LISTP SCRATCHLIST) (CONS)) NIL))) (PUTPROPS ADDTOSCRATCHLIST MACRO ((VALUE) (FRPLACA (SETQ !SCRATCHTAIL (OR (LISTP (CDR !SCRATCHTAIL)) (CDR (FRPLACD !SCRATCHTAIL (CONS))))) VALUE))) (PUTPROPS SCRATCHLIST INFO EVAL) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSFILES LOADOPTIONS LISPXCOMS CLISPTRANFLG COMMENTFLG HISTSTR4 LISPXREADFN REREADFLG HISTSTR0 CTRLUFLG NOLINKMESS PROMPTCHARFORMS PROMPT#FLG FILERDTBL SPELLINGS2 USERWORDS BELLS CLISPARRAY) ) (DEFINEQ (nlambda.args (lambda (x) (* |bvm:| "26-Apr-86 16:41") (* |;;;| "Standard function to take argument to NLAMBDA function, e.g. BREAK, and check to see if accidentally quoted.") (* |;;;| "Handles both BREAK 'FOO as a command and (BREAK 'FOO 'BAR). In the former case, X is (QUOTE FOO), in the latter it is ((QUOTE FOO) (QUOTE BAR)).") (cond ((nlistp x) (and x (list x))) ((and (eq (car x) (quote quote)) (listp (cdr x)))) ((and (listp (car x)) (eq (caar x) (quote quote))) (cons (cadr (car x)) (nlambda.args (cdr x)))) (t x))) ) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (ADDTOVAR CLISPARRAY ) (ADDTOVAR CLISPFLG ) (ADDTOVAR CTRLUFLG ) (ADDTOVAR EDITCALLS ) (ADDTOVAR EDITHISTORY ) (ADDTOVAR EDITUNDOSAVES ) (ADDTOVAR EDITUNDOSTATS ) (ADDTOVAR GLOBALVARS ) (ADDTOVAR LCASEFLG ) (ADDTOVAR LISPXBUFS ) (ADDTOVAR LISPXCOMS ) (ADDTOVAR LISPXFNS ) (ADDTOVAR LISPXHIST ) (ADDTOVAR LISPXHISTORY ) (ADDTOVAR LISPXPRINTFLG ) (ADDTOVAR NOCLEARSTKLST ) (ADDTOVAR NOFIXFNSLST ) (ADDTOVAR NOFIXVARSLST ) (ADDTOVAR P.A.STATS ) (ADDTOVAR PROMPTCHARFORMS ) (ADDTOVAR READBUF ) (ADDTOVAR READBUFSOURCE ) (ADDTOVAR REREADFLG ) (ADDTOVAR RESETSTATE ) (ADDTOVAR SPELLSTATS1 ) (RPAQQ CHCONLST (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (RPAQQ CHCONLST1 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL )) (RPAQQ CHCONLST2 (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL )) (RPAQQ CLEARSTKLST T) (RPAQQ CLISPTRANFLG CLISP\ ) (RPAQ HISTSTR0 "") (RPAQ HISTSTR2 "repeat") (RPAQ HISTSTR3 "from event:") (RPAQ HISTSTR4 "ignore") (RPAQQ LISPXREADFN READ) (RPAQQ USEMAPFLG T) (MAPC '((APPLY BLKAPPLY) (SETTOPVAL SETATOMVAL) (GETTOPVAL GETATOMVAL) (APPLY* BLKAPPLY*) (RPLACA FRPLACA) (RPLACD FRPLACD) (STKNTH FSTKNTH) (STKNAME FSTKNAME) (CHARACTER FCHARACTER) (STKARG FSTKARG) (CHCON DCHCON) (UNPACK DUNPACK) (ADDPROP /ADDPROP) (ATTACH /ATTACH) (DREMOVE /DREMOVE) (DSUBST /DSUBST) (NCONC /NCONC) (NCONC1 /NCONC1) (PUT /PUT) (PUTPROP /PUTPROP) (PUTD /PUTD) (REMPROP /REMPROP) (RPLACA /RPLACA) (RPLACD /RPLACD) (SET /SET) (SETATOMVAL /SETATOMVAL) (SETTOPVAL /SETTOPVAL) (SETPROPLIST /SETPROPLIST) (SET SAVESET) (PRINT LISPXPRINT) (PRIN1 LISPXPRIN1) (PRIN2 LISPXPRIN2) (SPACES LISPXSPACES) (TAB LISPXTAB) (TERPRI LISPXTERPRI) (PRINT SHOWPRINT) (PRIN2 SHOWPRIN2) (PUTHASH /PUTHASH) '* (FNCLOSER /FNCLOSER) (FNCLOSERA /FNCLOSERA) (FNCLOSERD /FNCLOSERD) (EVQ DELFILE) (NILL SMASHFILECOMS) (PUTASSOC /PUTASSOC) (LISTPUT1 PUTL) (NILL I.S.OPR) (NILL RESETUNDO) (NILL LISPXWATCH) 'ADDSTATS (NILL FREEVARS) 'USEDFREE (COPYBYTES COPYCHARS)) (FUNCTION (LAMBDA (X) (MOVD? (CAR X) (CADR X))))) (MAPC '((TIME PRIN1 LISPXPRIN1) (TIME SPACES LISPXSPACES) (TIME PRINT LISPXPRINT) (DEFC PRINT LISPXPRINT) (DEFC PUTD /PUTD) (DEFC PUTPROP /PUTPROP) (DOLINK FNCLOSERD /FNCLOSERD) (DOLINK FNCLOSERA /FNCLOSERA) (DEFLIST PUTPROP /PUTPROP) (SAVEDEF1 PUTPROP /PUTPROP) (MKSWAPBLOCK PUTD /PUTD)) (FUNCTION (LAMBDA (X) (AND (CCODEP (CAR X)) (APPLY 'CHANGENAME X))))) (MAPC '((EVALQT (LAMBDA NIL (PROG (TEM) (RESETRESTORE NIL 'RESET) LP (PROMPTCHAR '_ T) (LISPX (LISPXREAD T T)) (GO LP)))) (LISPX (LAMBDA (LISPXX) (PRINT (AND LISPXX (PROG (LISPXLINE LISPXHIST TEM) (RETURN (COND ((AND (NLISTP LISPXX) (SETQ LISPXLINE (READLINE T NIL T))) (APPLY LISPXX (CAR LISPXLINE))) (T (EVAL LISPXX)))))) T T))) (LISPXREAD (LAMBDA (FILE RDTBL) (COND (READBUF (PROG1 (CAR READBUF) (SETQ READBUF (CDR READBUF)))) (T (READ FILE RDTBL))))) (LISPXREADP (LAMBDA (FLG) (COND ((AND READBUF (SETQ READBUF (LISPXREADBUF READBUF))) T) (T (READP T FLG))))) (LISPXUNREAD (LAMBDA (LST) (SETQ READBUF (APPEND LST (CONS HISTSTR0 READBUF))))) (LISPXREADBUF (LAMBDA (RDBUF) (PROG NIL LP (COND ((NLISTP RDBUF) (RETURN NIL)) ((EQ (CAR RDBUF) HISTSTR0) (SETQ RDBUF (CDR RDBUF)) (GO LP)) (T (RETURN RDBUF)))))) (LISPX/ (LAMBDA (X) X)) (LOWERCASE (LAMBDA (FLG) (PROG1 LCASEFLG (RAISE (NULL FLG)) (RPAQ LCASEFLG FLG)))) (FILEPOS (LAMBDA (STR FILE) (PROG NIL LP (COND ((EQ (PEEKC FILE) (NTHCHAR STR 1)) (RETURN T))) (READC FILE) (GO LP)))) (FILEPKGCOM (NLAMBDA NIL NIL))) (FUNCTION (LAMBDA (L) (OR (GETD (CAR L)) (PUTD (CAR L) (CADR L)))))) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA RESETBUFS DMPHASH FILESLOAD) (ADDTOVAR NLAML FILEMAP) (ADDTOVAR LAMA READFILE NLIST) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS MACHINEINDEPENDENT COPYRIGHT ("Venue & Xerox Corporation" T 1983 1984 1985 1986 1987 1988 1989 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL (12996 18632 (LOAD? 13006 . 13733) (FILESLOAD 13735 . 13959) (DOFILESLOAD 13961 . 16898) (FINDFILE-WITH-EXTENSIONS 16900 . 18630)) (18750 23205 (DMPHASH 18760 . 19338) (HASHOVERFLOW 19340 . 23203)) (24007 43277 (BKBUFS 24017 . 24798) (CHANGENAME 24800 . 24973) (CHNGNM 24975 . 26185) (CLBUFS 26187 . 27139) (DEFINE 27141 . 27461) (FNS.PUTDEF 27463 . 29643) (EQMEMB 29645 . 29741) (EQUALN 29743 . 30245) (FNCHECK 30247 . 31392) (FNTYP1 31394 . 31478) (LCSKIP 31480 . 31924) (MAPRINT 31926 . 32454 ) (MKLIST 32456 . 32538) (NAMEFIELD 32540 . 33594) (NLIST 33596 . 33770) (PRINTBELLS 33772 . 33843) ( PROMPTCHAR 33845 . 35101) (RAISEP 35103 . 35283) (READFILE 35285 . 36296) (READLINE 36298 . 40014) ( REMPROPLIST 40016 . 40495) (RESETBUFS 40497 . 40744) (TAB 40746 . 41056) (UNSAVED1 41058 . 41689) ( WRITEFILE 41691 . 42666) (CLOSE-AND-MAYBE-DELETE 42668 . 42944) (UNSAFE.TO.MODIFY 42946 . 43275)) ( 45604 46859 (FILEDATE 45614 . 46857)) (47091 60043 (FILEMAP 47101 . 47444) (\\PARSE-FILE-HEADER 47446 . 49593) (GET-ENVIRONMENT-AND-FILEMAP 49595 . 50991) (LOOKUP-ENVIRONMENT-AND-FILEMAP 50993 . 52181) ( GET-FILEMAP-FROM-FILECREATED 52183 . 52673) (\\FILEMAP-HASHOVERFLOW 52675 . 54723) (FLUSHFILEMAPS 54725 . 55025) (LISPSOURCEFILEP 55027 . 55698) (GETFILEMAP 55700 . 56014) (PUTFILEMAP 56016 . 57117) ( UPDATEFILEMAP 57119 . 59313) (PRINT-READER-ENVIRONMENT 59315 . 60041)) (60661 62841 (LVLPRINT 60671 . 60801) (LVLPRIN1 60803 . 60950) (LVLPRIN2 60952 . 61128) (LVLPRIN 61130 . 61791) (LVLPRIN0 61793 . 62839)) (62876 66183 (FLUSHRIGHT 62886 . 63392) (PRINTPARA 63394 . 64217) (PRINTPARA1 64219 . 66181)) (66220 67334 (SUBLIS 66230 . 66553) (SUBPAIR 66555 . 67074) (DSUBLIS 67076 . 67332)) (67357 67706 ( CONSTANTOK 67367 . 67704)) (69792 70335 (NLAMBDA.ARGS 69802 . 70333))))) STOP \ No newline at end of file diff --git a/sources/MACROAUX b/sources/MACROAUX new file mode 100644 index 00000000..ddf4e773 --- /dev/null +++ b/sources/MACROAUX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 20:26:31" {DSK}local>lde>lispcore>sources>MACROAUX.;2 20459 changes to%: (VARS MACROAUXCOMS) previous date%: " 3-Nov-86 11:54:19" {DSK}local>lde>lispcore>sources>MACROAUX.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MACROAUXCOMS) (RPAQQ MACROAUXCOMS ((EXPORT (DECLARE%: DONTCOPY (MACROS NNLITATOM \NULL.OR.FIXP \CHECKTYPE CANONICAL.TIMERUNITS)) (PROP DMACRO \MACRO.EVAL) (OPTIMIZERS \MACRO.MX)) (COMS (* ;  "functions which help macro and compiler writers.") (FNS LISPFORM.SIMPLIFY NO.SIDEEFFECTS.FNP CODE.SUBST CODE.SUBPAIR) (GLOBALRESOURCES \NSE.STRPTR)) (COMS (FNS ARGS.COMMUTABLEP ARGS.COMMUTABLEP.LIST VAR.NOT.USED \VARNOTUSED \VARNOTUSED.LIST EVALUABLE.CONSTANTP EVALUABLE.CONSTANT.FIXP) (MACROS EVALUABLE.CONSTANT.FIXP CARCDR.FNP)) (FNS \DECL.COMNT.PROCESS) (COMS (FNS \WALKOVER.SPECIALFORMS \WALKOVER.SF.LIST \WALKOVER.FUNCTION) (DECLARE%: DONTCOPY (CONSTANTS \QUOTIFYING.NLS \WALKABLE.SPECIALFORMS) (MACROS \WALKABLE.SPECIALFORMP)) (ADDVARS (CONSTANTFOLDFNS IMIN IMAX IABS LOGOR LOGXOR LOGAND)) (VARS NOSIDEFNS) (GLOBALVARS CLISPARRAY CONSTANTFOLDFNS)) (PROP FILETYPE MACROAUX))) (* "FOLLOWING DEFINITIONS EXPORTED") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (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) ''FUNCTION] then (SETQ PRED (LIST (CADR PRED) VAR))) (RETURN (SUBPAIR '(MSG VAR PRED) (LIST (CONCAT " is not a suitable value for the variable: " VAR) VAR PRED) '(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 '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) (* "END EXPORTED DEFINITIONS") (* ; "functions which help macro and compiler writers.") (DEFINEQ (LISPFORM.SIMPLIFY [LAMBDA (X EVALFLG) (* lmm "11-Jul-85 02:46") (* Reduce some LISP code to its more primitive form. Currently, supporst macroexpansion, dwimmification, and evaluation of compile-time constants.) (if (LISTP X) then (LET ((FN (CAR X)) Y) (COND ((NOT (LITATOM FN)) X) ((AND EVALFLG (GETD FN)) X) ((SETQ Y (GETMACROPROP FN COMPILERMACROPROPS)) (if (EQ X (SETQ X (MACROEXPANSION X Y))) then X else (LISPFORM.SIMPLIFY X))) ([AND (OR (SETQ Y (GETHASH X CLISPARRAY)) (DWIMIFY0? X X X NIL T "LISPFORM.SIMPLIFY") (SETQ Y (GETHASH X CLISPARRAY] (LISPFORM.SIMPLIFY Y)) ((SETQ Y (CONSTANTEXPRESSIONP X)) (KWOTE (CAR Y))) (T X))) else (if EVALFLG then X else (LET ((CE (CONSTANTEXPRESSIONP X))) (if CE then (CAR CE) else X]) (NO.SIDEEFFECTS.FNP [LAMBDA (X) (* edited%: "14-May-86 15:12") (* Fast-case-test for simple memory access fns) (AND (NNLITATOM X) (OR (GETPROP X 'CROPS) (FMEMB X NOSIDEFNS]) (CODE.SUBST [LAMBDA (X Y FORM) (* JonL "21-NOV-82 14:24") (* Ho Hum, someday this ought to be made to work!) (SUBST X Y FORM]) (CODE.SUBPAIR [LAMBDA (L1 L2 FORM) (* JonL "21-NOV-82 14:24") (* Ho Hum, someday this ought to be made to work!) (SUBPAIR L1 L2 FORM]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\NSE.STRPTR 'RESOURCES '(NEW (ALLOCSTRING 0] ) ) (/SETTOPVAL '\\NSE.STRPTR.GLOBALRESOURCE NIL) (DEFINEQ (ARGS.COMMUTABLEP [LAMBDA (X Y) (* lmm "11-Jul-85 02:48") (* non-NIL iff the evaluation of X and Y can be done in either order without any change in effects or value.) (PROG (FN) [if (NLISTP Y) then (if (NLISTP X) then (* If both args are atoms, then we can just punt out here with the answer.) (RETURN T)) (* Switch args so that we don't have to handle the case of Y an atom) (SETQ X (PROG1 Y (SETQ Y X] (if (if (LISTP X) then (* Fast check for quoted frobs. Remember, Y can't be an atom.) (MEMB (CAR X) \QUOTIFYING.NLS) else (* Cases like random, non-variable atoms) (NOT (NNLITATOM X))) then (RETURN T)) (SETQ Y (LISPFORM.SIMPLIFY Y T)) (RETURN (if (LISTP (SETQ FN (CAR Y))) then (if (EQ (CAR FN) 'LAMBDA) then (ARGS.COMMUTABLEP.LIST Y (LISPFORM.SIMPLIFY X T))) elseif (MEMB FN \QUOTIFYING.NLS) then 'T elseif (EQ FN 'SETQ) then (AND (\VARNOTUSED X (CADR Y)) (ARGS.COMMUTABLEP.LIST (CDDR Y) (LISPFORM.SIMPLIFY X T))) elseif (\WALKABLE.SPECIALFORMP FN) then (\WALKOVER.SPECIALFORMS (FUNCTION ARGS.COMMUTABLEP) Y (LISPFORM.SIMPLIFY X T)) else (AND (NO.SIDEEFFECTS.FNP FN) (ARGS.COMMUTABLEP.LIST (CDR Y) (LISPFORM.SIMPLIFY X T]) (ARGS.COMMUTABLEP.LIST [LAMBDA (L Y) (* JonL "21-NOV-82 15:07") (EVERY L (FUNCTION (LAMBDA (X) (ARGS.COMMUTABLEP X Y]) (VAR.NOT.USED [LAMBDA (FORM VAR SETQONLY?) (* JonL "21-NOV-82 14:01") (PROG NIL A (if (NOT (LITATOM VAR)) then (SETERRORN 14 VAR) (SETQ VAR (ERRORX)) (GO A)) (if (MEMB VAR '(NIL T)) then (SETERRORN 27 VAR) (SETQ VAR (ERRORX)) (GO A)) (RETURN (\VARNOTUSED FORM VAR SETQONLY?]) (\VARNOTUSED [LAMBDA (FORM VAR SETQONLY?) (* JonL "21-NOV-82 16:10") (* Look for free occurances of a variable VAR which may be evaluable in FORM) (if (NLISTP FORM) then (AND (NOT SETQONLY?) (NEQ VAR FORM)) elseif (LISTP (CAR FORM)) then (\VARNOTUSED.LIST FORM VAR SETQONLY?) elseif (EQ (CAR FORM) 'LAMBDA) then (* Note that if a LAMBDA form bind a var X, then VAR can't be "used inside" the form.) (OR (MEMB VAR (CADR FORM)) (\VARNOTUSED (CDDR FORM) VAR SETQONLY?)) elseif (MEMB (CAR FORM) \QUOTIFYING.NLS) then T elseif (MEMB (CAR FORM) '(SETQ)) then (* Stupid Interlisp SETQ format -- You really wound't believe it!) (AND (NEQ VAR (CADR FORM)) (\VARNOTUSED.LIST FORM VAR SETQONLY?)) elseif (\WALKABLE.SPECIALFORMP (CAR FORM)) then (\WALKOVER.SPECIALFORMS (FUNCTION \VARNOTUSED) FORM VAR SETQONLY?) elseif (NO.SIDEEFFECTS.FNP (CAR FORM)) then (\VARNOTUSED.LIST (CDR FORM) VAR SETQONLY?]) (\VARNOTUSED.LIST [LAMBDA (L X SETQONLY?) (* JonL "21-NOV-82 15:06") (EVERY L (FUNCTION (LAMBDA (FORM) (\VARNOTUSED FORM X SETQONLY?]) (EVALUABLE.CONSTANTP [LAMBDA (X) (* lmm "12-Apr-85 09:42") (if (OR (NLISTP X) (EQ (CAR X) 'QUOTE) (EQ (CAR X) 'CONSTANT) (FMEMB (CAR X) CONSTANTFOLDFNS)) then (* Unfortunately, CONSTANT has a macro property which may conflict with the action of LISPFORM.SIMPLIFY) (CONSTANTEXPRESSIONP X) else (if (LISTP X) then (SETQ X (LISPFORM.SIMPLIFY X T))) (if (NLISTP X) then (CONSTANTEXPRESSIONP X) elseif (NNLITATOM (CAR X)) then [if (\WALKABLE.SPECIALFORMP (CAR X)) then (if (\WALKOVER.SPECIALFORMS (FUNCTION EVALUABLE.CONSTANTP) X) then (* This branch currently has a bug in it -- we'd like a version of EVAL which didn't just do an EVALV on litatoms, but first check CONSTANTEXPRESSIONP on them. The problem occurs in cross-compilation.) (LIST (EVAL X))) elseif (AND [NOT (FMEMB (CAR X) '(CONS LIST \ALLOCKBLOCK ARRAY MKSTRING MKATOM ALLOCSTRING SYSTEMTYPE MACHINETYPE GETD] (NO.SIDEEFFECTS.FNP (CAR X))) then (* If a random function without side-effects, then it is constant when applied to constant args, except for consers of various kinds.) (PROG [(VALS (for Z in (CDR X) collect (CAR (OR (EVALUABLE.CONSTANTP Z) (RETURN] (RETURN (if VALS then (LIST (APPLY (CAR X) VALS] elseif (AND (LISTP (CAR X)) (EQ (CAAR X) 'LAMBDA)) then (if (NLISTP (CADAR X)) then (* Arglist is NIL or some non-list.) [EVALUABLE.CONSTANTP (CONS 'PROGN (APPEND (CDR X) (CDDAR X] else (for Z VALS in (CDR X) do (* Be sure that any "arguments" are all constant. Then do "beta" reduction.) [push VALS (KWOTE (CAR (OR (EVALUABLE.CONSTANTP Z) (RETURN] finally (RETURN (EVALUABLE.CONSTANTP (CODE.SUBPAIR (CADAR X) VALS (CONS 'PROGN (CDDAR X]) (EVALUABLE.CONSTANT.FIXP [LAMBDA (X) (* JonL "25-FEB-83 20:36") (FIXP (CAR (EVALUABLE.CONSTANTP X]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS EVALUABLE.CONSTANT.FIXP MACRO [(X) (FIXP (CAR (EVALUABLE.CONSTANTP X]) (PUTPROPS CARCDR.FNP MACRO ((X) (GETPROP X 'CROPS))) ) (DEFINEQ (\DECL.COMNT.PROCESS [LAMBDA (FORMS) (* JonL "17-OCT-83 22:01") (* Returns a list whose first element is the list of all declarations preceeding significand, whose second element is the list of all comments preceeding significand, and whose remaining elements are the "body" of FORMS) (for L DECLS COMNTS Y on FORMS while [AND (LISTP (SETQ Y (CAR L))) (OR (EQ COMMENTFLG (SETQ Y (CAR Y))) (EQ Y 'DECLARE] do (if (EQ COMMENTFLG Y) then (push COMNTS (CAR L)) elseif (EQ Y 'DECLARE) then (push DECLS (CAR L))) finally (RETURN (CONS DECLS (CONS COMNTS L]) ) (DEFINEQ (\WALKOVER.SPECIALFORMS [LAMBDA (PRED FORM REST1 REST2 REST3) (* JonL "29-JAN-83 21:30") (* Loser! What I really need is a &REST argument L, and use (APPLY PRED L) instead of the APPLY*) (SELECTQ (CAR (LISTP FORM)) (COND [EVERY (CDR FORM) (FUNCTION (LAMBDA (CLZ) (OR (NLISTP CLZ) (\WALKOVER.SF.LIST PRED CLZ REST1 REST2 REST3]) ((SELECTQ SELECTC) (AND (APPLY* PRED (CADR FORM) REST1 REST2 REST3) (APPLY* PRED (CAR (LAST FORM)) REST1 REST2 REST3) (for LL on (CDDR FORM) until (NULL (CDR LL)) do (OR (\WALKOVER.SF.LIST PRED (CDAR LL) REST1 REST2 REST3) (RETURN)) finally (RETURN T)))) ((AND OR FRPTQ SETQ) (\WALKOVER.SF.LIST PRED (CDR FORM) REST1 REST2 REST3)) ((APPLY APPLY*) (AND (\WALKOVER.FUNCTION PRED (CADR FORM) REST1 REST2 REST3) (\WALKOVER.SF.LIST PRED (CDDR FORM) REST1 REST2 REST3))) ((MAP MAPLIST MAPC MAPCAR MAPCON MAPCONC MAPHASH EVERY SOME NOTEVERY NOTANY) (AND (APPLY* PRED (CADR FORM) REST1 REST2 REST3) (CAR (SETQ FORM (CDDR FORM))) (\WALKOVER.FUNCTION PRED (CAR FORM) REST1 REST2 REST3) (OR (NLISTP (CDR FORM)) (\WALKOVER.FUNCTION PRED (CADR FORM) REST1 REST2 REST3)))) ((MAPATOMS) (\WALKOVER.FUNCTION PRED (CADR FORM) REST1 REST2 REST3)) ((PROG) (* FooBar! Note that we can't currently walk over a PROG -- 30 JAN 1983) [AND [EVERY (CADR FORM) (FUNCTION (LAMBDA (L) (OR (NLISTP L) (NLISTP (CDR L)) (APPLY* PRED (CADR L) REST1 REST2 REST3] (EVERY (CDDR FORM) (FUNCTION (LAMBDA (L) (OR (NLISTP L) (APPLY* PRED L REST1 REST2 REST3]) (SHOULDNT]) (\WALKOVER.SF.LIST [LAMBDA (PRED L REST1 REST2 REST3) (* JonL "21-NOV-82 15:04") (EVERY L (FUNCTION (LAMBDA (X) (APPLY* PRED X REST1 REST2 REST3]) (\WALKOVER.FUNCTION [LAMBDA (PRED FN REST1 REST2 REST3) (* JonL "21-NOV-82 15:11") (* Analyze case where FN is being applied (e.g. as in MAPCAR)) (if [OR (NLISTP FN) (NOT (MEMB (CAR FN) ''FUNCTION] then (AND (APPLY* PRED FN REST1 REST2 REST3) (APPLY* PRED '(\TypicalUnknownFunction) REST1 REST2 REST3)) else (APPLY* PRED (if (NLISTP (SETQ FN (CADR FN))) then (LIST FN) else FN) REST1 REST2 REST3]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \QUOTIFYING.NLS (QUOTE FUNCTION DECLARE CONSTANT DEFERREDCONSTANT)) (RPAQQ \WALKABLE.SPECIALFORMS (COND SELECTQ SELECTC AND OR SETQ FRPTQ APPLY APPLY* MAP MAPLIST MAPC MAPCAR MAPCON MAPCONC MAPHASH MAPATOMS EVERY SOME NOTEVERY NOTANY)) (CONSTANTS \QUOTIFYING.NLS \WALKABLE.SPECIALFORMS) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \WALKABLE.SPECIALFORMP MACRO ((FORM) (MEMB FORM \WALKABLE.SPECIALFORMS))) ) ) (ADDTOVAR CONSTANTFOLDFNS IMIN IMAX IABS LOGOR LOGXOR LOGAND) (RPAQQ NOSIDEFNS (fetch CONS NLISTP PROGN APPEND LIST NEQ MEMB MEMBER FMEMB ASSOC TAILP COPY create ELT ELTD AND OR ADD1 SUB1 IPLUS IDIFFERENCE EQ EQUAL NOT NULL)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLISPARRAY CONSTANTFOLDFNS) ) (PUTPROPS MACROAUX FILETYPE COMPILE-FILE) (PUTPROPS MACROAUX COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4368 6541 (LISPFORM.SIMPLIFY 4378 . 5756) (NO.SIDEEFFECTS.FNP 5758 . 6133) (CODE.SUBST 6135 . 6333) (CODE.SUBPAIR 6335 . 6539)) (6694 14690 (ARGS.COMMUTABLEP 6704 . 8900) ( ARGS.COMMUTABLEP.LIST 8902 . 9104) (VAR.NOT.USED 9106 . 9573) (\VARNOTUSED 9575 . 10953) ( \VARNOTUSED.LIST 10955 . 11163) (EVALUABLE.CONSTANTP 11165 . 14526) (EVALUABLE.CONSTANT.FIXP 14528 . 14688)) (14959 15806 (\DECL.COMNT.PROCESS 14969 . 15804)) (15807 19350 (\WALKOVER.SPECIALFORMS 15817 . 18423) (\WALKOVER.SF.LIST 18425 . 18630) (\WALKOVER.FUNCTION 18632 . 19348))))) STOP \ No newline at end of file diff --git a/sources/MACROAUX-OPTIMIZERS b/sources/MACROAUX-OPTIMIZERS new file mode 100644 index 00000000..6989cae7 --- /dev/null +++ b/sources/MACROAUX-OPTIMIZERS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 20:24:51" {DSK}local>lde>lispcore>sources>MACROAUX-OPTIMIZERS.;2 766 changes to%: (VARS MACROAUX-OPTIMIZERSCOMS) previous date%: "23-Sep-86 20:01:04" {DSK}local>lde>lispcore>sources>MACROAUX-OPTIMIZERS.;1 ) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MACROAUX-OPTIMIZERSCOMS) (RPAQQ MACROAUX-OPTIMIZERSCOMS ((OPTIMIZERS EVALUABLE.CONSTANT.FIXP))) (DEFOPTIMIZER EVALUABLE.CONSTANT.FIXP (X) `[FIXP (CAR (EVALUABLE.CONSTANTP ,X]) (PUTPROPS MACROAUX-OPTIMIZERS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/MACROS b/sources/MACROS new file mode 100644 index 00000000..57e754e8 --- /dev/null +++ b/sources/MACROS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 20:28:24" {DSK}local>lde>lispcore>sources>MACROS.;2 35869 changes to%: (VARS MACROSCOMS) previous date%: "17-Feb-88 14:13:34" {DSK}local>lde>lispcore>sources>MACROS.;1) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MACROSCOMS) (RPAQQ MACROSCOMS [(OPTIMIZERS ADD1 CONSTANT DEFERREDCONSTANT EVENP GEQ IGEQ ILEQ IMAX IMIN LEQ LIST* NCONC1 NEQ NLISTP ODDP RPTQ SELECT SELECTC SETQQ SUB1 ZEROP) (PROP MACRO RESETBUFS FLESSP PROG2 SIGNED UNSIGNED) (COMS (* ;  "obsolete Interlisp macro functions") (FNS EXPANDMACRO MACROEXPANSION EXPAND-DEFMACRO COMPUTE-MACRO-ARGS MACROS.GETDEF GETMACROPROP EXPANDOPENLAMBDA) (GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP)) (PROP MACRO LOADTIMECONSTANT) (FUNCTIONS CSELECT) (COMS (FNS PRINTCOMSTRAN) (GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS) (ADDVARS (PRINTOUTMACROS)) (VARS PRINTOUTTOKENS) (PROP INFO PRINTOUT printout) (PROP MACRO PRINTOUT printout)) (ADDVARS * (LIST (CONS 'SYSPROPS MACROPROPS))) (PROP PROPTYPE * (PROGN MACROPROPS)) (PROP SETFN GETTOPVAL) (PROP FILETYPE MACROS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFOPTIMIZER ADD1 (X) `(IPLUS ,X 1)) (DEFOPTIMIZER CONSTANT (&REST MACROX) [PROG ((VAL (APPLY 'PROG1 MACROX))) (RETURN (COND ((CONSTANTOK VAL) (KWOTE VAL)) (T (CONS 'LOADTIMECONSTANT MACROX]) (DEFOPTIMIZER DEFERREDCONSTANT (X) `((CL:LAMBDA (MACROX) (DECLARE (LOCALVARS MACROX)) (OR (CDR MACROX) (FRPLACD (FRPLACA MACROX (EVQ ,X)) T)) (CAR MACROX)) (LOADTIMECONSTANT (CONS NIL NIL)))) (DEFOPTIMIZER EVENP (N &OPTIONAL (MODULUS 2)) `(EQ 0 (IMOD ,N ,MODULUS))) (DEFOPTIMIZER GEQ (X Y) `(NOT (LESSP ,X ,Y))) (DEFOPTIMIZER IGEQ (X Y) `(NOT (ILESSP ,X ,Y))) (DEFOPTIMIZER ILEQ (X Y) `(NOT (IGREATERP ,X ,Y))) (DEFOPTIMIZER IMAX (&OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) [COND ((NOT ARG1GIVEN) 'MIN.INTEGER) ((NOT ARG2GIVEN) `(FIX %, ARG1)) (RESTARGS `(IMAX (IMAX2 %, ARG1 %, ARG2) ., RESTARGS)) (T `(IMAX2 %, ARG1 %, ARG2]) (DEFOPTIMIZER IMIN (&OPTIONAL (ARG1 NIL ARG1GIVEN) (ARG2 NIL ARG2GIVEN) &REST RESTARGS) (COND ((NOT ARG1GIVEN) 'MAX.INTEGER) ((NOT ARG2GIVEN) `(FIX %, ARG1)) (RESTARGS `(IMIN (IMIN2 %, ARG1 %, ARG2) ., RESTARGS)) (T (LIST 'IMIN2 ARG1 ARG2)))) (DEFOPTIMIZER LEQ (X Y) `(NOT (GREATERP ,X ,Y))) (DEFOPTIMIZER LIST* (&REST X) [COND ((NULL X) NIL) ((NULL (CDR X)) (CAR X)) ((NULL (CDDR X)) (CONS 'CONS X)) (T (LIST 'CONS (CAR X) (CONS 'LIST* (CDR X]) (DEFOPTIMIZER NCONC1 (LST X) `(NCONC ,LST (CONS ,X))) (DEFOPTIMIZER NEQ (X Y) `(NULL (EQ ,X ,Y))) (DEFOPTIMIZER NLISTP (X) `(NULL (LISTP ,X))) (DEFOPTIMIZER ODDP (X . TAIL) `(NOT (EVENP ,X . ,TAIL))) (DEFOPTIMIZER RPTQ (N . FORMS) `(PROG ((RPTN ,N) RPTV) (DECLARE (LOCALVARS RPTN RPTV)) RPTQLAB (COND ((IGREATERP RPTN 0) (SETQ RPTV (PROGN . ,FORMS)) (SETQ RPTN (SUB1 RPTN)) (GO RPTQLAB))) (RETURN RPTV))) (DEFOPTIMIZER SELECT (&REST X) (CSELECT X)) (DEFOPTIMIZER SELECTC (EXPR &REST CLAUSES) `[SELECTQ ,EXPR ,@(FOR TAIL ON CLAUSES COLLECT (CL:IF (CDR TAIL) `(,(EVAL (CAAR TAIL)) ,@(CDAR TAIL)) (CAR TAIL))]) (DEFOPTIMIZER SETQQ (X V) `(SETQ ,X ',V)) (DEFOPTIMIZER SUB1 (X) `(IDIFFERENCE ,X 1)) (DEFOPTIMIZER ZEROP (&REST ARGS) (CONS '[OPENLAMBDA (X) (COND ((EQ X 0)) ((FLOATP X) (\FZEROP X] ARGS)) (PUTPROPS RESETBUFS MACRO [(A . B) ([LAMBDA ($$BUFS) (DECLARE (LOCALVARS $$BUFS)) (PROG1 (PROGN A . B) (AND $$BUFS (BKBUFS $$BUFS)))] (PROGN (LINBUF) (SYSBUF) (CLBUFS NIL T READBUF]) (PUTPROPS FLESSP MACRO [LAMBDA (X Y) (FGREATERP Y X]) (PUTPROPS PROG2 MACRO ((X . Y) (PROGN X (PROG1 . Y)))) (PUTPROPS SIGNED MACRO [ARGS (COND ((EQ COMPILE.CONTEXT 'EFFECT) (CAR ARGS)) (T (CONS '(OPENLAMBDA (N WIDTH) (COND [[IGREATERP N (SUB1 (LLSH 1 (SUB1 WIDTH] (* done this way just so that  (SIGNED X |2^16|) doesn't box) (SUB1 (IDIFFERENCE N (SUB1 (LLSH 1 WIDTH] (T N))) ARGS]) (PUTPROPS UNSIGNED MACRO [(X WIDTH) (LOGAND X (SUB1 (LLSH 1 WIDTH]) (* ; "obsolete Interlisp macro functions") (DEFINEQ (EXPANDMACRO [LAMBDA (EXP QUIETFLG OPTIONS COMPILE.CONTEXT) (* Pavel "24-Oct-86 23:44") (DECLARE (SPECVARS NCF PCF VCF EFF EXP COMPILE.CONTEXT)) (PROG [ALLFLG MACRODEF NCF PCF (VCF (NEQ COMPILE.CONTEXT 'EFFECT)) (EFF (EQ COMPILE.CONTEXT 'EFFECT] LP (COND ((NLISTP EXP) (GO OUT)) ((AND (EQ ALLFLG 'CLISP) (GETHASH EXP CLISPARRAY)) (SETQ EXP (GETHASH EXP CLISPARRAY)) (GO LP))) MLP (SETQ MACRODEF (GETMACROPROP (CAR EXP) COMPILERMACROPROPS)) [COND ((NEQ EXP (SETQ EXP (MACROEXPANSION EXP MACRODEF))) (COND (ALLFLG (GO LP] OUT (COND (QUIETFLG (RETURN EXP)) (T (RESETFORM (OUTPUT T) (PRINTDEF EXP NIL T) (TERPRI T]) (MACROEXPANSION [LAMBDA (EXPR MACRODEF COMPFLG COMPILE.CONTEXT) (* ; "Edited 17-Feb-88 14:10 by amd") (DECLARE (SPECVARS COMPILE.CONTEXT)) (COND ((NLISTP MACRODEF) EXPR) (T (SELECTQ (CAR MACRODEF) (NIL (COND ((CDDR MACRODEF) (CONS 'PROGN (CDR MACRODEF))) (T (CADR MACRODEF)))) ([LAMBDA NLAMBDA] (CONS MACRODEF (CDR EXPR))) (= (* bytemacro abbreviation) (CONS (CDR MACRODEF) (CDR EXPR))) (OPENLAMBDA (EXPANDOPENLAMBDA MACRODEF (CDR EXPR))) ((APPLY APPLY*) EXPR) (DEFMACRO (EXPAND-DEFMACRO (CDR MACRODEF) EXPR)) (COND [(LISTP (CAR MACRODEF)) (SUBPAIR (CAR MACRODEF) (CDR EXPR) (COND ((CDDR MACRODEF) (CONS 'PROGN (CDR MACRODEF))) (T (CADR MACRODEF] ((LITATOM (CAR MACRODEF)) (COND ((FMEMB (CAR MACRODEF) LAMBDASPLST) (CONS MACRODEF (CDR EXPR))) ((OR (EQ [SETQ MACRODEF (COND (COMPFLG (APPLY (CONS 'NLAMBDA MACRODEF) (CDR EXPR))) (T (PROG ((EXP EXPR) (EFF (EQ COMPILE.CONTEXT 'EFFECT)) (VCF (NEQ COMPILE.CONTEXT 'EFFECT)) NCF PCF PREDF) (DECLARE (SPECVARS NCF PCF VCF EFF EXPR EXP RETF PREDF )) (* various variables bound in the  Interlisp-D and Interlisp-10  compiler) (RETURN (APPLY (CONS 'NLAMBDA MACRODEF) (CDR EXPR] 'IGNOREMACRO) (EQ MACRODEF 'COMPILER:PASS)) (AND (EQ MACRODEF 'COMPILER:PASS) (CL:WARN "Macroexpansion of ~S produced COMPILER:PASS. This should probably be an optimizer." (CAR EXPR))) EXPR) (T MACRODEF))) (T EXPR]) (EXPAND-DEFMACRO [CL:LAMBDA (DEF FORM &OPTIONAL DEFAULT-VALUE) (* lmm "25-May-86 00:15") (LET (*MACRO-VARS* *MACRO-VALS* (*MACRO-FORM* FORM) (*MACRO-DEFAULT* DEFAULT-VALUE)) (DECLARE (CL:SPECIAL *MACRO-VARS* *MACRO-VALS* *MACRO-FORM* *MACRO-DEFAULT*)) (COMPUTE-MACRO-ARGS (CAR DEF) (CDR FORM) NIL) (LET [(VAL (CL:PROGV *MACRO-VARS* *MACRO-VALS* (EVAL (CONS 'PROGN (CDR DEF] (if (EQ VAL 'IGNOREMACRO) then FORM else VAL]) (COMPUTE-MACRO-ARGS [CL:LAMBDA (ARGUMENT-LIST MACRO-CALL-BODY CONTEXT) (* lmm "18-Apr-86 12:04") (COND ((NULL ARGUMENT-LIST) NIL) ((CL:ATOM ARGUMENT-LIST) (SETQ *MACRO-VARS* (CONS ARGUMENT-LIST *MACRO-VARS*)) (SETQ *MACRO-VALS* (CONS MACRO-CALL-BODY *MACRO-VALS*))) (T (SELECTQ (CAR ARGUMENT-LIST) ((&REST &BODY) (COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST) MACRO-CALL-BODY NIL) (COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST) MACRO-CALL-BODY 'AUX-ONLY)) (&WHOLE (COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST) *MACRO-FORM* 'ONE) (COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST) MACRO-CALL-BODY 'AUX-ONLY)) (&ENVIRONMENT (* dunno exactly what to do about this-- there no environments here right now) (COMPUTE-MACRO-ARGS (CADR ARGUMENT-LIST) NIL 'ONE) (COMPUTE-MACRO-ARGS (CDDR ARGUMENT-LIST) MACRO-CALL-BODY 'AUX-ONLY)) (&OPTIONAL (COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST) MACRO-CALL-BODY 'OPTIONAL)) (&AUX (COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST) MACRO-CALL-BODY 'AUX)) (&KEY (SETQ ARGUMENT-LIST (CDR ARGUMENT-LIST)) [while ARGUMENT-LIST do (SELECTQ (CAR ARGUMENT-LIST) ((&REST &ALLOW-OTHER-KEYS &AUX) (RETURN (COMPUTE-MACRO-ARGS ARGUMENT-LIST MACRO-CALL-BODY NIL))) (PROGN (LET* [(KEYWORD-VARIABLE (CAR ARGUMENT-LIST)) SUPPLIED-P-VARIABLE [DEFAULT-VALUE (COND ((CL:CONSP KEYWORD-VARIABLE) (PROG1 (CADR KEYWORD-VARIABLE) (SETQ SUPPLIED-P-VARIABLE (CADDR KEYWORD-VARIABLE)) (SETQ KEYWORD-VARIABLE (CAR KEYWORD-VARIABLE] [CL:KEYWORD (COND [(CL:CONSP KEYWORD-VARIABLE) (PROG1 (CAR KEYWORD-VARIABLE) (SETQ KEYWORD-VARIABLE (CADR KEYWORD-VARIABLE ] (T (MAKE-KEYWORD KEYWORD-VARIABLE] (FOUND-VALUE (for FM on MACRO-CALL-BODY by (CDDR FM) do (COND ((EQ (CAR FM) CL:KEYWORD) (RETURN (CDR FM] [COND (SUPPLIED-P-VARIABLE (COMPUTE-MACRO-ARGS SUPPLIED-P-VARIABLE (COND (FOUND-VALUE T) (T NIL)) 'ONE] (COMPUTE-MACRO-ARGS KEYWORD-VARIABLE (COND (FOUND-VALUE (CAR FOUND-VALUE)) (T (EVAL DEFAULT-VALUE ))) 'ONE)) (pop ARGUMENT-LIST]) (PROGN [COND [(EQ CONTEXT 'OPTIONAL) (COND [(CL:CONSP (CAR ARGUMENT-LIST)) (* an optional of the form (arg init val)) (DESTRUCTURING-BIND (ARG INIT SUPPLIEDP) (CAR ARGUMENT-LIST) (COND ((CL:ATOM MACRO-CALL-BODY) (* optional omitted) (AND SUPPLIEDP (COMPUTE-MACRO-ARGS SUPPLIEDP NIL 'ONE)) (COMPUTE-MACRO-ARGS (CAAR ARGUMENT-LIST) (EVAL INIT) 'ONE)) (T (* optional present) [COND (SUPPLIEDP (COMPUTE-MACRO-ARGS SUPPLIEDP T 'ONE] (COMPUTE-MACRO-ARGS (CAAR ARGUMENT-LIST) (CAR MACRO-CALL-BODY) NIL] (T (COND ((CL:ATOM MACRO-CALL-BODY) (* optional omitted) (COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST) *MACRO-DEFAULT* 'ONE)) (T (* optional present) (COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST) (CAR MACRO-CALL-BODY) NIL] [(EQ CONTEXT 'AUX) (for BINDING in ARGUMENT-LIST do (COND ((CL:CONSP BINDING) (COMPUTE-MACRO-ARGS (CAR BINDING) (EVAL (CADR BINDING)) 'ONE)) (T (COMPUTE-MACRO-ARGS BINDING NIL 'ONE] (T (COND ((CL:ATOM MACRO-CALL-BODY) (ERROR "macro body missing value for" ARGUMENT-LIST)) (T (COMPUTE-MACRO-ARGS (CAR ARGUMENT-LIST) (CAR MACRO-CALL-BODY) NIL] (COMPUTE-MACRO-ARGS (CDR ARGUMENT-LIST) (CDR MACRO-CALL-BODY) CONTEXT]) (MACROS.GETDEF [LAMBDA (NAME TYPE OPTIONS) (* lmm " 2-Apr-85 17:26") (MKPROGN (for X on (GETPROPLIST NAME) by (CDDR X) when (FMEMB (CAR X) MACROPROPS) collect (if (AND (EQ (CAR X) 'MACRO) (EQ (CAADR X) 'DEFMACRO)) then `(DEFMACRO %, NAME %,@ (CDR (CADR X))) else `(PUTPROPS %, NAME %, (CAR X) %, (CADR X]) (GETMACROPROP [LAMBDA (FN PROPS) (* lmm "18-APR-82 13:23") (for X in PROPS bind VAL do (COND ((SETQ VAL (GETPROP FN X)) (RETURN VAL]) (EXPANDOPENLAMBDA [LAMBDA (OPENLAM ACTUALS) (* lmm "27-FEB-83 23:26") (PROG ((FORMALS (CADR OPENLAM)) A ARGS VALS SUBSTPAIRS VAL GENARGS TMP) LP (COND ((NLISTP FORMALS) (GO OUT))) (SETQ A (CAR FORMALS)) (COND ((NLISTP ACTUALS) (* Here if ran out of actuals before formals) (for A in FORMALS do (push SUBSTPAIRS (LIST A))) (GO OUT))) (SETQ VAL (CAR ACTUALS)) (COND [(SETQ TMP (CONSTANTEXPRESSIONP VAL)) (push SUBSTPAIRS (CONS A (KWOTE (CAR TMP] (T (push ARGS A) (push VALS VAL))) (SETQ FORMALS (CDR FORMALS)) (SETQ ACTUALS (CDR ACTUALS)) (GO LP) OUT [while (AND VALS (ATOM (CAR VALS))) do (push SUBSTPAIRS (CONS (pop ARGS) (pop VALS] (SETQ OPENLAM (CDDR OPENLAM)) [COND (SUBSTPAIRS [COND (ARGS (SETQ OPENLAM (SUBPAIR ARGS [SETQ ARGS (MAPCAR ARGS (FUNCTION (LAMBDA (A) (PACK* A ( GENSYM ] OPENLAM] (* Replace variables to avoid conflict with names in substituted values) (SETQ OPENLAM (SUBLIS SUBSTPAIRS OPENLAM] (* Any ACTUALS left are extra but still need to be evaluated) (RETURN (COND (ARGS `([LAMBDA %, (SETQ ARGS (REVERSE ARGS)) (DECLARE (LOCALVARS ., ARGS)) ., OPENLAM] ., (REVERSE VALS) ., ACTUALS)) (T (MKPROGN (NCONC ACTUALS OPENLAM]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NOFIXFNSLST BYTECOMPFLG CLISPARRAY BYTEMACROPROP) ) (PUTPROPS LOADTIMECONSTANT MACRO ((X) (DEFERREDCONSTANT X))) (CL:DEFUN CSELECT (L) (* ;;; "The macro-expansion function for the optimizer on SELECT.") [LET* [(SELECTOR (CAR L)) (CLAUSES (CDR L)) (COND-FORM `(COND ,@(for TAIL on CLAUSES collect (CL:IF (NULL (CDR TAIL)) (* ; "The default clause") `(T ,(CAR TAIL)) [LET* [(CASES (CAR (CAR TAIL))) (ACTIONS (CDR (CAR TAIL))) [EQ-FORMS (FOR CASE IN (OR (LISTP CASES) (LIST CASES)) COLLECT `(EQ .SELEC. ,CASE] (TEST (CL:IF (NULL (CDR EQ-FORMS)) (CAR EQ-FORMS) `(OR ,@EQ-FORMS))] `(,TEST ,@ACTIONS])] (CL:IF (NULL CLAUSES) SELECTOR `([LAMBDA (.SELEC.) (DECLARE (LOCALVARS .SELEC.)) ,COND-FORM] ,SELECTOR))]) (DEFINEQ (PRINTCOMSTRAN [LAMBDA (FORM TAIL MACROS FILEFORM FROMDWIM) (* lmm "10-Jan-86 13:55") (* This function computes the translations for PRINTOUT type CLISP forms. FORM is the form beginning with the CLISPWORD. After it is dwimified, TAIL is applied to obtain the TAIL of printing commands. If FILEFORM~=NIL, it is applied to FORM after dwimification to produce the output file specification.) (PROG [FORMATLIST (VARS (AND FROMDWIM (APPEND (MAPCAR MACROS (FUNCTION CAR)) PRINTOUTTOKENS VARS] (DECLARE (SPECVARS VARS)) [for ARG in (CDR FORM) bind (TYPE POINT WIDTH) when [AND (LITATOM ARG) (NOT (FASSOC ARG FORMATLIST)) (EQ (CHCON1 ARG) (CHARCODE %.)) (SELCHARQ (SETQ TYPE (NTHCHARCODE ARG 2)) ((I F) T) NIL) (FIXP (SETQ WIDTH (SUBATOM ARG 3 (AND (SETQ POINT (STRPOS '%. ARG 3)) (SUB1 POINT] do (push VARS ARG) (* Suppress spelling-correction of formatcode atoms) (push FORMATLIST (CONS ARG `'(%, (COND ((EQ TYPE (CHARCODE I)) 'FIX) (T 'FLOAT)) %, WIDTH ., (while POINT collect (SUBATOM ARG (ADD1 POINT) (AND (SETQ POINT (STRPOS '%. ARG (ADD1 POINT))) (SUB1 POINT] (* Since we did all the work to decode the format, save it for later.) (AND FROMDWIM (DWIMIFY0? (CDR FORM) FORM NIL NIL NIL FAULTFN)) [COND (FILEFORM (SETQ FILEFORM (LIST (COND ((EQ FILEFORM T) T) (T (APPLY* FILEFORM FORM] (SETQ TAIL (APPLY* TAIL FORM)) (RETURN (while TAIL bind (ARG TEMP RESETOUT) collect [COND ((SETQ TEMP (ASSOC (CAR TAIL) MACROS)) (SETQ RESETOUT T) (* Probably should pass FILEFORM to macrofn, but then would have to explain interface, smashing etc.) (SETQ TAIL (APPLY* (CADR TEMP) TAIL)) (pop TAIL)) (T (SELECTQ (SETQ ARG (pop TAIL)) (.TAB0 `(TAB %, (pop TAIL) 0 ., FILEFORM)) (.TAB `(TAB %, (pop TAIL) NIL %,@ FILEFORM)) ((0 T) `(TERPRI %,@ FILEFORM)) (.RESET `(PRIN1 (CONSTANT (CHARACTER (CHARCODE CR))) %,@ FILEFORM)) (%# (SETQ RESETOUT T) (pop TAIL)) (|.P2| `(PRIN2 %, (pop TAIL) %,@ FILEFORM)) ((.PPF .PPV .PPFTL .PPVTL) `(PRINTDEF %, (pop TAIL) (POSITION %,@ FILEFORM) %, (OR (EQ ARG '.PPF) (EQ ARG '.PPFTL)) %, (OR (EQ ARG '.PPVTL) (EQ ARG '.PPFTL)) NIL %,@ FILEFORM)) (.FONT (SETQ ARG (pop TAIL)) `(CHANGEFONT %, (COND ((FIXP ARG) (PACK* 'FONT ARG)) (T ARG)) %,@ FILEFORM)) ((.SUB .SUP .BASE) `(AND FONTCHANGEFLG (PROGN (CHANGEFONT SUPERSCRIPTFONT %,@ FILEFORM) (PRIN3 %, (LIST 'QUOTE (SELECTQ ARG (.SUB (CONSTANT (CHARACTER 20))) (.SUP (CONSTANT (CHARACTER 8))) (.BASE (CONSTANT (CHARACTER 14))) NIL)) %,@ FILEFORM)))) (%, `(SPACES 1 %,@ FILEFORM)) (%,, `(SPACES 2 %,@ FILEFORM)) (%,,, `(SPACES 3 %,@ FILEFORM)) (.SP `(SPACES %, (pop TAIL) %,@ FILEFORM)) (.SKIP `(FRPTQ %, (pop TAIL) (TERPRI %,@ FILEFORM))) (.N `(PRINTNUM %, (pop TAIL) %, (pop TAIL) %,@ FILEFORM)) ((.FR .FR2 .CENTER .CENTER2) `(FLUSHRIGHT %, (pop TAIL) %, (pop TAIL) 0 %, (SELECTQ ARG ((.FR2 .CENTER2) T) NIL) %, (SELECTQ ARG ((.CENTER .CENTER2) T) NIL) %,@ FILEFORM)) ((.PARA .PARA2) `(PRINTPARA %, (pop TAIL) %, (pop TAIL) %, (pop TAIL) %, (EQ ARG '.PARA2) NIL %,@ FILEFORM)) (.PAGE `(PROGN (PRIN3 %, (LIST 'QUOTE (CHARACTER (CHARCODE FORM))) %,@ FILEFORM) (POSITION (PROGN %,@ FILEFORM) 0))) (COND ((SETQ TEMP (CDR (FASSOC ARG FORMATLIST))) `(PRINTNUM %, TEMP %, (pop TAIL) %,@ FILEFORM)) ((NOT (FIXP ARG)) `(PRIN1 %, ARG %,@ FILEFORM)) ((MINUSP ARG) `(SPACES %, (IMINUS ARG) %,@ FILEFORM)) (T `(TAB %, ARG NIL %,@ FILEFORM] finally (RETURN (COND ((AND (CAR FILEFORM) RESETOUT) `(RESETFORM (OUTPUT %, (PROG1 (CAR FILEFORM) (RPLACA FILEFORM NIL))) %,@ $$VAL)) [(LISTP (CAR FILEFORM)) `([LAMBDA ($$OUTPUT) (DECLARE (LOCALVARS $$OUTPUT)) %,@ $$VAL] %, (PROG1 (CAR FILEFORM) (RPLACA FILEFORM '$$OUTPUT] (T `(PROGN ., $$VAL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COMMENTFLG LCASEFLG PRINTOUTMACROS) ) (ADDTOVAR PRINTOUTMACROS ) (RPAQQ PRINTOUTTOKENS (.RESET .TAB %# %, %,, %,,, |.P2| .PPF .PPV .PPFTL .PPVTL .TAB0 .FR .FR2 .CENTER .CENTER2 .PARA .PARA2 .PAGE .FONT .SUP .SUB .BASE .SP .SKIP .N)) (PUTPROPS PRINTOUT INFO NOEVAL) (PUTPROPS printout INFO NOEVAL) (PUTPROPS PRINTOUT MACRO (DEFMACRO (&WHOLE X) (PRINTCOMSTRAN X (FUNCTION CDDR) PRINTOUTMACROS (FUNCTION CADR)))) (PUTPROPS printout MACRO (DEFMACRO (&WHOLE X) (PRINTCOMSTRAN X (FUNCTION CDDR) PRINTOUTMACROS (FUNCTION CADR)))) (ADDTOVAR SYSPROPS ALTOMACRO MACRO BYTEMACRO DMACRO) (PUTPROPS ALTOMACRO PROPTYPE MACROS) (PUTPROPS MACRO PROPTYPE MACROS) (PUTPROPS BYTEMACRO PROPTYPE MACROS) (PUTPROPS DMACRO PROPTYPE MACROS) (PUTPROPS GETTOPVAL SETFN SETTOPVAL) (PUTPROPS MACROS FILETYPE CL:COMPILE-FILE) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS MACROS COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7929 23852 (EXPANDMACRO 7939 . 8869) (MACROEXPANSION 8871 . 11790) (EXPAND-DEFMACRO 11792 . 12428) (COMPUTE-MACRO-ARGS 12430 . 20402) (MACROS.GETDEF 20404 . 21108) (GETMACROPROP 21110 . 21380) (EXPANDOPENLAMBDA 21382 . 23850)) (25243 34364 (PRINTCOMSTRAN 25253 . 34362))))) STOP \ No newline at end of file diff --git a/sources/MAIKOBITBLT b/sources/MAIKOBITBLT new file mode 100644 index 00000000..69da190d --- /dev/null +++ b/sources/MAIKOBITBLT @@ -0,0 +1,64 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "25-Feb-94 16:50:33" |{DSK}nilsson>mnw>MAIKOBITBLT.;1| 8778 + + |changes| |to:| (VARS MAIKOBITBLTCOMS) + + |previous| |date:| "14-Jun-90 16:57:27" |{DSK}export>lispcore>sources>MAIKOBITBLT.;1|) + + +; Copyright (c) 1988, 1989, 1990, 1994 by Venue & Xerox Corporation. All rights reserved. + +(PRETTYCOMPRINT MAIKOBITBLTCOMS) + +(RPAQQ MAIKOBITBLTCOMS ( + (* |;;| "this file has some optimizations for BITBLT on MAIKO; while PILOTBITBLT opcode still works, these functions directly implement some higher level operations") + + (FNS \\MAIKO.BITBLTSUB \\MAIKO.BLTCHAR \\MAIKO.PUNTBLTCHAR + \\MAIKO.BITBLT.BITMAP \\MAIKO.BLTSHADE.BITMAP) + + (* |;;| "Save the old \\BITBLT.BITMAP, because it handles the OPERATION - MERGE case, where the C code doesn't.") + + (P (MOVD '\\BITBLT.BITMAP '\\MAIKO.OLDBITBLT.BITMAP)) + (ADDVARS (\\MAIKO.MOVDS (\\MAIKO.BLTCHAR \\MEDW.BLTCHAR) + (\\MAIKO.BITBLTSUB \\BITBLTSUB) + (\\MAIKO.BITBLT.BITMAP \\BITBLT.BITMAP) + (\\MAIKO.BLTSHADE.BITMAP \\BLTSHADE.BITMAP))))) + + + +(* |;;| +"this file has some optimizations for BITBLT on MAIKO; while PILOTBITBLT opcode still works, these functions directly implement some higher level operations" +) + +(DEFINEQ + +(\\MAIKO.BITBLTSUB (LAMBDA (PILOTBBT |SourceBitMap| SLX STY |DestinationBitMap| DLX DTY HEIGHT |SourceType| |Operation| |Texture| |WindowXOffset| |WindowYOffset|) (* \; "Edited 29-Jun-88 16:24 by ") (* |;;| "replaces \\BITBLTSUB on Maiko") ((OPCODES SUBRCALL 69 13) PILOTBBT |SourceBitMap| SLX STY |DestinationBitMap| DLX DTY HEIGHT |SourceType| |Operation| |Texture| |WindowXOffset| |WindowYOffset|))) + +(\\MAIKO.BLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) ((OPCODES SUBRCALL 135 3) CHARCODE DISPLAYSTREAM DISPLAYDATA))) + +(\\MAIKO.PUNTBLTCHAR (LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* \; "Edited 29-Jun-88 16:04 by ") (* |;;| "puts a character on a display stream. This function will be called when \\maiko.bltchar failed. Punt from subr call") (DECLARE (LOCALVARS . T)) (PROG (LOCAL1 RIGHT LEFT CURX CHAR8CODE) (SETQ CHAR8CODE (\\CHAR8CODE CHARCODE)) CRLP (COND ((NOT (EQ (|ffetch| (\\DISPLAYDATA DDCHARSET) |of| DISPLAYDATA) (\\CHARSET CHARCODE))) (\\CHANGECHARSET.DISPLAY DISPLAYDATA (\\CHARSET CHARCODE)))) (COND ((|ffetch| (\\DISPLAYDATA |DDSlowPrintingCase|) |of| DISPLAYDATA) (RETURN (\\SLOWBLTCHAR CHARCODE DISPLAYSTREAM)))) (SETQ CURX (|ffetch| (\\DISPLAYDATA DDXPOSITION) |of| DISPLAYDATA)) (SETQ RIGHT (IPLUS CURX (\\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA))) (COND ((IGREATERP RIGHT (|ffetch| (\\DISPLAYDATA |DDRightMargin|) |of| DISPLAYDATA)) (* \;  "would go past right margin, force a cr") (COND ((IGREATERP CURX (|ffetch| (\\DISPLAYDATA |DDLeftMargin|) |of| DISPLAYDATA)) (* \;  "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\\DSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* \;  "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP))))) (* \;  "update the display stream x position.") (|freplace| (\\DISPLAYDATA DDXPOSITION) |of| DISPLAYDATA |with| (IPLUS CURX (\\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) (* \;  "transforms an x coordinate into the destination coordinate.") (SETQ LOCAL1 (|ffetch| (\\DISPLAYDATA DDXOFFSET) |of| DISPLAYDATA)) (SETQ CURX (IPLUS CURX LOCAL1)) (SETQ RIGHT (IPLUS RIGHT LOCAL1)) (COND ((IGREATERP RIGHT (SETQ LOCAL1 (|ffetch| (\\DISPLAYDATA |DDClippingRight|) |of| DISPLAYDATA))) (* \;  "character overlaps right edge of clipping region.") (SETQ RIGHT LOCAL1))) (SETQ LEFT (COND ((IGREATERP CURX (SETQ LOCAL1 (|ffetch| (\\DISPLAYDATA |DDClippingLeft|) |of| DISPLAYDATA))) CURX) (T LOCAL1))) (RETURN (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|fetch| (PILOTBBT PBTHEIGHT) |of| (SETQ LOCAL1 (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DISPLAYDATA) )) 0))) (.WHILE.TOP.DS. DISPLAYSTREAM ((OPCODES SUBRCALL 70 6) LOCAL1 DISPLAYDATA CHAR8CODE CURX LEFT RIGHT)) T)))))) + +(\\MAIKO.BITBLT.BITMAP (LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (* \; "Edited 14-Jun-90 16:47 by TS") (* |;;| "SUN version of \\BITBLT.BITMAP. For all but the MERGE case, use C code. For the MERGE case, use the old code.") (* |;;| "Jun-14 Now,C function, bitblt_bitmap , has PUNT case for MREGE case(Takeshi)") (* |;;| "\\MAIKO.OLDBITBLT.BITMAP is obsolete, \\PUNT.BITBLT.BITMAP is there.") (* |;;| "") (* |;;| "(COND ((EQ SOURCETYPE 'MERGE) (\\\\MAIKO.OLDBITBLT.BITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)) (T (SUBRCALL BITBLT.BITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)))") (SUBRCALL BITBLT.BITMAP SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) + +(\\MAIKO.BLTSHADE.BITMAP (LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* \; "Edited 14-Jun-90 16:49 by TS") (DECLARE (LOCALVARS . T)) (* |;;| "C function, bitshade_bitmap , has PUNT case \\PUNT.BLTSHADE.BITMAP(Takeshi)") (SUBRCALL BLTSHADE.BITMAP TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION))) +) + + + +(* |;;| +"Save the old \\BITBLT.BITMAP, because it handles the OPERATION - MERGE case, where the C code doesn't." +) + + +(MOVD '\\BITBLT.BITMAP '\\MAIKO.OLDBITBLT.BITMAP) + +(ADDTOVAR \\MAIKO.MOVDS (\\MAIKO.BLTCHAR \\MEDW.BLTCHAR) + (\\MAIKO.BITBLTSUB \\BITBLTSUB) + (\\MAIKO.BITBLT.BITMAP \\BITBLT.BITMAP) + (\\MAIKO.BLTSHADE.BITMAP \\BLTSHADE.BITMAP)) +(PUTPROPS MAIKOBITBLT COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1994)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (1600 8233 (\\MAIKO.BITBLTSUB 1610 . 2130) (\\MAIKO.BLTCHAR 2132 . 2272) ( +\\MAIKO.PUNTBLTCHAR 2274 . 6375) (\\MAIKO.BITBLT.BITMAP 6377 . 7729) (\\MAIKO.BLTSHADE.BITMAP 7731 . +8231))))) +STOP diff --git a/sources/MAIKOCOLOR b/sources/MAIKOCOLOR new file mode 100644 index 00000000..db3f2ff2 --- /dev/null +++ b/sources/MAIKOCOLOR @@ -0,0 +1,972 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "23-Oct-91 14:43:35" |{PELE:MV:ENVOS}LIBRARY>MAIKOCOLOR.;6| 57582 + + changes to%: (VARS MAIKOCOLORCOMS) + (FNS \MAIKOCOLOR.EVENTFN) + + previous date%: "22-Aug-91 17:11:25" |{PELE:MV:ENVOS}LIBRARY>MAIKOCOLOR.;3|) + + +(* ; " +Copyright (c) 1988, 1989, 1990, 1991 by Fuji Xerox Co., Ltd.. All rights reserved. +") + +(PRETTYCOMPRINT MAIKOCOLORCOMS) + +(RPAQQ MAIKOCOLORCOMS + [(P (MOVD? 'BITBLT 'ORG.BITBLT) + (MOVD? 'BLTSHADE 'ORG.BLTSHADE) + (MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) + (MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) + (MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP)) + (FNS \MAIKO.COLORINIT \MAIKO.STARTCOLOR \MAIKO.STOPCOLOR \MAIKOCOLOR.EVENTFN + \MAIKO.SENDCOLORMAPENTRY \MAIKO.CHANGESCREEN) + (FNS CURSOREXIT CURSORSCREEN WARPCURSOR \SLOWBLTCHAR \SOFTCURSORUP \BITBLT.DISPLAY) + (* ; + "these FNS defs. will be moved to original files,later") + (FNS \PUNT.SLOWBLTCHAR \MAIKO.PUNTBLTCHAR \MAIKO.BLTCHAR) + (FNS \PUNT.BLTSHADE.BITMAP \PUNT.BITBLT.BITMAP) + (FNS BITMAPOBJ.SNAPW) + (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \MAIKO.CGTHREEP \MAIKO.CGFOURP \MAIKO.CGSIXP + \MAIKO.CGTWOP) + (CONSTANTS (\TO.MAIKO.MONOSCREEN 0) + (\TO.MAIKO.COLORSCREEN 1) + (\MAIKO.COLORSCREENWIDTH 1152) + (\MAIKO.COLORSCREENHEIGHT 900) + (\MAIKO.COLORPAGES 2048) + (\MAIKO.COLORBUF.ALIGN 4095)) + (FILES (LOADCOMP) + LLDISPLAY BIGBITMAPS)) + (INITVARS \MONO.PROMPTWINDOW \COLOR.PROMPTWINDOW) + (GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) + (FILES COLOR BIGBITMAPS) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) + (MOVD '\MAIKO.BLTCHAR '\BILTCHAR) + (\MAIKO.COLORINIT) + (COLORDISPLAY 'ON 'MAIKOCOLOR) + (CURSORSCREEN (COLORSCREEN) + 100 100) + (CHANGEBACKGROUND 36) + (ADD-EXEC :TTY T :REGION '(0 650 370 150)) + (LOGOW]) + +(MOVD? 'BITBLT 'ORG.BITBLT) + +(MOVD? 'BLTSHADE 'ORG.BLTSHADE) + +(MOVD? '\SLOWBLTCHAR '\OLD.SLOWBLTCHAR) + +(MOVD? 'CURSOREXIT 'OLD.CURSOREXIT) + +(MOVD? '\SOFTCURSORUP '\OLD.SOFTCURSORUP) +(DEFINEQ + +(\MAIKO.COLORINIT + [LAMBDA NIL + (DECLARE (GLOBALVARS \MAIKOCOLORWSOPS \MAIKOCOLORINFO)) + (* ; "Edited 28-Apr-89 16:51 by tshimizu.fx") + (SETQ \MAIKOCOLORWSOPS (create WSOPS + STARTBOARD _ (FUNCTION NILL) + STARTCOLOR _ (FUNCTION \MAIKO.STARTCOLOR) + STOPCOLOR _ (FUNCTION \MAIKO.STOPCOLOR) + EVENTFN _ (FUNCTION \MAIKOCOLOR.EVENTFN) + SENDCOLORMAPENTRY _ (FUNCTION \MAIKO.SENDCOLORMAPENTRY) + SENDPAGE _ (FUNCTION NILL) + PILOTBITBLT _ (FUNCTION \DISPLAY.PILOTBITBLT))) + (SETQ \MAIKOCOLORINFO (create DISPLAYINFO + DITYPE _ 'MAIKOCOLOR + DIWIDTH _ \MAIKO.COLORSCREENWIDTH + DIHEIGHT _ \MAIKO.COLORSCREENHEIGHT + DIBITSPERPIXEL _ 8 + DIWSOPS _ \MAIKOCOLORWSOPS)) + (\DEFINEDISPLAYINFO \MAIKOCOLORINFO]) + +(\MAIKO.STARTCOLOR + [LAMBDA (FDEV) (* ; "Edited 2-Nov-88 11:13 by shimizu") + (PROG (DISPLAYSTATE) + (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) + (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'STARTCOLOR) + (MOVD '\DISPLAY.PILOTBITBLT '\SOFTCURSORPILOTBITBLT) + + (* ;; " MMAP colorbuffer") + + ((OPCODES SUBRCALL 136 1) + (FETCH (BITMAP BITMAPBASE) OF ColorScreenBitMap)) + (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'ON]) + +(\MAIKO.STOPCOLOR + [LAMBDA (FDEV) (* ; "Edited 28-Apr-89 16:51 by tshimizu.fx") + (* ; "By Take") + (PROG (DISPLAYSTATE) + (SETQ DISPLAYSTATE (fetch (FDEV DEVICEINFO) of FDEV)) + (replace (DISPLAYSTATE ONOFF) of DISPLAYSTATE with 'OFF]) + +(\MAIKOCOLOR.EVENTFN + [LAMBDA (FDEV EVENT) (* ; "Edited 23-Oct-91 14:18 by jds") + (COND + ((EQ (fetch (DISPLAYSTATE ONOFF) of (fetch (FDEV DEVICEINFO) of FDEV)) + 'ON) + (SELECTQ EVENT + ((AFTERSAVEVM AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS) + (\MAIKO.STARTCOLOR \COLORDISPLAYFDEV) + (SCREENCOLORMAP (SCREENCOLORMAP)) + (COND + ((EQ LASTSCREEN (COLORSCREEN)) + (CURSORSCREEN (COLORSCREEN) + 200 200)))) + NIL]) + +(\MAIKO.SENDCOLORMAPENTRY + [LAMBDA (FDEV COLOR# RGB) (* ; "Edited 1-Dec-88 18:16 by shimizu") + ((OPCODES SUBRCALL 138 4) + COLOR# + (CAR RGB) + (CADR RGB) + (CADDR RGB]) + +(\MAIKO.CHANGESCREEN + [LAMBDA (TOSCREEN) (* ; "Edited 1-Dec-88 18:32 by shimizu") + ((OPCODES SUBRCALL 137 1) + TOSCREEN]) +) +(DEFINEQ + +(CURSOREXIT + [LAMBDA NIL (* ; "Edited 11-Aug-89 13:16 by takeshi") + + (* * called when cursor moves off the screen edge) + + (DECLARE (GLOBALVARS LASTSCREEN LASTMOUSEX LASTMOUSEY \MAIKO.CURRENT.SCREEN.MODE)) + (PROG (SCREEN XCOORD YCOORD SCREEN2 XCOORD2 YCOORD2) + (SETQ SCREEN LASTSCREEN) + (SETQ XCOORD LASTMOUSEX) + (SETQ YCOORD LASTMOUSEY) + [SETQ SCREEN2 (COND + ((EQ SCREEN \MAINSCREEN) + (PROGN \COLORSCREEN)) + (T (PROGN \MAINSCREEN] (* generalize for more than two + screens (or alternate physical + arrangement of screens.)) + (COND + ((EQ XCOORD 0) + (SETQ XCOORD2 (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN2) + 2))) + ((EQ XCOORD (SUB1 (fetch (SCREEN SCWIDTH) of SCREEN))) + (SETQ XCOORD2 1)) + (T (RETURN))) + [SETQ YCOORD2 (IQUOTIENT (ITIMES YCOORD (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN2)) + ) + (SUB1 (fetch (SCREEN SCHEIGHT) of SCREEN] + (CURSORSCREEN SCREEN2 XCOORD2 YCOORD2]) + +(CURSORSCREEN + [LAMBDA (SCREEN XCOORD YCOORD) (* ; "Edited 19-Jun-90 16:33 by matsuda") + + (* * sets up SCREEN to be the current screen, XCOORD %, YCOORD is initial pos + of cursor on SCREEN) + + (COND + ((NULL XCOORD) + (SETQ XCOORD 0))) + (COND + ((NULL YCOORD) + (SETQ YCOORD 0))) + (PROG (DESTINATION) + (SETQ DESTINATION (fetch (SCREEN SCDESTINATION) of SCREEN)) + (\CURSORDOWN) + (SETQ \CURSORSCREEN SCREEN) + (\CURSORDESTINATION DESTINATION) + (\CURSORUP \CURRENTCURSOR) + (\CURSORPOSITION XCOORD YCOORD) + (AND (EQUAL (MACHINETYPE) + 'MAIKO) + (COND + ((EQ (fetch (SCREEN SCBITSPERPIXEL) of SCREEN) + 1) + (SETQ \COLOR.PROMPTWINDOW PROMPTWINDOW) + (\MAIKO.CHANGESCREEN \TO.MAIKO.MONOSCREEN) + (SETQ PROMPTWINDOW \MONO.PROMPTWINDOW)) + (T (SETQ \MONO.PROMPTWINDOW PROMPTWINDOW) + (\MAIKO.CHANGESCREEN \TO.MAIKO.COLORSCREEN) + (SETQ PROMPTWINDOW (OR \COLOR.PROMPTWINDOW + (PROG1 (SETQ W (CREATEW '(0 800 370 80) + "Prompt Window" 2)) + (SETQ DISPLAYDATA (FETCH IMAGEDATA + OF (FETCH (WINDOW DSP) + OF W))) + (REPLACE DDOPERATION OF DISPLAYDATA + WITH 'ERASE) + (REPLACE DDTexture OF DISPLAYDATA + WITH 65535) + (CLEARW W))]) + +(WARPCURSOR + [LAMBDA (ENABLE) (* ; "Edited 20-Jul-90 19:02 by matsuda") + (COND + (ENABLE (MOVD 'SAVE.CURSOREXIT 'CURSOREXIT) + T) + (T (MOVD 'NILL 'CURSOREXIT) + NIL]) + +(\SLOWBLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 7-Jun-90 14:06 by matsuda") + ((OPCODES SUBRCALL 140 2) + CHARCODE DISPLAYSTREAM]) + +(\SOFTCURSORUP + [LAMBDA (NEWCURSOR) (* ; "Edited 16-Jan-89 15:44 by shimizu") + (* Put soft NEWCURSOR up, assuming + soft cursor is down. + *) + (COND + ((EQ \MACHINETYPE \MAIKO) + (SETQ \CURRENTCURSOR NEWCURSOR)) + (T (PROG (IMAGE MASK WIDTH BWIDTH HEIGHT CURSORBITSPERPIXEL CURSORBPL UPBMBASE DOWNBMBASE) + (* Get cursor IMAGE & MASK. + *) + (SETQ IMAGE (fetch (CURSOR CUIMAGE) of NEWCURSOR)) + (SETQ MASK (fetch (CURSOR CUMASK) of NEWCURSOR)) + (SETQ WIDTH (fetch (BITMAP BITMAPWIDTH) of IMAGE)) + (SETQ HEIGHT (fetch (BITMAP BITMAPHEIGHT) of IMAGE)) + (SETQ CURSORBITSPERPIXEL (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE)) + (* Create new UPBM & DOWNBM caches + if necessary. *) + (COND + ((NOT (AND (type? BITMAP \SOFTCURSORUPBM) + (EQ (fetch (BITMAP BITMAPWIDTH) of \SOFTCURSORUPBM) + WIDTH) + (EQ (fetch (BITMAP BITMAPHEIGHT) of \SOFTCURSORUPBM) + HEIGHT) + (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of \SOFTCURSORUPBM) + CURSORBITSPERPIXEL))) + (SETQ \SOFTCURSORWIDTH WIDTH) + (SETQ \SOFTCURSORHEIGHT HEIGHT) + (SETQ \SOFTCURSORUPBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) + (SETQ \SOFTCURSORDOWNBM (BITMAPCREATE WIDTH HEIGHT CURSORBITSPERPIXEL)) + (SETQ UPBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORUPBM)) + (\TEMPLOCKPAGES UPBMBASE 1) + (SETQ DOWNBMBASE (fetch (BITMAP BITMAPBASE) of \SOFTCURSORDOWNBM)) + (\TEMPLOCKPAGES DOWNBMBASE 1) + (SETQ CURSORBPL (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) of IMAGE) + BITSPERWORD)) + (SETQ BWIDTH (ITIMES (fetch (BITMAP BITMAPWIDTH) of IMAGE) + (fetch (BITMAP BITMAPBITSPERPIXEL) of IMAGE))) + (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT1 with CURSORBPL) + (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT2 with UPBMBASE) + (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT2 with CURSORBPL) + (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT2 with DOWNBMBASE) + (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT2 with CURSORBPL) + (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT2 with BWIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT2 with HEIGHT) + (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT3 with UPBMBASE) + (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT3 with CURSORBPL) + (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT3 with CURSORBPL) + (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT3 with BWIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT3 with HEIGHT) + (replace (PILOTBBT PBTDEST) of \SOFTCURSORBBT4 with UPBMBASE) + (replace (PILOTBBT PBTDESTBPL) of \SOFTCURSORBBT4 with CURSORBPL) + (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT4 with CURSORBPL) + (replace (PILOTBBT PBTWIDTH) of \SOFTCURSORBBT4 with BWIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SOFTCURSORBBT4 with HEIGHT) + (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT5 with CURSORBPL) + (replace (PILOTBBT PBTSOURCEBPL) of \SOFTCURSORBBT6 with CURSORBPL))) + (* Change PILOTBBTs. + *) + (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT3 with (fetch + (BITMAP BITMAPBASE + ) + of MASK)) + (replace (PILOTBBT PBTSOURCE) of \SOFTCURSORBBT4 with (fetch + (BITMAP BITMAPBASE + ) + of IMAGE)) + (* Put up new \CURRENTCURSOR. + *) + (SETQ \CURRENTCURSOR NEWCURSOR) + (\TEMPLOCKPAGES \CURRENTCURSOR 1) + (SETQ \SOFTCURSORP T) + (\SOFTCURSORUPCURRENT]) + +(\BITBLT.DISPLAY + [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH + HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT + CLIPPEDSOURCEBOTTOM) (* ; "Edited 24-Jan-91 11:57 by matsuda") + (DECLARE (LOCALVARS . T)) + (DECLARE (GLOBALVARS \SYSPILOTBBT \SCREENBITMAPS \BBSCRATCHTEXTURE \SOFTCURSORP + \SOFTCURSORUPP \CURSORDESTINATION)) + (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE) + (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) + (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) + + (* ;; "bring it to top so that its TOTOPFNs will get called before the destination information is cached in case one of them moves, reshapes, etc. the window") + + (* ;; "We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic. But we might get interrupted before we go interruptable, so we do it there too.") + + (\INSURETOPWDS DESTSTRM) + (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) + (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) + [PROGN (* ; + "compute limits based on clipping regions.") + (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) + (SETQ bottom (ffetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) + (SETQ right (ffetch (\DISPLAYDATA DDClippingRight) of DESTDD)) + (SETQ top (ffetch (\DISPLAYDATA DDClippingTop) of DESTDD)) + (COND + (CLIPPINGREGION (* ; + "hard case, two destination clipping regions: do calculations to merge them.") + (PROG (CRLEFT CRBOTTOM) + [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX + (fetch (REGION LEFT) + of CLIPPINGREGION) + DESTDD] + [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY + (ffetch (REGION BOTTOM + ) + of CLIPPINGREGION) + DESTDD] + [SETQ right (IMIN right (IPLUS CRLEFT (ffetch (REGION WIDTH) + of CLIPPINGREGION] + (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) + of CLIPPINGREGION] + (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTBITMAP)) + (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP)) + [COND + ((NOT (EQ SOURCENBITS DESTINATIONNBITS)) + (COND + ((EQ SOURCENBITS 1) + (SETQ SOURCEBITMAP (COLORIZEBITMAP SOURCEBITMAP (ffetch DDBACKGROUNDCOLOR + of DESTDD) + (ffetch DDFOREGROUNDCOLOR of DESTDD) + DESTINATIONNBITS))) + [(EQ DESTINATIONNBITS 1) + (SETQ SOURCEBITMAP (UNCOLORIZEBITMAP SOURCEBITMAP (COLORMAP DESTINATIONNBITS] + (T + (* ;; "Between two color bitmaps with different bpp. It seems that NOP is better than breaking. Eventually do some kind of output here, but don't error now. ") + + (RETURN] + + (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") + + [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) + (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) + [COND + (WIDTH (* ; "WIDTH is optional") + (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) + right] + (COND + (HEIGHT (* ; "HEIGHT is optional") + (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) + top] (* ; "Clip and translate coordinates.") + (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) + (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) + + (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") + + [PROGN (* ; "compute left margin") + (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) + 0)) (* ; "compute bottom margin") + (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody) + 0)) (* ; "compute right margin") + (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) + (IDIFFERENCE right stodx) + (IPLUS CLIPPEDSOURCELEFT WIDTH))) + (* ; "compute top margin") + (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) + (IDIFFERENCE top stody) + (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] + (COND + ((OR (ILEQ right left) + (ILEQ top bottom)) (* ; "there is nothing to move.") + (RETURN))) + (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) + (SETQ MAXSHADE (MAXIMUMSHADE DESTINATIONNBITS)) + (SELECTQ SOURCETYPE + (MERGE (* ; + "Need to use complement of TEXTURE") + [COND + ((AND (LISTP TEXTURE) + (EQ DESTINATIONNBITS 1)) (* ; + "either a color or a (texture color) filling.") + (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE] + [SETQ TEXTURE (COND + ((NULL TEXTURE) + MAXSHADE) + ((FIXP TEXTURE) + (LOGXOR (LOGAND TEXTURE MAXSHADE) + MAXSHADE)) + [(type? BITMAP TEXTURE) + (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE + (SETQ \BBSCRATCHTEXTURE + (BITMAPCREATE 16 16] + ((NOT (EQ DESTINATIONNBITS 1)) + (COLORNUMBERP TEXTURE DESTINATIONNBITS)) + (T (\ILLEGAL.ARG TEXTURE] + [COND + ((NOT (EQ DESTINATIONNBITS 1)) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]) + (TEXTURE [COND + ((EQ DESTINATIONNBITS 1) (* ; + "either a color or a (texture color) filling.") + (SETQ TEXTURE (INSURE.B&W.TEXTURE TEXTURE]) + NIL) + [COND + ((AND (NOT (EQ DESTINATIONNBITS 1)) + (NOT (type? BIGBM SOURCEBITMAP)) + (NOT (type? BIGBM DESTBITMAP))) + (SETQ left (ITIMES DESTINATIONNBITS left)) + (SETQ right (ITIMES DESTINATIONNBITS right)) + (SETQ stodx (ITIMES DESTINATIONNBITS stodx] + [.WHILE.TOP.DS. DESTSTRM + (COND + [(AND (NOT (type? BIGBM SOURCEBITMAP)) + (NOT (type? BIGBM DESTBITMAP))) + (PROG (HEIGHT WIDTH DTY DLX STY SLX) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (SETQ WIDTH (IDIFFERENCE right left)) + (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) + (SETQ DLX (IPLUS left stodx)) + (SETQ STY (\SFInvert SOURCEBITMAP top)) + (SETQ SLX left) + (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) + (COND + ((EQ SOURCETYPE 'MERGE) + (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY + WIDTH HEIGHT OPERATION TEXTURE)) + (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY + HEIGHT SOURCETYPE OPERATION TEXTURE] + (T (PROG (HEIGHT WIDTH DBY DLX SBY SLX) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (SETQ WIDTH (IDIFFERENCE right left)) + (SETQ DBY (IPLUS bottom stody)) + (SETQ DLX (IPLUS left stodx)) + (SETQ SBY bottom) + (SETQ SLX left) + (BITBLT.BIGBM SOURCEBITMAP SLX SBY DESTBITMAP DLX DBY WIDTH HEIGHT + SOURCETYPE OPERATION TEXTURE] + (RETURN T]) +) + + + +(* ; "these FNS defs. will be moved to original files,later") + +(DEFINEQ + +(\PUNT.SLOWBLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM) (* ; "Edited 2-Jul-90 14:23 by matsuda") + + (* ;; "case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a display stream, and its cache fields have been updated for CHARCODE's charset") + + (PROG (ROTATION CHAR8CODE DD FONTDESC) + (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) + (SETQ DD (ffetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) + (SETQ FONTDESC (ffetch (\DISPLAYDATA DDFONT) of DD)) + (SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of FONTDESC)) + (COND + ((EQ 0 ROTATION) + (PROG (NEWX LEFT RIGHT CURX PILOTBBT DESTBIT WIDTH SOURCEBIT CSINFO) + (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) + (ffetch (\DISPLAYDATA DDFONT) of DD))) + (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) + (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD))) + [COND + ((IGREATERP NEWX (ffetch (\DISPLAYDATA DDRightMargin) of DD)) + (* ; "past RIGHT margin, force eol") + (\DSPPRINTCR/LF (CHARCODE EOL) + DISPLAYSTREAM) + (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DD)) + (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DD] + (* ; "update the x position.") + (freplace (\DISPLAYDATA DDXPOSITION) of DD with NEWX) + (* SETQ CURX (\DSPTRANSFORMX CURX DD)) + (SETQ LEFT (IMAX (ffetch (\DISPLAYDATA DDClippingLeft) of DD) + CURX)) + (SETQ RIGHT (IMIN (ffetch (\DISPLAYDATA DDClippingRight) of DD) + (\DSPTRANSFORMX NEWX DD))) + (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + (\DSPGETCHAROFFSET CHAR8CODE DD) + 0 DISPLAYSTREAM CURX (IDIFFERENCE (ffetch (\DISPLAYDATA DDYPOSITION) + of DD) + (ffetch (CHARSETINFO CHARSETDESCENT) + of CSINFO)) + (\DSPGETCHARWIDTH CHAR8CODE DD) + (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))) + (* ; "(SETQ PILOTBBT (|ffetch| (\\DISPLAYDATA DDPILOTBBT) |of| DD)) (COND ((AND (ILESSP LEFT RIGHT) (NOT (EQ (|ffetch| (PILOTBBT PBTHEIGHT) |of| PILOTBBT) 0))) (SETQ DESTBIT LEFT) (SETQ WIDTH (IDIFFERENCE RIGHT LEFT)) (SETQ SOURCEBIT (IDIFFERENCE (IPLUS (\\DSPGETCHAROFFSET CHAR8CODE DD) LEFT) CURX)) (SELECTQ (|ffetch| (BITMAP BITMAPBITSPERPIXEL) |of| (|ffetch| (\\DISPLAYDATA |DDDestination|) |of| DD)) (1) (4 (SETQ DESTBIT (LLSH DESTBIT 2)) (SETQ WIDTH (LLSH WIDTH 2)) (SETQ SOURCEBIT (LLSH SOURCEBIT 2))) (8 (SETQ DESTBIT (LLSH DESTBIT 3)) (SETQ WIDTH (LLSH WIDTH 3)) (SETQ SOURCEBIT (LLSH SOURCEBIT 3))) (24 (SETQ DESTBIT (ITIMES 24 DESTBIT)) (SETQ WIDTH (ITIMES 24 WIDTH)) (SETQ SOURCEBIT (ITIMES 24 SOURCEBIT))) (SHOULDNT)) (.WHILE.TOP.DS. DISPLAYSTREAM (|freplace| (PILOTBBT PBTDESTBIT) |of| PILOTBBT |with| DESTBIT) (|freplace| (PILOTBBT PBTWIDTH) |of| PILOTBBT |with| WIDTH) (|freplace| (PILOTBBT PBTSOURCEBIT) |of| PILOTBBT |with| SOURCEBIT) (\\PILOTBITBLT PILOTBBT 0)) T))") + )) + (T (* ; "handle rotated fonts") + (PROG (YPOS HEIGHTMOVED CSINFO) + (SETQ YPOS (ffetch (\DISPLAYDATA DDYPOSITION) of DD)) + (SETQ HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD)) + (SETQ CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE) + (ffetch (\DISPLAYDATA DDFONT) of DD))) + (COND + ((EQ ROTATION 90) (* ; + "don't force CR for rotated fonts.") + (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED)) + (* ; + "update the display stream x position.") + (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + 0 + (\DSPGETCHAROFFSET CHAR8CODE DD) + DISPLAYSTREAM + (ADD1 (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) + of DD) + (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)) + ) + YPOS + (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + HEIGHTMOVED)) + ((EQ ROTATION 270) + (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)) + (BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO) + 0 + (\GETBASE (ffetch (\DISPLAYDATA DDOFFSETSCACHE) of DD) + CHAR8CODE) + DISPLAYSTREAM + (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) + (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYSTREAM) + (IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO) + (ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO)) + HEIGHTMOVED)) + (T (ERROR "Not implemented to rotate by other than 0, 90 or 270"]) + +(\MAIKO.PUNTBLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 1-Nov-89 15:26 by takeshi") + + (* ;; "puts a character on a display stream. This function will be called when \maiko.bltchar failed. Punt from subr call") + + (DECLARE (LOCALVARS . T)) + (PROG (LOCAL1 RIGHT LEFT CURX CHAR8CODE) + (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) + CRLP + [COND + ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) + (\CHARSET CHARCODE))) + (\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE] + [COND + ((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA) + (RETURN (COND + ((type? STREAM DISPLAYSTREAM) + (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM)) + ((type? WINDOW DISPLAYSTREAM) + (\SLOWBLTCHAR CHARCODE (FETCH DSP OF DISPLAYSTREAM))) + (T (ERROR "Not Stream or Window" DISPLAYSTREAM] + (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) + (SETQ RIGHT (IPLUS CURX (\DSPGETCHARIMAGEWIDTH CHAR8CODE DISPLAYDATA))) + [COND + ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) + (* ; + "would go past right margin, force a cr") + (COND + ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) + (* ; + "don't bother CR if position is at left margin anyway. This also serves to break the loop.") + (\DSPPRINTCR/LF (CHARCODE EOL) + DISPLAYSTREAM) (* ; + "reuse the code in the test of this conditional rather than repeat it here.") + (GO CRLP] (* ; + "update the display stream x position.") + (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX + ( + \DSPGETCHARWIDTH + CHAR8CODE + DISPLAYDATA))) + (* ; + "transforms an x coordinate into the destination coordinate.") + (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) + (SETQ CURX (IPLUS CURX LOCAL1)) + (SETQ RIGHT (IPLUS RIGHT LOCAL1)) + (COND + ((IGREATERP RIGHT (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingRight) of + DISPLAYDATA + ))) (* ; + "character overlaps right edge of clipping region.") + (SETQ RIGHT LOCAL1))) + (SETQ LEFT (COND + ((IGREATERP CURX (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDClippingLeft) + of DISPLAYDATA))) + CURX) + (T LOCAL1))) + (RETURN (COND + ((AND (ILESSP LEFT RIGHT) + (NOT (EQ (fetch (PILOTBBT PBTHEIGHT) of (SETQ LOCAL1 + (ffetch (\DISPLAYDATA + DDPILOTBBT) + of DISPLAYDATA))) + 0))) + (.WHILE.TOP.DS. DISPLAYSTREAM ((OPCODES SUBRCALL 70 6) + LOCAL1 DISPLAYDATA CHAR8CODE CURX LEFT RIGHT)) + T]) + +(\MAIKO.BLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* ; "Edited 6-Jul-90 10:14 by matsuda") + ((OPCODES SUBRCALL 135 3) + CHARCODE DISPLAYSTREAM DISPLAYDATA]) +) +(DEFINEQ + +(\PUNT.BLTSHADE.BITMAP + [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION + CLIPPINGREGION) (* ; "Edited 5-Jun-90 12:12 by Takeshi") + + (* ;; "This FNS is for a punt case of \BLTSHADE.BITMAP which is implemeted in C ") + (* ; + " Stolen from old definition of \BLTSHADE.BITMAP") + (DECLARE (LOCALVARS . T)) + (PROG (left bottom top right DESTINATIONNBITS) + (SETQ left 0) + (SETQ bottom 0) + (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTINATIONBITMAP)) + (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTINATIONBITMAP)) + (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)) + (COND + ((EQ DESTINATIONNBITS 1) (* ; + "DESTINATIONNBITS is NIL for the case of 1 bit per pixel.") + (SETQ DESTINATIONNBITS NIL))) + [COND + (CLIPPINGREGION (* ; "adjust limits") + (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) + (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) + [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) + (fetch (REGION LEFT) of CLIPPINGREGION] + (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) + (fetch (REGION HEIGHT) of CLIPPINGREGION] + (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) + (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) + + (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") + + [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) + (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) + [COND + (WIDTH (* ; "WIDTH is optional") + (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) + right] + (COND + (HEIGHT (* ; "HEIGHT is optional") + (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) + top] + (COND + ((OR (ILEQ right left) + (ILEQ top bottom)) (* ; "there is nothing to move.") + (RETURN))) + (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) + (LITATOM (* ; "includes NIL case") + (COND + [DESTINATIONNBITS (COND + (TEXTURE + (* ; "should be a color name") + (OR (COLORNUMBERP TEXTURE + DESTINATIONNBITS T) + (\ILLEGAL.ARG TEXTURE))) + (T (MAXIMUMCOLOR DESTINATIONNBITS] + (TEXTURE (\ILLEGAL.ARG TEXTURE)) + (T WHITESHADE))) + ((SMALLP FIXP) + (COND + [DESTINATIONNBITS + + (* ;; "if fixp use the low order bits as a color number. This picks up the case of BLACKSHADE being used to INVERT.") + + (OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T) + (LOGAND TEXTURE (MAXIMUMCOLOR DESTINATIONNBITS] + (T (LOGAND TEXTURE BLACKSHADE)))) + (BITMAP TEXTURE) + (LISTP (* ; + "can be a list of (TEXTURE COLOR) or a list of levels rgb or hls.") + (COND + [DESTINATIONNBITS + + (* ;; "color case: If it is a color, use it; if it is a list that contains a color, use that; otherwise, use the texture") + + (COND + ((COLORNUMBERP TEXTURE)) + [(COLORNUMBERP (CAR (LISTP (CDR TEXTURE] + ((FIXP (CAR TEXTURE)) + (LOGAND (CAR TEXTURE) + (MAXIMUMCOLOR DESTINATIONNBITS))) + ((TEXTUREP (CAR TEXTURE))) + (T (\ILLEGAL.ARG TEXTURE] + ((TEXTUREP (CAR TEXTURE))) + ((COLORNUMBERP TEXTURE) + (TEXTUREOFCOLOR TEXTURE)) + (T (\ILLEGAL.ARG TEXTURE)))) + (\ILLEGAL.ARG TEXTURE))) (* ; "filling an area with a texture.") + [COND + (DESTINATIONNBITS (SETQ left (ITIMES DESTINATIONNBITS left)) + (SETQ right (ITIMES DESTINATIONNBITS right)) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS] + (* ; + "easy case of black and white bitmap into black and white or color to color or texture filling.") + (UNINTERRUPTABLY + (PROG (HEIGHT) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with (IDIFFERENCE right + left)) + (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) + (\BITBLTSUB \SYSPILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert + DESTINATIONBITMAP + top) + HEIGHT + 'TEXTURE OPERATION TEXTURE))) + (RETURN T]) + +(\PUNT.BITBLT.BITMAP + [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH + HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT + CLIPPEDSOURCEBOTTOM) (* ; "Edited 5-Jun-90 11:59 by Takeshi") + + (* ;; " This FNS is for a punt case of \BITBLT.BITMAP which is implemeted in C") + + (* ;; " Stolen from old definition of \BITBLT.BITMAP") + + (DECLARE (LOCALVARS . T)) + (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) + (SETQ top (fetch (BITMAP BITMAPHEIGHT) of DESTBITMAP)) + (SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP)) + (SETQ left 0) + (SETQ bottom 0) + (SETQ SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)) + (SETQ right (fetch (BITMAP BITMAPWIDTH) of DESTBITMAP)) + [COND + (CLIPPINGREGION (* ; "adjust limits") + (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) + (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) + [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) + (fetch (REGION LEFT) of CLIPPINGREGION] + (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) + (fetch (REGION HEIGHT) of CLIPPINGREGION] + + (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") + + [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) + (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) + [COND + (WIDTH (* ; "WIDTH is optional") + (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) + right] + (COND + (HEIGHT (* ; "HEIGHT is optional") + (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) + top] (* ; "Clip and translate coordinates.") + (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) + (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) + + (* ;; "compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be moved with the limits of the region to be moved in the destination coordinates.") + + [PROGN (* ; "compute left margin") + (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) + (* ; "compute bottom margin") + (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) + (* ; "compute right margin") + (SETQ right (IMIN (ffetch (BITMAP BITMAPWIDTH) of SOURCEBITMAP) + (IDIFFERENCE right stodx) + (IPLUS CLIPPEDSOURCELEFT WIDTH))) + (* ; "compute top margin") + (SETQ top (IMIN (ffetch (BITMAP BITMAPHEIGHT) of SOURCEBITMAP) + (IDIFFERENCE top stody) + (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] + (COND + ((OR (ILEQ right left) + (ILEQ top bottom)) (* ; "there is nothing to move.") + (RETURN))) + (SELECTQ SOURCETYPE + (MERGE (* ; + "Need to use complement of TEXTURE") + (* ; "MAY NOT WORK FOR COLOR CASE.") + [SETQ TEXTURE (COND + ((NULL TEXTURE) + BLACKSHADE) + ((FIXP TEXTURE) + (LOGXOR (LOGAND TEXTURE BLACKSHADE) + BLACKSHADE)) + ((AND (NOT (EQ DESTINATIONNBITS 1)) + (COLORNUMBERP TEXTURE DESTINATIONNBITS))) + [(type? BITMAP TEXTURE) + (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE + (SETQ \BBSCRATCHTEXTURE + (BITMAPCREATE 16 16] + (T (\ILLEGAL.ARG TEXTURE]) + NIL) + (COND + [(EQ SOURCENBITS DESTINATIONNBITS) (* ; + "going from one to another of the same size.") + (SELECTQ DESTINATIONNBITS + (4 (* ; + "use UNFOLD with constant value rather than multiple because it compiles into opcodes.") + (SETQ left (UNFOLD left 4)) + (SETQ right (UNFOLD right 4)) + (SETQ stodx (UNFOLD stodx 4)) (* ; + "set texture if it will ever get looked at.") + (AND (EQ SOURCETYPE 'MERGE) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) + (8 (SETQ left (UNFOLD left 8)) + (SETQ right (UNFOLD right 8)) + (SETQ stodx (UNFOLD stodx 8)) + (AND (EQ SOURCETYPE 'MERGE) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) + (24 (SETQ left (ITIMES left 24)) + (SETQ right (ITIMES right 24)) + (SETQ stodx (ITIMES stodx 24)) + (AND (EQ SOURCETYPE 'MERGE) + (SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))) + NIL) (* ; + "easy case of black and white bitmap into black and white or color to color or texture filling.") + (UNINTERRUPTABLY + [PROG (HEIGHT WIDTH DTY DLX STY SLX) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (SETQ WIDTH (IDIFFERENCE right left)) + (SETQ DTY (\SFInvert DESTBITMAP (IPLUS top stody))) + (SETQ DLX (IPLUS left stodx)) + (SETQ STY (\SFInvert SOURCEBITMAP top)) + (SETQ SLX left) + (replace (PILOTBBT PBTWIDTH) of \SYSPILOTBBT with WIDTH) + (replace (PILOTBBT PBTHEIGHT) of \SYSPILOTBBT with HEIGHT) + (COND + ((EQ SOURCETYPE 'MERGE) + (\BITBLT.MERGE \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH + HEIGHT OPERATION TEXTURE)) + (T (\BITBLTSUB \SYSPILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT + SOURCETYPE OPERATION TEXTURE])] + [(EQ SOURCENBITS 1) (* ; + "going from a black and white bitmap to a color map") + (AND SOURCETYPE (NOT (EQ SOURCETYPE 'INPUT)) + (ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE)) + (PROG (HEIGHT WIDTH DBOT DLFT) + (SETQ HEIGHT (IDIFFERENCE top bottom)) + (SETQ WIDTH (IDIFFERENCE right left)) + (SETQ DBOT (IPLUS bottom stody)) + (SETQ DLFT (IPLUS left stodx)) + (SELECTQ OPERATION + ((NIL REPLACE) + (\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH + HEIGHT 0 (MAXIMUMCOLOR DESTINATIONNBITS) + DESTINATIONNBITS)) + (PAINT) + (INVERT) + (ERASE) + (SHOULDNT] + (T (* ; + "going from color map into black and white map.") + (ERROR "not implemented to blt between bitmaps of different pixel size."))) + (RETURN T]) +) +(DEFINEQ + +(BITMAPOBJ.SNAPW + [LAMBDA NIL (* ; "Edited 12-Apr-90 09:09 by matsuda") + + (* * makes an image object of a prompted for region of the screen.) + + (PROG ((REG (GETREGION)) + BM) + [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of REG) + (fetch (REGION HEIGHT) of REG) + (BITSPERPIXEL (SCREENBITMAP \CURSORSCREEN] + (BITBLT (SCREENBITMAP \CURSORSCREEN) + (fetch (REGION LEFT) of REG) + (fetch (REGION BOTTOM) of REG) + BM 0 0 NIL NIL 'INPUT 'REPLACE) + (COPYINSERT (BITMAPTEDITOBJ BM 1 0)) + (RETURN]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: EVAL@COMPILE + +[PROGN (DEFMACRO \MAIKO.CGTHREEP () + (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) + 48)) + (PUTPROPS \MAIKO.CGTHREEP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of + + \InterfacePage + )) + 48)))] + +(PUTPROPS \MAIKO.CGFOURP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of + \InterfacePage + )) + 64))) + +[PROGN (DEFMACRO \MAIKO.CGSIXP () + (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage)) + 96)) + (PUTPROPS \MAIKO.CGSIXP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of + \InterfacePage + )) + 96)))] + +(PUTPROPS \MAIKO.CGTWOP MACRO (NIL (EQ (LOGAND 120 (fetch DEVCONFIG of \InterfacePage + )) + 24))) +) + +(DECLARE%: EVAL@COMPILE + +(RPAQQ \TO.MAIKO.MONOSCREEN 0) + +(RPAQQ \TO.MAIKO.COLORSCREEN 1) + +(RPAQQ \MAIKO.COLORSCREENWIDTH 1152) + +(RPAQQ \MAIKO.COLORSCREENHEIGHT 900) + +(RPAQQ \MAIKO.COLORPAGES 2048) + +(RPAQQ \MAIKO.COLORBUF.ALIGN 4095) + + +(CONSTANTS (\TO.MAIKO.MONOSCREEN 0) + (\TO.MAIKO.COLORSCREEN 1) + (\MAIKO.COLORSCREENWIDTH 1152) + (\MAIKO.COLORSCREENHEIGHT 900) + (\MAIKO.COLORPAGES 2048) + (\MAIKO.COLORBUF.ALIGN 4095)) +) + + +(FILESLOAD (LOADCOMP) + LLDISPLAY BIGBITMAPS) +) + +(RPAQ? \MONO.PROMPTWINDOW NIL) + +(RPAQ? \COLOR.PROMPTWINDOW NIL) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS MAIKOCOLOR.BITSPERPIXEL) +) + +(FILESLOAD COLOR BIGBITMAPS) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(MOVD 'CURSOREXIT 'SAVE.CURSOREXIT) + +(MOVD '\MAIKO.BLTCHAR '\BILTCHAR) + +(\MAIKO.COLORINIT) + +(COLORDISPLAY 'ON 'MAIKOCOLOR) + +(CURSORSCREEN (COLORSCREEN) + 100 100) + +(CHANGEBACKGROUND 36) + +(ADD-EXEC :TTY T :REGION '(0 650 370 150)) + +(LOGOW) +) +(PUTPROPS MAIKOCOLOR COPYRIGHT ("Fuji Xerox Co., Ltd." 1988 1989 1990 1991)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2782 5984 (\MAIKO.COLORINIT 2792 . 3962) (\MAIKO.STARTCOLOR 3964 . 4559) ( +\MAIKO.STOPCOLOR 4561 . 4945) (\MAIKOCOLOR.EVENTFN 4947 . 5578) (\MAIKO.SENDCOLORMAPENTRY 5580 . 5805) + (\MAIKO.CHANGESCREEN 5807 . 5982)) (5985 26414 (CURSOREXIT 5995 . 7433) (CURSORSCREEN 7435 . 9475) ( +WARPCURSOR 9477 . 9726) (\SLOWBLTCHAR 9728 . 9910) (\SOFTCURSORUP 9912 . 15707) (\BITBLT.DISPLAY 15709 + . 26412)) (26485 37922 (\PUNT.SLOWBLTCHAR 26495 . 33267) (\MAIKO.PUNTBLTCHAR 33269 . 37722) ( +\MAIKO.BLTCHAR 37724 . 37920)) (37923 54124 (\PUNT.BLTSHADE.BITMAP 37933 . 44959) (\PUNT.BITBLT.BITMAP + 44961 . 54122)) (54125 54867 (BITMAPOBJ.SNAPW 54135 . 54865))))) +STOP diff --git a/sources/MAIKOETHER b/sources/MAIKOETHER new file mode 100644 index 00000000..dec8986d --- /dev/null +++ b/sources/MAIKOETHER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED " 4-May-91 15:52:07" |{PELE:MV:ENVOS}SOURCES>MAIKOETHER.;6| 19857 |changes| |to:| (FNS \\MAIKO.10MBSTARTDRIVER \\MAIKO.ETHER-INTERRUPT) |previous| |date:| " 3-Apr-91 10:59:27" |{PELE:MV:ENVOS}SOURCES>MAIKOETHER.;4|) ; Copyright (c) 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT MAIKOETHERCOMS) (RPAQQ MAIKOETHERCOMS ((FNS \\MAIKO.10MBSENDPACKET \\MAIKO.10MBWATCHER \\MAIKO.ETHERRESUME \\MAIKO.ETHERSUSPEND \\MAIKO.INPUT.INTERRUPT \\MAIKO.10MBSTARTDRIVER \\MAIKO.10MBTURNONETHER \\MAIKO.10MB.RESTART.ETHER \\MAIKO.CHECKSUM) (INITVARS (\\MAIKO.INPUT.PACKET) (|\\ETHERtopMonitor| (CREATE.MONITORLOCK "ETHERTopMonitor"))) (DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP) 10MBDRIVER) (GLOBALVARS \\MAIKO.INPUT.PACKET |\\ETHERtopMonitor|) (* |;;| "The NDB for Maiko's 10MB connection; used by \\MAIKO.ETHER-INTERRUPT:") (GLOBALVARS \\MAIKO.10MB.NDB) (GLOBALVARS \\MAIKO.IO-INTERRUPT-FLAGS \\MAIKO.IO-INTERRUPT-VECTOR)) (ADDVARS (\\MAIKO.MOVDS (\\MAIKO.10MBSTARTDRIVER \\10MB.STARTDRIVER) (\\MAIKO.10MBWATCHER \\10MBWATCHER) (\\MAIKO.10MBSENDPACKET \\10MBSENDPACKET) (\\MAIKO.ETHERSUSPEND \\10MB.TURNOFFETHER) (\\MAIKO.10MBTURNONETHER \\10MB.TURNONETHER) (\\MAIKO.ETHERRESUME \\10MB.RESTART.ETHER) (\\MAIKO.CHECKSUM \\CHECKSUM))) (COMS (* \; "MAIKO handler for new interrupt-driven incoming ethernet communication, rather than polling for it.") (FNS \\MAIKO.ETHER-INTERRUPT)) (COMS (* \; "MAIKO Log & Console message handling. Interrupt-driven message printing, instead of polled printing.") (FNS \\MAIKO.CONSOLE-LOG-PRINT)) (COMS (* |;;| "Asynchronous I/O handling") (FNS \\MAIKO.IO-INTERRUPT) (VARS (\\MAIKO.IO-INTERRUPT-FLAGS (\\CREATECELL \\FIXP)) (\\MAIKO.IO-INTERRUPT-VECTOR NIL))))) (DEFINEQ (\\MAIKO.10MBSENDPACKET (LAMBDA (NDB PACKET) (* \; "Edited 31-Oct-89 14:10 by bvm") (PROG NIL (COND (\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWPUT))) (COND ((OR (|fetch| 10MBMULTICASTP |of| PACKET) (EQNSADDRESS.HOST \\MY.NSADDRESS (|fetch| 10MBDESTNSADDRESSBASE |of| PACKET )))(* \;  "We would hear this packet if our hardware let us, so fake receipt") (PROG ((COPYPACKET (\\ALLOCATE.ETHERPACKET))) (\\BLT (LOCF (|fetch| 10MBLENGTH |of| COPYPACKET)) (LOCF (|fetch| 10MBLENGTH |of| PACKET)) (ADD1 (|fetch| 10MBLENGTH |of| PACKET))) (* \;  "Copy all data that would have been transmitted") (|replace| EPNETWORK |of| COPYPACKET |with| NDB) (|replace| EPTYPE |of| COPYPACKET |with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS |bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET)) |when| (EQ TYPE (CAR PAIR)) |do| (* |;;| "TYPE is the raw type of the etherpacket. These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.") (RETURN (CDR PAIR)) |finally| (RETURN TYPE))) (COND (\\RAWTRACING (\\MAYBEPRINTPACKET COPYPACKET 'RAWGET))) (\\HANDLE.RAW.PACKET COPYPACKET)))) (UNINTERRUPTABLY (SUBRCALL ETHER-SEND (IMAX (|fetch| 10MBLENGTH |of| PACKET) \\10MB.MINPACKETLENGTH) (|fetch| 10MBPACKETBASE |of| PACKET)) (|replace| EPNETWORK |of| PACKET |with| NIL) (\\REQUEUE.ETHERPACKET PACKET)) (RETURN T)))) (\\maiko.10mbwatcher (lambda (ndb) (* \; "Edited 16-May-88 22:24 by MASINTER") (* |;;| "merge message and packet reading") (prog ((cntr 0) message-buffer message-length packet) lp (if (subrcall message-readp) then (promptprint (if (setq message-length (subrcall message-read (or message-buffer (setq message-buffer (allocstring 1024))) 1024)) then (substring message-buffer 1 message-length) else "?? system message: polling failed"))) (uninterruptably (subrcall ether-check) (setq packet (\\maiko.input.interrupt ndb))) (cond (packet (\\handle.raw.packet packet) (cond ((ilessp (|add| cntr 1) \\maxwatchergets) (go lp))))) (block) (setq cntr 0) (go lp)))) (\\maiko.etherresume (lambda nil (* \; "Edited 11-May-88 16:09 by MASINTER") (subrcall ether-resume))) (\\maiko.ethersuspend (lambda nil (* \; "Edited 11-May-88 16:11 by MASINTER") (subrcall ether-suspend))) (\\maiko.input.interrupt (lambda (ndb) (* \; "Edited 11-May-88 16:05 by MASINTER") (* |;;| "This routine gets called when 10MB input signals an interrupt. See if the \\MAIKO.INPUT.PACKET has indeed been processed, and if so, take care of it") (prog (length (packet \\maiko.input.packet)) (cond ((neq (setq length (|fetch| dlfirsticb |of| (|fetch| ndbcsb |of| ndb))) \\es.pending) (|replace| 10mblength |of| packet |with| length) (\\rclk (locf (|fetch| eptimestamp |of| packet))) (|replace| epnetwork |of| packet |with| ndb) (|replace| eptype |of| packet |with| (|for| pair |in| \\10mbtype.translations |bind| (type _ (|fetch| 10mbtype |of| packet )) |when| (eq type (car pair)) |do| (return (cdr pair)) |finally| (return type))) (cond (\\rawtracing (\\maybeprintpacket packet 'rawget))) (return (prog1 packet (setq \\maiko.input.packet (\\allocate.etherpacket)) (|replace| dlfirsticb |of| (|fetch| ndbcsb |of| ndb) |with| \\es.pending) (subrcall ether-get \\10mbpacketlength (|fetch| 10mbpacketbase |of| \\maiko.input.packet)))) ) (t (return nil)))))) (\\MAIKO.10MBSTARTDRIVER (LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* \; "Edited 4-May-91 15:50 by jds") (* |;;| "Start the \"driver\" for the 10MB ethernet on Sun Medley. In particular, turn on the C ehternet code, queue up the first input packet, and start the \\10MBWATCHER process.") (SUBRCALL ETHER-SUSPEND) (OR (\\INIT.ETHER.BUFFER.POOL) (ERROR "Unable to create buffer pool")) (|replace| NDBTQ |of| NDB |with| (|create| SYSQUEUE)) (SETQ \\10MB.RAWPACKETQ (|create| SYSQUEUE)) (SETQ \\10MB.INPUT.TIMEOUT (TIMES \\RCLKSECOND \\10MB.EXPECTED.RECEIVE.INTERVAL)) (SETQ \\MAIKO.10MB.NDB NDB) (\\10MB.TURNONETHER NDB NIL NIL (OR MYNSNUMBER T) 0 0) (PROG ((CSB (|fetch| NDBCSB |of| NDB))) (OR \\MAIKO.INPUT.PACKET (SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET))) (|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING) (AND (SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of| \\MAIKO.INPUT.PACKET )) (\\MAIKO.ETHER-INTERRUPT)) (* |;;| "Commented out the 10MBWATCHER adder, so this process never gets created.") (* |;;| "(replace NDBWATCHER of NDB with (ADD.PROCESS (LIST '\\10MBWATCHER (KWOTE NDB)) 'RESTARTABLE 'SYSTEM 'AFTEREXIT 'DELETE))") (RETURN NDB)))) (\\maiko.10mbturnonether (lambda (ndb smashstate newstate nshostnumber ininterrupt outinterrupt) (* \; "Edited 11-May-88 16:08 by MASINTER") (* |;;;| "Reset and activate ether associated with NDB. If SMASHSTATE is given, it is a CSB-length block into which state is saved for later restoration by passing as the NEWSTATE arg. If NEWSTATE is NIL, then the remaining non-NIL args give parameters for this activation: the host number for microcode to watch for, T meaning my own number; and interrupt masks for when a packet arrives or finishes transmitting") (* |;;| "For Daybreak, SMASHSTATE and NEWSTATE must be NIL") (prog ((csb (|fetch| ndbcsb |of| ndb))) (\\maiko.ethersuspend) (or csb (|replace| ndbcsb |of| ndb |with| (setq csb (locf (|fetch| dlethernet |of| \\iopage))))) (|replace| dlfirstocb |of| csb |with| 0) (|replace| dlfirsticb |of| csb |with| 0) (and nshostnumber (cond ((eq nshostnumber t) (\\blt (locf (|fetch| dllocalhost0 |of| csb)) (locf (|fetch| (ifpage |NSHost0|) |of| |\\InterfacePage|) ) \\#wds.nshostnumber)) (t (\\storenshostnumber (locf (|fetch| dllocalhost0 |of| csb)) nshostnumber)))) (and outinterrupt (|replace| dloutputmask |of| csb |with| outinterrupt)) (and ininterrupt (|replace| dlinputmask |of| csb |with| ininterrupt)) (|replace| dlmissedpackets |of| csb |with| 0) (|replace| dllasticb |of| csb |with| 0) (|replace| dllastocb |of| csb |with| 0) (subrcall ether-reset) (subrcall ether-resume) (return ndb)))) (\\maiko.10mb.restart.ether (lambda (ndb) (* \; "Edited 11-May-88 16:08 by MASINTER") (* |;;;| "Kick the Ethernet receiver task to restart the Ethernet receiver task. This function gets called when the 10MBDRIVER thinks the Ethernet has been accidentally disabled") (subrcall ether-resume))) (\\maiko.checksum (lambda (base nwords initsum) (* \; "Edited 20-May-88 11:48 by MASINTER") (subrcall check-sum base nwords initsum))) ) (RPAQ? \\MAIKO.INPUT.PACKET ) (RPAQ? |\\ETHERtopMonitor| (CREATE.MONITORLOCK "ETHERTopMonitor")) (DECLARE\: EVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) 10MBDRIVER) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\MAIKO.INPUT.PACKET |\\ETHERtopMonitor|) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\MAIKO.10MB.NDB) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\MAIKO.IO-INTERRUPT-FLAGS \\MAIKO.IO-INTERRUPT-VECTOR) ) ) (ADDTOVAR \\MAIKO.MOVDS (\\MAIKO.10MBSTARTDRIVER \\10MB.STARTDRIVER) (\\MAIKO.10MBWATCHER \\10MBWATCHER) (\\MAIKO.10MBSENDPACKET \\10MBSENDPACKET) (\\MAIKO.ETHERSUSPEND \\10MB.TURNOFFETHER) (\\MAIKO.10MBTURNONETHER \\10MB.TURNONETHER) (\\MAIKO.ETHERRESUME \\10MB.RESTART.ETHER) (\\MAIKO.CHECKSUM \\CHECKSUM)) (* \; "MAIKO handler for new interrupt-driven incoming ethernet communication, rather than polling for it.") (DEFINEQ (\\MAIKO.ETHER-INTERRUPT (LAMBDA NIL (* \; "Edited 4-May-91 13:46 by jds") (* |;;| "This routine gets called when 10MB input signals an interrupt. See if the \\MAIKO.INPUT.PACKET has indeed been processed, and if so, take care of it") (PROG ((NDB \\MAIKO.10MB.NDB) LENGTH) (* |;;| "First, turn off the interrupt flag:") (REPLACE (INTERRUPTSTATE ETHERINTERRUPT) OF \\INTERRUPTSTATE WITH NIL) (* |;;| "Now handle it:") (UNINTERRUPTABLY (WITH.MONITOR |\\ETHERtopMonitor| (PROG ((PACKET \\MAIKO.INPUT.PACKET)) (* |;;| "We come back here if there's more than one packet ready to be read, so we process as many as possible in one swell foop.") READ-MORE-LOOP (COND ((NEQ (SETQ LENGTH (|fetch| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB))) \\ES.PENDING) (|replace| 10MBLENGTH |of| PACKET |with| LENGTH) (\\RCLK (LOCF (|fetch| EPTIMESTAMP |of| PACKET))) (|replace| EPNETWORK |of| PACKET |with| NDB) (|replace| EPTYPE |of| PACKET |with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS |bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET )) |when| (EQ TYPE (CAR PAIR)) |do| (RETURN (CDR PAIR)) |finally| (RETURN TYPE))) (COND (\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWGET))) (\\HANDLE.RAW.PACKET PACKET) (SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET)) (|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING) (COND ((SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of| \\MAIKO.INPUT.PACKET) ) (* |;;|  "Returned T, so there's another packet waiting already. Process it.") (SETQ PACKET \\MAIKO.INPUT.PACKET) (GO READ-MORE-LOOP))))))))))) ) (* \; "MAIKO Log & Console message handling. Interrupt-driven message printing, instead of polled printing." ) (DEFINEQ (\\MAIKO.CONSOLE-LOG-PRINT (LAMBDA NIL (* \; "Edited 18-Dec-89 12:16 by jds") (* |;;| "Read any pending Console or Log messages, and print them in the prompt window.") (* |;;|  "Called from INTERRUPTED when the Maiko emulator sets the LogMsgPending flag in \\INTERRUPTSTATE.") (PROG (MESSAGE-BUFFER MESSAGE-LENGTH) (|replace| (INTERRUPTSTATE LOGMSGSPENDING) |of| \\INTERRUPTSTATE |with| NIL) (|while| (SUBRCALL MESSAGE-READP) |do| (FRESHLINE PROMPTWINDOW) (PRIN1 (|if| (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ (OR MESSAGE-BUFFER (SETQ MESSAGE-BUFFER (ALLOCSTRING 1024))) 1024)) |then| (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH) |else| "?? system message: polling failed") PROMPTWINDOW))))) ) (* |;;| "Asynchronous I/O handling") (DEFINEQ (\\MAIKO.IO-INTERRUPT (LAMBDA NIL (* \; "Edited 18-Dec-89 13:09 by jds") (* |;;| "Handle I/O pending on an asynchronous file descriptor.") (* |;;|  "Called from INTERRUPTED when the Maiko emulator sets theIOINTERRUPT flag in \\INTERRUPTSTATE.") (PROG NIL (|replace| (INTERRUPTSTATE IOINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL) (FOR INFO IN \\MAIKO.IO-INTERRUPT-VECTOR WHEN (NOT (ZEROP (LOGAND (CAR INFO) \\MAIKO.IO-INTERRUPT-FLAGS))) DO (CL:FUNCALL (CADR INFO)))))) ) (RPAQ \\MAIKO.IO-INTERRUPT-FLAGS (\\CREATECELL \\FIXP)) (RPAQQ \\MAIKO.IO-INTERRUPT-VECTOR NIL) (PUTPROPS MAIKOETHER COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL (2430 13315 (\\MAIKO.10MBSENDPACKET 2440 . 4818) (\\MAIKO.10MBWATCHER 4820 . 6165) ( \\MAIKO.ETHERRESUME 6167 . 6326) (\\MAIKO.ETHERSUSPEND 6328 . 6489) (\\MAIKO.INPUT.INTERRUPT 6491 . 8753) (\\MAIKO.10MBSTARTDRIVER 8755 . 10406) (\\MAIKO.10MBTURNONETHER 10408 . 12783) ( \\MAIKO.10MB.RESTART.ETHER 12785 . 13138) (\\MAIKO.CHECKSUM 13140 . 13313)) (14370 17435 ( \\MAIKO.ETHER-INTERRUPT 14380 . 17433)) (17557 18920 (\\MAIKO.CONSOLE-LOG-PRINT 17567 . 18918)) (18966 19646 (\\MAIKO.IO-INTERRUPT 18976 . 19644))))) STOP \ No newline at end of file diff --git a/sources/MAIKOLOADUPFNS b/sources/MAIKOLOADUPFNS new file mode 100644 index 00000000..859b38c5 --- /dev/null +++ b/sources/MAIKOLOADUPFNS @@ -0,0 +1,429 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "18-May-2018 09:49:50"  {DSK}kaplan>Local>medley3.5>lispcore>sources>MAIKOLOADUPFNS.;2 33928 changes to%: (VARS MAIKOLOADUPFNSCOMS) previous date%: " 5-Apr-89 16:23:30" {DSK}kaplan>Local>medley3.5>lispcore>sources>MAIKOLOADUPFNS.;1) (* ; " Copyright (c) 1989, 2018 by ENVOS Corporation. All rights reserved. ") (PRETTYCOMPRINT MAIKOLOADUPFNSCOMS) (RPAQQ MAIKOLOADUPFNSCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) MAIKOLOADUPFNS) (FNS CL::%%COPY-TIME-STATS CHECKPAGEMAP CLOCK CLOCK0 DAYTIME SETTIME \10MB.RESTART.ETHER \10MB.STARTDRIVER \10MB.TURNOFFETHER \10MB.TURNONETHER \10MBSENDPACKET \10MBWATCHER \BITBLTSUB \BLTCHAR \CHECKSUM \CLOCK0 \COUNTREALPAGES \DAYTIME0 \DIRTYBACKGROUND \DISPLAYLINE \DOLOCKPAGES \DONEWPAGE \DORECLAIM \DOTEMPLOCKPAGES \LOADVMEMPAGE \LOCKEDPAGEP \LOCKPAGES \MOVEVMEMFILEPAGE \NEWPAGE \NS.SETTIME \PAGEFAULT \PUP.SETTIME \SHOWPAGETABLE \TEMPUNLOCKPAGES \UNLOCKPAGES \WRITEDIRTYPAGE) (GLOBALVARS \TimeZoneComp \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER \10MBTYPE.TRANSLATIONS \MY.NSADDRESS \RAWTRACING \MAXWATCHERGETS) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (SOURCE) 10MBDECLS LLNSDECLS TEDITDCL)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE \MOVEVMEMFILEPAGE \LOCKPAGES \LOCKEDPAGEP \DOTEMPLOCKPAGES \DOLOCKPAGES \DIRTYBACKGROUND \COUNTREALPAGES CHECKPAGEMAP]) (PUTPROPS MAIKOLOADUPFNS FILETYPE CL:COMPILE-FILE) (PUTPROPS MAIKOLOADUPFNS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) (DEFINEQ (CL::%%COPY-TIME-STATS + [LAMBDA (REFERENCE-BLOCK DESTINIATION-BLOCK) (* ; "Edited 2-May-88 17:16 by MASINTER") + (SUBRCALL COPYTIMESTATS REFERENCE-BLOCK DESTINIATION-BLOCK]) (CHECKPAGEMAP + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (CLOCK + [LAMBDA (N BOX) (* ; "Edited 2-May-88 16:11 by MASINTER") + (SUBRCALL GETUNIXTIME N BOX]) (CLOCK0 + [LAMBDA (BOX) (* ; "Edited 2-May-88 16:19 by MASINTER") + (SUBRCALL GETUNIXTIME 0 BOX]) (DAYTIME + [LAMBDA (BOX) (* ; "Edited 2-May-88 16:20 by MASINTER") + (SUBRCALL GETUNIXTIME 5 BOX]) (SETTIME + [LAMBDA (RETFLG) (* ; "Edited 13-May-88 15:22 by MASINTER") + (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG))) + (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL))) + (\PROCESS.RESET.TIMERS) + (DAYTIME]) (\10MB.RESTART.ETHER + [LAMBDA NIL (* ; "Edited 11-May-88 16:09 by MASINTER") + (SUBRCALL ETHER-RESUME]) (\10MB.STARTDRIVER + [LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* ; "Edited 5-Apr-89 15:03 by snow") + (DECLARE (GLOBALVARS \MAIKO.INPUT.PACKET \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT) + ) + (SUBRCALL ETHER-SUSPEND) + (OR (\INIT.ETHER.BUFFER.POOL) + (ERROR "Unable to create buffer pool")) + (replace NDBTQ of NDB with (create SYSQUEUE)) + (SETQ \10MB.RAWPACKETQ (create SYSQUEUE)) + (SETQ \10MB.INPUT.TIMEOUT (TIMES \RCLKSECOND \10MB.EXPECTED.RECEIVE.INTERVAL)) + (\10MB.TURNONETHER NDB NIL NIL (OR MYNSNUMBER T) + 0 0) + (PROG ((CSB (fetch NDBCSB of NDB))) + (OR \MAIKO.INPUT.PACKET (SETQ \MAIKO.INPUT.PACKET (\ALLOCATE.ETHERPACKET))) + (replace DLFIRSTICB of (fetch NDBCSB of NDB) with \ES.PENDING) + (SUBRCALL ETHER-GET \10MBPACKETLENGTH (fetch 10MBPACKETBASE of \MAIKO.INPUT.PACKET) + ) + (replace NDBWATCHER of NDB with (ADD.PROCESS (LIST '\10MBWATCHER (KWOTE NDB)) + 'RESTARTABLE + 'SYSTEM + 'AFTEREXIT + 'DELETE)) + (RETURN NDB]) (\10MB.TURNOFFETHER + [LAMBDA NIL (* ; "Edited 11-May-88 16:11 by MASINTER") + (SUBRCALL ETHER-SUSPEND]) (\10MB.TURNONETHER + [LAMBDA (NDB SMASHSTATE NEWSTATE NSHOSTNUMBER ININTERRUPT OUTINTERRUPT) + (* ; "Edited 11-May-88 16:08 by MASINTER") + +(* ;;; "Reset and activate ether associated with NDB. If SMASHSTATE is given, it is a CSB-length block into which state is saved for later restoration by passing as the NEWSTATE arg. If NEWSTATE is NIL, then the remaining non-NIL args give parameters for this activation: the host number for microcode to watch for, T meaning my own number; and interrupt masks for when a packet arrives or finishes transmitting") + + (* ;; "For Daybreak, SMASHSTATE and NEWSTATE must be NIL") + + (PROG ((CSB (fetch NDBCSB of NDB))) + (\MAIKO.ETHERSUSPEND) + [OR CSB (replace NDBCSB of NDB with (SETQ CSB (LOCF (fetch DLETHERNET + of \IOPAGE] + (replace DLFIRSTOCB of CSB with 0) + (replace DLFIRSTICB of CSB with 0) + [AND NSHOSTNUMBER (COND + ((EQ NSHOSTNUMBER T) + (\BLT (LOCF (fetch DLLOCALHOST0 of CSB)) + (LOCF (fetch (IFPAGE NSHost0) of \InterfacePage)) + \#WDS.NSHOSTNUMBER)) + (T (\STORENSHOSTNUMBER (LOCF (fetch DLLOCALHOST0 of CSB)) + NSHOSTNUMBER] + (AND OUTINTERRUPT (replace DLOUTPUTMASK of CSB with OUTINTERRUPT)) + (AND ININTERRUPT (replace DLINPUTMASK of CSB with ININTERRUPT)) + (replace DLMISSEDPACKETS of CSB with 0) + (replace DLLASTICB of CSB with 0) + (replace DLLASTOCB of CSB with 0) + (SUBRCALL ETHER-RESET) + (SUBRCALL ETHER-RESUME) + (RETURN NDB]) (\10MBSENDPACKET + [LAMBDA (NDB PACKET) (* ; "Edited 11-May-88 16:10 by MASINTER") + (PROG NIL + [COND + (\RAWTRACING (\MAYBEPRINTPACKET PACKET 'RAWPUT] + [COND + ((OR (fetch 10MBMULTICASTP of PACKET) + (EQNSADDRESS.HOST \MY.NSADDRESS (fetch 10MBDESTHOSTBASE of PACKET))) + (* ; + "We would hear this packet if our hardware let us, so fake receipt") + (PROG ((COPYPACKET (\ALLOCATE.ETHERPACKET))) + (\BLT (LOCF (fetch 10MBLENGTH of COPYPACKET)) + (LOCF (fetch 10MBLENGTH of PACKET)) + (ADD1 (fetch 10MBLENGTH of PACKET))) + (* ; + "Copy all data that would have been transmitted") + (replace EPNETWORK of COPYPACKET with NDB) + (replace EPTYPE of COPYPACKET + with (for PAIR in \10MBTYPE.TRANSLATIONS + bind (TYPE _ (fetch 10MBTYPE of PACKET)) + when (EQ TYPE (CAR PAIR)) do + + (* ;; "TYPE is the raw type of the etherpacket. These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.") + + (RETURN (CDR PAIR)) + finally (RETURN TYPE))) + [COND + (\RAWTRACING (\MAYBEPRINTPACKET COPYPACKET 'RAWGET] + (\HANDLE.RAW.PACKET COPYPACKET] + (UNINTERRUPTABLY + (SUBRCALL ETHER-SEND (IMAX (fetch 10MBLENGTH of PACKET) + \10MB.MINPACKETLENGTH) + (fetch 10MBPACKETBASE of PACKET)) + (replace EPNETWORK of PACKET with NIL) + (\REQUEUE.ETHERPACKET PACKET)) + (RETURN T]) (\10MBWATCHER + [LAMBDA (NDB) (* ; "Edited 16-May-88 22:24 by MASINTER") + + (* ;; "merge message and packet reading") + + (PROG ((CNTR 0) + MESSAGE-BUFFER MESSAGE-LENGTH PACKET) + LP (IF (SUBRCALL MESSAGE-READP) + THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ + (OR MESSAGE-BUFFER + (SETQ MESSAGE-BUFFER + (ALLOCSTRING 1024))) + 1024)) + THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH) + ELSE "?? system message: polling failed"))) + (UNINTERRUPTABLY + (SUBRCALL ETHER-CHECK) + (SETQ PACKET (\MAIKO.INPUT.INTERRUPT NDB))) + [COND + (PACKET (\HANDLE.RAW.PACKET PACKET) + (COND + ((ILESSP (add CNTR 1) + \MAXWATCHERGETS) + (GO LP] + (BLOCK) + (SETQ CNTR 0) + (GO LP]) (\BITBLTSUB + [LAMBDA (PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation + Texture WindowXOffset WindowYOffset) (* ; "Edited 29-Jun-88 16:24 by ") + + (* ;; "replaces \BITBLTSUB on Maiko") + + ((OPCODES SUBRCALL 69 13) + PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation Texture + WindowXOffset WindowYOffset]) (\BLTCHAR + [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) + ((OPCODES SUBRCALL 135 3) + CHARCODE DISPLAYSTREAM DISPLAYDATA]) (\CHECKSUM + [LAMBDA (BASE NWORDS INITSUM) (* ; "Edited 20-May-88 11:48 by MASINTER") + (SUBRCALL CHECK-SUM BASE NWORDS INITSUM]) (\CLOCK0 + [LAMBDA (BOX) (* ; "Edited 2-May-88 16:19 by MASINTER") + (SUBRCALL GETUNIXTIME 0 BOX]) (\COUNTREALPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + 0]) (\DAYTIME0 + [LAMBDA (BOX) (* ; "Edited 2-May-88 16:20 by MASINTER") + (SUBRCALL GETUNIXTIME 4 BOX]) (\DIRTYBACKGROUND + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\DISPLAYLINE + [LAMBDA (TEXTOBJ LINE WINDOW) (* ; "Edited 5-Apr-89 16:22 by snow") + + (* ;; "Display the line of text LINE in the edit window where it belongs.") + + (* ;; " This Function works on MIAKO") + + (PROG ((CH 0) + (CHLIST (fetch (THISLINE CHARS) of (fetch THISLINE of TEXTOBJ))) + (WLIST (fetch (THISLINE WIDTHS) of (ffetch THISLINE of TEXTOBJ))) + (LOOKS (fetch (THISLINE LOOKS) of (ffetch THISLINE of TEXTOBJ))) + (WINDOWDS (WINDOWPROP (OR WINDOW (CAR (fetch (TEXTOBJ \WINDOW) of TEXTOBJ))) + 'DSP)) + (TEXTLEN (ffetch (TEXTOBJ TEXTLEN) of TEXTOBJ)) + (THISLINE (ffetch (TEXTOBJ THISLINE) of TEXTOBJ)) + (TERMSA (ffetch (TEXTOBJ TXTTERMSA) of TEXTOBJ)) + (STREAM (ffetch (TEXTOBJ STREAMHINT) of TEXTOBJ)) + (OLDCACHE (fetch LCBITMAP of (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ))) + (DS (ffetch (TEXTOBJ DISPLAYCACHEDS) of TEXTOBJ)) + (HCPYDS (ffetch (TEXTOBJ DISPLAYHCPYDS) of TEXTOBJ)) + (HARDCOPYMODE (fetch (FMTSPEC FMTHARDCOPY) of (fetch (LINEDESCRIPTOR LFMTSPEC) + of LINE))) + LOOKSTARTX CACHE \PCHARSLEFT \PSTRING \PFILE FONT OFONT OLOOKS XOFFSET CLIPLEFT CLIPRIGHT + DISPLAYDATA DDPILOTBBT DDWIDTHCACHE DDOFFSETCACHE CURY LHEIGHT SCALE) + [SETQ LHEIGHT (COND + ((ffetch (LINEDESCRIPTOR PREVLINE) of LINE) + (* ; + "So if theres a base-to-base measure, we clear everything right.") + (IMAX (IDIFFERENCE (fetch YBOT of (ffetch (LINEDESCRIPTOR + PREVLINE) + of LINE)) + (ffetch (LINEDESCRIPTOR YBOT) of LINE)) + (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE))) + (T (ffetch (LINEDESCRIPTOR LHEIGHT) of LINE] + (COND + (HARDCOPYMODE (* ; + "This is a hardcopy-mode line. Scale things.") + (* ; "(SETQ DS HCPYDS)") + (SETQ SCALE (DSPSCALE NIL HCPYDS))) + (T (SETQ SCALE 1))) + (SETQ CACHE (\TEDIT.LINECACHE (ffetch (TEXTOBJ DISPLAYCACHE) of TEXTOBJ) + (COND + (HARDCOPYMODE (FIXR (FQUOTIENT (fetch RIGHTMARGIN of LINE) + SCALE))) + (T (fetch RIGHTMARGIN of LINE))) + LHEIGHT)) + (COND + ((NEQ CACHE OLDCACHE) (* ; + "We changed the bitmaps because this line was bigger--update the displaystream, too") + (DSPDESTINATION CACHE DS) + (DSPCLIPPINGREGION (create REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (fetch BITMAPWIDTH of CACHE) + HEIGHT _ (ffetch BITMAPHEIGHT of CACHE)) + DS))) + (BITBLT NIL 0 0 CACHE 0 0 NIL NIL 'TEXTURE 'REPLACE WHITESHADE) + (* ; "Clear the line cache") + (COND + (HARDCOPYMODE (* ; + "This is a hardcopy-mode line. Scale things.") + (* ; "(SETQ DS HCPYDS)") + (SETQ SCALE (DSPSCALE NIL HCPYDS))) + (T (SETQ SCALE 1))) + [COND + ((AND (NOT (ZEROP (fetch CHAR1 of LINE))) + (ILEQ (ffetch CHAR1 of LINE) + TEXTLEN) + (IGEQ (ffetch YBOT of LINE) + (ffetch WBOTTOM of TEXTOBJ))) + + (* ;; "Only display the line of it contains text (CHAR1 > 0), appears before the end of the test, and is on-screen.") + + (COND + ((NEQ (fetch DESC of THISLINE) + LINE) (* ; + "No image cache -- re-format and display") + (\FORMATLINE TEXTOBJ NIL (ffetch CHAR1 of LINE) + LINE))) + (MOVETO (ffetch LEFTMARGIN of LINE) + (ffetch DESCENT of LINE) + DS) + (SETQ DISPLAYDATA (fetch IMAGEDATA of DS)) + (SETQ DDPILOTBBT (ffetch DDPILOTBBT of DISPLAYDATA)) + (SETQ XOFFSET (ffetch DDXOFFSET of DISPLAYDATA)) + + (* ;; "The X position of the left edge of the window, since \TEDIT.BLTCHAR works on the screen bitmap itself.") + + (SETQ CLIPLEFT (ffetch DDClippingLeft of DISPLAYDATA)) + (* ; + "The left and right edges of the clipping region for the text display window.") + (SETQ CLIPRIGHT (ffetch DDClippingRight of DISPLAYDATA)) + (SETQ OFONT (DSPFONT (fetch CLFONT of (SETQ OLOOKS (\EDITELT LOOKS 0))) + DS)) (* ; "The starting font") + (SETQ DDWIDTHCACHE (ffetch DDWIDTHSCACHE of DISPLAYDATA)) + (* ; + "Cache the character-image widths") + (SETQ DDOFFSETCACHE (ffetch DDOFFSETSCACHE of DISPLAYDATA)) + (* ; + "And the offset-into-strike-bitmap array") + (SETQ LOOKSTARTX (ffetch LEFTMARGIN of LINE)) + (* ; + "Starting X position for the current-looks text.") + (AND (fetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (FIXR (FTIMES SCALE (ffetch CLOFFSET of OLOOKS))) + DS)) (* ; + "Any sub- or superscripting at start of line") + (bind (LOOKNO _ 1) + DX + (TX _ (IPLUS XOFFSET (ffetch LEFTMARGIN of LINE))) for I + from 0 to (fetch LEN of THISLINE) + do + + (* ;; "Display the line character by character") + + (SETQ CH (\EDITELT CHLIST I)) (* ; + "Grab the character (or IMAGEOBJ) to display") + (SETQ DX (\WORDELT WLIST I)) (* ; "And its width") + [SELECTC CH + (LMInvisibleRun (* ; + "An INVISIBLE run -- skip it, and skip over the char count") + (add LOOKNO 1)) + (LMLooksChange (* ; "A LOOKS change") + (freplace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE TX XOFFSET)) + (* ; + "Make the displaystream reflect our current X position") + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS + (ffetch DESCENT of LINE)) + (* ; + "Make any necessary changes to the preceding characters (underline, strike-out &c)") + (DSPFONT (fetch CLFONT of (SETQ OLOOKS + (\EDITELT LOOKS LOOKNO)) + ) + DS) (* ; "Set the new font") + (add LOOKNO 1) (* ; "Grab the next set of char looks") + (AND (ffetch CLOFFSET of OLOOKS) + (RELMOVETO 0 (ffetch CLOFFSET of OLOOKS) + DS)) (* ; "Account for super/subscripting") + (SETQ LOOKSTARTX (IDIFFERENCE TX XOFFSET)) + (* ; + "Remember the starting Xpos for possible later underlining &c") + ) + ((CHARCODE (TAB %#^I)) (* ; + "TAB: use the width from the cache to decide the right formatting.") + [COND + ((OR (IEQP CH (CHARCODE %#^I)) + (ffetch CLLEADER of OLOOKS) + (EQ (ffetch CLUSERINFO of OLOOKS) + 'DOTTEDLEADER)) + (LET* [[LEADERFONT (COND + (HARDCOPYMODE (FONTCOPY (ffetch CLFONT + of OLOOKS) + 'DEVICE HCPYDS)) + (T (ffetch CLFONT of OLOOKS] + (DOTWIDTH (CHARWIDTH (CHARCODE %.) + LEADERFONT)) + (TTX (IPLUS TX DOTWIDTH (IDIFFERENCE DOTWIDTH + (IREMAINDER TX DOTWIDTH] + (while (ILEQ TTX (IPLUS TX DX)) + do (COND + (HARDCOPYMODE + (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.) + DS + (FIXR (FQUOTIENT (IDIFFERENCE TTX + DOTWIDTH) + SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT)) + ((OR TERMSA HARDCOPYMODE) + (* ; + "Using special instrns from TERMSA") + (\DSPPRINTCHAR DS (CHARCODE %.))) + (T (* ; "Native charcodes") + (SUBRCALL TEDIT.BLTCHAR (CHARCODE %.) + DS + (IDIFFERENCE TTX DOTWIDTH) + DISPLAYDATA DDPILOTBBT CLIPRIGHT))) + (add TTX DOTWIDTH]) + (13 (* ; "It's a CR") + NIL) + (COND + [(SMALLP CH) (* ; + "Normal character -- just display it.") + (COND + (HARDCOPYMODE (SUBRCALL TEDIT.BLTCHAR CH DS (FIXR (FQUOTIENT TX + SCALE)) + DISPLAYDATA DDPILOTBBT CLIPRIGHT)) + ((OR TERMSA HARDCOPYMODE) (* ; + "Using special instrns from TERMSA") + (\DSPPRINTCHAR DS CH)) + (T (* ; "Native charcodes") + (SUBRCALL TEDIT.BLTCHAR CH DS TX DISPLAYDATA DDPILOTBBT + CLIPRIGHT] + (T (* ; "CH is an object.") + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + (SETQ CURY (DSPYPOSITION NIL DS)) + DS) (* ; + "Go to the base line, left edge of the image region.") + (APPLY* (IMAGEOBJPROP CH 'DISPLAYFN) + CH DS 'DISPLAY (ffetch STREAMHINT of TEXTOBJ)) + (* ; + "Tell him to display himself here.") + (DSPFONT (ffetch CLFONT of OLOOKS) + DS) + (MOVETO (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET) + CURY DS) (* ; + "Move to after the object's image") + ] + (add TX DX) (* ; "Update our X position") + finally (freplace DDXPOSITION of DISPLAYDATA + with (IDIFFERENCE (FIXR (FQUOTIENT TX SCALE)) + XOFFSET)) (* ; + "Make any necessary looks mods to the last run of characters") + (TEDIT.MODIFYLOOKS LINE LOOKSTARTX DS OLOOKS (ffetch DESCENT of LINE] + (BITBLT CACHE 0 0 WINDOWDS 0 (ffetch YBOT of LINE) + (ffetch WRIGHT of TEXTOBJ) + LHEIGHT + 'INPUT + 'REPLACE) (* ; + "Paint the cached image on the screen (this lessens flicker during update)") + (COND + ((fetch (FMTSPEC FMTREVISED) of (ffetch (LINEDESCRIPTOR LFMTSPEC) + of LINE)) + (* ; + "This paragraph has been revised, so mark it.") + (\TEDIT.MARK.REVISION TEXTOBJ (ffetch (LINEDESCRIPTOR LFMTSPEC) of LINE) + WINDOWDS LINE))) + (SELECTQ (ffetch LMARK of LINE) + (GREY (* ; + "This line has some property that isn't visible to the user. Tell him to be careful") + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE) + 6 6 'TEXTURE 'PAINT 42405)) + (SOLID (* ; + "This line has some property that isn't visible to the user. Tell him to be careful") + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE) + 6 6 'TEXTURE 'PAINT BLACKSHADE)) + (BITBLT NIL 0 0 WINDOWDS 0 (ffetch YBASE of LINE) + 6 6 'TEXTURE 'REPLACE WHITESHADE]) (\DOLOCKPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\DONEWPAGE + [LAMBDA (BASE NOERROR LOCK?) (* ; "Edited 20-Apr-88 10:28 by MASINTER") + (SUBRCALL NEWPAGE BASE]) (\DORECLAIM + [LAMBDA NIL (* ; "Edited 12-Oct-88 12:01 by krivacic") + (SUBRCALL DORECLAIM]) (\DOTEMPLOCKPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\LOADVMEMPAGE + [LAMBDA (X) (* lmm%: 26 JUN 75 726) + X]) (\LOCKEDPAGEP + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + T]) (\LOCKPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\MOVEVMEMFILEPAGE + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + T]) (\NEWPAGE + [LAMBDA (BASE NOERROR LOCK?) (* ; "Edited 20-Apr-88 10:28 by MASINTER") + (SUBRCALL NEWPAGE BASE]) (\NS.SETTIME + [LAMBDA (RETFLG) (* ; "Edited 13-May-88 15:22 by MASINTER") + (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG))) + (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL))) + (\PROCESS.RESET.TIMERS) + (DAYTIME]) (\PAGEFAULT + [LAMBDA (X) (* lmm%: 26 JUN 75 726) + X]) (\PUP.SETTIME + [LAMBDA (RETFLG) (* ; "Edited 13-May-88 15:22 by MASINTER") + (CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG))) + (SETQ \TimeZoneComp (SUBRCALL GETUNIXTIME 8 NIL))) + (\PROCESS.RESET.TIMERS) + (DAYTIME]) (\SHOWPAGETABLE + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\TEMPUNLOCKPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\UNLOCKPAGES + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) (\WRITEDIRTYPAGE + [LAMBDA NOBIND (* lmm " 4-OCT-83 03:05") + NIL]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TimeZoneComp \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER \10MBTYPE.TRANSLATIONS \MY.NSADDRESS \RAWTRACING \MAXWATCHERGETS) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SOURCE) 10MBDECLS LLNSDECLS TEDITDCL) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE \MOVEVMEMFILEPAGE \LOCKPAGES \LOCKEDPAGEP \DOTEMPLOCKPAGES \DOLOCKPAGES \DIRTYBACKGROUND \COUNTREALPAGES CHECKPAGEMAP) ) (PRETTYCOMPRINT MAIKOLOADUPFNSCOMS) (RPAQQ MAIKOLOADUPFNSCOMS [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) MAIKOLOADUPFNS) (FNS CL::%%COPY-TIME-STATS CHECKPAGEMAP CLOCK CLOCK0 DAYTIME SETTIME \10MB.RESTART.ETHER \10MB.STARTDRIVER \10MB.TURNOFFETHER \10MB.TURNONETHER \10MBSENDPACKET \10MBWATCHER \BITBLTSUB \BLTCHAR \CHECKSUM \CLOCK0 \COUNTREALPAGES \DAYTIME0 \DIRTYBACKGROUND \DISPLAYLINE \DOLOCKPAGES \DONEWPAGE \DORECLAIM \DOTEMPLOCKPAGES \LOADVMEMPAGE \LOCKEDPAGEP \LOCKPAGES \MOVEVMEMFILEPAGE \NEWPAGE \NS.SETTIME \PAGEFAULT \PUP.SETTIME \SHOWPAGETABLE \TEMPUNLOCKPAGES \UNLOCKPAGES \WRITEDIRTYPAGE) (GLOBALVARS \TimeZoneComp \10MB.RCLK.BOX \10MB.EXPECTED.RECEIVE.INTERVAL \10MB.INPUT.TIMEOUT \10MB.INPUT.TIMER \10MBTYPE.TRANSLATIONS \MY.NSADDRESS \RAWTRACING \MAXWATCHERGETS) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (SOURCE) 10MBDECLS LLNSDECLS TEDITDCL)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE \LOCKPAGES \LOADVMEMPAGE \DOTEMPLOCKPAGES \DOLOCKPAGES \DIRTYBACKGROUND \COUNTREALPAGES CHECKPAGEMAP]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA \WRITEDIRTYPAGE \UNLOCKPAGES \TEMPUNLOCKPAGES \SHOWPAGETABLE \LOCKPAGES \LOADVMEMPAGE \DOTEMPLOCKPAGES \DOLOCKPAGES \DIRTYBACKGROUND \COUNTREALPAGES CHECKPAGEMAP) ) (PUTPROPS MAIKOLOADUPFNS COPYRIGHT ("ENVOS Corporation" 1989 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2114 31331 (CL::%%COPY-TIME-STATS 2124 . 2320) (CHECKPAGEMAP 2322 . 2440) (CLOCK 2442 . 2591) (CLOCK0 2593 . 2743) (DAYTIME 2745 . 2896) (SETTIME 2898 . 3172) (\10MB.RESTART.ETHER 3174 . 3332) (\10MB.STARTDRIVER 3334 . 4716) (\10MB.TURNOFFETHER 4718 . 4876) (\10MB.TURNONETHER 4878 . 6871) (\10MBSENDPACKET 6873 . 9145) (\10MBWATCHER 9147 . 10468) (\BITBLTSUB 10470 . 10892) (\BLTCHAR 10894 . 11026) (\CHECKSUM 11028 . 11193) (\CLOCK0 11195 . 11346) (\COUNTREALPAGES 11348 . 11467) (\DAYTIME0 11469 . 11622) (\DIRTYBACKGROUND 11624 . 11746) (\DISPLAYLINE 11748 . 28997) (\DOLOCKPAGES 28999 . 29117) (\DONEWPAGE 29119 . 29268) (\DORECLAIM 29270 . 29416) (\DOTEMPLOCKPAGES 29418 . 29540) ( \LOADVMEMPAGE 29542 . 29657) (\LOCKEDPAGEP 29659 . 29775) (\LOCKPAGES 29777 . 29893) ( \MOVEVMEMFILEPAGE 29895 . 30016) (\NEWPAGE 30018 . 30165) (\NS.SETTIME 30167 . 30445) (\PAGEFAULT 30447 . 30559) (\PUP.SETTIME 30561 . 30840) (\SHOWPAGETABLE 30842 . 30962) (\TEMPUNLOCKPAGES 30964 . 31086) (\UNLOCKPAGES 31088 . 31206) (\WRITEDIRTYPAGE 31208 . 31329))))) STOP \ No newline at end of file diff --git a/sources/MAKEINIT b/sources/MAKEINIT new file mode 100644 index 00000000..895c1666 --- /dev/null +++ b/sources/MAKEINIT @@ -0,0 +1,286 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "30-Jan-98 12:46:00" {DSK}disk2>jdstools>lc3>lispcore3.0>sources>MAKEINIT.;3 26173 + + changes to%: (FNS I.\ATOMCELL) + + previous date%: "30-Jan-98 12:10:24" +{DSK}disk2>jdstools>lc3>lispcore3.0>sources>MAKEINIT.;2) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1998 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT MAKEINITCOMS) + +(RPAQQ MAKEINITCOMS + ((FNS LOADMAKEINIT LOADMKIFILES RELOAD MAKEINIT MKI.START) + (COMS (* ; + "reading compiled files and processing well-known expressions") + (FNS MKI.PASSFILE SCRATCHARRAY DOFORM CONSTFORMP NOTICECOMS EVALFORMAKEINIT) + (FNS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.FILECREATED I.PUTPROPS I.RPAQ I.RPAQQ + I.RPAQ? I.SETTOPVAL I.NOUNDO) + (PROP MKI ADDTOVAR DECLARE%: DEFINE-FILE-INFO FILECREATED PUTPROPS RPAQ RPAQ? RPAQQ + LISPXPRINT PRETTYCOMPRINT * SETTOPVAL SETQQ SETQ /SETTOPVAL)) + (FNS I.ATOMNUMBER I.\ATOMCELL I.FIXUPNUM I.FIXUPPTR I.FIXUPSYM I.WORDSPERNAMEENTRY + I.SETSTKNTOFFSET) + (COMS (* ; "stuff for MAXC") + (FNS MKI.ATOM MKI.IEEE)) + [COMS (* ; + "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.") + (FNS MKI.DSET MKI.ADDTO MKI.PUTPROP) + (VARS (MKI.ARRAY) + (MKI.TVHA (HASHARRAY 400)) + (MKI.PLHA (HASHARRAY 150)) + (MKI.ATOMARRAY (HASHARRAY 5000)) + (INIT.EXT 'SYSOUT] + (COMS (FNS DUMPVP BOUTZEROS BIN16 BOUT16) + (VARS (MKI.FirstDataByte 1024) + (MKI.Page0Byte 512) + (MKI.DATE (DATE)) + MKI.CODESTARTOFFSET MKI.SEQUENTIAL PRINTEXPRS)) + (INITVARS (PRINTEXPRS T) + (REMOTECOMPILE.EXT COMPILE.EXT)) + [DECLARE%: DONTEVAL@LOAD DOCOPY (P (PUTPROP (NAMEFIELD (INPUT) + T) + 'LOADDATE + (GETFILEINFO (INPUT) + 'ICREATIONDATE] + (DECLARE%: EVAL@COMPILE (PROP MACRO SETXVAR IEQ) + DONTCOPY + (FILES (LOADCOMP) + MEM)))) +(DEFINEQ + +(LOADMAKEINIT (LAMBDA (LARGEFLG) (* lmm "31-JUL-81 14:27") (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (ADDTOVAR DIRECTORIES BLISP) (GCGAG 1000) (COND ((NOT LARGEFLG) (SETSEPR (QUOTE (%| 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26)) 1 FILERDTBL) (MINFS 45000 (QUOTE ARRAYP)) (MINFS 10000 (QUOTE FIXP)) (MINFS 3000 (QUOTE STRING.CHARS)) (MINFS 2000 (QUOTE ATOM.CHARS)))) (MOVD? (QUOTE NILL) (QUOTE MKNUMATOM)) (* ;; "This is a kludge to get around the problem that, while MKATOM is in LLNEW, MKNUMATOM is not, and MKATOM calls MKNUMATOM when given an atom beginning with a digit. It turns out that MKNUMATOM will always return NIL in the cases called from MAKEINIT because MAKEINIT is merely copying things which it knows are really LITATOM and spelled like it.") (MOVD? (QUOTE *) (QUOTE BLOCKRECORD)) (PUTDQ? FIXSPELL1 (LAMBDA (OLD NEW) (PRINT (LIST OLD (QUOTE ->) NEW) T T))))) (LOADMKIFILES) (SELECTQ (SYSTEMTYPE) ((D ALTO)) (PROGN (MINFS 10000 (QUOTE ALTOPOINTER)) (* ; "doesn't work until after datatype declaration has been loaded") (RECLAIM (QUOTE ARRAYP)) (RECLAIM (QUOTE ATOM.CHARS)) (MINFS 10000 (QUOTE ARRAYP)) (MINFS 5000 (QUOTE LISTP)) (SYSOUT (QUOTE MKI.SAV))))) ) + +(LOADMKIFILES (LAMBDA NIL (* mjs "13-Mar-84 14:41") (for X in (UNION MAKEINITFILES (SELECTQ (SYSTEMTYPE) ((ALTO D) NIL) MAXC.MAKEINITFILES)) do (RELOAD (PACKFILENAME (QUOTE BODY) X (QUOTE EXTENSION) COMPILE.EXT)))) ) + +(RELOAD (LAMBDA (FILE) (* lmm "13-APR-81 21:16") (PROG (DATE FULLFILENAME) RETRY (COND ((ILESSP (OR (GETPROP FILE (QUOTE LOADDATE)) MIN.INTEGER) (SETQ DATE (GETFILEINFO (SETQ FULLFILENAME (OR (FINDFILE FILE T) (GO NOTFOUND))) (QUOTE ICREATIONDATE)))) (LOAD FULLFILENAME T) (PUTPROP FILE (QUOTE LOADDATE) DATE))) (RETURN T) NOTFOUND (COND ((GETP (NAMEFIELD FILE) (QUOTE FILEDATES)) (PRINT (CONS FILE (QUOTE (already loaded))) T) (RETURN))) (ERROR FILE "not found.") (GO RETRY))) ) + +(MAKEINIT [LAMBDA (VERSIONS TYPE TOFILE LOADUPDIRS FONTDIRS) (* ; "Edited 19-Jul-90 17:26 by jds") (LOADMKIFILES) (* ;  "Load the files that have to be here to start making the init.") (PROG ([TYPELST (OR (LISTP TYPE) (OR (CDR (ASSOC TYPE MAKEINITTYPES)) (ERROR TYPE '?] FILES SIZEGUESS AFTERINITFILESET EXPRESSIONS) (* ;; "TYPELST is a list of the form (type file-list after-init-files init-size-guess)") (SETQ FILES (CADR TYPELST)) (SETQ AFTERINITFILESET (CADDR TYPELST)) (SETQ SIZEGUESS (CADDDR TYPELST)) (RESETLST [RESETSAVE (OUTPUT (SETQ TOFILE (OPENSTREAM (PACKFILENAME.STRING 'BODY (OR TOFILE (CAR TYPELST) 'XXX) 'EXTENSION INIT.EXT) 'OUTPUT 'NEW 8 (COND [NIL (* ;  "Can't do this until we can do GETFILEPTR on a sequential output file") (APPEND MKI.SEQUENTIAL '((TYPE BINARY)) (AND SIZEGUESS (CONS (LIST 'LENGTH (UNFOLD SIZEGUESS BYTESPERPAGE] (T '((TYPE BINARY] (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (FL) (AND (OPENP FL) (CLOSEF FL)) (AND RESETSTATE (DELFILE (FULLNAME FL] TOFILE)) (PROG ((OUTX TOFILE)) (SETQ DIRECTORIES LOADUPDIRS) (MKI.START) (for X in FILES do (MKI.PASSFILE X)) (* ;; "Generally loads the files in 0LISPSET and 1LISPSET, with 2LISPSET getting loaded immediately after the init starts.") (AND LOADUPDIRS (MKI.DSET 'LOADUPDIRECTORIES LOADUPDIRS)) (AND FONTDIRS (MKI.DSET 'DISPLAYFONTDIRECTORIES FONTDIRS)) [COND (AFTERINITFILESET (* ; "Load stuff that has to be loaded before we can call LOADUP. Ugly expression here is because FILESLOAD is on MACHINEINDEPENDENT.") [MKI.ADDTO 'MAKEINIT.EXPRESSIONS `((MAPC ',(EVAL AFTERINITFILESET) (FUNCTION (LAMBDA (FILE) (OR [SOME LOADUPDIRECTORIES (FUNCTION (LAMBDA (DIR FL) (COND ((SETQ FL (INFILEP (PACKFILENAME.STRING 'DIRECTORY DIR 'NAME FILE 'EXTENSION COMPILE.EXT))) (LOAD FL 'SYSLOAD) T] (PRINT (CONS FILE '(not found)) T] (MKI.ADDTO 'BOOTFILES '(MAKEINIT.EXPRESSIONS] (I.MAKEINITLAST VERSIONS))) (RETURN (FULLNAME TOFILE]) + +(MKI.START (LAMBDA NIL (* bvm%: "12-Dec-84 15:23") (SETQ RESETPTR) (SETQ RESETPC) (BOUTZEROS MKI.FirstDataByte) (CLRHASH MKI.TVHA) (CLRHASH MKI.PLHA) (CLRHASH MKI.ATOMARRAY) (RESETMEMORY) (SETQ MKI.VALUES (for X in INITVALUES bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (EVAL (CADR X))) Y)) (SETQ MKI.PTRS (for X in INITPTRS bind Y collect (SET (SETQ Y (PACK* "I." (SUBSTRING (CAR X) 2 -1))) (CADR X)) Y)) (I.MAKEINITFIRST) (MKI.DSET NIL NIL) (MKI.DSET T T) (MKI.DSET (QUOTE MAKEINITDATES) (LIST MKI.DATE (DATE))) (for X in INITCONSTANTS when (NEQ (CAR X) (QUOTE *)) do (I.FSETVAL (CAR X) (COND ((LISTP (CADR X)) (I.VAG2 (CAADR X) (CADR (CADR X)))) (T (I.\COPY (CADR X))))))) ) +) + + + +(* ; "reading compiled files and processing well-known expressions") + +(DEFINEQ + +(MKI.PASSFILE (LAMBDA (FILESET) (* ; "Edited 30-Mar-87 17:17 by bvm:") (* ;;; "Read a DCOM file and load its contents into the INIT.") (* ;;; "FILESET can be one of a number, which is a LISPSET number, or a list of file names, or a file name") (COND ((NUMBERP FILESET) (* ; "We were given a nLISPSET number. Pack it up to get the list of files") (MKI.PASSFILE (EVALV (PACK* FILESET (QUOTE LISPSET))))) ((LISTP FILESET) (* ; "We were given a list of file names") (MAPC FILESET (FUNCTION MKI.PASSFILE))) (T (* ; "It's a file name. Read it in.") (INPUT (SETQ FILESET (OPENSTREAM (OR (FINDFILE (PACKFILENAME.STRING (QUOTE BODY) FILESET (QUOTE EXTENSION) REMOTECOMPILE.EXT) T) FILESET) (QUOTE INPUT) (QUOTE OLD) 8 MKI.SEQUENTIAL))) (MKI.ADDTO (QUOTE LOADEDFILELST) (LIST (SETQ FILESET (FULLNAME FILESET)))) (PRINT FILESET T T) (LET* ((FILEROOT (NAMEFIELD FILESET)) (COMSNAMES (LIST (PACK* FILEROOT (QUOTE COMS)))) SKIPVARS MEXPRS X) (DECLARE (SPECVARS COMSNAMES SKIPVARS MEXPRS)) (* ; " used by I.RPAQQ and DOFORM") (* ;;; "Loop here reading from the dcom file into the init.") (WITH-READER-ENVIRONMENT *OLD-INTERLISP-READ-ENVIRONMENT* (until (SELECTQ (SETQ X (READ)) ((STOP NIL) (* ; "End of file") T) NIL) do (COND ((NLISTP X) (* ;; "Start of a code object. Skip the code indicator (assume it says to read with DCODERD) and read the code") (IF (NOT (LITATOM (READ))) THEN (ERROR "Bad compiled function" X)) (I.DCODERD X)) (T (* ; "It's a form. go either do it now or add it to the forms to execute inside the init.") (DOFORM X))) finally (COND ((CAR MEXPRS) (* ; "There are expressions to be executed in the INIT when it comes up. Save them.") (MKI.ADDTO (SETQ FILESET (PACK* FILEROOT ".EXPRESSIONS")) (CAR MEXPRS)) (MKI.ADDTO (QUOTE BOOTFILES) (LIST FILESET)))))) (CLOSEF (INPUT)))))) ) + +(SCRATCHARRAY (LAMBDA (NBYTES ALIGN) (* ; "Edited 30-Mar-87 16:20 by bvm:") (COND ((OR (NULL MKI.ARRAY) (IGREATERP NBYTES (ARRAYSIZE MKI.ARRAY))) (* ;; "make sure the scratch array is big enough. Note that the scratch array is unboxed, not code, since we aren't going to be storing legitimate local code in it (let's not fool the garbage collector too much).") (SETQ MKI.ARRAY (create ARRAYP TYP _ \ST.BYTE BASE _ (\ALLOCBLOCK (FOLDHI NBYTES BYTESPERCELL) UNBOXEDBLOCK.GCT 0 CELLSPERQUAD) LENGTH _ NBYTES ORIG _ 0)))) (for I from 0 to (SUB1 (UNFOLD ALIGN BYTESPERCELL)) do (\BYTESETA MKI.ARRAY I 0)) (* ; "clear the fnheader area") MKI.ARRAY) ) + +(DOFORM (LAMBDA (X NOPROP) (* bvm%: "30-Aug-86 15:36") (* ;;; "Handle a raw form found in a dcom file that's going into a makeinit.") (LET ((FN (GETPROP (CAR X) (QUOTE MKI)))) (if (AND FN (NOT NOPROP)) then (* ; "it's a local command that can be run `renamed' . Execute it in the local context.") (* ASSERT%: (CALLS I.ADDTOVAR I.DECLARE%: I.DEFINE-FILE-INFO I.DEFLIST I.FILECREATED I.PRETTYDEFMACROS I.PUTPROPS I.RPAQ I.RPAQQ I.SETHASHQ)) (APPLY* FN X) else (* ;; "it's a command that has to be done remotely, since we don't know how to do it from here. Add it to the collection of init expressions.") (COND (PRINTEXPRS (PRINT X T T))) (SETQ MEXPRS (TCONC MEXPRS X))))) ) + +(CONSTFORMP (LAMBDA (X) (* lmm " 7-MAR-80 08:54") (COND ((LISTP X) (SELECTQ (CAR X) ((QUOTE FUNCTION) X) NIL)) ((LITATOM X) (SELECTQ X (NIL (QUOTE (QUOTE NIL))) (T T) (AND (SETQ X (GETHASH X MKI.TVHA)) (KWOTE (CDR X))))) (T X))) ) + +(NOTICECOMS (LAMBDA (VAL) (* lmm "10-Mar-85 14:51") (for X in VAL when (LISTP X) do (COND ((AND (EQ (CADR X) (QUOTE *)) (LITATOM (CADDR X))) (COND ((EQ (CAR X) (QUOTE COMS)) (push COMSNAMES (CADDR X))) (T (push SKIPVARS (CADDR X))))) (T (SELECTQ (CAR X) ((COMS DECLARE%:) (NOTICECOMS (CDR X))) NIL))))) ) + +(EVALFORMAKEINIT (LAMBDA (FORM) (* bvm%: " 2-NOV-83 15:22") (COND ((LISTP FORM) (SELECTQ (CAR FORM) (MKATOM (COND ((STRINGP (CADR FORM)) (MKATOM (CADR FORM))) (T (HELP)))) (HELP))) ((FIXP FORM) FORM) (T (HELP)))) ) +) +(DEFINEQ + +(I.ADDTOVAR (LAMBDA (FORM) (* lmm " 2-DEC-81 23:58") (MKI.ADDTO (CADR FORM) (CDDR FORM)))) + +(I.DECLARE%: (LAMBDA (FORM) (* lmm "18-FEB-80 14:04") (PROG ((L FORM) (FLAG T) X FN) LP (COND ((NULL (SETQ L (CDR L))) (RETURN)) ((NLISTP (SETQ X (CAR L))) (SELECTQ X ((EVAL@LOAD DOEVAL@LOAD) (SETQ FLAG T)) (DONTEVAL@LOAD (SETQ FLAG NIL)) NIL)) (T (DOFORM X))) (GO LP))) ) + +(I.DEFINE-FILE-INFO (LAMBDA (FORM) (* bvm%: "30-Aug-86 15:32") (* ;;; "Set reader environment for reading rest of file") (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO NIL (CDR FORM)))) ) + +(I.FILECREATED (LAMBDA (X) (* ; "Edited 12-Jan-88 11:00 by bvm") (* ;; "Form is (FILECREATED date filename . otherstuff)") (COND ((NLISTP (CADDR X)) (* ; "FILENAME a list is for the %"compiled on%" expression") (LET ((NAME (NAMEFIELD (CADDR X)))) (MKI.ADDTO (QUOTE BOOTLOADEDFILES) (LIST NAME)) (MKI.PUTPROP NAME (QUOTE FILEDATES) (LIST (CONS (CADR X) (CADDR X)))))))) ) + +(I.PUTPROPS (LAMBDA (FORM) (* lpd%: "29-APR-77 13:22") (MKI.PUTPROP (CADR FORM) (CADDR FORM) (CADDDR FORM)))) + +(I.RPAQ (LAMBDA (FORM) (* edited%: "10-Jul-84 14:05") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL) T))))) ) + +(I.RPAQQ (LAMBDA (FORM) (* lmm "30-APR-80 22:12") (PROG ((ATM (CADR FORM)) (VAL (CADDR FORM))) (COND ((FMEMB ATM COMSNAMES) (NOTICECOMS VAL)) ((FMEMB ATM SKIPVARS)) (T (MKI.DSET ATM VAL))))) ) + +(I.RPAQ? (LAMBDA (FORM) (* lmm " 7-MAR-80 08:36") (PROG ((VAL (CADDR FORM)) V) (COND ((SETQ V (CONSTFORMP VAL)) (MKI.DSET (CADR FORM) (EVAL V))) (T (DOFORM (LIST (QUOTE SETTOPVAL) (KWOTE (CADR FORM)) VAL)))))) ) + +(I.SETTOPVAL (LAMBDA (FORM) (* edited%: "10-Jul-84 14:07") (PROG (V) (if (AND (EQ (CAR (LISTP (CADR FORM))) (QUOTE QUOTE)) (SETQ V (CONSTFORMP (CADDR FORM)))) then (MKI.DSET (CADR (CADR FORM)) (EVAL V)) else (DOFORM FORM T)))) ) + +(I.NOUNDO (LAMBDA (FORM) (* edited%: "10-Jul-84 14:02") (if (EQ (NTHCHAR (CAR FORM) 1) (QUOTE /)) then (DOFORM (CONS (SUBATOM (CAR FORM) 2 -1) (CDR FORM))) else (SHOULDNT))) ) +) + +(PUTPROPS ADDTOVAR MKI I.ADDTOVAR) + +(PUTPROPS DECLARE%: MKI I.DECLARE%:) + +(PUTPROPS DEFINE-FILE-INFO MKI I.DEFINE-FILE-INFO) + +(PUTPROPS FILECREATED MKI I.FILECREATED) + +(PUTPROPS PUTPROPS MKI I.PUTPROPS) + +(PUTPROPS RPAQ MKI I.RPAQ) + +(PUTPROPS RPAQ? MKI I.RPAQ?) + +(PUTPROPS RPAQQ MKI I.RPAQQ) + +(PUTPROPS LISPXPRINT MKI NILL) + +(PUTPROPS PRETTYCOMPRINT MKI NILL) + +(PUTPROPS * MKI NILL) + +(PUTPROPS SETTOPVAL MKI I.SETTOPVAL) + +(PUTPROPS SETQQ MKI I.RPAQQ) + +(PUTPROPS SETQ MKI I.RPAQ) + +(PUTPROPS /SETTOPVAL MKI I.NOUNDO) +(DEFINEQ + +(I.ATOMNUMBER [LAMBDA (A) (* ;  "Edited 27-Oct-92 14:10 by sybalsky:mv:envos") (* ;; "Given a symbol, return the symbol's atom #, in the INIT being made.") (* ;; "NB that this will work only so long as there are no NEW-SYMBOLs in the INIT, because of the LOLOC.") (I.LOLOC (COND ((LITATOM A) (MKI.ATOM A)) (T A]) + +(I.\ATOMCELL + [LAMBDA (X N) (* ; + "Edited 26-Oct-92 14:24 by sybalsky:mv:envos") + (LET ((ATOMNO (I.ATOMNUMBER X))) + (COND + (NIL + (* ;; "THIS WAS THE PRE-BIGVM CODE:") + + (LET [(LOC (SELECTC N + (10 (I.ATOMNUMBER X)) + (12 (I.ATOMNUMBER X)) + (2 (I.ATOMNUMBER X)) + (8 (I.ATOMNUMBER X)) + (SHOULDNT] + (I.ADDBASE (I.VAG2 N LOC) + LOC))) + [(EQ (LRSH ATOMNO 16) + 0) (* ; "Xerox Lisp traditional symbol") + + (* ;; + "CHANGED 1/30/98 JDS TO VAG2 44... FROM VAG2 8.. BECAUSE ATOMS MOVED (PNPSPACE SHOLE G") + + (LET [(LOC (SELECTC N + (10 4) + (12 2) + (2 6) + (8 0) + (SHOULDNT] + (I.ADDBASE (I.VAG2 \ATOM.HI 0) + (IPLUS LOC (ITIMES 10 ATOMNO] + (T (* ; + "New symbol that appears after traditional symbol runs out.") + (LET [(OFFSET (SELECTC N + (10 4) + (12 2) + (2 6) + (8 0) + (SHOULDNT] + (I.ADDBASE ATOMNO OFFSET]) + +(I.FIXUPNUM [LAMBDA (CA BN NUM MASK) (* ; "Edited 17-Jul-90 14:28 by jds") (* ;; "ÿ2ÿPerform atom-number fixup for a code block.") (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.") (I.FIXUPPTR CA BN NUM)) (T (* ;; "Otherwise, fill in the two bytes.") (\BYTESETA CA (SUB1 BN) (LOGOR (LOGAND (\BYTELT CA (SUB1 BN)) (LRSH (LOGXOR MASK 65535) 8)) (LOGAND (LRSH (LOGAND NUM MASK) 8) 255))) (\BYTESETA CA BN (LOGAND NUM 255]) + +(I.FIXUPPTR [LAMBDA (CA BN PTR) (* ; "Edited 22-Jul-90 12:10 by jds") (* ;; "Specific for MAXC --- actual ptr is same as simulated ptr") (PROG ((LOLOC (I.LOLOC PTR))) (\BYTESETA CA (SUB1 BN) (LRSH LOLOC 8)) (\BYTESETA CA BN (LOGAND LOLOC 255)) (\BYTESETA CA (IDIFFERENCE BN 2) (LOGOR (\BYTELT CA (IDIFFERENCE BN 2)) (I.HILOC PTR]) + +(I.FIXUPSYM [LAMBDA (CA BN NUM MASK) (* ; "Edited 23-Jan-91 19:04 by jds") (* ;; "ÿ2ÿPerform SYMBOL fixup for a code block.") (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) (* ;; "If it's on a machine wiht 3 byte atom numbers, treat it as a pointer.") (I.FIXUPPTR CA BN (I.ATOMNUMBER NUM))) (T (* ;; "Otherwise, fill in the two bytes.") (\BYTESETA CA (SUB1 BN) (LOGOR (LOGAND (\BYTELT CA (SUB1 BN)) (LRSH (LOGXOR MASK 65535) 8)) (LOGAND (LRSH (LOGAND (I.ATOMNUMBER NUM) MASK) 8) 255))) (\BYTESETA CA BN (LOGAND (I.ATOMNUMBER NUM) 255]) + +(I.WORDSPERNAMEENTRY [LAMBDA NIL (* ; "Edited 25-Jan-91 15:35 by jds") (* ;; "For MAKEINIT, returns the number of words in a name-table entry.") (* ;; "For the old 2-byte atom case, it's 1 word; for 3-byte atoms, 2 words.") (* ;; "An %"Entry%" means an entry in each half of the name table (symbol & type/offset).") (* ;; "While we're building the INIT, react to either :3-BYTE or :3-BYTE-INIT in the target architecture -- we're automatically CROSSCOMPILING as far as this function is concerned.") (COND ((FMEMB :3-BYTE COMPILER::*TARGET-ARCHITECTURE*) 2) ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*) 2) (T 1]) + +(I.SETSTKNTOFFSET [LAMBDA (BASE OFFSET TYPE VAL) (* ; "Edited 25-Jan-91 16:00 by jds") (* ;; "FOR MAKEINIT: 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::*TARGET-ARCHITECTURE*) (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD) TYPE) (I.FIXUPNUM BASE OFFSET VAL)) ((FMEMB :3-BYTE-INIT COMPILER::*TARGET-ARCHITECTURE*) (I.FIXUPNUM BASE (IDIFFERENCE OFFSET BYTESPERWORD) TYPE) (I.FIXUPNUM BASE OFFSET VAL)) (T (I.FIXUPNUM BASE OFFSET (IPLUS TYPE VAL]) +) + + + +(* ; "stuff for MAXC") + +(DEFINEQ + +(MKI.ATOM (LAMBDA (X) (* lmm "29-JUL-81 22:46") (* ; "for MAXC") (AND X (OR (GETHASH X MKI.ATOMARRAY) (PUTHASH X (COND ((EQ X (QUOTE NOBIND)) PTRNOBIND) (T (I.COPYATOM X))) MKI.ATOMARRAY)))) ) + +(MKI.IEEE (LAMBDA (X BOX) (* bvm%: "16-Dec-80 00:44") (* ;; "Converts pdp-10 floating-point number X to IEEE standard for Dolphin, storing (with I.PUTBASE) into BOX. For MAXC only.") (PROG (MAGNITUDE (SIGN 0) (EXP 0) (FRAC 0)) RETRY (SETQ MAGNITUDE (COND ((MINUSP X) (SETQ SIGN 32768) (IMINUS (OPENR (LOC X)))) (T (OPENR (LOC X))))) (COND ((ZEROP MAGNITUDE) (GO DONE)) ((IEQP (LOGAND MAGNITUDE 67108864) 0) (* ; "unnormalized number???") (SETQ X (FPLUS X 0.0)) (GO RETRY))) (COND ((ILEQ (SETQ EXP (IDIFFERENCE (LRSH MAGNITUDE 27) 2)) 0) (* ;; "Exponent bias is off by 1, plus another 1 because of the implicit high bit. Thus have to watch for underflow") (ERROR "Unrepresentable floating-point number" X) (SETQ EXP (SETQ SIGN 0)) (* ; "If continued, make it zero") (GO DONE))) (SETQ FRAC (IPLUS (LOGAND (LRSH MAGNITUDE 3) 16777215) (COND ((OR (ILESSP (LOGAND MAGNITUDE 7) 4) (EQ (LOGAND MAGNITUDE 15) 4)) (* ; "Round down") 0) (T 1)))) (COND ((IGREATERP FRAC 16777215) (* ; "Rounding overflowed the high bit") (SETQ FRAC (LRSH FRAC 1)) (* ; "EXP can't overflow, because of bias difference") (SETQ EXP (ADD1 EXP)))) (* ; "FRAC is now a 24-bit fraction with its high bit on") DONE (I.PUTBASE BOX 0 (LOGOR SIGN (LLSH EXP 7) (LOGAND (LRSH FRAC 16) 127))) (I.PUTBASE BOX 1 (LOGAND FRAC 65535)))) ) +) + + + +(* ; "stuff to maintain symbol values, prop lists during makeinit--all dumped at end.") + +(DEFINEQ + +(MKI.DSET (LAMBDA (A VAL) (* ; "Edited 12-Jan-88 11:03 by bvm") (LET ((LST (GETHASH A MKI.TVHA))) (COND (LST (COND ((NOT (EQUAL VAL (CDR LST))) (EXEC-FORMAT "(Value of ~S changed from ~S to ~S)~%%" A (CDR LST) VAL))) (RPLACD LST VAL)) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA))))) ) + +(MKI.ADDTO (LAMBDA (A VAL) (* lpd%: "29-APR-77 13:20") (PROG ((LST (GETHASH A MKI.TVHA))) (COND (LST (RPLACD LST (UNION VAL (CDR LST)))) (T (PUTHASH A (CONS NIL VAL) MKI.TVHA))))) ) + +(MKI.PUTPROP (LAMBDA (A PROP VAL) (* ; "Edited 12-Jan-88 11:04 by bvm") (LET ((LST (GETHASH A MKI.PLHA))) (COND (LST (COND ((LISTGET LST PROP) (EXEC-FORMAT "(Property ~S of ~S has been changed)~%%" A PROP))) (LISTPUT LST PROP VAL)) (T (PUTHASH A (LIST PROP VAL) MKI.PLHA))))) ) +) + +(RPAQQ MKI.ARRAY NIL) + +(RPAQ MKI.TVHA (HASHARRAY 400)) + +(RPAQ MKI.PLHA (HASHARRAY 150)) + +(RPAQ MKI.ATOMARRAY (HASHARRAY 5000)) + +(RPAQQ INIT.EXT SYSOUT) +(DEFINEQ + +(DUMPVP (LAMBDA (VP) (* lpd%: "27-APR-77 20:24") (PRIN1 (QUOTE *) T) (WriteoutPage OUTX VP))) + +(BOUTZEROS (LAMBDA (N) (* lmm "16-MAY-81 16:49") (FRPTQ N (\BOUT OUTX 0)))) + +(BIN16 (LAMBDA (J) (* lmm "16-MAY-81 16:49") (IPLUS (LLSH (\BIN J) 8) (\BIN J)))) + +(BOUT16 (LAMBDA (J N) (* lmm "16-MAY-81 16:51") (\BOUT J (LRSH N 8)) (\BOUT J (LOGAND N 255)))) +) + +(RPAQQ MKI.FirstDataByte 1024) + +(RPAQQ MKI.Page0Byte 512) + +(RPAQ MKI.DATE (DATE)) + +(RPAQQ MKI.CODESTARTOFFSET 60) + +(RPAQQ MKI.SEQUENTIAL ((SEQUENTIAL T))) + +(RPAQQ PRINTEXPRS T) + +(RPAQ? PRINTEXPRS T) + +(RPAQ? REMOTECOMPILE.EXT COMPILE.EXT) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(PUTPROP (NAMEFIELD (INPUT) + T) + 'LOADDATE + (GETFILEINFO (INPUT) + 'ICREATIONDATE)) +) +(DECLARE%: EVAL@COMPILE + +(PUTPROPS SETXVAR MACRO [X `(SETQ.NOREF %, (CADAR X) + %, + (CADR X]) + +(PUTPROPS IEQ MACRO ((X Y) + (IEQP X Y))) +DONTCOPY + +(FILESLOAD (LOADCOMP) + MEM) +) +(PUTPROPS MAKEINIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 + 1992 1998)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2691 9683 (LOADMAKEINIT 2701 . 3904) (LOADMKIFILES 3906 . 4126) (RELOAD 4128 . 4611) ( +MAKEINIT 4613 . 8975) (MKI.START 8977 . 9681)) (9761 13662 (MKI.PASSFILE 9771 . 11564) (SCRATCHARRAY +11566 . 12215) (DOFORM 12217 . 12894) (CONSTFORMP 12896 . 13130) (NOTICECOMS 13132 . 13440) ( +EVALFORMAKEINIT 13442 . 13660)) (13663 15783 (I.ADDTOVAR 13673 . 13767) (I.DECLARE%: 13769 . 14045) ( +I.DEFINE-FILE-INFO 14047 . 14237) (I.FILECREATED 14239 . 14613) (I.PUTPROPS 14615 . 14728) (I.RPAQ +14730 . 14951) (I.RPAQQ 14953 . 15149) (I.RPAQ? 15151 . 15366) (I.SETTOPVAL 15368 . 15600) (I.NOUNDO +15602 . 15781)) (16359 22359 (I.ATOMNUMBER 16369 . 16860) (I.\ATOMCELL 16862 . 18615) (I.FIXUPNUM +18617 . 19434) (I.FIXUPPTR 19436 . 19917) (I.FIXUPSYM 19919 . 20867) (I.WORDSPERNAMEENTRY 20869 . +21624) (I.SETSTKNTOFFSET 21626 . 22357)) (22391 23899 (MKI.ATOM 22401 . 22597) (MKI.IEEE 22599 . 23897 +)) (23996 24761 (MKI.DSET 24006 . 24289) (MKI.ADDTO 24291 . 24476) (MKI.PUTPROP 24478 . 24759)) (24935 + 25313 (DUMPVP 24945 . 25042) (BOUTZEROS 25044 . 25123) (BIN16 25125 . 25210) (BOUT16 25212 . 25311))) +)) +STOP diff --git a/sources/MAPATOMS b/sources/MAPATOMS new file mode 100644 index 00000000..299f47a3 --- /dev/null +++ b/sources/MAPATOMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "29-Mar-95 11:53:28" |{DSK}sources>MAPATOMS.;2| 3719 |changes| |to:| (FNS MAPATOMS) |previous| |date:| "29-Mar-95 10:47:32" |{DSK}sources>MAPATOMS.;1|) (PRETTYCOMPRINT MAPATOMSCOMS) (RPAQQ MAPATOMSCOMS ((FNS MAPATOMS))) (DEFINEQ (MAPATOMS (LAMBDA (FN) (* \; "Edited 29-Mar-95 11:52 by sybalsky") (* |;;| "8-FEB-92 JDS: We now switch over into big-atom mode at 12288 (changes in \\CREATE.SYMBOL should be lected here)") (PROG ((A 0) (DTD (\\GETDTD \\NEW-ATOM))) (|for| |old| A |from| 0 |to| (IMIN |\\AtomFrLst| 12286) |do| (APPLY* FN (\\INDEXATOMPNAME A))) (COND ((IGREATERP |\\AtomFrLst| 12286) (LET* ((SIZE (|fetch| DTDSIZE |of| DTD)) (ATOM# A) (FIRSTFREE (|fetch| DTDFREE |of| DTD)) (LASTFREE (|create| POINTER PAGE# _ (LOGAND (|fetch| (POINTER PAGE#) |of| FIRSTFREE ) 65534))) (LASTFREE2 (|create| POINTER PAGE# _ (ADD1 (LOGAND (|fetch| (POINTER PAGE#) |of| FIRSTFREE) 65534)))) RESULT FIRSTPAGE LASTPAGE LIMIT) (COND ((.ALLOCATED.PER.PAGE. SIZE) (SETQ LASTPAGE (SUB1 |\\PagesPerMDSUnit|)) (SETQ LIMIT WORDSPERPAGE)) (T (SETQ LASTPAGE 0) (SETQ LIMIT (FOLDLO |\\MDSIncrement| |\\PagesPerMDSUnit|)))) (|for| MDSPAGE# |from| 0 |by| (ADD1 LASTPAGE) |while| (<= MDSPAGE# \\MAXVMPAGE) |when| (EQ (MDSTYPE# MDSPAGE#) \\NEW-ATOM) |do| (* |;;|  "Now collect all pointers not on free list. This code parallels \\INITMDSPAGE") (|for| N |from| 0 |to| LASTPAGE |do| (SETQ FIRSTPAGE (|create| POINTER PAGE# _ (IPLUS N MDSPAGE#))) (|for| (DISP _ 0) |while| (<= (|add| DISP SIZE) LIMIT) |as| (DATUMBASE _ FIRSTPAGE) |by| (\\ADDBASE DATUMBASE SIZE) |when| (OR (AND (NEQ FIRSTPAGE LASTFREE) (NEQ FIRSTPAGE LASTFREE2)) (|for| (FREE _ FIRSTFREE) |by| (\\GETBASEPTR FREE 0) |while| FREE |never| (EQ DATUMBASE FREE))) |do| (APPLY* FN DATUMBASE) (|add| ATOM# 1)))) NIL)))))) ) (DECLARE\: DONTCOPY (FILEMAP (NIL (341 3696 (MAPATOMS 351 . 3694))))) STOP \ No newline at end of file diff --git a/sources/MEM b/sources/MEM new file mode 100644 index 00000000..af61de23 --- /dev/null +++ b/sources/MEM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 5-Nov-92 15:57:00" "{Pele:mv:envos}Sources>MEM.;7" 13313 changes to%: (FNS MKI.NEXTPAGE MKI.NEWPAGE WriteoutPage I.PUTBASEPTR I.GETBASEFIXP I.PUTBASEFIXP) (VARS MEMCOMS) previous date%: "16-May-90 20:36:32" "{Pele:mv:envos}Sources>MEM.;2") (* ; " Copyright (c) 1982, 1983, 1986, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MEMCOMS) (RPAQQ MEMCOMS ( (* ;; "Memory-faking functions for use in MAKEINIT. These read and write from a huge (tree-structured) set of arrays, rather than changing real memory.") (COMS (* ;; "Page creation, locking/unlocking, ") (FNS MKI.NEXTPAGE WriteoutPage MKI.NEWPAGE MKI.LOCKPAGES MKI.LOCKEDPAGEP RESETMEMORY)) (DECLARE%: EVAL@COMPILE (VARS (PTRNIL 0) (PTRNOBIND 1)) DONTCOPY (RECORDS ALTOPOINTER)) (VARS (NEWPAGETRACE) (BLANKPAGE)) (COMS (* ;; "Functions for fetching and replacing words, pointers, and FIXPs in the MAKEINIT. If, e.g., we need GETBASEFLOATP in the init, we'd have to add a definition here. You'd also need to add an entry to MKI.SUBFNS (e.g. (\GETBASEFLOATP . I.GETBASEFLOATP) ), so that the renaming code would catch it.") (FNS I.PUTBASE I.GETBASE I.PUTBASEPTR I.GETBASEPTR I.GETBASEFIXP I.PUTBASEFIXP) (DECLARE%: DONTCOPY (MACROS .DOADDBASE. I.HILOC I.LOLOC I.ADDBASE I.PAGELOC I.VAG2))) (* ;; "MEMARRAY is the fake-memory array.") (VARS (MEMARRAY)) (GLOBALVARS MEMARRAY NONPAGE NONPAGE2 PTRNIL BLANKPAGE NEWPAGETRACE))) (* ;; "Memory-faking functions for use in MAKEINIT. These read and write from a huge (tree-structured) set of arrays, rather than changing real memory." ) (* ;; "Page creation, locking/unlocking, ") (DEFINEQ (MKI.NEXTPAGE [LAMBDA (VP) (* ;  "Edited 5-Nov-92 15:40 by sybalsky:mv:envos") (* ;; "Find the next occupied virtual page, starting with VP. Can return VP, if it exists.") (* ;; "Used only in MAKEINIT.") (PROG (A I) L1 (COND ((IGREATERP VP 65535) (RETURN)) ((EQ (SETQ A (FASTELT MEMARRAY (LRSH VP 8))) NONPAGE2) (SETQ VP (ADD1 (LOGOR VP 255))) (GO L1))) (SETQ I (LOGAND VP 255)) L2 [COND ((EQ I 256) (SETQ VP (ADD1 (LOGOR VP 255))) (GO L1)) ((NEQ (FASTELT A I) NONPAGE) (RETURN (IPLUS (LOGAND VP 65280) I] (SETQ I (ADD1 I)) (GO L2]) (WriteoutPage [LAMBDA (FX VP) (* ;  "Edited 26-Oct-92 15:23 by sybalsky:mv:envos") (* For MAXC) (* ;; "Write out the page VP to file FX. Used only for MAXC, according to above comment (not verified)??") (PROG [(A (FASTELT (FASTELT MEMARRAY (LRSH VP 8)) (LOGAND VP 255] (AOUT A 0 256 FX 'SMALLPOSP]) (MKI.NEWPAGE [LAMBDA (PTR NOERROR LOCK? BLANKFLG) (* ;  "Edited 5-Nov-92 15:49 by sybalsky:mv:envos") (* ;; "Create a new virtual page for the MAKEINIT.") (PROG (A LO1 PAGE) [COND ((EQ (SETQ A (FASTELT MEMARRAY (LRSH PTR 16))) NONPAGE2) (* ;;  "This whole segment hasn't been created yet. Create it as a segment full of non-page entries.") (FASTSETA MEMARRAY (LRSH PTR 16) (SETQ A (POINTERARRAY 256 NONPAGE] [COND ((NEQ (FASTELT A (SETQ LO1 (LRSH (LOGAND PTR 65535) 8))) NONPAGE) (* ;; "This page better not yet have been allocated!") (HELP PTR '"already allocated"] (COND (NEWPAGETRACE (printout NEWPAGETRACE "page " .I3.8 (I.HILOC PTR) "," .I3.8 (LRSH (I.LOLOC PTR) 8) %,,,))) (* ;; "Fill in the MEMARRAY entry for this page with a 256-word block of nothing much. If BLANKPAGE, fill it in with the same page of blanks.") [FASTSETA A LO1 (COND ((NOT BLANKFLG) (WORDARRAY 256)) (T (OR BLANKPAGE (SETQ BLANKPAGE (WORDARRAY 256] (* ;; "If LOCK?, this is a locked page, so add it to the locked page table.") (AND LOCK? (MKI.LOCKPAGES PTR 1)) (RETURN PTR]) (MKI.LOCKPAGES [LAMBDA (PTR NPAGES) (* lmm "11-AUG-80 21:53") (push LOCKEDPAGES (CONS (I.PAGELOC PTR) NPAGES]) (MKI.LOCKEDPAGEP [LAMBDA (VP) (* lmm " 9-FEB-82 21:54") (for X in LOCKEDPAGES when [AND (IGEQ VP (CAR X)) (ILESSP VP (IPLUS (CAR X) (CDR X] do (RETURN T]) (RESETMEMORY [LAMBDA NIL (* lmm "26-MAR-81 09:23") (SETQ LOCKEDPAGES) (COND ((NULL MEMARRAY) (SETQ NONPAGE (WORDARRAY 256)) (SETQ NONPAGE2 (POINTERARRAY 256 NONPAGE)) (SETQ MEMARRAY (POINTERARRAY 256 NONPAGE2))) (T (for I from 0 to 255 do (FASTSETA MEMARRAY I NONPAGE2]) ) (DECLARE%: EVAL@COMPILE (RPAQQ PTRNIL 0) (RPAQQ PTRNOBIND 1) DONTCOPY (DECLARE%: EVAL@COMPILE (ACCESSFNS ALTOPOINTER ((HILOC (LRSH DATUM 16)) (LOLOC (LOGAND DATUM 65535))) (CREATE (IPLUS (LLSH HILOC 16) LOLOC)) [ACCESSFNS ALTOPOINTER ((6to13 (LRSH (LOGAND DATUM 65535) 8)) [bit12 (NOT (ZEROP (LOGAND 512 DATUM] (0to13 (I.PAGELOC DATUM)) (0to11 (LRSH (I.PAGELOC DATUM) 2]) ) ) (RPAQQ NEWPAGETRACE NIL) (RPAQQ BLANKPAGE NIL) (* ;; "Functions for fetching and replacing words, pointers, and FIXPs in the MAKEINIT. If, e.g., we need GETBASEFLOATP in the init, we'd have to add a definition here. You'd also need to add an entry to MKI.SUBFNS (e.g. (\GETBASEFLOATP . I.GETBASEFLOATP) ), so that the renaming code would catch it." ) (DEFINEQ (I.PUTBASE [LAMBDA (PTR D V) (PROG (HI LO1 LO2) (DECLARE (LOCALVARS . T)) (.DOADDBASE. PTR D) (AND (EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR)) (RETURN (FASTSETAW HI LO2 V]) (I.GETBASE [LAMBDA (PTR D) (PROG (HI LO1 LO2) (DECLARE (LOCALVARS HI LO1 LO2)) (.DOADDBASE. PTR D) (COND ((EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR))) (RETURN (FASTELTW HI LO2]) (I.PUTBASEPTR [LAMBDA (PTR D V) (* ;  "Edited 26-Oct-92 15:19 by sybalsky:mv:envos") (* ;; "MAKEINIT version of \PUTBASEPTR. Must be able to handle local symbols, so \CREATE.SYMBOL can set values to NOBIND. (JDS 10/26/92).") (PROG (HI LO1 LO2 (VAL (OR V PTRNIL))) (DECLARE (LOCALVARS . T)) (.DOADDBASE. PTR D) (AND (EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR)) (AND (LITATOM VAL) (SETQ VAL (I.ATOMNUMBER VAL))) (FASTSETAW HI LO2 (LRSH VAL 16)) (FASTSETAW HI (ADD1 LO2) (LOGAND VAL 65535)) (RETURN VAL]) (I.GETBASEPTR [LAMBDA (PTR D) (PROG (HI LO1 LO2) (DECLARE (LOCALVARS . T)) (.DOADDBASE. PTR D) (COND ((EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR))) (RETURN (I.VAG2 (LOGAND 255 (FASTELTW HI LO2)) (FASTELTW HI (ADD1 LO2]) (I.GETBASEFIXP [LAMBDA (PTR D) (* ;  "Edited 26-Oct-92 13:33 by sybalsky:mv:envos") (* ;; "MAKEINIT version of \GETBASEFIXP.") (PROG (HI LO1 LO2) (DECLARE (LOCALVARS HI LO1 LO2)) (.DOADDBASE. PTR D) (COND ((EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR))) (RETURN (IPLUS (LLSH (FASTELTW HI LO2) 16) (FASTELTW HI (ADD1 LO2]) (I.PUTBASEFIXP [LAMBDA (PTR D V) (* ;  "Edited 26-Oct-92 12:30 by sybalsky:mv:envos") (PROG (HI LO1 LO2) (DECLARE (LOCALVARS . T)) (.DOADDBASE. PTR D) (AND (EQ (SETQ HI (FASTELT (FASTELT MEMARRAY HI) LO1)) NONPAGE) (INVALIDADDR)) (RETURN (PROGN (FASTSETAW HI LO2 (LRSH V 16)) (FASTSETAW HI (ADD1 LO2) (LOGAND V 65535]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PROGN (PUTPROPS .DOADDBASE. MACRO ((PTR D) (ASSEMBLE NIL (CQ (VAG (IPLUS PTR D))) (LSHC 1 %, -16) (ADDI 1 %, ASZ) (SETQ HI) (LSHC 1 %, 8) (ANDI 1 %, 255) (ADDI 1 %, ASZ) (SETQ LO1) (LSHC 1 %, 8) (ANDI 1 %, 255) (ADDI 1 %, ASZ) (SETQ LO2)))) (PUTPROPS .DOADDBASE. ALTOMACRO ((PTR D) (SETQ HI (LRSH (SETQ LO2 (IPLUS PTR D)) 16)) (SETQ LO1 (LOGAND 255 (LRSH LO2 8))) (SETQ LO2 (LOGAND LO2 255)))) (PUTPROPS .DOADDBASE. DMACRO ((PTR D) (SETQ HI (LRSH (SETQ LO2 (IPLUS PTR D)) 16)) (SETQ LO1 (LOGAND 255 (LRSH LO2 8))) (SETQ LO2 (LOGAND LO2 255))))] (PUTPROPS I.HILOC MACRO ((PTR) (LRSH (OR PTR PTRNIL) 16))) (PUTPROPS I.LOLOC MACRO ((PTR) (LOGAND (OR PTR PTRNIL) 65535))) (PUTPROPS I.ADDBASE MACRO ((PTR D) (IPLUS (OR PTR PTRNIL) D))) (PUTPROPS I.PAGELOC MACRO ((PTR) (LRSH (OR PTR PTRNIL) 8))) (PUTPROPS I.VAG2 MACRO ((HI LO) ([LAMBDA (X) (DECLARE (LOCALVARS . T)) (COND ((ZEROP X) NIL) (T X] (IPLUS (LLSH HI 16) LO)))) ) ) (* ;; "MEMARRAY is the fake-memory array.") (RPAQQ MEMARRAY NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MEMARRAY NONPAGE NONPAGE2 PTRNIL BLANKPAGE NEWPAGETRACE) ) (PUTPROPS MEM COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1986 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2057 6071 (MKI.NEXTPAGE 2067 . 2967) (WriteoutPage 2969 . 3477) (MKI.NEWPAGE 3479 . 5132) (MKI.LOCKPAGES 5134 . 5332) (MKI.LOCKEDPAGEP 5334 . 5678) (RESETMEMORY 5680 . 6069)) (7250 10374 (I.PUTBASE 7260 . 7585) (I.GETBASE 7587 . 7927) (I.PUTBASEPTR 7929 . 8741) (I.GETBASEPTR 8743 . 9149) (I.GETBASEFIXP 9151 . 9786) (I.PUTBASEFIXP 9788 . 10372))))) STOP \ No newline at end of file diff --git a/sources/MENU b/sources/MENU new file mode 100644 index 00000000..d719efd3 --- /dev/null +++ b/sources/MENU @@ -0,0 +1,275 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Jul-99 15:51:36" {DSK}medley3.5>sources>MENU.;3 102161 changes to%: (FNS UPDATE/MENU/IMAGE) previous date%: "28-Jun-99 17:05:55" {DSK}medley3.5>sources>MENU.;2) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MENUCOMS) (RPAQQ MENUCOMS ((COMS (* ; "window functions") (FNS MAXMENUITEMHEIGHT MAXMENUITEMWIDTH MENU MENUTITLEFONT ADDMENU DELETEMENU MENUREGION BLTMENUIMAGE ERASEMENUIMAGE DEFAULTMENUHELDFN DEFAULTWHENSELECTEDFN BACKGROUNDWHENSELECTEDFN GETMENUITEM MENUBUTTONFN MENU.HANDLER DOSELECTEDITEM SHOWSHADEDITEMS \AddShade \DelShade \FDECODE/BUTTON MENUITEMREGION \MENUITEMLABEL \MENUSUBITEMS CHECK/MENU/IMAGE PPROMPT2 UPDATE/MENU/IMAGE \MAKE.ITEMS.VERT.ORDER \SHOWMENULABEL \POSITION.MENU.IMAGE \SMASHMENUIMAGEONRESET CLOSE.PROCESS.MENU DEFAULTSUBITEMFN GETMENUPROP PUTMENUPROP WAKE.MY.PROCESS \INVERTITEM \MENU.ITEM.SELECT \MENU.ITEM.DESELECT \ItemNumber \BOXITEM NESTED.SUBMENU NESTED.SUBMENU.POS WFROMMENU) (BITMAPS MENUSUBITEMMARK) (INITVARS (MENUFONT (FONTCREATE 'HELVETICA 10))) (DECLARE%: DONTCOPY (MACROS MENU.HELDSTATE.RESET MENU.PRIN2.FLG))) (COMS (* ;  "scrolling menu functions and utilities") (FNS MENUREPAINTFN)) (COMS (* ; "misc utility fns.") (FNS MAXSTRINGWIDTH CENTEREDPRIN1 CENTERPRINTINREGION CENTERPRINTINAREA STRICTLY/BETWEEN)) (COMS (* ; "examples of use.") (FNS UNREADITEM TYPEINMENU SHADEITEM RESHADEITEM MOST/VISIBLE/OPERATION %#BITSON BUTTONPANEL BUTTONPANEL/SELECTION/FN GETSELECTEDITEMS) (VARS EDITCMDS MENUHELDWAIT) (CONSTANTS (BITSPERSHADE 16)) (GLOBALVARS MENUSELECTSHADE) (VARS MENUSELECTSHADE) (FNS MENUDESELECT MENUSELECT)) (DECLARE%: DOCOPY DONTEVAL@LOAD (VARS (MENUFONT))) (GLOBALVARS MENUFONT MENUHELDWAIT) (RECORDS MENU))) (* ; "window functions") (DEFINEQ (MAXMENUITEMHEIGHT [LAMBDA (MENU) (* kbr%: "27-May-85 13:31") (* returns the height of the largest  menu item label in the menu MENU.) (PROG (FONTHEIGHT LABEL ANSWER) (SETQ FONTHEIGHT (FONTPROP (fetch (MENU MENUFONT) of MENU) 'HEIGHT)) (SETQ ANSWER 0) [for ITEM in (fetch (MENU ITEMS) of MENU) do (SETQ LABEL (\MENUITEMLABEL ITEM)) (SETQ ANSWER (IMAX ANSWER (COND ((BITMAPP LABEL) (fetch (BITMAP BITMAPHEIGHT) of LABEL)) (T FONTHEIGHT] (RETURN ANSWER]) (MAXMENUITEMWIDTH [LAMBDA (MENU NOSUBITEMMARK) (* bvm%: "14-Oct-86 13:04") (* returns the width of the largest  menu item label in the menu MENU.) (DECLARE (GLOBALVARS MENUSUBITEMMARK)) (for I in (fetch (MENU ITEMS) of MENU) bind (ANSWER _ 0) (FONT _ (fetch (MENU MENUFONT) of MENU)) (P2FLG _ (MENU.PRIN2.FLG MENU)) LABEL SUBITEMS do (SETQ LABEL (\MENUITEMLABEL I)) [SETQ SUBITEMS (COND ((NOT NOSUBITEMMARK) (\MENUSUBITEMS MENU I] [SETQ ANSWER (IMAX ANSWER (IPLUS (COND ((BITMAPP LABEL) (fetch (BITMAP BITMAPWIDTH) of LABEL)) (T (IPLUS (STRINGWIDTH LABEL FONT P2FLG NIL ) 2))) (COND (SUBITEMS (BITMAPWIDTH MENUSUBITEMMARK)) (T 0] finally (RETURN ANSWER]) (MENU [LAMBDA (MENU POSITION RELEASECONTROLFLG NESTEDFLG)(* ; "Edited 21-Jun-88 19:00 by jds") (DECLARE (LOCALVARS . T)) (* ;; "puts a menu on the screen and waits for the user to select one of the items") (\DTEST MENU 'MENU) (PROG (IMAGE SELVAL DSP) (* ; "make sure the image is a window") [SETQ IMAGE (COND ((NOT (EQ POSITION 'INPLACE)) (\POSITION.MENU.IMAGE MENU POSITION)) (T (fetch (MENU IMAGE) of MENU] (SETQ DSP (WINDOWPROP IMAGE 'DSP)) [SETQ SELVAL (RESETLST (RESETSAVE (OPENW IMAGE) (LIST 'CLOSEW IMAGE)) (COND (RELEASECONTROLFLG (PROG (MVAL) (WINDOWPROP IMAGE 'MENUPROCESS (THIS.PROCESS)) (WINDOWPROP IMAGE 'CLOSEFN 'CLOSE.PROCESS.MENU) (WINDOWPROP IMAGE 'BUTTONEVENTFN 'WAKE.MY.PROCESS) LP (TOTOPW IMAGE) (OR [NOT (EQ T (SETQ MVAL (BLOCK 200] (RETURN NIL)) (GETMOUSESTATE) (* ;  "if mouse state is up, then someone came into the window with the mouse down. Ignore it.") (OR (MOUSESTATE (OR LEFT RIGHT MIDDLE)) (GO LP)) (* ;  "MVAL will be NIL only if the user clicked up outside the window") (OR (SETQ MVAL (MENU.HANDLER MENU DSP NIL T NESTEDFLG)) (GO LP)) (RETURN MVAL))) (T (MENU.HANDLER MENU DSP T T NESTEDFLG))))] (* ;  "evaluate menu form after image has been taken down.") (RETURN (COND (NESTEDFLG SELVAL) (SELVAL (DOSELECTEDITEM MENU (CAR SELVAL) (CDR SELVAL]) (MENUTITLEFONT [LAMBDA (MENU SCREEN) (* kbr%: " 2-Sep-85 14:35") (* returns the title font for a  menu.) (PROG (TITLEFONT) [COND ((NULL SCREEN) (COND [(type? WINDOW (fetch (MENU IMAGE) of MENU)) (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) of MENU] (T (SETQ SCREEN LASTSCREEN] (RETURN (COND ((NULL (SETQ TITLEFONT (fetch (MENU MENUTITLEFONT) of MENU))) (* use the window title font) (DSPFONT NIL (fetch (SCREEN SCTITLEDS) of SCREEN))) ((EQ TITLEFONT T) (* use the menu item font) (fetch (MENU MENUFONT) of MENU)) ((FONTP (\COERCEFONTDESC TITLEFONT 'DISPLAY T))) (T (DSPFONT NIL (fetch (SCREEN SCTITLEDS) of SCREEN]) (ADDMENU [LAMBDA (ADDEDMENU W POSITION DONTOPENFLG) (* kbr%: "24-Jan-86 18:00") (* adds a menu to a window. If W is not given, it is created;  sized a necessary.) (OR (TYPENAMEP ADDEDMENU 'MENU) (\ILLEGAL.ARG ADDEDMENU)) (PROG (IMAGEWIDTH IMAGEHEIGHT SCREEN) (SETQ IMAGEWIDTH (fetch (MENU IMAGEWIDTH) of ADDEDMENU)) (SETQ IMAGEHEIGHT (fetch (MENU IMAGEHEIGHT) of ADDEDMENU)) (* put menu at POSITION if argument,  otherwise its stored position,  otherwise at cursorposition) [COND ((POSITIONP POSITION)) ((SETQ POSITION (fetch (MENU MENUPOSITION) of ADDEDMENU))) (W (* if a window is given, put it in  the lower left corner.) (SETQ POSITION (create POSITION XCOORD _ 0 YCOORD _ 0))) (T (SETQ POSITION (create POSITION XCOORD _ LASTMOUSEX YCOORD _ LASTMOUSEY] [COND ((WINDOWP W) (* adding to an existing window. To avoid partial images when window is partly  off the screen, this case could close window then blt to save region then  reopen window.) (* locate menu grid in MENU.) (replace (REGION LEFT) of (fetch (MENU MENUGRID) of ADDEDMENU) with (IPLUS (fetch (POSITION XCOORD) of POSITION) (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU))) (replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of ADDEDMENU) with (IPLUS (fetch (POSITION YCOORD) of POSITION) (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU))) (* Blt image into Window.) (BLTMENUIMAGE ADDEDMENU (WINDOWPROP W 'DSP) DONTOPENFLG)) (T (* have to create new window.  Put position at Origin.) (SETQ SCREEN (COND ((type? SCREEN W) W) (T LASTSCREEN))) (SETQ W (CREATEWFROMIMAGE (BITMAPCOPY (CHECK/MENU/IMAGE ADDEDMENU NIL SCREEN)) SCREEN)) (MOVEW W (fetch (POSITION XCOORD) of POSITION) (fetch (POSITION YCOORD) of POSITION) SCREEN) (SHOWSHADEDITEMS ADDEDMENU W) (SETQ POSITION (create POSITION XCOORD _ 0 YCOORD _ 0)) (* locate menu grid in MENU.) (replace (REGION LEFT) of (fetch (MENU MENUGRID) of ADDEDMENU) with (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)) (replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of ADDEDMENU) with (fetch (MENU MENUOUTLINESIZE) of ADDEDMENU)) (OR DONTOPENFLG (OPENW W] (* put MENUBUTTONFN in CURSORINFN so it will get called if button is down and  moves into W.) (WINDOWPROP W 'CURSORINFN (FUNCTION MENUBUTTONFN)) (* Set ButtonEventFn to activate  menu selection.) (WINDOWPROP W 'BUTTONEVENTFN (FUNCTION MENUBUTTONFN)) (WINDOWPROP W 'CURSORMOVEDFN (FUNCTION MENUBUTTONFN)) (* put ADDEDMENU on USERDATA so  MENUBUTTONFN can get at it.) (WINDOWADDPROP W 'MENU ADDEDMENU) (WINDOWADDPROP W 'REPAINTFN (FUNCTION MENUREPAINTFN)) [COND ((NULL (fetch (MENU WHENSELECTEDFN) of ADDEDMENU)) (* make the default selection function call EVAL.AS.PROCESS instead of EVAL so  it won't tie up background.) (replace (MENU WHENSELECTEDFN) of ADDEDMENU with (FUNCTION BACKGROUNDWHENSELECTEDFN ] [COND ((NOT (SUBREGIONP (DSPCLIPPINGREGION NIL W) (MENUREGION ADDEDMENU))) (* if the menu didn't fit, make it  scrollable.) (WINDOWPROP W 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (EXTENDEXTENT W (MENUREGION ADDEDMENU] (RETURN W]) (DELETEMENU [LAMBDA (MENU CLOSEFLG FROMWINDOW) (* rrb " 6-Apr-84 11:55") (* deletes a menu from its window. If it is the only menu in the window and  CLOSEFLG is non-NIL, it closes the window.) (OR (TYPENAMEP MENU 'MENU) (\ILLEGAL.ARG MENU)) (PROG ([W (COND ((type? WINDOW FROMWINDOW) FROMWINDOW) (T (WFROMMENU MENU] OTHERMENUS) (* see if menu is in a window.) (OR W (RETURN)) (* Blt image out of Window.) (ERASEMENUIMAGE MENU W) [COND [[NULL (CDR (SETQ OTHERMENUS (WINDOWPROP W 'MENU] (* last menu) (OR (EQ MENU (CAR OTHERMENUS)) (ERROR "MENU not correctly in W")) (WINDOWPROP W 'MENU NIL) (COND (CLOSEFLG (CLOSEW W] (T (WINDOWPROP W 'MENU (DREMOVE MENU OTHERMENUS] (COND ((EQ (fetch (MENU WHENSELECTEDFN) of MENU) (FUNCTION BACKGROUNDWHENSELECTEDFN)) (* return the default selection function call EVAL instead of EVAL.AS.PROCESS  so it will return the correct value.) (replace (MENU WHENSELECTEDFN) of MENU with NIL))) (RETURN W]) (MENUREGION [LAMBDA (MENU) (* rrb " 9-FEB-82 09:37") (* returns the region covered by the  image of a MENU) (* calls IMAGEWIDTH first so that it  will calculate an image if none  exists yet.) (create REGION WIDTH _ (fetch (MENU IMAGEWIDTH) of MENU) HEIGHT _ (fetch (MENU IMAGEHEIGHT) of MENU) LEFT _ (fetch (MENU MENUREGIONLEFT) of MENU) BOTTOM _ (fetch (MENU MENUREGIONBOTTOM) of MENU]) (BLTMENUIMAGE [LAMBDA (MENU WIN DONTOPEN) (* hdj "12-Apr-85 14:05") (* Displays a menu image at its  position on DS.) (PROG ([SRC (COND ((WINDOWP (fetch IMAGE of MENU)) (fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MENU))) (T (fetch IMAGE of MENU] (DSTWIN (\INSUREWINDOW WIN))) (RETURN (COND [(AND DONTOPEN (NOT (OPENWP DSTWIN))) (* leave the window closed) (PROG ((BORDER (WINDOWPROP DSTWIN 'BORDER)) (CR (DSPCLIPPINGREGION NIL DSTWIN))) (RETURN (PROG1 (BITBLT SRC 0 0 (fetch (WINDOW SAVE) of DSTWIN) (IPLUS BORDER (fetch (MENU MENUREGIONLEFT) of MENU)) (IPLUS BORDER (fetch (MENU MENUREGIONBOTTOM ) of MENU)) (IMIN (BITMAPWIDTH SRC) (fetch (REGION WIDTH) of CR)) (IMIN (BITMAPHEIGHT SRC) (fetch (REGION HEIGHT) of CR))) (SHOWSHADEDITEMS MENU DSTWIN] (T (PROG1 (BITBLT SRC NIL NIL DSTWIN (fetch (MENU MENUREGIONLEFT) of MENU) (fetch (MENU MENUREGIONBOTTOM) of MENU)) (SHOWSHADEDITEMS MENU DSTWIN]) (ERASEMENUIMAGE [LAMBDA (MENU W) (* rrb "19-MAR-82 10:26") (* removes the menu image from a window by clearing the place it used to  occupy. Image may be different from stored image because user may have shaded  an item.) (BITBLT NIL NIL NIL (WINDOWPROP W 'DSP) (IDIFFERENCE (fetch (REGION LEFT) of (fetch (MENU MENUGRID) of MENU)) (fetch MENUOUTLINESIZE of MENU)) (IDIFFERENCE (fetch (REGION BOTTOM) of (fetch (MENU MENUGRID) of MENU)) (fetch MENUOUTLINESIZE of MENU)) (fetch (MENU IMAGEWIDTH) of MENU) (fetch (MENU IMAGEHEIGHT) of MENU) 'TEXTURE 'REPLACE]) (DEFAULTMENUHELDFN [LAMBDA (ITEM) (* rrb "23-NOV-81 12:41") (COND ((AND (LISTP ITEM) (CADDR ITEM)) (PROMPTPRINT (CADDR ITEM))) (T (PROMPTPRINT "Will select this item when you release the button."]) (DEFAULTWHENSELECTEDFN [LAMBDA (ITEM FROMMENU BUTTON) (* rrb "24-Feb-84 15:01") (* default Menu handler) (COND ((AND (LISTP ITEM) (LISTP (CDR ITEM))) (STKEVAL (OR (STKPOS 'MENU) 'MENUBUTTONFN) (CADR ITEM) T)) (T ITEM]) (BACKGROUNDWHENSELECTEDFN [LAMBDA (ITEM FROMMENU BUTTON) (* rrb "27-AUG-82 10:17") (* default Menu handler for fixed menus.  It differs from DEFAULTWHENSELECTEDFN by calling EVAL.AS.PROCESS instead of  EVAL.) (COND [(LISTP ITEM) (COND ((CDR ITEM) (EVAL.AS.PROCESS (CADR ITEM))) (T (CAR ITEM] (T ITEM]) (GETMENUITEM [LAMBDA (MENU XGRID YGRID) (* rrb "31-JUL-81 07:31") (* returns the menu item that is in  grid location {XGRID,YGRID}.) (CAR (FNTH (fetch (MENU ITEMS) of MENU) (IPLUS (ITIMES (SUB1 (IDIFFERENCE (fetch MENUROWS of MENU) YGRID)) (fetch MENUCOLUMNS of MENU)) XGRID 1]) (MENUBUTTONFN [LAMBDA (W) (* rrb "18-APR-83 17:19") (COND [(LASTMOUSESTATE (OR LEFT MIDDLE RIGHT)) (TOTOPW W) (bind SELECTION for MENU in (WINDOWPROP W 'MENU) when [SETQ SELECTION (MENU.HANDLER MENU (WINDOWPROP W 'DSP] do (DOSELECTEDITEM MENU (CAR SELECTION) (CDR SELECTION] (T (* must have been button up or a  cursor move event.) NIL]) (MENU.HANDLER + [LAMBDA (MENU DSP KEEPCONTROLIFOUTFLG CHANGEOFFSETFLG NESTEDFLG) + (* ; "Edited 28-Dec-93 12:56 by sybalsky") + (DECLARE (SPECVARS SUBMENU MOVEDLEFT)) + + (* ;; "handles details of watching mouse for menus.") + + (RESETLST + (RESETSAVE NIL (LIST '\SMASHMENUIMAGEONRESET MENU)) + [PROG (ITEM SUBITEMS SUBMENURESULT OLDBOXX OLDBOXY BOXX BOXY HELDSTATE + (MOUSEDOWN (LASTMOUSESTATE (NOT UP))) + (MOVEDLEFT "NESTED") + (LASTBUTTONSTATE LASTMOUSEBUTTONS) + (MGRIDSPEC (fetch (MENU MENUGRID) of MENU)) + (HOLDTIMER (SETUPTIMER MENUHELDWAIT)) + (HELDFN (fetch (MENU WHENHELDFN) of MENU)) + (NROWS (fetch (MENU MENUROWS) of MENU)) + (NCOLUMNS (fetch (MENU MENUCOLUMNS) of MENU)) + SUBMENUWINDOW SUBMENU (LOCALMENUHELDWAIT (OR (FIXP MENUHELDWAIT) + 1200))) + + (* ;; "SUBMENUWINDOW is used to hold the window of the submenu and to indicate if a submenu is up. SUBMENU is to hold onto the submenu so it can be passed to MENU if it is entered.") + + [COND + ((AND MOUSEDOWN (STRICTLY/BETWEEN (SETQ BOXY (GRIDYCOORD (LASTMOUSEY DSP) + MGRIDSPEC)) + -1 NROWS) + (STRICTLY/BETWEEN (SETQ BOXX (GRIDXCOORD (LASTMOUSEX DSP) + MGRIDSPEC)) + -1 NCOLUMNS)) + + (* ;; "make a special check for when the last state was down and save the information about which item that was over.") + + (SETQ SUBMENUWINDOW (\MENU.ITEM.SELECT (SETQ OLDBOXX BOXX) + (SETQ OLDBOXY BOXY) + MENU DSP] + (RETURN (COND + ([SETQ ITEM + (ERSETQ (until (COND + (MOUSEDOWN (* ; + "if mouse has been down, process it") + (MOUSESTATE UP)) + ((MOUSESTATE (NOT UP)) + (* ; + "mouse hasn't been down but just went down.") + [COND + ((AND (NULL KEEPCONTROLIFOUTFLG) + (LASTMOUSESTATE RIGHT)) + (DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY))) + (T (SETQ MOUSEDOWN T) + (COND + (OLDBOXX + (* ; + "switch between boxing to flipping items.") + (\BOXITEM OLDBOXX OLDBOXY MENU + DSP) + (SETQ SUBMENUWINDOW + (\MENU.ITEM.SELECT OLDBOXX + OLDBOXY MENU DSP] + NIL)) + do [COND + [[OR (AND SUBMENUWINDOW (INSIDE? (fetch + (WINDOW REG) + of + SUBMENUWINDOW + ) + LASTMOUSEX LASTMOUSEY) + ) + (AND SUBMENU (EQ (GRIDYCOORD (LASTMOUSEY DSP) + MGRIDSPEC) + OLDBOXY) + (IGEQ (GRIDXCOORD (LASTMOUSEX DSP) + MGRIDSPEC) + (COND + (OLDBOXX (PLUS OLDBOXX 1)) + (T NCOLUMNS] + + (* ;; "either the cursor moved into or already was inside of the submenu, or it rolled out the right side of an item that has non-popup submenu items. It could already be inside if the submenu came up over the menu. This can lead to funny interactions of submenus popping up and automatically being selected when near the right edge of the screen but I can't think of anything better and this is at least consistent.") + (* ; + "call submenu and process result.") + (COND + ((EQ (SETQ SUBMENURESULT + (MENU SUBMENU + (COND + (SUBMENUWINDOW 'INPLACE) + (T (NESTED.SUBMENU.POS + MENU + (GETMENUITEM MENU OLDBOXX + OLDBOXY) + DSP))) + NIL T)) + MOVEDLEFT) + (* ; + "user moved back to left without selecting anything.") + + (* ;; "reopen the submenu which was closed by MENU on its way out. This would be cleaner to have MENU not close it but this is hard to error set protect correctly.") + + (AND SUBMENUWINDOW (OPENW SUBMENUWINDOW)) + (SETQ SUBMENURESULT NIL)) + (T (* ; "selected something from submenu") + (COND + (MOUSEDOWN (\MENU.ITEM.DESELECT OLDBOXX + OLDBOXY MENU DSP)) + (T (\BOXITEM OLDBOXX OLDBOXY MENU DSP)) + ) + (MENU.HELDSTATE.RESET OLDBOXX OLDBOXY) + (SETQ OLDBOXX) + (GO OUT] + [(AND (STRICTLY/BETWEEN (SETQ BOXY + (GRIDYCOORD (LASTMOUSEY + DSP) + MGRIDSPEC)) + -1 NROWS) + (STRICTLY/BETWEEN (SETQ BOXX + (GRIDXCOORD (LASTMOUSEX + DSP) + MGRIDSPEC)) + -1 NCOLUMNS)) + (* ; + "BOXX and BOXY hold the number of the box pointed at.") + (COND + ((OR (NEQ BOXX OLDBOXX) + (NEQ BOXY OLDBOXY)) + (* ; "selected item has changed.") + (* ; + "deselect old item if there was one.") + [COND + (OLDBOXX (COND + (MOUSEDOWN (\MENU.ITEM.DESELECT + OLDBOXX OLDBOXY MENU + DSP)) + (T (\BOXITEM OLDBOXX OLDBOXY + MENU DSP))) + (MENU.HELDSTATE.RESET OLDBOXX OLDBOXY) + ) + (T (SETQ HOLDTIMER (SETUPTIMER + LOCALMENUHELDWAIT + HOLDTIMER] + (* ; "invert new item") + (COND + (MOUSEDOWN (SETQ SUBMENUWINDOW + (\MENU.ITEM.SELECT BOXX BOXY + MENU DSP))) + (T (\BOXITEM BOXX BOXY MENU DSP))) + (SETQ OLDBOXX BOXX) + (SETQ OLDBOXY BOXY)) + ((AND HELDFN (NULL HELDSTATE) + (TIMEREXPIRED? HOLDTIMER)) + (* ; + "same button in same region for MENUHELDWAIT milliseconds.") + (APPLY* HELDFN (GETMENUITEM MENU OLDBOXX + OLDBOXY) + MENU + (\FDECODE/BUTTON LASTBUTTONSTATE)) + (SETQ HELDSTATE T] + (T (* ; + "cursor moved out of the menu, deselect any selected items") + (COND + (OLDBOXX (COND + (MOUSEDOWN (\MENU.ITEM.DESELECT + OLDBOXX OLDBOXY MENU + DSP)) + (T (\BOXITEM OLDBOXX OLDBOXY + MENU DSP))) + (MENU.HELDSTATE.RESET OLDBOXX OLDBOXY) + (SETQ OLDBOXX))) + (COND + ((AND NESTEDFLG BOXX (IGREATERP 0 BOXX) + (ILESSP (LASTMOUSEX DSP) + 0)) + + (* ;; "make sure the mouse has moved all the way past the left including its border and outline size. We know it has to be a popup menu that will have 0 as its left edge.") + (* ; + "if this is a nested call and the user moved to the left, return indicator of this.") + (RETURN MOVEDLEFT)) + ((NOT KEEPCONTROLIFOUTFLG) + (RETURN] + (COND + ((NEQ LASTBUTTONSTATE (SETQ LASTBUTTONSTATE + LASTMOUSEBUTTONS)) + (* ; "reset held timer") + (MENU.HELDSTATE.RESET OLDBOXX OLDBOXX))) + finally (* ; + "turn off inverse image. and call whenunheldfn is necessary.") + OUT + (COND + (OLDBOXX (COND + (MOUSEDOWN (\MENU.ITEM.DESELECT + OLDBOXX OLDBOXY MENU DSP + )) + (T (\BOXITEM OLDBOXX OLDBOXY MENU DSP) + )) + (MENU.HELDSTATE.RESET OLDBOXX OLDBOXY))) + + (* ;; "if called for, change the menu offset so the menu will come up in the same place relative to the cursor next time.") + + [COND + ((AND CHANGEOFFSETFLG OLDBOXX) + (SELECTQ (fetch (MENU CHANGEOFFSETFLG) + of MENU) + ((Y NIL)) + (replace (POSITION XCOORD) + of (fetch (MENU MENUOFFSET) + of MENU) with (LASTMOUSEX + DSP))) + (SELECTQ (fetch (MENU CHANGEOFFSETFLG) + of MENU) + ((X NIL)) + (replace (POSITION YCOORD) + of (fetch (MENU MENUOFFSET) + of MENU) with (LASTMOUSEY + DSP] + (RETURN (COND + (SUBMENURESULT) + (OLDBOXX (CONS (GETMENUITEM MENU OLDBOXX + OLDBOXY) + (\FDECODE/BUTTON + LASTBUTTONSTATE] + (* ; "no error") + (RETURN (CAR ITEM))) + (T (* ; + "user ^E --- reset the menu selection. ^d is handled by RESETLST.") + [COND + (OLDBOXX (COND + (MOUSEDOWN (\MENU.ITEM.DESELECT OLDBOXX OLDBOXY MENU + DSP)) + (T (\BOXITEM OLDBOXX OLDBOXY MENU DSP] + (ERROR!])]) (DOSELECTEDITEM [LAMBDA (MENU ITEM BUTTON) (* ; "Edited 9-Apr-94 00:43 by rmk:") (* rrb "28-JAN-82 16:33") (CL:UNLESS [EQ '*DUMMYITEM* (CAR (LISTP (CDR (LISTP ITEM] (APPLY* (OR (fetch WHENSELECTEDFN of MENU) (FUNCTION DEFAULTWHENSELECTEDFN)) ITEM MENU BUTTON))]) (SHOWSHADEDITEMS [LAMBDA (MENU DSP) (* edited%: "31-Dec-00 19:10") (* shades a menu item with a background shade.  DS/W if provided is the displaystream to use.) (PROG ((ALLITEMS (fetch (MENU ITEMS) of MENU)) SHADE ITEM ITEMREGION ANYSUBITEMS) (SETQ ANYSUBITEMS (for ITEM in ALLITEMS thereis (\MENUSUBITEMS MENU ITEM))) (for ITEMDESCR in (fetch (MENU SHADEDITEMS) of MENU) do [SETQ ITEM (CAR (NTH ALLITEMS (CAR ITEMDESCR] (SETQ SHADE (CDR ITEMDESCR)) (SETQ ITEMREGION (MENUITEMREGION ITEM MENU)) (OR ITEMREGION (RETURN)) (* if the menu is not in a window  don't do anything.) [COND (ANYSUBITEMS (replace (REGION WIDTH) of ITEMREGION with (DIFFERENCE (fetch (REGION WIDTH) of ITEMREGION ) (BITMAPWIDTH MENUSUBITEMMARK] (RESHADEITEM ITEM ITEMREGION MENU SHADE DSP]) (\AddShade [LAMBDA (ITEM SHADE MENU) (* ; "Edited 29-Jul-87 14:56 by scp") (PROG ((INDEX (\ItemNumber ITEM (fetch (MENU ITEMS) of MENU))) (SHADEDITEMS (fetch (MENU SHADEDITEMS) of MENU))) (if (NULL INDEX) then (RETURN)) (for SHADEDITEM in SHADEDITEMS do (if (EQ (CAR SHADEDITEM) INDEX) then (RPLACD SHADEDITEM SHADE) (RETURN)) finally (SETQ SHADEDITEMS (CONS (CONS INDEX SHADE) SHADEDITEMS))) (* ;; "(if (EQ SHADE 0) then (* we take shade = 0 to mean 'unshade') (SETQ SHADEDITEMS (\DelShade INDEX SHADEDITEMS)) else (for SHADEDITEM in SHADEDITEMS do (if (EQ (CAR SHADEDITEM) INDEX) then (RPLACD SHADEDITEM SHADE) (RETURN)) finally (SETQ SHADEDITEMS (CONS (CONS INDEX SHADE) SHADEDITEMS)))) ") (replace (MENU SHADEDITEMS) of MENU with SHADEDITEMS]) (\DelShade [LAMBDA (KEY LIST) (* hdj " 4-Sep-85 14:42") (COND ((NULL LIST) NIL) ((EQ KEY (CAAR LIST)) (CDR LIST)) (T (CONS (CAR LIST) (\DelShade KEY (CDR LIST]) (\FDECODE/BUTTON [LAMBDA (BUTTONSTATE) (* rrb " 9-JAN-82 13:59") (* return RED BLUE or YELLOW from a  button state.) (SELECTQ BUTTONSTATE (4 'LEFT) (2 'RIGHT) (1 'MIDDLE) NIL]) (MENUITEMREGION [LAMBDA (ITEM IMENU) (* ;  "Edited 8-Jul-93 19:26 by sybalskY:MV:ENVOS") (* ;  "returns the region for ITEM in IMENU. NIL if ITEM isn't in IMENU.") (CHECK/MENU/IMAGE IMENU) (* ; "COMPUTE MENUCOLUMNS ETC") (PROG (ITEMNUMBER (ITEMS (fetch (MENU ITEMS) of IMENU)) (GRIDSPEC (fetch (MENU MENUGRID) of IMENU)) (BORDER (fetch (MENU MENUBORDERSIZE) of IMENU))) [SETQ ITEMNUMBER (IDIFFERENCE (LENGTH ITEMS) (LENGTH (OR (FMEMB ITEM ITEMS) (for ITEMTAIL on ITEMS when (EQ (CAR (LISTP (CAR ITEMTAIL))) ITEM) do (RETURN ITEMTAIL)) (RETURN] (RETURN (create REGION LEFT _ (IPLUS (fetch (REGION LEFT) of GRIDSPEC) (ITIMES (IREMAINDER ITEMNUMBER (fetch (MENU MENUCOLUMNS) of IMENU)) (fetch (REGION WIDTH) of GRIDSPEC)) BORDER) BOTTOM _ (IPLUS (fetch (REGION BOTTOM) of GRIDSPEC) (ITIMES [SUB1 (IDIFFERENCE (fetch (MENU MENUROWS) of IMENU) (IQUOTIENT ITEMNUMBER (fetch (MENU MENUCOLUMNS ) of IMENU] (fetch (REGION HEIGHT) of GRIDSPEC)) BORDER) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of GRIDSPEC) (ITIMES 2 BORDER)) HEIGHT _ (IDIFFERENCE (fetch (REGION HEIGHT) of GRIDSPEC) (ITIMES 2 BORDER]) (\MENUITEMLABEL [LAMBDA (ITEM) (* rrb "21-AUG-81 08:13") (* returns the item label of an  item.) (COND ((LISTP ITEM) (CAR ITEM)) (T ITEM]) (\MENUSUBITEMS [LAMBDA (MENU ITEM) (* rrb "29-Dec-83 09:54") (APPLY* (OR (fetch (MENU SUBITEMFN) of MENU) (FUNCTION DEFAULTSUBITEMFN)) MENU ITEM]) (CHECK/MENU/IMAGE [LAMBDA (MENU MAKEWINDOWFLG SCREEN) (* kbr%: " 5-Sep-85 20:31") (* returns menus image, creating one if necessary.  The image field will be a WINDOW for popup menus.) (PROG (IMAGE DSP WINDOW) (OR (type? MENU MENU) (\ILLEGAL.ARG MENU)) (SETQ IMAGE (fetch (MENU IMAGE) of MENU)) [OR SCREEN (SETQ SCREEN (COND ((type? WINDOW IMAGE) (fetch (WINDOW SCREEN) of IMAGE)) (T LASTSCREEN] [COND ((OR (NULL IMAGE) (NOT (EQ (fetch (WINDOW SCREEN) of IMAGE) SCREEN))) (* Switched screens.  *) (UPDATE/MENU/IMAGE MENU SCREEN) (SETQ IMAGE (fetch (MENU IMAGE) of MENU] (COND (MAKEWINDOWFLG (COND ((type? WINDOW IMAGE) (UPDATEWFROMIMAGE IMAGE)) (T (SETQ IMAGE (CREATEWFROMIMAGE IMAGE SCREEN)) (replace (MENU IMAGE) of MENU with IMAGE))) (SETQ DSP (fetch (WINDOW DSP) of IMAGE)) (* set the offset in the display  stream to agree with the region.) (DSPXOFFSET (fetch (WINDOW WBORDER) of IMAGE) DSP) (DSPYOFFSET (fetch (WINDOW WBORDER) of IMAGE) DSP))) (RETURN (COND ((type? BITMAP IMAGE) IMAGE) (T (fetch (WINDOW SAVE) of IMAGE]) (PPROMPT2 [LAMBDA (ITEM) (* rrb "17-NOV-81 14:09") (* prints the second element of ITEM  in the prompt window.) (COND ((AND (LISTP ITEM) (CADR ITEM)) (PROMPTPRINT (CADR ITEM]) (UPDATE/MENU/IMAGE [LAMBDA (MNU SCREEN) (* ; "Edited 16-Jul-99 15:51 by rmk:") (* ;  "Edited 10-Dec-93 16:01 by sybalsky") (* ;  "recomputes the menu image from its labels.") (PROG (NUMCOLS NUMROWS WIDTH HEIGHT DSP BLK COLWIDTH ROWHEIGHT BITSPERPIXEL MENUITEMS NITEMS BORDER OUTLINE FONT TITLEFONT TITLEHEIGHT TITLEWIDTH WINDOW TITLE ANYSUBITEMS? CENTER?) [COND ((NULL SCREEN) (COND [(type? WINDOW (fetch (MENU IMAGE) of MNU)) (SETQ SCREEN (fetch (WINDOW SCREEN) of (fetch (MENU IMAGE) of MNU] (T (SETQ SCREEN LASTSCREEN] (SETQ MENUITEMS (fetch (MENU ITEMS) of MNU)) (SETQ CENTER? (fetch (MENU CENTERFLG) of MNU)) (* ; "check the font.") (COND [(FONTP (SETQ FONT (AND (fetch (MENU MENUFONT) of MNU) (\COERCEFONTDESC (fetch (MENU MENUFONT) of MNU) 'DISPLAY T] (T [SETQ FONT (COND ((FONTP MENUFONT)) (T (SETQ MENUFONT (FONTCREATE 'HELVETICA 10] (* ; "keep font in the menu") (replace (MENU MENUFONT) of MNU with FONT))) (COND ((SETQ TITLE (fetch (MENU TITLE) of MNU)) (* ; "set the title font") (SETQ TITLEFONT (MENUTITLEFONT MNU SCREEN)) (SETQ TITLEHEIGHT (FONTPROP TITLEFONT 'HEIGHT)) (SETQ TITLEWIDTH (STRINGWIDTH TITLE TITLEFONT))) (T (SETQ TITLEHEIGHT 0) (SETQ TITLEWIDTH 0))) (* ;  "calculate the number of columns and rows") (SETQ NITEMS (LENGTH MENUITEMS)) (COND [(SETQ NUMCOLS (NUMBERP (fetch (MENU MENUCOLUMNS) of MNU))) (SETQ NUMROWS (COND ((NUMBERP (fetch (MENU MENUROWS) of MNU))) (T (ADD1 (IQUOTIENT (SUB1 NITEMS) NUMCOLS] [(SETQ NUMROWS (NUMBERP (fetch (MENU MENUROWS) of MNU))) (SETQ NUMCOLS (ADD1 (IQUOTIENT (SUB1 NITEMS) NUMROWS] (T (SETQ NUMCOLS 1) (SETQ NUMROWS NITEMS))) (* ;; "set BORDER to the size of the outline around each menu item and OUTLINE to the size of the outline around the whole menu.") (SETQ BORDER (OR (FIXP (fetch (MENU MENUBORDERSIZE) of MNU)) (replace (MENU MENUBORDERSIZE) of MNU with 0))) [SETQ OUTLINE (OR (FIXP (fetch (MENU MENUOUTLINESIZE) of MNU)) (replace (MENU MENUOUTLINESIZE) of MNU with (IMAX BORDER 1] (SETQ ANYSUBITEMS? (for I in (fetch (MENU ITEMS) of MNU) when (\MENUSUBITEMS MNU I) do (RETURN T))) (COND ((IGREATERP (SETQ COLWIDTH (fetch (MENU ITEMWIDTH) of MNU)) 5000) (* ;; "If ITEMWIDTH is greater than 5000, it was probably default clipping region. if no columnwidth is given {common case}, calculate it from the items widths.") [SETQ COLWIDTH (IPLUS (MAXMENUITEMWIDTH MNU T) (ITIMES (ADD1 BORDER) 2) (COND (ANYSUBITEMS? (BITMAPWIDTH MENUSUBITEMMARK)) (T 0] [COND ((IGREATERP (IPLUS TITLEWIDTH 2) (ITIMES COLWIDTH NUMCOLS)) (* ;  "adjust column width to cover title.") (SETQ COLWIDTH (IQUOTIENT (IPLUS TITLEWIDTH (SUB1 NUMCOLS)) NUMCOLS] (replace (MENU ITEMWIDTH) of MNU with COLWIDTH))) (COND ((ILESSP (SETQ ROWHEIGHT (fetch (MENU ITEMHEIGHT) of MNU)) 5000) ROWHEIGHT) (T (SETQ ROWHEIGHT (IPLUS (MAXMENUITEMHEIGHT MNU) (ITIMES BORDER 2))) (replace (MENU ITEMHEIGHT) of MNU with ROWHEIGHT))) (SETQ WIDTH (IPLUS (ITIMES COLWIDTH NUMCOLS) (ITIMES OUTLINE 2))) (SETQ HEIGHT (IPLUS (ITIMES NUMROWS ROWHEIGHT) (ITIMES OUTLINE 2) TITLEHEIGHT)) [COND [(AND (IGREATERP HEIGHT (fetch (SCREEN SCHEIGHT) of SCREEN)) (NULL (fetch (MENU MENUCOLUMNS) of MNU)) (NULL (fetch (MENU MENUROWS) of MNU))) (* ;; "it is too large to fit on the screen and menu is defaulting the number of columns and rows If the user specified either the number of rows or columns, assume they knew what they were doing.") (PROG (NITEMSTOFIT) (* ;  "menu is defaulting the number of columns") (SETQ NITEMSTOFIT (IQUOTIENT (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) TITLEHEIGHT) ROWHEIGHT)) (SETQ NUMCOLS (ADD1 (IQUOTIENT (SUB1 NITEMS) NITEMSTOFIT))) (SETQ NUMROWS (ADD1 (IQUOTIENT (SUB1 NITEMS) NUMCOLS))) (SETQ WIDTH (IPLUS (ITIMES COLWIDTH NUMCOLS) (ITIMES OUTLINE 2))) (SETQ HEIGHT (IPLUS (ITIMES NUMROWS ROWHEIGHT) (ITIMES OUTLINE 2) TITLEHEIGHT)) (* ;; "changing the items field is suspect since conceivably the user might be depending upon it. At least the fact that MENUCOLUMNS is NIL keeps it from happening twice if it gets called again.") (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS (\MAKE.ITEMS.VERT.ORDER MENUITEMS NUMROWS NUMCOLS] ((AND (NULL (fetch (MENU MENUCOLUMNS) of MNU)) (fetch (MENU MENUROWS) of MNU)) (* ;; "user wants a certain number of rows but doesn't care about the columns, switch to vertical order so the blanks items appear in the last row.") (replace (MENU ITEMS) of MNU with (SETQ MENUITEMS (  \MAKE.ITEMS.VERT.ORDER MENUITEMS NUMROWS NUMCOLS] (replace (MENU MENUCOLUMNS) of MNU with NUMCOLS) (replace (MENU MENUROWS) of MNU with NUMROWS) (SETQ BITSPERPIXEL (OR (fetch (SCREEN SCDEPTH) of SCREEN) (fetch (SCREEN SCBITSPERPIXEL) of SCREEN))) [SETQ BLK (COND ((AND [SETQ BLK (COND ((type? BITMAP (SETQ BLK (fetch (MENU IMAGE) of MNU))) BLK) ((type? WINDOW BLK) (* ;  "if it is a window, make sure it is not active, then") (CLOSEW BLK) (fetch (WINDOW SAVE) of BLK] (EQ (fetch (BITMAP BITMAPWIDTH) of BLK) WIDTH) (EQ (fetch (BITMAP BITMAPHEIGHT) of BLK) HEIGHT) (EQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BLK) BITSPERPIXEL)) (* ; "reuse current image bitmap") BLK) (T (* ; "create a new one") (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL] (BITBLT NIL NIL NIL BLK 0 0 WIDTH HEIGHT 'TEXTURE 'REPLACE BLACKSHADE) (* ; "Draw box by nested BitBlts") (* ; "leave outline") (BITBLT NIL NIL NIL BLK OUTLINE OUTLINE (IDIFFERENCE WIDTH (ITIMES OUTLINE 2)) (IDIFFERENCE HEIGHT (IPLUS TITLEHEIGHT (ITIMES OUTLINE 2))) 'TEXTURE 'REPLACE WHITESHADE) (SETQ DSP (DSPCREATE BLK)) (DSPRIGHTMARGIN MAX.SMALLP DSP) (DSPXOFFSET OUTLINE DSP) (DSPYOFFSET OUTLINE DSP) (replace (REGION LEFT) of (fetch (MENU MENUGRID) of MNU) with 0) (replace (REGION BOTTOM) of (fetch (MENU MENUGRID) of MNU) with 0) (GRID (fetch (MENU MENUGRID) of MNU) NUMCOLS NUMROWS BORDER DSP) (DSPOPERATION 'INVERT DSP) (* ;  "calculate the offset from the top of the item box to the base line of the printed item.") [COND (TITLE (* ; "if there is a title, display it") (DSPFONT TITLEFONT DSP) (\SHOWMENULABEL TITLE (create REGION LEFT _ BORDER BOTTOM _ (IDIFFERENCE (IPLUS HEIGHT BORDER) (IPLUS TITLEHEIGHT (ITIMES OUTLINE 2))) WIDTH _ WIDTH HEIGHT _ TITLEHEIGHT) MNU DSP CENTER?) (SETQ HEIGHT (IDIFFERENCE HEIGHT TITLEHEIGHT] [PROG (ITEMREGION MAJOR#) [SETQ ITEMREGION (create REGION LEFT _ BORDER BOTTOM _ (IDIFFERENCE (IPLUS HEIGHT BORDER) (IPLUS ROWHEIGHT (ITIMES OUTLINE 2))) WIDTH _ (IDIFFERENCE (IDIFFERENCE (fetch (REGION WIDTH) of (fetch (MENU MENUGRID) of MNU)) (ITIMES BORDER 2)) (COND (ANYSUBITEMS? (* ;  "the subitem mark goes outside of the normal title space") (BITMAPWIDTH MENUSUBITEMMARK)) (T 0))) HEIGHT _ (IDIFFERENCE ROWHEIGHT (ITIMES BORDER 2] (SETQ MAJOR# 1) (DSPFONT FONT DSP) LP (COND (MENUITEMS (\SHOWMENULABEL (CAR MENUITEMS) ITEMREGION MNU DSP CENTER?) (SETQ MENUITEMS (CDR MENUITEMS)) [COND ((EQ MAJOR# NUMCOLS) (* ; "advance to the next row") (SETQ MAJOR# 1) (replace (REGION BOTTOM) of ITEMREGION with (IDIFFERENCE (fetch (REGION BOTTOM) of ITEMREGION) ROWHEIGHT)) (replace (REGION LEFT) of ITEMREGION with BORDER)) (T (SETQ MAJOR# (ADD1 MAJOR#)) (replace (REGION LEFT) of ITEMREGION with (IPLUS (fetch (REGION LEFT) of ITEMREGION) COLWIDTH] (GO LP] [COND ((NULL (fetch (MENU MENUOFFSET) of MNU)) (* ;; "set offset so cursor will be be in middle of the menu on first display if it is to move with the cursor. If it is fixed offset, initialize it to 0") (replace (MENU MENUOFFSET) of MNU with (COND ((fetch (MENU CHANGEOFFSETFLG) of MNU) (create POSITION XCOORD _ (IQUOTIENT WIDTH 2) YCOORD _ (IQUOTIENT HEIGHT 2))) (T (create POSITION XCOORD _ 0 YCOORD _ 0] [COND ((AND (type? WINDOW (SETQ WINDOW (fetch (MENU IMAGE) of MNU))) (EQ (fetch (WINDOW SCREEN) of WINDOW) SCREEN)) (* ;  "menu has a window, replace its save image.") (replace (WINDOW SAVE) of WINDOW with BLK)) (T (replace (MENU IMAGE) of MNU with (SETQ WINDOW (CREATEWFROMIMAGE BLK SCREEN] (* ;  "tell the window about its border") (replace (WINDOW WBORDER) of WINDOW with OUTLINE) (ADVISEWDS WINDOW) (* ;  "snap circular link between the display stream created for printing and its stream.") (RETURN (fetch (WINDOW SAVE) of (fetch (MENU IMAGE) of MNU]) (\MAKE.ITEMS.VERT.ORDER [LAMBDA (ITEMS %#ROWS %#COLUMNS) (* ; "Edited 9-Apr-94 00:42 by rmk:") (* rrb " 3-Feb-86 14:46") (* changes the order of a list of  elements to be by row.) (PROG ((ROWS (for I to %#ROWS collect (CONS))) (ITEM.POINTER ITEMS) (EMPTY.STRING "")) [for C to %#COLUMNS do (for R in ROWS do (TCONC R (COND [(LISTP ITEM.POINTER) (* still items left) (PROG1 (CAR ITEM.POINTER) (SETQ ITEM.POINTER (CDR ITEM.POINTER)))] (T (* use a dummy item) (LIST EMPTY.STRING '*DUMMYITEM*] (RETURN (for ROW in ROWS join (CAR ROW]) (\SHOWMENULABEL [LAMBDA (ITEM ITEMREGION MENU DSP CENTER?) (* edited%: "31-Dec-00 18:58") (* ;; "displays the item label for ITEM in the region ITEMREGION on the stream DSP according to the formatting information from MENU.") (DECLARE (GLOBALVARS MENUSUBITEMMARK)) (LET ((LABEL (\MENUITEMLABEL ITEM))) [COND ((\MENUSUBITEMS MENU ITEM) (* * ; "this item has subitems, put the mark in.") (BITBLT MENUSUBITEMMARK 0 0 DSP (IPLUS (fetch (REGION LEFT) of ITEMREGION) (fetch (REGION WIDTH) of ITEMREGION)) (IPLUS (fetch (REGION BOTTOM) of ITEMREGION) (FONTPROP (fetch (MENU MENUFONT) of MENU) 'DESCENT)) NIL NIL 'INPUT 'REPLACE NIL (CREATEREGION (fetch (REGION LEFT) of ITEMREGION ) (fetch (REGION BOTTOM) of ITEMREGION) (IPLUS (fetch (REGION WIDTH) of ITEMREGION ) (BITMAPWIDTH MENUSUBITEMMARK)) (fetch (REGION HEIGHT) of ITEMREGION] (COND [(BITMAPP LABEL) (* ;  "bitblt the label using the default operation of the displaystream.") (COND (CENTER? (BITBLT LABEL 0 0 DSP (IPLUS (fetch (REGION LEFT) of ITEMREGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION WIDTH) of ITEMREGION) (BITMAPWIDTH LABEL)) 2)) (IPLUS (fetch (REGION BOTTOM) of ITEMREGION) (IQUOTIENT (IDIFFERENCE (fetch (REGION HEIGHT) of ITEMREGION) (fetch (BITMAP BITMAPHEIGHT) of LABEL)) 2)) NIL NIL 'INPUT NIL NIL ITEMREGION)) (T (BITBLT LABEL 0 0 DSP (fetch (REGION LEFT) of ITEMREGION) (fetch (REGION BOTTOM) of ITEMREGION) (fetch (REGION WIDTH) of ITEMREGION) (fetch (REGION HEIGHT) of ITEMREGION) 'INPUT NIL NIL] (CENTER? (CENTERPRINTINREGION LABEL ITEMREGION DSP (MENU.PRIN2.FLG MENU))) (T (DSPXPOSITION (ADD1 (fetch (REGION LEFT) of ITEMREGION)) DSP) (DSPYPOSITION (IPLUS (fetch (REGION BOTTOM) of ITEMREGION) (FONTDESCENT (DSPFONT NIL DSP))) DSP) (CL:FUNCALL (if (MENU.PRIN2.FLG MENU) then (FUNCTION PRIN4) else (FUNCTION PRIN3)) LABEL DSP]) (\POSITION.MENU.IMAGE + [LAMBDA (MENU POSITION) (* ; "Edited 5-Jan-94 17:16 by nilsson") + + (* ;; "puts a menu image window in the right place on the screen. Subfunction to MENU") + + (PROG (SCREEN IMAGE MX MY) (* ; "make sure the image is a window") + (OR POSITION (SETQ POSITION (fetch (MENU MENUPOSITION) of MENU))) + (COND + ((type? SCREENPOSITION POSITION) + (SETQ SCREEN (fetch (SCREENPOSITION SCREEN) of POSITION)) + (SETQ MX (fetch (SCREENPOSITION XCOORD) of POSITION)) + (SETQ MY (fetch (SCREENPOSITION YCOORD) of POSITION))) + ((type? POSITION POSITION) + (SETQ MX (fetch (POSITION XCOORD) of POSITION)) + (SETQ MY (fetch (POSITION YCOORD) of POSITION)) + (GETMOUSESTATE) + (SETQ SCREEN LASTSCREEN)) + (T (GETMOUSESTATE) + (SETQ MX LASTMOUSEX) + (SETQ MY LASTMOUSEY) + (SETQ SCREEN LASTSCREEN))) (* ; "make sure the image is a window") + (CHECK/MENU/IMAGE MENU T SCREEN) + (SETQ IMAGE (fetch (MENU IMAGE) of MENU)) + [SETQ MX (IDIFFERENCE MX (fetch (POSITION XCOORD) of (fetch (MENU + MENUOFFSET) + of MENU] + [SETQ MY (IDIFFERENCE MY (fetch (POSITION YCOORD) of (fetch (MENU + MENUOFFSET) + of MENU] + (* ; + "Adjust the position so that the menu will be entirely on the screen.") + + (* ;; "do left margin first so that if the menu is wider than the screen, the left most part of it will be shown") + + (SETQ MX (IMAX (IMIN MX (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN) + (fetch (MENU IMAGEWIDTH) of MENU))) + 0)) + + (* ;; "do the bottom margin first so that the top of the menu will show if the menu is higher than the a screen") + + [SETQ MY (IMIN (IMAX MY 0) + (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) + (fetch (MENU IMAGEHEIGHT) of MENU] + (SETQ IMAGE (fetch (MENU IMAGE) of MENU)) + (MOVEW IMAGE MX MY) + (SHOWSHADEDITEMS MENU IMAGE) + (RETURN IMAGE]) (\SMASHMENUIMAGEONRESET [LAMBDA (MENU) (* rrb " 9-Jan-84 19:23") (* sets the menu image field to NIL if RESETSTATE indicates that a ^D was  typed.) (COND ((FMEMB RESETSTATE '(RESET HARDRESET)) (replace (MENU IMAGE) of MENU with NIL]) (CLOSE.PROCESS.MENU [LAMBDA (WINDOW) (* dgb%: "15-DEC-83 19:18") (WAKE.PROCESS (WINDOWPROP WINDOW 'MENUPROCESS) T]) (DEFAULTSUBITEMFN [LAMBDA (MENU ITEM) (* rrb "17-Aug-84 17:24") (* default subitemfn for menus.  Checks the fourth element of the  (item for an expression of the form  (SUBITEMS a b c))) (AND (LISTP ITEM) (LISTP (SETQ ITEM (CDR ITEM))) (LISTP (SETQ ITEM (CDR ITEM))) (LISTP (SETQ ITEM (CDR ITEM))) (EQ [CAR (SETQ ITEM (LISTP (CAR ITEM] 'SUBITEMS) (CDR ITEM]) (GETMENUPROP [LAMBDA (MENU PROPERTY) (* dgb%: "13-DEC-83 17:50") (LISTGET (fetch (MENU MENUUSERDATA) of MENU) PROPERTY]) (PUTMENUPROP [LAMBDA (MENU PROPERTY VALUE) (* dgb%: "13-DEC-83 17:52") (PROG ((NOWDATA (fetch (MENU MENUUSERDATA) of MENU))) [COND (NOWDATA (LISTPUT NOWDATA PROPERTY VALUE)) (T (replace (MENU MENUUSERDATA) of MENU with (LIST PROPERTY VALUE] (RETURN VALUE]) (WAKE.MY.PROCESS [LAMBDA (WINDOW) (* dgb%: "15-DEC-83 19:09") (WAKE.PROCESS (WINDOWPROP WINDOW 'MENUPROCESS) "ABC"]) (\INVERTITEM [LAMBDA (COLUMN ROW MENU DSP) (* dgb%: "13-DEC-83 18:06") (* inverts an item in a menu  displayed in DSP.) (SHADEGRIDBOX COLUMN ROW BLACKSHADE 'INVERT (fetch (MENU MENUGRID) of MENU) (fetch (MENU MENUBORDERSIZE) of MENU) DSP]) (\MENU.ITEM.SELECT [LAMBDA (COLUMN ROW MENU DSP) (* ; "Edited 9-Apr-94 09:14 by rmk:") (* rrb "21-May-85 13:57") (DECLARE (USEDFREE SUBMENU)) (* selects an item in a menu displayed in DSP.  Looks for submenus and brings those up as well.  Returns the image window of the submenu if it was brought up.) (PROG ((ITEM (GETMENUITEM MENU COLUMN ROW)) SUBITEMS) (CL:UNLESS [EQ '*DUMMYITEM* (CAR (LISTP (CDR (LISTP ITEM] (\INVERTITEM COLUMN ROW MENU DSP) [RETURN (AND ITEM (SETQ SUBITEMS (\MENUSUBITEMS MENU ITEM)) (COND [(EQ (CAR SUBITEMS) 'POPUP) (* if the first item is POPUP then  bring up the menu.) (SETQ SUBMENU (NESTED.SUBMENU MENU (CDR SUBITEMS))) (OPENW (\POSITION.MENU.IMAGE SUBMENU (NESTED.SUBMENU.POS MENU ITEM DSP] (T (* otherwise just create it but  don't bring it up.) (SETQ SUBMENU (NESTED.SUBMENU MENU SUBITEMS)) NIL])]) (\MENU.ITEM.DESELECT [LAMBDA (COLUMN ROW MENU DSP) (* ; "Edited 9-Apr-94 09:15 by rmk:") (* rrb "21-May-85 15:11") (DECLARE (USEDFREE SUBMENU SUBMENUWINDOW)) (* deselects an item in a menu displayed in DSP.  Also takes care of closing the submenu and resetting the variables that  indicate that there is a submenu.) (CL:UNLESS [EQ '*DUMMYITEM* (CAR (LISTP (CDR (LISTP (GETMENUITEM MENU COLUMN ROW] (\INVERTITEM COLUMN ROW MENU DSP) (AND SUBMENUWINDOW (CLOSEW SUBMENUWINDOW)) (SETQ SUBMENUWINDOW (SETQ SUBMENU NIL)))]) (\ItemNumber [LAMBDA (ITEM ALLITEMS) (* ;  "Edited 8-Jul-93 19:26 by sybalskY:MV:ENVOS") (* ;; "Walk thru the list of items in a menu, returning the relative item # of the menu item that matches ITEM. Failing that, return NIL.") (for SOMEITEM in ALLITEMS as ITEMNUM from 1 do (COND ([OR (EQ SOMEITEM ITEM) (EQ ITEM (CAR (LISTP SOMEITEM] (RETURN ITEMNUM))) finally (RETURN NIL]) (\BOXITEM [LAMBDA (COLUMN ROW MENU DSP) (* ; "Edited 9-Apr-94 09:39 by rmk:") (* rrb "28-Dec-83 17:34") (* inverts an item in a menu  displayed in DSP.) (CL:UNLESS [EQ '*DUMMYITEM* (CAR (LISTP (CDR (LISTP (GETMENUITEM MENU COLUMN ROW] (PROG ((BORDER (OR (FIXP (fetch (MENU MENUBORDERSIZE) of MENU)) 0)) (GRID (fetch (MENU MENUGRID) of MENU)) LFT BTM WID HGHT) (BITBLT NIL NIL NIL DSP (SETQ LFT (IPLUS (LEFTOFGRIDCOORD COLUMN GRID) BORDER)) (SETQ BTM (IPLUS (BOTTOMOFGRIDCOORD ROW GRID) BORDER)) (SETQ WID (IDIFFERENCE (fetch (REGION WIDTH) of GRID) (ITIMES BORDER 2))) (SETQ HGHT (IDIFFERENCE (fetch (REGION HEIGHT) of GRID) (ITIMES BORDER 2))) 'TEXTURE 'INVERT BLACKSHADE) (BITBLT NIL NIL NIL DSP (ADD1 LFT) (ADD1 BTM) (IDIFFERENCE WID 2) (IDIFFERENCE HGHT 2) 'TEXTURE 'INVERT BLACKSHADE)))]) (NESTED.SUBMENU [LAMBDA (MENU SUBITEMS) (* rrb "20-Jun-84 19:26") (* computes and returns the nested submenu for SUBITEMS.  It maintains a cache on the MENUUSERDATA) (PROG [SUBMENU (SUBMENULST (GETMENUPROP MENU 'SUBMENUS] [COND ([NULL (SETQ SUBMENU (CDR (FASSOC SUBITEMS SUBMENULST] (* Cache submenu on user data) (PUTMENUPROP MENU 'SUBMENUS (CONS [CONS SUBITEMS (SETQ SUBMENU (create MENU ITEMS _ SUBITEMS MENUOFFSET _ (create POSITION XCOORD _ 1 YCOORD _ 5) CHANGEOFFSETFLG _ 'Y CENTERFLG _ (fetch (MENU CENTERFLG) of MENU) MENUFONT _ (fetch (MENU MENUFONT) of MENU) MENUBORDERSIZE _ (fetch (MENU MENUBORDERSIZE) of MENU) MENUOUTLINESIZE _ (IMAX (fetch (MENU MENUOUTLINESIZE ) of MENU) 1) WHENHELDFN _ (fetch (MENU WHENHELDFN) of MENU) WHENUNHELDFN _ (fetch (MENU WHENUNHELDFN) of MENU) SUBITEMFN _ (fetch (MENU SUBITEMFN) of MENU] SUBMENULST] (RETURN SUBMENU]) (NESTED.SUBMENU.POS [LAMBDA (IMENU ITEM STREAM) (* rrb "28-Dec-83 19:24") (* return the position of a nested  submenu should have.) (PROG (ITEMNUMBER (ITEMS (fetch (MENU ITEMS) of IMENU)) (GRIDSPEC (fetch (MENU MENUGRID) of IMENU)) (BORDER (fetch (MENU MENUBORDERSIZE) of IMENU)) (DD (\GETDISPLAYDATA STREAM))) [SETQ ITEMNUMBER (IDIFFERENCE (LENGTH ITEMS) (LENGTH (OR (FMEMB ITEM ITEMS) (for ITEMTAIL on ITEMS when (EQ (CAAR ITEMTAIL) ITEM) do (RETURN ITEMTAIL)) (RETURN] (RETURN (create POSITION XCOORD _ (\DSPTRANSFORMX (IPLUS (fetch (REGION LEFT) of GRIDSPEC) (ITIMES (IREMAINDER ITEMNUMBER (fetch (MENU MENUCOLUMNS ) of IMENU)) (fetch (REGION WIDTH) of GRIDSPEC)) (IDIFFERENCE (fetch (REGION WIDTH) of GRIDSPEC) (ITIMES 2 BORDER))) DD) YCOORD _ (\DSPTRANSFORMY (IPLUS (ITIMES -2 BORDER) (fetch (REGION BOTTOM) of GRIDSPEC) (ITIMES [SUB1 (IDIFFERENCE (fetch (MENU MENUROWS) of IMENU) (IQUOTIENT ITEMNUMBER (fetch (MENU MENUCOLUMNS) of IMENU] (fetch (REGION HEIGHT) of GRIDSPEC))) DD]) (WFROMMENU [LAMBDA (MENU) (* kbr%: " 3-Apr-85 11:38") (* finds the window that menu is in  if any.) (for WINDOW in (OPENWINDOWS T) thereis (MEMB MENU (WINDOWPROP WINDOW 'MENU]) ) (RPAQQ MENUSUBITEMMARK #*(6 9)H@@@D@@@J@@@E@@@JH@@E@@@J@@@D@@@H@@@) (RPAQ? MENUFONT (FONTCREATE 'HELVETICA 10)) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS MENU.HELDSTATE.RESET MACRO ((BX BY) [COND (HELDSTATE (COND ((SETQ HELDSTATE (fetch (MENU WHENUNHELDFN) of MENU)) (APPLY* HELDSTATE (GETMENUITEM MENU BX BY) MENU (\FDECODE/BUTTON LASTBUTTONSTATE)) (SETQ HELDSTATE NIL] (SETQ HOLDTIMER (SETUPTIMER MENUHELDWAIT HOLDTIMER)))) (PUTPROPS MENU.PRIN2.FLG MACRO ((MNU) (LISTGET (fetch (MENU MENUUSERDATA) of MNU) :ESCAPE))) ) ) (* ; "scrolling menu functions and utilities") (DEFINEQ (MENUREPAINTFN [LAMBDA (WINDOW REG) (* hdj "11-Apr-85 12:11") (* repaints the menus in a window.) (PROG [(DSP (WINDOWPROP WINDOW 'DSP] (* stuff new images over old) (for MENU in (REVERSE (WINDOWPROP WINDOW 'MENU)) do (BLTMENUIMAGE MENU DSP]) ) (* ; "misc utility fns.") (DEFINEQ (MAXSTRINGWIDTH [LAMBDA (L FONT PRIN2FLG RDTBL) (* rrb " 9-JAN-82 13:49") (bind (M _ 0) for I in L do (SETQ M (IMAX M (STRINGWIDTH I FONT PRIN2FLG RDTBL))) finally (RETURN M]) (CENTEREDPRIN1 [LAMBDA (EXP DS LEFT WIDTH Y) (* rrb "17-DEC-82 15:53") (* prints an expression in the  middle of a width.) (MOVETO (IPLUS LEFT (IQUOTIENT (IDIFFERENCE WIDTH (STRINGWIDTH EXP DS)) 2)) Y DS) (PRIN3 EXP DS]) (CENTERPRINTINREGION [LAMBDA (EXP REGION STREAM PRIN2FLG) (* bvm%: "14-Oct-86 12:55") (* ;; "prints an expression in the middle of a region") (OR (type? REGION REGION) (SETQ REGION (DSPCLIPPINGREGION NIL STREAM))) (CENTERPRINTINAREA EXP (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) STREAM PRIN2FLG]) (CENTERPRINTINAREA [LAMBDA (EXP X Y WIDTH HEIGHT STREAM PRIN2FLG) (* bvm%: "14-Oct-86 12:54") (* ;;  "prints expression EXP in a box defined by remaining args. If PRIN2FLG is true uses PRIN2-pnames") (SETQ STREAM (\OUTSTREAMARG STREAM)) (PROG ((STRWIDTH (STRINGWIDTH EXP STREAM PRIN2FLG)) (PFN (if PRIN2FLG then (FUNCTION PRIN4) else (FUNCTION PRIN3))) XPOS) (MOVETO (SETQ XPOS (IPLUS X (IQUOTIENT (ADD1 (IDIFFERENCE WIDTH STRWIDTH)) 2))) (IPLUS Y (IQUOTIENT (IPLUS (IDIFFERENCE HEIGHT (FONTPROP STREAM 'ASCENT)) (FONTPROP STREAM 'DESCENT)) 2)) STREAM) (COND ((IGREATERP (IPLUS XPOS STRWIDTH) (DSPRIGHTMARGIN NIL STREAM)) (* ;; "if string would cause a CR to be inserted, change the right margin to avoid it. When PRIN3 is fixed so that it never inserts CR, this can be removed.") (RESETLST (RESETSAVE NIL (LIST 'DSPRIGHTMARGIN (DSPRIGHTMARGIN (IPLUS XPOS STRWIDTH) STREAM) STREAM)) (CL:FUNCALL PFN EXP STREAM))) (T (CL:FUNCALL PFN EXP STREAM]) (STRICTLY/BETWEEN [LAMBDA (VAL LOWER HIGHER) (* rrb "30-JUL-81 14:53") (* returns T if VAL is strictly  between LOWER and HIGHER) (AND (IGREATERP VAL LOWER) (IGREATERP HIGHER VAL]) ) (* ; "examples of use.") (DEFINEQ (UNREADITEM [LAMBDA (ITEM MENU BUTTON) (* rrb "31-JUL-81 17:37") (BKSYSBUF (CONCAT (MKSTRING (COND ((LISTP ITEM) (EVAL (CADR ITEM))) (T ITEM))) " "]) (TYPEINMENU [LAMBDA (LST) (* rrb "17-NOV-81 14:04") (create MENU ITEMS _ LST WHENSELECTEDFN _ (FUNCTION UNREADITEM]) (SHADEITEM [LAMBDA (ITEM MENU SHADE DS/W) (* lmm "16-Nov-86 01:01") (* ;  "shades a menu item with a background shade. DS/W if provided is the displaystream to use.") (PROG ((NEWSHADE (OR SHADE WHITESHADE)) DSP ITEMREGION) (SETQ ITEMREGION (MENUITEMREGION ITEM MENU)) (* ;  "if the item isn't in MENU don't do anything.") (OR ITEMREGION (RETURN)) (\AddShade ITEM NEWSHADE MENU) (* ;  "if the menu is not in a window mark it as shaded but don't try to display") (COND ([SETQ DSP (COND [(NULL DS/W) (COND ((SETQ DSP (WFROMMENU MENU)) (WINDOWPROP DSP 'DSP] ((DISPLAYSTREAMP (GETSTREAM DS/W 'OUTPUT] [COND ((for ITEM in (fetch (MENU ITEMS) of MENU) thereis (\MENUSUBITEMS MENU ITEM)) (replace (REGION WIDTH) of ITEMREGION with (DIFFERENCE (fetch (REGION WIDTH) of ITEMREGION) (BITMAPWIDTH MENUSUBITEMMARK] (RESHADEITEM ITEM ITEMREGION MENU NEWSHADE DSP]) (RESHADEITEM [LAMBDA (ITEM ITEMREGION MENU NEWSHADE DSP) (* edited%: "31-Dec-00 19:16") (RESETLST (if (FONTP NEWSHADE) then (DSPFILL ITEMREGION BLACKSHADE 'ERASE DSP) (RESETSAVE NIL (LIST 'DSPFONT (DSPFONT NEWSHADE DSP) DSP)) else (DSPFILL ITEMREGION NEWSHADE 'REPLACE DSP) (RESETSAVE NIL (LIST 'DSPOPERATION (DSPOPERATION (MOST/VISIBLE/OPERATION NEWSHADE ) DSP) DSP)) (RESETSAVE NIL (LIST 'DSPFONT (DSPFONT (fetch (MENU MENUFONT) of MENU) DSP) DSP))) (RESETSAVE NIL (LIST 'DSPRIGHTMARGIN (DSPRIGHTMARGIN 64000 DSP) DSP)) (\SHOWMENULABEL ITEM ITEMREGION MENU DSP (fetch (MENU CENTERFLG) of MENU)))]) (MOST/VISIBLE/OPERATION [LAMBDA (SHADE) (* chooses the operation that is most visible way of putting characters on a  SHADE background.) (COND ((IGREATERP (%#BITSON SHADE) 8) 'ERASE) (T 'PAINT]) (%#BITSON [LAMBDA (N) (* rrb "16-AUG-81 18:35") (* determines the number of bits  that are on.) (PROG ((MASK 1) (I 1) NBITS) (COND ((NOT (ZEROP (LOGAND N 1))) (SETQ NBITS 1)) (T (SETQ NBITS 0))) LP (COND ((EQ I BITSPERSHADE) (RETURN NBITS))) (SETQ MASK (LLSH MASK 1)) (SETQ I (ADD1 I)) [COND ((NOT (ZEROP (LOGAND N MASK))) (SETQ NBITS (ADD1 NBITS] (GO LP]) (BUTTONPANEL [LAMBDA (LABELLST) (* rrb "17-NOV-81 14:09") (* make items which have second  element that marks whether or not  they are selected.) (create MENU ITEMS _ (for LABEL in LABELLST collect (LIST LABEL "Release the button to select this item." NIL)) CENTERFLG _ T WHENSELECTEDFN _ (FUNCTION BUTTONPANEL/SELECTION/FN) WHENHELDFN _ (FUNCTION PPROMPT2]) (BUTTONPANEL/SELECTION/FN [LAMBDA (ITEM MENU BUTTON WINDOW) (* rrb "10-NOV-81 09:25") (* flips the selection and shades  the background.) (SHADEITEM ITEM MENU (COND ((CADDR ITEM) WHITESHADE) (T MENUSELECTSHADE)) WINDOW) (RPLACA (CDDR ITEM) (NOT (CADDR ITEM]) (GETSELECTEDITEMS [LAMBDA (WMENU) (* rrb "10-NOV-81 09:26") (for ITEM in (fetch ITEMS of WMENU) when (CADDR ITEM) collect (CAR ITEM]) ) (RPAQQ EDITCMDS ("P" "PP" ("LF" "% +") 0 1 -1 2 3 "BK" "EF" "EVAL")) (RPAQQ MENUHELDWAIT 1200) (DECLARE%: EVAL@COMPILE (RPAQQ BITSPERSHADE 16) (CONSTANTS (BITSPERSHADE 16)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MENUSELECTSHADE) ) (RPAQQ MENUSELECTSHADE 32800) (DEFINEQ (MENUDESELECT [LAMBDA (ITEM MENU) (* deselects a menu item) (SHADEITEM ITEM MENU WHITESHADE) (replace (MENU MENUUSERDATA) of MENU with NIL]) (MENUSELECT [LAMBDA (ITEM MENU) (* rrb "23-SEP-81 15:26") (* selects a menu item) (SHADEITEM ITEM MENU MENUSELECTSHADE) (replace (MENU MENUUSERDATA) of MENU with ITEM]) ) (DECLARE%: DOCOPY DONTEVAL@LOAD (RPAQQ MENUFONT NIL) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MENUFONT MENUHELDWAIT) ) (DECLARE%: EVAL@COMPILE (DATATYPE MENU (IMAGE SAVEIMAGE ITEMS MENUROWS MENUCOLUMNS MENUGRID CENTERFLG CHANGEOFFSETFLG MENUFONT TITLE MENUOFFSET WHENSELECTEDFN MENUBORDERSIZE MENUOUTLINESIZE WHENHELDFN MENUPOSITION WHENUNHELDFN MENUUSERDATA MENUTITLEFONT SUBITEMFN MENUFEEDBACKFLG SHADEDITEMS) MENUGRID _ (create REGION LEFT _ 0 BOTTOM _ 0) WHENHELDFN _ 'DEFAULTMENUHELDFN WHENUNHELDFN _ 'CLRPROMPT [ACCESSFNS ((ITEMWIDTH (fetch (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM)) (replace (REGION WIDTH) of (fetch (MENU MENUGRID) of DATUM) with NEWVALUE)) (ITEMHEIGHT (fetch (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM)) (replace (REGION HEIGHT) of (fetch (MENU MENUGRID) of DATUM) with NEWVALUE)) (IMAGEWIDTH (BITMAPWIDTH (CHECK/MENU/IMAGE DATUM))) (IMAGEHEIGHT (BITMAPHEIGHT (CHECK/MENU/IMAGE DATUM))) (MENUREGIONLEFT (IDIFFERENCE (fetch (REGION LEFT) of (fetch (MENU MENUGRID) of DATUM) ) (fetch (MENU MENUOUTLINESIZE) of DATUM))) (MENUREGIONBOTTOM (IDIFFERENCE (fetch (REGION BOTTOM) of (fetch (MENU MENUGRID) of DATUM)) (fetch (MENU MENUOUTLINESIZE) of DATUM]) ) (/DECLAREDATATYPE 'MENU '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((MENU 0 POINTER) (MENU 2 POINTER) (MENU 4 POINTER) (MENU 6 POINTER) (MENU 8 POINTER) (MENU 10 POINTER) (MENU 12 POINTER) (MENU 14 POINTER) (MENU 16 POINTER) (MENU 18 POINTER) (MENU 20 POINTER) (MENU 22 POINTER) (MENU 24 POINTER) (MENU 26 POINTER) (MENU 28 POINTER) (MENU 30 POINTER) (MENU 32 POINTER) (MENU 34 POINTER) (MENU 36 POINTER) (MENU 38 POINTER) (MENU 40 POINTER) (MENU 42 POINTER)) '44) (PUTPROPS MENU COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 1993 1994 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2642 87699 (MAXMENUITEMHEIGHT 2652 . 3589) (MAXMENUITEMWIDTH 3591 . 5290) (MENU 5292 . 8189) (MENUTITLEFONT 8191 . 9461) (ADDMENU 9463 . 14901) (DELETEMENU 14903 . 16384) (MENUREGION 16386 . 17246) (BLTMENUIMAGE 17248 . 19276) (ERASEMENUIMAGE 19278 . 20200) (DEFAULTMENUHELDFN 20202 . 20492 ) (DEFAULTWHENSELECTEDFN 20494 . 20905) (BACKGROUNDWHENSELECTEDFN 20907 . 21342) (GETMENUITEM 21344 . 21933) (MENUBUTTONFN 21935 . 22566) (MENU.HANDLER 22568 . 40670) (DOSELECTEDITEM 40672 . 41097) ( SHOWSHADEDITEMS 41099 . 42516) (\AddShade 42518 . 43710) (\DelShade 43712 . 43983) (\FDECODE/BUTTON 43985 . 44372) (MENUITEMREGION 44374 . 47109) (\MENUITEMLABEL 47111 . 47457) (\MENUSUBITEMS 47459 . 47697) (CHECK/MENU/IMAGE 47699 . 49705) (PPROMPT2 49707 . 50096) (UPDATE/MENU/IMAGE 50098 . 66458) ( \MAKE.ITEMS.VERT.ORDER 66460 . 67987) (\SHOWMENULABEL 67989 . 71916) (\POSITION.MENU.IMAGE 71918 . 74773) (\SMASHMENUIMAGEONRESET 74775 . 75123) (CLOSE.PROCESS.MENU 75125 . 75307) (DEFAULTSUBITEMFN 75309 . 76029) (GETMENUPROP 76031 . 76223) (PUTMENUPROP 76225 . 76598) (WAKE.MY.PROCESS 76600 . 76783) (\INVERTITEM 76785 . 77241) (\MENU.ITEM.SELECT 77243 . 78806) (\MENU.ITEM.DESELECT 78808 . 79510) ( \ItemNumber 79512 . 80079) (\BOXITEM 80081 . 81628) (NESTED.SUBMENU 81630 . 84348) (NESTED.SUBMENU.POS 84350 . 87321) (WFROMMENU 87323 . 87697)) (88489 88909 (MENUREPAINTFN 88499 . 88907)) (88944 91993 ( MAXSTRINGWIDTH 88954 . 89197) (CENTEREDPRIN1 89199 . 89636) (CENTERPRINTINREGION 89638 . 90167) ( CENTERPRINTINAREA 90169 . 91626) (STRICTLY/BETWEEN 91628 . 91991)) (92027 97969 (UNREADITEM 92037 . 92359) (TYPEINMENU 92361 . 92562) (SHADEITEM 92564 . 94308) (RESHADEITEM 94310 . 95403) ( MOST/VISIBLE/OPERATION 95405 . 95676) (%#BITSON 95678 . 96396) (BUTTONPANEL 96398 . 97190) ( BUTTONPANEL/SELECTION/FN 97192 . 97744) (GETSELECTEDITEMS 97746 . 97967)) (98289 98830 (MENUDESELECT 98299 . 98516) (MENUSELECT 98518 . 98828))))) STOP \ No newline at end of file diff --git a/sources/MISC b/sources/MISC new file mode 100644 index 00000000..0bd44122 --- /dev/null +++ b/sources/MISC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 20:40:30" {DSK}local>lde>lispcore>sources>MISC.;2 32490 changes to%: (VARS MISCCOMS) previous date%: " 8-Jan-88 13:03:33" {DSK}local>lde>lispcore>sources>MISC.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MISCCOMS) (RPAQQ MISCCOMS [(FNS ADD1VAR ADDTOVAR APPENDTOVAR APPEND \APPEND2 ASSOC ATTACH CHANGEPROP CONCATLIST COPY DEFINEQ DEFLIST DREMOVE DREVERSE DSUBST EQLENGTH EVERY GETLIS INTERSECTION KWOTE LAST LASTN LCONC LDIFF LDIFFERENCE LENGTH LISTGET LISTGET1 LISTPUT LISTPUT1 LSUBST MAP MAP2C MAP2CAR MAPC MAPCAR MAPCON MAPCONC MAPLIST MEMBER NLEFT NOTANY NOTEVERY NTH PUTASSOC RATOMS REMOVE REVERSE RPT RPTQ FRPTQ SASSOC SAVEDEF SAVEDEF1 SELECT SELECT1 SELECTC SETQQ SOME STRMEMB SUB1VAR SUBSET SUBST TAILP TCONC UNION) (COMS (* ; "ERRORSET stuff") (FNS ERSETQ NLSETQ XNLSETQ RESETLST RESETSAVE RESETFORM RESETVARS RESETVAR SI::RESETUNWIND) (FNS SI::NLSETQHANDLER) (INITVARS (SI::*NLSETQFLAG*) (RESETSTATE)) (PROP INFO RESETTOPVALS)) (COMS (FNS GENSYM GENSYM? \GS.INITBUF) (* ; "GENSYM garbage") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\GS.BUFSIZE 100))) (INITVARS (GENNUM 0) (\GS.OGENNUM -1) (\GS.NUMLEN 0) (\GS.BUF NIL) (\GS.STR (ALLOCSTRING 0))) (GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR)) (ALISTS (PRETTYEQUIVLST SELECTC) (DWIMEQUIVLST SELECTC)) (LOCALVARS . T) [P (CL:PROCLAIM '(GLOBAL MAKESYSDATE MAKESYSNAME] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA RESETVARS RESETFORM RESETSAVE RESETLST NLSETQ ERSETQ SELECTC SELECT FRPTQ RPTQ DEFINEQ APPENDTOVAR ADDTOVAR) (NLAML RESETVAR XNLSETQ SUB1VAR SETQQ ADD1VAR) (LAMA APPEND]) (DEFINEQ (ADD1VAR (NLAMBDA (ADD1X) (SET ADD1X (ADD1 (EVAL ADD1X))))) (ADDTOVAR (NLAMBDA X (* ; "Edited 8-Jan-88 12:50 by bvm") (LET* ((VAR (CAR X)) (VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP)) (GETPROP VAR (QUOTE VALUE))) (LISTP (EVALV VAR)))) TYPE) (if (AND (NEQ DFNFLG (QUOTE ALLPROP)) (SETQ TYPE (GETPROP VAR (QUOTE VARTYPE))) (SETQ TYPE (OR (LISTGET1 (LISTP TYPE) (QUOTE ALIST)) (EQ TYPE (QUOTE ALIST))))) then (* ;; "The variable appears to be an A-list. Treat it as such unless we see evidence to the contrary.") (for PAIR in (CDR X) BIND ADDED-NONLIST? do (if (NLISTP PAIR) then (* ;; "This is evidence to the contrary. We arrange for the variable itself to be marked as changed below.") (SETQ VAL (CONS PAIR VAL)) (SETQ ADDED-NONLIST? T) else (LET ((OLDENTRY (if (EQ TYPE (QUOTE USERMACROS)) then (find OP in VAL suchthat (AND (EQ (CAR OP) (CAR PAIR)) (EQ (NULL (CADR OP)) (NULL (CADR PAIR))))) else (FASSOC (CAR PAIR) VAL)))) (if (NOT (EQUAL OLDENTRY PAIR)) then (if (AND OLDENTRY (NEQ DFNFLG T)) then (EXEC-FORMAT "(new ~S entry for ~S)~%%" VAR (CAR PAIR))) (MARKASCHANGED (LIST VAR (CAR PAIR)) (QUOTE ALISTS) (NULL OLDENTRY)) (SETQ VAL (CONS PAIR (if OLDENTRY then (/DREMOVE OLDENTRY VAL) else VAL)))))) FINALLY (if ADDED-NONLIST? then (SAVESET VAR VAL NIL (QUOTE NOSTACKUNDO)) else (/SET VAR VAL))) else (* ;; "The variable doesn't appear to be an A-list.") (LET ((DFNFLG (if (EQ DFNFLG (QUOTE ALLPROP)) then (QUOTE PROP) else DFNFLG))) (DECLARE (SPECVARS DFNFLG)) (if (OR VAL (CDR X)) then (SAVESET VAR (UNION (CDR X) VAL) NIL (QUOTE NOSTACKUNDO)) elseif (EQ (EVALV VAR) (QUOTE NOBIND)) then (* ;; "The semantics of (ADDVARS (FOO)) are to initialize FOO to NIL if it is NOBIND, otherwise leave it alone.") (/SET VAR NIL)))) VAR)) ) (APPENDTOVAR (NLAMBDA X (* ; "Edited 9-Mar-87 15:48 by Pavel") (LET* ((VAR (CAR X)) (VAL (OR (AND (EQ DFNFLG (QUOTE ALLPROP)) (GETPROP VAR (QUOTE VALUE))) (LISTP (EVALV VAR)))) TYPE) (IF (AND (NEQ DFNFLG (QUOTE ALLPROP)) (SETQ TYPE (GETPROP VAR (QUOTE VARTYPE))) (SETQ TYPE (OR (LISTGET1 (LISTP TYPE) (QUOTE ALIST)) (EQ TYPE (QUOTE ALIST))))) THEN (* ;; "The variable appears to be an A-list. Treat it as such unless we see evidence to the contrary.") (LET ((ADDED-NONLIST? NIL)) (FOR PAIR IN (CDR X) DO (IF (NLISTP PAIR) THEN (* ;; "This is evidence to the contrary. We arrange for the variable itself to be marked as changed below.") (SETQ VAL (APPEND VAL (LIST PAIR))) (SETQ ADDED-NONLIST? T) ELSE (LET ((OLDENTRY (IF (EQ TYPE (QUOTE USERMACROS)) THEN (FIND OP IN VAL SUCHTHAT (AND (EQ (CAR OP) (CAR PAIR)) (EQ (NULL (CADR OP)) (NULL (CADR PAIR))))) ELSE (FASSOC (CAR PAIR) VAL)))) (IF (NOT (EQUAL OLDENTRY PAIR)) THEN (IF (AND OLDENTRY (NEQ DFNFLG T)) THEN (EXEC-FORMAT "(new ~S entry for ~S)~%%" VAR (CAR PAIR))) (MARKASCHANGED (LIST VAR (CAR PAIR)) (QUOTE ALISTS) (NULL OLDENTRY)) (SETQ VAL (APPEND (IF OLDENTRY THEN (/DREMOVE OLDENTRY VAL) ELSE VAL) (LIST PAIR))))))) (IF ADDED-NONLIST? THEN (SAVESET VAR VAL NIL (QUOTE NOPRINT)) ELSE (/SET VAR VAL))) ELSE (* ;; "The variable doesn't appear to be an A-list.") (LET ((DFNFLG (IF (EQ DFNFLG (QUOTE ALLPROP)) THEN (QUOTE PROP) ELSE DFNFLG))) (DECLARE (SPECVARS DFNFLG)) (IF (OR VAL (CDR X)) THEN (SAVESET VAR (APPEND VAL (LDIFFERENCE (CDR X) VAL)) NIL (QUOTE NOPRINT)) ELSEIF (EQ (EVALV VAR) (QUOTE NOBIND)) THEN (* ;; "The semantics of (ADDVARS (FOO)) are to initialize FOO to NIL if it is NOBIND, otherwise leave it alone.") (/SET VAR NIL)))) VAR)) ) (APPEND (LAMBDA L (* lmm "30-Jun-84 00:37") (* ; "fixed bug so that (APPEND (QUOTE (A B . C))) was (QUOTE (A B . C))") (COND ((EQ L 0) NIL) ((EQ L 1) (\APPEND2 (ARG L 1) NIL)) (T (bind (VAL _ (ARG L L)) (N _ L) while (IGREATERP (add N -1) 0) do (SETQ VAL (\APPEND2 (ARG L N) VAL)) finally (RETURN VAL))))) ) (\APPEND2 (LAMBDA (L1 L2) (* lmm "30-Jun-84 00:30") (COND ((LISTP L1) (PROG ((VAL (CONS (CAR L1) L2)) TAIL) (SETQ TAIL VAL) LP (FRPLACD TAIL (SETQ TAIL (LIST (CAR (OR (LISTP (SETQ L1 (CDR L1))) (PROGN (FRPLACD TAIL (OR L2 L1)) (RETURN VAL))))))) (GO LP))) ((NLISTP L2) L1) (T L2))) ) (ASSOC (LAMBDA (KEY ALST) (* bvm%: "20-FEB-81 14:58") (PROG NIL LP (COND ((NLISTP ALST) (RETURN)) ((AND (LISTP (CAR ALST)) (EQ (CAAR ALST) KEY)) (RETURN (CAR ALST)))) (SETQ ALST (CDR ALST)) (GO LP))) ) (ATTACH (LAMBDA (X L) (COND ((LISTP L) (FRPLACA (FRPLACD L (CONS (CAR L) (CDR L))) X)) ((NULL L) (CONS X)) (T (ERRORX (LIST 4 L))))) ) (CHANGEPROP (LAMBDA (X PROP1 PROP2) (* wt%: "31-MAY-79 22:28") (PROG ((Z (COND ((LITATOM X) (GETPROPLIST X)) (T (ERRORX (LIST 14 X)))))) LP (RETURN (COND ((NLISTP Z) NIL) ((EQ (CAR Z) PROP1) (FRPLACA Z PROP2) X) (T (SETQ Z (CDR (LISTP (CDR Z)))) (GO LP)))))) ) (CONCATLIST (LAMBDA (L) (* ; "Edited 24-Nov-86 17:37 by jop:") (PROG (STR FATP) (* ; "Try to pre-determine FATP, at least for strings and litatoms, where it is easy to tell.") (SETQ STR (ALLOCSTRING (for X in L sum (OR FATP (COND ((STRINGP X) (SETQ FATP (ffetch (STRINGP FATSTRINGP) of X))) ((LITATOM X) (SETQ FATP (ffetch (LITATOM FATPNAMEP) of X))))) (NCHARS X)) NIL NIL FATP)) (for X in L as I from 1 by (NCHARS X) do (RPLSTRING STR I X)) (RETURN STR))) ) (COPY (LAMBDA (X) (* lmm "16-FEB-82 22:07") (COND ((NLISTP X) X) (T (PROG (TAIL (VAL (LIST (COPY (CAR X))))) (SETQ TAIL VAL) LP (COND ((NLISTP (SETQ X (CDR X))) (AND X (FRPLACD TAIL X)) (RETURN VAL))) (FRPLACD TAIL (SETQ TAIL (CONS (COPY (CAR X))))) (GO LP))))) ) (DEFINEQ (NLAMBDA X (DEFINE X))) (DEFLIST (LAMBDA (L PROP) (PROG NIL LP (COND ((NLISTP L) (RETURN))) (PUTPROP (CAAR L) PROP (CADAR L)) (* ; "NOTE: this call to PUTPROP is changed to /PUTPROP later in the loadup.") (SETQ L (CDR L)) (GO LP))) ) (DREMOVE (LAMBDA (X L) (COND ((NLISTP L) NIL) ((EQ X (CAR L)) (COND ((CDR L) (FRPLACA L (CADR L)) (FRPLACD L (CDDR L)) (DREMOVE X L)))) (T (PROG (Z) (DECLARE (LOCALVARS Z)) (SETQ Z L) LP (COND ((NLISTP (CDR L)) (RETURN Z)) ((EQ X (CADR L)) (FRPLACD L (CDDR L))) (T (SETQ L (CDR L)))) (GO LP))))) ) (DREVERSE (LAMBDA (L) (PROG (Y Z) (DECLARE (LOCALVARS Y Z)) R1 (COND ((NLISTP (SETQ Y L)) (RETURN Z))) (SETQ L (CDR L)) (SETQ Z (FRPLACD Y Z)) (GO R1))) ) (DSUBST (LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:10") (PROG (B) (COND ((EQ OLD (SETQ B EXPR)) (RETURN (COPY NEW)))) LP (COND ((NLISTP EXPR) (RETURN B)) ((EQUAL OLD (CAR EXPR)) (FRPLACA EXPR (COPY NEW))) (T (DSUBST NEW OLD (CAR EXPR)))) (COND ((AND OLD (EQ OLD (CDR EXPR))) (FRPLACD EXPR (COPY NEW)) (RETURN B))) (SETQ EXPR (CDR EXPR)) (GO LP))) ) (EQLENGTH (LAMBDA (X N) (* bvm%: "14-Feb-85 00:34") (* ;; "Generated by paatern match. INcluded so user can load code that has been dwimified and or compiled into a nonclisp system and run it.") (COND ((ILESSP N 0) NIL) ((EQ N 0) (NLISTP X)) (T (AND (LISTP (SETQ X (NTH X N))) (NLISTP (CDR X)))))) ) (EVERY (LAMBDA (EVERYX EVERYFN1 EVERYFN2) (* ;; "Note that EVERY does not compile open, although SOME does.") (PROG NIL CL:LOOP (COND ((NLISTP EVERYX) (RETURN T)) ((NULL (APPLY* EVERYFN1 (CAR EVERYX) EVERYX)) (RETURN NIL))) (SETQ EVERYX (COND (EVERYFN2 (APPLY* EVERYFN2 EVERYX)) (T (CDR EVERYX)))) (GO CL:LOOP))) ) (GETLIS (LAMBDA (X PROPS) (* wt%: "31-MAY-79 22:25") (PROG ((Z (COND ((LITATOM X) (GETPROPLIST X)) (T X)))) LP (RETURN (COND ((NLISTP Z) NIL) ((FMEMB (CAR Z) PROPS) Z) (T (SETQ Z (CDR (LISTP (CDR Z)))) (GO LP)))))) ) (INTERSECTION (LAMBDA (X Y) (PROG ((R (CONS)) S) (DECLARE (LOCALVARS R S)) LP (COND ((NLISTP X) (RETURN (CAR R))) ((COND ((LITATOM (SETQ S (CAR X))) (AND (FMEMB S Y) (NULL (FMEMB S (CAR R))))) (T (AND (MEMBER S Y) (NULL (MEMBER S (CAR R)))))) (TCONC R S))) (SETQ X (CDR X)) (GO LP))) ) (KWOTE (LAMBDA (X) (* dcl%: 15 SEP 75 15%:25) (COND ((OR (NULL X) (EQ X T) (NUMBERP X)) X) (T (LIST (QUOTE QUOTE) X)))) ) (LAST (LAMBDA (X) (PROG (XX) (DECLARE (LOCALVARS XX)) L (COND ((NLISTP X) (RETURN XX))) (SETQ XX X) (SETQ X (CDR X)) (GO L))) ) (LASTN (LAMBDA (L N) (PROG (X Y) (DECLARE (LOCALVARS X Y)) (COND ((NLISTP L) (RETURN NIL)) ((NULL (SETQ X (FNTH L N))) (RETURN))) LP (COND ((NULL (SETQ X (CDR X))) (RETURN (CONS Y L)))) (SETQ Y (NCONC1 Y (CAR L))) (SETQ L (CDR L)) (GO LP))) ) (LCONC (LAMBDA (PTR X) (PROG (XX) (DECLARE (LOCALVARS XX)) (RETURN (COND ((NULL X) PTR) ((OR (NLISTP X) (CDR (SETQ XX (LAST X)))) (SETQ XX X) (GO ERROR)) ((NULL PTR) (CONS X XX)) ((NLISTP PTR) (SETQ XX PTR) (GO ERROR)) ((NULL (CAR PTR)) (FRPLACA (FRPLACD PTR XX) X)) (T (FRPLACD (CDR PTR) X) (FRPLACD PTR XX)))) ERROR (ERROR (QUOTE "bad argument - LCONC") XX))) ) (LDIFF (LAMBDA (X Y Z) (COND ((EQ X Y) Z) ((AND (NULL Y) (NULL Z)) X) (T (PROG (V) (COND (Z (SETQ V (CDR (FRPLACD (SETQ V (FLAST Z)) (FRPLACD (CONS (CAR X) V)))))) (T (SETQ V (SETQ Z (CONS (CAR X)))))) CL:LOOP (SETQ X (CDR X)) (COND ((EQ X Y) (RETURN Z)) ((NULL X) (RETURN (ERROR (QUOTE "LDIFF: not a tail") Y)))) (SETQ V (CDR (FRPLACD V (FRPLACD (CONS (CAR X) V))))) (GO CL:LOOP))))) ) (LDIFFERENCE (LAMBDA (X Y) (* lmm "27-Mar-84 16:26") (for Z in X when (NOT (MEMBER Z Y)) collect Z))) (LENGTH (LAMBDA (X) (PROG ((N 0)) (DECLARE (LOCALVARS N)) LP (COND ((NLISTP X) (RETURN N)) (T (SETN N (ADD1 N)) (SETQ X (CDR X)) (GO LP))))) ) (LISTGET (LAMBDA (LST PROP) (* ; "Edited 3-Sep-87 12:18 by bvm:") (* ;; "like GETPROP but works on lists, searching them two cdrs at a time.") (PROG NIL LP (COND ((NLISTP LST) (RETURN)) ((EQ (CAR LST) PROP) (RETURN (CADR LST)))) (SETQ LST (CDR (LISTP (CDR LST)))) (GO LP))) ) (LISTGET1 (LAMBDA (LST PROP) (* ;; "Used to be called GET. Like LISTGET but only searches one cdr at a time.") (PROG NIL LP (COND ((NLISTP LST) (RETURN)) ((EQ (CAR LST) PROP) (RETURN (CADR LST)))) (SETQ LST (CDR LST)) (GO LP))) ) (LISTPUT (LAMBDA (LST PROP VAL) (* ;; "Like PUT but works on lists. Inverse of LISTGET") (PROG ((X (OR (LISTP LST) (ERRORX (LIST 4 LST)))) X0) CL:LOOP (COND ((NLISTP (CDR X)) (* ; "Odd parity; either (A B C) or (A B C . D) --- drop thru and add at beginning")) ((EQ (CAR X) PROP) (* ; "found it") (FRPLACA (CDR X) VAL) (RETURN VAL)) ((LISTP (SETQ X (CDDR (SETQ X0 X)))) (GO CL:LOOP)) ((NULL X) (* ;; "Ran out without finding PROP on even parity. add at end If X is not NIL, means ended in a non-list following even parity, e.g. (A B . C) so drop through and add at front.") (FRPLACD (CDR X0) (LIST PROP VAL)) (RETURN VAL))) ADDFRONT (FRPLNODE LST PROP (CONS VAL (CONS (CAR LST) (CDR LST)))) (RETURN VAL))) ) (LISTPUT1 (LAMBDA (LST PROP VAL) (* lmm "22-Oct-85 16:44") (* ;; "Used to be called PUTL. Like LISTPUT but only searches one cdr at a time. Inverse of LISTGET1") (PROG ((X LST)) LP (COND ((NLISTP X) (* ; "Note no checks for lists ending in dotted pairs.") (RETURN (NCONC LST (LIST PROP VAL)))) ((EQ (CAR X) PROP) (COND ((CDR X) (FRPLACA (CDR X) VAL)) (T (FRPLACD X (LIST VAL)))) (RETURN LST))) (SETQ X (CDR X)) (GO LP))) ) (LSUBST (LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11") (* ;; "Substitutes X as a segment for Y in Z. E.g. LSUBST ((A B) Y (X Y Z)) is (X A B Z) not meaningful for Y an atom and CDR of a list. if X is NIL, operation effectively deletes Y, i.e. produces a copy without Y in it.") (COND ((NULL EXPR) NIL) ((NLISTP EXPR) (COND ((EQ OLD EXPR) NEW) (T EXPR))) ((EQUAL OLD (CAR EXPR)) (NCONC (COPY NEW) (LSUBST NEW OLD (CDR EXPR)))) (T (CONS (LSUBST NEW OLD (CAR EXPR)) (LSUBST NEW OLD (CDR EXPR)))))) ) (MAP (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG NIL LP (COND ((NLISTP MAPX) (RETURN))) (APPLY* MAPFN1 MAPX) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MAP2C (LAMBDA (MAPX MAPY MAPFN1 MAPFN2) (PROG NIL LP (COND ((OR (NLISTP MAPX) (NLISTP MAPY)) (RETURN))) (APPLY* MAPFN1 (CAR MAPX) (CAR MAPY)) (COND (MAPFN2 (SETQ MAPX (APPLY* MAPFN2 MAPX)) (SETQ MAPY (APPLY* MAPFN2 MAPY))) (T (SETQ MAPX (CDR MAPX)) (SETQ MAPY (CDR MAPY)))) (GO LP))) ) (MAP2CAR (LAMBDA (MAPX MAPY MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((OR (NLISTP MAPX) (NLISTP MAPY)) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX) (CAR MAPY)) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (COND (MAPFN2 (SETQ MAPY (APPLY* MAPFN2 MAPY)) (SETQ MAPX (APPLY* MAPFN2 MAPX))) (T (SETQ MAPY (CDR MAPY)) (SETQ MAPX (CDR MAPX)))) (GO LP))) ) (MAPC (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG NIL LP (COND ((NLISTP MAPX) (RETURN))) (APPLY* MAPFN1 (CAR MAPX)) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MAPCAR (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 (CAR MAPX)) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MAPCON (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((LISTP (SETQ MAPY (APPLY* MAPFN1 MAPX))) (COND (MAPE (FRPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MAPCONC (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((LISTP (SETQ MAPY (APPLY* MAPFN1 (CAR MAPX)))) (COND (MAPE (FRPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MAPLIST (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL))) (SETQ MAPE (CONS (APPLY* MAPFN1 MAPX) MAPE)) (COND (CL:MAPL (FRPLACD (CDR MAPE) (FRPLACD MAPE))) (T (SETQ CL:MAPL MAPE))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (MEMBER (LAMBDA (X Y) (PROG NIL LP (RETURN (COND ((NLISTP Y) NIL) ((COND ((LITATOM X) (EQ X (CAR Y))) (T (EQUAL X (CAR Y)))) Y) (T (SETQ Y (CDR Y)) (GO LP)))))) ) (NLEFT (LAMBDA (L N TAIL) (* bvm%: "14-Feb-85 00:35") (* ;; "Returns TAIL of L containing N elements more than TAIL, e.g. if TAIL is NIL (the usual case) NLEFT ((A B C D E) 2) is (D E). If FOO is (A B C D E) and FIE is (CDDDR FOO), (NLEFT FOO 1 FIE) is (C D E).") (PROG ((X L) (Y L)) LP (COND ((EQ N 0) (GO LP1)) ((OR (EQ X TAIL) (NLISTP X)) (RETURN NIL))) (SETQ X (CDR X)) (SUB1VAR N) (GO LP) LP1 (COND ((OR (EQ X TAIL) (NLISTP X)) (RETURN Y))) (SETQ X (CDR X)) (SETQ Y (CDR Y)) (GO LP1))) ) (NOTANY (LAMBDA (SOMEX SOMEFN1 SOMEFN2) (NULL (SOME SOMEX SOMEFN1 SOMEFN2)))) (NOTEVERY (LAMBDA (EVERYX EVERYFN1 EVERYFN2) (NULL (EVERY EVERYX EVERYFN1 EVERYFN2)))) (NTH (LAMBDA (X N) (COND ((IGREATERP 1 N) (CONS NIL X)) (T (PROG NIL LP (COND ((NOT (IGREATERP N 1)) (RETURN X)) ((NLISTP X) (RETURN NIL))) (SETQ X (CDR X)) (SETQ N (SUB1 N)) (GO LP))))) ) (PUTASSOC (LAMBDA (KEY VAL ALST) (* lmm%: 5 SEP 75 119) (PROG ((X (OR (LISTP ALST) (ERRORX (LIST 4 ALST))))) (DECLARE (LOCALVARS X)) LP (COND ((EQ (CAR (OR (LISTP (CAR X)) (GO NEXT))) KEY) (FRPLACD (CAR X) VAL) (RETURN VAL))) NEXT (SETQ X (OR (LISTP (CDR X)) (PROGN (FRPLACD X (LIST (CONS KEY VAL))) (RETURN VAL)))) (GO LP))) ) (RATOMS (LAMBDA (A FILE RDTBL) (PROG (L X) B (COND ((EQ (SETQ X (RATOM FILE RDTBL)) A) (RETURN (CAR L))) ((SETQ L (TCONC L X)) (GO B))))) ) (REMOVE (LAMBDA (X L) (COND ((NLISTP L) NIL) ((EQUAL X (CAR L)) (REMOVE X (CDR L))) (T (CONS (CAR L) (REMOVE X (CDR L)))))) ) (REVERSE (LAMBDA (L) (PROG (U) (DECLARE (LOCALVARS U)) CL:LOOP (COND ((NLISTP L) (RETURN U))) (SETQ U (CONS (CAR L) U)) (SETQ L (CDR L)) (GO CL:LOOP))) ) (RPT (LAMBDA (RPTN RPTF) (DECLARE (SPECVARS RPTN) (LOCALVARS RPTF)) (* ; "Edited 6-Apr-87 13:57 by Pavel") (PROG (RPTV) (DECLARE (LOCALVARS RPTV)) LP (COND ((IGREATERP RPTN 0) (SETQ RPTV (EVAL RPTF (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO LP)) (T (RETURN RPTV))))) ) (RPTQ (NLAMBDA RPTZ (PROG ((RPTN (EVAL (CAR RPTZ) (QUOTE INTERNAL))) RPTV) (DECLARE (SPECVARS RPTN)) RPTQLOOP (COND ((IGREATERP RPTN 0) (SETQ RPTV (APPLY (FUNCTION PROGN) (CDR RPTZ) (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO RPTQLOOP))) (RETURN RPTV))) ) (FRPTQ (NLAMBDA RPTZ (DECLARE (LOCALVARS . T)) (PROG ((RPTN (EVAL (CAR RPTZ) (QUOTE INTERNAL))) RPTV) RPTQLOOP (COND ((IGREATERP RPTN 0) (SETQ RPTV (APPLY (FUNCTION PROGN) (CDR RPTZ) (QUOTE INTERNAL))) (SETQ RPTN (SUB1 RPTN)) (GO RPTQLOOP))) (RETURN RPTV))) ) (SASSOC (LAMBDA (KEY ALST) (PROG NIL LP (COND ((NLISTP ALST) (RETURN NIL)) ((EQUAL (CAAR ALST) KEY) (RETURN (CAR ALST)))) (SETQ ALST (CDR ALST)) (GO LP))) ) (SAVEDEF (LAMBDA (X) (COND ((ATOM X) (SAVEDEF1 X)) (T (MAPCAR X (FUNCTION SAVEDEF1)))))) (SAVEDEF1 (LAMBDA (X) (PROG ((DF (GETD X))) (RETURN (COND (DF (PUTPROP X (SETQ X (SELECTQ (FNTYP X) ((SUBR SUBR* FSUBR FSUBR*) (QUOTE SUBR)) ((EXPR EXPR* FEXPR FEXPR*) (QUOTE EXPR)) ((CEXPR CEXPR* CFEXPR CFEXPR*) (QUOTE CODE)) (COND ((EXPRP X) (QUOTE EXPR)) (T (QUOTE LIST))))) DF) (* ; "NOTE: this call to PUTPROP is changed to /PUTPROP later in the loadup.") X))))) ) (SELECT (NLAMBDA .SELEC. (DECLARE (LOCALVARS . T)) (* dcl%: 12 Dec 78 09%:08) (APPLY (QUOTE PROGN) (SELECT1 (EVAL (CAR .SELEC.) (QUOTE SELECTQ)) (CDR .SELEC.)) (QUOTE SELECTQ))) ) (SELECT1 (LAMBDA (M L) (DECLARE (LOCALVARS . T)) (* edited%: 8 Dec 78 13%:53) (PROG (C A) LP (SETQ C L) (COND ((NULL (SETQ L (CDR L))) (RETURN C)) ((NLISTP (CAR (SETQ C (CAR C)))) (AND (EQ M (EVAL (CAR C) (QUOTE INTERNAL))) (RETURN (CDR C))) (GO LP))) (SETQ A (CAR C)) L2 (COND ((EQ M (EVAL (CAR A) (QUOTE INTERNAL))) (RETURN (CDR C))) ((LISTP (SETQ A (CDR A))) (GO L2)) (T (GO LP))))) ) (SELECTC (NLAMBDA SELCQ (* lmm "28-FEB-82 16:07") (DECLARE (LOCALVARS . T)) (APPLY (QUOTE PROGN) ((LAMBDA (M L) (PROG (C TL) LP (SETQ C L) (COND ((NULL (SETQ L (CDR L))) (RETURN C)) ((OR (EQ (SETQ TL (EVAL (CAR (SETQ C (CAR C))) (QUOTE INTERNAL))) M) (AND (LISTP TL) (FMEMB M TL))) (RETURN (CDR C)))) (GO LP))) (EVAL (CAR SELCQ) (QUOTE SELECTQ)) (CDR SELCQ)) (QUOTE SELECTQ))) ) (SETQQ (NLAMBDA (X Y) (SET X Y))) (SOME (LAMBDA (SOMEX SOMEFN1 SOMEFN2) (* ; "SOME compiles open.") (PROG NIL CL:LOOP (COND ((NLISTP SOMEX) (RETURN NIL)) ((APPLY* SOMEFN1 (CAR SOMEX) SOMEX) (RETURN SOMEX))) (SETQ SOMEX (COND (SOMEFN2 (APPLY* SOMEFN2 SOMEX)) (T (CDR SOMEX)))) (GO CL:LOOP))) ) (STRMEMB (LAMBDA (X Y) (* rmk%: " 6-JUN-82 15:08") (PROG (C N) (DECLARE (LOCALVARS C N)) (SETQ Y (SUBSTRING Y 1)) B (SETQ N 1) A (COND ((NULL (SETQ C (NTHCHARCODE X N))) (RETURN Y))) (COND ((EQ C (NTHCHARCODE Y N)) (SETQ N (ADD1 N)) (GO A))) (COND ((NULL (GNC Y)) (RETURN)) (T (GO B))))) ) (SUB1VAR (NLAMBDA (SUB1X) (SET SUB1X (SUB1 (EVAL SUB1X))))) (SUBSET (LAMBDA (MAPX MAPFN1 MAPFN2) (DECLARE (LOCALVARS . T)) (PROG (RESULT TAIL) LP (COND ((NLISTP MAPX) (RETURN RESULT)) ((APPLY* MAPFN1 (CAR MAPX)) (COND ((NULL RESULT) (SETQ RESULT (SETQ TAIL (CONS (CAR MAPX))))) (T (SETQ TAIL (CDR (FRPLACD TAIL (FRPLACD (CONS (CAR MAPX) TAIL))))) (* ; "Eseentially an open TCONC."))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (SUBST (LAMBDA (NEW OLD EXPR) (* lmm "16-FEB-82 22:11") (COND ((NULL EXPR) NIL) ((NLISTP EXPR) (COND ((EQ OLD EXPR) (COPY NEW)) (T EXPR))) (T (CONS (COND ((EQUAL OLD (CAR EXPR)) (COPY NEW)) (T (SUBST NEW OLD (CAR EXPR)))) (SUBST NEW OLD (CDR EXPR)))))) ) (TAILP (LAMBDA (X Y) (* ;; "True if X is A tail of Y X and Y non-null.") (* ; "Included with editor for block compilation purposes.") (AND X (PROG NIL LP (COND ((NLISTP Y) (RETURN NIL)) ((EQ X Y) (RETURN X))) (SETQ Y (CDR Y)) (GO LP)))) ) (TCONC (LAMBDA (PTR X) (PROG (XX) (DECLARE (LOCALVARS XX)) (RETURN (COND ((NULL PTR) (CONS (SETQ XX (CONS X NIL)) XX)) ((NLISTP PTR) (ERROR (QUOTE "bad argument - TCONC") PTR)) ((NULL (CDR PTR)) (FRPLACA PTR (CONS X NIL)) (FRPLACD PTR (CAR PTR))) (T (FRPLACD PTR (CDR (FRPLACD (CDR PTR) (FRPLACD (CONS X (CDR PTR))))))))))) ) (UNION (LAMBDA (X Y) (DECLARE (LOCALVARS . T)) (* bvm%: "30-Jun-86 16:59") (* ;;; "Defined explicitly to be Y prepended with any elements of X not in Y") (for ELT in X bind HEAD TAIL unless (COND ((LITATOM ELT) (* ; "Optimize MEMBER for a common case") (FMEMB ELT Y)) (T (MEMBER ELT Y))) do (COND (TAIL (RPLACD TAIL (SETQ TAIL (CONS ELT NIL)))) (T (SETQ HEAD (SETQ TAIL (CONS ELT NIL))))) finally (RETURN (COND (TAIL (RPLACD TAIL Y) HEAD) (T Y))))) ) ) (* ; "ERRORSET stuff") (DEFINEQ (ERSETQ (NLAMBDA ERSETX (* bvm%: "14-Oct-86 11:42") (ERRORSET (CONS (QUOTE PROGN) ERSETX) T))) (NLSETQ (NLAMBDA NLSETX (* bvm%: "14-Oct-86 11:41") (ERRORSET (CONS (QUOTE PROGN) NLSETX) NIL))) (XNLSETQ (NLAMBDA (XNLSETQX XNLSETFLG XNLSETFN) (ERRORSET XNLSETQX XNLSETFLG XNLSETFN))) (RESETLST (NLAMBDA RESETX (* bvm%: "11-Nov-86 22:26") (* ;; "RESETLST and RESETSAVE together permit the user to combine the effects of several RESETVAR's and RESETFORM's under one function. RESETLST acts like an ERRORSET which takes an indefinite number of forms, i.e. like PROGN, and errorset protects them, and restores all RESETSAVE's performed while inside of RESETLST. RESETLST compiles open.") (RESETLST (\EVPROGN RESETX))) ) (RESETSAVE (NLAMBDA RESETX (* wt%: "23-JUL-79 21:08") (DECLARE (LOCALVARS . T)) (* ;; "for use under a RESETLST.") (SETQ SI::*RESETFORMS* (CONS (COND ((AND (CAR RESETX) (LITATOM (CAR RESETX))) (* ;; "This is the (RESETSAVE var value) form") (PROG1 (CONS (CAR RESETX) (GETTOPVAL (CAR RESETX))) (SETTOPVAL (CAR RESETX) (\EVAL (CADR RESETX))))) ((CDR RESETX) (* ;; "This is the (RESETSAVE savingform restore-form). CADR of the entry we save is the value of the saving form. The variable OLDVALUE is bound to this value during restoration. This makes it more convenient for the restoration to be conditional, e.g. the user can perform (RESETSAVE (FOO mumble) '(AND pred (FIE OLDVALUE)))") (LIST (\EVAL (CADR RESETX)) (\EVAL (CAR RESETX)))) (T (* ;; "This is the (RESETSAVE (fn arg)) form, a special case of the above. Save (fn oldval) as the restoration expression.") (LET ((FORM (CAR RESETX))) (LIST (LIST (COND ((EQ (CAR FORM) (QUOTE SETQ)) (* ;; "Silly special case: in (RESETSAVE (SETQ var (fn arg))) ignore the SETQ for restoration purposes.") (CAR (CADDR FORM))) (T (CAR FORM))) (\EVAL FORM)))))) SI::*RESETFORMS*))) ) (RESETFORM (NLAMBDA RESETZ (* ; "Edited 3-Sep-87 12:15 by bvm:") (* ;; "Similar to RESETVAR. Permits evaluation of a form while resetting a system state, and provides for the system to be returned to that state after evaluation. RESETX is a form, e.g. (OUTPUT T), (PRINTLEVEL 2) etc. RESETX is evaluated and its value saved. Then RESETY is evaluated under errorset protection and then (CAR RESETX) is applied to the result of the evaluation of X. If an error occurs during the evaluation of FORM, the effect of RESETX is still 'undone'") (LET ((SI::*RESETFORMS* (LIST (LIST (LIST (CAAR RESETZ) (\EVAL (CAR RESETZ))))))) (DECLARE (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (\EVPROGN (CDR RESETZ)) (SI::RESETUNWIND)))) ) (RESETVARS (NLAMBDA RESETX (* ; "Edited 25-Nov-86 23:16 by bvm:") (LET ((SI::*RESETFORMS* (PROGN (* ; "Initialize *RESETFORMS* to list of vars and old values") (for V in (CAR RESETX) collect (if (LISTP V) then (SETQ V (CAR V))) (CONS V (GETTOPVAL V)))))) (DECLARE (LOCALVARS . T) (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (PROGN (* ; "Set the variables to new values, execute prog body") (for V in (CAR RESETX) do (if (LISTP V) then (SETTOPVAL (CAR V) (\EVPROG1 (CDR V))) else (* ; "initial value NIL") (SETTOPVAL V NIL))) (APPLY (QUOTE PROG) (CONS NIL (CDR RESETX)) (QUOTE INTERNAL))) (SI::RESETUNWIND)))) ) (RESETVAR (NLAMBDA (RESETX RESETY RESETZ) (* ; "Edited 19-Mar-87 16:06 by jrb:") (* ;; "Permits evaluation of a form while resetting a top level variable, and provides for the variable to be automatcally restored after valuation. In this way, the user pays when he wants to 'rebind' a globalvariable, but does not have to pay for the possiblity, as would be the case if variables such as DFNFLG, LISPXHISTORY, etc. were not global, i.e. were looked up. In the event of a control-D, or control-C reenter, the variabes will still be restored by EVALQT. Note that STKEVALs will not do the right t on variables reset by RESETVAR.") (LET ((SI::*RESETFORMS* (LIST (CONS RESETX (GETTOPVAL RESETX))))) (DECLARE (SPECVARS SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (PROGN (SETTOPVAL RESETX (\EVAL RESETY)) (\EVAL RESETZ)) (SI::RESETUNWIND)))) ) (SI::RESETUNWIND (LAMBDA (NORMALP) (* bvm%: " 4-Nov-86 16:53") (while (LISTP SI::*RESETFORMS*) bind OLDVALUE RESETZ do (SETQ RESETZ (pop SI::*RESETFORMS*)) (if (LISTP (CAR RESETZ)) then (* ; "RESETSAVE and RESETFORM do this") (SETQ OLDVALUE (if (CDR RESETZ) then (* ;; "occurs for RESETSAVE's when second argument is specified. In this case, (CADR RESETZ) is the value of the saving form, i.e. the first argument to RESETSAVE.") (CADR RESETZ) else (CADAR RESETZ))) (APPLY (CAAR RESETZ) (CDAR RESETZ)) else (* ; "RESETSAVE of a symbol sets its value") (SETTOPVAL (CAR RESETZ) (CDR RESETZ))))) ) ) (DEFINEQ (SI::NLSETQHANDLER (LAMBDA (C) (* bvm%: "16-Sep-86 19:19") (if (AND SI::*NLSETQFLAG* NLSETQGAG) then (ABORT C)))) ) (RPAQ? SI::*NLSETQFLAG* ) (RPAQ? RESETSTATE ) (PUTPROPS RESETTOPVALS INFO (EVAL BINDS)) (DEFINEQ (GENSYM (LAMBDA (PREFIX NUMSUFFIX OSTRBUFFER NEW? CHARCODE) (* bvm%: "25-Aug-86 16:03") (* ;;; "Create a unique SYMBOL with the given prefix.") (OR (NULL PREFIX) (STRINGP PREFIX) (LITATOM PREFIX) (CL:STRINGP PREFIX) (\ILLEGAL.ARG PREFIX)) (* ; "The prefix has to be something string-like") (OR (NULL NUMSUFFIX) (FIXP NUMSUFFIX) (\ILLEGAL.ARG NUMSUFFIX)) (* ; "Any number-suffix better be numeric") (OR (NULL OSTRBUFFER) (STRINGP OSTRBUFFER) (\ILLEGAL.ARG OSTRBUFFER)) (* ; "Any buffer you supply better be an Interlisp string") (OR (NULL CHARCODE) (CHARCODEP CHARCODE) (\ILLEGAL.ARG CHARCODE)) (* ; "Any charcode better really be one") (PROG ((BUFSIZE \GS.BUFSIZE) (NUMLEN \GS.NUMLEN) (BUF (OR (STRINGP \GS.BUF) (SETQ \GS.BUF (ALLOCSTRING \GS.BUFSIZE)))) (PREFIXLEN 0) BEG.I ATOM) (COND ((OR (NULL PREFIX) (EQ (SETQ PREFIXLEN (NCHARS PREFIX)) 0)) (SETQ PREFIX) (COND ((NULL CHARCODE) (* ; "Here's the default case") (SETQ CHARCODE (CHARCODE A))))) ((IGREATERP PREFIXLEN (IDIFFERENCE BUFSIZE 10)) (ERROR PREFIX "Too long"))) (COND ((COND (OSTRBUFFER (COND ((NULL NUMSUFFIX) (HELP "OSTRBUFFER supplied without NUMSUFFIX")) ((ILESSP (SETQ BUFSIZE (NCHARS OSTRBUFFER)) (IPLUS 12 PREFIXLEN)) (ERROR OSTRBUFFER "Too short"))) T) (NUMSUFFIX (* ; "Insulate the normal \GS.BUF from random intrusions") (SETQ OSTRBUFFER (ALLOCSTRING (SETQ BUFSIZE (IPLUS PREFIXLEN 12)))) T)) (SETQ BUF OSTRBUFFER))) A (UNINTERRUPTABLY (COND ((COND (OSTRBUFFER (* ; "Use the user-supplied buffer, or a freshly cons'd one if he supplied NUMSUFFIX without OSTRBUFFER") T) ((NOT (FIXP GENNUM)) (* ; "Disaster recovery") (SETQ GENNUM 0) T)) (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE (OR NUMSUFFIX GENNUM)))) (T (* ;; "In this case, we have kept account of the contents of \GS.BUF so we don't have to call \GS.INITBUF afresh, but rather merely 'patch up' the effect of adding 1 to GENNUM") (COND ((COND ((NOT (IEQP GENNUM \GS.OGENNUM)) (* ; "User perhaps has reset GENNUM") (COND ((ILESSP GENNUM 0) (SETQ GENNUM 0))) T) ((IGEQ GENNUM MAX.FIXP) (* ; "Sigh, two's complement wrap-around") (SETQ GENNUM 0) T)) (SETQ NUMLEN (\GS.INITBUF BUF BUFSIZE GENNUM)))) (* ; "Increment the GENNUM counter and the string buffer buffer.") (COND ((for CNT C to NUMLEN as I from BUFSIZE by -1 do (* ; "Simulates a BCD type add in the gensym string") (SETQ C (NTHCHARCODE \GS.BUF I)) (COND ((ILEQ (add C 1) (CHARCODE 9)) (* ; "ha, carry stops here") (RPLCHARCODE BUF I C) (RETURN)) (T (RPLCHARCODE BUF I (CHARCODE 0)))) finally (RETURN T)) (* ; "Sigh, we have to extend the numerical part") (RPLCHARCODE BUF (IDIFFERENCE BUFSIZE NUMLEN) (CHARCODE 1)) (SETQ NUMLEN (add \GS.NUMLEN 1)))) (SETQ \GS.OGENNUM (add GENNUM 1)))) (* ; "BEG.I will be the beginning index, in the buffer, for the atom") (SETQ BEG.I (ADD1 (IDIFFERENCE BUFSIZE NUMLEN))) (COND (CHARCODE (RPLCHARCODE BUF (add BEG.I -1) CHARCODE))) (COND (PREFIX (RPLSTRING BUF (SETQ BEG.I (IDIFFERENCE BEG.I PREFIXLEN)) PREFIX))) (SETQ \GS.STR (SUBSTRING BUF BEG.I BUFSIZE \GS.STR)) (SETQ ATOM (MKATOM \GS.STR))) (COND ((NUMBERP ATOM) (\ILLEGAL.ARG PREFIX))) (RETURN ATOM))) ) (GENSYM? (LAMBDA (X) (* lmm " 1-JUN-81 08:30") (AND (LITATOM X) (EQ (NTHCHARCODE X -5) (CHARCODE A)) (FIXP (NTHCHAR X -4)) (FIXP (NTHCHAR X -3)) (FIXP (NTHCHAR X -2)) (FIXP (NTHCHAR X -1)) T)) ) (\GS.INITBUF (LAMBDA (BUF BUFSIZE N) (* lmm "14-Apr-85 20:36") (* ;; "Initializes BUF (which must be a stringp of length BUFSIZE) with the digits of N right-justified and left-0 padded up to a minimum of 4 digits. Returns the decimal length of N") (PROG (NUMLEN) (RPLSTRING BUF (IDIFFERENCE BUFSIZE (if (ILESSP N 10000) then (* ; "Trick to get leading zeros") (SETQ N (IPLUS N 10000)) (SETQ NUMLEN 4) else (SUB1 (SETQ NUMLEN (NCHARS N))))) N) (AND (EQ BUF \GS.BUF) (SETQ \GS.NUMLEN NUMLEN)) (RETURN NUMLEN))) ) ) (* ; "GENSYM garbage") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \GS.BUFSIZE 100) (CONSTANTS (\GS.BUFSIZE 100)) ) ) (RPAQ? GENNUM 0) (RPAQ? \GS.OGENNUM -1) (RPAQ? \GS.NUMLEN 0) (RPAQ? \GS.BUF NIL) (RPAQ? \GS.STR (ALLOCSTRING 0)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GENNUM \GS.OGENNUM \GS.NUMLEN \GS.BUF \GS.STR) ) (ADDTOVAR PRETTYEQUIVLST (SELECTC . SELECTQ)) (ADDTOVAR DWIMEQUIVLST (SELECTC . SELECTQ)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (CL:PROCLAIM '(GLOBAL MAKESYSDATE MAKESYSNAME)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA RESETVARS RESETFORM RESETSAVE RESETLST NLSETQ ERSETQ SELECTC SELECT FRPTQ RPTQ DEFINEQ APPENDTOVAR ADDTOVAR) (ADDTOVAR NLAML RESETVAR XNLSETQ SUB1VAR SETQQ ADD1VAR) (ADDTOVAR LAMA APPEND) ) (PUTPROPS MISC COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2393 22722 (ADD1VAR 2403 . 2466) (ADDTOVAR 2468 . 4147) (APPENDTOVAR 4149 . 5863) ( APPEND 5865 . 6176) (\APPEND2 6178 . 6465) (ASSOC 6467 . 6672) (ATTACH 6674 . 6812) (CHANGEPROP 6814 . 7078) (CONCATLIST 7080 . 7542) (COPY 7544 . 7811) (DEFINEQ 7813 . 7849) (DEFLIST 7851 . 8064) ( DREMOVE 8066 . 8367) (DREVERSE 8369 . 8527) (DSUBST 8529 . 8882) (EQLENGTH 8884 . 9188) (EVERY 9190 . 9508) (GETLIS 9510 . 9730) (INTERSECTION 9732 . 10021) (KWOTE 10023 . 10148) (LAST 10150 . 10281) ( LASTN 10283 . 10529) (LCONC 10531 . 10898) (LDIFF 10900 . 11290) (LDIFFERENCE 11292 . 11397) (LENGTH 11399 . 11545) (LISTGET 11547 . 11827) (LISTGET1 11829 . 12063) (LISTPUT 12065 . 12779) (LISTPUT1 12781 . 13209) (LSUBST 13211 . 13715) (MAP 13717 . 13896) (MAP2C 13898 . 14188) (MAP2CAR 14190 . 14602 ) (MAPC 14604 . 14790) (MAPCAR 14792 . 15100) (MAPCON 15102 . 15471) (MAPCONC 15473 . 15849) (MAPLIST 15851 . 16154) (MEMBER 16156 . 16322) (NLEFT 16324 . 16821) (NOTANY 16823 . 16904) (NOTEVERY 16906 . 16996) (NTH 16998 . 17190) (PUTASSOC 17192 . 17523) (RATOMS 17525 . 17668) (REMOVE 17670 . 17799) ( REVERSE 17801 . 17958) (RPT 17960 . 18237) (RPTQ 18239 . 18501) (FRPTQ 18503 . 18766) (SASSOC 18768 . 18928) (SAVEDEF 18930 . 19022) (SAVEDEF1 19024 . 19397) (SELECT 19399 . 19582) (SELECT1 19584 . 19975) (SELECTC 19977 . 20359) (SETQQ 20361 . 20398) (SOME 20400 . 20662) (STRMEMB 20664 . 20957) (SUB1VAR 20959 . 21022) (SUBSET 21024 . 21429) (SUBST 21431 . 21689) (TAILP 21691 . 21933) (TCONC 21935 . 22264 ) (UNION 22266 . 22720)) (22754 27422 (ERSETQ 22764 . 22862) (NLSETQ 22864 . 22964) (XNLSETQ 22966 . 23058) (RESETLST 23060 . 23497) (RESETSAVE 23499 . 24627) (RESETFORM 24629 . 25361) (RESETVARS 25363 . 25981) (RESETVAR 25983 . 26820) (SI::RESETUNWIND 26822 . 27420)) (27423 27552 (SI::NLSETQHANDLER 27433 . 27550)) (27660 31467 (GENSYM 27670 . 30748) (GENSYM? 30750 . 30948) (\GS.INITBUF 30950 . 31465 ))))) STOP \ No newline at end of file diff --git a/sources/MOD44IO b/sources/MOD44IO new file mode 100644 index 00000000..c89b0672 --- /dev/null +++ b/sources/MOD44IO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "21-Jan-91 23:56:42" |{PELE:MV:ENVOS}SOURCES>MOD44IO.;4| 143621 changes to%: (VARS MOD44IOCOMS) (FNS \M44AddDiskPages \M44CompleteFH \M44CREATEFILE \M44DeleteFile \M44EVENTFN \M44ExtendFilePageMap \M44FillInMap \M44GetFileHandle \M44GetFileInfo \M44GetFileName \M44GetPageLoc \M44KillFilePageMap \M44MAKEDIRENTRY \M44OpenFile \M44OPENFILEFROMFP \M44ReadDiskPage \M44ReadLeaderPage \M44SetAccessTimes \M44SetEndOfFile \M44SetFileInfo \M44SETFILETYPE \M44TruncateFile \M44WriteDiskPage \M44WriteLeaderPage \M44WritePages \M44WritePages1 \ADDDISKPAGES \M44DELETEPAGES \ASSIGNDISKPAGE \M44FLUSHDISKDESCRIPTOR \MAKELEADERDAS \M44GENERATENEXT \M44NEXTFILEFN \M44SORTEDNEXTFILEFN \M44FILEINFOFN \M44PARSEFILENAME \FINDDIRHOLE \OPENDISKDESCRIPTOR \M44READDIRFID \M44SEARCHDIR \M44UNPACKFILENAME \CREATE.FID.FOR.DD \OPENDISK \OPENDISKDEVICE GATHERSTATS) previous date%: "16-May-90 20:44:00" |{PELE:MV:ENVOS}SOURCES>MOD44IO.;3|) (* ; " Copyright (c) 1981, 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MOD44IOCOMS) (RPAQQ MOD44IOCOMS ( (* ;;; "Dorado disk driver") (COMS (* ;; "Device dependent code for the Model44 disk") (FNS \M44AddDiskPages \M44CloseFile \M44CompleteFH \M44CREATEFILE \M44DeleteFile \M44EVENTFN \M44ExtendFilePageMap \M44FillInMap \M44GetFileHandle \M44GetFileInfo \M44GETDATEPROP \M44GetFileName \M44GetPageLoc \M44KillFilePageMap \M44MAKEDIRENTRY \M44OpenFile \M44OPENFILEFROMFP \M44ReadDiskPage \M44ReadLeaderPage \M44ReadPages \M44SetAccessTimes \M44SetEndOfFile \M44SetFileInfo \M44SETFILETYPE \M44TruncateFile \M44WriteDiskPage \M44WriteLeaderPage \M44WritePages \M44WritePages1)) (COMS (* ;; "Disk allocation") (FNS \ADDDISKPAGES \M44DELETEPAGES \ASSIGNDISKPAGE \COUNTDISKFREEPAGES \M44MARKPAGEFREE \M44FLUSHDISKDESCRIPTOR \MAKELEADERDAS DISKFREEPAGES \M44FREEPAGECOUNT VMEMSIZE)) (COMS (INITVARS (\M44MULTFLG T)) (DECLARE%: DONTCOPY (MACROS UCASECHAR UPDATEVALIDATION) (RECORDS M44DEVICE) (GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY) (MACROS .LISP.TO.BFS. .BFS.TO.LISP. .DISKCASEARRAY.) (CONSTANTS (PageMapIncrement 64) (\MAX.ALTO.NAME.LENGTH 39)) (COMS (* ;; "File properties") (RECORDS M44FILEPROP) (CONSTANTS * FPROPTYPES) (CONSTANTS * FPTYPES)) (GLOBALRESOURCES \M44PAGEBUFFER)) (INITRESOURCES \M44PAGEBUFFER)) (COMS (* ;; "Directory enumeration") (FNS \M44GENERATEFILES \M44SORTFILES \M44GENERATENEXT \M44NEXTFILEFN \M44SORTEDNEXTFILEFN \M44FILEINFOFN)) (COMS (* ;; "Directory lookup routines") (FNS \M44PARSEFILENAME \FINDDIRHOLE \M44PACKFILENAME \M44READVERSION \OPENDISKDESCRIPTOR \M44READDIRFID \M44READDIRNAME \M44SEARCHDIR \M44UNPACKFILENAME) (VARS \FILENAMECHARSLST) (GLOBALVARS \FILENAMECHARSLST) (DECLARE%: DONTCOPY (RECORDS UNAME FILESPEC M44GENFILESTATE M44DIRSEARCHSTATE) (MACROS BETWEEN))) (COMS (FNS \CREATE.FID.FOR.DD \OPENDISK \OPENDISKDEVICE \OPENDIR \M44CHECKPASSWORD \M44HOSTNAMEP) (DECLARE%: DONTCOPY (CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD \NWORDS.BCPLPASSWORD))) [COMS (* ;; "SYSOUT etc.") (FNS \COPYSYS \COPYSYS1) (* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.") (FNS \MAIKO.CHECKFREESPACE) (INITVARS (\LDEDESTOVERWRITE NIL)) (DECLARE%: DONTCOPY (CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2] (COMS (* ;; "Stats code. On MOD44IO because it writes on the disk and uses records not exported from MOD44IO. (For this and other reasons, GATHERSTATS only works on Dorados.)") (FNS GATHERSTATS) (VARS (\STATSON NIL))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (LOADCOMP) LLBFS)))) (* ;;; "Dorado disk driver") (* ;; "Device dependent code for the Model44 disk") (DEFINEQ (\M44AddDiskPages [LAMBDA (STREAM NEWLASTPAGE NEWLASTBYTE) (* ; "Edited 21-Jan-91 23:35 by jds") (* ;; "Add pages to an existing Model44 file. NEWLASTPAGE is the page number of the last page in the extended file. Return the disk address of the new last page.") (\M44FillInMap STREAM (fetch (M44STREAM LastPage) of STREAM)) (* ;  "Fill in map to end of file. Code below assumes at least one valid map entry") (\ADDDISKPAGES STREAM (ADD1 (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)) (IDIFFERENCE NEWLASTPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)) (fetch (ARRAYP BASE) of (\M44ExtendFilePageMap STREAM NEWLASTPAGE)) NEWLASTBYTE) (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with NEWLASTPAGE) (replace (M44STREAM LastPage) of STREAM with NEWLASTPAGE) (replace (M44STREAM LastOffset) of STREAM with NEWLASTBYTE) (* ;  "record new eof in filehandle only") NEWLASTPAGE]) (\M44CloseFile (LAMBDA (STREAM) (* hdj "25-Sep-86 11:03") (\CLEARMAP STREAM) (COND ((NEQ (fetch ACCESS of STREAM) (QUOTE INPUT)) (* ; "Update EOF in leader page") (\M44TruncateFile STREAM (fetch EPAGE of STREAM) (fetch EOFFSET of STREAM) T) (\M44FLUSHDISKDESCRIPTOR (fetch DEVICE of STREAM)))) STREAM) ) (\M44CompleteFH [LAMBDA (STREAM) (* ; "Edited 21-Jan-91 23:41 by jds") (* ;; "Completes the fields of a file handle that describes an existing file by reading in its leader page which it leaves for its caller") (PROG ((NUMCHARS (CONS)) (LEADERPAGE (\M44ReadLeaderPage STREAM)) (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))) LASTPAGE# NBYTES) (* ;; "Get the page number and the number of bytes on the last page of the file specified by fHandle. If the last page number hint is wrong in the leader page, then find the real last page and change the hint.") (COND ((AND (NEQ (SETQ LASTPAGE# (.BFS.TO.LISP. (fetch (\M44LeaderPage LastPageNumber) of LEADERPAGE))) -1) (EQ [PROG ((DAs (ARRAY 3 'WORD \FILLINDA 0)) (BFSPG# (.LISP.TO.BFS. LASTPAGE#))) (SETA DAs 1 (fetch (\M44LeaderPage LastPageAddress) of LEADERPAGE )) (SETA DAs 2 \EOFDA) (RETURN (AND (EQ (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs) LASTPAGE# STREAM BFSPG# BFSPG# \DC.READD NUMCHARS NIL T) BFSPG#) (SETQ NBYTES (CAR NUMCHARS] (fetch (\M44LeaderPage LastPageByteCount) of LEADERPAGE))) (replace (M44STREAM LastPage) of STREAM with LASTPAGE#) (* ; "Update STREAM eof") (replace (M44STREAM LastOffset) of STREAM with NBYTES)) (T (* ;  "Hint was wrong so scan the file for last page") (for PN from PageMapIncrement by PageMapIncrement do (SETQ LASTPAGE# (\M44FillInMap STREAM PN)) (* ;  "Wait until attempt to find page fails") repeatwhile (EQ PN LASTPAGE#)) (SETQ NBYTES (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM (.LISP.TO.BFS. LASTPAGE#) (.LISP.TO.BFS. LASTPAGE#) \DC.READD NUMCHARS)) (* ;  "Read last page to find out how many bytes are on it") (\M44SetEndOfFile STREAM LASTPAGE# (CAR NUMCHARS) T))) (UPDATEVALIDATION STREAM LEADERPAGE) (* ;  "Validation is low order bits of creation and write dates") [COND ((EQ (fetch (M44STREAM LastOffset) of STREAM) BYTESPERPAGE) (* ;; "Shouldn't happen, because alto files should never have a full last page. However, cope if it happens...") (replace EPAGE of STREAM with (ADD1 (fetch (M44STREAM LastPage) of STREAM))) (replace EOFFSET of STREAM with 0)) (T (replace EPAGE of STREAM with (fetch (M44STREAM LastPage) of STREAM)) (replace EOFFSET of STREAM with (fetch (M44STREAM LastOffset) of STREAM] (RETURN STREAM]) (\M44CREATEFILE [LAMBDA (FDEV UNAME LENGTH CRDATE TYPE DIRECTORYP) (* ; "Edited 21-Jan-91 23:41 by jds") (* ;; "Create a file on the Model44 disk.") (PROG ((DSK (fetch (M44DEVICE DSKOBJ) of FDEV)) (PNAME (\M44PACKFILENAME UNAME)) (LEADERPAGE (create \M44LeaderPage)) (NC 0) STREAM FP MAP FPBASE DAT PSTART) (OR PNAME (RETURN)) (* ;  "Cant create as name wasnt complete") (SETQ STREAM (create M44STREAM)) (replace FULLFILENAME of STREAM with PNAME) (replace DEVICE of STREAM with FDEV) (replace (M44STREAM FID) of STREAM with (SETQ FP (create FID))) (replace (M44STREAM FILEPAGEMAP) of STREAM with (SETQ MAP (ARRAY (COND ((FIXP LENGTH) (IPLUS 4 (FOLDHI LENGTH BYTESPERPAGE))) (T PageMapIncrement)) 'WORD \FILLINDA 0))) (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with 0) (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG) (replace (M44STREAM LEADERPAGE) of STREAM with LEADERPAGE) (SETQ FPBASE (fetch (ARRAYP BASE) of FP)) (replace (FP FPSERIAL#) of FPBASE with (add (fetch (DSKOBJ DISKLASTSERIAL# ) of DSK) 1)) (COND (DIRECTORYP (add (fetch (FP FPSERIALHI) of FPBASE) \FP.DIRECTORYP))) (replace (FP FPVERSION) of FPBASE with 1) (SETA MAP 0 \EOFDA) (SETA MAP 3 \EOFDA) (* ;  "We are about to create pages 0 and 1, everything else is nonexistent") (* ;  "Done by the NCREATE -- (\ZEROPAGE (fetch (POINTER PAGE#) of LEADERPAGE))") (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of LEADERPAGE)) (SETQ DAT (\DAYTIME0 (create FIXP))) WORDSPERCELL) (* ; "Set creation and write dates") (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of LEADERPAGE)) (OR CRDATE DAT) WORDSPERCELL) (* ;  "See \M44MAKEDIRENTRY for the name logic.") (for C in (fetch (UNAME ORIGCHARS) of UNAME) bind (NAMEBASE _ (LOCF (fetch (\M44LeaderPage NameCharCount) of LEADERPAGE)) ) (V _ (fetch (UNAME VERSION) of UNAME)) do (\PUTBASEBYTE NAMEBASE (add NC 1) C) finally [COND ((NEQ V 1) (\PUTBASEBYTE NAMEBASE (add NC 1) (CHARCODE !)) (for C in (CHCON V) do (\PUTBASEBYTE NAMEBASE (add NC 1) C] (\PUTBASEBYTE NAMEBASE (add NC 1) (CHARCODE %.)) (* ;  "Last character of all alto names is dot") (replace (\M44LeaderPage NameCharCount) of LEADERPAGE with NC)) (replace (\M44LeaderPage PropertyBegin) of LEADERPAGE with (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE))) [replace (\M44LeaderPage PropertyLength) of LEADERPAGE with (CONSTANT (- (INDEXF (FETCH (\M44LeaderPage Spares) of LEADERPAGE)) (INDEXF (FETCH (\M44LeaderPage LeaderProps) of LEADERPAGE] (* ; "The start and length of the property section are theoretically variable, but at least some %"official%" Alto software, such as Scavenge, believes that file names must be no more than 39 chars.") (\M44SETFILETYPE STREAM TYPE) (\WRITEDISKPAGES DSK (LIST LEADERPAGE NIL) (fetch (ARRAYP BASE) of MAP) -1 STREAM 0 1 NIL NIL 0 0) (* ;  "The end of file will be zero and the validation not set as befits a new file.") (replace (FP FPLEADERVDA) of FPBASE with (\WORDELT MAP 1)) (* ;  "Now that the file is safely created, make entry in directory") (replace (M44STREAM DIRINFO) of STREAM with (\M44MAKEDIRENTRY (fetch (M44STREAM FID) of STREAM) UNAME NC FDEV)) (RETURN STREAM]) (\M44DeleteFile [LAMBDA (FILENAME DEV) (* ; "Edited 21-Jan-91 23:35 by jds") (* ; "Delete a Model44 file.") (PROG ((STREAM (\M44GetFileHandle FILENAME 'OLDEST DEV T))) (COND ((OR (NOT STREAM) (FDEVOP 'OPENP DEV (fetch FULLFILENAME of STREAM) NIL DEV)) (* ; "Can't delete an open file") (RETURN))) (\M44DELETEPAGES STREAM -1) (PROG ((DIROFD (fetch (M44DEVICE SYSDIROFD) of DEV))) (* ; "Delete directory entry") (\SETFILEPTR DIROFD (fetch (M44STREAM DIRINFO) of STREAM)) (\BOUT DIROFD (LOGAND 3 (\PEEKBIN DIROFD))) (FLUSHMAP DIROFD)) (\M44KillFilePageMap STREAM) (replace (M44STREAM FID) of STREAM with NIL) (RETURN (fetch FULLFILENAME of STREAM]) (\M44EVENTFN [LAMBDA (FDEV EVENT) (* ; "Edited 21-Jan-91 23:31 by jds") (DECLARE (GLOBALVARS \DEVICENAMETODEVICE \MACHINETYPE)) (SELECTQ EVENT ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (* ;;  "reinitialize DSK device and revalidate its open streams") [PROG ((DSKOBJ (fetch (M44DEVICE DSKOBJ) of FDEV)) DD) (COND ((SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ)) (* ;  "Flush out of date disk descriptor") (FORGETPAGES DD) (FDEVOP 'UNREGISTERFILE FDEV FDEV DD) (* ;  "Stream no longer in use. Don't go thru \M44CloseFile because it will try to Truncate, etc.") (replace (DSKOBJ DDVALID) of DSKOBJ with NIL) (replace (DSKOBJ DISKDESCRIPTOROFD) of DSKOBJ with NIL))) (FORGETPAGES (fetch (DSKOBJ SYSDIROFD) of DSKOBJ)) (FDEVOP 'UNREGISTERFILE FDEV FDEV (fetch (DSKOBJ SYSDIROFD) of DSKOBJ)) (COND [(AND (EQ \MACHINETYPE \DORADO) (LET [(PARTZEROP (EQ (fetch (M44DEVICE DSKPARTITION) of FDEV) 0)) (CURPARTP (EQ (fetch (FDEV DEVICENAME) of FDEV) (PACK* 'DSK (DISKPARTITION] (COND (PARTZEROP (* ;  "This is interlock with \M44EXTENDVMEMFILE which doesn't want to mess up the DiskDescriptor") (SETQ \M44.READY T))) (COND ((OR (AND PARTZEROP CURPARTP) (\DEVICE-OPEN-STREAMS FDEV)) (COND ((EQ PARTZEROP CURPARTP) (* ;  "No partition change to worry about, just reopen dir") (\OPENDIR FDEV)) (PARTZEROP (* ;; "This was the default partition, no longer is, so reopen it as if from scratch. Also, remove the mapping of DSK to this device") (\REMOVEDEVICE.NAMES FDEV 'DSK) (\OPENDISK (SUBATOM (fetch (FDEV DEVICENAME) of FDEV) 4) FDEV)) (T (* ;  "This was a non-default partition, now the default. Reopen it with \MAINDISK as its DSKOBJ") (\OPENDISKDEVICE NIL NIL FDEV] (T (* ;; "Device no longer exists if machine is now Dandelion; and if there were no open files, no need to try reopening the dir") (replace (DSKOBJ SYSDIROFD) of DSKOBJ with NIL) (* ;; "Have to explicitly clear these fields, because when we drop the DSKOBJ on the floor, GC does not know about its POINTER fields") (replace REOPENFILE of FDEV with (FUNCTION NILL)) (* ;  "In case there are files open over sysout as we come back on Dandelion") (\REMOVEDEVICE FDEV] (\PAGED.REVALIDATEFILELST FDEV)) (BEFORELOGOUT (\FLUSH.OPEN.STREAMS FDEV) (\M44FLUSHDISKDESCRIPTOR FDEV)) NIL]) (\M44ExtendFilePageMap [LAMBDA (STREAM TOPAGE#) (* ; "Edited 21-Jan-91 23:35 by jds") (* ;; "If the file's page map is not big enough to map the given page, then create a new one that is big enough and copy the old OLDMAP information into the new map. If the file has no map, then create one big enough to map the given page. Return the new map. --- Map entry 0 corresponds to bfs page -1, entry 1 corresponds to the leader page, and entry 2 corresponds to Lisp page 0") (PROG ((OLDMAP (fetch (M44STREAM FILEPAGEMAP) of STREAM)) OLDSIZE NEWMAP) (RETURN (COND ([AND OLDMAP (ILESSP (IPLUS TOPAGE# 3) (SETQ OLDSIZE (fetch (ARRAYP LENGTH) of OLDMAP] OLDMAP) (T (SETQ NEWMAP (ARRAY (CEIL (IPLUS TOPAGE# 4) PageMapIncrement) 'SMALLPOSP \FILLINDA 0)) [COND (OLDMAP (* ; "Copy old map into new") (\BLT (fetch (ARRAYP BASE) of NEWMAP) (fetch (ARRAYP BASE) of OLDMAP) OLDSIZE)) (T (* ;  "Initialize with leader page hint") (SETA NEWMAP 0 \EOFDA) (SETA NEWMAP 1 (fetch (FP FPLEADERVDA) of (fetch (ARRAYP BASE) of (fetch (M44STREAM FID) of STREAM] (replace (M44STREAM FILEPAGEMAP) of STREAM with NEWMAP) NEWMAP]) (\M44FillInMap [LAMBDA (STREAM UPTOPAGE) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;;; "Assures that the disk address map for STREAM is filled in up thru page# UPTOPAGE. Reads file as needed") (PROG ((MAP (\M44ExtendFilePageMap STREAM UPTOPAGE)) (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))) (LASTKNOWNPAGE (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)) NPAGES LASTPAGEREAD LASTATTEMPTED DAs DA) (* ; "Extend MAP") (SETQ DAs (fetch (ARRAYP BASE) of MAP)) [while (ILESSP LASTKNOWNPAGE UPTOPAGE) do (COND [(NEQ (SETQ DA (\GETBASE DAs (IPLUS LASTKNOWNPAGE 1 2))) \FILLINDA) (* ;  "There already is an entry for the next page, so no need to read it") (COND ((EQ DA \EOFDA) (RETURN)) (T (add LASTKNOWNPAGE 1] (T [SETQ NPAGES (IMIN \MAXDISKDAs (ADD1 (IDIFFERENCE UPTOPAGE LASTKNOWNPAGE] (* ;; "We know where LASTKNOWNPAGE lives, so read it to find out where the next page after that is. Can do this for many pages at once to make it reasonable") (SETQ LASTPAGEREAD (\ACTONDISKPAGES DSK NIL DAs -1 STREAM (.LISP.TO.BFS. LASTKNOWNPAGE) [SETQ LASTATTEMPTED (.LISP.TO.BFS. (SUB1 (IPLUS LASTKNOWNPAGE NPAGES ] \DC.READD)) (SETQ LASTKNOWNPAGE (.BFS.TO.LISP. LASTPAGEREAD)) (COND ((ILESSP LASTPAGEREAD LASTATTEMPTED) (* ; "Hit end of file") (RETURN] (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LASTKNOWNPAGE) (RETURN LASTKNOWNPAGE]) (\M44GetFileHandle [LAMBDA (NAME RECOG FDEV FAST CREATEFLG) (* ; "Edited 21-Jan-91 23:48 by jds") (* ;; "Creates a STREAM for dsk file NAME. If file does not exist, but CREATEFLG is true, returns the UNAME of the file so that it may be created. If FAST is true, does not fill in any fields of STREAM that would require reading the file, e.g., the length and full map") (LET ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV)) FS DP STREAM) (COND ((NULL DIRSTREAM) (* ; "Non-existent device") NIL) ((NULL (SETQ FS (\M44PARSEFILENAME NAME RECOG FDEV CREATEFLG))) (* ; "File not found") NIL) ((SETQ DP (fetch (FILESPEC FSDIRPTR) of FS)) (* ;  "File was found--here's the directory pointer") (SETQ STREAM (create M44STREAM)) (replace DEVICE of STREAM with FDEV) (replace (M44STREAM FID) of STREAM with (\M44READDIRFID DIRSTREAM DP)) (replace (M44STREAM DIRINFO) of STREAM with DP) (replace FULLFILENAME of STREAM with (\M44PACKFILENAME (fetch (FILESPEC UNAME) of FS) DP DIRSTREAM)) (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG) (OR FAST (\M44CompleteFH STREAM)) STREAM) ((NULL (fetch (FILESPEC UNAME) of FS)) (* ;  "Name was malformed--can't create it even if we want to") (LISPERROR "BAD FILE NAME" NAME)) (CREATEFLG (fetch (FILESPEC UNAME) of FS]) (\M44GetFileInfo [LAMBDA (STREAM ATTRIBUTE DEV) (* ; "Edited 21-Jan-91 23:44 by jds") (* ;; "Get the value of the ATTRIBUTE for a model44 file. If STREAM is a filename, then the file is not open.") (COND ((OR (type? STREAM STREAM) (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T))) (SELECTQ ATTRIBUTE ((LENGTH SIZE) (COND ((NULL (fetch VALIDATION of STREAM)) (* ;  "Need to read leader page etc to get length") (\M44CompleteFH STREAM))) (SELECTQ ATTRIBUTE (LENGTH (create BYTEPTR PAGE _ (fetch EPAGE of STREAM) OFFSET _ (fetch EOFFSET of STREAM))) (IPLUS (fetch EPAGE of STREAM) (FOLDHI (fetch EOFFSET of STREAM) BYTESPERPAGE)))) (TYPE [PROG ((BUF (\M44ReadLeaderPage STREAM))) (RETURN (COND ((IGREATERP (fetch (\M44LeaderPage PropertyLength) of BUF) 0) (SETQ BUF (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin) of BUF))) (do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of BUF) (0 (* ; "End of properties") (RETURN)) (\FPROP.TYPE [RETURN (SELECTC (fetch (M44FILEPROP FPROPWORD0) of BUF) (\FPTYPE.TEXT 'TEXT) (\FPTYPE.BINARY 'BINARY) (\FPTYPE.UNKNOWN NIL) (\TYPE.FROM.FILETYPE (fetch (M44FILEPROP FPROPWORD0 ) of BUF]) NIL) (SETQ BUF (\ADDBASE BUF (fetch (M44FILEPROP FPROPLENGTH) of BUF]) (CREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate) of T)) T)) (WRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite) of T)) T)) (READDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead) of T)) T)) (ICREATIONDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeCreate) of T)))) (IWRITEDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeWrite) of T)))) (IREADDATE (\M44GETDATEPROP STREAM (INDEXF (fetch (\M44LeaderPage TimeRead) of T)))) NIL]) (\M44GETDATEPROP (LAMBDA (STREAM OFFSET STRINGIFY) (* bvm%: "27-May-84 22:57") (* ;; "Returns the create/write/read date of STREAM that lives at OFFSET in its leader page, as a string if STRINGIFY is true, else as a Lisp date fixp") (PROG ((DATEBASE (\ADDBASE (\M44ReadLeaderPage STREAM) OFFSET)) DAT) (SETQ DAT (\MAKENUMBER (\GETBASE DATEBASE 0) (\GETBASE DATEBASE 1))) (RETURN (COND ((NEQ DAT 0) (SETQ DAT (ALTO.TO.LISP.DATE DAT)) (COND (STRINGIFY (GDATE DAT)) (T DAT))))))) ) (\M44GetFileName [LAMBDA (NAME RECOG FDEV) (* ; "Edited 21-Jan-91 23:48 by jds") (LET ((FS (\M44PARSEFILENAME NAME RECOG FDEV)) DP UNAME) (AND FS (SETQ UNAME (fetch (FILESPEC UNAME) of FS)) (\M44PACKFILENAME UNAME (SETQ DP (fetch (FILESPEC FSDIRPTR) of FS)) (AND DP (fetch (M44DEVICE SYSDIROFD) of FDEV]) (\M44GetPageLoc [LAMBDA (STREAM PAGENO CREATE?) (* ; "Edited 21-Jan-91 23:35 by jds") (* ;; "Look in the file's page map to find the disk address of the page. If the map does not include the page, then extend it appropriately. If page does not exit, create it if CREATE? is true, else return \EOFDA") (COND ((ILEQ PAGENO (fetch (M44STREAM LastPage) of STREAM)) (COND ((IGREATERP PAGENO (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)) (\M44FillInMap STREAM PAGENO))) (\WORDELT (fetch (M44STREAM FILEPAGEMAP) of STREAM) (IPLUS PAGENO 2))) (CREATE? (\M44AddDiskPages STREAM PAGENO 0) (\M44GetPageLoc STREAM PAGENO)) (T \EOFDA]) (\M44KillFilePageMap [LAMBDA (fHandle) (* ; "Edited 21-Jan-91 23:35 by jds") (* ; "Remove the file's page map.") (replace (M44STREAM FILEPAGEMAP) of fHandle with NIL) (replace (M44STREAM LASTMAPPEDPAGE) of fHandle with -1]) (\M44MAKEDIRENTRY [LAMBDA (FID UNAME NC FDEV) (* ; "Edited 21-Jan-91 23:38 by jds") (* ;; "Makes a directory entry for a new file. FID is file's ID, NC the number of characters in the full Alto name.") (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV)) (VERSION (fetch (UNAME VERSION) of UNAME)) POS) (SETQ POS (\FINDDIRHOLE (LRSH (IPLUS NC 14) 1) DIRSTREAM)) (\BOUTS DIRSTREAM (fetch (FID FIDBLOCK) of FID) 0 (UNFOLD 5 BYTESPERWORD)) (\BOUT DIRSTREAM NC) (* ;; "Now write out the alto-style name 'name[.ext]!ver.' with ver omitted if 1; This is basically the same logic as is used to write the name in the leader page in \M44CREATEFILE. We can't share cause here we do bouts, cause we might run over a page; there we must do PUTBASEBYTE's cause we can't set the fileptr to the leader page.") (for C in (fetch (UNAME ORIGCHARS) of UNAME) do (\BOUT DIRSTREAM C)) [COND ((NEQ VERSION 1) (\BOUT DIRSTREAM (CHARCODE !)) (LET ((*PRINT-BASE* 10)) (PRIN3 VERSION DIRSTREAM] (\BOUT DIRSTREAM (CHARCODE %.)) (COND ((EVENP NC BYTESPERWORD) (\BOUT DIRSTREAM 0))) (\SETFILEPTR DIRSTREAM POS) (\BOUT DIRSTREAM (LOGOR 4 (\PEEKBIN DIRSTREAM))) (* ;  "When everything is ready, finally change the type from hole to file.") (FORCEOUTPUT DIRSTREAM) (RETURN POS]) (\M44OpenFile [LAMBDA (NAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 21-Jan-91 23:38 by jds") (* ;; "Open a Model44 file. Gets the physical end of file and sets up ofd") (PROG (PAGESTIMATE STREAM CRDATE TYPE DON'T.CHANGE.DATE X) (* ;  "if file is open in a conflicting way, barf") [COND ((NEQ ACCESS 'INPUT) (* ;  "Interesting parameters when creating a file") (for X in PARAMETERS do (SELECTQ (CAR (LISTP X)) (LENGTH (SETQ PAGESTIMATE (IPLUS 2 (FOLDHI (CADR X) BYTESPERPAGE)))) (CREATIONDATE (SETQ CRDATE (IDATE (CADR X)))) (ICREATIONDATE (SETQ CRDATE (CADR X))) (TYPE (SETQ TYPE (CADR X))) (DON'T.CHANGE.DATE (SETQ DON'T.CHANGE.DATE T)) NIL] (COND [(type? STREAM NAME) (COND ((OR (fetch (M44DEVICE DSKPASSWORDOK) of (fetch DEVICE of NAME)) (EQ (fetch (FID W0) of (fetch (M44STREAM FID) of NAME)) 32768)) (* ;  "Make sure password is ok if trying to reopen anything but a directory") (\M44CompleteFH (SETQ STREAM NAME))) (T (RETURN] ([NULL (SETQ STREAM (\M44GetFileHandle NAME RECOG FDEV NIL (NEQ ACCESS 'INPUT] (* ;  "File not found. Return NIL to let generic open generate a FILE NOT FOUND error") (RETURN NIL))) (if OLDSTREAM then (* ; "REOPENFILE--nothing more to do") (RETURN STREAM)) [COND ([AND PAGESTIMATE (IGREATERP PAGESTIMATE (IPLUS (fetch (M44DEVICE DISKFREEPAGES) of FDEV) (COND ((type? STREAM STREAM) (fetch (M44STREAM LastPage) of STREAM)) (T (* ; "New file") 0] (RETURN (LISPERROR "FILE SYSTEM RESOURCES EXCEEDED" (COND ((type? STREAM STREAM) (fetch FULLFILENAME of STREAM)) (T NAME] [COND (CRDATE (* ; "Convert to alto format") (COND ([NOT (type? FIXP (SETQ CRDATE (LISP.TO.ALTO.DATE CRDATE] (* ; "sigh, wanted a number box") (\PUTBASEFIXP (SETQ X (create FIXP)) 0 CRDATE) (SETQ CRDATE X] [COND ((NOT (type? STREAM STREAM)) (* ; "New file") (SETQ STREAM (\M44CREATEFILE FDEV STREAM PAGESTIMATE CRDATE TYPE))) (T (* ; "Old file") [LET ((MYNAME (fetch FULLFILENAME of STREAM))) (COND ([for OTHER in (fetch (FDEV OPENFILELST) of FDEV) when (STRING-EQUAL (fetch FULLFILENAME of OTHER) MYNAME) do (RETURN (OR (NEQ ACCESS 'INPUT) (NEQ (fetch ACCESS of OTHER) 'INPUT] (* ;  "Access conflict with existing open file") (RETURN (LISPERROR "FILE WON'T OPEN" MYNAME] [COND ((EQ ACCESS 'OUTPUT) (* ; "File is EMPTY even if it is old") (replace EPAGE of STREAM with (replace EOFFSET of STREAM with 0] (* ;  "Leader page is read in during STREAM initialization") (COND ((NOT DON'T.CHANGE.DATE) (\M44SetAccessTimes STREAM ACCESS CRDATE) (* ; "Resets validation") (\M44WriteLeaderPage STREAM) (* ;  "We write out accumulated changes to leader page") ] (COND (CRDATE (replace NONDEFAULTDATEFLG of STREAM with T))) (RETURN STREAM]) (\M44OPENFILEFROMFP [LAMBDA (DEV NAME ACCESS FID DIRINFO) (* ; "Edited 21-Jan-91 23:36 by jds") (* ; "Opens a disk file given its FP") (LET ((STREAM (create M44STREAM))) (replace FULLFILENAME of STREAM with (SETQ NAME (PACK* '{ (fetch (FDEV DEVICENAME) of DEV) '} NAME))) (replace DEVICE of STREAM with DEV) (replace (M44STREAM FID) of STREAM with FID) (replace (M44STREAM DIRINFO) of STREAM with DIRINFO) (replace MULTIBUFFERHINT of STREAM with \M44MULTFLG) (\OPENFILE STREAM ACCESS) (replace USERVISIBLE of STREAM with NIL) STREAM]) (\M44ReadDiskPage [LAMBDA (STREAM PAGENO BUF) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;; "The functions for reading a disk page called by \M44ReadPages. Returns the number of bytes read. If PAGEADDR is 0, then assume 0 bytes read. Fill the BUF with zeros beyond the last byte read.") (COND ((AND (IGEQ PAGENO (fetch EPAGE of STREAM)) (OR (NOT (IEQP PAGENO (fetch EPAGE of STREAM))) (EQ (fetch EOFFSET of STREAM) 0))) (* ;  "Asking for page after eof. PMAP system really ought to catch this itself") (\CLEARWORDS BUF WORDSPERPAGE) 0) (T (PROG ((PAGEADDR (\M44GetPageLoc STREAM PAGENO)) (BFSPG# (ADD1 PAGENO))) (RETURN (COND ((EQ PAGEADDR \EOFDA) (* ;  "no bytes read, fill with zeroes.") (\CLEARWORDS BUF WORDSPERPAGE) 0) ((EQ PAGEADDR \FILLINDA) (SHOULDNT)) ((EQ (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUF (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM BFSPG# BFSPG# \DC.READD) BFSPG#) BYTESPERPAGE) (T (* ;; "if READDISKPAGE returns NIL, presumably there is an error of some kind, hope it was with the file map and try again.") (\M44KillFilePageMap STREAM) (\M44ReadDiskPage STREAM PAGENO BUF]) (\M44ReadLeaderPage [LAMBDA (STREAM AGAIN) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;;; "Returns the leader page of STREAM, reading it if necessary. If AGAIN is true, will read it afresh even if it already has a cached leader page") (* ;; "File leader page format: Words 0-1, time created. Words 2-3, time last written. Words 4-5, time last read. Words 6-25, name of file. Words 26-235, leader properties. Words 236-245, spare. Word 246, property pointer. Word 247, change serial number. Words 248-252, STREAM hint for directory. Word 253, disk address of last page. Word 254, page number of last page. Word 255, number of bytes on last page.") (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM))) (COND [(NULL BUFFER) (SETQ BUFFER (NCREATE 'VMEMPAGEP] ((NOT AGAIN) (RETURN BUFFER))) (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUFFER (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP) of STREAM ) (\MAKELEADERDAS STREAM))) -1 STREAM 0 0 \DC.READD) (replace (M44STREAM LEADERPAGE) of STREAM with BUFFER) (RETURN BUFFER]) (\M44ReadPages (LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* bvm%: "26-DEC-81 23:50") (* ; "Read pages from a Model44 file.") (for BUF inside BUFFERS as PAGENO from FIRSTPAGE# sum (\M44ReadDiskPage STREAM PAGENO BUF))) ) (\M44SetAccessTimes [LAMBDA (STREAM ACCESS CRDATE) (* ; "Edited 21-Jan-91 23:36 by jds") (* ;;; "Set the 'last read' and/or 'last written' times in the leader page according to access, which is assumed to be either INPUT, OUTPUT, BOTH, or APPEND.") (PROG ((DAT (\DAYTIME0 (create FIXP))) (BUF (fetch (M44STREAM LEADERPAGE) of STREAM))) (* ;; "Note: DAYTIME0 returns an Alto time, not Lisp time. This is consistent with the dates in the leader page") (SELECTQ ACCESS ((OUTPUT BOTH APPEND) (\BLT (LOCF (fetch (\M44LeaderPage TimeCreate) of BUF)) (OR CRDATE DAT) WORDSPERCELL) (\BLT (LOCF (fetch (\M44LeaderPage TimeWrite) of BUF)) DAT WORDSPERCELL) (* ;  "Must revalidate because write DAT has changed") (UPDATEVALIDATION STREAM BUF)) NIL) (SELECTQ ACCESS ((INPUT BOTH) (\BLT (LOCF (fetch (\M44LeaderPage TimeRead) of BUF)) DAT WORDSPERCELL)) NIL]) (\M44SetEndOfFile [LAMBDA (STREAM EPAGE EOFFSET UPDATENOW) (* ; "Edited 21-Jan-91 23:36 by jds") (* ;; "Reset the file's leader page end-of-file hint. If UPDATENOW is NIL, then simply update the leader page. If it is not, then read and write the leader page.") (UNINTERRUPTABLY (* ;; "Must update STREAM handle and leader page in synch") (replace (M44STREAM LastPage) of STREAM with EPAGE) (replace (M44STREAM LastOffset) of STREAM with EOFFSET) [LET ((LEADERPAGE (\M44ReadLeaderPage STREAM))) (if (NEQ (fetch (\M44LeaderPage LastPageNumber) of LEADERPAGE) (ADD1 EPAGE)) then (* ;  "if LastPage hasn't changed, don't do anything") (* ; "ADD1 because M44 counts from 1") (replace (\M44LeaderPage LastPageAddress) of LEADERPAGE with (\M44GetPageLoc STREAM EPAGE)) (replace (\M44LeaderPage LastPageNumber) of LEADERPAGE with (ADD1 EPAGE))) (replace (\M44LeaderPage LastPageByteCount) of LEADERPAGE with EOFFSET) (COND (UPDATENOW (\M44WriteLeaderPage STREAM])]) (\M44SetFileInfo [LAMBDA (STREAM ATTRIBUTE VALUE DEV) (* ; "Edited 21-Jan-91 23:34 by jds") (PROG ((WASOPEN (type? STREAM STREAM))) (SELECTQ ATTRIBUTE (CREATIONDATE (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (ICREATIONDATE (OR (FIXP VALUE) (LISPERROR "NON-NUMERIC ARG" VALUE))) (TYPE) (RETURN)) (RETURN (COND ((OR WASOPEN (SETQ STREAM (\M44GetFileHandle STREAM 'OLD DEV T))) (COND ((SELECTQ ATTRIBUTE (TYPE (\M44SETFILETYPE STREAM VALUE)) (PROGN (replace (\M44LeaderPage TimeCreate) of (  \M44ReadLeaderPage STREAM) with (LISP.TO.ALTO.DATE VALUE)) T)) (\M44WriteLeaderPage STREAM) T]) (\M44SETFILETYPE [LAMBDA (STREAM TYPE) (* ; "Edited 21-Jan-91 23:44 by jds") (* ;; "Set TYPE attribute of file to be TYPE -- assumes someone else will be writing out the leader page later") (PROG ((TYPECODE (SELECTQ TYPE (TEXT \FPTYPE.TEXT) (BINARY \FPTYPE.BINARY) (NIL \FPTYPE.UNKNOWN) (OR (\FILETYPE.FROM.TYPE TYPE) \FPTYPE.BINARY))) (BUF (\M44ReadLeaderPage STREAM)) PTR TOTALLENGTH) (* ;; "Computation of TYPECODE done this way for backward compatibility -- the \FPTYPE.xx constants were defined before \FILETYPE.FROM.TYPE was written, and the numbers are incompatible") (SETQ PTR (\ADDBASE BUF (fetch (\M44LeaderPage PropertyBegin) of BUF))) (SETQ TOTALLENGTH (fetch (\M44LeaderPage PropertyLength) of BUF)) (RETURN (while (IGREATERP TOTALLENGTH 0) do (SELECTC (fetch (M44FILEPROP FPROPTYPE) of PTR) (0 (* ; "End of properties") (RETURN (COND ((IGREATERP TOTALLENGTH 1) (replace (M44FILEPROP FPROPWORD0) of PTR with TYPECODE) (replace (M44FILEPROP FPROPLENGTH) of PTR with 2) (replace (M44FILEPROP FPROPTYPE) of PTR with \FPROP.TYPE) T)))) (\FPROP.TYPE (* ; "Already has a type, change it") (replace (M44FILEPROP FPROPWORD0) of PTR with TYPECODE) (RETURN T)) NIL) (SETQ PTR (\ADDBASE PTR (fetch (M44FILEPROP FPROPLENGTH) of PTR))) (SETQ TOTALLENGTH (IDIFFERENCE TOTALLENGTH (fetch (M44FILEPROP FPROPLENGTH) of PTR]) (\M44TruncateFile [LAMBDA (STREAM LP LO UPDATENOW) (* ; "Edited 21-Jan-91 23:36 by jds") (* ;;  "Resets the length of the file to LP page and LO offset. Can both shorten and lengthen files.") [COND ((NOT LP) (SETQ LP (fetch EPAGE of STREAM)) (SETQ LO (fetch EOFFSET of STREAM] (COND ((IGREATERP LP (fetch (M44STREAM LastPage) of STREAM)) (\M44AddDiskPages STREAM LP LO)) ((ILESSP LP (fetch (M44STREAM LastPage) of STREAM)) (\M44DELETEPAGES STREAM (ADD1 LP)) (COND ((ILESSP LP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM)) (for I from (ADD1 LP) to (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM) do (SETA (fetch (M44STREAM FILEPAGEMAP) of STREAM) (IPLUS I 2) \EOFDA)) (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with LP))) (\M44SetEndOfFile STREAM LP LO) (* ;  "Now need to rewrite last page with new length, null next pointer") (\MAPPAGE LP STREAM) (\SETIODIRTY STREAM LP) (FORCEOUTPUT STREAM)) (T (replace (M44STREAM LastOffset) of STREAM with LO))) (AND UPDATENOW (\M44SetEndOfFile STREAM LP LO T)) STREAM]) (\M44WriteDiskPage [LAMBDA (STREAM PAGENO BUF NBYTES) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;  "Write a disk page on the Model44.") (\M44GetPageLoc STREAM PAGENO T) (* ; "Ensure that PAGENO is in map") (PROG ((BFSPG# (ADD1 PAGENO))) (RETURN (COND ([COND ((NEQ PAGENO (fetch (M44STREAM LastPage) of STREAM)) (* ; "Writing only data") (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUF (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM BFSPG# BFSPG# \DC.WRITED)) (T (* ;  "When writing last page, need to fill in the numchars field of label, so this is harder") (COND ((EQ PAGENO (fetch EPAGE of STREAM)) (EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUF (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM BFSPG# BFSPG# NIL NIL NBYTES) BFSPG#)) (T (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it. This may save a call to \ADDDISKPAGES") [COND ((ILEQ (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM) PAGENO) (\M44ExtendFilePageMap STREAM (ADD1 PAGENO] (COND ((EQ (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM) ) (LIST BUF NIL) (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM BFSPG# (ADD1 BFSPG#) NIL NIL 0) (ADD1 BFSPG#)) (* ;  "Write two pages, the second of which is blank") (replace (M44STREAM LastPage) of STREAM with (ADD1 PAGENO)) (replace (M44STREAM LastOffset) of STREAM with 0) T] NBYTES) (T (\M44KillFilePageMap STREAM) (\M44WriteDiskPage STREAM PAGENO BUF NBYTES]) (\M44WriteLeaderPage [LAMBDA (STREAM) (* ; "Edited 21-Jan-91 23:42 by jds") (* ; "Write the file's leader page") (PROG ((BUFFER (fetch (M44STREAM LEADERPAGE) of STREAM))) (AND BUFFER (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUFFER (fetch (ARRAYP BASE) of (OR (fetch (M44STREAM FILEPAGEMAP) of STREAM) (\MAKELEADERDAS STREAM))) -1 STREAM 0 0 \DC.WRITED]) (\M44WritePages [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* ; "Edited 21-Jan-91 23:36 by jds") (* ;  "Write pages onto a Model44 file.") (PROG ([NPAGES (COND ((NLISTP BUFFERS) 1) (T (for B in BUFFERS sum 1] LASTPAGE#) (COND ((fetch REVALIDATEFLG of STREAM) (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write. Otherwise, it is possible to see a change to the file but no change to the creationdate") (\M44SetAccessTimes STREAM 'OUTPUT) (\M44WriteLeaderPage STREAM) (replace REVALIDATEFLG of STREAM with NIL))) (\M44GetPageLoc STREAM FIRSTPAGE# T) (* ;  "Make sure we know where we are starting to write") [COND ([ILESSP (fetch (M44STREAM LASTMAPPEDPAGE) of STREAM) (SETQ LASTPAGE# (IPLUS FIRSTPAGE# (SUB1 NPAGES] (* ;  "Need enough pagemap to cover everything we write") (\M44ExtendFilePageMap STREAM (ADD1 LASTPAGE#] [COND ([AND (IGEQ NPAGES \#DISKBUFFERS) (for B in BUFFERS thereis (NOT (EMADDRESSP B] (* ;; "More pages to write than we have disk buffers to do it in one command, so break it up. Buffers already in emulator space are free, though, so we can write lots of them") (bind (MAXPAGES _ (SUB1 \#DISKBUFFERS)) do (\M44WritePages1 STREAM FIRSTPAGE# (IPLUS FIRSTPAGE# (SUB1 MAXPAGES)) (to MAXPAGES collect (pop BUFFERS))) (add FIRSTPAGE# MAXPAGES) (SETQ NPAGES (IDIFFERENCE NPAGES MAXPAGES)) repeatwhile (IGREATERP NPAGES MAXPAGES] (\M44WritePages1 STREAM FIRSTPAGE# LASTPAGE# BUFFERS]) (\M44WritePages1 [LAMBDA (STREAM FIRSTPAGE# LASTPAGE# BUFFERS) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;;; "Writes BUFFERS to STREAM, covering pages FIRSTPAGE# thru LASTPAGE#. Caller guarantees that we have enough disk buffers to do it. --- There are two cases: easy one is if the pages already exist, in which case we just rewrite their data; hard case is writing pages at end of file, in which case we need to write labels and maybe allocate pages") (COND ((ILESSP LASTPAGE# (fetch (M44STREAM LastPage) of STREAM)) (* ; "Writing only data") (\ACTONDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM)) BUFFERS (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#) (.LISP.TO.BFS. LASTPAGE#) \DC.WRITED)) (T (* ;  "When writing last page, need to fill in the numchars field of label, so this is harder") (PROG (MYBUFS NBYTES) [SETQ MYBUFS (COND ((AND (EQ LASTPAGE# (fetch EPAGE of STREAM)) (NEQ (SETQ NBYTES (fetch EOFFSET of STREAM)) BYTESPERPAGE)) (* ;  "Only write to the end of the file") BUFFERS) (T (* ;; "We will have to write more pages after this one, too, unless the file is truncated back to here, so extend the file while we're at it. This may save a call to \ADDDISKPAGES") (PROG1 (SETQ MYBUFS (CONS)) [for B inside BUFFERS do (RPLACA MYBUFS B) (SETQ MYBUFS (CDR (RPLACD MYBUFS (CONS] (RPLACD (RPLACA MYBUFS NIL) NIL) (* ; "Write a final blank page") (SETQ NBYTES 0) (add LASTPAGE# 1))] (\WRITEDISKPAGES (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM )) MYBUFS (fetch (ARRAYP BASE) of (fetch (M44STREAM FILEPAGEMAP) of STREAM)) -1 STREAM (.LISP.TO.BFS. FIRSTPAGE#) (.LISP.TO.BFS. LASTPAGE#) NIL NIL NBYTES) (replace (M44STREAM LastPage) of STREAM with LASTPAGE#) (replace (M44STREAM LastOffset) of STREAM with NBYTES]) ) (* ;; "Disk allocation") (DEFINEQ (\ADDDISKPAGES [LAMBDA (STREAM FIRSTNEWPAGE NPAGES DAs LASTNUMCHARS) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;; "Adds to file STREAM NPAGES, where FIRSTNEWPAGE-1 is the last existing page. DAs is the vector of disk addresses, where first element corresponds to BFS page -1") (* ;  "Note FIRSTNEWPAGE is in Lisp terms, so it is actually LASTOLDPAGE for the BFS") (PROG ((LASTPAGEBUF (NCREATE 'VMEMPAGEP)) (LASTEXISTINGPAGE FIRSTNEWPAGE) (DSK (fetch (M44DEVICE DSKOBJ) of (fetch DEVICE of STREAM))) BUFFERS CHUNK) (SETQ BUFFERS (CONS LASTPAGEBUF (for I from 1 to (IMIN NPAGES \MAXDISKDAs) collect NIL))) (\ACTONDISKPAGES DSK LASTPAGEBUF DAs -1 STREAM LASTEXISTINGPAGE LASTEXISTINGPAGE \DC.READD NIL NIL NIL LASTEXISTINGPAGE) (* ;  "Read last existing page, so we can rewrite it with new label") (while (IGREATERP NPAGES 0) do (SETQ CHUNK (IMIN \MAXDISKDAs NPAGES)) (\WRITEDISKPAGES DSK BUFFERS DAs -1 STREAM LASTEXISTINGPAGE (IPLUS LASTEXISTINGPAGE CHUNK ) NIL NIL LASTNUMCHARS LASTEXISTINGPAGE) (RPLACA BUFFERS NIL) (add LASTEXISTINGPAGE CHUNK) (SETQ NPAGES (IDIFFERENCE NPAGES CHUNK]) (\M44DELETEPAGES [LAMBDA (STREAM FIRSTPAGE) (* ; "Edited 21-Jan-91 23:42 by jds") (* ;  "FIRSTPAGE is in Lisp terms, i.e. -1 = leader page") (PROG ((DEV (fetch DEVICE of STREAM)) (NPAGES (COND ((fetch VALIDATION of STREAM) (IPLUS (ADD1 (IDIFFERENCE (fetch (M44STREAM LastPage) of STREAM) FIRSTPAGE)) 2)) (T PageMapIncrement))) (PN (ADD1 FIRSTPAGE)) DAs FIRSTDA LASTPAGESEEN DSK) (* ;; "NPAGES is used to decide how much to do at once. Need be no more than number of pages known to exist. The ADD1 is that, plus two for the pages around it") (COND ((ILESSP NPAGES 2) (* ; "Nothing to delete") (RETURN))) (SETQ DSK (fetch (M44DEVICE DSKOBJ) of DEV)) (* (\FLUSHDISKDESCRIPTOR  (EMPOINTER (fetch (DSKOBJ DSKDDMGR)  of DSK)) (fetch (DSKOBJ ALTODSKOBJ)  of DSK))) (* ;  "Tell Alto to clear out anything it knows about dd") (* ;  "IF STREAM:LASTMAPPEDPAGE GE FIRSTPAGE+NPAGES THEN DAs _ STREAM:FILEPAGEMAP DAorigin _ -1") (SETQ DAs (ARRAY (SETQ NPAGES (IMIN NPAGES \MAXDISKDAs)) 'WORD NIL 0)) [SETQ FIRSTDA (COND [(EQ FIRSTPAGE -1) (fetch (FP FPLEADERVDA) of (fetch (FID FIDBLOCK) of (fetch (M44STREAM FID) of STREAM] (T (\M44GetPageLoc STREAM FIRSTPAGE] (while (NEQ FIRSTDA \EOFDA) do (SETA DAs 0 \FILLINDA) (SETA DAs 1 FIRSTDA) (* ; "Corresponds to PN") (for I from 2 to (SUB1 NPAGES) do (SETA DAs I \FILLINDA)) [SETQ LASTPAGESEEN (\ACTONDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs) (SUB1 PN) STREAM PN (IPLUS PN NPAGES -3) \DC.READD NIL NIL NIL (ADD1 (fetch EPAGE of STREAM] (* ; "Read DAs for the next NPAGES-2") (\WRITEDISKPAGES DSK NIL (fetch (ARRAYP BASE) of DAs) (SUB1 PN) \FREEPAGEFID PN LASTPAGESEEN (UNSIGNED -1 BITSPERWORD)) [for I from PN to LASTPAGESEEN do (\M44MARKPAGEFREE DEV (ELT DAs (ADD1 (IDIFFERENCE I PN] (SETQ FIRSTDA (ELT DAs (IPLUS (IDIFFERENCE LASTPAGESEEN PN) 2))) (SETQ PN (ADD1 LASTPAGESEEN))) (* (FLUSHMAP (fetch  (M44DEVICE DISKDESCRIPTOROFD) of DEV))  (FORGETPAGES (fetch  (M44DEVICE DISKDESCRIPTOROFD) of DEV))) (\M44FLUSHDISKDESCRIPTOR DEV]) (\ASSIGNDISKPAGE [LAMBDA (DSK PREVDA) (* ; "Edited 21-Jan-91 23:32 by jds") (* ;;; "Assigns a new page on DSK. If PREVDA is \EOFDA will pick random page, otherwise will attempt to allocate PREVDA+1. Returns NIL if disk is full") (PROG ([VDA (COND ((OR (EQ PREVDA \EOFDA) (COND ((EQ PREVDA \FILLINDA) (AND \DISKDEBUG (RAID "[Disk debug] \ASSIGNDISKPAGE called with \FILLINDA. ^N to continue" )) T))) (fetch (DSKOBJ DISKLASTPAGEALLOC) of DSK)) (T (ADD1 PREVDA] (DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK)) (MASK 128) BITS A LOOPEDONCE FREE) (OR (fetch (DSKOBJ DDVALID) of DSK) (RAID "DISKDESCRIPTOR not open" DSK)) (\SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO VDA BITSPERBYTE))) (SETQ A (MOD VDA BITSPERBYTE)) (FRPTQ A (SETQ MASK (LRSH MASK 1))) LP (COND ((NULL (SETQ BITS (\BIN DD))) (* ;; "End of file -- wrap around to start. This technique takes longer than necessary to bomb out when disk is full, but who cares?") (COND (LOOPEDONCE (RETURN NIL))) (SETQ LOOPEDONCE T) (\SETFILEPTR DD \DDBITTABSTART)) ((NEQ BITS 255) (until (OR (EQ (LOGAND BITS MASK) 0) (EQ (SETQ MASK (LRSH MASK 1)) 0)) do (add A 1)) (COND ((NEQ MASK 0) (* ; "Found a free page") (\BACKFILEPTR DD) (SETQ VDA (IPLUS (UNFOLD (IDIFFERENCE (\GETFILEPTR DD) \DDBITTABSTART) BITSPERBYTE) A)) (\BOUT DD (LOGOR BITS MASK)) (* ;  "Set bit indicating we snarfed this page") (* ; "Decrement free page count hint") [replace (DSKOBJ DISKFREEPAGES) of DSK with (COND ((EQ (SETQ FREE (fetch (DSKOBJ DISKFREEPAGES) of DSK)) 0) (AND \DISKDEBUG (RAID "[Disk debug] Free page hint went negative. ^N to continue" )) (\COUNTDISKFREEPAGES DD)) (T (SUB1 FREE] (replace (DSKOBJ DISKLASTPAGEALLOC) of DSK with VDA) (replace (DSKOBJ DDDIRTY) of DSK with T) (RETURN VDA))) (SETQ MASK 128) (SETQ A 0))) (GO LP]) (\COUNTDISKFREEPAGES (LAMBDA (DD) (* bvm%: "13-Feb-85 19:32") (* ;;; "Counts number of free pages on a disk. DD is the diskdescriptor stream") (OR (type? STREAM DD) (SETQ DD (\OPENDISKDESCRIPTOR (\GETDEVICEFROMNAME (OR DD (QUOTE DSK)))))) (PROG ((CNT 0) MASK BITS) (\SETFILEPTR DD \DDBITTABSTART) LP (COND ((NULL (SETQ BITS (\BIN DD))) (* ; "End of file") (RETURN CNT)) ((EQ BITS 0) (add CNT 8)) ((NEQ BITS 255) (SETQ MASK 128) (do (COND ((EQ (LOGAND BITS MASK) 0) (add CNT 1))) until (EQ (SETQ MASK (LRSH MASK 1)) 0)))) (GO LP))) ) (\M44MARKPAGEFREE (LAMBDA (DEV DA) (* bvm%: "17-Jan-85 17:11") (* ;; "Mark disk address DA on disk device DEV free") (PROG ((DSK (COND ((type? FDEV DEV) (fetch (M44DEVICE DSKOBJ) of DEV)) (T DEV))) DD BITS MASK) (SETQ DD (COND ((fetch (DSKOBJ DDVALID) of DSK) (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK)) (T (\OPENDISKDESCRIPTOR DEV)))) (SETFILEPTR DD (IPLUS \DDBITTABSTART (FOLDLO DA BITSPERBYTE))) (SETQ BITS (\BIN DD)) (SETQ MASK (LLSH 1 (IDIFFERENCE 7 (MOD DA BITSPERBYTE)))) (COND ((NEQ (LOGAND BITS MASK) 0) (* ; "Page is marked occupied, so free it") (\BACKFILEPTR DD) (\BOUT DD (LOGXOR BITS MASK)) (add (fetch (DSKOBJ DISKFREEPAGES) of DSK) 1) (replace (DSKOBJ DDDIRTY) of DSK with T))))) ) (\M44FLUSHDISKDESCRIPTOR [LAMBDA (DEV) (* ; "Edited 21-Jan-91 23:32 by jds") (PROG ((DSK (COND ((type? FDEV DEV) (fetch (M44DEVICE DSKOBJ) of DEV)) (T DEV))) DD) (OR (fetch (DSKOBJ DDDIRTY) of DSK) (RETURN)) (OR (SETQ DD (fetch (DSKOBJ DISKDESCRIPTOROFD) of DSK)) (RETURN (RAID "[Disk debug] no disk descriptor stream"))) (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#) (\BOUTS DD (LOCF (fetch (DSKOBJ DISKLASTSERIAL#) of DSK)) 0 \NBYTES.DISKINFO) (* ;  "Copy interesting stuff into diskdescriptor header") (FORCEOUTPUT DD) (replace (DSKOBJ DDDIRTY) of DSK with NIL) (RETURN T]) (\MAKELEADERDAS [LAMBDA (STREAM) (* ; "Edited 21-Jan-91 23:30 by jds") (* ;; "Makes a page map for STREAM that includes the leader vda") (PROG ((MAP (ARRAY 4 'WORD \FILLINDA 0))) (SETA MAP 0 \EOFDA) [SETA MAP 1 (fetch (FP FPLEADERVDA) of (fetch (ARRAYP BASE) of (fetch (M44STREAM FID) of STREAM] (replace (M44STREAM FILEPAGEMAP) of STREAM with MAP) (replace (M44STREAM LASTMAPPEDPAGE) of STREAM with -1) (RETURN MAP]) (DISKFREEPAGES (LAMBDA (DSK RECOMPUTE) (* ejs%: " 7-Nov-85 16:33") (* ; "DSK ignored for now") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK) (* ; "Temporary until this become a device op") (\DFSFreeDiskPages DSK RECOMPUTE)) (\M44FREEPAGECOUNT (COND ((type? FDEV DSK) DSK) (T (\GETDEVICEFROMNAME (OR DSK (QUOTE DSK))))) NIL RECOMPUTE))) ) (\M44FREEPAGECOUNT (LAMBDA (DEV DIRECTORY RECOMPUTE) (* bvm%: "12-Oct-85 15:43") (PROG (CNT) (COND ((NOT (type? M44DEVICE DEV)) (\ILLEGAL.ARG DEV))) (RETURN (COND (RECOMPUTE (SETQ CNT (\COUNTDISKFREEPAGES (\OPENDISKDESCRIPTOR DEV))) (COND ((NEQ CNT (fetch (M44DEVICE DISKFREEPAGES) of DEV)) (replace (M44DEVICE DISKFREEPAGES) of DEV with CNT) (replace (M44DEVICE DDDIRTY) of DEV with T))) CNT) (T (fetch (M44DEVICE DISKFREEPAGES) of DEV)))))) ) (VMEMSIZE (LAMBDA NIL (* bvm%: " 1-NOV-82 16:44") (fetch (IFPAGE NActivePages) of \InterfacePage))) ) (RPAQ? \M44MULTFLG T) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS UCASECHAR MACRO [(C) (COND ((ILESSP C (CHARCODE a)) C) (T (IDIFFERENCE C (IDIFFERENCE (CHARCODE a) (CHARCODE A]) (PUTPROPS UPDATEVALIDATION MACRO [(STREAM BUF) (replace VALIDATION of STREAM with (\MAKENUMBER (\GETBASE BUF 1) (\GETBASE BUF 3]) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS M44DEVICE ((DSKOBJ (fetch DEVICEINFO of DATUM) (replace DEVICEINFO of DATUM with NEWVALUE))) [TYPE? (AND (type? FDEV DATUM) (EQ (fetch OPENFILE of DATUM) '\M44OpenFile]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \OPENFILES \M44MULTFLG \DISKNAMECASEARRAY) ) (DECLARE%: EVAL@COMPILE (PUTPROPS .LISP.TO.BFS. MACRO (= . ADD1)) (PUTPROPS .BFS.TO.LISP. MACRO (= . SUB1)) (PUTPROPS .DISKCASEARRAY. MACRO [NIL (fetch (ARRAYP BASE) of (\DTEST \DISKNAMECASEARRAY 'ARRAYP]) ) (DECLARE%: EVAL@COMPILE (RPAQQ PageMapIncrement 64) (RPAQQ \MAX.ALTO.NAME.LENGTH 39) (CONSTANTS (PageMapIncrement 64) (\MAX.ALTO.NAME.LENGTH 39)) ) (* ;; "File properties") (DECLARE%: EVAL@COMPILE (BLOCKRECORD M44FILEPROP ((FPROPTYPE BYTE) (* ; "Type of property") (FPROPLENGTH BYTE) (* ; "Length of entire entry in words") (FPROPWORD0 WORD) (* ; "value starts here") ) (* ;  "Overlays a piece of leader page to describe a file property") ) ) (RPAQQ FPROPTYPES ((\FPROP.TYPE 136) (\FPROP.PAGEMAP 137))) (DECLARE%: EVAL@COMPILE (RPAQQ \FPROP.TYPE 136) (RPAQQ \FPROP.PAGEMAP 137) (CONSTANTS (\FPROP.TYPE 136) (\FPROP.PAGEMAP 137)) ) (RPAQQ FPTYPES ((\FPTYPE.UNKNOWN 0) (\FPTYPE.TEXT 1) (\FPTYPE.BINARY 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \FPTYPE.UNKNOWN 0) (RPAQQ \FPTYPE.TEXT 1) (RPAQQ \FPTYPE.BINARY 2) (CONSTANTS (\FPTYPE.UNKNOWN 0) (\FPTYPE.TEXT 1) (\FPTYPE.BINARY 2)) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\M44PAGEBUFFER 'RESOURCES '(NEW (NCREATE 'VMEMPAGEP] ) ) (/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL) ) (/SETTOPVAL '\\M44PAGEBUFFER.GLOBALRESOURCE NIL) (* ;; "Directory enumeration") (DEFINEQ (\M44GENERATEFILES (LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* bvm%: "12-Oct-85 15:13") (* ;; "Returns a file-generator object that will generate AT LEAST all files in the sys-dir of FDEV whose names match PATTERN. Clients might need to provide additional filtering. For M44, the generate state consists of the HOSTNAME (DSK) followed by a 'search state' , a directory pointer and a character list of the sort that \SEARCHDIR1 expects. DIRPTR is the position of the next file to be considered in the directory.") (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of FDEV)) (SORT? (EQMEMB (QUOTE SORT) OPTIONS)) (CASEBASE (.DISKCASEARRAY.)) (EXT (QUOTE *)) HOSTNAME NAME VERSION CHARLIST GENSTREAM FILTER DESIREDVERSION SEARCHSTATE HOSTPREFIX) (OR DIRSTREAM (RETURN (\NULLFILEGENERATOR))) (COND ((for TAIL on (UNPACKFILENAME.STRING PATTERN) by (CDDR TAIL) do (SELECTQ (CAR TAIL) (HOST (SETQ HOSTNAME (CADR TAIL))) (NAME (SETQ NAME (CADR TAIL))) (EXTENSION (SETQ EXT (CADR TAIL))) (VERSION (COND ((OR (EQ (NCHARS (SETQ VERSION (MKATOM (CADR TAIL)))) 0) (EQ VERSION 0)) (* ; "Newest version only") (SETQ SORT? T) (* ; "Can only get highest version by sorting") (SETQ VERSION NIL) (SETQ DESIREDVERSION T)) ((SMALLP VERSION) (* ; "An actual specific version to look for") (SETQ DESIREDVERSION VERSION)) ((NEQ VERSION (QUOTE *)) (* ; "Bogus version") (RETURN T)))) (RETURN T))) (* ; "Bad file name") (RETURN (\NULLFILEGENERATOR)))) (SETQ FILTER (DIRECTORY.MATCH.SETUP (CONCAT NAME (QUOTE %.) EXT ";*"))) (SETQ CHARLIST (for C instring (COND ((OR (EQ 0 (NCHARS EXT)) (EQ (CHCON1 EXT) (CHARCODE *))) NAME) (T (CONCAT NAME (QUOTE %.) EXT))) until (SELCHARQ (SETQ C (\GETBASEBYTE CASEBASE C)) ((%# *) (* ;; "\SEARCHDIR1 currently only checks prefixes, so we truncate at the first * or escape. Also ignore version specifications, because of the alternative representations of version 1") T) NIL) collect C)) (COND (DESIREDPROPS (* ; "Create a scratch stream for \M44FILEINFOFN to use") (SETQ GENSTREAM (create M44STREAM)) (replace DEVICE of GENSTREAM with FDEV))) (SETQ SEARCHSTATE (create M44DIRSEARCHSTATE DIRPTR _ 0 CHARLIST _ CHARLIST)) (SETQ HOSTPREFIX (CONCAT (QUOTE {) HOSTNAME (QUOTE }))) (RETURN (COND (SORT? (* ; "Have to generate the matching files first, sort them, then enumerate") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44SORTEDNEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ (\M44SORTFILES DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX (LENGTH CHARLIST)) GENVERSION _ DESIREDVERSION GENSTREAM _ GENSTREAM))) (T (* ; "Order not important") (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \M44NEXTFILEFN) FILEINFOFN _ (FUNCTION \M44FILEINFOFN) GENFILESTATE _ (create M44GENFILESTATE DIROFD _ DIRSTREAM SEARCHSTATE _ SEARCHSTATE GENFILTER _ FILTER GENVERSION _ DESIREDVERSION HOSTNAME _ HOSTPREFIX GENSTREAM _ GENSTREAM))))))) ) (\M44SORTFILES (LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH) (* bvm%: " 7-Jun-84 14:38") (SORT (bind FL while (SETQ FL (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH)) collect FL) (FUNCTION (LAMBDA (X Y) (SELECTQ (UALPHORDER (CAR X) (CAR Y)) (LESSP T) (EQUAL (IGREATERP (CADR X) (CADR Y))) NIL))))) ) (\M44GENERATENEXT [LAMBDA (DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH GENFILESTATE) (* ; "Edited 21-Jan-91 23:53 by jds") (* ;;; "Produces the next filename from directory DIRSTREAM satisfying SEARCHSTATE and the more constrained FILTER and DESIREDVERSION, or returns NIL if no more files. HOSTPREFIX is string to put on front, or NIL for names only. PATTERNLENGTH is the length of the pattern in SEARCHSTATE. GENFILESTATE is a a M44GENFILESTATE whose GENSTREAM and ENTRYSTART want to be set appropriately for \M44FILEINFOFN; if NIL, then the value is returned for SORTFILES in the form (name version entrystart)") (PROG ((PATTERNHASDOT (MEMB (CHARCODE %.) (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE))) SAWDOT ENTRYSTART TEMP PREFIXLEN TOTALLEN THISVERSION RESULT INDEX) LP (COND ((NOT (SETQ TEMP (\M44SEARCHDIR DIRSTREAM SEARCHSTATE))) (* ; "Enumeration finished") (RETURN NIL))) (SETQ SAWDOT PATTERNHASDOT) (SETQ ENTRYSTART (IDIFFERENCE (GETFILEPTR DIRSTREAM) (IPLUS PATTERNLENGTH 13))) (* ;  "Read all the characters from the directory") (SETQ TOTALLEN (IPLUS PATTERNLENGTH (SUB1 TEMP))) (for I from (SUB1 TEMP) to 1 by -1 do (* ;  "The SUB1 is because the last character is the undesired dot") (SELCHARQ (\BIN DIRSTREAM) (! [RETURN (SETQ THISVERSION (\M44READVERSION DIRSTREAM (SUB1 I]) (%. (SETQ SAWDOT T)) NIL) finally (SETQ THISVERSION 1)) (COND ((AND DESIREDVERSION (NEQ THISVERSION DESIREDVERSION) (NEQ DESIREDVERSION T)) (* ; "Failure, try next") (GO LP))) [SETQ RESULT (ALLOCSTRING (IPLUS TOTALLEN (SETQ PREFIXLEN (COND (HOSTPREFIX (NCHARS HOSTPREFIX )) (T 0))) (COND ((AND (EQ THISVERSION 1) HOSTPREFIX) 2) (T 0)) (COND (SAWDOT 0) (T 1] (AND HOSTPREFIX (RPLSTRING RESULT 1 HOSTPREFIX)) (\SETFILEPTR DIRSTREAM (IPLUS ENTRYSTART 13)) (* ; "Now read the whole name") (SETQ INDEX PREFIXLEN) (for I from TOTALLEN to 1 by -1 do (SELCHARQ (SETQ TEMP (\BIN DIRSTREAM)) (%. (SETQ SAWDOT T)) (! (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1) (CHARCODE %.))) (SETQ SAWDOT T) [COND (HOSTPREFIX (RPLCHARCODE RESULT (add INDEX 1) (CHARCODE ;)) (to (SUB1 I) do (RPLCHARCODE RESULT (add INDEX 1) (COND (GENFILESTATE (\BIN DIRSTREAM)) (T (* ;; "Make everything a constant version for benefit of SORT. Will replace with real thing later. The constant version is chosen in a way that makes 2-digit versions sort in front of 1-digit versions, etc, and single-digit versions come out as ;1 to match the ;1 inserted below") (IDIFFERENCE (CHARCODE 3) I] (RETURN)) NIL) (RPLCHARCODE RESULT (add INDEX 1) TEMP)) (OR SAWDOT (RPLCHARCODE RESULT (add INDEX 1) (CHARCODE %.))) (COND ((AND (EQ THISVERSION 1) HOSTPREFIX) (RPLSTRING RESULT (ADD1 INDEX) ";1"))) (COND ((AND FILTER (NOT (DIRECTORY.MATCH FILTER RESULT))) (GO LP))) (RETURN (COND (GENFILESTATE (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE with ENTRYSTART) (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE GENSTREAM) of GENFILESTATE) with NIL) RESULT) (T (LIST RESULT THISVERSION ENTRYSTART]) (\M44NEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 21-Jan-91 23:53 by jds") (* ;; "GENFILESTATE is the state information from the file-generator object created by \M44GENERATEFILES. This function returns the next file name as a string. Returns NIL if no files left. It updates GENFILESTATE so that it will get the following satisfactory file on the next call to this function. --- NAMEONLY => returns the filenames without the semi-colon and version number") (PROG ((DIRSTREAM (fetch (M44GENFILESTATE DIROFD) of GENFILESTATE)) (SEARCHSTATE (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE)) (DESIREDVERSION (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE)) (FILTER (fetch (M44GENFILESTATE GENFILTER) of GENFILESTATE)) (HOSTPREFIX (AND (NOT NAMEONLY) (fetch (M44GENFILESTATE HOSTNAME) of GENFILESTATE))) PATTERNLENGTH) (SETQ PATTERNLENGTH (LENGTH (fetch (M44DIRSEARCHSTATE CHARLIST) of SEARCHSTATE))) (RETURN (\M44GENERATENEXT DIRSTREAM SEARCHSTATE FILTER DESIREDVERSION HOSTPREFIX PATTERNLENGTH GENFILESTATE]) (\M44SORTEDNEXTFILEFN [LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 21-Jan-91 23:51 by jds") (LET ((FILES (fetch (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE)) THISFILE THISNAME V LEN) (COND ((SETQ THISFILE (CAR FILES)) (* ;  "THISFILE = (name version entryStart)") (SETQ THISNAME (CAR THISFILE)) (SETQ V (CADR THISFILE)) (* ;; "need to fill in the correct version number, since the names were generated with constant version number") (SETQ LEN (NCHARS THISNAME)) [COND [(ILESSP V 10) (* ; "Easy, 1-digit version") (\RPLCHARCODE THISNAME LEN (PLUS V (CHARCODE 0] (T (SETQ V (CHCON V)) (for C in V as I from [SETQ LEN (ADD1 (IDIFFERENCE LEN (LENGTH V] do (\RPLCHARCODE THISNAME I C] (replace (M44STREAM DIRINFO) of (fetch (M44GENFILESTATE GENSTREAM) of GENFILESTATE) with NIL) (replace (M44GENFILESTATE ENTRYSTART) of GENFILESTATE with (CADDR THISFILE)) (SETQ FILES (CDR FILES)) (COND ((EQ (fetch (M44GENFILESTATE GENVERSION) of GENFILESTATE) T) (bind (THISNAMEONLY _ (SUBSTRING THISNAME 1 (SUB1 LEN))) while (AND FILES (STRING-EQUAL (SUBSTRING (CAAR FILES) 1 (SUB1 LEN)) THISNAMEONLY)) do (SETQ FILES (CDR FILES))) FILES)) (replace (M44GENFILESTATE SEARCHSTATE) of GENFILESTATE with FILES) THISNAME]) (\M44FILEINFOFN [LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 21-Jan-91 23:51 by jds") (* ;;  "Retrieves info of file currently being enumerated. State has a directory pointer to help us out") (PROG ((STREAM (fetch (M44GENFILESTATE GENSTREAM) of GENFILESTATE))) (OR STREAM (RETURN)) (COND ((NULL (fetch (M44STREAM DIRINFO) of STREAM)) (replace VALIDATION of STREAM with (replace (M44STREAM FILEPAGEMAP) of STREAM with NIL)) (replace (M44STREAM DIRINFO) of STREAM with (fetch (M44GENFILESTATE ENTRYSTART) of GENFILESTATE)) (replace (M44STREAM FID) of STREAM with (\M44READDIRFID (fetch (M44GENFILESTATE DIROFD ) of GENFILESTATE ) (fetch (M44GENFILESTATE ENTRYSTART) of GENFILESTATE) (fetch (M44STREAM FID) of STREAM))) (\M44ReadLeaderPage STREAM T))) (RETURN (\M44GetFileInfo STREAM ATTRIBUTE]) ) (* ;; "Directory lookup routines") (DEFINEQ (\M44PARSEFILENAME [LAMBDA (X RECOG DEV CREATEFLG) (* ; "Edited 21-Jan-91 23:47 by jds") (* ;; "This returns a full file specification, with all the information needed to do open, delete, etc. A filespec is a (uname dirptr) pair, with the true version number smashed into the uname. The dirptr is NIL if the file does not currently exist in the directory.") (PROG ((DIRSTREAM (fetch (M44DEVICE SYSDIROFD) of DEV)) UNAME ENDNAMEOFFSET MAYBENEW EXPLICITVERSION FIXEDVERSION UCHARS SOMEPTR TLIST PTR NCHARSLEFT BESTVERSION BESTPTR VERS HMIN OLDESTP) [COND ([NULL (SETQ UNAME (\M44UNPACKFILENAME X DEV (SELECTQ RECOG ((NEW OLD/NEW) (* ;  "We might create a new file here, so tell unpack to save the original characters.") (SETQ MAYBENEW T)) NIL] (* ; "BAD FILE NAME") (RETURN (create FILESPEC UNAME _ NIL] (* ;; "Name parsed ok, get ready to search directory for it.") (SETQ UCHARS (fetch (UNAME UCASECHARS) of UNAME)) (SETQ ENDNAMEOFFSET (+ 13 (LENGTH UCHARS))) (* ; "ENDNAMEOFFSET is length of name we're searching for plus fixed overhead (header word, FID, name length byte)") [COND (CREATEFLG (* ; "Want to look for a hole, in case we need to create the file. The 6 is to allow for the maximum number of chars in a version number") (SETQ HMIN (FOLDLO (+ ENDNAMEOFFSET 6) BYTESPERWORD] (SETQ TLIST (CONS 0 UCHARS)) (* ;  "Pair of dirptr & chars used to communicate with \M44SEARCHDIR") (if (AND (FIXP (SETQ EXPLICITVERSION (fetch (UNAME VERSION) of UNAME))) (NEQ EXPLICITVERSION 0)) then (* ;  "If caller gave a real explicit version, then if we find that version, we know we're done.") (SETQ FIXEDVERSION EXPLICITVERSION)) (SETQ OLDESTP (EQ (OR EXPLICITVERSION RECOG) 'OLDEST)) SEARCHLP (COND ((NULL (SETQ NCHARSLEFT (\M44SEARCHDIR DIRSTREAM TLIST HMIN))) (* ; "No more prefix matches found") (GO DONE))) (SETQ PTR (\GETFILEPTR DIRSTREAM)) (* ; "Note current position") (COND ((EQ NCHARSLEFT 1) (* ;  "No version, just the final dot remains, so we must have matched version 1") (SETQ VERS 1)) ((NEQ (\BIN DIRSTREAM) (CHARCODE !)) (* ;  "More chars follow before version, so no match") (GO NEXT)) ([NULL (SETQ VERS (\M44READVERSION DIRSTREAM (- NCHARSLEFT 2] (GO NEXT))) (* ;; "Name matches. VERS is the version number. Is it better than we've seen? Accumulate extreme vers,ptr in BESTVERSION,BESTPTR.") (SETQ PTR (- PTR ENDNAMEOFFSET)) (* ;  "Beginning of the directory entry") (COND [FIXEDVERSION (* ; "Version must match") (SETQ BESTPTR PTR) (* ;  "Always note a pointer, for benefit of getting case right.") (COND ((EQ VERS FIXEDVERSION) (* ; "The one we've been looking for") (SETQ BESTVERSION VERS) (GO DONE] ((OR (NULL BESTVERSION) (if OLDESTP then (< VERS BESTVERSION) else (> VERS BESTVERSION))) (* ; "More extreme than the last one") (SETQ BESTVERSION VERS) (SETQ BESTPTR PTR))) NEXT (COND ((AND HMIN (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM)) (* ;  "Stop looking for a hole if found one") (SETQ HMIN NIL))) (GO SEARCHLP) DONE (* ;; "At this point, BESTVERSION is the version, if any, that best matches RECOG or funny version spec in UNAME, i.e., it is the oldest or newest version. BESTPTR is the corresponding directory pointer. In the case where an explicit version was requested but not found, BESTPTR is the directory pointer of SOME version. So now we need to bump the version up for RECOG = NEW, and maybe adjust the characters.") (SETQ SOMEPTR BESTPTR) (* ;  "Save dir pointer for getting at true chars for new files.") (if BESTVERSION then (* ; "Found one") (if (if EXPLICITVERSION then (* ; "Ignore funny version N when asking for %"OLD%" recognition--don't want FOO;N to mean next highest version, since that's a lie. e.g., it's not infilep.") (AND (EQ EXPLICITVERSION 'NEW) MAYBENEW) else (EQ RECOG 'NEW)) then (add BESTVERSION 1) (* ;  "Bump version, clear directory pointer (since we're creating)") (SETQ BESTPTR NIL)) elseif MAYBENEW then (* ;  "Specified file doesn't exist, but we're willing to create it") (SETQ BESTVERSION (OR FIXEDVERSION 1)) (SETQ BESTPTR NIL)) (RETURN (if BESTVERSION then (* ; "Success") (if (NULL BESTPTR) then (* ;  "New file. Get the case right if some other version existed.") (if SOMEPTR then (replace (UNAME ORIGCHARS) of UNAME with (\M44READDIRNAME DIRSTREAM SOMEPTR ))) elseif (fetch (UNAME ORIGCHARS) of UNAME) then (* ;  "New recog but existing file--happens when overwriting. Still want to get the characters right.") (replace (UNAME ORIGCHARS) of UNAME with (\M44READDIRNAME DIRSTREAM BESTPTR))) (replace (UNAME VERSION) of UNAME with BESTVERSION) (create FILESPEC UNAME _ UNAME FSDIRPTR _ BESTPTR]) (\FINDDIRHOLE [LAMBDA (NWORDS DIRSTREAM) (* ; "Edited 21-Jan-91 23:37 by jds") (* ;; "Returns the byte address of a directory hole of size NWORDS. The directory file is positioned just after the 2-byte length field of the hole.") (PROG ((HINT (fetch (M44STREAM DIRHOLEPTR) of DIRSTREAM)) PTR ENTRYLENGTH C) (SETQ PTR (OR HINT 0)) NEXT (\SETFILEPTR DIRSTREAM PTR) (COND ((\EOFP DIRSTREAM) (if (AND HINT (> HINT 0)) then (* ;  "Hint failed, so try from the start.") (SETQ HINT NIL) (SETQ PTR 0) (GO NEXT) else (GO END))) ((AND (>= (SETQ ENTRYLENGTH (+ (LLSH (LOGAND (SETQ C (\BIN DIRSTREAM)) 3) 8) (\BIN DIRSTREAM))) NWORDS) (< C 4)) (* ;; "First 6 bits is entry type, next 10 bits are length of entry in words. Free entries have type zero. Thus C < 4 implies this is free entry.") (\SETFILEPTR DIRSTREAM PTR) (* ; "Hole is large enough") [COND ((> ENTRYLENGTH NWORDS) (* ;  "Too large, so split hole into 2 parts. We'll return the second half of the hole.") (\WOUT DIRSTREAM (SETQ ENTRYLENGTH (- ENTRYLENGTH NWORDS))) (\SETFILEPTR DIRSTREAM (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD] (GO END))) (add PTR (UNFOLD ENTRYLENGTH BYTESPERWORD)) (GO NEXT) END (\WOUT DIRSTREAM NWORDS) (RETURN PTR]) (\M44PACKFILENAME (LAMBDA (UNAME DIRPTR DIRSTREAM) (* ; "Edited 12-Jan-88 12:01 by bvm") (* ;; "Produces a Lisp style file-name of the form 'name.[ext];ver'") (LET* ((CHARS (OR (AND (NULL *UPPER-CASE-FILE-NAMES*) (OR (fetch (UNAME ORIGCHARS) of UNAME) (if DIRPTR then (* ; "Get the exact name out of the directory") (\M44READDIRNAME DIRSTREAM DIRPTR)))) (fetch (UNAME UCASECHARS) of UNAME))) (NAME (CONCAT (QUOTE {) (fetch (UNAME PARTNAME) of UNAME) (QUOTE }) (CONCATCODES CHARS) (COND ((MEMB (CHARCODE %.) CHARS) ";") (T ".;")) (fetch (UNAME VERSION) of UNAME)))) (if *UPPER-CASE-FILE-NAMES* then (MKATOM NAME) else NAME))) ) (\M44READVERSION (LAMBDA (DIRSTREAM MAXCHARS) (* bvm%: " 7-Jun-84 11:38") (to MAXCHARS bind (VERSION _ 0) C do (SETQ C (\BIN DIRSTREAM)) (COND ((AND (IGEQ C (CHARCODE 0)) (ILEQ C (CHARCODE 9))) (SETQ VERSION (IPLUS (ITIMES VERSION 10) (IDIFFERENCE C (CHARCODE 0))))) (T (* ;; "A non-numeric after a ! means that it wasn't the version marker. This is permissible by alto file spec") (RETURN))) finally (RETURN VERSION))) ) (\OPENDISKDESCRIPTOR [LAMBDA (DEV) (* ; "Edited 21-Jan-91 23:43 by jds") (* ;; "Opens and returns a stream on the disk descriptor file for DEV") [COND ((NOT (type? FDEV DEV)) (SETQ DEV (\GETDEVICEFROMNAME (fetch (DSKOBJ DISKDEVICENAME) of DEV] (OR (fetch (M44DEVICE DDVALID) of DEV) (PROG ((OLDD (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV)) STREAM) (COND (OLDD (FORGETPAGES OLDD))) [SETQ STREAM (COND ((EQ (fetch (M44DEVICE DSKOBJ) of DEV) \MAINDISK) (\M44OPENFILEFROMFP DEV "DISKDESCRIPTOR.;1" 'BOTH (  \CREATE.FID.FOR.DD DEV))) (T (\OPENFILE (CONCAT "{" (fetch (FDEV DEVICENAME) of DEV) "}" "DISKDESCRIPTOR.;1") 'BOTH] (replace USERVISIBLE of STREAM with NIL) (replace (M44DEVICE DISKDESCRIPTOROFD) of DEV with STREAM) (replace MAXBUFFERS of STREAM with (ADD1 (fetch EPAGE of STREAM))) (* ;  "Prepare to buffer the whole file, so that we don't get in trouble under \NEWPAGE") (for I from 0 to (fetch EPAGE of STREAM) do (\MAPPAGE I STREAM)) (* ;  "Ought to define a \MAPPAGES to do that more efficiently") (replace ENDOFSTREAMOP of STREAM with (FUNCTION NILL)) (replace (M44DEVICE DDVALID) of DEV with T))) (fetch (M44DEVICE DISKDESCRIPTOROFD) of DEV]) (\M44READDIRFID [LAMBDA (DIRSTREAM DIRPTR FID) (* ; "Edited 21-Jan-91 23:39 by jds") (* ;; "Read the 5-word FID from the directory into FID (or create a new one if FID is nil). Return the new FID.") (\SETFILEPTR DIRSTREAM (+ DIRPTR 2)) (\BINS DIRSTREAM [fetch (FID FIDBLOCK) of (OR FID (SETQ FID (create FID] 0 (UNFOLD 5 BYTESPERWORD)) FID]) (\M44READDIRNAME (LAMBDA (DIRSTREAM DIRPTR) (* ; "Edited 11-Jan-88 14:39 by bvm") (* ;; "Read the exact file name, sans version number, from directory stream as a list of char codes.") (* ;; "Format of a directory entry is --- Type&WordLength (1 word), FP (5 words), Name as a BcplString") (SETFILEPTR DIRSTREAM (+ DIRPTR 12)) (to (SUB1 (BIN DIRSTREAM)) bind CH until (EQ (SETQ CH (BIN DIRSTREAM)) (CHARCODE !)) collect CH)) ) (\M44SEARCHDIR [LAMBDA (STREAM TLIST HMIN) (* ; "Edited 21-Jan-91 23:37 by jds") (* ;; "TLIST is a list of the form (POS . NAMECHARS), where POS at entry is a fileptr in the directory file at which to start searching and NAMECHARS is like the characters pairs of a uname. Finds next directory entry for which NAMECHARS is a prefix of the filename. Returns NIL if no entry found, else the length of the remaining chars in the entry. Leaves the directory positioned after the char matching the last char of NAMECHARS --- STREAM is the ofd of the directory file --- At exit, TLIST is smashed so that POS is the fileptr just beyond the found entry. --- if HMIN~=NIL, sets STREAM's DIRHOLEPTR to NIL or the fileptr of the first hole of at least HMIN words.") (PROG ((CASEBASE (.DISKCASEARRAY.)) (NEXT (CAR TLIST)) (NAMECHARS (CDR TLIST)) THISNAMELENGTH TARGETLENGTH PTR L TYP ENTRYLENGTH) (COND (HMIN (replace (M44STREAM DIRHOLEPTR) of STREAM with NIL))) (SETQ TARGETLENGTH (LENGTH NAMECHARS)) NEXT (\SETFILEPTR STREAM (SETQ PTR NEXT)) (COND ((\EOFP STREAM) (RETURN))) (* ;; "Format of a directory entry is --- Type (0 = hole, 1 = file), 6 bits --- Length of entry in words, 10 bits --- FP 5 words --- Name as a BcplString") (SETQ TYP (\BIN STREAM)) (SETQ ENTRYLENGTH (IPLUS (LLSH (LOGAND TYP 3) 8) (\BIN STREAM))) (SETQ NEXT (IPLUS (UNFOLD ENTRYLENGTH BYTESPERWORD) PTR)) (COND ((NEQ (LRSH TYP 2) 1) (* ; "Not a file") (COND ((AND HMIN (NOT (IGREATERP HMIN ENTRYLENGTH))) (replace (M44STREAM DIRHOLEPTR) of STREAM with PTR) (SETQ HMIN NIL))) (GO NEXT))) (\SETFILEPTR STREAM (IPLUS PTR 12)) (COND ((ILESSP (SETQ THISNAMELENGTH (\BIN STREAM)) TARGETLENGTH) (GO NEXT))) (SETQ L NAMECHARS) READ (COND ((NULL L) (* ;  "Exhausted the pattern before finding a mismatch, so take it") (RPLACA TLIST NEXT) (RETURN (IDIFFERENCE THISNAMELENGTH TARGETLENGTH))) ((EQ (\GETBASEBYTE CASEBASE (\BIN STREAM)) (CAR L)) (SETQ L (CDR L)) (GO READ)) (T (GO NEXT]) (\M44UNPACKFILENAME [LAMBDA (NAME DEV CREATEFLG) (* ; "Edited 21-Jan-91 23:47 by jds") (* ;; "Unpacks file name into a UNAME whose VERSION is the version indicator (either a positive integer or one of OLD, OLDEST, NEW); PARTNAME is the name of DEV. UCASECHARS is a list of uppercase charcodes from the name. If CREATEFLG is true, also sets ORIGCHARS to be list of original char codes, for sake of setting real file name") (PROG ((CASEBASE (.DISKCASEARRAY.)) (NC 0) J C UPC END ORIGEND VERSION RESULT DOTPREV ORIGDOTPREV EXCESS TAIL) (COND ((OR (NOT NAME) (EQ NAME T) (NOT (OR (LITATOM NAME) (STRINGP NAME))) (NEQ (NTHCHARCODE NAME 1) (CHARCODE {)) (NOT (SETQ J (STRPOS "}" NAME 5))) (EQ (NTHCHARCODE NAME (add J 1)) (CHARCODE <))) (* ;; "Name is not a non-null string/atom, or doesn't have a host on front, or { is mismatched, or there's a directory. There used to be some junk in here about passing back a different value if the name had a directory than if it was otherwise malformed, but we really have no use for that.") (RETURN NIL))) [SETQ END (fetch (UNAME UCASECHARHEAD) of (SETQ RESULT (create UNAME PARTNAME _ (fetch DEVICENAME of DEV] (* ;  "End is the cell whose CDR can be smashed.") (SETQ ORIGEND (fetch (UNAME ORIGCHARHEAD) of RESULT)) COLLECTNAME (COND ((NOT (SETQ C (NTHCHARCODE NAME J))) (* ; "End of name") (GO RET)) ((EQ (SETQ UPC (\GETBASEBYTE CASEBASE C)) 0) (* ; "Illegal char") (GO ERR)) (T [RPLACD END (SETQ END (LIST (SELCHARQ UPC (; (GO SEMI)) ((%# *) (* ; "Wildcards not allowed") (GO ERR)) (%. (* ; "Omit trailing dots") (PROG1 (SELCHARQ (NTHCHARCODE NAME (ADD1 J)) (NIL (GO RET)) ((; !) (add J 1) (GO SEMI)) UPC) (SETQ DOTPREV END) (* ;  "Save tail position here in case name gets long") (AND CREATEFLG (SETQ ORIGDOTPREV ORIGEND)))) UPC] [COND (CREATEFLG (* ; "Save orig chars as well") (RPLACD ORIGEND (SETQ ORIGEND (LIST C] (add J 1) (add NC 1) (GO COLLECTNAME))) SEMI (* ;; "Parsing the stuff after the semicolon; we only accept version, though we do accept the funny symbolic versions H, L and N.") (COND ([NULL (SETQ C (NTHCHARCODE NAME (add J 1] (GO RET)) ((EQ (SETQ C (\GETBASEBYTE CASEBASE C)) 0) (* ; "Illegal char") (GO ERR))) (SELCHARQ C (H (SETQQ VERSION OLD)) (L (SETQQ VERSION OLDEST)) (N (SETQQ VERSION NEW)) (GO COLLECTVERSION)) (if (EQ J (NCHARS NAME)) then (* ; "Done") (GO RET) else (* ; "Malformed name") (GO ERR)) COLLECTVERSION (SETQ VERSION 0) [while (AND C (BETWEEN C (CHARCODE 0) (CHARCODE 9))) do [SETQ VERSION (+ (TIMES VERSION 10) (- C (CHARCODE 0] (SETQ C (NTHCHARCODE NAME (add J 1] (COND ((EQ VERSION 0) (SETQQ VERSION OLD)) ((IGREATERP VERSION 65535) (GO ERR))) (if (NULL C) then (* ; "end of name ok") (GO RET)) ERR (* ; "BAD FILE NAME") (RETURN NIL) RET (replace (UNAME VERSION) of RESULT with VERSION) [if (> (SETQ EXCESS (- NC (- \MAX.ALTO.NAME.LENGTH 7))) 0) then (* ;; "Hmm, is name too long? 7 counts for a possible !, 5 version chars and the final dot. This is unnecessarily restrictive for names with shorter versions, but it would get quite untidy if you let version 9 squeak in and then complain or shorten on 10. So best to shorten now. We prefer to leave the extension intact, since that can convey info, and shorten the name.") [if DOTPREV then (SETQ DOTPREV (CDR DOTPREV)) (* ; "Now (CAR DOTPREV) is the period") (SETQ ORIGDOTPREV (CDR ORIGDOTPREV)) (if (CDR (SETQ TAIL (CL:NTHCDR 10 DOTPREV))) then (* ;  "Extension longer than 10 chars (this allows, e.g., INTERPRESS), so let's shorten it.") (if (<= (SETQ NC (LENGTH (CDR TAIL))) EXCESS) then (* ; "Chop off the entire excess") (RPLACD TAIL NIL) (if CREATEFLG then (RPLACD (CL:NTHCDR 10 ORIGDOTPREV) NIL)) (SETQ EXCESS (- EXCESS NC)) else (* ; "only have to get rid of some") (RPLACD (CL:NTHCDR (- NC EXCESS) TAIL) NIL) (if CREATEFLG then (RPLACD (CL:NTHCDR (+ 10 (- NC EXCESS)) ORIGDOTPREV) NIL)) (SETQ EXCESS 0] (if (> EXCESS 0) then (* ; "Chop away at name") (RPLACD (NLEFT (fetch (UNAME UCASECHARS) of RESULT) (ADD1 EXCESS) DOTPREV) DOTPREV) (if CREATEFLG then (RPLACD (NLEFT (fetch (UNAME ORIGCHARS) of RESULT) (ADD1 EXCESS) ORIGDOTPREV) ORIGDOTPREV] (RETURN RESULT]) ) (RPAQQ \FILENAMECHARSLST (36 43 45 46)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FILENAMECHARSLST) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD UNAME (VERSION . UCASECHARHEAD) (RECORD UCASECHARHEAD (ORIGCHARHEAD . UCASECHARS) (RECORD ORIGCHARHEAD (PARTNAME . ORIGCHARS)))) (RECORD FILESPEC (UNAME FSDIRPTR) [ACCESSFNS FILESPEC ((PNAME (\M44PACKFILENAME (fetch UNAME of DATUM]) (RECORD M44GENFILESTATE (DIROFD SEARCHSTATE GENFILTER GENVERSION HOSTNAME GENSTREAM ENTRYSTART)) (RECORD M44DIRSEARCHSTATE (DIRPTR . CHARLIST)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS BETWEEN MACRO (OPENLAMBDA (V LO HI) (AND (IGEQ V LO) (ILEQ V HI)))) ) ) (DEFINEQ (\CREATE.FID.FOR.DD [LAMBDA (FDEV) (* ; "Edited 21-Jan-91 23:39 by jds") (* ;; "Creates a FID for the file DISKDESCRIPTOR on FDEV, which must be the default disk partition's device") (PROG ((FID (create FID))) (* ;; "Currently \SYSDISK has a copy of the diskdescriptor fp inside it, as looked up by alto at beginning of world, so be lazy and use that") (\BLT (fetch (FID FIDBLOCK) of FID) (LOCF (fetch (M44DEVICE DSKDDBLK) of FDEV)) \LENFP) (RETURN FID]) (\OPENDISK [LAMBDA (PARTNUM FDEV) (* ; "Edited 21-Jan-91 23:32 by jds") (PROG (DSK DD) (OR (\TESTPARTITION PARTNUM) (RETURN)) (SETQ DSK (create DSKOBJ)) (\LOCKWORDS DSK \NWORDS.DSKOBJ) (replace (DSKOBJ DSKPARTITION) of DSK with PARTNUM) (replace (DSKOBJ ddPOINTER) of DSK with (LOCF (fetch (DSKOBJ ddLASTSERIAL#) of DSK))) (replace (DSKOBJ NDISKS) of DSK with 2) (replace (DSKOBJ NTRACKS) of DSK with 406) (replace (DSKOBJ NHEADS) of DSK with 2) (replace (DSKOBJ NSECTORS) of DSK with 14) (replace (DSKOBJ RETRYCOUNT) of DSK with 8) (replace (DSKOBJ CBQUEUE) of DSK with (fetch (DSKOBJ CBQUEUE) of \MAINDISK )) (* ; "Really should have our own") (RETURN (\OPENDISKDEVICE PARTNUM DSK FDEV]) (\OPENDISKDEVICE [LAMBDA (PARTITION DSKOBJ FDEV) (* ; "Edited 21-Jan-91 23:43 by jds") (DECLARE (GLOBALVARS \MAINDISK)) (* ;  "Creates the model 44 DSK device and opens its SYSDIR.") (PROG ([NAME (PACK* 'DSK (OR PARTITION (DISKPARTITION] FDEV) [OR FDEV (SETQ FDEV (\MAKE.PMAP.DEVICE (create FDEV DEVICENAME _ NAME NODIRECTORIES _ T CLOSEFILE _ (FUNCTION \M44CloseFile) DELETEFILE _ (FUNCTION \M44DeleteFile) GETFILEINFO _ (FUNCTION \M44GetFileInfo) GETFILENAME _ (FUNCTION \M44GetFileName) OPENFILE _ (FUNCTION \M44OpenFile) READPAGES _ (FUNCTION \M44ReadPages) SETFILEINFO _ (FUNCTION \M44SetFileInfo) TRUNCATEFILE _ (FUNCTION \M44TruncateFile) WRITEPAGES _ (FUNCTION \M44WritePages) REOPENFILE _ (FUNCTION \M44OpenFile) GENERATEFILES _ (FUNCTION \M44GENERATEFILES) EVENTFN _ (FUNCTION \M44EVENTFN) DIRECTORYNAMEP _ [FUNCTION (LAMBDA (NAME) (* ;  "Assume host is OK, check that no directory") (EQ (NTHCHARCODE NAME -1) (CHARCODE }] HOSTNAMEP _ (FUNCTION NILL) FREEPAGECOUNT _ (FUNCTION \M44FREEPAGECOUNT) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM] (replace (M44DEVICE DSKOBJ) of FDEV with (OR DSKOBJ (SETQ DSKOBJ \MAINDISK))) (replace (DSKOBJ DISKDEVICENAME) of DSKOBJ with NAME) (RETURN (RESETLST (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (DEV) (COND ((NOT (fetch (M44DEVICE DSKPASSWORDOK) of DEV)) (* ;  "Oops, it didn't work, take it away") (\REMOVEDEVICE DEV] FDEV)) (\DEFINEDEVICE NAME FDEV) (* ;  "have to define it tentatively first so that \OPENDISKDESCRIPTOR will work") (COND ((\OPENDIR FDEV) (COND ((NULL PARTITION) (* ; "this is also the default disk") (\DEFINEDEVICE 'DSK FDEV))) FDEV)))]) (\OPENDIR (LAMBDA (FDEV) (* bvm%: " 6-APR-83 12:16") (* ;; "Opens the model44 directory on the current partition") (PROG ((PART (fetch (M44DEVICE DSKPARTITION) of FDEV)) STREAM DD) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with NIL) (COND ((AND (NEQ PART 0) (NOT (\TESTPARTITION PART))) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))) (SETQ STREAM (\M44OPENFILEFROMFP FDEV "SYSDIR.;1" (QUOTE BOTH) (create FID W0 _ 32768 W1 _ 100 W2 _ 1 W3 _ 0 W4 _ 1))) (* ; "{DSK}SYSDIR.;1 always has sn 100, leader page on virtual page 1") (replace MAXBUFFERS of STREAM with (IMAX 64 (ADD1 (fetch EPAGE of STREAM)))) (* ; "Enough buffers so that directory is effectively always in core") (replace (M44DEVICE SYSDIROFD) of FDEV with STREAM) (COND ((NEQ PART 0) (SETQ DD (\OPENDISKDESCRIPTOR FDEV)) (\SETFILEPTR DD \OFFSET.DISKLASTSERIAL#) (\BINS DD (LOCF (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV)) 0 \NBYTES.DISKINFO) (add (fetch (M44DEVICE DISKLASTSERIAL#) of FDEV) 3) (* ; "Try to avoid collisions") (COND ((NOT (\M44CHECKPASSWORD FDEV)) (replace (M44DEVICE SYSDIROFD) of FDEV with NIL) (RETURN))))) (replace (M44DEVICE DSKPASSWORDOK) of FDEV with T) (RETURN STREAM))) ) (\M44CHECKPASSWORD (LAMBDA (DEV) (* bvm%: "11-Jun-86 12:20") (PROG ((STREAM (\OPENFILE (PACK* (QUOTE {) (fetch (FDEV DEVICENAME) of DEV) "}SYS.BOOT;1") (QUOTE INPUT) (QUOTE OLD))) PASSVECTOR BUF PASSINFO ASKEDONCE NAME N) (COND ((NULL STREAM) (RETURN T))) (SETQ PASSVECTOR (\ALLOCBLOCK (FOLDHI \NWORDS.BCPLPASSWORD WORDSPERCELL))) (SETFILEPTR STREAM \OFFSET.BCPLPASSWORD) (\BINS STREAM PASSVECTOR 0 (UNFOLD \NWORDS.BCPLPASSWORD BYTESPERWORD)) (COND ((EQ (\GETBASE PASSVECTOR 0) 0) (* ; "No password") (\CLOSEFILE STREAM) (RETURN T))) (SETFILEPTR STREAM \OFFSET.BCPLUSERNAME) (SETQ NAME (ALLOCSTRING (SETQ N (\BIN STREAM)))) (* ; "Read in a bcpl string which is the username installed on the disk") (\BINS STREAM (fetch (STRINGP BASE) of NAME) 0 N) (\CLOSEFILE STREAM) (SETQ NAME (MKATOM NAME)) LP (SETQ PASSINFO (\INTERNAL/GETPASSWORD (fetch (FDEV DEVICENAME) of DEV) ASKEDONCE NIL NIL NAME)) (COND ((NULL PASSINFO) (RETURN NIL))) (COND ((UNINTERRUPTABLY (SETQ BUF (\GETPACKETBUFFER)) (* ; "HORRIBLE CHEAP TRICK to get some emulator space") (\BLT (\ADDBASE BUF 64) PASSVECTOR \NWORDS.BCPLPASSWORD) (SetBcplString (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\DECRYPT.PWD (CDR PASSINFO))) (\CHECKBCPLPASSWORD (\ADDBASE BUF (IPLUS 64 \NWORDS.BCPLPASSWORD)) (\ADDBASE BUF 64))) (RETURN T)) (T (SETQ ASKEDONCE T) (GO LP))))) ) (\M44HOSTNAMEP (LAMBDA (NAME DEV) (* bvm%: "20-Nov-84 16:06") (PROG (PARTNUM) (RETURN (COND ((EQ NAME (QUOTE DSK)) (\OPENDISKDEVICE)) ((AND (STRPOS (QUOTE DSK) NAME 1 NIL T) (SETQ PARTNUM (FIXP (SUBATOM NAME 4))) (\TESTPARTITION PARTNUM)) (COND ((EQ PARTNUM (DISKPARTITION)) (RETURN (\GETDEVICEFROMNAME (QUOTE DSK)))) (T (\OPENDISK PARTNUM)))))))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \OFFSET.BCPLUSERNAME 512) (RPAQQ \OFFSET.BCPLPASSWORD 768) (RPAQQ \NWORDS.BCPLPASSWORD 9) (CONSTANTS \OFFSET.BCPLUSERNAME \OFFSET.BCPLPASSWORD \NWORDS.BCPLPASSWORD) ) ) (* ;; "SYSOUT etc.") (DEFINEQ (\COPYSYS (LAMBDA (FILE SYSNAME DONTSAVE) (DECLARE (GLOBALVARS SYSOUTCURSOR \VMEM.INHIBIT.WRITE IDLE.PROFILE)) (* ; "Edited 1-Apr-90 16:27 by nm") (PROG (FULLNAME VAL HOST) RETRY (RECLAIM) (RETURN (COND ((NULL (SETQ VAL (OR (COND ((NOT DONTSAVE) (* ; "Make vmem consistent on disk (like SAVEVM)") (COND (\VMEM.INHIBIT.WRITE (* ; "Force this to NIL, in case someone accidentally got it set to T") (PROMPTPRINT "***WARNING: VMEM.INHIBIT.WRITE was true; setting it to NIL now.") (SETQ \VMEM.INHIBIT.WRITE NIL))) (SETQ FILE (\ADD.CONNECTED.DIR FILE)) (SELECTQ (MACHINETYPE) (MAIKO (SELECTQ (SETQ HOST (U-CASE (FILENAMEFIELD FILE (QUOTE HOST)))) (DSK (* ; "OPENSTREAM with file attributes is not available on DSK and UNIX, so check is done by \DOFLUSHVM ") (* ;; "If \MAIKO.SYSOUTNAME is non NIL, image is saved by \FLUSHVM, no need to copy") (\FLUSHVM (SETQ FULLNAME (CONCAT "{" HOST "}" (\UFS.RECOGNIZE.FILE FILE (QUOTE NON) (\GETDEVICEFROMNAME HOST)))))) (UNIX (* ; "OPENSTREAM with file attributes is not available on DSK and UNIX, so check is done by \DOFLUSHVM ") (* ;; "If \MAIKO.SYSOUTNAME is non NIL, image is saved by \FLUSHVM, no need to copy") (\FLUSHVM (SETQ FULLNAME (CONCAT "{" HOST "}" (\UFS.RECOGNIZE.FILE FILE (QUOTE NON) (\GETDEVICEFROMNAME HOST)))))) (RESETLST (PROG1 (\FLUSHVM) (RESETSAVE (CURSOR (COND ((type? CURSOR SYSOUTCURSOR) SYSOUTCURSOR) (T T)))) (LET ((UNIXVAR (UNIX-GETENV "LDEDESTSYSOUT"))) (* ; "\FLSUVM saves image to Unix enviroment var or lisp.virtualmem") (SETQ FULLNAME (COPYFILE (COND (UNIXVAR (CONCAT "{DSK}" UNIXVAR)) (T "{DSK}~/lisp.virtualmem")) FILE (QUOTE ((TYPE BINARY)))))))))) (\FLUSHVM)))) (CL:UNWIND-PROTECT (COND ((EQ \MACHINETYPE \MAIKO) NIL) (T (PROGN (SETQ \VMEM.INHIBIT.WRITE T) (* ; "Prevent dirty pages from being written after the \FLUSHVM") (RESETLST (LET ((LASTPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)) STREAM) (* ; "Note length of sysout now, because NActivePages can grow as we prepare to write the sysout") (SETQ STREAM (OPENSTREAM FILE (QUOTE OUTPUT) (QUOTE NEW) NIL (BQUOTE ((LENGTH (\, (UNFOLD LASTPAGE BYTESPERPAGE))) (SEQUENTIAL T) (TYPE BINARY))))) (SETQ FULLNAME (fetch (STREAM FULLNAME) of STREAM)) (RESETSAVE NIL (LIST (FUNCTION (LAMBDA (FILE) (CLOSEF FILE) (AND RESETSTATE (DELFILE (fetch (STREAM FULLNAME) of FILE))))) STREAM)) (COND (SYSNAME (SET SYSNAME FULLNAME))) (RESETSAVE (CURSOR (COND ((type? CURSOR SYSOUTCURSOR) (* ; "Comes from a later file") SYSOUTCURSOR) (T T)))) (RESETSAVE IDLE.PROFILE NIL) (* ; "Disable idler") (\COPYSYS1 STREAM LASTPAGE)))))) (* ;; "For cleanup, set \vmem.inhibit.write back to NIL. This is done as its own cleanup so that impatiently aborting a sysout with repeated ^E will be less likely to miss this restoration.") (SETQ \VMEM.INHIBIT.WRITE NIL))))) (* ;; "First clause of OR is T when resuming this vmem; second is starting the sysout. Unless \COPYSYS1 itself does a \FLUSHVM, the second never returns T, yes? NIL is normal return (continuing in same image), is error return") (* ; "Continuing in the current image") (\DAYTIME0 \LASTUSERACTION) FULLNAME) ((AND (SMALLP VAL) (IGREATERP 0 VAL)) (* ; "Error occurred while making sysout.") (LISPERROR (IMINUS VAL) FULLNAME) (GO RETRY)) (T (* ; "Starting sysout") (\CLEARSYSBUF T) (* ; "Get rid of any spurious typeahead") (\RESETKEYBOARD) (* ; "Enable keyhandler") (LIST FULLNAME)))))) ) (\COPYSYS1 (LAMBDA (STREAM LASTPAGE) (* ; "Edited 21-Aug-88 13:54 by bvm") (COND ((AND (type? M44DEVICE (fetch DEVICE of STREAM)) (EQ (fetch DEVICENAME of (fetch DEVICE of STREAM)) (QUOTE DSK))) (ERROR "Sysout to Dorado login partition no longer supported."))) (PROG ((ACTONVMEMFN \VMEMACCESSFN) (PAGEMAPPED (fetch PAGEMAPPED of (fetch DEVICE of STREAM))) (NBUFS (SUB1 \#EMUBUFFERS)) (BUFBASE \EMUBUFFERS) (FIRSTPAGE 2) (CURSORBAR \EM.CURSORBITMAP) (CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))) (DOMINOPAGE (fetch LastDominoFilePage of \InterfacePage)) (DAYBREAKP (EQ \MACHINETYPE \DAYBREAK)) CURSORINC CURSORNEXT NPAGES BUFFERS) (* ;; "Strategy is to copy from the vmem file to STREAM --- The vmem file is read with \ACTONVMEMFILE to finesse the differences among machines. As buffers we use the set of pre-allocated swap buffers, reducing the number available for swapping to a bare minimum of one. If STREAM is pagemapped, we take advantage of knowledge of pagemapped streams to write these buffers directly to the destination stream, which saves the copying that would occur if we just generically used \BOUTS for all streams. In the case of Mod44 DSK, this also lets us use more buffers at a time, because DSK can write directly from the buffers we use for reading the vmem, rather than copying into its own buffers") (RESETSAVE \#SWAPBUFFERS 1) (* ; "Reduce us to one swap buffer, so we can use the rest for copying the vmem") (RESETSAVE \EMUSWAPBUFFERS (\ADDBASE BUFBASE (UNFOLD NBUFS WORDSPERPAGE))) (RESETSAVE \#DISKBUFFERS (COND ((type? M44DEVICE (fetch DEVICE of STREAM)) (* ; "DSK code needs 1 extra buffer beyond the ones we give to \WRITEPAGES") (SETQ NBUFS (SUB1 NBUFS)) (SETQ BUFBASE (\ADDBASE BUFBASE WORDSPERPAGE)) 1) (T 0))) (SETQ BUFFERS (to NBUFS as (BUF _ BUFBASE) by (\ADDBASE BUF WORDSPERPAGE) collect BUF)) (SETQ CURSORINC (SETQ CURSORNEXT (FOLDLO LASTPAGE (ITIMES 16 16)))) (* ; "How often to do something to the cursor") (COND ((EQ DOMINOPAGE 0) (* ; "First page to write is the ISF map page, which should be blank in a sysout") (\CLEARWORDS BUFBASE WORDSPERPAGE)) (T (CL:FUNCALL ACTONVMEMFN DOMINOPAGE BUFBASE 1))) (COND (PAGEMAPPED (replace EPAGE of STREAM with LASTPAGE) (* ; "Set up end of file correctly. LASTPAGE is last alto page (full), which is last Lisp page plus 1") (replace EOFFSET of STREAM with 0) (\WRITEPAGES STREAM 0 (CAR BUFFERS))) (T (\BOUTS STREAM (CAR BUFFERS) 0 BYTESPERPAGE))) (while (<= FIRSTPAGE LASTPAGE) do (COND ((>= FIRSTPAGE CURSORNEXT) (* ; "Gradually complement the cursor") (\PUTBASE CURSORBAR 0 (LOGXOR (\GETBASE CURSORBAR 0) CURSORMASK)) (COND (DAYBREAKP (\DoveDisplay.SetCursorShape))) (add CURSORNEXT CURSORINC) (COND ((EQ (SETQ CURSORMASK (LRSH CURSORMASK 1)) 0) (SETQ CURSORBAR (\ADDBASE CURSORBAR 1)) (SETQ CURSORMASK (LLSH 1 (SUB1 BITSPERWORD))))))) (CL:FUNCALL ACTONVMEMFN FIRSTPAGE BUFBASE (SETQ NPAGES (IMIN NBUFS (ADD1 (- LASTPAGE FIRSTPAGE))))) (* ; "Read NBUFS pages from vmem, then write them to output") (COND ((NOT PAGEMAPPED) (* ; "Have to just ship the bits") (\BOUTS STREAM BUFBASE 0 (UNFOLD NPAGES BYTESPERPAGE))) (T (\WRITEPAGES STREAM (SUB1 FIRSTPAGE) (COND ((< NPAGES NBUFS) BUFFERS) (T (* ; "Don't write too many pages on the last pass if NPAGES is less than length of BUFFERS") (to NPAGES as BUF in BUFFERS collect BUF)))))) (add FIRSTPAGE NPAGES)) (RETURN NIL))) ) ) (* ;; "For MAIKO. \COPYSYS use UNIX-PAGEPERBLOCK.") (DEFINEQ (\MAIKO.CHECKFREESPACE (LAMBDA (FILENAME) (* ; "Edited 1-Apr-90 18:24 by nm") (DECLARE (GLOBALVARS \LDEDESTOVERWRITE \DSKdevice)) (LET ((LASTPAGE (fetch (IFPAGE NActivePages) of \InterfacePage)) (BUFFER (CREATECELL \FIXP)) FULLNAME FILESIZE FREEPAGES HOST) (* ;; "FULLNAME is UNIX/DSK format pathname with UNIX/DSK. And type is string.") (SETQ FULLNAME (if (NULL FILENAME) then (SETQ HOST (QUOTE DSK)) (\UFS.RECOGNIZE.FILE (CONCAT "{" HOST "}" (OR (UNIX-GETENV "LDEDESTSYSOUT") "~/lisp.virtualmem")) (QUOTE NON) (\GETDEVICEFROMNAME HOST)) else (SETQ HOST (U-CASE (FILENAMEFIELD FILENAME (QUOTE HOST)))) (\UFS.RECOGNIZE.FILE FILENAME (QUOTE NON) (\GETDEVICEFROMNAME HOST)))) (SETQ FULLNAME (CONCAT "{" HOST "}" FULLNAME)) (* ;; "get current free space") (OR (\UFSGetFreeBlock-C FULLNAME BUFFER) (LISPERROR "FILE NOT FOUND" FULLNAME)) (if (IGREATERP LASTPAGE (SETQ FREEPAGES (ITIMES BUFFER LISPPAGE-PER-UNIXBLOCK))) then (* ;; "not enough free space ") (if \LDEDESTOVERWRITE then (* ;; "if possible, try to overwrite") (OR (INFILEP FULLNAME) (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME)) (* ;; "file exist, check file size") (SETQ FILESIZE (GETFILEINFO FULLNAME (QUOTE SIZE))) (if (IGREATERP LASTPAGE (IPLUS FILESIZE FREEPAGES)) then (* ;; "also, not ehough space") (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME) else (* ;; "Remove file, then get enoght space to save") (DELFILE FULLNAME)) else (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME FULLNAME))))) ) ) (RPAQ? \LDEDESTOVERWRITE NIL) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ LISPPAGE-PER-UNIXBLOCK 2) (CONSTANTS (LISPPAGE-PER-UNIXBLOCK 2)) ) ) (* ;; "Stats code. On MOD44IO because it writes on the disk and uses records not exported from MOD44IO. (For this and other reasons, GATHERSTATS only works on Dorados.)" ) (DEFINEQ (GATHERSTATS [LAMBDA (FILENAME) (* ; "Edited 21-Jan-91 23:33 by jds") (* ;; "Enables and disables statistics gathering. Uses low level file operations to avoid stats file being visible from Lisp b/c the file position is not updated as it is written") (DECLARE (GLOBALVARS \STATSON)) (COND ((NEQ \MACHINETYPE \DORADO) (ERROR "Stats not implemented for this type of machine" FILENAME)) [FILENAME (AND \STATSON (GATHERSTATS)) (SELECTQ (FILENAMEFIELD FILENAME 'HOST) (DSK) (NIL (SETQ FILENAME (PACKFILENAME.STRING 'HOST 'DSK 'BODY FILENAME))) (ERROR "Stats file must be on DSK" FILENAME)) (SETQ \STATSON T) (\GATHERSTATS (PROG [(STREAM (\OPENFILE FILENAME 'OUTPUT 'NEW] (* ;  "CLose before doing stats, cause file isn't really open from Lisp's point of view.") (RETURN (fetch (ARRAYP BASE) of (fetch (M44STREAM FID) of (PROG1 STREAM (\CLOSEFILE STREAM) (\M44FLUSHDISKDESCRIPTOR (fetch DEVICE of STREAM)) (replace (DSKOBJ DDVALID) of (fetch DEVICE of STREAM) with NIL))] (\STATSON (\GATHERSTATS) (SETQ \STATSON NIL]) ) (RPAQQ \STATSON NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (LOADCOMP) LLBFS) ) (PUTPROPS MOD44IO COPYRIGHT ("Venue & Xerox Corporation" 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5090 66819 (\M44AddDiskPages 5100 . 6368) (\M44CloseFile 6370 . 6677) (\M44CompleteFH 6679 . 11093) (\M44CREATEFILE 11095 . 17025) (\M44DeleteFile 17027 . 18116) (\M44EVENTFN 18118 . 22495 ) (\M44ExtendFilePageMap 22497 . 24548) (\M44FillInMap 24550 . 26900) (\M44GetFileHandle 26902 . 29006 ) (\M44GetFileInfo 29008 . 33191) (\M44GETDATEPROP 33193 . 33675) (\M44GetFileName 33677 . 34114) ( \M44GetPageLoc 34116 . 34917) (\M44KillFilePageMap 34919 . 35290) (\M44MAKEDIRENTRY 35292 . 37023) ( \M44OpenFile 37025 . 43158) (\M44OPENFILEFROMFP 43160 . 44188) (\M44ReadDiskPage 44190 . 46417) ( \M44ReadLeaderPage 46419 . 47871) (\M44ReadPages 47873 . 48090) (\M44SetAccessTimes 48092 . 49377) ( \M44SetEndOfFile 49379 . 50870) (\M44SetFileInfo 50872 . 52126) (\M44SETFILETYPE 52128 . 54741) ( \M44TruncateFile 54743 . 56196) (\M44WriteDiskPage 56198 . 60420) (\M44WriteLeaderPage 60422 . 61280) (\M44WritePages 61282 . 63666) (\M44WritePages1 63668 . 66817)) (66853 79777 (\ADDDISKPAGES 66863 . 68676) (\M44DELETEPAGES 68678 . 72720) (\ASSIGNDISKPAGE 72722 . 75974) (\COUNTDISKFREEPAGES 75976 . 76513) (\M44MARKPAGEFREE 76515 . 77215) (\M44FLUSHDISKDESCRIPTOR 77217 . 78159) (\MAKELEADERDAS 78161 . 78872) (DISKFREEPAGES 78874 . 79220) (\M44FREEPAGECOUNT 79222 . 79670) (VMEMSIZE 79672 . 79775)) ( 82930 97231 (\M44GENERATEFILES 82940 . 85860) (\M44SORTFILES 85862 . 86239) (\M44GENERATENEXT 86241 . 91886) (\M44NEXTFILEFN 91888 . 93151) (\M44SORTEDNEXTFILEFN 93153 . 95276) (\M44FILEINFOFN 95278 . 97229)) (97275 122542 (\M44PARSEFILENAME 97285 . 105317) (\FINDDIRHOLE 105319 . 107302) ( \M44PACKFILENAME 107304 . 107934) (\M44READVERSION 107936 . 108362) (\OPENDISKDESCRIPTOR 108364 . 110471) (\M44READDIRFID 110473 . 110909) (\M44READDIRNAME 110911 . 111341) (\M44SEARCHDIR 111343 . 114084) (\M44UNPACKFILENAME 114086 . 122540)) (123381 132404 (\CREATE.FID.FOR.DD 123391 . 123996) ( \OPENDISK 123998 . 125287) (\OPENDISKDEVICE 125289 . 129538) (\OPENDIR 129540 . 130716) ( \M44CHECKPASSWORD 130718 . 132047) (\M44HOSTNAMEP 132049 . 132402)) (132673 139416 (\COPYSYS 132683 . 136057) (\COPYSYS1 136059 . 139414)) (139477 140993 (\MAIKO.CHECKFREESPACE 139487 . 140991)) (141341 143329 (GATHERSTATS 141351 . 143327))))) STOP \ No newline at end of file diff --git a/sources/MODARITH b/sources/MODARITH new file mode 100644 index 00000000..973e0126 --- /dev/null +++ b/sources/MODARITH @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 20:46:21" {DSK}local>lde>lispcore>sources>MODARITH.;2 5852 changes to%: (VARS MODARITHCOMS) previous date%: " 2-Nov-86 17:42:53" {DSK}local>lde>lispcore>sources>MODARITH.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT MODARITHCOMS) (RPAQQ MODARITHCOMS ( (* ;; "The intent, as of Feb 1983, is to move most of these macros into the system under real or CommonLisp names, and to move the various CONSTANTS into some arithmetic package.") (ADDVARS * (LIST (CONS 'EXPANDMACROFNS MODARITHMACROS))) (EXPORT (MACROS * MODARITHMACROS) (CONSTANTS BITSPERNIBBLE NIBBLESPERBYTE BITSPERBYTE BITSPERCELL BITSPERWORD BYTESPERCELL BYTESPERPAGE BYTESPERWORD CELLSPERPAGE CELLSPERSEGMENT PAGESPERSEGMENT WORDSPERCELL WORDSPERPAGE WORDSPERSEGMENT WORDSPERQUAD CELLSPERQUAD BYTESPERQUAD) (CONSTANTS * INTEGERSIZECONSTANTS)))) (* ;; "The intent, as of Feb 1983, is to move most of these macros into the system under real or CommonLisp names, and to move the various CONSTANTS into some arithmetic package." ) (ADDTOVAR EXPANDMACROFNS CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD) (* "FOLLOWING DEFINITIONS EXPORTED") (RPAQQ MODARITHMACROS (CEIL FLOOR FOLDHI FOLDLO MODUP UNFOLD MOD)) (DECLARE%: EVAL@COMPILE (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 'LRSH (LIST '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 '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 'LLSH FORM (SUB1 (INTEGERLENGTH DIVISOR]) (PUTPROPS MOD MACRO (= . IMOD)) ) (DECLARE%: EVAL@COMPILE (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)))) (DECLARE%: EVAL@COMPILE (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))) ) (* "END EXPORTED DEFINITIONS") (PUTPROPS MODARITH COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/NEW-EDIT-INTERFACE b/sources/NEW-EDIT-INTERFACE new file mode 100644 index 00000000..2c6a174e --- /dev/null +++ b/sources/NEW-EDIT-INTERFACE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "25-Jan-91 16:57:19" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;8| 6497 |changes| |to:| (FUNCTIONS XCL::EDIT-EXPRESSION XCL::EDIT-DEFINITION XCL::EDIT SEDIT::EDIT-EXPRESSION SEDIT::MYED) (VARS NEW-EDIT-INTERFACECOMS) |previous| |date:| " 3-Dec-90 18:01:41" |{DSK}woz>SOURCES>NEW-EDIT-INTERFACE.;1|) ; Copyright (c) 1990, 1991 by Venue. All rights reserved. (PRETTYCOMPRINT NEW-EDIT-INTERFACECOMS) (RPAQQ NEW-EDIT-INTERFACECOMS ((FUNCTIONS XCL::EDIT XCL::EDIT-DEFINITION XCL::EDIT-EXPRESSION))) (CL:DEFUN XCL::EDIT (CL:STRUCTURE XCL::PROPS XCL::OPTIONS) (* |;;;| "this is the new way to start the current editor, once you have all the props and options figured out.") (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (CL:FUNCALL (EDITMODE) CL:STRUCTURE XCL::PROPS XCL::OPTIONS)) (CL:DEFUN XCL::EDIT-DEFINITION (XCL::NAME TYPE &OPTIONAL XCL::SOURCE XCL::OPTIONS XCL::PROPS) (* |;;;| "this is a new version of IL:EDITDEF, consistent with the new definition of how to start the current editor. figure out how to get the definition (same as il:editdef), then build the necessary stuff to start the editor and have completion work properly. since we have a \"definition\" there is no need for a root-changed-fn, because putdef will be handed the right structure on completion anyway. Do not wait for completion, just return NAME.") (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::DEFINITION (COND (XCL::SOURCE (GETDEF XCL::NAME TYPE XCL::SOURCE '(EDIT NOCOPY))) ((GETDEF XCL::NAME TYPE 'CURRENT '(EDIT NOCOPY NOERROR))) ((GETDEF XCL::NAME TYPE 'SAVED '(EDIT NOCOPY NOERROR))) (T (LET ((XCL::FILES (WHEREIS XCL::NAME TYPE T))) (CL:IF (NULL XCL::FILES) (CL:FORMAT T "~S has no ~A definition.~%" XCL::NAME TYPE) (LET ((XCL::FILE (PROGN (CL:FORMAT T "~S is contained on~{ ~S~}.~%" XCL::NAME XCL::FILES) (CL:IF (CL:ENDP (CDR XCL::FILES)) (CL:IF (CL:Y-OR-N-P "Shall I load this file PROP? " ) (CAR XCL::FILES)) (ASKUSER NIL NIL "indicate which file to load PROP: " (MAKEKEYLST XCL::FILES) T))))) (CL:WHEN XCL::FILE (LOAD XCL::FILE 'PROP) (GETDEF XCL::NAME TYPE '? '(EDIT NOCOPY))))))))) (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT XCL::NEW-DEF XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (* |;;| "don't reinstall on :ABORT or NIL (no changes)") (PUTDEF XCL::NAME TYPE XCL::NEW-DEF 'CHANGED))))) (CL:WHEN XCL::DEFINITION (XCL::EDIT XCL::DEFINITION (LIST :NAME XCL::NAME :TYPE TYPE :COMPLETION-FN XCL::COMPLETION-FN) XCL::OPTIONS)) XCL::NAME)) (CL:DEFUN XCL::EDIT-EXPRESSION (XCL::EXPR &OPTIONAL XCL::OPTIONS XCL::PROPS) (* |;;;| "similar to ED, but just a one-time un-named edit of an expression. start the editor with :close-on-completion, wait until the edit session completes, and return the structure. Copy the expression before starting the editor so that changes won't be destructive, then recreate eqness on completion. This way aborted changes will not be kept.") (CL:UNLESS (CL:CONSP XCL::EXPR) (CL:ERROR "~S - Not Editable. Must be a list expression." XCL::EXPR) (CL:RETURN-FROM XCL::EDIT-EXPRESSION NIL)) (CL:UNLESS (CL:LISTP XCL::OPTIONS) (CL:SETQ XCL::OPTIONS (LIST XCL::OPTIONS))) (LET* ((XCL::EVENT (CREATE.EVENT "EDIT-EXPRESSION Completion")) (XCL::USER-COMPLETION (LISTGET XCL::PROPS :COMPLETION-FN)) (XCL::NEW-EXPR NIL) (XCL::COMPLETION-FN #'(CL:LAMBDA (XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?) (CL:WHEN XCL::USER-COMPLETION (CL:FUNCALL XCL::USER-COMPLETION XCL::CONTEXT CL:STRUCTURE XCL::CHANGED?)) (CL:WHEN (EQ XCL::CHANGED? T) (CL:SETQ XCL::NEW-EXPR CL:STRUCTURE)) (NOTIFY.EVENT XCL::EVENT)))) (XCL::EDIT (CL:COPY-TREE XCL::EXPR) (LIST :COMPLETION-FN XCL::COMPLETION-FN) (LIST* :CLOSE-ON-COMPLETION XCL::OPTIONS)) (CL:UNLESS (CL:MEMBER :DONTWAIT XCL::OPTIONS) (AWAIT.EVENT XCL::EVENT)) (CL:IF (AND XCL::NEW-EXPR (CL:CONSP XCL::NEW-EXPR)) (RPLNODE2 XCL::EXPR (CL:COPY-TREE XCL::NEW-EXPR)) XCL::EXPR))) (PUTPROPS NEW-EDIT-INTERFACE COPYRIGHT ("Venue" 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/NEWPRINTDEF b/sources/NEWPRINTDEF new file mode 100644 index 00000000..5ac5b3e8 --- /dev/null +++ b/sources/NEWPRINTDEF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "31-Dec-2000 11:53:33" {DSK}medley3.5>sources>NEWPRINTDEF.;2 38876 changes to%: (VARS NEWPRINTDEFCOMS) previous date%: " 7-Feb-91 10:59:12" {DSK}medley3.5>sources>NEWPRINTDEF.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 2000 by Venue. All rights reserved. ") (PRETTYCOMPRINT NEWPRINTDEFCOMS) (RPAQQ NEWPRINTDEFCOMS [(COMS (* ;;; "A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.") (* ;;; "One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here.") (FNS PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG PRINTPROGVARS PRINTSQ BACKARROWP SUBPRINT/ENDLINE RPARS FITP DSFIT1 DSFIT2 SUPERPRINT/SPACE SUBPRINT/WRAPPERTAIL)) [COMS (* ; "Comment prettyprinter") (FNS SUPERPRINT/COMMENT SEMI-COLON-COMMENT-P SUPERPRINT/COMMENT1 SUPERPRINT/COMMENT2) (INITVARS (COMMENTCOLUMN '(0.6 . 0.1)) (*PRINT-SEMICOLON-COMMENTS* NIL) (*BACKQUOTE-WRAPPERS* '(BQUOTE %, %,@ %,.] (COMS (* ;  "Prettyprintmacros for common lisp and other poor things") (FNS CODEWRAPPER.PRETTYPRINT PROG1.PRETTYPRINT CASE.PRETTYPRINT PROGV.PRETTYPRINT DO.PRETTYPRINT INDENTATION.FROM.HERE SEQUENTIAL.PRETTYPRINT) (ALISTS (PRETTYPRINTMACROS UNINTERRUPTABLY CL:UNWIND-PROTECT RESETLST CL:BLOCK CL:IF PROG1 CL:WHEN CL:UNLESS WITH-READER-ENVIRONMENT CL:CATCH CASE CL:ECASE CL:ETYPECASE CL:TYPECASE CL:PROGV WITH.MONITOR CL:DO* CL:DO CL:DOLIST CL:DOTIMES) (PRETTYEQUIVLST PROG* OPENLAMBDA CL:COMPILER-LET))) [DECLARE%: EVAL@COMPILE DOCOPY (P (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT BOLDFONT USERFONT SYSTEMFONT CLISPFONT BIGFONT PRETTYPRINTMACROS] (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS CLISPARRAY CHANGESARRAY AVERAGEFNLENGTH %#CAREFULCOLUMNS AVERAGEVARLENGTH FONTWORDS FONTFNS CLISPCHARS FUNNYATOMLST PRETTYEQUIVLST COMMENTFLG *BACKQUOTE-WRAPPERS*) (BLOCKS (DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG PRINTPROGVARS PRINTSQ BACKARROWP RPARS FITP DSFIT1 DSFIT2 (ENTRIES PRINTDEF SUPERPRINT FITP) (SPECVARS TAIL LEFT FNSLST FIRSTPOS COMMENTCOL FORMFLG FILEFLG) (LOCALFREEVARS TAILFLG CHANGEFLG))) (DECLARE%: DONTEVAL@LOAD (FILES (LOADCOMP) DSPRINTDEF]) (* ;;; "A version of PRINTDEF abstracted so that it can be parameterized for non-teletype devices.") (* ;;; "One example is file DSPRINTDEF which provides one definition for the abstract fns such as WIDTH, XPOSITION etc used here." ) (DEFINEQ (PRINTDEF (LAMBDA (EXPR LEFT FORMFLG TAILFLG FNSLST FILE) (* ; "Edited 15-Apr-88 11:59 by bvm") (LET ((*STANDARD-OUTPUT* (GETSTREAM FILE (QUOTE OUTPUT))) (MAKEMAP NIL) (%#RPARS (COND ((AND %#RPARS (SYNTAXP (CHARCODE "]") (QUOTE RIGHTBRACKET))) (* ; "can only use brackets if read table supports them") %#RPARS))) SPACEWIDTH) (DECLARE (SPECVARS MAKEMAP SPACEWIDTH %#RPARS)) (PROG ((FIRSTPOS (DSPLEFTMARGIN NIL *STANDARD-OUTPUT*)) (RMARGIN (SUB1 (DSPRIGHTMARGIN NIL *STANDARD-OUTPUT*))) (TAIL (LIST EXPR)) COMMENTCOL CHANGEFLG (FILEFLG (NEQ *STANDARD-OUTPUT* (TTYDISPLAYSTREAM)))) (DECLARE (SPECVARS RMARGIN FILEFLG FIRSTPOS)) (COND ((AND (NOT (IMAGESTREAMP *STANDARD-OUTPUT*)) (NOT FONTCHANGEFLG)) (DSPFONT 0 *STANDARD-OUTPUT*))) (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT NIL *STANDARD-OUTPUT*) *STANDARD-OUTPUT*)) (SETFONT DEFAULTFONT *STANDARD-OUTPUT*) (COND (PRETTYFLG (SETQ LEFT (COND ((NOT LEFT) FIRSTPOS) ((NUMBERP LEFT) (PLUS FIRSTPOS (BLANKS LEFT))) (T (DSPXPOSITION NIL *STANDARD-OUTPUT*)))) (COND ((GREATERP (DSPXPOSITION NIL *STANDARD-OUTPUT*) LEFT) (TERPRI *STANDARD-OUTPUT*))) (DSPXPOSITION LEFT *STANDARD-OUTPUT*) (COND (TAILFLG (SUBPRINT EXPR NIL NIL *STANDARD-OUTPUT*)) (T (SUPERPRINT EXPR TAIL NIL *STANDARD-OUTPUT*)))) (T (COND (TAILFLG (MAPRINT EXPR *STANDARD-OUTPUT* NIL NIL NIL (FUNCTION PRIN2S))) (T (PRIN2S EXPR TAIL *STANDARD-OUTPUT*))))))))) ) (SUPERPRINT (LAMBDA (E TAIL BRFLG FILE) (* ; "Edited 14-Apr-88 18:44 by bvm") (SETQ FILE (\GETSTREAM FILE (QUOTE OUTPUT))) (COND ((NLISTP E) (OR (AND (NOT MAKEMAP) (NOT (ATOM E)) (LET ((MACRO (ASSOC (TYPENAME E) PRETTYPRINTYPEMACROS))) (AND MACRO (NEQ (APPLY* (CDR MACRO) E) E)))) (COND ((STRINGP E) (PRIN2STRING E TAIL FILE LEFT RMARGIN)) (T (LET ((TEM (IDIFFERENCE RMARGIN (WIDTH E FILE T)))) (* ; "TEM is the last position at which E will fit") (COND ((AND (ILESSP TEM (DSPXPOSITION NIL FILE)) (IGREATERP TEM FIRSTPOS)) (SUBPRINT/ENDLINE (IMIN LEFT TEM) FILE))) (PRIN2S E TAIL FILE)))))) ((AND (SUPERPRINTEQ (CAR E) COMMENTFLG) (OR FORMFLG (SEMI-COLON-COMMENT-P E))) (SUPERPRINT/COMMENT E FILE)) ((AND PRETTYTRANFLG (NOT (ARGTYPE (CAR E))) (GETHASH E CLISPARRAY)) (SUPERPRINT0 (GETHASH E CLISPARRAY) TAIL BRFLG FILE)) (T (SUPERPRINT0 E TAIL BRFLG FILE)))) ) (SUPERPRINT0 (LAMBDA (E TAIL BRFLG FILE) (* ; "Edited 14-Apr-88 18:44 by bvm") (* ; "BRFLG says do not print a ) as expression will be terminated by a ].") (PROG ((FN (CAR E)) MACRO) (COND ((NOT (CL:SYMBOLP FN))) ((AND (SETQ MACRO (GET FN (QUOTE PRETTYWRAPPER))) (LISTP (CDR E)) (NULL (CDDR E)) (SETQ MACRO (CL:FUNCALL MACRO E FILE))) (* ; "Special case that DEDIT can handle: a 'wrapper' form wants to pretty print via a read macro syntax") (RETURN (SUPERPRINT/WRAPPER MACRO E TAIL BRFLG FILE))) ((SETQ MACRO (AND (NOT MAKEMAP) (ASSOC FN PRETTYPRINTMACROS))) (COND ((NOT (SETQ MACRO (APPLY* (CDR MACRO) E))) (* ; "macro printed the thing") (RETURN E)) ((NEQ E MACRO) (* ; "macro returns something else to print (!)") (RETURN (SUPERPRINT MACRO TAIL BRFLG FILE))) (T (SETQ E MACRO))))) (LET ((LEFT NIL) (NEWBR (AND (NULL BRFLG) (FIXP %#RPARS) (RPARS E %#RPARS)))) (* ; "LEFT is set from within SUBPRINT. Only appears here for call to ENDLINE") (PRINOPEN TAIL (COND (NEWBR (QUOTE %[)) (T (QUOTE %())) FILE) (SUBPRINT E (OR BRFLG NEWBR) NIL FILE) (COND ((ILESSP RMARGIN (IPLUS (DSPXPOSITION NIL FILE) (WIDTH ")" FILE))) (PROG (TAIL) (* ;; "need to rebind tail because if next expression is a comment dont want to print it yet because we still have the right paren to print.") (SUBPRINT/ENDLINE LEFT FILE)))) (PRINSHUT TAIL (COND (NEWBR (QUOTE %])) (BRFLG NIL) (T (QUOTE %)))) FILE)) (RETURN E))) ) (SUBPRINT (LAMBDA (TAIL BRFLG END FILE) (* ; "Edited 26-Apr-88 10:48 by bvm") (* ;; "Prettyprint the elements of TAIL until we reach END.") (PROG (CURRENT DOCRFLG NEXT TEM OLDY CLISPWORD (FORMFLG FORMFLG) (FORMFLG0 FORMFLG) (TAIL0 TAIL) (LEFT0 (DSPXPOSITION NIL FILE)) (CLW0 (CAR (SUPERPRINTGETPROP (CAR TAIL) (QUOTE CLISPWORD))))) (SETQ LEFT LEFT0) (* ; "LEFT is set from SUBPRINT. Start where we are") LP (COND ((EQ TAIL END) (RETURN TAIL)) ((NULL TAIL) (RETURN)) ((NLISTP TAIL) (RETURN (PRINDOTP TAIL FILE)))) (SETQ OLDY (DSPYPOSITION NIL FILE)) (SETQ CURRENT (CAR TAIL)) (if (LITATOM CURRENT) then (if (AND (NEQ TAIL TAIL0) (LISTP (CDR TAIL)) (NULL (CDDR TAIL)) (FMEMB CURRENT *BACKQUOTE-WRAPPERS*) (SETQ TEM (GET CURRENT (QUOTE PRETTYWRAPPER))) (NEQ (CDR TAIL) END) (NOT MAKEMAP) (SETQ TEM (CL:FUNCALL TEM TAIL FILE))) then (* ; "tail of expression is something with a pretty wrapper, e.g., (foo . ,bar), which if we printed it normally would come out (foo \, bar)") (SUBPRINT/WRAPPERTAIL TAIL TEM BRFLG) (RETURN) elseif (AND CLISPFLG FORMFLG0 (SETQ CLISPWORD (SUPERPRINTGETPROP CURRENT (QUOTE CLISPWORD)))) then (OR (EQ CLW0 (CAR CLISPWORD)) (SETQ CLISPWORD NIL)))) (SETQ FORMFLG (AND FORMFLG0 (NOT (SUPERPRINTEQ (CAR TAIL0) (QUOTE QUOTE))))) (* ;; "says whether next expression is to be treated as a form. used to be an argument to superprint but this value of formflg should also affect the call to endline from subprint.") (SETFONT (PROG1 (AND FORMFLG0 (LITATOM CURRENT) (SETFONT (COND ((LISTP CLISPWORD) CLISPFONT) ((FMEMB CURRENT FONTWORDS) USERFONT) ((AND (EQ TAIL0 TAIL) (NULL END)) (COND ((OR (FMEMB CURRENT FNSLST) (FMEMB CURRENT (LISTP FONTFNS))) USERFONT) ((FGETD CURRENT) SYSTEMFONT))) ((AND (SUPERPRINTGETPROP CURRENT (QUOTE CLISPTYPE)) (NOT (FMEMB CURRENT CLISPCHARS))) (* ; "Infix operators like GT AND etc.") CLISPFONT)) FILE)) (* ;; "When printing a function via a call to prettydef and fontflg is turned on and the function is either on FNS or on FONTFLG do a fontchange.") (SETQ CURRENT (SUPERPRINT CURRENT TAIL (AND (NULL (CDR TAIL)) BRFLG) FILE))) FILE) (* ; "Reason for (SETQ CURRENT --) is in case CURRENT is printed as something else") (* ;; "Popping TAIL used to be done in the call to SUPERPRINT. But this can cause subsequent comments to be printed first if ENDLINE is called because of no space. BRFLG only affects last expression in list.") (SETQ TAIL (CDR TAIL)) (* ;; "CURRENT is always the element just printed; NEXT the one about to be i.e. CAR of TAIL") LP0 (COND ((OR (EQ TAIL END) (NLISTP TAIL)) (GO LP)) ((OR (NULL CLISPFLG) (NULL FORMFLG) (NULL FORMFLG0)) (* ; "Skip this clisp stuff") (GO LP1)) ((NOT (LITATOM (SETQ NEXT (CAR TAIL))))) ((AND (SETQ TEM (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD))) (OR (NLISTP TEM) (EQ CLW0 (CAR TEM)))) (* ;; "AND and OR are treated like prettywords because they are broadscope operators i.e. they permit segments and therefore the standard FITP test can't be used.") (GO CLISPWORD)) ((AND (EQ (CADR (LISTP TAIL)) (QUOTE _)) (OR (SUPERPRINTEQ (CAR TAIL0) (QUOTE CREATE)) (SUPERPRINTEQ (CAR TAIL0) (QUOTE create)))) (GO CR))) (COND ((LISTP CURRENT)) ((NOT (LITATOM CURRENT)) (GO LP1)) ((SELECTQ (CAR CLISPWORD) ((IFWORD FORWORD) T) NIL) (SETQ DOCRFLG NIL) (COND ((NULL END) (SETQ END T))) (* ; "See use of END below")) ((NOT (OR (NULL CLISPIFYPACKFLG) (ATOM NEXT) (COND ((EQ TAIL (CDR TAIL0)) (OR (FGETD CURRENT) (SUPERPRINTGETPROP CURRENT (QUOTE EXPR)))) (T (BOUNDP CURRENT))) (FMEMB CURRENT FUNNYATOMLST) (NOT (FMEMB (SETQ TEM (NTHCHAR CURRENT -1)) CLISPCHARS)) (EQ TEM (QUOTE >)))) (* ; "E.g. X* (FOO) Don't space") (GO LP)) ((BACKARROWP CURRENT) (* ; "E.G. IF -- THEN FOO_X FIE_Y is more readable if the assignments are on separate lines.") (GO CR))) LP1 (COND ((EQ TAIL (CDR TAIL0)) (* ; "First time through i.e. just superprinted HEAD of list.") (COND ((LISTP CURRENT) (GO CR)) ((AND FORMFLG0 (SELECTQ (OR (CDR (FASSOC CURRENT PRETTYEQUIVLST)) CURRENT) (COND (SETQ LEFT (IPLUS LEFT0 (WIDTH "CO" FILE))) (GO CR)) ((PROG RESETVARS) (RETURN (PRINTPROG TAIL BRFLG FILE CURRENT))) (SELECTQ (RETURN (PRINTSQ TAIL BRFLG FILE))) ((SETQ RESETVAR) (GO SP)) (FUNCTION (* ; "If FUNCTION has a second arg, fall thru and reset margin. Else leave it for compactness") (OR (CDR TAIL) (GO SP))) ((LAMBDA NLAMBDA) (SETQ DOCRFLG T) (SETQ LEFT (IPLUS LEFT0 (BLANKS 1))) (SUPERPRINT/SPACE FILE) (GO LP)) NIL))) ((NOT (FITP TAIL T (OR (LISTP END) (AND CLISPWORD (SUBPRINT1 TAIL (CAR CLISPWORD)))) NIL FILE)) (GO CR) (* ; "Don't reset I.")) (T (SUPERPRINT/SPACE FILE) (* ; "Default head of form handling") (SETQ LEFT (IMIN (DSPXPOSITION NIL FILE) (IPLUS LEFT0 (BLANKS 6)))) (* ; "Dont indent too far") (GO LP))))) (COND ((AND (NEQ OLDY (DSPYPOSITION NIL FILE)) (OR (NOT (ATOM CURRENT)) (EQ CURRENT (QUOTE >)))) (GO CR))) (* ;; "Printing last 'thing' (usually a list) caused a c.r. Also occurs if printing angle brackets which contain a list inside e.g. < (FOO (FIE) X) > and c.r. will occur after >.") (SETQ NEXT (CAR TAIL)) (COND ((LISTP CURRENT) (COND ((OR (NULL END) (SUPERPRINTEQ (CAR CURRENT) COMMENTFLG)) (GO CR)) ((AND (LISTP NEXT) (SUPERPRINTEQ (CAR NEXT) COMMENTFLG)) (GO SP)) ((AND (LITATOM NEXT) (OR (SUPERPRINTGETPROP NEXT (QUOTE CLISPWORD)) (SUPERPRINTGETPROP NEXT (QUOTE CLISPTYPE)))) (GO SP)) (T (GO CR)))) ((NLISTP NEXT) (GO SP)) (DOCRFLG (* ;; "DOCRFLG is set to T whenever a carriage return is performed. It is reset to NIL whenever a carriage return is NOT performed e.g. when two atoms are adjacent. while it is T carriage returns are performed FOLLOWING all expressions. For example in (A B (C) D (E) F G (H)) (C) D (E) and F would be on separate lines but F G and (H) would all be on the same line.") (GO CR)) ((FITP NEXT NIL NIL NIL FILE) (GO SP)) (T (GO CR))) SP (SETQ DOCRFLG NIL) (SUPERPRINT/SPACE FILE) (GO LP) CR (SETQ DOCRFLG T) (SUBPRINT/ENDLINE NIL FILE) (GO LP) CLISPWORD (PROG ((LEFT LEFT) (LEFT0 LEFT0) (CEND)) (SELECTQ (OR (CDR (FASSOC NEXT PRETTYEQUIVLST)) NEXT) ((THEN ELSE ELSEIF then else elseif) (* ; "THEN ELSE and ELSEIF always start a new line.") (SETQ LEFT (IPLUS (SUBPRINT/ENDLINE (IPLUS LEFT0 (BLANKS (SELECTQ NEXT ((THEN then) 3) 1))) FILE) (BLANKS 1))) (* ;; "Note that in most cases LEFT will be reset again in subprint after printing the CLISPWORD. It will remain this value only if the next expression wont fit.") (SETQ TAIL (SUBPRINT TAIL BRFLG (SUBPRINT1 (CDR TAIL) (QUOTE IFWORD) END) FILE)) (RETURN)) ((AND OR and or) (* ; "So when new left margin is coputed in next cond it will be based on inner expression.") (SETQ LEFT0 LEFT) (SETQ CEND (SUBPRINT1 (CDR TAIL) NIL END))) ((! !!) (SETQ CEND (CDDR TAIL))) (SETQ CEND (SUBPRINT1 (CDR TAIL) (CAR (GETP (CAR TAIL0) (QUOTE CLISPWORD))) END))) (SETQ LEFT (IPLUS (COND ((AND (EQ OLDY (DSPYPOSITION NIL FILE)) (FITP TAIL NIL CEND NIL FILE)) (SUPERPRINT/SPACE FILE) (DSPXPOSITION NIL FILE)) (T (* ;; "Either last expression involved a CR e.g. FOR X IN (FOO (FIE) (FUM)) DO -- OR the segment of the list between here and the next CLISPFORWORD will not fit.") (SUBPRINT/ENDLINE (IPLUS LEFT0 (BLANKS 2)) FILE))) (BLANKS 1))) (SETQ OLDY (DSPYPOSITION NIL FILE)) (SETQ CURRENT (CAR (NLEFT TAIL 1 CEND))) (SETQ TAIL (SUBPRINT TAIL BRFLG CEND FILE))) (GO LP0) (* ;; "We are now in the position of just having printed the element before E and are ready to look ahead at the next one so go to LP0."))) ) (SUBPRINT1 (LAMBDA (LST X END) (* bas%: "24-NOV-81 15:28") (bind TMP for L on LST until (OR (EQ L END) (AND (LITATOM (CAR L)) (SETQ TMP (GETPROP (CAR L) (QUOTE CLISPWORD))) (OR (NULL X) (EQ X (CAR TMP)))) (AND (EQ X (QUOTE RECORDWORD)) (EQ (CADR L) (QUOTE _)))) finally (RETURN L))) ) (PRINTPROG (LAMBDA (TAIL BRFLG FILE PROGWORD) (* ; "Edited 14-Apr-88 18:44 by bvm") (PROG ((LABELL (IDIFFERENCE (DSPXPOSITION NIL FILE) (STRINGWIDTH "ROG" FILE))) (FORMLEFT (IPLUS (DSPXPOSITION NIL FILE) (STRINGWIDTH " " FILE)))) (* ; "LABELL is the position PROG labels start in; FORMLEFT that for forms") (DSPXPOSITION FORMLEFT FILE) (COND ((AND (CAR TAIL) (LITATOM (CAR TAIL))) (SUPERPRINT (CAR TAIL) TAIL (PROGN (SETQ TAIL (CDR TAIL)) T) FILE) (SPACES 1 FILE))) (* ; "Print PROG variables.") (PRINTPROGVARS TAIL FILE (AND (NULL (SETQ TAIL (CDR TAIL))) BRFLG)) LP1 (COND ((LISTP TAIL) (SUBPRINT/ENDLINE LABELL FILE))) (* ; "ENDLINE resets TAIL when it sees a comment.") LP2 (COND ((NLISTP TAIL) (AND TAIL (PRINDOTP TAIL FILE)) (RETURN)) ((LISTP (CAR TAIL)) (COND ((ILEQ FORMLEFT (DSPXPOSITION NIL FILE)) (PRINENDLINE FORMLEFT FILE)) (T (DSPXPOSITION FORMLEFT FILE))) (SUPERPRINT (CAR TAIL) TAIL (AND (NULL (SETQ TAIL (CDR TAIL))) BRFLG) FILE) (GO LP1)) (T (COND ((ILESSP LABELL (DSPXPOSITION NIL FILE)) (* ; "Two labels in a row") (PRINENDLINE LABELL FILE))) (SUPERPRINT (CAR TAIL) TAIL NIL FILE) (* ; "Print the label.") (pop TAIL) (GO LP2))))) ) (PRINTPROGVARS (LAMBDA (TAIL FILE BRFLG) (* bvm%: " 4-May-86 15:01") (* ;;; "(CAR TAIL) is a VARS list for a PROG etc. Print it suitably") (SUPERPRINT (CAR TAIL) TAIL BRFLG FILE)) ) (PRINTSQ (LAMBDA (TAIL BRFLG FILE) (* bvm%: " 2-Jun-86 15:07") (PROG ((KEYL (QUOTIENT (PLUS LEFT (DSPXPOSITION NIL FILE)) 2)) FOLD LEFT REST) (* ; "KEYL is the position keys start in; LEFT that for forms") (* ; "Print select expression FORMFLG=T") (SUPERPRINT/SPACE FILE) (SETQ FOLD (IPLUS (SETQ LEFT (DSPXPOSITION NIL FILE)) (TIMES 2 (DIFFERENCE LEFT KEYL)))) (SUPERPRINT (CAR TAIL) TAIL NIL FILE) LP (OR (SETQ TAIL (CDR TAIL)) (RETURN)) (PRINENDLINE KEYL FILE) (COND ((NLISTP TAIL) (RETURN (PRINDOTP TAIL FILE))) ((CDR TAIL) (COND ((LISTP (CAR TAIL)) (PRINOPEN TAIL (QUOTE %() FILE) (PROG (FORMFLG) (* ; "Print keys not as function") (SUPERPRINT (CAAR TAIL) (CAR TAIL) NIL FILE)) (AND (SETQ REST (CDAR TAIL)) (PROG ((LEFT LEFT) (HERE (DSPXPOSITION NIL FILE))) (SUPERPRINT/SPACE FILE) (COND ((OR (LISTP (CAAR TAIL)) (IGEQ HERE FOLD)) (COND ((AND (LISTP (CAR REST)) (EQMEMB (CAAR REST) COMMENTFLG)) (* ; "Start comment on same line") (PROG ((LEFT LEFT)) (SUBPRINT REST NIL (CDR REST) FILE)) (SETQ REST (CDR REST)))) (PRINENDLINE LEFT FILE)) (T (SETQ LEFT HERE))) (SUBPRINT REST NIL NIL FILE))) (PRINSHUT TAIL (QUOTE %)) FILE)) (T (PRIN2S (CAR TAIL) TAIL FILE)))) (T (SUPERPRINT (CAR TAIL) TAIL BRFLG FILE))) (GO LP))) ) (BACKARROWP (LAMBDA (X) (* bas%: "17-NOV-82 15:19") (AND (STRPOS (QUOTE _) X) (NEQ (NTHCHARCODE X -1) (CHARCODE _)))) ) (SUBPRINT/ENDLINE (LAMBDA (N FILE) (* lmm "30-Jul-85 03:20") (AND FORMFLG (while (SUPERPRINTEQ (CAR (LISTP (CAR (LISTP TAIL)))) COMMENTFLG) do (SUPERPRINT (CAR TAIL) TAIL NIL FILE) (* ; "a comment") (pop TAIL))) (PRINENDLINE (OR N LEFT) FILE) N) ) (RPARS (LAMBDA (E NP) (* bas%: "11-MAR-83 11:45") (COND ((ILEQ NP 0)) ((NLISTP E) NIL) (T (SELECTQ (CAR E) ((LAMBDA NLAMBDA) T) (DEFINEQ (* ;; "Dont want square brakcets around DEFINEQ expressions, because this means last function pair is special with respect to LOADFNS") NIL) (RPARS (CAR (LAST E)) (SUB1 NP)))))) ) (FITP (LAMBDA (X TAILFLG ENDTAIL LSTCOL FILE) (* ; "Edited 14-Apr-88 18:39 by bvm") (* ;; "Value is T unless X doesnt fit. There are two cases: one where X is a tail (only called for the first tail i.e. CDR of an expression) and the second where it is an element. They differ in their treatment of linear lists of atoms. If one is about to print (FOO A B C D E F) and it wont fit on a line then do a carriage return and start printing. However if A B C D E F doesnt fit doesnt mean to do a carriage return (and then line all the atoms up in a column). The idea is that long lists are given as much room as possible (the first carriage return) but not at the expense of making them be vertical.") (DECLARE (SPECVARS ENDTAIL)) (* ; "ENDTAIL is the end of TAIL e.g. when printing CLISP segments") (OR FILE (SETQ FILE *STANDARD-OUTPUT*)) (* ; "Don't let FILE be NIL, since CHARWIDTH and STRINGWIDTH won't default correctly") (LET* ((SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) FILE)) (CAREFUL (BLANKS %#CAREFULCOLUMNS)) (N (- (OR LSTCOL RMARGIN) (DSPXPOSITION NIL FILE)))) (DECLARE (SPECVARS SPACEWIDTH CAREFUL)) (COND (TAILFLG (AND (> N (BLANKS (+ AVERAGEVARLENGTH 2))) (DSFIT1 X N NIL FILE))) (T (DSFIT2 X N NIL FILE))))) ) (DSFIT1 (LAMBDA (LST N N1 FILE) (* lmm "30-Jul-85 03:08") (DECLARE (USEDFREE CAREFUL ENDTAIL)) (* ;; "Checks to see if LST could fit in N spaces.") (bind (M _ (COND (TAILFLG NIL) (T N))) for L on LST until (EQ L ENDTAIL) do (COND ((NLISTP (CAR L)) (COND (M (SETQ M (IDIFFERENCE M (IPLUS (COND ((ILESSP M CAREFUL) (* ; "When getting near right margin actually perform the WIDTH check.") (WIDTH (CAR L) FILE T)) (T (BLANKS AVERAGEVARLENGTH))) (BLANKS 1)))) (COND ((ILESSP M 0) (RETURN NIL)))))) ((DSFIT2 (CAR L) (OR N1 N) NIL FILE) (* ;; "The extra argument to DSFIT1 is for use in connectionwith CLISPPRETTYWORDS e.g. FOR IF etc. Normally we figure that any lists can be printed at the position corresponding to the first argument ut with FOR's and IF's et al they would always be preceded by the corresponding CLISP word.") (AND M (SETQ M N)) (* ; "Reset count when LISTP reached as margin will be reset")) (T (RETURN NIL))) finally (RETURN T))) ) (DSFIT2 (LAMBDA (X N NC FILE) (* lmm "30-Jul-85 03:09") (DECLARE (USEDFREE CAREFUL)) (* ; "NC is local to DSFIT2") (COND ((SUPERPRINTEQ (CAR X) COMMENTFLG) T) ((LISTP (CAR X)) (* ; "Non-atomic CAR of form e.g. COND clause open lambda etc.") (AND (ILESSP 0 (SETQ N (IDIFFERENCE N (WIDTH "()" FILE)))) (DSFIT2 (CAR X) N NIL FILE) (OR (NULL (CDR X)) (DSFIT1 (CDR X) N NIL FILE)))) ((ILESSP N (IPLUS (WIDTH "()" FILE) (SETQ NC (COND ((ILESSP N CAREFUL) (WIDTH (CAR X) FILE T)) (T (BLANKS AVERAGEFNLENGTH)))))) (* ;; "Checks to see if there is space for function name and two parentheses. when there are more than CAREFUL columns left approximate using AVERAGEFNLENGTH.") NIL) ((NULL (CDR X)) T) ((ILEQ (SELECTQ (CAR X) (COND 0) (FUNCTION (WIDTH "(FUNCTION LAMBDA ABC)" FILE)) ((LAMBDA NLAMBDA) (WIDTH "(LAMBDA ABC" FILE)) (SETQ (IPLUS (WIDTH "(SETQ " FILE) (BLANKS AVERAGEVARLENGTH))) (PROGN (SETQ N (IDIFFERENCE N NC)) (BLANKS (ADD1 AVERAGEFNLENGTH)))) (SETQ N (IDIFFERENCE N (BLANKS 2)))) (* ;; "The two spaces correspond to the amount LEFT would be decremented on the recursive call to superprint. the default clause in the selectq checks to see if function and at least one atomic argument (we know there is at least one) will fit. The call to DSFIT1 checks to see if using normal alignment algorithm the expression can fit.") (DSFIT1 (CDR X) N (SELECTQ (CAR (SUPERPRINTGETPROP (CAR X) (QUOTE CLISPWORD))) ((IFWORD FORWORD) (IDIFFERENCE N (IPLUS NC (BLANKS 1)))) NIL) FILE)))) ) (SUPERPRINT/SPACE (LAMBDA (FILE) (* ; "Edited 31-Mar-88 12:18 by bvm") (* ;; "Print a space, preparing for next item to be printed") (DECLARE (CL:SPECIAL RMARGIN SPACEWIDTH LEFT)) (* ; "bound by prettyprinter stuff") (if (< (- RMARGIN (DSPXPOSITION NIL FILE)) (TIMES 2 SPACEWIDTH)) then (* ; "printing a space will overflow the line, or if not then the next char would, so go to new line") (PRINENDLINE LEFT FILE) else (PRIN3 " " FILE))) ) (SUBPRINT/WRAPPERTAIL (LAMBDA (TAIL MACRO BRFLG) (* ; "Edited 15-Apr-88 11:54 by bvm") (* ;; "Called when TAIL = ... wrapperform body), e.g, QUOTE FOO). We print this as a dotted tail with the wrapper instead.") (LET ((DOT ". ") (BODY (CADR TAIL))) (if (NOT (if (NLISTP BODY) then (< (+ (DSPXPOSITION) (WIDTH DOT) (WIDTH MACRO) (WIDTH BODY NIL T) (WIDTH ")")) RMARGIN) else (FITP BODY))) then (* ; "Start a new line") (PRINENDLINE LEFT)) (PRIN3 DOT) (PRIN3 MACRO) (SUPERPRINT BODY (CDR TAIL) BRFLG *STANDARD-OUTPUT*))) ) ) (* ; "Comment prettyprinter") (DEFINEQ (SUPERPRINT/COMMENT (LAMBDA (L FILE) (* ; "Edited 13-Apr-88 12:55 by bvm") (DECLARE (USEDFREE LEFT TAIL RMARGIN FILEFLG MAKEMAP)) (COND ((AND **COMMENT**FLG (NOT FILEFLG) (NOT MAKEMAP)) (* ;; "If we're eliding comments, not printing to a file, and not in DEdit, then just print the elision string") (COND ((> (+ (DSPXPOSITION NIL FILE) (STRINGWIDTH **COMMENT**FLG FILE)) (DSPRIGHTMARGIN NIL FILE)) (* ; "Watch out for overflowing the current line.") (PRINENDLINE (DSPLEFTMARGIN NIL FILE) FILE))) (PRIN1S **COMMENT**FLG NIL FILE)) (T (PROG ((DSLMARG (DSPLEFTMARGIN NIL FILE)) (HERE (DSPXPOSITION NIL FILE)) (COMMENT-RMARGIN RMARGIN) (SEMIP (SEMI-COLON-COMMENT-P L)) COMMENT-LMARGIN RIGHTFLG BODY HALFLINE) (if SEMIP then (* ; "Extract the comment body") (COND ((OR (NOT (STRINGP (SETQ BODY (CAR (LISTP (CDR (LISTP (CDR L)))))))) (CDDDR L)) (* ; "Not a good semi-colon comment") (SETQ SEMIP NIL)))) (COND ((SETQ RIGHTFLG (if SEMIP then (* ; "Only 1-semi comments go in right margin") (EQ SEMIP 1) else (* ; "Short single * comments go at right") (AND (NOT (SUPERPRINTEQ (CADR L) COMMENTFLG)) (<= (LENGTH L) 15)))) (* ; "Print comment in the righthand margin") (SETQ COMMENT-LMARGIN (OR COMMENTCOL (SUPERPRINT/COMMENT1 L RMARGIN FILE)))) ((AND SEMIP (NOT MAKEMAP)) (* ; "Semi-colon comment > 1, unless under DEdit (lest we confuse it)") (AND SEMIP (> SEMIP 2) (NOT MAKEMAP)) (SETQ COMMENT-LMARGIN (if (EQ SEMIP 2) then (* ; "indent like code, but no more than a third of the way over if it would take more than 2 lines to print this.") (MIN LEFT (MAX (- RMARGIN (FIXR (TIMES (STRINGWIDTH BODY FILE) 0.52))) (+ DSLMARG (IQUOTIENT (- RMARGIN DSLMARG) 3)))) else (* ; "Comment should be printed flush left.") DSLMARG))) (T (LET ((INDENT (IQUOTIENT (- RMARGIN DSLMARG) 11))) (* ; "Print old-style comment centered and wide, indented about 10%% from margins") (SETQ COMMENT-LMARGIN (+ DSLMARG INDENT)) (SETQ COMMENT-RMARGIN (- RMARGIN INDENT)) (COND ((EQ HERE COMMENT-LMARGIN) (* ;; "HACK: Almost certainly called from REPP, so we must supress the normal leading and trailing blank lines as they have already been done") (SETQ RIGHTFLG T)))))) (COND ((AND (NULL RIGHTFLG) (OR (NOT SEMIP) (> SEMIP 1))) (* ; "Centered comment starts on new line") (if (> HERE COMMENT-LMARGIN) then (* ; "We have not yet moved down a line, so do that first") (TERPRI FILE)) (if (AND (EQ SEMIP 2) (IMAGESTREAMP FILE)) then (* ; "For 2-semi comments, only go down half line, accomplished by moving up half line now before this next endline") (RELMOVETO 0 (SETQ HALFLINE (IQUOTIENT (- (DSPLINEFEED NIL FILE)) 2)))) (PRINENDLINE COMMENT-LMARGIN FILE)) ((< COMMENT-LMARGIN (DSPXPOSITION NIL FILE)) (* ; "Past the starting point, so start new line") (PRINENDLINE COMMENT-LMARGIN FILE)) (T (DSPXPOSITION COMMENT-LMARGIN FILE))) (SETFONT (PROG1 (SETFONT COMMENTFONT FILE) (COND ((AND SEMIP (NOT MAKEMAP) (OR *PRINT-SEMICOLON-COMMENTS* (IMAGESTREAMP FILE))) (* ; "do nice semi-colon stuff") (PRIN2-LONG-STRING BODY FILE NIL NIL COMMENT-LMARGIN COMMENT-RMARGIN T SEMIP)) (T (* ; "Old comment or in DEdit (makemap true), so have to do it the old way") (SETQ SEMIP NIL) (SUPERPRINT/COMMENT2 L COMMENT-LMARGIN (IQUOTIENT (+ COMMENT-LMARGIN COMMENT-RMARGIN) 2) COMMENT-RMARGIN FILE)))) FILE) (if (OR (NULL SEMIP) (> SEMIP 2)) then (* ; "Old centered comments and big semi-colon comments get new line") (OR RIGHTFLG (PRINENDLINE DSLMARG FILE)) elseif (NULL (CDR TAIL)) then (* ; "Nothing more will be printed. So even though we were a short comment, we need to go to new line so that the closing paren is on a new line, rather than here after the comment (AR 8475)") (PRINENDLINE LEFT FILE) elseif (AND HALFLINE (NOT (AND (LISTP (CDR TAIL)) (SEMI-COLON-COMMENT-P (LISTP (CADR TAIL)))))) then (* ; "Set off double-semi-colon comment by half line. Don't do for consecutive comments, since the next comment will take care of it") (RELMOVETO 0 HALFLINE) (PRINENDLINE DSLMARG FILE)) (RETURN L))))) ) (SEMI-COLON-COMMENT-P (LAMBDA (E) (* ; "Edited 20-Sep-87 18:30 by raf") (* ;; "If E is a comment, returns a number giving number of semis (or type).") (SELECTQ (CADR E) (; (* ; "SEdit-style right-margin comment") 1) (;; (* ; "SEdit-style current-indent comment") 2) (;;; (* ; "SEdit-style flush left comment") 3) (;;;; (* ; "Page boundary type comment") 4) (%| (* ; "Balanced (hash vertical bar) comment") 5) NIL)) ) (SUPERPRINT/COMMENT1 (LAMBDA (CF RMARGIN FILE) (* bvm%: "26-Mar-86 14:03") (* ;;; "Computes the left margin for comments printed on the right") (LET ((EDITDATEP (EDITDATE? CF)) LM MINLEFT DEFAULT) (SETQ MINLEFT (IDIFFERENCE (IDIFFERENCE RMARGIN (COND (EDITDATEP (* ; "Min space is size of this edit date comment") (LET ((FONT (DSPFONT COMMENTFONT FILE))) (PROG1 (WIDTH CF FILE T) (DSPFONT FONT FILE)))) (T (* ; "Else an arbitrary space") (BLANKS 15)))) (BLANKS 1))) (SETQ DEFAULT (FIXR (TIMES (OR (FLOATP (CAR (LISTP COMMENTCOLUMN))) 0.6) RMARGIN))) (SETQ LM (IMAX (IQUOTIENT RMARGIN 2) (IMIN MINLEFT DEFAULT))) (* ; "use at least enough space, but no more than half the line") (COND ((NOT EDITDATEP) (* ; "Don't have the editdate dictate margin for rest of function!") (SETQ COMMENTCOL LM))) LM)) ) (SUPERPRINT/COMMENT2 (LAMBDA (CMT COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE) (* bvm%: "28-May-86 15:15") (SETQ FILE (\GETSTREAM FILE (QUOTE OUTPUT))) (PRINOPEN TAIL (QUOTE %() FILE) (for TAIL on CMT bind LASTITEM THISITEM do (SETQ THISITEM (CAR TAIL)) (* ; "Decide whether to continue on a new line") (COND ((OR (EQ LASTITEM (QUOTE -)) (AND (IGEQ (DSPXPOSITION NIL FILE) COMMENT-MIDPOINT) (OR (LISTP THISITEM) (AND (LITATOM LASTITEM) (SELCHARQ (NTHCHARCODE LASTITEM -1) ((; %. -) T) NIL)))) (PROGN (COND ((AND (NEQ TAIL CMT) (OR (NLISTP LASTITEM) (SELECTQ THISITEM ((%. %, ; %:) NIL) T))) (* ; "Space before next element unless it looks like punctuation after a list") (SUPERPRINT/SPACE FILE))) (AND (NLISTP THISITEM) (NOT (STRINGP THISITEM)) (IGEQ (IPLUS (DSPXPOSITION NIL FILE) (WIDTH THISITEM FILE T) (WIDTH (COND ((CDR TAIL) " ") (T (* ; "Leave space for the paren; i.e., don't print last atom on one line and the paren on the next") ")")) FILE)) COMMENT-RMARGIN)))) (PRINENDLINE COMMENT-LMARGIN FILE))) (COND ((LISTP (SETQ LASTITEM THISITEM)) (SUPERPRINT/COMMENT2 LASTITEM COMMENT-LMARGIN COMMENT-MIDPOINT COMMENT-RMARGIN FILE)) ((STRINGP LASTITEM) (PRIN2STRING LASTITEM TAIL FILE COMMENT-LMARGIN COMMENT-RMARGIN T)) (T (PRIN2S LASTITEM TAIL FILE))) finally (AND TAIL (PRINDOTP TAIL FILE))) (PRINSHUT TAIL (QUOTE %)) FILE)) ) ) (RPAQ? COMMENTCOLUMN '(0.6 . 0.1)) (RPAQ? *PRINT-SEMICOLON-COMMENTS* NIL) (RPAQ? *BACKQUOTE-WRAPPERS* '(BQUOTE %, %,@ %,.)) (* ; "Prettyprintmacros for common lisp and other poor things") (DEFINEQ (CODEWRAPPER.PRETTYPRINT (LAMBDA (FORM) (* ; "Edited 30-Mar-88 11:44 by bvm") (* ;; "Prettyprints things that wrap code like PROGN. We usually want them to start the code on the next line, rather than put the first expression way to the right of all the rest.") (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE))) (PRIN2 (pop FORM)) (* ; "Print the %"function%" itself") (if (NLISTP FORM) then (* ; "Ignore degenerate cases") (PRINTDEF FORM T T T FNSLST) else (SEQUENTIAL.PRETTYPRINT FORM HERE)) (PRIN1 ")") NIL)) ) (PROG1.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 14-Apr-88 18:39 by bvm") (* ;; "Prettyprinter advice for PROG1, CL:IF, UNLESS, etc. Default way's main problem is that if the first expression is a non-list but some later expression is a list, it doesn't put ALL the subsequent expressions equally indented. Thus, you get something like (PROG1 A (expression) (expression) ...)") (if (OR (NLISTP (CDR (LISTP (CDR EXPR)))) (AND (NLISTP (CDDDR EXPR)) (for E in (LISTP (CADDR EXPR)) never (LISTP E)))) then (* ; "2 or fewer elements, or 3 elements, the last of which is very simple--let default prettyprinter do it") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION)))) (DECLARE (SPECVARS LEFT)) (if (OR (if (>= HERE LEFT) then (* ; "Default indentation wants to be greater than the function length, so change it to here") (SETQ HERE LEFT)) (NLISTP (CAR EXPR)) (FITP (CAR EXPR))) then (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (* ; "Print the first element right at this position") (pop EXPR)) (SEQUENTIAL.PRETTYPRINT EXPR HERE)) (PRIN1 ")") (* ; "Return NIL to say we handled it") NIL)) ) (CASE.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 26-Apr-88 10:52 by bvm") (if (NLISTP (CDR EXPR)) then (* ; "Degenerate case--punt") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION))) (TAIL EXPR) INNERLEFT CASE) (DECLARE (SPECVARS LEFT TAIL)) (if (OR (if (>= HERE LEFT) then (* ; "Default indentation wants to be greater than the function length, so change it to here") (SETQ HERE LEFT)) (NLISTP (CAR TAIL)) (FITP (CAR TAIL))) then (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (* ; "Print the first element right at this position") (pop TAIL)) (SETQ INNERLEFT (+ (SETQ LEFT HERE) (TIMES 3 (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)))) (do (if (NLISTP TAIL) then (if TAIL then (* ; "dotted tail?") (PRINENDLINE LEFT *STANDARD-OUTPUT*) (PRINTDEF TAIL T T T)) (PRIN1 ")") (RETURN NIL) elseif (SEMI-COLON-COMMENT-P (LISTP (CAR TAIL))) then (* ; "Print any comments stuck in between elements") (SUPERPRINT/COMMENT (CAR TAIL) *STANDARD-OUTPUT*) (pop TAIL) else (* ; "Start new line, after printing any comments") (PRINENDLINE LEFT *STANDARD-OUTPUT*) (if (NLISTP (SETQ CASE (CAR TAIL))) then (* ; "Degenerate case?") (PRIN2 CASE) elseif (FMEMB (CAR CASE) *BACKQUOTE-WRAPPERS*) then (* ; "backquoted case") (SUPERPRINT CASE TAIL NIL *STANDARD-OUTPUT*) else (PRIN1 "(") (LET (FORMFLG) (DECLARE (SPECVARS FORMFLG)) (* ; "Print the key(s) as data") (SUPERPRINT (CAR CASE) CASE NIL *STANDARD-OUTPUT*) (SPACES 1)) (if (NLISTP (SETQ CASE (CDR CASE))) then (* ; "No tail, but handle degenerates") (PRINTDEF CASE T T T) else (SEQUENTIAL.PRETTYPRINT CASE (LET ((HERE (DSPXPOSITION))) (if (OR (<= HERE INNERLEFT) (AND (NULL (CDR CASE)) (if (LISTP (CDR CASE)) then (* ; "Multiple things to print") NIL elseif (NLISTP (CAR CASE)) then (* ; "Print simple consequent if space") (< (STRINGWIDTH (CAR CASE) *STANDARD-OUTPUT* T) (- (DSPRIGHTMARGIN) HERE)) else (FITP CASE T)))) then (* ; "Key didn't go too far over, so just prettyprint from here") HERE else INNERLEFT)))) (PRIN1 ")")) (pop TAIL)))))) ) (PROGV.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 14-Apr-88 18:37 by bvm") (* ;; "Prettyprinter advice for PROGV. Default way's main problem is that if the vars and values are non-lists the %"body%" of the form doesn't get uniformly indented. Thus, you get something like (PROGV vars values (expression) (expression) ...)") (if (OR (NLISTP (CDR EXPR)) (LISTP (CADR EXPR)) (NLISTP (CDR (LISTP (CDDR EXPR))))) then (* ; "3 or fewer elements, or the second is a list--default prettyprinter will do fine") EXPR else (PRIN1 "(") (LET ((HERE (INDENTATION.FROM.HERE)) (LEFT (PROGN (PRIN2 (pop EXPR)) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION)))) (DECLARE (SPECVARS LEFT)) (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (* ; "Print the first element (vars) at this position") (pop EXPR) (if (OR (NLISTP (CAR EXPR)) (FITP (CAR EXPR))) then (SPACES 1) (* ; "Room for next element (values) here") (SUPERPRINT (CAR EXPR) EXPR NIL *STANDARD-OUTPUT*) (pop EXPR)) (* ; "Finally, print the body") (SEQUENTIAL.PRETTYPRINT EXPR HERE)) (PRIN1 ")") (* ; "Return NIL to say we handled it") NIL)) ) (DO.PRETTYPRINT (LAMBDA (EXPR) (* ; "Edited 26-Apr-88 11:30 by bvm") (* ;; "Prettyprinter advice for DO, DO*, DOLIST, DOTIMES. Default way's main problem is that the body is indented at the same level as the clauses. Syntax: (do clauses exit . body)") (if (NOT (LISTP (CDR (LISTP (CDR EXPR))))) then (* ; "2 or fewer elements--default prettyprinter will do fine") EXPR else (PRIN1 "(") (LET* ((START (DSPXPOSITION)) (HEAD (CAR EXPR)) (LEFT (PROGN (PRIN2 HEAD) (* ; "Print the car of form") (SPACES 1) (DSPXPOSITION))) (TAIL (CDR EXPR))) (DECLARE (SPECVARS LEFT TAIL)) (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (* ; "Print the first element (var clauses) at this position") (pop TAIL) (SELECTQ HEAD ((CL:DO CL:DO*) (* ; "There's another clause here") (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*) (* ; "Indent next at same level, printing any comments first") (if (LISTP TAIL) then (* ; "Unless degenerate case, print the second element (end test) at this position") (if (NULL (CAR TAIL)) then (* ; "Empty exit condition") (PRIN1 "()") else (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*)) (pop TAIL))) NIL) (* ;; "Finally, print the body, with left margin halfway between left edge of form and the initial clauses") (SEQUENTIAL.PRETTYPRINT TAIL (+ START (MIN (TIMES 3 SPACEWIDTH) (IQUOTIENT (- LEFT START) 2))))) (PRIN1 ")") (* ; "Return NIL to say we handled it") NIL)) ) (INDENTATION.FROM.HERE (LAMBDA NIL (* ; "Edited 28-Mar-88 18:17 by bvm") (* ;; "Returns X-pos about 3 chars over, for use in indenting code") (+ (DSPXPOSITION) (TIMES 3 (CHARWIDTH (CHARCODE X) *STANDARD-OUTPUT*)))) ) (SEQUENTIAL.PRETTYPRINT (LAMBDA (TAIL LEFT) (* ; "Edited 26-Apr-88 11:15 by bvm") (DECLARE (SPECVARS TAIL LEFT)) (* ;; "Print each element of tail indented at position LEFT.") (PROG (TEM) (if (<= (DSPXPOSITION) LEFT) then (* ; "Don't start with newline if we aren't to the right of the left margin") (GO MIDDLE)) TOP (if (OR (NULL TAIL) (PROGN (SUBPRINT/ENDLINE LEFT *STANDARD-OUTPUT*) (NULL TAIL))) then (* ; "Done") (RETURN)) MIDDLE (if (NLISTP TAIL) then (* ; "Degenerate tail") (RETURN (PRINTDEF TAIL T T T)) elseif (AND (LISTP (CDR TAIL)) (FMEMB (CAR TAIL) *BACKQUOTE-WRAPPERS*) (NULL (CDDR TAIL)) (SETQ TEM (GET (CAR TAIL) (QUOTE PRETTYWRAPPER))) (SETQ TEM (CL:FUNCALL TEM TAIL *STANDARD-OUTPUT*))) then (* ; "Dotted backquote tail (sigh)") (RETURN (SUBPRINT/WRAPPERTAIL TAIL TEM))) (SUPERPRINT (CAR TAIL) TAIL NIL *STANDARD-OUTPUT*) (pop TAIL) (GO TOP))) ) ) (ADDTOVAR PRETTYPRINTMACROS (UNINTERRUPTABLY . CODEWRAPPER.PRETTYPRINT) (CL:UNWIND-PROTECT . CODEWRAPPER.PRETTYPRINT) (RESETLST . CODEWRAPPER.PRETTYPRINT) (CL:BLOCK . PROG1.PRETTYPRINT) (CL:IF . PROG1.PRETTYPRINT) (PROG1 . PROG1.PRETTYPRINT) (CL:WHEN . PROG1.PRETTYPRINT) (CL:UNLESS . PROG1.PRETTYPRINT) (WITH-READER-ENVIRONMENT . PROG1.PRETTYPRINT) (CL:CATCH . PROG1.PRETTYPRINT) (CASE . CASE.PRETTYPRINT) (CL:ECASE . CASE.PRETTYPRINT) (CL:ETYPECASE . CASE.PRETTYPRINT) (CL:TYPECASE . CASE.PRETTYPRINT) (CL:PROGV . PROGV.PRETTYPRINT) (WITH.MONITOR . PROG1.PRETTYPRINT) (CL:DO* . DO.PRETTYPRINT) (CL:DO . DO.PRETTYPRINT) (CL:DOLIST . DO.PRETTYPRINT) (CL:DOTIMES . DO.PRETTYPRINT)) (ADDTOVAR PRETTYEQUIVLST (PROG* . PROG) (OPENLAMBDA . LAMBDA) (CL:COMPILER-LET . LET)) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT BOLDFONT USERFONT SYSTEMFONT CLISPFONT BIGFONT PRETTYPRINTMACROS)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLISPARRAY CHANGESARRAY AVERAGEFNLENGTH %#CAREFULCOLUMNS AVERAGEVARLENGTH FONTWORDS FONTFNS CLISPCHARS FUNNYATOMLST PRETTYEQUIVLST COMMENTFLG *BACKQUOTE-WRAPPERS*) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: DSPRETTY PRINTDEF SUPERPRINT SUPERPRINT0 SUBPRINT SUBPRINT1 PRINTPROG PRINTPROGVARS PRINTSQ BACKARROWP RPARS FITP DSFIT1 DSFIT2 (ENTRIES PRINTDEF SUPERPRINT FITP) (SPECVARS TAIL LEFT FNSLST FIRSTPOS COMMENTCOL FORMFLG FILEFLG) (LOCALFREEVARS TAILFLG CHANGEFLG)) ) (DECLARE%: DONTEVAL@LOAD (FILESLOAD (LOADCOMP) DSPRINTDEF) ) ) (PUTPROPS NEWPRINTDEF COPYRIGHT ("Venue" 1982 1983 1984 1985 1986 1987 1988 1990 1991 2000)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3455 22694 (PRINTDEF 3465 . 4853) (SUPERPRINT 4855 . 5719) (SUPERPRINT0 5721 . 7120) ( SUBPRINT 7122 . 14493) (SUBPRINT1 14495 . 14783) (PRINTPROG 14785 . 15940) (PRINTPROGVARS 15942 . 16127) (PRINTSQ 16129 . 17353) (BACKARROWP 17355 . 17478) (SUBPRINT/ENDLINE 17480 . 17731) (RPARS 17733 . 18053) (FITP 18055 . 19280) (DSFIT1 19282 . 20233) (DSFIT2 20235 . 21720) (SUPERPRINT/SPACE 21722 . 22165) (SUBPRINT/WRAPPERTAIL 22167 . 22692)) (22733 29278 (SUPERPRINT/COMMENT 22743 . 26701) ( SEMI-COLON-COMMENT-P 26703 . 27123) (SUPERPRINT/COMMENT1 27125 . 27928) (SUPERPRINT/COMMENT2 27930 . 29276)) (29490 36888 (CODEWRAPPER.PRETTYPRINT 29500 . 30018) (PROG1.PRETTYPRINT 30020 . 31219) ( CASE.PRETTYPRINT 31221 . 33304) (PROGV.PRETTYPRINT 33306 . 34407) (DO.PRETTYPRINT 34409 . 35795) ( INDENTATION.FROM.HERE 35797 . 36017) (SEQUENTIAL.PRETTYPRINT 36019 . 36886))))) STOP \ No newline at end of file diff --git a/sources/NSFILING b/sources/NSFILING new file mode 100644 index 00000000..3ee8857e --- /dev/null +++ b/sources/NSFILING @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Jun-99 17:07:34" {DSK}medley3.5>sources>NSFILING.;2 294552 changes to%: (FNS \NSFILING.GENERATEFILES) previous date%: "19-Jan-93 10:59:09" {DSK}medley3.5>sources>NSFILING.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 1999 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSFILINGCOMS) (RPAQQ NSFILINGCOMS [(COMS (* ; "Filing Protocol") (COURIERPROGRAMS FILING FILING.4) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS * NSFILINGCONSTANTS) (RECORDS NSFILINGSTREAM FILINGSESSION FILINGHANDLE NSFILESERVER NSFILINGDEVICEINFO \NSFILING.GENFILESTATE NSFILINGPARSE NSPAGECACHE) (MACROS WITHOUT.SESSION.MONITOR) (GLOBALVARS \NSFILING.CONNECTIONS \NSFILING.DEVICE \NSFILING.NULL.HANDLE \NSFILING.ATTRIBUTES \LISP.TO.NSFILING.ATTRIBUTES \NSFILING.USEFUL.ATTRIBUTE.TYPES \NSFILING.PROGRAM.NAME \NSFILING.ACTIVE.SESSIONS FILING.CACHE.LIMIT *NSFILING-PAGE-CACHE-INCREMENT* *NSFILING-PAGE-CACHE-LIMIT* *NSFILING-RANDOM-ACCESS* *NSFILING-SESSION-TIMEOUT* \NSRANDOM.CHECK.CACHE \NSFILING.PROTECTION.BITS \FILEDEVICES) (LOCALVARS . T) (FILES (SOURCE) SPPDECLS) (FILES (LOADCOMP) COURIER)) (INITRECORDS FILINGSESSION FILINGHANDLE) (FNS \FILINGSESSION.DEFPRINT \FILINGHANDLE.DEFPRINT)) [COMS (FNS \GET.FILING.ATTRIBUTE \PUT.FILING.ATTRIBUTE \GET.SESSION.HANDLE \PUT.SESSION.HANDLE) (PROP COURIERDEF FILING.SESSION FILING.ATTRIBUTE) (DECLARE%: EVAL@COMPILE DOCOPY (VARS \NSFILING.NULL.HANDLE \NSFILING.PROTECTION.BITS \NSFILING.ATTRIBUTES \LISP.TO.NSFILING.ATTRIBUTES (\NSFILING.USEFUL.ATTRIBUTE.TYPES (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(CREATED.ON FILE.ID IS.DIRECTORY PATHNAME SIZE.IN.BYTES FILE.TYPE VERSION] (INITVARS (FILING.CACHE.LIMIT 6) (NSFILING.SHOW.STATUS T) (FILING.ENUMERATION.DEPTH T) (\NSFILING.LOCK (CREATE.MONITORLOCK 'NSFILING)) (\NSFILING.PROGRAM.NAME 'FILING) (\NSFILING.ACTIVE.SESSIONS) (*NSFILING-RANDOM-ACCESS* T) (*NSFILING-PAGE-CACHE-LIMIT* 8) (*NSFILING-PAGE-CACHE-INCREMENT* 4) (*NSFILING-SESSION-TIMEOUT* '(900 . 21600)) (\NSRANDOM.CHECK.CACHE)) (COMS (* ; "Connection maintenance") (FNS \GETFILINGCONNECTION \NSFILING.GET.NEW.SESSION \NSFILING.GET.STREAM \NSFILING.COURIER.OPEN \NSFILING.CLOSE.BULKSTREAM \NSFILING.RELEASE.BULKSTREAM FILING.CALL \NSFILING.LOGIN \NSFILING.AFTER.LOGIN \NSFILING.SET.CONTINUANCE \NSFILING.LOGOUT \NSFILING.DISCARD.SESSION \VALID.FILING.CONNECTIONP \NSFILING.CLOSE.CONNECTIONS BREAK.NSFILING.CONNECTION) (ADDVARS (\AFTERLOGINFNS \NSFILING.AFTER.LOGIN))) (COMS (* ; "Support") (FNS \NSFILING.CONNECT \NSFILING.MAYBE.CREATE \NSFILING.REMOVEQUOTES \NSFILING.ADDQUOTES \FILING.ATTRIBUTE.TYPE.SEQUENCE \FILING.ATTRIBUTE.TYPE \LISP.TO.NSFILING.ATTRIBUTE)) (COMS (* ; "FILINGHANDLE stuff") (FNS \NSFILING.GETFILE \NSFILING.LOOKUP.CACHE \NSFILING.ADD.TO.CACHE \NSFILING.OPEN.HANDLE \NSFILING.CONFLICTP \NSFILING.CHECK.ACCESS \NSFILING.FILLIN.ATTRIBUTES \NSFILING.COMPOSE.PATHNAME \NSFILING.PARSE.FILENAME \NSFILING.ERRORHANDLER \NSFILING.WHENCLOSED \NSFILING.CLOSE.HANDLE \NSFILING.FULLNAME)) (COMS (* ; "NSFILING device") (FNS \NSFILING.OPENFILE \NSFILING.HANDLE.ERROR \NSFILING.CLOSEFILE \NSFILING.EVENTFN \NSFILING.DELETEFILE \NSFILING.CHILDLESS-P \NSFILING.DIRECTORYNAMEP \NSFILING.HOSTNAMEP \NSFILING.GETFILENAME \NSFILING.GETFILEINFO \NSFILING.GET.ATTRIBUTES \NSFILING.GETFILEINFO.FROM.PLIST \NSFILING.GDATE \NSFILING.SETFILEINFO \NSFILING.GET/SETINFO \NSFILING.UPDATE.ATTRIBUTES \NSFILING.GETEOFPTR \NSFILING.GENERATEFILES \NSFILING.GENERATE.STARS \NSFILING.NEXTFILE \NSFILING.FILEINFOFN \NSFILING.RENAMEFILE \NSFILING.COPYFILE \NSFILING.COPY/RENAME)) (COMS (* ; "Random access methods") (FNS \NSRANDOM.CLOSEFILE \NSRANDOM.RELEASE.HANDLE \NSRANDOM.RELEASE.LOCK \NSRANDOM.RELEASE.IF.ERROR \NSRANDOM.CREATE.STREAM \NSRANDOM.READPAGES \NSRANDOM.READ.SEGMENT \NSRANDOM.PREPARE.CACHE \NSRANDOM.FETCH.CACHE \NSRANDOM.CHECK.CACHE \NSRANDOM.WRITEPAGES \NSRANDOM.WRITE.SEGMENT \NSRANDOM.WROTE.HANDLE \NSRANDOM.SETEOFPTR \NSRANDOM.TRUNCATEFILE \NSRANDOM.UPDATE.VALIDATION \NSRANDOM.OPENFILE) (* ; "error handling") (FNS \NSRANDOM.HANDLE.ERROR \NSRANDOM.PROCEEDABLE.ERROR \NSRANDOM.REESTABLISH \NSRANDOM.STREAM.CHANGED \NSRANDOM.DESTROY.STREAM \NSRANDOM.SESSION.WATCHER \NSRANDOM.ENSURE.WATCHER)) (COMS (* ; "Cleaning up directories") (FNS GC-FILING-DIRECTORY \NSGC.COLLECT.DIRECTORIES)) (COMS (* ;  "Deserialize (special for NSMAIL)") (FNS \NSFILING.DESERIALIZE \NSFILING.DESERIALIZE1)) [COMS (FNS \NSFILING.INIT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\NSFILING.INIT] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA FILING.CALL]) (* ; "Filing Protocol") (COURIERPROGRAM FILING (10 5) TYPES [(ATTRIBUTE.TYPE LONGCARDINAL) (ATTRIBUTE.TYPE.SEQUENCE (SEQUENCE ATTRIBUTE.TYPE)) (ATTRIBUTE FILING.ATTRIBUTE) (ATTRIBUTE.SEQUENCE (SEQUENCE FILING.ATTRIBUTE)) (CONTROL.TYPE (ENUMERATION (LOCK 0) (TIMEOUT 1) (ACCESS 2))) (CONTROL.TYPE.SEQUENCE (SEQUENCE CONTROL.TYPE)) (CONTROL (CHOICE (LOCK 0 LOCK) (TIMEOUT 1 TIMEOUT) (ACCESS 2 ACCESS.SEQUENCE))) (CONTROL.SEQUENCE (SEQUENCE CONTROL)) (LOCK (ENUMERATION (NONE 0) (SHARE 1) (EXCLUSIVE 2))) (TIMEOUT CARDINAL) (ACCESS.TYPE (ENUMERATION (READ 0) (WRITE 1) (OWNER 2) (ADD 3) (REMOVE 4) (ALL 65535))) (ACCESS.SEQUENCE (SEQUENCE ACCESS.TYPE)) (ACCESS.ENTRY (RECORD (KEY (CLEARINGHOUSE . NAME)) (ACCESS ACCESS.SEQUENCE))) (ACCESS.LIST (RECORD (ENTRIES (SEQUENCE ACCESS.ENTRY)) (DEFAULTED BOOLEAN))) (SCOPE.TYPE (ENUMERATION (COUNT 0) (DIRECTION 1) (FILTER 2) (DEPTH 3))) (SCOPE (CHOICE (COUNT 0 CARDINAL) (DIRECTION 1 DIRECTION) (FILTER 2 FILTER) (DEPTH 3 CARDINAL))) (SCOPE.SEQUENCE (SEQUENCE SCOPE)) (DIRECTION (ENUMERATION (FORWARD 0) (BACKWARD 1))) (FILTER (CHOICE (LT 0 FILTER.ATTRIBUTE) (LE 1 FILTER.ATTRIBUTE) (= 2 FILTER.ATTRIBUTE) (~= 3 FILTER.ATTRIBUTE) (GE 4 FILTER.ATTRIBUTE) (GT 5 FILTER.ATTRIBUTE) (AND 6 (SEQUENCE FILTER)) (OR 7 (SEQUENCE FILTER)) (NOT 8 FILTER) (NONE 9 NIL) (ALL 10 NIL) (MATCHES 11 ATTRIBUTE))) (FILTER.ATTRIBUTE (RECORD (ATTRIBUTE FILING.ATTRIBUTE) (INTERPRETATION INTERPRETATION))) (INTERPRETATION (ENUMERATION (NONE 0) (BOOLEAN 1) (CARDINAL 2) (LONGCARDINAL 3) (TIME 4) (INTEGER 5) (LONGINTEGER 6) (STRING 7))) (BYTE.RANGE (RECORD (FIRSTBYTE LONGCARDINAL) (COUNT LONGCARDINAL))) (CREDENTIALS (AUTHENTICATION . CREDENTIALS)) (HANDLE (ARRAY 2 UNSPECIFIED)) (SESSION FILING.SESSION) (VERIFIER (AUTHENTICATION . VERIFIER)) (SIMPLE.VERIFIER (AUTHENTICATION . SIMPLE.VERIFIER)) (FILE.ID (ARRAY 5 UNSPECIFIED)) (USER (CLEARINGHOUSE . NAME)) (ORDERING (RECORD (KEY ATTRIBUTE.TYPE) (ASCENDING BOOLEAN) (INTERPRETATION INTERPRETATION))) (ARGUMENT.PROBLEM (ENUMERATION (Illegal 0) (Disallowed 1) (Unreasonable 2) (Unimplemented 3) (Duplicated 4) (Missing 5))) (ACCESS.PROBLEM (ENUMERATION (AccessRightsInsufficient 0) (AccessRightsIndeterminate 1) (FileChanged 2) (FileDamaged 3) (FileInUse 4) (FileNotFound 5) (FileOpen 6))) (CONNECTION.PROBLEM (ENUMERATION (NoRoute 0) (NoResponse 1) (TransmissionHardware 2) (TransportTimeout 3) (TooManyLocalConnections 4) (TooManyRemoteConnections 5) (MissingCourier 6) (MissingProgram 7) (MissingProcedure 8) (ProtocolMismatch 9) (ParameterInconsistency 10) (InvalidMessage 11) (ReturnTimedOut 12) (Other 65535))) (HANDLE.PROBLEM (ENUMERATION (Invalid 0) (NullDisallowed 1) (DirectoryRequired 2))) (INSERTION.PROBLEM (ENUMERATION (PositionUnavailable 0) (FileNotUnique 1) (LoopInHierarchy 2))) (SERVICE.PROBLEM (ENUMERATION (CannotAuthenticate 0) (ServiceFull 1) (ServiceUnavailable 2) (SessionInUse 3) (UnknownService 4))) (SESSION.PROBLEM (ENUMERATION (TokenInvalid 0))) (SPACE.PROBLEM (ENUMERATION (AllocationExceeded 0) (AttributeAreaFull 1) (MediumFull 2))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) (ChecksumIncorrect 1) (FormatIncorrect 2) (NoRendezvous 3) (WrongDirection 4] PROCEDURES ((LOGON 0 ((CLEARINGHOUSE . NAME) CREDENTIALS VERIFIER) RETURNS (SESSION) REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (LOGOFF 1 (SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR SERVICE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (CONTINUE 19 (SESSION) RETURNS (CARDINAL) REPORTS (AUTHENTICATION.ERROR SESSION.ERROR UNDEFINED.ERROR)) (OPEN 2 (ATTRIBUTE.SEQUENCE HANDLE CONTROL.SEQUENCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR )) (CLOSE 3 (HANDLE SESSION) RETURNS NIL REPORTS (AUTHENTICATION.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (CREATE 4 (HANDLE ATTRIBUTE.SEQUENCE CONTROL.SEQUENCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR UNDEFINED.ERROR)) (DELETE 5 (HANDLE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (GET.CONTROLS 6 (HANDLE CONTROL.TYPE.SEQUENCE SESSION) RETURNS (CONTROL.SEQUENCE) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (CHANGE.CONTROLS 7 (HANDLE CONTROL.SEQUENCE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (GET.ATTRIBUTES 8 (HANDLE ATTRIBUTE.TYPE.SEQUENCE SESSION) RETURNS (ATTRIBUTE.SEQUENCE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR AUTHENTICATION.ERROR HANDLE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (CHANGE.ATTRIBUTES 9 (HANDLE ATTRIBUTE.SEQUENCE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR UNDEFINED.ERROR)) (COPY 10 (HANDLE HANDLE ATTRIBUTE.SEQUENCE CONTROL.SEQUENCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR UNDEFINED.ERROR)) (MOVE 11 (HANDLE HANDLE ATTRIBUTE.SEQUENCE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR UNDEFINED.ERROR)) (STORE 12 (HANDLE ATTRIBUTE.SEQUENCE CONTROL.SEQUENCE BULK.DATA.SOURCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (RETRIEVE 13 (HANDLE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR HANDLE.ERROR SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (REPLACE 14 (HANDLE ATTRIBUTE.SEQUENCE BULK.DATA.SOURCE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR HANDLE.ERROR SESSION.ERROR SPACE.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (SERIALIZE 15 (HANDLE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR HANDLE.ERROR SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (DESERIALIZE 16 (HANDLE ATTRIBUTE.SEQUENCE CONTROL.SEQUENCE BULK.DATA.SOURCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR INSERTION.ERROR SESSION.ERROR SPACE.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (FIND 17 (HANDLE SCOPE.SEQUENCE CONTROL.SEQUENCE SESSION) RETURNS (HANDLE) REPORTS (ACCESS.ERROR AUTHENTICATION.ERROR CONTROL.TYPE.ERROR CONTROL.VALUE.ERROR HANDLE.ERROR SCOPE.TYPE.ERROR SCOPE.VALUE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (LIST 18 (HANDLE ATTRIBUTE.TYPE.SEQUENCE SCOPE.SEQUENCE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (ACCESS.ERROR ATTRIBUTE.TYPE.ERROR ATTRIBUTE.VALUE.ERROR AUTHENTICATION.ERROR CONNECTION.ERROR HANDLE.ERROR SCOPE.TYPE.ERROR SCOPE.VALUE.ERROR SESSION.ERROR TRANSFER.ERROR UNDEFINED.ERROR)) (RETRIEVE.BYTES 22 (HANDLE BYTE.RANGE BULK.DATA.SINK SESSION) RETURNS NIL REPORTS (ACCESS.ERROR HANDLE.ERROR RANGE.ERROR SESSION.ERROR UNDEFINED.ERROR)) (REPLACE.BYTES 23 (HANDLE BYTE.RANGE BULK.DATA.SOURCE SESSION) RETURNS NIL REPORTS (ACCESS.ERROR HANDLE.ERROR RANGE.ERROR SESSION.ERROR SPACE.ERROR UNDEFINED.ERROR))) ERRORS ((ATTRIBUTE.TYPE.ERROR 0 (ARGUMENT.PROBLEM ATTRIBUTE.TYPE)) (ATTRIBUTE.VALUE.ERROR 1 (ARGUMENT.PROBLEM ATTRIBUTE.TYPE)) (CONTROL.TYPE.ERROR 2 (ARGUMENT.PROBLEM CONTROL.TYPE)) (CONTROL.VALUE.ERROR 3 (ARGUMENT.PROBLEM CONTROL.TYPE)) (SCOPE.TYPE.ERROR 4 (ARGUMENT.PROBLEM SCOPE.TYPE)) (SCOPE.VALUE.ERROR 5 (ARGUMENT.PROBLEM SCOPE.TYPE)) (ACCESS.ERROR 6 (ACCESS.PROBLEM)) (AUTHENTICATION.ERROR 7 ((AUTHENTICATION . PROBLEM))) (CONNECTION.ERROR 8 (CONNECTION.PROBLEM)) (HANDLE.ERROR 9 (HANDLE.PROBLEM)) (INSERTION.ERROR 10 (INSERTION.PROBLEM)) (SERVICE.ERROR 11 (SERVICE.PROBLEM)) (SESSION.ERROR 12 (SESSION.PROBLEM)) (SPACE.ERROR 13 (SPACE.PROBLEM)) (TRANSFER.ERROR 14 (TRANSFER.PROBLEM)) (UNDEFINED.ERROR 15 (CARDINAL)) (RANGE.ERROR 16 (ARGUMENT.PROBLEM)))) (COURIERPROGRAM FILING.4 (10 4) INHERITS (FILING) TYPES [(SCOPE.TYPE (ENUMERATION (COUNT 0) (DIRECTION 1) (FILTER 2) (DEPTH 3))) (SCOPE (CHOICE (COUNT 0 CARDINAL) (DIRECTION 1 DIRECTION) (FILTER 2 FILTER) (DEPTH 4 CARDINAL))) (ACCESS.LIST (RECORD (ENTRIES (SEQUENCE ACCESS.ENTRY)) (DEFAULTED BOOLEAN))) (ACCESS.ENTRY (RECORD (KEY (CLEARINGHOUSE . NAME)) (TYPE (ENUMERATION (INDIVIDUAL 0) (ALIAS 1) (GROUP 2) (-- 3))) (ACCESS UNSPECIFIED]) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ NSFILINGCONSTANTS ((\NSFILING.ALL.ATTRIBUTE.TYPES '(-1)) (\NSFILING.DEFAULT.TIMEOUT -1) (\NSFILING.NULL.FILTER '(ALL)) (\NSFILING.NULL.FILE.ID '(0 0 0 0 0)) (\NSFILING.LOWEST.VERSION 0) (\NSFILING.HIGHEST.VERSION 65535) (\NSFILING.TYPE.BINARY 0) (\NSFILING.TYPE.DIRECTORY 1) (\NSFILING.TYPE.TEXT 2))) (DECLARE%: EVAL@COMPILE (RPAQQ \NSFILING.ALL.ATTRIBUTE.TYPES (-1)) (RPAQQ \NSFILING.DEFAULT.TIMEOUT -1) (RPAQQ \NSFILING.NULL.FILTER (ALL)) (RPAQQ \NSFILING.NULL.FILE.ID (0 0 0 0 0)) (RPAQQ \NSFILING.LOWEST.VERSION 0) (RPAQQ \NSFILING.HIGHEST.VERSION 65535) (RPAQQ \NSFILING.TYPE.BINARY 0) (RPAQQ \NSFILING.TYPE.DIRECTORY 1) (RPAQQ \NSFILING.TYPE.TEXT 2) (CONSTANTS (\NSFILING.ALL.ATTRIBUTE.TYPES '(-1)) (\NSFILING.DEFAULT.TIMEOUT -1) (\NSFILING.NULL.FILTER '(ALL)) (\NSFILING.NULL.FILE.ID '(0 0 0 0 0)) (\NSFILING.LOWEST.VERSION 0) (\NSFILING.HIGHEST.VERSION 65535) (\NSFILING.TYPE.BINARY 0) (\NSFILING.TYPE.DIRECTORY 1) (\NSFILING.TYPE.TEXT 2)) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS NSFILINGSTREAM ( (* ;  "Overlays STREAM. F1-2 and FW6-8 are used by the bulkdata device") (NSFILING.CONNECTION (fetch F3 of DATUM) (replace F3 of DATUM with NEWVALUE)) (* ;  "Session on which this stream is open") (NSFILING.HANDLE (fetch F4 of DATUM) (replace F4 of DATUM with NEWVALUE)) (* ; "Filing HANDLE") (NSFILING.NEW.ATTRIBUTES (fetch F5 of DATUM) (replace F5 of DATUM with NEWVALUE)) (* ;  "For output sequential files, the attributes to install after we write the file") (NSFILING.PAGE.CACHE (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (* ;  "Cache of pages read from server but not yet read by client") (NSFILING.SERVER.LENGTH (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (* ;  "For random-access streams, actual length of file on server") (NSFILING.LAST.REQUEST (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (* ;  "Last page requested to be read or written") )) (DATATYPE FILINGSESSION ((FSLOGINCHANGED FLAG) (* ;  "True if login info changes for this host") (FSREALACTIVITY FLAG) (* ;  "Set true when there have been non-CONTINUE calls made on this session") (NIL BITS 6) (FSPARSEDNAME POINTER) (* ; "Canonical NSNAME of server") (FSNAMESTRING POINTER) (* ; "same as a Lisp string") (FSADDRESS POINTER) (* ; "NSADDRESS of server") (FSPROCESSNAME POINTER) (* ;  "Courier stream open for this session, or NIL if none") (FSSESSIONHANDLE POINTER) (* ; "Handle for this session") (FSSESSIONLOCK POINTER) (FSLASTREALACTIVITYTIMER POINTER) (* ;  "Time of last interesting activity") (FSDEVICENAME POINTER) (FSCOURIERSTREAMS POINTER) (* ;  "Courier streams usable by session") (FSCACHEDHANDLES POINTER) (* ;  "Zero or more instances of FILINGHANDLE describing handles we have open in this session") (FSLOGINNAME POINTER) (* ;  "Name under which this session is logged in") (FSPROTOCOLNAME POINTER) (* ; "FILING or OLDFILING") (FSPROTOCOLDEF POINTER) (* ;  "Courier def for FILING.CALL to use") (FSSESSIONTIMER POINTER) (* ;  "Time we last did anything at all in this session") (FSCONTINUANCE WORD) (* ;  "How long in msecs we can be idle without having server close session") (FSVERSION WORD) (* ;  "Version of the protocol in use by this server") (* ; "Spares") (NIL POINTER) (NIL POINTER) (NIL POINTER))) (DATATYPE FILINGHANDLE ((NSHDIRECTORYP FLAG) (* ; "Handle is a directory") (NSHWASREAD FLAG) (* ; "True if we have read file since we obtained the handle (in which case read date has been updated)") (NSHWASWRITTEN FLAG) (NSHWASMODIFIED FLAG) (NIL BITS 4) (NSHDATUM POINTER) (* ;  "The file handle datum used in Courier calls") (NSHFILEID POINTER) (* ; "FILE.ID of file") (NSHNAME POINTER) (* ;  "Full name of the file referenced") (NSHPATHNAME POINTER) (* ; "Canonical pathname of file") (NSHATTRIBUTES POINTER) (* ; "Cached attributes") (NSHACCESS POINTER) (* ;  "Current access controls on handle") (NSHTIMER POINTER) (* ; "Last reference to this handle") (NSHBUSYCOUNT WORD) (* ;  "Number of current users of handle") (NIL WORD) (NSHDIRECTORYPATH POINTER) (* ;  "For directories, the list of component dirs") (NIL POINTER)) NSHTIMER _ (SETUPTIMER 0) NSHDIRECTORYPATH _ T) (RECORD NSFILESERVER (NSFSPARSEDNAME . NSFSADDRESSES)) (RECORD NSFILINGDEVICEINFO (NSFILESERVER NSWATCHERPROC NSFILINGLOCK NSFILINGNAME NSRANDOMDEVICE . NSCONNECTIONS)) (RECORD \NSFILING.GENFILESTATE (CURRENTINFO NSCONNECTION NSGENERATOR NSFILTER NSIGNOREDIRECTORIES NSBULKSTREAM)) (RECORD NSFILINGPARSE (NSDIRECTORIES NSROOTNAME NSVERSION NSDIRECTORYP NSHASPERIOD)) (RECORD NSPAGECACHE (NSPSIZE . NSPHEADER) (RECORD NSPHEADER (NSPTAIL . NSPBUFFERS))) ) (/DECLAREDATATYPE 'FILINGSESSION '(FLAG FLAG (BITS 6) POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILINGSESSION 0 (FLAGBITS . 0)) (FILINGSESSION 0 (FLAGBITS . 16)) (FILINGSESSION 0 (BITS . 37)) (FILINGSESSION 2 POINTER) (FILINGSESSION 4 POINTER) (FILINGSESSION 6 POINTER) (FILINGSESSION 8 POINTER) (FILINGSESSION 10 POINTER) (FILINGSESSION 12 POINTER) (FILINGSESSION 14 POINTER) (FILINGSESSION 16 POINTER) (FILINGSESSION 18 POINTER) (FILINGSESSION 20 POINTER) (FILINGSESSION 22 POINTER) (FILINGSESSION 24 POINTER) (FILINGSESSION 26 POINTER) (FILINGSESSION 28 POINTER) (FILINGSESSION 1 (BITS . 15)) (FILINGSESSION 30 (BITS . 15)) (FILINGSESSION 32 POINTER) (FILINGSESSION 34 POINTER) (FILINGSESSION 36 POINTER)) '38) (/DECLAREDATATYPE 'FILINGHANDLE '(FLAG FLAG FLAG FLAG (BITS 4) POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER) '((FILINGHANDLE 0 (FLAGBITS . 0)) (FILINGHANDLE 0 (FLAGBITS . 16)) (FILINGHANDLE 0 (FLAGBITS . 32)) (FILINGHANDLE 0 (FLAGBITS . 48)) (FILINGHANDLE 0 (BITS . 67)) (FILINGHANDLE 2 POINTER) (FILINGHANDLE 4 POINTER) (FILINGHANDLE 6 POINTER) (FILINGHANDLE 8 POINTER) (FILINGHANDLE 10 POINTER) (FILINGHANDLE 12 POINTER) (FILINGHANDLE 14 POINTER) (FILINGHANDLE 1 (BITS . 15)) (FILINGHANDLE 16 (BITS . 15)) (FILINGHANDLE 18 POINTER) (FILINGHANDLE 20 POINTER)) '22) (DECLARE%: EVAL@COMPILE (PUTPROPS WITHOUT.SESSION.MONITOR MACRO [(SESSION . FORMS) (LET ((LOCK (fetch FSSESSIONLOCK of SESSION))) (DECLARE (LOCALVARS LOCK)) (RELEASE.MONITORLOCK LOCK) (PROG1 (PROGN . FORMS) (OBTAIN.MONITORLOCK LOCK]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \NSFILING.CONNECTIONS \NSFILING.DEVICE \NSFILING.NULL.HANDLE \NSFILING.ATTRIBUTES \LISP.TO.NSFILING.ATTRIBUTES \NSFILING.USEFUL.ATTRIBUTE.TYPES \NSFILING.PROGRAM.NAME \NSFILING.ACTIVE.SESSIONS FILING.CACHE.LIMIT *NSFILING-PAGE-CACHE-INCREMENT* *NSFILING-PAGE-CACHE-LIMIT* *NSFILING-RANDOM-ACCESS* *NSFILING-SESSION-TIMEOUT* \NSRANDOM.CHECK.CACHE \NSFILING.PROTECTION.BITS \FILEDEVICES) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (SOURCE) SPPDECLS) (FILESLOAD (LOADCOMP) COURIER) ) (/DECLAREDATATYPE 'FILINGSESSION '(FLAG FLAG (BITS 6) POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER) '((FILINGSESSION 0 (FLAGBITS . 0)) (FILINGSESSION 0 (FLAGBITS . 16)) (FILINGSESSION 0 (BITS . 37)) (FILINGSESSION 2 POINTER) (FILINGSESSION 4 POINTER) (FILINGSESSION 6 POINTER) (FILINGSESSION 8 POINTER) (FILINGSESSION 10 POINTER) (FILINGSESSION 12 POINTER) (FILINGSESSION 14 POINTER) (FILINGSESSION 16 POINTER) (FILINGSESSION 18 POINTER) (FILINGSESSION 20 POINTER) (FILINGSESSION 22 POINTER) (FILINGSESSION 24 POINTER) (FILINGSESSION 26 POINTER) (FILINGSESSION 28 POINTER) (FILINGSESSION 1 (BITS . 15)) (FILINGSESSION 30 (BITS . 15)) (FILINGSESSION 32 POINTER) (FILINGSESSION 34 POINTER) (FILINGSESSION 36 POINTER)) '38) (/DECLAREDATATYPE 'FILINGHANDLE '(FLAG FLAG FLAG FLAG (BITS 4) POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER) '((FILINGHANDLE 0 (FLAGBITS . 0)) (FILINGHANDLE 0 (FLAGBITS . 16)) (FILINGHANDLE 0 (FLAGBITS . 32)) (FILINGHANDLE 0 (FLAGBITS . 48)) (FILINGHANDLE 0 (BITS . 67)) (FILINGHANDLE 2 POINTER) (FILINGHANDLE 4 POINTER) (FILINGHANDLE 6 POINTER) (FILINGHANDLE 8 POINTER) (FILINGHANDLE 10 POINTER) (FILINGHANDLE 12 POINTER) (FILINGHANDLE 14 POINTER) (FILINGHANDLE 1 (BITS . 15)) (FILINGHANDLE 16 (BITS . 15)) (FILINGHANDLE 18 POINTER) (FILINGHANDLE 20 POINTER)) '22) (DEFINEQ (\FILINGSESSION.DEFPRINT [LAMBDA (SESSION STREAM) (* ; "Edited 1-Jun-87 16:58 by bvm:") (COND ((AND COURIERTRACEFILE (TYPENAMEP COURIERTRACEFILE 'WINDOW) (EQ (ffetch (WINDOW DSP) of COURIERTRACEFILE) STREAM)) (* ; "Want it curt in trace output") NIL) (T (\DEFPRINT.BY.NAME SESSION STREAM (fetch FSNAMESTRING of SESSION) "Filing Session on"]) (\FILINGHANDLE.DEFPRINT [LAMBDA (HANDLE STREAM) (* ; "Edited 15-May-87 17:10 by bvm:") (\DEFPRINT.BY.NAME HANDLE STREAM (OR (fetch NSHNAME of HANDLE) (fetch NSHPATHNAME of HANDLE)) "Filing Handle on"]) ) (DEFINEQ (\GET.FILING.ATTRIBUTE [LAMBDA (STREAM PROGRAM) (* bvm%: "25-Jul-86 16:48") (* ;; "Reads a filing attribute value pair from STREAM, returning a list of two elements, (ATTR VALUE); if the attribute is not a known attribute, ATTR is an integer and VALUE is a sequence of unspecified") (bind (ATTR _ (COURIER.READ STREAM NIL 'LONGCARDINAL)) VALUE for X in \NSFILING.ATTRIBUTES when (EQ (CADR X) ATTR) do [RETURN (CONS (CAR X) (COND ((EQ (\WIN STREAM) 0) (* ;  "sequence count zero means no value is here") NIL) (T (* ;  "Ignore sequence count, read as known kind of data") (LIST (COURIER.READ STREAM PROGRAM (CADDR X] finally (* ; "ATTR not recognized") (RETURN (LIST ATTR (COURIER.READ.SEQUENCE STREAM NIL 'UNSPECIFIED]) (\PUT.FILING.ATTRIBUTE [LAMBDA (STREAM ITEM PROGRAM) (* bvm%: "15-Jan-85 16:29") (* ;;; "Writes a filing attribute value pair to STREAM. ITEM is a list of two elements (ATTR VALUE)") (PROG ((ATTR (CAR ITEM)) (VALUE (CADR ITEM)) VALUETYPE) [COND ((NOT (FIXP ATTR)) (for X in \NSFILING.ATTRIBUTES when (EQ (CAR X) ATTR) do (SETQ ATTR (CADR X)) (SETQ VALUETYPE (CADDR X)) (RETURN) finally (ERROR "Unknown Filing attribute" ATTR] (COURIER.WRITE STREAM ATTR NIL 'LONGCARDINAL) (COND (VALUETYPE (COURIER.WRITE.SEQUENCE.UNSPECIFIED STREAM VALUE PROGRAM VALUETYPE)) (T (COURIER.WRITE.SEQUENCE STREAM VALUE PROGRAM 'UNSPECIFIED]) (\GET.SESSION.HANDLE [LAMBDA (STREAM PROGRAM) (* ; "Edited 1-Jun-87 15:52 by bvm:") (* ;; "Read an object of type Filing.Session, which consists of a token (array 2 unspecified) and a verifier.") (CONS (COURIER.READ STREAM NIL 'UNSPECIFIED) (CONS (COURIER.READ STREAM NIL 'UNSPECIFIED) (COURIER.READ STREAM 'AUTHENTICATION 'VERIFIER]) (\PUT.SESSION.HANDLE [LAMBDA (STREAM ITEM PROGRAM) (* ; "Edited 1-Jun-87 15:52 by bvm:") (* ;; "Write a session handle. This is where we can stick hook to increment verifier when we start using strong authentication. Handle = (token token . verifier).") (LET [(HANDLE (OR (LISTP ITEM) [LISTP (ffetch FSSESSIONHANDLE of (\DTEST ITEM 'FILINGSESSION] (ERROR "Attempt to use obsolete session" ITEM] (COURIER.WRITE STREAM (pop HANDLE) NIL 'UNSPECIFIED) (COURIER.WRITE STREAM (pop HANDLE) NIL 'UNSPECIFIED) (COURIER.WRITE STREAM HANDLE 'AUTHENTICATION 'VERIFIER) ITEM]) ) (PUTPROPS FILING.SESSION COURIERDEF (\GET.SESSION.HANDLE \PUT.SESSION.HANDLE)) (PUTPROPS FILING.ATTRIBUTE COURIERDEF (\GET.FILING.ATTRIBUTE \PUT.FILING.ATTRIBUTE)) (DECLARE%: EVAL@COMPILE DOCOPY (RPAQQ \NSFILING.NULL.HANDLE (0 0)) (RPAQQ \NSFILING.PROTECTION.BITS ((READ . 16) (WRITE . 8) (DELETE . 1) (CREATE . 2) (MODIFY . 4))) (RPAQQ \NSFILING.ATTRIBUTES ((CHECKSUM 0 CARDINAL) (CHILDREN.UNIQUELY.NAMED 1 BOOLEAN) (CREATED.BY 2 USER) (CREATED.ON 3 TIME) (FILE.ID 4 FILE.ID) (IS.DIRECTORY 5 BOOLEAN) (IS.TEMPORARY 6 BOOLEAN) (MODIFIED.BY 7 USER) (MODIFIED.ON 8 TIME) (NAME 9 STRING) (NUMBER.OF.CHILDREN 10 CARDINAL) (ORDERING 11 ORDERING) (PARENT.ID 12 FILE.ID) (POSITION 13 (SEQUENCE UNSPECIFIED)) (READ.BY 14 USER) (READ.ON 15 TIME) (SIZE.IN.BYTES 16 LONGCARDINAL) (FILE.TYPE 17 LONGCARDINAL) (VERSION 18 CARDINAL) (ACCESS.LIST 19 ACCESS.LIST) (DEFAULT.ACCESS.LIST 20 ACCESS.LIST) (PATHNAME 21 STRING) (BACKED.UP.ON 23 TIME) (FILED.BY 24 USER) (FILED.ON 25 TIME) (STORED.SIZE 26 LONGCARDINAL) (SUBTREE.SIZE 27 LONGCARDINAL) (SUBTREE.SIZE.LIMIT 28 LONGCARDINAL) (OWNER 4351 STRING))) (RPAQQ \LISP.TO.NSFILING.ATTRIBUTES ((IWRITEDATE MODIFIED.ON) (IREADDATE READ.ON) (ICREATIONDATE CREATED.ON) (CREATIONDATE CREATED.ON) (READDATE READ.ON) (WRITEDATE MODIFIED.ON) (LENGTH SIZE.IN.BYTES) (AUTHOR CREATED.BY) (READER READ.BY) (PROTECTION ACCESS.LIST) (SIZE SIZE.IN.BYTES) (TYPE FILE.TYPE) (FILETYPE FILE.TYPE))) (RPAQ \NSFILING.USEFUL.ATTRIBUTE.TYPES (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(CREATED.ON FILE.ID IS.DIRECTORY PATHNAME SIZE.IN.BYTES FILE.TYPE VERSION ))) ) (RPAQ? FILING.CACHE.LIMIT 6) (RPAQ? NSFILING.SHOW.STATUS T) (RPAQ? FILING.ENUMERATION.DEPTH T) (RPAQ? \NSFILING.LOCK (CREATE.MONITORLOCK 'NSFILING)) (RPAQ? \NSFILING.PROGRAM.NAME 'FILING) (RPAQ? \NSFILING.ACTIVE.SESSIONS ) (RPAQ? *NSFILING-RANDOM-ACCESS* T) (RPAQ? *NSFILING-PAGE-CACHE-LIMIT* 8) (RPAQ? *NSFILING-PAGE-CACHE-INCREMENT* 4) (RPAQ? *NSFILING-SESSION-TIMEOUT* '(900 . 21600)) (RPAQ? \NSRANDOM.CHECK.CACHE ) (* ; "Connection maintenance") (DEFINEQ (\GETFILINGCONNECTION [LAMBDA (DEVICE OLDSTREAM NOLOCK) (* ; "Edited 18-May-87 17:53 by bvm:") (* ;;; "Find an existing session on this fileserver or log in a new one. Returns the session, after obtaining its monitor lock. Caller must have a RESETLST") (LET* [(DEVINFO (fetch DEVICEINFO of DEVICE)) (SESSION (WITH.MONITOR (fetch NSFILINGLOCK of DEVINFO) (bind SESSION while (SETQ SESSION (CAR (fetch NSCONNECTIONS of DEVINFO))) do (* ;  "Awkward control structure because of DREMOVE") [COND ((WITH.MONITOR (fetch FSSESSIONLOCK of SESSION) (\VALID.FILING.CONNECTIONP SESSION)) (* ;  "If good, returned session. If bad, returned possibly an open courier stream") (RETURN SESSION)) (T (SETQ OLDSTREAM (\NSFILING.DISCARD.SESSION SESSION DEVICE (NULL OLDSTREAM] finally (RETURN (\NSFILING.LOGIN DEVINFO DEVICE OLDSTREAM))))] (COND (SESSION (COND ((NOT NOLOCK) (* ;  "Grab lock here outside of our own WITH.MONITOR. Unwindsave info goes on caller's reset") (OBTAIN.MONITORLOCK (fetch FSSESSIONLOCK of SESSION) NIL T))) SESSION]) (\NSFILING.GET.NEW.SESSION [LAMBDA (OLDSESSION DEVICE NOLOCK) (* ; "Edited 22-May-87 14:42 by bvm:") (* ;; "Called when OLDSESSION has encountered a session error (TokenInvalid). Discards knowledge of OLDSESSION and establishes a new one. Unless NOLOCK is true, a lock is obtained on the new session (caller must have RESETLST).") (\GETFILINGCONNECTION DEVICE (\NSFILING.DISCARD.SESSION OLDSESSION DEVICE T) NOLOCK]) (\NSFILING.GET.STREAM [LAMBDA (CONNECTION KEEPSTREAM) (* ; "Edited 9-Jun-87 15:41 by bvm:") (* ;;; "Get a Courier stream for CONNECTION and return it. If KEEPSTREAM is true, we want the stream to persist after the enclosing RESETLST exits, else we release the stream on its exit") (PROG [(STREAMPAIR (find PAIR in (fetch FSCOURIERSTREAMS of CONNECTION) suchthat (NULL (CDR PAIR] (COND (STREAMPAIR (RPLACD STREAMPAIR T)) [(SETQ STREAMPAIR (\NSFILING.COURIER.OPEN (fetch FSADDRESS of CONNECTION) (fetch FSPROCESSNAME of CONNECTION))) (push (fetch FSCOURIERSTREAMS of CONNECTION) (SETQ STREAMPAIR (CONS STREAMPAIR T] (T (RETURN NIL))) (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (CONNECTION PAIR KEEPSTREAM) (COND [RESETSTATE (SPP.CLOSE (CAR PAIR) T) (replace FSCOURIERSTREAMS of CONNECTION with (DREMOVE PAIR (fetch FSCOURIERSTREAMS of CONNECTION] ((NOT KEEPSTREAM) (RPLACD PAIR NIL] CONNECTION STREAMPAIR KEEPSTREAM)) (RETURN STREAMPAIR]) (\NSFILING.COURIER.OPEN [LAMBDA (ADDRESS NAME) (* bvm%: "11-Dec-85 12:57") (COURIER.OPEN ADDRESS NIL T NAME (FUNCTION \NSFILING.WHENCLOSED) (CONSTANT (LIST 'ERRORHANDLER (FUNCTION \NSFILING.ERRORHANDLER]) (\NSFILING.CLOSE.BULKSTREAM [LAMBDA (CONNECTION STREAM) (* ; "Edited 20-Nov-87 18:47 by bvm:") (COND ((AND STREAM (OPENP STREAM)) (CLOSEF STREAM) (\NSFILING.RELEASE.BULKSTREAM CONNECTION STREAM RESETSTATE]) (\NSFILING.RELEASE.BULKSTREAM [LAMBDA (CONNECTION STREAM ABORT?) (* bvm%: "11-Dec-85 14:42") (LET ((STREAMS (fetch FSCOURIERSTREAMS of CONNECTION))) (for PAIR in STREAMS when (EQ (CDR PAIR) STREAM) do (COND (ABORT? (* ; "Unknown state, bag it") (SPP.CLOSE (CAR PAIR) T) (replace FSCOURIERSTREAMS of CONNECTION with (DREMOVE PAIR STREAMS) )) (T (* ; "Stream now free") (RPLACD PAIR NIL))) (RETURN]) (FILING.CALL [LAMBDA ARGS (* ; "Edited 5-Aug-87 12:39 by bvm:") (* ;; "Call a FILING procedure. procedure, in a style similar to COURIER.CALL --- (FILING.CALL session procedure-name arg1 ... argN) --- Returns the result of the remote procedure, or a list of such results if it returns more than one. A single flag NoErrorFlg can be optionally appended to the arglist -- If NoErrorFlg is NOERROR, return NIL if the Courier program aborts with an error; if RETURNERRORS, then return an expression (ERROR ERRNAME . args) on error.") (* ;; "Copied from COURIER.CALL") (PROG (SESSION PROCEDURE PROGRAM STREAM NARGS ARGLIST NOERRORFLG PGMDEF PROCDEF ARGTYPES KEEPSTREAM ABSOLUTELY-NO-ERROR) [COND ((< ARGS 2) (RETURN (ERROR "Malformed FILING.CALL"] [if (NULL (SETQ SESSION (ARG ARGS 1))) then (* ; "session killed, don't even try") (RETURN '(ERROR SESSION.ERROR TokenInvalid] (SETQ PGMDEF (fetch FSPROTOCOLDEF of SESSION)) (SETQ PROCDEF (\GET.COURIER.DEFINITION (SETQ PROGRAM (fetch FSPROTOCOLNAME of SESSION)) (SETQ PROCEDURE (ARG ARGS 2)) 'PROCEDURES PGMDEF)) [SETQ NARGS (LENGTH (SETQ ARGTYPES (fetch (COURIERFN ARGS) of PROCDEF] [OR (SELECTQ (- ARGS NARGS) (2 (* ; "Exactly right") T) ((3 4) (* ; "Extra arg is errorflg") (AND (SELECTQ (SETQ NOERRORFLG (ARG ARGS (+ NARGS 3))) (NOERROR (* ;  "Caller wants not to hassle with errors, but we always want to see session errors") (SETQ NOERRORFLG 'RETURNERRORS) (SETQ ABSOLUTELY-NO-ERROR T)) ((NOERROR RETURNERRORS NIL) T) NIL) (COND [(EQ (- ARGS NARGS) 4) (SETQ KEEPSTREAM (EQ (ARG ARGS (+ NARGS 4)) 'KEEPSTREAM] (T T)))) NIL) (RETURN (ERROR "Wrong number of arguments to Courier procedure" (CONS PROGRAM PROCEDURE ] (SETQ ARGLIST (for I from 3 to (+ NARGS 2) collect (ARG ARGS I))) (RETURN (WITH.MONITOR (fetch FSSESSIONLOCK of SESSION) (* ; "Note: implicit RESETLST") [PROG ((FAILED 0) STREAM RESULT) NEWSTREAM [COND [(NOT (LISTP (fetch FSSESSIONHANDLE of SESSION))) (* ;  "Session is dead, don't even try the call") (RETURN '(ERROR SESSION.ERROR TokenInvalid] ((NULL (SETQ STREAM (\NSFILING.GET.STREAM SESSION KEEPSTREAM))) (COND (ABSOLUTELY-NO-ERROR (RETURN NIL)) (T (COND ((EQ (add FAILED 1) 2) (* ; "Don't complain the first time--it seems like it often takes a while to wake up a sleepy server. Perhaps should adjust this in SPP.OPEN.") (PRINTOUT PROMPTWINDOW T "No response from " (fetch FSNAMESTRING of SESSION) ";" " will keep trying."))) (GO NEWSTREAM] (SETQ RESULT (COURIER.EXECUTE.CALL (CAR STREAM) PROGRAM PGMDEF PROCEDURE PROCDEF ARGLIST ARGTYPES NOERRORFLG)) [COND ((EQ RESULT 'STREAM.LOST) (GO NEWSTREAM)) ((AND (LISTP RESULT) (EQ (CAR RESULT) 'ERROR) (SELECTQ (CADR RESULT) (SESSION.ERROR (* ; "Dead session") T) (REJECT (SELECTQ (CAADDR RESULT) ((NoSuchService WrongVersionOfService) (* ;; "Server not responding to Filing? Could happen if server crashed and has just come back. In any case, our old session is clearly dead--we masquerade here as session error and let LOGIN worry about proceeding.") (SETQ RESULT '(ERROR SESSION.ERROR TokenInvalid))) NIL)) NIL)) (* ;; "Session is dead, don't let anybody even think about using it again. If caller is clever, however, he may reuse the stream to login afresh.") (replace FSSESSIONHANDLE of SESSION with :CLOSED)) (T (COND ((NEQ PROCEDURE 'CONTINUE) (* ; "Note real activity") (replace FSREALACTIVITY of SESSION with T)) ((fetch FSREALACTIVITY of SESSION) (* ;  "transfer activity timer to real timer") (\BLT (OR (fetch FSLASTREALACTIVITYTIMER of SESSION) (replace FSLASTREALACTIVITYTIMER of SESSION with (\CREATECELL \FIXP))) (fetch FSSESSIONTIMER of SESSION) WORDSPERCELL) (replace FSREALACTIVITY of SESSION with NIL))) (\DAYTIME0 (fetch FSSESSIONTIMER of SESSION)) (* ; "Note time of last activity") (COND (KEEPSTREAM (RPLACD STREAM (COND ((TYPENAMEP RESULT 'STREAM) (* ;  "Save bulk stream for later linkup") RESULT) (T (* ;  "Were expecting bulk stream but failed, so release main stream") NIL] (RETURN (COND ((AND ABSOLUTELY-NO-ERROR (LISTP RESULT) (EQ (CAR RESULT) 'ERROR)) (* ; "Manually suppress this error.") NIL) (T RESULT])]) (\NSFILING.LOGIN [LAMBDA (DEVINFO DEVICE STREAM) (* ; "Edited 9-Feb-88 15:58 by bvm:") (RESETLST [RESETSAVE NIL (LIST (FUNCTION (LAMBDA NIL (* ; "Close any open stream on error") (AND STREAM RESETSTATE (SPP.CLOSE STREAM] (LET ((FILESERVER (fetch NSFILESERVER of DEVINFO)) (PROCNAME (fetch NSFILINGNAME of DEVINFO)) (PROGRAM \NSFILING.PROGRAM.NAME) ADDRESS SERVERNAME SERVERNSNAME SESSIONHANDLE SESSION CREDENTIALS NEEDLOGIN PROBLEM OLDPROBLEM LOGINNAME RANDEVICE) (SETQ SERVERNAME (MKATOM (NSNAME.TO.STRING (SETQ SERVERNSNAME (fetch NSFSPARSEDNAME of FILESERVER)) T))) (SETQ ADDRESS (CAR (fetch NSFSADDRESSES of FILESERVER))) (COND ([when [COND ([NOT (SETQ CREDENTIALS (\INTERNAL/GETPASSWORD SERVERNAME NEEDLOGIN NIL [COND (NEEDLOGIN (PROG1 (SELECTQ NEEDLOGIN (VerifierInvalid "Incorrect Password") (CredentialsInvalid "Invalid User Name") (CONCAT "Login failed -- " NEEDLOGIN)) (SETQ NEEDLOGIN NIL] NIL 'NS] (* ; "User aborted") (RETURN NIL)) ([NOT (OR STREAM (SETQ STREAM (\NSFILING.COURIER.OPEN ADDRESS PROCNAME] (* ; "No response") (SETQ PROBLEM T)) (T (SETQ LOGINNAME (CAR CREDENTIALS)) (SETQ CREDENTIALS (NS.MAKE.SIMPLE.CREDENTIALS CREDENTIALS)) (SETQ SESSIONHANDLE (COURIER.CALL STREAM PROGRAM 'LOGON SERVERNSNAME (CAR CREDENTIALS) (CDR CREDENTIALS) 'RETURNERRORS)) (COND ((EQ SESSIONHANDLE 'STREAM.LOST) (* ;  "Stream was idle too long before we made that call, so toss it and get a new one.") (SETQ STREAM NIL)) ((NULL SESSIONHANDLE) (* ;  "Shouldn't happen, treat as no response") (SETQ PROBLEM T)) ((NEQ (CAR SESSIONHANDLE) 'ERROR) (* ; "Success") (RETURN SESSIONHANDLE)) (T (SELECTQ (CADR SESSIONHANDLE) (REJECT (* ; "Can't handle this call") (SELECTQ (CAR (CADDR SESSIONHANDLE)) (WrongVersionOfService (COND ((EQ PROGRAM 'FILING) (SETQ PROGRAM 'FILING.4) (* ;  "Quietly try older version next time around") NIL) (T (* ; "Doesn't run any version we talk") T))) (NoSuchService (* ;  "Can happen when you boot a file server. Keep trying") (SETQ PROBLEM 'NoSuchService)) T)) (AUTHENTICATION.ERROR (SETQ NEEDLOGIN (CADDR SESSIONHANDLE)) (* ;  "Login incorrect, prompt next time around") NIL) (SERVICE.ERROR (SELECTQ (SETQ PROBLEM (CADDR SESSIONHANDLE)) ((CannotAuthenticate ServiceFull) (* ; "hopefully transient problems") T) (UnknownService (* ; "No service by that name at this node. This is quite transient in the case where the server was just booted") (if (NEQ OLDPROBLEM 'NoSuchService) then (SETQ PROBLEM NIL)) T) (PROGN (SETQ PROBLEM NIL) (* ;  "Let other problems cause a break") T))) T] do (* ; "Some sort of problem encountered. PROBLEM set non-nil if it's worthwhile to keep trying, else an unexpected problem is stored in SESSIONHANDLE") (COND ((NULL PROBLEM) (SPP.CLOSE STREAM) (SETQ STREAM NIL) (CL:CERROR "Try again to connect" "Error while logging on to ~A: ~A~%%(Type OK to try again)" SERVERNAME (CDR SESSIONHANDLE))) (T (COND ((NEQ PROBLEM OLDPROBLEM) (PRINTOUT PROMPTWINDOW T "Can't connect to " SERVERNAME " because: " (SELECTQ (SETQ OLDPROBLEM PROBLEM) (T "No response") (NoSuchService "File Service not running") OLDPROBLEM) ";" " will keep trying."))) (SETQ PROBLEM NIL) (DISMISS (COND ((EQ OLDPROBLEM T) (* ;  "No explicit response, just try soon") 5000) (T (* ;  "It's likely to take a while to get going") 30000] (* ;; "Succeeded in logging in") (if (AND OLDPROBLEM (NEQ OLDPROBLEM T)) then (* ; "Let us know when successful") (PRINTOUT PROMPTWINDOW T "Got connection to " SERVERNAME)) (push \NSFILING.ACTIVE.SESSIONS (SETQ SESSION (create FILINGSESSION FSADDRESS _ ADDRESS FSPARSEDNAME _ SERVERNSNAME FSNAMESTRING _ SERVERNAME FSPROCESSNAME _ PROCNAME FSCOURIERSTREAMS _ (LIST (CONS STREAM)) FSSESSIONHANDLE _ SESSIONHANDLE FSPROTOCOLNAME _ PROGRAM FSDEVICENAME _ (fetch (FDEV DEVICENAME) of DEVICE) FSPROTOCOLDEF _ (\GET.COURIERPROGRAM PROGRAM) FSSESSIONLOCK _ (CREATE.MONITORLOCK SERVERNAME) FSSESSIONTIMER _ (\CREATECELL \FIXP) FSLOGINNAME _ LOGINNAME))) (\NSFILING.SET.CONTINUANCE SESSION) (push (fetch NSCONNECTIONS of DEVINFO) SESSION) (COND ((AND (EQ PROGRAM 'FILING) (NOT (fetch NSRANDOMDEVICE of DEVINFO))) (* ; "Create a second device to use for random-access streams. This is an invisible device, so only needs methods for things you can do to open streams") [replace NSRANDOMDEVICE of DEVINFO with (SETQ RANDEVICE (\MAKE.PMAP.DEVICE (create FDEV DEVICENAME _ (fetch FSNAMESTRING of SESSION) OPENFILE _ (FUNCTION \NSRANDOM.OPENFILE) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION \NSRANDOM.CLOSEFILE) GETFILEINFO _ (FUNCTION \NSFILING.GETFILEINFO ) SETFILEINFO _ (FUNCTION \NSFILING.SETFILEINFO ) REGISTERFILE _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) READPAGES _ (FUNCTION \NSRANDOM.READPAGES) WRITEPAGES _ (FUNCTION \NSRANDOM.WRITEPAGES) TRUNCATEFILE _ (FUNCTION \NSRANDOM.TRUNCATEFILE) DEVICEINFO _ DEVICE REMOTEP _ T SUBDIRECTORIES _ T] (replace SETEOFPTR of RANDEVICE with (FUNCTION \NSRANDOM.SETEOFPTR)) (* ;  "Have to do this after \make.pmap.device") )) SESSION))))]) (\NSFILING.AFTER.LOGIN [LAMBDA (HOST USER) (* bvm%: "31-Jan-86 17:45") (for SESSION in \NSFILING.ACTIVE.SESSIONS when (OR (NULL HOST) (STRING-EQUAL HOST (fetch FSNAMESTRING of SESSION))) do (* ;  "Note that the login has changed for this host") (replace FSLOGINCHANGED of SESSION with T]) (\NSFILING.SET.CONTINUANCE [LAMBDA (SESSION) (* ; "Edited 5-Jun-87 18:11 by bvm:") (LET [(SECONDS (FILING.CALL SESSION 'CONTINUE SESSION 'RETURNERRORS] (COND ((FIXP SECONDS) (* ;; "Continue value is number of seconds we can be idle. Take 3/4 of what the server says, just to be conservative") (replace FSCONTINUANCE of SESSION with (IMIN (IQUOTIENT (ITIMES SECONDS 3) 4) MAX.SMALLP)) T]) (\NSFILING.LOGOUT [LAMBDA (SESSION) (* ; "Edited 5-Jun-87 17:54 by bvm:") (FILING.CALL SESSION 'LOGOFF SESSION 'NOERROR]) (\NSFILING.DISCARD.SESSION [LAMBDA (SESSION DEVICE KEEPSTREAM) (* ; "Edited 2-Jun-87 17:55 by bvm:") (* ;; "Called when SESSION is known to be dead. If KEEPSTREAM is true, we return some active stream, if any, otherwise all streams are closed.") (SETQ \NSFILING.ACTIVE.SESSIONS (DREMOVE SESSION \NSFILING.ACTIVE.SESSIONS)) (change (fetch NSCONNECTIONS of (fetch DEVICEINFO of DEVICE)) (DREMOVE SESSION DATUM)) (PROG1 (for PAIR in (fetch FSCOURIERSTREAMS of SESSION) bind KEPT do [COND ((AND KEEPSTREAM (NULL KEPT) (NULL (CDR PAIR))) (* ; "Keep this stream for caller") (SETQ KEPT (CAR PAIR))) (T (CLOSEF (CAR PAIR] finally (replace FSCOURIERSTREAMS of SESSION with NIL) (RETURN KEPT)) (replace FSSESSIONHANDLE of SESSION with :CLOSED) (* ;  "Let no one be tempted to use it again.") (* ;; "Finally, release lock if we have it. This avoids deadlock in the case where we try to get a new session, but somebody before us is already inside \GETFILINGCONNECTION holding on to this session lock.") (RELEASE.MONITORLOCK (fetch FSSESSIONLOCK of SESSION)))]) (\VALID.FILING.CONNECTIONP [LAMBDA (SESSION) (* ; "Edited 5-Jun-87 18:11 by bvm:") (* ;; "true if this is a useable connection") (COND ([AND (fetch FSLOGINCHANGED of SESSION) (NOT (STRING-EQUAL (CAR (\INTERNAL/GETPASSWORD (fetch FSNAMESTRING of SESSION))) (fetch FSLOGINNAME of SESSION] (* ;  "Want new session because credentials changed") (COND ((NOT (for PAIR in (fetch FSCOURIERSTREAMS of SESSION) thereis (CDR PAIR))) (* ;; "Can't do this if someone is using the session!") (\NSFILING.LOGOUT SESSION))) NIL) ((\SECONDSCLOCKGREATERP (fetch FSSESSIONTIMER of SESSION) (fetch FSCONTINUANCE of SESSION)) (* ;  "Our conservative timer has expired, but try to use session anyway") (BLOCK) (BLOCK) (* ;  "Let spp process run, possibly purge streams") (COND ((\NSFILING.SET.CONTINUANCE SESSION) SESSION))) (T (* ;  "Timer not expired, so we're safe, it says here") SESSION]) (\NSFILING.CLOSE.CONNECTIONS [LAMBDA (DEVICE ABORT?) (* ; "Edited 30-Nov-87 13:18 by bvm:") (* ;; "ABORT? = {NIL | :TEST | :ABORT}, meaning {do logout | logout if we haven't timed out | never bother logging out}.") (RESETLST (OBTAIN.MONITORLOCK (fetch NSFILINGLOCK of (fetch (FDEV DEVICEINFO) of DEVICE )) (EQ ABORT? :ABORT) T) (* ; "Note that if ABORT = :ABORT we don't ever wait for the lock--we're probably screwed anyway if some other process has the session lock at the instant the SAVEVM, etc. happened.") (LET ((DEVINFO (fetch (FDEV DEVICEINFO) of DEVICE)) SESSION) (if (fetch NSWATCHERPROC of DEVINFO) then (* ; "Don't need a watcher any more") (DEL.PROCESS (fetch NSWATCHERPROC of DEVINFO))) (while (SETQ SESSION (CAR (fetch NSCONNECTIONS of DEVINFO))) do (COND ([SELECTQ ABORT? (NIL T) (:ABORT (* ;  "don't bother trying to LOGOUT, we know it's futile") NIL) (PROGN (* ;  "Assume session is timed out if session timer expired much longer ago than stated continuance.") (NOT (\SECONDSCLOCKGREATERP (fetch FSSESSIONTIMER of SESSION) (TIMES 2 (fetch FSCONTINUANCE of SESSION] (for PAIR in (APPEND (fetch FSCOURIERSTREAMS of SESSION)) when (CDR PAIR) do (* ; "Someone has a courier stream open on this session, e.g., a bulk data retrieve or write. If we try to LOGOUT now we will hang, so bash the stream") (SPP.CLOSE (CAR PAIR) T) (BLOCK)) (\NSFILING.LOGOUT SESSION))) (\NSFILING.DISCARD.SESSION SESSION DEVICE))) (for STREAM in (fetch (FDEV OPENFILELST) of DEVICE) do (* ; "invalidate stream's sessions") (replace NSFILING.CONNECTION of STREAM with NIL)))]) (BREAK.NSFILING.CONNECTION [LAMBDA (HOST DEVICE) (* ; "Edited 26-May-87 17:06 by bvm:") (COND ((EQ HOST T) (for DEV in \FILEDEVICES when (AND (EQ (fetch (FDEV OPENFILE) of DEV) (FUNCTION \NSFILING.OPENFILE)) (fetch NSCONNECTIONS of (fetch (FDEV DEVICEINFO) of DEV))) collect (\NSFILING.CLOSE.CONNECTIONS DEV) (fetch (FDEV DEVICENAME) of DEV))) (T (LET [(DEV (OR DEVICE (\GETDEVICEFROMNAME (\CANONICAL.NSHOSTNAME HOST) T T] (COND (DEV (\NSFILING.CLOSE.CONNECTIONS DEV) T]) ) (ADDTOVAR \AFTERLOGINFNS \NSFILING.AFTER.LOGIN) (* ; "Support") (DEFINEQ (\NSFILING.CONNECT [LAMBDA (SESSION DIRPATH REALREQUIRED CREATE?) (* ; "Edited 14-Sep-87 14:06 by bvm:") (* ;; "Follow the list of directories in DIRPATH and return the handle for the final one. The special case when DIRPATH is NIL is equivalent to connecting to the root directory. Uses cached paths to avoid useless reconnecting.") (PROG (NEW.HANDLE NSPATHNAME) [COND ((SETQ NEW.HANDLE (\NSFILING.LOOKUP.CACHE SESSION DIRPATH)) (* ;  "Nothing needs to be done because we're already connected to this path.") (RETURN (AND NEW.HANDLE (fetch NSHDIRECTORYP of NEW.HANDLE) NEW.HANDLE] [SETQ NSPATHNAME (COND [(CDR DIRPATH) (CONCATLIST (CDR (for DIR in DIRPATH join (LIST '/ DIR] (T (CAR DIRPATH] (SETQ NEW.HANDLE (FILING.CALL SESSION 'OPEN [AND NSPATHNAME `((PATHNAME ,NSPATHNAME] \NSFILING.NULL.HANDLE NIL SESSION 'RETURNERRORS)) (SELECTQ (CAR NEW.HANDLE) (NIL (* ; "Utter failure") (RETURN)) (ERROR (COND ((AND (EQ (CADDR NEW.HANDLE) 'FileNotFound) (SETQ NEW.HANDLE (\NSFILING.MAYBE.CREATE SESSION DIRPATH CREATE?))) (* ; "Successfully created") ) (T (* ; "Failed for some other reason") (RETURN)))) NIL) (RETURN (AND [NLISTP (SETQ NEW.HANDLE (\NSFILING.ADD.TO.CACHE SESSION (create FILINGHANDLE NSHDIRECTORYPATH _ DIRPATH NSHDATUM _ NEW.HANDLE] (fetch NSHDIRECTORYP of NEW.HANDLE) NEW.HANDLE]) (\NSFILING.MAYBE.CREATE [LAMBDA (SESSION DIRLST CREATE?) (* ; "Edited 1-Jun-87 16:06 by bvm:") (* ;;; "Called to possibly create a nonexistent subdirectory. DIRLST is a list of subdirectories from root to leaf.") (LET (OLDHANDLE NEW.DIR) (AND (SELECTQ CREATE? (:ASK (SETQ CREATE? :ASKED) (* ;  "flag needed on recursive calls to show we asked up here") (EQ 'Y (ASKUSER DWIMWAIT 'Y (CONCAT "Create subdirectory {" (fetch FSNAMESTRING of SESSION) "}<" [CONCATLIST (for DIR in DIRLST join (LIST DIR '>] "? ")))) (NIL NIL) T) (SETQ OLDHANDLE (\NSFILING.CONNECT SESSION (for TAIL on DIRLST collect (CAR TAIL) while (CDR TAIL) finally (SETQ NEW.DIR (CAR TAIL))) T CREATE?)) (COND ((AND (SETQ OLDHANDLE (FILING.CALL SESSION 'CREATE (fetch NSHDATUM of OLDHANDLE) `((NAME ,(\NSFILING.REMOVEQUOTES NEW.DIR)) (IS.DIRECTORY T) (FILE.TYPE 1)) NIL SESSION 'RETURNERRORS)) (NEQ (CAR OLDHANDLE) 'ERROR)) (* ; "Success") OLDHANDLE) (T (SELECTQ CREATE? ((:ASK :ASKED) (* ;  "Interactive use--let user know why we failed.") (CL:ERROR "Could not create ~A because of ~A: ~A" [CONCATLIST (LIST* "{" (fetch FSNAMESTRING of SESSION) "}<" (for DIR in DIRLST join (LIST DIR '>] (CADR OLDHANDLE) (STRING (CADDR OLDHANDLE))) NIL) NIL]) (\NSFILING.REMOVEQUOTES [LAMBDA (NAME) (* bvm%: "24-Sep-85 15:17") (* ;;; "Removes quoting characters from NAME") (COND [(STRPOS "'" NAME) (CONCATCODES (bind (I _ 0) CH while (SETQ CH (NTHCHARCODE NAME (add I 1))) collect (COND ((EQ CH (CHARCODE %')) (OR (NTHCHARCODE NAME (add I 1)) CH)) (T CH] (T NAME]) (\NSFILING.ADDQUOTES [LAMBDA (NAME ALREADYQUOTED) (* bvm%: "27-Jun-86 11:16") (* ;;; "Returns NAME with funny characters (file name delimeters) quoted. If ALREADYQUOTED is true, then any quote characters in NAME are interpreted as quoting the next char, rather than being a funny char that needs to be quoted") (COND [[for CH instring (OR (STRINGP NAME) (SETQ NAME (MKSTRING NAME))) bind QUOTED do (COND (QUOTED (SETQ QUOTED (SETQ CH NIL))) (T (SELCHARQ CH ((%: ; < > } %] /) (RETURN T)) (%' (COND (ALREADYQUOTED (SETQ QUOTED T)) (T (RETURN T)))) NIL))) finally (COND ((EQ CH (CHARCODE ".")) (* ;; "Name ending in period, the period is significant and must be quoted, else we would leave it out as being an extensionless file indicator") (RETURN T] (* ;  "Yes, there is something funny, so it's worth constructing a whole new name") (CONCATCODES (for CH instring NAME bind QUOTED NAMECHARS LASTCH do (COND (QUOTED (SETQ QUOTED NIL)) (T (SELCHARQ (SETQ LASTCH CH) ((%: ; < > } %] /) (push NAMECHARS (CHARCODE %'))) (%' [COND (ALREADYQUOTED (SETQ QUOTED T)) (T (push NAMECHARS (CHARCODE %']) NIL))) (push NAMECHARS CH) finally [COND ((EQ LASTCH (CHARCODE ".")) (* ; "See ugliness above") (RPLACD NAMECHARS (CONS (CHARCODE %') (CDR NAMECHARS] (RETURN (REVERSE NAMECHARS] (T NAME]) (\FILING.ATTRIBUTE.TYPE.SEQUENCE [LAMBDA (ATTRIBUTETYPES) (* ecc " 3-AUG-83 16:39") (for ATTR in ATTRIBUTETYPES collect (\FILING.ATTRIBUTE.TYPE ATTR]) (\FILING.ATTRIBUTE.TYPE [LAMBDA (ATTR NOERRORFLG) (* ; "Edited 3-Jun-87 16:34 by bvm:") (OR (FIXP ATTR) (for X in \NSFILING.ATTRIBUTES do [COND ((EQ (CAR X) ATTR) (RETURN (CADR X] finally (OR NOERRORFLG (ERROR "Unknown Filing attribute" ATTR]) (\LISP.TO.NSFILING.ATTRIBUTE [LAMBDA (ATTRIBUTE VALUE) (* ; "Edited 18-Apr-88 15:00 by bvm") (* ;; "Convert a Lisp file attribute and its value to a filing attr/val pair (list of two elements), or NIL if we can't figure it out.") (LET (X) [SELECTQ ATTRIBUTE (WRITEDATE (SETQ ATTRIBUTE 'MODIFIED.ON) (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (READDATE (SETQ ATTRIBUTE 'READ.ON) (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (CREATIONDATE (SETQ ATTRIBUTE 'CREATED.ON) (SETQ VALUE (OR (IDATE VALUE) (LISPERROR "ILLEGAL ARG" VALUE)))) (TYPE (SETQ ATTRIBUTE 'FILE.TYPE) (SETQ VALUE (OR (\FILETYPE.FROM.TYPE VALUE) \NSFILING.TYPE.BINARY))) (SIZE (SETQ ATTRIBUTE 'SIZE.IN.BYTES) (SETQ VALUE (UNFOLD VALUE BYTESPERPAGE))) (COND ((SETQ X (ASSOC ATTRIBUTE \LISP.TO.NSFILING.ATTRIBUTES)) (SETQ ATTRIBUTE (CADR X] (COND ((SETQ X (CADDR (ASSOC ATTRIBUTE \NSFILING.ATTRIBUTES))) (* ;  "Check that the value is reasonable before we die deep in a courier call. X = courier type.") (LET ((COERCEDVALUE VALUE)) (OR (SELECTQ X ((CARDINAL UNSPECIFIED) (AND (SMALLP VALUE) (>= VALUE 0))) (INTEGER (SMALLP VALUE)) ((LONGCARDINAL LONGINTEGER TIME) (FIXP VALUE)) (USER (SETQ COERCEDVALUE (PARSE.NSNAME VALUE))) (ACCESS.LIST (* ;  "A protection value is complicated") [AND (OR (NULL VALUE) (LISTP VALUE)) (SETQ COERCEDVALUE (for ENTRY in VALUE collect [LIST (PARSE.NSNAME (CAR ENTRY)) (COND ([AND (LISTP (CADR ENTRY)) (for ACCESS in (CADR ENTRY) always (MEMB ACCESS '(ALL READ WRITE OWNER ADD REMOVE ] (CADR ENTRY)) (T (RETURN] finally (RETURN (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ $$VAL DEFAULTED _ NIL]) (PROGN (* ;  "accept anything, hope for the best") T)) (\ILLEGAL.ARG VALUE)) (LIST ATTRIBUTE COERCEDVALUE))) ((FIXP ATTRIBUTE) (* ;  "This is how to get raw, unregistered attributes. Value must be sequence unspecified") (COND ([for (TL _ VALUE) by (CDR TL) while TL always (AND (LISTP TL) (SMALLP (CAR TL] (LIST ATTRIBUTE VALUE)) (T (\ILLEGAL.ARG VALUE]) ) (* ; "FILINGHANDLE stuff") (DEFINEQ (\NSFILING.GETFILE [LAMBDA (DEVICE FILENAME ACCESS RECOG OPTION PARAMETERS DIROK SEQUENTIAL OLDSTREAM) (* ; "Edited 19-Aug-88 17:17 by bvm") (* ;; "Opens FILENAME for specified ACCESS and RECOG, returning a stream. If OPTION is NAME, ATTRIBUTES, or HANDLE, just return the appropriate information instead of a stream. If OPTION is DIRECTORY, return T or NIL if FILENAME is a directory or not -- PARAMETERS gives the CREATE? option in case the directory doesn't exist. If ACCESS is not NONE, then PARAMETERS gives extra parameters for the open.") (RESETLST [PROG ((NAME "") VERSION EXPLICIT-VERSION SESSION OLDHANDLE FILE.ID HANDLE FILESTREAM FULLNAME PARSE ROOTNAME DIRPATH RANDEVICE HAVELOCK SERIALIZE) (COND ((NOT (SETQ SESSION (\GETFILINGCONNECTION DEVICE))) (RETURN NIL))) [COND ((EQ ACCESS 'SERIALIZE) (* ;  "Like INPUT, but retrieve a serialized stream on file") (SETQ ACCESS 'INPUT) (SETQ SERIALIZE 'SERIALIZE) (SETQ SEQUENTIAL T)) ((AND (NOT SEQUENTIAL) (NOT OPTION) *NSFILING-RANDOM-ACCESS*) (* ;  "RANDEVICE set if we want to open a randaccess stream") (SETQ RANDEVICE (fetch NSRANDOMDEVICE of (fetch DEVICEINFO of DEVICE] RETRY [COND [(SETQ HANDLE (\NSFILING.LOOKUP.CACHE SESSION FILENAME)) (* ; "Cache hit") (COND (OPTION (* ;  "Got handle, so just do what the option said (else fall thru and try to open a file)") (GO HANDLE.OPTION] ((AND (LISTP FILENAME) (EQ (CAR FILENAME) 'FILE.ID)) (* ; "Identifying file by ID, take shortcut. Do this second just in case we have cached this file already") (SETQ FILE.ID (CADR FILENAME))) (T (* ;  "Parse the name and go thru all this hassle") (SETQ PARSE (\NSFILING.PARSE.FILENAME FILENAME)) (SETQ DIRPATH (fetch NSDIRECTORIES of PARSE)) (COND ((NULL DIRPATH) (* ;  "No directories specified, so is illegal name") (GO FILE.NOT.FOUND)) [(EQ OPTION 'DIRECTORY) (RETURN (AND (fetch NSDIRECTORYP of PARSE) (SETQ HANDLE (\NSFILING.CONNECT SESSION DIRPATH T PARAMETERS )) (GO HANDLE.OPTION] ((AND (fetch NSDIRECTORYP of PARSE) (NOT DIROK)) (* ;  "No name, just a directory. Failure unless caller said a directory file is ok") (GO FILE.NOT.FOUND))) (SETQ EXPLICIT-VERSION (fetch NSVERSION of PARSE)) (SETQ ROOTNAME (fetch NSROOTNAME of PARSE] [COND (HANDLE (* ;  "We have an open file handle from the cache") ) [FILE.ID (* ;  "Try to open an existing file by ID.") (COND ([SETQ HANDLE (\NSFILING.OPEN.HANDLE SESSION `((FILE.ID ,FILE.ID)) (AND RANDEVICE (SELECTQ ACCESS ((BOTH APPEND) 'OUTPUT) ACCESS] (SETQ HAVELOCK RANDEVICE)) (T (GO FILE.NOT.FOUND] (T (* ; "open by name") (SETQ OLDHANDLE (\NSFILING.OPEN.HANDLE SESSION [\NSFILING.COMPOSE.PATHNAME DIRPATH ROOTNAME (OR EXPLICIT-VERSION (SELECTQ RECOG (OLDEST '-) '+] (AND RANDEVICE (SETQ HAVELOCK (SELECTQ ACCESS ((OUTPUT BOTH APPEND) (* ; "When opening for output, only get lock right now if we know we will be playing with the old file.") (AND (OR EXPLICIT-VERSION (NEQ RECOG 'NEW)) 'OUTPUT)) (INPUT ACCESS) NIL))) 'RETURNERRORS)) (COND [[OR (NULL OLDHANDLE) (AND (LISTP OLDHANDLE) (EQ (CADR OLDHANDLE) 'ACCESS.ERROR) (EQ (CADDR OLDHANDLE) 'FileNotFound] (* ;  "No file of any version exists by this name") (SETQ HAVELOCK NIL) (SELECTQ RECOG ((OLD OLDEST) (* ;  "No version exists, so certainly this one doesn't") (RETURN NIL)) (COND ((EQ ACCESS 'INPUT) (* ;  "Version given explicitly, file does not exist") (RETURN NIL)) ((NULL EXPLICIT-VERSION) (* ;  "No extant version, so create number 1") (OR RANDEVICE (SETQ VERSION 1))) (T (SETQ VERSION EXPLICIT-VERSION] ((LISTP OLDHANDLE) (* ; "Error case") (SETQ HAVELOCK NIL) (SETQ FILESTREAM OLDHANDLE) (GO HANDLE.ERROR)) ((AND (fetch NSHDIRECTORYP of OLDHANDLE) (NOT DIROK)) (* ;  "It's a directory, don't try to treat as ordinary file") (GO FILE.NOT.FOUND)) [(OR EXPLICIT-VERSION (NEQ RECOG 'NEW)) (* ;  "Old file exists, use it unless we explicitly requested a new version") (SETQ HANDLE OLDHANDLE) (COND (EXPLICIT-VERSION (SETQ VERSION EXPLICIT-VERSION] ((NOT RANDEVICE) (* ; "RECOG = NEW -- write a file version one higher. Don't do this in random access case, because we can get the server to tell us the version there.") (SETQ VERSION (ADD1 (OR [CADR (ASSOC 'VERSION (OR (fetch NSHATTRIBUTES of OLDHANDLE) (  \NSFILING.FILLIN.ATTRIBUTES SESSION OLDHANDLE] (GO FILE.NOT.FOUND] (* ;; "At this point, HANDLE is an open handle on the file we want, or is NIL in the case where we are to create a new version, in which case VERSION has been set correctly.") (SETQ FULLNAME (\NSFILING.FULLNAME SESSION (OR HANDLE PARSE) VERSION)) (COND (OPTION (* ;  "Not opening file, something simpler") (GO HANDLE.OPTION)) ((AND HANDLE (NOT OLDSTREAM) (\NSFILING.CONFLICTP DEVICE SESSION HANDLE ACCESS)) (GO FILE.BUSY))) (SELECTQ ACCESS (INPUT (COND ((NULL HANDLE) (* ;  "Odd to get here. E.g., open for INPUT recog NEW.") (GO FILE.NOT.FOUND)) (RANDEVICE (SETQ FILESTREAM (\NSRANDOM.CREATE.STREAM SESSION HANDLE 'INPUT HAVELOCK OLDSTREAM))) [(NEQ (fetch NSHACCESS of HANDLE) 'OUTPUT) (* ; "Just retrieve old file") (SETQ FILESTREAM (FILING.CALL SESSION (OR SERIALIZE 'RETRIEVE) (fetch NSHDATUM of HANDLE) NIL SESSION 'RETURNERRORS 'KEEPSTREAM] (T (GO FILE.BUSY)))) ((OUTPUT BOTH APPEND) (COND ((AND (NEQ ACCESS 'OUTPUT) (NOT RANDEVICE)) (* ;  "Sequential can only write whole files") (GO FILE.WONT.OPEN))) (COND [HANDLE (* ;  "File already exists, need to overwrite") (COND (RANDEVICE (SETQ FILESTREAM (\NSRANDOM.CREATE.STREAM SESSION HANDLE ACCESS HAVELOCK OLDSTREAM T))) [(NULL (fetch NSHACCESS of HANDLE)) (* ;  "Overwrite existing file sequentially") [SETQ FILESTREAM (OR (\NSFILING.CHECK.ACCESS SESSION HANDLE 'WRITE) (FILING.CALL SESSION 'REPLACE (fetch NSHDATUM of HANDLE) NIL NIL SESSION 'RETURNERRORS 'KEEPSTREAM] (COND ((type? STREAM FILESTREAM) (* ;  "Cache of saved attributes is now wrong") (replace NSHATTRIBUTES of HANDLE with NIL) (* ;  "Save attributes to change after file is stored") (replace NSFILING.NEW.ATTRIBUTES of FILESTREAM with PARAMETERS] (T (GO FILE.BUSY] (OLDSTREAM (* ;  "Trying to reopen old stream, failed.") (RETURN NIL)) [(SETQ OLDHANDLE (\NSFILING.CONNECT SESSION DIRPATH T T)) (* ; "Need to create the file, so first had to get a handle on the parent (CREATE and STORE procedures do not permit PATHNAME as one of the specifying attributes).") (COND [RANDEVICE (* ; "Create a new, empty file, then start writing pages to it. Lucky us, we can do this right for a change.") (SETQ HANDLE (FILING.CALL SESSION 'CREATE (fetch NSHDATUM of OLDHANDLE) `([NAME ,(\NSFILING.REMOVEQUOTES (fetch NSROOTNAME of PARSE] ,@[AND VERSION `((VERSION ,VERSION] ,@PARAMETERS) '((LOCK EXCLUSIVE)) SESSION 'RETURNERRORS)) (COND ([OR (NLISTP HANDLE) (EQ (CAR HANDLE) 'ERROR) (LISTP (SETQ HANDLE (\NSFILING.ADD.TO.CACHE SESSION (create FILINGHANDLE NSHDATUM _ HANDLE NSHACCESS _ 'OUTPUT] (* ;  "Create failed or we can't read its attributes! Fall thru to error handler") (SETQ FILESTREAM HANDLE) (GO HANDLE.ERROR)) ((type? STREAM (SETQ FILESTREAM (\NSRANDOM.CREATE.STREAM SESSION HANDLE ACCESS T))) (* ;  "Succeeded in opening stream, i.e., no further conflicts detected.") (SETQ FULLNAME (\NSFILING.FULLNAME SESSION HANDLE))) (T (GO HANDLE.ERROR] (T (* ; "Start writing new file, guessing the version. Ideally we shouldn't guess the version, but Lisp wants a full file name NOW (grumble).") (SETQ FILESTREAM (OR (\NSFILING.CHECK.ACCESS SESSION OLDHANDLE 'ADD) (FILING.CALL SESSION 'STORE (fetch NSHDATUM of OLDHANDLE) `([NAME ,(\NSFILING.REMOVEQUOTES (fetch NSROOTNAME of PARSE] (VERSION ,VERSION) ,@PARAMETERS) NIL NIL SESSION 'RETURNERRORS 'KEEPSTREAM] (T (GO FILE.NOT.FOUND)))) (\ILLEGAL.ARG ACCESS)) (COND ((NOT (type? STREAM FILESTREAM)) (* ;  "Had handle, but failed to open it.") (GO HANDLE.ERROR))) (replace FULLFILENAME of FILESTREAM with (COND (*UPPER-CASE-FILE-NAMES* (MKATOM (U-CASE FULLNAME))) (T FULLNAME))) (replace NSFILING.CONNECTION of FILESTREAM with SESSION) (replace NSFILING.HANDLE of FILESTREAM with HANDLE) (replace DEVICE of FILESTREAM with (OR RANDEVICE DEVICE)) (COND (HANDLE (add (fetch NSHBUSYCOUNT of HANDLE) 1))) (RETURN FILESTREAM) HANDLE.OPTION (* ;; "Come here when we have obtained the handle on the file in question, but OPTION is non-NIL, so we want to do something other than open a file.") (RETURN (SELECTQ OPTION (NAME (if HANDLE then (\NSFILING.FULLNAME SESSION HANDLE NIL *UPPER-CASE-FILE-NAMES*) else (* ;  "OUTFILEP case: no handle, but we have computed the name") FULLNAME)) (DIRECTORY (* ;  "I'm pretty sure HANDLE can't be NIL at this point, but a little test never hurt anyone.") (AND HANDLE (fetch NSHDIRECTORYP of HANDLE) (\NSFILING.FULLNAME SESSION HANDLE NIL *UPPER-CASE-FILE-NAMES*))) (ATTRIBUTES (OR (fetch NSHATTRIBUTES of HANDLE) (\NSFILING.FILLIN.ATTRIBUTES SESSION HANDLE))) (HANDLE (CL:FUNCALL PARAMETERS SESSION HANDLE)) (SHOULDNT))) HANDLE.ERROR (* ;; "Come here with FILESTREAM set to an error returned from some courier call") (COND ([NOT (EQUAL FILESTREAM '(ERROR SESSION.ERROR TokenInvalid] (COND (HAVELOCK (\NSRANDOM.RELEASE.LOCK SESSION HANDLE))) (RETURN (\NSFILING.HANDLE.ERROR SESSION FILESTREAM FILENAME))) ((SETQ SESSION (\NSFILING.GET.NEW.SESSION SESSION DEVICE)) (* ; "Got new session, so start over. Note that we may have to reparse, since the first time thru we might have gotten the cached handle.") (SETQ HAVELOCK (SETQ HANDLE (SETQ VERSION NIL))) (GO RETRY)) (T (* ;  "Can't get connection at all? OH well, die as if it were true from the start.") (RETURN NIL))) FILE.NOT.FOUND (COND (HAVELOCK (\NSRANDOM.RELEASE.LOCK SESSION HANDLE))) (RETURN NIL) FILE.BUSY (COND (HAVELOCK (\NSRANDOM.RELEASE.LOCK SESSION HANDLE))) FILE.WONT.OPEN (RETURN (WITHOUT.SESSION.MONITOR SESSION (LISPERROR "FILE WON'T OPEN" FULLNAME])]) (\NSFILING.LOOKUP.CACHE [LAMBDA (CONNECTION FILENAME) (* ; "Edited 9-Jun-87 22:55 by bvm:") (LET ((CACHE (fetch FSCACHEDHANDLES of CONNECTION)) ENTRY) (COND ([COND ((EQ (CAR (LISTP FILENAME)) 'FILE.ID) (* ; "Look by id") (find old ENTRY in CACHE bind (ID _ (CADR FILENAME)) suchthat (EQUAL (fetch NSHFILEID of ENTRY) ID))) [(OR (NULL FILENAME) (LISTP FILENAME)) (* ; "Looking for directory match") (find old ENTRY in CACHE bind NAME (PATHLENGTH _ (LENGTH FILENAME)) suchthat (AND (NEQ (SETQ NAME (fetch NSHDIRECTORYPATH of ENTRY)) T) (EQ (LENGTH NAME) PATHLENGTH) (for X in FILENAME always (STRING-EQUAL X (pop NAME] (T (* ; "Looking for file name match") (find old ENTRY in CACHE suchthat (STRING-EQUAL (fetch NSHNAME of ENTRY) FILENAME] [COND ((CDR CACHE) (* ; "Promote to front of cache") (replace FSCACHEDHANDLES of CONNECTION with (CONS ENTRY (DREMOVE ENTRY CACHE] ENTRY]) (\NSFILING.ADD.TO.CACHE [LAMBDA (SESSION HANDLE NOERRORFLG) (* ; "Edited 1-Sep-87 11:42 by bvm:") (* ;;; "Add file HANDLE to the cache for SESSION and return it, or an earlier cached version of the same handle if there is one") (PROG ((CACHE (fetch FSCACHEDHANDLES of SESSION)) (ID (fetch NSHFILEID of HANDLE)) OLDHANDLE) [COND ((NULL ID) (COND ((OR (NLISTP (SETQ ID (\NSFILING.FILLIN.ATTRIBUTES SESSION HANDLE NOERRORFLG))) (EQ (CAR ID) 'ERROR)) (* ; "Pass error up") (RETURN ID))) (SETQ ID (fetch NSHFILEID of HANDLE] (COND ([AND ID (SETQ OLDHANDLE (find H in CACHE suchthat (EQUAL (fetch NSHFILEID of H) ID] (* ;  "Don't keep duplicates--flush the new one and return the old one") (\NSFILING.CLOSE.HANDLE SESSION HANDLE) (RETURN OLDHANDLE))) [while (GREATERP (LENGTH CACHE) FILING.CACHE.LIMIT) do (* ;  "Flush old unused handles to keep the cache within limits") (for H in CACHE when (EQ (fetch NSHBUSYCOUNT of H) 0) do (SETQ OLDHANDLE H)) (COND (OLDHANDLE (* ;  "The least recently referenced unused handle") (SETQ CACHE (DREMOVE OLDHANDLE CACHE)) (\NSFILING.CLOSE.HANDLE SESSION OLDHANDLE) (SETQ OLDHANDLE NIL)) (T (* ; "All handles are busy") (RETURN] (replace FSCACHEDHANDLES of SESSION with (CONS HANDLE CACHE)) (RETURN HANDLE]) (\NSFILING.OPEN.HANDLE [LAMBDA (SESSION PNAME.OR.PROPS CONTROLS NOERRORFLG PARENT) (* ; "Edited 19-Aug-88 17:38 by bvm") (LET [(HANDLE (FILING.CALL SESSION 'OPEN [OR (LISTP PNAME.OR.PROPS) `((PATHNAME ,PNAME.OR.PROPS] (if PARENT then (fetch NSHDATUM of PARENT) else \NSFILING.NULL.HANDLE) [AND CONTROLS `((LOCK ,(SELECTQ CONTROLS (INPUT 'SHARE) (OUTPUT 'EXCLUSIVE) (SHOULDNT] SESSION (OR NOERRORFLG 'NOERROR] (COND ((OR (NLISTP HANDLE) (EQ (CAR HANDLE) 'ERROR)) (* ; "Failure return") HANDLE) (T (LET ((RESULT (\NSFILING.ADD.TO.CACHE SESSION (SETQ HANDLE (create FILINGHANDLE NSHDATUM _ HANDLE NSHACCESS _ CONTROLS)) NOERRORFLG))) [COND ((NOT (TYPENAMEP RESULT 'FILINGHANDLE)) (* ; "Error trying to get attributes--close the handle altogether now, since it's not going into the cache.") (\NSFILING.CLOSE.HANDLE SESSION HANDLE)) (CONTROLS (* ;  "May need to release lock if there's an error later.") (RESETSAVE NIL (LIST (FUNCTION \NSRANDOM.RELEASE.IF.ERROR) SESSION HANDLE] RESULT]) (\NSFILING.CONFLICTP [LAMBDA (DEVICE SESSION HANDLE ACCESS) (* ; "Edited 19-Aug-88 17:17 by bvm") (* ;; "True if opening HANDLE on SESSION for specified ACCESS would present an access conflict for streams already open on DEVICE. We need this as an explicit check because we might have files open on expired sessions where we haven't yet reestablished their streams on the new session, and hence the handle conflict would not be apparent.") (LET ((OPENFILES (fetch (FDEV OPENFILELST) of DEVICE))) (AND OPENFILES (for S in OPENFILES bind (NAME _ (\NSFILING.FULLNAME SESSION HANDLE)) when (STRING-EQUAL NAME (fetch FULLFILENAME of S)) do (* ;  "Note that looking at one stream on the file is sufficient for conflict check.") (RETURN (SELECTQ ACCESS ((OUTPUT BOTH APPEND) (* ; "Always a conflict") T) (INPUT (* ; "Ok if only input") (DIRTYABLE S)) (\ILLEGAL.ARG ACCESS]) (\NSFILING.CHECK.ACCESS [LAMBDA (SESSION HANDLE TYPE) (* ; "Edited 30-Nov-87 10:39 by bvm:") (* ;; "Check that user has TYPE access to the specified file handle. TYPE is one of the values of the ACCESS control: READ, WRITE, OWNER, ADD, REMOVE, ALL. If user has access, returns NIL; otherwise, returns some sort of courier error.") (* ;; "In Filing 4 (Services 8.0) this can't work, so we pretend it succeeds.") (AND (NEQ (fetch FSPROTOCOLNAME of SESSION) 'FILING.4) (LET [(RESULT (FILING.CALL SESSION 'GET.CONTROLS (fetch NSHDATUM of HANDLE) '(ACCESS) SESSION 'RETURNERRORS] (COND ((EQ (CAR RESULT) 'ERROR) RESULT) ([NOT (for A in (CADR (ASSOC 'ACCESS RESULT)) thereis (OR (EQ A TYPE) (EQ A 'ALL] (* ;; "Fake a protection error. Don't generate the error here, because caller may need to release a lock first. The ASSOC is because filing returns a list of controls, even though I only asked for one (bug).") '(ERROR ACCESS.ERROR AccessRightsInsufficient]) (\NSFILING.FILLIN.ATTRIBUTES [LAMBDA (SESSION HANDLE NOERRORFLG) (* ; "Edited 3-Jun-87 19:25 by bvm:") (OR (fetch NSHATTRIBUTES of HANDLE) (LET [(ATTRS (FILING.CALL SESSION 'GET.ATTRIBUTES (fetch NSHDATUM of HANDLE) \NSFILING.USEFUL.ATTRIBUTE.TYPES SESSION (OR NOERRORFLG 'RETURNERRORS] (COND ((AND (LISTP ATTRS) (NEQ (CAR ATTRS) 'ERROR)) (replace NSHATTRIBUTES of HANDLE with ATTRS) (for X in ATTRS do (* ;; "Fill in interesting attributes that we might want to get at quickly and not lose if a SETFILEINFO is done") (SELECTQ (CAR X) (PATHNAME (replace NSHPATHNAME of HANDLE with (CADR X))) (FILE.ID (replace NSHFILEID of HANDLE with (CADR X))) (IS.DIRECTORY (replace NSHDIRECTORYP of HANDLE with (CADR X))) NIL))) ((NOT NOERRORFLG) (COURIER.SIGNAL.ERROR (fetch FSPROTOCOLNAME of SESSION) 'GET.ATTRIBUTES ATTRS))) ATTRS]) (\NSFILING.COMPOSE.PATHNAME [LAMBDA (DIRPATH NAME VERSION) (* bvm%: "19-Dec-85 16:55") (* ;;; "Makes a NS pathname out of the file name with given components. All components are assumed to be quoted as needed. NAME and/or VERSION can be NIL") (CONCATLIST (NCONC (CDR (for DIR in DIRPATH join (LIST '/ DIR))) (AND NAME (LIST '/ (\NSFILING.ADDQUOTES NAME T))) (AND VERSION (LIST '! VERSION]) (\NSFILING.PARSE.FILENAME [LAMBDA (FILENAME PATTERNP) (* ; "Edited 10-Dec-87 11:09 by bvm:") (* ;;; "Parses FILENAME into an NSFILINGPARSE record. Hate to do this independent of UNPACKFILENAME, but there's too much to worry about -- need to parse the directories individually, require periods not to mean version, ignore colon as a device delimeter, etc.") (* ;;; "PATTERNP is true when parsing a directory pattern. Main difference is we preserve final dot in name so caller knows it has to be extensionless.") (* ;;; "Returns NIL if filename is bad.") (bind CH (I _ 1) (NC _ (NCHARS FILENAME)) START VERSION SEMI DOTSEEN DIRS END LASTHOST NAME first (COND ([OR (NULL (SETQ LASTHOST (SELCHARQ (CHCON1 FILENAME) ({ (CHARCODE })) (%( (CHARCODE %))) (%[ (CHARCODE %])) NIL))) (until (EQ (SETQ CH (NTHCHARCODE FILENAME (add I 1))) LASTHOST) do (COND ((NULL CH) (* ; "end of file name") (RETURN T] (* ; "Bad file name") (RETURN NIL))) [SETQ START (+ I (SELCHARQ (NTHCHARCODE FILENAME (ADD1 I)) ((/ <) 2) (PROGN (* ; "No directory") 1] while (<= (add I 1) NC) do (SELCHARQ (NTHCHARCODE FILENAME I) (; (* ; "Version marker maybe") (SETQ SEMI I)) (%. (OR DOTSEEN (SETQ DOTSEEN I))) (%' (* ;  "quote mark, skip it and next char") (add I 1)) ((/ >) (* ; "Directory marker") (if SEMI then (* ;  "Version marker inside directory?") (RETURN NIL)) [SETQ DIRS (NCONC1 DIRS (SUBSTRING FILENAME START (SUB1 I] (SETQ SEMI (SETQ DOTSEEN NIL)) (SETQ START (ADD1 I))) (* (if (NOT PATTERNP) then (RETURN NIL))) NIL) finally [COND ((NEQ START I) [SETQ END (COND (SEMI (SUB1 SEMI)) (T (SUB1 I] [COND ((AND (EQ END DOTSEEN) (NOT PATTERNP)) (* ;  "Don't include final dot of extensionless files in actual name on server") (SETQ DOTSEEN NIL) (SETQ END (SUB1 END] (COND ((GEQ END START) (SETQ NAME (SUBSTRING FILENAME START END] (if (AND SEMI (NEQ SEMI NC)) then (* ;  "Parse version as integer. Note: PARSE-INTEGER demands a string, but FILENAME might be a symbol.") (CL:MULTIPLE-VALUE-SETQ (VERSION END) (CL:PARSE-INTEGER (SUBSTRING FILENAME (ADD1 SEMI)) :JUNK-ALLOWED T)) (if (NEQ END (- NC SEMI)) then (* ; "Junk found") (if (AND PATTERNP (EQ SEMI (SUB1 NC)) (EQ (NTHCHARCODE FILENAME NC) (CHARCODE *))) then (* ; "Version * ok for patterns") (SETQ VERSION '*) else (RETURN NIL)) elseif (NOT (AND (> VERSION 0) (<= VERSION MAX.SMALLP))) then (* ;  "Bad version--negative or out of range") (RETURN NIL))) (RETURN (create NSFILINGPARSE NSDIRECTORIES _ DIRS NSROOTNAME _ NAME NSVERSION _ VERSION NSDIRECTORYP _ (OR (NULL NAME) (EQ (NCHARS NAME) 0)) NSHASPERIOD _ DOTSEEN]) (\NSFILING.ERRORHANDLER [LAMBDA (STREAM ERRCODE) (* ; "Edited 20-Nov-87 17:03 by bvm:") (* ;;; "Called when error encountered on STREAM. If STREAM.LOST on an input file, we try to re-establish the connection") (PROG ((PRINTFLG NSFILING.SHOW.STATUS) (FAILCNT 0) NEWSTREAM HANDLE FULLNAME OLDPTR CON POS) (COND ((AND (NEQ ERRCODE 'STREAM.LOST) (NEQ ERRCODE 'END)) (* ; "Not a stream lost type of error. END can occur if you try to make a call on a Courier stream at the same time that the other end decided to time you out.") (GO EXIT)) [(NOT (SETQ FULLNAME (fetch FULLFILENAME of STREAM))) (* ;  "Not a bulk stream with a file in it, maybe in midst of Courier call") (COND ((SETQ POS (STKPOS (FUNCTION COURIER.EXECUTE.CALL))) (BLOCK 500) (* ;; "Tell courier caller that the stream went away. Wait a moment for connection process to clean up the mess if there is any") (RETFROM POS 'STREAM.LOST T)) (T (GO EXIT] ((SETQ POS (STKPOS (FUNCTION \COURIER.RESULTS)))(* ;  "Error trying to close the file -- convert this to an error return") (BLOCK 500) (RETFROM POS '(ERROR STREAM.LOST) T)) ((NEQ (fetch ACCESS of STREAM) 'INPUT) (* ; "No help for output files") (GO EXIT)) ((NOT (SETQ HANDLE (fetch NSFILING.HANDLE of STREAM))) (* ; "Stream already blown away?") (GO EXIT))) (AND PRINTFLG (printout PROMPTWINDOW T "[Reestablishing connection to " FULLNAME " at byte " (SETQ OLDPTR (GETFILEPTR STREAM)) %,)) RETRY (COND ((SETQ NEWSTREAM (\NSFILING.GETFILE (fetch DEVICE of STREAM) (LET ((ID (fetch NSHFILEID of HANDLE))) (OR (AND ID (LIST 'FILE.ID ID)) FULLNAME)) 'INPUT 'OLD NIL NIL NIL T)) (* ; "Reopen using ID if possible") (AND PRINTFLG (printout PROMPTWINDOW "...")) (replace SPPERRORHANDLER of (SETQ CON (fetch SPP.CONNECTION of NEWSTREAM )) with (FUNCTION ERROR!)) (COND ((NLSETQ (SETFILEPTR NEWSTREAM OLDPTR)) (* ; "Succeeded in advancing file ptr") ) ((GREATERP (add FAILCNT 1) 3) (GO FAIL)) (T (AND PRINTFLG (printout PROMPTWINDOW "failed, retrying ")) (GO RETRY))) (replace SPPERRORHANDLER of CON with (FUNCTION \NSFILING.ERRORHANDLER)) (UNINTERRUPTABLY (* ; "Smash new stream into old") (replace F1 of STREAM with (fetch F1 of NEWSTREAM)) (replace F2 of STREAM with (fetch F2 of NEWSTREAM)) (replace F3 of STREAM with (fetch F3 of NEWSTREAM)) (replace F4 of STREAM with (fetch F4 of NEWSTREAM)) (replace F5 of STREAM with (fetch F5 of NEWSTREAM)) (replace FW6 of STREAM with (fetch FW6 of NEWSTREAM)) (replace FW7 of STREAM with (fetch FW7 of NEWSTREAM)) (replace SPPSUBSTREAM of CON with STREAM) (replace CBUFPTR of STREAM with (fetch CBUFPTR of NEWSTREAM)) (replace CBUFSIZE of STREAM with (fetch CBUFSIZE of NEWSTREAM)) (replace COFFSET of STREAM with (fetch COFFSET of NEWSTREAM))) (AND PRINTFLG (printout PROMPTWINDOW "done.]")) (RETURN T))) FAIL (AND PRINTFLG (printout PROMPTWINDOW "...failed.]")) EXIT (RETURN (\SPP.DEFAULT.ERRORHANDLER STREAM ERRCODE]) (\NSFILING.WHENCLOSED [LAMBDA (STREAM) (* ; "Edited 2-Jun-87 18:42 by bvm:") (* ;;; "Called when Courier STREAM is closed, by whatever means") (for SESSION in \NSFILING.ACTIVE.SESSIONS bind STREAMPAIRS DEV thereis (for PAIR in (SETQ STREAMPAIRS (fetch FSCOURIERSTREAMS of SESSION) ) when (EQ (CAR PAIR) STREAM) do (replace FSCOURIERSTREAMS of SESSION with (DREMOVE PAIR STREAMPAIRS )) (COND ((AND (SETQ DEV (\GETDEVICEFROMHOSTNAME (fetch FSDEVICENAME of SESSION) T)) (fetch (FDEV OPENFILELST) of DEV)) (\NSRANDOM.ENSURE.WATCHER DEV))) (RETURN T]) (\NSFILING.CLOSE.HANDLE [LAMBDA (SESSION HANDLE) (* ; "Edited 5-Jun-87 17:59 by bvm:") (* ;; "Release the given file handle.") (FILING.CALL SESSION 'CLOSE (fetch NSHDATUM of HANDLE) SESSION 'NOERROR]) (\NSFILING.FULLNAME [LAMBDA (CONNECTION HANDLE.OR.PARSE VERSION ATOMFLG) (* ; "Edited 20-Nov-87 18:40 by bvm:") (PROG (FILENAME DIRLST DIRECTORYFLG FULLNAME PATHNAME FUNNYCHAR DOTSEEN ALREADYQUOTED INFO HANDLE QUOTEDDIRS) (COND ((SETQ INFO (COND ((type? FILINGHANDLE HANDLE.OR.PARSE) (COND ((SETQ FULLNAME (fetch NSHNAME of (SETQ HANDLE HANDLE.OR.PARSE))) (GO EXIT))) (OR (fetch NSHATTRIBUTES of HANDLE) (\NSFILING.FILLIN.ATTRIBUTES CONNECTION HANDLE))) ((LISTP (CADR HANDLE.OR.PARSE)) (* ; "Assume is attribute list itself") HANDLE.OR.PARSE))) (for PAIR in INFO do (SELECTQ (CAR PAIR) (IS.DIRECTORY (SETQ DIRECTORYFLG (CADR PAIR))) (VERSION (SETQ VERSION (CADR PAIR))) (PATHNAME (SETQ PATHNAME (CADR PAIR))) NIL)) [for I from 1 while (<= I NC) bind CH VERS (START _ 1) (NC _ (NCHARS PATHNAME)) PREVDOT do (SELCHARQ (SETQ CH (NTHCHARCODE PATHNAME I)) (! (* ; "Version marker") (SETQ VERS I)) (%' (* ;  "quote mark, skip it and next char") (add I 1)) (/ (* ; "Directory marker") [push DIRLST (SUBSTRING PATHNAME START (COND ((AND VERS (EQ VERS (- I 2)) (EQ (NTHCHARCODE PATHNAME (ADD1 VERS)) (CHARCODE 1))) (* ; "Version 1 in path, toss it out") (SUB1 VERS)) (T (SUB1 I] (SETQ VERS) (SETQ START (ADD1 I)) (SETQ DOTSEEN (SETQ PREVDOT NIL))) (%. (SETQ PREVDOT DOTSEEN) (SETQ DOTSEEN I)) ((; %: < > } %]) (* ;  "Funny characters that filing doesn't care about but we do -- need to quote these") (SETQ FUNNYCHAR T)) NIL) finally [SETQ PATHNAME (SUBSTRING PATHNAME START (COND ((NULL VERS) NIL) ((NULL DIRECTORYFLG) (* ;  "ordinary file, here's the version") (SETQ VERSION (SUBSTRING PATHNAME (ADD1 VERS)) ) (SUB1 VERS)) ((AND (EQ VERS (- I 2)) (EQ (NTHCHARCODE PATHNAME (ADD1 VERS)) (CHARCODE 1))) (* ; "Version 1 in path, toss it out") (SUB1 VERS] (SETQ FILENAME (COND (DIRECTORYFLG (SETQ DOTSEEN NIL) (push DIRLST PATHNAME) NIL) ((OR (if (AND DOTSEEN (EQ DOTSEEN (if VERS then (SUB1 VERS) else NC))) then (* ; "Ugh--the pathname ended in an actual period, which we usually toss out. I.e. we prefer extensionless files to have no period at the end. So if the server thinks there is one, we'd better say FOO'..;1 instead of FOO.;1.") (SETQ DOTSEEN PREVDOT) T) FUNNYCHAR) (* ;  "May need to quote chars that the server didn't find worth quoting. ") (\NSFILING.ADDQUOTES PATHNAME T)) (T PATHNAME] (* ;; "DIRLST is in reverse order now.") (for DIR in DIRLST do (push QUOTEDDIRS (COND (FUNNYCHAR (  \NSFILING.ADDQUOTES DIR T)) (T DIR)) '>)) (SETQ ALREADYQUOTED T) (* ;; "Since everything came from a valid (from the server's point of view) pathname, we won't have to add quotes except for characters that WE care about (for unpackfilename and friends)") ) (T (SETQ FILENAME (fetch NSROOTNAME of HANDLE.OR.PARSE)) [SETQ QUOTEDDIRS (for DIR in (fetch NSDIRECTORIES of HANDLE.OR.PARSE) join (LIST (\NSFILING.ADDQUOTES DIR ALREADYQUOTED) '>] (SETQ DIRECTORYFLG (fetch NSDIRECTORYP of HANDLE.OR.PARSE)) (OR VERSION (SETQ VERSION (fetch NSVERSION of HANDLE.OR.PARSE))) (SETQ DOTSEEN (fetch NSHASPERIOD of HANDLE.OR.PARSE)) (SETQ ALREADYQUOTED T))) [SETQ FULLNAME (CONCATLIST (NCONC (LIST '{ (fetch FSNAMESTRING of CONNECTION) "}<") QUOTEDDIRS (AND (NOT DIRECTORYFLG) (LIST (OR FILENAME "") (COND (DOTSEEN ";") (T ".;")) (OR VERSION ""] (COND (HANDLE (replace NSHNAME of HANDLE with FULLNAME))) EXIT (RETURN (COND ((AND ATOMFLG *UPPER-CASE-FILE-NAMES*) (* ; "Return in 'Lisp file name' form") (MKATOM (U-CASE FULLNAME))) (T FULLNAME]) ) (* ; "NSFILING device") (DEFINEQ (\NSFILING.OPENFILE [LAMBDA (FILENAME ACCESS RECOG PARAMETERS DEVICE) (* ; "Edited 19-Aug-88 17:17 by bvm") (LET (ATTRIBUTES ATVAL OTHER SEQUENTIAL STREAM) (COND ((SETQ STREAM (\NSFILING.GETFILE DEVICE (if (NOT (type? STREAM FILENAME)) then FILENAME elseif (OPENED FILENAME) then (\ILLEGAL.ARG FILENAME) else (* ;  "Reopening a closed stream, such as TEdit might do.") (fetch FULLFILENAME of FILENAME)) (SELECTQ ACCESS ((INPUT OUTPUT BOTH APPEND) ACCESS) (\ILLEGAL.ARG ACCESS)) (SELECTQ RECOG ((OLD NEW OLDEST OLD/NEW) (* ; "explicit recog values") RECOG) (NIL (* ;  "Default according to access. I think maybe the generic system does this anyway.") (SELECTQ ACCESS (INPUT 'OLD) (OUTPUT 'NEW) (BOTH 'OLD/NEW) NIL)) (\ILLEGAL.ARG RECOG)) NIL (PROGN (* ;  "Convert caller's PARAMETERS list to OPENSTREAM to a list of filing attributes") [for PAIR in PARAMETERS do (COND [(NLISTP PAIR) (COND ((EQ PAIR 'SEQUENTIAL) (* ;  "Obsolete way of asking for sequential access") (SETQ SEQUENTIAL T] ((EQ (CAR PAIR) 'SEQUENTIAL) (SETQ SEQUENTIAL (CADR PAIR))) ((EQ ACCESS 'INPUT) (* ; "Nothing interesting to do") ) ([NULL (SETQ ATVAL (\LISP.TO.NSFILING.ATTRIBUTE (CAR PAIR) (CADR PAIR] (* ; "Unrecognized attribute, ignore") ) [(SETQ OTHER (ASSOC (CAR ATVAL) ATTRIBUTES)) (* ;  "Duplicate attribute. If not consistent, complain") (COND ((NOT (EQUAL (CADR OTHER) (CADR ATVAL))) (ERROR "Inconsistent attributes specified to OPENSTREAM" PARAMETERS] (T (push ATTRIBUTES ATVAL] [COND ((AND (NEQ ACCESS 'INPUT) DEFAULTFILETYPE (NOT (ASSOC 'FILE.TYPE ATTRIBUTES))) (* ;  "If no type specified, use default") (push ATTRIBUTES `(FILE.TYPE ,(OR (\FILETYPE.FROM.TYPE DEFAULTFILETYPE) \NSFILING.TYPE.BINARY] ATTRIBUTES) NIL SEQUENTIAL)) (* ;; "Register stream manually in the main device so that there is only one place to look, independent of whether the stream itself uses the random or sequential device") (push (fetch (FDEV OPENFILELST) of DEVICE) STREAM) STREAM]) (\NSFILING.HANDLE.ERROR [LAMBDA (SESSION ERROR FILENAME) (* ; "Edited 8-Dec-87 12:42 by bvm:") (if ERROR then (PRINTOUT PROMPTWINDOW T (CADR ERROR) "--" (CADDR ERROR))) (WITHOUT.SESSION.MONITOR SESSION (CL:ERROR (COND ((AND (EQ (CADR ERROR) 'ACCESS.ERROR) (STRPOS "ACCESS" (CADDR ERROR) NIL NIL NIL NIL UPPERCASEARRAY)) 'XCL:FS-PROTECTION-VIOLATION) (T 'XCL:FILE-WONT-OPEN)) :PATHNAME FILENAME]) (\NSFILING.CLOSEFILE [LAMBDA (FILESTREAM OPTIONS) (* ; "Edited 18-Apr-88 13:53 by bvm") (PROG ((ABORTFLG (LISTGET ':ABORT OPTIONS)) NEWHANDLE HANDLE SESSION INFO) (\GENERIC-UNREGISTER-STREAM (fetch DEVICE of FILESTREAM) FILESTREAM) (COND ((NOT (SETQ SESSION (fetch NSFILING.CONNECTION of FILESTREAM))) (GO EXIT))) (* ;; "Get the handle from the result of the STORE (for OUTPUT) or from the handle already given to RETRIEVE or REPLACE") (SETQ NEWHANDLE (\BULK.DATA.CLOSE FILESTREAM ABORTFLG)) (\NSFILING.RELEASE.BULKSTREAM SESSION FILESTREAM) (* ;  "Courier stream now available for use by others") (COND ((SETQ HANDLE (fetch NSFILING.HANDLE of FILESTREAM)) (\NSRANDOM.RELEASE.HANDLE FILESTREAM))) [COND [(EQ (CAR NEWHANDLE) 'ERROR) (COND ((AND (DIRTYABLE FILESTREAM) (NOT ABORTFLG)) (ERROR (CONCAT "CLOSEF: File not written " (CADR NEWHANDLE) " -- " (CADDR NEWHANDLE)) (fetch FULLFILENAME of FILESTREAM] ((OR HANDLE NEWHANDLE) [COND (NEWHANDLE (SETQ HANDLE (\NSFILING.ADD.TO.CACHE SESSION (create FILINGHANDLE NSHDATUM _ NEWHANDLE NSHNAME _ (fetch FULLFILENAME of FILESTREAM] (COND ((SETQ INFO (fetch NSFILING.NEW.ATTRIBUTES of FILESTREAM)) (* ;; "Caller of OPENFILE specified new attributes for this file, so change them now that we've stored the file") (if (fetch NSHATTRIBUTES of HANDLE) then (* ; "If attrs are cached, fix them") (\NSFILING.UPDATE.ATTRIBUTES HANDLE INFO)) (FILING.CALL SESSION 'CHANGE.ATTRIBUTES (fetch NSHDATUM of HANDLE) INFO SESSION 'RETURNERRORS] EXIT (* ;; "just return") ]) (\NSFILING.EVENTFN [LAMBDA (DEVICE EVENT) (* ; "Edited 30-Nov-87 13:18 by bvm:") (SELECTQ EVENT (BEFORELOGOUT (for S in (fetch (FDEV OPENFILELST) of DEVICE) when (NEQ (fetch (STREAM DEVICE) of S) DEVICE) do (* ;  "Force output on random streams, flush page cache") (\CLEARMAP S)) (* ; "Dispose of any open sessions.") (\NSFILING.CLOSE.CONNECTIONS DEVICE :TEST)) ((AFTERLOGOUT AFTERSAVEVM AFTERMAKESYS AFTERSYSOUT) (\NSFILING.CLOSE.CONNECTIONS DEVICE :ABORT) [for S in (APPEND (fetch (FDEV OPENFILELST) of DEVICE)) do (COND ((AND (EQ (fetch (STREAM DEVICE) of S) DEVICE) (DIRTYABLE S)) (* ;  "Files open for sequential write cannot be recovered. For now we also don't recover input files.") (PRINTOUT T T "***Warning: sequential " (COND ((DIRTYABLE S) "output to") (T "input from")) " the file " (fetch FULLFILENAME of S) " has been aborted and cannot be resumed." T T) (CLOSEF S)) (T (* ;  "Let other streams recover if and when anyone touches them.") ] (COND ((NULL (fetch (FDEV OPENFILELST) of DEVICE)) (* ;  "If no open files, dispose of the device") [LET [(RANDEVICE (fetch NSRANDOMDEVICE of (fetch DEVICEINFO of DEVICE] (COND (RANDEVICE (* ; "Have to break this circularity") (replace DEVICEINFO of RANDEVICE with NIL] (\REMOVEDEVICE DEVICE)))) NIL]) (\NSFILING.DELETEFILE [LAMBDA (FILENAME DEVICE) (* ; "Edited 8-Dec-87 15:40 by bvm:") (\NSFILING.GETFILE DEVICE FILENAME 'NONE 'OLDEST 'HANDLE [FUNCTION (LAMBDA (SESSION HANDLE) (COND ((OR (NEQ (fetch NSHBUSYCOUNT of HANDLE) 0) (\NSFILING.CONFLICTP DEVICE SESSION HANDLE 'OUTPUT)) (* ; "File is in use, can't delete") NIL) ((AND (fetch NSHDIRECTORYP of HANDLE) (NOT (\NSFILING.CHILDLESS-P SESSION HANDLE))) (* ;  "Is a directory with children, can't delete") NIL) ((FILING.CALL SESSION 'DELETE (fetch NSHDATUM of HANDLE) SESSION 'RETURNERRORS) (* ; "Failed to delete it") NIL) (T (* ;  "Delete succeeded, handle now invalid") (replace FSCACHEDHANDLES of SESSION with (DREMOVE HANDLE (fetch FSCACHEDHANDLES of SESSION))) (\NSFILING.FULLNAME SESSION HANDLE NIL T] T]) (\NSFILING.CHILDLESS-P [LAMBDA (SESSION HANDLE) (* ; "Edited 8-Dec-87 15:40 by bvm:") (* ;; "True if we can tell for sure that directory HANDLE has no children. Errors return nil") (EQ [CADR (ASSOC 'NUMBER.OF.CHILDREN (FILING.CALL SESSION 'GET.ATTRIBUTES (fetch NSHDATUM of HANDLE) [CONSTANT (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(NUMBER.OF.CHILDREN] SESSION 'NOERROR] 0]) (\NSFILING.DIRECTORYNAMEP [LAMBDA (HOST/DIR DEVICE CREATE?) (* ; "Edited 4-May-87 17:21 by bvm:") (* ;;  "Returns T or NIL according to whether or not HOST/DIR is a valid host/directory specification.") (\NSFILING.GETFILE DEVICE HOST/DIR 'NONE NIL 'DIRECTORY (COND (CREATE? :ASK]) (\NSFILING.HOSTNAMEP [LAMBDA (HOST DEVICE) (* ; "Edited 11-Jun-87 14:49 by bvm:") (LET ((SERVER (AND (STRPOS ":" HOST) (LOOKUP.NS.SERVER HOST NIL T))) FILINGNAME FULLHOSTNAME) (* ;  "To avoid useless lookups of PUP names, require Clearinghouse names to have a colon.") (COND ((NOT SERVER) NIL) ((\GETDEVICEFROMNAME [SETQ FULLHOSTNAME (MKATOM (U-CASE (NSNAME.TO.STRING (fetch NSFSPARSEDNAME of SERVER) T] T T)) (T (SETQ FILINGNAME (PACK* (fetch NSOBJECT of (fetch NSFSPARSEDNAME of SERVER)) " Filing")) [\DEFINEDEVICE FULLHOSTNAME (SETQ DEVICE (create FDEV using \SPP.BULKDATA.DEVICE DEVICENAME _ FULLHOSTNAME REMOTEP _ T SUBDIRECTORIES _ T OPENFILE _ (FUNCTION \NSFILING.OPENFILE) REOPENFILE _ (FUNCTION NILL) CLOSEFILE _ (FUNCTION \NSFILING.CLOSEFILE) GETFILEINFO _ (FUNCTION \NSFILING.GETFILEINFO) SETFILEINFO _ (FUNCTION \NSFILING.SETFILEINFO) GETEOFPTR _ (FUNCTION \NSFILING.GETEOFPTR) DELETEFILE _ (FUNCTION \NSFILING.DELETEFILE) HOSTNAMEP _ (FUNCTION NILL) GETFILENAME _ (FUNCTION \NSFILING.GETFILENAME) DIRECTORYNAMEP _ (FUNCTION \NSFILING.DIRECTORYNAMEP) GENERATEFILES _ (FUNCTION \NSFILING.GENERATEFILES) RENAMEFILE _ (FUNCTION \NSFILING.RENAMEFILE) EVENTFN _ (FUNCTION \NSFILING.EVENTFN) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION NILL) UNREGISTERFILE _ (FUNCTION NILL) BREAKCONNECTION _ (FUNCTION BREAK.NSFILING.CONNECTION) DEVICEINFO _ (create NSFILINGDEVICEINFO NSFILESERVER _ SERVER NSFILINGLOCK _ (CREATE.MONITORLOCK FILINGNAME) NSFILINGNAME _ FILINGNAME NSCONNECTIONS _ NIL] DEVICE]) (\NSFILING.GETFILENAME [LAMBDA (NAME RECOG DEVICE) (* ; "Edited 4-May-87 17:21 by bvm:") (* ;; "Returns full file name of file or NIL if not found.") (\NSFILING.GETFILE DEVICE NAME 'NONE RECOG 'NAME]) (\NSFILING.GETFILEINFO [LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 5-May-87 13:12 by bvm:") (LET (DESIREDPROPS INFO HANDLE) (DECLARE (SPECVARS DESIREDPROPS)) (* ;  "Used by \NSFILING.GET.ATTRIBUTES") (COND ((EQ ATTRIBUTE 'ALL) (SETQ DESIREDPROPS \NSFILING.ALL.ATTRIBUTE.TYPES) (\NSFILING.GET/SETINFO DEVICE STREAM (FUNCTION \NSFILING.GET.ATTRIBUTES))) ((NULL (SETQ DESIREDPROPS (\FILING.ATTRIBUTE.TYPE (OR (CADR (ASSOC ATTRIBUTE \LISP.TO.NSFILING.ATTRIBUTES )) ATTRIBUTE) T))) NIL) [(AND [EQ DESIREDPROPS (CONSTANT (\FILING.ATTRIBUTE.TYPE 'SIZE.IN.BYTES] (type? STREAM STREAM) (LET [(LEN (COND ((fetch RANDOMACCESSP of DEVICE) (* ; "We know for sure") (GETEOFPTR STREAM)) ((DIRTYABLE STREAM) (* ;  "sequential output stream's length is current fileptr") (GETFILEPTR STREAM] (AND LEN (SELECTQ ATTRIBUTE (SIZE (FOLDHI LEN BYTESPERPAGE)) LEN] (T [SETQ INFO (COND ((NOT (MEMB DESIREDPROPS \NSFILING.USEFUL.ATTRIBUTE.TYPES)) (* ;  "Need to fetch this attribute explicitly") (SETQ DESIREDPROPS (LIST DESIREDPROPS)) (\NSFILING.GET/SETINFO DEVICE STREAM (FUNCTION \NSFILING.GET.ATTRIBUTES))) ((NOT (type? STREAM STREAM))(* ;  "Not an open stream, so have to look it up") (\NSFILING.GETFILE DEVICE STREAM 'NONE 'OLD 'ATTRIBUTES)) ((NULL (SETQ HANDLE (fetch NSFILING.HANDLE of STREAM))) (* ;  "Open for output, don't know attributes yet") NIL) ((fetch NSHATTRIBUTES of HANDLE)) (T (* ;  "Stream open but its attributes wiped--retrieve them again") (\NSFILING.FILLIN.ATTRIBUTES (fetch NSFILING.CONNECTION of STREAM) HANDLE] (\NSFILING.GETFILEINFO.FROM.PLIST INFO ATTRIBUTE]) (\NSFILING.GET.ATTRIBUTES [LAMBDA (SESSION HANDLE) (* ; "Edited 1-Jun-87 16:08 by bvm:") (* ;;; "Fetches the DESIREDPROPS of the file whose HANDLE is open on this CONNECTION") (DECLARE (USEDFREE DESIREDPROPS)) (FILING.CALL SESSION 'GET.ATTRIBUTES (fetch NSHDATUM of HANDLE) DESIREDPROPS SESSION 'RETURNERRORS]) (\NSFILING.GETFILEINFO.FROM.PLIST [LAMBDA (PLIST ATTRIBUTE) (* bvm%: "26-Jun-86 15:36") (COND (PLIST (SELECTQ ATTRIBUTE (WRITEDATE (\NSFILING.GDATE (CADR (ASSOC 'MODIFIED.ON PLIST)))) (READDATE (\NSFILING.GDATE (CADR (ASSOC 'READ.ON PLIST)))) (CREATIONDATE (\NSFILING.GDATE (CADR (ASSOC 'CREATED.ON PLIST)))) (SIZE (LET [(LENGTH (CADR (ASSOC 'SIZE.IN.BYTES PLIST] (AND LENGTH (FOLDHI LENGTH BYTESPERPAGE)))) (AUTHOR (LET [(CHNAME (CADR (ASSOC 'CREATED.BY PLIST] (AND CHNAME (NSNAME.TO.STRING CHNAME)))) (PROTECTION [LET [(PROT (CADR (ASSOC 'ACCESS.LIST PLIST] (* ;  "PROT = ((ENTRIES SEQUENCE) (DEFAULTED BOOLEAN))") (* (COND ((COURIER.FETCH  (FILING . ACCESS.LIST) DEFAULTED of  PROT) (push RESULT "(defaulted)")))) (AND PROT (for ENTRY in (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT) collect (COND [(SMALLP (SETQ PROT (CADDR ENTRY))) `(,(CAR ENTRY) ,(CADR ENTRY) ,@(COND ([EQ PROT (CONSTANT (APPLY 'LOGOR (for PAIR in \NSFILING.PROTECTION.BITS collect (CDR PAIR] (* ; "All bits on") '(ALL)) (T (for PAIR in \NSFILING.PROTECTION.BITS collect (CAR PAIR) when (BITTEST PROT (CDR PAIR] (T (* ;  "Must be some other kind of entry, perhaps new filing") ENTRY]) (TYPE (\TYPE.FROM.FILETYPE (CADR (ASSOC 'FILE.TYPE PLIST)))) (FILETYPE (CADR (ASSOC 'FILE.TYPE PLIST))) (CADR (ASSOC (OR (CADR (ASSOC ATTRIBUTE \LISP.TO.NSFILING.ATTRIBUTES)) ATTRIBUTE) PLIST]) (\NSFILING.GDATE [LAMBDA (DATE) (* lmm "15-Apr-85 16:16") (COND ((AND DATE (NOT (EQUAL DATE MIN.FIXP))) (GDATE DATE]) (\NSFILING.SETFILEINFO [LAMBDA (NAME.OR.STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 9-Jun-87 15:17 by bvm:") (PROG ((ATTR/VAL (\LISP.TO.NSFILING.ATTRIBUTE ATTRIBUTE VALUE)) RESULT) (DECLARE (SPECVARS NAME.OR.STREAM ATTR/VAL)) [COND ((NULL ATTR/VAL) (* ; "Unsupported attribute") (RETURN NIL)) ((AND (EQ (CAR ATTR/VAL) 'SIZE.IN.BYTES) (type? STREAM NAME.OR.STREAM)) (* ;  "Changing the length on an open stream requires a little more than just changing the attribute") (RETURN (AND (fetch RANDOMACCESSP of DEVICE) (\NSRANDOM.SETEOFPTR NAME.OR.STREAM (CADR ATTR/VAL] [SETQ RESULT (\NSFILING.GET/SETINFO DEVICE NAME.OR.STREAM (FUNCTION (LAMBDA (SESSION HANDLE) (DECLARE (USEDFREE NAME.OR.STREAM ATTR/VAL)) (COND ((AND (OR (NOT (type? STREAM NAME.OR.STREAM)) (NEQ HANDLE (fetch NSFILING.HANDLE of NAME.OR.STREAM))) (\NSFILING.CONFLICTP DEVICE SESSION HANDLE 'OUTPUT)) (* ;  "We have a stream open on this file, can't change attributes out from under it") NIL) ((FILING.CALL SESSION 'CHANGE.ATTRIBUTES (fetch NSHDATUM of HANDLE) (LIST ATTR/VAL) SESSION 'RETURNERRORS)) (T (* ;  "Change attributes succeeded. Update cached attributes.") (\NSFILING.UPDATE.ATTRIBUTES HANDLE (LIST ATTR/VAL )) T] (RETURN (COND ((LISTP RESULT) (printout PROMPTWINDOW T (COND ((type? STREAM NAME.OR.STREAM) (fetch FULLFILENAME of NAME.OR.STREAM)) (T NAME.OR.STREAM)) " -- " (CADDR RESULT)) NIL) (T RESULT]) (\NSFILING.GET/SETINFO [LAMBDA (DEVICE STREAM INFOFN) (* ; "Edited 22-May-87 13:09 by bvm:") (COND [(type? STREAM STREAM) (PROG (SESSION RESULT) RETRY (COND ([AND (SETQ SESSION (fetch NSFILING.CONNECTION of STREAM)) (OR [NLISTP (SETQ RESULT (CL:FUNCALL INFOFN (fetch NSFILING.CONNECTION of STREAM) (fetch NSFILING.HANDLE of STREAM] (NEQ (CAR RESULT) 'ERROR) (NEQ (CADR RESULT) 'SESSION.ERROR] (RETURN RESULT))) (COND ((fetch RANDOMACCESSP of DEVICE) (* ; "Get new session") (\NSRANDOM.REESTABLISH STREAM) (GO RETRY)) (T (* ;  "Sequential stream that was lost. Hmm. Just punt out to the file name itself") (\NSFILING.GETFILE DEVICE (fetch FULLFILENAME of STREAM) 'NONE 'OLD 'HANDLE INFOFN T] (T (\NSFILING.GETFILE DEVICE STREAM 'NONE 'OLD 'HANDLE INFOFN T]) (\NSFILING.UPDATE.ATTRIBUTES [LAMBDA (HANDLE NEWATTRS) (* ; "Edited 9-Jun-87 22:11 by bvm:") (* ;; "Update HANDLE's attribute cache with the set of possibly changed NEWATTRS. Return the new attribute cache.") (replace NSHATTRIBUTES of HANDLE with (NCONC [for X in NEWATTRS collect X unless (PROGN (* ; "Don't cache attributes that are in a different form, or that could easily change without our knowledge") (MEMB (CAR X) '(ACCESS.LIST DEFAULT.ACCESS.LIST NUMBER.OF.CHILDREN] (for X in (fetch NSHATTRIBUTES of HANDLE) collect X unless (ASSOC (CAR X) NEWATTRS]) (\NSFILING.GETEOFPTR [LAMBDA (STREAM) (* ; "Edited 11-Jun-87 14:42 by bvm:") (COND ((DIRTYABLE STREAM) (* ; "Open for output, must be at eof") (GETFILEPTR STREAM)) (T (* ;  "Not randaccessp, but we can fake it with the length server gave us on opening") (\NSFILING.GETFILEINFO STREAM 'LENGTH (fetch DEVICE of STREAM]) (\NSFILING.GENERATEFILES [LAMBDA (DEVICE PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 28-Jan-94 19:15 by bvm") (* ;; "Device method for file enumeration. Return a generator that enumerates files matching PATTERN. DESIREDPROPS is set of attributes caller may ask for. If OPTIONS includes RESETLST, caller promises to be wrapped in a RESETLST that we can use to kill an aborted bulk listing.") (LET (SESSION BULKSTREAM RESULT) (* ;  "Need these outside of scope of RESETLST in order to process the RESETLST option.") (RESETLST (* ;  "Need RESETLST for \getfilingconnection") [PROG ((FILING5 T)) TOP (RETURN (PROG ((PARSE (\NSFILING.PARSE.FILENAME PATTERN T)) NAME VERSION DIRPATH DIR N FILTERNEEDED PATHREQUIRED FILTERLIST SCOPELIST INFINITE.DEPTH HANDLE VERSIONFILTER RETURNPROPS) (if [OR (NULL PARSE) (NULL (OR SESSION (SETQ SESSION (\GETFILINGCONNECTION DEVICE] then (RETURN NIL)) (if (AND FILING5 (NEQ (fetch FSPROTOCOLNAME of SESSION) 'FILING)) then (SETQ FILING5 NIL)) [for TAIL on (SETQ DIRPATH (fetch NSDIRECTORIES of PARSE)) when [SETQ N (STRPOS '* (SETQ DIR (CAR TAIL] do (* ; "Wildcard in directory part, e.g., b*r>baz. By Lisp's rules, we want to include b>r>baz but not barbaz.tedit.") (if FILING5 then (* ;  "New filing lets us say ** to match arbitrary components in pathname") (SETQ PATHREQUIRED T) (RPLACA TAIL (\NSFILING.GENERATE.STARS DIR)) else (* ;  "This is hard. Get as far down in the tree as possible, then enumerate everything") [SETQ FILTERNEEDED (SETQ DIRPATH (for D in DIRPATH collect D until (EQ D DIR] (SETQ NAME (if (NEQ N 1) then (* ;  "If asked to enumerate b*r>baz, we can at least enumerate b* and filter the rest") (SUBSTRING DIR 1 N))) (RETURN)) finally (* ;; "Directories are fine, so all the matching happens on the name") (if (STREQUAL (SETQ NAME (fetch NSROOTNAME of PARSE)) "*.*") then (* ; "Trivial match") (SETQ NAME NIL) else (if (STRPOS ".*" NAME -2 NIL T) then (* ;  "If name is foo.*, need to enumerate foo* in order to include extensionless foo") (if (NEQ (NTHCHARCODE (SETQ NAME (SUBSTRING NAME 1 -3)) -1) (CHARCODE *)) then (SETQ NAME (CONCAT NAME "*")) (* ;  "foo*.* is ok as foo*, but foo.* needs filtering of foo*") (SETQ FILTERNEEDED T)) elseif (EQ (NTHCHARCODE NAME -1) (CHARCODE ".")) then (* ; "If have explicitly null extension, remove period and filter -- ns file server doesn't understand %"extension%"") (SETQ NAME (SUBSTRING NAME 1 -2)) (SETQ FILTERNEEDED T)) (if (AND FILING5 (SETQ N (STRPOS "*" NAME))) then (* ;; "Interior * needs to be replaced with ** so that server will match subdirectories along the path. May only work in version 5 (Services 10)") (SETQ NAME (\NSFILING.GENERATE.STARS NAME)) (SETQ PATHREQUIRED T] (if (NULL (SETQ HANDLE (\NSFILING.CONNECT SESSION (if PATHREQUIRED then (* ; "get root directory") NIL else DIRPATH) T))) then (RETURN NIL)) [SETQ RETURNPROPS (CL:REMOVE-DUPLICATES (APPEND [CONSTANT (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(PATHNAME IS.DIRECTORY] (for PROP in DESIREDPROPS when (SETQ PROP (\FILING.ATTRIBUTE.TYPE (OR (CADR (ASSOC PROP \LISP.TO.NSFILING.ATTRIBUTES )) PROP) T)) collect PROP] (* ;  "make sure there are no duplicates, since File server can object to that") [if PATHREQUIRED then (* ; "Match a full path name") [push FILTERLIST `(MATCHES (PATHNAME ,(\NSFILING.COMPOSE.PATHNAME DIRPATH (OR NAME '*] elseif (NULL NAME) then (* ; "Enumerate everything") elseif (STRPOS '* NAME) then (* ;; "The following doesn't quite work in Services 8 because the fileserver won't match against subdirectory names.") [push FILTERLIST `(MATCHES (NAME ,NAME] else (* ; "Only enumerate versions.") (push FILTERLIST `(= ,(COURIER.CREATE (FILING . FILTER.ATTRIBUTE) ATTRIBUTE _ (LIST 'NAME NAME) INTERPRETATION _ 'STRING] (SETQ VERSION (fetch NSVERSION of PARSE)) [if (NEQ VERSION '*) then (* ;  "An interesting version -- either a specific one, or none, meaning highest") (* ;  "Highest version matching seems not to work in Services 8") (push FILTERLIST (SETQ VERSIONFILTER `(= ,(COURIER.CREATE (FILING . FILTER.ATTRIBUTE) ATTRIBUTE _ (LIST 'VERSION (OR VERSION \NSFILING.HIGHEST.VERSION )) INTERPRETATION _ 'CARDINAL] [if (AND FILING.ENUMERATION.DEPTH DIRPATH) then (* ;; "Controls how many levels in hierarchy to show. If FILING.ENUMERATION.DEPTH is infinite, then let's also ignore the `files' that are subdirectories") (push SCOPELIST `(DEPTH ,(OR (SMALLP FILING.ENUMERATION.DEPTH) (PROGN (SETQ INFINITE.DEPTH T) 65535] [if FILTERLIST then (push SCOPELIST (LIST 'FILTER (if (CDR FILTERLIST) then (LIST 'AND FILTERLIST) else (CAR FILTERLIST] (PROG NIL RETRY (SETQ BULKSTREAM (FILING.CALL SESSION 'LIST (fetch NSHDATUM of HANDLE) RETURNPROPS SCOPELIST NIL SESSION 'RETURNERRORS 'KEEPSTREAM)) (if (EQ (CAR (LISTP BULKSTREAM)) 'ERROR) then (if (AND (EQUAL (CDR BULKSTREAM) '(SCOPE.VALUE.ERROR Illegal FILTER)) VERSIONFILTER (NULL VERSION)) then (* ; "old versions of Services didn't handle filtering on highest version. Compromise and return ALL versions") (LET ((SCOPE (ASSOC 'FILTER SCOPELIST))) [if (EQ (CADR SCOPE) VERSIONFILTER) then (SETQ SCOPELIST (DREMOVE SCOPE SCOPELIST )) else (* ; "SCOPE = (FILTER (AND filters))") (CL:SETF (CADADR SCOPE) (DREMOVE VERSIONFILTER (CADADR SCOPE] (SETQ VERSIONFILTER NIL) (GO RETRY)) elseif [AND FILING5 (EQUAL (CDR BULKSTREAM) '(SCOPE.VALUE.ERROR Unimplemented FILTER] then (* ;;  "Grumble. Unix implementation of filing5 doesn't support * in pathname") (SETQ FILING5 NIL) (GO TOP))) (if (STREAMP BULKSTREAM) then (SETQ RESULT (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \NSFILING.NEXTFILE) FILEINFOFN _ (FUNCTION \NSFILING.FILEINFOFN) GENFILESTATE _ (create \NSFILING.GENFILESTATE NSGENERATOR _ (BULKDATA.GENERATOR BULKSTREAM (fetch FSPROTOCOLNAME of SESSION) 'ATTRIBUTE.SEQUENCE) NSFILTER _ (AND FILTERNEEDED ( DIRECTORY.MATCH.SETUP PATTERN)) NSCONNECTION _ SESSION NSIGNOREDIRECTORIES _ INFINITE.DEPTH NSBULKSTREAM _ BULKSTREAM))) else (if (AND (LISTP BULKSTREAM) (EQ (pop BULKSTREAM) 'ERROR)) then (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because " (pop BULKSTREAM) ": ") (MAPRINT BULKSTREAM PROMPTWINDOW)) (SETQ BULKSTREAM NIL]) (* ;; "We now have either a bulk data listing stream, or we failed. Outside of the RESETLST, let's arrange to kill the listing stream on error") (if (AND RESULT (EQMEMB 'RESETLST OPTIONS)) then (RESETSAVE NIL (LIST (FUNCTION \NSFILING.CLOSE.BULKSTREAM) SESSION BULKSTREAM))) (OR RESULT (\NULLFILEGENERATOR]) (\NSFILING.GENERATE.STARS [LAMBDA (NAME) (* ; "Edited 15-Sep-87 13:09 by bvm:") (bind N while (SETQ N (STRPOS "*" NAME N)) do (SETQ NAME (CONCAT (SUBSTRING NAME 1 N) '* (OR (SUBSTRING NAME (+ N 1)) ""))) (SETQ N (+ N 3)) (* ;  "Skip past the * we found, the * we added, and the next char (since if it's a *, we don't care).") finally (RETURN NAME]) (\NSFILING.NEXTFILE [LAMBDA (GENFILESTATE NAMEONLY SCRATCHLIST) (* ; "Edited 20-Nov-87 18:34 by bvm:") (PROG ((GENERATOR (fetch NSGENERATOR of GENFILESTATE)) (SESSION (fetch NSCONNECTION of GENFILESTATE)) (FILTER (fetch NSFILTER of GENFILESTATE)) (IGNOREDIRS (fetch NSIGNOREDIRECTORIES of GENFILESTATE)) INFO NAME) LP (COND ((NULL (SETQ INFO (BULKDATA.GENERATE.NEXT GENERATOR))) (* ;  "Generator exhausted, so close the bulkdata.") (LET ((RESETSTATE NIL)) (* ; "normal close") (\NSFILING.CLOSE.BULKSTREAM SESSION (fetch NSBULKSTREAM of GENFILESTATE ))) (RETURN NIL)) ((AND IGNOREDIRS (CADR (ASSOC 'IS.DIRECTORY INFO))) (* ; "Skip directory files") (GO LP))) (SETQ NAME (\NSFILING.FULLNAME SESSION INFO)) (COND ((AND FILTER (NOT (DIRECTORY.MATCH FILTER NAME))) (GO LP))) (replace CURRENTINFO of GENFILESTATE with INFO) (RETURN (COND (NAMEONLY (NAMEFIELD NAME T)) (T NAME]) (\NSFILING.FILEINFOFN [LAMBDA (GENFILESTATE ATTRIBUTE) (* bvm%: " 1-May-84 14:04") (\NSFILING.GETFILEINFO.FROM.PLIST (fetch CURRENTINFO of GENFILESTATE) ATTRIBUTE]) (\NSFILING.RENAMEFILE [LAMBDA (DEVICE OLDNAME NEWDEVICE NEWNAME) (* ; "Edited 8-Dec-87 20:05 by bvm:") (COND ((EQ (fetch OPENFILE of NEWDEVICE) (FUNCTION \NSFILING.OPENFILE)) (\NSFILING.COPY/RENAME DEVICE OLDNAME NEWDEVICE NEWNAME)) (T (* ; "Different devices, can't rename cleverly. Ideally we should make sure that oldname is deletable, but what follows is at least not worse than the old behavior") (\GENERIC.RENAMEFILE DEVICE OLDNAME NEWDEVICE NEWNAME]) (\NSFILING.COPYFILE [LAMBDA (DEVICE FROMFILE NEWDEVICE TOFILE) (* ; "Edited 8-Dec-87 17:12 by bvm:") (COND ((EQ (fetch OPENFILE of NEWDEVICE) (FUNCTION \NSFILING.OPENFILE)) (\NSFILING.COPY/RENAME DEVICE FROMFILE NEWDEVICE TOFILE T)) (T (* ; "Different devices, can't rename cleverly. Ideally we should make sure that oldname is deletable, but what follows is at least not worse than the old behavior") (\GENERIC.COPYFILE DEVICE FROMFILE NEWDEVICE TOFILE]) (\NSFILING.COPY/RENAME [LAMBDA (DEVICE FROMFILE NEWDEVICE TOFILE COPYFLG) (* ; "Edited 9-Dec-87 18:18 by bvm:") (* ;; "Perform a COPY or RENAME (according to whether COPYFLG is T or NIL) of FROMFILE to TOFILE. DEVICE and NEWDEVICE are NS Filing devices, but not necessarily the same.") (* ;; "Between NS servers we can do a copy/rename that preserves maximal information. However, there are some unpleasantnesses: if the destination already exists, we have to delete it before starting; as far as errors go, Lisp wants RENAMEFILE to just return NIL, but COPYFILE must error.") (RESETLST [PROG ((OLDPARSE (\NSFILING.PARSE.FILENAME FROMFILE)) (NEWPARSE (\NSFILING.PARSE.FILENAME TOFILE)) SESSION NEWSESSION NEWDIR OLDDIR NEWPARENT HANDLE NEWHANDLE NEWATTRS VERSION NAME RESULT SERIALSTREAM OLDHANDLE SAME-DIR-P DEST-UNIQUE-P) (* ;; "The preliminary work is all the same--parse the source and destination, get a handle on the source name and the destination directory, check to make sure the source isn't busy and the destination doesn't yet exist.") [COND [(NULL OLDPARSE) (* ; "Bad name") (RETURN (AND COPYFLG (CL:ERROR 'XCL:INVALID-PATHNAME :PATHNAME FROMFILE] [(NULL NEWPARSE) (RETURN (AND COPYFLG (CL:ERROR 'XCL:INVALID-PATHNAME :PATHNAME TOFILE] [[OR (NULL (SETQ SESSION (\GETFILINGCONNECTION DEVICE))) (NULL (SETQ HANDLE (OR (\NSFILING.LOOKUP.CACHE SESSION FROMFILE) (\NSFILING.OPEN.HANDLE SESSION (\NSFILING.COMPOSE.PATHNAME (fetch NSDIRECTORIES of OLDPARSE) (fetch NSROOTNAME of OLDPARSE) (OR (fetch NSVERSION of OLDPARSE) '+] (* ;  "Can't get to server, or can't get handle on FROMFILE") (RETURN (AND COPYFLG (CL:ERROR 'XCL:FILE-NOT-FOUND :PATHNAME FROMFILE] [[OR (AND (NULL COPYFLG) (NEQ (fetch NSHBUSYCOUNT of HANDLE) 0)) (\NSFILING.CONFLICTP DEVICE SESSION HANDLE (if COPYFLG then 'INPUT else 'OUTPUT] (* ; "File is in use") (RETURN (AND COPYFLG (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME FROMFILE] ([NULL (SETQ NEWSESSION (if (EQ DEVICE NEWDEVICE) then (* ; "Same session will do") SESSION else (\GETFILINGCONNECTION NEWDEVICE] (* ; "Can't get to destination") (RETURN (AND COPYFLG (CL:ERROR 'XCL:FILE-NOT-FOUND :PATHNAME TOFILE] (SETQ NEWDIR (fetch NSDIRECTORIES of NEWPARSE)) (SETQ VERSION (fetch NSVERSION of NEWPARSE)) (if (OR VERSION (fetch NSHDIRECTORYP of HANDLE)) then (* ;  "Destination is uniquely specified, down to the version. Directories try hard to be version 1.") (SETQ DEST-UNIQUE-P T)) (if (NULL (SETQ NAME (fetch NSROOTNAME of NEWPARSE))) then (* ;  "Interpret last directory as the name") (SETQ NAME (CAR (LAST NEWDIR))) (SETQ NEWDIR (CL:BUTLAST NEWDIR))) (if [AND (NULL COPYFLG) (EQ DEVICE NEWDEVICE) (EQ (LENGTH NEWDIR) (LET [(N (LENGTH (SETQ OLDDIR (fetch NSDIRECTORIES of OLDPARSE ] (if (fetch NSHDIRECTORYP of HANDLE) then (* ;  "Don't count the last directory--it's the %"file%"") (- N 1) else N))) (for DIR in NEWDIR always (STRING-EQUAL DIR (pop OLDDIR] then (* ; "RENAME uses a simpler call in the case where the source and destination directories are identical") (SETQ SAME-DIR-P T)) [SETQ NEWATTRS `((NAME ,(\NSFILING.REMOVEQUOTES NAME)) ,@(AND VERSION `((VERSION ,VERSION] [COND ([AND (OR (NOT SAME-DIR-P) DEST-UNIQUE-P) (NULL (SETQ NEWPARENT (\NSFILING.CONNECT NEWSESSION NEWDIR T T] (* ; "Couldn't get handle on destination directory. Don't bother if we don't need this handle (we don't need it for rename on same dir unless there is a uniqueness question)") (RETURN (AND COPYFLG (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME TOFILE] [COND ((AND DEST-UNIQUE-P (SETQ OLDHANDLE (\NSFILING.OPEN.HANDLE NEWSESSION NEWATTRS NIL 'NOERROR NEWPARENT))) (* ;  "Destination already exists, so we'll get a NotUnique error if we COPY/MOVE/SERIALIZE directly.") (if (if (fetch NSHDIRECTORYP of OLDHANDLE) then (* ;  "Old directory ok if it has children or we're copying a non-directory") (OR (NOT (fetch NSHDIRECTORYP of HANDLE)) (NOT (\NSFILING.CHILDLESS-P NEWSESSION OLDHANDLE))) else (* ; "Not file to directory, please") (fetch NSHDIRECTORYP of HANDLE)) then (* ; "Don't try to overwrite") (CL:FORMAT PROMPTWINDOW "~%%Destination ~A already exists." TOFILE) (RETURN (AND COPYFLG (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME TOFILE] [if (AND (NULL COPYFLG) (OR OLDHANDLE (NEQ DEVICE NEWDEVICE))) then (* ; "RENAME case: we are about to do something we'd rather not do (delete destination or copy file) if in the end we're not going to have delete access to the source, so check now.") (if (SETQ RESULT (\NSFILING.CHECK.ACCESS SESSION HANDLE 'WRITE)) then (* ; "No access to delete source") (RETURN (AND COPYFLG (\NSFILING.HANDLE.ERROR SESSION RESULT FROMFILE] [if OLDHANDLE then (* ;  "To overwrite old file, have to delete current file first") [if (SETQ RESULT (FILING.CALL NEWSESSION 'DELETE (fetch NSHDATUM of OLDHANDLE) NEWSESSION 'RETURNERRORS)) then (* ; "Failed to delete it") (RETURN (AND COPYFLG (\NSFILING.HANDLE.ERROR NEWSESSION RESULT TOFILE] (* ;  "Delete succeeded, handle now invalid") (replace FSCACHEDHANDLES of NEWSESSION with (DREMOVE OLDHANDLE (fetch FSCACHEDHANDLES of NEWSESSION] [if (NOT SAME-DIR-P) then (* ; "Be sure not to copy protection along with the file. Only exception is a same-dir rename. You might want the protection to come along, but it's likely to cause confusion.") (SETQ NEWATTRS (APPEND NEWATTRS `((ACCESS.LIST ,(COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T)) ,@(AND (fetch NSHDIRECTORYP of HANDLE) `((DEFAULT.ACCESS.LIST ,(COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T] (* ;; "Ok, we should be ready to do the copy. If it's the same server, can just use the COPY command, else have to serialize and deserialize") [SETQ RESULT (if (EQ DEVICE NEWDEVICE) then (* ; "Easy case") (if COPYFLG then (FILING.CALL SESSION 'COPY (fetch NSHDATUM of HANDLE) (fetch NSHDATUM of NEWPARENT) NEWATTRS NIL SESSION 'RETURNERRORS) elseif SAME-DIR-P then (* ;  "Same directories, just change attributes") (FILING.CALL SESSION 'CHANGE.ATTRIBUTES (fetch NSHDATUM of HANDLE) NEWATTRS SESSION 'RETURNERRORS) else (* ;  "Move file to new directory and change its name at the same time") (FILING.CALL SESSION 'MOVE (fetch NSHDATUM of HANDLE) (fetch NSHDATUM of NEWPARENT) NEWATTRS SESSION 'RETURNERRORS)) elseif (SETQ RESULT (\NSFILING.CHECK.ACCESS NEWSESSION NEWPARENT 'ADD)) then (* ; "No access to write destination") (RETURN (AND COPYFLG (\NSFILING.HANDLE.ERROR SESSION RESULT FROMFILE))) else (* ; "Copy with serialize-deserialize") (if (TYPENAMEP (SETQ SERIALSTREAM (FILING.CALL SESSION 'SERIALIZE (fetch NSHDATUM of HANDLE ) NIL SESSION 'RETURNERRORS 'KEEPSTREAM)) 'STREAM) then (CL:UNWIND-PROTECT [PROGN (add (fetch NSHBUSYCOUNT of HANDLE) 1) (RELEASE.MONITORLOCK (fetch FSSESSIONLOCK of SESSION)) (* ;  "we don't need this lock while transferring--don't keep the session busy") (PROG1 (\NSFILING.DESERIALIZE1 NEWSESSION NEWPARENT NEWATTRS SERIALSTREAM (FUNCTION \BULK.DATA.CLOSE)) (if (NOT COPYFLG) then (* ;  "we need to get the source lock back in order to delete the source.") (OBTAIN.MONITORLOCK (fetch FSSESSIONLOCK of SESSION)))) ] (* ;; "Cleanup after the SERIALIZE finishes") (add (fetch NSHBUSYCOUNT of HANDLE) -1) (\BULK.DATA.CLOSE SERIALSTREAM) (\NSFILING.RELEASE.BULKSTREAM SESSION SERIALSTREAM)) else (RETURN (AND COPYFLG (\NSFILING.HANDLE.ERROR SESSION HANDLE FROMFILE] (RETURN (COND ((NEQ (CAR (LISTP RESULT)) 'ERROR) (* ; "Success--note new file in cache") (SETQ NEWHANDLE (if (OR COPYFLG (NEQ DEVICE NEWDEVICE)) then (\NSFILING.ADD.TO.CACHE NEWSESSION (create FILINGHANDLE NSHDATUM _ RESULT)) else (* ;  "In place move invalidates our knowledge about handle") (replace NSHATTRIBUTES of HANDLE with (replace NSHNAME of HANDLE with NIL)) HANDLE)) [if (AND (NULL COPYFLG) (NEQ DEVICE NEWDEVICE)) then (* ; "Now have to delete the source") (if (SETQ RESULT (FILING.CALL SESSION 'DELETE (fetch NSHDATUM of HANDLE) SESSION 'RETURNERRORS)) then (* ; "Failed to delete it. Unclear what we should do about the destination at this point. I planned on not getting this error, so tell user. Typical case: I tried to move a directory one of whose children I do not have delete access to") (RELEASE.MONITORLOCK (fetch FSSESSIONLOCK of SESSION)) (RELEASE.MONITORLOCK (fetch FSSESSIONLOCK of NEWSESSION)) (* ;  "Release locks so not tied up while in error") (RETURN (CL:ERROR "Successfully copied ~A to ~A, but failed to delete the source because ~A: ~A." (\NSFILING.FULLNAME SESSION HANDLE) (\NSFILING.FULLNAME NEWSESSION NEWHANDLE) (CADR RESULT) (CADDR RESULT] (\NSFILING.FULLNAME NEWSESSION NEWHANDLE)) (COPYFLG (* ; "Failure--signal some error") (\NSFILING.HANDLE.ERROR NEWSESSION RESULT TOFILE])]) ) (* ; "Random access methods") (DEFINEQ (\NSRANDOM.CLOSEFILE [LAMBDA (STREAM) (* ; "Edited 20-Nov-87 17:28 by bvm:") (* ;; "Close method for a stream open on the random access Filing device") (RESETLST (PROG ((SESSION (fetch NSFILING.CONNECTION of STREAM))) (if SESSION then (* ;; "We ought not have to do this, but sometimes ill-disciplined folk try to close the same stream twice, by lazily calling CLOSEF? and getting in here while we're talking to the server. We don't have monitor locks per stream (though we probably should), so use the session's lock. This is obviously inadequate in general, since the session might have died, but it should handle the average case.") (OBTAIN.MONITORLOCK (fetch FSSESSIONLOCK of SESSION) NIL T)) (if (NULL (fetch (STREAM ACCESS) of STREAM)) then (* ; "Somebody else already closed us") (RETURN)) (\CLEARMAP STREAM) (* ; "Force out dirty buffers") (COND ((DIRTYABLE STREAM) (* ; "Truncate to current length") (\NSRANDOM.TRUNCATEFILE STREAM))) (\NSRANDOM.RELEASE.HANDLE STREAM) (* ; "Release controls") (\GENERIC-UNREGISTER-STREAM (fetch DEVICEINFO of (fetch DEVICE of STREAM)) STREAM) (replace (STREAM ACCESS) of STREAM with NIL))) STREAM]) (\NSRANDOM.RELEASE.HANDLE [LAMBDA (STREAM) (* ; "Edited 20-Nov-87 17:00 by bvm:") (* ;; "Release STREAM's hold on its file handle. We also remove the HANDLE and CONNECTION from the stream, etc.") (LET ((HANDLE (fetch NSFILING.HANDLE of STREAM)) (SESSION (fetch NSFILING.CONNECTION of STREAM))) (replace NSFILING.HANDLE of STREAM with NIL) (replace NSFILING.CONNECTION of STREAM with NIL) (COND ((NULL HANDLE)) ((NEQ (fetch NSHBUSYCOUNT of HANDLE) 1) (* ;; "More than one user, so keep controls") (add (fetch NSHBUSYCOUNT of HANDLE) -1)) (T (replace NSHBUSYCOUNT of HANDLE with 0) (COND ((AND SESSION (fetch NSHACCESS of HANDLE)) (* ; "Release lock held on the handle. Session may have been dropped, in which case no need to change control") (\NSRANDOM.RELEASE.LOCK SESSION HANDLE]) (\NSRANDOM.RELEASE.LOCK [LAMBDA (SESSION HANDLE) (* ; "Edited 3-Jun-87 18:22 by bvm:") (FILING.CALL SESSION 'CHANGE.CONTROLS (fetch NSHDATUM of HANDLE) '((LOCK NONE)) SESSION 'RETURNERRORS) (replace NSHACCESS of HANDLE with NIL]) (\NSRANDOM.RELEASE.IF.ERROR [LAMBDA (SESSION HANDLE) (* ; "Edited 26-Aug-87 15:30 by bvm:") (AND RESETSTATE (\NSRANDOM.RELEASE.LOCK SESSION HANDLE]) (\NSRANDOM.CREATE.STREAM [LAMBDA (SESSION HANDLE ACCESS GOTCONTROLS OLDSTREAM CHECKACCESS) (* ; "Edited 19-Aug-88 17:24 by bvm") (PROG NIL [COND ((NOT GOTCONTROLS) (* ;; "Acquire lock on file for duration of open stream. Need this so that nobody can get in between calls to RetrieveBytes or ReplaceBytes") (LET ((OLDACCESS (fetch NSHACCESS of HANDLE)) ERROR) [COND ((SELECTQ OLDACCESS ((NIL) (* ;  "Just a cached handle, no controls") NIL) (OUTPUT (* ;  "Handle already open for write, can't do anything else") T) (INPUT (* ;  "Open for input, so only other input streams allowed.") (NEQ ACCESS 'INPUT)) (SHOULDNT)) (RETURN (LISPERROR "FILE WON'T OPEN" (\NSFILING.FULLNAME SESSION HANDLE] (COND ((NEQ OLDACCESS 'INPUT) (* ;  "Get a share/exclusive control. If OLDACCESS is INPUT, we have already obtained this control") (COND ((SETQ ERROR (FILING.CALL SESSION 'CHANGE.CONTROLS (fetch NSHDATUM of HANDLE) `[(LOCK ,(SELECTQ ACCESS (INPUT 'SHARE) 'EXCLUSIVE] SESSION 'RETURNERRORS)) (RETURN ERROR))) (RESETSAVE NIL (LIST (FUNCTION \NSRANDOM.RELEASE.IF.ERROR) SESSION HANDLE)) (* ;  "If this open doesn't succeed, be sure to release this lock.") (replace NSHACCESS of HANDLE with (SELECTQ ACCESS ((BOTH APPEND) 'OUTPUT) ACCESS] [COND (CHECKACCESS (* ;; "Problem: How can we tell NOW whether we have access rights to write this file? At least in the case of a new file, the CREATE procedure will tell us if we had ADD access, but even then we might perversely not have WRITE access.") (LET [(ERROR (\NSFILING.CHECK.ACCESS SESSION HANDLE 'WRITE] (AND ERROR (RETURN ERROR] (LET* ((ATTRS (OR (fetch NSHATTRIBUTES of HANDLE) (\NSFILING.FILLIN.ATTRIBUTES SESSION HANDLE))) (LEN (CADR (ASSOC 'SIZE.IN.BYTES ATTRS))) S EOF) [COND (OLDSTREAM [LET [(OLDATTRS (fetch NSHATTRIBUTES of (fetch NSFILING.HANDLE of OLDSTREAM] (COND ([OR (NOT (EQUAL LEN (fetch NSFILING.SERVER.LENGTH of OLDSTREAM))) (NOT (EQUAL (CADR (ASSOC 'CREATED.ON ATTRS)) (CADR (ASSOC 'CREATED.ON OLDATTRS] (* ; "file has changed!") (\NSRANDOM.STREAM.CHANGED OLDSTREAM HANDLE] (* ;  "If got here, user let us continue") (replace NSFILING.HANDLE of (SETQ S OLDSTREAM) with HANDLE)) (T (SETQ EOF (SELECTQ ACCESS (OUTPUT 0) LEN)) (SETQ S (create STREAM EPAGE _ (FOLDLO EOF BYTESPERPAGE) EOFFSET _ (IMOD EOF BYTESPERPAGE) MULTIBUFFERHINT _ T)) (if (EQ ACCESS 'APPEND) then (* ; "File pos at end") (freplace (STREAM CPAGE) of S with (fetch (STREAM EPAGE) of S)) (freplace (STREAM COFFSET) of S with (fetch (STREAM EOFFSET) of S)) else (* ; "File pos at start") (freplace (STREAM CPAGE) of S with 0) (freplace (STREAM COFFSET) of S with 0] (replace NSFILING.SERVER.LENGTH of S with LEN) (RETURN S]) (\NSRANDOM.READPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* ; "Edited 3-Sep-87 12:03 by bvm:") (* ;; "Read pages method for NSFIling Random access device.") (COND ((LISTP BUFFERS) (\NSRANDOM.READ.SEGMENT STREAM FIRSTPAGE# BUFFERS)) (T (* ;; "Single buffer. We special case this because we want to in general fetch several pages at once to improve performance") (COND ((NULL (fetch NSFILING.CONNECTION of STREAM)) (* ; "Session lost, e.g., after logout. Want to reestablish stream immediately, even if all we're going to do is clear the buffer.") (\NSRANDOM.REESTABLISH STREAM))) [LET ((EP (fetch (STREAM EPAGE) of STREAM)) (EO (fetch (STREAM EOFFSET) of STREAM)) CACHE NMORE EXTRABUFFERS) (COND ((OR (> FIRSTPAGE# EP) (AND (EQ FIRSTPAGE# EP) (EQ EO 0))) (* ; "Past eof. This is silly") (\CLEARBYTES BUFFERS 0 BYTESPERPAGE)) [(SETQ CACHE (\NSRANDOM.FETCH.CACHE STREAM FIRSTPAGE#)) (* ;  "We fetched it earlier, so this is easy") (\BLT BUFFERS (CADR CACHE) WORDSPERPAGE) (COND (\NSRANDOM.CHECK.CACHE (\NSRANDOM.CHECK.CACHE (fetch NSFILING.PAGE.CACHE of STREAM] (T (* ;  "Have to fetch it. Get next few pages while we're at it.") [COND ((AND (>= FIRSTPAGE# (fetch NSFILING.LAST.REQUEST of STREAM)) (PROGN [for I from 1 to (SETQ NMORE (IMIN *NSFILING-PAGE-CACHE-INCREMENT* (- (if (DIRTYABLE STREAM) then (* ; "For output files, it is possible for our local eof to be greater than the server's, in which case we'd better not try to read.") (FOLDLO (SUB1 (fetch NSFILING.SERVER.LENGTH of STREAM)) BYTESPERPAGE) elseif (EQ EO 0) then (SUB1 EP) else EP) FIRSTPAGE#))) when (\NSRANDOM.FETCH.CACHE STREAM (+ FIRSTPAGE# I) T) do (* ;; "This page already cached, so don't bother fetching it again. Notice that this algorithm is pessimal for reading a file backward, but it's hard for me to do better without more knowledge of what's already buffered in the stream.") (RETURN (SETQ NMORE (SUB1 I] (NEQ NMORE 0))) (* ;; "Ok, have a range to read. First check says don't read multiple if going backward in file (I don't know how to do this well--there are many common cases, such as Lafite get mail and backward searches, that would be handled pessimally if I retrieve multiple pages here).") (SETQ EXTRABUFFERS (\NSRANDOM.PREPARE.CACHE STREAM NMORE] (\NSRANDOM.READ.SEGMENT STREAM FIRSTPAGE# BUFFERS EXTRABUFFERS NMORE) (COND (\NSRANDOM.CHECK.CACHE (\NSRANDOM.CHECK.CACHE (fetch NSFILING.PAGE.CACHE of STREAM) T] (replace NSFILING.LAST.REQUEST of STREAM with FIRSTPAGE#]) (\NSRANDOM.READ.SEGMENT [LAMBDA (STREAM FIRSTPAGE# BUFFERS EXTRABUFFERS NEXTRA)(* ; "Edited 27-Aug-87 11:30 by bvm:") (* ;; "Read contents of STREAM starting at FIRSTPAGE# into successive members of BUFFERS. In the case that BUFFERS is a single buffer, read additional NEXTRA pages into page cache entries EXTRABUFFERS.") (PROG (SESSION) RETRY (COND ((NULL (SETQ SESSION (fetch NSFILING.CONNECTION of STREAM))) (* ;  "Session lost, e.g., after logout") (\NSRANDOM.REESTABLISH STREAM) (GO RETRY))) (LET* ((EP (fetch (STREAM EPAGE) of STREAM)) (EO (fetch (STREAM EOFFSET) of STREAM)) [BYTESTOFETCH (COND [EXTRABUFFERS (* ;  "Caller assures us that at worst, the last extra buffer is the end of file.") (+ (UNFOLD NEXTRA BYTESPERPAGE) (COND ((EQ (+ FIRSTPAGE# NEXTRA) EP) EO) (T BYTESPERPAGE] (T (* ; "Just a single list of buffers") (for BUF inside BUFFERS as PAGE from FIRSTPAGE# sum (COND ((< PAGE EP) BYTESPERPAGE) ((EQ PAGE EP) EO) (T 0] (HANDLE (fetch NSFILING.HANDLE of STREAM)) BYTES-TIL-EOF) (COND [[AND (NEQ BYTESTOFETCH 0) (OR (NOT (DIRTYABLE STREAM)) (COND ([> BYTESTOFETCH (SETQ BYTES-TIL-EOF (- (fetch NSFILING.SERVER.LENGTH of STREAM) (UNFOLD FIRSTPAGE# BYTESPERPAGE] (* ; "For output files, it is possible for our local eof to be greater than the server's, in which case we'd better not try to read.") (> (SETQ BYTESTOFETCH BYTES-TIL-EOF) 0)) (T T] (* ; "There is something to retrieve") (LET [(ERROR (FILING.CALL SESSION 'RETRIEVE.BYTES (fetch NSHDATUM of HANDLE) (COURIER.CREATE (FILING . BYTE.RANGE) FIRSTBYTE _ (UNFOLD FIRSTPAGE# BYTESPERPAGE) COUNT _ BYTESTOFETCH) [FUNCTION (LAMBDA (BULKSTREAM) (* ;; "What to do with the bulk data") (LET ((PAGENO FIRSTPAGE#) (TOTALBYTES BYTESTOFETCH)) (* ; "Note that we must keep local copy of the number of bytes expected, since FILING.CALL can iterate (when stream lost).") (for BUF inside BUFFERS do (COND ((>= TOTALBYTES BYTESPERPAGE) (* ; "Fetch a whole page") (\BINS BULKSTREAM BUF 0 BYTESPERPAGE) (SETQ TOTALBYTES (- TOTALBYTES BYTESPERPAGE))) ((> TOTALBYTES 0) (* ;  "Fetch remaining bytes of last page") (\BINS BULKSTREAM BUF 0 TOTALBYTES) (\CLEARBYTES BUF TOTALBYTES (- BYTESPERPAGE TOTALBYTES)) (SETQ TOTALBYTES 0)) (T (* ;  "At end of actual file, so just clear buffer") (\CLEARBYTES BUF 0 BYTESPERPAGE))) (add PAGENO 1)) (from 1 to NEXTRA as PAIR in EXTRABUFFERS do (RPLACA PAIR -1) (* ; "Temporarily make invalid") (COND ((>= TOTALBYTES BYTESPERPAGE) (* ; "Fetch a whole page") (\BINS BULKSTREAM (CADR PAIR) 0 BYTESPERPAGE) (SETQ TOTALBYTES (- TOTALBYTES BYTESPERPAGE))) ((> TOTALBYTES 0) (* ;  "Fetch remaining bytes of last page") (\BINS BULKSTREAM (CADR PAIR) 0 TOTALBYTES) (\CLEARBYTES (CADR PAIR) TOTALBYTES (- BYTESPERPAGE TOTALBYTES)) (SETQ TOTALBYTES 0)) (T (* ; "This better never happen") (HELP "Inconsistency in READPAGE byte count" ))) (RPLACA PAIR PAGENO) (add PAGENO 1)) (COND ((NOT (EOFP BULKSTREAM)) (* ;  "RetrieveBytes returned more data than we requested.") (COURIER.ABORT.BULKDATA '(ERROR TRANSFER.ERROR FormatIncorrect] SESSION 'RETURNERRORS] (COND (ERROR (\NSRANDOM.HANDLE.ERROR ERROR STREAM SESSION 'RETRIEVE.BYTES) (GO RETRY))) (COND ((NOT (fetch NSHWASREAD of HANDLE)) (* ;; "Reading file has changed its read date. We assume this happens only once per handle, that the file service does not change the date on every read!") (LET [(ATTR (ASSOC 'READ.ON (fetch NSHATTRIBUTES of HANDLE] [COND (ATTR (replace NSHATTRIBUTES of HANDLE with (DREMOVE ATTR (fetch NSHATTRIBUTES of HANDLE] (replace NSHWASREAD of HANDLE with T] (T (* ;  "Nothing to retrieve, just clear buffers (pmap code ought to catch this)") (for BUF inside BUFFERS do (\CLEARBYTES BUF 0 BYTESPERPAGE]) (\NSRANDOM.PREPARE.CACHE [LAMBDA (STREAM NPAGES) (* ; "Edited 10-Jun-87 20:33 by bvm:") (LET ((CACHE (fetch NSFILING.PAGE.CACHE of STREAM))) (COND ((NULL CACHE) (* ;  "No cache yet, so create one with n pages in it") [SETQ CACHE (for I from 1 to NPAGES collect (LIST -1 (NCREATE 'VMEMPAGEP] (replace NSFILING.PAGE.CACHE of STREAM with (create NSPAGECACHE NSPSIZE _ NPAGES NSPTAIL _ (LAST CACHE) NSPBUFFERS _ CACHE)) CACHE) (T (COND (\NSRANDOM.CHECK.CACHE (\NSRANDOM.CHECK.CACHE CACHE))) (PROG ((OLDSIZE (fetch NSPSIZE of CACHE)) (HEAD (fetch NSPHEADER of CACHE)) PREV FREETAIL NAVAIL NCREATED NNEEDED) RETRY (SETQ FREETAIL HEAD) (* ;  "Find first free cache page. (CDR HEAD) is the first buffer.") (while (SETQ FREETAIL (CDR (SETQ PREV FREETAIL))) when (EQ (CAAR FREETAIL) -1) do (* ; "This buffer is free") (SETQ NAVAIL 1) [bind PREVFREE (MORETAIL _ FREETAIL) while (SETQ MORETAIL (CDR (SETQ PREVFREE MORETAIL))) do (COND ((EQ (CAAR MORETAIL) -1) (add NAVAIL 1)) (T (* ;  "Not all empty's are at end. Move these there and try again.") (UNINTERRUPTABLY (* ;; "Want to transform PREV.FREETAIL...PREVFREE.MORETAIL...LAST to be PREV.MORETAIL...LAST.FREETAIL...PREVFREE") (RPLACD PREV MORETAIL) (* ; "Splice out") (RPLACD PREVFREE NIL) (RPLACD (fetch (NSPAGECACHE NSPTAIL) of CACHE) FREETAIL) (* ; "Attach to end of list") (replace (NSPAGECACHE NSPTAIL) of CACHE with PREVFREE) (* ; "Update end pointer") ) (GO RETRY] (RETURN) finally (* ; "No free buffers found") (SETQ NAVAIL 0)) (* ;; "There are now NAVAIL free buffers, the first of which is in NEWTAIL") [COND [(<= NPAGES NAVAIL) (* ;  "That's enough, don't need to allocate any") (SETQ NCREATED 0) (RPTQ (- NAVAIL NPAGES) (* ;  "Want to use the LAST n pages in the case where there are more free pages than we need") (SETQ FREETAIL (CDR (SETQ PREV FREETAIL] [(<= (SETQ NNEEDED (- NPAGES NAVAIL)) (SETQ NCREATED (- *NSFILING-PAGE-CACHE-LIMIT* OLDSIZE))) (* ; "NCREATED (Maximum buffers we can add) is more than we need, so use free buffers found above plus just what we need") (SETQ NCREATED NNEEDED) (COND ((NULL FREETAIL) (* ;  "All the created buffers get used, no old ones, so they all go on front.") (SETQ FREETAIL (CDR (SETQ PREV HEAD] ((< NPAGES *NSFILING-PAGE-CACHE-LIMIT*) (* ; "Create as buffers to get up to limit, and additionally use as many old buffers as needed to get n.") (SETQ PREV (CL:NTHCDR (- OLDSIZE (- NPAGES NCREATED)) HEAD)) (* ;  "Fast version of (NLEFT Buffers NPAGES-NCREATED)") (SETQ FREETAIL (CDR PREV))) (T (* ; "Perverse case--usually increment < limit. But do it anyway: use all existing buffers, and allocate enough new ones to satisfy request.") (SETQ NCREATED (- NPAGES OLDSIZE)) (SETQ PREV HEAD) (SETQ FREETAIL (CDR PREV] (* ;; "Have HEAD-->FIRST...PREV.FREETAIL...LAST and want to turn it into HEAD-->NewBufs.FREETAIL...LAST.FIRST...PREV") [to NCREATED do (push FREETAIL (LIST -1 (NCREATE 'VMEMPAGEP] (* ; "Create new buffers as needed") (UNINTERRUPTABLY (* ;  "Need to maintain consistency here...") (COND ([AND (NEQ PREV HEAD) (NOT (NULL (CDR PREV] (* ;  "There is non-trivial rearrangement to be done.") (RPLACD PREV NIL) (* ; "PREV is new end of list") (RPLACD (fetch NSPTAIL of CACHE) (CDR HEAD)) (* ; "Splice old head onto old last") (replace NSPTAIL of CACHE with PREV) (* ; "PREV is new last") )) (RPLACD HEAD FREETAIL) (* ; "New buffer list") [COND ((NEQ NCREATED 0) (replace NSPSIZE of CACHE with (+ OLDSIZE NCREATED]) (RETURN FREETAIL]) (\NSRANDOM.FETCH.CACHE [LAMBDA (STREAM PAGENO KEEP) (* ; "Edited 3-Sep-87 12:03 by bvm:") (LET ((CACHE (fetch NSFILING.PAGE.CACHE of STREAM))) (COND (CACHE (LET ((TAIL (fetch (NSPAGECACHE NSPHEADER) of CACHE)) PREV PAIR) (* ;; "Cache is constructed so that there is always a header node we can rplacd to change first element of real list. Contents of header node happens to be the pointer to the tail of the list.") (while (SETQ TAIL (CDR (SETQ PREV TAIL))) when (EQ (CAR (SETQ PAIR (CAR TAIL))) PAGENO) do (* ; "Found it. ") (COND ((NOT KEEP) (* ;  "Removing it from cache, so move node to end of list.") [COND ((CDR TAIL) (* ; "Not already at end") (UNINTERRUPTABLY (RPLACD PREV (CDR TAIL)) (* ; "Splice out") (RPLACD TAIL NIL) (RPLACD (fetch (NSPAGECACHE NSPTAIL) of CACHE) TAIL) (* ; "Attach to end of list") (replace (NSPAGECACHE NSPTAIL) of CACHE with TAIL) (* ; "Update end pointer") )] (* ;  "Mark pair with impossible page number -1") (RPLACA PAIR -1))) (RETURN PAIR]) (\NSRANDOM.CHECK.CACHE [LAMBDA (CACHE CHECKORDER) (* ; "Edited 10-Jun-87 19:21 by bvm:") (COND ((NULL CACHE) (* ; "Empty cache") NIL) ((NEQ (fetch NSPSIZE of CACHE) (LENGTH (fetch NSPBUFFERS of CACHE))) (HELP "Cache length is wrong")) ((NEQ (fetch (NSPAGECACHE NSPTAIL) of CACHE) (LAST (fetch NSPBUFFERS of CACHE))) (HELP "Cache tail pointer is wrong")) (CHECKORDER (for X in (fetch NSPBUFFERS of CACHE) bind EMPTY do (COND [EMPTY (COND ((NEQ (CAR X) -1) (HELP "Cache empty elements not all at end"] ((EQ (CAR X) -1) (SETQ EMPTY T]) (\NSRANDOM.WRITEPAGES [LAMBDA (STREAM FIRSTPAGE# BUFFERS) (* ; "Edited 9-Oct-87 15:52 by bvm:") (* ;; "Write pages method for NS random access file.") (PROG (SESSION) (for BUF inside BUFFERS as P from FIRSTPAGE# do (* ;; "Flush these pages from cache if they happen to have been prefetched. Problem is that prefetch doesn't see what the stream itself has buffered in its pmap buffers, so could have fetched a page even though there is a local copy, possibly dirty even.") (\NSRANDOM.FETCH.CACHE STREAM P)) RETRY (COND ((NULL (SETQ SESSION (fetch NSFILING.CONNECTION of STREAM))) (* ;  "Session lost, e.g., after logout") (\NSRANDOM.REESTABLISH STREAM) (GO RETRY))) (LET ((CURRENTEOF (fetch NSFILING.SERVER.LENGTH of STREAM)) (HANDLE (fetch NSFILING.HANDLE of STREAM)) (FIRSTBYTE (UNFOLD FIRSTPAGE# BYTESPERPAGE)) BYTES-TIL-EOF BYTESTOSTORE ATTRS ERROR LASTPAGE) [SETQ BYTESTOSTORE (for BUF inside BUFFERS as old LASTPAGE from FIRSTPAGE# bind (EP _ (fetch (STREAM EPAGE) of STREAM)) sum (COND ((EQ LASTPAGE EP) (fetch (STREAM EOFFSET) of STREAM)) (T BYTESPERPAGE] (COND ((EQ BYTESTOSTORE 0) (* ;  "Nothing to write. Stupid of pmap to call us.") (RETURN))) [COND ((fetch REVALIDATEFLG of STREAM) (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write. Otherwise, it is possible to see a change to the file but no change to the creationdate") (OR (\NSRANDOM.UPDATE.VALIDATION STREAM SESSION HANDLE) (GO RETRY] (COND ((< (SETQ BYTES-TIL-EOF (- CURRENTEOF FIRSTBYTE)) 0) (* ; "Writing past end of file?") (\NSRANDOM.TRUNCATEFILE STREAM (FOLDLO FIRSTBYTE BYTESPERPAGE) (IMOD FIRSTBYTE BYTESPERPAGE)) (SETQ CURRENTEOF FIRSTBYTE) (SETQ BYTES-TIL-EOF 0))) [SETQ ERROR (COND [(AND (< BYTES-TIL-EOF BYTESTOSTORE) (NEQ BYTES-TIL-EOF 0)) (* ; "Range to write overlaps eof. Filing doesn't like this, so write the first part, then the last part") (OR (\NSRANDOM.WRITE.SEGMENT SESSION HANDLE BUFFERS FIRSTBYTE BYTES-TIL-EOF) (\NSRANDOM.WRITE.SEGMENT SESSION HANDLE (COND ((NLISTP BUFFERS) BUFFERS) (T (CL:NTHCDR (FOLDLO BYTES-TIL-EOF BYTESPERPAGE) BUFFERS))) CURRENTEOF (- BYTESTOSTORE BYTES-TIL-EOF] (T (* ; "Ok to write in one segment") (\NSRANDOM.WRITE.SEGMENT SESSION HANDLE BUFFERS FIRSTBYTE BYTESTOSTORE] (COND (ERROR (\NSRANDOM.HANDLE.ERROR ERROR STREAM SESSION 'REPLACE.BYTES) (GO RETRY))) (\NSRANDOM.WROTE.HANDLE SESSION HANDLE) (* ;  "Writing data to file has (potentially) changed its creationdate.") [COND ((< (- CURRENTEOF FIRSTBYTE) BYTESTOSTORE) (* ;  "Wrote to eof, so update remote eof") (replace NSFILING.SERVER.LENGTH of STREAM with (SETQ CURRENTEOF (+ FIRSTBYTE BYTESTOSTORE))) (COND ((SETQ ATTRS (ASSOC 'SIZE.IN.BYTES (fetch NSHATTRIBUTES of HANDLE))) (* ;  "Update cached info about size of file") (CL:SETF (CADR ATTRS) CURRENTEOF] (replace NSFILING.LAST.REQUEST of STREAM with LASTPAGE]) (\NSRANDOM.WRITE.SEGMENT [LAMBDA (SESSION HANDLE BUFFERS FIRSTBYTE BYTESTOSTORE)(* ; "Edited 1-Jun-87 16:45 by bvm:") (* ;; "Write data from BUFFERS, a set of page buffers. FIRSTBYTE is the first byte in file to replace, BYTESTOSTORE the count. If FIRSTBYTE is not on a page boundary, start in the middle of a page.") (FILING.CALL SESSION 'REPLACE.BYTES (fetch NSHDATUM of HANDLE) (COURIER.CREATE (FILING . BYTE.RANGE) FIRSTBYTE _ FIRSTBYTE COUNT _ BYTESTOSTORE) [FUNCTION (LAMBDA (BULKSTREAM) (* ;; "What to store as the bulk data") (for BUF inside BUFFERS bind (OFFSET _ (IMOD FIRSTBYTE BYTESPERPAGE)) (BYTESLEFT _ BYTESTOSTORE) CNT do [SETQ BYTESLEFT (COND ((> (SETQ CNT (- BYTESPERPAGE OFFSET)) BYTESLEFT) (SETQ CNT BYTESLEFT) 0) (T (- BYTESLEFT CNT] (\BOUTS BULKSTREAM BUF OFFSET CNT) (SETQ OFFSET 0) repeatuntil (EQ BYTESLEFT 0] SESSION 'RETURNERRORS]) (\NSRANDOM.WROTE.HANDLE [LAMBDA (SESSION HANDLE) (* ; "Edited 9-Oct-87 15:52 by bvm:") (* ;; "Called when we did something (e.g., ReplaceBytes) that would cause the creation date to change. We assume this happens only once per handle, that the file service does not change the date on every write! Since validation depends on creationdate, we have to actually refetch it, not just zap it.") [COND ((NOT (fetch NSHWASWRITTEN of HANDLE)) (LET [(NEWINFO (FILING.CALL SESSION 'GET.ATTRIBUTES (fetch NSHDATUM of HANDLE) [CONSTANT (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(CREATED.ON] SESSION 'RETURNERRORS] (COND ((AND NEWINFO (NEQ (CAR NEWINFO) 'ERROR)) (* ;  "If error occurred, we don't care, since the handle is then trash.") (\NSFILING.UPDATE.ATTRIBUTES HANDLE NEWINFO) (replace NSHWASWRITTEN of HANDLE with T] (COND ((NOT (fetch NSHWASMODIFIED of HANDLE)) (* ; "Ditto write date.") (LET [(ATTR (ASSOC 'MODIFIED.ON (fetch NSHATTRIBUTES of HANDLE] [COND (ATTR (replace NSHATTRIBUTES of HANDLE with (DREMOVE ATTR (fetch NSHATTRIBUTES of HANDLE] (replace NSHWASMODIFIED of HANDLE with T]) (\NSRANDOM.SETEOFPTR [LAMBDA (STREAM NBYTES) (* ; "Edited 9-Jun-87 14:03 by bvm:") (* ;; "Change open stream length to be NBYTES. This is our own version of SETEOFPTR, since we have no need to remap the last page.") (LET ((NEWEP (fetch (BYTEPTR PAGE) of NBYTES)) (NEWEO (fetch (BYTEPTR OFFSET) of NBYTES))) (SELECTQ (\NEWLENGTHIS STREAM NEWEP NEWEO) (SHORTER (COND ((OVERWRITEABLE STREAM) (FORGETPAGES STREAM (ADD1 NEWEP) (PROG1 (fetch EPAGE of STREAM) (* ; "\seteof changes EPAGE") (\SETEOF STREAM NEWEP NEWEO))) (* ;; "FORGETPAGES tells PMAP to throw away the extra pages. The \SETEOF is done first so that an interrupt will not leave STREAM pointing to old and possibly partially overwritten pages.") (\NSRANDOM.TRUNCATEFILE STREAM NEWEP NEWEO) (* ; "Shorten the real file") T))) (SAME (* ; "Nothing to do") T) (LONGER (COND ((APPENDABLE STREAM) (\SETEOF STREAM NEWEP NEWEO) T))) (SHOULDNT]) (\NSRANDOM.TRUNCATEFILE [LAMBDA (STREAM LP LO) (* ; "Edited 9-Oct-87 15:52 by bvm:") (* ;;  "Resets the length of the file to LP page and LO offset. Can both shorten and lengthen files.") [PROG (SESSION CURRENTEOF NEWEOF) RETRY (COND ([NOT (= (SETQ CURRENTEOF (fetch NSFILING.SERVER.LENGTH of STREAM)) (SETQ NEWEOF (COND (LP (create BYTEPTR PAGE _ LP OFFSET _ LO)) (T (\GETEOFPTR STREAM] (* ; "There's something to do") (COND ((NULL (SETQ SESSION (fetch NSFILING.CONNECTION of STREAM))) (* ;  "Session lost, e.g., after logout") (\NSRANDOM.REESTABLISH STREAM) (GO RETRY))) (LET ((HANDLE (fetch NSFILING.HANDLE of STREAM)) ERROR ATTRS) [COND ((fetch REVALIDATEFLG of STREAM) (* ;; "Need to update creationdate, since a SAVEVM etc has occurred since the last write. Otherwise, it is possible to see a change to the file but no change to the creationdate") (OR (\NSRANDOM.UPDATE.VALIDATION STREAM SESSION HANDLE) (GO RETRY] (* ;; "Although you might think the right way to shorten a file is to do a ReplaceBytes on the range [newEof,EndOfFile] with zero bytes, the server rejects that. Instead, explicitly change the LENGTH attribute.") (SETQ ERROR (FILING.CALL SESSION 'CHANGE.ATTRIBUTES (fetch NSHDATUM of HANDLE) `((SIZE.IN.BYTES ,NEWEOF)) SESSION 'RETURNERRORS)) (COND (ERROR (\NSRANDOM.HANDLE.ERROR ERROR STREAM SESSION 'CHANGE.ATTRIBUTES) (GO RETRY))) (replace NSFILING.SERVER.LENGTH of STREAM with NEWEOF) (COND ((SETQ ATTRS (ASSOC 'SIZE.IN.BYTES (fetch NSHATTRIBUTES of HANDLE))) (* ;  "Update cached info about size of file") (CL:SETF (CADR ATTRS) NEWEOF))) (\NSRANDOM.WROTE.HANDLE SESSION HANDLE] STREAM]) (\NSRANDOM.UPDATE.VALIDATION [LAMBDA (STREAM SESSION HANDLE) (* ; "Edited 1-Jun-87 16:45 by bvm:") (* ;; "Called when STREAM's REVALIDATEFLG is true, meaning we need to update its creationdate to ensure that what we are about to write is noticeable if we were to boot back to the last savevm.") (LET* [[NEWATTRS `((CREATED.ON ,(IDATE] (ERROR (FILING.CALL SESSION 'CHANGE.ATTRIBUTES (fetch NSHDATUM of HANDLE) NEWATTRS SESSION 'RETURNERRORS] (COND (ERROR (\NSRANDOM.HANDLE.ERROR ERROR STREAM SESSION 'CHANGE.ATTRIBUTES) (* ; "Return NIL on failure") NIL) (T (replace REVALIDATEFLG of STREAM with NIL) (\NSFILING.UPDATE.ATTRIBUTES HANDLE NEWATTRS]) (\NSRANDOM.OPENFILE [LAMBDA (FILENAME ACCESS RECOG PARAMETERS DEVICE) (* ; "Edited 9-Feb-88 15:59 by bvm:") (* ;; "OPENFILE on the random device. This only happens when reopening a stream.") (SETQ FILENAME (if (NOT (type? STREAM FILENAME)) then (SHOULDNT "Random OPENFILE called on non-stream") elseif (OPENED FILENAME) then (\ILLEGAL.ARG FILENAME) else (* ;  "Reopening a closed stream, such as TEdit might do.") (fetch FULLFILENAME of FILENAME))) (\NSFILING.OPENFILE FILENAME ACCESS RECOG PARAMETERS (fetch DEVICEINFO of DEVICE]) ) (* ; "error handling") (DEFINEQ (\NSRANDOM.HANDLE.ERROR [LAMBDA (ERROR STREAM SESSION PROCEDURE) (* ; "Edited 27-Aug-87 11:30 by bvm:") (* ;; "Handle error in call to filing random access procedure. Most interesting one now is session error, which happens when the session times out.") (SELECTQ (CADR ERROR) (SESSION.ERROR (LET [(DEVICE (fetch DEVICEINFO of (fetch DEVICE of STREAM] (for S in (fetch OPENFILELST of DEVICE) when (EQ (fetch NSFILING.CONNECTION of S) SESSION) do (* ;  "Invalidate all streams on this connection so we're not tempted to use it again.") (replace NSFILING.CONNECTION of S with NIL)) (AND (\NSFILING.GET.NEW.SESSION SESSION DEVICE T) (\NSRANDOM.REESTABLISH STREAM)))) (SPACE.ERROR (* ;  "Ran out of space writing the file") (\NSRANDOM.PROCEEDABLE.ERROR STREAM 'XCL:FS-RESOURCES-EXCEEDED (LIST :PATHNAME (fetch FULLFILENAME of STREAM)))) (ACCESS.ERROR (* ; "Grumble. Can happen if you open an old file for output, or create a file in a directory to which you have ADD but not WRITE access.") (\NSRANDOM.PROCEEDABLE.ERROR STREAM "Attempt to ~:[read~;write to~] file ~A failed because: ~A. How shall I proceeed?" (LIST (NEQ PROCEDURE 'RETRIEVE.BYTES) (FULLNAME STREAM) (CADDR ERROR)))) (TRANSFER.ERROR (* ;  "Something went wrong in transit. let's try it again.") (PRINTOUT PROMPTWINDOW T "Access to " (FULLNAME STREAM) " failed because: " (CADDR ERROR) "; " "will retry.")) (COURIER.SIGNAL.ERROR (fetch FSPROTOCOLNAME of SESSION) PROCEDURE ERROR]) (\NSRANDOM.PROCEEDABLE.ERROR [LAMBDA (STREAM ERROR ERRORARGS PROCEED-DETAILS) (* ; "Edited 5-Feb-88 13:45 by amd") (* ;; "Enter the debugger because of a problem with STREAM. ERROR and ERRORARGS are passed to CL:ERROR. PROCEED-DETAILS, if non-NIL, is a format string describing what will happen if you choose the proceed option PROCEED (or OK). Returns only if CONTINUE was selected.") (CONDITIONS:RESTART-CASE (CL:APPLY (FUNCTION CL:ERROR) ERROR ERRORARGS) (CONDITIONS:CONTINUE NIL :REPORT (CL:LAMBDA (ERR-STRM) (CL:FORMAT ERR-STRM (OR PROCEED-DETAILS "Try again") ERRORARGS))) (GIVEUP NIL :REPORT "Abort: close the stream and abort the computation" (  \NSRANDOM.DESTROY.STREAM STREAM) (* ; "Blow away the stream.") (ERROR!]) (\NSRANDOM.REESTABLISH [LAMBDA (STREAM) (* ; "Edited 20-Nov-87 17:08 by bvm:") (PROG (HANDLE) RETRY (RETURN (if (NULL (SETQ HANDLE (fetch NSFILING.HANDLE of STREAM))) then (* ;  "Somebody's already blown away this stream") (\NSRANDOM.PROCEEDABLE.ERROR STREAM "Trying to operate on stream after it's closed: ~S" (LIST STREAM)) (GO RETRY) elseif (\NSFILING.GETFILE (fetch DEVICEINFO of (fetch DEVICE of STREAM)) (LET ((ID (fetch NSHFILEID of HANDLE))) (OR (AND ID (LIST 'FILE.ID ID)) (fetch FULLFILENAME of STREAM))) (fetch ACCESS of STREAM) 'OLD NIL NIL NIL NIL STREAM) else (\NSRANDOM.PROCEEDABLE.ERROR STREAM "Lost connection to file ~A, can't reestablish" (LIST (fetch FULLFILENAME of STREAM))) (GO RETRY]) (\NSRANDOM.STREAM.CHANGED [LAMBDA (OLDSTREAM NEWHANDLE) (* ; "Edited 5-Aug-87 16:35 by bvm:") (* ;; "Called when trying to reestablish OLDSTREAM. NEWHANDLE is a new handle on the file, which shows that the file has changed with respect to OLDSTREAM's handle. Returning from this function will continue by using the new handle. ") (\NSRANDOM.PROCEEDABLE.ERROR OLDSTREAM "The file ~A has been modified since you last accessed it. How shall I proceed?" (LIST (FULLNAME OLDSTREAM)) (COND ((DIRTYABLE OLDSTREAM) "Continue output to the file, possibly overwriting its more recent contents") (T "Continue, reading the new contents of the file"))) [COND ((NEQ (fetch ACCESS of OLDSTREAM) 'OUTPUT) (* ; "reset eof to correct value") (LET [(LEN (IMAX (CADR (ASSOC 'SIZE.IN.BYTES (fetch NSHATTRIBUTES of NEWHANDLE] (replace EPAGE of OLDSTREAM with (FOLDLO LEN BYTESPERPAGE)) (replace EOFFSET of OLDSTREAM with (IMOD LEN BYTESPERPAGE] (replace NSFILING.PAGE.CACHE of OLDSTREAM with NIL]) (\NSRANDOM.DESTROY.STREAM [LAMBDA (STREAM) (* ; "Edited 3-Jun-87 18:58 by bvm:") (* ;; "Blow away stream in a way that we won't keep dying. CLOSEF will just keep trying to write pages otherwise.") (UNINTERRUPTABLY (\RELEASECPAGE STREAM)) (FORGETPAGES STREAM) (* ;  "Discard buffers before closing file, so that CLOSEF doesn't try to write anything.") (replace NSFILING.SERVER.LENGTH of STREAM with (\GETEOFPTR STREAM)) (* ;  "Wrong, but it keeps truncatefile from trying to resize the file.") (CLOSEF STREAM]) (\NSRANDOM.SESSION.WATCHER [LAMBDA (DEVICE) (* ; "Edited 10-Jun-87 17:57 by bvm:") (* ;; "Process that makes sure sessions stay open on DEVICE if they are needed. There are two notions of timeout here: (1) the server has an inactivity timeout; if no courier calls in that time, the session is discarded. (2) we have a timeout for open streams; if no stream activity happens within that time, we are willing to let session die. Our timeout is, in general, greater than the servers; it is chosen to obtain a balance between the expense of opening a new session and reestablishing open streams on it and the load we place on the server by keeping a session open that we aren't actively using.") (LET ((DEVINFO (fetch DEVICEINFO of DEVICE))) (replace NSWATCHERPROC of DEVINFO with (THIS.PROCESS)) (* ; "Redundant ordinarily (ensure.watcher does this itself to avoid races), but important to redo it after HARDRESET.") (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (DEVINFO) (* ;  "Remove this pointer when process goes away") (replace NSWATCHERPROC of DEVINFO with NIL] DEVINFO)) (do (LET (WRITING? SESSION TIMEOUT CONTINUANCE BASICTIMER) (* ;  "See if any random access files are open") (COND ([NULL (SETQ SESSION (CAR (fetch NSCONNECTIONS of DEVINFO] (* ;  "No live sessions, so nothing to watch") (RETURN)) ([NOT (for S in (fetch (FDEV OPENFILELST) of DEVICE) when (NEQ (fetch (STREAM DEVICE) of S) DEVICE) do (* ; "Stream is open on random device") (SETQ $$VAL T) (COND ((DIRTYABLE S) (SETQ WRITING? T] (* ;  "No randaccess files are open, so nothing to watch") (RETURN)) ([EQ 0 (SETQ TIMEOUT (COND ((NLISTP *NSFILING-SESSION-TIMEOUT*) *NSFILING-SESSION-TIMEOUT*) (WRITING? (CDR *NSFILING-SESSION-TIMEOUT*)) (T (CAR *NSFILING-SESSION-TIMEOUT*] (* ;  "timeout is zero (i.e., timeout immediately), so don't need to stick around.") (RETURN)) ([NOT (\SECONDSCLOCKGREATERP (SETQ BASICTIMER (fetch FSSESSIONTIMER of SESSION)) (SETQ CONTINUANCE (fetch FSCONTINUANCE of SESSION] (* ;  "Ho hum, we have lots of time before we need to worry about keeping session alive.") ) ((AND TIMEOUT (\SECONDSCLOCKGREATERP (LET ((REALTIMER (fetch FSLASTREALACTIVITYTIMER of SESSION))) (COND ((AND REALTIMER (NOT (fetch FSREALACTIVITY of SESSION))) (* ;  "nothing's happened since the last CONTINUE") REALTIMER) (T BASICTIMER))) TIMEOUT)) (* ;  "Real timeout has passed, so give up") (RETURN)) ((NOT (FILING.CALL SESSION 'CONTINUE SESSION 'NOERROR)) (* ;  "Failed to keep the session alive, go away") (RETURN))) (BLOCK (TIMES 1000 (IMAX (- CONTINUANCE (- (\DAYTIME0 (\CREATECELL \FIXP)) BASICTIMER)) 0))) (* ;  "Dismiss until the time we next worry about session going away.") ]) (\NSRANDOM.ENSURE.WATCHER [LAMBDA (DEVICE) (* ; "Edited 2-Jun-87 15:33 by bvm:") (* ;; "Create a watcher process for this device, if one does not already exist, to make sure that sessions stay open.") (LET ((DEVINFO (fetch DEVICEINFO of DEVICE))) (OR (fetch NSWATCHERPROC of DEVINFO) (replace NSWATCHERPROC of DEVINFO with (ADD.PROCESS (LIST (FUNCTION \NSRANDOM.SESSION.WATCHER) DEVICE) 'RESTARTABLE 'HARDRESET 'NAME (CONCAT (fetch NSFILINGNAME of DEVINFO) " Watcher") 'AFTEREXIT 'DELETE]) ) (* ; "Cleaning up directories") (DEFINEQ (GC-FILING-DIRECTORY [LAMBDA (DIRNAME CONFIRM?) (* ; "Edited 5-Aug-87 15:20 by bvm:") (* ;; "Device method for file enumeration. Return a generator that enumerates files matching PATTERN. DESIREDPROPS is set of attributes caller may ask for. If OPTIONS includes RESETLST, caller promises to be wrapped in a RESETLST that we can use to kill an aborted bulk listing.") (if (OR (NULL DIRNAME) (NEQ (CHCON1 DIRNAME) (CHARCODE "{"))) then (* ; "add defaults") (SETQ DIRNAME (\ADD.CONNECTED.DIR DIRNAME))) (PROG ((DEVICE (\GETDEVICEFROMNAME DIRNAME)) (PARSE (\NSFILING.PARSE.FILENAME DIRNAME T)) (NDELETED 0) CANDIDATES HOST DIRINDEX TOPID) (COND ((NEQ (fetch OPENFILE of DEVICE) (FUNCTION \NSFILING.OPENFILE)) (RETURN "Not an NS File Server")) ((NOT (fetch NSDIRECTORYP of PARSE)) (RETURN "Not a directory name")) ((OR (NLISTP (SETQ CANDIDATES (\NSGC.COLLECT.DIRECTORIES DEVICE (fetch NSDIRECTORIES of PARSE) T))) (EQ (CAR CANDIDATES) 'ERROR)) (* ; "Some sort of failure") (RETURN CANDIDATES))) (SETQ TOPID (pop CANDIDATES)) (COND ((NULL CANDIDATES) (RETURN "No empty directories"))) (* ;; "Now have list of file id's that are directories with no children.") (PRINTOUT T "{" [SETQ HOST (fetch FSNAMESTRING of (CAR (fetch NSCONNECTIONS of (fetch DEVICEINFO of DEVICE] "}" T) (SETQ DIRINDEX (+ 3 (NCHARS HOST))) (* ;  "Index of where directory name will start in full names.") (for ID in CANDIDATES do (while (AND (SETQ ID (\NSFILING.GETFILE DEVICE `(FILE.ID ,ID) 'NONE NIL 'HANDLE [FUNCTION (LAMBDA (SESSION HANDLE) (COND ((EQ (fetch NSHBUSYCOUNT of HANDLE) 0) (* ; "Directory not in use, ok to delete. Ordinarily nobody holds on to directories, so this may be superfluous today") (for PAIR in (FILING.CALL SESSION 'GET.ATTRIBUTES (fetch NSHDATUM of HANDLE) (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(NUMBER.OF.CHILDREN PARENT.ID)) SESSION) bind PARENT ERROR do (SELECTQ (CAR PAIR) (NUMBER.OF.CHILDREN (COND ((NEQ (CADR PAIR) 0) (* ; "Has children now, skip it. Note that this could be true for any directory collected above, because we didn't obtain handles then.") (RETURN NIL)))) (PARENT.ID (SETQ PARENT (CADR PAIR))) (SHOULDNT)) finally (* ; "Ready to try deleting it.") (PRINTOUT T (SUBSTRING (\NSFILING.FULLNAME SESSION HANDLE) DIRINDEX) %,) (COND ((AND CONFIRM? (NEQ 'Y (ASKUSER NIL NIL "delete? " '((Y "es ") (N "o ")) T))) (* ; "disconfirmed") ) ((SETQ ERROR (FILING.CALL SESSION 'DELETE (fetch NSHDATUM of HANDLE) SESSION 'RETURNERRORS)) (COND ((EQ (CADDR ERROR) 'TokenInvalid) (* ;  "sigh, could get this if the ASKUSER took a long time. Go around again") (PRINTOUT T "connection lost" T) (RETURN ID))) (PRINTOUT T (CADDR ERROR))) (T (* ; "success") (PRINTOUT T "deleted." T) (add NDELETED 1) (replace FSCACHEDHANDLES of SESSION with (DREMOVE HANDLE (fetch FSCACHEDHANDLES of SESSION))) (* ;  "return parent id for another go around in case deleting this directory emptied the parent.") (RETURN PARENT))) (TERPRI T) (RETURN NIL] T)) (NOT (EQUAL ID TOPID))) do (* ;  "Keep trying to delete dirs until we get back to the root.") )) (RETURN (CONCAT NDELETED " directories deleted"]) (\NSGC.COLLECT.DIRECTORIES [LAMBDA (DEVICE DIRPATH NOCHILDREN) (* ; "Edited 5-Aug-87 15:20 by bvm:") (* ;; "Return a list of directory id's below DIRPATH, with the root directory's id consed on the front. If NOCHILDREN is true, only directories with zero children are included.") (RESETLST (* ;  "Need RESETLST for \getfilingconnection") [PROG ([SCOPELIST `((DEPTH 65535) (FILTER (AND ((= ((IS.DIRECTORY T) BOOLEAN)) ,@(AND NOCHILDREN '((= ((NUMBER.OF.CHILDREN 0) CARDINAL] (SESSION (\GETFILINGCONNECTION DEVICE)) BULKSTREAM HANDLE GENERATOR) (COND ((NULL SESSION) (RETURN NIL)) ((NULL (SETQ HANDLE (\NSFILING.CONNECT SESSION DIRPATH T))) (RETURN "No such directory"))) RETRY (SETQ BULKSTREAM (FILING.CALL SESSION 'LIST (fetch NSHDATUM of HANDLE) [if NOCHILDREN then [CONSTANT (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(FILE.ID IS.DIRECTORY NUMBER.OF.CHILDREN] else (CONSTANT (\FILING.ATTRIBUTE.TYPE.SEQUENCE '(FILE.ID IS.DIRECTORY] SCOPELIST NIL SESSION 'RETURNERRORS 'KEEPSTREAM)) (COND ([AND (LISTP BULKSTREAM) (CDR SCOPELIST) (EQUAL BULKSTREAM '(ERROR SCOPE.VALUE.ERROR Unimplemented FILTER] (* ; "Would be nice to have a filter on IS.DIRECTORY and NUMBER.OF.CHILDREN, but servers don't implement that.") [SETQ SCOPELIST '((DEPTH 65535] (GO RETRY))) (COND ((NOT (STREAMP BULKSTREAM)) (RETURN BULKSTREAM))) (RESETSAVE NIL (LIST (FUNCTION \NSFILING.CLOSE.BULKSTREAM) SESSION BULKSTREAM)) (SETQ GENERATOR (BULKDATA.GENERATOR BULKSTREAM (fetch FSPROTOCOLNAME of SESSION ) 'ATTRIBUTE.SEQUENCE)) (RETURN (CONS (fetch NSHFILEID of HANDLE) (bind ID INFO eachtime (SETQ ID NIL) while (SETQ INFO ( BULKDATA.GENERATE.NEXT GENERATOR)) when (for PAIR in INFO always (SELECTQ (CAR PAIR) (FILE.ID (SETQ ID (CADR PAIR))) (IS.DIRECTORY (CADR PAIR)) (NUMBER.OF.CHILDREN (EQ 0 (CADR PAIR))) NIL)) collect ID])]) ) (* ; "Deserialize (special for NSMAIL)") (DEFINEQ (\NSFILING.DESERIALIZE [LAMBDA (FILENAME SERIALSTREAM DEVICE) (* ; "Edited 8-Dec-87 13:05 by bvm:") (RESETLST [LET ((PARSE (\NSFILING.PARSE.FILENAME FILENAME)) DIRHANDLE HANDLE SESSION VERSION NAME) (COND ((NULL PARSE) (* ; "Bad name") (CL:ERROR 'XCL:INVALID-PATHNAME :PATHNAME FILENAME)) ((NULL (SETQ SESSION (\GETFILINGCONNECTION DEVICE))) (CL:ERROR 'XCL:FILE-NOT-FOUND :PATHNAME FILENAME)) ((NULL (SETQ DIRHANDLE (\NSFILING.CONNECT SESSION (fetch NSDIRECTORIES of PARSE) T T))) (* ;  "Couldn't get handle on destination") (CL:ERROR 'XCL:FILE-WONT-OPEN :PATHNAME FILENAME)) [(AND (LISTP (SETQ HANDLE (\NSFILING.DESERIALIZE1 SESSION DIRHANDLE `[,@[AND (SETQ NAME (fetch NSROOTNAME of PARSE)) `((NAME ,(\NSFILING.REMOVEQUOTES NAME] ,@(AND (SETQ VERSION (fetch NSVERSION of PARSE)) `((VERSION ,(MKATOM VERSION] SERIALSTREAM))) (NEQ (CAR HANDLE) 'ERROR)) (* ; "Success") (\NSFILING.FULLNAME SESSION (\NSFILING.ADD.TO.CACHE SESSION (create FILINGHANDLE NSHDATUM _ HANDLE] (T (* ; "Failure") (COURIER.SIGNAL.ERROR (fetch FSPROTOCOLNAME of SESSION) 'DESERIALIZE HANDLE])]) (\NSFILING.DESERIALIZE1 [LAMBDA (SERIALSESSION DIRHANDLE NEWATTRS SERIALSTREAM CLOSEFN) (* ; "Edited 9-Dec-87 18:27 by bvm:") (* ;; "Perform the DESERIALIZE call on SESSION, handle of parent directory, attributes to change, and the source of the serialized file. The awful contorted structure is so we don't tie up the session while the transfer is in progress.") (LET [(BULKSTREAM (FILING.CALL SERIALSESSION 'DESERIALIZE (fetch NSHDATUM of DIRHANDLE ) NEWATTRS NIL NIL SERIALSESSION 'RETURNERRORS 'KEEPSTREAM] (CL:UNWIND-PROTECT (LET (EXPLICIT-RESULT BULKRESULT) (RELEASE.MONITORLOCK (fetch FSSESSIONLOCK of SERIALSESSION)) (* ;  "Don't let this serial transfer tie up the session forever.") (SETQ EXPLICIT-RESULT (if (TYPENAMEP SERIALSTREAM 'STREAM) then (* ;  "a stream containing the serialized data") (COPYBYTES SERIALSTREAM BULKSTREAM) (* ;  "Normally want to return NIL from here so we see the real courier results.") (AND CLOSEFN (CL:FUNCALL CLOSEFN BULKSTREAM)) else (* ; "A function to store the file.") (CL:FUNCALL SERIALSTREAM BULKSTREAM))) [SETQ BULKRESULT (\BULK.DATA.CLOSE BULKSTREAM (AND (LISTP EXPLICIT-RESULT) (EQ (CAR EXPLICIT-RESULT) 'ERROR] (OBTAIN.MONITORLOCK (fetch FSSESSIONLOCK of SERIALSESSION)) (OR EXPLICIT-RESULT BULKRESULT)) (* ;; "Cleanups: Abort bulk data if there's a problem, release bulk stream") (\BULK.DATA.CLOSE BULKSTREAM T) (\NSFILING.RELEASE.BULKSTREAM SERIALSESSION BULKSTREAM))]) ) (DEFINEQ (\NSFILING.INIT [LAMBDA NIL (* ; "Edited 15-May-87 17:15 by bvm:") (\DEFINEDEVICE NIL (create FDEV DEVICENAME _ 'NSFILING HOSTNAMEP _ (FUNCTION \NSFILING.HOSTNAMEP) EVENTFN _ (FUNCTION NILL))) (DEFPRINT 'FILINGSESSION (FUNCTION \FILINGSESSION.DEFPRINT)) (DEFPRINT 'FILINGHANDLE (FUNCTION \FILINGHANDLE.DEFPRINT]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\NSFILING.INIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA FILING.CALL) ) (PUTPROPS NSFILING COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1993 1999 )) (DECLARE%: DONTCOPY (FILEMAP (NIL (34234 35080 (\FILINGSESSION.DEFPRINT 34244 . 34758) (\FILINGHANDLE.DEFPRINT 34760 . 35078)) (35081 38808 (\GET.FILING.ATTRIBUTE 35091 . 36404) (\PUT.FILING.ATTRIBUTE 36406 . 37604) ( \GET.SESSION.HANDLE 37606 . 38025) (\PUT.SESSION.HANDLE 38027 . 38806)) (41840 77789 ( \GETFILINGCONNECTION 41850 . 43745) (\NSFILING.GET.NEW.SESSION 43747 . 44232) (\NSFILING.GET.STREAM 44234 . 46010) (\NSFILING.COURIER.OPEN 46012 . 46277) (\NSFILING.CLOSE.BULKSTREAM 46279 . 46557) ( \NSFILING.RELEASE.BULKSTREAM 46559 . 47488) (FILING.CALL 47490 . 56089) (\NSFILING.LOGIN 56091 . 69270 ) (\NSFILING.AFTER.LOGIN 69272 . 69803) (\NSFILING.SET.CONTINUANCE 69805 . 70478) (\NSFILING.LOGOUT 70480 . 70661) (\NSFILING.DISCARD.SESSION 70663 . 72360) (\VALID.FILING.CONNECTIONP 72362 . 73958) ( \NSFILING.CLOSE.CONNECTIONS 73960 . 76822) (BREAK.NSFILING.CONNECTION 76824 . 77787)) (77867 91247 ( \NSFILING.CONNECT 77877 . 80294) (\NSFILING.MAYBE.CREATE 80296 . 83335) (\NSFILING.REMOVEQUOTES 83337 . 83962) (\NSFILING.ADDQUOTES 83964 . 86702) (\FILING.ATTRIBUTE.TYPE.SEQUENCE 86704 . 86918) ( \FILING.ATTRIBUTE.TYPE 86920 . 87423) (\LISP.TO.NSFILING.ATTRIBUTE 87425 . 91245)) (91283 144407 ( \NSFILING.GETFILE 91293 . 112576) (\NSFILING.LOOKUP.CACHE 112578 . 114640) (\NSFILING.ADD.TO.CACHE 114642 . 117005) (\NSFILING.OPEN.HANDLE 117007 . 119110) (\NSFILING.CONFLICTP 119112 . 120606) ( \NSFILING.CHECK.ACCESS 120608 . 121971) (\NSFILING.FILLIN.ATTRIBUTES 121973 . 123720) ( \NSFILING.COMPOSE.PATHNAME 123722 . 124223) (\NSFILING.PARSE.FILENAME 124225 . 129762) ( \NSFILING.ERRORHANDLER 129764 . 134582) (\NSFILING.WHENCLOSED 134584 . 135856) (\NSFILING.CLOSE.HANDLE 135858 . 136151) (\NSFILING.FULLNAME 136153 . 144405)) (144440 212555 (\NSFILING.OPENFILE 144450 . 149642) (\NSFILING.HANDLE.ERROR 149644 . 150522) (\NSFILING.CLOSEFILE 150524 . 153147) ( \NSFILING.EVENTFN 153149 . 155907) (\NSFILING.DELETEFILE 155909 . 157577) (\NSFILING.CHILDLESS-P 157579 . 158282) (\NSFILING.DIRECTORYNAMEP 158284 . 158691) (\NSFILING.HOSTNAMEP 158693 . 161788) ( \NSFILING.GETFILENAME 161790 . 162050) (\NSFILING.GETFILEINFO 162052 . 165460) ( \NSFILING.GET.ATTRIBUTES 165462 . 165858) (\NSFILING.GETFILEINFO.FROM.PLIST 165860 . 168820) ( \NSFILING.GDATE 168822 . 169012) (\NSFILING.SETFILEINFO 169014 . 172196) (\NSFILING.GET/SETINFO 172198 . 173662) (\NSFILING.UPDATE.ATTRIBUTES 173664 . 174635) (\NSFILING.GETEOFPTR 174637 . 175171) ( \NSFILING.GENERATEFILES 175173 . 191035) (\NSFILING.GENERATE.STARS 191037 . 191627) ( \NSFILING.NEXTFILE 191629 . 193207) (\NSFILING.FILEINFOFN 193209 . 193436) (\NSFILING.RENAMEFILE 193438 . 194038) (\NSFILING.COPYFILE 194040 . 194638) (\NSFILING.COPY/RENAME 194640 . 212553)) (212594 263202 (\NSRANDOM.CLOSEFILE 212604 . 214400) (\NSRANDOM.RELEASE.HANDLE 214402 . 215595) ( \NSRANDOM.RELEASE.LOCK 215597 . 215936) (\NSRANDOM.RELEASE.IF.ERROR 215938 . 216138) ( \NSRANDOM.CREATE.STREAM 216140 . 222206) (\NSRANDOM.READPAGES 222208 . 226998) (\NSRANDOM.READ.SEGMENT 227000 . 237526) (\NSRANDOM.PREPARE.CACHE 237528 . 244860) (\NSRANDOM.FETCH.CACHE 244862 . 247035) ( \NSRANDOM.CHECK.CACHE 247037 . 248082) (\NSRANDOM.WRITEPAGES 248084 . 253627) (\NSRANDOM.WRITE.SEGMENT 253629 . 255223) (\NSRANDOM.WROTE.HANDLE 255225 . 257031) (\NSRANDOM.SETEOFPTR 257033 . 258562) ( \NSRANDOM.TRUNCATEFILE 258564 . 261478) (\NSRANDOM.UPDATE.VALIDATION 261480 . 262383) ( \NSRANDOM.OPENFILE 262385 . 263200)) (263234 277742 (\NSRANDOM.HANDLE.ERROR 263244 . 265690) ( \NSRANDOM.PROCEEDABLE.ERROR 265692 . 266948) (\NSRANDOM.REESTABLISH 266950 . 268422) ( \NSRANDOM.STREAM.CHANGED 268424 . 269694) (\NSRANDOM.DESTROY.STREAM 269696 . 270466) ( \NSRANDOM.SESSION.WATCHER 270468 . 276377) (\NSRANDOM.ENSURE.WATCHER 276379 . 277740)) (277783 288993 (GC-FILING-DIRECTORY 277793 . 285216) (\NSGC.COLLECT.DIRECTORIES 285218 . 288991)) (289043 293734 ( \NSFILING.DESERIALIZE 289053 . 291155) (\NSFILING.DESERIALIZE1 291157 . 293732)) (293735 294222 ( \NSFILING.INIT 293745 . 294220))))) STOP \ No newline at end of file diff --git a/sources/NSPRINT b/sources/NSPRINT new file mode 100644 index 00000000..ebf56763 --- /dev/null +++ b/sources/NSPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "28-Apr-92 17:29:44" |{PELE:MV:ENVOS}SOURCES>NSPRINT.;3| 30963 changes to%: (FNS \NSPRINT.INTERNAL) previous date%: "16-May-90 20:54:31" |{PELE:MV:ENVOS}SOURCES>NSPRINT.;2|) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT NSPRINTCOMS) (RPAQQ NSPRINTCOMS [(COMS (COURIERPROGRAMS PRINTING) (DECLARE%: DONTCOPY (RECORDS NSPRINTER) (GLOBALVARS NS.DEFAULT.PRINTER NSPRINT.DEFAULT.MEDIUM NSPRINT.WATCHERFLG)) (INITVARS (NS.DEFAULT.PRINTER NIL) (NSPRINT.DEFAULT.MEDIUM) (NSPRINT.WATCHERFLG T)) (FNS GETNSPRINTER NSPRINT \NSPRINT.INTERNAL \NSPRINT.MEDIUM.CHECK \NSPRINT.UNSUPPORTED NSPRINTER.HOSTNAMEP NSPRINTER.STATUS NSPRINTER.PROPERTIES NSPRINTREQUEST.STATUS \NSPRINT.ENQUIRE \NSPRINT.COURIER.OPEN)) (COMS (* ; "Printer watcher") (FNS \NSPRINT.WATCHDOG \NSPRINT.WATCH.JOB \NSPRINT.FULL.REQUEST.STATUS) (GLOBALVARS *PRINT-JOBS-IN-PROGRESS*) (INITVARS (*PRINT-JOBS-IN-PROGRESS*))) (COMS (* ; "FAX") (FNS FAX.SEND.FILE FAX.STATUS FAX.PROPERTIES FAX.HOSTNAMEP \FAX.PARSE.NAME) (INITVARS (DEFAULTFAXHOST) (FAXADDRESSES) (FAX.NO.WATCHER T)) (GLOBALVARS DEFAULTFAXHOST FAXADDRESSES FAX.NO.WATCHER) (ADDVARS (PRINTERTYPES ((FAX TELECOPIER) (CANPRINT (INTERPRESS)) (HOSTNAMEP FAX.HOSTNAMEP) (STATUS FAX.STATUS) (PROPERTIES FAX.PROPERTIES) (SEND FAX.SEND.FILE) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE]) (COURIERPROGRAM PRINTING (4 3) TYPES [(REQUEST.ID (ARRAY 5 UNSPECIFIED)) [PRINT.ATTRIBUTES (SEQUENCE (CHOICE (PRINT.OBJECT.NAME 0 STRING) (PRINT.OBJECT.CREATE.DATE 1 TIME) (SENDER.NAME 2 STRING] [PRINT.OPTIONS (SEQUENCE (CHOICE (PRINT.OBJECT.SIZE 0 LONGCARDINAL) (RECIPIENT.NAME 1 STRING) (MESSAGE 2 STRING) (COPY.COUNT 3 CARDINAL) (PAGES.TO.PRINT 4 (RECORD (BEGINNING.PAGE.NUMBER CARDINAL) (ENDING.PAGE.NUMBER CARDINAL))) (MEDIUM.HINT 5 MEDIUM) (PRIORITY.HINT 6 (ENUMERATION (HOLD 0) (LOW 1) (NORMAL 2) (HIGH 3))) (RELEASE.KEY 7 HASHED.PASSWORD) (STAPLE 8 BOOLEAN) (TWO.SIDED 9 BOOLEAN] [PRINTER.PROPERTIES (SEQUENCE (CHOICE (MEDIA 0 MEDIA) (STAPLE 1 BOOLEAN) (TWO.SIDED 2 BOOLEAN] [PRINTER.STATUS (SEQUENCE (CHOICE (SPOOLER 0 (ENUMERATION (Available 0) (Busy 1) (Disabled 2) (Full 3))) (FORMATTER 1 (ENUMERATION (Available 0) (Busy 1) (Disabled 2))) (PRINTER 2 (ENUMERATION (Available 0) (Busy 1) (Disabled 2) (NeedsAttention 3) (NeedKeyOperator 4))) (MEDIA 3 MEDIA] [REQUEST.STATUS (SEQUENCE (CHOICE (STATUS 0 (ENUMERATION (Pending 0) (InProgress 1) (Completed 2) (Unknown 3) (Rejected 4) (Aborted 5) (Cancelled 6) (Held 7))) (STATUS.MESSAGE 1 STRING] (MEDIA (SEQUENCE MEDIUM)) (MEDIUM (CHOICE (PAPER 0 PAPER))) [PAPER (CHOICE (UNKNOWN 0 NIL) (KNOWN.SIZE 1 (ENUMERATION ("US.LETTER" 1) ("US.LEGAL" 2) ("A0" 3) ("A1" 4) ("A2" 5) ("A3" 6) ("A4" 7) ("A5" 8) ("A6" 9) ("A7" 10) ("A8" 11) ("A9" 12) ("A10" 35) ("ISO.B0" 13) ("ISO.B1" 14) ("ISO.B2" 15) ("ISO.B3" 16) ("ISO.B4" 17) ("ISO.B5" 18) ("ISO.B6" 19) ("ISO.B7" 20) ("ISO.B8" 21) ("ISO.B9" 22) ("ISO.B10" 23) ("JIS.B0" 24) ("JIS.B1" 25) ("JIS.B2" 26) ("JIS.B3" 27) ("JIS.B4" 28) ("JIS.B5" 29) ("JIS.B6" 30) ("JIS.B7" 31) ("JIS.B8" 32) ("JIS.B9" 33) ("JIS.B10" 34))) (OTHER.SIZE 2 (RECORD (WIDTH CARDINAL) (LENGTH CARDINAL] (CONNECTION.PROBLEM (ENUMERATION (NoRoute 0) (NoResponse 1) (TransmissionHardware 2) (TransportTimeout 3) (TooManyLocalConnections 4) (TooManyRemoteConnections 5) (MissingCourier 6) (MissingProgram 7) (MissingProcedure 8) (ProtocolMismatch 9) (ParameterInconsistency 10) (InvalidMessage 11) (ReturnTimedOut 12) (Other 65535))) (TRANSFER.PROBLEM (ENUMERATION (Aborted 0) (ChecksumIncorrect 1) (FormatIncorrect 2) (NoRendezvous 3) (WrongDirection 4] PROCEDURES ((PRINT 0 (BULK.DATA.SOURCE PRINT.ATTRIBUTES PRINT.OPTIONS) RETURNS (REQUEST.ID) REPORTS (BUSY CONNECTION.ERROR INSUFFICIENT.SPOOL.SPACE INVALID.PRINT.PARAMETERS MASTER.TOO.LARGE MEDIUM.UNAVAILABLE SERVICE.UNAVAILABLE SPOOLING.DISABLED SPOOLING.QUEUE.FULL SYSTEM.ERROR TOO.MANY.CLIENTS TRANSFER.ERROR UNDEFINED.ERROR) ) (GET.PRINTER.PROPERTIES 1 NIL RETURNS (PRINTER.PROPERTIES) REPORTS (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR)) (GET.PRINT.REQUEST.STATUS 2 (REQUEST.ID) RETURNS (REQUEST.STATUS) REPORTS (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR)) (GET.PRINTER.STATUS 3 NIL RETURNS (PRINTER.STATUS) REPORTS (SERVICE.UNAVAILABLE SYSTEM.ERROR UNDEFINED.ERROR))) ERRORS ((BUSY 0) (INSUFFICIENT.SPOOL.SPACE 1) (INVALID.PRINT.PARAMETERS 2) (MASTER.TOO.LARGE 3) (MEDIUM.UNAVAILABLE 4) (SERVICE.UNAVAILABLE 5) (SPOOLING.DISABLED 6) (SPOOLING.QUEUE.FULL 7) (SYSTEM.ERROR 8) (TOO.MANY.CLIENTS 9) (UNDEFINED.ERROR 10 (CARDINAL)) (CONNECTION.ERROR 11 (CONNECTION.PROBLEM)) (TRANSFER.ERROR 12 (TRANSFER.PROBLEM)))) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (RECORD NSPRINTER (NSPRINTERNAME NSPRINTERADDRESS)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS NS.DEFAULT.PRINTER NSPRINT.DEFAULT.MEDIUM NSPRINT.WATCHERFLG) ) ) (RPAQ? NS.DEFAULT.PRINTER NIL) (RPAQ? NSPRINT.DEFAULT.MEDIUM ) (RPAQ? NSPRINT.WATCHERFLG T) (DEFINEQ (GETNSPRINTER (LAMBDA (HOST) (* bvm%: "19-Sep-86 15:52") (COND ((AND (LISTP HOST) (TYPENAMEP (fetch NSPRINTERNAME of HOST) (QUOTE NSNAME)) (TYPENAMEP (fetch NSPRINTERADDRESS of HOST) (QUOTE NSADDRESS))) (* ; "Already in standard form") HOST) (T (LET ((NAME (COND (HOST) (NS.DEFAULT.PRINTER) ((SETQ NS.DEFAULT.PRINTER (CAR (CH.LIST.OBJECTS "*" (QUOTE PRINT.SERVICE)))) (printout PROMPTWINDOW .TAB0 0 "[Default NS printer set to " NS.DEFAULT.PRINTER "]") NS.DEFAULT.PRINTER))) INFO) (COND ((NULL NAME) (ERROR "Can't find an NS printserver" NIL T)) ((NULL (SETQ INFO (LOOKUP.NS.SERVER (SETQ NAME (PARSE.NSNAME NAME)) NIL T))) (ERROR "Can't find address of " NAME)) (T (create NSPRINTER NSPRINTERNAME _ (CAR INFO) NSPRINTERADDRESS _ (CADR INFO)))))))) ) (NSPRINT (LAMBDA (PRINTER FILE OPTIONS) (* ; "Edited 11-Dec-87 16:15 by bvm:") (* ;; "Transmit the interpress file FILE to server PRINTER. OPTIONS controls some of the printing, e.g., what title should appear on the header page, etc.") (LET (INSTREAM) (CL:UNWIND-PROTECT (LET (DOCUMENT.NAME PRINTRESULTS JOBNAME) (SETQ PRINTER (GETNSPRINTER PRINTER)) (SETQ INSTREAM (OPENSTREAM FILE (QUOTE INPUT) NIL NIL (QUOTE ((SEQUENTIAL T))))) (COND ((SETQ DOCUMENT.NAME (LISTGET OPTIONS (QUOTE DOCUMENT.NAME))) (SETQ JOBNAME DOCUMENT.NAME)) (T (push OPTIONS (QUOTE DOCUMENT.NAME) (SETQ DOCUMENT.NAME (FULLNAME INSTREAM))))) (OR (LISTGET OPTIONS (QUOTE DOCUMENT.CREATION.DATE)) (push OPTIONS (QUOTE DOCUMENT.CREATION.DATE) (GETFILEINFO INSTREAM (QUOTE ICREATIONDATE)))) (SETQ PRINTRESULTS (\NSPRINT.INTERNAL PRINTER OPTIONS (FUNCTION (LAMBDA (DATASTREAM) (DECLARE (USEDFREE INSTREAM)) (if (NEQ (GETFILEPTR INSTREAM) 0) then (* ; "This is the second attempt? Have to set back to zero") (if (RANDACCESSP INSTREAM) then (SETFILEPTR INSTREAM 0) else (* ; "Have to reopen") (SETQ INSTREAM (OPENSTREAM (PROG1 (FULLNAME INSTREAM) (CLOSEF INSTREAM)) (QUOTE INPUT) NIL NIL (QUOTE ((SEQUENTIAL T))))))) (COPYBYTES INSTREAM DATASTREAM) NIL)))) (if PRINTRESULTS then (COND ((AND NSPRINT.WATCHERFLG (NOT (LISTGET OPTIONS (QUOTE NO.WATCHER)))) (\NSPRINT.WATCH.JOB PRINTRESULTS PRINTER (OR JOBNAME (UNPACKFILENAME.STRING DOCUMENT.NAME (QUOTE NAME)) DOCUMENT.NAME)))) DOCUMENT.NAME)) (* ;; "Be sure to close stream on the way out") (AND INSTREAM (CLOSEF? INSTREAM))))) ) (\NSPRINT.INTERNAL [LAMBDA (PRINTER OPTIONS TRANSFERFN) (* ; "Edited 9-Aug-89 14:54 by bvm") (* ;;; "Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options. TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master") (LET (COURIERSTREAM) (CL:UNWIND-PROTECT (PROG* ((MEDIUM (OR (LISTGET OPTIONS 'MEDIUM) NSPRINT.DEFAULT.MEDIUM)) (STAPLE? (LISTGET OPTIONS 'STAPLE?)) (TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS '%#SIDES) EMPRESS#SIDES))) (SENDER.NAME (OR (LISTGET OPTIONS 'SENDER.NAME) (USERNAME NIL NIL T))) (DOCNAME (OR (LISTGET OPTIONS 'DOCUMENT.NAME) "Document")) [ATTRIBUTES `((PRINT.OBJECT.NAME ,DOCNAME) [PRINT.OBJECT.CREATE.DATE ,(OR (LISTGET OPTIONS 'DOCUMENT.CREATION.DATE) (IDATE] (SENDER.NAME ,SENDER.NAME] [PRINTOPTIONS `((COPY.COUNT ,(FIX (OR (LISTGET OPTIONS '%#COPIES) 1] PROPERTIES VALUE STATUS LASTSTATUS) (* ;  "#copies 'option' seems to be required") [COND ((SETQ VALUE (LISTGET OPTIONS 'RECIPIENT.NAME)) (push PRINTOPTIONS (LIST 'RECIPIENT.NAME (OR (STRINGP VALUE) (MKSTRING VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS 'PRIORITY)) (push PRINTOPTIONS (LIST 'PRIORITY.HINT (SELECTQ VALUE ((HOLD LOW NORMAL HIGH) VALUE) (\ILLEGAL.ARG VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS 'MESSAGE)) (push PRINTOPTIONS (LIST 'MESSAGE (OR (STRINGP VALUE) (MKSTRING VALUE] [COND ((SETQ VALUE (LISTGET OPTIONS 'PAGES.TO.PRINT)) (* ;  "A page range to print, (first# last#)") (COND ((AND (LISTP VALUE) (LISTP (CDR VALUE)) (NULL (CDDR VALUE)) (SMALLPOSP (CAR VALUE)) (SMALLPOSP (CADR VALUE))) (push PRINTOPTIONS (LIST 'PAGES.TO.PRINT VALUE))) (T (\ILLEGAL.ARG VALUE] RETRY (COND ((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER))) (printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME of PRINTER)) (DISMISS 5000) (GO RETRY))) (* ; "Check the status of the printer. No point sending to busy spooler, only to get a %"too many clients%" reject.") (bind SS PS do (SETQ STATUS (COURIER.CALL COURIERSTREAM 'PRINTING 'GET.PRINTER.STATUS 'RETURNERRORS)) [COND ((EQ (CAR STATUS) 'ERROR) (COND ((NOT (EQUAL STATUS LASTSTATUS)) (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER) " Error: " (SUBSTRING (CDR STATUS) 2 -2) "; will retry]") (SETQ LASTSTATUS STATUS))) (* ; "Wait longer for this problem") (DISMISS 30000)) ((NEQ (SETQ SS (CADR (ASSOC 'SPOOLER STATUS))) LASTSTATUS) (SELECTQ SS (Available (* ; "All is hunky dory") (RETURN)) (Busy (CL:FORMAT PROMPTWINDOW "~%%[Spooler on ~A is busy~@[ (printer ~A)~]; will retry]" (fetch NSPRINTERNAME of PRINTER) (SELECTQ (SETQ PS (CADR (ASSOC 'PRINTER STATUS))) ((Available Busy) (* ; "Printer status is uninteresting") NIL) (STRING PS))) (SETQ LASTSTATUS SS)) (PROGN (* ;  "Full or Disabled--these are not transient errors, so may want to interact with user") (SETQ STATUS (CONS NIL (ASSOC 'SPOOLER STATUS))) (GO HANDLE.ERROR] (DISMISS 5000)) [COND ((OR MEDIUM STAPLE? TWO.SIDED?) (* ;  "Check that the printer supports these options.") (SETQ PROPERTIES (COURIER.CALL COURIERSTREAM 'PRINTING 'GET.PRINTER.PROPERTIES 'RETURNERRORS)) (COND ((EQ (CAR PROPERTIES) 'ERROR) (SETQ STATUS PROPERTIES) (GO HANDLE.ERROR))) (COND (MEDIUM [COND ((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM (CADR (ASSOC 'MEDIA PROPERTIES)) PRINTER)) (push PRINTOPTIONS (LIST 'MEDIUM.HINT VALUE] (SETQ MEDIUM))) (COND (STAPLE? (COND ((CADR (ASSOC 'STAPLE PROPERTIES)) (push PRINTOPTIONS (LIST 'STAPLE T))) (T (\NSPRINT.UNSUPPORTED PRINTER "stapled copies"))) (SETQ STAPLE?))) (COND (TWO.SIDED? (COND ((CADR (ASSOC 'TWO.SIDED PROPERTIES)) (push PRINTOPTIONS (LIST 'TWO.SIDED T))) ((LISTGET OPTIONS '%#SIDES) (* ;  "Only warn if user explicitly asked for 2-sided") (\NSPRINT.UNSUPPORTED PRINTER "two-sided copies"))) (SETQ TWO.SIDED?] (* ;; "Finally, send the print document") (SETQ STATUS (COURIER.CALL COURIERSTREAM 'PRINTING 'PRINT TRANSFERFN ATTRIBUTES PRINTOPTIONS 'RETURNERRORS)) (COND ((NEQ (CAR STATUS) 'ERROR) (CLOSEF COURIERSTREAM) (SETQ COURIERSTREAM NIL) (RETURN STATUS))) HANDLE.ERROR (* ;; "Come here with STATUS = a courier error form.") (CLOSEF COURIERSTREAM) (SELECTQ (CADR STATUS) ((TOO.MANY.CLIENTS TRANSFER.ERROR CONNECTION.ERROR) (* ;  "Transient errors, quietly try again") (if (NEQ LASTSTATUS (SETQ LASTSTATUS 'Busy)) then (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER) " -- " (CL:STRING-CAPITALIZE (CADR STATUS)) "; will retry]")) (DISMISS 10000)) (CL:CERROR "Try to send the document again" "Unexpected error from ~A while attempting to print ~A -- ~A" (fetch NSPRINTERNAME of PRINTER) DOCNAME (CDR STATUS))) (GO RETRY)) (if COURIERSTREAM then (* ; "Abort the stream") (SPP.CLOSE COURIERSTREAM T)))]) (\NSPRINT.MEDIUM.CHECK (LAMBDA (MEDIUM MEDIA PRINTER) (* ; "Edited 11-Dec-87 14:31 by bvm:") (if (EQ MEDIUM T) then (CAR MEDIA) else (for X in MEDIA when (OR (EQUAL X MEDIUM) (AND (EQ (CAR X) (QUOTE PAPER)) (STRPOS MEDIUM (CADR (CADR X)) NIL NIL NIL NIL (UPPERCASEARRAY)))) do (RETURN X) finally (\NSPRINT.UNSUPPORTED PRINTER "print medium" MEDIUM) (RETURN (CAR MEDIA))))) ) (\NSPRINT.UNSUPPORTED (LAMBDA (PRINTER FEATURE VALUE) (* ; "Edited 11-Dec-87 14:27 by bvm:") (* ;; "Mention that this printer does not support some feature, with optional value.") (CL:FORMAT PROMPTWINDOW "~%%[Printer ~A does not support ~A~@[: ~A~]]" (fetch NSPRINTERNAME of PRINTER) FEATURE VALUE)) ) (NSPRINTER.HOSTNAMEP (LAMBDA (PRINTERNAME) (* bvm%: "16-Sep-85 22:49") (* ;; "True if PRINTERNAME names an NS printer. Do stupid test for now. Later on might want to test that random NS name really is a printer") (AND (STRPOS ":" PRINTERNAME) (QUOTE INTERPRESS))) ) (NSPRINTER.STATUS (LAMBDA (PRINTER) (* bvm%: "29-Jun-84 17:02") (\NSPRINT.ENQUIRE PRINTER (QUOTE GET.PRINTER.STATUS)))) (NSPRINTER.PROPERTIES (LAMBDA (PRINTER) (* bvm%: "29-Jun-84 17:02") (\NSPRINT.ENQUIRE PRINTER (QUOTE GET.PRINTER.PROPERTIES))) ) (NSPRINTREQUEST.STATUS (LAMBDA (REQUESTID PRINTER) (* bvm%: "29-Jun-84 16:38") (\NSPRINT.ENQUIRE PRINTER (LIST (QUOTE GET.PRINT.REQUEST.STATUS) REQUESTID))) ) (\NSPRINT.ENQUIRE (LAMBDA (PRINTER OP) (* bvm%: "20-Jul-84 17:56") (* ;;; "Perform a printing Courier op to PRINTER. OP is (FN . ARGS) to perform a COURIER.CALL on") (SETQ PRINTER (GETNSPRINTER PRINTER)) (PROG ((STREAM (\NSPRINT.COURIER.OPEN PRINTER))) (RETURN (COND (STREAM (RESETLST (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) STREAM)) (APPLY (FUNCTION COURIER.CALL) (CONS STREAM (CONS (QUOTE PRINTING) (APPEND (OR (LISTP OP) (LIST OP)) (LIST (QUOTE NOERROR)))))))))))) ) (\NSPRINT.COURIER.OPEN (LAMBDA (PRINTER) (* bvm%: "20-Jul-84 10:31") (COURIER.OPEN (fetch NSPRINTERADDRESS of PRINTER) NIL T (PACK* (fetch NSOBJECT of (fetch NSPRINTERNAME of PRINTER)) "#Printing"))) ) ) (* ; "Printer watcher") (DEFINEQ (\NSPRINT.WATCHDOG (LAMBDA (ID PRINTER JOBNAME) (* ; "Edited 11-Dec-87 14:38 by bvm:") (* ;; "Run the single process for a given printer.") (* ;; "*PRINT-JOBS-IN-PROGRESS* is a list of quads (JOB-ID PRINTER JOBNAME LASTSTATUS).") (BLOCK 15000) (bind MSG STATUS do (for TAIL on *PRINT-JOBS-IN-PROGRESS* do (DESTRUCTURING-BIND (ID PRINTER JOBNAME GIVEUPCNT . LASTSTATUS) (CAR TAIL) (COND ((NOT (EQUAL (SETQ STATUS (\NSPRINT.FULL.REQUEST.STATUS ID PRINTER)) LASTSTATUS)) (printout PROMPTWINDOW .TAB0 0) (COND (JOBNAME (printout PROMPTWINDOW JOBNAME " on "))) (printout PROMPTWINDOW (fetch NSPRINTERNAME of PRINTER) " -- " (OR (CAR STATUS) "No response")) (COND ((SETQ MSG (CADR STATUS)) (printout PROMPTWINDOW " (" MSG ")"))) (COND ((SETQ MSG (CADDR STATUS)) (printout PROMPTWINDOW " (" MSG ")"))) (if (SELECTQ (CAR STATUS) ((Pending InProgress) (SETQ GIVEUPCNT 0) NIL) (NIL (* ; "No response") (> (add GIVEUPCNT 1) 5)) T) then (* ; "Can stop watching. This awful construction is because DREMOVE can disrupt the iteration.") (RPLACA TAIL NIL) else (* ; "Note status for next time") (RPLACD (RPLACA (CDDDR (CAR TAIL)) GIVEUPCNT) STATUS)))))) (if (NULL (SETQ *PRINT-JOBS-IN-PROGRESS* (DREMOVE NIL *PRINT-JOBS-IN-PROGRESS*))) then (RETURN)) (BLOCK 30000))) ) (\NSPRINT.WATCH.JOB (LAMBDA (PRINTRESULTS PRINTER JOBNAME) (* ; "Edited 11-Dec-87 12:38 by bvm:") (* ;; "Set up a 'watchdog' process to keep the guy informed of the print job's status") (CL:PUSH (LIST PRINTRESULTS PRINTER JOBNAME 0) *PRINT-JOBS-IN-PROGRESS*) (OR (FIND.PROCESS (QUOTE Printer% Watcher)) (ADD.PROCESS (LIST (FUNCTION \NSPRINT.WATCHDOG)) (QUOTE NAME) (QUOTE Printer% Watcher) (QUOTE AFTEREXIT) (QUOTE DELETE)))) ) (\NSPRINT.FULL.REQUEST.STATUS (LAMBDA (ID PRINTER) (* bvm%: "26-Jul-85 12:38") (* ;;; "Returns a triple (RequestStatus StatusMessage PrinterStatus), with the last two items being NIL when they are uninteresting") (SETQ PRINTER (GETNSPRINTER PRINTER)) (CAR (NLSETQ (RESETLST (LET ((STREAM (\NSPRINT.COURIER.OPEN PRINTER)) RESULT STATUS) (COND ((AND STREAM (PROGN (RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE) STREAM)) (SETQ RESULT (COURIER.CALL STREAM (QUOTE PRINTING) (QUOTE GET.PRINT.REQUEST.STATUS) ID (QUOTE NOERROR)))) (LIST (CADR (ASSOC (QUOTE STATUS) RESULT)) (AND (SETQ STATUS (CADR (ASSOC (QUOTE STATUS.MESSAGE) RESULT))) (NOT (STREQUAL STATUS "")) STATUS) (SELECTQ (SETQ STATUS (CADR (ASSOC (QUOTE PRINTER) (COURIER.CALL STREAM (QUOTE PRINTING) (QUOTE GET.PRINTER.STATUS) (QUOTE NOERROR))))) ((NIL Busy Available) (* ; "Expected status values") NIL) STATUS)))))))))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS *PRINT-JOBS-IN-PROGRESS*) ) (RPAQ? *PRINT-JOBS-IN-PROGRESS* ) (* ; "FAX") (DEFINEQ (FAX.SEND.FILE (LAMBDA (HOST FILE PRINTOPTIONS) (* bvm%: "17-Sep-85 15:52") (* ;;; "Sends Interpress document FILE to a FAX server specified by HOST, which is of the form person@place. Simple front end to NSPRINT") (LET ((HOST&OPTIONS (\FAX.PARSE.NAME HOST))) (NSPRINT (CAR HOST&OPTIONS) FILE (APPEND (CDR HOST&OPTIONS) PRINTOPTIONS (AND FAX.NO.WATCHER (LIST (QUOTE NO.WATCHER) T)))))) ) (FAX.STATUS (LAMBDA (HOST) (* bvm%: "16-Sep-85 23:29") (* ;;; "Tests status of FAX server specified by HOST, which is of the form person@place. Simple front end to NSPRINTER.STATUS") (NSPRINTER.STATUS (CAR (\FAX.PARSE.NAME HOST)))) ) (FAX.PROPERTIES (LAMBDA (HOST) (* bvm%: "16-Sep-85 23:33") (* ;;; "Returns properties of FAX server specified by HOST, which is of the form person@place. Simple front end to NSPRINTER.PROPERTIES") (NSPRINTER.PROPERTIES (CAR (\FAX.PARSE.NAME HOST)))) ) (FAX.HOSTNAMEP (LAMBDA (PRINTERNAME) (* bvm%: "16-Sep-85 22:51") (* ;;; "True if PRINTERNAME is something that looks like a FAX spec, i.e., person@place, where place is a phone number or something registered as a fax address. Stupid for now") (AND (STRPOS "@" PRINTERNAME) (QUOTE FAX))) ) (\FAX.PARSE.NAME (LAMBDA (PLACE) (* bvm%: "17-Sep-85 15:58") (* ;;; "Parse a Fax spec 'Person@Place' and return a dotted pair (FaxServer . PrintOptions)") (PROG (AT PERSON DESTINATION PHONE HOST MSG INFO) RETRY (SETQ AT (STRPOS "@" PLACE)) (COND ((SETQ PERSON (AND (NEQ AT 1) (SUBSTRING PLACE 1 (SUB1 AT)))) (SETQ PERSON (LIST (QUOTE RECIPIENT.NAME) PERSON)))) (SETQ DESTINATION (SUBSTRING PLACE (ADD1 AT))) (COND ((for CH instring DESTINATION always (OR (DIGITCHARP CH) (EQ CH (CHARCODE -)) (EQ CH (CHARCODE *)) (EQ CH (CHARCODE %#)))) (* ; "Looks like a phone number") (SETQ PHONE DESTINATION)) ((AND (SETQ INFO (CDR (ASSOC (MKATOM (U-CASE DESTINATION)) FAXADDRESSES))) (SETQ PHONE (CAR INFO))) (SETQ HOST (CADR INFO))) (T (SETQ MSG (CONCAT "The FAX destination %"" DESTINATION "%" is unknown. Edit the list FAXADDRESSES")) (GO FAIL))) (COND ((AND (NULL HOST) (NULL (SETQ HOST DEFAULTFAXHOST))) (SETQ MSG "Don't know the name of your local FAX server. Set the variable DEFAULTFAXHOST") (GO FAIL))) (RETURN (CONS HOST (CONS (QUOTE MESSAGE) (CONS PHONE PERSON)))) FAIL (ERROR (CONCAT "Don't understand " PLACE " because:") (CONCAT MSG " appropriately, then say OK. Alternatively, RETURN %"name@CorrectPhoneOrDestination%""))))) ) (RPAQ? DEFAULTFAXHOST ) (RPAQ? FAXADDRESSES ) (RPAQ? FAX.NO.WATCHER T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DEFAULTFAXHOST FAXADDRESSES FAX.NO.WATCHER) ) (ADDTOVAR PRINTERTYPES ((FAX TELECOPIER) (CANPRINT (INTERPRESS)) (HOSTNAMEP FAX.HOSTNAMEP) (STATUS FAX.STATUS) (PROPERTIES FAX.PROPERTIES) (SEND FAX.SEND.FILE) (BITMAPSCALE INTERPRESS.BITMAPSCALE) (BITMAPFILE (INTERPRESSBITMAP FILE BITMAP SCALEFACTOR REGION ROTATION TITLE)))) (PUTPROPS NSPRINT COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1987 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10281 25115 (GETNSPRINTER 10291 . 11044) (NSPRINT 11046 . 12594) (\NSPRINT.INTERNAL 12596 . 23038) (\NSPRINT.MEDIUM.CHECK 23040 . 23418) (\NSPRINT.UNSUPPORTED 23420 . 23725) ( NSPRINTER.HOSTNAMEP 23727 . 23998) (NSPRINTER.STATUS 24000 . 24123) (NSPRINTER.PROPERTIES 24125 . 24257) (NSPRINTREQUEST.STATUS 24259 . 24421) (\NSPRINT.ENQUIRE 24423 . 24906) (\NSPRINT.COURIER.OPEN 24908 . 25113)) (25148 27735 (\NSPRINT.WATCHDOG 25158 . 26415) (\NSPRINT.WATCH.JOB 26417 . 26848) ( \NSPRINT.FULL.REQUEST.STATUS 26850 . 27733)) (27871 30302 (FAX.SEND.FILE 27881 . 28273) (FAX.STATUS 28275 . 28513) (FAX.PROPERTIES 28515 . 28771) (FAX.HOSTNAMEP 28773 . 29066) (\FAX.PARSE.NAME 29068 . 30300))))) STOP \ No newline at end of file diff --git a/sources/P4A.scn b/sources/P4A.scn new file mode 100644 index 00000000..82d2a22a --- /dev/null +++ b/sources/P4A.scn @@ -0,0 +1,245 @@ +;;; The minimal stuff needed to make this a vanilla CL file +(LISP:IN-PACKAGE "INTERLISP") +(SETQ *READTABLE* (FIND-READTABLE "INTERLISP")) +(PROGN (_ (SETQ *LOADED-OBJECT-SET* (PROGN (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 31)) ( +shift-in-operation 14) (day 7) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 30)) ( +shift-in-operation 13) (day 7) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 29)) ( +shift-in-operation 12) (day 6) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 28)) ( +shift-in-operation 11) (day 6) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 27)) ( +shift-in-operation 10) (day 5) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 26)) ( +shift-in-operation 9) (day 5) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 25)) ( +shift-in-operation 8) (day 4) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 24)) ( +shift-in-operation 7) (day 4) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 23)) ( +shift-in-operation 6) (day 3) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 22)) ( +shift-in-operation 5) (day 3) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 21)) ( +shift-in-operation 4) (day 2) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 20)) ( +shift-in-operation 3) (day 2) (shift 1)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 19)) ( +shift-in-operation 2) (day 1) (shift 2)) (DEFINST DAILY-INFORMATION ((|JF_0P.002.:V8.UF:| . 18)) ( +shift-in-operation 1) (day 1) (shift 1)) (DEFINST FileIndexedObjectSet ((|JF_0P.002.:V8.UF:| . 17)) ( +objects (#,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 31)) #,($& DAILY-INFORMATION ( +|JF_0P.002.:V8.UF:| . 30)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 29)) #,($& DAILY-INFORMATION + (|JF_0P.002.:V8.UF:| . 28)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 27)) #,($& +DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 26)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 25)) #,( +$& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 24)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 23)) +#,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 22)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 21) +) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 20)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . +19)) #,($& DAILY-INFORMATION (|JF_0P.002.:V8.UF:| . 18)))) (type DAILY-INFORMATION) (indexIV +shift-in-operation)))) SetFilename) (_ (SETQ *LOADED-OBJECT-SET* (PROGN (PROGN (DEFINST ObjectSet (( +|JF_0P.002.:V8.UF:| . 36)) (type STEVEDORE))) (PROGN (DEFINST LIGHTERAGE ((|JF_0P.002.:V8.UF:| . 50)) +(name "CF-3") (AVAILABLE #,(TABLECREATE 'AVAILABLE '"Mins Available" '"Day/Shift" '"" '(CW-FERRY-3% 1 CW-FERRY-3% 2 CW-FERRY-3% 3 CW-FERRY-3% 4 CW-FERRY-3% 5 CW-FERRY-3% 6 CW-FERRY-3% 7) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480) (480 480 480 480 480 480 480 480 480 480 480 480 480 480)) +)) (TYPE CW-FERRY-3) (MENU-NAME "CF-3") (available-force 7) (LENGTH 360) (BEAM 21) (SECTIONS 3) ( +MAX-LOAD #,(TABLECREATE 'MAX-LOAD '"Max items" '"Cargo Package" '"" '(VALUE) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + 'NIL 'NIL 'NIL #2A((8 4 240 24 12)))) (MAX-TONS 305) (MAX-SEA-STATE 3) (MAX-SURF-STATE 6) ( +MAX-CURRENT NIL) (SPEED #,(TABLECREATE 'SPEED '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((7.5 7.5 7.5 7.5 7.5 7.5 7.5 7.5 7.5) (4.3 4.3 4.3 4.3 4.3 4.3 4.3 4.3 4.3)))) ( +LOADED-WEIGHT NIL) (LOADED-DRAFT 9) (UNLOADED-DRAFT NIL) (ACCELERATION #,(TABLECREATE 'ACCELERATION '"Loading" + '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)) +)) (DECELERATION #,(TABLECREATE 'DECELERATION '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)))) (ALLOWED-PKG (WHEELED-VEHICLE +TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40)) (ALLOWED-OFFLOAD (LSP ELCAS)) (ALLOWED-DISCHARGE-PT + (30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RRDF)) (DOCK-TIME +#,(TABLECREATE 'DOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNDOCK-TIME #,(TABLECREATE 'UNDOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL) (15 NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (MOOR-TIME #,(TABLECREATE 'MOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (22 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (14 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNMOOR-TIME #,(TABLECREATE 'UNMOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((18 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-SETUP-TIME #,(TABLECREATE 'LOAD-SETUP-TIME '"Ship" '"Cargo Packaging" '"Sea State" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-SETUP-TIME #,(TABLECREATE 'UNLOAD-SETUP-TIME '"Offload Site" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL)) ((0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL)) ((0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL)) ((0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL) (0 0 0 0 0 0 0 NIL NIL NIL NIL))) +)) (LOAD-ONE-ITEM-TIME #,(TABLECREATE 'LOAD-ONE-ITEM-TIME '"Discharge Pt" '"Cargo Packaging" '"Sea State" + '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((12 NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL)) ((8 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL)) ((8 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL)) ((8 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-ONE-ITEM-TIME #,(TABLECREATE 'UNLOAD-ONE-ITEM-TIME '"Offload" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((2 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((20 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (20 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +))) (DEFINST LIGHTERAGE ((|JF_0P.002.:V8.UF:| . 49)) (name "LSV") (AVAILABLE #,(TABLECREATE 'AVAILABLE + '"Mins Available" '"Day/Shift" '"" '(LSV% 1 LSV% 2) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS + #2A((600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600)) +)) (TYPE LSV) (MENU-NAME "LSV") (available-force 2) (LENGTH 272.75) (BEAM 60) (SECTIONS 3) (MAX-LOAD +#,(TABLECREATE 'MAX-LOAD '"Max items" '"Cargo Package" '"" '(VALUE) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + 'NIL 'NIL 'NIL #2A((10 5 200 25 15)))) (MAX-TONS 2000) (MAX-SEA-STATE 3) (MAX-SURF-STATE NIL) ( +MAX-CURRENT NIL) (SPEED #,(TABLECREATE 'SPEED '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((10.8 10.8 10.8 10.8 10.8 10.8 10.8 10.8 10.8) (8.9 8.9 8.9 8.9 8.9 8.9 8.9 8.9 8.9)) +)) (LOADED-WEIGHT NIL) (LOADED-DRAFT 12) (UNLOADED-DRAFT 5.75) (ACCELERATION #,(TABLECREATE 'ACCELERATION + '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)) +)) (DECELERATION #,(TABLECREATE 'DECELERATION '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)))) (ALLOWED-PKG (WHEELED-VEHICLE +TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40)) (ALLOWED-OFFLOAD (LSP ELCAS FLOATING-PIER)) ( +ALLOWED-DISCHARGE-PT (30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RRDF)) ( +DOCK-TIME #,(TABLECREATE 'DOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL) (21 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNDOCK-TIME #,(TABLECREATE 'UNDOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (MOOR-TIME #,(TABLECREATE 'MOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNMOOR-TIME #,(TABLECREATE 'UNMOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-SETUP-TIME #,(TABLECREATE 'LOAD-SETUP-TIME '"Ship" '"Cargo Packaging" '"Sea State" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-SETUP-TIME #,(TABLECREATE 'UNLOAD-SETUP-TIME '"Offload Site" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-ONE-ITEM-TIME #,(TABLECREATE 'LOAD-ONE-ITEM-TIME '"Discharge Pt" '"Cargo Packaging" '"Sea State" + '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL) (8 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-ONE-ITEM-TIME #,(TABLECREATE 'UNLOAD-ONE-ITEM-TIME '"Offload" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (18 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +))) (DEFINST LIGHTERAGE ((|JF_0P.002.:V8.UF:| . 48)) (name "LCU 2000") (AVAILABLE #,(TABLECREATE 'AVAILABLE + '"Mins Available" '"Day/Shift" '"" '(LCU-2000% 1 LCU-2000% 2 LCU-2000% 3 LCU-2000% 4 LCU-2000% 5 LCU-2000% 6) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((540 540 540 540 540 540 540 540 540 540 540 540 540 540) (540 540 540 540 540 540 540 540 540 540 540 540 540 540) (540 540 540 540 540 540 540 540 540 540 540 540 540 540) (540 540 540 540 540 540 540 540 540 540 540 540 540 540) (540 540 540 540 540 540 540 540 540 540 540 540 540 540) (540 540 540 540 540 540 540 540 540 540 540 540 540 540)) +)) (TYPE LCU-2000) (MENU-NAME "LCU-2000") (available-force 6) (LENGTH 174) (BEAM 42) (SECTIONS 3) ( +MAX-LOAD #,(TABLECREATE 'MAX-LOAD '"Max items" '"Cargo Package" '"" '(VALUE) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + 'NIL 'NIL 'NIL #2A((4 2 224 7 3)))) (MAX-TONS 350) (MAX-SEA-STATE 3) (MAX-SURF-STATE 12) (MAX-CURRENT + NIL) (SPEED #,(TABLECREATE 'SPEED '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((12.5 12.5 12.5 12.5 12.5 12.5 12.5 12.5 12.5) (7.4 7.4 7.4 7.4 7.4 7.4 7.4 7.4 7.4)) +)) (LOADED-WEIGHT NIL) (LOADED-DRAFT 8.85) (UNLOADED-DRAFT 8) (ACCELERATION #,(TABLECREATE 'ACCELERATION + '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)) +)) (DECELERATION #,(TABLECREATE 'DECELERATION '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)))) (ALLOWED-PKG (WHEELED-VEHICLE +TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40)) (ALLOWED-OFFLOAD (LSP ELCAS FLOATING-PIER)) ( +ALLOWED-DISCHARGE-PT (30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RRDF)) ( +DOCK-TIME #,(TABLECREATE 'DOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNDOCK-TIME #,(TABLECREATE 'UNDOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL) (6 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (MOOR-TIME #,(TABLECREATE 'MOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((121 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (121 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (12 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (9 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNMOOR-TIME #,(TABLECREATE 'UNMOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-SETUP-TIME #,(TABLECREATE 'LOAD-SETUP-TIME '"Ship" '"Cargo Packaging" '"Sea State" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-SETUP-TIME #,(TABLECREATE 'UNLOAD-SETUP-TIME '"Offload Site" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-ONE-ITEM-TIME #,(TABLECREATE 'LOAD-ONE-ITEM-TIME '"Discharge Pt" '"Cargo Packaging" '"Sea State" + '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((11 NIL NIL NIL NIL NIL NIL NIL NIL) (11 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-ONE-ITEM-TIME #,(TABLECREATE 'UNLOAD-ONE-ITEM-TIME '"Offload" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (7 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (10 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (4 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +))) (DEFINST LIGHTERAGE ((|JF_0P.002.:V8.UF:| . 47)) (name "LACV-30") (AVAILABLE #,(TABLECREATE 'AVAILABLE + '"Mins Available" '"Day/Shift" '"" '(LACV-30% 1 LACV-30% 2 LACV-30% 3 LACV-30% 4 LACV-30% 5 LACV-30% 6) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600) (600 600 600 600 600 600 600 600 600 600 600 600 600 600)) +)) (TYPE LACV-30) (MENU-NAME "LACV-30") (available-force 6) (LENGTH 79.42) (BEAM 36.67) (SECTIONS 3) ( +MAX-LOAD #,(TABLECREATE 'MAX-LOAD '"Max items" '"Cargo Package" '"" '(VALUE) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + 'NIL 'NIL 'NIL #2A((NIL NIL NIL 1 1)))) (MAX-TONS 23) (MAX-SEA-STATE 3) (MAX-SURF-STATE 8) ( +MAX-CURRENT NIL) (SPEED #,(TABLECREATE 'SPEED '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((25 25 25 NIL NIL NIL NIL NIL NIL) (15 15 15 NIL NIL NIL NIL NIL NIL)))) ( +LOADED-WEIGHT 76.5) (LOADED-DRAFT 2) (UNLOADED-DRAFT 2) (ACCELERATION #,(TABLECREATE 'ACCELERATION '"Loading" + '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)) +)) (DECELERATION #,(TABLECREATE 'DECELERATION '"Loading" '"Sea State" '"" '(UNLOADED LOADED) '(0 1 2 3 4 5 6 10 20) + 'NIL 'NIL 'NIL #2A((0 0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0 0)))) (ALLOWED-PKG (CONTAINER-20 CONTAINER-40 +)) (ALLOWED-OFFLOAD (AMPHIB-BERM)) (ALLOWED-DISCHARGE-PT (30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON + 40-TON-TWIN 50-TON 105-TON)) (DOCK-TIME #,(TABLECREATE 'DOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNDOCK-TIME #,(TABLECREATE 'UNDOCK-TIME '"Offload Site" '"Surf State" '"Shore Current" '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) + '(0 1 2 3 4 5 6 7 8 9 10) '(0 1 2 3 4 5 6 7 8) 'NIL 'NIL #3A(((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (MOOR-TIME #,(TABLECREATE 'MOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((ÿÿ NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNMOOR-TIME #,(TABLECREATE 'UNMOOR-TIME '"Ship Type" '"Sea State" '"Current" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(0 1 2 3 4 5 6 10 20) '(0 1 2 3 4 5 6 7 8 10 20 30) 'NIL 'NIL #3A(((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (3 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-SETUP-TIME #,(TABLECREATE 'LOAD-SETUP-TIME '"Ship" '"Cargo Packaging" '"Sea State" '(CONTAINER BREAKBULK BREAKBULK-CONT FAST-SEA-LIFT TACS RORO) + '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-SETUP-TIME #,(TABLECREATE 'UNLOAD-SETUP-TIME '"Offload Site" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (0 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +)) (LOAD-ONE-ITEM-TIME #,(TABLECREATE 'LOAD-ONE-ITEM-TIME '"Discharge Pt" '"Cargo Packaging" '"Sea State" + '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 10 20) 'NIL 'NIL #3A(((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL) (5 5 5 NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL 5 5 NIL NIL NIL NIL NIL NIL) (NIL 5 5 NIL NIL NIL NIL NIL NIL))) +)) (UNLOAD-ONE-ITEM-TIME #,(TABLECREATE 'UNLOAD-ONE-ITEM-TIME '"Offload" '"Cargo Packaging" '"Surf State" + '(LSP ELCAS AMPHIB-BERM FLOATING-PIER) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + '(0 1 2 3 4 5 6 7 8 9 10) 'NIL 'NIL #3A(((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (2 NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL))) +))) (DEFINST ObjectSet ((|JF_0P.002.:V8.UF:| . 35)) (objects (#,($& LIGHTERAGE (|JF_0P.002.:V8.UF:| . +50)) #,($& LIGHTERAGE (|JF_0P.002.:V8.UF:| . 49)) #,($& LIGHTERAGE (|JF_0P.002.:V8.UF:| . 48)) #,($& +LIGHTERAGE (|JF_0P.002.:V8.UF:| . 47)))) (type LIGHTERAGE))) (PROGN (PROGN (DEFINST OFFLOAD-SITE (( +|JF_0P.002.:V8.UF:| . 43)) (name "Floating Pier #1") (AVAILABLE #,(TABLECREATE 'AVAILABLE '"Mins Available" + '"Day/Shift" '"" '(FLOATING-PIER% 1) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((NIL 600 NIL 600 NIL 600 NIL 600 NIL 600 NIL 600 NIL 600)) +)) (TYPE FLOATING-PIER) (MENU-NAME "Fltng Pier") (map-image-width 57) (map-save #*(57 27)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 20) (beach-location #,(CREATE-MAPREF "Generic Southern Shore" 704 623)) (CRANES T) ( +RORO-LANES NIL) (SHORE-CURRENT NIL) (ALLOWED-LIGHTERS (LCM-8 LCU-1600 LCU-2000 CW-FERRY-1 CW-FERRY-2 +CW-FERRY-3)) (MAP-PICTURE #*(16 16)@@@@@CL@@CL@@CL@@CL@@CL@@CL@@CL@@BH@@B@@@B@@@@@@@GN@@CL@@AH@@@@@) ( +MAP-CURSOR #,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)@@@@@CL@@CL@@CL@@CL@@CL@@CL@@CL@@BH@@B@@@B@@@@@@@GN@@CL@@AH@@@@@ +) image 7 0 NIL))))) (PROGN (DEFINST OFFLOAD-SITE ((|JF_0P.002.:V8.UF:| . 42)) (name "Amphib #1") ( +AVAILABLE #,(TABLECREATE 'AVAILABLE '"Mins Available" '"Day/Shift" '"" '(AMPHIB-BERM% 1) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) + 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((450 450 450 450 450 450 450 450 450 450 450 450 450 450)))) (TYPE +AMPHIB-BERM) (MENU-NAME "Amphib-Berm") (map-image-width 41) (map-save #*(41 19)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 12) (beach-location #,(CREATE-MAPREF "Generic Southern Shore" 718 711)) (CRANES T) ( +RORO-LANES NIL) (SHORE-CURRENT #,(TABLECREATE 'SHORE-CURRENT '"Mins Available" '"Day/Shift" '"" '(AMPHIB-BERM% 1) + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((480 480 480 480 480 480 480 480 480 480 480 480 480 480)) +)) (ALLOWED-PKG (CONTAINER-20 CONTAINER-40)) (ALLOWED-LIGHTERS (LACV-30)) (MAP-PICTURE #*(16 8)AF@@@C@@AAIO@@MCA@GC@@COA@AO@@AO +) (MAP-CURSOR #,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)@@@@@L@@AF@@@C@@AAIO@@MCA@GC@@COA@AO@@AO@GL@@GL@@CH@@CH@@A@@@A@@ +) image 7 0 NIL))))) (PROGN (DEFINST OFFLOAD-SITE ((|JF_0P.002.:V8.UF:| . 41)) (name "ELCAS #1") ( +AVAILABLE #,(TABLECREATE 'AVAILABLE '"Mins Available" '"Day/Shift" '"" '(ELCAS% 1) '(0 1 2 3 4 5 6 7) + 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((600 NIL 600 NIL 600 NIL 600 NIL)))) (TYPE ELCAS) (MENU-NAME "ELCAS") ( +map-image-width 35) (map-save #*(35 24)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 9) (beach-location #,(CREATE-MAPREF "Generic Southern Shore" 735 818)) (CRANES T) ( +RORO-LANES T) (MAX-SEA 3) (SHORE-CURRENT NIL) (ALLOWED-LIGHTERS (LCM-8 LCU-1600 LCU-2000 CW-FERRY-1 +CW-FERRY-2 CW-FERRY-3)) (MAP-PICTURE #*(16 13)@@@C@@@G@AON@AOL@AOH@AO@OOOOOOOOLNCKMKFOOALGOOOOOOOO) ( +MAP-CURSOR #,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)@@@B@@@D@@CH@@CHOOOOIIIINFFGOOOO@@@@@@@@@GL@@GL@@CH@@CH@@A@@@A@@ +) image 7 0 NIL))))) (PROGN (DEFINST OFFLOAD-SITE ((|JF_0P.002.:V8.UF:| . 40)) (name "LSP #1") ( +AVAILABLE #,(TABLECREATE 'AVAILABLE '"Mins Available" '"Day/Shift" '"" '(LSP% 1) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) + 'NIL 'NIL 'SHIFTS-TO-DAYS #2A((600 600 600 600 600 600 600 600 600 600 600 600 600 600)))) (TYPE LSP) + (MENU-NAME "LSP") (map-image-width 24) (map-save #*(24 27)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 4) (beach-location #,(CREATE-MAPREF "Generic Southern Shore" 733 910)) (LOCATION "") ( +CRANES T) (RORO-LANES NIL) (MAX-DRAFT 50) (MAX-SEA 10) (SHORE-CURRENT NIL) (MAX-CURRENT 10) ( +ALLOWED-PKG (WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20)) (ALLOWED-LIGHTERS (LARC-60 LCM-8 +LCU-1600 LCU-2000 CW-FERRY-1 CW-FERRY-2 CW-FERRY-3)) (MAP-PICTURE #*(16 16)NBDGNBDGNBDGNBDGNBDGNBDGOJEOOOOOOLCON@@GL@@CL@@CH@@A@@@@@@@@@@@@ +) (MAP-CURSOR #,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)NBDGNBDGNBDGNBDGNBDGNBDGOJEOOOOOOLCON@@GL@@CLOOCHOOA@GN@@CL@@AH@ +) image 7 0 NIL))))) (DEFINST ObjectSet ((|JF_0P.002.:V8.UF:| . 34)) (objects (#,($& OFFLOAD-SITE ( +|JF_0P.002.:V8.UF:| . 43)) #,($& OFFLOAD-SITE (|JF_0P.002.:V8.UF:| . 42)) #,($& OFFLOAD-SITE ( +|JF_0P.002.:V8.UF:| . 41)) #,($& OFFLOAD-SITE (|JF_0P.002.:V8.UF:| . 40)))) (type OFFLOAD-SITE))) ( +PROGN (PROGN (DEFINST ANCHORAGE ((|JF_0P.002.:V8.UF:| . 46)) (name "Anch #2") (TYPE ANCHORAGE) ( +MENU-NAME "Anchorage") (map-image-width 32) (map-save #*(32 27)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 8) (location #,(CREATE-MAPREF "Generic Southern Shore" 502 921)) (depth 1000) ( +MAP-PICTURE #*(16 16)@@@@@@@@@AH@@BD@@BD@@AH@@AH@@AH@@AH@@AH@GAHNFAHFEIIJAMKH@GN@@AH@) (MAP-CURSOR +#,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)@A@@@BH@@A@@@A@@@A@@@A@@AAA@AMG@@CH@@@@@@GL@@GL@@CH@@CH@@A@@@A@@ +) image 7 0 NIL))))) (PROGN (DEFINST RRDF ((|JF_0P.002.:V8.UF:| . 45))) (DEFINST ANCHORAGE (( +|JF_0P.002.:V8.UF:| . 44)) (name "Anch #1") (TYPE ANCHORAGE) (MENU-NAME "Anchorage") (map-image-width +32) (map-save #*(32 27)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +) (map-image-x 8) (location #,(CREATE-MAPREF "Generic Southern Shore" 551 660)) (depth 1000) (rrdf #,( +$& RRDF (|JF_0P.002.:V8.UF:| . 45))) (MAP-PICTURE #*(16 16)@@@@@@@@@AH@@BD@@BD@@AH@@AH@@AH@@AH@@AH@GAHNFAHFEIIJAMKH@GN@@AH@ +) (MAP-CURSOR #,(LET(image) (CURSORCREATE (SETQ image '#*(16 16)@A@@@BH@@A@@@A@@@A@@@A@@AAA@AMG@@CH@@@@@@GL@@GL@@CH@@CH@@A@@@A@@ +) image 7 0 NIL))))) (DEFINST ObjectSet ((|JF_0P.002.:V8.UF:| . 33)) (objects (#,($& ANCHORAGE ( +|JF_0P.002.:V8.UF:| . 46)) #,($& ANCHORAGE (|JF_0P.002.:V8.UF:| . 44)))) (type ANCHORAGE))) (DEFINST +FileObjectSet ((|JF_0P.002.:V8.UF:| . 32)) (objects (#,($& ObjectSet (|JF_0P.002.:V8.UF:| . 36)) #,($& + ObjectSet (|JF_0P.002.:V8.UF:| . 35)) #,($& ObjectSet (|JF_0P.002.:V8.UF:| . 34)) #,($& ObjectSet ( +|JF_0P.002.:V8.UF:| . 33)))) (type ASSET)))) SetFilename) (_ (SETQ *LOADED-OBJECT-SET* (PROGN (PROGN ( +DEFINST ACTUAL-SHIP ((|JF_0P.002.:V8.UF:| . 39)) (PACKAGE-TYPES (WHEELED-VEHICLE TRACKED-VEHICLE)) ( +UNLOADABLE-PKG-TYPES (TRACKED-VEHICLE WHEELED-VEHICLE)) (name "RORO #1") (arrival-time (1 1)) (DRAFT +50) (MANIFEST #,(TABLECREATE '"Ship's manifest" '"Units of cargo" '"Package" '"" '(GEN-TRACKED-VEH GEN-WHEELED-VEH GEN-PALLET GEN-CONT-20 GEN-CONT-40) + '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) 'NIL 'NIL 'NIL #2A((NIL 435 NIL NIL NIL) (131 NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL)) +)) (ATTACH-POINTS #,(TABLECREATE 'ATTACH-POINTS '"Number" '"Kind of discharge point" '"" '(VALUE) '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) + 'NIL 'NIL 'NIL #2A((NIL NIL NIL NIL NIL NIL NIL NIL NIL 2)))) (ALLOWED-LIGHTER (CW-FERRY-1 CW-FERRY-2 + CW-FERRY-3 LCU-1600 LCU-2000 LCM-8)) (TYPE RORO) (MENU-NAME "RO/RO Ship"))) (PROGN (DEFINST +ACTUAL-SHIP ((|JF_0P.002.:V8.UF:| . 38)) (PACKAGE-TYPES (CONTAINER-20 CONTAINER-40)) ( +UNLOADABLE-PKG-TYPES (CONTAINER-40 CONTAINER-20)) (name "Container #1") (arrival-time (1 1)) (LENGTH +1000) (BEAM 500) (DRAFT 50) (MANIFEST #,(TABLECREATE '"Ship's manifest" '"Units of cargo" '"Package" '"" + '(GEN-TRACKED-VEH GEN-WHEELED-VEH GEN-PALLET GEN-CONT-20 GEN-CONT-40) '(WHEELED-VEHICLE TRACKED-VEHICLE PALLET CONTAINER-20 CONTAINER-40) + 'NIL 'NIL 'NIL #2A((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL 560 NIL) (NIL NIL NIL NIL 70)) +)) (ATTACH-POINTS #,(TABLECREATE 'ATTACH-POINTS '"Number" '"Kind of discharge point" '"" '(VALUE) '(30-TON 30-TON-TWIN 35-TON 35-TON-TWIN 40-TON 40-TON-TWIN 50-TON 105-TON RAMP RRDF) + 'NIL 'NIL 'NIL #2A((NIL 1 NIL NIL NIL NIL NIL NIL NIL NIL)))) (ALLOWED-LIGHTER (LACV-30 LARC-60 +LCU-1600 LCU-2000 LSV CW-FERRY-1 CW-FERRY-2 CW-FERRY-3)) (TYPE CONTAINER) (MENU-NAME "Cont Ship"))) ( +DEFINST FileObjectSet ((|JF_0P.002.:V8.UF:| . 37)) (objects (#,($& ACTUAL-SHIP (|JF_0P.002.:V8.UF:| . +39)) #,($& ACTUAL-SHIP (|JF_0P.002.:V8.UF:| . 38)))) (type ACTUAL-SHIP)))) SetFilename) (_ (SETQ +*LOADED-OBJECT-SET* (DEFINST SCENARIO ((|JF_0P.002.:V8.UF:| . 16)) (START-DAY 1) (END-DAY 4) ( +ACTUAL-SHIP #,($& FileObjectSet (|JF_0P.002.:V8.UF:| . 37))) (DAILY-INFORMATION #,($& +FileIndexedObjectSet (|JF_0P.002.:V8.UF:| . 17))) (ASSET #,($& FileObjectSet (|JF_0P.002.:V8.UF:| . 32 +))) (ANCHORAGE #,($& ObjectSet (|JF_0P.002.:V8.UF:| . 33))) (OFFLOAD-SITE #,($& ObjectSet ( +|JF_0P.002.:V8.UF:| . 34))) (LIGHTERAGE #,($& ObjectSet (|JF_0P.002.:V8.UF:| . 35))) (STEVEDORE #,($& +ObjectSet (|JF_0P.002.:V8.UF:| . 36))) (filename "P4A") (name "(P4a) Practice Scenario") (map-name +"Generic Southern Shore") (prompt-window {WINDOW}#376,13000) (WEATHER-TABLE #,(TABLECREATE '"Forecasts" + '"Environmental Data" '"Day & Shift" 'NIL '(SEA-STATE SURF-STATE SEA-CURRENT SHORE-CURRENT WIND) '(0 1 2 3 4 5 6 7) + 'NIL '0 'SHIFTS-TO-DAYS #2A((0 0 3 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0) (0 0 0 0 0 0 0 0)) +)) (KB-NAME "Default") (RDD-TABLE #,(TABLECREATE '"RDDs" '"Delivery Reqts" '"Day/Shift" 'NIL '("GEN-TRACKED-VEH (ea)" "GEN-WHEELED-VEH (ea)" "GEN-PALLET (ea)" "GEN-CONT-20 (ea)" "GEN-CONT-40 (ea)") + '(0 1 2 3 4 5 6 7) '(REQTS DELIVERIES PLAN) 'NIL 'SHIFTS-TO-DAYS #3A(((NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (400 NIL NIL)) ((NIL NIL NIL) (20 NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (100 NIL NIL)) ((NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL)) ((NIL NIL NIL) (20 NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (450 NIL NIL)) ((NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (NIL NIL NIL) (50 NIL NIL))) +)) (PACKAGE-DELIVERIES #,(TABLECREATE '"Planned Deliveries" '"Cargo" '"Day/Shift" '"Package" '("GEN-TRACKED-VEH (ea)" "GEN-WHEELED-VEH (ea)" "GEN-PALLET (ea)" "GEN-CONT-20 (ea)" "GEN-CONT-40 (ea)") + '(0 1 2 3 4 5 6 7 8 9 10 11 12 13) '("WHEELED-VEHICLE (ea)" "TRACKED-VEHICLE (ea)" "PALLET (ea)" "CONTAINER-20 (ea)" "CONTAINER-40 (ea)") + 'NIL 'SHIFTS-TO-DAYS #3A(((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL)) ((NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL) (NIL NIL NIL NIL NIL))) +)))) SetFilename)) diff --git a/sources/PACKAGE-CONVERSION-TABLE b/sources/PACKAGE-CONVERSION-TABLE new file mode 100644 index 00000000..410817e8 --- /dev/null +++ b/sources/PACKAGE-CONVERSION-TABLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-May-90 20:56:25"  |{DSK}local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;2| 1926 |changes| |to:| (VARS PACKAGE-CONVERSION-TABLECOMS) |previous| |date:| " 8-Jan-88 11:33:44" |{DSK}local>lde>lispcore>sources>PACKAGE-CONVERSION-TABLE.;1|) ; Copyright (c) 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT PACKAGE-CONVERSION-TABLECOMS) (RPAQQ PACKAGE-CONVERSION-TABLECOMS ( (* |;;;| "Set up the LITATOM-PACKAGE-CONVERSION-TABLE for use by the INIT.") (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE) (* |;;| "Arrange to use the correct compiler.") (PROP FILETYPE PACKAGE-CONVERSION-TABLE))) (* |;;;| "Set up the LITATOM-PACKAGE-CONVERSION-TABLE for use by the INIT.") (CL:DEFVAR LITATOM-PACKAGE-CONVERSION-TABLE '(("CL::" NIL "LISP" :INTERNAL) ("CL:" ("CL:FLG" "CL:MAKE-SYMBOL" "CL:COPY-SYMBOL" "CL:INTERN" "CL:MAKE-KEYWORD" "CL:GENTEMP" "CL:KEYWORDP") "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) ("CONDITIONS::" NIL "CONDITIONS" :INTERNAL) ("CONDITIONS:" NIL "CONDITIONS" :EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) ("XCL:" NIL "XCL" :EXTERNAL) ("SI::" NIL "SI" :INTERNAL) ("SI:" NIL "SI" :EXTERNAL) ("COMPILER::" NIL "COMPILER" :INTERNAL) ("COMPILER:" NIL "COMPILER" :EXTERNAL) ("FASL::" NIL "FASL" :INTERNAL) ("FASL:" NIL "FASL" :EXTERNAL))) (* |;;| "Arrange to use the correct compiler.") (PUTPROPS PACKAGE-CONVERSION-TABLE FILETYPE CL:COMPILE-FILE) (PUTPROPS PACKAGE-CONVERSION-TABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/PACKAGE-STARTUP b/sources/PACKAGE-STARTUP new file mode 100644 index 00000000..3f2f1382 --- /dev/null +++ b/sources/PACKAGE-STARTUP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "15-Mar-91 17:09:30" |{PELE:MV:ENVOS}SOURCES>PACKAGE-STARTUP.;4| 37574 |changes| |to:| (FUNCTIONS PACKAGE-MAKE) |previous| |date:| "27-Feb-91 20:17:52" |{PELE:MV:ENVOS}SOURCES>PACKAGE-STARTUP.;3| ) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT PACKAGE-STARTUPCOMS) (RPAQQ PACKAGE-STARTUPCOMS ( (* |;;;| "Initialize the package system (LLPACKAGE must be loaded)") (* |;;| "Simple definitions for the init. Improved in CMLPACKAGE") (FUNCTIONS RETURN-FIRST-OF-THREE ERROR-MISSING-EXTERNAL-SYMBOL) (P (MOVD? 'ERROR-MISSING-EXTERNAL-SYMBOL 'RESOLVE-MISSING-EXTERNAL-SYMBOL) (MOVD? 'ERROR 'RESOLVE-MISSING-PACKAGE) (MOVD? 'ERROR 'RESOLVE-USE-PACKAGE-CONFLICT) (MOVD? 'ERROR 'RESOLVE-EXPORT-CONFLICT) (MOVD? 'ERROR 'RESOLVE-EXPORT-MISSING-CONFLICT) (MOVD? 'ERROR 'RESOLVE-IMPORT-CONFLICT) (MOVD? 'ERROR 'RESOLVE-UNINTERN-CONFLICT) (MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT) (* \;  "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") ) (* |;;| "Reader changes") (FUNCTIONS CHECK-SYMBOL-NAMESTRING \\NEW.READ.SYMBOL \\NEW.MKATOM) (VARIABLES LITATOM-PACKAGE-CONVERSION-ENABLED) (* |;;| "Initialization tables and functions") (VARIABLES CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS) (VARIABLES (* \; "Be very careful with this.") CMLSYMBOLS.SHARED) (FUNCTIONS LITATOM.EXISTS) (VARIABLES LITATOM-PACKAGE-CONVERSION-TABLE) (FUNCTIONS NAMESTRING-CONVERSION-CLAUSE CONVERT-LITATOM CONCOCT-SYMBOL TRANSFER-SYMBOL INTERN-LITATOM \\LITATOM.EATCHARS) (FUNCTIONS PACKAGE-INIT PACKAGE-CLEAR PACKAGE-MAKE PACKAGE-HIERARCHY-INIT PACKAGE-ENABLE PACKAGE-DISABLE) (* |;;| "A hack for initialization") (FUNCTIONS ID) (PROP (FILETYPE MAKEFILE-ENVIRONMENT) PACKAGE-STARTUP) (* |;;|  "Initialize package system, plus functions needed in llpackage at init time") (DECLARE\: DONTEVAL@LOAD DOCOPY (P (MOVD? 'EQ 'EQL) (MOVD? 'LENGTH 'CL:LENGTH) (MOVD? 'ID 'CL:IDENTITY) (MOVD? 'ID 'REMOVE-COMMENTS) (PACKAGE-INIT))))) (* |;;;| "Initialize the package system (LLPACKAGE must be loaded)") (* |;;| "Simple definitions for the init. Improved in CMLPACKAGE") (CL:DEFUN RETURN-FIRST-OF-THREE (ONE TWO THREE) (DECLARE (IGNORE TWO THREE)) ONE) (CL:DEFUN ERROR-MISSING-EXTERNAL-SYMBOL (NAME PACKAGE) (ERROR (CONCAT "External symbol |" NAME "| not found in package " PACKAGE))) (MOVD? 'ERROR-MISSING-EXTERNAL-SYMBOL 'RESOLVE-MISSING-EXTERNAL-SYMBOL) (MOVD? 'ERROR 'RESOLVE-MISSING-PACKAGE) (MOVD? 'ERROR 'RESOLVE-USE-PACKAGE-CONFLICT) (MOVD? 'ERROR 'RESOLVE-EXPORT-CONFLICT) (MOVD? 'ERROR 'RESOLVE-EXPORT-MISSING-CONFLICT) (MOVD? 'ERROR 'RESOLVE-IMPORT-CONFLICT) (MOVD? 'ERROR 'RESOLVE-UNINTERN-CONFLICT) (MOVD? 'RETURN-FIRST-OF-THREE 'RESOLVE-READER-CONFLICT) (* \;  "In pre-package init all symbols are prefixed, thus the INTERLISP symbol is always default") (* |;;| "Reader changes") (CL:DEFUN CHECK-SYMBOL-NAMESTRING (BASE OFFSET LEN FATP) "Check whether a symbol would rather be in a package." (LET* ((CLAUSE (OR (NAMESTRING-CONVERSION-CLAUSE BASE OFFSET LEN FATP) (CL:RETURN-FROM CHECK-SYMBOL-NAMESTRING NIL))) (PREFIX (CL:FIRST CLAUSE)) (CL:PACKAGE-NAME (CL:THIRD CLAUSE)) (WHERE (CL:FOURTH CLAUSE)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (COND (CL:PACKAGE-NAME (INTERN* BASE PREFIX-LENGTH (IDIFFERENCE LEN PREFIX-LENGTH) FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (CL:FIND-PACKAGE CL:PACKAGE-NAME) (EQ WHERE :EXTERNAL))) (T (UNINTERRUPTABLY (\\CREATE.SYMBOL BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP))))))) (CL:DEFUN \\NEW.READ.SYMBOL (BASE OFFSET LEN FATP PACKAGE EXTERNALP NONNUMERICP) "Read a number or symbol from the string defined by BASE OFFSET LEN FATP PACKAGE is NIL if no package was specified, a package object or a string if an unknown package was typed (causes error). EXTERNALP is true if symbol was typed with one colon, which requires that the symbol exist and be external (unless it was a keyword). NONNUMERICP is true if we know the symbol is not a number, e.g., some characters in it were escaped." (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-ENABLED *READTABLE* FILERDTBL CODERDTBL *PACKAGE* *LISP-PACKAGE* *INTERLISP-PACKAGE*)) (OR (AND (NOT NONNUMERICP) (\\PARSE.NUMBER BASE OFFSET LEN FATP)) (AND (* |;;| "The reader conversion feature is contained in this expression") LITATOM-PACKAGE-CONVERSION-ENABLED (NULL PACKAGE) (OR (EQ *READTABLE* FILERDTBL) (EQ *READTABLE* CODERDTBL)) (OR (CHECK-SYMBOL-NAMESTRING BASE OFFSET LEN FATP) (CL:MULTIPLE-VALUE-BIND (CLSYM CLSYMWHERE) (FIND-SYMBOL* BASE OFFSET LEN FATP *LISP-PACKAGE*) (LET ((ILSYM (FIND-SYMBOL* BASE OFFSET LEN FATP *INTERLISP-PACKAGE*))) (COND ((NULL ILSYM) (* \; "No IL symbol, try CL") CLSYM) ((NULL CLSYM) (* \; "No CL symbol, use IL") ILSYM) ((EQ ILSYM CLSYM) (* \; "SAME") ILSYM) (T (* \; "Both symbols exist, resolve. During the INIT where packages are turned off this is defined to return its first argument.") (RESOLVE-READER-CONFLICT ILSYM CLSYM CLSYMWHERE))))))) (COND ((STRINGP PACKAGE) (RESOLVE-MISSING-PACKAGE PACKAGE (\\GETBASESTRING BASE OFFSET LEN FATP) EXTERNALP)) ((OR (NOT EXTERNALP) (EQ PACKAGE *KEYWORD-PACKAGE*)) (INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (OR PACKAGE *PACKAGE*) NIL)) (T (CL:MULTIPLE-VALUE-BIND (CL:SYMBOL ACCESSIBLE) (FIND-SYMBOL* BASE OFFSET LEN FATP (OR PACKAGE *PACKAGE*)) (COND ((EQ ACCESSIBLE :EXTERNAL) CL:SYMBOL) ((CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (* \;  "External only packages don't error creating external symbols on read") (INTERN* BASE OFFSET LEN FATP (\\FATCHARSEENP BASE OFFSET LEN FATP) (OR PACKAGE *PACKAGE*) T)) (T (RESOLVE-MISSING-EXTERNAL-SYMBOL (\\GETBASESTRING BASE OFFSET LEN FATP) PACKAGE)))))))) (CL:DEFUN \\NEW.MKATOM (BASE OFFST LEN FATP) "A version of \\MKATOM which makes symbols in the Interlisp package instead of the old litatom table." (PROG ((FATCHARSEENP (\\FATCHARSEENP BASE OFFST LEN FATP)) (FIRSTCHAR (UNLESSRDSYS (\\GETBASECHAR FATP BASE OFFST) (NTHCHARCODE BASE OFFST))) TEMP) (DECLARE (SPECVARS *INTERLISP-PACKAGE*)) (UNLESSRDSYS (COND ((AND (EQ LEN 1) (ILEQ FIRSTCHAR \\MAXTHINCHAR) |\\OneCharAtomBase|) (* \;  "The one-character atoms live in well known places, no need to hash") (RETURN (COND ((IGREATERP FIRSTCHAR (CHARCODE "9")) (\\ADDBASE |\\OneCharAtomBase| (IDIFFERENCE FIRSTCHAR 10))) ((IGEQ FIRSTCHAR (CHARCODE "0")) (* \;  "These one-character atoms are integers") (IDIFFERENCE FIRSTCHAR (CHARCODE "0"))) (T (\\ADDBASE |\\OneCharAtomBase| FIRSTCHAR))))) ((AND (ILEQ FIRSTCHAR (CHARCODE "9")) (SETQ TEMP (\\PARSE.NUMBER BASE OFFST LEN FATP))) (* |;;| "\\PARSE.NUMBER returns a number or NIL") (RETURN TEMP)))) (RETURN (CL:VALUES (INTERN* BASE OFFST LEN FATP FATCHARSEENP *INTERLISP-PACKAGE* T))))) (CL:DEFVAR LITATOM-PACKAGE-CONVERSION-ENABLED NIL) (* |;;| "Initialization tables and functions") (CL:DEFPARAMETER CMLSYMBOLS.VARS '("*" "**" "***" "*APPLYHOOK*" "*BREAK-ON-WARNINGS*" "*DEBUG-IO*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*EVALHOOK*" "*FEATURES*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "+" "++" "+++" "-" "/" "//" "///" "ARRAY-DIMENSION-LIMIT" "ARRAY-RANK-LIMIT" "ARRAY-TOTAL-SIZE-LIMIT" "BOOLE-1" "BOOLE-2" "BOOLE-AND" "BOOLE-ANDC1" "BOOLE-ANDC2" "BOOLE-C1" "BOOLE-C2" "BOOLE-CLR" "BOOLE-EQV" "BOOLE-IOR" "BOOLE-NAND" "BOOLE-NOR" "BOOLE-ORC1" "BOOLE-ORC2" "BOOLE-SET" "BOOLE-XOR" "CALL-ARGUMENTS-LIMIT" "CHAR-BITS-LIMIT" "CHAR-CODE-LIMIT" "CHAR-CONTROL-BIT" "CHAR-FONT-LIMIT" "CHAR-HYPER-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "DOUBLE-FLOAT-EPSILON" "DOUBLE-FLOAT-NEGATIVE-EPSILON" "INTERNAL-TIME-UNITS-PER-SECOND" "LAMBDA-LIST-KEYWORDS" "LAMBDA-PARAMETERS-LIMIT" "LEAST-NEGATIVE-DOUBLE-FLOAT" "LEAST-NEGATIVE-LONG-FLOAT" "LEAST-NEGATIVE-SHORT-FLOAT" "LEAST-NEGATIVE-SINGLE-FLOAT" "LEAST-POSITIVE-DOUBLE-FLOAT" "LEAST-POSITIVE-LONG-FLOAT" "LEAST-POSITIVE-SHORT-FLOAT" "LEAST-POSITIVE-SINGLE-FLOAT" "LONG-FLOAT-EPSILON" "LONG-FLOAT-NEGATIVE-EPSILON" "MOST-NEGATIVE-DOUBLE-FLOAT" "MOST-NEGATIVE-FIXNUM" "MOST-NEGATIVE-LONG-FLOAT" "MOST-NEGATIVE-SHORT-FLOAT" "MOST-NEGATIVE-SINGLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-DOUBLE-FLOAT" "MOST-POSITIVE-FIXNUM" "MOST-POSITIVE-LONG-FLOAT" "MOST-POSITIVE-SHORT-FLOAT" "MOST-POSITIVE-SINGLE-FLOAT" "MULTIPLE-VALUES-LIMIT" "NIL" "OTHERWISE" "PI" "*PRINT-ESCAPE*" "SHORT-FLOAT-EPSILON" "SHORT-FLOAT-NEGATIVE-EPSILON" "SINGLE-FLOAT-EPSILON" "SINGLE-FLOAT-NEGATIVE-EPSILON" "T")) (CL:DEFPARAMETER CMLSYMBOLS.FNNAMES '("*" "+" "-" "/" "/=" "1+" "1-" "<" "<=" "=" ">" ">=" "ABS" "ACONS" "ACOS" "ACOSH" "ADJOIN" "ADJUST-ARRAY" "ADJUSTABLE-ARRAY-P" "ALPHA-CHAR-P" "ALPHANUMERICP" "APPEND" "APPLY" "APPLYHOOK" "APROPOS" "APROPOS-LIST" "AREF" "ARRAY-DIMENSION" "ARRAY-DIMENSIONS" "ARRAY-ELEMENT-TYPE" "ARRAY-HAS-FILL-POINTER-P" "ARRAY-IN-BOUNDS-P" "ARRAY-RANK" "ARRAY-ROW-MAJOR-INDEX" "ARRAY-TOTAL-SIZE" "ARRAYP" "ASH" "ASIN" "ASINH" "ASSOC" "ASSOC-IF" "ASSOC-IF-NOT" "ATAN" "ATANH" "ATOM" "BIT" "BIT-AND" "BIT-ANDC1" "BIT-ANDC2" "BIT-EQV" "BIT-IOR" "BIT-NAND" "BIT-NOR" "BIT-NOT" "BIT-ORC1" "BIT-ORC2" "BIT-VECTOR-P" "BIT-XOR" "BOOLE" "BOTH-CASE-P" "BOUNDP" "BREAK" "BUTLAST" "BYTE" "BYTE-POSITION" "BYTE-SIZE" "CAR" "CDR" "CAAR" "CADR" "CDAR" "CDDR" "CAAAR" "CAADR" "CADAR" "CADDR" "CDAAR" "CDADR" "CDDAR" "CDDDR" "CAAAAR" "CAAADR" "CAADAR" "CAADDR" "CADAAR" "CADADR" "CADDAR" "CADDDR" "CDAAAR" "CDAADR" "CDADAR" "CDADDR" "CDDAAR" "CDDADR" "CDDDAR" "CDDDDR" "CEILING" "CERROR" "CHAR" "CHAR-BIT" "CHAR-BITS" "CHAR-CODE" "CHAR-DOWNCASE" "CHAR-EQUAL" "CHAR-FONT" "CHAR-GREATERP" "CHAR-INT" "CHAR-LESSP" "CHAR-NAME" "CHAR-NOT-EQUAL" "CHAR-NOT-GREATERP" "CHAR-NOT-LESSP" "CHAR-UPCASE" "CHAR/=" "CHAR<" "CHAR<=" "CHAR=" "CHAR>" "CHAR>=" "CHARACTER" "CHARACTERP" "CIS" "CLEAR-INPUT" "CLEAR-OUTPUT" "CLOSE" "CLRHASH" "CODE-CHAR" "COERCE" "COMMONP" "COMPILE" "COMPILE-FILE" "COMPILED-FUNCTION-P" "COMPLEX" "COMPLEXP" "CONCATENATE" "CONJUGATE" "CONS" "CONSP" "CONSTANTP" "COPY-ALIST" "COPY-LIST" "COPY-READTABLE" "COPY-SEQ" "COPY-SYMBOL" "COPY-TREE" "COS" "COSH" "COUNT" "COUNT-IF" "COUNT-IF-NOT" "DECODE-FLOAT" "DECODE-UNIVERSAL-TIME" "DELETE" "DELETE-DUPLICATES" "DELETE-FILE" "DELETE-IF" "DELETE-IF-NOT" "DENOMINATOR" "DEPOSIT-FIELD" "DESCRIBE" "DIGIT-CHAR" "DIGIT-CHAR-P" "DIRECTORY" "DIRECTORY-NAMESTRING" "DISASSEMBLE" "DOCUMENTATION" "DPB" "DRIBBLE" "ED" "EIGHTH" "ELT" "ENCODE-UNIVERSAL-TIME" "ENDP" "ENOUGH-NAMESTRING" "EQ" "EQL" "EQUAL" "EQUALP" "ERROR" "EVAL" "EVALHOOK" "EVENP" "EVERY" "EXP" "EXPORT" "EXPT" "FBOUNDP" "FCEILING" "FFLOOR" "FIFTH" "FILE-AUTHOR" "FILE-LENGTH" "FILE-NAMESTRING" "FILE-POSITION" "FILE-WRITE-DATE" "FILL" "FILL-POINTER" "FIND" "FIND-ALL-SYMBOLS" "FIND-IF" "FIND-IF-NOT" "FIND-PACKAGE" "FIND-SYMBOL" "FINISH-OUTPUT" "FIRST" "FLOAT" "FLOAT-DIGITS" "FLOAT-PRECISION" "FLOAT-RADIX" "FLOAT-SIGN" "FLOATP" "FLOOR" "FMAKUNBOUND" "FORCE-OUTPUT" "FORMAT" "FOURTH" "FRESH-LINE" "FROUND" "FTRUNCATE" "FUNCALL" "FUNCTIONP" "GCD" "GENSYM" "GENTEMP" "GET" "GET-DECODED-TIME" "GET-DISPATCH-MACRO-CHARACTER" "GET-INTERNAL-REAL-TIME" "GET-INTERNAL-RUN-TIME" "GET-MACRO-CHARACTER" "GET-OUTPUT-STREAM-STRING" "GET-PROPERTIES" "GET-SETF-METHOD" "GET-SETF-METHOD-MULTIPLE-VALUE" "GET-UNIVERSAL-TIME" "GETF" "GETHASH" "GRAPHIC-CHAR-P" "HASH-TABLE-COUNT" "HASH-TABLE-P" "HOST-NAMESTRING" "IDENTITY" "IMAGPART" "IMPORT" "IN-PACKAGE" "INPUT-STREAM-P" "INSPECT" "INT-CHAR" "INTEGER-DECODE-FLOAT" "INTEGER-LENGTH" "INTEGERP" "INTERN" "INTERSECTION" "ISQRT" "KEYWORDP" "LAST" "LCM" "LDB" "LDB-TEST" "LDIFF" "LENGTH" "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "LIST" "LIST*" "LIST-ALL-PACKAGES" "LIST-LENGTH" "LISTEN" "LISTP" "LOAD" "LOG" "LOGAND" "LOGANDC1" "LOGANDC2" "LOGBITP" "LOGCOUNT" "LOGEQV" "LOGIOR" "LOGNAND" "LOGNOR" "LOGNOT" "LOGORC1" "LOGORC2" "LOGTEST" "LOGXOR" "LONG-SITE-NAME" "LOWER-CASE-P" "MACHINE-INSTANCE" "MACHINE-TYPE" "MACHINE-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "MAKE-ARRAY" "MAKE-BROADCAST-STREAM" "MAKE-CHAR" "MAKE-CONCATENATED-STREAM" "MAKE-DISPATCH-MACRO-CHARACTER" "MAKE-ECHO-STREAM" "MAKE-HASH-TABLE" "MAKE-LIST" "MAKE-PACKAGE" "MAKE-PATHNAME" "MAKE-RANDOM-STATE" "MAKE-SEQUENCE" "MAKE-STRING" "MAKE-STRING-INPUT-STREAM" "MAKE-STRING-OUTPUT-STREAM" "MAKE-SYMBOL" "MAKE-SYNONYM-STREAM" "MAKE-TWO-WAY-STREAM" "MAKUNBOUND" "MAP" "MAPC" "MAPCAN" "MAPCAR" "MAPCON" "MAPHASH" "MAPL" "MAPLIST" "MASK-FIELD" "MAX" "MEMBER" "MEMBER-IF" "MEMBER-IF-NOT" "MERGE" "MERGE-PATHNAMES" "MIN" "MINUSP" "MISMATCH" "MOD" "NAME-CHAR" "NAMESTRING" "NBUTLAST" "NCONC" "NINTERSECTION" "NINTH" "NOT" "NOTANY" "NOTEVERY" "NRECONC" "NREVERSE" "NSET-DIFFERENCE" "NSET-EXCLUSIVE-OR" "NSTRING-CAPITALIZE" "NSTRING-DOWNCASE" "NSTRING-UPCASE" "NSUBLIS" "NSUBST" "NSUBST-IF" "NSUBST-IF-NOT" "NSUBSTITUTE" "NSUBSTITUTE-IF" "NSUBSTITUTE-IF-NOT" "NTH" "NTHCDR" "NUMERATOR" "NULL" "NUMBERP" "NUNION" "ODDP" "OPEN" "OUTPUT-STREAM-P" "PACKAGE-NAME" "PACKAGE-NICKNAMES" "PACKAGE-SHADOWING-SYMBOLS" "PACKAGE-USE-LIST" "PACKAGE-USED-BY-LIST" "PACKAGEP" "PAIRLIS" "PARSE-INTEGER" "PARSE-NAMESTRING" "PATHNAME" "PATHNAME-DEVICE" "PATHNAME-DIRECTORY" "PATHNAME-HOST" "PATHNAME-NAME" "PATHNAME-TYPE" "PATHNAME-VERSION" "PATHNAMEP" "PEEK-CHAR" "PHASE" "PLUSP" "POSITION" "POSITION-IF" "POSITION-IF-NOT" "PPRINT" "PRIN1" "PRIN1-TO-STRING" "PRINC" "PRINC-TO-STRING" "PRINT" "PROBE-FILE" "PROCLAIM" "PROVIDE" "RANDOM" "RANDOM-STATE-P" "RASSOC" "RASSOC-IF" "RASSOC-IF-NOT" "RATIONAL" "RATIONALIZE" "RATIONALP" "READ" "READ-BYTE" "READ-CHAR" "READ-CHAR-NO-HANG" "READ-DELIMITED-LIST" "READ-FROM-STRING" "READ-LINE" "READ-PRESERVING-WHITESPACE" "READTABLEP" "REALPART" "REDUCE" "REM" "REMHASH" "REMOVE" "REMOVE-DUPLICATES" "REMOVE-IF" "REMOVE-IF-NOT" "REMPROP" "RENAME-FILE" "RENAME-PACKAGE" "REPLACE" "REQUIRE" "REST" "REVAPPEND" "REVERSE" "ROOM" "ROUND" "RPLACA" "RPLACD" "SBIT" "SCALE-FLOAT" "SCHAR" "SEARCH" "SECOND" "SET" "SET-CHAR-BIT" "SET-DIFFERENCE" "SET-DISPATCH-MACRO-CHARACTER" "SET-EXCLUSIVE-OR" "SET-MACRO-CHARACTER" "SET-SYNTAX-FROM-CHAR" "SEVENTH" "SHADOW" "SHADOWING-IMPORT" "SHORT-SITE-NAME" "SIGNUM" "SIMPLE-BIT-VECTOR-P" "SIMPLE-STRING-P" "SIMPLE-VECTOR-P" "SIN" "SINH" "SIXTH" "SLEEP" "SOFTWARE-TYPE" "SOFTWARE-VERSION" "SOME" "SORT" "SPECIAL-FORM-P" "SQRT" "STABLE-SORT" "STANDARD-CHAR-P" "STREAM-ELEMENT-TYPE" "STREAM-EXTERNAL-FORMAT" "STREAMP" "STRING" "STRING-CAPITALIZE" "STRING-CHAR-P" "STRING-DOWNCASE" "STRING-EQUAL" "STRING-GREATERP" "STRING-LEFT-TRIM" "STRING-LESSP" "STRING-NOT-EQUAL" "STRING-NOT-GREATERP" "STRING-NOT-LESSP" "STRING-RIGHT-TRIM" "STRING-TRIM" "STRING-UPCASE" "STRING/=" "STRING<" "STRING<=" "STRING=" "STRING>" "STRING>=" "STRINGP" "SUBLIS" "SUBSEQ" "SUBSETP" "SUBST" "SUBST-IF" "SUBST-IF-NOT" "SUBSTITUTE" "SUBSTITUTE-IF" "SUBSTITUTE-IF-NOT" "SUBTYPEP" "SVREF" "SXHASH" "SYMBOL-FUNCTION" "SYMBOL-NAME" "SYMBOL-PACKAGE" "SYMBOL-PLIST" "SYMBOL-VALUE" "SYMBOLP" "TAILP" "TAN" "TANH" "TENTH" "TERPRI" "THIRD" "TREE-EQUAL" "TRUENAME" "TRUNCATE" "TYPE-OF" "TYPEP" "UNEXPORT" "UNINTERN" "UNION" "UNREAD-CHAR" "UNUSE-PACKAGE" "UPPER-CASE-P" "USE-PACKAGE" "USER-HOMEDIR-PATHNAME" "VALUES" "VALUES-LIST" "VECTOR" "VECTOR-POP" "VECTOR-PUSH" "VECTOR-PUSH-EXTEND" "VECTORP" "WARN" "WRITE" "WRITE-BYTE" "WRITE-CHAR" "WRITE-LINE" "WRITE-STRING" "WRITE-TO-STRING" "Y-OR-N-P" "YES-OR-NO-P" "ZEROP")) (CL:DEFPARAMETER CMLSYMBOLS.DECLARATORS '("DECLARATION" "FTYPE" "FUNCTION" "IGNORE" "INLINE" "NOTINLINE" "OPTIMIZE" "SPECIAL" "TYPE")) (CL:DEFPARAMETER CMLSYMBOLS.TYPENAMES '("ARRAY" "ATOM" "BIGNUM" "BIT" "BIT-VECTOR" "CHARACTER" "COMMON" "COMPILED-FUNCTION" "COMPLEX" "CONS" "DOUBLE-FLOAT" "FIXNUM" "FLOAT" "FUNCTION" "HASH-TABLE" "INTEGER" "KEYWORD" "LIST" "LONG-FLOAT" "NIL" "NUMBER" "PACKAGE" "PATHNAME" "RANDOM-STATE" "RATIO" "RATIONAL" "READTABLE" "SATISFIES" "SEQUENCE" "SHORT-FLOAT" "SIMPLE-ARRAY" "SIMPLE-BIT-VECTOR" "SIMPLE-STRING" "SIMPLE-VECTOR" "SIGNED-BYTE" "SINGLE-FLOAT" "STANDARD-CHAR" "STREAM" "STRING" "STRING-CHAR" "SYMBOL" "T" "UNSIGNED-BYTE" "VECTOR")) (CL:DEFPARAMETER CMLSYMBOLS.MACROS '("AND" "ASSERT" "CASE" "CCASE" "CHECK-TYPE" "COND" "CTYPECASE" "DECF" "DEFCONSTANT" "DEFINE-MODIFY-MACRO" "DEFINE-SETF-METHOD" "DEFMACRO" "DEFPARAMETER" "DEFSETF" "DEFSTRUCT" "DEFTYPE" "DEFUN" "DEFVAR" "DO" "DO*" "DO-ALL-SYMBOLS" "DO-EXTERNAL-SYMBOLS" "DO-SYMBOLS" "DOLIST" "DOTIMES" "ECASE" "ETYPECASE" "INCF" "LOCALLY" "LOOP" "MULTIPLE-VALUE-BIND" "MULTIPLE-VALUE-LIST" "MULTIPLE-VALUE-SETQ" "OR" "POP" "PROG" "PROG*" "PROG1" "PROG2" "PSETF" "PSETQ" "PUSH" "PUSHNEW" "REMF" "RETURN" "ROTATEF" "SETF" "SHIFTF" "STEP" "TIME" "TRACE" "TYPECASE" "UNLESS" "UNTRACE" "WHEN" "WITH-INPUT-FROM-STRING" "WITH-OPEN-FILE" "WITH-OPEN-STREAM" "WITH-OUTPUT-TO-STRING")) (CL:DEFPARAMETER CMLSYMBOLS.SPECIALFORMS '("BLOCK" "CATCH" "COMPILER-LET" "DECLARE" "EVAL-WHEN" "FLET" "FUNCTION" "GO" "IF" "LABELS" "LAMBDA" "LET" "LET*" "MACROLET" "MULTIPLE-VALUE-CALL" "MULTIPLE-VALUE-PROG1" "PROGN" "PROGV" "QUOTE" "RETURN-FROM" "SETQ" "TAGBODY" "THE" "THROW" "UNWIND-PROTECT")) (CL:DEFPARAMETER CMLSYMBOLS.LAMBDA.LIST.KEYWORDS '("&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE")) (CL:DEFPARAMETER CMLSYMBOLS.SHARED '("+" "-" "/" "<" "<=" "=" ">" ">=" "&ALLOW-OTHER-KEYS" "&AUX" "&BODY" "&ENVIRONMENT" "&KEY" "&OPTIONAL" "&REST" "&WHOLE" "*APPLYHOOK*" "*BREAK-ON-WARNINGS*" "*DEBUG-IO*" "*DEFAULT-PATHNAME-DEFAULTS*" "*ERROR-OUTPUT*" "*EVALHOOK*" "*FEATURES*" "*LOAD-VERBOSE*" "*MACROEXPAND-HOOK*" "*MODULES*" "*PACKAGE*" "*PRINT-ARRAY*" "*PRINT-BASE*" "*PRINT-CASE*" "*PRINT-CIRCLE*" "*PRINT-ESCAPE*" "*PRINT-GENSYM*" "*PRINT-LENGTH*" "*PRINT-LEVEL*" "*PRINT-PRETTY*" "*PRINT-RADIX*" "*QUERY-IO*" "*RANDOM-STATE*" "*READ-BASE*" "*READ-DEFAULT-FLOAT-FORMAT*" "*READ-SUPPRESS*" "*READTABLE*" "*STANDARD-INPUT*" "*STANDARD-OUTPUT*" "*TERMINAL-IO*" "*TRACE-OUTPUT*" "ABS" "AND" "BIGNUM" "BIT" "BOUNDP" "BYTE" "BYTE-SIZE" "CAAAAR" "CAAADR" "CAAAR" "CAADAR" "CAADDR" "CAADR" "CAAR" "CADAAR" "CADADR" "CADAR" "CADDAR" "CADDDR" "CADDR" "CADR" "CAR" "CASE" "CDAAAR" "CDAADR" "CDAAR" "CDADAR" "CDADDR" "CDADR" "CDAR" "CDDAAR" "CDDADR" "CDDAR" "CDDDAR" "CDDDDR" "CDDDR" "CDDR" "CDR" "CLRHASH" "COERCE" "COMPLEX" "COND" "CONS" "DECLARE" "DEFMACRO" "DPB" "DRIBBLE" "ED" "EQ" "EQL" "EVENP" "EXPORT" "FLOAT" "GET" "GO" "IGNORE" "IMPORT" "INSPECT" "INTEGER" "LAST" "LDB" "LET" "LET*" "LIST" "LIST*" "LOGAND" "LOGNOT" "LOGXOR" "MAX" "MIN" "MINUSP" "NCONC" "NIL" "NOT" "NULL" "ODDP" "OPEN" "OR" "PACKAGE" "PATHNAME" "PROG" "PROG*" "PROG1" "PROG2" "PROGN" "QUOTE" "RANDOM-STATE" "RATIO" "READTABLEP" "REMHASH" "REMPROP" "RETURN" "ROUND" "RPLACA" "RPLACD" "SATISFIES" "SEQUENCE" "SET" "STRING" "STRING-EQUAL" "STREAM" "STREAMP" "T" "TAILP" "THE" "TIME" "TRACE" "TYPE" "TYPEP" "UNTRACE" "WRITE") (* |;;;| "Symbols shared by the Interlisp and Lisp packages.") ) (CL:DEFUN LITATOM.EXISTS (STRING) (AND (ATOMHASH#PROBES STRING) T)) (CL:DEFVAR LITATOM-PACKAGE-CONVERSION-TABLE '(("CL::" NIL "LISP" :INTERNAL) ("CL:" ("CL:FLG" "CL:MAKE-SYMBOL" "CL:COPY-SYMBOL" "CL:INTERN" "CL:MAKE-KEYWORD" "CL:GENTEMP" "CL:KEYWORDP") "LISP" :EXTERNAL) (":" NIL "KEYWORD" :EXTERNAL) ("CONDITIONS::" NIL "CONDITIONS" :INTERNAL) ("CONDITIONS:" NIL "CONDITIONS" :EXTERNAL) ("XCL::" NIL "XCL" :INTERNAL) ("XCL:" NIL "XCL" :EXTERNAL) ("SI::" NIL "SI" :INTERNAL) ("SI:" NIL "SI" :EXTERNAL) ("COMPILER::" NIL "COMPILER" :INTERNAL) ("COMPILER:" NIL "COMPILER" :EXTERNAL) ("FASL::" NIL "FASL" :INTERNAL) ("FASL:" NIL "FASL" :EXTERNAL))) (CL:DEFUN NAMESTRING-CONVERSION-CLAUSE (BASE OFFSET LEN FATP) (* |;;;| "Check whether a given namestring has a prefix that would indicate membership in a package. If so, return the first clause out of the conversion table that matched. Otherwise, return NIL.") (DECLARE (CL:SPECIAL LITATOM-PACKAGE-CONVERSION-TABLE)) (CL:DOLIST (CONVERSION-LIST LITATOM-PACKAGE-CONVERSION-TABLE NIL) (LET* ((PREFIX (CL:FIRST CONVERSION-LIST)) (EXCEPTIONS (CL:SECOND CONVERSION-LIST)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (COND ((AND (IGREATERP LEN PREFIX-LENGTH) (\\STRING-EQUALBASE PREFIX BASE OFFSET PREFIX-LENGTH FATP) (NOT (|for| X |in| EXCEPTIONS |suchthat| (\\STRING-EQUALBASE X BASE OFFSET LEN FATP)))) (RETURN CONVERSION-LIST)))))) (CL:DEFUN CONVERT-LITATOM (ATOM) (* |;;| "Conditionally move an INTERLISP litatom into a package based on the naming conventions in LITATOM-PACKAGE-CONVERSION-TABLE.") (LET* ((BASE (|ffetch| (CL:SYMBOL PNAMEBASE) |of| ATOM)) (LEN (|ffetch| (CL:SYMBOL PNAMELENGTH) |of| ATOM)) (FATP (|ffetch| (CL:SYMBOL FATPNAMEP) |of| ATOM)) (CLAUSE (OR (NAMESTRING-CONVERSION-CLAUSE BASE 1 LEN FATP) (CL:RETURN-FROM CONVERT-LITATOM NIL))) (PREFIX (CL:FIRST CLAUSE)) (CL:PACKAGE-NAME (CL:THIRD CLAUSE)) (WHERE (CL:FOURTH CLAUSE)) (PREFIX-LENGTH (|ffetch| (STRINGP LENGTH) PREFIX))) (\\LITATOM.EATCHARS ATOM PREFIX-LENGTH) (* \; "Take off the pseudo-package prefix. This makes the symbol inaccessible in INTERLISP (because not rehashed).") (COND (CL:PACKAGE-NAME (* \;  " Symbol is interned, put it in the package.") (INTERN-LITATOM ATOM (CL:FIND-PACKAGE CL:PACKAGE-NAME) :WHERE WHERE))) T)) (CL:DEFUN CONCOCT-SYMBOL (STRING) (* |;;| "Create a symbol in the LISP package. Conflicting symbols must already have been converted and defined by CONVERT-LITATOM. Given a string, if a symbol by that name exists in INTERLISP (and doesn't conflict) we INTERN-LITATOM it into the LISP package, making that its home. Otherwise, we create a new one.") (DECLARE (CL:SPECIAL *LISP-PACKAGE* *INTERLISP-PACKAGE* CMLSYMBOLS.SHARED)) (LET (ILSYM CLSYM) (COND ((CL:MULTIPLE-VALUE-BIND (SYM WHERE) (CL:FIND-SYMBOL STRING *LISP-PACKAGE*) (CL:WHEN (EQ WHERE :INTERNAL) (EXPORT SYM *LISP-PACKAGE*)) (SETQ CLSYM SYM) WHERE) (* \;  "The CL symbol already exists. Make it external. If the symbol is shared, import it into IL.") (CL:WHEN (CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL) (IMPORT CLSYM *INTERLISP-PACKAGE*))) (* |;;| "From this point down, the CL symbol doesn't yet exist.") ((CL:MEMBER STRING CMLSYMBOLS.SHARED :TEST 'STREQUAL) (* \; "The symbol is shared. Create it in CL and import it to IL. NOTE that the symbol should never be found in IL.") (COND ((CL:FIND-SYMBOL STRING *INTERLISP-PACKAGE*) (CL:ERROR "Shared symbol found in IL: ~S" STRING) (* |;;| "(intern-litatom ilsym *lisp-package* :where :external)") ) (T (LET ((SYM (CL:INTERN STRING *LISP-PACKAGE*))) (EXPORT SYM *LISP-PACKAGE*) (IMPORT SYM *INTERLISP-PACKAGE*))))) (T (* \;  "Symbol doesn't exist, so just create it in LISP.") (EXPORT (CL:INTERN STRING *LISP-PACKAGE*) *LISP-PACKAGE*))))) (CL:DEFUN TRANSFER-SYMBOL (FROM TO) "Move the function and plist definition cells of a symbol onto another, leaving name and value alone." (CL:SETF (CL:SYMBOL-PLIST TO) (CL:SYMBOL-PLIST FROM)) (CL:SETF (CL:SYMBOL-FUNCTION TO) (CL:SYMBOL-FUNCTION FROM))) (CL:DEFUN INTERN-LITATOM (ATOM PACKAGE &KEY WHERE) "Tag a litatom with a package. Add it to the package hashtable. Handle keywords appropriately. Return the symbol." (CL:WHEN (AND (CL::%PACKAGE-EXTERNAL-ONLY PACKAGE) (EQ WHERE :INTERNAL)) (ERROR (CONCAT "Attempting to INTERN-LITATOM " ATOM "internal in external-only package " PACKAGE))) (ADD-SYMBOL (CL:IF (EQ WHERE :INTERNAL) (CL::%PACKAGE-INTERNAL-SYMBOLS PACKAGE) (CL::%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)) ATOM) (CL:SETF (CL:SYMBOL-PACKAGE ATOM) PACKAGE) (CL:IF (EQ *KEYWORD-PACKAGE* PACKAGE) (SET ATOM ATOM)) ATOM) (CL:DEFUN \\LITATOM.EATCHARS (LITATOM N) (LET* ((PNBASE (|fetch| (LITATOM PNAMEBASE) |of| LITATOM)) (LEN (- (|fetch| (PNAMEBASE PNAMELENGTH) |of| PNBASE) N))) (COND ((|fetch| (LITATOM FATPNAMEP) |of| LITATOM) (ERROR (CONCAT "Can't move fat LITATOM |" LITATOM "| into LISP package"))) (T (|for| I |from| 0 |to| LEN |as| J |from| N |do| (\\PUTBASETHIN PNBASE I (\\GETBASETHIN PNBASE J))))) (|replace| (PNAMEBASE PNAMELENGTH) |of| PNBASE |with| LEN)) LITATOM) (CL:DEFUN PACKAGE-INIT (&OPTIONAL (CONVERT? T)) "Clear, make structures of, initialize & convert symbols to, and enable use of the symbol package system." (PACKAGE-CLEAR) (PACKAGE-MAKE) (PACKAGE-HIERARCHY-INIT CONVERT?) (PACKAGE-ENABLE) T) (CL:DEFUN PACKAGE-CLEAR () "Clear the global package data (used by FIND-PACKAGE) and reset the globals that hold the existing packages." (DECLARE (CL:SPECIAL *PACKAGE-FROM-NAME* *PACKAGE-FROM-INDEX* *PACKAGE* *LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE*)) (CLRHASH *PACKAGE-FROM-NAME*) (CL:DOTIMES (I (ADD1 *TOTAL-PACKAGES-LIMIT*)) (CL:SETF (CL:AREF *PACKAGE-FROM-INDEX* I) NIL)) (SETQ *PACKAGE* NIL) (SETQ *LISP-PACKAGE* NIL) (SETQ *KEYWORD-PACKAGE* NIL) (SETQ *INTERLISP-PACKAGE* NIL) T) (CL:DEFUN PACKAGE-MAKE () "Create, but do not fill with symbols, the base packages that need to exist. Also enables the package qualifier characters in the readtables and saves the old definitions of \\READ.SYMBOL and \\MKATOM." (DECLARE (CL:SPECIAL *LISP-PACKAGE* *KEYWORD-PACKAGE* *INTERLISP-PACKAGE* *PACKAGE* HASHTABLE-SIZE-LIMIT)) (SETQ *INTERLISP-PACKAGE* (CL:MAKE-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL") :PREFIX-NAME "IL" :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS 32749)) (SETQ *LISP-PACKAGE* (CL:MAKE-PACKAGE "LISP" :USE NIL :NICKNAMES '("CL" "COMMON-LISP") :PREFIX-NAME "CL" :EXTERNAL-SYMBOLS 1173)) (CL:MAKE-PACKAGE "CONDITIONS" :USE "LISP" :PREFIX-NAME "CONDITIONS") (CL:MAKE-PACKAGE "XEROX-COMMON-LISP" :USE '("LISP" "CONDITIONS") :NICKNAMES '("XCL") :PREFIX-NAME "XCL") (CL:MAKE-PACKAGE "SYSTEM" :USE "LISP" :NICKNAMES '("SYS" "SI") :PREFIX-NAME "SI") (CL:MAKE-PACKAGE "USER" :USE "LISP") (SETQ *KEYWORD-PACKAGE* (CL:MAKE-PACKAGE "KEYWORD" :USE NIL :EXTERNAL-ONLY T :EXTERNAL-SYMBOLS 96) ) (CL:MAKE-PACKAGE "COMPILER" :USE "LISP") (CL:MAKE-PACKAGE "FASL" :USE "LISP") (CL:MAKE-PACKAGE "XCL-USER" :USE '("LISP" "XCL")) (MOVD '\\READ.SYMBOL '\\OLD.READ.SYMBOL) (MOVD '\\MKATOM '\\OLD.MKATOM) T) (CL:DEFUN PACKAGE-HIERARCHY-INIT (&OPTIONAL (CONVERT? NIL)) (* |;;;| "Fill all the initial system packages with their proper symbols, moving litatoms into appropriate places and such. If convert? is non-nil then symbols whose pnames have fake package qualifiers, like cl:length, will be converted IN PLACE to remove the qualifier. If conversion takes place you cannot fully disable the package system.") (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *KEYWORD-PACKAGE* CMLSYMBOLS.LAMBDA.LIST.KEYWORDS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.MACROS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.VARS)) (* |;;| "Fill the INTERLISP package with its symbols.") (MAPATOMS #'(CL:LAMBDA (ATOM) (CL:IF (OR (NULL CONVERT?) (NULL (CONVERT-LITATOM ATOM))) (INTERN-LITATOM ATOM *INTERLISP-PACKAGE* :WHERE :EXTERNAL)))) (* |;;| "Fill the LISP package with its symbols.") (CL:DOLIST (I (APPEND CMLSYMBOLS.VARS CMLSYMBOLS.FNNAMES CMLSYMBOLS.DECLARATORS CMLSYMBOLS.TYPENAMES CMLSYMBOLS.MACROS CMLSYMBOLS.SPECIALFORMS CMLSYMBOLS.LAMBDA.LIST.KEYWORDS)) (CONCOCT-SYMBOL I)) T) (CL:DEFUN PACKAGE-ENABLE (&OPTIONAL (PACKAGE *INTERLISP-PACKAGE*)) "Turn on the package system, making PACKAGE the current one and redefining \\READ.SYMBOL and \\MKATOM appropriatly." (DECLARE (CL:SPECIAL *INTERLISP-PACKAGE* *PACKAGE* *OLD-INTERLISP-READ-ENVIRONMENT* *PER-EXEC-VARIABLES*)) (|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| *INTERLISP-PACKAGE*) (COND ((FIND-READTABLE "LISP") (READTABLEPROP (FIND-READTABLE "LISP") 'PACKAGECHAR (CHARCODE ":")))) (COND ((FIND-READTABLE "INTERLISP") (READTABLEPROP (FIND-READTABLE "INTERLISP") 'PACKAGECHAR (CHARCODE ":")))) (COND ((FIND-READTABLE "XCL") (READTABLEPROP (FIND-READTABLE "XCL") 'PACKAGECHAR (CHARCODE ":")))) (RPAQ? *PER-EXEC-VARIABLES* NIL) (CL:PUSHNEW '(*PACKAGE* (COND ((CL:PACKAGEP *PACKAGE*) *PACKAGE*) (T (PROMPTPRINT "Invalid package, reset to LISP") (SETQ *PACKAGE* (CL:FIND-PACKAGE "LISP"))))) *PER-EXEC-VARIABLES* :TEST 'CL:EQUAL) (CL:SETF *DEFAULT-MAKEFILE-ENVIRONMENT* '(:READTABLE "XCL" :PACKAGE "INTERLISP")) (MOVD '\\NEW.READ.SYMBOL '\\READ.SYMBOL) (MOVD '\\NEW.MKATOM '\\MKATOM) (CL:SETF *PACKAGE* PACKAGE) T) (CL:DEFUN PACKAGE-DISABLE () "Turn off the package system and restore the old definitions of \\\\READ.SYMBOL and \\MKATOM. After disabling, symbols interned under the package system will not be EQ to symbols of the same name reread." (MOVD '\\OLD.READ.SYMBOL '\\READ.SYMBOL) (MOVD '\\OLD.MKATOM '\\MKATOM) (SETQ *PACKAGE* NIL) (|replace| REPACKAGE |of| *OLD-INTERLISP-READ-ENVIRONMENT* |with| NIL) (READTABLEPROP (FIND-READTABLE "LISP") 'PACKAGECHAR 0) (READTABLEPROP (FIND-READTABLE "INTERLISP") 'PACKAGECHAR 0) (READTABLEPROP (FIND-READTABLE "XCL") 'PACKAGECHAR 0) T) (* |;;| "A hack for initialization") (CL:DEFUN ID (X) X) (PUTPROPS PACKAGE-STARTUP FILETYPE CL:COMPILE-FILE) (PUTPROPS PACKAGE-STARTUP MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "INTERLISP")) (* |;;| "Initialize package system, plus functions needed in llpackage at init time") (DECLARE\: DONTEVAL@LOAD DOCOPY (MOVD? 'EQ 'EQL) (MOVD? 'LENGTH 'CL:LENGTH) (MOVD? 'ID 'CL:IDENTITY) (MOVD? 'ID 'REMOVE-COMMENTS) (PACKAGE-INIT) ) (PUTPROPS PACKAGE-STARTUP COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/PAINTW b/sources/PAINTW new file mode 100644 index 00000000..e046f76a --- /dev/null +++ b/sources/PAINTW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "16-Jul-99 15:49:37" |{DSK}medley3.5>sources>PAINTW.;3| 16985 |changes| |to:| (FNS PAINTW) |previous| |date:| "17-Jan-94 14:38:09" |{DSK}medley3.5>sources>PAINTW.;1|) ; Copyright (c) 1986, 1990, 1992, 1994, 1999 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT PAINTWCOMS) (RPAQQ PAINTWCOMS ((FNS PAINTW PAINTW.READMODE PAINTW.READBRUSHSHAPE PAINTW.READBRUSHSIZE PAINTW.READBRUSHSHADE PAINTW.READBRUSHTEXTURE PAINTW.READ.AND.SAVE.SHADE PAINTW.CACHE.SHADE PAINTW.SHADE.LABEL PAINTW.READCOMMAND) (COMS (INITVARS (PAINTW.SHADES)) (GLOBALVARS PAINTW.SHADES)) (DECLARE\: DONTEVAL@LOAD DOCOPY (P (PAINTW.CACHE.SHADE BLACKSHADE) (PAINTW.CACHE.SHADE GRAYSHADE) (PAINTW.CACHE.SHADE HIGHLIGHTSHADE))) (INITVARS (PAINTCOMMANDBRUSH '(ROUND 2)) (PAINTCOMMANDMODE 'PAINT) (PAINTCOMMANDMENU) (PAINTCOMMANDSHADE BLACKSHADE) (PAINTSIZEMENU) (PAINTSHAPEMENU) (PAINTSHADEMENU) (PAINTMODEMENU) (PAINTWCURSOR)))) (DEFINEQ (PAINTW (LAMBDA (WINDOW) (* \; "Edited 16-Jul-99 15:49 by rmk:") (* \; "Edited 16-Jul-99 15:48 by rmk:") (* \;  "Edited 17-Jan-94 14:27 by sybalsky:mv:envos") (* |;;;| "allows the user to paint with the cursor") (* |;;;| "should make sure cursor has moved or a button has change before proceeding with the inner loop.") (* |;;;| "has some of the stuff to allow the brush to be an arbitrary bitmap but not all.") (SETQ WINDOW (\\INSUREWINDOW WINDOW)) (|printout| PROMPTWINDOW "Left button paints; Middle button erases. Right button pops up a command menu. To stop, select the QUIT command.") (RESETLST (RESETSAVE NIL (LIST 'CURSOR (CURSOR))) (PROG (DS BITSPERPIXEL MASKSHADE BRUSH MASK HOTX HOTY (PREVX -65535) (PREVY -65535) (PREVBUT -5)) (TOTOPW WINDOW) (* \;  "look for a previously stored brush.") (COND ((SETQ BRUSH (WINDOWPROP WINDOW 'PAINTBRUSH)) (SETQ PAINTCOMMANDMODE (CAR BRUSH)) (SETQ PAINTCOMMANDSHADE (CADR BRUSH)) (SETQ PAINTCOMMANDBRUSH (CADDR BRUSH)))) (SETQ DS (|fetch| (WINDOW DSP) |of| WINDOW)) (SETQ BITSPERPIXEL (OR (|fetch| (SCREEN SCDEPTH) |of| (FETCH (WINDOW SCREEN ) OF WINDOW)) (|fetch| (SCREEN SCBITSPERPIXEL) |of| (FETCH (WINDOW SCREEN) OF WINDOW)))) (SETQ MASKSHADE (SELECTQ BITSPERPIXEL (1 BLACKSHADE) (MASK.1\'S 0 BITSPERPIXEL))) BRUSHLP (SETQ BRUSH (COND ((BITMAPP PAINTCOMMANDBRUSH)) (T (\\GETBRUSH PAINTCOMMANDBRUSH)))) (SETQ HOTX (HALF (|fetch| (BITMAP BITMAPWIDTH) |of| BRUSH))) (SETQ HOTY (HALF (|fetch| (BITMAP BITMAPHEIGHT) |of| BRUSH))) (SETQ PAINTWCURSOR (|create| CURSOR CUIMAGE _ BRUSH CUMASK _ BRUSH CUHOTSPOTX _ HOTX CUHOTSPOTY _ HOTY CUDATA _ NIL |using| PAINTWCURSOR)) (CURSOR PAINTWCURSOR) (COND ((NOT (EQ BITSPERPIXEL 1)) (CURSORCOLOR PAINTCOMMANDSHADE))) (* \;  "BRUSH can change if PAINTW is to color screen. *") (SETQ BRUSH (|fetch| (CURSOR CUIMAGE) |of| PAINTWCURSOR)) (SETQ MASK (|fetch| (CURSOR CUMASK) |of| PAINTWCURSOR)) PAINTLP (GETMOUSESTATE) (COND ((AND (IEQP PREVX LASTMOUSEX) (IEQP PREVY LASTMOUSEY) (IEQP PREVBUT LASTMOUSEBUTTONS)) (* |;;| "No movement, and no button changes.") ) ((LASTMOUSESTATE RIGHT) (SETQ PREVX LASTMOUSEX) (SETQ PREVY LASTMOUSEY) (SETQ PREVBUT LASTMOUSEBUTTONS) (COND ((OR (INSIDE? (DSPCLIPPINGREGION NIL DS) (LASTMOUSEX DS) (LASTMOUSEY DS)) (NOT (WHICHW LASTMOUSEX LASTMOUSEY))) (* \;  "inside the interior, give command menu") (SELECTQ (PAINTW.READCOMMAND) (SHADE (SETQ PAINTCOMMANDSHADE (OR (PAINTW.READBRUSHTEXTURE BITSPERPIXEL) PAINTCOMMANDSHADE)) (GO BRUSHLP)) (MODE (SETQ PAINTCOMMANDMODE (OR (PAINTW.READMODE) PAINTCOMMANDMODE)) (GO BRUSHLP)) (SHAPE (RPLACA PAINTCOMMANDBRUSH (OR (PAINTW.READBRUSHSHAPE) (CAR PAINTCOMMANDBRUSH))) (GO BRUSHLP)) (SIZE (RPLACA (CDR PAINTCOMMANDBRUSH) (OR (PAINTW.READBRUSHSIZE) (CADR PAINTCOMMANDBRUSH))) (GO BRUSHLP)) (QUIT (RETURN)) NIL)) (T (* \; "do the window menu") (DOWINDOWCOM (WHICHW LASTMOUSEX LASTMOUSEY))))) ((AND (LASTMOUSESTATE LEFT) (OR (EQ PAINTCOMMANDMODE 'REPLACE) (NOT (EQ PAINTCOMMANDSHADE MASKSHADE)))) (* \;  "painting in grey is slightly harder.") (SETQ PREVX LASTMOUSEX) (SETQ PREVY LASTMOUSEY) (SETQ PREVBUT LASTMOUSEBUTTONS) (COND ((EQ PAINTCOMMANDMODE 'REPLACE) (* \; "erase what is there now") (BITBLT MASK 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'INPUT 'ERASE) (* \; "put in grey") (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'MERGE 'PAINT PAINTCOMMANDSHADE)) (T (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'MERGE PAINTCOMMANDMODE PAINTCOMMANDSHADE)))) ((LASTMOUSESTATE (OR MIDDLE LEFT)) (SETQ PREVX LASTMOUSEX) (SETQ PREVY LASTMOUSEY) (SETQ PREVBUT LASTMOUSEBUTTONS) (BITBLT BRUSH 0 0 DS (IDIFFERENCE (LASTMOUSEX DS) HOTX) (IDIFFERENCE (LASTMOUSEY DS) HOTY) NIL NIL 'INPUT (COND ((LASTMOUSESTATE MIDDLE) 'ERASE) (T PAINTCOMMANDMODE)))) (T (SETQ PREVX LASTMOUSEX) (SETQ PREVY LASTMOUSEY) (SETQ PREVBUT LASTMOUSEBUTTONS))) (GO PAINTLP)) (WINDOWPROP WINDOW 'PAINTBRUSH (LIST PAINTCOMMANDMODE PAINTCOMMANDSHADE (COPY PAINTCOMMANDBRUSH )))))) (paintw.readmode (lambda nil (* |rrb| " 1-DEC-82 17:29") (menu (cond ((|type?| menu paintmodemenu) paintmodemenu) (t (setq paintmodemenu (|create| menu items _ '((replace 'replace "the screen bits are replaced by the brush bits" ) (invert 'invert "the screen bits inverted whereever brush bits are" ) (add 'paint "the brush bits are added to the bits on the screen" ))))))))) (paintw.readbrushshape (lambda nil (* |rrb| " 1-DEC-82 17:29") (menu (cond ((|type?| menu paintshapemenu) paintshapemenu) (t (setq paintshapemenu (|create| menu items _ '(diagonal vertical horizontal square round)))))) )) (paintw.readbrushsize (lambda nil (* |rrb| " 1-DEC-82 17:30") (menu (cond ((|type?| menu paintsizemenu) paintsizemenu) (t (setq paintsizemenu (|create| menu items _ '(16 8 4 2 1)))))))) (paintw.readbrushshade (lambda nil (* |rrb| " 7-Oct-85 14:30") (* |reads| \a |shade|) (prog (shade) (* i |removed| |the| 16\x16 |case| |because| paintw |uses| |merge| |mode| |and|  |the| |alignment| |of| 16\x16 |texture| |is| |off| |in| |that| |case.|  |When| |fixed| |at| |the| |menu| |item| ("16x16 shade"  (quote |16X16|) "Allows creation of a 16 bits by 16 bits shade")) (selectq (setq shade (menu (|create| menu centerflg _ t title _ "Choose shade" items _ (append (|for| fillpat |in| paintw.shades |collect| (list (car fillpat) (kwote (cadr fillpat)) "changes filling to this pattern" )) '(("4 x 4 shade" '|4X4| "Allows creation of a 4 bits by 4 bits shade" ))) menubordersize _ 1))) (|4X4| (return (paintw.read.and.save.shade))) (|16X16| (return (paintw.read.and.save.shade t))) (return shade))))) (paintw.readbrushtexture (lambda nil (* |gbn:| "25-Jan-86 17:15") (selectq (bitsperpixel \\cursordestination) (1 (paintw.readbrushshade)) (menu (colormenu (bitsperpixel \\cursordestination)))))) (paintw.read.and.save.shade (lambda (16x16flg) (* |rrb| " 4-Oct-85 11:34") (* |reads| \a |new| |filling,| |confirms| |it| |with| |the| |user| |and| |adds|  |it| |to| paintw.shades) (prog (shade) (cond ((null (setq shade (editshade (cond (16x16flg (bitmapcreate 16 16)))))) (* |user| |aborted|) (return nil))) (paintw.cache.shade shade) (return shade)))) (paintw.cache.shade (lambda (shade) (* |rrb| " 4-Oct-85 11:32") (* |adds| \a |shade| |to| |the|  |global| |cache.|) (or (|for| entry |in| paintw.shades |when| (equal (cadr entry) shade) |do| (return t)) (cond (paintw.shades (nconc1 paintw.shades (list (paintw.shade.label shade) shade))) (t (setq paintw.shades (list (list (paintw.shade.label shade) shade))) 'added))))) (paintw.shade.label (lambda (filling) (* |rrb| " 7-Oct-85 14:29") (* |creates| \a |bitmap| |label| |which| |fills| |it| |with| |the| |texture|  filling.) (prog ((bm (bitmapcreate (plus 8 (stringwidth "4 x 4 shade" menufont)) (fontprop menufont 'height)))) (bltshade filling bm) (return bm)))) (paintw.readcommand (lambda nil (* |gbn:| "25-Jan-86 16:35") (menu (cond ((|type?| menu paintcommandmenu) paintcommandmenu) (t (setq paintcommandmenu (|create| menu items _ '((|SetMode| 'mode "Allows specification of how new bits are merged" ) (|SetShade| 'shade "Allows specification of new shade.") (|SetShape| 'shape "Allows specification of brush shape") (|SetSize| 'size "Allows specification of the brush size" ) (quit 'quit "Exits painting mode"))))))))) ) (RPAQ? PAINTW.SHADES ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PAINTW.SHADES) ) (DECLARE\: DONTEVAL@LOAD DOCOPY (PAINTW.CACHE.SHADE BLACKSHADE) (PAINTW.CACHE.SHADE GRAYSHADE) (PAINTW.CACHE.SHADE HIGHLIGHTSHADE) ) (RPAQ? PAINTCOMMANDBRUSH '(ROUND 2)) (RPAQ? PAINTCOMMANDMODE 'PAINT) (RPAQ? PAINTCOMMANDMENU ) (RPAQ? PAINTCOMMANDSHADE BLACKSHADE) (RPAQ? PAINTSIZEMENU ) (RPAQ? PAINTSHAPEMENU ) (RPAQ? PAINTSHADEMENU ) (RPAQ? PAINTMODEMENU ) (RPAQ? PAINTWCURSOR ) (PUTPROPS PAINTW COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1992 1994 1999)) (DECLARE\: DONTCOPY (FILEMAP (NIL (1316 16344 (PAINTW 1326 . 9487) (PAINTW.READMODE 9489 . 10467) (PAINTW.READBRUSHSHAPE 10469 . 10851) (PAINTW.READBRUSHSIZE 10853 . 11194) (PAINTW.READBRUSHSHADE 11196 . 13001) ( PAINTW.READBRUSHTEXTURE 13003 . 13282) (PAINTW.READ.AND.SAVE.SHADE 13284 . 13907) (PAINTW.CACHE.SHADE 13909 . 14692) (PAINTW.SHADE.LABEL 14694 . 15127) (PAINTW.READCOMMAND 15129 . 16342))))) STOP \ No newline at end of file diff --git a/sources/PASSWORDS b/sources/PASSWORDS new file mode 100644 index 00000000..7936d194 --- /dev/null +++ b/sources/PASSWORDS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 21:02:21" {DSK}local>lde>lispcore>sources>PASSWORDS.;2 22217 changes to%: (VARS PASSWORDSCOMS) previous date%: " 3-May-88 12:15:19" {DSK}local>lde>lispcore>sources>PASSWORDS.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PASSWORDSCOMS) (RPAQQ PASSWORDSCOMS ([COMS (FNS LOGIN SETPASSWORD \INTERNAL/GETPASSWORD \INTERNAL/SETPASSWORD \LOGIN.READ PROVIDE.PROMPTING.WINDOW \ADJUST.USERNAME \ENCRYPT.PWD \DECRYPT.PWD) [INITVARS (LOGINPASSWORDS (HASHARRAY 8)) (\GETPASSWORD.LOCK (CREATE.MONITORLOCK "GetPassword")) (DEFAULTREGISTRY) (\AFTERLOGINFNS) (\PROC.READY T) (UNSCHEDULEDPROMPTREGION '(262 466 500 100] (GLOBALVARS LOGINPASSWORDS USERNAME \GETPASSWORD.LOCK DEFAULTREGISTRY \AFTERLOGINFNS UNSCHEDULEDPROMPTREGION \PROC.READY TTYREGIONOFFSETS \TTYREGIONOFFSETSPTR) (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (PROP DMACRO EMPASSWORDLOC) (MACROS \DECRYPT.PWD.CHAR))) (P (MOVD? 'NILL 'CLBUFS] (COMS (* PROMPTFORWORD) (FNS PROMPTFORWORD \PROMPTFORWORDBIN \PROMPTFORWORDERASE \PROMPTFORWORDBS \PROMPTFORWORDRETYPE) (INITVARS (\PROMPTFORWORDTTBL NIL) (\PROMPTFORWORD.CURSOR)) (GLOBALVARS \PROMPTFORWORDTTBL \PROMPTFORWORD.CURSOR)) (LOCALVARS . T))) (DEFINEQ (LOGIN (LAMBDA (HOST FLG DIRECTORY MSG) (* ; "Edited 3-May-88 11:54 by bvm") (* ;; "Forces a login at HOST optionally connecting to DIRECTORY, and returns the name logged in. MSG is optional message string to print before asking") (CAR (\INTERNAL/GETPASSWORD (SELECTQ HOST ((NIL |NS::| GV) HOST) (OR (CANONICAL.HOSTNAME HOST) (ERROR "Host not found" HOST))) (NEQ FLG (QUOTE QUIET)) DIRECTORY MSG NIL (AND (STRPOS ":" HOST) (QUOTE NS))))) ) (SETPASSWORD (LAMBDA (HOST USER PASSWORD DIRECTORY) (* bvm%: "27-Feb-86 14:17") (CAR (\INTERNAL/SETPASSWORD (AND HOST (OR (CANONICAL.HOSTNAME HOST) HOST)) (CONS (COND (DIRECTORY (* ; "Directories need to be atomic for ASSOC") (MKATOM DIRECTORY)) (USER (MKSTRING USER))) (MKSTRING PASSWORD)) DIRECTORY))) ) (\INTERNAL/GETPASSWORD (LAMBDA (HOST ALWAYSASK DIRECTORY MSG DEFAULTNAME OSTYPE) (* bvm%: "27-Sep-85 10:45") (* ;; "returns (name . password) with which to login (or connect if DIRECTORY given) at HOST, performing an alto-style login if necessary, or if ALWAYSASK is true. MSG is optional message string to print before asking") (COND (HOST (COND ((NOT (LITATOM HOST)) (SETQ HOST (MKATOM HOST)))) (COND ((AND (NOT OSTYPE) (STRPOS ":" HOST)) (SETQ OSTYPE (QUOTE NS)))))) (PROG ((INFO (GETHASH HOST LOGINPASSWORDS)) NAME/PASS) (COND ((AND (NOT ALWAYSASK) (SETQ NAME/PASS (COND (DIRECTORY (COND ((STRINGP DIRECTORY) (SETQ DIRECTORY (MKATOM (U-CASE DIRECTORY))))) (ASSOC DIRECTORY (CDR INFO))) (T (CAR INFO))))) (* ; "We already have login info") (RETURN NAME/PASS))) (RETURN (\INTERNAL/SETPASSWORD HOST NIL DIRECTORY ALWAYSASK MSG DEFAULTNAME OSTYPE)))) ) (\INTERNAL/SETPASSWORD (LAMBDA (HOST NEWNAME/PASS DIRECTORY ALWAYSASK MSG DEFAULTNAME OSTYPE) (* bvm%: "27-Sep-85 10:42") (LET (RESULT INFOCHANGED) (SETQ RESULT (WITH.MONITOR \GETPASSWORD.LOCK (* ;; "Don't grab the monitor til now, since we don't really care if what we fetched above was about to change") (CAR (NLSETQ (PROG ((INFO (GETHASH HOST LOGINPASSWORDS)) PASSWORDADDR NAME/PASS DISKNAME PWD NSINFO NEWNAME) (COND (DIRECTORY (COND ((NOT INFO) (SETQ INFO (PUTHASH HOST (CONS) LOGINPASSWORDS)))) (COND ((NOT NEWNAME/PASS) (SETQ NEWNAME/PASS (COND ((NULL ALWAYSASK) (* ; "First time, guess that no password is needed") (CONS DIRECTORY "")) (T (\LOGIN.READ HOST DIRECTORY MSG T OSTYPE)))))) (COND (NEWNAME/PASS (COND ((SETQ NAME/PASS (ASSOC DIRECTORY (CDR INFO))) (SETQ NEWNAME/PASS (RPLACD NAME/PASS (\ENCRYPT.PWD (CONCAT (CDR NEWNAME/PASS)))))) (T (RPLACD INFO (CONS (SETQ NEWNAME/PASS (CONS (CAR NEWNAME/PASS) (\ENCRYPT.PWD (CONCAT (CDR NEWNAME/PASS))))) (CDR INFO))))))) (RETURN NEWNAME/PASS)) (T (COND ((EQ (SYSTEMTYPE) (QUOTE D)) (OR OSTYPE (SETQ OSTYPE (COND (HOST (GETOSTYPE HOST)) (T (QUOTE LOCAL))))) (COND ((NEQ (SETQ PASSWORDADDR (EMPASSWORDLOC)) 0) (SETQ PASSWORDADDR (EMPOINTER PASSWORDADDR)))))) (COND ((EQ OSTYPE (QUOTE NS)) (SETQ NSINFO (GETHASH (QUOTE |NS::|) LOGINPASSWORDS)))) (SETQ DISKNAME (\ADJUST.USERNAME (USERNAME NIL T T) OSTYPE)) (COND (NEWNAME/PASS (SETQ NAME/PASS (CONS (CAR NEWNAME/PASS) (CONCAT (CDR NEWNAME/PASS)))) (SETQ INFOCHANGED T)) ((AND NSINFO (NULL ALWAYSASK)) (* ; "For NS hosts, there is a uniform login. Try that first") (SETQ NAME/PASS (CONS (CAAR NSINFO) (\DECRYPT.PWD (CDAR NSINFO))))) ((PROGN (SETQ DEFAULTNAME (COND ((NOT DEFAULTNAME) (OR (CAAR (OR NSINFO INFO)) DISKNAME)) (T (\ADJUST.USERNAME DEFAULTNAME OSTYPE)))) (AND (NULL ALWAYSASK) DISKNAME PASSWORDADDR (OR (EQ DEFAULTNAME DISKNAME) (EQ (ALPHORDER DEFAULTNAME DISKNAME UPPERCASEARRAY) (QUOTE EQUAL))) (IGREATERP (NCHARS (SETQ PWD (GetBcplString PASSWORDADDR))) 0))) (* ;; "Try using the global password if DEFAULTNAME matches the global name. Match is case-insensitive, of course") (SETQ NAME/PASS (CONS DEFAULTNAME (SETQ PWD (SELECTQ OSTYPE (UNIX (L-CASE PWD)) (TENEX (U-CASE PWD)) PWD))))) (T (SETQ NAME/PASS (\LOGIN.READ HOST DEFAULTNAME MSG NIL OSTYPE)) (SETQ INFOCHANGED T))) (SETQ NEWNAME (CAR NAME/PASS)) (COND (INFOCHANGED (COND ((EQ OSTYPE (QUOTE NS)) (* ; "Don't touch alto login") (COND ((OR (NULL NSINFO) (EQ (CAAR NSINFO) NEWNAME)) (FRPLACA (OR NSINFO (PUTHASH (QUOTE |NS::|) (CONS) LOGINPASSWORDS)) NAME/PASS)))) ((EQ NEWNAME DISKNAME) (AND PASSWORDADDR (SetBcplString PASSWORDADDR (CDR NAME/PASS))))) (COND ((OR (NULL HOST) (NULL DISKNAME) (AND (NEQ OSTYPE (QUOTE NS)) PASSWORDADDR (EQ (\GETBASE PASSWORDADDR 0) 0))) (* ; "There was no password before, or user forced login") (COND ((GETD (QUOTE SETUSERNAME)) (SETUSERNAME (COND (NEWNAME (COND ((EQ OSTYPE (QUOTE NS)) (\ADJUST.USERNAME NEWNAME (QUOTE LOCAL))) (T NEWNAME))) (T ""))) (AND PASSWORDADDR (SetBcplString PASSWORDADDR (COND (NEWNAME (CDR NAME/PASS)) (T "")))))))))) (COND ((NULL HOST) (CLRHASH LOGINPASSWORDS) (COND ((NULL NEWNAME) (RETURN NIL))) (SETQ INFO))) (\ENCRYPT.PWD (CDR NAME/PASS)) (FRPLACA (OR INFO (PUTHASH HOST (CONS) LOGINPASSWORDS)) NAME/PASS))) (RETURN NAME/PASS)))))) (COND (INFOCHANGED (for FN in \AFTERLOGINFNS do (* ; "Report change to any user packages that cache user info") (APPLY* FN HOST (CAR RESULT))))) RESULT)) ) (\LOGIN.READ (LAMBDA (HOST DEFAULTNAME MSG CONNECTFLG OSTYPE) (* bvm%: "15-Aug-84 16:02") (PROG ((PROMPT (COND ((NEQ OSTYPE (QUOTE NS)) "Login: ") (HOST (* ; "This would get to be a pretty long line") " (terminate input with ) Login: ") (T "Login ( to terminate): "))) (HELPFN " You are being asked for a user name and password for login. Type to accept the given user name, or to back up over it, or type a new name followed by . ") (TERMINATIONS (COND ((EQ OSTYPE (QUOTE NS)) (CHARCODE (CR LF))) (T (* ; "default") NIL)))) (COND (CONNECTFLG (SETQ PROMPT (CONCAT "Connect password for " DEFAULTNAME ": ")) (SETQ HELPFN "Type followed by the password for the directory. "))) (COND (HOST (SETQ PROMPT (CONCAT "{" HOST "} " PROMPT)))) (COND (MSG (SETQ PROMPT (CONCAT MSG (CONSTANT (CHARACTER (CHARCODE EOL))) PROMPT)))) (RETURN (RESETLST (PROVIDE.PROMPTING.WINDOW "Password prompter") (FRESHLINE T) (PROG1 (RESETBUFS (COND (CONNECTFLG (CONS DEFAULTNAME (PROMPTFORWORD PROMPT NIL NIL T (QUOTE *) T TERMINATIONS))) (T (PROG ((NAME (PROMPTFORWORD PROMPT DEFAULTNAME HELPFN T NIL T TERMINATIONS))) (COND ((AND HOST DEFAULTREGISTRY (SELECTQ OSTYPE ((NIL IFS) T) NIL) (NOT (STRPOS "." NAME))) (PRIN1 "." T) (PRIN1 DEFAULTREGISTRY T) (SETQ NAME (CONCAT NAME "." DEFAULTREGISTRY)))) (RETURN (CONS (MKATOM NAME) (PROMPTFORWORD " (password) " NIL NIL T (QUOTE *)))))))) (TERPRI T)))))) ) (PROVIDE.PROMPTING.WINDOW (LAMBDA (TITLE REGION) (* kbr%: "16-Jan-86 17:23") (* ;;; "Called under RESETLST -- makes sure this process has a tty window; if it doesn't, makes a dramatic one which will be closed on exit.") (COND ((AND (NOT (TTY.PROCESSP)) (NOT \PROC.READY)) (* ; "Called before world has woken up, so mouse is not available. Use brute force") (RESETSAVE (TTY.PROCESS (THIS.PROCESS))))) (COND ((AND \WINDOWWORLD (DISPLAYSTREAMP (GETSTREAM T (QUOTE OUTPUT))) (OR (NOT (HASTTYWINDOWP)) (NOT (OPENWP (WFROMDS (TTYDISPLAYSTREAM) T))))) (* ; "Make a nice tty window and clean up afterwards") (PROG ((W (CREATEW (OR REGION (PROGN (SETQ \TTYREGIONOFFSETSPTR (OR (CDR \TTYREGIONOFFSETSPTR) TTYREGIONOFFSETS)) (SETQ REGION (CREATEREGION (IPLUS (CAAR \TTYREGIONOFFSETSPTR) (fetch (REGION LEFT) of UNSCHEDULEDPROMPTREGION)) (IPLUS (CDAR \TTYREGIONOFFSETSPTR) (fetch (REGION BOTTOM) of UNSCHEDULEDPROMPTREGION)) (fetch (REGION WIDTH) of UNSCHEDULEDPROMPTREGION) (fetch (REGION HEIGHT) of UNSCHEDULEDPROMPTREGION))))) (OR TITLE "Special input window") 12)) STR) (RESETSAVE NIL (LIST (QUOTE CLOSEW) W)) (RESETSAVE (TTYDISPLAYSTREAM W)) (RESETSAVE NIL (LIST (QUOTE WINDOWPROP) W (QUOTE CLOSEFN) NIL)) (WINDOWPROP W (QUOTE CLOSEFN) (FUNCTION (LAMBDA (WINDOW PROC) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW (QUOTE PROCESS))) (PROCESSP PROC)) (PROCESS.APPLY PROC (FUNCTION ERROR!)) (QUOTE DON'T)))))) (COND ((NOT (TTY.PROCESSP)) (RELMOVETO (LRSH (IDIFFERENCE (fetch (REGION WIDTH) of REGION) (STRINGWIDTH (SETQ STR "-> Click here, please <-") W)) 1) 0 W) (printout T STR T T) (SELECTQ (MACHINETYPE) (DANDELION (RINGBELLS)) NIL) (until (WAIT.FOR.TTY 30000) do (FLASHWINDOW W 1)))) (RETURN W))))) ) (\ADJUST.USERNAME (LAMBDA (NAME OSTYPE) (* bvm%: "17-May-85 19:03") (COND ((AND NAME (NEQ (NCHARS NAME) 0)) (* ; "Don't do this for blank name, as occurs after DLion boot") (SELECTQ OSTYPE ((NIL IFS) (COND ((AND DEFAULTREGISTRY (NOT (STRPOS "." NAME))) (SETQ NAME (PACK* NAME "." DEFAULTREGISTRY))))) (PROGN (LET (POS) (COND ((AND DEFAULTREGISTRY (SETQ POS (STRPOS "." NAME))) (* ; "For folks who login at the alto exec using a registry, get rid of it") (SETQ NAME (SUBSTRING NAME 1 (SUB1 POS)))))) (SELECTQ OSTYPE (UNIX (SETQ NAME (L-CASE NAME))) (NS (COND ((AND CH.DEFAULT.DOMAIN CH.DEFAULT.ORGANIZATION (NOT (STRPOS (QUOTE %:) NAME))) (SETQ NAME (CONCAT NAME (QUOTE %:) CH.DEFAULT.DOMAIN (QUOTE %:) CH.DEFAULT.ORGANIZATION))))) NIL))) NAME))) ) (\ENCRYPT.PWD (LAMBDA (STR) (* bvm%: " 3-NOV-83 22:09") (* ;;; "Destructively disguises the characters of STR so that passwords are not stored in clear text anywhere. Decode with \DECRYPT.PWD, or macro \DECRYPT.PWD.CHAR") (for I from 1 do (RPLCHARCODE STR I (LOGXOR (OR (NTHCHARCODE STR I) (RETURN STR)) 73)))) ) (\DECRYPT.PWD (LAMBDA (STR) (* bvm%: " 3-NOV-83 22:09") (* ; "undoes \ENCRYPT.PWD. Easy, it being its own inverse") (\ENCRYPT.PWD (CONCAT STR))) ) ) (RPAQ? LOGINPASSWORDS (HASHARRAY 8)) (RPAQ? \GETPASSWORD.LOCK (CREATE.MONITORLOCK "GetPassword")) (RPAQ? DEFAULTREGISTRY ) (RPAQ? \AFTERLOGINFNS ) (RPAQ? \PROC.READY T) (RPAQ? UNSCHEDULEDPROMPTREGION '(262 466 500 100)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LOGINPASSWORDS USERNAME \GETPASSWORD.LOCK DEFAULTREGISTRY \AFTERLOGINFNS UNSCHEDULEDPROMPTREGION \PROC.READY TTYREGIONOFFSETS \TTYREGIONOFFSETSPTR) ) (DECLARE%: EVAL@COMPILE DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED") (PUTPROPS EMPASSWORDLOC DMACRO [LAMBDA NIL (* lmm "24-MAR-83 06:46") (fetch (IFPAGE UserPswdAddr) of \InterfacePage]) (DECLARE%: EVAL@COMPILE (PUTPROPS \DECRYPT.PWD.CHAR MACRO ((CHAR) (LOGXOR CHAR 73))) ) (* "END EXPORTED DEFINITIONS") ) (MOVD? 'NILL 'CLBUFS) (* PROMPTFORWORD) (DEFINEQ (PROMPTFORWORD (LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION TERMINCHARS.LST KEYBD.CHANNEL) (* lmm "16-Jan-86 18:07") (DECLARE (SPECVARS TERMINCHARS.LST ECHO.CHANNEL DONTECHOTYPEIN.FLG)) (COND ((NOT (TERMTABLEP \PROMPTFORWORDTTBL)) (* ; "Initializes the special readtable on the first time through.") (SETQ \PROMPTFORWORDTTBL (bind (TTBL _ (COPYTERMTABLE (QUOTE ORIG))) for CHAR from 0 to 31 do (SELCHARQ CHAR ((EOL ESCAPE SPACE LF TAB)) (ECHOCHAR CHAR (QUOTE INDICATE) TTBL)) finally (PROGN (ECHOMODE NIL TTBL) (CONTROL T TTBL) (RETURN TTBL)))))) (RESETLST (RESETSAVE (SETTERMTABLE \PROMPTFORWORDTTBL)) (PROG ((CHARBUFFER (COND (CANDIDATE.STR (DREVERSE (CHCON CANDIDATE.STR))))) TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CANDIDATATE.LENGTH CHAR BEGUNTYPING? RUBBING? ?HELPMSGTRIEDP ?HELPMSGLIST TIMER) (DECLARE (SPECVARS TTYD X0Y0 TIMELIMITEXPIRED? BELLBEENHEARD? CHARBUFFER RUBBING?)) (COND ((EQMEMB (QUOTE TTY) URGENCY.OPTION) (* ; "If we're going to switch the TTY process, better do it before looking for TTYDISPLAYSTREAM etc.") (OR (TTY.PROCESSP) (RESETSAVE (TTY.PROCESS (THIS.PROCESS)))) (AND \PROMPTFORWORD.CURSOR (RESETSAVE (CURSOR \PROMPTFORWORD.CURSOR)))) (T (OR (FIXP URGENCY.OPTION) (SELECTQ URGENCY.OPTION ((NIL T) T) NIL) (\ILLEGAL.ARG URGENCY.OPTION)))) (RESETSAVE (TTYDISPLAYSTREAM (SETQ ECHO.CHANNEL (GETSTREAM (OR ECHO.CHANNEL T) (QUOTE OUTPUT))))) (* ; "Normalize the echo channel.") (SETQ TTYD (DISPLAYSTREAMP ECHO.CHANNEL)) (COND ((AND DONTECHOTYPEIN.FLG (NEQ DONTECHOTYPEIN.FLG T)) (SETQ DONTECHOTYPEIN.FLG (COND ((EQ (NCHARS DONTECHOTYPEIN.FLG) 1) (NTHCHARCODE DONTECHOTYPEIN.FLG 1)) (T T))))) (COND ((NULL TERMINCHARS.LST) (SETQ TERMINCHARS.LST (CHARCODE (EOL ESCAPE SPACE LF TAB)))) ((CHARCODEP TERMINCHARS.LST) (SETQ TERMINCHARS.LST (LIST TERMINCHARS.LST))) ((OR (NLISTP TERMINCHARS.LST) (for C in TERMINCHARS.LST bind CONVERTIBLEP unless (CHARCODEP C) do (COND ((AND (OR (LITATOM C) (STRINGP C)) (EQ 1 (NCHARS C))) (SETQ CONVERTIBLEP T)) (T (RETURN T))) finally (COND (CONVERTIBLEP (* ; "List not all charcodes, but all are at least charcode like") (SETQ TERMINCHARS.LST (MAPCAR TERMINCHARS.LST (FUNCTION (LAMBDA (C) (OR (FIXP C) (CHCON1 C)))))))))) (\ILLEGAL.ARG TERMINCHARS.LST))) (COND (KEYBD.CHANNEL (SETQ KEYBD.CHANNEL (\INSTREAMARG KEYBD.CHANNEL)))) (COND (URGENCY.OPTION (SETQ TIMER (SETUPTIMER (OR (FIXP URGENCY.OPTION) 0) NIL (QUOTE SECONDS))))) (* ;; "Now ready to begin. Print the prompt, gather input") PROMPTAGAIN (COND (PROMPT.STR (PRIN3 PROMPT.STR ECHO.CHANNEL) (PRIN3 " " ECHO.CHANNEL))) (COND (TTYD (SETQ X0Y0 (create POSITION XCOORD _ (DSPXPOSITION NIL TTYD) YCOORD _ (DSPYPOSITION NIL TTYD))))) (COND (CHARBUFFER (* ;; "If there is input, e.g. the candidate string, echo it. This is the one place calling \PROMPTFORWORDRETYPE that doesn't want the line erased first.") (\PROMPTFORWORDRETYPE))) (until (OR (NULL (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD URGENCY.OPTION TIMER))) (FMEMB CHAR TERMINCHARS.LST)) do (COND ((SELECTQ (GETSYNTAX CHAR \PROMPTFORWORDTTBL) (CHARDELETE (COND (CHARBUFFER (SETQ BEGUNTYPING? T) (\PROMPTFORWORDBS)) (T (SETQ RUBBING?))) NIL) (LINEDELETE (COND (CHARBUFFER (COND ((NEQ DONTECHOTYPEIN.FLG T) (\PROMPTFORWORDERASE))) (SETQ BEGUNTYPING? T) (SETQ CHARBUFFER)) (T (SETQ RUBBING?))) NIL) (RETYPE (COND (CHARBUFFER (COND ((NEQ DONTECHOTYPEIN.FLG T) (\PROMPTFORWORDERASE))) (\PROMPTFORWORDRETYPE)) (T (SETQ RUBBING?))) NIL) (WORDDELETE (COND (CHARBUFFER (SETQ BEGUNTYPING? T) (bind (SPACEP _ (SYNTAXP (CAR CHARBUFFER) (QUOTE WORDSEPR) \PROMPTFORWORDTTBL)) do (\PROMPTFORWORDBS) (COND ((NULL CHARBUFFER) (RETURN))) (SETQ CHAR (CAR CHARBUFFER)) (COND ((NOT SPACEP) (COND ((SYNTAXP CHAR (QUOTE WORDSEPR) \PROMPTFORWORDTTBL) (RETURN)))) ((NOT (SYNTAXP CHAR (QUOTE WORDSEPR) \PROMPTFORWORDTTBL)) (SETQ SPACEP NIL))))) (T (SETQ RUBBING?))) NIL) (CNTRLV (COND ((NOT DONTECHOTYPEIN.FLG) (* ;; "Well, so echo the ^V SO THAT THE LOSER CAN SEE THAT HE'S IN THE STATE OF WAITING FOR THE NEXT CHARACTER AFTER A ^V") (COND ((AND RUBBING? (NOT TTYD)) (BOUT ECHO.CHANNEL (CHARCODE \)) (SETQ RUBBING?))) (PRIN3 (CHARACTER CHAR) ECHO.CHANNEL))) (COND ((NULL (SETQ CHAR (\PROMPTFORWORDBIN KEYBD.CHANNEL TTYD URGENCY.OPTION TIMER T))) (RETURN T))) (COND ((AND TTYD (NOT DONTECHOTYPEIN.FLG) (NULL (DSPRUBOUTCHAR TTYD CHAR))) (* ;; "Well, we tried to erase the ^V so that the typed-in charcter could be echoed, but apparently the ^V was split between lines.") (\PROMPTFORWORDERASE) (\PROMPTFORWORDRETYPE))) T) (COND ((EQ CHAR (CHARCODE ?)) (FRESHLINE ECHO.CHANNEL) (COND ((AND GENERATE?LIST.FN (NOT ?HELPMSGTRIEDP)) (SETQ ?HELPMSGLIST (OR (STRINGP GENERATE?LIST.FN) (APPLY* GENERATE?LIST.FN PROMPT.STR CANDIDATE.STR))) (SETQ ?HELPMSGTRIEDP T)) ((NOT ?HELPMSGTRIEDP) (SETQ ?HELPMSGLIST (QUOTE ??)))) (COND ((LISTP ?HELPMSGLIST) (PRIN3 (QUOTE {) ECHO.CHANNEL) (PRIN3 (CONSTANT (CHARACTER (CHARCODE SPACE))) ECHO.CHANNEL) (MAPC ?HELPMSGLIST (FUNCTION (LAMBDA (X) (PRIN1 X ECHO.CHANNEL) (PRIN3 (CONSTANT (CHARACTER (CHARCODE SPACE))) ECHO.CHANNEL)))) (PRIN3 (QUOTE }) ECHO.CHANNEL)) (T (PRIN1 ?HELPMSGLIST ECHO.CHANNEL) (* ; "FOO we'd really like this FRESHLINE to be just a MOVETO some initial position."))) (FRESHLINE ECHO.CHANNEL) (GO PROMPTAGAIN)) (T T))) (* ; "If the SELCHARQ does't select out any of its 'special' characters, then just fall through here") (COND ((AND (NOT BEGUNTYPING?) CHARBUFFER) (* ;; "This is the case of the CANDIDATE.STR having been proffered, but the user starts typing something else.") (COND ((EQ CHAR (CHARCODE SPACE)) (* ;; "Special kludge for benefit of those with old space-terminating habits: If there is a candidate string, and the first thing you do is type a space, then the space terminates even if it isn't a member of TERMINCHARS.LST") (RETURN))) (COND ((NOT DONTECHOTYPEIN.FLG) (* ; "Don't need to do anything if type-in isn't being echoed") (\PROMPTFORWORDERASE))) (SETQ CHARBUFFER))) (push CHARBUFFER CHAR) (SETQ BEGUNTYPING? T) (COND ((NEQ DONTECHOTYPEIN.FLG T) (* ; "Well, so echo the typed-in character already!") (COND ((AND RUBBING? (NOT TTYD)) (PRIN3 (QUOTE \) ECHO.CHANNEL) (SETQ RUBBING?))) (BOUT ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG CHAR))))))) (SETQ CHARBUFFER (COND (TIMELIMITEXPIRED? (* ; "Ha, we overflowed the time limit.") (COND (CANDIDATE.STR (CONCAT CANDIDATE.STR)))) (CHARBUFFER (CONCATCODES (DREVERSE CHARBUFFER))))) (\CARET.DOWN ECHO.CHANNEL) (RETURN CHARBUFFER)))) ) (\PROMPTFORWORDBIN (LAMBDA (INSTREAM DISPLAYECHOSTREAM URGENCY.OPTION TIMER) (* lmm "16-Jan-86 18:06") (* ;; "Takes in one character from the KEYBD.CHANNEL") (DECLARE (USEDFREE TERMINCHARS.LST TIMELIMITEXPIRED? BELLBEENHEARD?)) (PROG ((WAITINTERVAL.secs 15) (TTYWAITLIMIT (if URGENCY.OPTION then (if BELLBEENHEARD? then 30000 else 0))) (BROADURGENCY? (AND URGENCY.OPTION (NOT (FIXP URGENCY.OPTION)))) CHAR READABLE (KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))) NEXTROUND (if BROADURGENCY? then (SETQ TIMER (SETUPTIMER WAITINTERVAL.secs TIMER (QUOTE SECONDS)))) LP (if (SETQ READABLE (OR INSTREAM (NEQ KEYSTREAM \KEYBOARD.STREAM) (WAIT.FOR.TTY TTYWAITLIMIT))) then (* ; "Ready to read") (if (SETQ CHAR (if (NULL INSTREAM) then (if (READP KEYSTREAM T) then (BIN KEYSTREAM)) elseif (READP INSTREAM T) then (BIN INSTREAM) elseif (\EOFP INSTREAM) then (CAR TERMINCHARS.LST))) then (RETURN CHAR)) (if DISPLAYECHOSTREAM then (* ; "\TTYBACKGROUND so that a caret will flash") (\TTYBACKGROUND) else (BLOCK))) (if (AND TIMER (TIMEREXPIRED? TIMER (QUOTE SECONDS))) then (if (AND URGENCY.OPTION (NOT BROADURGENCY?)) then (SETQ TIMELIMITEXPIRED? T) (RETURN)) else (SETQ TTYWAITLIMIT 30000) (AND READABLE (GO LP))) (if (NULL BELLBEENHEARD?) then (SETQ BELLBEENHEARD? T) (SELECTQ (MACHINETYPE) (DANDELION (RINGBELLS)) NIL)) (FLASHWINDOW DISPLAYECHOSTREAM NIL 350) (if (AND BROADURGENCY? (TTY.PROCESSP)) then (SETQ WAITINTERVAL.secs (IMIN (LLSH WAITINTERVAL.secs 1) (TIMES 2 60)))) (* ; "Double the wait interval time (the time between 'flashings') up to about 2 minutes, so that it doesn't become obnoxious") (GO NEXTROUND))) ) (\PROMPTFORWORDERASE (LAMBDA NIL (* JonL "29-Jul-84 21:45") (DECLARE (USEDFREE TTYD X0Y0 ECHO.CHANNEL)) (* ;; "Called whenever the CHARBUFFER is being cleared out, or when it is necessary to retype the whole series of input characters") (* ;; "If TTYD is non-null, then it is guaranteed to be a display stream. X0Y0 is a POSITION where the user started typing in (or where the default CANDIDATE was started) Erase that portion of the screen.") (if TTYD then (PROG ((Y (DSPYPOSITION NIL TTYD)) (|0X| (fetch XCOORD of X0Y0)) (|0Y| (fetch YCOORD of X0Y0))) (MOVETO |0X| |0Y| TTYD) (DSPCLEOL TTYD |0X|) (if (NOT (IEQP |0Y| Y)) then (* ; "Foobar, how can you tell if the stupid window has been scrolling?") (DSPCLEOL TTYD (DSPLEFTMARGIN NIL TTYD) (IDIFFERENCE Y (FONTDESCENT TTYD)) (IDIFFERENCE |0Y| Y)))) else (TERPRI ECHO.CHANNEL))) ) (\PROMPTFORWORDBS (LAMBDA NIL (* bvm%: " 4-Jan-85 14:51") (DECLARE (USEDFREE TTYD DONTECHOTYPEIN.FLG RUBBING? ECHO.CHANNEL CHARBUFFER)) (PROG (C (CH (pop CHARBUFFER))) (COND ((NEQ DONTECHOTYPEIN.FLG T) (SETQ C (OR DONTECHOTYPEIN.FLG CH)) (COND (TTYD (COND ((NULL (DSPRUBOUTCHAR TTYD C)) (\PROMPTFORWORDERASE) (\PROMPTFORWORDRETYPE)))) (T (COND ((NOT RUBBING?) (PRIN3 (QUOTE \) ECHO.CHANNEL) (SETQ RUBBING? T))) (BOUT ECHO.CHANNEL C))))) (RETURN C))) ) (\PROMPTFORWORDRETYPE (LAMBDA NIL (* lmm "10-Jan-86 01:54") (DECLARE (USEDFREE DONTECHOTYPEIN.FLG ECHO.CHANNEL CHARBUFFER)) (* ;; "Retypes input as seen so far. All callers except one have already done a \PROMPTFORWORDERASE so the ECHO.CHANNEL will be positioned correctly.") (if (NEQ DONTECHOTYPEIN.FLG T) then (for CHAR in (REVERSE CHARBUFFER) do (\OUTCHAR ECHO.CHANNEL (OR DONTECHOTYPEIN.FLG CHAR))))) ) ) (RPAQ? \PROMPTFORWORDTTBL NIL) (RPAQ? \PROMPTFORWORD.CURSOR ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PROMPTFORWORDTTBL \PROMPTFORWORD.CURSOR) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS PASSWORDS COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1720 11134 (LOGIN 1730 . 2175) (SETPASSWORD 2177 . 2486) (\INTERNAL/GETPASSWORD 2488 . 3345) (\INTERNAL/SETPASSWORD 3347 . 6780) (\LOGIN.READ 6782 . 8208) (PROVIDE.PROMPTING.WINDOW 8210 . 9907) (\ADJUST.USERNAME 9909 . 10660) (\ENCRYPT.PWD 10662 . 10979) (\DECRYPT.PWD 10981 . 11132)) ( 12077 21880 (PROMPTFORWORD 12087 . 18533) (\PROMPTFORWORDBIN 18535 . 20170) (\PROMPTFORWORDERASE 20172 . 21008) (\PROMPTFORWORDBS 21010 . 21465) (\PROMPTFORWORDRETYPE 21467 . 21878))))) STOP \ No newline at end of file diff --git a/sources/PMAP b/sources/PMAP new file mode 100644 index 00000000..894de04b --- /dev/null +++ b/sources/PMAP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 3-Feb-2002 14:11:02" {DSK}medley3.5>sources>PMAP.;2 58154 changes to%: (FNS \PAGED.GETNEXTBUFFER) previous date%: "19-Jan-93 11:00:45" {DSK}medley3.5>sources>PMAP.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993, 2002 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PMAPCOMS) (RPAQQ PMAPCOMS ( (* ;  "Page mapping primitives. This file is shared with VAX.") (FNS ADDMAPBUFFER \ALLOCMAPBUFFER CHECKBUFFERREFVAL CLEARMAP \WRITEOUTBUFFERS \CLEARMAP DOPMAP FINDPTRSBUFFER FORGETPAGES \GETMAPBUFFER LOCKMAP MAPAFTERCLOSE MAPBUFFERCOUNT MAPPAGE MAPWORD \RELEASEBUFFER RELEASINGVMEMPAGE RESTOREMAP UNLOCKMAP \MAPPAGE \COLLECTDIRTYBUFS \SETIODIRTY) (FNS WORDCONTENTS SETWORDCONTENTS /SETWORDCONTENTS WORDOFFSET) (EXPORT (PROP BYTEMACRO WORDCONTENTS SETWORDCONTENTS WORDOFFSET)) (COMS (ADDVARS (DEFAULTMAPFILE) (SYSTEMBUFFERLIST) (MAPEMPTYBUFFERLIST)) (GLOBALVARS SYSTEMBUFFERLIST MAPEMPTYBUFFERLIST DEFAULTMAPFILE)) [COMS (* ;  "Functions for page-mapped devices") (DECLARE%: DONTCOPY (EXPORT (MACROS \RELEASECPAGE))) (FNS \MAKE.PMAP.DEVICE \PAGEDBACKFILEPTR \PAGEDSETFILEPTR \PAGED.INCFILEPTR \PAGEDGETFILEPTR \PAGEDGETEOFPTR \PAGEDREADP \PAGEDEOFP \PAGED.GETNEXTBUFFER \PAGED.FORCEOUTPUT \UPDATEOF \READPAGES \WRITEPAGES) (FNS \SETEOF \PAGED.SETEOFPTR \NEWLENGTHIS) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ; "For TEXTOFD") (P (PUTD '\PAGEDBIN (GETD '\BUFFERED.BIN) T) (PUTD '\PAGEDPEEKBIN (GETD '\BUFFERED.PEEKBIN) T] (FNS PPBUFS) (DECLARE%: DONTCOPY (RECORDS BUFFER) EVAL@COMPILE (MACROS GETBUFFERPTR CHECKBUFFERREF CPBUFFERP BUFFERINUSEP UNDIRTY DIRTYP) (I.S.OPRS INBUFS)) (INITRECORDS BUFFER) (LOCALVARS . T))) (* ; "Page mapping primitives. This file is shared with VAX.") (DEFINEQ (ADDMAPBUFFER [LAMBDA (TEMP ERRORFLG) (* rrb "16-DEC-79 15:54") (* ;; "old entry left arond for compatibility") NIL]) (\ALLOCMAPBUFFER [LAMBDA NIL (* lmm "10-MAR-83 23:19") (* ;; "allocates a new buffer. The new buffer will be put on SYSTEMBUFFERLIST which is used by the GC when releasing a buffer.") (* ;  "This should be the only function that creates BUFFERs.") (SETQ SYSTEMBUFFERLIST (create BUFFER VMEMPAGE _ (NCREATE 'VMEMPAGEP) SYSNEXT _ SYSTEMBUFFERLIST]) (CHECKBUFFERREFVAL [LAMBDA (BUFF) (* lmm "10-MAR-83 23:23") (* ;; "checks the reference bit of a buffer descriptor and sets it if it is off. Also returns the value of the buffer page ptr so that it will be on the stack and therefore not be reset if a gc occurs.") (UNINTERRUPTABLY (COND ((fetch NOREFERENCE of BUFF) (\DELREF (fetch VMEMPAGE of BUFF)) (replace NOREFERENCE of BUFF with NIL))) (fetch VMEMPAGE of BUFF))]) (CLEARMAP [LAMBDA (FILE PAGES RELEASE) (* hdj " 5-Jun-86 11:53") (* ;;  "Clears the usermapped PAGES of FILE from the buffers. RELEASE is for compatibility with MAXC.") (COND [(EQ FILE T) (* ; "T denotes all files") (ERROR "T flag no longer supported for CLEARMAP") (if NIL then (for STREAM in \OPENFILES do (\CLEARMAP STREAM PAGES T] (T (PROG NIL (\CLEARMAP (OR (\GETSTREAM FILE NIL T) (RETURN)) PAGES T]) (\WRITEOUTBUFFERS [LAMBDA (BUFFER STREAM) (* bvm%: "16-May-84 14:32") (* ;; "writes the contents of a buffer back out to the file they are mapped from. BUFFER can be a single buffer or a list of buffers containing ascending contiguous pages") (COND ((LISTP BUFFER) (\WRITEPAGES STREAM (fetch FILEPAGE# of (CAR BUFFER)) (for BUF in BUFFER collect (CHECKBUFFERREFVAL BUF))) (for BUF in BUFFER do (UNDIRTY BUF STREAM))) (T (\WRITEPAGES STREAM (fetch FILEPAGE# of BUFFER) (CHECKBUFFERREFVAL BUFFER)) (* ; "reset dirty bit.") (UNDIRTY BUFFER STREAM]) (\CLEARMAP [LAMBDA (STREAM PAGES USERFLG) (* ; "Edited 12-Jul-88 13:53 by bvm") (* ;; "clears pages from an ofd writing them out if they are dirty. PAGES is a page# or a list of page#s or NIL. USERFLG is T for user calls and if PAGES is NIL, causes all usermapped pages to get written out.") (COND ((DIRTYABLE STREAM) (* ;; "first write out any buffers that are dirty.") (FDEVOP 'FORCEOUTPUT (fetch DEVICE of STREAM) STREAM))) (if (NULL PAGES) then (UNINTERRUPTABLY (* ;; "Since we're about to throw the buffers away, flush the current page. In the case of output stream, the forceoutput method already did this with a \releasecpage") (replace CBUFSIZE of STREAM with 0) (replace CBUFPTR of STREAM with NIL))) (PROG ((BUFFER (fetch BUFFS of STREAM)) PREVBUFFER) LP (COND ((NULL BUFFER) (RETURN)) ((COND ((NULL PAGES) (COND (USERFLG (* ;  "User is asking for all mapped pages to be cleared, Is this a usermapped page?") (fetch USERMAPPED of BUFFER)) (T (* ; "system call, clear all pages") T))) ((NLISTP PAGES) (EQ PAGES (fetch FILEPAGE# of BUFFER))) ((FMEMB (fetch FILEPAGE# of BUFFER) PAGES))) (* ; "found a page to clear.") (* ;; "this may cause extra IO system buffers to get unallocated. this is ok in that they will get reallocated up to the standard number but not ok in that if the file was opened specifying more that the standard number, the extras will get lost.") (\RELEASEBUFFER (PROG1 BUFFER [COND [PREVBUFFER (* ;  "This isn't the first buffer on list.") (replace BUFFERNEXT of PREVBUFFER with (SETQ BUFFER (fetch BUFFERNEXT of BUFFER] (T (* ;  "deleting the first buffer, change the STREAM") (replace BUFFS of STREAM with (SETQ BUFFER (fetch BUFFERNEXT of BUFFER]) STREAM) (GO LP)) (T (SETQ PREVBUFFER BUFFER) (SETQ BUFFER (fetch BUFFERNEXT of BUFFER)) (GO LP]) (DOPMAP [LAMBDA (PAGE# STREAM VMEMPAGE) (* rmk%: "25-OCT-83 19:57") (* ;; "reads a page from a file into a block of storage. If the protection bits are ever implemented in hardware, this should set them from a new argument.") (\READPAGES STREAM PAGE# VMEMPAGE) (* ;; "We return the page pointer to ensure that it remains on the stack to guard against inclement garbage collections") VMEMPAGE]) (FINDPTRSBUFFER [LAMBDA (PTR NOERRORFLG) (* lmm "10-MAR-83 23:20") (* ;; "given a pointer to a mapped location, return the buffer which contains that pointer. Causes error if no such buffer (thus this is used as a checking function too)") (COND [(bind (B _ SYSTEMBUFFERLIST) while B do (COND ((EQ PTR (fetch VMEMPAGE of B)) (RETURN B)) (T (SETQ B (fetch SYSNEXT of B] (NOERRORFLG NIL) (T (ERROR PTR "not a MAPPAGE pointer"]) (FORGETPAGES [LAMBDA (STREAM FROMPAGE TOPAGE) (* bvm%: "12-NOV-83 16:51") (* ;; "cleans pages out of the map. Used only by truncate file to throw away any trancated pages that might be mapped. Pages FROMPAGE to TOPAGE inclusive are forgotten. If FROMPAGE is NIL uses 0, if TOPAGE is NIL, uses last page.") (COND ((OR (NULL TOPAGE) (NULL FROMPAGE) (IGEQ TOPAGE FROMPAGE)) (PROG (REFFED (BUFFER (fetch BUFFS of STREAM)) PREVBUFFER) LP (COND ((NULL BUFFER) (RETURN REFFED)) ((AND (OR (NULL FROMPAGE) (IGEQ (fetch FILEPAGE# of BUFFER) FROMPAGE)) (OR (NULL TOPAGE) (ILEQ (fetch FILEPAGE# of BUFFER) TOPAGE))) (* ; "this is a BUFFER to process") [COND ((BUFFERINUSEP BUFFER STREAM) (* ;  "if buffer is still referenced, note to return that fact.") (SETQ REFFED (CONS (fetch FILEPAGE# of BUFFER) REFFED] [COND (PREVBUFFER (replace BUFFERNEXT of PREVBUFFER with (fetch BUFFERNEXT of BUFFER))) (T (replace BUFFS of STREAM with (fetch BUFFERNEXT of BUFFER ] (* ;  "MAPOUTBUFFER changes the structure of BUFFER so make change to BUFFS before it is called.") (\RELEASEBUFFER BUFFER STREAM) [SETQ BUFFER (COND (PREVBUFFER (fetch BUFFERNEXT of PREVBUFFER)) (T (fetch BUFFS of STREAM] (GO LP)) (T (SETQ PREVBUFFER BUFFER) (SETQ BUFFER (fetch BUFFERNEXT of BUFFER)) (GO LP]) (\GETMAPBUFFER [LAMBDA NIL (* bvm%: "12-NOV-83 16:54") (* ;; "gets a map buffer from the free list or creates a new one. Some of the ones on the free list may still be referenced by user structure and hence can't be used. the reference counts will actually be behind the real ones because PMAPs only gets updated when a garbage collection occurs. A possible strategy before allocating a new one or if none can be allocated is to force a garbage collection.") (COND [(AND MAPEMPTYBUFFERLIST (COND [(OR (NOT (fetch USERMAPPED of MAPEMPTYBUFFERLIST)) (fetch NOREFERENCE of MAPEMPTYBUFFERLIST)) (* ;  "is first empty buffer unreferenced or has it never been user mapped?") (replace IODIRTY of MAPEMPTYBUFFERLIST with NIL) (replace USERMAPPED of MAPEMPTYBUFFERLIST with NIL) (PROG1 MAPEMPTYBUFFERLIST (SETQ MAPEMPTYBUFFERLIST (fetch BUFFERNEXT of MAPEMPTYBUFFERLIST )))] (T (* ;  "find the first not referenced one and return it.") (PROG ((PREV MAPEMPTYBUFFERLIST) (BUF MAPEMPTYBUFFERLIST)) LP (COND ((NULL (SETQ BUF (fetch BUFFERNEXT of BUF))) (RETURN NIL)) ((OR (NOT (fetch USERMAPPED of BUF)) (fetch NOREFERENCE of BUF)) (* ;  "buffer is not referenced or was never user mapped.") (replace BUFFERNEXT of PREV with (fetch BUFFERNEXT of BUF)) (replace IODIRTY of BUF with NIL) (replace USERMAPPED of BUF with NIL) (RETURN BUF)) (T (SETQ PREV BUF) (GO LP] (T (* ;  "if there isn't one that's not referenced, create a new one.") (\ALLOCMAPBUFFER]) (LOCKMAP [LAMBDA (PTR) (* rrb "15-SEP-79 18:17") (* ;; "is a noop on the dorado all buffers are locked until no longer referenced.") PTR]) (MAPAFTERCLOSE [LAMBDA (STREAM) (* rmk%: "25-OCT-83 20:08") (* ;; "this function is called after closing a file.") (\CLEARMAP STREAM) (AND DEFAULTMAPFILE (EQ STREAM (\GETSTREAM DEFAULTMAPFILE)) (SETQ DEFAULTMAPFILE NIL]) (MAPBUFFERCOUNT [LAMBDA (AVAILFLG) (* rrb " 2-JAN-80 15:47") (* ;; "counts either the total number of buffers or the number available for use now.") (bind (B _ SYSTEMBUFFERLIST) while B count (PROG1 (OR (NOT AVAILFLG) (fetch NOREFERENCE of B) (NOT (fetch USERMAPPED of B))) (SETQ B (fetch SYSNEXT of B)))]) (MAPPAGE [LAMBDA (PAGE# FILE READONLY) (* rmk%: "25-OCT-83 19:55") (* ;; "establishes a buffer for a page of a file and (since semantics of 10 require it) checks to make sure file is open for reading.") (* ;; "must set the eof pointer if this page is past the current eof and the file is writable, unless user says READONLY in which case we don't guarantee that (accidental) changes to the buffer will get saved in the file.") (PROG ((STREAM (\GETSTREAM FILE))) (OR (fetch PAGEMAPPED of (fetch DEVICE of STREAM)) (ERROR STREAM "not page-mappable")) (RETURN (SELECTQ (fetch ACCESS of STREAM) (INPUT (\MAPPAGE PAGE# STREAM T)) (BOTH (PROG1 (\MAPPAGE PAGE# STREAM T) [OR READONLY (COND ((ILEQ (fetch EPAGE of STREAM) PAGE#) (* ;; "user is mapping for write the last page or a page beyond the last one, set the EOF to the zeroth byte of the next page. This assumes that BOUT keeps at least the page part of the EOF up to date with its output.") (\SETEOF STREAM (ADD1 PAGE#) 0])) (ERROR STREAM "must be open for input to map."]) (MAPWORD [LAMBDA (FILEADR FILE) (* lmm "10-MAR-83 23:33") (* ;; "changed to contain dorado standard page size constants.") (WORDOFFSET (MAPPAGE (FOLDLO FILEADR WORDSPERPAGE) FILE) (MOD FILEADR BYTESPERPAGE]) (\RELEASEBUFFER [LAMBDA (BUFFER STREAM) (* bvm%: "12-NOV-83 16:51") (* ;; "releases a buffer by moving it from the STREAM to the free list. it will not be taken off the free list if it is still referenced and it has been usermapped.") (replace BUFFERNEXT of BUFFER with MAPEMPTYBUFFERLIST) (* ;  "put the buffer on the free list.") (SETQ MAPEMPTYBUFFERLIST BUFFER]) (RELEASINGVMEMPAGE [LAMBDA (PTR) (* bvm%: "24-JUN-82 17:01") (* ;; "this function is called by the garbage collector when it determines that PTR is a VMEMPAGE to which there are no pointers. If this function returns T, PTR will not be put on the free list. This function checks to see if PTR is a buffer and if so, marks that buffer's descriptor as available. If not, the user has created and used PTR so zero it before it goes onto free list.") (COND ((SETQ PTR (FINDPTRSBUFFER PTR T)) (replace NOREFERENCE of PTR with T) T]) (RESTOREMAP [LAMBDA (STREAM PAGES) (* bvm%: "12-NOV-83 16:51") (* ;; "This function is called by LOGOUT after it has returned on any file that has been found to be changed. It remaps any pages that are referenced (LOGOUT calls RECLAIM) and returns a list of their page numbers.") (PROG ((STRM (\GETSTREAM STREAM)) (BUFFER (fetch BUFFS of STREAM)) PREVBUFFER REFFED) LP [COND ((NULL BUFFER) (RETURN REFFED)) ([OR (NULL PAGES) (for P inside PAGES thereis (EQ P (fetch FILEPAGE# of BUFFER] (* ;; "found a page to restore. If page is not referenced, don't bother to remap it. If it is referenced, map it and return its page number.") (COND ((BUFFERINUSEP BUFFER STRM) (* ;; "if r/w bits are ever made accessible to LISP, they should be gotten from the ofd and passed to DOPMAP.") (DOPMAP (fetch FILEPAGE# of BUFFER) STRM (fetch VMEMPAGE of BUFFER)) (SETQ REFFED (CONS (fetch FILEPAGE# of BUFFER) REFFED))) (T (* ;; "this may cause extra IO system buffers to get unallocated. this is ok in that they will get reallocated up to the standard number but not ok in that if the file was opened specifying more that the standard number, the extras will get lost.") (\RELEASEBUFFER (PROG1 BUFFER [COND [PREVBUFFER (* ;  "This isn't the first buffer on list.") (replace BUFFERNEXT of PREVBUFFER with (SETQ BUFFER (fetch BUFFERNEXT of BUFFER] (T (* ;  "deleting the first buffer, change the STRM") (replace BUFFS of STRM with (SETQ BUFFER (fetch BUFFERNEXT of BUFFER]) STRM) (GO LP] (SETQ PREVBUFFER BUFFER) (SETQ BUFFER (fetch BUFFERNEXT of BUFFER)) (GO LP]) (UNLOCKMAP [LAMBDA (PTR) (* rrb "15-SEP-79 18:18") (* ;; "is a noop on the dorado all buffers are locked until no longer referenced.") PTR]) (\MAPPAGE [LAMBDA (FILEPAGE# STREAM USERFLG) (* bvm%: "17-May-84 10:39") (* ;; "maps a page of a file into a buffer. Assumes its arg is an STREAM and has been checked. Currently mapped pages are maintained in the STREAM. The STREAM specifies a fixed number of buffers which are cycled through the sequential IO and more are added if the user calls MAPPAGE. The oldest available buffer is used for the new page and more are allocated if none is available.") (PROG ((BUF (fetch BUFFS of STREAM)) %#IOBUFFS PREV PREVAVAIL MOREBUFS) [COND ((NULL BUF) (* ; "no buffers yet") (SETQ BUF (\GETMAPBUFFER)) (GO DOPMAP)) ((EQ (fetch FILEPAGE# of BUF) FILEPAGE#) (* ;  "if usermapped, then set bit in buffer.") (COND (USERFLG (replace USERMAPPED of BUF with T))) (CHECKBUFFERREF BUF) (* ; "page is already on top") (RETURN (fetch VMEMPAGE of BUF] (* ;; "not on top -- walk thru the list, looking for the page and noting the last available buffer in case it is not found.") (SETQ %#IOBUFFS (COND ((fetch USERMAPPED of BUF) 0) (T 1))) (* ;  "Counts number of non-usermapped buffers") (SETQ PREV BUF) LP [COND ((NULL (SETQ BUF (fetch BUFFERNEXT of BUF))) (* ; "not found") [COND ((OR (NULL PREVAVAIL) (ILEQ %#IOBUFFS (fetch MAXBUFFERS of STREAM))) (* ;  "Fewer than the specified max exist so far, so create a new buffer") (SETQ BUF (\GETMAPBUFFER))) (T (SETQ BUF (fetch BUFFERNEXT of PREVAVAIL)) (* ;  "write out the old buffer if necessary and remove it from its place in the list") (COND ((AND (DIRTYABLE STREAM) (OR (fetch USERMAPPED of BUF) (DIRTYP BUF STREAM))) (\WRITEOUTBUFFERS (COND ((AND (fetch MULTIBUFFERHINT of STREAM) (SETQ MOREBUFS (\COLLECTDIRTYBUFS (fetch FILEPAGE# of BUF) STREAM))) (* ;  "This device likes multiple buffers, so write out as much as we can") (CONS BUF MOREBUFS)) (T BUF)) STREAM))) (replace BUFFERNEXT of PREVAVAIL with (fetch BUFFERNEXT of BUF] (* ;  "BUF is not a buffer to be used. If interrupted here a buffer could get dropped.") (GO DOPMAP)) ((EQ (fetch FILEPAGE# of BUF) FILEPAGE#) (* ;  "found the page, move it to front.") (CHECKBUFFERREF BUF) (UNINTERRUPTABLY (replace BUFFERNEXT of PREV with (fetch BUFFERNEXT of BUF)) (replace BUFFERNEXT of BUF with (fetch BUFFS of STREAM)) (replace BUFFS of STREAM with BUF)) (RETURN (GETBUFFERPTR BUF))) ((OR (NULL (fetch USERMAPPED of BUF)) (fetch NOREFERENCE of BUF)) (* ; "BUF is available") (SETQ PREVAVAIL PREV) (SETQ %#IOBUFFS (ADD1 %#IOBUFFS] (* ; "advance to next buffer on list.") (SETQ PREV BUF) (GO LP) DOPMAP (RETURN (PROG1 (DOPMAP FILEPAGE# STREAM (CHECKBUFFERREFVAL BUF)) (* ; "PROG1 holds page pointer") (replace FILEPAGE# of BUF with FILEPAGE#) (replace BUFFERNEXT of BUF with (fetch BUFFS of STREAM)) (* ; "move to front of buffer list") (replace BUFFS of STREAM with BUF) (replace USERMAPPED of BUF with USERFLG))]) (\COLLECTDIRTYBUFS [LAMBDA (FIRSTPAGE STREAM) (* bvm%: "16-May-84 14:38") (* ;;; "Returns a list of buffers that contain contiguously ascending dirty pages in STREAM immediately beyond FIRSTPAGE") (bind NEXTBUF (LASTPAGE _ (ADD1 FIRSTPAGE)) while [SETQ NEXTBUF (find B inbufs (fetch BUFFS of STREAM) suchthat (AND (EQ (fetch FILEPAGE# of B) LASTPAGE) (OR (fetch USERMAPPED of B) (DIRTYP B STREAM] collect (PROGN (add LASTPAGE 1) NEXTBUF]) (\SETIODIRTY [LAMBDA (STREAM PAGENUMBER) (* rmk%: "25-OCT-83 20:00") (* ;; "marks a buffer descriptor as dirty.") (for BUF inbufs (fetch BUFFS of STREAM) when (EQ (fetch FILEPAGE# of BUF) PAGENUMBER) do (replace IODIRTY of BUF with T) (RETURN BUF) finally (SHOULDNT) (* ; "It better be there somewhere") ]) ) (DEFINEQ (WORDCONTENTS [LAMBDA (PTR) (* lmm "28-FEB-82 23:24") (CHECK (FINDPTRSBUFFER PTR T)) (\GETBASE PTR 0]) (SETWORDCONTENTS [LAMBDA (PTR N) (* lmm "28-FEB-82 23:21") (* ;; "stores into a word in a buffer. Does error checking which is not done by macro.") (OR (FINDPTRSBUFFER PTR T) (ERROR PTR "not a PMAP buffer.")) (\PUTBASE PTR 0 N]) (/SETWORDCONTENTS [LAMBDA (PTR N) (* lmm "18-SEP-78 00:26") [AND LISPXHIST (UNDOSAVE (LIST (FUNCTION /SETWORDCONTENTS) PTR (WORDCONTENTS PTR] (SETWORDCONTENTS PTR N]) (WORDOFFSET [LAMBDA (PTR N) (* lmm "28-FEB-82 23:22") (CHECK (FINDPTRSBUFFER PTR T)) (\ADDBASE PTR N]) ) (* "FOLLOWING DEFINITIONS EXPORTED") (PUTPROPS WORDCONTENTS BYTEMACRO ((PTR) (\GETBASE PTR 0))) (PUTPROPS SETWORDCONTENTS BYTEMACRO ((PTR N) (\PUTBASE PTR 0 N))) (PUTPROPS WORDOFFSET BYTEMACRO ((PTR N) (\ADDBASE PTR N))) (* "END EXPORTED DEFINITIONS") (ADDTOVAR DEFAULTMAPFILE ) (ADDTOVAR SYSTEMBUFFERLIST ) (ADDTOVAR MAPEMPTYBUFFERLIST ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSTEMBUFFERLIST MAPEMPTYBUFFERLIST DEFAULTMAPFILE) ) (* ; "Functions for page-mapped devices") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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)))) ) (* "END EXPORTED DEFINITIONS") ) (DEFINEQ (\MAKE.PMAP.DEVICE [LAMBDA (DEVICE) (* bvm%: "10-Jul-84 13:54") (* ;;; "Installs the device ops needed to make DEVICE a pagemapped device. Returns DEVICE") [with FDEV DEVICE (SETQ FDBINABLE T) (SETQ FDBOUTABLE T) (SETQ FDEXTENDABLE T) (SETQ RESETABLE T) (SETQ RANDOMACCESSP T) (SETQ PAGEMAPPED T) (SETQ BUFFERED T) (SETQ BIN (FUNCTION \BUFFERED.BIN)) (SETQ BOUT (FUNCTION \BUFFERED.BOUT)) (SETQ PEEKBIN (FUNCTION \BUFFERED.PEEKBIN)) (SETQ READP (FUNCTION \PAGEDREADP)) (SETQ BACKFILEPTR (FUNCTION \PAGEDBACKFILEPTR)) (SETQ SETFILEPTR (FUNCTION \PAGEDSETFILEPTR)) (SETQ GETFILEPTR (FUNCTION \PAGEDGETFILEPTR)) (SETQ GETEOFPTR (FUNCTION \PAGEDGETEOFPTR)) (SETQ SETEOFPTR (FUNCTION \PAGED.SETEOFPTR)) (SETQ EOFP (FUNCTION \PAGEDEOFP)) (SETQ BLOCKIN (FUNCTION \BUFFERED.BINS)) (SETQ BLOCKOUT (FUNCTION \BUFFERED.BOUTS)) (SETQ GETNEXTBUFFER (FUNCTION \PAGED.GETNEXTBUFFER)) (COND ((OR (NULL FORCEOUTPUT) (EQ FORCEOUTPUT (FUNCTION NILL))) (SETQ FORCEOUTPUT (FUNCTION \PAGED.FORCEOUTPUT] DEVICE]) (\PAGEDBACKFILEPTR [LAMBDA (STREAM) (* bvm%: "13-Feb-85 23:32") (* ;  "also see similar function \DRIBBACKFILEPTR") [COND ((APPENDONLY STREAM) (LISPERROR "ILLEGAL ARG" (fetch FULLNAME of STREAM] (* ;  "Checks done separately so we dont take an error with interrupts off") (\UPDATEOF STREAM) (COND ((NOT (AND (EQ (fetch COFFSET of STREAM) 0) (EQ (fetch CPAGE of STREAM) 0))) (UNINTERRUPTABLY [replace COFFSET of STREAM with (COND ((EQ (fetch COFFSET of STREAM) 0) (\RELEASECPAGE STREAM) (add (fetch CPAGE of STREAM) -1) (SUB1 BYTESPERPAGE)) (T (SUB1 (fetch COFFSET of STREAM] [replace (STREAM CHARPOSITION) of STREAM with (IMAX 0 (SUB1 (fetch (STREAM CHARPOSITION ) of STREAM])]) (\PAGEDSETFILEPTR [LAMBDA (STREAM INDX) (* ; "Edited 24-Jun-87 18:18 by bvm:") (\UPDATEOF STREAM) (* ;  "Update the EOF in case we have writen thru it") (PROG ((NEWPAGE (fetch (BYTEPTR PAGE) of INDX)) (NEWOFF (fetch (BYTEPTR OFFSET) of INDX))) (UNINTERRUPTABLY (COND ([OR (NEQ NEWPAGE (fetch CPAGE of STREAM)) (AND (EQ NEWPAGE (fetch EPAGE of STREAM)) (> NEWOFF (fetch COFFSET of STREAM] (* ;; "Force page release if (1) ptr is moving to a different page, (2) new ptr is past eof. We permit setting ptr past eof--if the next op is a BIN, an eof error occurs, while if the next op is a write, the end of file gets moved. In order for this to work, we have the convention that whenever CBUFPTR is non-nil, eof is the greater of the old eof or the current file pointer.") (* ;; "This clause also used to test for backing up on an APPEND-only stream, but that's nonsense--we should probably prohibit it altogether.") (\RELEASECPAGE STREAM) (replace CPAGE of STREAM with NEWPAGE))) (replace COFFSET of STREAM with NEWOFF))]) (\PAGED.INCFILEPTR [LAMBDA (STREAM AMOUNT) (* ; "Edited 29-Feb-88 17:22 by bvm") (* ;; "Increment file pointer of stream by AMOUNT, which may be negative. The only reason this function currently exists is to give fast performance to FFILEPOS -- it avoids the boxing that would occur on large file pointers.") (UNINTERRUPTABLY (PROG ((NEWOFF (+ (fetch COFFSET of STREAM) AMOUNT)) (NEWPAGE (fetch CPAGE of STREAM))) (* ;;  "SETFILEPTR sets CHARPOSITION to zero, but callers of \INCFILEPTR don't care, by fiat") (COND ((>= NEWOFF BYTESPERPAGE) (* ; "New page") (SETQ NEWPAGE (+ NEWPAGE (fetch (BYTEPTR PAGE) of NEWOFF))) (SETQ NEWOFF (fetch (BYTEPTR OFFSET) of NEWOFF))) [(< NEWOFF 0) (* ; "New page going backward") [SETQ NEWPAGE (- NEWPAGE (fetch (BYTEPTR PAGE) of (SETQ NEWOFF (SUB1 (- BYTESPERPAGE NEWOFF] (COND ((< NEWPAGE 0) (* ;  "Probably shouldn't happen; should it be an error?") (SETQ NEWPAGE 0))) (SETQ NEWOFF (SUB1 (- BYTESPERPAGE (fetch (BYTEPTR OFFSET) of NEWOFF] ([COND ((< AMOUNT 0) (* ;  "Backing up, may have to set the eof if we have been writing") (\UPDATEOF STREAM) T) (T (* ;  "Moving forward, make sure we don't move past the eof") (AND (fetch CBUFPTR of STREAM) (<= NEWOFF (fetch CBUFSIZE of STREAM] (* ; "easy case, no page turn") (replace COFFSET of STREAM with NEWOFF) (* ;  "Just bump COFFSET and we're done") (RETURN)) (T (* ; "Moving forward past eof, might as well let this fall thru to general case, since we need to make sure current buffer is released.") )) (\UPDATEOF STREAM) (\RELEASECPAGE STREAM) (replace CPAGE of STREAM with NEWPAGE) (replace COFFSET of STREAM with NEWOFF)))]) (\PAGEDGETFILEPTR [LAMBDA (STREAM) (* rmk%: " 2-JUL-82 13:07") (create BYTEPTR PAGE _ (fetch CPAGE of STREAM) OFFSET _ (fetch COFFSET of STREAM]) (\PAGEDGETEOFPTR [LAMBDA (STREAM) (* bvm%: "26-DEC-81 15:48") (\UPDATEOF STREAM) (* ;  "If we have been writing the EOF may not be current") (create BYTEPTR PAGE _ (fetch EPAGE of STREAM) OFFSET _ (fetch EOFFSET of STREAM]) (\PAGEDREADP [LAMBDA (STREAM FLG) (* rmk%: " 5-Apr-85 11:10") (* ;; "If FLG is NIL, a single EOL as the last character of the file doesn't count.") (* ;  "The 10 does not do the EOL check on the peeked character.") (AND (NOT (\PAGEDEOFP STREAM)) (OR (NOT (NULL FLG)) (NEQ EOL.TC (\SYNCODE \PRIMTERMSA (\PEEKCCODE STREAM))) (OR (ILESSP (ffetch CPAGE of STREAM) (ffetch EPAGE of STREAM)) (PROGN (* ;; "Having done a \PAGEDPEEKBIN above, we won't be in the case where COFFSET is BYTESPERPAGE Thus there are at least two characters in the buffer") (ILESSP (IPLUS (ffetch COFFSET of STREAM) (COND ((\RUNCODED STREAM) 1) (T 2))) (ffetch CBUFSIZE of STREAM]) (\PAGEDEOFP [LAMBDA (STREAM) (* ; "Edited 15-Jun-87 15:06 by jds") (* ;;; "Determines if a paged file is at EOF.") (OR (READONLY STREAM) (\UPDATEOF STREAM)) (LET* [(CUROFFSET (fetch COFFSET of STREAM)) (CURPAGE (IPLUS (fetch CPAGE of STREAM) (COND ((AND (fetch CBUFPTR of STREAM) (IEQP CUROFFSET (fetch CBUFSIZE of STREAM))) (SETQ CUROFFSET 0) 1) (T 0] (* ;; "CURPAGE is current page, allowing for the fact that COFFSET can be at end of the prior page which is equivalent to being at 0 on the next page.") (COND ((IGREATERP CURPAGE (fetch EPAGE of STREAM)) (* ;  "We're on a page that's past the last one in the file.") T) ((ILESSP CURPAGE (fetch EPAGE of STREAM)) (* ;; "Not on last page yet, so not eof. Need to figure in the COFFSET because it is possible for COFFSET to be BYTESPERPAGE before the page is turned") NIL) ((IGEQ CUROFFSET (fetch EOFFSET of STREAM)) (* ;  "We're on the last page, so check the buffer offset.") T]) (\PAGED.GETNEXTBUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* bvm%: "30-Sep-84 15:14") (* ;; "Advances STREAM to a new page. Leaves the current page pointer NIL as the new page may never be written, so must update eof. Returns T on success; any other return is a value to use by \BIN") (PROG ((CPAGE# (fetch CPAGE of STREAM)) (COFF (fetch COFFSET of STREAM)) EPAGE# BUF) [COND ((NOT (OPENED STREAM)) (LISPERROR "FILE NOT OPEN" (fetch FULLNAME of STREAM] (COND ((AND (ILESSP COFF (SELECTQ WHATFOR (READ (fetch CBUFSIZE of STREAM)) BYTESPERPAGE)) (fetch CBUFPTR of STREAM)) (* ; "Is ok, why were we called?") (RETURN T))) (* ; "Buffer exhausted or empty") (UNINTERRUPTABLY (* ; "Clean up current page") (\RELEASECPAGE STREAM) (if (EQ COFF BYTESPERPAGE) then (* ;  "Change to be first byte of next page instead of beyond last byte of previous page") (replace COFFSET of STREAM with (SETQ COFF 0)) (replace CPAGE of STREAM with (add CPAGE# 1)))) [COND ([AND (IGEQ CPAGE# (SETQ EPAGE# (fetch EPAGE of STREAM))) (OR (NOT (IEQP CPAGE# EPAGE#)) (IGEQ COFF (fetch EOFFSET of STREAM] (* ;  "Current file pointer is at or past end of file") (SELECTQ WHATFOR (READ (RETURN (AND (NULL NOERRORFLG) (\EOF.ACTION STREAM)))) (WRITE (UNINTERRUPTABLY (replace EPAGE of STREAM with (SETQ EPAGE# CPAGE#)) (replace EOFFSET of STREAM with COFF))) (SHOULDNT] (* ;; "Now fill the buffer -- map in current page") (SETQ BUF (\MAPPAGE CPAGE# STREAM)) (* ; "This is interruptable") (UNINTERRUPTABLY (replace CBUFSIZE of STREAM with (COND ((ILESSP CPAGE# EPAGE#) (* ; "Full page") BYTESPERPAGE) ((IEQP CPAGE# EPAGE#) (* ; "Last page") (fetch EOFFSET of STREAM)) (T (* ; "Beyond EOF so no data") 0))) (replace CBUFMAXSIZE of STREAM with BYTESPERPAGE) (replace CBUFPTR of STREAM with BUF)) (RETURN T]) (\PAGED.FORCEOUTPUT [LAMBDA (STREAM) (* bvm%: "22-Aug-84 12:44") (* ;; "Flushes the contents of any dirty pages back into the file but leaves them available to LISP. As there is no way to know whether or not a usermapped page has been changed, such pages will be written out again when the ofd is closed.") (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT)) (COND ((DIRTYABLE STREAM) (\UPDATEOF STREAM) (UNINTERRUPTABLY (\RELEASECPAGE STREAM)) (PROG [(BUFFERS (SORT (for B inbufs (fetch BUFFS of STREAM) when (OR (fetch USERMAPPED of B) (DIRTYP B)) collect B) (FUNCTION (LAMBDA (X Y) (IGREATERP (fetch FILEPAGE# of Y) (fetch FILEPAGE# of X] (* ;  "Write out any dirty pages, in ascending order.") (while BUFFERS do (\WRITEOUTBUFFERS (PROG1 BUFFERS (* ;  "Write out as many contiguous ones as possible") (bind (B _ BUFFERS) (N _ (fetch FILEPAGE# of (CAR BUFFERS))) while (AND (CDR B) (EQ (fetch FILEPAGE# of (CADR B)) (ADD1 N))) do (SETQ B (CDR B)) (add N 1) finally (SETQ BUFFERS (CDR B)) (RPLACD B NIL))) STREAM))) (\TRUNCATEFILE STREAM) (* ; "Adjusts length on device") )) STREAM]) (\UPDATEOF [LAMBDA (STREAM) (* bvm%: " 7-Jun-84 16:53") (* ;; "The EOF needs updating if we have written past the EOF. We check CBUFPTR to detect phony file positions from SETFILEPTR and TURNPAGE that were never actually written thru") (AND (fetch CBUFPTR of STREAM) (PROGN (* ;; "Determines if the current file ptr is BEYOND the end of file. Since page is loaded, we can test against the CBUFSIZE. As we are ignoring the equal case, we dont need the test for page numbers used by FASTEOF.") (IGREATERP (fetch COFFSET of STREAM) (fetch CBUFSIZE of STREAM))) (\SETEOF STREAM (fetch CPAGE of STREAM) (fetch COFFSET of STREAM]) (\READPAGES [LAMBDA (STREAM FIRSTPAGE BUFFERLIST) (* bvm%: "26-DEC-81 15:44") (* ;; "Read data from the file specified by open file descriptor OFD, starting with FIRSTPAGE into the buffers given in BUFFERLIST. If BUFFERLIST is not a list, then it is assumed to be a pointer to a buffer into which a single page is read.") (FDEVOP 'READPAGES (fetch DEVICE of STREAM) STREAM FIRSTPAGE BUFFERLIST]) (\WRITEPAGES [LAMBDA (STREAM FIRSTPAGE BUFFERLIST) (* bvm%: "26-DEC-81 15:44") (* ;; "Write data into the file specified by open file descriptor OFD, starting with FIRSTPAGE from the buffers given in BUFFERLIST. If BUFFERLIST is not a list, then it is assumed to be a pointer to a buffer from which a single page is written.") (\UPDATEOF STREAM) (* ; "Make EOF current") (FDEVOP 'WRITEPAGES (fetch DEVICE of STREAM) STREAM FIRSTPAGE BUFFERLIST]) ) (DEFINEQ (\SETEOF [LAMBDA (STREAM EP EO) (* bvm%: "30-Sep-84 15:12") (* ;; "Sets the end of file. If new end of file is on the current page, resets the character count if necessary.") [COND ((IGEQ EO BYTESPERPAGE) (add EP (fetch (BYTEPTR PAGE) of EO)) (SETQ EO (fetch (BYTEPTR OFFSET) of EO] (UNINTERRUPTABLY (replace EPAGE of STREAM with EP) (replace EOFFSET of STREAM with EO) (COND ((NULL (fetch CBUFPTR of STREAM)) (* ; "nothing mapped, so no fuss") ) ((EQ EP (fetch CPAGE of STREAM)) (replace CBUFSIZE of STREAM with EO)) ((IGREATERP (fetch CPAGE of STREAM) EP) (\RELEASECPAGE STREAM) (* ; "Page no longer exists") ) (T (* ;; "If there's a page mapped in, it must not be the last page now, so make sure its CBUFSIZE is maximal. Otherwise we lose when EO was 512") (replace CBUFSIZE of STREAM with BYTESPERPAGE))) NIL)]) (\PAGED.SETEOFPTR [LAMBDA (STREAM NBYTES) (* bvm%: "30-Oct-86 17:44") (LET ((NEWEP (fetch (BYTEPTR PAGE) of NBYTES)) (NEWEO (fetch (BYTEPTR OFFSET) of NBYTES))) (SELECTQ (\NEWLENGTHIS STREAM NEWEP NEWEO) (SHORTER (COND ((OVERWRITEABLE STREAM) (FORGETPAGES STREAM (ADD1 NEWEP) (PROG1 (fetch EPAGE of STREAM) (* ; "Remember the old last page") (\SETEOF STREAM NEWEP NEWEO) (* ;  "Shorten the OFD's view of the file") )) (* ;; "FORGETPAGES tells PMAP to throw away the extra pages. The \SETEOF is done first so that an interrupt will not leave STREAM pointing to old and possibly partially overwritten pages.") (\CLEARBYTES (\MAPPAGE NEWEP STREAM) NEWEO (- BYTESPERPAGE NEWEO)) (* ;  "Zero out the trailing fragment of the last page") (\SETIODIRTY STREAM NEWEP) (* ; "Note that its dirty") (\TRUNCATEFILE STREAM NEWEP NEWEO) (* ; "Shorten the real file") T))) (SAME (* ; "Nothing to do") T) (LONGER (if (APPENDABLE STREAM) then (\SETEOF STREAM NEWEP NEWEO) T)) (SHOULDNT]) (\NEWLENGTHIS [LAMBDA (STREAM PGE OFF) (* bvm%: "13-Feb-85 23:32") (* ;; "Computes whether PGE OFF pair is longer or shorter than the current end of file") (\UPDATEOF STREAM) (* ;  "Before comparing, make it current") (PROG ((TMP (IDIFFERENCE (fetch EPAGE of STREAM) PGE))) (RETURN (COND ((ILESSP TMP 0) 'LONGER) [(EQ TMP 0) (SETQ TMP (IDIFFERENCE (fetch EOFFSET of STREAM) OFF)) (COND ((ILESSP TMP 0) 'LONGER) ((EQ TMP 0) 'SAME) (T 'SHORTER] (T 'SHORTER]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (PUTD '\PAGEDBIN (GETD '\BUFFERED.BIN) T) (PUTD '\PAGEDPEEKBIN (GETD '\BUFFERED.PEEKBIN) T) ) (DEFINEQ (PPBUFS [LAMBDA (BUF0) (* rmk%: " 7-APR-81 20:53") (* ; "Displays a buffer chain") (for B inbufs BUF0 do (printout T "[" (fetch FILEPAGE# of B) ": " B "] ") finally (TERPRI T]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE BUFFER (FILEPAGE# (VMEMPAGE XPOINTER) BUFFERNEXT SYSNEXT (NOREFERENCE FLAG) (USERMAPPED FLAG) (IODIRTY FLAG))) ) (/DECLAREDATATYPE 'BUFFER '(POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG) '((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32))) '8) EVAL@COMPILE (DECLARE%: EVAL@COMPILE (PUTPROPS GETBUFFERPTR MACRO ((BUFF) (fetch VMEMPAGE of BUFF))) (PUTPROPS CHECKBUFFERREF MACRO [OPENLAMBDA (BUFF) (* bvm%: "24-JUN-82 17:03") (* ;; "checks the reference field of a buffer descriptor and if no one is referencing it, it creates a reference and changes the flag. The flag is set by the garbage collector when there are no longer any references to the buffer it describes.") (UNINTERRUPTABLY (COND ((fetch NOREFERENCE of BUFF) (* ;; "this is a page the reference to which has been dropped, zero its reference count before returning it.") (\DELREF (fetch VMEMPAGE of BUFF)) (replace NOREFERENCE of BUFF with NIL))))]) (PUTPROPS CPBUFFERP MACRO ((BUFFER STREAM) (EQ (fetch CBUFPTR of STREAM) (fetch VMEMPAGE of BUFFER)))) (PUTPROPS BUFFERINUSEP MACRO [OPENLAMBDA (BUFFER STREAM) (AND (NULL (fetch NOREFERENCE of BUFFER)) (OR (fetch USERMAPPED of BUFFER) (CPBUFFERP BUFFER STREAM]) (PUTPROPS UNDIRTY MACRO [OPENLAMBDA (BUFFER STREAM) (replace IODIRTY of BUFFER with NIL) (COND ((CPBUFFERP BUFFER STREAM) (replace CBUFDIRTY of STREAM with NIL]) (PUTPROPS DIRTYP MACRO [OPENLAMBDA (BUFFER STREAM) (* rmk%: "25-OCT-83 19:57") (* ;; "determines if this buffer has been dirtied by the IO system. It can't determine if the user has done a putbase into the page if he got it from MAPPAGE.") (OR (fetch IODIRTY of BUFFER) (AND STREAM (CPBUFFERP BUFFER STREAM) (fetch CBUFDIRTY of STREAM]) ) (DECLARE%: EVAL@COMPILE [I.S.OPR 'INBUFS NIL '(first (SETQ I.V. BODY) by (fetch BUFFERNEXT of I.V.) until (NULL I.V.] ) ) (/DECLAREDATATYPE 'BUFFER '(POINTER XPOINTER POINTER POINTER FLAG FLAG FLAG) '((BUFFER 0 POINTER) (BUFFER 2 XPOINTER) (BUFFER 4 POINTER) (BUFFER 6 POINTER) (BUFFER 6 (FLAGBITS . 0)) (BUFFER 6 (FLAGBITS . 16)) (BUFFER 6 (FLAGBITS . 32))) '8) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS PMAP COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1993 2002)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2522 29176 (ADDMAPBUFFER 2532 . 2708) (\ALLOCMAPBUFFER 2710 . 3311) (CHECKBUFFERREFVAL 3313 . 3888) (CLEARMAP 3890 . 4546) (\WRITEOUTBUFFERS 4548 . 5297) (\CLEARMAP 5299 . 8525) (DOPMAP 8527 . 8990) (FINDPTRSBUFFER 8992 . 9866) (FORGETPAGES 9868 . 12153) (\GETMAPBUFFER 12155 . 15277) ( LOCKMAP 15279 . 15486) (MAPAFTERCLOSE 15488 . 15791) (MAPBUFFERCOUNT 15793 . 16283) (MAPPAGE 16285 . 17794) (MAPWORD 17796 . 18109) (\RELEASEBUFFER 18111 . 18680) (RELEASINGVMEMPAGE 18682 . 19319) ( RESTOREMAP 19321 . 22118) (UNLOCKMAP 22120 . 22329) (\MAPPAGE 22331 . 27785) (\COLLECTDIRTYBUFS 27787 . 28567) (\SETIODIRTY 28569 . 29174)) (29177 30148 (WORDCONTENTS 29187 . 29356) (SETWORDCONTENTS 29358 . 29670) (/SETWORDCONTENTS 29672 . 29977) (WORDOFFSET 29979 . 30146)) (31476 50442 ( \MAKE.PMAP.DEVICE 31486 . 32814) (\PAGEDBACKFILEPTR 32816 . 34736) (\PAGEDSETFILEPTR 34738 . 36174) ( \PAGED.INCFILEPTR 36176 . 39200) (\PAGEDGETFILEPTR 39202 . 39445) (\PAGEDGETEOFPTR 39447 . 39865) ( \PAGEDREADP 39867 . 41051) (\PAGEDEOFP 41053 . 42670) (\PAGED.GETNEXTBUFFER 42672 . 46136) ( \PAGED.FORCEOUTPUT 46138 . 48586) (\UPDATEOF 48588 . 49420) (\READPAGES 49422 . 49882) (\WRITEPAGES 49884 . 50440)) (50443 54535 (\SETEOF 50453 . 51668) (\PAGED.SETEOFPTR 51670 . 53564) (\NEWLENGTHIS 53566 . 54533)) (54677 55057 (PPBUFS 54687 . 55055))))) STOP \ No newline at end of file diff --git a/sources/POSTLOADUP b/sources/POSTLOADUP new file mode 100644 index 00000000..2d2ed13c --- /dev/null +++ b/sources/POSTLOADUP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-May-90 21:05:36" {DSK}local>lde>lispcore>sources>POSTLOADUP.;2 870 changes to%: (VARS POSTLOADUPCOMS) previous date%: " 8-DEC-81 15:27:54" {DSK}local>lde>lispcore>sources>POSTLOADUP.;1) (* ; " Copyright (c) 1990 by Venue. All rights reserved. ") (PRETTYCOMPRINT POSTLOADUPCOMS) (RPAQQ POSTLOADUPCOMS [(* set up so that files can be loaded directly from phylum) (* turn off checking for dates of source) (P (MOVD 'NILL 'LOADUP2A) (CHANGENAME 'LOADUP2 'ASSOC 'TRUE]) (* set up so that files can be loaded directly from phylum) (* turn off checking for dates of source) (MOVD 'NILL 'LOADUP2A) (CHANGENAME 'LOADUP2 'ASSOC 'TRUE) (PUTPROPS POSTLOADUP COPYRIGHT ("Venue" 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/PRETTY b/sources/PRETTY new file mode 100644 index 00000000..82e15fa7 --- /dev/null +++ b/sources/PRETTY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 21:37:09" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRETTY.;6 56513 changes to%: (FNS PRINTDEF1) previous date%: "16-Apr-2018 10:21:19" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRETTY.;5) (* ; " Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. The following program was created in 1984 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 PRETTYCOMS) (RPAQQ PRETTYCOMS [(FNS PRETTYDEF PRETTYDEFCOMS PRETTYDEF0 PRETTYDEF1 PRINTDATE PRINTDATE1 PRINTFNS PRETTYCOM PRETTYVAR PRETTYVAR1 PRETTYCOM1 ENDFILE MAKEDEFLIST PP PP* PPT PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 PRETTYPRINT3 PRINTDEF1 SUPERPRINTEQ SUPERPRINTGETPROP CHANGEFONT) (FNS READARRAY PRINTARRAY READARRAY-FROM-LIST PRINTARRAY-TO-LIST) (COMS (DECLARE%: DONTCOPY (MACROS CHANGFONT))) (COMS (* ; "COPYRIGHT") (FNS PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT) (BLOCKS (NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1))) (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) (INITVARS (COPYRIGHTFLG) (DEFAULTCOPYRIGHTOWNER) (COPYRIGHTPRETTYFLG T) (COPYRIGHTOWNERS) [DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL] (COPYRIGHTSRESERVED T) (*NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (*DEFAULT-MAKEFILE-ENVIRONMENT*)) (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*)) (INITVARS (COMMENTFLG '*) (**COMMENT**FLG '" **COMMENT** ") (PRETTYFLG T) (%#RPARS 4) (CLISPIFYPRETTYFLG) (PRETTYTRANFLG) (FONTCHANGEFLG) (CHANGECHARTABSTR) (PRETTYTABFLG T) (DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (AVERAGEVARLENGTH 4) (AVERAGEFNLENGTH 5) (%#CAREFULCOLUMNS 0) (CHANGECHAR '%|) (ENDLINEUSERFN)) [INITVARS (PRETTYDEFMACROS) (PRETTYPRINTMACROS) (PRETTYEQUIVLST) (PRETTYPRINTYPEMACROS) (FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER] (BLOCKS (PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG))) (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) [DECLARE%: EVAL@COMPILE DOCOPY (P (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS] (DECLARE%: DOEVAL@COMPILE DONTCOPY (* ;  "IMPORT because FILEPKG has records EXPORTed but is not a member of EXPORTFILES") (FILES (IMPORT) FILEPKG)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PPT PP* PP) (NLAML) (LAMA]) (DEFINEQ (PRETTYDEF (LAMBDA (PRTTYFNS PRTTYFILE PRTTYCOMS REPRINTFNS SOURCEFILE CHANGES) (* ; "Edited 16-Feb-88 11:46 by raf") (DECLARE (SPECVARS PRTTYFILE REPRINTFNS SOURCEFILE CHANGES)) (RESETLST (RESETSAVE (RESETUNDO) (QUOTE (AND RESETSTATE (RESETUNDO OLDVALUE)))) (* ;; "Says undo everything if there is an error or control-D This is particularly necessary if user is using the PRINT* prettyprintmacro which updates comments to point to the newest version.") (PROG ((NEWFILEMAP (AND BUILDMAPFLG (LIST NIL))) (%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) FILEFLG FNSLST PRTTYTEM PRETTYCOMSLST PRTTYSPELLFLG OLDFILEMAP MAPADR NLAMALST NLAMLST LAMALST LAM?LST FILEDATES ORIGFLG ROOTNAME DESTINATIONENV SOURCEFILENV SOURCEFC FCLOCATION) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* NEWFILEMAP ORIGFLG FILEFLG NLAMALST PRTTYSPELLFLG PRETTYCOMSLST PRTTYCOMS LAM?LST FNSLST OLDFILEMAP LAMALST MAPADR ORIGFLG NLAMLST DESTINATIONENV SOURCEFILENV %#RPARS)) (* ; "NEWFILEMAP corresponds to the map being built for the file being written. OLDFILEMAP corresponds to the map that exists for SOURCEFILE, if any.") (COND ((OR (NULL (\DTEST PRTTYFILE (QUOTE LITATOM))) (EQ PRTTYFILE T)) (* ; "we no longer support any of the crufty alternatives to writing a brand new file") (\ILLEGAL.ARG PRTTYFILE))) (SETQ ROOTNAME (ROOTFILENAME PRTTYFILE)) (if (OR (EQ SOURCEFILE T) (AND REPRINTFNS (NULL SOURCEFILE))) then (* ;; "SOURCEFILE plays the role of CFILE for recompiling. It permits PRETTYPRINT to obtain the definitions from the file withou having to reprettyprint them, or even having them loaded into core. T (or NIL if REPRINTFNS is specified) is the same as PRETTYFILE.") (* ;; "REPRINTFNS specifies those functions to be printed anew. REPRINTFNS=T means reprint all EXPRS, a la recompile. For example, if you have an entire file loaded in, but only change a few functions, using this option can speed up dumping the file by a factor of two. If REPRINTFNS=ALL, all functions that contain in core exprs, whether on function definition cell or property lists, are reprinted. REPRINTFNS can also be a list. MAKEFILE uses this for the REMAKE option by specifying as REPRINTFNS the list CHANGES. In any case, if the function does not contain an in core defnition, prettyprint will try to find one on the file. i.e., act as though REPRINTFNS were NIL.") (SETQ SOURCEFILE ROOTNAME)) (if (SETQ DESTINATIONENV (GET ROOTNAME (QUOTE MAKEFILE-ENVIRONMENT))) then (* ; "use this explicit environment. Copy it in case user later on destructively edits it") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY DESTINATIONENV))) else (* ; "see if we already know the environment of the source") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (LOOKUP-ENVIRONMENT-AND-FILEMAP (OR SOURCEFILE ROOTNAME) (OR (NULL SOURCEFILE) (EQ SOURCEFILE ROOTNAME))))) (if SOURCEFILE then (if (NULL (NLSETQ (SETQ SOURCEFILE (OPENSTREAM SOURCEFILE (QUOTE INPUT))))) then (* ; "can't find file to reprint from.") (* ; "OPENSTREAM is called in order that 'correction' take place.") (SETQ SOURCEFILE NIL) (PRIN1 PRTTYFILE T) (PRIN1 (QUOTE " not found, so it will be written anew. ") T) elseif (RANDACCESSP SOURCEFILE) then (RESETSAVE NIL (LIST (QUOTE CLOSEF) SOURCEFILE)) (RESETSAVE (INPUT SOURCEFILE)) (if (EQ REPRINTFNS (QUOTE EXPRS)) then (SETQ REPRINTFNS T) elseif (EQ REPRINTFNS (QUOTE CHANGES)) then (SETQ REPRINTFNS (UNION (FILEPKG.CHANGEDFNS CHANGES) (FILEPKG.CHANGEDFNS (fetch FILECHANGES of ROOTNAME))))) (if (NULL SOURCEFILENV) then (* ; "if we didn't have environment cached, look it up from the actual stream now") (CL:MULTIPLE-VALUE-SETQ (SOURCEFILENV OLDFILEMAP SOURCEFC) (GET-ENVIRONMENT-AND-FILEMAP SOURCEFILE))) (if (NULL OLDFILEMAP) then (* ; "no map on file, so we will build one as needed") (SETFILEPTR SOURCEFILE (OR SOURCEFC 0)) elseif (NULL (CAR OLDFILEMAP)) then (* ; "complete map.") elseif (LISTP (CAR OLDFILEMAP)) then (* ; "only partial map built up. should only happen for files that were made with BUILDMAPFLG=NIL, since otherwise there would be a coplete map on the file.") (SETFILEPTR SOURCEFILE (CAAR OLDFILEMAP)) else (* ; "Redundancy check. Should only occur if there was a compiled function in the file. and a partial map was formed that stopped after that function.") (HELP)) else (* ; "Can't copy from non-randaccessp source") (SETQ SOURCEFILE NIL))) (* ;; "Now figure out what environment to write the new file in.") (if DESTINATIONENV then (* ; "have explicit env, ok") elseif SOURCEFILENV then (* ; "use same as source") (SETQ DESTINATIONENV (if (EQUAL-READER-ENVIRONMENT SOURCEFILENV *OLD-INTERLISP-READ-ENVIRONMENT*) then (* ; "write the new style") (\DO-DEFINE-FILE-INFO NIL *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) else (* ; "use same env on new file as old") SOURCEFILENV)) else (* ; "new file, use default") (SETQ DESTINATIONENV (\DO-DEFINE-FILE-INFO NIL (COPY *DEFAULT-MAKEFILE-ENVIRONMENT*)))) (if (NULL SOURCEFILE) then (* ; "get rid of anything we knew about source") (SETQ OLDFILEMAP NIL) (SETQ SOURCEFC NIL) (SETQ SOURCEFILENV NIL) elseif (AND SOURCEFILENV (EQUAL-READER-ENVIRONMENT SOURCEFILENV DESTINATIONENV)) then (* ; "source and destination compatible, so we won't need to worry about it in PRETTYPRINT1/2") (SETQ SOURCEFILENV NIL)) (RESETSAVE NIL (LIST (FUNCTION PRETTYDEF0) (SETQ PRTTYFILE (OPENSTREAM PRTTYFILE (QUOTE OUTPUT))))) (* ; "Cleans up by closing and deleting file if aborted.") (RESETSAVE (OUTPUT PRTTYFILE)) (PRINT-READER-ENVIRONMENT DESTINATIONENV) (SETQ FCLOCATION (GETFILEPTR PRTTYFILE)) (WITH-READER-ENVIRONMENT DESTINATIONENV (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (SETQ FILEDATES (PRINTDATE PRTTYFILE CHANGES)) (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) ROOTNAME (PRINTCOPYRIGHT ROOTNAME)) (SETQ FILEFLG T) (SETQ CHANGES (FILEPKG.CHANGEDFNS CHANGES)) (* ; "Used freely by PRETTYPRINT to decide clispifying.") (if (NOT (RANDACCESSP PRTTYFILE)) then (* ; "No point building a map, since we won't be able to go back to the start to point at it") (SETQ NEWFILEMAP NIL)) (if FONTCHANGEFLG then (* ; "this is expensive in that it costs as many conses as there are functions, but you can afford it for a makefile.") (SETQ FNSLST (OR (for FL in (GETPROP ROOTNAME (QUOTE FILEGROUP)) when (fetch FILEPROP of FL) join (FILEFNSLST FL)) (FILEFNSLST ROOTNAME)))) (if (OR (LISTP PRTTYFNS) (LISTP (GETTOPVAL PRTTYFNS))) then (* ; "Ancient cruft from before the days of MAKEFILE.") (PRINTFNS PRTTYFNS T) (PRETTYCOM PRTTYFNS T)) (if (SETQ PRETTYCOMSLST (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS))))) then (PRETTYCOM PRTTYCOMS T) (* ; "PRTTYCOMS is just like the argument to a COMS command. see comment in prettycom1") (for L on PRETTYCOMSLST do (PRETTYCOM (CAR L) NIL L)) (* ; "The original value of PRTTYCOMS is saved so that it can be rewritten if a spelling correction occurs. The list PRTTYCOMSLST is searched by PRETTYCOM1 for * commands to see if the variable has be dumped out as well.")) (if (PRETTYDEF1) then (* ; "The coms were reprinted by PRETTYDEF1 due to a change to nlama and or nlaml") elseif PRTTYSPELLFLG then (* ; "A correction on prettycoms was performed, so dump it out aain to get the corrected version on the file.") (PRETTYCOM PRTTYCOMS T)) (if (NEQ COPYRIGHTFLG (QUOTE NEVER)) then (SAVECOPYRIGHT ROOTNAME)) (if NEWFILEMAP then (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (PRIN2 (QUOTE DONTCOPY)) (TERPRI) (SPACES 2) (for ADR in MAPADR do (SETQ PRTTYTEM (GETFILEPTR PRTTYFILE)) (SETFILEPTR PRTTYFILE ADR) (* ; "Write the current file positon into the filecreated expression, and then restores the file pointer.") (PRIN2 PRTTYTEM) (SETFILEPTR PRTTYFILE PRTTYTEM)) (PRIN2 (LIST (QUOTE FILEMAP) NEWFILEMAP)) (* ; "printed instead of prettyprinted, so wont take up two pages of listing.") (PRIN1 (QUOTE ") ")) (PUTFILEMAP (FULLNAME PRTTYFILE) NEWFILEMAP NIL DESTINATIONENV NIL FCLOCATION) (* ; "Also save map, so can be used for subsequent makefiles.")) (ENDFILE PRTTYFILE) (if (AND FILEDATES ROOTNAME) then (/replace FILEDATES of ROOTNAME with FILEDATES))) (RETURN (FULLNAME PRTTYFILE))))) ) (PRETTYDEFCOMS (LAMBDA (PRTTYCOMS FNSLST) (* ; "Edited 19-Aug-88 16:07 by raf") (DECLARE (SPECVARS FNSLST)) (PROG ((%#RPARS %#RPARS) (*PRINT-ARRAY* T) (XCL:*PRINT-STRUCTURE* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) BUILDMAPFLG PRTTYSPELLFLG ORIGFLG SOURCEFILE) (DECLARE (SPECVARS *PRINT-ARRAY* XCL:*PRINT-STRUCTURE* *PRINT-LEVEL* *PRINT-LENGTH* BUILDMAPFLG NEWFILEMAP ORIGFLG PRTTYSPELLFLG LAM?LST ORIGFLG SOURCEFILE %#RPARS)) (if (NOT (SYNTAXP (CHARCODE "[") (QUOTE LEFTBRACKET))) then (* ; "can't use brackets on this read table") (SETQ %#RPARS NIL)) (for L on (OR (LISTP PRTTYCOMS) (AND (LITATOM PRTTYCOMS) (LISTP (GETTOPVAL PRTTYCOMS)))) do (PRETTYCOM (CAR L) NIL L)))) ) (PRETTYDEF0 (LAMBDA (MADEFILE) (* bvm%: " 2-Aug-86 16:24") (* ;; "Cleans up after prettydef in case of control-d.") (COND ((OPENP MADEFILE (QUOTE OUTPUT)) (DELFILE (CLOSEF MADEFILE))))) ) (PRETTYDEF1 (LAMBDA NIL (* wt%: " 9-SEP-78 16:05") (* ; "Updates the DECLARE: for NLAMA/NLAML") (PROG (PRTTYCOM PRTTYTEM PRTTYNEW) (COND ((NULL (SOME PRETTYCOMSLST (FUNCTION (LAMBDA (X) (AND (EQ (CAR X) (QUOTE DECLARE%:)) (SETQ PRTTYTEM (MEMB (QUOTE COMPILERVARS) (SETQ PRTTYCOM X))) (EQ (CAAR (SETQ PRTTYTEM (CDR PRTTYTEM))) (QUOTE ADDVARS))))))) (AND (NULL NLAMALST) (NULL NLAMLST) (NULL LAMALST) (RETURN NIL)) (* ;; "If thee is no DECLARE: and no nlambdas, dont bother to add any. note tha if thee is IS a DECLARE:, then we must check even if there are no nlambdas, because consider what happens when user changes the only nlambda to a lambda must replace the declare: by a nop addvars.") (SETQ PRTTYCOM (SUBPAIR (QUOTE (NLAMALST NLAMLST LAMALST)) (LIST NLAMALST NLAMLST LAMALST) (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA . NLAMALST) (NLAML . NLAMLST) (LAMA . LAMALST)))))) (COND ((AND (LISTP PRETTYCOMSLST) (NLISTP PRTTYCOMS)) (/NCONC1 PRETTYCOMSLST PRTTYCOM) (PRETTYCOM PRTTYCOMS T)))) ((NOT (EQUAL (CAR PRTTYTEM) (SETQ PRTTYNEW (LIST (QUOTE ADDVARS) (CONS (QUOTE NLAMA) (UNION NLAMALST (INTERSECTION LAM?LST (CDADAR PRTTYTEM)))) (CONS (QUOTE NLAML) (UNION NLAMLST (INTERSECTION LAM?LST (CDR (CADDAR PRTTYTEM))))) (CONS (QUOTE LAMA) (UNION LAMALST (INTERSECTION LAM?LST (CDR (CADDDR (CAR PRTTYTEM)))))))))) (* ;; "The reason for the unions and intersections is that prettydef simply may not know the fntyps of some of the functions in the file, namely those on lam?lst, and theefore tese should not be removed from NLAMA and NLAML if they are there from a previous makefile.") (/RPLACA PRTTYTEM PRTTYNEW) (AND (NLISTP PRTTYCOMS) (PRETTYCOM PRTTYCOMS T))) (T (RETURN NIL))) (PRETTYCOM PRTTYCOM) (RETURN T))) ) (PRINTDATE (LAMBDA (OUTSTREAM CHANGES) (* bvm%: " 1-Aug-86 15:51") (* ;;; "assumes that OUTSTREAM is a file open for output, and prints the date information for that file on it") (PROG ((DAT (DATE)) (ROOTNAME (ROOTFILENAME OUTSTREAM)) PREVPAIR FILEDATES) (if FILEPKGFLG then (if ROOTNAME then (/replace FILECHANGES of ROOTNAME with (SETQ CHANGES (FILEPKG.MERGECHANGES CHANGES (fetch FILECHANGES of ROOTNAME))))) (* ;; "The reason for the order of arguments in UNION is so that the changes will be listed in roughly the order made.") (SETQ FILEDATES (CONS (create FILEDATEPAIR FILEDATE _ DAT DATEFILENAME _ (FULLNAME OUTSTREAM)) (SETQ PREVPAIR (LAST (fetch FILEDATES of ROOTNAME))))) (* ;;; "Right now, FILEDATES simply keeps latest version and date, and original version and date. Latter for integrity checks on makefile remake, as described in filepackage. Note that don't want to change FILEDATES property until PRETTDEF completes. In case of control-d, the file will be deleted automatically.")) (PRINTDATE1 OUTSTREAM CHANGES DAT (fetch FILEDATE of (CAR PREVPAIR)) (fetch DATEFILENAME of (CAR PREVPAIR))) (* ; "PRINTDATE1 does the actual printing. It is a separate function so that it can be advised.") (RETURN FILEDATES))) ) (PRINTDATE1 (LAMBDA (OUTSTREAM CHANGES DAT PREVDATE PREVERS TERMINATING.STRING) (* bvm%: "18-Sep-86 19:08") (* ;;; "does the printing for PRINTDATE") (printout OUTSTREAM .FONT DEFAULTFONT "(" |.P2| (QUOTE FILECREATED) %, |.P2| DAT %, .FONT LAMBDAFONT |.P2| (FULLNAME OUTSTREAM) .FONT DEFAULTFONT) (* ;; "note that CHANGEFONT checks for FONTCHANGEFLG explicitly so that it won't do anything if FONTCHANGEFLG is NIL") (if (AND BUILDMAPFLG (NOT (DISPLAYP OUTSTREAM))) then (push MAPADR (ADD1 (GETFILEPTR OUTSTREAM))) (PRIN3 " " OUTSTREAM) (* ;; "The address of where the map begins will be stored in this slot. 8 spaces left because when radix is 8, can overflow seven spaces by a file of 300000 characters (Alice did it). The push is because of a feature no longer used where there could be two FILECREATED expressions at the head of a file font")) (if FILEPKGFLG then (if CHANGES then (printout OUTSTREAM T T 6 |.P2| (QUOTE changes) %, |.P2| (QUOTE to%:) %,, .PPVTL CHANGES)) (if PREVDATE then (printout OUTSTREAM T T 6 |.P2| (QUOTE previous) %, |.P2| (QUOTE date%:) %, |.P2| PREVDATE) (if PREVERS then (printout OUTSTREAM %, |.P2| PREVERS)))) (PRIN1 (OR TERMINATING.STRING ") ") OUTSTREAM))) (PRINTFNS (LAMBDA (X PRETTYDEFLG) (* lmm "13-OCT-82 16:44") (* ; "prettydeflg=T when called from prettydef.") (AND X (PROG (FNADRLST) (COND ((AND PRETTYDEFLG NEWFILEMAP) (SETQ FNADRLST (TCONC NIL (GETFILEPTR PRTTYFILE))) (TCONC FNADRLST NIL) (NCONC1 NEWFILEMAP (CAR FNADRLST)))) (PRIN1 (QUOTE %()) (PRINT (QUOTE DEFINEQ)) (PRETTYPRINT X (AND PRETTYDEFLG (OR FNADRLST T)) FNSLST) (* ; "FNSLST bound in prettydef to list of functions on this file. used for font stuff.") (PRIN1 (QUOTE %))) (AND FNADRLST (RPLACA (CDAR FNADRLST) (GETFILEPTR PRTTYFILE))) (TERPRI)))) ) (PRETTYCOM (LAMBDA (PRTTYCOM PRTTYFLG PRETTYCOMSTAIL) (* ; "Edited 14-Apr-88 18:26 by bvm") (PROG (PRTTYTEM) (COND ((NULL PRTTYCOM) (* ; "So that RECOMPILE and BRECOMPILE do not have to check before calling PRETTYCOM.") (RETURN)) ((AND PRTTYFLG (NEQ PRTTYFILE T)) (PRINT (COND (LISPXPRINTFLG (* ;; "PRETTYCOMPRINT is an nlambda that does a lispxprint, except when prettyheader is NIL, in hich case it does nothing.") (LIST (QUOTE PRETTYCOMPRINT) PRTTYCOM)) (T (LIST (QUOTE PRINT) (LIST (QUOTE QUOTE) PRTTYCOM) T T)))))) (COND ((LITATOM PRTTYCOM) (COND ((AND (NULL PRTTYFLG) (NOT (BOUNDP PRTTYCOM)) DWIMFLG (SETQ PRTTYTEM (FIXSPELL PRTTYCOM 70 USERWORDS T PRETTYCOMSTAIL (FUNCTION BOUNDP))) (SETQ PRTTYSPELLFLG T)) (SETQ PRTTYCOM PRTTYTEM))) (PRETTYVAR PRTTYCOM PRTTYFLG) (* ;; "FNS and VARS are printed as (RPAQQ atom value T) so that LOAD ALLPROP will still stre them in the value cell.") (RETURN PRTTYCOM)) (PRTTYFLG (* ; "PRETTYDEF called with a list for FNS or VARS,") (RETURN PRTTYCOM))) TOP (COND ((AND (NULL ORIGFLG) (SETQ PRTTYTEM (fetch (FILEPKGCOM MACRO) of (CAR PRTTYCOM)))) (for X on (SUBPAIR (CAR PRTTYTEM) (PRETTYCOM1 PRTTYCOM T T) (CDR PRTTYTEM)) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (T (SELECTQ (CAR PRTTYCOM) (FNS (PROG (PRTTYSPELLFLG) (PRINTFNS (PRETTYCOM1 PRTTYCOM T T) (NOT (NULL PRETTYCOMSTAIL))) (AND PRTTYSPELLFLG (EQ (CADR PRTTYCOM) (QUOTE *)) (LITATOM (SETQ PRTTYTEM (CADDR PRTTYCOM))) (PRETTYCOM PRTTYTEM)) (* ; "The FNSlst had an error in it that was corrected."))) ((VARS ARRAY) (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR X))) (DECLARE%: (* ;; "Normally, expressions appearing in a symbolic file are (1) evaluated upon loading the file, (2) not evaluated when compiling the file, and (3) copied to the compile file. DECLARE: can be used to change state around any PRETTYCOM. The atomic symbols DONTCOPY, DOCOPY, DONTEVAL@COMPILE, DOEVAL@COMPILE, DONTEVAL@LOAD, and DOEVAL@LOAD have the obvious meaning. DECLARE: eliminates the pretty commands DECLARE, COMPROP, COMPROP*, PD, PC, and PC*. DECLARE: is defined as a functionthat evaluates all list expressions except when under a DONTEVAL@LOAD state.") (PRIN1 "(") (PRIN2 (QUOTE DECLARE%:)) (SPACES 1) (for LST on (PRETTYCOM1 PRTTYCOM T T) do (COND ((NLISTP (CAR LST)) (COND ((NOT (MEMB (CAR LST) DECLARETAGSLST)) (COND ((AND DWIMFLG (FIXSPELL (CAR LST) 70 DECLARETAGSLST T LST)) (SETQ PRTTYSPELLFLG T)) (T (GO ERROR))))) (PRIN2 (CAR LST)) (SPACES 1)) (T (TERPRI) (PRETTYCOM (CAR LST) NIL LST))) (SELECTQ (CAR LST) ((EVAL@LOADWHEN EVAL@COMPILEWHEN COPYWHEN) (COND ((SETQ LST (CDR LST)) (PRINTDEF (CAR LST)) (SPACES 1)))) NIL)) (PRIN1 (QUOTE ") "))) ((CL:EVAL-WHEN) (* ;; "Has the syntax (EVAL-WHEN (times ...) coms ...). Dumps an EVAL-WHEN form on the file containing whatever is dumped by the given COMS.") (CL:ASSERT (AND (CL:CONSP (CADR PRTTYCOM)) (CL:SUBSETP (CADR PRTTYCOM) (QUOTE (EVAL CL:EVAL COMPILE CL:COMPILE LOAD CL:LOAD)))) NIL "The first argument to the ~S command must be a list of times") (CL:FORMAT T "(~S ~S" (QUOTE CL:EVAL-WHEN) (CADR PRTTYCOM)) (for LST on (PRETTYCOM1 (CDR PRTTYCOM) T NIL) do (CL:TERPRI) (PRETTYCOM (CAR LST) NIL LST)) (CL:FORMAT T "~&)~%%")) ((SPECVARS LOCALVARS GLOBALVARS) (SETQ PRTTYTEM (CONS (CAR PRTTYCOM) (PRETTYCOM1 PRTTYCOM T T))) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (PRINTDEF1 PRTTYTEM) (PRIN1 ") ")) ((PROP IFPROP) (PROG ((PRTTYFLG (EQ (CAR PRTTYCOM) (QUOTE IFPROP))) (PRTTYTEM (CADR PRTTYCOM)) (PRTTYX (PRETTYCOM1 (CDR PRTTYCOM) T T))) (* ; "IFPROP only dumps those property values that are non-NIL.") (COND ((LISTP PRTTYTEM) (for X in PRTTYTEM do (MAKEDEFLIST PRTTYX X PRTTYFLG))) ((NEQ PRTTYTEM (QUOTE ALL)) (MAKEDEFLIST PRTTYX PRTTYTEM PRTTYFLG PRTTYCOM)) ((ASSOC (QUOTE PUTPROPS) PRETTYPRINTMACROS) (for ATM in PRTTYX do (PRINTDEF1 (CONS (QUOTE PUTPROPS) (CONS ATM (CONS (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) join (LIST (CAR X) (CADR X))))))))) (T (for ATM in PRTTYX do (printout NIL %,, "(" |.P2| (QUOTE PUTPROPS) %, |.P2| ATM) (SETQ PRTTYTEM (ADD1 (POSITION))) (for X on (GETPROPLIST ATM) by (CDDR X) unless (MEMB (CAR X) SYSPROPS) do (printout NIL .TAB PRTTYTEM .PPV (CAR X) %, .PPV (CADR X))) (PRIN1 (QUOTE ") "))))))) (P (* ; "Arbitrary expression to evaluate when loaded. Be sure to prettyprint as code") (for X in (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T)) do (PRINTDEF1 X T))) (INITVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (COND ((LISTP X) (OR (EQ (CAR X) COMMENTFLG) (PRETTYVAR1 (QUOTE RPAQ?) (CAR X) (CDR X) NIL T))) (T (PRETTYVAR1 (QUOTE RPAQ?) X NIL))))) (ADDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE ADDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (APPENDVARS (for X in (PRETTYCOM1 PRTTYCOM T T) do (PRETTYVAR1 (QUOTE APPENDTOVAR) (CAR (OR (LISTP X) (ERRORX (LIST 4 X)))) (CDR X) NIL T))) (E (for X in (PRETTYCOM1 PRTTYCOM T) do (EVAL X))) (COMS (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X)))) (ORIGINAL (LET ((ORIGFLG T)) (DECLARE (SPECVARS ORIGFLG)) (for X on (PRETTYCOM1 PRTTYCOM T) do (PRETTYCOM (CAR X) NIL (AND PRETTYCOMSTAIL X))))) (BLOCKS (SETQ PRTTYTEM (PRETTYCOM1 PRTTYCOM T T)) (PRIN1 "(") (MAPRINT (QUOTE (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY)) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) (for X in PRTTYTEM do (PRINTDEF1 (CONS (QUOTE BLOCK%:) X))) (PRIN1 ") ")) ((*) (COND ((EQ (CADR PRTTYCOM) (QUOTE *)) (* ; "Form-feed if super-comment indicated. Use * no matter what current COMMENTFLG is.") (printout NIL .PAGE)) (T (RPTQ 3 (TERPRI)))) (COND ((AND (COND (FILEFLG FONTCHANGEFLG) (T (EQ FONTCHANGEFLG (QUOTE ALL)))) LAMBDAFONT) (CHANGEFONT LAMBDAFONT) (PRIN2 PRTTYCOM) (CHANGEFONT DEFAULTFONT)) (T (PRIN2 PRTTYCOM))) (RPTQ 2 (TERPRI))) (COND ((AND (LITATOM (CAR PRTTYCOM)) (fetch (FILEPKGTYPE GETDEF) of (CAR PRTTYCOM))) (* ; "If its the name of a type with a GETDEF, put out PUTDEF expressions.") (for X in (PRETTYCOM1 PRTTYCOM T T) do (printout NIL "(" |.P2| (QUOTE PUTDEF) %, |.P2| (KWOTE X) %, |.P2| (KWOTE (CAR PRTTYCOM)) %, .PPV (KWOTE (GETDEF X (CAR PRTTYCOM))) ")" T))) ((FIXSPELL (CAR PRTTYCOM) 70 FILEPKGCOMSPLST T PRTTYCOM) (SETQ PRTTYSPELLFLG T) (GO TOP)) (T (GO ERROR)))))) (RETURN PRTTYCOM) ERROR (ERROR "bad file package command" PRTTYCOM))) ) (PRETTYVAR (LAMBDA (VAR FLG) (* lmm "27-Aug-84 20:15") (* ; "I don't see what FLG is used for--rmk") (PROG (VAL TEM) (* ;; "Dumps value of VAR for reloading. If VAR is non-atomic, of form (var form) where VAR is to be dumped so as to be set to value of form, computed at LOAD time.") (COND ((LITATOM VAR) (AND (EQ (SETQ VAL (GETTOPVAL VAR)) (QUOTE NOBIND)) (printout T T "****WARNING: " |.P2| VAR " is unbound" T T)) (PRETTYVAR1 (QUOTE RPAQQ) VAR VAL)) ((LISTP VAR) (SETQ VAL (CDR VAR)) (SETQ VAR (CAR VAR)) (COND ((AND (EQ (CAR (SETQ TEM (LISTP (CAR (LISTP VAL))))) (QUOTE QUOTE)) (LISTP (CDR TEM))) (PRETTYVAR1 (QUOTE RPAQQ) VAR (CADR TEM))) ((EQ VAR COMMENTFLG) (* ; "don't print out comments")) ((OR (NULL VAL) (AND (LISTP VAL) (OR (NUMBERP (CAR VAL)) (EQ T (CAR VAL)) (NULL (CAR VAL))) (NULL (CDR VAL)))) (* ; "A minor optimization for RPAQQ's to suppresses unnecessary load-time eval's.") (PRETTYVAR1 (QUOTE RPAQQ) VAR (CAR VAL))) (T (PRETTYVAR1 (QUOTE RPAQ) VAR VAL NIL T)))) (T (ERROR "Bad variable specification" VAR))))) ) (PRETTYVAR1 (LAMBDA (OP VAR E DEF TAILFLG) (* ; "Edited 10-Feb-87 18:01 by Pavel") (* ;; "does printing for VAR, ADDVAR, and PROP commands. OP is the name of the function, VAR the operand, and E the rest of the expression to be printed, either as an element, or as a tail if TAILFLG=T. VAR is printed in LAMBDAFONT. If VAR is a list, each element is printed in LAMBDAFONT. This option is used to print both the name of the atom and its property for PROP commands.") (PROG ((LASTCOL (LINELENGTH)) TEM (*PRINT-ARRAY* T)) (* ; "This is supposed to be bound above here but isn't in some case I can't find. --Pavel") (TERPRI) (* ;; "because if you have a really bold font, it lines up the bottoms, but you can get crowded into the line above.") (COND ((AND (MEMB OP (QUOTE (RPAQQ RPAQ RPAQ?))) (EQ (TYPENAME (SETQ TEM (COND (TAILFLG (CAR E)) (T E)))) (QUOTE ARRAYP))) (* ;; "dump arrays and bitmaps specially. This really ought to be handled by having *PRINT-ARRAY* say how to dump these, so that only a single expression ends up on the file.") (* ;; "1 December 1986, Pavel: Well, I fixed bitmaps for this. Maybe I'll fix arrays as well...") (* ;; "10 February 1987, Pavel: ARRAYP's are now fixed as well, but not by using *PRINT-ARRAY*. Rather than invent another non-standard reader macro, I simply store the elements in a list and use a non-READing version of READARRAY.") (COND ((EQ OP (QUOTE RPAQQ)) (SETQQ OP RPAQ))) (printout NIL "(" |.P2| OP %, |.P2| VAR %,) (PRIN2 (BQUOTE (READARRAY-FROM-LIST (\, (ARRAYSIZE TEM)) (QUOTE (\, (ARRAYTYP TEM))) (\, (ARRAYORIG TEM)) (QUOTE (\, (PRINTARRAY-TO-LIST TEM)))))) (printout NIL (QUOTE %)) T)) ((ASSOC OP PRETTYPRINTMACROS) (OR TAILFLG (SETQ E (CONS E))) (PRINTDEF (CONS OP (COND ((LISTP VAR) (APPEND VAR E)) (T (CONS VAR E)))) 0 DEF)) (T (PRIN1 (QUOTE %()) (PRIN2 OP) (SPACES 1) (SETQ TEM (POSITION)) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT PRETTYCOMFONT))) (COND ((LISTP VAR) (MAPRINT VAR NIL NIL NIL NIL (FUNCTION PRIN2))) (T (PRIN2 VAR))) (COND ((AND FONTCHANGEFLG PRETTYCOMFONT) (CHANGEFONT DEFAULTFONT))) (SPACES 1) (PRINTDEF E (COND ((OR (NLISTP E) (FITP E NIL NIL LASTCOL)) (POSITION)) (T TEM)) DEF TAILFLG) (PRIN1 (QUOTE %))))) (TERPRI))) ) (PRETTYCOM1 (LAMBDA (PRTYCOM PRTYFLG REMOVECOMMENTS) (* rmk%: "13-Feb-85 22:54") (PROG (PRTYX) (COND ((AND (EQ (CAR (LISTP (SETQ PRTYX (CDR PRTYCOM)))) (QUOTE *)) (CDR PRTYX)) (COND ((AND (LITATOM (SETQ PRTYX (CADR PRTYX))) PRTYFLG) (* ; "Checks to see if the variable is already being dumped and dumps it if not.") (PRETTYCOM PRTYX))) (SETQ PRTYX (COND (PRTYFLG (EVAL PRTYX)) ((LITATOM PRTYX) (AND (NEQ (SETQ PRTYX (GETTOPVAL PRTYX)) (QUOTE NOBIND)) PRTYX)) (T (RESETVARS (DWIMLOADFNSFLG) (RETURN (AND (ERSETQ (SETQ PRTYX (EVAL PRTYX))) PRTYX)))))))) (RETURN (if (AND REMOVECOMMENTS (LISTP PRTYX)) then (SUBSET PRTYX (FUNCTION (LAMBDA (X) (OR (NLISTP X) (NEQ (CAR X) COMMENTFLG))))) else PRTYX)))) ) (ENDFILE (LAMBDA (FILE) (* wt%: "10-SEP-78 13:54") (PRINT (QUOTE STOP) FILE) (CLOSEF FILE))) (MAKEDEFLIST (LAMBDA (X PROP FLG) (* ; "Edited 11-Feb-87 11:10 by bvm:") (for Z in X bind TEM do (COND ((AND (LITATOM Z) (SETQ TEM (SOME (GETPROPLIST Z) (FUNCTION (LAMBDA (X) (EQ X PROP))) (QUOTE CDDR)))) (PRETTYVAR1 (QUOTE PUTPROPS) (LIST Z PROP) (CADR TEM) (OR (EQ PROP (QUOTE EXPR)) (MEMB PROP MACROPROPS)))) ((NULL FLG) (* ; "PROP command") (EXEC-FORMAT "(no ~S property for ~S)~%%" PROP Z))))) ) (PP (NLAMBDA X (* lmm "15-Nov-86 00:54") (DECLARE (LOCALVARS . T)) (MAPC (NLAMBDA.ARGS X) (FUNCTION (LAMBDA (NAME) (for TYPE in (TYPESOF NAME NIL (QUOTE (FIELDS)) (QUOTE CURRENT)) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE)))))) ) (PP* (NLAMBDA X (* lmm "14-Aug-84 19:11") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with comments not suppressed.") (LET ((**COMMENT**FLG NIL) (*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS **COMMENT**FLG *STANDARD-OUTPUT*)) (PRETTYPRINT (NLAMBDA.ARGS X)))) ) (PPT (NLAMBDA X (* lmm "14-Aug-84 19:12") (DECLARE (LOCALVARS . T)) (* ;; "Prettyprints definitions to terminal with clisp translations shown.") (LET ((*STANDARD-OUTPUT* (GETSTREAM T (QUOTE OUTPUT)))) (DECLARE (SPECVARS *STANDARD-OUTPUT*)) (RESETVARS ((PRETTYTRANFLG T)) (RETURN (PRETTYPRINT (NLAMBDA.ARGS X)))))) ) (PRETTYPRINT (LAMBDA (FNS PRETTYDEFLG FNSLST) (* ; "Edited 11-Feb-87 11:11 by bvm:") (* ;; "PRETTYDEFLG is supplied when called from PRINTFNS. it is either a paatial file map or T, so that it is also used as a flag for whether you are being called from prettydef.") (* ;; "Note that prettyprint does all of its printing to standard output file and using current readtable. it assumes that higher functions have set these appropriately, as is the case when called from prettydef, pp, pp*,") (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT) (GETSTREAM NIL (QUOTE OUTPUT)))) (PROG ((CLK (CLOCK 0)) (NEWADRLST (LISTP PRETTYDEFLG)) (FILEFLG (NOT (DISPLAYP (OUTPUT)))) FN DEF ADR LST SKIPPEDLST TEM) (* ; "NEWADRLST Corresponds to the current entry on NEWFILEMAP. Is in TCONC format.") (COND ((ATOM (SETQ LST FNS)) (SETQ LST (EVALV FNS)))) LP (COND ((NLISTP LST) (RETURN FNS)) ((AND FILEFLG (IGREATERP (CLOCKDIFFERENCE CLK) 30000)) (* ; "Every 30 seconds say what function we're working on") (SETQ CLK (CLOCK 0)) (PRIN2 (CAR LST) T T) (PRIN1 (QUOTE ", ") T))) (SETQ FN (CAR LST)) (TERPRI) (* ; "The initial TERPRI is not in map") (AND NEWADRLST (TCONC NEWADRLST (LIST FN (GETFILEPTR PRTTYFILE)))) (* ; "Address of start.") LP1 (SETQ DEF (VIRGINFN FN)) (AND PRETTYDEFLG (SELECTQ (ARGTYPE DEF) (1 (SETQ NLAMLST (CONS FN NLAMLST))) (2 (SETQ LAMALST (CONS FN LAMALST))) (3 (SETQ NLAMALST (CONS FN NLAMALST))) (NIL (SETQ LAM?LST (CONS FN LAM?LST))) NIL)) (* ; "So prettydef can add the appropriate DECLARE:") (COND ((NULL DEF) (COND ((AND (NULL PRETTYDEFLG) FN (BOUNDP FN)) (* ; "No fn definition, but is a variable. Only make this check when called via PP or PP*") (PRINTDEF (EVALV FN) 2)) (T (GO NOPRINT)))) ((NULL (EXPRP DEF)) (GO NOPRINT)) (T (AND ADDSPELLFLG (ADDSPELL FN)) (COND ((AND PRETTYDEFLG SOURCEFILE (NULL SOURCEFILENV) (NULL (SELECTQ REPRINTFNS (ALL T) ((T EXPRS) (EXPRP FN)) (AND (LISTP REPRINTFNS) (FMEMB FN REPRINTFNS)))) (PRETTYPRINT1 FN)) (* ; "Was a fn to be copied from old file, and we succeeded")) (T (* ; "Prettyprint afresh") (PRETTYPRINT3 FN DEF PRETTYDEFLG))))) DEFPRINTED (* ;;; "At this point we have prettyprinted FN one way or another") (AND NEWADRLST (RPLACD (CDADR NEWADRLST) (GETFILEPTR PRTTYFILE))) (* ; "Store end address") (TERPRI) (* ; "TERPRI is not included in map address") (SETQ LST (CDR LST)) (GO LP) NOPRINT (COND ((AND FILEFLG SOURCEFILE (PRETTYPRINT1 FN)) (GO DEFPRINTED)) ((AND (NULL PRETTYDEFLG) (SETQ TEM (EDITLOADFNS? FN))) (* ; "only make this check when called from PP or PP*") (LOADFNS FN TEM (QUOTE PROP)) (COND ((GETPROP FN (QUOTE EXPR)) (GO LP1))) (PRINT (CONS FN (QUOTE (not found))) T T)) ((AND DWIMFLG (NULL DEF) (SETQ TEM (MISSPELLED? FN 70 USERWORDS (AND PRETTYDEFLG T) LST)) (NEQ TEM FN)) (/RPLACA LST (SETQ FN TEM)) (AND NEWADRLST (FRPLACA (CADR NEWADRLST) FN)) (* ; "Fixes filemap.") (AND PRETTYDEFLG (SETQ PRTTYSPELLFLG T)) (GO LP1))) (EXEC-FORMAT "(~S not printable)~%%" FN) (AND LISPXHISTORY (LISPXPUT (QUOTE *ERROR*) FN NIL (CAAR LISPXHISTORY))) (COND (NEWADRLST (SETQ TEM (NLEFT (CAR NEWADRLST) 2)) (RPLACD TEM) (RPLACD NEWADRLST TEM))) LP3 (SETQ LST (CDR LST)) (GO LP)))) ) (PRETTYPRINT1 (LAMBDA (FN) (* bvm%: "30-Aug-86 17:25") (* ;;; "Like BRECOMPILE1. Obtains FN from SOURCEFILE. works whether the file has previously been mapped by PRETTYDEF, LOAD, or LOADFNS (or patially mapped)") (WITH-READER-ENVIRONMENT (OR SOURCEFILENV DESTINATIONENV) (PROG (ADR TEM) (COND ((NULL OLDFILEMAP) (GO DEFQLP)) ((PRETTYPRINT2 FN) (RETURN FN)) ((NULL (CAR OLDFILEMAP)) (RETURN NIL) (* ; "The entire file has been scanned.")) (T (GO FNLP) (* ; "Already inside of DEFINEQ."))) DEFQLP (* ; "Find DEFINEQ") (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) ((STOP NIL) (* ; "End of file reached.") (SETQ OLDFILEMAP (CONS NIL OLDFILEMAP)) (* ; "Just to inform future calls to PRETTYPRINT1 not to bother scanning.") (RETURN NIL)) (%( (COND ((EQ (SETQ TEM (RATOM SOURCEFILE)) (QUOTE DEFINEQ)) (COND ((NULL OLDFILEMAP) (SETQ OLDFILEMAP (LIST T)) (* ;; "In case functionis found right off, OLDFILEMAP must not be left as NIL or else next call to PRETTYPRINT1 will not realize are alredy inside of DEFINEQ."))) (GO FNLP)) (T (SKREAD SOURCEFILE (QUOTE %())))) (SKREAD SOURCEFILE TEM)) (GO DEFQLP) FNLP (SELECTQ (SETQ TEM (RATOM SOURCEFILE)) (%) (* ; "End of DEFINEQ.") (GO DEFQLP)) ((%( %[) NIL) (SCANFILEHELP)) (SETQ ADR (SUB1 (GETFILEPTR SOURCEFILE))) (SETQ TEM (RATOM SOURCEFILE)) (SETFILEPTR SOURCEFILE ADR) (SKREAD SOURCEFILE) (COND ((EQ TEM FN) (PRETTYPRINT2 FN ADR (GETFILEPTR SOURCEFILE)) (* ; "copies the bytes.") (RETURN FN)) (T (SETQ OLDFILEMAP (CONS (CONS TEM (CONS ADR (GETFILEPTR SOURCEFILE))) OLDFILEMAP)) (* ;; "Note that this situation only occurs when (a) the entire file was not peviously scanned, e.g. if loaded with buildmapflg off, and (b) user is doing a remake, and (c) this functio was either dumped directly because it was changed, or else it has been deleted from the FNS. The function is added to OLDFILEMAP just in case it is out of order.") (GO FNLP)))))) ) (PRETTYPRINT2 (LAMBDA (FN FROM TO) (* bvm%: "30-Aug-86 18:13") (* ;; "Copies function from sourcefile to prettyfile. looking it up on the map when not already given address. returns nil if not there") (PROG (TEM) (COND (FROM) ((for X in OLDFILEMAP thereis (COND ((NLISTP X) NIL) ((EQ (CAR X) FN) (* ;; "occurs when remaking a file without a map, and a function is previously skipped that later is needed.") (SETQ TEM X)) ((LISTP (CDDR X)) (SETQ TEM (FASSOC FN (CDDR X)))))) (SETQ FROM (CADR TEM)) (SETQ TO (CDDR TEM))) (T (RETURN NIL))) (SETFILEPTR SOURCEFILE FROM) (RATOM SOURCEFILE) (* ;; "The RATOM skips the paren. the reason for the RATOM instead of simply setting file ptr to (ADD1 FROM) is that there may be font info there.") (COND ((NEQ FN (SETQ TEM (READ SOURCEFILE))) (* ; "Consistency check.") (LISPXPRINT (CONS FN TEM) T) (ERROR (QUOTE "filemap does not agree with contents of") SOURCEFILE T))) (if (NULL SOURCEFILENV) then (* ; "compatible environments, just copy characters") (COPYCHARS SOURCEFILE PRTTYFILE FROM TO) else (* ; "incompatible, have to read old def and reprettyprint") (SETQ TEM (READ SOURCEFILE)) (* ; "old definition") (WITH-READER-ENVIRONMENT DESTINATIONENV (PRETTYPRINT3 FN TEM T))) (* ; "Initial and final TERPRI's are done by callers; they are not in map.") (RETURN FN))) ) (PRETTYPRINT3 (LAMBDA (FN DEF PRETTYDEFLG) (* bvm%: "30-Aug-86 17:18") (LET (TEM) (AND (OR (SELECTQ CLISPIFYPRETTYFLG ((T EXPRS) (EXPRP FN)) (ALL T) (CHANGES (AND PRETTYDEFLG (MEMB FN CHANGES))) (MEMB FN CLISPIFYPRETTYFLG)) (AND (SUPERPRINTEQ (CAR (SETQ TEM (CADDR DEF))) COMMENTFLG) (EQ (CADR TEM) (QUOTE DECLARATIONS%:)) (MEMB (QUOTE CLISPIFY) TEM))) (SETQ DEF (CLISPIFY DEF))) (* ;; "If the function is stored on property list, only clispify if user specifically said MAKEFILE (file CLISPIFY), otherwise, assume that functions on property list have already been clispified") (COND ((AND LAMBDAFONT FONTCHANGEFLG) (PRIN1 (QUOTE %()) (* ;; "The font change is after the paren because of problems with updating filemaps when moving back and forth between -10 and -D systems--rmk") (CHANGEFONT LAMBDAFONT) (PRIN2 FN) (CHANGEFONT DEFAULTFONT) (TERPRI)) (T (PRIN1 (QUOTE %()) (PRINT FN))) (PRINTDEF DEF 2 (QUOTE FNS) NIL FNSLST) (PRIN1 (QUOTE %))) FN)) ) (PRINTDEF1 [LAMBDA (EXPR FORMFLG) (* ; "Edited 16-Apr-2018 21:35 by rmk:") (* ; "Edited 16-Apr-2018 10:14 by rmk:") (* ; "Edited 14-Apr-88 18:21 by bvm") (* ;; "RMK: Special for DEFUNs: build filemap as per PRINTFNS") (* ;; "Used by MAKEFILE to print P, etc expressions. ") (TERPRI) (LET (STARTPOS ENDPOS) (IF (AND FORMFLG NEWFILEMAP (EQ (CAR EXPR) 'CL:DEFUN)) THEN (SETQ STARTPOS (GETFILEPTR PRTTYFILE))) (PRINTDEF EXPR NIL FORMFLG NIL FNSLST) [IF STARTPOS THEN (SETQ ENDPOS (GETFILEPTR PRTTYFILE)) (NCONC1 NEWFILEMAP (LIST STARTPOS ENDPOS (CONS (CADR EXPR) (CONS STARTPOS ENDPOS] (TERPRI]) (SUPERPRINTEQ (LAMBDA (X Y) (OR (EQ X Y) (AND Y (EQ (CDR (FASSOC X PRETTYEQUIVLST)) Y))))) (SUPERPRINTGETPROP (LAMBDA (ATM PROP) (* wt%: "17-SEP-79 15:57") (OR (GETPROP (CDR (FASSOC ATM PRETTYEQUIVLST)) PROP) (GETPROP ATM PROP))) ) (CHANGEFONT (LAMBDA (FONTCLASS FILE) (* lmm "17-Jan-86 20:59") (* ;; "for calls to changefont when not under prettyprin prettydef. This is only for non-D systems. For D, DSPFONT is moved'ed in.") (* ;; "Don't bother testing for FONTCHANGEFLG=ALL, because presumably the FONTCLASS will have a NULL entry if display printing isn't wanted. FONTCHANGEFLG=ALL tests are really only needed if something expensive can be avoided by advance knowledge.") (AND FONTCHANGEFLG FONTCLASS (DSPFONT FONTCLASS FILE))) ) ) (DEFINEQ (READARRAY (LAMBDA (SIZE TYPE ORIG) (* rrb " 4-JUL-80 17:07") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (COND ((NEQ (READC) (QUOTE %()) (GO LP))) (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (READ)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (READ)) (SETQ M (ADD1 M)) (GO LP2))) OUT (READ) (* ; "Reads the final right parentheses surrounding the elements of the array.") (RETURN A))) ) (PRINTARRAY (LAMBDA (V) (* bvm%: " 3-Oct-86 12:57") (* ; "Used by prettydef. Included in ABASIC because it uses LOC and VAG on the 10") (PROG (A N M TYPE FLG DOUBLEFLG ORIG) (COND ((AND (LITATOM V) (ARRAYP (SETQ A (EVALV V (QUOTE PRINTARRAY))))) (PRINT (BQUOTE (SETQ (\, V) (READARRAY (\, (SETQ N (ARRAYSIZE A))) (QUOTE (\, (SETQ TYPE (ARRAYTYP A)))) (\, (SETQ ORIG (ARRAYORIG A)))))))) ((ARRAYP V) (* ; "Just dumps the element expression--assumes that READARRAY has already been written") (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (PRIN1 (QUOTE %()) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (COND ((OR (EQ TYPE (QUOTE POINTER)) DOUBLEFLG) (PRINT (ELT A (SUB1 (IPLUS M ORIG))))) (T (* ; "changed from PRINT to PRIN2 so would look better in file.") (PRIN2 (ELT A (SUB1 (IPLUS M ORIG)))) (SPACES 1))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP)) ((NULL (PRINT FLG)) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (PRINT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (PRIN1 (QUOTE %))) (RETURN A))) ) (READARRAY-FROM-LIST (LAMBDA (SIZE TYPE ORIG ELEMENTS) (* ; "Edited 10-Feb-87 17:59 by Pavel") (* ;;; "This is not written in the most straightforward way possible. Rather, in order to minimize the possibility of destabilization, we have kept this as much like READARRAY as possible. In essence, the only change is to use POP instead of READ.") (* ;; "type is one of: POINTER, FIXP, SMALLPOSP BYTE DOUBLEPOINTER or a number which is the place (between 0 and SIZE) where FIXPs stop and POINTERs begin.") (PROG (X (A (ARRAY SIZE TYPE NIL ORIG)) M DELTA) LP (SETQ M 1) (SETQ DELTA (SUB1 (OR ORIG 1))) LP1 (COND ((NOT (IGREATERP M SIZE)) (SETA A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP1)) ((NULL (pop ELEMENTS)) (* ;; "PRINTARRAY writes a NIL if there are no elements in the array for which the left half must be set using SETD, otherwise it writes a T.") (GO OUT))) (SETQ M (COND ((NUMBERP TYPE) (ADD1 TYPE)) ((EQ TYPE (QUOTE DOUBLEPOINTER)) 1) (T (SHOULDNT)))) LP2 (COND ((NOT (IGREATERP M SIZE)) (SETD A (IPLUS M DELTA) (pop ELEMENTS)) (SETQ M (ADD1 M)) (GO LP2))) OUT (RETURN A))) ) (PRINTARRAY-TO-LIST (LAMBDA (V) (* ; "Edited 10-Feb-87 18:09 by Pavel") (* ;;; "This code is not written in the most straighforward way possible. Rather, to minimize the possibility of destabilization, we attempt to make it as much like PRINTARRAY as we can. In essence, the only changes are to PUSH the elements onto RESULT instead of printing them. At the end, we return the reversal of RESULT.") (PROG ((RESULT NIL) A N M TYPE FLG DOUBLEFLG ORIG) (COND ((ARRAYP V) (SETQ A V) (SETQ N (ARRAYSIZE A)) (SETQ TYPE (ARRAYTYP A)) (SETQ ORIG (ARRAYORIG A))) (T (RETURN (HELP V "not array")))) (SETQ DOUBLEFLG (OR (EQ TYPE (QUOTE DOUBLEPOINTER)) (NUMBERP TYPE))) (* ; "note if this array has different ELTD.") (SETQ M 1) LP (COND ((NOT (IGREATERP M N)) (push RESULT (ELT A (SUB1 (IPLUS M ORIG)))) (* ;; "check for any non-NIL entries in the ELTD part of the double arrays. If there are none, format for print out avoids lots of NILs.") (AND DOUBLEFLG (COND ((NUMBERP TYPE) (* ; "check for M being in the double pointer part of the array") (IGREATERP M TYPE)) (T T)) (ELTD A (SUB1 (IPLUS M ORIG))) (SETQ FLG T)) (SETQ M (ADD1 M)) (GO LP))) (push RESULT FLG) (COND ((NULL FLG) (* ; "if FLG is NULL, there are non-NIL double word entries.") (GO OUT))) (SETQ M (COND ((EQ TYPE (QUOTE DOUBLEPOINTER)) (* ; "all entries are double") 1) ((NUMBERP TYPE) (* ; "first TYPE elements in the array are numbers") (ADD1 TYPE)))) LP1 (COND ((NOT (IGREATERP M N)) (push RESULT (ELTD A (SUB1 (IPLUS M ORIG)))) (SETQ M (ADD1 M)) (GO LP1))) OUT (RETURN (REVERSE RESULT)))) ) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CHANGFONT MACRO (= . DSPFONT)) ) ) (* ; "COPYRIGHT") (DEFINEQ (PRINTCOPYRIGHT [LAMBDA (FILENAME) (* ; "Edited 31-Aug-99 09:06 by rmk:") (* ; "Edited 31-Aug-99 09:01 by rmk:") (* edited%: " 1-Jan-85 20:16") (* ;;; "CALLED BY PRETTYDEF TO PUT a copyright notice on a file. The globalvar COPYRIGHTOWNERS is used to determine the possible copyright owners when it is determined the file doesn't have a copyright yet and has never been asked if the programmer wanted one. The whole copyright mechanism can be turned off by setting COPYRIGHTFLG to NEVER -- originaly NIL. If the file is copyrighted, any year the file is editted the new year is tacked on to the list of copyright years. The copyright notice comes immediately after the FILECREATED expression * *") (PROG [(OWNER (GETPROP FILENAME 'COPYRIGHT] (AND [OR OWNER (AND COPYRIGHTFLG (SETQ OWNER (ASKUSER (if (EQ COPYRIGHTFLG 'DEFAULT) then 0 else DWIMWAIT) (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT "Copyright owner for file " FILENAME ": ") (NCONC [MAPCAR COPYRIGHTOWNERS (FUNCTION (LAMBDA (X) (LIST (CAR X) "" 'EXPLAINSTRING (CONCAT (CAR X) " - " (CADR X)) 'RETURN (CADR X) 'CONFIRMFLG T] (CONS (if (SETQ OWNER (ASSOC DEFAULTCOPYRIGHTOWNER COPYRIGHTOWNERS)) then (LIST (CONSTANT (CHARACTER (CHARCODE LF))) (CONCAT DEFAULTCOPYRIGHTOWNER " ") 'EXPLAINSTRING (CONCAT " - " (CADR OWNER) " [Default]") 'NOECHOFLG T 'RETURN (CADR OWNER)) else '(% "No copyright notice now " EXPLAINSTRING " - no copyright notice now [Default]" NOECHOFLG T RETURN NIL)) DEFAULTCOPYRIGHTKEYLST)) T T)) (/PUTPROP FILENAME 'COPYRIGHT (SETQ OWNER (LIST OWNER] (COND ((NEQ (CAR OWNER) 'NONE) (PROG ((CURRENTYEAR (SUBATOM (DATE (DATEFORMAT YEAR.LONG NO.TIME)) -4 -1))) (OR (MEMBER CURRENTYEAR (CDR OWNER)) (NCONC1 OWNER CURRENTYEAR))) (PRINTCOPYRIGHT1 OWNER]) (PRINTCOPYRIGHT1 [LAMBDA (OWNER) (* ; "Edited 6-Apr-90 10:36 by jds") (PROG ((DATES (CDR OWNER)) (SEMICOLON (AND (READTABLEPROP *READTABLE* 'COMMONLISP) "; ")) (PRIVATE NIL)) (COND ((EQ (CAR DATES) T) (SETQ PRIVATE T) (pop DATES))) (COND (SEMICOLON (* ; "do CommonLisp style comment") (PRIN1 SEMICOLON)) (T (* ; "Print IL-style comment, with a ; in it so the pretty printer will render it as a CL-style comment.") (printout NIL "(" |.P2| '* '% '; " %" "))) (PRIN3 "Copyright (c) ") [for Y on DATES do (* ;  "print years of copyright, e.g., 1985, 1986") (PRINTNUM '(FIX 4) (CAR Y)) (COND ((CDR Y) (PRIN3 ", "] (PRIN3 " by ") (PRIN3 (CAR OWNER)) (PRIN3 ".") (AND COPYRIGHTSRESERVED (PRIN3 " All rights reserved.")) (TERPRI) [COND (PRIVATE (for LINE in (CONS (CONCAT "The following program was created in " (CAR DATES) " 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.")) do (COND (SEMICOLON (PRIN1 SEMICOLON))) (printout NIL LINE T] (COND ((NOT SEMICOLON) (PRIN1 "%") "))) (TERPRI]) (SAVECOPYRIGHT (LAMBDA (FILENAME) (* lmm "25-DEC-82 16:48") (* ;; "Called from PRETTYDEF to save copyright info on end of file") (AND (NEQ COPYRIGHTFLG (QUOTE NEVER)) (PROG (X) (COND ((SETQ X (GETPROP FILENAME (QUOTE COPYRIGHT))) (PRINT (LIST (QUOTE PUTPROPS) FILENAME (QUOTE COPYRIGHT) X))))))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL PRINTCOPYRIGHT PRINTCOPYRIGHT1 SAVECOPYRIGHT (LOCALVARS . T) (NOLINKFNS PRINTCOPYRIGHT1)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTFLG COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST DEFAULTCOPYRIGHTOWNER COPYRIGHTSRESERVED) ) (RPAQ? COPYRIGHTFLG ) (RPAQ? DEFAULTCOPYRIGHTOWNER ) (RPAQ? COPYRIGHTPRETTYFLG T) (RPAQ? COPYRIGHTOWNERS ) (RPAQ? DEFAULTCOPYRIGHTKEYLST '((NONE " " EXPLAINSTRING "NONE - No copyright ever on this file" CONFIRM T RETURN 'NONE) [%[ "owner: " EXPLAINSTRING "[ - new copyright owner -- type one line of text" NOECHOFLG T KEYLST (( " " RETURN (SUBSTRING (CADR ANSWER) 2 -2] (%] "No copyright notice now " EXPLAINSTRING "] - no copyright notice now" NOECHOFLG T RETURN NIL))) (RPAQ? COPYRIGHTSRESERVED T) (RPAQ? *NEW-INTERLISP-MAKEFILE-ENVIRONMENT* '(:READTABLE "INTERLISP" :PACKAGE "INTERLISP")) (RPAQ? *DEFAULT-MAKEFILE-ENVIRONMENT* ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS COPYRIGHTOWNERS DEFAULTCOPYRIGHTKEYLST COPYRIGHTPRETTYFLG COMMENTFLG *DEFAULT-MAKEFILE-ENVIRONMENT* *NEW-INTERLISP-MAKEFILE-ENVIRONMENT*) ) (RPAQ? COMMENTFLG '*) (RPAQ? **COMMENT**FLG '" **COMMENT** ") (RPAQ? PRETTYFLG T) (RPAQ? %#RPARS 4) (RPAQ? CLISPIFYPRETTYFLG ) (RPAQ? PRETTYTRANFLG ) (RPAQ? FONTCHANGEFLG ) (RPAQ? CHANGECHARTABSTR ) (RPAQ? PRETTYTABFLG T) (RPAQ? DECLARETAGSLST '(COMPILERVARS COPY COPYWHEN DOCOPY DOEVAL@COMPILE DOEVAL@LOAD DONTCOPY DONTEVAL@COMPILE DONTEVAL@LOAD EVAL@COMPILE EVAL@COMPILEWHEN EVAL@LOAD EVAL@LOADWHEN FIRST NOTFIRST)) (RPAQ? AVERAGEVARLENGTH 4) (RPAQ? AVERAGEFNLENGTH 5) (RPAQ? %#CAREFULCOLUMNS 0) (RPAQ? CHANGECHAR '%|) (RPAQ? ENDLINEUSERFN ) (RPAQ? PRETTYDEFMACROS ) (RPAQ? PRETTYPRINTMACROS ) (RPAQ? PRETTYEQUIVLST ) (RPAQ? PRETTYPRINTYPEMACROS ) (RPAQ? FILEPKGCOMSPLST '(DECLARE%: SPECVARS LOCALVARS GLOBALVARS PROP IFPROP P VARS INITVARS ADDVARS APPENDVARS FNS ARRAY E COMS ORIGINAL BLOCKS *)) (RPAQ? SYSPROPS '(PROPTYPE ALISTTYPE DELDEF EDITDEF PUTDEF GETDEF WHENCHANGED NOTICEFN NEWCOMFN PRETTYTYPE DELFROMPRETTYCOM ADDTOPRETTYCOM ACCESSFN ACS AMAC ARGNAMES BLKLIBRARYDEF BROADSCOPE CLISPCLASS CLISPCLASSDEF CLISPFORM CLISPIFYISPROP CLISPINFIX CLISPISFORM CLISPISPROP CLISPNEG CLISPTYPE CLISPWORD CLMAPS CODE CONVERT COREVAL CROPS CTYPE EDIT-SAVE EXPR FILE FILECHANGES FILEDATES FILEDEF FILEGROUP FILEHISTORY FILEMAP FILETYPE GLOBALVAR HISTORY I.S.OPR I.S.TYPE INFO LASTVALUE LISPFN MACRO MAKE NAMESCHANGED NARGS OLDVALUE OPD SETFN SUBR UBOX UNARYOP VALUE \DEF CLISPBRACKET TRYHARDER)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: PRETTYPRINTBLOCK PRETTYPRINT PRETTYPRINT1 PRETTYPRINT2 (ENTRIES PRETTYPRINT) (SPECVARS FNSLST FILEFLG)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS DECLARETAGSLST LISPXPRINTFLG SYSPROPS FILEPKGCOMSPLST DWIMLOADFNSFLG PRETTYHEADER FILERDTBL PRETTYEQUIVLST PRETTYTRANFLG CLISPIFYPRETTYFLG LISPXHISTORY DWIMFLG USERWORDS COMMENTFLG) ) (DECLARE%: EVAL@COMPILE DOCOPY (CL:PROCLAIM '(CL:SPECIAL DEFAULTFONT LAMBDAFONT PRETTYCOMFONT COMMENTFONT **COMMENT**FLG PRETTYPRINTMACROS)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (IMPORT) FILEPKG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PPT PP* PP) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PRETTY COPYRIGHT ("Venue & Xerox Corporation" T 1984 1985 1986 1987 1988 1989 1990 1999 2018 )) (DECLARE%: DONTCOPY (FILEMAP (NIL (5962 40703 (PRETTYDEF 5972 . 14235) (PRETTYDEFCOMS 14237 . 14919) (PRETTYDEF0 14921 . 15112) (PRETTYDEF1 15114 . 16877) (PRINTDATE 16879 . 18115) (PRINTDATE1 18117 . 19322) (PRINTFNS 19324 . 19893) (PRETTYCOM 19895 . 26236) (PRETTYVAR 26238 . 27276) (PRETTYVAR1 27278 . 29496) (PRETTYCOM1 29498 . 30202) (ENDFILE 30204 . 30300) (MAKEDEFLIST 30302 . 30706) (PP 30708 . 30984) (PP* 30986 . 31299) (PPT 31301 . 31620) (PRETTYPRINT 31622 . 34774) (PRETTYPRINT1 34776 . 36662) (PRETTYPRINT2 36664 . 37980) (PRETTYPRINT3 37982 . 38937) (PRINTDEF1 38939 . 39947) (SUPERPRINTEQ 39949 . 40043) ( SUPERPRINTGETPROP 40045 . 40189) (CHANGEFONT 40191 . 40701)) (40704 46050 (READARRAY 40714 . 41640) ( PRINTARRAY 41642 . 43382) (READARRAY-FROM-LIST 43384 . 44489) (PRINTARRAY-TO-LIST 44491 . 46048)) ( 46177 52632 (PRINTCOPYRIGHT 46187 . 49959) (PRINTCOPYRIGHT1 49961 . 52327) (SAVECOPYRIGHT 52329 . 52630))))) STOP \ No newline at end of file diff --git a/sources/PRINTFN b/sources/PRINTFN new file mode 100644 index 00000000..b25858ae --- /dev/null +++ b/sources/PRINTFN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "16-Apr-2018 21:40:32" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRINTFN.;4 14468 changes to%: (FNS PF) previous date%: "28-Jun-99 17:09:59" {DSK}kaplan>Local>medley3.5>lispcore>sources>PRINTFN.;3) (* ; " Copyright (c) 1986, 1987, 1990, 1999, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PRINTFNCOMS) (RPAQQ PRINTFNCOMS [(* * PRINTFN) (FNS PF PF* PMORE PRINTFN PRINTFNDEF FINDFNDEF PFCOPYBYTES DISPLAYP) (INITVARS PFDEFAULT (LASTFNDEF)) (DECLARE%: DONTCOPY (MACROS PFPRINCHAR PFOUTCHAR)) (P (MOVD? 'COPYBYTES 'PFCOPYBYTES)) (USERMACROS PF) (GLOBALVARS **COMMENT**FLG LASTFNDEF LASTWORD PFDEFAULT FILERDTBL USEMAPFLG) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA PF* PF) (NLAML) (LAMA]) (* * PRINTFN) (DEFINEQ (PF [NLAMBDA FN (* ; "Edited 4-Apr-2018 11:13 by rmk:") (* ;; "RMK; Fixed to skip compiled files, also to use FUNCTIONS as well as FNS. That might not help, if FUNCTIONS are not included in the filemap.") (* ;; "Print from files known to masterscope database before looking at whereis database. Note, however, that it also prefers the masterscope database to incore files") (* ;; "If FN is NIL, prints the function named by LASTWORD") (* ;; "If FN is a list, then extra args are interpreted as:") (* ;; " OUTPUT FILE") (* ;; "...") (RESETLST (PROG (OUT OTHERARGS IFILES) (SETQ FN (NLAMBDA.ARGS FN)) (* ; "Grab the args as a list") [COND ((LISTP FN) (* ;  "If it's a list, take the first element as the function name.") (SETQ OTHERARGS (CDR FN)) (SETQ FN (CAR FN] (COND (FN (* ; "FN name specified; use it.") (SETQ LASTWORD FN)) (T (* ; "Not specified, use LASTWORD") (SETQ FN LASTWORD))) [SETQ IFILES (OR (CAR OTHERARGS) (APPEND (WHEREIS FN 'FNS T) (WHEREIS FN 'FUNCTIONS T] [RESETSAVE (OUTPUT (COND ((CADR OTHERARGS) (* ;  "An output file was specified; if not open for output, open it.") (OR (OPENP (CADR OTHERARGS) 'OUTPUT) (WINDOWP (CADR OTHERARGS)) (PROGN [RESETSAVE (SETQ OUT (OPENFILE (CADR OTHERARGS) 'OUTPUT)) '(PROGN (CLOSEF? OLDVALUE] OUT))) (T (* ; "otherwise, use primary output.") T] (* ; "skip compiled files") (FOR FILE INSIDE IFILES UNLESS (MEMB (FILENAMEFIELD FILE 'EXTENSION) *COMPILED-EXTENSIONS*) DO (PRINTFN FN FILE))))]) (PF* [NLAMBDA FN (* ; "Edited 10-Jun-87 11:09 by jds") (* ;;; "Print the function FN (or LASTWORD), with comments visible to the user.") (RESETVARS (**COMMENT**FLG) (APPLY (FUNCTION PF) FN]) (PMORE [LAMBDA NIL (* lmm " 9-AUG-78 17:21") (* lmm "17-MAY-78 15:38") (PRINTFNDEF (CAR LASTFNDEF) T (CADDR LASTFNDEF) -1 (CADDDR LASTFNDEF]) (PRINTFN [LAMBDA (FN FROMFILE TOFILE) (* lmm "14-Aug-84 14:16") (PROG ((LOC (FINDFNDEF FN FROMFILE))) (COND ((LISTP LOC) (SETQ LASTFNDEF LOC) (PRINTFNDEF (CAR LOC) TOFILE (CADR LOC) (CADDR LOC) (CADDDR LOC)) (RETURN FN)) ((EQ LOC 'FILE.NOT.FOUND) (printout TOFILE "file " FROMFILE " not found." T)) (T (printout TOFILE FN " not found on " LOC "." T]) (PRINTFNDEF [LAMBDA (SRCFIL DSTFIL START END TYPE) (* bvm%: " 9-Sep-86 15:54") (RESETLST (PROG (TEM) [COND ((SETQ TEM (GETSTREAM DSTFIL 'OUTPUT T)) (SETQ DSTFIL TEM)) (T (RESETSAVE (SETQ DSTFIL (OPENSTREAM DSTFIL 'OUTPUT)) '(PROGN (CLOSEF? OLDVALUE] [COND ((SETQ TEM (GETSTREAM SRCFIL 'INPUT T)) (RESETSAVE NIL (LIST 'SETFILEPTR TEM (GETFILEPTR TEM))) (SETQ SRCFIL TEM)) (T (RESETSAVE (SETQ SRCFIL (OPENSTREAM SRCFIL 'INPUT)) '(PROGN (CLOSEF? OLDVALUE] (PRIN1 "{from " DSTFIL) (PRIN2 (FULLNAME SRCFIL) DSTFIL T) (PRIN1 "} " DSTFIL)) (COND ((OR (NOT (DISPLAYP DSTFIL)) (EQ PFDEFAULT 'COPYBYTES) (EQ TYPE 'MAC)) (COPYBYTES SRCFIL DSTFIL START END)) (T (PFCOPYBYTES SRCFIL DSTFIL START END PFDEFAULT))) (TERPRI DSTFIL]) (FINDFNDEF [LAMBDA (FN FROMFILE) (* bvm%: "27-Aug-86 16:27") (* * "Locates FNS definition of FN on FROMFILE. If found, returns a list (file start end type); if file not found, returns symbol FILE.NOT.FOUND; if file found but not fn, returns full name of file that was found") (LET (FULL MAP VALUE) (COND ((NOT (SETQ FULL (FINDFILE FROMFILE T))) 'FILE.NOT.FOUND) [(COND ((SETQ MAP (OR (GETFILEMAP FULL) (LOADFILEMAP FULL))) (* First clause is quick check when the file already has a map.  LOADFILEMAP will find file map, rebuild if necessary and rewrite it on file if  updatemapflg is T.) (AND (for GROUP in (CDR MAP) thereis (SETQ VALUE (FASSOC FN GROUP))) (LIST FULL (CADR VALUE) (CDDR VALUE) 'MAP] (T FULL]) (PFCOPYBYTES [LAMBDA (SRCFIL DSTFIL START END FLG) (* ; "Edited 29-Mar-96 11:51 by rmk") (* ; "Edited 24-Mar-93 14:16 by rmk:") (* lmm "28-Sep-86 14:38") (* ;; " copy from SRCFIL to DSTFIL, paying attention to font changes. Other stuff about truncating lines gone away. Interprets all possible EOL conventions as EOL. Has to call \NSIN macro in order to keep track of character count--READDCODE doesn't do that.") (DECLARE (GLOBALVARS CHANGECHAR COMMENTFLG **COMMENT**FLG)) (RESETLST (PROG ((SSTRM (\INSTREAMARG SRCFIL)) (DSTRM (\OUTSTREAMARG DSTFIL)) FONTARRAY CHARCODE %#CHARS MAXFONT) (DECLARE (SPECVARS . T)) (COND ((IMAGESTREAMP DSTRM) (SETQ FONTARRAY (FONTMAPARRAY)) (SETQ MAXFONT (ARRAYSIZE FONTARRAY)) (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT NIL DSTRM) DSTRM)) (DSPFONT (ELT FONTARRAY 1) DSTRM))) (SETQ %#CHARS (COND (END (SETFILEPTR SSTRM START) (* ;; "Doesn't call \SETFILEPTR cause START has to be checked") (IDIFFERENCE (COND ((EQ END -1) (GETEOFPTR SSTRM)) (T END)) START)) (START) (T (* ; "Stop on end of file") (RESETSAVE NIL (LIST [FUNCTION (LAMBDA (STREAM FN) (REPLACE ENDOFSTREAMOP OF STREAM WITH FN] SSTRM (FETCH ENDOFSTREAMOP OF SSTRM))) (REPLACE ENDOFSTREAMOP OF SSTRM WITH (FUNCTION NILL)) MAX.SMALL.INTEGER))) (COND ((AND START (ILEQ %#CHARS 0)) (RETURN T))) LP [COND ((ILEQ %#CHARS 0) (COND (START (RETURN T)) (T (* ;  "Just keep the counter going until EOF") (SETQ %#CHARS MAX.SMALL.INTEGER] (SETQ CHARCODE (\NSIN SSTRM (UNFOLD (ACCESS-CHARSET SSTRM) 256) NIL %#CHARS)) (SELCHARQ CHARCODE ((LINEFEED EOL) (* ;  "Output CR, since we don't rely on EOL convention") (TERPRI DSTRM) (GO LP)) (CR (* ;; "Consume next LF, since we don't rely on EOL convention") (CL:WHEN (EQ (CHARCODE LF) (\PEEKBIN SSTRM T)) (\BIN SSTRM) (SETQ %#CHARS (SUB1 %#CHARS))) (TERPRI DSTRM) (GO LP)) (NIL (TERPRI DSTRM) (* ;  "This is the EOF when we are copying the whole file") (RETURN T)) (^F (* ;  "Don't do EOL interpretation after ^F") (SETQ CHARCODE (\NSIN SSTRM (UNFOLD (ACCESS-CHARSET SSTRM) 256) NIL %#CHARS)) (COND ((AND (IGEQ MAXFONT CHARCODE) (NEQ CHARCODE 0)) (DSPFONT (ELT FONTARRAY CHARCODE) DSTRM) (GO LP)))) NIL) (\OUTCHAR DSTRM CHARCODE) (GO LP)))]) (DISPLAYP [LAMBDA (STREAM) (* AJB "23-Sep-85 14:53") (LET ((STRM (\OUTSTREAMARG STREAM T))) (AND STRM (OR (DISPLAYSTREAMP STRM) (IMAGESTREAMTYPEP STRM 'TEXT]) ) (RPAQ? PFDEFAULT NIL) (RPAQ? LASTFNDEF ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS PFPRINCHAR MACRO ((CC) (COND (EOLFLG (TERPRI DSTRM) (SETQ EOLFLG NIL) (SETQ HPOS LMAR))) (COND ((NOT (ZEROP %#SPACES)) (FRPTQ (COND ((OR FLG STRFLG) %#SPACES) (T (FOLDHI %#SPACES 2))) (PFOUTCHAR (CHARCODE SPACE))) (SETQ %#SPACES 0))) (PFOUTCHAR CC))) (PUTPROPS PFOUTCHAR MACRO ((CC) ([LAMBDA (WIDTH) (COND ((AND WIDTH (IGREATERP (add HPOS WIDTH) RMAR)) (* past RIGHT margin, force eol) (TERPRI DSTRM) (SETQ HPOS WIDTH))) (\OUTCHAR DSTRM CC] (\STREAMCHARWIDTH CC DSTRM \PRIMTERMTABLE)))) ) ) (MOVD? 'COPYBYTES 'PFCOPYBYTES) (ADDTOVAR EDITMACROS [PF NIL (ORR [(E (APPLY* 'PF (FIRSTATOM (%##] ((E 'PF?]) (ADDTOVAR EDITCOMSA PF) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS **COMMENT**FLG LASTFNDEF LASTWORD PFDEFAULT FILERDTBL USEMAPFLG) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA PF* PF) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS PRINTFN COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1999 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1112 12351 (PF 1122 . 3817) (PF* 3819 . 4117) (PMORE 4119 . 4442) (PRINTFN 4444 . 5039) (PRINTFNDEF 5041 . 6263) (FINDFNDEF 6265 . 7321) (PFCOPYBYTES 7323 . 12097) (DISPLAYP 12099 . 12349)) ))) STOP \ No newline at end of file diff --git a/sources/PROC b/sources/PROC new file mode 100644 index 00000000..b773ff40 --- /dev/null +++ b/sources/PROC @@ -0,0 +1,2220 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-Jun-99 21:58:52" {DSK}medley3.5>sources>PROC.;2 173526 changes to%: (RECORDS MONITORLOCK) previous date%: "31-Jan-98 18:03:02" {DSK}medley3.5>sources>PROC.;1) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1998, 1999 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 PROCCOMS) (RPAQQ PROCCOMS [(COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS PROCESS)) (RECORDS PROCESSQUEUE) (CONSTANTS \PSTAT.WAITING \PSTAT.RUNNING \PSTAT.DELETED)) (INITRECORDS PROCESS PROCESSQUEUE) (SYSRECORDS PROCESS PROCESSQUEUE)) [COMS (* ; "User entries") (FNS PROCESSWORLD ADD.PROCESS DEL.PROCESS PROCESS.RETURN FIND.PROCESS MAP.PROCESSES PROCESSP RELPROCESSP RESTART.PROCESS WAKE.PROCESS SUSPEND.PROCESS PROCESS.RESULT PROCESS-STATUS PROCESS.FINISHEDP) (FNS THIS.PROCESS TTY.PROCESS TTY.PROCESSP PROCESS.TTY GIVE.TTY.PROCESS ALLOW.BUTTON.EVENTS SPAWN.MOUSE \WAIT.FOR.TTY WAIT.FOR.TTY) (FNS RESET ERROR!) [INITVARS (TTY.PROCESS.DEFAULT '(EXEC MOUSE)) (\TTY.PROCESS.EVENT) (\TTY.PROCESS) (\PROCESS.NAME.TABLE (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL] (GLOBALVARS TTY.PROCESS.DEFAULT \TTY.PROCESS.EVENT \PROCESS.NAME.TABLE) (FNS PROCESSPROP PROCESS.NAME PROCESS.WINDOW) (PROP ARGNAMES PROCESSPROP ADD.PROCESS) (COMS (* ; "Temporary") (P (MOVD? 'PROCESS.RETURN 'KILL.ME NIL T] (COMS (FNS DISMISS BLOCK WAITFORINPUT \WAITFORSYSBUFP) (* ; "Used to be a GLOBALRESOURCES") (DECLARE%: DONTCOPY (RESOURCES \DISMISSTIMER)) (INITRESOURCES \DISMISSTIMER)) (COMS (FNS EVAL.AS.PROCESS EVAL.IN.TTY.PROCESS) (* ;; "The PROCESS.WAIT macro is an augmentation to BLOCK, waiting for a condition to come true, or a timeout, or a wakeup") (MACROS PROCESS.WAIT) (FNS PROCESS.READ PROCESS.EVALV PROCESS.EVAL \PROCESS.EVAL1 PROCESS.APPLY \PROCESS.APPLY1) (* ;  "Standard values for WAKEREASON -- PSTAT.TIMEDOUT is the only public one") (VARS (PSTAT.WAKEUP "default WakeUp") (PSTAT.TIMEDOUT "{time interval expired}") (PSTAT.QUIT "Quit") (\PSTAT.NORESULT "{no result yet}")) (GLOBALVARS PSTAT.WAKEUP PSTAT.TIMEDOUT PSTAT.QUIT \PSTAT.NORESULT)) (COMS (* ; "Event stuff") (DECLARE%: DONTCOPY (RECORDS EVENT)) (INITRECORDS EVENT) (SYSRECORDS EVENT) (FNS CREATE.EVENT NOTIFY.EVENT AWAIT.EVENT \UNQUEUE.EVENT \ENQUEUE.EVENT/LOCK \EVENT.DEFPRINT) (MACROS AWAIT.CONDITION) (INITVARS (\PROCESS.AFTEREXIT.EVENT)) (GLOBALVARS \PROCESS.AFTEREXIT.EVENT)) (COMS (* ; "Monitor stuff") (DECLARE%: DONTCOPY (RECORDS MONITORLOCK) (MACROS .RELEASE.LOCK.)) (INITRECORDS MONITORLOCK) (SYSRECORDS MONITORLOCK) (FNS OBTAIN.MONITORLOCK CREATE.MONITORLOCK RELEASE.MONITORLOCK SI::MONITOR-UNWIND MONITOR.AWAIT.EVENT \MONITORLOCK.DEFPRINT) (MACROS WITH.MONITOR WITH.FAST.MONITOR)) (COMS (FNS \MAKE.PROCESS0 \MAKE.PROCESS1 \PROCESS.MOVEFRAME \RELEASE.PROCESS \UNWIND.PROCESS \MAYBEBLOCK \BACKGROUND.PROCESS \MOUSE.PROCESS \TIMER.PROCESS \PROCESS.RELEASE.LOCKS \SET.PROCESS.NAME \PROCESS.DEFPRINT) (FNS \START.PROCESSES \PROCESS.GO.TO.SLEEP \PROC.RESUME \RUN.PROCESS \SUSPEND.PROCESS \UNQUEUE.TIMER \ENQUEUE.TIMER \GET.PRIORITY.QUEUE) (DECLARE%: DONTCOPY (MACROS \RESCHEDULE))) (COMS (FNS \PROCESS.INIT \PROCESS.EVENTFN \PROCESS.BEFORE.LOGOUT \PROCESS.AFTER.EXIT \PROCESS.RESET.TIMERS \PROC.AFTER.WINDOWWORLD \TURN.ON.PROCESSES) (* ; "Redefinitions") (FNS \PROC.CODEFORTFRAME \PROC.REPEATEDLYEVALQT)) (COMS (* ; "switching stacks") (FNS BREAK.PROCESS \SELECTPROCESS \PROCESS.MAKEFRAME \PROCESS.MAKEFRAME0)) (INITVARS (%#MYHANDLE#) (%#SCHEDULER#) (\RUNNING.PROCESS) (\PROCESSES) (PROCESS.MAXMOUSE 5) (PROC.FREESPACESIZE 1024) (AUTOPROCESSFLG T) (BACKGROUNDFNS) (\TIMERQHEAD) (\HIGHEST.PRIORITY.QUEUE) (PROC.DEFAULT.PRIORITY 2) (\DEFAULTLINEBUF) (\DEFAULTTTYDISPLAYSTREAM) (\PROCTIMER.SCRATCH (NCREATE 'FIXP)) (TOPW) (\PROC.RUN.NEXT.FLG) (\PROC.READY T)) (ADDVARS (\SYSTEMCACHEVARS \PROC.READY) (\SYSTEMTIMERVARS (\LASTUSERACTION SECONDS))) (COMS (VARS (\PROC.RESTARTME "{restart flag}") (\PROC.RESETME "{reset flag}") (\PROC.KILLME "{abort flag}")) (DECLARE%: DONTCOPY (EXPORT (MACROS THIS.PROCESS TTY.PROCESS TTY.PROCESSP) (GLOBALVARS \RUNNING.PROCESS \TTY.PROCESS \PROC.RESTARTME \PROC.RESETME \PROC.ABORTME)) (GLOBALVARS \PROCESSES PROC.FREESPACESIZE %#SCHEDULER# PROCESS.MAXMOUSE AUTOPROCESSFLG BACKGROUNDFNS \TopLevelTtyWindow \PROC.READY) (GLOBALVARS \TIMERQHEAD \PROCTIMER.SCRATCH \HIGHEST.PRIORITY.QUEUE PROC.DEFAULT.PRIORITY \PROC.RUN.NEXT.FLG \SYSTEMTIMERVARS) (MACROS ALIVEPROCP DEADPROCP \COERCE.TO.PROCESS) (LOCALVARS . T))) (COMS (* ; "Debugging") (FNS \CHECK.PQUEUE) (FNS PPROC PPROCWINDOW PPROCREPAINTFN PPROCRESHAPEFN PPROCEXTENT PPROC1 PROCESS.STATUS.WINDOW \PSW.SELECTED \PSWOP.SELECTED PROCESS.BACKTRACE \INVALIDATE.PROCESS.WINDOW \UPDATE.PROCESS.WINDOW) (INITVARS (PROCMENU) (PROCOPMENU) (PROCOP.WAKEMENU) (PROCESS.STATUS.WINDOW) (SELECTEDPROC) (PROCBACKTRACEHEIGHT 320)) (ADDVARS (BackgroundMenuCommands ("PSW" '(PROCESS.STATUS.WINDOW) "Puts up a Process Status Window"))) (P (SETQQ BackgroundMenu)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS PROCESS.STATUS.WINDOW PROCMENU PROCOPMENU PROCOP.WAKEMENU PROCBACKTRACEHEIGHT SELECTEDPROC BACKTRACEFONT) (CONSTANTS LIGHTGRAYSHADE SELECTIONSHADE))) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (WINDOWUSERFORMS (\PROC.AFTER.WINDOWWORLD))) (P (DEFPRINT 'PROCESS (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT 'EVENT (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT 'MONITORLOCK (FUNCTION \MONITORLOCK.DEFPRINT)) (* ;  "\process.init must come last, since it does a HARDRESET") (\PROCESS.INIT))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PROCESSPROP ADD.PROCESS]) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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) ) (/DECLAREDATATYPE 'PROCESS '(WORD WORD BYTE POINTER BYTE POINTER BYTE POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PROCESS 0 (BITS . 15)) (PROCESS 1 (BITS . 15)) (PROCESS 2 (BITS . 7)) (PROCESS 4 POINTER) (PROCESS 3 (BITS . 7)) (PROCESS 6 POINTER) (PROCESS 3 (BITS . 135)) (PROCESS 8 POINTER) (PROCESS 8 (FLAGBITS . 0)) (PROCESS 8 (FLAGBITS . 16)) (PROCESS 8 (FLAGBITS . 32)) (PROCESS 8 (FLAGBITS . 48)) (PROCESS 6 (FLAGBITS . 0)) (PROCESS 6 (FLAGBITS . 16)) (PROCESS 6 (FLAGBITS . 32)) (PROCESS 6 (FLAGBITS . 48)) (PROCESS 10 POINTER) (PROCESS 12 POINTER) (PROCESS 14 POINTER) (PROCESS 16 POINTER) (PROCESS 18 POINTER) (PROCESS 20 POINTER) (PROCESS 22 POINTER) (PROCESS 24 POINTER) (PROCESS 26 POINTER) (PROCESS 28 POINTER) (PROCESS 30 POINTER) (PROCESS 32 POINTER) (PROCESS 34 POINTER) (PROCESS 36 POINTER) (PROCESS 38 POINTER) (PROCESS 40 POINTER) (PROCESS 42 POINTER) (PROCESS 44 POINTER) (PROCESS 46 POINTER) (PROCESS 48 POINTER) (PROCESS 50 POINTER) (PROCESS 52 POINTER) (PROCESS 54 POINTER) (PROCESS 56 POINTER) (PROCESS 58 POINTER) (PROCESS 60 POINTER) (PROCESS 62 POINTER) (PROCESS 64 POINTER)) '66) (* "END EXPORTED DEFINITIONS") (DECLARE%: EVAL@COMPILE (DATATYPE PROCESSQUEUE ((PQPRIORITY BYTE) (* ;  "Priority for the processes in thie queue.") (PQHIGHER POINTER) (* ; "Next higher-prioirty queue") (PQLOWER POINTER) (* ; "Next lower") (PQNEXT POINTER) (* ;  "The process currently running or runnable at this priority") (PQLAST POINTER) (* ;  "The proc previous to it. PQNEXT might be redundant") )) ) (/DECLAREDATATYPE 'PROCESSQUEUE '(BYTE POINTER POINTER POINTER POINTER) '((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) (PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER)) '10) (DECLARE%: EVAL@COMPILE (RPAQQ \PSTAT.WAITING 0) (RPAQQ \PSTAT.RUNNING 1) (RPAQQ \PSTAT.DELETED 2) (CONSTANTS \PSTAT.WAITING \PSTAT.RUNNING \PSTAT.DELETED) ) ) (/DECLAREDATATYPE 'PROCESS '(WORD WORD BYTE POINTER BYTE POINTER BYTE POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((PROCESS 0 (BITS . 15)) (PROCESS 1 (BITS . 15)) (PROCESS 2 (BITS . 7)) (PROCESS 4 POINTER) (PROCESS 3 (BITS . 7)) (PROCESS 6 POINTER) (PROCESS 3 (BITS . 135)) (PROCESS 8 POINTER) (PROCESS 8 (FLAGBITS . 0)) (PROCESS 8 (FLAGBITS . 16)) (PROCESS 8 (FLAGBITS . 32)) (PROCESS 8 (FLAGBITS . 48)) (PROCESS 6 (FLAGBITS . 0)) (PROCESS 6 (FLAGBITS . 16)) (PROCESS 6 (FLAGBITS . 32)) (PROCESS 6 (FLAGBITS . 48)) (PROCESS 10 POINTER) (PROCESS 12 POINTER) (PROCESS 14 POINTER) (PROCESS 16 POINTER) (PROCESS 18 POINTER) (PROCESS 20 POINTER) (PROCESS 22 POINTER) (PROCESS 24 POINTER) (PROCESS 26 POINTER) (PROCESS 28 POINTER) (PROCESS 30 POINTER) (PROCESS 32 POINTER) (PROCESS 34 POINTER) (PROCESS 36 POINTER) (PROCESS 38 POINTER) (PROCESS 40 POINTER) (PROCESS 42 POINTER) (PROCESS 44 POINTER) (PROCESS 46 POINTER) (PROCESS 48 POINTER) (PROCESS 50 POINTER) (PROCESS 52 POINTER) (PROCESS 54 POINTER) (PROCESS 56 POINTER) (PROCESS 58 POINTER) (PROCESS 60 POINTER) (PROCESS 62 POINTER) (PROCESS 64 POINTER)) '66) (/DECLAREDATATYPE 'PROCESSQUEUE '(BYTE POINTER POINTER POINTER POINTER) '((PROCESSQUEUE 0 (BITS . 7)) (PROCESSQUEUE 2 POINTER) (PROCESSQUEUE 4 POINTER) (PROCESSQUEUE 6 POINTER) (PROCESSQUEUE 8 POINTER)) '10) (ADDTOVAR SYSTEMRECLST (DATATYPE PROCESS ((PROCFX0 WORD) (PROCFX WORD) (PROCSTATUS BYTE) (PROCNAME POINTER) (PROCPRIORITY BYTE) (PROCQUEUE POINTER) (NIL BYTE) (NEXTPROCHANDLE POINTER) (PROCTIMERSET FLAG) (PROCBEINGDELETED FLAG) (PROCDELETED FLAG) (PROCSYSTEMP FLAG) (PROCNEVERSTARTED FLAG) (NIL FLAG) (NIL FLAG) (NIL FLAG) (PROCWAKEUPTIMER POINTER) (PROCTIMERLINK POINTER) (PROCTIMERBOX POINTER) (WAKEREASON POINTER) (PROCEVENTORLOCK POINTER) (PROCFORM POINTER) (RESTARTABLE POINTER) (PROCWINDOW POINTER) (PROCFINISHED POINTER) (PROCRESULT POINTER) (PROCFINISHEVENT POINTER) (PROCMAILBOX POINTER) (PROCDRIBBLEOUTPUT POINTER) (PROCINFOHOOK POINTER) (PROCTYPEAHEAD POINTER) (PROCREMOTEINFO POINTER) (PROCUSERDATA POINTER) (PROCEVENTLINK POINTER) (PROCAFTEREXIT POINTER) (PROCBEFOREEXIT POINTER) (PROCOWNEDLOCKS POINTER) (PROCEVAPPLYRESULT POINTER) (PROCTTYENTRYFN POINTER) (PROCTTYEXITFN POINTER) (PROCHARDRESETINFO POINTER) (PROCRESTARTFORM POINTER) (PROCOLDTTYPROC POINTER) (NIL POINTER))) (DATATYPE PROCESSQUEUE ((PQPRIORITY BYTE) (PQHIGHER POINTER) (PQLOWER POINTER) (PQNEXT POINTER) (PQLAST POINTER))) ) (* ; "User entries") (DEFINEQ (PROCESSWORLD + [LAMBDA (FLG) (* ; "Edited 1-Jun-88 15:39 by bvm") + + (* ;; "get started with multi-processing") + + (COND + [(EQ FLG 'OFF) (* ; "Turn them off") + + (* ;; "Release the stack space used by the procs, but keep the handles around for possible unwinding; normally processworld is never turned off--don't know if this has any hope of working any more.") + + (for P in \PROCESSES do (\RELEASE.PROCESS P)) + (SETQ \TTY.PROCESS) + (COND + ((TYPENAMEP \TopLevelTtyWindow 'WINDOW) + (WINDOWPROP \TopLevelTtyWindow 'PROCESS NIL))) + (SETQ \RUNNING.PROCESS) + (COND + ((AND %#SCHEDULER# (NEQ 0 (fetch PROCFX of %#SCHEDULER#))) + (RETTO (PROG1 %#SCHEDULER# (SETQ %#SCHEDULER#)) + PSTAT.QUIT T] + (\RUNNING.PROCESS "Processes are already on") + (T (PROG ((FIRSTTIME (NOT (type? PROCESS %#SCHEDULER#))) + EXECPROC BACKGROUNDPROC) + [PROGN (SETQ \STACKOVERFLOW NIL) (* ; + "Clear the stack overflow indicator in case a hard reset occurred.") + (COND + (\WINDOWWORLD (* ; "Cursor maybe smashed if died in hard stack overflow. Only do this if window world on (bootstrap problem).") + (CURSOR T] + (COND + (FIRSTTIME (SETQ %#SCHEDULER# (create PROCESS)) + (SETQ \TTY.PROCESS.EVENT (CREATE.EVENT 'TTY)) + (SETQ \PROCESS.AFTEREXIT.EVENT (CREATE.EVENT "After Exit"))) + (T (replace PROCFX of %#SCHEDULER# with 0))) + + (* ;; "First wander thru any old processes, checking for unwind info and processes that said they want to restart on HARDRESET") + + [COND + ((type? PROCESSQUEUE \HIGHEST.PRIORITY.QUEUE) + (* ; "Empty out the queues") + (for (PQ _ \HIGHEST.PRIORITY.QUEUE) by (fetch PQLOWER of PQ) + while PQ do (replace PQNEXT of PQ + with (replace PQLAST of PQ with NIL] + (SETQ \PROCESSES (for P in \PROCESSES + when (COND + ((EQ (fetch PROCNAME of P) + 'EXEC) (* ; + "Save the primary EXEC to run last") + (\RELEASE.PROCESS P) + (SETQ EXECPROC P) + NIL) + ((fetch PROCNEVERSTARTED of P) + (* ; + "Process got created when scheduling was off") + (replace PROCNEVERSTARTED of P with + NIL) + T) + ((fetch RESTARTABLE of P) + (* ; + "Stack of this process got flushed by a hard reset") + T) + ((OR (AND (EQ P \TTY.PROCESS) + (fetch PROCTTYEXITFN of P)) + (fetch PROCDRIBBLEOUTPUT of P) + (fetch PROCHARDRESETINFO of P)) + (* ; + "Need to clean up once processworld back on") + (replace PROCFINISHED of P + with 'DELETED) + T) + (T (* ; + "Not restartable & no cleanup, so just bash it.") + (replace PROCDELETED of P with T) + (\RELEASE.PROCESS P T T) + (* ; + "3rd arg tells it not to remove it from \processes, because we're doing that.") + NIL)) collect (PROGN (\RELEASE.PROCESS + P) + (* ; + "Take it off any queues etc it was on") + P))) + (for P in \PROCESSES do (* ; "Bring it back to life") + (\MAKE.PROCESS0 (OR (fetch PROCRESTARTFORM + of P) + (fetch PROCFORM + of P)) + P) + (\RUN.PROCESS P)) + [COND + ([NOT (SETQ BACKGROUNDPROC (FIND.PROCESS 'BACKGROUND] + (SETQ BACKGROUNDPROC (ADD.PROCESS (LIST (FUNCTION \BACKGROUND.PROCESS)) + 'NAME + 'BACKGROUND + 'RESTARTABLE + 'SYSTEM + 'SCHEDULE T] + (COND + ((NOT (FIND.PROCESS 'MOUSE)) + (ADD.PROCESS (LIST (FUNCTION \MOUSE.PROCESS)) + 'NAME + 'MOUSE + 'RESTARTABLE + 'SYSTEM + 'SCHEDULE T))) + (COND + ((NOT (FIND.PROCESS '\TIMER.PROCESS)) + (SETQ \TIMERQHEAD (ADD.PROCESS (LIST (FUNCTION \TIMER.PROCESS)) + 'RESTARTABLE + 'SYSTEM + 'SCHEDULE T))) + (T (replace PROCTIMERLINK of (\DTEST \TIMERQHEAD 'PROCESS) with NIL))) + [COND + (EXECPROC (* ; "Restore exec last so that it at least starts out with all of stack space to play with, don't sandbar as soon") + (push \PROCESSES EXECPROC) + (\MAKE.PROCESS0 (fetch PROCFORM of EXECPROC) + EXECPROC) + (\RUN.PROCESS EXECPROC)) + (FIRSTTIME (* ; "Create an exec. Don't do this on Hard reset--if user has deliberately killed exec, don't bring it back") + (SETQ EXECPROC (ADD.PROCESS '(\PROC.REPEATEDLYEVALQT) + 'NAME + 'EXEC + 'RESTARTABLE + 'ALWAYS + 'SCHEDULE T] + [COND + ((NOT (MEMB \TTY.PROCESS \PROCESSES)) (* ; + "The tty process died in the hardreset, so make it the exec, or background if no exec") + (SETQ \TTY.PROCESS (OR EXECPROC BACKGROUNDPROC] + + (* ;; "All set to go now -- schedule a process, save state of this piece of stack in #Scheduler#. Should never need to go around this loop, says here.") + + LP [PROGN (replace NEXTPROCHANDLE of %#SCHEDULER# with (CAR \PROCESSES)) + (LET ((RESULT (\START.PROCESSES))) + (COND + ((EQ RESULT PSTAT.QUIT) (* ; "from (PROCESSWORLD 'OFF)") + (RETFROM 'PROCESSWORLD)) + (T (RAID "??? Process error - strange result from \Start.Processes" + RESULT] + (GO LP]) (ADD.PROCESS + [LAMBDA ARGS (* ; "Edited 8-May-87 17:36 by bvm") + (PROG ((CREATENOW (THIS.PROCESS)) + (PRIORITY PROC.DEFAULT.PRIORITY) + FORM RESTARTFLG SYSTEMP SUSPENDIT INFOHOOK RESTARTFORM WINDOW NAME AFTEREXIT PROC + USERPROPS PROP VALUE BEFOREEXIT TTYENTRYFN TTYEXITFN) + [COND + ([OR (EQ ARGS 0) + (NLISTP (SETQ FORM (ARG ARGS 1] + (RETURN (\ILLEGAL.ARG FORM] + [COND + ((EQ ARGS 2) (* ; "Backward compatibility") + (SETQ NAME (ARG ARGS 2))) + (T (for I from 2 to ARGS by 2 + do (SETQ VALUE (ARG ARGS (ADD1 I))) + (SELECTQ (SETQ PROP (ARG ARGS I)) + (WINDOW (SETQ WINDOW (\INSUREWINDOW VALUE))) + (PRIORITY (SETQ PRIORITY (\DTEST VALUE 'SMALLP))) + (NAME (SETQ NAME VALUE)) + (AFTEREXIT (SETQ AFTEREXIT VALUE)) + (BEFOREEXIT (SETQ BEFOREEXIT VALUE)) + (TTYENTRYFN (SETQ TTYENTRYFN VALUE)) + (TTYEXITFN (SETQ TTYEXITFN VALUE)) + (INFOHOOK (SETQ INFOHOOK VALUE)) + (RESTARTFORM (SETQ RESTARTFORM VALUE)) + (RESTARTABLE (SETQ RESTARTFLG VALUE)) + (SCHEDULE (SETQ CREATENOW T)) + (SUSPEND (SETQ SUSPENDIT VALUE)) + (COND + ([AND (EQ ARGS 3) + (FMEMB VALUE '(SYSTEM NO T] + (* ; + "Backward compatibility: arglist used to be (FORM NAME RESTARTFLG)") + (SETQ NAME PROP) + (SETQ RESTARTFLG VALUE)) + (T (push USERPROPS PROP VALUE] + (SETQ RESTARTFLG (SELECTQ RESTARTFLG + (SYSTEM (SETQ SYSTEMP T)) + ((NIL NO NEVER) + NIL) + ((T YES ALWAYS) + T) + (HARDRESET 'HARDRESET) + (\ILLEGAL.ARG RESTARTFLG))) + (SETQ PROC + (create PROCESS + PROCTIMERSET _ NIL + WAKEREASON _ T + PROCFORM _ FORM + RESTARTABLE _ RESTARTFLG + PROCPRIORITY _ PRIORITY + PROCSTATUS _ \PSTAT.WAITING + PROCSYSTEMP _ SYSTEMP + PROCAFTEREXIT _ AFTEREXIT + PROCBEFOREEXIT _ BEFOREEXIT + PROCTTYENTRYFN _ TTYENTRYFN + PROCTTYEXITFN _ TTYEXITFN + PROCWINDOW _ WINDOW + PROCINFOHOOK _ INFOHOOK + PROCUSERDATA _ USERPROPS + PROCRESTARTFORM _ RESTARTFORM)) + (replace PROCQUEUE of PROC with (\GET.PRIORITY.QUEUE (fetch + PROCPRIORITY + of PROC))) + (\SET.PROCESS.NAME PROC (OR NAME (CAR FORM))) + (UNINTERRUPTABLY + (SETQ \PROCESSES (CONS PROC \PROCESSES)) + (\INVALIDATE.PROCESS.WINDOW) + (COND + (CREATENOW (* ; + "Only create it if we are actually scheduling") + (\MAKE.PROCESS0 FORM PROC) + (OR SUSPENDIT (\RUN.PROCESS PROC))) + (T (replace PROCNEVERSTARTED of PROC with T)))) + (COND + (WINDOW (WINDOWPROP WINDOW 'PROCESS PROC))) + (RETURN PROC]) (DEL.PROCESS + [LAMBDA (PROC INTERNAL) (* ; "Edited 2-Dec-86 20:35 by bvm:") + (LET ((P (\COERCE.TO.PROCESS PROC))) + (COND + (P (if (NEQ P (THIS.PROCESS)) + then (* ; + "Delete proc in its own context, so that (THIS.PROCESS) is correct during the unwind") + (if (NOT (fetch PROCBEINGDELETED of P)) + then (replace PROCBEINGDELETED of P with T) + (\PROCESS.MAKEFRAME P (FUNCTION \UNWIND.PROCESS) + (LIST P))) + else (* ; "delete current process.") + (replace PROCBEINGDELETED of P with T) + (\UNWIND.PROCESS P)) + T]) (PROCESS.RETURN + [LAMBDA (VALUE) (* bvm%: " 4-MAY-83 12:35") + (RETTO '\MAKE.PROCESS0 VALUE]) (FIND.PROCESS + [LAMBDA (PROC ERRORFLG) (* ; "Edited 12-Oct-87 17:17 by bvm:") + + (* ;; "Coerces PROC to a process handle, returning handle if okay; otherwise, if ERRORFLG is set, causes an error, else returns NIL. If ERRORFLG is true, also causes error if proc is not alive") + + (COND + [(COND + ((type? PROCESS PROC) + (AND (NOT (fetch PROCDELETED of PROC)) + PROC)) + ((OR (LITATOM PROC) + (STRINGP PROC)) + (GETHASH PROC \PROCESS.NAME.TABLE] + (ERRORFLG (ERROR PROC "not a live process"]) (MAP.PROCESSES + [LAMBDA (MAPFN) (* bvm%: "16-JUN-82 16:22") + (for P in (APPEND \PROCESSES) do (APPLY* MAPFN P (fetch PROCNAME of P) + (fetch PROCFORM of P)) + unless (DEADPROCP P]) (PROCESSP + [LAMBDA (PROC) (* bvm%: " 6-JUL-82 17:30") + (AND (type? PROCESS PROC) + (ALIVEPROCP PROC]) (RELPROCESSP + [LAMBDA (PROCHANDLE) (* bvm%: "13-JUN-82 14:39") + (AND (type? PROCESS PROCHANDLE) + (DEADPROCP PROCHANDLE]) (RESTART.PROCESS + [LAMBDA (PROC) (* bvm%: "12-Nov-86 17:24") + (LET ((P (\COERCE.TO.PROCESS PROC))) + (COND + (P (UNINTERRUPTABLY + (replace WAKEREASON of P with \PROC.RESTARTME) + (COND + ((EQ P (THIS.PROCESS)) + (RETTO '\MAKE.PROCESS0 \PROC.RESTARTME)) + (T (\PROCESS.MAKEFRAME P (FUNCTION RESTART.PROCESS) + (LIST P)) + P)))]) (WAKE.PROCESS + [LAMBDA (PROC STATUS) (* bvm%: " 4-MAY-83 14:58") + + (* ;; "cause a (possibly) sleeping process to run --- Note that the STATUS will be returned as the value of the BLOCK that put the process to sleep") + + (DECLARE (GLOBALVARS PSTAT.WAKEUP)) + (PROG ((P (\COERCE.TO.PROCESS PROC))) + (COND + (P (UNINTERRUPTABLY + [COND + ((NEQ (fetch PROCSTATUS of P) + \PSTAT.RUNNING) + (\RUN.PROCESS P (OR STATUS PSTAT.WAKEUP))) + (T (replace WAKEREASON of P with (OR STATUS PSTAT.WAKEUP]) + (RETURN T]) (SUSPEND.PROCESS + [LAMBDA (PROC) (* bvm%: " 4-MAY-83 12:37") + (PROG [(P (COND + (PROC (\COERCE.TO.PROCESS PROC T)) + (T (THIS.PROCESS] + (COND + ((EQ P (THIS.PROCESS)) + (\PROCESS.GO.TO.SLEEP)) + (T (\SUSPEND.PROCESS P))) + (RETURN P]) (PROCESS.RESULT + [LAMBDA (PROCESS WAITFORRESULT) (* bvm%: " 1-JUN-83 22:26") + (SETQ PROCESS (\DTEST PROCESS 'PROCESS)) + (COND + ((DEADPROCP PROCESS) + (fetch PROCRESULT of PROCESS)) + (WAITFORRESULT (bind [EVENT _ (OR (fetch PROCFINISHEVENT of PROCESS) + (replace PROCFINISHEVENT of PROCESS + with (CREATE.EVENT (CONCAT (fetch + PROCNAME + of PROCESS) + "#Finish"] + until (DEADPROCP PROCESS) do (AWAIT.EVENT EVENT) + finally (RETURN (fetch PROCRESULT of PROCESS]) (PROCESS-STATUS + [LAMBDA (POS) (* ; "Edited 12-Oct-87 17:28 by bvm:") + (LET ((POS (if POS + then (if (OR (LITATOM POS) + (STRINGP POS)) + then (FIND.PROCESS POS) + else POS) + else 2))) + (AND POS (LET ((STKI (\STACKARGPTR POS))) + (do (SELECTQ (fetch (FX FRAMENAME) of STKI) + ((\INTERRUPTFRAME \INTERRUPTED INTERRUPTED \DOINTERRUPTHERE + \PERIODIC.INTERRUPTFRAME ERRORSET) + (* ; "Skip over these") + (SETQ STKI (fetch (FX CLINK) of STKI))) + ((\GETCHAR \GETKEY \TTYBACKGROUND GETMOUSESTATE MENU.HANDLER) + (RETURN 'IO.WAIT)) + ((BLOCK \BACKGROUND AWAIT.EVENT MONITOR.AWAIT.EVENT + \PROCESS.GO.TO.SLEEP) + (* ; "Forms of blocking") + (RETURN 'WAITING)) + (RETURN 'RUNNING]) (PROCESS.FINISHEDP + [LAMBDA (PROCESS) (* bvm%: "17-SEP-82 11:53") + (SETQ PROCESS (\DTEST PROCESS 'PROCESS)) + (COND + ((fetch PROCFINISHED of PROCESS)) + ((DEADPROCP PROCESS) + 'ERROR]) ) (DEFINEQ (THIS.PROCESS + [LAMBDA NIL (* bvm%: " 4-MAY-83 13:47") + \RUNNING.PROCESS]) (TTY.PROCESS + [LAMBDA (PROC) (* ; "Edited 3-May-89 18:21 by atm") + (PROG1 (AND (type? PROCESS \TTY.PROCESS) + \TTY.PROCESS) + [COND + (PROC (PROG ((OLDTTY \TTY.PROCESS) + NEWTTY OTHER OLDTTYDS TYPEAHEAD FN) + [SETQ NEWTTY (COND + [(EQ PROC T) (* ; + "Return tty to default tty process") + (COND + ((AND OLDTTY (SETQ OTHER (fetch PROCOLDTTYPROC + of OLDTTY)) + (OPENWP (WFROMDS (PROCESS.TTY OTHER) + T))) + (* ; +"Only give it to recent tty process if its window is open. Avoids popping up shrunk tedit's, etc.") + OTHER) + ((for P in TTY.PROCESS.DEFAULT + when [AND (SETQ OTHER (FIND.PROCESS P)) + (NEQ OTHER OLDTTY) + (OR (NOT (HASTTYWINDOWP OTHER)) + (OPENWP (WFROMDS (PROCESS.TTY + OTHER) + T] + do (* ; + "lets us return it to MOUSE but not to a shrunken EXEC") + (RETURN OTHER))) + ((for P in \PROCESSES + when [AND (NEQ P OLDTTY) + (OR (NOT (HASTTYWINDOWP P)) + (OPENWP (WFROMDS (PROCESS.TTY + P) + T] + do (RETURN P))) + ((EQ (CAR \PROCESSES) + OLDTTY) (* ; + "If nothing on TTY.PROCESS.DEFAULT exists, pick something random") + (CADR \PROCESSES)) + (T (CAR \PROCESSES] + ((type? PROCESS PROC) + PROC) + (T (FIND.PROCESS PROC T] + (COND + ((fetch PROCDELETED of NEWTTY) + (* ; + "Ordinarily would error, but this can easily happen from a RESETFORM") + (RETURN))) + (COND + ((NEQ NEWTTY OLDTTY) + (if (AND OLDTTY (NEQ PROC T)) + then (* ; + "record in new process which process used to be the tty, for use of (tty.process t)") + (replace PROCOLDTTYPROC of NEWTTY with OLDTTY)) + (\CHECKCARET) (* ; + "gonna switch TTY, take down caret wherever it is") + [COND + ((AND (SETQ TYPEAHEAD (bind C while (SETQ C (\GETSYSBUF)) + collect C)) + OLDTTY) (* ; + "Save any typeahead that was done while old proc had the tty") + (replace PROCTYPEAHEAD of OLDTTY + with (NCONC (fetch PROCTYPEAHEAD of OLDTTY) + TYPEAHEAD] + (LET* [(KEYACTION (OR (PROCESSPROP NEWTTY 'KEYACTION) + \DEFAULTKEYACTION)) + (NEWINTERRUPTS (PROCESSPROP NEWTTY 'INTERRUPTS] + (UNINTERRUPTABLY + (COND + ((AND OLDTTY (SETQ FN (fetch PROCTTYEXITFN of OLDTTY) + )) + (CL:FUNCALL FN OLDTTY NEWTTY))) + (SETQ \TTY.PROCESS NEWTTY) + [PROCESSPROP OLDTTY 'INTERRUPTS + (LET ((INTERRUPTLIST (fetch (KEYACTION INTERRUPTLIST) + of \CURRENTKEYACTION))) + (if INTERRUPTLIST + then (APPEND INTERRUPTLIST) + else 'OFF] + (* ; + "save the old interrupts on the process.") + (SETQ \CURRENTKEYACTION KEYACTION) + (* ; "set the new interrupts up.") + (AND NEWINTERRUPTS (REPLACE (KEYACTION INTERRUPTLIST) + OF \CURRENTKEYACTION + WITH (AND (NEQ NEWINTERRUPTS + 'OFF) + NEWINTERRUPTS))) + (COND + ((SETQ FN (fetch PROCTTYENTRYFN of NEWTTY)) + (CL:FUNCALL FN NEWTTY OLDTTY))) + (NOTIFY.EVENT \TTY.PROCESS.EVENT))])]) (TTY.PROCESSP + [LAMBDA (PROC) (* bvm%: " 5-MAY-83 18:14") + (OR (NULL (THIS.PROCESS)) + (EQ (OR PROC (THIS.PROCESS)) + (TTY.PROCESS]) (PROCESS.TTY + [LAMBDA (PROC) (* lmm "20-Jan-86 23:51") + + (* ;; "returns the TTY for a process") + + (COND + ((OR (NULL PROC) + (EQ (SETQ PROC (\COERCE.TO.PROCESS PROC)) + (THIS.PROCESS))) + \TERM.OFD) + (PROC (PROCESS.EVALV PROC '\TERM.OFD]) (GIVE.TTY.PROCESS + [LAMBDA (WINDOW) (* rrb "16-Jul-84 17:53") + + (* ;; "default WINDOWENTRYFN which gives the tty to the process associated with this window and calls its BUTTONEVENTFN") + + (OR (WINDOWP WINDOW) + (\ILLEGAL.ARG WINDOW)) + (PROG ((PROC (WINDOWPROP WINDOW 'PROCESS)) + FN) + [COND + (PROC (COND + ((DEADPROCP PROC) + (WINDOWPROP WINDOW 'PROCESS NIL)) + (T (TTY.PROCESS PROC] + (AND [SETQ FN (COND + ((LASTMOUSESTATE (ONLY RIGHT)) + (fetch RIGHTBUTTONFN of WINDOW)) + (T (fetch BUTTONEVENTFN of WINDOW] + (APPLY* FN WINDOW]) (ALLOW.BUTTON.EVENTS + [LAMBDA NIL (* bvm%: "24-JUL-83 15:31") + (AND (EQ (fetch PROCNAME of (THIS.PROCESS)) + 'MOUSE) + (SPAWN.MOUSE (THIS.PROCESS]) (SPAWN.MOUSE + [LAMBDA (INTERNAL) (* ; "Edited 8-May-87 17:34 by bvm") + (UNINTERRUPTABLY + (PROG ([MOUSEPROC (COND + ((AND INTERNAL (EQ (fetch PROCNAME of INTERNAL) + 'MOUSE)) + INTERNAL) + (T (FIND.PROCESS 'MOUSE] + NAME) + (COND + (MOUSEPROC (\SET.PROCESS.NAME MOUSEPROC + (COND + ((NOT (FIND.PROCESS 'OLDMOUSE)) + (* ; "First spawned mouse") + 'OLDMOUSE) + ((for I from 2 to (COND + (INTERNAL PROCESS.MAXMOUSE) + (T MAX.SMALLP)) + unless (FIND.PROCESS (SETQ NAME (CONCAT + 'OLDMOUSE + '%# I))) + do (* ; "Get a unique name") + (RETURN NAME))) + (T (* ; + "Too many mice, stop before we eat up the whole stack") + (RETURN))) + T) + (replace PROCSYSTEMP of MOUSEPROC with NIL) + (* ; + "Make non systemp in case user wants to kill it") + )) + (ADD.PROCESS (LIST '\MOUSE.PROCESS) + 'NAME + 'MOUSE + 'RESTARTABLE + 'SYSTEM) + (RETURN T)))]) (\WAIT.FOR.TTY + [LAMBDA NIL (* bvm%: " 5-MAY-83 12:43") + (until (TTY.PROCESSP) do (AWAIT.EVENT \TTY.PROCESS.EVENT]) (WAIT.FOR.TTY + [LAMBDA (MSECS NEEDWINDOW) (* kbr%: "29-Jan-86 12:59") + +(* ;;; +"Ensures that current process can take input. Blocks if necesary until it becomes tty process") + + (COND + ((EQ (fetch PROCNAME of (THIS.PROCESS)) + 'MOUSE) + (SPAWN.MOUSE (THIS.PROCESS)) + + (* ;; "Background proc cannot take input, because if we block it, then nobody is listening to the mouse. So spin off a new background process and relegate this one to the tty use") + (* ; + "Assume mouse-invoked action wants to have the tty") + [OR (TTY.PROCESSP) + (SETQ \OLDTTY (TTY.PROCESS (THIS.PROCESS] + T) + ((TTY.PROCESSP) + T) + [\WINDOWWORLD (PROG (WINDOW TIMER) + [COND + (NEEDWINDOW (* ; + "Make sure process has a tty window") + (OR [OPENWP (SETQ WINDOW (WFROMDS (PROGN (\GETSTREAM + T + 'INPUT) + (TTYDISPLAYSTREAM] + (OPENW WINDOW] + [COND + (MSECS (* ; "Put a time limit on the wait") + (SETQ TIMER (SETUPTIMER MSECS] + (RETURN (do (AWAIT.EVENT \TTY.PROCESS.EVENT TIMER TIMER) + (COND + ((TTY.PROCESSP) + (RETURN T)) + ((AND TIMER (TIMEREXPIRED? TIMER)) + (RETURN NIL] + (T (TTY.PROCESS (THIS.PROCESS)) + T]) ) (DEFINEQ (RESET + [LAMBDA NIL (* bvm%: "10-Nov-86 18:16") + (PROG ((FX (\MYALINK))) + LP [COND + ((SELECTQ (fetch (FX FRAMENAME) of FX) + ((T \MAKE.PROCESS0 \REPEATEDLYEVALQT) + T) + NIL) + + (* ;; "In process world, try to return to top level exec frame (\REPEATEDLYEVALQT), or to the top of the process, which will decide whether to restart or kill the process. In non-process world, we eventually return to the T frame") + + (\SMASHRETURN NIL FX) + (RETURN \PROC.RESETME)) + ((fetch (FX INVALIDP) of (SETQ FX (fetch (FX CLINK) of FX))) + (RETURN (printout PROMPTWINDOW .TAB0 0 "Can't find top of stack!!!"] + (GO LP]) (ERROR! + [LAMBDA NIL (* bvm%: "12-Nov-86 17:49") + (if NIL + then (* ; + "old way--unwind to errorset or top") + [PROG ((FX (\MYALINK)) + NFX) + LP (SELECTQ (fetch (FX FRAMENAME) of FX) + (ERRORSET (* ; "return from NLSETQ, ERSETQ etc") + (\SMASHLINK NIL (fetch (FX CLINK) of FX) + (fetch (FX ALINK) of FX)) + (RETURN)) + (\MAKE.PROCESS0 (* ; + "no ERRORSETs to be found, so return to top-level of process") + (\SMASHLINK NIL FX FX) + (RETURN)) + (if (fetch (FX INVALIDP) of (SETQ NFX (fetch (FX CLINK) + of FX))) + then (* ; + "return to top. This can only happen in non-process world") + (\SMASHLINK NIL FX FX) + (RETURN) + else (SETQ FX NFX) + (GO LP] + else (ABORT) (* ; + "If ABORT returns, must have been no CATCH-ABORT, so reset to top") + (RETTO '\MAKE.PROCESS0 \PROC.RESETME]) ) (RPAQ? TTY.PROCESS.DEFAULT '(EXEC MOUSE)) (RPAQ? \TTY.PROCESS.EVENT ) (RPAQ? \TTY.PROCESS ) (RPAQ? \PROCESS.NAME.TABLE (HASHARRAY 30 NIL (FUNCTION STRING-EQUAL-HASHBITS) (FUNCTION STRING-EQUAL))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS TTY.PROCESS.DEFAULT \TTY.PROCESS.EVENT \PROCESS.NAME.TABLE) ) (DEFINEQ (PROCESSPROP + [LAMBDA ARGS (* ; "Edited 12-Oct-87 17:40 by bvm:") + (LET ((P (ARG ARGS 1)) + (PROP (ARG ARGS 2)) + NEWVALUE OLDDATA OLDVALUE) (* ; "First arg is the process handle or name. It is allowed to be a dead process, for benefit of folks retrieving props from a process after it dies.") + (AND (OR (type? PROCESS P) + (SETQ P (FIND.PROCESS P))) + (PROG1 (SELECTQ PROP + (WINDOW (fetch PROCWINDOW of P)) + (PRIORITY (fetch PROCPRIORITY of P)) + (NAME (fetch PROCNAME of P)) + (RESTARTABLE (fetch RESTARTABLE of P)) + (FORM (fetch PROCFORM of P)) + (INFOHOOK (fetch PROCINFOHOOK of P)) + (AFTEREXIT (fetch PROCAFTEREXIT of P)) + (BEFOREEXIT (fetch PROCBEFOREEXIT of P)) + (TTYENTRYFN (fetch PROCTTYENTRYFN of P)) + (TTYEXITFN (fetch PROCTTYEXITFN of P)) + (USERDATA (fetch PROCUSERDATA of P)) + (RESTARTFORM (fetch PROCRESTARTFORM of P)) + (SETQ OLDVALUE (LISTGET (SETQ OLDDATA (fetch PROCUSERDATA of P)) + PROP))) + [COND + ((> ARGS 2) + (SETQ NEWVALUE (ARG ARGS 3)) + (SELECTQ PROP + (WINDOW [replace PROCWINDOW of P with (AND NEWVALUE + (SETQ NEWVALUE + (\INSUREWINDOW + NEWVALUE] + (if NEWVALUE + then (WINDOWPROP NEWVALUE 'PROCESS P))) + (PRIORITY NIL) + (NAME (\SET.PROCESS.NAME P NEWVALUE) + (\INVALIDATE.PROCESS.WINDOW)) + (RESTARTABLE (replace RESTARTABLE of P + with (SELECTQ NEWVALUE + ((NIL NO NEVER) + NIL) + ((T YES ALWAYS) + T) + (HARDRESET 'HARDRESET) + (\ILLEGAL.ARG NEWVALUE)))) + (FORM) + (INFOHOOK (replace PROCINFOHOOK of P with NEWVALUE)) + (AFTEREXIT (replace PROCAFTEREXIT of P with NEWVALUE)) + (BEFOREEXIT (replace PROCBEFOREEXIT of P with NEWVALUE)) + (TTYENTRYFN (replace PROCTTYENTRYFN of P with NEWVALUE)) + (TTYEXITFN (replace PROCTTYEXITFN of P with NEWVALUE)) + (USERDATA (replace PROCUSERDATA of P with NEWVALUE)) + (RESTARTFORM (replace PROCRESTARTFORM of P with NEWVALUE)) + (COND + [(NOT NEWVALUE) (* ; "Delete the old value, if any") + (COND + ((EQ (CAR OLDDATA) + PROP) + (replace PROCUSERDATA of P with (CDDR OLDDATA))) + (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) + when (EQ (CADR TAIL) + PROP) do (RPLACD TAIL (CDDDR TAIL)) + (RETURN] + (OLDDATA (LISTPUT OLDDATA PROP NEWVALUE)) + (T (replace PROCUSERDATA of P with (LIST PROP NEWVALUE])]) (PROCESS.NAME + [LAMBDA (PROC NAME) (* ; "Edited 8-May-87 17:27 by bvm") + (LET ((P (\COERCE.TO.PROCESS PROC))) + (AND P (PROG1 (fetch PROCNAME of P) + (COND + (NAME (\SET.PROCESS.NAME P NAME))))]) (PROCESS.WINDOW + [LAMBDA (PROC WINDOW) (* bvm%: "16-JUN-82 16:36") + + (* ;; "Associates WINDOW with PROC, for exec switching") + + (LET ((P (\COERCE.TO.PROCESS PROC))) + (COND + (P (PROG1 (fetch PROCWINDOW of P) + (COND + (WINDOW (replace PROCWINDOW of P with (SETQ WINDOW (\INSUREWINDOW + WINDOW))) + (WINDOWPROP WINDOW 'PROCESS P))))]) ) (PUTPROPS PROCESSPROP ARGNAMES (PROC PROP NEWVALUE)) (PUTPROPS ADD.PROCESS ARGNAMES (NIL (FORM . PROPS&VALUES) . U)) (* ; "Temporary") (MOVD? 'PROCESS.RETURN 'KILL.ME NIL T) (DEFINEQ (DISMISS + [LAMBDA (MSECSWAIT TIMER NOBLOCK) (* bvm%: " 5-Nov-85 10:52") + (PROG (DTIMER) + [SETQ DTIMER (COND + [MSECSWAIT (SETUPTIMER (IMIN MSECSWAIT MAX.FIXP) + (OR TIMER (GETRESOURCE \DISMISSTIMER] + (TIMER (\DTEST TIMER 'FIXP)) + (T (RETURN (BLOCK] + (COND + ((NOT (THIS.PROCESS)) (* ; "Process world off") + (SETQ NOBLOCK T))) + (do (OR NOBLOCK (\PROCESS.GO.TO.SLEEP NIL DTIMER T)) until (TIMEREXPIRED? + DTIMER)) + (OR TIMER (FREERESOURCE \DISMISSTIMER DTIMER))) + MSECSWAIT]) (BLOCK + [LAMBDA (MSECSWAIT TIMER) (* kbr%: " 1-Feb-86 12:12") + + (* ;; "Waits for MSECSWAIT or forever if MSECSWAIT=T. Yields if MSECSWAIT is NIL. TIMER can be given as an alternative for specifying how long to wait.") + + (PROG ((PROC (THIS.PROCESS)) + PQUEUE) + (RETURN (COND + [(type? PROCESS PROC) + (COND + ((AND (NULL MSECSWAIT) + (NULL TIMER)) (* ; + "Only yielding, not going to sleep") + (UNINTERRUPTABLY + (SETQ PQUEUE (fetch PROCQUEUE of PROC)) + (COND + ((NEQ PROC (fetch PQNEXT of PQUEUE)) + (\MP.ERROR \MP.PROCERROR "Current process is not its queue's NEXT" + PROC))) + (replace WAKEREASON of PROC with T) + (replace PQNEXT of PQUEUE with (fetch NEXTPROCHANDLE + of PROC)) + (replace PQLAST of PQUEUE with PROC) + (\RESCHEDULE PROC))) + (T (\PROCESS.GO.TO.SLEEP NIL (COND + (TIMER (\DTEST TIMER 'FIXP)) + ((FIXP MSECSWAIT) + (IMIN MSECSWAIT MAX.FIXP))) + (NEQ TIMER NIL] + ((FIXP MSECSWAIT) (* ; + "Not scheduling; act like DISMISS") + (DISMISS MSECSWAIT T) + NIL) + (T (AND \WINDOWWORLD (WINDOW.MOUSE.HANDLER)) + (for FN in BACKGROUNDFNS do (SPREADAPPLY* FN)) + NIL]) (WAITFORINPUT + [LAMBDA (N) (* bvm%: "24-Jul-85 12:21") + (COND + [(FIXP N) + (GLOBALRESOURCE (\DISMISSTIMER) + (PROG ((NOW (\CLOCK0 \DISMISSTIMER)) + (N-100 (IDIFFERENCE N 100)) + ELAPSED) + LP (COND + ((READP T) + (RETURN T)) + ((NOT (\CLOCKGREATERP NOW N-100)) (* ; + "only run background task if at least 100 msecs left") + (\TTYBACKGROUND)) + ((\CLOCKGREATERP NOW N) (* ; "Time's up, return with no input") + (RETURN))) + (GO LP] + (N (* ; + "Getting OFD avoids time wasted in directory search, leaves more time for \TTYBACKGROUND") + (bind (STREAM _ (\GETSTREAM N 'INPUT)) until (OR (READP T) + (READP STREAM)) + do (\TTYBACKGROUND))) + (T (until (READP T) do (\TTYBACKGROUND]) (\WAITFORSYSBUFP + [LAMBDA (N) (* bvm%: "24-Jul-85 12:22") + (COND + [(FIXP N) + (GLOBALRESOURCE (\DISMISSTIMER) + (PROG ((NOW (\CLOCK0 \DISMISSTIMER))) + LP (COND + ((\SYSBUFP) + (RETURN T)) + ((NOT (TTY.PROCESSP)) + (\WAIT.FOR.TTY)) + ((\CLOCKGREATERP NOW N) (* ; "Time's up, return with no input") + (RETURN)) + (T (BLOCK))) + (GO LP] + (T (until (\SYSBUFP) do (BLOCK) + (\WAIT.FOR.TTY]) ) (* ; "Used to be a GLOBALRESOURCES") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\DISMISSTIMER 'RESOURCES '(NEW (SETUPTIMER 0] ) ) (/SETTOPVAL '\\DISMISSTIMER.GLOBALRESOURCE NIL) (DEFINEQ (EVAL.AS.PROCESS + [LAMBDA (FORM) (* bvm%: "20-MAY-83 12:00") + (COND + ((THIS.PROCESS) + (ADD.PROCESS FORM 'RESTARTABLE 'NO)) + (T (\EVAL FORM]) (EVAL.IN.TTY.PROCESS + [LAMBDA (FORM WAITFORRESULT) (* bvm%: " 5-MAY-83 18:14") + (COND + ((TTY.PROCESSP) + (\EVAL FORM)) + (T (PROCESS.EVAL (TTY.PROCESS) + FORM WAITFORRESULT]) ) (* ;; "The PROCESS.WAIT macro is an augmentation to BLOCK, waiting for a condition to come true, or a timeout, or a wakeup" ) (DECLARE%: EVAL@COMPILE (PUTPROPS PROCESS.WAIT MACRO [(WAITCOND TIMEOUT) (bind ($$TIMEOUT _ (AND TIMEOUT (SETUPTIMER TIMEOUT))) until (AND $$TIMEOUT ( TIMEREXPIRED? $$TIMEOUT)) do (if (SETQ $$VAL WAITCOND) then (RETURN $$VAL) else (BLOCK]) ) (DEFINEQ (PROCESS.READ + [LAMBDA (WINDOW PROMPT CLEAR?) (* bvm%: " 5-MAY-83 12:54") + + (* ;; "Special case of PREEMPT.KEYBOARD") + + (PROG ((OLDTTY (TTY.PROCESS)) + OLDW) + (RETURN (PROG1 (NLSETQ (PROGN (TTY.PROCESS (THIS.PROCESS)) + [COND + (WINDOW (SETQ OLDW (TTYDISPLAYSTREAM WINDOW)) + (COND + (CLEAR? (CLEARW WINDOW] + (COND + (PROMPT (PRIN1 PROMPT T))) + (READ T T))) + (TTY.PROCESS OLDTTY) + (AND OLDW (TTYDISPLAYSTREAM OLDW)))]) (PROCESS.EVALV + [LAMBDA (PROC VAR) (* bvm%: " 8-Jun-85 23:08") + (LET ((P (\COERCE.TO.PROCESS PROC T)) + ME) + (COND + ((OR (NULL (\DTEST VAR 'LITATOM)) + (EQ VAR T)) + VAR) + (T [COND + ((NEQ P (THIS.PROCESS)) + (SETQ ME (\MYALINK)) + (\SMASHLINK NIL (fetch PROCFX of P] + (PROG1 (\GETBASEPTR (\STKSCAN VAR) + 0) + (AND ME (\SMASHLINK NIL ME)))]) (PROCESS.EVAL + [LAMBDA (PROC FORM WAITFORRESULT) (* ; "Edited 9-Nov-87 18:54 by bvm:") + (DECLARE (LOCALVARS . T)) + (PROG ((P (\COERCE.TO.PROCESS PROC T)) + (ME (THIS.PROCESS))) + [COND + ((EQ P ME) + (RETURN (CL:EVAL FORM] + (COND + (WAITFORRESULT (replace PROCEVAPPLYRESULT of ME with \PSTAT.NORESULT))) + (\PROCESS.MAKEFRAME P '\PROCESS.EVAL1 (CONS FORM (AND WAITFORRESULT (LIST ME))) + T) + (RETURN (COND + (WAITFORRESULT (do (\PROCESS.GO.TO.SLEEP) + until (NEQ (fetch PROCEVAPPLYRESULT of ME) + \PSTAT.NORESULT)) + (PROG1 (fetch PROCEVAPPLYRESULT of ME) + (replace PROCEVAPPLYRESULT of ME with \PSTAT.NORESULT]) (\PROCESS.EVAL1 + [LAMBDA (..PEV-FORM.. ..PEV-PROC..) (* ; "Edited 10-Nov-87 14:50 by bvm") + + (* ;; "Evaluate the FORM argument and give the result to the calling process. If PROC is nil, then the evaluation is for effect only, and nobody needs to see it.") + + (if ..PEV-PROC.. + then + + (* ;; "Be careful here that aborting or killing the evaluation still causes the calling process to see a result.") + + [LET ((..PEV-RESULT.. :ABORTED)) + (CL:UNWIND-PROTECT + (SETQ ..PEV-RESULT.. (\EVAL ..PEV-FORM..)) + (replace PROCEVAPPLYRESULT of ..PEV-PROC.. with ..PEV-RESULT..) + (COND + ((NEQ (fetch PROCSTATUS of ..PEV-PROC..) + \PSTAT.RUNNING) (* ; "Make caller run.") + (\RUN.PROCESS ..PEV-PROC..))))] + else (* ; "Just eval it.") + (\EVAL ..PEV-FORM..]) (PROCESS.APPLY + [LAMBDA (PROC FN ARGS WAITFORRESULT) (* ; "Edited 9-Nov-87 18:54 by bvm:") + (DECLARE (LOCALVARS . T)) + (PROG ((P (\COERCE.TO.PROCESS PROC T)) + (ME (THIS.PROCESS))) + [COND + ((EQ P ME) + (RETURN (APPLY FN ARGS] + (COND + (WAITFORRESULT (replace PROCEVAPPLYRESULT of ME with \PSTAT.NORESULT))) + (\PROCESS.MAKEFRAME P '\PROCESS.APPLY1 (LIST* FN ARGS (AND WAITFORRESULT (LIST ME))) + T) + (RETURN (COND + (WAITFORRESULT (do (\PROCESS.GO.TO.SLEEP) + until (NEQ (fetch PROCEVAPPLYRESULT of ME) + \PSTAT.NORESULT)) + (PROG1 (fetch PROCEVAPPLYRESULT of ME) + (replace PROCEVAPPLYRESULT of ME with \PSTAT.NORESULT]) (\PROCESS.APPLY1 + [LAMBDA (..PEV-FN.. ..PEV-ARGS.. ..PEV-PROC..) (* ; "Edited 9-Nov-87 18:54 by bvm:") + + (* ;; "Apply the FN to the ARGS and give the result to the calling process. If PROC is nil, then the evaluation is for effect only, and nobody needs to see it. Ugly names here are because the Interlisp compiler will make them specvars on account of the UNWIND-PROTECT, and we can't use the XCL compiler in the init.") + + (if ..PEV-PROC.. + then + + (* ;; "Be careful here that aborting or killing the evaluation still causes the calling process to see a result.") + + [LET ((..PEV-RESULT.. :ABORTED)) + (CL:UNWIND-PROTECT + (SETQ ..PEV-RESULT.. (APPLY ..PEV-FN.. ..PEV-ARGS..)) + (replace PROCEVAPPLYRESULT of ..PEV-PROC.. with ..PEV-RESULT..) + (COND + ((NEQ (fetch PROCSTATUS of ..PEV-PROC..) + \PSTAT.RUNNING) (* ; "Make caller run.") + (\RUN.PROCESS ..PEV-PROC..))))] + else (* ; "Just call it.") + (APPLY ..PEV-FN.. ..PEV-ARGS..]) ) (* ; "Standard values for WAKEREASON -- PSTAT.TIMEDOUT is the only public one") (RPAQ PSTAT.WAKEUP "default WakeUp") (RPAQ PSTAT.TIMEDOUT "{time interval expired}") (RPAQ PSTAT.QUIT "Quit") (RPAQ \PSTAT.NORESULT "{no result yet}") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PSTAT.WAKEUP PSTAT.TIMEDOUT PSTAT.QUIT \PSTAT.NORESULT) ) (* ; "Event stuff") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE EVENT ((EVENTWAKEUPPENDING FLAG) (* ;  "True if this event was signaled with nobody waiting on it") (NIL BITS 3) (EVENTQUEUETAIL POINTER) (* ;  "Pointer to last process waiting on this event") (EVENTNAME POINTER) (* ;  "Optional name of EVENT for status window, debugging, etc") ) (ACCESSFNS EVENT ((EVLOCKQUEUETAIL (ffetch EVENTQUEUETAIL of DATUM) (freplace EVENTQUEUETAIL of DATUM with NEWVALUE))) (* ;  "Used by both EVENT and MONITORLOCK data") )) ) (/DECLAREDATATYPE 'EVENT '(FLAG (BITS 3) POINTER POINTER) '((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) (EVENT 2 POINTER)) '4) ) (/DECLAREDATATYPE 'EVENT '(FLAG (BITS 3) POINTER POINTER) '((EVENT 0 (FLAGBITS . 0)) (EVENT 0 (BITS . 18)) (EVENT 0 POINTER) (EVENT 2 POINTER)) '4) (ADDTOVAR SYSTEMRECLST (DATATYPE EVENT ((EVENTWAKEUPPENDING FLAG) (NIL BITS 3) (EVENTQUEUETAIL POINTER) (EVENTNAME POINTER))) ) (DEFINEQ (CREATE.EVENT + [LAMBDA (NAME) (* bvm%: " 5-MAY-83 11:00") + (create EVENT + EVENTNAME _ NAME]) (NOTIFY.EVENT + [LAMBDA (EVENT ONCEONLY) (* bvm%: " 3-Jan-85 12:10") + + (* ;; "Wake up any process waiting for EVENT, or only the first one if ONCEONLY is true") + + (SETQ EVENT (\DTEST EVENT 'EVENT)) + (PROG (PROC SUCCESS TAIL) + LP (UNINTERRUPTABLY + (COND + ((SETQ TAIL (ffetch EVENTQUEUETAIL of EVENT)) + (SETQ PROC (fetch PROCEVENTLINK of TAIL)) + [COND + ((EQ PROC TAIL) + (freplace EVENTQUEUETAIL of EVENT with (SETQ TAIL NIL))) + (T (replace PROCEVENTLINK of TAIL with (fetch PROCEVENTLINK + of PROC] + (replace PROCEVENTLINK of PROC with (replace PROCEVENTORLOCK + of PROC with NIL)) + (\RUN.PROCESS PROC EVENT) + (SETQ SUCCESS T)) + ((NOT SUCCESS) + + (* ;; "Indicate that a wakeup was signaled, even though nobody was waiting. Handles most cases where the wakeup would otherwise be lost by occurring between a process's testing a condition and waiting on the event") + + (freplace EVENTWAKEUPPENDING of EVENT with T)))) + (COND + ((AND TAIL (NOT ONCEONLY)) + (GO LP]) (AWAIT.EVENT + [LAMBDA (EVENT TIMEOUT TIMERP) (* bvm%: " 5-Nov-85 11:09") + [COND + (TIMEOUT (* ; + "Check args before going uninterruptable") + (SETQ TIMEOUT (COND + (TIMERP (\DTEST TIMEOUT 'FIXP)) + ((TYPENAMEP TIMEOUT 'BIGNUM) + MAX.FIXP) + (T (FIX TIMEOUT] + (\PROCESS.GO.TO.SLEEP (\DTEST EVENT 'EVENT) + TIMEOUT TIMERP]) (\UNQUEUE.EVENT + [LAMBDA (PROC EVENT) (* bvm%: " 3-Jan-85 12:34") + + (* ;; "Remove PROC from EVENT's queue. EVENT is an EVENT or MONITORLOCK. Their queues consist of a pointer to the last item in the queue, which in turn points to the first item") + + (PROG ((TAIL (ffetch EVLOCKQUEUETAIL of EVENT)) + NEXT) + [COND + ((NOT TAIL) + (\MP.ERROR \MP.PROCERROR "Process not on its EVENT/MONITOR queue" PROC)) + (T (while (NEQ PROC (SETQ NEXT (ffetch PROCEVENTLINK of TAIL))) + do (SETQ TAIL NEXT)) + (COND + ((EQ PROC TAIL) + (freplace EVLOCKQUEUETAIL of EVENT with NIL)) + (T (replace PROCEVENTLINK of TAIL with (fetch PROCEVENTLINK + of PROC)) + (COND + ((EQ PROC (fetch EVLOCKQUEUETAIL of EVENT)) + (freplace EVLOCKQUEUETAIL of EVENT with (fetch + PROCEVENTLINK + of PROC] + (replace PROCEVENTORLOCK of PROC with NIL) + (replace PROCEVENTLINK of PROC with NIL]) (\ENQUEUE.EVENT/LOCK + [LAMBDA (PROC EVLOCK) (* bvm%: " 3-Jan-85 12:15") + +(* ;;; +"Enqueue process PROC on EVLOCK's waiting queue. EVLOCK is either an EVENT or a MONITORLOCK") + + (PROG (TAIL) + (replace PROCEVENTORLOCK of PROC with EVLOCK) + + (* ;; "Put PROC at end of event or monitorlock's queue. Queue tail is pointed to by a common field in EVENT and MONITORLOCK. The tail itself points at the first item in the queue") + + (freplace PROCEVENTLINK of PROC with (COND + ((SETQ TAIL (ffetch EVLOCKQUEUETAIL + of EVLOCK)) + (PROG1 (fetch PROCEVENTLINK + of TAIL) + (freplace PROCEVENTLINK + of TAIL with PROC))) + (T PROC))) + (freplace EVLOCKQUEUETAIL of EVLOCK with PROC]) (\EVENT.DEFPRINT + [LAMBDA (EVENT STREAM) (* ; "Edited 8-May-87 15:55 by bvm") + (\DEFPRINT.BY.NAME EVENT STREAM (fetch (EVENT EVENTNAME) of EVENT) + "Event"]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS AWAIT.CONDITION MACRO [(CONDITION EVNT TIMEOUT TIMERP) (PROG [($$TIMER TIMEOUT) ($$EV (\DTEST EVNT 'EVENT] (DECLARE (LOCALVARS $$TIMER $$EV)) LP (RETURN (OR CONDITION (COND ((NEQ (\PROCESS.GO.TO.SLEEP $$EV $$TIMER TIMERP) $$EV) NIL) (T (AND $$TIMER (SETQ $$TIMER T)) (GO LP]) ) (RPAQ? \PROCESS.AFTEREXIT.EVENT ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PROCESS.AFTEREXIT.EVENT) ) (* ; "Monitor stuff") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE MONITORLOCK ((NIL FLAG) (MLOCKPERPROCESS FLAG) (* ;  "Monitor's use by anybody in process lets everyone in that proc use it, the normal case") (NIL BITS 2) (MLOCKQUEUETAIL POINTER) (* ;  "Last process waiting for monitor to become available") (MLOCKOWNER POINTER) (* ; "Process owning it") (MLOCKNAME POINTER) (* ;  "optional name, for debugging, etc") (MLOCKLINK POINTER) (* ;  "Link to next lock owned by my owner") )) ) (/DECLAREDATATYPE 'MONITORLOCK '(FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER) '((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) (MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER)) '8) (DECLARE%: EVAL@COMPILE (PUTPROPS .RELEASE.LOCK. MACRO [(LOCK EVENIFNOTMINE) (UNINTERRUPTABLY [PROG ((OWNER (ffetch MLOCKOWNER of LOCK)) TAIL PREV NEXTPROC) (COND ((OR (NULL OWNER) (AND (NEQ OWNER (THIS.PROCESS)) (NOT EVENIFNOTMINE))) (RETURN))) (freplace MLOCKOWNER of LOCK with NIL) (* ;  "Now remove LOCK from my list of owned locks") [COND ((EQ (SETQ PREV (fetch PROCOWNEDLOCKS of OWNER)) LOCK) (replace PROCOWNEDLOCKS of OWNER with (ffetch MLOCKLINK of LOCK))) (T (do (COND ((NULL PREV) (RETURN (\MP.ERROR \MP.PROCERROR "Lock not found among owner's owned locks" LOCK))) [(EQ (fetch MLOCKLINK of PREV) LOCK) (RETURN (replace MLOCKLINK of PREV with (ffetch MLOCKLINK of LOCK] (T (SETQ PREV (fetch MLOCKLINK of PREV] (freplace MLOCKLINK of LOCK with NIL) (COND ((SETQ TAIL (ffetch MLOCKQUEUETAIL of LOCK)) (SETQ NEXTPROC (fetch PROCEVENTLINK of TAIL)) [COND ((EQ NEXTPROC TAIL) (* ; "Only one process in queue") (freplace MLOCKQUEUETAIL of LOCK with NIL)) (T (replace PROCEVENTLINK of TAIL with (fetch PROCEVENTLINK of NEXTPROC] (replace PROCEVENTLINK of NEXTPROC with (replace PROCEVENTORLOCK of NEXTPROC with NIL)) (\RUN.PROCESS NEXTPROC LOCK])]) ) ) (/DECLAREDATATYPE 'MONITORLOCK '(FLAG FLAG (BITS 2) POINTER POINTER POINTER POINTER) '((MONITORLOCK 0 (FLAGBITS . 0)) (MONITORLOCK 0 (FLAGBITS . 16)) (MONITORLOCK 0 (BITS . 33)) (MONITORLOCK 0 POINTER) (MONITORLOCK 2 POINTER) (MONITORLOCK 4 POINTER) (MONITORLOCK 6 POINTER)) '8) (ADDTOVAR SYSTEMRECLST (DATATYPE MONITORLOCK ((NIL FLAG) (MLOCKPERPROCESS FLAG) (NIL BITS 2) (MLOCKQUEUETAIL POINTER) (MLOCKOWNER POINTER) (MLOCKNAME POINTER) (MLOCKLINK POINTER))) ) (DEFINEQ (OBTAIN.MONITORLOCK + [LAMBDA (LOCK DONTWAIT UNWINDSAVE) (* ; "Edited 24-Feb-87 14:45 by bvm:") + + (* ;; "Attempts to acquire lock. If lock is busy, waits until it is available, unless DONTWAIT is true, in which case it returns NIL immediately. Returns LOCK if it grabbed the lock, T if the current process already had the lock. If UNWINDSAVE is true, does the appropriate RESETSAVE to release the lock on exit of the surrounding RESETLST") + + (SETQ LOCK (\DTEST LOCK 'MONITORLOCK)) + (PROG ((PROC (THIS.PROCESS)) + (WASINTERRUPTABLE \INTERRUPTABLE) + (\INTERRUPTABLE)) + LP (RETURN (COND + ((NULL (fetch MLOCKOWNER of LOCK)) + (* ; "Lock is idle") + [SELECTQ UNWINDSAVE + (NIL) + (WITH.MONITOR (* ; "from WITH.MONITOR macro -- set variable freely to be unlocked by SI::MONITOR-UNWIND. Do it this way rather than in caller to reduce the possibility that it won't get unlocked") + (SETQ SI::*LOCKED-MONITOR* LOCK)) + (PROGN (* ; + "The normal RESETLST method of ensuring unwind") + (RESETSAVE (PROGN LOCK) + '(RELEASE.MONITORLOCK OLDVALUE] + (replace MLOCKOWNER of LOCK with PROC) + (replace MLOCKLINK of LOCK with (fetch PROCOWNEDLOCKS + of PROC)) + (* ; + "Link lock into list of those owned by this process") + (replace PROCOWNEDLOCKS of PROC with LOCK) + (* ; "return lock for those that care") + LOCK) + [(EQ (fetch MLOCKOWNER of LOCK) + PROC) (* ; "My process already owns it") + (COND + ((fetch MLOCKPERPROCESS of LOCK) + (* ; "ok, per-process lock") + T) + (T (ERROR "Trying to acquire lock exclusively owned already by this process" + LOCK] + ((NOT DONTWAIT) + (PROG ((\INTERRUPTABLE WASINTERRUPTABLE)) + (\PROCESS.GO.TO.SLEEP LOCK)) + (GO LP]) (CREATE.MONITORLOCK + [LAMBDA (NAME EXCLUSIVE) (* bvm%: "17-MAY-83 17:58") + (create MONITORLOCK + MLOCKPERPROCESS _ (NOT EXCLUSIVE) + MLOCKNAME _ NAME]) (RELEASE.MONITORLOCK + [LAMBDA (LOCK EVENIFNOTMINE) (* bvm%: "22-Nov-86 18:40") + (COND + ((EQ LOCK 'OLDVALUE) (* ; "Hack for RESETSAVE") + (SETQ LOCK OLDVALUE))) + (SETQ LOCK (\DTEST LOCK 'MONITORLOCK)) + (.RELEASE.LOCK. LOCK EVENIFNOTMINE]) (SI::MONITOR-UNWIND + [LAMBDA NIL (* ; "Edited 24-Feb-87 14:51 by bvm:") + + (* ;; "Cleanup fn for WITH.MONITOR's implicit unwind-protect.") + + (if SI::*RESETFORMS* + then + + (* ;; "WITH.MONITOR used to be implicit RESETLST, so best to keep it that way--handle RESETSAVEs before releasing lock") + + (SI::RESETUNWIND)) + (LET ((LOCK SI::*LOCKED-MONITOR*)) + (if LOCK + then (SETQ LOCK (\DTEST LOCK 'MONITORLOCK)) + (.RELEASE.LOCK. LOCK]) (MONITOR.AWAIT.EVENT + [LAMBDA (RELEASELOCK EVENT TIMEOUT TIMERP) (* bvm%: " 5-Nov-85 11:10") + [COND + (TIMEOUT (* ; + "Check args before going uninterruptable") + (SETQ TIMEOUT (COND + (TIMERP (\DTEST TIMEOUT 'FIXP)) + ((TYPENAMEP TIMEOUT 'BIGNUM) + MAX.FIXP) + (T (FIX TIMEOUT] + (RELEASE.MONITORLOCK RELEASELOCK) + (PROG1 (\PROCESS.GO.TO.SLEEP (\DTEST EVENT 'EVENT) + TIMEOUT TIMERP) + (OBTAIN.MONITORLOCK RELEASELOCK]) (\MONITORLOCK.DEFPRINT + [LAMBDA (LOCK STREAM) (* ; "Edited 8-May-87 15:55 by bvm") + (\DEFPRINT.BY.NAME LOCK STREAM (fetch (MONITORLOCK MLOCKNAME) of LOCK) + "Lock"]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS WITH.MONITOR MACRO [(LOCK . FORMS) (LET (SI::*LOCKED-MONITOR* SI::*RESETFORMS*) (DECLARE (CL:SPECIAL SI::*LOCKED-MONITOR* SI::*RESETFORMS*)) (CL:UNWIND-PROTECT (PROGN (OBTAIN.MONITORLOCK LOCK NIL 'WITH.MONITOR) . FORMS) (SI::MONITOR-UNWIND))]) (PUTPROPS WITH.FAST.MONITOR MACRO [(LOCK . FORMS) (UNINTERRUPTABLY ([LAMBDA (UNLOCK) (PROG1 (PROGN . FORMS) (AND (NEQ UNLOCK T) (RELEASE.MONITORLOCK UNLOCK)))] (OBTAIN.MONITORLOCK LOCK)))]) ) (DEFINEQ (\MAKE.PROCESS0 + [LAMBDA (FORM HANDLE) (* ; "Edited 18-Jan-87 17:25 by bvm:") + (DECLARE (LOCALVARS . T) + (SPECVARS %#FORM# HELPFLAG \CURRENTDISPLAYLINE \#DISPLAYLINES \LINEBUF.OFD + *STANDARD-INPUT* *READTABLE* \PRIMREADTABLE \PRIMTERMTABLE \PRIMTERMSA + TtyDisplayStream \TERM.OFD \TTYWINDOW *STANDARD-OUTPUT* \INTERRUPTABLE READBUF + *CURRENT-PROCESS* SI::*RESETFORMS* *DRIBBLE-OUTPUT*) + (GLOBALVARS \DEFAULTLINEBUF \DEFAULTTTYDISPLAYSTREAM)) + (PROG ((%#FORM# FORM) + (*CURRENT-PROCESS* HANDLE) + (SI::*RESETFORMS*) + (HELPFLAG (AND HELPFLAG 'BREAK!)) + (\CURRENTDISPLAYLINE 0) + (\#DISPLAYLINES 40) + (\LINEBUF.OFD (OR \DEFAULTLINEBUF \LINEBUF.OFD)) + (*READTABLE* *READTABLE*) + (\PRIMTERMTABLE \PRIMTERMTABLE) + (\PRIMTERMSA \PRIMTERMSA) + (TtyDisplayStream \DEFAULTTTYDISPLAYSTREAM) + (\INTERRUPTABLE) + (\TTYWINDOW) + (READBUF) + \TERM.OFD *STANDARD-OUTPUT* *STANDARD-INPUT* RESULT TMP) + (* ; + "HELPFLAG set to ensure breaks occur. Proc can rebind if desired") + + (* ;; "\TTYWINDOW is currently just a place to hold onto the WINDOW of the TtyDisplayStream in case user closes same and then someone prints to TtyDisplayStream") + + (\MISCAPPLY* (FUNCTION \PROCESS.MOVEFRAME)) (* ; "Move me to the boonies") + [SETQ *STANDARD-OUTPUT* (SETQ \TERM.OFD (COND + (TtyDisplayStream (\GETOFD TtyDisplayStream + 'OUTPUT)) + (T (* ; + "For init time, before LLDISPLAY sets up") + (GETTOPVAL '\TERM.OFD] + (SETQ *STANDARD-INPUT* \LINEBUF.OFD) + (PROGN + (* ;; "Make this proc use a piece of its PROCESS handle as the binding place for *DRIBBLE-OUTPUT*. This lets its survive a HARDRESET. The extra third arg to \SETFVARSLOT is so that the compiler will create a fvar slot for *DRIBBLE-OUTPUT* in the first place.") + + (\SETFVARSLOT '*DRIBBLE-OUTPUT* (LOCF (fetch PROCDRIBBLEOUTPUT of HANDLE)) + *DRIBBLE-OUTPUT*)) + (\MAKE.PROCESS1 HANDLE) + (SETQ \INTERRUPTABLE T) (* ; "Safe to go interruptable now") + [if (SETQ TMP (fetch PROCHARDRESETINFO of HANDLE)) + then (* ; + "new style cleanup from HARDRESET") + (if (EQ TMP 'ERROR) + then (printout T T + "***Warning: errors occurred recovering stack for process " + (fetch PROCNAME of HANDLE) + "; cleanups not run" T) + else (SELECTQ (\HARDRESET-CLEANUP HANDLE) + (ERROR (printout T T + "***Warning: errors occurred running cleanups for process " + (fetch PROCNAME of HANDLE) + T)) + (T (* ; "ok")) + (GO ABORT] + (if (fetch PROCFINISHED of HANDLE) + then (* ; + "Happens after a HARDRESET -- proc was restarted only long enough to clean up after itself") + (GO DIE)) + LP (* ; + "Unwind anything left from last invocation") + (if SI::*RESETFORMS* + then (LET [(RESETSTATE (COND + ((EQ RESULT \PROC.RESETME) + (* ; "From RESET") + 'RESET) + (T 'HARDRESET] + (DECLARE (SPECVARS RESETSTATE)) + (SI::RESETUNWIND))) + (\PROCESS.RELEASE.LOCKS HANDLE) + (SETQ RESULT (\EVAL %#FORM#)) + (if (EQ RESULT \PROC.KILLME) + then (* ; "from \UNWIND.PROCESS") + (GO DIE) + elseif (EQ RESULT \PROC.RESTARTME) + then (* ; "from RESTART.PROCESS") + (SETQ %#FORM# (OR (fetch PROCRESTARTFORM of HANDLE) + %#FORM#)) + (GO LP) + elseif (EQ RESULT \PROC.RESETME) + then (* ; + "RESET or ERROR! -- maybe restart") + (if (EQ (fetch RESTARTABLE of HANDLE) + T) + then (* ; "Autorestart on errors") + (SETQ %#FORM# (OR (fetch PROCRESTARTFORM of HANDLE) + %#FORM#)) + (GO LP)) + else (* ; "normal termination") + (replace PROCRESULT of HANDLE with RESULT) + (replace PROCFINISHED of HANDLE with 'NORMAL) + (GO DIE)) + ABORT + (printout PROMPTWINDOW T (fetch PROCNAME of HANDLE) + " aborted.") + (replace PROCFINISHED of HANDLE with 'ERROR) + DIE (if SI::*RESETFORMS* + then (* ; + "Every process has implicit RESETLST at top, so do it") + (LET ((RESETSTATE 'RESET)) + (DECLARE (SPECVARS RESETSTATE)) + (SI::RESETUNWIND))) + (DRIBBLE) (* ; "Close dribble file, if any") + (LET ((EVENT (fetch PROCFINISHEVENT of HANDLE))) + (AND EVENT (NOTIFY.EVENT EVENT))) + (COND + ((EQ HANDLE (TTY.PROCESS)) (* ; + "It is possible that while unwinding, so this check happens very late") + (TTY.PROCESS T))) + (\PROCESS.RELEASE.LOCKS HANDLE) + (\PROCESS.GO.TO.SLEEP NIL NIL NIL T]) (\MAKE.PROCESS1 + [LAMBDA (PROC) (* bvm%: " 8-Jun-85 23:14") + +(* ;;; "Called by \MAKE.PROCESS0 to set up PROC's initial handle and then return to its caller, usually ADD.PROCESS --- we have here a partial exchange of stack pointers: PROC gets pointer to \MAKE.PROCESS0 frame, \MAKE.PROCESS0 points to T, we return to former parent of \MAKE.PROCESS0; the only use count that changes is the T frame, which now has one more user") + + (UNINTERRUPTABLY + (LET ((MP0 (\MYALINK)) + (TOP (\STACKARGPTR T)) + MP0CALLER) + [COND + ((NEQ 0 (fetch PROCFX of PROC)) (* ; + "Should never happen, but let's be consistent with stackp use") + (\DECUSECOUNT (fetch PROCFX of PROC] + (SETQ MP0CALLER (fetch (FX ALINK) of MP0)) + (replace PROCFX of PROC with MP0) (* ; + "Fix proc handle to return to \MAKE.PROCESS0") + (replace (FX ACLINK) of MP0 with TOP) + (* ; + "Detach \MAKE.PROCESS0 from the ADD.PROCESS stack") + (\INCUSECOUNT TOP) + (\RESUME MP0CALLER) (* ; + "Make me return to the caller of \MAKE.PROCESS0") + NIL))]) (\PROCESS.MOVEFRAME + [LAMBDA NIL (* bvm%: " 8-Jun-85 22:30") + + (* ;; "Called in misc context to move a frame to a big free area") + + (FLIPCURSORBAR 12) + (PROG ((OLDFRAME (fetch MiscFXP of \InterfacePage)) + NXT NEW FRAMESIZE BFSIZE RESIDUAL FREESIZE FXSIZE BLINK INITSIZE) + (SETQ BLINK (fetch (FX DUMMYBF) of OLDFRAME)) + [SETQ FRAMESIZE (IPLUS (SETQ FXSIZE (fetch (FX SIZE) of OLDFRAME)) + (SETQ BFSIZE (COND + ((OR (fetch (BF RESIDUAL) of BLINK) + (SETQ RESIDUAL (NEQ (fetch (BF USECNT) + of BLINK) + 0))) + WORDSPERCELL) + (T (fetch (BF SIZE) of BLINK] + (SETQ NEW (\FREESTACKBLOCK (SETQ FREESIZE (IPLUS FRAMESIZE PROC.FREESPACESIZE)) + OLDFRAME)) (* ; "Find a free stack block") + [COND + ((type? FSB (SETQ NXT (IPLUS NEW FREESIZE))) + + (* ;; "\FREESTACKBLOCK normally sticks a free block after the block it returns. We will massage them together") + + (add FREESIZE (fetch (FSB SIZE) of NXT] + (SETQ INITSIZE (FLOOR (LRSH (IDIFFERENCE FREESIZE FRAMESIZE) + 1) + WORDSPERCELL)) (* ; "Size of free block to go before") + (COND + ((EVENP (IPLUS NEW INITSIZE BFSIZE) + WORDSPERQUAD) (* ; "FX must be odd-quad aligned") + (add INITSIZE WORDSPERCELL))) + (\MAKEFREEBLOCK NEW INITSIZE) + (add NEW INITSIZE) + (SETQ FREESIZE (IDIFFERENCE FREESIZE INITSIZE)) + (\BLT (ADDSTACKBASE NEW) + (ADDSTACKBASE (IDIFFERENCE OLDFRAME BFSIZE)) + FRAMESIZE) (* ; + "Copy FX and BF into middle of new free area") + (COND + (RESIDUAL (replace (BF RESIDUAL) of NEW with T)) + ((NOT (fetch (BF RESIDUAL) of BLINK)) (* ; "Point new BF at itself") + (replace (BF IVAR) of (IPLUS NEW (IDIFFERENCE BFSIZE WORDSPERCELL)) + with NEW))) + (add NEW BFSIZE) (* ; "now NEW points to the FX") + (replace (FX NEXTBLOCK) of NEW with (SETQ NXT (IPLUS NEW FXSIZE))) + [replace (FX BLINK) of NEW with (COND + (RESIDUAL + (* ; "Point at real bf") + (fetch (FX BLINK) of OLDFRAME + )) + (T (IDIFFERENCE NEW WORDSPERCELL] + [COND + ((AND (fetch (FX VALIDNAMETABLE) of NEW) + (EQ (fetch (FX NAMETABHI) of NEW) + \STACKHI)) + (CHECK ([LAMBDA (N) + (AND (IGREATERP N OLDFRAME) + (ILESSP N (fetch (FX NEXTBLOCK) of OLDFRAME] + (fetch (FX NAMETABLO) of OLDFRAME))) + (add (fetch (FX NAMETABLO) of NEW) + (IDIFFERENCE NEW OLDFRAME] + (\MAKEFREEBLOCK NXT (IDIFFERENCE FREESIZE FRAMESIZE)) + (* ; "Install free block after frame") + (COND + (RESIDUAL (\MAKEFREEBLOCK OLDFRAME (IDIFFERENCE FRAMESIZE WORDSPERCELL))) + (T (\MAKEFREEBLOCK (IDIFFERENCE OLDFRAME BFSIZE) + FRAMESIZE))) (* ; + "Finally free up the original frame") + OUT (replace MiscFXP of \InterfacePage with NEW) + (FLIPCURSORBAR 12) (* ; "Restore cursor") + (RETURN NEW]) (\RELEASE.PROCESS + [LAMBDA (PROC KILLIT RESTARTFLG) (* ; "Edited 1-Jun-88 15:38 by bvm") + + (* ;; "Disentangle PROC from process land. If KILLIT is true, free all resources associated with it, since we are about to delete it. RESTARTFLG is when killing a process at HARDRESET. Must be called uninterruptably.") + + (PROG ((EVENT (fetch PROCEVENTORLOCK of PROC)) + FX WINDOW) + (CHECK (NULL \INTERRUPTABLE)) + (COND + ((NEQ (SETQ FX (fetch PROCFX of PROC)) + 0) + (\DECUSECOUNT FX) + (replace PROCFX of PROC with 0))) + (COND + (EVENT (\UNQUEUE.EVENT PROC EVENT))) + (COND + ((fetch PROCTIMERSET of PROC) + (\UNQUEUE.TIMER PROC T))) + (COND + [KILLIT (for OTHER in \PROCESSES when (EQ (fetch PROCOLDTTYPROC + of OTHER) + PROC) + do (* ; + "remove links to the dead proc from others") + (replace PROCOLDTTYPROC of OTHER with NIL)) + (replace PROCOLDTTYPROC of PROC with NIL) + [COND + ((NOT RESTARTFLG) (* ; "From PROCESSWORLD on HARDRESET. In this case, \processes is being iterated over, so we don't want to suffer the DREMOVE bug.") + (SETQ \PROCESSES (DREMOVE PROC \PROCESSES] + (REMHASH (fetch PROCNAME of PROC) + \PROCESS.NAME.TABLE) + (\INVALIDATE.PROCESS.WINDOW) + (replace PROCDELETED of PROC with T) + (replace PROCSTATUS of PROC with \PSTAT.DELETED) + (replace PROCFORM of PROC with (replace PROCRESTARTFORM + of PROC + with (replace PROCQUEUE + of PROC + with NIL))) + (COND + ((SETQ WINDOW (fetch PROCWINDOW of PROC)) + (* ; "Break link to proc's window") + (replace PROCWINDOW of PROC with NIL) + (WINDOWPROP WINDOW 'PROCESS NIL] + (T (replace PROCSTATUS of PROC with \PSTAT.WAITING) + (replace PROCTIMERSET of PROC with NIL))) + (replace NEXTPROCHANDLE of PROC with NIL]) (\UNWIND.PROCESS + [LAMBDA (P) (* ; "Edited 2-Dec-86 20:35 by bvm:") + (OR (fetch PROCFINISHED of P) + (replace PROCFINISHED of P with 'DELETED)) + (replace PROCBEINGDELETED of P with T) + (RETTO '\MAKE.PROCESS0 \PROC.KILLME]) (\MAYBEBLOCK + [LAMBDA NIL (* bvm%: "21-JUN-83 16:01") + (COND + (\INTERRUPTABLE (BLOCK]) (\BACKGROUND.PROCESS + [LAMBDA NIL (* bvm%: "24-JUL-83 15:35") + (PROG NIL + LP (for FN in BACKGROUNDFNS do (SPREADAPPLY* FN)) + (BLOCK) + (GO LP]) (\MOUSE.PROCESS + [LAMBDA NIL (* ; "Edited 10-Nov-87 11:18 by bvm:") + (DECLARE (SPECVARS \OLDTTY \MOUSEBUSY)) + (PROG (\OLDTTY \MOUSEBUSY OTHERMOUSE) + LP [COND + ((NEQ (fetch PROCNAME of (THIS.PROCESS)) + 'MOUSE) (* ; + "A new mouse process sprung up while we were hung") + (COND + ((AND (SETQ OTHERMOUSE (FIND.PROCESS 'MOUSE)) + (PROCESS.EVALV OTHERMOUSE '\MOUSEBUSY)) + (* ; + "The other mouse is still busy, so we can't kill it. Die instead") + (PROCESS.RETURN)) + (T (COND + (OTHERMOUSE (* ; + "Kill off the mouse process that took our place") + (\SET.PROCESS.NAME OTHERMOUSE "DeadMouse" T) + (* ; "Have to change its name, since we are about to become the unique MOUSE proc, and the DEL.PROCESS does not take effect immediately.") + (DEL.PROCESS OTHERMOUSE) + (SETQ OTHERMOUSE) (* ; + "Don't inadvertantly hold a pointer to this dead process") + )) + (replace PROCSYSTEMP of (THIS.PROCESS) with T) + (\SET.PROCESS.NAME (THIS.PROCESS) + 'MOUSE T] + (COND + (\WINDOWWORLD (WINDOW.MOUSE.HANDLER))) + (COND + ((TTY.PROCESSP) (* ; + "Give up the tty if we still have it") + (TTY.PROCESS (COND + ((NEQ \OLDTTY (THIS.PROCESS)) + \OLDTTY) + (T T))) + (SETQ \OLDTTY))) + (replace PROCTYPEAHEAD of (THIS.PROCESS) with NIL) + (* ; + "No sense keeping around this typeahead") + (BLOCK) + (GO LP]) (\TIMER.PROCESS + [LAMBDA NIL (* bvm%: " 1-AUG-83 15:17") + + (* ;; "This process runs at default priority and tests for processes that have timed out") + + (PROG ((\INTERRUPTABLE NIL) + (HEAD \TIMERQHEAD) + PROC) + LP (COND + ((AND (SETQ PROC (fetch PROCTIMERLINK of HEAD)) + (TIMEREXPIRED? (fetch PROCWAKEUPTIMER of PROC))) + (\RUN.PROCESS PROC PSTAT.TIMEDOUT)) + (T (BLOCK))) + (GO LP]) (\PROCESS.RELEASE.LOCKS + [LAMBDA (P) (* bvm%: "12-Nov-86 18:07") + (while (fetch PROCOWNEDLOCKS of P) do (RELEASE.MONITORLOCK (fetch + PROCOWNEDLOCKS + of P]) (\SET.PROCESS.NAME + [LAMBDA (PROC NEWNAME INTERNAL) (* ; "Edited 28-Jan-93 17:44 by jds") + +(* ;;; "Changes proc's name to be newname. Unless INTERNAL is true, the name is checked for validity and is coerced to one not in use by any active process") + + [COND + ((NOT INTERNAL) (* ; " check name") + (PROG NIL + RETRY + (SELECTQ (TYPENAME NEWNAME) + ((LITATOM NEW-ATOM STRINGP)) + (LISTP (SETQ NEWNAME (CAR NEWNAME)) + (GO RETRY)) + (SETQ NEWNAME (MKSTRING NEWNAME))) + (COND + ((OR (NULL NEWNAME) + (EQ NEWNAME T)) + (SETQ NEWNAME (ERROR "Illegal Process Name" NEWNAME)) + (GO RETRY] + (UNINTERRUPTABLY + [COND + ((AND (NOT INTERNAL) + (FIND.PROCESS NEWNAME)) (* ; + "Proc by this name exists, so make another name") + (for I from 2 bind (FIRSTNAME _ NEWNAME) + while (FIND.PROCESS (SETQ NEWNAME (CONCAT FIRSTNAME "#" I] + (LET ((OLDNAME (FETCH PROCNAME OF PROC))) + (IF OLDNAME + THEN (REMHASH OLDNAME \PROCESS.NAME.TABLE)) + (PUTHASH NEWNAME PROC \PROCESS.NAME.TABLE) + (replace PROCNAME of PROC with NEWNAME) + NEWNAME))]) (\PROCESS.DEFPRINT + [LAMBDA (PROC STREAM) (* ; "Edited 8-May-87 15:54 by bvm") + + (* ;; "Print process using its name, for example, #") + + (\DEFPRINT.BY.NAME PROC STREAM (fetch PROCNAME of PROC) + "Process"]) ) (DEFINEQ (\START.PROCESSES + [LAMBDA NIL (* bvm%: " 2-MAY-83 12:30") + (UNINTERRUPTABLY + (\RESCHEDULE %#SCHEDULER#))]) (\PROCESS.GO.TO.SLEEP + [LAMBDA (EVLOCK TIMEOUT TIMERP DELETEFLG) (* bvm%: " 3-Jan-85 12:34") + + (* ;; "puts the current process to sleep. EVLOCK is a lock or event to wait on, or NIL for neither. TIMEOUT is optional timeout to wake up if we haven't been woken any other way; monitor locks do not get timeouts. TIMERP=T means TIMEOUT is an absolute timer rather than an interval. TIMEOUT=T means continue using the timer from the last time we went to sleep. DELETEFLG means never to return.") + + (UNINTERRUPTABLY + [PROG ((PROC (THIS.PROCESS)) + HEAD TAIL PREV) + (OR PROC (RETURN (BLOCK))) + (COND + ((AND (type? EVENT EVLOCK) + (fetch EVENTWAKEUPPENDING of EVLOCK)) + (* ; + "Missed a wakeup for this event, take it now") + (replace EVENTWAKEUPPENDING of EVLOCK with NIL) + (RETURN EVLOCK))) + (replace PROCSTATUS of PROC with \PSTAT.WAITING) + (SETQ HEAD (fetch PROCQUEUE of PROC)) (* ; + "Now remove PROC from its run queue") + (SETQ PREV (fetch PQLAST of HEAD)) + [COND + [(EQ PROC PREV) (* ; "Nobody left at this level") + (COND + ((EQ PROC (fetch PQNEXT of HEAD)) + (replace PQLAST of HEAD with (replace PQNEXT of HEAD + with NIL))) + (T (\MP.ERROR \MP.PROCERROR "Inconsistent process queue state"] + (T (replace NEXTPROCHANDLE of PREV + with (replace PQNEXT of HEAD with (OR (fetch + NEXTPROCHANDLE + of PROC) + (\MP.ERROR \MP.PROCERROR + + "Running process has no NEXT pointer" + PROC] + (replace NEXTPROCHANDLE of PROC with NIL) + (COND + (EVLOCK (\ENQUEUE.EVENT/LOCK PROC EVLOCK))) + (replace PROCTIMERSET of PROC + with (COND + (TIMEOUT [COND + ((NEQ TIMEOUT T) + (replace PROCWAKEUPTIMER of PROC + with (COND + (TIMERP TIMEOUT) + (T (SETUPTIMER TIMEOUT (fetch + PROCTIMERBOX + of PROC] + (\ENQUEUE.TIMER PROC) + T))) + (RETURN (\RESCHEDULE (COND + (DELETEFLG (\RELEASE.PROCESS PROC T) + NIL) + (T PROC])]) (\PROC.RESUME + [LAMBDA (FRAME OLDFX) (* bvm%: " 6-Oct-86 14:22") + + (* ;; "Diddles caller so that it returns to FRAME. If OLDFX is non-NIL, it is released. Do it in this order so that the current stack is always valid") + + (replace (FX ACLINK) of (\MYALINK) with FRAME) + (AND OLDFX (\DECUSECOUNT OLDFX]) (\RUN.PROCESS + [LAMBDA (PROC REASON BRUTALLY) (* ; "Edited 6-Apr-92 11:39 by jds") + + (* ;; "Cause PROC to be placed in the runnable state, with REASON as the value to return from the call to a waiting function") + + (PROG ((PQUEUE (fetch PROCQUEUE of PROC)) + (EVENT (fetch PROCEVENTORLOCK of PROC)) + PREV NEXT) + (COND + ((AND (EQ (fetch PROCSTATUS of PROC) + \PSTAT.RUNNING) + (NOT BRUTALLY)) + (ERROR "Attempt to run already running process" PROC))) + (COND + ((fetch (PROCESS PROCDELETED) of PROC) + + (* ;; "Process has ended; don't bother restarting it.") + + (* ;; "This used to test PROCFINISHED, but that caused dying processes to hang around holding monitorlocks (JDS, fixing AR 11505)") + + NIL) + ((EQ (fetch PROCSTATUS of PROC) + \PSTAT.DELETED) (* ; + "Process has been deleted somehow; don't bother restarting it.") + NIL) + (T (* ; + "Go ahead and restart the process.") + (UNINTERRUPTABLY + (COND + (EVENT (\UNQUEUE.EVENT PROC EVENT))) + (COND + ((fetch PROCTIMERSET of PROC) + (\UNQUEUE.TIMER PROC))) + (SETQ PREV (fetch PQLAST of PQUEUE)) + (COND + [(NOT PREV) (* ; + "PROC will be the only process at this level") + (replace PQNEXT of PQUEUE + with (replace PQLAST of PQUEUE + with (replace NEXTPROCHANDLE of PROC with + PROC] + [\PROC.RUN.NEXT.FLG (SETQ NEXT (fetch PQNEXT of PQUEUE)) + (replace NEXTPROCHANDLE of PROC with (fetch + NEXTPROCHANDLE + of NEXT)) + (replace NEXTPROCHANDLE of NEXT with PROC) + (COND + ((EQ NEXT PREV) + (replace PQLAST of PQUEUE with PROC] + (T (replace NEXTPROCHANDLE of PROC with (fetch NEXTPROCHANDLE + of PREV)) + (replace NEXTPROCHANDLE of PREV with PROC) + (replace PQLAST of PQUEUE with PROC))) + (replace PROCSTATUS of PROC with \PSTAT.RUNNING) + (replace WAKEREASON of PROC with REASON))]) (\SUSPEND.PROCESS + [LAMBDA (PROC EVENT) (* bvm%: " 3-Jan-85 12:35") + +(* ;;; "Suspends PROC, not the running process, waiting on EVENT, or forever if EVENT = NIL") + + (UNINTERRUPTABLY + [PROG (PQHEAD PREV OLDEVENT NEXT LAST) + [COND + ((EQ (fetch PROCSTATUS of PROC) + \PSTAT.RUNNING) + + (* ;; "PROC is now running, so put it to sleep with no reason to wake. This is a simplification of \PROCESS.GO.TO.SLEEP") + + (replace PROCSTATUS of PROC with \PSTAT.WAITING) + (SETQ PQHEAD (fetch PROCQUEUE of PROC)) + (* ; + "Now remove PROC from its run queue") + (SETQ PREV (SETQ LAST (fetch PQLAST of PQHEAD))) + [do (SETQ NEXT (fetch NEXTPROCHANDLE of PREV)) + (COND + ((EQ NEXT PROC) + [COND + [(NEQ NEXT PREV) + (replace NEXTPROCHANDLE of PREV with (fetch + NEXTPROCHANDLE + of PROC)) + (COND + ((EQ PROC (fetch PQLAST of PQHEAD)) + (replace PQLAST of PQHEAD with PREV] + (T (* ; "Nobody left at this level") + (replace PQLAST of PQHEAD + with (replace PQNEXT of PQHEAD with NIL] + (RETURN))) + (COND + ((EQ (SETQ PREV NEXT) + LAST) + (\MP.ERROR \MP.PROCERROR "Can't find running process in its queue"] + (replace NEXTPROCHANDLE of PROC with NIL)) + (T (* ; + "Not running, so just keep it from waking up") + (COND + ((fetch PROCTIMERSET of PROC) + (\UNQUEUE.TIMER PROC))) + (COND + ((SETQ OLDEVENT (fetch PROCEVENTORLOCK of PROC)) + (COND + ((NEQ OLDEVENT EVENT) + (\UNQUEUE.EVENT PROC OLDEVENT)) + (T (* ; "Already queued for proper event") + (SETQ EVENT] + (COND + (EVENT (\ENQUEUE.EVENT/LOCK PROC EVENT])]) (\UNQUEUE.TIMER + [LAMBDA (PROC NOERROR) (* bvm%: "31-JUL-83 16:29") + + (* ;; "Remove PROC from the timer queue") + + (PROG ((PREV \TIMERQHEAD)) + LP (COND + ((EQ (fetch PROCTIMERLINK of PREV) + PROC) + (replace PROCTIMERLINK of PREV with (fetch PROCTIMERLINK of PROC))) + ((SETQ PREV (fetch PROCTIMERLINK of PREV)) + (GO LP)) + ((NULL NOERROR) + (ERROR "Process not found on timer queue" PROC))) + (replace PROCTIMERLINK of PROC with NIL) + (replace PROCTIMERSET of PROC with NIL]) (\ENQUEUE.TIMER + [LAMBDA (PROC) (* bvm%: " 7-SEP-83 13:48") + + (* ;; "Place PROC on the timer queue. Queue is ordered by timeout, so that the first item will timeout first") + + (UNINTERRUPTABLY + (PROG ((PREV \TIMERQHEAD) + (NEXT (fetch PROCTIMERLINK of \TIMERQHEAD))) + [COND + (NEXT (bind (TIMER _ \PROCTIMER.SCRATCH) + first (\BOXIPLUS (\BOXIDIFFERENCE TIMER TIMER) + (fetch PROCWAKEUPTIMER of PROC)) + while (AND NEXT (IGREATERP (\BOXIDIFFERENCE TIMER (fetch + PROCWAKEUPTIMER + of NEXT)) + 0)) do + (* ; + "NEXT will timeout before PROC, so keep going.") + (\BOXIPLUS TIMER (fetch + PROCWAKEUPTIMER + of NEXT)) + (* ; "Restore TIMER") + (SETQ NEXT (fetch PROCTIMERLINK + of (SETQ PREV NEXT] + + (* ;; "PROC goes between PREV and NEXT") + + (replace PROCTIMERLINK of PROC with NEXT) + (replace PROCTIMERLINK of PREV with PROC)))]) (\GET.PRIORITY.QUEUE + [LAMBDA (PRIORITY) (* bvm%: "29-APR-83 18:37") + (PROG ((HEAD \HIGHEST.PRIORITY.QUEUE) + PREV PQ) + [COND + ((NULL HEAD) + (RETURN (SETQ \HIGHEST.PRIORITY.QUEUE (create PROCESSQUEUE + PQPRIORITY _ PRIORITY] + LP (COND + ((EQ (fetch PQPRIORITY of HEAD) + PRIORITY) + (RETURN HEAD)) + ((IGREATERP (fetch PQPRIORITY of HEAD) + PRIORITY) + (SETQ HEAD (fetch PQLOWER of (SETQ PREV HEAD))) + (GO LP))) + (SETQ PQ (create PROCESSQUEUE + PQPRIORITY _ PRIORITY + PQHIGHER _ PREV + PQLOWER _ HEAD)) + (COND + (PREV (replace PQLOWER of PREV with PQ)) + (T (SETQ \HIGHEST.PRIORITY.QUEUE PQ))) + (RETURN PQ]) ) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \RESCHEDULE MACRO [LAMBDA (OLDPROC) (* ;; "Causes process switch, saving current context in OLDPROC's handle, or nowhere if OLDPROC is NIL. Must be called uninterruptably!") (PROG (PQUEUE PROC) TOP (* ;; "Maybe check for events here?") (SETQ PQUEUE \HIGHEST.PRIORITY.QUEUE) LP (COND ((SETQ PROC (fetch PQNEXT of PQUEUE)) [COND ((NEQ PROC OLDPROC) (* ;  "Yes, there is a process switch required here. Below is roughly the body of RESUME") (LET ((TOFX (fetch PROCFX of PROC)) FROMFX) (COND ((fetch (FX INVALIDP) of TOFX) (\MP.ERROR \MP.STACKRELEASED "Process's stack has been released!" PROC))) (SETQ \RUNNING.PROCESS PROC) (replace PROCFX of PROC with 0) (\PROC.RESUME TOFX (COND (OLDPROC (SETQ FROMFX (fetch PROCFX of OLDPROC) ) (COND ((NOT (fetch (FX INVALIDP) of FROMFX) ) (* ;  "Release stack pointer of OLDPROC if it hasn't been yet. should never happen") (\DECUSECOUNT FROMFX))) (replace PROCFX of OLDPROC with (\MYALINK)) NIL) (T (* ;  "no OLDPROC to resume later, so jettison caller") (\MYALINK] (RETURN (fetch WAKEREASON of PROC))) ((SETQ PQUEUE (fetch PQLOWER of PQUEUE)) (GO LP)) (T (* ;  "nobody runnable, wait for events") (\MP.ERROR \MP.PROCERROR "No runnable process!!" OLDPROC) (GO TOP]) ) ) (DEFINEQ (\PROCESS.INIT + [LAMBDA (DONTRESET) (* lmm "13-Sep-84 15:03") + (COND + ((CCODEP '\PROC.CODEFORTFRAME) + (\DEFINEDEVICE NIL (create FDEV + DEVICENAME _ 'PROCESS + EVENTFN _ (FUNCTION \PROCESS.EVENTFN) + DIRECTORYNAMEP _ 'NILL + HOSTNAMEP _ 'NILL)) + (\LOCKFN '\PROC.CODEFORTFRAME) + (/PUTD '\CODEFORTFRAME (GETD '\PROC.CODEFORTFRAME) + T) + (MOVD 'BLOCK '\BACKGROUND) + (OR DONTRESET (HARDRESET]) (\PROCESS.EVENTFN + [LAMBDA (DEV EVENTNAME) (* bvm%: " 3-Apr-84 12:01") + (SELECTQ EVENTNAME + ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) + [for PROC in (APPEND \PROCESSES) when (AND (ALIVEPROCP PROC) + (NEQ PROC (THIS.PROCESS))) + bind ACTION do (* ; + "What does this process want done for it after exit?") + (SELECTQ (SETQ ACTION (fetch PROCAFTEREXIT of PROC)) + (DELETE (DEL.PROCESS PROC)) + (SUSPEND (SUSPEND.PROCESS PROC)) + (COND + ((type? EVENT ACTION) + (* ; + "Cause PROC to wait on this event") + (\SUSPEND.PROCESS PROC ACTION)) + ((NEQ (fetch PROCNAME of PROC) + '\TIMER.PROCESS) + + (* ;; "Suspend process until system after exit events have run. This also has the side effect of eventually waking any process waiting on a timer, important since the timer is garbage over exit") + + (\SUSPEND.PROCESS PROC \PROCESS.AFTEREXIT.EVENT]) + ((BEFOREMAKESYS BEFORELOGOUT BEFORESYSOUT)) + NIL]) (\PROCESS.BEFORE.LOGOUT + [LAMBDA NIL (* ; "Edited 24-Feb-87 14:53 by bvm:") + +(* ;;; "Make sure we don't log out until processes that asked to run to completion actually finish") + + (RESETLST + [PROG (W) + RETRY + (for PROC in \PROCESSES + do (COND + ((EQ (fetch PROCBEFOREEXIT of PROC) + 'DON'T) + (ALLOW.BUTTON.EVENTS) (* ; + "in case logout called from mouse process, want to make sure user can get a PSW!") + [COND + ((NOT W) + (RESETSAVE NIL (LIST 'CLOSEW (SETQ W + (CREATEW '(260 247 453 173) + + "Waiting for process(es) to finish" + ] + (printout W T "Waiting for process " (fetch PROCNAME of PROC) + " to finish..." T + " [Use the process status window to kill it + if you really don't want to wait]" T) + (PROCESS.RESULT PROC T) (* ; "Wait for it to finish") + (GO RETRY])]) (\PROCESS.AFTER.EXIT + [LAMBDA (FLG) (* bvm%: " 4-Jan-85 12:49") + +(* ;;; +"Stuff to do after the system after exit eventfns are finished but before we release to the user") + + (NOTIFY.EVENT \PROCESS.AFTEREXIT.EVENT) + (SETQ \PROC.READY T]) (\PROCESS.RESET.TIMERS + [LAMBDA NIL (* ; "Edited 8-May-87 17:42 by bvm") + + (* ;; "Called when the time is up in the air -- clears timers on \SYSTEMTIMERVARS and wakes any process waiting only on a timer") + + (for TIMER in \SYSTEMTIMERVARS bind UNITS do [SETQ UNITS + (COND + ((LISTP TIMER) + (PROG1 (CADR TIMER) + (SETQ TIMER (CAR TIMER)))] + (SETUPTIMER 0 (COND + ((LITATOM TIMER) + (GETTOPVAL TIMER)) + (T TIMER)) + UNITS)) + (for PROC in \PROCESSES when (AND (EQ (fetch PROCSTATUS of PROC) + \PSTAT.WAITING) + (fetch PROCTIMERSET of PROC) + (NOT (fetch PROCEVENTORLOCK of PROC))) + do (\RUN.PROCESS PROC]) (\PROC.AFTER.WINDOWWORLD + [LAMBDA NIL (* kbr%: " 1-Feb-86 12:12") + (PROG [(EXECPROC (FIND.PROCESS 'EXEC] + (COND + ((AND EXECPROC (TYPENAMEP \TopLevelTtyWindow 'WINDOW)) + (replace PROCWINDOW of EXECPROC with \TopLevelTtyWindow) + (WINDOWPROP \TopLevelTtyWindow 'PROCESS EXECPROC))) + (COND + ([AND \WINDOWWORLD (NOT (FIND.PROCESS 'MOUSE] + (ADD.PROCESS '(\MOUSE.PROCESS) + 'NAME + 'MOUSE + 'RESTARTABLE + 'SYSTEM + 'SCHEDULE T]) (\TURN.ON.PROCESSES + [LAMBDA NIL (* bvm%: "12-Nov-86 18:18") + (for P in \PROCESSES do + + (* ;; + "CLEARSTK after HARDRESET did not get the process handles, so smash them now") + + (replace PROCFX of P with 0)) + (COND + ((OR AUTOPROCESSFLG (EQ (ASKUSER NIL NIL "^D -- run process scheduler? " NIL) + 'Y)) + [COND + ((AND NIL (LISTP RESETVARSLST)) (* ; + "Better unwind these now, since this RESETVARSLST binding will become invisible") + (RESETRESTORE NIL 'RESET] + (PROCESSWORLD T))) + 'OK]) ) (* ; "Redefinitions") (DEFINEQ (\PROC.CODEFORTFRAME + [LAMBDA NIL (* ; "Edited 10-Jan-91 16:42 by jds") + (\CALLME 'T) + (SETQ \RUNNING.PROCESS) + (CLEARSTK '**CLEAR**) + (\KEYBOARDON) (* ; + "restore keyboard after hard reset. Ideally, this should be done earlier.") + [COND + ((NEQ (\TURN.ON.PROCESSES) + 'OK) + (while T do (\MP.ERROR \MP.TOPUNWOUND "Unexpected (RETTO T)"] + + (* ;; "Normally never get here. There's a hack in \TURN.ON.PROCESSES that lets you run without processes, but I'm not sure you can even do that any more. The OK test is to catch inadvertant (RETTO T) calls") + + (INITIALEVALQT) + (PROG NIL + LP (\REPEATEDLYEVALQT) + (GO LP]) (\PROC.REPEATEDLYEVALQT + [LAMBDA NIL (* bvm%: "20-Jun-84 17:15") + (DECLARE (GLOBALVARS \TopLevelTtyWindow)) + (\CALLME '\REPEATEDLYEVALQT) + (INITIALEVALQT) + (PROG NIL + (TTYDISPLAYSTREAM \TopLevelTtyWindow) + (OUTPUT T) + (INPUT T) + LP (\RESETSYSTEMSTATE) + (EVALQT) + (GO LP]) ) (* ; "switching stacks") (DEFINEQ (BREAK.PROCESS + [LAMBDA (PROC) (* bvm%: "25-JUL-83 17:36") + (PROG ((P (\COERCE.TO.PROCESS PROC))) + (COND + ((EQ P (THIS.PROCESS)) + (\DOHELPINTERRUPT1)) + (T (\PROCESS.MAKEFRAME P (FUNCTION \DOHELPINTERRUPT1]) (\SELECTPROCESS + [LAMBDA (TITLE) (* bvm%: "30-Sep-86 21:22") + (LET ((TTYNAME (fetch PROCNAME of (TTY.PROCESS))) + (ME (fetch PROCNAME of (THIS.PROCESS))) + PROCNAMES NAME) + + (* ;; "Construct list of all processes. Put the running process and the tty process at the top for ease of recognition") + + (SETQ PROCNAMES (CONS TTYNAME (for PROC in \PROCESSES + unless [OR (EQ (SETQ NAME (fetch PROCNAME + of PROC)) + TTYNAME) + (EQ NAME ME) + (AND (fetch PROCSYSTEMP of PROC) + (NEQ NAME 'MOUSE] collect NAME))) + (if (NEQ ME TTYNAME) + then (push PROCNAMES ME)) + (NCONC PROCNAMES (for PROC in \PROCESSES collect (fetch PROCNAME + of PROC) + unless (FMEMB (fetch PROCNAME of PROC) + PROCNAMES))) + [PROGN (* ; "Tag the running and tty procs") + (RPLACA PROCNAMES (LIST (CONCAT ME " *run") + (LIST 'QUOTE ME))) + (if (NEQ ME TTYNAME) + then (RPLACA (CDR PROCNAMES) + (LIST (CONCAT TTYNAME " *tty") + (LIST 'QUOTE TTYNAME] + (LET ((MOUSEITEM "[Spawn Mouse]")) + (if [NOT (SETQ NAME (MENU (create MENU + ITEMS _ (CONS MOUSEITEM PROCNAMES) + TITLE _ TITLE + CENTERFLG _ T + MENUFONT _ INTERRUPTMENUFONT] + then NIL + elseif (EQ NAME MOUSEITEM) + then (SPAWN.MOUSE) + NIL + else (FIND.PROCESS NAME]) (\PROCESS.MAKEFRAME + [LAMBDA (PROC FN ARGS FLG) (* bvm%: " 5-Feb-85 13:09") + +(* ;;; "Builds a frame to call FN with ARGS on top of PROC. Returns NIL if it can't right now. FN must have no pvars or fvars") + + (UNINTERRUPTABLY + (PROG ((FRAME (fetch PROCFX of PROC)) + (FN&ARGS (CONS FN ARGS)) + NEWFRAME) + [COND + ((ILESSP FRAME (fetch (IFPAGE StackBase) of \InterfacePage)) + (* ; "This is the test used in \CAUSEINTERRUPT, but actually, we could afford to test \INTERRUPTABLE here") + (RETURN (COND + ((EQ FRAME 0) + (\MP.ERROR \MP.PROCERROR + "PROC confused: trying to call a fn in a nonexistent process" FN + )) + (T (\MP.ERROR \MP.PROCERROR + "PROC confused: a process other than the running one is in uninterruptable region" + FRAME] + [COND + ((SETQ NEWFRAME (\MISCAPPLY* (FUNCTION \PROCESS.MAKEFRAME0) + FRAME FN&ARGS)) + + (* ;; "Note that FN&ARGS was consed up before entering \MISCAPPLY* in case the CONS causes a NEWPAGE, which uses the misc context also") + + ) + (T (* ; + "Should never happen -- error occurs inside \PROCESS.MAKEFRAME0 first") + (RETURN (COND + (FLG (\MP.ERROR \MP.PROCERROR "Can't build frame for process call" FN] + (COND + ((NEQ (fetch PROCSTATUS of PROC) + \PSTAT.RUNNING) + (\RUN.PROCESS PROC))) + (replace PROCFX of PROC with NEWFRAME) + (RETURN T)))]) (\PROCESS.MAKEFRAME0 + [LAMBDA (FRAME FN&ARGS) (* bvm%: " 6-Oct-86 14:22") + (PROG ((ARGS (CDR FN&ARGS)) + (FN (CAR FN&ARGS)) + FREE NXT NXTEND) + (SETQ NXT (fetch (FX NEXTBLOCK) of FRAME)) + (CHECK (fetch (FX CHECKED) of FRAME) + (type? FSB NXT)) + (SETQ NXTEND (IPLUS NXT (fetch (FSB SIZE) of NXT))) + [while (type? FSB NXTEND) do (SETQ NXTEND (IPLUS NXTEND (fetch (FSB SIZE) + of NXTEND] + (RETURN (OR (\MAKEFRAME FN NXT NXTEND FRAME FRAME ARGS) + (\MAKEFRAME FN (SETQ FREE (\FREESTACKBLOCK + (IPLUS (PROG1 (fetch (FNHEADER STKMIN) + of (fetch (LITATOM + DEFPOINTER + ) + of FN)) + (* ; "Stack needed to call this fn") + ) + (PROG1 (UNFOLD 20 WORDSPERCELL) + (* ; "Extra slop") + )) + FRAME)) + (IPLUS FREE (fetch (FSB SIZE) of FREE)) + FRAME FRAME ARGS) + (\MP.ERROR \MP.PROCNOFRAME "Failed to build frame for PROCESS use" FN]) ) (RPAQ? %#MYHANDLE# ) (RPAQ? %#SCHEDULER# ) (RPAQ? \RUNNING.PROCESS ) (RPAQ? \PROCESSES ) (RPAQ? PROCESS.MAXMOUSE 5) (RPAQ? PROC.FREESPACESIZE 1024) (RPAQ? AUTOPROCESSFLG T) (RPAQ? BACKGROUNDFNS ) (RPAQ? \TIMERQHEAD ) (RPAQ? \HIGHEST.PRIORITY.QUEUE ) (RPAQ? PROC.DEFAULT.PRIORITY 2) (RPAQ? \DEFAULTLINEBUF ) (RPAQ? \DEFAULTTTYDISPLAYSTREAM ) (RPAQ? \PROCTIMER.SCRATCH (NCREATE 'FIXP)) (RPAQ? TOPW ) (RPAQ? \PROC.RUN.NEXT.FLG ) (RPAQ? \PROC.READY T) (ADDTOVAR \SYSTEMCACHEVARS \PROC.READY) (ADDTOVAR \SYSTEMTIMERVARS (\LASTUSERACTION SECONDS)) (RPAQ \PROC.RESTARTME "{restart flag}") (RPAQ \PROC.RESETME "{reset flag}") (RPAQ \PROC.KILLME "{abort flag}") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (PUTPROPS THIS.PROCESS MACRO (NIL \RUNNING.PROCESS)) (PUTPROPS TTY.PROCESS MACRO [X (COND ((CAR X) 'IGNOREMACRO) (T '\TTY.PROCESS]) (PUTPROPS TTY.PROCESSP MACRO [X (COND ((CAR X) 'IGNOREMACRO) (T '(OR (NULL (THIS.PROCESS)) (EQ (THIS.PROCESS) (TTY.PROCESS]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \RUNNING.PROCESS \TTY.PROCESS \PROC.RESTARTME \PROC.RESETME \PROC.ABORTME) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PROCESSES PROC.FREESPACESIZE %#SCHEDULER# PROCESS.MAXMOUSE AUTOPROCESSFLG BACKGROUNDFNS \TopLevelTtyWindow \PROC.READY) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TIMERQHEAD \PROCTIMER.SCRATCH \HIGHEST.PRIORITY.QUEUE PROC.DEFAULT.PRIORITY \PROC.RUN.NEXT.FLG \SYSTEMTIMERVARS) ) (DECLARE%: EVAL@COMPILE (PUTPROPS ALIVEPROCP MACRO ((p) (NOT (DEADPROCP p)))) (PUTPROPS DEADPROCP MACRO ((p) (fetch PROCDELETED of p))) (PUTPROPS \COERCE.TO.PROCESS MACRO [OPENLAMBDA (P ERRORFLG) (COND ((AND (type? PROCESS P) (NOT (fetch PROCDELETED of P))) P) (T (FIND.PROCESS P ERRORFLG]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (* ; "Debugging") (DEFINEQ (\CHECK.PQUEUE + [LAMBDA (P THISP) (* bvm%: "21-Jun-84 11:41") + [COND + ((type? PROCESS P) + (SETQ P (fetch PROCQUEUE of P] + (OR (PROG ((PREV (fetch PQLAST of P)) + (NEXT (fetch PQNEXT of P)) + X) + [COND + ((NULL PREV) + (RETURN (COND + ((NULL NEXT) + T) + (T (printout T P " has a LAST = " PREV " but no NEXT" T) + NIL] + (COND + ((NEQ (fetch NEXTPROCHANDLE of PREV) + NEXT) + (printout T "Last=" PREV " points at " (fetch NEXTPROCHANDLE of PREV) + " but NEXT=" NEXT T) + (RETURN))) + (COND + ((AND THISP (NEQ NEXT (THIS.PROCESS))) + (printout T "NEXT=" NEXT " but running process = " (THIS.PROCESS) + T) + (RETURN))) + (SETQ X (fetch NEXTPROCHANDLE of NEXT)) + (SETQ PREV NEXT) + LP (COND + ((NULL X) + (printout T "Successor of " PREV " is NIL" T) + (RETURN))) + (COND + ((EQ X NEXT) (* ; "The end") + (COND + ((NEQ PREV (fetch PQLAST of P)) + (printout T "Predecessor of NEXT = " NEXT " is " PREV " which is not LAST" T) + (RETURN))) + (RETURN T))) + (SETQ X (fetch NEXTPROCHANDLE of (SETQ PREV X))) + (GO LP)) + (RESETVARS ((\RUNNING.PROCESS)) (* ; "Inhibit process switch") + (RETURN (HELP]) ) (DEFINEQ (PPROC + [LAMBDA (PROC FILE) (* bvm%: "10-MAY-83 22:59") + (* ; "show a process, or many") + (COND + (PROC (PPROC1 PROC FILE)) + (T (PROG ((NOW (CLOCK 0)) + (PQ \HIGHEST.PRIORITY.QUEUE) + DONE P1) + (printout FILE " name" .FR 21 "prty" " state (run reason)" T) + LP [COND + ((SETQ P1 (fetch PQNEXT of PQ)) + (for (P _ P1) do (PPROC1 P FILE NOW) + (push DONE P) + repeatuntil (EQ (SETQ P (fetch NEXTPROCHANDLE of P)) + P1] + (COND + ((SETQ PQ (fetch PQLOWER of PQ)) + (GO LP))) + (printout FILE " - - -" T 22 "TimeLeft WakeCondition" T) + (for (P _ \TIMERQHEAD) while (SETQ P (fetch PROCTIMERLINK of P)) + do (PPROC1 P FILE NOW) + (push DONE P)) + (for P in \PROCESSES unless (FMEMB P DONE) + do (PPROC1 P FILE NOW]) (PPROCWINDOW + [LAMBDA (W) (* bvm%: " 6-MAY-83 13:05") + (OR W (SETQ W (CREATEW NIL "Detailed process status"))) + (WINDOWPROP W 'BUTTONEVENTFN (FUNCTION PPROCREPAINTFN)) + (WINDOWPROP W 'REPAINTFN (FUNCTION PPROCREPAINTFN)) + (WINDOWPROP W 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) + (WINDOWPROP W 'RESHAPEFN (FUNCTION PPROCRESHAPEFN)) + (WINDOWPROP W 'PPROCHEIGHT (WINDOWPROP W 'HEIGHT)) + (DSPRIGHTMARGIN 32000 W) + W]) (PPROCREPAINTFN + [LAMBDA (WINDOW REGION) (* bvm%: " 4-MAY-83 12:06") + [COND + (REGION (* ; "As repaintfn") + (MOVETO 0 (WINDOWPROP WINDOW 'PPROCSTART) + WINDOW) + (DSPFILL NIL 0 NIL WINDOW) + (PPROC NIL WINDOW)) + (T (* ; "As buttoneventfn") + (COND + ((LASTMOUSESTATE (NOT UP)) + (CLEARW WINDOW) + (WINDOWPROP WINDOW 'PPROCSTART (DSPYPOSITION NIL WINDOW)) + (PPROC NIL WINDOW] + (WINDOWPROP WINDOW 'EXTENT (PPROCEXTENT WINDOW]) (PPROCRESHAPEFN + [LAMBDA (WINDOW OLDCONTENTS REGION) (* bvm%: "22-JUN-83 10:24") + (WINDOWPROP WINDOW 'PPROCHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) + (DSPRIGHTMARGIN 32000 WINDOW) + (RESHAPEBYREPAINTFN WINDOW OLDCONTENTS REGION]) (PPROCEXTENT + [LAMBDA (WINDOW) (* bvm%: "10-MAY-83 22:59") + (PROG [(H (ITIMES (IPLUS 3 (LENGTH \PROCESSES)) + (IMINUS (DSPLINEFEED NIL WINDOW] + (RETURN (create REGION + LEFT _ 0 + BOTTOM _ (IDIFFERENCE (WINDOWPROP WINDOW 'PPROCHEIGHT) + H) + WIDTH _ -1 + HEIGHT _ H]) (PPROC1 + [LAMBDA (PROC FILE NOW) (* bvm%: "10-MAY-83 22:58") + (PROG (EVLOCK TIMELEFT NAME) + (PRIN1 (COND + ((DEADPROCP PROC) + '*) + ((EQ PROC (TTY.PROCESS)) + '%#) + (T " ")) + FILE) + (PRIN1 (COND + ((fetch PROCSYSTEMP of PROC) + '+) + (T " ")) + FILE) + (printout FILE (fetch PROCNAME of PROC) + 20 + (fetch PROCPRIORITY of PROC) + %,) + [COND + ((EQ PROC (THIS.PROCESS)) + (printout FILE "running ")) + ((EQ (fetch PROCSTATUS of PROC) + \PSTAT.RUNNING) + (printout FILE "runnable (" (fetch WAKEREASON of PROC) + ")")) + (T (COND + ((NOT (fetch PROCTIMERSET of PROC)) + (PRIN1 "(forever)" FILE)) + ((IGEQ [SETQ TIMELEFT (IDIFFERENCE (fetch PROCWAKEUPTIMER of PROC) + (OR NOW (SETQ NOW (CLOCK 0] + 0) + (printout FILE .I8 TIMELEFT)) + (T (PRIN1 "(expired)" FILE))) + (TAB 32 T FILE) + (COND + ((SETQ EVLOCK (fetch PROCEVENTORLOCK of PROC)) + (printout FILE (COND + ((type? MONITORLOCK EVLOCK) + (SETQ NAME (fetch MLOCKNAME of EVLOCK)) + "lock ") + (T (SETQ NAME (fetch EVENTNAME of EVLOCK)) + "event ")) + (OR NAME "unnamed"))) + (T (printout FILE "blocked"] + (TERPRI FILE]) (PROCESS.STATUS.WINDOW + [LAMBDA (WHERE) (* ; "Edited 12-Oct-87 18:13 by bvm:") + (PROG ((PROCS (for P in \PROCESSES collect (fetch PROCNAME of P))) + PMENU HEIGHT WIDTH LEFT BOTTOM REG) + (SETQ PMENU (create MENU + ITEMS _ PROCS + WHENSELECTEDFN _ (FUNCTION \PSW.SELECTED) + MENUFONT _ (FONTCREATE 'GACHA 10) + CENTERFLG _ T)) + (OR PROCOPMENU + (SETQ PROCOPMENU + (create MENU + ITEMS _ '(BT WHO? KILL BTV KBD_ RESTART BTV* INFO WAKE BTV! BREAK SUSPEND) + WHENSELECTEDFN _ (FUNCTION \PSWOP.SELECTED) + CENTERFLG _ T + MENUCOLUMNS _ 3))) + (SETQ HEIGHT (HEIGHTIFWINDOW (+ (fetch IMAGEHEIGHT of PMENU) + (fetch IMAGEHEIGHT of PROCOPMENU) + 4))) + [SETQ WIDTH (WIDTHIFWINDOW (MAX (fetch IMAGEWIDTH of PMENU) + (fetch IMAGEWIDTH of PROCOPMENU] + [COND + [(AND (WINDOWP PROCESS.STATUS.WINDOW) + (EQ WHERE T)) + (SETQ REG (WINDOWPROP PROCESS.STATUS.WINDOW 'REGION)) + (SETQ LEFT (fetch LEFT of REG)) + (COND + ((> (+ (SETQ BOTTOM (fetch BOTTOM of REG)) + HEIGHT) + SCREENHEIGHT) + (SETQ BOTTOM (- SCREENHEIGHT HEIGHT] + (T [SETQ WHERE (COND + ((POSITIONP WHERE)) + (T (GETBOXPOSITION WIDTH HEIGHT] + (SETQ LEFT (fetch XCOORD of WHERE)) + (SETQ BOTTOM (fetch YCOORD of WHERE] + (COND + ((WINDOWP PROCESS.STATUS.WINDOW) + (CLOSEW PROCESS.STATUS.WINDOW))) + (SETQ PROCESS.STATUS.WINDOW + (CREATEW (create REGION + LEFT _ LEFT + BOTTOM _ BOTTOM + WIDTH _ WIDTH + HEIGHT _ HEIGHT))) + (ADDMENU PROCOPMENU PROCESS.STATUS.WINDOW '(0 . 0)) + (ADDMENU (SETQ PROCMENU PMENU) + PROCESS.STATUS.WINDOW + (create POSITION + XCOORD _ (IQUOTIENT (- WIDTH (fetch IMAGEWIDTH of PMENU)) + 2) + YCOORD _ (+ (fetch IMAGEHEIGHT of PROCOPMENU) + 4))) (* ; + "Don't set PROCMENU globally until after old psw is closed") + [COND + (SELECTEDPROC (COND + ((FMEMB SELECTEDPROC PROCS) + (SHADEITEM SELECTEDPROC PMENU SELECTIONSHADE)) + (T (SETQ SELECTEDPROC] + (WINDOWPROP PROCESS.STATUS.WINDOW 'PROCS PROCS) + (WINDOWPROP PROCESS.STATUS.WINDOW 'MINSIZE (CONS 0 HEIGHT)) + (WINDOWPROP PROCESS.STATUS.WINDOW 'MAXSIZE (CONS MAX.SMALLP HEIGHT)) + (* ; + "Window is of fixed size for attached window reshaping") + (WINDOWPROP PROCESS.STATUS.WINDOW 'CLOSEFN (FUNCTION (LAMBDA (WINDOW) + (COND + ((EQ WINDOW PROCESS.STATUS.WINDOW + ) + (SETQ PROCMENU (SETQ + PROCESS.STATUS.WINDOW + ]) (\PSW.SELECTED + [LAMBDA (ITEM MENU BUTTON) (* bvm%: " 6-JUN-82 21:03") + (COND + ((AND SELECTEDPROC (NEQ ITEM SELECTEDPROC)) + (SHADEITEM SELECTEDPROC MENU WHITESHADE))) + (SHADEITEM ITEM MENU SELECTIONSHADE) + (SETQ SELECTEDPROC ITEM]) (\PSWOP.SELECTED + [LAMBDA (ITEM MENU BUTTON) (* ; "Edited 12-Oct-87 18:28 by bvm:") + (COND + ((NULL (THIS.PROCESS)) + (PROMPTPRINT "Processes are off!")) + [(EQ ITEM 'WHO?) + (COND + ((TTY.PROCESS) + (\PSW.SELECTED (fetch PROCNAME of (TTY.PROCESS)) + PROCMENU)) + (T (PROMPTPRINT "No process has the tty!!!"] + (SELECTEDPROC + (PROG ((P (FIND.PROCESS SELECTEDPROC)) + VALUE) + (OR P (RETURN (PROMPTPRINT "Can't find process " SELECTEDPROC))) + (SELECTQ ITEM + (KBD_ (TTY.PROCESS P)) + ((BT BTV BTV* BTV!) + (PROCESS.BACKTRACE P ITEM)) + (INFO [COND + ((NOT (SETQ VALUE (fetch PROCINFOHOOK of P))) + (PROMPTPRINT "No info program supplied for this process")) + ((AND (LISTP VALUE) + (NOT (FMEMB (CAR VALUE) + LAMBDASPLST))) + (PROCESS.EVAL P VALUE)) + (T (PROCESS.APPLY P VALUE (LIST P BUTTON]) + (KILL [COND + ((COND + ((OR (fetch PROCSYSTEMP of P) + (EQ (fetch PROCNAME of P) + 'EXEC)) + (MOUSECONFIRM "Click LEFT to confirm killing system process" T NIL + (WFROMMENU MENU))) + (T T)) + (DEL.PROCESS P) + (forDuration 500 until (fetch PROCDELETED of P) + do (BLOCK)) + (if (EQ (WINDOWPROP PROCESS.STATUS.WINDOW 'BUTTONEVENTFN) + '\UPDATE.PROCESS.WINDOW) + then (* ; + "Repaint the window after the kill") + (PROCESS.STATUS.WINDOW T) + (ERROR!) (* ; "Don't let the mouse handler think any longer about the old window, lest it bring it to top to handle the selection") + ]) + (RESTART (RESTART.PROCESS P)) + (WAKE (PROG (VALUE) + (WAKE.PROCESS + P + (SELECTQ [MENU (OR PROCOP.WAKEMENU + (SETQ PROCOP.WAKEMENU + (create MENU + ITEMS _ '((NIL 'NULL) + T Other) + TITLE _ "WakeUp Value" + CENTERFLG _ T] + (NIL (RETURN)) + (NULL NIL) + (T T) + (Other (CAR (OR (LISTP (PROCESS.READ + "Value to return to woken process: " + )) + (RETURN)))) + NIL)))) + (BREAK (BREAK.PROCESS P)) + (SUSPEND (AND (NEQ P (THIS.PROCESS)) + (\SUSPEND.PROCESS P))) + NIL]) (PROCESS.BACKTRACE + [LAMBDA (PROC CMD WINDOW) (* jds " 4-Feb-86 14:52") + (PROG (DSP PLACE REGION) + [COND + ([NOT (WINDOWP (OR WINDOW (SETQ WINDOW (CAR (ATTACHEDWINDOWS PROCESS.STATUS.WINDOW] + (SETQ REGION (WINDOWPROP PROCESS.STATUS.WINDOW 'REGION)) + (SETQ DSP (WINDOWPROP (SETQ WINDOW (CREATEW (create + REGION + LEFT _ (fetch (REGION LEFT) + of REGION) + BOTTOM _ + (COND + ((ILESSP (fetch (REGION BOTTOM) + of REGION) + PROCBACKTRACEHEIGHT) + (SETQ PLACE 'TOP) + (fetch (REGION TOP) of REGION) + ) + (T (SETQ PLACE 'BOTTOM) + (IDIFFERENCE (fetch (REGION + BOTTOM) + of REGION) + PROCBACKTRACEHEIGHT))) + WIDTH _ (fetch (REGION WIDTH) + of REGION) + HEIGHT _ PROCBACKTRACEHEIGHT) + "Process backtrace" NIL T)) + 'DSP)) + (ATTACHWINDOW WINDOW PROCESS.STATUS.WINDOW PLACE 'JUSTIFY 'LOCALCLOSE) + (DSPSCROLL 'OFF DSP) + (WINDOWPROP WINDOW 'PASSTOMAINCOMS '(MOVEW SHRINKW BURYW)) + (DSPFONT (OR BACKTRACEFONT (FONTCREATE 'GACHA 8)) + DSP)) + (T (SETQ DSP (WINDOWPROP WINDOW 'DSP] + (DSPRESET DSP) + (LET ((PLVLFILEFLG T) + (FX (fetch (PROCESS PROCFX) of PROC)) + STKP) + (BAKTRACE [COND + ((EQ FX 0) (* ; "The currently active proc!") + '\PSWOP.SELECTED) + (T (SETQ STKP (\MAKESTACKP NIL FX] + NIL NIL (SELECTQ CMD + (BT 0) + (BTV 1) + (BTV* 7) + (BTV! 39) + 0) + DSP) + (AND STKP (RELSTK STKP]) (\INVALIDATE.PROCESS.WINDOW + [LAMBDA NIL (* bvm%: "21-JUN-82 17:50") + + (* ;; "If process window is active and correct, grays it out and makes its buttoneventfn be something to update it") + + (PROG (OLDBUTTONFN) + (COND + ((AND PROCESS.STATUS.WINDOW (ACTIVEWP PROCESS.STATUS.WINDOW) + (NEQ (SETQ OLDBUTTONFN (WINDOWPROP PROCESS.STATUS.WINDOW 'BUTTONEVENTFN + '\UPDATE.PROCESS.WINDOW)) + '\UPDATE.PROCESS.WINDOW)) + (WINDOWPROP PROCESS.STATUS.WINDOW 'OLDBUTTONEVENTFN OLDBUTTONFN) + (DSPFILL NIL LIGHTGRAYSHADE 'INVERT PROCESS.STATUS.WINDOW]) (\UPDATE.PROCESS.WINDOW + [LAMBDA (WINDOW) (* bvm%: " 4-OCT-83 11:54") + (PROG (OLDBUTTONFN) (* ; "Restore proper button fn") + (COND + ((for P in \PROCESSES as NAME in (WINDOWPROP WINDOW 'PROCS) + thereis (NEQ NAME (fetch PROCNAME of P))) + (PROCESS.STATUS.WINDOW T)) + (T (DSPFILL NIL LIGHTGRAYSHADE 'INVERT PROCESS.STATUS.WINDOW) + (WINDOWPROP WINDOW 'BUTTONEVENTFN (SETQ OLDBUTTONFN (WINDOWPROP WINDOW + 'OLDBUTTONEVENTFN NIL))) + (* ; "Now invoke the real fn") + (APPLY* OLDBUTTONFN WINDOW]) ) (RPAQ? PROCMENU ) (RPAQ? PROCOPMENU ) (RPAQ? PROCOP.WAKEMENU ) (RPAQ? PROCESS.STATUS.WINDOW ) (RPAQ? SELECTEDPROC ) (RPAQ? PROCBACKTRACEHEIGHT 320) (ADDTOVAR BackgroundMenuCommands ("PSW" '(PROCESS.STATUS.WINDOW) "Puts up a Process Status Window")) (SETQQ BackgroundMenu) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PROCESS.STATUS.WINDOW PROCMENU PROCOPMENU PROCOP.WAKEMENU PROCBACKTRACEHEIGHT SELECTEDPROC BACKTRACEFONT) ) (DECLARE%: EVAL@COMPILE (RPAQQ LIGHTGRAYSHADE 1) (RPAQQ SELECTIONSHADE 520) (CONSTANTS LIGHTGRAYSHADE SELECTIONSHADE) ) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR WINDOWUSERFORMS (\PROC.AFTER.WINDOWWORLD)) (DEFPRINT 'PROCESS (FUNCTION \PROCESS.DEFPRINT)) (DEFPRINT 'EVENT (FUNCTION \EVENT.DEFPRINT)) (DEFPRINT 'MONITORLOCK (FUNCTION \MONITORLOCK.DEFPRINT)) (* ;  "\process.init must come last, since it does a HARDRESET") (\PROCESS.INIT) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA PROCESSPROP ADD.PROCESS) ) (PUTPROPS PROC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1990 1991 1992 1993 1998 1999)) (DECLARE%: DONTCOPY (FILEMAP (NIL (22392 42659 (PROCESSWORLD 22402 . 31747) (ADD.PROCESS 31749 . 35906) (DEL.PROCESS 35908 . 36855) (PROCESS.RETURN 36857 . 37004) (FIND.PROCESS 37006 . 37640) (MAP.PROCESSES 37642 . 37968) ( PROCESSP 37970 . 38138) (RELPROCESSP 38140 . 38322) (RESTART.PROCESS 38324 . 38893) (WAKE.PROCESS 38895 . 39625) (SUSPEND.PROCESS 39627 . 40014) (PROCESS.RESULT 40016 . 40994) (PROCESS-STATUS 40996 . 42391) (PROCESS.FINISHEDP 42393 . 42657)) (42660 55867 (THIS.PROCESS 42670 . 42803) (TTY.PROCESS 42805 . 49632) (TTY.PROCESSP 49634 . 49850) (PROCESS.TTY 49852 . 50202) (GIVE.TTY.PROCESS 50204 . 51014) ( ALLOW.BUTTON.EVENTS 51016 . 51260) (SPAWN.MOUSE 51262 . 53475) (\WAIT.FOR.TTY 53477 . 53667) ( WAIT.FOR.TTY 53669 . 55865)) (55868 58486 (RESET 55878 . 56710) (ERROR! 56712 . 58484)) (58851 64199 ( PROCESSPROP 58861 . 63313) (PROCESS.NAME 63315 . 63620) (PROCESS.WINDOW 63622 . 64197)) (64401 69436 ( DISMISS 64411 . 65226) (BLOCK 65228 . 67452) (WAITFORINPUT 67454 . 68683) (\WAITFORSYSBUFP 68685 . 69434)) (69637 70134 (EVAL.AS.PROCESS 69647 . 69870) (EVAL.IN.TTY.PROCESS 69872 . 70132)) (70768 76552 (PROCESS.READ 70778 . 71616) (PROCESS.EVALV 71618 . 72196) (PROCESS.EVAL 72198 . 73175) ( \PROCESS.EVAL1 73177 . 74280) (PROCESS.APPLY 74282 . 75266) (\PROCESS.APPLY1 75268 . 76550)) (78718 84023 (CREATE.EVENT 78728 . 78890) (NOTIFY.EVENT 78892 . 80400) (AWAIT.EVENT 80402 . 81024) ( \UNQUEUE.EVENT 81026 . 82501) (\ENQUEUE.EVENT/LOCK 82503 . 83796) (\EVENT.DEFPRINT 83798 . 84021)) ( 89263 94254 (OBTAIN.MONITORLOCK 89273 . 92137) (CREATE.MONITORLOCK 92139 . 92358) (RELEASE.MONITORLOCK 92360 . 92694) (SI::MONITOR-UNWIND 92696 . 93282) (MONITOR.AWAIT.EVENT 93284 . 94018) ( \MONITORLOCK.DEFPRINT 94020 . 94252)) (94863 117339 (\MAKE.PROCESS0 94873 . 102072) (\MAKE.PROCESS1 102074 . 103638) (\PROCESS.MOVEFRAME 103640 . 108189) (\RELEASE.PROCESS 108191 . 111241) ( \UNWIND.PROCESS 111243 . 111569) (\MAYBEBLOCK 111571 . 111726) (\BACKGROUND.PROCESS 111728 . 111969) ( \MOUSE.PROCESS 111971 . 114520) (\TIMER.PROCESS 114522 . 115078) (\PROCESS.RELEASE.LOCKS 115080 . 115494) (\SET.PROCESS.NAME 115496 . 117032) (\PROCESS.DEFPRINT 117034 . 117337)) (117340 131695 ( \START.PROCESSES 117350 . 117523) (\PROCESS.GO.TO.SLEEP 117525 . 121279) (\PROC.RESUME 121281 . 121655 ) (\RUN.PROCESS 121657 . 124993) (\SUSPEND.PROCESS 124995 . 128056) (\UNQUEUE.TIMER 128058 . 128757) ( \ENQUEUE.TIMER 128759 . 130666) (\GET.PRIORITY.QUEUE 130668 . 131693)) (134377 141599 (\PROCESS.INIT 134387 . 135013) (\PROCESS.EVENTFN 135015 . 136751) (\PROCESS.BEFORE.LOGOUT 136753 . 138272) ( \PROCESS.AFTER.EXIT 138274 . 138582) (\PROCESS.RESET.TIMERS 138584 . 140113) (\PROC.AFTER.WINDOWWORLD 140115 . 140800) (\TURN.ON.PROCESSES 140802 . 141597)) (141630 142859 (\PROC.CODEFORTFRAME 141640 . 142461) (\PROC.REPEATEDLYEVALQT 142463 . 142857)) (142893 149625 (BREAK.PROCESS 142903 . 143219) ( \SELECTPROCESS 143221 . 145661) (\PROCESS.MAKEFRAME 145663 . 147714) (\PROCESS.MAKEFRAME0 147716 . 149623)) (151838 153761 (\CHECK.PQUEUE 151848 . 153759)) (153762 172091 (PPROC 153772 . 155053) ( PPROCWINDOW 155055 . 155546) (PPROCREPAINTFN 155548 . 156262) (PPROCRESHAPEFN 156264 . 156527) ( PPROCEXTENT 156529 . 157013) (PPROC1 157015 . 159033) (PROCESS.STATUS.WINDOW 159035 . 163117) ( \PSW.SELECTED 163119 . 163413) (\PSWOP.SELECTED 163415 . 167315) (PROCESS.BACKTRACE 167317 . 170508) ( \INVALIDATE.PROCESS.WINDOW 170510 . 171244) (\UPDATE.PROCESS.WINDOW 171246 . 172089))))) STOP \ No newline at end of file diff --git a/sources/PROFILE b/sources/PROFILE new file mode 100644 index 00000000..29dd6b8c --- /dev/null +++ b/sources/PROFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "16-May-90 21:15:43" IL:|{DSK}local>lde>lispcore>sources>PROFILE.;2| 17478 IL:|changes| IL:|to:| (IL:VARS IL:PROFILECOMS) IL:|previous| IL:|date:| "27-Feb-87 14:34:18" IL:|{DSK}local>lde>lispcore>sources>PROFILE.;1| ) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:PROFILECOMS) (IL:RPAQQ IL:PROFILECOMS ( (IL:* IL:|;;| "The profile type") (IL:DEFINE-TYPES PROFILES) (IL:FUNCTIONS DEFPROFILE) (IL:TYPES PROFILE) (IL:STRUCTURES PROFILE-CLAUSE VARIABLE-DEFINITION) (IL:VARIABLES *PROFILE* *PROFILE-NAME* *PROFILE-VARIABLES* *PROFILES*) (IL:FUNCTIONS FIND-VARIABLE-DEFINITION IN-PROFILE INSTALL-PROFILE MAKE-VARIABLE-DEFINITION PROFILIZE PROFILE-ENTRY-VALUE PROFILE-ENTRY-VALUE-NAME PROFILE-NAME PROFILE-P PROFILE-VALUE-TYPE-CHECK SETF-PROFILE-ENTRY-VALUE SETF-PROFILE-ENTRY-VALUE-NAME SETF-PROFILE-NAME MAKE-PROFILE COPY-PROFILE RESTORE-PROFILE SAVE-PROFILE WITH-PROFILE FIND-PROFILE SETF-FIND-PROFILE LIST-ALL-PROFILES PROFILE-VALUES PROFILE-VARIABLES) (IL:SETFS FIND-PROFILE PROFILE-ENTRY-VALUE PROFILE-ENTRY-VALUE-NAME PROFILE-NAME) (PROFILES "READ-PRINT" "LISP" "INTERLISP" "OLD-INTERLISP-T" "XEROX-COMMON-LISP") (IL:DECLARE\: IL:DONTCOPY IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:PROFILE))) (IL:* IL:|;;| "The profile type") (DEF-DEFINE-TYPE PROFILES "interaction profiles") (DEFDEFINER (DEFPROFILE (:NAME (LAMBDA (WHOLE) (LET ((NAME-CLAUSE (SECOND WHOLE))) (IF (CONSP NAME-CLAUSE) (STRING (CAR NAME-CLAUSE)) (STRING NAME-CLAUSE)))))) PROFILES (NAME-CLAUSE &REST VARIABLE-CLAUSES ) "Creates a new named profile. name . clauses or (name (:nicknames n1 n2...)) clauses" (LET ((NAME (IF (CONSP NAME-CLAUSE) (STRING (CAR NAME-CLAUSE)) (STRING NAME-CLAUSE))) (NICKNAMES (AND (CONSP NAME-CLAUSE) (MAPCAR #'STRING (CDADR NAME-CLAUSE))))) `(LET ((PROFILE (MAKE-PROFILE ,NAME ,@(MAPCAR #'(LAMBDA (CLAUSE) `',CLAUSE) VARIABLE-CLAUSES)))) (INSTALL-PROFILE PROFILE ,NAME ',NICKNAMES)))) (DEFTYPE PROFILE () `(SATISFIES PROFILE-P)) (DEFSTRUCT (PROFILE-CLAUSE (:TYPE LIST) (:CONSTRUCTOR NIL)) VARIABLE NAME TYPE COERCION-FUNCTION NAME-FUNCTION) (DEFSTRUCT (VARIABLE-DEFINITION (:TYPE LIST) (:CONSTRUCTOR NIL)) VARIABLE TYPE COERCION-FUNCTION NAME-FUNCTION) (DEFPARAMETER *PROFILE* "XCL" "The default or current profile.") (DEFPARAMETER *PROFILE-NAME* NIL) (DEFPARAMETER *PROFILE-VARIABLES* '((*PROFILE-NAME* T IDENTITY IDENTITY) (*EVAL-FUNCTION* (MEMBER IL:EVAL EVAL) IDENTITY IDENTITY) (*EXEC-PROMPT* STRING STRING IDENTITY) (*DEBUGGER-PROMPT* STRING STRING IDENTITY) (*READTABLE* READTABLE IL:FIND-READTABLE IL:READTABLE-NAME) (*READ-BASE* (INTEGER 2 36) IDENTITY IDENTITY) (*READ-SUPPRESS* (MEMBER NIL T) IDENTITY IDENTITY) (*PACKAGE* PACKAGE FIND-PACKAGE PACKAGE-NAME) (*READ-DEFAULT-FLOAT-FORMAT* (MEMBER SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SHORT-FLOAT) IDENTITY IDENTITY) (*PRINT-ESCAPE* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-PRETTY* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-CIRCLE* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-BASE* (INTEGER 2 36) IDENTITY IDENTITY) (*PRINT-RADIX* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-CASE* (MEMBER :DOWNCASE :UPCASE :CAPITALIZE) IDENTITY IDENTITY) (*PRINT-GENSYM* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-LEVEL* (OR NULL FIXNUM) IDENTITY IDENTITY) (*PRINT-LENGTH* (OR NULL FIXNUM) IDENTITY IDENTITY) (*PRINT-ARRAY* (MEMBER NIL T) IDENTITY IDENTITY) (*PRINT-STRUCTURE* (MEMBER NIL T) IDENTITY IDENTITY))) (DEFGLOBALVAR *PROFILES* (MAKE-HASH-TABLE :TEST 'EQUAL) "Where profiles live.") (DEFUN FIND-VARIABLE-DEFINITION (VARIABLE) (DOLIST (ENTRY *PROFILE-VARIABLES* NIL) (IF (EQ VARIABLE (VARIABLE-DEFINITION-VARIABLE ENTRY)) (RETURN ENTRY)))) (DEFUN IN-PROFILE (PROFILE) "Makes profile the current profile and resets *profile*" (SETQ *PROFILE* (PROFILIZE PROFILE)) (RESTORE-PROFILE *PROFILE*)) (DEFUN INSTALL-PROFILE (PROFILE PROFILE-NAME PROFILE-NICKNAMES) (DOLIST (NAME (CONS PROFILE-NAME PROFILE-NICKNAMES)) (IL:* IL:\;  "Make the name and all nicknames point at the new profile.") (IF (AND (FIND-PROFILE NAME) (FBOUNDP 'WARN)) (WARN "Resetting profile ~s." NAME)) (SETF (FIND-PROFILE NAME) PROFILE))) (DEFUN MAKE-VARIABLE-DEFINITION (CLAUSE &AUX (DEFINITION NIL)) "Add a new profile variable entry based on clauses. clauses is bounded by a keyword or nil." (DOLIST (DEFAULT '(NIL (IL:* IL:\; "variable") IGNORE (IL:* IL:\; "value") T (IL:* IL:\; "type") IDENTITY (IL:* IL:\; "coercion-function") IDENTITY (IL:* IL:\; "name-function") ) (IL:* IL:\;  "Defaults for a definition's slots.") ) (IL:* IL:\;  "Maps on defaults to always fill all the slots.") (IF (EQ DEFAULT 'IGNORE) (POP CLAUSE) (IL:* IL:\; "Ignore the value slot") (PUSH (IL:* IL:\; "Push onto the new entry") (IF (NULL CLAUSE) (IL:* IL:\;  "If we're at the end of the clause:") DEFAULT (IL:* IL:\; "...use the default.") (POP CLAUSE) (IL:* IL:\;  "...otherwise use the next element of the clause.") ) DEFINITION))) (SETQ DEFINITION (NREVERSE DEFINITION)) (PUSH DEFINITION (IL:* IL:\;  "Flip the push built list.") *PROFILE-VARIABLES*) (IL:* IL:\;  "Put the new definition onto the global list of definitions.") DEFINITION) (DEFUN PROFILIZE (NAME-OR-PROFILE) (ETYPECASE NAME-OR-PROFILE ((OR STRING SYMBOL) (OR (FIND-PROFILE NAME-OR-PROFILE) (ERROR "Not the name of an existing profile ~s" NAME-OR-PROFILE))) (PROFILE NAME-OR-PROFILE))) (DEFUN PROFILE-ENTRY-VALUE (VARIABLE &OPTIONAL (PROFILE *PROFILE*)) "Returns the value of the variable in the current profile or its binding." (GETF (PROFILIZE PROFILE) VARIABLE (EVAL VARIABLE))) (DEFUN PROFILE-ENTRY-VALUE-NAME (VARIABLE &OPTIONAL (PROFILE *PROFILE*)) "Get the name of the value in a variable or the name of the current binding." (FUNCALL (VARIABLE-DEFINITION-NAME-FUNCTION (FIND-VARIABLE-DEFINITION VARIABLE)) (GETF (PROFILIZE PROFILE) VARIABLE (EVAL VARIABLE)))) (DEFUN PROFILE-NAME (&OPTIONAL (PROFILE *PROFILE*)) "Returns the name of the profile as a string." (PROFILE-ENTRY-VALUE '*PROFILE-NAME* (PROFILIZE PROFILE))) (DEFUN PROFILE-P (OBJECT) "Returns true if the object seems to be a profile. Is true only of profiles, never their names." (AND (CONSP OBJECT) (SYMBOLP (FIRST OBJECT)) (EVENP (LENGTH OBJECT)) T)) (DEFUN PROFILE-VALUE-TYPE-CHECK (DEFINITION VALUE) "Returns correct or corrected value." (LET ((COERCION-FUNCTION (VARIABLE-DEFINITION-COERCION-FUNCTION DEFINITION)) (TYPE (VARIABLE-DEFINITION-TYPE DEFINITION))) (LOOP (IF (TYPEP VALUE TYPE) (IL:* IL:\; "Is it of the right type?") (RETURN VALUE) (IL:* IL:\; "...just return it") ) (COND (COERCION-FUNCTION (SETQ VALUE (FUNCALL COERCION-FUNCTION VALUE)) (IL:* IL:\;  "Perhaps it was a name, coerce it.") (IF (TYPEP VALUE TYPE) (IL:* IL:\;  "Is it NOW of the right type?") (RETURN VALUE) (IL:* IL:\; "...just return it") ))) (IL:* IL:|;;|  "Otherwise we were given something that can't either use or coerce; complain, fix and retry") (CERROR "Give new value" "Profile slot ~s's value ~s not a(n) ~s" ( VARIABLE-DEFINITION-VARIABLE DEFINITION) VALUE TYPE) (FORMAT *QUERY-IO* "Give new value expression (will be evaluated)~%") (SETQ VALUE (EVAL (READ)))))) (DEFUN SETF-PROFILE-ENTRY-VALUE (VARIABLE PROFILE VALUE) (SETQ PROFILE (PROFILIZE PROFILE)) (LET ((TYPE (VARIABLE-DEFINITION-TYPE (FIND-VARIABLE-DEFINITION VARIABLE)))) (ASSERT (TYPEP VALUE TYPE) (VALUE) "Profile slot ~s's value ~s not a(n) ~s" VARIABLE VALUE TYPE) (SETF (GETF PROFILE VARIABLE) VALUE))) (DEFUN SETF-PROFILE-ENTRY-VALUE-NAME (VARIABLE PROFILE NAME) (SETQ PROFILE (PROFILIZE PROFILE)) (SETF (PROFILE-ENTRY-VALUE VARIABLE PROFILE) (FUNCALL (VARIABLE-DEFINITION-COERCION-FUNCTION (FIND-VARIABLE-DEFINITION VARIABLE)) NAME))) (DEFUN SETF-PROFILE-NAME (PROFILE NAME) (SETF (PROFILE-ENTRY-VALUE '*PROFILE-NAME* PROFILE) (STRING NAME))) (DEFUN MAKE-PROFILE (PROFILE-NAME &REST CLAUSES) "Creates a profile with slots described by the clauses. Clauses is an alist of variables and values, similar to defstruct's." (LET ((PROFILE NIL)) (DOLIST (CLAUSE CLAUSES) (LET* ((VARIABLE (PROFILE-CLAUSE-VARIABLE CLAUSE)) (NAME (PROFILE-CLAUSE-NAME CLAUSE)) (IL:* IL:\;  "Name of the value to be used (or the value itself).") (DEFINITION (OR (FIND-VARIABLE-DEFINITION VARIABLE) (MAKE-VARIABLE-DEFINITION CLAUSE)))) (IL:* IL:|;;| "These are pushed on in reverse order so the final prop list format of the profile will be correct.") (PUSH (PROFILE-VALUE-TYPE-CHECK DEFINITION (EVAL NAME)) PROFILE) (PUSH VARIABLE PROFILE))) (CONS '*PROFILE-NAME* (CONS PROFILE-NAME PROFILE)))) (DEFUN COPY-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Copies the given profile." (COPY-SEQ (PROFILIZE PROFILE))) (DEFUN RESTORE-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Set profile variables from given profile." (SETQ PROFILE (PROFILIZE PROFILE)) (MAPC #'SET (PROFILE-VARIABLES PROFILE) (PROFILE-VALUES PROFILE)) PROFILE) (DEFUN SAVE-PROFILE (&OPTIONAL (PROFILE *PROFILE*)) "Save current values of bindings into profile." (IL:FOR X IL:ON (PROFILIZE PROFILE) IL:BY CDDR IL:DO (SETF (CADR X) (EVAL (CAR X)))) PROFILE) (DEFMACRO WITH-PROFILE (PROFILE-FORM &BODY FORMS) "Bind all the special IO variables to the values in the profile and execute the body forms." `(LET ((*PROFILE* ,PROFILE-FORM)) (SETQ *PROFILE* (PROFILIZE *PROFILE*)) (PROGV (PROFILE-VARIABLES *PROFILE*) (PROFILE-VALUES *PROFILE*) ,@FORMS))) (DEFUN FIND-PROFILE (NAME) (GETHASH (STRING NAME) *PROFILES*)) (DEFUN SETF-FIND-PROFILE (NAME PROFILE) (SETQ NAME (STRING NAME)) (SETQ PROFILE (PROFILIZE PROFILE)) (SETF (GETHASH NAME *PROFILES*) PROFILE) (SETF (PROFILE-NAME PROFILE) NAME) NAME) (DEFUN LIST-ALL-PROFILES () (LET ((PROFILES NIL)) (MAPHASH #'(LAMBDA (NAME VALUE) (PUSHNEW VALUE PROFILES :TEST #'EQ)(IL:* IL:\;  "Avoid repeats due to nicknames") ) *PROFILES*) (MAPCAR #'(LAMBDA (PROFILE) (PROFILE-NAME PROFILE) (IL:* IL:\; "Convert to name strings") ) PROFILES))) (DEFUN PROFILE-VALUES (PROFILE) (IL:FOR X IL:IN (CDR (PROFILIZE PROFILE)) IL:BY CDDR IL:COLLECT X)) (DEFUN PROFILE-VARIABLES (&OPTIONAL (PROFILE *PROFILE*)) (IL:FOR X IL:IN (PROFILIZE PROFILE) IL:BY CDDR IL:COLLECT X)) (DEFSETF FIND-PROFILE SETF-FIND-PROFILE) (DEFSETF PROFILE-ENTRY-VALUE SETF-PROFILE-ENTRY-VALUE) (DEFSETF PROFILE-ENTRY-VALUE-NAME SETF-PROFILE-ENTRY-VALUE-NAME) (DEFSETF PROFILE-NAME SETF-PROFILE-NAME) (DEFPROFILE "READ-PRINT" (*READTABLE* "LISP") (*READ-BASE* 10) (*READ-SUPPRESS* NIL) (*PACKAGE* "USER") (*READ-DEFAULT-FLOAT-FORMAT* 'SINGLE-FLOAT) (*PRINT-ESCAPE* T) (*PRINT-PRETTY* NIL) (*PRINT-CIRCLE* NIL) (*PRINT-BASE* 10) (*PRINT-RADIX* NIL) (*PRINT-CASE* :UPCASE) (*PRINT-GENSYM* T) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-ARRAY* NIL) (*PRINT-STRUCTURE* NIL)) (DEFPROFILE ("LISP" (:NICKNAMES "CL")) (*READTABLE* "LISP") (*PACKAGE* "USER") (*EVAL-FUNCTION* 'EVAL) (*EXEC-PROMPT* "> ") (*DEBUGGER-PROMPT* ": ")) (DEFPROFILE ("INTERLISP" (:NICKNAMES "IL")) (*READTABLE* "INTERLISP") (*PACKAGE* "INTERLISP") (*EVAL-FUNCTION* 'IL:EVAL) (*EXEC-PROMPT* "_ ") (*DEBUGGER-PROMPT* "_: ")) (DEFPROFILE "OLD-INTERLISP-T" (*READTABLE* "OLD-INTERLISP-T") (*PACKAGE* "INTERLISP") (*EVAL-FUNCTION* 'IL:EVAL) (*EXEC-PROMPT* "_ ") (*DEBUGGER-PROMPT* "_: ")) (DEFPROFILE ("XEROX-COMMON-LISP" (:NICKNAMES "XCL")) (*READTABLE* "XCL") (*PACKAGE* "XCL-USER") (*EVAL-FUNCTION* 'EVAL) (*EXEC-PROMPT* "> ") (*DEBUGGER-PROMPT* ": ")) (IL:DECLARE\: IL:DONTCOPY IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:PUTPROPS IL:PROFILE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS IL:PROFILE IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:PROFILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/PUP b/sources/PUP new file mode 100644 index 00000000..7ec67cb8 --- /dev/null +++ b/sources/PUP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8) (FILECREATED "19-Jan-93 11:14:09" {DSK}lde>lispcore>sources>PUP.;4 352070Q changes to%: (RECORDS PUP PUPADDRESS ERRORPUP PUPROUTINGINFO PUPSOCKET PORT TIMEPUPCONTENTS) previous date%: " 5-Jan-93 01:53:53" {DSK}lde>lispcore>sources>PUP.;3) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT PUPCOMS) (RPAQQ PUPCOMS ((COMS (* ; "Low level pup") (DECLARE%: DONTCOPY (EXPORT (RECORDS PUP PUPADDRESS) (MACROS \LOCALPUPADDRESS \LOCALPUPHOSTNUMBER \LOCALPUPNETNUMBER)) (GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#)) (FNS \STARTPUP ASSURE.PUP.READY \FIND.LOCALPUPHOSTNUMBER \PROMPT.FOR.PUP.NUMBER \HANDLE.RAW.PUP \FORWARD.PUP \SETPUPCHECKSUM) (INITVARS (\PUP.CHECKSUMFLG T) (\MAX.EPKTS.ON.PUPSOCKET 20Q) (\LOCALPUPNETHOST) (\OLDPUPHOST# 0))) (COMS (* ; "Pup error stuff") (DECLARE%: DONTCOPY (EXPORT (RECORDS ERRORPUP) (CONSTANTS * PUPERRORCODES)) (GLOBALVARS PUPERRORMESSAGES)) (VARS PUPERRORMESSAGES) (FNS \PUPERROR)) (COMS (* ; "Pup utilities") (FNS SETUPPUP SWAPPUPPORTS GETPUP SENDPUP EXCHANGEPUPS DISCARDPUPS GETPUPWORD \PUPINIT) (FNS ETHERHOSTNAME ETHERHOSTNUMBER ETHERPORT BESTPUPADDRESS NETDAYTIME0 \PUP.SETTIME \SETNEWTIME0 \NET.SETTIME NETDATE \LOOKUPPORT \PARSE.PORTCONSTANT \FIXLOCALNET) (FNS PORTSTRING OCTALSTRING) (INITVARS (\ETHERPORTS (HASHARRAY 24Q)) (\ETHERTIMEOUT 3720Q) (\MAXETHERTRIES 4) (\PUPCOUNTER 0)) (GLOBALVARS \ETHERPORTS \PUPCOUNTER)) (COMS (* ; "Accessing a PUP's contents") (FNS CLEARPUP PUTPUPWORD GETPUPBYTE PUTPUPBYTE GETPUPSTRING GETPUPSTREAM PUTPUPSTRING) (OPTIMIZERS GETPUPWORD PUTPUPWORD GETPUPBYTE PUTPUPBYTE)) (COMS (* ;  "Reading property lists from streams") (FNS READPLIST) (INITVARS \READPLIST.READTABLES) (GLOBALVARS \READPLIST.READTABLES)) (COMS (FNS CANONICAL.HOSTNAME \CANONICAL.HOSTNAME \CANONICALIZE.PUP.HOSTNAME) (P (* ;  "Default this for when IP not loaded") (MOVD? 'NILL '\CANONICALIZE.IP.HOSTNAME NIL T)) (ADDVARS (\HOSTNAMES) (\SYSTEMCACHEVARS \HOSTNAMES)) (GLOBALVARS \HOSTNAMES)) [COMS (* ; "PUP allocation") (EXPORT (MACROS BINDPUPS) (PROP INFO BINDPUPS) (ALISTS (PRETTYPRINTMACROS BINDPUPS] (COMS (* ; "Pup routing") (FNS \PUPGATELISTENER \HANDLE.PUP.ROUTING.INFO \ROUTE.PUP \LOCATE.PUPNET SORT.PUPHOSTS.BY.DISTANCE \PUPNET.CLOSERP PUPNET.DISTANCE) (INITVARS (\PUP.ROUTING.TABLE (CONS)) (\PUP.ROUTING.TABLE.RADIUS 2) (\PUPROUTER.PROBECOUNT 0) (\PUPROUTER.PROBETIMER) (\PUPROUTER.PROBEINTERVAL 5670Q) (\PUP.READY) (\PUP.READY.EVENT (CREATE.EVENT "Pup Ready")) (\PUP.READY.LOCK (CREATE.MONITORLOCK "Pup Ready"))) (ADDVARS (\SYSTEMCACHEVARS \PUP.READY)) (DECLARE%: DONTCOPY (RECORDS PUPROUTINGINFO) (CONSTANTS \PUP.ROUTINGINFO.WORDS) (GLOBALVARS \PUP.ROUTING.TABLE \PUP.ROUTING.TABLE.RADIUS \PUPROUTER.PROBECOUNT \PUPROUTER.PROBETIMER \PUPROUTER.PROBEINTERVAL \PUP.READY \PUP.READY.EVENT \PUP.READY.LOCK))) (COMS (* ; "Sockets") (DECLARE%: DONTCOPY (RECORDS PUPSOCKET) (MACROS \PUPSOCKET.FROM#) (GLOBALVARS \PUPSOCKETS.TABLE \MAX.EPKTS.ON.PUPSOCKET \PUP.CHECKSUMFLG)) (INITRECORDS PUPSOCKET) (SYSRECORDS PUPSOCKET) (FNS OPENPUPSOCKET CLOSEPUPSOCKET PUPSOCKETNUMBER PUPSOCKETFROMNUMBER PUPSOCKETEVENT \FLUSHPUPSOCQUEUE) (FNS \GETMISCSOCKET) (GLOBALVARS \MISC.SOCKET \PUPSOCKETS) (INITVARS (\MISC.SOCKET) (\PUPSOCKETS))) (DECLARE%: DONTCOPY (EXPORT (RECORDS PORT ERRORPUP) (GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS) (GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS) (CONSTANTS (\PUPOVLEN 26Q) (\MAX.PUPLENGTH 1024Q) (\TIME.GETPUP 5)) (PROP VARTYPE PUPPRINTMACROS) (MACROS \GETPUPWORD \PUTPUPWORD \GETPUPBYTE \PUTPUPBYTE) (CONSTANTS * RAWPUPTYPES) (INITVARS (PUPTYPES RAWPUPTYPES)) (CONSTANTS * WELLKNOWNPUPSOCKETS)) (CONSTANTS * PUPCONSTANTS) (MACROS PUPDEBUGGING) (ALISTS (PUPPRINTMACROS 210Q 214Q 211Q 213Q 201Q 30Q)) (RECORDS TIMEPUPCONTENTS)) (COMS (* ; "echo utilities") (FNS PUP.ECHOSERVER PUP.ECHOUSER)) (COMS (* ; "Peeking") (FNS \PEEKPUP \MAYBEPEEKPUP) (INITVARS (\PEEKPUPNUMBER)) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS \ETHERHOSTLOC) (GLOBALVARS \PEEKPUPNUMBER))) (COMS (* ; "Debugging assistance") (FNS PRINTPUP PRINTPUPROUTE PRINTPUPDATA PRINTERRORPUP PUPTRACE PRINTCONSTANT) (INITVARS (PUPTRACEFLG) (PUPTRACEFILE T) (PUPTRACETIME)) (GLOBALVARS PUPTRACETIME) (ADDVARS (PUPPRINTMACROS) (PUPONLYTYPES) (PUPIGNORETYPES)) (ALISTS (PUPPRINTMACROS 4 220Q 221Q 223Q 224Q))) (DECLARE%: DONTEVAL@LOAD (P (\PUPINIT))) (DECLARE%: EVAL@COMPILE DONTCOPY (LOCALVARS . T) (FILES (LOADCOMP) LLETHER)) (PROP (MAKEFILE-ENVIRONMENT FILETYPE) PUP))) (* ; "Low level pup") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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 412Q 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 10Q)) (PUPHOST# (LOGAND DATUM 377Q))) (CREATE (IPLUS (LLSH PUPNET# 10Q) PUPHOST#))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \LOCALPUPADDRESS MACRO (NIL \LOCALPUPNETHOST)) (PUTPROPS \LOCALPUPHOSTNUMBER MACRO (NIL (fetch PUPHOST# of \LOCALPUPNETHOST))) (PUTPROPS \LOCALPUPNETNUMBER MACRO (NIL (fetch PUPNET# of \LOCALPUPNETHOST))) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \LOCALPUPNETHOST \OLDPUPHOST#) ) ) (DEFINEQ (\STARTPUP [LAMBDA (EVENT) (* ; "Edited 15-Jan-88 01:04 by bvm") (for SOC in \PUPSOCKETS do (* ;; "Flush any pups waiting on existing sockets. Not only are they stale, but they will have the wrong NDB") (\FLUSHPUPSOCQUEUE SOC)) (ASSURE.PUP.READY EVENT]) (ASSURE.PUP.READY [LAMBDA (QUIET) (* ; "Edited 15-Jan-88 01:03 by bvm") (* ;; "Assures that Pup software is enabled. PUP is turned off after exit until somebody indicates a need for it") (WITH.MONITOR \PUP.READY.LOCK [COND ((NULL \PUP.READY) (PROG ((NDB \LOCALNDBS) (PROC (FIND.PROCESS '\PUPGATELISTENER)) MYHOST#) (SETQ \PUP.ROUTING.TABLE (\CLEAR.ROUTING.TABLE \PUP.ROUTING.TABLE)) (CLRHASH \ETHERPORTS) (COND ((NULL NDB) (SETQ \PUP.READY 'NO) (SETQ \LOCALPUPNETHOST 0) (AND PROC (DEL.PROCESS PROC)) (RETURN))) LP (COND ((NEQ (fetch NDBPUPHOST# of NDB) 0) (SETQ MYHOST# (fetch NDBPUPHOST# of NDB))) ([NULL (OR MYHOST# (SETQ MYHOST# (\FIND.LOCALPUPHOSTNUMBER NDB QUIET QUIET] (SETQ \LOCALPUPNETHOST 0) (* ;  "Don't know our pup number yet, so wait until somebody actually asks for pup service") (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.PUP)) (AND PROC (DEL.PROCESS PROC)) (RETURN)) (T (replace NDBPUPHOST# of NDB with MYHOST#))) (COND ((SETQ NDB (fetch NDBNEXT of NDB)) (GO LP))) (SETQ \LOCALPUPNETHOST (create PUPADDRESS PUPNET# _ (fetch NDBPUPNET# of \LOCALNDBS) PUPHOST# _ MYHOST#)) (SETQ \OLDPUPHOST# MYHOST#) [COND (\10MBFLG (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.3TO10))) (T (\DEL.PACKET.FILTER (FUNCTION \HANDLE.RAW.3TO10] (SETQ \PUPROUTER.PROBECOUNT 5) (SETQ \PUPROUTER.PROBETIMER (SETUPTIMER 0 \PUPROUTER.PROBETIMER)) (* ;  "This will get gate listener to probe for gateways when it starts up.") (COND (\GATEWAYFLG (AND PROC (DEL.PROCESS PROC))) (PROC (* ;  "Restart proc because it contains local timer that is now garbage") (RESTART.PROCESS PROC)) (T (ADD.PROCESS '(\PUPGATELISTENER) 'RESTARTABLE 'SYSTEM 'AFTEREXIT \PUP.READY.EVENT))) (\ADD.PACKET.FILTER (FUNCTION \HANDLE.RAW.PUP)) (SETQ \PUP.READY T) (NOTIFY.EVENT \PUP.READY.EVENT) (BLOCK) (RETURN T])]) (\FIND.LOCALPUPHOSTNUMBER [LAMBDA (NDB EVENT QUIET) (* bvm%: "26-Jul-84 16:27") (* ;; "Finds out our pup address on this 10mb NDB") (PROG (NEWNUMBER) [COND [(SETQ NEWNUMBER (\LOOKUPPUPNUMBER \MY.NSHOSTNUMBER NDB)) (COND (PUPTRACEFLG (printout PUPTRACEFILE "My pup address = " (fetch PUPNET# of NEWNUMBER) "#" (fetch PUPHOST# of NEWNUMBER) "#" T] (QUIET (RETURN NIL)) (T (SETQ NEWNUMBER (\PROMPT.FOR.PUP.NUMBER (AND (EQ EVENT 'AFTERLOGOUT) (NEQ \OLDPUPHOST# 0) (OCTALSTRING \OLDPUPHOST#] (* ;; "Only rely on the host number part of reply. There is confusion for machines that exist on more than one net") (RETURN (fetch PUPHOST# of NEWNUMBER]) (\PROMPT.FOR.PUP.NUMBER [LAMBDA (DEFAULT) (* bvm%: "26-Jul-84 16:30") (RESETLST (PROVIDE.PROMPTING.WINDOW "Ethernet info needed") (RESETBUFS (PROG (NEWNUMBER) LP (SETQ NEWNUMBER (PACK* (PROMPTFORWORD "Please enter my pup host number (in octal):" DEFAULT NIL NIL NIL T) 'Q)) (TERPRI T) (COND ((OR (NOT (FIXP NEWNUMBER)) (ILEQ NEWNUMBER 0) (IGEQ NEWNUMBER 376Q)) (printout T T "Pup host number must be between 1 and 376" T T) (CLEARBUF T) (FLASHWINDOW (TTYDISPLAYSTREAM)) (GO LP))) (RETURN NEWNUMBER))))]) (\HANDLE.RAW.PUP [LAMBDA (PACKET TYPE) (* ; "Edited 26-Feb-91 12:03 by jds") (* ;; "Handles the arrival of a PUP. If it is destined for a local socket that has room, queues it there, else releases it") (COND ((EQ TYPE \EPT.PUP) [COND ((NULL \PUP.READY) (RELEASE.PUP PACKET)) (T (PROG ((NDB (fetch EPNETWORK of PACKET)) CSUM PUPSOC DESTNET MYNET) (COND ((NULL NDB) (* ;; "Somehow, there's no network descriptor for this, so punt:") (RELEASE.PUP PACKET) (RETURN))) [COND ((AND (NEQ (fetch PUPDESTHOST of PACKET) (fetch NDBPUPHOST# of NDB)) (NEQ (fetch PUPDESTHOST of PACKET) 0)) (RETURN (\FORWARD.PUP PACKET] [COND ((AND (NEQ (SETQ DESTNET (fetch PUPDESTNET of PACKET)) (SETQ MYNET (fetch NDBPUPNET# of NDB))) (NEQ MYNET 0) (NEQ DESTNET 0)) (* ;  "Destination net is not us, so packet not for us") (RETURN (\FORWARD.PUP PACKET] (COND [[NULL (SETQ PUPSOC (\PUPSOCKET.FROM# (fetch PUPDESTSOCKETHI of PACKET ) (fetch PUPDESTSOCKETLO of PACKET] (* ;  "Packets addressed to non-active sockets are just ignored.") (COND (PUPTRACEFLG (PRIN1 '& PUPTRACEFILE))) (COND ((AND (EQ (fetch PUPTYPE of PACKET) \PT.ECHOME) (EQ (fetch PUPDESTSOCKETLO of PACKET) \PUPSOCKET.ECHO) (EQ (fetch PUPDESTSOCKETHI of PACKET) 0)) (* ; "Play echo server") (replace TYPEWORD of PACKET with (COND ([AND (NEQ (SETQ CSUM (fetch PUPCHECKSUM of PACKET )) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch PUPCHECKSUMBASE of PACKET) (SUB1 (FOLDHI (fetch PUPLENGTH of PACKET) BYTESPERWORD] \PT.IAMBADECHO) (T \PT.IAMECHO))) (SWAPPUPPORTS PACKET) (replace EPREQUEUE of PACKET with 'FREE) (SENDPUP NIL PACKET)) (T (\PUPERROR PACKET \PUPE.NOSOCKET] ((IGEQ (fetch (PUPSOCKET INQUEUELENGTH) of PUPSOC) (fetch (PUPSOCKET PUPSOC#ALLOCATION) of PUPSOC)) (* ;  "Note that packets are just 'dropped' when the queue overflows.") (\PUPERROR PACKET \PUPE.SOCKETFULL)) ([AND \PUP.CHECKSUMFLG (NEQ (SETQ CSUM (fetch PUPCHECKSUM of PACKET)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch PUPCHECKSUMBASE of PACKET) (SUB1 (FOLDHI (fetch PUPLENGTH of PACKET) BYTESPERWORD] (\PUPERROR PACKET \PUPE.CHECKSUM)) (T [COND ((EQ DESTNET 0) (* ;  "Fill in unspecified destination net (possibly redundantly with zero)") (replace PUPDESTNET of PACKET with MYNET)) ((EQ MYNET 0) (* ;; "Packet of specific destination net has arrived on a socket that we listen to. If we don't know our own net number, assume sender is telling the truth") (replace NDBPUPNET# of NDB with DESTNET) (* ;; "But don't try to set our \LOCALPUPNETHOST if the NDB doesn't know its pup host number. This can happen when a pup arrives in the interval after the NDB was created and before a \LOOKUPPUPNUMBER call has succeeded.") [COND ((NEQ 0 (fetch NDBPUPHOST# of NDB)) (SETQ \LOCALPUPNETHOST (create PUPADDRESS PUPNET# _ DESTNET PUPHOST# _ (fetch NDBPUPHOST# of NDB] (* ;  "This variable only for backward compatibility. Delete it some day") (PROG [(ENTRY (OR (\LOCATE.PUPNET DESTNET T) (\ADD.ROUTING.TABLE.ENTRY \PUP.ROUTING.TABLE (create ROUTING RTNET# _ DESTNET] (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) (replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T] (UNINTERRUPTABLY (\ENQUEUE (fetch (PUPSOCKET INQUEUE) of PUPSOC) PACKET) (add (fetch (PUPSOCKET INQUEUELENGTH) of PUPSOC) 1) (NOTIFY.EVENT (fetch PUPSOCEVENT of PUPSOC)))] T]) (\FORWARD.PUP [LAMBDA (PUP) (* bvm%: "22-SEP-83 14:24") (* ;; "Called when we receive a PUP not addressed to us. Unless we are a gateway, dump it") (COND (\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP)) (\GATEWAYFLG (\GATEWAY.FORWARD.PUP PUP)) (T (COND (PUPTRACEFLG (PRINTPUP PUP 'GET NIL "PUP not addressed to this host: "))) (\RELEASE.ETHERPACKET PUP]) (\SETPUPCHECKSUM [LAMBDA (PUP) (* bvm%: "11-FEB-83 12:28") (* ;; "Sets the PUPCHECKSUM field of PUP to checksum over its current contents") (replace PUPCHECKSUM of PUP with (COND [\PUP.CHECKSUMFLG (\CHECKSUM (fetch PUPCHECKSUMBASE of PUP) (SUB1 (FOLDHI (fetch PUPLENGTH of PUP) BYTESPERWORD] (T \NULLCHECKSUM))) T]) ) (RPAQ? \PUP.CHECKSUMFLG T) (RPAQ? \MAX.EPKTS.ON.PUPSOCKET 20Q) (RPAQ? \LOCALPUPNETHOST ) (RPAQ? \OLDPUPHOST# 0) (* ; "Pup error stuff") (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM))) (BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q 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 1001Q) (\PUPE.NOROUTE 1002Q) (\PUPE.NOHOST 1003Q) (\PUPE.LOOPED 1004Q) (\PUPE.TOOLARGE 1005Q) (\PUPE.WRONG.GATEWAY 1006Q) (\PUPE.GATEWAYFULL 1007Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPE.CHECKSUM 1) (RPAQQ \PUPE.NOSOCKET 2) (RPAQQ \PUPE.SOCKETFULL 3) (RPAQQ \PUPE.GATEWAY.BADPUP 1001Q) (RPAQQ \PUPE.NOROUTE 1002Q) (RPAQQ \PUPE.NOHOST 1003Q) (RPAQQ \PUPE.LOOPED 1004Q) (RPAQQ \PUPE.TOOLARGE 1005Q) (RPAQQ \PUPE.WRONG.GATEWAY 1006Q) (RPAQQ \PUPE.GATEWAYFULL 1007Q) (CONSTANTS (\PUPE.CHECKSUM 1) (\PUPE.NOSOCKET 2) (\PUPE.SOCKETFULL 3) (\PUPE.GATEWAY.BADPUP 1001Q) (\PUPE.NOROUTE 1002Q) (\PUPE.NOHOST 1003Q) (\PUPE.LOOPED 1004Q) (\PUPE.TOOLARGE 1005Q) (\PUPE.WRONG.GATEWAY 1006Q) (\PUPE.GATEWAYFULL 1007Q)) ) (* "END EXPORTED DEFINITIONS") (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PUPERRORMESSAGES) ) ) (RPAQQ PUPERRORMESSAGES ((1 "Bad Checksum") (2 "No such socket") (3 "Socket full") (1001Q "Inconsistent pup") (1002Q "No route to that host") (1003Q "Host is down") (1004Q "Too many hops") (1005Q "Pup too long") (1006Q "Wrong gateway for that host") (1007Q "Gateway IQ full"))) (DEFINEQ (\PUPERROR [LAMBDA (PUP ERRCODE MSG) (* bvm%: " 5-Jan-85 23:33") (* ;;; "Turn packet around into an error packet with given error") (COND (\PEEKPUPNUMBER (\MAYBEPEEKPUP PUP)) ((AND (NEQ (fetch PUPDESTHOST of PUP) 0) (NEQ (fetch PUPTYPE of PUP) \PT.ERROR)) (* ;  "Don't respond to errors or to broadcasts!") [COND ((AND PUPTRACEFLG (NEQ PUPTRACEFLG 'PEEK)) (printout PUPTRACEFILE "Incoming packet dropped because: " (OR (CADR (ASSOC ERRCODE PUPERRORMESSAGES )) ERRCODE) T) (OR (EQ PUPTRACEFLG 'RAW) (PRINTPUP PUP] (\BLT (fetch PUPCONTENTS of PUP) (fetch PUPBASE of PUP) (FOLDLO \PUPHEADERLEN BYTESPERWORD)) (* ; "Copy pup header into body") (replace ERRORPUPCODE of PUP with ERRCODE) (replace ERRORPUPARG of PUP with 0) [replace PUPLENGTH of PUP with (IPLUS \PUPOVLEN \PUPHEADERLEN (ITIMES 2 BYTESPERWORD ) (\PUTBASESTRING (LOCF (fetch ERRORPUPSTRINGBASE of PUP)) 0 (OR MSG (CADR (ASSOC ERRCODE PUPERRORMESSAGES )) ""] (replace PUPTYPE of PUP with \PT.ERROR) (SWAPPUPPORTS PUP) (replace EPREQUEUE of PUP with 'FREE) (SENDPUP NIL PUP)) (T (\RELEASE.ETHERPACKET PUP]) ) (* ; "Pup utilities") (DEFINEQ (SETUPPUP [LAMBDA (PUP DESTHOST DESTSOCKET TYPE ID SOC REQUEUE) (* bvm%: " 5-Jan-85 23:34") (* ;; "Initialize pup header PUP with indicated destination HOST, DESTSOCKET and TYPE. A local socket and ID (if not supplied) are assigned. Returns a 'socket' datum") (OR \PUP.READY (ASSURE.PUP.READY)) (replace PUPLENGTH of (SETQ PUP (\DTEST PUP 'ETHERPACKET)) with \PUPOVLEN) (* ; "pup data initially empty") (replace (PUP TYPEWORD) of PUP with TYPE) (* ; "Clears PUPTCONTROL") [replace PUPID of PUP with (OR ID (SETQ \PUPCOUNTER (COND ((IGEQ \PUPCOUNTER 177777Q) 1) (T (ADD1 \PUPCOUNTER] (replace PUPDEST of PUP with (OR (FIXP (SETQ DESTHOST (ETHERPORT DESTHOST T))) (CAR DESTHOST))) (replace PUPDESTSOCKET of PUP with (COND ((AND (LISTP DESTHOST) (NEQ (CDR DESTHOST) 0)) (CDR DESTHOST)) (T DESTSOCKET))) (AND REQUEUE (replace EPREQUEUE of PUP with REQUEUE)) (OR SOC (SETQ SOC (OPENPUPSOCKET]) (SWAPPUPPORTS [LAMBDA (PUP) (* bvm%: "12-FEB-83 16:21") (swap (fetch PUPSOURCE of PUP) (fetch DEST of PUP)) (swap (fetch PUPSOURCESOCKETHI of PUP) (fetch DESTSKTHI of PUP)) (swap (fetch PUPSOURCESOCKETLO of PUP) (fetch DESTSKTLO of PUP]) (GETPUP [LAMBDA (PUPSOC WAIT) (* bvm%: "24-MAY-83 17:42") (SETQ PUPSOC (\DTEST PUPSOC 'PUPSOCKET)) (PROG (PUP TIMER) LP (UNINTERRUPTABLY (COND ((SETQ PUP (\DEQUEUE (ffetch (PUPSOCKET INQUEUE) of PUPSOC))) (add (ffetch (PUPSOCKET INQUEUELENGTH) of PUPSOC) -1)))) (COND [(NULL PUP) (COND (WAIT (COND ((EQ WAIT T)) [TIMER (COND ((TIMEREXPIRED? TIMER) (RETURN] (T (OR (FIXP WAIT) (LISPERROR "NON-NUMERIC ARG" WAIT)) (SETQ TIMER (SETUPTIMER WAIT)) T)) (AWAIT.EVENT (ffetch PUPSOCEVENT of PUPSOC) TIMER T) (GO LP)) (T (* ; "Let ether procs run") (BLOCK] [(EQ \EPT.PUP (fetch EPTYPE of PUP)) (AND PUPTRACEFLG (\MAYBEPRINTPACKET PUP 'GET] (T (AND PUPTRACEFLG (printout PUPTRACEFILE T "Non-PUP packet " PUP " arrived on " PUPSOC T)) (SETQ PUP))) (RETURN PUP]) (SENDPUP [LAMBDA (PUPSOC PUP) (* bvm%: " 5-Jan-85 23:34") (* ;;  "Returns the PUP arg iff packet can be sent; returns a litatom explaining error otherwise.") (SETQ PUP (\DTEST PUP 'ETHERPACKET)) [AND PUPSOC (SETQ PUPSOC (\DTEST PUPSOC 'PUPSOCKET] (replace EPTYPE of PUP with \EPT.PUP) (replace PUPTCONTROL of PUP with 0) (PROG (NDB) (\RCLK (LOCF (fetch EPTIMESTAMP of PUP))) [COND ((AND PUPSOC (EQ (fetch PUPSOURCESOCKETLO of PUP) 0) (EQ (fetch PUPSOURCESOCKETHI of PUP) 0)) (replace PUPSOURCESOCKETHI of PUP with (fetch PSOCKETHI of PUPSOC)) (replace PUPSOURCESOCKETLO of PUP with (fetch PSOCKETLO of PUPSOC] (RETURN (COND ((NEQ (OR \PUP.READY (ASSURE.PUP.READY)) T) (* ; "No PUP?") (\REQUEUE.ETHERPACKET PUP) 'NoEther) ((fetch EPTRANSMITTING of PUP) (AND PUPTRACEFLG (printout PUPTRACEFILE "[Packet not sent--already being transmitted]" T)) 'AlreadyQueued) ((NULL (SETQ NDB (\ROUTE.PUP PUP))) (AND PUPTRACEFLG (PRINTPUPROUTE PUP "[Put fails: no routing]" PUPTRACEFILE) ) (\REQUEUE.ETHERPACKET PUP) 'NoRouting) (T (\SETPUPCHECKSUM PUP) (AND PUPTRACEFLG (\MAYBEPRINTPACKET PUP 'PUT)) (TRANSMIT.ETHERPACKET NDB PUP) (BLOCK) NIL]) (EXCHANGEPUPS [LAMBDA (SOC OUTPUP DUMMY IDFILTER TIMEOUT) (* bvm%: "24-MAY-83 23:19") (* ;; "Sends out OUTPUP on SOC and waits for a reply, which it puts in INPUP. If IDFILTER is true, only replies with the same ID are accepted. Returns input pup on success, or NIL on failure. TIMEOUT overrides the default timeout.") (DISCARDPUPS (\DTEST SOC 'PUPSOCKET)) (* ;  "Flush any pups waiting on this socket") (SENDPUP SOC OUTPUP) (bind INPUP (TIMER _ (SETUPTIMER (OR TIMEOUT \ETHERTIMEOUT))) (EVENT _ (ffetch PUPSOCEVENT of SOC)) do (COND ([AND (SETQ INPUP (GETPUP SOC)) (OR (NOT IDFILTER) (IEQP (fetch PUPID of INPUP) (fetch PUPID of OUTPUP] (RETURN INPUP)) (T (AWAIT.EVENT EVENT TIMER T))) repeatuntil (TIMEREXPIRED? TIMER]) (DISCARDPUPS [LAMBDA (SOC) (* bvm%: " 5-MAY-83 23:51") (SETQ SOC (\DTEST SOC 'PUPSOCKET)) (UNINTERRUPTABLY (PROG1 (fetch (PUPSOCKET INQUEUELENGTH) of SOC) (\FLUSH.PACKET.QUEUE (fetch (PUPSOCKET INQUEUE) of SOC)) (replace (PUPSOCKET INQUEUELENGTH) of SOC with 0)))]) (GETPUPWORD [LAMBDA (PUP WORD#) (* bvm%: "31-JAN-83 15:27") (\GETBASE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP 'ETHERPACKET] WORD#]) (\PUPINIT [LAMBDA NIL (* ; "Edited 13-Feb-89 15:25 by snow") (for FN in '(SETUPPUP EXCHANGEPUPS GETPUP SENDPUP CLEARPUP GETPUPSTRING PUTPUPSTRING ALLOCATE.PUP RELEASE.PUP CREATESOCKET FLUSHSOCKET) bind NEWFN unless (GETD (SETQ NEWFN (PACK* '\ FN))) do (* ; "make dummy defs for old \ fns") (PUTD NEWFN (GETD FN) T)) (OR (EQ \MACHINETYPE \MAIKO) (INITPUPLEVEL1 T]) ) (DEFINEQ (ETHERHOSTNAME [LAMBDA (PORT USE.OCTAL.DEFAULT) (* bvm%: "25-Apr-86 12:40") (* ;;; "Looks up the name of the host at address PORT. PORT may be a numeric address, or (host . socket) as returned by ETHERPORT") (PROG ((SOC (\GETMISCSOCKET)) (SOCKET# 0) (OPUP (ALLOCATE.PUP)) NETHOST RESULT BUF IPUP) (OR (EQ (OR \PUP.READY (ASSURE.PUP.READY)) T) (RETURN)) [SETQ NETHOST (COND ((NULL PORT) (\LOCALPUPHOSTNUMBER)) ((FIXP PORT)) [(AND (LISTP PORT) (FIXP (SETQ SOCKET# (CDR PORT))) (FIXP (CAR PORT] ((AND (NLISTP PORT) (SETQ NETHOST (\PARSE.PORTCONSTANT PORT))) (SETQ SOCKET# (CDR NETHOST)) (CAR NETHOST)) (T (LISPERROR "ILLEGAL ARG" PORT] [COND ((EQ (fetch PUPNET# of NETHOST) 0) (* ;  "Net not specified, default to local net") (SETQ NETHOST (create PUPADDRESS PUPNET# _ (\LOCALPUPNETNUMBER) PUPHOST# _ NETHOST] (SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.ADDRLOOKUP NIL SOC T) (add (fetch PUPLENGTH of OPUP) 6) (* ; "port is 6 bytes long") (replace (PORT NETHOST) of (SETQ BUF (fetch PUPCONTENTS of OPUP)) with NETHOST) (replace (PORT SOCKET) of BUF with SOCKET#) [to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T)) do (SELECTC (fetch PUPTYPE of IPUP) (\PT.ADDRRESPONSE (SETQ RESULT (GETPUPSTRING IPUP)) (COND ([for C instring RESULT always (AND (ILESSP C (CHARCODE 10Q)) (IGEQ C (CHARCODE 0] (* ;; "Not really a name, but a Dandelion processor ID. Pretend is NIL so as not to confuse rest of world with uninvertable name") (SETQ RESULT NIL))) (RETURN)) (\PT.NAME/ADDRERROR (COND (PUPTRACEFLG (printout PUPTRACEFILE "Address lookup error for " (PORTSTRING NETHOST SOCKET#) ": " (GETPUPSTRING IPUP) T))) (RETURN)) NIL) finally (COND (PUPTRACEFLG (printout PUPTRACEFILE "Address lookup timed out" T] (AND IPUP (RELEASE.PUP IPUP)) (RELEASE.PUP OPUP) (RETURN (OR RESULT (AND USE.OCTAL.DEFAULT (PORTSTRING NETHOST (AND (NEQ SOCKET# 0) SOCKET#]) (ETHERHOSTNUMBER [LAMBDA (NAME) (* ; "Edited 31-Mar-87 18:26 by bvm:") (OR \PUP.READY (ASSURE.PUP.READY)) (COND ((NULL NAME) (\LOCALPUPADDRESS)) (T (CAR (BESTPUPADDRESS NAME]) (ETHERPORT [LAMBDA (NAME ERRORFLG MULTFLG) (* bvm%: "16-NOV-83 11:40") (* ;;; "Returns net address of NAME as (nethost . socket), or list of same if MULTFLG is true . Caches results locally so doesn't have to look all the time. If ERRORFLG is true, generates error on failure.") (* ;;; "If MULTFLG is nonNIL, returns a list of results --- singleton unless perhaps from \LOOKUPPORT") (PROG (VAL) (RETURN (COND ([SETQ VAL (COND ((FIXP NAME) (* ;  "A host number. Give it socket zero") (\FIXLOCALNET (CONS NAME 0))) [(LISTP NAME) (* ; "An existing port structure") (COND ((AND (FIXP (CAR NAME)) (FIXP (CDR NAME))) (\FIXLOCALNET NAME)) (ERRORFLG (\ILLEGAL.ARG NAME)) (T (RETURN] (T (\PARSE.PORTCONSTANT NAME] (COND (MULTFLG (LIST VAL)) (T VAL))) [(SETQ VAL (OR (GETHASH NAME \ETHERPORTS) (PUTHASH NAME (\LOOKUPPORT NAME) \ETHERPORTS))) (* ;  "note we always save multiple values in case they are ever wanted") (COND (MULTFLG VAL) (T (CAR VAL] (ERRORFLG (ERROR "host not found" NAME]) (BESTPUPADDRESS [LAMBDA (HOST ERRORSTREAM) (* bvm%: " 5-Jan-85 23:36") (* ;; "Returns a pup port for HOST, selecting the one of possibly multiple ports that is closest, returning NIL if there is no route or name lookup fails. If ERRORSTREAM = ERROR, causes error on failure; otherwise ERRORSTREAM is a stream to print an appropriate error message to before returning NIL") (PROG (PORT NET MSG) (OR (EQ (OR \PUP.READY (ASSURE.PUP.READY)) T) (RETURN)) RETRY (COND [[SETQ PORT (COND ((FIXP HOST) (* ;  "A host number. Give it socket zero") (\FIXLOCALNET (CONS HOST 0))) [(LISTP HOST) (* ; "An existing port structure") (COND ((AND (FIXP (CAR HOST)) (FIXP (CDR HOST))) (\FIXLOCALNET HOST)) (ERRORSTREAM (SETQ MSG "Invalid port specification") (GO ERROR)) (T (RETURN] (T (\PARSE.PORTCONSTANT HOST] (COND ((OR (EQ (SETQ NET (fetch PUPNET# of (CAR PORT))) 0) (EQ NET (\LOCALPUPNETNUMBER))) (RETURN PORT)) (T (SETQ PORT (LIST PORT] ((SETQ PORT (OR (GETHASH HOST \ETHERPORTS) (PUTHASH HOST (\LOOKUPPORT HOST) \ETHERPORTS))) (* ;  "note we always save multiple values in case they are ever wanted") ) (ERRORSTREAM (SETQ MSG "Host not found") (GO ERROR)) (T (RETURN))) [RETURN (for TRY from 1 to 5 bind NOTLOOKEDUP HOPS BESTHOPS BESTPORT ROUTE do (SETQ BESTHOPS \RT.INFINITY) (SETQ NOTLOOKEDUP (SETQ BESTPORT NIL)) [for PAIR in PORT do (COND ((OR [NOT (SETQ ROUTE (\LOCATE.PUPNET (fetch PUPNET# of (CAR PAIR] (IGEQ (SETQ HOPS (fetch RTHOPCOUNT of ROUTE)) \RT.INFINITY)) (SETQ NOTLOOKEDUP T)) ((ILESSP HOPS BESTHOPS) (SETQ BESTHOPS HOPS) (SETQ BESTPORT PAIR] (* ;  "Enter request for routing for all hosts") (COND ((AND BESTPORT (OR (NOT NOTLOOKEDUP) (ILEQ BESTHOPS \PUP.ROUTING.TABLE.RADIUS) (IGREATERP TRY 1))) (RETURN BESTPORT))) (BLOCK \ETHERTIMEOUT) finally (COND (ERRORSTREAM (SETQ MSG "No route to host") (GO ERROR] ERROR (COND ((EQ ERRORSTREAM 'ERROR) (ERROR MSG HOST) (GO RETRY)) (T (printout ERRORSTREAM T MSG ": " HOST) (RETURN]) (NETDAYTIME0 [LAMBDA NIL (* bvm%: "26-Jul-84 15:26") (* ;;; "Returns a 32-bit unsigned alto time from the network, if possible") (\NET.SETTIME T]) (\PUP.SETTIME [LAMBDA (RETFLG) (* bvm%: " 1-NOV-83 17:07") (* ;;; "Sets the local time from the network, if possible, or simply returns a 32-bit unsigned alto time if RETFLG is T") (DECLARE (GLOBALVARS \TimeZoneComp \BeginDST \EndDST)) (PROG ((SOC (\GETMISCSOCKET)) (OPUP (ALLOCATE.PUP)) RESULT IPUP DATA TIME) (SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.ALTOTIMEREQUEST NIL SOC T) (RETURN (to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T)) do (SELECTC (fetch PUPTYPE of IPUP) (\PT.ALTOTIMERESPONSE (SETQ DATA (fetch PUPCONTENTS of IPUP)) (SETQ TIME (create FIXP HINUM _ (fetch TIMEPUPVALUEHI of DATA) LONUM _ (fetch TIMEPUPVALUELO of DATA))) (COND (RETFLG (RETURN TIME))) (\SETNEWTIME0 TIME) (SETQ \TimeZoneComp (ITIMES (COND ((fetch TIMEPUPEASTP of DATA) -1) (T 1)) (fetch TIMEPUPHOURS of DATA)) ) (SETQ \BeginDST (fetch TIMEPUPBEGINDST of DATA)) (SETQ \EndDST (fetch TIMEPUPENDDST of DATA)) (RELEASE.PUP IPUP) (RETURN T)) (\PT.ERROR (AND PUPTRACEFLG (PRINTERRORPUP IPUP PUPTRACEFILE))) NIL) (RELEASE.PUP IPUP]) (\SETNEWTIME0 [LAMBDA (NEWTIME) (* bvm%: "26-Jul-84 15:23") (PROG [(OLDTIME (\DAYTIME0 (create FIXP] (\SETDAYTIME0 NEWTIME) (COND ((IGREATERP (IABS (IDIFFERENCE NEWTIME OLDTIME)) 454Q) (* ;  "Time changed by more than 5 minutes, maybe mention it") (printout PROMPTWINDOW T "[Time reset to " (DATE (DATEFORMAT TIME.ZONE)) "]"]) (\NET.SETTIME [LAMBDA (RETFLG) (* bvm%: "26-Jul-84 15:25") (* ;;; "Sets the time from local network time server, or just returns said time if RETFLG is true") (if \LOCALNDBS then (SELECTQ (fetch (NDB NETTYPE) of \LOCALNDBS) (3 (OR (\PUP.SETTIME RETFLG) (\NS.SETTIME RETFLG))) (12Q (OR (\NS.SETTIME RETFLG) (AND \PUP.READY (\PUP.SETTIME RETFLG)))) NIL]) (NETDATE [LAMBDA NIL (* bvm%: "25-Apr-86 12:46") (GDATE (ALTO.TO.LISP.DATE (OR (NETDAYTIME0) (\DAYTIME0 (create FIXP]) (\LOOKUPPORT [LAMBDA (NAME) (* ; "Edited 1-Apr-87 12:37 by bvm:") (* ;;; "Looks up the ether address of NAME, returning a list of dotted pairs (nethost . socket), or NIL on failure") (AND NAME (PROG ((SOC (\GETMISCSOCKET)) (OPUP (ALLOCATE.PUP)) RESULT BUF LEN IPUP) (SETUPPUP OPUP 0 \PUPSOCKET.MISCSERVICES \PT.NAMELOOKUP NIL SOC T) (PUTPUPSTRING OPUP NAME) [to \MAXETHERTRIES when (SETQ IPUP (EXCHANGEPUPS SOC OPUP NIL T)) do (SELECTC (fetch PUPTYPE of IPUP) (\PT.NAMERESPONSE [COND ((> (SETQ LEN (IQUOTIENT (FOLDLO (- (fetch PUPLENGTH of IPUP) \PUPOVLEN) BYTESPERWORD) \PORTIDLEN)) 1) (COND (PUPTRACEFLG (printout PUPTRACEFILE "Multiple response received for " NAME T ] [RETURN (SETQ RESULT (from 1 to LEN as (PTR _ (fetch PUPCONTENTS of IPUP)) by (\ADDBASE PTR \PORTIDLEN) collect (CONS (fetch (PORT NETHOST) of PTR) (fetch (PORT SOCKET) of PTR]) (\PT.NAME/ADDRERROR (COND (PUPTRACEFLG (printout PUPTRACEFILE "Name lookup error for " NAME ": " (GETPUPSTRING IPUP) T))) (RETURN)) NIL) finally (COND (PUPTRACEFLG (printout PUPTRACEFILE "Name lookup timed out" T] (AND IPUP (RELEASE.PUP IPUP)) (RELEASE.PUP OPUP) (RETURN RESULT]) (\PARSE.PORTCONSTANT [LAMBDA (STR) (* bvm%: "16-NOV-83 12:01") (* ;;; "If STR is a constant ether address of form net#host#socket, returns a port, else NIL") (for CH instring (OR (STRINGP STR) (SETQ STR (MKSTRING STR))) bind NET HOST VAL do (COND [(AND (IGEQ CH (CHARCODE 0)) (ILEQ CH (CHARCODE 7))) (* ; "Add octal digit into value") (SETQ VAL (IPLUS (COND (VAL (LLSH VAL 3)) (T 0)) (IDIFFERENCE CH (CHARCODE 0] ((EQ CH (CHARCODE %#)) (* ; "# terminates net or host number") (COND (NET (RETURN))) (SETQ NET HOST) (SETQ HOST (OR VAL 0)) (SETQ VAL NIL)) (T (RETURN))) finally (* ;  "Ran out of chars. Save last value parsed, make sure we have at least a net and host") (RETURN (AND (OR HOST VAL) (CONS (LOGOR (OR HOST 0) (COND (NET (LLSH NET 10Q)) (T 0))) (OR VAL 0]) (\FIXLOCALNET [LAMBDA (PORT) (* bvm%: " 5-Jan-85 23:37") (* ;; "Port is a dotted pair (nethost . socket). We force the nethost to have a nonzero net if we know our net by now. Returns the possibly modified PORT") [PROG (NET) (COND ((AND (ILESSP (CAR PORT) 400Q) (NEQ (CAR PORT) 0) \LOCALNDBS (SETQ NET (fetch NDBPUPNET# of \LOCALNDBS)) (NEQ NET 0)) (RPLACA PORT (create PUPADDRESS PUPNET# _ NET PUPHOST# _ (CAR PORT] PORT]) ) (DEFINEQ (PORTSTRING [LAMBDA (NETHOST SOCKET) (* bvm%: " 5-Jan-85 23:40") [COND ((LISTP NETHOST) (SETQ SOCKET (CDR NETHOST)) (COND ((EQ SOCKET 0) (SETQ SOCKET NIL))) (SETQ NETHOST (CAR NETHOST] (CONCAT (OCTALSTRING (LRSH NETHOST 10Q)) '%# (OCTALSTRING (LOGAND NETHOST 377Q)) '%# (COND (SOCKET (OCTALSTRING SOCKET)) (T ""]) (OCTALSTRING [LAMBDA (N) (* bvm%: "21-JUL-81 12:16") (GLOBALRESOURCE (\NUMSTR \NUMSTR1) (CONCAT (\CONVERTNUMBER N 10Q NIL NIL \NUMSTR \NUMSTR1]) ) (RPAQ? \ETHERPORTS (HASHARRAY 24Q)) (RPAQ? \ETHERTIMEOUT 3720Q) (RPAQ? \MAXETHERTRIES 4) (RPAQ? \PUPCOUNTER 0) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \ETHERPORTS \PUPCOUNTER) ) (* ; "Accessing a PUP's contents") (DEFINEQ (CLEARPUP [LAMBDA (PUP) (* bvm%: "31-JAN-83 15:31") (replace EPLINK of (SETQ PUP (\DTEST PUP 'ETHERPACKET)) with NIL) (* ; "Clear the pointer fields") [replace EPUSERFIELD of PUP with (replace EPPLIST of PUP with (replace EPREQUEUE of PUP with (replace EPSOCKET of PUP with (replace EPNETWORK of PUP with NIL] (\ZEROWORDS (fetch PUPBASE of PUP) (\ADDBASE (LOCF (fetch SOURCESKT of PUP)) 1)) (\ZEROBYTES (fetch PUPCONTENTS of PUP) 0 (SUB1 \MAX.PUPLENGTH]) (PUTPUPWORD [LAMBDA (PUP WORD# VALUE) (* bvm%: "31-JAN-83 15:31") (\PUTBASE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP 'ETHERPACKET] WORD# VALUE]) (GETPUPBYTE [LAMBDA (PUP BYTE#) (* bvm%: "31-JAN-83 15:31") (\GETBASEBYTE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP 'ETHERPACKET] BYTE#]) (PUTPUPBYTE [LAMBDA (PUP BYTE# VALUE) (* bvm%: "31-JAN-83 15:31") (\PUTBASEBYTE [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP 'ETHERPACKET] BYTE# VALUE]) (GETPUPSTRING [LAMBDA (PUP OFFSET) (* bvm%: "26-Apr-84 10:04") (PROG [(NC (IDIFFERENCE (IDIFFERENCE [ffetch PUPLENGTH of (SETQ PUP (\DTEST PUP 'ETHERPACKET] \PUPOVLEN) (OR OFFSET (SETQ OFFSET 0] (RETURN (COND ((IGREATERP NC 0) (\GETBASESTRING (ffetch PUPCONTENTS of PUP) OFFSET NC)) (T (* ;  "Could give error if length negative, but the empty string is a reasonable thing to return") (ALLOCSTRING 0]) (GETPUPSTREAM [LAMBDA (PUP OFFSET LENGTH ACCESS WRITEXTENSIONFN) (* bvm%: "26-OCT-83 12:10") (\MAKEBASEBYTESTREAM [fetch PUPCONTENTS of (SETQ PUP (\DTEST PUP 'ETHERPACKET] (OR OFFSET (SETQ OFFSET 0)) (OR LENGTH (IDIFFERENCE (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN) OFFSET)) (OR ACCESS 'INPUT) WRITEXTENSIONFN]) (PUTPUPSTRING [LAMBDA (PUP STR) (* bvm%: "31-JAN-83 15:35") (add [fetch PUPLENGTH of (SETQ PUP (\DTEST PUP 'ETHERPACKET] (\PUTBASESTRING (fetch PUPCONTENTS of PUP) (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN) STR]) ) (DEFOPTIMIZER GETPUPWORD (PUPARG WORD#) `(\GETBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET)) ,WORD#)) (DEFOPTIMIZER PUTPUPWORD (PUPARG WORD# VALUE) `(\PUTBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET)) ,WORD# ,VALUE)) (DEFOPTIMIZER GETPUPBYTE (PUPARG BYTE#) `(\GETBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET)) ,BYTE#)) (DEFOPTIMIZER PUTPUPBYTE (PUPARG BYTE# VALUE) `(\PUTBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET)) ,BYTE# ,VALUE)) (* ; "Reading property lists from streams") (DEFINEQ (READPLIST [LAMBDA (STREAM NOERRORFLG) (* bvm%: " 6-Oct-86 14:14") (* ;;; "Reads an FTP-style property list from STREAM. If the plist is malformed, causes an error unless NOERRORFLG is true. FTP-style plists look like lists of two elements in a very rigid syntax: each element of the list is (property value); spaces are significant except the one immediately following property. READPLIST returns the property names as uppercase atoms, the values as strings") (PROG ([READTABLES (OR (LISTP \READPLIST.READTABLES) (SETQ \READPLIST.READTABLES (LET ((TAB1 (COPYREADTABLE 'ORIG)) TAB2) (SETSEPR NIL NIL TAB1) (* ;; "Want to set up two readtables to read properties. Both read tables use ' as escape character. The first read table reads the property; it terminates on space and is case-insensitive. The second read table reads the value; it terminates on right paren.") (SETSYNTAX '%' 'ESCAPE TAB1) (SETSYNTAX '%% 'OTHER TAB1) (SETQ TAB2 (COPYREADTABLE TAB1)) (SETBRK (CHARCODE (")")) NIL TAB2) (SETBRK (CHARCODE (SPACE)) NIL TAB1) (READTABLEPROP TAB1 'CASEINSENSITIVE T) (CONS TAB1 TAB2] PLIST) (OR (EQ (BIN STREAM) (CHARCODE "(")) (GO ERROR)) [RETURN (bind CH while (EQ (SETQ CH (BIN STREAM)) (CHARCODE "(")) collect (* ; "Another element") (PROG1 [LIST (RATOM STREAM (CAR READTABLES)) (PROGN (BIN STREAM) (* ; "Skip over the space") (RSTRING STREAM (CDR READTABLES] (COND ((NEQ (BIN STREAM) (CHARCODE ")")) (GO ERROR)))) finally (COND ((NEQ CH (CHARCODE ")")) (GO ERROR] ERROR (OR NOERRORFLG (ERROR "Malformed property list in stream" STREAM)) (RETURN NIL]) ) (RPAQ? \READPLIST.READTABLES NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \READPLIST.READTABLES) ) (DEFINEQ (CANONICAL.HOSTNAME [LAMBDA (HOSTNAME) (* ; "Edited 12-Apr-88 17:43 by bvm") (LET [(DEV (CL:ASSOC HOSTNAME \DEVICENAMETODEVICE :TEST 'STRING-EQUAL] (if DEV then (* ; "Known device, don't ask anyone") (fetch DEVICENAME of (CDR DEV)) elseif (STRPOS ":" HOSTNAME) then (* ; "Assume NS") (\CANONICAL.NSHOSTNAME HOSTNAME) elseif (NUMBERP HOSTNAME) then (* ; "Some sort of host address") (if (AND (SMALLP HOSTNAME) (< HOSTNAME 377Q)) then (* ; "valid pup address") HOSTNAME elseif \IP.READY then (* ; "Big number may be IP host") (IPHOSTNAME HOSTNAME)) else (if (NOT (LITATOM HOSTNAME)) then (SETQ HOSTNAME (MKATOM HOSTNAME))) (OR (CDR (FASSOC HOSTNAME \HOSTNAMES)) (\CANONICALIZE.IP.HOSTNAME HOSTNAME) (\CANONICALIZE.PUP.HOSTNAME HOSTNAME]) (\CANONICAL.HOSTNAME [LAMBDA (NAME) (* ; "Edited 11-Mar-88 12:09 by bvm") (* ;;; "Returns the canonical name of a given hostname, in case a server has synonyms") (if (NUMBERP NAME) then (AND (SMALLP NAME) (< NAME 377Q) NAME) else (if (NOT (LITATOM NAME)) then (SETQ NAME (MKATOM NAME))) (OR (CDR (FASSOC NAME \HOSTNAMES)) (\CANONICALIZE.PUP.HOSTNAME NAME]) (\CANONICALIZE.PUP.HOSTNAME [LAMBDA (NAME) (* ; "Edited 11-Mar-88 12:09 by bvm") (DECLARE (GLOBALVARS FIXSPELLREL)) (LET ((PORT (ETHERPORT NAME)) OFFICIALNAME) (COND (PORT (if [NOT (LITATOM (SETQ OFFICIALNAME (MKATOM (U-CASE (OR (ETHERHOSTNAME PORT) NAME] then (* ;  "DLions with no real name come out as large integers, not litatoms, so use name given") (SETQ OFFICIALNAME (U-CASE NAME))) (push \HOSTNAMES (CONS NAME OFFICIALNAME)) (* ;  "If no name in database, take what was given") OFFICIALNAME) (\HOSTNAMES (FIXSPELL NAME FIXSPELLREL \HOSTNAMES T]) ) (* ;  "Default this for when IP not loaded") (MOVD? 'NILL '\CANONICALIZE.IP.HOSTNAME NIL T) (ADDTOVAR \HOSTNAMES ) (ADDTOVAR \SYSTEMCACHEVARS \HOSTNAMES) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \HOSTNAMES) ) (* ; "PUP allocation") (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE [PUTPROPS BINDPUPS MACRO (X (CONS (LIST 'LAMBDA (CAR X) (CONS 'PROGN (CDR X))) (in (CAR X) collect (LIST '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 ")")))) (* "END EXPORTED DEFINITIONS") (* ; "Pup routing") (DEFINEQ (\PUPGATELISTENER [LAMBDA NIL (* ; "Edited 15-Jan-88 03:00 by bvm") (PROG ((SOCKET (OPENPUPSOCKET \PUPSOCKET.ROUTING T)) (TIMER (SETUPTIMER 0)) PUP EVENT BASE) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION \ROUTINGTABLE.INFOHOOK)) (* ;  "For info, print our routing table") (PROCESSPROP (THIS.PROCESS) :PROTOCOL 'PUP) (SETQ EVENT (fetch PUPSOCEVENT of SOCKET)) LP (COND ((SETQ PUP (GETPUP SOCKET)) (\HANDLE.PUP.ROUTING.INFO PUP) (BLOCK)) ((EQ (AWAIT.EVENT EVENT (COND ((> \PUPROUTER.PROBECOUNT 0) \PUPROUTER.PROBETIMER) (T TIMER)) T) EVENT) (* ;  "Waiting for pup to arrive or timer to expire--pup arrived.") (GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE \PUP.ROUTING.TABLE) (SETUPTIMER \RT.AGEINTERVAL TIMER))) [COND ((AND (> \PUPROUTER.PROBECOUNT 0) (TIMEREXPIRED? \PUPROUTER.PROBETIMER)) (* ;  "Routing info desired. Broadcast a routing request on each directly-connected net") (SETUPPUP (SETQ PUP (ALLOCATE.PUP)) 0 \PUPSOCKET.ROUTING \PT.GATEWAYREQUEST NIL SOCKET) (SENDPUP SOCKET PUP) (SETUPTIMER \PUPROUTER.PROBEINTERVAL \PUPROUTER.PROBETIMER) (SETQ \PUPROUTER.PROBECOUNT (SUB1 \PUPROUTER.PROBECOUNT] (GO LP]) (\HANDLE.PUP.ROUTING.INFO [LAMBDA (PUP) (* ; "Edited 15-Jan-88 01:15 by bvm") (* ; "Processes a routing info PUP") [COND ((EQ (fetch PUPTYPE of PUP) \PT.GATEWAYRESPONSE) (* ;  "Unless we're a gateway, we only handle responses") (PROG ((HOST (fetch PUPSOURCEHOST of PUP)) (NDB (fetch EPNETWORK of PUP)) (LENGTH (FOLDLO (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN) BYTESPERWORD)) (BASE (fetch PUPCONTENTS of PUP)) (TABLE \PUP.ROUTING.TABLE) (MASK \ROUTING.TABLE.MASK) (RADIUS \PUP.ROUTING.TABLE.RADIUS) ENTRY NET HOPS OLDHOPS BUCKET NEWTIMER) [COND ((NEQ (fetch NETTYPE of NDB) 3) (* ;  "For PUP on 10mb net, get translated address") (OR (SETQ HOST (\TRANSLATE.3TO10 HOST NDB)) (RETURN] (SETQ \PUPROUTER.PROBECOUNT 0) (* ;  "We info from somewhere, so can stop probing") (while (>= LENGTH \PUP.ROUTINGINFO.WORDS) do (SETQ HOPS (ADD1 (fetch (PUPROUTINGINFO %#HOPS) of BASE))) (SETQ NET (fetch (PUPROUTINGINFO NET#) of BASE)) [COND ((OR [AND (SETQ BUCKET (\GETBASEPTR TABLE (UNFOLD (LOGAND NET MASK) WORDSPERCELL))) (when (EQ (fetch RTNET# of (SETQ ENTRY (CAR BUCKET))) NET) do (RETURN T) repeatwhile (SETQ BUCKET (CDR BUCKET] (COND ((<= HOPS RADIUS) [\ADD.ROUTING.TABLE.ENTRY TABLE (SETQ ENTRY (create ROUTING RTNET# _ NET RTTIMER _ (SETUPTIMER 0] T))) (* ;; "Have an entry for this net. Shall we accept the new info?") (COND ((EQ (SETQ OLDHOPS (fetch RTHOPCOUNT of ENTRY)) 0) (* ;  "Don't touch the directly connected net") ) ((COND ((AND (EQ NDB (fetch RTNDB of ENTRY)) (EQ HOST (fetch RTGATEWAY# of ENTRY))) (* ;;  "Same net and gateway, so we'll want to update the hop count") T) ((OR (NOT (fetch RTRECENT of ENTRY)) (< HOPS OLDHOPS)) (* ;; "Shorter route than we had, or the old route was getting out of date. Note we only smash these fields on this arm of the cond, since they're unchanged on the other arm. Smashing there would be slow, especially since NDB's tend to have overflowed ref counts. Also note OLDHOPS is NIL for brand new entry, which is why we check RECENT first.") (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) T)) (replace RTHOPCOUNT of ENTRY with HOPS) (COND ((< HOPS \RT.INFINITY) (* ;  "Hops at infinity means inaccessible, so don't encourage this entry to stick around.") (replace RTRECENT of ENTRY with T) (COND (NEWTIMER (* ;  "Save repeatedly calling the clock--everyone can get the same timer.") (\BLT (fetch RTTIMER of ENTRY) NEWTIMER WORDSPERCELL)) (T (SETQ NEWTIMER (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY] (SETQ LENGTH (- LENGTH \PUP.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \PUP.ROUTINGINFO.WORDS] (\RELEASE.ETHERPACKET PUP]) (\ROUTE.PUP [LAMBDA (PUP READONLY) (* bvm%: "15-Feb-85 22:21") (* ;; "Encapsulates PUP, choosing the right network and immediate destination host. Returns an NDB for the transmission. Defaults the pup source fields, unless READONLY is set") (PROG ((NET (fetch PUPDESTNET of PUP)) (HOST (fetch PUPDESTHOST of PUP)) PDH ROUTE NDB) (COND [(EQ NET 0) (COND ((NOT (SETQ NDB \LOCALNDBS)) (RETURN] ((SETQ ROUTE (\LOCATE.PUPNET NET)) (SETQ NDB (fetch RTNDB of ROUTE))) (T (RETURN))) [SETQ PDH (COND ((AND ROUTE (NEQ (fetch RTHOPCOUNT of ROUTE) 0)) (fetch RTGATEWAY# of ROUTE)) ((EQ (fetch NETTYPE of NDB) 3) HOST) ((EQ HOST 0) (* ; "Broadcast") BROADCASTNSHOSTNUMBER) ((\TRANSLATE.3TO10 HOST NDB)) (T (RETURN] (replace EPNETWORK of PUP with NDB) (ENCAPSULATE.ETHERPACKET NDB PUP PDH (fetch PUPLENGTH of PUP) (ffetch NDBPUPTYPE of NDB)) [COND ((NOT READONLY) [COND ((EQ NET 0) (replace PUPDESTNET of PUP with (fetch NDBPUPNET# of NDB] (replace PUPSOURCENET of PUP with (fetch NDBPUPNET# of NDB)) (COND ((EQ (fetch PUPSOURCEHOST of PUP) 0) (replace PUPSOURCEHOST of PUP with (fetch NDBPUPHOST# of NDB] (RETURN NDB]) (\LOCATE.PUPNET [LAMBDA (NET DONTPROBE) (* ; "Edited 29-Sep-89 10:28 by jds") (* ;; "Returning routing info entry for NET, or NIL if not in table. If not found, initiates a probe for the net, unless DONTPROBE is true.") (OR (SMALLP NET) (HELP "Bad network number" NET)) (OR \PUP.READY (ASSURE.PUP.READY)) (LET [(BUCKET (\GETBASEPTR \PUP.ROUTING.TABLE (UNFOLD (LOGAND NET \ROUTING.TABLE.MASK) WORDSPERCELL] (for DATA in BUCKET when [OR (EQL (fetch (ROUTING RTNET#) of DATA) NET) (AND (EQ 0 NET) (EQ 0 (fetch (ROUTING RTHOPCOUNT) of DATA] do (RETURN (AND (< (fetch RTHOPCOUNT of DATA) \RT.INFINITY) DATA)) finally (COND ((EQ 0 NET) (* ;  "Net is 0 -- the local net, so return a routing showing 0 hops to that net. ") (RETURN (create ROUTING RTNET# _ NET RTHOPCOUNT _ 0))) ((NOT DONTPROBE) (* ;  "Insert an entry for the net, to be purged in 30 sec if router process hasn't filled it by then") (\RPLPTR \PUP.ROUTING.TABLE (UNFOLD (LOGAND NET \ROUTING.TABLE.MASK) WORDSPERCELL) (CONS (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY RTTIMER _ (SETUPTIMER 72460Q)) BUCKET)) (SETQ \PUPROUTER.PROBECOUNT 5) (SETQ \PUPROUTER.PROBETIMER (SETUPTIMER 0 \PUPROUTER.PROBETIMER)) (WAKE.PROCESS '\PUPGATELISTENER) (BLOCK]) (SORT.PUPHOSTS.BY.DISTANCE [LAMBDA (HOSTLIST) (* bvm%: " 6-MAY-83 00:18") (COND ((NULL (CDR (LISTP HOSTLIST))) HOSTLIST) (T (* ;; "HOSTLIST is a list each of whose elements has a pup nethost in its CAR and anything in its CDR. In particular, standard pup PORT pairs work") [for PAIR in HOSTLIST do (\LOCATE.PUPNET (fetch PUPNET# of (CAR PAIR] (* ;  "Enter request for routing for all hosts") (BLOCK) (COND ((NOT (for PAIR in HOSTLIST always (\LOCATE.PUPNET (fetch PUPNET# of (CAR PAIR)) T))) (BLOCK \ETHERTIMEOUT))) (SORT HOSTLIST (FUNCTION \PUPNET.CLOSERP]) (\PUPNET.CLOSERP [LAMBDA (X Y) (* edited%: "12-APR-83 12:44") (PROG ((ROUTEX (\LOCATE.PUPNET (fetch PUPNET# of (CAR X)) T)) ROUTEY) (RETURN (COND ((NULL ROUTEX) NIL) ((SETQ ROUTEY (\LOCATE.PUPNET (fetch PUPNET# of (CAR Y)) T)) (ILESSP (fetch RTHOPCOUNT of ROUTEX) (fetch RTHOPCOUNT of ROUTEY))) (T T]) (PUPNET.DISTANCE [LAMBDA (NET#) (* bvm%: " 1-MAR-83 16:15") (PROG ((ROUTE (\LOCATE.PUPNET NET#))) [COND ((NULL ROUTE) (to 4 do (BLOCK \ETHERTIMEOUT) repeatuntil (SETQ ROUTE (\LOCATE.PUPNET NET#] (RETURN (COND (ROUTE (fetch RTHOPCOUNT of ROUTE]) ) (RPAQ? \PUP.ROUTING.TABLE (CONS)) (RPAQ? \PUP.ROUTING.TABLE.RADIUS 2) (RPAQ? \PUPROUTER.PROBECOUNT 0) (RPAQ? \PUPROUTER.PROBETIMER ) (RPAQ? \PUPROUTER.PROBEINTERVAL 5670Q) (RPAQ? \PUP.READY ) (RPAQ? \PUP.READY.EVENT (CREATE.EVENT "Pup Ready")) (RPAQ? \PUP.READY.LOCK (CREATE.MONITORLOCK "Pup Ready")) (ADDTOVAR \SYSTEMCACHEVARS \PUP.READY) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD PUPROUTINGINFO ( (* ;  "Format of each entry in a pup routing info packet. We only actually use NET# and #HOPS") (NET# BYTE) (GATENET# BYTE) (GATEHOST# BYTE) (%#HOPS BYTE))) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUP.ROUTINGINFO.WORDS 2) (CONSTANTS \PUP.ROUTINGINFO.WORDS) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PUP.ROUTING.TABLE \PUP.ROUTING.TABLE.RADIUS \PUPROUTER.PROBECOUNT \PUPROUTER.PROBETIMER \PUPROUTER.PROBEINTERVAL \PUP.READY \PUP.READY.EVENT \PUP.READY.LOCK) ) ) (* ; "Sockets") (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE PUPSOCKET ((NIL BITS 4) (PUPSOCLINK POINTER) (* ; "So that we can Queue them") (PSOCKET# FIXP) (INQUEUE POINTER) (INQUEUELENGTH WORD) (PUPSOC#ALLOCATION WORD) (PUPSOCHANDLE WORD) (* ; "Back-fitting for Bcpl") (PUPSOCPUPADDRESS WORD) (* ; "Local net/host") (NIL BITS 4) (PUPSOCEVENT POINTER) (* ;  "Event that is notified when a pup arrives on this socket") (NIL BITS 4) (NIL POINTER)) (BLOCKRECORD PUPSOCKET ((NIL BITS 4) (NIL POINTER) (PSOCKETHI WORD) (PSOCKETLO WORD))) INQUEUE _ (create SYSQUEUE) PUPSOC#ALLOCATION _ \MAX.EPKTS.ON.PUPSOCKET) ) (/DECLAREDATATYPE 'PUPSOCKET '((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER) '((PUPSOCKET 0 (BITS . 3)) (PUPSOCKET 0 POINTER) (PUPSOCKET 2 FIXP) (PUPSOCKET 4 POINTER) (PUPSOCKET 6 (BITS . 17Q)) (PUPSOCKET 7 (BITS . 17Q)) (PUPSOCKET 10Q (BITS . 17Q)) (PUPSOCKET 11Q (BITS . 17Q)) (PUPSOCKET 4 (BITS . 3)) (PUPSOCKET 12Q POINTER) (PUPSOCKET 12Q (BITS . 3)) (PUPSOCKET 14Q POINTER)) '16Q) (DECLARE%: EVAL@COMPILE [PUTPROPS \PUPSOCKET.FROM# MACRO (OPENLAMBDA (SOCHI SOCLO) (for SOC in \PUPSOCKETS when (AND (EQ (fetch PSOCKETLO of SOC) SOCLO) (EQ (fetch PSOCKETHI of SOC) SOCHI)) do (RETURN SOC] ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PUPSOCKETS.TABLE \MAX.EPKTS.ON.PUPSOCKET \PUP.CHECKSUMFLG) ) ) (/DECLAREDATATYPE 'PUPSOCKET '((BITS 4) POINTER FIXP POINTER WORD WORD WORD WORD (BITS 4) POINTER (BITS 4) POINTER) '((PUPSOCKET 0 (BITS . 3)) (PUPSOCKET 0 POINTER) (PUPSOCKET 2 FIXP) (PUPSOCKET 4 POINTER) (PUPSOCKET 6 (BITS . 17Q)) (PUPSOCKET 7 (BITS . 17Q)) (PUPSOCKET 10Q (BITS . 17Q)) (PUPSOCKET 11Q (BITS . 17Q)) (PUPSOCKET 4 (BITS . 3)) (PUPSOCKET 12Q POINTER) (PUPSOCKET 12Q (BITS . 3)) (PUPSOCKET 14Q POINTER)) '16Q) (ADDTOVAR SYSTEMRECLST (DATATYPE PUPSOCKET ((NIL BITS 4) (PUPSOCLINK POINTER) (PSOCKET# FIXP) (INQUEUE POINTER) (INQUEUELENGTH WORD) (PUPSOC#ALLOCATION WORD) (PUPSOCHANDLE WORD) (PUPSOCPUPADDRESS WORD) (NIL BITS 4) (PUPSOCEVENT POINTER) (NIL BITS 4) (NIL POINTER))) ) (DEFINEQ (OPENPUPSOCKET [LAMBDA (SKT# IFCLASH) (* bvm%: "21-JUL-83 10:36") (* ;; "Creates a new local PUPSOCKET If SKT# is supplied, it is the identifying number (32-bit) of the socket, and an error occurs if that socket is already in use.") (PROG ((ID#EXPLICIT? (FIXP SKT#)) PUPSOC CLASHP SOCHI SOCLO) [COND [(type? PUPSOCKET SKT#) (SETQ PUPSOC SKT#) (\FLUSHPUPSOCQUEUE PUPSOC) (COND ((NEQ PUPSOC (\PUPSOCKET.FROM# (fetch PSOCKETHI of PUPSOC) (fetch PSOCKETLO of PUPSOC))) (ERROR PUPSOC "Attempt to re-open a released PUPSOCKET."] (T (COND (ID#EXPLICIT? (SETQ SOCHI (\HINUM SKT#)) (SETQ SOCLO (\LONUM SKT#))) (T (* ;  "Pick a socket that is reasonably random but won't conflict with well-known sockets") [SETQ SOCLO (LOGOR 100000Q (\LONUM (DAYTIME] (SETQ SOCHI 1))) (UNINTERRUPTABLY [do (COND ((NOT (SETQ CLASHP (\PUPSOCKET.FROM# SOCHI SOCLO))) (SETQ PUPSOC (create PUPSOCKET PSOCKETHI _ SOCHI PSOCKETLO _ SOCLO)) (replace PUPSOCEVENT of PUPSOC with (CREATE.EVENT PUPSOC) ) (push \PUPSOCKETS PUPSOC) (RETURN)) [(NOT ID#EXPLICIT?) (SETQ SOCLO (LOGOR 100000Q (ADD1 (LOGAND SOCLO 77777Q] (T (RETURN]) (COND (CLASHP (SELECTQ IFCLASH ((T ACCEPT) (\FLUSHPUPSOCQUEUE (SETQ PUPSOC CLASHP))) ((DON'T FAIL) (RETURN NIL)) (ERROR "Socket number is already in use" SKT#] (RETURN PUPSOC]) (CLOSEPUPSOCKET [LAMBDA (PUPSOC NOERRORFLG) (* bvm%: " 5-MAY-83 23:58") (* ;; "Closes a local PUPSOCKET -- argument = T means close all sockets") (COND ((EQ PUPSOC T) (while \PUPSOCKETS do (\FLUSHPUPSOCQUEUE (SETQ PUPSOC (pop \PUPSOCKETS))) (replace PUPSOCEVENT of PUPSOC with NIL))) (T (\FLUSHPUPSOCQUEUE (\DTEST PUPSOC 'PUPSOCKET)) (PROG1 (COND ((FMEMB PUPSOC \PUPSOCKETS) (SETQ \PUPSOCKETS (DREMOVE PUPSOC \PUPSOCKETS)) T) ((NOT NOERRORFLG) (ERROR PUPSOC "not an open PUP socket"))) (replace PUPSOCEVENT of PUPSOC with NIL]) (PUPSOCKETNUMBER [LAMBDA (PUPSOC) (* bvm%: "14-FEB-83 15:21") (fetch PSOCKET# of PUPSOC]) (PUPSOCKETFROMNUMBER [LAMBDA (SOC#orSOCLO SOCHI) (* bvm%: "21-JUL-83 11:39") [COND ((NULL SOCHI) (SETQ SOCHI (\HINUM SOC#orSOCLO)) (SETQ SOC#orSOCLO (LOGAND SOC#orSOCLO 177777Q] (\PUPSOCKET.FROM# SOCHI SOC#orSOCLO]) (PUPSOCKETEVENT [LAMBDA (PUPSOC) (* bvm%: "10-MAY-83 22:32") (ffetch PUPSOCEVENT of (\DTEST PUPSOC 'PUPSOCKET]) (\FLUSHPUPSOCQUEUE [LAMBDA (PUPSOC) (* bvm%: "11-FEB-83 12:55") (\FLUSH.PACKET.QUEUE (fetch (PUPSOCKET INQUEUE) of PUPSOC)) (replace (PUPSOCKET INQUEUELENGTH) of PUPSOC with 0) PUPSOC]) ) (DEFINEQ (\GETMISCSOCKET [LAMBDA NIL (* bvm%: "14-FEB-83 15:29") (* ;; "Opens a socket for miscellaneous services, if we don't have it open yet") (COND ((AND \MISC.SOCKET (FMEMB \MISC.SOCKET \PUPSOCKETS)) \MISC.SOCKET) (T (SETQ \MISC.SOCKET (OPENPUPSOCKET]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \MISC.SOCKET \PUPSOCKETS) ) (RPAQ? \MISC.SOCKET ) (RPAQ? \PUPSOCKETS ) (DECLARE%: DONTCOPY (* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE (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 12Q WORD) (* ; "Copy of pup header") (ERRORPUPCODE WORD) (ERRORPUPARG WORD) (* ; "Usually zero") (ERRORPUPSTRINGBASE WORD) (* ; "Human readable message") ))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \ETHERWAIT1 \ETHERTIMEOUT \MAXETHERTRIES PUPTRACEFLG LOGINPASSWORDS) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PUPTRACEFILE PUPONLYTYPES PUPIGNORETYPES PUPPRINTMACROS) ) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPOVLEN 26Q) (RPAQQ \MAX.PUPLENGTH 1024Q) (RPAQQ \TIME.GETPUP 5) (CONSTANTS (\PUPOVLEN 26Q) (\MAX.PUPLENGTH 1024Q) (\TIME.GETPUP 5)) ) (PUTPROPS PUPPRINTMACROS VARTYPE ALIST) (DECLARE%: EVAL@COMPILE (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 10Q) (\PT.ABORT 11Q) (\PT.END 12Q) (\PT.ENDREPLY 13Q) (\PT.DATA 20Q) (\PT.ADATA 21Q) (\PT.ACK 22Q) (\PT.MARK 23Q) (\PT.INTERRUPT 24Q) (\PT.INTERRUPTREPLY 25Q) (\PT.AMARK 26Q) (\PT.GATEWAYREQUEST 200Q) (\PT.GATEWAYRESPONSE 201Q) (\PT.ALTOTIMEREQUEST 206Q) (\PT.ALTOTIMERESPONSE 207Q) (\PT.MSGCHECK 210Q) (\PT.NEWMAIL 211Q) (\PT.NONEWMAIL 212Q) (\PT.NOMAILBOX 213Q) (\PT.LAURELCHECK 214Q) (\PT.NAMELOOKUP 220Q) (\PT.NAMERESPONSE 221Q) (\PT.NAME/ADDRERROR 222Q) (\PT.ADDRLOOKUP 223Q) (\PT.ADDRRESPONSE 224Q) (\PT.PRINTERSTATUS 200Q) (\PT.STATUSRESPONSE 201Q) (\PT.PRINTERCAPABILITY 202Q) (\PT.CAPABILITYRESPONSE 203Q) (\PT.PRINTJOBSTATUS 204Q) (\PT.PRINTJOBRESPONSE 205Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \PT.ECHOME 1) (RPAQQ \PT.IAMECHO 2) (RPAQQ \PT.IAMBADECHO 3) (RPAQQ \PT.ERROR 4) (RPAQQ \PT.RFC 10Q) (RPAQQ \PT.ABORT 11Q) (RPAQQ \PT.END 12Q) (RPAQQ \PT.ENDREPLY 13Q) (RPAQQ \PT.DATA 20Q) (RPAQQ \PT.ADATA 21Q) (RPAQQ \PT.ACK 22Q) (RPAQQ \PT.MARK 23Q) (RPAQQ \PT.INTERRUPT 24Q) (RPAQQ \PT.INTERRUPTREPLY 25Q) (RPAQQ \PT.AMARK 26Q) (RPAQQ \PT.GATEWAYREQUEST 200Q) (RPAQQ \PT.GATEWAYRESPONSE 201Q) (RPAQQ \PT.ALTOTIMEREQUEST 206Q) (RPAQQ \PT.ALTOTIMERESPONSE 207Q) (RPAQQ \PT.MSGCHECK 210Q) (RPAQQ \PT.NEWMAIL 211Q) (RPAQQ \PT.NONEWMAIL 212Q) (RPAQQ \PT.NOMAILBOX 213Q) (RPAQQ \PT.LAURELCHECK 214Q) (RPAQQ \PT.NAMELOOKUP 220Q) (RPAQQ \PT.NAMERESPONSE 221Q) (RPAQQ \PT.NAME/ADDRERROR 222Q) (RPAQQ \PT.ADDRLOOKUP 223Q) (RPAQQ \PT.ADDRRESPONSE 224Q) (RPAQQ \PT.PRINTERSTATUS 200Q) (RPAQQ \PT.STATUSRESPONSE 201Q) (RPAQQ \PT.PRINTERCAPABILITY 202Q) (RPAQQ \PT.CAPABILITYRESPONSE 203Q) (RPAQQ \PT.PRINTJOBSTATUS 204Q) (RPAQQ \PT.PRINTJOBRESPONSE 205Q) (CONSTANTS (\PT.ECHOME 1) (\PT.IAMECHO 2) (\PT.IAMBADECHO 3) (\PT.ERROR 4) (\PT.RFC 10Q) (\PT.ABORT 11Q) (\PT.END 12Q) (\PT.ENDREPLY 13Q) (\PT.DATA 20Q) (\PT.ADATA 21Q) (\PT.ACK 22Q) (\PT.MARK 23Q) (\PT.INTERRUPT 24Q) (\PT.INTERRUPTREPLY 25Q) (\PT.AMARK 26Q) (\PT.GATEWAYREQUEST 200Q) (\PT.GATEWAYRESPONSE 201Q) (\PT.ALTOTIMEREQUEST 206Q) (\PT.ALTOTIMERESPONSE 207Q) (\PT.MSGCHECK 210Q) (\PT.NEWMAIL 211Q) (\PT.NONEWMAIL 212Q) (\PT.NOMAILBOX 213Q) (\PT.LAURELCHECK 214Q) (\PT.NAMELOOKUP 220Q) (\PT.NAMERESPONSE 221Q) (\PT.NAME/ADDRERROR 222Q) (\PT.ADDRLOOKUP 223Q) (\PT.ADDRRESPONSE 224Q) (\PT.PRINTERSTATUS 200Q) (\PT.STATUSRESPONSE 201Q) (\PT.PRINTERCAPABILITY 202Q) (\PT.CAPABILITYRESPONSE 203Q) (\PT.PRINTJOBSTATUS 204Q) (\PT.PRINTJOBRESPONSE 205Q)) ) (RPAQ? PUPTYPES RAWPUPTYPES) (RPAQQ WELLKNOWNPUPSOCKETS ((\PUPSOCKET.TELNET 1) (\PUPSOCKET.ROUTING 2) (\PUPSOCKET.FTP 3) (\PUPSOCKET.MISCSERVICES 4) (\PUPSOCKET.ECHO 5) (\PUPSOCKET.EFTP 20Q) (\PUPSOCKET.PRINTERSTATUS 21Q) (\PUPSOCKET.LEAF 43Q))) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPSOCKET.TELNET 1) (RPAQQ \PUPSOCKET.ROUTING 2) (RPAQQ \PUPSOCKET.FTP 3) (RPAQQ \PUPSOCKET.MISCSERVICES 4) (RPAQQ \PUPSOCKET.ECHO 5) (RPAQQ \PUPSOCKET.EFTP 20Q) (RPAQQ \PUPSOCKET.PRINTERSTATUS 21Q) (RPAQQ \PUPSOCKET.LEAF 43Q) (CONSTANTS (\PUPSOCKET.TELNET 1) (\PUPSOCKET.ROUTING 2) (\PUPSOCKET.FTP 3) (\PUPSOCKET.MISCSERVICES 4) (\PUPSOCKET.ECHO 5) (\PUPSOCKET.EFTP 20Q) (\PUPSOCKET.PRINTERSTATUS 21Q) (\PUPSOCKET.LEAF 43Q)) ) (* "END EXPORTED DEFINITIONS") (RPAQQ PUPCONSTANTS ((\PUPHEADERLEN 24Q) (\NetMask 177400Q) (\HILOCALSOCKET 1) (\PORTIDLEN 3))) (DECLARE%: EVAL@COMPILE (RPAQQ \PUPHEADERLEN 24Q) (RPAQQ \NetMask 177400Q) (RPAQQ \HILOCALSOCKET 1) (RPAQQ \PORTIDLEN 3) (CONSTANTS (\PUPHEADERLEN 24Q) (\NetMask 177400Q) (\HILOCALSOCKET 1) (\PORTIDLEN 3)) ) (DECLARE%: EVAL@COMPILE [PUTPROPS PUPDEBUGGING MACRO ((X . Y) (COND (PUPTRACEFLG (printout PUPTRACEFILE X . Y] ) (ADDTOVAR PUPPRINTMACROS (210Q CHARS) (214Q CHARS) (211Q CHARS) (213Q CHARS) (201Q WORDS 2 CHARS 24Q |...|) (30Q CHARS)) (DECLARE%: EVAL@COMPILE (BLOCKRECORD TIMEPUPCONTENTS ((TIMEPUPVALUEHI WORD) (TIMEPUPVALUELO WORD) (TIMEPUPEASTP FLAG) (TIMEPUPHOURS BITS 7) (TIMEPUPMINUTES BITS 10Q) (TIMEPUPBEGINDST WORD) (TIMEPUPENDDST WORD)) (* ; "format of alto time response") ) ) ) (* ; "echo utilities") (DEFINEQ (PUP.ECHOSERVER [LAMBDA (ECHOWINDOW FLG) (* bvm%: " 7-AUG-83 01:11") (RESETLST (PROG ((SOC (OPENPUPSOCKET \PUPSOCKET.ECHO T)) PUP EVENT ISGOOD) (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC)) (OR FLG (SETQ FLG 'PEEK)) (SETQ EVENT (fetch PUPSOCEVENT of SOC)) LP (COND ((SETQ PUP (GETPUP SOC)) (SETQ ISGOOD (EQ (fetch PUPTYPE of PUP) \PT.ECHOME)) [COND (ECHOWINDOW (SELECTQ FLG (NIL) (PEEK (PRIN1 (COND (ISGOOD '!) (T '?)) ECHOWINDOW)) (PRINTPUP PUP NIL ECHOWINDOW] (COND (ISGOOD (replace TYPEWORD of PUP with \PT.IAMECHO) (SWAPPUPPORTS PUP) (replace EPREQUEUE of PUP with 'FREE) (SENDPUP SOC PUP)) (T (RELEASE.PUP PUP))) (BLOCK)) (T (AWAIT.EVENT EVENT))) (GO LP)))]) (PUP.ECHOUSER [LAMBDA (HOST ECHOSTREAM INTERVAL NTIMES) (* bvm%: " 1-NOV-83 15:31") (RESETLST [PROG ((OPUP (ALLOCATE.PUP)) (PORT (BESTPUPADDRESS HOST (OR ECHOSTREAM PROMPTWINDOW))) (SOC (OPENPUPSOCKET)) (TIMER (SETUPTIMER 0)) IPUP EVENT ECHOPUPLENGTH I) (RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC)) (OR PORT (RETURN)) (OR INTERVAL (SETQ INTERVAL 1750Q)) (OR NTIMES (SETQ NTIMES 1750Q)) (SETQ ECHOSTREAM (GETSTREAM (OR ECHOSTREAM T) 'OUTPUT)) (SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T) (PUTPUPWORD OPUP 0 (SETQ I 1)) (add (fetch PUPLENGTH of OPUP) BYTESPERWORD) (PUTPUPSTRING OPUP "Random string for echo") (SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP)) (SETQ EVENT (fetch PUPSOCEVENT of SOC)) LP (SENDPUP SOC OPUP) (PRIN1 '! ECHOSTREAM) (SETUPTIMER INTERVAL TIMER) (do (COND [(SETQ IPUP (GETPUP SOC)) (COND ((PROG1 (SELECTC (fetch PUPTYPE of IPUP) (\PT.IAMBADECHO (PRIN1 'x ECHOSTREAM)) (\PT.IAMECHO (COND ((NOT (AND (EQ (fetch PUPIDHI of IPUP) (fetch PUPIDHI of OPUP)) (EQ (fetch PUPIDLO of IPUP) (fetch PUPIDLO of OPUP)) (EQ (fetch PUPLENGTH of IPUP) ECHOPUPLENGTH))) (PRIN1 '? ECHOSTREAM) NIL) ((IEQP (GETPUPWORD IPUP 0) I) (PRIN1 '+ ECHOSTREAM)) (T (PRIN1 "(late)" ECHOSTREAM) NIL))) (\PT.ERROR (PRINTERRORPUP IPUP ECHOSTREAM) NIL) (PROGN (PRIN1 '? ECHOSTREAM) NIL)) (RELEASE.PUP IPUP)) (RETURN] (T (AWAIT.EVENT EVENT TIMER T))) repeatuntil (TIMEREXPIRED? TIMER) finally (COND ((fetch EPTRANSMITTING of OPUP) (PRIN1 "[not yet transmitted; maybe transmitter is off]" ECHOSTREAM) )) (PRIN1 '%. ECHOSTREAM)) (COND ((IGREATERP (OR (EQ NTIMES T) (add NTIMES -1)) 0) (PUTPUPWORD OPUP 0 (add I 1)) (GO LP])]) ) (* ; "Peeking") (DEFINEQ (\PEEKPUP [LAMBDA (HOST FILE) (* bvm%: " 1-NOV-83 15:32") (PROG (NETHOST L) [COND ((NULL HOST) (SELECTQ (fetch NETTYPE of \LOCALNDBS) (3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC) 0 (fetch NDBPUPHOST# of \LOCALNDBS))) (12Q) NIL) (RPTQ 24Q (BLOCK)) (* ; "empty the pipe") (SETQ \PEEKPUPNUMBER)) (T [COND ((EQ HOST T) (SETQ \PEEKPUPNUMBER T)) (T [SETQ L (for H inside HOST collect (PROGN (SETQ NETHOST (CAR (BESTPUPADDRESS H PROMPTWINDOW))) (COND ([AND NETHOST (OR (EQ (fetch PUPNET# of NETHOST ) 0) (EQ (fetch PUPNET# of NETHOST ) (\LOCALPUPNETNUMBER] (fetch PUPHOST# of NETHOST)) (T (ERROR H "not a host on local network"] (SETQ \PEEKPUPNUMBER (COND ((CDR L) L) (T (CAR L] (* ; "Now make us promiscuous") (SELECTQ (fetch NETTYPE of \LOCALNDBS) (3 (\PUTBASE (EMADDRESS \ETHERHOSTLOC) 0 0)) (12Q) NIL) [COND (FILE (SETQ PUPTRACEFILE (OR (OPENP FILE 'OUTPUT) (OPENFILE FILE 'OUTPUT] (OR PUPTRACEFLG (SETQ PUPTRACEFLG T] (RETURN \PEEKPUPNUMBER]) (\MAYBEPEEKPUP [LAMBDA (PUP) (* bvm%: " 5-Jan-85 23:39") [COND ((AND \PEEKPUPNUMBER PUPTRACEFLG) (PROG (DIRECTION) (COND ([OR (EQ \PEEKPUPNUMBER T) (EQ (fetch PUPDESTHOST of PUP) 0) (for HOST inside \PEEKPUPNUMBER thereis (OR [COND ((EQ (fetch PUPSOURCEHOST of PUP) HOST) (SETQ DIRECTION 'PUT] (COND ((EQ (fetch PUPDESTHOST of PUP) HOST) (SETQ DIRECTION 'GET] (PRINTPUP PUP DIRECTION PUPTRACEFILE NIL T] (\RELEASE.ETHERPACKET PUP]) ) (RPAQ? \PEEKPUPNUMBER ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (RPAQQ \ETHERHOSTLOC 610Q) (CONSTANTS \ETHERHOSTLOC) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \PEEKPUPNUMBER) ) ) (* ; "Debugging assistance") (DEFINEQ (PRINTPUP [LAMBDA (PACKET CALLER FILE PRE.NOTE DOFILTER) (* bvm%: " 5-Jan-85 23:40") (\DTEST PACKET 'ETHERPACKET) (OR FILE (SETQ FILE PUPTRACEFILE)) (PROG ((TYPE (fetch PUPTYPE of PACKET)) MACRO LENGTH) (COND ([AND DOFILTER (COND (PUPONLYTYPES (NOT (FMEMB TYPE PUPONLYTYPES))) (PUPIGNORETYPES (FMEMB TYPE PUPIGNORETYPES] (PRIN1 (SELECTQ CALLER ((GET RAWGET) (COND ((EQ (fetch PUPDESTHOST of PACKET) 0) (* ; "Broadcast") '*) (T '+))) ((PUT RAWPUT) '!) '?) PUPTRACEFILE) (RETURN))) (AND PRE.NOTE (PRIN1 PRE.NOTE FILE)) (PRINTPUPROUTE PACKET CALLER FILE) [COND ((SETQ MACRO (CDR (FASSOC TYPE PUPPRINTMACROS))) (COND ((NLISTP MACRO) (RETURN (RESETFORM (OUTPUT FILE) (APPLY* MACRO PACKET FILE] (printout FILE "Length = " .P2 (SETQ LENGTH (fetch PUPLENGTH of PACKET)) " bytes" " (header + " .P2 (IDIFFERENCE LENGTH \PUPOVLEN) ")" T "Type = ") (PRINTCONSTANT TYPE PUPTYPES FILE "\PT.") (printout FILE ", ID = " .P2 (fetch PUPID of PACKET) T) (COND ((IGREATERP LENGTH \PUPOVLEN) (* ;  "Tells how to print data. Consists of elements in pairs: a byte offset followed by a type") (PRIN1 "Contents: " FILE) (PRINTPACKETDATA (fetch PUPCONTENTS of PACKET) 0 (OR MACRO '(BYTES 14Q |...|)) (IDIFFERENCE LENGTH \PUPOVLEN) FILE))) (TERPRI FILE)) PACKET]) (PRINTPUPROUTE [LAMBDA (PACKET CALLER FILE) (* bvm%: "26-OCT-83 15:33") (TAB 0 0 FILE) (AND CALLER (printout FILE CALLER ": ")) (PROG ((CONTROL (fetch PUPTCONTROL of PACKET)) CSECS) (printout FILE "From " (PORTSTRING (fetch PUPSOURCE of PACKET) (fetch PUPSOURCESOCKET of PACKET)) " to " (PORTSTRING (fetch PUPDEST of PACKET) (fetch PUPDESTSOCKET of PACKET))) [COND ((NEQ CONTROL 0) (printout FILE ", Hops = " .P2 (LRSH CONTROL 4] (COND (PUPTRACETIME (printout FILE " [" .I4 (IQUOTIENT (SETQ CSECS (\CENTICLOCK PACKET)) 144Q) '%. .I2..T (IREMAINDER CSECS 144Q) "]"))) (TERPRI FILE]) (PRINTPUPDATA [LAMBDA (PUP MACRO OFFSET FILE) (* bvm%: "26-MAY-83 12:13") (PRINTPACKETDATA (fetch PUPCONTENTS of PUP) OFFSET MACRO (IDIFFERENCE (fetch PUPLENGTH of PUP) \PUPOVLEN) FILE]) (PRINTERRORPUP [LAMBDA (PUP FILE) (* bvm%: "12-FEB-83 16:24") (printout FILE "From " (PORTSTRING (fetch PUPSOURCE of PUP)) ": [Error " .P2 (fetch ERRORPUPCODE of PUP) "] " (GETPUPSTRING PUP 30Q) T]) (PUPTRACE [LAMBDA (FLG REGION) (* ; "Edited 14-Jan-88 18:06 by bvm") (MAKE-NETWORK-TRACE-WINDOW 'PUPTRACEFLG 'PUPTRACEFILE "Pup traffic" REGION FLG]) (PRINTCONSTANT [LAMBDA (VAR CONSTANTLIST FILE PREFIX) (* bvm%: " 4-APR-83 16:11") (PRIN2 VAR FILE) (COND ((LISTP CONSTANTLIST) (PRIN1 " (" FILE) (PRIN1 (OR [for X in CONSTANTLIST when (EQ (CADR X) VAR) do (RETURN (COND [(AND PREFIX (STRPOS PREFIX (CAR X) 1 NIL T)) (SUBSTRING (CAR X) (ADD1 (NCHARS PREFIX] (T (CAR X] '?) FILE) (PRIN1 ")" FILE]) ) (RPAQ? PUPTRACEFLG ) (RPAQ? PUPTRACEFILE T) (RPAQ? PUPTRACETIME ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PUPTRACETIME) ) (ADDTOVAR PUPPRINTMACROS ) (ADDTOVAR PUPONLYTYPES ) (ADDTOVAR PUPIGNORETYPES ) (ADDTOVAR PUPPRINTMACROS (4 . PRINTERRORPUP) (220Q CHARS) (221Q REPEAT BYTES -2 WORDS -4) (223Q BYTES -2 WORDS) (224Q CHARS)) (DECLARE%: DONTEVAL@LOAD (\PUPINIT) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (FILESLOAD (LOADCOMP) LLETHER) ) (PUTPROPS PUP MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q)) (PUTPROPS PUP FILETYPE CL:COMPILE-FILE) (PUTPROPS PUP COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3705Q 3706Q 3707Q 3710Q 3711Q)) (DECLARE%: DONTCOPY (FILEMAP (NIL (30620Q 64575Q (\STARTPUP 30632Q . 31504Q) (ASSURE.PUP.READY 31506Q . 37601Q) ( \FIND.LOCALPUPHOSTNUMBER 37603Q . 42001Q) (\PROMPT.FOR.PUP.NUMBER 42003Q . 44023Q) (\HANDLE.RAW.PUP 44025Q . 62125Q) (\FORWARD.PUP 62127Q . 63047Q) (\SETPUPCHECKSUM 63051Q . 64573Q)) (72106Q 77200Q ( \PUPERROR 72120Q . 77176Q)) (77237Q 116373Q (SETUPPUP 77251Q . 102437Q) (SWAPPUPPORTS 102441Q . 103256Q) (GETPUP 103260Q . 106172Q) (SENDPUP 106174Q . 112016Q) (EXCHANGEPUPS 112020Q . 114056Q) ( DISCARDPUPS 114060Q . 114664Q) (GETPUPWORD 114666Q . 115205Q) (\PUPINIT 115207Q . 116371Q)) (116374Q 164121Q (ETHERHOSTNAME 116406Q . 125534Q) (ETHERHOSTNUMBER 125536Q . 126151Q) (ETHERPORT 126153Q . 131672Q) (BESTPUPADDRESS 131674Q . 141734Q) (NETDAYTIME0 141736Q . 142267Q) (\PUP.SETTIME 142271Q . 147063Q) (\SETNEWTIME0 147065Q . 150145Q) (\NET.SETTIME 150147Q . 151236Q) (NETDATE 151240Q . 151575Q) (\LOOKUPPORT 151577Q . 157436Q) (\PARSE.PORTCONSTANT 157440Q . 162550Q) (\FIXLOCALNET 162552Q . 164117Q)) (164122Q 165457Q (PORTSTRING 164134Q . 165123Q) (OCTALSTRING 165125Q . 165455Q)) (166051Q 175162Q (CLEARPUP 166063Q . 170576Q) (PUTPUPWORD 170600Q . 171125Q) (GETPUPBYTE 171127Q . 171452Q) ( PUTPUPBYTE 171454Q . 172005Q) (GETPUPSTRING 172007Q . 173440Q) (GETPUPSTREAM 173442Q . 174371Q) ( PUTPUPSTRING 174373Q . 175160Q)) (177265Q 205104Q (READPLIST 177277Q . 205102Q)) (205265Q 213311Q ( CANONICAL.HOSTNAME 205277Q . 210121Q) (\CANONICAL.HOSTNAME 210123Q . 211170Q) ( \CANONICALIZE.PUP.HOSTNAME 211172Q . 213307Q)) (216177Q 251404Q (\PUPGATELISTENER 216211Q . 222042Q) ( \HANDLE.PUP.ROUTING.INFO 222044Q . 234403Q) (\ROUTE.PUP 234405Q . 240240Q) (\LOCATE.PUPNET 240242Q . 244777Q) (SORT.PUPHOSTS.BY.DISTANCE 245001Q . 247255Q) (\PUPNET.CLOSERP 247257Q . 250440Q) ( PUPNET.DISTANCE 250442Q . 251402Q)) (263001Q 272753Q (OPENPUPSOCKET 263013Q . 267474Q) (CLOSEPUPSOCKET 267476Q . 271155Q) (PUPSOCKETNUMBER 271157Q . 271410Q) (PUPSOCKETFROMNUMBER 271412Q . 272051Q) ( PUPSOCKETEVENT 272053Q . 272332Q) (\FLUSHPUPSOCQUEUE 272334Q . 272751Q)) (272754Q 273521Q ( \GETMISCSOCKET 272766Q . 273517Q)) (314367Q 327157Q (PUP.ECHOSERVER 314401Q . 317206Q) (PUP.ECHOUSER 317210Q . 327155Q)) (327210Q 336341Q (\PEEKPUP 327222Q . 334353Q) (\MAYBEPEEKPUP 334355Q . 336337Q)) ( 336742Q 350177Q (PRINTPUP 336754Q . 343124Q) (PRINTPUPROUTE 343126Q . 345073Q) (PRINTPUPDATA 345075Q . 345545Q) (PRINTERRORPUP 345547Q . 346247Q) (PUPTRACE 346251Q . 346562Q) (PRINTCONSTANT 346564Q . 350175Q))))) STOP \ No newline at end of file diff --git a/sources/READ-PRINT-PROFILE b/sources/READ-PRINT-PROFILE new file mode 100644 index 00000000..dadc2827 --- /dev/null +++ b/sources/READ-PRINT-PROFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "XCL") (IL:FILECREATED "16-May-90 21:23:08" IL:{DSK}local>lde>lispcore>sources>READ-PRINT-PROFILE.;2 12400 IL:changes IL:to%: (IL:VARS IL:READ-PRINT-PROFILECOMS) IL:previous IL:date%: "13-Nov-86 11:37:11" IL:{DSK}local>lde>lispcore>sources>READ-PRINT-PROFILE.;1) (IL:* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:READ-PRINT-PROFILECOMS) (IL:RPAQQ IL:READ-PRINT-PROFILECOMS ((IL:P (EXPORT '(MAKE-READ-PRINT-PROFILE COPY-READ-PRINT-PROFILE READ-PRINT-PROFILE-P READ-PRINT-PROFILE-READTABLE READ-PRINT-PROFILE-READ-BASE READ-PRINT-PROFILE-READ-SUPPRESS READ-PRINT-PROFILE-PACKAGE READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT READ-PRINT-PROFILE-PRINT-ESCAPE READ-PRINT-PROFILE-PRINT-PRETTY READ-PRINT-PROFILE-PRINT-CIRCLE READ-PRINT-PROFILE-PRINT-BASE READ-PRINT-PROFILE-PRINT-RADIX READ-PRINT-PROFILE-PRINT-CASE READ-PRINT-PROFILE-PRINT-GENSYM READ-PRINT-PROFILE-PRINT-LEVEL READ-PRINT-PROFILE-PRINT-LENGTH READ-PRINT-PROFILE-PRINT-ARRAY READ-PRINT-PROFILE-PRINT-STRUCTURE RESTORE-READ-PRINT-PROFILE SAVE-READ-PRINT-PROFILE WITH-READ-PRINT-PROFILE *DEFAULT-READ-PRINT-PROFILE* FIND-READ-PRINT-PROFILE LIST-ALL-READ-PRINT-PROFILE-NAMES) "XCL")) (IL:STRUCTURES READ-PRINT-PROFILE) (IL:FUNCTIONS MAKE-READ-PRINT-PROFILE RESTORE-READ-PRINT-PROFILE SAVE-READ-PRINT-PROFILE WITH-READ-PRINT-PROFILE FIND-READ-PRINT-PROFILE SETF-FIND-READ-PRINT-PROFILE LIST-ALL-READ-PRINT-PROFILE-NAMES) (IL:SETFS FIND-READ-PRINT-PROFILE) (IL:VARIABLES *READ-PRINT-PROFILES* *DEFAULT-READ-PRINT-PROFILE*) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:READ-PRINT-PROFILE))) (EXPORT '(MAKE-READ-PRINT-PROFILE COPY-READ-PRINT-PROFILE READ-PRINT-PROFILE-P READ-PRINT-PROFILE-READTABLE READ-PRINT-PROFILE-READ-BASE READ-PRINT-PROFILE-READ-SUPPRESS READ-PRINT-PROFILE-PACKAGE READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT READ-PRINT-PROFILE-PRINT-ESCAPE READ-PRINT-PROFILE-PRINT-PRETTY READ-PRINT-PROFILE-PRINT-CIRCLE READ-PRINT-PROFILE-PRINT-BASE READ-PRINT-PROFILE-PRINT-RADIX READ-PRINT-PROFILE-PRINT-CASE READ-PRINT-PROFILE-PRINT-GENSYM READ-PRINT-PROFILE-PRINT-LEVEL READ-PRINT-PROFILE-PRINT-LENGTH READ-PRINT-PROFILE-PRINT-ARRAY READ-PRINT-PROFILE-PRINT-STRUCTURE RESTORE-READ-PRINT-PROFILE SAVE-READ-PRINT-PROFILE WITH-READ-PRINT-PROFILE *DEFAULT-READ-PRINT-PROFILE* FIND-READ-PRINT-PROFILE LIST-ALL-READ-PRINT-PROFILE-NAMES) "XCL") (DEFSTRUCT (READ-PRINT-PROFILE (:CONSTRUCTOR INTERNAL-MAKE-READ-PRINT-PROFILE)) (IL:* IL:;;; "Holds complete collection of read / print affecting globals.") READTABLE READ-BASE READ-SUPPRESS PACKAGE READ-DEFAULT-FLOAT-FORMAT PRINT-ESCAPE PRINT-PRETTY PRINT-CIRCLE PRINT-BASE PRINT-RADIX PRINT-CASE PRINT-GENSYM PRINT-LEVEL PRINT-LENGTH PRINT-ARRAY PRINT-STRUCTURE) (DEFUN MAKE-READ-PRINT-PROFILE (&KEY (READTABLE *READTABLE*) (READ-BASE *READ-BASE*) (READ-SUPPRESS *READ-SUPPRESS*) (PACKAGE *PACKAGE*) (READ-DEFAULT-FLOAT-FORMAT *READ-DEFAULT-FLOAT-FORMAT*) (PRINT-ESCAPE *PRINT-ESCAPE*) (PRINT-PRETTY *PRINT-PRETTY*) (PRINT-CIRCLE *PRINT-CIRCLE*) (PRINT-BASE *PRINT-BASE*) (PRINT-RADIX *PRINT-RADIX*) (PRINT-CASE *PRINT-CASE*) (PRINT-GENSYM *PRINT-GENSYM*) (PRINT-LEVEL *PRINT-LEVEL*) (PRINT-LENGTH *PRINT-LENGTH*)) (IL:* IL:;;; "Create and return a profile with default contents the current bindings of the read print special variables.") (INTERNAL-MAKE-READ-PRINT-PROFILE :READTABLE READTABLE :READ-BASE READ-BASE :READ-SUPPRESS READ-SUPPRESS :PACKAGE PACKAGE :READ-DEFAULT-FLOAT-FORMAT READ-DEFAULT-FLOAT-FORMAT :PRINT-ESCAPE PRINT-ESCAPE :PRINT-PRETTY PRINT-PRETTY :PRINT-CIRCLE PRINT-CIRCLE :PRINT-BASE PRINT-BASE :PRINT-RADIX PRINT-RADIX :PRINT-CASE PRINT-CASE :PRINT-GENSYM PRINT-GENSYM :PRINT-LEVEL PRINT-LEVEL :PRINT-LENGTH PRINT-LENGTH)) (DEFUN RESTORE-READ-PRINT-PROFILE (PROFILE) "Restore values of special io bindings from profile. Sets current bindings. Returns T." (SETF *READTABLE* (READ-PRINT-PROFILE-READTABLE PROFILE)) (SETF *READ-BASE* (READ-PRINT-PROFILE-READ-BASE PROFILE)) (SETF *READ-SUPPRESS* (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE)) (SETF *PACKAGE* (READ-PRINT-PROFILE-PACKAGE PROFILE)) (SETF *READ-DEFAULT-FLOAT-FORMAT* (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE)) (SETF *PRINT-ESCAPE* (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE)) (SETF *PRINT-PRETTY* (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE)) (SETF *PRINT-CIRCLE* (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE)) (SETF *PRINT-BASE* (READ-PRINT-PROFILE-PRINT-BASE PROFILE)) (SETF *PRINT-RADIX* (READ-PRINT-PROFILE-PRINT-RADIX PROFILE)) (SETF *PRINT-CASE* (READ-PRINT-PROFILE-PRINT-CASE PROFILE)) (SETF *PRINT-GENSYM* (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE)) (SETF *PRINT-LEVEL* (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE)) (SETF *PRINT-LENGTH* (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE)) (SETF *PRINT-ARRAY* (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE)) (SETF *PRINT-STRUCTURE* (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE)) T) (DEFUN SAVE-READ-PRINT-PROFILE (PROFILE) "Capture bindings of special io variables. Returns profile." (SETF (READ-PRINT-PROFILE-READTABLE PROFILE) *READTABLE*) (SETF (READ-PRINT-PROFILE-READ-BASE PROFILE) *READ-BASE*) (SETF (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE) *READ-SUPPRESS*) (SETF (READ-PRINT-PROFILE-PACKAGE PROFILE) *PACKAGE*) (SETF (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE) *READ-DEFAULT-FLOAT-FORMAT*) (SETF (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE) *PRINT-ESCAPE*) (SETF (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE) *PRINT-PRETTY*) (SETF (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE) *PRINT-CIRCLE*) (SETF (READ-PRINT-PROFILE-PRINT-BASE PROFILE) *PRINT-BASE*) (SETF (READ-PRINT-PROFILE-PRINT-RADIX PROFILE) *PRINT-RADIX*) (SETF (READ-PRINT-PROFILE-PRINT-CASE PROFILE) *PRINT-CASE*) (SETF (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE) *PRINT-GENSYM*) (SETF (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE) *PRINT-LEVEL*) (SETF (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE) *PRINT-LENGTH*) (SETF (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE) *PRINT-ARRAY*) (SETF (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE) *PRINT-STRUCTURE*) PROFILE) (DEFMACRO WITH-READ-PRINT-PROFILE (PROFILE-FORM &BODY FORMS) "Bind all the special IO variables to the values in the profile and execute the body forms." `(LET ((PROFILE ,PROFILE-FORM)) (LET ((*READTABLE* (READ-PRINT-PROFILE-READTABLE PROFILE)) (*READ-BASE* (READ-PRINT-PROFILE-READ-BASE PROFILE)) (*READ-SUPPRESS* (READ-PRINT-PROFILE-READ-SUPPRESS PROFILE)) (*PACKAGE* (READ-PRINT-PROFILE-PACKAGE PROFILE)) (*READ-DEFAULT-FLOAT-FORMAT* (READ-PRINT-PROFILE-READ-DEFAULT-FLOAT-FORMAT PROFILE)) (*PRINT-ESCAPE* (READ-PRINT-PROFILE-PRINT-ESCAPE PROFILE)) (*PRINT-PRETTY* (READ-PRINT-PROFILE-PRINT-PRETTY PROFILE)) (*PRINT-CIRCLE* (READ-PRINT-PROFILE-PRINT-CIRCLE PROFILE)) (*PRINT-BASE* (READ-PRINT-PROFILE-PRINT-BASE PROFILE)) (*PRINT-RADIX* (READ-PRINT-PROFILE-PRINT-RADIX PROFILE)) (*PRINT-CASE* (READ-PRINT-PROFILE-PRINT-CASE PROFILE)) (*PRINT-GENSYM* (READ-PRINT-PROFILE-PRINT-GENSYM PROFILE)) (*PRINT-LEVEL* (READ-PRINT-PROFILE-PRINT-LEVEL PROFILE)) (*PRINT-LENGTH* (READ-PRINT-PROFILE-PRINT-LENGTH PROFILE)) (*PRINT-ARRAY* (READ-PRINT-PROFILE-PRINT-ARRAY PROFILE)) (*PRINT-STRUCTURE* (READ-PRINT-PROFILE-PRINT-STRUCTURE PROFILE))) ,@FORMS))) (DEFUN FIND-READ-PRINT-PROFILE (NAME) (GETHASH (STRING-UPCASE NAME) *READ-PRINT-PROFILES*)) (DEFUN SETF-FIND-READ-PRINT-PROFILE (NAME READ-PRINT-PROFILE) (CHECK-TYPE READ-PRINT-PROFILE READ-PRINT-PROFILE) (SETF (GETHASH (STRING-UPCASE NAME) *READ-PRINT-PROFILES*) READ-PRINT-PROFILE)) (DEFUN LIST-ALL-READ-PRINT-PROFILE-NAMES () (LET ((NAMES NIL)) (MAPHASH #'(LAMBDA (NAME VALUE) (PUSH NAME NAMES)) *READ-PRINT-PROFILES*) NAMES)) (DEFSETF FIND-READ-PRINT-PROFILE SETF-FIND-READ-PRINT-PROFILE) (DEFPARAMETER *READ-PRINT-PROFILES* (LET ((TABLE (MAKE-HASH-TABLE :TEST 'EQUAL)) (LISP-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "LISP") :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "USER") :READ-DEFAULT-FLOAT-FORMAT 'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE NIL) ) (XCL-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "XCL") :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "XCL-USER") :READ-DEFAULT-FLOAT-FORMAT 'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE NIL)) (INTERLISP-TABLE (MAKE-READ-PRINT-PROFILE :READTABLE (IL:FIND-READTABLE "INTERLISP") :READ-BASE 10 :READ-SUPPRESS NIL :PACKAGE (FIND-PACKAGE "INTERLISP") :READ-DEFAULT-FLOAT-FORMAT 'SINGLE-FLOAT :PRINT-ESCAPE T :PRINT-PRETTY NIL :PRINT-CIRCLE NIL :PRINT-BASE 10 :PRINT-RADIX NIL :PRINT-CASE :UPCASE :PRINT-GENSYM T :PRINT-LEVEL NIL :PRINT-LENGTH NIL :PRINT-ARRAY NIL :PRINT-STRUCTURE NIL))) (SETF (GETHASH "LISP" TABLE) LISP-TABLE) (SETF (GETHASH "XCL" TABLE) XCL-TABLE) (SETF (GETHASH "INTERLISP" TABLE) INTERLISP-TABLE) TABLE) "Where read-print-modes live.") (DEFPARAMETER *DEFAULT-READ-PRINT-PROFILE* (FIND-READ-PRINT-PROFILE "INTERLISP") "The default read & print state to be used when not explicitly set.") (IL:PUTPROPS IL:READ-PRINT-PROFILE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "XCL")) (IL:PUTPROPS IL:READ-PRINT-PROFILE IL:FILETYPE IL:COMPILE-FILE) (IL:PUTPROPS IL:READ-PRINT-PROFILE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/RECORD b/sources/RECORD new file mode 100644 index 00000000..68310668 --- /dev/null +++ b/sources/RECORD @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 11:15:39" {DSK}lde>lispcore>sources>RECORD.;3 180531 previous date%: " 5-Jan-93 02:03:38" {DSK}lde>lispcore>sources>RECORD.;2) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT RECORDCOMS) (RPAQQ RECORDCOMS [(FNS RECORDTRAN RECREDECLARE RECREDECLARE1 RECREDECLARE2 RECORDECL RECORDFIELD? RECORDECL0 RECORDECL1 RECORDECLBLOCK RECORDECLTAIL CHECKRECORDNAME LISTRECORDEFS RECORD.REMOVE.COMMENTS DECLARERECORD DECLSUBFIELD UNCLISPTRAN RECDEC? ALLOCHASH GETSETQ RECORDACCESS RECORDFIELDNAMES RECEVAL FIELDLOOK SIMPLEP RECORDBINDVAL RECORDPRIORITY RECORDACCESSFORM) (FNS RECORDWORD MAKECREATE0 MAKECREATE1 CREATEFIELDS REBINDP CSUBST RECONS COPY1 CSUBSTLST RECORD.FIELD.VALUE RECORD.FIELD.VALUE0 MAKECREATELST SMASHPATTERN SMASHPAT1 MAKECREATELST1 GETFIELDFORCREATE SUBFIELDCREATE MAKEHASHLINKS HASHLINKS RECLOOK ALLFIELDS SUBDECLARATIONS) (FNS CLISPRECORD ACCESSDEF FIELDNAMESIN ACCESSDEF4 MAKEACCESS MAKEACCESS1 MKACCESSFN RECFIELDLOOK RECORDCHAIN RECLOOK1 SYSRECLOOK1 TOPPATHS ALLPATHS CHECKDEFS JOINDEF) (FNS NOTOKSWAP FIXFIELDORDER FINDFIELDUSAGE EMBEDPROG) (FNS RECLISPLOOKUP CONSFN RECORDGENSYM RECORDBIND RECORDERROR SETUPHASHARRAY DWIMIFYREC MKCONS MKPROGN) (FNS RECORDINIT) (VARS PATGENSYMVARS) (INITVARS (RECORDINIT)) (INITVARS CLISPRECORDTYPES) (INITVARS (RECORDTRANHASH (HASHARRAY 20))) (FNS * (PROGN CLISPRECORDTYPES)) (FNS RECORDECLARATIONS RECORDALLOCATIONS SAVEONSYSRECLST) (ADDVARS (USERRECLST)) (VARS (DECLARATIONCHAIN) MSBLIP NOSIDEFNS (RECORDSUBSTFLG) (RECORDUSE) DATATYPEFIELDCOERCIONS) (INITVARS (RECORDCHANGEFN)) (VARS CLISPRECORDWORDS) (PROP CLISPWORD /REPLACE COPYING FETCH FFETCH FREPLACE REPLACE REUSING SMASHING TYPE? USING /replace copying fetch ffetch freplace replace reusing smashing type? using OF of WITH with CREATE create INITRECORD initrecord) (DECLARE%: DONTCOPY (FILEPKGCOMS RECORDTYPES)) (RECORDTYPES RECORD TYPERECORD PROPRECORD HASHLINK ACCESSFN ACCESSFNS HASHRECORD ATOMRECORD ARRAYRECORD DATATYPE BLOCKRECORD ASSOCRECORD CACCESSFNS ARRAYBLOCK SYNONYM) (DECLARE%: DONTCOPY (MACROS CREATE.RECORD ADD.RECORD.SUBDECS RECORD.ALLOCATIONS RECORD.CREATEINFO RECORD.DEFAULTFIELDS RECORD.FIELDINFO RECORD.FIELDNAMES RECORD.NAME RECORD.SUBDECS RECORD.TYPECHECK SET.RECORD.ALLOCATIONS SET.RECORD.CREATEINFO SET.RECORD.DEFAULTFIELDS SET.RECORD.FIELDNAMES SET.RECORD.NAME SET.RECORD.TYPECHECK RECORD.DECL SET.RECORD.DECL RECORD.PRIORITY SET.RECORD.PRIORITY)) (LOCALVARS . T) (ADDVARS (SYSLOCALVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) [COMS (* ; "for handling datatype") (P (MOVD 'FETCHFIELD 'FFETCHFIELD) (MOVD 'REPLACEFIELD 'FREPLACEFIELD)) (E (CLISPDEC 'STANDARD)) (IFPROP (LISPFN CLISPCLASS CLISPCLASSDEF) FETCHFIELD FFETCHFIELD FREPLACEFIELD /REPLACEFIELD REPLACEFIELD) (ADDVARS (DECLWORDS FFETCHFIELD FETCHFIELD REPLACEFIELD FREPLACEFIELD /REPLACEFIELD)) (P (NEW/FN 'REPLACEFIELD] (VARS RECORDWORDS) (COMS (* ; "for CHANGETRAN") (PROP CLISPWORD ADD CHANGE POP PUSH PUSHNEW PUSHLIST add change pop push pushnew pushlist SWAP swap /push /pushnew /PUSH /PUSHNEW) (FNS CHANGETRAN CHANGETRAN1 FIXDATUM) (PROP SETFN GETP GETPROP EVALV GETATOMVAL OPENR WORDCONTENTS \GETBASE \GETBASEBYTE \GETBASEBIT FETCHFIELD)) (BLOCKS (RECORDBLOCK ACCESSDEF ACCESSDEF4 ALLFIELDS ALLOCHASH ALLPATHS CHANGETRAN CHANGETRAN1 CHECKDEFS CHECKRECORDNAME CLISPRECORD CONSFN COPY1 CREATEFIELDS CSUBST RECONS CSUBSTLST DECLARERECORD DECLSUBFIELD DWIMIFYREC EMBEDPROG FIELDLOOK FIELDNAMESIN FINDFIELDUSAGE FIXDATUM FIXFIELDORDER GETFIELDFORCREATE GETSETQ HASHLINKS JOINDEF LISTRECORDEFS MAKEACCESS MAKEACCESS1 MAKECREATE0 MAKECREATE1 MAKECREATELST MAKECREATELST1 MAKEHASHLINKS MKACCESSFN MKCONS MKPROGN NOTOKSWAP REBINDP RECDEC? RECEVAL RECFIELDLOOK RECLISPLOOKUP RECLOOK RECLOOK1 RECORD.FIELD.VALUE RECORD.FIELD.VALUE0 RECORDACCESS RECORDALLOCATIONS RECORDBIND RECORDBINDVAL RECORDCHAIN RECORDECL RECORDECL0 RECORDECL1 RECORDECLBLOCK RECORDECLTAIL RECORDECLARATIONS RECORDERROR RECORDFIELD? RECORDFIELDNAMES RECORDGENSYM RECORDTRAN RECORDWORD RECREDECLARE SETUPHASHARRAY SIMPLEP SUBDECLARATIONS SUBFIELDCREATE TOPPATHS UNCLISPTRAN RECORDPRIORITY (ENTRIES RECORDTRAN CHANGETRAN CLISPRECORD RECORDFIELD? RECORDECLARATIONS RECORDALLOCATIONS RECORDACCESS RECORDFIELDNAMES RECLOOK SETUPHASHARRAY FIELDLOOK RECORD.FIELD.VALUE DECLARERECORD RECORDPRIORITY) (SPECVARS DWIMIFYFLG CLISPCHANGE NEWVALUE DECLARATIONCHAIN USINGTYPE USINGEXPR ARRAYDESC EXPR FAULTFN VARS DECLST FIELDNAMES RECORDEXPRESSION RECORD.TRAN ALLOCATIONS FIELDS.IN.CREATE PATGENSYMVARS NOSPELLFLG PATGENSYMVARS) (LOCALFREEVARS FIELD.USAGE BINDINGS RNAME NAME TAIL SETQPART SETQTAIL DECL CREATEINFO CLISPCHANGE FIELDINFO HASHLINKS ARGS AVOID BODY VAR1 NOTRANFLG SPECIALFIELDS SUBSTYPE STRUCNAME) (NOLINKFNS . T) SMASHPATTERN SMASHPAT1)) (GLOBALVARS MSBLIP CLISPRECORDTYPES NOSIDEFNS CLISPRECORDWORDS RECORDSTATS USERRECLST RECORDINIT LAMBDASPLST CLISPTRANFLG RECORDCHANGEFN COMMENTFLG CLISPCHARRAY LCASEFLG CLISPARRAY LISPXFNS RECORDWORDS DATATYPEFIELDCOERCIONS DATATYPEFIELDTYPES RECORDTRANHASH RECORDINIT CLISPARRAY CLISPRECORDTYPES RECORDTRANHASH) (FNS EDITREC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA EDITREC SAVEONSYSRECLST RECORDALLOCATIONS RECORDECLARATIONS SYNONYM ARRAYBLOCK CACCESSFNS ASSOCRECORD BLOCKRECORD DATATYPE ARRAYRECORD ATOMRECORD HASHRECORD ACCESSFNS ACCESSFN HASHLINK PROPRECORD TYPERECORD RECORD MESATYPE MESARECORD MESAARRAY) (NLAML) (LAMA]) (DEFINEQ (RECORDTRAN [LAMBDA (RECORDEXPRESSION WORDTYPE) (* ; "Edited 9-Jan-87 21:10 by Pavel") (* ;; "top level entry for translation of record expressions") (PROG ((PATGENSYMVARS PATGENSYMVARS) (DECLST (GETLOCALDEC EXPR FAULTFN)) DEF NOTRANFLG (EXPRESSIONTYPE (RECORDWORD (CAR RECORDEXPRESSION) RECORDEXPRESSION WORDTYPE)) BINDINGS TAIL) (SETQ CLISPCHANGE T) [COND ((SETQ DEF (ASSOC EXPRESSIONTYPE RECORDWORDS)) (SETQ DECLST (CONS (CADR DEF) DECLST)) (SETQ EXPRESSIONTYPE (CADDR DEF] (SETQ DEF (SELECTQ EXPRESSIONTYPE (fetch (OR (SETQ DEF (ACCESSDEF (CADR RECORDEXPRESSION) (CADDDR RECORDEXPRESSION) (CDR RECORDEXPRESSION))) (RECORDERROR 7 RECORDEXPRESSION)) (SELECTQ (RECORDWORD (CAR (SETQ TAIL (CDDR RECORDEXPRESSION))) TAIL) ((of OF) (SETQ TAIL (CDR TAIL))) NIL) (DWIMIFYREC TAIL NIL RECORDEXPRESSION) (MAKEACCESS DEF (MKPROGN TAIL) NIL 'fetch)) (replace (COND ([NOT (SETQ DEF (ACCESSDEF (CADR RECORDEXPRESSION) (CADDDR RECORDEXPRESSION) (CDR RECORDEXPRESSION] (RECORDERROR 7 RECORDEXPRESSION))) (SELECTQ (RECORDWORD (CAR (SETQ TAIL (CDDR RECORDEXPRESSION))) TAIL) ((OF of) (SETQ TAIL (CDR TAIL))) NIL) (DWIMIFYREC TAIL '(with WITH) RECORDEXPRESSION T) (MAKEACCESS DEF (CAR TAIL) (PROGN (DWIMIFYREC (CDR (SELECTQ (RECORDWORD (CADR TAIL) (CDR TAIL)) ((with WITH) (SETQ TAIL (CDR TAIL))) TAIL)) NIL RECORDEXPRESSION) (CDR TAIL)) EXPRESSIONTYPE)) (create (PROG (DEC FIELDS.IN.CREATE TRAN SETQPART SETQTAIL TEM2 USING USINGTYPE USINGEXPR (TL (CDDR RECORDEXPRESSION)) FIELDNAMES UNUSED) (* ;; "BLIP is used throughout the computation to indicate a no-op -- i.e. a field which was not specified") [SETQ FIELDNAMES (ALLFIELDS (SETQ TRAN (RECORDECL (SETQ DEC (RECLOOK (CADR RECORDEXPRESSION ) (CDR RECORDEXPRESSION) DECLST RECORDEXPRESSION T] (* ;; "RECLOOK looks up the declaration for the record name given (CREATE A --) it returns the declaration for A") (* ;  "Go through the create statement, picking up the field_'s and the USING or COPYING, etc") [while TL do (COND ((SETQ TEM2 (RECORDWORD (CAR TL) TL)) (* ; "USING COPYING ETC") (COND (USING (RECORDERROR [COND ((EQ (CAR TL) (CAR USING)) (LIST (CAR TL) "occurs twice")) (T (LIST "both" (CAR TL) "and" (CAR USING] TL RECORDEXPRESSION)) (T (SETQ USINGTYPE TEM2) (SETQ USING TL))) (DWIMIFYREC (CDR TL) CLISPRECORDWORDS RECORDEXPRESSION) (SETQ TL (CDDR TL))) ((GETSETQ TL FIELDNAMES RECORDEXPRESSION CLISPRECORDWORDS NIL CLISPRECORDWORDS) (* ;; "Adds the info to alist, or ERROR's --- if it returned NIL then a correction was made and we should just retry the same TL") (COND ((ASSOC (CAR SETQPART) FIELDS.IN.CREATE) (RECORDERROR 5 TL RECORDEXPRESSION)) (T (SETQ FIELDS.IN.CREATE (CONS SETQPART FIELDS.IN.CREATE)) (SETQ TL SETQTAIL] [COND (USINGTYPE (SETQ USINGEXPR (RECORDBINDVAL (COND ((FMEMB 'CHECK (CDR (RECORD.TYPECHECK TRAN))) (LIST 'THE (RECORD.NAME TRAN) (CADR USING))) (T (CADR USING] (SETQ DEF (MAKECREATE0 TRAN (HASHLINKS TRAN) T)) [COND ((SETQ UNUSED (FIXFIELDORDER DEF)) (PROG ((DECLST (CONS 'FAST DECLST)) TEM) (SETQ DEF (CONS 'PROG1 (CONS (LIST 'SETQ (SETQ TEM (RECORDBIND)) DEF) (for X in (DREVERSE UNUSED) collect (MAKEACCESS (CAR (OR (ACCESSDEF4 (LIST (CAR X)) TRAN) (RECORDERROR 'REPLACE (CAR X) RECORDEXPRESSION))) TEM (CDR X) 'replace] (RETURN DEF))) (with (* ;; "new feature: (with RECORDNAME of stuff) --- means execute substituting the fieldnames") [PROG ((SUBSTYPE 'WITH) [SPECIALFIELDS (LIST (LIST 'DATUM 'USING] USINGEXPR RECORD.TRAN FIELDNAMES) [SETQ FIELDNAMES (ALLFIELDS (SETQ RECORD.TRAN (RECORDECL (RECLOOK (CADR RECORDEXPRESSION ) (CDR RECORDEXPRESSION ) DECLST RECORDEXPRESSION T] (DWIMIFYREC (CDDR RECORDEXPRESSION) (CONS 'DATUM FIELDNAMES) RECORDEXPRESSION) (SETQ USINGEXPR (RECORDBINDVAL (CADDR RECORDEXPRESSION))) (RETURN (CSUBST (MKPROGN (CDDDR RECORDEXPRESSION]) (type? (OR [SETQ DEF (CAR (RECORD.TYPECHECK (RECORDECL (RECLOOK (CADR RECORDEXPRESSION ) (CDR RECORDEXPRESSION ) DECLST RECORDEXPRESSION T] (RECORDERROR 'TYPE? (CADR RECORDEXPRESSION) RECORDEXPRESSION)) (DWIMIFY0? (CDDR RECORDEXPRESSION) RECORDEXPRESSION T T NIL FAULTFN 'VARSBOUND) [COND [(OR (NLISTP DEF) (FMEMB (CAR DEF) LAMBDASPLST)) (SETQ DEF (CONS DEF (CDDR RECORDEXPRESSION] (T (PROG [(SUBSTYPE 'TYPE?) [SPECIALFIELDS (LIST (LIST 'DATUM 'USING] FIELDNAMES (USINGEXPR (MKPROGN (CDDR RECORDEXPRESSION] (RETURN (CSUBST DEF]) (initrecord [SETQ DEF (MKPROGN (RECORD.ALLOCATIONS (RECORDECL (RECLOOK (CADR RECORDEXPRESSION ) (CDR RECORDEXPRESSION) DECLST RECORDEXPRESSION T]) (CHANGETRAN1 EXPRESSIONTYPE RECORDEXPRESSION))) [COND (BINDINGS (SETQ DEF (EMBEDPROG DEF] (LET ((DWIMESSGAG T) (NOSPELLFLG T) LISPXHIST) (DECLARE (SPECVARS LISPXHIST DWIMESSGAG NOSPELLFLG)) (DWIMIFY0? DEF DEF NIL NIL NIL FAULTFN 'VARSBOUND)) [COND ((NLISTP DEF) (SETQ DEF (LIST 'PROGN DEF] (COND (NOTRANFLG (RETURN DEF))) (CLISPTRAN RECORDEXPRESSION DEF) (RETURN RECORDEXPRESSION]) (RECREDECLARE [LAMBDA (RECNAME RECFIELDS OLDFLG) (* lmm "13-SEP-77 15:49") (DECLARE (SPECVARS RECNAME RECFIELDS)) (AND RECORDCHANGEFN (APPLY* RECORDCHANGEFN RECNAME RECFIELDS OLDFLG)) (AND CLISPARRAY (MAPHASH CLISPARRAY (FUNCTION RECREDECLARE1]) (RECREDECLARE1 [LAMBDA (TRAN ORIG) (* lmm "31-JUL-78 05:04") (* ;; "Given an entry in CLISPARRAY, test if it is a record expression involving any of the fields that have changed, and remove the old translation") (AND (RECREDECLARE2 ORIG) (/PUTHASH ORIG NIL CLISPARRAY]) (RECREDECLARE2 [LAMBDA (FORM) (* lmm "31-JUL-78 05:04") (* ; "should this form be changed") (SELECTQ (CAR (GETP (CAR FORM) 'CLISPWORD)) (RECORDTRAN (SELECTQ (CAR FORM) ((CREATE create TYPE? type?) (EQ (CADR FORM) RECNAME)) (OR (LISTP (CADR FORM)) (FMEMB (CADR FORM) RECFIELDS)))) (CHANGETRAN (RECREDECLARE2 (CADR FORM))) NIL]) (RECORDECL [LAMBDA (DEC) (* lmm%: "26-JUL-76 02:44:29") (* ;; "Entry for lookup of record declarations --- retrieve the current translation of the declaration DECL, or create a new one and store it on DEC") (PROG (ALLOCATIONS TEM) (* ;; "Some declarations (specifically HASHLINKS and DATATYPES) require expressions to be evaluated at run-time. When these are encountered, the run-times are added to ALLOCATIONS. The RECORDS prettydefmacro puts out the ALLOCATIONS within a DOCOPY so that they will be inserted in the .COM file even if the declaration itself is dumped out DONTCOPY") (AND (SETQ TEM (RECORDECL0 DEC)) ALLOCATIONS (SET.RECORD.ALLOCATIONS TEM ALLOCATIONS)) (RETURN TEM]) (RECORDFIELD? [LAMBDA (FIELD DECLARATIONS) (* lmm "18-SEP-78 18:35") (* ;; "Top level predicate if an atom is a field name. Used by DWIM to avoid ambiguity in X:FIELD9 -> X:FIELD") (PROG (TEM) (RETURN (COND [(SETQ TEM (STRPOS '%. FIELD)) (AND (RECLOOK (SUBATOM FIELD 1 (SUB1 TEM))) (RECORDFIELD? (SUBATOM FIELD (ADD1 TEM) -1] (T (for X in (OR DECLARATIONS USERRECLST) when [FMEMB FIELD (RECORD.FIELDNAMES (SETQ X (RECORDECL X] do (RETURN (OR (RECORD.NAME X) X]) (RECORDECL0 [LAMBDA (DEC PARENT) (* lmm " 7-AUG-84 23:33") (* ;; "Returns either NIL or the translation of a declaration expression") (if (NLISTP DEC) then NIL elseif (NOT (FMEMB (CAR DEC) CLISPRECORDTYPES)) then NIL elseif (GETHASH DEC RECORDTRANHASH) elseif (AND CLISPARRAY (GETHASH DEC CLISPARRAY)) else (PROG ((TRANSLATION (RECORDECL1 DEC PARENT))) (PUTHASH DEC TRANSLATION RECORDTRANHASH) (RETURN TRANSLATION]) (RECORDECL1 [LAMBDA (DECL PARENT) (* lmm " 7-Jul-86 10:32") (if (NOT (FMEMB DECL DECLARATIONCHAIN)) then (LET ((DECLARATIONCHAIN (CONS DECL DECLARATIONCHAIN))) (SETQ DECL (RECORD.REMOVE.COMMENTS DECL)) (PROG (TEM1 TRANSLATION (NAME (CADR DECL)) (STRUCNAME (CADR DECL)) (TAIL (CDDDR DECL)) (CREATEINFO (CADDR DECL)) (CREATETYPE (CAR DECL)) FIELDINF TYPECHECK FIELDNAMES) (* ;; "the vars CREATETYPE NAME CREATEINFO TAIL are bound to 'default' values. If declaration is in non-standard format (e.g. (RECORD (B . C))) these values are changed below.") RETRY [SELECTQ (CAR DECL) (RECORD (CHECKRECORDNAME NIL T) (SETQ FIELDINF (LISTRECORDEFS CREATEINFO))) (TYPERECORD (* ;; "For RECORD and TYPERECORD, the field info is a CROPS list, and the CREATEINFO is the original template (TYPERECORD has NAME consed onto it)") (CHECKRECORDNAME T T T) (SETQ TYPECHECK (LIST 'EQ '(CAR (LISTP DATUM)) (KWOTE STRUCNAME))) [SETQ FIELDINF (LISTRECORDEFS (SETQ CREATEINFO CREATEINFO) '(D] (SETQ CREATEINFO (CONS STRUCNAME CREATEINFO))) ((PROPRECORD ATOMRECORD ASSOCRECORD) (* ;; "For these record types, the FIELDINF is the atom of the field name and the CREATEINFO is just the list of fields") (CHECKRECORDNAME) [SETQ FIELDINF (for FIELD in CREATEINFO collect (CONS FIELD (CONS (CAR DECL) FIELD]) (ARRAYRECORD (CHECKRECORDNAME) (SETQQ TYPECHECK (ARRAYP DATUM)) (* ;; "for ARRAYRECORD, the fieldinfo is either n (index) or (D . n) (index for ELTD) and the CREATEINFO is just the total number of entries") (* ;  "RECORDECLARRAY returns the FIELD information, but also smashes up CREATEINFO") (PROG ((CNT 0) X (CL CREATEINFO)) LP (COND (CL [COND [(SMALLP (CAR CL)) (SETQ CNT (IPLUS CNT (CAR CL] (T (SETQ CNT (ADD1 CNT)) (COND ((CAR CL) [COND ((OR (NLISTP (SETQ X (CAR CL))) (SETQ X (CAR X))) (SETQ FIELDINF (CONS (CONS X (CONS 'ARRAYRECORD CNT)) FIELDINF] (COND ((CDR (LISTP (CAR CL))) (SETQ FIELDINF (CONS (CONS (CDR (CAR CL)) (CONS 'ARRAYRECORD (CONS 'D CNT))) FIELDINF)) (FRPLNODE CL (CAAR CL) (FRPLNODE (CAR CL) (CDAR CL) (CDR CL))) (SETQ CL (CDR CL] (SETQ CL (CDR CL)) (GO LP))) (SETQ CREATEINFO (CONS CNT CREATEINFO)))) (HASHRECORD [SETQ TEM1 (COND ((RECDEC? (CADR DECL)) (* ; "(hashlink (record --) --)") (SETQ NAME NIL) (SETQ TAIL (CDR DECL)) (LIST (GENSYM))) ((LISTP (CADR DECL)) (* ; "(hashlink (foo) --)") (SETQ NAME NIL) (SETQ TAIL (CDDR DECL)) (CADR DECL)) ((NULL (CDDR DECL)) (* ; "(hashlink foo)") (SETQ NAME NIL) (SETQ TAIL (CDDR DECL)) (LIST (CADR DECL))) ((RECDEC? (CADDR DECL)) (* ; "(hashlink foo (record ---) --)") (SETQ TAIL (CDDR DECL)) (LIST (GENSYM))) ((NLISTP (CADDR DECL)) (* ; "(hashlink fie fum --)") (LIST (CADDR DECL))) (T (* ;  "Finally, the 'right' way --- (hashlink name (field) --)") (CADDR DECL] [SETQ CREATEINFO (LIST (CAR TEM1) (COND ((NUMBERP (CADR TEM1)) (* ;  "(HASHLINK (FOO 100)) --- initial size") (ALLOCHASH (OR (CADDR TEM1) (CAR TEM1)) (CADR TEM1) T)) (T (ALLOCHASH (CADR TEM1) (CADDR TEM1) T] [SETQ FIELDINF (LIST (CONS (CAR CREATEINFO) (CONS 'HASHRECORD (CDR CREATEINFO]) ((ACCESSFNS CACCESSFNS) (CHECKRECORDNAME NIL T) [SETQ FIELDINF (for X in (COND ((LITATOM (CAR CREATEINFO)) (LIST CREATEINFO)) (T CREATEINFO)) join (PROGN (COND ((OR (NLISTP X) (CDDDR X)) (RECORDERROR 1 X DECL))) (COND [(LISTP (CAR X)) (for Y in (CAR X) collect (CONS Y (CONS (CAR DECL) (CONS Y (CDR X] (T (LIST (CONS (CAR X) (CONS (CAR DECL) X] (SETQ CREATEINFO) (SETQ CREATETYPE)) ((BLOCKRECORD DATATYPE ARRAYBLOCK) (CHECKRECORDNAME (NEQ (CAR DECL) 'DATATYPE) NIL T) [PROG ((ARRAYDESC) DEFL) [SETQ FIELDINF (CAR (SETQ DEFL (RECORDECLBLOCK DECL] (SETQ CREATEINFO (CONS (SELECTQ (CAR DECL) (DATATYPE (SETQ TYPECHECK (LIST 'TYPENAMEP 'DATUM (KWOTE STRUCNAME))) STRUCNAME) (ARRAYBLOCK ARRAYDESC) (RETURN (SETQ CREATEINFO))) (CONS (MAPCAR FIELDINF (FUNCTION CAR)) (CONS (CDR DEFL) FIELDINF]) (COND ((SETQ TEM1 (GETPROP (CAR DECL) 'USERRECORDTYPE)) (RETURN (RECORDECL1 (APPLY* TEM1 DECL) PARENT))) ((FIXSPELL (CAR DECL) CLISPRECORDTYPES) (GO RETRY)) (T (RECORDERROR 1 DECL] [SETQ FIELDNAMES (for X on FIELDINF when (CAAR X) collect (COND ((NOT (LITATOM (CAAR X))) (RECORDERROR 4 (CAAR X) DECL)) ((NULL (CAAR X)) NIL) ((ASSOC (CAAR X) (CDR X)) (RECORDERROR 5 (CAAR X) DECL)) (T (CAAR X] (SETQ TRANSLATION (CREATE.RECORD FIELDNAMES NAME FIELDINF (CONS CREATETYPE CREATEINFO) (CONS TYPECHECK))) (COND (TAIL (* ;  "Process sub-declarations and 'defaults' (e.g. (RECORD A (B . C) B _ 10))") (RECORDECLTAIL NAME FIELDNAMES TAIL DECL TRANSLATION))) (RETURN TRANSLATION]) (RECORDECLBLOCK [LAMBDA (DEC) (* ; "Edited 24-Aug-87 16:38 by amd") (PROG ((FIELDS (CADDR DEC)) SPECS SPEC FNAME FIELDNAMES DEFAULTS FI TMP) [for SPEC in (OR FIELDS (RECORDERROR 'F DEC)) when (NEQ (CAR SPEC) COMMENTFLG) do (PROG ((RPT 0) (ORIGINAL-SPEC SPEC)) [COND ((NLISTP SPEC) (SETQ SPEC (LIST SPEC 'POINTER] (SETQ FNAME (CAR SPEC)) (SETQ SPEC (CDR SPEC)) L1 [SELECTQ (CAR SPEC) (BITS (SETQ DEFAULTS (CONS (CONS FNAME (OR (CADDR SPEC) 0)) DEFAULTS)) (* ; "Should be BITS n1 offset") ) (BETWEEN (SETQ DEFAULTS (CONS (CONS FNAME (CADR SPEC)) DEFAULTS)) (* ; "BETWEEN N1 N2") (SETQ SPEC (LIST 'BITS [bind (Z _ (IDIFFERENCE (CADDR SPEC) (CADR SPEC))) find I from 1 suchthat (ZEROP (SETQ Z (LRSH Z 1] (CADR SPEC)))) (COND ((SETQ TMP (ASSOC (CAR SPEC) DATATYPEFIELDTYPES)) (SETQ DEFAULTS (CONS (CONS FNAME (CADR TMP)) DEFAULTS)) (SETQ SPEC (CAR SPEC))) ((SETQ TMP (ASSOC (CAR SPEC) DATATYPEFIELDCOERCIONS)) (SETQ DEFAULTS (CONS [CONS FNAME (CADR (OR (ASSOC (SETQ SPEC (CDR TMP)) DATATYPEFIELDTYPES) (SHOULDNT] DEFAULTS))) ((FIXP (CAR SPEC)) (CL:UNLESS (CL:PLUSP (CAR SPEC)) (RECORDERROR 1 ORIGINAL-SPEC DEC)) (SETQ RPT (SUB1 (CAR SPEC))) (SETQ SPEC (CDR SPEC)) (GO L1)) ((FIXSPELL (CAR SPEC) NIL (NCONC (MAPCAR DATATYPEFIELDTYPES (FUNCTION CAR)) (MAPCAR DATATYPEFIELDCOERCIONS (FUNCTION CAR)) '(BETWEEN BITS)) NIL SPEC NIL NIL T) (GO L1)) (T (RECORDERROR 1 SPEC DEC] L2 (SETQ FIELDNAMES (NCONC1 FIELDNAMES FNAME)) (SETQ SPECS (NCONC1 SPECS SPEC)) (COND ((NEQ RPT 0) (SETQ FNAME NIL) (SETQ RPT (SUB1 RPT)) (GO L2] [LET ((DLIST (TRANSLATE.DATATYPE (AND (EQ (CAR DEC) 'DATATYPE) STRUCNAME) SPECS))) (SELECTQ (CAR DEC) (DATATYPE (SETQ ALLOCATIONS (CONS `[/DECLAREDATATYPE ',STRUCNAME ',SPECS ',(CDR DLIST) ',(CAR DLIST] ALLOCATIONS))) NIL) (SETQ FI (for X in (CDR DLIST) as Y in FIELDNAMES collect (CONS Y (CONS 'DATATYPE X] (RETURN (CONS FI DEFAULTS]) (RECORDECLTAIL [LAMBDA (NAME FIELDNAMES TL DEC TRANSLATION) (* gbn " 9-Jun-86 21:36") (PROG [SETQTAIL SETQPART (TYPES (APPEND '(CCREATE CREATE TYPE? SUBRECORD INIT DECL SYSTEM) CLISPRECORDTYPES)) (LOCALVARS (COND (NAME (CONS NAME FIELDNAMES)) (T FIELDNAMES] LP (COND ((NULL TL) (RETURN))) (COND ((LISTP (CAR TL)) [SELECTQ (CAAR TL) (INCLUDES (* ;  "change the translation to have includes on the end if the declaration is a datatype") (LET ((RUNTIMEDECL (ASSOC '/DECLAREDATATYPE ALLOCATIONS))) (if RUNTIMEDECL then [RPLACD (NTH RUNTIMEDECL 5) `(',(CADAR TL] (* ;  "as a signal that the super's fields have not been included, set the length to NIL") (RPLACA (NTH RUNTIMEDECL 5) NIL)))) (SUBRECORD (DECLSUBFIELD (CAR TL) TRANSLATION DEC)) (INIT (APPLY 'PROGN (CDAR TL)) (* ;; "We'd like the builtin INIT's to be done before the user's, so that, e.g., a datatype has been declared before the user does a DEFPRINT in the INIT.") (SETQ ALLOCATIONS (APPEND ALLOCATIONS (CDAR TL)))) ((CREATE CCREATE) [SET.RECORD.CREATEINFO TRANSLATION (CONS (CAAR TL) (CONS (CADAR TL) (RECORD.CREATEINFO TRANSLATION]) (TYPE? (SET.RECORD.TYPECHECK TRANSLATION (CONS (OR (CADAR TL) (CAR (RECORD.TYPECHECK TRANSLATION))) (CDDAR TL)))) (DECL (SET.RECORD.DECL TRANSLATION (CAR TL))) (SYSTEM (SET.RECORD.PRIORITY TRANSLATION 'SYSTEM)) (COND ((EQ (CAAR TL) COMMENTFLG)) ((RECDEC? (CAR TL)) (DECLSUBFIELD (UNCLISPTRAN (CAR TL)) TRANSLATION DEC)) (T (GO TRYASSIGN] (GO NXT)) ((EQ (CADR TL) '@) (COND [(EQ (CAR TL) NAME) (SETQ TL (CONS (LIST 'TYPE? (CADDR TL)) (CDDDR TL] (T (RECORDERROR 1 TL DEC))) (GO LP))) TRYASSIGN (COND ((GETSETQ TL LOCALVARS DEC NIL TYPES NIL T) [COND [(EQ (CAR SETQPART) NAME) (SET.RECORD.CREATEINFO TRANSLATION (CONS 'CREATE (CONS (CADR SETQPART) (RECORD.CREATEINFO TRANSLATION] (T (SET.RECORD.DEFAULTFIELDS TRANSLATION (CONS (LIST (CAR SETQPART) (CADR SETQPART)) (RECORD.DEFAULTFIELDS TRANSLATION] (* ;  "Add the 'default' value to the default-value-association-list") (SETQ TL SETQTAIL) (GO LP)) (T (GO LP))) NXT (SETQ TL (CDR TL)) (GO LP]) (CHECKRECORDNAME [LAMBDA (NEEDSNAME 3MUSTLISTP OKSTRUCDIFF) (* lmm "29-AUG-78 23:57") (* ;; "DECL is the declaration; NEEDSNAME is on if it's ok for record to have no record-name; OKSTRUCDIFF is ok if it is OK for STRUCNAME to be different from NAME") [COND ((NOT (AND NAME (LITATOM NAME))) (COND ((AND OKSTRUCDIFF (LISTP NAME) (LITATOM (CAR NAME)) (LITATOM (CADR NAME)) (NULL (CDDR NAME))) (SETQ STRUCNAME (CADR NAME)) (SETQ NAME (CAR NAME))) (T (COND (NEEDSNAME (RECORDERROR 0 DECL))) (SETQ NAME NIL) (SETQ TAIL (CDDR DECL)) (SETQ CREATEINFO (CADR DECL] (COND ((AND (NOT 3MUSTLISTP) (NLISTP CREATEINFO)) (RECORDERROR 1 (CADDR DECL) DECL]) (LISTRECORDEFS [LAMBDA (FORMAT CROPS TL) (* lmm " 8-AUG-83 23:19") (COND ((NULL FORMAT) TL) ((NLISTP FORMAT) (CONS (CONS FORMAT (CONS 'RECORD CROPS)) TL)) ((SMALLP (CAR FORMAT)) (LISTRECORDEFS (CDR FORMAT) (to (CAR FORMAT) do (SETQ CROPS (CONS 'D CROPS)) finally (RETURN CROPS)) TL)) (T (AND (CAR FORMAT) (SETQ TL (LISTRECORDEFS (CAR FORMAT) (CONS 'A CROPS) TL))) (COND ((CDR FORMAT) (LISTRECORDEFS (CDR FORMAT) (CONS 'D CROPS) TL)) (T TL]) (RECORD.REMOVE.COMMENTS [LAMBDA (X) (* lmm " 8-AUG-83 23:26") (COND ((NLISTP X) X) ((EQ (CAR (LISTP (CAR X))) COMMENTFLG) (RECORD.REMOVE.COMMENTS (CDR X))) (T (PROG [(A (RECORD.REMOVE.COMMENTS (CAR X))) (D (RECORD.REMOVE.COMMENTS (CDR X] (RETURN (COND ((AND (EQ A (CAR X)) (EQ D (CDR X))) X) (T (CONS A D]) (DECLARERECORD [LAMBDA (DEC) (* ; "Edited 12-Jan-88 14:44 by drc:") (PROG (TRANSLATION TEM RECNAME OLDTRAN OLDFLG) [COND ((SETQ TEM (CL:MEMBER DEC USERRECLST :TEST 'CL:EQUAL)) (* ;  "There is already an EQUAL declaration (this can often happen with DOEVAL@COMPILE declarations)") (RETURN (OR (RECORD.NAME (RECORDECL (CAR TEM))) TEM] (* ;; "the COPY is so that later when the the whole declaration is stored on USERRECLST that a subsequent edit to the same structure won't get confused.") (OR [SETQ TRANSLATION (RECORDECL (SETQ DEC (COPY DEC] (RECORDERROR 1 DEC)) [if (SETQ RECNAME (RECORD.NAME TRANSLATION)) then (* ;  "If the declaration has a name, check if some previous declaration exists with same name") [if [SETQ TEM (SOME USERRECLST (FUNCTION (LAMBDA (X) (EQ (RECORD.NAME (SETQ OLDTRAN (RECORDECL X))) RECNAME] then (SETQ OLDFLG T) (PUTHASH TEM NIL RECORDTRANHASH) (OR (EQ DFNFLG T) (LISPXPRINT (LIST 'record RECNAME 'redeclared) T T)) else (SETQ OLDTRAN) (* ;  "OLDTRAN is used below to get the names of the fields which USE TO BE in this record") (SETQ TEM (SETQ USERRECLST (CONS NIL USERRECLST] (* ;  "TEM is the location in USERRECLST where the declaration will go") else (SETQ TEM NIL) (for X in USERRECLST do (for Y in (RECORD.FIELDNAMES (RECORDECL X)) unless (FMEMB Y TEM) when (FMEMB Y (RECORD.FIELDNAMES TRANSLATION)) do (LISPXPRINT (LIST 'record 'field Y 'redeclared) T T) (SETQ TEM (CONS Y TEM)) (* ;; "TEM is the list of field names which appear in other declarations --- normally, field names that appear in multiple declarations are ok, since they can be qualified with the record name. If there is no name, however, the old declarations are ignored... e.g. if you define (RECORD A (B . C)) and then define (RECORD (D C)) you will get the latter interpretation if you just say C, and the former if you say A.C") )) (SETQ TEM (SETQ USERRECLST (CONS NIL USERRECLST] (MAPC (RECORD.ALLOCATIONS TRANSLATION) (FUNCTION EVAL)) (* ;  "At this point, TEM points to the tail of USERRECLST where this declaration should be smashed") (/RPLACA TEM DEC) (AND FILEPKGFLG (MARKASCHANGED (OR RECNAME DEC) 'RECORDS)) (RECREDECLARE RECNAME (UNION (RECORD.FIELDNAMES OLDTRAN) (RECORD.FIELDNAMES TRANSLATION)) OLDFLG) (* ;; "RECREDECLARE takes care of removing current CLISP translations involving the old or new declaration and (possibly) unsavedef'ing compiled code that involves those declarations") (RETURN RECNAME]) (DECLSUBFIELD [LAMBDA (SUBDECL TRANSLATION DEC) (* lmm "13-Mar-85 16:12") (* ;  "Translate SUBDECL and insert it into the 'meaning' of the superior") (PROG (SUBTRAN SUBNAME) (COND ((EQ (CAR SUBDECL) 'SUBRECORD) (OR (ASSOC (CADR SUBDECL) (RECORD.FIELDINFO TRANSLATION)) (GO ERR))) (T (OR (SETQ SUBTRAN (RECORDECL0 SUBDECL TRANSLATION)) (RECORDERROR 1 SUBDECL DEC)) [COND ((NULL (SETQ SUBNAME (RECORD.NAME SUBTRAN))) (SET.RECORD.NAME SUBTRAN (SETQ SUBNAME (COND ((EQ (CAR (RECORD.CREATEINFO TRANSLATION)) 'HASHRECORD) (CAAR (RECORD.FIELDINFO TRANSLATION))) (T (RECORD.NAME TRANSLATION] (OR (EQ (RECORD.NAME TRANSLATION) SUBNAME) (ASSOC SUBNAME (RECORD.FIELDINFO TRANSLATION)) (GO ERR)) (SET.RECORD.FIELDNAMES TRANSLATION (APPEND (RECORD.FIELDNAMES SUBTRAN) (RECORD.FIELDNAMES TRANSLATION))) (* ;  "Add the sub-declaration to the list of sub-declarations in the parent's translation") )) (RETURN (ADD.RECORD.SUBDECS TRANSLATION SUBDECL)) ERR (RECORDERROR -1 SUBDECL DEC]) (UNCLISPTRAN [LAMBDA (EXPRESSION) (* lmm%: 28 JUL 75 437) [COND ((EQ (CAR EXPRESSION) CLISPTRANFLG) (/RPLNODE2 EXPRESSION (CDDR EXPRESSION] (AND CLISPARRAY (/PUTHASH EXPRESSION NIL CLISPARRAY)) EXPRESSION]) (RECDEC? [LAMBDA (X) (* Simple test if X is a record  declaration) (COND ((NLISTP X) NIL) ((EQ (CAR X) CLISPTRANFLG) (RECDEC? (CDDR X))) (T (FMEMB (CAR X) CLISPRECORDTYPES]) (ALLOCHASH [LAMBDA (HASHTABLENAME SIZE FLAG) (* lmm " 7-MAY-82 16:43") (COND ((OR (AND SIZE (NOT (NUMBERP SIZE))) (NOT (LITATOM HASHTABLENAME))) (ERROR SIZE "bad hash array size"))) [AND FLAG HASHTABLENAME (SETQ ALLOCATIONS (CONS (LIST 'DECLARE%: 'EVAL@COMPILE (LIST 'GLOBALVARS HASHTABLENAME)) (CONS (LIST 'SETUPHASHARRAY (KWOTE HASHTABLENAME) SIZE) ALLOCATIONS] (SETUPHASHARRAY HASHTABLENAME SIZE) HASHTABLENAME]) (GETSETQ [LAMBDA (TL NVARS PARENT OKVARS OKFNS VARSPLST INDECL) (* lmm " 7-AUG-84 23:48") (* ;; "Sets the free variables SETQTAIL and SETQPART --- SETQTAIL is the tail of TL after a SETQ type expression; SETQPART is (var value); does spelling correction and/or dwimifying if necessary --- returns T if a setq was found, and NIL if an OKVAR is found (or corrected) or if a form starting with an OKFN is found (or corrected) and prints an error message otherwise") (PROG NIL RETRY (COND ((NULL TL) (RETURN)) ((FMEMB (CAR TL) OKVARS) (RETURN)) ((LISTP (CAR TL)) [SELECTQ (CAAR TL) (* (SETQ TL (CDR TL)) (GO RETRY)) ((SETQ SAVESETQ)) ((SETQQ SAVESETQQ) [/RPLNODE (CAR TL) 'SETQ (LIST (CADAR TL) (KWOTE (CADDR (CAR TL]) (COND ((FMEMB (CAAR TL) OKFNS) (RETURN)) (T (GO DWIM] (OR (FMEMB (CADAR TL) NVARS) (FIXSPELL (CADAR TL) 70 NVARS NIL (CDAR TL) NIL NIL NIL T) (RECORDERROR 7 TL PARENT)) (SETQ SETQTAIL (CDR TL)) (SETQ SETQPART (APPEND (CDAR TL))) [/RPLNODE TL (CADAR TL) (CONS '_ (CONS (CADDR (CAR TL)) (CDR TL] (RETURN T)) ([AND (FMEMB (CAR TL) NVARS) (EQ (CADR TL) '_) (PROGN (COND ((COND [(NLISTP (CADDR TL)) (AND (LITATOM (CADDR TL)) (STRPOSL CLISPCHARRAY (CADDR TL] (T (NOT VARSPLST))) (DWIMIFYREC (CDDR TL) NIL PARENT T INDECL))) (OR (NULL (CDDDR TL)) (LISTP (CADDDR TL)) (FMEMB (CADDDR TL) NVARS) (FMEMB (CADDDR TL) OKVARS] (* ;; "Kludge: Don't call DWIMIFY0? in previous conditional if called from RECORDSTATEMENT but do if in a declaration") (SETQ SETQTAIL (CDDDR TL)) (SETQ SETQPART (LIST (CAR TL) (CADDR TL))) (RETURN T))) DWIM (COND ((AND OKFNS (LISTP (CAR TL)) (FIXSPELL (CAAR TL) 70 (CONS 'SETQ OKFNS) NIL (CAR TL) NIL NIL NIL T)) (GO RETRY)) ((DWIMIFYREC TL (APPEND NVARS (OR VARSPLST OKVARS)) PARENT NIL INDECL) (GO RETRY)) (T (RECORDERROR 'P (CAR TL) PARENT]) (RECORDACCESS [LAMBDA (FIELD DATUM DEC TYPE NEWVALUE) (* lmm "21-MAR-82 18:19") (DECLARE (SPECVARS DATUM)) (PROG (RECS DECLST TEM DEF EXPR (FAULTFN 'TYPE-IN) (DWIMIFYFLG 'EVAL) VARS RECORDEXPRESSION BINDINGS) RETRY (COND ((LISTP FIELD) (COND ((NULL (CDR FIELD)) (SETQ FIELD (CAR FIELD)) (GO RETRY))) (UNCLISPTRAN FIELD) (SETQ DEF (RECORDCHAIN FIELD))) [[SETQ RECS (COND [DEC (COND ((RECDEC? DEC) (RECFIELDLOOK (LIST DEC) FIELD)) (T (RECORDERROR 1 DEC] (T (RECFIELDLOOK USERRECLST FIELD] (* ;  "RECFIELDLOOK returns a list of of declarations") (SETQ DEF (CHECKDEFS (for X in RECS join (ACCESSDEF4 (LIST FIELD) (RECORDECL X] ((SETQ TEM (FIXSPELL FIELD NIL (FIELDNAMESIN USERRECLST) NIL NIL NIL NIL NIL T)) (* ;  "Finally, attempt spelling correction") (SETQ FIELD TEM) (GO RETRY)) (T (SETQ DEF))) (COND ((NOT DEF) (RECORDERROR 7 FIELD))) (RETURN (EVAL (EMBEDPROG (MAKEACCESS DEF 'DATUM (SELECTQ TYPE ((NIL ffetch fetch FETCH FFETCH) (SETQ TYPE 'fetch) NIL) ((replace freplace /replace REPLACE FREPLACE /REPLACE) (SETQ TYPE 'replace) (LIST (KWOTE NEWVALUE))) (ERROR TYPE "not FETCH or REPLACE")) TYPE]) (RECORDFIELDNAMES [LAMBDA (RECORDNAME FLG) (* lmm "24-FEB-79 12:10") (PROG ([DECL (RECORDECL (OR (LISTP RECORDNAME) (RECLOOK RECORDNAME] VAL) [COND ((NULL FLG) (RETURN (RECORD.FIELDNAMES DECL))) ((EQ FLG 'DECL) (RETURN (RECORD.DECL DECL] (for S in (RECORD.SUBDECS DECL) do (SETQ VAL (CONS (RECORDFIELDNAMES S T) VAL))) (for X in (RECORD.FIELDINFO DECL) collect (SETQ VAL (CONS (CAR X) VAL))) (RETURN (CONS (RECORD.NAME DECL) VAL]) (RECEVAL [LAMBDA (FORM DATUM NEWVALUE FIELDNAME) (DECLARE (SPECVARS NEWVALUE DATUM FIELDNAME)) (* lmm "31-JUL-78 07:15") (* ASSERT%: ((REMOTE EVAL) DATUM  NEWVALUE FIELDNAME)) (AND FORM (COND ((AND (LISTP FORM) (NEQ (CAR FORM) 'LAMBDA)) (EVAL FORM)) (T (APPLY* FORM DATUM NEWVALUE FIELDNAME]) (FIELDLOOK [LAMBDA (FIELDNAME) (RECFIELDLOOK USERRECLST FIELDNAME]) (SIMPLEP [LAMBDA (X N) (* lmm " 3-Jul-85 12:24") (* ;; "is it worth it to bind a variable if this is being computed twice? --- returns N-{complexity} or NIL") (OR N (SETQ N 3)) (COND ((OR (NLISTP X) (CONSTANTEXPRESSIONP X)) N) ((GETP (CAR X) 'CROPS) (AND [NOT (MINUSP (SETQ N (IDIFFERENCE N (LENGTH (GETP (CAR X) 'CROPS] (SIMPLEP (CADR X) N))) (T (SELECTQ (CAR X) (PROGN (AND [EVERY (CDR X) (FUNCTION (LAMBDA (Z) (SETQ N (SIMPLEP Z N] N)) ((fetch FFETCH) (AND CLISPARRAY (SETQ X (GETHASH X CLISPARRAY)) (SIMPLEP X N))) NIL]) (RECORDBINDVAL [LAMBDA (VAL) (COND ((SIMPLEP VAL 3) VAL) (T (RECORDBIND VAL]) (RECORDPRIORITY [LAMBDA (RECNAME PRIORITY) (* rmk%: "30-JUN-82 23:21") (* ;; "This is hackish--shouldn't really smash the user's declaration, cause it might be of a different form given by his own translation function.") (PROG (TRAN PREV (DECL (RECLOOK RECNAME))) (SETQ TRAN (RECORDECL DECL)) (SETQ PREV (SELECTQ (RECORD.PRIORITY TRAN) (NIL 'USER) 'SYSTEM)) (SELECTQ PRIORITY (USER (COND ((NEQ PREV 'USER) (/DREMOVE (ASSOC 'SYSTEM DECL) DECL) (SET.RECORD.PRIORITY TRAN NIL)))) (SYSTEM [COND ((NEQ PREV 'SYSTEM) (/NCONC1 DECL (CONS 'SYSTEM)) (SET.RECORD.PRIORITY TRAN 'SYSTEM]) NIL) (RETURN PREV]) (RECORDACCESSFORM [LAMBDA (FIELD DATUM TYPE NEWVALUE) (* rrb "28-OCT-83 16:30") (* ;; "returns the form that results from a record access.") (PROG [EXP (TYPE (COND (TYPE (L-CASE TYPE)) (T 'fetch] (SETQ EXP (SELECTQ TYPE ((fetch ffetch) (LIST TYPE FIELD 'OF DATUM)) (LIST TYPE FIELD 'OF DATUM 'WITH NEWVALUE))) (RETURN (COMPILEUSERFN (CDR EXP) EXP]) ) (DEFINEQ (RECORDWORD [LAMBDA (WORD TL WORDTYPE) (* lmm "29-SEP-78 16:51") (PROG (NEWORD) (RETURN (COND ([AND (SETQ NEWORD (GETPROP WORD 'CLISPWORD)) (EQ (CAR NEWORD) (OR WORDTYPE 'RECORDTRAN] [COND [(LISTP (CDR NEWORD)) (SETQ NEWORD (CADR NEWORD)) (SETQ WORD (RECORDWORD (CADDR NEWORD] (T (SETQ WORD (SETQ NEWORD (CDR NEWORD] (AND LCASEFLG TL NEWORD (NEQ (CAR TL) NEWORD) (/RPLACA TL NEWORD)) WORD]) (MAKECREATE0 [LAMBDA (RECORD.TRAN HASHLINKS NEEDACELL) (* lmm "23-SEP-78 02:08") (PROG ((FIELDINFO (RECORD.FIELDINFO RECORD.TRAN))) (RETURN (MAKECREATE1 (CAR (RECORD.CREATEINFO RECORD.TRAN)) (CDR (RECORD.CREATEINFO RECORD.TRAN)) NEEDACELL]) (MAKECREATE1 [LAMBDA (TYPE CREATEINFO NEEDACELL) (* ; "Edited 21-Jul-88 18:14 by jrb:") (PROG (DEF TEM TEM3 VAL SMASHFIELDS (USINGTYPE USINGTYPE) BINDINGS (CKVALFLG T)) (AND HASHLINKS (SETQ NEEDACELL T)) [if (EQ USINGTYPE 'smashing) then (SETQ DEF (SELECTQ TYPE (RECORD (if (LISTP CREATEINFO) then (SMASHPATTERN USINGEXPR CREATEINFO) else (MAKECREATELST CREATEINFO USINGEXPR NEEDACELL))) (TYPERECORD (SMASHPATTERN USINGEXPR CREATEINFO (LIST 'QUOTE (CAR CREATEINFO)))) (ARRAYRECORD [SETQ SMASHFIELDS (DREVERSE (for FIELD in (CREATEFIELDS (CDR CREATEINFO)) when (NEQ (SETQ VAL (GETFIELDFORCREATE FIELD USINGEXPR T T USINGTYPE NIL T)) MSBLIP) collect (LIST FIELD VAL] USINGEXPR) ((ARRAYBLOCK DATATYPE) (SETQ DEF USINGEXPR) (for FIELD in (DREVERSE (CREATEFIELDS (CADR CREATEINFO))) when (NEQ (SETQ VAL (GETFIELDFORCREATE FIELD USINGEXPR 0 T USINGTYPE (CADDR CREATEINFO))) MSBLIP) do (SETQ DEF (LIST (COND ((NULL CKVALFLG) 'FREPLACEFIELDVAL) (T (SETQ CKVALFLG) 'REPLACEFIELDVAL)) [KWOTE (CDDR (ASSOC FIELD (CDDDR CREATEINFO] DEF VAL))) DEF) (CCREATE (* ; "a form to be evaluated") (PROG (FIELD.USAGE [SPECIALFIELDS (COPY '((DATUM CREATE) (OLDDATUM USING] (DECLST '(FAST)) VAR1 (SUBSTYPE 'CREATE)) [SETQ DEF (CSUBST (COND ((EQ TYPE 'CCREATE) (EVAL (CAR CREATEINFO))) (T (CAR CREATEINFO] [COND ((EQ (CADAR SPECIALFIELDS) 'CREATE) (* ;; "if this wasn't an 'advice' -- i.e. if didn't do the regular create when we saw DATUM , then need to make sure that the using/copying/default fields are incorporated") (SETQ SMASHFIELDS (for X in FIELDINFO when (NOT (OR (NULL (CAR X)) (ASSOC (CAR X) FIELD.USAGE) (ASSOC (CAR X) FIELDS.IN.CREATE) (EQ (SETQ TEM (GETFIELDFORCREATE (CAR X) USINGEXPR NIL T (SELECTQ USINGTYPE (reusing 'using) USINGTYPE))) MSBLIP))) collect (LIST (CAR X) TEM] (RETURN (EMBEDPROG DEF)))) (GO SMASHING))) else (SETQ DEF (SELECTQ TYPE (RECORD (MAKECREATELST CREATEINFO USINGEXPR NEEDACELL)) (TYPERECORD (COND ((NEQ MSBLIP (SETQ TEM (MAKECREATELST (CDR CREATEINFO) (AND USINGEXPR (SETQ TEM3 (LIST 'CDR USINGEXPR))) NEEDACELL))) (LIST 'CONS (KWOTE (CAR CREATEINFO)) TEM)) (T MSBLIP))) ((PROPRECORD ASSOCRECORD) (SELECTQ USINGTYPE ((NIL reusing) (SETQ TEM (for X in (CREATEFIELDS CREATEINFO) when (NEQ [SETQ TEM3 (GETFIELDFORCREATE X USINGEXPR 'NOTNIL T (AND USINGTYPE 'reusing] MSBLIP) collect (CONS X TEM3)))) NIL) (* ;; "GETFIELDFORCREATE returns MSBLIP if USINGTYPE = (QUOTE reusing) and the field does not occur. All other reusing types are handled later, thus USINGTYPE is re-bound") (* ;; "TEM is the list of VALUES specified, where FIELD_VAL is included; plain USING expressions are not, and only non-nil universal defaults are handled, but explicit defaults are there") [SELECTQ USINGTYPE (NIL [COND ((NULL TEM) (* ;; "You cannot create an assocrecord or proprecord with NO fields, since the value would be NIL and you couldn't smash into it. Thus, a dummy FIELD_NIL is inserted") (SETQ TEM (LIST (CONS (CAR CREATEINFO) NIL] [CONS 'LIST (COND [(EQ TYPE 'ASSOCRECORD) (for X in (DREVERSE TEM) collect (LIST 'CONS (KWOTE (CAR X)) (CDR X] (T (for X in (DREVERSE TEM) join (LIST (KWOTE (CAR X)) (CDR X]) (reusing (COND (TEM (* ;; "This says that if you are REUSING an ASSOCRECORD, just CONS the new entries onto the beginning. This is not good if you do a lot of CREATE REUSING's, but , oh well") [for X in TEM do (SETQ USINGEXPR (SELECTQ TYPE (ASSOCRECORD (LIST 'CONS (LIST 'CONS (KWOTE (CAR X)) (CDR X)) USINGEXPR)) (PROPRECORD (LIST 'CONS (KWOTE (CAR X)) (LIST 'CONS (CDR X) USINGEXPR))) (SHOULDNT] USINGEXPR) (NEEDACELL (LIST 'APPEND USINGEXPR)) (T MSBLIP))) (PROGN (* ;; "otherwise, we just copy the 'using' expression appropriately and smash in the fields given in the create later") (SELECTQ USINGTYPE (copying (CONS (FUNCTION COPYALL) (LIST USINGEXPR))) (COND [(EQ TYPE 'ASSOCRECORD) (LIST 'MAPCAR USINGEXPR '(FUNCTION (LAMBDA (X) (CONS (CAR X) (CDR X] (T (CONS (FUNCTION APPEND) (LIST USINGEXPR]) (ATOMRECORD (SELECTQ USINGTYPE ((NIL reusing) (SETQ TEM (for X in (CREATEFIELDS CREATEINFO) when (NEQ [SETQ TEM3 (GETFIELDFORCREATE X USINGEXPR 'NOTNIL T (AND USINGTYPE 'reusing] MSBLIP) collect (LIST X TEM3)))) NIL) (* ;; "GETFIELDFORCREATE returns MSBLIP if USINGTYPE = (QUOTE reusing) and the field does not occur. All other reusing types are handled later, thus USINGTYPE is re-bound") (* ;; "TEM is the list of VALUES specified, where FIELD_VAL is included; plain USING expressions are not, and only non-nil universal defaults are handled, but explicit defaults are there") (SETQ DEF '(GENSYM)) (SELECTQ USINGTYPE (NIL (SETQ SMASHFIELDS TEM) DEF) (LIST 'PROGN [LIST 'SETPROPLIST (SETQ DEF (RECORDBIND DEF)) (SELECTQ USINGTYPE (copying (CONS (FUNCTION COPYALL) (LIST (LIST 'GETPROPLIST USINGEXPR)))) (CONS (FUNCTION APPEND) (LIST (LIST 'GETPROPLIST USINGEXPR] DEF))) (ARRAYRECORD [SETQ SMASHFIELDS (DREVERSE (for FIELD in (CREATEFIELDS (CDR CREATEINFO)) when (NEQ (SETQ VAL (GETFIELDFORCREATE FIELD USINGEXPR T T USINGTYPE)) MSBLIP) collect (LIST FIELD VAL] (SELECTQ USINGTYPE ((using reusing) (COND ((OR SMASHFIELDS NEEDACELL) (SETQ SMASHFIELDS) (SETQ CKVALFLG) (LIST 'COPYARRAY USINGEXPR)) (T (RETURN MSBLIP)))) (copying (SETQ SMASHFIELDS) (LIST 'COPYALL USINGEXPR)) (NIL (SETQ SMASHFIELDS (SUBSET SMASHFIELDS (FUNCTION CADR))) (SETQ CKVALFLG) (LIST 'ARRAY (CAR CREATEINFO))) (SHOULDNT))) ((ARRAYBLOCK DATATYPE) [SETQ DEF (SELECTQ USINGTYPE (copying (LIST 'COPYALL USINGEXPR)) (COND [(EQ TYPE 'ARRAYBLOCK) (SETQ CKVALFLG) (COND (USINGTYPE (LIST 'COPYARRAY USINGEXPR)) (T (LIST 'ARRAY (CAAR CREATEINFO) (CDAR CREATEINFO] (T (SETQ CKVALFLG) (CONS 'NCREATE (CONS (KWOTE (CAR CREATEINFO)) (AND USINGTYPE (LIST USINGEXPR] (for FIELD in (DREVERSE (CREATEFIELDS (CADR CREATEINFO))) when (NEQ (SETQ VAL (GETFIELDFORCREATE FIELD USINGEXPR 0 T (SELECTQ USINGTYPE (NIL USINGTYPE) 'reusing) (CADDR CREATEINFO))) MSBLIP) do (SETQ DEF (LIST (COND ((NULL CKVALFLG) 'FREPLACEFIELDVAL) (T (SETQ CKVALFLG) 'REPLACEFIELDVAL)) [KWOTE (CDDR (ASSOC FIELD (CDDDR CREATEINFO] DEF VAL))) (COND ((AND (NOT NEEDACELL) (EQ USINGTYPE 'reusing) (NEQ (CAR DEF) 'FREPLACEFIELD)) (RETURN MSBLIP))) DEF) ((CREATE CCREATE) (* ;  "a form to be subst'd or evaluated") (PROG (FIELD.USAGE [SPECIALFIELDS (COPY '((DATUM CREATE) (OLDDATUM USING] (DECLST '(FAST)) VAR1 (SUBSTYPE 'CREATE)) [SETQ DEF (CSUBST (COND ((EQ TYPE 'CCREATE) (EVAL (CAR CREATEINFO))) (T (CAR CREATEINFO] [COND ((EQ (CADAR SPECIALFIELDS) 'CREATE) (* ;; "if this wasn't an 'advice' -- i.e. if didn't do the regular create when we saw DATUM , then need to make sure that the using/copying/default fields are incorporated") (SETQ SMASHFIELDS (for X in FIELDINFO when (NOT (OR (NULL (CAR X)) (ASSOC (CAR X) FIELD.USAGE) (ASSOC (CAR X) FIELDS.IN.CREATE) (EQ (SETQ TEM (GETFIELDFORCREATE (CAR X) USINGEXPR NIL T (SELECTQ USINGTYPE (reusing 'using) USINGTYPE))) MSBLIP))) collect (LIST (CAR X) TEM] (RETURN (EMBEDPROG DEF)))) (RECORDERROR 'CREATE TYPE RECORDEXPRESSION] EXIT [COND (SMASHFIELDS (PROG (BINDINGS (DECLST (CONS (OR CKVALFLG 'FAST) DECLST))) [SETQ DEF (LIST (SETQ TEM (RECORDBINDVAL DEF] (for X in (REVERSE SMASHFIELDS) do (SETQ DEF (CONS (MAKEACCESS (CAR (ACCESSDEF4 (LIST (CAR X)) RECORD.TRAN)) TEM (CDR X) 'replace) DEF)) (FRPLACA DECLST 'FAST)) (SETQ DEF (EMBEDPROG (MKPROGN DEF] [RETURN (EMBEDPROG (COND (HASHLINKS (MAKEHASHLINKS DEF HASHLINKS)) (T DEF] SMASHING (SETQ DEF USINGEXPR) [SETQ SMASHFIELDS (for FIELD in FIELDINFO collect (LIST (CAR FIELD) (GETFIELDFORCREATE (CAR FIELD) NIL T] (GO EXIT]) (CREATEFIELDS [LAMBDA (FIELDS) (* lmm "13-Mar-85 16:12") (NCONC [SUBSET FIELDS (FUNCTION (LAMBDA (X) (NOT (ASSOC X FIELDS.IN.CREATE] (for X in FIELDS.IN.CREATE when (FMEMB (CAR X) FIELDS) collect (CAR X]) (REBINDP [LAMBDA (OB EXP) (* lmm "31-JUL-78 01:21") (* ;; "do any of the elements of OB occur anywhere inside EXP") (COND ((NLISTP EXP) (AND EXP (FMEMB EXP OB))) (T (OR (REBINDP OB (CAR EXP)) (REBINDP OB (CDR EXP]) (CSUBST [LAMBDA (X) (* lmm "13-Mar-85 16:12") (PROG (TEM TEM2) (RETURN (COND ((NLISTP X) (COND ((SETQ TEM (ASSOC X SPECIALFIELDS)) (SELECTQ (CADR TEM) (2 (* ; "already SIMPLE") (CDDR TEM)) (1 (* ;  "second time seen --- make sure form is SIMPLE") (FRPLACA (CDR TEM) 2) [FRPLNODE (CDDR TEM) 'PROGN (LIST (SETQ TEM2 (RECORDBIND (COPY1 (CDDR TEM] TEM2) (PROGN (SETQ TEM2 (SELECTQ (CADR TEM) (CREATE (MAKECREATE1 (CADR CREATEINFO) (CDDR CREATEINFO))) (USING USINGEXPR) (DATUM (CAR ARGS)) (NEWVALUE (CADR ARGS)) (PARENT BODY) (SHOULDNT))) (FRPLNODE (CDR TEM) (COND ((SIMPLEP TEM2) 2) (T (SETQ TEM2 (LIST 'PROGN TEM2)) 1)) TEM2) TEM2))) ((FMEMB X FIELDNAMES) (SELECTQ SUBSTYPE (CREATE (RECORD.FIELD.VALUE0 X)) (WITH (MAKEACCESS (CAR (ACCESSDEF4 (LIST X) RECORD.TRAN)) USINGEXPR NIL 'fetch)) (SHOULDNT))) (T X))) [[LISTP (SETQ TEM (GETP (CAR X) 'CLISPWORD] (SELECTQ (CDR TEM) ((type? the) (RECONS (CAR X) (RECONS (CADR X) (CSUBSTLST (CDDR X)) (CDR X)) X)) (create (* ;  "should do better but punt for now") (PROG ((VAL (LIST (CAR X) (CADR X))) (X (CDDR X))) LP [COND ((NLISTP X) (RETURN VAL)) ((EQ (CADR X) '_) [NCONC VAL (LIST (CAR X) (CADR X) (CSUBST (CADDR X] (SETQ X (CDDDR X))) ((RECORDWORD (CAR X)) [NCONC VAL (LIST (CAR X) (CSUBST (CADR X] (SETQ X (CDDR X))) (T (NCONC1 VAL (CSUBST (CAR X))) (SETQ X (CDR X] (GO LP))) (SELECTQ (CAR TEM) ((RECORDTRAN RECORDWORD) (RECONS (CAR X) (RECONS (CADR X) (CSUBSTLST (CDDR X)) (CDR X)) X)) (MATCHWORD [PROG NIL (DWIMIFYREC (LIST X) NIL RECORDEXPRESSION) (RETURN (CSUBST (OR (GETHASH X CLISPARRAY) (RETURN (RECONS (CAR X) (RECONS (CSUBST (CADR X)) (CDDR X) (CDR X)) X]) (PROGN (* ; "some other clisp word") (RECONS (CAR X) (CSUBSTLST (CDR X)) X] ((EQ (CAR X) 'QUOTE) X) ((AND (LISTP (CAR X)) (EQ (CAAR X) 'LAMBDA)) (SETQ TEM (CSUBSTLST (CDR X))) (RECONS (RECONS (CAAR X) (RECONS (CADAR X) (CSUBSTLST (CDDAR X)) (CDAR X)) (CAR X)) TEM X)) ((SELECTQ SUBSTYPE (WITH (AND (EQ (CAR X) 'SETQ) (FMEMB (CADR X) FIELDNAMES) (MAKEACCESS (CAR (ACCESSDEF4 (LIST (CADR X)) RECORD.TRAN)) USINGEXPR (CSUBSTLST (CDDR X)) 'replace))) (REPLACE (RECONS (RECLISPLOOKUP (CSUBST (CAR X)) DECLST (CAR ARGS)) (CSUBSTLST (CDR X)) X)) (CHANGE [COND ([OR (EQ (CAR (SETQ TEM X)) 'DATUM_) (AND (EQ (CAR X) 'SETQ) (EQ (CAR (SETQ TEM (CDR X))) 'DATUM] (COPY1 (SUBPAIR 'NEWVALUE (MKPROGN (CSUBSTLST (CDR TEM))) (CADDR ARGS]) NIL)) (T (RECONS (CSUBST (CAR X)) (CSUBSTLST (CDR X)) X]) (RECONS [LAMBDA (X Y C) (* lmm "11-AUG-78 10:20") (COND ((AND (EQ X (CAR C)) (EQ Y (CDR C))) C) (T (CONS X Y]) (COPY1 [LAMBDA (X) (* lmm "31-JUL-78 04:11") (COND ((LISTP X) (CONS (CAR X) (CDR X))) (T (LIST 'PROGN X]) (CSUBSTLST [LAMBDA (X) (* lmm "11-AUG-78 10:26") (COND ((NLISTP X) (AND X (CSUBST X))) (T (RECONS (CSUBST (CAR X)) (CSUBSTLST (CDR X)) X]) (RECORD.FIELD.VALUE [LAMBDA (FIELDNAME) (* lmm "13-Mar-85 16:12") (PROG (TMP) (RETURN (COND ((SETQ TMP (ASSOC FIELDNAME FIELDS.IN.CREATE)) (CADR TMP)) (T (GETFIELDFORCREATE FIELDNAME USINGEXPR T T USINGTYPE]) (RECORD.FIELD.VALUE0 [LAMBDA (FIELDNAME) (* lmm "31-JUL-78 03:00") (CDAR (SETQ FIELD.USAGE (CONS (CONS FIELDNAME (GETFIELDFORCREATE FIELDNAME USINGEXPR T T USINGTYPE)) FIELD.USAGE]) (MAKECREATELST [LAMBDA (TEMPLATE USING NEEDACELL) (* lmm "22-AUG-84 23:15") (* ;; "Make the create expression for regular RECORD declaration (i.e. LISTRECORDS)") (MAKECREATELST1 TEMPLATE T USING NEEDACELL]) (SMASHPATTERN [LAMBDA (X PATTERN CARVAL EFF) (* lmm "23-AUG-84 00:27") (if (LITATOM X) then (CONS 'PROGN (SMASHPAT1 PATTERN X CARVAL EFF)) else ([LAMBDA (XV) `([LAMBDA (%, XV) ., (SMASHPAT1 PATTERN XV CARVAL EFF] %, X] (RECORDGENSYM]) (SMASHPAT1 [LAMBDA (PATTERN XV CARVAL EFF) (* lmm "23-AUG-84 00:26") (LIST* (if (NLISTP (CAR PATTERN)) then `(RPLACA %, XV %, (OR CARVAL (GETFIELDFORCREATE (CAR PATTERN) (LIST 'CAR XV) T))) else (SMASHPATTERN `(CAR %, XV) (CAR PATTERN) NIL T)) (if (NLISTP (CDR PATTERN)) then `(RPLACD %, XV %, (AND (CDR PATTERN) (GETFIELDFORCREATE (CDR PATTERN) (LIST 'CDR XV) T))) else (SMASHPATTERN `(CDR %, XV) (CDR PATTERN) NIL T)) (AND (NOT EFF) (LIST XV]) (MAKECREATELST1 [LAMBDA (TEMPLATE CARFLG USING NEEDACELL) (* lmm "22-AUG-84 23:15") (* ;; "Make the create expression for regular RECORD declaration (i.e. LISTRECORDS)") (COND [(NLISTP TEMPLATE) (COND ((AND (NULL TEMPLATE) (NOT NEEDACELL)) MSBLIP) (T (GETFIELDFORCREATE TEMPLATE USING (OR TEMPLATE CARFLG) NIL USINGTYPE] ([AND CARFLG (EQ COMMENTFLG (CAR (LISTP (CAR TEMPLATE] (HELP) (MAKECREATELST1 (CDR TEMPLATE) CARFLG USING NEEDACELL)) (T [COND ((SMALLP (CAR TEMPLATE)) (SETQ TEMPLATE (NCONC (to (CAR TEMPLATE) collect NIL) (CDR TEMPLATE] (PROG [(AU (AND USING (LIST 'CAR USING))) (DU (AND USING (LIST 'CDR USING] (RETURN (PROG ((A (MAKECREATELST1 (CAR TEMPLATE) T AU)) (D (MAKECREATELST1 (CDR TEMPLATE) NIL DU))) (RETURN (COND ((AND (NOT NEEDACELL) (EQ A MSBLIP) (EQ D MSBLIP)) MSBLIP) (T (LIST 'CONS (COND ((EQ A MSBLIP) AU) (T A)) (COND ((EQ D MSBLIP) DU) (T D]) (GETFIELDFORCREATE [LAMBDA (RNAME USINGEXPR USEUNIVDEFAULT COMPOSEWITHUSING USETYPE TOPDEFAULTS NOPOSTPROCESSING) (* ; "Edited 21-Jul-88 17:20 by jrb:") (* ;; "Returns the value which should go into the place of record field NAME; e.g. in (create (RECORD (A . B)) B_ (FOO)) should return the expression (FOO) for B --- If the field is NOT specified (the free var FIELDS.IN.CREATE is an alist of the fields given in the original CREATE expression) then, if USINGTYPE (i.e. a using or copying expression occured) obtain the value from USINGEXPR (unless COMPOSEWITHUSING in which case it is USINGEXPR:NAME) --- If the field wasn't specified, and there is no USINGTYPE, then return either NIL or MSBLIP depending on whether USEUNIVDEFAULT is T or NIL") (* ;; "Note that USETYPE is used rather than USINGTYPE because some types of record expressions (PROPRECORD for one) wish to temporarily rebind USINGTYPE for this level only") (PROG (TEM VALUE (DEFAULTS (RECORD.DEFAULTFIELDS RECORD.TRAN)) DEFFLG) [COND ((AND USETYPE COMPOSEWITHUSING) (* ;  "i.e. compute USINGEXPR:RECORDNAME") (SETQ USINGEXPR (MAKEACCESS (CAR (ACCESSDEF4 (LIST RNAME) RECORD.TRAN)) USINGEXPR NIL 'fetch] [COND [(SETQ VALUE (ASSOC RNAME FIELDS.IN.CREATE)) (* ;; "Return the entire item in the association list; the post-processing done to make sure fields are in the same order as in the original CREATE will change this item to the actual value") (* ;; "JRB - HACK! GETFIELDFORCREATE is called by MAKECREATE1 in a place where there will be no postprocessing (the ordering hack is done by CREATEFIELDS).") (AND NOPOSTPROCESSING (SETQ VALUE (CADR VALUE] [(AND USETYPE (NEQ USETYPE 'smashing)) (SETQ VALUE (OR (SUBFIELDCREATE MSBLIP) (SELECTQ USETYPE (reusing MSBLIP) (copying (LIST 'COPYALL USINGEXPR)) USINGEXPR] ((SETQ TEM (ASSOC RNAME DEFAULTS)) (* ;  "Is there a specific default for this field?") (SETQ DEFFLG T) (SETQ VALUE (CADR TEM))) (T (RETURN (OR (SUBFIELDCREATE MSBLIP) (PROGN (SETQ TEM (ASSOC 'DEFAULT DEFAULTS)) (SELECTQ USEUNIVDEFAULT (0 (COND ((EQ USINGTYPE 'smashing) (CDR (ASSOC RNAME TOPDEFAULTS))) (T MSBLIP))) (NOTNIL (OR (CADR TEM) MSBLIP)) (NIL MSBLIP) (CADR TEM] (RETURN (OR (SUBFIELDCREATE VALUE DEFFLG) VALUE]) (SUBFIELDCREATE [LAMBDA (VAL DFLT) (* lmm "13-Mar-85 16:12") (PROG (TEM SUBDECL SUBTRAN HL) (SETQ HL (for DEC in (SUBDECLARATIONS RECORD.TRAN) when [AND (EQ (RECORD.NAME (SETQ TEM (RECORDECL0 DEC))) RNAME) (OR (EQ (CAR (RECORD.CREATEINFO TEM)) 'HASHRECORD) (COND ((NULL SUBDECL) (* ;  "set SUBDECL and SUBTRAN to FIRST sub-declaration for this field, collecting HL separately") (SETQ SUBDECL DEC) (SETQ SUBTRAN TEM) NIL] collect TEM)) (* ;; "Then create the sub-record, putting on both the embedded hashlinks and the one from this record: e.g. (create (RECORD A (B . C) (HASHRECORD B (RECORD (E . F))) (RECORD B (D . G) (HASHRECORD (FOO) DEFAULT _ (CONS)))))") (* ;; "the VAL arg is what was given for the field in the create .. e.g. (RECORD A (B . C) (HASHLINK B FOO)) need both the value given for B and the value given for FOO") [COND ([OR (EQ VAL MSBLIP) (AND DFLT (SOME (RECORD.FIELDNAMES SUBTRAN) (FUNCTION (LAMBDA (X) (ASSOC X FIELDS.IN.CREATE] (* ;  "if this field was not specified, then we do an implicit CREATE on the subdeclaration, if any") (OR (NULL SUBTRAN) (EQ (SETQ TEM (MAKECREATE0 SUBTRAN)) MSBLIP) (SETQ VAL TEM] (RETURN (COND ((NULL HL) (AND (NEQ VAL MSBLIP) VAL)) ((EQ VAL MSBLIP) (* ;  "Since the field has no content, the hashlink cannot either") NIL) (T (MAKEHASHLINKS VAL HL]) (MAKEHASHLINKS [LAMBDA (DEF TRANS) (* lmm " 5-OCT-78 05:41") (PROG (TEM TEM2 BINDINGS) (COND ((NULL TRANS) (RETURN DEF))) [SETQ TEM2 (for RECORD.TRAN in TRANS when (SETQ TEM (GETFIELDFORCREATE (CADR (RECORD.CREATEINFO RECORD.TRAN)) USINGEXPR T T (SELECTQ USINGTYPE (reusing 'using) USINGTYPE))) collect (COND ((EQ USINGTYPE 'smashing) TEM) (T (CONS 'PUTHASH (CONS (SETQ DEF (RECORDBINDVAL DEF)) (CONS TEM (CDDR (RECORD.CREATEINFO RECORD.TRAN] (RETURN (EMBEDPROG (MKPROGN (DREVERSE (CONS DEF TEM2]) (HASHLINKS [LAMBDA (TRAN) (* lmm " 7-OCT-77 15:50") (for DEC in (SUBDECLARATIONS TRAN) bind DEC1 when (SELECTQ [CAR (RECORD.CREATEINFO (SETQ DEC1 (RECORDECL DEC] (HASHRECORD (OR (NULL (RECORD.NAME DEC1)) (EQ (RECORD.NAME TRAN) (RECORD.NAME DEC1)))) NIL) collect DEC1]) (RECLOOK [LAMBDA (RECNAME TL LOCALDEC PARENT ERROR) (* lmm " 7-AUG-84 23:23") (* ;; "Look for a declaration of a record named RECNAME") (OR (COND ((NULL RECNAME) NIL) [(NLISTP RECNAME) (CAR (OR (RECLOOK1 RECNAME LOCALDEC) (RECLOOK1 RECNAME USERRECLST] ((RECDEC? RECNAME) RECNAME)) (AND ERROR (PROG (TEM) (AND TL (SETQ TEM (FIXSPELL RECNAME 70 [NCONC [MAPCONC LOCALDEC (FUNCTION (LAMBDA (X) (AND (SETQ X (RECORDECL X)) (LIST (RECORD.NAME X] (MAPCAR USERRECLST (FUNCTION (LAMBDA (DEC) (RECORD.NAME (RECORDECL DEC] " -> " TL NIL NIL NIL T)) (RETURN (RECLOOK TEM NIL LOCALDEC PARENT NIL))) (PROG ((FAULTFN)) (RECORDERROR 'NAME RECNAME PARENT]) (ALLFIELDS [LAMBDA (TRAN) (* lmm " 5-SEP-83 13:09") (NCONC [for Y in (RECORD.SUBDECS TRAN) when (EQ (CAR Y) 'SUBRECORD) join (APPEND (ALLFIELDS (RECORDECL (RECLOOK (CADR Y) NIL DECLST Y T] (RECORD.FIELDNAMES TRAN]) (SUBDECLARATIONS [LAMBDA (TRAN) (* lmm " 7-OCT-77 16:46") (for Y in (RECORD.SUBDECS TRAN) collect [COND ((EQ (CAR Y) 'SUBRECORD) (PROG ((TEM (RECLOOK (CADR Y) NIL DECLST Y T))) (SETQ Y (COND [(CDDR Y) (COND ((EQ (CAR TEM) CLISPTRANFLG) (CDDR TEM)) (T (APPEND TEM (CDDR Y] (T TEM] Y]) ) (DEFINEQ (CLISPRECORD [LAMBDA (E FIELD SETQFLG) (* lmm "13-OCT-78 01:57") (* ;; "This is the entry to the record package for fetch and replace statements as well as for direct inputs like X:FIELD and X:FIELD_VALUE.") (PROG ((DECLST (GETLOCALDEC EXPR FAULTFN))) (RETURN (COND [SETQFLG (COND ((AND FIELD (NLISTP FIELD)) (* ; "X : FIELD input") (* ;  "X:FIELD_expression is done in two passes; this is the first") (AND (OR (RECORDFIELD? FIELD DECLST) (AND DECLST (RECORDFIELD? FIELD))) (LIST 'REPLACE FIELD (COND (LCASEFLG 'of) (T 'OF)) E))) ((NEQ (CAR E) 'REPLACE) (SHOULDNT)) (T (* ;  "This is the second pass of the X:FIELD_expression input") (RECORDTRAN (NCONC [FRPLACA E (RECLISPLOOKUP (COND (LCASEFLG 'replace) (T 'REPLACE] (CONS (COND (LCASEFLG 'with) (T 'WITH)) FIELD] (T (RECORDTRAN (CONSFN (COND (LCASEFLG 'fetch) (T 'FETCH)) (LIST FIELD (COND (LCASEFLG 'of) (T 'OF)) E]) (ACCESSDEF [LAMBDA (FIELD V1 TL CFLG) (* lmm "22-MAY-80 21:35") (PROG (RECS CHRLST DOTTAIL TEM FIELDLST) RETRY (COND ([AND (LISTP FIELD) (FMEMB (RECORDWORD (CAR FIELD)) '(fetch FETCH] (RETURN))) [COND ([AND [OR (NLISTP FIELD) (AND (NULL (CDR FIELD)) (SETQ FIELD (CAR FIELD] (SETQ RECS (OR (RECFIELDLOOK DECLST FIELD V1) (RECFIELDLOOK USERRECLST FIELD] (* ;  "RECFIELDLOOK returns a list of of declarations") (RETURN (CHECKDEFS (for DEC in RECS join (ACCESSDEF4 (LIST FIELD) (RECORDECL DEC))) RECS FIELD T] [COND ((LISTP FIELD) (RETURN (RECORDCHAIN FIELD] (AND (NOT CFLG) (COND [(SETQ TEM (GETP FIELD 'ACCESSFN)) (* ; "CFLG says it is from a CREATE") (SETQ NOTRANFLG T) (RETURN (LIST (LIST 'ACCESSFNS FIELD TEM (GETP TEM 'SETFN] ((AND [SETQ TEM (FMEMB '%: (SETQ CHRLST (UNPACK FIELD] (NEQ TEM CHRLST)) [/RPLNODE TL (SETQ FIELD (PACK (CDR TEM))) (CONS 'OF (CONS (SETQ V1 (PACK (LDIFF CHRLST TEM))) (CDR TL] (GO RETRY)) [(SETQ DOTTAIL (FMEMB '%. CHRLST)) (* ;; "check if FIELD contains a . within it, e.g. AB.CD. TL must be the tail of the input expression starting with FIELD") (RETURN (PROG1 [RECORDCHAIN (SETQ FIELDLST (PROG ((TEM DOTTAIL) R)(* ;  "collect the atoms with .'s removed e.g. A.B.CD.E -> (A B CD E)") LP [COND ((NULL TEM) (RETURN (NCONC1 R (COND ((CDR CHRLST) (PACK CHRLST)) (T (CAR CHRLST] [SETQ R (NCONC1 R (COND ((EQ (CDR CHRLST) TEM) (CAR CHRLST)) (T (PACK (LDIFF CHRLST TEM] [SETQ TEM (FMEMB '%. (SETQ CHRLST (CDR TEM] (GO LP] (FRPLACA (OR TL (SHOULDNT)) FIELDLST))] ((SETQ TEM (FIXSPELL FIELD 70 (NCONC (FIELDNAMESIN DECLST) (FIELDNAMESIN USERRECLST)) NIL TL NIL NIL NIL T)) (* ;  "Finally, attempt spelling correction") (SETQ FIELD TEM) (GO RETRY)) (T (RETURN]) (FIELDNAMESIN [LAMBDA (DECS) (* lmm "12-SEP-77 02:19") (MAPCONC DECS (FUNCTION (LAMBDA (X) (APPEND (RECORD.FIELDNAMES (RECORDECL X]) (ACCESSDEF4 [LAMBDA (LST TRAN TL) (* lmm "13-Mar-85 16:12") (PROG (TEM SUBDECS AVOID) (RETURN (COND [[SETQ TEM (CDR (ASSOC (CAR LST) (RECORD.FIELDINFO TRAN] (* ;; "The FIELDINFO part of the translation contains (fieldname type tokens) for TOP LEVEL fields --- this name (CAR LST) is declared in this declaration") [COND ([AND (NULL TL) (FMEMB 'CHECK (CDR (RECORD.TYPECHECK TRAN] (SETQ TL (CONS (CONS 'THE (RECORD.NAME TRAN)) TL] (COND ((NULL (CDR LST)) (LIST (JOINDEF TEM TL))) (T (OR (AND (SETQ SUBDECS (RECFIELDLOOK (RECORD.SUBDECS TRAN) (CADR LST))) (ALLPATHS (RECLOOK1 (CAR LST) SUBDECS) (CDR LST) (JOINDEF TEM TL))) (TOPPATHS (CAR LST) (CDR LST) (JOINDEF TEM TL] (T (* ;  "Found (CAR LST) in a sub-declaration") (for SUBDEC in (RECFIELDLOOK (RECORD.SUBDECS TRAN) (CAR LST)) join (ALLPATHS (LIST SUBDEC) LST (JOINDEF [CDR (OR (ASSOC (SETQ TEM (RECORD.NAME (RECORDECL SUBDEC))) (RECORD.FIELDINFO TRAN)) (COND ((OR (EQ TEM (RECORD.NAME TRAN)) (NULL TEM)) NIL) (T (SHOULDNT] TL]) (MAKEACCESS [LAMBDA (ACCESS BODY NEWVAL TYPE) (* lmm " 1-AUG-78 00:58") (COND ((NULL ACCESS) (SELECTQ TYPE (fetch BODY) (SHOULDNT))) (T (MAKEACCESS1 (CAAR ACCESS) (CDAR ACCESS) (MAKEACCESS (CDR ACCESS) BODY NIL 'fetch) NEWVAL TYPE BODY]) (MAKEACCESS1 [LAMBDA (RECTYPE SPEC DAT NEWVAL TYPE BODY) (* lmm "23-SEP-78 01:17") (COND ((AND (NEQ TYPE 'fetch) (EQ RECTYPE 'RECORD) (CDR SPEC)) (MAKEACCESS1 RECTYPE (LIST (CAR SPEC)) (MAKEACCESS1 RECTYPE (CDR SPEC) DAT NIL 'fetch) NEWVAL TYPE BODY)) ((EQ TYPE 'change) (LIST (MAKEACCESS1 RECTYPE SPEC (SETQ DAT (RECORDBINDVAL DAT)) NIL 'fetch) NIL (MAKEACCESS1 RECTYPE SPEC DAT NEWVAL 'replace BODY))) (T (SELECTQ RECTYPE (RECORD [SELECTQ TYPE (replace (COND ((CDR SPEC) (SHOULDNT))) (LIST (SELECTQ (CAR SPEC) (A 'CAR) (D 'CDR) (RECORDERROR 'REPLACE RECORDEXPRESSION)) (CONSFN (SELECTQ (CAR SPEC) (A 'RPLACA) 'RPLACD) (CONS DAT NEWVAL)))) (COND [(CDDDDR SPEC) (LIST (PACK* 'C (CAR SPEC) (CADR SPEC) (CADDR SPEC) (CADDDR SPEC) 'R) (MAKEACCESS1 RECTYPE (CDDDDR SPEC) DAT NIL 'fetch] ((NULL SPEC) DAT) (T (LIST [PACK (CONS 'C (APPEND SPEC (LIST 'R] DAT]) (HASHRECORD (SELECTQ TYPE (replace (CONSFN 'PUTHASH (CONS DAT (CONS (CAR NEWVAL) SPEC)))) (CONS 'GETHASH (CONS DAT SPEC)))) (ACCESSFNS (MKACCESSFN (SELECTQ TYPE (replace (CADDR SPEC)) (CADR SPEC)) (CONS DAT NEWVAL) TYPE (CAR SPEC))) (CACCESSFNS (MKACCESSFN (RECEVAL (SELECTQ TYPE (replace (CADDR SPEC)) (CADR SPEC)) DAT (MKPROGN (CAR NEWVALUE)) (CAR SPEC)) (CONS DAT NEWVAL) TYPE (CAR SPEC))) (PROPRECORD (CONSFN (SELECTQ TYPE (replace 'LISTPUT) 'LISTGET) (CONS DAT (CONS (KWOTE SPEC) NEWVAL)))) (ATOMRECORD (CONSFN (SELECTQ TYPE (replace 'PUTPROP) 'GETPROP) (CONS DAT (CONS (KWOTE SPEC) NEWVAL)))) (ASSOCRECORD [SELECTQ TYPE (replace (CONSFN 'PUTASSOC (CONS (KWOTE SPEC) (LIST (CAR NEWVAL) DAT)))) (LIST 'CDR (CONSFN 'ASSOC (LIST (KWOTE SPEC) DAT]) (ARRAYRECORD (CONSFN [SELECTQ TYPE (replace (COND ((LISTP SPEC) 'SETD) (T 'SETA))) (COND ((LISTP SPEC) 'ELTD) (T 'ELT] (CONS DAT (CONS (COND ((LISTP SPEC) (CDR SPEC)) (T SPEC)) NEWVAL)))) (DATATYPE (CONSFN (SELECTQ TYPE (replace 'REPLACEFIELD) 'FETCHFIELD) (CONS (KWOTE SPEC) (CONS DAT NEWVAL)))) (THE (SELECTQ TYPE (replace (SHOULDNT)) (LIST (COND ((FMEMB 'FAST DECLST) 'FTHE) (T 'THE)) SPEC DAT))) (SHOULDNT]) (MKACCESSFN [LAMBDA (FN ARGS TYPE FIELD) (* lmm "19-OCT-78 00:47") (COND ((NULL FN) (RECORDERROR (SELECTQ TYPE (replace 'REPLACE) 'FETCH) FIELD RECORDEXPRESSION))) (COND ((EQ FN 'DATUM) (CAR ARGS)) ((OR (NLISTP FN) (EQ (CAR FN) 'LAMBDA)) (CONSFN FN ARGS)) [(FMEMB (CAR FN) '(FAST STANDARD UNDOABLE)) [SETQ FN (CLISPLOOKUP0 NIL (CAR ARGS) (CADR ARGS) (OR DECLST '(DUMMY)) (CADR FN) 'DUMMY (LIST 'ACCESS (LISTGET FN 'STANDARD) (LISTGET FN 'UNDOABLE) (LISTGET FN 'FAST] (PROG ((DECLST (CONS 'STANDARD DECLST))) (RETURN (MKACCESSFN FN ARGS TYPE FIELD] (T (PROG (FIELDNAMES [SPECIALFIELDS (COPY '((DATUM DATUM) (NEWVALUE NEWVALUE) (PARENT PARENT] (SUBSTYPE 'REPLACE)) (RETURN (CSUBST FN]) (RECFIELDLOOK [LAMBDA (RECLST FIELD VAR EDITRECFLG) (* lmm "18-SEP-78 19:03") (* ;; "Looks up on either local or global declst for records relavant to field and var") (for Y in RECLST join (AND (LISTP Y) (COND ((EQ (CAR Y) 'RECORDS) (RECFIELDLOOK [MAPCAR (CDR Y) (FUNCTION (LAMBDA (X) (RECLOOK X] FIELD VAR)) ((EQ (CAR Y) 'SUBRECORD) (RECFIELDLOOK (LIST (RECLOOK (CADR Y))) FIELD VAR)) ((AND VAR (EQ (CAR Y) VAR)) (RECFIELDLOOK (CDR Y) FIELD)) ([OR (FMEMB FIELD (RECORD.FIELDNAMES (RECORDECL Y))) (AND EDITRECFLG (EQ FIELD (RECORD.NAME (RECORDECL Y] (LIST Y]) (RECORDCHAIN [LAMBDA (LST) (* lmm "23-SEP-78 02:08") (* ;; "Search for the sequence of record declarations which are for the sequence of field names given in LST. (e.g. if LST is (A B) will look for the declaration of A which contains B) Return the list of declarations. The name of each declaration (except the first) should be a field in the previous one") (CHECKDEFS (TOPPATHS (CAR LST) (CDR LST)) NIL LST T]) (RECLOOK1 [LAMBDA (RECNAME DECS AVOIDDECS) (* lmm%: "27-JUL-76 04:13:50") (* ;; "Search DECS for declaration with name RECNAME") (SUBSET DECS (FUNCTION (LAMBDA (DEC) (AND (NOT (FMEMB DEC AVOIDDECS)) (EQ (RECORD.NAME (RECORDECL DEC)) RECNAME]) (SYSRECLOOK1 [LAMBDA (RECNAME) (* rmk%: " 4-JAN-82 17:12") (* ;; "returns the declaration of a system record.") (DECLARE (GLOBALVARS SYSTEMRECLST)) (for D in SYSTEMRECLST when (EQ RECNAME (CADR D)) do (RETURN D]) (TOPPATHS [LAMBDA (FIELD LST TL DECS AVOID) (* lmm "25-AUG-78 13:41") (ALLPATHS (OR (RECLOOK1 FIELD DECS) (RECLOOK1 FIELD DECLST) (RECLOOK1 FIELD USERRECLST)) LST TL]) (ALLPATHS [LAMBDA (DECLS LST TL) (* lmm "24-FEB-79 12:08") (PROG (TRAN ANY DEFS DEC) (COND ((NULL DECLS) (RETURN))) (SETQ DEFS (for DEC in DECLS when [AND (NOT (FMEMB DEC AVOID)) (FMEMB (CAR LST) (RECORD.FIELDNAMES (SETQ TRAN (RECORDECL DEC] join (SETQ ANY T) (ACCESSDEF4 LST TRAN TL))) (RETURN (COND (ANY DEFS) (T (SETQ DEFS (APPEND DECLS AVOID)) (for DEC in DECLS when (NOT (FMEMB DEC AVOID)) join (NCONC (ALLPATHS (RECLOOK1 (RECORD.NAME (SETQ TRAN (RECORDECL DEC))) (RECORD.SUBDECS TRAN) AVOID) LST TL) (PROGN [COND ([AND (NULL TL) (FMEMB 'CHECK (CDR (RECORD.TYPECHECK TRAN] (SETQ TL (CONS (CONS 'THE (RECORD.NAME TRAN)) TL] (for PR in (RECORD.FIELDINFO TRAN) join (TOPPATHS (CAR PR) LST (JOINDEF (CDR PR) TL) (RECORD.SUBDECS TRAN) DEFS]) (CHECKDEFS [LAMBDA (DEFS RECS FIELDS MUST) (* rmk%: "30-JUN-82 23:10") (COND ([AND [SOME (CDR DEFS) (FUNCTION (LAMBDA (X) (NOT (EQUAL X (CAR DEFS] (OR (NULL RECS) (bind FOUND for D on DEFS as R in RECS unless (EQ (RECORD.PRIORITY (RECORDECL R)) 'SYSTEM) do (COND ((NOT FOUND) (SETQ FOUND D)) ((NOT (EQUAL (CAR D) (CAR FOUND))) (RETURN T))) finally (SETQ DEFS FOUND) (RETURN NIL] (RECORDERROR [CONS "ambiguous" (CONS (COND ((LISTP FIELDS) "path") (T "field")) (CONS "appears in" (for X in RECS join (LIST '" " (RETDWIM2 X] FIELDS RECORDEXPRESSION)) ((AND MUST (NULL DEFS)) (RECORDERROR 2 FIELDS RECORDEXPRESSION))) (CAR DEFS]) (JOINDEF [LAMBDA (DEF DEFLST) (* lmm%: "26-JUL-76 19:42:36") (COND ((NULL DEF) DEFLST) ([AND DEFLST (EQ (CAR DEF) 'RECORD) (OR (EQ (CAAR DEFLST) 'RECORD) (NULL (CDR DEF] (* ;; "If merging two RECORD expressions with CAR's and CDR's, do it here so that the ambiguous path checker can just use EQUAL") (* ;; "This also handles the case of 'synonym' records where there is just (RECORD A B)") (CONS (CONS (CAAR DEFLST) (NCONC (APPEND (CDR DEF)) (CDAR DEFLST))) (CDR DEFLST))) (T (CONS DEF DEFLST]) ) (DEFINEQ (NOTOKSWAP [LAMBDA (EXPR1 EXPR2) (* lmm " 3-Jul-85 12:36") (NOT (ARGS.COMMUTABLEP EXPR1 EXPR2]) (FIXFIELDORDER [LAMBDA (EXPRESSION) (* DECLARATIONS%: FAST) (* lmm " 3-Jul-85 12:36") (PROG (REVFIELDS LASTFIELDTAIL TEM FIELD.USAGE USE1 USE2 PLACE1 PLACE2 UNUSEDFIELDS) (FINDFIELDUSAGE EXPRESSION) (* ;; "The elements of FIELDS.IN.CREATE are entries of the form (field.name value.given.in.create . seen) where seen is NIL initially, the last 'place' field.name was") [for X in (REVERSE FIELDS.IN.CREATE) do (COND ((ASSOC (CAR X) FIELD.USAGE)) (T (SETQ UNUSEDFIELDS (CONS [CONS (CAR X) (SETQ TEM (LIST (CADR X] UNUSEDFIELDS)) (SETQ FIELD.USAGE (CONS (CONS (CAR X) TEM) FIELD.USAGE] LP (COND ((NULL FIELD.USAGE) (* ; "Done") (RETURN UNUSEDFIELDS))) [COND ((NOT (OR (CONSTANTEXPRESSIONP (CADAR FIELD.USAGE)) (ASSOC (CADAR FIELD.USAGE) BINDINGS))) (COND ([SETQ TEM (for X in (CDR FIELD.USAGE) when (EQ (CAR X) (CAAR FIELD.USAGE)) do (SETQ $$VAL (CONS X $$VAL] (FRPLACA (CDAR TEM) (LIST 'SETQ (RECORDBIND) (CADAR TEM))) [MAPC (CONS (CAR FIELD.USAGE) (CDR TEM)) (FUNCTION (LAMBDA (X) (FRPLACA (CDR X) (CADR (CADAR TEM))) (FRPLACA X NIL] (FRPLACD (CAR TEM) (CDDR (CADAR TEM))) (SETQ FIELD.USAGE (CDR FIELD.USAGE)) (GO LP] [COND ((NULL (CAAR FIELD.USAGE)) (SETQ FIELD.USAGE (CDR FIELD.USAGE))) ((EQ (CAAR FIELD.USAGE) (CAAR FIELDS.IN.CREATE)) (* ;; "Both FIELD.USAGE and FIELDS.IN.CREATE are in reverse order of occurance of expression in the translation and occurance in the original CREATE; if order of ends is the same, we can ignore those fields") (SETQ FIELD.USAGE (CDR FIELD.USAGE)) (SETQ FIELDS.IN.CREATE (CDR FIELDS.IN.CREATE))) ((OR (CONSTANTEXPRESSIONP (CADAR FIELD.USAGE)) (ASSOC (CADAR FIELD.USAGE) BINDINGS)) (* ;  "The last field used is a constant") (AND (SETQ TEM (ASSOC (CAAR FIELD.USAGE) FIELDS.IN.CREATE)) (FRPLACD (CDR TEM) T)) (SETQ FIELD.USAGE (CDR FIELD.USAGE))) ((OR (CDDAR FIELDS.IN.CREATE) (CONSTANTEXPRESSIONP (CADAR FIELDS.IN.CREATE)) (ASSOC (CADAR FIELDS.IN.CREATE) BINDINGS)) (* ; "This one has been seen before") (SETQ FIELDS.IN.CREATE (CDR FIELDS.IN.CREATE))) (T (SETQ REVFIELDS) [for X in FIELDS.IN.CREATE do (COND ((EQ (CAR X) (CAAR FIELD.USAGE)) (RETURN))) (COND ((NOTOKSWAP (CADR X) (CADAR FIELD.USAGE)) (SETQ REVFIELDS (CONS (CAR X) REVFIELDS] (* ;; "REVFIELDS is the list of fields which are specified in the CREATE after the last field used and which must be referenced AFTER what is now the last-field-used") (COND (REVFIELDS (* ;; "The last field referenced (CAR FIELDS.IN.CREATE) must actually be referenced before any of REVFIELDS") (for TL on FIELD.USAGE when (MEMB (CAAR TL) REVFIELDS) do (SETQ LASTFIELDTAIL TL)) (OR LASTFIELDTAIL (SHOULDNT)) (* ;  "In particular, it must be referenced before LASTFIELDTAIL") (SETQ USE1 (CAR LASTFIELDTAIL)) (SETQ USE2 (CAR FIELD.USAGE)) (SETQ FIELD.USAGE (CDR FIELD.USAGE)) (FRPLACD LASTFIELDTAIL (CONS USE2 (CDR LASTFIELDTAIL))) (* ; "Reorder FIELD.USAGE list") (* ;; "Now comes the incredible list structure patch: USE1= (NAME1 EXPR1 ...) USE2= (NAME2 EXPR2 ...) --- first change USE1 to (PROGN (SETQ TEM EXPR2) EXPR1) then change USE2 to TEM; then make USE pointers point back to the EXPRS") [FRPLACA (CDR USE1) (CONS 'PROGN (CONS [CONS 'SETQ (CONS (SETQ TEM (RECORDBIND)) (SETQ PLACE2 (LIST (CADR USE2] (SETQ PLACE1 (LIST (CADR USE1] (FRPLACA (CDR USE2) TEM) (FRPLACD USE1 PLACE1) (FRPLACD USE2 PLACE2)) (T (* ;  "It is ok that this field is used out of order") (AND (SETQ TEM (ASSOC (CAAR FIELD.USAGE) FIELDS.IN.CREATE)) (FRPLACD (CDR TEM) T)) (SETQ FIELD.USAGE (CDR FIELD.USAGE] (GO LP]) (FINDFIELDUSAGE [LAMBDA (EXPRESSION) (* lmm%: "22-AUG-76 23:01:55") (* ;; "Sets the list FIELD.USAGE to the list (in reverse order) of the places where FIELDS.IN.CREATE are used --- originally, the FIELDS.IN.CREATE items are set up in the expression as the entire ALIST entry. FINDFIELDUSAGE also replaces them with the 'right' expression") (COND ((NLISTP EXPRESSION)) ((NLISTP (CAR EXPRESSION)) (FINDFIELDUSAGE (CDR EXPRESSION))) [(NLISTP (CAAR EXPRESSION)) (COND ((FMEMB (CAR EXPRESSION) FIELDS.IN.CREATE) (SETQ FIELD.USAGE (CONS (CONS (CAAR EXPRESSION) EXPRESSION) FIELD.USAGE)) (* ;  "Add (FIELDNAME . LOCATION) onto FIELD.USAGE") (FRPLACA EXPRESSION (CADAR EXPRESSION)) (FINDFIELDUSAGE (CDR EXPRESSION))) ((EQ (CAAR EXPRESSION) 'LAMBDA) (* ; "The CDR is executed first") (FINDFIELDUSAGE (CDR EXPRESSION)) (FINDFIELDUSAGE (CDDAR EXPRESSION))) (T (FINDFIELDUSAGE (CDAR EXPRESSION)) (FINDFIELDUSAGE (CDR EXPRESSION] (T (FINDFIELDUSAGE (CAR EXPRESSION)) (FINDFIELDUSAGE (CDR EXPRESSION]) (EMBEDPROG [LAMBDA (DEF) (* lmm "25-AUG-78 12:38") (COND [BINDINGS (PROG ((BINDVARS (MAPCAR (SETQ BINDINGS (DREVERSE BINDINGS)) (FUNCTION CAR))) [BINDVALS (MAPCAR BINDINGS (FUNCTION (LAMBDA (X) (COND ((AND (EQ (CAR (SETQ X (CADR X))) 'PROGN) (NULL (CDDR X))) (CADR X)) (T X] LE LL) (SETQ BINDINGS) (RETURN (COND [[AND (LISTP (CAR DEF)) (EQ (CAAR DEF) 'LAMBDA) (NOT (REBINDP BINDVARS (CDR DEF] (CONS (CONS 'LAMBDA (CONS (NCONC BINDVARS (CADAR DEF)) (CDDAR DEF))) (NCONC BINDVALS (CDR DEF] ([AND (NULL (CDR BINDVARS)) (EQ [CAR (SETQ LE (LISTP (CAR (LISTP (CAR BINDVALS] 'LAMBDA) (NULL (CDR (CADR LE))) (EQ (CAADR LE) (CAR (SETQ LL (LAST LE] (CONS [NCONC (LDIFF LE LL) (SUBPAIR BINDVARS (CADR LE) (COND ((EQ (CAR DEF) 'PROGN) (CDR DEF)) (T (LIST DEF] (CDAR BINDVALS))) (T (CONS [CONS 'LAMBDA (CONS BINDVARS (COND ((EQ (CAR DEF) 'PROGN) (CDR DEF)) (T (LIST DEF] BINDVALS] (T DEF]) ) (DEFINEQ (RECLISPLOOKUP [LAMBDA (WORD DECS VAR1 VAR2) (* lmm "13-Mar-85 16:12") (PROG ((LISPFN (GETPROP WORD 'LISPFN)) CLASSDEF) (RETURN (COND ([AND DECS (SETQ CLASSDEF (GETPROP WORD 'CLISPCLASSDEF] (* ;; "must do full lookup. Note that it is not necessary to do a call to CLISPLOOKUP0 if word has a CLASS, but no CLASSDEF, e.g. FGTP, FMEMB, etc., since if these are ued as infix operators, they mean the corresponding functin regardless of declaraton. I.e. The CLASSDEF property says that this is the name of an infix operator. The CLASS property is used as a back pointer to the name of the operator/class of which this word is a member.") (CLISPLOOKUP0 WORD VAR1 VAR2 DECS LISPFN (GETPROP WORD 'CLISPCLASS) CLASSDEF)) (LISPFN) [(AND (MEMB 'UNDOABLE DECS) (SETQ LISPFN (CDR (ASSOC WORD LISPXFNS] (T WORD]) (CONSFN [LAMBDA (X Y) (* lmm " 5-SEP-78 14:25") (CONS (RECLISPLOOKUP X DECLST) Y]) (RECORDGENSYM [LAMBDA NIL (* lmm "24-JAN-79 12:16") (OR (CAR (SETQ PATGENSYMVARS (CDR PATGENSYMVARS))) (GENSYM]) (RECORDBIND [LAMBDA (VAL) (* lmm%: "26-JUL-76 01:40:11") (CAAR (SETQ BINDINGS (CONS (LIST (RECORDGENSYM) VAL) BINDINGS]) (RECORDERROR [LAMBDA (MESSAGE AT IN CDRFLG) (* lmm " 7-AUG-84 23:46") (* ;; "Prints out error message and then ERROR!s. Given ATM marker for msg so that all strings and messages are localized here, and don't have duplication of strings") (PROG (TEM) (SETQ MESSAGE (SELECTQ MESSAGE (7 "undefined field name") (OF "no OF") (WITH "no WITH") (5 "field occurs twice") (TYPE? "TYPE? not defined for this record") (1 "bad record declaration") (F "no fields") (0 "no record name") (-1 "no corresponding field in parent declaration") (P "can't parse this expression") (CREATE "CREATE not defined for this record") (REPLACE "REPLACE not defined for this field") (FETCH "FETCH not defined for this field") (NAME "undefined record name") (2 "no such record path") (CHANGE "not an expression which can occur left of %"_%"") (4 "bad field name") MESSAGE)) (COND ((EQ AT IN) (SETQ AT NIL)) ((NULL IN) (SETQ IN AT) (SETQ AT))) [COND ((EQ DWIMIFYFLG 'EVAL) (if (AND AT IN) then (ERROR (APPEND (MKLIST MESSAGE) (LIST 'in (RETDWIM2 IN))) AT) else (ERROR MESSAGE (OR AT IN] (FIXPRINTIN FAULTFN) (LISPXSPACES 1) (COND ((NLISTP MESSAGE) (LISPXPRIN1 MESSAGE T)) (T (MAPRINT MESSAGE T NIL NIL NIL NIL T))) (LISPXTERPRI T) [COND (AT (LISPXPRIN1 " at " T) (COND ((NLISTP AT) (LISPXPRIN2 AT T T) (LISPXPRIN1 " " T)) ([AND IN (SETQ TEM (OR (MEMB AT IN) (TAILP AT IN] (MAPRINT (RETDWIM2 (COND (CDRFLG (NLEFT IN 1 TEM)) (T TEM)) (CDDR AT)) T "... " ") " NIL NIL T)) (T (LISPXPRINT (RETDWIM2 AT) T T] (COND (IN (LISPXPRIN1 "in " T) (LISPXPRINT (RETDWIM2 IN) T T))) (DWIMERRORRETURN 'ALREADYPRINTED]) (SETUPHASHARRAY [LAMBDA (ARRAYNAME SIZE) (* lmm "12-Jul-84 22:40") (PROG (TEM) [COND [(NULL (SETQ TEM (GETATOMVAL ARRAYNAME] ((HASHARRAYP TEM)) (T (SET ARRAYNAME (HASHARRAY (OR SIZE 100] (RETURN ARRAYNAME]) (DWIMIFYREC [LAMBDA (DWIMTAIL NEWVARS PARENT ONEFLG INDECL) (* lmm " 7-AUG-84 23:32") (AND DWIMTAIL (if INDECL then [PROG ((EXPR DECL) (VARS NEWVARS) (FAULTFN (LIST (CADR DECL) 'declaration)) (DWIMIFYFLG 'VARSBOUND)) (RETURN (DWIMIFY0? DWIMTAIL PARENT T T ONEFLG FAULTFN 'VARSBOUND] else (PROG ((VARS (APPEND NEWVARS VARS))) (RETURN (DWIMIFY0? DWIMTAIL PARENT T T ONEFLG FAULTFN 'VARSBOUND]) (MKCONS [LAMBDA (CARPART CDRPART) (* lmm%: 15-APR-76 15 30) (COND [(OR (EQ (CAR (LISTP CDRPART)) 'LIST) (NULL CDRPART)) (CONS 'LIST (CONS CARPART (CDR CDRPART] (T (LIST 'CONS CARPART CDRPART]) (MKPROGN [LAMBDA (X) (COND ((NULL (CDR X)) (CAR X)) (T (CONS 'PROGN X]) ) (DEFINEQ (RECORDINIT [LAMBDA NIL (* lmm%: " 3-FEB-77 18:51:20") [MAPC RECORDINIT (FUNCTION (LAMBDA (X) (APPLY (CAR X) (CDR X] (/SET 'RECORDINIT]) ) (RPAQQ PATGENSYMVARS (GENSYMVARS%: $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17)) (RPAQ? RECORDINIT ) (RPAQ? CLISPRECORDTYPES NIL) (RPAQ? RECORDTRANHASH (HASHARRAY 20)) (DEFINEQ (RECORD [NLAMBDA NAME&FIELDS (* lmm " 3-MAR-82 11:20") (PROG ((N -1) NAM) LP (COND [(FMEMB (SETQ NAM (STKNTHNAME N)) CLISPRECORDTYPES) (RETURN (DECLARERECORD (CONS NAM NAME&FIELDS] (NAM (SETQ N (SUB1 N)) (GO LP))) (HELP "Record definition called, but no framename matches CLISPRECCORDTYPES"]) (TYPERECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'TYPERECORD NAME&FIELDS]) (PROPRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'PROPRECORD NAME&FIELDS]) (HASHLINK [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'HASHLINK NAME&FIELDS]) (ACCESSFN [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ACCESSFN NAME&FIELDS]) (ACCESSFNS [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ACCESSFNS NAME&FIELDS]) (HASHRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'HASHRECORD NAME&FIELDS]) (ATOMRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ATOMRECORD NAME&FIELDS]) (ARRAYRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ARRAYRECORD NAME&FIELDS]) (DATATYPE [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'DATATYPE NAME&FIELDS]) (BLOCKRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'BLOCKRECORD NAME&FIELDS]) (ASSOCRECORD [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ASSOCRECORD NAME&FIELDS]) (CACCESSFNS [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'CACCESSFNS NAME&FIELDS]) (ARRAYBLOCK [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'ARRAYBLOCK NAME&FIELDS]) (SYNONYM [NLAMBDA NAME&FIELDS (* edited%: "13-OCT-81 14:39") (DECLARERECORD (CONS 'SYNONYM NAME&FIELDS]) ) (DEFINEQ (RECORDECLARATIONS [NLAMBDA DECS (* bvm%: "10-Oct-86 18:18") (* ;; "Entry from the RECORDS prettymacro. Given a list of record names {DECS} prints the record declarations") (PROG (TEM) (PRIN1 "(") (MAPRINT '(DECLARE%: EVAL@COMPILE) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) [MAPC DECS (FUNCTION (LAMBDA (NAM DEC) [SETQ TEM (COND ([AND (LITATOM NAM) (SETQ DEC (CAR (RECLOOK1 NAM USERRECLST] (COND ((AND (LISTP DEC) (EQ (CAR DEC) CLISPTRANFLG)) (CDDR DEC)) (T DEC))) ((AND (LISTP NAM) (PROGN [COND ((EQ (CAR NAM) CLISPTRANFLG) (SETQ NAM (CDDR NAM] (FMEMB (CAR NAM) CLISPRECORDTYPES))) (SETQ DEC NAM)) (T (LIST 'QUOTE (LISPXPRINT (APPEND '(no RECORD declaration for) (LIST NAM)) T T] (COND ((EQ (CADR TEM) NAM) (PRETTYVAR1 (CAR TEM) (CADR TEM) (CDDR TEM) T T)) (T (PRINTDEF TEM 0 T) (TERPRI] (PRIN1 ") "]) (RECORDALLOCATIONS [NLAMBDA DECS (* lmm "27-OCT-77 15:20") (for X in DECS join (APPEND (RECORD.ALLOCATIONS (RECORDECL (CAR (RECLOOK1 X USERRECLST]) (SAVEONSYSRECLST [NLAMBDA NAMES (* bvm%: "16-Nov-86 17:20") (* ;; "Entry from SYSRECORDS prettymacro. Given a list of record names {DECS} prints an expression that saves their record declarations on the variable SYSTEMRECLST") (printout NIL "(") (MAPRINT '(ADDTOVAR SYSTEMRECLST) NIL NIL NIL NIL (FUNCTION PRIN2)) (TERPRI) [for N DECL in NAMES do (COND ((NULL (SETQ DECL (RECLOOK N))) (CL:FORMAT T "(no RECORD declaration for ~S)~%%" N)) ((EQ N (CADR DECL)) (PRETTYVAR1 (CAR DECL) (CADR DECL) (COND [(EQ (CAR DECL) 'DATATYPE) (* ;; "The usual case. Save only the fields declaration, sans comments, since that is all the inspector needs, and it reduces the cruft in a loaded system") (LIST (for FIELD in (CADDR DECL) collect FIELD unless (EQ (CAR (LISTP FIELD)) COMMENTFLG] (T (CDDR DECL))) T T)) (T (PRINTDEF DECL 0 T) (TERPRI] (printout NIL ")" T]) ) (ADDTOVAR USERRECLST ) (RPAQQ DECLARATIONCHAIN NIL) (RPAQQ MSBLIP "sysout and inform Masinter@PARC") (RPAQQ NOSIDEFNS (fetch CONS NLISTP PROGN APPEND LIST NEQ MEMB MEMBER FMEMB ASSOC TAILP COPY create ELT ELTD AND OR ADD1 SUB1 IPLUS IDIFFERENCE EQ EQUAL NOT NULL)) (RPAQQ RECORDSUBSTFLG NIL) (RPAQQ RECORDUSE NIL) (RPAQQ DATATYPEFIELDCOERCIONS ((INTEGER . FIXP) (REAL . FLOATP) (FLOATING . FLOATP))) (RPAQ? RECORDCHANGEFN ) (RPAQQ CLISPRECORDWORDS (smashing using copying reusing SMASHING USING COPYING REUSING)) (PUTPROPS /REPLACE CLISPWORD (RECORDTRAN . /replace)) (PUTPROPS COPYING CLISPWORD (RECORDTRAN . copying)) (PUTPROPS FETCH CLISPWORD (RECORDTRAN . fetch)) (PUTPROPS FFETCH CLISPWORD (RECORDTRAN . ffetch)) (PUTPROPS FREPLACE CLISPWORD (RECORDTRAN . freplace)) (PUTPROPS REPLACE CLISPWORD (RECORDTRAN . replace)) (PUTPROPS REUSING CLISPWORD (RECORDTRAN . reusing)) (PUTPROPS SMASHING CLISPWORD (RECORDTRAN . smashing)) (PUTPROPS TYPE? CLISPWORD (RECORDTRAN . type?)) (PUTPROPS USING CLISPWORD (RECORDTRAN . using)) (PUTPROPS /replace CLISPWORD (RECORDTRAN . /replace)) (PUTPROPS copying CLISPWORD (RECORDTRAN . copying)) (PUTPROPS fetch CLISPWORD (RECORDTRAN . fetch)) (PUTPROPS ffetch CLISPWORD (RECORDTRAN . ffetch)) (PUTPROPS freplace CLISPWORD (RECORDTRAN . freplace)) (PUTPROPS replace CLISPWORD (RECORDTRAN . replace)) (PUTPROPS reusing CLISPWORD (RECORDTRAN . reusing)) (PUTPROPS smashing CLISPWORD (RECORDTRAN . smashing)) (PUTPROPS type? CLISPWORD (RECORDTRAN . type?)) (PUTPROPS using CLISPWORD (RECORDTRAN . using)) (PUTPROPS OF CLISPWORD (RECORDTRAN . of)) (PUTPROPS of CLISPWORD (RECORDTRAN . of)) (PUTPROPS WITH CLISPWORD (RECORDTRAN . with)) (PUTPROPS with CLISPWORD (RECORDTRAN . with)) (PUTPROPS CREATE CLISPWORD (RECORDTRAN . create)) (PUTPROPS create CLISPWORD (RECORDTRAN . create)) (PUTPROPS INITRECORD CLISPWORD (RECORDTRAN . initrecord)) (PUTPROPS initrecord CLISPWORD (RECORDTRAN . initrecord)) (DECLARE%: DONTCOPY (PUTDEF (QUOTE RECORDTYPES) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (IFPROP USERRECORDTYPE . X) (ADDVARS (CLISPRECORDTYPES . X)) (P (MAPC 'X (FUNCTION (LAMBDA (FN) (MOVD? 'RECORD FN]) ) (PUTPROPS HASHLINK USERRECORDTYPE [LAMBDA (DEC) (CONS 'HASHRECORD (CDR DEC]) (PUTPROPS ACCESSFN USERRECORDTYPE [LAMBDA (DEC) (CONS 'ACCESSFNS (CDR DEC]) (PUTPROPS SYNONYM USERRECORDTYPE [LAMBDA (DEC) (CONS 'RECORD (CONS (CADR DEC) (CONS [CAR (OR (LISTP (CADDR DEC)) (CAR (/RPLACA (CDDR DEC) (LIST (CADDR DEC] (NCONC [MAPCAR (CDR (CADDR DEC)) (FUNCTION (LAMBDA (X) (LIST 'RECORD (CADR DEC) X] (CDDDR DEC]) (ADDTOVAR CLISPRECORDTYPES RECORD TYPERECORD PROPRECORD HASHLINK ACCESSFN ACCESSFNS HASHRECORD ATOMRECORD ARRAYRECORD DATATYPE BLOCKRECORD ASSOCRECORD CACCESSFNS ARRAYBLOCK SYNONYM) [MAPC '(RECORD TYPERECORD PROPRECORD HASHLINK ACCESSFN ACCESSFNS HASHRECORD ATOMRECORD ARRAYRECORD DATATYPE BLOCKRECORD ASSOCRECORD CACCESSFNS ARRAYBLOCK SYNONYM) (FUNCTION (LAMBDA (FN) (MOVD? 'RECORD FN] (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS CREATE.RECORD MACRO ((FIELDNAMES NAME FIELDINFO CREATEINFO TYPECHECK SUBDECS ALLOCATIONS DEFAULTFIELDS DECL PRIORITY) (LIST FIELDNAMES NAME FIELDINFO CREATEINFO TYPECHECK SUBDECS ALLOCATIONS DEFAULTFIELDS DECL PRIORITY))) [PUTPROPS ADD.RECORD.SUBDECS MACRO ((TRAN NEWVALUE) (FRPLACA (CDR (CDDDDR TRAN)) (NCONC1 (CADR (CDDDDR TRAN)) NEWVALUE] [PUTPROPS RECORD.ALLOCATIONS MACRO ((TRAN) (CADDR (CDDDDR TRAN] (PUTPROPS RECORD.CREATEINFO MACRO ((TRAN) (CADDDR TRAN))) [PUTPROPS RECORD.DEFAULTFIELDS MACRO ((TRAN) (CADDDR (CDDDDR TRAN] (PUTPROPS RECORD.FIELDINFO MACRO ((TRAN) (CADDR TRAN))) (PUTPROPS RECORD.FIELDNAMES MACRO ((TRAN) (CAR TRAN))) (PUTPROPS RECORD.NAME MACRO ((TRAN) (CADR TRAN))) [PUTPROPS RECORD.SUBDECS MACRO (LAMBDA (TRAN) (CADR (CDDDDR TRAN] [PUTPROPS RECORD.TYPECHECK MACRO ((TRAN) (CAR (CDDDDR TRAN] (PUTPROPS SET.RECORD.ALLOCATIONS MACRO ((TRAN NEWVALUE) (FRPLACA (CDDR (CDDDDR TRAN)) NEWVALUE))) (PUTPROPS SET.RECORD.CREATEINFO MACRO ((TRAN NEWVALUE) (FRPLACA (CDDDR TRAN) NEWVALUE))) (PUTPROPS SET.RECORD.DEFAULTFIELDS MACRO ((TRAN NEWVALUE) (FRPLACA (CDDDR (CDDDDR TRAN)) NEWVALUE))) (PUTPROPS SET.RECORD.FIELDNAMES MACRO ((TRAN NEWVALUE) (FRPLACA TRAN NEWVALUE))) (PUTPROPS SET.RECORD.NAME MACRO ((TRAN NEWVALUE) (FRPLACA (CDR TRAN) NEWVALUE))) (PUTPROPS SET.RECORD.TYPECHECK MACRO ((TRAN NEWVALUE) (FRPLACA (CDDDDR TRAN) NEWVALUE))) [PUTPROPS RECORD.DECL MACRO ((X) (CAR (FNTH X 9] (PUTPROPS SET.RECORD.DECL MACRO ((X Y) (FRPLACA (FNTH X 9) Y))) [PUTPROPS RECORD.PRIORITY MACRO ((X) (CAR (FNTH X 10] (PUTPROPS SET.RECORD.PRIORITY MACRO ((X Y) (/RPLACA (FNTH X 10) Y))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (ADDTOVAR SYSLOCALVARS $$1 $$2 $$3 $$4 $$5 $$6 $$7 $$8 $$9 $$10 $$11 $$12 $$13 $$14 $$15 $$16 $$17) (* ; "for handling datatype") (MOVD 'FETCHFIELD 'FFETCHFIELD) (MOVD 'REPLACEFIELD 'FREPLACEFIELD) (PUTPROPS FETCHFIELD LISPFN FETCHFIELD) (PUTPROPS FREPLACEFIELD LISPFN FREPLACEFIELD) (PUTPROPS REPLACEFIELD LISPFN REPLACEFIELD) (PUTPROPS FETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS FFETCHFIELD CLISPCLASS FETCHFIELD) (PUTPROPS FREPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS /REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS REPLACEFIELD CLISPCLASS REPLACEFIELD) (PUTPROPS FETCHFIELD CLISPCLASSDEF (ACCESS FETCHFIELD NIL FFETCHFIELD)) (PUTPROPS REPLACEFIELD CLISPCLASSDEF (ACCESS REPLACEFIELD /REPLACEFIELD FREPLACEFIELD)) (ADDTOVAR DECLWORDS FFETCHFIELD FETCHFIELD REPLACEFIELD FREPLACEFIELD /REPLACEFIELD) (NEW/FN 'REPLACEFIELD) (RPAQQ RECORDWORDS ((/replace UNDOABLE replace) (/push UNDOABLE push) (/pushnew UNDOABLE pushnew) (freplace FAST replace) (ffetch FAST fetch))) (* ; "for CHANGETRAN") (PUTPROPS ADD CLISPWORD (CHANGETRAN . add)) (PUTPROPS CHANGE CLISPWORD (CHANGETRAN . change)) (PUTPROPS POP CLISPWORD (CHANGETRAN . pop)) (PUTPROPS PUSH CLISPWORD (CHANGETRAN . push)) (PUTPROPS PUSHNEW CLISPWORD (CHANGETRAN . pushnew)) (PUTPROPS PUSHLIST CLISPWORD (CHANGETRAN . pushlist)) (PUTPROPS add CLISPWORD (CHANGETRAN . add)) (PUTPROPS change CLISPWORD (CHANGETRAN . change)) (PUTPROPS pop CLISPWORD (CHANGETRAN . pop)) (PUTPROPS push CLISPWORD (CHANGETRAN . push)) (PUTPROPS pushnew CLISPWORD (CHANGETRAN . pushnew)) (PUTPROPS pushlist CLISPWORD (CHANGETRAN . pushlist)) (PUTPROPS SWAP CLISPWORD (CHANGETRAN . swap)) (PUTPROPS swap CLISPWORD (CHANGETRAN . swap)) (PUTPROPS /push CLISPWORD (CHANGETRAN . /push)) (PUTPROPS /pushnew CLISPWORD (CHANGETRAN . /pushnew)) (PUTPROPS /PUSH CLISPWORD (CHANGETRAN . /push)) (PUTPROPS /PUSHNEW CLISPWORD (CHANGETRAN . /pushnew)) (DEFINEQ (CHANGETRAN [LAMBDA (X) (* lmm "29-SEP-78 16:51") (RECORDTRAN X 'CHANGETRAN]) (CHANGETRAN1 [LAMBDA (CHANGEWORD RECORDEXPRESSION) (* rmk%: " 6-JUN-79 16:56") (PROG (TEM FORM VAR1 NOTRANFLG ARGS [SPECIALFIELDS (COPY '((DATUM DATUM] FIELDNAMES (SUBSTYPE 'CHANGE)) (DWIMIFYREC (CDR RECORDEXPRESSION) '(DATUM) RECORDEXPRESSION) (SETQ ARGS (FIXDATUM (SETQ VAR1 (CADR RECORDEXPRESSION)) DECLST)) [SETQ FORM (COND ((SETQ TEM (GETPROP CHANGEWORD 'CHANGEWORD)) (APPLY* TEM RECORDEXPRESSION)) (T (SELECTQ CHANGEWORD (add [LIST 'DATUM_ (CONS (RECLISPLOOKUP '+ DECLST VAR1 (CADDR RECORDEXPRESSION)) (CONS 'DATUM (CDDR RECORDEXPRESSION]) (change (LIST 'DATUM_ (CADDR RECORDEXPRESSION))) (pop '(PROG1 (CAR DATUM) (DATUM_ (CDR DATUM)))) (push (LIST 'DATUM_ (for ELT (EXP _ 'DATUM) in (REVERSE (CDDR RECORDEXPRESSION)) do (SETQ EXP (LIST 'CONS ELT EXP)) finally (RETURN EXP)))) (pushnew [SUBST (RECORDBINDVAL (CADDR RECORDEXPRESSION)) 'NEWELT '(COND ((FMEMB NEWELT DATUM) DATUM) (T (DATUM_ (CONS NEWELT DATUM]) (pushlist [LIST 'DATUM_ (CONS 'APPEND (APPEND (CDDR RECORDEXPRESSION) (LIST 'DATUM]) (swap (SETQ TEM (FIXDATUM (CADDR RECORDEXPRESSION) DECLST)) [LIST 'DATUM_ (LIST 'PROG1 (CAR TEM) (SUBST 'DATUM 'NEWVALUE (CADDR TEM]) (RECORDERROR "Undefined CHANGEWORD" RECORDEXPRESSION] (RETURN (PROG (BINDINGS) (RETURN (EMBEDPROG (CSUBST FORM]) (FIXDATUM [LAMBDA (FORM DECLST) (* lmm " 3-Jul-85 12:37") (* ;; "turn a form into one which can be smashed more easily") (PROG (TEM (X FORM)) LP [COND [(LITATOM X) (COND ((AND (STRPOSL CLISPCHARRAY X) (CLISPNOTVARP X)) (RECORDERROR "unable to DWIMify" X RECORDEXPRESSION))) (RETURN (LIST X NIL (LIST (RECLISPLOOKUP 'SETQ DECLST) X 'NEWVALUE] ((LISTP X) (SELECTQ (CAR X) ((fetch FETCH ffetch FFETCH) (RETURN (MAKEACCESS (OR (ACCESSDEF (CADR X) (CADDDR X)) (RECORDERROR "unable to DWIMify" (CADR X) RECORDEXPRESSION)) (SELECTQ (CADDR X) ((of OF) (MKPROGN (CDDDR X))) (MKPROGN (CDDR X))) '(NEWVALUE) 'change))) (AND [SETQ X (SELECTQ (CAR X) ((CAR CDR GETHASH) X) ((NTH FNTH NLEFT) [LIST 'CDR (LIST (CAR X) (CADR X) ([LAMBDA (N X) (COND ((FIXP X) (APPLY* N X)) (T (LIST N X] (COND ((EQ (CAR X) 'NLEFT) 'ADD1) (T 'SUB1)) (CADDR X]) ((LAST FLAST) (LIST 'CDR (LIST 'NLEFT (CADR X) 2))) (COND ((AND (SETQ TEM (GETPROP (CAR X) 'SETFN)) (LITATOM TEM)) X) [(SETQ TEM (GETP (CAR X) 'CROPS)) (LIST (SELECTQ (CAR (SETQ TEM (REVERSE TEM))) (A 'CAR) (D 'CDR) (SHOULDNT)) (CONS [PACK (CONS 'C (NCONC1 (CDR TEM) 'R] (CDR X] ([AND (SETQ TEM (GETMACROPROP (CAR X) COMPILERMACROPROPS)) (NOT (EQUAL X (SETQ TEM (MACROEXPANSION X TEM] (SETQ X TEM) (GO LP] (RETURN (LIST [SETQ X (CONS (CAR X) (PROG ((TEM T) VAL) (for Y in (REVERSE (CDR X)) do (SETQ VAL (CONS (COND ((OR (AND TEM (SETQ TEM (SIMPLEP Y))) (CONSTANTEXPRESSIONP Y)) Y) (T (RECORDBIND Y))) VAL))) (RETURN VAL] NIL ([LAMBDA (Y) (SELECTQ (CAR X) ((CAR CDR) (LIST (CAR X) Y)) Y] (CONS (RECLISPLOOKUP (SELECTQ (CAR X) (CAR 'RPLACA) (CDR 'RPLACD) (GETHASH 'PUTHASH) (GETP (CAR X) 'SETFN)) DECLST) (COND [(EQ (CAR X) 'GETHASH) (CONS (CADR X) (CONS 'NEWVALUE (CDDR X] (T (APPEND (CDR X) '(NEWVALUE] (RECORDERROR 'CHANGE FORM RECORDEXPRESSION]) ) (PUTPROPS GETP SETFN PUT) (PUTPROPS GETPROP SETFN PUTPROP) (PUTPROPS EVALV SETFN SET) (PUTPROPS GETATOMVAL SETFN SETATOMVAL) (PUTPROPS OPENR SETFN CLOSER) (PUTPROPS WORDCONTENTS SETFN SETWORDCONTENTS) (PUTPROPS \GETBASE SETFN \PUTBASE) (PUTPROPS \GETBASEBYTE SETFN \PUTBASEBYTE) (PUTPROPS \GETBASEBIT SETFN \PUTBASEBIT) (PUTPROPS FETCHFIELD SETFN REPLACEFIELD) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: RECORDBLOCK ACCESSDEF ACCESSDEF4 ALLFIELDS ALLOCHASH ALLPATHS CHANGETRAN CHANGETRAN1 CHECKDEFS CHECKRECORDNAME CLISPRECORD CONSFN COPY1 CREATEFIELDS CSUBST RECONS CSUBSTLST DECLARERECORD DECLSUBFIELD DWIMIFYREC EMBEDPROG FIELDLOOK FIELDNAMESIN FINDFIELDUSAGE FIXDATUM FIXFIELDORDER GETFIELDFORCREATE GETSETQ HASHLINKS JOINDEF LISTRECORDEFS MAKEACCESS MAKEACCESS1 MAKECREATE0 MAKECREATE1 MAKECREATELST MAKECREATELST1 MAKEHASHLINKS MKACCESSFN MKCONS MKPROGN NOTOKSWAP REBINDP RECDEC? RECEVAL RECFIELDLOOK RECLISPLOOKUP RECLOOK RECLOOK1 RECORD.FIELD.VALUE RECORD.FIELD.VALUE0 RECORDACCESS RECORDALLOCATIONS RECORDBIND RECORDBINDVAL RECORDCHAIN RECORDECL RECORDECL0 RECORDECL1 RECORDECLBLOCK RECORDECLTAIL RECORDECLARATIONS RECORDERROR RECORDFIELD? RECORDFIELDNAMES RECORDGENSYM RECORDTRAN RECORDWORD RECREDECLARE SETUPHASHARRAY SIMPLEP SUBDECLARATIONS SUBFIELDCREATE TOPPATHS UNCLISPTRAN RECORDPRIORITY (ENTRIES RECORDTRAN CHANGETRAN CLISPRECORD RECORDFIELD? RECORDECLARATIONS RECORDALLOCATIONS RECORDACCESS RECORDFIELDNAMES RECLOOK SETUPHASHARRAY FIELDLOOK RECORD.FIELD.VALUE DECLARERECORD RECORDPRIORITY) (SPECVARS DWIMIFYFLG CLISPCHANGE NEWVALUE DECLARATIONCHAIN USINGTYPE USINGEXPR ARRAYDESC EXPR FAULTFN VARS DECLST FIELDNAMES RECORDEXPRESSION RECORD.TRAN ALLOCATIONS FIELDS.IN.CREATE PATGENSYMVARS NOSPELLFLG PATGENSYMVARS) (LOCALFREEVARS FIELD.USAGE BINDINGS RNAME NAME TAIL SETQPART SETQTAIL DECL CREATEINFO CLISPCHANGE FIELDINFO HASHLINKS ARGS AVOID BODY VAR1 NOTRANFLG SPECIALFIELDS SUBSTYPE STRUCNAME) (NOLINKFNS . T) SMASHPATTERN SMASHPAT1) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS MSBLIP CLISPRECORDTYPES NOSIDEFNS CLISPRECORDWORDS RECORDSTATS USERRECLST RECORDINIT LAMBDASPLST CLISPTRANFLG RECORDCHANGEFN COMMENTFLG CLISPCHARRAY LCASEFLG CLISPARRAY LISPXFNS RECORDWORDS DATATYPEFIELDCOERCIONS DATATYPEFIELDTYPES RECORDTRANHASH RECORDINIT CLISPARRAY CLISPRECORDTYPES RECORDTRANHASH) ) (DEFINEQ (EDITREC [NLAMBDA L (* lmm "15-Nov-86 00:41") (EDITDEF (IF (NLISTP L) THEN L ELSE (CAR L)) 'RECORDS]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA EDITREC SAVEONSYSRECLST RECORDALLOCATIONS RECORDECLARATIONS SYNONYM ARRAYBLOCK CACCESSFNS ASSOCRECORD BLOCKRECORD DATATYPE ARRAYRECORD ATOMRECORD HASHRECORD ACCESSFNS ACCESSFN HASHLINK PROPRECORD TYPERECORD RECORD MESATYPE MESARECORD MESAARRAY) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS RECORD COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (7343 65283 (RECORDTRAN 7353 . 20527) (RECREDECLARE 20529 . 20824) (RECREDECLARE1 20826 . 21171) (RECREDECLARE2 21173 . 21848) (RECORDECL 21850 . 22669) (RECORDFIELD? 22671 . 23468) ( RECORDECL0 23470 . 24090) (RECORDECL1 24092 . 36143) (RECORDECLBLOCK 36145 . 41124) (RECORDECLTAIL 41126 . 45294) (CHECKRECORDNAME 45296 . 46204) (LISTRECORDEFS 46206 . 46982) (RECORD.REMOVE.COMMENTS 46984 . 47560) (DECLARERECORD 47562 . 51978) (DECLSUBFIELD 51980 . 53888) (UNCLISPTRAN 53890 . 54183) (RECDEC? 54185 . 54552) (ALLOCHASH 54554 . 55283) (GETSETQ 55285 . 58665) (RECORDACCESS 58667 . 61189) (RECORDFIELDNAMES 61191 . 62023) (RECEVAL 62025 . 62577) (FIELDLOOK 62579 . 62660) (SIMPLEP 62662 . 63621) (RECORDBINDVAL 63623 . 63740) (RECORDPRIORITY 63742 . 64713) (RECORDACCESSFORM 64715 . 65281)) (65284 109137 (RECORDWORD 65294 . 66069) (MAKECREATE0 66071 . 66406) (MAKECREATE1 66408 . 85743) ( CREATEFIELDS 85745 . 86132) (REBINDP 86134 . 86458) (CSUBST 86460 . 93818) (RECONS 93820 . 94022) ( COPY1 94024 . 94226) (CSUBSTLST 94228 . 94499) (RECORD.FIELD.VALUE 94501 . 94840) (RECORD.FIELD.VALUE0 94842 . 95172) (MAKECREATELST 95174 . 95432) (SMASHPATTERN 95434 . 95846) (SMASHPAT1 95848 . 96859) ( MAKECREATELST1 96861 . 98781) (GETFIELDFORCREATE 98783 . 102137) (SUBFIELDCREATE 102139 . 104415) ( MAKEHASHLINKS 104417 . 105631) (HASHLINKS 105633 . 106110) (RECLOOK 106112 . 107851) (ALLFIELDS 107853 . 108310) (SUBDECLARATIONS 108312 . 109135)) (109138 134187 (CLISPRECORD 109148 . 111644) (ACCESSDEF 111646 . 115722) (FIELDNAMESIN 115724 . 115948) (ACCESSDEF4 115950 . 118682) (MAKEACCESS 118684 . 119089) (MAKEACCESS1 119091 . 124732) (MKACCESSFN 124734 . 126007) (RECFIELDLOOK 126009 . 127846) ( RECORDCHAIN 127848 . 128376) (RECLOOK1 128378 . 128775) (SYSRECLOOK1 128777 . 129078) (TOPPATHS 129080 . 129357) (ALLPATHS 129359 . 131893) (CHECKDEFS 131895 . 133437) (JOINDEF 133439 . 134185)) (134188 145499 (NOTOKSWAP 134198 . 134344) (FIXFIELDORDER 134346 . 141160) (FINDFIELDUSAGE 141162 . 142632) ( EMBEDPROG 142634 . 145497)) (145500 151566 (RECLISPLOOKUP 145510 . 146565) (CONSFN 146567 . 146722) ( RECORDGENSYM 146724 . 146905) (RECORDBIND 146907 . 147158) (RECORDERROR 147160 . 150090) ( SETUPHASHARRAY 150092 . 150405) (DWIMIFYREC 150407 . 151168) (MKCONS 151170 . 151459) (MKPROGN 151461 . 151564)) (151567 151853 (RECORDINIT 151577 . 151851)) (152082 154890 (RECORD 152095 . 152550) ( TYPERECORD 152552 . 152718) (PROPRECORD 152720 . 152886) (HASHLINK 152888 . 153050) (ACCESSFN 153052 . 153214) (ACCESSFNS 153216 . 153380) (HASHRECORD 153382 . 153548) (ATOMRECORD 153550 . 153716) ( ARRAYRECORD 153718 . 153886) (DATATYPE 153888 . 154050) (BLOCKRECORD 154052 . 154220) (ASSOCRECORD 154222 . 154390) (CACCESSFNS 154392 . 154558) (ARRAYBLOCK 154560 . 154726) (SYNONYM 154728 . 154888)) (154891 159156 (RECORDECLARATIONS 154901 . 157428) (RECORDALLOCATIONS 157430 . 157741) ( SAVEONSYSRECLST 157743 . 159154)) (168425 177163 (CHANGETRAN 168435 . 168577) (CHANGETRAN1 168579 . 171180) (FIXDATUM 171182 . 177161)) (179755 179985 (EDITREC 179765 . 179983))))) STOP \ No newline at end of file diff --git a/sources/RENAMEFNS b/sources/RENAMEFNS new file mode 100644 index 00000000..0d118402 --- /dev/null +++ b/sources/RENAMEFNS @@ -0,0 +1,105 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) +(FILECREATED "29-Jan-98 15:47:09" |{DSK}disk2>jdstools>lc3>lispcore3.0>sources>RENAMEFNS.;2| 13941 + + |changes| |to:| (VARS RENAMEFNSCOMS) + (FNS DORENAME RENAMEFN) + + |previous| |date:| " 6-Nov-92 19:47:12" +|{DSK}disk2>jdstools>lc3>lispcore3.0>sources>RENAMEFNS.;1|) + + +; Copyright (c) 1982, 1984, 1986, 1990, 1991, 1992, 1998 by Venue & Xerox Corporation. All rights reserved. + +(PRETTYCOMPRINT RENAMEFNSCOMS) + +(RPAQQ RENAMEFNSCOMS ( + (* |;;| + "Create \"retargeted\" functions, to read/write to sysout files, rather than to memory.") + + + (* |;;| "(DORENAME 'I creates I-NEW in makeinit") + + + (* |;;| "(DORENAME 'R) creates RDSYS for library.") + + + (* |;;| "") + + (FNS DORENAME DORENAME0 RENAMEFN RENAMEDVAL MAKECOMP RNSUBST) + (FILES (SOURCE) + FILESETS) + (BLOCKS (RNSUBST RNSUBST (NOLINKFNS . T))) + (GLOBALVARS RENAMEHASH RENAMETYPE EXPANDMACROFNS RENAMETYPES INITCONSTANTS + RENAMEFNSPAIRS VAG2FN RENAMEDFILE NEWCOMS EXTRACOMS))) + + + +(* |;;| "Create \"retargeted\" functions, to read/write to sysout files, rather than to memory.") + + + + +(* |;;| "(DORENAME 'I creates I-NEW in makeinit") + + + + +(* |;;| "(DORENAME 'R) creates RDSYS for library.") + + + + +(* |;;| "") + +(DEFINEQ + +(DORENAME + (LAMBDA (TYPE NOLOADFLG MINIMALFLG) (* |bvm:| "16-Jun-86 15:35") + (DORENAME0 (SETQ RENAMETYPE TYPE) + NOLOADFLG MINIMALFLG) + (RESETVARS ((LOADDBFLG 'NO) + (NOSPELLFLG T) + (CROSSCOMPILING T)) + (|for| X |in| RENAMEFNSPAIRS |do| (RENAMEFN (CAR X) + (CDR X)))) + (MAKECOMP RENAMEDFILE (APPEND (RENAMEDVAL NEWCOMS) + EXTRACOMS)))) + +(DORENAME0 (LAMBDA (TYPE NOLOAD MINIMALFLG) (* \; "Edited 24-Jan-91 10:35 by jds") (PROG (LISPXHIST RENAMEALIST) (DECLARE (SPECVARS . T)) (MAPC (CDR (ASSOC (OR TYPE 'I) RENAMETYPES)) (FUNCTION (LAMBDA (X) (SETATOMVAL (CAR X) (CDR X))))) (RESETVARS ((LOADDBFLG 'NO) (NOSPELLFLG T) (CROSSCOMPILING T)) (FILESLOAD (SYSLOAD) DTDECLARE) (|for| X |in| FILES |do| (COND (MINIMALFLG (PRINT (LOADFROM (FINDFILE X)) T T)) (T (* \;  "Load whole file, getting fn definitions at the same time") (LOAD (FINDFILE X) 'PROP) (LOADCOMP (FINDFILE X)) (* \;  "May need to LOADCOMP because the file's functions use local macros and optimizers....") )))) (SETQ ALLFNS (INFILECOMS? NIL 'FNS (SETQ NEWCOMS (GETATOMVAL COMSNAME)))) (COND (MINIMALFLG (* \;  "Load the fns specified as needed by NEWCOMS") (RESETVARS ((NOSPELLFLG T)) (MAPC FILES (FUNCTION (LAMBDA (FILE) (LOADFNS ALLFNS FILE 'PROP))))))) (SETQ NEWCOMS (MAPCAR NEWCOMS (FUNCTION (LAMBDA (X) (COND ((EQ (CADR X) '*) (CONS (CAR X) (EVAL (CADDR X)))) (T X)))))) (SETQ RENAMEALIST (GETATOMVAL SUBNAME)) (SETQ RENAMEFNSPAIRS (MAPCAR (INFILECOMS? NIL 'FNS NEWCOMS) (FUNCTION (LAMBDA (FN) (CONS FN (OR (CDR (ASSOC FN RENAMEALIST)) (PACK* PREFIX FN))))))) (SETQ RENAMEHASH (HASHARRAY (LENGTH RENAMEALIST))) (* |;;| "Store SUBNAME associations in hash array for faster access. First add other things, then elts of SUBNAME, since they have absolute precedence over anything implicitly declared here") (|for| X |in| INITCONSTANTS |when| (AND (NEQ (CAR X) '*) (LISTP (CADR X))) |do| (* \;  "Do substitutions on all constants declared as addresses") (PUTHASH (CAR X) (LIST VAG2FN (CAADR X) (CADR (CADR X))) RENAMEHASH)) (|for| X |in| (APPEND (GETATOMVAL VALUES) (GETATOMVAL PTRS)) |when| (NEQ (CAR X) '*) |do| (* |;;| "These are global variables containing simple values and pointers that are renamed so that the operations on them happen in the remote image instead of the local one.") (PUTHASH (CAR X) (PACK* PREFIX (SUBSTRING (CAR X) 2 -1)) RENAMEHASH)) (|for| X |in| FILES |do| (|for| Y |in| (FILECOMSLST X 'CONSTANTS) |do| (* \; "Arrange for all constants to be substituted explicitly, rather than rely on the compiler to do so") (PUTHASH Y (COND ((OR (NULL (SETQ Y (EVAL Y))) (EQ Y T) (NUMBERP Y)) Y) (T (LIST 'QUOTE Y))) RENAMEHASH))) (|for| PAIR |in| (APPEND RENAMEFNSPAIRS RENAMEALIST) |do| (PUTHASH (CAR PAIR) (CDR PAIR) RENAMEHASH))))) + +(RENAMEFN + (LAMBDA (OFN NFN) (* |bvm:| "24-Jul-86 10:57") + (|until| (ERSETQ (RESETVARS ((NOSPELLFLG T) + (DWIMESSGAG T) + (DWIMUSERFORMS)) + (LET ((NEWDEF (RNSUBST (GETDEF OFN)))) + (COND + ((EXPRP NFN) (* |Redefine| |existing| |expr| |to| + |avoid| |confusing| |filepkg|) + (/PUTD NFN NEWDEF)) + (T (/PUTPROP NFN 'EXPR NEWDEF)))))) + |do| (HELP OFN "Rename failed -- RETURN to try again")))) + +(RENAMEDVAL (LAMBDA (VAL) (* |bvm:| "14-Jun-86 17:30") (RESETVARS ((NOSPELLFLG T) (DWIMESSGAG T) (DWIMUSERFORMS)) (RETURN (RNSUBST VAL))))) + +(MAKECOMP (LAMBDA (FILE COMS) (* |bvm:| "14-Jun-86 17:31") (LET (FULL) (SETATOMVAL (FILECOMS FILE) COMS) (RESETVARS ((COPYRIGHTFLG 'NEVER) PRETTYFLG USEMAPFLG MAKEFILEREMAKEFLG) (SETQ FULL (MAKEFILE FILE '(NEW)))) (LISPXUNREAD '(F)) (LIST FULL (RESETVARS (DONTCOMPILEFNS) (RETURN (BRECOMPILE FULL NIL 'ALL))))))) + +(RNSUBST (LAMBDA (X) (* \;  "Edited 6-Nov-92 19:46 by sybalsky:mv:envos") (* |;;| "Make substitutions during a rename.") (COND ((NLISTP X) (OR (GETHASH X RENAMEHASH) X)) (T (LET ((A (CAR X)) (ENV (COMPILER::MAKE-ENV))) (* \;  "May need the ENV when we expand optimizers, since they can depend on the compiler environment.") (COND ((LISTP A) (* \;  "Translate LAMBDA forms recursively just like other elements") (COND ((EQ (CAR A) 'OPENLAMBDA) (RNSUBST (EXPANDOPENLAMBDA A (MAPCAR (CDR X) (FUNCTION RNSUBST))))) (T (MAPCAR X (FUNCTION RNSUBST))))) (T (SELECTQ A (* (* \; "LEAVE COMMENT PLACEHOLDERS") (CONS '* NIL)) (LOCAL (LET ((EXPR (CADR X))) (COND ((LISTP EXPR) (CONS (CAR EXPR) (MAPCAR (CDR EXPR) (FUNCTION RNSUBST)))) (T EXPR)))) (UNLESSRDSYS (SELECTQ RENAMETYPE (R (RNSUBST (CADDR X))) (RNSUBST (CADR X)))) (ALLOCAL (CADR X)) (QUOTE (* \; "Don't walk quoted forms") X) (COND ((FMEMB (CAR (LISTP (GETPROP A 'CLISPWORD))) '(RECORDTRAN CHANGETRAN)) (* \;  "most CLISP forms don't need or want to substitute under, but do so for record expressions") (RNSUBST (OR (GETHASH (DWIMIFY X T) CLISPARRAY) (PROGN (HELP X "DWIM failed") X)))) ((SETQ A (GETHASH A RENAMEHASH)) (RNSUBST (CONS A (CDR X)))) ((FMEMB (CAR X) EXPANDMACROFNS) (RESETVARS ((COMPILERMACROPROPS '(DMACRO ALTOMACRO BYTEMACRO MACRO))) (LET ((OPTS (GET (CAR X) 'COMPILER:OPTIMIZER-LIST)) (TRY-MACROS T)) (* |;;| "Try expanding its optimizers:") (CL:WHEN OPTS (|for| OPT |in| OPTS |do| (LET ((RESULT (APPLY* OPT X ENV NIL))) (CL:WHEN (AND (NEQ RESULT X) (NEQ RESULT 'IGNOREMACRO) (NEQ RESULT 'COMPILER:PASS) ) (SETQ X RESULT) (SETQ TRY-MACROS NIL))))) (* |;;| "Try expanding it as a macro:") (CL:WHEN TRY-MACROS (LET ((EXPANDED-FORM (CL:MACROEXPAND-1 X))) (CL:IF (EQ EXPANDED-FORM X) (HELP X "macro expansion failed") (SETQ X EXPANDED-FORM)))))) (RNSUBST X)) (T (CONS (CAR X) (MAPCAR (CDR X) (FUNCTION RNSUBST))))))))))))) +) + +(FILESLOAD (SOURCE) + FILESETS) +(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY + +(BLOCK\: RNSUBST RNSUBST (NOLINKFNS . T)) +) +(DECLARE\: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS RENAMEHASH RENAMETYPE EXPANDMACROFNS RENAMETYPES INITCONSTANTS RENAMEFNSPAIRS VAG2FN + RENAMEDFILE NEWCOMS EXTRACOMS) +) +(PUTPROPS RENAMEFNS COPYRIGHT ("Venue & Xerox Corporation" 1982 1984 1986 1990 1991 1992 1998)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL (1664 13516 (DORENAME 1674 . 2231) (DORENAME0 2233 . 7591) (RENAMEFN 7593 . 8395) ( +RENAMEDVAL 8397 . 8646) (MAKECOMP 8648 . 9137) (RNSUBST 9139 . 13514))))) +STOP diff --git a/sources/RENAMEMACROS b/sources/RENAMEMACROS new file mode 100644 index 00000000..3f49585b --- /dev/null +++ b/sources/RENAMEMACROS @@ -0,0 +1,222 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "27-Apr-94 15:43:27" {DSK}export>lispcore>sources>RENAMEMACROS.;2) + + +(* ; " +Copyright (c) 1982, 1985, 1986, 1990, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT RENAMEMACROSCOMS) + +(RPAQQ RENAMEMACROSCOMS + ( + (* ;; "MACROS FOR CODE THAT NEEDS TO CHANGE WHEN YOU RUN IT RENAMED.") + + [COMS (* ; + "Things that change when we're renaming for RDSYS/TELERAID") + (ADDVARS (RD.SUBFNS (UNLESSRDSYS . 2ND) + (\GETBITS . RNGETBITS) + (\PUTBITS . RNPUTBITS] + [COMS (* ; + "Things that change when we're making I-NEW, for building a new loadup.") + (ADDVARS (MKI.SUBFNS (UNLESSINEW . 2ND) + (\GETBITS . RNGETBITS) + (\PUTBITS . RNPUTBITS] + + (* ;; "Force these macros to be expanded while renaming:") + + (ADDVARS (EXPANDMACROFNS 1ST 2ND UNLESSRDSYS UNLESSINEW RNGETBITS RNPUTBITS \TESTBITS) + (EXPANDMACROFNS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE + PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC)) + + (* ;; "MACROS TO CONTROL EFFECTS:") + + + (* ;; "(UNLESSRDSYS normal rdsys) expands to one form or the other, depending on whether you're making a RDSYS.") + + + (* ;; "(UNLESSINEW normal inew) expandes to one form or the other, depending on whether you're makeing an I-NEW.") + + + (* ;; "(1ST ...) expands to its first argument") + + + (* ;; "(2ND ...) expands to its second argument. These are used in epxanding UNLESS...") + + (EXPORT (MACROS UNLESSRDSYS UNLESSINEW 1ST 2ND LOCAL ALLOCAL) + (MACROS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE + PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC)) + (MACROS RNPUTBITS RNGETBITS))) + + + +(* ;; "MACROS FOR CODE THAT NEEDS TO CHANGE WHEN YOU RUN IT RENAMED.") + + + + +(* ; "Things that change when we're renaming for RDSYS/TELERAID") + + +(ADDTOVAR RD.SUBFNS (UNLESSRDSYS . 2ND) + (\GETBITS . RNGETBITS) + (\PUTBITS . RNPUTBITS)) + + + +(* ; "Things that change when we're making I-NEW, for building a new loadup.") + + +(ADDTOVAR MKI.SUBFNS (UNLESSINEW . 2ND) + (\GETBITS . RNGETBITS) + (\PUTBITS . RNPUTBITS)) + + + +(* ;; "Force these macros to be expanded while renaming:") + + +(ADDTOVAR EXPANDMACROFNS 1ST 2ND UNLESSRDSYS UNLESSINEW RNGETBITS RNPUTBITS \TESTBITS) + +(ADDTOVAR EXPANDMACROFNS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE + PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC) + + + +(* ;; "MACROS TO CONTROL EFFECTS:") + + + + +(* ;; +"(UNLESSRDSYS normal rdsys) expands to one form or the other, depending on whether you're making a RDSYS." +) + + + + +(* ;; +"(UNLESSINEW normal inew) expandes to one form or the other, depending on whether you're makeing an I-NEW." +) + + + + +(* ;; "(1ST ...) expands to its first argument") + + + + +(* ;; "(2ND ...) expands to its second argument. These are used in epxanding UNLESS...") + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(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)) +) +(DECLARE%: EVAL@COMPILE + +(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] +) + +(* "END EXPORTED DEFINITIONS") + +(DECLARE%: EVAL@COMPILE + +[PUTPROPS RNPUTBITS MACRO (X ([LAMBDA (DATUM OFFSET FD NEWVALUE) + (PROG ((MASK (BitFieldMask FD)) + (SHIFT (BitFieldShift FD)) + (FIRST (BitFieldFirst FD))) + (OR (EQ FIRST 0) + (SETQ NEWVALUE (LIST 'LOGAND NEWVALUE MASK))) + (OR (EQ SHIFT 0) + (SETQ NEWVALUE (LIST 'LLSH NEWVALUE SHIFT))) + [COND + ((AND (EQ FIRST 0) + (EQ SHIFT 0)) + (SETQ NEWVALUE (LIST '\PUTBASE DATUM OFFSET NEWVALUE))) + (T (SETQ NEWVALUE (LIST 'LOGOR + (LIST 'LOGAND (LIST '\GETBASE + '$$PUTBITS + OFFSET) + (LOGXOR 65535 (LLSH MASK SHIFT + ))) + NEWVALUE)) + (SETQ NEWVALUE (LIST (LIST 'OPENLAMBDA '($$PUTBITS) + (LIST '\PUTBASE '$$PUTBITS + OFFSET NEWVALUE)) + DATUM] + [COND + ((NOT EFF) + (OR (EQ SHIFT 0) + (SETQ NEWVALUE (LIST 'LRSH NEWVALUE SHIFT))) + (OR (EQ FIRST 0) + (SETQ NEWVALUE (LIST 'LOGAND NEWVALUE MASK] + (RETURN NEWVALUE] + (CAR X) + (CADR X) + (CADDR X) + (CADDDR X] + +[PUTPROPS RNGETBITS MACRO (X ([LAMBDA (FORM OFFSET FD) + (COND + ((NOT (FIXP FD)) + 'IGNOREMACRO) + (T (SETQ FORM (LIST '\GETBASE FORM OFFSET)) + [OR (EQ (BitFieldShift FD) + 0) + (SETQ FORM (LIST 'LRSH FORM (BitFieldShift FD] + [OR (EQ (BitFieldFirst FD) + 0) + (SETQ FORM (LIST 'LOGAND FORM (BitFieldMask FD] + FORM] + (CAR X) + (CADR X) + (CADDR X] +) +(PUTPROPS RENAMEMACROS COPYRIGHT ("Venue & Xerox Corporation" 1982 1985 1986 1990 1994)) +STOP diff --git a/sources/RESOURCE b/sources/RESOURCE new file mode 100644 index 00000000..26c7ae09 --- /dev/null +++ b/sources/RESOURCE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-May-90 21:31:50" {DSK}local>lde>lispcore>sources>RESOURCE.;2 12730 changes to%: (VARS RESOURCECOMS) previous date%: "11-Aug-87 18:19:35" {DSK}local>lde>lispcore>sources>RESOURCE.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT RESOURCECOMS) (RPAQQ RESOURCECOMS [(MACROS INITRESOURCE NEWRESOURCE GETRESOURCE FREERESOURCE WITH-RESOURCE WITH-RESOURCES) (FNS \GR.METHODEXPANDER \GR.WITHRESOURCEMAC) (FILEPKGCOMS RESOURCES INITRESOURCES) (FNS \GR.GETDEFFN \GR.PUTDEFFN \GR.DELDEFFN \GR.CONTENTS \GR.GvarInitLst) (FNS \GR.MAKEPRETTYCOMSL \IGR.MAKEPRETTYCOMSL) (INITVARS (GLOBAL.RESOURCES)) (GLOBALVARS GLOBAL.RESOURCES) (PROP ARGNAMES INITRESOURCE NEWRESOURCE GETRESOURCE FREERESOURCE) (COMS (* "need only be in ABC") (FILEPKGCOMS GLOBALRESOURCES) (MACROS GLOBALRESOURCE GLOBALRESOURCES) (MACROS RELEASERESOURCE)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA \IGR.MAKEPRETTYCOMSL \GR.MAKEPRETTYCOMSL ) (NLAML) (LAMA]) (DECLARE%: EVAL@COMPILE (PUTPROPS INITRESOURCE MACRO (X (\GR.METHODEXPANDER X 'INIT))) (PUTPROPS NEWRESOURCE MACRO (X (\GR.METHODEXPANDER X 'NEW))) (PUTPROPS GETRESOURCE MACRO (X (\GR.METHODEXPANDER X 'GET))) (PUTPROPS FREERESOURCE MACRO (X (\GR.METHODEXPANDER X 'FREE))) (PUTPROPS WITH-RESOURCE MACRO (= . WITH-RESOURCES)) (PUTPROPS WITH-RESOURCES MACRO (X (\GR.WITHRESOURCEMAC X))) ) (DEFINEQ (\GR.METHODEXPANDER [LAMBDA (X METHOD) (* ; "Edited 27-Feb-87 15:54 by jop") (PROG (DEF RVAR (NAME (OR (CAR (LISTP X)) X))) (RETURN (if (NULL (SETQ DEF (LISTGET (SETQ DEF (GETDEF NAME 'RESOURCES)) METHOD))) then (* ;; "Although these could all be implemented by functions, this is the default (and common) case; so just put in-line here.") (SETQ RVAR (PACK* '\ NAME '.GLOBALRESOURCE)) (SELECTQ METHOD (GET `[LET NIL (DECLARE (GLOBALVARS ,RVAR)) (COND (,RVAR (PROG1 ,RVAR (SETQ ,RVAR NIL))) (T (NEWRESOURCE ,NAME]) (FREE `[LET NIL (DECLARE (GLOBALVARS ,RVAR)) (SETQ ,RVAR ,(CADR (LISTP X]) (INIT `(/SETTOPVAL ',RVAR NIL)) (NEW (ERROR "No NEW method for resource" NAME)) (SHOULDNT)) elseif (FNTYP DEF) then (APPLY DEF X) elseif (LISTP DEF) then (SUBPAIR '(RESOURCENAME ARGS) (LIST NAME (CDR (LISTP X))) DEF) else (ERROR (CONCAT "Bad resource " METHOD " method for " NAME) DEF]) (\GR.WITHRESOURCEMAC [LAMBDA (X) (* ; "Edited 11-Aug-87 18:18 by Snow") (PROG [(NAMES (MKLIST (CAR X))) (FORMS (\DECL.COMNT.PROCESS (CDR X] (* ;; "Forms is a list of the form (decls comments . body)") (* ;; "This should probably expand into UNWIND-PROTECT instead of PROG1. Cf AR 8944") (RETURN `([,'LAMBDA ,NAMES ,@(CAR FORMS) ,@(CADR FORMS) (PROG1 (PROGN ,@(CDDR FORMS)) ,@(for NAME in NAMES collect `(FREERESOURCE ,NAME ,NAME] ,@(for NAME in NAMES collect `(GETRESOURCE ,NAME]) ) (PUTDEF (QUOTE RESOURCES) (QUOTE FILEPKGCOMS) '((COM MACRO [X (DECLARE%: EVAL@COMPILE (P * (\GR.MAKEPRETTYCOMSL . X] CONTENTS \GR.CONTENTS) (TYPE DESCRIPTION "global resources" GETDEF \GR.GETDEFFN DELDEF \GR.DELDEFFN PUTDEF \GR.PUTDEFFN))) (PUTDEF (QUOTE INITRESOURCES) (QUOTE FILEPKGCOMS) '((COM MACRO (X (P * (\IGR.MAKEPRETTYCOMSL . X))) CONTENTS \GR.CONTENTS))) (DEFINEQ (\GR.GETDEFFN [LAMBDA (NAME TYPE) (* rmk%: "14-Jun-84 22:39") (CDR (ASSOC NAME GLOBAL.RESOURCES]) (\GR.PUTDEFFN [LAMBDA (NAME TYPE DEF) (* ; "Edited 4-Aug-87 12:25 by amd") (if (OR (NULL NAME) (NOT (LITATOM NAME))) then (ERRORX (LIST 14 NAME))) (if [AND (LISTP DEF) (NOT (LISTGET DEF 'NEW] then (* ;; "Conversion from old format -- to be flushed soon after CAROL release. Jonl 5/14/84") (SETQ DEF (LIST 'NEW DEF)) elseif [AND DEF (NOT (LISTGET (LISTP DEF) 'NEW] then (ERROR "No NEW method for resource" NAME)) (* ;  "Note that the variable GLOBAL.RESOURCES has been GLOBALVAR'd by the file COMS") [if (NULL DEF) then (\GR.DELDEFFN NAME TYPE) else (PROG NIL (MARKASCHANGED NAME 'RESOURCES (if (SETQ TYPE (ASSOC NAME GLOBAL.RESOURCES)) then (* ;  "The initialization has to be performed regardless of whether or not the definition has changed.") (EVAL (\GR.METHODEXPANDER NAME 'INIT)) (AND (EQUAL DEF (CDR TYPE)) (RETURN)) (/RPLACD TYPE DEF) 'CHANGED else (/SETTOPVAL 'GLOBAL.RESOURCES (CONS (CONS NAME DEF) GLOBAL.RESOURCES)) (EVAL (\GR.METHODEXPANDER NAME 'INIT)) 'DEFINED] NAME]) (\GR.DELDEFFN [LAMBDA (NAME TYPE) (* rmk%: "15-Jun-84 11:23") (if (NOT (AND NAME (LITATOM NAME))) then (ERRORX (LIST 14 NAME))) (PROG ((DEF (ASSOC NAME GLOBAL.RESOURCES))) (if DEF then (MARKASCHANGED NAME 'RESOURCES 'DELETED) (/SETTOPVAL 'GLOBAL.RESOURCES (REMOVE DEF GLOBAL.RESOURCES)) (if (NULL (LISTGET (CDR DEF) 'GET)) then (* Help clean up mess left by the  default case) (/SETTOPVAL (PACK* '\ NAME '.GLOBALRESOURCE) 'NOBIND)) (RETURN T]) (\GR.CONTENTS [LAMBDA (COM NAME TYPE) (* rmk%: "14-Jun-84 22:29") (COND ((EQ TYPE 'RESOURCES) [SETQ COM (COND ((EQ (CAR (LISTP (CDR COM))) '*) (EVAL (CADDR COM))) (T (CDR COM] (COND ((EQ NAME T) (AND COM T)) ((AND NAME (LITATOM NAME)) (AND [find X in COM suchthat (EQ NAME (COND ((LISTP X) (CAR X)) (T X] T)) (T (MAPCAR COM (FUNCTION (LAMBDA (X) (COND ((LISTP X) (CAR X)) (T X]) (\GR.GvarInitLst [LAMBDA (NAME) (* ; "Edited 4-Aug-87 12:28 by amd") `(/SETTOPVAL ',(MKATOM (CONCAT "\RESOURCE." NAME ".LST")) (LIST NIL]) ) (DEFINEQ (\GR.MAKEPRETTYCOMSL [NLAMBDA L (* ; "Edited 4-Aug-87 12:29 by amd") [COND ((EQ (CAR (LISTP L)) '*) (SETQ L (EVAL (CADR L] (for Y NAME DEF in L collect [COND [(LISTP Y) (SETQ NAME (CAR Y)) (SETQ DEF (CAR (LISTP (CDR Y] (T (SETQ NAME Y) (SETQ DEF (GETDEF NAME 'RESOURCES] (OR (AND NAME (LITATOM NAME)) (ERROR "Bad filepkg command" L)) `(PUTDEF ',NAME 'RESOURCES ',DEF]) (\IGR.MAKEPRETTYCOMSL [NLAMBDA L (* JonL "24-Oct-84 18:49") [if (EQ (CAR (LISTP L)) '*) then (SETQ L (EVAL (CADR L] (for NAME in L collect (LISPFORM.SIMPLIFY (LIST 'INITRESOURCE NAME) T]) ) (RPAQ? GLOBAL.RESOURCES ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS GLOBAL.RESOURCES) ) (PUTPROPS INITRESOURCE ARGNAMES (NIL ("" . ARGS))) (PUTPROPS NEWRESOURCE ARGNAMES (NIL ("" . ARGS))) (PUTPROPS GETRESOURCE ARGNAMES (NIL ("" . ARGS))) (PUTPROPS FREERESOURCE ARGNAMES (NIL ("" DATUM . ARGS))) (* "need only be in ABC") (PUTDEF (QUOTE GLOBALRESOURCES) (QUOTE FILEPKGCOMS) '[(COM MACRO (X (DECLARE%: DONTCOPY (RESOURCES . X) ) (INITRESOURCES . X]) (DECLARE%: EVAL@COMPILE (PUTPROPS GLOBALRESOURCE MACRO (= . WITH-RESOURCES)) (PUTPROPS GLOBALRESOURCES MACRO (= . WITH-RESOURCES)) ) (DECLARE%: EVAL@COMPILE (PUTPROPS RELEASERESOURCE MACRO [ARGS ([LAMBDA (RVALVAR) (OR (AND (LITATOM RVALVAR) RVALVAR (NEQ T RVALVAR)) (ERROR "Must RELEASERESOURCE from a variable" ARGS] (CADR ARGS)) (SUBPAIR '(RNAME RVALVAR . FORMS) ARGS '(PROGN (FREERESOURCE RNAME RVALVAR) (PROG1 (PROGN . FORMS) (SETQ RVALVAR (GETRESOURCE RNAME)))]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA \IGR.MAKEPRETTYCOMSL \GR.MAKEPRETTYCOMSL) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS RESOURCE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2218 4617 (\GR.METHODEXPANDER 2228 . 3890) (\GR.WITHRESOURCEMAC 3892 . 4615)) (5320 9444 (\GR.GETDEFFN 5330 . 5484) (\GR.PUTDEFFN 5486 . 7441) (\GR.DELDEFFN 7443 . 8284) (\GR.CONTENTS 8286 . 9238) (\GR.GvarInitLst 9240 . 9442)) (9445 10551 (\GR.MAKEPRETTYCOMSL 9455 . 10216) ( \IGR.MAKEPRETTYCOMSL 10218 . 10549))))) STOP \ No newline at end of file diff --git a/sources/SEDIT b/sources/SEDIT new file mode 100644 index 00000000..7e178634 --- /dev/null +++ b/sources/SEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "USER") (IL:FILECREATED "25-Jan-91 17:04:34" IL:|{DSK}woz>SOURCES>SEDIT.;2| 2065 IL:|changes| IL:|to:| (IL:VARS IL:SEDITCOMS) IL:|previous| IL:|date:| " 9-Jan-91 12:39:27" IL:|{DSK}woz>SOURCES>SEDIT.;2|) ; Copyright (c) 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDITCOMS) (IL:RPAQQ IL:SEDITCOMS ((IL:PROP IL:FILETYPE IL:SEDIT) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT) (IL:DECLARE\: IL:DOEVAL@LOAD IL:DOEVAL@COMPILE IL:DOCOPY (IL:P (XCL:DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")))) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:FILES IL:SEDIT-ACCESS IL:SEDIT-ATOMIC IL:SEDIT-BASE IL:SEDIT-COMMANDS IL:SEDIT-COMMENTS IL:SEDIT-EXPORTS IL:SEDIT-INDENT IL:SEDIT-LIST-FORMATS IL:SEDIT-LINEAR IL:SEDIT-LISTS IL:SEDIT-TERMINAL IL:SEDIT-TOPLEVEL IL:SEDIT-WINDOW) (IL:P (FUNCALL (INTERN "INITIALIZE" "SEDIT")) (IL:EDITMODE (INTERN "SEDIT" "SEDIT")))))) (IL:PUTPROPS IL:SEDIT IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "USER")) (IL:DECLARE\: IL:DOEVAL@LOAD IL:DOEVAL@COMPILE IL:DOCOPY (XCL:DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")) ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOCOPY (IL:FILESLOAD IL:SEDIT-ACCESS IL:SEDIT-ATOMIC IL:SEDIT-BASE IL:SEDIT-COMMANDS IL:SEDIT-COMMENTS IL:SEDIT-EXPORTS IL:SEDIT-INDENT IL:SEDIT-LIST-FORMATS IL:SEDIT-LINEAR IL:SEDIT-LISTS IL:SEDIT-TERMINAL IL:SEDIT-TOPLEVEL IL:SEDIT-WINDOW) (FUNCALL (INTERN "INITIALIZE" "SEDIT")) (IL:EDITMODE (INTERN "SEDIT" "SEDIT")) ) (IL:PUTPROPS IL:SEDIT IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-ACCESS b/sources/SEDIT-ACCESS new file mode 100644 index 00000000..aace7863 --- /dev/null +++ b/sources/SEDIT-ACCESS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SEDIT" (USE "LISP" "XCL"))) (IL:FILECREATED "19-Jan-93 11:17:23" IL:|{DSK}lde>lispcore>sources>SEDIT-ACCESS.;3| 16340 IL:|previous| IL:|date:| " 5-Jan-93 02:16:37" IL:|{DSK}lde>lispcore>sources>SEDIT-ACCESS.;2|) ; Copyright (c) 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-ACCESSCOMS) (IL:RPAQQ IL:SEDIT-ACCESSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-ACCESS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-ACCESS) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:INITRECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) (IL:SYSRECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK))) (IL:PUTPROPS IL:SEDIT-ACCESS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-ACCESS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:/DECLAREDATATYPE 'BROKEN-ATOM '(IL:POINTER) '((BROKEN-ATOM 0 IL:POINTER)) '2) (IL:/DECLAREDATATYPE 'EDIT-CONTEXT '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-CONTEXT 0 IL:POINTER) (EDIT-CONTEXT 2 IL:POINTER) (EDIT-CONTEXT 4 IL:POINTER) (EDIT-CONTEXT 6 IL:POINTER) (EDIT-CONTEXT 8 IL:POINTER) (EDIT-CONTEXT 10 IL:POINTER) (EDIT-CONTEXT 12 IL:POINTER) (EDIT-CONTEXT 14 IL:POINTER) (EDIT-CONTEXT 16 IL:POINTER) (EDIT-CONTEXT 18 IL:POINTER) (EDIT-CONTEXT 20 IL:POINTER) (EDIT-CONTEXT 22 IL:POINTER) (EDIT-CONTEXT 24 IL:POINTER) (EDIT-CONTEXT 26 IL:POINTER) (EDIT-CONTEXT 28 IL:POINTER) (EDIT-CONTEXT 30 IL:POINTER) (EDIT-CONTEXT 32 IL:POINTER) (EDIT-CONTEXT 34 IL:POINTER) (EDIT-CONTEXT 36 IL:POINTER) (EDIT-CONTEXT 38 IL:POINTER) (EDIT-CONTEXT 40 IL:POINTER) (EDIT-CONTEXT 42 IL:POINTER) (EDIT-CONTEXT 42 (IL:FLAGBITS . 0)) (EDIT-CONTEXT 44 IL:POINTER) (EDIT-CONTEXT 46 IL:POINTER) (EDIT-CONTEXT 48 IL:POINTER) (EDIT-CONTEXT 50 IL:POINTER) (EDIT-CONTEXT 52 IL:POINTER) (EDIT-CONTEXT 54 IL:POINTER) (EDIT-CONTEXT 56 IL:POINTER) (EDIT-CONTEXT 58 IL:POINTER) (EDIT-CONTEXT 60 IL:POINTER) (EDIT-CONTEXT 62 IL:POINTER) (EDIT-CONTEXT 64 IL:POINTER) (EDIT-CONTEXT 66 IL:POINTER) (EDIT-CONTEXT 68 IL:FULLXPOINTER) (EDIT-CONTEXT 70 IL:POINTER) (EDIT-CONTEXT 72 IL:FULLXPOINTER) (EDIT-CONTEXT 74 (IL:BITS . 15)) (EDIT-CONTEXT 76 IL:FULLXPOINTER) (EDIT-CONTEXT 78 IL:FULLXPOINTER) (EDIT-CONTEXT 80 IL:POINTER) (EDIT-CONTEXT 82 IL:POINTER) (EDIT-CONTEXT 84 IL:POINTER) (EDIT-CONTEXT 86 IL:POINTER) (EDIT-CONTEXT 88 IL:POINTER) (EDIT-CONTEXT 90 IL:POINTER) (EDIT-CONTEXT 92 IL:POINTER) (EDIT-CONTEXT 94 IL:POINTER) (EDIT-CONTEXT 96 IL:POINTER) (EDIT-CONTEXT 98 IL:POINTER) (EDIT-CONTEXT 100 IL:POINTER) (EDIT-CONTEXT 102 IL:POINTER) (EDIT-CONTEXT 104 IL:FULLXPOINTER) (EDIT-CONTEXT 106 IL:FULLXPOINTER) (EDIT-CONTEXT 108 IL:POINTER) (EDIT-CONTEXT 110 IL:POINTER) (EDIT-CONTEXT 112 IL:POINTER) (EDIT-CONTEXT 114 IL:POINTER) (EDIT-CONTEXT 116 IL:POINTER)) '118) (IL:/DECLAREDATATYPE 'EDIT-ENV '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-ENV 0 IL:POINTER) (EDIT-ENV 2 IL:POINTER) (EDIT-ENV 4 IL:POINTER) (EDIT-ENV 6 IL:POINTER) (EDIT-ENV 8 IL:POINTER) (EDIT-ENV 10 IL:POINTER) (EDIT-ENV 12 IL:POINTER) (EDIT-ENV 14 IL:POINTER) (EDIT-ENV 16 IL:POINTER) (EDIT-ENV 18 IL:POINTER) (EDIT-ENV 20 IL:POINTER) (EDIT-ENV 22 IL:POINTER) (EDIT-ENV 24 IL:POINTER) (EDIT-ENV 26 IL:POINTER) (EDIT-ENV 28 IL:POINTER) (EDIT-ENV 30 IL:POINTER) (EDIT-ENV 32 IL:POINTER) (EDIT-ENV 34 IL:POINTER) (EDIT-ENV 36 IL:POINTER) (EDIT-ENV 38 IL:POINTER) (EDIT-ENV 40 IL:POINTER) (EDIT-ENV 42 IL:POINTER) (EDIT-ENV 44 IL:POINTER) (EDIT-ENV 46 IL:POINTER)) '48) (IL:/DECLAREDATATYPE 'EDIT-NODE '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-NODE 0 IL:FULLXPOINTER) (EDIT-NODE 2 IL:POINTER) (EDIT-NODE 4 IL:POINTER) (EDIT-NODE 6 IL:FULLXPOINTER) (EDIT-NODE 8 (IL:BITS . 15)) (EDIT-NODE 9 (IL:BITS . 15)) (EDIT-NODE 10 IL:POINTER) (EDIT-NODE 12 IL:POINTER) (EDIT-NODE 14 IL:FULLXPOINTER) (EDIT-NODE 16 IL:POINTER) (EDIT-NODE 18 (IL:BITS . 15)) (EDIT-NODE 19 (IL:BITS . 15)) (EDIT-NODE 20 (IL:BITS . 15)) (EDIT-NODE 21 (IL:BITS . 15)) (EDIT-NODE 16 (IL:FLAGBITS . 0)) (EDIT-NODE 22 IL:POINTER) (EDIT-NODE 24 IL:POINTER) (EDIT-NODE 26 IL:POINTER) (EDIT-NODE 28 IL:POINTER)) '30) (IL:/DECLAREDATATYPE 'EDIT-NODE-TYPE '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-NODE-TYPE 0 IL:POINTER) (EDIT-NODE-TYPE 2 IL:POINTER) (EDIT-NODE-TYPE 4 IL:POINTER) (EDIT-NODE-TYPE 6 IL:POINTER) (EDIT-NODE-TYPE 8 IL:POINTER) (EDIT-NODE-TYPE 10 IL:POINTER) (EDIT-NODE-TYPE 12 IL:POINTER) (EDIT-NODE-TYPE 14 IL:POINTER) (EDIT-NODE-TYPE 16 IL:POINTER) (EDIT-NODE-TYPE 18 IL:POINTER) (EDIT-NODE-TYPE 20 IL:POINTER) (EDIT-NODE-TYPE 22 IL:POINTER) (EDIT-NODE-TYPE 24 IL:POINTER) (EDIT-NODE-TYPE 26 IL:POINTER) (EDIT-NODE-TYPE 28 IL:POINTER) (EDIT-NODE-TYPE 30 IL:POINTER) (EDIT-NODE-TYPE 32 IL:POINTER) (EDIT-NODE-TYPE 34 IL:POINTER)) '36) (IL:/DECLAREDATATYPE 'EDIT-POINT '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER) '((EDIT-POINT 0 IL:FULLXPOINTER) (EDIT-POINT 2 IL:POINTER) (EDIT-POINT 4 IL:POINTER) (EDIT-POINT 6 IL:POINTER) (EDIT-POINT 8 IL:FULLXPOINTER) (EDIT-POINT 10 IL:POINTER) (EDIT-POINT 12 IL:POINTER)) '14) (IL:/DECLAREDATATYPE 'EDIT-SELECTION '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-SELECTION 0 IL:FULLXPOINTER) (EDIT-SELECTION 2 IL:POINTER) (EDIT-SELECTION 4 IL:POINTER) (EDIT-SELECTION 6 IL:POINTER) (EDIT-SELECTION 8 IL:POINTER) (EDIT-SELECTION 10 IL:POINTER) (EDIT-SELECTION 12 IL:POINTER) (EDIT-SELECTION 14 IL:FULLXPOINTER) (EDIT-SELECTION 16 IL:POINTER) (EDIT-SELECTION 18 IL:FULLXPOINTER) (EDIT-SELECTION 20 IL:POINTER) (EDIT-SELECTION 22 IL:POINTER) (EDIT-SELECTION 24 IL:POINTER)) '26) (IL:/DECLAREDATATYPE 'GAP '(IL:POINTER) '((GAP 0 IL:POINTER)) '2) (IL:/DECLAREDATATYPE 'LINE-BLOCK '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((LINE-BLOCK 0 IL:FULLXPOINTER) (LINE-BLOCK 2 IL:POINTER) (LINE-BLOCK 4 IL:POINTER) (LINE-BLOCK 6 IL:POINTER) (LINE-BLOCK 8 IL:POINTER) (LINE-BLOCK 10 IL:POINTER) (LINE-BLOCK 12 IL:POINTER) (LINE-BLOCK 14 IL:POINTER) (LINE-BLOCK 16 IL:POINTER)) '18) (IL:/DECLAREDATATYPE 'LINE-START '(IL:FULLXPOINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:POINTER IL:WORD IL:POINTER IL:WORD IL:WORD) '((LINE-START 0 IL:FULLXPOINTER) (LINE-START 2 IL:FULLXPOINTER) (LINE-START 4 IL:FULLXPOINTER) (LINE-START 6 (IL:BITS . 15)) (LINE-START 7 (IL:BITS . 15)) (LINE-START 8 (IL:BITS . 15)) (LINE-START 9 (IL:BITS . 15)) (LINE-START 10 (IL:BITS . 15)) (LINE-START 12 IL:POINTER) (LINE-START 11 (IL:BITS . 15)) (LINE-START 14 IL:POINTER) (LINE-START 16 (IL:BITS . 15)) (LINE-START 17 (IL:BITS . 15))) '18) (IL:/DECLAREDATATYPE 'LIST-FORMAT '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((LIST-FORMAT 0 IL:POINTER) (LIST-FORMAT 2 IL:POINTER) (LIST-FORMAT 4 IL:POINTER) (LIST-FORMAT 6 IL:POINTER) (LIST-FORMAT 8 IL:POINTER)) '10) (IL:/DECLAREDATATYPE 'STRING-ITEM '(IL:POINTER IL:WORD IL:FULLXPOINTER IL:FLAG) '((STRING-ITEM 0 IL:POINTER) (STRING-ITEM 2 (IL:BITS . 15)) (STRING-ITEM 4 IL:FULLXPOINTER) (STRING-ITEM 3 (IL:FLAGBITS . 0))) '6) (IL:/DECLAREDATATYPE 'WEAK-LINK '(IL:FULLXPOINTER) '((WEAK-LINK 0 IL:FULLXPOINTER)) '2) (IL:ADDTOVAR IL:SYSTEMRECLST (IL:DATATYPE BROKEN-ATOM (ATOM-CHARS)) (IL:DATATYPE EDIT-CONTEXT (ENVIRONMENT PROFILE EVAL-FN EVAL-IN-PROCESS CONTEXT-LOCK COMPLETION-EVENT EDIT-TYPE ICON-TITLE EDIT-OPTIONS COMMENT-WIDTH COMMENT-SEPARATION FIND-CANDIDATE SUBSTITUTE-CANDIDATE DISPLAY-WINDOW WINDOW-LEFT WINDOW-BOTTOM WINDOW-RIGHT WINDOW-TOP ROOT ROOT-CHANGED-FN COMPLETION-FN CHANGED-STRUCTURE? ( DONT-COLLECT-CHANGES? IL:FLAG) CHANGED-NODES OPEN-NODE-CHANGED? OPEN-NODE OPEN-NODE-INFO ATOM-STARTED ATOM-STARTED-UNDO-POINTER UNDO-LIST UNDO-UNDO-LIST CARET CARET-POINT SELECTION SELECTION-DISPLAYED? (CURRENT-NODE IL:FULLXPOINTER) CURRENT-X (CURRENT-LINE IL:FULLXPOINTER) (LAST-LINEARIZED-SUB-NODE-INDEX IL:WORD) (LINEAR-POINTER IL:FULLXPOINTER) (LINEAR-PREV IL:FULLXPOINTER) LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK CURRENT-BLOCK MATCHING? BELOW? VISIBLE? (REPAINT-START IL:FULLXPOINTER) (REPAINT-LINE IL:FULLXPOINTER) REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT)) (IL:DATATYPE EDIT-ENV (PARSE-INFO PARSE-INFO-UNKNOWN USER-DATA DEFAULT-FONT ITALIC-FONT KEYWORD-FONT COMMENT-FONT BROKEN-ATOM-FONT SPACE-WIDTH DEFAULT-LINE-SKIP EM-WIDTH INDENT-BASE INDENT-STEP MAX-WIDTH COMMENT-WIDTH-PERCENT INIT-COMMENT-SEPARATION LPAREN-STRING RPAREN-STRING DOT-STRING QUOTE-STRING COMMENT-STRING COMMAND-TABLE DEFAULT-CHAR-HANDLER HELP-MENU)) (IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER) FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER) (DEPTH IL:WORD) (SUB-NODE-INDEX IL:WORD) STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER) LINEAR-FORM (START-X IL:WORD) (RIGHT-MARGIN IL:WORD) (PREFERRED-WIDTH IL:WORD) (ACTUAL-WIDTH IL:WORD) (CHANGED? IL:FLAG) INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE)) (IL:DATATYPE EDIT-NODE-TYPE (NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED SET-POINT COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION SET-SELECTION GROW-SELECTION SELECT-SEGMENT INSERT DELETE COPY-STRUCTURE COPY-SELECTION STRINGIFY BACK-SPACE CLOSE-NODE)) (IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER) POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER) POINT-STRING POINT-OFFSET)) (IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER) SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE? SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER) SELECT-END-X (SELECT-END-LINE IL:FULLXPOINTER) SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET)) (IL:DATATYPE GAP (LINEAR-ITEM)) (IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER) BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE BLOCK-ASCENT BLOCK-DESCENT)) (IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER) (PREV-LINE IL:FULLXPOINTER) (NODE IL:FULLXPOINTER) (LINE-ASCENT IL:WORD) (LINE-DESCENT IL:WORD) (LINE-SKIP IL:WORD) (LINE-LENGTH IL:WORD) (INDENT IL:WORD) YCOORD (CACHE-TIME IL:WORD) CACHED-Y (CACHED-ASCENT IL:WORD) (CACHED-DESCENT IL:WORD))) (IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS)) (IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING)) (IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD) (FONT IL:FULLXPOINTER) (PRIN-2? IL:FLAG))) (IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER))) ) (IL:PUTPROPS IL:SEDIT-ACCESS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-ATOMIC b/sources/SEDIT-ATOMIC new file mode 100644 index 00000000..5a2af2e0 --- /dev/null +++ b/sources/SEDIT-ATOMIC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:37:57" IL:|{DSK}local>lde>lispcore>sources>SEDIT-ATOMIC.;3| 43305 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-ATOMICCOMS) IL:|previous| IL:|date:| "30-Mar-90 01:10:14" IL:|{DSK}local>lde>lispcore>sources>SEDIT-ATOMIC.;2|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-ATOMICCOMS) (IL:RPAQQ IL:SEDIT-ATOMICCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-ATOMIC) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-ATOMIC) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:FNS ASSIGN-FORMAT-LITATOM ATOM-POINT-TYPE BACKSPACE-GAP BACKSPACE-LITATOM BACKSPACE-UNKNOWN CLOSE-NODE-LITATOM COMPUTE-POINT-POSITION-LITATOM COMPUTE-SELECTION-POSITION-LITATOM CONS-ATOM COPY-SELECTION-LITATOM COPY-STRUCTURE-STRING DELETE-LITATOM DETRANSLATE-CHARS GET-BUTTON-STRING GROW-SELECTION-LITATOM HASFAT INITIALIZE-ATOMIC INSERT-LITATOM INSERT-STRING OPEN-LITATOM PARSE--BROKEN-ATOM PARSE--LITATOM PARSE--STRING RELEASE-OPEN-STRING REPLACE-CHARS REPLACE-STRING SCAN-STRING SELECT-SEGMENT-LITATOM SET-POINT-LITATOM SET-POINT-STRING SET-SELECTION-LITATOM SET-SELECTION-STRING SPLIT-LITATOM STRINGIFY-ATOM TRANSLATE-CHARS UNDO-ATOM-CHANGE))) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:DEFINEQ (assign-format-litatom (il:lambda (node context format) (il:* il:\; "Edited 19-Nov-87 16:43 by DCB") (il:* il:|;;;| "atoms have no children, so the format will not propagate further. normal nodes can get relinearized if their placement changes, even if their format type did not change. however, the presentation of an atom changes only when its format type changes (from KeyWord to NIL or back). thus to avoid unnecessary relinearization, the parse method for atoms builds a prelinearized node, and here we fiddle the prelinearized node to account for the change in font between KeyWord atoms and normal ones. ") (il:* il:|;;;| "note that when building the SEdit tree from scratch, the format will necessarily have changed, so this routine will get called whether the prelinearized node needs patching (changed to keyword) or not.") (let* ((atom (il:|fetch| structure il:|of| node)) (broken? (il:|type?| broken-atom atom)) (environment (il:\\dtest (il:|fetch| environment il:|of| context) (quote edit-env))) (font (cond (broken? (il:setq atom (il:fetch atom-chars il:of atom)) (il:fetch broken-atom-font il:of environment)) ((eq format :keyword) (il:|ffetch| keyword-font il:|of| environment)) (t (il:|ffetch| default-font il:|of| environment)))) (string-item (car (il:|ffetch| linear-form il:|of| node))) width) (il:* il:\; "read table specific") (when (and (not (and (il:|ffetch| open-node-changed? il:|of| context) (eq (il:ffetch open-node il:of context) node))) (or (il:ffetch changed? il:of node) (and (not broken?) (il:stringp (il:|ffetch| string il:|of| string-item))) (il:neq font (il:|fetch| font il:|of| string-item)))) (il:* il:|;;| "this stuff gets run only if the prelinearized node is wrong. (see comment above.)") (il:setq width (stringwidth atom font (not broken?))) (il:|freplace| string il:|of| string-item il:|with| atom) (il:|freplace| font il:|of| string-item il:|with| font) (il:|freplace| prin-2? il:|of| string-item il:|with| (not broken?)) (il:|freplace| width il:|of| string-item il:|with| width) (il:|freplace| inline-width il:|of| node il:|with| width) (il:|freplace| preferred-width il:|of| node il:|with| width) (il:|freplace| actual-width il:|of| node il:|with| width) (il:|freplace| actual-llength il:|of| node il:|with| width) (when (eq (il:|ffetch| open-node il:|of| context) node) (il:|freplace| open-node il:|of| context il:|with| nil))))) ) (atom-point-type (il:lambda (str index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;;| "used to pass read.table, but now under profile just use *READTABLE* directly.") (il:for c il:instring str il:as i il:to index il:bind (result il:_ (quote atom)) (esc-char il:_ (escape-char)) (mult-esc-char il:_ (il:fetch (readtablep il:multescapechar) il:of *readtable*)) escaped il:do (cond (escaped (il:setq escaped nil)) ((eq c esc-char) (il:setq escaped t)) ((eq c mult-esc-char) (il:setq result (if (eq result (quote atom)) (quote esc-atom) (quote atom))))) il:finally (return result))) ) (backspace-gap (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;;| "handle the case of backspacing onto a gap. should pending delete select it.") (cond (index (il:shouldnt "point can't be in a gap")) (t (set-selection-me (il:fetch selection il:of context) context node) (pending-delete (il:fetch caret-point il:of context) (il:fetch selection il:of context))))) ) (backspace-litatom (il:lambda (node context index string) (il:* il:\; "Edited 24-Nov-87 08:14 by DCB") (il:* il:|;;| "the BackSpace method for litatoms and strings") (cond ((null index) (il:* il:|;;| "backspacing from the right boundary puts the caret immediately after the last character") (set-point-litatom (il:fetch caret-point il:of context) context node nil t) (set-selection-nowhere (il:fetch selection il:of context))) ((eq index 0) (cond ((eq 0 (il:nchars string)) (il:* il:|;;| "backspacing from the front of an empty string deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil (il:fetch caret-point il:of context))) (t (il:* il:|;;| "might be at the front of a quote to degrade") (let* ((super-node (il:fetch super-node il:of node)) (super-type (il:fetch node-type il:of super-node))) (when (eq super-type type-quote) (il:* il:|;;| "used to call backspace-quote directly here, now indirect through type") (funcall (il:fetch back-space il:of super-type) super-node context 0)))))) (t (il:* il:|;;| "otherwise, delete the character to the left of the caret") (let ((start index) end) (when (il:neq (il:fetch node-type il:of node) type-string) (il:* il:\; "read table specific") (il:for i il:from (il:sub1 index) il:to 1 il:by -1 il:bind (esc il:_ (escape-char)) il:while (eq (il:nthcharcode string i) esc) il:finally (when (evenp (il:idifference i index)) (il:setq end start) (il:setq start (il:sub1 start))))) (delete-litatom node context start end (il:fetch caret-point il:of context) string) (when (not (dead-node? node)) (il:* il:|;;| "if the atom's still there, cancel the selection. otherwise don't worry about it, the delete method might have set it") (set-selection-nowhere (il:fetch selection il:of context))))))) ) (backspace-unknown (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (cond (index (il:shouldnt "point shouldn't be in an unknown node")) (t (il:* il:|;;| "jump caret to before the unknown node") (set-point (il:fetch caret-point il:of context) context node nil nil nil (quote structure)) (set-selection-nowhere (il:fetch selection il:of context))))) ) (close-node-litatom (il:lambda (context node) (il:* il:\; "Edited 19-Nov-87 16:10 by DCB") (cond ((and (eq node (il:|fetch| atom-started il:|of| context)) (eq (il:|fetch| undo-list il:|of| context) (il:|fetch| atom-started-undo-pointer il:|of| context)) (null (il:|fetch| undo-undo-list il:|of| context))) (il:* il:\; "don't record this as a separate undo event") (il:|replace| atom-started il:|of| context il:|with| nil) (il:|replace| atom-started-undo-pointer il:|of| context il:|with| nil)) (t (undo-by undo-atom-change node (il:|fetch| structure il:|of| node)))) (let* ((string-item (car (il:|fetch| linear-form il:|of| node))) (old-string (il:|fetch| string il:|of| string-item)) (new-string (il:|replace| structure il:|of| node il:|with| (cons-atom old-string (il:neq (il:|fetch| node-type il:|of| node) type-string))))) (il:|replace| string il:|of| string-item il:|with| (cond ((il:stringp new-string) new-string) (t (il:* il:|;;| "this is a litatom, so we have to make sure the string item has a copy") (il:setq new-string (il:concat old-string))))) (release-open-string old-string new-string (il:|fetch| caret-point il:|of| context) (il:|fetch| selection il:|of| context)) (subnode-changed node context) (cond ((eq (il:|fetch| node-type il:|of| node) type-string) (note-change-in-simple node context) (il:replace open-node il:of context il:with nil)) (t (note-change node context))))) ) (compute-point-position-litatom (il:lambda (point context) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;| "implements the ComputePointPosition method for a litatom or string. string.offset does all the work") (let ((node (il:fetch point-node il:of point))) (il:* il:|;;| "read table specific. used to pass read.table as 5th arg to string.offset. now just flag prin2? for it and it will do the right thing using the current readtable.") (string-offset (il:fetch point-string il:of point) nil (il:fetch point-index il:of point) (il:fetch font il:of (car (il:fetch linear-form il:of node))) (eq (il:fetch node-type il:of node) type-string) point (il:fetch start-x il:of node)) (il:replace point-line il:of point il:with (il:fetch first-line il:of node)))) ) (compute-selection-position-litatom (il:lambda (selection context) (il:* il:\; "Edited 7-Jul-87 08:26 by DCB") (il:* il:|;;| "implements the ComputeSelectionPosition method for a litatom or string. string.offset does all the work") (let* ((node (il:fetch select-node il:of selection)) (string-item (car (il:fetch linear-form il:of node)))) (il:* il:\; "read table specific") (string-offset (il:fetch select-string il:of selection) (il:fetch select-start il:of selection) (or (il:fetch select-end il:of selection) (il:fetch select-start il:of selection)) (il:fetch font il:of string-item) (eq (il:fetch node-type il:of node) type-string) selection (il:fetch start-x il:of node)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of node)) (il:replace select-end-line il:of selection il:with (il:fetch select-start-line il:of selection)))) ) (cons-atom (il:lambda (chars atom?) (il:* il:\; "Edited 19-Nov-87 14:37 by DCB") (il:* il:|;;;| "read table specific. used to pass in read.table, but now must run under sedit profile using *readtable*") (if atom? (let (result) (if (il:setq result (il:nlsetq (il:read (il:openstringstream chars (quote il:input))))) (car result) (il:create broken-atom atom-chars il:_ (il:concat chars)))) (cond ((null chars) (il:allocstring 0)) ((hasfat chars) (il:concat chars)) (t (il:\\smashstring (il:allocstring (il:nchars chars)) 0 chars))))) ) (copy-selection-litatom (il:lambda (selection context destination point delete?) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "implements the CopySelection method for a litatom or string. Assume under sedit profile..") (let* ((node (il:fetch select-node il:of selection)) (chars (il:fetch structure il:of node)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (string (il:fetch select-string il:of selection)) (type (il:fetch select-type il:of selection)) not-all-selected) (when (il:type? broken-atom chars) (il:setq chars (il:fetch atom-chars il:of chars))) (when (eq type (quote structure)) (il:setq string (get-button-string node context)) (il:setq type (if (eq (il:fetch node-type il:of node) type-string) (quote string) (quote atom)))) (when (and start (or (il:neq (or end (il:setq end start)) (il:nchars string)) (il:neq start 1))) (il:* il:|;;| "some subset of the atom/string has been selected") (il:setq not-all-selected t)) (cond ((null destination) (il:* il:|;;| "it's going to a foreign sink; bksysbuf it") (il:bksysbuf (if not-all-selected (detranslate-chars (il:substring string start end) type) chars) (if (eq type (quote string)) (null start) (not not-all-selected))) (when delete? (delete-nodes node context start end nil string))) ((and (eq type (quote string)) (null start)) (il:* il:|;;| "strings insert as whole structures") (copy-selection-default selection context destination point delete?)) ((eq (il:fetch point-type il:of point) (quote structure)) (il:* il:|;;| "make the selected characters into a new atom or string") (with-profile (il:fetch profile il:of destination) (cond ((and delete? (il:neq (il:fetch node-type il:of node) type-string) (not not-all-selected) (delete-nodes node context)) (il:* il:|;;| "if we're moving the whole atom, we can just reuse the node") (il:* il:|;;| "assume under sedit profile for this call to stringwidth") (adjust-width node nil (stringwidth chars (il:fetch font il:of (car (il:fetch linear-form il:of node))) t))) (t (when (or (eq (il:fetch node-type il:of node) type-string) not-all-selected (il:type? broken-atom (il:fetch structure il:of node))) (il:setq chars (cons-atom (if start (il:substring string start end) string) t)) (when (and delete? not-all-selected) (delete-nodes node context start end nil string))) (il:* il:|;;| "again here need sedit profile to create.simple.node.") (il:setq node (create-simple-node chars (il:fetch environment il:of destination) type-litatom (if (il:type? broken-atom chars) (il:fetch atom-chars il:of chars) chars) (not (il:type? broken-atom chars)) (if (il:type? broken-atom chars) (il:fetch broken-atom-font il:of (il:fetch environment il:of destination)) (il:fetch default-font il:of (il:fetch environment il:of destination))))))) (insert point destination (list node)) (when start (set-point-litatom point destination node nil t)))) (t (il:* il:|;;| "we're adding characters to an existing string or atom") (with-profile (il:fetch profile il:of destination) (let ((new-chars (il:concat (if not-all-selected (il:substring string start end) string)))) (when delete? (delete-nodes node context start end nil string)) (insert point destination (detranslate-chars new-chars type)))))))) ) (copy-structure-string (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "the CopyStructure method for strings and litatoms. the Structure and LinearForm fields have already been filled in with the values from the node we're a copy of, but we want to copy these structures in case we decide to smash them later. Assume under sedit profile.") (let* ((structure (il:fetch structure il:of node)) (font (il:fetch font il:of (car (il:fetch linear-form il:of node)))) (prin-2? (not (il:type? broken-atom structure)))) (il:replace structure il:of node il:with (cond ((il:stringp structure) (il:setq structure (il:concat structure))) ((il:type? broken-atom structure) (il:create broken-atom atom-chars il:_ (il:setq structure (il:concat (il:fetch atom-chars il:of structure))))) (t structure))) (rplaca (il:fetch linear-form il:of node) (il:create string-item string il:_ structure font il:_ font prin-2? il:_ prin-2?)) (il:* il:|;;| "assume running under sedit profile for this call to stringwidth") (il:* il:\; "read table specific") (adjust-width node nil (stringwidth structure font prin-2?)))) ) (delete-litatom (il:lambda (node context start end set-point? string) (il:* il:\; "Edited 23-Nov-87 19:10 by DCB") (il:* il:|;;| "the Delete method for strings and litatoms") (cond ((and (il:neq (il:fetch node-type il:of node) type-string) (eq start 1) (eq (or end start) (il:nchars string))) (il:* il:|;;| "deleting all the characters in an atom deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil set-point?)) (t (replace-string node context start (or end start) "" set-point? string (and (il:neq (il:fetch node-type il:of node) type-string) (atom-point-type string start))) t))) ) (detranslate-chars (il:lambda (str type) (il:* il:\; "Edited 16-Jul-87 15:42 by DCB") (il:* il:|;;;| "read table specific. used to take read.table, now just uses *READTABLE* for profiles.") (when (il:neq type (quote string)) (il:setq str (il:copyall str)) (il:|for| c il:|instring| str il:|bind| escaped? (length il:_ 0) (esc il:_ (escape-char)) (multi-esc il:_ (il:|fetch| (readtablep il:multescapechar) il:|of| *readtable*)) (upcase? il:_ (il:|fetch| (readtablep il:caseinsensitive) il:|of| *readtable*)) il:|first| (il:setq type (and upcase? (eq type (quote atom)))) il:|do| (cond (escaped? nil) ((eq c multi-esc) (il:setq type (and upcase? (not type))) (il:setq c nil)) ((eq c esc) (il:setq escaped? t) (il:setq c nil)) ((and type (il:igeq c (il:charcode \a)) (il:ileq c (il:charcode \z))) (il:setq c (il:iplus c (il:constant (il:idifference (il:charcode a) (il:charcode \a))))))) (when c (il:rplcharcode str (il:setq length (il:add1 length)) c)) il:|finally| (il:|replace| (il:stringp il:length) il:|of| str il:|with| length))) str) ) (get-button-string (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "assume this is running under sedit profile.") (cond ((eq button-string-node node) button-string) (t (il:setq button-string-node node) (il:setq button-string (car (il:fetch linear-form il:of node))) (il:* il:\; "read table specific") (il:setq button-string (if (and (il:neq (il:fetch node-type il:of node) type-string) (il:fetch prin-2? il:of button-string)) (prin1-to-string (il:fetch string il:of button-string)) (princ-to-string (il:fetch string il:of button-string))))))) ) (grow-selection-litatom (il:lambda (selection context node) (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:* il:|;;;| "the GrowSelection method for litatoms and strings. if the whole node is already selected, select the super; otherwise select the whole node") (if (null (il:fetch select-start il:of selection)) (grow-selection-default selection context node) (set-selection-me selection context node))) ) (hasfat (il:lambda (str) (il:* il:\; "Edited 19-Nov-87 14:35 by DCB") (il:for c il:instring str il:thereis (il:igreaterp c il:\\maxthinchar))) ) (initialize-atomic (il:lambda nil (il:* il:\; "Edited 7-Jul-87 08:31 by DCB") (il:setq types (list* (il:setq type-litatom (il:create edit-node-type name il:_ (quote litatom) assign-format il:_ (quote assign-format-litatom) compute-format-values il:_ (quote il:nill) linearize il:_ nil sub-node-changed il:_ (quote il:shouldnt) compute-point-position il:_ (quote compute-point-position-litatom) compute-selection-position il:_ (quote compute-selection-position-litatom) set-point il:_ (quote set-point-litatom) set-selection il:_ (quote set-selection-litatom) grow-selection il:_ (quote grow-selection-litatom) select-segment il:_ (quote select-segment-litatom) insert il:_ (quote insert-litatom) delete il:_ (quote delete-litatom) copy-structure il:_ (quote copy-structure-string) copy-selection il:_ (quote copy-selection-litatom) stringify il:_ (quote stringify-atom) back-space il:_ (quote backspace-litatom) close-node il:_ (quote close-node-litatom))) (il:setq type-string (il:create edit-node-type il:using type-litatom name il:_ (quote string) assign-format il:_ (quote il:nill) set-point il:_ (quote set-point-string) set-selection il:_ (quote set-selection-string) insert il:_ (quote insert-string))) types))) ) (insert-litatom (il:lambda (node context where char point) (il:* il:\; "Edited 17-Jul-87 09:47 by DCB") (il:* il:|;;;| "the Insert method for litatoms") (il:* il:\; "read table specific") (insert-string node context where (and char (translate-chars char (if (il:type? edit-selection where) (il:fetch select-type il:of where) (il:fetch point-type il:of where)) (eq *print-case* :upcase))) point)) ) (insert-string (il:lambda (node context where chars point) (il:* il:\; "Edited 30-Nov-87 12:58 by DCB") (il:* il:|;;;| "the Insert method for strings") (let (start end string type) (cond ((il:type? edit-selection where) (il:setq start (il:fetch select-start il:of where)) (il:setq end (or (il:fetch select-end il:of where) start)) (il:setq string (il:fetch select-string il:of where)) (il:setq type (il:fetch select-type il:of where))) (t (il:setq end (il:fetch point-index il:of where)) (il:setq start (il:add1 end)) (il:setq string (il:fetch point-string il:of where)) (il:setq type (il:fetch point-type il:of where)))) (il:* il:|;;| "first replace any old chars with new chars") (replace-string node context start end (or chars "") point string type) (il:* il:|;;| "now do any indicated split ") (unless (or chars (dead-node? node)) (split-litatom node point context start (1- start) (il:fetch string il:of (car (il:fetch linear-form il:of node))))))) ) (open-litatom (il:lambda (context node string length) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (when (null length) (il:setq length 0)) (cond ((il:neq (il:fetch open-node il:of context) node) (close-open-node context) (il:replace open-node il:of context il:with node) (let ((open-string (il:fetch open-node-info il:of context)) (string-length (il:nchars string)) (string-item (car (il:fetch linear-form il:of node))) sub-string) (il:replace prin-2? il:of string-item il:with (eq (il:fetch node-type il:of node) type-string)) (il:replace real-length il:of open-string il:with string-length) (il:setq sub-string (il:fetch substring il:of open-string)) (when (il:ilessp (il:nchars (il:fetch buffer-string il:of open-string)) (il:setq length (il:iplus string-length (il:imax length 0)))) (il:substring (il:replace buffer-string il:of open-string il:with (il:allocstring length nil nil t)) 1 1 sub-string)) (il:rplstring (il:fetch buffer-string il:of open-string) 1 string) (il:replace (il:stringp il:length) il:of sub-string il:with string-length) (il:replace string il:of string-item il:with sub-string))) (t (let ((open-string (il:fetch open-node-info il:of context))) (when (il:igreaterp length 0) (when (il:ilessp (il:nchars (il:fetch buffer-string il:of open-string)) (il:setq length (il:iplus (il:fetch real-length il:of open-string) length))) (il:substring (il:replace buffer-string il:of open-string il:with (il:rplstring (il:allocstring length nil nil t) 1 (il:fetch buffer-string il:of open-string))) 1 1 (il:fetch substring il:of open-string)))) (il:replace string il:of (car (il:fetch linear-form il:of node)) il:with (il:fetch substring il:of open-string)))))) ) (parse--broken-atom (il:lambda (structure context mode) (il:* il:\; "Edited 17-Jul-87 09:04 by DCB") (il:* il:|;;;| "parse a BrokenAtom structure (presumably left there by a previous editing session)") (build-prelinearized-node structure context type-litatom (il:fetch atom-chars il:of structure) nil (il:fetch broken-atom-font il:of (il:fetch environment il:of context)))) ) (parse--litatom (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (il:* il:|;;;| "parse a litatom (this actually includes numbers). ") (il:* il:|;;;| "this used to take a parse mode as an argument, and if the parse mode was BindingList, it would call parse..list. parse..list now knows to make sure that its second child gets parsed as a list.") (il:* il:|;;;| "when the atom turns to a keyword, its linearization will have to be twiddled. see the comments in assign.format.litatom. ") (build-prelinearized-node structure context type-litatom structure t (il:fetch default-font il:of (il:fetch environment il:of context)))) ) (parse--string (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (il:* il:|;;;| "parse a string") (build-prelinearized-node structure context type-string structure t (il:fetch default-font il:of (il:fetch environment il:of context)))) ) (release-open-string (il:lambda (old-string new-string point selection) (il:* il:\; "Edited 7-Jul-87 08:38 by DCB") (when (eq (il:fetch point-string il:of point) old-string) (il:replace point-string il:of point il:with new-string)) (when (eq (il:fetch select-string il:of selection) old-string) (il:replace select-string il:of selection il:with new-string))) ) (REPLACE-CHARS (IL:LAMBDA (NODE CONTEXT START END CHARS POINT TYPE STRING-ITEM) (IL:* IL:\; "Edited 28-Mar-90 19:14 by jds") (IL:* IL:|;;;| "replace the substring of this (open) node bounded by start and end (inclusive) with the characters in chars. set point after the inserted characters.") (IL:* IL:|;;| "read table specific") (IL:SETQ BUTTON-STRING-NODE (IL:SETQ BUTTON-STRING NIL)) (LET* ((DELTA-LENGTH (IL:IDIFFERENCE (IL:NCHARS CHARS) (IL:ADD1 (IL:IDIFFERENCE END START)))) (NEW-END (IL:IPLUS END DELTA-LENGTH)) (PRIN-2? (AND (EQ TYPE 'STRING) (IL:|fetch| PRIN-2? IL:|of| STRING-ITEM))) (MULTI-ESCAPE (AND (IL:NEQ TYPE 'STRING) (IL:|fetch| (READTABLEP IL:MULTESCAPECHAR) IL:|of| *READTABLE*) )) (ADD-MULTI-ESCAPE?) (COMPUTE-NEW-POINT-TYPE?) (OPEN-STRING (IL:|fetch| OPEN-NODE-INFO IL:|of| CONTEXT)) (STRING (IL:|fetch| BUFFER-STRING IL:|of| OPEN-STRING)) (LENGTH (IL:|fetch| REAL-LENGTH IL:|of| OPEN-STRING)) (FONT (IL:|fetch| FONT IL:|of| STRING-ITEM)) (DELTA-WIDTH (IL:IDIFFERENCE (STRINGWIDTH (IL:MKSTRING CHARS) FONT PRIN-2?) (STRINGWIDTH (IF (IL:ILEQ START END) (IL:SUBSTRING STRING START END) "") FONT PRIN-2?)))) (WHEN MULTI-ESCAPE (IL:|bind| (ESCAPE IL:_ (ESCAPE-CHAR)) C IL:|for| I IL:|from| START IL:|to| END IL:|do| (IL:SETQ C (IL:NTHCHARCODE STRING I)) (COND ((EQ C ESCAPE) (IL:SETQ I (IL:ADD1 I))) ((EQ C MULTI-ESCAPE) (IL:SETQ ADD-MULTI-ESCAPE? (NOT ADD-MULTI-ESCAPE?))))) (WHEN ADD-MULTI-ESCAPE? (SETF COMPUTE-NEW-POINT-TYPE? T) (IL:SETQ ADD-MULTI-ESCAPE? (COND ((AND (IL:NEQ END LENGTH) (EQ (IL:NTHCHARCODE STRING (IL:ADD1 END)) MULTI-ESCAPE)) (IL:SETQ END (IL:ADD1 END)) -1) (T 1))) (IL:SETQ DELTA-LENGTH (IL:IPLUS DELTA-LENGTH ADD-MULTI-ESCAPE?)) (IL:SETQ DELTA-WIDTH (IL:IPLUS DELTA-WIDTH (IL:ITIMES ADD-MULTI-ESCAPE? (IL:CHARWIDTH MULTI-ESCAPE FONT)) )))) (IL:|replace| REAL-LENGTH IL:|of| OPEN-STRING IL:|with| (IL:IPLUS LENGTH DELTA-LENGTH)) (COND ((AND (EQ 0 (IL:IPLUS LENGTH DELTA-LENGTH)) (IL:NEQ (IL:FETCH NODE-TYPE IL:OF NODE) TYPE-STRING)) (CLOSE-OPEN-NODE CONTEXT) (DELETE-NODES (IL:FETCH SUPER-NODE IL:OF NODE) CONTEXT NODE NIL POINT)) (T (WHEN (IL:NEQ END LENGTH) (IL:* IL:|;;|  "there are characters after the replacement, so shift them forward or backward as appropriate") (SHIFT-STRING STRING (IL:ADD1 END) (IL:IPLUS END DELTA-LENGTH 1) (IL:IDIFFERENCE LENGTH END))) (IL:RPLSTRING STRING START CHARS) (WHEN (EQ ADD-MULTI-ESCAPE? 1) (IL:RPLCHARCODE STRING (IL:ADD1 NEW-END) MULTI-ESCAPE)) (IL:|replace| (IL:STRINGP IL:LENGTH) IL:|of| (IL:SETQ STRING (IL:|fetch| SUBSTRING IL:|of| OPEN-STRING)) IL:|with| (IL:IPLUS LENGTH DELTA-LENGTH)) (ADJUST-WIDTH NODE CONTEXT (IL:IPLUS (IL:|fetch| INLINE-WIDTH IL:|of| NODE) DELTA-WIDTH)) (IL:|replace| OPEN-NODE-CHANGED? IL:|of| CONTEXT IL:|with| T) (WHEN POINT (IL:|replace| POINT-NODE IL:|of| POINT IL:|with| NODE) (IL:|replace| POINT-STRING IL:|of| POINT IL:|with| STRING) (IL:|replace| POINT-INDEX IL:|of| POINT IL:|with| NEW-END) (IL:|replace| POINT-TYPE IL:|of| POINT IL:|with| (IF COMPUTE-NEW-POINT-TYPE? (  ATOM-POINT-TYPE STRING NEW-END) TYPE))) (LET ((CARET (IL:|fetch| CARET-POINT IL:|of| CONTEXT))) (WHEN (AND (IL:NEQ CARET POINT) (EQ (IL:FETCH POINT-NODE IL:OF CARET) NODE) (IL:IGEQ (IL:FETCH POINT-INDEX IL:OF CARET) START)) (IL:* IL:|;;|  "if the caret was within or after replaced characters, it will need to be fixed up") (IL:REPLACE POINT-INDEX IL:OF CARET IL:WITH (IL:IPLUS DELTA-LENGTH (IL:IMAX (IL:FETCH POINT-INDEX IL:OF CARET) END))) (IL:REPLACE POINT-STRING IL:OF CARET IL:WITH STRING)))))))) (replace-string (il:lambda (node context start end chars point string type) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "replace the substring of this string node bounded by start and end (inclusive) with the characters in chars. set point after the inserted characters.") (open-litatom context node string (il:idifference (il:nchars chars) (il:add1 (il:idifference end start)))) (replace-chars node context start end chars point (or type (quote string)) (car (il:fetch linear-form il:of node)))) ) (scan-string (il:lambda (point-or-sel node read-table string font offset string?) (il:* il:\; "Edited 17-Jul-87 09:07 by DCB") (il:* il:|;;;| "given a string item and pixel offset from the start of the string, find the character pointed to. if string?, assume that string delim characters in the string are escaped and the string is preceded and followed by stringdelims") (il:bind in-multi-esc c cwidth (index il:_ 0) (x il:_ 0) (length il:_ (il:nchars string)) (point? il:_ (il:type? edit-point point-or-sel)) (esc-char il:_ (escape-char read-table)) (multi-esc-char il:_ (il:fetch (readtablep il:multescapechar) il:of (or read-table *readtable*))) il:first (when string? (il:setq cwidth (il:charwidth (il:charcode \") font)) (when (and (not point?) (il:ileq offset cwidth)) (set-selection-me point-or-sel nil (il:fetch select-node il:of point-or-sel)) (return)) (il:setq offset (il:idifference offset cwidth)) (il:setq x (il:iplus x cwidth))) il:while (il:ileq (il:setq index (il:add1 index)) length) il:do (il:setq cwidth (il:charwidth (il:setq c (il:nthcharcode string index)) font)) (if string? (cond ((or (eq c esc-char) (eq c (il:charcode \"))) (il:setq cwidth (il:iplus cwidth (il:charwidth esc-char font)))) ((il:ilessp c (il:charcode il:space)) (il:setq cwidth (il:iplus (il:charwidth (il:charcode ^) font) (il:charwidth (il:iplus c 64) font))))) (when (eq c esc-char) (il:setq cwidth (il:iplus cwidth (il:charwidth (il:nthcharcode string (il:add1 index)) font))))) (when (il:ileq offset (if point? (il:half cwidth) cwidth)) (go il:$$out)) (il:setq offset (il:idifference offset cwidth)) (il:setq x (il:iplus x cwidth)) (when (not string?) (cond ((eq c esc-char) (il:setq index (il:add1 index))) ((eq c multi-esc-char) (il:setq in-multi-esc (not in-multi-esc))))) il:finally (when (and string? (not point?) (il:igreaterp index length)) (set-selection-me point-or-sel nil (il:fetch select-node il:of point-or-sel)) (return)) (il:setq in-multi-esc (cond (string? (quote string)) (in-multi-esc (quote esc-atom)) (t (quote atom)))) (cond (point? (il:replace point-index il:of point-or-sel il:with (il:sub1 index)) (il:replace point-type il:of point-or-sel il:with in-multi-esc) (il:replace point-line il:of point-or-sel il:with (il:fetch first-line il:of node)) (il:replace point-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x))) (t (when (and (not string?) (il:igreaterp index length)) (il:shouldnt "select past end of atom")) (cond ((not (il:fetch select-start il:of point-or-sel)) (il:replace select-start il:of point-or-sel il:with index) (il:replace select-end il:of point-or-sel il:with (and (not string?) (eq c esc-char) (il:add1 index))) (il:replace select-type il:of point-or-sel il:with in-multi-esc) (il:replace select-start-line il:of point-or-sel il:with (il:replace select-end-line il:of point-or-sel il:with (il:fetch first-line il:of node))) (il:replace select-end-x il:of point-or-sel il:with (il:iplus cwidth (il:replace select-start-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x))))) (t (il:* il:\; "extending a point.or.sel") (when (not (il:fetch select-end il:of point-or-sel)) (il:replace select-end il:of point-or-sel il:with (il:fetch select-start il:of point-or-sel))) (cond ((il:ilessp index (il:fetch select-start il:of point-or-sel)) (il:* il:\; "extend the point.or.sel to the left") (il:replace select-start il:of point-or-sel il:with index) (il:replace select-start-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x)) (il:replace select-type il:of point-or-sel il:with in-multi-esc)) ((il:igreaterp (if (and (not string?) (eq c esc-char)) (il:setq index (il:add1 index)) index) (il:fetch select-end il:of point-or-sel)) (il:* il:\; "extend the point.or.sel to the right") (il:replace select-end il:of point-or-sel il:with index) (il:replace select-end-x il:of point-or-sel il:with (il:iplus (il:fetch start-x il:of node) x cwidth)))))))))) ) (select-segment-litatom (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "the SelectSegment method for litatoms and strings. scan.string does most of the work") (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil (il:fetch select-string il:of selection) (il:fetch font il:of item) offset (eq (il:fetch node-type il:of node) type-string))) ) (set-point-litatom (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 24-Nov-87 09:54 by DCB") (il:* il:|;;;| "the SetPoint method for litatoms") (cond ((eq type (quote structure)) (il:* il:|;;| "structure points will have to be handled by our super") (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch width il:of item))) offset) compute-location?)) (t (il:replace point-node il:of point il:with node) (il:replace point-string il:of point il:with (get-button-string node context)) (cond ((not index) (il:* il:|;;| "placing the caret at the beginning or end of the atom") (il:replace point-index il:of point il:with (if offset (il:nchars button-string) 0)) (il:replace point-type il:of point il:with (quote atom)) (when compute-location? (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of node) (if offset (il:fetch inline-width il:of node) 0))) (il:replace point-line il:of point il:with (il:fetch first-line il:of node)))) (t (il:* il:|;;| "pass NIL as readtable") (scan-string point node nil button-string (il:fetch font il:of item) offset)))))) ) (set-point-string (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the SetPoint method for strings. the point must be *inside* the delimiting quotes") (cond ((eq type (quote structure)) (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch width il:of item))) offset) compute-location?)) ((not index) (punt-set-point point context node offset compute-location?)) (t (il:replace point-node il:of point il:with node) (il:replace point-string il:of point il:with (get-button-string node context)) (il:* il:|;;| "pass NIL as readtable") (scan-string point node nil button-string (il:fetch font il:of item) offset t)))) ) (set-selection-litatom (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 24-Nov-87 09:55 by DCB") (il:* il:|;;;| "the SetSelection method for litatoms") (cond ((eq type (quote structure)) (il:* il:|;;| "structure selections get it all") (set-selection-me selection context node)) (t (il:replace select-node il:of selection il:with node) (il:replace select-string il:of selection il:with (get-button-string node context)) (il:replace select-start il:of selection il:with nil) (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil button-string (il:fetch font il:of item) offset)))) ) (set-selection-string (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the SetSelection method for strings") (cond ((eq type (quote structure)) (il:* il:|;;| "structure selections or pointing at the delimiting quotes gets the whole string") (set-selection-me selection context node)) (t (il:replace select-node il:of selection il:with node) (il:replace select-string il:of selection il:with (get-button-string node context)) (il:replace select-start il:of selection il:with nil) (il:* il:|;;| "pass NIL as readtable") (scan-string selection node nil button-string (il:fetch font il:of item) offset t)))) ) (split-litatom (il:lambda (node point context start end string) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:|;;;| "the Split method for litatoms and strings") (il:setq button-string-node (il:setq button-string nil)) (let ((length (il:nchars string)) suffix) (cond ((and (il:neq (il:fetch node-type il:of node) type-string) (eq start 1) (eq end length)) (il:* il:|;;| "deleting all the characters in an atom deletes it") (close-open-node context) (delete-nodes (il:fetch super-node il:of node) context node nil point)) (t (when (not (and (eq start (il:add1 end)) (or (eq start 1) (eq end length)))) (il:* il:|;;| "something's got to be changed") (open-litatom context node string) (let ((open-string (il:fetch open-node-info il:of context)) new-length) (cond ((eq end length) (il:setq new-length (il:sub1 start))) ((eq start 1) (il:setq new-length (il:idifference length end)) (shift-string (il:fetch buffer-string il:of open-string) (il:add1 end) 1 new-length)) (t (il:setq new-length (il:sub1 start)) (il:setq suffix (il:substring (il:fetch buffer-string il:of open-string) (il:add1 end) length)))) (il:replace real-length il:of open-string il:with new-length) (il:replace (il:stringp il:length) il:of (il:fetch substring il:of open-string) il:with new-length) (il:replace open-node-changed? il:of context il:with t))) (when suffix (start-undo-block)) (close-open-node context) (punt-set-point point context node (or (il:neq start 1) (eq end length)) nil) (when suffix (when (il:fetch point-node il:of point) (let (string) (il:* il:|;;| "use string to handle broken atoms: if the suffix is a broken atom, string will be the chars") (cond ((il:neq (il:fetch node-type il:of node) type-string) (il:* il:\; "read table specific") (il:setq suffix (cons-atom suffix t)) (when (il:type? broken-atom suffix) (il:setq string (il:fetch atom-chars il:of suffix)))) (t (il:setq suffix (il:concat suffix)))) (il:setq suffix (create-simple-node suffix (il:fetch environment il:of context) (il:fetch node-type il:of node) (or string suffix) (null string) (il:fetch default-font il:of (il:fetch environment il:of context))))) (insert point context suffix) (punt-set-point point context suffix nil nil)) (end-undo-block)))))) ) (stringify-atom (il:lambda (node environment) (il:* il:\; "Edited 7-Jul-87 08:39 by DCB") (il:* il:\; "read table specific") (il:mkstring (il:fetch structure il:of node) t)) ) (translate-chars (il:lambda (chars point-type upcase?) (il:* il:\; "Edited 16-Jul-87 15:36 by DCB") (il:* il:|;;;| "read table specific. used to take read.table, now just uses *READTABLE* for profiles.") (when (not (il:fetch (readtablep il:caseinsensitive) il:of *readtable*)) (il:setq upcase? t)) (il:bind (esc il:_ (escape-char)) (mult-esc il:_ (il:fetch (readtablep il:multescapechar) il:of *readtable*)) (r il:_ "") il:first (when (eq (il:nchars chars) 1) (il:setq c (il:chcon1 chars)) (return (if (and (il:neq c esc) (il:neq c mult-esc) (or (eq point-type (quote esc-atom)) (not (atom-char-escaped c)))) (if (or upcase? (il:ilessp c (il:charcode a)) (il:igreaterp c (il:charcode z)) (eq point-type (quote esc-atom))) chars (il:character (il:iplus c (il:constant (il:idifference (il:charcode \a) (il:charcode a)))))) (il:concat (il:character esc) chars)))) il:for c il:instring chars il:do (il:setq r (if (and (il:neq c esc) (il:neq c mult-esc) (or (eq point-type (quote esc-atom)) (not (atom-char-escaped c)))) (il:concat r (il:character (if (or upcase? (il:ilessp c (il:charcode a)) (il:igreaterp c (il:charcode z)) (eq point-type (quote esc-atom))) c (il:iplus c (il:constant (il:idifference (il:charcode \a) (il:charcode a))))))) (il:concat r (il:character esc) (il:character c)))) il:finally (return r))) ) (undo-atom-change (il:lambda (context node old-value) (il:* il:\; "Edited 7-Jul-87 08:40 by DCB") (undo-by undo-atom-change node (il:fetch structure il:of node)) (il:replace structure il:of node il:with old-value) (subnode-changed node context) (if (eq (il:fetch node-type il:of node) type-string) (note-change-in-simple node context) (note-change node context))) ) ) (IL:PUTPROPS IL:SEDIT-ATOMIC IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (2049 43188 (ASSIGN-FORMAT-LITATOM 2062 . 4448) (ATOM-POINT-TYPE 4450 . 5048) ( BACKSPACE-GAP 5050 . 5458) (BACKSPACE-LITATOM 5460 . 7222) (BACKSPACE-UNKNOWN 7224 . 7605) ( CLOSE-NODE-LITATOM 7607 . 9006) (COMPUTE-POINT-POSITION-LITATOM 9008 . 9781) ( COMPUTE-SELECTION-POSITION-LITATOM 9783 . 10656) (CONS-ATOM 10658 . 11196) (COPY-SELECTION-LITATOM 11198 . 14457) (COPY-STRUCTURE-STRING 14459 . 15593) (DELETE-LITATOM 15595 . 16207) (DETRANSLATE-CHARS 16209 . 17253) (GET-BUTTON-STRING 17255 . 17841) (GROW-SELECTION-LITATOM 17843 . 18256) (HASFAT 18258 . 18406) (INITIALIZE-ATOMIC 18408 . 19633) (INSERT-LITATOM 19635 . 20036) (INSERT-STRING 20038 . 20998) (OPEN-LITATOM 21000 . 22678) (PARSE--BROKEN-ATOM 22680 . 23059) (PARSE--LITATOM 23061 . 23719) (PARSE--STRING 23721 . 23987) (RELEASE-OPEN-STRING 23989 . 24354) (REPLACE-CHARS 24356 . 30966) ( REPLACE-STRING 30968 . 31487) (SCAN-STRING 31489 . 35443) (SELECT-SEGMENT-LITATOM 35445 . 35882) ( SET-POINT-LITATOM 35884 . 37032) (SET-POINT-STRING 37034 . 37766) (SET-SELECTION-LITATOM 37768 . 38400 ) (SET-SELECTION-STRING 38402 . 39082) (SPLIT-LITATOM 39084 . 41310) (STRINGIFY-ATOM 41312 . 41492) ( TRANSLATE-CHARS 41494 . 42814) (UNDO-ATOM-CHANGE 42816 . 43186))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-BASE b/sources/SEDIT-BASE new file mode 100644 index 00000000..87c44ff5 --- /dev/null +++ b/sources/SEDIT-BASE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "SEDIT" (USE "LISP" "XCL"))) (IL:FILECREATED " 2-Dec-92 17:28:09" IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-BASE.;7| 104133 IL:|changes| IL:|to:| (IL:FNS SETUP-WINDOW-AND-PROCESS) IL:|previous| IL:|date:| "10-Jul-91 15:05:17" IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-BASE.;6| ) ; Copyright (c) 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-BASECOMS) (IL:RPAQQ IL:SEDIT-BASECOMS ((IL:PROP IL:FILETYPE IL:SEDIT-BASE) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-BASE) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:BITMAPS GAP-BITMAP ARGS-BITMAP BODY-BITMAP) (IL:VARIABLES *CLEAR-LINEAR-ON-COMPLETION* *IGNORE-CHANGES-ON-COMPLETION* *COMPILE-FN*) (IL:FUNCTIONS COMPLETE THROW-AWAY-CHANGES SET-INITIAL-SELECTION PREV-NODE MAKE-FUNCTION-PROTOTYPE) (IL:P (IL:MOVD 'MAKE-FUNCTION-PROTOTYPE 'XCL::%MAKE-FUNCTION-PROTOTYPE)) (IL:FNS ADJUST-WIDTH ASSIGN-FORMAT-NIL ATOM-CHANGE-RELINEARIZE BUILD-INTERNAL-STRUCTURE BUILD-LINEAR-FORM BUILD-NODE BUILD-PRELINEARIZED-NODE CLOSE-NODE COLLECT-UNDO-BLOCK COMPILE-STRUCTURE COMPUTE-ALL-FORMATS COMPUTE-FORMATS-AND-FORMAT-VALUES COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION COMPUTE-SELECTION-POSITION-DEFAULT CONTAINS? COPY-NODE COPY-SELECTION COPY-SELECTION-DEFAULT CREATE-CONSTANT-STRINGS CREATE-ENVIRONMENTS CREATE-GAP-NODE CREATE-NODE CREATE-PRELINEARIZED-NODE CREATE-PRETTY-PRINT-ENV CREATE-SIMPLE-NODE CREATE-STRING-ITEM DEFAULT-COMPILE-FN DEFAULT-GETDEF-FN DEFAULT-PACKAGE DELETE-NODES DETACH-NODE FORMAT-VALUES-CHANGED GET-SELECTED-STRUCTURE HANDLE-COMPLETION INITIALIZE INSERT INSERT-CHANGED KILL-NODE LINEARIZE-ROOT NEXT-NODE NOTE-CHANGE NOTE-CHANGE-FORMAT NOTE-CHANGE-IN-SIMPLE PARSE PARSE--GAP PARSE--UNKNOWN PARSE-NEW PROPAGATE-WIDTH-CHANGE RECOMPUTE-WIDTH RELINEARIZE-WHERE-NECESSARY REPLACE-NODE REPLACE-ROOT REVIVE-NODE SEDIT1 SELECT-NEXT-GAP SET-DEPTH SET-FORMAT SETUP-CONTEXT SETUP-CONTEXT-WINDOW-DEPENDENCIES SETUP-NEW-CONTEXT SETUP-PROFILE SETUP-WINDOW-AND-PROCESS SETUP-WINDOW-CONTEXT-DEPENDENCIES SHIFT-LINEAR-FORM STRINGIFY STRINGIFY-GAP SUBNODE-CHANGED SUBNODE-CHANGED-ROOT TYPE-OF-INPUT UNDO-EVENT UNDO-REPLACE-ROOT UPDATE VERIFY-STRUCTURE WALK-UP-TREE))) (IL:PUTPROPS IL:SEDIT-BASE IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-BASE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQQ GAP-BITMAP #*(15 7)@@@@@DD@@BH@OICN@BH@@DD@@@@@) (IL:RPAQQ ARGS-BITMAP #*(42 9)@@AJFHMC@@@@@@BFCABDH@@@ONDDBBBBAOL@@@DDDALA@@@@@@DMDB@I@@@@@@CFDCHF@@@@@@@@@DD@@@@@@@@@@DD@@@@@@@@@@CH@@@@@ ) (IL:RPAQQ BODY-BITMAP #*(42 12)@@C@@@F@@@@@@@A@@@B@@@@@@@B@@@B@@@@@@@BHFADHH@@@@@CDIBMDH@@@ONDEADDEAOL@@@DEADHE@@@@@@DIBEJB@@@@@@C@LFLB@@@@@@@@@@@D@@@@@@@@@@AD@@@@@@@@@@AH@@@@ ) (DEFPARAMETER *CLEAR-LINEAR-ON-COMPLETION* NIL "Completion assumes old linear forms may be garbage.") (DEFPARAMETER *IGNORE-CHANGES-ON-COMPLETION* T "If T, markaschangedfn will ignore calls caused by completion of that edit.") (DEFPARAMETER *COMPILE-FN* 'DEFAULT-COMPILE-FN) (DEFUN COMPLETE (CONTEXT CHARCODE REASON COMPILE?) (IL:* IL:|;;;| "entry point into completing an sedit. this function is invoked by the completion commands and the closefn and shrinkfn if the sedit is not busy. REASON specifies how the user wants to complete, one of :CLOSE, :SHRINK, :ABORT, or :DONE. :ABORT means throw away changes, and :DONE means complete and leave the window open. In order for SEdit to unwind itself properly, all completion must begin in the SEdit process with the window still open, so the closefn and shrinkfn return DON'T if they're running under the mouse, and the window will be closed appropriately here. COMPILE? is T if keyboard command says to compile. ") (LET ((COMPILE-SUCCEEDED? T) (OPTIONS (IL:FETCH EDIT-OPTIONS IL:OF CONTEXT))) (CLOSE-OPEN-NODE CONTEXT) (WHEN (EQ REASON :ABORT) (UNLESS (IL:MOUSECONFIRM "Click LEFT to ABORT ALL changes." T (GET-PROMPT-WINDOW CONTEXT) ) (RETURN-FROM COMPLETE T)) (IL:* IL:|;;| "IDEALLY: if we're editing an \"expression\" (not a definition), assume editing structure in place (destructively), and so to abort we must undo all the edits.") (IL:* IL:|;;| "HOWEVER: since the file manager (editdef, getdef) edits il:fns, il:vars, etc in place, not a definition, to abort on these types we must undo.") (IL:* IL:|;;| "FOR NOW (1/13/91) just undo always. If the edit interface is changed to always edit a copy/definition for any type, then just undo if type=:expression.") (DO NIL ((NULL (IL:FETCH UNDO-LIST IL:OF CONTEXT))) (UNDO CONTEXT))) (HANDLE-COMPLETION CONTEXT REASON) (WHEN (AND (NOT (EQ REASON :ABORT)) (OR COMPILE? (MEMBER :COMPILE-ON-COMPLETION OPTIONS))) (SETQ COMPILE-SUCCEEDED? (COMPILE-STRUCTURE CONTEXT))) (COND ((NOT COMPILE-SUCCEEDED?) (IL:* IL:|;;| "if the compile failed, don't continue") ) ((OR (EQ REASON :CLOSE) (EQ REASON :ABORT) (MEMBER :CLOSE-ON-COMPLETION OPTIONS)) (IL:CLOSEW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)) (DISINTEGRATE-CONTEXT CONTEXT) (IL:DEL.PROCESS (IL:THIS.PROCESS))) ((EQ REASON :SHRINK) (IL:SHRINKW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)) (IL:DEL.PROCESS (IL:THIS.PROCESS))) ((EQ REASON :DONE) (IL:TTY.PROCESS T))) T)) (DEFUN THROW-AWAY-CHANGES (CONTEXT) (IL:REPLACE (EDIT-CONTEXT ATOM-STARTED) IL:OF CONTEXT IL:WITH NIL) (IL:REPLACE (EDIT-CONTEXT ATOM-STARTED-UNDO-POINTER) IL:OF CONTEXT IL:WITH NIL) (IL:REPLACE (EDIT-CONTEXT CHANGED-STRUCTURE?) IL:OF CONTEXT IL:WITH NIL) (IL:REPLACE (EDIT-CONTEXT UNDO-LIST) IL:OF CONTEXT IL:WITH NIL) (IL:REPLACE (EDIT-CONTEXT UNDO-UNDO-LIST) IL:OF CONTEXT IL:WITH NIL)) (DEFUN SET-INITIAL-SELECTION (CONTEXT) (IL:* IL:|;;;| "the initial selection was stored by set-props in the find-candidate field, in the form (structure . instance). Find and select the nth instance of structure, then replace the find candidate with just the structure. If there is no candidate, select the next gap.") (LET ((CANDIDATE (IL:FETCH (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT))) (WHEN (CONSP CANDIDATE) (SELECTION-DOWN CONTEXT) (COND (CANDIDATE (FIND-NTH-STRUCTURE CONTEXT NIL (CAR CANDIDATE) (CDR CANDIDATE)) (IL:REPLACE (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT IL:WITH (CAR CANDIDATE))) (T (SELECT-NEXT-GAP CONTEXT (IL:|fetch| ROOT IL:|of| CONTEXT)))) (COMPUTE-SELECTION-POSITION (IL:|fetch| SELECTION IL:|of| CONTEXT) CONTEXT) (SHOW-CARET CONTEXT) (SELECTION-UP CONTEXT)))) (DEFUN PREV-NODE (NODE &OPTIONAL INDEX) (IL:* IL:|;;;| "step to the previous node before this one (in postorder). if index is a fixp, start with the first subnode before the one with that index. if it's T, start with the first node before this node. if it's NIL, start with this node's last subnode") (DO* ((SUBNODES (IL:|fetch| SUB-NODES IL:|of| NODE) (IL:|fetch| SUB-NODES IL:|of| NODE)) (LASTINDEX (1+ (FIRST SUBNODES)) (1+ (FIRST SUBNODES))) (INDEX (OR INDEX LASTINDEX))) ((AND (INTEGERP INDEX) (> INDEX 1) (<= INDEX LASTINDEX)) (NTH (1- INDEX) SUBNODES)) (SETF INDEX (IL:|fetch| SUB-NODE-INDEX IL:|of| NODE)) (UNLESS (SETF NODE (IL:|fetch| SUPER-NODE IL:|of| NODE)) (RETURN NIL)))) (DEFUN MAKE-FUNCTION-PROTOTYPE () (DECLARE (GLOBAL ARGS-GAP BODY-GAP)) (IF (EQ (IL:EDITMODE) 'IL:SEDIT) (LIST ARGS-GAP BODY-GAP) (LIST (LIST "Arg List") "Body"))) (IL:MOVD 'MAKE-FUNCTION-PROTOTYPE 'XCL::%MAKE-FUNCTION-PROTOTYPE) (IL:DEFINEQ (adjust-width (il:lambda (node context new-width) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "we've made some change to an open node. adjust the widths and notice the changes") (let ((string-item (car (il:fetch linear-form il:of node)))) (il:replace width il:of string-item il:with new-width) (il:replace inline-width il:of node il:with new-width) (il:replace preferred-width il:of node il:with new-width) (il:replace actual-width il:of node il:with new-width) (il:replace actual-llength il:of node il:with new-width) (when context (cond ((eq (il:fetch node-type il:of node) type-litatom) (note-change node context)) (t (il:replace changed? il:of node il:with t) (note-change (il:fetch super-node il:of node) context)))))) ) (assign-format-nil (il:lambda (node context format) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "assigns NIL as the format for each of the subnodes of node. ") (il:* il:|;;;| "IMPORTANT NOTE: all nonleaf node types (except node types which have only prelinearized subnodes) must have a method which actually resets the format of each of their subnodes. if they don't care what format type they assign, they should use this method. (if the subnode format is not actually reset from the unassigned value, the format assigner and width estimator will not be run, with yukky results.)") (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (set-format subnode context nil))) ) (atom-change-relinearize (il:lambda (context) (il:* il:\; "Edited 24-Aug-87 16:22 by drc:") (il:* il:|;;;| "a simple method for relinearizing everything when we think display of atoms may have changed, like if we view the structure from a different package.") (il:* il:|;;;| "need to waste cached atom info in point and selection, as well as make sure the structure is intact.") (close-open-node context) (set-point-nowhere (il:|fetch| caret-point il:|of| context)) (set-selection-nowhere (il:|fetch| selection il:|of| context)) (il:* il:|;;;| "recompute widths for the whole tree ") (walk-up-tree (il:fetch root il:of context) context (function (lambda (node context) (if (eq (il:fetch node-type il:of node) type-litatom) (let* ((structure (il:ffetch structure il:of node)) (broken? (il:type? broken-atom structure))) (unless broken? (il:* il:\; "smash new width into real atom nodes") (let* ((string-item (car (il:ffetch linear-form il:of node))) (width (stringwidth structure (il:ffetch font il:of string-item) (not broken?)))) (il:freplace width il:of string-item il:with width) (il:freplace inline-width il:of node il:with width) (il:freplace preferred-width il:of node il:with width) (il:freplace actual-width il:of node il:with width) (il:freplace actual-llength il:of node il:with width)))) (il:* il:|;;| "just call CFV method for other node types") (funcall (il:fetch compute-format-values il:of (il:ffetch node-type il:of node)) node (il:fetch environment il:of context) context (il:ffetch format il:of node))) (il:* il:\; "mark all nodes as changed") (il:freplace changed? il:of node il:with t)))) (relinearize (il:fetch root il:of context) context)) ) (build-internal-structure (il:lambda (context) (il:* il:\; "Edited 6-Apr-88 16:25 by woz") (il:* il:|;;;| "called when setting up a new context. the structure to parse was stored in the Root field of the context by get.context. here we grab it and then setup the context for parsing.") (let ((structure (il:|fetch| root il:|of| context)) (root (il:|create| edit-node node-type il:_ type-root depth il:_ 1 sub-nodes il:_ (list 0) linear-form il:_ (cons) start-x il:_ 1 actual-width il:_ 0)) (string (il:allocstring 512 nil nil t))) (il:|replace| root il:|of| context il:|with| root) (il:|replace| caret-point il:|of| context il:|with| (il:|create| edit-point) ) (il:|replace| selection il:|of| context il:|with| (il:|create| edit-selection)) (il:|replace| current-node il:|of| context il:|with| root) (il:|replace| \\x il:|of| context il:|with| nil) (il:|replace| open-node il:|of| context il:|with| nil) (il:|replace| open-node-info il:|of| context il:|with| (il:|create| open-string buffer-string il:_ string substring il:_ (il:substring string 1 1))) (il:* il:|;;| "now we're ready to build the actual structures. build SEdit tree; propagate format types and compute space estimates; and compute actual presentation") (parse structure context) (compute-all-formats context) (build-linear-form context)))) (build-linear-form (il:lambda (context) (il:* il:\; "Edited 6-Apr-88 16:38 by woz") (il:* il:|;;| "help initialize this context by filling in the linear form. we fill in initial values for a bunch of fields and then call linearize") (let ((root (il:|fetch| root il:|of| context))) (il:|replace| current-x il:|of| context il:|with| (il:|fetch| start-x il:|of| root)) (il:|replace| current-node il:|of| context il:|with| root) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| 0) (il:|replace| linear-form il:|of| root il:|with| (cons (il:|create| line-start prev-line il:_ nil node il:_ root line-skip il:_ 2 line-ascent il:_ 0 line-descent il:_ 0 indent il:_ (il:|fetch| start-x il:|of| root) ycoord il:_ 0) (create-weak-link root))) (il:* il:\;  "create the initial, unfilled-in linear form for the root.") (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-form il:|of| root)) (il:|replace| current-line il:|of| context il:|with| (il:|fetch| linear-form il:|of| root)) (il:|replace| first-line il:|of| root il:|with| (car (il:|fetch| linear-form il:|of| root))) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|fetch| linear-form il:|of| root))) (il:* il:\; "this must be special: normally linear-pointer at a weak-link means we're done with this node and go up to the super.") (il:|replace| first-block il:|of| context il:|with| (il:|create| line-block block-new-x il:_ (il:|fetch| start-x il:|of| root) block-start il:_ (il:|fetch| linear-form il:|of| root))) (il:|replace| current-block il:|of| context il:|with| (il:|fetch| first-block il:|of| context)) (il:|replace| relinearization-time-stamp il:|of| context il:|with| 0) (il:|replace| below? il:|of| context il:|with| 'new) (linearize (subnode 1 root) context (il:idifference (il:windowprop (il:|fetch| display-window il:|of| context) 'il:width) 5)) (il:* il:\;  "fix up some of the information recorded in the root") (il:|replace| line-length il:|of| (car (il:|fetch| current-line il:|of| context)) il:|with| (il:|fetch| current-x il:|of| context)) (il:|replace| actual-llength il:|of| root il:|with| (il:idifference (  il:|fetch| current-x il:|of| context) (il:|fetch| start-x il:|of| root))) (il:|replace| actual-width il:|of| root il:|with| (il:idifference (il:|fetch| actual-width il:|of| root) (il:|fetch| start-x il:|of| root))) (il:* il:\;  "used to replace LastLineLinear of root with (fetch CurrentLine of context)") (il:|replace| last-line il:|of| root il:|with| (car (il:|fetch| current-line il:|of| context))) (il:* il:\;  "if we haven't finished updating the window, make sure the last line is dumped properly") (when (eq (il:|fetch| below? il:|of| context) 'new) (repaint-new-line (il:|fetch| current-line il:|of| context)))))) (build-node (il:lambda (structure context node-type trust-subnodes) (il:* il:\; "Edited 3-Dec-87 15:47 by DCB") (il:|replace| current-node il:|of| context il:|with| (il:|bind| (tail il:_ (il:|fetch| \\x il:|of| context)) subnodes il:|while| (il:setq subnodes (cdr tail)) il:|do| (when (eq structure (il:|fetch| structure il:|of| (car subnodes))) (cond ((eq node-type (il:|fetch| node-type il:|of| (car subnodes))) (il:* il:|;;| "we can re-use the node") (rplacd tail (cdr subnodes)) (il:|replace| sub-node-index il:|of| (il:setq subnodes (car subnodes)) il:|with| (il:add1 (car (il:setq tail (il:|fetch| sub-nodes il:|of| (il:|fetch| current-node il:|of| context)))))) (when (not trust-subnodes) (il:* il:|;;| "we were just called from parse--comment, damn it!") (il:|replace| \\x il:|of| context il:|with| (il:|fetch| sub-nodes il:|of| subnodes)) (il:|replace| sub-nodes il:|of| subnodes il:|with| (list 0))) (il:nconc1 tail subnodes) (rplaca tail (il:|fetch| sub-node-index il:|of| subnodes)) (return subnodes)) (t (il:* il:|;;| "it's changed type -- make this undoable") (let ((new-node (create-node structure (il:|fetch| current-node il:|of| context) node-type))) (undo-by replace-node new-node (car subnodes)) (il:|replace| \\x il:|of| context il:|with| nil) (return new-node))))) (il:setq tail subnodes) il:|finally| (il:|replace| \\x il:|of| context il:|with| nil) (return (create-node structure (il:|fetch| current-node il:|of| context) node-type))))) ) (build-prelinearized-node (il:lambda (structure context node-type string prin-2? font) (il:* il:\; "Edited 19-Aug-87 17:44 by drc:") (il:replace current-node il:of context il:with (il:bind (tail il:_ (il:fetch \\x il:of context)) subnodes il:while (il:setq subnodes (cdr tail)) il:do (when (eq structure (il:|fetch| structure il:|of| (car subnodes))) (cond ((eq node-type (il:fetch node-type il:of (car subnodes))) (il:* il:|;;| "we can re-use the node") (rplacd tail (cdr subnodes)) (il:replace sub-node-index il:of (il:setq subnodes (car subnodes)) il:with (il:add1 (car (il:setq tail (il:fetch sub-nodes il:of (il:fetch current-node il:of context)))))) (il:replace \\x il:of context il:with (il:fetch sub-nodes il:of subnodes)) (il:replace sub-nodes il:of subnodes il:with (list 0)) (il:nconc1 tail subnodes) (rplaca tail (il:fetch sub-node-index il:of subnodes)) (return subnodes)) (t (il:* il:|;;| "it's changed type -- make this undoable") (let ((new-node (create-prelinearized-node structure (il:fetch current-node il:of context) (il:fetch environment il:of context) node-type string prin-2? font))) (undo-by replace-node new-node (car subnodes)) (return new-node))))) (il:setq tail subnodes) il:finally (il:replace \\x il:of context il:with nil) (return (create-prelinearized-node structure (il:fetch current-node il:of context) (il:fetch environment il:of context) node-type string prin-2? font))))) ) (close-node (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (when (il:fetch open-node il:of context) (if (dead-node? (il:fetch open-node il:of context)) (il:replace open-node il:of context il:with nil) (funcall (il:fetch close-node il:of (il:fetch node-type il:of (il:fetch open-node il:of context))) context (il:fetch open-node il:of context)))) (il:replace open-node-changed? il:of context il:with nil)) ) (collect-undo-block (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (let ((block-start (il:fetch undo-list il:of context))) (cond ((null block-start) (il:* il:\; "empty undo list -- do nothing") nil) ((null (car block-start)) (il:* il:\; "empty block -- throw it out") (il:replace undo-list il:of context il:with (cdr block-start))) (t (il:for (block-end il:_ block-start) il:by (cdr block-end) il:while (cadr block-end) il:eachtime (when (null (cdr block-end)) (il:* il:\; "no matching blip -- do nothing") (return)) il:finally (cond ((eq block-start block-end) (il:* il:\; "one element block -- just remove the blip") (rplacd block-end (cddr block-end))) (t (il:replace undo-list il:of context il:with (cdr block-end)) (rplacd block-end nil) (rplaca (il:fetch undo-list il:of context) block-start)))))))) ) (COMPILE-STRUCTURE (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 18:05 by woz") (IL:* IL:|;;;| "Compile the function being edited (if any). Return T if compilation returns OK, NIL otherwise.") (LET ((NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT)) (TYPE (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)) (BODY (IL:|fetch| STRUCTURE IL:|of| (CADR (IL:|fetch| SUB-NODES IL:|of| (IL:|fetch| ROOT IL:|of| CONTEXT)))) ) (PW (OR (IL:OPENWP (GET-PROMPT-WINDOW CONTEXT)) IL:PROMPTWINDOW))) (WHEN NAME (FORMAT PW "~%Compiling ~A defn of ~A..." TYPE NAME)) (COND ((IL:ERSETQ (FUNCALL *COMPILE-FN* NAME TYPE BODY)) (FORMAT PW "~%~A compiled." NAME) T) (T (FORMAT PW "~%Compilation of ~A failed." NAME) NIL))))) (compute-all-formats (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "assigns format types to each node in the tree top-down and width estimates to each node bottom-up. Avoids touching any node more than once and does not record changes.") (il:replace dont-collect-changes? il:of context il:with t) (compute-formats-and-format-values (il:fetch root il:of context) context) (il:replace dont-collect-changes? il:of context il:with nil)) ) (compute-formats-and-format-values (il:lambda (node context) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "computes format types and horizontal space estimates for the SEdit subtree rooted at node. assigns format type from root down, so that a node's format type can be based on the format type of its parent. computes format values depth first, so that a node's space estimates can be based on those of its children.") (il:* il:|;;;| "efficiency note: if an assign format method changes the format, it will before returning cause the assign format methods of its subnodes to be run. this means that the assign format method will be run twice for some nodes.") (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context (il:fetch format il:of node)) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (compute-formats-and-format-values subnode context)) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node))) ) (compute-point-position (il:lambda (point context) (il:* il:\; "Edited 14-Jan-88 10:40 by DCB") (il:* il:|;;;| "if there's a caret point, compute its coordinates. each node type has a method for this") (il:* il:|;;| "if we get an error we throw the point away.") (when (il:type? edit-node (il:fetch point-node il:of point)) (if (dead-node? (il:fetch point-node il:of point)) (set-point-nowhere point) (let ((errval (il:nlsetq (funcall (il:fetch compute-point-position il:of (il:fetch node-type il:of (il:fetch point-node il:of point))) point context)))) (unless errval (set-point-nowhere point)))))) ) (compute-selection-position (il:lambda (selection context) (il:* il:\; "Edited 14-Jan-88 10:42 by DCB") (il:* il:|;;;| "if there's a current selection, compute its coordinates. each node has a method for this") (il:* il:|;;| "if this errs out we throw away the selection") (when (il:fetch select-node il:of selection) (cond ((dead-node? (il:fetch select-node il:of selection)) (set-selection-nowhere selection)) ((il:fetch select-start il:of selection) (let ((errval (il:nlsetq (funcall (il:fetch compute-selection-position il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context)))) (unless errval (set-selection-nowhere selection)))) (t (let ((node (il:fetch select-node il:of selection))) (il:replace select-start-x il:of selection il:with (il:fetch start-x il:of node)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of node)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of node) (il:fetch actual-llength il:of node))) (il:replace select-end-line il:of selection il:with (il:fetch last-line il:of node))))))) ) (compute-selection-position-default (il:lambda (selection context) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "a default ComputeSelectionPosition method for aggregate nodes. start and end values are assumed to be subnode indices, and the selection will extend from the beginning of the first selected subnode to the end of the last") (let ((start (subnode (il:fetch select-start il:of selection) (il:fetch select-node il:of selection))) end) (il:setq end (if (il:fetch select-end il:of selection) (subnode (il:fetch select-end il:of selection) (il:fetch select-node il:of selection)) start)) (il:replace select-start-x il:of selection il:with (il:fetch start-x il:of start)) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of start)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of end) (il:fetch actual-llength il:of end))) (il:replace select-end-line il:of selection il:with (il:fetch last-line il:of end)))) ) (contains? (il:lambda (selection-1 selection-2) (il:* il:\; "Edited 6-Jul-87 20:48 by DCB") (il:* il:|;;;| "check to see if the selection overlaps some or all of these nodes. if there's no overlap, return NIL. if it properly contains them, return T. otherwise return (QUOTE Overlap). (node1, start1, end1) and (node2, start2, end2) describe the two sequences of nodes") (let ((node-1 (il:fetch select-node il:of selection-1)) (start-1 (il:fetch select-start il:of selection-1)) (end-1 (il:fetch select-end il:of selection-1)) (node-2 (il:fetch select-node il:of selection-2)) (start-2 (il:fetch select-start il:of selection-2)) (end-2 (il:fetch select-end il:of selection-2))) (cond ((null start-1) (il:setq start-1 (il:setq end-1 (il:fetch sub-node-index il:of node-1))) (il:setq node-1 (il:fetch super-node il:of node-1))) ((null end-1) (il:setq end-1 start-1))) (cond ((null start-2) (il:setq start-2 (il:setq end-2 (il:fetch sub-node-index il:of node-2))) (il:setq node-2 (il:fetch super-node il:of node-2))) ((null end-2) (il:setq end-2 start-2))) (il:* il:|;;| "now we must get the selections at equal tree depth so we can compare bounds. First try to bring node2 up to depth of node1, then do it the other way. It doesn't matter which loop runs, the depths will end up equal.") (il:while (il:ilessp (il:fetch depth il:of node-1) (il:fetch depth il:of node-2)) il:do (il:setq start-2 (il:setq end-2 (il:fetch sub-node-index il:of node-2))) (il:setq node-2 (il:fetch super-node il:of node-2))) (il:* il:|;;| " bring node 1 up to depth of node 2, in case the first loop was wrong") (il:while (il:ilessp (il:fetch depth il:of node-2) (il:fetch depth il:of node-1)) il:do (il:setq start-1 (il:setq end-1 (il:fetch sub-node-index il:of node-1))) (il:setq node-1 (il:fetch super-node il:of node-1))) (il:* il:|;;| "and see if the selection contains the node2 sequence. ") (cond ((or (il:neq node-1 node-2) (il:ilessp end-1 start-2) (il:ilessp end-2 start-1)) (il:* il:|;;| "non-overlapping sisters") nil) (t (il:* il:|;;| "they do overlap. check if it's proper, otherwise return Unsafe") (or (and (il:ileq start-1 start-2) (il:igeq end-1 end-2)) (quote overlap)))))) ) (copy-node (il:lambda (node context) (il:* il:\; "Edited 6-Apr-88 16:42 by woz") (il:* il:|;;;| "copy the subtree rooted at node") (let ((new-node (il:|create| edit-node node-type il:_ (il:|fetch| node-type il:|of| node) structure il:_ (il:|fetch| structure il:|of| node) sub-node-index il:_ (il:|fetch| sub-node-index il:|of| node) changed? il:_ t inline-width il:_ (il:|fetch| inline-width il:|of| node) preferred-width il:_ (il:|fetch| preferred-width il:|of| node) unassigned il:_ (il:|fetch| unassigned il:|of| node)))) (il:|replace| sub-nodes il:|of| new-node il:|with| (cons (car (il:|fetch| sub-nodes il:|of| node)) (il:|for| subnode il:|in| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|collect| (il:setq subnode (copy-node subnode context)) (il:|replace| super-node il:|of| subnode il:|with| new-node) subnode))) (il:* il:|;;| "if this node type has no relinearization method, copy the linear form") (cond ((il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)) (il:|replace| linear-form il:|of| new-node il:|with| (create-weak-link new-node))) (t (il:|replace| linear-form il:|of| new-node il:|with| (il:append (il:|fetch| linear-form il:|of| node) (create-weak-link new-node))) (il:|replace| actual-width il:|of| new-node il:|with| (il:|fetch| actual-width il:|of| node)) (il:|replace| actual-llength il:|of| new-node il:|with| (il:|fetch| actual-llength il:|of| node)))) (il:* il:|;;| "the CopyStructure method will fill in the Structure field appropriately") (funcall (il:|fetch| copy-structure il:|of| (il:|fetch| node-type il:|of| node)) new-node context) new-node))) (copy-selection (il:lambda (selection context destination-context point delete?) (il:* il:\; "Edited 19-Nov-87 15:45 by DCB") (il:* il:|;;;| "apply CopySelection method for the selected node, to copy or move the current selection") (if (or (null destination-context) (il:fetch point-node il:of point)) (cond ((and destination-context delete? (il:type? edit-selection (il:fetch point-node il:of point)) (contains? (il:fetch point-node il:of point) selection)) (il:* il:|;;| "this is a move selection into an overlapping pending delete selection. can't handle this case because deleting the selection to move deletes some nodes out from under the pending delete selection, and then the selection is wrong. if we could fix up the selection in this case (hard) we would be okay.") (il:|printout| (get-prompt-window destination-context) t "Can't move a structure which overlaps the selection.")) (t (when (eq context destination-context) (start-undo-block)) (funcall (il:fetch copy-selection il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context destination-context point delete?) (when (eq context destination-context) (il:* il:|;;| "if we're moving within the same context, then we want the insert and possible delete to be grouped, so we need to close the node inserted into (so changes will get recorded). Since we're in the same context, the correct profile closing is the current profile.") (close-open-node context) (end-undo-block)))) (il:|printout| (get-prompt-window context) t "Select a place to " (if delete? "move" "copy") " to."))) ) (copy-selection-default (il:lambda (selection context destination point delete?) (il:* il:\; "Edited 6-Jul-87 20:49 by DCB") (il:* il:|;;;| "a simple copy selection method for aggregate nodes") (let ((node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) nodes) (cond (destination (il:* il:\; "copying into an SEdit") (with-profile (il:fetch profile il:of destination) (il:setq nodes (if (null start) (list node) (il:for i il:from start il:to (or end start) il:as subnode il:in (il:nth (cdr (il:fetch sub-nodes il:of node)) start) il:collect subnode))) (if (eq (il:fetch point-type il:of point) (quote string)) (il:setq nodes (il:concatlist (cdr (il:for node il:in nodes il:join (list " " (stringify node (il:fetch environment il:of context))))))) (il:setq nodes (il:for node il:in nodes il:collect (copy-node node destination)))) (when delete? (delete-nodes node context start end)) (insert point destination nodes))) ((null start) (il:* il:\; "copying one node to a foreign sink. just bksysbuf it") (il:bksysbuf (il:fetch structure il:of node) t) (when delete? (delete-nodes (il:fetch super-node il:of node) context node))) (t (il:* il:\; "copying a sequence of nodes to a foreign sink. bksysbuf each one, with spaces between them") (il:bind blank-before il:for i il:from start il:to (or end start) il:as x il:on (cdr (il:nth (il:fetch sub-nodes il:of node) start)) il:do (if blank-before (il:bksysbuf " ") (il:setq blank-before t)) (il:bksysbuf (il:fetch structure il:of (car x)) t)) (when delete? (delete-nodes node context start end)))))) ) (create-constant-strings (il:lambda (env) (il:* il:\; "Edited 23-Feb-88 11:09 by raf") (let ((font (il:fetch default-font il:of env))) (il:replace lparen-string il:of env il:with (create-string-item "(" font)) (il:replace rparen-string il:of env il:with (create-string-item ")" font)) (il:replace dot-string il:of env il:with (create-string-item "." font)) (il:replace quote-string il:of env il:with (il:for prefix il:in (quote ((quote . "'") (il:bquote . "`") (il:comma . ",") (comma-at . ",@") (comma-dot . ",.") (function . "#'"))) il:join (list (car prefix) (create-string-item (cdr prefix) font)))) (il:replace comment-string il:of env il:with (il:for prefix il:in (quote ((1 . "; ") (2 . ";; ") (3 . ";;; ") (4 . ";;;; ") (5 . "#|") (6 . "|#"))) il:join (list (car prefix) (create-string-item (cdr prefix) (il:fetch keyword-font il:of env))))))) ) (CREATE-ENVIRONMENTS (IL:LAMBDA NIL (IL:* IL:\; "Edited 10-Jul-91 15:02 by jds") (IL:* IL:|;;;| "remake lisp environment based on fonts, command table spec... now this guy only makes the lisp edit environment. the pretty print environment is created when it is needed, because otherwise it makes lots of IP fonts that the user doesn't need/have. pretty.print calls create.pretty.print.env to create it when necessary.") (LET ((COMMANDS (CREATE-COMMAND-TABLE COMMAND-TABLE-SPEC))) (IL:SETQ LISP-EDIT-ENVIRONMENT (IL:CREATE EDIT-ENV PARSE-INFO IL:_ (LIST 'IL:LITATOM 'PARSE--LITATOM 'IL:SMALLP 'PARSE--LITATOM 'IL:STRINGP 'PARSE--STRING 'IL:LISTP 'PARSE--LIST 'IL:FIXP 'PARSE--LITATOM 'BIGNUM 'PARSE--LITATOM 'IL:FLOATP 'PARSE--LITATOM 'RATIO 'PARSE--LITATOM 'IL:CHARACTER 'PARSE--LITATOM 'GAP 'PARSE--GAP 'BROKEN-ATOM 'PARSE--BROKEN-ATOM 'IL:NEW-ATOM 'PARSE--LITATOM) PARSE-INFO-UNKNOWN IL:_ 'PARSE--UNKNOWN DEFAULT-FONT IL:_ (IL:FONTCREATE IL:DEFAULTFONT) ITALIC-FONT IL:_ (IL:FONTCREATE IL:ITALICFONT) KEYWORD-FONT IL:_ (IL:FONTCREATE IL:CLISPFONT) COMMENT-FONT IL:_ (IL:FONTCREATE IL:COMMENTFONT) BROKEN-ATOM-FONT IL:_ (IL:FONTCREATE IL:ITALICFONT) SPACE-WIDTH IL:_ (IL:CHARWIDTH (IL:CHARCODE IL:SPACE) (IL:FONTCREATE IL:DEFAULTFONT) ) DEFAULT-LINE-SKIP IL:_ 2 COMMAND-TABLE IL:_ (CAR COMMANDS) HELP-MENU IL:_ (CADR COMMANDS) DEFAULT-CHAR-HANDLER IL:_ (IL:FUNCTION INPUT-NORMAL-CHAR) EM-WIDTH IL:_ (IL:CHARWIDTH (IL:CHARCODE "M") (IL:FONTCREATE IL:DEFAULTFONT)) INDENT-BASE IL:_ (IL:CHARWIDTH (IL:CHARCODE "M") (IL:FONTCREATE IL:DEFAULTFONT) ) INDENT-STEP IL:_ (IL:ITIMES 2 (IL:CHARWIDTH (IL:CHARCODE "M") (IL:FONTCREATE IL:DEFAULTFONT)) ) MAX-WIDTH IL:_ 500 COMMENT-WIDTH-PERCENT IL:_ 40 INIT-COMMENT-SEPARATION IL:_ 15)) (CREATE-CONSTANT-STRINGS LISP-EDIT-ENVIRONMENT)))) (create-gap-node (il:lambda (gap) (il:* il:\; "Edited 6-Apr-88 16:43 by woz") (let* ((width (linear-item-width (il:|fetch| linear-item il:|of| gap))) (gap-node (il:|create| edit-node node-type il:_ type-gap structure il:_ gap sub-nodes il:_ (list 0) inline-width il:_ width preferred-width il:_ width actual-llength il:_ width actual-width il:_ width))) (il:|replace| linear-form il:|of| gap-node il:|with| (cons (il:|fetch| linear-item il:|of| gap) (create-weak-link gap-node))) gap-node))) (create-node (il:lambda (structure super-node nodetype) (il:* il:\; "Edited 6-Apr-88 16:44 by woz") (il:* il:|;;;| "construct a new node and fit it into the tree") (let ((new-node (il:|create| edit-node node-type il:_ nodetype super-node il:_ super-node structure il:_ structure sub-nodes il:_ (list 0)))) (cond (super-node (il:|replace| depth il:|of| new-node il:|with| (il:add1 (il:|fetch| depth il:|of| super-node))) (il:|replace| sub-node-index il:|of| new-node il:|with| (il:add1 (car (il:|fetch| sub-nodes il:|of| super-node))) ) (il:nconc1 (il:|fetch| sub-nodes il:|of| super-node) new-node) (rplaca (il:|fetch| sub-nodes il:|of| super-node) (il:|fetch| sub-node-index il:|of| new-node))) (t (il:|replace| depth il:|of| new-node il:|with| 0))) (il:|replace| linear-form il:|of| new-node il:|with| (create-weak-link new-node) ) new-node))) (create-prelinearized-node (il:lambda (structure super-node environment nodetype string prin-2? font) (il:* il:\; "Edited 17-Nov-87 11:17 by DCB") (il:* il:|;;;| "construct a new node and fit it into the tree. this node has a fixed linear form, given by string, prin2? and font, so use create.simple.node to construct it") (let ((new-node (create-simple-node structure environment nodetype string prin-2? font))) (cond ((il:replace super-node il:of new-node il:with super-node) (il:replace depth il:of new-node il:with (il:add1 (il:fetch depth il:of super-node))) (il:replace sub-node-index il:of new-node il:with (il:add1 (car (il:fetch sub-nodes il:of super-node)))) (rplaca (il:fetch sub-nodes il:of super-node) (il:fetch sub-node-index il:of new-node)) (il:nconc1 (il:fetch sub-nodes il:of super-node) new-node)) (t (il:replace depth il:of new-node il:with 0))) new-node)) ) (create-pretty-print-env (il:lambda nil (il:* il:\; "Edited 6-Jul-87 20:49 by DCB") (il:setq pretty-print-env (il:create edit-env il:using lisp-edit-environment default-font il:_ (il:fontcreate il:defaultfont nil nil nil (quote il:interpress)) italic-font il:_ (il:fontcreate il:italicfont nil nil nil (quote il:interpress)) keyword-font il:_ (il:fontcreate il:clispfont nil nil nil (quote il:interpress)) comment-font il:_ (il:fontcreate il:commentfont nil nil nil (quote il:interpress)) broken-atom-font il:_ (il:fontcreate il:italicfont nil nil nil (quote il:interpress)) space-width il:_ (il:charwidth (il:charcode il:space) (il:fontcreate il:defaultfont nil nil nil (quote il:interpress))) default-line-skip il:_ 0 indent-base il:_ (il:fixr (il:times il:micasperpt (il:fetch indent-base il:of lisp-edit-environment))) indent-step il:_ (il:fixr (il:times il:micasperpt (il:fetch indent-step il:of lisp-edit-environment))) em-width il:_ (il:fixr (il:times il:micasperpt (il:fetch em-width il:of lisp-edit-environment))) max-width il:_ (il:fixr (il:times il:micasperpt (il:fetch max-width il:of lisp-edit-environment))))) (create-constant-strings pretty-print-env)) ) (create-simple-node (il:lambda (structure environment nodetype string prin-2? font) (il:* il:\; "Edited 6-Apr-88 16:44 by woz") (il:* il:|;;;| "construct a node with fixed linear form, given by string, prin2? and font.") (let ((width (stringwidth string font prin-2?)) new-node) (il:setq new-node (il:|create| edit-node node-type il:_ nodetype structure il:_ structure sub-nodes il:_ (list 0) inline-width il:_ width preferred-width il:_ width actual-width il:_ width actual-llength il:_ width)) (il:|replace| linear-form il:|of| new-node il:|with| (cons (il:|create| string-item string il:_ string width il:_ width font il:_ font prin-2? il:_ prin-2?) (create-weak-link new-node))) new-node))) (create-string-item (il:lambda (string font) (il:* il:\; "Edited 6-Jul-87 20:49 by DCB") (il:create string-item string il:_ string width il:_ (stringwidth string font) font il:_ font prin-2? il:_ nil)) ) (default-compile-fn (il:lambda (name type body) (il:* il:\; "Edited 31-Aug-87 11:59 by drc:") (case type ((il:fns) (compile name body)) (t (compile-form body)))) ) (default-getdef-fn (il:lambda (name type old-def) (il:* il:\; "Edited 26-Aug-87 10:09 by drc:") (let ((new-def (il:getdef name type nil (quote (il:noerror))))) (or new-def (progn (cerror "Use the definition currently being edited." "No ~S definition for ~S" type name) old-def)))) ) (default-package (il:lambda (name type structure) (il:* il:\; "Edited 25-Aug-87 17:29 by drc:") (il:* il:|;;;| "called by SETUP-PROFILE to determine what package to use for the edit") (il:* il:|;;;| "We only look at name for now.") (if (and name (symbolp name) (not (keywordp name))) (symbol-package name) *package*)) ) (delete-nodes (il:lambda (node context start end set-point? string) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;| "delete a node or sequence of nodes. if SET-POINT?, change the caret point to be in the gap. the deletion is handled by the super of the nodes to be deleted.") (if start (funcall (il:fetch delete il:of (il:fetch node-type il:of node)) node context start end set-point? string) (funcall (il:fetch delete il:of (il:fetch node-type il:of (il:fetch super-node il:of node))) (il:fetch super-node il:of node) context node nil set-point?))) ) (detach-node (il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;;| "sever any connection between node and its old supernode, before it's inserted somewhere else") (il:replace linear-thread il:of node il:with nil)) ) (format-values-changed (il:lambda (node context) (il:* il:\; "Edited 6-Jul-87 20:49 by DCB") (il:* il:|;;;| "recompute this nodes's width estimates, and check if any have changed") (il:* il:|;;;| "if it's a litatom, we've been updating its width as we go along, so we can safely assume that it's changed. we won't call cfv.litatom if the node's still open and has been changed.") (cond ((eq (il:fetch node-type il:of node) type-litatom) (when (not (and (eq node (il:fetch open-node il:of context)) (il:fetch open-node-changed? il:of context))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node))) t) (t (let ((old-inline-width (il:fetch inline-width il:of node)) (old-preferred-width (il:fetch preferred-width il:of node))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context (il:fetch format il:of node)) (or (il:neq old-inline-width (il:fetch inline-width il:of node)) (il:neq old-preferred-width (il:fetch preferred-width il:of node))))))) ) (get-selected-structure (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:49 by DCB") (il:* il:|;;;| "this is the guy who figures out what is selected for operations like eval and open. for now we only want to deal with single selection, not extended ones. Return NIL if it is an extended selection, or if there is no node selected.") (close-open-node context) (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection))) (and node (not (il:fetch select-start il:of selection)) (il:fetch structure il:of node)))) ) (HANDLE-COMPLETION (IL:LAMBDA (CONTEXT REASON) (IL:* IL:\; "Edited 25-Jan-91 13:52 by woz") (IL:* IL:|;;;| "call the completion function. it is either a function or a list of the form ( *). The REASON arg will be :ABORT if the edit completes with an abort command, otherwise it is meaningless. The function is applied to CONTEXT, STRUCTURE, REASON, , where STRUCTURE is the edited structure and REASON is NIL if no changes were made, T if changes were made, and :ABORT is user wants to abort changes. ") (IL:* IL:|;;;| "IDEALLY: The completion fn is called in the abort case with the structure including the changes, so that the edit interface could potentially implement \"undo abort\". But FOR NOW (1/13/91) this doesn't happen (see COMPLETE) because the changes have been undone by the time we get here.") (UNLESS (EQ REASON :ABORT) (SETQ REASON (IL:|fetch| CHANGED-STRUCTURE? IL:|of| CONTEXT))) (THROW-AWAY-CHANGES CONTEXT) (IL:* IL:\; "do this before completion-fn runs, so if markaschanged gets called, it won't think they're still changes on this edit.") (LET ((FN (IL:|fetch| COMPLETION-FN IL:|of| CONTEXT)) EXTRA-ARGS) (WHEN FN (WHEN (AND (LISTP FN) (NOT (MEMBER (FIRST FN) '(LAMBDA IL:LAMBDA)))) (IL:* IL:|;;| "catch the #' case by checking for lambda as the car. This is terrible, but cl:functionp returns T for any list, which is wrong, so can't use it now.") (SETQ EXTRA-ARGS (REST FN)) (SETQ FN (FIRST FN))) (APPLY FN (LIST* CONTEXT (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 1 (IL:|fetch| ROOT IL:|of| CONTEXT))) REASON EXTRA-ARGS)))))) (initialize (il:lambda nil (il:* il:\; "Edited 16-Jul-87 15:26 by DCB") (il:pushnew il:markaschangedfns (il:function markaschangedfn)) (il:changename (quote il:editferror) (quote il:copy) (quote new-function-body)) (il:* il:\; "set up SEdit's global variables: the standard environments, node types, and terminal table") (create-environments) (il:setq types (list (il:setq type-root (il:create edit-node-type name il:_ (quote root) assign-format il:_ (quote assign-format-nil) compute-format-values il:_ (quote il:nill) linearize il:_ (quote linearize-root) sub-node-changed il:_ (quote subnode-changed-root) compute-point-position il:_ (quote il:shouldnt) compute-selection-position il:_ (quote compute-selection-position-default) set-point il:_ (quote set-point-nowhere) set-selection il:_ (quote set-selection-nowhere) grow-selection il:_ (quote il:shouldnt) select-segment il:_ (quote select-segment-default) insert il:_ (quote replace-root) delete il:_ (quote il:nill) copy-structure il:_ (quote il:shouldnt) copy-selection il:_ (quote copy-selection-default) back-space il:_ (quote il:shouldnt))) (il:setq type-unknown (il:create edit-node-type name il:_ (quote unknown) assign-format il:_ (quote assign-format-nil) compute-format-values il:_ (quote il:nill) linearize il:_ nil sub-node-changed il:_ (quote il:shouldnt) compute-point-position il:_ (quote il:shouldnt) compute-selection-position il:_ (quote il:shouldnt) set-point il:_ (quote set-point-unknown) set-selection il:_ (quote set-selection-me) grow-selection il:_ (quote grow-selection-default) select-segment il:_ (quote il:shouldnt) insert il:_ (quote il:shouldnt) delete il:_ (quote il:shouldnt) copy-structure il:_ (quote il:nill) copy-selection il:_ (quote copy-selection-default) stringify il:_ (quote stringify-atom) back-space il:_ (quote backspace-unknown))) (il:setq type-gap (il:create edit-node-type il:using type-unknown name il:_ (quote gap) stringify il:_ (quote stringify-gap) back-space il:_ (quote backspace-gap))))) (il:* il:\; "these must be called after types has been created") (initialize-atomic) (initialize-lists) (initialize-comments) (il:setq terminal-table (il:copytermtable)) (il:for class il:in (quote (il:chardelete il:linedelete il:worddelete il:retype il:ctrlv il:eol)) il:do (il:for c il:in (il:getsyntax class terminal-table) il:do (il:setsyntax c (quote il:none) terminal-table))) (il:echomode nil terminal-table) (il:control t terminal-table) (il:setq basic-gap (il:create gap linear-item il:_ (cons 0 gap-bitmap))) (il:setq args-gap (il:create gap linear-item il:_ (cons 3 args-bitmap))) (il:setq body-gap (il:create gap linear-item il:_ (cons 3 body-bitmap))) (il:* il:|;;| "initialize the selection state variables that used to be in the WINDOW file") (il:setq pending-selection (il:create edit-selection)) (il:setq initial-selection (il:create edit-selection)) (il:setq scratch-selection (il:create edit-selection)) (il:setq pending-caret (il:create edit-point)) (il:setq selection-pending? nil) (il:* il:|;;| "initialize the cache point and selection for replace.node") (il:setq temp-point (il:create edit-point)) (il:setq temp-selection (il:create edit-selection)) t) ) (insert (il:lambda (point context subnodes) (il:* il:\; "Edited 13-Jan-88 14:46 by DCB") (il:* il:|;;;| "insert handles a lot of different cases, translating where necessary to those handled by the method. point is a normal point or points to a pending-delete selection. subnodes is a character or string of characters to be inserted, or a list of subnodes, or NIL (split). we massage the material to be inserted according to the type of point. methods called to insert a list of subnodes return the list starting with the last subnode inserted, and we automatically fix up the point and handle the uninserted nodes (if any).") (let ((node (il:fetch point-node il:of point)) (selection (il:fetch selection il:of context)) chars where pending-delete?) (when (eq (il:fetch point-type il:of point) (quote structure)) (close-open-node context)) (cond ((il:type? edit-node node) (il:setq where point)) (t (il:* il:|;;| "the pending-delete case. the PointNode actually points to a selection framing the material to be replaced") (il:setq pending-delete? t) (il:setq node (il:fetch select-node il:of selection)) (cond ((il:fetch select-start il:of selection) (il:setq where selection)) (t (il:setq where node) (il:setq node (il:fetch super-node il:of node)))))) (when node (when (il:type? edit-node subnodes) (il:* il:|;;| "coerce a single node to a list containing that node") (il:setq subnodes (list subnodes))) (il:* il:|;;| "make sure these nodes have been properly disconnected from whence they came") (when (il:listp subnodes) (il:for subnode il:in subnodes il:do (detach-node subnode))) (cond ((eq (il:fetch point-type il:of point) (quote structure)) (il:* il:|;;| "inserting/replacing at a structure point. inserting NIL does nothing, replacing with it deletes. if subnodes is a string, the appropriate atom is constructed. use the value returned by the method to set the point and try again with any leftovers") (cond ((null subnodes) (when pending-delete? (delete-nodes node context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) point))) ((il:nlistp subnodes) (il:* il:|;;| "insert the atom NIL, and then replace its characters with the character typed") (let ((new-node (create-simple-node nil (il:fetch environment il:of context) type-litatom nil t (il:fetch default-font il:of (il:fetch environment il:of context))))) (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where (list new-node) point) (il:* il:|;;| "this is a little nasty -- we don't want to bother figuring out the printname of the node, so we tell replace.char it was \"\". but before we do that, we've got to make the inlinewidth agree so that when replace.chars adjusts it it comes out right") (il:replace inline-width il:of new-node il:with 0) (replace-string new-node context 1 0 (or (il:stringp subnodes) (translate-chars (il:mkstring subnodes) (quote atom) (eq *print-case* (quote :upcase)))) point "" (quote atom)))) (t (il:* il:|;;| "keep trying to insert these nodes and placing the point after them until we run out of nodes or run out of places to put them") (il:do (il:setq subnodes (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where subnodes point)) il:repeatwhile (and (setq node (il:fetch point-node il:of (setq where point))) subnodes))))) (t (il:* il:|;;| "inserting/replacing at an atom or string point. if it's characters, insert them; otherwise split, and if there were any subnodes insert them") (funcall (il:fetch insert il:of (il:fetch node-type il:of node)) node context where (and (il:nlistp subnodes) subnodes) point) (when (and (il:listp subnodes) (il:fetch point-node il:of point)) (insert point context subnodes)))) (il:* il:|;;| "the copy selection methods rely on there being no selection after an insert. the copy selection methods can't take care of this because sometimes the selection gets set (eg from moving out of a quote.") (set-selection-nowhere selection)))) ) (insert-changed (il:lambda (node list) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "inserts node into list (but not before the first element) such that list is kept in decreasing order of depth") (il:bind next (depth il:_ (il:fetch depth il:of node)) il:while (and (il:setq next (cdr list)) (il:igreaterp (il:fetch depth il:of (car next)) depth)) il:do (il:setq list next) il:finally (rplacd list (cons node next)))) ) (kill-node (il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:18 by DCB") (il:* il:|;;;| "the subtree rooted at this node is being deleted. mark all the nodes as dead, and cut the first line/last line pointers to avoid confusion.") (il:replace depth il:of node il:with 0) (il:replace first-line il:of node il:with nil) (il:* il:|;;| "used to replace LastLineLinear of node with NIL") (il:replace last-line il:of node il:with nil) (il:replace start-x il:of node il:with 0) (il:replace linear-thread il:of node il:with nil) (il:for x il:in (cdr (il:fetch sub-nodes il:of node)) il:do (kill-node x))) ) (linearize-root (il:lambda (node context index) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (if index (il:shouldnt "can't be within the root node") (linearize (subnode 1 node) context))) ) (next-node (il:lambda (node index postorder?) (il:* il:\; "Edited 11-Dec-87 11:38 by DCB") (il:* il:|;;;| "step to the next node after this one (in preorder unless postorder? given). if index is a fixp, start with the next subnode after the one with that index. if it's T, start with the first node after this node. if it's NIL, start with this node's first subnode") (or (and (null index) (subnode 1 node)) (il:first (or index (il:setq index 0)) il:do (when (and (il:fixp index) (il:ilessp index (car (il:fetch sub-nodes il:of node)))) (return (subnode (il:add1 index) node))) (when (and postorder?)) (il:setq index (il:fetch sub-node-index il:of node)) (il:setq node (il:fetch super-node il:of node)) il:repeatwhile node))) ) (note-change (il:lambda (node context) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "this routine should be called whenever we make a structural change to node. clobber any clisp translation, and insert it into the ChangedNodes list. the ChangedNodes list is kept sorted by increasing depth. this is because the ChangedNodes list will next be used to recompute format types, which must be propagated top-down. ") (when (not (il:fetch changed? il:of node)) (il:for (super il:_ node) il:by (il:fetch super-node il:of super) il:while super il:when (il:listp (il:fetch structure il:of super)) il:do (zap-clisp-translation (il:fetch structure il:of super))) (il:replace changed? il:of node il:with t) (when (not (il:fetch dont-collect-changes? il:of context)) (insert-changed node (il:fetch changed-nodes il:of context))) (il:replace changed-structure? il:of context il:with t))) ) (note-change-format (il:lambda (node context) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "this routine should be called whenever we make a node's format changes. inserts the node should be inserted in the ChangedNodes list. this list will include nodes whose structure has changed and nodes whose format type has changed. it is kept sorted by decreasing depth. this is because the ChangedFormatNodes list will next be used to recompute width estimates, which must be propagated bottom-up. ") (il:* il:|;;;| "note that the ChangedNodes list should initially contain the reverse of the old ChangedNodes list (as left behind after noting all structure changes).") (when (not (il:fetch changed? il:of node)) (il:replace changed? il:of node il:with t) (when (not (il:fetch dont-collect-changes? il:of context)) (insert-changed node (il:fetch changed-nodes il:of context))))) ) (note-change-in-simple (il:lambda (node context offset width start end) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "we've changed a prelinearized node. fix up the linear form and width estimates, and notify its super") (let ((temp (car (il:fetch linear-form il:of node))) new-width) (il:replace string il:of temp il:with (il:fetch structure il:of node)) (il:* il:\; "read table specific") (il:setq new-width (stringwidth (il:fetch string il:of temp) (il:fetch font il:of temp) (il:fetch prin-2? il:of temp))) (il:replace width il:of temp il:with new-width) (il:replace inline-width il:of node il:with new-width) (il:replace preferred-width il:of node il:with new-width) (il:replace actual-width il:of node il:with new-width) (il:replace actual-llength il:of node il:with new-width) (il:replace changed? il:of node il:with t) (note-change (il:fetch super-node il:of node) context))) ) (parse (il:lambda (structure context parser data) (il:* il:\; "Edited 22-Jun-90 10:37 by narusawa") (il:* il:|;;;| "construct the SEdit tree for this structure. ") (il:* il:|;;;| "if a node needs to be parsed as a particular kind of structure (for example, the second child of a lambda-list must be parsed as a list, even if it is NIL), you can specify a particular parsing function.") (il:* il:|;;;| "parse used to compute the width estimates, but it can no longer do that because the new assign format pass must intervene between parsing and computing width estimates, and the assign format pass, since it is top down, and you can't run it until the lower nodes have been created, cannot conveniently be intermingled with the parsing pass.") (let ((super-node (il:|fetch| current-node il:|of| context)) (environment (il:|fetch| environment il:|of| context)) (reuse-nodes (il:|fetch| \\x il:|of| context)) this-node) (funcall (or parser (il:listget (il:|fetch| parse-info il:|of| environment) (il:typename structure)) (il:fetch parse-info-unknown il:of environment)) structure context data) (il:setq this-node (il:|fetch| current-node il:|of| context)) (when (cdr (il:|fetch| \\x il:|of| context)) (il:* il:|;;| "some of the old nodes weren't reused (ie deleted). so mark this node changed, and kill the old ones.") (il:|replace| changed? il:|of| this-node il:|with| t) (kill-node (cadr (il:|fetch| \\x il:|of| context)))) (when (or (il:|fetch| changed? il:|of| this-node) (and (eq (il:|fetch| start-x il:|of| this-node) 0) reuse-nodes)) (il:* il:|;;| "or first case: this node was reused and it changed") (il:* il:|;;| "or second case: this node is new but our super node is being reused") (il:* il:|;;| " in either case the super-node has changed") (il:|replace| changed? il:|of| super-node il:|with| t)) (il:|replace| \\x il:|of| context il:|with| reuse-nodes) (if super-node (il:|replace| current-node il:|of| context il:|with| super-node) (il:fetch current-node il:of context))))) (parse--gap (il:lambda (structure context) (il:* il:\; "Edited 6-Apr-88 16:45 by woz") (il:* il:|;;;| "parse a gap structure (presumably left there by a previous editing session)") (build-node structure context type-gap) (let ((new-node (il:|fetch| current-node il:|of| context)) (width (linear-item-width (il:|fetch| linear-item il:|of| structure)))) (il:|replace| linear-form il:|of| new-node il:|with| (cons (il:|fetch| linear-item il:|of| structure) (create-weak-link new-node))) (il:|replace| inline-width il:|of| new-node il:|with| width) (il:|replace| preferred-width il:|of| new-node il:|with| width) (il:|replace| actual-width il:|of| new-node il:|with| width) (il:|replace| actual-llength il:|of| new-node il:|with| width)))) (parse--unknown (il:lambda (structure context) (il:* il:\; "Edited 23-Jun-88 12:42 by Snow") (il:* il:|;;| "this is the default parser for structures of an unknown type. they display in italics, and can't be edited") (build-prelinearized-node structure context type-unknown structure t (il:|fetch| comment-font il:|of| (il:|fetch| environment il:|of| context)) ))) (parse-new (il:lambda (expression context) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:replace current-node il:of context il:with nil) (il:replace \\x il:of context il:with nil) (parse expression context)) ) (propagate-width-change (il:lambda (context node old-width) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "the width of node has been recomputed. this may change the width of some of its super nodes, and possibly even the extent recorded with the window") (let ((width (il:fetch actual-width il:of node)) (super (il:fetch super-node il:of node)) super-width new-width) (cond ((eq width old-width) nil) ((null super) (il:replace il:width il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)) il:with width)) ((il:fetch super-node il:of super) (il:setq super-width (il:fetch actual-width il:of super)) (il:setq new-width (il:iplus width (il:idifference (il:fetch start-x il:of node) (il:fetch start-x il:of super)))) (cond ((il:igeq new-width super-width) (il:replace actual-width il:of super il:with new-width) (propagate-width-change context super super-width)) ((eq super-width (il:iplus old-width (il:idifference (il:fetch start-x il:of node) (il:fetch start-x il:of super)))) (recompute-width super) (propagate-width-change context super super-width)))) (t (il:replace actual-width il:of super il:with width) (il:replace il:width il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)) il:with width))))) ) (recompute-width (il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "determine the width of this node. we keep it fast by being tricky and skipping over subnodes which span several lines (we assume their widths are correct) so it isn't pretty") (prog ((line (il:fetch first-line il:of node)) (last-line (il:fetch last-line il:of node)) (startx (il:fetch start-x il:of node)) width) (when (eq line last-line) (il:shouldnt "trying to recompute width of an inline node")) (il:setq width (il:iplus startx (il:fetch actual-llength il:of node))) next-line (il:setq width (il:imax width (il:fetch line-length il:of line))) (when (eq (il:setq line (car (il:fetch next-line il:of line))) last-line) (go done)) (when (eq (il:fetch node il:of line) node) (go next-line)) (il:setq line (il:fetch node il:of line)) (il:setq width (il:imax width (il:iplus (il:fetch start-x il:of line) (il:fetch actual-width il:of line)))) (when (il:neq (il:setq line (il:fetch last-line il:of line)) last-line) (go next-line)) done (il:replace actual-width il:of node il:with (il:idifference width startx)))) ) (relinearize-where-necessary (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "we've made some changes to the structure; now it's time to fix up the linear forms and the window. first we recompute the format types top down for all appropriate nodes. then we recompute the width estimates for all appropriate nodes bottom up. given this, we find a minimal set of nodes to relinearize (such that each changed node is a subnode of one of these nodes, and the structure and format type and width estimates for these nodes have not changed)") (il:* il:|;;;| "mdd 4/24/87: as an experiment, i modified this function to always simply relinearize from the top of the tree (by imbedding (format.values.changed ...) in (OR (format.values.changed ...) T)). this has the potential for considerably simplifying some of the linearizer. unfortunately, it caused very noticeable performance degradation while editing large structures. oh well.") (let ((changed-nodes (cdr (il:fetch changed-nodes il:of context))) nodes-to-relinearize) (cond ((null changed-nodes) nil) ((and (eq (il:fetch depth il:of (car changed-nodes)) 1) (null (cdr changed-nodes))) (il:* il:|;;| "special case for editing a tree of just one node") (relinearize (car changed-nodes) context) (il:replace changed? il:of (car changed-nodes) il:with nil)) (t (il:* il:|;;| "collect nodes whose structure has changed or whose format type has changed") (il:for node il:in (il:reverse changed-nodes) il:bind super-node il:when (not (dead-node? node)) il:do (il:* il:|;;| "call format method on node and its super (super first). mark the super as changed so that it will be relinearized.") (il:setq super-node (il:fetch super-node il:of node)) (when (and super-node (not (dead-node? super-node)) (not (il:fetch changed? il:of super-node)) (il:fetch super-node il:of super-node)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of super-node)) super-node context (il:fetch format il:of super-node)) (note-change-format super-node context)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context (il:fetch format il:of node))) (il:* il:|;;| "collect nodes whose structure has changed or whose format type has changed or whose width formats have changed: in short, all the nodes which might need relinearizing.") (il:setq changed-nodes (cdr (il:fetch changed-nodes il:of context))) (il:while changed-nodes il:bind node super-node il:do (il:setq node (car changed-nodes)) (when (not (dead-node? node)) (cond ((and (il:setq super-node (il:fetch super-node il:of node)) (format-values-changed node context) (il:fetch super-node il:of super-node)) (il:* il:|;;| "climb up the super node links until the width estimates stop changing") (when (not (il:fetch changed? il:of super-node)) (il:replace changed? il:of super-node il:with t) (insert-changed super-node changed-nodes))) (t (il:push nodes-to-relinearize node)))) (il:setq changed-nodes (cdr changed-nodes))) (il:for node il:in il:old (il:setq nodes-to-relinearize (il:dreverse nodes-to-relinearize)) il:do (if (and (cdr nodes-to-relinearize) (il:for (super-node il:_ node) il:while (il:setq super-node (il:fetch super-node il:of super-node)) il:thereis (il:fetch changed? il:of super-node))) (il:for (super-node il:_ node) il:until (il:fetch changed? il:of (il:setq super-node (il:fetch super-node il:of super-node))) il:do (il:replace changed? il:of super-node il:with t)) (relinearize node context))))) (rplacd (il:fetch changed-nodes il:of context) nil))) ) (replace-node (il:lambda (context node new-node) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:* il:|;;;| "replace node with new.node, without changing current selection or point") (let* ((point (il:fetch caret-point il:of context)) (selection (il:fetch selection il:of context)) (select-node (il:fetch select-node il:of selection))) (smash-using edit-point temp-point point) (smash-using edit-selection temp-selection selection) (set-selection-me selection context node) (pending-delete point selection) (insert point context new-node) (smash-using edit-point point temp-point) (cond ((and select-node (dead-node? select-node)) (il:replace select-node il:of selection il:with new-node) (il:replace select-start il:of selection il:with nil) (il:replace select-end il:of selection il:with nil) (il:replace select-type il:of selection il:with (quote structure)) (il:replace pending-delete? il:of selection il:with nil)) (t (smash-using edit-selection selection temp-selection))))) ) (replace-root (il:lambda (root context where subnodes point) (il:* il:\; "Edited 11-Apr-88 17:02 by woz") (il:* il:|;;;| "Insert method for the root. If we're passed a single node to insert, replace the root with it. If we're passed several nodes, then replace the root with an empty list, set the point in that list, and return the subnodes in toto so that insert will then insert them into the new (empty) root list.") (when (and (null point) (rest subnodes)) (il:shouldnt "Replacing root with list but no point specified!")) (undo-by undo-replace-root root (subnode 1 root)) (let ((top-node (if (rest subnodes) (create-null-list context) (car subnodes)))) (kill-node (subnode 1 root)) (rplaca (cdr (il:|fetch| sub-nodes il:|of| root)) top-node) (rplaca (cdr (il:|fetch| linear-form il:|of| root)) (create-weak-link top-node)) (when (il:|fetch| inline? il:|of| top-node) (il:* il:|;;| "used to be (IL:REPLACE LAST-LINE-LINEAR IL:OF SUBNODE IL:WITH (IL:FETCH LINEAR-FORM IL:OF NODE))") (il:|replace| last-line il:|of| top-node il:|with| (car (il:|fetch| linear-form il:|of| root)))) (il:|replace| first-line il:|of| top-node il:|with| (car (il:|fetch| linear-form il:|of| root))) (il:|replace| linear-thread il:|of| top-node il:|with| (cdr (il:|fetch| linear-form il:|of| root))) (il:|replace| super-node il:|of| top-node il:|with| root) (il:|replace| sub-node-index il:|of| top-node il:|with| 1) (set-depth top-node (il:add1 (il:|fetch| depth il:|of| root))) (note-change root context) (subnode-changed-root root top-node context) (cond ((rest subnodes) (il:* il:|;;| "set the point ourself since set-point-list will blow out assuming that the list already has a linear form.") (il:|replace| point-node il:|of| point il:|with| top-node) (il:|replace| point-index il:|of| point il:|with| 0) (il:|replace| point-type il:|of| point il:|with| (quote structure)) subnodes) (point (set-point-nowhere point) nil)))) ) (revive-node (il:lambda (node depth) (il:* il:\; "Edited 6-Jul-87 20:50 by DCB") (il:replace depth il:of node il:with (il:setq depth (il:iplus 1 depth))) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (revive-node subnode depth))) ) (SEDIT1 (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 18:56 by woz") (IL:* IL:|;;;| "this is the function that runs in the sedit process. first finish the initialization that wasn't done in the calling process, then start the main loop. The read-print profile is rebound specially here, so global changes won't affect existing SEdits. ") (WHEN (IL:NEQ (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) 'DEAD) (IL:* IL:|;;| "this SEdit is okay, or new") (WITH-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT) (SETUP-CONTEXT CONTEXT) (SETUP-WINDOW-AND-PROCESS CONTEXT) (IL:* IL:|;;|  "SEDIT (in start-process) is waiting for the initialization to complete before returning") (IL:NOTIFY.EVENT (IL:|fetch| COMPLETION-EVENT IL:|of| CONTEXT)) (LET* ((LOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT)) (DEFAULT-CHAR-HANDLER (IL:|fetch| DEFAULT-CHAR-HANDLER IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT))) (COMMAND-TABLE (IL:|fetch| COMMAND-TABLE IL:|of| (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT))) (WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)) (PROMPTWINDOW (IL:GETPROMPTWINDOW WINDOW)) CHARCODE COMMAND THIS-CHAR-ESCAPED) (DECLARE (IL:SPECVARS THIS-CHAR-ESCAPED)) (LOOP (IL:* IL:\;  "run the command loop forever. COMPLETE will kill the process") (WHEN (NULL (IL:ERSETQ (IL:* IL:\;  "catch errors at top of loop") (IL:SETQ CHARCODE (GETKEY CONTEXT)) (IL:* IL:|;;|  "AWAKE-COMMAND-PROCESS will cause getkey to return a command (a list), rather than a charcode") (IL:WITH.MONITOR LOCK (WHEN CHARCODE (IL:\\CARET.DOWN WINDOW) (SELECTION-DOWN CONTEXT) (IL:* IL:|;;| "this COND handles the different command generation cases. A \"command\" is a list of the form ( *), where is the function to apply, is T if SEdit should auto-scroll after this command, and * are zero or more extra args to the command function beyond the normal args of CONTEXT and CHARCODE.") (COND ((IL:LISTP CHARCODE) (IL:* IL:|;;|  "a command generated externally. the variable command gets used later, so it must be set here") (IL:SETQ COMMAND CHARCODE) (IL:SETQ THIS-CHAR-ESCAPED NIL) (FORMAT PROMPTWINDOW "~%") (IL:APPLY (CAR COMMAND) (LIST* CONTEXT NIL (CDDR COMMAND)))) (THIS-CHAR-ESCAPED (IL:* IL:\; "an escaped char") (FUNCALL DEFAULT-CHAR-HANDLER CONTEXT CHARCODE) (IL:SETQ THIS-CHAR-ESCAPED NIL)) ((AND (OR (IL:SETQ COMMAND (LOOKUP-COMMAND CHARCODE COMMAND-TABLE)) (IL:SETQ COMMAND (LOOKUP-COMMAND ( IL:GETSYNTAX CHARCODE) COMMAND-TABLE))) (IL:APPLY (CAR COMMAND) (LIST* CONTEXT CHARCODE (CDDR COMMAND)))) (IL:* IL:|;;|  "this is a valid command or syntax char, and it has already been handled") ) (T (IL:* IL:|;;|  "none of the above, or else the command didn't want to run. treat as normal input") (FUNCALL DEFAULT-CHAR-HANDLER CONTEXT CHARCODE))) (WHEN (OR (NOT COMMAND) (NOT (IL:FMEMB (CAR COMMAND) '(UNDO REDO)))) (IL:|replace| UNDO-UNDO-LIST IL:|of| CONTEXT IL:|with| NIL))) (IL:* IL:|;;|  "unless the user is typing too fast to keep up, fix up the window") (UNLESS (IL:\\SYSBUFP) (UPDATE CONTEXT NIL (SECOND COMMAND)) (IL:* IL:|;;| "once the update has triggerred on this command, set it to nil so other updates without a new command (shift selection...) won't update with an old command.") (SETQ COMMAND NIL))))) (IL:* IL:|;;| "on catching of errors, re-update to capture what was undone to run the command, like the current selection") (UPDATE CONTEXT T)))))))) (select-next-gap (il:lambda (context node index) (il:* il:\; "Edited 23-Nov-87 18:23 by DCB") (il:setq node (next-node node index)) (il:while node il:do (when (eq (il:fetch node-type il:of node) type-gap) (select-segment (il:fetch selection il:of context) context (il:fetch super-node il:of node) node node) (pending-delete (il:fetch caret-point il:of context) (il:fetch selection il:of context)) (return t)) (il:setq node (next-node node)) il:finally (set-selection-nowhere (il:fetch selection il:of context)))) ) (set-depth (il:lambda (node depth) (il:* il:\; "Edited 17-Nov-87 11:19 by DCB") (il:* il:|;;;| "set the depth of this subtree") (il:replace depth il:of node il:with depth) (il:for x il:in (cdr (il:fetch sub-nodes il:of node)) il:do (set-depth x (il:add1 depth)))) ) (set-format (il:lambda (node context format) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (il:* il:|;;;| "a node's AssignFormat method may assign a format type (such as KeyWord or BindingList) to its immediate subnodes. to do so, it should call set.format rather than setting the Format field directly. if the format type assigned is different from the old one, this function will note the node as changed and run the AssignFormatTypes method for node to give it a chance to assign new format types to its children based upon its own changed format type. For example, if a node's parent changed its format type from NIL to BindingList, the node will have to get a chance to change each of its children from NIL to Binding; and these will have to get a chance to reset themselves.") (il:* il:|;;;| "") (il:* il:|;;;| "if we are visiting every node anyway (for example, just after building the tree), we don't want to collect changed nodes and automatically propagate changed formats.") (il:* il:|;;;| "") (il:* il:|;;;| "the rough equivalent of the format type used to be determined in the parse phase and was known as the ParseMode. back then there was reparsing (which happened every time a node changed), and the reparser could reset the ParseMode. reparsing was determined to be at best unnecessary and at worst an evil, since reparsing during copy-selection can be disastrous. (think of copy-selecting (QUOTE A) from a TEdit window: you reparse from list to quote, get 'A, and do the wrong thing with the closing parenthesis.)") (il:* il:|;;;| "") (when (not (il:equal (il:fetch format il:of node) format)) (il:replace format il:of node il:with format) (note-change-format node context) (when (not (il:fetch dont-collect-changes? il:of context)) (funcall (il:fetch assign-format il:of (il:fetch node-type il:of node)) node context format)))) ) (SETUP-CONTEXT (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 14:10 by woz") (IL:* IL:|;;;| "confirm that this context is setup. that means either setting up a new context or verifying the structure in an old one, and setting the initial selection") (COND ((NULL (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT)) (IL:* IL:|;;| "this is a new sedit. setup its profile, and then the context itself") (SETUP-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT) CONTEXT) (SETUP-NEW-CONTEXT CONTEXT)) ((AND (IL:|fetch| CHANGED-STRUCTURE? IL:|of| CONTEXT) (NOT (EQ (IL:|fetch| CHANGED-STRUCTURE? IL:|of| CONTEXT) T))) (IL:* IL:|;;| "this is an old context getting restarted with a new structure stashed in the context by SEDIT. this means the new structure is not EQ with our structure. verify what we've got againt this new structure, and since it might be different, we have to throw away our edit history.") (VERIFY-STRUCTURE CONTEXT NIL (IL:|fetch| CHANGED-STRUCTURE? IL:|of| CONTEXT)) (THROW-AWAY-CHANGES CONTEXT)) (T (IL:* IL:|;;| "just verify what we've already got.") (VERIFY-STRUCTURE CONTEXT))) (SET-INITIAL-SELECTION CONTEXT))) (setup-context-window-dependencies (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (il:* il:|;;;| "setup the fields in the context that depend on the window being built") (let ((window (il:fetch display-window il:of context))) (il:* il:|;;| "set the context's comment column info based on the window.") (compute-comment-column context window))) ) (SETUP-NEW-CONTEXT (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 11:59 by woz") (IL:* IL:|;;;| "this is a new context: build all the necessary data structures.") (LET ((LOCK (IL:CREATE.MONITORLOCK (IL:CONCAT EDITOR-NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT))))) (IL:|replace| CONTEXT-LOCK IL:|of| CONTEXT IL:|with| LOCK) (IL:WITH.MONITOR LOCK (BUILD-WINDOW CONTEXT) (SETUP-CONTEXT-WINDOW-DEPENDENCIES CONTEXT) (BUILD-INTERNAL-STRUCTURE CONTEXT) (SETUP-WINDOW-CONTEXT-DEPENDENCIES CONTEXT))))) (setup-profile (il:lambda (profile context) (il:* il:\; "Edited 16-Feb-88 11:14 by raf") (il:* il:|;;;| "here we set up the specifics about the profile of the world we're editing in, based on what we're editing. this function must be called under WITH-PROFILE, so that the current bindings reflect the profile, because we update the profile by changing the binding as necessary and then re-saving the profile.") (il:* il:|;;;| "Use current readtable, print-base, print-case, print-level, print-length.") (il:* il:|;;;| "Set package based on name of structure editing. Maybe should be changed to reflect package of profile of file function lives in.") (il:* il:|;;;| "The rest get forced to appropriate values for editing.") (il:setq *read-base* 10) (il:setq *read-suppress* nil) (il:setq *package* (default-package (il:fetch icon-title il:of context) (il:fetch edit-type il:of context) (il:fetch root il:of context))) (il:setq *print-escape* t) (il:* il:\; "shouldn't matter") (il:setq *print-pretty* nil) (il:setq *print-circle* nil) (il:setq *print-radix* (il:neq *print-base* 10)) (il:* il:\; "interlisp semantics ") (il:setq *print-gensym* t) (il:setq *print-array* nil) (il:* il:\; "until we can edit ") (il:setq *print-structure* nil) (il:* il:\; "the structures.") (save-profile profile)) ) (SETUP-WINDOW-AND-PROCESS (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 2-Dec-92 17:27 by jds") (LET ((PROCESS (IL:THIS.PROCESS)) (WINDOW (IL:FETCH DISPLAY-WINDOW IL:OF CONTEXT))) (WHEN (AND (IL:WINDOWPROP WINDOW 'IL:PROCESS) (IL:NEQ PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (IL:* IL:|;;|  "it's okay if the same process is there already. this the case of RESET restarting the process.") (IL:SHOULDNT "There's already a command process for this SEdit!")) (IL:WINDOWPROP WINDOW 'IL:PROCESS PROCESS) (UPDATE-TITLE CONTEXT WINDOW T) (IL:SETTERMTABLE TERMINAL-TABLE) (IL:PROCESSPROP PROCESS 'IL:WINDOW WINDOW) (IL:PROCESSPROP PROCESS 'IL:TTYEXITFN (IL:FUNCTION TTYEXITFN)) (IL:PROCESSPROP PROCESS 'IL:KEYACTION (LET ((IL:TABLE (IL:KEYACTIONTABLE IL:\\CURRENTKEYACTION))) (IL:SETINTERRUPT (IL:CHARCODE IL:DEL) NIL IL:TABLE) IL:TABLE)) (IL:PROCESSPROP PROCESS 'IL:RESTARTABLE T) (IL:TTY.PROCESS PROCESS) (IL:CLEARW (IL:GETPROMPTWINDOW WINDOW)) (IL:TTYDISPLAYSTREAM IL:PROMPTWINDOW)))) (setup-window-context-dependencies (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (il:* il:|;;;| "setup the window properties that depend on the context being build and sedit structure computed") (let* ((window (il:fetch display-window il:of context)) (root (il:fetch root il:of context)) (height (il:idifference (il:fetch line-height il:of (il:fetch last-line il:of root)) (il:fetch ycoord il:of (il:fetch last-line il:of root))))) (il:* il:|;;| "now that we know about the structures, we can set the window's extent") (il:windowprop window (quote il:extent) (il:create il:region il:left il:_ 0 il:bottom il:_ (il:idifference 1 height) il:width il:_ (il:fetch actual-width il:of root) il:height il:_ height)) (il:* il:|;;| "and cache the title info for update.title") (il:windowprop window (quote title-info) (list :|ChangedStructure?| nil :|package| *package* :|name| (il:fetch icon-title il:of context))))) ) (shift-linear-form (il:lambda (node right-shift) (il:* il:\; "Edited 11-Apr-88 17:04 by woz") (il:* il:|;;;| "this node's linear form has just been shifted left or right. adjust its StartX value and that of any of its subnodes which are being displayed") (il:|replace| start-x il:|of| node il:|with| (il:iplus (il:|fetch| start-x il:|of| node) right-shift)) (il:|for| x il:|in| (il:|fetch| linear-form il:|of| node) il:|when| (il:|type?| weak-link x) il:|do| (shift-linear-form (il:|fetch| destination il:|of| x) right-shift))) ) (stringify (il:lambda (node environment) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (funcall (il:fetch stringify il:of (il:fetch node-type il:of node)) node environment)) ) (stringify-gap (il:lambda (node environment) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") "-?-")) (subnode-changed (il:lambda (node context) (il:* il:\; "Edited 17-Nov-87 11:20 by DCB") (il:* il:|;;;| "inform a node that one of its subnodes has been replaced") (funcall (il:fetch sub-node-changed il:of (il:fetch node-type il:of (il:fetch super-node il:of node))) (il:fetch super-node il:of node) node context)) ) (subnode-changed-root (il:lambda (node subnode context) (il:* il:\; "Edited 19-Jan-88 14:25 by woz") (let ((fn (il:fetch root-changed-fn il:of context)) extra-args) (when fn (when (and (listp fn) (not (member (first fn) (quote (lambda il:lambda))))) (il:* il:|;;| "check for the #' case (car fn) = lambda. should be able to use functionp, but it returns t for an arbitrary list, which is a bug.") (setq extra-args (rest fn)) (setq fn (first fn))) (apply fn (cons (il:fetch structure il:of subnode) extra-args))))) ) (type-of-input (il:lambda (context) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (il:* il:\; "access fn for the type of input expected") (and (il:fetch point-node il:of (il:fetch caret-point il:of context)) (il:fetch point-type il:of (il:fetch caret-point il:of context)))) ) (undo-event (il:lambda (event context) (il:* il:\; "Edited 17-Nov-87 11:20 by DCB") (cond ((null event) (il:* il:|;;| "someone got confused and left an unmatched blip on the undo list -- do nothing") nil) ((il:listp (car event)) (start-undo-block) (il:for subevent il:in event il:do (undo-event subevent context)) (end-undo-block)) (t (il:apply (car event) (cons context (cdr event)))))) ) (undo-replace-root (il:lambda (context node old-value) (il:* il:\; "Edited 6-Jul-87 20:51 by DCB") (when (not (dead-node? old-value)) (il:shouldnt "undo is confused!")) (replace-root node context (subnode 1 node) (list old-value) nil)) ) (UPDATE (IL:LAMBDA (CONTEXT RELINEARIZE SCROLL?) (IL:* IL:\; "Edited 13-Jun-88 18:57 by Snow") (IL:* IL:|;;| "fix up the window after changes to the structure. relinearize.where.necessary will fix up the formatting, and we also have to figure out where the point and selection should be displayed") (LET ((WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))) (IF RELINEARIZE (PROGN (RELINEARIZE (IL:|fetch| ROOT IL:|of| CONTEXT) CONTEXT) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%~%")) (RELINEARIZE-WHERE-NECESSARY CONTEXT)) (CHECK-SELECTION SELECTION (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (COMPUTE-SELECTION-POSITION SELECTION CONTEXT) (SELECTION-UP CONTEXT) (UPDATE-TITLE CONTEXT WINDOW) (SHOW-CARET CONTEXT T SCROLL?)))) (VERIFY-STRUCTURE (IL:LAMBDA (CONTEXT CHARCODE STRUCTURE REDISPLAY-ALWAYS? CLEAR-LINEAR-FORMS?) (IL:* IL:\; "Edited 5-Dec-90 14:10 by woz") (IL:* IL:|;;;| "reparse and relinearize as necessary to make sure the sedit is current. can be called as a command, so must have context and charcode args. the STRUCTURE are can be a new structure to verify against. this happens when someone changed the structure under an existing edit and we found out about it. otherwise we just check what we've already got.") (LET* ((ROOT (IL:|fetch| ROOT IL:|of| CONTEXT)) (CHECK-STRUCTURE (OR STRUCTURE (IL:|fetch| STRUCTURE IL:|of| (CADR (IL:|fetch| SUB-NODES IL:|of| ROOT)))))) (IL:WITH.MONITOR (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) (CLOSE-OPEN-NODE CONTEXT) (IL:|replace| CURRENT-NODE IL:|of| CONTEXT IL:|with| ROOT) (IL:|replace| \\X IL:|of| CONTEXT IL:|with| (IL:|fetch| SUB-NODES IL:|of| ROOT)) (IL:|replace| SUB-NODES IL:|of| ROOT IL:|with| (LIST 0)) (PARSE CHECK-STRUCTURE CONTEXT) (COMPUTE-ALL-FORMATS CONTEXT) (WHEN CLEAR-LINEAR-FORMS? (CLEAR-ALL-LINEAR-FORMS CONTEXT)) (COND ((OR CLEAR-LINEAR-FORMS? (IL:|fetch| CHANGED? IL:|of| ROOT)) (SELECTION-DOWN CONTEXT) (RELINEARIZE ROOT CONTEXT) (SET-SELECTION-NOWHERE (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SET-POINT-NOWHERE (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (UPDATE CONTEXT)) (REDISPLAY-ALWAYS? (IL:* IL:|;;| "this used to be here as a way to see the edit-date change. now nobody calls us with this flag set, so it could be removed. wasn't cause of change control.") (IL:REDISPLAYW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)))) (RPLACD (IL:|fetch| CHANGED-NODES IL:|of| CONTEXT) NIL))))) (walk-up-tree (il:lambda (node context fn) (il:* il:\; "Edited 25-Aug-87 09:50 by drc:") (dolist (subnode (cdr (il:fetch sub-nodes il:of node))) (walk-up-tree subnode context fn)) (funcall fn node context)) ) ) (IL:PUTPROPS IL:SEDIT-BASE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (9218 104008 (ADJUST-WIDTH 9231 . 9977) (ASSIGN-FORMAT-NIL 9979 . 10687) ( ATOM-CHANGE-RELINEARIZE 10689 . 12356) (BUILD-INTERNAL-STRUCTURE 12358 . 14276) (BUILD-LINEAR-FORM 14278 . 20897) (BUILD-NODE 20899 . 22365) (BUILD-PRELINEARIZED-NODE 22367 . 23781) (CLOSE-NODE 23783 . 24212) (COLLECT-UNDO-BLOCK 24214 . 25044) (COMPILE-STRUCTURE 25046 . 26125) (COMPUTE-ALL-FORMATS 26127 . 26601) (COMPUTE-FORMATS-AND-FORMAT-VALUES 26603 . 27682) (COMPUTE-POINT-POSITION 27684 . 28290 ) (COMPUTE-SELECTION-POSITION 28292 . 29413) (COMPUTE-SELECTION-POSITION-DEFAULT 29415 . 30414) ( CONTAINS? 30416 . 32597) (COPY-NODE 32599 . 36236) (COPY-SELECTION 36238 . 37824) ( COPY-SELECTION-DEFAULT 37826 . 39461) (CREATE-CONSTANT-STRINGS 39463 . 40320) (CREATE-ENVIRONMENTS 40322 . 45288) (CREATE-GAP-NODE 45290 . 46506) (CREATE-NODE 46508 . 47836) (CREATE-PRELINEARIZED-NODE 47838 . 48722) (CREATE-PRETTY-PRINT-ENV 48724 . 49898) (CREATE-SIMPLE-NODE 49900 . 51171) ( CREATE-STRING-ITEM 51173 . 51381) (DEFAULT-COMPILE-FN 51383 . 51550) (DEFAULT-GETDEF-FN 51552 . 51838) (DEFAULT-PACKAGE 51840 . 52163) (DELETE-NODES 52165 . 52733) (DETACH-NODE 52735 . 52978) ( FORMAT-VALUES-CHANGED 52980 . 54116) (GET-SELECTED-STRUCTURE 54118 . 54682) (HANDLE-COMPLETION 54684 . 56844) (INITIALIZE 56846 . 60029) (INSERT 60031 . 64011) (INSERT-CHANGED 64013 . 64451) (KILL-NODE 64453 . 65057) (LINEARIZE-ROOT 65059 . 65252) (NEXT-NODE 65254 . 65988) (NOTE-CHANGE 65990 . 66889) ( NOTE-CHANGE-FORMAT 66891 . 67788) (NOTE-CHANGE-IN-SIMPLE 67790 . 68695) (PARSE 68697 . 71229) ( PARSE--GAP 71231 . 72572) (PARSE--UNKNOWN 72574 . 73027) (PARSE-NEW 73029 . 73245) ( PROPAGATE-WIDTH-CHANGE 73247 . 74525) (RECOMPUTE-WIDTH 74527 . 75640) (RELINEARIZE-WHERE-NECESSARY 75642 . 79185) (REPLACE-NODE 79187 . 80174) (REPLACE-ROOT 80176 . 82094) (REVIVE-NODE 82096 . 82352) ( SEDIT1 82354 . 88940) (SELECT-NEXT-GAP 88942 . 89460) (SET-DEPTH 89462 . 89731) (SET-FORMAT 89733 . 91590) (SETUP-CONTEXT 91592 . 92991) (SETUP-CONTEXT-WINDOW-DEPENDENCIES 92993 . 93361) ( SETUP-NEW-CONTEXT 93363 . 94106) (SETUP-PROFILE 94108 . 95411) (SETUP-WINDOW-AND-PROCESS 95413 . 96848 ) (SETUP-WINDOW-CONTEXT-DEPENDENCIES 96850 . 97784) (SHIFT-LINEAR-FORM 97786 . 98320) (STRINGIFY 98322 . 98500) (STRINGIFY-GAP 98502 . 98603) (SUBNODE-CHANGED 98605 . 98924) (SUBNODE-CHANGED-ROOT 98926 . 99446) (TYPE-OF-INPUT 99448 . 99727) (UNDO-EVENT 99729 . 100122) (UNDO-REPLACE-ROOT 100124 . 100366) ( UPDATE 100368 . 101384) (VERIFY-STRUCTURE 101386 . 103792) (WALK-UP-TREE 103794 . 104006))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-COMMANDS b/sources/SEDIT-COMMANDS new file mode 100644 index 00000000..b0714ae8 --- /dev/null +++ b/sources/SEDIT-COMMANDS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "23-Apr-2018 18:12:52"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.;3| 124949 IL:|changes| IL:|to:| (IL:FUNCTIONS GET-SELECTION) IL:|previous| IL:|date:| "22-Apr-2018 17:13:59" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.;2|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991, 2018 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMANDSCOMS) (IL:RPAQQ IL:SEDIT-COMMANDSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-COMMANDS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-COMMANDS) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:VARIABLES COMMAND-TABLE-SPEC *EDIT-FN* *WRAP-SEARCH*) (IL:VARS MENU-DESCRIPTION (FIND-CANDIDATE NIL) (SUBSTITUTE-CANDIDATE NIL) (MUTATE-CANDIDATE NIL) (PACKAGE-CANDIDATE NIL) (PRINTBASE-CANDIDATE NIL)) (IL:INITVARS (CONVERT-UPGRADE 100) (WANT-MENU NIL) (MENUS NIL)) (IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.)))) (IL:FUNCTIONS (IL:* IL:|;;| "pseudo-selections") PSEUDO-SELECTION-FROM-SELECTION COMPOSE-PSEUDO-SELECTION DECOMPOSE-PSEUDO-SELECTION SELECTION-FROM-PSEUDO-SELECTION SELECT-PSEUDO-SEGMENT) (IL:* IL:|;;| "user interface to adding new commands") (IL:FUNCTIONS ADD-COMMAND GET-SELECTION REPLACE-SELECTION RESET-COMMANDS DEFAULT-COMMANDS) (IL:VARIABLES DEFAULT-COMMAND-TABLE-SPEC FIRST-ADD-COMMAND FIRST-ADD-COMMAND-MENU-ENTRY) (IL:FUNCTIONS (IL:* IL:|;;| "building help menu") EQUALIZE-STRING-WIDTHS MINIMUM-STRING-WIDTH MAXIMUM-STRING-WIDTH) (IL:FUNCTIONS FIND-AND-DISPLAY-STRUCTURE FIND-AND-DISPLAY-STRUCTURE-BACKWARDS FIND-AND-DISPLAY-SUBSTRUCTURE FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS FIND-NTH-STRUCTURE FIND-NODE-SUBSTRUCTURE FIND-NODE-SUBSTRUCTURE-BACKWARDS FIND-OBJ FIND-SELECTION FIND-SELECTION-BACKWARDS FIND-STRUCTURE FIND-STRUCTURE-BACKWARDS FIND-SUBSTRUCTURE FIND-SUBSTRUCTURE-BACKWARDS GET-USER-STRING SEARCH-OBJ SEARCH-OBJ-BACKWARDS SUBSTITUTE-OBJ SUBSTITUTE-STRUCTURE SUBSTITUTE-SUBSTRUCTURE STRUCTURE-FROM-SELECTION STRUCTURE-FROM-STRING COMMENT-OUT-SELECTION) (IL:FNS ADD-MENU BACKSPACE CHANGE-PACKAGE CHANGE-PRINTBASE CHANGE-QUOTE CONVERT-COMMENT CONVERT-COMMENT-STRUCTURE CONVERT-COMMENT-TAIL CREATE-COMMAND-TABLE DEFAULT-EDIT-FN DELETE-SELECTION DELETE-WORD DO-MUTATION EDIT-SELECTION EVAL-SELECTION EXPAND EXTRACT-CURRENT-SELECTION FIND-COMMENT GET-MENU EDIT-HELP HELPMENU INPUT-DOT INPUT-ESCAPE INPUT-NORMAL-CHAR INPUT-QUOTE INPUT-SQUARE-BRACKET INPUT-STRINGDELIM INPUT-TOKENDELIM INSERT-MULTI-ESCAPE INSERT-SPECIAL-CHARACTER INSPECT-SELECTION JOIN MENU-CLOSEFN MENU-FIND-SELECTEDFN MENU-INIT-STATE MENU-PACKAGE-SELECTEDFN MENU-PRINTBASE-SELECTEDFN MENU-SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN MUTATE QUOTE-CURRENT-SELECTION REDISPLAY REDO SELECTED-FN-NAME SKIP-TO-GAP UNDO UNDO-EXTRACT))) (IL:PUTPROPS IL:SEDIT-COMMANDS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMANDS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (DEFPARAMETER COMMAND-TABLE-SPEC (IL:* IL:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: ( +) where is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), is a list of strings for the name, key-name, and help-string, is T if the caret should be normalized after this command, and + is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).") '( (IL:* IL:|;;| "STRUCTURE CONTROL") (INSERT-NULL-LIST NIL T (IL:LEFTPAREN)) (CLOSE-LIST NIL NIL (IL:RIGHTPAREN)) (INPUT-SQUARE-BRACKET NIL NIL (IL:LEFTBRACKET) (IL:RIGHTBRACKET)) (INPUT-TOKENDELIM NIL T (IL:SEPRCHAR)) (INPUT-STRINGDELIM NIL NIL (IL:STRINGDELIM)) (INPUT-ESCAPE NIL NIL (IL:ESCAPE)) (INSERT-MULTI-ESCAPE NIL NIL (IL:MULTIPLE-ESCAPE)) (INSERT-SPECIAL-CHARACTER NIL NIL (IL:PACKAGEDELIM)) (START-COMMENT NIL NIL ";") (INPUT-DOT NIL NIL ".") (INSERT-SPECIAL-CHARACTER NIL NIL "#") ((INPUT-QUOTE QUOTE) NIL NIL "'") ((INPUT-QUOTE IL:BQUOTE) NIL NIL "`") ((INPUT-QUOTE IL:COMMA) NIL NIL ",") ((INPUT-QUOTE COMMA-AT) NIL NIL "@") (IL:* IL:|;;| "EDIT CONTROL") (DELETE-SELECTION NIL T IL:DEL) (BACKSPACE NIL T IL:BS "^A") (DELETE-WORD NIL T "^W") ((VERIFY-STRUCTURE NIL T T) NIL NIL "^L") ((VERIFY-STRUCTURE NIL T NIL) NIL NIL "1,^L") (IL:* IL:|;;| "COMPLETION") ((COMPLETE :ABORT NIL) ("Abort" "M-A" "Complete this edit without installing changes.") NIL "1,A" "1,a" (ABORT)) (NULL ("" "" "") NIL 0) ((COMPLETE :DONE NIL) ("Done" "C-X" "Complete this edit and leave the window open.") NIL "^X" (DONE)) ((COMPLETE :CLOSE) ("Done & Close" "C-M-X" "Complete this edit and close the window.") NIL "1,^X" (EXIT)) ((COMPLETE :DONE T) ("Done & Compile" "C-C" "Complete this edit, compile, and leave the window open.") NIL "^C" (COMPILE)) ((COMPLETE :CLOSE T) ("Done, Compile, & Close" "C-M-C" "Complete this edit, compile, and close the window.") NIL "1,^C") (IL:* IL:|;;| "COMMANDS") (NULL ("" "" "") NIL 0) (UNDO ("Undo" "M-U" "Undo the last change made.") NIL "1,U" "1,u" 516 (UNDO)) (REDO ("Redo" "M-R" "Redo the last change undone.") NIL "1,R" "1,r" 520 (REDO)) (NULL ("" "" "") NIL 0) (FIND-OBJ ("Find" "M-F" "Find the current selection, or prompt for structure to Find.") T "1,F" "1,f" 515 (FIND)) ((FIND-OBJ NIL T) ("Reverse Find" "C-M-F" "Find the current selection, or prompt for structure to Find.") T "1,^F") ((SUBSTITUTE-OBJ NIL NIL T) ("Remove" "C-M-S" "Remove structures from within the current selection.") NIL "1,^S") (SUBSTITUTE-OBJ ("Substitute" "M-S" "Substitute structures within the current selection.") NIL "1,S" "1,s" 547 (SUBSTITUTE)) (SKIP-TO-GAP ("Find Gap" "M-N" "Skip to the next fill in gap.") T "1,N" "1,n" 530) (NULL ("" "" "") NIL 0) (EDIT-HELP ("Arglist" "M-H" "Show the argument list for the selected function.") NIL "1,H" "1,h" 513 (ARGLIST)) (CONVERT-COMMENT ("Convert Comment" "M-;" "Convert the old style comments in the current selection.") NIL "1,;") (COMMENT-OUT-SELECTION NIL NIL "1,^;") (EDIT-SELECTION ("Edit" "M-O" "Edit the definition of the current selection.") NIL "1,O" "1,o" (EDIT)) ((EDIT-SELECTION (:CURRENT)) ("Edit Fast" "C-M-O" "Edit the current definition of the selection.") NIL "1,^O") (EVAL-SELECTION ("Eval" "M-E" "Evaluate the current selection.") NIL "1,E" "1,e" (EVAL)) (EXPAND ("Expand" "M-X" "Replace the current selection with its definition.") NIL "1,X" "1,x" IL:ESC 532 (EXPAND)) (EXTRACT-CURRENT-SELECTION ("Extract" "M-/" "Extract one level of structure: unquote or unlist.") NIL "1,/" (EXTRACT)) (INSPECT-SELECTION ("Inspect" "M-I" "Inspect the current selection.") NIL "1,I" "1,i" (INSPECT)) (JOIN ("Join" "M-J" "Join selected items together.") NIL "1,J" "1,j" (JOIN)) (MUTATE ("Mutate" "M-Z" "Prompt for a function to operate on the current selection.") NIL "1,Z" "1,z") ((PARENTHESIZE-CURRENT-SELECTION NIL) ("Parenthesize" "M-(" "Parenthesize the current selection.") NIL "1,(" "1,71" (PAREN)) ((PARENTHESIZE-CURRENT-SELECTION T) NIL NIL "1,)" "1,60") ((QUOTE-CURRENT-SELECTION QUOTE) ("Quote" "M-'" "Quote the current selection.") NIL "1,'" (QUOTE)) ((QUOTE-CURRENT-SELECTION IL:BQUOTE) NIL NIL "1,`") ((QUOTE-CURRENT-SELECTION IL:COMMA) NIL NIL "1,,") ((QUOTE-CURRENT-SELECTION COMMA-AT) NIL NIL "1,@" "1,62") ((QUOTE-CURRENT-SELECTION COMMA-DOT) NIL NIL "1,.") ((QUOTE-CURRENT-SELECTION FUNCTION) NIL NIL "1,#" "1,63") (NULL ("" "" "") NIL 0) (CHANGE-PRINTBASE ("Set Print-Base" "M-B" "Set the print-base for this edit.") NIL "1,B" "1,b" (SET-PRINT-BASE)) (CHANGE-PACKAGE ("Set Package" "M-P" "Set the package to edit in.") NIL "1,P" "1,p" (SET-PACKAGE)) (ADD-MENU ("Attach Menu" "M-M" "Attach a command menu.") NIL "1,M" "1,m") (IL:* IL:|;;| "RANDOM: tells Meta-Space or Meta-Return to scroll to the selection, using the auto-scroller for free.") (TRUE NIL T "1, " "1, "))) (DEFPARAMETER *EDIT-FN* 'DEFAULT-EDIT-FN) (DEFVAR *WRAP-SEARCH* NIL) (IL:RPAQQ MENU-DESCRIPTION ((IL:PROPS IL:FONT (IL:HELVETICA 10 IL:BOLD)) ((IL:GROUP (IL:PROPS IL:FORMAT IL:COLUMN IL:COLUMNSPACE 20 IL:ROWSPACE 3) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12) ((IL:PROPS IL:BOX 1) (IL:LABEL EXIT IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL DONE IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL ABORT IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 39)) ((IL:PROPS IL:BOX 1) (IL:LABEL UNDO IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL REDO IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL ARGLIST IL:SELECTEDFN MENU-SELECTEDFN)))) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE IL:COLUMNSPACE 12) ((IL:PROPS IL:BOX 1) (IL:LABEL PAREN IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL QUOTE IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EXTRACT IL:SELECTEDFN MENU-SELECTEDFN)) ((IL:PROPS IL:BOX 1) (IL:LABEL EDIT IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EVAL IL:SELECTEDFN MENU-SELECTEDFN) (IL:LABEL EXPAND IL:SELECTEDFN MENU-SELECTEDFN IL:MAXWIDTH 46)))))) ((IL:LABEL PRINT-BASE IL:SELECTEDFN MENU-PRINTBASE-SELECTEDFN IL:ID PRINTBASE-ITEM IL:LINKS (IL:EDIT PRINTBASE-VALUE-ITEM)) (IL:LABEL "" TYPE IL:NUMBER IL:MAXWIDTH 14 IL:ID PRINTBASE-VALUE-ITEM IL:FONT (IL:GACHA 10)) (IL:LABEL PACKAGE IL:SELECTEDFN MENU-PACKAGE-SELECTEDFN IL:ID PACKAGE-ITEM IL:LINKS (IL:EDIT PACKAGE-NAME-ITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID PACKAGE-NAME-ITEM IL:FONT (IL:GACHA 10))) ((IL:GROUP (IL:PROPS IL:FORMAT IL:TABLE) ((IL:LABEL FIND\: IL:SELECTEDFN MENU-FIND-SELECTEDFN IL:LINKS (IL:EDIT FINDITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID FINDITEM IL:FONT (IL:GACHA 10))) ((IL:LABEL SUBSTITUTE\: IL:SELECTEDFN MENU-SUBSTITUTE-SELECTEDFN IL:LINKS (IL:EDIT SUBSTITUTEITEM FINDITEM FINDITEM)) (IL:LABEL "" TYPE IL:EDIT IL:ID SUBSTITUTEITEM IL:FONT (IL:GACHA 10))))))) (IL:RPAQQ FIND-CANDIDATE NIL) (IL:RPAQQ SUBSTITUTE-CANDIDATE NIL) (IL:RPAQQ MUTATE-CANDIDATE NIL) (IL:RPAQQ PACKAGE-CANDIDATE NIL) (IL:RPAQQ PRINTBASE-CANDIDATE NIL) (IL:RPAQ? CONVERT-UPGRADE 100) (IL:RPAQ? WANT-MENU NIL) (IL:RPAQ? MENUS NIL) (IL:DECLARE\: IL:EVAL@COMPILE (IL:RPAQ WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.))) (IL:CONSTANTS (WORD-DELIM-CHARS (IL:CHARCODE (IL:SPACE IL:CR IL:TAB - IL:{ IL:} IL:[ IL:] IL:\; < > IL:\.)))) ) (DEFUN PSEUDO-SELECTION-FROM-SELECTION (SEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a selection and creates a pseudo selection from it.") (COMPOSE-PSEUDO-SELECTION (IL:FETCH SELECT-NODE IL:OF SEL) (IL:FETCH SELECT-START IL:OF SEL) (OR (IL:FETCH SELECT-END IL:OF SEL) (IL:FETCH SELECT-START IL:OF SEL)))) (DEFUN COMPOSE-PSEUDO-SELECTION (NODE &OPTIONAL START END) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes the fields of a pseudo selection and hands back one.") (COND ((LISTP NODE) (LIST (IL:FETCH SUPER-NODE IL:OF (FIRST NODE)) (+ (IL:FETCH SUB-NODE-INDEX IL:OF (FIRST NODE)) (OR START 0)) (+ (IL:FETCH SUB-NODE-INDEX IL:OF (FIRST NODE)) (1- (OR END (LENGTH NODE)))))) ((OR START END) (LIST NODE (OR START END) (OR END START))) (T NODE))) (DEFUN DECOMPOSE-PSEUDO-SELECTION (PSEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a pseudo selection and hands its fields back as values.") (IF (LISTP PSEL) (VALUES (FIRST PSEL) (OR (SECOND PSEL) (THIRD PSEL)) (OR (THIRD PSEL) (SECOND PSEL))) (VALUES PSEL NIL NIL))) (DEFUN SELECTION-FROM-PSEUDO-SELECTION (PSEL &OPTIONAL SEL) (IL:* IL:|;;;| "A pseudo-selection is either a node or a list of a node and two integers. It's interpreted as the select-node, select-start, and select-end fields of a selection.") (IL:* IL:|;;;| "This function takes a pseudo-selection and constructs the corresponding selection. If you don't hand it a selection structure, it conses one.") (UNLESS SEL (SETF SEL (IL:CREATE EDIT-SELECTION))) (MULTIPLE-VALUE-BIND (NODE START END) (DECOMPOSE-PSEUDO-SELECTION PSEL) (IL:REPLACE SELECT-NODE IL:OF SEL IL:WITH NODE) (IL:REPLACE SELECT-START IL:OF SEL IL:WITH START) (IL:REPLACE SELECT-END IL:OF SEL IL:WITH END) SEL)) (DEFUN SELECT-PSEUDO-SEGMENT (CONTEXT PSEL &OPTIONAL SET-POINT? WHERE) (MULTIPLE-VALUE-BIND (NODE START END) (DECOMPOSE-PSEUDO-SELECTION PSEL) (IF START (SELECT-NODE-SEGMENT CONTEXT NODE START END) (SELECT-NODE CONTEXT NODE SET-POINT? WHERE)))) (IL:* IL:|;;| "user interface to adding new commands") (DEFUN ADD-COMMAND (KEY-CODE FORM &OPTIONAL SCROLL? KEY-NAME COMMAND-NAME HELP-STRING) (WHEN FIRST-ADD-COMMAND (IL:* IL:|;;| "cache the command-table-spec so the user can undo this!") (SETQ DEFAULT-COMMAND-TABLE-SPEC (COPY-TREE COMMAND-TABLE-SPEC)) (SETQ FIRST-ADD-COMMAND NIL)) (WHEN (AND KEY-NAME COMMAND-NAME FIRST-ADD-COMMAND-MENU-ENTRY) (IL:* IL:|;;| "add another separation line to the help menu.") (NCONC COMMAND-TABLE-SPEC (LIST (LIST 'NULL (LIST "-----" "" "") NIL 0))) (SETQ FIRST-ADD-COMMAND-MENU-ENTRY NIL)) (NCONC COMMAND-TABLE-SPEC (LIST (LIST FORM (WHEN (AND KEY-NAME COMMAND-NAME) (LIST KEY-NAME COMMAND-NAME HELP-STRING)) SCROLL? KEY-CODE))) (OR COMMAND-NAME FORM)) (DEFUN GET-SELECTION (CONTEXT) (IL:* IL:\; "Edited 23-Apr-2018 18:11 by rmk:") (IL:* IL:\; "Edited 22-Apr-2018 16:48 by rmk:") (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (CHARS (IL:FETCH STRUCTURE IL:OF NODE)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (END (IL:FETCH SELECT-END IL:OF SELECTION)) (STRING (IL:FETCH SELECT-STRING IL:OF SELECTION)) (TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION)) NOT-ALL-SELECTED) (IL:* IL:|;;| "All except NODE are needed for the atom/string cases") (COND ((NULL NODE) (VALUES NIL NIL)) ((EQ TYPE 'STRUCTURE) (VALUES (STRUCTURE-FROM-SELECTION SELECTION) (COND (START :SUB-LIST) (T T)))) (T (IL:* IL:|;;| "RMK: a single character-atom or a substring of characters in an atom or string. Full multicharacter atoms are structures. Code copies from COPY-SELECTION-LITATOM") (WHEN (IL:TYPE? BROKEN-ATOM CHARS) (IL:SETQ CHARS (IL:FETCH ATOM-CHARS IL:OF CHARS))) (WHEN (AND START (OR (IL:NEQ (OR END (IL:SETQ END START)) (IL:NCHARS STRING)) (IL:NEQ START 1))) (IL:* IL:|;;| "some subset of the atom/string has been selected") (IL:SETQ NOT-ALL-SELECTED T)) (VALUES (IL:MKSTRING (IF NOT-ALL-SELECTED (DETRANSLATE-CHARS (IL:SUBSTRING STRING START END) TYPE) CHARS) (IF (EQ TYPE 'STRING) (NULL START) (NOT NOT-ALL-SELECTED))) :CHARACTERS))))) (DEFUN REPLACE-SELECTION (CONTEXT STRUCTURE SELECTION-TYPE) (UNLESS (OR (EQ SELECTION-TYPE T) (EQ SELECTION-TYPE :SUB-LIST)) (ERROR "Illegal SELECTION-TYPE arg: ~A." SELECTION-TYPE)) (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) NEW-NODES) (COND ((OR (NOT (IL:FETCH SELECT-NODE IL:OF SELECTION)) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) 'STRUCTURE))) (ERROR "Invalid SEdit selection. Can't REPLACE-SELECTION.")) ((EQ SELECTION-TYPE :SUB-LIST) (SETQ NEW-NODES (MAPCAR #'(LAMBDA (S) (PARSE-NEW S CONTEXT)) STRUCTURE))) (T (SETQ NEW-NODES (PARSE-NEW STRUCTURE CONTEXT)))) (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)) (IL:* IL:|;;| "try to select the stuff that was just inserted.") (SELECT-PSEUDO-SEGMENT CONTEXT (COMPOSE-PSEUDO-SELECTION NEW-NODES)))) (DEFUN RESET-COMMANDS () (LET ((COMMANDS (CREATE-COMMAND-TABLE COMMAND-TABLE-SPEC))) (IL:REPLACE (EDIT-ENV COMMAND-TABLE) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (FIRST COMMANDS)) (IL:REPLACE (EDIT-ENV HELP-MENU) IL:OF LISP-EDIT-ENVIRONMENT IL:WITH (SECOND COMMANDS))) T) (DEFUN DEFAULT-COMMANDS () (SETQ COMMAND-TABLE-SPEC (COPY-TREE DEFAULT-COMMAND-TABLE-SPEC)) (SETQ FIRST-ADD-COMMAND-MENU-ENTRY T) (RESET-COMMANDS) T) (DEFGLOBALVAR DEFAULT-COMMAND-TABLE-SPEC NIL "Used to cache the original command table spec for Reset-Commands") (DEFGLOBALVAR FIRST-ADD-COMMAND T "Used in Add-Command to know if this is the first new command for help-menu update purposes") (DEFGLOBALVAR FIRST-ADD-COMMAND-MENU-ENTRY T "Used in Add-Command to signal the first time a new command is added to the middle button menu, so that the user entries can be separated from the default entries" ) (DEFUN EQUALIZE-STRING-WIDTHS (STRING-LIST FONT &OPTIONAL PRIN2? (DESIRED-WIDTH (  MAXIMUM-STRING-WIDTH STRING-LIST FONT PRIN2?)) (PAD-CHAR #\Space)) (IL:* IL:|;;;| "Increase the width of all the strings in STRING-LIST to DESIRED-WIDTH by padding them on the right with PAD-CHAR.") (DO ((PAD-CHAR-WIDTH (IL:CHARWIDTH (CHAR-CODE PAD-CHAR) FONT)) (STR STRING-LIST (REST STR))) ((NULL STR) STRING-LIST) (SETF (FIRST STR) (CONCATENATE 'STRING (FIRST STR) (MAKE-STRING (CEILING (- DESIRED-WIDTH (IL:STRINGWIDTH (FIRST STR) FONT PRIN2?)) PAD-CHAR-WIDTH) :INITIAL-ELEMENT PAD-CHAR))))) (DEFUN MINIMUM-STRING-WIDTH (STRING-LIST FONT PRIN2?) (APPLY #'MIN (MAPCAR #'(LAMBDA (S) (IL:STRINGWIDTH S FONT PRIN2?)) STRING-LIST))) (DEFUN MAXIMUM-STRING-WIDTH (STRING-LIST FONT PRIN2?) (APPLY #'MAX (MAPCAR #'(LAMBDA (S) (IL:STRINGWIDTH S FONT PRIN2?)) STRING-LIST))) (DEFUN FIND-AND-DISPLAY-STRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?) (IL:* IL:|;;;| "Find structure and display it by selecting it (point after) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-STRUCTURE STR (OR SCOPE TOP) START))) (COND (TARGET (SELECT-NODE CONTEXT TARGET T T) (FORMAT PROMPTWINDOW "~%~S - Found." STR)) ((AND WRAP? START) (FIND-AND-DISPLAY-STRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR))))) (DEFUN FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?) (IL:* IL:|;;;| "Like find-and-display-structure, but searches backwards") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-STRUCTURE-BACKWARDS STR (OR SCOPE TOP) END))) (COND (TARGET (SELECT-NODE CONTEXT TARGET T T) (FORMAT PROMPTWINDOW "~%~S - Found." STR)) ((AND WRAP? END) (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~S - Not found." STR))))) (DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE (CONTEXT STR &OPTIONAL SCOPE START WRAP?) (IL:* IL:|;;;| "Find substructure and display it by selecting it (pending delete) and normalizing the selection in the window. SCOPE defaults to the root structure of the CONTEXT. The WRAP? flag says to wrap failing searches around and try them again (i.e., ignore start and try again).") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-SUBSTRUCTURE STR (OR SCOPE TOP) START))) (COND (TARGET (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR)) ((AND WRAP? START) (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR))))) (DEFUN FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (CONTEXT STR &OPTIONAL SCOPE END WRAP?) (IL:* IL:|;;;| "Like find-and-display-substructure but searches backwards") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (TARGET (FIND-SUBSTRUCTURE-BACKWARDS STR (OR SCOPE TOP) END))) (COND (TARGET (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (FORMAT PROMPTWINDOW "~%~{~S ~}- Found." STR)) ((AND WRAP? END) (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE)) (T (FORMAT PROMPTWINDOW "~%~{~S ~}- Not found." STR))))) (DEFUN FIND-NTH-STRUCTURE (CONTEXT CHARCODE STRUCTURE N) (IL:* IL:|;;;| "Find the Nth occurance of Structure in this edit, always starting from the beginning. This function is used as an external command to set the selection to a desired structure. Find, select, and normalize.") (LET ((TOP (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT)))) (DO ((M 1 (+ M 1)) (TARGET (FIND-STRUCTURE STRUCTURE TOP) (FIND-STRUCTURE STRUCTURE TOP (NEXT-NODE TARGET)))) ((OR (NULL TARGET) (= N M)) (AND TARGET (SELECT-NODE CONTEXT TARGET T T))))) T) (DEFUN FIND-NODE-SUBSTRUCTURE (STR STRLEN NODE &OPTIONAL START END CONTINUATION?) (IL:* IL:|;;;| "STR is a list of structures of length STRLEN. NODE, together with START and END (which are subnode indices), is taken to indicate a subtree. We return a pseudo-selection which selects the first sequence of sibling nodes in that subtree whose successive structures match the successive elements of STR.") (IL:* IL:|;;;| "\"First\" here is taken to mean \"first in linearization order\", so we have to do a careful recursion which: (1a) recursively checks the subtree rooted at the START subnode of NODE (default the first), (1b) checks if the START subnode starts a matching sibling sequence, (2a) recursively checks the subtree rooted at the START+1 subnode of NODE, (2b) checks if the START+1 subnode starts a matching sibling sequence, . . ., (Na) recusively checks the subtree rooted at the END subnode of NODE (default the last), (Nb) checks if the END subnode starts a matching sibling sequence [note that such a sequence could be only 1 node long since END is the right end of the subtree being checked].") (IL:* IL:|;;;| "N.B. It might seem that, to get true linearization order, we should check to see if a node starts a matching sibling sequence before we check its subtree. But since node structures can not be circular, we know that if a match is found in the subtree below a node then that node could not have started a matching sequence.") (IL:* IL:|;;;| "The CONTINUATION? flag means that we are continuing a search that has already recursively checked the START subnode, so we skip that particular recursion. This generally happens when we are working our way up and to the right in some subtree which has already been partially checked.") (SETF START (OR START 1)) (LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE)) (LASTINDEX (OR END (FIRST SUBNODES)))) (DO ((SUBS (NTHCDR START SUBNODES) (REST SUBS)) (INDEX START (1+ INDEX)) (ENDINDEX (+ START (1- STRLEN)) (1+ ENDINDEX)) (DOSUBS? (NOT CONTINUATION?) T) MATCH) ((OR (NULL SUBS) (AND END (> INDEX END))) NIL) (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE STR STRLEN (FIRST SUBS)))) (RETURN MATCH)) (UNLESS (OR (> ENDINDEX LASTINDEX) (MISMATCH STR SUBS :END2 STRLEN :TEST #'(LAMBDA (S N) (IL:EQUAL S (IL:FETCH STRUCTURE IL:OF N))))) (RETURN (LIST NODE INDEX ENDINDEX)))))) (DEFUN FIND-NODE-SUBSTRUCTURE-BACKWARDS (STR STRLEN NODE &OPTIONAL START END CONTINUATION?) (IL:* IL:|;;;| "Like find-node-substructure but searches in reverse linearization order.") (LET* ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE)) (SUBLENGTH (FIRST SUBNODES))) (SETF END (OR END SUBLENGTH)) (DO ((SUBS (NTHCDR (- SUBLENGTH END) (REVERSE (CDR SUBNODES))) (CDR SUBS)) (INDEX END (1- INDEX)) (STARTINDEX (- END (1- STRLEN)) (1- STARTINDEX)) (DOSUBS? (NOT CONTINUATION?) T) MATCH) ((OR (NULL SUBS) (AND START (< INDEX START))) NIL) (WHEN (AND DOSUBS? (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN (FIRST SUBS)))) (RETURN MATCH)) (UNLESS (OR (< STARTINDEX 1) (MISMATCH STR SUBS :END2 STRLEN :TEST #'(LAMBDA (S N) (IL:EQUAL S (IL:FETCH STRUCTURE IL:OF N))))) (RETURN (LIST NODE STARTINDEX INDEX)))))) (DEFUN FIND-OBJ (CONTEXT &OPTIONAL CHARCODE FIND-STRING BACKWARDS?) (IL:* IL:|;;;| "Find either the passed structure, the selected structure, or a prompted-for structure. The search direction is forward unless BACKWARDS? is specified.") (CLOSE-OPEN-NODE CONTEXT) (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (WRAP? *WRAP-SEARCH*)) (COND ((AND (NULL FIND-STRING) (IL:|fetch| SELECT-NODE IL:|of| SELECTION) (EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION) 'STRUCTURE)) (IL:* IL:|;;| "there is a non-string selection") (IF BACKWARDS? (FIND-SELECTION-BACKWARDS CONTEXT WRAP?) (FIND-SELECTION CONTEXT WRAP?))) (T (IF BACKWARDS? (SEARCH-OBJ-BACKWARDS CONTEXT FIND-STRING WRAP?) (SEARCH-OBJ CONTEXT FIND-STRING WRAP?))))) T) (DEFUN FIND-SELECTION (CONTEXT &OPTIONAL WRAP?) (IL:* IL:|;;;| "Find the next match of the current selection and display it.") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (START (IL:|fetch| SELECT-START IL:|of| SELECTION))) (IF START (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence after it") (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL (LIST NODE (1+ START)) WRAP?) (IL:* IL:|;;| "a node is selected, look for a matching node ") (IF (SETF START (NEXT-NODE NODE T)) (IL:* IL:|;;| "start the search with the following node") (FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL START WRAP?) (IL:* IL:|;;| "there are no more nodes, either wrap or give up") (IF WRAP? (FIND-AND-DISPLAY-STRUCTURE CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) ) (FORMAT PROMPTWINDOW "~%At end; no more structure to search.")))))) (DEFUN FIND-SELECTION-BACKWARDS (CONTEXT &OPTIONAL WRAP?) (IL:* IL:|;;;| "Find the previous match of the current selection and display it.") (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (END (OR (IL:|fetch| SELECT-START IL:|of| SELECTION) (IL:|fetch| SELECT-END IL:|of| SELECTION)))) (IF END (IL:* IL:|;;| "a sibling sequence is selected, look for a matching sequence before it") (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL (LIST NODE (1- END)) WRAP?) (IL:* IL:|;;| "a node is selected, look for a matching node ") (IF (SETF END (PREV-NODE NODE T)) (IL:* IL:|;;| "start the search with the previous node") (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION) NIL END WRAP?) (IL:* IL:|;;| "there are no more nodes, either wrap or give up") (IF WRAP? (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (STRUCTURE-FROM-SELECTION SELECTION)) (FORMAT PROMPTWINDOW "~%At beginning; no more structure to search.")))))) (DEFUN FIND-STRUCTURE (STR SCOPE &OPTIONAL START) (IL:* IL:|;;;| "Search forward in linearization order for a node whose structure matches STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate its left-most node). START defaults to SCOPE. The return value is the first node in SCOPE at or after START whose structure is IL:EQUAL to STR.") (IL:* IL:|;;;| "N.B. Since node structures can not be circular, no subnode of a node can have structure matching that node. Thus looking for a matching node in pre-order is the same as looking for one in linearization order. So we do a pre-order search here.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (START-NODE START-START) (DECOMPOSE-PSEUDO-SELECTION START) (WHEN (AND (NULL SCOPE-START) (OR (NULL START-NODE) (AND (NULL START-START) (EQ START-NODE SCOPE-NODE))) (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE))) (IL:* IL:|;;| "special case: the scope includes its root node, we're starting at the root of the scope, and the root of the scope matches the passed structure.") (RETURN-FROM FIND-STRUCTURE SCOPE-NODE)) (IL:* IL:|;;| "normal case: check all the nodes in the scope subtree in preorder.") (DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE))) (NODE (OR (IF START-START (SUBNODE START-START START-NODE) (UNLESS (EQ START-NODE SCOPE-NODE) START-NODE)) (IF SCOPE-START (SUBNODE SCOPE-START SCOPE-NODE) (NEXT-NODE SCOPE-NODE))) (NEXT-NODE NODE))) ((OR (NULL NODE) (< (IL:FETCH DEPTH IL:OF NODE) MIN-DEPTH) (AND SCOPE-END (EQ (IL:FETCH SUPER-NODE IL:OF NODE) SCOPE-NODE) (> (IL:FETCH SUB-NODE-INDEX IL:OF NODE) SCOPE-END))) NIL) (WHEN (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF NODE)) (RETURN NODE)))))) (DEFUN FIND-STRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END) (IL:* IL:|;;;| "like find-structure but searches in reverse linearization order. Actually we search in postorder rather than reverse linearization order but this works just as well for the same reasons that preorder matches linearization order.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (END-NODE END-START END-END) (DECOMPOSE-PSEUDO-SELECTION END) (WHEN (AND (NULL SCOPE-START) (OR (NULL END-NODE) (AND (NULL END-START) (EQ END-NODE SCOPE-NODE))) (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF SCOPE-NODE))) (IL:* IL:|;;| "special case: the scope includes its root node, we're ending at the root of the scope, and the root of the scope matches the passed structure.") (RETURN-FROM FIND-STRUCTURE-BACKWARDS SCOPE-NODE)) (IL:* IL:|;;|  "normal case: check all the nodes in the scope subtree in postorder.") (DO* ((MIN-DEPTH (1+ (IL:FETCH DEPTH IL:OF SCOPE-NODE))) (NODE (OR (IF END-END (SUBNODE END-END END-NODE) (UNLESS (EQ END-NODE SCOPE-NODE) END-NODE)) (IF SCOPE-END (SUBNODE SCOPE-END SCOPE-NODE) (PREV-NODE SCOPE-NODE))) (PREV-NODE NODE))) ((OR (NULL NODE) (< (IL:FETCH DEPTH IL:OF NODE) MIN-DEPTH) (AND SCOPE-START (EQ (IL:FETCH SUPER-NODE IL:OF NODE) SCOPE-NODE) (< (IL:FETCH SUB-NODE-INDEX IL:OF NODE) SCOPE-START))) NIL) (WHEN (IL:EQUAL STR (IL:FETCH STRUCTURE IL:OF NODE)) (RETURN NODE)))))) (DEFUN FIND-SUBSTRUCTURE (STR SCOPE &OPTIONAL START) (IL:* IL:|;;;| "Search forward in linearization order for a sequence of nodes whose successive structures match the successive elements of STR. The search is bounded by SCOPE (a pseudo-selection taken to indicate a subtree) and starts at START (a pseudo-selection taken to indicate the left edge of a subtree). START defauts to SCOPE. The return value is a pseudo-selection indicating the sibling sequence of nodes in SCOPE at or to the right of START whose successive node structures are IL:EQUAL to the successive members of STR.") (IL:* IL:|;;;| "N.B. For a sequence of sibling nodes, first in linearization order can not be found by doing a preorder search. See find-node-substructure for details about the correct search method.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (START-NODE START-START) (DECOMPOSE-PSEUDO-SELECTION START) (COND ((NULL START-NODE) (IL:* IL:|;;| "just check the entire scope") (FIND-NODE-SUBSTRUCTURE STR (LENGTH STR) SCOPE-NODE SCOPE-START SCOPE-END)) ((EQ START-NODE SCOPE-NODE) (IL:* IL:|;;| "just check a terminal subtree of the scope") (FIND-NODE-SUBSTRUCTURE STR (LENGTH STR) SCOPE-NODE START-START SCOPE-END)) (T (IL:* IL:|;;| "check each node from the start subtree up and to the right in the scope subtree. We carefully resume the recursion that would have happened if we had started from the root of the subtree. This means checking remaining structure in super-nodes on our way from the start node back up the subtree.") (DO ((NODE START-NODE SUPER-NODE) (SUPER-NODE (IL:FETCH SUPER-NODE IL:OF START-NODE) (IL:FETCH SUPER-NODE IL:OF NODE)) (NODE-INDEX (IL:FETCH SUB-NODE-INDEX IL:OF START-NODE) (IL:FETCH SUB-NODE-INDEX IL:OF NODE)) (CONTINUATION? NIL T) (START START-START NODE-INDEX) (END NIL (AND (EQ NODE SCOPE-NODE) SCOPE-END)) (STRLEN (LENGTH STR)) MATCH) ((OR (NULL NODE) (SETF MATCH (FIND-NODE-SUBSTRUCTURE STR STRLEN NODE START END CONTINUATION?)) (EQ NODE SCOPE-NODE)) MATCH))))))) (DEFUN FIND-SUBSTRUCTURE-BACKWARDS (STR SCOPE &OPTIONAL END) (IL:* IL:|;;;| "Like find-substructure but searches in reverse linearization order.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (MULTIPLE-VALUE-BIND (END-NODE END-START END-END) (DECOMPOSE-PSEUDO-SELECTION END) (COND ((NULL END-NODE) (IL:* IL:|;;| "just check the entire scope") (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR) SCOPE-NODE SCOPE-START SCOPE-END)) ((EQ END-NODE SCOPE-NODE) (IL:* IL:|;;| "just check an initial subtree of the scope") (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR (LENGTH STR) SCOPE-NODE SCOPE-START END-END)) (T (IL:* IL:|;;| "check each node in the initial subtree of scope terminated by the end subtree. We carefully resume the recursion that would have happened if we had started from the root of the scope subtree. This means checking remaining structure in super-nodes on our way from the end node back up the subtree.") (DO ((NODE END-NODE SUPER-NODE) (SUPER-NODE (IL:FETCH SUPER-NODE IL:OF END-NODE) (IL:FETCH SUPER-NODE IL:OF NODE)) (NODE-INDEX (IL:FETCH SUB-NODE-INDEX IL:OF END-NODE) (IL:FETCH SUB-NODE-INDEX IL:OF NODE)) (CONTINUATION? NIL T) (END END-END NODE-INDEX) (START NIL (AND (EQ NODE SCOPE-NODE) SCOPE-START)) (STRLEN (LENGTH STR)) MATCH) ((OR (NULL NODE) (SETF MATCH (FIND-NODE-SUBSTRUCTURE-BACKWARDS STR STRLEN NODE START END CONTINUATION?)) (EQ NODE SCOPE-NODE)) MATCH))))))) (DEFUN GET-USER-STRING (CONTEXT PROMPT DEFAULT) (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT))) (IL:TERPRI PROMPTWINDOW) (IL:TTYINPROMPTFORWORD PROMPT DEFAULT NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X))))) (DEFUN SEARCH-OBJ (CONTEXT &OPTIONAL SEARCH-STRING WRAP?) (IL:* IL:|;;;| "Search for the the structure(s) in the string SEARCH-OBJ and display them. The search starts just after the current point or selection, if any.") (MULTIPLE-VALUE-BIND (STR STRLEN) (STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING (GET-USER-STRING CONTEXT "Find: " (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) " -- Invalid structure.") (RETURN-FROM SEARCH-OBJ)) ((= STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "-- aborted.") (RETURN-FROM SEARCH-OBJ))) (IL:* IL:|;;| "update the remembered defaults") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE SEARCH-STRING)) (IL:* IL:|;;| "figure out where to search and where to start") (LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (START (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (POINT-TYPE (IL:|fetch| POINT-TYPE IL:|of| POINT)) (POINT-NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) (POINT-INDEX (IL:|fetch| POINT-INDEX IL:|of| POINT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SELECT-TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION)) (SELECT-NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (SELECT-START (IL:|fetch| SELECT-START IL:|of| SELECTION))) (COND ((TYPEP POINT-NODE 'EDIT-NODE) (IF (EQ POINT-TYPE 'STRUCTURE) (NEXT-NODE POINT-NODE POINT-INDEX) (NEXT-NODE POINT-NODE T))) ((TYPEP SELECT-NODE 'EDIT-NODE) (IF (AND (EQ SELECT-TYPE 'STRUCTURE) SELECT-START) (LIST SELECT-NODE (1+ SELECT-START)) (NEXT-NODE SELECT-NODE T))) (T SCOPE))))) (UNLESS (OR WRAP? START) (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap") (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%At end; no more structure to search.") (RETURN-FROM SEARCH-OBJ)) (IL:* IL:|;;| "do the search") (IF (> STRLEN 1) (IL:* IL:|;;| "substructure search") (FIND-AND-DISPLAY-SUBSTRUCTURE CONTEXT STR SCOPE START WRAP?) (IL:* IL:|;;| "structure search") (FIND-AND-DISPLAY-STRUCTURE CONTEXT (FIRST STR) SCOPE START WRAP?))))) (DEFUN SEARCH-OBJ-BACKWARDS (CONTEXT &OPTIONAL SEARCH-STRING WRAP?) (IL:* IL:|;;;| "Like search-obj but searches backwards.") (MULTIPLE-VALUE-BIND (STR STRLEN) (STRUCTURE-FROM-STRING (OR SEARCH-STRING (SETF SEARCH-STRING (GET-USER-STRING CONTEXT "Find: " (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) " -- Invalid structure.") (RETURN-FROM SEARCH-OBJ-BACKWARDS)) ((= STRLEN 0) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "-- aborted.") (RETURN-FROM SEARCH-OBJ-BACKWARDS))) (IL:* IL:|;;| "update the remembered defaults") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE SEARCH-STRING)) (IL:* IL:|;;| "figure out where to search and where to start") (LET* ((SCOPE (SUBNODE 1 (IL:FETCH ROOT IL:OF CONTEXT))) (END (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (POINT-TYPE (IL:|fetch| POINT-TYPE IL:|of| POINT)) (POINT-NODE (IL:|fetch| POINT-NODE IL:|of| POINT)) (POINT-INDEX (IL:|fetch| POINT-INDEX IL:|of| POINT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SELECT-TYPE (IL:FETCH SELECT-TYPE IL:OF SELECTION)) (SELECT-NODE (IL:|fetch| SELECT-NODE IL:|of| SELECTION)) (SELECT-END (OR (IL:|fetch| SELECT-END IL:|of| SELECTION) (IL:|fetch| SELECT-START IL:|of| SELECTION)))) (COND ((TYPEP POINT-NODE 'EDIT-NODE) (IF (EQ POINT-TYPE 'STRUCTURE) (PREV-NODE POINT-NODE (1+ POINT-INDEX)) (PREV-NODE POINT-NODE T))) ((TYPEP SELECT-NODE 'EDIT-NODE) (IF (EQ SELECT-TYPE 'STRUCTURE) (LIST SELECT-NODE (1- SELECT-END)) (PREV-NODE SELECT-NODE T))) (T SCOPE))))) (UNLESS (OR WRAP? END) (IL:* IL:|;;| "Nothing left to search, and we're not supposed to wrap") (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%At beginning; no more structure to search.") (RETURN-FROM SEARCH-OBJ-BACKWARDS)) (IL:* IL:|;;| "do the search") (IF (> STRLEN 1) (IL:* IL:|;;| "substructure search") (FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS CONTEXT STR SCOPE END WRAP?) (IL:* IL:|;;| "structure search") (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CONTEXT (FIRST STR) SCOPE END WRAP?))))) (DEFUN SUBSTITUTE-OBJ (CONTEXT &OPTIONAL CHARCODE OLDSTR NEWSTR REMOVE?) (IL:* IL:|;;;| "OLDSTR and NEWSTR are strings. In the scope of the selection, replace every occurence of structure matching OLDSTR by structure parsed from NEWSTR. If REMOVE? is specified, just remove structure matching OLD.") (IL:* IL:|;;;| "We preserve the selection as best we can. Point gets thrown away.") (CLOSE-OPEN-NODE CONTEXT) (LET* ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (SCOPE NIL) (TYPE (IF REMOVE? "delet" "substitut"))) (IL:* IL:\; "hack!!!") (UNLESS (AND (IL:|fetch| SELECT-NODE IL:|of| SELECTION) (EQ (IL:|fetch| SELECT-TYPE IL:|of| SELECTION) 'STRUCTURE)) (FORMAT PROMPTWINDOW "~%Please select a structure to ~Ae within." TYPE) (RETURN-FROM SUBSTITUTE-OBJ T)) (SETQ SCOPE (PSEUDO-SELECTION-FROM-SELECTION SELECTION)) (MULTIPLE-VALUE-BIND (OLD OLDLEN) (STRUCTURE-FROM-STRING (OR OLDSTR (SETF OLDSTR (GET-USER-STRING CONTEXT (IF REMOVE? "Delete form: " "Replace old form: ") (OR (IL:|fetch| FIND-CANDIDATE IL:|of| CONTEXT) FIND-CANDIDATE))))) (COND ((< OLDLEN 0) (FORMAT PROMPTWINDOW " -- Invalid structure.") (RETURN-FROM SUBSTITUTE-OBJ T)) ((= OLDLEN 0) (FORMAT PROMPTWINDOW "-- aborted.") (RETURN-FROM SUBSTITUTE-OBJ T))) (MULTIPLE-VALUE-BIND (NEW NEWLEN) (IF REMOVE? (VALUES NIL 0) (STRUCTURE-FROM-STRING (OR NEWSTR (SETF NEWSTR (GET-USER-STRING CONTEXT "with new form: " (OR (IL:|fetch| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT) SUBSTITUTE-CANDIDATE)))))) (COND ((< NEWLEN 0) (FORMAT PROMPTWINDOW " -- Invalid structure.") (RETURN-FROM SUBSTITUTE-OBJ T)) ((AND (NOT REMOVE?) (= NEWLEN 0)) (FORMAT PROMPTWINDOW "-- aborted.") (RETURN-FROM SUBSTITUTE-OBJ T))) (IL:* IL:|;;| "update defaults ") (IL:|replace| FIND-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ FIND-CANDIDATE OLDSTR)) (UNLESS REMOVE? (IL:|replace| SUBSTITUTE-CANDIDATE IL:|of| CONTEXT IL:|with| (IL:SETQ SUBSTITUTE-CANDIDATE NEWSTR))) (IL:* IL:|;;| "do the substitution, report, and reselect.") (MULTIPLE-VALUE-BIND (NEW-SCOPE SUBCOUNT) (IF (> OLDLEN 1) (SUBSTITUTE-SUBSTRUCTURE CONTEXT OLD NEW SCOPE REMOVE?) (SUBSTITUTE-STRUCTURE CONTEXT (FIRST OLD) NEW SCOPE REMOVE?)) (CASE SUBCOUNT (0 (FORMAT PROMPTWINDOW "~%No ~Aions made." TYPE)) (1 (FORMAT PROMPTWINDOW "~%1 ~Aion made." TYPE)) (OTHERWISE (FORMAT PROMPTWINDOW "~%~A ~Aions made." SUBCOUNT TYPE))) (WHEN NEW-SCOPE (SELECT-PSEUDO-SEGMENT CONTEXT NEW-SCOPE)))))) T) (DEFUN SUBSTITUTE-STRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?) (IL:* IL:|;;;| "Inside SCOPE, replace any node with structure OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old nodes. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.") (IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (LET* ((ROOT (IL:FETCH ROOT IL:OF CONTEXT))(IL:* IL:\;  "substituting for root is special") (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (NEWLEN (IF REMOVE? 0 (LENGTH NEW))) (DELTA-LENGTH (- NEWLEN 1))) (START-UNDO-BLOCK) (DO* ((TARGET (FIND-STRUCTURE OLD SCOPE) (AND RESUME (FIND-STRUCTURE OLD SCOPE RESUME))) (TARGET-SUPER (AND TARGET (IL:FETCH SUPER-NODE IL:OF TARGET)) (AND TARGET (IL:FETCH SUPER-NODE IL:OF TARGET))) (TARGET-INDEX (AND TARGET (IL:FETCH SUB-NODE-INDEX IL:OF TARGET)) (AND TARGET (IL:FETCH SUB-NODE-INDEX IL:OF TARGET))) (RESUME (AND TARGET (NEXT-NODE TARGET T)) (AND TARGET (NEXT-NODE TARGET T))) (NEW-NODES (AND TARGET (NOT REMOVE?) (MAPCAR #'(LAMBDA (S) (PARSE-NEW S CONTEXT)) NEW)) (AND TARGET (NOT REMOVE?) (MAPCAR #'(LAMBDA (N) (COPY-NODE N CONTEXT)) NEW-NODES))) (NUMSUBS 0 (1+ NUMSUBS))) ((NULL TARGET) (END-UNDO-BLOCK) (SET-POINT-NOWHERE POINT) (SET-SELECTION-NOWHERE SELECTION) (VALUES SCOPE NUMSUBS)) (IL:* IL:|;;| "replace the target ") (SELECT-NODE CONTEXT TARGET) (COND (REMOVE? (COND ((EQ TARGET-SUPER ROOT) (IL:* IL:|;;| "\"delete\" the root structure by making it nil") (PENDING-DELETE POINT SELECTION) (INSERT-NULL-LIST CONTEXT)) (T (DELETE-SELECTION CONTEXT)))) (T (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)))) (IL:* IL:|;;| "fix up the scope, if necessary") (COND ((EQ TARGET SCOPE-NODE) (IL:* IL:|;;| "matched the scope, so we're done") (COND (REMOVE? (SETF SCOPE NIL)) ((= NEWLEN 1) (SETF SCOPE (SUBNODE TARGET-INDEX TARGET-SUPER))) (T (IL:* IL:|;;| "replacing the root structure with multiple nodes inserts a new level of list between the root (target-super) and the multiple nodes inserted. In this case, make the scope node be the new list node instead of the root itself.") (SETF SCOPE (LIST (IF (EQ TARGET-SUPER ROOT) (SUBNODE 1 ROOT) TARGET-SUPER) TARGET-INDEX (+ TARGET-INDEX (1- NEWLEN)))))) (SETF RESUME NIL)) ((AND SCOPE-START (EQ TARGET-SUPER SCOPE-NODE)) (IL:* IL:|;;| "matched a direct subnode of an extended scope") (WHEN (= TARGET-INDEX SCOPE-END) (SETF RESUME NIL)) (SETF (THIRD SCOPE) (INCF SCOPE-END DELTA-LENGTH)))))))) (DEFUN SUBSTITUTE-SUBSTRUCTURE (CONTEXT OLD NEW SCOPE &OPTIONAL REMOVE?) (IL:* IL:|;;;| "Inside SCOPE, replace any sequences of nodes whose structures sequentially match the elements of OLD by nodes gotten from parsing NEW. If REMOVE? is given, just delete the old sequences. Returns two values: the final scope after all substitutions are made, and the number of substitutions/deletions made.") (IL:* IL:|;;;| "The substitution is done as a single undoable operation, and the current selection and point are thrown away.") (MULTIPLE-VALUE-BIND (SCOPE-NODE SCOPE-START SCOPE-END) (DECOMPOSE-PSEUDO-SELECTION SCOPE) (LET* ((POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT)) (NEWLEN (IF REMOVE? 0 (LENGTH NEW))) (DELTA-LENGTH (- NEWLEN (LENGTH OLD)))) (START-UNDO-BLOCK) (DO* ((TARGET (FIND-SUBSTRUCTURE OLD SCOPE) (AND RESUME (FIND-SUBSTRUCTURE OLD SCOPE RESUME))) (NEW-NODES (AND TARGET (NOT REMOVE?) (MAPCAR #'(LAMBDA (S) (PARSE-NEW S CONTEXT)) NEW)) (AND TARGET (NOT REMOVE?) (MAPCAR #'(LAMBDA (N) (COPY-NODE N CONTEXT)) NEW-NODES))) (NUMSUBS 0 (1+ NUMSUBS)) RESUME) ((NULL TARGET) (END-UNDO-BLOCK) (SET-POINT-NOWHERE POINT) (SET-SELECTION-NOWHERE SELECTION) (VALUES SCOPE NUMSUBS)) (MULTIPLE-VALUE-BIND (TNODE TSTART TEND) (DECOMPOSE-PSEUDO-SELECTION TARGET) (IL:* IL:|;;| "replace the target ") (SELECT-PSEUDO-SEGMENT CONTEXT TARGET) (COND (REMOVE? (DELETE-SELECTION CONTEXT)) (T (PENDING-DELETE POINT SELECTION) (INSERT POINT CONTEXT (COPY-LIST NEW-NODES)))) (IL:* IL:|;;|  "fix up the scope, if necessary, and figure where to resume") (COND ((AND SCOPE-START (EQ TNODE SCOPE-NODE)) (IL:* IL:|;;| "matched direct subnodes of an extended scope") (IF (= TEND SCOPE-END) (SETF RESUME NIL) (SETF RESUME (LIST TNODE (+ TEND 1 DELTA-LENGTH)))) (SETF (THIRD SCOPE) (INCF SCOPE-END DELTA-LENGTH))) (T (SETF RESUME (LIST TNODE (+ TEND 1)))))))))) (DEFUN STRUCTURE-FROM-SELECTION (SELECTION) (IL:* IL:|;;;| "selection must be a structure selection. Return the structure encompassed by selection, which if the selection is a node is the structure of that node, and if the selection is a segment a list of the structures of the nodes in that segment.") (LET* ((NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (END (OR (IL:FETCH SELECT-END IL:OF SELECTION) START))) (COND (START (LET ((SUBNODES (IL:FETCH SUB-NODES IL:OF NODE))) (WHEN (<= START END (CAR SUBNODES)) (SETF SUBNODES (NTHCDR START SUBNODES)) (DO ((STRUCTURE NIL) (INDEX START (1+ INDEX))) ((> INDEX END) (NREVERSE STRUCTURE)) (PUSH (IL:FETCH STRUCTURE IL:OF (POP SUBNODES)) STRUCTURE))))) (T (IL:FETCH STRUCTURE IL:OF NODE))))) (DEFUN STRUCTURE-FROM-STRING (STR) (IL:* IL:|;;;| "return all the structures that can be read from string as a list. return a second value saying how many structures there were. If an error is encountered, a second value of -1 is returned. ") (COND ((NULL STR) (VALUES NIL 0)) ((STRINGP STR) (WITH-INPUT-FROM-STRING (S STR) (DO ((RESULTS NIL) (EOF (LIST 'EOF)) (COUNT 0 (1+ COUNT)) VAL) ((NULL (IL:NLSETQ (SETF VAL (READ S NIL EOF)))) (VALUES (NREVERSE RESULTS) -1)) (IF (EQ VAL EOF) (RETURN (VALUES (NREVERSE RESULTS) COUNT)) (PUSH VAL RESULTS))))) (T (VALUES NIL -1)))) (DEFUN COMMENT-OUT-SELECTION (CONTEXT CHARCODE) (IL:* IL:|;;;| "given a sequence of whole structure selections, build a 5 level comment node and replace the nodes with the comment.") (LET* ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT)) (NODE (IL:FETCH SELECT-NODE IL:OF SELECTION)) (START (IL:FETCH SELECT-START IL:OF SELECTION)) (STR (COND ((OR (NULL NODE) (NOT (EQ (IL:FETCH SELECT-TYPE IL:OF SELECTION) 'STRUCTURE))) (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%Select whole structure or structures to comment out.") NIL) (START (WITH-OUTPUT-TO-STRING (S) (IL:BIND BLANK-BEFORE IL:FOR I IL:FROM START IL:TO (OR (IL:FETCH SELECT-END IL:OF SELECTION) START) IL:AS X IL:ON (CDR (IL:NTH (IL:FETCH SUB-NODES IL:OF NODE) START)) IL:DO (IF BLANK-BEFORE (WRITE-CHAR #\Space S) (SETQ BLANK-BEFORE T)) (PRIN1 (IL:FETCH STRUCTURE IL:OF (CAR X)) S)))) (T (FORMAT NIL "~S" (IL:FETCH STRUCTURE IL:OF NODE)))))) (WHEN STR (LET ((NEW-NODE (PARSE-NEW (LIST 'IL:* 'IL:\| STR) CONTEXT))) (START-UNDO-BLOCK) (DELETE-SELECTION CONTEXT) (INSERT POINT CONTEXT NEW-NODE) (SELECT-NODE CONTEXT NEW-NODE) (IL:REPLACE PENDING-DELETE? IL:OF SELECTION IL:WITH NIL) (END-UNDO-BLOCK)))) T) (IL:DEFINEQ (add-menu (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (let ((window (il:fetch display-window il:of context)) (promptwindow (get-prompt-window context)) menu) (cond ((il:windowprop window (quote menu)) (il:|printout| promptwindow t "This SEdit already has a menu.")) (t (il:|printout| promptwindow t "Creating menu...") (il:setq menu (get-menu context)) (il:attachwindow menu window nil nil (quote il:localclose)) (il:windowprop menu (quote il:rejectmaincoms) (quote (il:shapew))) (il:windowaddprop window (quote il:reshapefn) (quote il:repositionattachedwindows)) (il:windowprop window (quote menu) menu) (il:terpri promptwindow)))) t) ) (backspace (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (il:* il:|;;;| "implements the backspace key. if there's a caret, find the appropriate method for the node it's in. the type methods must take care of any selection as appropriate. If there's a pending delete selection, consider backspace an undefined operation and punt, unless it's a quoted gap, let quote deal with it.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-node node) (funcall (il:fetch back-space il:of (il:fetch node-type il:of node)) node context (il:fetch point-index il:of point) (il:fetch point-string il:of point))) (node (let* ((selection node)) (when (and (il:setq node (il:fetch select-node il:of selection)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of (il:fetch super-node il:of node)))) (backspace-quote (il:fetch super-node il:of node) context t)))))) t) ) (CHANGE-PACKAGE (IL:LAMBDA (CONTEXT CHARCODE NEW-PACKAGE NEW-PACKAGE-NAME) (IL:* IL:\; "Edited 5-Dec-90 14:19 by woz") (IL:* IL:|;;;| "new.package and new.package.name will be set if coming from the menu. the menu selectedfn already checked valid package. otherwise coming from the keyboard, and need to prompt.") (CLOSE-OPEN-NODE CONTEXT) (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) (WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT))) (WHEN (NULL NEW-PACKAGE) (IL:TERPRI PROMPTWINDOW) (IL:SETQ NEW-PACKAGE-NAME (IL:U-CASE (IL:TTYINPROMPTFORWORD "New package: " PACKAGE-CANDIDATE NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X))))) (IL:* IL:|;;| "if have input then look for package, and if found reset candidate to full package name (user could have typed it abbreviation) of new package.") (IF (IL:STRINGP NEW-PACKAGE-NAME) (IL:SETQ NEW-PACKAGE (FIND-PACKAGE NEW-PACKAGE-NAME))) (IF NEW-PACKAGE (IL:SETQ PACKAGE-CANDIDATE (IL:SETQ NEW-PACKAGE-NAME (PACKAGE-NAME NEW-PACKAGE))))) (COND ((EQ NEW-PACKAGE *PACKAGE*) (FORMAT PROMPTWINDOW "~%Already editing in package ~A." NEW-PACKAGE-NAME)) (NEW-PACKAGE (IL:SETQ *PACKAGE* NEW-PACKAGE) (SAVE-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT)) (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T) (WHEN (IL:WINDOWPROP WINDOW 'MENU) (IL:FM.CHANGELABEL 'PACKAGE-NAME-ITEM NEW-PACKAGE-NAME (IL:WINDOWPROP WINDOW 'MENU))) (FORMAT PROMPTWINDOW "~%Now editing in package ~A" NEW-PACKAGE-NAME) (IF (AND (NOT (EQ NEW-PACKAGE (FIND-PACKAGE "INTERLISP"))) (NOT (EQ NEW-PACKAGE (FIND-PACKAGE "LISP"))) (NOT (MEMBER (FIND-PACKAGE "LISP") (PACKAGE-USE-LIST NEW-PACKAGE))) (NOT (MEMBER (FIND-PACKAGE "INTERLISP") (PACKAGE-USE-LIST NEW-PACKAGE)))) (FORMAT PROMPTWINDOW " (which does not use package LISP).") (FORMAT PROMPTWINDOW "."))) (NEW-PACKAGE-NAME (IL:|printout| PROMPTWINDOW T "No such package: " NEW-PACKAGE-NAME)) (T (IL:|printout| PROMPTWINDOW "...aborted")))) T)) (CHANGE-PRINTBASE (IL:LAMBDA (CONTEXT CHARCODE NEW-PRINTBASE) (IL:* IL:\; "Edited 5-Dec-90 14:18 by woz") (IL:* IL:|;;;| "new.printbase will be set (and valid) if coming from the menu. otherwise, prompt.") (CLOSE-OPEN-NODE CONTEXT) (LET ((PROMPTWINDOW (GET-PROMPT-WINDOW CONTEXT)) NEW-PRINTBASE-STRING) (WHEN (NULL NEW-PRINTBASE) (IL:TERPRI PROMPTWINDOW) (IL:SETQ NEW-PRINTBASE-STRING (IL:TTYINPROMPTFORWORD "New print-base: " PRINTBASE-CANDIDATE NIL PROMPTWINDOW NIL NIL (IL:CHARCODE (IL:CR ^X)))) (OR (AND (IL:STRINGP NEW-PRINTBASE-STRING) (IL:SETQ NEW-PRINTBASE (IL:FIXP (CAR (IL:NLSETQ (IL:READ (IL:OPENSTRINGSTREAM NEW-PRINTBASE-STRING 'IL:INPUT)))))) (IL:IGREATERP NEW-PRINTBASE 1) (IL:ILEQ NEW-PRINTBASE 36) (IL:SETQ PRINTBASE-CANDIDATE NEW-PRINTBASE-STRING)) (IL:SETQ NEW-PRINTBASE NIL))) (COND (NEW-PRINTBASE (IL:SETQ *PRINT-BASE* NEW-PRINTBASE) (IL:SETQ *PRINT-RADIX* (IL:NEQ *PRINT-BASE* 10)) (SAVE-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT)) (VERIFY-STRUCTURE CONTEXT NIL NIL NIL T) (WHEN (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT) 'MENU) (LET ((*PRINT-BASE* 10)) (IL:* IL:\;  "make display be in base 10") (IL:FM.CHANGESTATE 'PRINTBASE-VALUE-ITEM NEW-PRINTBASE (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT) 'MENU))))) (T (IL:|printout| PROMPTWINDOW T "Illegal print-base: " NEW-PRINTBASE-STRING)))) T)) (change-quote (il:lambda (quote-node context quote-type) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (rplaca (il:fetch structure il:of quote-node) (quote-wrapper quote-type)) (il:replace unassigned il:of quote-node il:with (il:listget (il:fetch quote-string il:of (il:fetch environment il:of context)) quote-type)) (note-change quote-node context)) ) (convert-comment (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (number-of-comments 0) select-end) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:* il:\; "there is a selection to substitute within") (cond (start (il:setq node (subnode start node)) (il:setq select-end (or (il:fetch select-end il:of selection) start))) (t (il:setq select-end (il:fetch sub-node-index il:of node)))) (start-undo-block) (il:bind (next-node il:_ node) (depth il:_ (il:fetch depth il:of node)) new-node il:while (il:setq node (find-comment next-node context depth select-end)) il:do (il:* il:|;;| "move past it so we're not pointing to a dead node after the substitution") (il:setq next-node (next-node node t)) (when (not (il:fmemb (cadr (il:fetch structure il:of node)) comment-markers)) (il:* il:|;;| "this is an old comment. convert it") (il:setq new-node (parse-new (convert-comment-structure (il:fetch structure il:of node)) context)) (replace-node context node new-node) (il:add number-of-comments 1)) (il:* il:|;;| "and continue the search")) (end-undo-block) (il:|printout| promptwindow t (if (eq 0 number-of-comments) "No" number-of-comments) (if (eq number-of-comments 1) " comment converted." " comments converted.")) (il:* il:|;;| "finally reset the point ") (when (not (eq 0 number-of-comments)) (set-point-nowhere point) (il:replace pending-delete? il:of selection il:with nil))) (t (il:|printout| promptwindow t "Select structure to convert comments within.")))) t) ) (convert-comment-structure (il:lambda (expr) (il:* il:\; "Edited 17-Jul-87 09:48 by DCB") (let (2-stars comtail comchar) (cond ((and (il:eqmemb (car expr) il:commentflg) (il:listp (cdr expr)) (not (il:fmemb (cadr expr) (quote (il:e il:declarations\: il:clisp\:)))) (il:listp (il:setq comtail (if (il:setq 2-stars (il:eqmemb (cadr expr) il:commentflg)) (cddr expr) (cdr expr))))) (il:setq comchar (or (car (il:listp il:commentflg)) il:commentflg)) (cond ((and (il:nlistp (cdr comtail)) (il:stringp (car comtail))) (il:* il:\; "already stringified. now semicolonize") (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)) ((and (il:nlistp (cddr comtail)) (il:stringp (cadr comtail))) (il:* il:\; "could be an edit date") expr) (t (il:* il:|;;| "COMTAIL is where the comment starts, and this is not a funny evaluated comment.") (il:setq comtail (list (il:concatlist (convert-comment-tail comtail (cons))))) (cond (2-stars (il:push comtail level-3-comment)) ((il:igeq (il:nchars (car comtail)) convert-upgrade) (il:push comtail level-2-comment)) (t (il:push comtail level-1-comment))) (cons comchar comtail)))) (t (il:* il:\; "Not convertible") expr)))) ) (convert-comment-tail (il:lambda (tail stream) (il:* il:\; "Edited 17-Jul-87 09:49 by DCB") (il:* il:|;;;| "to remove the dependency on WITH-OUTPUT-TO-STRING, which probably isn't very efficient and isn't available in koto anyway, we instead just accumulate a list of strings, and concatlist them at the end. STREAM should be a TCONC pointer") (il:while tail il:bind il:x nspaces il:do (il:setq nspaces 1) (cond ((il:nlistp tail) (il:* il:\; "Dotted tail of some super list") (il:tconc stream " . ") (il:setq il:x tail) (il:setq tail nil)) (t (il:setq il:x (car tail)) (il:setq tail (cdr tail)))) (cond ((il:stringp il:x) (il:* il:\; "Turn quote marks into single quotes") (il:lconc stream (list "'" il:x "'"))) ((il:listp il:x) (il:tconc stream "(") (cond ((eq (car il:x) (quote -)) (il:* il:\; "Suppress line break that would occur here: MAKE IT A BIG DASH") (il:tconc stream (if (cdr il:x) "--- " "---")) (il:pop il:x))) (convert-comment-tail il:x stream) (il:tconc stream ")") (il:selectq (car (il:listp tail)) ((il:\. il:\, il:\; il:?) (il:setq nspaces 0)) nil)) ((eq il:x (quote -)) (il:* il:\; "old style \"force line break\": MAKE IT A BIG DASH") (il:tconc stream "---")) (t (il:tconc stream il:x) (il:selcharq (il:nthcharcode il:x -1) ((il:\. il:\; il:?) (il:setq nspaces 2)) nil))) (cond ((and (il:neq nspaces 0) tail) (il:tconc stream (if (eq nspaces 1) " " " "))))) (car stream)) ) (create-command-table (il:lambda (description) (il:* il:\; "Edited 13-Jun-88 19:02 by Snow") (il:* il:|;;;| "each entry in the COMMAND-TABLE-SPEC should be of the form: ( +) where is an atom function name or a list whose car is the function name and the rest are the extra arguments (beyond context and charcode), is a list of strings for the name, key-name, and help-string, is T if the caret should be normalized after this command, and + is one or more key specifier which can be passed to charcode (if non-list) or whose car is a termtable syntax (if a list).") (let ((table (make-hash-table :size 95 :rehash-size 5)) (menu-items nil) (menu-left nil) (menu-right nil) fn entry) (il:|for| command il:|in| description il:|do| (il:* il:|;;| "get fn for this command. The first thing in COMMAND is either an atom (a simple function name), or a list of the form ( *). Make a \"command form\" for sedit of the form ( *)") (setq fn (if (consp (setq entry (first command))) (list* (first entry) (third command) (rest entry)) (list entry (third command)))) (il:* il:|;;| "check for help menu entry: save left and right columns for tabulating later, and collect the menu items, without the label, but with the selectedfn and the help string.") (when (il:setq entry (second command)) (push (first entry) menu-left) (push (second entry) menu-right) (push (list (il:kwote fn) (third entry)) menu-items)) (il:* il:|;;| "for each of the keys for this command, make a table entry. if key is a list, use the symbol in it to key on (for syntax and attached menu entries), else treat it as a charcode spec.") (il:|for| key il:|in| (cdddr command) il:|do| (setf (gethash (if (il:listp key) (car key) (charcode key)) table) fn))) (il:* il:|;;| "return list of command table and help menu items") (list table (list menu-items menu-left menu-right)))) ) (default-edit-fn (il:lambda (obj options) (il:* il:\; "Edited 5-Jul-88 15:12 by woz") (ed obj (list* :display :dontwait options))) ) (delete-selection (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (il:* il:|;;| "delete the currently selected nodes, and set the caret point to where they were. ") (let ((selection (il:fetch selection il:of context))) (and (il:fetch select-node il:of selection) (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) (il:fetch caret-point il:of context) (il:fetch select-string il:of selection))) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (set-selection-nowhere selection))) t) ) (delete-word (il:lambda (context) (il:* il:\; "Edited 24-Nov-87 10:02 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (selection (il:fetch selection il:of context)) (node (il:fetch point-node il:of point)) (end (il:fetch point-index il:of point)) (string (il:fetch point-string il:of point)) start) (il:* il:|;;| "don't do anything if there's no point or a pending delete selection.") (when (and node (or (not (il:fetch select-node il:of selection)) (not (il:fetch pending-delete? il:of selection)))) (il:selectq (il:fetch point-type il:of point) (atom (delete-nodes node context 1 end point string)) (esc-atom (delete-nodes node context 1 end point string)) (string (cond ((eq (il:fetch node-type il:of node) type-comment) (map-comment-index context node end) (cond ((il:igreaterp end 0) (delete-nodes node context (il:idifference (il:add1 end) (il:fetch \\x il:of context)) end point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) (t (il:setq start end) (cond ((il:igreaterp start 0) (il:* il:\; "backup over preceding whitespace") (il:while (and (il:neq start 1) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (il:* il:\; "backup over preceding word") (il:until (or (eq start 0) (il:fmemb (il:nthcharcode string start) word-delim-chars)) il:do (il:setq start (il:sub1 start))) (delete-nodes node context (il:add1 start) end point string)) ((eq 0 (il:nchars string)) (delete-nodes node context nil nil point string)))))) (structure (cond ((il:igreaterp end 0) (delete-nodes node context end nil point string)) ((null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes node context nil nil point string)))) nil) (when (not (and (il:fetch select-node il:of selection) (eq type-gap (il:fetch node-type il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "cancel the selection unless its pending delete (ctrl-w doesn't do anything) or its a gap, which could have been created by the deletion.") (set-selection-nowhere selection)))) t) ) (do-mutation (il:lambda (context node mutator) (il:* il:\; "Edited 7-Jul-87 09:27 by DCB") (il:* il:|;;;| "this guy actually applies the mutation and replaces the sedit structure. should return T if okay, and NIL if error occured durng mutation.") (let ((result (il:nlsetq (funcall mutator (il:fetch structure il:of node))))) (when result (il:* il:|;;| "assume result is not equal to node's Structure. otherwise, why would mutate have been called?") (replace-node context node (parse-new (car result) context)) (il:* il:\; "return T") t))) ) (edit-selection (il:lambda (context charcode options) (il:* il:\; "Edited 5-Jul-88 15:53 by woz") (let ((structure (get-selected-structure context))) (cond (structure (cond ((funcall *edit-fn* structure options) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context))))) (t (format (get-prompt-window context) "~%Select name of object to edit.")))) t) ) (eval-selection (il:lambda (context) (il:* il:\; "Edited 29-Oct-87 15:14 by drc:") (il:* il:|;;;| "evaluate the selected structure in the appropriate process, which should be stored in the EvalInProcess field of the context. If this field is NIL, then the process went away unexpectedly, so find an exec to eval in. This is dangerous: FIND.PROCESS 'EXEC IS NOT GUARANTEED!") (let* ((structure (get-selected-structure context)) (structure-copy (copy-tree structure)) (process (il:fetch eval-in-process il:of context)) (promptwindow (get-prompt-window context)) (value (quote il:nobind))) (il:terpri promptwindow) (when (not (il:processp process)) (il:setq process (il:replace eval-in-process il:of context il:with (il:find.process (quote il:mouse))))) (cond ((null structure) (il:|printout| promptwindow t "Invalid selection for evaluation.")) ((il:listp structure) (il:setq value (il:resetform (il:tty.process process) (il:process.eval process (il:bquote (il:ersetq (il:\\\, structure))) t))) (unless (equal structure structure-copy) (il:* il:|;;| "eval (DWIM) changed the structure") (replace-node context (il:fetch select-node il:of (il:fetch selection il:of context)) (parse-new structure context))) (if value (il:setq value (car value)) (il:setq value (quote il:nobind)))) ((il:numberp structure) (il:* il:|;;| "make numbers eval to themselves, since PROCESS.EVALV won't work") (il:setq value structure)) ((il:atom structure) (il:setq value (il:process.evalv process structure)) (when (eq value (quote il:nobind)) (il:|printout| promptwindow t "Unbound atom: " il:|.P2| structure))) (t (il:setq value structure))) (when (il:neq value (quote il:nobind)) (cond ((or (il:atom value) (il:stringp value)) (il:|printout| promptwindow t "Result: " il:|.P2| value)) (t (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (inspect value))))) t) ) (expand (il:lambda (context charcode) (il:* il:\; "Edited 7-Jan-88 13:43 by DCB") (il:* il:|;;;| "Replace the current selection with its macro-expansion, if any.") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection))) (cond ((and node (eq (il:fetch select-type il:of selection) (quote structure)) (null (il:fetch select-start il:of selection))) (let ((structure (il:fetch structure il:of node)) expansion) (when (consp structure) (il:* il:|;;| "we have a whole list structure node selected. try to expand its definition") (il:|printout| promptwindow t "Looking for expansion...") (il:setq expansion (il:nlsetq (il:editgetd structure))) (cond ((null expansion) (il:|printout| promptwindow t "Error during macro expansion.")) ((not (equal (car expansion) structure)) (il:terpri promptwindow) (replace-node context node (parse-new (car expansion) context))) (t (il:|printout| promptwindow t "No expansion found.")))))) (t (il:|printout| promptwindow t "Can't expand this selection.")))) t) ) (extract-current-selection (il:lambda (context) (il:* il:\; "Edited 27-Jun-88 15:30 by woz") (close-open-node context) (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) subnodes set-selection?) (when (and (null node) (il:setq node (il:|fetch| point-node il:|of| point)) (eq (il:|fetch| point-type il:|of| point) (quote structure))) (il:* il:|;;| "when you've only got a structure point extract from the list pointed within") (set-selection-me selection context node)) (cond ((or (null node) (il:neq (il:|fetch| select-type il:|of| selection) (quote structure)) (il:|fetch| select-start il:|of| selection) (il:|fetch| select-end il:|of| selection)) (il:|printout| promptwindow t "Select structure to extract.")) ((eq 0 (car (il:|fetch| sub-nodes il:|of| node))) (il:* il:\; "nothing to extract") (il:|printout| promptwindow t "Nothing to extract.")) ((eq (il:|fetch| node-type il:|of| node) type-comment) (let ((start 0) (string (third (il:fetch structure il:of node))) structure new-structures) (cond ((il:nlsetq (loop (if (eq :sedit-read-end-flg (multiple-value-setq (structure start) (read-from-string string nil :sedit-read-end-flg :start start))) (return t) (push structure new-structures)))) (setq subnodes (mapcar (function (lambda (s) (parse-new s context))) (nreverse new-structures))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (pending-delete point selection) (insert point context subnodes)) (t (format promptwindow "~%Unreadable structure in comment. Can't Extract."))))) (t (il:|replace| point-node il:|of| point il:|with| selection) (il:|replace| point-type il:|of| point il:|with| (quote structure)) (il:setq subnodes (cdr (il:|fetch| sub-nodes il:|of| node))) (unless (cdr subnodes) (setq set-selection? (car subnodes))) (rplacd (il:|fetch| sub-nodes il:|of| node) nil) (start-undo-block) (undo-by undo-extract node subnodes) (il:* il:\; "replace with subnodes") (insert point context (il:copy subnodes)) (end-undo-block))) (when set-selection? (il:* il:|;;| "if only one subnode, leave it selected") (set-selection-me selection context set-selection?) (il:|replace| pending-delete? il:|of| selection il:|with| nil))) (il:* il:|;;| "must return non-NIL if command executed") t) ) (find-comment (il:lambda (node context min-depth last-subnode) (il:* il:\; "Edited 3-Dec-87 12:54 by DCB") (il:* il:|;;;| "search starting with NODE for a node whose structure begins with a comment char . move selection and point accordingly. return the node found, else NIL") (when node (il:bind (commentchar il:_ (if (il:listp il:commentflg) (car il:commentflg) il:commentflg)) il:until (or (null node) (il:ilessp (il:fetch depth il:of node) min-depth) (and (eq (il:fetch depth il:of node) min-depth) (il:igreaterp (il:fetch sub-node-index il:of node) last-subnode))) il:do (when (eq commentchar (car (il:fetch structure il:of node))) (return node)) (il:setq node (next-node node))))) ) (get-menu (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:28 by DCB") (let (menu) (cond ((il:setq menu (il:pop menus)) (il:fm.resetmenu menu)) (t (il:setq menu (il:freemenu menu-description "SEdit Command Menu")) (il:windowaddprop menu (quote il:closefn) (quote menu-closefn)) (il:windowprop menu (quote il:fm.dontreshape) t))) (menu-init-state menu context) menu)) ) (edit-help (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (close-open-node context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (and (il:type? edit-node node) (il:litatom (il:fetch structure il:of node)) (eq (il:fetch point-index point) (il:nchars (il:fetch structure il:of node)))) (il:* il:\; "if at end of this node, change to structure point.") (insert point context nil))) (let* ((fname (selected-fn-name context)) (promptwindow (get-prompt-window context)) args) (if fname (if (il:setq args (il:nlsetq (il:smartarglist fname t))) (cond ((il:ileq (il:stringwidth (il:setq args (cons fname (car args)))) (il:windowprop promptwindow (quote il:width))) (il:* il:\; "will fit in attached window") (il:|printout| promptwindow t args)) (t (il:* il:\; "put in main promptwindow") (il:terpri promptwindow) (il:|printout| il:promptwindow t args))) (il:|printout| promptwindow t "Arguments not available for " fname)) (il:|printout| promptwindow t "Select function you want the arguments for."))) t) ) (helpmenu (il:lambda (context) (il:* il:\; "Edited 24-May-88 14:20 by woz") (let ((menu (il:fetch help-menu il:of (il:fetch environment il:of context))) (promptwindow (get-prompt-window context)) command) (when (listp menu) (format promptwindow "~%Creating menu, please wait...") (il:* il:|;;| "build the popup menu info. the lists of menu-items, menu-left strings, and menu-right strings are in the MENU list. take it apart, then build the menu. this information was compiled in create-command-table, but the menu gets built when first used (so the font ends up right if the user changed it).") (let* ((font (il:fontcreate il:menufont)) (menu-items (first menu)) (equalized-menu-left (equalize-string-widths (second menu) font)) (menu-right (third menu)) itemwidth items) (il:* il:|;;| "figure out the width of the left column, including the tab, then set the menu width. Do this by finding the first tab stop after the shortest stringwidth in EQUALIZED-MENU-LEFT. We know that the widths of each equalized string are within one space width of each other, and since a tab is bigger than a space, we know that this tab stop is the first after all of the strings, allowing tabulation.") (il:* il:|;;| "There is a strange feature of the menu code that starts printing lables at 1 instead of zero, which changes the relative tab stop position. This shift can cause a tab stop to fall in between the shortest and longest equalized strings. So we have to see if our chosen tab stop is within one pixel of the longest string, and if so, pad the strings with an extra space to jump them all past that tab stop.") (do* ((left-width (minimum-string-width equalized-menu-left font)) (tab-width (il:stringwidth " " font)) (tab-column tab-width (+ tab-column tab-width))) ((> tab-column left-width) (il:* il:|;;| "check for the stupid menu case:") (when (= (1- tab-column) (maximum-string-width equalized-menu-left font)) (setq equalized-menu-left (equalize-string-widths equalized-menu-left font nil tab-column)) (incf tab-column tab-width)) (setq itemwidth (+ tab-column (maximum-string-width menu-right font)))) nil) (il:* il:|;;| "construct the menu strings and the menu items.") (do ((left equalized-menu-left (rest left)) (right menu-right (rest right)) (item menu-items (rest item))) ((null item) (setq items (nreverse menu-items))) (push (concatenate (quote string) (first left) (string #\Tab) (first right)) (first item))) (il:replace help-menu il:of (il:fetch environment il:of context) il:with (setq menu (il:create il:menu il:items il:_ items il:itemwidth il:_ itemwidth il:changeoffsetflg il:_ (quote il:y) il:menuoffset il:_ (cons -1 0) il:title il:_ "Commands"))))) (when (setq command (il:menu menu)) (terpri promptwindow) (awake-command-process context command)))) ) (input-dot (il:lambda (context charcode) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (il:* il:|;;;| "handle input of a dot. cases: ") (il:* il:|;;;| "(1) structure selection; might be a quoted gap to be ugraded, otherwise just a node to delete in a list to be dotted.") (il:* il:|;;;| "(2) structure point; in a list to be dotted.") (il:* il:|;;;| "(3) atom point; might be at the beginning of a quote to be ugraded, otherwise just insert the dot.") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (cond ((il:type? edit-selection node) (let ((selection node)) (il:* il:|;;| "if we're at a structure selection, this is interesting. otherwise, let the char handler input the dot. ") (when (eq (quote structure) (il:fetch select-type il:of selection)) (cond ((eq type-quote (il:fetch node-type il:of (if (il:fetch select-start il:of selection) (il:fetch select-node il:of selection) (il:fetch super-node il:of (il:fetch select-node il:of selection))))) (il:* il:|;;| "we're in a quote form. let the quote handler check for a comma-dot") (input-quote context charcode (quote comma-dot)) t) (t (il:* il:|;;| "just at a pending delete selection. delete it and try to dot the list.") (delete-nodes (il:fetch select-node il:of selection) context (il:fetch select-start il:of selection) (il:fetch select-end il:of selection) point) (dot-this-list context) t))))) ((and node (eq (quote structure) (il:fetch point-type il:of point))) (il:* il:|;;| "normal case of dot input at a structure point in a list") (dot-this-list context) t) ((and node (eq (quote atom) (il:fetch point-type il:of point)) (eq 0 (il:fetch point-index il:of point))) (il:* il:|;;| "at the beginning of an atom. check if it's a comma quote, otherwise, just input") (let ((super-node (il:fetch super-node il:of node))) (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're at the beginning of a COMMA quote atom that wants to be upgraded") (change-quote super-node context (quote comma-dot)) t)))))) ) (input-escape (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (il:* il:|;;;| "dynamically set this.char.escaped true, so that next time through the loop, it knows it's getting an escaped char") (il:setq this-char-escaped t)) ) (input-normal-char (il:lambda (context char) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (cond ((and (il:igreaterp char 255) (il:ilessp char 512)) (il:* il:|;;| "this is a meta-character that wasn't recognized as a command. don't insert it!") (il:|printout| (get-prompt-window context) t "Unknown command: Meta-" (il:character (il:idifference char 256)))) (t (let ((point (il:fetch (edit-context caret-point) il:of context)) (point-type (type-of-input context))) (il:setq char (il:character char)) (when (il:neq point-type (quote string)) (cond (this-char-escaped (il:* il:|;;| "prepend an escape character") (il:* il:\; "read table specific") (il:setq char (il:concat (il:character (escape-char)) char))) ((and (il:fetch (readtablep il:caseinsensitive) il:of *readtable*) (il:neq point-type (quote esc-atom))) (il:setq char (if (or (eq point-type (quote structure)) (eq *print-case* (quote :upcase))) (il:u-case char) (il:l-case char)))))) (il:selectq point-type (structure (il:* il:|;;| "first mark that we're starting an atom, because the reparser needs to know when inserting in a lambda arglist slot whether or not to reparse it as a list. THIS IS UGLY, but it works.") (il:replace atom-started il:of context il:with t) (insert point context char) (il:replace atom-started il:of context il:with (il:fetch point-node il:of point)) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context))) ((atom esc-atom) (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case. the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where char point) (set-selection-nowhere (il:fetch selection il:of context)))) (string (insert point context char)) (nil) (il:shouldnt "bad point type"))))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) ) (input-quote (il:lambda (context charcode quote-type) (il:* il:\; "Edited 19-Nov-87 15:28 by DCB") (il:selectq (type-of-input context) (structure (close-open-node context) (cond ((il:fmemb quote-type (quote (comma-at comma-dot))) (il:* il:|;;| "check if we're in a COMMA quote to be upgraded") (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection)) (super-node)) (when (and node (il:setq super-node (il:fetch super-node il:of node)) (eq type-gap (il:fetch node-type il:of node)) (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (il:* il:|;;| "we're in the middle of typing in a COMMA quote form that wants to be upgraded") (change-quote super-node context quote-type) t))) (t (insert-quoted-gap context charcode quote-type) t))) (atom (il:* il:|;;| "check if we're at the beginning of an atom to quote. otherwise, let the quote be inserted normally") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) (super-node (and (il:type? edit-node node) (il:fetch super-node il:of node)))) (cond ((and super-node (eq 0 (il:fetch point-index point))) (cond ((eq quote-type (quote comma-at)) (il:* il:|;;| "this is tricky. we got an @ at the beginning of an atom. if it's in a COMMA quote, then upgrade, otherwise insert the @ as part of the atom.") (when (and (eq type-quote (il:fetch node-type il:of super-node)) (eq (quote-wrapper (quote il:comma)) (car (il:fetch structure il:of super-node)))) (change-quote super-node context (quote comma-at)) t)) (t (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context charcode quote-type) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node) t))) ((and super-node (eq quote-type (quote quote)) (eq 1 (il:fetch point-index point)) (eq (il:charcode \#) (il:chcon1 (il:fetch point-string il:of point)))) (il:* il:|;;| "this is tricky. We are adding the ' part of #', so we want to function wrap the rest of this string (or gap it if it's empty).") (cond ((eq 1 (il:nchars (il:fetch point-string il:of point))) (il:* il:|;;| "close the node, get rid of it, and replace it with a quoted gap. Oh yeah, do this undoably by just closing and calling an undoable thing,") (close-open-node context) (set-selection-me (il:fetch selection il:of context) context node) (pending-delete point (il:fetch selection il:of context)) (insert-quoted-gap context nil (quote function)) t) (t (il:* il:|;;| "remove the #, close the node, wrap it with function, and put point at the first character. Oh yeah, do this undoably.") (start-undo-block) (replace-string node context 1 1 "" point (il:fetch point-string il:of point) (quote atom)) (set-selection-me (il:fetch selection il:of context) context node) (quote-current-selection context nil (quote function)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node nil nil nil (quote atom)) (end-undo-block) t)))))) nil)) ) (input-square-bracket (il:lambda (context charcode) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (when (il:neq (type-of-input context) (quote string)) (let ((promptwindow (get-prompt-window context))) (il:|printout| promptwindow t "SEdit can't handle square brackets. Ignoring rest of input.") (il:flashwindow promptwindow) (il:clearbuf t) t))) ) (input-stringdelim (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:35 by DCB") (cond ((eq (type-of-input context) (quote string)) (il:* il:|;;| "split or close this string") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point))) (when (il:type? edit-selection node) (il:setq node (il:fetch select-node il:of node))) (when (eq (il:fetch node-type il:of node) type-string) (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) t))) (t (il:* il:|;;| "insert a new string") (let ((new-string (il:allocstring 0)) (point (il:fetch (edit-context caret-point) il:of context))) (il:setq new-string (create-simple-node new-string (il:fetch environment il:of context) type-string new-string t (il:fetch default-font il:of (il:fetch environment il:of context)))) (insert point context new-string) (when (not (dead-node? new-string)) (il:replace point-node il:of point il:with new-string) (il:replace point-index il:of point il:with 0) (il:replace point-type il:of point il:with (quote string)) (il:replace point-string il:of point il:with (il:fetch structure il:of new-string)) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (il:replace atom-started il:of context il:with new-string) (il:replace atom-started-undo-pointer il:of context il:with (il:fetch undo-list il:of context)))) t))) ) (input-tokendelim (il:lambda (context charcode) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context))) (il:selectq (type-of-input context) (atom (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (structure (when (not (il:fetch pending-delete? il:of (il:fetch selection il:of context))) (il:* il:|;;| "this test so that delims don't do anything on pending delete gaps in particular, to avoid or wasting the gap. i don't think it will hurt the other cases.") (insert point context nil) (set-selection-nowhere (il:fetch (edit-context selection) il:of context)))) ((string esc-atom) (if (and (eq charcode (il:charcode il:cr)) (eq-point-type point type-comment)) (insert point context nil) (insert point context (il:character charcode))) (set-selection-nowhere (il:fetch (edit-context selection) il:of context))) (nil) (il:shouldnt "bad point type"))) t) ) (insert-multi-escape (il:lambda (context char) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (let ((point (il:fetch caret-point il:of context)) (type (type-of-input context)) node il:where) (cond ((eq type (quote structure)) (insert point context (il:allocstring 2 char)) (il:replace point-index il:of point il:with 1) (il:replace point-type il:of point il:with (quote esc-atom))) ((or (eq type (quote atom)) (eq type (quote esc-atom))) (if (il:type? edit-node (il:setq node (il:fetch point-node il:of point))) (if (and (eq type (quote esc-atom)) (eq (il:nthcharcode (il:fetch point-string il:of point) (il:add1 (il:fetch point-index il:of point))) char)) (il:add (il:fetch point-index il:of point) 1) (il:setq il:where point)) (il:setq node (il:fetch select-node il:of (il:setq il:where node)))) (when il:where (insert-string node context il:where (il:allocstring 2 char) point) (il:add (il:fetch point-index il:of point) -1)) (il:replace point-type il:of point il:with (if (eq (il:fetch point-type il:of point) (quote atom)) (quote esc-atom) (quote atom))) (set-selection-nowhere (il:fetch selection il:of context)) t)))) ) (insert-special-character (il:lambda (context char) (il:* il:\; "Edited 7-Jul-87 09:29 by DCB") (il:* il:|;;;| "insert a special character (e.g. the package delimiter) without escaping it") (let ((point (il:fetch caret-point il:of context)) (string (il:allocstring 1 char))) (il:selectq (type-of-input context) (atom (let ((node (il:fetch point-node il:of point)) il:where) (cond ((il:type? edit-node node) (il:setq il:where point)) (t (il:* il:|;;| "the pending-delete case. the PointNode actually points to a selection framing the material to be replaced") (il:setq node (il:fetch select-node il:of (il:setq il:where node))))) (insert-string node context il:where string point) (set-selection-nowhere (il:fetch selection il:of context)) t)) (structure (il:* il:|;;| "LET ((new.node (fetch PointNode of point))) (replace AtomStarted of context with new.node) (replace AtomStartedUndoPointer of context with (fetch UndoList of context)) (open.litatom context new.node string) (replace OpenNodeChanged? of context with T) (adjust.width new.node context (STRINGWIDTH string) (fetch Font of (CAR (fetch LinearForm of new.node)))) (replace PointIndex of point with 1) (replace PointString of point with string) T") (insert point context string) t) nil))) ) (inspect-selection (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 13:36 by DCB") (let ((structure (get-selected-structure context))) (cond (structure (set-selection-nowhere (il:fetch (edit-context selection) il:of context)) (set-point-nowhere (il:fetch (edit-context caret-point) il:of context)) (il:* il:|;;| "update context") (when (null (il:nlsetq (inspect structure))) (il:|printout| (get-prompt-window context) t "Inspection aborted."))) (t (il:|printout| (get-prompt-window context) t "Select object to inspect.")))) t) ) (join (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:36 by DCB") (let* ((promptwindow (get-prompt-window context)) (selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (comment-level 1) subnodes type new-structure new-node) (close-open-node context) (cond ((not (and node start end (il:neq start end) (eq (il:fetch select-type il:of selection) (quote structure)))) (il:|printout| promptwindow t "Select items to join.")) ((and (il:setq type (il:fetch name il:of (il:fetch node-type il:of (subnode start node)))) (il:fmemb type (il:constant (quote (quote unknown gap root dotlist))))) (il:|printout| promptwindow t "Can't join things of this type.")) (t (il:setq subnodes (il:fetch sub-nodes il:of node)) (pending-delete point selection) (start-undo-block) (il:selectq type ((litatom string) (il:* il:|;;| "for these types, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:collect (when (not (il:fmemb (il:fetch name il:of (il:fetch node-type il:of subnode)) (il:constant (quote (litatom string))))) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:fetch structure il:of subnode))) (when new-structure (cond ((il:numberp (car new-structure)) (il:|printout| promptwindow t "Can't join numbers.")) (t (il:setq new-node (parse-new (if (eq type (quote litatom)) (intern (il:concatlist new-structure) (symbol-package (car new-structure))) (il:concatlist new-structure)) context)) (insert point context new-node))))) (comment (il:* il:|;;| "for comments, each node must be of the same SEdit type") (il:setq new-structure (il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:join (when (il:neq (il:fetch name il:of (il:fetch node-type il:of subnode)) (quote comment)) (il:|printout| promptwindow t "Each item to join must be of the same type.") (return)) (il:setq comment-level (il:imax comment-level (il:fetch unassigned il:of subnode))) (cond ((eq index end) (cddr (il:fetch structure il:of subnode))) (t (il:* il:|;;| "add space between comments") (list (caddr (il:fetch structure il:of subnode)) " "))))) (when new-structure (il:setq new-structure (list (quote il:*) (car (il:nth comment-markers comment-level)) (il:apply* (quote il:concatlist) new-structure))) (il:setq new-node (parse-new new-structure context)) (insert point context new-node))) (progn (il:* il:|;;| "for the rest, the structures must all be listp's") (cond ((il:for index il:from start il:to end il:as subnode il:in (il:nth (cdr subnodes) start) il:thereis (not (il:listp (il:fetch structure il:of subnode)))) (il:|printout| promptwindow t "Each item to join must be of the same type.")) (t (il:setq new-node (subnode start node)) (set-point point context new-node (car (il:fetch sub-nodes il:of new-node)) t (car (last (il:fetch sub-nodes il:of new-node))) (quote structure)) (il:for index il:from (il:add1 start) il:to end il:as subnode il:in (il:nth (cdr subnodes) (il:add1 start)) il:do (il:setq new-structure (cdr (il:fetch sub-nodes il:of subnode))) (delete-nodes subnode context 1 (car (il:fetch sub-nodes il:of subnode))) (insert point context new-structure)) (delete-nodes node context (il:add1 start) end))))) (when new-node (set-selection-me selection context new-node) (il:replace pending-delete? il:of selection il:with nil) (set-point point context new-node nil t nil (quote structure))) (end-undo-block)))) t) ) (menu-closefn (il:lambda (w) (il:* il:\; "Edited 7-Jul-87 09:36 by DCB") (il:* il:|;;;| "must be called before menu is detached from sedit.") (il:push menus w) (il:windowprop (il:mainwindow w) (quote menu) nil)) ) (menu-find-selectedfn (il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:12 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((or (il:equal (il:fm.itemprop find-item (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:|;;| "need new stuff to find") (il:fm.edititem find-item window t)) (t (il:* il:|;;| "call find with an extra argument of the stuff to find") (menu-selectedfn item window buttons (quote find) (list (il:fm.itemprop find-item (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process))))))) ) (menu-init-state (il:lambda (menu context) (il:* il:\; "Edited 7-Jul-87 09:38 by DCB") (il:* il:|;;;| "initialize menu profile entries. will be called by either under command loop, or under building new window, either case under sedit's profile, so references to *print* variables are okay.") (let* ((package-name (package-name *package*)) (print-base *print-base*) (*print-base* 10)) (il:* il:|;;| "want to display *PRINT-BASE* in print base 10, so must cache and rebind it.") (il:fm.changestate (quote printbase-value-item) print-base menu) (il:fm.itemprop (il:fm.getitem (quote printbase-item) nil menu) (quote printbase) print-base) (il:fm.changelabel (quote package-name-item) package-name menu) (il:fm.itemprop (il:fm.getitem (quote package-item) nil menu) (quote package-name) package-name))) ) (menu-package-selectedfn (il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "check if the new package name is valid and if so initiate the package change by waking up the comand process to handle the command. otherwise error and reset the package name in the menu to the name of the current package, which is cached on this item.") (let* ((package-name-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (package-name (il:fm.itemprop package-name-item (quote il:label))) package) (cond ((or (il:equal package-name "") (eq (car buttons) (quote il:right))) (il:fm.edititem package-name-item window t)) ((il:setq package (find-package package-name)) (il:fm.itemprop item (quote package-name) package-name) (menu-selectedfn item window buttons (quote set-package) (list package package-name))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "No such package: " package-name) (il:fm.changelabel package-name-item (il:fm.itemprop item (quote package-name)) window))))) ) (menu-printbase-selectedfn (il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (il:* il:|;;;| "make sure there is a valid printbase value, and if so, change sedits printbase to it.") (let* ((printbase-value-item (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (print-base (il:fm.itemprop printbase-value-item (quote il:state)))) (cond ((or (null print-base) (eq (car buttons) (quote il:right))) (il:fm.edititem printbase-value-item window t)) ((and (il:igreaterp print-base 1) (il:ileq print-base 36)) (il:fm.itemprop item (quote printbase) print-base) (menu-selectedfn item window buttons (quote set-print-base) (list print-base))) (t (il:|printout| (il:getpromptwindow (il:mainwindow window)) t "Illegal print-base: " print-base) (il:fm.changestate printbase-value-item (il:fm.itemprop item (quote printbase)) window))))) ) (menu-selectedfn (il:lambda (item window buttons command extra-args) (il:* il:\; "Edited 17-Jul-87 10:13 by DCB") (let ((context (il:windowprop (il:mainwindow window) (quote edit-context)))) (awake-command-process context (il:append (lookup-command (or command (il:fm.itemprop item (quote il:id)) (il:fm.itemprop item (quote il:label))) (il:fetch command-table il:of (il:fetch environment il:of context))) extra-args)))) ) (menu-substitute-selectedfn (il:lambda (item window buttons) (il:* il:\; "Edited 17-Jul-87 09:57 by DCB") (let ((find-item (il:listget (il:fm.itemprop item (quote il:links)) (quote finditem))) (subitem (il:listget (il:fm.itemprop item (quote il:links)) (quote il:edit))) (context (il:windowprop (il:mainwindow window) (quote edit-context)))) (cond ((il:equal (il:fm.itemprop find-item (quote il:label)) "") (il:* il:\; "need new stuff to find") (il:fm.edititem find-item window t)) ((or (il:equal (il:fm.itemprop subitem (quote il:label)) "") (eq (car buttons) (quote il:right))) (il:* il:\; "need new stuff to substitute") (il:fm.edititem subitem window t)) (t (il:* il:\; "call substitute with all the stuff to substitute") (menu-selectedfn item window buttons (quote substitute) (list (il:fm.itemprop find-item (quote il:label)) (il:fm.itemprop subitem (quote il:label)))) (il:tty.process (il:windowprop (il:mainwindow window) (quote il:process))))))) ) (mutate (il:lambda (context) (il:* il:\; "Edited 11-Apr-88 15:58 by woz") (let* ((promptwindow (get-prompt-window context)) (selection (il:|fetch| selection il:|of| context)) (point (il:|fetch| caret-point il:|of| context)) (node (il:|fetch| select-node il:|of| selection)) mutator-string mutator result) (cond ((and node (eq (il:|fetch| select-type il:|of| selection) (quote structure)) (null (il:|fetch| select-start il:|of| selection))) (il:terpri promptwindow) (il:setq mutator-string (il:ttyinpromptforword "Mutate by function: " mutate-candidate nil promptwindow nil nil (il:charcode (il:cr ^x)))) (cond ((il:stringp mutator-string) (il:setq mutator (il:nlsetq (il:read (il:openstringstream mutator-string (quote il:input))))) (if mutator (if (do-mutation context node (car mutator)) (il:setq mutate-candidate mutator-string) (il:|printout| promptwindow t "Error during mutation. No changes made.")) (il:|printout| promptwindow t "Invalid function name: " mutator-string))) (t (il:|printout| promptwindow "...aborted")))) (t (il:|printout| promptwindow t "Select whole structure to mutate."))) t)) ) (quote-current-selection (il:lambda (context charcode quote-type) (il:* il:\; "Edited 13-Jan-88 13:26 by DCB") (close-open-node context) (let* ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (node (il:fetch select-node il:of selection)) (quote-node)) (when (and node (eq (il:fetch select-type il:of selection) (quote structure))) (il:setq quote-node (create-quoted-gap basic-gap context quote-type)) (start-undo-block) (replace-node context node quote-node) (replace-node context (subnode 1 quote-node) node) (note-change quote-node context) (select-node context quote-node) (set-point point context quote-node nil t nil (quote structure)) (end-undo-block))) (il:* il:\; "must return non-NIL if command executed") t) ) (REDISPLAY (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 14:16 by woz") (IL:* IL:|;;;| "woz: i don't think this function ever gets called!!!") (VERIFY-STRUCTURE CONTEXT NIL NIL T))) (redo (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:39 by DCB") (let ((undo-undo-list (il:fetch undo-undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-undo-list (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-undo-list) context) (il:replace undo-undo-list il:of context il:with (cdr undo-undo-list))) (t (il:|printout| promptwindow t "No Undo to Undo")))) t) ) (selected-fn-name (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:39 by DCB") (close-open-node context) (or (get-selected-structure context) (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) structure) (when (il:type? edit-node node) (il:setq structure (il:fetch structure il:of node)) (when (il:listp structure) (il:setq structure (car structure))) (when (il:atom structure) structure))))) ) (skip-to-gap (il:lambda (context) (il:* il:\; "Edited 23-Nov-87 18:19 by DCB") (let ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) (promptwindow (get-prompt-window context)) node) (cond ((il:setq node (il:fetch select-node il:of selection)) (unless (select-next-gap context node (il:fetch select-start il:of selection)) (il:|printout| promptwindow t "No more blanks to fill in."))) ((il:setq node (il:fetch point-node il:of point)) (unless (select-next-gap context node (if (eq (il:fetch point-type il:of point) (quote structure)) (il:fetch point-index il:of point) 0)) (il:|printout| promptwindow t "No more blanks to fill in."))) (t (il:|printout| promptwindow t "Select point from which to start search for blanks.")))) t) ) (undo (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 09:39 by DCB") (close-open-node context) (let ((undo-list (il:fetch undo-list il:of context)) (promptwindow (get-prompt-window context))) (cond (undo-list (il:replace undo-list il:of context il:with (il:fetch undo-undo-list il:of context)) (set-selection-nowhere (il:fetch selection il:of context)) (set-point-nowhere (il:fetch caret-point il:of context)) (undo-event (car undo-list) context) (il:replace undo-undo-list il:of context il:with (il:fetch undo-list il:of context)) (when (null (il:replace undo-list il:of context il:with (cdr undo-list))) (il:replace changed-structure? il:of context il:with nil))) (t (il:|printout| promptwindow t (if (il:fetch undo-undo-list il:of context) "Nothing else to Undo" "Nothing to Undo"))))) t) ) (undo-extract (il:lambda (context node subnodes) (il:* il:\; "Edited 7-Jul-87 09:39 by DCB") (il:* il:|;;;| "sticks subnodes back into node and revives them. ") (rplacd (il:fetch sub-nodes il:of node) subnodes) (il:for subnode il:in subnodes il:as index il:from 1 il:do (il:replace super-node il:of subnode il:with node) (il:replace sub-node-index il:of subnode il:with index) (detach-node subnode) (revive-node subnode (il:fetch depth il:of node))) (il:* il:|;;| "used to reparse here. now if we simply note the change, the format types, format values, and linear forms will be recomputed.") (note-change node context)) ) ) (IL:PUTPROPS IL:SEDIT-COMMANDS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 2018 )) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (13416 13986 (PSEUDO-SELECTION-FROM-SELECTION 13416 . 13986)) (13988 14742 ( COMPOSE-PSEUDO-SELECTION 13988 . 14742)) (14744 15283 (DECOMPOSE-PSEUDO-SELECTION 14744 . 15283)) ( 15285 16082 (SELECTION-FROM-PSEUDO-SELECTION 15285 . 16082)) (16084 16387 (SELECT-PSEUDO-SEGMENT 16084 . 16387)) (16452 17342 (ADD-COMMAND 16452 . 17342)) (17344 19507 (GET-SELECTION 17344 . 19507)) ( 19509 20689 (REPLACE-SELECTION 19509 . 20689)) (20691 21183 (RESET-COMMANDS 20691 . 21183)) (21185 21354 (DEFAULT-COMMANDS 21185 . 21354)) (21832 22935 (EQUALIZE-STRING-WIDTHS 21832 . 22935)) (22937 23135 (MINIMUM-STRING-WIDTH 22937 . 23135)) (23137 23335 (MAXIMUM-STRING-WIDTH 23137 . 23335)) (23337 24208 (FIND-AND-DISPLAY-STRUCTURE 23337 . 24208)) (24210 24894 (FIND-AND-DISPLAY-STRUCTURE-BACKWARDS 24210 . 24894)) (24896 25800 (FIND-AND-DISPLAY-SUBSTRUCTURE 24896 . 25800)) (25802 26505 ( FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS 25802 . 26505)) (26507 27148 (FIND-NTH-STRUCTURE 26507 . 27148 )) (27150 29880 (FIND-NODE-SUBSTRUCTURE 27150 . 29880)) (29882 31135 (FIND-NODE-SUBSTRUCTURE-BACKWARDS 29882 . 31135)) (31137 32116 (FIND-OBJ 31137 . 32116)) (32118 33518 (FIND-SELECTION 32118 . 33518)) ( 33520 35212 (FIND-SELECTION-BACKWARDS 33520 . 35212)) (35214 37943 (FIND-STRUCTURE 35214 . 37943)) ( 37945 40292 (FIND-STRUCTURE-BACKWARDS 37945 . 40292)) (40294 43223 (FIND-SUBSTRUCTURE 40294 . 43223)) (43225 45525 (FIND-SUBSTRUCTURE-BACKWARDS 43225 . 45525)) (45527 45763 (GET-USER-STRING 45527 . 45763) ) (45765 49473 (SEARCH-OBJ 45765 . 49473)) (49475 53140 (SEARCH-OBJ-BACKWARDS 49475 . 53140)) (53142 57968 (SUBSTITUTE-OBJ 53142 . 57968)) (57970 62626 (SUBSTITUTE-STRUCTURE 57970 . 62626)) (62628 65800 (SUBSTITUTE-SUBSTRUCTURE 62628 . 65800)) (65802 66964 (STRUCTURE-FROM-SELECTION 65802 . 66964)) (66966 67809 (STRUCTURE-FROM-STRING 66966 . 67809)) (67811 69952 (COMMENT-OUT-SELECTION 67811 . 69952)) ( 69953 124814 (ADD-MENU 69966 . 70629) (BACKSPACE 70631 . 71610) (CHANGE-PACKAGE 71612 . 74412) ( CHANGE-PRINTBASE 74414 . 76596) (CHANGE-QUOTE 76598 . 76953) (CONVERT-COMMENT 76955 . 78715) ( CONVERT-COMMENT-STRUCTURE 78717 . 80020) (CONVERT-COMMENT-TAIL 80022 . 81422) (CREATE-COMMAND-TABLE 81424 . 83402) (DEFAULT-EDIT-FN 83404 . 83541) (DELETE-SELECTION 83543 . 84225) (DELETE-WORD 84227 . 86328) (DO-MUTATION 86330 . 86878) (EDIT-SELECTION 86880 . 87328) (EVAL-SELECTION 87330 . 89199) ( EXPAND 89201 . 90330) (EXTRACT-CURRENT-SELECTION 90332 . 92700) (FIND-COMMENT 92702 . 93396) (GET-MENU 93398 . 93775) (EDIT-HELP 93777 . 94852) (HELPMENU 94854 . 97643) (INPUT-DOT 97645 . 99777) ( INPUT-ESCAPE 99779 . 100027) (INPUT-NORMAL-CHAR 100029 . 102062) (INPUT-QUOTE 102064 . 105146) ( INPUT-SQUARE-BRACKET 105148 . 105499) (INPUT-STRINGDELIM 105501 . 106900) (INPUT-TOKENDELIM 106902 . 107882) (INSERT-MULTI-ESCAPE 107884 . 109012) (INSERT-SPECIAL-CHARACTER 109014 . 110274) ( INSPECT-SELECTION 110276 . 110811) (JOIN 110813 . 114483) (MENU-CLOSEFN 114485 . 114703) ( MENU-FIND-SELECTEDFN 114705 . 115405) (MENU-INIT-STATE 115407 . 116214) (MENU-PACKAGE-SELECTEDFN 116216 . 117267) (MENU-PRINTBASE-SELECTEDFN 117269 . 118145) (MENU-SELECTEDFN 118147 . 118573) ( MENU-SUBSTITUTE-SELECTEDFN 118575 . 119535) (MUTATE 119537 . 120647) (QUOTE-CURRENT-SELECTION 120649 . 121416) (REDISPLAY 121418 . 121657) (REDO 121659 . 122153) (SELECTED-FN-NAME 122155 . 122600) ( SKIP-TO-GAP 122602 . 123379) (UNDO 123381 . 124181) (UNDO-EXTRACT 124183 . 124812))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-COMMANDS.DATABASE b/sources/SEDIT-COMMANDS.DATABASE new file mode 100644 index 00000000..5ef573f4 --- /dev/null +++ b/sources/SEDIT-COMMANDS.DATABASE @@ -0,0 +1 @@ +(PROGN (PRIN1 "Use LOADDB to load database files! " T) (ERROR!)) ("22-Apr-2018 17:13:59" . {DSK}kaplan>Local>medley3.5>lispcore>sources>SEDIT-COMMANDS.;2) FNS (SEDIT::PSEUDO-SELECTION-FROM-SELECTION SEDIT::COMPOSE-PSEUDO-SELECTION SEDIT::DECOMPOSE-PSEUDO-SELECTION SEDIT::SELECTION-FROM-PSEUDO-SELECTION SEDIT::SELECT-PSEUDO-SEGMENT SEDIT:ADD-COMMAND SEDIT:GET-SELECTION SEDIT:REPLACE-SELECTION SEDIT:RESET-COMMANDS SEDIT:DEFAULT-COMMANDS SEDIT::EQUALIZE-STRING-WIDTHS SEDIT::MINIMUM-STRING-WIDTH SEDIT::MAXIMUM-STRING-WIDTH SEDIT::FIND-AND-DISPLAY-STRUCTURE SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS SEDIT::FIND-NTH-STRUCTURE SEDIT::FIND-NODE-SUBSTRUCTURE SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS SEDIT::FIND-OBJ SEDIT::FIND-SELECTION SEDIT::FIND-SELECTION-BACKWARDS SEDIT::FIND-STRUCTURE SEDIT::FIND-STRUCTURE-BACKWARDS SEDIT::FIND-SUBSTRUCTURE SEDIT::FIND-SUBSTRUCTURE-BACKWARDS SEDIT::GET-USER-STRING SEDIT::SEARCH-OBJ SEDIT::SEARCH-OBJ-BACKWARDS SEDIT::SUBSTITUTE-OBJ SEDIT::SUBSTITUTE-STRUCTURE SEDIT::SUBSTITUTE-SUBSTRUCTURE SEDIT::STRUCTURE-FROM-SELECTION SEDIT::STRUCTURE-FROM-STRING SEDIT::COMMENT-OUT-SELECTION SEDIT::ADD-MENU SEDIT::BACKSPACE SEDIT::CHANGE-PACKAGE SEDIT::CHANGE-PRINTBASE SEDIT::CHANGE-QUOTE SEDIT::CONVERT-COMMENT SEDIT::CONVERT-COMMENT-STRUCTURE SEDIT::CONVERT-COMMENT-TAIL SEDIT::CREATE-COMMAND-TABLE SEDIT::DEFAULT-EDIT-FN SEDIT::DELETE-SELECTION SEDIT::DELETE-WORD SEDIT::DO-MUTATION SEDIT::EDIT-SELECTION SEDIT::EVAL-SELECTION SEDIT::EXPAND SEDIT::EXTRACT-CURRENT-SELECTION SEDIT::FIND-COMMENT SEDIT::GET-MENU SEDIT::EDIT-HELP SEDIT::HELPMENU SEDIT::INPUT-DOT SEDIT::INPUT-ESCAPE SEDIT::INPUT-NORMAL-CHAR SEDIT::INPUT-QUOTE SEDIT::INPUT-SQUARE-BRACKET SEDIT::INPUT-STRINGDELIM SEDIT::INPUT-TOKENDELIM SEDIT::INSERT-MULTI-ESCAPE SEDIT::INSERT-SPECIAL-CHARACTER SEDIT::INSPECT-SELECTION SEDIT::JOIN SEDIT::MENU-CLOSEFN SEDIT::MENU-FIND-SELECTEDFN SEDIT::MENU-INIT-STATE SEDIT::MENU-PACKAGE-SELECTEDFN SEDIT::MENU-PRINTBASE-SELECTEDFN SEDIT::MENU-SELECTEDFN SEDIT::MENU-SUBSTITUTE-SELECTEDFN SEDIT::MUTATE SEDIT::QUOTE-CURRENT-SELECTION SEDIT::REDISPLAY SEDIT::REDO SEDIT::SELECTED-FN-NAME SEDIT::SKIP-TO-GAP SEDIT::UNDO SEDIT::UNDO-EXTRACT) (READATABASE) ( CALL SEDIT::PSEUDO-SELECTION-FROM-SELECTION (SEDIT::COMPOSE-PSEUDO-SELECTION) SEDIT::COMPOSE-PSEUDO-SELECTION (LIST CL:FIRST + CL:1- CL:LENGTH) SEDIT::DECOMPOSE-PSEUDO-SELECTION ( CL:VALUES CL:FIRST CL:SECOND CL:THIRD) SEDIT::SELECTION-FROM-PSEUDO-SELECTION (CL:UNLESS CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION ) SEDIT::SELECT-PSEUDO-SEGMENT (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION SEDIT::SELECT-NODE-SEGMENT SEDIT::SELECT-NODE) SEDIT:ADD-COMMAND (CL:WHEN CL:COPY-TREE LIST NCONC) SEDIT:GET-SELECTION (CL:VALUES SEDIT::STRUCTURE-FROM-SELECTION) SEDIT:REPLACE-SELECTION (CL:UNLESS CL:ERROR CL:MAPCAR CL:FUNCTION SEDIT::PARSE-NEW CL:COPY-LIST SEDIT::SELECT-PSEUDO-SEGMENT SEDIT::COMPOSE-PSEUDO-SELECTION) SEDIT:RESET-COMMANDS ( SEDIT::CREATE-COMMAND-TABLE CL:FIRST CL:SECOND) SEDIT:DEFAULT-COMMANDS (CL:COPY-TREE SEDIT:RESET-COMMANDS ) SEDIT::EQUALIZE-STRING-WIDTHS (SEDIT::MAXIMUM-STRING-WIDTH CL:DO CHARWIDTH CL:CHAR-CODE CL:FIRST CL:CONCATENATE CL:MAKE-STRING CL:CEILING - STRINGWIDTH CL:REST) SEDIT::MINIMUM-STRING-WIDTH (CL:APPLY) SEDIT::MAXIMUM-STRING-WIDTH (CL:APPLY) SEDIT::FIND-AND-DISPLAY-STRUCTURE (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::FIND-STRUCTURE CL:FORMAT SEDIT::FIND-AND-DISPLAY-STRUCTURE) SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::FIND-STRUCTURE-BACKWARDS CL:FORMAT SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::FIND-SUBSTRUCTURE CL:FORMAT SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::FIND-SUBSTRUCTURE-BACKWARDS CL:FORMAT SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE) SEDIT::FIND-NTH-STRUCTURE (SEDIT::SUBNODE CL:DO SEDIT::FIND-STRUCTURE SEDIT::SELECT-NODE + SEDIT::NEXT-NODE ) SEDIT::FIND-NODE-SUBSTRUCTURE (CL:FIRST CL:DO CL:NTHCDR + CL:1- SEDIT::FIND-NODE-SUBSTRUCTURE CL:FUNCTION LIST CL:REST CL:1+) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (CL:FIRST CL:DO CL:NTHCDR - CL:REVERSE CL:1- SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS CL:FUNCTION LIST) SEDIT::FIND-OBJ ( SEDIT::CLOSE-OPEN-NODE SEDIT::CLOSE-NODE SEDIT::FIND-SELECTION-BACKWARDS SEDIT::FIND-SELECTION SEDIT::SEARCH-OBJ-BACKWARDS SEDIT::SEARCH-OBJ) SEDIT::FIND-SELECTION (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE SEDIT::STRUCTURE-FROM-SELECTION LIST CL:1+ SEDIT::NEXT-NODE SEDIT::FIND-AND-DISPLAY-STRUCTURE CL:FORMAT) SEDIT::FIND-SELECTION-BACKWARDS ( SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS SEDIT::STRUCTURE-FROM-SELECTION LIST CL:1- SEDIT::PREV-NODE SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CL:FORMAT) SEDIT::FIND-STRUCTURE (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION CL:DO* CL:1+ SEDIT::SUBNODE NTH CL:UNLESS SEDIT::NEXT-NODE) SEDIT::FIND-STRUCTURE-BACKWARDS (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION CL:DO* CL:1+ SEDIT::SUBNODE NTH CL:UNLESS SEDIT::PREV-NODE) SEDIT::FIND-SUBSTRUCTURE (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION SEDIT::FIND-NODE-SUBSTRUCTURE CL:LENGTH CL:DO) SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS CL:LENGTH CL:DO) SEDIT::GET-USER-STRING (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW TTYINPROMPTFORWORD) SEDIT::SEARCH-OBJ (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::STRUCTURE-FROM-STRING SEDIT::GET-USER-STRING SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::NEXT-NODE CL:1+ SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE SEDIT::FIND-AND-DISPLAY-STRUCTURE CL:FIRST) SEDIT::SEARCH-OBJ-BACKWARDS (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::STRUCTURE-FROM-STRING SEDIT::GET-USER-STRING SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE SEDIT::PREV-NODE CL:1+ CL:1- SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS CL:FIRST) SEDIT::SUBSTITUTE-OBJ (SEDIT::CLOSE-OPEN-NODE SEDIT::CLOSE-NODE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::PSEUDO-SELECTION-FROM-SELECTION CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::STRUCTURE-FROM-STRING SEDIT::GET-USER-STRING CL:VALUES SEDIT::SUBSTITUTE-SUBSTRUCTURE SEDIT::SUBSTITUTE-STRUCTURE CL:FIRST CL:FORMAT CL:WHEN SEDIT::SELECT-PSEUDO-SEGMENT) SEDIT::SUBSTITUTE-STRUCTURE (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION CL:LENGTH - REPLACEFIELD CONS FETCHFIELD CL:DO* SEDIT::FIND-STRUCTURE SEDIT::NEXT-NODE CL:MAPCAR CL:FUNCTION SEDIT::COLLECT-UNDO-BLOCK CL:VALUES CL:COPY-LIST SEDIT::SUBNODE NTH + CL:1- CL:THIRD CL:1+) SEDIT::SUBSTITUTE-SUBSTRUCTURE (CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-CALL LIST SEDIT::DECOMPOSE-PSEUDO-SELECTION CL:LENGTH - REPLACEFIELD CONS FETCHFIELD CL:DO* SEDIT::FIND-SUBSTRUCTURE CL:MAPCAR CL:FUNCTION SEDIT::COLLECT-UNDO-BLOCK CL:VALUES CL:COPY-LIST + CL:THIRD CL:1+) SEDIT::STRUCTURE-FROM-SELECTION (CL:WHEN CL:NTHCDR CL:DO CL:NREVERSE CL:1+) SEDIT::STRUCTURE-FROM-STRING (CL:VALUES CL:WITH-INPUT-FROM-STRING CL:WITH-OPEN-STREAM CL:MAKE-STRING-INPUT-STREAM CL:MULTIPLE-VALUE-PROG1 .UNWIND.PROTECT. FUNCTION CL:DO LIST CL:READ CL:NREVERSE CL:1+) SEDIT::COMMENT-OUT-SELECTION (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW CL:WITH-OUTPUT-TO-STRING CL:MAKE-STRING-OUTPUT-STREAM CL:MULTIPLE-VALUE-PROG1 .UNWIND.PROTECT. FUNCTION NTH PLUS CL:GET-OUTPUT-STREAM-STRING CL:FORMAT CL:WHEN SEDIT::PARSE-NEW LIST REPLACEFIELD CONS FETCHFIELD SEDIT::END-UNDO-BLOCK SEDIT::COLLECT-UNDO-BLOCK) SEDIT::ADD-MENU (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW PRIN1 SEDIT::GET-MENU) SEDIT::BACKSPACE (SEDIT::BACKSPACE-QUOTE) SEDIT::CHANGE-PACKAGE (SEDIT::CLOSE-NODE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW U-CASE TTYINPROMPTFORWORD CL:FIND-PACKAGE CL:PACKAGE-NAME FM.CHANGELABEL WINDOWPROP CL:PACKAGE-USE-LIST PRIN1) SEDIT::CHANGE-PRINTBASE ( SEDIT::CLOSE-NODE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW TTYINPROMPTFORWORD FIXP NLSETQ READ OPENSTRINGSTREAM FM.CHANGESTATE WINDOWPROP PRIN1) SEDIT::CHANGE-QUOTE (SEDIT::QUOTE-WRAPPER LISTGET SEDIT::NOTE-CHANGE) SEDIT::CONVERT-COMMENT (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SUBNODE NTH REPLACEFIELD CONS FETCHFIELD SEDIT::FIND-COMMENT SEDIT::NEXT-NODE SEDIT::PARSE-NEW SEDIT::CONVERT-COMMENT-STRUCTURE PLUS SEDIT::COLLECT-UNDO-BLOCK PRIN1) SEDIT::CONVERT-COMMENT-STRUCTURE (EQMEMB CONS NCHARS LIST CONCATLIST SEDIT::CONVERT-COMMENT-TAIL) SEDIT::CONVERT-COMMENT-TAIL (LIST NTHCHARCODE) SEDIT::CREATE-COMMAND-TABLE (CL:MAKE-HASH-TABLE CL:FIRST LIST* CL:THIRD CL:REST LIST CL:SECOND KWOTE MAPC CL:GETHASH SEDIT::CHARCODE) SEDIT::DEFAULT-EDIT-FN (ED LIST*) SEDIT::DELETE-SELECTION (SEDIT::SET-SELECTION-NOWHERE) SEDIT::DELETE-WORD (SEDIT::CLOSE-NODE IDIFFERENCE ADD1 NTHCHARCODE SUB1 NCHARS CL:WHEN SEDIT::SET-SELECTION-NOWHERE) SEDIT::DO-MUTATION (NLSETQ CL:FUNCALL CL:WHEN SEDIT::PARSE-NEW) SEDIT::EDIT-SELECTION (SEDIT::GET-SELECTED-STRUCTURE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW) SEDIT::EVAL-SELECTION (SEDIT::GET-SELECTED-STRUCTURE CL:COPY-TREE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW FIND.PROCESS PRIN1 RESETFORM TTY.PROCESS PROCESS.EVAL BQUOTE LIST SEDIT::REPLACE-NODE SEDIT::PARSE-NEW PROCESS.EVALV printout PRIN2 INSPECT) SEDIT::EXPAND (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW PRIN1 NLSETQ EDITGETD printout SEDIT::REPLACE-NODE SEDIT::PARSE-NEW) SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::CLOSE-NODE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::SET-SELECTION-ME PRIN1 CL:THIRD CL:LOOP CL:MULTIPLE-VALUE-SETQ CL:READ-FROM-STRING CL:MAPCAR CL:FUNCTION CL:NREVERSE REPLACEFIELD CONS FETCHFIELD LIST COPY SEDIT::COLLECT-UNDO-BLOCK) SEDIT::FIND-COMMENT (CL:WHEN SEDIT::NEXT-NODE) SEDIT::GET-MENU (FREEMENU) SEDIT::EDIT-HELP ( SEDIT::CLOSE-NODE NCHARS SEDIT::INSERT SEDIT::SELECTED-FN-NAME SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW NLSETQ SMARTARGLIST STRINGWIDTH CONS WINDOWPROP PRIN1) SEDIT::HELPMENU (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW FONTCREATE CL:FIRST SEDIT::EQUALIZE-STRING-WIDTHS CL:SECOND CL:THIRD SEDIT::MINIMUM-STRING-WIDTH STRINGWIDTH CL:1- SEDIT::MAXIMUM-STRING-WIDTH + CL:NREVERSE CL:CONCATENATE STRING CL:REST CONS CL:WHEN MENU SEDIT::AWAKE-COMMAND-PROCESS) SEDIT::INPUT-DOT (CL:WHEN SEDIT::QUOTE-WRAPPER) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (PRIN1 CHARACTER IDIFFERENCE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::TYPE-OF-INPUT CONCAT SEDIT::ESCAPE-CHAR FETCHFIELD U-CASE L-CASE SEDIT::SET-SELECTION-NOWHERE) SEDIT::INPUT-QUOTE (SELECTQ SEDIT::TYPE-OF-INPUT SEDIT::CLOSE-NODE CL:WHEN SEDIT::QUOTE-WRAPPER CHCON1 NCHARS REPLACEFIELD CONS FETCHFIELD SEDIT::COLLECT-UNDO-BLOCK) SEDIT::INPUT-SQUARE-BRACKET (CL:WHEN SEDIT::TYPE-OF-INPUT SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW PRIN1) SEDIT::INPUT-STRINGDELIM (SEDIT::TYPE-OF-INPUT CL:WHEN ALLOCSTRING SEDIT::CREATE-SIMPLE-NODE) SEDIT::INPUT-TOKENDELIM (SEDIT::TYPE-OF-INPUT SEDIT::SET-SELECTION-NOWHERE CHARACTER) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::TYPE-OF-INPUT ALLOCSTRING NTHCHARCODE ADD1 PLUS FETCHFIELD REPLACEFIELD) SEDIT::INSERT-SPECIAL-CHARACTER (ALLOCSTRING SELECTQ SEDIT::TYPE-OF-INPUT) SEDIT::INSPECT-SELECTION (SEDIT::GET-SELECTED-STRUCTURE INSPECT printout PRIN1 SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW) SEDIT::JOIN (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW SEDIT::CLOSE-NODE PRIN1 SEDIT::SUBNODE NTH CONSTANT REPLACEFIELD CONS FETCHFIELD LIST PLUS printout SEDIT::PARSE-NEW CL:INTERN CONCATLIST CL:SYMBOL-PACKAGE SEDIT::INSERT NCONC IMAX APPLY* LAST ADD1 SEDIT::SET-POINT SEDIT::COLLECT-UNDO-BLOCK) SEDIT::MENU-CLOSEFN (CONS WINDOWPROP MAINWINDOW) SEDIT::MENU-FIND-SELECTEDFN (LISTGET FM.ITEMPROP WINDOWPROP MAINWINDOW FM.EDITITEM LIST TTY.PROCESS) SEDIT::MENU-INIT-STATE (CL:PACKAGE-NAME FM.GETITEM FM.ITEMPROP) SEDIT::MENU-PACKAGE-SELECTEDFN ( LISTGET FM.ITEMPROP FM.EDITITEM CL:FIND-PACKAGE SEDIT::MENU-SELECTEDFN LIST PRIN1 GETPROMPTWINDOW MAINWINDOW FM.CHANGELABEL) SEDIT::MENU-PRINTBASE-SELECTEDFN (LISTGET FM.ITEMPROP FM.EDITITEM SEDIT::MENU-SELECTEDFN LIST PRIN1 GETPROMPTWINDOW MAINWINDOW FM.CHANGESTATE) SEDIT::MENU-SELECTEDFN ( WINDOWPROP MAINWINDOW SEDIT::AWAKE-COMMAND-PROCESS APPEND SEDIT::LOOKUP-COMMAND CL:GETHASH FM.ITEMPROP ) SEDIT::MENU-SUBSTITUTE-SELECTEDFN (LISTGET FM.ITEMPROP WINDOWPROP MAINWINDOW FM.EDITITEM LIST TTY.PROCESS) SEDIT::MUTATE (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW TTYINPROMPTFORWORD NLSETQ READ OPENSTRINGSTREAM PRIN1) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::CLOSE-NODE SEDIT::CREATE-QUOTED-GAP REPLACEFIELD CONS FETCHFIELD SEDIT::SUBNODE SEDIT::END-UNDO-BLOCK SEDIT::COLLECT-UNDO-BLOCK) SEDIT::REDISPLAY (SEDIT::VERIFY-STRUCTURE) SEDIT::REDO (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW PRIN1) SEDIT::SELECTED-FN-NAME (SEDIT::CLOSE-NODE SEDIT::GET-SELECTED-STRUCTURE CL:WHEN) SEDIT::SKIP-TO-GAP (SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW printout PRIN1) SEDIT::UNDO (SEDIT::CLOSE-NODE SEDIT:GET-PROMPT-WINDOW GETPROMPTWINDOW PRIN1) SEDIT::UNDO-EXTRACT (PLUS SEDIT::NOTE-CHANGE) NIL BIND SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH (SEDIT::STRING-LIST SEDIT::FONT SEDIT::PRIN2?) SEDIT::MAXIMUM-STRING-WIDTH (SEDIT::STRING-LIST SEDIT::FONT SEDIT::PRIN2?) SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE (SEDIT::CHARCODE) SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ ( SEDIT::CHARCODE) SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (SEDIT::END-START) SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ (SEDIT::CHARCODE) SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::TSTART) SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION (SEDIT::CHARCODE) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE (SEDIT::CHARCODE) SEDIT::CHANGE-PRINTBASE (SEDIT::CHARCODE *PRINT-BASE*) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION ( SEDIT::CHARCODE) SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND (SEDIT::CHARCODE SEDIT::POINT) SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT (SEDIT::CONTEXT) SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE (SEDIT::CONTEXT) SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET (SEDIT::CHARCODE) SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN (SEDIT::CONTEXT) SEDIT::MENU-INIT-STATE (SEDIT::CONTEXT *PRINT-BASE*) SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN ( SEDIT::BUTTONS) SEDIT::MENU-SUBSTITUTE-SELECTEDFN (SEDIT::CONTEXT) SEDIT::MUTATE (SEDIT::POINT SEDIT::RESULT) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::CHARCODE) SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL NLAMBDA SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING (CHARCODE) SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (CL:UNWIND-PROTECT) SEDIT::COMMENT-OUT-SELECTION (CL:UNWIND-PROTECT) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE (CHARCODE) SEDIT::CHANGE-PRINTBASE (CHARCODE) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE (CHARCODE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM (CHARCODE) SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE (CHARCODE) SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL NOBIND SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE T SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL RECORD SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS (SEDIT::EDIT-ENV) SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE (SEDIT::EDIT-NODE) SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION (SEDIT::EDIT-CONTEXT) SEDIT::EVAL-SELECTION ( SEDIT::EDIT-CONTEXT) SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP (SEDIT::EDIT-NODE) SEDIT::HELPMENU NIL SEDIT::INPUT-DOT ( SEDIT::EDIT-SELECTION) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::EDIT-CONTEXT READTABLEP SEDIT::EDIT-NODE) SEDIT::INPUT-QUOTE (SEDIT::EDIT-NODE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::EDIT-SELECTION SEDIT::EDIT-CONTEXT) SEDIT::INPUT-TOKENDELIM ( SEDIT::EDIT-CONTEXT SEDIT::EDIT-SELECTION) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::EDIT-NODE) SEDIT::INSERT-SPECIAL-CHARACTER (SEDIT::EDIT-NODE) SEDIT::INSPECT-SELECTION (SEDIT::EDIT-CONTEXT) SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME (SEDIT::EDIT-NODE) SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL CREATE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::EDIT-SELECTION) SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU (MENU) SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL FETCH SEDIT::PSEUDO-SELECTION-FROM-SELECTION (SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END ) SEDIT::COMPOSE-PSEUDO-SELECTION (SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION (SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SELECT-START) SEDIT:REPLACE-SELECTION (SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-TYPE) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE (SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT) SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE (SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT) SEDIT::FIND-NTH-STRUCTURE (SEDIT::SUB-NODES SEDIT::ROOT) SEDIT::FIND-NODE-SUBSTRUCTURE (SEDIT::SUB-NODES CL:STRUCTURE) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (SEDIT::SUB-NODES CL:STRUCTURE) SEDIT::FIND-OBJ (SEDIT::OPEN-NODE-CHANGED? SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-TYPE) SEDIT::FIND-SELECTION (SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-START) SEDIT::FIND-SELECTION-BACKWARDS (SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END) SEDIT::FIND-STRUCTURE (CL:STRUCTURE SEDIT::DEPTH SEDIT::SUB-NODES SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) SEDIT::FIND-STRUCTURE-BACKWARDS (CL:STRUCTURE SEDIT::DEPTH SEDIT::SUB-NODES SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) SEDIT::FIND-SUBSTRUCTURE (SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) SEDIT::GET-USER-STRING (SEDIT::DISPLAY-WINDOW) SEDIT::SEARCH-OBJ (SEDIT::FIND-CANDIDATE SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT SEDIT::CARET-POINT SEDIT::POINT-TYPE SEDIT::POINT-NODE SEDIT::POINT-INDEX SEDIT::SELECTION SEDIT::SELECT-TYPE SEDIT::SELECT-NODE SEDIT::SELECT-START) SEDIT::SEARCH-OBJ-BACKWARDS (SEDIT::FIND-CANDIDATE SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::ROOT SEDIT::CARET-POINT SEDIT::POINT-TYPE SEDIT::POINT-NODE SEDIT::POINT-INDEX SEDIT::SELECTION SEDIT::SELECT-TYPE SEDIT::SELECT-NODE SEDIT::SELECT-END SEDIT::SELECT-START) SEDIT::SUBSTITUTE-OBJ ( SEDIT::OPEN-NODE-CHANGED? SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::FIND-CANDIDATE SEDIT::SUBSTITUTE-CANDIDATE) SEDIT::SUBSTITUTE-STRUCTURE (SEDIT::ROOT SEDIT::CARET-POINT SEDIT::SELECTION SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX SEDIT::SUB-NODES) SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::CARET-POINT SEDIT::SELECTION) SEDIT::STRUCTURE-FROM-SELECTION ( SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END SEDIT::SUB-NODES CL:STRUCTURE) SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION (SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-TYPE SEDIT::DISPLAY-WINDOW SEDIT::SUB-NODES SEDIT::SELECT-END CL:STRUCTURE) SEDIT::ADD-MENU (SEDIT::DISPLAY-WINDOW) SEDIT::BACKSPACE ( SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::BACK-SPACE SEDIT::NODE-TYPE SEDIT::POINT-INDEX SEDIT::POINT-STRING SEDIT::SELECT-NODE SEDIT::SUPER-NODE) SEDIT::CHANGE-PACKAGE (SEDIT::OPEN-NODE-CHANGED? SEDIT::DISPLAY-WINDOW SEDIT::PROFILE) SEDIT::CHANGE-PRINTBASE (SEDIT::OPEN-NODE-CHANGED? SEDIT::DISPLAY-WINDOW SEDIT::PROFILE) SEDIT::CHANGE-QUOTE (CL:STRUCTURE SEDIT::QUOTE-STRING SEDIT::ENVIRONMENT) SEDIT::CONVERT-COMMENT (SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-TYPE SEDIT::SUB-NODES SEDIT::SELECT-END SEDIT::SUB-NODE-INDEX SEDIT::DEPTH CL:STRUCTURE) SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION (SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END SEDIT::CARET-POINT SEDIT::SELECT-STRING SEDIT::NODE-TYPE) SEDIT::DELETE-WORD (SEDIT::OPEN-NODE-CHANGED? SEDIT::CARET-POINT SEDIT::SELECTION SEDIT::POINT-NODE SEDIT::POINT-INDEX SEDIT::POINT-STRING SEDIT::SELECT-NODE SEDIT::PENDING-DELETE? SEDIT::POINT-TYPE SEDIT::NODE-TYPE SEDIT::\X SEDIT::SUB-NODES ) SEDIT::DO-MUTATION (CL:STRUCTURE) SEDIT::EDIT-SELECTION (SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::DISPLAY-WINDOW) SEDIT::EVAL-SELECTION (SEDIT::EVAL-IN-PROCESS SEDIT::DISPLAY-WINDOW SEDIT::SELECT-NODE SEDIT::SELECTION) SEDIT::EXPAND (SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SELECT-START CL:STRUCTURE) SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::OPEN-NODE-CHANGED? SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::POINT-NODE SEDIT::POINT-TYPE SEDIT::SELECT-TYPE SEDIT::SELECT-START SEDIT::SELECT-END SEDIT::SUB-NODES SEDIT::NODE-TYPE CL:STRUCTURE) SEDIT::FIND-COMMENT (SEDIT::DEPTH SEDIT::SUB-NODE-INDEX CL:STRUCTURE) SEDIT::GET-MENU NIL SEDIT::EDIT-HELP ( SEDIT::OPEN-NODE-CHANGED? SEDIT::CARET-POINT SEDIT::POINT-NODE CL:STRUCTURE SEDIT::POINT-INDEX SEDIT::DISPLAY-WINDOW) SEDIT::HELPMENU (SEDIT::HELP-MENU SEDIT::ENVIRONMENT SEDIT::DISPLAY-WINDOW) SEDIT::INPUT-DOT (SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::SELECT-TYPE SEDIT::NODE-TYPE SEDIT::SELECT-START SEDIT::SELECT-NODE SEDIT::SUPER-NODE SEDIT::SELECT-END SEDIT::POINT-TYPE SEDIT::POINT-INDEX CL:STRUCTURE) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::DISPLAY-WINDOW SEDIT::CARET-POINT CASEINSENSITIVE SEDIT::POINT-NODE SEDIT::UNDO-LIST SEDIT::SELECT-NODE SEDIT::SELECTION ) SEDIT::INPUT-QUOTE (SEDIT::OPEN-NODE-CHANGED? SEDIT::SELECTION SEDIT::SELECT-NODE SEDIT::SUPER-NODE SEDIT::NODE-TYPE CL:STRUCTURE SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::POINT-INDEX SEDIT::POINT-STRING ) SEDIT::INPUT-SQUARE-BRACKET (SEDIT::DISPLAY-WINDOW) SEDIT::INPUT-STRINGDELIM (SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::SELECT-NODE SEDIT::NODE-TYPE SEDIT::SELECTION SEDIT::ENVIRONMENT SEDIT::DEFAULT-FONT SEDIT::DEPTH CL:STRUCTURE SEDIT::UNDO-LIST) SEDIT::INPUT-TOKENDELIM (SEDIT::CARET-POINT SEDIT::SELECTION SEDIT::PENDING-DELETE? SEDIT::POINT-NODE SEDIT::NODE-TYPE SEDIT::SELECT-NODE) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::POINT-STRING SEDIT::POINT-INDEX SEDIT::SELECT-NODE SEDIT::POINT-TYPE SEDIT::SELECTION) SEDIT::INSERT-SPECIAL-CHARACTER (SEDIT::CARET-POINT SEDIT::POINT-NODE SEDIT::SELECT-NODE SEDIT::SELECTION) SEDIT::INSPECT-SELECTION (SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::DISPLAY-WINDOW) SEDIT::JOIN (SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END SEDIT::OPEN-NODE-CHANGED? SEDIT::SELECT-TYPE SEDIT::NAME SEDIT::NODE-TYPE SEDIT::SUB-NODES CL:STRUCTURE SEDIT::UNASSIGNED) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN ( SEDIT::COMMAND-TABLE SEDIT::ENVIRONMENT) SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE ( SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SELECT-START) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::OPEN-NODE-CHANGED? SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SUB-NODES) SEDIT::REDISPLAY NIL SEDIT::REDO (SEDIT::UNDO-UNDO-LIST SEDIT::DISPLAY-WINDOW SEDIT::SELECTION SEDIT::CARET-POINT) SEDIT::SELECTED-FN-NAME (SEDIT::OPEN-NODE-CHANGED? SEDIT::CARET-POINT SEDIT::POINT-NODE CL:STRUCTURE) SEDIT::SKIP-TO-GAP ( SEDIT::SELECTION SEDIT::CARET-POINT SEDIT::DISPLAY-WINDOW SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::POINT-NODE SEDIT::POINT-TYPE SEDIT::POINT-INDEX) SEDIT::UNDO (SEDIT::OPEN-NODE-CHANGED? SEDIT::UNDO-LIST SEDIT::DISPLAY-WINDOW SEDIT::UNDO-UNDO-LIST SEDIT::SELECTION SEDIT::CARET-POINT) SEDIT::UNDO-EXTRACT (SEDIT::SUB-NODES SEDIT::DEPTH) NIL REPLACE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::SELECT-NODE SEDIT::SELECT-START SEDIT::SELECT-END) SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS (SEDIT::COMMAND-TABLE SEDIT::HELP-MENU) SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ (SEDIT::FIND-CANDIDATE) SEDIT::SEARCH-OBJ-BACKWARDS ( SEDIT::FIND-CANDIDATE) SEDIT::SUBSTITUTE-OBJ (SEDIT::FIND-CANDIDATE SEDIT::SUBSTITUTE-CANDIDATE) SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION (SEDIT::PENDING-DELETE?) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE ( SEDIT::UNASSIGNED) SEDIT::CONVERT-COMMENT (SEDIT::PENDING-DELETE?) SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION (SEDIT::EVAL-IN-PROCESS) SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION ( SEDIT::POINT-NODE SEDIT::POINT-TYPE SEDIT::PENDING-DELETE?) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU (SEDIT::HELP-MENU ITEMS ITEMWIDTH CHANGEOFFSETFLG MENUOFFSET TITLE) SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::ATOM-STARTED SEDIT::ATOM-STARTED-UNDO-POINTER) SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::POINT-NODE SEDIT::POINT-INDEX SEDIT::POINT-TYPE SEDIT::POINT-STRING SEDIT::ATOM-STARTED SEDIT::ATOM-STARTED-UNDO-POINTER) SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE (SEDIT::POINT-INDEX SEDIT::POINT-TYPE) SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (SEDIT::PENDING-DELETE?) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO ( SEDIT::UNDO-UNDO-LIST) SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO (SEDIT::UNDO-LIST SEDIT::UNDO-UNDO-LIST SEDIT::CHANGED-STRUCTURE?) SEDIT::UNDO-EXTRACT (SEDIT::SUPER-NODE SEDIT::SUB-NODE-INDEX) NIL REFFREE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND (SEDIT::COMMAND-TABLE-SPEC) SEDIT:GET-SELECTION ( :SUB-LIST) SEDIT:REPLACE-SELECTION (:SUB-LIST) SEDIT:RESET-COMMANDS (SEDIT::COMMAND-TABLE-SPEC) SEDIT:DEFAULT-COMMANDS (SEDIT::DEFAULT-COMMAND-TABLE-SPEC) SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ ( SEDIT:*WRAP-SEARCH*) SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE (SEDIT::TYPE-GAP SEDIT::TYPE-QUOTE) SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE (SEDIT::QUOTE-WRAPPER-LIST) SEDIT::CONVERT-COMMENT (SEDIT::COMMENT-MARKERS) SEDIT::CONVERT-COMMENT-STRUCTURE (COMMENTFLG SEDIT::LEVEL-3-COMMENT SEDIT:CONVERT-UPGRADE SEDIT::LEVEL-2-COMMENT SEDIT::LEVEL-1-COMMENT) SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN (:DISPLAY :DONTWAIT) SEDIT::DELETE-SELECTION (SEDIT::TYPE-GAP) SEDIT::DELETE-WORD (SEDIT::TYPE-COMMENT SEDIT::WORD-DELIM-CHARS SEDIT::TYPE-GAP) SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION (SEDIT:*EDIT-FN*) SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::TYPE-COMMENT :SEDIT-READ-END-FLG) SEDIT::FIND-COMMENT ( COMMENTFLG) SEDIT::GET-MENU (SEDIT::MENU-DESCRIPTION) SEDIT::EDIT-HELP (PROMPTWINDOW) SEDIT::HELPMENU (MENUFONT) SEDIT::INPUT-DOT (SEDIT::TYPE-QUOTE) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR ( *READTABLE* *PRINT-CASE*) SEDIT::INPUT-QUOTE (SEDIT::TYPE-GAP SEDIT::TYPE-QUOTE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::TYPE-STRING) SEDIT::INPUT-TOKENDELIM (SEDIT::TYPE-COMMENT) SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (SEDIT::COMMENT-MARKERS) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE (*PACKAGE* *PRINT-BASE*) SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::BASIC-GAP ) SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL REF SEDIT::PSEUDO-SELECTION-FROM-SELECTION (SEDIT::SEL) SEDIT::COMPOSE-PSEUDO-SELECTION (SEDIT::NODE) SEDIT::DECOMPOSE-PSEUDO-SELECTION (SEDIT::PSEL) SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::PSEL A0319 A0320 SEDIT::NODE SEDIT::START SEDIT::END) SEDIT::SELECT-PSEUDO-SEGMENT (SEDIT::PSEL A0321 A0322 SEDIT::CONTEXT SEDIT::NODE SEDIT::END SEDIT::SET-POINT? SEDIT::WHERE) SEDIT:ADD-COMMAND (SEDIT::FORM SEDIT::HELP-STRING SEDIT::SCROLL? SEDIT::KEY-CODE) SEDIT:GET-SELECTION (SEDIT::CONTEXT SEDIT::SELECTION ) SEDIT:REPLACE-SELECTION (SEDIT::SELECTION-TYPE SEDIT::CONTEXT SEDIT::SELECTION SEDIT::S CL:STRUCTURE SEDIT::POINT) SEDIT:RESET-COMMANDS (SEDIT::COMMANDS) SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS (SEDIT::STRING-LIST SEDIT::FONT SEDIT::PRIN2? SEDIT::PAD-CHAR SEDIT::DESIRED-WIDTH SEDIT::PAD-CHAR-WIDTH) SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE (SEDIT::CONTEXT SEDIT::STR SEDIT::SCOPE SEDIT::TOP SEDIT::PROMPTWINDOW) SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (SEDIT::CONTEXT SEDIT::STR SEDIT::SCOPE SEDIT::TOP SEDIT::PROMPTWINDOW) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE (SEDIT::CONTEXT SEDIT::STR SEDIT::SCOPE SEDIT::TOP SEDIT::PROMPTWINDOW) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (SEDIT::CONTEXT SEDIT::STR SEDIT::SCOPE SEDIT::TOP SEDIT::PROMPTWINDOW) SEDIT::FIND-NTH-STRUCTURE (SEDIT::CONTEXT CL:STRUCTURE SEDIT::TOP SEDIT::N) SEDIT::FIND-NODE-SUBSTRUCTURE (SEDIT::NODE SEDIT::SUBNODES SEDIT::STRLEN SEDIT::STR SEDIT::LASTINDEX SEDIT::S SEDIT::N) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (SEDIT::NODE SEDIT::SUBNODES SEDIT::SUBLENGTH SEDIT::STRLEN SEDIT::STR SEDIT::S SEDIT::N) SEDIT::FIND-OBJ ( SEDIT::CONTEXT SEDIT::SELECTION SEDIT::WRAP?) SEDIT::FIND-SELECTION (SEDIT::CONTEXT SEDIT::SELECTION SEDIT::NODE SEDIT::PROMPTWINDOW) SEDIT::FIND-SELECTION-BACKWARDS (SEDIT::CONTEXT SEDIT::SELECTION SEDIT::NODE SEDIT::PROMPTWINDOW) SEDIT::FIND-STRUCTURE (SEDIT::SCOPE A0325 A0327 SEDIT::START A0328 SEDIT::SCOPE-NODE SEDIT::STR SEDIT::MIN-DEPTH) SEDIT::FIND-STRUCTURE-BACKWARDS (SEDIT::SCOPE A0329 A0332 SEDIT::END A0333 A0334 SEDIT::SCOPE-NODE SEDIT::STR SEDIT::MIN-DEPTH) SEDIT::FIND-SUBSTRUCTURE ( SEDIT::SCOPE A0335 A0337 A0338 SEDIT::STR SEDIT::SCOPE-NODE SEDIT::SCOPE-START SEDIT::SCOPE-END SEDIT::START-START SEDIT::STRLEN) SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (SEDIT::SCOPE A0339 A0342 A0343 A0344 SEDIT::STR SEDIT::SCOPE-NODE SEDIT::SCOPE-START SEDIT::SCOPE-END SEDIT::END-END SEDIT::STRLEN) SEDIT::GET-USER-STRING (SEDIT::CONTEXT SEDIT::PROMPTWINDOW SEDIT::PROMPT SEDIT::DEFAULT) SEDIT::SEARCH-OBJ (A0345 SEDIT::STRLEN SEDIT::POINT SEDIT::SELECTION SEDIT::POINT-NODE SEDIT::POINT-TYPE SEDIT::POINT-INDEX SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SCOPE SEDIT::STR) SEDIT::SEARCH-OBJ-BACKWARDS (A0346 SEDIT::STRLEN SEDIT::POINT SEDIT::SELECTION SEDIT::POINT-NODE SEDIT::POINT-TYPE SEDIT::POINT-INDEX SEDIT::SELECT-NODE SEDIT::SELECT-TYPE SEDIT::SELECT-END SEDIT::SCOPE SEDIT::STR) SEDIT::SUBSTITUTE-OBJ (SEDIT::SELECTION SEDIT::PROMPTWINDOW TYPE A0347 SEDIT::OLDLEN A0348 SEDIT::NEWLEN SEDIT::OLD SEDIT::NEW A0349 SEDIT::SUBCOUNT) SEDIT::SUBSTITUTE-STRUCTURE (A0350 A0351 SEDIT::CONTEXT SEDIT::NEW SEDIT::NEWLEN SEDIT::OLD SEDIT::S SEDIT::POINT SEDIT::SELECTION SEDIT::ROOT SEDIT::SCOPE-NODE SEDIT::DELTA-LENGTH SEDIT::N) SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::SCOPE A0352 A0353 SEDIT::CONTEXT SEDIT::NEW SEDIT::NEWLEN SEDIT::OLD SEDIT::S SEDIT::POINT SEDIT::SELECTION A0356 A0357 SEDIT::TNODE SEDIT::SCOPE-NODE SEDIT::TEND SEDIT::DELTA-LENGTH SEDIT::N) SEDIT::STRUCTURE-FROM-SELECTION (SEDIT::SELECTION SEDIT::NODE SEDIT::END ) SEDIT::STRUCTURE-FROM-STRING (CL::$STRING$ CL::$START$ SEDIT::S SEDIT::EOF) SEDIT::COMMENT-OUT-SELECTION (SEDIT::CONTEXT SEDIT::S SEDIT::POINT SEDIT::NEW-NODE) SEDIT::ADD-MENU (SEDIT::CONTEXT SEDIT::WINDOW SEDIT::PROMPTWINDOW) SEDIT::BACKSPACE (SEDIT::CONTEXT SEDIT::POINT SEDIT::SELECTION) SEDIT::CHANGE-PACKAGE (SEDIT::CONTEXT SEDIT::PROMPTWINDOW SEDIT::WINDOW) SEDIT::CHANGE-PRINTBASE (SEDIT::CONTEXT SEDIT::PROMPTWINDOW) SEDIT::CHANGE-QUOTE (SEDIT::QUOTE-TYPE SEDIT::CONTEXT) SEDIT::CONVERT-COMMENT ( SEDIT::CONTEXT SEDIT::DEPTH SEDIT::PROMPTWINDOW SEDIT::POINT) SEDIT::CONVERT-COMMENT-STRUCTURE (SEDIT::EXPR ) SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE (SEDIT::DESCRIPTION SEDIT::COMMAND SEDIT::KEY SEDIT::TABLE) SEDIT::DEFAULT-EDIT-FN (SEDIT::OBJ SEDIT::OPTIONS) SEDIT::DELETE-SELECTION (SEDIT::CONTEXT SEDIT::SELECTION) SEDIT::DELETE-WORD (SEDIT::CONTEXT SEDIT::POINT SEDIT::SELECTION SEDIT::END STRING) SEDIT::DO-MUTATION (SEDIT::MUTATOR SEDIT::NODE SEDIT::CONTEXT) SEDIT::EDIT-SELECTION (SEDIT::CONTEXT SEDIT::OPTIONS) SEDIT::EVAL-SELECTION (SEDIT::PROMPTWINDOW SEDIT::STRUCTURE-COPY) SEDIT::EXPAND ( SEDIT::CONTEXT SEDIT::SELECTION CL:STRUCTURE SEDIT::PROMPTWINDOW) SEDIT::EXTRACT-CURRENT-SELECTION ( SEDIT::CONTEXT SEDIT::PROMPTWINDOW STRING SEDIT::S) SEDIT::FIND-COMMENT (SEDIT::MIN-DEPTH SEDIT::LAST-SUBNODE SEDIT::COMMENTCHAR) SEDIT::GET-MENU (SEDIT::CONTEXT) SEDIT::EDIT-HELP (SEDIT::CONTEXT SEDIT::POINT SEDIT::NODE SEDIT::PROMPTWINDOW) SEDIT::HELPMENU (SEDIT::CONTEXT SEDIT::PROMPTWINDOW SEDIT::FONT SEDIT::TAB-WIDTH SEDIT::LEFT-WIDTH SEDIT::MENU-RIGHT SEDIT::MENU-ITEMS) SEDIT::INPUT-DOT ( SEDIT::CONTEXT SEDIT::POINT SEDIT::SELECTION SEDIT::CHARCODE SEDIT::SUPER-NODE) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR ($$OUTPUT SEDIT::POINT-TYPE SEDIT::POINT) SEDIT::INPUT-QUOTE (SEDIT::CONTEXT SEDIT::QUOTE-TYPE SEDIT::SELECTION SEDIT::CHARCODE SEDIT::POINT) SEDIT::INPUT-SQUARE-BRACKET ( SEDIT::CONTEXT SEDIT::PROMPTWINDOW) SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM (SEDIT::CONTEXT SEDIT::POINT SEDIT::CHARCODE SEDIT::POINTNODE) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::CONTEXT TYPE CL:CHAR ) SEDIT::INSERT-SPECIAL-CHARACTER (SEDIT::CONTEXT CL:CHAR SEDIT::POINT STRING) SEDIT::INSPECT-SELECTION (SEDIT::CONTEXT $$OUTPUT) SEDIT::JOIN (SEDIT::CONTEXT SEDIT::PROMPTWINDOW SEDIT::POINT) SEDIT::MENU-CLOSEFN (SEDIT::W) SEDIT::MENU-FIND-SELECTEDFN (SEDIT::ITEM SEDIT::WINDOW SEDIT::FIND-ITEM SEDIT::BUTTONS) SEDIT::MENU-INIT-STATE (SEDIT::PRINT-BASE SEDIT::MENU CL:PACKAGE-NAME) SEDIT::MENU-PACKAGE-SELECTEDFN (SEDIT::ITEM SEDIT::PACKAGE-NAME-ITEM CL:PACKAGE-NAME SEDIT::BUTTONS SEDIT::WINDOW $$OUTPUT) SEDIT::MENU-PRINTBASE-SELECTEDFN (SEDIT::ITEM SEDIT::PRINTBASE-VALUE-ITEM SEDIT::BUTTONS SEDIT::WINDOW $$OUTPUT) SEDIT::MENU-SELECTEDFN (SEDIT::WINDOW SEDIT::CONTEXT SEDIT::COMMAND SEDIT::ITEM SEDIT::EXTRA-ARGS) SEDIT::MENU-SUBSTITUTE-SELECTEDFN (SEDIT::ITEM SEDIT::WINDOW SEDIT::FIND-ITEM SEDIT::SUBITEM SEDIT::BUTTONS) SEDIT::MUTATE (SEDIT::CONTEXT SEDIT::SELECTION SEDIT::PROMPTWINDOW) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::CONTEXT SEDIT::SELECTION SEDIT::QUOTE-TYPE SEDIT::POINT) SEDIT::REDISPLAY (SEDIT::CONTEXT) SEDIT::REDO (SEDIT::PROMPTWINDOW) SEDIT::SELECTED-FN-NAME (SEDIT::CONTEXT SEDIT::POINT SEDIT::NODE) SEDIT::SKIP-TO-GAP (SEDIT::CONTEXT SEDIT::SELECTION SEDIT::PROMPTWINDOW SEDIT::POINT) SEDIT::UNDO (SEDIT::PROMPTWINDOW) SEDIT::UNDO-EXTRACT (SEDIT::NODE SEDIT::SUBNODES SEDIT::CONTEXT) NIL SETFREE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND (SEDIT::DEFAULT-COMMAND-TABLE-SPEC SEDIT::FIRST-ADD-COMMAND SEDIT::FIRST-ADD-COMMAND-MENU-ENTRY) SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS (SEDIT::COMMAND-TABLE-SPEC SEDIT::FIRST-ADD-COMMAND-MENU-ENTRY) SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ (SEDIT::FIND-CANDIDATE) SEDIT::SEARCH-OBJ-BACKWARDS ( SEDIT::FIND-CANDIDATE) SEDIT::SUBSTITUTE-OBJ (SEDIT::FIND-CANDIDATE SEDIT::SUBSTITUTE-CANDIDATE) SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE (SEDIT::PACKAGE-CANDIDATE *PACKAGE*) SEDIT::CHANGE-PRINTBASE ( SEDIT::PRINTBASE-CANDIDATE *PRINT-BASE* *PRINT-RADIX*) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU (SEDIT::MENUS) SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE (SEDIT::THIS-CHAR-ESCAPED) SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN (SEDIT::MENUS) SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE (SEDIT::MUTATE-CANDIDATE) SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL SET SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::SEL) SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION (SEDIT::NEW-NODES) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS (SEDIT::STR) SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE (SEDIT::M SEDIT::TARGET) SEDIT::FIND-NODE-SUBSTRUCTURE (SEDIT::START SEDIT::MATCH SEDIT::SUBS SEDIT::INDEX SEDIT::ENDINDEX SEDIT::DOSUBS?) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS ( SEDIT::END SEDIT::MATCH SEDIT::SUBS SEDIT::INDEX SEDIT::STARTINDEX SEDIT::DOSUBS?) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION (SEDIT::START) SEDIT::FIND-SELECTION-BACKWARDS (SEDIT::END) SEDIT::FIND-STRUCTURE (SEDIT::NODE) SEDIT::FIND-STRUCTURE-BACKWARDS (SEDIT::NODE) SEDIT::FIND-SUBSTRUCTURE (SEDIT::MATCH SEDIT::NODE SEDIT::SUPER-NODE SEDIT::NODE-INDEX SEDIT::CONTINUATION? SEDIT::START SEDIT::END) SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (SEDIT::MATCH SEDIT::NODE SEDIT::SUPER-NODE SEDIT::NODE-INDEX SEDIT::CONTINUATION? SEDIT::END SEDIT::START) SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ ( SEDIT::SEARCH-STRING) SEDIT::SEARCH-OBJ-BACKWARDS (SEDIT::SEARCH-STRING) SEDIT::SUBSTITUTE-OBJ ( SEDIT::SCOPE SEDIT::OLDSTR SEDIT::NEWSTR) SEDIT::SUBSTITUTE-STRUCTURE (SEDIT::SCOPE SEDIT::RESUME SEDIT::SCOPE-END SEDIT::TARGET SEDIT::TARGET-SUPER SEDIT::TARGET-INDEX SEDIT::NEW-NODES SEDIT::NUMSUBS ) SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::RESUME SEDIT::SCOPE-END SEDIT::TARGET SEDIT::NEW-NODES SEDIT::NUMSUBS) SEDIT::STRUCTURE-FROM-SELECTION (SEDIT::SUBNODES CL:STRUCTURE SEDIT::INDEX) SEDIT::STRUCTURE-FROM-STRING (SEDIT::VAL SEDIT::RESULTS CL:COUNT A0358) SEDIT::COMMENT-OUT-SELECTION ( SEDIT::X SEDIT::BLANK-BEFORE SEDIT::I A0359) SEDIT::ADD-MENU (SEDIT::MENU) SEDIT::BACKSPACE (SEDIT::NODE ) SEDIT::CHANGE-PACKAGE (SEDIT::NEW-PACKAGE-NAME SEDIT::NEW-PACKAGE) SEDIT::CHANGE-PRINTBASE ( SEDIT::NEW-PRINTBASE-STRING SEDIT::NEW-PRINTBASE) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT ( SEDIT::NODE SEDIT::SELECT-END SEDIT::NEXT-NODE SEDIT::NEW-NODE SEDIT::NUMBER-OF-COMMENTS) SEDIT::CONVERT-COMMENT-STRUCTURE (SEDIT::COMTAIL SEDIT::2-STARS SEDIT::COMCHAR) SEDIT::CONVERT-COMMENT-TAIL (SEDIT::NSPACES X SEDIT::TAIL) SEDIT::CREATE-COMMAND-TABLE (SEDIT::FN SEDIT::ENTRY SEDIT::MENU-LEFT SEDIT::MENU-RIGHT SEDIT::MENU-ITEMS) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD (SEDIT::START) SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION (SEDIT::PROCESS SEDIT::VALUE) SEDIT::EXPAND (SEDIT::EXPANSION) SEDIT::EXTRACT-CURRENT-SELECTION ( SEDIT::NODE CL:STRUCTURE SEDIT::START SEDIT::NEW-STRUCTURES SEDIT::SUBNODES SEDIT::SET-SELECTION?) SEDIT::FIND-COMMENT (SEDIT::NODE) SEDIT::GET-MENU (SEDIT::MENU) SEDIT::EDIT-HELP (SEDIT::ARGS) SEDIT::HELPMENU (SEDIT::EQUALIZED-MENU-LEFT SEDIT::TAB-COLUMN SEDIT::ITEMWIDTH SEDIT::ITEMS SEDIT::LEFT SEDIT::RIGHT SEDIT::ITEM SEDIT::MENU SEDIT::COMMAND) SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (CL:CHAR WHERE SEDIT::NODE) SEDIT::INPUT-QUOTE (SEDIT::SUPER-NODE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::NODE SEDIT::NEW-STRING) SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE (SEDIT::NODE WHERE) SEDIT::INSERT-SPECIAL-CHARACTER (WHERE SEDIT::NODE) SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (TYPE SEDIT::SUBNODES SEDIT::NEW-STRUCTURE SEDIT::SUBNODE SEDIT::INDEX SEDIT::NEW-NODE SEDIT::COMMENT-LEVEL) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN (PACKAGE) SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE (SEDIT::MUTATOR-STRING SEDIT::MUTATOR) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::QUOTE-NODE ) SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME (CL:STRUCTURE) SEDIT::SKIP-TO-GAP ( SEDIT::NODE) SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT (SEDIT::SUBNODE SEDIT::INDEX) NIL SMASHFREE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS (SEDIT::LISP-EDIT-ENVIRONMENT) SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL SMASH SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::SEL) SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ (SEDIT::CONTEXT) SEDIT::SEARCH-OBJ-BACKWARDS ( SEDIT::CONTEXT) SEDIT::SUBSTITUTE-OBJ (SEDIT::CONTEXT) SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION (SEDIT::SELECTION) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE (SEDIT::QUOTE-NODE) SEDIT::CONVERT-COMMENT (SEDIT::SELECTION) SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL (STREAM) SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION ( SEDIT::CONTEXT) SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::POINT SEDIT::SELECTION) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::CONTEXT) SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::POINT SEDIT::CONTEXT) SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE (SEDIT::POINT) SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (SEDIT::SELECTION) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO (SEDIT::CONTEXT) SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO (SEDIT::CONTEXT) SEDIT::UNDO-EXTRACT ( SEDIT::SUBNODE) NIL PROP SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU (SEDIT::MENU REJECTMAINCOMS RESHAPEFN) SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE (SEDIT::MENU) SEDIT::CHANGE-PRINTBASE (SEDIT::MENU) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU (CLOSEFN FM.DONTRESHAPE) SEDIT::EDIT-HELP (WIDTH) SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN (SEDIT::MENU) SEDIT::MENU-FIND-SELECTEDFN (EDIT SEDIT::EDIT-CONTEXT PROCESS) SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN (EDIT) SEDIT::MENU-PRINTBASE-SELECTEDFN ( EDIT) SEDIT::MENU-SELECTEDFN (SEDIT::EDIT-CONTEXT) SEDIT::MENU-SUBSTITUTE-SELECTEDFN (SEDIT::FINDITEM EDIT SEDIT::EDIT-CONTEXT PROCESS) SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL TEST SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION (SEDIT::START SEDIT::END ) SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION (SEDIT::SEL) SEDIT::SELECT-PSEUDO-SEGMENT (SEDIT::START) SEDIT:ADD-COMMAND (SEDIT::KEY-NAME SEDIT::COMMAND-NAME) SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS (SEDIT::STR) SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE (SEDIT::TARGET SEDIT::WRAP? SEDIT::START) SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS (SEDIT::TARGET SEDIT::WRAP? SEDIT::END) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE (SEDIT::TARGET SEDIT::WRAP? SEDIT::START) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (SEDIT::TARGET SEDIT::WRAP? SEDIT::END) SEDIT::FIND-NTH-STRUCTURE (SEDIT::TARGET) SEDIT::FIND-NODE-SUBSTRUCTURE (SEDIT::CONTINUATION? SEDIT::SUBS SEDIT::END SEDIT::DOSUBS?) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (SEDIT::CONTINUATION? SEDIT::SUBS SEDIT::START SEDIT::DOSUBS?) SEDIT::FIND-OBJ (SEDIT::FIND-STRING SEDIT::BACKWARDS?) SEDIT::FIND-SELECTION (SEDIT::START SEDIT::WRAP?) SEDIT::FIND-SELECTION-BACKWARDS (SEDIT::END SEDIT::WRAP?) SEDIT::FIND-STRUCTURE (SEDIT::SCOPE-START SEDIT::START-NODE SEDIT::START-START SEDIT::NODE SEDIT::SCOPE-END ) SEDIT::FIND-STRUCTURE-BACKWARDS (SEDIT::SCOPE-START SEDIT::END-NODE SEDIT::END-START SEDIT::END-END SEDIT::SCOPE-END SEDIT::NODE) SEDIT::FIND-SUBSTRUCTURE (SEDIT::START-NODE SEDIT::NODE) SEDIT::FIND-SUBSTRUCTURE-BACKWARDS (SEDIT::END-NODE SEDIT::NODE) SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ (SEDIT::SELECT-START SEDIT::WRAP? SEDIT::START) SEDIT::SEARCH-OBJ-BACKWARDS (SEDIT::WRAP? SEDIT::END) SEDIT::SUBSTITUTE-OBJ (SEDIT::REMOVE? SEDIT::NEW-SCOPE) SEDIT::SUBSTITUTE-STRUCTURE ( SEDIT::REMOVE? SEDIT::TARGET SEDIT::SCOPE-START SEDIT::RESUME) SEDIT::SUBSTITUTE-SUBSTRUCTURE ( SEDIT::REMOVE? SEDIT::TARGET SEDIT::SCOPE-START SEDIT::RESUME) SEDIT::STRUCTURE-FROM-SELECTION ( SEDIT::START) SEDIT::STRUCTURE-FROM-STRING (SEDIT::STR) SEDIT::COMMENT-OUT-SELECTION (SEDIT::NODE SEDIT::START SEDIT::BLANK-BEFORE SEDIT::STR) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE (SEDIT::NODE) SEDIT::CHANGE-PACKAGE (SEDIT::NEW-PACKAGE SEDIT::NEW-PACKAGE-NAME) SEDIT::CHANGE-PRINTBASE ( SEDIT::NEW-PRINTBASE) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT (SEDIT::NODE SEDIT::START) SEDIT::CONVERT-COMMENT-STRUCTURE (SEDIT::2-STARS) SEDIT::CONVERT-COMMENT-TAIL (SEDIT::TAIL) SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD (SEDIT::NODE) SEDIT::DO-MUTATION (SEDIT::RESULT) SEDIT::EDIT-SELECTION (CL:STRUCTURE) SEDIT::EVAL-SELECTION (CL:STRUCTURE SEDIT::VALUE) SEDIT::EXPAND (SEDIT::NODE SEDIT::EXPANSION) SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::NODE SEDIT::SET-SELECTION?) SEDIT::FIND-COMMENT (SEDIT::NODE) SEDIT::GET-MENU NIL SEDIT::EDIT-HELP (SEDIT::FNAME) SEDIT::HELPMENU (SEDIT::ITEM) SEDIT::INPUT-DOT ( SEDIT::NODE) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE (SEDIT::NODE SEDIT::SUPER-NODE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE (WHERE) SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION ( CL:STRUCTURE) SEDIT::JOIN (SEDIT::NODE SEDIT::START SEDIT::END SEDIT::NEW-STRUCTURE SEDIT::NEW-NODE) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN (SEDIT::PRINT-BASE) SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE (SEDIT::NODE SEDIT::MUTATOR ) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::NODE) SEDIT::REDISPLAY NIL SEDIT::REDO (SEDIT::UNDO-UNDO-LIST ) SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO (SEDIT::UNDO-LIST) SEDIT::UNDO-EXTRACT NIL NIL TESTFREE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND (SEDIT::FIRST-ADD-COMMAND SEDIT::FIRST-ADD-COMMAND-MENU-ENTRY) SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::THIS-CHAR-ESCAPED) SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL PREDICATE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION (CL:LISTP) SEDIT::DECOMPOSE-PSEUDO-SELECTION (CL:LISTP) SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE (=) SEDIT::FIND-NODE-SUBSTRUCTURE (> CL:MISMATCH) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (< CL:MISMATCH) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE (EQUAL < >) SEDIT::FIND-STRUCTURE-BACKWARDS (EQUAL <) SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ (< = TYPEP >) SEDIT::SEARCH-OBJ-BACKWARDS (< = TYPEP >) SEDIT::SUBSTITUTE-OBJ (< = > EQL) SEDIT::SUBSTITUTE-STRUCTURE (=) SEDIT::SUBSTITUTE-SUBSTRUCTURE (=) SEDIT::STRUCTURE-FROM-SELECTION (<= >) SEDIT::STRUCTURE-FROM-STRING (CL:STRINGP NLSETQ) SEDIT::COMMENT-OUT-SELECTION (GREATERP) SEDIT::ADD-MENU (WINDOWPROP) SEDIT::BACKSPACE (TYPENAMEP) SEDIT::CHANGE-PACKAGE (STRINGP CL:MEMBER) SEDIT::CHANGE-PRINTBASE (STRINGP IGREATERP ILEQ ) SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT (FMEMB) SEDIT::CONVERT-COMMENT-STRUCTURE (FMEMB STRINGP IGEQ) SEDIT::CONVERT-COMMENT-TAIL (STRINGP) SEDIT::CREATE-COMMAND-TABLE (CL:CONSP) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD (IGREATERP FMEMB) SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION (CL:FUNCALL) SEDIT::EVAL-SELECTION (PROCESSP CL:EQUAL NUMBERP ATOM STRINGP) SEDIT::EXPAND (CL:CONSP CL:EQUAL) SEDIT::EXTRACT-CURRENT-SELECTION (NLSETQ) SEDIT::FIND-COMMENT (ILESSP IGREATERP) SEDIT::GET-MENU NIL SEDIT::EDIT-HELP (TYPENAMEP LITATOM ILEQ) SEDIT::HELPMENU (CL:LISTP > =) SEDIT::INPUT-DOT (TYPENAMEP) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (IGREATERP ILESSP TYPENAMEP) SEDIT::INPUT-QUOTE (FMEMB TYPENAMEP) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (TYPENAMEP SEDIT::DEAD-NODE?) SEDIT::INPUT-TOKENDELIM (SEDIT::EQ-POINT-TYPE TYPENAMEP) SEDIT::INSERT-MULTI-ESCAPE (TYPENAMEP) SEDIT::INSERT-SPECIAL-CHARACTER (TYPENAMEP) SEDIT::INSPECT-SELECTION (NLSETQ) SEDIT::JOIN (FMEMB GREATERP NUMBERP) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN (EQUAL) SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN (EQUAL) SEDIT::MENU-PRINTBASE-SELECTEDFN (IGREATERP ILEQ) SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN (EQUAL) SEDIT::MUTATE (STRINGP SEDIT::DO-MUTATION) SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME (TYPENAMEP ATOM) SEDIT::SKIP-TO-GAP (SEDIT::SELECT-NEXT-GAP) SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL EFFECT SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION (HELP) SEDIT:REPLACE-SELECTION (SEDIT::PENDING-DELETE SEDIT::INSERT) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE (SEDIT::SELECT-NODE) SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS ( SEDIT::SELECT-NODE) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE (SEDIT::SELECT-PSEUDO-SEGMENT) SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS (SEDIT::SELECT-PSEUDO-SEGMENT) SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE (CL:WHEN CL:UNLESS) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (CL:WHEN CL:UNLESS) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE (CL:WHEN) SEDIT::FIND-STRUCTURE-BACKWARDS (CL:WHEN) SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING (TERPRI) SEDIT::SEARCH-OBJ (CL:FORMAT CL:UNLESS) SEDIT::SEARCH-OBJ-BACKWARDS (CL:FORMAT CL:UNLESS) SEDIT::SUBSTITUTE-OBJ (CL:UNLESS CASE) SEDIT::SUBSTITUTE-STRUCTURE (SEDIT::START-UNDO-BLOCK SEDIT::END-UNDO-BLOCK SEDIT::SET-POINT-NOWHERE SEDIT::SET-SELECTION-NOWHERE SEDIT::SELECT-NODE SEDIT::PENDING-DELETE SEDIT::INSERT-NULL-LIST SEDIT::DELETE-SELECTION SEDIT::INSERT CL:WHEN) SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::START-UNDO-BLOCK SEDIT::END-UNDO-BLOCK SEDIT::SET-POINT-NOWHERE SEDIT::SET-SELECTION-NOWHERE SEDIT::SELECT-PSEUDO-SEGMENT SEDIT::DELETE-SELECTION SEDIT::PENDING-DELETE SEDIT::INSERT) SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (DECLARE CL:CLOSE) SEDIT::COMMENT-OUT-SELECTION (CL:WRITE-CHAR CL:PRIN1 CL:CLOSE SEDIT::START-UNDO-BLOCK SEDIT::DELETE-SELECTION SEDIT::INSERT SEDIT::SELECT-NODE) SEDIT::ADD-MENU (printout TERPRI ATTACHWINDOW WINDOWADDPROP) SEDIT::BACKSPACE (CL:FUNCALL CL:WHEN) SEDIT::CHANGE-PACKAGE (SEDIT::CLOSE-OPEN-NODE CL:WHEN TERPRI CL:FORMAT XCL:SAVE-PROFILE SEDIT::VERIFY-STRUCTURE printout) SEDIT::CHANGE-PRINTBASE (SEDIT::CLOSE-OPEN-NODE CL:WHEN TERPRI XCL:SAVE-PROFILE SEDIT::VERIFY-STRUCTURE printout) SEDIT::CHANGE-QUOTE (RPLACA) SEDIT::CONVERT-COMMENT (SEDIT::START-UNDO-BLOCK CL:WHEN SEDIT::REPLACE-NODE SEDIT::END-UNDO-BLOCK printout TERPRI SEDIT::SET-POINT-NOWHERE) SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL (TCONC LCONC SEDIT::CONVERT-COMMENT-TAIL SELECTQ SELCHARQ) SEDIT::CREATE-COMMAND-TABLE (CL:WHEN) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION (SEDIT::DELETE-NODES CL:WHEN) SEDIT::DELETE-WORD (SEDIT::CLOSE-OPEN-NODE SELECTQ SEDIT::DELETE-NODES SEDIT::MAP-COMMENT-INDEX) SEDIT::DO-MUTATION (SEDIT::REPLACE-NODE) SEDIT::EDIT-SELECTION ( SEDIT::SET-SELECTION-NOWHERE SEDIT::SET-POINT-NOWHERE CL:FORMAT) SEDIT::EVAL-SELECTION (TERPRI CL:WHEN CL:UNLESS SEDIT::SET-SELECTION-NOWHERE) SEDIT::EXPAND (CL:WHEN TERPRI) SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::CLOSE-OPEN-NODE CL:WHEN printout TERPRI CL:UNLESS SEDIT::PENDING-DELETE SEDIT::INSERT CL:FORMAT RPLACD SEDIT::START-UNDO-BLOCK SEDIT::UNDO-BY SEDIT::END-UNDO-BLOCK) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU (FM.RESETMENU WINDOWADDPROP WINDOWPROP SEDIT::MENU-INIT-STATE) SEDIT::EDIT-HELP ( SEDIT::CLOSE-OPEN-NODE CL:WHEN printout TERPRI) SEDIT::HELPMENU (CL:FORMAT CL:DO* CL:DO CL:TERPRI) SEDIT::INPUT-DOT (SEDIT::INPUT-QUOTE SEDIT::DELETE-NODES SEDIT::DOT-THIS-LIST SEDIT::CHANGE-QUOTE) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (printout DECLARE TERPRI CL:WHEN SELECTQ SEDIT::INSERT SEDIT::INSERT-STRING SHOULDNT) SEDIT::INPUT-QUOTE (SEDIT::CLOSE-OPEN-NODE SEDIT::CHANGE-QUOTE SEDIT::INSERT-QUOTED-GAP SEDIT::SET-SELECTION-ME SEDIT::QUOTE-CURRENT-SELECTION SEDIT::SET-SELECTION-NOWHERE SEDIT::SET-POINT SEDIT::PENDING-DELETE SEDIT::START-UNDO-BLOCK SEDIT::REPLACE-STRING SEDIT::END-UNDO-BLOCK) SEDIT::INPUT-SQUARE-BRACKET (printout TERPRI FLASHWINDOW CLEARBUF) SEDIT::INPUT-STRINGDELIM (SEDIT::INSERT SEDIT::SET-SELECTION-NOWHERE) SEDIT::INPUT-TOKENDELIM (SELECTQ SEDIT::INSERT CL:WHEN SHOULDNT) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::INSERT CL:WHEN SEDIT::INSERT-STRING SEDIT::SET-SELECTION-NOWHERE) SEDIT::INSERT-SPECIAL-CHARACTER (SEDIT::INSERT-STRING SEDIT::SET-SELECTION-NOWHERE SEDIT::INSERT) SEDIT::INSPECT-SELECTION (SEDIT::SET-SELECTION-NOWHERE SEDIT::SET-POINT-NOWHERE CL:WHEN DECLARE TERPRI) SEDIT::JOIN (SEDIT::CLOSE-OPEN-NODE TERPRI SEDIT::PENDING-DELETE SEDIT::START-UNDO-BLOCK SELECTQ CL:WHEN FRPLACD SEDIT::DELETE-NODES SEDIT::SET-SELECTION-ME SEDIT::END-UNDO-BLOCK) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN ( SEDIT::MENU-SELECTEDFN) SEDIT::MENU-INIT-STATE (FM.CHANGESTATE FM.CHANGELABEL) SEDIT::MENU-PACKAGE-SELECTEDFN (printout DECLARE TERPRI) SEDIT::MENU-PRINTBASE-SELECTEDFN (printout DECLARE TERPRI) SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN (SEDIT::MENU-SELECTEDFN) SEDIT::MUTATE (TERPRI printout) SEDIT::QUOTE-CURRENT-SELECTION (SEDIT::CLOSE-OPEN-NODE CL:WHEN SEDIT::START-UNDO-BLOCK SEDIT::REPLACE-NODE SEDIT::NOTE-CHANGE SEDIT::SELECT-NODE SEDIT::SET-POINT) SEDIT::REDISPLAY NIL SEDIT::REDO (SEDIT::SET-SELECTION-NOWHERE SEDIT::SET-POINT-NOWHERE SEDIT::UNDO-EVENT printout TERPRI) SEDIT::SELECTED-FN-NAME (SEDIT::CLOSE-OPEN-NODE) SEDIT::SKIP-TO-GAP (CL:UNLESS TERPRI) SEDIT::UNDO (SEDIT::CLOSE-OPEN-NODE SEDIT::SET-SELECTION-NOWHERE SEDIT::SET-POINT-NOWHERE SEDIT::UNDO-EVENT CL:WHEN printout TERPRI) SEDIT::UNDO-EXTRACT (RPLACD SEDIT::DETACH-NODE SEDIT::REVIVE-NODE) NIL CLISP SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION (BIND FOR FROM TO AS ON DO) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE (type?) SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT (BIND WHILE DO) SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL (WHILE BIND DO) SEDIT::CREATE-COMMAND-TABLE (for in do) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD (WHILE DO UNTIL) SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT (BIND UNTIL DO) SEDIT::GET-MENU NIL SEDIT::EDIT-HELP (type?) SEDIT::HELPMENU NIL SEDIT::INPUT-DOT (type?) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (type?) SEDIT::INPUT-QUOTE (type?) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (type?) SEDIT::INPUT-TOKENDELIM ( type?) SEDIT::INSERT-MULTI-ESCAPE (type?) SEDIT::INSERT-SPECIAL-CHARACTER (type?) SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (FOR FROM TO AS IN COLLECT JOIN THEREIS DO) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME (type?) SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT (FOR IN AS FROM DO) NIL SPECVARS SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL LOCALVARS SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (CL::$STRING$ CL::$START$) SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR ($$OUTPUT) SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION ($$OUTPUT) SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN ( $$OUTPUT) SEDIT::MENU-PRINTBASE-SELECTEDFN ($$OUTPUT) SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL APPLY SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION (SEDIT::PARSE-NEW) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE (EQUAL) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (EQUAL) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE (SEDIT::PARSE-NEW SEDIT::COPY-NODE) SEDIT::SUBSTITUTE-SUBSTRUCTURE ( SEDIT::PARSE-NEW SEDIT::COPY-NODE) SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING ( CL:CLOSE) SEDIT::COMMENT-OUT-SELECTION (CL:CLOSE) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::PARSE-NEW) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN (CONCATLIST) SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL ERROR SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION (apply) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE (apply) SEDIT::SUBSTITUTE-SUBSTRUCTURE (apply) SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (apply) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL LOCALFREEVARS SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION (SEDIT::CONTEXT) SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE (SEDIT::CONTEXT) SEDIT::SUBSTITUTE-SUBSTRUCTURE (SEDIT::CONTEXT) SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (SEDIT::S A0358) SEDIT::COMMENT-OUT-SELECTION (SEDIT::S A0359) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (SEDIT::CONTEXT) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL ARGS SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL USERTEMPLATES FCACHE.GETPROP (CALL EVAL PROP . PPE) WINDOWDELPROP (CALL EVAL PROP EVAL . PPE) CH.PROPERTY (CALL PROP) CATCH (CALL |..| EVAL) PROCESSPROP (CALL EVAL PROP EVAL . PPE) OP# (CALL) IBM-INIT (CALL KEYWORDS :FONT-DIRECTORY :MACHINETYPE :DEFAULT-FONTPROFILE :REDEFINE-KEYBOARD) CL:PUSH (NIL @ EXPR (IF (ATOM (CADR EXPR)) THEN (QUOTE (EVAL SET)) ELSE (QUOTE (EVAL SMASH)))) PERFORM (MACRO ARGS (PERFORMTRAN ARGS T)) TEXTPROP (CALL EVAL PROP EVAL . PPE) SHAZAM (CALL |..| NIL) SPREADAPPLY* ( CALL FUNCTIONAL |..| EVAL) CL:INCF (NIL @ EXPR (IF (LITATOM (CAR EXPR)) THEN (QUOTE (SET EVAL)) ELSE ( QUOTE (SMASH EVAL)))) CL:DECF (NIL @ EXPR (IF (LITATOM (CAR EXPR)) THEN (QUOTE (SET EVAL)) ELSE (QUOTE (SMASH EVAL)))) WINDOWPROP (CALL EVAL PROP EVAL . PPE) SETQ.NOREF (CALL SET EVAL . PPE) SPREADAPPLY ( CALL FUNCTIONAL EVAL . PPE) UNINTERRUPTABLY (CALL |..| EVAL) WINDOWADDPROP (CALL EVAL PROP EVAL EVAL . PPE) perform (MACRO ARGS (PERFORMTRAN ARGS T)) FCACHE.PUTPROP (CALL EVAL PROP EVAL . PPE) NIL 0 SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE (SEDIT::EDIT-NODE) SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP ( SEDIT::EDIT-NODE) SEDIT::HELPMENU NIL SEDIT::INPUT-DOT (SEDIT::EDIT-SELECTION) SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR (SEDIT::EDIT-NODE) SEDIT::INPUT-QUOTE (SEDIT::EDIT-NODE) SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM (SEDIT::EDIT-SELECTION) SEDIT::INPUT-TOKENDELIM (SEDIT::EDIT-SELECTION) SEDIT::INSERT-MULTI-ESCAPE (SEDIT::EDIT-NODE) SEDIT::INSERT-SPECIAL-CHARACTER (SEDIT::EDIT-NODE) SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME (SEDIT::EDIT-NODE) SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL FPTYPE SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL KEYACCEPT SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL KEYSPECIFY SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS ( :INITIAL-ELEMENT) SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE (:END2 :TEST) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (:END2 :TEST) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (:ABORT) SEDIT::COMMENT-OUT-SELECTION (:ABORT) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE ( :SIZE :REHASH-SIZE) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (:START) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL KEYCALL SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS (CL:MAKE-STRING ) SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE (CL:MISMATCH) SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS (CL:MISMATCH) SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING (CL:CLOSE) SEDIT::COMMENT-OUT-SELECTION (CL:CLOSE) SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE (CL:MAKE-HASH-TABLE) SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION (CL:READ-FROM-STRING) SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL FLET SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL LABEL SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL MACROLET SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL COMPILER-LET SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL SENDNOTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL SENDSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL IMPLEMENT SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL GETNOTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL GETSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL GETCVSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL GETCVNOTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL PUTNOTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL PUTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL PUTCVSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL PUTCVNOTSELF SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL OBJECT SEDIT::PSEUDO-SELECTION-FROM-SELECTION NIL SEDIT::COMPOSE-PSEUDO-SELECTION NIL SEDIT::DECOMPOSE-PSEUDO-SELECTION NIL SEDIT::SELECTION-FROM-PSEUDO-SELECTION NIL SEDIT::SELECT-PSEUDO-SEGMENT NIL SEDIT:ADD-COMMAND NIL SEDIT:GET-SELECTION NIL SEDIT:REPLACE-SELECTION NIL SEDIT:RESET-COMMANDS NIL SEDIT:DEFAULT-COMMANDS NIL SEDIT::EQUALIZE-STRING-WIDTHS NIL SEDIT::MINIMUM-STRING-WIDTH NIL SEDIT::MAXIMUM-STRING-WIDTH NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE NIL SEDIT::FIND-AND-DISPLAY-STRUCTURE-BACKWARDS NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE NIL SEDIT::FIND-AND-DISPLAY-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-NTH-STRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE NIL SEDIT::FIND-NODE-SUBSTRUCTURE-BACKWARDS NIL SEDIT::FIND-OBJ NIL SEDIT::FIND-SELECTION NIL SEDIT::FIND-SELECTION-BACKWARDS NIL SEDIT::FIND-STRUCTURE NIL SEDIT::FIND-STRUCTURE-BACKWARDS NIL SEDIT::FIND-SUBSTRUCTURE NIL SEDIT::FIND-SUBSTRUCTURE-BACKWARDS NIL SEDIT::GET-USER-STRING NIL SEDIT::SEARCH-OBJ NIL SEDIT::SEARCH-OBJ-BACKWARDS NIL SEDIT::SUBSTITUTE-OBJ NIL SEDIT::SUBSTITUTE-STRUCTURE NIL SEDIT::SUBSTITUTE-SUBSTRUCTURE NIL SEDIT::STRUCTURE-FROM-SELECTION NIL SEDIT::STRUCTURE-FROM-STRING NIL SEDIT::COMMENT-OUT-SELECTION NIL SEDIT::ADD-MENU NIL SEDIT::BACKSPACE NIL SEDIT::CHANGE-PACKAGE NIL SEDIT::CHANGE-PRINTBASE NIL SEDIT::CHANGE-QUOTE NIL SEDIT::CONVERT-COMMENT NIL SEDIT::CONVERT-COMMENT-STRUCTURE NIL SEDIT::CONVERT-COMMENT-TAIL NIL SEDIT::CREATE-COMMAND-TABLE NIL SEDIT::DEFAULT-EDIT-FN NIL SEDIT::DELETE-SELECTION NIL SEDIT::DELETE-WORD NIL SEDIT::DO-MUTATION NIL SEDIT::EDIT-SELECTION NIL SEDIT::EVAL-SELECTION NIL SEDIT::EXPAND NIL SEDIT::EXTRACT-CURRENT-SELECTION NIL SEDIT::FIND-COMMENT NIL SEDIT::GET-MENU NIL SEDIT::EDIT-HELP NIL SEDIT::HELPMENU NIL SEDIT::INPUT-DOT NIL SEDIT::INPUT-ESCAPE NIL SEDIT::INPUT-NORMAL-CHAR NIL SEDIT::INPUT-QUOTE NIL SEDIT::INPUT-SQUARE-BRACKET NIL SEDIT::INPUT-STRINGDELIM NIL SEDIT::INPUT-TOKENDELIM NIL SEDIT::INSERT-MULTI-ESCAPE NIL SEDIT::INSERT-SPECIAL-CHARACTER NIL SEDIT::INSPECT-SELECTION NIL SEDIT::JOIN NIL SEDIT::MENU-CLOSEFN NIL SEDIT::MENU-FIND-SELECTEDFN NIL SEDIT::MENU-INIT-STATE NIL SEDIT::MENU-PACKAGE-SELECTEDFN NIL SEDIT::MENU-PRINTBASE-SELECTEDFN NIL SEDIT::MENU-SELECTEDFN NIL SEDIT::MENU-SUBSTITUTE-SELECTEDFN NIL SEDIT::MUTATE NIL SEDIT::QUOTE-CURRENT-SELECTION NIL SEDIT::REDISPLAY NIL SEDIT::REDO NIL SEDIT::SELECTED-FN-NAME NIL SEDIT::SKIP-TO-GAP NIL SEDIT::UNDO NIL SEDIT::UNDO-EXTRACT NIL NIL ) \ No newline at end of file diff --git a/sources/SEDIT-COMMENTS b/sources/SEDIT-COMMENTS new file mode 100644 index 00000000..c8471b2f --- /dev/null +++ b/sources/SEDIT-COMMENTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:47:02" IL:|{DSK}local>lde>lispcore>sources>SEDIT-COMMENTS.;2| 42559 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-COMMENTSCOMS) IL:|previous| IL:|date:| "27-Apr-88 11:20:49" IL:|{DSK}local>lde>lispcore>sources>SEDIT-COMMENTS.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-COMMENTSCOMS) (IL:RPAQQ IL:SEDIT-COMMENTSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-COMMENTS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-COMMENTS) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:CONSTANTS (LEVEL-1-COMMENT 'IL:\;) (LEVEL-2-COMMENT 'IL:|;;|) (LEVEL-3-COMMENT 'IL:|;;;|) (LEVEL-4-COMMENT 'IL:|;;;;|) (LEVEL-5-COMMENT 'IL:\|) (COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT))) (IL:FNS BACKSPACE-COMMENT CFV-COMMENT CLOSE-NODE-COMMENT COMMENT-LENGTH COMPUTE-COMMENT-COLUMN COMPUTE-POINT-POSITION-COMMENT COMPUTE-SELECTION-POSITION-COMMENT COPY-SELECTION-COMMENT COPY-STRUCTURE-COMMENT COPY-STRUCTURE-COMMENT-WORD CREATE-NEW-COMMENT DEGRADE-COMMENT DELETE-COMMENT INITIALIZE-COMMENTS INSERT-COMMENT SPLIT-COMMENT INSERT-COMMENT-CHARS LINEARIZE-COMMENT MAP-COMMENT-INDEX PARSE--COMMENT PARSE--COMMENT-WORD PARSE-STRING-INTO-WORDS SELECT-SEGMENT-COMMENT SET-POINT-COMMENT SET-POINT-COMMENT-WORD SET-SELECTION-COMMENT SET-SELECTION-COMMENT-WORD SIMPLE-STRING-OFFSET SIMPLE-STRING-SCAN START-COMMENT STRINGIFY-COMMENT CREATE-COMMENT-WORD-NODE CREATE-COMMENT-WORD-NODES UNDO-COMMENT-CHANGE UPGRADE-COMMENT) (IL:FUNCTIONS MAKE-COMMENT-STRING VERIFY-COMMENT))) (IL:PUTPROPS IL:SEDIT-COMMENTS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-COMMENTS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:DECLARE\: IL:EVAL@COMPILE (IL:RPAQQ LEVEL-1-COMMENT IL:\;) (IL:RPAQQ LEVEL-2-COMMENT IL:|;;|) (IL:RPAQQ LEVEL-3-COMMENT IL:|;;;|) (IL:RPAQQ LEVEL-4-COMMENT IL:|;;;;|) (IL:RPAQQ LEVEL-5-COMMENT IL:\|) (IL:RPAQ COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (IL:RPAQ COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT)) (IL:CONSTANTS (LEVEL-1-COMMENT 'IL:\;) (LEVEL-2-COMMENT 'IL:|;;|) (LEVEL-3-COMMENT 'IL:|;;;|) (LEVEL-4-COMMENT 'IL:|;;;;|) (LEVEL-5-COMMENT 'IL:\|) (COMMENT-LEVEL-TABLE (LIST LEVEL-1-COMMENT 1 LEVEL-2-COMMENT 2 LEVEL-3-COMMENT 3 LEVEL-4-COMMENT 4 LEVEL-5-COMMENT 5)) (COMMENT-MARKERS (LIST LEVEL-1-COMMENT LEVEL-2-COMMENT LEVEL-3-COMMENT LEVEL-4-COMMENT LEVEL-5-COMMENT))) ) (IL:DEFINEQ (backspace-comment (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 09:50 by DCB") (il:* il:\; "the BackSpace method for comments") (cond ((null index) (il:* il:\; "backspacing from the right boundary puts the caret immediately after the last character") (let ((point (il:fetch caret-point il:of context))) (close-open-node context) (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (il:nchars (caddr (il:fetch structure il:of node)))) (il:replace point-type il:of point il:with (quote string)))) ((eq 0 index) (cond ((il:igreaterp (il:fetch unassigned il:of node) 1) (il:* il:\; "backspacing over one of the semicolons") (degrade-comment context node)) ((null (cdr (il:fetch sub-nodes il:of node))) (il:* il:\; "backspacing from the front of an empty comment deletes it") (delete-nodes (il:fetch super-node il:of node) context node nil (il:fetch caret-point il:of context))))) (t (il:* il:\; "otherwise, delete the character to the left of the caret") (delete-comment node context index nil (il:fetch caret-point il:of context)))) (set-selection-nowhere (il:fetch selection il:of context))) ) (cfv-comment (il:lambda (node environment context format) (il:* il:\; "Edited 12-Feb-88 16:48 by raf") (il:* il:|;;;| "compute the width estimates for a comment node") (il:replace inline-width il:of node il:with nil) (il:* il:\; "dispatch on the comment level") (let ((width (il:fetch comment-width il:of context))) (il:selectq (il:fetch unassigned il:of node) (1 (il:* il:|;;| "here we know the comment width") (il:replace preferred-width il:of node il:with width)) (2 (il:* il:|;;| "these affect the super-node's formatting. We don't generally want double-semi comments to force us into miser mode, so guess small") (il:replace preferred-width il:of node il:with 30)) ((3 4 5) (il:* il:|;;| "since these won't affect supernode's formattng, just guess small") (il:replace preferred-width il:of node il:with 30)) (il:shouldnt "unexpected value for comment level")))) ) (close-node-comment (il:lambda (context node) (il:* il:\; "Edited 13-Apr-88 14:45 by woz") (undo-by undo-comment-change node (caddr (il:fetch structure il:of node))) (rplaca (cddr (il:|fetch| structure il:|of| node)) (make-comment-string node)) (il:|replace| open-node il:|of| context il:|with| nil))) (comment-length (il:lambda (node number-of-subnodes) (il:* il:\; "Edited 13-Apr-88 14:25 by woz") (il:|for| i il:|from| 1 il:|to| number-of-subnodes il:|as| subnode il:|in| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|sum| (il:nchars (il:|fetch| structure il:|of| subnode))))) (compute-comment-column (il:lambda (context window) (il:* il:\; "Edited 7-Jul-87 09:50 by DCB") (let ((environment (il:fetch environment il:of context))) (il:* il:|;;| "set the context's comment column info based on the window.") (il:replace comment-width il:of context il:with (il:iquotient (il:itimes (il:windowprop window (quote il:width)) (il:fetch comment-width-percent il:of environment)) 100)) (il:replace comment-separation il:of context il:with (il:fetch init-comment-separation il:of environment)))) ) (compute-point-position-comment (il:lambda (point context) (il:* il:\; "Edited 17-Nov-87 11:47 by DCB") (il:* il:|;;;| "implements the ComputePointPosition method for a comment") (let ((node (il:fetch point-node il:of point)) subnode) (map-comment-index context node (il:fetch point-index il:of point)) (il:setq subnode (car (il:fetch \\y il:of context))) (cond ((null subnode) (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of node) (il:fetch width il:of (car (il:fetch linear-form il:of node))))) (il:replace point-line il:of point il:with (il:fetch first-line il:of node))) (t (il:replace point-line il:of point il:with (il:fetch first-line il:of subnode)) (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of subnode) (simple-string-offset (car (il:fetch linear-form il:of subnode)) (il:fetch \\x il:of context)))))))) ) (compute-selection-position-comment (il:lambda (selection context) (il:* il:\; "Edited 17-Nov-87 11:48 by DCB") (il:* il:|;;;| "implements the ComputeSelectionPosition method for a comment") (let ((node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection))) (map-comment-index context node start (or (il:fetch select-end il:of selection) start)) (let ((start-subnode (car (il:fetch \\y il:of context))) (end-subnode (car (il:fetch \\t il:of context)))) (il:replace select-start-line il:of selection il:with (il:fetch first-line il:of start-subnode)) (il:replace select-start-x il:of selection il:with (il:iplus (il:fetch start-x il:of start-subnode) (simple-string-offset (car (il:fetch linear-form il:of start-subnode)) (il:sub1 (il:fetch \\x il:of context))))) (il:replace select-end-line il:of selection il:with (il:fetch first-line il:of end-subnode)) (il:replace select-end-x il:of selection il:with (il:iplus (il:fetch start-x il:of end-subnode) (simple-string-offset (car (il:fetch linear-form il:of end-subnode)) (il:fetch \\z il:of context))))))) ) (copy-selection-comment (il:lambda (selection context destination point delete?) (il:* il:\; "Edited 23-Feb-88 11:37 by raf") (il:* il:|;;;| "method for shift selecting a comment anywhere.") (let ((node (il:fetch select-node il:of selection)) (comment (caddr (il:fetch structure il:of (il:fetch select-node il:of selection)))) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (promptwindow (get-prompt-window (or destination context))) insert) (cond ((and start (or (il:neq (or end (il:setq end start)) (il:sub1 (il:nchars comment))) (il:neq start 0))) (il:* il:\; "some subset of the comment has been selected") (il:setq comment (il:substring comment start end))) (t (il:setq comment (stringify-comment node (il:fetch environment il:of context))))) (when delete? (delete-nodes node context start end)) (cond ((null destination) (il:* il:\; "it's going to a foreign sink; bksysbuf it") (il:bksysbuf comment (and (eq (il:fetch node-type il:of node) type-string) (null start)))) ((eq (il:fetch point-type il:of point) (quote string)) (il:* il:\; "comments insert as whole structures") (insert point destination comment)) (t (when (eq (il:fetch point-type il:of point) (quote atom)) (il:* il:\; "first make a structure point") (insert point destination nil)) (cond ((not start) (il:* il:\; "insert whole node") (insert point destination (copy-node node destination))) (t (il:setq insert (il:bind (stream il:_ (il:openstringstream comment)) obj il:while (il:setq obj (il:nlsetq (il:read stream))) il:collect (parse-new (car obj) destination))) (if insert (insert point destination insert) (il:|printout| promptwindow t "Selection not a valid structure.")))))))) ) (copy-structure-comment (il:lambda (node) (il:* il:\; "Edited 13-Apr-88 14:44 by woz") (il:|replace| structure il:|of| node il:|with| (list 'il:* (cadr (il:|fetch| structure il:|of| node)) (make-comment-string node))))) (copy-structure-comment-word (il:lambda (node) (il:* il:\; "Edited 13-Apr-88 14:28 by woz") (il:* il:|;;;| "the structure field of the new comment.word isn't completely built here, since it's supposed to be a list of all the words in the comment starting with this one. instead, we build one element lists for each comment.word, and copy.structure.comment links them all together") (let ((new-string (copy-seq (il:|fetch| structure il:|of| node)))) (il:|replace| structure il:|of| node il:|with| new-string) (rplaca (il:|fetch| linear-form il:|of| node) (il:|create| string-item il:|using| (car (il:|fetch| linear-form il:|of| node)) string il:_ new-string))))) (create-new-comment (il:lambda (context) (il:* il:\; "Edited 6-Apr-88 16:35 by woz") (let* ((width (il:|fetch| comment-width il:|of| context)) (comment (il:|create| edit-node node-type il:_ type-comment structure il:_ (list 'il:* 'il:\; "") depth il:_ 0 inline-width il:_ nil preferred-width il:_ width unassigned il:_ 1 sub-nodes il:_ (list 0)))) (il:|replace| linear-form il:|of| comment il:|with| (create-weak-link comment)) comment))) (degrade-comment (il:lambda (context node) (il:* il:\; "Edited 7-Jul-87 09:53 by DCB") (rplaca (cdr (il:fetch structure il:of node)) (car (il:nth comment-markers (il:add (il:fetch unassigned il:of node) -1)))) (note-change node context) (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (il:* il:\; "this node has a supernode that is not the root") (note-change (il:fetch super-node il:of node) context)) (undo-by upgrade-comment node)) ) (delete-comment (il:lambda (node context start end set-point?) (il:* il:\; "Edited 27-Apr-88 11:14 by woz") (il:* il:|;;;| "the Delete method for comments") (when (il:neq (il:|fetch| open-node il:|of| context) node) (close-open-node context) (il:|replace| open-node il:|of| context il:|with| node)) (il:|replace| open-node-changed? il:|of| context il:|with| t) (when set-point? (il:|replace| point-node il:|of| set-point? il:|with| node) (il:|replace| point-index il:|of| set-point? il:|with| (il:sub1 start)) (il:|replace| point-type il:|of| set-point? il:|with| (quote string))) (map-comment-index context node start (or end start)) (prog* ((start-index (il:|fetch| \\x il:|of| context)) (start-node (car (il:|fetch| \\y il:|of| context))) (end-index (il:|fetch| \\z il:|of| context)) (end-node (car (il:|fetch| \\t il:|of| context))) (number-of-subnodes (car (il:|fetch| sub-nodes il:|of| node))) node-index string length new-width) (when (eq start-node end-node) (il:setq string (il:|fetch| string il:|of| (car (il:|fetch| linear-form il:|of| start-node)))) (il:setq length (il:nchars string)) (il:setq node-index (il:|fetch| sub-node-index il:|of| start-node)) (when (not (or (and (eq start-index 1) (il:neq node-index 1) (or (eq end-index length) (eq (il:nthcharcode string (il:add1 end-index)) (il:charcode il:sp)))) (and (eq end-index length) (il:neq node-index number-of-subnodes) (or (eq start-index 1) (il:neq (il:nthcharcode string (il:sub1 start-index)) (il:charcode il:sp)))))) (il:* il:|;;| "we're not going to merge -- fast case") (cond ((and (eq start-index 1) (eq end-index length)) (il:* il:\; "everything deleted!") (il:|replace| open-node il:|of| context il:|with| nil) (il:|replace| open-node-changed? il:|of| context il:|with| nil) (rplaca (cddr (il:|fetch| structure il:|of| node)) (il:concat "")) (il:|replace| sub-nodes il:|of| node il:|with| (list 0)) (note-change node context)) (t (il:setq new-width (il:idifference (il:|fetch| inline-width il:|of| start-node) (stringwidth (il:substring string start-index end-index) (il:|fetch| font il:|of| (car (il:|fetch| linear-form il:|of| start-node)))))) (il:setq string (il:concat (or (il:substring string 1 (il:sub1 start-index)) "") (or (il:substring string (il:add1 end-index)) ""))) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| start-node)) il:|with| string) (il:|replace| structure il:|of| start-node il:|with| string) (adjust-width start-node context new-width))) (let ((caret (il:|fetch| caret-point il:|of| context))) (when (and (il:neq caret set-point?) (eq (il:|fetch| point-node il:|of| caret) node) (il:igeq (il:|fetch| point-index il:|of| caret) start)) (il:* il:|;;| "if the caret was within or after replaced characters, it will need to be fixed up") (il:|replace| point-index il:|of| caret il:|with| (il:idifference (il:|fetch| point-index il:|of| caret) (il:idifference (il:add1 end-index) start-index))))) (return))) (il:setq length (il:nchars (caddr (il:|fetch| structure il:|of| node)))) (il:* il:\; "save old length") (il:setq string (il:concat (or (il:substring (il:|fetch| structure il:|of| start-node) 1 (il:sub1 start-index)) "") (or (il:substring (il:|fetch| structure il:|of| end-node) (il:add1 end-index)) ""))) (il:|for| subnode-index il:|from| (il:|fetch| sub-node-index il:|of| start-node) il:|bind| nodes rest-nodes il:|first| (il:setq nodes (il:nth (il:|fetch| sub-nodes il:|of| node) subnode-index)) (il:setq rest-nodes (cdr (il:|fetch| \\t il:|of| context))) (rplacd nodes rest-nodes) il:|while| rest-nodes il:|do| (il:|replace| sub-node-index il:|of| (car rest-nodes) il:|with| subnode-index) (il:setq rest-nodes (cdr rest-nodes)) il:|finally| (rplaca (il:|fetch| sub-nodes il:|of| node) (il:sub1 subnode-index)) (when (il:igreaterp (il:nchars string) 0) (insert-comment-chars context node (and (il:neq (il:|fetch| sub-node-index il:|of| start-node) 1) nodes) nil string))) (note-change node context) (let ((caret (il:|fetch| caret-point il:|of| context))) (when (and (il:neq caret set-point?) (eq (il:|fetch| point-node il:|of| caret) node) (il:igeq (il:|fetch| point-index il:|of| caret) start)) (il:* il:|;;| "if the caret was within or after replaced characters, it will need to be fixed up") (il:|replace| point-index il:|of| caret il:|with| (il:idifference (il:|fetch| point-index il:|of| caret) (il:idifference (il:add1 (or end start)) start)))))) t) ) (initialize-comments (il:lambda nil (il:* il:\; "Edited 7-Jul-87 09:54 by DCB") (il:setq types (list* (il:setq type-comment (il:create edit-node-type name il:_ (quote comment) assign-format il:_ (quote il:nill) compute-format-values il:_ (quote cfv-comment) linearize il:_ (quote linearize-comment) set-point il:_ (quote set-point-comment) set-selection il:_ (quote set-selection-comment) grow-selection il:_ (quote grow-selection-litatom) select-segment il:_ (quote select-segment-comment) compute-point-position il:_ (quote compute-point-position-comment) compute-selection-position il:_ (quote compute-selection-position-comment) insert il:_ (quote insert-comment) delete il:_ (quote delete-comment) copy-structure il:_ (quote copy-structure-comment) copy-selection il:_ (quote copy-selection-comment) stringify il:_ (quote stringify-comment) back-space il:_ (quote backspace-comment) close-node il:_ (quote close-node-comment))) (il:setq type-comment-word (il:create edit-node-type name il:_ (quote comment-word) assign-format il:_ (quote il:nill) compute-format-values il:_ (quote il:nill) set-point il:_ (quote set-point-comment-word) set-selection il:_ (quote set-selection-comment-word) copy-structure il:_ (quote copy-structure-comment-word))) types))) ) (insert-comment (il:lambda (node context where chars point) (il:* il:\; "Edited 17-Jul-87 09:59 by DCB") (il:* il:|;;;| "the Insert method for comments") (let (start) (cond ((il:type? edit-selection where) (il:setq start (il:sub1 (il:fetch select-start il:of where))) (delete-comment node context (il:add1 start) (or (il:fetch select-end il:of where) (il:add1 start)))) (t (il:setq start (il:fetch point-index il:of where)))) (cond (chars (map-comment-index context node start) (when (il:neq (il:fetch open-node il:of context) node) (close-open-node context) (il:replace open-node il:of context il:with node)) (il:replace open-node-changed? il:of context il:with t) (insert-comment-chars context node (il:fetch \\y il:of context) (il:fetch \\x il:of context) chars) (note-change node context) (when point (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (il:iplus start (il:nchars chars))))) (t (split-comment node point context start))))) ) (split-comment (il:lambda (node point context start) (il:* il:\; "Edited 7-Jul-87 09:54 by DCB") (close-open-node context) (let* ((comment (caddr (il:fetch structure il:of node))) (length (il:nchars comment)) (split-string (il:substring comment (il:add1 start) length))) (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) t node (quote structure)) (when (il:neq start length) (il:* il:\; "split in middle of comment.") (delete-nodes node context (il:add1 start) length nil comment) (insert point context (parse-new (list (quote il:*) (car (il:nth comment-markers (il:fetch unassigned il:of node))) split-string) context)) (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) t node (quote structure))))) ) (insert-comment-chars (il:lambda (context node subnodes index chars) (il:* il:\; "Edited 13-Apr-88 16:55 by woz") (il:* il:|;;;| "what a hack. ugh blech.") (let ((length (il:nchars chars)) (subnode (car subnodes)) (font (il:|fetch| comment-font il:|of| (il:|fetch| environment il:|of| context))) string string-length) (when subnode (il:setq string (il:|fetch| structure il:|of| subnode)) (il:setq string-length (il:nchars string)) (when (eq index string-length) (il:setq index nil))) (cond ((and (eq length 1) subnode (if (eq (il:chcon1 chars) (il:charcode il:sp)) (or (null index) (eq (il:nthcharcode string (il:add1 index)) (il:charcode il:sp))) (or (eq index 0) (il:neq (il:nthcharcode string (or index string-length)) (il:charcode il:sp))))) (il:* il:|;;| "fast case") (il:setq chars (il:mkstring chars)) (il:setq string (il:concat (or (il:substring string 1 index) "") chars (or (and index (il:substring string (il:add1 index))) ""))) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| string) (il:|replace| structure il:|of| subnode il:|with| string) (adjust-width subnode context (il:iplus (il:|fetch| inline-width il:|of| subnode) (stringwidth chars font)))) (t (cond ((eq index 0) (il:setq subnodes (and (il:neq (il:|fetch| sub-node-index il:|of| subnode) 1) (il:nth (il:|fetch| sub-nodes il:|of| node) (il:|fetch| sub-node-index il:|of| subnode)))) (il:setq subnode (car subnodes))) (index (let* ((new-string (il:substring string (il:add1 index))) (new-subnode (create-simple-node new-string (il:|fetch| environment il:|of| context) type-comment-word new-string nil font))) (adjust-width subnode context (il:idifference (il:|fetch| inline-width il:|of| subnode) (il:|fetch| inline-width il:|of| new-subnode))) (rplacd subnodes (cons new-subnode (cdr subnodes))) (il:setq new-string (il:substring string 1 index)) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| new-string) (il:|replace| structure il:|of| subnode il:|with| new-string)))) (let ((words (create-comment-word-nodes chars (if subnodes (cdr subnodes) (cdr (il:|fetch| sub-nodes il:|of| node))) (il:|fetch| environment il:|of| context)))) (if subnodes (rplacd subnodes words) (rplacd (il:|fetch| sub-nodes il:|of| node) words))) (il:|for| il:|old| subnodes il:|on| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|bind| (n il:_ 0) next-subnode string (depth il:_ (il:add1 (il:|fetch| depth il:|of| node))) il:|do| (il:setq n (il:add1 n)) (il:setq subnode (car subnodes)) (il:|replace| sub-node-index il:|of| subnode il:|with| n) (il:|replace| super-node il:|of| subnode il:|with| node) (il:|replace| depth il:|of| subnode il:|with| depth) (il:setq string (il:|fetch| structure il:|of| subnode)) (il:|while| (and (il:setq next-subnode (cadr subnodes)) (or (il:neq (il:nthcharcode string (il:nchars string)) (il:charcode il:sp)) (eq (il:chcon1 (car (il:|fetch| structure il:|of| next-subnode))) (il:charcode il:sp)))) il:|do| (il:setq string (il:concat string (il:|fetch| structure il:|of| next-subnode))) (il:|replace| structure il:|of| subnode il:|with| string) (il:|replace| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)) il:|with| string) (adjust-width subnode context (il:iplus (il:|fetch| inline-width il:|of| subnode) (il:|fetch| inline-width il:|of| next-subnode))) (rplacd subnodes (cddr subnodes))) il:|finally| (rplaca (il:|fetch| sub-nodes il:|of| node) n)))))) ) (linearize-comment (il:lambda (node context index) (il:* il:\; "Edited 23-Feb-88 11:18 by raf") (let* ((level (il:|fetch| unassigned il:|of| node)) (environment (il:|fetch| environment il:|of| context)) (prefix (il:listget (il:|fetch| comment-string il:|of| environment) level))) (il:|bind| (il:first il:_ t) il:|for| subnode il:|in| (cond (index (cddr (il:nth (il:|fetch| sub-nodes il:|of| node) index))) (t (il:* il:|;;| "we're at the beginning, so display the prefix") (output-constant-string context prefix) (cdr (il:|fetch| sub-nodes il:|of| node)))) il:|do| (cond ((or il:first (il:ileq (il:iplus (il:|fetch| current-x il:|of| context) (il:|fetch| inline-width il:|of| subnode)) (il:|fetch| right-margin il:|of| node))) (linearize subnode context)) (t (output-cr context (il:|fetch| start-x il:|of| node)) (unless (eq 5 level) (output-constant-string context prefix)) (linearize subnode context))) (il:setq il:first nil)) (when (eq 5 level) (output-constant-string context (il:listget (il:fetch comment-string il:of environment) 6))))) ) (map-comment-index (il:lambda (context node start end) (il:* il:\; "Edited 13-Apr-88 14:26 by woz") (il:|bind| length subnode (index il:_ start) (open-node il:_ (il:|fetch| open-node il:|of| context)) il:|for| subnodes il:|on| (cdr (il:|fetch| sub-nodes il:|of| node)) il:|do| (il:setq subnode (car subnodes)) (il:setq length (if (eq subnode open-node) (il:|fetch| real-length il:|of| (il:|fetch| string il:|of| (car (il:|fetch| linear-form il:|of| subnode)))) (il:nchars (il:|fetch| structure il:|of| subnode)))) (cond ((il:igreaterp index length) (il:setq index (il:idifference index length))) (t (when start (il:|replace| \\x il:|of| context il:|with| index) (il:|replace| \\y il:|of| context il:|with| subnodes) (when (null end) (return)) (il:setq index (il:iplus index (il:idifference end start))) (when (il:igreaterp index length) (il:setq index (il:idifference index length)) (il:setq start nil) (il:setq end nil) (go il:$$iterate))) (il:|replace| \\z il:|of| context il:|with| index) (il:|replace| \\t il:|of| context il:|with| subnodes) (return))) il:|finally| (il:|replace| \\x il:|of| context il:|with| nil) (il:|replace| \\y il:|of| context il:|with| nil) (il:|replace| \\z il:|of| context il:|with| nil) (il:|replace| \\t il:|of| context il:|with| nil)))) (parse--comment (il:lambda (structure context) (il:* il:\; "Edited 27-Apr-88 11:12 by woz") (il:* il:|;;;| "try to parse this list as a common lisp comment. the second element should be one or more semicolons, and the rest of the list should be a string") (let (comment-words (level (and (cdr structure) (il:listget comment-level-table (cadr structure))))) (when (and level (cddr structure) (null (cdddr structure)) (il:stringp (caddr structure)) (or (null (il:|fetch| current-node il:|of| context)) (il:fmemb (il:|fetch| name il:|of| (il:|fetch| node-type il:|of| (il:|fetch| current-node il:|of| context))) (quote (form clisp lambda list))))) (build-node structure context type-comment t) (cond ((not (il:|fetch| \\x il:|of| context)) (il:* il:|;;| "if we're here for the first time then parse afresh.") (il:setq comment-words (parse-string-into-words (caddr structure))) (il:|for| word il:|in| comment-words il:|do| (parse word context (il:function parse--comment-word))) (il:|replace| unassigned il:|of| (il:|fetch| current-node il:|of| context) il:|with| level)) ((and nil (not (verify-comment (il:|fetch| current-node il:|of| context)))) (il:* il:|;;| "the comment changed from underneath us. trash the subnodes and reparse.") (il:* il:|;;| "couldn't get this to work. not absolutely at this point, so leave the case out.")) (t (il:* il:|;;| "flag that everything matched.") (il:|replace| \\x il:|of| context il:|with| nil))) t))) ) (parse--comment-word (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:* il:|;;;| "parse a comment word. different from string in that it does not use PRIN2 (does not print quotes round itself) and it uses a different font.") (build-prelinearized-node structure context type-comment-word structure nil (il:fetch comment-font il:of (il:fetch environment il:of context)))) ) (parse-string-into-words (il:lambda (chars) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:bind (end il:_ (il:nchars chars)) ok? result i il:first (il:setq i end) il:while (il:neq i 0) il:do (cond ((il:neq (il:nthcharcode chars i) (il:charcode il:sp)) (il:setq ok? t)) (ok? (il:setq result (cons (il:substring chars (il:add1 i) end) result)) (il:setq end i) (il:setq ok? nil))) (il:setq i (il:sub1 i)) il:finally (return (and (il:neq end 0) (cons (il:substring chars 1 end) result))))) ) (select-segment-comment (il:lambda (selection context node subnode index sub-offset sub-item) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "the SelectSegment method for comments") (let ((start (il:fetch select-start il:of selection)) new) (when (and start subnode) (il:setq new (il:iplus (comment-length node (il:sub1 (il:fetch sub-node-index il:of subnode))) (simple-string-scan sub-item sub-offset))) (il:replace select-end il:of selection il:with (il:imax new (or (il:fetch select-end il:of selection) start))) (when (il:ilessp new start) (il:replace select-start il:of selection il:with new)) (compute-selection-position-comment selection context)))) ) (set-point-comment (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 11-Apr-88 16:46 by woz") (il:* il:|;;;| "the SetPoint method for comments") (cond ((null index) (setq index (and offset (il:nchars (caddr (il:|fetch| structure il:|of| node)))))) (t (setq item (il:nth (il:|fetch| linear-form il:|of| node) (il:add1 index))) (cond ((il:listp item) (if (il:|type?| weak-link (car item)) (setq item (il:|fetch| destination il:|of| (car item))) (setq item (il:|fetch| destination il:|of| (cadr item)))) (setq index (comment-length node (il:sub1 (il:|fetch| sub-node-index il:|of| item))))) (t (setq index 0))))) (cond (index (il:|replace| point-node il:|of| point il:|with| node) (il:|replace| point-index il:|of| point il:|with| index) (il:|replace| point-type il:|of| point il:|with| (quote string)) (when compute-location? (compute-point-position-comment point context))) (t (set-point-nowhere point)))) ) (set-point-comment-word (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:replace point-node il:of point il:with (il:fetch super-node il:of node)) (il:replace point-index il:of point il:with (il:iplus (comment-length (il:fetch super-node il:of node) (il:sub1 (il:fetch sub-node-index il:of node))) (simple-string-scan (car (il:fetch linear-form il:of node)) offset t))) (il:replace point-type il:of point il:with (quote string)) (when compute-location? (compute-point-position-comment point context))) ) (set-selection-comment (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "the SetSelection method for comments") (if (il:type? string-item item) (set-selection-me selection context node) (set-selection-nowhere selection))) ) (set-selection-comment-word (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 7-Jul-87 11:12 by DCB") (il:replace select-node il:of selection il:with (il:fetch super-node il:of node)) (il:replace select-start il:of selection il:with (il:iplus (comment-length (il:fetch super-node il:of node) (il:sub1 (il:fetch sub-node-index il:of node))) (simple-string-scan (car (il:fetch linear-form il:of node)) offset))) (il:replace select-end il:of selection il:with nil) (il:replace select-type il:of selection il:with (quote string)) (compute-selection-position-comment selection context)) ) (simple-string-offset (il:lambda (stringitem index) (il:* il:\; "Edited 17-Nov-87 11:54 by DCB") (il:* il:|;;;| "compute the width of the first index characters in this stringitem. PRIN2? is assumed to be false!") (il:* il:|;;| "(bind (font _ (fetch Font of stringitem)) (string _ (fetch String of stringitem)) for i from 1 to index sum (CHARWIDTH (NTHCHARCODE string i) font))") (if (il:igreaterp index 0) (stringwidth (il:substring (il:fetch string il:of stringitem) 1 index) (il:fetch font il:of stringitem)) 0)) ) (simple-string-scan (il:lambda (stringitem offset point?) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (il:bind (string il:_ (il:fetch string il:of stringitem)) (font il:_ (il:fetch font il:of stringitem)) (index il:_ 0) length cwidth il:first (il:setq length (il:nchars string)) il:while (il:ileq (il:setq index (il:add1 index)) length) il:do (il:setq cwidth (il:nthcharcode string index)) (il:setq cwidth (if (il:ilessp cwidth 32) (il:iplus (il:charwidth (il:charcode il:^) font) (il:charwidth (il:iplus 64 cwidth) font)) (il:charwidth cwidth font))) (if point? (when (il:ileq offset (il:half cwidth)) (return (il:sub1 index))) (when (il:ileq offset cwidth) (return index))) (il:setq offset (il:idifference offset cwidth)) il:finally (return (il:sub1 index)))) ) (start-comment (il:lambda (context charcode) (il:* il:\; "Edited 24-Nov-87 10:22 by DCB") (let* ((caret-point (il:fetch caret-point il:of context)) (point-node (il:fetch point-node il:of caret-point)) (point-type (il:fetch point-type il:of caret-point)) new-node) (cond ((null point-node) nil) ((eq point-type (quote string)) (when (and (il:type? edit-node point-node) (eq (il:fetch node-type il:of point-node) type-comment) (eq 0 (il:fetch point-index il:of caret-point))) (upgrade-comment context point-node) t)) ((eq point-type (quote esc-atom)) nil) (t (when (il:type? edit-selection point-node) (il:setq point-node (if (il:fetch select-start il:of point-node) (il:fetch select-node il:of point-node) (il:fetch super-node il:of (il:fetch select-node il:of point-node))))) (cond ((eq (il:fetch node-type il:of point-node) type-quote) t) (t (insert caret-point context (list (il:setq new-node (create-new-comment context)))) (when (not (dead-node? new-node)) (il:replace point-node il:of caret-point il:with new-node) (il:replace point-index il:of caret-point il:with 0) (il:replace point-type il:of caret-point il:with (quote string)) (set-selection-nowhere (il:fetch selection il:of context))) t)))))) ) (stringify-comment (il:lambda (node environment) (il:* il:\; "Edited 23-Feb-88 11:18 by raf") (let ((level (il:|fetch| unassigned il:|of| node))) (ecase level ((0 1 2 3 4) (il:concat (cadr (il:|fetch| structure il:|of| node)) " " (caddr (il:|fetch| structure il:|of| node)))) (5 (il:concat (il:|fetch| (string-item string) il:|of| (il:listget (il:|fetch| comment-string il:|of| environment) 5)) (caddr (il:|fetch| structure il:|of| node)) (il:|fetch| (string-item string) il:|of| (il:listget (il:|fetch| comment-string il:|of| environment) 6))))))) ) (create-comment-word-node (il:lambda (chars environment) (il:* il:\; "Edited 13-Apr-88 14:51 by woz") (create-simple-node chars environment type-comment-word chars nil (il:|fetch| comment-font il:|of| environment)))) (create-comment-word-nodes (il:lambda (chars subnodes environment) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (il:|bind| (end il:_ (il:nchars chars)) i ok? il:|first| (il:setq i end) il:|while| (il:neq i 0) il:|do| (cond ((il:neq (il:nthcharcode chars i) (il:charcode il:sp)) (il:setq ok? t)) (ok? (push (create-comment-word-node (il:substring chars (il:add1 i) end) environment) subnodes) (il:setq end i) (il:setq ok? nil))) (il:setq i (il:sub1 i)) il:|finally| (return (cons (create-comment-word-node (il:substring chars 1 end) environment) subnodes))))) (undo-comment-change (il:lambda (context node old-value) (il:* il:\; "Edited 13-Apr-88 15:31 by woz") (undo-by undo-comment-change node (caddr (il:fetch structure il:of node))) (let ((comment-words (parse-string-into-words old-value)) (subnodes (il:|fetch| sub-nodes il:|of| node))) (rplaca (cddr (il:|fetch| structure il:|of| node)) old-value) (il:|for| word il:|in| comment-words il:|as| sub-node-index il:|from| 1 il:|do| (cond ((cdr subnodes) (il:|replace| structure il:|of| (cadr subnodes) il:|with| word) (note-change-in-simple (cadr subnodes) context)) (t (il:nconc1 subnodes (create-simple-node word (il:|fetch| environment il:|of| context) type-comment-word word nil (il:|fetch| comment-font il:|of| (il:|fetch| environment il:|of| context)))) (il:|replace| super-node il:|of| (cadr subnodes) il:|with| node) (il:|replace| sub-node-index il:|of| (cadr subnodes) il:|with| sub-node-index))) (il:setq subnodes (cdr subnodes)) il:|finally| (il:* il:\;  "throw away extra subnodes") (rplacd subnodes) (rplaca (il:|fetch| sub-nodes il:|of| node) (il:flength comment-words))) (note-change node context)))) (upgrade-comment (il:lambda (context node) (il:* il:\; "Edited 7-Jul-87 11:13 by DCB") (when (il:ilessp (il:fetch unassigned il:of node) (il:constant (il:length comment-markers))) (rplaca (cdr (il:fetch structure il:of node)) (car (il:nth comment-markers (il:add (il:fetch unassigned il:of node) 1)))) (note-change node context) (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (il:* il:\; "this node has a supernode that is not the root") (note-change (il:fetch super-node il:of node) context)) (undo-by degrade-comment node))) ) ) (DEFUN MAKE-COMMENT-STRING (NODE) (IL:* IL:|;;;| "get the comment words from the subnodes and put them together into one string (as efficiently as possible)") (LET* ((SUBNODES (CDR (IL:|fetch| SUB-NODES IL:|of| NODE))) (LENGTH (LET ((SUM 0)) (DOLIST (SUBNODE SUBNODES SUM) (INCF SUM (LENGTH (IL:|fetch| STRUCTURE IL:|of| SUBNODE)))))) (STRING (MAKE-STRING LENGTH)) (POINTER 0)) (DOLIST (SUBNODE SUBNODES STRING) (LET ((WORD (IL:|fetch| STRUCTURE IL:|of| SUBNODE))) (REPLACE STRING WORD :START1 POINTER) (INCF POINTER (LENGTH WORD)))))) (DEFUN VERIFY-COMMENT (NODE) (IL:* IL:|;;;| "check the comment in this node the strings in the subnodes (ie verify-comment). return T if they match, NIL otherwise.") (LET* ((POINTER 0) (STRING (THIRD (IL:FETCH STRUCTURE IL:OF NODE))) (STRING-LENGTH (LENGTH STRING))) (DOLIST (SUBNODE (CDR (IL:|fetch| SUB-NODES IL:|of| NODE)) T) (LET* ((WORD (IL:|fetch| STRUCTURE IL:|of| SUBNODE)) (WORD-LENGTH (LENGTH WORD))) (WHEN (MISMATCH STRING WORD :START1 POINTER :END1 (MIN (INCF POINTER (LENGTH WORD)) STRING-LENGTH)) (RETURN NIL)))))) (IL:PUTPROPS IL:SEDIT-COMMENTS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3870 40862 (BACKSPACE-COMMENT 3883 . 5036) (CFV-COMMENT 5038 . 5911) ( CLOSE-NODE-COMMENT 5913 . 6304) (COMMENT-LENGTH 6306 . 6669) (COMPUTE-COMMENT-COLUMN 6671 . 7187) ( COMPUTE-POINT-POSITION-COMMENT 7189 . 8062) (COMPUTE-SELECTION-POSITION-COMMENT 8064 . 9159) ( COPY-SELECTION-COMMENT 9161 . 10868) (COPY-STRUCTURE-COMMENT 10870 . 11376) ( COPY-STRUCTURE-COMMENT-WORD 11378 . 12293) (CREATE-NEW-COMMENT 12295 . 13026) (DEGRADE-COMMENT 13028 . 13488) (DELETE-COMMENT 13490 . 17882) (INITIALIZE-COMMENTS 17884 . 19152) (INSERT-COMMENT 19154 . 20143) (SPLIT-COMMENT 20145 . 20941) (INSERT-COMMENT-CHARS 20943 . 24376) (LINEARIZE-COMMENT 24378 . 25425) (MAP-COMMENT-INDEX 25427 . 27725) (PARSE--COMMENT 27727 . 29172) (PARSE--COMMENT-WORD 29174 . 29581) (PARSE-STRING-INTO-WORDS 29583 . 30076) (SELECT-SEGMENT-COMMENT 30078 . 30753) ( SET-POINT-COMMENT 30755 . 31708) (SET-POINT-COMMENT-WORD 31710 . 32289) (SET-SELECTION-COMMENT 32291 . 32588) (SET-SELECTION-COMMENT-WORD 32590 . 33207) (SIMPLE-STRING-OFFSET 33209 . 33732) ( SIMPLE-STRING-SCAN 33734 . 34502) (START-COMMENT 34504 . 35715) (STRINGIFY-COMMENT 35717 . 36271) ( CREATE-COMMENT-WORD-NODE 36273 . 36608) (CREATE-COMMENT-WORD-NODES 36610 . 37756) (UNDO-COMMENT-CHANGE 37758 . 40305) (UPGRADE-COMMENT 40307 . 40860))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-CONVERT b/sources/SEDIT-CONVERT new file mode 100644 index 00000000..ff356cee --- /dev/null +++ b/sources/SEDIT-CONVERT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:48:59" IL:|{DSK}local>lde>lispcore>sources>SEDIT-CONVERT.;2| 2271 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-CONVERTCOMS) IL:|previous| IL:|date:| "17-Nov-87 16:02:51" IL:|{DSK}local>lde>lispcore>sources>SEDIT-CONVERT.;1|) ; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-CONVERTCOMS) (IL:RPAQQ IL:SEDIT-CONVERTCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-CONVERT) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-CONVERT) (IL:FUNCTIONS INCOMS LOOKOLDCOM MAPINCOMS))) (IL:PUTPROPS IL:SEDIT-CONVERT IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-CONVERT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (DEFUN INCOMS (COMS PREDICATE &OPTIONAL (EDIT? T)) (DOLIST (COM COMS) (WHEN (FUNCALL PREDICATE COM) (PRINT COM)) (CASE (FIRST COM) ((IL:FNS IL:FUNCTIONS IL:VARS IL:MACROS) (DOLIST (F (REST COM)) (LET ((DEF (AND (ATOM F) (IL:NLSETQ (IL:GETDEF F (FIRST COM)))))) (WHEN (AND DEF (FUNCALL PREDICATE (FIRST DEF))) (PRINT (LIST F (FIRST COM))) (WHEN EDIT? (ED F (LIST (FIRST COM))))))))))) (DEFUN LOOKOLDCOM (DEF) (COND ((ATOM DEF) NIL) ((AND (EQ (FIRST DEF) 'IL:*) (NOT (MEMBER (SECOND DEF) '(IL:\; IL:|;;| IL:|;;;|)))) T) (T (SOME #'LOOKOLDCOM DEF)))) (DEFUN MAPINCOMS (PREDICATE &OPTIONAL (FILES IL:FILELST) (EDIT? T)) (DOLIST (F FILES) (PRINT F) (INCOMS (FIRST (IL:GETDEF F 'IL:FILES)) PREDICATE EDIT?))) (IL:PUTPROPS IL:SEDIT-CONVERT IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-DEBUG b/sources/SEDIT-DEBUG new file mode 100644 index 00000000..4e2a9456 --- /dev/null +++ b/sources/SEDIT-DEBUG @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "16-May-90 21:51:00" IL:|{DSK}local>lde>lispcore>sources>SEDIT-DEBUG.;2| 6465 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-DEBUGCOMS) IL:|previous| IL:|date:| "13-Apr-88 13:02:09" IL:|{DSK}local>lde>lispcore>sources>SEDIT-DEBUG.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-DEBUGCOMS) (IL:RPAQQ IL:SEDIT-DEBUGCOMS ((IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-DEBUG) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:VARS FILES) (IL:FUNCTIONS FNS-TO-FUNCTIONS LOADPROP-SOURCES DISTRIBUTE-CALL-INFO WHO-DOES) (IL:COMMANDS "icontext" "ienv" "ipoint" "isel" "inode"))) (IL:PUTPROPS IL:SEDIT-DEBUG IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-DEBUG IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQQ FILES (IL:SEDIT-DECLS IL:SEDIT IL:SEDIT-ACCESS IL:SEDIT-ATOMIC IL:SEDIT-BASE IL:SEDIT-COMMANDS IL:SEDIT-COMMENTS IL:SEDIT-DEBUG IL:SEDIT-EXPORTS IL:SEDIT-INDENT IL:SEDIT-LINEAR IL:SEDIT-LIST-FORMATS IL:SEDIT-LISTS IL:SEDIT-TERMINAL IL:SEDIT-TOPLEVEL IL:SEDIT-WINDOW)) (DEFUN FNS-TO-FUNCTIONS (SYM &OPTIONAL (EDIT? T) (EDITCOMS? NIL)) (IL:* IL:|;;;| "Sym is assumed to have a FNS definition. Give it a FUNCTIONS definition instead.") (LET ((OLDDEF (IL:GETDEF SYM 'IL:FNS))) (UNLESS (AND OLDDEF (LISTP OLDDEF) (EQ (FIRST OLDDEF) 'IL:LAMBDA)) (ERROR "Invalid or missing FNS definition for ~S." SYM)) (LET ((NEWDEF (COPY-TREE (LIST* 'DEFUN SYM (REST OLDDEF)))) (FILE (IL:WHEREIS SYM 'IL:FNS))) (IL:PUTDEF SYM 'IL:FUNCTIONS NEWDEF 'IL:DEFINED) (IL:DELDEF SYM 'IL:FNS) (UNLESS (IL:GETDEF SYM 'IL:FUNCTIONS) (ERROR "The functions definition went away!")) (WHEN EDIT? (ED SYM '(IL:FUNCTIONS))) (WHEN (AND FILE (LISTP FILE) (NULL (REST FILE))) (IL:ADDTOFILE SYM 'IL:FUNCTIONS (FIRST FILE)) (WHEN EDITCOMS? (ED (FIRST FILE) '(IL:FILES))))))) (DEFUN LOADPROP-SOURCES () (DECLARE (SPECIAL FILES)) (DOLIST (F FILES) (IL:LOAD F 'IL:ALLPROP))) (DEFUN DISTRIBUTE-CALL-INFO (&OPTIONAL FILE-LIST) (DECLARE (SPECIAL FILES)) (IL:FOR FILE IL:INSIDE (IL:U-CASE (OR FILE-LIST FILES)) IL:DO (IL:FOR FN IL:IN (APPEND (IL:FILECOMSLST FILE 'IL:FUNCTIONS) (IL:FILEFNSLST FILE)) IL:WHEN (IL:CCODEP FN) IL:DO (IL:BLOCK) (LET ((Y (IL:CALLSCCODE FN))) (IL:FOR Z IL:IN (CADR Y) IL:DO (IL:PUSHNEW (IL:GETPROP Z 'IL:CALLEDBY) FN)) (IL:FOR Z IL:IN (CADDR Y) IL:DO (IL:PUSHNEW (IL:GETPROP Z 'IL:BOUNDBY) FN)) (IL:FOR Z IL:IN (CADDDR Y) IL:DO (IL:PUSHNEW (IL:GETPROP Z 'IL:USEDFREEBY) FN)) (IL:FOR Z IL:IN (CAR (CDDDDR Y)) IL:DO (IL:PUSHNEW (IL:GETPROP Z 'IL:USEDGLOBALBY) FN)))))) (DEFUN WHO-DOES (METHOD-NAME) (LET (L FN) (DOLIST (TY TYPES) (WHEN (SETQ FN (IL:RECORDACCESS METHOD-NAME TY NIL 'IL:FETCH)) (IL:PUSHNEW L FN))) L)) (DEFCOMMAND "icontext" (&OPTIONAL (INSPECT? T) (WINDOWSPEC (IL:GETPOSITION))) (LET ((CONTEXT (IL:WINDOWPROP (IL:WHICHW WINDOWSPEC) 'EDIT-CONTEXT))) (WHEN INSPECT? (INSPECT CONTEXT)) NIL)) (DEFCOMMAND "ienv" (&OPTIONAL (INSPECT? T) (WINDOWSPEC (IL:GETPOSITION))) (LET ((ENV (IL:FETCH ENVIRONMENT IL:OF (IL:WINDOWPROP (IL:WHICHW WINDOWSPEC) 'EDIT-CONTEXT)))) (WHEN INSPECT? (INSPECT ENV)) ENV NIL)) (DEFCOMMAND "ipoint" (&OPTIONAL (INSPECT? T) (WINDOWSPEC (IL:GETPOSITION))) (LET ((POINT (IL:FETCH CARET-POINT IL:OF (IL:WINDOWPROP (IL:WHICHW WINDOWSPEC) 'EDIT-CONTEXT)))) (WHEN INSPECT? (INSPECT POINT)) POINT NIL)) (DEFCOMMAND "isel" (&OPTIONAL (INSPECT? T) (WINDOWSPEC (IL:GETPOSITION))) (LET ((SELECTION (IL:FETCH SELECTION IL:OF (IL:WINDOWPROP (IL:WHICHW WINDOWSPEC) 'EDIT-CONTEXT)))) (WHEN INSPECT? (INSPECT SELECTION)) NIL)) (DEFCOMMAND "inode" (&OPTIONAL (WINDOWSPEC (IL:GETPOSITION))) (INSPECT (IL:FETCH SELECT-NODE IL:OF (IL:FETCH SELECTION IL:OF (IL:WINDOWPROP (IL:WHICHW WINDOWSPEC) 'EDIT-CONTEXT)))) NIL) (IL:PUTPROPS IL:SEDIT-DEBUG IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-DECLS b/sources/SEDIT-DECLS new file mode 100644 index 00000000..6f1518ec --- /dev/null +++ b/sources/SEDIT-DECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "19-Jan-93 11:18:34" IL:|{DSK}lde>lispcore>sources>SEDIT-DECLS.;3| 50314 IL:|changes| IL:|to:| (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) IL:|previous| IL:|date:| " 5-Jan-93 02:19:37" IL:|{DSK}lde>lispcore>sources>SEDIT-DECLS.;2|) ; Copyright (c) 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-DECLSCOMS) (IL:RPAQQ IL:SEDIT-DECLSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-DECLS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-DECLS) (IL:* IL:|;;;| "This file is for declaring things which are shared among sedit files. This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files. The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS. If you change a record, make sure sedit-access gets remade NEW. All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file. Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. ") (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) (IL:* IL:|;;| "interface globalvars") (IL:GLOBALVARS CONVERT-UPGRADE KEEP-WINDOW-REGION CONTEXTS LISP-EDIT-ENVIRONMENT LIST-FORMATS-TABLE PRETTY-PRINT-ENV REGIONS) (IL:* IL:|;;| "shared globalvars") (IL:GLOBALVARS IL:BOLDFONT IL:CLISPFONT IL:COMMENTFLG IL:COMMENTFONT IL:DEFAULTFONT IL:PROMPTWINDOW IL:ITALICFONT ARGS-GAP ATOM-CARET BASIC-GAP BODY-GAP BUTTON-STRING BUTTON-STRING-NODE STRUCTURE-CARET CLISP-INDENT-WORDS CLISP-PROGRAM-WORDS COMMAND-TABLE-SPEC LIST-PARSE-INFO TERMINAL-TABLE TEMP-POINT TEMP-SELECTION TYPE-CLISP TYPE-COMMENT TYPE-COMMENT-WORD TYPE-DOTLIST TYPE-GAP TYPE-LIST TYPE-LITATOM TYPE-QUOTE TYPE-ROOT TYPE-STRING TYPE-UNKNOWN TYPES ARGS-BITMAP BODY-BITMAP GAP-BITMAP) (IL:* IL:|;;| "window file globalvars") (IL:GLOBALVARS TITLED-ICON SELECTION-PENDING? PENDING-SELECTION INITIAL-SELECTION SCRATCH-SELECTION PENDING-CARET PENDING-LAST-X PENDING-LAST-Y PENDING-TYPE PENDING-SHIFT LAST-MOVE-CLOCK BUTTON-STRING-NODE) (IL:* IL:|;;| "command file globalvars") (IL:GLOBALVARS MENUS MENU-DESCRIPTION MUTATE-CANDIDATE PACKAGE-CANDIDATE PRINTBASE-CANDIDATE FIND-CANDIDATE SUBSTITUTE-CANDIDATE) (IL:* IL:|;;| "random constants") (IL:CONSTANTS (EDITOR-NAME "SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST '(QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION))) (IL:* IL:|;;| "random macros") (IL:MACROS GET-PROMPT-WINDOW EVAL-IN-PROCESS LOOKUP-COMMAND QUOTE-WRAPPER QUOTE-WRAPPER-NAME REPAINT-NEW-LINE RESET-CONTROL-VARIABLES SELECT-COMMENT-INDENT SET-COMMENT-POSITIONS SET-SELECTION-NOWHERE) (IL:* IL:|;;| "kernel macros") (IL:FUNCTIONS CREATE-WEAK-LINK) (IL:MACROS ADVANCE CLOSE-OPEN-NODE DEAD-NODE? END-UNDO-BLOCK ESCAPE-CHAR EQ-POINT-TYPE NEXT-LINEAR SET-LINEAR START-UNDO-BLOCK STEP-LINEAR SUBNODE UNDO-BY ZAP-CLISP-TRANSLATION SMASH-USING IL:HALF) (IL:* IL:|;;| "the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't. The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes.") (IL:VARIABLES *IL-CL-CONFLICTS* *IL-IMPORTS*) (IL:* IL:|;;| "and a little reminder:") (IL:P (IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T) (IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T)))) (IL:PUTPROPS IL:SEDIT-DECLS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-DECLS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:* IL:|;;;| "This file is for declaring things which are shared among sedit files. This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files. The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS. If you change a record, make sure sedit-access gets remade NEW. All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file. Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. " ) (IL:DECLARE\: IL:EVAL@COMPILE (IL:DATATYPE BROKEN-ATOM (ATOM-CHARS)) (IL:DATATYPE EDIT-CONTEXT (ENVIRONMENT PROFILE EVAL-FN EVAL-IN-PROCESS CONTEXT-LOCK COMPLETION-EVENT EDIT-TYPE ICON-TITLE EDIT-OPTIONS COMMENT-WIDTH COMMENT-SEPARATION FIND-CANDIDATE SUBSTITUTE-CANDIDATE DISPLAY-WINDOW WINDOW-LEFT WINDOW-BOTTOM WINDOW-RIGHT WINDOW-TOP ROOT ROOT-CHANGED-FN COMPLETION-FN CHANGED-STRUCTURE? ( DONT-COLLECT-CHANGES? IL:FLAG) CHANGED-NODES OPEN-NODE-CHANGED? OPEN-NODE OPEN-NODE-INFO ATOM-STARTED ATOM-STARTED-UNDO-POINTER UNDO-LIST UNDO-UNDO-LIST CARET CARET-POINT SELECTION SELECTION-DISPLAYED? (CURRENT-NODE IL:FULLXPOINTER) CURRENT-X (CURRENT-LINE IL:FULLXPOINTER) (LAST-LINEARIZED-SUB-NODE-INDEX IL:WORD) (LINEAR-POINTER IL:FULLXPOINTER) (LINEAR-PREV IL:FULLXPOINTER) LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK CURRENT-BLOCK MATCHING? BELOW? VISIBLE? (REPAINT-START IL:FULLXPOINTER) (REPAINT-LINE IL:FULLXPOINTER) REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT) CHANGED-NODES IL:_ (CONS)) (IL:DATATYPE EDIT-ENV (PARSE-INFO PARSE-INFO-UNKNOWN USER-DATA DEFAULT-FONT ITALIC-FONT KEYWORD-FONT COMMENT-FONT BROKEN-ATOM-FONT SPACE-WIDTH DEFAULT-LINE-SKIP EM-WIDTH INDENT-BASE INDENT-STEP MAX-WIDTH COMMENT-WIDTH-PERCENT INIT-COMMENT-SEPARATION LPAREN-STRING RPAREN-STRING DOT-STRING QUOTE-STRING COMMENT-STRING COMMAND-TABLE DEFAULT-CHAR-HANDLER HELP-MENU)) (IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER) FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER) (DEPTH IL:WORD) (SUB-NODE-INDEX IL:WORD) STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER) LINEAR-FORM (START-X IL:WORD) (RIGHT-MARGIN IL:WORD) (PREFERRED-WIDTH IL:WORD) (ACTUAL-WIDTH IL:WORD) (CHANGED? IL:FLAG) INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE) (IL:ACCESSFNS (INLINE? (EQ (IL:|fetch| FIRST-LINE IL:|of| IL:DATUM ) (IL:|fetch| LAST-LINE IL:|of| IL:DATUM) ))) FORMAT IL:_ 'NOT-YET-ASSIGNED) (IL:DATATYPE EDIT-NODE-TYPE (NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED SET-POINT COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION SET-SELECTION GROW-SELECTION SELECT-SEGMENT INSERT DELETE COPY-STRUCTURE COPY-SELECTION STRINGIFY BACK-SPACE CLOSE-NODE)) (IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER) POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER) POINT-STRING POINT-OFFSET)) (IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER) SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE? SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER) SELECT-END-X (SELECT-END-LINE IL:FULLXPOINTER) SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET)) (IL:DATATYPE GAP (LINEAR-ITEM)) (IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER) BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE BLOCK-ASCENT BLOCK-DESCENT)) (IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER) (PREV-LINE IL:FULLXPOINTER) (NODE IL:FULLXPOINTER) (LINE-ASCENT IL:WORD) (LINE-DESCENT IL:WORD) (LINE-SKIP IL:WORD) (LINE-LENGTH IL:WORD) (INDENT IL:WORD) YCOORD (CACHE-TIME IL:WORD) CACHED-Y (CACHED-ASCENT IL:WORD) (CACHED-DESCENT IL:WORD)) (IL:ACCESSFNS (LINE-HEIGHT (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF IL:DATUM) (IL:FETCH LINE-DESCENT IL:OF IL:DATUM)))) (IL:ACCESSFNS (BASE-LINE-Y (IL:IDIFFERENCE (IL:ADD1 (IL:FETCH YCOORD IL:OF IL:DATUM )) (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF IL:DATUM))))) (IL:ACCESSFNS (NEXT-LINE-Y (IL:IDIFFERENCE (IL:FETCH YCOORD IL:OF IL:DATUM) (IL:FETCH LINE-HEIGHT IL:OF IL:DATUM)))) (IL:ACCESSFNS (OLD-TOP (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) (IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of| CONTEXT)) (IL:SUB1 (IL:IPLUS (IL:FETCH CACHED-Y IL:OF IL:DATUM) (IL:FETCH CACHED-ASCENT IL:OF IL:DATUM))) (IL:FETCH YCOORD IL:OF IL:DATUM)))) (IL:ACCESSFNS (OLD-BOTTOM (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) (IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of| CONTEXT)) (IL:IDIFFERENCE (IL:FETCH CACHED-Y IL:OF IL:DATUM) (IL:FETCH CACHED-DESCENT IL:OF IL:DATUM)) (IL:ADD1 (IL:FETCH NEXT-LINE-Y IL:OF IL:DATUM)))))) (IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS) (IL:ACCESSFNS (NON-STANDARD? (NULL (IL:|fetch| LIST-FORMATS IL:|of| IL:DATUM)))) (IL:ACCESSFNS (SET-FORMAT-LIST (IL:|fetch| LIST-INLINE? IL:|of| IL:DATUM))) (IL:ACCESSFNS (CFVLIST (IL:|fetch| LIST-PFORMAT IL:|of| IL:DATUM ))) (IL:ACCESSFNS (LINEARIZE-LIST (IL:|fetch| LIST-MFORMAT IL:|of| IL:DATUM))) LIST-SUBLISTS IL:_ NIL) (IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING)) (IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD) (FONT IL:FULLXPOINTER) (PRIN-2? IL:FLAG))) (IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER))) ) (IL:/DECLAREDATATYPE 'BROKEN-ATOM '(IL:POINTER) '((BROKEN-ATOM 0 IL:POINTER)) '2) (IL:/DECLAREDATATYPE 'EDIT-CONTEXT '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-CONTEXT 0 IL:POINTER) (EDIT-CONTEXT 2 IL:POINTER) (EDIT-CONTEXT 4 IL:POINTER) (EDIT-CONTEXT 6 IL:POINTER) (EDIT-CONTEXT 8 IL:POINTER) (EDIT-CONTEXT 10 IL:POINTER) (EDIT-CONTEXT 12 IL:POINTER) (EDIT-CONTEXT 14 IL:POINTER) (EDIT-CONTEXT 16 IL:POINTER) (EDIT-CONTEXT 18 IL:POINTER) (EDIT-CONTEXT 20 IL:POINTER) (EDIT-CONTEXT 22 IL:POINTER) (EDIT-CONTEXT 24 IL:POINTER) (EDIT-CONTEXT 26 IL:POINTER) (EDIT-CONTEXT 28 IL:POINTER) (EDIT-CONTEXT 30 IL:POINTER) (EDIT-CONTEXT 32 IL:POINTER) (EDIT-CONTEXT 34 IL:POINTER) (EDIT-CONTEXT 36 IL:POINTER) (EDIT-CONTEXT 38 IL:POINTER) (EDIT-CONTEXT 40 IL:POINTER) (EDIT-CONTEXT 42 IL:POINTER) (EDIT-CONTEXT 42 (IL:FLAGBITS . 0)) (EDIT-CONTEXT 44 IL:POINTER) (EDIT-CONTEXT 46 IL:POINTER) (EDIT-CONTEXT 48 IL:POINTER) (EDIT-CONTEXT 50 IL:POINTER) (EDIT-CONTEXT 52 IL:POINTER) (EDIT-CONTEXT 54 IL:POINTER) (EDIT-CONTEXT 56 IL:POINTER) (EDIT-CONTEXT 58 IL:POINTER) (EDIT-CONTEXT 60 IL:POINTER) (EDIT-CONTEXT 62 IL:POINTER) (EDIT-CONTEXT 64 IL:POINTER) (EDIT-CONTEXT 66 IL:POINTER) (EDIT-CONTEXT 68 IL:FULLXPOINTER) (EDIT-CONTEXT 70 IL:POINTER) (EDIT-CONTEXT 72 IL:FULLXPOINTER) (EDIT-CONTEXT 74 (IL:BITS . 15)) (EDIT-CONTEXT 76 IL:FULLXPOINTER) (EDIT-CONTEXT 78 IL:FULLXPOINTER) (EDIT-CONTEXT 80 IL:POINTER) (EDIT-CONTEXT 82 IL:POINTER) (EDIT-CONTEXT 84 IL:POINTER) (EDIT-CONTEXT 86 IL:POINTER) (EDIT-CONTEXT 88 IL:POINTER) (EDIT-CONTEXT 90 IL:POINTER) (EDIT-CONTEXT 92 IL:POINTER) (EDIT-CONTEXT 94 IL:POINTER) (EDIT-CONTEXT 96 IL:POINTER) (EDIT-CONTEXT 98 IL:POINTER) (EDIT-CONTEXT 100 IL:POINTER) (EDIT-CONTEXT 102 IL:POINTER) (EDIT-CONTEXT 104 IL:FULLXPOINTER) (EDIT-CONTEXT 106 IL:FULLXPOINTER) (EDIT-CONTEXT 108 IL:POINTER) (EDIT-CONTEXT 110 IL:POINTER) (EDIT-CONTEXT 112 IL:POINTER) (EDIT-CONTEXT 114 IL:POINTER) (EDIT-CONTEXT 116 IL:POINTER)) '118) (IL:/DECLAREDATATYPE 'EDIT-ENV '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-ENV 0 IL:POINTER) (EDIT-ENV 2 IL:POINTER) (EDIT-ENV 4 IL:POINTER) (EDIT-ENV 6 IL:POINTER) (EDIT-ENV 8 IL:POINTER) (EDIT-ENV 10 IL:POINTER) (EDIT-ENV 12 IL:POINTER) (EDIT-ENV 14 IL:POINTER) (EDIT-ENV 16 IL:POINTER) (EDIT-ENV 18 IL:POINTER) (EDIT-ENV 20 IL:POINTER) (EDIT-ENV 22 IL:POINTER) (EDIT-ENV 24 IL:POINTER) (EDIT-ENV 26 IL:POINTER) (EDIT-ENV 28 IL:POINTER) (EDIT-ENV 30 IL:POINTER) (EDIT-ENV 32 IL:POINTER) (EDIT-ENV 34 IL:POINTER) (EDIT-ENV 36 IL:POINTER) (EDIT-ENV 38 IL:POINTER) (EDIT-ENV 40 IL:POINTER) (EDIT-ENV 42 IL:POINTER) (EDIT-ENV 44 IL:POINTER) (EDIT-ENV 46 IL:POINTER)) '48) (IL:/DECLAREDATATYPE 'EDIT-NODE '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-NODE 0 IL:FULLXPOINTER) (EDIT-NODE 2 IL:POINTER) (EDIT-NODE 4 IL:POINTER) (EDIT-NODE 6 IL:FULLXPOINTER) (EDIT-NODE 8 (IL:BITS . 15)) (EDIT-NODE 9 (IL:BITS . 15)) (EDIT-NODE 10 IL:POINTER) (EDIT-NODE 12 IL:POINTER) (EDIT-NODE 14 IL:FULLXPOINTER) (EDIT-NODE 16 IL:POINTER) (EDIT-NODE 18 (IL:BITS . 15)) (EDIT-NODE 19 (IL:BITS . 15)) (EDIT-NODE 20 (IL:BITS . 15)) (EDIT-NODE 21 (IL:BITS . 15)) (EDIT-NODE 16 (IL:FLAGBITS . 0)) (EDIT-NODE 22 IL:POINTER) (EDIT-NODE 24 IL:POINTER) (EDIT-NODE 26 IL:POINTER) (EDIT-NODE 28 IL:POINTER)) '30) (IL:/DECLAREDATATYPE 'EDIT-NODE-TYPE '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-NODE-TYPE 0 IL:POINTER) (EDIT-NODE-TYPE 2 IL:POINTER) (EDIT-NODE-TYPE 4 IL:POINTER) (EDIT-NODE-TYPE 6 IL:POINTER) (EDIT-NODE-TYPE 8 IL:POINTER) (EDIT-NODE-TYPE 10 IL:POINTER) (EDIT-NODE-TYPE 12 IL:POINTER) (EDIT-NODE-TYPE 14 IL:POINTER) (EDIT-NODE-TYPE 16 IL:POINTER) (EDIT-NODE-TYPE 18 IL:POINTER) (EDIT-NODE-TYPE 20 IL:POINTER) (EDIT-NODE-TYPE 22 IL:POINTER) (EDIT-NODE-TYPE 24 IL:POINTER) (EDIT-NODE-TYPE 26 IL:POINTER) (EDIT-NODE-TYPE 28 IL:POINTER) (EDIT-NODE-TYPE 30 IL:POINTER) (EDIT-NODE-TYPE 32 IL:POINTER) (EDIT-NODE-TYPE 34 IL:POINTER)) '36) (IL:/DECLAREDATATYPE 'EDIT-POINT '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER) '((EDIT-POINT 0 IL:FULLXPOINTER) (EDIT-POINT 2 IL:POINTER) (EDIT-POINT 4 IL:POINTER) (EDIT-POINT 6 IL:POINTER) (EDIT-POINT 8 IL:FULLXPOINTER) (EDIT-POINT 10 IL:POINTER) (EDIT-POINT 12 IL:POINTER)) '14) (IL:/DECLAREDATATYPE 'EDIT-SELECTION '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER) '((EDIT-SELECTION 0 IL:FULLXPOINTER) (EDIT-SELECTION 2 IL:POINTER) (EDIT-SELECTION 4 IL:POINTER) (EDIT-SELECTION 6 IL:POINTER) (EDIT-SELECTION 8 IL:POINTER) (EDIT-SELECTION 10 IL:POINTER) (EDIT-SELECTION 12 IL:POINTER) (EDIT-SELECTION 14 IL:FULLXPOINTER) (EDIT-SELECTION 16 IL:POINTER) (EDIT-SELECTION 18 IL:FULLXPOINTER) (EDIT-SELECTION 20 IL:POINTER) (EDIT-SELECTION 22 IL:POINTER) (EDIT-SELECTION 24 IL:POINTER)) '26) (IL:/DECLAREDATATYPE 'GAP '(IL:POINTER) '((GAP 0 IL:POINTER)) '2) (IL:/DECLAREDATATYPE 'LINE-BLOCK '(IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((LINE-BLOCK 0 IL:FULLXPOINTER) (LINE-BLOCK 2 IL:POINTER) (LINE-BLOCK 4 IL:POINTER) (LINE-BLOCK 6 IL:POINTER) (LINE-BLOCK 8 IL:POINTER) (LINE-BLOCK 10 IL:POINTER) (LINE-BLOCK 12 IL:POINTER) (LINE-BLOCK 14 IL:POINTER) (LINE-BLOCK 16 IL:POINTER)) '18) (IL:/DECLAREDATATYPE 'LINE-START '(IL:FULLXPOINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:POINTER IL:WORD IL:POINTER IL:WORD IL:WORD) '((LINE-START 0 IL:FULLXPOINTER) (LINE-START 2 IL:FULLXPOINTER) (LINE-START 4 IL:FULLXPOINTER) (LINE-START 6 (IL:BITS . 15)) (LINE-START 7 (IL:BITS . 15)) (LINE-START 8 (IL:BITS . 15)) (LINE-START 9 (IL:BITS . 15)) (LINE-START 10 (IL:BITS . 15)) (LINE-START 12 IL:POINTER) (LINE-START 11 (IL:BITS . 15)) (LINE-START 14 IL:POINTER) (LINE-START 16 (IL:BITS . 15)) (LINE-START 17 (IL:BITS . 15))) '18) (IL:/DECLAREDATATYPE 'LIST-FORMAT '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER) '((LIST-FORMAT 0 IL:POINTER) (LIST-FORMAT 2 IL:POINTER) (LIST-FORMAT 4 IL:POINTER) (LIST-FORMAT 6 IL:POINTER) (LIST-FORMAT 8 IL:POINTER)) '10) (IL:/DECLAREDATATYPE 'STRING-ITEM '(IL:POINTER IL:WORD IL:FULLXPOINTER IL:FLAG) '((STRING-ITEM 0 IL:POINTER) (STRING-ITEM 2 (IL:BITS . 15)) (STRING-ITEM 4 IL:FULLXPOINTER) (STRING-ITEM 3 (IL:FLAGBITS . 0))) '6) (IL:/DECLAREDATATYPE 'WEAK-LINK '(IL:FULLXPOINTER) '((WEAK-LINK 0 IL:FULLXPOINTER)) '2) (IL:* IL:|;;| "interface globalvars") (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS CONVERT-UPGRADE KEEP-WINDOW-REGION CONTEXTS LISP-EDIT-ENVIRONMENT LIST-FORMATS-TABLE PRETTY-PRINT-ENV REGIONS) ) (IL:* IL:|;;| "shared globalvars") (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS IL:BOLDFONT IL:CLISPFONT IL:COMMENTFLG IL:COMMENTFONT IL:DEFAULTFONT IL:PROMPTWINDOW IL:ITALICFONT ARGS-GAP ATOM-CARET BASIC-GAP BODY-GAP BUTTON-STRING BUTTON-STRING-NODE STRUCTURE-CARET CLISP-INDENT-WORDS CLISP-PROGRAM-WORDS COMMAND-TABLE-SPEC LIST-PARSE-INFO TERMINAL-TABLE TEMP-POINT TEMP-SELECTION TYPE-CLISP TYPE-COMMENT TYPE-COMMENT-WORD TYPE-DOTLIST TYPE-GAP TYPE-LIST TYPE-LITATOM TYPE-QUOTE TYPE-ROOT TYPE-STRING TYPE-UNKNOWN TYPES ARGS-BITMAP BODY-BITMAP GAP-BITMAP) ) (IL:* IL:|;;| "window file globalvars") (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS TITLED-ICON SELECTION-PENDING? PENDING-SELECTION INITIAL-SELECTION SCRATCH-SELECTION PENDING-CARET PENDING-LAST-X PENDING-LAST-Y PENDING-TYPE PENDING-SHIFT LAST-MOVE-CLOCK BUTTON-STRING-NODE) ) (IL:* IL:|;;| "command file globalvars") (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:GLOBALVARS MENUS MENU-DESCRIPTION MUTATE-CANDIDATE PACKAGE-CANDIDATE PRINTBASE-CANDIDATE FIND-CANDIDATE SUBSTITUTE-CANDIDATE) ) (IL:* IL:|;;| "random constants") (IL:DECLARE\: IL:EVAL@COMPILE (IL:RPAQ EDITOR-NAME "SEdit") (IL:RPAQQ IL:MICASPERPT 35.27778) (IL:RPAQQ QUOTE-WRAPPER-LIST (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION)) (IL:CONSTANTS (EDITOR-NAME "SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST '(QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION))) ) (IL:* IL:|;;| "random macros") (IL:DECLARE\: IL:EVAL@COMPILE (IL:PUTPROPS GET-PROMPT-WINDOW IL:MACRO ((CONTEXT) (IL:GETPROMPTWINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)))) (IL:PUTPROPS EVAL-IN-PROCESS IL:MACRO (NIL (LET* ((PROCESS (IF (EQ (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) 'IL:MOUSE) (IL:TTY.PROCESS) (IL:THIS.PROCESS))) (PROCFORM (IL:PROCESSPROP PROCESS 'IL:FORM))) (COND ((EQ (CAR PROCFORM) 'SEDIT1) (IL:|fetch| (EDIT-CONTEXT EVAL-IN-PROCESS) IL:|of| (CADADR PROCFORM))) (T PROCESS))))) (IL:PUTPROPS LOOKUP-COMMAND IL:MACRO ((CHAR TABLE) (GETHASH CHAR TABLE))) (IL:PUTPROPS QUOTE-WRAPPER IL:MACRO (TYPE (COND ((AND (IL:LISTP (CAR TYPE)) (EQ (CAAR TYPE) 'QUOTE)) (IF (IL:LISTP (CADAR TYPE)) (IL:KWOTE (IL:|for| W IL:|in| (CADAR TYPE) IL:|collect| (IL:LISTGET QUOTE-WRAPPER-LIST W))) (IL:KWOTE (IL:LISTGET QUOTE-WRAPPER-LIST (CADAR TYPE))))) (T `(IL:LISTGET QUOTE-WRAPPER-LIST ,(CAR TYPE)))))) (IL:PUTPROPS QUOTE-WRAPPER-NAME IL:MACRO ((TYPE) (IL:LISTGET (IL:CONSTANT (IL:REVERSE QUOTE-WRAPPER-LIST)) TYPE))) (IL:PUTPROPS REPAINT-NEW-LINE IL:MACRO (IL:OPENLAMBDA (LINE) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-TOP IL:|of| CONTEXT)) (REPAINT CONTEXT (IL:|fetch| INDENT IL:|of| (CAR LINE)) (IL:|fetch| BASE-LINE-Y IL:|of| (CAR LINE)) (CDR LINE) (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-BOTTOM IL:|of| CONTEXT)) (IL:|replace| BELOW? IL:|of| CONTEXT IL:|with| T))))) (IL:PUTPROPS RESET-CONTROL-VARIABLES IL:MACRO ((CONTEXT) (WHEN (COMPILING-POST-KOTO) (IL:SETQ *PACKAGE* (IL:FETCH PACKAGE IL:OF CONTEXT)) (IL:SETQ *PRINT-ARRAY* NIL) (IL:SETQ *PRINT-BASE* (IL:FETCH PRINT-BASE IL:OF CONTEXT)) (IL:SETQ *PRINT-CASE* (IL:FETCH PRINT-CASE IL:OF CONTEXT)) (IL:SETQ *PRINT-ESCAPE* T) (IL:SETQ *PRINT-GENSYM* T) (IL:SETQ *PRINT-RADIX* NIL)))) (IL:PUTPROPS SELECT-COMMENT-INDENT IL:MACRO ((KEY LEVEL-1-INDENT LEVEL-2-INDENT LEVEL-3-INDENT) (IL:SELECTQ KEY (1 LEVEL-1-INDENT) (2 LEVEL-2-INDENT) ((3 4 5) LEVEL-3-INDENT) (IL:SHOULDNT "unexpected comment level")))) (IL:PUTPROPS SET-COMMENT-POSITIONS IL:MACRO ((COMMENT-START-X COMMENT-INDENT FORM-INDENT PAREN-WIDTH NODE CONTEXT) (COND ((IL:IGEQ (IL:IPLUS FORM-INDENT (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT)) (IL:|fetch| RIGHT-MARGIN IL:|of| NODE)) (IL:SETQ COMMENT-START-X (IL:IPLUS (IL:|fetch| START-X IL:|of| NODE) PAREN-WIDTH)) (IL:SETQ COMMENT-INDENT COMMENT-START-X)) (T (IL:SETQ COMMENT-START-X (IL:IDIFFERENCE (IL:|fetch| RIGHT-MARGIN IL:|of| NODE) (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT))) (IL:SETQ COMMENT-INDENT (IL:IPLUS COMMENT-START-X (IL:|fetch| COMMENT-SEPARATION IL:|of| CONTEXT) )))))) (IL:PUTPROPS SET-SELECTION-NOWHERE IL:MACRO ((SELECTION) (IL:|replace| SELECT-NODE IL:|of| SELECTION IL:|with| NIL))) ) (IL:* IL:|;;| "kernel macros") (DEFMACRO CREATE-WEAK-LINK (DEST) `(IL:|create| WEAK-LINK DESTINATION IL:_ ,DEST)) (IL:DECLARE\: IL:EVAL@COMPILE (IL:PUTPROPS ADVANCE IL:MACRO ((WIDTH) (IL:|add| (IL:|fetch| CURRENT-X IL:|of| CONTEXT) WIDTH))) (IL:PUTPROPS CLOSE-OPEN-NODE IL:MACRO ((CONTEXT) (WHEN (IL:|fetch| OPEN-NODE-CHANGED? IL:|of| CONTEXT) (CLOSE-NODE CONTEXT)))) (IL:PUTPROPS DEAD-NODE? IL:MACRO ((NODE) (EQ 0 (IL:|fetch| DEPTH IL:|of| NODE)))) (IL:PUTPROPS END-UNDO-BLOCK IL:MACRO (NIL (COLLECT-UNDO-BLOCK CONTEXT))) (IL:PUTPROPS ESCAPE-CHAR IL:MACRO ((READ-TABLE) (IL:|fetch| (READTABLEP IL:ESCAPECHAR) IL:|of| (OR READ-TABLE *READTABLE*)))) (IL:PUTPROPS EQ-POINT-TYPE IL:MACRO ((POINT TYPE) (LET ((POINTNODE (IL:|fetch| POINT-NODE IL:|of| POINT))) (IF (IL:|type?| EDIT-SELECTION POINTNODE) (EQ (IL:|fetch| NODE-TYPE IL:|of| (IL:|fetch| SELECT-NODE IL:|of| POINTNODE)) TYPE) (EQ (IL:|fetch| NODE-TYPE IL:|of| POINTNODE) TYPE))))) (IL:PUTPROPS NEXT-LINEAR IL:MACRO ((CONTEXT ITEM) (AND (IL:LISTP (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT) ) (EQ (CAR (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) ITEM)))) (IL:PUTPROPS SET-LINEAR IL:MACRO (IL:OPENLAMBDA (CONTEXT NEW-LPTR) (IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| NEW-LPTR) (IF (IL:LISTP (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT )) (RPLACD (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT) NEW-LPTR) (IL:|replace| LINEAR-FORM IL:|of| (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT) IL:|with| NEW-LPTR)))) (IL:PUTPROPS START-UNDO-BLOCK IL:MACRO (NIL (IL:|push| (IL:|fetch| UNDO-LIST IL:|of| CONTEXT) NIL))) (IL:PUTPROPS STEP-LINEAR IL:MACRO ((CONTEXT) (IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| (CDR (IL:|replace| LINEAR-PREV IL:|of| CONTEXT IL:|with| (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT))))) ) (IL:PUTPROPS SUBNODE IL:MACRO (X (IF (EQ (CAR X) 1) (LIST 'CADR (LIST 'IL:FETCH 'SUB-NODES (CADR X))) (LIST 'CADR (LIST 'IL:NTH (LIST 'IL:FETCH 'SUB-NODES (CADR X)) (CAR X)))))) (IL:PUTPROPS UNDO-BY IL:MACRO (INFO (LIST 'IL:PUSH '(IL:|fetch| UNDO-LIST IL:|of| CONTEXT) (LIST* 'LIST (IL:KWOTE (CAR INFO)) (CDR INFO))))) (IL:PUTPROPS ZAP-CLISP-TRANSLATION IL:MACRO ((X) (AND IL:CLISPARRAY (IL:PUTHASH X NIL IL:CLISPARRAY)))) (IL:PUTPROPS SMASH-USING IL:MACRO (X (IL:|bind| (SRC IL:_ (IF (IL:ATOM (CADDR X)) (CADDR X) '$$SOURCE)) DEST (DESCR IL:_ (IL:GETDESCRIPTORS (CAR X))) IL:|first| (IL:SETQ DEST (LIST 'IL:REPLACEFIELDVAL (LIST 'QUOTE (CAR DESCR)) (CADR X) (LIST 'IL:FETCHFIELD (LIST 'QUOTE (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|while| DESCR IL:|do| (IL:SETQ DEST (LIST 'IL:FREPLACEFIELDVAL (LIST 'QUOTE (CAR DESCR)) DEST (LIST 'IL:FETCHFIELD (LIST 'QUOTE (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|finally| (WHEN (NOT (IL:ATOM (CADDR X))) (IL:SETQ DEST (LIST 'LET (LIST (LIST '$$SOURCE (CADDR X))) DEST))) (RETURN DEST)))) (IL:PUTPROPS IL:HALF IL:MACRO ((IL:X) (IL:LRSH IL:X 1))) ) (IL:* IL:|;;| "the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't. The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes." ) (DEFPARAMETER *IL-CL-CONFLICTS* '(IL:*PRINT-STRUCTURE* IL:* IL:APPEND IL:APPLY IL:ASSOC IL:ATOM IL:BLOCK IL:CHARACTER   IL:EQUAL IL:ERROR IL:FLOATP IL:FORMAT IL:FUNCTION IL:GETHASH IL:IF IL:LAMBDA IL:LENGTH IL:LISTP IL:MAPCAR IL:NTH IL:NUMBER IL:NUMBERP IL:PRIN1 IL:READ IL:REVERSE IL:SETQ IL:SPACE IL:STRINGP IL:TERPRI)) (DEFPARAMETER *IL-IMPORTS* '(IL:\" IL:$$ITERATE IL:$$LST1 IL:$$OUT IL:\( IL:*DISPLAY-EDITOR* IL:\, IL:\. IL:.P2 IL:/DECLAREDATATYPE IL:\; IL:|;;| IL:|;;;| IL:? IL:ACCESSFNS IL:ADD.PROCESS IL:ADD1 IL:ADDSPELL IL:ADDSPELLFLG IL:ADDTOVAR IL:ALIST IL:ALISTS IL:ALLOCSTRING IL:APPLY* IL:ASCENT IL:ATM IL:ATTACHWINDOW IL:AWAIT.EVENT IL:BASE IL:BITBLT IL:BITMAPHEIGHT IL:BITMAPS IL:BITMAPWIDTH IL:BITS IL:BKSYSBUF IL:BLACKSHADE IL:BLTSHADE IL:BOLD IL:BOLDFONT IL:BOTTOM IL:BOX IL:BQUOTE IL:BS IL:BUTTONEVENTFN IL:BUTTONS IL:C IL:CASEINSENSITIVE IL:CCODEP IL:CHANGENAME IL:CHANGEOFFSETFLG IL:CHARCODE IL:CHARDELETE IL:CHARWIDTH IL:CHCON1 IL:CLEARBUF IL:CLEARW IL:CLISP\: IL:CLISPARRAY IL:CLISPFONT IL:CLISPTRAN IL:CLISPWORD IL:CLOCK IL:CLOSEFN IL:CLOSEW IL:COLUMN IL:COLUMNSPACE IL:COMMA IL:COMMENTFLG IL:COMMENTFONT IL:COMS IL:COMTAIL IL:CONCAT IL:CONCATLIST IL:CONSTANT IL:CONSTANTS IL:CONTROL IL:COPY IL:COPYALL IL:COPYRIGHT IL:COPYTERMTABLE IL:CR IL:CREATE IL:CREATE.EVENT IL:CREATE.MONITORLOCK IL:CREATEREGION IL:CREATEW IL:CTRL IL:CTRLV IL:CURSORCREATE IL:DATATYPE IL:DATE IL:DATUM IL:DECLARATIONS\: IL:DECLARE\: IL:DEFAULTFONT IL:DEFINEQ IL:DEL IL:DESCENT IL:DOCOPY IL:DOEVAL@COMPILE IL:DON\'T IL:DONTCOPY IL:DONTEVAL@LOAD IL:DONTWAIT IL:DOWINDOWCOM IL:DREMOVE IL:DREVERSE IL:DSP IL:DSPCLIPPINGREGION IL:DSPFONT IL:DSPLINEFEED IL:DSPRIGHTMARGIN IL:DSPXOFFSET IL:DSPXPOSITION IL:DSPYOFFSET IL:|Definition-for-EDITDATE| IL:|Definition-for-EDITE| IL:|Definition-for-EDITL| IL:E IL:ECHOMODE IL:EDIT IL:EDITCHANGES IL:EDITFERROR IL:EDITGETD IL:EDITMACROS IL:EDITMODE IL:ENVIRONMENT IL:EOL IL:EQMEMB IL:ERSETQ IL:ESC IL:ESCAPE IL:ESCAPECHAR IL:EVAL@COMPILE IL:EVALV IL:EXPANDFN IL:EXPANDREGIONFN IL:EXPANDW IL:EXPR IL:EXTENT IL:FCHARACTER IL:FETCHFIELD IL:FILECREATED IL:FILEMAP IL:FILEPKGFLG IL:FILES IL:FILESLOAD IL:FILETYPE IL:FIND.PROCESS IL:FIXEDITDATE IL:FIXP IL:FIXR IL:FLAG IL:FLAGBITS IL:FLASHWINDOW IL:FLENGTH IL:FM.CHANGELABEL IL:FM.CHANGESTATE IL:FM.DONTRESHAPE IL:FM.EDITITEM IL:FM.GETITEM IL:FM.ITEMPROP IL:FM.RESETMENU IL:FMEMB IL:FN IL:FNS IL:FONT IL:FONTCREATE IL:FONTPROP IL:FORM IL:FORWORD IL:FREEMENU IL:FREPLACEFIELDVAL IL:FULLXPOINTER IL:FUNCTIONS IL:GACHA IL:GETD IL:GETDEF IL:GETDESCRIPTORS IL:GETPROMPTWINDOW IL:GETPROP IL:GETPROPLIST IL:GETREGION IL:GETSYNTAX IL:GLOBALVARS IL:GROUP IL:HALF IL:HEIGHT IL:HEIGHTIFWINDOW IL:HELVETICA IL:ICON IL:ICONWINDOW IL:ID IL:IDIFFERENCE IL:IFWORD IL:IGEQ IL:IGREATERP IL:ILEQ IL:ILESSP IL:IMAX IL:IMIN IL:IMINUS IL:IN/SCROLL/BAR? IL:INNERESCQUOTE IL:INFOHOOK IL:INITRECORDS IL:INITVARS IL:INPUT IL:INSIDEP IL:INTERPRESS IL:INVERT IL:IPLUS IL:IQUOTIENT IL:ITALICFONT IL:ITEM IL:ITEMS IL:ITEMWIDTH IL:ITIMES IL:KEYACTION IL:KEYACTIONTABLE IL:KEYBOARDSTREAM IL:KEYDOWNP IL:KWOTE IL:L IL:L-CASE IL:LABEL IL:LASTMOUSESTATE IL:LASTMOUSEX IL:LASTMOUSEY IL:LCONC IL:LEFT IL:LEFTBRACKET IL:LEFTPAREN IL:LEQ IL:LINEDELETE IL:LINKS IL:LISTGET IL:LISTPUT IL:LITATOM IL:LOCALCLOSE IL:LOCALVARS IL:LRSH IL:MACRO IL:MACROS IL:MAINWINDOW IL:MAKEFILE-ENVIRONMENT IL:MARKASCHANGED IL:MARKASCHANGEDFNS IL:MASK IL:MAXWIDTH IL:MEMB IL:MENU IL:MENUFONT IL:MENUOFFSET IL:MESS IL:MICASPERPT IL:MIDDLE IL:MKSTRING IL:MOUSE IL:MOUSECONFIRM IL:MOUSESTATE IL:MOVE IL:MOVETO IL:MULTESCAPECHAR IL:MULTIPLE-ESCAPE IL:NAME IL:NCHARS IL:NCONC1 IL:NEQ IL:NILL IL:NLAMBDA IL:NLISTP IL:NLSETQ IL:NOBIND IL:NONE IL:NOTIFY.EVENT IL:NTHCHARCODE IL:OBTAIN.MONITORLOCK IL:OFFST IL:OPENLAMBDA IL:OPENSTRINGSTREAM IL:OPENWP IL:P IL:PACKAGEDELIM IL:PAINT IL:POINTER IL:PRETTYCOMPRINT IL:PRIN2 IL:PROCESS IL:PROCESS.APPLY IL:PROCESS.EVAL IL:PROCESS.EVALV IL:PROCESSP IL:PROCESSPROP IL:PROCTYPEAHEAD IL:PROMPTFORWORD IL:PROMPTWINDOW IL:PROP IL:PROPLST IL:PROPS IL:PUTD IL:PUTDEF IL:PUTHASH IL:PUTPROP IL:PUTPROPS IL:QUOTIENT IL:READCODE IL:READP IL:READSA IL:RECORD IL:RECORDS IL:RECORDTRAN IL:REDISPLAYW IL:REGION IL:REJECTMAINCOMS IL:RELEASE.MONITORLOCK IL:RELMOVETO IL:REPAINTFN IL:REPLACEFIELDVAL IL:REPOSITIONATTACHEDWINDOWS IL:RESETLST IL:RESETSAVE IL:RESETVAR IL:RESHAPEFN IL:RESTARTABLE IL:RETFROM IL:RETYPE IL:RIGHT IL:RIGHTBRACKET IL:RIGHTBUTTONFN IL:RIGHTPAREN IL:ROWSPACE IL:RPAQ IL:RPAQ? IL:RPAQQ IL:RPLCHARCODE IL:RPLNODE2 IL:RPLSTRING IL:SCROLL.HANDLER IL:SCROLLBYREPAINTFN IL:SCROLLEXTENTUSE IL:SCROLLFN IL:SCROLLW IL:SELCHARQ IL:SELECTEDFN IL:SELECTQ IL:SEPRCHAR IL:SETFS IL:SETINTERRUPT IL:SETPROPLIST IL:SETSYNTAX IL:SETTERMTABLE IL:SHAPEW IL:SHIFT IL:SHIFTDOWNP IL:SHOULDNT IL:SHRINKFN IL:SMALLP IL:SMARTARGLIST IL:SP IL:SPECVARS IL:SPELLFILE IL:STATE IL:STKPOS IL:STREQUAL IL:STRINGDELIM IL:STRINGWIDTH IL:STRPOS IL:SUB1 IL:SUBSTRING IL:SYSRECORDS IL:SYSTEMRECLST IL:TAB IL:TABLE IL:TAIL IL:TCONC IL:TEDIT.INSERT IL:TEDIT.PARALOOKS IL:THIS.PROCESS IL:TIMES IL:TITLE IL:TITLEDICON IL:TITLEDICONW IL:TITLEREG IL:TOP IL:TOTOPW IL:TTY.PROCESS IL:TTY.PROCESSP IL:TTY/EDITDATE IL:TTY/EDITE IL:TTY/EDITL IL:TTY\: IL:TTYDISPLAYSTREAM IL:TTYEXITFN IL:TYPENAME IL:U-CASE IL:UNTILMOUSESTATE IL:UP IL:USEDFREE IL:VARIABLES IL:VARS IL:VARTYPE IL:WAIT.FOR.TTY IL:WHITESHADE IL:WIDTH IL:WINDOW IL:WINDOWADDPROP IL:WINDOWENTRYFN IL:WINDOWPROP IL:WINDOWREGION IL:WITH.MONITOR IL:WORD IL:WORDDELETE IL:WXOFFSET IL:WYOFFSET IL:X IL:Y IL:[ IL:\\\, IL:\\\,. IL:\\\,@ IL:\\ADDBASE IL:\\BACKGROUND IL:\\BLT IL:\\BLTCHAR IL:\\CARET.CREATE IL:\\CARET.DOWN IL:\\CARET.FLASH? IL:\\DEFAULTKEYACTION IL:\\DTEST IL:\\GETBASE IL:\\GETSYSBUF IL:\\KEYBOARD.STREAM IL:\\LINEBUF.OFD IL:\\PUTBASE IL:\\SAVEVMBACKGROUND IL:\\SYNCODE IL:] IL:^ IL:_ IL:ADD IL:ALWAYS IL:AS IL:BIND IL:BY IL:CHANGE IL:|changes| IL:COLLECT IL:COUNT IL:CREATE IL:|date:| IL:DO IL:EACHTIME IL:ELSE IL:ELSEIF IL:FETCH IL:FFETCH IL:FINALLY IL:FIRST IL:FOR IL:FREPLACE IL:FROM WHEN IL:IN IL:INSTRING IL:JOIN IL:LARGEST IL:NEVER IL:OF IL:OLD IL:ON IL:OUTOF IL:POP IL:|previous| IL:|printout| IL:PUSH IL:PUSHNEW IL:REPEATUNTIL IL:REPEATWHILE IL:REPLACE IL:SMALLEST IL:SUM IL:THEN IL:THEREIS IL:TO IL:|to:| IL:TYPE? IL:UNLESS IL:UNTIL IL:USING IL:WHEN IL:WHERE IL:WHILE IL:WITH IL:{ IL:})) (IL:* IL:|;;| "and a little reminder:") (IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T) (IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T) (IL:PUTPROPS IL:SEDIT-DECLS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-EXPORTS b/sources/SEDIT-EXPORTS new file mode 100644 index 00000000..7a6bd30f --- /dev/null +++ b/sources/SEDIT-EXPORTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:01:36" IL:|{DSK}local>lde>lispcore>sources>SEDIT-EXPORTS.;2| 2834 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-EXPORTSCOMS) IL:|previous| IL:|date:| " 5-Feb-88 11:38:07" IL:|{DSK}local>lde>lispcore>sources>SEDIT-EXPORTS.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-EXPORTSCOMS) (IL:RPAQQ IL:SEDIT-EXPORTSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-EXPORTS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-EXPORTS) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:* IL:|;;| "REGION MANAGER") (IL:P (EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION)) (EXPORT '(KEEP-WINDOW-REGION))) (IL:* IL:|;;| "PROGRAMMERS INTERFACE") (IL:P (EXPORT '(SEDIT RESET ADD-COMMAND RESET-COMMANDS DEFAULT-COMMANDS GET-PROMPT-WINDOW GET-SELECTION REPLACE-SELECTION)) (EXPORT '(*GETDEF-FN* *FETCH-DEFINITION-ERROR-BREAK-FLAG* *GETDEF-ERROR-FN* *EDIT-FN* *COMPILE-FN*))) (IL:* IL:|;;| "OPTIONS") (IL:P (EXPORT '(*CLEAR-LINEAR-ON-COMPLETION* *WRAP-SEARCH* *WRAP-PARENS* CONVERT-UPGRADE)) ) (IL:* IL:|;;| "FORMATTING STUFF ") (IL:P (EXPORT '(GET-FORMAT RESET-FORMATS DEF-LIST-FORMAT)) (EXPORT '(*INDENT-ALIST*))))) (IL:PUTPROPS IL:SEDIT-EXPORTS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-EXPORTS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:* IL:|;;| "REGION MANAGER") (EXPORT '(GET-WINDOW-REGION SAVE-WINDOW-REGION)) (EXPORT '(KEEP-WINDOW-REGION)) (IL:* IL:|;;| "PROGRAMMERS INTERFACE") (EXPORT '(SEDIT RESET ADD-COMMAND RESET-COMMANDS DEFAULT-COMMANDS GET-PROMPT-WINDOW GET-SELECTION REPLACE-SELECTION)) (EXPORT '(*GETDEF-FN* *FETCH-DEFINITION-ERROR-BREAK-FLAG* *GETDEF-ERROR-FN* *EDIT-FN* *COMPILE-FN*)) (IL:* IL:|;;| "OPTIONS") (EXPORT '(*CLEAR-LINEAR-ON-COMPLETION* *WRAP-SEARCH* *WRAP-PARENS* CONVERT-UPGRADE)) (IL:* IL:|;;| "FORMATTING STUFF ") (EXPORT '(GET-FORMAT RESET-FORMATS DEF-LIST-FORMAT)) (EXPORT '(*INDENT-ALIST*)) (IL:PUTPROPS IL:SEDIT-EXPORTS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-INDENT b/sources/SEDIT-INDENT new file mode 100644 index 00000000..53355303 --- /dev/null +++ b/sources/SEDIT-INDENT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:03:43" IL:|{DSK}local>lde>lispcore>sources>SEDIT-INDENT.;2| 28064 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-INDENTCOMS) IL:|previous| IL:|date:| "27-Jun-88 17:37:44" IL:|{DSK}local>lde>lispcore>sources>SEDIT-INDENT.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-INDENTCOMS) (IL:RPAQQ IL:SEDIT-INDENTCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-INDENT) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-INDENT) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:VARIABLES LIST-FORMATS-TABLE *FSPEC-TABLE* *FSPEC-TABLE-COPY* *INDENT-ALIST*) (IL:FUNCTIONS GET-INDENT GET-FORMAT) (IL:SETFS GET-INDENT GET-FORMAT) (IL:FUNCTIONS RESET-FORMATS INSTALL-SPECIAL-FORMATS PARSE-FORMAT SETF-OF-GET-FORMAT FORMAT-FROM-INDENT PARSE-INDENT PARSE-INDENT-NAME PARSE-INDENT-BODY PARSE-INDENT-GROUP PARSE-INDENT-GROUP-BODY PARSE-INDENT-GROUP-ONE PARSE-INDENT-GROUPS SCALE-INDENT) (IL:FUNCTIONS COPY-HASH-TABLE) (IL:COMS (IL:* IL:|;;| "a definer for formats") (IL:DEFINE-TYPES IL:SEDIT-FORMATS) (IL:FUNCTIONS DEF-LIST-FORMAT) (IL:PROP IL:ARGNAMES DEF-LIST-FORMAT)))) (IL:PUTPROPS IL:SEDIT-INDENT IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-INDENT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (DEFVAR LIST-FORMATS-TABLE (MAKE-HASH-TABLE :SIZE 1000)) (DEFVAR *FSPEC-TABLE* (MAKE-HASH-TABLE :TEST #'EQUAL :SIZE 2000) "Associates function names with their format specifications.") (DEFVAR *FSPEC-TABLE-COPY* NIL "hash table containing original format specs") (DEFPARAMETER *INDENT-ALIST* (LIST (IL:* IL:|;;;| "Each entry associates a name with a list of two indentation specifications. The first is for preferred mode and the second is for miser mode. Each number in the specs is taken as an indentation level (0=none, 1=body, 2=step1, etc.) and will be scaled appropriately at installation time.") (LIST :VERTICAL (IL:* IL:|;;| "vertical indentation aligns all args with first, each on their own line. In preferred mode, the first arg goes on the same line with the CAR. In miser mode, it goes on the next line at body indentation. If the CAR is non-atomic then the first arg always goes on next line with NO indentation.") (LIST (LIST* 'BREAK 'FROM-INDENT 0) (LIST* 'SET-INDENT 'PREV-ATOM? 1 'BREAK 0) (LIST* 'BREAK 'FROM-INDENT 0)) (LIST (LIST* 'BREAK 'FROM-INDENT 0) (LIST* 'SET-INDENT 'BREAK 'PREV-ATOM? 1 0) (LIST* 'BREAK 'FROM-INDENT 0))) (LIST :KEYWORD-ARG (IL:* IL:|;;| "Keyword-arg indentation is like vertical, but args which follow keywords go on the same line as the keyword. Note this won't work real well if there are keyword values being specified for regular args.") (LIST (LIST* 'PREV-KEYWORD? (LIST* 'NEXT-INLINE? 1 'BREAK 'FROM-INDENT 1) 'BREAK 'FROM-INDENT 0) (LIST* 'SET-INDENT 'PREV-ATOM? 1 'BREAK 0) (LIST* 'PREV-KEYWORD? (LIST* 'NEXT-INLINE? 1 'BREAK 'FROM-INDENT 1) 'BREAK 'FROM-INDENT 0)) (LIST (LIST* 'PREV-KEYWORD? (LIST* 'NEXT-INLINE? 1 'BREAK 'FROM-INDENT 1) 'BREAK 'FROM-INDENT 0) (LIST* 'SET-INDENT 'BREAK 'PREV-ATOM? 1 0) (LIST* 'PREV-KEYWORD? (LIST* 'NEXT-INLINE? 1 'BREAK 'FROM-INDENT 1) 'BREAK 'FROM-INDENT 0))) (LIST :HORIZONTAL (IL:* IL:|;;| " Horizontal packs as many args on a single line as will fit. Note that only complete forms are packed together on a line, not pieces of forms. Also, the notes under :vertical about miser/preferred modes and non-atomic CARs apply here as well.") (LIST (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) (LIST* 'SET-INDENT 'PREV-ATOM? 1 'BREAK 0) (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) (LIST* 'SET-INDENT 'BREAK 'PREV-ATOM? 1 0) (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0))) (LIST :HORIZONTAL-ATOM (IL:* IL:|;;|  "break before & after keyword/arg pairs & lists, otherwise atoms stay on one line") (LIST (LIST* 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0) (LIST* 'SET-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0) (LIST* 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0) (LIST* 'SET-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0) (LIST* 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0))) (LIST :SQUASH (IL:* IL:|;;| "Squash is like horizontal except it will also pack complete forms on the ends of lines which finish off partial forms. As in (FOO/BAR) BAZ/BAM where each / indicates a line break.") (LIST (LIST* 'FROM-INDENT 'NEXT-INLINE? 0 'BREAK 0) (LIST* 'SET-INDENT 'PREV-ATOM? 1 'BREAK 0) (LIST* 'FROM-INDENT 'NEXT-INLINE? 0 'BREAK 0)) (LIST (LIST* 'FROM-INDENT 'NEXT-INLINE? 0 'BREAK 0) (LIST* 'SET-INDENT 'BREAK 'PREV-ATOM? 1 0) (LIST* 'FROM-INDENT 'NEXT-INLINE? 0 'BREAK 0))) (LIST :DATA (IL:* IL:|;;| "Data packs as many atoms on a line as will go, possibly followed by a single list. There isn't any difference between regular and miser modes.") (LIST (LIST* 'PREV-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'PREV-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0))) (LIST :BINDING (IL:* IL:|;;| "This is an \"extended binding\", as in a lambda list or the binding list of a DO. The CAR is the variable bound, the CADR is the form to bind to, and the (optional) CADDR is a sometimes-evaled form. We line up the second and third forms, basically like vertical mode.") (LIST (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) (LIST* 'SET-INDENT 1) (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'FROM-INDENT 'BREAK 0) (LIST* 'SET-INDENT 'BREAK 1) (LIST* 'FROM-INDENT 'BREAK 0))) (LIST :BINDING-LIST (IL:* IL:|;;| "This is a list of bindings, as in LETs and DOs. They all line up vertically, and each goes on its own line except strings of atoms are grouped on one line.") (LIST (LIST* 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0))) (LIST :COND-CLAUSE (IL:* IL:|;;|  "Cond clauses line up each form on its own line unless all can go on one.") (LIST (LIST* 'BREAK 0)) (LIST (LIST* 'BREAK 0))) (LIST :LAMBDA-LIST (IL:* IL:|;;| "Lambda lists go all on one line if possible. Otherwise they group strings of atoms on one line and put each initialized binding on a line by itself. Lambda-list words like &optional get exdented to the list margin and start a new level of indentation for the following forms.") (LIST (LIST* 'PREV-LAMBDAWORD? (LIST* 'NEXT-LAMBDAWORD? 0 'SET-INDENT 0) 'NEXT-LAMBDAWORD? (LIST* 'BREAK 'SET-INDENT 0) 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0)) (LIST (LIST* 'PREV-LAMBDAWORD? (LIST* 'NEXT-LAMBDAWORD? 0 'SET-INDENT 0) 'NEXT-LAMBDAWORD? (LIST* 'BREAK 'SET-INDENT 0) 'FROM-INDENT 'PREV-ATOM? (LIST* 'NEXT-ATOM? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0) 'BREAK 0)))) "Alist of keyword names and SEdit indentation specifications (2 per name).") (DEFUN GET-INDENT (NAME) (IL:* IL:|;;;| "Retrieves the SEdit-internal indent specification for NAME (if any) by looking it up.") (CDR (ASSOC NAME *INDENT-ALIST*))) (DEFUN GET-FORMAT (FNAME) (IL:* IL:|;;;| "Returns the external format specification associated with FNAME (or NIL if none).") (GETHASH FNAME *FSPEC-TABLE*)) (DEFSETF GET-INDENT (NAME) (BODY) (IL:* IL:|;;;| "Replace the indent associated with NAME, or add a new one if necessary.") `(LET ((IPAIR (ASSOC ,NAME *INDENT-ALIST*))) (IF IPAIR (SETF (CDR IPAIR) ,BODY) (PUSH (CONS ,NAME ,BODY) *INDENT-ALIST*)))) (DEFSETF GET-FORMAT SETF-OF-GET-FORMAT) (DEFUN RESET-FORMATS (&OPTIONAL SMASH-USER-REDEFINITIONS? DONT-REPARSE?) (IL:* IL:|;;;| "This installs the built-in SEdit formats. We tend to throw away all cached info on the assumption that something such as fonts may have changed and so the old info is just wrong now.") (IL:* IL:|;;| "clear tables which will get re-built") (CLRHASH LIST-FORMATS-TABLE) (IL:* IL:|;;| "install the formats we can't run without") (INSTALL-SPECIAL-FORMATS DONT-REPARSE?) (IF (NULL *FSPEC-TABLE-COPY*) (IL:* IL:|;;| "we're bootstrapping -- make a copy of *FSPEC-TABLE*") (SETQ *FSPEC-TABLE-COPY* (COPY-HASH-TABLE *FSPEC-TABLE* (MAKE-HASH-TABLE))) (WHEN SMASH-USER-REDEFINITIONS? (IL:* IL:|;;| "smash *FSPEC-TABLE-COPY* into *FSPEC-TABLE*") (COPY-HASH-TABLE *FSPEC-TABLE-COPY* *FSPEC-TABLE*))) (UNLESS DONT-REPARSE? (IL:* IL:|;;| "reparse & install all the defined list formats") (MAPHASH #'(LAMBDA (NAME FSPEC) (SETF (GET-FORMAT NAME) FSPEC)) *FSPEC-TABLE*))) (DEFUN INSTALL-SPECIAL-FORMATS (DEFAULT-AND-DATA-TOO?) (IL:* IL:|;;;| "There are four special formats that SEdit must know about in order to run at all: the :default format (used for lists in general), the :data format (used for quoted lists), the :clisp format (used for CLISP forms), and the :dotlist format (used for dotted lists). We install these here to make sure they're around!") (WHEN DEFAULT-AND-DATA-TOO? (SET-LIST-FORMAT :DEFAULT (PARSE-FORMAT (LIST :INDENT :VERTICAL :INLINE T))) (SET-LIST-FORMAT :DATA (PARSE-FORMAT (LIST :INDENT :DATA :ARGS (LIST :RECURSIVE) :INLINE T)))) (SET-LIST-FORMAT :CLISP (IL:CREATE LIST-FORMAT LIST-FORMATS IL:_ NIL LIST-INLINE? IL:_ 'ASSIGN-FORMAT-CLISP LIST-PFORMAT IL:_ 'CFV-CLISP LIST-MFORMAT IL:_ 'LINEARIZE-CLISP)) (SET-LIST-FORMAT :DOTLIST (IL:CREATE LIST-FORMAT LIST-FORMATS IL:_ NIL LIST-INLINE? IL:_ 'ASSIGN-FORMAT-DOTLIST LIST-PFORMAT IL:_ 'CFV-DOTLIST LIST-MFORMAT IL:_ 'LINEARIZE-DOTLIST))) (DEFUN PARSE-FORMAT (FORMAT-SPEC) (IL:* IL:|;;;| "A format specification is a plist. We parse it and return an SEdit internal list format object for it. ") (IL:* IL:|;;;| "REUSE is a list-format object to be re-used") (DESTRUCTURING-BIND (&KEY INDENT ARGS SUBLISTS INLINE MISER LAST) FORMAT-SPEC (FORMAT-FROM-INDENT (PARSE-INDENT INDENT) ARGS SUBLISTS INLINE MISER (GETF FORMAT-SPEC :LAST :REPEAT)))) (DEFUN SETF-OF-GET-FORMAT (NAME SPEC) (IL:* IL:|;;| "Replace the external format spec associated with NAME, or add a new one if necessary. Side effect is to associate the parsed version of the spec with NAME internally. This way, external and internal versions always stay in sync.") (IL:* IL:|;;| "SPEC is either a plist or the name of a defined format.") (WHEN *FSPEC-TABLE-COPY* (IL:* IL:|;;| "don't parse when we're bootstrapping") (LET ((FORMAT (ETYPECASE SPEC (SYMBOL (IL:* IL:\; "it's an alias") SPEC) (CONS (IL:* IL:\; "it's a real format") (PARSE-FORMAT SPEC))))) (IL:* IL:|;;| "store the internal definition") (SET-LIST-FORMAT NAME FORMAT))) (IL:* IL:|;;| "finally store external definition") (IF SPEC (SETF (GETHASH NAME *FSPEC-TABLE*) SPEC) (REMHASH NAME *FSPEC-TABLE*))) (DEFUN FORMAT-FROM-INDENT (INDENTS ARGS SUBLISTS INLINE? &OPTIONAL MISER LAST) (IL:* IL:|;;;| "We are passed the SEdit-internal preferred and miser indents (in a list), a list of the SEdit formats for the arguments (if any), and the setting of the ListInline? field, and we return a SEdit format structure that carries this information. The optional args are used to determine (1) which of the indents to put into the SEdit format, and (2) how to process the subforms list before stuffing it into the format.") (CASE LAST (:REPEAT (IL:* IL:|;;| "The last form should get the repeat formatting, so we take the last element of the subforms and push it on the front. (Note this works even if the arg info is NIL.)") (PUSH (CAR (LAST ARGS)) ARGS)) (OTHERWISE (IL:* IL:|;;| "The user wants to format the last arg specially, so we put this format at the front of the SEdit arg list.") (PUSH LAST ARGS))) (IL:* IL:|;;| "The miser arg flags if we always or never use the miser format. The default is to use whichever makes things fit best (as SEdit figures it).") (CASE MISER (:ALWAYS (SETF INDENTS (LIST (SECOND INDENTS) (SECOND INDENTS)))) (:NEVER (SETF INDENTS (LIST (FIRST INDENTS) (FIRST INDENTS))))) (IL:CREATE LIST-FORMAT LIST-FORMATS IL:_ ARGS LIST-SUBLISTS IL:_ SUBLISTS LIST-INLINE? IL:_ INLINE? LIST-PFORMAT IL:_ (SCALE-INDENT (FIRST INDENTS)) LIST-MFORMAT IL:_ (SCALE-INDENT (SECOND INDENTS)))) (DEFUN PARSE-INDENT (ISPEC &AUX INDENTS) (IL:* IL:|;;;| "An indent specification is either a keyword indent name or a list of groupings. An indent (which we return) is a list of two SEdit-internal indentation specs: the first for preferred mode and the second for miser mode. See *INDENT-ALIST* for details.") (COND ((KEYWORDP ISPEC) (SETF INDENTS (PARSE-INDENT-NAME ISPEC))) ((LISTP ISPEC) (SETF INDENTS (PARSE-INDENT-GROUPS ISPEC))) (T (CERROR "Use :vertical indentation." "Illegal indent specification: ~S" ISPEC) (SETF INDENTS (PARSE-INDENT-NAME :VERTICAL)))) (UNLESS (AND INDENTS (LISTP INDENTS)) (ERROR "Unanticipated parse error in parse-indent!")) INDENTS) (DEFUN PARSE-INDENT-NAME (NAME) (IL:* IL:|;;;| "The only special indent names are those in the *indent-alist*. So we do an error-checked lookup.") (LET ((INDENTS (GET-INDENT NAME))) (UNLESS INDENTS (CERROR "Use :vertical indentation." "Not a known indentation: ~S." NAME) (SETF INDENTS (CDR (ASSOC :VERTICAL *INDENT-ALIST*)))) INDENTS)) (DEFUN PARSE-INDENT-BODY (INDENTS OFFSET TAGBODY?) (IL:* IL:|;;;| "Creates the body part of an indentation spec. If this is a tagbody, we exdent atoms. Note that, since the first element sets the indent, the indent will be set exdented if the first element is a tag. This will screw up double-semi comments. To compensate as best we can, we make every non-exdented form in a tagbody set the tab. That way, the only double-semi comments that get screwed up are ones following an initial tag but preceding all the forms.") (IL:* IL:|;;;| "As usual, we precede everything with WholeInline? tests that disable the breaks, that way you can win if you specify :inline as a format option.") (LET* ((FIRST (IF TAGBODY? (LIST* 'BREAK 'NEXT-ATOM? 0 'SET-INDENT OFFSET) (LIST* 'SET-INDENT 'BREAK OFFSET))) (REPEAT (IF TAGBODY? (LIST* 'BREAK 'NEXT-ATOM? 0 'SET-INDENT OFFSET) (LIST* 'BREAK OFFSET)))) (IL:* IL:|;;| "Start off with the first and repeat forms.") (PUSH FIRST (FIRST INDENTS)) (PUSH FIRST (SECOND INDENTS)) (PUSH REPEAT (FIRST INDENTS)) (PUSH REPEAT (SECOND INDENTS)) (IL:* IL:|;;| "Now, since indents have this screwy last-element first format, we reverse the whole thing and then add the repeat to the beginning.") (LIST (CONS REPEAT (NREVERSE (FIRST INDENTS))) (CONS REPEAT (NREVERSE (SECOND INDENTS)))))) (DEFUN PARSE-INDENT-GROUP (INDENTS GROUP OFFSET &AUX (BREAK (LIST* 'FROM-INDENT 'BREAK 0)) (NOBREAK (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0))) (IL:* IL:|;;;| "Each group after the first (if it has any members at all) starts on a new line. And we should only be called for groups after the first. Elements after the first are handled as a normal group body.") (UNLESS (AND (NUMBERP GROUP) (= GROUP 0)) (PUSH (LIST* 'SET-INDENT 'BREAK OFFSET) (FIRST INDENTS)) (PUSH (LIST* 'SET-INDENT 'BREAK OFFSET) (SECOND INDENTS)) (PARSE-INDENT-GROUP-BODY INDENTS GROUP))) (DEFUN PARSE-INDENT-GROUP-BODY (INDENTS GROUP &AUX (BREAK (LIST* 'FROM-INDENT 'BREAK 0)) (NOBREAK (LIST* 'FROM-INDENT 'PREV-INLINE? (LIST* 'NEXT-INLINE? 0 'BREAK 0) 'BREAK 0))) (IL:* IL:|;;;| "Creates the body part of one of the distinguished groups in an indentation spec. If the spec is a simple number, we force each form in the body onto a separate line starting at the tab stop. If the spec is a number inside a list, we allow the body forms to go together on lines if they fit in line. The idea is really to allow them either to ALL go on one line or else ALL go on separate lines, but the SEdit indentation mechnism doesn't have enough power to allow this.") (IL:* IL:|;;;| "As usual, we precede everything with WholeInline? tests that disable the breaks, that way you can win if you specify :inline as a format option.") (COND ((NUMBERP GROUP) (DOTIMES (I (1- GROUP)) (PUSH BREAK (FIRST INDENTS)) (PUSH BREAK (SECOND INDENTS)))) ((AND (LISTP GROUP) (NUMBERP (FIRST GROUP))) (DOTIMES (I (1- (FIRST GROUP))) (PUSH NOBREAK (FIRST INDENTS)) (PUSH NOBREAK (SECOND INDENTS)))) (T (ERROR "Illegal indent group specification: ~S" GROUP)))) (DEFUN PARSE-INDENT-GROUP-ONE (INDENTS GROUP OFFSET ARG-1) (IL:* IL:|;;;| "The first distinguished group in an indent spec has to specially place the first arg if desired. We do that and then call the normal code to place any other args in the first group.") (UNLESS (AND (NUMBERP GROUP) (= GROUP 0)) (PUSH (CASE ARG-1 (:BREAK (LIST* 'SET-INDENT 'BREAK OFFSET)) (OTHERWISE (LIST* 'SET-INDENT OFFSET))) (FIRST INDENTS)) (PUSH (CASE ARG-1 (:NOBREAK (LIST* 'SET-INDENT OFFSET)) (:BREAK (LIST* 'SET-INDENT 'BREAK OFFSET)) (OTHERWISE (LIST* 'SET-INDENT 'NEXT-PREFERRED? OFFSET 'BREAK OFFSET))) (SECOND INDENTS)) (PARSE-INDENT-GROUP-BODY INDENTS GROUP))) (DEFUN PARSE-INDENT-GROUPS (GROUPS &AUX (ARG-1 NIL) (TAGBODY? NIL) (CURIN 1) (INDENTS (LIST NIL NIL))) (IL:* IL:|;;;| "A grouping is either a number or a list containing a single number. Each number indicates how many forms are to be indented at the current level. Each group is indented 1 step further in from the next group, except the first group is sometimes indented as a first arg. A parenthesized group number indicates that the group members can sit on one line with each other, else each form goes on its own line. Each group sets the tab.") (COND (GROUPS (IL:* IL:|;;| "the spec can be preceded by keywords: :step (increase all indentations one step), :tagbody (the body part is a tagbody), :break/:nobreak/:fit (describes where to place the first group). These can come in any order.") (DO ((G GROUPS (REST G))) ((OR (NULL G) (NOT (KEYWORDP (FIRST G)))) (SETF GROUPS G)) (CASE (FIRST G) (:STEP (INCF CURIN)) (:TAGBODY (SETF TAGBODY? T)) ((:BREAK :NOBREAK :FIT) (WHEN ARG-1 (CERROR "Ignore it." "Extra placement keyword in indentation: ~A" (FIRST G))) (SETF ARG-1 (FIRST G))) (OTHERWISE (CERROR "Ignore it." "Unrecognized indentation keyword: ~A." (FIRST G))))) (INCF CURIN (LENGTH GROUPS)) (WHEN GROUPS (PARSE-INDENT-GROUP-ONE INDENTS (FIRST GROUPS) CURIN ARG-1) (DECF CURIN) (DOLIST (IL:GROUP (REST GROUPS)) (PARSE-INDENT-GROUP INDENTS IL:GROUP CURIN) (DECF CURIN))) (PARSE-INDENT-BODY INDENTS CURIN TAGBODY?)) (T (CERROR "Use :vertical indentation." "Null indentation specification.") (PARSE-INDENT-NAME :VERTICAL)))) (DEFUN SCALE-INDENT (INDENT &OPTIONAL (INDENT-BASE (IL:FETCH INDENT-BASE IL:OF LISP-EDIT-ENVIRONMENT )) (INDENT-STEP (IL:FETCH INDENT-STEP IL:OF LISP-EDIT-ENVIRONMENT ))) (IL:* IL:|;;;| "Substitute point sizes for the indentation tab stop specifications in an indent. This definition is adapted from that for SUBST given in the Common Lisp manual. The result shares as much structure with the original as possible.") (COND ((NUMBERP INDENT) (IF (= INDENT 0) INDENT (+ INDENT-BASE (* INDENT-STEP (1- INDENT))))) ((CONSP INDENT) (LET ((IL:LEFT (SCALE-INDENT (CAR INDENT) INDENT-BASE INDENT-STEP)) (IL:RIGHT (SCALE-INDENT (CDR INDENT) INDENT-BASE INDENT-STEP))) (IF (AND (EQL IL:LEFT (CAR INDENT)) (EQL IL:RIGHT (CDR INDENT))) INDENT (CONS IL:LEFT IL:RIGHT)))) (T INDENT))) (DEFUN COPY-HASH-TABLE (OLD-TABLE NEW-TABLE) (IL:* IL:|;;| "copies the contents of OLD-TABLE into NEW-TABLE") (MAPHASH #'(LAMBDA (KEY VALUE) (SETF (GETHASH KEY NEW-TABLE) VALUE)) OLD-TABLE) NEW-TABLE) (IL:* IL:|;;| "a definer for formats") (DEF-DEFINE-TYPE IL:SEDIT-FORMATS "SEdit list formats") (DEFDEFINER (DEF-LIST-FORMAT (:UNDEFINER (LAMBDA (NAME) (SETF (GET-FORMAT NAME) 'NIL)))) IL:SEDIT-FORMATS (NAME &REST REST) (LET* ((DOCUMENTATION (IF (STRINGP (CAR REST)) (CAR REST))) (REST (IF DOCUMENTATION (CDR REST) REST))) `(SETF (GET-FORMAT ',NAME) ',(IF (ENDP (CDR REST)) (CAR REST) REST) ,@(IF DOCUMENTATION `((DOCUMENTATION ,NAME 'IL:SEDIT-FORMATS) ,DOCUMENTATION))))) (IL:PUTPROPS DEF-LIST-FORMAT IL:ARGNAMES (NAME {DOC} &KEY INDENT ARGS INLINE MISER LAST SUBLISTS)) (IL:PUTPROPS IL:SEDIT-INDENT IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-LINEAR b/sources/SEDIT-LINEAR new file mode 100644 index 00000000..0b183973 --- /dev/null +++ b/sources/SEDIT-LINEAR @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:06:11" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LINEAR.;2| 73213 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-LINEARCOMS) IL:|previous| IL:|date:| "13-Apr-88 11:51:14" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LINEAR.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-LINEARCOMS) (IL:RPAQQ IL:SEDIT-LINEARCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-LINEAR) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-LINEAR) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:FUNCTIONS CLEAR-ALL-LINEAR-FORMS CLEAR-LINEAR-FORM RELINEARIZE-PRELINEARIZED-NODE) (IL:FNS CLEAN-UP-AFTER-RELINEARIZATION FIRST-LINE-LINEAR GENERATE-LINEAR-FORM LAST-LINE-LINEAR LINE-FINISHED LINEAR-ITEM-WIDTH LINEARIZE NEW-BLOCK NEXT-LINEAR-ITEM OUTPUT-BITMAP OUTPUT-CONSTANT-STRING OUTPUT-CR OUTPUT-SPACE OUTPUT-STRING PAINT-TO-END-OF-LINE RECOMPUTE-FORMAT-VALUES RELINEARIZE REPAINT REUSE-LINEAR-FORM SHIFT-BLOCK TRY-REUSING-BITS))) (IL:PUTPROPS IL:SEDIT-LINEAR IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-LINEAR IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (DEFUN CLEAR-ALL-LINEAR-FORMS (CONTEXT) (WALK-UP-TREE (SUBNODE 1 (IL:|fetch| ROOT IL:|of| CONTEXT)) CONTEXT #'CLEAR-LINEAR-FORM)) (DEFUN CLEAR-LINEAR-FORM (NODE) (IL:* IL:|;;;| "throw away old linear form (and create new one if a prelinearized node)") (COND ((IL:|fetch| LINEARIZE IL:|of| (IL:|fetch| NODE-TYPE IL:|of| NODE)) (IL:|replace| START-X IL:|of| NODE IL:|with| 0) (IL:|replace| LINEAR-FORM IL:|of| NODE IL:|with| (CREATE-WEAK-LINK NODE))) (T (RELINEARIZE-PRELINEARIZED-NODE NODE))) (IL:|replace| LINEAR-THREAD IL:|of| NODE IL:|with| NIL)) (DEFUN RELINEARIZE-PRELINEARIZED-NODE (NODE) (IL:* IL:|;;;| "we've changed a prelinearized node. fix up the width estimates") (LET ((LITEM (CAR (IL:|fetch| LINEAR-FORM IL:|of| NODE)))) (WHEN (TYPEP LITEM 'STRING-ITEM) (LET ((NEW-WIDTH (STRINGWIDTH (IL:|fetch| STRING IL:|of| LITEM) (IL:|fetch| FONT IL:|of| LITEM) (IL:|fetch| PRIN-2? IL:|of| LITEM)))) (IL:|replace| WIDTH IL:|of| LITEM IL:|with| NEW-WIDTH) (IL:|replace| INLINE-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| PREFERRED-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| ACTUAL-WIDTH IL:|of| NODE IL:|with| NEW-WIDTH) (IL:|replace| ACTUAL-LLENGTH IL:|of| NODE IL:|with| NEW-WIDTH))))) (IL:DEFINEQ (clean-up-after-relinearization (il:lambda (context node following-line y-1 y-2) (il:* il:\; "Edited 17-Nov-87 11:37 by DCB") (il:* il:|;;;| "we've just finished relinearizing this node. adjust the y coordinates of everything that follows, and fix up the rest of the window. y1 and y2 record where the following lines start and how far they must be shifted") (let* ((window (il:fetch display-window il:of context)) (extent (il:windowprop window (quote il:extent))) (bottom (il:fetch window-bottom il:of context)) (left (il:fetch window-left il:of context)) (window-width (il:add1 (il:idifference (il:fetch window-right il:of context) left))) delta ry-1 ry-2) (cond (following-line (il:* il:|;;| "there are lines after this node. fix up the links, adjust their y coordinates, and fix the window's extent") (il:* il:|;;| "used to be replace PrevLine of following.line with (fetch LastLineLinear of node)") (il:replace prev-line il:of following-line il:with (last-line-linear node context)) (il:setq delta (il:idifference (il:fetch next-line-y il:of (il:fetch last-line il:of node)) (il:fetch ycoord il:of following-line))) (when (not (eq 0 delta)) (il:bind (line il:_ following-line) il:do (il:add (il:fetch ycoord il:of line) delta) il:repeatwhile (il:setq line (car (il:fetch next-line il:of line)))) (il:add (il:fetch (il:region il:bottom) il:of extent) delta) (il:add (il:fetch (il:region il:height) il:of extent) (il:iminus delta))) (il:* il:|;;| "if the following stuff isn't off the bottom of the window, we'll have to fix it up") (when (and y-2 (il:igeq y-2 bottom)) (cond ((il:igeq y-2 (il:fetch window-top il:of context)) (il:* il:|;;| "none of the changes were visible, so we just have to twiddle the coordinate system") (il:wyoffset (il:idifference y-1 y-2) window)) ((il:neq y-1 y-2) (cond ((il:igreaterp y-1 y-2) (il:* il:|;;| "bitblt the following lines up, and repaint below them") (il:setq ry-1 y-2) (il:setq ry-2 (il:iplus y-2 1 (il:idifference y-2 y-1))) (if (il:igreaterp ry-2 bottom) (il:bitblt window left (il:iplus (il:idifference y-1 y-2) bottom) window left bottom window-width (il:idifference ry-2 bottom)) (il:setq ry-2 bottom))) (t (il:* il:|;;| "the following stuff moves down, if it hasn't already been overwritten") (cond ((il:igeq y-1 bottom) (il:setq ry-1 (il:fetch ycoord il:of following-line)) (il:setq ry-2 (il:iplus (il:sub1 bottom) (il:idifference y-2 y-1))) (il:bind (next-line il:_ following-line) next-line-y il:while (and next-line (il:igeq (il:setq next-line-y (if (il:setq next-line (car (il:fetch next-line il:of next-line))) (il:fetch ycoord il:of next-line) (il:fetch next-line-y il:of following-line))) ry-2)) il:do (il:setq following-line next-line) (il:setq ry-1 next-line-y)) (il:setq ry-2 (il:iplus ry-1 (il:idifference y-1 y-2))) (il:bitblt window left (il:add1 ry-2) window left (il:add1 ry-1) window-width (il:idifference y-1 ry-2))) (t (il:setq ry-1 y-2))) (il:setq ry-2 bottom))) (il:* il:|;;| "now that we've figured out what needs to be repainted, blank the area and repaint it") (il:bltshade il:whiteshade window left ry-2 window-width (il:add1 (il:idifference ry-1 ry-2))) (when following-line (repaint context (il:fetch indent il:of following-line) (il:fetch base-line-y il:of following-line) (cdr (il:fetch next-line il:of (car (il:fetch prev-line il:of following-line)))) ry-2)))))) (t (il:* il:|;;| "there's nothing after the relinearized material -- blank anything after it on the window and adjust the extent") (when (and y-2 (il:igreaterp y-2 y-1)) (il:bltshade il:whiteshade window left y-1 window-width (il:idifference y-2 y-1))) (il:setq delta (il:fetch next-line-y il:of (il:fetch last-line il:of node))) (il:replace (il:region il:bottom) il:of extent il:with (il:add1 delta)) (il:replace (il:region il:height) il:of extent il:with (il:iminus delta)))))) ) (first-line-linear (il:lambda (node context) (il:* il:\; "Edited 17-Nov-87 11:38 by DCB") (il:* il:|;;;| "find the info which used to be stored in FirstLineLinear (i.e. the tail of the linear form beginning with the first line of this node). we try to step back one more line and then forward; if this is the first line we know it must be the beginning of the root's linear form") (and (il:setq node (il:fetch first-line il:of node)) (if (il:fetch prev-line il:of node) (il:fetch next-line il:of (car (il:fetch prev-line il:of node))) (il:fetch linear-form il:of (il:fetch root il:of context))))) ) (generate-linear-form (il:lambda (node context right-margin) (il:* il:\; "Edited 7-Apr-88 11:02 by woz") (il:* il:|;;;| "we need to compute the linear form of this node. if there's a previously computed linear form and it fits the constraints, we can just reuse it; otherwise call the Linearize method for the node") (let ((current-x (il:|fetch| current-x il:|of| context)) (linearize (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (il:* il:|;;| "this next IF test is ugly. want to reuse the LF if we can. Don't try to reuse the root's LF, becuase it starts with a line start which messes up scan.for.bounds, and the root has no bits on the screen so there's no savings in reusing it. Otherwise check if it has changed, and if it will fit is the new space provided (we might be reshaping), and if all those pass, then reuse the LF.") (cond ((or (null linearize) (and (il:neq node (il:|fetch| root il:|of| context)) (il:neq (il:|fetch| start-x il:|of| node) 0) (not (il:|fetch| changed? il:|of| node)) (or (il:ileq (il:iplus current-x (il:|fetch| actual-width il:|of| node)) right-margin) (il:ileq (il:idifference (il:|fetch| right-margin il:|of| node) (il:|fetch| start-x il:|of| node)) (il:idifference right-margin current-x))) (or (il:|fetch| inline? il:|of| node) (il:igeq (il:idifference (il:|fetch| right-margin il:|of| node) (il:|fetch| start-x il:|of| node)) (il:idifference right-margin current-x))))) (il:* il:|;;| "the old linear form will do") (il:|replace| right-margin il:|of| node il:|with| right-margin) (reuse-linear-form node context)) (t (il:* il:\; "we've got to call the Linearize method. initialize various random fields and do it") (il:|replace| start-x il:|of| node il:|with| current-x) (il:|replace| right-margin il:|of| node il:|with| right-margin) (il:|replace| actual-width il:|of| node il:|with| 0) (il:|replace| first-line il:|of| node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| current-node il:|of| context il:|with| node) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| 0) (cond ((il:|fetch| super-node il:|of| node) (il:* il:\; "setup pointers to start at the beginning of this nodes linear form.") (il:|replace| linear-pointer il:|of| context il:|with| (il:|fetch| linear-form il:|of| node)) (il:|replace| linear-prev il:|of| context il:|with| node)) (t (il:* il:|;;| "(hack) the linear form of the root doesn't correspond to what linearize.root will produce, since it has the initial line start as its first element. this should be fixed, but in the meantime we'll just skip over it") (il:* il:|;;| "SO: here the linear form of the root is alread set to a list of the first line start and a weak-link. make the linear-pointer point into the list at the weak-link.") (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-form il:|of| node)))))) (il:|replace| actual-llength il:|of| node il:|with| nil) (funcall linearize node context) (il:* il:|;;| "now we're done with this node (and thus its subnodes), so move back to its super.") (il:|replace| current-node il:|of| context il:|with| (il:|fetch| super-node il:|of| node)) (when (not (and (il:|type?| weak-link (il:|fetch| linear-pointer il:|of| context)) (eq (il:fetch destination il:of (il:|fetch| linear-pointer il:|of| context)) node))) (il:* il:|;;| "we should have finished linearizing the node, and so linear-pointer will be at the weak-link. if not, (i guess it didn't need to be relinearized? and thus the matching? test below?) set it there so we can go on.") (set-linear context (cdr (last (il:fetch linear-form il:of node)))) (when (il:|fetch| matching? il:|of| context) (new-block context) (il:|replace| matching? il:|of| context il:|with| nil))) (il:* il:\; "used to be replace LastLineLinear of x with (fetch CurrentLine of context)") (il:|replace| last-line il:|of| node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| actual-width il:|of| node il:|with| (il:idifference (il:imax (il:|fetch| actual-width il:|of| node) (il:|fetch| current-x il:|of| context)) current-x)) (il:|replace| actual-llength il:|of| node il:|with| (il:idifference (il:|fetch| current-x il:|of| context) current-x))))) (il:|replace| changed? il:|of| node il:|with| nil)) ) (last-line-linear (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 12:47 by DCB") (il:* il:|;;| "find the info which used to be stored in LastLineLinear (i.e. the tail of the linear form beginning with the last line of this node). we try to step back one more line and then forward; if there is no previous line then the whole linear form must be on one line, and thus the last line is simply the root's linear form") (and (il:setq node (il:fetch last-line il:of node)) (if (il:fetch prev-line il:of node) (il:fetch next-line il:of (car (il:fetch prev-line il:of node))) (il:fetch linear-form il:of (il:fetch root il:of context))))) ) (line-finished (il:lambda (context x linear force) (il:* il:\; "Edited 17-Nov-87 11:38 by DCB") (il:* il:|;;;| "we've finished a line which is visible (or above the window) we only flush it if it reuses bits or we're forced") (when (il:fetch below? il:of context) (il:shouldnt "tried to flush a line off the bottom of the screen")) (let ((this-line (car (il:fetch current-line il:of context)))) (when (il:ilessp (il:fetch next-line-y il:of this-line) (il:fetch window-bottom il:of context)) (il:* il:|;;| "this is the last line visible in the window. force it and don't come back") (il:replace below? il:of context il:with t) (il:setq force t)) (cond ((il:ilessp (il:fetch next-line-y il:of this-line) (il:fetch window-top il:of context)) (il:* il:|;;| "it's visible. fix up the block list, and then check if any of them can reuse bits visible in the window") (il:replace block-width il:of (il:fetch current-block il:of context) il:with (il:idifference x (il:fetch block-new-x il:of (il:fetch current-block il:of context)))) (il:replace block-start il:of (or (il:fetch next-block il:of (il:fetch current-block il:of context)) (il:replace next-block il:of (il:fetch current-block il:of context) il:with (il:create line-block))) il:with linear) (when (il:type? line-start (car (il:fetch block-start il:of (il:fetch first-block il:of context)))) (il:replace block-start il:of (il:fetch first-block il:of context) il:with (cdr (il:fetch block-start il:of (il:fetch first-block il:of context))))) (il:for (block il:_ (il:fetch first-block il:of context)) il:by (il:fetch next-block il:of block) il:do (when (and (il:fetch bits? il:of block) (try-reusing-bits context block)) (il:* il:|;;| "found some bits we can reuse, so paint up to this point and make sure we dump the rest of this line") (il:setq force t)) il:repeatuntil (eq block (il:fetch current-block il:of context)) il:finally (when force (il:* il:|;;| "display the rest") (paint-to-end-of-line context linear) (when linear (il:* il:|;;| "that wasn't the last line, so set up for the next") (il:replace repaint-start il:of context il:with linear) (il:replace repaint-line il:of context il:with (car linear)) (il:replace repaint-x il:of context il:with (il:fetch indent il:of (car linear))) (when (and (il:fetch matching? il:of context) (not (il:fetch visible? il:of context)) (il:ileq (il:fetch old-bottom il:of (car linear)) (il:fetch window-top il:of context))) (il:* il:|;;| "we were off the top of the screen, but now we're on") (il:replace visible? il:of context il:with t)))))) (linear (il:* il:|;;| "when it's off the top of the window, we just have to reset things (unless it was the last)") (il:replace repaint-start il:of context il:with linear) (il:replace repaint-line il:of context il:with (car linear)) (il:replace repaint-x il:of context il:with (il:fetch indent il:of (car linear))) (when (and (il:fetch matching? il:of context) (not (il:fetch visible? il:of context)) (il:ileq (il:fetch old-bottom il:of (car linear)) (il:fetch window-top il:of context))) (il:replace visible? il:of context il:with t)))))) ) (linear-item-width (il:lambda (item) (il:* il:\; "Edited 17-Nov-87 11:39 by DCB") (il:* il:|;;;| "determine the amount of horizontal space taken up by this linear form item") (cond ((il:fixp item) item) ((il:type? string-item item) (il:fetch width il:of item)) ((il:listp item) (il:bitmapwidth (cdr item))) (t (il:shouldnt "this doesn't have a linear width")))) ) (linearize (il:lambda (node context right-margin) (il:* il:\; "Edited 13-Apr-88 10:38 by woz") (il:* il:|;;| "fill in the linear form of this node. make sure that we're actually running as an editor (not just a pretty printer)") (cond ((il:|fetch| relinearization-time-stamp il:|of| context) (il:* il:\; "we're actually editing") (prog ((super-node (il:|fetch| current-node il:|of| context))) (when (or (il:neq super-node (il:|fetch| super-node il:|of| node)) (il:ileq (il:|fetch| sub-node-index il:|of| node) (il:|fetch| last-linearized-sub-node-index il:|of| context))) (il:shouldnt "this node shouldn't be linearized now")) (when (and (il:|fetch| matching? il:|of| context) (next-linear context node)) (il:* il:\;  "we're already matching -- all's cool. fix up the LinearThread in case it's been smashed.") (il:|replace| linear-thread il:|of| node il:|with| (il:|fetch| linear-pointer il:|of| context)) (go ok)) (cond ((il:|fetch| linear-thread il:|of| node) (il:* il:\;  "was already linearized -- skip to the appropriate point in the super's linear form") (set-linear context (il:|fetch| linear-thread il:|of| node))) (t (il:* il:\;  "insert this node in the super's linear form") (set-linear context (cons (create-weak-link node) (il:|fetch| linear-pointer il:|of| context))) (il:|replace| linear-thread il:|of| node il:|with| (il:|fetch| linear-pointer il:|of| context)))) (when (il:|fetch| matching? il:|of| context) (il:* il:\;  "we were matching, but lost -- start a new block") (new-block context) (il:|replace| matching? il:|of| context il:|with| nil)) (when (and (not (il:|fetch| below? il:|of| context)) (il:neq (il:|fetch| start-x il:|of| node) 0) (il:igeq (il:|fetch| old-top il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-bottom il:|of| context)) (or (not (il:|fetch| changed? il:|of| node)) (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (il:* il:\; "we can start matching") (il:|replace| matching? il:|of| context il:|with| t) (when (or (il:|replace| visible? il:|of| context il:|with| (and (il:ileq (il:|fetch| start-x il:|of| node) (il:|fetch| window-right il:|of| context)) (il:ileq (il:|fetch| old-bottom il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-top il:|of| context)))) t) (il:* il:\;  "the stuff we're matching is visible, so build a block describing it") (new-block context) (let ((block (il:|fetch| current-block il:|of| context)) (line (il:|fetch| first-line il:|of| node))) (il:|replace| bits? il:|of| block il:|with| t) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| start-x il:|of| node)) (cond ((eq (il:|fetch| cache-time il:|of| line) (il:|fetch| relinearization-time-stamp il:|of| context )) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| cached-y il:|of| line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| cached-ascent il:|of| line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| cached-descent il:|of| line)) ) (t (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| line)) ))))) ok (il:* il:\;  "we're ready to actually construct/check the linear form") (generate-linear-form node context (or right-margin (il:|fetch| right-margin il:|of| super-node))) (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|fetch| linear-prev il:|of| context))) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| (il:|fetch| sub-node-index il:|of| node)) (il:|replace| actual-width il:|of| super-node il:|with| (il:imax (il:|fetch| actual-width il:|of| super-node) (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| actual-width il:|of| node)))) (return (il:|fetch| inline? il:|of| node)))) (t (il:* il:\;  "we're pretty printing -- just call the Linearize method, or use the fixed linear form") (il:|replace| right-margin il:|of| node il:|with| (or right-margin (il:|fetch| right-margin il:|of| (il:|fetch| super-node il:|of| node))) ) (il:|replace| start-x il:|of| node il:|with| (il:|fetch| current-x il:|of| context)) (cond ((il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)) (let ((me (il:|fetch| current-node il:|of| context))) (il:|replace| current-node il:|of| context il:|with| node) (funcall (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)) node context) (il:|replace| current-node il:|of| context il:|with| me))) (t (il:* il:\;  "this node has a fix linear form (i.e. it's been prelinearized) so just output it") (output-constant-string context (car (il:|fetch| linear-form il:|of| node))))))))) (new-block (il:lambda (context) (il:* il:\; "Edited 8-Jul-87 17:36 by DCB") (il:* il:|;;;| "start a new block in the block list describing this line (we've started or stopped matching)") (let ((block (il:fetch current-block il:of context)) (x (il:fetch current-x il:of context))) (when (il:neq x (il:fetch block-new-x il:of block)) (il:* il:|;;| "the current one is non empty, so we need a new one. fill in the width of the current one before we move on. if there isn't already a next block we'll have to create one") (il:replace block-width il:of block il:with (il:idifference x (il:fetch block-new-x il:of block))) (il:replace current-block il:of context il:with (il:setq block (or (il:fetch next-block il:of block) (il:replace next-block il:of block il:with (il:create line-block))))) (il:replace block-new-x il:of block il:with x)) (il:replace block-start il:of block il:with (il:fetch linear-pointer il:of context)) (il:replace bits? il:of block il:with nil))) ) (next-linear-item (il:lambda (linear) (il:* il:\; "Edited 13-Apr-88 11:46 by woz") (il:* il:|;;;| "find the first linear item starting from this point, expanding subnodes") (il:|do| (cond ((not (il:listp linear)) (il:* il:|;;|  "we're at the end of this node's linear form -- continue from where it appeared in its super") (il:setq linear (cdr (il:|fetch| linear-thread il:|of| (il:|fetch| destination il:|of| linear))))) ((il:|type?| weak-link (car linear)) (il:* il:|;;| "it's a subnode -- examine its linear form") (il:setq linear (il:|fetch| linear-form il:|of| (il:fetch destination il:of (car linear))))) (t (return linear)))))) (output-bitmap (il:lambda (context bitmap) (il:* il:\; "Edited 17-Nov-87 11:39 by DCB") (il:* il:|;;;| "insert a bitmap at this point in the linear form") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. if this bitmap wasn't already there, insert it (this means we're no longer matching)") (when (not (next-linear context bitmap)) (set-linear context (cons bitmap (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil))) (step-linear context) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:idifference (il:bitmapheight (cdr bitmap)) (car bitmap)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:iminus (car bitmap)))) (advance (il:bitmapwidth (cdr bitmap)))) (t (il:* il:|;;| "we're pretty printing. we haven't implemented bitmaps here. there's no real problem, but we do have to fix linear.item.width") (il:shouldnt "the pretty printer doesn't like bitmaps")))) ) (output-constant-string (il:lambda (context stringitem) (il:* il:\; "Edited 7-Jul-87 12:48 by DCB") (il:* il:|;;| "insert a fixed string in the linear form. fixed strings are previously generated stringitems (improves efficiency)") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. if this stringitem wasn't already there, insert it (this means we're no longer matching)") (cond ((next-linear context stringitem) (step-linear context)) (t (il:* il:|;;| "this is gratuitously complicated. it could be like output.bitmap (except that this is marginally faster)") (let ((linear (cons stringitem (il:fetch linear-pointer il:of context)))) (if (il:listp (il:fetch linear-prev il:of context)) (rplacd (il:fetch linear-prev il:of context) linear) (il:replace linear-form il:of (il:fetch linear-prev il:of context) il:with linear)) (il:replace linear-prev il:of context il:with linear) (when (il:fetch matching? il:of context) (new-block context) (il:replace block-start il:of (il:fetch current-block il:of context) il:with linear) (il:replace matching? il:of context il:with nil))))) (advance (il:fetch width il:of stringitem)) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop (il:fetch font il:of stringitem) (quote il:ascent)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop (il:fetch font il:of stringitem) (quote il:descent))))) (t (il:* il:|;;| "we're pretty printing. we have to map the font because TEDIT.INSERT does weird things with interpress fonts") (il:tedit.insert (il:fetch display-window il:of context) (cond ((il:fetch prin-2? il:of stringitem) (il:* il:\; "read table specific") (il:mkstring (il:fetch string il:of stringitem) t)) (t (il:fetch string il:of stringitem))) nil (map-font (il:fetch font il:of stringitem) (il:fetch environment il:of context)) t) (il:add (il:fetch current-x il:of context) (il:fetch width il:of stringitem))))) ) (output-cr (il:lambda (context indent lineskip) (il:* il:\; "Edited 8-Jul-87 17:21 by DCB") (il:* il:|;;| "insert a line start in the linear form. this is rather tricky because we need to update the window as we go") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:|;;| "we're editing. compute various dimensions") (let ((last-line (car (il:fetch current-line il:of context))) (current-node (il:fetch current-node il:of context)) y this-line match-x match-baseline match-ascent match-descent) (when (null lineskip) (il:setq lineskip (il:fetch default-line-skip il:of (il:fetch environment il:of context)))) (il:setq y (il:idifference (il:fetch ycoord il:of last-line) (il:fetch line-height il:of last-line))) (il:replace actual-width il:of current-node il:with (il:imax (il:fetch actual-width il:of current-node) (il:fetch current-x il:of context))) (il:* il:|;;| "if there's already a line start at this point, we can smash it, but we have to cache its old values for use when fixing up the screen") (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:type? line-start (il:setq this-line (car (il:fetch linear-pointer il:of context))))) (when (not (il:fetch below? il:of context)) (il:replace cached-ascent il:of this-line il:with (il:setq match-ascent (il:fetch line-ascent il:of this-line))) (il:replace cached-descent il:of this-line il:with (il:setq match-descent (il:fetch line-descent il:of this-line))) (il:replace cached-y il:of this-line il:with (il:setq match-baseline (il:fetch base-line-y il:of this-line))) (il:replace cache-time il:of this-line il:with (il:fetch relinearization-time-stamp il:of context)) (il:setq match-x (il:fetch indent il:of this-line))) (il:replace prev-line il:of this-line il:with (il:fetch current-line il:of context)) (il:replace line-skip il:of this-line il:with lineskip) (il:replace line-ascent il:of this-line il:with 0) (il:replace line-descent il:of this-line il:with 0) (il:replace indent il:of this-line il:with indent) (il:replace ycoord il:of this-line il:with y)) (t (il:* il:|;;| "there was no line start here before. create one") (set-linear context (cons (il:setq this-line (il:create line-start prev-line il:_ (il:fetch current-line il:of context) node il:_ (il:fetch current-node il:of context) line-skip il:_ lineskip line-ascent il:_ 0 line-descent il:_ 0 indent il:_ indent ycoord il:_ y)) (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (il:setq match-x (il:fetch current-block il:of context)) (il:setq match-ascent (il:fetch block-ascent il:of match-x)) (il:setq match-descent (il:fetch block-descent il:of match-x)) (il:setq match-baseline (il:fetch block-base-line il:of match-x)) (il:setq match-x (il:iplus (il:fetch current-x il:of context) (il:idifference (il:fetch block-x il:of match-x) (il:fetch block-new-x il:of match-x))))))) (il:replace line-length il:of last-line il:with (il:fetch current-x il:of context)) (il:selectq (il:fetch below? il:of context) (nil (il:* il:\; "this line might be visible. flush it and reset the block list") (line-finished context (il:fetch current-x il:of context) (il:fetch linear-pointer il:of context)) (il:replace shift-y il:of context il:with nil) (let ((block (il:fetch first-block il:of context))) (il:replace current-block il:of context il:with block) (il:replace block-new-x il:of block il:with indent) (il:replace block-start il:of block il:with (il:fetch linear-pointer il:of context)) (when (il:replace bits? il:of block il:with (il:fetch matching? il:of context)) (il:replace block-x il:of block il:with match-x) (il:replace block-base-line il:of block il:with match-baseline) (il:replace block-ascent il:of block il:with match-ascent) (il:replace block-descent il:of block il:with match-descent)))) (new (il:* il:\; "we're repainting this window from the top. nothing should be reused") (repaint-new-line (il:fetch current-line il:of context))) nil) (il:replace current-line il:of context il:with (il:fetch linear-pointer il:of context)) (il:replace next-line il:of last-line il:with (il:fetch current-line il:of context)) (il:replace current-x il:of context il:with indent) (step-linear context))) (t (il:* il:|;;| "we're pretty printing") (il:tedit.insert (il:fetch display-window il:of context) (il:fcharacter (il:charcode il:cr)) nil nil t) (il:tedit.paralooks (il:fetch display-window il:of context) (list (quote -1-stleftmargin) (il:fixr (il:quotient indent il:micasperpt)) (quote paraleading) (or lineskip (il:fetch default-line-skip il:of (il:fetch environment il:of context))))) (il:replace current-x il:of context il:with indent)))) ) (output-space (il:lambda (context x) (il:* il:\; "Edited 17-Nov-87 11:40 by DCB") (il:* il:|;;;| "insert horizontal space at this point in the linear form") (cond ((eq 0 x) (il:* il:\; "insert no space; that's easy!") nil) ((il:fetch relinearization-time-stamp il:of context) (il:* il:\; "we're editing") (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:smallp (car (il:fetch linear-pointer il:of context)))) (when (and (il:fetch matching? il:of context) (il:neq (car (il:fetch linear-pointer il:of context)) x)) (new-block context) (il:replace matching? il:of context il:with nil)) (rplaca (il:fetch linear-pointer il:of context) x)) (t (set-linear context (cons x (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil)))) (step-linear context) (advance x)) (t (il:* il:|;;| "we're pretty printing") (il:for i il:from 1 il:to (il:iquotient x (il:fetch space-width il:of (il:fetch environment il:of context))) il:do (il:tedit.insert (il:fetch display-window il:of context) " " nil il:defaultfont t)) (il:add (il:fetch current-x il:of context) x)))) ) (output-string (il:lambda (context string prin-2? font) (il:* il:\; "Edited 7-Jul-87 12:49 by DCB") (il:* il:\; "insert a string at this point in the linear form") (cond ((il:fetch relinearization-time-stamp il:of context) (il:* il:\; "we're editing") (let (this-item width) (when (null font) (il:* il:\; "font defaults to the DefaultFont of this environment") (il:setq font (il:fetch default-font il:of (il:fetch environment il:of context)))) (cond ((and (il:listp (il:fetch linear-pointer il:of context)) (il:type? string-item (il:setq this-item (car (il:fetch linear-pointer il:of context))))) (il:* il:\; "there was already a string at this point. is it the same one?") (cond ((or (il:neq (il:fetch string il:of this-item) string) (il:neq (il:fetch font il:of this-item) font) (il:neq (il:fetch prin-2? il:of this-item) prin-2?)) (il:* il:\; "it's different. reuse the structure, but recompute everything and smash all the fields") (il:* il:\; "read table specific") (il:setq width (stringwidth string font prin-2?)) (il:replace string il:of this-item il:with string) (il:replace width il:of this-item il:with width) (il:replace font il:of this-item il:with font) (il:replace prin-2? il:of this-item il:with prin-2?) (when (il:fetch matching? il:of context) (new-block context) (il:replace matching? il:of context il:with nil))) (t (il:* il:\; "it's the same. this is easy") (il:setq width (il:fetch width il:of this-item))))) (t (il:* il:\; "we need to create a new StringItem") (il:* il:\; "read table specific") (il:setq width (stringwidth string font prin-2?)) (set-linear context (cons (il:create string-item string il:_ string width il:_ width font il:_ font prin-2? il:_ prin-2?) (il:fetch linear-pointer il:of context))) (when (il:fetch matching? il:of context) (il:* il:\; "not anymore") (new-block context) (il:replace matching? il:of context il:with nil)))) (step-linear context) (il:change (il:fetch line-ascent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop font (quote il:ascent)))) (il:change (il:fetch line-descent il:of (car (il:fetch current-line il:of context))) (il:imax il:datum (il:fontprop font (quote il:descent)))) (advance width))) (t (il:* il:|;;| "we're pretty printing. we have to map the font because TEDIT.INSERT does weird things with interpress fonts") (il:tedit.insert (il:fetch display-window il:of context) (cond (prin-2? (il:* il:\; "read table specific") (il:setq string (il:mkstring string t))) (t string)) nil (map-font (or font (il:setq font (il:fetch default-font il:of (il:fetch environment il:of context)))) (il:fetch environment il:of context)) t) (il:add (il:fetch current-x il:of context (stringwidth string font)))))) ) (paint-to-end-of-line (il:lambda (context linear-end) (il:* il:\; "Edited 17-Nov-87 11:40 by DCB") (il:* il:|;;;| "update the window to the end of the current line") (let ((this-line (car (il:fetch current-line il:of context)))) (cond ((eq (il:fetch repaint-line il:of context) this-line) (il:* il:|;;| "we've already started displaying some of this line") (let ((blank-from (cond ((eq (il:fetch repaint-x il:of context) (il:fetch indent il:of this-line)) (il:* il:|;;| "painting from the start of the line, so blank from left edge of window") (il:fetch window-left il:of context)) (t (il:* il:|;;| "just blank the part we're repainting") (il:fetch repaint-x il:of context))))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) blank-from (il:add1 (il:fetch next-line-y il:of this-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) blank-from)) (il:fetch line-height il:of this-line))) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of this-line) (il:fetch repaint-start il:of context) linear-end)) (t (il:* il:|;;| "there are several lines which need to be repainted") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of this-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) (il:idifference (il:fetch ycoord il:of (il:fetch repaint-line il:of context)) (il:fetch next-line-y il:of this-line))) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) (cdr (il:fetch repaint-start il:of context)) linear-end))))) ) (recompute-format-values (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 12:49 by DCB") (let (changed?) (if (eq (il:fetch node-type il:of node) type-litatom) (il:setq changed? (il:fetch inline-width il:of node)) (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (recompute-format-values subnode context) (when (il:fetch changed? il:of subnode) (il:setq changed? t)))) (funcall (il:fetch compute-format-values il:of (il:fetch node-type il:of node)) node (il:fetch environment il:of context) context) (when (and changed? (il:neq changed? (il:fetch inline-width il:of node))) (il:replace changed? il:of node il:with t)))) ) (relinearize (il:lambda (node context) (il:* il:\; "Edited 7-Apr-88 11:04 by woz") (il:* il:|;;;| "some part of this node has changed. do all the work necessary to update the linear form and window. this function is never supposed to be an entry point. that is, it assumes it will run under an sedit profile.") (let ((super-node (il:|fetch| super-node il:|of| node)) following-line from-top (old-actual-width (il:|fetch| actual-width il:|of| node)) (old-actualllength (il:|fetch| actual-llength il:|of| node)) (old-last-line (il:|fetch| last-line il:|of| node)) (display-window-region (il:dspclippingregion nil (il:|fetch| display-window il:|of| context))) y-1 y-2) (il:* il:\; "we cache the window dimensions because they're needed so often") (il:|replace| window-left il:|of| context il:|with| (il:|fetch| (il:region il:left) il:|of| display-window-region)) (il:|replace| window-bottom il:|of| context il:|with| (il:|fetch| (il:region il:bottom) il:|of| display-window-region)) (il:|replace| window-right il:|of| context il:|with| (il:|fetch| (il:region il:right) il:|of| display-window-region)) (il:|replace| window-top il:|of| context il:|with| (il:|fetch| (il:region il:top) il:|of| display-window-region)) (cond (super-node (il:* il:\; "the usual case: some node changed and we want to do a minimal update") (il:|replace| relinearization-time-stamp il:|of| context il:|with| (il:add1 (il:|fetch| relinearization-time-stamp il:|of| context))) (il:|replace| shift-y il:|of| context il:|with| nil) (il:|replace| shift-down il:|of| context il:|with| 0) (let ((first-line (il:|fetch| first-line il:|of| node)) first-line-linear) (il:setq first-line-linear (first-line-linear node context)) (cond ((il:|replace| below? il:|of| context il:|with| (il:ilessp (il:|fetch| ycoord il:|of| (il:|fetch| first-line il:|of| node)) (il:|fetch| window-bottom il:|of| context))) (il:|replace| matching? il:|of| context il:|with| nil)) (t (il:|replace| matching? il:|of| context il:|with| (il:neq (il:|fetch| start-x il:|of| node) 0)) (let ((block (il:|fetch| first-block il:|of| context))) (il:|replace| current-block il:|of| context il:|with| block) (il:|replace| visible? il:|of| context il:|with| (il:ilessp (il:|fetch| next-line-y il:|of| first-line) (il:|fetch| window-top il:|of| context))) (il:|replace| block-start il:|of| block il:|with| first-line-linear) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| indent il:|of| first-line)) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| indent il:|of| first-line)) (cond ((il:|fetch| matching? il:|of| context) (il:|replace| bits? il:|of| block il:|with| t) (il:|replace| block-width il:|of| block il:|with| (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| block-x il:|of| block))) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| first-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| first-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| first-line))) (t (il:|replace| bits? il:|of| block il:|with| nil))) (il:|replace| repaint-x il:|of| context il:|with| (il:|fetch| indent il:|of| first-line)) (il:|replace| repaint-line il:|of| context il:|with| first-line) (il:|replace| repaint-start il:|of| context il:|with| first-line-linear)))) (il:|replace| cached-ascent il:|of| first-line il:|with| (il:|fetch| line-ascent il:|of| first-line)) (il:|replace| cached-descent il:|of| first-line il:|with| (il:|fetch| line-descent il:|of| first-line)) (il:|replace| cached-y il:|of| first-line il:|with| (il:|fetch| base-line-y il:|of| first-line)) (il:|replace| cache-time il:|of| first-line il:|with| (il:|fetch| relinearization-time-stamp il:|of| context)) (scan-for-bounds (cdr first-line-linear) (il:|fetch| linear-thread il:|of| node) first-line-linear t))) (t (il:* il:|;;| "we're redisplaying everything from scratch (probably because the window was reshaped). node is the root node ") (il:bltshade il:whiteshade (il:|fetch| display-window il:|of| context) (il:|fetch| (il:region il:left) il:|of| display-window-region) (il:|fetch| (il:region il:bottom) il:|of| display-window-region) (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:|fetch| (il:region il:height) il:|of| display-window-region)) (il:|replace| shift-down il:|of| context il:|with| nil) (il:setq from-top t) (il:|replace| below? il:|of| context il:|with| (quote new)) (il:|replace| matching? il:|of| context il:|with| nil) (il:* il:|;;| "must set ascent and descent of first line because the linearizer never touches this line start") (il:|replace| line-ascent il:|of| (il:|fetch| first-line il:|of| node) il:|with| 0) (il:|replace| line-descent il:|of| (il:|fetch| first-line il:|of| node) il:|with| 0) (il:* il:|;;| "not sure if the format values will be taken care of elsewhere, so do it here just to be sure.") (compute-all-formats context))) (when (eq (il:|fetch| start-x il:|of| node) 0) (il:shouldnt "the linearize root method should take care of this") (il:|replace| start-x il:|of| node il:|with| (il:|fetch| start-x il:|of| super-node)) (il:|replace| first-line il:|of| node il:|with| (il:|fetch| first-line il:|of| super-node)) (il:|replace| right-margin il:|of| node il:|with| (il:|fetch| (il:region il:width) il:|of| display-window-region))) (il:|replace| current-x il:|of| context il:|with| (il:|fetch| start-x il:|of| node)) (il:|replace| current-node il:|of| context il:|with| super-node) (il:|replace| current-line il:|of| context il:|with| (first-line-linear node context)) (il:|replace| linear-pointer il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-prev il:|of| context il:|with| nil) (generate-linear-form node context (if from-top (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:|fetch| right-margin il:|of| node))) (il:* il:|;;| "if this isn't the top of the tree, and reformatting this node caused the width of its last line to change, the formatting of its supernode might change, so we'll have to relinearize it. and so on...") (il:|while| (and super-node (il:|fetch| super-node il:|of| super-node) (il:neq (il:|fetch| current-x il:|of| context) (il:iplus (il:|fetch| start-x il:|of| node) old-actualllength))) il:|do| (il:setq old-actualllength (il:|fetch| actual-llength il:|of| super-node)) (il:setq old-last-line (il:|fetch| last-line il:|of| super-node)) (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|fetch| linear-prev il:|of| context))) (il:|replace| last-linearized-sub-node-index il:|of| context il:|with| (il:|fetch| sub-node-index il:|of| node)) (il:* il:|;;| "compute the maximum width of the lines in the linear form of the super up to the end of the node we just linearized (so we can recompute the super's width)") (il:|replace| actual-width il:|of| super-node il:|with| (il:|bind| (width il:_ 0) il:|for| (line il:_ (il:|fetch| first-line il:|of| super-node)) il:|by| (car (il:|fetch| next-line il:|of| line)) il:|while| (il:neq line (car (il:|fetch| current-line il:|of| context))) il:|do| (when (il:igreaterp (il:|fetch| line-length il:|of| line) width) (il:setq width (il:|fetch| line-length il:|of| line))) il:|finally| (return width))) (il:|replace| actual-llength il:|of| super-node il:|with| nil) (funcall (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| super-node)) super-node context (il:|fetch| sub-node-index il:|of| node)) (when (not (and (il:|type?| weak-link (il:|fetch| linear-pointer il:|of| context)) (eq (il:fetch destination il:of (il:|fetch| linear-pointer il:|of| context)) super-node))) (set-linear context (cdr (last (il:fetch linear-form il:of super-node))))) (il:* il:|;;| "this used to be:") (il:* il:|;;| "(il:|replace| last-line-linear il:|of| super-node il:|with| (il:fetch current-line il:of context))") (il:|replace| last-line il:|of| super-node il:|with| (car (il:|fetch| current-line il:|of| context))) (il:|replace| actual-width il:|of| super-node il:|with| (il:idifference (il:imax (il:|fetch| actual-width il:|of| super-node) (il:|fetch| current-x il:|of| context)) (il:|fetch| start-x il:|of| super-node))) (il:|replace| actual-llength il:|of| super-node il:|with| (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| start-x il:|of| super-node))) (il:|replace| changed? il:|of| super-node il:|with| nil) (il:setq node super-node) (il:setq super-node (il:|fetch| super-node il:|of| super-node)) (il:|replace| current-node il:|of| context il:|with| super-node)) (il:|replace| line-length il:|of| (il:|fetch| last-line il:|of| node) il:|with| (il:|fetch| current-x il:|of| context)) (cond ((or (null super-node) (null (il:|fetch| super-node il:|of| super-node))) (il:* il:|;;| "need to fix up node and supernode pointers, because came through root path") (when (null super-node) (il:setq super-node node) (il:setq node (subnode 1 node))) (il:* il:|;;| "we've relinearized to the end of the structure, so all we need to do is make sure the last line is flushed, blank the rest of the window, and fix up some recorded dimensions") (il:|replace| actual-llength il:|of| super-node il:|with| (il:|fetch| actual-llength il:|of| node)) (il:|replace| next-line il:|of| (il:|fetch| last-line il:|of| node) il:|with| nil) (il:selectq (il:|fetch| below? il:|of| context) (t) (nil (line-finished context (il:|fetch| current-x il:|of| context) nil t)) (new (repaint-new-line (last-line-linear node context))) (il:shouldnt "unexpected value for Below?")) (let* ((bottom-y (il:add1 (il:|fetch| next-line-y il:|of| (il:|fetch| last-line il:|of| node)))) (extent (il:windowprop (il:|fetch| display-window il:|of| context) (quote il:extent))) (old-bottom-y (il:idifference (il:|fetch| (il:region il:bottom) il:|of| extent) (or (il:|fetch| shift-down il:|of| context) 0)))) (when (and (il:neq (il:|fetch| below? il:|of| context) t) (il:igreaterp bottom-y old-bottom-y)) (il:bltshade il:whiteshade (il:|fetch| display-window il:|of| context) (il:|fetch| (il:region il:left) il:|of| display-window-region) old-bottom-y (il:|fetch| (il:region il:width) il:|of| display-window-region) (il:idifference bottom-y old-bottom-y))) (il:|replace| (il:region il:bottom) il:|of| extent il:|with| bottom-y) (il:|replace| (il:region il:height) il:|of| extent il:|with| (il:idifference 1 bottom-y)))) (t (il:* il:|;;| "we've finished relinearizing, but there was stuff after this. patch the pieces together and fix up all sorts of things") (il:|add| (il:|fetch| line-length il:|of| (il:|fetch| last-line il:|of| node)) (scan-for-bounds (cdr (il:|fetch| linear-thread il:|of| node)) nil (last-line-linear node context))) (il:setq following-line (car (il:|fetch| next-line il:|of| (il:|fetch| last-line il:|of| node)))) (when (not (il:|fetch| below? il:|of| context)) (new-block context) (let ((block (il:|fetch| current-block il:|of| context))) (il:|replace| block-start il:|of| block il:|with| (cdr (il:|fetch| linear-thread il:|of| node))) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| current-x il:|of| context)) (il:|replace| block-x il:|of| block il:|with| (il:|fetch| current-x il:|of| context)) (il:|replace| bits? il:|of| block il:|with| t) (cond ((eq (il:|fetch| cache-time il:|of| old-last-line) (il:|fetch| relinearization-time-stamp il:|of| context)) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| cached-y il:|of| old-last-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| cached-ascent il:|of| old-last-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| cached-descent il:|of| old-last-line))) (t (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| old-last-line)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| old-last-line)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| old-last-line)))) (il:setq y-1 (il:idifference (il:|fetch| block-base-line il:|of| block) (il:iplus (il:|fetch| block-descent il:|of| block) 1))) (il:setq y-2 (il:|fetch| next-line-y il:|of| (car (il:|fetch| current-line il:|of| context))))) (line-finished context (il:|fetch| line-length il:|of| (il:|fetch| last-line il:|of| node)) (il:|fetch| next-line il:|of| (il:|fetch| last-line il:|of| node)) t) (il:setq y-1 (il:idifference y-1 (il:|fetch| shift-down il:|of| context)))) (clean-up-after-relinearization context node following-line y-1 y-2))) (il:* il:\; "changing this node may have changed the width of some of its super nodes") (propagate-width-change context node old-actual-width))) ) (repaint (il:lambda (context x y linear-start end) (il:* il:\; "Edited 11-Apr-88 15:52 by woz") (il:* il:|;;| "display the sequence of linear form from linear.start to end, starting at x,y. end is either an integer, indicating the lowest y to which repainting should be done, or a linear form pointer") (il:|bind| (dsp il:_ (il:|fetch| display-window il:|of| context)) item temp min-y current-font il:|first| (il:moveto x y dsp) (cond ((il:fixp end) (il:setq min-y end) (il:setq end nil)) (t (il:setq min-y (il:|fetch| window-bottom il:|of| context)))) il:|while| (il:neq linear-start end) il:|do| (cond ((not (il:listp linear-start)) (il:* il:\; "finished this node, follow its thread to super") (il:setq linear-start (cdr (il:|fetch| linear-thread il:|of| (il:|fetch| destination il:|of| linear-start))))) ((il:|type?| weak-link (il:setq item (car linear-start))) (il:* il:\; "insert the linear form of a subnode") (il:setq linear-start (il:|fetch| linear-form il:|of| (il:|fetch| destination il:|of| item)))) (t (il:* il:\; "display something") (cond ((il:|type?| line-start item) (il:* il:\; "new line. if it takes us off the bottom of the region to be repainted, we can quit") (when (il:ileq (il:iplus (il:setq y (il:|fetch| base-line-y il:|of| item)) (il:|fetch| line-ascent il:|of| item)) min-y) (il:* il:\; "we've repainted enough") (return)) (il:moveto (il:|fetch| indent il:|of| item) y dsp)) ((il:fixp item) (il:relmoveto item 0 dsp)) ((il:|type?| string-item item) (when (il:neq current-font (il:|fetch| font il:|of| item)) (when (null (il:|fetch| font il:|of| item)) (il:shouldnt "this StringItem has no font")) (il:dspfont (il:|fetch| font il:|of| item) dsp) (il:setq current-font (il:|fetch| font il:|of| item))) (cond ((il:stringp (il:setq temp (il:|fetch| string il:|of| item))) (il:* il:\; "read table specific") (print-string temp dsp (il:|fetch| prin-2? il:|of| item))) ((il:|fetch| prin-2? il:|of| item) (il:* il:\; "read table specific") (il:prin2 temp dsp)) (t (il:prin1 temp dsp)))) ((il:listp item) (il:bitblt (cdr item) nil nil dsp (il:dspxposition nil dsp) (il:idifference y (car item))) (il:relmoveto (il:bitmapwidth (cdr item)) 0 dsp)) (t (il:shouldnt "unknown linear form item"))) (il:setq linear-start (cdr linear-start)))))) ) (reuse-linear-form (il:lambda (node context) (il:* il:\; "Edited 8-Apr-88 12:06 by woz") (il:* il:|;;;| "we've been asked to generate the linear form of node, and have decided that the old one will do. make any necessary adjustments and make sure that it's displayed properly") (let ((current-x (il:|fetch| current-x il:|of| context)) (current-line (il:|fetch| current-line il:|of| context)) delta-x temp) (cond ((il:neq (il:|fetch| start-x il:|of| node) 0) (il:* il:\; "adjust the StartX values for this node and all its subnodes") (when (il:neq (il:setq delta-x (il:idifference (il:|fetch| current-x il:|of| context) (il:|fetch| start-x il:|of| node))) 0) (shift-linear-form node delta-x))) (t (il:* il:\; "this must be a prelinearized atom") (il:|replace| start-x il:|of| node il:|with| current-x))) (cond ((or (null (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node))) (il:|fetch| inline? il:|of| node)) (il:|replace| first-line il:|of| node il:|with| (car current-line)) (when (and (il:|fetch| matching? il:|of| context) (il:|fetch| changed? il:|of| node) (not (il:|fetch| linearize il:|of| (il:|fetch| node-type il:|of| node)))) (new-block context) (il:|replace| matching? il:|of| context il:|with| nil)) (il:setq current-x (il:iplus current-x (scan-for-bounds (il:|fetch| linear-form il:|of| node) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line nil)))) (t (il:* il:\; "the linear form spans several lines") (il:setq current-x (il:iplus current-x (scan-for-bounds (il:|fetch| linear-form il:|of| node) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line nil))) (il:|replace| first-line il:|of| node il:|with| (car current-line)) (il:setq temp (il:|fetch| next-line il:|of| (car current-line))) (il:|replace| prev-line il:|of| (car temp) il:|with| current-line) (il:|replace| line-length il:|of| (car current-line) il:|with| current-x) (il:|add| (il:|fetch| indent il:|of| (car temp)) delta-x) (il:* il:|;;| "for each line in the linear form, adjust its y coordinate and indentation and the flush it (except the last)") (il:|bind| (block il:_ (il:|fetch| first-block il:|of| context)) (delta-y il:_ (il:idifference (il:|fetch| next-line-y il:|of| (car current-line)) (il:|fetch| ycoord il:|of| (car temp)))) (below? il:_ (il:|fetch| below? il:|of| context)) il:|first| (when (not below?) (line-finished context current-x temp) (il:setq below? (il:|fetch| below? il:|of| context)) (il:|replace| current-block il:|of| context il:|with| block)) il:|do| (cond (below? (when (eq below? (quote new)) (il:|replace| linear-pointer il:|of| context il:|with| temp) (repaint-new-line (il:|fetch| prev-line il:|of| (car temp)))) (il:setq temp (car temp))) (t (il:|replace| block-start il:|of| block il:|with| (cdr temp)) (il:|replace| current-line il:|of| context il:|with| temp) (il:|replace| shift-y il:|of| context il:|with| nil) (il:setq temp (car temp)) (il:|replace| block-x il:|of| block il:|with| (il:idifference (il:|fetch| indent il:|of| temp) delta-x)) (il:|replace| block-new-x il:|of| block il:|with| (il:|fetch| indent il:|of| temp)) (il:|replace| block-ascent il:|of| block il:|with| (il:|fetch| line-ascent il:|of| temp)) (il:|replace| block-descent il:|of| block il:|with| (il:|fetch| line-descent il:|of| temp)) (il:|replace| block-base-line il:|of| block il:|with| (il:|fetch| base-line-y il:|of| temp)) (il:|replace| bits? il:|of| block il:|with| t))) (il:|replace| ycoord il:|of| temp il:|with| (il:iplus (il:|fetch| ycoord il:|of| temp) delta-y)) (when (eq temp (il:|fetch| last-line il:|of| node)) (when (not below?) (il:|replace| cached-y il:|of| temp il:|with| (il:idifference (il:|fetch| base-line-y il:|of| temp) delta-y)) (il:|replace| cached-ascent il:|of| temp il:|with| (il:|fetch| line-ascent il:|of| temp)) (il:|replace| cached-descent il:|of| temp il:|with| (il:|fetch| line-descent il:|of| temp)) (il:|replace| cache-time il:|of| temp il:|with| (il:|fetch| relinearization-time-stamp il:|of| context))) (return)) (il:|replace| line-length il:|of| temp il:|with| (il:setq current-x (il:iplus (il:|fetch| line-length il:|of| temp) delta-x))) (il:setq temp (il:|fetch| next-line il:|of| temp)) (il:|add| (il:|fetch| indent il:|of| (car temp)) delta-x) (when (not below?) (line-finished context current-x temp) (il:setq below? (il:|fetch| below? il:|of| context)))) (il:* il:\; "used to be replace CurrentLine of context with (SETQ current.line (fetch LastLineLinear of node))") (il:|replace| current-line il:|of| context il:|with| (il:setq current-line (last-line-linear node context))) (il:setq current-x (il:iplus (il:|fetch| indent il:|of| temp) (scan-for-bounds (cdr current-line) (cdr (last (il:|fetch| linear-form il:|of| node))) current-line t))))) (when (il:neq current-x (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| actual-llength il:|of| node))) (il:shouldnt "old ActualLLength value doesn't match")) (il:|replace| current-x il:|of| context il:|with| current-x) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-thread il:|of| node)))))) ) (shift-block (il:lambda (context x y width start end ascent descent new-x old-y) (il:* il:\; "Edited 17-Nov-87 11:45 by DCB") (il:* il:|;;;| "we've found a block of bits in the window which can be reused. bitblt them to the appropriate place") (let* ((current-line (car (il:fetch current-line il:of context))) (current-line-bottom (il:add1 (il:fetch next-line-y il:of current-line))) (delta (il:idifference (il:idifference y descent) current-line-bottom)) (repaint-start (il:fetch repaint-start il:of context)) h w) (when (and (il:igreaterp delta 0) (il:igreaterp (il:setq h (il:idifference current-line-bottom (il:fetch window-bottom il:of context))) 0)) (il:* il:|;;| "we're shifting stuff down, so move the bits below them out of the way (down) first") (il:bitblt (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:iplus (il:fetch window-bottom il:of context) delta) (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:fetch window-bottom il:of context) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) h) (il:replace shift-down il:of context il:with (il:iplus (il:fetch shift-down il:of context) delta))) (when (or (il:neq y (il:fetch base-line-y il:of current-line)) (il:neq x new-x)) (il:* il:|;;| "the bits aren't already in the right place, so move them") (cond ((il:igreaterp (il:iplus y ascent) current-line-bottom) (il:* il:|;;| "we'll take along the rest of the line while we're at it (rather than lose those bits)") (cond ((eq old-y (il:fetch shift-y il:of context)) (il:replace shift-right il:of context il:with (il:iplus (il:fetch shift-right il:of context) (il:idifference new-x x)))) (t (il:replace shift-right il:of context il:with (il:idifference new-x x)) (il:replace shift-y il:of context il:with old-y))) (il:setq w (il:add1 (il:idifference (il:fetch window-right il:of context) new-x)))) (t (il:setq w width))) (il:setq descent (il:imin descent (il:fetch line-descent il:of current-line))) (il:setq ascent (il:imin ascent (il:fetch line-ascent il:of current-line))) (il:bitblt (il:fetch display-window il:of context) x (il:idifference y descent) (il:fetch display-window il:of context) new-x (il:idifference (il:fetch base-line-y il:of current-line) descent) w (il:iplus ascent descent))) (when (il:ileq (il:setq ascent (il:iplus (il:fetch base-line-y il:of current-line) ascent)) (il:fetch ycoord il:of current-line)) (il:* il:|;;| "it wasn't as tall as the line it's moved to, so blank above it") (il:bltshade il:whiteshade (il:fetch display-window il:of context) new-x ascent width (il:add1 (il:idifference (il:fetch ycoord il:of current-line) ascent)))) (when (il:ilessp descent (il:fetch line-descent il:of current-line)) (il:* il:|;;| "it descend as mush as the line it's moved to, so blank below it") (il:bltshade il:whiteshade (il:fetch display-window il:of context) new-x (il:add1 (il:fetch next-line-y il:of current-line)) width (il:idifference (il:fetch line-descent il:of current-line) descent))) (when (il:type? line-start (car repaint-start)) (il:setq repaint-start (cdr repaint-start))) (cond ((eq repaint-start start) (il:* il:|;;| "nothing to be painted, just blank where necessary") (when (and (or (il:neq y (il:fetch base-line-y il:of current-line)) (il:neq x new-x)) (eq new-x (il:fetch indent il:of current-line))) (il:* il:|;;| "this is the start of the line, so blank to the left margin") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x (il:fetch window-left il:of context)) (il:fetch line-height il:of current-line)))) (t (il:* il:|;;| "there is extra material to paint in front of the bits we've moved") (cond ((il:neq (il:fetch repaint-line il:of context) current-line) (il:* il:|;;| "there are several lines of stuff to paint. blank the area it's going to first") (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch ycoord il:of current-line)) (il:add1 (il:idifference (il:fetch window-right il:of context) (il:fetch window-left il:of context))) (il:idifference (il:fetch ycoord il:of (il:fetch repaint-line il:of context)) (il:fetch ycoord il:of current-line))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) (il:fetch window-left il:of context) (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x (il:fetch window-left il:of context)) (il:fetch line-height il:of current-line)) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) repaint-start start)) (t (il:* il:|;;| "the stuff to be repainted is all on this line") (when (eq (il:setq x (il:fetch repaint-x il:of context)) (il:fetch indent il:of (il:fetch repaint-line il:of context))) (il:* il:|;;| "this is the beginning of the line, so blank to the left margin") (il:setq x (il:fetch window-left il:of context))) (il:bltshade il:whiteshade (il:fetch display-window il:of context) x (il:add1 (il:fetch next-line-y il:of current-line)) (il:idifference new-x x) (il:fetch line-height il:of current-line)) (repaint context (il:fetch repaint-x il:of context) (il:fetch base-line-y il:of (il:fetch repaint-line il:of context)) repaint-start start))))) (il:replace repaint-start il:of context il:with end) (il:replace repaint-line il:of context il:with current-line) (il:replace repaint-x il:of context il:with (il:iplus new-x width)))) ) (try-reusing-bits (il:lambda (context block) (il:* il:\; "Edited 17-Nov-87 11:47 by DCB") (il:* il:|;;;| "decide whether the bits described by this block are actually available. if so, use shift.block to move them to the appropriate position. return T if we were successful") (prog ((shifted-x (il:fetch block-x il:of block)) (left-clip (il:fetch window-left il:of context)) (start (il:fetch block-start il:of block)) (end (il:fetch block-start il:of (il:fetch next-block il:of block))) (ascent (il:fetch block-ascent il:of block)) (descent (il:fetch block-descent il:of block)) (width (il:fetch block-width il:of block)) (new-x (il:fetch block-new-x il:of block)) shifted-y) (when (eq width 0) (il:* il:|;;| "no point in it if there are no bits") (go no-good)) (il:* il:|;;| "make sure they haven't been overwritten already, or shifted off the window") (cond ((il:fetch shift-y il:of context) (cond ((eq (il:fetch block-base-line il:of block) (il:fetch shift-y il:of context)) (il:setq shifted-y (il:fetch base-line-y il:of (car (il:fetch current-line il:of context)))) (il:setq shifted-x (il:iplus shifted-x (il:fetch shift-right il:of context))) (il:setq left-clip (il:fetch repaint-x il:of context))) (t (il:setq shifted-y (il:idifference (il:fetch block-base-line il:of block) (il:fetch shift-down il:of context))) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch next-line-y il:of (car (il:fetch current-line il:of context)))) (go no-good))))) (t (il:setq shifted-y (il:idifference (il:fetch block-base-line il:of block) (il:fetch shift-down il:of context))) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch ycoord il:of (il:fetch repaint-line il:of context))) (go no-good)) (when (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch next-line-y il:of (il:fetch repaint-line il:of context))) (il:setq left-clip (il:fetch repaint-x il:of context))))) (when (or (il:igreaterp shifted-x (il:fetch window-right il:of context)) (il:ileq (il:iplus shifted-y ascent) (il:fetch window-bottom il:of context))) (il:* il:\; "none of it's within the window") (go no-good)) (when (or (and (il:igreaterp (il:sub1 (il:iplus shifted-y ascent)) (il:fetch window-top il:of context)) (il:ilessp (il:fetch base-line-y il:of (car (il:fetch current-line il:of context))) shifted-y)) (and (il:ilessp (il:idifference shifted-y descent) (il:fetch window-bottom il:of context)) (il:igreaterp (il:fetch base-line-y il:of (car (il:fetch current-line il:of context))) shifted-y))) (il:* il:|;;| "some of it's within the window, but too much is clipped by the top or bottom edge of the window") (go no-good)) (when (il:igeq left-clip (il:iplus shifted-x width)) (go no-good)) (il:setq start (next-linear-item start)) (when (il:igreaterp (il:idifference left-clip shifted-x) (il:idifference (il:fetch window-right il:of context) new-x)) (il:* il:|;;| "this block was clipped on the left, so adjust its description (we'll have to repaint more)") (il:while (il:igreaterp left-clip shifted-x) il:bind w il:do (il:setq w (linear-item-width (car start))) (when (il:igeq w width) (il:* il:\; "there's nothing useable left") (go no-good)) (il:setq width (il:idifference width w)) (il:setq shifted-x (il:iplus shifted-x w)) (il:setq new-x (il:iplus new-x w)) (il:setq start (next-linear-item (cdr start))))) (when (and (il:igreaterp shifted-x new-x) (il:igreaterp (il:sub1 (il:iplus shifted-x width)) (il:fetch window-right il:of context))) (il:* il:|;;| "this block was clipped on the right, so adjust its description (we'll have to repaint more)") (il:setq end start) (il:setq width 0) (il:bind w il:until (il:igreaterp (il:sub1 (il:iplus shifted-x width (il:setq w (linear-item-width (car end))))) (il:fetch window-right il:of context)) il:do (il:setq width (il:iplus width w)) (il:setq end (next-linear-item (cdr end)))) (when (eq start end) (il:* il:|;;| "there's nothing useable left") (go no-good))) (il:* il:|;;| "there seem to be some useful bits here. put them in the right place") (shift-block context shifted-x shifted-y width start end ascent descent new-x (il:fetch block-base-line il:of block)) (return t) no-good)) ) ) (IL:PUTPROPS IL:SEDIT-LINEAR IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3402 73091 (CLEAN-UP-AFTER-RELINEARIZATION 3415 . 7248) (FIRST-LINE-LINEAR 7250 . 7855) (GENERATE-LINEAR-FORM 7857 . 12194) (LAST-LINE-LINEAR 12196 . 12844) (LINE-FINISHED 12846 . 15932) (LINEAR-ITEM-WIDTH 15934 . 16301) (LINEARIZE 16303 . 26852) (NEW-BLOCK 26854 . 27828) ( NEXT-LINEAR-ITEM 27830 . 29226) (OUTPUT-BITMAP 29228 . 30357) (OUTPUT-CONSTANT-STRING 30359 . 32394) ( OUTPUT-CR 32396 . 37036) (OUTPUT-SPACE 37038 . 38208) (OUTPUT-STRING 38210 . 40925) ( PAINT-TO-END-OF-LINE 40927 . 42622) (RECOMPUTE-FORMAT-VALUES 42624 . 43272) (RELINEARIZE 43274 . 55982 ) (REPAINT 55984 . 58248) (REUSE-LINEAR-FORM 58250 . 63366) (SHIFT-BLOCK 63368 . 68934) ( TRY-REUSING-BITS 68936 . 73089))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-LIST-FORMATS b/sources/SEDIT-LIST-FORMATS new file mode 100644 index 00000000..5557247b --- /dev/null +++ b/sources/SEDIT-LIST-FORMATS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "SEDIT" READTABLE "XCL" BASE 10) (IL:FILECREATED "17-May-90 11:08:07" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LIST-FORMATS.;2| 9591 IL:|changes| IL:|to:| (IL:FILES IL:SEDIT-INDENT) (IL:VARS IL:SEDIT-LIST-FORMATSCOMS) IL:|previous| IL:|date:| "18-Nov-88 10:56:22" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LIST-FORMATS.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-LIST-FORMATSCOMS) (IL:RPAQQ IL:SEDIT-LIST-FORMATSCOMS ((IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SEDIT-LIST-FORMATS) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-INDENT)) (IL:SEDIT-FORMATS RETURN-FROM THROW BLOCK (IL:* IL:|;;|  "some handy formats under names we don't expect to find as CAR of form") :DEFAULT :DATA :BINDING :BINDING-LIST :LAMBDA-LIST :FBINDING :FBINDING-LIST :COND-CLAUSE :CASE-CLAUSE :HORIZONTAL :HORIZONTAL-NOBREAK :VERTICAL :VERTICAL-NOBREAK :KEYWORD-ARGS :KEYWORD-ARGS-NOBREAK :SQUASHED :DEDIT) (IL:SEDIT-FORMATS (IL:* IL:|;;| "special forms & macros") AND CASE CATCH CCASE CERROR COMPILER-LET COND CTYPECASE DECLARE DEFCOMMAND DEFCONSTANT DEFDEFINER DEFUN DEFINE-SPECIAL-FORM DEFINLINE DEFGLOBALVAR DEFGLOBALPARAMETER DEF-LIST-FORMAT DEFMACRO DEFOPTIMIZER DEFPACKAGE DEFPARAMETER DEFSETF DEFSTRUCT DEFTYPE DEFVAR DESTRUCTURING-BIND DO DO* DOLIST DOTIMES DO-ALL-SYMBOLS DO-EXTERNAL-SYMBOLS DO-INTERNAL-SYMBOLS DO-LOCAL-SYMBOLS DO-SYMBOLS ECASE ERROR ETYPECASE EVAL-WHEN FLET FORMAT IF IGNORE-ERRORS LABELS LAMBDA IL:LAMBDA LET LET* LOCALLY LIST LIST* MACROLET MULTIPLE-VALUE-BIND MULTIPLE-VALUE-SETQ IL:NLAMBDA IL:OPENLAMBDA OR IL:P PROCEED-CASE PROG PROG* PROGN PROGV RESTART-CASE IL:SELCHARQ IL:SELECTQ TAGBODY THE TYPECASE UNDOABLY UNLESS UNWIND-PROTECT WHEN WITH-INPUT-FROM-STRING WITH-OUTPUT-TO-STRING WITH-OPEN-FILE WITH-OPEN-STREAM IL:WITH.MONITOR IL:WITH.FAST.MONITOR IL:WITH.SPY))) (IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:MAKEFILE-ENVIRONMENT NIL) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-INDENT) ) (DEF-LIST-FORMAT RETURN-FROM CATCH) (DEF-LIST-FORMAT THROW CATCH) (DEF-LIST-FORMAT BLOCK CATCH) (DEF-LIST-FORMAT :DEFAULT "Used for lists whose CAR has no specified format." :INDENT :HORIZONTAL-ATOM :INLINE T) (DEF-LIST-FORMAT :DATA "Used for quoted (not backquoted) lists." :INDENT :DATA :ARGS (:RECURSIVE) :INLINE T) (DEF-LIST-FORMAT :BINDING :INDENT :BINDING :INLINE T) (DEF-LIST-FORMAT :BINDING-LIST :INDENT :BINDING-LIST :ARGS (:BINDING) :INLINE NIL) (DEF-LIST-FORMAT :LAMBDA-LIST :INDENT :LAMBDA-LIST :ARGS (:BINDING) :INLINE T) (DEF-LIST-FORMAT :FBINDING :INDENT (:NOBREAK 1) :ARGS (NIL :LAMBDA-LIST NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT :FBINDING-LIST :INDENT :BINDING-LIST :ARGS (:FBINDING)) (DEF-LIST-FORMAT :COND-CLAUSE :INDENT :COND-CLAUSE :INLINE T) (DEF-LIST-FORMAT :CASE-CLAUSE :INDENT :COND-CLAUSE :ARGS (:DATA NIL) :SUBLISTS (1) :INLINE T) (DEF-LIST-FORMAT :HORIZONTAL :INDENT :HORIZONTAL :INLINE T) (DEF-LIST-FORMAT :HORIZONTAL-NOBREAK :INDENT :HORIZONTAL :INLINE T :MISER :NEVER) (DEF-LIST-FORMAT :VERTICAL :INDENT :VERTICAL :INLINE T) (DEF-LIST-FORMAT :VERTICAL-NOBREAK :INDENT :VERTICAL :INLINE T :MISER :NEVER) (DEF-LIST-FORMAT :KEYWORD-ARGS :INDENT :KEYWORD-ARG :INLINE T) (DEF-LIST-FORMAT :KEYWORD-ARGS-NOBREAK :INDENT :KEYWORD-ARG :INLINE T :MISER :NEVER) (DEF-LIST-FORMAT :SQUASHED :INDENT :SQUASH :INLINE T) (DEF-LIST-FORMAT :DEDIT :SQUASHED) (DEF-LIST-FORMAT AND :INDENT :VERTICAL :MISER :NEVER :INLINE T) (DEF-LIST-FORMAT CASE :INDENT (1) :ARGS (NIL NIL :CASE-CLAUSE) :SUBLISTS T) (DEF-LIST-FORMAT CATCH :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T) (DEF-LIST-FORMAT CCASE CASE) (DEF-LIST-FORMAT CERROR FORMAT) (DEF-LIST-FORMAT COMPILER-LET LET) (DEF-LIST-FORMAT COND :INDENT :VERTICAL :ARGS (NIL :COND-CLAUSE) :SUBLISTS T) (DEF-LIST-FORMAT CTYPECASE TYPECASE) (DEF-LIST-FORMAT DECLARE :INDENT :VERTICAL :ARGS (:KEYWORD :HORIZONTAL) :SUBLISTS T) (DEF-LIST-FORMAT DEFCOMMAND DEFUN) (DEF-LIST-FORMAT DEFCONSTANT DEFVAR) (DEF-LIST-FORMAT DEFDEFINER :INDENT ((2) 1) :ARGS (:KEYWORD :CASE-CLAUSE NIL :LAMBDA-LIST NIL)) (DEF-LIST-FORMAT DEFUN :INDENT ((2)) :ARGS (:KEYWORD NIL :LAMBDA-LIST NIL) :SUBLISTS (3)) (DEF-LIST-FORMAT DEFINE-SPECIAL-FORM DEFUN) (DEF-LIST-FORMAT DEFINLINE DEFUN) (DEF-LIST-FORMAT DEFGLOBALVAR DEFVAR) (DEF-LIST-FORMAT DEFGLOBALPARAMETER DEFVAR) (DEF-LIST-FORMAT DEF-LIST-FORMAT :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T) (DEF-LIST-FORMAT DEFMACRO DEFUN) (DEF-LIST-FORMAT DEFOPTIMIZER (IL:* IL:|;;;| "note: this loses in the case where OPT-NAME is specified in DEFOPTIMIZER form because we can't handle optional arguments at this level. we could go through the pain of writing a custom indent spec...") DEFUN) (DEF-LIST-FORMAT DEFPACKAGE :INDENT (1) :ARGS (:KEYWORD NIL :CASE-CLAUSE) :INLINE NIL) (DEF-LIST-FORMAT DEFPARAMETER DEFVAR) (DEF-LIST-FORMAT DEFSETF :INDENT ((3)) :ARGS (:KEYWORD NIL :LAMBDA-LIST :BINDING NIL) :SUBLISTS (3 4)) (DEF-LIST-FORMAT DEFSTRUCT :INDENT (1) :ARGS (:KEYWORD NIL)) (DEF-LIST-FORMAT DEFTYPE DEFMACRO) (DEF-LIST-FORMAT DEFVAR :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T) (DEF-LIST-FORMAT DESTRUCTURING-BIND :INDENT (1 1) :ARGS (:KEYWORD :LAMBDA-LIST NIL) :INLINE NIL) (DEF-LIST-FORMAT DO :INDENT (:TAGBODY 2) :ARGS (:KEYWORD :BINDING-LIST :COND-CLAUSE NIL) :SUBLISTS (2 3)) (DEF-LIST-FORMAT DO* DO) (DEF-LIST-FORMAT DOLIST :INDENT (:TAGBODY :STEP 1) :ARGS (:KEYWORD :BINDING NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT DOTIMES DOLIST) (DEF-LIST-FORMAT DO-ALL-SYMBOLS DOLIST) (DEF-LIST-FORMAT DO-EXTERNAL-SYMBOLS DOLIST) (DEF-LIST-FORMAT DO-INTERNAL-SYMBOLS DOLIST) (DEF-LIST-FORMAT DO-LOCAL-SYMBOLS DOLIST) (DEF-LIST-FORMAT DO-SYMBOLS DOLIST) (DEF-LIST-FORMAT ECASE CASE) (DEF-LIST-FORMAT ERROR FORMAT) (DEF-LIST-FORMAT ETYPECASE TYPECASE) (DEF-LIST-FORMAT EVAL-WHEN :INDENT (1) :SUBLISTS (2)) (DEF-LIST-FORMAT FLET :INDENT (1) :ARGS (:KEYWORD :FBINDING-LIST NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT FORMAT :INDENT :HORIZONTAL :INLINE T) (DEF-LIST-FORMAT IF :INDENT (2) :INLINE T) (DEF-LIST-FORMAT IGNORE-ERRORS UNDOABLY) (DEF-LIST-FORMAT LABELS FLET) (DEF-LIST-FORMAT LAMBDA :INDENT (1) :ARGS (:KEYWORD :LAMBDA-LIST NIL) :INLINE T :SUBLISTS (2)) (DEF-LIST-FORMAT IL:LAMBDA LAMBDA) (DEF-LIST-FORMAT LET :INDENT (1) :ARGS (:KEYWORD :BINDING-LIST NIL) :SUBLISTS (2) :MISER :NEVER) (DEF-LIST-FORMAT LET* LET) (DEF-LIST-FORMAT LOCALLY :INDENT (0) :ARGS (:KEYWORD NIL) :SUBLISTS T) (DEF-LIST-FORMAT LIST :INDENT :HORIZONTAL :INLINE T) (DEF-LIST-FORMAT LIST* LIST) (DEF-LIST-FORMAT MACROLET FLET) (DEF-LIST-FORMAT MULTIPLE-VALUE-BIND :INDENT (1 1) :ARGS (:KEYWORD :DATA NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT MULTIPLE-VALUE-SETQ :INDENT (1) :ARGS (NIL :DATA NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT IL:NLAMBDA LAMBDA) (DEF-LIST-FORMAT IL:OPENLAMBDA LAMBDA) (DEF-LIST-FORMAT OR AND) (DEF-LIST-FORMAT IL:P PROGN) (DEF-LIST-FORMAT PROCEED-CASE :INDENT (1) :ARGS (NIL :FBINDING)) (DEF-LIST-FORMAT PROG :INDENT (:TAGBODY :STEP 1) :ARGS (:KEYWORD :BINDING-LIST NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT PROG* PROG) (DEF-LIST-FORMAT PROGN :INDENT :VERTICAL :INLINE NIL) (DEF-LIST-FORMAT PROGV :INDENT (1 1) :ARGS (:KEYWORD :DATA NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT RESTART-CASE :INDENT (1) :ARGS (NIL :FBINDING)) (DEF-LIST-FORMAT IL:SELCHARQ IL:SELECTQ) (DEF-LIST-FORMAT IL:SELECTQ :INDENT (1) :ARGS (:KEYWORD NIL :CASE-CLAUSE) :LAST NIL) (DEF-LIST-FORMAT TAGBODY :INDENT (:TAGBODY :STEP 0) :ARGS (:KEYWORD NIL)) (DEF-LIST-FORMAT THE :INDENT (1) :ARGS (:KEYWORD NIL) :INLINE T) (DEF-LIST-FORMAT TYPECASE CASE) (DEF-LIST-FORMAT UNDOABLY :INDENT :VERTICAL :INLINE NIL :ARGS (:KEYWORD NIL)) (DEF-LIST-FORMAT UNLESS :INDENT (1)) (DEF-LIST-FORMAT UNWIND-PROTECT :INDENT (:BREAK 1)) (DEF-LIST-FORMAT WHEN UNLESS) (DEF-LIST-FORMAT WITH-INPUT-FROM-STRING WITH-OPEN-STREAM) (DEF-LIST-FORMAT WITH-OUTPUT-TO-STRING WITH-OPEN-STREAM) (DEF-LIST-FORMAT WITH-OPEN-FILE WITH-OPEN-STREAM) (DEF-LIST-FORMAT WITH-OPEN-STREAM :INDENT (1) :ARGS (NIL :KEYWORD-ARGS NIL) :SUBLISTS (2)) (DEF-LIST-FORMAT IL:WITH.MONITOR :INDENT (1)) (DEF-LIST-FORMAT IL:WITH.FAST.MONITOR IL:WITH.MONITOR) (DEF-LIST-FORMAT IL:WITH.SPY IL:WITH.MONITOR) (IL:PUTPROPS IL:SEDIT-LIST-FORMATS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-LISTS b/sources/SEDIT-LISTS new file mode 100644 index 00000000..83980836 --- /dev/null +++ b/sources/SEDIT-LISTS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:10:05" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LISTS.;2| 118946 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-LISTSCOMS) IL:|previous| IL:|date:| "14-Jun-88 21:42:26" IL:|{DSK}local>lde>lispcore>sources>SEDIT-LISTS.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-LISTSCOMS) (IL:RPAQQ IL:SEDIT-LISTSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-LISTS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-LISTS) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS) (IL:LOCALVARS . T)) (IL:VARIABLES *FORMAT-ALIAS-DEPTH-LIMIT* *WRAP-PARENS* INTERNAL-WRAPPERS) (IL:VARS (LIST-PARSE-INFO '(QUOTE PARSE--QUOTE IL:BQUOTE PARSE--QUOTE IL:\\\, PARSE--QUOTE IL:\\\,@ PARSE--QUOTE IL:\\\,. PARSE--QUOTE FUNCTION PARSE--QUOTE IL:* PARSE--COMMENT)) (CLISP-INDENT-WORDS '(IL:THEN IL:|then| IL:ELSE IL:|else| IL:OF IL:|of| IL:WITH IL:|with| IL:IN IL:|in| IL:INSTRING IL:|instring| IL:FROM IL:|from| IL:ON IL:|on| IL:TO IL:|to| IL:BY IL:|by| IL:OLD IL:|old| IL:INSIDE IL:|inside| IL:OUTOF IL:|outof|)) (CLISP-PROGRAM-WORDS '(IL:THEN IL:|then| IL:ELSE IL:|else| IL:DO IL:|do| IL:COLLECT IL:|collect| IL:JOIN IL:|join| IL:SUM IL:|sum| IL:COUNT IL:|count| IL:ALWAYS IL:|always| IL:NEVER IL:|never| IL:THEREIS IL:|thereis| IL:LARGEST IL:|largest| IL:SMALLEST IL:|smallest|))) (IL:FNS ASSIGN-FORMAT-CLISP ASSIGN-FORMAT-DOTLIST ASSIGN-FORMAT-LIST ASSIGN-FORMAT-QUOTE BACKSPACE-LIST BACKSPACE-QUOTE CFV-CLISP CFV-DOTLIST CFV-LIST CFV-QUOTE CLOSE-LIST COMPUTE-POINT-POSITION-LIST COPY-STRUCTURE-LIST COPY-STRUCTURE-QUOTE CREATE-NULL-LIST CREATE-QUOTED-GAP DELETE-LIST DELETE-QUOTE DOT-THIS-LIST GET-LIST-FORMAT INITIALIZE-LISTS INSERT-LIST INSERT-NULL-LIST INSERT-QUOTED-GAP LINEARIZE-CLISP LINEARIZE-DOTLIST LINEARIZE-LIST LINEARIZE-QUOTE NEXT-NODE-TYPE OUTPUT-CR-OR-SPACE PARENTHESIZE-CURRENT-SELECTION PARSE--LIST PARSE--LIST-INTERNAL PARSE--QUOTE REPLACE-LIST REPLACE-QUOTE SET-LIST-FORMAT SET-POINT-LIST SET-POINT-QUOTE SET-SELECTION-LIST SET-SELECTION-QUOTE STRINGIFY-LIST STRINGIFY-QUOTE SUBNODE-CHANGED-LIST SUBNODE-CHANGED-QUOTE UNDO-LIST-REPLACE UNDO-REPLACE-QUOTE))) (IL:PUTPROPS IL:SEDIT-LISTS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-LISTS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (DEFGLOBALVAR *FORMAT-ALIAS-DEPTH-LIMIT* 10) (DEFPARAMETER *WRAP-PARENS* NIL "Determines whether closing parens wrap to next line if they don't fit.") (DEFGLOBALVAR INTERNAL-WRAPPERS (IL:* IL:|;;;| "this list pretty-prints badly because of itself. see parse--list-internal.") '(IL:BQUOTE IL:\\\, . ,@IL:\\\,.)) (IL:RPAQQ LIST-PARSE-INFO (QUOTE PARSE--QUOTE IL:BQUOTE PARSE--QUOTE IL:\\\, PARSE--QUOTE IL:\\\,@ PARSE--QUOTE IL:\\\,. PARSE--QUOTE FUNCTION PARSE--QUOTE IL:* PARSE--COMMENT)) (IL:RPAQQ CLISP-INDENT-WORDS (IL:THEN IL:|then| IL:ELSE IL:|else| IL:OF IL:|of| IL:WITH IL:|with| IL:IN IL:|in| IL:INSTRING IL:|instring| IL:FROM IL:|from| IL:ON IL:|on| IL:TO IL:|to| IL:BY IL:|by| IL:OLD IL:|old| IL:INSIDE IL:|inside| IL:OUTOF IL:|outof|)) (IL:RPAQQ CLISP-PROGRAM-WORDS (IL:THEN IL:|then| IL:ELSE IL:|else| IL:DO IL:|do| IL:COLLECT IL:|collect| IL:JOIN IL:|join| IL:SUM IL:|sum| IL:COUNT IL:|count| IL:ALWAYS IL:|always| IL:NEVER IL:|never| IL:THEREIS IL:|thereis| IL:LARGEST IL:|largest| IL:SMALLEST IL:|smallest|)) (IL:DEFINEQ (assign-format-clisp (il:lambda (node context) (il:* il:\; "Edited 16-Jul-87 08:32 by DCB") (il:* il:|;;;| "in a clisp expression, the car is a clispword and determines the type of the clisp expression. for example, for would set the type to be FORWORD. in a clisp expression, each clisp word of the same type as the car should be set as a keyword, and all other subnodes should be set normally. (note that this way, \"if\" won't get set as a keyword if it appears as an atom directly in a for-loop list.) ") (il:* il:|;;;| "note that we must keep the clisp type in the Unassigned field of the clisp list's node, since the clisp linearize method depends on it.") (let* ((subnodes (cdr (il:fetch sub-nodes il:of node))) (clisp-type (car (il:getprop (il:fetch structure il:of (car subnodes)) 'il:clispword)))) (set-format (car subnodes) context :keyword) (il:for subnode il:in (cdr subnodes) il:do (set-format subnode context (if (eq clisp-type (car (il:listp (il:getprop (il:fetch structure il:of subnode) 'il:clispword)))) :keyword nil)))))) (assign-format-dotlist (il:lambda (node context) (il:* il:\; "Edited 7-Jul-87 12:51 by DCB") (il:* il:|;;;| "in a dotted list, all sublists should be set as data lists and other types should not be set specially.") (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (set-format subnode context (get-list-format :data))))) (assign-format-list (il:lambda (node context format) (il:* il:\; "Edited 1-Sep-87 18:41 by drc:") (il:* il:|;;;| "Determine this list's ListFormat, and propagate the appropriate formats to its subnodes") (when (not (il:type? list-format format)) (il:* il:|;;| "if we weren't given one, see if we recognize the CAR -- if not, use the default format") (let ((list-car (car (il:fetch structure il:of node)))) (il:setq format (if (not (il:litatom list-car)) (get-list-format :default) (or (get-list-format list-car) (and (il:listp (il:setq list-car (il:getprop list-car 'il:clispword))) (il:memb (car list-car) '(il:ifword il:forword il:recordtran )) (get-list-format :clisp)) (get-list-format :default)))))) (il:* il:|;;| "Stash the ListFormat for cfv.list and linearize.list") (il:replace unassigned il:of node il:with format) (il:* il:|;;| "Non-standard ListFormats provide their own SetFormat method -- use it.") (cond ((il:fetch non-standard? il:of format) (funcall (il:fetch set-format-list il:of format) node context)) (t (il:* il:|;;| "Otherwise, we do the work") (let* ((formats (il:fetch list-formats il:of format)) (last-format (car formats)) (subnodes (cdr (il:fetch sub-nodes il:of node))) (last-subnode subnodes)) (il:* il:|;;| "Find the last non-comment subnode") (il:for p il:on subnodes il:when (not (eq (il:fetch node-type il:of (car p)) type-comment)) il:do (il:setq last-subnode p)) (il:while subnodes il:do (let* ((subnode (car subnodes)) (subformat-name (and (il:neq (il:fetch node-type il:of subnode) type-comment) (if (and (eq subnodes last-subnode) (null (cddr formats))) last-format (car (il:setq formats (or (cdr formats) formats))))))) (set-format subnode context (case subformat-name ((nil :keyword) subformat-name) (:recursive format) (otherwise (get-list-format subformat-name)))) ) (il:setq subnodes (cdr subnodes)))))))) (assign-format-quote (il:lambda (node context format) (il:* il:\; "Edited 7-Jul-87 12:51 by DCB") (il:* il:|;;;| "assigns the format for a quoted subnode. Normal quotes assume the subnode is data, other types (e.g., backquote) assume the subnode is a form. ") (il:* il:|;;;| "We used to supercede any passed-in format and assign the subnode anyway, now we propagate a passed-in format down to the subnode.") (set-format (cadr (il:fetch sub-nodes il:of node)) context (cond ((il:type? list-format format) format) ((eq 'quote (car (il:fetch structure il:of node))) (get-list-format :data)) (t nil))))) (backspace-list (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 12:51 by DCB") (il:* il:\; "the BackSpace method for lists") (cond ((null index) (il:* il:\; "backspace from the right boundary of a list puts the caret inside the right paren") (let ((point (il:fetch caret-point il:of context))) (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (car (il:fetch sub-nodes il:of node))) (il:replace point-type il:of point il:with 'structure)) (set-selection-nowhere (il:fetch selection il:of context))) ((eq 0 index) (il:* il:|;;| "backspacing from before the first element deletes the list if it's empty") (when (null (cdr (il:fetch sub-nodes il:of node))) (delete-nodes (il:fetch super-node il:of node) context node nil (il:fetch caret-point il:of context)))) (t (il:* il:\; "backspacing after an element of the list is handled by that element") (il:setq node (subnode index node)) (funcall (il:fetch back-space il:of (il:fetch node-type il:of node)) node context))))) (backspace-quote (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 12:51 by DCB") (il:* il:|;;;| "the BackSpace method for quoted structure. index = NIL means backing up from right edge: let the subnode deal; index = T means backspace from quoted gap: either degrade.quote type or delete the quote. index = 0 means backspace from beginning of atom: either degrade of extract the quoted node.") (cond ((null index) (il:* il:\; "jump into quoted node") (il:setq node (subnode 1 node)) (funcall (il:fetch back-space il:of (il:fetch node-type il:of node)) node context)) ((il:fmemb (car (il:fetch structure il:of node)) (quote-wrapper '(comma-at comma-dot))) (il:* il:\; "degrade a big quote type") (change-quote node context 'il:comma)) ((eq index t) (il:* il:|;;| "this is tricky: there is a selection and i wan't to delete the quote node, which contains the selection. but the deletion may cause something else to be selected, so i must cancel my selection first. the delete method had better know what it's doing!") (set-selection-nowhere (il:fetch selection il:of context)) (delete-nodes node context nil nil (il:fetch caret-point il:of context))) ((eq index 0) (il:* il:\; "unquote the atom") (let ((atom-node (subnode 1 node))) (il:* il:|;;| "grap the node to be extracted, so can set the point later") (set-selection-me (il:fetch selection il:of context) context node) (extract-current-selection context) (set-selection-nowhere (il:fetch selection il:of context)) (set-point (il:fetch caret-point il:of context) context atom-node))) (t (il:shouldnt "this point shouldn't be inside a quote!"))))) (cfv-clisp (il:lambda (x environment) (il:* il:\; "Edited 16-Jul-87 08:31 by DCB") (il:* il:|;;;| "compute the width estimates for a clisp expression") (il:bind (pwidth il:_ 0) (iwidth il:_ 0) (first-subnode il:_ t) (paren-width il:_ (il:fetch width il:of (il:fetch lparen-string il:of environment))) (space-width il:_ (il:fetch space-width il:of environment)) indent il:first (il:setq indent paren-width) il:for subnode il:in (cdr (il:fetch sub-nodes il:of x)) il:do (when iwidth (if (il:fetch inline-width il:of subnode) (il:setq iwidth (il:iplus iwidth (if (eq 0 iwidth) paren-width space-width) (il:fetch inline-width il:of subnode))) (il:setq iwidth nil))) (when (and (not first-subnode) (eq (il:fetch format il:of subnode) :keyword)) (il:* il:|;;| "indentable keywords are indented by the base indentation, except for the first keyword of the expression. other keywords are only indented by the width of the left parenthesis") (cond ((il:memb (cdr (il:getprop (il:fetch structure il:of subnode) 'il:clispword)) clisp-indent-words) (il:setq indent (il:fetch indent-base il:of environment))) (t (il:setq indent paren-width) (il:setq iwidth nil)))) (il:setq pwidth (il:imax pwidth (il:iplus (il:fetch preferred-width il:of subnode) indent))) (when (eq (il:fetch format il:of subnode) :keyword) (il:* il:|;;| "the subnodes following a keyword are indented by the keyword's indentation plus its width plus a blank") (il:setq indent (il:iplus indent (il:fetch inline-width il:of subnode) space-width))) (il:setq first-subnode nil) il:finally (il:replace inline-width il:of x il:with (and iwidth (il:ilessp iwidth (il:fetch max-width il:of environment)) (il:iplus iwidth paren-width))) (il:replace preferred-width il:of x il:with pwidth)))) (cfv-dotlist (il:lambda (x environment) (il:* il:\; "Edited 7-Jul-87 12:52 by DCB") (il:* il:|;;;| "compute the width estimates for a dotted list") (let ((paren-width (il:fetch width il:of (il:fetch lparen-string il:of environment))) (space-width (il:charwidth (il:charcode il:space) (il:fetch default-font il:of environment))) (subnodes (cdr (il:fetch sub-nodes il:of x))) (number-of-subnodes (car (il:fetch sub-nodes il:of x)))) (cond ((eq 0 number-of-subnodes) (il:* il:|;;| "empty lists are boring") (il:setq paren-width (il:itimes paren-width 2)) (il:replace inline-width il:of x il:with paren-width) (il:replace preferred-width il:of x il:with paren-width)) (t (let ((width-of-dot (if (eq (il:fetch node-type il:of x) type-dotlist) (il:iplus (il:fetch width il:of (il:fetch dot-string il:of environment)) space-width) 0))) (il:* il:|;;| "a list can go inline if all of its subnodes can") (il:replace inline-width il:of x il:with (and (il:for subnode il:in subnodes il:always (il:atom (il:fetch structure il:of subnode))) (il:iplus paren-width width-of-dot (il:itimes (il:sub1 number-of-subnodes ) space-width) (il:for subnode il:in subnodes il:sum (il:fetch inline-width il:of subnode)) paren-width))) (il:* il:|;;| "forget the closing paren if it can't go inline, since the last line may be short") (il:replace preferred-width il:of x il:with (il:bind (max il:_ 0) il:for subnode il:in subnodes il:do (il:setq max (il:imax max (il:fetch preferred-width il:of subnode))) il:finally (return (il:iplus max paren-width)))))))))) (cfv-list (il:lambda (node environment) (il:* il:\; "Edited 31-Aug-87 16:06 by drc:") (il:* il:|;;;| "Compute the format values of a list, driven by its ListFormat.") (let ((info (il:fetch unassigned il:of node))) (cond ((il:fetch non-standard? il:of info) (il:* il:|;;| "Non-standard ListFormats specify their own CFV method") (funcall (il:fetch cfvlist il:of info) node environment)) (t(il:* il:|;;| "Otherwise we do the work") (let* ((space-width (il:fetch space-width il:of environment)) (two-parens (il:itimes (il:fetch width il:of (il:fetch lparen-string il:of environment )) 2)) (indent 0 (il:* il:\; "our estimate of the indentation, relative to the start of the list") ) (iwidth nil (il:* il:\; "InlineWidth so far") ) (pwidth 0 (il:* il:\; "PreferredWidth so far") ) last-info (il:first t) (prev-type nil (il:* il:\; "Atom, Comment, or NIL (other)") ) next-type (x 0 (il:* il:\; "our estimate of CurrentX") ) (subnodes (cdr (il:fetch sub-nodes il:of node))) (last-subnode subnodes (il:* il:\; "will point to the tail of subnodes beginning with the last non-comment subnode") )) (il:* il:|;;| "If this node has a chance of going inline, start iwidth with the width of the parens and spaces") (when (il:fetch list-inline? il:of info) (let ((number-subnodes (car (il:fetch sub-nodes il:of node)))) (il:setq iwidth (if (il:igreaterp number-subnodes 1) (il:iplus two-parens (il:itimes (il:sub1 number-subnodes) space-width)) two-parens)))) (il:setq last-info (car (il:setq info (il:fetch list-pformat il:of info)))) (il:* il:|;;| "Find the last non-comment subnode") (il:for p il:on subnodes il:when (not (eq (il:fetch node-type il:of (car p)) type-comment)) il:do (il:setq last-subnode p)) (il:while subnodes il:do (let ((subnode (car subnodes))) (cond ((eq (il:fetch node-type il:of subnode) type-comment) (il:* il:|;;| "Comments can never go inline. Their contribution to the preferred width is pretty approximate, but it works fine") (il:setq iwidth nil) (il:setq pwidth (il:imax pwidth (il:iplus indent (il:fetch preferred-width il:of subnode)))) (il:setq prev-type 'comment)) (t (il:setq next-type (next-node-type subnode)) (cond (il:first (il:setq il:first nil)) (t (il:* il:|;;| "We (rather conservatively) guess what the separation info will be") (let ((sepr-info (if (and (eq subnodes last-subnode) (null (cddr info))) last-info (car (il:setq info (or (cdr info) info))))) (break? (eq prev-type 'comment)) (set-indent? nil) (indent-base 0)) (il:while (il:listp sepr-info) il:do (il:setq sepr-info (il:selectq (car sepr-info) ((prev-inline? next-inline? next-preferred?) (cddr sepr-info)) (prev-atom? (if (il:fmemb prev-type '(atom keyword lambdaword)) (cadr sepr-info) (cddr sepr-info))) (prev-keyword? (if (eq prev-type 'keyword) (cadr sepr-info) (cddr sepr-info))) (prev-lambdaword? (if (eq prev-type 'lambdaword) (cadr sepr-info) (cddr sepr-info))) (next-atom? (if (il:fmemb next-type '(atom keyword lambdaword)) (cadr sepr-info) (cddr sepr-info))) (next-keyword? (if (eq next-type 'keyword) (cadr sepr-info) (cddr sepr-info))) (next-lambdaword? (if (eq next-type 'lambdaword) (cadr sepr-info) (cddr sepr-info))) (set-indent (il:setq set-indent? t) (cdr sepr-info)) (from-indent (il:setq indent-base indent) (cdr sepr-info)) (break (il:setq break? t) (cdr sepr-info)) (il:shouldnt "Bad List Format")))) (il:setq x (if break? (il:imin (il:iplus sepr-info indent-base) (il:iplus x space-width)) (il:iplus x space-width))) (when set-indent? (il:setq indent x))))) (il:* il:|;;| "Now that we think we know where this subnode will start, check its effect on the overall width") (il:setq pwidth (il:imax pwidth (il:iplus x (il:fetch preferred-width il:of subnode)))) (let ((sub-iwidth (il:fetch inline-width il:of subnode)) (sub-pwidth (il:fetch preferred-width il:of subnode))) (cond (sub-iwidth (il:setq x (il:iplus x sub-iwidth)) (when iwidth (il:setq iwidth (il:iplus iwidth sub-iwidth)) )) (t (il:setq iwidth nil)))) (il:setq prev-type next-type)))) (il:setq subnodes (cdr subnodes))) (il:replace inline-width il:of node il:with (and iwidth (il:ilessp iwidth (il:fetch max-width il:of environment )) iwidth)) (il:replace preferred-width il:of node il:with (il:iplus pwidth two-parens)))))))) (cfv-quote (il:lambda (x environment format) (il:* il:\; "Edited 7-Jul-87 12:53 by DCB") (il:* il:|;;;| "compute the width estimates for a quoted structure. very straightforward") (let ((quote-width (il:fetch width il:of (il:fetch unassigned il:of x))) (subnode (cadr (il:fetch sub-nodes il:of x)))) (il:replace inline-width il:of x il:with (and (il:fetch inline-width il:of subnode) (il:iplus quote-width (il:fetch inline-width il:of subnode)))) (il:replace preferred-width il:of x il:with (il:iplus quote-width (il:fetch preferred-width il:of subnode )))))) (close-list (il:lambda (context charcode) (il:* il:\; "Edited 22-Dec-87 09:03 by DCB") (il:* il:|;;;| "implements the close paren command (skips to the end of this list)") (let ((pnode)) (when (il:fmemb (type-of-input context) '(atom structure)) (close-open-node context) (il:bind node il:_ (il:fetch point-node il:of (il:fetch caret-point il:of context)) il:first (when (typep node 'edit-selection) (il:setq node (il:fetch select-node il:of node))) il:while (and node (not (il:memb (il:fetch name il:of (il:fetch node-type il:of node)) '(list dotlist clisp)))) il:do (il:* il:|;;| "climb up looking for the nearest enclosing list-type structure") (il:setq node (il:fetch super-node il:of node)) il:finally (cond (node (il:* il:|;;| "ask the list to put this point after itself") (set-point (il:fetch caret-point il:of context) context node nil t) (select-node context node)) (t (il:* il:|;;| "we're not in a list (pretty unusual) so there's no obvious place to put the point") (set-point-nowhere (il:fetch caret-point il:of context)) (format (get-prompt-window context) "~%No enclosing list.")))) (il:* il:|;;| "must return non-NIL if command executed") t)))) (compute-point-position-list (il:lambda (point) (il:* il:\; "Edited 17-Nov-87 11:29 by DCB") (il:* il:|;;;| "implement the ComputePointPosition method for a list, form, clisp, lambda, etc.") (let ((node (il:fetch point-node il:of point)) subnode item) (cond ((eq 0 (il:fetch point-index il:of point)) (il:* il:|;;| "before the first element -- right after the opening paren, which we assume is the first item in the linear form") (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of node) (il:fetch width il:of (car (il:fetch linear-form il:of node))))) (il:replace point-line il:of point il:with (il:fetch first-line il:of node))) (t (il:* il:|;;| "find the subnode it will follow") (il:setq subnode (subnode (il:fetch point-index il:of point) node)) (cond ((eq (il:fetch node-type il:of subnode) type-comment) (il:replace point-line il:of point il:with (car (il:fetch next-line il:of (il:fetch last-line il:of subnode) ))) (il:replace point-x il:of point il:with (il:imax (il:idifference (il:fetch indent il:of (il:fetch point-line il:of point) ) 6) (il:fetch start-x il:of node)))) (t (il:replace point-line il:of point il:with (il:fetch last-line il:of subnode)) (il:setq item (cadr (il:fetch linear-thread il:of subnode))) (il:replace point-x il:of point il:with (il:iplus (il:fetch start-x il:of subnode) (il:fetch actual-llength il:of subnode) (cond ((il:smallp item) (il:* il:|;;| "it's followed by space -- put the caret in the middle") (il:imin (il:half item) 6)) ((il:type? line-start item) (il:* il:|;;| "it's the last thing on the line -- put the caret a little ways after it") 6) (t (il:* il:|;;| "it's followed by something else -- presumably the close paren -- so put the caret immediately after it") 0))))))))))) (copy-structure-list (il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:29 by DCB") (il:* il:|;;| "the CopyStructure method for lists, forms, clisp expressions, etc.") (il:replace structure il:of node il:with (il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:collect (il:fetch structure il:of subnode))) (when (eq (il:fetch node-type il:of node) type-dotlist) (let ((tail (il:nth (il:fetch structure il:of node) (il:sub1 (car (il:fetch sub-nodes il:of node)))))) (rplacd tail (cadr tail)))))) (copy-structure-quote (il:lambda (node) (il:* il:\; "Edited 17-Nov-87 11:29 by DCB") (il:* il:|;;| "the CopyStructure method for quoted structures") (il:replace structure il:of node il:with (list (car (il:fetch structure il:of node)) (il:fetch structure il:of (subnode 1 node)))))) (create-null-list (il:lambda (context) (il:* il:\; "Edited 6-Apr-88 16:27 by woz") (il:* il:|;;;| "creates a new node describing an empty list") (let* ((width (il:itimes 2 (il:charwidth (il:charcode il:\() (il:|fetch| default-font il:|of| (il:|fetch| environment il:|of| context ))))) (node (il:|create| edit-node node-type il:_ type-list structure il:_ nil sub-nodes il:_ (list 0) inline-width il:_ width preferred-width il:_ width))) (il:|replace| linear-form il:|of| node il:|with| (create-weak-link node)) node))) (create-quoted-gap (il:lambda (gap context quote-type) (il:* il:\; "Edited 6-Apr-88 16:28 by woz") (il:* il:|;;;| "cons a quoted gap, and the node to represent it") (let* ((gap-node (create-gap-node gap)) (quote-node (il:|create| edit-node node-type il:_ type-quote structure il:_ (list (quote-wrapper quote-type) gap) sub-nodes il:_ (list 1 gap-node) unassigned il:_ (il:listget (il:|fetch| quote-string il:|of| (il:|fetch| environment il:|of| context)) quote-type)))) (il:|replace| super-node il:|of| gap-node il:|with| quote-node) (il:|replace| sub-node-index il:|of| gap-node il:|with| 1) (il:|replace| linear-form il:|of| quote-node il:|with| (create-weak-link quote-node)) (note-change quote-node context) quote-node))) (delete-list (il:lambda (node context start end set-point?) (il:* il:\; "Edited 17-Nov-87 11:29 by DCB") (il:* il:|;;| "the Delete method for lists and related animals") (when (il:type? edit-node start) (il:setq start (il:fetch sub-node-index il:of start))) (replace-list node context start (or end start) nil set-point?) t)) (delete-quote (il:lambda (node context start end set-point?) (il:* il:\; "Edited 7-Jul-87 12:53 by DCB") (il:* il:|;;;| "replace node to be delete with a gap. the backspace method will let a quoted gap be deleted.") (if (or (il:neq (or (il:smallp start) (il:fetch sub-node-index il:of start)) 1) (and end (il:neq end 1))) (il:shouldnt "bad index in delete.quote") (let ((subnode (subnode 1 node)) (gap-node (create-gap-node basic-gap))) (replace-node context subnode gap-node) (when set-point? (set-selection-me (il:fetch selection il:of context) context gap-node) (pending-delete set-point? (il:fetch selection il:of context))) t)))) (dot-this-list (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 12:53 by DCB") (il:* il:|;;;| "implements the dot command: make this a dotted list") (let* ((point (il:fetch caret-point il:of context)) (node (il:fetch point-node il:of point)) (index (il:fetch point-index il:of point)) (num-subnodes (car (il:fetch sub-nodes il:of node))) gap-node) (cond ((and (il:igreaterp index 0) (il:igeq index (il:sub1 num-subnodes))) (when (eq index num-subnodes) (il:* il:\; "at end of list. add dotted gap") (il:setq gap-node (create-gap-node basic-gap)) (insert point context gap-node) (select-segment (il:fetch selection il:of context) context node gap-node gap-node) (pending-delete point (il:fetch selection il:of context))) (il:* il:\; "just dot contents of this list") (let ((tail (il:nth (il:fetch structure il:of node) index))) (rplacd tail (cadr tail))) (il:replace node-type il:of node il:with type-dotlist) (note-change node context) (when (il:neq index num-subnodes) (il:* il:\; "if dotted existing list, set point before dot") (set-selection-nowhere (il:fetch selection il:of context)) (set-point point context node index t (subnode index node) 'structure t))) (t (il:* il:|;;| "waste selection to avoid pending delete inconsistency ") (set-selection-nowhere (il:fetch selection il:of context))))))) (get-list-format (il:lambda (fn) (il:* il:\; "Edited 1-Sep-87 18:45 by drc:") (il:* il:|;;| "return the internal list format for forms whose CAR is FN, or NIL. ") (il:* il:|;;| "we loop down aliases to *FORMAT-ALIAS-DEPTH-LIMIT*.") (do ((format (gethash fn list-formats-table) (gethash format list-formats-table)) (depth 0 (1+ depth))) ((= depth *format-alias-depth-limit*) (cerror "forget ~S's list format" "aliases for ~S too deep (possibly circular)" fn) (set-list-format fn 'nil)) (etypecase format (null (return 'nil)) (list-format (return format)) (symbol))))) (initialize-lists (il:lambda nil (il:* il:\; "Edited 7-Jul-87 12:53 by DCB") (il:setq types (list* (il:setq type-list (il:create edit-node-type name il:_ 'list assign-format il:_ ' assign-format-list compute-format-values il:_ 'cfv-list linearize il:_ ' linearize-list sub-node-changed il:_ 'subnode-changed-list compute-point-position il:_ 'compute-point-position-list compute-selection-position il:_ 'compute-selection-position-default set-point il:_ 'set-point-list set-selection il:_ ' set-selection-list grow-selection il:_ 'grow-selection-default select-segment il:_ ' select-segment-default insert il:_ 'insert-list delete il:_ 'delete-list copy-structure il:_ ' copy-structure-list copy-selection il:_ 'copy-selection-default stringify il:_ 'stringify-list back-space il:_ 'backspace-list)) (il:setq type-dotlist (il:create edit-node-type il:using type-list name il:_ 'dotlist assign-format il:_ 'assign-format-dotlist compute-format-values il:_ 'cfv-dotlist linearize il:_ 'linearize-dotlist)) (il:setq type-quote (il:create edit-node-type il:using type-root name il:_ 'quote assign-format il:_ 'assign-format-quote compute-format-values il:_ 'cfv-quote linearize il:_ 'linearize-quote sub-node-changed il:_ ' subnode-changed-quote set-point il:_ 'set-point-quote set-selection il:_ 'set-selection-quote grow-selection il:_ 'grow-selection-default insert il:_ 'replace-quote delete il:_ 'delete-quote copy-structure il:_ ' copy-structure-quote copy-selection il:_ 'copy-selection-default stringify il:_ 'stringify-quote back-space il:_ 'backspace-quote)) types)) (reset-formats))) (insert-list (il:lambda (node context where subnodes point) (il:* il:\; "Edited 17-Jul-87 10:04 by DCB") (il:* il:|;;;| "the Insert method for lists and related animals") (let (start end) (cond ((il:type? edit-selection where) (il:setq start (il:fetch select-start il:of where)) (il:setq end (or (il:fetch select-end il:of where) start))) ((il:type? edit-point where) (il:setq end (il:fetch point-index il:of where)) (il:setq start (il:add1 end))) (t (il:setq start (il:fetch sub-node-index il:of where)) (il:setq end start))) (replace-list node context start end subnodes point)))) (insert-null-list (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 11:30 by DCB") (il:* il:|;;;| "implements the left paren command: insert an empty list") (when (il:fmemb (type-of-input context) '(atom structure)) (let ((point (il:fetch caret-point il:of context)) new-list) (insert point context (list (il:setq new-list (create-null-list context)))) (when (not (dead-node? new-list)) (il:replace point-node il:of point il:with new-list) (il:replace point-index il:of point il:with 0) (il:replace point-type il:of point il:with 'structure) (set-selection-nowhere (il:fetch selection il:of context)))) (il:* il:|;;| "must return non-NIL if command executed") t))) (insert-quoted-gap (il:lambda (context charcode quote-type) (il:* il:\; "Edited 7-Jul-87 12:53 by DCB") (il:* il:\; "implements the ' command: insert a quoted gap") (when (eq (type-of-input context) 'structure) (let ((selection (il:fetch selection il:of context)) (point (il:fetch caret-point il:of context)) new-quote gap) (il:setq new-quote (create-quoted-gap basic-gap context quote-type)) (il:setq gap (subnode 1 new-quote)) (il:* il:\; "we get our hands on the gap node now, to handle the case where the insert reparses the new.quote") (insert (il:fetch caret-point il:of context) context (list new-quote)) (when (not (dead-node? new-quote)) (set-selection-me selection context gap) (pending-delete point selection)))(il:* il:\; "must return non-NIL if command executed") t))) (linearize-clisp (il:lambda (node context index) (il:* il:\; "Edited 11-Apr-88 15:45 by woz") (il:* il:|;;;| "the Linearize method for clisp expressions. the variable ok keeps track of our state: (NIL: next item starts a new line) (T: next item stays on this line) (check: next item goes on this line if it fits) (atom: next item goes on this line if it fits and is an atom)") (il:* il:|;;;| "the formatting rules are that (1) keywords not on clisp.indent.words always start new lines (2) always start a new line after anything non-atomic (3) non-atomic things can only follow keywords on the same line (4) clisp.indent.words can go on the same line as the preceding material if they're the last thing in the expression or followed by another keyword or by something that will fit inline on the same line (5) if clisp.indent.words start a new line they are indented by the minimum indentation (6) if anything else starts a new line it is indented by the width of the most recent keyword to start a line, plus one blank") (il:* il:|;;| "at present, if keywords always start new lines. this could be improved with a little more smarts") (il:|bind| indent comment-start-x comment-indent comment? program-word? (keyword? il:_ t) (second-subnode il:_ t) (ok il:_ t) (space-width il:_ (il:|fetch| space-width il:|of| (il:|fetch| environment il:|of| context))) (min-indent il:_ (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| indent-base il:|of| (il:|fetch| environment il:|of| context)))) (paren-width il:_ (il:|fetch| width il:|of| (il:|fetch| lparen-string il:|of| (il:|fetch| environment il:|of| context)))) (could-inline? il:_ (and (il:|fetch| inline-width il:|of| node) (il:ileq (il:iplus (il:|fetch| start-x il:|of| node) (il:|fetch| inline-width il:|of| node)) (il:|fetch| right-margin il:|of| node)))) (if? il:_ (il:memb (car (il:|fetch| structure il:|of| node)) (quote (il:if il:|if|)))) il:|first| (cond (index (il:setq index (and (il:neq index 1) (il:sub1 index)))) (t (il:* il:|;;| "start with an open paren and the first subnode (which should be a keyword) since system won't recognize clisp if first subnode is comment, don't have to handle that case here. it will be formatted as a form.") (output-constant-string context (il:|fetch| lparen-string il:|of| (il:|fetch| environment il:|of| context))) (linearize (cadr (il:|fetch| sub-nodes il:|of| node)) context))) (il:* il:|;;| "set indentation to one blank after the end of the keyword") (il:setq indent (il:iplus (il:|fetch| start-x il:|of| node) paren-width (il:|fetch| inline-width il:|of| (cadr (il:|fetch| sub-nodes il:|of| node))) space-width)) (set-comment-positions comment-start-x comment-indent indent paren-width node context) il:|for| subnode il:|in| (cddr (il:|fetch| sub-nodes il:|of| node)) il:|do| (cond (index (il:* il:|;;| "we don't actually linearize this subnode, but need to update our state as if we had") (il:setq index (and (il:neq index 1) (il:sub1 index))) (cond ((il:setq comment? (eq (il:|fetch| node-type il:|of| subnode) type-comment)) (il:* il:|;;| "this is a comment, so the next guy must start a new line. if following the first keyword, change indent to min.indent") (il:setq ok nil) (when second-subnode (il:setq indent min-indent))) ((il:setq keyword? (eq (il:|fetch| format il:|of| subnode) :keyword)) (il:* il:|;;| "this is a keyword. is it the first thing on this line?") (cond ((let ((item (cadr (il:memb (il:|fetch| last-line il:|of| subnode) (il:|fetch| linear-form il:|of| node))))) (and (il:|type?| weak-link item) (eq subnode (il:|fetch| destination il:|of| item)))) (il:* il:|;;| "the test for this branch used to be:") (il:* il:|;;| "(eq subnode (cadr (il:|fetch| last-line-linear il:|of| subnode)))") (il:* il:|;;| "yep. set the indentation to be one blank after the end of it") (il:setq indent (il:iplus (il:|fetch| start-x il:|of| subnode) (il:|fetch| inline-width il:|of| subnode) space-width)) (il:* il:|;;| "and the next thing goes on this line") (il:setq ok t)) (t (il:* il:|;;| "the next thing goes on this line if it fits") (il:setq ok (quote check))))) (t (il:* il:|;;| "the next thing can go on this line if i'm atomic, and it's atomic too") (il:setq ok (and (il:atom (il:|fetch| structure il:|of| subnode)) (quote atom)))))) (t (il:* il:|;;| "we really are linearizing this subnode") (cond ((il:setq comment? (eq (il:|fetch| node-type il:|of| subnode) type-comment)) (il:setq comment? (select-comment-indent (il:|fetch| unassigned il:|of| subnode) comment-indent indent (il:|fetch| start-x il:|of| (il:|fetch| root il:|of| context)))) (if (or (not ok) (il:igreaterp (il:|fetch| current-x il:|of| context) (il:selectq (il:|fetch| unassigned il:|of| subnode) (1 comment-start-x) (2 (il:idifference indent space-width)) 0))) (output-cr context comment?) (output-space context (il:idifference comment? (il:|fetch| current-x il:|of| context)))) (il:setq ok nil) (when second-subnode (il:setq indent min-indent))) ((il:setq keyword? (eq (il:|fetch| format il:|of| subnode) :keyword)) (il:* il:|;;| "we've got a keyword") (il:setq program-word? (il:fmemb (cdr (il:getprop (il:|fetch| structure il:|of| subnode) (quote il:clispword))) clisp-program-words)) (cond ((il:fmemb (cdr (il:getprop (il:|fetch| structure il:|of| subnode) (quote il:clispword))) clisp-indent-words) (il:* il:|;;| "perhaps it can go on this line") (cond ((and ok (or could-inline? (not if?)) (il:ileq (il:iplus (il:|fetch| current-x il:|of| context) space-width (il:|fetch| inline-width il:|of| subnode) (if (and (cdr il:$$lst1) (il:neq (il:|fetch| format il:|of| (cadr il:$$lst1)) :keyword)) (il:iplus space-width (or (il:|fetch| inline-width il:|of| (cadr il:$$lst1)) (il:|fetch| right-margin il:|of| node))) 0)) (il:|fetch| right-margin il:|of| node))) (il:* il:|;;| "it'll go on this line") (output-space context space-width) (il:setq ok (quote check))) (t (il:* il:|;;| "new line, indented by minimum indentation") (output-cr context min-indent) (il:setq indent (il:iplus min-indent (il:|fetch| inline-width il:|of| subnode) space-width)) (il:setq ok t)))) (t (il:* il:|;;| "new line, no indentation") (output-cr context (il:iplus (il:|fetch| start-x il:|of| node) paren-width)) (il:setq indent (il:iplus (il:|fetch| start-x il:|of| node) paren-width (il:|fetch| inline-width il:|of| subnode) space-width)) (il:setq ok t)))) (t (if (or (eq ok t) (and ok (il:|fetch| inline-width il:|of| subnode) (il:ileq (il:iplus (il:|fetch| current-x il:|of| context) space-width (il:|fetch| inline-width il:|of| subnode)) (il:|fetch| right-margin il:|of| node)) (or (eq ok (quote check)) (il:atom (il:|fetch| structure il:|of| subnode))))) (output-space context space-width) (output-cr context indent)) (il:setq ok (quote atom)))) (linearize subnode context) (when (and (eq ok (quote atom)) (not (il:|fetch| inline? il:|of| subnode))) (il:setq ok nil)))) (il:setq second-subnode nil) il:|finally| (when comment? (output-cr context (il:iplus (il:|fetch| start-x il:|of| node) paren-width)))) (when index (il:shouldnt "linearize index out of range")) (output-constant-string context (il:|fetch| rparen-string il:|of| (il:|fetch| environment il:|of| context)))) ) (linearize-dotlist (il:lambda (node context index) (il:* il:\; "Edited 7-Jul-87 12:54 by DCB") (il:* il:|;;;| "the Linearize method for dotted lists. nothing is indented, non-atomic things go on separate lines, and we put as many atoms on a line as we can fit. the last element of a dotted list is preceded by a dot.") (when (not index) (output-constant-string context (il:fetch lparen-string il:of (il:fetch environment il:of context)))) (when (cdr (il:fetch sub-nodes il:of node)) (il:bind (first-time? il:_ t) (space-width il:_ (il:fetch space-width il:of (il:fetch environment il:of context))) (paren-width il:_ (il:fetch width il:of (il:fetch lparen-string il:of (il:fetch environment il:of context)) )) this-line? needs-dot? comment? comment-start-x comment-indent il:first (set-comment-positions comment-start-x comment-indent paren-width paren-width node context) il:for subnode il:in (cdr (il:fetch sub-nodes il:of node)) il:do (il:setq comment? (eq (il:fetch node-type il:of subnode) type-comment)) (cond (index (il:setq index (and (il:neq index 1) (il:sub1 index))) (when comment? (output-cr context (il:iplus paren-width (il:fetch start-x il:of node) )))) (t (il:setq needs-dot? (and (eq (il:fetch node-type il:of node) type-dotlist) (null (cdr il:$$lst1)) (il:iplus space-width (il:fetch width il:of (il:fetch dot-string il:of (il:fetch environment il:of context)))))) (cond (comment? (il:setq first-time? nil) (if (or (il:neq (il:fetch unassigned il:of subnode) 1) (il:igreaterp (il:fetch current-x il:of context) comment-start-x)) (output-cr context (select-comment-indent (il:fetch unassigned il:of subnode) comment-indent (il:iplus paren-width (il:fetch start-x il:of node)) (il:fetch start-x il:of (il:fetch root il:of context)) )) (output-space context (il:idifference comment-indent (il:fetch current-x il:of context))))) ((and first-time? (not comment?)) (il:* il:\; "first time through, if not a comment, then i'm already in the right place for the first subnode") (il:setq first-time? nil)) ((and this-line? (null (cdr (il:fetch sub-nodes il:of subnode)) ) (il:leq (il:iplus (il:fetch current-x il:of context) space-width (il:fetch inline-width subnode) (or needs-dot? 0)) (il:fetch right-margin il:of node))) (il:* il:\; "the last node said i could go on this line, i'm atomic so i can go on this line, and i will fit") (output-space context space-width)) (t (il:* il:\; "somebody forced be to the next line") (output-cr context (il:iplus paren-width (il:fetch start-x il:of node))))) (when needs-dot? (output-constant-string context (il:fetch dot-string il:of (il:fetch environment il:of context))) (output-space context space-width)) (linearize subnode context))) (il:setq this-line? (and (not comment?) (null (cdr (il:fetch sub-nodes il:of subnode) )))) il:finally (when comment? (output-cr context (il:iplus paren-width (il:fetch start-x il:of node)))))) (when index (il:shouldnt "linearize index out of range")) (output-constant-string context (il:fetch rparen-string il:of (il:fetch environment il:of context))))) (linearize-list (il:lambda (node context index) (il:* il:\; "Edited 15-Feb-88 13:24 by raf") (il:* il:|;;;| "The list linearizer. Present this list, driven by the previously-determined ListFormat.") (let ((info (il:fetch unassigned il:of node))) (cond ((il:fetch non-standard? il:of info) (il:* il:|;;| "Non-standard ListFormats provide their own Linearize method -- use it.") (funcall (il:fetch linearize-list il:of info) node context index)) (t(il:* il:|;;| "Otherwise, we do the work") (let* ((environment (il:fetch environment il:of context)) (lparen (il:fetch lparen-string il:of environment)) (paren-width (il:fetch width il:of lparen)) (space-width (il:fetch space-width il:of environment)) (startx (il:fetch start-x il:of node)) (indent (il:iplus startx paren-width) (il:* il:\; "this will record the current tab setting") ) (first t (il:* il:\; "true until we've printed the first non-comment subnode") ) (prev-type nil (il:* il:\; "one of Atom, Comment, or NIL (other)") ) next-type (prev-inline nil (il:* il:\; "true if the last subnode printed inline") ) (subnodes (cdr (il:fetch sub-nodes il:of node))) (last-subnode subnodes (il:* il:\; "will point to the tail of subnodes beginning with the last non-comment subnode") ) (right-margin (il:fetch right-margin il:of node)) (comment-separation (il:fetch comment-separation il:of context)) (comment-start (il:iplus (il:idifference right-margin (il:fetch comment-width il:of context)) comment-separation)) (inline? (and (il:fetch inline-width il:of node) (il:ileq (il:iplus (il:fetch inline-width il:of node) startx) right-margin)) (il:* il:\; "true if we could fit this whole node inline") ) last-info already-indented?) (il:* il:\; "'already.indented' is a real pain. part of the comment-indent look-ahead") (il:* il:|;;| "Use either the preferred or minimal spacing information, depending on how much room we have") (when (not index) (output-constant-string context lparen)) (il:for p il:on subnodes il:when (not (eq (il:fetch node-type il:of (car p)) type-comment)) il:do (il:setq last-subnode p)) (cond (inline? (il:* il:|;;| "NODE will fit inline, so we don't run formatting rules, just print it.") (dolist (subnode (if index (nthcdr index subnodes) subnodes)) (linearize subnode context) (unless (eq subnode (car last-subnode)) (output-space context space-width)))) (t (il:setq info (if (il:igreaterp (il:iplus (il:fetch preferred-width il:of node) startx) right-margin) (il:fetch list-mformat il:of info) (il:fetch list-pformat il:of info))) (il:setq last-info (car info)) (il:* il:|;;| "Find the last non-comment subnode") (il:while subnodes il:do (let ((subnode (car subnodes))) (cond ((eq (il:fetch node-type il:of subnode) type-comment) (cond (index (when (eq (il:fetch unassigned il:of subnode) 2) (when (il:neq indent (il:fetch start-x il:of subnode)) (il:setq already-indented? t) (il:setq indent (il:fetch start-x il:of subnode))))) (t (il:* il:|;;| "The rules for spacing before comments are tricky") (il:selectq (il:fetch unassigned il:of subnode) (1 (il:* il:|;;| "Level 1 comments will always start at comment.start. If the current line isn't already past the comment margin, start at the end of it -- otherwise on a new line") (output-cr-or-space context comment-start comment-separation)) (2 (il:* il:|;;| "Level 2 comments start on a new line, unless they're the first thing in the list, and are indented to the tab setting. The trick is that unless we've just printed a comment, or we've already printed the last non-comment node in the list, we want the tab setting for the *next* element of the list (e.g. suppose we just printed a 'then') -- and the next element hasn't been printed yet... so we interpret the next separation info, and give it a chance to reset the tab first") (cond (already-indented? (output-cr context indent)) ((null info) (output-cr-or-space context indent space-width)) ((and first (null prev-type)) (il:* il:|;;| "Level 2 comments at the beginning of a list (and not following other comments) immediately follow the (") ) (t (il:* il:|;;| "Determine the separation info for the next element, and see if it sets the tab") (let ((sepr-info (car (or (cdr info) info))) (break? nil) (set-indent? nil) (indent-base (il:iplus startx paren-width))) (il:while (il:listp sepr-info) il:do (il:setq sepr-info (il:selectq (car sepr-info) (prev-inline? (if prev-inline (cadr sepr-info) (cddr sepr-info))) ((next-inline? next-preferred? next-atom? next-keyword? next-lambdaword?) (cddr sepr-info)) (prev-atom? (if (il:fmemb prev-type '(atom keyword lambdaword)) (cadr sepr-info) (cddr sepr-info))) (prev-keyword? (if (eq prev-type 'keyword) (cadr sepr-info) (cddr sepr-info))) (prev-lambdaword? (if (eq prev-type 'lambdaword) (cadr sepr-info) (cddr sepr-info) )) (set-indent (il:setq set-indent? t) (cdr sepr-info)) (from-indent (il:setq indent-base indent) (cdr sepr-info)) (break (il:setq break? t) (cdr sepr-info)) (il:shouldnt "Bad List Format")))) (cond (set-indent? (if break? (output-cr-or-space context (il:imax 1 (il:iplus sepr-info indent-base)) space-width) (output-space context space-width) ) (il:setq indent (il:fetch current-x il:of context)) (il:setq already-indented? t)) (t (output-cr-or-space context indent space-width))))) )) ((3 4 5) (il:* il:|;;| "Level 3, 4 and 5 comments are aligned with the left edge of the root") (output-cr context (il:fetch start-x il:of (il:fetch root il:of context)))) (il:shouldnt "unexpected comment level")) (linearize subnode context))) (il:setq prev-type 'comment) (il:setq prev-inline nil)) (t (il:* il:|;;| "A non-comment node") (il:setq next-type (next-node-type subnode)) (cond (first (il:setq first nil) (il:* il:|;;| "If it was preceded by a comment, we'll need a new line") (when (and prev-type (not index)) (output-cr context indent))) (already-indented? (il:* il:|;;| "doesn't matter if this was the last subnode, since there won't be any more") (when (cdr info) (il:setq info (cdr info))) (when (not index) (output-cr context indent))) (t (let ((sepr-info (cond ((and (eq subnodes last-subnode) (null (cddr info))) (il:setq info nil) last-info) (t (car (il:setq info (or (cdr info) info)))))) (break? nil) (set-indent? nil) (indent-base (il:iplus startx paren-width))) (il:while (il:listp sepr-info) il:do (il:setq sepr-info (il:selectq (car sepr-info) (prev-inline? (if prev-inline (cadr sepr-info) (cddr sepr-info))) (next-inline? (if (and (il:fetch inline-width il:of subnode) (il:ileq (il:iplus (il:fetch current-x il:of context) space-width (il:fetch inline-width il:of subnode)) right-margin)) (cadr sepr-info) (cddr sepr-info))) (next-preferred? (if (il:ileq (il:iplus (il:fetch current-x il:of context) space-width (il:fetch preferred-width il:of subnode) ) right-margin) (cadr sepr-info) (cddr sepr-info))) (prev-atom? (if (il:fmemb prev-type '(atom keyword lambdaword)) (cadr sepr-info) (cddr sepr-info))) (prev-keyword? (if (eq prev-type 'keyword) (cadr sepr-info) (cddr sepr-info))) (prev-lambdaword? (if (eq prev-type 'lambdaword) (cadr sepr-info) (cddr sepr-info))) (next-atom? (if (il:fmemb next-type '(atom keyword lambdaword)) (cadr sepr-info) (cddr sepr-info))) (next-keyword? (if (eq next-type 'keyword) (cadr sepr-info) (cddr sepr-info))) (next-lambdaword? (if (eq next-type 'lambdaword) (cadr sepr-info) (cddr sepr-info))) (set-indent (il:setq set-indent? t) (cdr sepr-info)) (from-indent (il:setq indent-base indent) (cdr sepr-info)) (break (il:setq break? t) (cdr sepr-info)) (il:shouldnt "Bad List Format")))) (cond (index (when set-indent? (il:setq indent (il:fetch start-x il:of subnode)))) (t (cond ((eq prev-type 'comment) (output-cr context (il:imax 1 (il:iplus sepr-info indent-base)))) (break? (output-cr-or-space context (il:imax 1 (il:iplus sepr-info indent-base)) space-width)) (t (output-space context space-width))) (when set-indent? (il:setq indent (il:fetch current-x il:of context)))))))) (il:* il:|;;| "Now we've got the appropriate spacing, linearize the subnode and set prev.inline and prev.type appropriately") (il:setq prev-inline (if index (il:fetch inline? il:of subnode) (linearize subnode context))) (il:setq prev-type next-type) (il:setq already-indented? nil)))) (when index (il:setq index (and (il:neq index 1) (il:sub1 index)))) (il:setq subnodes (cdr subnodes))) (when index (il:shouldnt "linearize index out of range")) (il:* il:|;;| "The closing paren goes on a new line if it's following a comment or there's no room for it on the previous line") (when (or (eq prev-type 'comment) (and *wrap-parens* (il:igreaterp (il:iplus (il:fetch current-x il:of context) paren-width) right-margin) (il:ilessp indent right-margin))) (output-cr context indent)))) (output-constant-string context (il:fetch rparen-string il:of environment)))))))) (linearize-quote (il:lambda (x context index) (il:* il:\; "Edited 17-Nov-87 11:33 by DCB") (il:* il:|;;;| "the Linearize method for quoted structures. trivial") (cond ((not index) (output-constant-string context (il:fetch unassigned il:of x)) (linearize (cadr (il:fetch sub-nodes il:of x)) context)) ((il:neq index 1) (il:shouldnt "linearize index out of range"))))) (next-node-type (il:lambda (node) (il:* il:\; "Edited 7-Jan-88 13:56 by DCB") (il:* il:|;;;| "Return the \"indentation type\" of a node, one of atom, keyword, lambdaword, or nil. Quote nodes return the type of their quoted structure; NIL nodes return atom or NIL depending on the node type.") (let* ((str (il:|fetch| structure il:|of| node)) (type (il:|ffetch| node-type il:|of| node))) (typecase str (cons (if (eq type type-quote) (next-node-type (subnode 1 node)) 'nil)) (keyword 'keyword) (symbol (cond ((eq type type-list) nil) ((il:fmemb str lambda-list-keywords) 'lambdaword) (t 'atom))) (t 'atom))))) (output-cr-or-space (il:lambda (context indent space-width) (il:* il:\; "Edited 7-Jul-87 12:55 by DCB") (if (il:igreaterp (il:iplus (il:fetch current-x il:of context) space-width) indent) (output-cr context indent) (output-space context (il:idifference indent (il:fetch current-x il:of context)))) )) (parenthesize-current-selection (il:lambda (context charcode point-after?) (il:* il:\; "Edited 22-Dec-87 08:51 by DCB") (let* ((selection (il:fetch selection il:of context)) (node (il:fetch select-node il:of selection)) (start (il:fetch select-start il:of selection)) (end (il:fetch select-end il:of selection)) (point (il:fetch caret-point il:of context)) nodes new-node) (cond ((and node (eq (il:fetch select-type il:of selection) 'structure)) (start-undo-block) (if start (il:setq nodes (il:for i il:from start il:to (or end start) il:as subnodes il:on (cdr (il:nth (il:fetch sub-nodes il:of node) start)) il:collect (car subnodes))) (il:setq nodes (list node))) (il:replace point-node il:of point il:with selection) (il:replace point-type il:of point il:with 'structure) (il:setq new-node (create-null-list context)) (insert point context new-node) (il:setq nodes (il:for n il:in nodes il:when (dead-node? n) il:collect n)) (il:replace point-node il:of point il:with new-node) (il:replace point-type il:of point il:with 'structure) (il:replace point-index il:of point il:with 0) (insert point context nodes) (select-node context new-node) (cond (point-after? (set-point point context new-node nil t)) (t (il:replace point-node il:of point il:with new-node) (il:replace point-type il:of point il:with 'structure) (il:replace point-index il:of point il:with 0))) (end-undo-block)) (t (format (get-prompt-window context) "~%Select structure to parenthesize.")))) (il:* il:|;;| "must return non-NIL if command executed") t)) (parse--list (il:lambda (structure context) (il:* il:\; "Edited 14-Jun-88 20:47 by drc:") (il:* il:|;;;| "parse a list. if we're in default mode and it's undotted, check to see if it starts with a special word and if so parse it appropriately") (let* ((parser (and (il:litatom (car structure)) (il:listget list-parse-info (car structure))))) (when (not (and parser (funcall parser structure context))) (parse--list-internal structure context (and (listp structure) (atom (car structure)) (get-list-format (car structure))))))) ) (parse--list-internal (il:lambda (structure context format) (il:* il:\; "Edited 14-Jun-88 21:26 by drc:") (let ((node (build-node structure context type-list))) (let* (list-positions sub-formats sub-formats-length subnode subformat) (when format (setq list-positions (il:|fetch| list-sublists il:|of| format)) (setq sub-formats (il:|ffetch| list-formats il:|of| format)) (setq sub-formats-length (if sub-formats (length sub-formats) 0))) (do ((sublist? nil) (comment? nil) (node-count 0) (tail structure (cdr tail))) ((or (atom tail) (and (consp (cdr tail)) (null (cddr tail)) (member (car tail) internal-wrappers :test (quote eq)))) (when tail (il:* il:|;;| "whent it's a real dotted-list or it's a dotted-wrapper, [e.g. (a . #'b)] then smash the type to dotted & parse TAIL as the last subnode.") (il:|replace| node-type il:|of| node il:|with| type-dotlist) (parse tail context))) (setq subnode (car tail)) (setq comment? (and (consp subnode) (eq (car subnode) (quote il:*)))) (cond ((not comment?) (incf node-count) (setq sublist? (and list-positions (null subnode) (or (eq list-positions t) (member node-count list-positions :test (quote eq))))) (setq subformat (when (and sub-formats (consp subnode) (not (member (car subnode) internal-wrappers :test (quote eq)))) (get-list-format (if (>= node-count sub-formats-length) (first sub-formats) (nth node-count sub-formats)))))) (t (setq sublist? nil) (setq subformat nil))) (parse subnode context (when (or sublist? subformat) (il:function parse--list-internal)) subformat))))) ) (parse--quote (il:lambda (structure context) (il:* il:\; "Edited 7-Jul-87 12:55 by DCB") (il:* il:|;;;| "try to parse this list as a quoted structure") (when (and (cdr structure) (null (cddr structure))) (build-node structure context type-quote) (il:replace unassigned il:of (il:fetch current-node il:of context) il:with (il:listget (il:fetch quote-string il:of (il:fetch environment il:of context)) (quote-wrapper-name (car structure)))) (parse (cadr structure) context) (il:* il:|;;| "that is, if the object is quoted and not backquoted, then it can be parsed in Data mode, and not as a form") t))) (replace-list (il:lambda (node context start end subnodes point redot?) (il:* il:\; "Edited 22-Dec-87 11:12 by DCB") (il:* il:|;;;| "replaces the subnodes of NODE indexed by START through END with new subnodes SUBNODES. turns the list into a dotted list if REDOT? is true. may also undot a list.") (let ((dot-list? (eq (il:fetch node-type il:of node) type-dotlist)) (insert-after (il:nth (il:fetch sub-nodes il:of node) start)) (trailing-subnodes (il:nth (il:fetch sub-nodes il:of node) (il:iplus end 2))) (delta-length (il:idifference (il:length subnodes) (il:add1 (il:idifference end start)))) trailing-structure structure converted? new-subnode-count undo-bounds undo-structure) (il:* il:|;;| "fix up subnode indices for those to follow the inserted material") (il:for s il:in trailing-subnodes il:do (il:add (il:fetch sub-node-index il:of s) delta-length)) (il:* il:|;;| "fix the subnode count") (il:setq new-subnode-count (il:iplus (car (il:fetch sub-nodes il:of node)) delta-length)) (rplaca (il:fetch sub-nodes il:of node) new-subnode-count) (il:* il:|;;| "mark the deleted subnodes as dead, dead, dead") (il:for (dead-nodes il:_ (cdr insert-after)) il:by (cdr dead-nodes) il:bind dead-node il:while (il:neq dead-nodes trailing-subnodes) il:do (il:replace super-node il:of (il:setq dead-node (car dead-nodes)) il:with 'dead!) (kill-node dead-node) (il:setq undo-structure dead-nodes)) (il:* il:|;;| "fix up the nodes to be inserted, and make a list out of their structures") (cond (subnodes (il:setq undo-bounds (cons start (il:iplus end delta-length))) (il:setq structure (il:for x il:in subnodes il:as i il:from start il:bind (depth il:_ (il:add1 (il:fetch depth il:of node))) il:collect (il:replace sub-node-index il:of x il:with i) (il:replace super-node il:of x il:with node) (set-depth x depth) (il:fetch structure il:of x)))) (t (il:setq undo-bounds start))) (when undo-structure (rplacd undo-structure nil) (il:setq undo-structure (cdr insert-after))) (il:* il:|;;| "then insert those subnodes into the super's list") (rplacd insert-after (nconc subnodes trailing-subnodes)) (il:* il:|;;| "and fix up the structure") (cond ((or (null (il:fetch structure il:of node)) (eq 0 new-subnode-count)) (il:* il:|;;| "changed this list to or from NIL. just replace it") (il:replace structure il:of node il:with structure) (subnode-changed node context)) (t (when trailing-subnodes (il:setq trailing-structure (il:nth (il:fetch structure il:of node) (il:add1 end)))) (cond ((eq start 1) (il:* il:|;;| "replacing at the beginning of a list. play games with pointers") (cond ((eq end 0) (il:* il:|;;| "straight insertion (nothing being replaced)") (il:setq trailing-structure (cons (car trailing-structure) (cdr trailing-structure)))) ((and dot-list? (eq new-subnode-count 1)) (il:* il:|;;| "deleting everything in a dotted list but the element after the dot undots it") (il:setq converted? t) (il:setq trailing-structure (list trailing-structure)))) (il:rplnode2 (il:fetch structure il:of node) (nconc structure trailing-structure))) (t (if (and dot-list? (null trailing-subnodes)) (when (and (eq 0 delta-length) (null (cdr subnodes))) (il:setq structure (car structure))) (il:setq structure (nconc structure trailing-structure))) (rplacd (il:nth (il:fetch structure il:of node) (il:sub1 start)) structure))))) (il:* il:|;;| "fix up selection and insertion point") (when point (il:replace point-node il:of point il:with node) (il:replace point-index il:of point il:with (il:iplus end delta-length)) (il:replace point-type il:of point il:with 'structure)) (let ((caret (il:fetch caret-point il:of context))) (cond ((and (il:neq caret point) (il:type? edit-node (il:fetch point-node il:of caret))) (cond ((dead-node? (il:fetch point-node il:of caret)) (il:* il:|;;| "if the caret was in the deleted material, we'll put it in the space the material was deleted from") (il:replace point-node il:of caret il:with node) (il:replace point-index il:of caret il:with (il:iplus end delta-length) ) (il:replace point-type il:of caret il:with 'structure)) ((and (eq (il:fetch point-node il:of caret) node) (il:igeq (il:fetch point-index il:of caret) start)) (il:* il:|;;| "if it was between deleted items or after them in the list, it will need to be fixed up") (il:replace point-index il:of caret il:with (il:iplus delta-length (il:imax (il:fetch point-index il:of caret) end)))))) ((and (il:neq caret point) (il:type? edit-selection (il:fetch point-node il:of caret))) (let* ((selection (il:fetch point-node il:of caret))) (cond ((dead-node? (il:fetch select-node il:of selection)) (set-selection-nowhere selection)) ((and (eq (il:fetch select-node il:of selection) node) (il:fetch select-start il:of selection) (il:igreaterp (il:fetch select-start il:of selection) end)) (il:* il:|;;| "the selection is after the stuff deleted. fix up the selection. don't need to worry about overlaps, because delete overlaps cancel the selection and move overlaps aren't allowed, so can just do simple index translation.") (il:replace select-start il:of selection il:with (il:iplus delta-length (il:fetch select-start il:of selection))) (il:replace select-end il:of selection il:with (il:iplus delta-length (il:fetch select-end il:of selection))))))))) (il:* il:|;;| "make sure this is a dotted list or not, as appropriate") (cond (redot? (when (or dot-list? (il:ilessp new-subnode-count 2)) (il:shouldnt "shouldn't be redotting this one")) (il:replace node-type il:of node il:with type-dotlist) (il:setq dot-list? t)) ((or converted? (and dot-list? (<= start end) (null trailing-subnodes) (or (il:ilessp start end) (il:neq delta-length 0)))) (il:* il:|;;| "dotted lists stop being dotted if you (a) delete everything but the last element, (b) replace a sequence of more than one subnode including the last element, (c) delete the last element, or (d) replace the last element with more than one element") (il:replace node-type il:of node il:with type-list) (il:setq converted? t))) (il:* il:|;;| "note change so that pretty-printer will fix up presentation") (note-change node context) (il:* il:|;;| "record how to undo this change") (undo-by undo-list-replace node undo-bounds undo-structure converted?) nil))) (replace-quote (il:lambda (node context where subnodes point) (il:* il:\; "Edited 17-Jul-87 10:04 by DCB") (let ((subnode (car subnodes))) (when (not (or (and (il:type? edit-selection where) (eq (il:fetch select-start il:of where) 1) (eq (il:fetch select-end il:of where) 1)) (il:type? edit-node where))) (il:shouldnt "weird bounds for replace.quote")) (undo-by undo-replace-quote node (subnode 1 node)) (kill-node (subnode 1 node)) (rplaca (cdr (il:fetch sub-nodes il:of node)) subnode) (il:replace super-node il:of subnode il:with node) (il:replace sub-node-index il:of subnode il:with 1) (rplaca (cdr (il:fetch structure il:of node)) (il:fetch structure il:of subnode)) (set-depth subnode (il:add1 (il:fetch depth il:of node))) (note-change node context) (when point (punt-set-point point context node t)) (cdr subnodes)))) (set-list-format (il:lambda (fn format) (il:* il:\; "Edited 1-Sep-87 14:54 by drc:") (if format (setf (gethash fn list-formats-table) format) (remhash fn list-formats-table)))) (set-point-list (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 22-Feb-88 14:33 by woz") (il:* il:|;;;| "the SetPoint method for lists, lambdas, clisps, etc.") (prog ((dotted? (eq (il:|fetch| node-type il:|of| node) type-dotlist)) (number-subnodes (car (il:|fetch| sub-nodes il:|of| node)))) (when (not index) (il:* il:|;;| "we can't set a point at our left or right boundary, but maybe our super can") (return (punt-set-point point context node offset compute-location?))) (cond ((il:|type?| string-item item) (il:* il:|;;| "pointing to the left paren, right paren, or dot. figure out which side they're pointing to") (il:setq offset (il:ilessp offset (il:half (il:fetch width il:of item)))) (cond ((il:strequal (il:fetch string il:of item) ".") (il:* il:\; "it's a dot") (il:setq index (if offset (il:sub1 number-subnodes) number-subnodes))) ((eq offset (eq index 1)) (il:* il:|;;| "left side of the left paren or right side of the right paren puts us outside the list") (return (punt-set-point point context node (not offset) compute-location?))) (offset (il:* il:|;;| "we must be on the right paren") (il:setq index number-subnodes) (il:* il:|;;| "the left paren case is already correct, since index=0")))) ((il:|type?| edit-node item) (il:setq type (quote structure))) (t (il:* il:|;;| "space or cr. figure out which end we're closer to") (when (or (il:smallp (cadr (il:fetch linear-form il:of node))) (il:|type?| line-start (cadr (il:fetch linear-form il:of node)))) (il:* il:|;;| "starts with a comment (single-semi causing space, triple-semi causing line-start), so there's something extra as the second thing in the linear form that we have to skip over") (il:setq index (il:sub1 index))) (il:setq offset (il:ilessp offset (il:half (or (il:smallp item) 0)))) (if offset (il:setq index (il:half index)) (il:setq index (il:half (il:iplus 2 index)))) (when dotted? (cond ((eq index number-subnodes) (when (il:setq offset (not offset)) (il:setq index (il:sub1 index)))) ((eq index (il:add1 number-subnodes)) (il:setq index number-subnodes)))) (when (il:igreaterp index number-subnodes) (il:setq index number-subnodes) (il:setq offset t)))) (cond ((and (eq type (quote atom)) (il:neq index 0) (il:ileq index number-subnodes)) (set-point point context (subnode index node) nil offset nil (quote atom) compute-location?)) ((and dotted? (eq index number-subnodes)) (il:* il:|;;| "can't insert structure after the dot in a dotted list") (set-point-nowhere point)) (t (il:|replace| point-node il:|of| point il:|with| node) (il:|replace| point-index il:|of| point il:|with| (if offset index (il:setq index (il:sub1 index)))) (il:|replace| point-type il:|of| point il:|with| (quote structure)) (when compute-location? (compute-point-position-list point)))))) ) (set-point-quote (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 17-Nov-87 11:34 by DCB") (il:* il:|;;;| "the SetPoint method for quoted structures. there's no place to insert, so if we can't punt to the super or sub node there'll be no point") (cond ((not index) (if offset (set-point point context (subnode 1 node) nil t nil type compute-location?) (punt-set-point point context node nil compute-location?))) ((il:type? string-item item) (set-point point context (subnode 1 node) nil nil nil type compute-location?)) (offset (punt-set-point point context node offset compute-location?)) (t (set-point-nowhere point))))) (set-selection-list (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:36 by DCB") (il:* il:|;;;| "the SetSelection method for lists. pointing to the parens gets the whole list, pointing to whitespace gets nothing") (if (or (and (il:type? string-item item) (eq type 'structure)) (il:type? edit-node item)) (set-selection-me selection context node) (set-selection-nowhere selection)))) (set-selection-quote (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:36 by DCB") (il:* il:|;;;| "the SetSelection method for quoted structures") (if (or (and (eq index 1) (eq type 'structure)) (il:type? edit-node item)) (set-selection-me selection context node) (set-selection-nowhere selection)))) (stringify-list (il:lambda (node environment) (il:* il:\; "Edited 7-Jul-87 12:56 by DCB") (il:bind (strings il:_ '(")")) (dot il:_ (eq (il:fetch node-type il:of node) type-dotlist)) il:for subnode il:in (il:reverse (cdr (il:fetch sub-nodes il:of node))) il:do (il:setq strings (cons (cond (dot (il:setq dot nil) " . ") (t " ")) (cons (stringify subnode environment) strings))) il:finally (return (il:concatlist (cons "(" (cdr strings))))))) (stringify-quote (il:lambda (node environment) (il:* il:\; "Edited 7-Jul-87 12:56 by DCB") (il:concat (il:fetch string il:of (il:fetch unassigned il:of node)) (stringify (subnode 1 node) environment)))) (subnode-changed-list (il:lambda (node subnode context) (il:* il:\; "Edited 7-Jul-87 12:56 by DCB") (il:* il:|;;;| "the SubNodeChanged method for lists of all flavours") (il:* il:|;;| "stick in the new subnode") (if (and (eq (il:fetch node-type il:of node) type-dotlist) (eq (il:fetch sub-node-index il:of subnode) (car (il:fetch sub-nodes il:of node)))) (rplacd (il:nth (il:fetch structure il:of node) (il:sub1 (il:fetch sub-node-index il:of subnode))) (il:fetch structure il:of subnode)) (rplaca (il:nth (il:fetch structure il:of node) (il:fetch sub-node-index il:of subnode)) (il:fetch structure il:of subnode))) (il:* il:|;;| "note the change so that the pretty-printer can fix things up") (note-change node context))) (subnode-changed-quote (il:lambda (node subnode) (il:* il:\; "Edited 17-Nov-87 11:36 by DCB") (il:* il:|;;;| "the SubNodeChanged method for quoted structures. not much interesting to happen here") (rplaca (cdr (il:fetch structure il:of node)) (il:fetch structure il:of subnode)))) (undo-list-replace (il:lambda (context node bounds old-subnodes redot?) (il:* il:\; "Edited 7-Jul-87 12:56 by DCB") (il:* il:|;;;| "undo method for replaces within lists.") (il:* il:|;;| "make sure you revive only dead nodes") (il:for subnode il:in old-subnodes il:unless (dead-node? subnode) il:do (il:shouldnt "undo is confused!")) (let ((last-inserted-subnode (and old-subnodes (car (last old-subnodes))))) (il:* il:|;;| "stick the dead nodes back in the list in place of the ones they were replaced by. replace.list will note the change to the list, which will cause the pretty-printer to fix up the presentation.") (replace-list node context (or (il:fixp bounds) (car bounds)) (or (cdr (il:listp bounds)) (il:sub1 bounds)) old-subnodes (il:fetch caret-point il:of context) redot?) (il:* il:|;;| "patch up selection") (when old-subnodes (select-segment (il:fetch selection il:of context) context node (car old-subnodes) last-inserted-subnode) (il:replace pending-delete? il:of (il:fetch selection il:of context) il:with nil))))) (undo-replace-quote (il:lambda (context node old-value) (il:* il:\; "Edited 7-Jul-87 12:56 by DCB") (when (not (dead-node? old-value)) (il:shouldnt "undo is confused!")) (replace-quote node context (subnode 1 node) (list old-value) nil) (when (eq (il:fetch node-type il:of old-value) type-gap) (select-segment (il:fetch selection il:of context) context node old-value old-value) (pending-delete (il:fetch caret-point il:of context) (il:fetch selection il:of context))))) ) (IL:PUTPROPS IL:SEDIT-LISTS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (4966 118825 (ASSIGN-FORMAT-CLISP 4979 . 6549) (ASSIGN-FORMAT-DOTLIST 6551 . 6962) ( ASSIGN-FORMAT-LIST 6964 . 11336) (ASSIGN-FORMAT-QUOTE 11338 . 12092) (BACKSPACE-LIST 12094 . 13642) ( BACKSPACE-QUOTE 13644 . 15705) (CFV-CLISP 15707 . 18753) (CFV-DOTLIST 18755 . 21902) (CFV-LIST 21904 . 31812) (CFV-QUOTE 31814 . 32793) (CLOSE-LIST 32795 . 34842) (COMPUTE-POINT-POSITION-LIST 34844 . 38766) (COPY-STRUCTURE-LIST 38768 . 39642) (COPY-STRUCTURE-QUOTE 39644 . 40053) (CREATE-NULL-LIST 40055 . 41102) (CREATE-QUOTED-GAP 41104 . 42431) (DELETE-LIST 42433 . 42838) (DELETE-QUOTE 42840 . 43796) (DOT-THIS-LIST 43798 . 45978) (GET-LIST-FORMAT 45980 . 46766) (INITIALIZE-LISTS 46768 . 51182) (INSERT-LIST 51184 . 52009) (INSERT-NULL-LIST 52011 . 53042) (INSERT-QUOTED-GAP 53044 . 54320) ( LINEARIZE-CLISP 54322 . 61476) (LINEARIZE-DOTLIST 61478 . 68130) (LINEARIZE-LIST 68132 . 89717) ( LINEARIZE-QUOTE 89719 . 90204) (NEXT-NODE-TYPE 90206 . 91206) (OUTPUT-CR-OR-SPACE 91208 . 91640) ( PARENTHESIZE-CURRENT-SELECTION 91642 . 94198) (PARSE--LIST 94200 . 94733) (PARSE--LIST-INTERNAL 94735 . 96270) (PARSE--QUOTE 96272 . 97098) (REPLACE-LIST 97100 . 107841) (REPLACE-QUOTE 107843 . 109144) ( SET-LIST-FORMAT 109146 . 109412) (SET-POINT-LIST 109414 . 112222) (SET-POINT-QUOTE 112224 . 113095) ( SET-SELECTION-LIST 113097 . 113683) (SET-SELECTION-QUOTE 113685 . 114191) (STRINGIFY-LIST 114193 . 115040) (STRINGIFY-QUOTE 115042 . 115317) (SUBNODE-CHANGED-LIST 115319 . 116356) ( SUBNODE-CHANGED-QUOTE 116358 . 116699) (UNDO-LIST-REPLACE 116701 . 118182) (UNDO-REPLACE-QUOTE 118184 . 118823))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-TERMINAL b/sources/SEDIT-TERMINAL new file mode 100644 index 00000000..ad22fe27 --- /dev/null +++ b/sources/SEDIT-TERMINAL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "17-May-90 11:11:54" IL:|{DSK}local>lde>lispcore>sources>SEDIT-TERMINAL.;2| 6716 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-TERMINALCOMS) IL:|previous| IL:|date:| "17-Nov-87 16:16:24" IL:|{DSK}local>lde>lispcore>sources>SEDIT-TERMINAL.;1|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-TERMINALCOMS) (IL:RPAQQ IL:SEDIT-TERMINALCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-TERMINAL) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-TERMINAL) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:BITMAPS STRUCTURE-CARET-BITMAP ATOM-CARET-BITMAP) (IL:VARS (STRUCTURE-CARET (IL:CURSORCREATE STRUCTURE-CARET-BITMAP 3 4)) (ATOM-CARET (IL:CURSORCREATE ATOM-CARET-BITMAP 3 4))) (IL:FNS ATOM-CHAR-ESCAPED CHARCODE GETKEY PRINT-STRING SHIFT-STRING STRINGWIDTH TTYEXITFN) )) (IL:PUTPROPS IL:SEDIT-TERMINAL IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-TERMINAL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQQ STRUCTURE-CARET-BITMAP #*(7 6)A@@@CH@@CH@@GL@@GL@@ON@@) (IL:RPAQQ ATOM-CARET-BITMAP #*(7 6)A@@@CH@@CH@@FL@@FL@@LF@@) (IL:RPAQ STRUCTURE-CARET (IL:CURSORCREATE STRUCTURE-CARET-BITMAP 3 4)) (IL:RPAQ ATOM-CARET (IL:CURSORCREATE ATOM-CARET-BITMAP 3 4)) (IL:DEFINEQ (atom-char-escaped (il:lambda (char read-table) (il:* il:\; "Edited 16-Jul-87 15:28 by DCB") (il:* il:|;;;| "teset if this char must be escaped in an atom. read.table now defaults to *READTABLE* for profiles.") (or read-table (il:setq read-table *readtable*)) (or (and (il:igeq char (il:charcode \a)) (il:ileq char (il:charcode \z)) (il:fetch (readtablep il:caseinsensitive) il:of read-table)) (il:fetch (il:readcode il:innerescquote) il:of (il:\\syncode (il:fetch il:readsa il:of read-table) char)))) ) (charcode (il:lambda (char) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (or (il:smallp char) (funcall (il:function il:charcode) char))) ) (getkey (il:lambda (context) (il:* il:\; "Edited 17-Nov-87 11:28 by DCB") (declare (il:globalvars il:\\linebuf.ofd)) (cond ((and (il:this.process) (il:fetch il:proctypeahead il:of (il:this.process))) (il:pop (il:fetch il:proctypeahead il:of (il:this.process)))) (t (il:bind il:c (point il:_ (il:fetch caret-point il:of context)) (window il:_ (il:windowprop (il:fetch display-window il:of context) (quote il:dsp))) il:do (il:wait.for.tty) (when (il:setq il:c (il:\\getsysbuf)) (return il:c)) (when (eq (il:fetch il:keyboardstream il:of il:\\linebuf.ofd) il:\\keyboard.stream) (il:* il:|;;| "now call the TTYBACKGROUND stuff explicitly, so can call CARET.FLASH? directly") (when (and (or (not selection-pending?) (and pending-shift (il:neq pending-shift (quote delete)))) (il:type? edit-node (il:fetch point-node il:of point))) (il:\\caret.flash? window (il:fetch caret il:of context) nil nil (il:fetch point-x il:of point) (il:fetch base-line-y il:of (il:fetch point-line il:of point)))) (il:\\savevmbackground)) (il:\\background))))) ) (print-string (il:lambda (str window prin-2?) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (il:* il:|;;;| "immitate PRIN2 with respect to *readtable* if print2?. otherwise just prin1, except control chars, which are always printed as ^") (il:|bind| (stream il:_ (il:|fetch| (il:window il:dsp) il:|of| window)) (esc-char il:_ (escape-char)) display-data il:|for| c il:|instring| str il:|first| (il:setq display-data (il:\\getdisplaydata stream)) (and prin-2? (il:\\bltchar (il:charcode il:\") stream display-data)) il:|do| (cond ((and prin-2? (or (eq c (il:charcode il:\")) (eq c esc-char))) (il:* il:|;;| "immitate prin2 of double quotes and escape char") (il:\\bltchar esc-char stream display-data)) ((il:ilessp c (il:charcode il:space)) (il:* il:|;;| "echo control chars as ^ followed by capital letter") (il:setq c (il:iplus c 64)) (il:\\bltchar (il:charcode il:^) stream display-data))) (il:\\bltchar c stream display-data) il:|finally| (and prin-2? (il:\\bltchar (il:charcode il:\") stream display-data)))) ) (shift-string (il:lambda (string from to length) (il:* il:\; "Edited 17-Jul-87 10:08 by DCB") (il:* il:|;;;| "ugly hack. shift the characters in a fat string left or right. move length characters, from from to to. if we're shifting right, we can use \\BLT, but otherwise have to move them ourselves (in the opposite order)") (il:setq string (il:\\addbase (il:fetch (il:stringp il:base) il:of string) (il:fetch (il:stringp il:offst) il:of string))) (il:setq from (il:sub1 from)) (il:setq to (il:sub1 to)) (cond ((il:ilessp from to) (il:\\blt (il:\\addbase string to) (il:\\addbase string from) length) nil) ((il:igreaterp from to) (il:to length il:do (il:\\putbase string to (il:\\getbase string from)) (il:setq from (il:add1 from)) (il:setq to (il:add1 to)))))) ) (stringwidth (il:lambda (str font prin-2? read-table) (il:* il:\; "Edited 17-Nov-87 09:25 by DCB") (il:* il:|;;;| "can take a readtable, but sedit under profile doesn't pass in readtable. will cause *readtable* to be used properly.") (if (il:stringp str) (il:for c il:instring (il:mkstring str) il:bind (length il:_ (if prin-2? (il:itimes 2 (il:charwidth (il:charcode il:\") font)) 0)) (escape il:_ (and prin-2? (escape-char read-table))) il:do (cond ((and prin-2? (or (eq c (il:charcode il:\")) (eq c escape))) (il:add length (il:charwidth escape font))) ((il:ilessp c (il:charcode il:space)) (il:add length (il:charwidth (il:charcode il:^) font)) (il:setq c (il:iplus c 64)))) (il:add length (il:charwidth c font)) il:finally (return length)) (il:stringwidth str font prin-2? read-table))) ) (ttyexitfn (il:lambda (oldproc newproc) (il:* il:\; "Edited 7-Jul-87 12:57 by DCB") (il:* il:\; "the TTY is being taken from an SEdit command process. restore the old caret") (and (il:setq newproc (il:processprop oldproc (quote il:window))) (il:setq newproc (il:windowprop newproc (quote edit-context))) (il:fetch open-node-changed? il:of newproc) (il:process.eval oldproc (list (quote close-node) newproc)))) ) ) (IL:PUTPROPS IL:SEDIT-TERMINAL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (1871 6597 (ATOM-CHAR-ESCAPED 1884 . 2392) (CHARCODE 2394 . 2536) (GETKEY 2538 . 3578 ) (PRINT-STRING 3580 . 4604) (SHIFT-STRING 4606 . 5376) (STRINGWIDTH 5378 . 6176) (TTYEXITFN 6178 . 6595))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-TEST.TEDIT b/sources/SEDIT-TEST.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..3cd401b8e9a2b01e9dc0d668e532f948fdd74ec7 GIT binary patch literal 2491 zcmZ`*U2ob*6s6TltF7eseZ0y`K_WDyo08;ZMZhGE_{f5ztg2mU2YbM7jE8#0rSzxm z&)8qI=Z>)hQPPLTvhUoFbIv`3FSQ{ZWbxY2LS-~_!`RR_ndw-iL<2d`a*=K6^tUFp zFU~uTGjm<)-E_y-_%j*%)5(wqlPUQ(E)Be)iwu3wcN}Nn{pt2EozAC=QyLw+G|!}X z)P$^QzM7)|KAoRZ&t%E*18rgx(ORZqoGvMpi8PWl{se~mD9$>a&dC{a-4xOCyFt7R zUy5sY5O-VF+(Z&pm5DfckyVDsc6PxtFQw767Qv%fN>U423L_Euv3-z_ zn-$3PHJ52%4^=arom>!And3t=vB*hx3UPaj^ z2~~+yi^xYhDfE^M%OnumrqF;fk;h+i1(J|BrGQD?pyWtAN;F9?aP!pq4b>x=tQ#mW zlPot|I8__cVoOK6nHPClkiS(qZA5D9a3WjgD+wf-xg*E9&C!@x7zybbV8;ww?3x4$ zMY<)>j*li@0hyfy07Iz)M)U(BOMFsAYZa%aY5C4II)9G z&{MHP9G1zIv|6{l?`aI>3Y|%+=B)I_z;D-p+R{c4po+HYo2^nUz#`7HL8rwmw|FYhwi2@P z>525cv0Ri!b95NRG*S18sD1j8dVL;I<;w`LXaYhz&e7)suemq&-RT{6c{YIC^}VUv z^Cwf!oncZStZ3{Ffu4Xctn(FXkBS}uQrwDxeIhP^|6yNBC)lwN<$4!pJq}fU09k3G zOlh40vSpV@RJw$sck0kvt#X5N%@(#qbHPjoYMI7Apk0h4Xt$^!9BtKYN_t;H8Z!-%Y6HVrHk zsvQDgt>79Pu{{*fp3GL<Pr_MHPuHW4I?W333AnWDbUDDb`I~6WsZ}H69{^j%UxQ13bm0x+4V;+xt5XnMrIC z6Nz#G{DQCaWD7z<#S{ZlAB(ZaGM@wl*6t4SSrbaFG4W|M^6V7TbkN5W4*P&TzX(?_ zxKfDtkx`m`A_Yjbim85ptRNzwm9Ka5f=`4>^0u{V{O_mQ+uESOURCES>SEDIT-TOPLEVEL.;5| 36139 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-TOPLEVELCOMS) (IL:FNS SEDITE) IL:|previous| IL:|date:| " 3-Apr-91 15:43:40" IL:|{PELE:MV:ENVOS}SOURCES>SEDIT-TOPLEVEL.;4|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-TOPLEVELCOMS) (IL:RPAQQ IL:SEDIT-TOPLEVELCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-TOPLEVEL) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-TOPLEVEL) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:INITVARS CONTEXTS REGIONS) (IL:VARS (IL:*DISPLAY-EDITOR* 'SEDIT)) (IL:FNS SEDIT RESET GET-WINDOW-REGION SAVE-WINDOW-REGION) (IL:FNS GET-CONTEXT DISINTEGRATE-CONTEXT AWAKE-COMMAND-PROCESS AWAKE-ME MARKASCHANGEDFN NEW-FUNCTION-BODY) (IL:FUNCTIONS QUERY-THROW-AWAY-CHANGES SET-OPTIONS SET-PROPS START-PROCESS) (IL:COMS (IL:* IL:|;;|  "THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)") (IL:PROP (IL:|Definition-for-EDITL| IL:|Definition-for-EDITE| IL:|Definition-for-EDITDATE|) SEDIT) (IL:FNS SEDITE SEDITL FN-CHANGED PROP-CHANGED PROPLST-CHANGED VAR-CHANGED ALIST-COMPLETION COMPLETION PROPS-COMPLETION TTYFN LOCATE-NODE-FROM-EDITCHAIN) (IL:* IL:|;;| "Mess around with the tty editor's TTY: command by defining a hook and then making TTY: a macro which calls the hook.") (IL:FUNCTIONS SMART-TTYFN) (IL:P (PUSHNEW '(IL:TTY\: NIL (IL:E (SMART-TTYFN) T)) IL:EDITMACROS :TEST #'IL:EQUAL))) (IL:FNS PRETTY-PRINT MAP-FONT) (IL:* IL:|;;| "these guys allow you to print and read structures with broken atoms and gaps. just a convenience for the loser who forgets to get them out of his code.") (IL:FUNCTIONS MAKE-BROKEN-ATOM PRINT-BROKEN-ATOM MAKE-GAP PRINT-GAP) (IL:P (IL:DEFPRINT 'BROKEN-ATOM 'PRINT-BROKEN-ATOM) (IL:DEFPRINT 'GAP 'PRINT-GAP)))) (IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "SEDIT" (:USE "LISP" "XCL")))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQ? CONTEXTS NIL) (IL:RPAQ? REGIONS NIL) (IL:RPAQQ IL:*DISPLAY-EDITOR* SEDIT) (IL:DEFINEQ (SEDIT (IL:LAMBDA (STRUCTURE PROPS OPTIONS) (IL:* IL:\; "Edited 25-Jan-91 13:51 by woz") (OR STRUCTURE (IL:SETQ STRUCTURE BASIC-GAP)) (LET* ((NAME (IL:LISTGET PROPS :NAME)) (TYPE (OR (IL:LISTGET PROPS :TYPE) :EXPRESSION)) (CONTEXT (GET-CONTEXT STRUCTURE NAME TYPE)) (WINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT))) (SET-PROPS CONTEXT PROPS) (SET-OPTIONS CONTEXT OPTIONS) (COND ((NULL WINDOW) (IL:* IL:|;;| "this is a new context, needs to be setup from scratch") (START-PROCESS CONTEXT NAME) CONTEXT) ((AND (IL:OPENWP WINDOW) (IL:PROCESSP (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (IL:* IL:|;;| "open and active") (IL:TOTOPW WINDOW) (WHEN (OR (NOT (EQ T (IL:|fetch| (EDIT-CONTEXT CHANGED-STRUCTURE?) IL:|of| CONTEXT))) (QUERY-THROW-AWAY-CHANGES NAME OPTIONS)) (IL:* IL:|;;| "there are no changes on this edit, or user said throw away changes, so we will restart this edit.") (IL:|replace| CHANGED-STRUCTURE? IL:|of| CONTEXT IL:|with| STRUCTURE) (IL:RESTART.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS)) CONTEXT)) ((IL:OPENWP (IL:WINDOWPROP WINDOW 'IL:ICONWINDOW)) (IL:* IL:|;;| "shrunk") (IL:|replace| CHANGED-STRUCTURE? IL:|of| CONTEXT IL:|with| STRUCTURE) (IL:EXPANDW WINDOW) CONTEXT) (T (IL:* IL:|;;| "found a dead context. get rid of it and try again.") (DISINTEGRATE-CONTEXT CONTEXT) (SEDIT STRUCTURE PROPS OPTIONS)))))) (reset (il:lambda nil (il:* il:\; "Edited 10-Jul-87 08:35 by DCB") (cond (contexts (il:error "Can't reset SEdit while there are open SEdit windows")) (t (create-environments) (reset-formats) t))) ) (get-window-region (il:lambda (context reason name type) (il:* il:\; "Edited 19-Nov-87 10:18 by DCB") (il:* il:|;;;| "called to get a region for this sedit window. should return the region for the sedit including the prompt window. context is being built and needs a window. the context will have at least the name (IconTitle) and type (EditType) of the object being edited, and can be used as desired to map between contexts and windows. If reason is :CREATE, then this function must return a region. If :EXPAND, then this algorithm returns a region from the stack only if SEDIT.KEEP.WINDOW.REGION is nil, otherwise it returns NIL, telling the window system not to reshape on expansion.") (when (or (eq reason :create) (not keep-window-region)) (or (il:pop regions) (progn (il:|printout| il:promptwindow t "Select region for SEdit window.") (il:getregion 30 20))))) ) (SAVE-WINDOW-REGION (IL:LAMBDA (CONTEXT REASON NAME TYPE REGION) (IL:* IL:\; "Edited 23-Nov-87 17:46 by DCB") (IL:* IL:|;;;| "Release this sedit windows region to be used again. If we're shrinking, KEEP-WINDOW-REGION determines whether to release the region or not. If an icon is being closed, don't release the region because it was handled appropriately when the window as shrunk. remember, we're maintaining regions including the prompt window height, so use WINDOWREGION to get the whole region.") (WHEN (OR (EQ REASON :CLOSE) (AND (EQ REASON :SHRINK) (NOT KEEP-WINDOW-REGION))) (IL:|push| REGIONS (OR REGION (IL:WINDOWREGION (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT))))))) ) (IL:DEFINEQ (GET-CONTEXT (IL:LAMBDA (STRUCTURE NAME TYPE SEARCH-ONLY?) (IL:* IL:\; "Edited 5-Dec-90 13:00 by woz") (IL:* IL:|;;;| "we've been asked to get the edit context for a new edit. if a context matching this description (same name and same type, or EQ structure) already exists, we'll return it rather than creating a new one. Also, if SEARCH-ONLY? is true then don't create a new one, just return NIL if not found.") (IL:|bind| WINDOW IL:|for| CONTEXT IL:|in| CONTEXTS IL:|when| (OR (AND NAME (EQUAL NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT)) (EQ TYPE (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT))) (AND STRUCTURE (IL:|type?| EDIT-NODE (IL:|fetch| ROOT IL:|of| CONTEXT)) (EQ STRUCTURE (IL:|fetch| STRUCTURE IL:|of| (SUBNODE 1 (IL:|fetch| ROOT IL:|of| CONTEXT)))))) IL:|do| (IL:* IL:|;;| "we found a context that matches, return it.") (RETURN CONTEXT) IL:|finally| (IL:* IL:|;;|  "this is a new editing task, so make an appropriate context and get it started") (IF SEARCH-ONLY? (RETURN NIL) (LET ((CONTEXT (IL:|create| EDIT-CONTEXT COMPLETION-EVENT IL:_ (IL:CREATE.EVENT (IL:CONCAT EDITOR-NAME NAME)) ROOT IL:_ STRUCTURE ICON-TITLE IL:_ NAME EDIT-TYPE IL:_ TYPE))) (PUSH CONTEXT CONTEXTS) (RETURN CONTEXT)))))) (DISINTEGRATE-CONTEXT (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 5-Dec-90 17:45 by woz") (IL:* IL:|;;;| "terminate this edit context. we mark it as dead, remove it from the active edits list, smash the connections between the context and the window") (WHEN CONTEXT (IL:NOTIFY.EVENT (IL:|fetch| COMPLETION-EVENT IL:|of| CONTEXT)) (IL:|replace| CONTEXT-LOCK IL:|of| CONTEXT IL:|with| 'DEAD) (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT) 'EDIT-CONTEXT NIL) (IL:|replace| DISPLAY-WINDOW IL:|of| CONTEXT IL:|with| NIL) (IL:SETQ CONTEXTS (IL:DREMOVE CONTEXT CONTEXTS))))) (AWAKE-COMMAND-PROCESS (IL:LAMBDA (CONTEXT COMMAND) (IL:* IL:\; "Edited 5-Dec-90 16:52 by woz") (IL:* IL:|;;| "if this context has a process associated with it, and the process is currently stuck waiting for input, unstick it so that it can look around and (presumably) notice some important change in its environment. This is also called when someone in another process, such as a command menu or a window menu operation, wants to tell the command process to execute the command. Note that under a few circumstances this function will be called by a running command in the sedit process. For example, the complete-and-close command calls il:closew which calls sedit's closefn which tries to wake up the sedit to let it know the window was closed. In this case, awake-command-porcess will result in a no-op because sedit has a command running, and therefore cannot be woken up. COMMAND is a command form which will be used as the value returned from GETKEY in SEDIT1. COMMAND should be of the form ( ), so that will be applied to the context, the charcode invokeing the command (NIL in this case), and the extra args. After the command runs the window will scroll to normalize the caret if is T. If COMMAND is NIL then the SEdit will just update the window.") (LET ((PROCESS (IL:WINDOWPROP (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT) 'IL:PROCESS))) (WHEN (IL:PROCESSP PROCESS) (IL:PROCESS.APPLY PROCESS 'AWAKE-ME (LIST COMMAND)))))) (awake-me (il:lambda (result) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (il:* il:|;;| "this rather ugly little function checks to see if it's being called under getkey (presumably by PROCESS.APPLY from awake.command.process) and if so forces the getkey to return result") (let ((stack-frame (il:stkpos (quote getkey)))) (when stack-frame (il:retfrom stack-frame result t)))) ) (MARKASCHANGEDFN (IL:LAMBDA (NAME TYPE REASON) (IL:* IL:\; "Edited 3-Apr-91 15:42 by jds") (IL:* IL:|;;;| "When a managed object is changed, we must check if we have an open edit on it. If so, calling SEdit again, with the fresh definition, will force the update. This is fairly tricky, though. Markaschanged is called as a result of editing a managed definition, so this markaschangedfn could be running in the sedit process under the completion-fn half way through completion. IDEALLY in this case we could say \"i know it changed, i just changed it!\" and ignore this call. BUT FOR NOW (1/14/91) since the manager can change the definition on completion (editdates, for one), we have to notify SEdit. Since calling editdef will restart the sedit process, the completion-fn will not finish, so do the verify-structure here.") (LET* ((FORM (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:FORM)) CONTEXT) (COND ((AND (EQ (CAR FORM) 'SEDIT1) (IL:|type?| EDIT-CONTEXT (SETQ CONTEXT (CADADR FORM))) (EQ NAME (IL:|fetch| ICON-TITLE IL:|of| CONTEXT)) (EQ TYPE (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT))) (IL:* IL:|;;| "we're running under the edit that is completing") (UNLESS *IGNORE-CHANGES-ON-COMPLETION* (VERIFY-STRUCTURE CONTEXT NIL (IL:GETDEF NAME TYPE NIL '(IL:EDIT IL:NOCOPY))))) ((GET-CONTEXT NIL NAME TYPE T) (IL:* IL:|;;| "found a matching context elsewhere") (IL:EDITDEF NAME TYPE NIL NIL '(:DONTWAIT))))))) (new-function-body (il:lambda (dummy-body) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (if (il:neq (il:editmode) (quote sedit)) (il:copy dummy-body) (list (quote il:lambda) args-gap body-gap))) ) ) (DEFUN QUERY-THROW-AWAY-CHANGES (NAME OPTIONS) (IL:* IL:|;;;| "this gets called when sedit is restarting because it got called again, but the structure doesn't match and changes have been made. should we throw away the changes and restart with the new structure, or not restart and keep the changes? ask the user.") (IF (IL:EQMEMB :DISPLAY OPTIONS) (IL:MENU (IL:|create| IL:MENU IL:ITEMS IL:_ '(("Throw away changes and restart with new structure" T) ("Keep changes and don't restart with new structure" NIL)) IL:TITLE IL:_ (FORMAT NIL "An edit session with changes already exists for ~S" NAME))) (IF (EQ 'IL:Y (IL:ASKUSER NIL NIL (FORMAT NIL "An edit session with changes already exists for ~S. Throw away changes and restart with new structure? " NAME))) T))) (DEFUN SET-OPTIONS (CONTEXT OPTIONS) (IL:* IL:|;;;| "set up the OPTIONS provided in the call to SEDIT for this context. Most of these options do not require immediate action. Rather, they control how some command or interaction will work later, so we just store the option list in the context. Most of these options are really edit-interface options, not sedit options. We stash them so that when the *edit-fn* is called under M-O, it will be handed the same options that this edit was started with") (IL:REPLACE (EDIT-CONTEXT EDIT-OPTIONS) IL:OF CONTEXT IL:WITH (IF (LISTP OPTIONS) OPTIONS (LIST OPTIONS)))) (DEFUN SET-PROPS (CONTEXT PROPS) (IL:* IL:|;;;| "go through the PROPS list supplied in the call to SEDIT and store the info in the context. The :NAME and :TYPE props are already handled, because get-context uses this information to find an appropriate context. Grab the current values of the variables that determine reading and printing, and save them in a profile in the context, so that later changes to the globals don't affect existing contexts. ") (IL:REPLACE (EDIT-CONTEXT COMPLETION-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :COMPLETION-FN ) #'NULL)) (IL:REPLACE (EDIT-CONTEXT ROOT-CHANGED-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :ROOT-CHANGED-FN ) #'NULL)) (IL:REPLACE (EDIT-CONTEXT ENVIRONMENT) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :ENVIRONMENT) LISP-EDIT-ENVIRONMENT )) (IL:REPLACE (EDIT-CONTEXT PROFILE) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :PROFILE) (SAVE-PROFILE (COPY-PROFILE "READ-PRINT")))) (IL:REPLACE (EDIT-CONTEXT EVAL-IN-PROCESS) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :EVAL-IN-PROCESS ) (EVAL-IN-PROCESS) )) (IL:REPLACE (EDIT-CONTEXT EVAL-FN) IL:OF CONTEXT IL:WITH (OR (IL:LISTGET PROPS :EVAL-FN) (XCL::PROFILE-ENTRY-VALUE '*EVAL-FUNCTION*))) (WHEN (IL:LISTGET PROPS :SELECT-STRUCTURE) (IL:REPLACE (EDIT-CONTEXT FIND-CANDIDATE) IL:OF CONTEXT IL:WITH (CONS (IL:LISTGET PROPS :SELECT-STRUCTURE) (OR (IL:LISTGET PROPS :SELECT-INSTANCE) 1))))) (DEFUN START-PROCESS (CONTEXT) (IL:* IL:|;;;| "the context is ready. start the sedit process. the rest of the initialization will happen in the sedit process, and the completion-event will be notified (by SEDIT1) when the sedit is initialized.") (LET ((NAME (IL:FETCH (EDIT-CONTEXT ICON-TITLE) IL:OF CONTEXT)) (EVENT (IL:|fetch| (EDIT-CONTEXT COMPLETION-EVENT) IL:|of| CONTEXT))) (IL:ADD.PROCESS (LIST 'SEDIT1 (IL:KWOTE CONTEXT)) 'IL:NAME (IF NAME (IL:CONCAT EDITOR-NAME " " NAME) EDITOR-NAME)) (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT))))) (IL:* IL:|;;| "THESE CAN ALL BE NUKED WITH THE NEW EDIT INTERFACE AND A DETACHED TTY/EDITOR (WOZ 1/25/91)") (IL:PUTPROPS SEDIT IL:|Definition-for-EDITL| SEDITL) (IL:PUTPROPS SEDIT IL:|Definition-for-EDITE| SEDITE) (IL:PUTPROPS SEDIT IL:|Definition-for-EDITDATE| IL:TTY/EDITDATE) (IL:DEFINEQ (SEDITE (IL:LAMBDA (EXPR COMS ATOM TYPE IFCHANGEDFN OPTIONS) (IL:* IL:\; "Edited 10-Jul-91 19:04 by jds") (IL:* IL:|;;;| "Convert call to EDITE into sedit format (structure props options). The completion-fn is determined based on TYPE, since the file manager isn't very consistent about IL:PROPLST and IL:ALIST. Since EDITE is supposed to wait for completion, create a completion event which is notified by the completion-fn. Also, if the top cons is changed, try to smash the completed structure into EXPR to provide eqness.") (IL:* IL:|;;;| "IDEALLY: this whole mess wouldn't exist- if il:putdef could handle il:proplst, etc, then completion could simply call putdef, not special case as it does here.") (LET* ((EVENT (IL:CREATE.EVENT "SEDITE Completion")) (NEW-EXPR) (COMPLETION-FN (OR (AND IL:FILEPKGFLG (IL:SELECTQ TYPE (IL:PROPLST (LET ((OLD-PROPS (IL:APPEND (IL:GETPROPLIST ATOM)))) #'(LAMBDA (CONTEXT STRUCTURE CHANGED?) (FUNCALL #'PROPS-COMPLETION CONTEXT STRUCTURE CHANGED? ATOM IFCHANGEDFN OLD-PROPS) (SETQ NEW-EXPR STRUCTURE) (IL:NOTIFY.EVENT EVENT)))) (IL:VARS (WHEN (IL:EQMEMB 'IL:ALIST (IL:GETPROP ATOM 'IL:VARTYPE)) (LET ((OLD-VAL (IL:MAPCAR (IL:FUNCTION CAR) (IL:EVALV ATOM)))) #'(LAMBDA (CONTEXT STRUCTURE CHANGED?) (FUNCALL #'ALIST-COMPLETION CONTEXT STRUCTURE CHANGED? ATOM IFCHANGEDFN OLD-VAL) (SETQ NEW-EXPR STRUCTURE) (IL:NOTIFY.EVENT EVENT))))) NIL)) (AND ATOM TYPE #'(LAMBDA (CONTEXT STRUCTURE CHANGED?) (FUNCALL #'COMPLETION CONTEXT STRUCTURE CHANGED? ATOM TYPE IFCHANGEDFN) (SETQ NEW-EXPR STRUCTURE) (IL:NOTIFY.EVENT EVENT))) #'(LAMBDA (CONTEXT STRUCTURE CHANGED?) (SETQ NEW-EXPR STRUCTURE) (IL:NOTIFY.EVENT EVENT)))) (ROOT-CHANGED-FN (IL:SELECTQ TYPE (IL:PROPLST (LIST (IL:FUNCTION PROPLST-CHANGED) ATOM)) (IL:VARS (LIST (IL:FUNCTION VAR-CHANGED) ATOM)) (IL:FNS (LIST (IL:FUNCTION FN-CHANGED) ATOM)) NIL))) (COND (COMS (IL:TTY/EDITE EXPR COMS ATOM TYPE IFCHANGEDFN OPTIONS)) (T (WHEN (AND IL:FILEPKGFLG (OR IL:CLISPARRAY (PROGN (IL:CLISPTRAN (CONS) (CONS)) IL:CLISPARRAY))) (IL:SELECTQ TYPE (IL:PROPLST (IL:|for| X IL:|in| (IL:GETPROPLIST ATOM) IL:|unless| (OR (IL:NLISTP X) (IL:GETHASH X IL:CLISPARRAY)) IL:|do| (IL:PUTHASH X (CONS (CAR X) (CDR X)) IL:CLISPARRAY))) (IL:VARS (WHEN (IL:EQMEMB 'IL:ALIST (IL:GETPROP ATOM 'IL:VARTYPE)) (IL:|for| X IL:|in| (IL:EVALV ATOM) IL:|unless| (OR (IL:NLISTP X) (IL:GETHASH X IL:CLISPARRAY)) IL:|do| (IL:PUTHASH X (CONS (CAR X) (CDR X)) IL:CLISPARRAY)))) NIL)) (SEDIT EXPR (LIST :NAME ATOM :TYPE TYPE :COMPLETION-FN COMPLETION-FN :ROOT-CHANGED-FN ROOT-CHANGED-FN) OPTIONS) (UNLESS (IL:EQMEMB :DONTWAIT OPTIONS) (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT)))) (IL:* IL:|;;| "EDITE is for side effects (but we return the correct structure anyway. If the user replaced the top cons, smash the new structure into it. Have to copy the new structure in this case because, if the user wrapped the top cons, smashing into it will result in a circular list. Additionally, if there is an sedit root-changed-fn, assume the caller handled the root change then, and eqness is not necessary.") (IF (OR (EQ NEW-EXPR EXPR) ROOT-CHANGED-FN (NOT (CONSP EXPR)) (NOT (CONSP NEW-EXPR))) NEW-EXPR (IL:RPLNODE2 EXPR (COPY-TREE NEW-EXPR)))))))) (SEDITL (IL:LAMBDA (EDITEXPR EDITCOMS ATOM MESSAGE EDITCHANGES) (IL:* IL:\; "Edited 25-Jan-91 13:45 by woz") (DECLARE (SPECIAL TYPE)) (IL:* IL:|;;;| "this is SEdit's definition for EDITL. if there are no COMS (normal case) we start an interactive SEdit. otherwise, we run the TTY editor to execute the coms, and arrange to start an SEdit if it stops for input.") (COND (EDITCOMS (IL:* IL:|;;| "used to push stuff on il:editmacros, now we bind il:ttyeditfn") (IL:* IL:|;;| "(il:resetvar il:editmacros (cons '(il:tty\\: nil (il:e (ttyfn il:atm type) t)) il:editmacros) (il:tty/editl editexpr editcoms atom message editchanges))") (LET ((IL:TTYEDITFN #'(LAMBDA NIL (TTYFN ATOM TYPE)))) (DECLARE (SPECIAL IL:TTYEDITFN)) (IL:TTY/EDITL EDITEXPR EDITCOMS ATOM MESSAGE EDITCHANGES))) (T (SEDIT (CAR EDITEXPR) (LIST :NAME ATOM :TYPE (AND (BOUNDP 'TYPE) TYPE))) EDITEXPR)))) (fn-changed (il:lambda (structure atom) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (cond ((not (il:ccodep (il:getd atom))) (il:putd atom structure)) ((il:listp (il:getprop atom (quote il:expr))) (il:putprop atom (quote il:expr) structure)) (t (il:shouldnt "where did this come from?")))) ) (prop-changed (il:lambda (structure atom) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (il:putprop atom (quote il:expr) structure)) ) (proplst-changed (il:lambda (structure atom) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (il:setproplist atom structure)) ) (var-changed (il:lambda (structure atom) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (set atom structure))) (alist-completion (il:lambda (context structure changed? atom ifchangedfn old-keys) (il:* il:\; "Edited 18-Jan-88 15:43 by woz") (when (eq changed? t) (il:* il:|;;| "don't do anything if changed is NIL or :ABORT ") (let (found-change old-value) (il:for x il:in old-keys il:unless (il:assoc x structure) il:do (il:markaschanged (list atom x) (quote il:alists) nil) (il:setq found-change t)) (il:for x il:in structure il:when (and (il:listp x) (not (and il:clisparray (il:setq old-value (il:gethash x il:clisparray)) (eq (car x) (car old-value)) (eq (cdr x) (cdr old-value))))) il:do (il:puthash x nil il:clisparray) (il:markaschanged (list atom (car x)) (quote il:alists) nil) (il:setq found-change t)) (when (not found-change) (completion context structure changed? atom (quote il:alists) ifchangedfn))))) ) (completion (il:lambda (context structure changed? atom type ifchangedfn) (il:* il:\; "Edited 18-Jan-88 15:40 by woz") (cond ((or (not changed?) (eq changed? :abort))) ((eq type (quote il:fns)) (il:fixeditdate structure) (il:putdef atom type structure) (il:* il:|;;| "(if (CCODEP (GETD atom)) then (if (NEQ structure (GETPROP atom (QUOTE EXPR))) then (SHOULDNT 'where did this come from?') else (if (OR (EQ DFNFLG (QUOTE PROP)) (EQ DFNFLG (QUOTE ALLPROP))) then (SETQ message ' NOT unsaved.') else (UNSAVEDEF atom) (SETQ message ' unsaved.')) (if (OPENWP (fetch DisplayWindow of context)) then (printout (get.prompt.window context) atom message) else (* ; 'window was closed. msg in promptwindow.') (printout PROMPTWINDOW T atom message))) else (if (NEQ structure (GETD atom)) then (if (NULL (GETD atom)) then (PUTD atom structure) else (SHOULDNT 'where did this come from?'))))")) (ifchangedfn (il:* il:|;;| "this is a bit wrong: the doc for edite says the ifchangedfn gets called with the last arg NIL if the editor is aborted. But we don't call the ifchangedfn at all if the user did an abort command. The idea is that ABORT is implemented as \"don't install even if changes we're made\"") (funcall ifchangedfn atom structure type t)) ((il:neq type (quote il:proplst)) (il:markaschanged atom type))) (when (and (il:litatom atom) il:addspellflg) (il:addspell atom))) ) (props-completion (il:lambda (context structure changed? atom ifchangedfn oldprops) (il:* il:\; "Edited 20-Apr-88 11:39 by woz") (when (eq changed? t) (il:* il:|;;| "don't do anything if changed? is NIL or :ABORT") (il:bind old-value found-one il:for new-prop il:on (il:getproplist atom) il:by (cddr new-prop) il:unless (il:for old-prop il:on oldprops il:by (cddr old-prop) il:when (eq (car old-prop) (car new-prop)) il:do (return (and (eq (cadr old-prop) (cadr new-prop)) (or (il:nlistp (cadr old-prop)) (and il:clisparray (il:setq old-value (il:gethash (cadr new-prop) il:clisparray)) (eq (caadr new-prop) (car old-value)) (eq (cdadr new-prop) (cdr old-value)) (or (il:puthash (cadr new-prop) nil il:clisparray) t)))))) il:do (il:markaschanged (list atom (car new-prop)) (quote il:props) nil) (il:setq found-one t)))) ) (TTYFN (IL:LAMBDA (ATM TYPE) (IL:* IL:\; "Edited 21-Jan-91 12:02 by woz") (DECLARE (SPECIAL IL:L IL:EDITCHANGES)) (IL:* IL:|;;| "this is a replacement for the TTY editor's TTY: command, which starts an SEdit process to do interactive editing for a while. it uses the TTY editor's edit chain to determine the initial selection in the structure, and scrolls the window to make sure the selection's visible. it then waits until the user signals that they've done enough editing (usually by closing or shrinking the window)") (LET* ((EDIT-CHANGES IL:EDITCHANGES) (EVENT (IL:CREATE.EVENT "SEdit TTYFN Completion")) (COMPLETION-FN #'(LAMBDA (CONTEXT STRUCTURE CHANGED?) (WHEN (EQ CHANGED? T) (RPLACA (CDR EDIT-CHANGES) T)) (IL:NOTIFY.EVENT EVENT))) (CONTEXT (SEDIT (CAR (LAST IL:L)) (LIST :NAME ATM :TYPE TYPE :COMPLETION-FN COMPLETION-FN))) NODE) (IL:WITH.MONITOR (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) (WHEN (IL:SETQ NODE (LOCATE-NODE-FROM-EDITCHAIN IL:L (IL:|fetch| ROOT IL:|of| CONTEXT))) (SELECTION-DOWN CONTEXT) (SELECT-NODE CONTEXT NODE) (SET-POINT-NOWHERE (IL:|fetch| CARET-POINT IL:|of| CONTEXT)) (NORMALIZE-SELECTION CONTEXT) (SELECTION-UP CONTEXT))) (IL:* IL:|;;| "let the user do their editing, then signal completion, before we return") (IL:|until| (EQ EVENT (IL:AWAIT.EVENT EVENT)))))) (locate-node-from-editchain (il:lambda (chain root) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "when SEdit is called under the TTY editor, it gets an edit chain to determine the initial selection. this process finds the node that editchain refers to (or returns NIL if no such node exists)") (if (null chain) root (il:for subnode il:in (cdr (il:fetch sub-nodes il:of (locate-node-from-editchain (cdr chain) root))) il:thereis (eq (il:fetch structure il:of subnode) (car chain))))) ) ) (IL:* IL:|;;| "Mess around with the tty editor's TTY: command by defining a hook and then making TTY: a macro which calls the hook." ) (DEFUN SMART-TTYFN () (IL:* IL:|;;;| "This is a replacement for the TTY editor's TTY: command, which is supposed to start up a TTY editor. We first check to see if we're ") (DECLARE (SPECIAL IL:L IL:TTYEDITFN)) (IF (AND (BOUNDP 'IL:TTYEDITFN) IL:TTYEDITFN) (FUNCALL IL:TTYEDITFN) (IL:EDITL0 IL:L NIL 'IL:TTY\: 'IL:TTY\:))) (PUSHNEW '(IL:TTY\: NIL (IL:E (SMART-TTYFN) T)) IL:EDITMACROS :TEST #'IL:EQUAL) (IL:DEFINEQ (pretty-print (il:lambda (structure stream right-margin) (il:* il:\; "Edited 7-Jul-87 12:59 by DCB") (il:* il:|;;;| "with just a little hacking, SEdit can be used to prettyprint functions onto TEdit streams. we make up a slightly weird context, and run the parser and linearizer each once. stream is actually the textobj of the tedit stream. note that right.margin is in micas (since that's the unit that interpress font widths are expressed in)") (or (boundp (quote pretty-print-env)) (create-pretty-print-env)) (let ((context (il:create edit-context display-window il:_ stream environment il:_ pretty-print-env current-x il:_ 0 comment-width il:_ (il:fixr (il:times 200 il:micasperpt)) comment-separation il:_ (il:fixr (il:times 30 il:micasperpt)))) (root (il:create edit-node node-type il:_ type-root sub-nodes il:_ (list 0) start-x il:_ 0 depth il:_ 0))) (il:replace current-node il:of context il:with root) (parse structure context) (compute-all-formats context nil) (linearize (subnode 1 root) context (il:fixr right-margin)))) ) (map-font (il:lambda (font env) (il:* il:\; "Edited 17-Nov-87 10:43 by DCB") (il:* il:|;;| "this is called when using the prettyprint environment, under output.string. we have to map the font into something acceptable to TEDIT.INSERT (since interpress fonts confuse it)") (cond ((eq font (il:fetch default-font il:of env)) il:defaultfont) ((eq font (il:fetch keyword-font il:of env)) il:clispfont) ((eq font (il:fetch italic-font il:of env)) il:italicfont) ((eq font (il:fetch comment-font il:of env)) il:commentfont) ((eq font (il:fetch broken-atom-font il:of env)) il:boldfont) (t (il:shouldnt "unexpected font!")))) ) ) (IL:* IL:|;;| "these guys allow you to print and read structures with broken atoms and gaps. just a convenience for the loser who forgets to get them out of his code." ) (DEFUN MAKE-BROKEN-ATOM (STRING) (IL:|create| BROKEN-ATOM ATOM-CHARS IL:_ STRING)) (DEFUN PRINT-BROKEN-ATOM (BROKEN-ATOM STREAM X) (FORMAT STREAM "#.(~S ~S)" 'MAKE-BROKEN-ATOM (IL:|fetch| ATOM-CHARS IL:|of| BROKEN-ATOM)) T) (DEFUN MAKE-GAP (ITEM) (IL:|create| GAP LINEAR-ITEM IL:_ ITEM)) (DEFUN PRINT-GAP (GAP STREAM X) (FORMAT STREAM "#.(~S '~S)" 'MAKE-GAP (IL:|fetch| LINEAR-ITEM IL:|of| GAP)) T) (IL:DEFPRINT 'BROKEN-ATOM 'PRINT-BROKEN-ATOM) (IL:DEFPRINT 'GAP 'PRINT-GAP) (IL:PUTPROPS IL:SEDIT-TOPLEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (3202 7114 (SEDIT 3215 . 5201) (RESET 5203 . 5404) (GET-WINDOW-REGION 5406 . 6283) ( SAVE-WINDOW-REGION 6285 . 7112)) (7115 13776 (GET-CONTEXT 7128 . 9148) (DISINTEGRATE-CONTEXT 9150 . 9876) (AWAKE-COMMAND-PROCESS 9878 . 11471) (AWAKE-ME 11473 . 11856) (MARKASCHANGEDFN 11858 . 13572) ( NEW-FUNCTION-BODY 13574 . 13774)) (19971 32948 (SEDITE 19984 . 25751) (SEDITL 25753 . 26898) ( FN-CHANGED 26900 . 27195) (PROP-CHANGED 27197 . 27334) (PROPLST-CHANGED 27336 . 27464) (VAR-CHANGED 27466 . 27578) (ALIST-COMPLETION 27580 . 28391) (COMPLETION 28393 . 29773) (PROPS-COMPLETION 29775 . 30600) (TTYFN 30602 . 32440) (LOCATE-NODE-FROM-EDITCHAIN 32442 . 32946)) (33586 35271 (PRETTY-PRINT 33599 . 34642) (MAP-FONT 34644 . 35269))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT-WINDOW b/sources/SEDIT-WINDOW new file mode 100644 index 00000000..8e201570 --- /dev/null +++ b/sources/SEDIT-WINDOW @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "14-May-2018 14:12:02"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.;2| 84658 IL:|changes| IL:|to:| (IL:FNS BUTTONEVENTFN) IL:|previous| IL:|date:| " 2-Apr-92 11:08:50" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>SEDIT-WINDOW.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 2018 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SEDIT-WINDOWCOMS) (IL:RPAQQ IL:SEDIT-WINDOWCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-WINDOW) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-WINDOW) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:BITMAPS ICON ICON-MASK) (IL:VARS ICON-TITLE-REGION (TITLED-ICON (IL:CREATE IL:TITLEDICON IL:ICON IL:_ ICON IL:MASK IL:_ ICON-MASK IL:TITLEREG IL:_ ICON-TITLE-REGION)) (KEEP-WINDOW-REGION T)) (IL:DECLARE\: IL:DONTCOPY (IL:MACROS IN-TITLE-BAR TRACK-BAR-IN-TRACK-SELECT)) (IL:FUNCTIONS SELECT-NODE-SEGMENT) (IL:FNS BUILD-WINDOW BUTTONEVENTFN CHECK-SELECTION CHECK-SELECTION-SHIFT CLOSEFN CONFLICTING-SELECTION? DISPLAY-SELECTION DRAW-HIGHLIGHT DRAW-OUTLINE DRAW-UNDERLINE EXPANDFN EXPANDREGIONFN EXTEND-SELECTION FINALIZE-MOUSE-SELECTION FIND-LINE-START FIND-NODE GET-DESTINATION-CONTEXT GRAY GROW-CLICK? GROW-SELECTION GROW-SELECTION-DEFAULT HIGHLIGHT-SELECTION ICON-COPYFN LESS-PROMPT-WINDOW NORMALIZE-SELECTION OUTLINE-SELECTION PENDING-DELETE PLACE-CARET-AND-SELECTION PUNT-SET-POINT PUNT-SET-SELECTION REPAINTFN RESHAPEFN SCAN-FOR-BOUNDS SELECT-NODE SELECT-SEGMENT SELECT-SEGMENT-DEFAULT SELECTION-DOWN SELECTION-UP SET-POINT SET-POINT-NOWHERE SET-POINT-UNKNOWN SET-SELECTION SET-SELECTION-ME SET-SELECTION-NOWHERE SHIFT-DOWN SHOW-CARET SHRINKFN STRING-OFFSET TRACK-EXTEND TRACK-SELECT UNDERLINE-SELECTION UPDATE-TITLE))) (IL:PUTPROPS IL:SEDIT-WINDOW IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-WINDOW IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL)))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQQ ICON #*(140 60)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MH@@LAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LL@@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LF@@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LAH@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@L@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOO@LFAKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LCAKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FMHFC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FMHLC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@ ) (IL:RPAQQ ICON-MASK #*(140 60)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@ ) (IL:RPAQQ ICON-TITLE-REGION (5 16 130 24)) (IL:RPAQ TITLED-ICON (IL:CREATE IL:TITLEDICON IL:ICON IL:_ ICON IL:MASK IL:_ ICON-MASK IL:TITLEREG IL:_ ICON-TITLE-REGION)) (IL:RPAQQ KEEP-WINDOW-REGION T) (IL:DECLARE\: IL:DONTCOPY (IL:DECLARE\: IL:EVAL@COMPILE (IL:PUTPROPS IN-TITLE-BAR IL:MACRO ((WINDOW) (NOT (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW) (IL:LASTMOUSEX WINDOW) (IL:LASTMOUSEY WINDOW))))) (IL:PUTPROPS TRACK-BAR-IN-TRACK-SELECT IL:MACRO (NIL (WHEN (OR (IL:NEQ POINT? (IL:|fetch| POINT-TYPE IL:|of| PENDING-CARET)) (IL:NEQ BAR-X (IL:|fetch| POINT-X IL:|of| PENDING-CARET)) (IL:NEQ BAR-LINE (IL:|fetch| POINT-LINE IL:|of| PENDING-CARET))) (WHEN POINT? (IL:BLTSHADE IL:BLACKSHADE WINDOW BAR-X BAR-Y 1 BAR-HEIGHT 'IL:INVERT)) (WHEN (IL:SETQ POINT? (IL:|fetch| POINT-TYPE IL:|of| PENDING-CARET)) (IL:SETQ BAR-X (IL:|fetch| POINT-X IL:|of| PENDING-CARET)) (IL:SETQ BAR-LINE (IL:|fetch| POINT-LINE IL:|of| PENDING-CARET)) (IL:SETQ BAR-HEIGHT (IL:IPLUS (IL:|fetch| LINE-ASCENT IL:|of| BAR-LINE) (IL:|fetch| LINE-DESCENT IL:|of| BAR-LINE))) (IL:SETQ BAR-Y (IL:IDIFFERENCE (IL:|fetch| YCOORD IL:|of| BAR-LINE) (IL:IPLUS (IL:|fetch| LINE-SKIP IL:|of| BAR-LINE) BAR-HEIGHT))) (IL:BLTSHADE IL:BLACKSHADE WINDOW BAR-X BAR-Y 1 BAR-HEIGHT 'IL:INVERT))))) ) ) (DEFUN SELECT-NODE-SEGMENT (CONTEXT NODE &OPTIONAL (START 1) END) (IL:* IL:|;;;| "set the current selection to be a segment under this node") (LET ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))) (IL:|replace| SELECT-NODE IL:|of| SELECTION IL:|with| NODE) (IL:|replace| SELECT-START IL:|of| SELECTION IL:|with| START) (IL:|replace| SELECT-END IL:|of| SELECTION IL:|with| END) (SELECT-SEGMENT SELECTION CONTEXT NODE) (IL:* IL:|;;| "set point to be the selection. This should really be done by select-segment but it doesn't because it expects finalization code to be run after it cause it's generally called from the mouse tracking code which finalizes.") (PENDING-DELETE POINT SELECTION))) (IL:DEFINEQ (BUILD-WINDOW (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 2-Apr-92 10:59 by jds") (IL:* IL:|;;;| "create a new window to edit in. called from setup.new.context when an sedit is started. ") (LET ((ENVIRONMENT (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) (DISPLAY-WINDOW (IL:CREATEW (LESS-PROMPT-WINDOW (GET-WINDOW-REGION CONTEXT :CREATE (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)) IL:DEFAULTFONT) (IL:CONCAT EDITOR-NAME " parsing " (OR (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) ""))))) (IL:WINDOWPROP DISPLAY-WINDOW 'EDIT-CONTEXT CONTEXT) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SCROLLEXTENTUSE '(- . +)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:WINDOWENTRYFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:BUTTONEVENTFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:RIGHTBUTTONFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:EXPANDREGIONFN (IL:FUNCTION EXPANDREGIONFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:CLOSEFN (IL:FUNCTION CLOSEFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SHRINKFN (IL:FUNCTION SHRINKFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:EXPANDFN (IL:FUNCTION EXPANDFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:RESHAPEFN (IL:FUNCTION RESHAPEFN)) (IL:* IL:|;;|  "get the prompt window after setting up all the window fn, so the'll be in the proper order") (IL:GETPROMPTWINDOW DISPLAY-WINDOW 1 IL:DEFAULTFONT) (IL:|replace| DISPLAY-WINDOW IL:|of| CONTEXT IL:|with| DISPLAY-WINDOW) (IL:WYOFFSET (IL:SUB1 (IL:WINDOWPROP DISPLAY-WINDOW 'IL:HEIGHT)) DISPLAY-WINDOW) (IL:* IL:|;;| "These window fns go AFTER the promptwindow setup, so we don't try to repaint the window in the course of adding the prompt window. This fixes AR 11376") (IL:WINDOWPROP DISPLAY-WINDOW 'IL:REPAINTFN (IL:FUNCTION REPAINTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SCROLLFN (IL:FUNCTION IL:SCROLLBYREPAINTFN)) (IL:|replace| WINDOW-LEFT IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:|replace| WINDOW-BOTTOM IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| (IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW))) (IL:|replace| WINDOW-RIGHT IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:RIGHT) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:|replace| WINDOW-TOP IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:TOP) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:DSPLINEFEED (IL:IMINUS (IL:IPLUS (IL:FONTPROP (IL:|fetch| DEFAULT-FONT IL:|of| ENVIRONMENT) 'IL:HEIGHT) (IL:|fetch| DEFAULT-LINE-SKIP IL:|of| ENVIRONMENT) )) DISPLAY-WINDOW) (IL:* IL:|;;| "set the window's right margin big enough that things won't be wrapped on us. this is sort of gross -- there should be a way to completely disable wrap") (IL:DSPRIGHTMARGIN 64000 DISPLAY-WINDOW)))) (BUTTONEVENTFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 23-Apr-2018 09:37 by rmk:") (IL:* IL:|;;| "called by the window system whenever the user hits a mouse button in an SEdit window. allows selection and setting the caret point") (LET* ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT)) (LOCK (AND CONTEXT (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))) (SHIFT-DOWN (SHIFT-DOWN))) (COND ((IL:LASTMOUSESTATE IL:UP) (IL:* IL:|;;| "oops, no mouse buttons down. what are we doing here?") NIL) ((NOT (AND CONTEXT (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (IL:* IL:|;;| "this context or process is dead. make it a dead SEdit.") (IL:|printout| (IL:GETPROMPTWINDOW WINDOW) T "This SEdit is dead.") (IL:WINDOWPROP WINDOW 'IL:REPAINTFN NIL) (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'IL:DON\'T) (IL:WINDOWPROP WINDOW 'IL:SHRINKFN 'IL:DON\'T) (AND (IL:LASTMOUSESTATE IL:RIGHT) (IL:DOWINDOWCOM WINDOW))) ((AND (IL:LASTMOUSESTATE IL:RIGHT) (IN-TITLE-BAR WINDOW)) (IL:* IL:|;;| "right buttoning the title bar or window border gives the default menu of window commands. Not interlocked because want to be able to move window under a break that has the lock.") (IL:\\CARET.DOWN) (IL:DOWINDOWCOM WINDOW)) ((AND (NOT (IL:TTY.PROCESSP (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (NOT SHIFT-DOWN)) (IL:* IL:|;;| "just grab the tty and don't change state") (IL:TOTOPW WINDOW) (IL:TTY.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))) ((OR (EQ SHIFT-DOWN 'COPY) (IL:OBTAIN.MONITORLOCK LOCK T)) (IL:* IL:|;;| "at this point we must have the lock, unless we're shift selecting (Copy only: Move and Delete are non-passive operation and must lock)") (IL:\\CARET.DOWN) (IL:TOTOPW WINDOW) (COND ((AND (IN-TITLE-BAR WINDOW) (OR (IL:LASTMOUSESTATE IL:MIDDLE) (AND (IL:LASTMOUSESTATE IL:LEFT) (IL:KEYDOWNP 'IL:CTRL)))) (IL:* IL:|;;| "popup help command menu here.") (IL:* IL:|;;| "RMK: CTRL-LEFT = MIDDLE") (HELPMENU CONTEXT)) (T (WITH-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT) (PROG NIL (CLOSE-OPEN-NODE CONTEXT) (IL:* IL:|;;| "record that we're busy making a selection in this window, and make sure that variables we use for recording our temporary state are all ready for action. note that these are global vars, and hence all this code is nonrentrant. shouldn't be a problem, since there's only one mouse") (IL:SETQ SELECTION-PENDING? CONTEXT) (IL:SETQ PENDING-LAST-X (IL:|fetch| LAST-MOUSE-X IL:|of| CONTEXT)) (IL:SETQ PENDING-LAST-Y (IL:|fetch| LAST-MOUSE-Y IL:|of| CONTEXT)) (IL:SETQ PENDING-TYPE (IL:|fetch| LAST-MOUSE-TYPE IL:|of| CONTEXT)) (IL:SETQ PENDING-SHIFT SHIFT-DOWN) (IL:|replace| SELECT-NODE IL:|of| PENDING-SELECTION IL:|with| NIL) (WHEN (NOT PENDING-SHIFT) (IL:* IL:|;;|  "if they're setting a new selection take down the main selection") (SELECTION-DOWN CONTEXT)) (IL:SETQ LAST-MOVE-CLOCK NIL) (IL:SETQ BUTTON-STRING-NODE NIL) MOUSE-BUTTON-DOWN (IF (IL:LASTMOUSESTATE IL:RIGHT) (TRACK-EXTEND CONTEXT WINDOW) (TRACK-SELECT CONTEXT WINDOW)) (IL:|until| (CHECK-SELECTION-SHIFT CONTEXT T) IL:|do| (WHEN (NOT (IL:MOUSESTATE IL:UP)) (GO MOUSE-BUTTON-DOWN)) (WHEN (IL:IN/SCROLL/BAR? WINDOW IL:LASTMOUSEX IL:LASTMOUSEY ) (IL:* IL:\;  "let them scroll while making a selection") (IL:SCROLL.HANDLER WINDOW)) (IL:BLOCK)) (IL:SETQ SELECTION-PENDING? NIL) (IL:* IL:\;  "figure out what we should do") (FINALIZE-MOUSE-SELECTION CONTEXT WINDOW))))) (OR (EQ SHIFT-DOWN 'COPY) (IL:RELEASE.MONITORLOCK LOCK))))))) (check-selection (il:lambda (selection point) (il:* il:\; "Edited 27-Jun-88 15:47 by woz") (il:* il:|;;;| "called from update each time through. check the selection for dead node, and for pending delete inconsistency.") (let ((node (il:|fetch| select-node il:|of| selection)) (start (il:|fetch| select-start il:|of| selection)) (end (il:|fetch| select-end il:|of| selection)) subnode) (when (and node (dead-node? node)) (il:replace select-node il:of selection il:with nil)) (cond ((eq (il:|fetch| point-node il:|of| point) selection) (cond ((null node) (il:replace point-node il:of point il:with nil)) ((not (il:fetch pending-delete? il:of selection)) (il:shouldnt "pending delete inconsistency")))) ((and node (il:|fetch| pending-delete? il:|of| selection)) (il:shouldnt "pending delete inconsistency"))) (il:* il:|;;| "try to simplify the selection. if it's a single node structure segment (single subnode selected), select the subnode directly instead.") (when (and node (eq (il:|fetch| select-type il:|of| selection) 'structure) (not (il:|fetch| pending-delete? il:|of| selection)) start (or (null end) (eql start end)) (il:|type?| edit-node (setq subnode (nth start (il:fetch sub-nodes il:of node))))) (il:|replace| select-node il:|of| selection il:|with| subnode) (il:|replace| select-start il:|of| selection il:|with| nil) (il:|replace| select-end il:|of| selection il:|with| nil))))) (check-selection-shift (il:lambda (context let-go) (il:* il:\; "Edited 7-Jul-87 13:00 by DCB") (il:* il:|;;;| "check for modifier keys being held down during this selection and update the display if they have changed. if let.go is true, and there are no modifier keys down, the selection is completed and return T to wake up the buttoneventfn") (let ((new-shift (shift-down))) (cond ((and let-go (null new-shift)) (il:* il:\; "no mouse buttons, and no modifier keys -- we're done") t) (t (when (il:neq new-shift pending-shift) (il:\\caret.down) (when (eq pending-shift (quote move)) (il:* il:|;;| "since move selection requires two keys (at least on my keyboard) we give it a little hysteresis so you don't have to release both keys at *exactly* the same time") (il:setq last-move-clock (il:clock 0))) (il:* il:\; "change the selection display") (display-selection pending-selection (il:fetch display-window il:of context) pending-shift) (display-selection pending-selection (il:fetch display-window il:of context) new-shift) (il:* il:\; "make the new shift type current") (il:setq pending-shift new-shift)) nil)))) ) (CLOSEFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 5-Dec-90 18:07 by woz") (IL:* IL:|;;;| "to be called by the window system when SEdit windows are closed. if there's a process, wake it up with a complete command. otherwise just trash the context. grab the lock here, because it wasn't yet grabbed by the buttoneventfn.") (LET ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT))) (WHEN CONTEXT (COND ((IL:OBTAIN.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) T) (IL:RELEASE.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT)) (IL:* IL:\;  "release before waking sedit") (IL:* IL:|;;|  "if there's a stupid attached menu, close it first so we'll release the correct region") (WHEN (IL:WINDOWPROP WINDOW 'MENU) (IL:CLOSEW (IL:WINDOWPROP WINDOW 'MENU))) (COND ((IL:WINDOWPROP WINDOW 'IL:PROCESS) (COND ((EQ (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) 'IL:MOUSE) (IL:* IL:|;;| "if we're running under the mouse, just wake up the SEdit process and let it close the window. That way all completion happens under the command process, not under the mouse.") (AWAKE-COMMAND-PROCESS CONTEXT '(COMPLETE NIL :CLOSE)) 'IL:DON\'T) (T (SAVE-WINDOW-REGION CONTEXT :CLOSE (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT) (IL:WINDOWREGION WINDOW))))) (T (IL:* IL:|;;| "We take this branch when an sedit icon is closed. The process is already dead, but we still have the context to junk. Also, This case CAN HAPPEN IF SOMEBODY RETFROMs sedit or some process involved in cleanup gets an error so the sedit dies.") (SAVE-WINDOW-REGION CONTEXT :CLOSE-ICON (AND CONTEXT (IL:|fetch| ICON-TITLE IL:|of| CONTEXT)) (AND CONTEXT (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)) (IL:WINDOWREGION WINDOW)) (DISINTEGRATE-CONTEXT CONTEXT)))) (T (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%Can't close. SEdit is busy") 'IL:DON\'T)))))) (conflicting-selection? (il:lambda (context destination-context) (il:* il:\; "Edited 7-Jul-87 13:00 by DCB") (il:* il:|;;| "determine if the pending selection conflicts with the main selection in context. there is a conflict for pending selections which get deleted (Delete or Move) because the deletion can mess up the main selection. In the case of Move, if the destination is the same SEdit and the main selection is pending delete, then this parks the point for the move, so leave it up; the copy meshod will worry about overlaps.") (let ((selection (il:fetch selection il:of context))) (when (il:fetch select-node il:of selection) (or (eq pending-shift (quote delete)) (and (eq pending-shift (quote move)) (il:neq context destination-context)))))) ) (display-selection (il:lambda (selection window type) (il:* il:\; "Edited 7-Jul-87 13:01 by DCB") (il:* il:|;;;| "display the current selection with the appropriate markings (outline or underline, gray or black)") (when (il:fetch select-node il:of selection) (cond ((dead-node? (il:fetch select-node il:of selection)) (il:replace select-node il:of selection il:with nil)) (t (il:selectq type (nil (il:* il:|;;| "normal selection -- black underline, or pending delete selection -- black outline") (if (il:fetch pending-delete? il:of selection) (outline-selection selection window il:blackshade) (underline-selection selection window il:blackshade))) (copy (il:* il:\; "copy selection -- gray underline") (underline-selection selection window (gray window))) (move (il:* il:\; "move selection -- gray outline") (outline-selection selection window (gray window))) (delete (il:* il:\; "delete selection -- inverted") (highlight-selection selection window il:blackshade)) (il:shouldnt "unknown selection display type")) t)))) ) (draw-highlight (il:lambda (x-1 x-2 x-3 w y-1 h-1 y-2 h-2 window shade) (il:* il:\; "Edited 17-Nov-87 11:21 by DCB") (il:* il:|;;;| "inverts the selection. x1 is the left edge of the region, x2 is the left edge of the first line (which may be indented) x3 is right edge of the last line, w is the width, y1 is the top, h1 is the height of the first line, y2 is the top of the last line, and h2 is its height. the region will be painted with the specified shade in invert mode") (il:setq x-3 (il:add1 x-3)) (il:setq w (il:add1 w)) (cond ((eq (il:setq y-1 (il:add1 y-1)) (il:setq y-2 (il:add1 y-2))) (il:bltshade shade window x-2 (il:idifference y-1 h-1) (il:idifference x-3 x-2) h-1 (quote il:invert))) (t (when (il:neq x-1 x-2) (il:setq y-1 (il:idifference y-1 h-1)) (il:bltshade shade window x-2 y-1 (il:idifference (il:iplus x-1 w) x-2) h-1 (quote il:invert))) (if (il:neq x-3 (il:iplus x-1 w)) (il:bltshade shade window x-1 (il:idifference y-2 h-2) (il:idifference x-3 x-1) h-2 (quote il:invert)) (il:setq y-2 (il:idifference y-2 h-2))) (il:bltshade shade window x-1 y-2 w (il:idifference y-1 y-2) (quote il:invert))))) ) (draw-outline (il:lambda (x-1 x-2 x-3 w y-1 h-1 y-2 h-2 window shade) (il:* il:\; "Edited 17-Nov-87 11:21 by DCB") (il:* il:|;;;| "outline the selection. arguments are the same as draw.highlight. the selection will be surrounded by a 1 pixel wide border in the specified shade") (il:setq h-1 (il:idifference y-1 h-1)) (il:setq h-2 (il:idifference y-2 h-2)) (il:setq w (il:iplus x-1 w)) (when (eq y-1 y-2) (il:setq x-1 x-2) (il:setq w x-3)) (cond ((eq x-1 x-2) (il:bltshade shade window (il:sub1 x-1) h-2 1 (il:idifference y-1 h-2) (quote il:invert))) (t (il:bltshade shade window (il:sub1 x-1) h-2 1 (il:idifference h-1 h-2) (quote il:invert)) (il:bltshade shade window (il:sub1 x-1) h-1 (il:idifference x-2 x-1) 1 (quote il:invert)) (il:bltshade shade window (il:sub1 x-2) h-1 1 (il:idifference y-1 h-1) (quote il:invert)))) (il:bltshade shade window (il:sub1 x-2) y-1 (il:idifference (il:iplus 2 w) x-2) 1 (quote il:invert)) (il:bltshade shade window x-1 h-2 (il:idifference x-3 x-1) 1 (quote il:invert)) (cond ((eq x-3 w) (il:bltshade shade window x-3 h-2 1 (il:idifference y-1 h-2) (quote il:invert))) (t (il:bltshade shade window x-3 h-2 1 (il:idifference y-2 h-2) (quote il:invert)) (il:bltshade shade window x-3 y-2 (il:idifference w x-3) 1 (quote il:invert)) (il:bltshade shade window w y-2 1 (il:idifference y-1 y-2) (quote il:invert))))) ) (draw-underline (il:lambda (startx first endx last window shade) (il:* il:\; "Edited 17-Jul-87 10:10 by DCB") (il:* il:|;;;| "underline the selection. first and last are the first and last lines, and startx and endx are the x coordinates of the ends of the selection on those lines. the selection will be underlined with a 2 pixel wide line of the specified shade") (il:until (eq first last) il:do (il:bltshade shade window startx (il:fetch next-line-y il:of first) (il:idifference (il:fetch line-length il:of first) startx) 2 (quote il:invert)) (il:setq first (car (il:fetch next-line il:of first))) (il:setq startx (il:fetch indent il:of first))) (il:bltshade shade window startx (il:fetch next-line-y il:of first) (il:idifference endx startx) 2 (quote il:invert))) ) (EXPANDFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 19-Aug-87 15:39 by drc:") (IL:* IL:|;;;| "called by the window system when SEdit window icons are expanded. start a new command process for the window") (LET ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT))) (WHEN (NOT (IL:WINDOWPROP WINDOW 'IL:PROCESS)) (IL:|replace| EVAL-IN-PROCESS IL:|of| CONTEXT IL:|with| (EVAL-IN-PROCESS)) (START-PROCESS CONTEXT))))) (expandregionfn (il:lambda (window) (il:* il:\; "Edited 8-Jan-88 17:49 by woz") (il:* il:|;;;| "calculates a new region for this window as it is expanded. Return NIL if don't want to reshape the window. remember the region manager gives a region including the prompt window, so subtract it before handing the region to the main window.") (let* ((context (il:windowprop window (quote edit-context))) (region (get-window-region context :expand (il:|fetch| icon-title il:|of| context) (il:|fetch| edit-type il:|of| context)))) (and region (less-prompt-window region il:defaultfont)))) ) (extend-selection (il:lambda (selection context x y) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "expand the given selection to include the point (x,y)") (let (node index offset line linear) (when (and (il:insidep (il:dspclippingregion nil (il:fetch display-window il:of context)) x y) (il:setq line (find-line-start y context)) (il:setq linear (find-node x line context))) (il:* il:|;;| "we've found the linear item they're pointing at. figure out what node it belongs to, what its index in the linear form is, and how far into the item the position is") (il:setq node (il:fetch destination il:of (cdr (last linear)))) (il:setq index (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of node)) il:by (cdr x) il:thereis (eq x linear))) (il:setq offset (if (il:type? line-start (car linear)) (if (eq 0 (il:fetch \\x il:of context)) 1 -1) (il:idifference x (il:fetch \\x il:of context)))) (cond ((and (il:fetch select-start il:of selection) (eq (il:fetch select-node il:of selection) node)) (il:* il:|;;| "easy case -- the current selection's node is the one to handle it") (select-segment selection context node nil index offset (car linear))) (t (il:* il:|;;| "harder. we've got to figure out the lowest common subnode and get it to do the work. this could (and should) be simplified and sped up now that we store depth information. its is currently so ugly that it's not even worth trying to explain") (prog ((a (il:fetch select-node il:of selection)) (b node) t-0 t-1 t-2) loopb (when (not (il:fetch super-node il:of a)) (go loopa)) (il:setq t-2 a) (il:setq a (il:fetch super-node il:of a)) (il:setq t-1 node) (il:setq t-0 t-1) loopb-2 (when (eq t-0 a) (go done)) (when (eq t-0 b) (go loopa)) (il:setq t-1 t-0) (il:setq t-0 (il:fetch super-node il:of t-0)) (go loopb-2) loopa (when (not (il:fetch super-node il:of b)) (go loopb)) (il:setq t-2 b) (il:setq b (il:fetch super-node il:of b)) (il:setq t-1 (il:fetch select-node il:of selection)) (il:setq t-0 t-1) loopa-2 (when (eq t-0 b) (go done)) (when (eq t-0 a) (go loopb)) (il:setq t-1 t-0) (il:setq t-0 (il:fetch super-node il:of t-0)) (go loopa-2) done (cond ((eq (il:fetch select-node il:of selection) t-0) (if (il:fetch select-start il:of selection) (select-segment selection context t-0 t-2 nil offset (car linear)) (select-segment selection context (il:fetch super-node il:of t-0) t-0 t-0 nil offset (car linear)))) ((eq node t-0) (select-segment selection context node t-2 index offset (car linear))) (t (select-segment selection context t-0 t-1 t-2 nil offset (car linear)))))))))) ) (FINALIZE-MOUSE-SELECTION (IL:LAMBDA (CONTEXT WINDOW) (IL:* IL:\; "Edited 7-Jul-87 13:03 by DCB") (IL:* IL:|;;| "all mouse buttons and modifier keys have been released, so the selection's completed. figure out just what it was that was selected, and if it's a copy, move, or delete, do it") (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))) (COND (PENDING-SHIFT (IL:* IL:\; "some action required") (WHEN (IL:|fetch| SELECT-NODE IL:|of| PENDING-SELECTION) (LET ((DESTINATION-CONTEXT (GET-DESTINATION-CONTEXT)) DESTINATION-POINT) (IL:\\CARET.DOWN) (IL:* IL:\;  "need this here because get.destination.context lets the caret flash again.") (WHEN (IL:NEQ PENDING-SHIFT 'COPY) (IL:* IL:\; "for Move or Delete") (SELECTION-DOWN CONTEXT)) (IL:* IL:|;;| "take down the pending (shift) selection") (DISPLAY-SELECTION PENDING-SELECTION WINDOW PENDING-SHIFT) (WHEN (AND LAST-MOVE-CLOCK (IL:ILESSP (IL:CLOCK 0) (IL:IPLUS LAST-MOVE-CLOCK 250))) (IL:* IL:|;;|  "if they release the two keys within a quarter second, we'll assume it was a move") (IL:SETQ PENDING-SHIFT 'MOVE)) (WHEN (CONFLICTING-SELECTION? CONTEXT DESTINATION-CONTEXT) (IL:* IL:|;;| "if the selection conflicts then waste it.") (SET-SELECTION-NOWHERE SELECTION)) (COND ((EQ PENDING-SHIFT 'DELETE) (DELETE-NODES (IL:|fetch| SELECT-NODE IL:|of| PENDING-SELECTION) CONTEXT (IL:|fetch| SELECT-START IL:|of| PENDING-SELECTION) (IL:|fetch| SELECT-END IL:|of| PENDING-SELECTION) (IL:|fetch| CARET-POINT IL:|of| CONTEXT) (IL:|fetch| SELECT-STRING IL:|of| PENDING-SELECTION)) (UPDATE CONTEXT) (IL:TTY.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (T (IL:* IL:|;;| "copy or move -- figure out whether it's going into an SEdit, or to an unknown sink (in which case we print it)") (WHEN DESTINATION-CONTEXT (IL:* IL:\;  "it's going to an SEdit. prepare it") (IL:\\CARET.DOWN (IL:|fetch| DISPLAY-WINDOW IL:|of| DESTINATION-CONTEXT )) (SELECTION-DOWN DESTINATION-CONTEXT) (CLOSE-OPEN-NODE DESTINATION-CONTEXT) (IL:SETQ DESTINATION-POINT (IL:|fetch| CARET-POINT IL:|of| DESTINATION-CONTEXT))) (COPY-SELECTION PENDING-SELECTION CONTEXT DESTINATION-CONTEXT DESTINATION-POINT (EQ PENDING-SHIFT 'MOVE)) (WHEN (IL:NEQ CONTEXT DESTINATION-CONTEXT) (COND ((EQ PENDING-SHIFT 'MOVE) (UPDATE CONTEXT)) ((IL:OBTAIN.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) T) (IL:* IL:|;;|  "for Copy select, only display the selection if this is a non-busy sedit") (SELECTION-UP CONTEXT) (IL:RELEASE.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))))) (WHEN DESTINATION-CONTEXT (IL:* IL:|;;|  "just wake up the destination and let it update itself.") (AWAKE-COMMAND-PROCESS DESTINATION-CONTEXT))))))) (T (IL:* IL:|;;| "just setting the current selection, and maybe the caret. it is all displayed from when it was pending, so mark it as displayed now") (IL:|replace| SELECTION-DISPLAYED? IL:|of| CONTEXT IL:|with| T) (IL:* IL:|;;| "and make it the main selection and point") (SMASH-USING EDIT-SELECTION SELECTION PENDING-SELECTION) (IL:|replace| LAST-MOUSE-X IL:|of| CONTEXT IL:|with| PENDING-LAST-X) (IL:|replace| LAST-MOUSE-Y IL:|of| CONTEXT IL:|with| PENDING-LAST-Y) (IL:|replace| LAST-MOUSE-TYPE IL:|of| CONTEXT IL:|with| PENDING-TYPE) (WHEN (IL:|fetch| PENDING-DELETE? IL:|of| PENDING-SELECTION) (IL:|replace| POINT-NODE IL:|of| PENDING-CARET IL:|with| SELECTION) (IL:|replace| POINT-TYPE IL:|of| PENDING-CARET IL:|with| (IL:|fetch| SELECT-TYPE IL:|of| PENDING-SELECTION))) (SMASH-USING EDIT-POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) PENDING-CARET) (SHOW-CARET CONTEXT)))))) (find-line-start (il:lambda (y context) (il:* il:\; "Edited 17-Nov-87 11:22 by DCB") (il:* il:|;;;| "find the line including a given y coordinate. very dumb -- we just linear search through them -- but does the job") (il:bind (line il:_ (il:fetch linear-form il:of (il:fetch root il:of context))) next-line il:first (when (or (il:ileq y (il:fetch il:bottom il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)))) (il:igreaterp y 0)) (il:* il:\; "above or below the structure") (return nil)) il:do (if (and (il:setq next-line (il:fetch next-line il:of (car line))) (il:igeq (il:fetch ycoord il:of (car next-line)) y)) (il:setq line next-line) (return line)))) ) (find-node (il:lambda (x linear-pointer context) (il:* il:\; "Edited 17-Nov-87 11:22 by DCB") (il:* il:|;;;| "sort of a dubious name. we're actually trying to find the linear item on this line which corresponds to the given x position. linear.pointer is the line. as an added bonus, set the \\X field of context to the x coordinate of this linear item. this is a hack; we really want to return multiple values, but there's no clean way to do that in interlisp") (prog (linear-item) (when (il:ilessp x 0) (il:* il:|;;| "to the left of the whole structure -- nothing there! (i don't think this should ever happen)") (return nil)) (il:setq linear-item (car linear-pointer)) (when (il:igeq x (il:fetch line-length il:of linear-item)) (il:* il:|;;| "past the right edge of this line; say we're before the next line") (il:replace \\x il:of context il:with 1) (return (il:fetch next-line il:of linear-item))) (il:bind (current-x il:_ 0) (nextx il:_ (il:fetch indent il:of linear-item)) il:while (il:ileq nextx x) il:do (il:setq current-x nextx) (il:setq linear-pointer (next-linear-item (cdr linear-pointer))) (il:setq nextx (il:iplus nextx (linear-item-width (car linear-pointer)))) il:finally (il:replace \\x il:of context il:with current-x)) (return linear-pointer))) ) (get-destination-context (il:lambda nil (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;;| "used under shift selections. if the destination is an SEdit, return its context, otherwise NIL. It is considered a valid (ready for shift selection) SEdit if the process is waiting under getkey") (let ((destination (il:processprop (il:tty.process) (quote il:window)))) (and destination (il:setq destination (il:windowprop destination (quote edit-context))) (il:process.eval (il:tty.process) (quote (il:stkpos (quote getkey))) t) destination))) ) (gray (il:lambda (window) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "due to a misfeature of the window system, we have to adjust the gray texture depending on how much the window's been scrolled. bleah") (il:* il:|;;| "DEdit's SHADEFIXER handles the more general case") (if (eq (evenp (il:dspxoffset nil window)) (evenp (il:dspyoffset nil window))) 23130 42405)) ) (grow-click? (il:lambda (context point-type window) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;| "the left or middle mouse button is down. decide if this is part of a multi-click, i.e. the mouse stays in the same position as the previous click. if so, we just grow the selection. return T if that's what happened") (when (and (cond ((il:fetch select-node il:of pending-selection) (il:* il:\; "you can't grow a selection if you've already extended it") (not (il:fetch select-end il:of pending-selection))) (t (and (not pending-shift) (il:fetch select-node il:of (il:fetch selection il:of context)) (not (il:fetch select-end il:of (il:fetch selection il:of context)))))) (eq pending-type point-type) (il:ileq (abs (il:idifference (il:lastmousex window) pending-last-x)) 2) (il:ileq (abs (il:idifference (il:lastmousey window) pending-last-y)) 2)) (il:* il:|;;| "it looks like we've got a grow click. display the grown selection, and wait until the mouse button goes up") (cond ((il:fetch select-node il:of pending-selection) (il:* il:\; "turn off the previous selection") (display-selection pending-selection window pending-shift)) (t (smash-using edit-selection pending-selection (il:fetch selection il:of context)))) (grow-selection pending-selection context) (when (and (il:fetch select-node il:of pending-selection) (null (il:fetch select-start-x il:of pending-selection))) (compute-selection-position pending-selection context)) (display-selection pending-selection window pending-shift) (set-point-nowhere pending-caret) (il:do (il:* il:|;;| "keep watching for new modifier keys, until the mouse buttons come up *or* the cursor is moved, which cancels the grow") (check-selection-shift context) (il:block) il:repeatuntil (or (il:mousestate (or il:up il:right)) (il:igreaterp (abs (il:idifference (il:lastmousex window) pending-last-x)) 2) (il:igreaterp (abs (il:idifference (il:lastmousey window) pending-last-y)) 2))) (il:mousestate (or il:up il:right)))) ) (grow-selection (il:lambda (selection context) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "compute the new selection which results from growing this one") (funcall (il:fetch grow-selection il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context (il:fetch select-node il:of selection))) ) (grow-selection-default (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "a default method for GrowSelection. if we're not the top node in the tree (i.e. our super isn't the root) then select our super") (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (punt-set-selection selection context node))) ) (highlight-selection (il:lambda (selection window shade) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "highlight this selection. draw.highlight does all the work, once we've figured out the bounds") (outline-selection selection window shade (il:function draw-highlight))) ) (icon-copyfn (il:lambda (il:window) (il:* il:\; "Edited 8-Jan-88 09:00 by DCB") (il:* il:|;;;| "BKSYSBUFs the title of the SEdit window (as a structure if it is one)") (let ((name (il:listget (il:windowprop (il:windowprop il:window (quote il:iconfor)) (quote title-info)) :|name|))) (if name (il:bksysbuf name t) (il:bksysbuf " " nil)))) ) (less-prompt-window (il:lambda (region font) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:createregion (il:fetch (il:region il:left) il:of region) (il:fetch (il:region il:bottom) il:of region) (il:fetch (il:region il:width) il:of region) (il:idifference (il:fetch (il:region il:height) il:of region) (il:heightifwindow (il:fontprop font (quote il:height)))))) ) (normalize-selection (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;;| "if the current selection isn't visible in the window, scroll until it is. we only worry about vertical position; this could be extended to handle horizontal scrolling too, should there prove any need. since we're usually getting called after just setting the selection to be normalized, we have to compute the position first, in order to know how to center it.") (let ((selection (il:fetch selection il:of context)) (region (il:dspclippingregion nil (il:fetch display-window il:of context))) first-line) (compute-selection-position selection context) (il:setq first-line (il:fetch select-start-line il:of selection)) (when (or (il:ilessp (il:fetch next-line-y il:of first-line) (il:fetch (il:region il:bottom) il:of region)) (il:igreaterp (il:fetch ycoord il:of first-line) (il:fetch (il:region il:top) il:of region))) (il:* il:|;;| "the selection isn't completely visible. scroll so that the top of it is 1/3 of the way from the top of the window. it might still not be completely visible, but it's good enough") (il:scrollw (il:fetch display-window il:of context) 0 (il:idifference (il:fetch (il:region il:top) il:of region) (il:imin 0 (il:iplus (il:fetch ycoord il:of first-line) (il:iquotient (il:fetch (il:region il:height) il:of region) 3)))))))) ) (outline-selection (il:lambda (selection window shade fn) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "highlight this selection. draw.outline does all the work, once we've figured out the bounds. we also share this code with highlight.selection, via a functional parameter") (il:bind (minx il:_ (il:fetch select-start-x il:of selection)) (maxx il:_ (il:fetch select-end-x il:of selection)) (line il:_ (il:fetch select-start-line il:of selection)) (endline il:_ (il:fetch select-end-line il:of selection)) il:while (il:neq line endline) il:do (il:setq maxx (il:imax maxx (il:fetch line-length il:of line))) (il:setq line (car (il:fetch next-line il:of line))) (il:setq minx (il:imin minx (il:fetch indent il:of line))) il:finally (funcall (or fn (il:function draw-outline)) minx (il:fetch select-start-x il:of selection) (il:fetch select-end-x il:of selection) (il:idifference maxx minx) (il:fetch ycoord il:of (il:fetch select-start-line il:of selection)) (il:fetch line-height il:of (il:fetch select-start-line il:of selection)) (il:fetch ycoord il:of endline) (il:fetch line-height il:of endline) window shade))) ) (pending-delete (il:lambda (point selection) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (when (il:fetch select-node il:of selection) (il:replace pending-delete? il:of selection il:with t) (il:replace point-node il:of point il:with selection) (il:replace point-type il:of point il:with (il:fetch select-type il:of selection)))) ) (place-caret-and-selection (il:lambda (caret selection context x y type) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "compute the new location of the caret and current selection, given the coordintes of the mouse and the type of selection being made") (let (line linear node index offset) (cond ((and (il:insidep (il:dspclippingregion nil (il:fetch display-window il:of context)) x y) (il:setq line (find-line-start y context)) (il:setq linear (find-node x line context))) (il:* il:|;;| "we've found the linear item they're pointing at. figure out what node it belongs to, what its index in the linear form is, and how far into the item the position is") (il:setq node (il:fetch destination il:of (cdr (last linear)))) (il:setq index (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of node)) il:by (cdr x) il:thereis (eq x linear))) (il:setq offset (if (il:type? line-start (car linear)) (if (eq 0 (il:fetch \\x il:of context)) 1 -1) (il:idifference x (il:fetch \\x il:of context)))) (il:* il:|;;| "call the appropriate methods to place the point and selection") (when caret (set-point caret context node index offset (car linear) type t)) (set-selection selection context node index offset (car linear) type) (when (and (il:fetch select-node il:of selection) (null (il:fetch select-start-x il:of selection))) (compute-selection-position selection context))) (t (il:* il:|;;| "the mouse isn't pointing at anything -- cancel the point and selection") (when caret (set-point-nowhere caret)) (set-selection-nowhere selection))))) ) (punt-set-point (il:lambda (point context node which-end compute-location?) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;| "there's no place to put the point in this node; try letting the supernode put it immediately before or after this node -- before if which.end is NIL, after if it's T") (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) which-end node (quote structure) compute-location?)) ) (punt-set-selection (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "this node can't handle the selection; ask its supernode to try") (set-selection selection context (il:fetch super-node il:of node) (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of (il:fetch super-node il:of node))) il:by (cdr x) il:thereis (eq x (il:fetch linear-thread il:of node))) nil node (quote structure))) ) (repaintfn (il:lambda (window region) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;| "called by the window system when it needs some or all of the window to be repainted (based on region)") (let ((context (il:windowprop window (quote edit-context)))) (when context (with-profile (il:fetch profile il:of context) (let (start line) (when (il:setq start (find-line-start (il:fetch (il:region il:top) il:of region) context)) (il:setq line (car start)) (il:* il:|;;| "here we have to lie about the selection. it may have been displayed, but now the region has been cleared, so that part of the selection is no longer on the screen. setting the flag NIL will force it to be redisplayed on the way out.") (il:replace selection-displayed? il:of context il:with nil) (repaint context (il:fetch indent il:of line) (il:fetch base-line-y il:of line) (cdr start) (il:fetch (il:region il:bottom) il:of region)) (when (eq selection-pending? context) (il:* il:|;;| "they're in the process of making a selection in this window -- probably scrolling to extend the selection") (il:* il:\; "(fix.caret.position)") (display-selection pending-selection window pending-shift)) (il:* il:|;;| "now that we're done, try to bring back the main selection.") (selection-up context))))))) ) (reshapefn (il:lambda (window old-image old-image-region old-screen-region) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;| "called by the window system when the window's size changes. if the width is exactly the same we'll just reuse as much of the image as possible and repaint the rest. if the width has changed, we'll have to completely reformat") (let* ((context (il:windowprop window (quote edit-context))) (new-region (il:dspclippingregion nil window)) (old-bottom (il:fetch (il:region il:bottom) il:of new-region))) (il:wyoffset (il:idifference (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region)) window) (compute-comment-column context window) (il:with.monitor (il:fetch context-lock il:of context) (cond ((eq (il:fetch (il:region il:width) il:of old-image-region) (il:fetch (il:region il:width) il:of new-region)) (il:* il:\; "reuse the old bits") (il:bitblt old-image (il:fetch (il:region il:left) il:of old-image-region) (il:fetch (il:region il:bottom) il:of old-image-region) window (il:fetch (il:region il:left) il:of new-region) old-bottom (il:fetch (il:region il:width) il:of old-image-region) (il:fetch (il:region il:height) il:of old-image-region)) (when (il:igreaterp (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region)) (il:* il:|;;| "if the new one is smaller, we're done. otherwise we have to repaint the extra space") (let ((blank-region (il:create il:region il:using new-region il:height il:_ (il:idifference (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region))))) (il:resetlst (il:resetsave nil (list (quote il:dspclippingregion) (il:dspclippingregion blank-region window) window)) (il:* il:|;;| "clip to area to repaint, and make sure clipping region gets reset on the way out.") (repaintfn window blank-region))))) (t (il:* il:|;;| "the new window is a different width. reformat and repaint from scratch. we also cancel any horizontal scrolling") (with-profile (il:fetch profile il:of context) (il:wxoffset (il:fetch (il:region il:left) il:of new-region) window) (il:* il:|;;| "atom.change.relinearize is just a convenient way to close up sedit structure and relinearize from scratch.") (atom-change-relinearize context))))))) ) (scan-for-bounds (il:lambda (start end line initialize) (il:* il:\; "Edited 11-Apr-88 15:26 by woz") (il:* il:|;;;| "we have to recompute the ascent and descent of this line. scan the linear form from start to end (or the next line start, which ever comes first) and compute the maximum ascent and descent. we also fix up the first and last line fields of any nodes we notice, and compute and return the width of the section of linear form we examine") (il:|bind| item item-node (line-start il:_ (car line)) max-ascent max-descent (x il:_ 0) il:|first| (cond (initialize (il:setq max-ascent 0) (il:setq max-descent 0)) (t (il:setq max-ascent (il:|fetch| line-ascent il:|of| line-start)) (il:setq max-descent (il:|fetch| line-descent il:|of| line-start)))) il:|do| (when (eq start end) (when (null start) (il:|replace| next-line il:|of| line-start il:|with| nil)) (go il:$$out)) (cond ((il:listp start) (il:setq item (car start)) (cond ((il:|type?| weak-link item) (setq item-node (il:|fetch| destination il:|of| item)) (il:|replace| first-line il:|of| item-node il:|with| line-start) (il:setq start (il:|fetch| linear-form il:|of| item-node))) ((il:|type?| line-start item) (il:|replace| prev-line il:|of| item il:|with| line) (il:|replace| next-line il:|of| line-start il:|with| start) (go il:$$out)) (t (cond ((il:fixp item) (il:setq x (il:iplus x item))) ((il:|type?| string-item item) (il:setq x (il:iplus x (il:|fetch| width il:|of| item))) (il:setq item (il:|fetch| font il:|of| item)) (il:setq max-ascent (il:imax max-ascent (il:fontprop item (quote il:ascent)))) (il:setq max-descent (il:imax max-descent (il:fontprop item (quote il:descent))))) (t (il:setq max-ascent (il:imax max-ascent (il:idifference (il:bitmapheight (cdr item)) (car item)))) (il:setq max-descent (il:imax max-descent (il:iminus (car item)))) (il:setq x (il:iplus x (il:bitmapwidth (cdr item)))))) (il:setq start (cdr start))))) (t (il:setq start (il:|fetch| destination il:|of| start)) (il:* il:\; "used to replace LastLineLinear of start with line") (il:|replace| last-line il:|of| start il:|with| line-start) (il:setq start (cdr (il:|fetch| linear-thread il:|of| start))))) il:|finally| (il:|replace| line-ascent il:|of| line-start il:|with| max-ascent) (il:|replace| line-descent il:|of| line-start il:|with| max-descent) (when (il:|type?| weak-link start) (il:* il:\; "used to replace LastLineLinear of (fetch Destination of start) with line") (il:|replace| last-line il:|of| (il:|fetch| destination il:|of| start) il:|with| (car line))) (return x))) ) (select-node (il:lambda (context node set-point? where) (il:* il:\; "Edited 3-Dec-87 12:15 by DCB") (set-selection-me (il:fetch selection il:of context) context node) (il:replace pending-delete? il:of (il:fetch selection il:of context) il:with nil) (when set-point? (set-point (il:fetch caret-point il:of context) context node nil where nil (quote structure) t))) ) (select-segment (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "apply the appropriate SelectSegment method to set this selection") (il:replace delete-ok? il:of selection il:with t) (il:replace pending-delete? il:of selection il:with t) (funcall (il:fetch select-segment il:of (il:fetch node-type il:of node)) selection context node subnode index offset item)) ) (select-segment-default (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 11-Apr-88 15:26 by woz") (il:* il:|;;;| "a default SelectSegment method for aggregate types. selects the sequence of subnodes bounded by the selected items") (let (start end) (cond (subnode (il:setq start (il:setq end (il:|fetch| sub-node-index il:|of| subnode)))) (t (il:setq start (il:|fetch| select-start il:|of| selection)) (il:setq end (or (il:|fetch| select-end il:|of| selection) start)))) (cond ((null index) (il:setq start (il:imin start (il:|fetch| select-start il:|of| selection))) (il:setq end (il:imax end (il:|fetch| select-end il:|of| selection)))) ((il:|type?| edit-node index) (cond ((il:ilessp (il:setq index (il:|fetch| sub-node-index il:|of| index)) start) (il:setq start index)) ((il:igreaterp index end) (il:setq end index)))) (t (il:|for| linear-item il:|in| (il:|fetch| linear-form il:|of| node) il:|as| linear-index il:|from| 1 il:|bind| last-subnode-index take-next linear-item-node il:|do| (when (il:|type?| weak-link linear-item) (setq linear-item-node (il:|fetch| destination il:|of| linear-item)) (cond (take-next (return (il:setq start (il:imin start (il:|fetch| sub-node-index il:|of| linear-item-node))))) (t (il:setq last-subnode-index (il:|fetch| sub-node-index il:|of| linear-item-node)) (when (eq linear-index index) (cond ((il:ilessp last-subnode-index start) (il:setq start last-subnode-index)) ((il:igreaterp last-subnode-index end) (il:setq end last-subnode-index))) (return))))) (when (eq linear-index index) (if (and last-subnode-index (il:igeq last-subnode-index start)) (return (il:setq end (il:imax end last-subnode-index))) (il:setq take-next t)))))) (il:|replace| select-node il:|of| selection il:|with| node) (il:|replace| select-start il:|of| selection il:|with| start) (il:|replace| select-end il:|of| selection il:|with| end) (il:|replace| select-start-x il:|of| selection il:|with| nil) (il:|replace| select-type il:|of| selection il:|with| (quote structure)))) ) (selection-down (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "turn off the display of the current selection -- we're going to change the window. displaly.se") (when (il:fetch selection-displayed? il:of context) (display-selection (il:fetch selection il:of context) (il:fetch display-window il:of context)) (il:replace selection-displayed? il:of context il:with nil))) ) (selection-up (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "make sure the selection is displayed. if it's not, and displaying it works, then mark it as displayed.") (when (and (not (il:fetch selection-displayed? il:of context)) (display-selection (il:fetch selection il:of context) (il:fetch display-window il:of context))) (il:replace selection-displayed? il:of context il:with t))) ) (set-point (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "apply the appropriate SetPoint method to set this point. these methods must be able to handle 3 cases:") (il:* il:|;;;| "case 1: index is index into linear form of cursor, offset is offset into that item, item is the item") (il:* il:|;;;| "case 2: (set point at beginning or end of this node) : index is NIL, offset is NIL for beginning, T for end") (il:* il:|;;;| "case 3: (set point before or after subnode) : index is subnode index, offset is before/after, item is subnode") (funcall (il:fetch set-point il:of (il:fetch node-type il:of node)) point context node index offset item type compute-location?)) ) (set-point-nowhere (il:lambda (point) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "a SetPoint method for types that have nowhere to insert") (il:replace point-node il:of point il:with nil) (il:replace point-type il:of point il:with nil)) ) (set-point-unknown (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "the SetPoint method for type unknown, and anyone else doesn't allow insertions but whose super might. ask the super to except input before or after this node, based on which is closer. note that the calculation for which is closer assumes that the node is displayed inline, so this method won't work for anyone that doesn't") (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch inline-width il:of node))) offset) compute-location?)) ) (set-selection (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "apply the appropriate SetSelection method to set this selection") (il:replace delete-ok? il:of selection il:with t) (il:replace pending-delete? il:of selection il:with nil) (funcall (il:fetch set-selection il:of (il:fetch node-type il:of node)) selection context node index offset item type)) ) (set-selection-me (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:26 by DCB") (il:* il:|;;;| "set the current selection to be this node") (il:|replace| select-node il:|of| selection il:|with| node) (il:|replace| select-start il:|of| selection il:|with| nil) (il:|replace| select-end il:|of| selection il:|with| nil) (il:* il:|;;| "we use to compute the selection position, but (a) this causes problems because some of these values might not be computed yet, and (b) ComputeSelectionPosition should be called anyway. Here's the old code:") (il:* il:|;;| "(replace SelectStartX of selection with (fetch StartX of node)) ") (il:* il:|;;| "(replace SelectStartLine of selection with (fetch FirstLine of node)) ") (il:* il:|;;| "(replace SelectEndX of selection with (IPLUS (fetch StartX of node) ") (il:* il:|;;| "(fetch ActualLLength of node))) ") (il:* il:|;;| "(replace SelectEndLine of selection with (fetch LastLine of node))") (il:|replace| select-start-x il:|of| selection il:|with| nil) (il:|replace| select-type il:|of| selection il:|with| (quote structure))) ) (set-selection-nowhere (il:lambda (selection) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "there is no current selection") (il:replace select-node il:of selection il:with nil)) ) (shift-down (il:lambda nil (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;| "check which selection modifer keys are held down, and return one of the atoms Move, Copy, Delete, or NIL. The META key is not considered a \"selection modifer\". It is used to popup the command menu.") (cond ((il:keydownp (quote il:move)) (quote move)) ((il:keydownp (quote il:copy)) (quote copy)) ((il:shiftdownp (quote il:shift)) (if (il:shiftdownp (quote il:ctrl)) (quote move) (quote copy))) ((il:shiftdownp (quote il:ctrl)) (quote delete)))) ) (show-caret (il:lambda (context compute-pos? scroll?) (il:* il:\; "Edited 13-Jun-88 18:59 by Snow") (il:* il:|;;;| "COMMAND is the command name run prior to this update. Normalize the caret if: the user is inside a structure (point-type not STRUCTURE), or we're specifically told to scroll. ") (let ((caret-point (il:|fetch| caret-point il:|of| context))) (when (il:|fetch| point-node il:|of| caret-point) (when compute-pos? (compute-point-position caret-point context)) (il:|freplace| caret il:|of| context il:|with| (il:\\caret.create (if (eq (il:|ffetch| point-type il:|of| caret-point) 'structure) structure-caret atom-caret))) (when (or (not (eq (il:|ffetch| point-type il:|of| caret-point) 'structure)) scroll?) (il:* il:|;;| "AUTO SCROLL: check for caret off screen.") (let* ((window (il:|ffetch| display-window il:|of| context)) (region (il:dspclippingregion nil window)) selection caret-x caret-y x-amount y-amount) (il:* il:|;;|  "if its a pending delete point, get the location out of the selection") (cond ((il:type? edit-selection (setq selection (il:ffetch point-node il:of caret-point))) (setq caret-x (il:ffetch select-start-x il:of selection)) (setq caret-y (il:fetch base-line-y il:of (il:ffetch select-start-line il:of selection)) )) (t (setq caret-x (il:ffetch point-x il:|of| caret-point)) (setq caret-y (il:fetch base-line-y il:|of| (il:ffetch point-line il:|of| caret-point))))) (il:* il:|;;| "with the fancy formatting of sedit, you can end up off the screen in two dimensions at once, so check horizontally and vertically separately, then do the scroll if need be.") (cond ((plusp (setq x-amount (- caret-x (il:ffetch (il:region il:right) il:|of| region)))) (il:* il:|;;| "fell off right edge") (setq x-amount (- (floor (il:ffetch (il:region il:width) il:|of| region) -2) x-amount))) ((minusp (setq x-amount (- caret-x (il:ffetch (il:region il:left) il:|of| region)))) (il:* il:|;;| "fell off left edge, scroll right") (setq x-amount (- (floor (il:ffetch (il:region il:width) il:|of| region) 2) x-amount))) (t (setq x-amount 0))) (cond ((minusp (setq y-amount (- caret-y (il:ffetch (il:region il:bottom) il:|of| region)))) (il:* il:|;;| "fell off bottom edge") (setq y-amount (- (floor (il:ffetch (il:region il:height) il:|of| region) 2) y-amount))) ((plusp (setq y-amount (- caret-y (il:ffetch (il:region il:top) il:|of| region)))) (il:* il:|;;| "fell off top edge") (setq y-amount (- (floor (il:ffetch (il:region il:height) il:|of| region) -2) y-amount))) (t (setq y-amount 0))) (when (or (not (zerop x-amount)) (not (zerop y-amount))) (il:scrollw window x-amount y-amount)))))))) (SHRINKFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 5-Dec-90 17:29 by woz") (IL:* IL:|;;| "called by the window system when an SEdit window is shrunk. if it doesn't already have one, give it a pretty icon with an appropriate title. also make sure the command process notices that it should die. grab the context lock here, because it wasn't grabbed by the buttoneventfn.") (LET* ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT)) (LOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))) (COND ((IL:EQMEMB :CLOSE-ON-COMPLETION (IL:|fetch| EDIT-OPTIONS IL:|of| CONTEXT)) (IL:* IL:|;;| "can't shrink, because must be a one-time edit") (IL:|printout| (GET-PROMPT-WINDOW CONTEXT) T "Can't shrink this SEdit. Must close when done editing.") 'IL:DON\'T) ((IL:OBTAIN.MONITORLOCK LOCK T) (IL:RELEASE.MONITORLOCK LOCK) (IL:* IL:\;  "release before waking sedit") (COND ((EQ (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) 'IL:MOUSE) (IL:* IL:|;;| "under the mouse, restart the completion under SEdit") (AWAKE-COMMAND-PROCESS CONTEXT '(COMPLETE NIL :SHRINK)) 'IL:DON\'T) (T (SAVE-WINDOW-REGION CONTEXT :SHRINK (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT) (IL:WINDOWREGION WINDOW)) (WHEN (NOT (IL:WINDOWPROP WINDOW 'IL:ICON)) (IL:WINDOWPROP WINDOW 'IL:ICON (LET ((SHRUNKW (IL:TITLEDICONW TITLED-ICON (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) NIL T))) (IL:WINDOWPROP SHRUNKW 'IL:COPYFN 'ICON-COPYFN) SHRUNKW)))))) (T (IL:|printout| (GET-PROMPT-WINDOW CONTEXT) T "Can't shrink. SEdit is busy.") 'IL:DON\'T))))) (string-offset (il:lambda (string start end font string? point-or-selection startx) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "compute the x coordinate of a point or selection in a litatom or string. for a point, start is NIL and end is the number of characters before the point. for a selection, start is the number of characters before the start of the selection, and end is the number of characters before the last character of the selection. string? specifies that we have to account for string quotes.") (il:for j il:from 1 il:to end il:bind (offset il:_ 0) (esc il:_ (escape-char)) k il:first (when string? (il:setq offset (il:charwidth (il:charcode il:\") font))) il:do (when (eq j start) (il:replace select-start-x il:of point-or-selection il:with (il:iplus offset startx))) (il:setq k (il:nthcharcode string j)) (il:setq offset (il:iplus (cond ((and string? (or (eq k (il:charcode il:\")) (eq k esc))) (il:iplus (il:charwidth esc font) (il:charwidth k font))) ((and string? (il:ilessp k (il:charcode il:space))) (il:iplus (il:charwidth (il:charcode il:^ font) font) (il:charwidth (il:iplus k 64) font))) (t (il:charwidth k font))) offset)) il:finally (if start (il:replace select-end-x il:of point-or-selection il:with (il:iplus offset startx)) (il:replace point-x il:of point-or-selection il:with (il:iplus offset startx))))) ) (track-extend (il:lambda (context window) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "we're extending a selection with the right mouse button. display the resulting selection until the user accepts it by releasing the button. we use smash.using to copy the contents of one selection into another") (il:first (il:setq pending-type nil) (il:* il:|;;| "extending a selection cancels the point") (set-point-nowhere pending-caret) (cond ((il:fetch select-node il:of pending-selection) (smash-using edit-selection initial-selection pending-selection)) ((il:fetch select-node il:of (il:fetch selection il:of context)) (smash-using edit-selection initial-selection (il:fetch selection il:of context))) (t (il:* il:|;;| "there's no selection to extend, so nothing happens. wait until the mouse button comes up. this could be changed; i think it would be more convenient if you could extend from a point as well as a selection") (il:untilmousestate (not il:right)) (return))) il:do (smash-using edit-selection scratch-selection initial-selection) (il:* il:\; "compute the extended selection") (extend-selection scratch-selection context (il:lastmousex window) (il:lastmousey window)) (when (or (il:neq (il:fetch select-node il:of pending-selection) (il:fetch select-node il:of scratch-selection)) (il:neq (il:fetch select-start il:of pending-selection) (il:fetch select-start il:of scratch-selection)) (il:neq (il:fetch select-end il:of pending-selection) (il:fetch select-end il:of scratch-selection))) (il:* il:\; "if it's different from the last extended selection, fix the display") (display-selection pending-selection window pending-shift) (when (null (il:fetch select-start-x il:of scratch-selection)) (compute-selection-position scratch-selection context)) (display-selection scratch-selection window pending-shift) (smash-using edit-selection pending-selection scratch-selection)) (il:* il:\; "keep watching for changes in modifier keys") (check-selection-shift context) (il:block) il:repeatuntil (il:mousestate (not il:right)))) ) (track-select (il:lambda (context window) (il:* il:\; "Edited 24-Nov-87 09:54 by DCB") (il:* il:|;;| "we're making a selection with the left or middle mouse button. display the resulting selection until the user accepts it by releasing the button") (il:bind (point-type il:_ (cond ((il:lastmousestate il:left) (il:* il:|;;| "left button select within an atom") (quote atom)) (t (il:* il:|;;| "middle button selects structures") (quote structure)))) point? bar-x bar-y bar-line bar-height il:first (when (grow-click? context point-type window) (il:* il:|;;| "if this can be parsed as part of a multi-click sequence to grow the current selection, do it") (when (and (not pending-shift) (il:fetch select-node il:of pending-selection)) (set-point pending-caret context (il:fetch select-node il:of pending-selection) nil t) (when (il:fetch point-node il:of pending-caret) (compute-point-position pending-caret context))) (return)) (smash-using edit-selection scratch-selection pending-selection) il:do (il:* il:|;;| "decide where the new point and selection will be") (place-caret-and-selection (and (null pending-shift) pending-caret) pending-selection context (il:lastmousex window) (il:lastmousey window) point-type) (when pending-shift (il:* il:|;;| "if modifier keys are down we won't set the caret point") (set-point-nowhere pending-caret)) (il:* il:|;;| "show a vertical bar where the caret will be placed") (track-bar-in-track-select) (when (or (il:neq (il:fetch select-node il:of pending-selection) (il:fetch select-node il:of scratch-selection)) (il:neq (il:fetch select-start il:of pending-selection) (il:fetch select-start il:of scratch-selection)) (il:neq (il:fetch select-end il:of pending-selection) (il:fetch select-end il:of scratch-selection))) (il:* il:|;;| "if this is a new selection, display it") (display-selection scratch-selection window pending-shift) (display-selection pending-selection window pending-shift) (smash-using edit-selection scratch-selection pending-selection)) (check-selection-shift context) (il:block) il:repeatuntil (il:mousestate (or il:up il:right)) il:finally (when point? (il:* il:|;;| "take down the vertical bar at the caret position") (il:bltshade il:blackshade window bar-x bar-y 1 bar-height (quote il:invert))) (il:* il:|;;| "remember where the mouse is, so that we can detect multi-click sequences") (il:setq pending-last-x (il:lastmousex window)) (il:setq pending-last-y (il:lastmousey window)) (il:setq pending-type point-type))) ) (underline-selection (il:lambda (selection window shade) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "use draw.underline to underline the this selection with the specified shade") (draw-underline (il:fetch select-start-x il:of selection) (il:fetch select-start-line il:of selection) (il:fetch select-end-x il:of selection) (il:fetch select-end-line il:of selection) window shade)) ) (update-title (il:lambda (context window always?) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "MUST BE CALLED UNDER SEDIT'S PROFILE: Expects *PACKAGE* to be bound properly. Update the window title to reflect the state of the edit. toggle the asterisk that means \"unsaved changes\", fixup the current package...") (il:* il:|;;;| "The OR to test if any field has changed is okay because only one thing can happen at a time, and so only one of the or clauses can be true on any call to this function.") (let ((title-info (il:windowprop window (quote title-info))) (changed-structure (il:fetch changed-structure? il:of context)) (name (il:fetch icon-title il:of context))) (when (or (when (il:neq changed-structure (il:listget title-info :|ChangedStructure?|)) (il:listput title-info :|ChangedStructure?| changed-structure) t) (when (il:neq *package* (il:listget title-info :|package|)) (il:listput title-info :|package| *package*) t) (when (il:neq name (il:listget title-info :|name|)) (il:listput title-info :|name| name) t) always?) (il:windowprop window (quote il:title) (il:concat (if changed-structure "* " "") editor-name " " (or name "") " Package: " (package-name *package*)))))) ) ) (IL:PUTPROPS IL:SEDIT-WINDOW IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 2018)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (9049 9957 (SELECT-NODE-SEGMENT 9049 . 9957)) (9958 84520 (BUILD-WINDOW 9971 . 15811) (BUTTONEVENTFN 15813 . 21522) (CHECK-SELECTION 21524 . 23564) (CHECK-SELECTION-SHIFT 23566 . 24689) ( CLOSEFN 24691 . 27694) (CONFLICTING-SELECTION? 27696 . 28457) (DISPLAY-SELECTION 28459 . 29486) ( DRAW-HIGHLIGHT 29488 . 30618) (DRAW-OUTLINE 30620 . 31975) (DRAW-UNDERLINE 31977 . 32752) (EXPANDFN 32754 . 33261) (EXPANDREGIONFN 33263 . 33853) (EXTEND-SELECTION 33855 . 36432) ( FINALIZE-MOUSE-SELECTION 36434 . 42980) (FIND-LINE-START 42982 . 43673) (FIND-NODE 43675 . 44950) ( GET-DESTINATION-CONTEXT 44952 . 45504) (GRAY 45506 . 45893) (GROW-CLICK? 45895 . 47880) ( GROW-SELECTION 47882 . 48225) (GROW-SELECTION-DEFAULT 48227 . 48598) (HIGHLIGHT-SELECTION 48600 . 48893) (ICON-COPYFN 48895 . 49239) (LESS-PROMPT-WINDOW 49241 . 49610) (NORMALIZE-SELECTION 49612 . 50978) (OUTLINE-SELECTION 50980 . 52118) (PENDING-DELETE 52120 . 52454) (PLACE-CARET-AND-SELECTION 52456 . 54016) (PUNT-SET-POINT 54018 . 54476) (PUNT-SET-SELECTION 54478 . 54927) (REPAINTFN 54929 . 56207) (RESHAPEFN 56209 . 58547) (SCAN-FOR-BOUNDS 58549 . 61092) (SELECT-NODE 61094 . 61464) ( SELECT-SEGMENT 61466 . 61906) (SELECT-SEGMENT-DEFAULT 61908 . 63935) (SELECTION-DOWN 63937 . 64347) ( SELECTION-UP 64349 . 64775) (SET-POINT 64777 . 65536) (SET-POINT-NOWHERE 65538 . 65797) ( SET-POINT-UNKNOWN 65799 . 66420) (SET-SELECTION 66422 . 66855) (SET-SELECTION-ME 66857 . 67949) ( SET-SELECTION-NOWHERE 67951 . 68149) (SHIFT-DOWN 68151 . 68692) (SHOW-CARET 68694 . 74252) (SHRINKFN 74254 . 76989) (STRING-OFFSET 76991 . 78351) (TRACK-EXTEND 78353 . 80409) (TRACK-SELECT 80411 . 82900) (UNDERLINE-SELECTION 82902 . 83304) (UPDATE-TITLE 83306 . 84518))))) IL:STOP \ No newline at end of file diff --git a/sources/SEDIT.TEDIT b/sources/SEDIT.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..7409bd7dddec565c93c63dbb28b1ec8bc4ebf57d GIT binary patch literal 77258 zcmeIb3vk?5nJ@Tn*@XTS#`|I1b~eEwwCR$x)?(_W4_defwbv8GT6b1_U(Sm<$Xsj^0$M**d zJp+YD{lkT^yziUL=FU}?%MTA1j`j3E;va7J{n0{C{}`*Lr$&>nT=Be7ui*7~{odG* zTfH%_58r%m0N+QwVSF-q-jFwP#cST*>^F}VCd&(cx$ZB_l>A3Zwd&*kK)F8e*B5Gw z6AO#Al3zlBY7MaTFZjjT+3K0Pf3~{lFH|MR4_BI~PL}-1a;-G6FniW7SNyrsT(x$# z-5;Al589AlE6vXqCrWj{N4jRQ?wR8JLaF9=?%(5&x{jG$t?luvQvzIn1x027Tdv0+ zDNU7XrOHIfA1qcDi?e{v_j}8=I)+kNs8uHyCrXoSdEjiVJOPSubUM_~$Sg$uOtJ2d zmr50Xx>hO@^ipM}h}NYEsXJJjoGqON?6aj}y(Hb4q~avNELSUazX)WNE0g7k;sR=( zDKE^R{ONKXnf`dORwq1!qgI}tS@7qIwdryNEj8z7XZ`xwx$)|39Tm*Lr0WHutvEkl zLaUEU`=!T$gi3MNwl!azI8~f3`IX`v`fQOQw(Rj2E3>6~-LIm%+L>~_G&CQ+r+dIiyBz+FV0d8VgC(AYG(Rm16S@L54u_LYiK>z4)tKU7;Q)u=3kF|o| z2Zu%;^^f%r_-wOWnMN5<3T40%tpFBfgcYPr_Hdiu*;X>-RWORP7+76-uOS-=sHLeX z@E0%%+>mg;J$iBugYzkJz!{M;3p6OTodR(U0(^{jt~gPv)}eU{tRB!yNe~i%1=2`hK>s8R=$5a5 z`V*yj5}Z0w*pgC7j`BH7+tPdT$ zfKpb^18Qy3Pz0sXssmkk|Ewr461Tm%UocXt)yS!a;**OtA$7$xWoWp^FOFAhDi<;$ zQL4aaUXsa)#74GWf(C;)k_Oam?f35y*=FX^(%E_&U>p;)ni@dZWR>FzLF%}7yadH8 zy2MzX2r}7b>2b=m^1FeUkX08U9b{yV1vV0jp>n!ht5zs4GVqwRg*6g!Q7efk3Lz;1 zEN;dPc+ap1Xi%}N%JR^%v(!;6S}C0gF_|zYOqu8(GABw@XD34?952sS>r`c+j8gIp z?crkmY`{+jGSQEIbz)+%hLkl2GczXX2EzCHc`$i7HROf7@alNT|<(&Hcx z1jC;Ja-bfdv%t?rIp}Bur>ni0_$r+Sg6LsQkUIr=kOLuZc62O1q9!;Gvn$Ra|BR0I z58=BQ*HQKW25dzy%)`)HtxhyWXn*&%Md$|VOwjkC#ZXa+WYf-)<*R2ZROj&Cpa4jf zg_*^=FQP=X4EG2IvcmBd9xqLBz|fLV)oAol84+B<;wfcn=MS9`)`8lYff6`Ho2dqX zIG6;=s&ggiM4IkdDn+1_J)@Y2B1y+0;D{P>nFd1+)SdMwz}G57+J&++n=Qgso2*u# zjmBnb)x~KMT|*U%EGuQOZl$?#Iwz#eSp`K*fdOzqo1jJ)E9OJfz;Px2=RrXuffHyR zW`l~SQW7w0CHYt{J+=t_P$tM$WMZH|k4ysLN)p&zusB5lL@QTlhK1XtO{arJqKr{B zey4gC95TENVh0iZ*ezd*4Ah0eZ`XKGNw(n8%d;b%FI zp}*LWSqpG%(^=IyihJ8kFA%7M&6wi+cc%Wa(sBWvzWNLuLfiDHuwkt6W=$3S6KAFwm|k^Ugb!8Wk`L#K(4a-26aYaDg?77_zyA*v<|qiJDAZSWCY(xS8;Kn zN@<|#g!~(ySnU)CVR*$B7X<+`21PuMxl(&`Uev6Vw6qa#pdP3WGzzI0f@+K*yQ+&Ee(q|8_0t~=*I)Fx8T6lEGkC)@OZ-W2(uGEz(aG%Aua z9JK=8a*VYo2rX9Jw1uj)ifIx2DljcaFbkhfh^!i$GOj}+v{aFl?I@||i*;bfA%O&v z%Iz|-Y~O3mad#0A*Ns61#Q5qjoPjJzI=D}J3Xw;0WS)tsV}7JCrt?c<=-dReRh!U> zr9d08Y@!JXRS?9`hDXOnj(3k8AHlRW-ny}!Cg`z32f&FSMHoezmRUOI_@Z1OM>WhI zXfrrw7NbuG7m?f#^;nsPcjurBJZ|t)5gd$!1v*Ft+okxRcOgtV& z2#Ph-bi%6mp$|V#f5WH_*CEQ8!U{YYPJlDS4vh;QTlG{O3I^rL$QEyH#+$_N&0Y_FZ#BPvxW#MQocTOUW-j~aV9m)c)L(NF zzr0&J_YEFwjxyV9@`==dmf&Eex?V?)PAjgFG4t!C;{4=JvF{^;?; z$MS;(iK$tghqST6BV%AP=gqfKsi1$v0_w035|dSflfY7TpwJ5?8UaL9-2f(0t%?o{ zi*vbB0RfR1gRXBlci?rH84O2MQ1SppZ>Vkj2y?&Y)SGxxj>x;sCByY=-o( zIv8Zthn))U_1;OPu(}^paINPxZ8>zn^D@xLOQL+EUU2L9Ymn>WG#jjIcnTEud1Gics1rHIxga&8)a? z@aZ{YqAL!kb7BTQ(O3a`Z8s*<)&qF=nQDy`6&69kpiY~5)I#iVm|Yc+wL}~Sxruzi z&zJ)lnji7*T0Qks5x*pv2c;F>@Uz-Yco(YLP0$#QJ6(nmL{YQ$QPyQTGg6Jr`7%k9&>f}nOnCw!8a67x!#F+c zx3{;q`A&i@79E!#_3pR|F87t8mOSt9x|i|U@4~0G>+$_0K0Sp`d%Wj-d|G#YX|Lz= z6Vh55e(L_w%U+B3I_h>&&GC=tdzmGCTJqLh(Vy2tpOA4wf0~7qmO2KhMWC<@t-@G= zLES`=;ZTQJMjH@zwDknh2#vQnw}|RUoGbB?&5C3wq?#S+Khl@#IE--h^5&XePI?X3 z!Ki9{j0?sPfRNm=(BgQI0QM{h+k(>^&*}s$Sd|^eN(AQmk0YYS$-hNV(2A*Q;-De! z=k!3u!pJy9gLY(&i{5a=i2N!r$>3uEfcQ5sS7peXk&t8|6%&ac>bxc*(4Qq5NBm?w`Lq@`a?77SfbUQ9U552!8EuNQ)a>DTttJX)SB&lYQ( z1xC=GX77v(Qwh;bBG2TU6ojYRAktU;us~#m3+af1X=KsOTBH>r3S`H+Sdl6zKm|1j zb!P*v=%0KK z__TSeH|fbIr1doV-+`VC+~^3DE%WuivlvY`gH zRFPqIA>zx^0f*kBLjlENBAZ|dEW{xuUNno8sKOwcQ;On$a2h><=`&|m@vS-zJH`RZ-bk@hDjVxN>~XBlR*+dM@t1CcFQ@W(LEu;wG^#Nfs*#51_e#bB{rz3AO(NfEQh7OU)%zOHKK z#Qugk*_ecRRQBQH*vaM}87UNwahfvAwe9H{i~?OcU(Iz#wC|R}G%*BKqM(!zm?&B0 zhiLLE)B*-fM^@K0kc{mefJn_;Lkwhf$B~QQ+E@zl)EagQxCM#JoAeEH>|Br%jPA1 zLZ)zmlmH6ul3FgJLm1STubmceVsdeA?yT~GZZ$$QUN=c7>VRp5!7aX4N}z7hM@wR> zh1mqRZrZGDEnOAC`Z^r0(O~S@Atvl$Iz#g(xOVS{mR~6VYOIBu9d9cf(2V1YWz55i zG43@}S4!51r$ zm}1FRCdJSkJaT&FDt!(Ht~zn3L9qBB&~EIJmnd$RIW zG0fGn7&;G&=S^f7D>Q+lEs_;pY7*>~wJ<7H$KC z&}2u43*G(s0j%xxXYGPd=lX#vrJHj6(~NTF^Zd zmP24tz;Qx-u$B>6(fP$$*;%Nn->w_R7!#4BQ?i>v)*cYAf{n6Bqy0dWA+8shR7RsF zfFZO{2rpaa1;`=3bz8k?55c%#N{kC1=&L0(0%T(jJB8?_FK~M-wm?CeFz+6GZ#Qp1Vc0#F z=Vt}TwhgomW2$^5=j!PSy{|Q8tyjV#Xj`^gMFKF6d;BcI?P|enxk$ljxDzD6cyU&@ z5fi;sYGxv+WYWnF7M-y4?D`|(F%guVE1}?zhW7(R2TLX4SQX<=u2PAyb&d=BW{mR_ zCl0`gszaHdp_=Oc6gc+4L|QYTT3W-EcHft71jRK1yym?DJ!DQseN z3y}@X5`_orky?R16?YrxR(wlQNF`Al+D)RXM@$TL1hz;7q?OoO$PvI8&XAGb0|n3Z zD7YffeCmy;jg8x2qxPxyX@aF?Y(8t=FbZg3Z67A`eQt!=iP_ZdE1thWf~h!m!0pXe zI|Zr-n&B`QL_ySgCs8X_jXO8AuRxgUs7lfoU3Ys}Fzm{=+z^c`4TS*$%eci@=nkr)(E5<3i zZJgo@7IsV(fJjZIJm-o*EM;C0vdJbBxgUXH}h7-WL)@*H1lY6q|=oln=&@O@%3@1IIOoX=F`dEM)HGA0iD|-rgj4NTWR9lP7CsEX;c#KD6-;gx$Dsl4=@Df|1c>?wBP{GD(me!Bs``L& zQ{0c1r*45Bt>ah^woema!`N;q12Yx!DL9RN)2+pxQcO;uQ5Gu(wt!Gzc;#wY1yNfM zp1~aAK~d>6rTCuh9vU1h95ZtXavKX>y&7Q{35?9m92nqS86ifnZT3Mhi|{>(V!8zW zgu3B^fqP9IJ~xjOH>Na^qLT(NR*a6oklXtt*1-kXC?!F6Zdhh6K;aVmg#CSH_9t@< zV6rIsncKQ$>M84QrXdh#aef|0b5PaJa1WY&jR=2K7oiD^jMli~O!WhHf_exL;+kSV z^bU$*DM8Z^#DIKuajt^4#(BC1TkT7w9H#@axza=s7^{&pT&mer(b-c43)M5&aH}~c zpl?rJ_6VG-2Z@JXplYz1h(GE<7zpIVqVOYN*TYV7=wVDozlt8F85c4kXF1*?FxuIE zctk+u7%1wZ0gjjK)Vo}vLrLEh%6773zkp2Q0Z^*L0%-VCsbvlmTCW5XZ=Nl5G!w^1 zv^CD1vLT2w!Z`p3>n1oZ%OqDAfX10kmh>>ct(=8X0M)^?kl*MzOro;g@52-VZOfXD z)81f)N!>qiR^zlf*H8d>rkDbY6DORSQ3e>zGm76z09}2|=Kv_Azhy%~rV=<-GlFvp zI&U+%PVD!uZnD;9gok5NaslBMk47TQ94p(x^Ju1!MhKKWRc^FYSnmfKK`VunyDHG- zv^qWH6va-Wg|xciV;uzcu1-;Th2aSbJ7dG4vKh11hbExL%)VtaIxr$O53`VFpbAwn z!W8v6%xTD5HsXYX)ovF`(lnWf;C|&P7zhajYA;kIOc8}80V=S68L>BT1GtR)rsRx| zzyZZPUWGyc1w`}OxRMR&i+_Z@yjamzZ+IB=bOjUCPF1qDszB<2%P%t_$7J%R{EZ|HEFlvEkwl)Kh4KM%?Ybg`8@;C~D zx5S)J0za7Jn3FAXxD!lJFwSVVA$>D;;$}y1K7Dj}Apa;19;vHovfKO-=q6bk3>3 zr7_%YNRk_X6L4&7WN09Vb)`e1Xmvkf;r*bW`{o7)t^M?QIE36m>$ z-J|#;$5*q;Ok6A)DCmqe0fyE=5nCw)4#%QRGyqI1D^%7)*JV%L&tV}tfo+Qpm=i-I zJxO#}I9N0Wg2mJcht3np`mRu@@+zQ)snMNh^ybL!vHbvGE2uB>rK%Ben&f*(QGwOv zoW-QzU(d48Pq3b1;ta5MR*@rmdd%g1nl~OV=l;(KBjyhejf^G7tB02Ds>A*^`A&j~ z4#;N*aa~9*pRA|ZDfnINQSK!CF-M+zzY7GE?L=7hXGXeC}hR~7&q z!GUEkGD9CfeA=tM*|N?fj=vsB;>{IW8FdWR6>CAGR<`^K3 zhsv6s9?aH-ax*1!u8JEJTU@VET$$6T&5=&KqcElr zGg|xx!>C6DmnSC-yb87mb95|Xb`SW+5#EbvIwm*;c3j7JJjtjsw&S5OQEO+9AL|)P zmZf^MD)Rm|mT5pF_H9tEQA#MQ>rid>ls7m3P(ID{ST!E_FLXv*JdG64Ve_jY*!k5V zXGD=Rk{qxgXCzclkdr@>??09-9L0_lYJeX0ZqOq-N7X$<%|z#9T~{Yb@y!3mNd#x-b4zxKV1A`&BKZbR%#H>+>#GIfa z_-^!Q|8VXY&X;E0r)1TzGCk1HX*yNbEsRt}qUNwLY(qp&O0Xbi;yg07&|@ePQc0XG zXwG7n#OPT6*l`3`62lqg(U0=NA|}tlfPzGalTk&xJk)cdCaqqRB@$CQoMR_2 zR*5?B;QR5e2?^E)bG_7Tw83jLXfT|4Vr@B?qtr3WH?r#umO(;-hW!&Tkh}v4EC`oiK?sEL)fq^EpEHKt z!FH85VN*;U6oEU-N+GmcN4!fPB*nSR9+>>kDVGC`$KP`ZEJk;SWy- zWSaqRw2M}t;^Z!<2^}pM8+gPaTZj{;XhKt&@rfeSOI|pS!)70B@T#Bkv-e=fgd)8E z7&c7vm<4u_>YcLL{(*zY*Oh?;um$4@5&qR8wgd{r zxn=@WXT~EsO{cI}_R=LGidqshVI+W{n+`FJgE&Vz6hp~j=`L~w*pvp{P8VlExA)~! zmPeQuB7#wE1tnXG3nyg5rP=1ljyhmH)m;BVwr42UpQ1n|GgP60gb|QMY-Td-*O;={ zPKA9pI)it1RQIc3IUZ*ZxL=9lrO`^n`Q;uoZpP%)iWnBm14$DzRbDn|u6dMspxMcw zoq(N&P+qotX%9i?*m{MPN?G$_lj+KH3^^qo7#AD>mAy`lb>QsrY?99Qu$c}!%$Q6@ zgDasIR>n78@yMj^yJIm4@dTP*W>VO}&J|o}Xew1KHoE>fL*?d1@QKkMkn#lyZfHb9 zDuQ3+vPS1em{@J280{k=+KQdSy}9|7!aE1rv{VCT7_rxl6CVk0S)Dtog+Sy2rK&-V zcuYg@pVV7}#m!u(;n>kEch7ZGfpXMHnxKMvWQ-?KQgob_aN~UdTSrA6{CBIowEFK( z){+v;u`=^OquH2&KqnqVK5Wf_h>1sF>FblpI^0uj()d0tpNw6_woaPC16vxgSl&KOa0kkQ48 zZVoqxr9$B?#Gq8(v;D_-j3|X-ra%bwj;s5XWc>{Y)*q_VfJtrRsd#U1&c1gjEgJk@ z+yEGAn_nGF?^T%I+W@BbhUztdiOnTe6a5b{RlJKJ035`6<>-WO4=ftfD!cZ?63Oll z>I}2_UkXr7!hZz8eP2cdt_XIQ(Rz|cpsPr8Ih;fS=to;W5d#pYg?B?tqJ9(T8h7kW72L`x#5($8Vp5p$z~4#kN&Ywk+y=D z)H25?c!LEQnvJ3wF|tQ`u`mlEF-S4`H1G)`Vuyxx+i<7{*Q!Ag7-sPJSUxRmGPsD1 zYeC55fi_KWZ1a9)oA)Fb95}n=Dbozy%=33M^nbG%4PiD}scPDCG zQ&EmnAb3lMJa*ttgIne^c5NQ}D#3HIgGjiSJ30;b87GHwB4T34#UezL8`tq%cYd^h z;XZ2i;~L;10Ud#p1EU*({RZJ~Ks3s8xC45b?aguy$Q(#d%-AF|#FGa%2&s1K>g!4U zvq%55>z^(<7E)@jCfw~3_BGIi(o58tvRA#-It3P?~PmtV+nA=-WKF$Yh0A|@vwwKosLXzKM)A1*&BOD z04TrVy{u7^dm2q-l%kJ-06F z+@FJ*D8`q&Yy6AfdtEaE7K zA@E5=YBdyMJrqJkhtw-c;Ytl?p~$6D11UlCtfwohRmZ1Q{~5D>h<81x;xx}uXdhf8^`FNT}Q#a!x}Wn zj`Ggp;e7Ye{E-ywpd@lle8mc27%jt!mXzS0pk??f&_exey?Yzd(O3j*2WNa3u?Edl zP-*g@Y>fMnG6^+n6Y%WMxEK*bA`WxnhdA^Z?@H98(SQtmOFYWJ1Kj29&d@;wG_v`z zv3z$Q9~3&4vX4Z|@+l$2KGLu^sMs59z*K|bN)4FGzysr}VHd+YjL^yc2w=(WVg-}o zB1k)77p)DwPw3>LHD)bT=PmmwM$PshY+>ak?cp?WH03ZDO(ajiF~$QHWn@XN{0oU| zUukw;dZMU0uO)JWAgF8=Z9KMsg)>AQd66ez4`h_ zCHZHG%r}4bXN_`x{L_E-z`h^setCPm(wjg2cdz`_H@@@i^FL0>`R;eW`@##S;~7^_ zM{>@jwT7Jk>4oWJYd`zacmL1twtaOhne+N%-~Gm4edmw9l58!}vrTx@en|XXCTFS9 zB~DF^bDml+*C0k~cAUgL)QxjK@%D3{`bo5g=VhOJhu8FpjeUb%sX6D*_w^-mTKyKU z>6z4=U5C7;3j-;2TKqh6j-ET;5${KGmg1@Q`!YEARUPk_hMh~69^t>6GiyQ9G%{>i zI**(qpE?&VE}wneY1VY1Z=f$x&Bv*4eWygk*i<-*0=Lahk| z#9QX;n>TOW7J@*aUb2wJ1{&hT#yPgG{ksgV4c_$DJ6pcvQX7F~wCd%KAlRGlo z4BocB_R><2nSHLy`xgdp+qUiOisl?9zX5OCw!VBh$Z7SvJmwH@+qUcsGQ8GZT^;|z z;O(=K)>?c(VDJ`&pv4E&OQA+0AD6+wD(WO~EqF8Rw$b~kb_Kk7e=l-s*lk;8gU#8I zd7H?oVYh8fnRnfVTccqYx|)>V47+V?%Is+A334E(hTVP*Id}0^Y2b}@`ugxt0vNH+ zyBj%8UCi0lwO8fTu-o044cZ#<_BP_}c4fEQ?^^n)LIAvZf4_vvFm=2@lYfFA!5i5F zIZ-aTK8yxE=%-(`1{5#Fv0}eBUFh<<>=*a9<0Nf;({grcPO>%eHl8_uBnd%_58q`e-n;#NgL5t|dC9IiPJTr2mX^cu9NF}Y z1;_nWy!Bla@ph^FAUT(wxsc3h_1RC~mXsXDTS{x{zokL&EB{T=euFt=Nn1_+Uap_0 zCJgE}UAhp{lFUmsrd+jfSCd?<=)22(eZR<$Md4hGeC1IdFZIH7|bCRvK zXq~M|2qb4I(Y;An4m&H=fr}OUX@Z>MC-ZYJoCkZl=I^23m?Qu5ll;IBfdxFW^{z)> zdNR}g8#Wn#jXk~C@}ZsipLX6I%~|vPOV9ilhw?AKnAx!-lw<7a+x)JbnOKh4)4q?l z9NwAF>x3D~HP`ga(t2;J-{cbHL&r(Zs=L;ETar1n3+s=b`>hZE z`tL<5iJU&OexUDS%eIzS&U;|z&i5VJ+Oq9XB&QY4H!Z=OqK+TU*_A;*eXpRkz0uax zo}N2;uKA8{Mj^Nv_B5$m6im@?+an<3i~1qZZ~js&tK(#m8tJva?Ap{G&B{Lauma=OxUKJoU0eLq5zkstBWKGEFU zzb%rCFWKil>NTA|f4J}a@f`7cpFvKdPOJKFDXpph)_1V)wWU~dhTjgylFe7(;5`j< z(leIhw{uIVlkt8cH7#yCPJ#;OyO@*Fv`Ef{b)P!_^t=Du`{~r4mp=7HsVUkY@#Fx%+&t%Q@L_q<+Jku7)}2XQ=_ZK_gx6H{FK*a9-bZ!OMq| z%t!bk$XR#vav}?MVX5iT`G1qhpgmmzc2fF*J#Cb;OL9_LgFOY*FZU%O;Jh9qZSZr0 zb1q%>{6tS3Cm~rEywn`f=fe7@lXb+NUOImKTr`qo~I0ty6oJN1FJx$ALA>Mv>Q^ett_9SDAU$XOpGy6I=h)#dw|Ub9kQhLethY7veds zzUFL9=Inw-x^TI`<5;|}4Jui~eagurmNz94-hy-7Fde8TN^rgEFT)HciCvtk>;(fPm z>ul+HswI-sg?`rU`1@@;4juS-c!sL>^o|`(+jjVC&-tvj}D!>YoCaBHH) zE^K=4`&<8c3<4vkp;m&AenU>gNSA_g(ND|doLlnNMhoLx$H|l8_on3lf(twEew9lx zkst9xF6`X7vnP^_FWKij*4er9iFi({kDQCh=}P46LeBZWm`t|T!aC<(`j;;yAds9T zWT*ZtgM+2i3P}7_o$J6sCJn2IBW*d9@%)D(nPz=q%MLgq{!%zgJ-c=9*^z61+<#gY z08O^cPoG(TVaI)){zF?^LR^=94u0>_GZzl+*x~!3&`>Pi{aKx9BCtRZhvUg?}fOog{u`yK^xIeH#moQi)lB?DI?om#9IuGj+2Lx z1H9qQ-PgW(IRskvIph#;Ej`fZemsYG+tl@3?Y6%T<+S?fhj`oD_07*l=Ju-J`Y!k_ zJ)exWCi?A}a~u8NIPmfRI|4!2e`|v88U3+%%lvgT{Tey(srB$tZrvDd3;OLc_9HdQ z`NZ}gZEC;e9gjU0_PP*%>uUPM`tuh%Z+XWjKbgomfBs_^cC7ucf4(7{)9Sys3;U5i z&73ErIlGW^q3`^~9cz0&xgqS~!Vf`C@ANU`JhuLCLx4-pQYazv(c&$VC|{Zqd%kSK zn{qdU+q);*sT$L;^zmu+`59_6j3*?v7EtQ!)!Ul1ox zafI0K#t{wK&Bu+U=2ifEsBjQlNhiw_at@Q5SNS>uclz0W-MI&DM}53BfvY?wefwOH zo-K1_XNr8^n|HyRD_z}1FZNzmY(jP02<=^7ykUnYA#IOx0Mg#H#7o2UV1+qY8*Jo{ zY@?KOY&hY>iUs~Xe)o2rkBueI# zXryJiohbA$IUnXVn?E0LH{iPMpB%StBz2oHg_F1Xq zwra-r)#9~ab6C%8)(t z3xL$v4R7|}hBwNR!N3Z3Q*4OvJa$_LkDn^p7tS(AyeY5o#!)LK=I@){FJAlEN3U#_ zuWw%Y=tpDu!Phsv|F8P9D{tzC(>JdiTDIhmUw-V3H}_8OdSdeRD~Ia4UkI9sd_tQ) zet!CmH@^Ms7hb5JzVgAjXCI8@2VVf^56+x<FLr ztY$n7-*?@dl5afw5zkxqgCE`b6L0+!PyCz@qct+LE5Pf9h+mOYevFKk=fLMDLl8 zZNF1XYVZ61bI&_u;p{jx_2L&Toap_Mz-dOrk`u1v1WPu%5qH9I|@;yd3Ug zna@`v9jk9M0q2#=X>#<7Ta%dgx*X<1V6VMNCBOEAj~w#Wz52apuHP~CQGh+ zg}p=KUVJ9h=Gxz3$;>mKF(qGRn*t}~=*5qPO0GM{l51Ys{Dr?0ID?WC=si55H5+G9 z60Lk&NXNJH z&&x^ZQ&Vn^9Id|hS1;Xv=TA02wfP~hX_L2o?e=}p{vH>x&i~*?OCgAF^9`~K8x+JfF+dO6zrtC#kF>!rW@#<@RWNvQt!+=<>%@`>{;w}d+P0OuXg zKYn@Rt4|{P4)6BuozHJaNz;3@O)dGYZ=>W^@Al3wf2H#)jYf3G^9L?({`~hI^6*^y z?VXo8zx?}u1}q)&=6~?Ru2A=HH8n4XU|H_tTMg%{-}%hz%fV;!K+QY9@oD>QxxZTS z@^VE?-mTuN&(3{%btPZ9b8gkW|JGHMTy5{a@%rjYuBMcSpSPOsZ!MfJfBt*#`pEab z{AV8_Dwg>HFMaFVU%CBjou59rOetpF>iyf>zx{_&a)qL|dhDGgpIEWvOW*qTGpp&&Ef3k&_&?^DtN~l z?_0+eGQ8(ZLV~d|2o~8%7{>5j?BSZBmK6sLYRB% z_a(4Txt&gLR|q`^tCu0!%NpG1ap|3gYeV$bC?YPy)9ZTA6meAr=;G=yDvS7PFkCB0 zZX^Uo*e4h!8V%jlXR<@=#U7@sxTUBa7eC0eO~ACdFiNlpNeWsEqRPpOhJ7D*9@%$8 z^ny+M1Mw79!<2g61>P;g-3+*3%LI!%J56Bt1lp>e@kdJ2 zygP8PSi#-IHC`Q{aaA;O8rnkw*EO(;+=VBvxmx8Cgwo~idb#IN>*~da8X~S~`xIpb zMJQ~gDtn}~kW)x<3Q6`zVJvq7mu(N7$c+?^@O|cN?_x!+6>Y;EyRqWI^$mzkbF~52 z>-i&v{3z-j%MTX(u}6msxDn4bVcz0ucmq@L1^_un^v$UX(1h@EjaN7LA~G0?j=)?$ zThx~*!2!6koVo^jaRyK5mT)f`1Jk^UUf7!#YH)p|hNcxAiZNiPBzFiR8IKSMj_^om zrF{%C0n`_HC*^nvvRy_|v`$EHkA#E6pqaPbNsGIonDM^aDRQ^wksM(BKt0H{6-FP= zV+8_C-mf-AYoZrn9T)&f#2e&vec$>KuzPHKvu89UHBwKyvZyjZVSC-}ZN0LEoIFvyFz1yLF{ z7x0>Uq9!b@OxI?>_R=r+A_=+btf7kXX@CcUU~hkud-as2F!OlF1($Ce>_)4&2M$O) zsJCQ-dfCz9=~7G(NAvG1G?v6|kS;Nz2xSl3F4m#$Vb~oCkGB>JfC5ldf zBJF#5E*}^g1&jwr`*1bYQ6bd9Zl>k>AFa>wz? zuHL-_Ml4t4DNYK$8WAE(=|J{AL7OK2Rn;GZG7s0VIz)W|K`3uspXOtqvNj8gp)J9n zC_E1e9cY}81IN)kTdqC( z7+yma6-Nw~em(%>FDH@$D+(!yyt*h<*)kFKIY0#fw~#$%i(4K5VFsaQ&OH}{MuQum z%>9R!h7@mkeb`=Msd_l@o|3){Dd;B^D~6?pnKwxqR|tLr{E?cquN)G95gx-|T)m6; z#lbYX?Z8~=w%6XqPA?C50%q;C)v!v%Ir1hH7w`siNru6llXgYD`JNMeuSo9ltKXBo z=fp^UI5(UhDI6QU$In{cZ}TI?mK6|j7?ja*rPKnRG}k+?YY9mKH9-;gCK4_OEzgq0 zMa9yf!k3uAby$FX2IH9EF!uO-?*k};v%tGq)dx6Tu9qRqc7|v8hjxT7iQ|HLAOtM~ z;fK#Uw+j{kO&b9czU4Exs*oTaAt;n6P=$DGSGsJOlBw0yREzMGy8ETcX{Tr{09518Pz8@N z+t*5glyFs&fG!7SCh9~PIC8{*;D&u2Xo%`^-HWF5H z{h__Uj@bF9{G<#fj%lfKx?HPPNH8Fc4^9IA@?f!e3}z}j1?V`}oGSATbIfx1>`9~` zSVLNcOGDJa>Z;Gg}sRA5wT)2S8hOD9^b0VKrQXWX}) zpPZz^VEfs8PY?A2H`|3V6e<$NlYg}ED2hWkdWS{^{ar)D)GByigXuEIHEreah*STu zBR;QRG@n;OuUMzLJXHleWKWFrkD-ND|Iwl2Bdz|>iDRumPIz?TPB}+nCv^p%Bl7`x6P@yEH<>pGoT_V~HO4|FOF_&;nQGOY?LU{-$s3>|0t_kQ< zg32yQ4ipxQnYLV!vB49|-r11yzi53(?e;k`ieOKg&1S0!Lw0M z5b=$(bK{VAT%azmBQ}psJ_BlzJm$^1Nu$66NqFJB~<)ISniv>eN zFQmkF;7>|N2G`1Z+&(NA(-|pMO&n;xTQFM|MJwVAsK+?a*w}FMz0AD88sE4rGG<6r@A<#*#F!D)QP4+BeK4PsJIGn4WEp!-U+74;Or~R`JJZ2;oaX zu};cs+(A=his&2$lw&317lhD_JIbwJYI_snR3I!G=MVT>8BXRS`W6&k3<^kIgnNs@ zi#JXEAk!S%CiuY-tUL*LiLV79fwAx~cR&%%ku@}OkJh+XoYZ7NLs!+*0e@JZ*vN~{ zg(hm{aa1?+Zx^Vv0_Xq_O&3(UMQf`#$deUhKV6)g(rfc6hFJ`3yj+n9qg)pZms}Td zSX$Uxc~D`+2z$W=<`RFuWiXe=JVUmS(|mE^149&lC~w8wHn04OD&4FEwW8&WY0u^1 zx2d^Od$SzmmKv6yv}r*fL*NK>h8O+9%U#x-wKsut?SN0Gc* z$*C2_l}4f1sPf|jf_WthgGc?~H|xR-o-^pf91@O=^2qVw;lhZ#67dk)3w?7FQd&x2 zcuXTYv7SI>Bb;*d!}9KNZJa)f@J3phN6}vdb*@KKT0~o7J2vu91!lo_a?U_J?5N1t z2szhiv%@9C07P@wt2hXvs?iDvEAb49(QRBM0B6%(A~(|Ov787mGRki1WLsAfZ*BIv zrLkziz@5CeZ6%iwulJCDVROO6wrdIpG#y;weBj5D>a>vI5pc;1_qq$k7kKK$gf?RE z2p`eH)xkyNj_^1i)G!*8Z2OEz$XZprY!Dd)cFZi$xo3FYv^RfzU@R3w@xoVwBNeh$ zpeS(u4Aock{xFr1-5XJa!M7q}!{{LPpbb@fOs<48I;H_N6@I+#ASw@u2RUf0N9~3@K>Pgiv91EqL{H|qWJAzqqgZA0OXgfxA5N}o^Of;%10pVwS zr8@N#1B#+E;q5?)kkB|9R-7&4Ju=--0H-D^=1-I!v@W}MnwynOP;wTx^W)i~v7pUR z6DUUbAmb7*3L0n+pfnZXx8prfXmSkCIpu)ByrqVgEMj;(%V;#UXc5Si^w1=zVc%g> zFVeMY8xn0N>+88uJ8CGr;emX2A(u+@5#7NO6b}f0U$6!lymagu$;s;P%4};k$Pn4~ z-Hd=BBH6kO?kFJ?pTlZBqbLD>;iW^9%7ekw@j^U1L^}_{vZ46Lwg9!EYd1@x%ETcy z2J0%j_pJ;Aj>TCIzWbPT9H0Xv(JtxIHf9aF{f>#%TaL7`fQdH`YNCmN!j`&Nw&KZB zaFH54*Qa}FW*?s%L2M9_xEiKj{XEV&g?&l7N`dlF6fQdpMTNNG;9y~7HzE`ALTxYj z!-O8fEwy5BrYSuB6FhR?d7lr7)XgD7F51B~**vmPb#V;(KZwaDNTg3i#m2o&UcD~K^; zGYl+Rt~VA^4vK^szCi@pcnB0gOJzgRuRN-ut55QoNeEdV)gBOlC11mCN*X96^Mhj$FgBk)0k9@rrn^9!O zho&6=o23iZvE!Mnmg<$=QpXGo?H}fZS)6;L~upjx&b3t zdx@?!OcXV!uSF?@aDW(5smUWWmZ9u4L6wtzpcWn^N`o9+jtc}!F&h>y#bW~@bH!K2 zmLs)cQ*;f)tRQT@l{Bh_h#O{vk9-zKTI5KyD%a>5De5R107?X3(S2HVEPP^~tgI>I zaS~^cEx{KUc-{AAeEY>puri)tWlE1~FUFA*y31x?H#)7`5GV;+AWlxKRtqM(BGK8w z+z=12OGqB9(~rrBj$bs848H{6>4~BdFj*Cm2beZ7>ZMtDUDMdhhc_v~Rk(LRq`;_* zz$*a4>A$fdZXDq%BHS%#5XA{s3Ht{M3ABU?T{mXz_>)@w@KDdA*f#?AUq(wEN!`Z3 zSU}`PP<)gXkqCZlxv0v+Lxs|u3GLY!2%6yjjR*$e+UcDG;i-jcW%|FeVsKxZCIr3( zq+xi}*VT{Fm7KMZT~>FRemQqq(x1|nL)JOy1oYyt;(Sl~QEMm+D1^xg_yO_Dvo7Gx zN&Fmq0NuT(alFu;3M~#F`e5@x+C)DmJ;_HSNGV3L`JhY-v@92~(1mOOaI)W(Pn1Ba=09YrvH_JO|07cg>IYJm>o<{)TU zxuJtG^l}Anc%mVO;$ldpEkOC1A{G)42K<(rsu;95<*7>E#$oI-1-r+TL!T`NIHrl< zQVmz1nK8}l;!lq3I)~He3ws`N8iUrz27J(tpfPnd0Oed;#7=ayF{-$3>~o+{Q+R1O zv@RL!%H>j~0*6*pCX@NYLnD}1f_9iI9+YpPsh&*wQ4s-ZWqiUVsH2cB%+&Oi`XW8o zaR2O;lvV#nZLqK?+H!2qb`9?|CY;O&kG{mN+#fs_F0_{2XwYVMi3@5|^ieMGlylaX z$r+C@r##CZ#2sZ{#u7k5$$Ffa=|$WiqqCF1l@i?*@hAB%?{u+-m83cvRAETMAReU! zz;tV-K2CC0;n0Ic6T^!%eIv#u4XV(HKZs5zp{UOkp-pqjtY!p(Zj$8>Qbf&$o%lw5 zMcDUx75)PLvM6;7Z~*L^*&I+=Lngi(L71RDoomn#As$1ht(laQFs3CkgxTD!Iy2Qh;;UC4xqUL`Y#Nut9zjaQ8jLnfsi z+6%j%)Saeb=_?Sdh$Dfmzv>AZI;4q3fK^LFS*LApZtj&Aa`Pjj4B#~9NBsNmy}#4X z;YYW61e;SezF+mb7izP)M||$VgwQEb0!XP;9oXEzEP*q7yb2Zk1%zy=Rt-l49;^h+ z{O(-0gVE2jGe6gjo5u_$U|C=rg@Ve<5w0L1MXi_cATm}f|HALbFxp> z#vp(+6M<;QeWGKazD8IA-Pke&H93ceo@@0MYpwL@S2};#{);C3N4f_NBFsSbJ=p*L z!pJBpm45SK$_5?S>Rj?0lm_$cW9u0sQ*~+ke|(u zj}H>C!ieqp_-Fy!&wv)9ZFKBWfQwIUvdtwA)I<>ml{S6tChvzTzm9 zi~^GM;?)F()L#NvyWuGvMH)|~(LCrN9kW+k$CM|S@^PPm>g`BaCA#FzF-!EOG(?4g zvZaOIE0(rAC}>0GCumBuiEgQu$>58#t+&OZPzW_fsm zZpPFH;aDc^>a*;7_6dc%VGn;TfEGuQaxA%=4A1JhAb4u^AOtLSjMfMUN zV-;3xWr9cx68PnsT4KdWOFNNp8~(YbnQ%=_-yLs>39D@hxD1BNmt~rnupa-wOu`WW;V@n3;`3H`Ul%_?N8wm5&8IhK3MGo*R+ptYD zfz1mk2UAC!xz*;gQ&#wgctY7G97%0K;kL}e7Qh}&(xnV5oO8%FWjk|4?}+DA!U^Or zSM-5cPUavJ?3h{f!{HKy=xgBwV&vDDVDWa%2!9tE5tG6(=F_p`aL}Kg{{|rmE@3;9A>G^+X^DU44?P{?g2nb=p>yJ0}N-QC>^P1a!B;J%0GfRV8uet4FtZna| zHX$9SO(H>-+$7TP*b3JTOh#00sO`+aHIM6e2^9rhh-A5u>?yX-CS0>TbL9U!{t0{1 z$ax#^&q=tbO3u0+?aF{8#fk_tp&@&Yr_+^0CZPo0!Oq#jJLAY=hKOsp{a&Vq6Z+!S zR;@%%gqtF2sZei>iyd`={yM{M0tVW?6F+6WAU8HOU7$h0Z9kh>(Xx(6tt6ix(kK(N?JNXZrv_GG^JPnH|lwPR)1wQvy2ir2<|U2Or})+X{rtXNhou=$`syc?-9NH;j~ zBKZw9)d`@$INo%)VxvBD*tbv>4QD>U6xNomED)^Z><=AWsg&-GWPZoy+eWKIZfniChHVM<31b7k{!Lrcjv*sK9*ZG5 z84g1n)UPAqntVt|du9(iBj9X<;{U($qfKC6WDBPguDLJjgN`KbQdE`5uBZ>PUrHUq zV^PC*hNFCiuTA3etwo^~rjpW?Yl;;~M^2s`2FNYa2Z8BI4uEBaGRzmUSlqGZDqvs( zIvfGSP+pQy$Rfj zSFQr?q!QSbgrSiVSoOG4+GMwGTq3|XiOK#;_GHEH#?sYk|9^aRRZrgzn_Bb#2;+eX zzaLH@w)fOU+yJDu@ejN~Rl?JdNib|_v+92?jU0hV;QVbi=!XBBhdpChx^kl(yE|lgExWc{|C}06>2y2{6`4&7YVghuVgVQz3XQ&Xh5&R zmWYrB(}BGO%qreAtvqCtd2j3v?2U<`kP zEQdZY=9aI=AVtEEHwFOxkD;U5ZFF3E)!XgKeEGlI$vP6Ga@O_1ib zZBs;ds!eh2jN23$kHtHi5D6qUerpA633Czx7tD!b z%Qni@&8tF^t;pHgZ=$l}aB4EQX~|KZN51G70_D!|yfDq1Sisfpj;4H^dVy@r7 zkPL2Qcc+sON%eiHJoC$8TtPL#6q-{+_E zd}d~lEl9Gmb~h7<+y)z3GdBMw4B?w>n*dv2oXT2B@NWVz?F1u&J!hI6K515@jK!yJ zj%6(|JLK5sZ5cZ#;avV&DSmhp2K7oD7?BeK)0xiVHSo()Bl1X0`^aBD;5Ir$HH}7KP+)4iVHW`5_Bbm#@0Yk#axwvur0A-q-hRcFalocal>lde>lispcore>sources>SETF-RUNTIME.;2| 1829 IL:|changes| IL:|to:| (IL:VARS IL:SETF-RUNTIMECOMS) IL:|previous| IL:|date:| " 5-Oct-87 12:13:18" IL:|{DSK}local>lde>lispcore>sources>SETF-RUNTIME.;1|) ; Copyright (c) 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:SETF-RUNTIMECOMS) (IL:RPAQQ IL:SETF-RUNTIMECOMS ( (IL:* IL:|;;;| "Run time support for setf.") (IL:FUNCTIONS SET-SETF-METHOD-EXPANDER SET-SETF-INVERSE SET-SHARED-SETF-INVERSE) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:SETF-RUNTIME))) (IL:* IL:|;;;| "Run time support for setf.") (DEFUN SET-SETF-METHOD-EXPANDER (NAME EXPANDER) (REMPROP NAME 'IL:SETF-INVERSE) (REMPROP NAME ':SETF-INVERSE) (REMPROP NAME ':SHARED-SETF-INVERSE) (SETF (GET NAME ':SETF-METHOD-EXPANDER) EXPANDER)) (DEFUN SET-SETF-INVERSE (NAME UPDATE-FN) (REMPROP NAME 'IL:SETF-METHOD-EXPANDER) (REMPROP NAME ':SETF-METHOD-EXPANDER) (SETF (GET NAME ':SETF-INVERSE) UPDATE-FN)) (DEFUN SET-SHARED-SETF-INVERSE (NAME SHARED-UPDATE-FN) (REMPROP NAME 'IL:SETF-METHOD-EXPANDER) (REMPROP NAME ':SETF-METHOD-EXPANDER) (REMPROP NAME ':SETF-INVERSE) (SETF (GET NAME ':SHARED-SETF-INVERSE) SHARED-UPDATE-FN)) (IL:PUTPROPS IL:SETF-RUNTIME IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:SETF-RUNTIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:PUTPROPS IL:SETF-RUNTIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/SPELL b/sources/SPELL new file mode 100644 index 00000000..e5527ee4 --- /dev/null +++ b/sources/SPELL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "17-May-90 11:20:15" |{DSK}local>lde>lispcore>sources>SPELL.;2| 60991 |changes| |to:| (VARS SPELLCOMS) |previous| |date:| "15-Nov-86 22:33:41" |{DSK}local>lde>lispcore>sources>SPELL.;1|) ; Copyright (c) 1984, 1985, 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT SPELLCOMS) (RPAQQ SPELLCOMS ((FNS ADDSPELL ADDSPELL1 ADDSPELL2 MISSPELLED? FIXSPELL FIXSPELL1 FIXSPELL2 CHOOZ CHOOZ1 SETSPELLCASE SKOR0 SKOR MOVETOP) (INITVARS (USERWORDS) (SPELLINGS1 '(DEFINEQ ARGLIST MOVD GETD FNTYP BREAK UNBREAK REBREAK TRACE BREAKIN MAKEFILE MAKEFILES LISTFILES FILES? WHEREIS CLEANUP PP PF EDITF EDITV EDITP ADVISE UNADVISE UNSAVEDEF RECOMPILE TCOMPL COMPILE BRECOMPILE BCOMPL MAPCAR MAPC LOAD LOADFROM LOADFNS TIME CLOSEF CLOSEALL OPENP OUTPUT INPUT OUTFILE INFILE LOGOUT PUTPROP REMPROP GETPROP SYSOUT CLISPIFY DWIMIFY EDITCALLERS FREEVARS CALLS)) (SPELLINGS2 '(GETPROP ADD1 AND APPEND ASSOC COND CONS COPY ELT EQ EQUAL ERROR ERSETQ EVAL FASSOC FMEMB FRPLACA FRPLACD FUNCTION GO IDIFFERENCE IGREATERP ILESSP IMINUS IPLUS ITIMES LENGTH LIST LISTP MAPC MAPCAR MAPCONC MEMB MEMBER NCONC NCONC1 NEQ NLISTP NLSETQ NULL NUMBERP OR PRINT PRIN1 PROG PROGN PUTPROP QUOTE READ RETURN RPLACA RPLACD SELECTQ SETA SETQ SPACES SUB1 TERPRI ZEROP IF F/L VALUEOF FOR FETCH REPLACE CREATE GETPROP PUTPROP DIFFERENCE GREATERP LESSP PLUS)) (SPELLINGS3 '(BROKENFNS ADVISEDFNS NOTLISTEDFILES FILELST NOTCOMPILEDFILES PROMPT#FLG CLISPIFYPRETTYFLG DWIMIFYCOMPFLG FILERDTBL EDITRDTBL SYSPRETTYFLG NOSPELLFLG INITIALS NIL)) (SPELLSTR1 "{spellseparator}") (SPELLSTR2 "{spellignore}") (FIXSPELLREL 70) (FIXSPELLDEFAULT '\y) (SKORLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) (SKORLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)) DWIMKEYLST FIXSPELLKEYLST (FASTYPEFLG) (RUNONFLG NIL) (\#USERWORDS 20) (\#SPELLINGS1 20) (\#SPELLINGS2 20) (\#SPELLINGS3 20) (DWIMWAIT 10) (RESPELLS) (FIXSPELL.UPPERCASE.QUIET NIL)) (P (SETSPELLCASE) (NCONC1 SPELLINGS1 SPELLSTR1) (NCONC1 SPELLINGS2 SPELLSTR1) (ATTACH SPELLSTR1 SPELLINGS3)) (DECLARE\: DONTCOPY (MACROS SPELLEQ)) (BLOCKS (FIXSPELLBLOCK MISSPELLED? FIXSPELL CHOOZ CHOOZ1 SKOR SKOR0 MOVETOP (ENTRIES MISSPELLED? FIXSPELL CHOOZ SKOR0 SKOR MOVETOP) (LOCALFREEVARS NCXWORD NCTWORD TAIL ALTFLG)) (FIXSPELL1 FIXSPELL1 FIXSPELL2)) (DECLARE\: EVAL@COMPILE DONTCOPY (P (AND (OR (GETPROP 'NOSPELLFLG 'GLOBALVAR) (FMEMB 'NOSPELLFLG GLOBALVARS)) (HELP "NOSPELLFLG shouldn't be a global variable!" " How did it get that way?")))) (GLOBALVARS \#SPELLINGS2 \#SPELLINGS3 \#USERWORDS APPROVEFLG CLISPCHARS CLISPFLG COMMENTFLG DWIMFLG DWIMKEYLST DWIMWAIT EDITQUIETFLG FASTYPEFLG LASTWORD REREADFLG RESPELLS RUNONFLG RUNONSTATS SKORLST1 SKORLST2 SPELLINGS1 SPELLINGS2 SPELLINGS3 SPELLSTATS SPELLSTATS1 SPELLSTR1 SPELLSTR2 USERWORDS VETOSTATS))) (DEFINEQ (addspell (lambda (x splst n) (* |Updates| |appropriate| |spellings| |lists| |as| |follows:| |if| splst |is| nil\, |adds| |to| userwords |and| spellings2\; - |if| splst |is| 0\, |just| |adds| |to| userwords\; - |if| splst |is| 1\, |adds| |to| spellings1\; - |if| splst |is| 2\, |adds| |to| spellings2\; - |if| splst |is| 3\, |adds| |to| userwords |and| spellings3. - - spellings1 |is| |the| |list| |of| |functions| |used| |in| |an| apply |context,| |e.g.| makefile\, tcompl\, defineq. spellings2 |is| |the| |list| |of| |functions| |used| |in| |an| eval |context,| |e.g.| cons\, and\, return. spellings3 |is| \a |list| |of| |variables.| userwords |is| \a |list| |of| |both| |functions| |and| |variables| |that| |the| |user| |references.|) (and (litatom x) (selectq splst ((nil 0) (* define |uses| splst nil\, |adds| |word| |to| spellings2 |because| |some| |user| |function| |must| |call| |it.| |However,| |it| |might| |not| |be| \a |top-level| |function,| |so| |it| |isn't| |added| |to| spellings1 |until| |used| |in| |that| |way.| - splst 0 |is| |for| load/prop\, |and| |for| |use| |from| edita\, printstructure\, |etc.| |doesn't| |add| |it| |to| spellings2 |since| |have| |no| |indication| |that| |the| |function| |will| |be| |called| |by| |the| |user.|) (setq userwords (addspell1 x userwords \#userwords)) (and (null splst) (setq spellings2 (addspell1 x spellings2 \#spellings2))) (setq lastword x)) (1 (* |Called| |from| lispx |on| apply |inputs,| |add| |to| |permanent| |section,| |i.e.| |never| |forgets| x.) (setq spellings1 (addspell1 x spellings1))) (2 (* |Called| |from| lispx |on| eval |inputs,| |never| |forgets| x. |Not| |however| |that| |words| |are| |added| |to| |temporary| |section| |of| spellings2 |for| type=nil |or| type=0.) (setq spellings2 (addspell1 x spellings2))) ((t 3) (* |Called| |from| lispx |inputs| |consisting| |of| |just| \a |variable,| |or| |from| saveset\, |i.e.| |any| |call| |to| rpaq |or| rpaqq\, |or| |any| |call| |to| set |or| setq |via| lispx\, |or| |from| editv.) (setq userwords (addspell1 x userwords \#userwords)) (setq spellings3 (addspell1 x spellings3 \#spellings3)) (setq lastword x)) (cond ((listp splst) (addspell1 x splst n)) (t (error '"bad addspell type:" splst t))))))) (addspell1 (lambda (word splst n) (* |wt:| " 9-OCT-78 00:37") (* splst |is| |divided| |into| |two| |sections,| |permanent| |and| |temporary,| |separated| |by| nil. |Words| |are| |never| |forgotten| |from| |the| |permanent| |section.| a |maximum| |of| n |words| |are| |allowed| |in| |the| |temporary| |section.| |When| \a |correction| |occurs,| |the| |word| |is| |moved| |to| |the| |front| |of| |the| |list,| |hence| |putting| |it| |in| |the| |permanent| |section.| - |When| addspell1 |is| |called| |with| n=nil\, |words| |are| |added| |at| |the| |end| |of| |the| |permanent| |section,| |i.e.| |just| |before| |the| nil. |Otherwise| |they| |are| |added| |at| |the| |beginning| |of| |the| |temporary| |section,| |and| |if| |there| |are| |more| |than| n |words| |in| |the| |temporary| |list,| |the| |last| |is| |deleted.|) (cond ((null splst) (setq splst (list spellstr1 word))) ((and (neq word (car splst)) (neq word (cadr splst))) (* |Loop| |begins| |with| |third| |element.|) (prog ((l1 splst) (l2 (cddr splst)) l3 m) (* l1 |stays| |two| |behind| l2 |so| |that| |the| |last| |element| |of| splst |can| |be| |deleted.|) (cond ((eq (car splst) spellstr1) (setq l3 splst) (setq m 1) (* l2 |has| |already| |skipped| |one| |of| |the| |temporary| |words.|) ) ((eq (cadr splst) spellstr1) (setq l3 splst) (setq m 0))) (* |Special| |check| |necessary| |because| userwords |starts| |off| |with| nil |first,| |i.e.| |no| |permanent| userwords. i\f nil |not| |noticed,| |length| |won't| |be| |counted| |and| |nothing| |will| |ever| |be| |deleted.|) lp (cond ((null l2) (go out)) ((eq word (car l2)) (cond ((null l3) (* word |is| |already| |in| |permanent| |section.|) ) ((null n) (* word |is| |in| |temporary| |section| |and| |would| |have| |been| |added| |to| |permanent| |section.| |Add| |it| |to| |permanent| |and| |erase| |from| |temporary.|) (frplacd (cdr l1) (cdr l2)) (frplacd l2 (cdr l3)) (frplacd l3 l2)) (t (* word |is| |in| |temporary| |section| |and| |would| |have| |been| |added| |to| |temporary| |section.| move |it| |to| |front| |of| |temporary| |section.|) (frplacd (cdr l1) (cdr l2)) (setq l3 (cdr l3)) (frplacd l2 (cdr l3)) (frplacd l3 l2))) (return)) ((eq (car l2) spellstr1) (setq l3 (cdr l1)) (* car |of| l3 |is| |the| |last| |member| |of| |the| |permanent| |section.|) (setq m 0))) (setq l1 (cdr l1)) (setq l2 (cdr l2)) (and m (add1var m)) (* m |will| |be| |the| |length| |of| |temporary| |section|) (go lp) out (cond ((null l3) (* nil |not| |found.| |Occurs| |if| |user| |is| |maintaining| |own| |spelling| |list| |and| |not| |using| |temporary/permanent| |conventions.|) (nconc1 l1 word)) ((null n) (* |Add| |at| |end| |of| |permanent| |section.|) (rplnode l3 (car l3) (cons word (cdr l3)))) ((igreaterp m n) (* |Add| |at| |beginning| |of| |temporary| |section,| |delete| (and reuse) |last| |element| |of| |temporary| |section.|) (rplnode (cdr l1) word (cddr l3)) (rplnode (cdr l3) (cadr l3) (cdr l1)) (frplacd l1 nil) (* |Not| |worth| |while| |to| |make| |the| |deletion| |of| |last| |elemetn| |undoable.|) ) (t (rplnode (cdr l3) (cadr l3) (cons word (cddr l3))) (* |Add| |at| |beginning| |of| |temporary| |section.|) )) (and lispxhist (undosave (list 'addspell2 word splst) lispxhist))))) splst)) (addspell2 (lambda (word splst) (* |wt:| " 8-OCT-78 23:19") (prog (tem) (and (setq tem (fmemb word splst)) (/rplaca tem spellstr2))))) (misspelled? (lambda (xword rel splst flg tail fn) (* |wt:| "25-APR-78 12:26") (* misspelled? |can| |be| |used| |when| xword |may| |in| |fact| |be| |all| |right.| fixspell |should| |be| |used| |if| |you| |know| xword |is| |wrong.|) (prog nil (* rel |is| |between| 0 |and| 100 |and| |indicates| |percentage.|) (return (cond ((or (null xword) (eq xword ')) (lispxwatch spellstats1) (prin1 '= t) (print lastword t t)) ((cond ((null fn) (fmemb xword splst)) (t (apply* fn xword))) xword) (t (fixspell xword rel splst flg tail fn))))))) (FIXSPELL (LAMBDA (XWORD REL SPLST FLG TAIL FN TIEFLG DONTMOVETOPFLG FROMDWIM APPROVALFLG) (* |lmm| "15-Nov-86 22:22") (* |;;|  "If FLG is T, XWORD is printed to left of = sign.") (* |;;| " CLST is used when FIXSPELL is called from WTFIX. In this case, if TYPE-IN? is NIL, XWORD is printed, and a -> is used instead of =. In addition, if FAULTFN is not NIL, (IN FAULTFN) is also printed as part of the message.") (* |;;| "If CLST is a list, it is a DUNPACK of XWORD, since in most cases WTFIX will already have computed this list.") (* |;;|  " FLG is used to specify other types of messages besides ->.") (* |;;| "If TAIL is supplied, and word is equal to CAR of it, the correction will be smahed into TAIL. If TAIL is non NIL, runon corrections will be attempted. (If TAIL=T, and a runon corection is approved, the dotted pair is returned as the value.)") (* |;;|  "IF FLG=NO-MESSAGE, the correction is returned without asking for approval.") (PROG (X FIXSPELLTEM (NDBLS 0) TLST (DWIM.GIVE.UP.TIME (OR DWIM.GIVE.UP.TIME (SETUPTIMER DWIM.GIVE.UP.INTERVAL)))) (COND ((OR (EQ NOSPELLFLG T) (AND NOSPELLFLG FROMDWIM (NOT TYPE-IN?)) (AND (NLISTP SPLST) (NOT (ARRAYP SPLST))) (AND (NOT (LITATOM XWORD)) (NOT (STRINGP XWORD)))) (RETURN))) (COND ((NULL REL) (SETQ REL FIXSPELLREL))) (COND ((NULL XWORD) (RETURN NIL))) (SETQ TLST (CHCON XWORD)) (COND ((AND (LISTP SPLST) (NOT (STACKP (CAR SPLST)))) (|for| Z |in| SPLST |when| (LISTP Z) |do| (COND ((EQ (CAR Z) XWORD) (SETQ X (CDR Z)) (COND (FROMDWIM (GO FIXSPELLOUT)) (T (GO FIXSPELLRET)))))) (COND ((NOT (U-CASEP XWORD)) (SETQ FIXSPELLTEM (U-CASE XWORD)) (COND ((|if| FN |then| (CL:FUNCALL FN FIXSPELLTEM) |else| (OR (COND ((OR (EQ SPLST SPELLINGS1) (EQ SPLST SPELLINGS2)) (CL:FBOUNDP FIXSPELLTEM)) ((EQ SPLST SPELLINGS3) (BOUNDP FIXSPELLTEM))) (FMEMB FIXSPELLTEM SPLST))) (SETQ X FIXSPELLTEM) (COND ((AND FIXSPELL.UPPERCASE.QUIET (OR (NOT FROMDWIM) (EQ TYPE-IN? T))) (GO FIXSPELLRET)) (T (GO FIXSPELLOUT)))) ((SOME SPLST (FUNCTION (LAMBDA (X) (AND (LISTP X) (EQ FIXSPELLTEM (CAR X)) (SETQ FIXSPELLTEM X))))) (* |;;|  "A synonym on the spelling list. ") (SETQ X (LIST (CAR FIXSPELLTEM) (CDR FIXSPELLTEM))) (GO LP2))))))) (COND ((AND (EQ XWORD ') (OR (NULL FROMDWIM) TYPE-IN?)) (* \; "TYPE-IN? is bound in WTFIX.") (SETQ X LASTWORD) (FIXSPELL1 XWORD LASTWORD NIL FROMDWIM) (GO FIXSPELLRET)) ((AND (SETQ FIXSPELLTEM (FASSOC XWORD (LISTGET1 LISPXHIST 'RESPELLS))) (FMEMB (CDR FIXSPELLTEM) SPLST)) (* \;  "Already made this correctionthis event.") (SETQQ APPROVALFLG NEEDNOTAPPROVE) (SETQ X (CDR FIXSPELLTEM)) (GO LP2))) (SETQ X TLST) LP (COND ((NULL X) (GO LP1)) ((AND (EQ (CAR X) (CHARCODE ESC)) (SETQ FIXSPELLTEM (CDR X))) (* |;;| "for escape codes we call CHOOZ since this also handles the case where ther are misspellings in the leading characters.") (SETQ TLST (UNPACK XWORD)) (PROGN (* \; "Alt-mode matching.") (RESETVARS ((EDITQUIETFLG T)) (PROG ((L SPLST) (GENFN (AND (ARRAYP SPLST) (ELT SPLST 1))) (GENERATOR (AND (STACKP (CAR SPLST)) SPLST))) (SETQ X NIL) LP3 (COND (GENFN (COND ((NULL (SETQ FIXSPELLTEM (APPLY* GENFN SPLST))) (RETURN)))) (GENERATOR (COND ((EQ (SETQ FIXSPELLTEM (GENERATE GENERATOR)) GENERATOR) (RELSTK (CDR GENERATOR)) (RETURN)))) ((NULL L) (RETURN)) ((NULL (SETQ FIXSPELLTEM (CAR L))) (SETQ L (CDR L)) (GO LP3)) (T (SETQ L (CDR L)))) (COND ((AND (EDIT4E1 TLST (UNPACK FIXSPELLTEM)) (OR (NULL FN) (CL:FUNCALL FN FIXSPELLTEM))) (AND GENFN (STRINGP FIXSPELLTEM) (SETQ FIXSPELLTEM (MKATOM FIXSPELLTEM))) (* \;  "because the generator function may (frequently does) reuse the string it reutnrs.") (COND ((OR (EQ TIEFLG 'ALL) (EQ TIEFLG 'LIST) (EQ TIEFLG 'EVERYTHING)) (SETQ X (CONS FIXSPELLTEM X))) (TIEFLG (SETQ X FIXSPELLTEM)) (X (* \;  "Already a match, therefore ambiguous.") (PRINT '|ambiguous| T) (SETQ X NIL) (RETURN)) (T (SETQ X FIXSPELLTEM))))) (GO LP3))) (GO LP2))) ((EQ (CAR X) FIXSPELLTEM) (SETQ NDBLS (ADD1 NDBLS))) (T (SETQ FIXSPELLTEM (CAR X)) (* \;  "FIXSPELLTEM keeps track of the previous character.") )) (SETQ X (CDR X)) (GO LP) LP1 (SETQ X (CHOOZ TLST REL SPLST TAIL FN TIEFLG NDBLS FROMDWIM)) LP2 (COND ((NULL X) (RETURN NIL)) ((OR (EQ TIEFLG 'ALL) (EQ TIEFLG 'LIST) (EQ TIEFLG 'EVERYTHING)) (RETURN X)) ((LISTP X) (RETURN (COND ((LISTP (CDR X)) (* \;  "synonym correction. XWORD is identical with CAR of X.") (COND ((OR (EQ XWORD (CAR X)) (EQ FLG 'NO-MESSAGE)) (* \; "no approval necessary") (SETQ X (CADR X)) (GO FIXSPELLRET)) ((SETQ FIXSPELLTEM (FIXSPELL1 XWORD (CAR X) FLG FROMDWIM APPROVALFLG)) (* \;  "e.g. synonym is S.T. but XWORD is S.TT.") (SETQ X (COND ((LISTP FIXSPELLTEM)(* \;  "user specified new value via USING") (CAR FIXSPELLTEM)) (T (CADR X)))) (GO FIXSPELLRET)))) ((NULL TAIL) (* \;  "value of form (a . b) returned by chooz means runon correction") NIL) ((EQ FLG 'NO-MESSAGE) X) ((SETQ FIXSPELLTEM (FIXSPELL1 XWORD (COND ((LISTP (CAR X)) (* |;;| "both a runon and synonym involved, e.g. user types WHERE, and (WHE . SY) on spelling list. fixpsspell1 asks WHERE= WHE RE?") (CONS (CAAR X) (CDR X))) (T X)) FLG FROMDWIM (OR APPROVALFLG 'MUSTAPPROVE))) (* \; "Runon correction.") (COND ((LISTP FIXSPELLTEM) (* \;  "user typed in a value. no run on") (SETQ X (CAR FIXSPELLTEM)) (GO FIXSPELLRET)) ((AND (LISTP TAIL) (EQ XWORD (CAR TAIL))) (* \;  "Smash TAIL and eturn the first word") (/RPLNODE TAIL (COND ((LISTP (CAR X)) (CADAR X)) (T (CAR X))) (CONS (CDR X) (CDR TAIL))) (CAR TAIL)) ((LISTP FIXSPELLTEM) (COND ((CDR FIXSPELLTEM) (CONS (CAR FIXSPELLTEM) (CADR FIXSPELLTEM))) (T (CAR FIXSPELLTEM)))) (T (* \; "Return the dotted pair") X))) ((IGREATERP (CHOOZ1 (NCHARS XWORD) (NCHARS (COND ((LISTP (CAR X)) (CAAR X)) (T (CAR X)))) (NCHARS (CDR X))) REL) (* |;;| "e.g. the correction (BREAK . X) is offered for BREAKX this asks whether BREAK is a valid correction for BREAKX") (SETQ X (CAR X)) (GO LP2)))))) FIXSPELLOUT (COND ((EQ FLG 'NO-MESSAGE) (RETURN X)) ((SETQ FIXSPELLTEM (FIXSPELL1 XWORD X FLG FROMDWIM APPROVALFLG)) (* \;  "Prints appropriate message to user.") (COND ((LISTP FIXSPELLTEM) (SETQ X (CAR FIXSPELLTEM)) (ADDSPELL X SPLST)) ((AND (NULL DONTMOVETOPFLG) (LISTP SPLST) (FMEMB SPELLSTR1 SPLST)) (MOVETOP X SPLST))) (GO FIXSPELLRET)) (T (RETURN NIL))) FIXSPELLRET (PROGN (AND (LISTP TAIL) (EQ XWORD (CAR TAIL)) (/RPLNODE TAIL X (CDR TAIL))) (RETURN X))))) (FIXSPELL1 (LAMBDA (WORD X FLG FROMDWIM APPROVALFLG DEFAULT) (* |lmm| "15-Nov-86 22:22") (* \;  "Performs interaction with user associated with a spelling or other correction.") (PROG ((LISPXHIST (AND LISPXHIST (CONS '*LISPXPRINT* (CONS NIL LISPXHIST)))) (VAL T) MESSFLG BUFS TEM) (* |;;| "LISPXHIST is rebound as we don't want to include any DWIM messages if the change isn't actually performed, e.g. the user says NO. Therefore, we want to have LISPXPRIN1 et al save the output on a local LISPXHIST, and then transfer it all over to the real LISPXHIST if the correction goes through.") (AND (EQ WORD X) (ERROR!)) (COND ((NEQ (POSITION T) 0) (LISPXTERPRI T) (TERPRI T))) (COND ((OR (SETQ MESSFLG (OR (STRINGP WORD) (STRINGP X))) (EQ RESPELLS T)) (* \; "Dont keep respells.") ) ((OR REREADFLG (STRPOS '"" WORD)) (* \; "Spelling completion") ) ((OR (LISTP X) (NULL (SETQ TEM (FASSOC X RESPELLS)))) (SETQ RESPELLS (CONS (LIST X WORD) RESPELLS))) (T (NCONC1 TEM WORD))) (COND ((AND (NEQ APPROVALFLG 'MUSTAPPROVE) (COND (FROMDWIM (AND TYPE-IN? (NULL MESSFLG))) (T (NULL FLG)))) (* |;;| "This is the case where the correction is a spelling correction (as inidcated by MESSFLG being NIL), and no approval is needed. i.e. FIXSPELL1 is just going to print = followed by the word.") (AND (OR (EQ REREADFLG 'T) FLG) (PRIN2 WORD T T)) (PRIN1 "=" T) (FIXSPELL2 X) (GO OUT1))) (COND ((AND (NEQ APPROVALFLG 'MUSTAPPROVE) (COND ((NULL FROMDWIM) (OR (NULL FLG) (NULL APPROVEFLG))) (T (* |;;| "OR is true if approval is required. NOte that even if APPROVEFLG is T, when there are two interpretations to a correction, as indicated by CLISPCHANGES not being NIL, always aks approval.") (NULL (OR (AND (NULL TYPE-IN?) APPROVEFLG) CLISPCHANGES))))) (SETQQ APPROVALFLG NEEDNOTAPPROVE))) (COND ((OR (EQ APPROVALFLG 'MUSTAPPROVE) (AND (NEQ APPROVALFLG 'NEEDNOTAPPROVE) APPROVEFLG)) (* |;;| "Want to clear out LINUF and SYSBUF to prevent CLBUFS from misakenly returning left over typeahead from a previous CLEARBUF.") (LINBUF) (SYSBUF) (* \;  "The extra argument to CLBUFS prevents READBUF (LISPX'S buffer) from being cleared.") (SETQ BUFS (CLBUFS NIL T READBUF)))) (FIXSPELL2 WORD T) (COND ((AND FROMDWIM (NULL TYPE-IN?)) (FIXPRINTIN FAULTFN T) (LISPXPRIN1 (OR FLG '" -> ") T)) (T (LISPXPRIN1 (COND ((AND FLG (NEQ FLG T)) FLG) (T '=)) T) (* \;  "E.g. For Shall I load ... message, FLG is '' for unary minus it is ' '") )) (AND NIL (STRINGP WORD) (STRINGP X) (OR (NULL FLG) (EQ FLG T)) (NOT (STREQUAL WORD '"")) (LISPXTERPRI T)) (* |;;| "On corrections where both left and right are strings, and FLG is normal (thereby xcluding the TREAT AS CLISP case) print the strings on separate lnes for readability.") (COND ((EQ APPROVALFLG 'NEEDNOTAPPROVE) (FIXSPELL2 X) (GO OUT))) (FIXSPELL2 X T) (SETQ VAL (ASKUSER (AND DWIMWAIT (COND (MESSFLG (* |;;| "MESSFLG would be NIL for straight spelling correction. This says that the correction involves an 8 or a 9, or asks some question about CLISP. User will probably need more time to think about it in this case.") (ITIMES 3 DWIMWAIT)) (T DWIMWAIT))) (COND (DEFAULT) ((AND (LISTP X) (OR (ILESSP (SETQ TEM (NCHARS (CAR X))) 3) (NOT (IGREATERP TEM (NCHARS (CDR X)))))) (* |;;| "Runon correction. Defaut is NO if less than three characters in first word, or first word is not greater than second in length") '\n) (T FIXSPELLDEFAULT)) '" ? " (COND (FROMDWIM DWIMKEYLST) (T FIXSPELLKEYLST)))) (AND BUFS (BKBUFS BUFS)) (SELECTQ VAL ((Y \y) (SETQ VAL T)) (N (LISPXWATCH VETOSTATS) (* \;  "If value returned was 'n' as opposed to 'N', means defaulted to NO, not vetoed.") (RETURN NIL)) (\n (RETURN NIL)) (SETQ X (CAR VAL))) (LISPXTERPRI T NIL NIL T) (* \; "Adds a TERPRI to history list if LISPXPRINTFLG is T, but does not actually print a carriage return.") OUT (COND ((CADR LISPXHIST) (LISPXPUT '*LISPXPRINT* (CADR LISPXHIST) T (CDDR LISPXHIST)) (* |;;| "Makes the print information part of LISPXHIST. Before it was on a property that ws just consed onto the front. This will also add it to any other print information.") )) OUT1 (AND FROMDWIM LISPXHIST (NULL TYPE-IN?) (NEQ (CAR SIDES) 'CLISP\ ) (SETQ SIDES (LIST 'CLISP\ (LIST COMMENTFLG (CADR LISPXHIST) SIDES)))) (* |;;| "This marks the side information and print information as of the beginning of this correction. For usefor selective undoing. CADR of LISPXHIST (which was rebound here), will be the beginning of the PRINT information, which if approved, will be NCONCed onto the print informaion for this event.") (COND (MESSFLG (RETURN VAL)) (FROMDWIM (LISPXWATCH SPELLSTATS) (AND LISPXHIST (LISPXPUT 'RESPELLS (LIST (CONS WORD X)) T LISPXHIST))) (T (LISPXWATCH SPELLSTATS1))) (AND (LISTP X) (LISPXWATCH RUNONSTATS)) (RETURN VAL)))) (fixspell2 (lambda (x flg) (* |wt:| 15-jul-76 20 53) (cond ((listp x) (maprint (cond ((and (cdr x) (nlistp (cdr x))) (list (car x) (cdr x))) (t x)) t nil nil nil (function (lambda (x) (cond ((stringp x) (lispxprin1 x t)) (t (lispxprin2 x t t))))) t)) ((stringp x) (lispxprin1 x t)) (t (lispxprin2 x t t))) (cond ((null flg) (lispxterpri t))))) (CHOOZ (LAMBDA (XWORD REL SPLST TAIL FN TIEFLG NDBLS FROMDWIM) (* |lmm| "15-Nov-86 22:12") (COND ((NLISTP XWORD) (* \;  "When called from FIXSPELL, XWORD is already a CHCON lst.") (SETQ XWORD (CHCON XWORD)))) (PROG ((NCXWORD0 (FLENGTH XWORD)) NCXWORD NCTWORD TWORD TWORD1 TWORD2 TEM SC VAL (GENFN (AND (ARRAYP SPLST) (ELT SPLST 1))) (GENERATOR (AND (STACKP (CAR SPLST)) SPLST)) ALTFLG) (COND ((NULL NDBLS) (SETQ NDBLS 0) (MAPC XWORD (FUNCTION (LAMBDA (X) (COND ((EQ X TEM) (SETQ NDBLS (ADD1 NDBLS))) (T (SETQ TEM X)))))))) (* \;  "Counts number of (possibly) doubled characters") (SETQ ALTFLG (EQ (CAR (LAST XWORD)) (CHARCODE ESC))) (* \;  "xword ends in an alt-mode. means k to call skor even if testword is much longer.") LP (AND DWIM.GIVE.UP.TIME (TIMEREXPIRED? DWIM.GIVE.UP.TIME) (GO OUT)) (COND (GENFN (* |;;| "this provides a way of giving the spelling corrector a generating function intead of a spelling list. the generatng function can keep its 'state' in one of the other cells of the array. when it returns a value of NIL for the 'next' element, the spelling lists is assume xhausted.") (COND ((NULL (SETQ TWORD (APPLY* GENFN SPLST))) (GO OUT)))) (GENERATOR (COND ((EQ (SETQ TWORD (GENERATE GENERATOR)) GENERATOR) (RELSTK (CDR GENERATOR)) (GO OUT)))) ((NULL SPLST) (GO OUT)) ((OR (EQ (SETQ TWORD (CAR SPLST)) SPELLSTR1) (EQ TWORD SPELLSTR2)) (* \; "marker.") (SETQ SPLST (CDR SPLST)) (GO LP)) (T (SETQ SPLST (CDR SPLST)))) (COND ((LISTP TWORD) (* \; "Synonym feature.") (SETQ TWORD1 (CAR TWORD)) (SETQ TWORD2 (CDR TWORD))) (T (SETQ TWORD1 (SETQ TWORD2 TWORD)))) (SETQ NCTWORD (NCHARS TWORD1)) (SETQ NCXWORD (COND (ALTFLG (* |;;| "for purposes of call to skor, pretend that both words are same length so first character matched against first character.") NCTWORD) (T NCXWORD0))) (COND ((COND ((IGREATERP NCTWORD NCXWORD) (* |;;| "Checks to see if test word and unknown word differ sufficiently in number of characters so as to make it unnecessary to even call SKOR. This case is where test word is longer than XWORD. If number of characters in XWORD, NCW, divided by number of characters in test word, NCT, is less than REL than don't bother to call SKOR. 0 P") (AND (NULL ALTFLG) (ILESSP (IQUOTIENT (ITIMES NCXWORD 100) NCTWORD) REL))) ((ILESSP (IQUOTIENT (ITIMES NCTWORD 100) (ADD1 (IDIFFERENCE NCXWORD NDBLS))) REL) (* \;  "XWORD longer than test word. However, must allow for possibility of doubled characters.") T)) (GO LP)) ((AND (SETQ SC (SKOR XWORD (SETQ TEM (DCHCON TWORD1 SKORLST2)) NCXWORD NCTWORD FROMDWIM)) (OR (NULL FN) (CL:FUNCALL FN TWORD2))) (SETQ TEM (COND ((LISTP TWORD) (* \;  "to distinguish from a runon correction, which is returned as a dotted pair.") (LIST TWORD1 TWORD2)) ((AND GENFN (STRINGP TWORD)) (MKATOM TWORD)) (T TWORD))) (* \;  "note that i dont know what happens if you have both a synonym and runoncorrecton") (COND ((LISTP SC) (AND RUNONFLG TAIL (OR (NULL VAL) (EQ TIEFLG 'EVERYTHING) (IGREATERP NCTWORD (NCHARS (CAAR VAL)))) (SETQ VAL (CONS (CONS TEM (PACKC SC)) (COND ((EQ TIEFLG 'EVERYTHING) VAL))))) (* |;;| "TWORD1 used instead of TWORD2 becauseif any interaction, want user to approve in terms of his typeing, not the synonym. this will mean another call to spelling corrector to get the synonym, but big deal.") ) ((ZEROP SC) (COND ((EQ TIEFLG 'EVERYTHING) (SETQ VAL (CONS TEM VAL))) ((AND (NEQ TIEFLG 'ALL) (NEQ TIEFLG 'LIST)) (* \; "return the value") (SETQ VAL TEM) (GO OUT1)) ((NEQ REL 100) (* \;  "tieflg=LIST means list the tied candidates. it used to be called ALL") (SETQ REL 100) (SETQ VAL (LIST TEM))) (T (SETQ VAL (CONS TEM VAL))))) ((IGREATERP (SETQ SC (COND (ALTFLG (CHOOZ1 (SUB1 (IDIFFERENCE NCXWORD0 (IDIFFERENCE NCTWORD NCXWORD ))) (SUB1 NCXWORD0) SC)) (T (CHOOZ1 NCXWORD NCTWORD SC)))) REL) (SETQ VAL (CONS TEM (COND ((EQ TIEFLG 'EVERYTHING) VAL) (T (SETQ REL SC) (* \;  "Now only look for words CLOSER than SC.") NIL))))) ((EQ SC REL) (SETQ VAL (CONS TEM VAL)))))) (GO LP) OUT (SETQ VAL (COND ((OR (EQ TIEFLG 'ALL) (EQ TIEFLG 'LIST) (EQ TIEFLG 'EVERYTHING)) (COND ((CDR VAL) (DREVERSE VAL)) (T VAL))) ((AND (CDR VAL) (NULL TIEFLG)) (* \; "More than one.") NIL) (T (CAR VAL)))) OUT1 (RETURN VAL)))) (chooz1 (lambda (nc1 nc2 sc) (* |wt:| 29-nov-76 14 53) (prog (tem) (* |The| |arithmetic| |expression| |computes| |the| |relative| |closeness| |as| \a |percentage| (|times| 100) |by| |dividing| |the| |difference| |between| |the| |average| |number| |of| |characters| |and| |the| |number| |of| |mistakes,| |over| |the| |average| |number| |of| |characters.| |This| |is| (((|a+b|) /2) - |sc|) / (|a+b|) /2 |Multiplying| |top| |and| |bottom| |by| |two| |gives| (a+b-2*sc/a+b)) (return (iquotient (itimes 100 (idifference (setq tem (iplus nc1 nc2)) (itimes sc 2))) tem))))) (setspellcase (lambda nil (* |lmm| " 1-JUN-84 23:44") (setq spellcasearray (casearray)) (for i from (charcode a) to (charcode z) do (setcasearray spellcasearray (iplus i (idifference (charcode \a) (charcode a))) i)) (for x in '((1 !) (2 \") (3 \#) (4 $) (5 %) (6 &) (7 \' &) (8 \( *) (9 \) \() (0 \) _) (= - +) (\; +) (\' \") (\: * \;) (< \,) (> \.) (? /)) do (for y in (cdr x) do (setcasearray spellcasearray (chcon1 y) (chcon1 (car x))))))) (skor0 (lambda (tword ncxword ndbls lst) (* |bvm:| " 4-Nov-86 01:56") (* a |special| |call| |to| skor |for| |use| |by| |editor.| lst |is| |an| |exploded| |chconlst| |of| |characteers,| ncxword |the| |number| |of| |characters| |in| l\, ndbls |the| |number| |of| |doubled| |characters.| skor0 |compares| tword |with| l\, |and| |returns| t |if| |'close'.|) (prog ((nctword (nchars tword)) sc tem tail altflg) (return (and (cond ((igreaterp nctword ncxword) (not (ilessp (iquotient (itimes ncxword 100) nctword) 70))) (t (igreaterp (iquotient (itimes nctword 100) (cond ((eq ncxword ndbls) 1) (t (idifference ncxword ndbls)))) 70))) (numberp (setq sc (skor lst (chcon tword) ncxword nctword))) (or (zerop sc) (igreaterp (iquotient (itimes (idifference (setq tem (cond ((igreaterp ncxword nctword) ncxword) (t nctword))) sc) 100) tem) 70))))))) (SKOR (LAMBDA (XWORD TWORD NCX NCT FROMDWIM) (* |lmm| "15-Nov-86 22:28") (* |;;| "This algorithm counts the number of mistakes in the testword vis a vis the known word. A mistake is a character in the known word that does not have a corresponding character in the test word, or vice versa. Mistakes are not counted until the end of the scoring, so that transpositions are not counted as mistakes. Instead, whenever an unexplained character is encountered, the tail is put in a buffer for the corresponding word. (For reasons of efficiency, instead of a genuine buffer, two PROG variables are used for each word: T1, T2, X1, and X2. Whenever these 'buffers' are exceeded, the skoring is aborted and NIL is returned as the value of SKOR.) When a character is found that does not match, it is first compared with the buffer for the other word. If it is there, it is not counted as a mistake but as out of order. Out of order characters are counted as mistakes if they are misplaced by more than two positions, or if there are any other mistakes, e.g. substitutions or missing letters. Also, double letters are not counted as mistakes, nor are shift mistakes, e.g. @RINT vs PRINT gives a value of 0") (PROG (X1 X2 T1 T2 X-1 XC TC (N 0) (NTRANS 0) TEM) LP (SETQ XC (CAR XWORD)) (SETQ TC (CAR TWORD)) (COND ((NULL XWORD) (COND ((NULL TWORD) (GO OUT)) (T (GO LP2)))) ((EQ XC 27) (* \; "altmode") (COND ((SETQ XWORD (CDR XWORD)) (RETURN))) (SETQ TWORD NIL) (GO LP1)) ((NULL TWORD) (GO LP1)) ((SPELLEQ XC TC) (SETQ XWORD (CDR XWORD)) (SUB1VAR NCX) (SETQ TWORD (CDR TWORD)) (SUB1VAR NCT) (SETQ X-1 XC) (GO LP))) LP1 (COND ((AND T2 (SPELLEQ XC (CAR T2))) (* |;;| "Character encountered in TWORD before XWORD, e.g. the P in IPRNT vs PRINT. The case of RPINT vs PRINT is handled specially without ever going to the buffers.") (COND ((IGREATERP (FLENGTH T2) (IPLUS NCX 2)) (ADD1VAR N)) (T (ADD1VAR NTRANS))) (SETQ T2 NIL) (SETQ XWORD (CDR XWORD)) (SUB1VAR NCX) (SETQ X-1 XC) (GO LP)) ((AND T1 (SPELLEQ XC (CAR T1))) (COND ((IGREATERP (FLENGTH T1) (IPLUS NCX 2)) (ADD1VAR N)) (T (ADD1VAR NTRANS))) (COND (T2 (SETQ T1 T2) (SETQ T2 NIL)) (T (SETQ T1 NIL))) (SETQ XWORD (CDR XWORD)) (SUB1VAR NCX) (SETQ X-1 XC) (GO LP)) ((NULL TWORD) (GO LP3))) LP2 (COND ((AND X2 (SPELLEQ TC (CAR X2))) (COND ((IGREATERP (FLENGTH X2) (IPLUS NCT 2)) (ADD1VAR N)) (T (ADD1VAR NTRANS))) (* \;  "Character encountered in XWORD first, e.g. I in IPRNT vs PRINT.") (SETQ X2 NIL) (SETQ TWORD (CDR TWORD)) (SUB1VAR NCT) (GO LP)) ((AND X1 (SPELLEQ TC (CAR X1))) (COND ((IGREATERP (FLENGTH X1) (IPLUS NCT 2)) (ADD1VAR N)) (T (ADD1VAR NTRANS))) (COND (X2 (SETQ X1 X2) (SETQ X2 NIL)) (T (SETQ X1 NIL))) (SETQ TWORD (CDR TWORD)) (SUB1VAR NCT) (GO LP)) ((AND XWORD (EQ XC (CADR TWORD)) (EQ TC (CADR XWORD)) (NEQ TC (CADDR TWORD))) (* |;;| "Special check for most common case of transposition. The last clause is an attempt to distinguish the case of a transposition from simply getting out of synch. e.g. consider MYCIN vs MICIN. The Y is discarded, and then we are comparing CIN with ICIN. Treating CI as a transposition of IC is wrong in this case, since it matches with CI if the I is discarded.") (SETQ X-1 (CADR XWORD)) (SETQ XWORD (CDDR XWORD)) (SUB1VAR NCX) (SUB1VAR NCX) (ADD1VAR NTRANS) (SETQ TWORD (CDDR TWORD)) (SUB1VAR NCT) (SUB1VAR NCT) (GO LP)) ((IGREATERP NCT NCX) (* \; "Remove from TWORD.") (COND ((NULL T1) (SETQ T1 TWORD)) ((NULL T2) (SETQ T2 TWORD)) ((AND ALTFLG (OR (EQ XC X-1) (EQ XC (CADR XWORD)))) (* |;;| "we already have two unaccounted for characters in tword, the (still) longer word. no point in checking for doubled character in xword, because even if it were, still would be three characters unaccounted for. however, if altflg is T, then worthwhile. reason why we dont do this before goig through T1 and T2 is that it might NOT be a doubled character, but a missplaced character.") (GO LP3)) (T (RETURN NIL))) (SETQ TWORD (CDR TWORD)) (SUB1VAR NCT) (GO LP))) LP3 (COND ((OR (EQ XC X-1) (EQ XC (CADR XWORD))) (* |;;| "About to remove from XWORD, check for double char. first check says was equal to last character. This occurs when last character was correct. Second check says equal to next character, so throw this one away.") (SETQ XWORD (CDR XWORD)) (SETQ NCXWORD (SUB1 NCXWORD)) (* |;;| "Bound in CHOOZ. When computing value of SKOR, want to divide number of mistakes by actual length of word, i.e. length minus number of doubled characters. Otherwise, making a word longer by adding extra characters will make it CLOSER, e.g. ZZZZZZZ would correct to PP.") (SUB1VAR NCX)) (T (COND ((NULL X1) (SETQ X1 XWORD)) ((NULL X2) (SETQ X2 XWORD)) (T (RETURN NIL))) (SETQ XWORD (CDR XWORD)) (SUB1VAR NCX) (SETQ X-1 XC))) (GO LP) OUT (COND ((AND (NULL XWORD) (NULL TWORD) T1 X1) (SETQ T1 (FLENGTH T1)) (SETQ X1 (FLENGTH X1)) (AND T2 (SETQ T2 (FLENGTH T2))) (AND X2 (SETQ X2 (FLENGTH X2))) (COND ((OR (EQ T1 X1) (EQ T1 X2)) (* |;;| "Check for substitution errors. Subtracts one so when two gets added below, net effect is only counted as one.") (SUB1VAR N))) (COND ((AND T2 (OR (EQ T2 X1) (EQ T2 X2))) (SUB1VAR N))))) (SETQ N (IPLUS N (COND (X2 2) (X1 1) (T 0)) (COND (T2 2) (T1 1) (T 0)))) (RETURN (COND ((AND (NULL ALTFLG) (OR (EQ N 0) FASTYPEFLG)) (* |;;| "If FASTYPEFLG is T, transpositions are not counted as errors. Otherwise, transpositions are counted if there are other errors, i.e. if thee are no errors except for transpostions, SKOR returns 0.0") N) (T (IPLUS N NTRANS))))))) (movetop (lambda (x l) (* |Used| |by| |spelling| |block| |and| |helpfixblock.|) (prog ((y l) z) lp (cond ((null y) (return l)) ((neq (car y) x) (setq z y) (setq y (cdr y)) (go lp)) ((neq y l) (* |Move| |to| |front| |of| |list|) (frplacd z (cdr y)) (frplacd y (cdr l)) (frplacd l y) (frplaca y (car l)) (frplaca l x))) (return l)))) ) (RPAQ? USERWORDS ) (RPAQ? SPELLINGS1 '(DEFINEQ ARGLIST MOVD GETD FNTYP BREAK UNBREAK REBREAK TRACE BREAKIN MAKEFILE MAKEFILES LISTFILES FILES? WHEREIS CLEANUP PP PF EDITF EDITV EDITP ADVISE UNADVISE UNSAVEDEF RECOMPILE TCOMPL COMPILE BRECOMPILE BCOMPL MAPCAR MAPC LOAD LOADFROM LOADFNS TIME CLOSEF CLOSEALL OPENP OUTPUT INPUT OUTFILE INFILE LOGOUT PUTPROP REMPROP GETPROP SYSOUT CLISPIFY DWIMIFY EDITCALLERS FREEVARS CALLS)) (RPAQ? SPELLINGS2 '(GETPROP ADD1 AND APPEND ASSOC COND CONS COPY ELT EQ EQUAL ERROR ERSETQ EVAL FASSOC FMEMB FRPLACA FRPLACD FUNCTION GO IDIFFERENCE IGREATERP ILESSP IMINUS IPLUS ITIMES LENGTH LIST LISTP MAPC MAPCAR MAPCONC MEMB MEMBER NCONC NCONC1 NEQ NLISTP NLSETQ NULL NUMBERP OR PRINT PRIN1 PROG PROGN PUTPROP QUOTE READ RETURN RPLACA RPLACD SELECTQ SETA SETQ SPACES SUB1 TERPRI ZEROP IF F/L VALUEOF FOR FETCH REPLACE CREATE GETPROP PUTPROP DIFFERENCE GREATERP LESSP PLUS)) (RPAQ? SPELLINGS3 '(BROKENFNS ADVISEDFNS NOTLISTEDFILES FILELST NOTCOMPILEDFILES PROMPT#FLG CLISPIFYPRETTYFLG DWIMIFYCOMPFLG FILERDTBL EDITRDTBL SYSPRETTYFLG NOSPELLFLG INITIALS NIL)) (RPAQ? SPELLSTR1 "{spellseparator}") (RPAQ? SPELLSTR2 "{spellignore}") (RPAQ? FIXSPELLREL 70) (RPAQ? FIXSPELLDEFAULT '\y) (RPAQ? SKORLST1 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL )) (RPAQ? SKORLST2 '(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL )) (RPAQ? DWIMKEYLST NIL) (RPAQ? FIXSPELLKEYLST NIL) (RPAQ? FASTYPEFLG ) (RPAQ? RUNONFLG NIL) (RPAQ? \#USERWORDS 20) (RPAQ? \#SPELLINGS1 20) (RPAQ? \#SPELLINGS2 20) (RPAQ? \#SPELLINGS3 20) (RPAQ? DWIMWAIT 10) (RPAQ? RESPELLS ) (RPAQ? FIXSPELL.UPPERCASE.QUIET NIL) (SETSPELLCASE) (NCONC1 SPELLINGS1 SPELLSTR1) (NCONC1 SPELLINGS2 SPELLSTR1) (ATTACH SPELLSTR1 SPELLINGS3) (DECLARE\: DONTCOPY (DECLARE\: EVAL@COMPILE (PUTPROPS SPELLEQ DMACRO (OPENLAMBDA (X Y) (OR (EQ X Y) (AND (< X 255) (< Y 255) (EQ (GETCASEARRAY SPELLCASEARRAY X) (GETCASEARRAY SPELLCASEARRAY Y)))))) ) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK\: FIXSPELLBLOCK MISSPELLED? FIXSPELL CHOOZ CHOOZ1 SKOR SKOR0 MOVETOP (ENTRIES MISSPELLED? FIXSPELL CHOOZ SKOR0 SKOR MOVETOP) (LOCALFREEVARS NCXWORD NCTWORD TAIL ALTFLG)) (BLOCK\: FIXSPELL1 FIXSPELL1 FIXSPELL2) ) (DECLARE\: EVAL@COMPILE DONTCOPY (AND (OR (GETPROP 'NOSPELLFLG 'GLOBALVAR) (FMEMB 'NOSPELLFLG GLOBALVARS)) (HELP "NOSPELLFLG shouldn't be a global variable!" " How did it get that way?")) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \#SPELLINGS2 \#SPELLINGS3 \#USERWORDS APPROVEFLG CLISPCHARS CLISPFLG COMMENTFLG DWIMFLG DWIMKEYLST DWIMWAIT EDITQUIETFLG FASTYPEFLG LASTWORD REREADFLG RESPELLS RUNONFLG RUNONSTATS SKORLST1 SKORLST2 SPELLINGS1 SPELLINGS2 SPELLINGS3 SPELLSTATS SPELLSTATS1 SPELLSTR1 SPELLSTR2 USERWORDS VETOSTATS) ) (PUTPROPS SPELL COPYRIGHT ("Venue & Xerox Corporation" 1984 1985 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (4156 57424 (ADDSPELL 4166 . 7132) (ADDSPELL1 7134 . 12565) (ADDSPELL2 12567 . 12774) ( MISSPELLED? 12776 . 13748) (FIXSPELL 13750 . 28186) (FIXSPELL1 28188 . 35825) (FIXSPELL2 35827 . 36597 ) (CHOOZ 36599 . 44481) (CHOOZ1 44483 . 45265) (SETSPELLCASE 45267 . 46317) (SKOR0 46319 . 48423) ( SKOR 48425 . 56723) (MOVETOP 56725 . 57422))))) STOP \ No newline at end of file diff --git a/sources/SPELLFILE b/sources/SPELLFILE new file mode 100644 index 00000000..adbef95d --- /dev/null +++ b/sources/SPELLFILE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "28-Apr-92 15:38:21" |{PELE:MV:ENVOS}SOURCES>SPELLFILE.;4| 16123 changes to%: (FNS FINDFILE SPELLFILE SPELLFILE.SPELL SPELLFILE1) previous date%: "27-Nov-90 14:57:57" |{PELE:MV:ENVOS}SOURCES>SPELLFILE.;3|) (* ; " Copyright (c) 1986, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SPELLFILECOMS) (RPAQQ SPELLFILECOMS ((* "File name spelling correction") (FNS FINDFILE SPELLFILE SPELLFILE.MATCHINGDIRS SPELLFILE.SPELL SPELLFILE.SPELL1 SPELLFILE1 SPELLFILEDIR) (GLOBALVARS USERNAME) (INITVARS (NOFILESPELLFLG T)) [DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (ERRORTYPELST (23 (SPELLFILE (CADR ERRORMESS) NIL NOFILESPELLFLG] (ADDVARS (DIRECTORIES)))) (* "File name spelling correction") (DEFINEQ (FINDFILE [LAMBDA (FILE NSFLG DIRLST) (* ; "Edited 14-Mar-91 21:54 by bvm") (* ;; "If file has an explicit directory on it and that file exists, don't fool around with the directory packing in SPELLFILE, simply return. ") (COND ((AND (OR (NULL DIRLST) (UNPACKFILENAME.STRING FILE 'DIRECTORY)) (INFILEP FILE))) (T (SPELLFILE FILE T NSFLG DIRLST]) (SPELLFILE [LAMBDA (FILE NOPRINTFLG NSFLG DIRLST) (* ; "Edited 27-Nov-90 14:13 by nm") (DECLARE (SPECVARS NAME EXTENSION VERSION SPELLVAL DIRHOSTS HOST) (GLOBALVARS \FILEDEVICENAMES)) (PROG (SPELLVAL VAL DIRHOSTS HOST DEVICE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY NAME EXTENSION VERSION FILEDATES (FIELDS (UNPACKFILENAME.STRING FILE)) (DIRS (OR DIRLST DIRECTORIES)) (APPFLG 'MUST-APPROVE) (NSFLG (OR NSFLG NOSPELLFLG (NULL DWIMFLG))) (ROOTNAME FILE)) (OR FILE (RETURN)) FLDLP (COND (FIELDS (SELECTQ (CAR FIELDS) (NAME (SETQ NAME (CADR FIELDS))) (VERSION (SETQ VERSION (CADR FIELDS))) (EXTENSION (SETQ EXTENSION (CADR FIELDS))) (DIRECTORY (SETQ DIRECTORY (CADR FIELDS))) (RELATIVEDIRECTORY (SETQ RELATIVEDIRECTORY (CADR FIELDS))) (SUBDIRECTORY (SETQ SUBDIRECTORY (CADR FIELDS))) (HOST (SETQ HOST (CADR FIELDS))) (DEVICE (* ;;  "Pseudo-devices FOO: can be used to denote a list of directories") (OR [AND (NULL DEVICE) (NULL DIRECTORY) (SETQ DIRS (GETPROP (SETQ DEVICE (CADR FIELDS)) 'DIRECTORIES] (RETURN))) (RETURN)) (SETQ FIELDS (CDDR FIELDS)) (GO FLDLP))) [AND HOST (COND ((HOSTNAMEP HOST)) ([AND (NOT NSFLG) (SETQ HOST (FIXSPELL HOST NIL \FILEDEVICENAMES 'NO-MESSAGE] (AND (SETQ VAL (INFILEP (PACKFILENAME.STRING 'HOST HOST 'BODY FILE))) (GO RET))) (T (* ;  "It is pointless to go on if we don't have a valid host.") (RETURN NIL] [COND ((OR HOST DEVICE DIRECTORY RELATIVEDIRECTORY SUBDIRECTORY VERSION) (* ;; "ROOTNAME is what fixspell gets called on. important that extra characters get stripped out so that spelling corrector metric is applied to what is really being corrected, otherwise, e.g. with directory supplied, any two short names will match") (SETQ ROOTNAME (MKATOM (PACKFILENAME 'NAME NAME 'EXTENSION EXTENSION] [COND ([AND (NEQ ROOTNAME FILE) (NULL DIRLST) (SETQ FILEDATES (GETPROP ROOTNAME 'FILEDATES)) (SETQ SPELLVAL (OR (INFILEP ROOTNAME) (AND VERSION (OR DIRECTORY HOST) (INFILEP (PACKFILENAME.STRING 'DIRECTORY DIRECTORY 'RELATIVEDIRECTORY RELATIVEDIRECTORY 'SUBDIRECTORY SUBDIRECTORY 'HOST HOST 'NAME NAME 'EXTENSION EXTENSION] (COND ([for X in FILEDATES thereis (AND (OR (EQ (CDR X) SPELLVAL) (EQ (CDR X) FILE)) (STREQUAL (CAR X) (FILEDATE SPELLVAL] (* ;; "attacks problem where sombody wants a specific file, e.g. makefile wants the source, the file is around, but with a different verson number, e.g. was ftped from maxc, and user didnt loadfrom symbolic but instead just started editing with compiled file having been loaded. This is a rare case; users should LOADFROM! Also, since we don't know where this fully-qualified name came from, we must ask for correction.") (SETQ VAL SPELLVAL) (* ; "works by looking to see if latest verson of rootname in fact has same filedate as requested file.") (GO RET] [COND [DIRECTORY (COND ((DIRECTORYNAMEP DIRECTORY HOST) (* ;  "User supplied directory is valid") (GO SPELLNAME))) (* ;; "Try to spelling correct directory with hostname stripped off for spelling metric. If HOST, then only consider directories on that host. Otherwise, keep a list of the hosts associated with the host-free directories.") (COND ([AND (NOT NSFLG) (SETQ DIRS (SPELLFILE.MATCHINGDIRS DIRS HOST)) (SETQ VAL (FIXSPELL DIRECTORY NIL DIRS 'NO-MESSAGE NIL (FUNCTION (LAMBDA (DIR) (* ;  "Check file only for directories that are close enough") (AND (SETQ DIR (SPELLFILEDIR DIR)) (RETFROM 'FIXSPELL DIR] (GO RET)) (T (RETURN] (T (* ;; "Here if directory wasn't specified in the filename. Search only directories on DIRS which match HOST, if specified.") (for DIR in DIRS when [PROGN (SELECTQ DIR ((NIL T) (SETQ DIR (DIRECTORYNAME DIR T))) NIL) (AND [OR (NULL HOST) (STREQUAL HOST (LISTGET ( UNPACKFILENAME.STRING DIR) 'HOST] (SETQ VAL (INFILEP (PACKFILENAME.STRING 'DIRECTORY DIR 'RELATIVEDIRECTORY RELATIVEDIRECTORY 'SUBDIRECTORY SUBDIRECTORY 'NAME NAME 'EXTENSION EXTENSION 'VERSION VERSION] do [SETQ APPFLG (COND (NOPRINTFLG 'NO-MESSAGE) (T 'NEEDNOTAPPROVE] (GO RET] (COND ([AND (NULL DIRLST) [LISTP (SETQ VAL (GETPROP FILE 'FILEDATES] (FMEMB [CDR (LISTP (CAR (LISTP (GETPROP FILE 'FILE] '(LOADFNS T)) (LITATOM (CDAR VAL)) (SETQ VAL (INFILEP (PACKFILENAME.STRING 'VERSION NIL 'BODY (CDAR VAL] [SETQ APPFLG (COND (NOPRINTFLG 'NO-MESSAGE) (T 'NEEDNOTAPPROVE] (GO RET))) SPELLNAME (COND ([OR NSFLG (NOT (SETQ VAL (SPELLFILE.SPELL HOST DIRECTORY NAME EXTENSION VERSION ROOTNAME RELATIVEDIRECTORY SUBDIRECTORY] (RETURN))) (* ;; "SPELLFILE1 and hence FIXSPELL return name without host/directory, since matching against ROOTNAME; hence, the packfilename below") [COND ((NEQ FILE ROOTNAME) (SETQ VAL (MKATOM (PACKFILENAME 'BODY VAL 'HOST HOST 'DIRECTORY DIRECTORY 'RELATIVEDIRECTORY RELATIVEDIRECTORY 'SUBDIRECTORY SUBDIRECTORY 'VERSION VERSION] RET (RETURN (AND (OR (EQ APPFLG 'NO-MESSAGE) (FIXSPELL1 FILE VAL (EQ APPFLG 'MUST-APPROVE) NIL APPFLG)) VAL]) (SPELLFILE.MATCHINGDIRS (LAMBDA (DIRS HOST) (* bvm%: "26-DEC-81 17:01") (COND (HOST (for DIR DHOST in DIRS when (EQ HOST (LISTGET (SETQ DIR (OR (LISTP DIR) (UNPACKFILENAME (SELECTQ DIR ((NIL T) (DIRECTORYNAME DIR T)) DIR)))) (QUOTE HOST))) collect (LISTGET DIR (QUOTE DIRECTORY)))) (T (for DIR UDIR DHOST in DIRS unless (PROG1 (MEMB (SETQ DIR (LISTGET (SETQ UDIR (OR (LISTP DIR) (UNPACKFILENAME (SELECTQ DIR ((NIL T) (DIRECTORYNAME DIR T)) DIR)))) (QUOTE DIRECTORY))) $$VAL) (AND (SETQ DHOST (LISTGET UDIR (QUOTE HOST))) (NCONC1 (OR (FASSOC DIR DIRHOSTS) (CAR (push DIRHOSTS (CONS DIR)))) DHOST))) collect DIR)))) ) (SPELLFILE.SPELL [LAMBDA (HOST DIRECTORY NAME EXTENSION VERSION ROOTNAME RELATIVEDIRECTORY SUBDIRECTORY) (* ; "Edited 28-Apr-92 13:58 by jds") (* ;; "Try to spelling-correct ROOTNAME against existing files. HOST DIRECTORY NAME EXTENSION VERSION are the unpacked fields of the originally supplied file, while ROOTNAME is just the name/extension we are willing to fix up.") (* ;;  "For efficiency, assume that either the name or the extension, but not both, is misspelled.") (COND ([AND VERSION (NOT (AND (FIXP VERSION) (IGREATERP VERSION 0] (* ; "Can't deal with funny versions") (SETQ VERSION NIL))) (RESETLST (* ;  "RESETLST is for the \GENERATEFILES inside SPELLFILE.SPELL1") (OR (COND (EXTENSION (* ;  "If non-null extension, then try all extensions of files with this name.") (SPELLFILE.SPELL1 HOST DIRECTORY NAME '* VERSION ROOTNAME RELATIVEDIRECTORY SUBDIRECTORY))) (SPELLFILE.SPELL1 HOST DIRECTORY '* EXTENSION VERSION ROOTNAME RELATIVEDIRECTORY SUBDIRECTORY)))]) (SPELLFILE.SPELL1 (LAMBDA (HOST DIRECTORY NAME EXTENSION VERSION ROOTNAME RELATIVEDIRECTORY SUBDIRECTORY) (* ; "Edited 27-Nov-90 13:58 by nm") (* ;;; "Try to spelling-correct ROOTNAME against all the files matching the fields supplied.") (DECLARE (SPECVARS VERSION)) (* ; "Used by SPELLFILE1") (LET ((SPELLFILE (ARRAY 2))) (SETA SPELLFILE 2 (\GENERATEFILES (PACKFILENAME.STRING (QUOTE HOST) HOST (QUOTE DIRECTORY) DIRECTORY (QUOTE RELATIVEDIRECTORY) RELATIVEDIRECTORY (QUOTE SUBDIRECTORY) SUBDIRECTORY (QUOTE NAME) NAME (QUOTE EXTENSION) EXTENSION (QUOTE VERSION) (OR VERSION "")) NIL (QUOTE RESETLST))) (* ; "If no version specified, enumerate only highest version") (SETA SPELLFILE 1 (FUNCTION SPELLFILE1)) (FIXSPELL ROOTNAME NIL SPELLFILE (QUOTE NO-MESSAGE)))) ) (SPELLFILE1 [LAMBDA (ARR) (* ; "Edited 28-Apr-92 15:10 by jds") (* ;; "Name generator for a FIXSPELL -- generates files for a given host/directory, but returns names with the host/directory stripped off for fixspell matching.") (DECLARE (USEDFREE VERSION)) (PROG (FL NAME1 EXT1 VERS#1) LP (COND ([NULL (SETQ FL (\GENERATENEXTFILE (ELT ARR 2) (NULL VERSION] (RETURN))) (for FIELDS on (UNPACKFILENAME.STRING FL) by (CDDR FIELDS) do (* ;  "Ignore host and directory, assuming we only generate appropriate ones.") (SELECTQ (CAR FIELDS) (NAME (SETQ NAME1 (CADR FIELDS))) (EXTENSION (SETQ EXT1 (CADR FIELDS))) (VERSION (SETQ VERS#1 (CADR FIELDS))) NIL)) [COND ([OR (NOT VERSION) (AND VERS#1 (EQ VERSION (MKATOM VERS#1] (* ;  "Skip if versions mismatch, so fixspell only works on names") (RETURN (PACKFILENAME.STRING 'NAME NAME1 'EXTENSION EXT1] (SETQ NAME1 (SETQ EXT1 (SETQ VERS#1 NIL))) (GO LP]) (SPELLFILEDIR (LAMBDA (DIR) (* rmk%: "13-NOV-81 22:13") (* If HOST, returns fullname of file on {HOST}DIR, otherwise searches the hosts associated with DIR for the first one with file.) (DECLARE (USEDFREE HOST DIRHOSTS NAME EXTENSION VERSION)) (COND (HOST (INFILEP (PACKFILENAME (QUOTE HOST) HOST (QUOTE DIRECTORY) DIR (QUOTE NAME) NAME (QUOTE EXTENSION) EXTENSION (QUOTE VERSION) VERSION))) (T (for H in (OR (CDR (FASSOC DIR DIRHOSTS)) (QUOTE (NIL))) when (SETQ H (INFILEP (PACKFILENAME (QUOTE HOST) H (QUOTE DIRECTORY) DIR (QUOTE NAME) NAME (QUOTE EXTENSION) EXTENSION (QUOTE VERSION) VERSION))) do (RETURN H))))) ) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS USERNAME) ) (RPAQ? NOFILESPELLFLG T) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR ERRORTYPELST (23 (SPELLFILE (CADR ERRORMESS) NIL NOFILESPELLFLG))) ) (ADDTOVAR DIRECTORIES ) (PUTPROPS SPELLFILE COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1992)) (DECLARE%: DONTCOPY (FILEMAP (NIL (993 15750 (FINDFILE 1003 . 1452) (SPELLFILE 1454 . 10927) (SPELLFILE.MATCHINGDIRS 10929 . 11548) (SPELLFILE.SPELL 11550 . 12964) (SPELLFILE.SPELL1 12966 . 13735) (SPELLFILE1 13737 . 15125) (SPELLFILEDIR 15127 . 15748))))) STOP \ No newline at end of file diff --git a/sources/SPP b/sources/SPP new file mode 100644 index 00000000..05113344 --- /dev/null +++ b/sources/SPP @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 11:20:29" {DSK}lde>lispcore>sources>SPP.;3 107246 previous date%: " 5-Jan-93 02:24:51" {DSK}lde>lispcore>sources>SPP.;2) (* ; " Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1993 by Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SPPCOMS) (RPAQQ SPPCOMS ((COMS (* ; "Sequenced Packet Protocol.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE) SPPDECLS) (MACROS RETRANSMITINDEX SEQ.ADD1 SEQ.GREATERP SEQ.GEQ) (GLOBALVARS SPP.USER.TIMEOUT SPP.MIN.TIMEOUT SPP.INACTIVITY.TIMEOUT SPP.MAX.FAILED.PROBES XIPTRACEFLG XIPTRACEFILE)) (SYSRECORDS SPPCON) (INITRECORDS SPPCON) (INITVARS (SPP.USER.TIMEOUT 15000) (SPP.INACTIVITY.TIMEOUT 120000) (SPP.MIN.TIMEOUT 50) (SPP.MAX.FAILED.PROBES 5)) (FNS \SPPCONNECTION \SPP.CREATE.CON \SPP.CREATE.STREAMS \SPP.CREATE.WATCHER \SPP.SENDPKT \FILLINSPP \SPP.SYSPKT \GETSPP \SENDSPP \SPP.SEND.ENDREPLY \TERMINATESPP \SPP.CLEANUP) (FNS \SPPWATCHER \SPP.HANDLE.INPUT \SPP.HANDLE.DATA \SPP.HANDLE.ATTN \SPP.RELEASE.ACKED.PACKETS \SPP.NOT.RESPONDING \SPP.PROBE \SPP.RETRANSMIT.NEXT \SPP.DUPLICATE.REQUEST \SPP.ESTABLISH \SPPGETERROR \SPPSENDERROR)) [COMS (* ;  "Stream interface to Sequenced Packet Protocol.") (FNS \INITSPP \SPP.EVENTFN \CREATE.SPP.DEVICE SPP.OPEN \SPP.CREATE.STREAM SPP.DESTADDRESS SPPOUTPUTSTREAM SPP.OPENP \STREAM.FROM.PACKET SPP.FORCEOUTPUT SPP.FLUSH.TO.EOF SPP.SENDEOM SPP.CLEAREOM SPP.SENDATTENTION SPP.CLEARATTENTION SPP.CLOSE \SPP.CLOSE.IF.ERROR \SPP.RESETCLOSE SPP.BACKFILEPTR \SPP.GETFILEPTR \SPP.SETFILEPTR \SPP.SKIPBYTES \SPP.BOUTS \SPP.OTHER.BOUT \SPP.GETNEXTBUFFER \SPP.STREAM.LOST \SPP.DEFAULT.ERRORHANDLER \SPP.PREPARE.INPUT \SPP.PREPARE.OUTPUT SPP.DSTYPE SPP.READP SPP.EOFP) (FNS SPPSTREAMP) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\INITSPP] (COMS (* ; "Debugging") (ALISTS (XIPPRINTMACROS 5)) (FNS PPSPP \SPP.INFO.HOOK PPSPPSTREAM \SPP.CHECK.INPUT.QUEUE PRINTSPP) (INITVARS (PRINTSPPDATAFLG)) (GLOBALVARS PRINTSPPDATAFLG)))) (* ; "Sequenced Packet Protocol.") (DECLARE%: EVAL@COMPILE DONTCOPY (FILESLOAD (SOURCE) SPPDECLS) (DECLARE%: EVAL@COMPILE (PUTPROPS RETRANSMITINDEX MACRO ((SEQNO) (IMOD SEQNO \SPP.RETRANSMITQ.SIZE))) [PUTPROPS SEQ.ADD1 MACRO ((FORM INC) (\LOLOC (\ADDBASE FORM (OR INC 1] (PUTPROPS SEQ.GREATERP MACRO ((X Y) (ILESSP (\LOLOC (IDIFFERENCE (IDIFFERENCE X Y) 1)) 32768))) (PUTPROPS SEQ.GEQ MACRO ((X Y) (ILESSP (\LOLOC (IDIFFERENCE X Y)) 32768))) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SPP.USER.TIMEOUT SPP.MIN.TIMEOUT SPP.INACTIVITY.TIMEOUT SPP.MAX.FAILED.PROBES XIPTRACEFLG XIPTRACEFILE) ) ) (ADDTOVAR SYSTEMRECLST (DATATYPE SPPCON ((SPPXIPLENGTH WORD) (NIL BYTE) (SPPXIPTYPE BYTE) (SPPDESTNSADDRESS0 5 WORD) (SPPDESTSKT# WORD) (SPPSOURCENSADDRESS0 5 WORD) (SPPSOURCESKT# WORD) (NIL BYTE) (SPPDSTYPE BYTE) (SPPSOURCEID WORD) (SPPDESTID WORD) (SPPSEQNO WORD) (SPPACKNO WORD) (SPPACCEPTNO WORD) (SPPESTABLISHEDP FLAG) (SPPDESTINATIONKNOWN FLAG) (SPPTERMINATEDP FLAG) (SPPOUTPUTABORTEDP FLAG) (SPPOUTPUTABORTEDFN POINTER) (SPPACKPENDING FLAG) (SPPEOMONFORCEOUT FLAG) (SPPSERVERFLAG FLAG) (SPPINPUTBLOCKED FLAG) (SPPINPUTQ POINTER) (SPPRETRANSMITQ POINTER) (SPPRETRANSMITTING POINTER) (SPPLOCK POINTER) (SPPMYNSOCKET POINTER) (SPPACKEDSEQNO WORD) (SPPOUTPUTALLOCNO WORD) (SPPRETRANSMITTIMER POINTER) (SPPACKREQUESTED POINTER) (SPPACKREQTIME POINTER) (SPPACKREQTIMEOUT POINTER) (SPPROUNDTRIPTIME POINTER) (SPPACTIVITYTIMER POINTER) (SPPATTENTIONFN POINTER) (SPPINPKT POINTER) (SPPOUTPKT POINTER) (SPPSYSPKT POINTER) (SPPINPUTSTREAM POINTER) (SPPSUBSTREAM POINTER) (SPPPROCESS POINTER) (SPPALLOCATIONEVENT POINTER) (SPPINPUTEVENT POINTER) (SPPOUTPUTSTREAM POINTER) (SPPWHENCLOSEDFN POINTER) (SPPSTATE POINTER) (SPPERRORHANDLER POINTER) (SPPSERVERFN POINTER) (SPPOTHERXIPHANDLER POINTER) (SPPINACTIVECOUNT POINTER) (SPPINPUTDSTYPE BYTE) (SPPDSTYPECHANGEFN POINTER))) ) (/DECLAREDATATYPE 'SPPCON '(WORD BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD BYTE BYTE WORD WORD WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER BYTE POINTER) '((SPPCON 0 (BITS . 15)) (SPPCON 1 (BITS . 7)) (SPPCON 1 (BITS . 135)) (SPPCON 2 (BITS . 15)) (SPPCON 3 (BITS . 15)) (SPPCON 4 (BITS . 15)) (SPPCON 5 (BITS . 15)) (SPPCON 6 (BITS . 15)) (SPPCON 7 (BITS . 15)) (SPPCON 8 (BITS . 15)) (SPPCON 9 (BITS . 15)) (SPPCON 10 (BITS . 15)) (SPPCON 11 (BITS . 15)) (SPPCON 12 (BITS . 15)) (SPPCON 13 (BITS . 15)) (SPPCON 14 (BITS . 7)) (SPPCON 14 (BITS . 135)) (SPPCON 15 (BITS . 15)) (SPPCON 16 (BITS . 15)) (SPPCON 17 (BITS . 15)) (SPPCON 18 (BITS . 15)) (SPPCON 19 (BITS . 15)) (SPPCON 20 (FLAGBITS . 0)) (SPPCON 20 (FLAGBITS . 16)) (SPPCON 20 (FLAGBITS . 32)) (SPPCON 20 (FLAGBITS . 48)) (SPPCON 20 POINTER) (SPPCON 22 (FLAGBITS . 0)) (SPPCON 22 (FLAGBITS . 16)) (SPPCON 22 (FLAGBITS . 32)) (SPPCON 22 (FLAGBITS . 48)) (SPPCON 22 POINTER) (SPPCON 24 POINTER) (SPPCON 26 POINTER) (SPPCON 28 POINTER) (SPPCON 30 POINTER) (SPPCON 32 (BITS . 15)) (SPPCON 33 (BITS . 15)) (SPPCON 34 POINTER) (SPPCON 36 POINTER) (SPPCON 38 POINTER) (SPPCON 40 POINTER) (SPPCON 42 POINTER) (SPPCON 44 POINTER) (SPPCON 46 POINTER) (SPPCON 48 POINTER) (SPPCON 50 POINTER) (SPPCON 52 POINTER) (SPPCON 54 POINTER) (SPPCON 56 POINTER) (SPPCON 58 POINTER) (SPPCON 60 POINTER) (SPPCON 62 POINTER) (SPPCON 64 POINTER) (SPPCON 66 POINTER) (SPPCON 68 POINTER) (SPPCON 70 POINTER) (SPPCON 72 POINTER) (SPPCON 74 POINTER) (SPPCON 76 POINTER) (SPPCON 78 (BITS . 7)) (SPPCON 80 POINTER)) '82) (RPAQ? SPP.USER.TIMEOUT 15000) (RPAQ? SPP.INACTIVITY.TIMEOUT 120000) (RPAQ? SPP.MIN.TIMEOUT 50) (RPAQ? SPP.MAX.FAILED.PROBES 5) (DEFINEQ (\SPPCONNECTION [LAMBDA (HOST SKT# NAME) (* ; "Edited 26-May-91 12:02 by jds") (* ;;; "Create an active connection if HOST is specified. NAME is optional name of connection watcher process. If HOST is NIL, sets up a listener on socket SKT#") [if HOST then (SETQ HOST (OR (\COERCE.TO.NSADDRESS HOST SKT#) (\ILLEGAL.ARG HOST] (LET [(CON (\SPP.CREATE.CON (AND (NULL HOST) SKT#] (COND (HOST (* ;  "User wants to initiate connection to host.") (\BLT (LOCF (fetch (SPPCON SPPDESTNSADDRESS0) of CON)) HOST \#WDS.NSADDRESS) (replace (SPPCON SPPDESTINATIONKNOWN) of CON with T))) [\SPP.CREATE.WATCHER CON (COND (NAME) (HOST (CONCAT "SPP#" (SPP.DESTADDRESS CON))) (T 'SPPSERVER] CON]) (\SPP.CREATE.CON [LAMBDA (SKT#) (* ; "Edited 26-May-91 12:02 by jds") (* ;; "Creates an SPPCON object, initialized to be a connection from this machine, etc. If SKT# is specified, we open that exact socket, else a random user socket.") (LET* ((NSOC (OPENNSOCKET SKT#)) (CON (create SPPCON SPPXIPLENGTH _ (+ \XIPOVLEN \SPPHEAD.LENGTH) SPPXIPTYPE _ \XIPT.SPP SPPSOURCEID _ (LOGOR 32768 (LOGAND (DAYTIME) 32767)) SPPMYNSOCKET _ NSOC SPPSOURCESKT# _ (NSOCKETNUMBER NSOC) SPPACCEPTNO _ \SPP.INITIAL.ALLOCATION))) (\BLT (LOCF (fetch (SPPCON SPPSOURCENSADDRESS0) of CON)) \MY.NSADDRESS (SUB1 \#WDS.NSADDRESS)) CON]) (\SPP.CREATE.STREAMS [LAMBDA (CON) (* ; "Edited 26-May-91 12:18 by jds") (* ;;; "Creates input and output streams for SPP connection CON and installs them appropriately. Returns the input stream") (LET [(INSTREAM (\SPP.CREATE.STREAM 'INPUT)) (OUTSTREAM (\SPP.CREATE.STREAM 'OUTPUT] (replace (SPPCON SPPINPUTSTREAM) of CON with INSTREAM) (replace (SPPSTREAM SPP.CONNECTION) of INSTREAM with CON) (replace (STREAM STRMBOUTFN) of INSTREAM with (FUNCTION \SPP.OTHER.BOUT)) (replace (SPPCON SPPOUTPUTSTREAM) of CON with OUTSTREAM) (replace (SPPSTREAM SPP.CONNECTION) of OUTSTREAM with CON) (push (fetch (FDEV DEVICEINFO) of \SPPDEVICE) INSTREAM) INSTREAM]) (\SPP.CREATE.WATCHER [LAMBDA (CON NAME) (* ; "Edited 26-May-91 12:02 by jds") (replace (SPPCON SPPINPUTEVENT) of CON with (CREATE.EVENT NAME)) (replace (SPPCON SPPLOCK) of CON with (CREATE.MONITORLOCK NAME)) (replace (SPPCON SPPROUNDTRIPTIME) of CON with \SPP.INITIAL.ROUNDTRIP) (replace (SPPCON SPPPROCESS) of CON with (ADD.PROCESS (LIST (FUNCTION \SPPWATCHER) (KWOTE CON)) 'NAME NAME 'RESTARTABLE 'HARDRESET 'AFTEREXIT 'DELETE]) (\SPP.SENDPKT [LAMBDA (CON EPKT RETRANSMITP) (* ; "Edited 26-May-91 12:21 by jds") (* ;; "This function makes sure the variable connection information in the packet is current, and actually sends the packet. If the packet is to be retransmitted, the connection must be locked when this function is called. Note that the sequence number is NOT updated; it was allocated once and for all by \SENDSPP") (PROG ((ACK# (fetch (SPPCON SPPACKNO) of CON)) (ALLOC# (fetch (SPPCON SPPACCEPTNO) of CON)) (BASE (fetch (XIP XIPCONTENTS) of EPKT)) SEQNO) (AND RETRANSMITP (HELP "RETRANSMITP on")) (replace (SPPHEAD ACKNO) of BASE with ACK#) (replace (SPPHEAD ALLOCNO) of BASE with ALLOC#) (replace (SPPCON SPPINPUTBLOCKED) of CON with (SEQ.GREATERP ACK# ALLOC#)) (* ;  "If ACK# > ALLOC# then partner cannot send more data until we eat some of what we have") [COND ((fetch (SPPHEAD SENDACK) of BASE) (* ;; "We start a timer when we send an Ack request, and turn it off when the next packet arrives (in \SPPINPUTWORK.) If the timer expires, we assume that the connection is wedged. Otherwise, the elapsed time will be used to update our estimate of the round trip delay. The timer will go off after the user-level timeout, or twice the round trip delay, whichever is longer.") (SETQ SEQNO (fetch (SPPHEAD SEQNO) of BASE)) [COND ((OR (NOT (fetch (SPPCON SPPACKREQUESTED) of CON)) (SEQ.GREATERP SEQNO (fetch (SPPCON SPPACKREQUESTED) of CON))) (replace (SPPCON SPPACKREQUESTED) of CON with SEQNO) (replace (SPPCON SPPACKREQTIME) of CON with (SETUPTIMER 0 (fetch (SPPCON SPPACKREQTIME ) of CON] (replace (SPPCON SPPACKREQTIMEOUT) of CON with (SETUPTIMER (UNFOLD (fetch (SPPCON SPPROUNDTRIPTIME) of CON) 2) (fetch (SPPCON SPPACKREQTIMEOUT) of CON] (replace (SPPCON SPPACKPENDING) of CON with NIL) (* ;  "If partner asked for an ack, this will satisfy it") (SENDXIP (fetch (SPPCON SPPMYNSOCKET) of CON) EPKT) (replace (SPPCON SPPRETRANSMITTIMER) of CON with (SETUPTIMER (COND ((fetch (SPPCON SPPRETRANSMITTING) of CON) (fetch (SPPCON SPPROUNDTRIPTIME) of CON)) (T (UNFOLD (fetch (SPPCON SPPROUNDTRIPTIME) of CON) 2))) (fetch (SPPCON SPPRETRANSMITTIMER) of CON]) (\FILLINSPP [LAMBDA (CON CCONTROL DSTYPE) (* ; "Edited 26-May-91 12:21 by jds") (PROG ((EPKT (\ALLOCATE.ETHERPACKET)) BASE) (replace EPTYPE of EPKT with \EPT.XIP) (\BLT (LOCF (fetch (XIP XIPLENGTH) of EPKT)) (LOCF (fetch (SPPCON SPPXIPLENGTH) of CON)) \#WDS.SPPINFO) (* ;  "Fill in canonical SPP packet for this connection") (SETQ BASE (fetch (XIP XIPCONTENTS) of EPKT)) (AND CCONTROL (replace (SPPHEAD CC) of BASE with CCONTROL)) (AND DSTYPE (replace (SPPHEAD DSTYPE) of BASE with DSTYPE)) (RETURN EPKT]) (\SPP.SYSPKT [LAMBDA (CON CCBITS) (* ; "Edited 26-May-91 12:21 by jds") (* ;; "Return a System packet for the connection with the specified control bits set. Uses the cached packet if there is one.") (PROG ((XIP (fetch (SPPCON SPPSYSPKT) of CON)) BASE) [COND ((NULL XIP) (SETQ XIP (\FILLINSPP CON)) (replace (SPPCON SPPSYSPKT) of CON with XIP)) (T (while (fetch EPTRANSMITTING of XIP) do (BLOCK] (SETQ BASE (fetch (XIP XIPCONTENTS) of XIP)) (replace (SPPHEAD CC) of BASE with (LOGOR \SPPHEAD.CC.SYSTEM (OR CCBITS 0))) (replace (SPPHEAD SEQNO) of BASE with (fetch (SPPCON SPPSEQNO) of CON)) (RETURN XIP]) (\GETSPP [LAMBDA (CON TIMEOUT PEEKFLG) (* ; "Edited 26-May-91 12:02 by jds") (* ;; "Obtains the next packet on this SPP connection. If TIMEOUT is specified and expires before a packet arrives, returns NIL. Also returns NIL if the connection is terminated. If PEEKFLG is true, returns the next packet without removing it from queue.") (WITH.MONITOR (fetch (SPPCON SPPLOCK) of CON) [bind (EPKT _ NIL) (TIMER _ (SETUPTIMER (OR TIMEOUT SPP.USER.TIMEOUT))) do (COND ((AND (SETQ EPKT (\QUEUEHEAD (fetch (SPPCON SPPINPUTQ) of CON))) (SEQ.GREATERP (fetch (SPPCON SPPACKNO) of CON) (fetch (SPPXIP SEQNO) of EPKT))) (* ;; "This is the packet we've been waiting for. The ACKNO field has already been incremented in \SPP.HANDLE.DATA") [COND ((NOT PEEKFLG) (UNINTERRUPTABLY (\DEQUEUE (fetch (SPPCON SPPINPUTQ) of CON)) (change (fetch (SPPCON SPPACCEPTNO) of CON) (SEQ.ADD1 DATUM))) (COND ((AND (fetch (SPPCON SPPINPUTBLOCKED) of CON) (SEQ.GREATERP (fetch (SPPCON SPPACCEPTNO) of CON) (fetch (SPPCON SPPACKNO) of CON))) (* ;; "Partner was waiting to be able to transmit again, so allow it now. Don't send this gratuitous ack the moment we open up; wait for the window to at least get a couple of packets wide") (\SPP.SENDPKT CON (\SPP.SYSPKT CON] (RETURN EPKT)) ((OR (AND TIMEOUT (TIMEREXPIRED? TIMER)) (fetch (SPPCON SPPTERMINATEDP) of CON)) (RETURN NIL)) (T (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of CON) (fetch (SPPCON SPPINPUTEVENT) of CON) TIMER T])]) (\SENDSPP [LAMBDA (CON EPKT IGNOREALLOC) (* ; "Edited 26-May-91 12:02 by jds") (* ;; "Send the next SPP packet over the connection. Blocks if necessary until the allocation window opens up. Returns T if successful, NIL if connection dropped.") (CHECK (type? ETHERPACKET EPKT) (NOT (fetch (SPPXIP SYSTEMPACKET) of EPKT))) (WITH.MONITOR (fetch (SPPCON SPPLOCK) of CON) [bind SEQNO while (NOT (fetch (SPPCON SPPTERMINATEDP) of CON)) do (COND ((SEQ.GEQ (COND (IGNOREALLOC (* ;; "Can send attention packet regardless of allocation, but make sure there is room in the retransmit pool") (SEQ.ADD1 (fetch (SPPCON SPPACKEDSEQNO) of CON) (SUB1 \SPP.RETRANSMITQ.SIZE))) (T (* ;  "Make sure allocation window open") (fetch (SPPCON SPPOUTPUTALLOCNO) of CON))) (fetch (SPPCON SPPSEQNO) of CON)) (\BLT (LOCF (fetch (SPPXIP SOURCECONID) of EPKT)) (LOCF (fetch (SPPCON SPPSOURCEID) of CON)) 5) (* ;  "Fill in connection id's and sequence numbers") (UNINTERRUPTABLY [replace (SPPCON SPPSEQNO) of CON with (SEQ.ADD1 (SETQ SEQNO (fetch (SPPCON SPPSEQNO) of CON] (* ;; "Bump the sequence number and stuff the packet into the retransmit bin. This is the only place, I think, where it would hurt us to be interrupted. After this, it is okay if we are interrupted even before the packet actually gets sent, since the retransmit logic will take over") (SETA (fetch (SPPCON SPPRETRANSMITQ) of CON) (IMOD SEQNO \SPP.RETRANSMITQ.SIZE) EPKT)) (* ;  "advance the packet sequence number.") (COND ((AND (EQ SEQNO (fetch (SPPCON SPPOUTPUTALLOCNO) of CON)) (NEQ (fetch (SPPXIP DSTYPE) of EPKT) \SPPDSTYPE.ENDREPLY)) (* ;  "Sending this packet exhausts our allocation, so request an ack in hopes of getting more") (replace (SPPXIP SENDACK) of EPKT with T))) (\SPP.SENDPKT CON EPKT) (RETURN T)) (T (* ;  "Otherwise, we have to wait until the other end opens up the allocation window.") (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of CON) (fetch (SPPCON SPPALLOCATIONEVENT) of CON])]) (\SPP.SEND.ENDREPLY [LAMBDA (CON NOACK) (* bvm%: "22-Jun-84 14:57") (\SENDSPP CON (\FILLINSPP CON (LOGOR \SPPHEAD.CC.EOM (COND (NOACK 0) (T \SPPHEAD.CC.ACKNOWLEDGE))) \SPPDSTYPE.ENDREPLY) T]) (\TERMINATESPP [LAMBDA (CON TIMEOUT) (* ; "Edited 26-May-91 12:02 by jds") (* ;  "Reliable connection termination, as in section 7.5 of the spec.") (WITH.MONITOR (fetch (SPPCON SPPLOCK) of CON) (PROG NIL (SELECTC (fetch (SPPCON SPPSTATE) of CON) ((LIST \SPS.CLOSED \SPS.ABORTED) (RETURN NIL)) ((LIST \SPS.INIT \SPS.LISTENING) (replace (SPPCON SPPTERMINATEDP) of CON with T) (replace (SPPCON SPPSTATE) of CON with \SPS.ABORTED) (RETURN NIL)) (\SPS.OPEN (* ;  "We initiate the termination by sending an END packet.") (\SENDSPP CON (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.EOM) \SPPDSTYPE.END) T) (replace (SPPCON SPPSTATE) of CON with \SPS.ENDSENT)) NIL) [COND ((NEQ TIMEOUT 0) (bind (TIMER _ (SETUPTIMER (OR TIMEOUT 5000))) do (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of CON) (fetch (SPPCON SPPINPUTEVENT) of CON) TIMER T) (SELECTC (fetch (SPPCON SPPSTATE) of CON) (\SPS.CLOSED (RETURN T)) (\SPS.ABORTED (RETURN)) NIL) repeatuntil (TIMEREXPIRED? TIMER] (replace (SPPCON SPPSTATE) of CON with \SPS.ABORTED) (DEL.PROCESS (PROG1 (fetch (SPPCON SPPPROCESS) of CON) (replace (SPPCON SPPPROCESS) of CON with NIL))) (RETURN NIL)))]) (\SPP.CLEANUP [LAMBDA (CON) (* ; "Edited 26-May-91 12:03 by jds") (* ;; "Called when \SPPWATCHER exits.") (SELECTQ RESETSTATE (HARDRESET (* ;  "Don't do this if process is being restarted after HARDRESET") NIL) (WITH.MONITOR (fetch (SPPCON SPPLOCK) of CON) (PROG ((INSTREAM (fetch (SPPCON SPPINPUTSTREAM) of CON)) FN) (replace (SPPCON SPPTERMINATEDP) of CON with T) (NOTIFY.EVENT (fetch (SPPCON SPPINPUTEVENT) of CON)) (NOTIFY.EVENT (fetch (SPPCON SPPALLOCATIONEVENT) of CON)) (* ;  "We just notified anyone who might be blocked waiting for something to happen on this connection.") (replace (FDEV DEVICEINFO) of \SPPDEVICE with (DREMOVE INSTREAM (fetch (FDEV DEVICEINFO ) of \SPPDEVICE))) [COND ((SETQ FN (fetch (SPPCON SPPWHENCLOSEDFN) of CON)) (for F in (COND ((AND (LISTP FN) (NEQ (CAR FN) 'LAMBDA)) FN) (T (LIST FN))) do (APPLY* F INSTREAM CON] (replace (SPPCON SPPOUTPUTSTREAM) of CON with (replace (SPPCON SPPINPUTSTREAM) of CON with (replace (SPPCON SPPSUBSTREAM) of CON with NIL))) (* ;  "Snap circular links before we lose control") (CLOSENSOCKET (PROG1 (fetch (SPPCON SPPMYNSOCKET) of CON) (replace (SPPCON SPPMYNSOCKET) of CON with NIL)) T) (replace (SPPCON SPPPROCESS) of CON with NIL)))]) ) (DEFINEQ (\SPPWATCHER [LAMBDA (SPPCON) (* ; "Edited 26-May-91 12:03 by jds") (DECLARE (SPECVARS SPPCON)) (RESETSAVE NIL (LIST (FUNCTION \SPP.CLEANUP) SPPCON)) (PROCESSPROP (THIS.PROCESS) 'INFOHOOK (FUNCTION \SPP.INFO.HOOK)) (if (NULL (fetch (SPPCON SPPACTIVITYTIMER) of SPPCON)) then (replace (SPPCON SPPACTIVITYTIMER) of SPPCON with (SETUPTIMER 0))) (WITH.MONITOR (fetch (SPPCON SPPLOCK) of SPPCON) [bind (SOCEVENT _ (NSOCKETEVENT (fetch (SPPCON SPPMYNSOCKET) of SPPCON))) (ACKINTERVAL _ (IQUOTIENT (TIMES SPP.USER.TIMEOUT 2) 3)) ACTIVITY TIMER until (fetch (SPPCON SPPTERMINATEDP) of SPPCON) do [COND ((SETQ ACTIVITY (\SPP.HANDLE.INPUT SPPCON)) (* ;  "Got some input, so partner is alive") (replace (SPPCON SPPINACTIVECOUNT) of SPPCON with NIL) (SETUPTIMER 0 (fetch (SPPCON SPPACTIVITYTIMER) of SPPCON] (COND ((AND (NULL ACTIVITY) (NOT (fetch (SPPCON SPPESTABLISHEDP) of SPPCON)) (NOT (fetch (SPPCON SPPDESTINATIONKNOWN) of SPPCON))) (* ;  "Nothing happening, and we're just listening. Go back to sleep") (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of SPPCON) SOCEVENT)) (T (* ;  "Do what is appropriate for state of connection") (SETQ TIMER (fetch (SPPCON SPPRETRANSMITTIMER) of SPPCON)) (* ;  "Default time we might want to do something next") [COND ((fetch (SPPCON SPPRETRANSMITTING) of SPPCON) (* ;  "In the midst of retransmitting one or more packets that appear to have been missed") (\SPP.RETRANSMIT.NEXT SPPCON)) ((fetch (SPPCON SPPACKPENDING) of SPPCON) (* ; "Partner asked for an ack, and we haven't sent anything yet as part of our routine activity, so send simple ack") (\SPP.SENDPKT SPPCON (\SPP.SYSPKT SPPCON (if (\CLOCKGREATERP (fetch (SPPCON SPPACKREQTIME ) of SPPCON) ACKINTERVAL) then (* ; "if we haven't timed an ACK in a while, take the opportunity now. This lets us kill two birds with one stone, er, packet--responding to partner's ack, and getting round trip info ourselves.") \SPPHEAD.CC.ACKNOWLEDGE))) (replace (SPPCON SPPACKPENDING) of SPPCON with NIL)) ((NULL ACTIVITY) (* ; "No input activity") (COND ((fetch (SPPCON SPPACKREQUESTED) of SPPCON) (* ;  "We requested an ack, haven't heard anything back") (if (TIMEREXPIRED? (SETQ TIMER (fetch (SPPCON SPPACKREQTIMEOUT ) of SPPCON)) ) then (\SPP.NOT.RESPONDING SPPCON))) ((OR (SEQ.GREATERP (fetch (SPPCON SPPSEQNO) of SPPCON) (fetch (SPPCON SPPACKEDSEQNO) of SPPCON)) (SEQ.GREATERP (fetch (SPPCON SPPSEQNO) of SPPCON) (fetch (SPPCON SPPOUTPUTALLOCNO) of SPPCON))) (* ;  "Not all outstanding packets are acked, or we are out of allocation") (if (TIMEREXPIRED? TIMER) then (* ; "Time to poke again") (\SPP.PROBE SPPCON))) (T (* ;  "Connection is quiet. Periodically poke the other end to make sure it's still alive") (if (\CLOCKGREATERP (fetch (SPPCON SPPACTIVITYTIMER) of SPPCON) SPP.USER.TIMEOUT) then (* ; "Haven't heard anything in a while. Next time thru, SPPACKREQUESTED will be true, so we'll never do this twice in a row.") (\SPP.PROBE SPPCON) else (* ;  "Don't need to wake up again until previous clause wants it") (SETUPTIMER [IMAX 0 (- SPP.USER.TIMEOUT (CLOCKDIFFERENCE (fetch (SPPCON SPPACTIVITYTIMER ) of SPPCON] TIMER] (if (fetch (SPPCON SPPTERMINATEDP) of SPPCON) then (RETURN)) (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of SPPCON) SOCEVENT TIMER T])]) (\SPP.HANDLE.INPUT [LAMBDA (CON) (* ; "Edited 26-May-91 12:21 by jds") (* ;; "Handle all queued input packets. Returns T if there was activity on the connection.") (PROG (XIP SPPBASE PKTSEQNO ACTIVE? ATTN ACKED ACKRECEIVED ALLOCINCREASED ADDRESSEDID NEWALLOCNO MAXALLOCNO) LOOP (COND ((fetch (SPPCON SPPTERMINATEDP) of CON) (RETURN T))) (SETQ XIP (GETXIP (fetch (SPPCON SPPMYNSOCKET) of CON))) (COND ((NULL XIP) [COND ((AND ACKRECEIVED (NOT ALLOCINCREASED) (SEQ.GREATERP (fetch (SPPCON SPPSEQNO) of CON) (fetch (SPPCON SPPACKEDSEQNO) of CON)) (NULL (fetch (SPPCON SPPRETRANSMITTING) of CON))) (* ;; "We received an apparently genuine ack, but there are still unacked packets, so assume that they have not been seen--start retransmitting them. The test for ALLOCINCREASED is in the hopes that this ack was so old that future acks will say the data arrived okay") (replace (SPPCON SPPRETRANSMITTING) of CON with (fetch (SPPCON SPPACKEDSEQNO ) of CON] (RETURN ACTIVE?))) (SELECTC (fetch (XIP XIPTYPE) of XIP) (\XIPT.SPP) (\XIPT.ERROR (COND ((EQ (fetch ERRORXIPCODE of XIP) \XIPE.NOSOCKET) (* ;  "Partner not there, or disappeared") (replace (SPPCON SPPTERMINATEDP) of CON with T) (\RELEASE.ETHERPACKET XIP) (RETURN T))) (GO DROPIT)) (PROGN (APPLY* (OR (fetch (SPPCON SPPOTHERXIPHANDLER) of CON) (FUNCTION RELEASE.XIP)) XIP (fetch (SPPCON SPPMYNSOCKET) of CON)) (GO LOOP))) (SETQ SPPBASE (fetch (XIP XIPCONTENTS) of XIP)) (COND ((OR (AND (fetch (SPPCON SPPESTABLISHEDP) of CON) (NEQ (fetch (SPPHEAD SOURCECONID) of SPPBASE) (fetch (SPPCON SPPDESTID) of CON))) (AND (NEQ (SETQ ADDRESSEDID (fetch (SPPHEAD DESTCONID) of SPPBASE)) (fetch (SPPCON SPPSOURCEID) of CON)) (NEQ ADDRESSEDID 0))) (* ;; "If the connection has already been established, then both connection IDs must match. Otherwise, the destination ID in the packet must be ours if it is nonzero.") (\SPPSENDERROR CON XIP "Wrong connection ID.") (GO DROPIT))) (SETQ PKTSEQNO (fetch (SPPHEAD SEQNO) of SPPBASE)) (COND ((OR (SEQ.GREATERP (fetch (SPPCON SPPACKNO) of CON) (SEQ.ADD1 PKTSEQNO 3000)) (SEQ.GREATERP PKTSEQNO (SEQ.ADD1 (fetch (SPPCON SPPACCEPTNO) of CON) 2))) (* ;; "Sequence numbers more than 1 or 2 past the allocation or delayed by more than a few thousand are grounds for generating an error response. See section 7.2 of the spec.") (\SPPSENDERROR CON XIP "Packet out of allocation sequence.") (GO DROPIT))) (* ;  "We have a legal packet for this connection.") (COND [(NOT (fetch (SPPCON SPPESTABLISHEDP) of CON)) (* ;  "We're just now establishing the connection.") (\SPP.ESTABLISH CON XIP) (COND ((fetch (SPPCON SPPSERVERFLAG) of CON) (* ;; "This process is a server. Remain a server in the listening state") (GO LOOP] (T (SETQ ACTIVE? T))) (COND ((fetch (SPPHEAD ATTENTION) of SPPBASE) (COND ((fetch (SPPHEAD SYSTEMPACKET) of SPPBASE) (\SPPSENDERROR CON XIP "Both System and Attention control bits?") (GO DROPIT))) (COND ((IGREATERP (IDIFFERENCE (fetch (XIP XIPLENGTH) of XIP) (IPLUS \XIPOVLEN \SPPHEAD.LENGTH)) 1) (\SPPSENDERROR CON XIP "More than 1 byte of data in Attention packet?") (GO DROPIT))) (SETQ ATTN T))) (COND ((SEQ.GREATERP (SETQ ACKED (fetch (SPPHEAD ACKNO) of SPPBASE)) (fetch (SPPCON SPPACKEDSEQNO) of CON)) (\SPP.RELEASE.ACKED.PACKETS CON ACKED))) [COND ([AND (SEQ.GREATERP (SETQ NEWALLOCNO (fetch (SPPHEAD ALLOCNO) of SPPBASE)) (fetch (SPPCON SPPOUTPUTALLOCNO) of CON)) (OR (SEQ.GEQ (SETQ MAXALLOCNO (IPLUS (fetch (SPPCON SPPACKEDSEQNO) of CON) (SUB1 \SPP.RETRANSMITQ.SIZE))) NEWALLOCNO) (SEQ.GREATERP (SETQ NEWALLOCNO MAXALLOCNO) (fetch (SPPCON SPPOUTPUTALLOCNO) of CON] (* ;  "Limit our actual allocation to the maximum we are willing to buffer up") (replace (SPPCON SPPOUTPUTALLOCNO) of CON with NEWALLOCNO) (SETQ ALLOCINCREASED T) (NOTIFY.EVENT (fetch (SPPCON SPPALLOCATIONEVENT) of CON] (COND ((fetch (SPPHEAD SENDACK) of SPPBASE) (* ;  "The other end wants an acknowledgment. Wait until we have processed all input") (replace (SPPCON SPPACKPENDING) of CON with T))) (COND ((fetch (SPPHEAD SYSTEMPACKET) of SPPBASE) (* ; "Don't keep system packets") (RELEASE.XIP XIP)) (T (\SPP.HANDLE.DATA CON XIP) (* ;  "Note that this call may increment the connection's ACKNO field.") )) (COND ([AND (fetch (SPPCON SPPACKREQUESTED) of CON) (OR (NEQ ACKED (fetch (SPPCON SPPACKREQUESTED) of CON)) (EQ ACKED (fetch (SPPCON SPPSEQNO) of CON] (* ;; "This is the first packet that has arrived since we turned on the Ack request timer in \SPP.SENDPKT. Turn off the timer and update our estimate of round trip delay. This packet might be delayed, and not really in response to our Ack request. The NEQ test filters out packets that cannot possibly be in response to our ACK: if partner received our request at seqno N, and has seen up thru N-1, ACKED should be N+1, unless the ack request was on a system packet.") (replace (SPPCON SPPROUNDTRIPTIME) of CON with (LRSH (IPLUS (ITIMES 3 (fetch (SPPCON SPPROUNDTRIPTIME) of CON)) (IMAX SPP.MIN.TIMEOUT (IMIN (CLOCKDIFFERENCE (fetch (SPPCON SPPACKREQTIME) of CON)) SPP.USER.TIMEOUT))) 2)) (replace (SPPCON SPPACKREQUESTED) of CON with NIL) (SETQ ACKRECEIVED T))) (COND (ATTN (\SPP.HANDLE.ATTN CON XIP))) (GO LOOP) DROPIT (RELEASE.XIP XIP) (GO LOOP]) (\SPP.HANDLE.DATA [LAMBDA (CON XIP) (* ; "Edited 26-May-91 12:03 by jds") (* ;; "This function is called when a non-System packet has arrived for a connection. It inserts the packet in the proper place in the queue, ordered by sequence number. If the packet is a duplicate, it is dropped.") (PROG ((ACKNO (fetch (SPPCON SPPACKNO) of CON)) (INQ (fetch (SPPCON SPPINPUTQ) of CON)) (XIPNO (fetch (SPPXIP SEQNO) of XIP)) CURRENT NEXT PKTNO) (CHECK (\SPP.CHECK.INPUT.QUEUE CON)) [COND ((SEQ.GREATERP ACKNO XIPNO) (* ;  "This packet is a duplicate, so drop it.") (RELEASE.XIP XIP) (RETURN)) ([OR (NULL (SETQ CURRENT (\QUEUEHEAD INQ))) (SEQ.GREATERP XIPNO (fetch (SPPXIP SEQNO) of (fetch SYSQUEUETAIL of INQ] (* ; "Goes at tail end of queue.") (\ENQUEUE INQ XIP)) ((SEQ.GREATERP (SETQ PKTNO (fetch (SPPXIP SEQNO) of CURRENT)) XIPNO) (* ; "Goes right at head of queue.") (replace QLINK of XIP with CURRENT) (replace SYSQUEUEHEAD of INQ with XIP)) (T (do (* ;  "Loop until the correct place is found for this packet.") (COND ((EQ XIPNO PKTNO) (* ;  "This packet is a duplicate, so drop it.") (RELEASE.XIP XIP) (RETURN))) (SETQ NEXT (fetch QLINK of CURRENT)) (SETQ PKTNO (fetch (SPPXIP SEQNO) of NEXT)) (COND ((SEQ.GREATERP PKTNO XIPNO) (* ; "Here's where it goes.") (replace QLINK of XIP with NEXT) (replace QLINK of CURRENT with XIP) (RETURN))) (SETQ CURRENT NEXT] (SELECTC (fetch (SPPXIP DSTYPE) of XIP) (\SPPDSTYPE.END (replace (SPPCON SPPSTATE) of CON with \SPS.ENDRECEIVED) (LET ((OUTSTREAM (fetch (SPPCON SPPOUTPUTSTREAM) of CON))) (* ; "Can't send any more") (replace (STREAM ACCESS) of OUTSTREAM with NIL) (replace (STREAM STRMBOUTFN) of OUTSTREAM with (FUNCTION \SPP.STREAM.LOST)) (* ;; "Make attempt to output to this stream go thru same error mechanism as other ways of losing stream, rather than getting lisp's FILE NOT OPEN error.") ) (\SPP.SEND.ENDREPLY CON) (replace (SPPCON SPPSTATE) of CON with \SPS.DALLYING)) (\SPPDSTYPE.ENDREPLY (SELECTC (fetch (SPPCON SPPSTATE) of CON) (\SPS.DALLYING (* ;  "This is the closing end reply, so can quit now")) (\SPS.ENDSENT (* ; "This is the reply to our END") (\SPP.SEND.ENDREPLY CON T)) (\SPPSENDERROR CON XIP "unexpected ENDREPLY")) (replace (SPPCON SPPSTATE) of CON with \SPS.CLOSED) (replace (SPPCON SPPTERMINATEDP) of CON with T)) NIL) (COND ((EQ XIPNO ACKNO) (* ;; "Looks like this packet opens the way for some acknowledgements. Find the end of the run of consecutive packets starting with the one we've just inserted.") (while (AND (SETQ XIP (fetch QLINK of XIP)) (EQ (SETQ PKTNO (fetch (SPPXIP SEQNO) of XIP)) (SEQ.ADD1 XIPNO))) do (SETQ XIPNO PKTNO)) (replace (SPPCON SPPACKNO) of CON with (SEQ.ADD1 XIPNO)) (NOTIFY.EVENT (fetch (SPPCON SPPINPUTEVENT) of CON]) (\SPP.HANDLE.ATTN [LAMBDA (CON XIP) (* ; "Edited 26-May-91 12:03 by jds") (* ;;; "Called when a packet is received with Attention bit set") (PROG ((ATTENTIONFN (fetch (SPPCON SPPATTENTIONFN) of CON)) (BYTE (fetch (SPPXIP FIRSTSPPDATABYTE) of XIP)) (DSTYPE (fetch (SPPXIP DSTYPE) of XIP)) STREAM) (COND ((AND ATTENTIONFN (for FN in (COND ((OR (NLISTP ATTENTIONFN) (MEMB (CAR ATTENTIONFN) LAMBDASPLST)) (LIST ATTENTIONFN)) (T ATTENTIONFN)) thereis (APPLY* FN (fetch (SPPCON SPPINPUTSTREAM) of CON) BYTE DSTYPE))) (* ; "Somebody knew how to handle it") ) (NSWIZARDFLG (* ;  "Some other kind of attention we don't know about") (printout PROMPTWINDOW .TAB0 0 "[Attention packet (" BYTE ")]"]) (\SPP.RELEASE.ACKED.PACKETS [LAMBDA (CON ACKNO) (* ; "Edited 26-May-91 12:03 by jds") (* ;;; "Releases packets that are acked by incoming ACKNO, i.e., any packets with sequence number less than ACKNO. Packets are held in SPPRETRANSMITQ array") (bind (POOL _ (fetch (SPPCON SPPRETRANSMITQ) of CON)) (OLDACKNO _ (fetch (SPPCON SPPACKEDSEQNO) of CON)) (MAXACKNO _ (fetch (SPPCON SPPSEQNO) of CON)) XIP while (SEQ.GREATERP ACKNO OLDACKNO) do [COND ((EQ OLDACKNO MAXACKNO) (RETURN (AND XIPTRACEFLG (HELP "SPP Partner acked a packet I haven't sent yet" ACKNO] (SETQ XIP (ELT POOL (RETRANSMITINDEX OLDACKNO))) [CHECK (AND XIP (EQ OLDACKNO (fetch (SPPXIP SEQNO) of XIP] (UNINTERRUPTABLY (SETA POOL (RETRANSMITINDEX OLDACKNO) NIL) (RELEASE.XIP XIP) (replace (SPPCON SPPACKEDSEQNO) of CON with (SETQ OLDACKNO (SEQ.ADD1 OLDACKNO)))) (replace (SPPCON SPPRETRANSMITTING) of CON with NIL) (* ;  "If we get ANY interesting ack, stop retransmission until we figure out what's going on") ]) (\SPP.NOT.RESPONDING [LAMBDA (CON) (* ; "Edited 26-May-91 12:03 by jds") (* ;; "There hasn't been any response to our probes for a while.") (COND ((AND (>= (replace (SPPCON SPPINACTIVECOUNT) of CON with (ADD1 (OR (fetch (SPPCON SPPINACTIVECOUNT) of CON) 0))) SPP.MAX.FAILED.PROBES) (OR (NOT (fetch (SPPCON SPPESTABLISHEDP) of CON)) (\CLOCKGREATERP (fetch (SPPCON SPPACTIVITYTIMER) of CON) SPP.INACTIVITY.TIMEOUT))) (* ;; "If the connection hasn't been established yet, or if the roundtrip time is intolerably long, we drop the connection.") (replace (SPPCON SPPTERMINATEDP) of CON with T)) (T (replace (SPPCON SPPROUNDTRIPTIME) of CON with (IMIN SPP.USER.TIMEOUT (TIMES (fetch (SPPCON SPPROUNDTRIPTIME ) of CON) 2))) (* ;  "Increase our estimate of the time it takes the other end to respond.") (\SPP.PROBE CON) (COND ((AND (fetch (SPPCON SPPESTABLISHEDP) of CON) (EQ (fetch (SPPCON SPPINACTIVECOUNT) of CON) (- SPP.MAX.FAILED.PROBES 2))) (* ;  "Warn the user after a while that the other end may have crashed, but hang in there.") (if (\CLOCKGREATERP (fetch (SPPCON SPPACTIVITYTIMER) of CON) (LRSH SPP.INACTIVITY.TIMEOUT 2)) then (printout PROMPTWINDOW T (PROCESSPROP (THIS.PROCESS) 'NAME) " not responding. ") else (* ; "Don't be unduly alarming--it hasn't been that long. If the round trip time had once been exceedingly low, doubling it a few times doesn't get us very far, so back off") (add (fetch (SPPCON SPPINACTIVECOUNT) of CON) -1]) (\SPP.PROBE [LAMBDA (CON) (* bvm%: " 2-Aug-84 16:32") (* ;; "Send out a system packet requesting acknowledgement from other side.") (\SPP.SENDPKT CON (\SPP.SYSPKT CON \SPPHEAD.CC.ACKNOWLEDGE]) (\SPP.RETRANSMIT.NEXT [LAMBDA (CON) (* ; "Edited 26-May-91 12:04 by jds") (PROG ((SEQNO (fetch (SPPCON SPPRETRANSMITTING) of CON)) XIP) (SETQ XIP (ELT (fetch (SPPCON SPPRETRANSMITQ) of CON) (IMOD SEQNO \SPP.RETRANSMITQ.SIZE))) (CHECK (EQ SEQNO (fetch (SPPXIP SEQNO) of XIP))) [replace (SPPXIP SENDACK) of XIP with (if T then T else (* ;  "Turn off any undesired acknowledge bit") (EQ SEQNO (fetch (SPPCON SPPOUTPUTALLOCNO ) of CON] (replace (SPPCON SPPRETRANSMITTING) of CON with (COND ((EQ (SETQ SEQNO (SEQ.ADD1 SEQNO)) (fetch (SPPCON SPPSEQNO) of CON)) (* ; "Finished") NIL) (T SEQNO))) (\SPP.SENDPKT CON XIP]) (\SPP.DUPLICATE.REQUEST [LAMBDA (XIP) (* ; "Edited 26-May-91 11:58 by jds") (* ;;; "Return T if the incoming XIP is a connection request for a connection we've already established") (bind CONNECTION (SOURCEID _ (fetch (SPPXIP SOURCECONID) of XIP)) for INSTREAM in (fetch (FDEV DEVICEINFO) of \SPPDEVICE) thereis (AND (SETQ CONNECTION (fetch (SPPSTREAM SPP.CONNECTION) of INSTREAM)) (EQ SOURCEID (fetch (SPPCON SPPDESTID) of CONNECTION]) (\SPP.ESTABLISH [LAMBDA (INITCON XIP) (* ; "Edited 26-May-91 12:21 by jds") (* ;;; "The arrival of XIP causes this SPP connection to be established. Fix up state as appropriate") (PROG (CON INSTREAM NAME) [COND ((NOT (fetch (SPPCON SPPSERVERFLAG) of INITCON)) (SETQ CON INITCON) (* ; "For user connection, need to update socket info, as server may have switched from a well-known socket to a private one.") (\BLT (LOCF (fetch (SPPCON SPPDESTNSADDRESS0) of CON)) (LOCF (fetch (XIP XIPSOURCENET) of XIP)) \#WDS.NSADDRESS)) (T (* ;; "The connection was opened in server mode. Create a new spp connection, and establish it to the remote side, spawning a new process") (COND ((\SPP.DUPLICATE.REQUEST XIP) (* ;  "We've already spawned a server for this source") (RETURN))) (SETQ CON (\SPP.CREATE.CON)) (\BLT (LOCF (fetch (SPPCON SPPDESTNSADDRESS0) of CON)) (LOCF (fetch (XIP XIPSOURCENET) of XIP)) \#WDS.NSADDRESS) (* ;  "Fill in address of port that contacted us") [SETQ NAME (CONCAT (PROCESSPROP (fetch (SPPCON SPPPROCESS) of INITCON) 'NAME) '+ (OCTALSTRING (fetch (SPPCON SPPSOURCESKT#) of CON] (replace (SPPCON SPPATTENTIONFN) of CON with (fetch (SPPCON SPPATTENTIONFN ) of INITCON)) (* ;  "Copy some methods from the listener con") (replace (SPPCON SPPWHENCLOSEDFN) of CON with (fetch (SPPCON SPPWHENCLOSEDFN ) of INITCON)) (replace (SPPCON SPPERRORHANDLER) of CON with (fetch (SPPCON SPPERRORHANDLER ) of INITCON] (replace (SPPCON SPPDESTID) of CON with (fetch (SPPXIP SOURCECONID) of XIP)) (replace (SPPCON SPPSYSPKT) of CON with NIL) (* ;  "Flush any cached sys packet, now out of date") (replace (SPPCON SPPESTABLISHEDP) of CON with T) (replace (SPPCON SPPSTATE) of CON with \SPS.OPEN) (replace (SPPCON SPPDESTINATIONKNOWN) of CON with T) (if NAME then (* ; "Finally, get server going") (SETQ INSTREAM (\SPP.CREATE.STREAMS CON)) (\SPP.CREATE.WATCHER CON NAME) (WITH.MONITOR (fetch (SPPCON SPPLOCK) of CON) (* ;  "Have to reply to the sender so he knows our id & socket") (\SPP.PROBE CON)) (ADD.PROCESS (LIST (fetch (SPPCON SPPSERVERFN) of INITCON) INSTREAM (SPPOUTPUTSTREAM INSTREAM)) 'AFTEREXIT 'DELETE)) (NOTIFY.EVENT (fetch (SPPCON SPPINPUTEVENT) of CON]) (\SPPGETERROR [LAMBDA (CON TRIALPKT MOREMSG) (* ecc " 3-OCT-83 17:09") (if XIPTRACEFLG then (printout XIPTRACEFILE "Error packet received on Sequenced Packet Protocol connection." T) (PRINTPACKET TRIALPKT NIL XIPTRACEFILE) (if MOREMSG then (printout XIPTRACEFILE .TAB0 0 MOREMSG)) (TERPRI XIPTRACEFILE]) (\SPPSENDERROR [LAMBDA (CON EPKT MSG) (* bvm%: " 8-Mar-85 16:17") (* ; "Stub for now") (COND ((OR XIPTRACEFLG NSWIZARDFLG) (printout XIPTRACEFILE MSG T) (PRINTPACKET EPKT NIL XIPTRACEFILE) (TERPRI XIPTRACEFILE]) ) (* ; "Stream interface to Sequenced Packet Protocol.") (DEFINEQ (\INITSPP [LAMBDA NIL (* ; "Edited 26-May-91 11:58 by jds") (* ;; "Set up devices so that SPP streams can be used generically. The Bulk Data device enables a naive stream user to read or write a Bulk Data object.") [\DEFINEDEVICE NIL (SETQ \SPPDEVICE (\CREATE.SPP.DEVICE 'SPP (FUNCTION SPP.CLOSE] (replace (FDEV EVENTFN) of \SPPDEVICE with (FUNCTION \SPP.EVENTFN)) (\DEFINEDEVICE NIL (SETQ \SPP.BULKDATA.DEVICE (\CREATE.SPP.DEVICE 'COURIER.BULK.DATA (FUNCTION \BULK.DATA.CLOSE]) (\SPP.EVENTFN [LAMBDA (DEVICE EVENT) (* ; "Edited 26-May-91 11:58 by jds") (* ;; "Fixed to copy DEVICEINFO, since SPP.CLOSE DREMOVEs from it - TAL") (SELECTQ EVENT (BEFORELOGOUT (* ;  "Abort any open streams before we logout") (for STREAM in (APPEND (fetch (FDEV DEVICEINFO) of DEVICE)) do (SPP.CLOSE STREAM T))) NIL]) (\CREATE.SPP.DEVICE [LAMBDA (NAME CLOSEFN) (* bvm%: " 9-Jun-85 16:39") (create FDEV DEVICENAME _ NAME FDBINABLE _ T BUFFERED _ T EVENTFN _ (FUNCTION NILL) TRUNCATEFILE _ (FUNCTION NILL) CLOSEFILE _ CLOSEFN BIN _ (FUNCTION \BUFFERED.BIN) BOUT _ (FUNCTION \BUFFERED.BOUT) EOFP _ (FUNCTION SPP.EOFP) READP _ (FUNCTION SPP.READP) PEEKBIN _ (FUNCTION \BUFFERED.PEEKBIN) BACKFILEPTR _ (FUNCTION SPP.BACKFILEPTR) FORCEOUTPUT _ (FUNCTION SPP.FORCEOUTPUT) BLOCKIN _ (FUNCTION \BUFFERED.BINS) BLOCKOUT _ (FUNCTION \SPP.BOUTS) GETNEXTBUFFER _ (FUNCTION \SPP.GETNEXTBUFFER) GETFILEPTR _ (FUNCTION \SPP.GETFILEPTR) SETFILEPTR _ (FUNCTION \SPP.SETFILEPTR]) (SPP.OPEN [LAMBDA (HOST SOCKET PROBEP NAME PROPS) (* ; "Edited 26-May-91 12:04 by jds") (RESETLST [LET ((CON (\SPPCONNECTION HOST SOCKET NAME))) (OBTAIN.MONITORLOCK (fetch (SPPCON SPPLOCK) of CON) NIL T) [RESETSAVE (fetch (SPPCON SPPMYNSOCKET) of CON) '(AND RESETSTATE (CLOSENSOCKET OLDVALUE T] (* ;  "Close socket if we abort out of SPP.OPEN") (COND ([COND [(NULL HOST) (* ; "Server connection") (LET [(SERVERFN (LISTGET PROPS 'SERVER.FUNCTION] (COND (SERVERFN (* ;  "Handler for each of multiple possible connections to this server socket") (replace (SPPCON SPPSERVERFLAG) of CON with T) (replace (SPPCON SPPSERVERFN) of CON with SERVERFN) T) (T (* ;  "Wait for single user to connect, then return it") (until (fetch (SPPCON SPPESTABLISHEDP) of CON) do (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of CON) (fetch (SPPCON SPPINPUTEVENT) of CON))) T] ((OR (fetch (SPPCON SPPESTABLISHEDP) of CON) (NOT PROBEP)) (* ; "User connection") T) (T (\SPP.PROBE CON) (bind (TIMER _ (SETUPTIMER (IMAX (TIMES 3000 (OR (NSNET.DISTANCE (fetch (SPPCON SPPDESTNSNET ) of CON)) 4)) SPP.USER.TIMEOUT))) do (COND ((fetch (SPPCON SPPESTABLISHEDP) of CON) (RETURN T)) ((TIMEREXPIRED? TIMER) (* ; "We've waited long enough without response. Wait period based on hop count. Kill the watcher and get out of here.") (replace (SPPCON SPPTERMINATEDP) of CON with T) (RELEASE.MONITORLOCK (fetch (SPPCON SPPLOCK) of CON)) (* ;  "So that watcher will be able to run") (WAKE.PROCESS (fetch (SPPCON SPPPROCESS) of CON)) (BLOCK) (* ;  "Give watcher a chance to clean up.") (RETURN NIL)) ((fetch (SPPCON SPPTERMINATEDP) of CON) (* ;  "It died quickly? Probably no such socket") (RETURN NIL)) (T (MONITOR.AWAIT.EVENT (fetch (SPPCON SPPLOCK) of CON) (fetch (SPPCON SPPINPUTEVENT) of CON) TIMER T] (* ;; "CON is okay to use -- either established, or willing to be") (for TAIL on PROPS by (CDDR TAIL) do (SELECTQ (CAR TAIL) (CLOSEFN (replace (SPPCON SPPWHENCLOSEDFN) of CON with (CADR TAIL))) (ATTENTIONFN (replace (SPPCON SPPATTENTIONFN) of CON with (CADR TAIL))) (ERRORHANDLER (replace (SPPCON SPPERRORHANDLER) of CON with (CADR TAIL))) (EOM.ON.FORCEOUT (replace (SPPCON SPPEOMONFORCEOUT) of CON with (CADR TAIL))) (OTHERXIPHANDLER [COND ((FNTYP (CADR TAIL)) (replace (SPPCON SPPOTHERXIPHANDLER) of CON with (CADR TAIL]) NIL)) (\SPP.CREATE.STREAMS CON])]) (\SPP.CREATE.STREAM [LAMBDA (ACCESS) (* bvm%: "12-Oct-84 22:43") (create STREAM DEVICE _ \SPPDEVICE ACCESS _ ACCESS]) (SPP.DESTADDRESS [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:04 by jds") (PROG ([CON (COND ((type? SPPCON STREAM) STREAM) (T (GETSPPCON STREAM] (ADDRESS (create NSADDRESS))) (\BLT ADDRESS (LOCF (fetch (SPPCON SPPDESTNSADDRESS0) of CON)) \#WDS.NSADDRESS) (RETURN ADDRESS]) (SPPOUTPUTSTREAM [LAMBDA (SPPINPUTSTREAM) (* ; "Edited 26-May-91 12:04 by jds") (LET ((CON (GETSPPCON SPPINPUTSTREAM))) (OR (AND CON (fetch (SPPCON SPPOUTPUTSTREAM) of CON)) (\SPP.STREAM.LOST SPPINPUTSTREAM]) (SPP.OPENP [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:04 by jds") (PROG (CON) (RETURN (AND STREAM (SPPSTREAMP STREAM) (SETQ CON (GETSPPCON STREAM)) (NOT (fetch (SPPCON SPPTERMINATEDP) of CON]) (\STREAM.FROM.PACKET [LAMBDA (EPKT) (* ; "Edited 26-May-91 12:22 by jds") (* ;; "Return a stream which will read out of the contents of a single Packet Exchange packet.") (CHECK (EQP (fetch (XIP XIPTYPE) of EPKT) \XIPT.EXCHANGE)) (\MAKEBASEBYTESTREAM (fetch PACKETEXCHANGEBODY of EPKT) 0 (IDIFFERENCE (fetch (XIP XIPLENGTH) of EPKT) (CONSTANT (IPLUS \XIPOVLEN 6))) 'INPUT]) (SPP.FORCEOUTPUT [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:22 by jds") (PROG ((CON (GETSPPCON STREAM)) EPKT) (COND ((SETQ EPKT (fetch (SPPCON SPPOUTPKT) of CON)) [COND ((EQ STREAM (fetch (SPPCON SPPINPUTSTREAM) of CON)) (SETQ STREAM (fetch (SPPCON SPPOUTPUTSTREAM) of CON] (UNINTERRUPTABLY (add (fetch (XIP XIPLENGTH) of EPKT) (fetch (STREAM COFFSET) of STREAM)) (\SPPINCFILEPTR STREAM (fetch (STREAM COFFSET) of STREAM)) (replace (SPPCON SPPOUTPKT) of CON with NIL) (replace (STREAM CBUFMAXSIZE) of STREAM with 0) (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFPTR) of STREAM with NIL)) (COND ((fetch (SPPCON SPPEOMONFORCEOUT) of CON) (replace (SPPXIP ENDOFMESSAGE) of EPKT with T))) (COND ((fetch (SPPCON SPPOUTPUTABORTEDP) of CON) (replace (SPPCON SPPOUTPUTABORTEDP) of CON with NIL) (APPLY* (fetch (SPPCON SPPOUTPUTABORTEDFN) of CON) STREAM)) ((NOT (\SENDSPP CON EPKT)) (\SPP.STREAM.LOST STREAM]) (SPP.FLUSH.TO.EOF [LAMBDA (INSTREAM) (* ; "Edited 26-May-91 12:19 by jds") (while (NOT (\SPP.PREPARE.INPUT INSTREAM)) do (replace (STREAM COFFSET) of INSTREAM with (fetch (STREAM CBUFSIZE ) of INSTREAM)) finally (RETURN (SELECTC (fetch (SPPSTREAM SPPEOFBITS) of INSTREAM) (\SPPFLAG.EOM (replace (SPPSTREAM SPPEOFP) of INSTREAM with NIL) 'EOM) (\SPPFLAG.ATTENTION (SPP.CLEARATTENTION INSTREAM) (BIN INSTREAM)) (\SPPFLAG.END 'EOF) NIL]) (SPP.SENDEOM [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:04 by jds") (* ;; "Send the End of Message indication.") (PROG ((CON (GETSPPCON STREAM)) EPKT) (OR (WRITEABLE STREAM) (SETQ STREAM (fetch (SPPCON SPPOUTPUTSTREAM) of CON)) (\SPP.STREAM.LOST STREAM)) (replace (SPPXIP ENDOFMESSAGE) of (OR (fetch (SPPCON SPPOUTPKT) of CON) (\SPP.PREPARE.OUTPUT STREAM CON) (\SPP.STREAM.LOST STREAM)) with T) (SPP.FORCEOUTPUT STREAM]) (SPP.CLEAREOM [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 26-May-91 12:19 by jds") (PROG ((CON (GETSPPCON STREAM)) FLG) (RETURN (COND ((AND (\SPP.PREPARE.INPUT STREAM) (EQ (fetch (SPPSTREAM SPPEOFBITS) of STREAM) \SPPFLAG.EOM)) (replace (SPPSTREAM SPPEOFP) of STREAM with NIL) T) ((NOT NOERRORFLG) (ERROR "SPP.CLEAREOM - not at end of message" STREAM]) (SPP.SENDATTENTION [LAMBDA (STREAM ATTENTIONBYTE CC) (* ; "Edited 26-May-91 12:22 by jds") (* ;; "Send an Attention packet with the specified data byte and control bits. Can't use normal stream mechanism because stream may be read only.") (PROG ((CON (GETSPPCON STREAM)) EPKT) [SETQ EPKT (\FILLINSPP CON (LOGOR \SPPHEAD.CC.ATTENTION (OR CC 0] (replace (SPPXIP FIRSTSPPDATABYTE) of EPKT with ATTENTIONBYTE) (add (fetch (XIP XIPLENGTH) of EPKT) 1) (RETURN (\SENDSPP CON EPKT T]) (SPP.CLEARATTENTION [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 26-May-91 12:20 by jds") (PROG ((CON (GETSPPCON STREAM)) FLG) (RETURN (COND ((AND (\SPP.PREPARE.INPUT STREAM) (EQ (fetch (SPPSTREAM SPPEOFBITS) of STREAM) \SPPFLAG.ATTENTION)) (UNINTERRUPTABLY (replace (SPPSTREAM SPPEOFP) of STREAM with NIL) (replace (STREAM CBUFSIZE) of STREAM with 1)) T) ((NOT NOERRORFLG) (ERROR "SPP.CLEARATTENTION - not at attention packet" STREAM]) (SPP.CLOSE [LAMBDA (STREAM ABORT?) (* ; "Edited 26-May-91 12:10 by jds") (* ;; "Close an SPP stream. Don't close it if there's still an open Bulk Data stream, unless the user is aborting the connection.") (PROG (CON SUBSTREAM) (RETURN (COND ((OR (NULL STREAM) (NULL (SETQ CON (GETSPPCON STREAM))) (fetch (SPPCON SPPTERMINATEDP) of CON)) NIL) (T [COND ((AND (SETQ SUBSTREAM (fetch (SPPCON SPPSUBSTREAM) of CON)) (OPENED SUBSTREAM)) (* ;  "This connection still has an active bulk data stream. Must want to abort it") (\BULK.DATA.CLOSE SUBSTREAM (SETQ ABORT? T] (COND ((NOT ABORT?) (SPP.FORCEOUTPUT STREAM))) (\TERMINATESPP CON]) (\SPP.CLOSE.IF.ERROR [LAMBDA (STREAM) (* bvm%: "16-NOV-83 14:57") (COND (RESETSTATE (SPP.CLOSE STREAM T]) (\SPP.RESETCLOSE [LAMBDA (STREAM) (* bvm%: "16-NOV-83 14:59") (* ;;; "For use in RESETSAVE -- sets the abort arg to SPP.CLOSE according to RESETSTATE") (SPP.CLOSE STREAM RESETSTATE]) (SPP.BACKFILEPTR [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:01 by jds") (if (NEQ (fetch (STREAM COFFSET) of STREAM) 0) then (add (fetch (STREAM COFFSET) of STREAM) -1]) (\SPP.GETFILEPTR [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:20 by jds") (IPLUS (fetch (SPPSTREAM SPPFILEPTR) of STREAM) (fetch (STREAM COFFSET) of STREAM]) (\SPP.SETFILEPTR [LAMBDA (STREAM INDX) (* ; "Edited 26-May-91 12:01 by jds") (PROG ((CON (GETSPPCON STREAM)) SKIPBYTES) (RETURN (COND ((AND (EQ (fetch (STREAM ACCESSBITS) of STREAM) ReadBit) (IGEQ (SETQ SKIPBYTES (IDIFFERENCE INDX (\SPP.GETFILEPTR STREAM))) 0)) (* ;  "Can only move file pointer on input, and then only forward") (\SPP.SKIPBYTES STREAM SKIPBYTES)) (T (\IS.NOT.RANDACCESSP STREAM]) (\SPP.SKIPBYTES [LAMBDA (STREAM NBYTES) (* ; "Edited 26-May-91 12:01 by jds") (PROG (BYTESLEFT CONDITION) LP [COND ((SETQ CONDITION (\SPP.PREPARE.INPUT STREAM)) (COND ((NEQ (SETQ CONDITION (SPP.STREAM.ERROR STREAM CONDITION)) T) (RETURN CONDITION] (COND ([IGREATERP NBYTES (SETQ BYTESLEFT (IDIFFERENCE (fetch (STREAM CBUFSIZE) of STREAM) (fetch (STREAM COFFSET) of STREAM] (SETQ NBYTES (IDIFFERENCE NBYTES BYTESLEFT)) (replace (STREAM COFFSET) of STREAM with (fetch (STREAM CBUFSIZE) of STREAM)) (GO LP)) (T (add (fetch (STREAM COFFSET) of STREAM) NBYTES]) (\SPP.BOUTS [LAMBDA (STREAM BASE OFF NBYTES) (* ; "Edited 26-May-91 12:10 by jds") (PROG ((CON (GETSPPCON STREAM))) (RETURN (\BUFFERED.BOUTS (OR (COND ((NULL CON) NIL) ((EQ STREAM (fetch (SPPCON SPPINPUTSTREAM) of CON)) (fetch (SPPCON SPPOUTPUTSTREAM) of CON)) (T STREAM)) (RETURN (\SPP.STREAM.LOST STREAM))) BASE OFF NBYTES]) (\SPP.OTHER.BOUT [LAMBDA (STREAM BYTE) (* bvm%: "31-Jan-86 16:49") (* ;; "BOUT function for the input side of an SPP connection, in case someone doesn't want to bother with SPPOUTPUTSTREAM") (\BOUT (OR (SPPOUTPUTSTREAM STREAM) (\SPP.STREAM.LOST STREAM)) BYTE]) (\SPP.GETNEXTBUFFER [LAMBDA (STREAM WHATFOR NOERRORFLG) (* ; "Edited 26-May-91 12:10 by jds") (* ;;; "Generic buffer refiller for SPP streams") (PROG (CON ERRCODE) (RETURN (SELECTQ WHATFOR (READ (COND ((NULL (SETQ ERRCODE (\SPP.PREPARE.INPUT STREAM))) T) ((OR (NEQ ERRCODE 'EOM) (NULL NOERRORFLG)) (SPP.STREAM.ERROR STREAM ERRCODE)))) (WRITE (SETQ CON (GETSPPCON STREAM)) (COND ((\SPP.PREPARE.OUTPUT (COND ((EQ STREAM (fetch (SPPCON SPPINPUTSTREAM ) of CON)) (ffetch (SPPCON SPPOUTPUTSTREAM) of CON)) (T STREAM)) CON) T) (T (* ;  "If that returned, then client must want no error") (RETFROM (OR (STKPOS '\BUFFERED.BOUT) (STKPOS '\BUFFERED.BOUTS) (RETURN (\SPP.STREAM.LOST STREAM))) NIL T)))) (SHOULDNT]) (\SPP.STREAM.LOST [LAMBDA (STREAM) (* bvm%: "31-Jan-86 16:47") (SPP.STREAM.ERROR STREAM 'STREAM.LOST]) (\SPP.DEFAULT.ERRORHANDLER [LAMBDA (STREAM CONDITION) (* ; "Edited 26-May-91 12:01 by jds") (SELECTQ CONDITION (STREAM.LOST (ERROR "Connection lost" (OR (fetch (STREAM FULLFILENAME) of STREAM) STREAM))) (ATTENTION [LET ((CON (GETSPPCON STREAM))) (COND ((AND CON (EQ (fetch (SPPCON SPPINPUTDSTYPE) of CON) \SPPDSTYPE.BULKDATA)) (* ; "Bulk data abort") (\COURIER.OUTPUT.ABORTED STREAM)) (T (\EOF.ACTION STREAM]) (\EOF.ACTION STREAM]) (\SPP.PREPARE.INPUT [LAMBDA (STREAM TIMEOUT) (* ; "Edited 26-May-91 12:22 by jds") (* ;;; "Gets the next input packet for the stream interface. If OK, returns NIL, otherwise returns the error condition as one of the canonical error codes, or one of the SPP-specific error codes") (PROG ((CON (GETSPPCON STREAM)) EPKT CONDITION OLD.DSTYPE NEW.DSTYPE SPPDSTYPECHANGEFN) (SETQ EPKT (fetch (SPPCON SPPINPKT) of CON)) CHECK-CURRENT (COND (EPKT (* ;  "Look at previous packet to make sure we're not trying to read past the end of the stream.") (COND ((ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM)) (* ;  "Not finished with this packet yet") (RETURN NIL))) [COND ((EQ (fetch (SPPSTREAM SPPEOFBITS) of STREAM) \SPPFLAG.ATTENTION) (* ;  "Waiting to read attention packet. Has to be cleared first, so indicate eof now") (RETURN 'ATTENTION] (* ;; "Throw away the previous packet in preparation for the next one.") (UNINTERRUPTABLY (\SPPINCFILEPTR STREAM (fetch (STREAM CBUFSIZE) of STREAM)) (replace (STREAM COFFSET) of STREAM with (replace (STREAM CBUFSIZE) of STREAM with 0)) (replace (SPPCON SPPINPKT) of CON with NIL) (replace (STREAM CBUFPTR) of STREAM with NIL) [COND ((fetch (SPPXIP EOMP) of EPKT) (replace (SPPSTREAM SPPEOFP) of STREAM with 'EOM]) (RELEASE.XIP EPKT))) (COND ((SETQ CONDITION (fetch (SPPSTREAM SPPEOFP) of STREAM)) (RETURN CONDITION))) AGAIN (SETQ EPKT (\GETSPP CON TIMEOUT)) [COND ((NULL EPKT) (RETURN (COND (TIMEOUT 'BIN.TIMEOUT) (T 'STREAM.LOST] (SELECTC (SETQ NEW.DSTYPE (fetch (SPPXIP DSTYPE) of EPKT)) ((LIST \SPPDSTYPE.END \SPPDSTYPE.ENDREPLY) (replace (SPPSTREAM SPPEOFP) of STREAM with 'END) (RETURN 'END)) (\SPPDSTYPE.BULKDATA (COND ((NULL (fetch (SPPSTREAM BULK.DATA.CONTINUATION) of STREAM)) (* ;; "We got a Bulk Data packet but not on a Bulk Data stream. It's probably a straggler after we aborted a transfer, so ignore it.") (GO AGAIN)))) NIL) (UNINTERRUPTABLY (replace (STREAM CBUFPTR) of STREAM with (fetch (SPPXIP SPPCONTENTS) of EPKT)) (replace (STREAM COFFSET) of STREAM with 0) [replace (STREAM CBUFSIZE) of STREAM with (COND ((fetch (SPPXIP ATTENTION) of EPKT) (* ; "Not readable yet") (replace (SPPSTREAM SPPEOFP) of STREAM with 'ATTENTION) 0) (T (IDIFFERENCE (fetch (XIP XIPLENGTH) of EPKT) (CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH] (replace (SPPCON SPPINPKT) of CON with EPKT)) (SETQ OLD.DSTYPE (fetch (SPPCON SPPINPUTDSTYPE) of CON)) (replace (SPPCON SPPINPUTDSTYPE) of CON with NEW.DSTYPE) (COND ((AND (NEQ OLD.DSTYPE NEW.DSTYPE) (SETQ SPPDSTYPECHANGEFN (fetch (SPPCON SPPDSTYPECHANGEFN) of CON))) (CL:FUNCALL SPPDSTYPECHANGEFN STREAM OLD.DSTYPE NEW.DSTYPE))) (GO CHECK-CURRENT) (* ;  "Finally, loop back to top in case new packet is empty or otherwise unusual") ]) (\SPP.PREPARE.OUTPUT [LAMBDA (STREAM CON) (* ; "Edited 26-May-91 12:10 by jds") (* ;; "Fill in a new packet for the output side of the stream interface.") (SPP.FORCEOUTPUT STREAM) (if (NOT (fetch (SPPCON SPPTERMINATEDP) of CON)) then (PROG ((EPKT (\FILLINSPP CON))) (replace (SPPCON SPPOUTPKT) of CON with EPKT) (replace (STREAM CBUFPTR) of STREAM with (fetch (SPPXIP SPPCONTENTS ) of EPKT)) (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFMAXSIZE) of STREAM with (IDIFFERENCE \MAX.XIPDATALENGTH \SPPHEAD.LENGTH )) (RETURN EPKT]) (SPP.DSTYPE [LAMBDA (STREAM DSTYPE NOBLOCK) (* ; "Edited 26-May-91 12:10 by jds") (* ;; "Get or set datastream type of current packet.") (PROG ((CON (GETSPPCON STREAM)) EPKT CONDITION) (RETURN (COND (DSTYPE (COND ((SETQ EPKT (fetch (SPPCON SPPOUTPKT) of CON)) (replace (SPPXIP DSTYPE) of EPKT with DSTYPE))) (replace (SPPCON SPPDSTYPE) of CON with DSTYPE)) (T (COND ((NOT (READABLE STREAM)) (fetch (SPPCON SPPDSTYPE) of CON)) (NOBLOCK (fetch (SPPCON SPPINPUTDSTYPE) of CON)) (T (fetch (SPPXIP DSTYPE) of (OR (fetch (SPPCON SPPINPKT) of CON) (COND ((AND (SETQ CONDITION (\SPP.PREPARE.INPUT STREAM)) (NEQ (SETQ CONDITION (SPP.STREAM.ERROR STREAM CONDITION)) T)) (RETURN CONDITION)) (T (fetch (SPPCON SPPINPKT) of CON]) (SPP.READP [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:01 by jds") (COND ((NOT (READABLE STREAM)) (LISPERROR "FILE NOT OPEN" (FULLNAME STREAM))) ((ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM)) T) (T (NULL (\SPP.PREPARE.INPUT STREAM 0]) (SPP.EOFP [LAMBDA (STREAM) (* ; "Edited 26-May-91 12:01 by jds") (COND ((NOT (READABLE STREAM)) T) ((ILESSP (fetch (STREAM COFFSET) of STREAM) (fetch (STREAM CBUFSIZE) of STREAM)) NIL) (T (LET ((CONDITION (\SPP.PREPARE.INPUT STREAM))) (SELECTQ CONDITION (NIL (* ; "There is more") NIL) (END T) (STREAM.LOST (* ;  "Harumph, can't say EOFP because there would have been more") NIL) (PROGN (* ; "Special kinds of EOF") CONDITION]) ) (DEFINEQ (SPPSTREAMP [LAMBDA (STREAM) (* ; "Edited 13-Sep-90 16:18 by jds") (* ;; "Returns non-NIL if STREAM is an SPP stream.") (type? SPPCON (GETSPPCON STREAM]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\INITSPP) ) (* ; "Debugging") (ADDTOVAR XIPPRINTMACROS (5 . PRINTSPP)) (DEFINEQ (PPSPP [LAMBDA (CON FILE DETAILS) (* ; "Edited 26-May-91 12:11 by jds") (PROG (STR N) (SETQ FILE (\GETSTREAM FILE 'OUTPUT)) (printout FILE "Local: " (fetch (SPPCON SPPSOURCENSADDRESS) of CON) ", id = " (fetch (SPPCON SPPSOURCEID) of CON) T "Remote: " (fetch (SPPCON SPPDESTNSADDRESS) of CON) ", id = " (fetch (SPPCON SPPDESTID) of CON) T) [COND ((NOT (fetch (SPPCON SPPESTABLISHEDP) of CON)) (printout FILE " [not established]")) (T (printout FILE "DS Type = " (SELECTC (fetch (SPPCON SPPDSTYPE) of CON) (\SPPDSTYPE.COURIER "courier") (\SPPDSTYPE.BULKDATA "bulkdata") (fetch (SPPCON SPPDSTYPE) of CON] (COND ((fetch (SPPCON SPPTERMINATEDP) of CON) (printout FILE " [terminated]"))) (COND ((fetch (SPPCON SPPACKREQUESTED) of CON) (printout FILE T "Ack requested: " .F3.1 (FQUOTIENT (CLOCKDIFFERENCE (fetch (SPPCON SPPACKREQTIME) of CON)) 1000) " secs ago"))) (printout FILE T "Round trip: " .F4.1 (FQUOTIENT (fetch (SPPCON SPPROUNDTRIPTIME) of CON) 1000) " secs") (printout FILE T "Last input activity: " .F4.1 (FQUOTIENT (CLOCKDIFFERENCE (fetch (SPPCON SPPACTIVITYTIMER ) of CON)) 1000) " secs ago" T) (printout FILE T "Input:" T " Seq# " (fetch (SPPCON SPPACKNO) of CON) T " Allocation: " [\LOLOC (IDIFFERENCE (fetch (SPPCON SPPACCEPTNO) of CON) (SUB1 (fetch (SPPCON SPPACKNO) of CON] T) (PPSPPSTREAM (fetch (SPPCON SPPINPUTSTREAM) of CON) FILE) (COND ((NEQ [SETQ N (IPLUS (COND ((fetch (SPPCON SPPINPKT) of CON) 1) (T 0)) (\QUEUELENGTH (fetch (SPPCON SPPINPUTQ) of CON] 0) (printout FILE " Packets in queue: " N T))) (printout FILE T "Output:" T " Seq# " (fetch (SPPCON SPPSEQNO) of CON)) [COND ((EQ (fetch (SPPCON SPPSEQNO) of CON) (fetch (SPPCON SPPACKEDSEQNO) of CON)) (printout FILE ", all acked")) (T (printout FILE ", acked# " (fetch (SPPCON SPPACKEDSEQNO) of CON] (printout FILE T " Allocation: " [\LOLOC (IDIFFERENCE (fetch (SPPCON SPPOUTPUTALLOCNO) of CON) (SUB1 (fetch (SPPCON SPPSEQNO) of CON] T) (PPSPPSTREAM (fetch (SPPCON SPPOUTPUTSTREAM) of CON) FILE) (COND (DETAILS (printout FILE " Awaiting ack: " %# [for (I _ (fetch (SPPCON SPPACKEDSEQNO) of CON)) by (SEQ.ADD1 I) bind (NEXT _ (fetch (SPPCON SPPSEQNO) of CON)) while (SEQ.GREATERP NEXT I) do (PRINTSPP (ELT (fetch (SPPCON SPPRETRANSMITQ) of CON) (RETRANSMITINDEX I] T))) (COND ((SETQ STR (fetch (SPPCON SPPSUBSTREAM) of CON)) (printout FILE T "Bulk data stream (" (fetch (STREAM ACCESS) of STR) "):" T) (PPSPPSTREAM STR FILE]) (\SPP.INFO.HOOK [LAMBDA (PROC BUTTON) (* bvm%: "25-Sep-84 13:07") (DECLARE (USEDFREE SPPCON)) (* ;; "This is evaluated underneath \SPPWATCHER") (if (EQ BUTTON 'MIDDLE) then (* ; "all the details") (INSPECT SPPCON) else (PROG [(WINDOW (PROCESSPROP PROC 'WINDOW] (COND ((NULL WINDOW) (SETQ WINDOW (CREATEW (GETBOXREGION 256 240) "SPP Connection Status")) (DSPFONT (FONTCREATE 'GACHA 8) WINDOW) (PROCESSPROP PROC 'WINDOW WINDOW)) (T (CLEARW WINDOW))) (PPSPP SPPCON WINDOW]) (PPSPPSTREAM [LAMBDA (STREAM FILE) (* ; "Edited 26-May-91 12:21 by jds") (if STREAM then (printout FILE " File pointer: " (\SPP.GETFILEPTR STREAM)) (if (fetch (SPPSTREAM SPPEOFP) of STREAM) then (printout FILE " [eof]")) (TERPRI FILE]) (\SPP.CHECK.INPUT.QUEUE [LAMBDA (CON) (* ; "Edited 26-May-91 12:11 by jds") (PROG ((ACKNO (fetch (SPPCON SPPACKNO) of CON)) (INQ (fetch (SPPCON SPPINPUTQ) of CON)) N1 N2 CURRENT NEXT) (* ;  "Check consistency of input queue.") (SETQ CURRENT (fetch SYSQUEUEHEAD of INQ)) L (COND ((NULL CURRENT) (RETURN T))) (SETQ N1 (fetch (SPPXIP SEQNO) of CURRENT)) (COND ((EQ N1 ACKNO) (SHOULDNT "The input queue contains a packet that should have been acknowledged already.") (RETURN NIL))) (COND ((NULL (SETQ NEXT (fetch QLINK of CURRENT))) (RETURN T))) (SETQ N2 (fetch (SPPXIP SEQNO) of NEXT)) (COND ((EQ N1 N2) (SHOULDNT "The input queue has duplicates.") (RETURN NIL))) (COND ((SEQ.GREATERP N1 N2) (SHOULDNT "The input queue is out of order.") (RETURN NIL))) (SETQ CURRENT NEXT) (GO L]) (PRINTSPP [LAMBDA (EPKT FILE) (* ; "Edited 26-May-91 12:23 by jds") (PROG ((BASE (fetch (XIP XIPCONTENTS) of EPKT)) SYSTEMP DS LENGTH) (printout FILE (fetch (SPPHEAD SOURCECONID) of BASE) "/" (fetch (SPPHEAD DESTCONID) of BASE)) [COND ((NEQ (fetch (SPPHEAD CC) of BASE) 0) (PROG ((SEPR " [") (COMMA ", ")) (COND ((fetch (SPPHEAD SYSTEMPACKET) of BASE) (printout FILE SEPR "sys") (SETQ SEPR COMMA) (SETQ SYSTEMP T))) (COND ((fetch (SPPHEAD SENDACK) of BASE) (printout FILE SEPR "ack") (SETQ SEPR COMMA))) (COND ((fetch (SPPHEAD ATTENTION) of BASE) (printout FILE SEPR "attn") (SETQ SEPR COMMA))) (COND ((fetch (SPPHEAD ENDOFMESSAGE) of BASE) (printout FILE SEPR "eom") (SETQ SEPR COMMA))) (COND ((NEQ SEPR COMMA) (printout FILE SEPR "??"))) (printout FILE "]"] (printout FILE %, (SELECTC (SETQ DS (fetch (SPPHEAD DSTYPE) of BASE)) (\SPPDSTYPE.COURIER "courier") (\SPPDSTYPE.BULKDATA "bulkdata") (\SPPDSTYPE.END "end") (\SPPDSTYPE.ENDREPLY "end-reply") DS)) (printout FILE " seq " (fetch (SPPHEAD SEQNO) of BASE) "; ack/alloc = " (fetch (SPPHEAD ACKNO) of BASE) "/" (fetch (SPPHEAD ALLOCNO) of BASE)) [COND ([NEQ 0 (SETQ LENGTH (IDIFFERENCE (fetch (XIP XIPLENGTH) of EPKT) (CONSTANT (IPLUS \XIPOVLEN \SPPHEAD.LENGTH] (printout FILE "; " LENGTH " bytes") (COND (PRINTSPPDATAFLG (printout FILE T "Data: ") (PRINTPACKETDATA (fetch (SPPHEAD SPPCONTENTS) of BASE) 0 '(CHARS) LENGTH FILE] (printout FILE T T]) ) (RPAQ? PRINTSPPDATAFLG ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PRINTSPPDATAFLG) ) (PUTPROPS SPP COPYRIGHT ("Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (8755 29124 (\SPPCONNECTION 8765 . 9948) (\SPP.CREATE.CON 9950 . 10897) ( \SPP.CREATE.STREAMS 10899 . 11785) (\SPP.CREATE.WATCHER 11787 . 12599) (\SPP.SENDPKT 12601 . 16196) ( \FILLINSPP 16198 . 16996) (\SPP.SYSPKT 16998 . 17948) (\GETSPP 17950 . 20259) (\SENDSPP 20261 . 23729) (\SPP.SEND.ENDREPLY 23731 . 24159) (\TERMINATESPP 24161 . 26417) (\SPP.CLEANUP 26419 . 29122)) (29125 64179 (\SPPWATCHER 29135 . 36416) (\SPP.HANDLE.INPUT 36418 . 45241) (\SPP.HANDLE.DATA 45243 . 50004) (\SPP.HANDLE.ATTN 50006 . 51487) (\SPP.RELEASE.ACKED.PACKETS 51489 . 53022) (\SPP.NOT.RESPONDING 53024 . 55738) (\SPP.PROBE 55740 . 56009) (\SPP.RETRANSMIT.NEXT 56011 . 58131) (\SPP.DUPLICATE.REQUEST 58133 . 58725) (\SPP.ESTABLISH 58727 . 63362) (\SPPGETERROR 63364 . 63818) (\SPPSENDERROR 63820 . 64177)) (64243 96114 (\INITSPP 64253 . 64888) (\SPP.EVENTFN 64890 . 65460) (\CREATE.SPP.DEVICE 65462 . 66356) (SPP.OPEN 66358 . 71966) (\SPP.CREATE.STREAM 71968 . 72167) (SPP.DESTADDRESS 72169 . 72616) (SPPOUTPUTSTREAM 72618 . 72908) (SPP.OPENP 72910 . 73226) (\STREAM.FROM.PACKET 73228 . 73764) ( SPP.FORCEOUTPUT 73766 . 75303) (SPP.FLUSH.TO.EOF 75305 . 76449) (SPP.SENDEOM 76451 . 77249) ( SPP.CLEAREOM 77251 . 77856) (SPP.SENDATTENTION 77858 . 78484) (SPP.CLEARATTENTION 78486 . 79238) ( SPP.CLOSE 79240 . 80306) (\SPP.CLOSE.IF.ERROR 80308 . 80480) (\SPP.RESETCLOSE 80482 . 80730) ( SPP.BACKFILEPTR 80732 . 81033) (\SPP.GETFILEPTR 81035 . 81273) (\SPP.SETFILEPTR 81275 . 81986) ( \SPP.SKIPBYTES 81988 . 83027) (\SPP.BOUTS 83029 . 83790) (\SPP.OTHER.BOUT 83792 . 84147) ( \SPP.GETNEXTBUFFER 84149 . 86087) (\SPP.STREAM.LOST 86089 . 86247) (\SPP.DEFAULT.ERRORHANDLER 86249 . 87028) (\SPP.PREPARE.INPUT 87030 . 91881) (\SPP.PREPARE.OUTPUT 91883 . 93307) (SPP.DSTYPE 93309 . 94829) (SPP.READP 94831 . 95226) (SPP.EOFP 95228 . 96112)) (96115 96350 (SPPSTREAMP 96125 . 96348)) ( 96474 107034 (PPSPP 96484 . 101673) (\SPP.INFO.HOOK 101675 . 102548) (PPSPPSTREAM 102550 . 102919) ( \SPP.CHECK.INPUT.QUEUE 102921 . 104221) (PRINTSPP 104223 . 107032))))) STOP \ No newline at end of file diff --git a/sources/SPPDECLS b/sources/SPPDECLS new file mode 100644 index 00000000..41ea0f1c --- /dev/null +++ b/sources/SPPDECLS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 11:21:28" {DSK}lde>lispcore>sources>SPPDECLS.;4 21893 changes to%: (RECORDS SPPCON SPPHEAD SPPXIP SPPSTREAM) previous date%: " 5-Jan-93 02:32:12" {DSK}lde>lispcore>sources>SPPDECLS.;3) (* ; " Copyright (c) 1986, 1987, 1990, 1992, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT SPPDECLSCOMS) (RPAQQ SPPDECLSCOMS ((FILES (SOURCE) LLNSDECLS) (RECORDS SPPCON SPPHEAD SPPXIP) (CONSTANTS * SPPTYPES) (CONSTANTS * SPPSTATES) (CONSTANTS (\SPPHEAD.LENGTH 12) (\#WDS.SPPINFO (SUB1 (FOLDLO (IPLUS \XIPOVLEN \SPPHEAD.LENGTH) BYTESPERWORD))) (\SPP.INITIAL.ALLOCATION 5) (\SPP.INITIAL.ROUNDTRIP 1000) (\SPP.RETRANSMITQ.SIZE 8)) (RECORDS SPPSTREAM) (MACROS GETSPPCON \FETCH.NSADDRESS \SPPINCFILEPTR GETWORD PUTWORD GETLONG PUTLONG SPP.STREAM.ERROR) (CONSTANTS * SPPEOFFLAGS) (GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE))) (FILESLOAD (SOURCE) LLNSDECLS) (DECLARE%: EVAL@COMPILE (DATATYPE SPPCON ( (* ;; "First part of this record looks like the header of an SPP XIP filled in with defaults for this connection") (SPPXIPLENGTH WORD) (NIL BYTE) (* ; "Transport control") (SPPXIPTYPE BYTE) (* ; "Constant \XIPT.SPP") (SPPDESTNSADDRESS0 5 WORD) (* ;  "Destination address, maybe not filled in until connection established") (SPPDESTSKT# WORD) (SPPSOURCENSADDRESS0 5 WORD) (* ; "My address and socket number") (SPPSOURCESKT# WORD) (NIL BYTE) (* ; "Connection Control") (SPPDSTYPE BYTE) (* ;  "Current datastream type from our outgoing side.") (SPPSOURCEID WORD) (* ;  "Connection identification number for this side.") (SPPDESTID WORD) (* ;  "Connection identification number for the other side.") (SPPSEQNO WORD) (* ; "Current sequence number -- next packet to go out will take this and, if not a system packet, then increment it.") (SPPACKNO WORD) (* ;  "We've seen all seqno's up to but not including this one.") (SPPACCEPTNO WORD) (* ;  "The Allocation number we've sent -- I'll accept his sequence numbers up to and including this.") (* ;;  "Remainder of record contains other interesting state not a part of the packet") (SPPESTABLISHEDP FLAG) (* ;  "True when connection is established.") (SPPDESTINATIONKNOWN FLAG) (* ;  "True if we initiate the connection, or once a passive connection is established") (SPPTERMINATEDP FLAG) (* ;  "True when \TERMINATESPP wants this one to go away.") (SPPOUTPUTABORTEDP FLAG) (* ; "Attempt to send output instead invokes the SPPOUTPUTABORTEDFN -- typically used to handle Bulk Data abort") (SPPOUTPUTABORTEDFN POINTER) (SPPACKPENDING FLAG) (* ;  "True if we have been requested to send an Ack") (SPPEOMONFORCEOUT FLAG) (* ;  "True if we want each FORCEOUTPUT to cause an EOM on the stream") (SPPSERVERFLAG FLAG) (* ;  "True if connection was opened as a server") (SPPINPUTBLOCKED FLAG) (* ; "True if we have received packets filling our allocation, so that further input is blocked until we consume some") (SPPINPUTQ POINTER) (* ;  "Packets that have arrived wait in this queue. The packets are in order but some may be missing.") (SPPRETRANSMITQ POINTER) (* ;  "Packets which have been to SENDXIP but have not yet been acknowledged.") (SPPRETRANSMITTING POINTER) (* ; "Queue of packets that we get back from the driver after transmission. These have to be merged into the retransmit queue.") (SPPLOCK POINTER) (* ; "Monitor lock for connection.") (SPPMYNSOCKET POINTER) (* ;  "NS socket for sending and receiving XIPs.") (SPPACKEDSEQNO WORD) (* ; "The most recent Acknowledge number we have received; i.e. the SEQNO he expects to receive next.") (SPPOUTPUTALLOCNO WORD) (* ;  "The most recent Allocation number we've received.") (SPPRETRANSMITTIMER POINTER) (* ;  "Time at which the next Acknowledgement request or retransmission should occur.") (SPPACKREQUESTED POINTER) (* ;  "Will be set to a seqno when an ACK request has been sent but not acknowledged.") (SPPACKREQTIME POINTER) (* ; "Whenever an ACK request is sent, this is set to the current time. When a response arrives, the round trip time is updated.") (SPPACKREQTIMEOUT POINTER) (* ;  "Time at which an ACK request should be considered hopeless.") (SPPROUNDTRIPTIME POINTER) (* ;  "Estimate of (twice) the round trip delay on this connection.") (SPPACTIVITYTIMER POINTER) (* ;  "If non-NIL, the time for the next probe to see if the other end is still there.") (SPPATTENTIONFN POINTER) (* ;  "Fn to call when attention packet is received") (SPPINPKT POINTER) (* ;  "Packet currently being read from, for BIN.") (SPPOUTPKT POINTER) (* ;  "Packet currently being written to, for BOUT.") (SPPSYSPKT POINTER) (* ;  "Cached System packet for probing and answering Acknowledgement requests.") (SPPINPUTSTREAM POINTER) (* ;  "Stream interface for this connection.") (SPPSUBSTREAM POINTER) (* ;  "Bulk data substream for connection.") (SPPPROCESS POINTER) (* ;  "Process managing this connection.") (SPPALLOCATIONEVENT POINTER) (* ;  "Event which occurs when the allocation increases.") (SPPINPUTEVENT POINTER) (* ;  "Event which occurs when the next data packet arrives.") (SPPOUTPUTSTREAM POINTER) (* ; "Stream for output side") (SPPWHENCLOSEDFN POINTER) (SPPSTATE POINTER) (SPPERRORHANDLER POINTER) (* ;  "Fn to call when stream is in abnormal input state") (SPPSERVERFN POINTER) (* ;  "Function to use as toplevel function for connections opened as servers") (SPPOTHERXIPHANDLER POINTER) (* ;  "Function to call when non-SPP, non-ERROR XIP received on socket") (SPPINACTIVECOUNT POINTER) (SPPINPUTDSTYPE BYTE) (SPPDSTYPECHANGEFN POINTER)) [ACCESSFNS SPPCON ([SPPSOURCENSADDRESS (\FETCH.NSADDRESS (LOCF (fetch SPPSOURCENSADDRESS0 of DATUM] [SPPDESTNSADDRESS (\FETCH.NSADDRESS (LOCF (fetch SPPDESTNSADDRESS0 of DATUM] (SPPDESTNSNET (\GETBASEFIXP (LOCF (fetch SPPDESTNSADDRESS0 of DATUM)) 0] SPPINPUTQ _ (create SYSQUEUE) SPPRETRANSMITQ _ (ARRAY \SPP.RETRANSMITQ.SIZE 'POINTER NIL 0) SPPALLOCATIONEVENT _ (CREATE.EVENT "SPP Allocation") SPPRETRANSMITTIMER _ (SETUPTIMER 0) SPPERRORHANDLER _ (FUNCTION \SPP.DEFAULT.ERRORHANDLER)) (BLOCKRECORD SPPHEAD ((CC BYTE) (DSTYPE BYTE) (SOURCECONID WORD) (DESTCONID WORD) (SEQNO WORD) (ACKNO WORD) (ALLOCNO WORD) (FIRSTSPPDATABYTE BYTE) (NIL BYTE)) (BLOCKRECORD SPPHEAD ((SYSTEMPACKET FLAG) (* ;  "Interpretation of Connection Control bits") (SENDACK FLAG) (ATTENTION FLAG) (ENDOFMESSAGE FLAG) (NIL BITS 4) (NIL BYTE))) (BLOCKRECORD SPPHEAD ((NIL FLAG) (NIL FLAG) (EOMBITS BITS 2) (* ; "End of message or Attention") (NIL BITS 4) (NIL BYTE))) [ACCESSFNS SPPHEAD ((SPPCONTENTS (LOCF (fetch (SPPHEAD FIRSTSPPDATABYTE) of DATUM))) (EOMP (NEQ 0 (fetch (SPPHEAD EOMBITS) of DATUM]) (ACCESSFNS SPPXIP ((SPPHEAD (fetch XIPCONTENTS of DATUM)))) ) (/DECLAREDATATYPE 'SPPCON '(WORD BYTE BYTE WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD BYTE BYTE WORD WORD WORD WORD WORD FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER BYTE POINTER) '((SPPCON 0 (BITS . 15)) (SPPCON 1 (BITS . 7)) (SPPCON 1 (BITS . 135)) (SPPCON 2 (BITS . 15)) (SPPCON 3 (BITS . 15)) (SPPCON 4 (BITS . 15)) (SPPCON 5 (BITS . 15)) (SPPCON 6 (BITS . 15)) (SPPCON 7 (BITS . 15)) (SPPCON 8 (BITS . 15)) (SPPCON 9 (BITS . 15)) (SPPCON 10 (BITS . 15)) (SPPCON 11 (BITS . 15)) (SPPCON 12 (BITS . 15)) (SPPCON 13 (BITS . 15)) (SPPCON 14 (BITS . 7)) (SPPCON 14 (BITS . 135)) (SPPCON 15 (BITS . 15)) (SPPCON 16 (BITS . 15)) (SPPCON 17 (BITS . 15)) (SPPCON 18 (BITS . 15)) (SPPCON 19 (BITS . 15)) (SPPCON 20 (FLAGBITS . 0)) (SPPCON 20 (FLAGBITS . 16)) (SPPCON 20 (FLAGBITS . 32)) (SPPCON 20 (FLAGBITS . 48)) (SPPCON 20 POINTER) (SPPCON 22 (FLAGBITS . 0)) (SPPCON 22 (FLAGBITS . 16)) (SPPCON 22 (FLAGBITS . 32)) (SPPCON 22 (FLAGBITS . 48)) (SPPCON 22 POINTER) (SPPCON 24 POINTER) (SPPCON 26 POINTER) (SPPCON 28 POINTER) (SPPCON 30 POINTER) (SPPCON 32 (BITS . 15)) (SPPCON 33 (BITS . 15)) (SPPCON 34 POINTER) (SPPCON 36 POINTER) (SPPCON 38 POINTER) (SPPCON 40 POINTER) (SPPCON 42 POINTER) (SPPCON 44 POINTER) (SPPCON 46 POINTER) (SPPCON 48 POINTER) (SPPCON 50 POINTER) (SPPCON 52 POINTER) (SPPCON 54 POINTER) (SPPCON 56 POINTER) (SPPCON 58 POINTER) (SPPCON 60 POINTER) (SPPCON 62 POINTER) (SPPCON 64 POINTER) (SPPCON 66 POINTER) (SPPCON 68 POINTER) (SPPCON 70 POINTER) (SPPCON 72 POINTER) (SPPCON 74 POINTER) (SPPCON 76 POINTER) (SPPCON 78 (BITS . 7)) (SPPCON 80 POINTER)) '82) (RPAQQ SPPTYPES (\SPPHEAD.CC.SYSTEM \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.ATTENTION \SPPHEAD.CC.EOM \SPPDSTYPE.COURIER \SPPDSTYPE.BULKDATA \SPPDSTYPE.END \SPPDSTYPE.ENDREPLY)) (DECLARE%: EVAL@COMPILE (RPAQQ \SPPHEAD.CC.SYSTEM 128) (RPAQQ \SPPHEAD.CC.ACKNOWLEDGE 64) (RPAQQ \SPPHEAD.CC.ATTENTION 32) (RPAQQ \SPPHEAD.CC.EOM 16) (RPAQQ \SPPDSTYPE.COURIER 0) (RPAQQ \SPPDSTYPE.BULKDATA 1) (RPAQQ \SPPDSTYPE.END 254) (RPAQQ \SPPDSTYPE.ENDREPLY 255) (CONSTANTS \SPPHEAD.CC.SYSTEM \SPPHEAD.CC.ACKNOWLEDGE \SPPHEAD.CC.ATTENTION \SPPHEAD.CC.EOM \SPPDSTYPE.COURIER \SPPDSTYPE.BULKDATA \SPPDSTYPE.END \SPPDSTYPE.ENDREPLY) ) (RPAQQ SPPSTATES ((\SPS.INIT 0) (\SPS.LISTENING 1) (\SPS.OPEN 2) (\SPS.ENDSENT 3) (\SPS.ENDRECEIVED 4) (\SPS.DALLYING 5) (\SPS.CLOSED 6) (\SPS.ABORTED 7))) (DECLARE%: EVAL@COMPILE (RPAQQ \SPS.INIT 0) (RPAQQ \SPS.LISTENING 1) (RPAQQ \SPS.OPEN 2) (RPAQQ \SPS.ENDSENT 3) (RPAQQ \SPS.ENDRECEIVED 4) (RPAQQ \SPS.DALLYING 5) (RPAQQ \SPS.CLOSED 6) (RPAQQ \SPS.ABORTED 7) (CONSTANTS (\SPS.INIT 0) (\SPS.LISTENING 1) (\SPS.OPEN 2) (\SPS.ENDSENT 3) (\SPS.ENDRECEIVED 4) (\SPS.DALLYING 5) (\SPS.CLOSED 6) (\SPS.ABORTED 7)) ) (DECLARE%: EVAL@COMPILE (RPAQQ \SPPHEAD.LENGTH 12) (RPAQ \#WDS.SPPINFO (SUB1 (FOLDLO (IPLUS \XIPOVLEN \SPPHEAD.LENGTH) BYTESPERWORD))) (RPAQQ \SPP.INITIAL.ALLOCATION 5) (RPAQQ \SPP.INITIAL.ROUNDTRIP 1000) (RPAQQ \SPP.RETRANSMITQ.SIZE 8) (CONSTANTS (\SPPHEAD.LENGTH 12) (\#WDS.SPPINFO (SUB1 (FOLDLO (IPLUS \XIPOVLEN \SPPHEAD.LENGTH) BYTESPERWORD))) (\SPP.INITIAL.ALLOCATION 5) (\SPP.INITIAL.ROUNDTRIP 1000) (\SPP.RETRANSMITQ.SIZE 8)) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS SPPSTREAM ((SPP.CONNECTION (fetch F1 of DATUM) (replace F1 of DATUM with NEWVALUE)) (BULK.DATA.CONTINUATION (fetch F2 of DATUM) (replace F2 of DATUM with NEWVALUE)) (SPPEOFBITS (fetch FW8 of DATUM) (replace FW8 of DATUM with NEWVALUE)) (SPPFILEPTRHI (fetch FW6 of DATUM) (replace FW6 of DATUM with NEWVALUE)) (SPPFILEPTRLO (fetch FW7 of DATUM) (replace FW7 of DATUM with NEWVALUE))) [ACCESSFNS SPPSTREAM ([SPPEOFP (SELECTC (fetch SPPEOFBITS of DATUM) (0 NIL) (\SPPFLAG.END 'END) (\SPPFLAG.ATTENTION 'ATTENTION) (\SPPFLAG.EOM 'EOM) NIL) (replace SPPEOFBITS of DATUM with (SELECTQ NEWVALUE (NIL 0) (EOM \SPPFLAG.EOM) (END \SPPFLAG.END) (ATTENTION \SPPFLAG.ATTENTION) (\ILLEGAL.ARG NEWVALUE] (SPPFILEPTR (\MAKENUMBER (fetch SPPFILEPTRHI of DATUM) (fetch SPPFILEPTRLO of DATUM]) ) (DECLARE%: EVAL@COMPILE (PUTPROPS GETSPPCON MACRO ((X) (fetch SPP.CONNECTION of X))) [PUTPROPS \FETCH.NSADDRESS MACRO ((BASE) (PROG ((ADDRESS (create NSADDRESS))) (\BLT ADDRESS BASE \#WDS.NSADDRESS) (RETURN ADDRESS] [PUTPROPS \SPPINCFILEPTR MACRO (OPENLAMBDA (STREAM NBYTES) (COND ((ILESSP (replace SPPFILEPTRLO of STREAM with (\LOLOC (\ADDBASE (fetch SPPFILEPTRLO of STREAM) NBYTES))) NBYTES) (add (fetch SPPFILEPTRHI of STREAM) 1] (PUTPROPS GETWORD MACRO (= . \WIN)) (PUTPROPS PUTWORD MACRO (= . \WOUT)) [PUTPROPS GETLONG MACRO (OPENLAMBDA (STREAM) (\MAKENUMBER (\WIN STREAM) (\WIN STREAM] [PUTPROPS PUTLONG MACRO (OPENLAMBDA (STREAM FIXP) (PROGN (\WOUT STREAM (\HINUM FIXP)) (\WOUT STREAM (LOGAND FIXP 65535] (PUTPROPS SPP.STREAM.ERROR MACRO (OPENLAMBDA (STREAM ERRCODE) (SPREADAPPLY* (fetch SPPERRORHANDLER of (GETSPPCON STREAM)) STREAM ERRCODE))) ) (RPAQQ SPPEOFFLAGS ((\SPPFLAG.EOM 1) (\SPPFLAG.END 2) (\SPPFLAG.ATTENTION 3))) (DECLARE%: EVAL@COMPILE (RPAQQ \SPPFLAG.EOM 1) (RPAQQ \SPPFLAG.END 2) (RPAQQ \SPPFLAG.ATTENTION 3) (CONSTANTS (\SPPFLAG.EOM 1) (\SPPFLAG.END 2) (\SPPFLAG.ATTENTION 3)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \SPPDEVICE \SPP.BULKDATA.DEVICE) ) (PUTPROPS SPPDECLS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/STACKFNS b/sources/STACKFNS new file mode 100644 index 00000000..47af5444 --- /dev/null +++ b/sources/STACKFNS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-May-90 15:48:43" |{DSK}local>lde>lispcore>sources>STACKFNS.;2| 6154 |changes| |to:| (VARS STACKFNSCOMS) |previous| |date:| "30-Nov-86 17:10:26" |{DSK}local>lde>lispcore>sources>STACKFNS.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT STACKFNSCOMS) (RPAQQ STACKFNSCOMS ((FNS STKARGS MAPDL SEARCHPDL VARIABLES REALFRAMEP \\REALFRAMEP REALSTKNTH) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA STKARGS))))) (DEFINEQ (STKARGS (CL:LAMBDA (POS) (* |;;|  " return the first NARGS arguments at POS") (FOR I FROM 1 TO (STKNARGS POS) COLLECT (STKARG I POS)))) (MAPDL (LAMBDA (MAPDLFN MAPDLPOS) (* |wt:| " 9-SEP-78 20:55") (PROG NIL (SETQ MAPDLPOS (COND ((NULL MAPDLPOS) (STKPOS 'MAPDL)) (SPAGHETTIFLG (STKNTH 0 MAPDLPOS)) (T MAPDLPOS))) LP (COND ((NULL (SETQ MAPDLPOS (STKNTH -1 MAPDLPOS MAPDLPOS))) (RETURN NIL))) (APPLY* MAPDLFN (STKNAME MAPDLPOS) MAPDLPOS) (GO LP)))) (SEARCHPDL (LAMBDA (SRCHFN SRCHPOS) (* |Does| |not| |release| |or| |reuse|  SRCHPOS) (PROG (SRCHX) (SETQ SRCHPOS (COND ((NULL SRCHPOS) (STKPOS 'SEARCHPDL)) (SPAGHETTIFLG (STKNTH 0 SRCHPOS)) (T SRCHPOS))) LP (COND ((NULL (SETQ SRCHPOS (STKNTH -1 SRCHPOS SRCHPOS))) (RETURN NIL)) ((APPLY* SRCHFN (SETQ SRCHX (STKNAME SRCHPOS)) SRCHPOS) (RETURN (CONS SRCHX SRCHPOS)))) (GO LP)))) (VARIABLES (LAMBDA (POS) (PROG (N L) (SETQ N (STKNARGS POS)) LP (COND ((ZEROP N) (RETURN L))) (SETQ L (CONS (STKARGNAME N POS) L)) (SETQ N (SUB1 N)) (GO LP)))) (REALFRAMEP (LAMBDA (POS INTERPFLG) (* |lmm| " 7-Nov-86 01:50") (* |;;| "Value is T if frame should be visible for backtrace, and error retry") (* |;;| "user did write a call to the function at POS, and either INTERPFLG is T, or else the functio call would also exist if compiled") (\\REALFRAMEP (\\STACKARGPTR POS) INTERPFLG))) (\\REALFRAMEP (LAMBDA (FRAME INTERPFLG) (* |lmm| " 7-Nov-86 01:53") (LET ((NAME (|fetch| (FNHEADER FRAMENAME) |of| (|fetch| (FX FNHEADER) |of| FRAME))) BFLINK) (* |;;| "note that the selection is on the fnheader's name rather than the nametable name. \\REALFRAMEP is thus not affected by SETSTKNAME") (AND (CL:SYMBOLP NAME) (SELECTQ NAME (*ENV* (* \; "*ENV* is used by ENVEVAL etc.") NIL) (\\INTERPRETER T) (ERRORSET (NEQ (\\STKARG 2 FRAME) 'INTERNAL)) ((EVAL APPLY) (\\SMASHLINK NIL FRAME) (SELECTQ \\INTERNAL ((INTERNAL SELECTQ) NIL) T)) (OR (NOT (LITATOM NAME)) (COND ((FMEMB NAME OPENFNS) INTERPFLG) (T (OR (NEQ (CHCON1 NAME) (CHARCODE \\)) (EXPRP NAME) (FASSOC NAME BRKINFOLST)))))))))) (REALSTKNTH (LAMBDA (N POS INTERPFLG OLDPOS) (* |amd| "11-Nov-86 12:03") (* |;;| "skips back N (or -N) real frames on the stack. i.e. frames for which (REALFRAMEP POS INTERPFLG) is true") (PROG ((FX (\\STACKARGPTR POS)) (K (COND ((ILESSP N 0) (IMINUS N)) (T N)))) LP (COND ((EQ 0 (SETQ FX (COND ((IGREATERP 0 N) (|fetch| (FX CLINK) |of| FX)) (T (|fetch| (FX ALINK) |of| FX))))) (RETURN NIL))) (COND ((\\REALFRAMEP FX INTERPFLG) (COND ((ILEQ (SETQ K (SUB1 K)) 0) (RETURN (\\MAKESTACKP OLDPOS FX)))))) (GO LP)))) ) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA STKARGS) ) (PRETTYCOMPRINT STACKFNSCOMS) (RPAQQ STACKFNSCOMS ((FNS STKARGS MAPDL SEARCHPDL VARIABLES REALFRAMEP \\REALFRAMEP REALSTKNTH) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA))))) (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS STACKFNS COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (762 5270 (STKARGS 772 . 1048) (MAPDL 1050 . 1604) (SEARCHPDL 1606 . 2306) (VARIABLES 2308 . 2575) (REALFRAMEP 2577 . 3024) (\\REALFRAMEP 3026 . 4364) (REALSTKNTH 4366 . 5268))))) STOP \ No newline at end of file diff --git a/sources/SUNFONT b/sources/SUNFONT new file mode 100644 index 00000000..c449f5e4 --- /dev/null +++ b/sources/SUNFONT @@ -0,0 +1,32 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "28-Jan-98 10:46:39" |{DSK}disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;2| 1164 + + |changes| |to:| (VARS DISPLAYFONTDIRECTORIES) + + |previous| |date:| "24-Jan-90 15:53:22" +|{DSK}disk2>jdstools>lc3>lispcore3.0>SUNLOADUP>SUNFONT.;1|) + + +; Copyright (c) 1990, 1998 by John Sybalsky. All rights reserved. + +(PRETTYCOMPRINT SUNFONTCOMS) + +(RPAQQ SUNFONTCOMS ((VARS DISPLAYFONTDIRECTORIES))) + +(RPAQQ DISPLAYFONTDIRECTORIES ( + "{DSK}~/lispcore/fonts/display/presentation/" + + "{DSK}~/lispcore/fonts/display/PRINTWHEEL/" + + "{DSK}~/lispcore/fonts/display/publishing/" + + "{DSK}~/lispcore/fonts/display/miscellaneous/" + )) +(PUTPROPS SUNFONT COPYRIGHT ("John Sybalsky" 1990 1998)) +(DECLARE\: DONTCOPY + (FILEMAP (NIL))) +STOP + + + + diff --git a/sources/SYSPRETTY b/sources/SYSPRETTY new file mode 100644 index 00000000..ace93c40 --- /dev/null +++ b/sources/SYSPRETTY @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "17-May-90 15:50:03" |{DSK}local>lde>lispcore>sources>SYSPRETTY.;2| 1233 |changes| |to:| (VARS SYSPRETTYCOMS) |previous| |date:| " 3-Dec-86 22:14:12" |{DSK}local>lde>lispcore>sources>SYSPRETTY.;1|) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT SYSPRETTYCOMS) (RPAQQ SYSPRETTYCOMS ((GLOBALVARS SYSPRETTYFLG) (FNS SHOWPRINT SHOWPRIN2) (INITVARS (SYSPRETTYFLG)))) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS SYSPRETTYFLG) ) (DEFINEQ (showprint (lambda (x file rdtbl) (* |lmm| "14-Aug-84 20:40") (cond (sysprettyflg (printdef x t nil nil nil file) (terpri file)) (t (print x file rdtbl))) x)) (showprin2 (lambda (x file rdtbl) (* |lmm| "14-Aug-84 20:40") (cond (sysprettyflg (printdef x t nil nil nil file)) (t (prin2 x file rdtbl))) x)) ) (RPAQ? SYSPRETTYFLG ) (PUTPROPS SYSPRETTY COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (638 1112 (SHOWPRINT 648 . 892) (SHOWPRIN2 894 . 1110))))) STOP \ No newline at end of file diff --git a/sources/TIME b/sources/TIME new file mode 100644 index 00000000..6f84b517 --- /dev/null +++ b/sources/TIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "CL") (IL:FILECREATED "16-Apr-2018 23:05:10"  IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>TIME.;3| 16066 IL:|changes| IL:|to:| (IL:FUNCTIONS %PRINT-TIMING-INFO) IL:|previous| IL:|date:| " 5-Jan-93 02:34:56" IL:|{DSK}kaplan>Local>medley3.5>lispcore>sources>TIME.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1993, 2018 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:TIMECOMS) (IL:RPAQQ IL:TIMECOMS ((IL:STRUCTURES STATS-OBJECT) (IL:FUNCTIONS %COPY-TIME-STATS %STATS-OBJECT-DIFFERENCE) (IL:FUNCTIONS %GET-TIMING-INFO TIME-CALL TIME) (IL:FUNCTIONS %CAPTURE-COUNTERS-BEFORE %CAPTURE-COUNTERS-AFTER TIME-FORMAT %PRINT-TIMING-ITEM %PRINT-TIMING-INFO) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %CAPTURE-BEFORE-STATS %CAPTURE-AFTER-STATS %MOVE-FIXP-FIELD)) (IL:SPECIAL-FORMS TIME) (IL:COMMANDS "TIME") (IL:* IL:|;;| "Interlisp Timeall function") (IL:FNS IL:TIMEALL) (IL:* IL:|;;| "file package stuff") (IL:PROP IL:FILETYPE TIME) (IL:PROP IL:MAKEFILE-ENVIRONMENT TIME) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T)) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML IL:TIMEALL) (IL:LAMA))))) (DEFSTRUCT (STATS-OBJECT (:TYPE LIST) (:COPIER NIL) (:PREDICATE NIL)) (ELAPSED-TIME (IL:CLOCK 0)) (TIME-BLOCK (IL:|create| IL:MISCSTATS)) (DATA-COUNTERS (MAKE-ARRAY (1+ IL:|\\MaxTypeNumber|) :ELEMENT-TYPE '(SIGNED-BYTE 32) :INITIAL-ELEMENT 0)) DATATYPES) (DEFUN %COPY-TIME-STATS (REFERENCE-BLOCK DESTINATION-BLOCK) (IL:* IL:|;;| "Copies various fields from one miscstats block to another. Both reference-block and destination-block should be unboxed hunks (made by (IL:create IL:miscstats)), but IL:\\\\miscstats is also a valid value for reference-block") (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWAITTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:GCTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:PAGEFAULTS) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:SWAPWRITES) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:TOTALTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:NETIOTIME) DESTINATION-BLOCK REFERENCE-BLOCK) (%MOVE-FIXP-FIELD (IL:MISCSTATS IL:DISKOPS) DESTINATION-BLOCK REFERENCE-BLOCK) DESTINATION-BLOCK) (DEFUN %STATS-OBJECT-DIFFERENCE (BEFORE AFTER) (IL:* IL:|;;|  "puts the differences between the stat-object after and stat-object before back into after.") (LET ((BEFORE-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS BEFORE)) (BEFORE-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK BEFORE)) (AFTER-DATA-COUNTERS (STATS-OBJECT-DATA-COUNTERS AFTER)) (AFTER-TIME-BLOCK (STATS-OBJECT-TIME-BLOCK AFTER))) (DOTIMES (I (LENGTH BEFORE-DATA-COUNTERS)) (DECF (AREF AFTER-DATA-COUNTERS I) (AREF BEFORE-DATA-COUNTERS I))) (DECF (STATS-OBJECT-ELAPSED-TIME AFTER) (STATS-OBJECT-ELAPSED-TIME BEFORE)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| BEFORE-TIME-BLOCK)) (DECF (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| AFTER-TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| BEFORE-TIME-BLOCK)) AFTER)) (DEFUN %GET-TIMING-INFO (TIMED-FUNCTION TIME-BEFORE TIME-AFTER &OPTIONAL (REPEAT 1)) (IL:* IL:|;;| "Side-effects TIME-BEFORE and TIME-AFTER. Returns the value (or values of TIMED-FUNCTION, and the timing-info in TIME-AFTER.") (LET ((VALUES NIL)) (%CAPTURE-BEFORE-STATS TIME-BEFORE) (DOTIMES (I (1- REPEAT)) (FUNCALL TIMED-FUNCTION)) (SETQ VALUES (MULTIPLE-VALUE-LIST (FUNCALL TIMED-FUNCTION))) (%CAPTURE-AFTER-STATS TIME-AFTER) (%STATS-OBJECT-DIFFERENCE TIME-BEFORE TIME-AFTER) (VALUES-LIST VALUES))) (DEFUN TIME-CALL (TIMED-FUNCTION &KEY (OUTPUT *TRACE-OUTPUT*) (TIMED-FORM NIL TIMED-FORM-P) (DATA-TYPES (IL:DATATYPES)) (REPEAT 1)) (LET ((VALUES NIL) (TIME-BEFORE (MAKE-STATS-OBJECT)) (TIME-AFTER (MAKE-STATS-OBJECT)) (TIME-DO-NOTHING (MAKE-STATS-OBJECT))) (IL:* IL:|;;| "Calibrate") (%GET-TIMING-INFO #'(LAMBDA NIL NIL) TIME-BEFORE TIME-DO-NOTHING) (SETQ VALUES (MULTIPLE-VALUE-LIST (%GET-TIMING-INFO TIMED-FUNCTION TIME-BEFORE TIME-AFTER REPEAT))) (%STATS-OBJECT-DIFFERENCE TIME-DO-NOTHING TIME-AFTER) (IF TIMED-FORM-P (TIME-FORMAT OUTPUT "Timing for ~[~;~:;~:* ~D x~]:~20T ~S~&" REPEAT TIMED-FORM)) (%PRINT-TIMING-ITEM OUTPUT "Elapsed time" (STATS-OBJECT-ELAPSED-TIME TIME-AFTER) T T) (%PRINT-TIMING-INFO OUTPUT TIME-AFTER DATA-TYPES) (VALUES-LIST VALUES))) (DEFMACRO TIME (TIMED-FORM &REST KEYWORDS) `(TIME-CALL #'(LAMBDA NIL ,TIMED-FORM) :TIMED-FORM ',TIMED-FORM ,@KEYWORDS)) (DEFUN %CAPTURE-COUNTERS-BEFORE (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes before timing. Note, IL:BOXCOUNT may create fixp's, so count down, so the FIXP count is recorded last") (DO ((I (1- (LENGTH VECTOR)) (1- I))) ((< I 0) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I)))) (DEFUN %CAPTURE-COUNTERS-AFTER (VECTOR) (IL:* IL:|;;| "Record box count for all known datatypes after timing. Note, IL:BOXCOUNT may create fixp's, so count up, so the FIXP count is recorded first") (DOTIMES (I (LENGTH VECTOR) VECTOR) (SETF (AREF VECTOR I) (IL:BOXCOUNT I)))) (DEFUN TIME-FORMAT (STREAM FORMAT-STRING &REST ARGS) (IF (EQ STREAM :EXEC) (APPLY 'XCL:EXEC-FORMAT FORMAT-STRING ARGS) (APPLY 'FORMAT STREAM FORMAT-STRING ARGS))) (DEFUN %PRINT-TIMING-ITEM (STREAM STRING NUM TIME-P ALWAYS-P) (IF (OR ALWAYS-P (> NUM 0)) (IF TIME-P (TIME-FORMAT STREAM "~&~A ~20,5T= ~9,3F seconds~&" STRING (MAX 0 (/ NUM 1000.0))) (TIME-FORMAT STREAM "~&~A ~20,5T= ~9D~&" STRING NUM)))) (DEFUN %PRINT-TIMING-INFO (STREAM STATS-OBJECT DATA-TYPES) (LET ((TIME-BLOCK (STATS-OBJECT-TIME-BLOCK STATS-OBJECT)) (DATA-TYPE-INFO (LET ((DATA-COUNTER (STATS-OBJECT-DATA-COUNTERS STATS-OBJECT)) (RESULT NIL) (RESULT-TAIL NIL) CNT TYPE-NAME) (DOTIMES (I (MIN (LENGTH DATA-COUNTER) (1+ IL:|\\MaxTypeNumber|)) RESULT) (SETQ CNT (AREF DATA-COUNTER I)) (WHEN (> CNT 0) (SETQ TYPE-NAME (IL:\\TYPENAMEFROMNUMBER I)) (IF (MEMBER TYPE-NAME DATA-TYPES :TEST #'EQ) (IF RESULT (RPLACD RESULT-TAIL (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME)))) (SETQ RESULT (SETQ RESULT-TAIL (LIST (LIST CNT TYPE-NAME))) )))))))) (%PRINT-TIMING-ITEM STREAM "SWAP time" (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) T NIL) (%PRINT-TIMING-ITEM STREAM "reclaim time" (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) T NIL) (%PRINT-TIMING-ITEM STREAM "Disk i/o time" (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) T NIL) (%PRINT-TIMING-ITEM STREAM "net compute time" (- (STATS-OBJECT-ELAPSED-TIME STATS-OBJECT) (IL:|fetch| (IL:MISCSTATS IL:SWAPWAITTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:GCTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:DISKIOTIME) IL:|of| TIME-BLOCK) (IL:|fetch| (IL:MISCSTATS IL:NETIOTIME) IL:|of| TIME-BLOCK)) T T) (%PRINT-TIMING-ITEM STREAM "Page faults" (IL:|fetch| (IL:MISCSTATS IL:PAGEFAULTS) IL:|of| TIME-BLOCK) NIL) (%PRINT-TIMING-ITEM STREAM "Swap writes" (IL:|fetch| (IL:MISCSTATS IL:SWAPWRITES) IL:|of| TIME-BLOCK) NIL) (%PRINT-TIMING-ITEM STREAM "Disk operations" (IL:|fetch| (IL:MISCSTATS IL:DISKOPS) IL:|of| TIME-BLOCK) NIL) (IF DATA-TYPE-INFO (TIME-FORMAT STREAM "~&Storage allocated:~%~{~{~D ~A~}~^, ~}~&" DATA-TYPE-INFO)) (TIME-FORMAT STREAM "~%"))) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (DEFMACRO %CAPTURE-BEFORE-STATS (STATS-OBJECT) (IL:* IL:|;;|  "Capture machine state before timeing an evaluation. Note that ordering is important") `(LET ((%$$STATS-OBJECT ,STATS-OBJECT)) (%CAPTURE-COUNTERS-BEFORE (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)))) (DEFMACRO %CAPTURE-AFTER-STATS (STATS-OBJECT) `(LET ((%$$STATS-OBJECT ,STATS-OBJECT)) (IL:CLOCK0 (STATS-OBJECT-ELAPSED-TIME %$$STATS-OBJECT)) (%COPY-TIME-STATS IL:\\MISCSTATS (STATS-OBJECT-TIME-BLOCK %$$STATS-OBJECT)) (%CAPTURE-COUNTERS-AFTER (STATS-OBJECT-DATA-COUNTERS %$$STATS-OBJECT)))) (DEFMACRO %MOVE-FIXP-FIELD (FIELD-NAME DEST SOURCE) `(IL:\\BLT (IL:LOCF (IL:FETCH ,FIELD-NAME IL:OF ,DEST)) (IL:LOCF (IL:FETCH ,FIELD-NAME IL:OF ,SOURCE)) 2)) ) (XCL:DEFINE-SPECIAL-FORM TIME (TIMED-FORM &KEY (DATA-TYPES '(IL:DATATYPES)) (REPEAT 1) (OUTPUT '*TRACE-OUTPUT*) &ENVIRONMENT ENV &AUX *EVALHOOK* *APPLYHOOK*) (TIME-CALL #'(LAMBDA NIL (EVAL TIMED-FORM ENV)) :TIMED-FORM TIMED-FORM :DATA-TYPES (EVAL DATA-TYPES ENV) :REPEAT (EVAL REPEAT ENV) :OUTPUT (EVAL OUTPUT ENV))) (XCL:DEFCOMMAND "TIME" (FORM &KEY (REPEAT 1) &ENVIRONMENT ENV) "Time evaluation of form, output here" (TIME-CALL #'(LAMBDA NIL (EVAL FORM ENV)) :OUTPUT :EXEC :REPEAT (EVAL REPEAT ENV))) (IL:* IL:|;;| "Interlisp Timeall function") (IL:DEFINEQ (IL:TIMEALL (IL:NLAMBDA (IL:TIMEFORM IL:NUMBEROFTIMES IL:TIMEWHAT IL:INTERPFLG) (IL:* IL:\; "Edited 29-Jan-87 18:48 by jop") (IL:* IL:|;;| "collects and prints stats on TIMEFORM. TIMEWHAT indicates what to collect stats on: if T, all of the system times are collected; if NIL, the system times plus all data allocations are kept; if a list, it should be a list of DATATYPES (or numbers) . ") (LET ((IL:DATATYPES (COND ((NULL IL:TIMEWHAT) (IL:DATATYPES)) ((EQ IL:TIMEWHAT T) NIL) (T (IL:|for| IL:X IL:|inside| IL:TIMEWHAT IL:|bind| IL:NAME IL:|join| (COND ((IL:SETQ IL:NAME (IL:DATATYPEP IL:X)) (CONS IL:NAME)) ((EQ IL:X 'TIME) NIL) (T (IL:|printout| T IL:X " is not a datatype." T) NIL)))))) IL:VALUE) (OR (IL:NUMBERP IL:NUMBEROFTIMES) (IL:SETQ IL:NUMBEROFTIMES 1)) (LET ((IL:STRF T) (IL:LCFIL NIL)) (DECLARE (IL:SPECVARS IL:STRF IL:LCFIL)) (IL:COMPILE1 'IL:TIMEDUMMYFUNCTION `(IL:LAMBDA NIL ,IL:TIMEFORM)) (TIME-CALL 'IL:TIMEDUMMYFUNCTION :OUTPUT (IL:GETSTREAM NIL 'IL:OUTPUT) :TIMED-FORM IL:TIMEFORM :DATA-TYPES IL:DATATYPES :REPEAT IL:NUMBEROFTIMES))))) ) (IL:* IL:|;;| "file package stuff") (IL:PUTPROPS TIME IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS TIME IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "CL")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDTOVAR IL:NLAMA ) (IL:ADDTOVAR IL:NLAML IL:TIMEALL) (IL:ADDTOVAR IL:LAMA ) ) (IL:PUTPROPS TIME IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993 2018)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (2061 3182 (%COPY-TIME-STATS 2061 . 3182)) (3184 4947 (%STATS-OBJECT-DIFFERENCE 3184 . 4947)) (4949 5537 (%GET-TIMING-INFO 4949 . 5537)) (5539 6623 (TIME-CALL 5539 . 6623)) (6790 7144 ( %CAPTURE-COUNTERS-BEFORE 6790 . 7144)) (7146 7472 (%CAPTURE-COUNTERS-AFTER 7146 . 7472)) (7474 7657 ( TIME-FORMAT 7474 . 7657)) (7659 7941 (%PRINT-TIMING-ITEM 7659 . 7941)) (7943 11802 (%PRINT-TIMING-INFO 7943 . 11802)) (13628 15457 (IL:TIMEALL 13641 . 15455))))) IL:STOP \ No newline at end of file diff --git a/sources/TRSERVER b/sources/TRSERVER new file mode 100644 index 00000000..a3adb347 --- /dev/null +++ b/sources/TRSERVER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "17-May-90 15:58:24" {DSK}local>lde>lispcore>sources>TRSERVER.;2 17572 changes to%: (VARS TRSERVERCOMS) previous date%: " 6-Jun-88 11:27:47" {DSK}local>lde>lispcore>sources>TRSERVER.;1) (* ; " Copyright (c) 1983, 1984, 1985, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TRSERVERCOMS) (RPAQQ TRSERVERCOMS [(FNS \DOTELERAID \TELERAIDINIT \TELERAIDSERVER \TELEBLTCURSOR \TELERAIDCOMMAND \TELERAIDBREAK \TELERAIDGET \TELERAIDSEND \TELERAIDRELEASE \TELERAIDENTRY \TELERAIDEXIT \3MBRAWRECEIVE \3MBRAWTRANSMIT \10MBRAWRECEIVE \10MBRAWTRANSMIT \10MBRAWENCAPSULATE \10MBSETUPRECEIVER) (INITVARS (\TELERAIDBUFFER) (\TELERAIDBLOCK)) (BITMAPS \TELERAIDBITMAPS) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \TELERAIDPACKET \TELERAIDBUFFER \TELERAIDIOCB \TELERAIDBLOCK \TELERAIDBITMAPS) (RECORDS TRBLOCK) (MACROS \TELEKBDWAIT) (CONSTANTS \#WORDS.CURSOR) (FILES (LOADCOMP) LLETHER 10MBDRIVER REMOTEVMEM LLFAULT)) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (\TELERAIDINIT]) (DEFINEQ (\DOTELERAID (LAMBDA NIL (* bvm%: "15-MAR-83 17:10") (PROG NIL LP (\TELERAIDSERVER) (\CONTEXTSWITCH \TeleRaidFXP) (GO LP))) ) (\TELERAIDINIT (LAMBDA NIL (* bvm%: "16-Aug-85 01:06") (for FN in (QUOTE (\TELERAIDSERVER \TELERAIDCOMMAND \DOTELERAID \TELERAIDGET \TELERAIDSEND \TELERAIDSETUP \TELERAIDENTRY \TELERAIDEXIT \TELEBLTCURSOR \3MBRAWTRANSMIT \3MBRAWRECEIVE \WRITERAWPBI \READRAWPBI \GETPACKETBUFFER \10MBRAWRECEIVE \10MBRAWTRANSMIT \TELERAIDRELEASE \10MBRAWENCAPSULATE \10MBSETUPRECEIVER FLIPCURSOR \KEYBOARDON \KEYBOARDOFF \10MB.TURNONETHER \QUEUE.OUTPUT.IOCB \QUEUE.INPUT.IOCB \10MB.GETPACKETSTATUS \10MB.GETPACKETLENGTH SETMAINTPANEL \TELERAIDBREAK \FREESTACKBLOCK \DOHELPINTERRUPT1 \MAKEFRAME \DoveEther.ByteSwapIOCB \DoveEther.DeQueue \DoveEther.EnQueue \DoveEther.GetPacketStatus \DoveEther.MakeSureOff \DoveEther.QueueInput \DoveEther.QueueOutput \DoveEther.TurnOn)) do (\LOCKFN FN)) (for VAR in (QUOTE (\TELERAIDPACKET \TELERAIDBUFFER \TELERAIDIOCB \TELERAIDBLOCK \LOCALNDBS \PUP.READY \DEFSPACE)) do (\LOCKVAR VAR)) (COND ((NOT (TYPENAMEP \TELERAIDPACKET (QUOTE ETHERPACKET))) (SETQ \TELERAIDPACKET (\ALLOCATE.ETHERPACKET)) (\LOCKPAGES \TELERAIDPACKET 2))) (\LOCKWORDS (SETQ \TELERAIDBLOCK (fetch BITMAPBASE of \TELERAIDBITMAPS)) (fetch BITMAPHEIGHT of \TELERAIDBITMAPS))) ) (\TELERAIDSERVER (LAMBDA (METADEBUGGING) (* ; "Edited 6-Jun-88 11:17 by bvm") (DECLARE (GLOBALVARS \RCLKSECOND)) (PROG ((NDB \LOCALNDBS) (PACKET \TELERAIDPACKET) RECEIVER PTR VP FILEPAGE BODY) (SETQ RECEIVER (\TELERAIDENTRY NDB METADEBUGGING)) LP (COND ((AND RECEIVER (\TELERAIDGET NDB PACKET RECEIVER)) (SELECTC (fetch PUPTYPE of PACKET) (TR.GIVEPAGE (COND ((NOT (EVENP (fetch PUPIDLO of PACKET) WORDSPERPAGE)) (GO ERROR))) (SETQ VP (create WORD HIBYTE _ (fetch LOBYTE of (fetch PUPIDHI of PACKET)) LOBYTE _ (fetch HIBYTE of (fetch PUPIDLO of PACKET)))) (COND ((fetch (VP INVALID) of VP) (GO ERROR))) (SETQ PTR (\GETBASEPTR (LOCF (fetch PUPIDHI of PACKET)) 0)) (COND ((NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP))) (* ; "page is resident, we can just blt it") (\BLT (fetch PUPCONTENTS of PACKET) PTR WORDSPERPAGE)) ((AND (SETQ FILEPAGE (\LOOKUPPAGEMAP VP)) (NEQ FILEPAGE 0)) (* ; "Page exists, so swap it into private buffer") (\ACTONVMEMFILE FILEPAGE \TELERAIDBUFFER 1) (\BLT (fetch PUPCONTENTS of PACKET) \TELERAIDBUFFER WORDSPERPAGE)) (T (GO ERROR))) (replace PUPLENGTH of PACKET with (IPLUS BYTESPERPAGE \PUPOVLEN)) (replace PUPTYPE of PACKET with TR.HEREISPAGE) (\TELERAIDSEND NDB PACKET)) (TR.STORE (SETQ BODY (fetch PUPCONTENTS of PACKET)) (COND ((NEQ (\GETBASEBYTE BODY 0) 0) (GO ERROR))) (SETQ VP (create WORD HIBYTE _ (\GETBASEBYTE BODY 1) LOBYTE _ (\GETBASEBYTE BODY 2))) (COND ((fetch (VP INVALID) of VP) (GO ERROR))) (SETQ PTR (\GETBASEPTR BODY 0)) (COND ((NOT (fetch (VMEMFLAGS VACANT) of (\READFLAGS VP))) (* ; "page is resident, we can just store directly") (\PUTBASE PTR 0 (\GETBASE BODY 2))) ((AND (SETQ FILEPAGE (\LOOKUPPAGEMAP VP)) (NEQ FILEPAGE 0)) (* ; "Page exists, so swap it into private buffer") (\ACTONVMEMFILE FILEPAGE \TELERAIDBUFFER 1) (\PUTBASE \TELERAIDBUFFER (fetch (POINTER WORDINPAGE) of PTR) (\GETBASE BODY 2)) (\ACTONVMEMFILE FILEPAGE \TELERAIDBUFFER 1 T)) (T (GO ERROR))) (replace PUPLENGTH of PACKET with \PUPOVLEN) (replace PUPTYPE of PACKET with TR.STOREDONE) (\TELERAIDSEND NDB PACKET)) (TR.GO (COND ((PROG ((IDHI (fetch PUPIDHI of PACKET)) (IDLO (fetch PUPIDLO of PACKET))) (replace PUPTYPE of PACKET with TR.GOACK) (\TELERAIDSEND NDB PACKET) (RETURN (to 20000 when (\TELERAIDGET NDB PACKET RECEIVER) do (COND ((AND (EQ (fetch PUPTYPE of PACKET) TR.GOREPLY) (COND ((EQ IDLO MAX.SMALL.INTEGER) (* ; "Sigh, opencoded 32-bit arithmetic") (AND (EQ (fetch PUPIDLO of PACKET) 0) (EQ (fetch PUPIDHI of PACKET) (ADD1 IDHI)))) (T (AND (EQ (fetch PUPIDLO of PACKET) (ADD1 IDLO)) (EQ (fetch PUPIDHI of PACKET) IDHI))))) (RETURN T)) (T (\TELERAIDRELEASE NDB PACKET)))))) (\TELERAIDEXIT NDB) (RETURN)))) (\TELERAIDRELEASE NDB PACKET)))) (COND ((OR (XKEYDOWNP (QUOTE BLANK-BOTTOM)) (XKEYDOWNP (QUOTE CTRL))) (* ; "Command key") (\TELEBLTCURSOR (fetch TRCOMMAND of \TELERAIDBLOCK)) (SELECTQ (\TELERAIDCOMMAND NDB) (RESET (\TELERAIDEXIT NDB T) (COND (METADEBUGGING (HARDRESET)) (T (\CONTEXTSWITCH \ResetFXP)))) (RETURN (\TELERAIDEXIT NDB) (RETURN)) NIL)) (T (\TELEBLTCURSOR (fetch TRCURSOR of \TELERAIDBLOCK)))) (\UPDATETIMERS) (* ; "Keep the clock running") (GO LP) ERROR (replace PUPLENGTH of PACKET with \PUPOVLEN) (replace PUPTYPE of PACKET with TR.ERROR) (\TELERAIDSEND NDB PACKET) (GO LP))) ) (\TELEBLTCURSOR (LAMBDA (CURSOR) (* bvm%: "14-Aug-85 16:26") (\BLT \EM.CURSORBITMAP CURSOR \#WORDS.CURSOR) (COND ((EQ \MACHINETYPE \DAYBREAK) (\DoveDisplay.SetCursorShape)))) ) (\TELERAIDCOMMAND (LAMBDA (NDB) (* ; "Edited 6-Jun-88 11:19 by bvm") (COND ((XKEYDOWNP (QUOTE D)) (* ; "D --- hard reset") (\TELEBLTCURSOR (fetch TRCONTROLD of \TELERAIDBLOCK)) (COND ((\TELEKBDWAIT (QUOTE D)) (QUOTE RESET)))) ((XKEYDOWNP (QUOTE N)) (* ; "^N returns") (\TELEBLTCURSOR (fetch TRCONTROLN of \TELERAIDBLOCK)) (COND ((\TELEKBDWAIT (QUOTE N)) (QUOTE RETURN)))) ((XKEYDOWNP (QUOTE B)) (* ; "Break offender if possible") (\TELERAIDBREAK)) ((XKEYDOWNP (QUOTE P)) (* ; "Display pup number in maintenance panel") (SETMAINTPANEL (fetch NDBPUPHOST# of NDB)) (\TELEKBDWAIT (QUOTE P))) ((AND (NEQ \MACHINETYPE \DANDELION) (NEQ \MACHINETYPE \DAYBREAK) (XKEYDOWNP (QUOTE R))) (* ; "Get RAID") (\TELEBLTCURSOR (fetch TRRAID of \TELERAIDBLOCK)) (COND ((\TELEKBDWAIT (QUOTE R)) (RAID) (\TELEBLTCURSOR (fetch TRCURSOR of \TELERAIDBLOCK))))) ((AND (XKEYDOWNP (QUOTE S)) (XKEYDOWNP (QUOTE LSHIFT))) (\TELEBLTCURSOR (fetch TRCONTROLS of \TELERAIDBLOCK)) (\FLUSHVM) (\TELEBLTCURSOR (fetch TRCURSOR of \TELERAIDBLOCK))))) ) (\TELERAIDBREAK (LAMBDA NIL (* ; "Edited 6-Jun-88 11:20 by bvm") (PROG ((FRAME (fetch (IFPAGE TELERAIDFXP) of \InterfacePage)) NEWFRAME USERFRAME FREE NXT NXTEND) (* ;; "Build a frame to invoke \DOHELPINTERRUPT1 on top of user process. This code adapted from \PROCESS.MAKEFRAME and \PROCESS.MAKEFRAME0") (\TELEBLTCURSOR (fetch TRBREAK of \TELERAIDBLOCK)) (COND ((ILESSP FRAME (fetch (IFPAGE StackBase) of \InterfacePage)) (* ; "Running in a system context") (COND ((AND (IGREATERP (SETQ USERFRAME (fetch (IFPAGE FAULTFXP) of \InterfacePage)) (fetch (IFPAGE StackBase) of \InterfacePage)) (SELECTQ (fetch (FX FRAMENAME) of FRAME) (\MP.ERROR T) (RAID (EQ (fetch (FX FRAMENAME) of (SETQ FRAME (fetch (FX CLINK) of FRAME))) (QUOTE \MP.ERROR))) NIL) (SELECTC (\GETBASEPTR (STACKADDBASE (fetch (BF IVAR) of (fetch (FX BLINK) of FRAME))) 0) ((LIST \MP.INVALIDADDR \MP.INVALIDVP \MP.MOB \MP.RESIDENT) (* ; "MP codes in fault handler that are 'safe'") T) NIL)) (* ;; "Special case: allow breaks in user process in these cases, because fault handler will just switch right back to user context") (SETQ FRAME USERFRAME) (FLIPCURSOR)) (T (* ; "Refuse to do it--chances of surviving a full-fledged break are slim") (\TELEBLTCURSOR (fetch TRNOBREAK of \TELERAIDBLOCK)) (\TELEKBDWAIT (QUOTE B)) (RETURN))))) (COND ((NOT (\TELEKBDWAIT (QUOTE B))) (RETURN))) (SETQ NXT (fetch (FX NEXTBLOCK) of FRAME)) (SETQ NXTEND (IPLUS NXT (fetch (FSB SIZE) of NXT))) (while (type? FSB NXTEND) do (SETQ NXTEND (IPLUS NXTEND (fetch (FSB SIZE) of NXTEND)))) (RETURN (COND ((SETQ NEWFRAME (OR (\MAKEFRAME (FUNCTION \DOHELPINTERRUPT1) NXT NXTEND FRAME FRAME) (\MAKEFRAME (FUNCTION \DOHELPINTERRUPT1) (SETQ FREE (\FREESTACKBLOCK (IPLUS (PROG1 (fetch (FNHEADER STKMIN) of (fetch (LITATOM DEFPOINTER) of (FUNCTION \DOHELPINTERRUPT1))) (* ; "Stack needed to call this fn")) (PROG1 (UNFOLD 20 WORDSPERCELL) (* ; "Extra slop"))) FRAME)) (IPLUS FREE (fetch (FSB SIZE) of FREE)) FRAME FRAME))) (COND (USERFRAME (replace (IFPAGE FAULTFXP) of \InterfacePage with NEWFRAME)) (T (replace (IFPAGE TELERAIDFXP) of \InterfacePage with NEWFRAME))) (QUOTE RETURN)))))) ) (\TELERAIDGET (LAMBDA (NDB PACKET RECEIVER) (* ; "Edited 6-Jun-88 11:27 by bvm") (COND ((CL:FUNCALL RECEIVER NDB PACKET T) (SELECTC (fetch EPTYPE of PACKET) (\EPT.PUP (FLIPCURSOR) (COND ((AND (EQ (fetch PUPDESTSOCKETLO of PACKET) \PUPSOC.TELERAID) (EQ (fetch PUPDESTHOST of PACKET) (fetch NDBPUPHOST# of NDB)) (EQ (fetch PUPDESTSOCKETHI of PACKET) 0))) (T (\TELERAIDRELEASE NDB PACKET)))) (\EPT.3TO10 (COND ((AND (EQ (fetch NETTYPE OF NDB) 10) (EQ (fetch TRANSOPERATION of PACKET) \TRANS.OP.REQUEST) (EQ (fetch TRANSPUPHOST of PACKET) (fetch NDBPUPHOST# of NDB))) (* ; "It's for us") (\BLTLOCALHOSTNUMBER (LOCF (fetch BASETRANSNSHOST of PACKET))) (* ; "Add in the information he wants") (replace TRANSOPERATION of PACKET with \TRANS.OP.RESPONSE) (\10MBRAWENCAPSULATE NDB PACKET \TRANS.DATALENGTH) (* ; "Send back the response") (\10MBRAWTRANSMIT NDB PACKET) NIL) (T (* ; "Not on a 10mb net (e.g., on 3mb this packet type is IP), or not for us") (\TELERAIDRELEASE NDB PACKET)))) (\TELERAIDRELEASE NDB PACKET))))) ) (\TELERAIDSEND (LAMBDA (NDB PACKET) (* bvm%: "19-JUL-83 11:10") (* ;; "Swap the ports on PACKET and send it back where it came from") (swap (fetch PUPDESTHOST of PACKET) (fetch PUPSOURCEHOST of PACKET)) (swap (fetch PUPDESTNET of PACKET) (fetch PUPSOURCENET of PACKET)) (replace PUPDESTSOCKETHI of PACKET with (fetch PUPSOURCESOCKETHI of PACKET)) (replace PUPDESTSOCKETLO of PACKET with (fetch PUPSOURCESOCKETLO of PACKET)) (replace PUPSOURCESOCKETHI of PACKET with 0) (replace PUPSOURCESOCKETLO of PACKET with \PUPSOC.TELERAID) (replace PUPCHECKSUM of PACKET with \NULLCHECKSUM) (SELECTQ (fetch NETTYPE of NDB) (3 (swap (fetch 3MBDESTHOST of PACKET) (fetch 3MBSOURCEHOST of PACKET)) (replace 3MBLENGTH of PACKET with (IPLUS \3MBENCAPSULATION.WORDS (FOLDHI (fetch PUPLENGTH of PACKET) BYTESPERWORD))) (\3MBRAWTRANSMIT NDB PACKET)) (10 (\10MBRAWENCAPSULATE NDB PACKET (fetch PUPLENGTH of PACKET)) (\10MBRAWTRANSMIT NDB PACKET)) NIL) (FLIPCURSOR)) ) (\TELERAIDRELEASE (LAMBDA (NDB PACKET) (* bvm%: "16-JUL-83 16:42") (* ;; "Called when Teleraid is finished with PACKET, so that it can be reused for receiving") (SELECTQ (fetch NETTYPE of NDB) (10 (\10MBSETUPRECEIVER NDB PACKET)) NIL) (FLIPCURSOR) NIL) ) (\TELERAIDENTRY (LAMBDA (NDB METADEBUGGING) (* ejs%: "30-Oct-85 17:41") (* ;; "Called on entry to TeleRaid. Returns a packet receiver function") (OR METADEBUGGING (\KEYBOARDOFF)) (\BLT (fetch TROLDCURSOR of \TELERAIDBLOCK) \EM.CURSORBITMAP \#WORDS.CURSOR) (\TELEBLTCURSOR (fetch TRCURSOR of \TELERAIDBLOCK)) (COND ((AND NDB \PUP.READY) (SELECTQ (AND NDB (fetch NETTYPE of NDB)) (3 (FUNCTION \3MBRAWRECEIVE)) (10 (\10MB.TURNONETHER NDB (fetch TROLDCSB of \TELERAIDBLOCK) NIL T 0 0) (\10MBSETUPRECEIVER NDB \TELERAIDPACKET) (FUNCTION \10MBRAWRECEIVE)) NIL)))) ) (\TELERAIDEXIT (LAMBDA (NDB RESET) (* ejs%: "30-Oct-85 17:41") (* ; "Restore state for teleraid exit") (SELECTQ (AND NDB (fetch NETTYPE of NDB)) (10 (\10MB.TURNONETHER NDB NIL (fetch TROLDCSB of \TELERAIDBLOCK))) NIL) (\TELEBLTCURSOR (fetch TROLDCURSOR of \TELERAIDBLOCK)) (OR RESET (\KEYBOARDON))) ) (\3MBRAWRECEIVE (LAMBDA (NDB PACKET) (* bvm%: "12-JUL-83 19:09") (COND ((UNINTERRUPTABLY (PROG ((PBI (\READRAWPBI))) (COND (PBI (\BLT (fetch 3MBBASE of PACKET) (fetch PBIRAWSTART of PBI) (ADD1 (fetch PBILENGTH of PBI))))) (RETURN PBI))) (replace EPTYPE of PACKET with (fetch 3MBTYPE of PACKET)) PACKET))) ) (\3MBRAWTRANSMIT (LAMBDA (NDB PACKET) (* bvm%: "14-MAR-83 15:23") (* ;; "Sends raw seething etherpacket on the 3mb net denoted by NDB") (SETQ PACKET (\DTEST PACKET (QUOTE ETHERPACKET))) (UNINTERRUPTABLY (PROG ((PBI (\GETPACKETBUFFER))) (OR PBI (RETURN)) (\BLT (fetch PBIRAWSTART of PBI) (fetch 3MBBASE of PACKET) (ADD1 (fetch 3MBLENGTH of PACKET))) (\WRITERAWPBI PBI) (RETURN T)))) ) (\10MBRAWRECEIVE (LAMBDA (NDB PACKET METADEBUGGING) (* ejs%: " 6-Nov-85 22:18") (COND ((AND (EQ \MACHINETYPE \DAYBREAK) (EQ (fetch (Dove.EtherIOCB IOCBType) of \TELERAIDIOCB) DoveEther.outputIOCBType)) (\10MBSETUPRECEIVER NDB PACKET) NIL) (T (LET ((STATUS (\10MB.GETPACKETSTATUS \TELERAIDIOCB METADEBUGGING))) (COND ((EQ STATUS \ES.PENDING) (* ; "nothing received yet") NIL) ((OR (EQ STATUS \ES.GOOD.PACKET) \10MB.GETGARBAGE) (* ; "Accept the packet") (replace 10MBLENGTH of PACKET with (\10MB.GETPACKETLENGTH \TELERAIDIOCB)) (replace EPTYPE of PACKET with (fetch 10MBTYPE of PACKET)) PACKET) (T (* ; "Bad packet, stuff it back on input") (\10MBSETUPRECEIVER NDB PACKET) NIL)))))) ) (\10MBRAWTRANSMIT (LAMBDA (NDB PACKET) (* ejs%: "16-Aug-85 07:30") (\QUEUE.OUTPUT.IOCB NDB \TELERAIDIOCB (fetch 10MBPACKETBASE of PACKET) (IMAX (fetch 10MBLENGTH of PACKET) \10MB.MINPACKETLENGTH)) (* ; "And then wait until transmitted") (repeatuntil (NEQ (\10MB.GETPACKETSTATUS \TELERAIDIOCB) \ES.PENDING))) ) (\10MBRAWENCAPSULATE (LAMBDA (NDB PACKET LENGTH) (* bvm%: "16-Dec-84 22:11") (replace 10MBLENGTH of PACKET with (IPLUS \10MBENCAPSULATION.WORDS (FOLDHI LENGTH BYTESPERWORD))) (\BLT (fetch 10MBDESTHOSTBASE of PACKET) (fetch 10MBSOURCEHOSTBASE of PACKET) 3) (\BLTLOCALHOSTNUMBER (fetch 10MBSOURCEHOSTBASE of PACKET))) ) (\10MBSETUPRECEIVER (LAMBDA (NDB PACKET) (* bvm%: "14-JUL-83 13:45") (\QUEUE.INPUT.IOCB NDB \TELERAIDIOCB (fetch 10MBPACKETBASE of PACKET) \10MBPACKETLENGTH)) ) ) (RPAQ? \TELERAIDBUFFER ) (RPAQ? \TELERAIDBLOCK ) (RPAQQ \TELERAIDBITMAPS #*(16 160)@@@@@@NA@@@@@@NA@@@@@@@@IJML@@NAHOML@@NAIJML@@@@@@@@@@@@@@@@@@@@H@@@L@@@N@@@O@@@OH@@OL@@ON@@O@@@MH@@IH@@@L@@@L@@@F@@@F@@@C@@@C@@N@@@DNHNDHHHDNHNDHHHDNNN@@@@@@@@@@@@N@@@ICGFIEBENGBEJEBEIEGF@@@@@@@@@@@@@@@@@@GH@@DD@HDDALDDBJDD@HDD@HDD@HGH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@DD@@FD@HFDALEDBJED@HDL@HDL@HDD@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FDELIFMBHGMBHEEBHEEBIDEBFDEL@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@B@N@@AICBGNDJIICJIIDJIIGGG@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@A@HHA@HJMBOCADHJALHJABOBAA@@@@@@@@@@@@@@@@@@@@GHD@HDJ@H@J@HAA@HEO@GJ@H@@@@@@@@DBMOFBDDEBHDDJ@DDF@DDB@D@@@@@@@@@@@@FDJ@HJJ@LJJ@BNJLJJD@LJD@@@@@@JDN@KEB@KE@@JMF@JMB@JEL@@@@@@@@ ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \TELERAIDPACKET \TELERAIDBUFFER \TELERAIDIOCB \TELERAIDBLOCK \TELERAIDBITMAPS) ) (DECLARE%: EVAL@COMPILE (ACCESSFNS TRBLOCK ((TROLDCSB (PROGN DATUM)) (TROLDCURSOR (\ADDBASE DATUM 16)) (TRCURSOR (\ADDBASE DATUM 32)) (TRCONTROLD (\ADDBASE DATUM 48)) (TRCONTROLN (\ADDBASE DATUM 64)) (TRCOMMAND (\ADDBASE DATUM 80)) (TRRAID (\ADDBASE DATUM 96)) (TRBREAK (\ADDBASE DATUM 112)) (TRNOBREAK (\ADDBASE DATUM 128)) (TRCONTROLS (\ADDBASE DATUM 144)))) ) (DECLARE%: EVAL@COMPILE (PUTPROPS \TELEKBDWAIT MACRO [(KEY) (while [AND (XKEYDOWNP KEY) (OR (XKEYDOWNP 'BLANK-BOTTOM) (XKEYDOWNP 'CTRL] finally (RETURN (COND ((OR (XKEYDOWNP 'BLANK-BOTTOM) (XKEYDOWNP 'CTRL)) T) (T (\TELEBLTCURSOR (fetch TRCURSOR of \TELERAIDBLOCK )) NIL]) ) (DECLARE%: EVAL@COMPILE (RPAQQ \#WORDS.CURSOR 16) (CONSTANTS \#WORDS.CURSOR) ) (FILESLOAD (LOADCOMP) LLETHER 10MBDRIVER REMOTEVMEM LLFAULT) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (\TELERAIDINIT) ) (PUTPROPS TRSERVER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1315 14489 (\DOTELERAID 1325 . 1454) (\TELERAIDINIT 1456 . 2622) (\TELERAIDSERVER 2624 . 5860) (\TELEBLTCURSOR 5862 . 6042) (\TELERAIDCOMMAND 6044 . 7063) (\TELERAIDBREAK 7065 . 9189) ( \TELERAIDGET 9191 . 10209) (\TELERAIDSEND 10211 . 11162) (\TELERAIDRELEASE 11164 . 11422) ( \TELERAIDENTRY 11424 . 11988) (\TELERAIDEXIT 11990 . 12294) (\3MBRAWRECEIVE 12296 . 12606) ( \3MBRAWTRANSMIT 12608 . 12995) (\10MBRAWRECEIVE 12997 . 13683) (\10MBRAWTRANSMIT 13685 . 13998) ( \10MBRAWENCAPSULATE 14000 . 14321) (\10MBSETUPRECEIVER 14323 . 14487))))) STOP \ No newline at end of file diff --git a/sources/TTYIN b/sources/TTYIN new file mode 100644 index 00000000..88c51647 --- /dev/null +++ b/sources/TTYIN @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "24-May-91 11:33:53" |{PELE:MV:ENVOS}SOURCES>TTYIN.;6| 330378 changes to%: (FNS TTYIN TTYIN.CLEANUP TTYIN1 TTYIN1RESTART TTYIN.FINISH ADDCHAR TTADDTAB ADJUSTLINE ADJUSTLINE.AND.RESTORE BREAKLINE CHECK.MARGIN CURRENT.WORD DELETE.TO.END DELETELINE DELETETO DELETETO1 DO.EDIT.COMMAND DO.EDIT.PP FIND.LINE FIND.NEXT.WORD FORWARD.DELETE.TO GO.TO.FREELINE GO.TO.RELATIVE INSERTLINE KILLSEGMENT MOVE.TO.LINE MOVE.TO.NEXT.LINE NTH.COLUMN.OF NTH.RELATIVE.COLUMN.OF OVERFLOW? OVERFLOWLINE? PREVLINE PREVWORD READFROMBUF RENUMBER.LINES RESTOREBUF RETYPE.BUFFER SCANBACK SCANFORWARD SCRATCHCONS SEGMENT.LENGTH SEGMENT.BIT.LENGTH SETTAIL? SHOW.MATCHING.PAREN SKIP/ZAP START.NEW.LINE START.OF.PARAGRAPH? TTDELETECHAR TTDELETELINE TTDELETEWORD TTECHO.TO.FILE TTLASTLINE TTNEXTLINE TTNLEFT TTNTH TTNTHLINE TTRUBOUT TYPE.BUFFER U/L-CASE TTRATOM DO.INSERT.LINE TTADJUSTWIDTH TTYINBUFFERSTREAM TTYINBUFFERBIN TTYINBUFFERPEEK TTYINBUFFERREADP TTYINBUFFEREOFP TTYINBUFFERBACKPTR DO.MOUSE DO.SHIFTED.SELECTION DELETE.LONG.SEGMENT DELETE.LONG.SEGMENT1 INVERT.LONG.SEGMENT INVERT.SEGMENT BRACKET.CURRENT.WORD TTBEFOREPOS TTNEXTPOS TTRACKMOUSE TTYIN.LASTINPUT) previous date%: "24-May-91 10:23:44" |{PELE:MV:ENVOS}SOURCES>TTYIN.;5|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TTYINCOMS) (RPAQQ TTYINCOMS [(COMS (* ; "Main TTYIN editor") (FNS TTYIN TTYIN.SETUP TTYIN.CLEANUP TTYIN1 TTYIN1RESTART TTYIN.FINISH TTYIN.BALANCE ADDCHAR TTMAKECOMPLEXCHAR ADDNAKEDCHAR TTADDTAB ADJUSTLINE ADJUSTLINE.AND.RESTORE AT.END.OF.SCREEN AT.END.OF.TEXT AUTOCR? BACKSKREAD BACKWARD.DELETE.TO BREAKLINE BUFTAILP CHECK.MARGIN CLEAR.LINE? CURRENT.WORD DELETE.TO.END DELETELINE DELETETO DELETETO1 DO.EDIT.COMMAND DO.EDIT.PP TTDOTABS EDITCOLUMN EDITNUMBERP END.DELETE.MODE ENDREAD? FIND.LINE FIND.LINE.BREAK FIND.MATCHING.QUOTE FIND.NEXT.WORD FIND.NON.SPACE FIND.START.OF.WORD FORWARD.DELETE.TO GO.TO.ADDRESSING GO.TO.FREELINE GO.TO.RELATIVE INIT.CURSOR INSERT.NODE INSERTLINE KILL.LINES KILLSEGMENT L-CASECODE MOVE.BACK.TO MOVE.FORWARD.TO MOVE.TO.LINE MOVE.TO.NEXT.LINE MOVE.TO.START.OF.WORD MOVE.TO.WHEREVER NTH.COLUMN.OF NTH.RELATIVE.COLUMN.OF OVERFLOW? OVERFLOWLINE? PREVLINE PREVWORD PROPERTAILP READFROMBUF RENUMBER.LINES RESTORE.CURSOR RESTOREBUF RETYPE.BUFFER SAVE.CURSOR SCANBACK SCANFORWARD SCRATCHCONS SEGMENT.LENGTH SEGMENT.BIT.LENGTH SETLASTC SETTAIL? SHOW.MATCHING.PAREN SKIP/ZAP START.NEW.LINE START.OF.PARAGRAPH? TTADJUSTWORD TTBIN TTBITWIDTH TTCRLF TTCRLF.ACCOUNT TTDELETECHAR TTDELETELINE TTDELETEWORD TTECHO.TO.FILE TTGIVEHELP TTGIVEHELP1 TTGIVEHELP2 TTLASTLINE TTLOADBUF TTNEXTLINE TTNEXTNODE TTNLEFT TTNTH TTNTHLINE TTPRIN1 TTPRINSPACE TTPRIN1COMMENT TTPRIN2 TTPROMPTCHAR TTRUBOUT TTUNREADBUF TTWAITFORINPUT TTYINSTRING TYPE.BUFFER U-CASECODE U/L-CASE)) (COMS (* ; "Internal reading. These functions all expect caller to have bound *READTABLE* correctly (not bound in TTYIN for who-line transparency)") (FNS TTRATOM TTREADLIST TTSKIPSEPR TTSKREAD TTYIN.READ)) (COMS (* ; "Escape completion and friends") (FNS FIND.MATCHING.WORD TTCOMPLETEWORD WORD.MATCHES.BUFFER TTYIN.SHOW.?ALTERNATIVES)) (COMS (* ; "? and ?= handler") (FNS DO?CMD TTYIN.PRINTARGS TTYIN.READ?=ARGS DO?CMD.ERRORHANDLER)) (COMS (* ; "Display handling") (FNS BEEP BITBLT.DELETE BITBLT.ERASE BITBLT.INSERT DO.CRLF DO.DELETE.LINES DO.INSERT.LINE DO.LF ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE INSERT.TEXT TTDELSECTION TTADJUSTWIDTH TTINSERTSECTION TTSETCURSOR)) [COMS (* ; "TTYINBUFFERSTREAM") (FNS TTYINBUFFERDEVICE TTYINBUFFERSTREAM TTYINBUFFERBIN TTYINBUFFERPEEK TTYINBUFFERREADP TTYINBUFFEREOFP TTYINBUFFERBACKPTR TTYINWORDRDTBL) (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TTYINBUFFERDEVICE (TTYINBUFFERDEVICE)) (TTYINWORDRDTBL (TTYINWORDRDTBL] (COMS (* ; "Mouse handling") (FNS DO.MOUSE DO.SHIFTED.SELECTION COPY.SEGMENT DELETE.LONG.SEGMENT DELETE.LONG.SEGMENT1 INVERT.LONG.SEGMENT INVERT.SEGMENT BRACKET.CURRENT.WORD TTBEFOREPOS TTNEXTPOS TTRACKMOUSE)) (COMS (* ;; "Auxiliary fns. These are outside the TTYIN block, and are provided to aid the outside world in special interfaces to TTYIN") (FNS SETREADFN TTYINENTRYFN TTYINREADP TTYINREAD TTYINFIX CHARMACRO? TTYINMETA TTYIN.LASTINPUT) (FNS TTYINEDIT SIMPLETEXTEDIT SET.TTYINEDIT.WINDOW TTYIN.PPTOFILE) (COMS (* ;  "New, correct way of getting scratch file") (FNS MAKE-TTSCRATCHFILE) (RESOURCES TTSCRATCHFILE)) (COMS (* ;  "Obsolete, but maybe someone calls it") (FNS TTYIN.SCRATCHFILE \TTYIN.RPEOF) (INITVARS (TTYINEDIT.SCRATCH))) (INITVARS (TTYINEDITWINDOW) (TTYINEDITPROMPT T) (TTYINAUTOCLOSEFLG) (TTYINPRINTFN) (TTYIN?=FN))) [COMS (* ; "Kludge of the week") (FNS TTYINPROMPTFORWORD) (INITVARS (TTYIN.USE.EXACT.CHARS)) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;  "This is so that you can (MOVD 'TTYINPROMPTFORWORD 'PROMPTFORWORD) and not die") (P (MOVD? 'PROMPTFORWORD 'NON-TTYIN-PROMPTFORWORD NIL T] (DECLARE%: DOEVAL@COMPILE DONTCOPY (COMS * TTCOMPILETIME)) (INITVARS (DORADO.RESTORE.BUF.CODES '(194)) (TTYIN.RESTORE.BUF.CODES '(516 530)) (TTYINBUFFER) (?ACTIVATEFLG T) (EDITPREFIXCHAR) (SHOWPARENFLG T) (TTYINBSFLG T) (\TTYIN.LAST.FONT) (\TTYIN.LAST.COMMENTFONT) (TTYINFILLDEFAULT T) (TTYINCOMPLETEFLG T) (TTYINUSERFN) (TYPEAHEADFLG T) (null "") (DEFAULTPROMPT "** ") (TTYJUSTLENGTH -1) (\INSIDE.TTYIN) (TTYINERRORSETFLG) (TTYINRAISEFLG T) (TTYINAUTOFILLMARGIN 8) (TTYINFIXLIMIT 50) (TTYINDEBUGFLG) (HISTSTR1 "from file:") (TTYINCOMMENTCHAR) (\RESTOREBUFCODES)) (P (MOVD? 'NILL 'GUESTUSER?) (MOVD? 'FIXSPELL 'FIXSPELL!!) (MOVD? 'HELPSYS 'XHELPSYS) [PUTDQ? SPRINTT (LAMBDA (X) (PRIN1 X] (MOVD? 'NILL 'WINDOWWORLD) (MOVD? 'LISPXFIX 'NONTTYINLISPXFIX)) (ADDVARS (TTYINREADMACROS) (TTYINRESPONSES) (LISPXCOMS (STOP . OK)) (\SYSTEMCACHEVARS \RESTOREBUFCODES)) (PROP VARTYPE TTYINREADMACROS) [DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND ((CCODEP 'TTYIN) (CHANGENAME 'PROMPTCHAR 'LISPXREADP 'TTYINREADP) (SETREADFN) (MOVD 'TTYINFIX 'LISPXFIX] (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML CHARMACRO?) (LAMA]) (* ; "Main TTYIN editor") (DEFINEQ (TTYIN [LAMBDA (PROMPT SPLST HELP OPTIONS ECHOTOFILE TABS UNREADBUF RDTBL) (* ; "Edited 24-May-91 10:39 by jds") (DECLARE (SPECVARS SPLST HELP OPTIONS ECHOTOFILE TABS UNREADBUF RDTBL)) (* ;;; "TTYIN is a general input function. See TTYIN.DOC for details on the arguments and use of this fn. TTYIN was designed and implemented by Bill van Melle in the late 1970's at Stanford. ") (* ;;; "The bulk of the code here was oriented toward smart use on display terminals from remote machines, and then hacked to get it to work in windows in Interlisp-D. As such, there are a large number of fairly obsolete crocks in the code.") (* ;;; "The most important terminal at the time was the datamedia. If on a dm, TTYIN puts the terminal in binary mode so it can read the 200q bit supplied by the EDIT key. Most of the cursor-moving commands from TVEDIT are available or slightly modified, and a few extra are supplied as well.") (* ;;; "The text being typed in is represented as a list of character codes, with a data structure on top of it which partitions it by line. Thus, you can view the text as one string, or broken into lines, depending on the function desired. \BUFFER is the pointer to the start of the buffer, \ENDBUFFER points one past the end. TTYIN saves up cons cells between calls and reuses them; \ENDBUFFER points to this list of free cells. TTYINBUFFER is the master record, which keeps assorted global information about where the cursor is, and saves some state info from one call to the next, enabling the restore previous buffer command. One of the fields points to the LINE records which describe the two-dimensional structure of the input. Each record points to the region of the buffer containing the text for one line, and has fields indicating the first and last columns, and a pointer to the next line record. \ARROW always points to the current LINE record --- \CURSOR points to where in the buffer the cursor appears. --- This representation is not terribly space-efficient for large buffers, but it is easily manipulated, and fast. If there is a particularly long input, there will be many cons cells tied up in TTYINBUFFER, so a good thing to do when trying to free up space is reset TTYINBUFFER to NIL to force its regeneration from scratch.") (RESETLST (PROG ((\INSIDE.TTYIN T) (\AUTOFILL TTYINFILLDEFAULT) (\DSP (TTYDISPLAYSTREAM)) (\FIRSTTIME T) (\INITCRLFS 0) (\RAISEINPUT (OR TTYINRAISEFLG (fetch RAISEFLG of \PRIMTERMTABLE))) (\TTYINSTATE TTYINBUFFER) (TYPEAHEAD TYPEAHEADFLG) \ARROW \BMARG \BUFFER \CHARHEIGHT \CHARWIDTH \COMMAND \COMMENTFONT \CURSOR \CURSORCOL \CURSORROW \DELETING \DESCENT \DONTCOMPLETE \ENDBUFFER \FILLINGBUFFER \FIRSTLINE \FIX \FONT \HOMECOL \HOMEROW \INITPOS \LAST.DELETION \LASTAIL \LASTAILCOL \LASTAILROW \LASTCHAR \LISPXREADING \LMARG \LOC.ROW.0 \NOFIXSPELL \NOVALUE \PFW.FIRSTTIME \PROMPT1 \PROMPT2 \PROMPTFORWORD \RDTBLSA \READING \REPEAT \RMARG \STRINGVALUE \TEXTURE \TTPAGELENGTH \TTYINBUFFERSTREAM VALUE) (SETQ TTYINBUFFER) (* ;  "Global resource. Any ttyin calls while we are running need to create their own") [OR (LISTP \TTYINSTATE) (SETQ \TTYINSTATE (create TTYINBUFFER FIRSTLINE _ (create LINE START _ (CONS 0) ROW _ 0] [COND ((AND SPLST (NLISTP SPLST)) (SETQ SPLST (CONS SPLST] (for OP inside OPTIONS do (SELECTQ OP ((NOFIXSPELL MUSTAPPROVE CRCOMPLETE) (SETQ \NOFIXSPELL (SETQ \DONTCOMPLETE OP ))) (\NOVALUE (SETQ \NOVALUE OP)) (STRING (SETQ \STRINGVALUE OP)) (COMMAND (SETQ \COMMAND OP)) (REPEAT (SETQ \REPEAT OP)) (NORAISE (SETQ \RAISEINPUT)) (RAISE (SETQ \RAISEINPUT T)) (TEXT (SETQ \REPEAT (SETQ \NOVALUE (SETQ \AUTOFILL OP))) (SETQ \RAISEINPUT)) (FIX (SETQ \FIX OP)) (READ (SETQ \READING (SETQ \AUTOFILL OP))) (LISPXREAD [SETQ TYPEAHEAD (SETQ \LISPXREADING (SETQ \READING (SETQ \AUTOFILL OP] (SETQ \RAISEINPUT (fetch RAISEFLG of \PRIMTERMTABLE ))) (EVALQT (* ;  "like LISPXREAD, but with added proviso about checking for EVALQT right-bracket hacks") [SETQ TYPEAHEAD (SETQ \LISPXREADING (SETQ \READING (SETQ \AUTOFILL OP] (SETQ \RAISEINPUT (fetch RAISEFLG of \PRIMTERMTABLE ))) (TYPEAHEAD (SETQ TYPEAHEAD OP)) (FILLBUFFER (SETQ \FILLINGBUFFER OP)) (NOPROMPT (SETQ \FIRSTTIME OP)) ((PROMPTFORWORD PROMPTFORWORD-SPACE) (* ; "For faking PROMPTFORWORD") (SETQ \PROMPTFORWORD (SETQ \STRINGVALUE OP)) (SETQ \PFW.FIRSTTIME UNREADBUF) (* ;  "Flag that says to erase the line if user types something other than , etc.") (SETQ \RAISEINPUT NIL)) NIL)) [SETQ \RDTBLSA (fetch READSA of (SETQ RDTBL (COND ((AND (NOT \READING) (NULL RDTBL)) (* ;  "Use the word table, rather than a Lispish table") (\DTEST TTYINWORDRDTBL 'READTABLEP)) (T (\GTREADTABLE RDTBL] (TTYIN.SETUP) (* ;  "Setup window, including fonts. Didn't do this til now since it uses \READING.") [COND ((EQ PROMPT T) (SETQ \PROMPT1 (SETQ \PROMPT2))) (T [COND ((NOT PROMPT) (SETQ PROMPT DEFAULTPROMPT)) [(LISTP PROMPT) (COND ((NLISTP (CDR PROMPT)) (* ;  "User has already supplied us with a dotted pair of prompts") (SETQ \PROMPT1 (CAR PROMPT)) (SETQ \PROMPT2 (CDR PROMPT))) (T (SETQ PROMPT (SUBSTRING PROMPT 2 -2] ((AND (NOT (STRINGP PROMPT)) (NOT (LITATOM PROMPT))) (SETQ PROMPT (MKSTRING PROMPT] (COND ((NLISTP PROMPT) (* ; "Now create 2 prompts out of one") (SETQ \PROMPT1 PROMPT) (SETQ \PROMPT2 (COND ((OR \LISPXREADING \PROMPTFORWORD) (* ;  "Don't use a secondary prompt for LISPX or PROMPTFORWORD") NIL) ((AND \REPEAT (< (NCHARS PROMPT) 12)) (* ;  "Okay to use this short prompt as a secondary prompt") PROMPT) (T '|...|] (COND ((NOT SPLST) (SETQ \DONTCOMPLETE T))) (COND (\READING (SETQ \REPEAT))) (COND ((NOT TYPEAHEAD) (CLEARBUF T))) LP (SETQ VALUE (NLSETQ (TTYIN1))) (COND ((NOT VALUE) (* ; "NLSETQ aborted. Try again.") (COND ((OR (NOT TTYINERRORSETFLG) \LISPXREADING) (* ;  "LISPXREAD is not errorset-protected, so why should this be?") (COND (\CURSORCOL (* ;  "If this is NIL, then we haven't initialized enough to go anywhere") (GO.TO.FREELINE))) (RESTOREMOD) (COND ((NEQ \BUFFER \ENDBUFFER) (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with \ENDBUFFER)) ) (ERROR!))) (GO LP))) (COND ((AND (NEQ \BUFFER \ENDBUFFER) (> (add (fetch (TTYINBUFFER STORAGECOUNTER) of \TTYINSTATE) 1) 10)) (* ;  "Release some storage, since it seems to accumulate and fragment") (replace (TTYINBUFFER STORAGECOUNTER) of \TTYINSTATE with 0) (FRPLACD \ENDBUFFER))) (SETQ VALUE (CAR VALUE)) (POSITION T 0) [COND ((AND CTRLUFLG (NEQ VALUE T)) (* ; "user typed ^U to edit input") (SETQ CTRLUFLG) (PROG ((\INSIDE.TTYIN)) (COND ((OR (LITATOM VALUE) (GUESTUSER?)) (* ; "guests may not edit") ) ((LISTP VALUE) (EDITE VALUE)) (T (SETQ VALUE (CAR (EDITE (LIST VALUE) '(REPACK] (COND ((AND TTYINMAILFLG (NEQ \READING 'EVALQT)) (* ; "Note time of last user input") (MWNOTE))) (RETURN VALUE)))]) (TTYIN.SETUP [LAMBDA NIL (* ; "Edited 19-Jan-88 01:51 by bvm") (* ;  "Disable buttons so we can do selection") [LET ((WINDOW (WFROMDS \DSP T))) (COND (WINDOW (replace (TTYINBUFFER TTOLDRIGHTFN) of \TTYINSTATE with (WINDOWPROP WINDOW 'RIGHTBUTTONFN 'TOTOPW)) (replace (TTYINBUFFER TTOLDBUTTONFN) of \TTYINSTATE with (WINDOWPROP WINDOW 'BUTTONEVENTFN 'TOTOPW)) (replace (TTYINBUFFER TTOLDENTRYFN) of \TTYINSTATE with (WINDOWPROP WINDOW 'WINDOWENTRYFN 'TTYINENTRYFN)) (replace (TTYINBUFFER TTYINWINDOW) of \TTYINSTATE with WINDOW) (WINDOWPROP WINDOW 'TTYINSTATE (fetch (TTYINBUFFER TTYINWINDOWSTATE) of \TTYINSTATE)) (RESETSAVE NIL (LIST (FUNCTION TTYIN.CLEANUP) \TTYINSTATE] (COND ((OR (IMAGESTREAMTYPEP \DSP 'TEXT) (FMEMB (DSPDESTINATION NIL \DSP) \SCREENBITMAPS)) (SETQ \CHARWIDTH (CHARWIDTH (CHARCODE A) \DSP)) (SETQ \FONT (DSPFONT NIL \DSP)) (if (EQ \FONT \TTYIN.LAST.FONT) then (SETQ \COMMENTFONT \TTYIN.LAST.COMMENTFONT) elseif \READING then (* ; "Want a %"comment%" font for ?=") [SETQ \COMMENTFONT (SETQ \TTYIN.LAST.COMMENTFONT (FONTCOPY \FONT 'WEIGHT (SELECTQ (FONTPROP \FONT 'WEIGHT) (BOLD 'MEDIUM) 'BOLD] (SETQ \TTYIN.LAST.FONT \FONT) else (SETQ \COMMENTFONT \FONT)) (SETQ \CHARHEIGHT (MAX (FONTHEIGHT \FONT) (FONTHEIGHT \COMMENTFONT))) (SETQ \DESCENT (FONTPROP \FONT 'DESCENT)) (* ;  "How many pixels below the baseline this font goes") (SETQ \TEXTURE (DSPTEXTURE NIL \DSP)) (SETQ \TTPAGELENGTH (PAGEHEIGHT NIL \DSP)) (SETQ \LMARG (DSPLEFTMARGIN NIL \DSP)) (* ; "bit pos of left margin") (SETQ \RMARG (DSPRIGHTMARGIN NIL \DSP)) (* ;  "bit pos of right margin, dsp relative") (SETQ \INITPOS (DSPXPOSITION NIL \DSP]) (TTYIN.CLEANUP [LAMBDA (\TTYINSTATE) (* ; "Edited 24-May-91 10:39 by jds") (PROG ((WINDOW (fetch (TTYINBUFFER TTYINWINDOW) of \TTYINSTATE))) (COND (WINDOW (WINDOWPROP WINDOW 'RIGHTBUTTONFN (fetch (TTYINBUFFER TTOLDRIGHTFN) of \TTYINSTATE)) (WINDOWPROP WINDOW 'BUTTONEVENTFN (fetch (TTYINBUFFER TTOLDBUTTONFN) of \TTYINSTATE)) (WINDOWPROP WINDOW 'WINDOWENTRYFN (fetch (TTYINBUFFER TTOLDENTRYFN) of \TTYINSTATE)) (WINDOWPROP WINDOW 'TTYINSTATE NIL))) (SETQ TTYINBUFFER \TTYINSTATE]) (TTYIN1 [LAMBDA NIL (* ; "Edited 24-May-91 10:33 by jds") (* ;;; "The main moby subfn of TTYIN. Is errorset protected in caller") (PROG ((DRIBFL (DRIBBLEFILE)) CHAR MATCHED RESULT STARTOFWORD X TMP WASEDITCHAR SNX) (COND ((SETQ CHAR (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD)) (* ; "Handle peeked char") [COND ((AND (OR (NULL \PROMPT1) (EQ \FIRSTTIME 'NOPROMPT)) (OR T (fetch (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD)) (>= CHAR (CHARCODE SPACE))) (* ;; "Want to avoid echoing peeked char twice. Only feasible to do so if we were called with no prompt, implying that there is some hope that the preceding char on the line is the peeked char") (SETQ X (FCHARWIDTH CHAR \FONT)) (DSPBACKUP X \DSP) (SETQ \INITPOS (- \INITPOS X] (replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL))) (SETQ \LASTAIL) RESTART PROMPT0 (TTYIN1RESTART) (COND ((NOT \FIRSTTIME) (* ; "Space over to where we started") (GO.TO.ADDRESSING \INITPOS 0))) (SETQ RESULT NIL) PROMPT1 (INIT.CURSOR \INITPOS) (COND [(AND (EQ \FIRSTTIME 'NOPROMPT) \PROMPT1) (* ;  "Prompting has already happened; account for it") (COND ((< (SETQ X (- \INITPOS (STRINGWIDTH \PROMPT1 \FONT))) \LMARG) (* ;; "Caller is confused; prompt couldn't have fit. Typically happens when LISPXREAD is called by other than LISPX") (SETQ \PROMPT1)) (T (SETQ \INITPOS X] (T (TTPROMPTCHAR \ARROW))) (replace (LINE FIRSTCOL) of \ARROW with (replace (LINE LASTCOL) of \ARROW with \CURSORCOL)) [COND ([OR (NLISTP TABS) (NOT (SMALLP (CAR TABS] (SETQ TABS)) ((NOT (> (ITIMES (SUB1 (CAR TABS)) \CHARWIDTH) \CURSORCOL)) (* ;; "Caller specified first tabstop as the position of the first char; we don't treat that as a tabstop, so peel it off") (SETQ TABS (CDR TABS] (COND [UNREADBUF (* ;  "something to preload buffer with") (COND ((FIXP UNREADBUF) (SETQ CHAR UNREADBUF) (* ;  "interpret number as character code of something to type ahead, usually altmode") (SETQ UNREADBUF NIL) (GO SELECTCHAR)) (T (WITH-RESOURCES (TTSCRATCHFILE) (TTLOADBUF (PROG1 (COND ((EQMEMB 'PRETTY OPTIONS) (* ;;  "We were told to pretty-print the FIXed form, so have to use a temp file.") (* ;;  "Pass TTLOADBUF a list ( (file start . end)).") (LIST HISTSTR1 (TTYIN.PPTOFILE (COND ((EQ (CAR (SETQ X (LAST UNREADBUF))) HISTSTR0) (* ;  "knock off the terminating marker") (LDIFF UNREADBUF X)) (T UNREADBUF)) 'PRETTY RDTBL TTSCRATCHFILE))) (T (* ;  "Not pretty printing; just pass TTLOADBUF the form to FIX.") UNREADBUF)) (SETQ UNREADBUF NIL) (SETFILEPTR TTSCRATCHFILE 0))] (\FIRSTTIME (* ;; "(for FORM in AFTERPROMPTCHARFORMS bind REFRESH when (EVAL FORM) do (SETQ REFRESH T) (* User forms to do after prompt is printed but before we do anything more. If one returns T, means it altered the display) finally (COND (REFRESH (SETQ \FIRSTTIME) (GO PROMPT1))))") )) (SETQ \FIRSTTIME) (COND (CHAR (GO SELECTCHAR))) CHAR (AND CHAR (SETQ \LASTCHAR CHAR)) (SETQ CHAR (TTBIN)) SELECTCHAR [COND ([AND (SETQ X (FASSOC CHAR TTYINREADMACROS)) (OR [NLISTP (SETQ X (CDR (SETQ TMP X] (AND (COND ((EQ (CAR X) T) (EMPTY.BUFFER)) ((LISTP (CAR X)) (EVAL (CAR X))) (T (* ;  "Old style macros that worked only at start of buffer") (SETQ X TMP) (EMPTY.BUFFER))) (OR (NLISTP (SETQ X (CDR X))) (SETQ X (EVAL X] (* ;; "Simple read macros: if you type the char on a blank line, and the macro returns something, use it as the value of the READ (or whatever)") (COND [(FIXP X) (* ;  "Special: means pretend this CHARACTER code was typed") (SELECTQ X (0 (* ; "No action") (GO CHAR)) (-1 (* ;  "Means refresh line, because terminal control was taken away") (SETQ CHAR NIL) (GO PROMPT1)) (COND ((METACHARP (SETQ CHAR X)) [COND ((EQ (NONMETACHARBITS X) 0) (* ; "another way to get edit prefix") (SETQ CHAR (METACHAR (TTBIN T] T] ((EMPTY.BUFFER) (* ;  "For now I'm not handling funny results in the middle") (SETQ RESULT (OR (LISTP X) (LIST X))) (GO DOCRLF] (COND ((NOT (METACHARP CHAR)) (SETQ WASEDITCHAR NIL)) ([NOT (SETQ CHAR (DO.EDIT.COMMAND (NONMETACHARBITS CHAR] (GO CHAR)) (T (* ;  "Fall thru if edit char gave us something to chomp on") (SETQ WASEDITCHAR T))) [COND ((SELECTC (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA CHAR)) (CHARDELETE.TC (TTDELETECHAR) T) (LINEDELETE.TC (TTDELETELINE) T) (WORDDELETE.TC (TTDELETEWORD) T) (RETYPE.TC (* ; "^R retype") (SETQ \PFW.FIRSTTIME NIL) [RETYPE.BUFFER (COND ((OR (ON.FIRST.LINE) (NOT (EMPTY.LINE))) \ARROW) (T (* ;  "If sitting on empty line, refresh the previous line") (PREVLINE \ARROW 1] (COND ((EQ CHAR (SETQ CHAR (TTBIN))) (* ;  "two ^R's means retype whole buffer") (OR DISPLAYTERMFLG (TTCRLF)) (* ;  "set off full retype by double line") (RETYPE.BUFFER \FIRSTLINE T)) (T (GO SELECTCHAR))) T) NIL) (* ;  "Did some routine editing command. This cancels promptforword kill mode") (SETQ \PFW.FIRSTTIME NIL)) ((PROGN (SETQ SNX (\SYNCODE \RDTBLSA CHAR)) (AND \FILLINGBUFFER (EQ (fetch WAKEUP of SNX) IMMEDIATE.RMW) (AT.END.OF.TEXT \CURSOR))) (* ;  "Immediate read macro--return now") (GO DOCRLF)) (T (if \PFW.FIRSTTIME then (* ; "The only non-meta characters that accept the input are cr, space and the hard-wired editing commands (which we have mostly covered already)") (SELCHARQ CHAR ((CR SPACE ^X ^A BS RUBOUT ^Q ^U ^W)) (PROGN (* ;  "Kill the entire input (could be more than one line if long input or long prompt)") (MOVE.TO.LINE \FIRSTLINE) (DELETE.TO.END))) (SETQ \PFW.FIRSTTIME NIL)) (COND ((AND (fetch STOPATOM of SNX) (NOT \DONTCOMPLETE)) (* ; "End of atom, try completion") (TTCOMPLETEWORD T))) (SELECTC SNX ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ;; "Right paren/bracket. See if it terminates read. Note that \READING is implicitly true here, since there are no parens in the word rdtbl") (SETQ STARTOFWORD \CURSOR) (ADDCHAR CHAR) (COND ((ENDREAD?) (GO DOCRLF)) ((AND SHOWPARENFLG T (NOT (TYPEAHEAD?))) (* ;  "prime conditions for hack to show which paren it matched") (SHOW.MATCHING.PAREN STARTOFWORD)))) (SELECTC CHAR ((CHARCODE ESCAPE) [COND (SPLST (* ;  "try to complete from spelling list") (OR (TTCOMPLETEWORD) (BEEP))) [(AND TTYINCOMPLETEFLG \LISPXREADING) (* ;; "always try to complete") (COND ((SETQ STARTOFWORD (CURRENT.WORD)) (SETQ MATCHED (FIND.MATCHING.WORD USERWORDS STARTOFWORD))) ((NEQ TTYINCOMPLETEFLG 0) (* ;; "naked escape stands for LASTWORD. ") (SETQ MATCHED (LIST LASTWORD)) LASTWORD)) (SETQ CHAR DIDESCAPECODE) (* ; "Kludge used by ? routine below") (COND (MATCHED (OR (TTCOMPLETEWORD NIL NIL MATCHED (OR STARTOFWORD \CURSOR)) (BEEP))) (T (BEEP] (T (* ; "no special significance") (ADDNAKEDCHAR (CHARCODE ESCAPE]) ((CHARCODE (%" *)) (ADDCHAR CHAR) (TTDOTABS TABS)) ((CHARCODE TAB) (OR (TTDOTABS TABS) (TTADDTAB))) ((CHARCODE SPACE) (if (AND (EQ \PROMPTFORWORD 'PROMPTFORWORD-SPACE) (AT.END.OF.TEXT \CURSOR)) then (* ; "Space completes") (GO DOCRLF)) (OR (AUTOCR?) (ADDCHAR CHAR))) ((CHARCODE ?) (* ; "supply alternative completions") (TTYIN.SHOW.?ALTERNATIVES)) ((CHARCODE CR) (* ; "terminate line") [COND ((NOT WASEDITCHAR) (* ; "i.e. not edit-CR") (* ; "Check for ? and ?= macros") (PROG ((START (fetch (LINE START) of \ARROW)) TAIL) (COND ((EQ \CURSOR START) (RETURN))) (SETQ TAIL (NLEFT START 1 \CURSOR)) (* ; "Look at last char on line") (SELCHARQ (CAR TAIL) (? (COND ((AND (DEFINEDP 'XHELPSYS) [OR (EQ TAIL START) (BREAK.OR.SEPRP (FIRSTCHAR (NLEFT START 1 TAIL] (DO?CMD '? TAIL)) (GO CHAR)))) (= (COND ((AND (NEQ TAIL START) (EQ (CAR (SETQ TAIL (NLEFT START 1 TAIL))) (CHARCODE ?)) [OR (EQ TAIL START) (BREAK.OR.SEPRP (FIRSTCHAR (NLEFT START 1 TAIL] (DO?CMD '?= TAIL)) (GO CHAR)))) NIL)) (COND ((NOT (AT.END.OF.TEXT \CURSOR)) (COND ((OR \REPEAT \READING) (* ;  "Insert a and continue reading") (BREAKLINE EOLCHARCODE) (GO CHAR)) (T (* ;  " typed here would terminate, so unread what's left") (TTUNREADBUF] (COND [(NOT (AT.END.OF.BUF)) (COND ((ON.LAST.LINE) (SETQ \CURSOR \ENDBUFFER)) ((AND \READING (NOT \PROMPT2) (AT.END.OF.TEXT (fetch (LINE END) of \ARROW))) (* ;; "Really the same condition as previous clause: there are lines after this one, but they're blank, so it looks like we're on the last line") (MOVE.FORWARD.TO (fetch (LINE END) of \ARROW)) (* ;  "have to make the extra stuff go away so the finishing routines are happy") (DELETE.TO.END)) (T (DO.EDIT.COMMAND (CHARCODE CR)) (* ;  "CR on other than last line just means go down one") (GO CHAR] ((OR (NOT \DONTCOMPLETE) (EQ \DONTCOMPLETE 'CRCOMPLETE)) (TTCOMPLETEWORD T))) (COND ((COND (\READING (TTSKREAD \BUFFER)) [\REPEAT (AND (ON.FIRST.LINE) (OR (EQ (CAR \BUFFER) TTYINCOMMENTCHAR) (AND \COMMAND (EQ (FIND.NEXT.WORD (FIND.NON.SPACE \BUFFER) ) \ENDBUFFER] (T T)) (* ;  "Terminating conditions: no REPEAT, or first line is a comment or has a single command on it") (SETQ CTRLVFLG (SETQ RESULT)) (SETQ CHAR (CHARCODE EOL)) (* ;  "Lisp likes to treat cr as (choke) EOL") (GO DOCRLF)) (T (START.NEW.LINE EOLCHARCODE)))) ((CHARCODE ^X) (* ; "Maybe exit") (COND ((COND (\READING (* ;  "return if parens balance. If already at end, add enough parens to balance") (TTYIN.BALANCE T (AT.END.OF.TEXT \CURSOR))) (T (* ;  "Taking string input, etc--finish now") (MOVE.TO.WHEREVER \ENDBUFFER) T)) (SETQ CHAR (CHARCODE EOL)) (GO DOCRLF)))) ((CHARCODE ^V) (COND ((NEQ \REPEAT 'TEXT) (* ; "Means enter control char") (SETQ CHAR (TTBIN)) (ADDNAKEDCHAR (if (EQ CHAR (CHARCODE ?)) then (* ;  "This is the only way to get a rubout") (SETQ CHAR (CHARCODE RUBOUT)) elseif (>= CHAR (CHARCODE @)) then (* ;  "Change alphabetics to corresponding control char") (SETQ CHAR (LOGAND CHAR 31)) else (* ; "take exact char") CHAR))) ((AT.END.OF.BUF) (* ;  "terminate multiline input and set special flag") (SETQ CTRLVFLG T) (TTBOUT ^ V) (GO DOCRLF)) (T (BEEP)))) ((CHARCODE ^Z) (* ; "^Z terminates multiline input") (COND ((AND \REPEAT (AT.END.OF.BUF)) (TTBOUT ^ Z) (SETQ CTRLVFLG) (GO DOCRLF)) (\READING (ADDNAKEDCHAR CHAR)) (T (BEEP)))) ((CHARCODE ^Y) (* ; "^Y invokes user exec") (COND ((AND \READING (NOT WASEDITCHAR)) (* ; "let ^Y read macro work instead") (ADDNAKEDCHAR CHAR)) ((GUESTUSER?) (BEEP)) (T (SETTAIL?) (SAVE.CURSOR) (GO.TO.FREELINE) (COND (DRIBFL (* ; "Make typescript understandable") (AND \PROMPT1 (PRIN1 \PROMPT1 DRIBFL)) (PRINT '^Y DRIBFL))) (PRIN1 "lisp: " T) (COND (TTYINMAILFLG (MWNOTE))) (RESTOREMOD) (PROG ((\INSIDE.TTYIN)) (USEREXEC '__)) (GO RETYPEBUFFER)))) (0 (* ; "ignore NULL")) ((CHARCODE (^A BS RUBOUT)) (TTDELETECHAR)) ((CHARCODE (^Q ^U)) (* ; "^Q delete line; ^U on tops20") (TTDELETELINE)) ((CHARCODE ^W) (* ; "^W delete last word") (TTDELETEWORD)) (COND ([MEMB CHAR (OR \RESTOREBUFCODES (SETQ \RESTOREBUFCODES (APPEND (AND (EQ (MACHINETYPE) 'DORADO) DORADO.RESTORE.BUF.CODES) TTYIN.RESTORE.BUF.CODES] (* ;; "One of the characters we interpret as %"restore last buffer%". Recomputed after exit in case we change machine. The dorado code is a perfectly good charset 0 code, so don't usually want to usurp it.") (RESTOREBUF)) [(> CHAR 32) (* ; "not a control char") (ADDCHAR (COND (\RAISEINPUT (U-CASECODE CHAR)) (T CHAR] (T (ADDNAKEDCHAR CHAR] (GO CHAR) RETYPEBUFFER (RETYPE.BUFFER \FIRSTLINE T T) (GO CHAR) DOCRLF (* ;; "Come here when it is time to terminate line") (COND ((EQ (SETQ RESULT (TTYIN.FINISH CHAR DRIBFL RESULT)) 'ABORT) (* ; "Aborted, try again") (SETQ CHAR NIL) (GO PROMPT0)) (T (RETURN RESULT]) (TTYIN1RESTART [LAMBDA NIL (* ; "Edited 24-May-91 10:39 by jds") (\RESETLINE) (* ;  "clear some terminal-related stuff, including the info about where to hold scroll") (\SETEOFPTR \LINEBUF.OFD 0) (* ; "Clear the line buffer") (SETQ \ARROW (SETQ \FIRSTLINE (fetch (TTYINBUFFER FIRSTLINE) of \TTYINSTATE))) [replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \BUFFER (SETQ \ENDBUFFER (fetch (LINE START) of \ARROW] [PROG ((MORELINES (fetch (LINE NEXTLINE) of \ARROW))) (COND (MORELINES (* ;  "Return old line records to cons pool") (replace (LINE NEXTLINE) of \ARROW with NIL) (KILL.LINES MORELINES] (SETQ \DELETING]) (TTYIN.FINISH [LAMBDA (FINALCHAR DRIBFL RESULT) (* ; "Edited 24-May-91 10:39 by jds") (PROG ((*READTABLE* RDTBL) WORD X ORIGBUFFER) (COND ((NOT \PROMPTFORWORD) (* ;  "Go to new line. Fake promptforword mode doesn't do this.") (TTCRLF) (CLEAR.LINE? T))) [COND ((EQ FINALCHAR (CHARCODE EOL)) (bind TAIL (START _ (fetch (LINE START) of \ARROW)) while (AND (NEQ START \ENDBUFFER) (EQ (CAR (SETQ TAIL (TTNLEFT \ENDBUFFER 1 START))) (CHARCODE SPACE)) (NEQ (\SYNCODE \RDTBLSA (FIRSTCHAR (TTNLEFT TAIL 1 START))) ESCAPE.RC)) do (* ;; "Strip blanks, e.g., resulting from escape completion, so that Lispx does not do its silly ... thing. Be careful not to strip a quoted space") (SETQ \ENDBUFFER TAIL] (COND (DRIBFL (* ; "print answer on typescript file") (TTECHO.TO.FILE DRIBFL T))) (for X inside ECHOTOFILE do (TTECHO.TO.FILE X)) (COND [(EMPTY.BUFFER) (* ;  "blank line. RESULT is NIL unless set above by a read macro") (COND ((OR RESULT (EQ FINALCHAR (CHARCODE EOL))) (SETLASTC (CHARCODE EOL)) (RETURN RESULT] ((EQ (CAR \BUFFER) TTYINCOMMENTCHAR) (* ; "comment") (RETURN 'ABORT)) ((AND (EQ (CDR \BUFFER) \ENDBUFFER) (EQ (CAR \BUFFER) (CHARCODE ?)) (OR HELP (AND \NOVALUE \REPEAT))) (* ; "a bare ?") (TTGIVEHELP (OR HELP "Terminate text with control-Z.")) (RETURN 'ABORT)) (T (* ;  "Save last buffer position for posterity") (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with \ENDBUFFER))) (SETQ ORIGBUFFER \BUFFER) [COND [\READING (SETQ RESULT (COND (\FILLINGBUFFER (TTYIN.READ FINALCHAR T \LINEBUF.OFD)) (T (TTYIN.READ FINALCHAR NIL (TTYIN.SCRATCHFILE] ((AND HELP (FIND.MATCHING.WORD '(? HELP) \BUFFER \ENDBUFFER)) (TTGIVEHELP HELP) (* ; "help handled; now restart ") (RETURN 'ABORT)) ((AND \STRINGVALUE (NOT \COMMAND)) (* ;  "Return input as string, no other special interpretation") (SETQ RESULT (TTYINSTRING ORIGBUFFER))) (T (SETQ WORD (TTRATOM)) [for RESPONSE in TTYINRESPONSES when (AND (EQMEMB WORD (CAR RESPONSE)) (OR (EQ \BUFFER \ENDBUFFER) (CADDR RESPONSE))) do (* ;; "Process global user option. RESPONSE is a triple (commands response-form rest-of-line-arg); if user gives one of the commands, the response form is evaluated with \COMMAND set to the command and LINE set to the remainder of the line; the third component says how to compute LINE: as a STRING or as a LIST; if NIL, means there should be nothing else on the line. If the response form returns the atom IGNORE, the input is not considered to be a special response and the normal computation proceeds; otherwise it is assumed the response has been processed, and we return to the original TTYIN prompt for more input. Response-form may be an atom, in which case it is APPLYed to \COMMAND and LINE.") (COND ((NEQ [PROG [(\COMMAND WORD) (\BUFFER \BUFFER) (LINE (COND ((EQ \BUFFER \ENDBUFFER) NIL) ((EQ (CADDR RESPONSE) 'STRING) (TTYINSTRING \BUFFER)) (T (TTREADLIST] (DECLARE (SPECVARS \COMMAND \BUFFER LINE)) (RETURN (COND ((LITATOM (CADR RESPONSE)) (APPLY* (CADR RESPONSE) \COMMAND LINE)) (T (EVAL (CADR RESPONSE] 'IGNORE) (RETFROM 'TTYIN.FINISH 'ABORT)) (T (* ;; "That response was ignored. We could quit the iteration now, but continue in case there is another entry with the same command. I.e. user can 'redefine' special responses this way, but still let the old definition happen if the input looks wrong") ] [SETQ WORD (COND ((TTADJUSTWORD WORD)) ((AND (NULL WORD) (NULL SPLST)) (* ;  "NIL is acceptable response, so don't abort!") NIL) (T (RETURN 'ABORT] [SETQ RESULT (COND [(EQ \BUFFER \ENDBUFFER) (COND (\COMMAND (LIST WORD)) (\NOVALUE T) (T (LIST WORD] (\STRINGVALUE (* ;  "return (command . string). Note that if \command is false, we handled it much earlier") (CONS WORD (TTYINSTRING \BUFFER))) (\NOVALUE (COND (\COMMAND (CONS WORD T)) (T T))) (T (SETQ RESULT (TTREADLIST)) (COND ((OR \COMMAND (NULL SPLST)) (* ;  "only check first word typed, or nothing at all") (CONS WORD RESULT)) (T (for TL on RESULT do [RPLACA TL (COND ((TTADJUSTWORD (CAR TL))) ((AND (NULL (CAR TL)) (NULL \FIX)) (* ;  "NIL is acceptable response, so don't abort!") NIL) (T (RETURN 'ABORT] finally (RETURN (CONS WORD RESULT] (SETLASTC FINALCHAR) (PROGN (* ;; "All this nonsense is just to convince prettyprint to keep the indentation down to a reasonable amount") (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN NIL] (* ;; "We have now processed the line, with the relevant value being RESULT...") [COND ((AND TTYINUSERFN (LISTP RESULT)) (COND ((EQ (SETQ X (APPLY* TTYINUSERFN RESULT)) T) (* ;  "Special response has been processed; try again") (RETURN 'ABORT)) (X (* ; "this is what we should return") (RETURN X] (SETQ \CURRENTDISPLAYLINE 0) (* ; "get scrolling right (again)") (* ; "see system \CLOSELINE") (RETURN RESULT]) (TTYIN.BALANCE [LAMBDA (ERRORFLG ADDPARENS) (* ; "Edited 17-Jan-88 16:36 by bvm:") (LET ((X (TTSKREAD \BUFFER NIL ADDPARENS))) (PROG1 (COND [(OR (EQ X \ENDBUFFER) (AND (LISTP X) (EQ (\SYNCODE \RDTBLSA (FIRSTCHAR X)) RIGHTBRACKET.RC) (AT.END.OF.TEXT (CDR X] ((FIXP X) (* ;  "Number of parens you'd have to add to balance") (MOVE.TO.WHEREVER \ENDBUFFER) (RPTQ X (ADDCHAR (CHARCODE ")"))) (SETQ X NIL) T) (T (COND ((AND ERRORFLG (EQ \CURSOR (OR X \ENDBUFFER))) (* ; "Only beep if cursor won't move") (BEEP))) NIL)) (MOVE.TO.WHEREVER (OR X \ENDBUFFER]) (ADDCHAR [LAMBDA (CHAR) (DECLARE (USEDFREE \CURSORCOL \ARROW \RMARG \CURSOR \AUTOFILL)) (* ; "Edited 24-May-91 11:09 by jds") (* ;;; "Add CHAR to buffer and print it, advancing cursor position appropriately") (LET ([WIDTH (COND ((COMPLEXCHARP CHAR) (fetch (COMPLEXCHAR CPXWIDTH) of CHAR)) (T (TTBITWIDTH CHAR] (ENDP (AT.END.OF.LINE))) (END.DELETE.MODE) (OVERFLOW? WIDTH) (COND ((NOT ENDP) (* ;  "Inserting in middle of line, so make space") (TTINSERTSECTION WIDTH))) (COND ((COMPLEXCHARP CHAR) (for PC in (fetch (COMPLEXCHAR CPXPRINTCHARS) of CHAR) do (TTBOUT PC))) (T (TTBOUT CHAR))) (INSERT.NODE \CURSOR) (FRPLACA \CURSOR CHAR) (SETQ \CURSOR (CDR \CURSOR)) (add \CURSORCOL WIDTH) [COND (ENDP (replace (LINE END) of \ARROW with \CURSOR) (replace (LINE LASTCOL) of \ARROW with \CURSORCOL) (* ;  "If we just advanced past the last column, do autofill stuff") (OVERFLOW? 0)) (T (* ;  "Check to see if line got shoved beyond right margin") (LET ((OVFL (IDIFFERENCE (add (fetch (LINE LASTCOL) of \ARROW) WIDTH) \RMARG))) (COND ((OR (IGREATERP OVFL 0) (AND (EQ OVFL 0) \AUTOFILL)) (ADJUSTLINE (AND \AUTOFILL T)) (MOVE.TO.WHEREVER \CURSOR] NIL]) (TTMAKECOMPLEXCHAR [LAMBDA (REALCHAR PRINTCHARS) (* bvm%: "16-Apr-85 16:50") (LET ((WIDTH 0) (NC 0)) (for C in PRINTCHARS do (add WIDTH (TTBITWIDTH C)) (add NC 1)) (create COMPLEXCHAR CPXREALCHAR _ REALCHAR CPXWIDTH _ WIDTH CPXNCHARS _ NC CPXPRINTCHARS _ PRINTCHARS]) (ADDNAKEDCHAR [LAMBDA (CHAR NOAUTOFILL) (* bvm%: "17-Apr-85 19:46") (* ;;; "Adds CHAR with no special processing, e.g. most control chars (except cr and lf, which I can't figure out yet) go thru ok.") (COND ((AND (IGREATERP CHAR 32) (NEQ CHAR 127)) (ADDCHAR CHAR)) (T (SELCHARQ CHAR (CR (* ; "CR can be attempted if at end") (COND ((AT.END.OF.BUF) (START.NEW.LINE EOLCHARCODE)) (T (BEEP)))) (SPACE (OR (AND (NOT NOAUTOFILL) (AUTOCR?)) (ADDCHAR (CHARCODE SPACE)))) (ESCAPE (* ; "Altmode will echo as $") [ADDCHAR (TTMAKECOMPLEXCHAR CHAR (LIST (CHARCODE $]) (TAB (TTADDTAB)) (ADDCHAR (TTMAKECOMPLEXCHAR CHAR (LIST (CHARCODE ^) (COND ((EQ CHAR (CHARCODE DEL)) (* ; "DELETE is represented as ^?") (CHARCODE ?)) (T (LOGOR CHAR 64]) (TTADDTAB [LAMBDA NIL (* ; "Edited 24-May-91 10:33 by jds") (* ;; "Represent in buffer as a tab with 128 bit on, followed by the appropriate number of spaces, each with 256 bit on. Tab is always self-inserting, i.e. it never overwrites anything (except itself, as above)") (ADDCHAR (TTMAKECOMPLEXCHAR (CHARCODE TAB) (from (LOGAND (IQUOTIENT (IDIFFERENCE \CURSORCOL (fetch (LINE FIRSTCOL ) of \ARROW)) \CHARWIDTH) 7) to 7 collect (CHARCODE SPACE]) (ADJUSTLINE [LAMBDA (JUSTIFYING LINE) (* ; "Edited 24-May-91 10:33 by jds") (* ;; "Handles patching up lines that are too long or short. Assures that the current line, ARROW, is correct with regard to overflows. If JUSTIFYING is true, it is a number specifying how many lines to 'justify' , by which we mean moving text around so that each line has as many words as possible for the linelength, but does not overflow. We don't do anything very fancy with that, like take care of deleting extra spaces.") (PROG ((IDEALLENGTH (- [COND ((> TTYJUSTLENGTH 0) (IMIN \RMARG (TIMES TTYJUSTLENGTH \CHARWIDTH))) (T (* ; "Relative to right margin") (IMAX (- \RMARG (TIMES (- TTYJUSTLENGTH) \CHARWIDTH)) (+ (LRSH (- \RMARG \LMARG) 1) \LMARG] \LMARG)) BREAK LASTCOL NEWENDLINE NEXTLINE OLDENDLINE OVFL START USECR ROW %#BITS) (OR LINE (SETQ LINE \ARROW)) (SETQ ROW (fetch (LINE ROW) of LINE)) LP (SETQ NEXTLINE (fetch (LINE NEXTLINE) of LINE)) (SETQ OVFL (OVERFLOWLINE? LINE)) (SETQ %#BITS (- \RMARG (fetch (LINE LASTCOL) of LINE))) (SETQ USECR (SETQ BREAK NIL)) (SETQ START (fetch (LINE START) of LINE)) (COND ((< %#BITS 0) (* ;; "Too much on line; need to break it somewhere, preferably at a space if permissible. If justifying, try to break at the appropriate length") (COND ([OR (AND JUSTIFYING (< (+ (fetch (LINE FIRSTCOL) of LINE) IDEALLENGTH) \RMARG) (SETQ BREAK (FIND.LINE.BREAK START (NTH.RELATIVE.COLUMN.OF LINE IDEALLENGTH) T))) (PROGN (SETQ NEWENDLINE (NTH.COLUMN.OF LINE \RMARG)) (AND (OR JUSTIFYING \AUTOFILL) (SETQ BREAK (FIND.LINE.BREAK START NEWENDLINE T] (SETQ USECR T)) (T (SETQ BREAK NEWENDLINE))) (GO DOBREAK)) [(AND OVFL (NEQ %#BITS 0) (NEQ (SETQ NEWENDLINE (NTH.RELATIVE.COLUMN.OF NEXTLINE %#BITS)) (fetch (LINE START) of NEXTLINE))) (* ;; "Line is too short, but is an overflow line, so text MUST be moved to fill the gap; alternatively, if we are justifying, we could break the line sooner") (* ;; "NEWENDLINE = where the line should end, based on linelength") (COND ([OR (EQ (fetch (LINE END) of LINE) NEWENDLINE) (AND (OR \AUTOFILL JUSTIFYING) (SETQ BREAK (FIND.LINE.BREAK (fetch (LINE END) of LINE) NEWENDLINE JUSTIFYING)) (SETQ NEWENDLINE BREAK)) (NOT JUSTIFYING) (NOT (SETQ BREAK (FIND.LINE.BREAK START (fetch (LINE END) of LINE) T] (GO DOJOIN)) (T (SETQ USECR T) (GO DOBREAK] ((NOT JUSTIFYING) (RETURN)) [(OR OVFL (AND (NEQ JUSTIFYING T) (> (- (fetch (LINE LASTCOL) of LINE) (fetch (LINE FIRSTCOL) of LINE)) IDEALLENGTH))) (* ; "line is longer than we'd like") (COND ((SETQ BREAK (FIND.LINE.BREAK START (NTH.RELATIVE.COLUMN.OF LINE IDEALLENGTH ) T)) (SETQ USECR T) (GO DOBREAK] [[AND (NOT (EMPTY.LINE LINE)) (NOT (START.OF.PARAGRAPH? NEXTLINE)) (OR (NEQ JUSTIFYING T) (EQ (CAR (fetch (LINE END) of LINE)) (CHARCODE SPACE] (* ;; "Don't move up text from next line if it is blank or starts with tab -- treat those as paragraph breaks") (* ;; "Note that we are guaranteed at this point that LINE is not an overflow line, so (fetch END of LINE) points at a space or cr") (COND ((OR (EQ [SETQ BREAK (NTH.RELATIVE.COLUMN.OF NEXTLINE (SUB1 (IMIN (- (+ IDEALLENGTH (fetch (LINE FIRSTCOL) of LINE)) (fetch (LINE LASTCOL) of LINE)) %#BITS] (fetch (LINE END) of NEXTLINE)) (SETQ BREAK (FIND.LINE.BREAK (fetch (LINE START) of NEXTLINE) BREAK T))) (SETQ NEWENDLINE BREAK) (* ;  "At least one more word from next line will fit up here") (GO DOJOIN)) (T (* ;  "No text movement, but if line ended in a real , make it a space") (FRPLACA (fetch (LINE END) of LINE) (CHARCODE SPACE] ((EQ JUSTIFYING T) (* ; "If this line is fine, quit") )) (SETQ LINE NEXTLINE) (GO BOTTOM) DOJOIN (* ;; "Move text from next line up to this one. NEWENDLINE is where line should end when done. BREAK=NEWENDLINE if this new end line is a pseudo-cr break") (COND ((EQ (SETQ OLDENDLINE (fetch (LINE END) of LINE)) NEWENDLINE) (SETQ %#BITS 0)) (T (GO.TO.RELATIVE (fetch (LINE LASTCOL) of LINE) ROW) (SETQ %#BITS (SEGMENT.BIT.LENGTH OLDENDLINE NEWENDLINE)) (* ;  "# chars to delete from next line") [COND ((NOT OVFL) (* ;  "Joining toa non-overflow line: turn its cr into a space") (FRPLACA OLDENDLINE (CHARCODE SPACE)) (while (AND (NEQ (CDR OLDENDLINE) NEWENDLINE) (EQ (CADR OLDENDLINE) (CHARCODE SPACE))) do (* ;  "strip leading spaces from next line") (KILLSEGMENT OLDENDLINE (CDR OLDENDLINE))) (COND ((EQ (CAR (NLEFT (fetch (LINE START) of LINE) 1 OLDENDLINE)) (CHARCODE %.)) (* ;  "LINE ends in period, so space twice") (FRPLACA (INSERT.NODE OLDENDLINE) (CHARCODE SPACE] (TYPE.BUFFER OLDENDLINE NEWENDLINE) (replace (LINE END) of LINE with NEWENDLINE) (replace (LINE LASTCOL) of LINE with \CURSORCOL))) (GO.TO.RELATIVE 'LINE NEXTLINE) (replace (LINE START) of NEXTLINE with (COND (BREAK (FRPLACA BREAK (CHARCODE SPACE)) (* ;  "In case BREAK was at the CR turn it into space") (COND (OVFL (add %#BITS (TTBITWIDTH (CHARCODE SPACE))) (* ; "will delete space also") )) (CDR NEWENDLINE)) (T NEWENDLINE))) (COND ((EQ (fetch (LINE END) of NEXTLINE) NEWENDLINE) (DELETELINE NEXTLINE T) (* ; "Nothing left here, so kill it") [COND (JUSTIFYING (* ;  "maybe we can move from next line, too") (COND ((AND (NEQ JUSTIFYING T) (NEQ (SUB1VAR JUSTIFYING) 0)) (GO LP)) (T (RETURN] (SETQ LINE (fetch (LINE NEXTLINE) of LINE))) (T (TTDELSECTION %#BITS) (replace (LINE LASTCOL) of NEXTLINE with (- (fetch (LINE LASTCOL) of NEXTLINE) %#BITS)) (SETQ LINE NEXTLINE))) (GO BOTTOM) DOBREAK (* ;; "Break line at BREAK, moving excess down to next line or a new line. USECR is true if break is to act like a cr; otherwise we are breaking a too-long line at the right margin, so there is no end of line place holder") [replace (LINE LASTCOL) of LINE with (SETQ LASTCOL (+ (SEGMENT.BIT.LENGTH (fetch (LINE START) of LINE) BREAK) (fetch (LINE FIRSTCOL) of LINE] (* ; "Column where break will occur") [SETQ %#BITS (SEGMENT.BIT.LENGTH BREAK (SETQ OLDENDLINE (fetch (LINE END) of LINE] (* ; "length of segment being moved") (COND ((NEQ LASTCOL \RMARG) (GO.TO.RELATIVE LASTCOL ROW) (* ;  "Go wipe out what was there. Don't need to do this if the break is right at the margin") (ERASE.TO.END.OF.LINE))) (replace END of LINE with BREAK) [COND (USECR (* ;  "we have counted one char too many above...") [SETQ %#BITS (- %#BITS (TTBITWIDTH (CHARCODE SPACE] (SETQ BREAK (CDR BREAK] (COND [[AND NEXTLINE (OR OVFL (AND (OR (SMALLP JUSTIFYING) (AND (EQ (CAR OLDENDLINE) (CHARCODE SPACE)) (< (+ (fetch LASTCOL of NEXTLINE) %#BITS) \RMARG))) (NOT (START.OF.PARAGRAPH? NEXTLINE] (* ;; "Insert the text on the next line, rather than starting new line, if justifying, overflow (forced), or the text will fit, i.e. not cause anything to be bumped off the next line") (GO.TO.RELATIVE 'LINE (SETQ LINE NEXTLINE)) (COND ((NOT OVFL) (* ;; "Turn the terminating into ordinary space; this space also needs to be inserted and counted, of course") (add %#BITS (TTBITWIDTH (CHARCODE SPACE))) (SETQ OLDENDLINE (CDR (FRPLACA OLDENDLINE (CHARCODE SPACE] (T (SETQ LINE (INSERTLINE LINE)) (replace END of LINE with OLDENDLINE))) (replace START of LINE with BREAK) (INSERT.TEXT BREAK OLDENDLINE (fetch END of LINE)) (add (fetch LASTCOL of LINE) %#BITS) BOTTOM (COND (LINE (ADD1VAR ROW) (COND ((AND JUSTIFYING (NEQ JUSTIFYING T) (EQ (SUB1VAR JUSTIFYING) 0)) (SETQ JUSTIFYING NIL))) (GO LP]) (ADJUSTLINE.AND.RESTORE [LAMBDA (JUSTIFYING) (* ; "Edited 24-May-91 10:33 by jds") (SAVE.CURSOR) (ADJUSTLINE JUSTIFYING) (COND ((IGREATERP \HOMECOL (fetch (LINE LASTCOL) of \ARROW)) (* ; "Oops, cursor must have moved") (MOVE.TO.WHEREVER \CURSOR)) (T (RESTORE.CURSOR]) (AT.END.OF.SCREEN [LAMBDA NIL (* bvm%: "11-Apr-85 14:58") (OR (AT.END.OF.LINE) (IGREATERP (IPLUS \CURSORCOL (SEGMENT.LENGTH \CURSOR (TTNEXTCHAR \CURSOR)) \CHARWIDTH) \RMARG]) (AT.END.OF.TEXT [LAMBDA (BUF) (* bvm%: "11-Apr-85 15:00") (* ;; "Checks that this is the last printing char in buffer. Fancier than just checking that BUF = ENDBUFFER, since that would mess up if user deletes a line and decides to terminate on previous line") (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X \ENDBUFFER) always (SPACEP (FIRSTCHAR X]) (AUTOCR? [LAMBDA NIL (* bvm%: "16-Apr-85 18:57") (* ;; "Terminates line if near edge of screen and in autofill mode") (COND ((AND \AUTOFILL (IGREATERP (IPLUS \CURSORCOL TTYINAUTOFILLMARGIN) \RMARG)) [COND ((AT.END.OF.LINE) (START.NEW.LINE (CHARCODE SPACE))) (T (BREAKLINE (CHARCODE SPACE] T]) (BACKSKREAD [LAMBDA (BUF NOTIFQUOTED) (* ; "Edited 8-Feb-88 12:45 by bvm:") (* ;; "Returns buffer position of start of list containing cursor position BUF, or start of buffer. If NOTIFQUOTED is true, then returns NIL if the paren/bracket at BUF is quoted with the escape char or is inside a string. Strategy: start at beginning of buffer and TTSKREAD forward (much easier); if read ends at BUF, we win; if ends before BUF, then resume reading there (we skipped an internal list); otherwise if read did not end, BUF must be inside a list, so scan ahead for start of an inner list, and repeat") (PROG ((B \BUFFER) (INNERMOSTLIST \BUFFER) ESCAPED BRACKETFLG X) LP [COND ((EQ B BUF) (* ; "No list in buffer at all") (RETURN (AND (OR (NOT NOTIFQUOTED) (NOT ESCAPED)) INNERMOSTLIST] [SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR B)) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (* ;  "open paren or bracket. Try scanning this new internal list") [COND (ESCAPED (* ; "Inside a multiple escape") ) ((EQ (SETQ X (TTSKREAD (CDR B) BUF)) BUF) (RETURN (OR BRACKETFLG B))) (X (* ;  "Skip over internal list just scanned") (SETQ B X)) (T (* ;; "The TTSKREAD failed, so BUF must be at least this deeply nested. Save pointer here in case we abort inside a string or such") (SETQ INNERMOSTLIST B) (COND ((AND (EQ (CAR B) (CHARCODE %[)) (EQ (CAR BUF) (CHARCODE %]))) (* ;; "Brackets may match; save position of this open bracket. Otherwise we'll return the innermost list, rather than the start of the bracket expression") (SETQ BRACKETFLG B]) (ESCAPE.RC (* ; " to quote the next char") [COND ((EQ (CDR B) BUF) (* ;; "The char at BUF is quoted. This is why TTSKREAD failed here. Just return the list we're now inside") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST))) (T (* ; "skip over escape char") (SETQ B (CDR B]) (STRINGDELIM.RC (* ; "double-quote") [COND ([AND (NOT ESCAPED) (NOT (SETQ B (FIND.MATCHING.QUOTE (CDR B) BUF] (* ;  "Termination analogous to previous case") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST]) (MULTIPLE-ESCAPE.RC (SETQ ESCAPED (NOT ESCAPED))) (OTHER.RC NIL) (PROGN (COND ((AND (EQ (CAR B) (CHARCODE ;)) (READTABLEPROP RDTBL 'COMMONLISP)) (* ; "Handle semicolon special") (COND ([do (SETQ B (CDR B)) (COND ((EQ B BUF) (RETURN T)) ((EQ (FIRSTCHAR B) (CHARCODE EOL)) (RETURN] (* ; "Done inside a comment") (RETURN (AND (NOT NOTIFQUOTED) INNERMOSTLIST] (SETQ B (CDR B)) (GO LP]) (BACKWARD.DELETE.TO [LAMBDA (BUF) (* bvm%: "19-MAR-81 11:55") (FORWARD.DELETE.TO (PROG1 \CURSOR (MOVE.BACK.TO BUF]) (BREAKLINE [LAMBDA (USECR STAY) (DECLARE (USEDFREE \CURSOR \ARROW \CURSORCOL \CURSOR)) (* ; "Edited 24-May-91 10:33 by jds") (* ;;; "Break current line at \CURSOR position, inserting a suitable if USECR is given. If STAY is true, \CURSOR does not move; otherwise cursor moves to first position of new line.") (PROG ((OLDLINE \ARROW) (OLDEND (fetch (LINE END) of \ARROW))) (replace (LINE END) of \ARROW with \CURSOR) (* ;  "terminate current line at \CURSOR position") (replace (LINE LASTCOL) of \ARROW with \CURSORCOL) (ERASE.TO.END.OF.LINE) (COND (STAY (SAVE.CURSOR))) (SETQ \ARROW (INSERTLINE \ARROW USECR)) (COND ((NOT STAY) (SAVE.CURSOR))) (replace (LINE END) of \ARROW with OLDEND) [COND [(EQ \CURSOR OLDEND) (* ;  "cr was inserted at end of line. Maybe this never happens") (replace (LINE END) of \ARROW with (SETQ \CURSOR (CDR OLDEND] (T (TYPE.BUFFER (SETQ \CURSOR (fetch (LINE START) of \ARROW)) OLDEND) (* ;  "Restore to screen what we erased above") (replace (LINE LASTCOL) of \ARROW with \CURSORCOL) (COND ((OVERFLOWLINE? \ARROW) (* ;; "the previous line overflowed, but when we inserted a cr we added more space on the line, so go fix it up") (ADJUSTLINE] [COND (STAY (* ;  "Oh well, undo what we did to poor \CURSOR") (SETQ \CURSOR (fetch (LINE END) of (SETQ \ARROW OLDLINE] (RESTORE.CURSOR]) (BUFTAILP [LAMBDA (TAIL START END) (* bvm%: "23-JUN-81 15:48") (do (COND ((EQ TAIL START) (RETURN TAIL)) ((OR (NOT START) (EQ START END)) (RETURN))) (SETQ START (CDR START]) (CHECK.MARGIN [LAMBDA (BUF LINE) (* ; "Edited 24-May-91 10:33 by jds") (* ;;; "If BUF is the pseudo-cr at the end of this LINE, then back it up one, since you can't let the cursor sit on it") (COND ((AND (EQ (fetch (LINE END) of LINE) BUF) (OR (EQ (fetch (LINE LASTCOL) of LINE) \RMARG) (EQ (fetch (LINE START) of (fetch (LINE NEXTLINE) of LINE)) BUF))) (TTNLEFT BUF 1 (fetch (LINE START) of LINE))) (T BUF]) (CLEAR.LINE? [LAMBDA (FLG) (* lmm "20-Nov-86 00:27") (* ; "If FLG true, erase lots") (COND (FLG (ERASE.TO.END.OF.PAGE)) (T (ERASE.TO.END.OF.LINE]) (CURRENT.WORD [LAMBDA NIL (* ; "Edited 24-May-91 10:34 by jds") (* ;; "Used by word-completion routines. Returns position in buffer of the start of the current word, or NIL if no word is in progress, or \COMMAND is true and this is not the first word, or the line is a comment. Definition of 'word' here is different from that of WORDSEPRP since we want only words with respect to the reader, not with respect to text") (COND ((AND (NOT (AT.START.OF.LINE)) (NEQ (CAR (fetch (LINE START) of \ARROW)) TTYINCOMMENTCHAR)) (for (X _ (fetch (LINE START) of \ARROW)) by (TTNEXTCHAR X) until (EQ X \CURSOR) bind (NEW _ T) SNX do (* ;  "NEW is true after we scan a break character") (SETQ SNX (\SYNCODE \RDTBLSA (FIRSTCHAR X))) (COND ((COND (NEW (* ;  "Most ANY funny character at start of word considered sepr") (SELECTC SNX ((LIST OTHER.RC ESCAPE.RC MULTIPLE-ESCAPE.RC) (* ; "Looks like good start of word") NIL) T)) (T (* ;  "If in middle of word, only 'terminating macros' stop word") (fetch STOPATOM of SNX))) (SETQ NEW T)) (NEW (* ;  "This is the start of a new word; note it") (COND ((AND $$VAL \COMMAND) (* ; "Means this is second word") (RETURN))) (SETQ $$VAL X) (SETQ NEW NIL))) finally (RETURN (AND (NOT NEW) $$VAL]) (DELETE.TO.END [LAMBDA NIL (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Kills buffer from \CURSOR onward") (SETTAIL? T) (COND (DISPLAYTERMFLG (ERASE.TO.END.OF.PAGE))) (COND ((fetch (LINE NEXTLINE) of \ARROW) (* ;  "There are lines after this, so return them to garbage heap") (KILL.LINES (fetch (LINE NEXTLINE) of \ARROW)) (replace (LINE NEXTLINE) of \ARROW with NIL))) (replace (LINE END) of \ARROW with (SETQ \ENDBUFFER \CURSOR)) (replace (LINE LASTCOL) of \ARROW with \CURSORCOL]) (DELETELINE [LAMBDA (LINE EMPTYLINE?) (* ; "Edited 24-May-91 10:34 by jds") (* ;; "Deletes this LINE from buffer and screen; assumes cursor is currently positioned somewhere on the line. EMPTYLINE? is true on calls from ADJUSTLINE where the line is naked and hence no text in the buffer needs to be killed.") (PROG ((NEXTLINE (fetch (LINE NEXTLINE) of LINE)) OLDSTART NEWSTART PREVLINE) [COND ((AND (EQ LINE \ARROW) (ON.FIRST.LINE)) (COND ((NOT NEXTLINE) (* ; "Can't delete the only line") (RETURN (BEEP))) ((NEQ \PROMPT1 \PROMPT2) (* ;  "tricky to delete first line, since the correct prompt should be displayed") (MOVE.BACK.TO \BUFFER) (RETURN (FORWARD.DELETE.TO (fetch (LINE END) of \ARROW] (COND (DISPLAYTERMFLG (DO.DELETE.LINES 1))) (RENUMBER.LINES NEXTLINE (fetch (LINE ROW) of LINE)) (replace (LINE NEXTLINE) of (SETQ PREVLINE (PREVLINE LINE 1)) with NEXTLINE ) [COND ((NOT NEXTLINE) (* ;  "deleting last line: need to worry about \ENDBUFFER and such") (SETQ \ENDBUFFER (fetch (LINE END) of PREVLINE))) (T (replace (LINE NEXTLINE) of LINE with NIL) (* ;  "in preparation for KILL.LINES below") (COND ((NOT EMPTYLINE?) (KILLSEGMENT (SETQ OLDSTART (fetch (LINE START) of LINE)) (SETQ NEWSTART (fetch (LINE START) of NEXTLINE))) (* ;  "flush anything on the line. PREVLINE pointers remain valid") (COND ((EQ (fetch (LINE END) of NEXTLINE) NEWSTART) (replace (LINE END) of NEXTLINE with OLDSTART))) (replace (LINE START) of NEXTLINE with OLDSTART] (KILL.LINES LINE) (* ; "return to heap") (COND ((EQ \ARROW LINE) (* ;  "if this is our home position, adjust appropriately") (SETQ \ARROW (SETQ LINE (OR NEXTLINE PREVLINE))) (SETQ \CURSOR (fetch (LINE START) of LINE)) (GO.TO.RELATIVE 'LINE LINE]) (DELETETO [LAMBDA (TAIL) (* ; "Edited 24-May-91 10:34 by jds") (SETTAIL?) (COND ((NEQ \CURSOR \ENDBUFFER) (* ;  "On other terminals also when Cursor capable") (BACKWARD.DELETE.TO TAIL)) (T [COND [(NOT DISPLAYTERMFLG) (COND ((NOT \DELETING) (* ; "prefix deletions with backslash") (COND ((NOT TTYINBSFLG) (* ;  "unless we are going to physically backspace") (TTBOUT \))) (SETQ \DELETING 0))) (DELETETO1 TAIL) (COND ((EQ TAIL \BUFFER) (END.DELETE.MODE] (T (PROG ((N (SEGMENT.BIT.LENGTH TAIL \ENDBUFFER))) (* ;  "need to kill the previous N chars") (* ;; "(COND ((CAPABILITY? ERASE.TO.END T) (* Ah, all we need do is go back N and erase to end) (DO.BACK N) (ERASE.TO.END.OF.LINE)) (T (* laborious technique for glass ttys: go back and wipe out each char one at a time) (FRPTQ N (PROGN (DO.BACK 1) (* back up) (TTBOUT SPACE) (* overwrite with space) (DO.BACK 1) (* and back up again)))))") (DSPBACKUP N \DSP) (SETQ \CURSORCOL (IDIFFERENCE \CURSORCOL N] (replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \ENDBUFFER TAIL))) (replace (LINE LASTCOL) of \ARROW with \CURSORCOL]) (DELETETO1 [LAMBDA (TAIL) (* ; "Edited 24-May-91 11:09 by jds") (* ;;; "Not used in Interlisp-D") (* ;; "on non-DMs: delete chars until we reach TAIL; since we echo deleted chars in reverse order, this is most easily done recursively") [COND ((NEQ (CDR TAIL) \ENDBUFFER) (DELETETO1 (CDR TAIL] (for CH inside (COND ((COMPLEXCHARP (CAR TAIL)) (fetch (COMPLEXCHAR CPXPRINTCHARS) of (CAR TAIL))) (T (CAR TAIL))) do (SELECTQ TTYINBSFLG (NIL (TTBOUT CH)) (LF (* ;; "physically backspace, crossing out character. LF means we will do a LF when ENDELETE happens. If we don't LF, then best not to cross out chars") (TTBOUT BS \ BS) (ADD1VAR \DELETING)) (TTBOUT BS))) (* ; "echo deleted char") (SETQ \CURSORCOL (SUB1 \CURSORCOL]) (DO.EDIT.COMMAND [LAMBDA (CHAR EDITARG) (* ; "Edited 24-May-91 10:40 by jds") (* ;;; "Handles the various edit commands, which mostly move the cursor around in the buffer, or kill pieces of it. CHAR is the character stripped of its editbit. EDITARG is the argument, if any (not set by type-in, but by program asking for a particular edit function). If this routine returns something, it means process it like ordinary character (this is how we can invoke non-editbit routines)") (PROG (EDITMINUS L X LASTSKIP) [COND ((NOT EDITARG) (SETQ EDITARG 1)) ((MINUSP EDITARG) (SETQ EDITMINUS T) (SETQ EDITARG (IMINUS EDITARG] LP [SELCHARQ (SETQ CHAR (U-CASECODE CHAR)) (CR (* ;; "CR on empty buffer means get back last buffer; in the middle of a buffer it is the same as normal CR, but also ends insert mode") [COND ((EMPTY.BUFFER) (RESTOREBUF)) ((ON.LAST.LINE) (RETURN CHAR)) (T (MOVE.TO.LINE (TTNEXTLINE \ARROW EDITARG]) ((SPACE >) (* ; "move right") [COND (EDITMINUS (SETQ CHAR (CHARCODE DEL)) (* ; "backward space is delete") (GO NOMINUS)) ((AT.END.OF.BUF) (BEEP)) ((AT.END.OF.SCREEN) (MOVE.TO.NEXT.LINE)) (T (MOVE.FORWARD.TO (TTNTH \CURSOR EDITARG]) ((DEL ^A BS <) (* ; "back up") [COND (EDITMINUS (SETQ CHAR (CHARCODE SPACE)) (* ; "backward delete is space") (GO NOMINUS)) ((AT.START.OF.BUF) (BEEP)) ((AT.START.OF.LINE) (MOVE.TO.LINE (SETQ X (PREVLINE \ARROW 1)) (fetch (LINE END) of X))) (T (MOVE.BACK.TO (TTNLEFT \CURSOR EDITARG]) (%( (* ; "backs up one word") [COND (EDITMINUS (SETQ CHAR (CHARCODE %))) (GO NOMINUS)) (T (MOVE.BACK.TO (PREVWORD \CURSOR EDITARG]) (%) (* ; "moves ahead one word") [COND (EDITMINUS (SETQ CHAR (CHARCODE %()) (GO NOMINUS)) ((AT.END.OF.SCREEN) (BEEP)) (T (MOVE.FORWARD.TO (FIND.NEXT.WORD \CURSOR EDITARG]) (TAB (* ; "go to end of line") (MOVE.TO.LINE (SETQ X (TTNEXTLINE \ARROW (SUB1VAR EDITARG))) (fetch (LINE END) of X))) (^L (* ; "go to start of line") (MOVE.TO.LINE (PREVLINE \ARROW (SUB1VAR EDITARG)))) ({ (* ;  "{ goes to start of buffer, like infinite FF") (MOVE.TO.LINE \FIRSTLINE)) (} (* ;  "} goes to end of buffer, like infinite TAB") (MOVE.TO.LINE (SETQ X (TTLASTLINE)) (fetch (LINE END) of X))) (LF (* ; "moves down") [COND (EDITMINUS (SETQ CHAR (CHARCODE ^)) (GO NOMINUS)) [(ON.LAST.LINE) (COND ((EMPTY.BUFFER) (* ;  "Treat this the same as regular linefeed, i.e. restore buffer") (RETURN (CHARCODE LF))) (T (BEEP] (T (MOVE.TO.LINE (SETQ X (TTNEXTLINE \ARROW EDITARG)) (NTH.COLUMN.OF X (EDITCOLUMN]) (^ (* ; "moves up") [COND (EDITMINUS (SETQ CHAR (CHARCODE LF)) (GO NOMINUS)) ((ON.FIRST.LINE) (BEEP)) (T (MOVE.TO.LINE (SETQ X (PREVLINE \ARROW (IMIN (IPLUS \LOC.ROW.0 \CURSORROW) EDITARG))) (NTH.COLUMN.OF X (EDITCOLUMN]) (K (* ; "kills one char") [COND ((AT.END.OF.LINE) (BEEP)) (T (FORWARD.DELETE.TO (TTNTH \CURSOR EDITARG]) ((S Z B) (* ; "various skip or zap commands") (SKIP/ZAP CHAR (TTBIN T) EDITARG EDITMINUS)) (A (* ; "repeat last S or Z") (COND ((SETQ LASTSKIP (fetch (TTYINBUFFER LASTSKIP) of \TTYINSTATE)) (SKIP/ZAP LASTSKIP (fetch (TTYINBUFFER LASTSKIPCHAR) of \TTYINSTATE ) EDITARG EDITMINUS)) (T (BEEP)))) (L (* ; "lowercase word") (U/L-CASE EDITARG)) (U (* ; "uppercase word") (U/L-CASE EDITARG T)) (C (* ; "capitalize word") (U/L-CASE EDITARG 1)) (G (* ;  "grab a copy of Nth previous line") (COND ((OR (ON.FIRST.LINE) (NOT (AT.END.OF.LINE)) (EQ (SETQ X (NTH.COLUMN.OF (SETQ L (PREVLINE \ARROW EDITARG)) \CURSORCOL)) (fetch (LINE END) of L))) (* ; "nothing to copy") (BEEP)) (T (READFROMBUF X (fetch (LINE END) of L) T)))) (%] (* ;  "Move to end of current expression") [COND ((AT.END.OF.BUF) (BEEP)) (T (MOVE.TO.WHEREVER (OR (TTSKREAD (TTNEXTCHAR \CURSOR)) \ENDBUFFER]) (%[ (* ;  "Move to start of current list expression") [COND ((AT.START.OF.BUF) (BEEP)) (T (MOVE.TO.WHEREVER (BACKSKREAD \CURSOR]) (^W (* ;  "delete back to start of current word") (TTDELETEWORD EDITARG)) (D (* ; "Delete forward to end of word") (COND ((AT.END.OF.LINE) (BEEP)) (T (COND ((AND (NEQ (SETQ X (FIND.NEXT.WORD \CURSOR EDITARG T)) (fetch (LINE END) of \ARROW)) (NOT (AT.START.OF.LINE)) [NOT (WORDSEPRP (FIRSTCHAR (TTNLEFT \CURSOR 1] [SPACEP (FIRSTCHAR (SETQ L (TTNLEFT X 1 \CURSOR] (NEQ L \CURSOR)) (* ;; "Don't want to delete all the way to start of new word, since we'd like a little space in between. Simulating EMACS would probably be easier if we just made FIND.NEXT.WORD stop at the intervening spaces rather than at the end") (SETQ X L))) (FORWARD.DELETE.TO X)))) ((^Q ^U) (* ;  "Delete line; ^U for tops20 folk") (COND ((EQ EDITARG 1000) (DELETE.TO.END)) (T (DELETELINE \ARROW)))) (^Y (* ; "gets userexec") (COND ((AND (EQ EDITARG 1000) (NEQ \CURSOR \ENDBUFFER)) (TTUNREADBUF) (* ;  "Stuff what's ahead of cursor into input buffer") )) (RETURN CHAR)) (F (* ; "accept tvedit's $$F to finish") (COND [(EQ EDITARG 1000) (MOVE.TO.WHEREVER \ENDBUFFER) (COND ((NEQ \CURSOR \ENDBUFFER) (* ; "This is because the cursor mover refuses to put me in column 80 of a line, due to certain anomalies") (add \CURSORCOL (SEGMENT.BIT.LENGTH \CURSOR \ENDBUFFER)) (SETQ \CURSOR \ENDBUFFER) (OVERFLOW? 0))) (RETURN (COND (\REPEAT (* ; "End with ^Z") (CHARCODE ^Z)) (\READING (* ;; "End read with ']' ; of course, this doesn't always 'finish' , but it's simple enough to remember what this is") (CHARCODE %])) (T (CHARCODE CR] (T (BEEP)))) (J (* ; "Justify/fill line") (ADJUSTLINE.AND.RESTORE EDITARG)) (- (* ; "minus sign negates arg") (SETQ EDITARG 0) (SETQ EDITMINUS T) (GO DONUMBERS)) (ESCAPE (* ; "ESCAPE may modify next command") [COND ((AND (EQ EDITARG 1000) (EQ EDITPREFIXCHAR (CHARCODE ESCAPE))) (* ;; "3 escapes in a row is the way to type a regular Escape when Escape is the edit prefix. Better ways might be forthcoming") (RETURN (CHARCODE ESCAPE] (SETQ EDITARG 1000) (* ;  "1000 is an adequate infinity for these purposes") (SETQ EDITMINUS) (SETQ CHAR (TTBIN T)) (GO LP)) ((N ^R) (* ;  "refresh n lines, or whole buffer for $$N") [COND ((EQ EDITARG 1000) (RETYPE.BUFFER \FIRSTLINE T)) (EDITMINUS (RETYPE.BUFFER (PREVLINE \ARROW EDITARG) \ARROW)) (T (RETYPE.BUFFER \ARROW (TTNEXTLINE \ARROW EDITARG]) (T (* ;; "transpose chars. If at end of line, do preceding two, else do the ones before and after the cursor.") [SETQ L (TTNLEFT \CURSOR (SETQ X (COND ((AT.END.OF.LINE) 2) (T 1] (* ; "start of swap") [COND ((OR (EQ L \CURSOR) (COMPLEXCHARP (CAR L)) (AND (EQ X 2) (EQ (CDR L) \CURSOR)) (COMPLEXCHARP (CADR L))) (* ;  "Complain if not enough chars to swap, or one of them is a funny multiple char (I'm lazy)") (BEEP)) (T [GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (SEGMENT.BIT.LENGTH L (NTH L (ADD1 X] (* ; "Back up to start of segment") [FRPLACA L (PROG1 (CADR L) (FRPLACA (CDR L) (CAR L)))] (* ; "Do the swap in the buffer") (TYPE.BUFFER L (CDDR L)) (* ; "Fix the display") (COND ((EQ X 1) (* ;  "Were between two chars, so get back there") (GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (TTBITWIDTH (FIRSTCHAR (CDR L]) (O (* ;  "Open line, i.e. insert but stay here") (BREAKLINE EOLCHARCODE T)) (_ (* ;; "Special hack: says to add the word before the cursor to USERWORDS, so I can use altmode completion on it") (COND [(AND TTYINCOMPLETEFLG (SETQ X (CURRENT.WORD)) [SETQ X (PROG ((\BUFFER X)) (RETURN (TTRATOM] (LITATOM X)) (COND ((EQ EDITARG 0) (* ;  "Means to remove! I don't know if there's an 'official' way to do this") (DREMOVE X USERWORDS)) (T (ADDSPELL X 0] (T (BEEP)))) (P (DO.EDIT.PP)) (COND ((SETQ CHAR (EDITNUMBERP CHAR)) (SETQ EDITARG CHAR) (GO DONUMBERS)) (T (BEEP] (SETQ \LASTCHAR CHAR) (RETURN) NOMINUS (SETQ EDITMINUS) (GO LP) DONUMBERS (* ;; "scanning a numeric arg. EDITARG is its magnitude; EDITMINUS set if negative. escape is treated as 1000, which is probably big enough. Doesn't matter if any of the next chars has edit bit on, since once we start a number, any other digits must be part of it, since numbers aren't themselves commands") (COND ([SETQ X (EDITNUMBERP (SETQ CHAR (TTBIN T] [SETQ EDITARG (COND ((IGREATERP EDITARG 100) (* ;  "Limit numeric args to 1000 so small number stuff works") 1000) (T (IPLUS (ITIMES EDITARG 10) X] (GO DONUMBERS))) (COND ((AND EDITMINUS (EQ EDITARG 0)) (* ;  "Happens if we get a '-' followed by no number") (SETQ EDITARG 1))) (GO LP]) (DO.EDIT.PP [LAMBDA NIL (* ; "Edited 24-May-91 10:34 by jds") (COND ((NOT \READING) (* ;  "Nothing to prettyprint--just redisplay") (RETYPE.BUFFER \FIRSTLINE T)) (T (* ;  "Read what we have, supplying closing parens if suitable, and then prettyprint it") (WITH-RESOURCES (TTSCRATCHFILE) (PROG ((*READTABLE* RDTBL) (\BUFFER \BUFFER) LEFTOVER EXPRS) [COND ((TTYIN.BALANCE NIL T) (* ; "Input is now perfectly balanced") ) ((NEQ \CURSOR \ENDBUFFER) (* ; "There was extra stuff at end") (SETQ LEFTOVER (COPY.SEGMENT \CURSOR \ENDBUFFER)) (SETQ \ENDBUFFER \CURSOR)) (T (* ; "Didn't balance, so punt") (RETURN (BEEP] (SETQ \CURSOR \BUFFER) [COND ((NEQ (TTSKIPSEPR) \ENDBUFFER) (SETQ EXPRS (TTYIN.READ 0 NIL TTSCRATCHFILE] (MOVE.TO.LINE \FIRSTLINE) (ERASE.TO.END.OF.PAGE) (TTYIN1RESTART) (replace (LINE FIRSTCOL) of \ARROW with (replace (LINE LASTCOL ) of \ARROW with \CURSORCOL)) [COND (EXPRS (TTLOADBUF (LIST HISTSTR1 (TTYIN.PPTOFILE EXPRS NIL NIL TTSCRATCHFILE] (SETFILEPTR TTSCRATCHFILE 0) (* ; "Leave it nice for next customer") (COND (LEFTOVER (* ;  "Display the stuff that follows the normal read termination") (BREAKLINE (CHARCODE EOL)) (READFROMBUF LEFTOVER]) (TTDOTABS [LAMBDA (TABS) (* bvm%: "16-Apr-85 17:35") (* ;;; "Tab to next tabstop in TABS, if any. Represent pseudotabs as a complex space. Return T if anything done") (COND ((AND TABS (AT.END.OF.BUF)) (for TB in TABS bind SPACES when (AND (SMALLP TB) (IGREATERP (SETQ SPACES (IDIFFERENCE (ITIMES TB \CHARWIDTH ) \CURSORCOL)) \CHARWIDTH)) do (* ;  "Make pseudo-tab and echo as spaces") [ADDCHAR (TTMAKECOMPLEXCHAR (CHARCODE SPACE) (to (IQUOTIENT SPACES \CHARWIDTH) collect (CHARCODE SPACE] (RETURN T]) (EDITCOLUMN [LAMBDA NIL (* bvm%: "24-AUG-81 23:17") (* ;; "If last edit command moved up/down, then return the same column we were using then; else use current cursor column, and record it as the 'goal' column for any future such commands") (OR (SELCHARQ \LASTCHAR ((LF ^) \HOMECOL) NIL) (SETQ \HOMECOL \CURSORCOL]) (EDITNUMBERP [LAMBDA (CHAR) (* bvm%: "11-MAR-81 22:05") (AND [NOT (MINUSP (SETQ CHAR (IDIFFERENCE CHAR (CONSTANT (CHCON1 0] (NOT (IGREATERP CHAR 9)) CHAR]) (END.DELETE.MODE [LAMBDA NIL (* bvm%: "19-MAR-81 11:59") (COND (\DELETING (SELECTQ TTYINBSFLG (NIL (TTBOUT \)) (LF (COND ((IGREATERP \DELETING 1) (* ;  "if more than one char x'd out, lf to new line") (DO.LF)))) NIL) (SETQ \DELETING NIL]) (ENDREAD? [LAMBDA NIL (* bvm%: "10-Apr-86 14:21") (* ;; "Return true if the paren/bracket just typed terminates the input. It does if the right paren (or even one earlier in buffer) is in excess, i.e unbalanced, or just balances and this is the only list on the line, or we are doing a LISPX input and the input is in EVALQT form, with no space after the first atom") (LET (X) (AND (AT.END.OF.TEXT \CURSOR) (SETQ X (TTSKREAD \BUFFER)) (OR (NEQ X \ENDBUFFER) (AND [SELCHARQ (CAR (SETQ X (FIND.NON.SPACE \BUFFER))) ((%( %[) (* ;  "OK, line started with paren/bracket") T) (AND (EQ \READING 'EVALQT) (NEQ \PROMPT1 '*) (while (NEQ X \ENDBUFFER) bind ESCAPED do (* ;; "Skip over this first atom, to see if input is in EVALQT form. Prompt check is so we don't do this in the editor") (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR X)) (SEPRCHAR.RC (* ;  "Space, etc: probably wants more on line") (OR ESCAPED (RETURN NIL))) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (* ; "Open paren/bracket: looks good") [OR ESCAPED (RETURN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (PROGN (* ; "Prettyprint sucks again!") T]) (ESCAPE.RC (* ; "Skip over escape char") (SETQ X (CDR X))) (MULTIPLE-ESCAPE.RC (* ; "Multiple escape") (SETQ ESCAPED (NOT ESCAPED))) NIL) (SETQ X (TTNEXTCHAR X] (EQ (CDR (TTSKREAD (CDR X))) \CURSOR]) (FIND.LINE [LAMBDA (BUF) (DECLARE (USEDFREE \FIRSTLINE)) (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Returns the buffer LINE on which BUF, a cursor position, occurs") (for (LINE _ (PROGN \FIRSTLINE)) do (COND [(EQ BUF (fetch (LINE END) of LINE)) (* ;  "Check this separately so next BUFTAILP doesn't catch it") (RETURN (COND ((OVERFLOWLINE? LINE) (fetch (LINE NEXTLINE) of LINE)) (T LINE] ((BUFTAILP BUF (fetch (LINE START) of LINE) (fetch (LINE END) of LINE)) (RETURN LINE))) (OR (SETQ LINE (fetch (LINE NEXTLINE) of LINE)) (SHOULDNT]) (FIND.LINE.BREAK [LAMBDA (START END USELAST) (* bvm%: "20-FEB-82 22:35") (* ;;; "Locates a place between START and END where line can be broken. If USELAST is true, returns last such place, else first") (while (NEQ START END) do [COND ((EQ (CAR START) (CHARCODE SPACE)) (COND (USELAST (SETQ $$VAL START)) (T (RETURN START] (SETQ START (TTNEXTCHAR START]) (FIND.MATCHING.QUOTE [LAMBDA (BUF END) (* bvm%: "16-Apr-86 15:07") (* ;;; "Searches BUF until END for a closing double-quote") (while (NEQ BUF END) do (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF)) (STRINGDELIM.RC (RETURN BUF)) (ESCAPE.RC (* ; "'%%' quotes next char") (COND ((EQ (SETQ BUF (CDR BUF)) END) (RETURN)))) NIL) (SETQ BUF (CDR BUF]) (FIND.NEXT.WORD [LAMBDA (BUFTAIL N BACKUPFLG) (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Return start of Nth word after BUFTAIL, or end of line if none. BACKUPFLG means if you cross a paren getting to the Nth word, return the paren rather than the word (used for smart word-delete)") (PROG ((END (fetch (LINE END) of \ARROW))) (COND ((EQ BUFTAIL END) (RETURN END))) (SETQ BUFTAIL (CDR BUFTAIL)) LP [COND ((EQ BUFTAIL END) (RETURN END)) ((WORDSEPRP (FIRSTCHAR BUFTAIL)) (* ;  "Found a space. Now scan for first non-space, and return there") [COND (BACKUPFLG (SETQ BUFTAIL (SETQ BACKUPFLG (FIND.START.OF.WORD BUFTAIL END] (while (AND (NEQ BUFTAIL END) (WORDSEPRP (FIRSTCHAR BUFTAIL))) do (SETQ BUFTAIL (TTNEXTCHAR BUFTAIL))) (COND ((OR (NOT N) (EQ (SUB1VAR N) 0) (EQ BUFTAIL END)) (RETURN (OR BACKUPFLG BUFTAIL] (SETQ BUFTAIL (TTNEXTCHAR BUFTAIL)) (GO LP]) (FIND.NON.SPACE [LAMBDA (BUF END) (* bvm%: "11-Apr-85 15:07") (OR END (SETQ END \ENDBUFFER)) (while (AND (NEQ BUF END) (SPACEP (FIRSTCHAR BUF))) do (SETQ BUF (TTNEXTCHAR BUF))) BUF]) (FIND.START.OF.WORD [LAMBDA (BUF END) (* bvm%: "11-Apr-85 15:07") (* ;;; "Returns position of first word, i.e. non-space, in BUF before END") (OR END (SETQ END \ENDBUFFER)) (while (AND (NEQ BUF END) (WORDSEPRP (FIRSTCHAR BUF))) do (SETQ BUF (TTNEXTCHAR BUF))) BUF]) (FORWARD.DELETE.TO [LAMBDA (BUFTAIL) (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Delete from \CURSOR to BUFTAIL. Cursor does not move") [COND ((EQ BUFTAIL \CURSOR) (* ; "Nothing to do") ) ((EQ BUFTAIL \ENDBUFFER) (* ; "deleting to end is simple") (ERASE.TO.END.OF.LINE) (replace (LINE END) of \ARROW with (SETQ \ENDBUFFER \CURSOR)) (replace (LINE LASTCOL) of \ARROW with \CURSORCOL)) (T (PROG ((DELETEDWIDTH (SEGMENT.BIT.LENGTH \CURSOR BUFTAIL)) L) (COND ((EQ BUFTAIL (fetch (LINE END) of \ARROW)) (* ;  "End pointer is about to disappear into free list, so move it back here") (replace (LINE END) of \ARROW with \CURSOR) [COND ((EQ (fetch (LINE START) of (SETQ L (fetch (LINE NEXTLINE) of \ARROW))) BUFTAIL) (replace (LINE START) of L with \CURSOR) (COND ((EQ (fetch (LINE END) of L) BUFTAIL) (replace (LINE END) of L with \CURSOR] (ERASE.TO.END.OF.LINE)) (T (TTDELSECTION DELETEDWIDTH))) (KILLSEGMENT \CURSOR BUFTAIL) (replace (LINE LASTCOL) of \ARROW with (IDIFFERENCE (fetch (LINE LASTCOL) of \ARROW) DELETEDWIDTH)) (COND ((OVERFLOWLINE? \ARROW) (ADJUSTLINE.AND.RESTORE] \CURSOR]) (GO.TO.ADDRESSING [LAMBDA (COL ROW) (* bvm%: "20-Mar-84 14:50") (* ;  "Regardless of where we are now, go to logical position COL,ROW using cursor addressing") (PROG ((ABSROW (IPLUS \LOC.ROW.0 ROW))) (TTSETCURSOR COL ABSROW) (* ;; "Used to prohibit going above top, but that is ugly. Better to go up there and be clipped out of existence by the display code. Formerly: (COND ((ILESSP ABSROW 0) (* trying to go beyond top of screen; ideally we should scroll, but for now just forbid it) (SETQ ROW (IDIFFERENCE ROW ABSROW)) 0) ((NOT (ILESSP ABSROW \TTPAGELENGTH)) (* This shouldn't happen at all until we can scroll!) (SETQ ROW (IPLUS (IDIFFERENCE ROW ABSROW) \TTPAGELENGTH -1)) (SUB1 \TTPAGELENGTH)) (T ABSROW))") (SETQ \CURSORROW ROW) (SETQ \CURSORCOL COL]) (GO.TO.FREELINE [LAMBDA NIL (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Moves cursor to the first free line after the buffer, and clears it") (GO.TO.RELATIVE NIL (fetch (LINE ROW) of (TTLASTLINE))) (* ;  "Put the cursor on the last row of buffer") (TTCRLF) (* ; "And down one more") (ERASE.TO.END.OF.PAGE]) (GO.TO.RELATIVE [LAMBDA (COL ROW) (* ; "Edited 24-May-91 10:34 by jds") (* ;;; "Moves cursor to indicated row/col. ROW arg may be omitted if the movement is on the same row. If COL=LINE then ROW is interpreted as a LINE record, and destination is the start of that line") (COND ((EQ COL 'LINE) (SETQ COL (fetch (LINE FIRSTCOL) of ROW)) (SETQ ROW (fetch (LINE ROW) of ROW))) ((NOT COL) (SETQ COL \CURSORCOL)) ((NOT ROW) (SETQ ROW \CURSORROW))) (MOVETO COL (+ (TIMES (SUB1 (- \TTPAGELENGTH (+ \LOC.ROW.0 ROW))) \CHARHEIGHT) \BMARG) \DSP) (SETQ \CURSORROW ROW) (SETQ \CURSORCOL COL]) (INIT.CURSOR [LAMBDA (COL) (* ; "Edited 18-Jan-88 15:12 by bvm") (* ;;; "Initializes cursor accounting; in Interlisp-10, this assumed/forced the cursor to be in column COL of the bottom row of the screen") (PROG ((YBOT (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL \DSP))) INITY) (SETQ INITY (- (DSPYPOSITION NIL \DSP) YBOT)) (SETQ \LOC.ROW.0 (- \TTPAGELENGTH (IQUOTIENT INITY \CHARHEIGHT) 1)) (* ;; "\LOC.ROW.0 is the number of the 'line' of the first line of text, counting from the top of the window. Instead, we really should count from the bottom and fix everyone who cares") (SETQ \BMARG (+ YBOT (IREMAINDER INITY \CHARHEIGHT))) (SETQ \CURSORROW 0) (SETQ \CURSORCOL COL]) (INSERT.NODE [LAMBDA (BUF) (* bvm%: "20-FEB-82 22:34") (* ;;; "Effectively does (ATTACH garbage BUF), but reuses from the garbage heap") (COND ((EQ BUF \ENDBUFFER) (* ;  "Already at end, just push pointer") (SETQ \ENDBUFFER (TTNEXTNODE \ENDBUFFER))) (T (FRPLACD BUF (FRPLNODE2 (SCRATCHCONS) BUF]) (INSERTLINE [LAMBDA (OLDLINE USECR) (* ; "Edited 24-May-91 10:34 by jds") (* ;; "Inserts a new line between OLDLINE and the next line, whose START is the END of LINE; caller must fill in END if line is non-empty (defaults to start); USECR, if supplied, is the char to end the previous line with") (PROG ((OLDEND (fetch (LINE END) of OLDLINE)) (ROW (ADD1 (fetch (LINE ROW) of OLDLINE))) X NEWLINE) [COND (USECR (INSERT.NODE OLDEND) (FRPLACA OLDEND USECR) (SETQ OLDEND (CDR OLDEND] (TTCRLF) (COND ((NEQ OLDEND \ENDBUFFER) (* ;  "Not last line, so insert a line on screen.") (DO.INSERT.LINE 1))) (TTPROMPTCHAR) [replace (LINE NEXTLINE) of OLDLINE with (SETQ NEWLINE (create LINE START _ OLDEND END _ OLDEND FIRSTCOL _ (SETQ X \CURSORCOL) LASTCOL _ X ROW _ ROW NEXTLINE _ (fetch (LINE NEXTLINE) of OLDLINE] (RENUMBER.LINES NEWLINE ROW) (RETURN NEWLINE]) (KILL.LINES [LAMBDA (FIRSTLINE) (* bvm%: " 2-JUN-82 15:46") (* ;;; "Returns line records from FIRSTLINE onward to the heap") [PROG NIL LP (COND (FIRSTLINE (SETQ FIRSTLINE (CDR (FRPLACA FIRSTLINE 0))) (* ;  "Remove some of the circularity in the buffer") (GO LP] (FRPLACD (FLAST \ENDBUFFER) FIRSTLINE]) (KILLSEGMENT [LAMBDA (START END) (* ; "Edited 24-May-91 10:40 by jds") (* ;;; "Removes segment from START up to, but not including END. When done, START contains the contents of former cell END. I.e. any pointer to START is still valid; any pointer to END should be reset to START.") (COND ((EQ END \ENDBUFFER) (SETQ \ENDBUFFER START)) (T (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with (SETQ \LASTAIL)) (* ;  "kill last buffer markers, as they may be trashed") (FRPLNODE START (CAR END) (PROG1 (CDR END) (FRPLACD END (CDR \ENDBUFFER)) (* ;  "Cell at END will point to free list") (FRPLACD \ENDBUFFER (CDR START)) (* ;  "And this segment now is start of free list") )]) (L-CASECODE [LAMBDA (CHAR) (* lmm "16-Nov-86 13:24") (CL:CHAR-INT (CL:CHAR-DOWNCASE (CL:INT-CHAR CHAR]) (MOVE.BACK.TO [LAMBDA (BUFTAIL) (* bvm%: " 1-JUN-82 18:10") (GO.TO.RELATIVE (IDIFFERENCE \CURSORCOL (SEGMENT.BIT.LENGTH BUFTAIL \CURSOR))) (SETQ \CURSOR BUFTAIL]) (MOVE.FORWARD.TO [LAMBDA (BUFTAIL) (* bvm%: " 1-JUN-82 18:03") [GO.TO.RELATIVE (IPLUS \CURSORCOL (SEGMENT.BIT.LENGTH \CURSOR (SETQ BUFTAIL (CHECK.MARGIN BUFTAIL \ARROW] (SETQ \CURSOR BUFTAIL]) (MOVE.TO.LINE [LAMBDA (NEWLINE BUFTAIL) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Moves to indicated line at indicate buffer position (default is START), resetting \ARROW etc appropriately.") (PROG ((RELATIVE.POSITION 0)) [COND [BUFTAIL (SETQ RELATIVE.POSITION (SEGMENT.BIT.LENGTH (fetch (LINE START) of NEWLINE) (SETQ BUFTAIL (CHECK.MARGIN BUFTAIL NEWLINE] (T (SETQ BUFTAIL (fetch (LINE START) of NEWLINE] (GO.TO.RELATIVE (IPLUS (fetch (LINE FIRSTCOL) of NEWLINE) RELATIVE.POSITION) (fetch (LINE ROW) of NEWLINE)) (SETQ \CURSOR BUFTAIL) (RETURN (SETQ \ARROW NEWLINE]) (MOVE.TO.NEXT.LINE [LAMBDA NIL (* ; "Edited 24-May-91 10:35 by jds") (GO.TO.RELATIVE 'LINE (SETQ \ARROW (fetch (LINE NEXTLINE) of \ARROW))) (SETQ \CURSOR (fetch (LINE START) of \ARROW]) (MOVE.TO.START.OF.WORD [LAMBDA NIL (* bvm%: "20-FEB-82 22:34") [COND ((AT.END.OF.LINE) (MOVE.BACK.TO (PREVWORD \CURSOR))) ((SELCHARQ (CAR \CURSOR) ((%( %[) NIL) T) (* ;; "Do nothing if sitting under an open paren/bracket, since otherwise the PREVWORD below will go to the previous word, rather than selecting the 'word' which begins with the paren; in all other cases the PREVWORD will do the right thing: if under the word, goes to its start (ignoring parens), or if under a space goes to the start of the word before the space") (MOVE.BACK.TO (PREVWORD (TTNEXTCHAR \CURSOR] NIL]) (MOVE.TO.WHEREVER [LAMBDA (BUF) (* bvm%: "24-Feb-80 00:28") (* ;;; "Moves to BUF, wherever it may be.") (MOVE.TO.LINE (FIND.LINE BUF) BUF]) (NTH.COLUMN.OF [LAMBDA (LINE N) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Returns buffer tail of LINE record which best approximates the Nth printing column of that line") (NTH.RELATIVE.COLUMN.OF LINE (IDIFFERENCE N (fetch (LINE FIRSTCOL) of LINE]) (NTH.RELATIVE.COLUMN.OF [LAMBDA (LINE N) (* ; "Edited 24-May-91 11:10 by jds") (* ;; "Returns buffer tail in LINE which represents the Nth printing character on the line. Returns start or end of buffer if out of range. If the nth char is a pad char, returns the start of the pad char sequence") (COND ((NOT (IGREATERP N 0)) (fetch (LINE START) of LINE)) (T (for WIDTH CH (BUF _ (fetch (LINE START) of LINE)) (END _ (fetch (LINE END) of LINE)) do [COND ((EQ BUF END) (* ; "Ran off the end, so quit") (RETURN END)) (T (COND ([ILESSP N (SETQ WIDTH (COND ((COMPLEXCHARP (SETQ CH (CAR BUF))) (fetch (COMPLEXCHAR CPXWIDTH) of CH)) (T (TTBITWIDTH CH] (RETURN BUF))) (SETQ N (IDIFFERENCE N WIDTH] (SETQ BUF (CDR BUF]) (OVERFLOW? [LAMBDA (WIDTH) (* ; "Edited 24-May-91 10:35 by jds") (* ;; "If typing WIDTH more chars would cause this line to overflow, starts new line (or simply goes to next line when N=0)") (COND ((NOT (ILESSP (IPLUS \CURSORCOL WIDTH) \RMARG)) (COND [(AT.END.OF.LINE) (PROG ((OLDLINE \ARROW)) (START.NEW.LINE) (COND ((AND \AUTOFILL DISPLAYTERMFLG) (* ;  "Hit the margin in the middle of a word. Try to move that word intact to the new line") (ADJUSTLINE 1 OLDLINE) (GO.TO.RELATIVE (fetch (LINE LASTCOL) of \ARROW) (fetch (LINE ROW) of \ARROW] ((EQ WIDTH 0) (MOVE.TO.NEXT.LINE)) (T (BREAKLINE]) (OVERFLOWLINE? [LAMBDA (LINE) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "True if LINE overflows into next line, rather than ending in a cr") (EQ (fetch (LINE END) of LINE) (fetch (LINE START) of (fetch (LINE NEXTLINE) of LINE]) (PREVLINE [LAMBDA (LINE N) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Backs up N lines in buffer before LINE, as far as start of buffer. i.e. an NLEFT on line records.") (PROG ((X \FIRSTLINE) (L \FIRSTLINE)) LP (* ; "Advance X by N chars") (COND ((EQ N 0) (GO LP1)) ((OR (EQ X LINE) (NULL X)) (* ;  "The NULL case should never happen, but better be safe") (RETURN L))) (SETQ X (fetch (LINE NEXTLINE) of X)) (SUB1VAR N) (GO LP) LP1 (* ;  "Now advance X and L in parallel until X reaches LINE, at which point L is N before it") (COND ((OR (EQ X LINE) (NULL X)) (RETURN L))) (SETQ X (fetch (LINE NEXTLINE) of X)) (SETQ L (fetch (LINE NEXTLINE) of L)) (GO LP1]) (PREVWORD [LAMBDA (BUF N START) (* ; "Edited 24-May-91 10:35 by jds") (OR START (SETQ START (fetch (LINE START) of \ARROW))) (for (X _ START) (NEW _ T) (%#HITS _ 0) by (TTNEXTCHAR X) until (EQ X BUF) do (* ;;  "Return start of the Nth word in line before BUF, or beginning of line if no such word") (COND ((WORDSEPRP (FIRSTCHAR X)) (* ; "Space between words") (SETQ NEW T)) (NEW (SETQ $$VAL X) (* ; "Start of new word") (SETQ NEW NIL) (ADD1VAR %#HITS))) finally (RETURN (COND ((OR (NOT N) (EQ N 1) (EQ %#HITS 0)) (OR $$VAL START)) ((ILESSP (SETQ N (IDIFFERENCE %#HITS N )) 0) (* ;  "N was greater than #words in buffer") START) ((EQ N 0) (FIND.START.OF.WORD START)) (T (FIND.NEXT.WORD (  FIND.START.OF.WORD START) N]) (PROPERTAILP [LAMBDA (X Y) (* bvm%: " 4-Aug-78 12:03") (* ;;; "true if X is a PROPER tail of Y") (AND X (NEQ X Y) (BUFTAILP X Y]) (READFROMBUF [LAMBDA (START END COPYFLG) (* ; "Edited 24-May-91 11:10 by jds") (* ;; "Unreads the chars in the buffer from START to END. The cells are returned to the free pool as they are used to reduce the storage demands on large unreads. Multichar sequences in buffer are unread as just their 'real' characters") (PROG (FIXUP CH) [COND ([AND (NOT (AT.END.OF.LINE)) (for (BUF _ START) by (CDR BUF) until (EQ BUF END) thereis (EQ (CAR BUF) (CHARCODE EOL] (* ;; "An insertion that contains a cr. This will look awful if we have to keep shoving text in front of us, so break the line first, then unbreak it at end") (BREAKLINE (CHARCODE SPACE) (SETQ FIXUP T] (until (EQ START END) do [COND ((COMPLEXCHARP (SETQ CH (CAR START))) (SETQ CH (fetch (COMPLEXCHAR CPXREALCHAR) of CH] (COND ((NEQ CH EOLCHARCODE) (ADDNAKEDCHAR CH T)) ((NOT (AT.END.OF.LINE)) (* ; "Insert EOL in middle of line") (BREAKLINE EOLCHARCODE)) ((OR (NEQ (CDR START) END) (NOT (AT.END.OF.TEXT \CURSOR))) (* ;  "EOL. Start new line. Ignore it if this is a terminating eol") (START.NEW.LINE EOLCHARCODE))) (SETQ START (CDR START))) (COND (FIXUP (* ; "Kill the cr we inserted") (MOVE.TO.WHEREVER (PROG1 \CURSOR (DELETE.LONG.SEGMENT1 \ARROW \CURSOR (fetch (LINE NEXTLINE) of \ARROW) (TTNEXTCHAR \CURSOR)))]) (RENUMBER.LINES [LAMBDA (LINE ROW) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Renumbers lines from LINE onward, giving LINE the value ROW") (while LINE do (replace (LINE ROW) of LINE with ROW) (ADD1VAR ROW) (SETQ LINE (fetch (LINE NEXTLINE) of LINE]) (RESTORE.CURSOR [LAMBDA NIL (* lmm "20-Nov-86 00:27") (GO.TO.RELATIVE \HOMECOL \HOMEROW]) (RESTOREBUF [LAMBDA NIL (* ; "Edited 24-May-91 10:41 by jds") (* ;; "recover previous buffer, which extends to either our current LASTAIL, if user has done deletions on this line, or previous LASTAIL, stored in the front of the buffer. If neither, then recover last thing zapped with the mouse") (PROG (TAIL) (COND ([AND (AT.END.OF.BUF) (SETQ TAIL (OR (AND \LASTAIL (IGEQ \LASTAILROW (fetch (LINE ROW) of \ARROW )) (OR (IGREATERP \LASTAILCOL \CURSORCOL) (IGREATERP \LASTAILROW (fetch (LINE ROW) of \ARROW ))) (PROPERTAILP \LASTAIL \ENDBUFFER)) (PROPERTAILP (fetch (TTYINBUFFER OLDTAIL) of \TTYINSTATE ) \ENDBUFFER] (END.DELETE.MODE) (READFROMBUF [CONS (CAR \ENDBUFFER) (PROG1 (CDR \ENDBUFFER) (* ;  "now detach buffer from here to TAIL to avoid conflict") (FRPLNODE \ENDBUFFER 0 (CDR TAIL)))] TAIL) (SETQ \LASTAIL \ENDBUFFER) (SETQ \LASTAILCOL \CURSORCOL) (SETQ \LASTAILROW (fetch (LINE ROW) of \ARROW)) (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with NIL)) (\LAST.DELETION (READFROMBUF \LAST.DELETION NIL T) (ADJUSTLINE.AND.RESTORE T)) (T (* ;  "Can't find where buffer ended; perhaps we have written past it") (BEEP]) (RETYPE.BUFFER [LAMBDA (LINE LASTLINE FROM.HERE) (* ; "Edited 24-May-91 10:35 by jds") (* ;; "Refreshes buffer starting with LINE for one line, or going to LASTLINE, where LASTLINE=T means end of buffer. Moves cursor to start of LINE (based on where we think we might be now) unless FROM.HERE is set. FROM.HERE is set when retyping whole buffer with the current cursor position defined as 0,0; in this case, the cursor is restored on completion to wherever it was last saved, rather than its current position") (PROG* ((ROW (fetch (LINE ROW) of LINE)) (COL0 (if (EQ ROW 0) then \INITPOS else \LMARG)) L) (SETQ \DELETING) (BINARY.MODE) [COND (FROM.HERE (INIT.CURSOR COL0)) (T (SAVE.CURSOR) (PROGN (* ;  "position cursor at start of line") (CANCEL.MODES) (* ;  "in case an funny terminal setting occurred, say because of noise") (if (EQ ROW 0) then (* ;  "If reprinting from the top, restore \LOC.ROW.0 to its original value") (SETQ \LOC.ROW.0 (- \LOC.ROW.0 \INITCRLFS))) (GO.TO.ADDRESSING COL0 ROW] LP (TTPROMPTCHAR LINE) (TYPE.BUFFER (fetch (LINE START) of LINE) (fetch (LINE END) of LINE)) (COND ((AND LASTLINE (SETQ L (fetch (LINE NEXTLINE) of LINE)) (NEQ L LASTLINE)) (SETQ LINE L) (TTCRLF) (ADD1VAR ROW) (GO LP))) (COND ((EQ LASTLINE T) (* ;  "kill any text that might be below bottom line") (ERASE.TO.END.OF.PAGE))) (RESTORE.CURSOR]) (SAVE.CURSOR [LAMBDA NIL (* bvm%: "11-MAR-81 21:40") (SETQ \HOMEROW \CURSORROW) (SETQ \HOMECOL \CURSORCOL]) (SCANBACK [LAMBDA (CHAR BUF N START) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Searches back for Nth previous occurrence of CHAR in buffer before BUF, returning NIL if there are no occurrences. Scan terminates at START, default is start of line; default N is 1; if there are fewer than N occurrences, returns the earliest one it can") (for [X _ (OR START (SETQ START (fetch (LINE START) of \ARROW] (%#HITS _ 0) by (TTNEXTCHAR X) until (EQ X BUF) do (COND ((EQ (U-CASECODE (FIRSTCHAR X)) CHAR) (SETQ $$VAL X) (ADD1VAR %#HITS))) finally (RETURN (COND ((OR (NOT N) (EQ N 1) (EQ %#HITS 0) (EQ %#HITS 1)) $$VAL) (T (* ;  "There are #HITS occurrences of CHAR, and we want the Nth from the end") (SCANFORWARD CHAR START (ADD1 (IMAX (IDIFFERENCE %#HITS N) 0)) BUF]) (SCANFORWARD [LAMBDA (CHAR BUF N END) (* ; "Edited 24-May-91 10:35 by jds") (* ;;; "Finds Nth occurrence of CHAR in BUF before END. Default END is end of current line; default N is 1; CHAR should be uppercase if a letter") (OR N (SETQ N 1)) (OR END (SETQ END (fetch (LINE END) of \ARROW))) (while (NEQ BUF END) do [COND ((EQ (U-CASECODE (FIRSTCHAR BUF)) CHAR) (COND ((EQ (SUB1VAR N) 0) (RETURN BUF)) (T (SETQ $$VAL BUF] (SETQ BUF (TTNEXTCHAR BUF]) (SCRATCHCONS [LAMBDA NIL (* ; "Edited 24-May-91 10:41 by jds") (* ;;; "Returns a garbage cons from the heap at the end of the buffer, or a fresh cons if none available") (replace (TTYINBUFFER OLDTAIL) of \TTYINSTATE with (SETQ \LASTAIL)) (* ;  "Wipe out last buffer ptrs, as this may trash them") (PROG1 (OR (CDR \ENDBUFFER) (CONS)) (FRPLACD \ENDBUFFER (CDDR \ENDBUFFER)))]) (SEGMENT.LENGTH [LAMBDA (START END) (* ; "Edited 24-May-91 11:11 by jds") (* ;;; "Returns number of print positions in buffer from START to END") (PROG ((N 0)) LP (COND ((EQ START END) (RETURN N))) (add N (COND ((COMPLEXCHARP (CAR START)) (fetch (COMPLEXCHAR CPXNCHARS) of (CAR START))) (T 1))) (SETQ START (CDR START)) (GO LP]) (SEGMENT.BIT.LENGTH [LAMBDA (START END) (* ; "Edited 24-May-91 11:11 by jds") (* ;;; "Returns number of print positions in bits in buffer from START to END") (PROG ((N 0)) LP (COND ((EQ START END) (RETURN N))) [add N (COND ((COMPLEXCHARP (CAR START)) (fetch (COMPLEXCHAR CPXWIDTH) of (CAR START))) (T (FCHARWIDTH (CAR START) \FONT] (SETQ START (CDR START)) (GO LP]) (SETLASTC [LAMBDA (CHAR) (* bvm%: "10-APR-81 23:28") (* ;; "Makes CHAR be LASTC for T. This is a kludge; I should be interfacing better with \LINEBUF.OFD at a more fundamental level.") (\BOUT \LINEBUF.OFD CHAR]) (SETTAIL? [LAMBDA (EVEN.IF.NOT.THERE) (* ; "Edited 24-May-91 10:35 by jds") (* ;; "If \ENDBUFFER is farther than we've been before, save this position on LASTAIL. If EVEN.IF.NOT.THERE is set, do this even if cursor is not currently at the end") (COND ([AND (NOT \DELETING) (NOT (EMPTY.BUFFER)) (OR EVEN.IF.NOT.THERE (EQ \CURSOR \ENDBUFFER)) (OR (NOT \LASTAIL) (OR (ILESSP \LASTAILROW (fetch (LINE ROW) of \ARROW)) (AND (ILESSP \LASTAILCOL \CURSORCOL) (ILEQ \LASTAILROW (fetch (LINE ROW) of \ARROW] (SETQ \LASTAIL \ENDBUFFER) (SETQ \LASTAILCOL \CURSORCOL) (SETQ \LASTAILROW (fetch (LINE ROW) of \ARROW]) (SHOW.MATCHING.PAREN [LAMBDA (BUF) (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Indicates parenthesis nesting by briefly moving the cursor to the paren that matches the paren at BUF, if that position is still on the screen. The cursor stays there for SHOWPARENFLG seconds, or until there is input from the user. Assumes terminal has cursor addressability") (PROG ((MATCHING (BACKSKREAD BUF T)) LINE ROW COL) (* ;  "MATCHING is the buffer position that matches BUF, or NIL if this paren was quoted somehow.") (OR MATCHING (RETURN)) (SETQ LINE (FIND.LINE MATCHING)) (* ;  "The buffer LINE on which it appears") (COND ((< (+ (SETQ ROW (fetch (LINE ROW) of LINE)) \LOC.ROW.0) 0) (* ; "Not on screen, so forget it") (RETURN))) (SETQ COL (+ (SEGMENT.BIT.LENGTH (fetch (LINE START) of LINE) MATCHING) (fetch (LINE FIRSTCOL) of LINE))) (* ; "The absolute column position") (COND ((TYPEAHEAD?) (* ;; "After all this computation, there is now input waiting, so don't do anything. Didn't do this earlier, since the SIBE itself takes time, and is likely to fail when done immediately after reading the closing paren") (RETURN))) (SAVE.CURSOR) (GO.TO.ADDRESSING COL ROW) (* ;  "Go to absolute coordinates of matching paren") (TTWAITFORINPUT (COND ((FIXP SHOWPARENFLG) (TIMES SHOWPARENFLG 1000)) (T 1000))) (* ; "Wait a while to let user see it") (\CHECKCARET \DSP) (* ;  "Tell background we moved the cursor") (RESTORE.CURSOR) (* ;  "Put cursor back where it belongs") ]) (SKIP/ZAP [LAMBDA (CMD CHAR N MINUS) (* ; "Edited 24-May-91 10:41 by jds") (* ;; "Performs S or Z, i.e. skip or zap to character. CMD is S, Z, B, or -Z (latter two are backward versions of the first two); CHAR is the target character, N is a repeat arg and MINUS is its sign. Last such operation is saved on LASTSKIP so that A can repeat it") (SETQ CHAR (U-CASECODE CHAR)) (* ; "Ignore case differences") [COND (MINUS (* ; "invert command") (SETQ CMD (SELECTC CMD ((CHARCODE S) (CHARCODE B)) ((CHARCODE B) (CHARCODE S)) ((CHARCODE Z) (IMINUS (CHARCODE Z))) ((IMINUS (CHARCODE Z)) (CHARCODE Z)) (SHOULDNT] (COND ([SETQ N (SELECTC CMD ((CHARCODE B) (SCANBACK CHAR \CURSOR N)) ((IMINUS (CHARCODE Z)) (SCANBACK CHAR (TTNLEFT \CURSOR 1) N)) (AND (NOT (AT.END.OF.LINE)) (SCANFORWARD CHAR (TTNEXTCHAR \CURSOR) N] (SELECTC CMD ((CHARCODE S) (* ; "S") (MOVE.FORWARD.TO N)) ((CHARCODE Z) (* ; "Z") (FORWARD.DELETE.TO N)) ((CHARCODE B) (* ; "B") (MOVE.BACK.TO N)) ((IMINUS (CHARCODE Z)) (* ; "-Z") [FORWARD.DELETE.TO (PROG1 (COND ((AT.END.OF.LINE) \CURSOR) (T (TTNEXTCHAR \CURSOR))) (MOVE.BACK.TO (TTNEXTCHAR N)))]) (SHOULDNT))) (T (BEEP))) (replace (TTYINBUFFER LASTSKIP) of \TTYINSTATE with CMD) (replace (TTYINBUFFER LASTSKIPCHAR) of \TTYINSTATE with CHAR]) (START.NEW.LINE [LAMBDA (USECR) (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Handles moving to new line. USECR, if set, is the character that should terminate current line") (SETQ \CURSOR (fetch (LINE START) of (SETQ \ARROW (INSERTLINE \ARROW USECR]) (START.OF.PARAGRAPH? [LAMBDA (LINE) (* ; "Edited 24-May-91 11:11 by jds") (OR (EQ (fetch (LINE END) of LINE) (SETQ LINE (fetch (LINE START) of LINE))) (AND (COMPLEXCHARP (CAR LINE)) (EQ (fetch (COMPLEXCHAR CPXREALCHAR) of (CAR LINE)) (CHARCODE TAB]) (TTADJUSTWORD [LAMBDA (WORD) (* ; "Edited 20-Jan-88 12:33 by bvm") (* ;;; "Returns WORD, possibly corrected, according to the spelling list, if any. Returns NIL if FIX was specified and the word fails.") (LET (X) (COND ((OR (NULL SPLST) (FMEMB WORD '(%( %) %[ %] %" %,)) (FMEMB WORD SPLST)) WORD) ((AND WORD (SETQ X (FASSOC WORD SPLST))) (* ;  "Is synonym. FASSOC assumes car of atom is NIL") (CDR X)) ([AND SPLST (LITATOM WORD) (NEQ \NOFIXSPELL 'NOFIXSPELL) (SETQ X (FIXSPELL WORD 70 SPLST (AND \NOFIXSPELL T] (* ; "respelled okay") X) (\FIX (TTPRIN1 WORD) (TTPRIN1 '?) (COND (HELP (TTGIVEHELP HELP)) (T (TTPRIN1 " please try again."))) (TTCRLF) NIL) (T WORD]) (TTBIN [LAMBDA (NOMETA) (* ; "Edited 18-Jan-88 15:13 by bvm") (* ;;; "Read the next char from terminal, return its character code. Sets \EDITBIT true or false according to whether char is meta. If NOMETA is true, the meta bit is discarded") (PROG ((CHAR (TTWAITFORINPUT NIL T))) [COND ((EQ CHAR EDITPREFIXCHAR) (* ; "edit prefix") (SETQ CHAR (\GETKEY)) [COND ((EQ CHAR EDITPREFIXCHAR) (* ;  "Two edits in a row = Edit-Escape") (SETQ CHAR (CHARCODE ESCAPE] (SETQ CHAR (METACHAR CHAR] [COND ((AND NOMETA (METACHARP CHAR)) (* ;  "Had meta key down, remove bit. This is useful for inside Edit commands") (SETQ CHAR (NONMETACHARBITS CHAR] (\CHECKCARET \DSP) (* ;  "Turn off the caret, since we will probably move") (RETURN CHAR]) (TTBITWIDTH [LAMBDA (CHAR) (* ; "Edited 17-Jan-88 16:04 by bvm:") (FCHARWIDTH CHAR \FONT]) (TTCRLF [LAMBDA NIL (* lmm "16-Nov-86 04:13") (* ;;; "Prints a crlf, updating cursor appropriately") (DO.CRLF) (TTCRLF.ACCOUNT]) (TTCRLF.ACCOUNT [LAMBDA NIL (* ; "Edited 18-Jan-88 15:41 by bvm") (SETQ \CURSORROW (ADD1 \CURSORROW)) [COND ((EQ (+ \LOC.ROW.0 \CURSORROW) \TTPAGELENGTH) (* ;  "This crlf glitched the screen, so row 0 has moved up one") (SETQ \LOC.ROW.0 (SUB1 \LOC.ROW.0)) (* ;  "We are also now guaranteed to be on the bottom row of the window") (SETQ \BMARG (DSPYPOSITION NIL \DSP] (SETQ \CURSORCOL \LMARG]) (TTDELETECHAR [LAMBDA NIL (* ; "Edited 24-May-91 10:36 by jds") (COND ((AT.START.OF.BUF) (BEEP)) [(AT.END.OF.LINE) (COND [(AT.START.OF.LINE) (* ;  "empty line: need to delete to previous line") (PROG ((PREV (PREVLINE \ARROW 1)) DODELETE) (SETQ DODELETE (OVERFLOWLINE? PREV)) (DELETELINE \ARROW) (* ; "get rid of this line") (MOVE.TO.LINE PREV (fetch (LINE END) of PREV)) (* ; "go to end of previous line") (COND (DODELETE (* ;  "We were on overflow line, so have to delete the last char, too") (DELETETO (TTNLEFT \CURSOR 1] (T (DELETETO (TTNLEFT \CURSOR 1] (T (TTRUBOUT]) (TTDELETELINE [LAMBDA NIL (* ; "Edited 24-May-91 10:36 by jds") (COND ((EMPTY.BUFFER) (BEEP)) [(EMPTY.LINE) (* ;  "Empty line: delete previous line if at end") (COND ((AT.END.OF.BUF) (MOVE.TO.LINE (PREVLINE \ARROW 1)) (COND ((NOT DISPLAYTERMFLG) (TTBOUT _) (DO.CRLF))) (DELETE.TO.END)) (T (BEEP] (T (SETTAIL? T) (COND ((NOT DISPLAYTERMFLG) (TTBOUT %# %#) (* ;  "On non-display just print ## and return to initial position") [replace (LINE END) of \ARROW with (SETQ \CURSOR (SETQ \ENDBUFFER (fetch (LINE START) of \ARROW] (replace (LINE LASTCOL) of \ARROW with (fetch (LINE FIRSTCOL) of \ARROW)) (RETYPE.BUFFER \ARROW)) ((AT.END.OF.LINE) (* ;  "kill back to start of line. This can work on glass tty, too, whereas next clause doesn't") (DELETETO (fetch (LINE START) of \ARROW))) (T (* ;  "We're inside line, so go back to start and then zap whole line") (MOVE.BACK.TO (fetch (LINE START) of \ARROW)) (FORWARD.DELETE.TO (fetch (LINE END) of \ARROW]) (TTDELETEWORD [LAMBDA (N) (* ; "Edited 24-May-91 10:36 by jds") (COND ((AT.START.OF.BUF) (BEEP)) (T (LET ((TAIL (PREVWORD \CURSOR N)) PREVL START) (SETTAIL?) (COND ((EQ TAIL \CURSOR) (DELETE.LONG.SEGMENT1 (SETQ PREVL (PREVLINE \ARROW 1)) (SETQ START (PREVWORD \CURSOR N (fetch (LINE START) of PREVL))) \ARROW \CURSOR) (MOVE.TO.WHEREVER START)) (T (BACKWARD.DELETE.TO TAIL]) (TTECHO.TO.FILE [LAMBDA (FILE DRIBBLING) (* ; "Edited 24-May-91 11:11 by jds") (* ;;; "Echos input to FILE. If DRIBBLING is true, the prompts are also echoed") (for (STREAM _ (GETSTREAM FILE 'OUTPUT)) (LINE _ \FIRSTLINE) (FIRSTIME _ T) X CH END do (COND ([AND DRIBBLING (SETQ X (COND (FIRSTIME (* ; "Print the first prompt") (SETQ FIRSTIME NIL) (AND \PROMPT1 (NOT (EQMEMB 'NOPROMPT OPTIONS)) \PROMPT1)) (T \PROMPT2] (PRIN1 X FILE))) (SETQ END (fetch (LINE END) of LINE)) (SETQ X (fetch (LINE START) of LINE)) (until (EQ X END) do [COND ([NOT (COMPLEXCHARP (SETQ CH (CAR X] (BOUTCCODE STREAM CH)) [(EQ (fetch (COMPLEXCHAR CPXREALCHAR) of CH) (CHARCODE SPACE)) (* ;; "pseudo-tab kludge: instead of printing the 'real' character, ignore it and print only its padding spaces") (FRPTQ (fetch (COMPLEXCHAR CPXNCHARS) of CH) (BOUTCCODE STREAM (CHARCODE SPACE] (T (BOUTCCODE STREAM (fetch (COMPLEXCHAR CPXREALCHAR) of CH] (SETQ X (TTNEXTCHAR X))) (SETQ LINE (fetch (LINE NEXTLINE) of LINE)) (COND ((AND (OR DRIBBLING (NEQ (fetch (LINE START) of LINE) END)) (NOT \PROMPTFORWORD)) (* ;; "Don't terpri on overflow line, since user didn't; except always do it to dribblefile, since that's what's on the screen. Promptforword-style input doesn't have terminating cr.") (TERPRI FILE))) repeatwhile (AND LINE (OR (EQ END \ENDBUFFER) (PROGN (* ;  "Avoid echoing the terminating empty line, except when it is an empty overflow line") (NEQ (fetch (LINE START) of LINE) \ENDBUFFER]) (TTGIVEHELP [LAMBDA (HELPKEY) (* ; "Edited 19-Jan-88 19:09 by bvm") (PROG ((*STANDARD-OUTPUT* \DSP)) (TERPRI) (COND ((EQ HELPKEY T) (TTGIVEHELP1)) [(LISTP HELPKEY) (COND ((EQ (CAR HELPKEY) T) (* ;  "List SPLST first, then subsequent blurb") (TTGIVEHELP1 T) (PRIN1 '% ) (TTGIVEHELP2 (CDR HELPKEY) T)) ((EQ (CDR HELPKEY) T) (* ; "Similar, but blurb first") (TTGIVEHELP2 (CAR HELPKEY) T) [COND ((NEQ (POSITION) 0) (PRIN1 '% ] (TTGIVEHELP1 T T)) (T (TTGIVEHELP2 HELPKEY] (T (TTGIVEHELP2 HELPKEY))) (COND ((NEQ (POSITION) 0) (TERPRI))) (TERPRI) (RETURN T]) (TTGIVEHELP1 [LAMBDA (NO.OTHER NO.INTRO) (* bvm%: "11-MAR-81 21:36") (COND (SPLST (OR NO.INTRO (PRIN1 "Please select from among ")) (for X on SPLST unless (OR (EQ X SPELLSTR1) (EQ X SPELLSTR2)) do (PRIN1 (INPART (CAR X))) (AND (CDR X) (PRIN1 ", "))) (COND ((NOT NO.OTHER) (OR \FIX (PRIN1 ", or other")) (TERPRI]) (TTGIVEHELP2 [LAMBDA (HELPKEY MIXED) (* bvm%: " 8-Aug-80 00:14") (COND [[OR (LITATOM HELPKEY) (AND (STRINGP HELPKEY) (NOT (STRPOS '% HELPKEY] (* ;  "Atom or spaceless string is a hashfile key") (COND ((NOT (DISPLAYHELP HELPKEY)) (OR MIXED (PRIN1 "Sorry, no help available."] (T (SPRINTT HELPKEY (COND (MIXED (* ; "no extra space") 0) (T 4)) 4 0]) (TTLASTLINE [LAMBDA NIL (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Returns last LINE record in buffer") (PROG ((LINE \FIRSTLINE) L) LP (COND ((SETQ L (fetch (LINE NEXTLINE) of LINE)) (SETQ LINE L) (GO LP))) (RETURN LINE]) (TTLOADBUF [LAMBDA (BUF) (* ; "Edited 8-Feb-88 12:54 by bvm:") (* ;; "BUF is a list, a la READBUF, which is loaded into our character buffer, using DCHCON to convert the s-expressions therein to char codes. If we are READING, then uses PRIN2 pnames, i.e. includes escape chars and such stuff. Alternatively, BUF may be a string, in which case its contents are also loaded into the buffer, a la BKSYSBUF, and the setting of \READING is irrelevant") (COND [(EQ (CAR (LISTP BUF)) HISTSTR1) (* ;  "read from file. BUF is ( (file start . end))") (SETQ BUF (CADR BUF)) (SETFILEPTR (CAR BUF) (CADR BUF)) (bind CHAR NEXTCH (STREAM _ (GETSTREAM (CAR BUF) 'INPUT)) (END _ (CDDR BUF)) while (< (GETFILEPTR STREAM) END) do (* ; "Read another character. Unfortunately, we have to go by file pointer to determine end, since stream could have ns chars in it") (COND ((NEQ (SETQ CHAR (BINCCODE STREAM)) (CHARCODE CR)) (ADDNAKEDCHAR CHAR T)) (T (* ; "eat up lf after the cr") (COND ([OR (>= (GETFILEPTR STREAM) END) (PROGN (SETQ NEXTCH (BINCCODE STREAM)) (AND (EQ NEXTCH (CHARCODE LF)) (>= (GETFILEPTR STREAM) END] (* ; "Ignore final CR") (RETURN))) (ADDNAKEDCHAR CHAR) (COND ((NEQ NEXTCH (CHARCODE LF)) (ADDNAKEDCHAR NEXTCH] (T (PROG (START END) [COND ((AND (LISTP BUF) (SETQ START (FMEMB HISTSTR0 BUF))) (* ;  "HISTSTR0 is a marker used by lispx to denote end of line") (FRPLACD (NLEFT BUF 1 START] (SETQ START (DCHCON BUF (CDR \ENDBUFFER) (AND (LISTP BUF) \READING) RDTBL)) (* ;  "Use our own buffer as a scratchlist for DCHCON as long as it's lying around anyway.") [COND ((LISTP BUF) (* ;  "Remove the surrounding parens from the outer list") (SETQ END (NLEFT (SETQ START (CDR START)) 1] (* ;; "now detach the result from our buffer to avoid conflict of interest. If DCHCON found our scratchlist inadequate, START will not be a tail of \ENDBUFFER so the NLEFT below comes out NIL, which is also fine") (FRPLACD (NLEFT \ENDBUFFER 1 START)) (* ; "Now unread the CHCON list.") (READFROMBUF START END]) (TTNEXTLINE [LAMBDA (LINE N) (* ; "Edited 24-May-91 10:36 by jds") (bind L while (AND (NEQ N 0) (SETQ L (fetch (LINE NEXTLINE) of LINE))) do (SETQ LINE L) (SUB1VAR N) finally (RETURN LINE]) (TTNEXTNODE [LAMBDA (BUF) (* bvm%: " 2-JUN-82 15:44") (* ;;; "Returns cdr of BUF, tacking on a new cons if the cdr was NIL") (OR (CDR BUF) (CDR (FRPLACD BUF (CONS 0]) (TTNLEFT [LAMBDA (BUF N START) (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Backs up N real characters in this line before BUF as far as START, default being the current start of the line. Assumes BUF is a tail of line and N is small") (OR START (SETQ START (fetch (LINE START) of \ARROW))) (PROG ((X START) (B START)) LP (* ; "Advance X by N chars") (COND ((EQ N 0) (GO LP1)) ((OR (EQ X BUF) (NULL X)) (* ;  "The NULL case should never happen, but better be safe") (RETURN B))) (SETQ X (TTNEXTCHAR X)) (SUB1VAR N) (GO LP) LP1 (* ;  "Now advance X and B in parallel until X reaches BUF, at which point B is N before it") (COND ((OR (EQ X BUF) (NULL X)) (RETURN B))) (SETQ X (TTNEXTCHAR X)) (SETQ B (TTNEXTCHAR B)) (GO LP1]) (TTNTH [LAMBDA (BUF N) (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Advances N real characters in BUF as far as the end of the line") (bind (END _ (fetch (LINE END) of \ARROW)) while (AND (NEQ N 0) (NEQ BUF END)) do (SETQ BUF (TTNEXTCHAR BUF)) (SUB1VAR N) finally (RETURN BUF]) (TTNTHLINE [LAMBDA (N) (DECLARE (USEDFREE \FIRSTLINE)) (* ; "Edited 24-May-91 10:36 by jds") (for (LINE _ \FIRSTLINE) do (COND ((ILEQ N 0) (RETURN LINE)) (T (SETQ N (SUB1 N)) (SETQ LINE (OR (fetch (LINE NEXTLINE) of LINE) (RETURN LINE]) (TTPRIN1 [LAMBDA (STR DOWNCASE INITP) (* ; "Edited 20-Jan-88 10:52 by bvm") (* ;;; "PRIN1 of STR, atom or string, directly to the terminal, bypassing any dribble file. Returns the number of crlfs it did.") (if (AND DOWNCASE (NOT (U-CASEP STR))) then (SETQ DOWNCASE NIL)) (PROG ((CRLFCOUNT 0) CH WIDTH) (if (OR INITP (EQ \CURSORCOL \LMARG)) then (* ; "If starting at left margin, we might as well start printing. This handles the otherwise unpleasant case of STR being wider than the window") (GO ONE.AT.A.TIME)) (* ;; "See if we have space first") (COND ((>= [+ \CURSORCOL (SETQ WIDTH (for I from 1 while (SETQ CH (NTHCHARCODE STR I)) sum (if (EQ CH (CHARCODE CR)) then (* ;  "I don't know how to handle strings with cr in them. Punt...") (GO ONE.AT.A.TIME)) (CHARWIDTH (if DOWNCASE then (L-CASECODE CH) else CH) \DSP] \RMARG) (* ;  "We would go past the right margin") (if (> WIDTH (- \RMARG \LMARG)) then (* ;  "It wouldn't fit even at the left, so go start printing") (GO ONE.AT.A.TIME)) (add CRLFCOUNT 1) (TTCRLF))) (for I from 1 while (SETQ CH (NTHCHARCODE STR I)) do (TTBOUT (if DOWNCASE then (L-CASECODE CH) else CH))) (add \CURSORCOL WIDTH) (GO DONE) ONE.AT.A.TIME (* ;; "Print chars one at a time. This handles initial prompts, as well as strings that are wider than the window.") (for I from 1 while (SETQ CH (NTHCHARCODE STR I)) do (if (EQ CH (CHARCODE CR)) then (TTCRLF) (add CRLFCOUNT 1) else (if (> (add \CURSORCOL (CHARWIDTH (SETQ CH (if DOWNCASE then (L-CASECODE CH) else CH)) \DSP)) \RMARG) then (* ; "Out of space") (TTCRLF) (add CRLFCOUNT 1) (add \CURSORCOL (CHARWIDTH CH \DSP))) (TTBOUT CH))) DONE (RETURN CRLFCOUNT]) (TTPRINSPACE [LAMBDA (N) (* ; "Edited 18-Jan-88 23:57 by bvm:") (OR N (SETQ N 1)) (if (>= (+ \CURSORCOL N) \RMARG) then (TTCRLF) else (RPTQ N (TTBOUT SPACE)) (add \CURSORCOL (TIMES N (CHARWIDTH (CHARCODE SPACE) \DSP]) (TTPRIN1COMMENT [LAMBDA (STR DOWNCASE) (* ; "Edited 16-Jan-88 16:55 by bvm:") (* ;; "TTPRIN1 of STR in the comment, rather than default, font.") (DSPFONT (PROG1 (DSPFONT \COMMENTFONT T) (TTPRIN1 STR DOWNCASE)) T]) (TTPRIN2 [LAMBDA (EXPR CARLVL CDRLVL) (* ; "Edited 16-Jan-88 18:01 by bvm:") (CL:TYPECASE EXPR [LISTP (OR CARLVL (SETQ CARLVL 10)) (OR CDRLVL (SETQ CDRLVL 10)) (LET (FIRST WRAPPER) (COND ((<= CARLVL 0) (TTPRIN1 '%#)) ((AND (LITATOM (SETQ FIRST (CAR EXPR))) (SETQ WRAPPER (GET FIRST 'PRETTYWRAPPER)) (LISTP (CDR EXPR)) (NULL (CDDR EXPR)) (SETQ WRAPPER (CL:FUNCALL WRAPPER EXPR))) (* ; "This handles quote and friends") (TTPRIN1 WRAPPER) (TTPRIN2 (CADR EXPR) CARLVL CDRLVL)) (T (TTPRIN1 '%() [do (TTPRIN2 (CAR EXPR) (SUB1 CARLVL) (SUB1 CDRLVL)) (COND ((NLISTP (SETQ EXPR (CDR EXPR))) (COND (EXPR (TTPRIN1 " . ") (TTPRIN2 EXPR))) (RETURN)) (T (TTPRIN1 '% ) (COND ((<= (SETQ CDRLVL (SUB1 CDRLVL)) 0) (TTPRIN1 "...") (RETURN] (TTPRIN1 '%)] (T (TTPRIN1 (MKSTRING EXPR T *READTABLE*]) (TTPROMPTCHAR [LAMBDA (LINE) (* ; "Edited 20-Jan-88 11:33 by bvm") (* ;;; "Prints the prompt for indicated LINE") (CLEAR.LINE?) (LET ((PROMPT (COND ((EQ LINE \FIRSTLINE) \PROMPT1) (T \PROMPT2))) CRLFS) (COND (PROMPT (SETQ CRLFS (TTPRIN1 PROMPT NIL T)) (if (EQ LINE \FIRSTLINE) then (* ;; "If the prompt took more than one line, account for being down a bit farther (normally CRLFS is 0), but insist that \cursorrow is still zero (it was bumped by crlf). (I don't know what to do if an internal prompt is wider). But then") (add \LOC.ROW.0 (SETQ \INITCRLFS CRLFS)) (SETQ \CURSORROW 0]) (TTRUBOUT [LAMBDA NIL (* ; "Edited 24-May-91 10:36 by jds") (* ;;; "Delete the previous character -- this is the interpretation of DELETE while inserting") (COND ((NOT (AT.START.OF.LINE)) (BACKWARD.DELETE.TO (TTNLEFT \CURSOR 1))) ((AT.START.OF.BUF) (BEEP)) (T (* ;; "At start of line, backspace deletes previous cr or char at end of previous overflow line, so have to compute more here") (LET ((PREVL (PREVLINE \ARROW 1)) START) (DELETE.LONG.SEGMENT1 PREVL (SETQ START (TTNLEFT \CURSOR 1 (fetch (LINE START) of PREVL))) \ARROW \CURSOR) (MOVE.TO.WHEREVER START]) (TTUNREADBUF [LAMBDA NIL (DECLARE (USEDFREE \CURSOR \ENDBUFFER)) (* bvm%: "11-Apr-85 15:13") (* ;;; "Takes contents of buffer from \CURSOR onward and 'unreads' it, i.e. erases it and simulates terminal input, a la BKSYSBUF") (for (X _ \CURSOR) by (TTNEXTCHAR X) until (EQ X \ENDBUFFER) do (BKSYSCHARCODE (FIRSTCHAR X))) (DELETE.TO.END]) (TTWAITFORINPUT [LAMBDA (MSECS RETKEYFLG) (* ; "Edited 19-Jan-88 01:00 by bvm") (* ;; "Waits for mouse or keystroke. If MSECS is non-NIL, waits a maximum of that many milliseconds. If RETKEYFLG is true, returns the input (if there is some), otherwise just T without reading input. Mouse buttons are returned as funny codes") (PROG ((TIMER (AND MSECS (SETUPTIMER MSECS))) (REG (DSPCLIPPINGREGION NIL \DSP)) W X Y FN ABSY NEWMARG) LP [COND ((\SYSBUFP) (RETURN (COND (RETKEYFLG (\GETKEY)) (T T] (WAIT.FOR.TTY) (GETMOUSESTATE) [COND ((AND (LASTMOUSESTATE (OR RED YELLOW BLUE)) (>= (SETQ X (LASTMOUSEX \DSP)) 0) (< X (fetch (REGION WIDTH) of REG)) (>= (SETQ Y (- (SETQ ABSY (LASTMOUSEY \DSP)) (fetch (REGION BOTTOM) of REG))) 0) (< Y (+ (fetch (REGION HEIGHT) of REG) \CHARHEIGHT)) (SETQ W (WHICHW LASTMOUSEX LASTMOUSEY)) (EQ (WINDOWPROP W 'DSP) \DSP)) (* ; "Bugged inside this window") (* ;; "The IPLUS is a grotesque kludge to include the title bar. Problem is that REG needs to be the clipping region, not the window region, because we get mouse coordinates in DSP terms, not window terms. Damn Dedit typein buffer") (* ;; "The WHICHW test is so that we don't fight the scrollbar handler, or anyone else who happens to be on top of this window. Really should have monitorlock on mouse") (COND [(AND (NOT (EMPTY.BUFFER)) (< ABSY (+ \BMARG (TIMES (- \TTPAGELENGTH \LOC.ROW.0) \CHARHEIGHT))) (< Y (fetch (REGION HEIGHT) of REG)) (>= Y (- (ITIMES (- \TTPAGELENGTH (+ \LOC.ROW.0 (fetch (LINE ROW) of (TTLASTLINE)) 1)) \CHARHEIGHT) 4))) (* ;; "Pointing inside text region. The second ILESSP is in case the text region overflows the window, we still want title bar to be for menu") (COND ((NOT RETKEYFLG) (RETURN T)) (T (DO.MOUSE) (SETQ \PFW.FIRSTTIME NIL) (GO LP] ([AND \WINDOWWORLD (SETQ FN (COND ((LASTMOUSESTATE (ONLY BLUE)) (OR (fetch (TTYINBUFFER TTOLDRIGHTFN) of \TTYINSTATE) (FUNCTION DOWINDOWCOM))) (T (fetch (TTYINBUFFER TTOLDBUTTONFN) of \TTYINSTATE] (* ;  "Pointing in our window, but outside text--do regular button stuff") (\PROTECTED.APPLY FN (WHICHW)) (COND ((NEQ \RMARG (SETQ NEWMARG (DSPRIGHTMARGIN NIL \DSP))) (* ; "Window was reshaped") (COND ((> \RMARG (SETQ \RMARG NEWMARG)) (* ; "Window got narrower, so reprint") (DO.EDIT.PP))) (SETQ REG (DSPCLIPPINGREGION NIL \DSP] (COND ((AND TIMER (TIMEREXPIRED? TIMER)) (RETURN NIL))) (\TTYBACKGROUND) (GO LP]) (TTYINSTRING [LAMBDA (BUF TAIL) (* ; "Edited 27-Jan-88 16:00 by bvm") (* ;;; "Returns a string consisting of the 'real' chars in buffer from BUF to TAIL or end of buffer. If BUF = TAIL returns a null string") (OR TAIL (SETQ TAIL \ENDBUFFER)) (LET ((NC 0) FATP RESULT) (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X TAIL) do (* ;  "First scan to see how long string needs to be") (COND ((\FATCHARCODEP (FIRSTCHAR X)) (SETQ FATP T))) (add NC 1)) (SETQ RESULT (ALLOCSTRING NC NIL NIL FATP)) (for (X _ BUF) by (TTNEXTCHAR X) until (EQ X TAIL) as I from 1 do (RPLCHARCODE RESULT I (FIRSTCHAR X))) RESULT]) (TYPE.BUFFER [LAMBDA (START END) (* ; "Edited 24-May-91 11:12 by jds") (* ;;; "Types buffer from START to END, returning number of chars typed. Assumes no CR's") (bind ($$VAL _ 0) WIDTH CH while (NEQ START END) do [SETQ WIDTH (COND ((COMPLEXCHARP (SETQ CH (CAR START))) (for PC in (fetch (COMPLEXCHAR CPXPRINTCHARS) of CH) do (TTBOUT PC)) (fetch (COMPLEXCHAR CPXWIDTH ) of CH)) (T (TTBOUT CH) (TTBITWIDTH CH] (add \CURSORCOL WIDTH) (add $$VAL WIDTH) (SETQ START (CDR START]) (U-CASECODE [LAMBDA (CHAR) (* lmm "16-Nov-86 13:24") (CL:CHAR-INT (CL:CHAR-UPCASE (CL:INT-CHAR CHAR]) (U/L-CASE [LAMBDA (N CAPFLG) (DECLARE (USEDFREE \CURSOR \ARROW)) (* ; "Edited 24-May-91 10:37 by jds") (* ;;; "UPPER or lower-case N words. CAPFLG=T for uppercase; CAPFLG=1 for just capitalization") (COND ((AND (EQ N 1000) (AT.END.OF.LINE)) (* ;; "$U or $L at end of line means do it to the whole line. This handles the common situation where you have typed several words in the wrong case and want to fix them without backing up to the beginning") (MOVE.BACK.TO (fetch (LINE START) of \ARROW))) (T (MOVE.TO.START.OF.WORD))) (* ; "Go to start of current word") (PROG ((NEXTWD (CHECK.MARGIN (FIND.NEXT.WORD \CURSOR N))) NEEDADJUST OLDLENGTH) (SETQ OLDLENGTH (SEGMENT.BIT.LENGTH \CURSOR NEXTWD)) (* ; "Notice how long it is now") (for (BUF _ (PROGN \CURSOR)) CHAR until (EQ BUF NEXTWD) do [COND ((AND [NOT (COMPLEXCHARP (SETQ CHAR (CAR BUF] (>= CHAR (CHARCODE A))) (RPLACA BUF (COND (CAPFLG (COND ((EQ CAPFLG 1) (* ; "only raise first char of word") (SETQ CAPFLG NIL))) (U-CASECODE CHAR)) (T (L-CASECODE CHAR] (SETQ BUF (TTNEXTCHAR BUF))) (SETQ NEEDADJUST (TTADJUSTWIDTH (- (SEGMENT.BIT.LENGTH \CURSOR NEXTWD) OLDLENGTH) NEXTWD)) (TYPE.BUFFER \CURSOR (SETQ \CURSOR NEXTWD)) (COND (NEEDADJUST (ADJUSTLINE.AND.RESTORE]) ) (* ; "Internal reading. These functions all expect caller to have bound *READTABLE* correctly (not bound in TTYIN for who-line transparency)" ) (DEFINEQ (TTRATOM [LAMBDA NIL (* ; "Edited 24-May-91 11:18 by jds") (* ;;; "Reads next atom from BUFFER, advancing it suitably") (COND ((EQ (TTSKIPSEPR) \ENDBUFFER) null) (T (LET ((STRM (TTYINBUFFERSTREAM \BUFFER))) (PROG1 (RATOM STRM) (SETQ \BUFFER (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)))]) (TTREADLIST [LAMBDA NIL (* ; "Edited 16-Jan-88 18:01 by bvm:") (* ;;; "Read a list of elements. OPENCHAR is the character that started the list (paren or bracket) or NIL if none.") (LET ((STRM (TTYINBUFFERSTREAM \BUFFER \ENDBUFFER))) (while (SKIPSEPRS STRM) collect (READ STRM]) (TTSKIPSEPR [LAMBDA (END) (* bvm%: "11-Apr-85 15:13") (* ;;; "Skip \BUFFER over any separator chars, returning new value") (while (AND (NEQ \BUFFER \ENDBUFFER) (NEQ \BUFFER END) (SPACEP (FIRSTCHAR \BUFFER))) do (SETQ \BUFFER (TTNEXTCHAR \BUFFER))) \BUFFER]) (TTSKREAD [LAMBDA (BUF END PARENCOUNT) (* ; "Edited 8-Feb-88 12:46 by bvm:") (* ;; "Simulates READLINE starting at BUF, returning tail of BUF where the read would terminate, or NIL if the read does not terminate before END (default \ENDBUFFER). If PARENCOUNT is true and the read does not terminate on account of unmatched parens, then returns the excess paren count instead of NIL.") (OR END (SETQ END \ENDBUFFER)) (bind X while (NEQ BUF END) do [SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF)) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (* ; "open paren/bracket") (SETQ X (CAR BUF)) (COND ((NOT (SETQ BUF (TTSKREAD (CDR BUF) END PARENCOUNT))) (* ;  "Failed to match string quotes, etc") (RETURN NIL)) ((EQ BUF END) (* ;  "Everything after the paren worked out ok, but we have no closing paren") (RETURN (AND PARENCOUNT 1))) ((FIXP BUF) (* ; "Unmatched parens") (RETURN (ADD1 BUF))) ((AND (EQ (CAR BUF) (CHARCODE %])) (NEQ X (CHARCODE %[))) (* ;  "left paren terminated by right bracket") (RETURN BUF)))) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (* ; "closing paren/bracket") (RETURN BUF)) (STRINGDELIM.RC (COND ((NOT (SETQ BUF (FIND.MATCHING.QUOTE (CDR BUF) END))) (RETURN NIL)))) (ESCAPE.RC (* ; " skip over without looking") (COND ((EQ (SETQ BUF (CDR BUF)) END) (* ; "Last char was escape") (RETURN NIL)))) (MULTIPLE-ESCAPE.RC (* ;  "Look for matching multiple escape, respecting only single escapes along the way") (OR (while (NEQ (SETQ BUF (CDR BUF)) END) do (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR BUF)) (ESCAPE.RC (COND ((EQ (SETQ BUF (CDR BUF)) END) (RETURN)))) (MULTIPLE-ESCAPE.RC (RETURN BUF)) NIL)) (RETURN NIL))) (OTHER.RC NIL) (PROGN (* ;  "Some sort of macro. Most we don't care about, but semicolon is nasty") (COND ((AND (EQ (FIRSTCHAR BUF) (CHARCODE ;)) (READTABLEPROP RDTBL 'COMMONLISP)) (* ; "Skip ahead to end of line") (COND ([do (COND ((EQ (SETQ BUF (CDR BUF)) END) (RETURN T)) ((EQ (FIRSTCHAR BUF) (CHARCODE EOL)) (RETURN] (* ;  "Ended inside this comment, so not complete -- just as if escaped") (RETURN NIL] (SETQ BUF (CDR BUF)) finally (RETURN BUF]) (TTYIN.READ [LAMBDA (FINALCHAR DONTREAD STREAM) (* ; "Edited 16-Jan-88 17:58 by bvm:") (* ;;; "Process buffer for reading. FINALCHAR is what prompted us to terminate the call to TTYIN and is not in the buffer. If DONTREAD is true, then STREAM is the line buffer and we are acting as \FILLBUFFER -- otherwise, STREAM is our own scratch stream, with an eof fn that returns right paren; we read the buffer and return a list of expressions") (LET (LASTC BUTLASTC) (while (NEQ \BUFFER \ENDBUFFER) do (SETQ BUTLASTC LASTC) (* ; "Fill the buffer") (BOUTCCODE STREAM (SETQ LASTC (FIRSTCHAR \BUFFER)) ) (SETQ \BUFFER (TTNEXTCHAR \BUFFER))) (COND ((AND DONTREAD (SELCHARQ FINALCHAR (EOL (SELECTC (\SYNCODE \RDTBLSA LASTC) ((LIST RIGHTPAREN.RC RIGHTBRACKET.RC) (COND ((OR (NULL BUTLASTC) (EQ (\SYNCODE \RDTBLSA BUTLASTC) ESCAPE.RC)) (* ;  "If it ended in a quoted right paren, then it's just like any other character") T) ((EQ (\SYNCODE \RDTBLSA (CHARCODE %])) RIGHTBRACKET.RC) (* ;; "Line ended in paren. Change to right bracket so READLINE doesn't get confused. Only do this if ] really is right bracket!") (\SETFILEPTR STREAM (IDIFFERENCE (\GETFILEPTR STREAM) (STREAMBYTESPERCHAR STREAM))) (BOUTCCODE STREAM (CHARCODE %])) NIL))) T)) ((%) %]) NIL) T)) (* ;  "Print FINALCHAR unless terminator was EOL and line already ended in a closing paren or bracket") (BOUTCCODE STREAM FINALCHAR))) (\SETEOFPTR STREAM (\GETFILEPTR STREAM)) (\SETFILEPTR STREAM 0) (COND (DONTREAD (* ;  "STREAM = \LINEBUF.OFD and caller will take care of reading buf") (AND (EQ STREAM \LINEBUF.OFD) (replace (LINEBUFFER LINEBUFSTATE) of STREAM with READING.LBS)) T) (T (* ;  "Read from buffer until it's empty") (PROG1 (bind TERM while [AND (SKIPSEPRS STREAM) (SETQ TERM (NLSETQ (READ STREAM] collect (CAR TERM)) (\SETFILEPTR STREAM 0) (* ;  "Now clear the stream so nobody reads extra garbage after us") (\SETEOFPTR STREAM 0]) ) (* ; "Escape completion and friends") (DEFINEQ (FIND.MATCHING.WORD [LAMBDA (WORDS START BUFTAIL) (* lmm "14-Nov-86 17:09") (* ;; "Find the first word in spelling list WORDS which matches the characters in the buffer from START to BUFTAIL (or current cursor position), and return the corresponding tail of WORDS") (OR BUFTAIL (SETQ BUFTAIL \CURSOR)) (find TAIL on WORDS suchthat (WORD.MATCHES.BUFFER (INPART (CAR TAIL)) START BUFTAIL]) (TTCOMPLETEWORD [LAMBDA (CAUTIOUS MUST.BE.UNIQUE FIRSTMATCH START) (* ; "Edited 20-Jan-88 12:32 by bvm") (* ;; "Tries to complete the current word from members of SPLST. Does nothing if no word in progress, or this is a comment line. Returns true if some completion done. If CAUTIOUS, only complete if can do so uniquely and caller permits fixspell; if MUST.BE.UNIQUE set, only do unique completion. FIRSTMATCH, if supplied, is the first match in SPLST, and START the start of the current word being worked on") (LET ((UNIQUE T) TAIL FIRSTMATCHCHARS SUFFIXCHARS LASTCHAR NEXTCHAR I WORD CH) (COND ([AND [OR START (SETQ START (COND ((AT.START.OF.BUF) (* ;  "Empty buffer. Allow altmode completion on one-word splst here") (AND (NOT CAUTIOUS) \BUFFER)) (T (CURRENT.WORD] (OR FIRSTMATCH (SETQ FIRSTMATCH (FIND.MATCHING.WORD SPLST START] (* ;; "Completion may be possible. (CAR FIRSTMATCH) is the first match in SPLST; START is buffer tail where current word starts; NEXTCHAR is the relative position of cursor in current word, i.e. #chars in word + 1; LASTCHAR is the last char position in common among all words which match. Both NEXTCHAR and LASTCHAR are in terms of the actual characters of the symbol, rather than its printed representation, so as to ignore questions of how the words might be escaped.") [SETQ NEXTCHAR (ADD1 (for (TAIL _ START) by (TTNEXTCHAR TAIL) until (EQ TAIL \CURSOR) sum (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR TAIL)) (MULTIPLE-ESCAPE.RC (* ; "ignore") 0) (ESCAPE.RC (* ;  "Ignore the escape, but count the next char") (if (EQ (SETQ TAIL (TTNEXTCHAR TAIL)) \CURSOR) then (* ;  "Shouldn't happen--FIND.MATCHING.WORD would have failed") (RETURN $$VAL) else 1)) 1] [SETQ LASTCHAR (NCHARS (SETQ FIRSTMATCH (INPART (CAR (SETQ TAIL FIRSTMATCH] (COND ((OR CAUTIOUS (EQ (SUB1 NEXTCHAR) LASTCHAR)) (* ;; "The latter case happens if the current word is exactly MATCH. In this case, if there are any other matches they are with words containing MATCH as initial substring, and thus no further completion is possible") (SETQ MUST.BE.UNIQUE T))) (* ;; "Now run through all other possible matches with the current word, reducing LASTCHAR to indicate the largest segment in common.") (while (SETQ TAIL (FIND.MATCHING.WORD (CDR TAIL) START)) do (COND (MUST.BE.UNIQUE (RETURN))) (SETQ UNIQUE NIL) (* ; "No longer a unique match") (SETQ WORD (INPART (CAR TAIL))) [COND ([find old I from NEXTCHAR to LASTCHAR as REFERENCE in (OR SUFFIXCHARS (SETQ SUFFIXCHARS (FNTH (SETQ FIRSTMATCHCHARS (CHCON FIRSTMATCH)) NEXTCHAR))) suchthat (AND (NEQ (SETQ CH (NTHCHARCODE WORD I)) REFERENCE) (NOT (AND CH (EQ (LOGXOR CH 32) REFERENCE) (IGEQ CH (CHARCODE A)) (ILEQ CH (CHARCODE z] (COND ((EQ I NEXTCHAR) (* ; "Tails are completely different, i.e., we have found two words that match the prefix so far, but they have no further characters in common, so give up") (RETURN)) (T (* ;  "reset LASTCHAR to last common character") (SETQ LASTCHAR (SUB1 I] finally (* ;; "chars from NEXTCHAR to LASTCHAR are uniquely determined by prefix so far") [PROG ((BUF START) (OLDLENGTH 0) RETYPEBUF RETYPETARGET RETYPELENGTH J NEEDADJUST ESCAPED) (END.DELETE.MODE) [SETQ FIRSTMATCHCHARS (if (NOT (LITATOM FIRSTMATCH)) then (* ; "Don't bother with prin2 stuff") (CHCON FIRSTMATCH) else (* ; "We want to get the case and escaping right for completion, but we don't know how to handle packages yet, so get a pname unlikely to have a package") (LET ((*PACKAGE* (OR (CL:SYMBOL-PACKAGE FIRSTMATCH) *PACKAGE*))) (CHCON FIRSTMATCH T] (SETQ I 1) (until (EQ I NEXTCHAR) do (* ;;  "Scan old part of string (part user has typed already) to make sure case is correct") (SETQ CH (CAR FIRSTMATCHCHARS)) (if RETYPEBUF then (add RETYPELENGTH 1) elseif (OR (NEQ CH (CAR BUF)) (EQ BUF \CURSOR)) then (* ; "The real spelling is different from what's in buf, so we'll want to fix it. The (eq buf \\cursor) test is just in case somehow the buffer has fewer chars than target, but the first n are identical. (Can you think of an example??)") (SETQ RETYPEBUF BUF) (SETQ RETYPETARGET FIRSTMATCHCHARS) (SETQ RETYPELENGTH 1)) (if (NOT (if ESCAPED then (* ; "Previous char was escape") (SETQ ESCAPED NIL) else (OR (FIXP CH) (HELP CH)) (SELECTC (\SYNCODE \RDTBLSA CH) (ESCAPE.RC (SETQ ESCAPED T)) (MULTIPLE-ESCAPE.RC T) NIL))) then (* ; "Count real chars as they go by") (add I 1)) (SETQ FIRSTMATCHCHARS (CDR FIRSTMATCHCHARS)) (SETQ BUF (CDR BUF))) [if RETYPEBUF then (* ;  "We found a difference, so smash old contents and retype as needed") [if (EQ (SETQ BUF RETYPEBUF) \CURSOR) then (* ; "RETYPEBUF = \CURSOR when the word we want to type has MORE characters than buffer does, yet the characters in buffer match identically. I don't think this can happen.") (HELP "More chars in match than source?") else (for old J from 1 to RETYPELENGTH until (EQ BUF \CURSOR) do (* ; "Replace existing buf chars until we either get to the current cursor position or we have used up the scanned chars of the match") (add OLDLENGTH (TTBITWIDTH (CAR BUF))) (* ;  "OLDLENGTH computes old distance from RETYPEBUF to BUF") (RPLACA BUF (CAR RETYPETARGET)) (SETQ BUF (CDR BUF)) (SETQ RETYPETARGET (CDR RETYPETARGET))) [GO.TO.RELATIVE (- \CURSORCOL (+ OLDLENGTH (PROGN (* ;  "If the new word is shorter than old, we haven't yet counted the bits from old BUF to the cursor") (SEGMENT.BIT.LENGTH BUF \CURSOR] (* ; "Go to start of changes") (SETQ NEEDADJUST (TTADJUSTWIDTH (- (SEGMENT.BIT.LENGTH RETYPEBUF BUF) OLDLENGTH) BUF)) (TYPE.BUFFER RETYPEBUF BUF) (* ; "Retype with new contents.") (COND (NEEDADJUST (ADJUSTLINE.AND.RESTORE))) (if (NEQ BUF \CURSOR) then (* ;; "There are more chars in buf than target, so have to delete (this can happen if buffer contains escape characters not deemed necessary in the print name). We could optimize movement by overtyping some of FIRSTMATCHCHARS instead of doing ADDCHAR's below, but the logic gets way messier than is seemly") (FORWARD.DELETE.TO (PROG1 \CURSOR (  MOVE.TO.WHEREVER BUF] (until (EQ RETYPETARGET FIRSTMATCHCHARS) do (* ; "The match has more characters than the buffer, e.g., when there were mixed-case chars needing escaping, so add the rest of target that we've already scanned.") (ADDCHAR (pop RETYPETARGET] (* ;;  "Now do second half, the completion part: add new chars from NEXTCHAR thru LASTCHAR") (if UNIQUE then (* ;  "Just add all the chars, including a possible final vertical bar") (while FIRSTMATCHCHARS do (ADDCHAR (pop FIRSTMATCHCHARS)) ) [COND ((NOT CAUTIOUS) (* ; "delimit as well") (ADDCHAR (CHARCODE SPACE)) (COND ((AND (NEQ NEXTCHAR 1) (MEMB SPELLSTR1 (OR SPLST USERWORDS))) (* ;; "Spelling list maintenance: user completed on this word, so move to front of spelling list, assuming this is a real spelling list. Don't do it in the trivial case of filling in the entire word uniquely (as when doing LASTWORD)") (MOVETOP FIRSTMATCH (OR SPLST USERWORDS] else (until (> I LASTCHAR) do (ADDCHAR (SETQ CH (pop FIRSTMATCHCHARS))) (if (NOT (if ESCAPED then (* ; "Previous char was escape") (SETQ ESCAPED NIL) else (SELECTC (\SYNCODE \RDTBLSA CH) (ESCAPE.RC (SETQ ESCAPED T)) (MULTIPLE-ESCAPE.RC T) NIL))) then (* ; "Count real chars as they go by") (add I 1] (RETURN (OR (AND UNIQUE FIRSTMATCH) T]) (WORD.MATCHES.BUFFER [LAMBDA (WORD START BUFTAIL) (* ; "Edited 17-Jan-88 18:07 by bvm:") (* ;;; "True if WORD matches case-insensitively chars in buffer from START to BUFTAIL") (for (I _ 0) as (BTAIL _ START) by (TTNEXTCHAR BTAIL) bind CHAR BUFCH until (EQ BTAIL BUFTAIL) always (OR (SELECTC (\SYNCODE \RDTBLSA (SETQ BUFCH (FIRSTCHAR BTAIL))) (ESCAPE.RC (* ; "Skip to next character") (if (EQ (SETQ BTAIL (TTNEXTCHAR BTAIL)) BUFTAIL) then (* ;  "Last character was escape. How can we match anything?") (RETURN NIL)) (SETQ BUFCH (FIRSTCHAR BTAIL)) NIL) (MULTIPLE-ESCAPE.RC (* ; "Just ignore multiple escape--it doesn't affect single escape, and so what if we match some things that aren't quite the right case?") T) NIL) [EQ BUFCH (SETQ CHAR (NTHCHARCODE WORD (add I 1] (AND CHAR (EQ (LOGXOR CHAR 32) BUFCH) (IGEQ CHAR (CHARCODE A)) (ILEQ CHAR (CHARCODE z]) (TTYIN.SHOW.?ALTERNATIVES [LAMBDA NIL (* ; "Edited 8-Feb-88 12:47 by bvm:") (* ;; "Called when ? is typed, to indicate alternative completions of current word") (LET (X MATCHED STARTOFWORD DOWNCASE) (COND ((OR (PROGN (* ;  "Global flag controls all of this") (NOT ?ACTIVATEFLG)) [CL:UNLESS (EQ \LASTCHAR DIDESCAPECODE) (* ; "If the immediately preceding typein was not an attempt at escape completion, don't answer ? if there's no spelling list or we're not at the end of the input") (OR (NOT SPLST) (NOT (AT.END.OF.BUF] [PROGN (* ;  "There needs to be a word in progress") (NOT (SETQ STARTOFWORD (CURRENT.WORD] (PROGN (* ;  "If previous char is ?, let it alone (allows ?? etc).") (EQ (SETQ X (CAR (NLEFT STARTOFWORD 1 \ENDBUFFER))) (CHARCODE ?))) (SELECTC (\SYNCODE \RDTBLSA X) ((LIST MULTIPLE-ESCAPE.RC ESCAPE.RC) (* ; "Preceded by an escape character. This isn't quite right, since the escape could be escaped, but it's close") T) NIL) (PROGN (FRPLACA \ENDBUFFER (CHARCODE ?)) (* ; "This is pretty random--i.e., if we decide to do something, first stick a ? beyond the end of the buffer") NIL)) (* ;; "All sorts of cases where we want to just treat the ? as a normal character") (ADDCHAR (CHARCODE ?))) [(NOT (SETQ MATCHED (FIND.MATCHING.WORD (OR SPLST USERWORDS) STARTOFWORD))) (BEEP) (* ;  "No match. Ring the bell, but accept the ? as is") (OR (EQ \LASTCHAR DIDESCAPECODE) (ADDCHAR (CHARCODE ?] ((TTCOMPLETEWORD NIL T MATCHED STARTOFWORD)) (T (* ; "There was more than one completion, so display them (if there was a unique one, TTCOMPLETEWORD filled it in)") (SAVE.CURSOR) (GO.TO.FREELINE) (if (AND (NEQ *PRINT-CASE* :UPCASE) (READTABLEPROP RDTBL 'CASEINSENSITIVE)) then (* ;  "Normally would print things in lower case, so try to do that here, too.") (SETQ DOWNCASE T)) (TTPRIN1COMMENT "one of ") [do (TTPRIN1 (INPART (CAR MATCHED)) DOWNCASE) (COND ((SETQ MATCHED (FIND.MATCHING.WORD (CDR MATCHED) STARTOFWORD)) (TTPRIN1COMMENT ", ")) (T (RETURN] (RESTORE.CURSOR]) ) (* ; "? and ?= handler") (DEFINEQ (DO?CMD [LAMBDA (CMD \?TAIL) (DECLARE (SPECVARS \?TAIL \?PARAMS \BUFFER \STARTED)) (* ; "Edited 8-Feb-88 12:47 by bvm:") (* ;;; "Handles 'read macros' ? and ?=. CMD is one of those. Returns NIL if thinks it isn't. Saves current cursor location for later restoration") (\CARET.DOWN) (PROG ((*READTABLE* RDTBL) (\BUFFER \BUFFER) (\?PARAMS null) (\STARTED NIL) (START (BACKSKREAD \CURSOR)) STUFF FN FNSTART FNEND SPTAIL SAVE) [HANDLER-BIND ((CL:ERROR (FUNCTION DO?CMD.ERRORHANDLER))) (* ; "This handler is in case there is an error while reading the symbol we're trying to get information about.") (SELECTC (\SYNCODE \RDTBLSA (FIRSTCHAR START)) ((LIST LEFTPAREN.RC LEFTBRACKET.RC) (COND ([AND (EQ (SCANFORWARD (CAR START) (SETQ FNSTART \BUFFER)) START) (PROGN (* ; "START is the first paren in buffer, so check and see if there's an atom before it, and that the atom is not an exec command") (SETQ FN (TTRATOM)) (SETQ FNEND \BUFFER) (AND (EQ (TTSKIPSEPR) START) (NOT (GETHASH FN *EXEC-COMMAND-TABLE*] (* ;  "This is first list on line, preceded by FN in evalqt format") ) (T (SETQ FNSTART (SETQ \BUFFER (CDR START))) (* ; "EVAL form: read fn") (COND ((EQ (SETQ FN (TTRATOM)) CMD) (* ; "Hasn't typed the fn name yet!") (RETURN))) (SETQ FNEND \BUFFER)))) (PROGN (* ;  "Not inside a list now, so no macro") (RETURN))) (* ;;  "Have to do it this way so that specials get set above to prepare for deletion of ?=") (SAVE.CURSOR) (COND ((EQ CMD '?) (* ; "Want verbose description of fn") (XHELPSYS FN)) (T (GO.TO.FREELINE) (SETQ \STARTED T) (* ;  "Tells error handler we've begun to work") [COND ((EQ \BUFFER START) (* ; "Apply format, skip over paren") (SETQ \BUFFER (CDR START] (COND ([OR (NOT TTYIN?=FN) (NOT (SETQ STUFF (CL:FUNCALL TTYIN?=FN FN] (* ;  "Default: get the arglist and interpret it") (if [NULL (SETQ STUFF (NLSETQ (SMARTARGLIST FN T (SETQ SPTAIL (CONS FN] then (* ;  "Error occurred getting args, probably not a function") (TTPRIN1COMMENT "Couldn't find args for ") (TTPRIN2 FN) (SETQ SPTAIL NIL) else (COND ((NEQ FN (SETQ FN (CAR SPTAIL))) (* ;  "Fn was spelling corrected, so There was an extra crlf involved in printing the correction") (TTCRLF.ACCOUNT)) (T (SETQ SPTAIL NIL))) (TTYIN.PRINTARGS FN (CAR STUFF) T))) ((EQ (CAR (LISTP STUFF)) 'ARGS) (TTYIN.PRINTARGS FN (CDR STUFF) T)) ((LISTP STUFF) (TTPRIN2 STUFF)) ((NEQ STUFF T) (TTPRIN1 STUFF] (SELECTQ CMD (? (* ; "now delete the ?") (TTRUBOUT)) (?= (RESTORE.CURSOR) (BACKWARD.DELETE.TO \?TAIL) (COND (SPTAIL (* ;; "Fn was spelling corrected, so replace it. There was also an extra crlf involved in printing the correction") (SETQ SAVE \CURSOR) (MOVE.TO.WHEREVER FNEND) (BACKWARD.DELETE.TO FNSTART) (READFROMBUF (CHCON FN T *READTABLE*)) (MOVE.TO.WHEREVER SAVE)))) NIL) (RETURN T]) (TTYIN.PRINTARGS [LAMBDA (FN ARGS ACTUALS ARGTYPE) (* ; "Edited 19-Jan-88 01:37 by bvm") (* ;; "Prints args to fn, matching up with ACTUALS, if supplied. Do this in a way that lets us keep track of where we are.") (PROG ((EQUALS " = ") (SPACE " ") NEXTARG KEY TYPE REMARGS DOWNCASE) (\CARET.DOWN) (TTPRIN1 "(") (TTPRIN2 FN) (if (AND ARGS (NEQ *PRINT-CASE* :UPCASE) (READTABLEPROP *READTABLE* 'CASEINSENSITIVE)) then (* ;  "Normally would print things in lower case, so try to do that here, too.") (SETQ DOWNCASE T)) [COND [(LISTP ARGS) (* ;  "Something interesting to print here") [COND ((CL:CHARACTERP (CAR ARGS)) (* ; "Forget about actuals") (SETQ ACTUALS NIL)) ((COND ((EQ ACTUALS T) (* ; "Means to compute the actuals") (SETQ ACTUALS (TTYIN.READ?=ARGS))) (T ACTUALS)) (* ;  "We have some actuals to match up to args") (COND ((CDR ACTUALS) (* ;  "More than one actual, so let's put each one on its own line for legibility") (TTCRLF)) (T (* ; "Start on the same line") (TTPRINSPACE))) (while ACTUALS do (* ;; "This loop will somehow print all the actual args from the user's input") (COND ((NULL ARGS) (* ; "More actuals than allowed") (TTPRIN1COMMENT "+ ... ")) ((NLISTP ARGS) (* ;  "Last arg is a %"&rest%" arg, but indicated as a dotted tail") (TTPRIN1COMMENT " . ") (TTPRIN1COMMENT ARGS DOWNCASE) (SETQ ARGS NIL) (RETURN)) ((CL:CHARACTERP (SETQ NEXTARG (CAR ARGS))) (* ; "We've gotten to the part where it's reduced to a syntax description. I don't plan to match actuals to that.") (SETQ ACTUALS NIL) (RETURN)) (T (* ;  "Some argument name or lambda keyword to show") (SETQ ARGS (CDR ARGS)) (TTPRIN1COMMENT NEXTARG DOWNCASE) (SELECTQ NEXTARG (&OPTIONAL (* ;  "We've printed &optional, now print the first name") (TTPRINSPACE) (TTPRIN1COMMENT (pop ARGS) DOWNCASE)) ((&REST &BODY) (* ;  "This will consume all remaining args") (TTPRINSPACE) (TTPRIN1COMMENT (pop ARGS) DOWNCASE) (RETURN)) (&KEY (* ;  "Parse actuals into keyword pairs") (LET ((ALLOW-OTHER-KEYS (MEMB '&ALLOW-OTHER-KEYS ARGS)) USEDKEYS KEY) (while ACTUALS do (TTCRLF) (SETQ KEY (pop ACTUALS)) (if (OR ALLOW-OTHER-KEYS (MEMB KEY ARGS) (EQ KEY :ALLOW-OTHER-KEYS)) then (* ; "Good keyword") (TTPRIN2 KEY) (push USEDKEYS KEY) else (* ;  "Something random--indicate skepticism") (TTPRIN1COMMENT "[") (TTPRIN2 KEY 2 4) (TTPRIN1COMMENT "]")) (TTPRIN1COMMENT EQUALS) (if ACTUALS then (TTPRIN2 (pop ACTUALS) 2 4))) (if (SETQ ARGS (CL:SET-DIFFERENCE ARGS USEDKEYS)) then (* ; "there is more to print") (TTCRLF)) (RETURN))) (&ALLOW-OTHER-KEYS (TTCRLF) (GO $$ITERATE)) NIL))) (TTPRIN1COMMENT EQUALS) (TTPRIN2 (CAR ACTUALS) 2 4) (SETQ ACTUALS (CDR ACTUALS)) (TTCRLF)) (* ;; "At this point, if there are any ACTUALS left, it means we had a &REST or dotted tail. Just print everything that's left") (if ACTUALS then (TTPRIN1COMMENT EQUALS) (do (TTPRIN2 (pop ACTUALS) 2 4) (if ACTUALS then (TTPRINSPACE) else (* ; "Finished") (RETURN))) (if ARGS then (* ; "More to say yet") (TTCRLF] (* ;; "We've now printed all the actuals. Are there any more args to print?") (while ARGS bind (DOSPACE _ T) do (if (NLISTP ARGS) then (TTPRIN1COMMENT " . ") (TTPRIN1COMMENT ARGS DOWNCASE) (RETURN)) (SETQ NEXTARG (pop ARGS)) (SETQ DOSPACE (if (CL:CHARACTERP NEXTARG) then (* ;  "Funny syntax description. Nicer if we handle spacing better than the default") [CASE NEXTARG ((#\) #\] #\} #\*) (* ;  "Don't space before these (but do after)") ) (T (if (AND DOSPACE (NEQ \CURSORCOL \LMARG)) then (TTPRINSPACE] (CASE NEXTARG ((#\( #\)) (* ;  "Parens are part of written syntax, so they come out in regular font") (TTPRIN1 NEXTARG)) (T (* ; "Others are comment") (TTPRIN1COMMENT NEXTARG))) (CASE NEXTARG ((#\( #\[ #\{) (* ; "Don't space after these") NIL) (T T)) else (if (AND DOSPACE (NEQ \CURSORCOL \LMARG)) then (TTPRINSPACE)) (if (CL:KEYWORDP NEXTARG) then (* ;  "Nice to print colon in front of keywords") (TTPRIN1COMMENT ":")) (TTPRIN1COMMENT NEXTARG DOWNCASE] ((NOT (NULL ARGS)) (* ;  "Atomic arglist--some sort of nospread") (TTPRIN1COMMENT " ...") (if (NEQ ARGS 'U) then (* ; "The canonical nospread has arglist U, which is hopelessly uninformative, so don't even bother printing it") (TTPRIN1COMMENT ARGS) (TTPRIN1COMMENT "..."] (TTPRIN1 ")") (COND ((SETQ TYPE (SELECTQ (OR ARGTYPE (ARGTYPE FN)) (1 'NL) (3 'NL*) NIL)) (* ; "indicate arg type") (TTPRIN1COMMENT (CONCAT " {" TYPE "}"]) (TTYIN.READ?=ARGS [LAMBDA NIL (* ; "Edited 17-Jan-88 15:20 by bvm:") (* ;; "Read the actual args for ?= from current input. Assumes \BUFFER has been positioned at start of args and \?TAIL at ?=. Caches args in special var \?PARAMS so that repeated calls do not recompute.") (COND [(EQ \?PARAMS null) (SETQ \?PARAMS (AND (NEQ (TTSKIPSEPR \?TAIL) \?TAIL) (WITH-RESOURCES (TTSCRATCHFILE) (LET ((\BUFFER \BUFFER) (\ENDBUFFER \?TAIL)) (TTYIN.READ NIL NIL TTSCRATCHFILE] (T (LISTP \?PARAMS]) (DO?CMD.ERRORHANDLER [LAMBDA (CONDITION) (* ; "Edited 19-Jan-88 20:16 by bvm") (* ;;  "Called by a condition handler underneath ?= handler -- display the condition and abort") (if (NOT \STARTED) then (* ; "Cursor still after the ?=") (SAVE.CURSOR) (GO.TO.FREELINE)) (TTPRIN1COMMENT (MKSTRING CONDITION)) (RESTORE.CURSOR) (BACKWARD.DELETE.TO \?TAIL) (* ;  "Finally, go back and erase the ?=, then return T from DO?CMD to indicate that we did something.") (RETFROM (FUNCTION DO?CMD) T]) ) (* ; "Display handling") (DEFINEQ (BEEP [LAMBDA (DS) (* bvm%: "27-JUL-83 23:20") (RESETFORM (VIDEOCOLOR (NOT (VIDEOCOLOR))) (DISMISS 200]) (BITBLT.DELETE [LAMBDA (X Y WIDTH) (* ; "Edited 18-Jan-88 15:16 by bvm") (PROG ((MOVEDWIDTH (- \RMARG X WIDTH))) (* ;  "First move everything from the right over to cursor pos") (BITBLT \DSP (+ X WIDTH) Y \DSP X Y MOVEDWIDTH \CHARHEIGHT 'INPUT 'REPLACE) (* ;; "then delete the last WIDTH positions on the line. May be unnecessary if they were already blank, might want to check LASTCOL") (BITBLT.ERASE (+ X MOVEDWIDTH) Y WIDTH \CHARHEIGHT]) (BITBLT.ERASE [LAMBDA (LEFT BOTTOM WIDTH HEIGHT) (* ; "Edited 18-Jan-88 15:18 by bvm") (BLTSHADE \TEXTURE \DSP LEFT BOTTOM WIDTH HEIGHT 'REPLACE]) (BITBLT.INSERT [LAMBDA (X Y WIDTH) (* ; "Edited 18-Jan-88 15:18 by bvm") (BITBLT \DSP X Y \DSP (+ X WIDTH) Y (- \RMARG X WIDTH) \CHARHEIGHT 'INPUT 'REPLACE) (BITBLT.ERASE X Y WIDTH \CHARHEIGHT]) (DO.CRLF [LAMBDA NIL (* ; "Edited 18-Jan-88 15:19 by bvm") (SETQ \CURRENTDISPLAYLINE 0) (* ; "Avoid stop scroll nonsense") (DSPLINEFEED (- \CHARHEIGHT) \DSP) (\DSPPRINTCR/LF (CHARCODE CR) \DSP]) (DO.DELETE.LINES [LAMBDA (%#LINES) (* ; "Edited 19-Jan-88 16:35 by bvm") (PROG ((TOTALHEIGHT (+ (- (DSPYPOSITION NIL \DSP) \BMARG) \CHARHEIGHT)) (WIDTH (- \RMARG \LMARG)) (BOTTOM (- \BMARG \DESCENT)) (DELHEIGHT (TIMES %#LINES \CHARHEIGHT))) (* ;; "TOTALHEIGHT is distance from top of current line to bottom of window. DELHEIGHT is height of lines being removed.") [COND ((> DELHEIGHT TOTALHEIGHT) (* ;  "Delete everything from here down") (SETQ DELHEIGHT TOTALHEIGHT)) (T (BITBLT \DSP \LMARG BOTTOM \DSP \LMARG (+ BOTTOM DELHEIGHT) WIDTH (- TOTALHEIGHT DELHEIGHT) 'INPUT 'REPLACE] (BITBLT.ERASE \LMARG BOTTOM WIDTH DELHEIGHT]) (DO.INSERT.LINE [LAMBDA NIL (* ; "Edited 24-May-91 10:37 by jds") (* ;;; "Inserts a new line on screen in front of current cursor row. The trickiness here is that unless there are some blank lines at the bottom of the screen, we actually have to scroll upwards before we can insert downwards, lest we lose the bottom line. Leaves cursor at start of new blank line.") (PROG ((DY (- (DSPYPOSITION NIL \DSP) \DESCENT)) (WIDTH (- \RMARG \LMARG))) [COND ((EQ (+ \LOC.ROW.0 (fetch (LINE ROW) of (TTLASTLINE)) 1) \TTPAGELENGTH) (* ;  "Bottom line is occupied, so scroll stuff above us upward") (add DY \CHARHEIGHT) (MOVETO (DSPXPOSITION NIL \DSP) (+ DY \DESCENT) \DSP) (BITBLT \DSP \LMARG DY \DSP \LMARG (+ DY \CHARHEIGHT) WIDTH (- (fetch (REGION TOP) of (DSPCLIPPINGREGION NIL \DSP)) (+ DY \CHARHEIGHT)) 'INPUT 'REPLACE) (SETQ \LOC.ROW.0 (SUB1 \LOC.ROW.0)) (* ;  "Top line of buffer has moved up one") ) (T (* ;  "Shove everything at or below current line down one") (BITBLT \DSP \LMARG (+ \BMARG \CHARHEIGHT) \DSP \LMARG \BMARG WIDTH (- DY \BMARG) 'INPUT 'REPLACE] (* ; "and clear this line") (BITBLT.ERASE \LMARG DY WIDTH \CHARHEIGHT]) (DO.LF [LAMBDA NIL (* ; "Edited 18-Jan-88 15:26 by bvm") (\DSPPRINTCR/LF (CHARCODE LF) \DSP]) (ERASE.TO.END.OF.LINE [LAMBDA NIL (* ; "Edited 18-Jan-88 15:27 by bvm") (LET ((X (DSPXPOSITION NIL \DSP))) (BITBLT.ERASE X (- (DSPYPOSITION NIL \DSP) \DESCENT) (- \RMARG X) \CHARHEIGHT]) (ERASE.TO.END.OF.PAGE [LAMBDA NIL (* ; "Edited 18-Jan-88 22:41 by bvm:") (* ;;; "Erases from current cursor position to end of page.") (ERASE.TO.END.OF.LINE) (LET ((BELOW (- (DSPYPOSITION NIL \DSP) \BMARG))) (* ;; "Y-descent is the bottom of current line. \BMARG-descent is bottom of window. Is there anything there?") (COND ((> BELOW 0) (BITBLT.ERASE \LMARG (- \BMARG \DESCENT) (- \RMARG \LMARG) BELOW]) (INSERT.TEXT [LAMBDA (START END ENDOFLINE) (* bvm%: " 4-JUN-82 13:43") (* ;;; "Inserts on screen the contents of buffer from START to END. Text from END to ENDOFLINE is the remainder of the line, in case it's more economical to just retype the line than do the insertion") (COND ((EQ END ENDOFLINE) (TYPE.BUFFER START ENDOFLINE)) (T (TTINSERTSECTION (SEGMENT.BIT.LENGTH START END)) (TYPE.BUFFER START END]) (TTDELSECTION [LAMBDA (WIDTH) (* ; "Edited 18-Jan-88 15:28 by bvm") (* ;;; "Deletes WIDTH bits at current pos") (BITBLT.DELETE (DSPXPOSITION NIL \DSP) (- (DSPYPOSITION NIL \DSP) \DESCENT) WIDTH]) (TTADJUSTWIDTH [LAMBDA (DELTA END) (* ; "Edited 24-May-91 10:37 by jds") (* ;; "Expand or shrink line at current cursorpos by DELTA. END, if supplied, is the end of the section being adjusted; if it is the end of the current line, then it is assumed that expansion is cheap. Returns true if anything was done") (COND ((NEQ DELTA 0) (COND ((ILESSP DELTA 0) (* ; "Line has shrunk") (TTDELSECTION (IMINUS DELTA))) ((NEQ END (fetch (LINE END) of \ARROW)) (* ;  "Line has expanded, so need to spread it if not at the end") (TTINSERTSECTION DELTA))) (add (fetch (LINE LASTCOL) of \ARROW) DELTA) T]) (TTINSERTSECTION [LAMBDA (WIDTH) (* ; "Edited 18-Jan-88 15:29 by bvm") (* ;;; "Inserts WIDTH character positions, leaving cursor at start of insertion") (BITBLT.INSERT (DSPXPOSITION NIL \DSP) (- (DSPYPOSITION NIL \DSP) \DESCENT) WIDTH]) (TTSETCURSOR [LAMBDA (COL ROW) (* ; "Edited 18-Jan-88 15:29 by bvm") (* ;;; "Sets cursor to absolute screen position COL,ROW") (MOVETO COL (+ (TIMES (- \TTPAGELENGTH ROW 1) \CHARHEIGHT) \BMARG) \DSP]) ) (* ; "TTYINBUFFERSTREAM") (DEFINEQ (TTYINBUFFERDEVICE [LAMBDA NIL (* bvm%: "11-Apr-86 11:43") (* ;;; "Defines a device for streams that read from the ttyin buffer. Modeled after the null device except for the interesting parts") (create FDEV DEVICENAME _ 'TTYIN RANDOMACCESSP _ NIL NODIRECTORIES _ T CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) OPENFILE _ (FUNCTION \NULL.OPENFILE) REOPENFILE _ (FUNCTION \NULL.OPENFILE) BIN _ (FUNCTION TTYINBUFFERBIN) BOUT _ (FUNCTION NILL) PEEKBIN _ (FUNCTION TTYINBUFFERPEEK) READP _ (FUNCTION TTYINBUFFERREADP) BACKFILEPTR _ (FUNCTION TTYINBUFFERBACKPTR) EOFP _ (FUNCTION TTYINBUFFEREOFP) RENAMEFILE _ (FUNCTION NILL) GETFILENAME _ (FUNCTION NILL) EVENTFN _ (FUNCTION NILL) BLOCKIN _ (FUNCTION \EOF.ACTION) BLOCKOUT _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \NULLFILEGENERATOR) GETFILEPTR _ (FUNCTION ZERO) GETEOFPTR _ (FUNCTION ZERO) SETFILEPTR _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) SETFILEINFO _ (FUNCTION NILL) SETEOFPTR _ (FUNCTION NILL]) (TTYINBUFFERSTREAM [LAMBDA (BUF END EOFACTION) (* ; "Edited 24-May-91 11:19 by jds") (LET [(STRM (OR \TTYINBUFFERSTREAM (SETQ \TTYINBUFFERSTREAM (create STREAM DEVICE _ TTYINBUFFERDEVICE ACCESS _ 'INPUT] (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM with BUF) (replace (TTYINBUFFERSTREAM TTYEOF) of STRM with (OR END \ENDBUFFER)) (replace (TTYINBUFFERSTREAM TTYEOFACTION) of STRM with EOFACTION) (replace (TTYINBUFFERSTREAM TTYORIGINPUT) of STRM with BUF) STRM]) (TTYINBUFFERBIN [LAMBDA (STRM) (* ; "Edited 24-May-91 11:19 by jds") (LET ((BUF (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM))) (COND ((EQ BUF (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM)) (* ; "Eof") (\EOF.ACTION STRM)) (T (PROG1 (FIRSTCHAR BUF) (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM with (CDR BUF)))]) (TTYINBUFFERPEEK [LAMBDA (STREAM NOERRORFLG) (* ; "Edited 24-May-91 11:19 by jds") (LET ((BUF (fetch (TTYINBUFFERSTREAM TTYINPUT) of STREAM))) (COND ((EQ BUF (fetch (TTYINBUFFERSTREAM TTYEOF) of STREAM)) (* ; "Eof") (AND (NOT NOERRORFLG) (\EOF.ACTION STREAM))) (T (FIRSTCHAR BUF]) (TTYINBUFFERREADP [LAMBDA (STRM) (* ; "Edited 24-May-91 11:19 by jds") (NEQ (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM) (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM]) (TTYINBUFFEREOFP [LAMBDA (STRM) (* ; "Edited 24-May-91 11:19 by jds") (EQ (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM) (fetch (TTYINBUFFERSTREAM TTYEOF) of STRM]) (TTYINBUFFERBACKPTR [LAMBDA (STRM) (* ; "Edited 24-May-91 11:19 by jds") (* ;;; "Back up STRM one. Needed because of top-level READ. What a kludge") (replace (TTYINBUFFERSTREAM TTYINPUT) of STRM with (OR (NLEFT (fetch (TTYINBUFFERSTREAM TTYORIGINPUT) of STRM) 1 (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM)) (fetch (TTYINBUFFERSTREAM TTYINPUT) of STRM]) (TTYINWORDRDTBL [LAMBDA NIL (* ; "Edited 20-Jan-88 22:01 by bvm") (* ;;; "Makes a table in which normal Lisp syntax characters are just break characters. Additionally, comma is a break") (LET [(TBL (COPYREADTABLE 'ORIG)) (BREAKS (CHARCODE (%( %) %[ %] %" %,] (SETSEPR (CHARCODE (SPACE TAB CR)) NIL TBL) (SETSEPR BREAKS 1 TBL) (* ;  "Have to disable their regular meanings before making them pure break chars") (SETBRK BREAKS NIL TBL) (SETSYNTAX (CHARCODE %%) 'OTHER TBL) (* ; "No escape char") (READTABLEPROP TBL 'NAME "TtyinText") TBL]) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQ TTYINBUFFERDEVICE (TTYINBUFFERDEVICE)) (RPAQ TTYINWORDRDTBL (TTYINWORDRDTBL)) ) (* ; "Mouse handling") (DEFINEQ (DO.MOUSE [LAMBDA NIL (* ; "Edited 24-May-91 11:07 by jds") (* ;; "Called when mouse is clicked down inside of our region; performs it as an edit command, returning T, or returns NIL if it is not a legal mouse call. The commands that actually change something display their intent while the button is down and are not actually executed until button is released.") (COND ((OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT) (KEYDOWNP 'CTRL) (KEYDOWNP 'MOVE) (KEYDOWNP 'COPY)) (DO.SHIFTED.SELECTION)) [(LASTMOUSESTATE (ONLY RED)) (* ; "Position cursor") (bind ROW/COL while (SETQ ROW/COL (TTRACKMOUSE ROW/COL)) when (LISTP ROW/COL) do (\CHECKCARET \DSP) (MOVE.TO.LINE (CAR ROW/COL) (CDR ROW/COL] [(LASTMOUSESTATE (ONLY YELLOW)) (* ; "Position cursor by word") (bind NEWPOS BUF COL LINE while (SETQ NEWPOS (TTRACKMOUSE NEWPOS)) when (LISTP NEWPOS) do (\CHECKCARET \DSP) [SETQ BUF (BRACKET.CURRENT.WORD (SETQ LINE (fetch (MOUSEPOS ROWPOS) of NEWPOS)) (SETQ COL (fetch (MOUSEPOS COLPOS) of NEWPOS] (MOVE.TO.LINE LINE (COND ((> (SEGMENT.BIT.LENGTH (CAR BUF) COL) (SEGMENT.BIT.LENGTH COL (CDR BUF))) (CDR BUF)) (T (CAR BUF] ((LASTMOUSESTATE (ONLY BLUE)) (* ;  "zap from cursor to mouse location.") (DO.SHIFTED.SELECTION 'DELETE]) (DO.SHIFTED.SELECTION [LAMBDA (INITMODE) (* ; "Edited 24-May-91 11:07 by jds") (bind START END SAVE EXTENDING MODE NEWSTART NEWEND COL NEWROW NEWMODE BUF NEWPOS WORDLEVEL ENDLINE while (OR [SETQ NEWMODE (COND ((KEYDOWNP 'MOVE) 'MOVE) ((KEYDOWNP 'COPY) 'COPY) [(OR (KEYDOWNP 'LSHIFT) (KEYDOWNP 'RSHIFT)) (COND ((KEYDOWNP 'CTRL) 'MOVE) (T 'COPY] ((KEYDOWNP 'CTRL) 'DELETE] (LASTMOUSESTATE (NOT UP))) do (SETQ NEWPOS (TTRACKMOUSE NEWPOS)) (\TTYBACKGROUND) (* ; "Flash caret") (COND [(LASTMOUSESTATE (OR RED YELLOW)) (* ; "Start new selection") (COND [(AND (LISTP NEWPOS) (NEQ (SETQ COL (fetch (MOUSEPOS COLPOS) of NEWPOS)) \ENDBUFFER)) (* ; "There is a selection") (SETQ NEWSTART (create MOUSEPOS using NEWPOS)) (SETQ NEWROW (fetch (MOUSEPOS ROWPOS) of NEWPOS)) (COND ((OR (LASTMOUSESTATE (ONLY RED)) (EQ COL (fetch (LINE END) of NEWROW))) (* ; "Selection extends to next char") (SETQ NEWEND (TTNEXTPOS NEWROW COL)) (SETQ WORDLEVEL NIL)) (T (* ; "Selection is current 'word'") (SETQ BUF (BRACKET.CURRENT.WORD NEWROW (fetch (MOUSEPOS COLPOS) of NEWSTART))) (replace (MOUSEPOS COLPOS) of NEWSTART with (CAR BUF)) (* ; "Start of previous word") (SETQ NEWEND (create MOUSEPOS ROWPOS _ NEWROW COLPOS _ (CDR BUF))) (SETQ WORDLEVEL T] (T (SETQ NEWSTART NIL))) (COND ((OR (NEQPOS START NEWSTART) (NEQPOS END NEWEND) (NEQ MODE NEWMODE)) (COND (START (* ; "turn off old selection") (INVERT.LONG.SEGMENT START END MODE))) (COND ((SETQ START NEWSTART) (INVERT.LONG.SEGMENT START (SETQ END NEWEND) (SETQ MODE NEWMODE] [(LASTMOUSESTATE (ONLY BLUE)) (* ; "Extend selection") [COND ((NOT START) (* ;  "No selection, extend from cursor") [SETQ NEWSTART (SETQ NEWEND (SETQ START (SETQ END (create MOUSEPOS ROWPOS _ \ARROW COLPOS _ \CURSOR] (SETQ WORDLEVEL (SETQ EXTENDING NIL)) (COND (INITMODE (SETQ MODE INITMODE) (* ; "E.g. in DO.MOUSE on BLUE") (SETQ INITMODE)) (T (SETQ MODE NEWMODE] (SETQ NEWROW (fetch (MOUSEPOS ROWPOS) of NEWPOS)) (COND [(NLISTP NEWPOS) (* ;  "No selection; cancel any existing extension") (COND (EXTENDING (COND ((NEQPOS START NEWSTART) (INVERT.LONG.SEGMENT NEWSTART START MODE) (SETQ NEWSTART START)) ((NEQPOS END NEWEND) (INVERT.LONG.SEGMENT END NEWEND MODE) (SETQ NEWEND END))) (SETQ EXTENDING NIL] (T (COND ((TTBEFOREPOS NEWPOS START) (* ;  "Extending to left of original selection") (COND ((AND EXTENDING (NEQPOS END NEWEND)) (* ;  "We were extending to right, so switch") (INVERT.LONG.SEGMENT END NEWEND MODE) (SETQ NEWEND END))) (INVERT.LONG.SEGMENT NEWSTART (SETQ NEWSTART (create MOUSEPOS using NEWPOS)) MODE)) (T (* ; "Extending to right") (COND ((AND EXTENDING (NEQPOS START NEWSTART)) (* ;  "We were extending to left, so switch") (INVERT.LONG.SEGMENT START NEWSTART MODE) (SETQ NEWSTART START))) (INVERT.LONG.SEGMENT NEWEND (SETQ NEWEND (TTNEXTPOS NEWROW (fetch (MOUSEPOS COLPOS) of NEWPOS))) MODE))) (SETQ EXTENDING T] (EXTENDING (* ;  "End of extension, make NEWSTART/END permanent") (SETQ START NEWSTART) (SETQ END NEWEND) (SETQ EXTENDING NIL))) finally (COND (START (* ; "There is a selection, so do it") (\CHECKCARET \DSP) (PROG ((STARTBUF (fetch (MOUSEPOS COLPOS) of START)) (ENDBUF (fetch (MOUSEPOS COLPOS) of END))) (COND [(EQ MODE 'COPY) (INVERT.LONG.SEGMENT START END MODE) (* ; "Take it as typein") (COND ((BEFOREBUF STARTBUF \CURSOR ENDBUF) (* ;  "Can't just unread, because structure will change as we do so") (READFROMBUF (COPY.SEGMENT STARTBUF ENDBUF))) (T (READFROMBUF STARTBUF ENDBUF T] ((AND (EQ MODE 'MOVE) (BEFOREBUF STARTBUF \CURSOR ENDBUF)) (* ;  "Action overlaps cursor, so effect is just to move cursor") (INVERT.LONG.SEGMENT START END MODE) (MOVE.TO.LINE (fetch (MOUSEPOS ROWPOS) of END) ENDBUF)) (T (* ;; "Delete or move selection, insert it as typein at cursor for the latter. We save away the selection in \LAST.DELETION to be restored later if desired") (SETQ SAVE (COND ((BEFOREBUF STARTBUF \CURSOR ENDBUF) (* ;  "The delete will move \CURSOR into trash heap") STARTBUF) (T \CURSOR))) (SETQ \LAST.DELETION (SETQ BUF (COPY.SEGMENT STARTBUF ENDBUF))) (* ; "Save selection") (DELETE.LONG.SEGMENT START END) (MOVE.TO.WHEREVER SAVE) (* ;  "Come back to where cursor is (may have moved)") (AND (EQ MODE 'MOVE) (READFROMBUF BUF NIL T]) (COPY.SEGMENT [LAMBDA (START END) (* bvm%: " 4-DEC-81 17:04") (for (TAIL _ START) by (CDR TAIL) until (EQ TAIL END) collect (CAR TAIL]) (DELETE.LONG.SEGMENT [LAMBDA (START END) (* ; "Edited 24-May-91 11:07 by jds") (DELETE.LONG.SEGMENT1 (fetch (MOUSEPOS ROWPOS) of START) (fetch (MOUSEPOS COLPOS) of START) (fetch (MOUSEPOS ROWPOS) of END) (fetch (MOUSEPOS COLPOS) of END]) (DELETE.LONG.SEGMENT1 [LAMBDA (STARTLINE STARTCOL ENDLINE ENDCOL) (* ; "Edited 24-May-91 10:38 by jds") (PROG (FIRSTLINE NEXTLINE NROWS) (COND ((EQ (SETQ NROWS (IDIFFERENCE (fetch (LINE ROW) of ENDLINE) (fetch (LINE ROW) of STARTLINE))) 0) (* ; "All on one line") (MOVE.TO.LINE STARTLINE STARTCOL) (FORWARD.DELETE.TO ENDCOL)) (T (MOVE.TO.LINE (SETQ FIRSTLINE (fetch (LINE NEXTLINE) of STARTLINE))) (DO.DELETE.LINES NROWS) (* ; "Delete excess lines") (SETQ NEXTLINE (fetch (LINE NEXTLINE) of ENDLINE)) (replace (LINE NEXTLINE) of STARTLINE with NEXTLINE) (RENUMBER.LINES NEXTLINE (ADD1 (fetch (LINE ROW) of STARTLINE))) [add (fetch (LINE LASTCOL) of STARTLINE) (IDIFFERENCE (SEGMENT.BIT.LENGTH ENDCOL (fetch (LINE END) of ENDLINE)) (SEGMENT.BIT.LENGTH STARTCOL (fetch (LINE END) of STARTLINE ] (replace (LINE END) of STARTLINE with (fetch (LINE END) of ENDLINE )) (COND ((EQ ENDCOL (fetch (LINE END) of STARTLINE)) (replace (LINE END) of STARTLINE with STARTCOL))) (KILLSEGMENT STARTCOL ENDCOL) (replace (LINE NEXTLINE) of ENDLINE with NIL) (KILL.LINES FIRSTLINE) (MOVE.TO.LINE STARTLINE STARTCOL) (ERASE.TO.END.OF.LINE) (COND ((ILESSP (fetch (LINE LASTCOL) of STARTLINE) \RMARG) (TYPE.BUFFER STARTCOL (fetch (LINE END) of STARTLINE))) (T (TYPE.BUFFER STARTCOL (NTH.COLUMN.OF STARTLINE \RMARG)) (ADJUSTLINE NIL STARTLINE]) (INVERT.LONG.SEGMENT [LAMBDA (START END MODE) (* ; "Edited 24-May-91 11:07 by jds") (COND ((NOT (EQPOS START END)) (OR (TTBEFOREPOS START END) (swap START END)) (PROG ((COL (fetch (MOUSEPOS COLPOS) of START)) (ROW (fetch (MOUSEPOS ROWPOS) of START))) (while (NEQ ROW (fetch (MOUSEPOS ROWPOS) of END)) do (INVERT.SEGMENT COL (fetch (LINE START) of (fetch (LINE NEXTLINE) of ROW)) ROW MODE T) (SETQ ROW (fetch (LINE NEXTLINE) of ROW)) (SETQ COL (fetch (LINE START) of ROW))) (INVERT.SEGMENT COL (fetch (MOUSEPOS COLPOS) of END) ROW MODE T]) (INVERT.SEGMENT [LAMBDA (START END LINE MODE NOSWAP) (DECLARE (USEDFREE \ARROW \CHARWIDTH \LOC.ROW.0 \CHARHEIGHT \BMARG \LMARG)) (* ; "Edited 24-May-91 10:38 by jds") (COND ((NEQ START END) (OR LINE (SETQ LINE \ARROW)) (OR MODE (SETQ MODE 'DELETE)) (OR NOSWAP (BEFOREBUF START END (fetch (LINE END) of LINE)) (swap START END)) (PROG ((LEFT (+ (fetch (LINE FIRSTCOL) of LINE) (SEGMENT.BIT.LENGTH (fetch (LINE START) of LINE) START))) (BOTTOM (+ (ITIMES (- \TTPAGELENGTH \LOC.ROW.0 (fetch (LINE ROW) of LINE) 1) \CHARHEIGHT) \BMARG (- \DESCENT))) (WIDTH (SEGMENT.BIT.LENGTH START END))) (BLTSHADE (COND ((NEQ MODE 'COPY) BLACKSHADE) (T DOTSHADE)) \DSP LEFT BOTTOM WIDTH (COND ((NEQ MODE 'COPY) \CHARHEIGHT) (T 2)) 'INVERT) (COND ((EQ MODE 'MOVE) (BLTSHADE DOTSHADE \DSP LEFT BOTTOM WIDTH 2 'INVERT]) (BRACKET.CURRENT.WORD [LAMBDA (LINE COL) (* ; "Edited 24-May-91 10:38 by jds") (* ;;; "Return dotted pair of columns indicating start and end of 'word' containing buffer position COL of LINE") (PROG ((INSPACES T) (ENDLINE (fetch (LINE END) of LINE)) (WSTART (fetch (LINE START) of LINE)) FIRSTCOL LASTCOL) (for (BUF _ WSTART) by (TTNEXTCHAR BUF) until (EQ BUF ENDLINE) do [COND ([NEQ INSPACES (SETQ INSPACES (WORDSEPRP (FIRSTCHAR BUF] (* ; "Change of state") (COND (FIRSTCOL (* ; "Done") (RETURN (SETQ LASTCOL BUF))) (T (* ;  "Still looking for COL, note start of word") (SETQ WSTART BUF] (COND ((EQ BUF COL) (SETQ FIRSTCOL WSTART))) finally (* ; "Got to end before word ended") (SETQ LASTCOL ENDLINE) (OR FIRSTCOL (SETQ FIRSTCOL LASTCOL))) (OR (BEFOREBUF FIRSTCOL COL LASTCOL) (HELP)) (RETURN (CONS FIRSTCOL LASTCOL]) (TTBEFOREPOS [LAMBDA (X Y) (* ; "Edited 24-May-91 11:08 by jds") (COND [(EQ (fetch (MOUSEPOS ROWPOS) of X) (fetch (MOUSEPOS ROWPOS) of Y)) (AND (NEQ (fetch (MOUSEPOS COLPOS) of X) (fetch (MOUSEPOS COLPOS) of Y)) (BEFOREBUF (fetch (MOUSEPOS COLPOS) of X) (fetch (MOUSEPOS COLPOS) of Y) (fetch (LINE END) of (fetch (MOUSEPOS ROWPOS) of X] (T (ILESSP (fetch (LINE ROW) of (fetch (MOUSEPOS ROWPOS) of X)) (fetch (LINE ROW) of (fetch (MOUSEPOS ROWPOS) of Y]) (TTNEXTPOS [LAMBDA (LINE COL) (* ; "Edited 24-May-91 10:38 by jds") (* ;;; "Makes a MOUSEPOS out of the position, if any, immediately after COL of LINE") (COND ((AND (EQ COL (fetch (LINE END) of LINE)) (NEQ COL \ENDBUFFER)) (create MOUSEPOS ROWPOS _ (SETQ LINE (fetch (LINE NEXTLINE) of LINE)) COLPOS _ (fetch (LINE START) of LINE))) (T (create MOUSEPOS ROWPOS _ LINE COLPOS _ (COND ((EQ COL \ENDBUFFER) COL) (T (TTNEXTCHAR COL]) (TTRACKMOUSE [LAMBDA (OLDROW/COL) (* ; "Edited 24-May-91 11:14 by jds") (DECLARE (USEDFREE \TTPAGELENGTH \LOC.ROW.0 \BMARG \CHARHEIGHT \LMARG \RMARG \FONT)) (* ;; "Follows the mouse, returning whenever its row/col changes or the user lets up the mouse buttons. Converts mouse coordinates into a dotted pair (LINE . BUFPOS) indicating what char is being pointed at, or T if outside range of text. Returns NIL when user lets go. OLDROW/COL is the previous value of this routine, which we may smash.") (PROG (OLDX OLDY ROW COL OLDROW OLDCOL CURSORPOS) [COND ((LISTP OLDROW/COL) (SETQ OLDROW (CAR OLDROW/COL)) (SETQ OLDCOL (CDR OLDROW/COL] LP (COND ((MOUSESTATE UP) (* ; "everything up") (RETURN))) (SETQ CURSORPOS (CURSORPOSITION NIL \DSP CURSORPOS)) [COND ((OR (NEQ (CAR CURSORPOS) OLDX) (NEQ (CDR CURSORPOS) OLDY)) (* ; "Cursor moved") (SETQ ROW (- \TTPAGELENGTH \LOC.ROW.0 (IQUOTIENT (- (SETQ OLDY (CDR CURSORPOS)) \BMARG) \CHARHEIGHT) 1)) (SETQ OLDX (CAR CURSORPOS)) (COND [(AND (>= OLDX \LMARG) (< OLDX \RMARG) (>= ROW 0)) (SETQ ROW (TTNTHLINE ROW)) (SETQ COL (- OLDX (fetch (LINE FIRSTCOL) of ROW))) (SETQ COL (bind WIDTH CH (BUF _ (fetch (LINE START) of ROW)) (END _ (fetch (LINE END) of ROW)) while (NEQ BUF END) do (* ;  "Scan row for the specific character we're pointing at by adding widths as we go") [SETQ WIDTH (COND ((COMPLEXCHARP (SETQ CH (CAR BUF))) (fetch (COMPLEXCHAR CPXWIDTH) of CH)) (T (FCHARWIDTH CH \FONT] (COND ((< COL (LRSH WIDTH 1)) (RETURN BUF))) (SETQ COL (- COL WIDTH)) (SETQ BUF (TTNEXTCHAR BUF)) finally (RETURN BUF))) (COND ((OR (NEQ ROW OLDROW) (NEQ COL OLDCOL)) (* ; "We moved") (RETURN (COND ((LISTP OLDROW/COL) (FRPLNODE OLDROW/COL ROW COL)) (T (CONS ROW COL] (T (COND ((NEQ OLDROW/COL T) (RETURN T] (\TTYBACKGROUND) (GO LP]) ) (* ;; "Auxiliary fns. These are outside the TTYIN block, and are provided to aid the outside world in special interfaces to TTYIN" ) (DEFINEQ (SETREADFN [LAMBDA (FLG) (* bvm%: "10-MAR-83 21:46") (/SETATOMVAL 'LISPXREADFN (COND ((AND (NEQ FLG 'READ) (OR FLG TTYINBSFLG (DISPLAYTERMP)) (FGETD 'TTYINREAD) (DISPLAYSTARTEDP)) 'TTYINREAD) (T 'READ]) (TTYINENTRYFN [LAMBDA (WINDOW) (* bvm%: "24-Aug-84 16:31") (COND ((LASTMOUSESTATE (ONLY RIGHT)) (PROG [(STATE (WINDOWPROP WINDOW 'TTYINSTATE] (APPLY* (OR (AND STATE (fetch (TTYINWINDOWSTATE TTOLDRIGHTFN) of STATE)) (FUNCTION DOWINDOWCOM)) WINDOW))) (T (GIVE.TTY.PROCESS WINDOW]) (TTYINREADP [LAMBDA (FLG) (* ; "Edited 14-Apr-87 00:25 by bvm:") (* ;;; "Intended to replace LISPXREADP. Does the right thing when READBUF has just a in it") (COND (READBUF (OR (NEQ (CAR READBUF) HISTSTR0) FLG)) ((NOT (LINEBUFFER-EOFP \LINEBUF.OFD)) (OR FLG (NEQ (PEEKBINCCODE \LINEBUF.OFD) (CHARCODE EOL]) (TTYINREAD [LAMBDA (FILE RDTBL) (* ; "Edited 10-Dec-87 17:57 by raf") (COND ([OR (AND TTYINDEBUGFLG \INSIDE.TTYIN) (NOT (DISPLAYSTREAMP (GETSTREAM T 'OUTPUT] (* ;  "If debugging and TTYIN breaks, don't want to die") (READ FILE RDTBL)) (T (PROG (X) (RETURN (COND ((OR (LINEBUFFER-SKIPSEPRS \LINEBUF.OFD RDTBL) (EQ (SETQ X (TTYIN LISPXID NIL NIL '(EVALQT FILLBUFFER NOPROMPT) NIL NIL NIL RDTBL)) T)) (* ;  "Don't call TTYIN if there's something significant already in buffer") (* ;; "SKIPSEPRS used to be (do (COND ((EOFP \LINEBUF.OFD) (* Nothing in buffer) (RETURN)) ((NEQ (PEEKBINCCODE \LINEBUF.OFD) (CHARCODE EOL)) (* significant stuff) (RETURN T)) (T (BINCCODE \LINEBUF.OFD))))") (READ \LINEBUF.OFD RDTBL)) (T (* ; "indicate null input") (SETQ READBUF (NCONC1 (CDR X) HISTSTR0)) (CAR X]) (TTYINFIX [LAMBDA (INPUT COMS) (* ; "Edited 20-Jan-88 12:13 by bvm") (LET (TAIL) (COND ([OR COMS (NEQ LISPXREADFN 'TTYINREAD) (>= (COUNT INPUT) TTYINFIXLIMIT) (CDR (SETQ TAIL (MEMB HISTSTR0 INPUT] (NONTTYINLISPXFIX INPUT COMS)) (T (TTYIN LISPXID NIL NIL (COND ((for X in [COND ((EQ TAIL (CDR INPUT)) (CAR INPUT)) (T (OR (LISTP (CADR INPUT)) (CDR INPUT] thereis (LISTP X)) (* ; "Something worth prettyprinting") '(PRETTY EVALQT)) (T 'EVALQT)) NIL NIL INPUT T]) (CHARMACRO? [NLAMBDA (MACRO) (DECLARE (USEDFREE \READING LISPXID)) (* bvm%: "19-MAR-81 12:15") (* ;;; "For use in a TTYINREADMACRO. If we are reading inside the editor, clear the output buffer and return MACRO") (COND ((AND (EQ \READING 'EVALQT) (EQ LISPXID '*)) (COND ((LISTP MACRO) (* ;  "a list of edit commands; we'd better copy") (APPEND MACRO)) (T MACRO]) (TTYINMETA [LAMBDA (FLG) (* bvm%: " 2-May-85 14:27") (METASHIFT FLG]) (TTYIN.LASTINPUT [LAMBDA NIL (* ; "Edited 24-May-91 10:44 by jds") (PROG [(BUF (AND (LISTP TTYINBUFFER) (fetch (TTYINBUFFER OLDTAIL) of TTYINBUFFER] (RETURN (AND BUF (TTYINSTRING (fetch (LINE START) of (fetch (TTYINBUFFER FIRSTLINE) of TTYINBUFFER)) BUF]) ) (DEFINEQ (TTYINEDIT [LAMBDA (EXPRS WINDOW PRINTFN PROMPT RDTBL) (* ; "Edited 19-Jan-88 17:13 by bvm") (OR PRINTFN (SETQ PRINTFN TTYINPRINTFN)) (RESETLST (SET.TTYINEDIT.WINDOW WINDOW) (RESETSAVE (CURSOR T)) (* ;  "Make sure we have something to point with") (WITH-RESOURCES (TTSCRATCHFILE) (PROG1 (TTYIN (OR PROMPT TTYINEDITPROMPT) NIL NIL 'LISPXREAD NIL NIL [COND ([OR (EQ PRINTFN T) (AND (NULL PRINTFN) (NULL (CDR EXPRS)) (STRINGP (CAR EXPRS] (* ; "Don't prettyprint it") EXPRS) (T (LIST HISTSTR1 (LET* ((\DSP (GETSTREAM WINDOW)) (\INITPOS (DSPXPOSITION NIL \DSP)) (\RMARG (DSPRIGHTMARGIN NIL \DSP)) (\PROMPT1 (OR PROMPT TTYINEDITPROMPT))) (* ;  "Set up these vars for TTYIN.PPTOFILE to understand the environment better") (if (EQ \PROMPT1 T) then (SETQ \PROMPT1 NIL)) (TTYIN.PPTOFILE EXPRS PRINTFN RDTBL TTSCRATCHFILE] RDTBL) (COND ((AND TTYINAUTOCLOSEFLG WINDOW) (CLOSEW WINDOW))) (SETFILEPTR TTSCRATCHFILE 0]) (SIMPLETEXTEDIT [LAMBDA (FILE WINDOW) (* ; "Edited 17-Jan-88 15:29 by bvm:") (RESETLST (WITH-RESOURCES (TTSCRATCHFILE) (LET (INSTREAM MAINOUTPUT) (SET.TTYINEDIT.WINDOW WINDOW) (COND ([TTYIN TTYINEDITPROMPT NIL NIL '(TEXT NOVALUE) TTSCRATCHFILE NIL (COND (FILE (* ; "User specified a file to edit") [RESETSAVE NIL (LIST 'CLOSEF (SETQ INSTREAM (OPENSTREAM FILE 'INPUT] `(,HISTSTR1 (,INSTREAM 0 ,@(GETEOFPTR INSTREAM] (repeatuntil [AND [SETQ MAINOUTPUT (COND (INSTREAM (* ;  "Default output to new version of input") (PROG1 (PACKFILENAME.STRING 'VERSION NIL 'BODY INSTREAM) (SETQ INSTREAM))) [(TTYIN "Output file: " NIL "Name of file for edited output" '(NORAISE STRING] ((CL:Y-OR-N-P "Abort edit? ") (* ;  "Really didn't want to write it anywhere") (RETURN NIL] (NLSETQ (SETQ MAINOUTPUT (OPENSTREAM MAINOUTPUT 'OUTPUT] finally (* ;  "Copy from scratch file to real output file") (COPYBYTES TTSCRATCHFILE MAINOUTPUT 0 (GETFILEPTR TTSCRATCHFILE)) (SETFILEPTR TTSCRATCHFILE 0) (* ;  "Leave scratch file in good shape") (RETURN (CLOSEF MAINOUTPUT]) (SET.TTYINEDIT.WINDOW [LAMBDA (WINDOW) (* lmm "14-Nov-86 17:04") (* ;; "Changes output to WINDOW, or the TTYIN edit window, returning the resulting WINDOW, or NIL if there is no window change. Caller must have RESETLST") (COND ((EQ WINDOW T) (* ; "Use current window") NIL) (T [OR WINDOW (SETQ WINDOW (OR TTYINEDITWINDOW (SETQ TTYINEDITWINDOW (CREATEW NIL "Edit Work Area"] (CLEARW WINDOW) [PROG [(OFFSET (IREMAINDER (WINDOWPROP WINDOW 'HEIGHT) (IMINUS (DSPLINEFEED NIL WINDOW] (COND ((NEQ OFFSET 0) (* ;; "Window is not an integral number of lines, so start down a little, so that bottom line will be correctly aligned (we count from bottom of screen)") (RELMOVETO 0 (IMINUS OFFSET) WINDOW] (RESETSAVE (TTYDISPLAYSTREAM WINDOW)) WINDOW]) (TTYIN.PPTOFILE [LAMBDA (EXPRS PRINTFN RDTBL STREAM) (* ; "Edited 19-Jan-88 17:19 by bvm") (* ;;; "Prettyprint each of EXPRS to a scratch file, returning (scratchfile start . end), as TTYIN would like. If STREAM is supplied, it is a scratch stream") (LET ([*STANDARD-OUTPUT* (OR STREAM (OPENSTREAM '{NODIRCORE} 'BOTH] (*READTABLE* (\GTREADTABLE RDTBL T)) (*PRINT-ARRAY* T) (*PRINT-STRUCTURE* T) (FONTCHANGEFLG NIL)) (DECLARE (CL:SPECIAL FONTCHANGEFLG)) (* ; "The others already are") (SETFILEPTR *STANDARD-OUTPUT* 0) (LINELENGTH (- (IQUOTIENT (- \RMARG \INITPOS) (CHARWIDTH (CHARCODE X) \DSP)) (if \PROMPT1 then (NCHARS \PROMPT1) else 0)) *STANDARD-OUTPUT*) (* ;  "Prettyprint to a linelength that accounts for available space, excluding margins and prompt") (COND ((AND PRINTFN (NEQ PRINTFN 'PRETTY)) (CL:FUNCALL (COND ((EQ PRINTFN T) 'PRINT) (T PRINTFN)) EXPRS *STANDARD-OUTPUT*)) ((AND (CDR EXPRS) (NLISTP (CAR EXPRS))) (* ;  "Be careful not to separate exec command or apply fn from its args") (PRIN2 (CAR EXPRS) *STANDARD-OUTPUT*) (SPACES 1 *STANDARD-OUTPUT*) (PRINTDEF (CDR EXPRS) (POSITION) T T NIL *STANDARD-OUTPUT*)) (T (PRINTDEF EXPRS NIL T T NIL *STANDARD-OUTPUT*))) (CONS *STANDARD-OUTPUT* (CONS 0 (GETFILEPTR *STANDARD-OUTPUT*]) ) (* ; "New, correct way of getting scratch file") (DEFINEQ (MAKE-TTSCRATCHFILE [LAMBDA NIL (* ; "Edited 17-Jan-88 15:16 by bvm:") (OPENSTREAM '{NODIRCORE} 'BOTH]) ) (DECLARE%: EVAL@COMPILE [PUTDEF 'TTSCRATCHFILE 'RESOURCES '(NEW (MAKE-TTSCRATCHFILE] ) (* ; "Obsolete, but maybe someone calls it") (DEFINEQ (TTYIN.SCRATCHFILE [LAMBDA NIL (DECLARE (GLOBALVARS TTYINEDIT.SCRATCH)) (* lmm "14-Nov-86 17:05") [COND ([OR (NOT TTYINEDIT.SCRATCH) (NOT (OPENP TTYINEDIT.SCRATCH 'BOTH] (SETQ TTYINEDIT.SCRATCH (OPENSTREAM '{NODIRCORE} 'BOTH 'OLD/NEW NIL (CONSTANT (LIST (LIST 'ENDOFSTREAMOP (FUNCTION \TTYIN.RPEOF] (SETFILEPTR TTYINEDIT.SCRATCH 0) TTYINEDIT.SCRATCH]) (\TTYIN.RPEOF [LAMBDA (STREAM) (* lmm "14-Nov-86 17:06") (* ;  "End of stream op for ttyin scratch file -- supplies as many closing parens as needed") (CHARCODE ")"]) ) (RPAQ? TTYINEDIT.SCRATCH ) (RPAQ? TTYINEDITWINDOW ) (RPAQ? TTYINEDITPROMPT T) (RPAQ? TTYINAUTOCLOSEFLG ) (RPAQ? TTYINPRINTFN ) (RPAQ? TTYIN?=FN ) (* ; "Kludge of the week") (DEFINEQ (TTYINPROMPTFORWORD [LAMBDA (PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION TERMINCHARS.LST KEYBD.CHANNEL) (* ; "Edited 8-Feb-88 14:26 by bvm:") (* ;; "Attempt at a plug-compatible replacement for common cases of PROMPTFORWORD -- lets you use your mouse and other editing commands.") (LET ((TYPE 'PROMPTFORWORD)) (* ;  "Default uses space or cr to terminate") (if [OR DONTECHOTYPEIN.FLG KEYBD.CHANNEL [if (NULL TERMINCHARS.LST) then (SETQ TYPE 'PROMPTFORWORD-SPACE) (* ; "Default is CR SPACE") NIL else (for C in TERMINCHARS.LST do (SELCHARQ C (SPACE (SETQ TYPE 'PROMPTFORWORD-SPACE)) ((CR ^X) (* ; "ok, ttyin uses these by default") ) (if TTYIN.USE.EXACT.CHARS then (* ; "A terminator we can't handle") (RETURN T] (AND ECHO.CHANNEL (NOT (DISPLAYSTREAMP (SETQ ECHO.CHANNEL (GETSTREAM ECHO.CHANNEL 'OUTPUT] then (* ; "Sorry, can't help") (NON-TTYIN-PROMPTFORWORD PROMPT.STR CANDIDATE.STR GENERATE?LIST.FN ECHO.CHANNEL DONTECHOTYPEIN.FLG URGENCY.OPTION TERMINCHARS.LST KEYBD.CHANNEL) else (RESETLST [if (AND (EQ URGENCY.OPTION 'TTY) (NOT (TTY.PROCESSP))) then (* ; "Caller wants to grab tty") (RESETSAVE (TTY.PROCESS (THIS.PROCESS] (if (AND ECHO.CHANNEL (NEQ ECHO.CHANNEL (TTYDISPLAYSTREAM))) then (RESETSAVE (TTYDISPLAYSTREAM ECHO.CHANNEL))) (TTYIN (COND ((NOT PROMPT.STR) T) ((EQ (NTHCHARCODE PROMPT.STR -1) (CHARCODE SPACE)) PROMPT.STR) (T (* ;  "Promptforword spaces after prompt") (CONCAT PROMPT.STR " "))) NIL (STRINGP GENERATE?LIST.FN) TYPE NIL NIL (if (FIXP CANDIDATE.STR) then (* ;  "Coerce integer to string, or otherwise ttyin will interpret it as a character code") (MKSTRING CANDIDATE.STR) else CANDIDATE.STR]) ) (RPAQ? TTYIN.USE.EXACT.CHARS ) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD? 'PROMPTFORWORD 'NON-TTYIN-PROMPTFORWORD NIL T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RPAQQ TTCOMPILETIME [(VARS TTYINBLOCKS) (LOCALVARS . T) (SPECVARS HELP RDTBL SPLST TABS OPTIONS ECHOTOFILE \ARROW \AUTOFILL \BMARG \BUFFER \CHARHEIGHT \CHARWIDTH \COMMAND \CURSOR \CURSORCOL \CURSORROW \DELETING \DESCENT \ENDBUFFER \FIRSTLINE \FIX \HOMECOL \HOMEROW \INITPOS \LASTAIL \LASTCHAR \LMARG \LOC.ROW.0 \NOFIXSPELL \PROMPT1 \PROMPT2 \READING \REPEAT \RMARG \INSIDE.TTYIN \TTYINSTATE \TTPAGELENGTH \RAISEINPUT \FIRSTTIME \DONTCOMPLETE \NOVALUE \STRINGVALUE \LISPXREADING \FILLINGBUFFER \RDTBLSA \LAST.DELETION \FONT \TEXTURE \LASTAILROW \LASTAILCOL \TTYINBUFFERSTREAM \PROMPTFORWORD \PFW.FIRSTTIME \DSP \INITCRLFS \COMMENTFONT) (GLOBALVARS ?ACTIVATEFLG CTRLUFLG CTRLVFLG EDITPREFIXCHAR EOLCHARCODE HISTSTR0 HISTSTR1 SPELLSTR1 LASTMOUSEBUTTONS LASTWORD LISPXREADFN SHOWPARENFLG SPELLSTR1 SPELLSTR2 TTYINAUTOCLOSEFLG TTYINBSFLG TTYINBUFFER TTYINCOMMENTCHAR TTYINCOMPLETEFLG TTYINEDITPROMPT TTYINEDITWINDOW TTYINERRORSETFLG TTYINRAISEFLG TTYINREADMACROS TTYINRESPONSES TTYINUSERFN TTYJUSTLENGTH TYPEAHEADFLG USERWORDS null TTYINAUTOFILLMARGIN TTYINPRINTFN TTYIN?=FN TTYINFIXLIMIT TTYINDEBUGFLG DORADO.RESTORE.BUF.CODES TTYIN.RESTORE.BUF.CODES \RESTOREBUFCODES) (MACROS * TTYINMACROS) (RECORDS LINE TTYINBUFFER TTYINWINDOWSTATE MOUSEPOS COMPLEXCHAR TTYINBUFFERSTREAM) (VARS DMCHARCODES TTSUPPORTFNS) (ADDVARS (DONTCOMPILEFNS DELETETO1)) (CONSTANTS (DISPLAYTERMFLG T) (TTYINMAILFLG) (DIDESCAPECODE 283) DOTSHADE) (VARS TTNILFNS) (MACROS * TTNILFNS) (DECLARE%: DONTEVAL@COMPILE (TEMPLATES TTBOUT TTBOUTN) DONTEVAL@LOAD EVAL@COMPILE (VARS (DONTCOMPILEFNS (UNION (UNION TTYINMACROS TTSUPPORTFNS) DONTCOMPILEFNS]) (RPAQQ TTYINBLOCKS ((TTYIN TTYIN TTBIN TTCRLF TTCRLF.ACCOUNT SCANFORWARD TTNLEFT TTNTH TTPRIN1 TTPROMPTCHAR TTRATOM TTREAD TTREADLIST TTSKIPSEPR TTSKREAD TTYINSTRING ADDCHAR ADDNAKEDCHAR AUTOCR? BACKWARD.DELETE.TO BEEP BUFTAILP CLEAR.LINE? CREATE.LINE DELETE.TO.END DELETETO DELETETO1 DELNCHARS TTECHO.TO.FILE END.DELETE.MODE ENDREAD? AT.END.OF.TEXT FIND.START.OF.WORD TTADJUSTWORD FORWARD.DELETE.TO GO.TO.RELATIVE GO.TO.ADDRESSING GO.TO.FREELINE INIT.CURSOR INSERT.CHAR.IN.BUF ADDCHARS.INSERTING INSERT.NODE TTRUBOUT KILL.LINES KILLSEGMENT MOVE.BACK.TO MOVE.FORWARD.TO MOVE.TO.NEXT.LINE START.NEW.LINE TTNEXTCHAR TTNEXTNODE OVERFLOW? PROPERTAILP RESTORE.CURSOR SAVE.CURSOR SCRATCHCONS SETLASTC SETTAIL? SPACE/PARENP DO.EDIT.COMMAND ADDSILENTCHAR TTADDTAB AT.END.OF.SCREEN SCANBACK BACKSKREAD BREAKLINE SEGMENT.LENGTH CHECK.MARGIN TTCOMPLETEWORD FIND.MATCHING.WORD NTHCHARCODE DELETELINE DO?CMD TTDOTABS EDITCOLUMN FIND.LINE FIND.LINE.BREAK ADJUSTLINE START.OF.PARAGRAPH? ADJUSTLINE.AND.RESTORE TTGIVEHELP TTGIVEHELP1 TTGIVEHELP2 INSERTLINE TTLASTLINE TTLOADBUF MOVE.TO.LINE MOVE.TO.START.OF.WORD MOVE.TO.WHEREVER TTNEXTLINE FIND.MATCHING.QUOTE FIND.NEXT.WORD NTH.COLUMN.OF NTH.RELATIVE.COLUMN.OF OVERFLOWLINE? PREVLINE PREVWORD READFROMBUF RENUMBER.LINES RESTOREBUF RETYPE.BUFFER SHOW.MATCHING.PAREN SKIP/ZAP SLEEP CURRENT.WORD TYPE.BUFFER U/L-CASE TTUNREADBUF DO.BACK DO.DELETE.LINES DO.DOWN DO.FORWARD DO.INSERT.LINE DO.UP ERASE.SCREEN ERASE.TO.END.OF.LINE ERASE.TO.END.OF.PAGE INSERT.TEXT INSERTNCHARS TTSETCURSOR (LOCALFREEVARS ARROW AUTOFILL BUFFER COMMAND CURSOR DELETING EDITBIT ENDBUFFER INITPOS INSERTING NOFIXSPELL READING REPEAT) (SPECVARS CTRLO!) (LINKFNS . T) (NOLINKFNS DISPLAYHELP DISPLAYTERMP EDITE ERROR! FIXSPELL!! GRIPE GUESTUSER? MAILWATCH MWNOTE SETBACKSPACE SHOULDNT SMARTARGLIST SPRINTT STKEVAL STRPOS USEREXEC XHELPSYS) (BLKLIBRARY NLEFT)) (NIL TTYINREAD (LOCALVARS . T) (LINKFNS TTYIN)) (NIL DISPLAYTERMP SETREADFN TTECHOMODE TTED TTYINPEEKC TTYINREADP TTYINREADPREP CHARMACRO? (LOCALVARS . T)))) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS HELP RDTBL SPLST TABS OPTIONS ECHOTOFILE \ARROW \AUTOFILL \BMARG \BUFFER \CHARHEIGHT \CHARWIDTH \COMMAND \CURSOR \CURSORCOL \CURSORROW \DELETING \DESCENT \ENDBUFFER \FIRSTLINE \FIX \HOMECOL \HOMEROW \INITPOS \LASTAIL \LASTCHAR \LMARG \LOC.ROW.0 \NOFIXSPELL \PROMPT1 \PROMPT2 \READING \REPEAT \RMARG \INSIDE.TTYIN \TTYINSTATE \TTPAGELENGTH \RAISEINPUT \FIRSTTIME \DONTCOMPLETE \NOVALUE \STRINGVALUE \LISPXREADING \FILLINGBUFFER \RDTBLSA \LAST.DELETION \FONT \TEXTURE \LASTAILROW \LASTAILCOL \TTYINBUFFERSTREAM \PROMPTFORWORD \PFW.FIRSTTIME \DSP \INITCRLFS \COMMENTFONT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ?ACTIVATEFLG CTRLUFLG CTRLVFLG EDITPREFIXCHAR EOLCHARCODE HISTSTR0 HISTSTR1 SPELLSTR1 LASTMOUSEBUTTONS LASTWORD LISPXREADFN SHOWPARENFLG SPELLSTR1 SPELLSTR2 TTYINAUTOCLOSEFLG TTYINBSFLG TTYINBUFFER TTYINCOMMENTCHAR TTYINCOMPLETEFLG TTYINEDITPROMPT TTYINEDITWINDOW TTYINERRORSETFLG TTYINRAISEFLG TTYINREADMACROS TTYINRESPONSES TTYINUSERFN TTYJUSTLENGTH TYPEAHEADFLG USERWORDS null TTYINAUTOFILLMARGIN TTYINPRINTFN TTYIN?=FN TTYINFIXLIMIT TTYINDEBUGFLG DORADO.RESTORE.BUF.CODES TTYIN.RESTORE.BUF.CODES \RESTOREBUFCODES) ) (RPAQQ TTYINMACROS (TYPEAHEAD? AT.END.OF.BUF AT.END.OF.LINE AT.START.OF.BUF AT.START.OF.LINE BEFOREBUF BREAK.OR.SEPRP DISPLAYTERMP EMPTY.BUFFER EMPTY.LINE EQPOS NEQPOS INPART ON.FIRST.LINE ON.LAST.LINE METACHARP NONMETACHARBITS METACHAR COMPLEXCHARP STREAMBYTESPERCHAR SPACEP TTBOUT TTNEXTCHAR BOUTCCODE PEEKBINCCODE BINCCODE WORDSEPRP FCHARWIDTH FIRSTCHAR)) (DECLARE%: EVAL@COMPILE (PUTPROPS TYPEAHEAD? MACRO (NIL (\SYSBUFP))) (PUTPROPS AT.END.OF.BUF MACRO (NIL (EQ \CURSOR \ENDBUFFER))) (PUTPROPS AT.END.OF.LINE MACRO (NIL (EQ (fetch END of \ARROW) \CURSOR))) (PUTPROPS AT.START.OF.BUF MACRO (NIL (EQ \CURSOR \BUFFER))) (PUTPROPS AT.START.OF.LINE MACRO (NIL (EQ (fetch START of \ARROW) \CURSOR))) (PUTPROPS BEFOREBUF MACRO ((THIS THAT END) (BUFTAILP THAT THIS END))) (PUTPROPS BREAK.OR.SEPRP MACRO ((C) (fetch STOPATOM of (\SYNCODE \RDTBLSA C)))) (PUTPROPS DISPLAYTERMP ALTOMACRO (NIL T)) (PUTPROPS EMPTY.BUFFER MACRO (NIL (EQ \BUFFER \ENDBUFFER))) (PUTPROPS EMPTY.LINE MACRO [X (SUBST (OR (CAR X) '\ARROW) '\ARROW '(EQ (fetch START of \ARROW) (fetch END of \ARROW]) (PUTPROPS EQPOS MACRO [(X Y) (AND (EQ (fetch COLPOS of X) (fetch COLPOS of Y)) (EQ (fetch ROWPOS of X) (fetch ROWPOS of Y]) (PUTPROPS NEQPOS MACRO ((X Y) (NOT (EQPOS X Y)))) (PUTPROPS INPART MACRO (OPENLAMBDA (X) (COND ((LISTP X) (CAR X)) (T X)))) (PUTPROPS ON.FIRST.LINE MACRO (NIL (EQ \FIRSTLINE \ARROW))) (PUTPROPS ON.LAST.LINE MACRO (NIL (EQ (fetch END of \ARROW) \ENDBUFFER))) (PUTPROPS METACHARP MACRO ((C) (EQ (LRSH C 8) 1))) (PUTPROPS NONMETACHARBITS MACRO ((C) (LOGAND C 255))) (PUTPROPS METACHAR MACRO ((C) (LOGOR C 256))) (PUTPROPS COMPLEXCHARP MACRO (= . LISTP)) (PUTPROPS STREAMBYTESPERCHAR MACRO ((STREAM) (COND ((\RUNCODED STREAM) 1) (T 2)))) (PUTPROPS SPACEP MACRO [(CHAR) (FMEMB CHAR (CHARCODE (SPACE TAB CR]) (PUTPROPS TTBOUT MACRO [X (CONS 'PROGN (for ARG in X collect (LIST 'BLTCHAR (OR (FIXP ARG) (CDR (ASSOC ARG DMCHARCODES)) (AND (EQ (NCHARS ARG) 1) (CHCON1 ARG)) ARG) '(TTYDISPLAYSTREAM]) (PUTPROPS TTNEXTCHAR MACRO (= . CDR)) (PUTPROPS BOUTCCODE MACRO (OPENLAMBDA (STREAM CHAR) (PRINTCCODE CHAR STREAM))) (PUTPROPS PEEKBINCCODE MACRO (= . PEEKCCODE)) (PUTPROPS BINCCODE MACRO (= . READCCODE)) (PUTPROPS WORDSEPRP DMACRO [OPENLAMBDA (X) (OR (EQ (\SYNCODE \PRIMTERMSA X) WORDSEPR.TC) (fetch STOPATOM of (\SYNCODE \RDTBLSA X]) (PUTPROPS FCHARWIDTH MACRO (= . CHARWIDTH)) (PUTPROPS FIRSTCHAR MACRO ((BUF) ([LAMBDA (CH) (DECLARE (LOCALVARS CH)) (COND ((COMPLEXCHARP CH) (fetch CPXREALCHAR of CH)) (T CH] (CAR BUF)))) ) (DECLARE%: EVAL@COMPILE (RECORD LINE (START END FIRSTCOL LASTCOL ROW . NEXTLINE)) (RECORD TTYINBUFFER (FIRSTLINE OLDTAIL LASTSKIP LASTSKIPCHAR STORAGECOUNTER TTYINWINDOW . TTYINWINDOWSTATE) (SUBRECORD TTYINWINDOWSTATE) STORAGECOUNTER _ 0) (RECORD TTYINWINDOWSTATE (TTOLDBUTTONFN TTOLDRIGHTFN TTOLDENTRYFN)) (RECORD MOUSEPOS (ROWPOS . COLPOS)) (RECORD COMPLEXCHAR (CPXREALCHAR CPXWIDTH CPXNCHARS . CPXPRINTCHARS)) (ACCESSFNS TTYINBUFFERSTREAM ((TTYINPUT (fetch (STREAM F1) of DATUM) (replace (STREAM F1) of DATUM with NEWVALUE)) (TTYEOF (fetch (STREAM F2) of DATUM) (replace (STREAM F2) of DATUM with NEWVALUE)) (TTYEOFACTION (fetch (STREAM F3) of DATUM) (replace (STREAM F3) of DATUM with NEWVALUE)) (TTYORIGINPUT (fetch (STREAM F4) of DATUM) (replace (STREAM F4) of DATUM with NEWVALUE)))) ) (RPAQQ DMCHARCODES ((HOME . 2) (BELL . 7) (DELCH . 8) (BS . 8) (DOWN . 10) (INSERT.LINE . 10) (LF . 10) (ADDR . 12) (CR . 13) (BLINKON . 14) (INSERT/DELETE . 16) (DLE . 16) (ERASE.TO.END . 23) (CANCEL . 24) (UP . 26) (DELETE.LINE . 26) (ESC . 27) (FORWARD . 28) (ROLL . 29) (ERASE . 30) (CLEAR . 30) (US . 31) (SPACE . 32))) (RPAQQ TTSUPPORTFNS NIL) (ADDTOVAR DONTCOMPILEFNS DELETETO1) (DECLARE%: EVAL@COMPILE (RPAQQ DISPLAYTERMFLG T) (RPAQQ TTYINMAILFLG NIL) (RPAQQ DIDESCAPECODE 283) (RPAQQ DOTSHADE 13260) (CONSTANTS (DISPLAYTERMFLG T) (TTYINMAILFLG) (DIDESCAPECODE 283) DOTSHADE) ) (RPAQQ TTNILFNS (BINARY.MODE RESTOREMOD CANCEL.MODES GUESTUSER?)) (RPAQQ TTNILFNS (BINARY.MODE RESTOREMOD CANCEL.MODES GUESTUSER?)) (DECLARE%: EVAL@COMPILE (PUTPROPS BINARY.MODE MACRO (NIL NIL)) (PUTPROPS RESTOREMOD MACRO (NIL NIL)) (PUTPROPS CANCEL.MODES MACRO (NIL NIL)) (PUTPROPS GUESTUSER? MACRO (NIL NIL)) ) (DECLARE%: DONTEVAL@COMPILE [SETTEMPLATE 'TTBOUT '(CALL |..| (IF [OR (LISTP EXPR) (AND (NTHCHAR EXPR 2) (NOT (ASSOC EXPR DMCHARCODES] EVAL NIL] [SETTEMPLATE 'TTBOUTN '(MACRO (X . Y) (FRPTQ X (TTBOUT . Y] DONTEVAL@LOAD EVAL@COMPILE (RPAQ DONTCOMPILEFNS (UNION (UNION TTYINMACROS TTSUPPORTFNS) DONTCOMPILEFNS)) ) ) (RPAQ? DORADO.RESTORE.BUF.CODES '(194)) (RPAQ? TTYIN.RESTORE.BUF.CODES '(516 530)) (RPAQ? TTYINBUFFER ) (RPAQ? ?ACTIVATEFLG T) (RPAQ? EDITPREFIXCHAR ) (RPAQ? SHOWPARENFLG T) (RPAQ? TTYINBSFLG T) (RPAQ? \TTYIN.LAST.FONT ) (RPAQ? \TTYIN.LAST.COMMENTFONT ) (RPAQ? TTYINFILLDEFAULT T) (RPAQ? TTYINCOMPLETEFLG T) (RPAQ? TTYINUSERFN ) (RPAQ? TYPEAHEADFLG T) (RPAQ? null "") (RPAQ? DEFAULTPROMPT "** ") (RPAQ? TTYJUSTLENGTH -1) (RPAQ? \INSIDE.TTYIN ) (RPAQ? TTYINERRORSETFLG ) (RPAQ? TTYINRAISEFLG T) (RPAQ? TTYINAUTOFILLMARGIN 8) (RPAQ? TTYINFIXLIMIT 50) (RPAQ? TTYINDEBUGFLG ) (RPAQ? HISTSTR1 "from file:") (RPAQ? TTYINCOMMENTCHAR ) (RPAQ? \RESTOREBUFCODES ) (MOVD? 'NILL 'GUESTUSER?) (MOVD? 'FIXSPELL 'FIXSPELL!!) (MOVD? 'HELPSYS 'XHELPSYS) [PUTDQ? SPRINTT (LAMBDA (X) (PRIN1 X] (MOVD? 'NILL 'WINDOWWORLD) (MOVD? 'LISPXFIX 'NONTTYINLISPXFIX) (ADDTOVAR TTYINREADMACROS ) (ADDTOVAR TTYINRESPONSES ) (ADDTOVAR LISPXCOMS (STOP . OK)) (ADDTOVAR \SYSTEMCACHEVARS \RESTOREBUFCODES) (PUTPROPS TTYINREADMACROS VARTYPE ALIST) (DECLARE%: DONTEVAL@LOAD DOCOPY [COND ((CCODEP 'TTYIN) (CHANGENAME 'PROMPTCHAR 'LISPXREADP 'TTYINREADP) (SETREADFN) (MOVD 'TTYINFIX 'LISPXFIX] ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML CHARMACRO?) (ADDTOVAR LAMA ) ) (PUTPROPS TTYIN COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9111 208710 (TTYIN 9121 . 22354) (TTYIN.SETUP 22356 . 25432) (TTYIN.CLEANUP 25434 . 26262) (TTYIN1 26264 . 52747) (TTYIN1RESTART 52749 . 54013) (TTYIN.FINISH 54015 . 63432) ( TTYIN.BALANCE 63434 . 64560) (ADDCHAR 64562 . 66748) (TTMAKECOMPLEXCHAR 66750 . 67224) (ADDNAKEDCHAR 67226 . 68736) (TTADDTAB 68738 . 69673) (ADJUSTLINE 69675 . 83542) (ADJUSTLINE.AND.RESTORE 83544 . 83982) (AT.END.OF.SCREEN 83984 . 84272) (AT.END.OF.TEXT 84274 . 84729) (AUTOCR? 84731 . 85205) ( BACKSKREAD 85207 . 89792) (BACKWARD.DELETE.TO 89794 . 89976) (BREAKLINE 89978 . 92245) (BUFTAILP 92247 . 92565) (CHECK.MARGIN 92567 . 93190) (CLEAR.LINE? 93192 . 93485) (CURRENT.WORD 93487 . 95887) ( DELETE.TO.END 95889 . 96608) (DELETELINE 96610 . 99567) (DELETETO 99569 . 101391) (DELETETO1 101393 . 102736) (DO.EDIT.COMMAND 102738 . 120057) (DO.EDIT.PP 120059 . 122721) (TTDOTABS 122723 . 124093) ( EDITCOLUMN 124095 . 124551) (EDITNUMBERP 124553 . 124784) (END.DELETE.MODE 124786 . 125303) (ENDREAD? 125305 . 127740) (FIND.LINE 127742 . 129278) (FIND.LINE.BREAK 129280 . 129950) (FIND.MATCHING.QUOTE 129952 . 130797) (FIND.NEXT.WORD 130799 . 132178) (FIND.NON.SPACE 132180 . 132453) (FIND.START.OF.WORD 132455 . 132818) (FORWARD.DELETE.TO 132820 . 135042) (GO.TO.ADDRESSING 135044 . 136000) ( GO.TO.FREELINE 136002 . 136583) (GO.TO.RELATIVE 136585 . 137365) (INIT.CURSOR 137367 . 138264) ( INSERT.NODE 138266 . 138788) (INSERTLINE 138790 . 140294) (KILL.LINES 140296 . 140834) (KILLSEGMENT 140836 . 141959) (L-CASECODE 141961 . 142122) (MOVE.BACK.TO 142124 . 142353) (MOVE.FORWARD.TO 142355 . 142776) (MOVE.TO.LINE 142778 . 143693) (MOVE.TO.NEXT.LINE 143695 . 143965) (MOVE.TO.START.OF.WORD 143967 . 144731) (MOVE.TO.WHEREVER 144733 . 144956) (NTH.COLUMN.OF 144958 . 145289) ( NTH.RELATIVE.COLUMN.OF 145291 . 146591) (OVERFLOW? 146593 . 147541) (OVERFLOWLINE? 147543 . 147869) ( PREVLINE 147871 . 149051) (PREVWORD 149053 . 151194) (PROPERTAILP 151196 . 151403) (READFROMBUF 151405 . 153994) (RENUMBER.LINES 153996 . 154389) (RESTORE.CURSOR 154391 . 154545) (RESTOREBUF 154547 . 156731) (RETYPE.BUFFER 156733 . 158996) (SAVE.CURSOR 158998 . 159170) (SCANBACK 159172 . 160530) ( SCANFORWARD 160532 . 161400) (SCRATCHCONS 161402 . 162004) (SEGMENT.LENGTH 162006 . 162542) ( SEGMENT.BIT.LENGTH 162544 . 163151) (SETLASTC 163153 . 163450) (SETTAIL? 163452 . 164268) ( SHOW.MATCHING.PAREN 164270 . 166770) (SKIP/ZAP 166772 . 169251) (START.NEW.LINE 169253 . 169585) ( START.OF.PARAGRAPH? 169587 . 169968) (TTADJUSTWORD 169970 . 171144) (TTBIN 171146 . 172352) ( TTBITWIDTH 172354 . 172503) (TTCRLF 172505 . 172712) (TTCRLF.ACCOUNT 172714 . 173354) (TTDELETECHAR 173356 . 174500) (TTDELETELINE 174502 . 176450) (TTDELETEWORD 176452 . 177120) (TTECHO.TO.FILE 177122 . 180670) (TTGIVEHELP 180672 . 181937) (TTGIVEHELP1 181939 . 182521) (TTGIVEHELP2 182523 . 183218) ( TTLASTLINE 183220 . 183588) (TTLOADBUF 183590 . 187104) (TTNEXTLINE 187106 . 187426) (TTNEXTNODE 187428 . 187667) (TTNLEFT 187669 . 188896) (TTNTH 188898 . 189357) (TTNTHLINE 189359 . 189891) ( TTPRIN1 189893 . 193706) (TTPRINSPACE 193708 . 194101) (TTPRIN1COMMENT 194103 . 194427) (TTPRIN2 194429 . 196748) (TTPROMPTCHAR 196750 . 197646) (TTRUBOUT 197648 . 198611) (TTUNREADBUF 198613 . 199022) (TTWAITFORINPUT 199024 . 203232) (TTYINSTRING 203234 . 204193) (TYPE.BUFFER 204195 . 205947) ( U-CASECODE 205949 . 206108) (U/L-CASE 206110 . 208708)) (208865 218578 (TTRATOM 208875 . 209319) ( TTREADLIST 209321 . 209688) (TTSKIPSEPR 209690 . 210064) (TTSKREAD 210066 . 214706) (TTYIN.READ 214708 . 218576)) (218625 238669 (FIND.MATCHING.WORD 218635 . 219163) (TTCOMPLETEWORD 219165 . 233593) ( WORD.MATCHES.BUFFER 233595 . 235155) (TTYIN.SHOW.?ALTERNATIVES 235157 . 238667)) (238703 257013 ( DO?CMD 238713 . 244615) (TTYIN.PRINTARGS 244617 . 255475) (TTYIN.READ?=ARGS 255477 . 256258) ( DO?CMD.ERRORHANDLER 256260 . 257011)) (257047 265120 (BEEP 257057 . 257232) (BITBLT.DELETE 257234 . 257881) (BITBLT.ERASE 257883 . 258068) (BITBLT.INSERT 258070 . 258381) (DO.CRLF 258383 . 258702) ( DO.DELETE.LINES 258704 . 259748) (DO.INSERT.LINE 259750 . 261684) (DO.LF 261686 . 261852) ( ERASE.TO.END.OF.LINE 261854 . 262179) (ERASE.TO.END.OF.PAGE 262181 . 262786) (INSERT.TEXT 262788 . 263292) (TTDELSECTION 263294 . 263592) (TTADJUSTWIDTH 263594 . 264458) (TTINSERTSECTION 264460 . 264799) (TTSETCURSOR 264801 . 265118)) (265155 270132 (TTYINBUFFERDEVICE 265165 . 266481) ( TTYINBUFFERSTREAM 266483 . 267245) (TTYINBUFFERBIN 267247 . 267783) (TTYINBUFFERPEEK 267785 . 268263) (TTYINBUFFERREADP 268265 . 268520) (TTYINBUFFEREOFP 268522 . 268774) (TTYINBUFFERBACKPTR 268776 . 269328) (TTYINWORDRDTBL 269330 . 270130)) (270293 295850 (DO.MOUSE 270303 . 273060) ( DO.SHIFTED.SELECTION 273062 . 283501) (COPY.SEGMENT 283503 . 283707) (DELETE.LONG.SEGMENT 283709 . 284068) (DELETE.LONG.SEGMENT1 284070 . 286546) (INVERT.LONG.SEGMENT 286548 . 287577) (INVERT.SEGMENT 287579 . 289094) (BRACKET.CURRENT.WORD 289096 . 290630) (TTBEFOREPOS 290632 . 291362) (TTNEXTPOS 291364 . 292072) (TTRACKMOUSE 292074 . 295848)) (295994 301250 (SETREADFN 296004 . 296482) ( TTYINENTRYFN 296484 . 296909) (TTYINREADP 296911 . 297376) (TTYINREAD 297378 . 298772) (TTYINFIX 298774 . 299973) (CHARMACRO? 299975 . 300542) (TTYINMETA 300544 . 300672) (TTYIN.LASTINPUT 300674 . 301248)) (301251 309520 (TTYINEDIT 301261 . 303378) (SIMPLETEXTEDIT 303380 . 306424) ( SET.TTYINEDIT.WINDOW 306426 . 307577) (TTYIN.PPTOFILE 307579 . 309518)) (309578 309755 ( MAKE-TTSCRATCHFILE 309588 . 309753)) (309902 310680 (TTYIN.SCRATCHFILE 309912 . 310371) (\TTYIN.RPEOF 310373 . 310678)) (310892 314525 (TTYINPROMPTFORWORD 310902 . 314523))))) STOP \ No newline at end of file diff --git a/sources/TWODINSPECTOR b/sources/TWODINSPECTOR new file mode 100644 index 00000000..79095a83 --- /dev/null +++ b/sources/TWODINSPECTOR @@ -0,0 +1,207 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "11-Aug-2020 11:22:30"  {DSK}kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.;2 111972 changes to%: (FNS ONEDINSPECT.PROPWIDTH ONEDINSPECT.ARRANGEWINDOWS RIGHTW.REPAINTFN) previous date%: "31-Dec-93 12:04:36" {DSK}kaplan>Local>medley3.5>lispcore>sources>TWODINSPECTOR.;1) (* ; " Copyright (c) 1985, 1900, 1987, 1990, 1992, 1993, 2020 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT TWODINSPECTORCOMS) (RPAQQ TWODINSPECTORCOMS ( (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (COMS (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file.") (FNS \CREATE.TWODINSPECTOR.TITLEMENU \CREATE.TWODINSPECTOR.SETMENU \CREATE.TWODINSPECTOR.INSPECTMENU)) (* ;; "Oned-inspector ") (FNS ONEDINSPECTW.CREATE GET-ONED-DISPLAYW ONEDINSPECT.ARRANGEWINDOWS ONEDINSPECT.REPAINTFN ONEDINSPECT.PRINTELEMENT ONEDINSPECT.RESHAPEFN ONEDINSPECT.MAKEREGIONS ONEDINSPECT.BUTTONEVENTFN ONEDINSPECT.COPYBUTTONFN ONEDINSPECT.SCROLLFN ONEDINSPECT.CLOSEFN ONEDINSPECT.REDISPLAY ONEDINSPECT.REPLACE ONEDINSPECT.SELECTITEM ONEDINSPECT.SELECTPROP ONEDINSPECT.ADJUSTSELECTION ONEDINSPECT.PROPWIDTH ONEDINSPECT.VALUEWIDTH ONEDINSPECT.DEFAULT.TITLECOMMANDFN ONEDINSPECT.DEFAULT.VALUECOMMANDFN ONEDINSPECT.SETELT) (* ;; "Twod-inspector") (FNS TWODINSPECTW.CREATE GET-TWOD-DISPLAYW GET-CORNERW TWODINSPECT.ARRANGEWINDOWS TWODINSPECT.REPAINTFN TWODINSPECT.PRINTELEMENT TWODINSPECT.RESHAPEFN TWODINSPECT.MAKEREGIONS TWODINSPECT.BUTTONEVENTFN TWODINSPECT.COPYBUTTONFN TWODINSPECT.DOWINDOWCOMFN TWODINSPECT.SCROLLFN TWODINSPECT.CLOSEFN TWODINSPECT.REDISPLAY TWODINSPECT.REPLACE TWODINSPECT.SELECTITEM TWODINSPECT.SELECTROWPROP TWODINSPECT.SELECTCOLUMNPROP TWODINSPECT.ADJUSTSELECTION TWODINSPECT.DEFAULT.TITLECOMMANDFN TWODINSPECT.DEFAULT.VALUECOMMANDFN TWODINSPECT.SETELT TWODINSPECT.ROWPROPWIDTH TWODINSPECT.COLUMNWIDTHS TWODINSPECT.COLUMNWIDTH TWODINSPECT.TOTALWIDTH) (* ;; "Right window fns") (FNS GET-RIGHTW RIGHTW.REPAINTFN RIGHTW.RESHAPEFN RIGHTW.BUTTONEVENTFN RIGHTW.ADJUSTSELECTION ) (* ;; "Top window fns") (FNS GET-TOPW TOPW.REPAINTFN TOPW.RESHAPEFN TOPW.ADJUSTSELECTION TOPW.BUTTONEVENTFN) (* ;; "Title window fns") (FNS GET-TITLEW TITLEW.REPAINTFN TITLEW.BUTTONEVENTFN) (* ;; "Utilites ") (FNS ONED.TRACKCURSOR TWOD.TRACKCURSOR INSPECT.INVERTSELECTION INSPECT.INVERTREGION INSPECT.FLIPSELECTION) (INITVARS INSPECTORFONT) (GLOBALVARS INSPECTORFONT) (DECLARE%: DOEVAL@COMPILE DONTCOPY (RECORDS INSPECT.SELECTION ONED.SELECTION TWOD.SELECTION)) (INITRECORDS ONED.SELECTION TWOD.SELECTION) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))) (* ;; "Substrate for two-dimensional inspectors. Used in inspecting arrays.") (* ;; "Added by yabu.fx, for SUNLOADUP without DWIM. They compute load time constants, and must come first in the file." ) (DEFINEQ (\CREATE.TWODINSPECTOR.TITLEMENU [LAMBDA NIL (create MENU ITEMS _ '(("Refetch" 'REFETCH "Refetch the datum") ("IT _ Datum" 'IT "Bind IT to the inspected datum"]) (\CREATE.TWODINSPECTOR.SETMENU [LAMBDA NIL (create MENU ITEMS _ '(("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) (\CREATE.TWODINSPECTOR.INSPECTMENU [LAMBDA NIL (create MENU ITEMS _ '(("Inspect" 'INSPECT "Inspect the value of the selected entry") ("IT _ Selection" 'IT "Bind IT to the value of the selected entry") ("Set" 'SET "Set the selected entry"]) ) (* ;; "Oned-inspector ") (DEFINEQ (ONEDINSPECTW.CREATE [LAMBDA (DATUM PROPS FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (WITH-INSPECTOR-ENV PROFILE (if (LITATOM PROPS) then (SETQ PROPS (APPLY* PROPS DATUM))) (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-ONED-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (ONEDINSPECT.ARRANGEWINDOWS DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; "Display the group") (ONEDINSPECT.RESHAPEFN DISPLAYWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns for windows in group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION ONEDINSPECT.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-ONED-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN PROPCOMMANDFN TITLECOMMANDFN PROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:57 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION ONEDINSPECT.REPAINTFN)) (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION ONEDINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION ONEDINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION ONEDINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION ONEDINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN PROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION ONEDINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS PROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH (ONEDINSPECT.VALUEWIDTH DATUM PROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'VALUESPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (ONEDINSPECT.ARRANGEWINDOWS [LAMBDA (DISPLAYWINDOW RIGHTWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 11-Aug-2020 11:21 by rmk:") (* ; "Edited 6-Apr-87 15:08 by jop") (* ;; "RMK: Save the ROWPROPWIDTH for future right-adjusting of the right (props) window") (* ;; "REGION should be the total available area") (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) (VALUEWIDTH (WINDOWPROP DISPLAYWINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP DISPLAYWINDOW 'VALUESPACE)) TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT RWWIDTH DWLEFT DWBOTTOM ROWPROPWIDTH) [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) NIL (WINDOWPROP TITLEWINDOW 'BORDER] (SETQ ROWPROPWIDTH (ONEDINSPECT.PROPWIDTH (WINDOWPROP DISPLAYWINDOW 'ROWPROPS) DISPLAYWINDOW)) [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) ROWPROPWIDTH) (WINDOWPROP RIGHTWINDOW 'BORDER] (if (NULL TOTALHEIGHT) then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW 'HEIGHT) (LENGTH ROWPROPS)) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT DWHEIGHT)) else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT TITLEHEIGHT))) (if (NULL TOTALWIDTH) then [SETQ DWWIDTH (IMIN 200 (WIDTHIFWINDOW (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE DISPLAYWINDOW) ) (WINDOWPROP DISPLAYWINDOW 'BORDER] (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) [if (POSITIONP TOPRIGHT) then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) elseif (AND TOTALLEFT TOTALBOTTOM) then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL "Position Inspector window"))) (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] (if (ILESSP DWLEFT 0) then (SETQ DWLEFT 0) (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) RWWIDTH))) [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TITLEHEIGHT] (if (LESSP DWBOTTOM 0) then (SETQ DWBOTTOM 0) (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) TITLEHEIGHT))) (* ;; "put up the window group") (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) (* ;  "Need to set the Minsize BEFORE reshaping else we catch the default minsize") (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) (WINDOWPROP RIGHTWINDOW 'ROWPROPWIDTH ROWPROPWIDTH) (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) of (WINDOWPROP DISPLAYWINDOW 'REGION] DWBOTTOM RWWIDTH DWHEIGHT)) (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) (WINDOWPROP DISPLAYWINDOW 'REGION] TOTALWIDTH TITLEHEIGHT)) (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) (RETURN DISPLAYWINDOW]) (ONEDINSPECT.REPAINTFN + [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 19-Apr-90 10:41 by mitani") + (if (NULL WINDOWREGION) + then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) + (PROG ((TOP (fetch (REGION TOP) of WINDOWREGION)) + (BOTTOM (fetch (REGION BOTTOM) of WINDOWREGION)) + (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) + (DATUM (WINDOWPROP WINDOW 'DATUM)) + (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) + (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) + STARTPROP LASTPROP STARTVERTMARKS) + (for PROP on ROWPROPS as MARK on VERTMARKS until (ILESSP (CAR MARK) + TOP) + finally (SETQ STARTPROP PROP) + (SETQ STARTVERTMARKS MARK)) + (for PROP on STARTPROP as MARK in STARTVERTMARKS + until (ILESSP MARK BOTTOM) finally (SETQ LASTPROP PROP)) + [if STARTPROP + then (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) + (bind [DESCENT _ (SUB1 (FONTPROP WINDOW 'DESCENT] for PROP + on STARTPROP as VMARK in STARTVERTMARKS + repeatuntil (EQ PROP LASTPROP) + do (ONEDINSPECT.PRINTELEMENT (APPLY* FETCHFN DATUM + (CAR PROP)) + VMARK DESCENT WINDOW] + (INSPECT.INVERTSELECTION WINDOW]) (ONEDINSPECT.PRINTELEMENT [LAMBDA (ELT BOTTOM SUB1DESCENT WINDOW) (* ; "Edited 19-Apr-90 10:42 by mitani") (MOVETO 0 (IPLUS BOTTOM SUB1DESCENT) WINDOW) (PRIN2 ELT WINDOW]) (ONEDINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:34") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (ONEDINSPECT.REPAINTFN WINDOW]) (ONEDINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:01 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (VALUESPACE (WINDOWPROP WINDOW 'VALUESPACE)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS) (if (NULL VALUEWIDTH) then (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (SETQ VALUEWIDTH (ONEDINSPECT.VALUEWIDTH (WINDOWPROP WINDOW 'DATUM) ROWPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW)) (WINDOWPROP WINDOW 'VALUEWIDTH VALUEWIDTH))) (* ; "VERTMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (IPLUS VALUEWIDTH (STRINGWIDTH VALUESPACE WINDOW)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (ONEDINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:03 by jop") (TOTOPW WINDOW) (LET [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(SELECTEDPROP (CAR (fetch (ONED.SELECTION PROP) of SELECTION))) (DATUM (WINDOWPROP WINDOW 'DATUM] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDPROP) SELECTEDPROP DATUM WINDOW]) (ONEDINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:09 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) 0 NIL 2 [FUNCTION (LAMBDA (P W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) P] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (ONED.SELECTION ELTLEFT) of SELECTION) (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION) (fetch (ONED.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (ONED.SELECTION PROP) of SELECTION]) (ONEDINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* jop%: " 1-Oct-85 22:41") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (WINDOWPROP RIGHTWINDOW 'SCROLLFN) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (ONEDINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:52") (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL]) (ONEDINSPECT.REDISPLAY [LAMBDA (WINDOW ELTPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTPROPS may be a single entries, a list, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTPROPS (NLISTP ELTPROPS)) then (SETQ ELTPROPS (LIST ELTPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VALUEWIDTH (WINDOWPROP WINDOW 'VALUEWIDTH)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTS ELTBOTTOMS) (SETQ ELTS (for PROP in ELTPROPS collect (APPLY* FETCHFN DATUM PROP))) [SETQ ELTBOTTOMS (for ELTPROP in ELTPROPS collect (for VMARK in VERTMARKS as PROP in ROWPROPS thereis (EQUAL PROP ELTPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELTWIDTH in (for ELT in ELTS collect (STRINGWIDTH ELT WINDOW T) ) never (IGREATERP ELTWIDTH VALUEWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as BOTTOM in ELTBOTTOMS do (BITBLT NIL NIL NIL WINDOW 0 BOTTOM VALUEWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (ONEDINSPECT.PRINTELEMENT ELT BOTTOM FDESCENT WINDOW)) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'VALUEWIDTH NIL) (ONEDINSPECT.MAKEREGIONS WINDOW) (ONEDINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (ONEDINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (ONEDINSPECT.REPLACE [LAMBDA (WINDOW PROP NEWVALUE) (* jop%: " 2-Oct-85 00:06") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM PROP) (ONEDINSPECT.REDISPLAY WINDOW PROP]) (ONEDINSPECT.SELECTITEM [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:36 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if PROP then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) WINDOW T))) (INSPECT.INVERTREGION 0 SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ 0 ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.SELECTPROP [LAMBDA (WINDOW PROP) (* ; "Edited 6-Apr-87 11:37 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDPROP (for PRP on ROWPROPS thereis (EQUAL (CAR PRP) PROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as PRP on ROWPROPS thereis (EQ PRP SELECTEDPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP]) (ONEDINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:34 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (SELPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ (for VMARK in VERTMARKS as PROP on ROWPROPS thereis (EQ PROP SELPROP)) ELTWIDTH _ (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELPROP)) WINDOW T)) ELTLEFT _ 0 PROP _ SELPROP]) (ONEDINSPECT.PROPWIDTH [LAMBDA (PROPS FONT) (* ; "Edited 11-Aug-2020 11:04 by rmk:") (* ; "Edited 5-Apr-87 16:18 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (* ;; "RMK: Added more SPACE: wasn't wide enough for large indexes") (for PROP in PROPS largest (STRINGWIDTH PROP FONT T) finally (RETURN (IPLUS (CHARWIDTH (CHARCODE SPACE) T) $$EXTREME]) (ONEDINSPECT.VALUEWIDTH [LAMBDA (DATUM PROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 16:20 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (for PROP in PROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM PROP) FONT T) finally (RETURN $$EXTREME]) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:47 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (ONEDINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (ONEDINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE PROP DATUM WINDOW) (* ; "Edited 20-Jul-90 20:51 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (ONEDINSPECT.SETELT PROP WINDOW)) NIL]) (ONEDINSPECT.SETELT + [LAMBDA (PROP WINDOW) (* ; "Edited 5-Apr-87 16:29 by jop") + (PROG ((PRTWINDOW (GETPROMPTWINDOW WINDOW (if (ILESSP (fetch (REGION WIDTH) + of (WINDOWREGION WINDOW)) + (IPLUS (ITIMES 5 (STRINGWIDTH + 'A WINDOW)) + (STRINGWIDTH "? " WINDOW))) + then 3 + else 1))) + (NEWVALUE (APPLY* (WINDOWPROP WINDOW 'FETCHFN) + (WINDOWPROP WINDOW 'DATUM) + PROP))) + (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) + (RESETLST + (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW)) + (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) + (CLEARBUF T T) + (PRINTOUT T "Eval> ") + (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) + (* ; + "clear tty buffer because it sometimes has stuff left.") + (CLEARBUF T T))) + (REMOVEPROMPTWINDOW WINDOW) + (ONEDINSPECT.REPLACE WINDOW PROP NEWVALUE]) ) (* ;; "Twod-inspector") (DEFINEQ (TWODINSPECTW.CREATE [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) (* ; "Edited 6-Apr-87 17:03 by jop") (* ;;  "If where is a window, it may be the result of a previous call, so try to reuse all windows") (PROG ((PROFILE (MAKE-INSPECTOR-PROFILE)) [FONT (OR INSPECTORFONT (DEFAULTFONT 'DISPLAY] [TITLEFONT (OR (DSPFONT NIL WindowTitleDisplayStream) '(HELVETICA 8 MRR] DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT WINDOWGROUP) (if (LITATOM ROWPROPS) then (SETQ ROWPROPS (APPLY* ROWPROPS DATUM))) (if (LITATOM COLUMNPROPS) then (SETQ COLUMNPROPS (APPLY* COLUMNPROPS DATUM))) (WITH-INSPECTOR-ENV PROFILE (* ;  "DISPLAYWINDOW is the central and main window of the group") (SETQ DISPLAYWINDOW (GET-TWOD-DISPLAYW WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT)) (* ;  "TOPWINDOW simply records the COLUMNPROPS") (SETQ TOPWINDOW (GET-TOPW DISPLAYWINDOW FONT)) (* ;  "RIGHTWINDOW records the ROWPROPS") (SETQ RIGHTWINDOW (GET-RIGHTW DISPLAYWINDOW FONT)) (* ;  "CORNERWINDOW is just a place holder") (SETQ CORNERWINDOW (GET-CORNERW DISPLAYWINDOW FONT)) (* ;  "TITLEWINDOW will only hold a title") (SETQ TITLEWINDOW (GET-TITLEW DISPLAYWINDOW TITLE TITLEFONT DATUM)) (* ; "Put up the window group") [if (NOT (POSITIONP TOPRIGHT)) then (LET ((REGION (if (WINDOWP WHERE) then (WINDOWPROP WHERE 'REGION) elseif (REGIONP WHERE) then WHERE))) (if REGION then (SETQ GLEFT (fetch (REGION LEFT) of REGION)) (SETQ GBOTTOM (fetch (REGION BOTTOM) of REGION)) (SETQ GWIDTH (fetch (REGION WIDTH) of REGION)) (SETQ GHEIGHT (fetch (REGION HEIGHT) of REGION)) elseif (POSITIONP WHERE) then (SETQ GLEFT (fetch (POSITION XCOORD) of WHERE)) (SETQ GBOTTOM (fetch (POSITION YCOORD) of WHERE] (SETQ WINDOWGROUP (TWODINSPECT.ARRANGEWINDOWS DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW GLEFT GBOTTOM GWIDTH GHEIGHT TOPRIGHT)) (* ;; " Display the group") (TWODINSPECT.RESHAPEFN DISPLAYWINDOW) (TOPW.RESHAPEFN TOPWINDOW) (RIGHTW.RESHAPEFN RIGHTWINDOW) (TITLEW.REPAINTFN TITLEWINDOW) (* ;; "then establish reshapefns on the windows of the window group") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION TWODINSPECT.RESHAPEFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION TOPW.RESHAPEFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION RIGHTW.RESHAPEFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION TITLEW.REPAINTFN))) (* ;; "finally return the group") (RETURN WINDOWGROUP]) (GET-TWOD-DISPLAYW [LAMBDA (WHERE DATUM FETCHFN STOREFN VALUECOMMANDFN ROWPROPCOMMANDFN COLUMNPROPCOMMANDFN TITLECOMMANDFN ROWPROPS COLUMNPROPS PROFILE FONT) (* ; "Edited 6-Apr-87 14:51 by jop") (LET [(DISPLAYWINDOW (if (WINDOWP WHERE) then WHERE else (CREATEW (CREATEREGION 0 0 100 100) NIL 2 T] (WINDOWPROP DISPLAYWINDOW 'REPAINTFN (FUNCTION TWODINSPECT.REPAINTFN)) (* ;  "Smash the reshapefn because we don't want to rely on shapew to repaint the windows") (WINDOWPROP DISPLAYWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP DISPLAYWINDOW 'SCROLLFN (FUNCTION TWODINSPECT.SCROLLFN)) (WINDOWPROP DISPLAYWINDOW 'BUTTONEVENTFN (FUNCTION TWODINSPECT.BUTTONEVENTFN)) (WINDOWPROP DISPLAYWINDOW 'COPYBUTTONEVENTFN (FUNCTION TWODINSPECT.COPYBUTTONFN)) (WINDOWPROP DISPLAYWINDOW 'CLOSEFN (FUNCTION TWODINSPECT.CLOSEFN)) (DSPRIGHTMARGIN MAX.SMALLP DISPLAYWINDOW) (DSPFONT FONT DISPLAYWINDOW) (WINDOWPROP DISPLAYWINDOW 'DATUM DATUM) (WINDOWPROP DISPLAYWINDOW 'FETCHFN FETCHFN) (WINDOWPROP DISPLAYWINDOW 'STOREFN STOREFN) (WINDOWPROP DISPLAYWINDOW 'VALUECOMMANDFN (OR VALUECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.VALUECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPCOMMANDFN ROWPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPCOMMANDFN COLUMNPROPCOMMANDFN) (WINDOWPROP DISPLAYWINDOW 'TITLECOMMANDFN (OR TITLECOMMANDFN (FUNCTION TWODINSPECT.DEFAULT.TITLECOMMANDFN ))) (WINDOWPROP DISPLAYWINDOW 'ROWPROPS ROWPROPS) (WINDOWPROP DISPLAYWINDOW 'ROWPROPWIDTH (TWODINSPECT.ROWPROPWIDTH ROWPROPS FONT)) (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS COLUMNPROPS) (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS (TWODINSPECT.COLUMNWIDTHS DATUM ROWPROPS COLUMNPROPS FETCHFN FONT)) (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE " ") (WINDOWPROP DISPLAYWINDOW 'PROFILE PROFILE) DISPLAYWINDOW]) (GET-CORNERW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:52 by jop") (LET [(CORNERWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (DSPFONT FONT CORNERWINDOW) (WINDOWPROP CORNERWINDOW 'REPAINTFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP CORNERWINDOW 'BUTTONEVENTFN NIL) (WINDOWPROP DISPLAYWINDOW 'CORNERWINDOW CORNERWINDOW) CORNERWINDOW]) (TWODINSPECT.ARRANGEWINDOWS + [LAMBDA (DISPLAYWINDOW TOPWINDOW RIGHTWINDOW CORNERWINDOW TITLEWINDOW TOTALLEFT TOTALBOTTOM + TOTALWIDTH TOTALHEIGHT TOPRIGHT) (* ; "Edited 6-Apr-87 15:10 by jop") + + (* ;; "REGION should be the total available area") + + (PROG ((ROWPROPS (WINDOWPROP DISPLAYWINDOW 'ROWPROPS)) + (COLUMNPROPS (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPS)) + (ROWPROPSPACE (WINDOWPROP DISPLAYWINDOW 'ROWPROPSPACE)) + (COLUMNWIDTHS (WINDOWPROP DISPLAYWINDOW 'COLUMNWIDTHS)) + (COLUMNPROPSPACE (WINDOWPROP DISPLAYWINDOW 'COLUMNPROPSPACE)) + TOTALRIGHT TOTALTOP DWHEIGHT DWWIDTH TITLEHEIGHT TWHEIGHT RWWIDTH DWLEFT DWBOTTOM) + [SETQ TITLEHEIGHT (HEIGHTIFWINDOW (FONTPROP TITLEWINDOW 'HEIGHT) + NIL + (WINDOWPROP TITLEWINDOW 'BORDER] + [SETQ TWHEIGHT (HEIGHTIFWINDOW (FONTPROP TOPWINDOW 'HEIGHT) + NIL + (WINDOWPROP TOPWINDOW 'BORDER] + [SETQ RWWIDTH (WIDTHIFWINDOW (IPLUS (STRINGWIDTH ROWPROPSPACE RIGHTWINDOW) + (TWODINSPECT.ROWPROPWIDTH ROWPROPS RIGHTWINDOW)) + (WINDOWPROP RIGHTWINDOW 'BORDER] + [if (NULL TOTALHEIGHT) + then [SETQ DWHEIGHT (IMIN 500 (HEIGHTIFWINDOW (ITIMES (FONTPROP DISPLAYWINDOW + 'HEIGHT) + (LENGTH ROWPROPS)) + NIL + (WINDOWPROP DISPLAYWINDOW 'BORDER] + (SETQ TOTALHEIGHT (IPLUS TITLEHEIGHT TWHEIGHT DWHEIGHT)) + else (SETQ DWHEIGHT (IDIFFERENCE TOTALHEIGHT (IPLUS TWHEIGHT TITLEHEIGHT] + (if (NULL TOTALWIDTH) + then [SETQ DWWIDTH (IMIN 400 (WIDTHIFWINDOW (TWODINSPECT.TOTALWIDTH + COLUMNWIDTHS COLUMNPROPSPACE + (DSPFONT DISPLAYWINDOW)) + (WINDOWPROP DISPLAYWINDOW 'BORDER] + (SETQ TOTALWIDTH (IPLUS RWWIDTH DWWIDTH)) + else (SETQ DWWIDTH (IDIFFERENCE TOTALWIDTH RWWIDTH))) + [if (POSITIONP TOPRIGHT) + then (SETQ TOTALRIGHT (fetch (POSITION XCOORD) of TOPRIGHT)) + (SETQ TOTALTOP (fetch (POSITION YCOORD) of TOPRIGHT)) + elseif (AND TOTALLEFT TOTALBOTTOM) + then (SETQ TOTALRIGHT (IPLUS TOTALLEFT (SUB1 TOTALWIDTH))) + (SETQ TOTALTOP (IPLUS TOTALBOTTOM (SUB1 TOTALHEIGHT))) + else (LET ((REGION (GETBOXREGION TOTALWIDTH TOTALHEIGHT NIL NIL NIL + "Position Inspector window"))) + (SETQ TOTALTOP (fetch (REGION TOP) of REGION)) + (SETQ TOTALRIGHT (fetch (REGION RIGHT) of REGION] + [SETQ DWLEFT (DIFFERENCE TOTALRIGHT (SUB1 (PLUS DWWIDTH RWWIDTH] + (if (ILESSP DWLEFT 0) + then (SETQ DWLEFT 0) + (SETQ DWWIDTH (DIFFERENCE (ADD1 TOTALRIGHT) + RWWIDTH))) + [SETQ DWBOTTOM (DIFFERENCE TOTALTOP (SUB1 (PLUS DWHEIGHT TWHEIGHT TITLEHEIGHT] + [if (LESSP DWBOTTOM 0) + then (SETQ DWBOTTOM 0) + (SETQ DWHEIGHT (DIFFERENCE (ADD1 TOTALTOP) + (PLUS TWHEIGHT TITLEHEIGHT] + + (* ;; "put up the window group") + + (WINDOWPROP DISPLAYWINDOW 'MINSIZE (CONS 0 0)) + (SHAPEW DISPLAYWINDOW (CREATEREGION DWLEFT DWBOTTOM DWWIDTH DWHEIGHT)) + (* ; + "Need to set the Minsize BEFORE reshaping else we catch the default minsize") + (WINDOWPROP TOPWINDOW 'MINSIZE (CONS 0 TWHEIGHT)) + (WINDOWPROP TOPWINDOW 'MAXSIZE (CONS MAX.SMALLP TWHEIGHT)) + (SHAPEW TOPWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) + of (WINDOWPROP DISPLAYWINDOW + 'REGION] + DWWIDTH TWHEIGHT)) + (ATTACHWINDOW TOPWINDOW DISPLAYWINDOW 'TOP) + (WINDOWPROP RIGHTWINDOW 'MINSIZE (CONS RWWIDTH 0)) + (WINDOWPROP RIGHTWINDOW 'MAXSIZE (CONS RWWIDTH MAX.SMALLP)) + (SHAPEW RIGHTWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) + of (WINDOWPROP DISPLAYWINDOW 'REGION] + DWBOTTOM RWWIDTH DWHEIGHT)) + (WINDOWPROP CORNERWINDOW 'MINSIZE (CONS RWWIDTH TWHEIGHT)) + (WINDOWPROP CORNERWINDOW 'MAXSIZE (CONS RWWIDTH TWHEIGHT)) + (SHAPEW CORNERWINDOW (CREATEREGION [ADD1 (fetch (REGION RIGHT) + of (WINDOWPROP DISPLAYWINDOW 'REGION] + [ADD1 (fetch (REGION TOP) of (WINDOWPROP DISPLAYWINDOW + 'REGION] + RWWIDTH TWHEIGHT)) + (ATTACHWINDOW CORNERWINDOW RIGHTWINDOW 'TOP) + (ATTACHWINDOW RIGHTWINDOW DISPLAYWINDOW 'RIGHT) + (WINDOWPROP TITLEWINDOW 'MINSIZE (CONS 0 TITLEHEIGHT)) + (WINDOWPROP TITLEWINDOW 'MAXSIZE (CONS MAX.SMALLP TITLEHEIGHT)) + (SHAPEW TITLEWINDOW (CREATEREGION DWLEFT [ADD1 (fetch (REGION TOP) + (WINDOWPROP TOPWINDOW 'REGION] + TOTALWIDTH TITLEHEIGHT)) + (ATTACHWINDOW TITLEWINDOW DISPLAYWINDOW 'TOP) + (RETURN DISPLAYWINDOW]) (TWODINSPECT.REPAINTFN + [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 6-Apr-87 11:12 by jop") + (if (NULL WINDOWREGION) + then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) + (PROG ((TOP (fetch (REGION TOP) of WINDOWREGION)) + (BOTTOM (fetch (REGION BOTTOM) of WINDOWREGION)) + (LEFT (fetch (REGION LEFT) of WINDOWREGION)) + (RIGHT (fetch (REGION RIGHT) of WINDOWREGION)) + (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) + (DATUM (WINDOWPROP WINDOW 'DATUM)) + (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) + (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) + (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) + (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) + STARTROWPROPS LASTROWPROP STARTCOLUMNPROPS LASTCOLUMNPROP STARTVERTMARKS STARTHORZMARKS) + (for ROWPROP on ROWPROPS as MARK on VERTMARKS + until (ILESSP (CAR MARK) + TOP) finally (SETQ STARTROWPROPS ROWPROP) + (SETQ STARTVERTMARKS MARK)) + (for ROWPROP on STARTROWPROPS as MARK in STARTVERTMARKS + until (ILESSP MARK BOTTOM) finally (SETQ LASTROWPROP ROWPROP)) + (for COLUMNPROP on COLUMNPROPS as MARK on HORZMARKS + until (IGREATERP (CAR MARK) + LEFT) finally (SETQ STARTCOLUMNPROPS COLUMNPROP) + (SETQ STARTHORZMARKS MARK)) + (for COLUMNPROP on STARTCOLUMNPROPS as MARK in STARTHORZMARKS + until (IGREATERP MARK RIGHT) finally (SETQ LASTCOLUMNPROP COLUMNPROP)) + [WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) + (if (AND STARTROWPROPS STARTCOLUMNPROPS) + then (for ROWPROP on STARTROWPROPS as VMARK in + STARTVERTMARKS + repeatuntil (EQ ROWPROP LASTROWPROP) + do (bind (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) + for COLUMNPROP on STARTCOLUMNPROPS as HMARK + in STARTHORZMARKS repeatuntil (EQ COLUMNPROP + LASTCOLUMNPROP) + do (TWODINSPECT.PRINTELEMENT (APPLY* FETCHFN DATUM + (CAR ROWPROP) + (CAR + COLUMNPROP + )) + HMARK VMARK FDESCENT WINDOW] + (INSPECT.INVERTSELECTION WINDOW]) (TWODINSPECT.PRINTELEMENT [LAMBDA (ELT RIGHT BOTTOM FDESCENT WINDOW) (* ; "Edited 5-Apr-87 15:17 by jop") (MOVETO (ADD1 (DIFFERENCE RIGHT (STRINGWIDTH ELT WINDOW T))) (IPLUS BOTTOM FDESCENT) WINDOW) (PRIN2 ELT WINDOW]) (TWODINSPECT.RESHAPEFN [LAMBDA (WINDOW) (* jop%: " 6-Oct-85 18:33") (CLEARW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (TWODINSPECT.REPAINTFN WINDOW]) (TWODINSPECT.MAKEREGIONS [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 16:31 by jop") (* ;; "Sets up windowprops and activeregions") (PROG ((ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SPACE (STRINGWIDTH (WINDOWPROP WINDOW 'COLUMNPROPSPACE) WINDOW)) (WINDOWHEIGHT (WINDOWPROP WINDOW 'HEIGHT)) (LF (DSPLINEFEED NIL WINDOW)) VERTMARKS HORZMARKS) (if (NULL COLUMNWIDTHS) then (SETQ COLUMNWIDTHS (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TWODINSPECT.COLUMNWIDTHS (WINDOWPROP WINDOW 'DATUM) ROWPROPS COLUMNPROPS (WINDOWPROP WINDOW 'FETCHFN) WINDOW))) (WINDOWPROP WINDOW 'COLUMNWIDTHS COLUMNWIDTHS)) (* ;  "VERTMARKS and HORZMARKS mark endpoints") (SETQ VERTMARKS (for I from 1 to (LENGTH ROWPROPS) as MARK from (IPLUS WINDOWHEIGHT LF) by LF collect MARK)) [SETQ HORZMARKS (bind (MARK _ -1) for I from 1 to (LENGTH COLUMNPROPS) as COLUMNWIDTH in COLUMNWIDTHS collect (SETQ MARK (IPLUS MARK SPACE COLUMNWIDTH] (WINDOWPROP WINDOW 'VERTMARKS VERTMARKS) (WINDOWPROP WINDOW 'HORZMARKS HORZMARKS) [WINDOWPROP WINDOW 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (CAR (LAST HORZMARKS)) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS] [WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'EXTENT (CREATEREGION 0 0 (CAR (LAST HORZMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'HEIGHT] (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'EXTENT (CREATEREGION 0 (CAR (LAST VERTMARKS)) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'WIDTH) (DIFFERENCE WINDOWHEIGHT (CAR (LAST VERTMARKS]) (TWODINSPECT.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:28 by jop") (TOTOPW WINDOW) (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (LET [(DATUM (WINDOWPROP WINDOW 'DATUM)) (SELECTEDROWPROP (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION))) (SELECTEDCOLUMNPROP (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION] (CL:FUNCALL (WINDOWPROP WINDOW 'VALUECOMMANDFN) (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) DATUM SELECTEDROWPROP SELECTEDCOLUMNPROP) SELECTEDROWPROP SELECTEDCOLUMNPROP DATUM WINDOW]) (TWODINSPECT.COPYBUTTONFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:32 by jop") (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (TOTOPW WINDOW) (bind SELECTION while (.COPYKEYDOWNP.) do (BLOCK) (SETQ SELECTION (TWOD.TRACKCURSOR WINDOW SELECTION (WINDOWPROP WINDOW 'ROWPROPS) (WINDOWPROP WINDOW 'VERTMARKS) (WINDOWPROP WINDOW 'COLUMNPROPS) (WINDOWPROP WINDOW 'HORZMARKS) 2 [FUNCTION (LAMBDA (RP CP W) (CL:FUNCALL (WINDOWPROP W 'FETCHFN) (WINDOWPROP W 'DATUM) RP CP] (FUNCTION INSPECT.FLIPSELECTION))) finally (if SELECTION then (INSPECT.FLIPSELECTION (fetch (TWOD.SELECTION ELTLEFT) of SELECTION) (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION) (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION) 2 WINDOW) (BKSYSBUF.GENERAL (CL:FUNCALL (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) (CAR (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (CAR (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION]) (TWODINSPECT.DOWINDOWCOMFN [LAMBDA (TWODWINDOW) (* ; "Edited 6-Apr-87 12:05 by jop") (* ;; "Pass on the usual comms, except for SHAPEW") (PROG (COM) (SETQ COM (MENU WindowMenu)) (SELECTQ COM (NIL NIL) (SHAPEW [SHAPEW TWODWINDOW (GETREGION NIL NIL NIL (FUNCTION ICMLARRAY.GETREGIONFN) (CONS TWODWINDOW 'CLOSED]) ((MOVEW CLOSEW SHRINKW BURYW) (APPLY* COM (MAINWINDOW TWODWINDOW))) (APPLY* COM TWODWINDOW]) (TWODINSPECT.SCROLLFN [LAMBDA (WINDOW DX DY FLG) (* jop%: "18-Jul-85 13:50") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW)) (RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (OR (NOT (EQP 0 DX)) (FLOATP DX)) then (APPLY* (WINDOWPROP TOPWINDOW 'SCROLLFN) TOPWINDOW DX 0 FLG)) (if (OR (NOT (EQP 0 DY)) (FLOATP DY)) then (APPLY* (WINDOWPROP RIGHTWINDOW 'SCROLLFN) RIGHTWINDOW 0 DY FLG)) (SCROLLBYREPAINTFN WINDOW DX DY FLG]) (TWODINSPECT.CLOSEFN [LAMBDA (WINDOW) (* jop%: " 4-Oct-85 17:51") (DETACHALLWINDOWS (WINDOWPROP WINDOW 'RIGHTWINDOW)) (DETACHALLWINDOWS WINDOW) (WINDOWPROP WINDOW 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'RIGHTWINDOW) 'SELECTION NIL) (WINDOWPROP (WINDOWPROP WINDOW 'TOPWINDOW) 'SELECTION NIL]) (TWODINSPECT.REDISPLAY [LAMBDA (WINDOW ELTROWPROPS ELTCOLUMNPROPS) (* ; "Edited 8-Apr-87 17:00 by jop") (* ;; "ELTROWPROPS and ELTCOLUMNPROPS may be single entries, lists, or NIL. If NIL than the whole inspector is refetched and redisplayed") (if (AND ELTROWPROPS (NLISTP ELTROWPROPS)) then (SETQ ELTROWPROPS (LIST ELTROWPROPS))) (if (AND ELTCOLUMNPROPS (NLISTP ELTCOLUMNPROPS)) then (SETQ ELTCOLUMNPROPS (LIST ELTCOLUMNPROPS))) (PROG ((FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (DATUM (WINDOWPROP WINDOW 'DATUM)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (COLUMNWIDTHS (WINDOWPROP WINDOW 'COLUMNWIDTHS)) (SELECTION (WINDOWPROP WINDOW 'SELECTION)) ELTCOLUMNWIDTHS ELTS ELTRIGHTS ELTBOTTOMS) [SETQ ELTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (APPLY* FETCHFN DATUM RPROP CPROP] [SETQ ELTCOLUMNWIDTHS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for COLWIDTH in COLUMNWIDTHS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTRIGHTS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for HMARK in HORZMARKS as COLPROP in COLUMNPROPS thereis (EQUAL COLPROP CPROP] [SETQ ELTBOTTOMS (for RPROP in ELTROWPROPS join (for CPROP in ELTCOLUMNPROPS collect (for VMARK in VERTMARKS as ROWPROP in ROWPROPS thereis (EQUAL ROWPROP RPROP] (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (if (AND ELTS (for ELT in ELTS as COLUMNWIDTH in ELTCOLUMNWIDTHS never (IGREATERP (STRINGWIDTH ELT WINDOW T) COLUMNWIDTH))) then (INSPECT.INVERTSELECTION WINDOW) (bind (FHEIGHT _ (FONTPROP WINDOW 'HEIGHT)) (FDESCENT _ (FONTPROP WINDOW 'DESCENT)) for ELT in ELTS as RIGHT in ELTRIGHTS as BOTTOM in ELTBOTTOMS as COLUMNWIDTH in ELTCOLUMNWIDTHS do (BITBLT NIL NIL NIL WINDOW (IDIFFERENCE (ADD1 RIGHT) COLUMNWIDTH) BOTTOM COLUMNWIDTH FHEIGHT 'TEXTURE 'REPLACE WHITESHADE) (TWODINSPECT.PRINTELEMENT ELT RIGHT BOTTOM FDESCENT WINDOW)) (TWODINSPECT.ADJUSTSELECTION WINDOW) (INSPECT.INVERTSELECTION WINDOW) else (* ; "Recompute the whole picture") (WINDOWPROP WINDOW 'COLUMNWIDTHS NIL) (TWODINSPECT.MAKEREGIONS WINDOW) (TWODINSPECT.ADJUSTSELECTION WINDOW) (DSPRESET WINDOW) (TWODINSPECT.REPAINTFN WINDOW) (DSPRESET (WINDOWPROP WINDOW 'TOPWINDOW)) (TOPW.REPAINTFN (WINDOWPROP WINDOW 'TOPWINDOW)) (DSPRESET (WINDOWPROP WINDOW 'RIGHTWINDOW)) (RIGHTW.REPAINTFN (WINDOWPROP WINDOW 'RIGHTWINDOW]) (TWODINSPECT.REPLACE [LAMBDA (WINDOW ROWPROP COLUMNPROP NEWVALUE) (* jop%: "30-Sep-85 20:44") (PROG [(DATUM (WINDOWPROP WINDOW 'DATUM)) (STOREFN (WINDOWPROP WINDOW 'STOREFN] (APPLY* STOREFN NEWVALUE DATUM ROWPROP COLUMNPROP) (TWODINSPECT.REDISPLAY WINDOW ROWPROP COLUMNPROP]) (TWODINSPECT.SELECTITEM [LAMBDA (WINDOW ROWPROP COLUMNPROP) (* ; "Edited 6-Apr-87 12:05 by jop") (if (WINDOWPROP WINDOW 'SELECTION) then (INSPECT.INVERTSELECTION WINDOW)) (if (AND ROWPROP COLUMNPROP) then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP))) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) WINDOW) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.SELECTROWPROP [LAMBDA (WINDOW ROWPROP) (* ; "Edited 6-Apr-87 12:07 by jop") (PROG [(RIGHTWINDOW (WINDOWPROP WINDOW 'RIGHTWINDOW] (if (WINDOWPROP RIGHTWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION RIGHTWINDOW)) (PROG ((ROWPROPSPACE (WINDOWPROP WINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) SELECTEDROWPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDROWPROP (for RPROP on ROWPROPS thereis (EQUAL (CAR RPROP) ROWPROP))) (SETQ SELECTEDELTBOTTOM (for VMARK in VERTMARKS as RPROP on ROWPROPS thereis (EQ RPROP SELECTEDROWPROP))) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDROWPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) RIGHTWINDOW) (WINDOWPROP RIGHTWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDROWPROP]) (TWODINSPECT.SELECTCOLUMNPROP [LAMBDA (WINDOW COLUMNPROP) (* ; "Edited 6-Apr-87 12:08 by jop") (PROG [(TOPWINDOW (WINDOWPROP WINDOW 'TOPWINDOW] (if (WINDOWPROP TOPWINDOW 'SELECTION) then (INSPECT.INVERTSELECTION TOPWINDOW)) (PROG ((COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (SETQ SELECTEDCOLUMNPROP (for CPROP on COLUMNPROPS thereis (EQUAL (CAR CPROP) COLUMNPROP))) (SETQ SELECTEDELTBOTTOM 0) (SETQ SELECTEDELTWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (CAR SELECTEDCOLUMNPROP) WINDOW T))) (SETQ SELECTEDELTLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as CPROP on COLUMNPROPS thereis (EQ CPROP SELECTEDCOLUMNPROP) )) SELECTEDELTWIDTH)) (INSPECT.INVERTREGION SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH (FONTPROP WINDOW 'HEIGHT) TOPWINDOW) (WINDOWPROP TOPWINDOW 'SELECTION (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDCOLUMNPROP]) (TWODINSPECT.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 12:06 by jop") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (PROG ((DATUM (WINDOWPROP WINDOW 'DATUM)) (FETCHFN (WINDOWPROP WINDOW 'FETCHFN)) (ROWPROPS (WINDOWPROP WINDOW 'ROWPROPS)) (COLUMNPROPS (WINDOWPROP WINDOW 'COLUMNPROPS)) (VERTMARKS (WINDOWPROP WINDOW 'VERTMARKS)) (HORZMARKS (WINDOWPROP WINDOW 'HORZMARKS)) (SELROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SELCOLPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (STRINGWIDTH (APPLY* FETCHFN DATUM (CAR SELROWPROP ) (CAR SELCOLPROP)) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create TWOD.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT ROWPROP _ SELROWPROP COLUMNPROP _ SELCOLPROP]) (TWODINSPECT.DEFAULT.TITLECOMMANDFN [LAMBDA (WINDOW) (* ; "Edited 20-Jul-90 20:54 by yabu") (if (MOUSESTATE MIDDLE) then (PROG [(TITLEMENU (CONSTANT (\CREATE.TWODINSPECTOR.TITLEMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Refetch%" 'REFETCH %"Refetch the datum%") (%"IT _ Datum%" 'IT %"Bind IT to the inspected datum%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (DATUM (WINDOWPROP WINDOW 'DATUM] (SELECTQ (MENU TITLEMENU) (REFETCH (TWODINSPECT.REDISPLAY WINDOW)) (IT (SETQ IT DATUM) (PROMPTPRINT "IT bound to " DATUM)) NIL]) (TWODINSPECT.DEFAULT.VALUECOMMANDFN [LAMBDA (VALUE ROWPROP COLUMNPROP DATUM WINDOW) (* ; "Edited 20-Jul-90 21:03 by yabu") (PROG ((SETMENU (CONSTANT (\CREATE.TWODINSPECTOR.SETMENU))) (* ; "Original was (create MENU ITEMS _ '((%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  "Changed by yabu.fx, for SUNLOADUP without DWIM.") (INSPECTMENU (CONSTANT (\CREATE.TWODINSPECTOR.INSPECTMENU))) (* ; "Original was (create MENU ITEMS _ '((%"Inspect%" 'INSPECT %"Inspect the value of the selected entry%") (%"IT _ Selection%" 'IT %"Bind IT to the value of the selected entry%") (%"Set%" 'SET %"Set the selected entry%"))).") (* ;  " Changed by yabu.fx, for SUNLOADUP without DWIM.") ) (SELECTQ (if (OR (NULL VALUE) (NUMBERP VALUE)) then (MENU SETMENU) else (MENU INSPECTMENU)) (INSPECT (INSPECT VALUE)) (IT (SETQ IT VALUE) (PROMPTPRINT "IT bound to " IT)) (SET (TWODINSPECT.SETELT ROWPROP COLUMNPROP WINDOW)) NIL]) (TWODINSPECT.SETELT [LAMBDA (ROWPROP COLUMNPROP WINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((PRTWINDOW (GETPROMPTWINDOW WINDOW)) (NEWVALUE (APPLY* (WINDOWPROP WINDOW 'FETCHFN) (WINDOWPROP WINDOW 'DATUM) ROWPROP COLUMNPROP))) (WITH-INSPECTOR-ENV (WINDOWPROP WINDOW 'PROFILE) (RESETLST (RESETSAVE (TTYDISPLAYSTREAM PRTWINDOW)) (RESETSAVE (TTY.PROCESS (THIS.PROCESS))) (CLEARBUF T T) (printout T "Eval> ") (SETQ NEWVALUE (CL:FUNCALL XCL:*EVAL-FUNCTION* (LISPXREAD T T))) (* ;  "clear tty buffer because it sometimes has stuff left.") (CLEARBUF T T))) (REMOVEPROMPTWINDOW WINDOW) (TWODINSPECT.REPLACE WINDOW ROWPROP COLUMNPROP NEWVALUE]) (TWODINSPECT.ROWPROPWIDTH [LAMBDA (ROWPROPS FONT) (* ; "Edited 5-Apr-87 16:33 by jop") (for ROWPROP in ROWPROPS largest (STRINGWIDTH ROWPROP FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.COLUMNWIDTHS [LAMBDA (DATUM ROWPROPS COLUMNPROPS FETCHFN FONT) (* ; "Edited 5-Apr-87 15:38 by jop") (* ;; "Computes the MIN fieldwidth for the jth column of SLICE") (for COLUMNPROP in COLUMNPROPS collect (TWODINSPECT.COLUMNWIDTH DATUM ROWPROPS COLUMNPROP FETCHFN FONT]) (TWODINSPECT.COLUMNWIDTH [LAMBDA (DATUM ROWPROPS COLUMNPROP FETCHFN FONT) (* ; "Edited 5-Apr-87 16:29 by jop") (* ;; "Computes the MIN fieldwidth for the COLUMNPROP column of SLICE") (IMAX (STRINGWIDTH COLUMNPROP FONT T) (for ROWPROP in ROWPROPS largest (STRINGWIDTH (APPLY* FETCHFN DATUM ROWPROP COLUMNPROP) FONT T) finally (RETURN $$EXTREME]) (TWODINSPECT.TOTALWIDTH [LAMBDA (COLUMNWIDTHS SPACE FONT) (* jop%: "25-Sep-85 13:21") (IPLUS (ITIMES (LENGTH COLUMNWIDTHS) (STRINGWIDTH SPACE FONT)) (for COLUMN in COLUMNWIDTHS sum COLUMN]) ) (* ;; "Right window fns") (DEFINEQ (GET-RIGHTW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 12:14 by jop") (LET [(RIGHTWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP RIGHTWINDOW 'REPAINTFN (FUNCTION RIGHTW.REPAINTFN)) (WINDOWPROP RIGHTWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP RIGHTWINDOW 'BUTTONEVENTFN (FUNCTION RIGHTW.BUTTONEVENTFN)) (WINDOWPROP RIGHTWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (WINDOWPROP RIGHTWINDOW 'NOSCROLLBARS T) (DSPFONT FONT RIGHTWINDOW) (WINDOWPROP DISPLAYWINDOW 'RIGHTWINDOW RIGHTWINDOW) RIGHTWINDOW]) (RIGHTW.REPAINTFN [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 11-Aug-2020 11:20 by rmk:") (* ; "Edited 22-May-92 17:37 by jds") (* ;; "RMK: Right justify the PROP in its window (assuming its a numeric index)") (* ;;  "REPAINT the right-hand window of a two-d inspector. This window contains the element indices.") [COND ((NULL WINDOWREGION) (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW] (LET [(DISPLAYW (MAINWINDOW WINDOW)) (TOP (fetch (REGION TOP) of WINDOWREGION)) (BOTTOM (fetch (REGION BOTTOM) of WINDOWREGION)) (ROWPROPWIDTH (WINDOWPROP WINDOW 'ROWPROPWIDTH] (LET ((VERTMARKS (WINDOWPROP DISPLAYW 'VERTMARKS)) (ROWPROPS (WINDOWPROP DISPLAYW 'ROWPROPS)) (SPACE (STRINGWIDTH (WINDOWPROP DISPLAYW 'ROWPROPSPACE) WINDOW)) STARTROWPROPS LASTROWPROP STARTVERTMARKS) (for ROWPROP on ROWPROPS as MARK on VERTMARKS until (ILESSP (CAR MARK) TOP) finally (SETQ STARTROWPROPS ROWPROP) (SETQ STARTVERTMARKS MARK)) (for ROWPROP on STARTROWPROPS as MARK in STARTVERTMARKS until (ILESSP MARK BOTTOM) finally (SETQ LASTROWPROP ROWPROP)) [COND (STARTROWPROPS (WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYW 'PROFILE) (bind [FDESCENT _ (SUB1 (FONTPROP WINDOW 'DESCENT] for ROWPROP on STARTROWPROPS as VERTMARK in STARTVERTMARKS repeatuntil (EQ ROWPROP LASTROWPROP) do (MOVETO (- ROWPROPWIDTH (STRINGWIDTH (CAR ROWPROP) WINDOW)) (IPLUS VERTMARK FDESCENT) WINDOW) (PRIN2 (CAR ROWPROP) WINDOW] (INSPECT.INVERTSELECTION WINDOW]) (RIGHTW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:37 by jop") (CLEARW WINDOW) (RIGHTW.ADJUSTSELECTION WINDOW) (RIGHTW.REPAINTFN WINDOW]) (RIGHTW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:48 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (ROWPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'ROWPROPCOMMANDFN] (if ROWPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'ROWPROPS) (WINDOWPROP MAINWINDOW 'VERTMARKS) (STRINGWIDTH (WINDOWPROP MAINWINDOW 'ROWPROPSPACE) WINDOW) NIL (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION))) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL ROWPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION )) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) (RIGHTW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 10:31 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((ROWPROPSPACE (WINDOWPROP MAINWINDOW 'ROWPROPSPACE)) (ROWPROPS (WINDOWPROP MAINWINDOW 'ROWPROPS)) (VERTMARKS (WINDOWPROP MAINWINDOW 'VERTMARKS)) (SELROWPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM (for VMARK in VERTMARKS as ROWPROP on ROWPROPS thereis (EQ ROWPROP SELROWPROP))) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELROWPROP) WINDOW T))) (SETQ SELLEFT (STRINGWIDTH ROWPROPSPACE WINDOW)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELROWPROP smashing SELECTION]) ) (* ;; "Top window fns") (DEFINEQ (GET-TOPW [LAMBDA (DISPLAYWINDOW FONT) (* ; "Edited 6-Apr-87 14:43 by jop") (LET [(TOPWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL (WINDOWPROP DISPLAYWINDOW 'BORDER) T] (WINDOWPROP TOPWINDOW 'REPAINTFN (FUNCTION TOPW.REPAINTFN)) (WINDOWPROP TOPWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TOPWINDOW 'BUTTONEVENTFN (FUNCTION TOPW.BUTTONEVENTFN)) (WINDOWPROP TOPWINDOW 'SCROLLFN (FUNCTION SCROLLBYREPAINTFN)) (DSPRIGHTMARGIN MAX.SMALLP TOPWINDOW) (* ;  "TOPWINDOW will scroll under program control") (WINDOWPROP TOPWINDOW 'NOSCROLLBARS T) (DSPFONT FONT TOPWINDOW) (WINDOWPROP DISPLAYWINDOW 'TOPWINDOW TOPWINDOW) TOPWINDOW]) (TOPW.REPAINTFN + [LAMBDA (WINDOW WINDOWREGION) (* ; "Edited 6-Apr-87 11:12 by jop") + (if (NULL WINDOWREGION) + then (SETQ WINDOWREGION (DSPCLIPPINGREGION NIL WINDOW))) + (PROG ((DISPLAYW (MAINWINDOW WINDOW)) + (LEFT (fetch (REGION LEFT) of WINDOWREGION)) + (RIGHT (fetch (REGION RIGHT) of WINDOWREGION)) + HORZMARKS COLUMNPROPS STARTCOLUMNPROPS LASTCOLUMNPROP STARTHORZMARKS) + (SETQ HORZMARKS (WINDOWPROP DISPLAYW 'HORZMARKS)) + (SETQ COLUMNPROPS (WINDOWPROP DISPLAYW 'COLUMNPROPS)) + (for COLUMNPROP on COLUMNPROPS as MARK on HORZMARKS + until (IGREATERP (CAR MARK) + LEFT) finally (SETQ STARTCOLUMNPROPS COLUMNPROP) + (SETQ STARTHORZMARKS MARK)) + (for COLUMNPROP on STARTCOLUMNPROPS as MARK in STARTHORZMARKS + until (IGREATERP MARK RIGHT) finally (SETQ LASTCOLUMNPROP COLUMNPROP)) + [if STARTCOLUMNPROPS + then (WITH-INSPECTOR-ENV (WINDOWPROP DISPLAYW 'PROFILE) + (bind [BOTTOM _ (SUB1 (FONTPROP WINDOW 'DESCENT] for COLUMNPROP + on STARTCOLUMNPROPS as HMARK in STARTHORZMARKS + repeatuntil (EQ COLUMNPROP LASTCOLUMNPROP) + do (MOVETO (ADD1 (DIFFERENCE HMARK (STRINGWIDTH (CAR COLUMNPROP) + WINDOW T))) + BOTTOM WINDOW) + (PRIN2 (CAR COLUMNPROP) + WINDOW] + (INSPECT.INVERTSELECTION WINDOW]) (TOPW.RESHAPEFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:55 by jop") (CLEARW WINDOW) (TOPW.ADJUSTSELECTION WINDOW) (TOPW.REPAINTFN WINDOW (DSPCLIPPINGREGION NIL WINDOW]) (TOPW.ADJUSTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:54 by jop") (PROG ((SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW))) (if SELECTION then (PROG ((COLUMNPROPS (WINDOWPROP MAINWINDOW 'COLUMNPROPS)) (HORZMARKS (WINDOWPROP MAINWINDOW 'HORZMARKS)) (SELCOLPROP (fetch (ONED.SELECTION PROP) of SELECTION)) SELBOTTOM SELWIDTH SELLEFT) (SETQ SELBOTTOM 0) (SETQ SELWIDTH (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (STRINGWIDTH (CAR SELCOLPROP) WINDOW T))) (SETQ SELLEFT (IDIFFERENCE (ADD1 (for HMARK in HORZMARKS as COLPROP on COLUMNPROPS thereis (EQ COLPROP SELCOLPROP))) SELWIDTH)) (WINDOWPROP WINDOW 'SELECTION (create ONED.SELECTION ELTBOTTOM _ SELBOTTOM ELTWIDTH _ SELWIDTH ELTLEFT _ SELLEFT PROP _ SELCOLPROP]) (TOPW.BUTTONEVENTFN [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 18:43 by jop") (TOTOPW WINDOW) (LET* [(SELECTION (WINDOWPROP WINDOW 'SELECTION)) (MAINWINDOW (MAINWINDOW WINDOW)) (COLUMNPROPCOMMANDFN (WINDOWPROP MAINWINDOW 'COLUMNPROPCOMMANDFN] (if COLUMNPROPCOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (if (MOUSESTATE LEFT) then (WINDOWPROP WINDOW 'SELECTION (ONED.TRACKCURSOR WINDOW SELECTION (WINDOWPROP MAINWINDOW 'COLUMNPROPS) (WINDOWPROP MAINWINDOW 'HORZMARKS) NIL 0 (FONTPROP WINDOW 'HEIGHT) [FUNCTION (LAMBDA (P W) P] (FUNCTION INSPECT.INVERTREGION) T)) else (* ; "MOUSESTATE MIDDLE") (if SELECTION then (CL:FUNCALL COLUMNPROPCOMMANDFN (CAR (fetch (ONED.SELECTION PROP) of SELECTION)) (WINDOWPROP MAINWINDOW 'DATUM) MAINWINDOW]) ) (* ;; "Title window fns") (DEFINEQ (GET-TITLEW [LAMBDA (DISPLAYWINDOW TITLE TITLEFONT DATUM) (* ; "Edited 6-Apr-87 17:02 by jop") (LET [(TITLEWINDOW (OR (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW) (CREATEW (CREATEREGION 0 0 100 100) NIL 1 T] (WINDOWPROP TITLEWINDOW 'REPAINTFN (FUNCTION TITLEW.REPAINTFN)) (WINDOWPROP TITLEWINDOW 'RESHAPEFN (FUNCTION CLEARW)) (WINDOWPROP TITLEWINDOW 'BUTTONEVENTFN (FUNCTION TITLEW.BUTTONEVENTFN)) (DSPFONT TITLEFONT TITLEWINDOW) (DSPOPERATION 'INVERT TITLEWINDOW) (WINDOWPROP TITLEWINDOW 'INSPECTTITLE (OR TITLE (CONCAT DATUM " Inspector"))) (WINDOWPROP DISPLAYWINDOW 'TITLEWINDOW TITLEWINDOW) TITLEWINDOW]) (TITLEW.REPAINTFN [LAMBDA (WINDOW) (* ; "Edited 5-Apr-87 14:50 by jop") (BITBLT NIL NIL NIL WINDOW NIL NIL NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) (MOVETOUPPERLEFT WINDOW) (PRINTOUT WINDOW (WINDOWPROP WINDOW 'INSPECTTITLE]) (TITLEW.BUTTONEVENTFN [LAMBDA (TITLEWINDOW) (* ; "Edited 5-Apr-87 16:41 by jop") (PROG ((MAINWINDOW (MAINWINDOW TITLEWINDOW)) TITLECOMMANDFN) (SETQ TITLECOMMANDFN (WINDOWPROP MAINWINDOW 'TITLECOMMANDFN)) (if TITLECOMMANDFN then (WITH-INSPECTOR-ENV (WINDOWPROP MAINWINDOW 'PROFILE) (APPLY* TITLECOMMANDFN MAINWINDOW]) ) (* ;; "Utilites ") (DEFINEQ (ONED.TRACKCURSOR [LAMBDA (WINDOW SELECTION PROPS MARKS LEFT BOTTOM HEIGHT NEW-ITEM-FN HIGHLIGHT-FN HORIZONTAL-P) (* ; "Edited 6-Apr-87 17:41 by jop") (LET (SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH SELECTEDPROP) (if SELECTION then (SETQ SELECTEDELTBOTTOM (fetch (ONED.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (ONED.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (ONED.SELECTION ELTWIDTH) of SELECTION)) (SETQ SELECTEDPROP (fetch (ONED.SELECTION PROP) of SELECTION))) (bind X Y NEWPROP WIDTH while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) [if (NOT HORIZONTAL-P) then [for PROP on PROPS as MARK in MARKS until (ILESSP MARK Y) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ BOTTOM MARK) (* ;  "Select the new region only if the cursor is inside the element box") (SETQ NEWPROP (AND [NOT (OR (ILESSP X LEFT) (IGREATERP X (IPLUS LEFT WIDTH] PROP] else (for PROP on PROPS as MARK in MARKS until (IGREATERP MARK X) finally (if PROP then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR PROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE MARK WIDTH))) (SETQ NEWPROP (AND (NOT (ILESSP X LEFT)) PROP] (if (NEQ NEWPROP SELECTEDPROP) then (* ;  "We need to consider highlighting a new region") (if SELECTEDPROP then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NIL)) (if NEWPROP then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDPROP NEWPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if SELECTEDPROP then (if (NULL SELECTION) then (SETQ SELECTION (create ONED.SELECTION))) (RETURN (create ONED.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM PROP _ SELECTEDPROP smashing SELECTION]) (TWOD.TRACKCURSOR [LAMBDA (WINDOW SELECTION ROWPROPS VERTMARKS COLUMNPROPS HORZMARKS HEIGHT NEW-ITEM-FN HIGHLIGHT-FN) (* ; "Edited 6-Apr-87 18:36 by jop") (TOTOPW WINDOW) (LET (SELECTEDROWPROP SELECTEDCOLUMNPROP SELECTEDELTBOTTOM SELECTEDELTLEFT SELECTEDELTWIDTH) (if SELECTION then (SETQ SELECTEDROWPROP (fetch (TWOD.SELECTION ROWPROP) of SELECTION)) (SETQ SELECTEDCOLUMNPROP (fetch (TWOD.SELECTION COLUMNPROP) of SELECTION)) (SETQ SELECTEDELTBOTTOM (fetch (TWOD.SELECTION ELTBOTTOM) of SELECTION)) (SETQ SELECTEDELTLEFT (fetch (TWOD.SELECTION ELTLEFT) of SELECTION)) (SETQ SELECTEDELTWIDTH (fetch (TWOD.SELECTION ELTWIDTH) of SELECTION))) (bind NEWROWPROP NEWCOLUMNPROP NEWHORZMARK LEFT BOTTOM WIDTH X Y while (MOUSESTATE LEFT) do (SETQ X (LASTMOUSEX WINDOW)) (SETQ Y (LASTMOUSEY WINDOW)) (for ROWPROP on ROWPROPS as VERTMARK in VERTMARKS until (ILESSP VERTMARK Y) finally (SETQ NEWROWPROP ROWPROP) (SETQ BOTTOM VERTMARK)) (for COLUMNPROP on COLUMNPROPS as HORZMARK in HORZMARKS until (IGREATERP HORZMARK X) finally (SETQ NEWCOLUMNPROP COLUMNPROP) (SETQ NEWHORZMARK HORZMARK)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (SETQ WIDTH (STRINGWIDTH (CL:FUNCALL NEW-ITEM-FN (CAR NEWROWPROP) (CAR NEWCOLUMNPROP) WINDOW) WINDOW T)) (SETQ LEFT (ADD1 (IDIFFERENCE NEWHORZMARK WIDTH))) (* ;  "Select the new region only if the cursor is inside the element box") (if (ILESSP X LEFT) then (SETQ NEWROWPROP NIL) (SETQ NEWCOLUMNPROP NIL))) (if (OR (NEQ NEWROWPROP SELECTEDROWPROP) (NEQ NEWCOLUMNPROP SELECTEDCOLUMNPROP)) then (* ;  "We need to consider highlighting a new region") (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (* ; "Lowlight the old region") (CL:FUNCALL HIGHLIGHT-FN SELECTEDELTLEFT SELECTEDELTBOTTOM SELECTEDELTWIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NIL) (SETQ SELECTEDCOLUMNPROP NIL)) (if (AND NEWROWPROP NEWCOLUMNPROP) then (* ;  "cursor inside element box, highlight that box") (CL:FUNCALL HIGHLIGHT-FN LEFT BOTTOM WIDTH HEIGHT WINDOW) (SETQ SELECTEDROWPROP NEWROWPROP) (SETQ SELECTEDCOLUMNPROP NEWCOLUMNPROP) (SETQ SELECTEDELTWIDTH WIDTH) (SETQ SELECTEDELTLEFT LEFT) (SETQ SELECTEDELTBOTTOM BOTTOM))) finally (if (AND SELECTEDROWPROP SELECTEDCOLUMNPROP) then (if (NULL SELECTION) then (SETQ SELECTION (create TWOD.SELECTION))) (RETURN (create TWOD.SELECTION ELTWIDTH _ SELECTEDELTWIDTH ELTLEFT _ SELECTEDELTLEFT ELTBOTTOM _ SELECTEDELTBOTTOM ROWPROP _ SELECTEDROWPROP COLUMNPROP _ SELECTEDCOLUMNPROP smashing SELECTION]) (INSPECT.INVERTSELECTION [LAMBDA (WINDOW) (* ; "Edited 6-Apr-87 11:11 by jop") (* ;; "Inverts SELECTION if non-NIL") (PROG [(SELECTION (WINDOWPROP WINDOW 'SELECTION] (if SELECTION then (INSPECT.INVERTREGION (fetch (INSPECT.SELECTION ELTLEFT) of SELECTION ) (fetch (INSPECT.SELECTION ELTBOTTOM) of SELECTION) (fetch (INSPECT.SELECTION ELTWIDTH) of SELECTION) (FONTPROP WINDOW 'HEIGHT) WINDOW]) (INSPECT.INVERTREGION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:38 by jop") (BLTSHADE BLACKSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) (INSPECT.FLIPSELECTION [LAMBDA (LEFT BOTTOM WIDTH HEIGHT WINDOW) (* ; "Edited 6-Apr-87 16:45 by jop") (BLTSHADE GRAYSHADE WINDOW LEFT BOTTOM WIDTH HEIGHT 'INVERT]) ) (RPAQ? INSPECTORFONT NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS INSPECTORFONT) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (BLOCKRECORD INSPECT.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH)) (DATATYPE ONED.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH PROP)) (DATATYPE TWOD.SELECTION (ELTBOTTOM ELTLEFT ELTWIDTH ROWPROP COLUMNPROP)) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) ) (/DECLAREDATATYPE 'ONED.SELECTION '(POINTER POINTER POINTER POINTER) '((ONED.SELECTION 0 POINTER) (ONED.SELECTION 2 POINTER) (ONED.SELECTION 4 POINTER) (ONED.SELECTION 6 POINTER)) '8) (/DECLAREDATATYPE 'TWOD.SELECTION '(POINTER POINTER POINTER POINTER POINTER) '((TWOD.SELECTION 0 POINTER) (TWOD.SELECTION 2 POINTER) (TWOD.SELECTION 4 POINTER) (TWOD.SELECTION 6 POINTER) (TWOD.SELECTION 8 POINTER)) '10) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) ) (PUTPROPS TWODINSPECTOR COPYRIGHT ("Venue & Xerox Corporation" 1985 1900 1987 1990 1992 1993 2020)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3520 4267 (\CREATE.TWODINSPECTOR.TITLEMENU 3530 . 3737) (\CREATE.TWODINSPECTOR.SETMENU 3739 . 3957) (\CREATE.TWODINSPECTOR.INSPECTMENU 3959 . 4265)) (4301 37441 (ONEDINSPECTW.CREATE 4311 . 8038) (GET-ONED-DISPLAYW 8040 . 10127) (ONEDINSPECT.ARRANGEWINDOWS 10129 . 15403) ( ONEDINSPECT.REPAINTFN 15405 . 17099) (ONEDINSPECT.PRINTELEMENT 17101 . 17319) (ONEDINSPECT.RESHAPEFN 17321 . 17657) (ONEDINSPECT.MAKEREGIONS 17659 . 19607) (ONEDINSPECT.BUTTONEVENTFN 19609 . 21622) ( ONEDINSPECT.COPYBUTTONFN 21624 . 23463) (ONEDINSPECT.SCROLLFN 23465 . 23881) (ONEDINSPECT.CLOSEFN 23883 . 24146) (ONEDINSPECT.REDISPLAY 24148 . 26904) (ONEDINSPECT.REPLACE 26906 . 27216) ( ONEDINSPECT.SELECTITEM 27218 . 29057) (ONEDINSPECT.SELECTPROP 29059 . 30803) ( ONEDINSPECT.ADJUSTSELECTION 30805 . 32345) (ONEDINSPECT.PROPWIDTH 32347 . 32964) ( ONEDINSPECT.VALUEWIDTH 32966 . 33352) (ONEDINSPECT.DEFAULT.TITLECOMMANDFN 33354 . 34329) ( ONEDINSPECT.DEFAULT.VALUECOMMANDFN 34331 . 35893) (ONEDINSPECT.SETELT 35895 . 37439)) (37474 83543 ( TWODINSPECTW.CREATE 37484 . 42117) (GET-TWOD-DISPLAYW 42119 . 44769) (GET-CORNERW 44771 . 45476) ( TWODINSPECT.ARRANGEWINDOWS 45478 . 51599) (TWODINSPECT.REPAINTFN 51601 . 54786) ( TWODINSPECT.PRINTELEMENT 54788 . 55063) (TWODINSPECT.RESHAPEFN 55065 . 55401) (TWODINSPECT.MAKEREGIONS 55403 . 58204) (TWODINSPECT.BUTTONEVENTFN 58206 . 60835) (TWODINSPECT.COPYBUTTONFN 60837 . 63128) ( TWODINSPECT.DOWINDOWCOMFN 63130 . 63740) (TWODINSPECT.SCROLLFN 63742 . 64401) (TWODINSPECT.CLOSEFN 64403 . 64796) (TWODINSPECT.REDISPLAY 64798 . 69035) (TWODINSPECT.REPLACE 69037 . 69375) ( TWODINSPECT.SELECTITEM 69377 . 72298) (TWODINSPECT.SELECTROWPROP 72300 . 74078) ( TWODINSPECT.SELECTCOLUMNPROP 74080 . 76114) (TWODINSPECT.ADJUSTSELECTION 76116 . 78484) ( TWODINSPECT.DEFAULT.TITLECOMMANDFN 78486 . 79461) (TWODINSPECT.DEFAULT.VALUECOMMANDFN 79463 . 81039) ( TWODINSPECT.SETELT 81041 . 82077) (TWODINSPECT.ROWPROPWIDTH 82079 . 82328) (TWODINSPECT.COLUMNWIDTHS 82330 . 82725) (TWODINSPECT.COLUMNWIDTH 82727 . 83270) (TWODINSPECT.TOTALWIDTH 83272 . 83541)) (83578 91324 (GET-RIGHTW 83588 . 84440) (RIGHTW.REPAINTFN 84442 . 86941) (RIGHTW.RESHAPEFN 86943 . 87162) ( RIGHTW.BUTTONEVENTFN 87164 . 89759) (RIGHTW.ADJUSTSELECTION 89761 . 91322)) (91357 98194 (GET-TOPW 91367 . 92359) (TOPW.REPAINTFN 92361 . 94220) (TOPW.RESHAPEFN 94222 . 94465) (TOPW.ADJUSTSELECTION 94467 . 96086) (TOPW.BUTTONEVENTFN 96088 . 98192)) (98229 99746 (GET-TITLEW 98239 . 99003) ( TITLEW.REPAINTFN 99005 . 99291) (TITLEW.BUTTONEVENTFN 99293 . 99744)) (99774 110379 (ONED.TRACKCURSOR 99784 . 104485) (TWOD.TRACKCURSOR 104487 . 109193) (INSPECT.INVERTSELECTION 109195 . 109983) ( INSPECT.INVERTREGION 109985 . 110180) (INSPECT.FLIPSELECTION 110182 . 110377))))) STOP \ No newline at end of file diff --git a/sources/TWODINSPECTOR.TEDIT b/sources/TWODINSPECTOR.TEDIT new file mode 100644 index 00000000..337276fe --- /dev/null +++ b/sources/TWODINSPECTOR.TEDIT @@ -0,0 +1,7 @@ +XEROX Lisp Users' Package 2 4 1 TWODINSPECTOR 1 4 By: Jan Pedersen (Pedersen.PA @ Xerox.ARPA) The TWODINSPECTOR package provides a two-dimensional inspector window abstraction, very similar in form to the standard one-dimensional inspector but laid out in rows and columns, instead of just rows. The top level function is TWODINSPECTW.CREATE (TWODINSPECTW.CREATE DATUM ROWPROPS COLUMNPROPS FETCHFNà STOREFN VALUECOMMANDFN ROWPROPCOMMANDFNà COLUMNPROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) [Function] Datum is the object to be inspected. Rowprops is a list of properties of the datum which will be laid out vertically, or a function which will be called with datum as an argument and returns such a list. Similarly, columnprops is a list of properties of the datum which will be laid out horizontally, or a function which will be called with datum as an argument and returns such a list. Each pair (rowprop, columprop) specifies a cell of the twodimensional inspector window. Fetchfn is a function which if called with arguments datum, rowprop, and columprop returns the value in that cell. Storefn is a function which if called with arguments newvalue, datum, rowprop, and columprop stores newvalue in the cell. The cells of the inspector window are selectable. If valuecommandfn is given, it must be a function which will be called with arguments cellvalue, rowprop, columnprop, datum, and twodinspectwindow when the cell specified by (rowprop, columnprop) is selected. A default valuecommandfn is provided which allows the cellvalue to be inspected, set, or bound to the litatom IT. Similarly the rowprops and the columnprops themselves are selectable. If rowpropcommandfn is given it must be a function which will be called with args rowprop, datum, and twodinspectwindow when rowprop is selected. If columnpropcommandfn is given it must be a function which will be called with args columnprop, datum, and twodinspectwindow when columnprop is selected. No default rowpropcommandfn or columnpropcommandfn is provided. If rowpropcommandfn is not given, the rowprops will not be selectable. Similarly, If columnpropcommandfn is not given, the columnprops will not be selectable. Title will be the title for the window -- a default is provided. Titlecommandfn is a function which will be called with the single argument twodinspectwindow if the middle button is depressed in the title bar of the window. Where may be a window, in which case it will be used as at least part of the twodinspector (the twodinspector is composed of five window), This is especially useful if where is the result of a previous call to TWODINSPECTW.CREATE. The dimensions of where will not be used to position the twodinspector unless topright is NIL. Where may also be region or a position specifying the lower left hand corner of the twodinspector. If where is NIL, the user will be prompted for a position. Topright allows the user to specify the top right-hand corner of the twodinspector. Topright must be a position, and if given overrides any specification which may have been provided by the argument where. Returns the main window of an attached window group. The arguments to TWODINSPECTW.CREATE are cached on windowprops of the same name on the returned main window. Several functions are provided for use in the various command functions. (TWODINSPECT.REDISPLAY TWODINSPECTW SOMEROWPROPS à SOMECOLUMNPROPS) [Function] Redisplay selected cells of twodinspectw. Somerowprops may either be a single rowprop, a list of rowprops, or NIL. Somecolumnprops may either be a single columnprop, a list of columnprops, or NIL. If either are NIL the entire twodinspectw is recomputed and redisplayed. Otherwise, the cells specified by the cross product of somerowprops and somecolumnprops are redisplayed, possibly forcing the entire twodinspectw to redisplay if the printed representation of a cell overflows its column width. (TWODINSPECT.REPLACE TWODINSPECTW ROWPROP COLUMNPROP à NEWVALUE) [Function] Replaces the cell specified by (rowprop, columprop) with newvalue and updates the display. (TWODINSPECT.SELECTITEM TWODINSPECTW ROWPROP COLUMNPROP] [Function] Selects the cell specified by (rowprop, columprop). That cell is inverted and put on the window prop SELECTION of twodinspectw. If either of rowprop or columprop is NIL, then the current selection is simply deselected. (TWODINSPECT.SELECTROWPROP TWODINSPECTW ROWPROP] [Function] Selects rowprop. If rowprop is NIL, then the currently selected rowprop is deselected. (TWODINSPECT.SELECTCOLUMNPROP TWODINSPECTW COLUMNPROP] [Function] Selects columprop. If rowprop is NIL, then the currently selected columprop is deselected. Note: there is no provision for redisplaying selected row or column props -- although this may be effected by redisplaying the entire twodinspectw. Since the Twodinspector windows differ stylistically from the standard inspector windows, a stylistically similar onedinspector window is also provided. (ONEDINSPECTW.CREATE DATUM PROPS FETCHFN STOREFN VALUECOMMANDFN à PROPCOMMANDFN TITLE TITLECOMMANDFN WHERE TOPRIGHT) [Function] Datum is the object to be inspected.Props is a list of properties of the datum which will be laid out horizontally, or a function which will be called with datum as an argument and returns such a list. Each prop specifies a cell of the onedimensional inspector window. Fetchfn is a function which if called with arguments datum, and prop returns the value in that cell. Storefn is a function which if called with arguments newvalue, datum, and prop stores newvalue in the cell. The cells of the inspector window are selectable. If valuecommandfn is given, it must be a function which will be called with arguments cellvalue, prop, datum, and onedinspectwindow when the cell specified by prop is selected. A default valuecommandfn is provided which allows the cellvalue to be inspected, set, or bound to the litatom IT. Similarly the props themselves are selectable. If propcommandfn is given it must be a function which will be called with args prop, datum, and onedinspectwindow when prop is selected. No default propcommandfn is provided. If propcommandfn is not given, the props will not be selectable. Title will be the title for the window -- a default is provided. Titlecommandfn is a function which will be called with the single argument onedinspectwindow if the middle button is depressed in the title bar of the window. Where may be a window, in which case it will be used as at least part of the onedinspector (the onedinspector is composed of three window), This is especially useful if where is the result of a previous call to ONEDINSPECTW.CREATE or TWODINSPECTW.CREATE. The dimensions of where will not be used to position the onedinspector unless topright is NIL. Where may also be region or a position specifying the lower left hand corner of the onedinspector. If where is NIL, the user will be prompted for a position. Topright allows the user to specify the top right-hand corner of the onedinspector. Topright must be a position, and if given overrides any specification which may have been provided by the argument where. Returns the main window of an attached window group. The arguments to ONEDINSPECTW.CREATE are cached on windowprops of the same name on the returned main window. (ONEDINSPECT.REDISPLAY ONEDINSPECTW SOMEPROPS) [Function] Redisplay selected cells of onedinspectw. Someprops may either be a single prop, a list of props, or NIL, in which case the entire onedinspectw is recomputed and redisplayed. Otherwise, the cell(s) specified by the someprops are redisplayed, possibly forcing the entire someprops to redisplay if the printed representation of a cell overflows the column width. (ONEDINSPECT.REPLACE ONEDINSPECTW PROP NEWVALUE) [Function] Replaces the cell specified by prop with newvalue and updates the display. (ONEDINSPECT.SELECTITEM ONEDINSPECTW PROP) [Function] Selects the cell specified by prop. That cell is inverted and put on the window prop SELECTION of onedinspectw. If prop is NIL, then the current selection is simply deselected. (ONEDINSPECT.SELECPROP ONEDINSPECTW PROP) [Function] Selects prop. If prop is NIL, then the currently selected prop is deselected. /HHÈÈ/È ¼È&È &È&ŠŠ8&ŠŠ8BÈÈ PAGEHEADING RUNNINGHEAD&MODERN +MODERN MODERN +MODERNLOGO?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) + HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN + HRULE.GETFNMODERN  HRULE.GETFNMODERN -Í.*+ ÈuRàFžÎ5nI ñ# Z  Ú V  Z“™ "2 ßUà^žÎ4m i J ° M E»zº \ No newline at end of file diff --git a/sources/UFS b/sources/UFS new file mode 100644 index 00000000..d2a5cdd9 --- /dev/null +++ b/sources/UFS @@ -0,0 +1,771 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED "31-Dec-2000 12:38:40" {DSK}medley3.5>sources>UFS.;2 69364 + + changes to%: (VARS UFSCOMS) + + previous date%: "29-Mar-95 17:50:11" {DSK}medley3.5>sources>UFS.;1) + + +(* ; " +Copyright (c) 1988, 1989, 1990, 1991, 1992, 1993, 1994, 1995, 2000 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT UFSCOMS) + +(RPAQQ UFSCOMS + [(PROP (FILETYPE MAKEFILE-ENVIRONMENT) + UFS) + (DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP) + DIRECTORY FILEIO)) + (COMS (* ; "Create FDEV function.") + (FNS \UFSCreateDevice \UFS.CREATE.DEVICE \UFSOpenDevice \UFSCloseDevice) + (INITVARS (\UFSdevice) + (\UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor"))) + (GLOBALVARS \UFSdevice \UFStopMonitor)) + (COMS (DECLARE%: DONTCOPY (EXPORT (RECORDS UFSGENFILESTATE))) + (INITRECORDS UFSGENFILESTATE) + (SYSRECORDS UFSGENFILESTATE)) + (COMS (* ; + "UNIX File System's FDEV methods.") + (FNS \UFSOpenFile \UFS.OPENP \UFS.RECOGNIZE.FILE \UFS.DIRECTORY.NAME \UFSCloseFile + \UFSGetFileName \UFSDeleteFile \UFSRenameFile \UFSReadPages \UFSWritePages + \UFSTruncateFile \UFSDirectoryNameP \UFSEventFn \UFSGetFileInfo \UFS.CREATE.PROPS + \UFSSetFileInfo \UFSGenerateFiles \UFS.NEXTFILEFN \UFS.FILEINFOFN \UFS.VALID.PROPP + \UFS.REGISTER.GFS \UFS.UNREGISTER.GFS \UFS.ABORT.DIRECTORY \UFS.ABORT.CL-DIRECTORY + \UFS.CLEANUP.GFS.TABLE)) + (COMS (* ; "File Name parsing") + (FNS \UFSMakeUnixFormatName \UFSParseNameString \UFSParse-Directory \UFS.PARSE.BODY + \UFS.ADJUST.HOST \UFS.FULLNAME \UFS.ADD.HOST.FIELD \UFS.REMOVE.HOST.FIELD + \UFS.HANDLE.RELATIVEDIRECTORY) + (INITVARS (\UFSDefaultDelimiter "/") + (\UFSDefaultDelimiterChar '/) + (\UFSDefaultConnDir "./") + (\UFSBeforeType '%.) + (\UFSBeforeVersion ';) + (\UFSDeviceDelimiter '}) + (\DSK.DEFAULT.DIRECTORY "~>") + (\UFS.DEFAULT.DIRECTORY ".>") + (*DSK-UPPER-CASE-FILE-NAMES* NIL) + (\UFS.GFS.TABLE (HASHARRAY 20)) + (*DSK-HOST-NAME* "{DSK}") + (*UFS-HOST-NAME* "{UNIX}")) + (GLOBALVARS \UFSDeviceDelimiter \UFSBeforeVersion \UFSBeforeType \UFSDefaultConnDir + \UFSDefaultDelimiterChar \UFSDefaultDelimiter \DSK.DEFAULT.DIRECTORY + \UFS.DEFAULT.DIRECTORY *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE + *DSK-HOST-NAME* *UFS-HOST-NAME*)) + (COMS + (* ;; "Change UNIX Curent Directory") + + (FNS CHDIR) + + (* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") + + (FNS \DEVICEFILE.EOSERROR) + + (* ;; "flush/revalidate unvisible stream, like dribble files.") + + (FNS \UNVISIBLE.PAGED.REVALIDATEFILELST \UNVISIBLE.FLUSH.OPEN.STREAMS) + + (* ;; " Error handler") + + (FNS \UFSError)) + (COMS (* ; "File Type and EOL handling") + (FNS \UFSGetFileType \UFSSetFileType \UFSeol) + [DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (DEFAULTFILETYPE 'BINARY) + (DEFAULTFILETYPELIST '((NIL . BINARY) + (C . TEXT) + (H . TEXT) + (EL . TEXT) + (IM . TEXT) + (LISP . TEXT) + (LSP . TEXT) + (O . BINARY) + (OUT . BINARY) + (LCOM . BINARY) + (DFASL . BINARY) + (DCOM . BINARY) + (SKETCH . BINARY) + (TEDIT . BINARY) + (TED . BINARY) + (DISPLAYFONT . BINARY) + (AC . BINARY) + (WD . BINARY) + (IP . BINARY) + (INTERPRESS . BINARY) + (PRESS . BINARY) + (PSCFONT . BINARY) + (RST . BINARY) + (BIN . BINARY) + (MAIL . BINARY) + (SYSOUT . BINARY) + (SYSOUT.Z . BINARY) + (TAR . BINARY) + (INDEX . BINARY) + (HASH . BINARY) + (NOTEFILE . BINARY) + (Z . BINARY) + (VIRTUALMEM . BINARY) + (VM . BINARY] + (GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST)) + (DECLARE%: EVAL@COMPILE DONTCOPY (COMS * UFSDECLS)) + (COMS (* ; "Filetypepatch functions. ") + (FNS \UFSGetPrintFileType \UFSGetFileTypeConfirm \UFSPrintTypeMenu) + (* ; "for hardcopy") + (FNS \UFStoOtherCopyMess \UFStoOtherRenameMess) + (* ; "for copyfile,renamefile") + (INITVARS (FileTypeConfirmFlg T)) + (GLOBALVARS FileTypeMenu FileTypeConfirmFlg)) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA]) + +(PUTPROPS UFS FILETYPE :BCOMPL) + +(PUTPROPS UFS MAKEFILE-ENVIRONMENT (:PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)) +(DECLARE%: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY + +(FILESLOAD (LOADCOMP) + DIRECTORY FILEIO) +) + + + +(* ; "Create FDEV function.") + +(DEFINEQ + +(\UFSCreateDevice (LAMBDA NIL (* ; "Edited 27-Feb-89 18:28 by bvm") (* ;;; "Creates and remembers the local hard disk file device, but does not open the device or any of its associated directories.") (if (AND (BOUNDP (QUOTE \UFSdevice)) (type? FDEV \UFSdevice)) then \UFSdevice else (SETQ \UFSdevice (\UFS.CREATE.DEVICE (QUOTE UNIX) (FUNCTION \UFSEventFn))))) ) + +(\UFS.CREATE.DEVICE (LAMBDA (NAME EVENTFN) (* ; "Edited 27-Feb-89 18:28 by bvm") (\MAKE.PMAP.DEVICE (create FDEV NODIRECTORIES _ T DEVICENAME _ NAME CLOSEFILE _ (FUNCTION \UFSCloseFile) DELETEFILE _ (FUNCTION \UFSDeleteFile) RENAMEFILE _ (FUNCTION \UFSRenameFile) TRUNCATEFILE _ (FUNCTION \UFSTruncateFile) GETFILEINFO _ (FUNCTION \UFSGetFileInfo) GETFILENAME _ (FUNCTION \UFSGetFileName) OPENFILE _ (FUNCTION \UFSOpenFile) READPAGES _ (FUNCTION \UFSReadPages) SETFILEINFO _ (FUNCTION \UFSSetFileInfo) WRITEPAGES _ (FUNCTION \UFSWritePages) REOPENFILE _ (FUNCTION \UFSOpenFile) GENERATEFILES _ (FUNCTION \UFSGenerateFiles) EVENTFN _ EVENTFN DIRECTORYNAMEP _ (FUNCTION \UFSDirectoryNameP) HOSTNAMEP _ (FUNCTION NILL) OPENP _ (FUNCTION \GENERIC.OPENP) REGISTERFILE _ (FUNCTION \ADD-OPEN-STREAM) UNREGISTERFILE _ (FUNCTION \GENERIC-UNREGISTER-STREAM)))) ) + +(\UFSOpenDevice (LAMBDA NIL (* ; "Edited 7-Apr-88 17:46 by masinter") (WITH.MONITOR \UFStopMonitor (LET ((DEV (\UFSCreateDevice))) (\DEFINEDEVICE (QUOTE UNIX) DEV) DEV))) ) + +(\UFSCloseDevice (LAMBDA NIL (* ; "Edited 13-Aug-87 14:15 by hayata") (WITH.MONITOR \UFStopMonitor (\REMOVEDEVICE \UFSdevice) NIL)) ) +) + +(RPAQ? \UFSdevice ) + +(RPAQ? \UFStopMonitor (CREATE.MONITORLOCK "UFSTopMonitor")) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \UFSdevice \UFStopMonitor) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(DATATYPE UFSGENFILESTATE ( + (* ;; + "Holds the file-directory-generator state for %"Unix%" file system enumeration.") + + (FINFOID FIXP) + (FILEID FIXP) (* ; + "Current file in list of 1 to TOTALNUM files.") + (TOTALNUM FIXP) + DIRECTORY DEV (PROPP FLAG) + THISFILE + (ERRONO FIXP) + NAME + (LENGTH FIXP) + (WDATE FIXP) + (RDATE FIXP) + (PROTECTION FIXP) + AUTHOR + (AULEN FIXP) + SUBGENERATORS (* ; +"A push-down list of generators for subdirectories. Used to generate to multiple-directory depths.") + CURRENT-DEPTH (* ; + "Current depth in the directory tree, so we can obey FILING.ENUMERATION.DEPTH") + MAX-DEPTH (* ; + "Value of FILING.ENUMERATION.DEPTH we were started with, so we can obey it.") + )) +) + +(/DECLAREDATATYPE 'UFSGENFILESTATE + '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP + POINTER POINTER POINTER) + '((UFSGENFILESTATE 0 FIXP) + (UFSGENFILESTATE 2 FIXP) + (UFSGENFILESTATE 4 FIXP) + (UFSGENFILESTATE 6 POINTER) + (UFSGENFILESTATE 8 POINTER) + (UFSGENFILESTATE 8 (FLAGBITS . 0)) + (UFSGENFILESTATE 10 POINTER) + (UFSGENFILESTATE 12 FIXP) + (UFSGENFILESTATE 14 POINTER) + (UFSGENFILESTATE 16 FIXP) + (UFSGENFILESTATE 18 FIXP) + (UFSGENFILESTATE 20 FIXP) + (UFSGENFILESTATE 22 FIXP) + (UFSGENFILESTATE 24 POINTER) + (UFSGENFILESTATE 26 FIXP) + (UFSGENFILESTATE 28 POINTER) + (UFSGENFILESTATE 30 POINTER) + (UFSGENFILESTATE 32 POINTER)) + '34) + +(* "END EXPORTED DEFINITIONS") + +) + +(/DECLAREDATATYPE 'UFSGENFILESTATE + '(FIXP FIXP FIXP POINTER POINTER FLAG POINTER FIXP POINTER FIXP FIXP FIXP FIXP POINTER FIXP + POINTER POINTER POINTER) + '((UFSGENFILESTATE 0 FIXP) + (UFSGENFILESTATE 2 FIXP) + (UFSGENFILESTATE 4 FIXP) + (UFSGENFILESTATE 6 POINTER) + (UFSGENFILESTATE 8 POINTER) + (UFSGENFILESTATE 8 (FLAGBITS . 0)) + (UFSGENFILESTATE 10 POINTER) + (UFSGENFILESTATE 12 FIXP) + (UFSGENFILESTATE 14 POINTER) + (UFSGENFILESTATE 16 FIXP) + (UFSGENFILESTATE 18 FIXP) + (UFSGENFILESTATE 20 FIXP) + (UFSGENFILESTATE 22 FIXP) + (UFSGENFILESTATE 24 POINTER) + (UFSGENFILESTATE 26 FIXP) + (UFSGENFILESTATE 28 POINTER) + (UFSGENFILESTATE 30 POINTER) + (UFSGENFILESTATE 32 POINTER)) + '34) +(ADDTOVAR SYSTEMRECLST + +(DATATYPE UFSGENFILESTATE ((FINFOID FIXP) + (FILEID FIXP) + (TOTALNUM FIXP) + DIRECTORY DEV (PROPP FLAG) + THISFILE + (ERRONO FIXP) + NAME + (LENGTH FIXP) + (WDATE FIXP) + (RDATE FIXP) + (PROTECTION FIXP) + AUTHOR + (AULEN FIXP) + SUBGENERATORS CURRENT-DEPTH MAX-DEPTH)) +) + + + +(* ; "UNIX File System's FDEV methods.") + +(DEFINEQ + +(\UFSOpenFile (LAMBDA (FILE ACCESS RECOG OTHERINFO FDEV OLDSTREAM) (* ; "Edited 6-Jun-90 12:18 by nm") (* ;;; "Open a file.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG ((ACC (SELECTQ ACCESS (INPUT ACCESS-INPUT) (OUTPUT ACCESS-OUTPUT) (BOTH ACCESS-BOTH) (APPEND ACCESS-APPEND) ACCESS-OTHER)) (REC (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (SELECTQ ACCESS (INPUT RECOG-OLD) (OUTPUT RECOG-NEW) ((BOTH APPEND) RECOG-NEW-OLD) RECOG-OTHER))) (EOF-FN (FUNCTION \EOSERROR)) (ERRNO (CREATECELL \FIXP)) OTHER FILEID BYTESIZE CDATE FULLNAME CINFO STRM CASE.CORRECT.NAME CASE.CORRECT.FULLFILENAME) (SETQ CASE.CORRECT.NAME (if (type? STREAM FILE) then (COND ((fetch (UFSSTREAM FILEID) of FILE) (* ; "Already open--this really ought to be an error") (RETURN FILE)) (T (LET ((FULLNAME (fetch (UFSSTREAM UNIXNAME) of FILE))) (SETQ STRM FILE) (* ; "Re use the old stream") (SUBSTRING FULLNAME (ADD1 (STRPOS "}" FULLNAME)))))) else (\UFS.RECOGNIZE.FILE FILE RECOG FDEV))) (COND ((NOT CASE.CORRECT.NAME) (RETURN NIL)) ((AND (NULL OLDSTREAM) (EQ (fetch (FDEV DEVICENAME) of FDEV) (QUOTE DSK)) (SETQ OTHER (\UFS.OPENP CASE.CORRECT.NAME FDEV)) (SELECTQ ACCESS (INPUT (* ; "ok if other file is also input") (DIRTYABLE OTHER)) T)) (* ; "Access conflict. Don't check this when just revalidating, of course. I also don't mess with this on UNIX device--let user get in trouble...") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME (\UFS.FULLNAME CASE.CORRECT.NAME FDEV)))) (SETQ CASE.CORRECT.FULLFILENAME (\UFS.ADD.HOST.FIELD CASE.CORRECT.NAME FDEV)) (* ;; "DSK cannot open a directory.") (AND (DSKP FDEV) (DIRECTORYNAMEP CASE.CORRECT.FULLFILENAME) (PROGN (PROMPTPRINT "{DSK} cannot open a directory file. Use {UNIX} device.") (\UFSError CASE.CORRECT.NAME 23 FDEV))) (SETQ CDATE (CREATECELL \FIXP)) (SETQ BYTESIZE (CREATECELL \FIXP)) (SETQ FILEID (OR (\UFSOpenFile-C CASE.CORRECT.FULLFILENAME REC ACC CDATE BYTESIZE ERRNO) (RETURN (\UFSError CASE.CORRECT.NAME ERRNO FDEV)))) (if (= (IPLUS BYTESIZE 0) -1) then (SETQ EOF-FN (FUNCTION \DEVICEFILE.EOSERROR)) (SETQ BYTESIZE 0) elseif (EQ ACCESS (QUOTE OUTPUT)) then (SETQ BYTESIZE 0)) (if STRM then (replace (STREAM FULLFILENAME) of STRM with (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T)) (replace (STREAM DEVICE) of STRM with FDEV) (replace (STREAM EPAGE) of STRM with (FOLDLO BYTESIZE BYTESPERPAGE)) (replace (STREAM EOFFSET) of STRM with (IMOD BYTESIZE BYTESPERPAGE)) (replace (STREAM EOLCONVENTION) of STRM with (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO))) (replace (STREAM VALIDATION) of STRM with CDATE) (replace (STREAM ENDOFSTREAMOP) of STRM with EOF-FN) else (SETQ STRM (create STREAM FULLFILENAME _ (\UFS.FULLNAME CASE.CORRECT.NAME FDEV T) DEVICE _ FDEV EPAGE _ (FOLDLO BYTESIZE BYTESPERPAGE) EOFFSET _ (IMOD BYTESIZE BYTESPERPAGE) EOLCONVENTION _ (\UFSeol CASE.CORRECT.NAME (FASSOC (QUOTE TYPE) OTHERINFO)) VALIDATION _ CDATE ENDOFSTREAMOP _ EOF-FN))) (replace (UFSSTREAM FILEID) of STRM with FILEID) (replace (UFSSTREAM CDATE) of STRM with (if (SETQ CINFO (FASSOC (QUOTE CREATIONDATE) OTHERINFO)) then (IDATE (CADR CINFO)) else 0)) (replace (UFSSTREAM UNIXNAME) of STRM with CASE.CORRECT.FULLFILENAME) (* ; "Save the case sensitive full file name for closef & getfileinfo.") (RETURN STRM)))) ) + +(\UFS.OPENP (LAMBDA (UNIXNAME DEV) (* ; "Edited 3-Mar-89 11:47 by bvm") (* ;; "Returns first open file having specified unix name") (for S in (fetch (FDEV OPENFILELST) of DEV) bind (COMPAREFN _ (if (EQ (fetch (FDEV DEVICENAME) of DEV) (QUOTE DSK)) then (* ; "We're case-insensitive, and it seems like not all functions return the correct Unix case") (FUNCTION STRING-EQUAL) else (* ; "Exact") (FUNCTION STREQUAL))) thereis (CL:FUNCALL COMPAREFN UNIXNAME (fetch (UFSSTREAM UNIXNAME) of S)))) ) + +(\UFS.RECOGNIZE.FILE (LAMBDA (FILENAME RECOG DEV) (* ; "Edited 13-Mar-90 11:19 by nm") (* ;; "Perform recognition on FILENAME, returning the %"true%" name for the file, or NIL. The result file name is following the Xerox Lisp file naming convention but does not include HOST field. It will be supplied by \UFS.FULLNAME.") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (ERRNO (CREATECELL \FIXP)) LEN) (SETQ LEN (CL:FUNCALL (\UFS.FILE.RECOGNIZER DEV) (\UFS.REMOVE.HOST.FIELD FILENAME DEV) (SELECTQ RECOG (OLD RECOG-OLD) (OLDEST RECOG-OLDEST) (NEW RECOG-NEW) (OLD/NEW RECOG-NEW-OLD) (NON RECOG-NON) RECOG-NEW-OLD) NAMEAREA ERRNO)) (COND ((FIXP LEN) (SUBSTRING NAMEAREA 1 LEN)) (T (\UFSError FILENAME ERRNO)))))) ) + +(\UFS.DIRECTORY.NAME (LAMBDA (DIRSTRING NAMEAREA DEV) (* ; "Edited 1-Apr-90 23:36 by nm") (* ;;; "Accepts a Xerox Lisp canonical directory name, and recognize it. If such directory exists, sets the %"ture%" name of the directory in NAMEAREA and returns the length of the name. If such directory does not exist, returns NIL. The canonical directory name does not include the initial directory delimiter and the trail directory delimiter, but the result %"ture%" name includes both of them. If DIRSTRING is %"<%", it means the root directory.") (if (STREQUAL DIRSTRING "<") then (RPLSTRING NAMEAREA 1 "<") 1 else (WITH.MONITOR (\UFSGetMonitor DEV) (CL:FUNCALL (\UFS.DIRECTORY.RECOGNIZER DEV) DIRSTRING NAMEAREA (CREATECELL \FIXP))))) ) + +(\UFSCloseFile (LAMBDA (STREAMFILE) (* ; "Edited 30-Mar-90 10:39 by nm") (* ; "return stream") (* ;;; "Closes the specified stream.") (* * WITH.MONITOR \UFStopMonitor) (* ;;; "Write out and dispense with buffers for this stream.") (\CLEARMAP STREAMFILE) (PROG ((DEVICE (fetch (STREAM DEVICE) of STREAMFILE)) (CDATE 0) (ERRNO (CREATECELL \FIXP)) (UNIXNAME (fetch (UFSSTREAM UNIXNAME) of STREAMFILE))) (if (NULL UNIXNAME) then (* ; "Already closed! Somebody's trying to close us twice.") (RETURN NIL)) (if (DIRTYABLE STREAMFILE) then (* ; "Open for output") (FDEVOP (QUOTE TRUNCATEFILE) DEVICE STREAMFILE) (SETQ CDATE (fetch (UFSSTREAM CDATE) of STREAMFILE))) (RETURN (if (\UFSCloseFile-C UNIXNAME (fetch (UFSSTREAM FILEID) of STREAMFILE) CDATE ERRNO) then (replace (UFSSTREAM FILEID) of STREAMFILE with NIL) (replace (UFSSTREAM CDATE) of STREAMFILE with NIL) (* ; "Clear open-file state") STREAMFILE else (\UFSError (fetch (STREAM FULLFILENAME) of STREAMFILE) ERRNO))))) ) + +(\UFSGetFileName (LAMBDA (FILENAME RECOG DEV) (* ; "Edited 24-Feb-89 16:20 by bvm") (* ;; "Recognize filename, return full name") (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE FILENAME RECOG DEV) DEV T)) ) + +(\UFSDeleteFile (LAMBDA (FILENAME DEV) (* ; "Edited 30-Mar-90 10:46 by nm") (* ; "return deleted file name") (* ; "if error, return NIL") (WITH.MONITOR (\UFSGetMonitor DEV) (LET ((NAME (\UFS.RECOGNIZE.FILE FILENAME (QUOTE OLDEST) DEV))) (COND ((AND NAME (NOT (\UFS.OPENP NAME DEV))) (* ; "file found and not open, so try to delete") (LET ((ERRNO (CREATECELL \FIXP))) (COND ((\UFSDeleteFile-C (\UFS.REMOVE.HOST.FIELD NAME DEV) DEV ERRNO) (* ; "Success") (\UFS.FULLNAME NAME DEV T)) (T (* ; "Failure") (\UFSError NAME ERRNO DEV))))))))) ) + +(\UFSRenameFile (LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 16-Apr-90 13:46 by nm") (if (NEQ OLD-DEVICE NEW-DEVICE) then (* ;; "Call the generic rename function. ") (LET ((FILE (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME))) (COND ((AND FILE (EQ \MACHINETYPE \MAIKO) FileTypeConfirmFlg) (* ; "print warnig message") (\UFStoOtherRenameMess OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME))) FILE) else (* ;; "UNIX file system rename.") (LET ((OLDUNIXNAME (\UFS.RECOGNIZE.FILE OLD-NAME (QUOTE OLD) OLD-DEVICE))) (if (AND OLDUNIXNAME (NOT (\UFS.OPENP OLDUNIXNAME OLD-DEVICE))) then (* ; "Old file is found and not open, so proceed") (LET ((NEWUNIXNAME (\UFS.RECOGNIZE.FILE NEW-NAME (QUOTE NEW) NEW-DEVICE)) (ERRNO (CREATECELL \FIXP))) (COND ((\UFSRenameFile-C (\UFS.REMOVE.HOST.FIELD OLDUNIXNAME OLD-DEVICE) (\UFS.REMOVE.HOST.FIELD NEWUNIXNAME NEW-DEVICE) NEW-DEVICE ERRNO) (\UFS.FULLNAME NEWUNIXNAME NEW-DEVICE)) (T (if (EQL (IPLUS ERRNO 0) 18) then (* ; "CrossDeviceError. Should be PARAMETER!") (\GENERIC.RENAMEFILE OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) else (\UFSError (CONCAT OLDUNIXNAME " or " NEWUNIXNAME) ERRNO) NIL)))))))) ) + +(\UFSReadPages (LAMBDA (stream streamFirstPage buffers) (* ; "Edited 3-Mar-89 14:49 by bvm") (* ;;; "ARG0 -- stream : {stream} data type.") (* ;;; "ARG1 -- streamFirstPage : the 1st page number of file to read.") (* ;;; "ARG2 -- buffers : {VMEMPAGEP} or list of {VMEMPAGEP}. ") (* ; "Write out the buffers to the backing file.") (for buffer inside buffers as streamPageNumber from streamFirstPage bind (fileID _ (fetch (UFSSTREAM FILEID) of stream)) lastStreamPage offset ERRNO first (\UPDATEOF stream) (SETQ lastStreamPage (PLUS (fetch (STREAM EPAGE) of stream) (if (EQ 0 (fetch (STREAM EOFFSET) of stream)) then -1 else 0))) (SETQ ERRNO (CREATECELL \FIXP)) sum (if (LEQ streamPageNumber lastStreamPage) then (OR (\UFSReadPages-C fileID streamPageNumber buffer ERRNO) (\UFSError stream ERRNO) (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE stream)) (if (EQ streamPageNumber lastStreamPage) then (SETQ offset (fetch (STREAM EOFFSET) of stream)) (if (EQ offset 0) then (SETQ offset BYTESPERPAGE) else (\CLEARBYTES buffer offset (- BYTESPERPAGE offset))) offset else BYTESPERPAGE) else (\CLEARWORDS buffer WORDSPERPAGE) 0))) ) + +(\UFSWritePages (LAMBDA (stream streamFirstPage buffers) (* ; "Edited 3-Mar-89 14:50 by bvm") (* ;;; "ARG0 -- stream : {stream} data type. ") (* ;;; "ARG1 -- streamFirstPage : the 1st page number of file to write. ") (* ;;; "ARG2 -- buffers : {VMEMPAGEP} or list of {VMEMPAGEP}.") (LET ((CSIZE (IPLUS (ITIMES (fetch (STREAM CPAGE) of stream) (fetch (STREAM CBUFMAXSIZE) of stream)) (fetch (STREAM COFFSET) of stream))) (ESIZE (IPLUS (ITIMES (fetch (STREAM EPAGE) of stream) (fetch (STREAM CBUFMAXSIZE) of stream)) (fetch (STREAM EOFFSET) of stream))) REALPAGE REALOFFSET (ERRNO (CREATECELL \FIXP))) (if (IGREATERP ESIZE CSIZE) then (SETQ REALPAGE (fetch (STREAM EPAGE) of stream)) (SETQ REALOFFSET (fetch (STREAM EOFFSET) of stream)) else (SETQ REALPAGE (fetch (STREAM CPAGE) of stream)) (SETQ REALOFFSET (fetch (STREAM COFFSET) of stream))) (for buffer inside buffers as PageNumber from streamFirstPage bind (fileID _ (fetch (UFSSTREAM FILEID) of stream)) size do (SETQ size (COND ((EQ PageNumber REALPAGE) REALOFFSET) (T (fetch (STREAM CBUFMAXSIZE) of stream)))) (OR (\UFSWritePages-C fileID PageNumber buffer size ERRNO) (\UFSError stream ERRNO) (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE stream))))) ) + +(\UFSTruncateFile (LAMBDA (STREAM PAGE# OFFSET) (* ; "Edited 22-Aug-90 16:46 by nm") (* ;;; "Used to shorten or lengthen STREAM. If lengthening, pad the file with nulls. Used by SETEOFPTR and FORCEOUTPUT.") (\UPDATEOF STREAM) (OR (FIXP PAGE#) (SETQ PAGE# (fetch (STREAM EPAGE) of STREAM))) (OR (FIXP OFFSET) (SETQ OFFSET (fetch (STREAM EOFFSET) of STREAM))) (* ; "Truncate size was set to PAGE# and OFFSET") (PROG ((curEof (+ (UNFOLD (fetch (STREAM EPAGE) of STREAM) BYTESPERPAGE) (fetch (STREAM EOFFSET) of STREAM))) (needSize (+ (UNFOLD PAGE# BYTESPERPAGE) OFFSET)) (ERRNO (CREATECELL \FIXP))) (if (> needSize curEof) then (* ; "Push 0 to extend file.") (LET ((FILEPTR (\GETFILEPTR STREAM))) (\SETFILEPTR STREAM curEof) (to (- needSize curEof) do (\BOUT STREAM 0)) (\SETFILEPTR STREAM FILEPTR)) elseif T then (* ; "Call c to shorten file. It would be good if we kept track of the file's eof, so that we wouldn't have to do this on closef when nothing had changed") (OR (\UFSGetSize-C (fetch (UFSSTREAM FILEID) of STREAM) needSize ERRNO) (RETURN (\UFSError STREAM ERRNO))) else (RETURN)) (* ;; "Set new value to stream") (replace (STREAM EPAGE) of STREAM with PAGE#) (replace (STREAM EOFFSET) of STREAM with OFFSET) (LET ((DT (CREATECELL \FIXP))) (* ;; "Set new validation value. UNIX mtime is updated, so Lisp stream validation must be updated.") (if (\UFSGetFileInfo-C (fetch (UFSSTREAM UNIXNAME) of STREAM) ATTR-WDATE DT ERRNO) then (replace (STREAM VALIDATION) of STREAM with DT))))) ) + +(\UFSDirectoryNameP (LAMBDA (DIRSPEC DEV) (* ; "Edited 21-Sep-92 15:27 by jds") (* ;;; " DIRECTORYNAMEP FDEV method. Performs a recognition as well and returns the %"true%" name if it exists.") (LET ((DIRECTORY (CONCAT (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DEVICE)) "") (OR (UNPACKFILENAME.STRING DIRSPEC (QUOTE DIRECTORY) (QUOTE RETURN)) (\UFS.HANDLE.RELATIVEDIRECTORY (UNPACKFILENAME.STRING DIRSPEC (QUOTE RELATIVEDIRECTORY) (QUOTE RETURN)) DEV) (\UFS.DEFAULT.DIR DEV)))) NAMEAREA LEN) (* ;; " HOST field of DIRSPEC has been defaulted by the generic file system code. Thus we don't have to worry about the subdirectory case.") (COND (DIRECTORY (SETQ NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) (* ; "NAMEAREA will be modified by C code and hold the %"true%" name of DIRECTORY if DIRECTORY is recognized as a valid directory name.") (SETQ LEN (\UFS.DIRECTORY.NAME DIRECTORY NAMEAREA DEV)) (COND ((FIXP LEN) (* ; "LEN holds the length of the %"true%" name of DIRECTORY.") (\UFS.FULLNAME (SUBSTRING NAMEAREA 1 LEN) DEV NIL)) (T NIL))) (T NIL)))) ) + +(\UFSEventFn (LAMBDA (Dev Event) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 3-May-90 17:35 by nm") (WITH.MONITOR \UFStopMonitor (SELECTQ Event ((AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM) (\UFSCloseDevice) (SELECTQ (MACHINETYPE) ((MAIKO) (\UFSOpenDevice) (* ;; "revalidate open streams (should probably move this into the SELECTQ above) ") (\UNVISIBLE.PAGED.REVALIDATEFILELST Dev) (\PAGED.REVALIDATEFILELST Dev) (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL)))) (CLRHASH \UFS.GFS.TABLE)) NIL)) ((BEFORELOGOUT) (\UNVISIBLE.FLUSH.OPEN.STREAMS Dev) (* ; "flush output buffers.") (\FLUSH.OPEN.STREAMS Dev)) NIL))) ) + +(\UFSGetFileInfo (LAMBDA (STREAM ATTRIBUTE DEVICE) (* ; "Edited 30-Mar-90 12:27 by nm") (* ;;; "Get the value of the attribute for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTHOR, the type of the buffer is STRING.") (* ;;; "Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE) (if FILENAME then (SELECTQ ATTRIBUTE (LENGTH (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (SIZE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-LENGTH BUFFER ERRNO) then (FOLDHI BUFFER BYTESPERPAGE) else (\UFSError FILENAME ERRNO DEVICE))) (TYPE (\UFSGetFileType FILENAME)) ((CREATIONDATE WRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) (READDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then (GDATE BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) ((ICREATIONDATE IWRITEDATE) (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-WDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (IREADDATE (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-RDATE BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (AUTHOR (SETQ BUFFER (ALLOCSTRING MAX-UNAME-LEN)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-AUTHOR BUFFER ERRNO)) then (CL:SUBSEQ BUFFER 0 NAMESIZE) else (\UFSError FILENAME ERRNO DEVICE))) (PROTECTION (SETQ BUFFER (CREATECELL \FIXP)) (if (\UFSGetFileInfo-C FILENAME ATTR-PROTECTION BUFFER ERRNO) then BUFFER else (\UFSError FILENAME ERRNO DEVICE))) (ALL (SETQ BUFFER (\UFS.CREATE.PROPS)) (if (SETQ NAMESIZE (\UFSGetFileInfo-C FILENAME ATTR-ALL BUFFER ERRNO)) then (LET ((ALIST (ASSOC (QUOTE AUTHOR) BUFFER))) (* ; "Copy string out of buffer") (RPLACD ALIST (CL:SUBSEQ (CDR ALIST) 0 NAMESIZE)) BUFFER) else (\UFSError FILENAME ERRNO DEVICE))) NIL))))) ) + +(\UFS.CREATE.PROPS (LAMBDA NIL (* ; "Edited 2-Mar-89 12:10 by bvm") (* ;; "Returns a data structure suitable for passing to the GetFileInfo ALL routine") (BQUOTE ((LENGTH (\,@ (CREATECELL \FIXP))) (WDATE (\,@ (CREATECELL \FIXP))) (RDATE (\,@ (CREATECELL \FIXP))) (PROTECTION (\,@ (CREATECELL \FIXP))) (AUTHOR (\,@ (ALLOCSTRING MAX-UNAME-LEN)))))) ) + +(\UFSSetFileInfo (LAMBDA (STREAM ATTRIBUTE VALUE DEVICE) (* ; "Edited 30-Mar-90 12:31 by nm") (* ;;; "Get the VALUE of the ATTRIBUTE for a file.") (* ;;; "Allocate buffer to store the value.") (* ;;; "If attribute is AUTOR, the type of the buffer is STRING.") (* ;;; " Otherwise the type of the buffer is FIXP.") (WITH.MONITOR (\UFSGetMonitor DEVICE) (LET ((FILENAME (if (type? STREAM STREAM) then (fetch (UFSSTREAM UNIXNAME) of STREAM) else (\UFS.FULLNAME (\UFS.RECOGNIZE.FILE STREAM (QUOTE OLD) DEVICE) DEVICE NIL))) (ERRNO (CREATECELL \FIXP)) BUFFER NAMESIZE PATHNAME) (if FILENAME then (SELECTQ ATTRIBUTE (TYPE (\UFSSetFileType FILENAME VALUE)) ((CREATIONDATE WRITEDATE) (if (AND (STRINGP VALUE) (SETQ VALUE (IDATE VALUE))) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) ((ICREATIONDATE IWRITEDATE) (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-WDATE VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) (PROTECTION (if (FIXP VALUE) then (OR (\UFSSetFileInfo-C FILENAME ATTR-PROTECTION VALUE ERRNO) (\UFSError FILENAME ERRNO DEVICE)) else (ERROR "Invalid argument" VALUE))) NIL))))) ) + +(\UFSGenerateFiles (LAMBDA (FDEV PATTERN DESIREDPROPS OPTIONS) (* ; "Edited 27-Sep-93 16:17 by jds") (* ;;; "Returns a file-generator object that will generate exactly those files in the sys-dir of FDEV whose names match PATTERN.") (WITH.MONITOR (\UFSGetMonitor FDEV) (PROG* ((PARSED (UNPACKFILENAME.STRING PATTERN)) (DIRECTORY (OR (LISTGET PARSED (QUOTE DIRECTORY)) (\UFS.HANDLE.RELATIVEDIRECTORY (LISTGET PARSED (QUOTE RELATIVEDIRECTORY)) FDEV) (\UFS.DEFAULT.DIR FDEV))) (DEVICE (LISTGET PARSED (QUOTE DEVICE))) (NAMEAREA (ALLOCSTRING MAX-PATHNAME-LEN)) FILTER LEN) (COND ((STREQUAL DIRECTORY "/") (SETQ DIRECTORY "<"))) (SETQ FILTER (COND ((STREQUAL DIRECTORY "<") (CONCAT "{" (LISTGET PARSED (QUOTE HOST)) "}" (OR DEVICE "") "<" (PACKFILENAME.STRING (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*")))) (T (PACKFILENAME.STRING (QUOTE DIRECTORY) DIRECTORY (QUOTE HOST) (LISTGET PARSED (QUOTE HOST)) (QUOTE DEVICE) DEVICE (QUOTE NAME) (OR (LISTGET PARSED (QUOTE NAME)) "*") (QUOTE EXTENSION) (OR (LISTGET PARSED (QUOTE EXTENSION)) "*") (QUOTE VERSION) (OR (LISTGET PARSED (QUOTE VERSION)) "*"))))) (SETQ LEN (\UFS.DIRECTORY.NAME (CONCAT (OR DEVICE "") DIRECTORY) NAMEAREA FDEV)) (COND ((NOT (FIXP LEN)) (* ; "No such directory. We go thru this recognition step so that \UFSFindFile gives us name in the correct case") (PRINTOUT PROMPTWINDOW T "Can't enumerate " PATTERN " because no such directory") (RETURN (\NULLFILEGENERATOR)))) (SETQ DIRECTORY (SUBSTRING NAMEAREA 1 LEN)) (* ;; "The information about enumerated files are cached in the emulator. We receive the ID and the total number of enumerated files. The ID is used to identify the object corresponding to the enumerated file.") (LET ((ID (CREATECELL \FIXP)) (ERRNO (CREATECELL \FIXP)) (PROPP (\UFS.VALID.PROPP DESIREDPROPS)) TOTALNUM) (SETQ TOTALNUM (\UFSReadDir-C FILTER PROPP ID ERRNO)) (COND ((< TOTALNUM 0) (OR (\UFSError DIRECTORY ERRNO FDEV) (RETURN (\NULLFILEGENERATOR)))) (T (COND ((ZEROP TOTALNUM) (RETURN (\NULLFILEGENERATOR))) (T (AND (OR (AND (NOT (LISTP OPTIONS)) (EQ OPTIONS (QUOTE RESETLST))) (FMEMB (QUOTE RESETLST) OPTIONS)) (RESETSAVE NIL (QUOTE (AND RESETSTATE (\UFSFinishFileInfo-C ID))))) (RETURN (create FILEGENOBJ NEXTFILEFN _ (FUNCTION \UFS.NEXTFILEFN) FILEINFOFN _ (FUNCTION \UFS.FILEINFOFN) GENFILESTATE _ (\UFS.REGISTER.GFS (create UFSGENFILESTATE FINFOID _ ID FILEID _ 0 TOTALNUM _ TOTALNUM DIRECTORY _ DIRECTORY DEV _ FDEV PROPP _ PROPP NAME _ (ALLOCSTRING MAX-PATHNAME-LEN) AUTHOR _ (AND PROPP (ALLOCSTRING MAX-UNAME-LEN)) CURRENT-DEPTH _ 1 MAX-DEPTH _ FILING.ENUMERATION.DEPTH)))))))))))) ) + +(\UFS.NEXTFILEFN (LAMBDA (GENFILESTATE NAMEONLY) (* ; "Edited 7-Oct-93 14:31 by jds") (* ;; "Given a UFS filesystem generator, return the %"next%" file in line.") (LET ((SUBGEN (fetch (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE))) (DECLARE (SPECVARS FILEGROUP)) (COND (SUBGEN (* ;; "We're in a sub-directory.") (LET (FILENAME NAMELEN NEWWNAME FILEGROUP) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY))))) (T (* ;; "Not in a sub-directory, so act directly on the top-level generator.") (LET* ((FINFOID (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE)) (FILEID (fetch (UFSGENFILESTATE FILEID) of GENFILESTATE)) (ERRNO (LOCF (fetch (UFSGENFILESTATE ERRONO) of GENFILESTATE))) FILENAME NAMELEN NEWNAME SUBGEN FILEGROUP (DEFAULTEXT (QUOTE *)) (DEFAULTVERS (QUOTE *)) (DESIREDPROPS (COND ((fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (QUOTE (SIZE CREATIONDATE AUTHOR))) (T NIL)))) (DECLARE (SPECVARS FILEGROUP DEFAULTEXT DESIREDPROPS DEFAULTVERS)) (AND (> FINFOID -1) (< FILEID (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (CL:UNWIND-PROTECT (COND ((> (SETQ NAMELEN (\UFSNextFile-C GENFILESTATE)) 0) (replace (UFSGENFILESTATE THISFILE) of GENFILESTATE with (SETQ FILENAME (\UFS.FULLNAME.M (fetch (UFSGENFILESTATE DIRECTORY) of GENFILESTATE) (SETQ NEWNAME (CL:SUBSEQ (fetch (UFSGENFILESTATE NAME) of GENFILESTATE) 0 NAMELEN)) (fetch (UFSGENFILESTATE DEV) of GENFILESTATE)))) (COND ((= (add FILEID 1) (fetch (UFSGENFILESTATE TOTALNUM) of GENFILESTATE)) (* ; "Generator exhausted. ") (\UFS.UNREGISTER.GFS GENFILESTATE T)) (T (replace (UFSGENFILESTATE FILEID) of GENFILESTATE with FILEID))) (COND ((AND FILENAME (OR (EQ (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE) T) (ILESSP (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE) (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE))) (IEQP (CHARCODE >) (NTHCHARCODE FILENAME (NCHARS FILENAME))) (DIRECTORY.PARSE (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP))) (* ;; "It's a directory, so let's recurse into it.") (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with (SETQ SUBGEN (fetch (FILEGENOBJ GENFILESTATE) of (CAR FILEGROUP)))) (replace (UFSGENFILESTATE CURRENT-DEPTH) of SUBGEN with (ADD1 (fetch (UFSGENFILESTATE CURRENT-DEPTH) of GENFILESTATE))) (replace (UFSGENFILESTATE MAX-DEPTH) of SUBGEN with (fetch (UFSGENFILESTATE MAX-DEPTH) of GENFILESTATE)) (SETQ FILENAME (\UFS.NEXTFILEFN SUBGEN NAMEONLY)) (COND (FILENAME (CL:WHEN (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (replace (UFSGENFILESTATE LENGTH) of GENFILESTATE with (fetch (UFSGENFILESTATE LENGTH) of SUBGEN)) (replace (UFSGENFILESTATE RDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE RDATE) of SUBGEN)) (replace (UFSGENFILESTATE WDATE) of GENFILESTATE with (fetch (UFSGENFILESTATE WDATE) of SUBGEN)) (replace (UFSGENFILESTATE PROTECTION) of GENFILESTATE with (fetch (UFSGENFILESTATE PROTECTION) of SUBGEN)) (replace (UFSGENFILESTATE AULEN) of GENFILESTATE with (fetch (UFSGENFILESTATE AULEN) of SUBGEN)) (replace (UFSGENFILESTATE AUTHOR) of GENFILESTATE with (fetch (UFSGENFILESTATE AUTHOR) of SUBGEN))) FILENAME) (NIL T (replace (UFSGENFILESTATE SUBGENERATORS) of GENFILESTATE with NIL) (\UFS.NEXTFILEFN GENFILESTATE NAMEONLY)))) (T (COND (NAMEONLY NEWNAME) (T FILENAME)))))) (AND RESETSTATE (\UFS.UNREGISTER.GFS GENFILESTATE T))))))))) ) + +(\UFS.FILEINFOFN (LAMBDA (GENFILESTATE ATTRIBUTE) (* ; "Edited 7-May-90 23:21 by nm") (* ;;; "FILEINFOFN for UFS--return the value of the specified ATTRIBUTE. ALLPROPS is fetched when a file is generated if GENERATEFILES method is invoked with some valid PROPs when the generator is created. ALLPROPS strucure is re-used. We have to be careful to COPY the values that come out.") (AND (fetch (UFSGENFILESTATE PROPP) of GENFILESTATE) (CL:UNWIND-PROTECT (if (EQ ATTRIBUTE (QUOTE TYPE)) then (\UFSGetFileType (fetch (UFSGENFILESTATE THISFILE) of GENFILESTATE)) else (BLOCK) (SELECTQ ATTRIBUTE (LENGTH (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE))) (PROTECTION (* ; "Copy numeric value") (+ 0 (fetch (UFSGENFILESTATE PROTECTION) of GENFILESTATE))) (SIZE (FOLDHI (fetch (UFSGENFILESTATE LENGTH) of GENFILESTATE) BYTESPERPAGE)) ((CREATIONDATE WRITEDATE) (GDATE (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (READDATE (GDATE (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) ((ICREATIONDATE IWRITEDATE) (+ 0 (fetch (UFSGENFILESTATE WDATE) of GENFILESTATE))) (IREADDATE (+ 0 (fetch (UFSGENFILESTATE RDATE) of GENFILESTATE))) (AUTHOR (* ; "Copy the string out of the buffer") (CL:SUBSEQ (fetch (UFSGENFILESTATE AUTHOR) of GENFILESTATE) 0 (fetch (UFSGENFILESTATE AULEN) of GENFILESTATE))) NIL)) (AND RESETSTATE (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (\UFS.UNREGISTER.GFS GENFILESTATE T))))) ) + +(\UFS.VALID.PROPP (LAMBDA (DESIREDPROPS) (* ; "Edited 3-May-90 14:43 by nm") (AND (SOME (OR (LISTP DESIREDPROPS) (LIST DESIREDPROPS)) (FUNCTION (LAMBDA (PROP) (FMEMB PROP (QUOTE (LENGTH PROTECTION SIZE CREATIONDATE WRITEDATE READDATE ICREATIONDATE IWRITEDATE IREADDATE AUTHOR)))))) T)) ) + +(\UFS.REGISTER.GFS (LAMBDA (GENFILESTATE) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 4-May-90 16:18 by nm") (UNINTERRUPTABLY (AND (> (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE) -1) (PUTHASH GENFILESTATE GENFILESTATE \UFS.GFS.TABLE)))) ) + +(\UFS.UNREGISTER.GFS (LAMBDA (GENFILESTATE NOTICETOCP) (DECLARE (GLOBALVARS \UFS.GFS.TABLE)) (* ; "Edited 4-May-90 16:10 by nm") (* ;; "Make GENFILESTATE, FILEGENOBJ, invalid. If NOTICETOCP, notice to C code to abandon the cached information.") (UNINTERRUPTABLY (AND NOTICETOCP (\UFSFinishFileInfo-C (fetch (UFSGENFILESTATE FINFOID) of GENFILESTATE))) (replace (UFSGENFILESTATE FINFOID) of GENFILESTATE with -1) (replace (UFSGENFILESTATE DIRECTORY) of GENFILESTATE with NIL) (replace (UFSGENFILESTATE DEV) of GENFILESTATE with NIL) (PUTHASH GENFILESTATE NIL \UFS.GFS.TABLE))) ) + +(\UFS.ABORT.DIRECTORY (LAMBDA NIL (DECLARE (SPECVARS FILEGROUP)) (* ; "Edited 8-May-90 13:21 by nm") (bind GFS for GEN in (fetch (FILEGROUP FILEGENERATORS) of FILEGROUP) do (SETQ GFS (fetch (FILEGENOBJ GENFILESTATE) of GEN)) (if (AND (type? UFSGENFILESTATE GFS) (> (fetch (UFSGENFILESTATE FINFOID) of GFS) -1) (\UFS.UNREGISTER.GFS GFS T))))) ) + +(\UFS.ABORT.CL-DIRECTORY (LAMBDA NIL (DECLARE (SPECVARS GENERATOR)) (* ; "Edited 8-Jun-90 15:09 by nm") (LET ((GFS (fetch (FILEGENOBJ GENFILESTATE) of GENERATOR))) (if (AND (type? UFSGENFILESTATE GFS) (> (fetch (UFSGENFILESTATE FINFOID) of GFS) -1) (\UFS.UNREGISTER.GFS GFS T))))) ) + +(\UFS.CLEANUP.GFS.TABLE (LAMBDA (NOTICETOCP) (* ; "Edited 8-Jun-90 15:17 by nm") (MAPHASH \UFS.GFS.TABLE (FUNCTION (LAMBDA (VAL KEY) (\UFS.UNREGISTER.GFS VAL NOTICETOCP)))) T) ) +) + + + +(* ; "File Name parsing") + +(DEFINEQ + +(\UFSMakeUnixFormatName (LAMBDA (FILE) (* ; "Edited 20-Sep-89 11:22 by jds") (* ;; "Given a file name in INTERLISP format {host}

subdir...>name.ext;ver,") (* ;; "convert the directory part to unix /dir/subdir/.../ format. . ") (DECLARE (GLOBALVARS \UFSDefaultDelimiter)) (LET* ((OLDFILE (MKSTRING FILE)) (LEN (NCHARS OLDFILE)) (NEWFILE (ALLOCSTRING LEN)) (NEWINDEX -1) (LASTSLASH -2) (SLASHCHAR (CL:CHAR \UFSDefaultDelimiter 0)) C) (* ;; "Change all %">%" and %"<%" to %"/%" and remove duplicate %"/%"s so that we don't misinterpret /foo//bar as being a relative spec (ugh).") (for I from 0 to (SUB1 LEN) do (CASE (SETQ C (CL:CHAR OLDFILE I)) ((#\/ #\> #\<) (* ; "Make this a slash, suppress it if we already had one") (if (> NEWINDEX LASTSLASH) then (CL:SETF (CL:CHAR NEWFILE (SETQ LASTSLASH (add NEWINDEX 1))) SLASHCHAR))) (T (* ; "Just copy it") (CL:SETF (CL:CHAR NEWFILE (add NEWINDEX 1)) C)))) (if (EQ NEWINDEX (SUB1 LEN)) then (* ; "nothing removed") NEWFILE else (SUBSTRING NEWFILE 1 (ADD1 NEWINDEX))))) ) + +(\UFSParseNameString (LAMBDA (FILE) (* ; "Edited 20-Sep-89 11:24 by jds") (* ;; "Like UNPACKFILENAME.STRING, with embellishments. Converts the file name to Unix format first, then unpacks it.") (DECLARE (GLOBALVARS \UFSDefaultDelimiter)) (LET* ((OLDFILE (MKSTRING FILE)) (NEWFILE (\UFSMakeUnixFormatName OLDFILE))) (\UFS.ADJUST.HOST (UNPACKFILENAME.STRING NEWFILE)))) ) + +(\UFSParse-Directory (LAMBDA (PARSE DEV) (* ; "Edited 1-Mar-89 14:45 by bvm") (LET ((DIRECTORY (LISTGET PARSE (QUOTE DIRECTORY)))) (COND (DIRECTORY (if (NEQ (NTHCHAR DIRECTORY -1) \UFSDefaultDelimiterChar) then (* ; "absolute pathname") (CONCAT \UFSDefaultDelimiter DIRECTORY \UFSDefaultDelimiter) elseif (> (NCHARS DIRECTORY) 0) then (* ; "relative pathname") (SELECTQ (NTHCHAR DIRECTORY 1) ((/ ~ %.) DIRECTORY) (CONCAT (\UFS.DEFAULT.DIR DEV) DIRECTORY)) else (* ; "Naked / = top-level dir") DIRECTORY)) (T (\UFS.DEFAULT.DIR DEV))))) ) + +(\UFS.PARSE.BODY (LAMBDA (PARSEDNAME) (* ; "Edited 1-Mar-89 14:24 by bvm") (* ;; "PARSEDNAME Is the output of unpackfilename. Extract the pieces that make up name.ext;version and return them as a single string.") (CONCAT (OR (LISTGET PARSEDNAME (QUOTE NAME)) "") (LET ((TYPE (LISTGET PARSEDNAME (QUOTE EXTENSION)))) (COND ((AND TYPE (> (NCHARS TYPE) 0)) (CONCAT \UFSBeforeType TYPE)) (T ""))) (LET ((VERSION (LISTGET PARSEDNAME (QUOTE VERSION)))) (COND ((AND VERSION (> (NCHARS VERSION) 0)) (CONCAT \UFSBeforeVersion VERSION)) (T ""))))) ) + +(\UFS.ADJUST.HOST (LAMBDA (FIELDS) (* ; "Edited 3-Mar-89 14:42 by bvm") (* ;; "Hook for NFS hack to further modify the parse of a dsk/ufs name") FIELDS) ) + +(\UFS.FULLNAME (LAMBDA (NAME DEV ATOMP) (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) (* ; "Edited 4-May-90 11:07 by nm") (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") (if NAME then (* ; "Pass NIL thru transparently") (if (DSKP DEV) then (SETQ NAME (CONCAT *DSK-HOST-NAME* NAME)) (if *DSK-UPPER-CASE-FILE-NAMES* then (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") (if ATOMP then (MKATOM (U-CASE NAME)) else (U-CASE NAME)) else (if ATOMP then (MKATOM NAME) else NAME)) else (SETQ NAME (CONCAT *UFS-HOST-NAME* NAME)) (if ATOMP then (MKATOM NAME) else NAME)))) ) + +(\UFS.ADD.HOST.FIELD (LAMBDA (NAME DEV) (* ; "Edited 30-Mar-90 10:26 by nm") (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is different from \UFS.FULLNAME at the point it refers *DSK-UPPER-CASE-FILE-NAMES* .") (if NAME then (SETQ NAME (CONCAT "{" (fetch (FDEV DEVICENAME) of DEV) "}" NAME)))) ) + +(\UFS.REMOVE.HOST.FIELD (LAMBDA (FILE DEV) (* ; "Edited 10-Sep-92 15:52 by jds") (* ;; "Accepts a full file representation, and returns the file representaion as a string in which HOST field is removed.") (LET* ((PARSE-LIST (UNPACKFILENAME.STRING FILE)) (RELATIVEDIRECTORY (MEMB (QUOTE RELATIVEDIRECTORY) PARSE-LIST)) (DIRECTORY (LISTGET PARSE-LIST (QUOTE DIRECTORY))) PACKED-NAME VERSION DEVICE) (if (DSKP DEV) then (* ;; " Check if FILE contains the valid version field or not so that C code can assume that all file names are valid.") (AND (SETQ VERSION (LISTGET PARSE-LIST (QUOTE VERSION))) (if (STREQUAL VERSION "") then (* ;; "Newest version is specifed. Just removes it.") (LISTPUT PARSE-LIST (QUOTE VERSION) NIL) else (OR (FIXP (MKATOM VERSION)) (CL:ERROR (QUOTE XCL:INVALID-PATHNAME) :PATHNAME FILE))))) (if RELATIVEDIRECTORY then (RPLACA (CDR RELATIVEDIRECTORY) (\UFS.HANDLE.RELATIVEDIRECTORY (CADR RELATIVEDIRECTORY) DEV)) elseif (NOT DIRECTORY) then (LISTPUT PARSE-LIST (QUOTE DIRECTORY) (\UFS.DEFAULT.DIR DEV))) (LISTPUT PARSE-LIST (QUOTE HOST) NIL) (SETQ DEVICE (LISTGET PARSE-LIST (QUOTE DEVICE))) (LISTPUT PARSE-LIST (QUOTE DEVICE) NIL) (SETQ PACKED-NAME (PACKFILENAME.STRING PARSE-LIST)) (* ;; "Trim off the leading <, unless this is a file on the root directory.") (SETQ PACKED-NAME (if (STREQUAL (LISTGET PARSE-LIST (QUOTE DIRECTORY)) "<") then (if (LISTGET PARSE-LIST (QUOTE NAME)) then (SUBSTRING PACKED-NAME 2) else "<") else (if (EQ (NTHCHARCODE PACKED-NAME 1) (CHARCODE <)) then (SUBSTRING PACKED-NAME 2) else PACKED-NAME))) (* ;; "Add back the device spec, if there is one:") (COND (DEVICE (CONCAT DEVICE PACKED-NAME)) (T PACKED-NAME)))) ) + +(\UFS.HANDLE.RELATIVEDIRECTORY (LAMBDA (DIR DEV) (* ; "Edited 22-Mar-90 11:42 by nm") (* ;;; "DIR is a relative directory. Reformats it to the form which the C subr code can accept. Only case we have to worry about is that no meta characters (i.e. %".%", %"..%", %"~%") is used. In this case, we have to attach the default meta character according to the device.") (if DIR then (COND ((SELCHARQ (NTHCHARCODE DIR 1) (%. (* ;; "%".%" or %"..%" or %".>%" or %"./%" or %"..>%" or %"../%"") (OR (NCHARS DIR 1) (AND (NCHARS DIR 2) (EQMEMB (NTHCHARCODE DIR 2) (CHARCODE (%. > /)))) (AND (NCHARS DIR 3) (EQ (NTHCHAR DIR 2) (QUOTE %.)) (EQMEMB (NTHCHARCODE DIR 3) (CHARCODE (> /)))))) (~ (* ;; "%"~>%" or %"~username%" ") T) NIL) DIR) (T (CONCAT (\UFS.DEFAULT.DIR DEV) DIR))))) ) +) + +(RPAQ? \UFSDefaultDelimiter "/") + +(RPAQ? \UFSDefaultDelimiterChar '/) + +(RPAQ? \UFSDefaultConnDir "./") + +(RPAQ? \UFSBeforeType '%.) + +(RPAQ? \UFSBeforeVersion ';) + +(RPAQ? \UFSDeviceDelimiter '}) + +(RPAQ? \DSK.DEFAULT.DIRECTORY "~>") + +(RPAQ? \UFS.DEFAULT.DIRECTORY ".>") + +(RPAQ? *DSK-UPPER-CASE-FILE-NAMES* NIL) + +(RPAQ? \UFS.GFS.TABLE (HASHARRAY 20)) + +(RPAQ? *DSK-HOST-NAME* "{DSK}") + +(RPAQ? *UFS-HOST-NAME* "{UNIX}") +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \UFSDeviceDelimiter \UFSBeforeVersion \UFSBeforeType \UFSDefaultConnDir + \UFSDefaultDelimiterChar \UFSDefaultDelimiter \DSK.DEFAULT.DIRECTORY \UFS.DEFAULT.DIRECTORY + *DSK-UPPER-CASE-FILE-NAMES* \UFS.GFS.TABLE *DSK-HOST-NAME* *UFS-HOST-NAME*) +) + + + +(* ;; "Change UNIX Curent Directory") + +(DEFINEQ + +(CHDIR (LAMBDA (PATHNAME) (* ; "Edited 2-Apr-90 01:07 by nm") (* ;;; "(\CALL-C SUBR-UFS-DIRECTORYNAMEP ..) returns T(=1) or NIL.") (WITH.MONITOR \UFStopMonitor (LET ((PATH (\ADD.CONNECTED.DIR PATHNAME)) HOST) (if PATH then (SETQ HOST (U-CASE (FILENAMEFIELD PATH (QUOTE HOST)))) (if (OR (EQ HOST (QUOTE DSK)) (EQ HOST (QUOTE UNIX))) then (if (SETQ PATH (DIRECTORYNAME PATH)) then (if (\UFSCHDIR-C PATH) then (DIRECTORYNAME PATH) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME)) else (ERROR "Bad Host Name" HOST)) else (ERROR "NO-SUCH-DIRECTORY" PATHNAME))))) ) +) + + + +(* ;; "To access UNIX special files by like {UNIX}/dev/ttya.") + +(DEFINEQ + +(\DEVICEFILE.EOSERROR (LAMBDA (STREAM) (* ; "Edited 3-Mar-89 15:06 by bvm") (SELECTQ (fetch (STREAM ACCESS) of STREAM) (OUTPUT (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T)) (INPUT (PROG (BUF VMEMBUF DATASIZE) (OR (SETQ BUF (fetch (STREAM BUFFS) of STREAM)) (replace (STREAM BUFFS) of STREAM with (SETQ BUF (\GETMAPBUFFER)))) (SETQ VMEMBUF (fetch (BUFFER VMEMPAGE) of BUF)) (until (SETQ DATASIZE (\UFSReadPages-C (fetch (UFSSTREAM FILEID) of STREAM) 0 VMEMBUF)) do (BLOCK)) (if (EQ DATASIZE 0) then (LISPERROR "END OF FILE" (fetch (STREAM FULLNAME) of STREAM) T) (RETURN NIL)) (UNINTERRUPTABLY (replace (BUFFER FILEPAGE#) of BUF with 0) (replace (BUFFER BUFFERNEXT) of BUF with NIL) (replace (BUFFER SYSNEXT) of BUF with NIL) (replace (STREAM CBUFSIZE) of STREAM with DATASIZE) (replace (STREAM EOFFSET) of STREAM with DATASIZE) (replace (STREAM COFFSET) of STREAM with 0) (replace (STREAM CBUFPTR) of STREAM with VMEMBUF)) (RETURN T))) (SHOULDNT))) ) +) + + + +(* ;; "flush/revalidate unvisible stream, like dribble files.") + +(DEFINEQ + +(\UNVISIBLE.PAGED.REVALIDATEFILELST (LAMBDA (DEVICE) (* ; "Edited 3-Mar-89 15:33 by bvm") (* ;;; "This function is writen based on \PAGED.REVALIDATEFILELST") (* ;;; "Revalidate unvisible open files on DEVICE (a PMAP device)") (bind REASON PAGES for STREAM in (fetch (FDEV OPENFILELST) of DEVICE) when (NULL (fetch (STREAM USERVISIBLE) of STREAM)) do (if (SETQ REASON (\PAGED.REVALIDATEFILE STREAM)) then (SELECTQ REASON (CHANGED (* ; "it changed % +% +update the map") (SETQ PAGES (RESTOREMAP STREAM))) (DELETED (* ; "the file disappeared, so zap the stream") (SETQ PAGES (FORGETPAGES STREAM)) (MAPC (STREAMPROP STREAM (QUOTE AFTERCLOSE)) (FUNCTION (LAMBDA (FN) (APPLY* FN STREAM)))) (replace (STREAM ACCESS) of STREAM with NIL) (FDEVOP (QUOTE UNREGISTERFILE) DEVICE DEVICE STREAM)) (SHOULDNT)) (\PRINT-REVALIDATION-RESULT REASON STREAM)))) ) + +(\UNVISIBLE.FLUSH.OPEN.STREAMS (LAMBDA (FDEV) (* ; "Edited 20-Dec-88 10:20 by Hayata") (* ;;; "This function is writen based on \FLUSH.OPEN.STREAMS") (* ;;; "flush unvisible open streams") (for STREAM in (fetch (FDEV OPENFILELST) of FDEV) bind STREAM when (AND (NULL (fetch (STREAM USERVISIBLE) of STREAM)) (DIRTYABLE STREAM)) do (FDEVOP (QUOTE FORCEOUTPUT) FDEV STREAM))) ) +) + + + +(* ;; " Error handler") + +(DEFINEQ + +(\UFSError (LAMBDA (PATHNAME ERRNO DEV) (* ; "Edited 14-Dec-94 16:46 by jds") (* ;; "If DEV is supplied, we combine it with PATHNAME to get a real name.") (* ;; "Note that codes not explicitly listed here do not signal an error (!!). This may be reasonable for code zero (file not found), but others???") (PROG ((NO (IPLUS ERRNO 0))) (* ;; "errno is fixp cell, changed into a SMALLP using IPLUS, and residing in NO.") (COND (DEV (SETQ PATHNAME (\UFS.FULLNAME PATHNAME DEV)))) (SELECTQ NO (1 (ERROR "Not owner" PATHNAME)) (5 (* ; "I/O error") (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE PATHNAME)) (13 (* ; "Permission denied") (CL:ERROR (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME PATHNAME)) (21 (ERROR "Is a directory" PATHNAME)) (23 (* ; "File table overflow") (CL:ERROR (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME PATHNAME)) (24 (* ; "LISPERROR 15 is no longer supported (LISPERROR %"TOO MANY FILES OPEN%" |pathname|)") (ERROR "TOO MANY FILES OPEN" PATHNAME)) (27 (ERROR "File too large" PATHNAME)) (28 (* ; "No space left on device") (CL:ERROR (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME PATHNAME)) (29 (* ; "Illegal seek") (CL:ERROR (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE PATHNAME)) (30 (* ; "Read only file system") (CL:ERROR (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME PATHNAME)) (60 (* ; "Connect request or NFS request failed") (ERROR "Connection timed out" PATHNAME)) (62 (* ; "Too many levels of symbolic link (usually a loop of links)") (ERROR "Too many levels of symbolic link in" PATHNAME)) (66 (ERROR "Directory not empty" PATHNAME)) (100 (ERROR "Connection timed out" PATHNAME)) NIL))) ) +) + + + +(* ; "File Type and EOL handling") + +(DEFINEQ + +(\UFSGetFileType (LAMBDA (FILENAME) (* ; "Edited 19-May-91 11:18 by jds") (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (MKATOM (U-CASE (COND ((AND (EQ (NCHARS TYPE) 0) (* ; "Handle null extension specially") (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T DEFAULTFILETYPE))))) (* ; "(SELECTQ TYPE ((TEXT BINARY) TYPE) (CL:ERROR %"Invalid File Type ~A for ~A%" TYPE FILENAME))") (* ;; "TYPE used to be constraied to be TEXT or BINARY, which caused some older user code to tail. AR 11373") TYPE)) ) + +(\UFSSetFileType (LAMBDA (FILENAME TYPE) (* ; "Edited 6-Jun-88 13:48 by HH") (LET ((EXTENSION (MKATOM (U-CASE (LISTGET (\UFSParseNameString FILENAME) (QUOTE EXTENSION)))))) (SETQ TYPE (MKATOM (U-CASE TYPE))) (for PAIR in DEFAULTFILETYPELIST bind PAIR finally (RETURN (EQ TYPE (MKATOM (U-CASE DEFAULTFILETYPE)))) do (if (EQUAL EXTENSION (MKATOM (U-CASE (CAR PAIR)))) then (RETURN (EQ TYPE (MKATOM (U-CASE (CDR PAIR))))))))) ) + +(\UFSeol (LAMBDA (FILENAME TYPE RECOG) (* ; "Edited 27-Feb-89 16:21 by bvm") (if (AND (SETQ TYPE (SELECTQ (CADR TYPE) (TEXT (QUOTE TEXT)) (NIL NIL) (PROGN (* ; "Anything else reduces to binary") (QUOTE BINARY)))) (EQ RECOG (QUOTE NEW)) (NEQ TYPE (\UFSGetFileType FILENAME))) then (* ; "Warn user that TYPE will not be properly inferred when we next read this file") (PRINTOUT PROMPTWINDOW T "Warning: creating " TYPE " file, but name '" (\UFS.PARSE.BODY (\UFSParseNameString FILENAME)) "' does not have a " TYPE " extension.")) (SELECTQ (OR TYPE (\UFSGetFileType FILENAME)) (TEXT LF.EOLC) (PROGN (* ; "BINARY or unknown") CR.EOLC))) ) +) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(RPAQQ DEFAULTFILETYPE BINARY) + +(RPAQQ DEFAULTFILETYPELIST ((NIL . BINARY) + (C . TEXT) + (H . TEXT) + (EL . TEXT) + (IM . TEXT) + (LISP . TEXT) + (LSP . TEXT) + (O . BINARY) + (OUT . BINARY) + (LCOM . BINARY) + (DFASL . BINARY) + (DCOM . BINARY) + (SKETCH . BINARY) + (TEDIT . BINARY) + (TED . BINARY) + (DISPLAYFONT . BINARY) + (AC . BINARY) + (WD . BINARY) + (IP . BINARY) + (INTERPRESS . BINARY) + (PRESS . BINARY) + (PSCFONT . BINARY) + (RST . BINARY) + (BIN . BINARY) + (MAIL . BINARY) + (SYSOUT . BINARY) + (SYSOUT.Z . BINARY) + (TAR . BINARY) + (INDEX . BINARY) + (HASH . BINARY) + (NOTEFILE . BINARY) + (Z . BINARY) + (VIRTUALMEM . BINARY) + (VM . BINARY))) +) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DEFAULTFILETYPE DEFAULTFILETYPELIST) +) +(DECLARE%: EVAL@COMPILE DONTCOPY + +(RPAQQ UFSDECLS ((MACROS \UFS.FULLNAME.M \UFSGetMonitor \UFS.DEFAULT.DIR \UFS.FILE.RECOGNIZER + \UFS.DIRECTORY.RECOGNIZER DSKP) + (RECORDS UFSSTREAM NAME&ALLPROPS) + + (* ;; "File attribute code. For interface between Cfunc and LISPfunc.") + + (CONSTANTS (ATTR-LENGTH 1) + (ATTR-WDATE 2) + (ATTR-RDATE 3) + (ATTR-CDATE 4) + (ATTR-AUTHOR 5) + (ATTR-PROTECTION 6) + (ATTR-EOL 7) + (ATTR-ALL 8)) + + (* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") + + (CONSTANTS (RECOG-OLD 0) + (RECOG-OLDEST 1) + (RECOG-NEW 2) + (RECOG-NEW-OLD 3) + (RECOG-OTHER 4) + (RECOG-NON 5)) + + (* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") + + (CONSTANTS (ACCESS-INPUT 0) + (ACCESS-OUTPUT 1) + (ACCESS-BOTH 2) + (ACCESS-APPEND 3) + (ACCESS-OTHER 4)) + + (* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") + + (CONSTANTS (MAX-UNAME-LEN 512)) + + (* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") + + (CONSTANTS (MAX-PATHNAME-LEN 256)) + (FILES (LOADCOMP) + PMAP) + (* ; "For \devicefile.eoserror"))) +(DECLARE%: EVAL@COMPILE + +[PUTPROPS \UFS.FULLNAME.M MACRO (LAMBDA (DIR NAME DEV ATOMP) + (DECLARE (GLOBALVARS *DSK-HOST-NAME* *UFS-HOST-NAME*)) + + (* ;; "NAME is a name string returned from UNIX. We turn it into a Lisp %"full file name%". This function is redefinable by code that hacks ufs names.") + + (COND + (NAME (* ; "Pass NIL thru transparently") + (COND + [(DSKP DEV) + (SETQ NAME (CONCAT *DSK-HOST-NAME* DIR NAME)) + (COND + [*DSK-UPPER-CASE-FILE-NAMES* + + (* ;; "DSK code uses *DSK-UPPER-CASE-FILE-NAMES* instead of *UPPER-CASE-FILE-NAMES*. I think the capability of case insensitive file recognition in Medley-S {DSK} device is essentially optional and implemented only to keep the compatibility with D-Machines. Actually the case insensitive file recognition is significantly slower than on the correct case (AR 11074). There is no reasonable way to solve this problem because the underlying UNIX file ysystem is case sensitive. Thus, I introduced the new parameter *DSK-UPPER-CASE-FILE-NAMES* with its default value NIL.") + + (COND + (ATOMP (MKATOM (U-CASE NAME))) + (T (U-CASE NAME] + (T (COND + (ATOMP (MKATOM NAME)) + (T NAME] + (T (SETQ NAME (CONCAT *UFS-HOST-NAME* DIR NAME)) + (COND + (ATOMP (MKATOM NAME)) + (T NAME] + +(PUTPROPS \UFSGetMonitor MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSKtopMonitor) + (UNIX \UFStopMonitor) + NIL))) + +(PUTPROPS \UFS.DEFAULT.DIR MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK \DSK.DEFAULT.DIRECTORY) + (UNIX \UFS.DEFAULT.DIRECTORY) + NIL))) + +[PUTPROPS \UFS.FILE.RECOGNIZER MACRO ((DEV) + + (* ;; + "Return a function that will do name recognition for this device") + + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK (FUNCTION \DSKGetFileName-C)) + (UNIX (FUNCTION \UFSGetFileName-C)) + (FUNCTION SHOULDNT] + +[PUTPROPS \UFS.DIRECTORY.RECOGNIZER MACRO ((DEV) + (SELECTQ (fetch (FDEV DEVICENAME) of DEV) + (DSK (FUNCTION \DSKDirectoryNameP-C)) + (UNIX (FUNCTION \UFSDirectoryNameP-C)) + (FUNCTION SHOULDNT] + +[PUTPROPS DSKP MACRO ((DEV) + (EQ (fetch (FDEV DEVICENAME) of DEV) + 'DSK] +) +(DECLARE%: EVAL@COMPILE + +(ACCESSFNS UFSSTREAM ( + (* ;; + "Overlay for the STREAM record to allow mnemonic access to stream fields for ufs streams.") + + (FILEID (fetch F1 of DATUM) + (REPLACE F1 OF DATUM WITH NEWVALUE)) + (* ; "Unix file handle") + (CDATE (fetch F2 of DATUM) + (REPLACE F2 OF DATUM WITH NEWVALUE)) + (* ; "IDate given to openstream") + (UNIXNAME (fetch F5 of DATUM) + (REPLACE F5 OF DATUM WITH NEWVALUE)) + (* ; + "The name by which Unix knows this file") + )) + +(RECORD NAME&ALLPROPS (NAME . ALLPROPS)) +) + + + +(* ;; "File attribute code. For interface between Cfunc and LISPfunc.") + +(DECLARE%: EVAL@COMPILE + +(RPAQQ ATTR-LENGTH 1) + +(RPAQQ ATTR-WDATE 2) + +(RPAQQ ATTR-RDATE 3) + +(RPAQQ ATTR-CDATE 4) + +(RPAQQ ATTR-AUTHOR 5) + +(RPAQQ ATTR-PROTECTION 6) + +(RPAQQ ATTR-EOL 7) + +(RPAQQ ATTR-ALL 8) + + +(CONSTANTS (ATTR-LENGTH 1) + (ATTR-WDATE 2) + (ATTR-RDATE 3) + (ATTR-CDATE 4) + (ATTR-AUTHOR 5) + (ATTR-PROTECTION 6) + (ATTR-EOL 7) + (ATTR-ALL 8)) +) + + + +(* ;; "File RECOG code. For interface between Cfunc and LISPfunc.") + +(DECLARE%: EVAL@COMPILE + +(RPAQQ RECOG-OLD 0) + +(RPAQQ RECOG-OLDEST 1) + +(RPAQQ RECOG-NEW 2) + +(RPAQQ RECOG-NEW-OLD 3) + +(RPAQQ RECOG-OTHER 4) + +(RPAQQ RECOG-NON 5) + + +(CONSTANTS (RECOG-OLD 0) + (RECOG-OLDEST 1) + (RECOG-NEW 2) + (RECOG-NEW-OLD 3) + (RECOG-OTHER 4) + (RECOG-NON 5)) +) + + + +(* ;; "File ACCESS code. For interface between Cfunc and LISPfunc.") + +(DECLARE%: EVAL@COMPILE + +(RPAQQ ACCESS-INPUT 0) + +(RPAQQ ACCESS-OUTPUT 1) + +(RPAQQ ACCESS-BOTH 2) + +(RPAQQ ACCESS-APPEND 3) + +(RPAQQ ACCESS-OTHER 4) + + +(CONSTANTS (ACCESS-INPUT 0) + (ACCESS-OUTPUT 1) + (ACCESS-BOTH 2) + (ACCESS-APPEND 3) + (ACCESS-OTHER 4)) +) + + + +(* ;; "\UFSGetFileInfo allocate this size buffer to keep the user name.") + +(DECLARE%: EVAL@COMPILE + +(RPAQQ MAX-UNAME-LEN 512) + + +(CONSTANTS (MAX-UNAME-LEN 512)) +) + + + +(* ;; "\UFSGetFileName allocate this size buffer to keep the path name.") + +(DECLARE%: EVAL@COMPILE + +(RPAQQ MAX-PATHNAME-LEN 256) + + +(CONSTANTS (MAX-PATHNAME-LEN 256)) +) + +(FILESLOAD (LOADCOMP) + PMAP) + + + +(* ; "For \devicefile.eoserror") + +) + + + +(* ; "Filetypepatch functions. ") + +(DEFINEQ + +(\UFSGetPrintFileType (LAMBDA (FILENAME) (* ; "Edited 23-Jul-91 13:40 by jds") (LET ((TYPE (UNPACKFILENAME.STRING FILENAME (QUOTE EXTENSION)))) (SETQ TYPE (MKATOM (U-CASE (COND ((AND (EQ (NCHARS TYPE) 0) (* ; "Handle null extension specially") (CDR (CL:ASSOC NIL DEFAULTFILETYPELIST)))) ((CDR (CL:ASSOC TYPE DEFAULTFILETYPELIST :TEST (QUOTE STRING-EQUAL)))) (T (\UFSGetFileTypeConfirm FILENAME)))))) TYPE)) ) + +(\UFSGetFileTypeConfirm (LAMBDA (FILENAME) (* ; "Edited 27-Oct-90 17:52 by nm") (* ; "Edited 9-Jan-89 20:43 by H.Komatsubara") (DECLARE (GLOBALVARS FileTypeMenu DEFAULTFILETYPE)) (PROMPTPRINT "Extension of " FILENAME " isn't in DEFAULTFILETYPELIST.% +" "Please select FileType.% +" "This message can be stopped by setting FileTypeConfirmFlg to NIL.% +") (OR (BOUNDP (QUOTE FileTypeMenu)) (\UFSPrintTypeMenu)) (OR (MENU FileTypeMenu) (RETTO T))) ) + +(\UFSPrintTypeMenu (LAMBDA NIL (DECLARE (GLOBALVARS FileTypeMenu)) (* ; "Edited 9-Jan-89 11:08 by hayata.abc") (SETQ FileTypeMenu (create MENU TITLE _ "FileType?" ITEMS _ (QUOTE ((TEXT (QUOTE TEXT)) (BINARY (QUOTE BINARY)))) CENTERFLG _ T))) ) +) + + + +(* ; "for hardcopy") + +(DEFINEQ + +(\UFStoOtherCopyMess (LAMBDA (INSTREAM OUTSTREAM) (* ; "Edited 9-Jan-89 12:19 by hayata.abc") (* ;; "") (* ; "Edited 10-Jan-89 01:01 by H.Komatsubara") (DECLARE (GLOBALVARS DEFAULTFILETYPELIST DEFAULTFILETYPE)) (AND (OR (EQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of INSTREAM)) (QUOTE DSK)) (EQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of INSTREAM)) (QUOTE UNIX))) (AND (NEQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of OUTSTREAM)) (QUOTE DSK)) (NEQ (fetch (FDEV DEVICENAME) of (fetch DEVICE of OUTSTREAM)) (QUOTE UNIX))) (NULL (LET ((EXTENSION (U-CASE (FILENAMEFIELD (fetch FULLFILENAME of INSTREAM) (QUOTE EXTENSION))))) (for PAIR in DEFAULTFILETYPELIST finally NIL do (if (EQUAL (U-CASE (CAR PAIR)) EXTENSION) then (RETURN (CDR PAIR)))))) (PROMPTPRINT "Extension of " (fetch FULLFILENAME of INSTREAM) " isn't in DEFAULTFILETYPELIST.% +" (fetch FULLFILENAME of OUTSTREAM) " was copied as " DEFAULTFILETYPE ".% +" "This message can be stopped by set FileTypeConfirmFlg to NIL.% +"))) ) + +(\UFStoOtherRenameMess (LAMBDA (OLD-DEVICE OLD-NAME NEW-DEVICE NEW-NAME) (* ; "Edited 9-Jan-89 12:19 by hayata.abc") (* ; "Edited 9-Jan-89 11:33 by hayata.abc") (DECLARE (GLOBALVARS DEFAULTFILETYPELIST DEFAULTFILETYPE)) (AND (AND (NEQ (fetch (FDEV DEVICENAME) of NEW-DEVICE) (QUOTE DSK)) (NEQ (fetch (FDEV DEVICENAME) of NEW-DEVICE) (QUOTE UNIX))) (NULL (LET ((EXTENSION (U-CASE (FILENAMEFIELD OLD-NAME (QUOTE EXTENSION))))) (for PAIR in DEFAULTFILETYPELIST finally NIL do (if (EQUAL (U-CASE (CAR PAIR)) EXTENSION) then (RETURN (CDR PAIR)))))) (PROMPTPRINT "Extension of " OLD-NAME " isn't in DEFAULTFILETYPELIST.% +" NEW-NAME " was renamed as " DEFAULTFILETYPE ".% +" "This message can be stopped by set FileTypeConfirmFlg to NIL.% +"))) ) +) + + + +(* ; "for copyfile,renamefile") + + +(RPAQ? FileTypeConfirmFlg T) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS FileTypeMenu FileTypeConfirmFlg) +) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA ) +) +(PUTPROPS UFS COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 1992 1993 1994 1995 2000)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (8170 9723 (\UFSCreateDevice 8180 . 8545) (\UFS.CREATE.DEVICE 8547 . 9403) ( +\UFSOpenDevice 9405 . 9582) (\UFSCloseDevice 9584 . 9721)) (13884 41794 (\UFSOpenFile 13894 . 17188) ( +\UFS.OPENP 17190 . 17687) (\UFS.RECOGNIZE.FILE 17689 . 18442) (\UFS.DIRECTORY.NAME 18444 . 19187) ( +\UFSCloseFile 19189 . 20165) (\UFSGetFileName 20167 . 20366) (\UFSDeleteFile 20368 . 20908) ( +\UFSRenameFile 20910 . 22075) (\UFSReadPages 22077 . 23212) (\UFSWritePages 23214 . 24434) ( +\UFSTruncateFile 24436 . 25933) (\UFSDirectoryNameP 25935 . 26989) (\UFSEventFn 26991 . 27653) ( +\UFSGetFileInfo 27655 . 29937) (\UFS.CREATE.PROPS 29939 . 30292) (\UFSSetFileInfo 30294 . 31523) ( +\UFSGenerateFiles 31525 . 34237) (\UFS.NEXTFILEFN 34239 . 38382) (\UFS.FILEINFOFN 38384 . 39833) ( +\UFS.VALID.PROPP 39835 . 40127) (\UFS.REGISTER.GFS 40129 . 40384) (\UFS.UNREGISTER.GFS 40386 . 40969) +(\UFS.ABORT.DIRECTORY 40971 . 41319) (\UFS.ABORT.CL-DIRECTORY 41321 . 41608) (\UFS.CLEANUP.GFS.TABLE +41610 . 41792)) (41829 48513 (\UFSMakeUnixFormatName 41839 . 42860) (\UFSParseNameString 42862 . 43236 +) (\UFSParse-Directory 43238 . 43779) (\UFS.PARSE.BODY 43781 . 44326) (\UFS.ADJUST.HOST 44328 . 44487) + (\UFS.FULLNAME 44489 . 45697) (\UFS.ADD.HOST.FIELD 45699 . 46059) (\UFS.REMOVE.HOST.FIELD 46061 . +47731) (\UFS.HANDLE.RELATIVEDIRECTORY 47733 . 48511)) (49329 49942 (CHDIR 49339 . 49940)) (50014 51000 + (\DEVICEFILE.EOSERROR 50024 . 50998)) (51073 52310 (\UNVISIBLE.PAGED.REVALIDATEFILELST 51083 . 51928) + (\UNVISIBLE.FLUSH.OPEN.STREAMS 51930 . 52308)) (52343 53969 (\UFSError 52353 . 53967)) (54013 55697 ( +\UFSGetFileType 54023 . 54624) (\UFSSetFileType 54626 . 55055) (\UFSeol 55057 . 55695)) (66049 67173 ( +\UFSGetPrintFileType 66059 . 66471) (\UFSGetFileTypeConfirm 66473 . 66921) (\UFSPrintTypeMenu 66923 . +67171)) (67203 68951 (\UFStoOtherCopyMess 67213 . 68204) (\UFStoOtherRenameMess 68206 . 68949))))) +STOP diff --git a/sources/UFSCALLC b/sources/UFSCALLC new file mode 100644 index 00000000..f6da74d5 --- /dev/null +++ b/sources/UFSCALLC @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-May-2018 12:53:00"  {DSK}kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.;2 3701 previous date%: "31-May-90 12:17:51" {DSK}kaplan>Local>medley3.5>lispcore>sources>UFSCALLC.;1) (* ; " Copyright (c) 1987, 1988, 1990, 2018 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UFSCALLCCOMS) (RPAQQ UFSCALLCCOMS ((FNS \UFSOpenFile-C \UFSCloseFile-C \UFSGetFileName-C \DSKGetFileName-C \UFSDeleteFile-C \UFSRenameFile-C \UFSReadPages-C \UFSWritePages-C \UFSGetSize-C \UFSReadDir-C \UFSDirectoryNameP-C \DSKDirectoryNameP-C \UFSGetFileInfo-C \UFSCHDIR-C \UFSSetFileInfo-C \UFSGetFreeBlock-C \UFSNextFile-C \UFSFinishFileInfo-C))) (DEFINEQ (\UFSOpenFile-C (LAMBDA (FILE REC ACC CDATE LENGTH ERRNO) (* ; "Edited 29-Mar-90 17:50 by nm") (SUBRCALL COM-OPENFILE FILE REC ACC CDATE LENGTH ERRNO)) ) (\UFSCloseFile-C (LAMBDA (PATHNAME FILEID CDATE ERRNO) (* ; "Edited 29-Mar-90 17:51 by nm") (SUBRCALL COM-CLOSEFILE PATHNAME FILEID CDATE ERRNO)) ) (\UFSGetFileName-C (LAMBDA (PATHNAME RECOG BUF ERRNO) (* ; "Edited 28-Jul-88 14:08 by hayata") (SUBRCALL UFS-GETFILENAME PATHNAME RECOG BUF ERRNO)) ) (\DSKGetFileName-C (LAMBDA (PATHNAME RECOG BUF ERRNO) (* ; "Edited 28-Jul-88 21:47 by hayata") (SUBRCALL DSK-GETFILENAME PATHNAME RECOG BUF ERRNO)) ) (\UFSDeleteFile-C (LAMBDA (NAME FDEV ERRNO) (* ; "Edited 28-Jul-88 21:48 by hayata") (SELECTQ (fetch (FDEV DEVICENAME) of FDEV) (UNIX (SUBRCALL UFS-DELETEFILE NAME ERRNO)) (DSK (SUBRCALL DSK-DELETEFILE NAME ERRNO)) NIL)) ) (\UFSRenameFile-C (LAMBDA (OLDNAME NEWNAME FDEV ERRNO) (* ; "Edited 28-Jul-88 21:49 by hayata") (SELECTQ (fetch (FDEV DEVICENAME) of FDEV) (UNIX (SUBRCALL UFS-RENAMEFILE OLDNAME NEWNAME ERRNO)) (DSK (SUBRCALL DSK-RENAMEFILE OLDNAME NEWNAME ERRNO)) NIL)) ) (\UFSReadPages-C (LAMBDA (FILEID PAGENUM BUFFER ERRNO) (* ; "Edited 29-Mar-90 17:52 by nm") (SUBRCALL COM-READPAGES FILEID PAGENUM BUFFER ERRNO)) ) (\UFSWritePages-C (LAMBDA (FILEID PAGENUM BUFFER SIZE ERRNO) (* ; "Edited 29-Mar-90 17:53 by nm") (SUBRCALL COM-WRITEPAGES FILEID PAGENUM BUFFER SIZE ERRNO)) ) (\UFSGetSize-C (LAMBDA (FILEID BUF ERRNO) (* ; "Edited 29-Mar-90 17:53 by nm") (SUBRCALL COM-TRUNCATEFILE FILEID BUF ERRNO)) ) (\UFSReadDir-C (LAMBDA (FILTER PROPP ID ERRNO) (* ; "Edited 3-May-90 15:02 by nm") (SUBRCALL COM-GEN-FILES FILTER PROPP ID ERRNO)) ) (\UFSDirectoryNameP-C (LAMBDA (DIRSPEC BUF ERRNO) (* ; "Edited 29-Mar-90 18:03 by nm") (SUBRCALL UFS-DIRECTORYNAMEP DIRSPEC BUF ERRNO)) ) (\DSKDirectoryNameP-C (LAMBDA (DIRSPEC BUF ERRNO) (* ; "Edited 29-Mar-90 18:03 by nm") (SUBRCALL DSK-DIRECTORYNAMEP DIRSPEC BUF ERRNO)) ) (\UFSGetFileInfo-C (LAMBDA (FILENAME ATTR-CODE BUFFER ERRNO) (* ; "Edited 29-Mar-90 17:57 by nm") (SUBRCALL COM-GETFILEINFO FILENAME ATTR-CODE BUFFER ERRNO)) ) (\UFSCHDIR-C (LAMBDA (DIR) (* ; "Edited 29-Mar-90 17:59 by nm") (SUBRCALL COM-CHANGEDIR DIR))) (\UFSSetFileInfo-C (LAMBDA (FILENAME ATTR-CODE BUFFER ERRNO) (* ; "Edited 29-Mar-90 17:59 by nm") (SUBRCALL COM-SETFILEINFO FILENAME ATTR-CODE BUFFER ERRNO)) ) (\UFSGetFreeBlock-C (LAMBDA (FILE BUF) (* ; "Edited 29-Mar-90 18:00 by nm") (SUBRCALL COM-GETFREEBLOCK FILE BUF))) (\UFSNextFile-C (LAMBDA (GENFILESTATE) (* ; "Edited 7-May-90 21:01 by nm") (SUBRCALL COM-NEXT-FILE GENFILESTATE))) (\UFSFinishFileInfo-C (LAMBDA (FINFOID) (* ; "Edited 3-May-90 18:06 by nm") (SUBRCALL COM-FINISH-FINFO FINFOID))) ) (PUTPROPS UFSCALLC COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (811 3598 (\UFSOpenFile-C 821 . 978) (\UFSCloseFile-C 980 . 1131) (\UFSGetFileName-C 1133 . 1286) (\DSKGetFileName-C 1288 . 1441) (\UFSDeleteFile-C 1443 . 1669) (\UFSRenameFile-C 1671 . 1930) (\UFSReadPages-C 1932 . 2083) (\UFSWritePages-C 2085 . 2248) (\UFSGetSize-C 2250 . 2380) ( \UFSReadDir-C 2382 . 2519) (\UFSDirectoryNameP-C 2521 . 2662) (\DSKDirectoryNameP-C 2664 . 2805) ( \UFSGetFileInfo-C 2807 . 2970) (\UFSCHDIR-C 2972 . 3070) (\UFSSetFileInfo-C 3072 . 3235) ( \UFSGetFreeBlock-C 3237 . 3355) (\UFSNextFile-C 3357 . 3476) (\UFSFinishFileInfo-C 3478 . 3596))))) STOP \ No newline at end of file diff --git a/sources/UNDO b/sources/UNDO new file mode 100644 index 00000000..54f80745 --- /dev/null +++ b/sources/UNDO @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-May-90 16:09:40" {DSK}local>lde>lispcore>sources>UNDO.;2 40846 changes to%: (VARS UNDOCOMS) previous date%: " 8-Jan-88 13:04:47" {DSK}local>lde>lispcore>sources>UNDO.;1) (* ; " Copyright (c) 1984, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNDOCOMS) (RPAQQ UNDOCOMS [(FNS SAVESET UNDOSET SAVESETQ SAVESETQQ RPAQQ RPAQ RPAQ? RPLNODE RPLNODE2 NEW/FN UNDOSAVE UNDOLISPX UNDOLISPX1 UNDOPRINT UNDOLISPX2 UNDOLISPX3 UNSET /LISPXPUT /PUT-1 /PUT+1 UNDONLSETQ UNDONLSETQ1 RESETUNDO /DEFINEQ /DEFINE /PRINTLEVEL) (INITVARS (%#UNDOSAVES) (UNDOSIDE0) (TESTMODEFLG)) (ADDVARS (LISPXFNS (SETQ . SAVESETQ) (SET . SAVESET) (SETQQ . SAVESETQQ) (DEFINEQ . /DEFINEQ) (DEFINE . /DEFINE) (PRINTLEVEL . /PRINTLEVEL)) (/FNS /ADDPROP /ATTACH /CONTROL /DELETECONTROL /DREMOVE /DREVERSE /DSUBST /ECHOCONTROL /ECHOMODE /LCONC /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /MOVD /NCONC /NCONC1 /PUT /PUTASSOC /PUTD /PUTDQ /PUTHASH /PUTPROP /RADIX /RAISE /REMPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SET /SETA /SETATOMVAL /SETBRK /SETD /SETPROPLIST /SETREADTABLE /SETSEPR /SETSYNTAX /SETTERMTABLE /SETTOPVAL /TCONC)) (FNS /ADDPROP /ATTACH /CONTROL /DELETECONTROL /DREMOVE /DREVERSE /DSUBST /ECHOCONTROL /ECHOMODE /LCONC /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /MOVD /NCONC /NCONC1 /PUT /PUTASSOC /PUTD /PUTDQ /PUTHASH /PUTPROP /RADIX /RAISE /REMPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SET /SETA /SETATOMVAL /SETBRK /SETD /SETPROPLIST /SETREADTABLE /SETSEPR /SETSYNTAX /SETTERMTABLE /SETTOPVAL /TCONC) [P (SETQ LISPXFNS (UNION LISPXFNS (MAPCAR /FNS (FUNCTION (LAMBDA (X Y) (CONS (PACK (CDR (DUNPACK X CHCONLST))) X] (P (MOVD? 'RPLNODE 'FRPLNODE) (MOVD? 'RPLNODE2 'FRPLNODE2)) (BLOCKS (NIL UNSET RPLNODE RPLNODE2 /LISPXPUT /PUT-1 /PUT+1 (LINKFNS . T) UNDONLSETQ UNDONLSETQ1 (GLOBALVARS UNDOSTATS CLEARSTKLST DWIMFLG SPELLINGS3 LISPXHISTORY %#UNDOSAVES) RESETUNDO UNDOPRINT) (NIL RPAQ RPAQQ (LOCALVARS . T)) (SAVESET SAVESET (LOCALVARS . T) (GLOBALVARS CLEARSTKLST)) (NIL UNDOSET (GLOBALVARS SPAGHETTIFLG)) (NIL NEW/FN (GLOBALVARS TESTMODEFLG LISPXFNS CHCONLST /FNS)) (UNDOLISPXBLOCK UNDOSAVE UNDOLISPX UNDOLISPX1 UNDOLISPX2 UNDOLISPX3 (ENTRIES UNDOSAVE UNDOLISPX UNDOLISPX1 UNDOLISPX2) (BLKLIBRARY LISPXWATCH) (GLOBALVARS UNDOSAVES UNDOSTATS %#UNDOSAVES DWIMFLG DWIMWAIT LISPXHISTORY CLISPTRANFLG EDITQUIETFLG MAXLEVEL) (LOCALFREEVARS UNDONEFLG)) (NIL /ADDPROP /ATTACH /CONTROL /DELETECONTROL /DREMOVE /DREVERSE /DSUBST /ECHOCONTROL /ECHOMODE /LCONC /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /MOVD /NCONC /NCONC1 /PRINTLEVEL /PUT /PUTASSOC /PUTD /PUTDQ /PUTHASH /PUTPROP /REMPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SET /SETA /SETBRK /SETD /SETPROPLIST /SETSEPR /SETSYNTAX /SETATOMVAL /SETTOPVAL /TCONC (GLOBALVARS UNDOSTATS) (LINKFNS . T))) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA /DEFINEQ SAVESETQ) (NLAML /PUTDQ UNDONLSETQ RPAQ? RPAQ RPAQQ SAVESETQQ) (LAMA /NCONC]) (DEFINEQ (SAVESET (LAMBDA (NAME VALUE TOPFLG FLG) (* ; "Edited 8-Jan-88 12:52 by bvm") (* ;; "Sets NAME to VALUE, binding used is most recent unless TOPFLG is T in which case always uses top level binding. The setting is always undoable in conventional way. In addition, if the binding being reset is a top level binding, its value is saved on its property list where it can be recovered via UNSET, even outside the scope of the history list, and (NAME RESET) is printed. If FLG is 'NOPRINT', the printing is suppressed. This is the case when called from UNSET. If FLG is 'NOPROPSAVE', binding is not saved on property list. This is the case when called from /SET. Note that SET becomes SAVESET in type-ins. /SET is used when in TESTMODE. If FLG is NOSTACKUNDO, the call is not undoable when the variable in question is bound on the stack. This is the case on calls from RPAQ, RPAQQ, ADDTOVAR, etc.") (COND ((NOT (LITATOM NAME)) (LISPERROR "ARG NOT LITATOM" NAME)) ((NULL NAME) (COND (VALUE (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))) ((EQ NAME T) (COND ((NEQ VALUE T) (LISPERROR "ATTEMPT TO SET NIL OR T" VALUE)))) (T (PROG (PTR OLDVAL TEM NEWFLG) (SETQ OLDVAL (COND (TOPFLG (GETTOPVAL NAME)) ((SETQ PTR (STKSCAN NAME)) (* ; "PTR=NIL means we are working on the top-level value.") (EVALV NAME)) (T (* ; "This is most efficient for both deep and shallow when we know there are no bindings.") (GETATOMVAL NAME)))) (COND ((AND (NULL PTR) (EQ DFNFLG (QUOTE ALLPROP)) (NEQ OLDVAL (QUOTE NOBIND))) (* ; "from LOAD ALLPROP") (/PUT NAME (QUOTE VALUE) VALUE) (AND ADDSPELLFLG (ADDSPELL NAME T)) (RETURN VALUE)) ((AND PTR (OR (NULL LISPXHIST) (EQ FLG (QUOTE NOSTACKUNDO)) (EQ FLG (QUOTE NOUNDO)))) (* ; "Bound on stack, but we're not saving, so stop agonizing") (SETQ FLG (QUOTE NOUNDO)) (GO OUT)) ((AND (SETQ TEM (SOME (LISTGET1 LISPXHIST (QUOTE SIDE)) (FUNCTION (LAMBDA (X) (AND (LISTP X) (EQ (CAR X) (QUOTE UNDOSET)) (EQ (CADDR X) NAME) (EQ (CADR X) PTR)))))) (NOT (TAILP TEM (LISTP (EVQ UNDOSIDE0))))) (* ;; "this variable has already been set, undoably, in this event. The TAILP check is to make sure it hasn't happened above an UNDONLSETQ now in effect.") (SETQ FLG (QUOTE NOUNDO)) (GO OUT)) ((OR PTR (EQ FLG (QUOTE NOPROPSAVE)) (EQ FLG (QUOTE NOSAVE))) (* ;; "The first predicate is because SAVESET only works for top level bindings. The second indicates a call from /SET or /SETQ. Note that in both cases the variable is NOT added to the spelling list. (The check for NOSAVE is for backwards compatibility. the NOPROPSAVE is newer.)") (GO OUT)) ((EQ (EQUALN OLDVAL VALUE 1000) T) (* ;; "note that we still need to save the undo information because of possibility that we are under an UNDONLSETQ. e.g. user does (SAVESET --) then several SETQ's than an ERROR! and wants to be sure variable was what it was when he entered the function.")) (T (* ; "Variable is being reset.") (AND (NEQ DFNFLG T) (COND ((NULL (SETQ NEWFLG (EQ OLDVAL (QUOTE NOBIND)))) (COND ((NEQ FLG (QUOTE NOPRINT)) (EXEC-FORMAT "(~S reset)~%%" NAME))) (/PUT NAME (QUOTE VALUE) OLDVAL)))) (MARKASCHANGED NAME (QUOTE VARS) NEWFLG))) (AND ADDSPELLFLG (ADDSPELL NAME T)) OUT (COND (PTR (SET NAME VALUE) (COND ((EQ FLG (QUOTE NOUNDO)) (RELSTK PTR)) (T (* ;; "A stack pointer to the frame of NAME's binding has been created and not released. This is because it is being saved for possible undoing. This is exceedingly crufty.") (UNDOSAVE (LIST (QUOTE UNDOSET) PTR NAME OLDVAL) LISPXHIST)))) (T (COND (TOPFLG (* ;; "Can't just SETATOMVAL, cause if TOPFLG we didn't bother searching for intermediate binding, which would be found by shallow SETATOMVAL") (SETTOPVAL NAME VALUE)) (T (SETATOMVAL NAME VALUE))) (COND ((AND LISPXHIST (NEQ FLG (QUOTE NOUNDO))) (UNDOSAVE (LIST (QUOTE UNDOSET) NIL NAME OLDVAL) LISPXHIST)))))))) VALUE) ) (UNDOSET (LAMBDA (PTR NAME VALUE) (* rmk%: " 5-JAN-82 01:35") (PROG (TEM) (RETURN (COND ((NULL PTR) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE UNDOSET) NIL NAME (GETTOPVAL NAME)) LISPXHIST)) (SETTOPVAL NAME VALUE) T) ((NULL SPAGHETTIFLG) (COND ((EQ (CDR PTR) NAME) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE UNDOSET) PTR NAME (GETTOPVAL NAME)))) (SETTOPVAL NAME VALUE) T))) ((SETQ TEM (FRAMESCAN NAME PTR)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE UNDOSET) PTR NAME (STKARG TEM PTR)) LISPXHIST)) (SETSTKARG NAME PTR VALUE) T))))) ) (SAVESETQ (NLAMBDA SETQX (* wt%: "13-JUN-78 23:53") (SAVESET (CAR SETQX) (APPLY (QUOTE PROG1) (CDR SETQX) (QUOTE INTERNAL)))) ) (SAVESETQQ (NLAMBDA (SETQX SETQY) (SAVESET SETQX SETQY))) (RPAQQ (NLAMBDA (X Y) (* rmk%: " 4-JAN-82 13:02") (SAVESET X Y T))) (RPAQ (NLAMBDA (RPAQX RPAQY) (* rmk%: " 4-JAN-82 13:03") (SAVESET RPAQX (EVAL RPAQY (QUOTE INTERNAL)) T))) (RPAQ? (NLAMBDA (RPAQX RPAQY) (* lmm "23-JUL-83 16:12") (* ;; "RPAQ? and RPAQQ are used by PRETTYDEF to save VARS.") (OR (NEQ (GETTOPVAL RPAQX) (QUOTE NOBIND)) (SETTOPVAL RPAQX (EVAL RPAQY)))) ) (RPLNODE (LAMBDA (X A D) (AND (NLISTP X) (ERRORX (LIST 4 X))) (RPLACA X A) (RPLACD X D))) (RPLNODE2 (LAMBDA (X Y) (* rmk%: " 4-MAR-82 22:07") (* ;; "Generated by paatern match. INcluded so user can load code that has been dwimified and or compiled into a nonclisp system and run it.") (COND ((AND Y (NLISTP Y)) (ERRORX (LIST 4 Y))) (T (RPLNODE X (CAR Y) (CDR Y))))) ) (NEW/FN (LAMBDA (FN) (* bvm%: " 1-Jan-84 16:50") (PROG (FN1) (COND ((EQ (CHCON1 FN) (CHARCODE /)) (SETQ FN1 (PACK (CDR (DUNPACK FN CHCONLST))))) (T (SETQ FN1 FN) (SETQ FN (PACK* (QUOTE /) FN)))) (SETQ /FNS (/NCONC1 /FNS FN)) (* ; "Used to do this for TESTMODE, but that not implemented any more: (/PUT FN (QUOTE \DEF) (GETD FN1))") (SETQ LISPXFNS (/NCONC1 LISPXFNS (CONS FN1 FN))) (RETURN FN))) ) (UNDOSAVE (LAMBDA (UNDOFORM HISTENTRY) (* wt%: 7-JUN-77 0 41) (AND (NULL HISTENTRY) (SETQ HISTENTRY (EVQ LISPXHIST))) (AND HISTENTRY (PROG (Y N) (LISPXWATCH UNDOSAVES) (COND ((NULL (CAR (SETQ Y (CDR (FMEMB (QUOTE SIDE) HISTENTRY))))) (* ;; "There could be a property SIDE with value NIL if the user did a FORGET during the execution of the event") (NCONC HISTENTRY (LIST (QUOTE SIDE) (LIST 1 UNDOFORM))) (RETURN)) ((EQ (CAR Y) (QUOTE NOSAVE)) (RETURN)) ((EQ (SETQ N (CAAR Y)) -1) (* ; "Already gone past #UNDOSAVES and user has confirmed.") (GO OUT)) (UNDOFORM (* ; "can be called with UNDOFORM=NIL just to check on #undosaves") (SETQ N (ADD1 N)))) (COND ((AND %#UNDOSAVES (IGREATERP N (COND ((MINUSP %#UNDOSAVES) (IMINUS %#UNDOSAVES)) (T %#UNDOSAVES)))) (COND ((OR (MINUSP %#UNDOSAVES) (AND DWIMFLG (NEQ (ASKUSER DWIMWAIT (QUOTE N) (LIST %#UNDOSAVES (QUOTE "undosaves, continue saving"))) (QUOTE Y)))) (FRPLACA Y (QUOTE NOSAVE)) (RETURN))) (SETQ N -1))) OUT (FRPLACA (SETQ Y (CAR Y)) N) (AND UNDOFORM (FRPLACD Y (CONS UNDOFORM (CDR Y))))))) ) (UNDOLISPX (LAMBDA (LINE) (* Note%: undoing in order is guaranteed to restore you to the original state. Undoing out of order is defined as restoring any cells changed in the indicated operation to their original state before the operation was performed. For independent operations, undoing will have the correct effect. However, for dependent operations, it may have an unforeseen effect. For example, ATTACH (A X) ATTACH (B X) followed by UNDO A will remove both A and B since the cell changed by the first ATTACH was the first cell in X, and this will be restored to its former state. In general, operations are always independent if they affect different lists or different sublists (not TAILS) of the same list. However, because property list functions might be thought of as independent, PUT, REMPROP, and ADDPROP are treated specially. Thus put (FOO PROP1 VAL1) followed by PUTPROP (FOO PROP2 VAL2) followed by UNDO PROP1 will remove just PROP1 even if both PUT'S resulted in new properties and hence additions to the end of the property list.) (PROG (UNDONEFLG DWIMCHANGES) (SETQ DWIMCHANGES (FMEMB (QUOTE %:) LINE)) (SETQ LINE (LDIFF LINE DWIMCHANGES)) (SETQ DWIMCHANGES (CDR DWIMCHANGES)) (COND (LINE (MAPC (LISPXFIND LISPXHISTORY LINE (QUOTE ENTRIES) T) (FUNCTION (LAMBDA (X) (SETQ UNDONEFLG (OR (UNDOLISPX1 X NIL DWIMCHANGES) UNDONEFLG)))))) (T (SOME (CDAR LISPXHISTORY) (FUNCTION (LAMBDA (X) (SETQ UNDONEFLG (OR (UNDOLISPX1 X T DWIMCHANGES) UNDONEFLG))))))) (RETURN (COND ((NULL UNDONEFLG) (PRIN1 (COND (DWIMCHANGES (QUOTE "not found. ")) (T (QUOTE "nothing saved. "))) T) (QUOTE)) (T UNDONEFLG)))))) (UNDOLISPX1 (LAMBDA (EVENT FLG DWIMCHANGES) (* ;; "FLG is T when interpreting a simple UNDO command. In this case, does not UNDO commands already undone, nor other UNDO commands.") (PROG (TEM Y X) (COND ((AND FLG (OR (EQ (CAAR EVENT) (QUOTE UNDO)) (EQ (CAAR EVENT) (QUOTE undo)))) (RETURN NIL))) (SETQ TEM (UNDOLISPX2 EVENT NIL DWIMCHANGES)) (COND ((NULL TEM) (RETURN)) ((EQ TEM (QUOTE already)) (COND (FLG (* ; "Searching for last thing to UNDO.") (RETURN NIL))) (SETQ X TEM)) ((SETQ Y (FMEMB (QUOTE *HISTORY*) EVENT)) (SETQ X (CAADR Y))) (T (SETQ X (CAR EVENT)))) (COND ((COND ((EQ X (QUOTE already)) (PRIN1 X T)) ((NULL DWIMCHANGES) (* ; "Messages for DWIMCHANGES are printed in UNDOLISPX3.") (SETQ X (UNDOPRINT X EVENT)))) (* ;; "Initially defined as PRIN1. Separate function so user can advise it to print the 'name' of the event.") (PRIN1 (QUOTE " undone. ") T))) (RETURN X)))) (UNDOPRINT (LAMBDA (X EVENT) (PRIN2 (COND ((NLISTP X) X) ((LISTP (CAR X)) (CAAR X)) (T (CAR X))) T T))) (UNDOLISPX2 (LAMBDA (X FORGETFLG DWIMCHANGES) (* ;; "Searches X for SIDE information. If finds some and is already undone, sets FLG1 to 'ALREADY, otherwise sets FLG1 to T, undoes it, and marks it undone.") (* ;; "If FORGETFLG is T, just erases the UNDO information entirely.") (PROG (Y TEM VAL) (AND FORGETFLG (MAPC (QUOTE (ENTERED EDITHIST EDIT)) (FUNCTION (LAMBDA (PROP) (AND (SETQ TEM (CDR (FMEMB PROP X))) (FRPLACA TEM NIL))))) (COND ((SETQ TEM (CDR (FMEMB (QUOTE EDIT) X))) (FRPLACA TEM NIL)))) (SETQ VAL (COND ((CDAR (SETQ Y (CDR (FMEMB (QUOTE SIDE) X)))) (* ; "An attempted CLISP correction will leave a side property consisting of just (0) the CDAR checks for this.") (COND (FORGETFLG (FRPLACA Y NIL)) ((NLISTP (SETQ Y (CAR Y))) NIL) ((NULL (CAR Y)) (QUOTE already)) (DWIMCHANGES (MAPC DWIMCHANGES (FUNCTION (LAMBDA (DWIMCHANGE) (SETQ VAL (OR (UNDOLISPX3 X DWIMCHANGE) VAL))))) VAL) (T (* ; "(CAR Y) Is the count.") (MAPC (CDR Y) (FUNCTION (LAMBDA (X) (COND ((NLISTP X) (* ; "a marker") NIL) ((LISTP (CAR X)) (/RPLNODE (CAR X) (CADR X) (CDDR X))) (T (APPLY (CAR X) (CDR X)))) (LISPXWATCH UNDOSTATS)))) (/ATTACH NIL Y) T))))) (COND ((SETQ Y (CADR (FMEMB (QUOTE *GROUP*) X))) (MAPC (REVERSE Y) (FUNCTION (LAMBDA (X) (SETQ VAL (OR (UNDOLISPX2 X FORGETFLG DWIMCHANGES) VAL))))))) (RETURN VAL))) ) (UNDOLISPX3 (LAMBDA (EVENT DWIMCHANGE) (RESETVARS ((EDITQUIETFLG T) (MAXLEVEL 1500) (CLISPTRANFLG (QUOTE CLISP% ))) (RETURN (PROG (L (COMS (LIST (LIST (QUOTE F) DWIMCHANGE T) 1 (QUOTE (BELOW ^)) (QUOTE UP))) MARKER L1 L2 TEM) (COND ((NULL (SETQ TEM (LISTGET1 EVENT (QUOTE *LISPXPRINT*)))) (RETURN NIL))) (SETQ L (LIST TEM)) LP (COND ((NULL (AND L (NLSETQ (SETQ L (EDITL L COMS))) (SETQ MARKER (FASSOC CLISPTRANFLG (CAR L))))) (* ;; "The FASSOC looks for the DWIM marker. If none is found, this message is not associated with a DWIM correction.") (RETURN)) ((NULL (TAILP (CAR L) (CADADR MARKER))) (* ;; "The form of MARKER is (CLISP (QUOTE PTR1 PTR2 PTR3)) where PTR1 marks the print list at the beginning of this DWIM correction, PTR2 the sides at the beginning, and PTR3 the sides at the end. The TAILP checks to see that the place where this word was found is inside of the DWIM correction. If not, it goes on to look for another instance of this word by starting with the position after the DWIM marker.") (SETQ L (CDR (FMEMB MARKER L))) (GO LP))) (SETQ L (SETQ L1 (CADDDR (SETQ TEM (CADR MARKER))))) (* ; "The beginning of the side info.") (SETQ L2 (CADDR TEM)) LP1 (COND ((EQ L1 L2) (/RPLNODE L (QUOTE (QUOTE PATCHED)) L2) (SETQ L1 (CADADR MARKER)) (GO LP2)) ((NLISTP (SETQ TEM (CAR L1)))) ((LISTP (CAR TEM)) (/RPLNODE (CAR TEM) (CADR TEM) (CDDR TEM))) (T (APPLY (CAR TEM) (CDR TEM)))) (LISPXWATCH UNDOSTATS) (SETQ L1 (CDR L1)) (GO LP1) LP2 (* ; "Prints the message associated with the DWIM correction.") (COND ((EQ (CADR L1) MARKER) (LISPXPRIN1 (QUOTE " undone. ") T) (RETURN T))) (LISPXPUT (QUOTE *LISPXPRINT*) (LIST (CAR L1)) T LISPXHIST) (LISPXREPRINT (CAR L1)) (SETQ L1 (CDR L1)) (GO LP2))))) ) (UNSET (LAMBDA (NAME) (PROG (X TEM) (RETURN (COND ((OR (SETQ X (FMEMB (QUOTE VALUE) (GETPROPLIST NAME))) (AND DWIMFLG (SETQ TEM (MISSPELLED? NAME 70 SPELLINGS3)) (SETQ X (FMEMB (QUOTE VALUE) (GETPROPLIST (SETQ NAME TEM)))))) (* ;; "Note that UNSET always works for top level bindings in conjuncture with SAVESET: only top level bindings are saved on property lists.") (SAVESET NAME (CADR X) T (QUOTE NOPRINT)) NAME) (T (ERROR (QUOTE "no value saved:") NAME)))))) ) (/LISPXPUT (LAMBDA (PROP L ADDFLG LST) (PROG (Y) (AND (NULL LST) (SETQ LST (CAAR LISPXHISTORY))) (* ; "Puts property at top level of entry. Used mostly for calls with PROP=ERROR.") (COND ((SETQ Y (CDR (FMEMB PROP LST))) (/RPLACA Y (COND (ADDFLG (/NCONC (CAR Y) L)) (T L)))) (T (/NCONC LST (LIST PROP L)))) (RETURN L))) ) (/PUT-1 (LAMBDA (ATM PROP) (* removes property and value at PROP) (PROG ((X (GETPROPLIST ATM)) X0) LP (COND ((EQ X PROP) (UNDOSAVE (LIST (QUOTE /PUT+1) ATM X0 PROP)) (COND (X0 (FRPLACD X0 (CDDR PROP))) (T (SETPROPLIST ATM (CDDR PROP))))) ((LISTP (SETQ X (CDR (SETQ X0 X)))) (GO LP))))) ) (/PUT+1 (LAMBDA (ATM TAIL PROP) (* ;; "CAR and CADR of PROP represent the propety and its value. /PUT+1 resotres CAR and CADR of PROP either at (CDR TAIL) if TAIL is found on the property list of ATM, else at the front of the property list.") (PROG ((X (GETPROPLIST ATM))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM PROP) LISPXHIST)) (COND ((NLISTP TAIL) (* ;; "TAIL is NIL when the property that was removed was the first one on te property list, i.e. should be attached back at the front.") (GO FRONT))) LP (COND ((EQ X TAIL) (FRPLACD (CDR PROP) (CDR X)) (FRPLACD X PROP) (RETURN)) ((LISTP (SETQ X (CDR X))) (GO LP))) FRONT (FRPLACD (CDR PROP) (GETPROPLIST ATM)) (SETPROPLIST ATM PROP))) ) (UNDONLSETQ (NLAMBDA (UNDOFORM UNDOFN) (* wt%: 8-JUN-77 1 48) (PROG ((LISPXHIST LISPXHIST) UNDOSIDE0 UNDOSIDE UNDOTEM) (* ;; "A version of NLSETQ that undoes all side effects if an error occurs. There are several situations to 'WORRY' about. First, LISPXHIST may be NIL, but we still want UNDONLSETQ to operate. Second, LISPXHIST may not yet contain a side property. Third, LISPXHIST may contain a side property. In the latter two cases we also have to worry about the number of undosaves exceeding (OR ALEADY HAVING EXCEEDED) #UNDOSAVES. Finally, we want the entire event undoable if the UNDONLSETQ is aborted with a control-d.") (COND ((LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST (QUOTE SIDE)))) (SETQ UNDOSIDE0 (CDR UNDOSIDE)) (* ; "saves current lst of sides for undoing")) (T (SETQ UNDOSIDE0 UNDOSIDE) (* ; "may be NIL or NOSAVE") (SETQ UNDOSIDE (LIST 0)) (COND (LISPXHIST (LISTPUT1 LISPXHIST (QUOTE SIDE) UNDOSIDE)) (T (SETQ LISPXHIST (LIST (QUOTE SIDE) UNDOSIDE)))))) (RESETVARS (%#UNDOSAVES) (* ; "so saving will continue regardless") (SETQ UNDOTEM (ERRORSET UNDOFORM NIL UNDOFN))) (* ;; "Note that all side effects are stored onto the higher level LISPXHIST, if any, so that if a control-d is typed, any changes made under the UNDONLSETQ will be undoable.") (COND ((EQ UNDOSIDE0 (QUOTE NOSAVE)) (* ;; "number of undosaves had already been exceeded before this call to undonlsetq, and user said not to continue saving.") (LISTPUT1 LISPXHIST (QUOTE SIDE) (QUOTE NOSAVE))) (T (UNDOSAVE) (* ; "to check whether or not to continue saving"))) (COND (UNDOTEM (RETURN UNDOTEM))) (UNDONLSETQ1 (CDR UNDOSIDE) (LISTP UNDOSIDE0)) (* ; "undoes the indicated segment.") (RETURN))) ) (UNDONLSETQ1 (LAMBDA (LST TAIL) (* wt%: 23-MAR-77 22 45) (* ;; "undoes the side informaton from LST to TAIL and then splices it out by smashing LST appropriately.") (AND (NEQ LST TAIL) (PROG ((LST1 LST) LISPXHIST TEM) LP (COND ((EQ LST1 TAIL) (FRPLACD LST TAIL) (FRPLACA LST (QUOTE (QUOTE undonlsetq))) (* ;; "note that the node TAIL must stay in the list because it might be pointed to as cdr of UNDOSIDE0 for some higher UNDONLSETQ.") (RETURN)) ((NLISTP (SETQ TEM (CAR LST1)))) ((LISTP (CAR TEM)) (FRPLACA (CAR TEM) (CADR TEM)) (FRPLACD (CAR TEM) (CDDR TEM))) (T (APPLY (CAR TEM) (CDR TEM)))) (LISPXWATCH UNDOSTATS) (SETQ LST1 (CDR LST1)) (GO LP)))) ) (RESETUNDO (LAMBDA (X STOPFLG) (* wt%: 8-JUN-77 1 52) (* ;; "this function is a generalization of UNDONLSETQ for use under a RESETLST. When called with X = NIL, it sets up things for undoing, and returns a value which when given back to RESETUNDO undoes the corresponding events. UNDONLSETQ could be written in terms of RESETUNDO as (RESETLST (RESETSAVE (RESETUNDO) (AND (EQ RESETSTATE (QUOTE ERROR)) (RESETUNDO OLDVALUE)) form))") (PROG ((UNDOSIDE (CAR X)) (UNDOSIDE0 (CDR X))) (* ;; "note that this function does not reflect the recent change in undonlsetq wherein the undosaves performed under the undonlsetq ARE counted towards the total number") (RETURN (COND ((NULL X) (* ; "just setup and return.") (COND ((LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST (QUOTE SIDE)))) (* ; "SIDE property may be NOSAVE.") (SETQ UNDOSIDE0 (CONS (CAR UNDOSIDE) (CDR UNDOSIDE))) (* ; "Saves old value of side property.") (FRPLACA UNDOSIDE -1) (* ; "So that will continue saving regardless of number.")) (T (SETQ UNDOSIDE (LIST -1)) (SETQ LISPXHIST (COND (LISPXHIST (* ; "LISTPUT1 is like PUT, except it works with lists.") (LISTPUT1 LISPXHIST (QUOTE SIDE) UNDOSIDE)) (T (LIST (QUOTE SIDE) UNDOSIDE)))))) (* ;; "Note that all side effects are stored onto the higher level LISPXHIST, if any, so that if a control-d is typed, any changes made under the UNDONLSETQ will be undoable.") (CONS UNDOSIDE UNDOSIDE0)) (STOPFLG (* ;; "user wants to stop the scope of the resetundo, e.g. he dooes (RESETLST (RESETSAVE (SETQ FOO (RESETUNDO)) (QUOTE (PROGN (RESETUNDO OLDVALUE)))) forms (RESETUNDO FOO T) more-forms) and more-forms will not be affected by tthe RESETUNDO.") (FRPLACA UNDOSIDE (FLENGTH (CDR UNDOSIDE))) (FRPLACA X (CDAR X)) (* ;; "CAR of (CAR X) is the number of undosaves for the corresponding segment. The FRPLACA replace (CAR X) by CDR of the corresponing node. Since the firt node of each of these is what gets smashed when new undosaves are added on, this operation protects thee segments from having subsequent undosaves stored in front.") (FRPLACD X (CDDR X)) X) ((EQ (CAR UNDOSIDE) -1) (FRPLACA UNDOSIDE (FLENGTH (CDR UNDOSIDE))) (UNDONLSETQ1 (CDR UNDOSIDE) (CDR UNDOSIDE0))) (T (* ;; "occurs when the scope was stopped by a call to resetundo with stopflg=T. In this case, UNDOSIDE is a tail of a side proprty.") (UNDONLSETQ1 UNDOSIDE UNDOSIDE0)))))) ) (/DEFINEQ (NLAMBDA X (* wt%: "22-JUL-78 18:55") (DEFINE X T))) (/DEFINE (LAMBDA (X) (DEFINE X T))) (/PRINTLEVEL (LAMBDA (CARVAL CDRVAL) (* bvm%: " 1-Jan-84 16:18") ((LAMBDA (RESULT) (UNDOSAVE (LIST (FUNCTION /PRINTLEVEL) RESULT)) RESULT) (PRINTLEVEL CARVAL CDRVAL))) ) ) (RPAQ? %#UNDOSAVES ) (RPAQ? UNDOSIDE0 ) (RPAQ? TESTMODEFLG ) (ADDTOVAR LISPXFNS (SETQ . SAVESETQ) (SET . SAVESET) (SETQQ . SAVESETQQ) (DEFINEQ . /DEFINEQ) (DEFINE . /DEFINE) (PRINTLEVEL . /PRINTLEVEL)) (ADDTOVAR /FNS /ADDPROP /ATTACH /CONTROL /DELETECONTROL /DREMOVE /DREVERSE /DSUBST /ECHOCONTROL /ECHOMODE /LCONC /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /MOVD /NCONC /NCONC1 /PUT /PUTASSOC /PUTD /PUTDQ /PUTHASH /PUTPROP /RADIX /RAISE /REMPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SET /SETA /SETATOMVAL /SETBRK /SETD /SETPROPLIST /SETREADTABLE /SETSEPR /SETSYNTAX /SETTERMTABLE /SETTOPVAL /TCONC) (DEFINEQ (/ADDPROP (LAMBDA (ATM PROP NEW FLG) (* wt%: "25-FEB-80 09:40") (* ;; "If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.") (* ;; "Value is new PROP value.") (COND ((NULL ATM) (ERRORX (LIST 7 (LIST PROP NEW)))) ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM)))) (PROG ((X (GETPROPLIST ATM)) X0 TEM) LOOP (COND ((NLISTP X) (COND ((AND (NULL X) X0) (* ;; "typical case. property list ran out on an even parity position. fall through and add property at beginning of property list.") (SETQ TEM (LIST PROP (SETQ NEW (LIST NEW)))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (RETURN NEW))) (* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g. (A B . C)")) ((NLISTP (CDR X)) (* ;; "property list runs out on an odd parity, or else ends in a non-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) (/RPLACA (CDR X) (SETQ NEW (COND (FLG (CONS NEW (CADR X))) (T (/NCONC1 (CADR X) NEW))))) (RETURN NEW)) (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) (* ; "Add to beginning of property list.") (SETQ TEM (CONS PROP (CONS (SETQ NEW (LIST NEW)) (GETPROPLIST ATM)))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (SETPROPLIST ATM TEM) (RETURN NEW))) ) (/ATTACH (LAMBDA (X LST) (* wt%: 23-SEP-76 20 55) (COND ((LISTP LST) (/RPLNODE LST X (CONS (CAR LST) (CDR LST)))) ((NULL LST) (CONS X)) (T (ERRORX (LIST 4 LST))))) ) (/CONTROL (LAMBDA (FLG TTBL) (SETQ FLG (CONTROL FLG TTBL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /CONTROL) FLG TTBL) LISPXHIST)) FLG) ) (/DELETECONTROL (LAMBDA (TYPE MESSAGE TTBL) (SETQ TTBL (GETTERMTABLE TTBL)) (AND LISPXHIST MESSAGE (UNDOSAVE (LIST (QUOTE /DELETECONTROL) TYPE (DELETECONTROL TYPE NIL TTBL) TTBL) LISPXHIST)) (DELETECONTROL TYPE MESSAGE TTBL)) ) (/DREMOVE (LAMBDA (X Y) (COND ((NLISTP Y) NIL) ((EQ X (CAR Y)) (COND ((CDR Y) (/RPLNODE Y (CADR Y) (CDDR Y)) (/DREMOVE X Y)))) (T (PROG (Z) (SETQ Z Y) LP (COND ((NLISTP (CDR Y)) (RETURN Z)) ((EQ X (CADR Y)) (/RPLACD Y (CDDR Y))) (T (SETQ Y (CDR Y)))) (GO LP))))) ) (/DREVERSE (LAMBDA (X) (PROG (Y Z) R1 (COND ((NLISTP (SETQ Y X)) (RETURN Z))) (SETQ X (CDR X)) (SETQ Z (/RPLACD Y Z)) (GO R1))) ) (/DSUBST (LAMBDA (NEW OLD EXPR) (* wt%: "28-AUG-78 21:55") (PROG (B) (COND ((EQ OLD (SETQ B EXPR)) (RETURN (COPY NEW)))) LP (COND ((NLISTP EXPR) (RETURN B)) ((COND ((LITATOM OLD) (* ;; "Most uses involve substitution for an atom, and the check enables avoiding an extra function call (to equal)") (EQ OLD (CAR EXPR))) (T (EQUAL OLD (CAR EXPR)))) (/RPLACA EXPR (COPY NEW))) (T (/DSUBST NEW OLD (CAR EXPR)))) (COND ((AND OLD (EQ OLD (CDR EXPR))) (/RPLACD EXPR (COPY NEW)) (RETURN B))) (SETQ EXPR (CDR EXPR)) (GO LP))) ) (/ECHOCONTROL (LAMBDA (CHAR MODE TTBL) (SETQ TTBL (GETTERMTABLE TTBL)) (AND LISPXHIST MODE (UNDOSAVE (LIST (QUOTE /ECHOCONTROL) CHAR (ECHOCONTROL CHAR NIL TTBL) TTBL) LISPXHIST)) MODE (ECHOCONTROL CHAR MODE TTBL)) ) (/ECHOMODE (LAMBDA (FLG TTBL) (SETQ FLG (ECHOMODE FLG TTBL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /ECHOMODE) FLG TTBL) LISPXHIST)) FLG) ) (/LCONC (LAMBDA (PTR X) (PROG (XX) (RETURN (COND ((NULL X) PTR) ((OR (NLISTP X) (CDR (SETQ XX (LAST X)))) (SETQ XX X) (GO ERROR)) ((NULL PTR) (CONS X XX)) ((NLISTP PTR) (SETQ XX PTR) (GO ERROR)) ((NULL (CAR PTR)) (/RPLNODE PTR X XX)) (T (/RPLACD (CDR PTR) X) (/RPLACD PTR XX)))) ERROR (ERROR (QUOTE "bad argument - LCONC") XX))) ) (/LISTPUT (LAMBDA (LST PROP VAL) (* ; "Like PUT but works on lists.") (PROG ((X (OR (LISTP LST) (ERRORX (LIST 4 LST)))) X0) LOOP (COND ((NLISTP (CDR X)) (* ; "Odd parity; either (A B C) or (A B C . D) --- drop thru and add at beginning")) ((EQ (CAR X) PROP) (* ; "found it") (/RPLACA (CDR X) VAL) (RETURN VAL)) ((LISTP (SETQ X (CDDR (SETQ X0 X)))) (GO LOOP)) ((NULL X) (* ;; "Ran out without finding PROP on even parity. add at end If X is not NIL, means ended in a non-list following even parity, e.g. (A B . C) so drop through and add at front.") (/RPLACD (CDR X0) (LIST PROP VAL)) (RETURN VAL))) ADDFRONT (/RPLNODE LST PROP (CONS VAL (CONS (CAR LST) (CDR LST)))) (RETURN VAL))) ) (/LISTPUT1 (LAMBDA (LST PROP VAL) (* ;; "like listput but does one cdr at a time. inverse of listget1. used by undonlsetq") (PROG ((X LST)) LP (COND ((NLISTP X) (* ; "Note no checks for LST ending in dotted pairs.") (RETURN (/NCONC LST (LIST PROP VAL)))) ((EQ (CAR X) PROP) (COND ((CDR X) (/RPLACA (CDR X) VAL)) (T (/RPLACD X (LIST VAL)))) (RETURN LST))) (SETQ X (CDR X)) (GO LP))) ) (/MAPCON (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((SETQ MAPY (APPLY* MAPFN1 MAPX)) (COND (MAPE (/RPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (/MAPCONC (LAMBDA (MAPX MAPFN1 MAPFN2) (PROG (CL:MAPL MAPE MAPY) LP (COND ((NLISTP MAPX) (RETURN CL:MAPL)) ((SETQ MAPY (APPLY* MAPFN1 (CAR MAPX))) (COND (MAPE (/RPLACD MAPE MAPY)) (T (SETQ CL:MAPL (SETQ MAPE MAPY)))) (PROG NIL LP (COND ((SETQ MAPY (CDR MAPE)) (SETQ MAPE MAPY) (GO LP)))))) (SETQ MAPX (COND (MAPFN2 (APPLY* MAPFN2 MAPX)) (T (CDR MAPX)))) (GO LP))) ) (/MOVD (LAMBDA (FROM TO FLG) (* rmk%: " 9-JUN-82 21:49") (PROG ((NEWFLG (NULL (GETD TO)))) (COND ((NULL (GETD FROM)) (LISPXPRIN1 "****note: " T T) (LISPXPRIN2 FROM T T) (LISPXPRIN1 " has no definition " T T))) (/PUTD TO (COND (FLG (COPY (VIRGINFN FROM))) (T (GETD FROM)))) (AND (EXPRP TO) (MARKASCHANGED TO (QUOTE FNS) NEWFLG)) (AND ADDSPELLFLG (ADDSPELL TO)) (RETURN TO))) ) (/NCONC (LAMBDA L (PROG (VAL X TEM (N 0)) LP (COND ((EQ N L) (RETURN VAL))) (SETQ TEM (ARG L (SETQ N (ADD1 N)))) (COND ((LISTP X) (/RPLACD (SETQ X (LAST X)) TEM)) (T (SETQ VAL (SETQ X TEM)))) (GO LP))) ) (/NCONC1 (LAMBDA (LST X) (/NCONC LST (FRPLACD (CONS X LST))))) (/PUT (LAMBDA (ATM PROP VAL) (* ;; "Now called /PUTPROP but included for backwards compatibility.") (COND ((NULL ATM) (ERRORX (LIST 7 (LIST ATM PROP)))) ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM)))) (PROG ((X (GETPROPLIST ATM)) X0 TEM) 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 (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (RETURN VAL))) (* ;; "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) (/RPLACA (CDR X) VAL) (RETURN VAL)) (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) (SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM)))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (SETPROPLIST ATM TEM) (RETURN VAL))) ) (/PUTASSOC (LAMBDA (KEY VAL ALST) (* lmm%: 5 SEP 75 119) (PROG ((X (OR (LISTP ALST) (ERRORX (LIST 4 ALST))))) LP (COND ((EQ (CAR (OR (LISTP (CAR X)) (GO NEXT))) KEY) (/RPLACD (CAR X) VAL) (RETURN VAL))) NEXT (SETQ X (OR (LISTP (CDR X)) (PROGN (/RPLACD X (LIST (CONS KEY VAL))) (RETURN VAL)))) (GO LP))) ) (/PUTD (LAMBDA (FN DEF FLG) (* lmm "11-FEB-82 14:46") (PROG ((TEM (GETD FN))) (PUTD FN DEF FLG) (* ;; "The reason for doing the PUTD first is to avoid storing any undo information if the PUTD should cause an error --- e.g. if FN is non-atomic. If undo information were stored, then undoing the event would cause an error --- thereby preventing the rest of the undo information (if any) from being undone.") (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUTD) FN TEM) LISPXHIST)) (RETURN DEF))) ) (/PUTDQ (NLAMBDA (X Y) (/PUTD X Y) X)) (/PUTHASH (LAMBDA (ITEM VAL ARRAY) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUTHASH) ITEM (GETHASH ITEM ARRAY) ARRAY) LISPXHIST)) (PUTHASH ITEM VAL ARRAY)) ) (/PUTPROP (LAMBDA (ATM PROP VAL) (COND ((NULL ATM) (ERRORX (LIST 7 (LIST ATM PROP)))) ((NOT (LITATOM ATM)) (ERRORX (LIST 14 ATM)))) (PROG ((X (GETPROPLIST ATM)) X0 TEM) 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 (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (FRPLACD (CDR X0) TEM) (RETURN VAL))) (* ;; "propety 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) (/RPLACA (CDR X) VAL) (RETURN VAL)) (T (SETQ X (CDDR (SETQ X0 X))) (GO LOOP))) (SETQ TEM (CONS PROP (CONS VAL (GETPROPLIST ATM)))) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT-1) ATM TEM) LISPXHIST)) (SETPROPLIST ATM TEM) (RETURN VAL))) ) (/RADIX (LAMBDA (N) (* wt%: "16-MAY-79 19:15") (COND (N (SETQ N (RADIX N)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RADIX) N) LISPXHIST)) N) (T (RADIX)))) ) (/RAISE (LAMBDA (FLG TTBL) (* wt%: "16-MAY-79 19:13") (SETQ FLG (RAISE FLG TTBL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RAISE) FLG TTBL) LISPXHIST)) FLG) ) (/REMPROP (LAMBDA (ATM PROP) (COND ((NULL (LITATOM ATM)) (ERRORX (LIST 14 ATM)))) (PROG ((X (GETPROPLIST ATM)) X0 VAL) LP (COND ((OR (NLISTP X) (NLISTP (CDR X))) (RETURN VAL)) ((EQ (CAR X) PROP) (SETQ VAL PROP) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /PUT+1) ATM (CDR X0) X) LISPXHIST)) (COND (X0 (FRPLACD (CDR X0) (CDDR X))) (T (SETPROPLIST ATM (CDDR X)))) (SETQ X (CDDR X))) (T (SETQ X (CDDR (SETQ X0 X))))) (GO LP))) ) (/RPLACA (LAMBDA (LST Y) (* wt%: 20-OCT-76 5 10) (COND ((LISTP LST) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACA) LST (CAR LST)) LISPXHIST)) (RPLACA LST Y)) ((NULL LST) (AND Y (ERRORX (LIST 7 Y)))) (T (AND (LITATOM LST) (PRIN1 (QUOTE "Use SETTOPVAL to 'set' a top level value ") T)) (ERRORX (LIST 4 LST)))))) (/RPLACD (LAMBDA (LST Y) (* wt%: 20-OCT-76 5 11) (COND ((LISTP LST) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /RPLACD) LST (CDR LST)) LISPXHIST)) (RPLACD LST Y)) ((NULL LST) (AND Y (ERRORX (LIST 7 Y)))) (T (AND (LITATOM LST) (PRIN1 (QUOTE "Use SETPROPLIST to 'set' a property list ") T)) (ERRORX (LIST 4 LST)))))) (/RPLNODE (LAMBDA (X A D) (* Coombines action of /RPLACA and /RPLACD. In this case, it takes only 3 cells to save the undo informaion whereasa /RPLACA and /RPLACD take eight. However, even where only /RPLACA or /RPLACD is being performed, an equivalent /RPLNODE is still cheaper, 3 cells to four.) (COND ((LISTP X) (AND LISPXHIST (UNDOSAVE (CONS X (CONS (CAR X) (CDR X))) LISPXHIST)) (FRPLACA X A) (FRPLACD X D)) (T (ERRORX (LIST 4 X))))) ) (/RPLNODE2 (LAMBDA (X Y) (* rmk%: " 4-MAR-82 22:07") (COND ((AND Y (NLISTP Y)) (ERRORX (LIST 4 Y))) (T (/RPLNODE X (CAR Y) (CDR Y))))) ) (/SET (LAMBDA (NAME VALUE) (SAVESET NAME VALUE NIL (QUOTE NOPROPSAVE)))) (/SETA (LAMBDA (A N V) (* lmm%: 29-NOV-75 21%:21) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETA) A N (ELT A N)))) (SETA A N V)) ) (/SETATOMVAL (LAMBDA (ATM VAL) (* lmm "12-FEB-82 21:54") (COND ((NULL ATM) (AND VAL (ERRORX (LIST 6 VAL)))) ((EQ ATM T) (OR (EQ VAL T) (ERRORX (LIST 6 VAL)))) ((LITATOM ATM) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETATOMVAL) ATM (GETATOMVAL ATM)))) (SETATOMVAL ATM VAL)) (T (ERRORX (LIST 14 ATM))))) ) (/SETBRK (LAMBDA (LST FLG RDTBL) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETBRK) (GETBRK RDTBL) NIL RDTBL) LISPXHIST)) (SETBRK LST FLG RDTBL)) ) (/SETD (LAMBDA (A N V) (* lmm%: 29-NOV-75 20%:43) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETD) A N (ELTD A N)))) (SETD A N V)) ) (/SETPROPLIST (LAMBDA (ATM LST) (* lmm "15-Apr-84 13:03") (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETPROPLIST) ATM (GETPROPLIST ATM)))) (SETPROPLIST ATM LST)) ) (/SETREADTABLE (LAMBDA (RDTBL) (* wt%: " 7-FEB-79 22:59") (SETQ RDTBL (SETREADTABLE RDTBL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETREADTABLE) RDTBL))) RDTBL) ) (/SETSEPR (LAMBDA (LST FLG RDTBL) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETSEPR) (GETSEPR RDTBL) NIL RDTBL) LISPXHIST)) (SETSEPR LST FLG RDTBL)) ) (/SETSYNTAX (LAMBDA (CH CLASS TABLE) (COND (LISPXHIST (PROG (OLDCLASS OLDCH) (SELECTQ CLASS ((CHARDELETE DELETECHAR LINEDELETE DELETELINE RETYPE CTRLV CNTRLV EOL NONE) (* ;; "Reason for this is currently setsyntax doesnt return enough information to enable restoring, e.g. if you do (SETSYNTAX 1 'LINEDELETE), value is 17, but you dont know what 1 WAS. however, cant do a GETSYNTAX because that defaults to readtable when table is NIL. When setsyntax is fixed, this shuld be changed, since it will not work correctly if any terminal classes are added or changed.") (SETQ TABLE (GETTERMTABLE TABLE))) (AND (NULL TABLE) (SETQ TABLE (GETREADTABLE TABLE)))) (SETQ OLDCLASS (GETSYNTAX CH TABLE)) (UNDOSAVE (LIST (QUOTE /SETSYNTAX) CH OLDCLASS TABLE) LISPXHIST) (COND ((NUMBERP (SETQ OLDCH (SETSYNTAX CH CLASS TABLE))) (* ;; "Says that CLASS specified one of the unique classes, and oldch was the character that prviously had this CLASS.") (UNDOSAVE (LIST (QUOTE /SETSYNTAX) OLDCH (GETSYNTAX CH TABLE) TABLE) LISPXHIST) (* ;; "Restores the character that previously was this unique class. e.g. if you say (SETSYNTAX 1 17 (GETTERMTABLE)), this will restore 17 to LINEDELETE. The GETSYNTAX is necessary because in this example nowhere did the user mention LINEDELETE"))) (RETURN OLDCH))) (T (SETSYNTAX CH CLASS TABLE)))) ) (/SETTERMTABLE (LAMBDA (TTBL) (* wt%: " 7-FEB-79 22:59") (SETQ TTBL (SETTERMTABLE TTBL)) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETTERMTABLE) TTBL))) TTBL) ) (/SETTOPVAL (LAMBDA (ATM VAL) (* lmm "12-FEB-82 21:54") (COND ((NULL ATM) (AND VAL (ERRORX (LIST 6 VAL)))) ((EQ ATM T) (OR (EQ VAL T) (ERRORX (LIST 6 VAL)))) ((LITATOM ATM) (AND LISPXHIST (UNDOSAVE (LIST (QUOTE /SETTOPVAL) ATM (GETTOPVAL ATM)))) (SETTOPVAL ATM VAL)) (T (ERRORX (LIST 14 ATM))))) ) (/TCONC (LAMBDA (PTR X) (PROG (XX) (RETURN (COND ((NULL PTR) (CONS (SETQ XX (CONS X NIL)) XX)) ((NLISTP PTR) (ERROR (QUOTE "bad argument - TCONC") PTR)) ((NULL (CDR PTR)) (/RPLNODE PTR (SETQ XX (CONS X NIL)) XX)) (T (* ;; "The (FRPLACD (CONS)) is just a kluge to get the cons on the same page as (CDR PTR). can be taken out when we eliminate that part of cons algorithm") (/RPLACD PTR (CDR (/RPLACD (CDR PTR) (FRPLACD (CONS X (CDR PTR))))))))))) ) ) [SETQ LISPXFNS (UNION LISPXFNS (MAPCAR /FNS (FUNCTION (LAMBDA (X Y) (CONS (PACK (CDR (DUNPACK X CHCONLST))) X] (MOVD? 'RPLNODE 'FRPLNODE) (MOVD? 'RPLNODE2 'FRPLNODE2) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL UNSET RPLNODE RPLNODE2 /LISPXPUT /PUT-1 /PUT+1 (LINKFNS . T) UNDONLSETQ UNDONLSETQ1 (GLOBALVARS UNDOSTATS CLEARSTKLST DWIMFLG SPELLINGS3 LISPXHISTORY %#UNDOSAVES) RESETUNDO UNDOPRINT) (BLOCK%: NIL RPAQ RPAQQ (LOCALVARS . T)) (BLOCK%: SAVESET SAVESET (LOCALVARS . T) (GLOBALVARS CLEARSTKLST)) (BLOCK%: NIL UNDOSET (GLOBALVARS SPAGHETTIFLG)) (BLOCK%: NIL NEW/FN (GLOBALVARS TESTMODEFLG LISPXFNS CHCONLST /FNS)) (BLOCK%: UNDOLISPXBLOCK UNDOSAVE UNDOLISPX UNDOLISPX1 UNDOLISPX2 UNDOLISPX3 (ENTRIES UNDOSAVE UNDOLISPX UNDOLISPX1 UNDOLISPX2) (BLKLIBRARY LISPXWATCH) (GLOBALVARS UNDOSAVES UNDOSTATS %#UNDOSAVES DWIMFLG DWIMWAIT LISPXHISTORY CLISPTRANFLG EDITQUIETFLG MAXLEVEL) (LOCALFREEVARS UNDONEFLG)) (BLOCK%: NIL /ADDPROP /ATTACH /CONTROL /DELETECONTROL /DREMOVE /DREVERSE /DSUBST /ECHOCONTROL /ECHOMODE /LCONC /LISTPUT /LISTPUT1 /MAPCON /MAPCONC /MOVD /NCONC /NCONC1 /PRINTLEVEL /PUT /PUTASSOC /PUTD /PUTDQ /PUTHASH /PUTPROP /REMPROP /RPLACA /RPLACD /RPLNODE /RPLNODE2 /SET /SETA /SETBRK /SETD /SETPROPLIST /SETSEPR /SETSYNTAX /SETATOMVAL /SETTOPVAL /TCONC (GLOBALVARS UNDOSTATS) (LINKFNS . T)) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA /DEFINEQ SAVESETQ) (ADDTOVAR NLAML /PUTDQ UNDONLSETQ RPAQ? RPAQ RPAQQ SAVESETQQ) (ADDTOVAR LAMA /NCONC) ) (PUTPROPS UNDO COPYRIGHT ("Venue & Xerox Corporation" 1984 1986 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (4220 23392 (SAVESET 4230 . 8035) (UNDOSET 8037 . 8559) (SAVESETQ 8561 . 8692) ( SAVESETQQ 8694 . 8755) (RPAQQ 8757 . 8828) (RPAQ 8830 . 8940) (RPAQ? 8942 . 9141) (RPLNODE 9143 . 9236 ) (RPLNODE2 9238 . 9520) (NEW/FN 9522 . 9922) (UNDOSAVE 9924 . 10971) (UNDOLISPX 10973 . 12590) ( UNDOLISPX1 12592 . 13481) (UNDOPRINT 13483 . 13590) (UNDOLISPX2 13592 . 14897) (UNDOLISPX3 14899 . 16610) (UNSET 16612 . 17080) (/LISPXPUT 17082 . 17407) (/PUT-1 17409 . 17700) (/PUT+1 17702 . 18405) ( UNDONLSETQ 18407 . 20092) (UNDONLSETQ1 20094 . 20751) (RESETUNDO 20753 . 23106) (/DEFINEQ 23108 . 23174) (/DEFINE 23176 . 23215) (/PRINTLEVEL 23217 . 23390)) (24228 38955 (/ADDPROP 24238 . 25597) ( /ATTACH 25599 . 25768) (/CONTROL 25770 . 25909) (/DELETECONTROL 25911 . 26142) (/DREMOVE 26144 . 26412 ) (/DREVERSE 26414 . 26547) (/DSUBST 26549 . 27070) (/ECHOCONTROL 27072 . 27291) (/ECHOMODE 27293 . 27435) (/LCONC 27437 . 27771) (/LISTPUT 27773 . 28462) (/LISTPUT1 28464 . 28853) (/MAPCON 28855 . 29217) (/MAPCONC 29219 . 29588) (/MOVD 29590 . 29969) (/NCONC 29971 . 30178) (/NCONC1 30180 . 30246) ( /PUT 30248 . 31380) (/PUTASSOC 31382 . 31690) (/PUTD 31692 . 32185) (/PUTDQ 32187 . 32229) (/PUTHASH 32231 . 32390) (/PUTPROP 32392 . 33456) (/RADIX 33458 . 33616) (/RAISE 33618 . 33778) (/REMPROP 33780 . 34203) (/RPLACA 34205 . 34518) (/RPLACD 34520 . 34833) (/RPLNODE 34835 . 35279) (/RPLNODE2 35281 . 35421) (/SET 35423 . 35499) (/SETA 35501 . 35632) (/SETATOMVAL 35634 . 35939) (/SETBRK 35941 . 36088) (/SETD 36090 . 36222) (/SETPROPLIST 36224 . 36387) (/SETREADTABLE 36389 . 36555) (/SETSEPR 36557 . 36708) (/SETSYNTAX 36710 . 38033) (/SETTERMTABLE 38035 . 38196) (/SETTOPVAL 38198 . 38499) (/TCONC 38501 . 38953))))) STOP \ No newline at end of file diff --git a/sources/UNIXPRINT b/sources/UNIXPRINT new file mode 100644 index 00000000..6b854571 --- /dev/null +++ b/sources/UNIXPRINT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "16-Apr-2018 17:25:15" {DSK}kaplan>Local>medley3.5>library>UNIXPRINT.;10 14353 changes to%: (FNS InstallUnixPrinter UnixPrint UnixShellQuote UnixTempFile UnixPrintCommand) previous date%: " 7-Dec-2001 14:55:11" {DSK}kaplan>Local>medley3.5>library>UNIXPRINT.;9 ) (* ; " Copyright (c) 1990, 1991, 1992, 1993, 1995, 1997, 1999, 2001, 2018 by Venue. All rights reserved. ") (PRETTYCOMPRINT UNIXPRINTCOMS) (RPAQQ UNIXPRINTCOMS [(FNS InstallUnixPrinter UnixPrint UnixShellQuote UnixTempFile UnixPrintCommand) (FUNCTIONS ShellCommand) (INITVARS (UnixPrinterName NIL) (UNIXPRINTSWITCHES " -r -s ")) (P (* ;;  "(InstallUnixPrinter) commented out because POSTSCRIPT indirects according to platform") (PRIN1 "Please feel free to edit UnixPrintCommand." PROMPTWINDOW)) (PROP FILETYPE UNIXPRINT) (DECLARE%: DONTEVAL@COMPILE DOCOPY (FNS UnixPrintCommand)) (DECLARE%: EVAL@COMPILE DOCOPY (FILES UNIXCOMM)) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS UnixPrinterName)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA]) (DEFINEQ (InstallUnixPrinter [LAMBDA (PrinterTypes) (* ; "Edited 8-Feb-97 11:33 by rmk:") (* ;; "Set up any printers in PrinterTypes (or just Postscript by default) so that they'll be printed using the unix LPR command.") (DECLARE (GLOBALVARS PRINTERTYPES)) (for type inside (OR PrinterTypes '(POSTSCRIPT)) do (for x in PRINTERTYPES when (EQMEMB type (CAR x)) do (LET ((PRINTERTYPE type)) (PUTASSOC 'SEND (LIST 'UnixPrint) (CDR x]) (UnixPrint [LAMBDA (HOST FILE PRINTOPTIONS) (* ; "Edited 7-Dec-2001 14:55 by rmk:") (* ; "Edited 20-May-92 14:13 by nilsson") (* ;; "Given a print FILE, use the Unix %"lpr%" command to spool it to a printer.") (* ;; "The printer is named by HOST or UnixPrinterName, a Global variable.") [LET* ((PRINTER (OR HOST UnixPrinterName)) (COPIES (LISTGET PRINTOPTIONS '%#COPIES)) (NAME (LISTGET PRINTOPTIONS 'DOCUMENT.NAME)) (NSIDES (LISTGET PRINTOPTIONS '%#SIDES)) (TYPE (PRINTERTYPE PRINTER))) (* ;; "Removed redundant check (we already know it's a PS printer), JDS 2/19/92:") (* ;; "(COND ((NULL TYPE) (ERROR (CONCAT %"Printertype unknown for %" PRINTER))) ((NOT (EQL (U-CASE TYPE) 'POSTSCRIPT)) (ERROR (CONCAT %"Printertype for %" PRINTER %" is not Postscript%"))))") [COND ((OR (NULL NAME) (STRPOS "{LPT}" NAME 1 NIL T)) (SETQ NAME "Medley Output")) ((EQ (CHCON1 NAME) (CHARCODE {)) (SETQ NAME (UNPACKFILENAME.STRING NAME 'NAME)) (COND ((EQ (NCHARS NAME) 0) (SETQ NAME "Medley Output"] (* ;; "Don't break if you have trouble with preexisting files, e.g. because of protection.") (FOR F IN [CAR (NLSETQ (FILDIR (PACKFILENAME 'HOST 'DSK 'EXTENSION '* 'BODY (UnixTempFile 'medleyprint. T] WHEN (CAR (NLSETQ (IGREATERP (DIFFERENCE (IDATE) (GETFILEINFO F 'ICREATIONDATE)) 120))) DO (NLSETQ (DELFILE F))) (* ;; "The temp file's name will be of the form medleyprint., so all such files can be found for deletion on a subsequent call after a certain amount of time (2 minutes) has gone by. If we delete immediately, it may happen before lpr has done its thing. ") (CL:MULTIPLE-VALUE-BIND (tmpstream tmpname) (UnixTempFile 'medleyprint.) (COND (tmpstream (* ;; "First, copy the lisp file to /tmp so lpr can find it.") [CL:WITH-OPEN-STREAM (out tmpstream) (CL:WITH-OPEN-STREAM (in (OPENSTREAM FILE 'INPUT)) (printout PROMPTWINDOW .TAB0 0 "Spooling output to Unix printer" (COND (PRINTER (CONCAT " '" PRINTER "'")) (T "")) "...") (IF NSIDES THEN (* ;; "Have to put magic simplex/duplex stuff in the tmp file itself, after the first line, cause there is no other way to control some duplex printers.") (BIND C SAWCR DO (SETQ C (BIN in)) (IF (MEMB C (CHARCODE (CR LF))) THEN (BOUT out C) (SETQ SAWCR T) ELSEIF SAWCR THEN (* ;;  "First char of 2nd line: nonCR/LF after CR/LF") (* ;;  "Put out simplex header, then print character in C") (PRINTOUT out "%%BeginSetup" T) (PRINTOUT out "[{" T "%%%%BeginFeature: *Duplex Simplex" T "<< /Duplex " (CL:IF (EQ NSIDES 1) "false" "true") " /Tumble false >> setpagedevice" T "%%%%EndFeature" T "} stopped cleartomark" T) (PRINTOUT out "%%EndSetup" T) (BOUT out C) (COPYCHARS in out (GETFILEPTR in) -1) (RETURN) ELSE (BOUT out C))) ELSE (COPYCHARS in out 0 -1] (* ;; "Now make Unix print the /tmp file.") (ShellCommand (UnixPrintCommand PRINTER COPIES NAME tmpname) PROMPTWINDOW) (printout PROMPTWINDOW "done" T)) (T (ERROR "Couldn't create unix temp file"] T]) (UnixShellQuote [LAMBDA (STRING) (DECLARE (LOCALVARS . T)) (* ; "Edited 19-Apr-89 21:14 by TAL") (LET* ((X (CHCON STRING)) (CT X) C FLG) [while (LISTP CT) do (SETQ C (CAR CT)) (COND ([OR (<= (CHARCODE a) C (CHARCODE z)) (<= (CHARCODE A) C (CHARCODE Z)) (<= (CHARCODE 0) C (CHARCODE 9)) (FMEMB C (CHARCODE (- /] (SETQ CT (CDR CT))) (T (SETQ FLG T) (RPLNODE CT (CHARCODE \) (CONS (COND ((FMEMB C (CHARCODE (CR LF))) (CHARCODE SPACE)) (T C)) (SETQ CT (CDR CT] (COND (FLG (CONCATCODES X)) (T STRING]) (UnixTempFile [LAMBDA (Prefix DontOpen) (* ; "Edited 28-Apr-93 13:49 by rmk:") (* ; "Edited 12-Jan-89 19:07 by TAL") (LET* ([host (AND (BOUNDP 'FISTempDir) (UNPACKFILENAME.STRING FISTempDir 'HOST] (dir (OR [COND ((OR (STRING-EQUAL host "UNIX") (STRING-EQUAL host "DSK")) (UNPACKFILENAME.STRING FISTempDir 'DIRECTORY] "tmp")) (str (CONCAT (OR Prefix "") (IDATE))) file unix) (COND ([for i from 1 to 100 thereis (NOT (INFILEP (SETQ file (CONCAT "{UNIX}" (SETQ unix (CONCAT "/" dir "/" str i] (CL:VALUES [COND (DontOpen file) (T (* ;;  "Type TEXT seems to be important for Apple LaserWriters at PARC") (OPENSTREAM file 'OUTPUT NIL '((TYPE TEXT] unix]) (UnixPrintCommand [LAMBDA (PRINTER COPIES NAME TMPNAME) (* ; "Edited 30-Apr-93 20:46 by rmk:") (* ; "Edited 20-May-92 14:26 by nilsson") (* ;; "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like %"/usr/ucb/lpr tmpname%". The arguments to this function are:") (* ;; " PRINTER - the name of the printer. Usually something like lw or plw.") (* ;; "COPIES - how many copies of this job to be printed.") (* ;; "NAME - the name of this job. This gets printed on the banner of your job.") (* ;;  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") (* ;; "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") (* ;; "UNIXPRINTSWITCHES makes it easy for other sites to change just the lpr switches.") (CONCAT "/usr/ucb/lpr " (COND (PRINTER (CONCAT "-P" (UnixShellQuote PRINTER) " ")) (T "")) (COND ((AND (FIXP COPIES) (NEQ COPIES 1)) (CONCAT "-#" COPIES " ")) (T "")) " -J" (UnixShellQuote NAME) " " (OR UNIXPRINTSWITCHES "") " " TMPNAME]) ) (CL:DEFUN ShellCommand (Cmd &OPTIONAL (Output T)) (CL:WITH-OPEN-STREAM (s (CREATE-PROCESS-STREAM Cmd)) (CL:TAGBODY [SETFILEINFO s 'ENDOFSTREAMOP #'(CL:LAMBDA (s) (GO OUT] (CL:LOOP (PRINTCCODE (READCCODE s) Output)) OUT)) NIL) (RPAQ? UnixPrinterName NIL) (RPAQ? UNIXPRINTSWITCHES " -r -s ") (* ;; "(InstallUnixPrinter) commented out because POSTSCRIPT indirects according to platform") (PRIN1 "Please feel free to edit UnixPrintCommand." PROMPTWINDOW) (PUTPROPS UNIXPRINT FILETYPE :COMPILE-FILE) (DECLARE%: DONTEVAL@COMPILE DOCOPY (DEFINEQ (UnixPrintCommand [LAMBDA (PRINTER COPIES NAME TMPNAME) (* ; "Edited 30-Apr-93 20:46 by rmk:") (* ; "Edited 20-May-92 14:26 by nilsson") (* ;; "This function is called when the user wants to UNIXPRINT a file. It has to return a string that when sent to a shell prints the file tmpname. In the cub version this should look something like %"/usr/ucb/lpr tmpname%". The arguments to this function are:") (* ;; " PRINTER - the name of the printer. Usually something like lw or plw.") (* ;; "COPIES - how many copies of this job to be printed.") (* ;; "NAME - the name of this job. This gets printed on the banner of your job.") (* ;;  "TMPNAME - The name of the temporary file that contains the postscript code for this job. ") (* ;; "Note the clever function UnixShellQuote. It converts any lisp name to a string that is quoted according to /bin/sh syntax") (* ;; "UNIXPRINTSWITCHES makes it easy for other sites to change just the lpr switches.") (CONCAT "/usr/ucb/lpr " (COND (PRINTER (CONCAT "-P" (UnixShellQuote PRINTER) " ")) (T "")) (COND ((AND (FIXP COPIES) (NEQ COPIES 1)) (CONCAT "-#" COPIES " ")) (T "")) " -J" (UnixShellQuote NAME) " " (OR UNIXPRINTSWITCHES "") " " TMPNAME]) ) ) (DECLARE%: EVAL@COMPILE DOCOPY (FILESLOAD UNIXCOMM) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS UnixPrinterName) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA ) ) (PUTPROPS UNIXPRINT COPYRIGHT ("Venue" 1990 1991 1992 1993 1995 1997 1999 2001 2018)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1462 11626 (InstallUnixPrinter 1472 . 2080) (UnixPrint 2082 . 7153) (UnixShellQuote 7155 . 8709) (UnixTempFile 8711 . 10019) (UnixPrintCommand 10021 . 11624)) (11628 12001 (ShellCommand 11628 . 12001)) (12335 13950 (UnixPrintCommand 12345 . 13948))))) STOP \ No newline at end of file diff --git a/sources/UNIXPRINT.TEDIT b/sources/UNIXPRINT.TEDIT new file mode 100644 index 0000000000000000000000000000000000000000..49a4e0a3b3a139ba83356148d579750d3886d194 GIT binary patch literal 6583 zcmeHLO>^7k5q>4dsU4SXr^)otuh}Y|2{}Vi5^c+lZ?FW~X!sQXbnRq(07+0p4FVVd zl+2uZ?X9=`lOEc?ke|_GXL8NWeRlCd(xe>})-_9~X5(3%23_M>-!!^*<>-obYY1x(mF3fMr7{S- zSN+%vQu5t2p+z_+Cyt%q%%wD>sdMh)5|2k=w4lU=+SrTTQR**v*`a=zq}C|*qLd;= zabr6794xStOhlt_Hgke;gXlTXM@|5sls&~Xb|=o<&uzWnjHbY&B&2leq~xXW9Yt=C zkTXxinUi`W$M+YFO0!Zif+WQQWMLp#3Z3yXZ;jKIX0;o1GEZRWedR8fPI{e=);(=h z?5UekNv8<*A_UPOjYFT#o!E1Rz6-Ze6o&}RNnL+YCno{p1mOAj<{yF4(h%KCyi3*&Vo77hjy#R5$WN;dx9Fgfx+}I69 zE_Iw>?)X%VS;DCoMYBVbFb4FQ8@MsnGjI_dI?pd}_Gd0AMuj+VC)l|9o z4&ZGjccGfB$OozmM$aILa;y|uKzglEgNvy*nsOvS4b>c47r+UC%Kql~j^xUIU6D7i zLWplFv9WwAnm*zs@M12ToLJ%r>e3J6XI5vxIu}chb!qPlXHp}0nBkY1ja9~=1sUhV zRj(xS2w1LU#FO|7KY{46t&iUYES7m7XnJCoKt7b!EK1H$miLFRRmG2D+V77YFIiB7 ze=F#?K&DmRQ(4QD(=4y)o|x=$yBZTwABPl#DL(OxM+qg7JMtzA?2%%AaevokM7@cI za&?WiOrK(|l;fuuZD$y5<$&dlI#1B!5n-Eh5W@w{!Z953u;X1bnFk}@u2ecZSsj-# zQR1a8&74KCZGF$`&Wu9fU?xnlf#Cw7w%}|s7pWKUHWrq=G3P6z7CvPLCyOL? zXLZ8fb-=ZpFe{62&*P_2slLgQWbWxEo%H&KZc$h3=wx^L{9VJAD#CkFG2L_?^CYJv z#Yw@@^N3G4K^UeBIv9GvK{74IPZ=gACMPPw$-tu*C(S4vyA84-bmFu53{wlRv0HGd z=Va;`8yr0aqeh{^ei@W&%_CVHWak&oj4TwWpxRtGhbG>usAv`DJ`FE8Cks%CJe(7# zv+zZ0N(OTHJkqSQ#)OQsqoEUET2tiUjD>H>b8*HZtSouk7@|y37&{oz6Ayz{5(m#X z;Sjupu%07190dN4;jmHBaQ6B>bKNXszES9i_Vn0$xkq~k=`1>!gkic@Ll0(yJC+*a ze4e@Kl=Dyy?>y4IgLx7k%tyn6)g8P4@e%F+o^fd(`#7N`c7ymB2I4%%DaVB^%29OA z#>U{xB=acpJ@n0mmrkkUj(vC0kkx!SzR;=drua~rY(QWmps+rm&wRWX_49#tN~ZDniCv?UCz_dytpR(^-Z&1) z=sq`YwCRy!XUoW5jpfgu~T{i|DCZ?N(=Ygf;WgWTU zfnnLtK^J#5B+cw-NX|yqkd@~BLpr)g%?A(Y&T%c%uRhVWQ{*zsRsLW<2Z>g%$4NF} zc<(MX@6)||t9G{j%oZaiz#9DT@GjkN-pQbAFx*;Q-L^5kFRL!B-o2J>z4gCYN+kOS zSMup4mAteA&~8?bS2M%=$IW-_f#U~v|9d^~|NZo+hKUWM^6j|C-hw3m_-p!)Cv7)`@w#Bjn z{*Aoc;_;sMjk;M*i|<82L@NbZM=85)3yPj|;q>iXdke~q{Oo%Ay&&tou|}l;F}HxQ z=smRXFVqd3WgVldwbcii9%y~2uG@yKbqf&|K2q=F&u@4+C}eQF#duBgCnez0`sZ6@ zx#Mg_?P8B%XQ>@^>xqfK_cb2tcB{Ly$w2g_6L~AL2^-$y+d}YT5nlm`4cCxvK_EN} zXcklaKymlfv*i?*Gby0-A@x+mM!}&5;;^ zO|Id}Wl*bvDCW;ZKH@yS`Gz8BQ9DDKaPvu7tz@zhMk!DdhOF$@^D@j)cwY<)$xVlmG7( zDdJj`#Sx=5iKy|V)Y&X)$)eOLt%NDBZ#47oAe3N47kWEi6cP@Qvn~tD1oSr~`-Oy2*^3Y_Q26-0oojsXwfgf{fBP4Z_f)C? literal 0 HcmV?d00001 diff --git a/sources/UNWINDMACROS b/sources/UNWINDMACROS new file mode 100644 index 00000000..f0431782 --- /dev/null +++ b/sources/UNWINDMACROS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "17-May-90 16:11:33" {DSK}local>lde>lispcore>sources>UNWINDMACROS.;2 12143 changes to%: (VARS UNWINDMACROSCOMS) previous date%: "27-May-87 16:49:53" {DSK}local>lde>lispcore>sources>UNWINDMACROS.;1) (* ; " Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT UNWINDMACROSCOMS) (RPAQQ UNWINDMACROSCOMS ( (* ;; "macros for use with the new unwinder ") (FUNCTIONS NLSETQ ERSETQ) (MACROS RESETLST RESETFORM RESETVARS XNLSETQ RESETVAR RESETSAVE UNDONLSETQ) (PROP DMACRO CL:CATCH CL:THROW CL:UNWIND-PROTECT) (MACROS .CATCH. .UNWIND.PROTECT. .RESETLST.) (FNS COMP.CATCH COMP.UNWIND-PROTECT) (ADDVARS (SYSSPECVARS SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*)) (PROP FILETYPE UNWINDMACROS))) (* ;; "macros for use with the new unwinder ") (DEFMACRO NLSETQ (&BODY FORMS) (* ;; "Effectively (proceed-case (handler-bind ...)) but expanded by hand for efficiency.") `(LET (SI::NLSETQ-VALUE) (CL:IF (EQ (LET ((*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*)) (SI::*NLSETQFLAG* T) (*CONDITION-HANDLER-BINDINGS* (CONS '(CL:ERROR . SI::NLSETQHANDLER) *CONDITION-HANDLER-BINDINGS*))) (DECLARE (SPECVARS SI::*NLSETQFLAG*)) (CL:CATCH *PROCEED-CASES* [CL:SETQ SI::NLSETQ-VALUE (LIST (PROGN ,@FORMS] :NORMAL)) :NORMAL) SI::NLSETQ-VALUE NIL))) (DEFMACRO ERSETQ (&BODY FORMS) (* ;; "Effectively (proceed-case ...), but hand-expanded for efficiency.") `(LET (SI::NLSETQ-VALUE) (CL:IF (EQ (LET ((*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*)) (SI::*NLSETQFLAG* NIL)) (DECLARE (SPECVARS SI::*NLSETQFLAG*)) (CL:CATCH *PROCEED-CASES* [CL:SETQ SI::NLSETQ-VALUE (LIST (PROGN ,@FORMS] :NORMAL)) :NORMAL) SI::NLSETQ-VALUE NIL))) (DECLARE%: EVAL@COMPILE (PUTPROPS RESETLST MACRO [(X . Y) (.RESETLST. (PROGN X . Y) NIL ((LISPXHIST LISPXHIST) (RESETSTATE NIL]) (PUTPROPS RESETFORM MACRO [TAIL `(.RESETLST. (PROGN ,@(CDR TAIL)) (LIST (LIST (LIST ',(CAAR TAIL) ,(CAR TAIL]) (PUTPROPS RESETVARS MACRO [TAIL (LET [(VARS (MAPCAR (CAR TAIL) (FUNCTION (LAMBDA (Z) (SETQ Z (MKLIST Z)) [COND ([AND EMFLAG (NOT (COMP.GLOBALVARP (CAR Z] (COMPERRM (LIST (CAR Z) "- not GLOBALVAR in RESETVARS"] Z] `(.RESETLST. (PROG NIL (* ;  "Set the variables to new values, execute forms, all inside a prog") ,.[MAPCAR VARS (FUNCTION (LAMBDA (V) (CONS 'SETQ V] ,@(CDR TAIL)) (PROGN (* ;  "Initialize *RESETFORMS* to list of vars and old values") (LIST ,@(MAPCAR VARS (FUNCTION (LAMBDA (V) `(CONS ',(CAR V) ,(CAR V]) (PUTPROPS XNLSETQ MACRO ((X) (NLSETQ X))) (PUTPROPS RESETVAR MACRO [(VAR VAL FORM) (.RESETLST. (PROGN (SETTOPVAL 'VAR VAL) FORM) (LIST (CONS 'VAR (GETTOPVAL 'VAR]) (PUTPROPS RESETSAVE MACRO [X `(SETQ SI::*RESETFORMS* (CONS ,[COND [(AND (ATOM (CAR X)) (CAR X)) (SUBPAIR '(VAR VAL) X '(PROG1 (CONS 'VAR (GETTOPVAL 'VAR)) (SETTOPVAL 'VAR VAL))] [(CDR X) `(LIST ,(CADR X) ,(CAR X] (T `(LIST (LIST ',(COND ((EQ (CAAR X) 'SETQ) (CAR (CADDAR X))) (T (CAAR X))) ,(CAR X] SI::*RESETFORMS*]) (PUTPROPS UNDONLSETQ MACRO ((UNDOFORM UNDOFN) (PROG ((LISPXHIST LISPXHIST) UNDOSIDE0 UNDOSIDE UNDOTEM) (DECLARE (SPECVARS LISPXHIST)) [COND ([LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST 'SIDE] (SETQ UNDOSIDE0 (CDR UNDOSIDE))) (T (SETQ UNDOSIDE0 UNDOSIDE) (SETQ UNDOSIDE (LIST 0)) (COND (LISPXHIST (LISTPUT1 LISPXHIST 'SIDE UNDOSIDE)) (T (SETQ LISPXHIST (LIST 'SIDE UNDOSIDE] (RESETVARS (%#UNDOSAVES) (SETQ UNDOTEM (XNLSETQ UNDOFORM NIL UNDOFN))) (COND ((EQ UNDOSIDE0 'NOSAVE) (LISTPUT1 LISPXHIST 'SIDE 'NOSAVE)) (T (UNDOSAVE))) (COND (UNDOTEM (RETURN UNDOTEM))) (UNDONLSETQ1 (CDR UNDOSIDE) (LISTP UNDOSIDE0)) (RETURN)))) ) (PUTPROPS CL:CATCH DMACRO ((TAG . BODY) (.CATCH. TAG (PROGN . BODY)))) (PUTPROPS CL:THROW DMACRO (DEFMACRO (TAG VALUE) [COND [(NLISTP VALUE) (* ; "simple one-valued case") `(SI::INTERNAL-THROW ,TAG ,VALUE] [(EQ (CAR VALUE) 'CL:VALUES) (* ; "simple multi-valued case") `(SI::INTERNAL-THROW ,TAG ,@(CDR VALUE] (T (* ; "general multi-valued case") `(SI::INTERNAL-THROW-VALUES ,TAG (CL:MULTIPLE-VALUE-LIST ,VALUE])) (PUTPROPS CL:UNWIND-PROTECT DMACRO (DEFMACRO (FORM &REST CLEANUP-FORMS) `(CL:MULTIPLE-VALUE-PROG1 (.UNWIND.PROTECT. [FUNCTION ,(COND ((AND (NULL (CDR CLEANUP-FORMS)) (LISTP (CAR CLEANUP-FORMS)) (NULL (CDAR CLEANUP-FORMS))) (* ;  "Optimize case of no-argument single cleanup fn") (CAAR CLEANUP-FORMS)) (T `(LAMBDA NIL ,@CLEANUP-FORMS] ,FORM) ,@CLEANUP-FORMS))) (DECLARE%: EVAL@COMPILE (PUTPROPS .CATCH. DMACRO (APPLY COMP.CATCH)) (PUTPROPS .UNWIND.PROTECT. DMACRO (APPLY COMP.UNWIND-PROTECT)) (PUTPROPS .RESETLST. DMACRO (DEFMACRO (FORM &OPTIONAL INIT OTHERBINDINGS) `(LET ((SI::*RESETFORMS* ,INIT) ,@OTHERBINDINGS) [DECLARE (SPECVARS SI::*RESETFORMS* ,@(MAPCAR OTHERBINDINGS 'CAR] (CL:UNWIND-PROTECT ,FORM (SI::RESETUNWIND))))) ) (DEFINEQ (COMP.CATCH [LAMBDA (ARG FORM) (* ; "Edited 27-May-87 16:48 by bvm:") (* ;;; "Compiles the separate subfunction for CATCH. The sub-function is a fn of one argument, ARG (the catch tag). FORM is the code to execute inside the subfn") (* ;; "SI::*DUMMY-FOR-CATCH* atrocity is to get the catch tag in pvar 1--assumes bytecompiler does not gratuitously rearrange pvars. Avoid naming ivar0 to reduce clutter of name table.") (COMP.CALL [COMP.LAM1 `(LAMBDA NOBIND (LET [(SI::*DUMMY-FOR-CATCH* T) (SI::*CATCH-RETURN-FROM* ((OPCODES (IVAR 0] (DECLARE (CL:SPECIAL SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*) ) ,FORM] (LIST ARG) 0]) (COMP.UNWIND-PROTECT [LAMBDA (CLEANUPFN FORM) (* bvm%: " 1-Jul-86 11:42") (* ;;; "Compiles the separate subfunction for UNWIND-PROTECT and friends. Frame's name is SI::*UNWIND-PROTECT* and its sole arg is the cleanup fn. FORM is the form to execute inside the separate frame.") (COMP.CALL [COMP.LAM1 `(LAMBDA (SI::*CLEANUP-FORMS*) (DECLARE (SPECVARS SI::*CLEANUP-FORMS*)) (\CALLME 'SI::*UNWIND-PROTECT*) ,FORM] (LIST CLEANUPFN) 0]) ) (ADDTOVAR SYSSPECVARS SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*) (PUTPROPS UNWINDMACROS FILETYPE COMPILE-FILE) (PUTPROPS UNWINDMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (10378 11912 (COMP.CATCH 10388 . 11304) (COMP.UNWIND-PROTECT 11306 . 11910))))) STOP \ No newline at end of file diff --git a/sources/VANILLADISK b/sources/VANILLADISK new file mode 100644 index 00000000..110b8813 --- /dev/null +++ b/sources/VANILLADISK @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "17-May-90 16:13:16" |{DSK}local>lde>lispcore>sources>VANILLADISK.;2| 5292 |changes| |to:| (VARS VANILLADISKCOMS) |previous| |date:| " 7-Apr-88 17:53:38" |{DSK}local>lde>lispcore>sources>VANILLADISK.;1| ) ; Copyright (c) 1985, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT VANILLADISKCOMS) (RPAQQ VANILLADISKCOMS ((FNS \\VANILLADISKINIT \\VANILLAHOSTNAMEP \\VANILLAEVENTFN) (INITVARS (\\PSEUDODSK)) (GLOBALVARS \\PSEUDODSK \\DISKNAMECASEARRAY) (DECLARE\: DONTEVAL@LOAD (P (\\VANILLADISKINIT))) (LOCALVARS . T))) (DEFINEQ (\\vanilladiskinit (lambda nil (* |bvm:| "30-Jan-85 21:43") (prog ((arr (copyarray uppercasearray))) (* * |Set| |up| |array| |that| |maps| |illegal| |filename| |chars| |to| 0  |and| |synonymous| |characters| |to| \a |canonical| |char|) (|for| i |from| 0 |to| (sub1 (charcode 0)) |do| (setcasearray arr i 0)) (* |Non-printing| |characters|  |verboten|) (|for| i |from| (add1 (charcode 9)) |to| (sub1 (charcode a)) |do| (setcasearray arr i 0)) (|for| i |from| (add1 (charcode z)) |to| (sub1 (charcode \a)) |do| (setcasearray arr i 0)) (|for| i |from| (add1 (charcode \z)) |to| \\maxchar |do| (setcasearray arr i 0)) (setcasearray arr (charcode \;) (charcode \;)) (setcasearray arr (charcode !) (charcode \;)) (setcasearray arr (charcode *) (charcode *)) (setcasearray arr (charcode escape) (charcode *)) (setcasearray arr (charcode ?) (charcode \#)) (setcasearray arr (charcode \.) (charcode \.)) (setcasearray arr (charcode -) (charcode -)) (setcasearray arr (charcode +) (charcode +)) (setcasearray arr (charcode $) (charcode $)) (setq \\disknamecasearray arr)) (* * |Define| \a |device| |whose| |sole| |purpose| |is| |to| |select| |the|  |appropriate| dsk |device| |depending| |on| |which| |machine| |you're| |on|) (\\definedevice nil (|create| fdev devicename _ "VANILLADISK" eventfn _ (function nill) hostnamep _ (function \\vanillahostnamep))))) (\\vanillahostnamep (lambda (name) (* \; "Edited 7-Apr-88 17:20 by masinter") (* |bvm:| "30-Jan-85 21:57") (* |;;;| "Fires up the appropriate file system for the machine you're running on") (selectq (machinetype) ((dandelion dove) (* |;;;| "If there is a valid Lisp directory on the disk, use that; otherwise use the pseudo-disk coredevice") (cond ((neq name 'dsk) (* \;  "Not interested in any other names") nil) ((and (getd '|\\LFOpenDevice|) (|\\LFOpenDevice|))) (t (* |;;;| "Define the PSEUDO-DSK device, if it hasn't been defined yet, and make DSK synonymous with it. On LOGOUT, the name DSK is disassociated with this device, but the device remains") (cond ((not \\pseudodsk) (coredevice 'pseudo-dsk) (setq \\pseudodsk (\\getdevicefromname 'pseudo-dsk)) (|replace| (fdev eventfn) |of| \\pseudodsk |with| (function \\vanillaeventfn)))) (\\definedevice 'dsk \\pseudodsk) \\pseudodsk))) (maiko (selectq name (unix (|\\UFSOpenDevice|)) (dsk (|\\DSKOpenDevice|)) nil)) ((dolphin dorado) (\\m44hostnamep name)) nil))) (\\vanillaeventfn (lambda (fdev event) (* |bvm:| "30-Jan-85 21:54") (* * |Disassociates| |the| |name| dsk |from| |the| |pseudo| |disk,| |in|  |case| |there's| \a |real| |disk| |on| |the| |machine| |now|) (selectq event ((afterlogout aftersysout aftermakesys aftersavevm) (\\removedevice.names fdev 'dsk)) nil))) ) (RPAQ? \\PSEUDODSK ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \\PSEUDODSK \\DISKNAMECASEARRAY) ) (DECLARE\: DONTEVAL@LOAD (\\VANILLADISKINIT) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (PUTPROPS VANILLADISK COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (784 4970 (\\VANILLADISKINIT 794 . 2901) (\\VANILLAHOSTNAMEP 2903 . 4547) ( \\VANILLAEVENTFN 4549 . 4968))))) STOP \ No newline at end of file diff --git a/sources/WALKER b/sources/WALKER new file mode 100644 index 00000000..4ed88405 --- /dev/null +++ b/sources/WALKER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "17-May-90 16:15:41" IL:|{DSK}local>lde>lispcore>sources>WALKER.;2| 36211 IL:|changes| IL:|to:| (IL:VARS IL:WALKERCOMS) IL:|previous| IL:|date:| "13-Jul-88 17:37:52" IL:|{DSK}local>lde>lispcore>sources>WALKER.;1| ) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:WALKERCOMS) (IL:RPAQQ IL:WALKERCOMS ( (IL:* IL:|;;| "A simple code walker. ") (IL:VARIABLES *DECLARATIONS* *ENVIRONMENT* *LEXICAL-VARIABLES* *WALK-FORM* *WALK-FUNCTION* *WALK-COPY*) (IL:FUNCTIONS WALK-FORM WALK-FORM-INTERNAL WALK-TEMPLATE) (IL:COMS (IL:FUNCTIONS VARIABLE-GLOBALLY-SPECIAL-P VARIABLE-LEXICAL-P VARIABLE-LEXICALLY-BOUNDP VARIABLE-SPECIAL-P) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:MOVD 'VARIABLE-LEXICAL-P 'IL:VARIABLE-LEXICAL-P) (IL:MOVD 'VARIABLE-SPECIAL-P 'IL:VARIABLE-SPECIAL-P)))) (IL:FUNCTIONS WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1) (IL:FUNCTIONS RECONS RELIST* RELIST*-INTERNAL) (IL:FUNCTIONS WALK-ARGLIST WALK-BINDINGS-1 WALK-BINDINGS-2 WALK-COMPILER-LET WALK-DECLARATIONS WALK-DO WALK-DO* WALK-DO/DO* WALK-FLET/LABELS WALK-LAMBDA WALK-LET WALK-LET* WALK-LET/LET* WALK-MACROLET WALK-MULTIPLE-VALUE-BIND WALK-PROG WALK-PROG* WALK-TAGBODY WALK-TAGBODY-1 WALK-UNEXPECTED-DECLARE WITH-NEW-CONTOUR) (IL:FUNCTIONS MAKE-LEXICAL-ENVIRONMENT ADD-MACROLET-ENVIRONMENT ADD-LABELS/FLET-ENVIRONMENT NOTE-DECLARATION NOTE-LEXICAL-BINDING) (IL:COMS (IL:DEFINE-TYPES WALKER-TEMPLATES) (IL:FUNCTIONS DEFINE-WALKER-TEMPLATE GET-WALKER-TEMPLATE GET-WALKER-TEMPLATE-INTERNAL)) (IL:* IL:|;;| "Templates for special forms") (WALKER-TEMPLATES AND BLOCK CATCH COMPILER-LET COND DECLARE DO DO* EVAL-WHEN FLET FUNCTION GO IF LABELS LAMBDA LET LET* MACROLET MULTIPLE-VALUE-BIND MULTIPLE-VALUE-CALL MULTIPLE-VALUE-PROG1 MULTIPLE-VALUE-SETQ OR PROG PROG* PROGN PROGV QUOTE RETURN-FROM SETQ TAGBODY THE THROW UNWIND-PROTECT) (IL:* IL:|;;|  "For Interlisp. Do not remove the template for IL:SETQ or the loadup may break.") (WALKER-TEMPLATES IL:LOAD-TIME-EVAL IL:SETQ IL:RPAQ? IL:RPAQ IL:XNLSETQ IL:ERSETQ IL:NLSETQ IL:RESETVARS) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:WALKER))) (IL:* IL:|;;| "A simple code walker. ") (DEFVAR *DECLARATIONS* (IL:* IL:|;;| " *declarations* is a list of the declarations currently in effect.") ) (DEFVAR *ENVIRONMENT* (IL:* IL:|;;| "An environment of the kind that macroexpand-1 gets as its second argument. in fact that is exactly where it comes from. For more info see: MAKE-LEXICAL-ENVIRONMENT") ) (DEFVAR *LEXICAL-VARIABLES* (IL:* IL:|;;| " *lexical-variables* is a list of the variables bound in the current contour. In *lexical-variables* the cons whose car is the variable is meaningful in the sense that the cons whose car is the variable can be used to keep track of which contour the variable is bound in.") ) (DEFVAR *WALK-FORM* (IL:* IL:|;;| "*walk-form* is used by the IF template. When the first argument to the if template is a list it will be evaluated with *walk-form* bound to the form currently being walked.") ) (DEFVAR *WALK-FUNCTION* (IL:* IL:|;;| "*walk-function* is the function being called on each sub-form as we walk. Normally it is supplied using the :walk-function keyword argument to walk-form, but it is OK to bind it around a call to walk-form-internal.") ) (DEFVAR *WALK-COPY*) (DEFUN WALK-FORM (FORM &KEY ((:DECLARATIONS *DECLARATIONS*) NIL) ((:LEXICAL-VARIABLES *LEXICAL-VARIABLES*) NIL) ((:ENVIRONMENT *ENVIRONMENT*) NIL) ((:COPY *WALK-COPY*) T) ((:WALK-FUNCTION *WALK-FUNCTION*) #'(LAMBDA (X Y) (DECLARE (IGNORE Y)) X))) (IL:* IL:|;;| " The main entry-point is walk-form, calls back in should use walk-form-internal.") (IL:* IL:|;;| "If :COPY is true (default), will return the expansion ") (LET ((RESULT (WALK-FORM-INTERNAL FORM ':EVAL))) (AND *WALK-COPY* RESULT))) (DEFUN WALK-FORM-INTERNAL (FORM CONTEXT &AUX NEWFORM NEWNEWFORM WALK-NO-MORE-P MACROP FN TEMPLATE ) (IL:* IL:|;;| "WALK-FORM-INTERNAL is the main driving function for the code walker. It takes a form and the current context and walks the form calling itself or the appropriate template recursively. ") (IL:* IL:|;;| "It is recommended that a program-analyzing-program process a form that is a list whose car is a symbol as follows: ") (IL:* IL:|;;| " 1. If the program has particular knowledge about the symbol, process the form using special-purpose code. All of the standard special forms should fall into this category. ") (IL:* IL:|;;| " 2. Otherwise, if macro-function is true of the symbol apply either macroexpand or macroexpand-1 and start over. ") (IL:* IL:|;;| "3. Otherwise, assume it is a function call.") (IL:* IL:|;;| " First apply the *walk-function* to perform whatever translation the user wants to to this form. If the second value returned by *walk-function* is T then we don't recurse...") (MULTIPLE-VALUE-SETQ (NEWFORM WALK-NO-MORE-P) (FUNCALL *WALK-FUNCTION* FORM CONTEXT)) (COND (WALK-NO-MORE-P NEWFORM) ((NOT (EQ FORM NEWFORM)) (WALK-FORM-INTERNAL NEWFORM CONTEXT)) ((NOT (CONSP NEWFORM)) NEWFORM) ((SETQ TEMPLATE (GET-WALKER-TEMPLATE (SETQ FN (CAR NEWFORM)))) (IF (SYMBOLP TEMPLATE) (FUNCALL TEMPLATE NEWFORM CONTEXT) (WALK-TEMPLATE NEWFORM TEMPLATE CONTEXT))) ((PROGN (MULTIPLE-VALUE-SETQ (NEWNEWFORM MACROP) (MACROEXPAND-1 NEWFORM *ENVIRONMENT*)) MACROP) (WALK-FORM-INTERNAL NEWNEWFORM CONTEXT)) ((AND (SYMBOLP FN) (NOT (FBOUNDP FN)) (SPECIAL-FORM-P FN)) (ERROR "~S is a special form, not defined in the CommonLisp manual. Please define a template for this special form and try again." FN)) (T (IL:* IL:|;;| "Otherwise, walk the form as if its just a standard function call using a template for standard function call.") (WALK-TEMPLATE NEWFORM '(:CALL :REPEAT (:EVAL)) CONTEXT)))) (DEFUN WALK-TEMPLATE (FORM TEMPLATE CONTEXT) (DECLARE (IL:GLOBALVARS IL:LAMBDASPLST)) (IF (ATOM TEMPLATE) (ECASE TEMPLATE ((:QUOTE NIL) FORM) ((:EVAL :FUNCTION :TEST :EFFECT :RETURN) (WALK-FORM-INTERNAL FORM :EVAL)) (:SET (WALK-FORM-INTERNAL FORM :SET)) ((:LAMBDA :CALL) (COND ((ATOM FORM) FORM) ((NOT (MEMBER (CAR FORM) IL:LAMBDASPLST :TEST 'EQ)) (IL:* IL:|;;|  "Don't descend into things that aren't known LAMBDA-like forms.") FORM) (T (WALK-LAMBDA FORM CONTEXT))))) (CASE (CAR TEMPLATE) (:IF (IL:* IL:|;;| "Conditional template") (LET ((*WALK-FORM* FORM)) (WALK-TEMPLATE FORM (IF (IF (LISTP (SECOND TEMPLATE)) (EVAL (SECOND TEMPLATE)) (FUNCALL (SECOND TEMPLATE) FORM)) (THIRD TEMPLATE) (FOURTH TEMPLATE)) CONTEXT))) (:REPEAT (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE) (IL:* IL:|;;|  " For the case where nothing happens after the repeat optimize out the call to length.") (IF (NULL (CDDR TEMPLATE)) NIL (NTHCDR (- (LENGTH FORM) (LENGTH (CDDR TEMPLATE))) FORM)) CONTEXT)) (:REMOTE (WALK-TEMPLATE FORM (CADR TEMPLATE) CONTEXT)) (OTHERWISE (IF (ATOM FORM) FORM (RECONS FORM (WALK-TEMPLATE (CAR FORM) (CAR TEMPLATE) CONTEXT) (WALK-TEMPLATE (CDR FORM) (CDR TEMPLATE) CONTEXT))))))) (DEFUN VARIABLE-GLOBALLY-SPECIAL-P (SYMBOL) (IL:* IL:|;;| " VARIABLE-GLOBALLY-SPECIAL-P is used to ask if a variable has been declared globally special. Any particular CommonLisp implementation should customize this function accordingly and send their customization back. The default version of variable-globally-special-p is probably pretty slow, so it uses *globally-special-variables* as a cache to remember variables that it has already figured out are globally special. This would need to be reworked if an unspecial declaration got added to Common Lisp. Common Lisp nit: variable-globally-special-p should be defined in Common Lisp.") (IL:VARIABLE-GLOBALLY-SPECIAL-P SYMBOL)) (DEFUN VARIABLE-LEXICAL-P (VAR) (IF (NOT (BOUNDP '*WALK-FUNCTION*)) :UNSURE (AND (NOT (EQ (VARIABLE-SPECIAL-P VAR) 'T)) (MEMBER VAR *LEXICAL-VARIABLES* :TEST #'EQ)))) (DEFUN VARIABLE-LEXICALLY-BOUNDP (VAR) (IF (NOT (BOUNDP '*WALK-FUNCTION*)) :UNSURE (VALUES (MEMBER VAR *LEXICAL-VARIABLES* :TEST #'EQ) (VARIABLE-SPECIAL-P VAR) 'T))) (DEFUN VARIABLE-SPECIAL-P (VAR) (IF (NOT (BOUNDP '*WALK-FUNCTION*)) (OR (VARIABLE-GLOBALLY-SPECIAL-P VAR) :UNSURE) (OR (DOLIST (DECL *DECLARATIONS*) (AND (EQ (CAR DECL) 'SPECIAL) (MEMBER VAR (CDR DECL) :TEST #'EQ) (RETURN T))) (VARIABLE-GLOBALLY-SPECIAL-P VAR)))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:MOVD 'VARIABLE-LEXICAL-P 'IL:VARIABLE-LEXICAL-P) (IL:MOVD 'VARIABLE-SPECIAL-P 'IL:VARIABLE-SPECIAL-P) ) (DEFUN WALK-TEMPLATE-HANDLE-REPEAT (FORM TEMPLATE STOP-FORM CONTEXT) (IF (EQ FORM STOP-FORM) (WALK-TEMPLATE FORM (CDR TEMPLATE) CONTEXT) (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE) STOP-FORM CONTEXT))) (DEFUN WALK-TEMPLATE-HANDLE-REPEAT-1 (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM CONTEXT) (COND ((NULL FORM) NIL) ((EQ FORM STOP-FORM) (IF (NULL REPEAT-TEMPLATE) (WALK-TEMPLATE STOP-FORM (CDR TEMPLATE) CONTEXT) (ERROR "While handling repeat: Ran into stop while still in repeat template."))) ((NULL REPEAT-TEMPLATE) (WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE) STOP-FORM CONTEXT)) (T (RECONS FORM (WALK-TEMPLATE (CAR FORM) (CAR REPEAT-TEMPLATE) CONTEXT) (WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM) TEMPLATE (CDR REPEAT-TEMPLATE) STOP-FORM CONTEXT))))) (DEFUN RECONS (X CAR CDR) (IF *WALK-COPY* (IF (OR (NOT (EQ (CAR X) CAR)) (NOT (EQ (CDR X) CDR))) (CONS CAR CDR) X))) (DEFUN RELIST* (X &REST ARGS) (IF *WALK-COPY* (RELIST*-INTERNAL X ARGS))) (DEFUN RELIST*-INTERNAL (X ARGS) (IF (NULL (CDR ARGS)) (CAR ARGS) (RECONS X (CAR ARGS) (RELIST*-INTERNAL (CDR X) (CDR ARGS))))) (DEFUN WALK-ARGLIST (ARGLIST CONTEXT &OPTIONAL (DESTRUCTURINGP NIL) &AUX ARG) (COND ((NULL ARGLIST) NIL) ((SYMBOLP (SETQ ARG (CAR ARGLIST))) (OR (MEMBER ARG LAMBDA-LIST-KEYWORDS :TEST #'EQ) (NOTE-LEXICAL-BINDING ARG)) (RECONS ARGLIST ARG (WALK-ARGLIST (CDR ARGLIST) CONTEXT (AND DESTRUCTURINGP (NOT (MEMBER ARG LAMBDA-LIST-KEYWORDS :TEST #'EQ)))))) ((CONSP ARG) (PROG1 (IF DESTRUCTURINGP (WALK-ARGLIST ARG CONTEXT DESTRUCTURINGP) (RECONS ARGLIST (RELIST* ARG (CAR ARG) (WALK-FORM-INTERNAL (CADR ARG) ':EVAL) (CDDR ARG)) (WALK-ARGLIST (CDR ARGLIST) CONTEXT NIL))) (IF (SYMBOLP (CAR ARG)) (NOTE-LEXICAL-BINDING (CAR ARG)) (NOTE-LEXICAL-BINDING (CADAR ARG))) (OR (NULL (CDDR ARG)) (NOT (SYMBOLP (CADDR ARG))) (NOTE-LEXICAL-BINDING ARG)))) (T (ERROR "Can't understand something in the arglist ~S" ARGLIST)))) (DEFUN WALK-BINDINGS-1 (BINDINGS OLD-DECLARATIONS OLD-LEXICAL-VARIABLES CONTEXT SEQUENTIALP) (AND BINDINGS (LET ((BINDING (CAR BINDINGS))) (RECONS BINDINGS (IF (SYMBOLP BINDING) (PROG1 BINDING (NOTE-LEXICAL-BINDING BINDING)) (PROG1 (LET ((*DECLARATIONS* OLD-DECLARATIONS) (*LEXICAL-VARIABLES* (IF SEQUENTIALP *LEXICAL-VARIABLES* OLD-LEXICAL-VARIABLES) )) (RELIST* BINDING (CAR BINDING) (WALK-FORM-INTERNAL (CADR BINDING) CONTEXT) (CDDR BINDING))) (IL:* IL:\;  "save cddr for DO/DO* it is the next value; form. Don't walk it now though.") (NOTE-LEXICAL-BINDING (CAR BINDING)))) (WALK-BINDINGS-1 (CDR BINDINGS) OLD-DECLARATIONS OLD-LEXICAL-VARIABLES CONTEXT SEQUENTIALP))))) (DEFUN WALK-BINDINGS-2 (BINDINGS WALKED-BINDINGS CONTEXT) (AND BINDINGS (LET ((BINDING (CAR BINDINGS)) (WALKED-BINDING (CAR WALKED-BINDINGS))) (RECONS BINDINGS (IF (SYMBOLP BINDING) BINDING (RELIST* BINDING (CAR WALKED-BINDING) (CADR WALKED-BINDING) (WALK-TEMPLATE (CDDR BINDING) '(:EVAL) CONTEXT))) (WALK-BINDINGS-2 (CDR BINDINGS) (CDR WALKED-BINDINGS) CONTEXT))))) (DEFUN WALK-COMPILER-LET (FORM CONTEXT) (WITH-NEW-CONTOUR (LET ((VARS NIL) (VALS NIL)) (DOLIST (BINDING (CADR FORM)) (COND ((SYMBOLP BINDING) (PUSH BINDING VARS) (PUSH NIL VALS)) (T (PUSH (CAR BINDING) VARS) (PUSH (EVAL (CADR BINDING)) VALS)))) (RELIST* FORM (CAR FORM) (CADR FORM) (PROGV VARS VALS (NOTE-DECLARATION (CONS 'SPECIAL VARS)) (WALK-TEMPLATE (CDDR FORM) '(:REPEAT (:EVAL)) CONTEXT)))))) (DEFUN WALK-DECLARATIONS (BODY FN &OPTIONAL DOC-STRING-P DECLARATIONS OLD-BODY &AUX (FORM (CAR BODY)) MACROP NEW-FORM) (COND ((AND (STRINGP FORM) (IL:* IL:\; "might be a doc string") (CDR BODY) (IL:* IL:\; "isn't the returned value") (NULL DOC-STRING-P) (IL:* IL:\; "no doc string yet") (NULL DECLARATIONS)) (IL:* IL:\; "no declarations yet") (RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY) FN T))) ((AND (LISTP FORM) (EQ (CAR FORM) 'DECLARE)) (IL:* IL:|;;| "Got ourselves a real live declaration. Record it, look for more.") (DOLIST (DECLARATION (CDR FORM)) (NOTE-DECLARATION DECLARATION) (PUSH DECLARATION DECLARATIONS)) (RECONS BODY FORM (WALK-DECLARATIONS (CDR BODY) FN DOC-STRING-P DECLARATIONS))) ((AND FORM (LISTP FORM) (NULL (GET-WALKER-TEMPLATE (CAR FORM))) (PROGN (MULTIPLE-VALUE-SETQ (NEW-FORM MACROP) (MACROEXPAND-1 (CAR FORM) *ENVIRONMENT*)) MACROP)) (IL:* IL:|;;|  "This form was a call to a macro. Maybe it expanded into a declare? Recurse to find out.") (WALK-DECLARATIONS (RECONS BODY NEW-FORM (CDR BODY)) FN DOC-STRING-P DECLARATIONS (OR OLD-BODY BODY))) (T (IL:* IL:|;;| " Now that we have walked and recorded the declarations, call the function our caller provided to expand the body. We call that function rather than passing the real-body back, because we are RECONSING up the new body.") (FUNCALL FN (OR OLD-BODY BODY))))) (DEFUN WALK-DO (FORM CONTEXT) (WALK-DO/DO* FORM CONTEXT NIL)) (DEFUN WALK-DO* (FORM CONTEXT) (WALK-DO/DO* FORM CONTEXT T)) (DEFUN WALK-DO/DO* (FORM CONTEXT SEQUENTIALP) (LET ((OLD-DECLARATIONS *DECLARATIONS*) (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*)) (WITH-NEW-CONTOUR (LET* ((DO/DO* (CAR FORM)) (BINDINGS (CADR FORM)) (END-TEST (CADDR FORM)) (BODY (CDDDR FORM)) WALKED-BINDINGS (WALKED-BODY (WALK-DECLARATIONS BODY #'(LAMBDA (REAL-BODY) (SETQ WALKED-BINDINGS (WALK-BINDINGS-1 BINDINGS OLD-DECLARATIONS OLD-LEXICAL-VARIABLES CONTEXT SEQUENTIALP)) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))) (RELIST* FORM DO/DO* (WALK-BINDINGS-2 BINDINGS WALKED-BINDINGS CONTEXT) (WALK-TEMPLATE END-TEST '(:TEST :REPEAT (:EVAL)) CONTEXT) WALKED-BODY))))) (DEFUN WALK-FLET/LABELS (FORM CONTEXT) (WITH-NEW-CONTOUR (LABELS ((WALK-DEFINITIONS (DEFINITIONS) (IF (NULL DEFINITIONS) NIL (RECONS DEFINITIONS (WALK-LAMBDA (CAR DEFINITIONS) CONTEXT) (WALK-DEFINITIONS (CDR DEFINITIONS))))) (IL:* IL:\; "") (UPDATE-ENVIRONMENT NIL (SETQ *ENVIRONMENT* (MAKE-LEXICAL-ENVIRONMENT FORM *ENVIRONMENT*)))) (RELIST* FORM (CAR FORM) (ECASE (CAR FORM) (FLET (PROG1 (WALK-DEFINITIONS (CADR FORM)) (UPDATE-ENVIRONMENT))) (LABELS (UPDATE-ENVIRONMENT) (WALK-DEFINITIONS (CADR FORM)))) (WALK-DECLARATIONS (CDDR FORM) #'(LAMBDA (REAL-BODY) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))))) (DEFUN WALK-LAMBDA (FORM CONTEXT) (WITH-NEW-CONTOUR (LET* ((ARGLIST (CADR FORM)) (BODY (CDDR FORM)) (WALKED-ARGLIST NIL) (WALKED-BODY (WALK-DECLARATIONS BODY #'(LAMBDA (REAL-BODY) (SETQ WALKED-ARGLIST (WALK-ARGLIST ARGLIST CONTEXT)) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))) (RELIST* FORM (CAR FORM) WALKED-ARGLIST WALKED-BODY)))) (DEFUN WALK-LET (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT NIL)) (DEFUN WALK-LET* (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT T)) (DEFUN WALK-LET/LET* (FORM CONTEXT SEQUENTIALP) (LET ((OLD-DECLARATIONS *DECLARATIONS*) (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*)) (WITH-NEW-CONTOUR (LET* ((LET/LET* (CAR FORM)) (BINDINGS (CADR FORM)) (BODY (CDDR FORM)) WALKED-BINDINGS (WALKED-BODY (WALK-DECLARATIONS BODY #'(LAMBDA (REAL-BODY) (SETQ WALKED-BINDINGS (WALK-BINDINGS-1 BINDINGS OLD-DECLARATIONS OLD-LEXICAL-VARIABLES CONTEXT SEQUENTIALP)) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))) (RELIST* FORM LET/LET* WALKED-BINDINGS WALKED-BODY))))) (DEFUN WALK-MACROLET (FORM CONTEXT) (LABELS ((WALK-DEFINITIONS (DEFINITIONS) (AND (NOT (NULL DEFINITIONS)) (LET ((DEFINITION (CAR DEFINITIONS))) (RECONS DEFINITIONS (WITH-NEW-CONTOUR (RELIST* DEFINITION (CAR DEFINITION) (WALK-ARGLIST (CADR DEFINITION) CONTEXT T) (WALK-DECLARATIONS (CDDR DEFINITION) #'(LAMBDA (REAL-BODY) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))) (WALK-DEFINITIONS (CDR DEFINITIONS))))))) (WITH-NEW-CONTOUR (RELIST* FORM (CAR FORM) (WALK-DEFINITIONS (CADR FORM)) (PROGN (SETQ *ENVIRONMENT* (MAKE-LEXICAL-ENVIRONMENT FORM *ENVIRONMENT*) ) (WALK-DECLARATIONS (CDDR FORM) #'(LAMBDA (REAL-BODY) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT)))))))) (DEFUN WALK-MULTIPLE-VALUE-BIND (FORM CONTEXT) (LET ((OLD-DECLARATIONS *DECLARATIONS*) (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*)) (WITH-NEW-CONTOUR (LET* ((MVB (CAR FORM)) (BINDINGS (CADR FORM)) (MV-FORM (WALK-TEMPLATE (CADDR FORM) ':EVAL CONTEXT)) (BODY (CDDDR FORM)) WALKED-BINDINGS (WALKED-BODY (WALK-DECLARATIONS BODY #'(LAMBDA (REAL-BODY) (SETQ WALKED-BINDINGS (WALK-BINDINGS-1 BINDINGS OLD-DECLARATIONS OLD-LEXICAL-VARIABLES CONTEXT NIL)) (WALK-TEMPLATE REAL-BODY '(:REPEAT (:EVAL)) CONTEXT))))) (RELIST* FORM MVB WALKED-BINDINGS MV-FORM WALKED-BODY))))) (DEFUN WALK-PROG (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT NIL)) (DEFUN WALK-PROG* (FORM CONTEXT) (WALK-LET/LET* FORM CONTEXT T)) (DEFUN WALK-TAGBODY (FORM CONTEXT) (RECONS FORM (CAR FORM) (WALK-TAGBODY-1 (CDR FORM) CONTEXT))) (DEFUN WALK-TAGBODY-1 (FORM CONTEXT) (AND FORM (RECONS FORM (WALK-FORM-INTERNAL (CAR FORM) (IF (SYMBOLP (CAR FORM)) ':QUOTE CONTEXT)) (WALK-TAGBODY-1 (CDR FORM) CONTEXT)))) (DEFUN WALK-UNEXPECTED-DECLARE (FORM CONTEXT) (DECLARE (IGNORE CONTEXT)) (WARN "Encountered declare ~S in a place where a declare was not expected." FORM) FORM) (DEFMACRO WITH-NEW-CONTOUR (&BODY BODY) (IL:* IL:|;;| " With new contour is used to enter a new lexical binding contour which inherits from the exisiting one. I admit that using with-new-contour is often overkill. It would suffice for the the walker to rebind *lexical-variables* and *declarations* when walking LET and rebind *environment* and *declarations* when walking MACROLET etc.WITH-NEW-CONTOUR is much more convenient and just as correct.") `(LET ((*DECLARATIONS* NIL) (*LEXICAL-VARIABLES* *LEXICAL-VARIABLES*) (*ENVIRONMENT* *ENVIRONMENT*)) . ,BODY)) (DEFUN MAKE-LEXICAL-ENVIRONMENT (MACROLET/FLET/LABELS-FORM ENVIRONMENT) (IL:* IL:|;;| "make-lexical-environemnt is kind of gross. It would be less gross if EVAL took an environment argument. ") (ECASE (CAR MACROLET/FLET/LABELS-FORM) (MACROLET (ADD-MACROLET-ENVIRONMENT MACROLET/FLET/LABELS-FORM ENVIRONMENT)) ((FLET LABELS) (ADD-LABELS/FLET-ENVIRONMENT MACROLET/FLET/LABELS-FORM ENVIRONMENT)))) (DEFUN ADD-MACROLET-ENVIRONMENT (MACROLET-FORM ENV) (DESTRUCTURING-BIND (CAR-OF-FORM LOCAL-MACROS &REST BODY) MACROLET-FORM (COND ((TYPEP ENV 'COMPILER:ENV) (IL:* IL:|;;| "From the compiler") (LET ((NEW-ENV (COMPILER::MAKE-CHILD-ENV ENV))) (DOLIST (MACRO-DEFN LOCAL-MACROS) (COMPILER::ENV-BIND-FUNCTION NEW-ENV (CAR MACRO-DEFN) :MACRO (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN)))) NEW-ENV)) ((OR (TYPEP ENV 'IL:ENVIRONMENT) (NULL ENV)) (IL:* IL:|;;| "from the interpreter") (LET ((NEW-ENV (IL:\\MAKE-CHILD-ENVIRONMENT ENV))) (SETF (IL:ENVIRONMENT-FUNCTIONS NEW-ENV) (NCONC (WITH-COLLECTION (DOLIST (MACRO-DEFN LOCAL-MACROS) (COLLECT (CAR MACRO-DEFN)) (COLLECT (CONS :MACRO (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN))))) ) (IL:ENVIRONMENT-FUNCTIONS NEW-ENV))) NEW-ENV)) (T (ERROR "Not a recognized environment type: ~s" ENV))))) (DEFUN ADD-LABELS/FLET-ENVIRONMENT (LABELS/FLET-FORM ENV) (DESTRUCTURING-BIND (CAR-OF-FORM LOCAL-FNS &REST BODY) LABELS/FLET-FORM (COND ((TYPEP ENV 'COMPILER:ENV) (IL:* IL:|;;| "From the compiler") (LET ((NEW-ENV (COMPILER::MAKE-CHILD-ENV ENV))) (DOLIST (FN-DEFN LOCAL-FNS) (COMPILER::ENV-BIND-FUNCTION NEW-ENV (CAR FN-DEFN) :FUNCTION (CONS 'LAMBDA (CDR FN-DEFN)))) NEW-ENV)) ((OR (TYPEP ENV 'IL:ENVIRONMENT) (NULL ENV)) (IL:* IL:|;;| "from the interpreter") (LET ((NEW-ENV (IL:\\MAKE-CHILD-ENVIRONMENT ENV))) (SETF (IL:ENVIRONMENT-FUNCTIONS NEW-ENV) (NCONC (WITH-COLLECTION (DOLIST (FN-DEFN LOCAL-FNS) (COLLECT (CAR FN-DEFN)) (COLLECT (CONS :FUNCTION (IL:MAKE-CLOSURE :FUNCTION (CONS 'LAMBDA (CDR FN-DEFN)) :ENVIRONMENT ENV))))) (IL:ENVIRONMENT-FUNCTIONS NEW-ENV))) NEW-ENV)) (T (ERROR "Not a recognized environment type: ~s" ENV))))) (DEFMACRO NOTE-DECLARATION (DECLARATION) `(PUSH ,DECLARATION *DECLARATIONS*)) (DEFMACRO NOTE-LEXICAL-BINDING (THING) `(PUSH ,THING *LEXICAL-VARIABLES*)) (DEF-DEFINE-TYPE WALKER-TEMPLATES "Walker templates") (DEFDEFINER DEFINE-WALKER-TEMPLATE WALKER-TEMPLATES (NAME TEMPLATE) `(EVAL-WHEN (LOAD EVAL) (SETF (GET-WALKER-TEMPLATE-INTERNAL ',NAME) ',TEMPLATE))) (DEFUN GET-WALKER-TEMPLATE (X) (COND ((SYMBOLP X) (GET-WALKER-TEMPLATE-INTERNAL X)) ((AND (LISTP X) (EQ (CAR X) 'LAMBDA)) '(:LAMBDA :REPEAT (:EVAL))))) (DEFMACRO GET-WALKER-TEMPLATE-INTERNAL (X) `(GET ,X 'WALKER-TEMPLATES)) (IL:* IL:|;;| "Templates for special forms") (DEFINE-WALKER-TEMPLATE AND (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE BLOCK (NIL NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE CATCH (NIL :EVAL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE COMPILER-LET WALK-COMPILER-LET) (DEFINE-WALKER-TEMPLATE COND (NIL :REPEAT ((:TEST :REPEAT (:EVAL))))) (DEFINE-WALKER-TEMPLATE DECLARE WALK-UNEXPECTED-DECLARE) (DEFINE-WALKER-TEMPLATE DO WALK-DO) (DEFINE-WALKER-TEMPLATE DO* WALK-DO*) (DEFINE-WALKER-TEMPLATE EVAL-WHEN (NIL :QUOTE :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE FLET WALK-FLET/LABELS) (DEFINE-WALKER-TEMPLATE FUNCTION (NIL :CALL)) (DEFINE-WALKER-TEMPLATE GO (NIL :QUOTE)) (DEFINE-WALKER-TEMPLATE IF (NIL :TEST :RETURN :RETURN)) (DEFINE-WALKER-TEMPLATE LABELS WALK-FLET/LABELS) (DEFINE-WALKER-TEMPLATE LAMBDA WALK-LAMBDA) (DEFINE-WALKER-TEMPLATE LET WALK-LET) (DEFINE-WALKER-TEMPLATE LET* WALK-LET*) (DEFINE-WALKER-TEMPLATE MACROLET WALK-MACROLET) (DEFINE-WALKER-TEMPLATE MULTIPLE-VALUE-BIND WALK-MULTIPLE-VALUE-BIND) (DEFINE-WALKER-TEMPLATE MULTIPLE-VALUE-CALL (NIL :EVAL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE MULTIPLE-VALUE-PROG1 (NIL :RETURN :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE MULTIPLE-VALUE-SETQ (NIL (:REPEAT (:SET)) :EVAL)) (DEFINE-WALKER-TEMPLATE OR (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE PROG WALK-PROG) (DEFINE-WALKER-TEMPLATE PROG* WALK-PROG*) (DEFINE-WALKER-TEMPLATE PROGN (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE PROGV (NIL :EVAL :EVAL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE QUOTE (NIL :QUOTE)) (DEFINE-WALKER-TEMPLATE RETURN-FROM (NIL :QUOTE :REPEAT (:RETURN))) (DEFINE-WALKER-TEMPLATE SETQ (NIL :REPEAT (:SET :EVAL))) (DEFINE-WALKER-TEMPLATE TAGBODY WALK-TAGBODY) (DEFINE-WALKER-TEMPLATE THE (NIL :QUOTE :EVAL)) (DEFINE-WALKER-TEMPLATE THROW (NIL :EVAL :EVAL)) (DEFINE-WALKER-TEMPLATE UNWIND-PROTECT (NIL :RETURN :REPEAT (:EVAL))) (IL:* IL:|;;| "For Interlisp. Do not remove the template for IL:SETQ or the loadup may break.") (DEFINE-WALKER-TEMPLATE IL:LOAD-TIME-EVAL (NIL :EVAL)) (DEFINE-WALKER-TEMPLATE IL:SETQ (NIL :SET :EVAL)) (DEFINE-WALKER-TEMPLATE IL:RPAQ? (NIL :SET :EVAL)) (DEFINE-WALKER-TEMPLATE IL:RPAQ (NIL :SET :EVAL)) (DEFINE-WALKER-TEMPLATE IL:XNLSETQ (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE IL:ERSETQ (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE IL:NLSETQ (NIL :REPEAT (:EVAL))) (DEFINE-WALKER-TEMPLATE IL:RESETVARS WALK-LET) (IL:PUTPROPS IL:WALKER IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:WALKER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS IL:WALKER IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/WEDIT b/sources/WEDIT new file mode 100644 index 00000000..5f5b66f8 --- /dev/null +++ b/sources/WEDIT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "23-Oct-91 16:39:18" |{PELE:MV:ENVOS}SOURCES>WEDIT.;4| 37235 changes to%: (FNS EDITGETD) previous date%: "25-Jun-90 14:33:27" |{PELE:MV:ENVOS}SOURCES>WEDIT.;3|) (* ; " Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WEDITCOMS) (RPAQQ WEDITCOMS [(VARS EDITOPS MAXLOOP (EDITRACEFN) (UPFINDFLG T) MAXLEVEL FINDFLAG (EDITQUIETFLG)) [INITVARS (EDITSMASHUSERFN) (EDITEMBEDTOKEN '&) (EDITUSERFN) (CHANGESARRAY) (EDITUNSAVEBLOCKFLG T) (EDITLOADFNSFLG '(T] (INITVARS (EDITMACROS) (USERMACROS)) (ADDVARS (HISTORYCOMS ?? REDO REPEAT FIX USE ... NAME RETRIEVE DO !N !E !F TYPE-AHEAD  BUFS ;) (DONTSAVEHISTORYCOMS SAVE P ? PP PP* E ;) (EDITCOMSA OK STOP SAVE TTY%: E ? PP PP* PPV P ^ !0 MARK UNDO !UNDO TEST UNBLOCK _ \ \P __ F BF UP DELETE NX BK !NX ?? REDO REPEAT FIX USE NAME RETRIEVE DO !N !E !F TYPE-AHEAD) (EDITCOMSL S R R1 RC RC1 E I N P F FS F= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR MBD XTR THRU TO A B %: AFTER BEFORE MV LP LPQ LC LCL _ BELOW SW BIND COMS ORIGINAL INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SWITCH ?? REDO REPEAT FIX USE NAME RETRIEVE DO MARK \)) (USERMACROS CAP LOWER RAISE 2ND 3RD %%F %% NEX REPACK * >* SHOW EXAM PP* ?=) [COMS (* ;  "control chars for moving around in the editor") (FNS SETTERMCHARS INTCHECK CHARMACRO) (INITVARS (EDITCHARACTERS)) (VARS NEGATIONS) (USERMACROS 2P NXP BKP -1P) (ADDVARS (COMPACTHISTORYCOMS 2P NXP BKP -1P)) (DECLARE%: DONTCOPY (MACROS CFOBF)) (BLOCKS (SETTERMCHARS SETTERMCHARS INTCHECK (NOLINKFNS . T) (GLOBALVARS EDITRDTBL)) (NIL CHARMACRO (LOCALVARS . T] [COMS (* ; "macros for calling editor") (USERMACROS EF EV EP) (ADDVARS (DONTSAVEHISTORYCOMS EF EV EP)) (FNS FIRSTATOM) (BLOCKS (NIL FIRSTATOM (LOCALVARS . T] [COMS (* ; "Misc edit macros") (USERMACROS EVAL Q GETD GETVAL MAKEFN D NEGATE GO SWAP MAKE SWAPC IFY SPLITC JOINC) (FNS MAKEFN EDITGETD EDITGETD-LAMBDA EDITGETD-LET NEGATE NEGL NEGLST NEGC MKPROGN MKPROGN1 MAKECOM SWAPPEDCOND COND.TO.IF) (PROP EDITGETD LET CL:IF) (BLOCKS (NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T) (GLOBALVARS NEGATIONS)) (MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T] (GLOBALVARS CLISPARRAY MACROPROPS) (LOCALVARS . T) (GLOBALVARS LAMBDASPLST NORMALCOMMENTSFLG COMMENTFLG FIRSTNAME INITIALS INITIALSLST DEFAULTINITIALS) (P (MOVD? 'NILL 'PREEDITFN)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML MAKECOM CHARMACRO ) (LAMA]) (RPAQQ EDITOPS ((INSERT (BEFORE AFTER FOR) (EDIT%: %#2 %#3 %#1)) (REPLACE (WITH BY) (EDIT%: %: %#1 %#3)) (CHANGE (TO) (EDIT%: %: %#1 %#3)) (DELETE NIL (EDIT%: %: %#1)) (EMBED (IN WITH) (EDITMBD %#1 %#3)) (SURROUND (WITH IN) (EDITMBD %#1 %#3)) (MOVE (TO) (EDITMV %#1 (CAR %#3) (CDR %#3))) (EXTRACT (FROM) (EDITXTR %#3 %#1)) (SWITCH (AND) (EDITSW %#1 %#3)))) (RPAQQ MAXLOOP 30) (RPAQQ EDITRACEFN NIL) (RPAQQ UPFINDFLG T) (RPAQQ MAXLEVEL 300) (RPAQQ FINDFLAG NIL) (RPAQQ EDITQUIETFLG NIL) (RPAQ? EDITSMASHUSERFN ) (RPAQ? EDITEMBEDTOKEN '&) (RPAQ? EDITUSERFN ) (RPAQ? CHANGESARRAY ) (RPAQ? EDITUNSAVEBLOCKFLG T) (RPAQ? EDITLOADFNSFLG '(T)) (RPAQ? EDITMACROS ) (RPAQ? USERMACROS ) (ADDTOVAR HISTORYCOMS ?? REDO REPEAT FIX USE ... NAME RETRIEVE DO !N !E !F TYPE-AHEAD  BUFS ;) (ADDTOVAR DONTSAVEHISTORYCOMS SAVE P ? PP PP* E ;) (ADDTOVAR EDITCOMSA OK STOP SAVE TTY%: E ? PP PP* PPV P ^ !0 MARK UNDO !UNDO TEST UNBLOCK _ \ \P __ F BF UP DELETE NX BK !NX ?? REDO REPEAT FIX USE NAME RETRIEVE DO !N !E !F TYPE-AHEAD) (ADDTOVAR EDITCOMSL S R R1 RC RC1 E I N P F FS F= ORF BF NTH IF RI RO LI LO BI BO M NX BK ORR MBD XTR THRU TO A B %: AFTER BEFORE MV LP LPQ LC LCL _ BELOW SW BIND COMS ORIGINAL INSERT REPLACE CHANGE DELETE EMBED SURROUND MOVE EXTRACT SWITCH ?? REDO REPEAT FIX USE NAME RETRIEVE DO MARK \) (ADDTOVAR EDITMACROS (EXAM X (F (*ANY* . X) T) (BIND (LPQ (MARK %#1) (ORR (1 !0 P) NIL) (MARK %#2) TTY%: (MARK %#3) (IF (EQ (%## (\ %#3)) (%## (\ %#2))) ((\ %#1)) NIL) (F (*ANY* . X) N))) (E 'done)) (>* (X) (BIND (MARK %#1) 0 (_ ((*ANY* PROG PROGN COND SELECTQ LAMBDA NLAMBDA ASSEMBLE) --)) (MARK %#2) (E (SETQ %#3 (SELECTQ (%## 1) ((COND SELECTQ) 2) 1)) T) (\ %#1) (ORR (1 1) (1) NIL) (BELOW (\ %#2) %#3) (IF 'X [(ORR (NX (B X)) ((IF (EQ (%## (\ %#2) 0 1) 'PROG) NIL (BK)) (A X)) ((\ %#2) (>* X] NIL))) (LOWER NIL UP (I 1 (L-CASE (%## 1))) 1) (CAP NIL UP (I 1 (L-CASE (%## 1) T)) 1) [REPACK NIL (IF (LISTP (%##)) (1) NIL) (I %: ([LAMBDA (X Y) (SETQ COM 'REPACK) [SETQ Y (APPLY 'CONCAT (EDITE (UNPACK X] [COND ((NOT (STRINGP X)) (SETQ Y (MKATOM Y] (PRINT Y T T] (%##] (* X MARK [ORR [(I >* (COND [(RAISEP) (CONS '* (CONS '%% 'X] (T (CONS '* 'X] ((E 'CAN'T] __) [LOWER (C) (I R 'C (L-CASE 'C] (RAISE (C) (I R (L-CASE 'C) 'C)) (RAISE NIL UP (I 1 (U-CASE (%## 1))) 1) [2ND X (ORR ((LC . X) (LC . X] [3RD X (ORR ((LC . X) (LC . X) (LC . X] (%%F (X Y) (E (EDITQF (L-CASE 'X 'Y)) T)) [%% X (COMS (CONS (CAR 'X) (COMMENT3 (CDR 'X) (CAR (LAST L] (NEX NIL (BELOW _) NX) (NEX (X) (BELOW X) NX) [REPACK NIL (IF (LISTP (%##)) (1) NIL) (I %: ([LAMBDA (X Y) (SETQ COM 'REPACK) [SETQ Y (APPLY 'CONCAT (EDITE (UNPACK X] [COND ((NOT (STRINGP X)) (SETQ Y (MKATOM Y] (PRINT Y T T] (%##] (REPACK (X) (LC . X) REPACK) (SHOW X (F (*ANY* . X) T) (LPQ MARK (ORR (1 !0) NIL) P __ (F (*ANY* . X) N)) (E 'done)) (PP* NIL (RESETVAR **COMMENT**FLG NIL PP)) (?= NIL (E (PROGN (PRINT-ARGLIST (SMARTARGLIST (CAR (%##))) (CDR (%##)) T 0) (TERPRI T)) T))) (ADDTOVAR EDITCOMSA CAP LOWER RAISE NEX REPACK PP*) (ADDTOVAR EDITCOMSL LOWER RAISE 2ND 3RD %%F %% REPACK * >* EXAM SHOW) (ADDTOVAR DONTSAVEHISTORYCOMS PP*) (* ; "control chars for moving around in the editor") (DEFINEQ (SETTERMCHARS [LAMBDA (NEXTCHAR BKCHAR LASTCHAR UNQUOTECHAR 2CHAR PPCHAR)(* lmm "11-SEP-78 04:57") (COND ((SETQ NEXTCHAR (INTCHECK NEXTCHAR)) (* ; "NEXTCHAR (usu. control-J) goes to the next entry") (/SETSYNTAX NEXTCHAR '[MACRO FIRST IMMEDIATE (LAMBDA NIL (CHARMACRO NXP] EDITRDTBL))) [COND ((SETQ LASTCHAR (INTCHECK LASTCHAR)) (* ; "LASTCHAR (usu. control-Z) to the editor will go to the last thing and print it") (/SETSYNTAX LASTCHAR '[MACRO FIRST IMMEDIATE (LAMBDA NIL (CHARMACRO |-1P|] EDITRDTBL) (/ECHOCONTROL LASTCHAR 'IGNORE] [COND ((SETQ 2CHAR (INTCHECK 2CHAR)) (* ; "2CHAR (usu. Control N) to the editor will go to 2 (or 1) and print it") (/SETSYNTAX 2CHAR '[MACRO FIRST IMMEDIATE (LAMBDA NIL (CHARMACRO |2P|] EDITRDTBL) (/ECHOCONTROL 2CHAR 'IGNORE] [COND ((SETQ BKCHAR (INTCHECK BKCHAR)) (* ; "BKCHAR (usu. control H) to the editor will go back (or up) and then print") (/SETSYNTAX BKCHAR '[MACRO FIRST IMMEDIATE ESCQUOTE (LAMBDA NIL (CHARMACRO BKP] EDITRDTBL) (/ECHOCONTROL BKCHAR 'IGNORE] (COND ((SETQ UNQUOTECHAR (INTCHECK UNQUOTECHAR)) (* ; "UNQUOTECHAR (usu. control Y (Yank)) is an 'unquote' -- reads next thing and evals it") (/SETSYNTAX UNQUOTECHAR '[MACRO FIRST (LAMBDA (FILE RDTBL) (EVAL (READ FILE RDTBL] T) (/SETSYNTAX UNQUOTECHAR T EDITRDTBL))) (COND ((SETQ PPCHAR (INTCHECK PPCHAR)) (* ; "PPCHAR (usu. control-O) to the editor will print current expression") (/SETSYNTAX PPCHAR '[SPLICE FIRST IMMEDIATE ESCQUOTE (LAMBDA NIL (TERPRI T) (%## PP*) (PRIN1 '* T) NIL] EDITRDTBL) (/ECHOCONTROL PPCHAR 'IGNORE]) (INTCHECK [LAMBDA (CHAR) (* lmm "29-NOV-77 20:32") (PROG ((CHR CHAR) NCHR) [COND ((LISTP CHR) (SETQ CHR (CAR CHR] (COND ((NULL CHR) (RETURN))) [COND ((NOT (FIXP CHR)) (SETQ CHR (CHCON1 CHR] [COND ((IGREATERP CHR 64) (SETQ CHR (IDIFFERENCE CHR 64] (COND ((NOT (GETINTERRUPT CHR)) (RETURN CHR))) (COND ((NLISTP CHAR) (PRIN1 "control-" T) (PRIN1 (FCHARACTER (IPLUS CHR 64)) T) (PRIN1 " is an interrupt and can't be an edit control-character" T) (TERPRI T)) (T (COND [(SETQ NCHR (CADR CHAR)) (OR (FIXP NCHR) (SETQ NCHR (CHCON1 NCHR))) [COND ((IGREATERP NCHR 64) (SETQ NCHR (IDIFFERENCE NCHR 64] (INTCHAR (CONS NCHR (CDR (OR (INTCHAR CHR) (HELP] (T (INTCHAR CHR))) (RETURN CHR]) (CHARMACRO [NLAMBDA (X) (* NOBIND "18-JUL-78 22:15") (CFOBF) (* ; "clear file output buffer; no-op on dorado") (TERPRI T) X]) ) (RPAQ? EDITCHARACTERS ) (RPAQQ NEGATIONS ((NEQ . EQ) (NLISTP . LISTP) (GO . GO) (ERROR . ERROR) (ERRORX . ERRORX) (RETURN . RETURN) (RETFROM . RETFROM) (RETTO . RETTO) (IGREATERP . ILEQ) (ILESSP . IGEQ))) (ADDTOVAR EDITMACROS (NXP NIL [ORR (NX) (!NX (E (PRIN1 "> " T) T)) ((E (PROGN (SETQQ COM NX) (ERROR!] P) [-1P NIL (ORR (-1 P) ((E (PROGN (SETQQ COM -1) (ERROR!] (BKP NIL [ORR (BK) (!0) ((E (PROGN (SETQQ COM BK) (ERROR!] P) (2P NIL [ORR (2) (1) ((E (PROGN (SETQQ COM 2) (ERROR!] P)) (ADDTOVAR EDITCOMSA NXP -1P BKP 2P) (ADDTOVAR COMPACTHISTORYCOMS 2P NXP BKP -1P) (ADDTOVAR COMPACTHISTORYCOMS 2P NXP BKP -1P) (DECLARE%: DONTCOPY (DECLARE%: EVAL@COMPILE (PROGN (PUTPROPS CFOBF MACRO (NIL (ASSEMBLE NIL (MOVEI 1 %, 65) (JSYS 65)))) (PUTPROPS CFOBF DMACRO (NIL NIL))) ) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: SETTERMCHARS SETTERMCHARS INTCHECK (NOLINKFNS . T) (GLOBALVARS EDITRDTBL)) (BLOCK%: NIL CHARMACRO (LOCALVARS . T)) ) (* ; "macros for calling editor") (ADDTOVAR EDITMACROS [EV NIL (ORR [(E (LISPXEVAL (LIST 'EDITV (FIRSTATOM (%##))) 'EV->] ((E 'EV?] [EP NIL (ORR [(E (LISPXEVAL (LIST 'EDITP (FIRSTATOM (%##))) 'EP->] ((E 'EP?] [EF NIL (ORR [(E (LISPXEVAL (LIST 'EDITF (FIRSTATOM (%##))) 'EF->] ((E 'EF?]) (ADDTOVAR EDITCOMSA EV EP EF) (ADDTOVAR DONTSAVEHISTORYCOMS EF EV EP) (ADDTOVAR DONTSAVEHISTORYCOMS EF EV EP) (DEFINEQ (FIRSTATOM [LAMBDA (X) (* NOBIND "18-JUL-78 21:57") (* ; "Used by EF macro") (COND ((NLISTP X) X) (T (FIRSTATOM (CAR X]) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NIL FIRSTATOM (LOCALVARS . T)) ) (* ; "Misc edit macros") (ADDTOVAR USERMACROS (IFY NIL (F (COND --) T) UP [I 1 (COND.TO.IF (CDR (%## 1] 1)) (ADDTOVAR EDITMACROS (SWAP (LC1 LC2) (BIND (MARK %#3) (LC . LC1) UP (MARK %#1) (\ %#3) (LC . LC2) UP [IF (NOT (OR (FMEMB (CAAR %#1) L) (FMEMB (CAAR L) %#1))) ((E (SETQ %#2 (CAR (%##))) T) (\ %#1) (E (SETQ %#1 (CAR (%##))) T) (I 1 %#2) \ (I 1 %#1)) ((E '(NESTED EXPRESSIONS] (\ %#3))) [EVAL NIL (ORR [(E (LISPXEVAL (%## (ORR (UP 1) NIL)) '*] ((E 'EVAL?] [GO (LAB) (ORR ((_ ((*ANY* PROG ASSEMBLE DPROG RESETLST) -- LAB --)) F LAB (ORR 2 1) P) ((E (PROGN (SETQQ COM LAB) (ERROR!] (JOINC NIL (F COND T) UP (BI 1 2) 1 (BO 2) (2) (RO 1) (BO 1)) (NEGATE NIL UP (I 1 (NEGATE (%## 1))) 1) (SPLITC (X) (F COND T) (BI 1 X) (IF [AND (EQ (%## 2 1) T) (%## 2 2) (NULL (CDDR (%##] ((BO 2) (2)) ((-2 COND) (LI 2))) UP (BO 1)) (SWAPC NIL (F ((*ANY* COND IF if) --) T) UP (I 1 (SWAPPEDCOND (%## 1))) 1) (MAKE (VAR . VALS) (COMS (MAKECOM VAR VALS))) (D NIL (%:) 1 P) (Q NIL (MBD QUOTE)) (MAKEFN (FORM ARGS N M) [IF 'M ((BI N M) (LC . N) (BELOW \)) ((IF 'N ((BI N -1) (LC . N) (BELOW \)) ((LI 1] (E (MAKEFN 'FORM 'ARGS (%##)) T) UP (1 FORM) 1) (GETD NIL UP [ORR [(I 1 (OR [EDITGETD (%## 1) (AND (CDR L) (EDITL0 L '(!0] (ERROR!] ((E 'GETD?] 1) (GETVAL NIL UP [ORR [(I 1 (EVAL (%## 1) '*] ((E 'GETVAL?] 1)) (ADDTOVAR EDITCOMSA JOINC EVAL NEGATE SWAPC D Q GETD GETVAL) (ADDTOVAR EDITCOMSL SPLITC MAKE MAKEFN SWAP GO) (DEFINEQ (MAKEFN [LAMBDA (FORM ARGLIST BODY) (* lmm "10-Jun-85 01:37") (* ; "called from MAKEFN edit macro") (COND ((AND (LITATOM FORM) (FNTYP (CAR BODY)) (NULL (CDR BODY)) (NULL ARGLIST)) (DEFINE (LIST (CONS FORM BODY)) T)) (T (PROG ((A ARGLIST) (ACTUAL (CDR FORM)) DEF) (OR (AND (LISTP FORM) (CAR FORM) (LITATOM (CAR FORM))) (ERROR FORM "? " T)) LP (COND ((LISTP ACTUAL) [COND ((NLISTP A) (SETQ ARGLIST (NCONC ARGLIST (SETQ A (LIST (COND ((LITATOM (CAR ACTUAL)) (CAR ACTUAL)) (T (OR [CAR (SOME '(X Y Z A B C D) (FUNCTION (LAMBDA (X) (NOT (FMEMB X ARGLIST] (GENSYM] (AND (NEQ (CAR A) (CAR ACTUAL)) (ERSETQ (ESUBST (CAR A) (CAR ACTUAL) BODY))) (SETQ A (CDR A)) (SETQ ACTUAL (CDR ACTUAL)) (GO LP))) (DEFINE [LIST (LIST (CAR FORM) (SETQ DEF (CONS 'LAMBDA (CONS ARGLIST BODY] T]) (EDITGETD [LAMBDA (X EDITCHAIN) (* ; "Edited 23-Oct-91 16:34 by jds") (* ;;; "used by the GETD edit macro and by the SEdit command Meta-X.") (* ;;  "(CAR X) isn't guaranteed to be either a list or a litatom, so we have to check carefully.") (AND (LISTP X) (LET (DEF (FN (CAR X))) (COND ((LISTP FN) (EDITGETD-LAMBDA (CADR FN) (CDDR FN) (CDR X))) ([SETQ DEF (AND (LITATOM FN) (GET FN 'EDITGETD] (COPY (CL:FUNCALL DEF X))) ((AND (LITATOM FN) (GET FN 'MACRO-FN)) (* ;  "a *REAL* common lisp macro, not a fake one") (COPY (CL:MACROEXPAND-1 X))) ((AND (SETQ DEF (EXPANDMACRO X T)) (NEQ DEF X)) (* ; "This will catch Interlisp macros that are invisible to the new compiler but visible to the old one.") (COPY DEF)) ((AND (LITATOM FN) (GETPROP FN 'CLISPWORD)) [DWIMIFY X T (OR EDITCHAIN '(NIL] (COND ((NEQ FN (CAR X)) (* ; "form changed") X) ((SETQ DEF (GETHASH X CLISPARRAY)) (COPY DEF)) (T X))) ((AND (SETQ DEF (GETDEF FN 'FUNCTIONS NIL 'NOERROR)) (EQ (CAR DEF) 'CL:DEFUN)) (EDITGETD-LAMBDA (CADDR DEF) (CDDDR DEF) (CDR X))) [(SETQ DEF (GETDEF FN 'FNS NIL 'NOERROR)) (COND [(EQ (CAR DEF) 'NLAMBDA) (EDITGETD-LAMBDA (CADR DEF) (CDDR DEF) (MAPCAR (CDR X) (FUNCTION KWOTE] ((AND (EQ (CAR DEF) 'LAMBDA) (CADR DEF) (NLISTP (CADR DEF))) (* ; "LAMBDA spread") (CONS DEF (CDR X))) (T (EDITGETD-LAMBDA (CADR DEF) (CDDR DEF) (CDR X] (T X]) (EDITGETD-LAMBDA [LAMBDA (ARGS BODY VALS DONE) (* lmm " 5-Jun-86 01:41") (if (NULL ARGS) then (if DONE then `(LET ,(REVERSE DONE) ,@BODY) else (MKPROGN BODY)) elseif (CL:CONSP (CAR ARGS)) then (EDITGETD-LAMBDA (CDR ARGS) BODY (CDR VALS) (CONS (LIST (CAAR ARGS) (if VALS then (CAR VALS) else (CADAR ARGS))) DONE)) else (SELECTQ (CAR ARGS) ((&ALLOW-OTHER-KEYS &OPTIONAL) (EDITGETD-LAMBDA (CDR ARGS) BODY VALS DONE)) (&AUX (EDITGETD-LAMBDA ARGS (APPEND VALS BODY) NIL DONE)) ((&BODY &REST) [EDITGETD-LAMBDA (CDDR ARGS) BODY NIL `((,(CADR ARGS) (LIST ,@VALS)) ,@DONE]) (EDITGETD-LAMBDA (CDR ARGS) BODY (CDR VALS) (CONS (LIST (CAR ARGS) (CAR VALS)) DONE]) (EDITGETD-LET [LAMBDA (FORM) (* lmm " 5-Jun-86 01:44") (MKPROGN (SUBPAIR (MAPCAR (CADR FORM) (FUNCTION CAR)) (MAPCAR (CADR FORM) (FUNCTION CADR)) (CDDR FORM]) (NEGATE [LAMBDA (X) (* JonL "10-Apr-84 22:05") (SELECTQ (CAR (LISTP X)) ((NOT NULL) (CADR X)) (AND (CONS 'OR (NEGLST (CDR X)))) (OR (CONS 'AND (NEGLST (CDR X)))) (COND [COND [[AND (NULL (CDDR X)) (NULL (CDR (CDADR X] (NEGATE (CONS 'AND (CADR X] (T (CONS 'COND (NEGC (CDR X]) (SELECTQ [CONS 'SELECTQ (CONS (CADR X) (MAPLIST (CDDR X) (FUNCTION (LAMBDA (X) (COND [(CDR X) (CONS (CAAR X) (NEGL (CDAR X] (T (NEGATE (CAR X]) (PROGN (MKPROGN (NEGL (CDR X)))) (PROG1 (CONS 'PROG1 (CONS (NEGATE (CADR X)) (CDDR X)))) (QUOTE (NULL (CADR X))) ((CONS) (* ; "functions which always return non-NIL") (MKPROGN (APPEND (CDR X) (LIST NIL)))) (COND [(for Y in NEGATIONS do (COND [(EQ (CAR Y) (CAR X)) (RETURN (CONS (CDR Y) (CDR X] ((EQ (CDR Y) (CAR X)) (RETURN (CONS (CAR Y) (CDR X] (T (OR (NULL X) (AND (NEQ X T) (NOT (OR (NUMBERP X) (STRINGP X))) (LIST 'NOT X]) (NEGL [LAMBDA (L) (* lmm%: " 7-FEB-77 17:17:51") (COND [(NULL (CDR L)) (LIST (NEGATE (CAR L] (T (CONS (CAR L) (NEGL (CDR L]) (NEGLST [LAMBDA (L) (MAPCAR L (FUNCTION NEGATE]) (NEGC [LAMBDA (X) (* lmm "14-SEP-78 23:07") (COND ((NULL X) (LIST (LIST T T))) [(NULL (CDAR X)) (* (COND (A) . TAIL) -> (NOT (OR A (COND . TAIL))) -> (AND (NOT A) (NOT (COND . TAIL)))) (LIST (LIST (NEGATE (CAAR X)) (OR (NULL (CDR X)) (AND (SETQ X (NEGC (CDR X))) (CONS 'COND X] (T (CONS (CONS (CAAR X) (NEGL (CDAR X))) (AND (NEQ (CAAR X) T) (NEGC (CDR X]) (MKPROGN [LAMBDA (L) (* wt%: "18-JUL-78 12:57") (COND ((CDR (SETQ L (MKPROGN1 L))) (CONS 'PROGN L)) (T (CAR L]) (MKPROGN1 [LAMBDA (L) (* lmm "21-SEP-77 15:19") (COND ((NULL (CDR L)) (COND ((EQ (CAAR L) 'PROGN) (CDAR L)) (T L))) ((NLISTP (CAR L)) (MKPROGN1 (CDR L))) (T (SELECTQ (CAAR L) ((PROGN LIST CONS CAR CDR NOT NULL) (MKPROGN1 (APPEND (CDAR L) (CDR L)))) (QUOTE (MKPROGN1 (CDR L))) (CONS (CAR L) (MKPROGN1 (CDR L]) (MAKECOM [NLAMBDA (VAR VALS) (* wt%: "19-JUL-78 11:35") (PROG (ARGNAMES (FORM (%##))) (SETQ ARGNAMES (SMARTARGLIST (SETQ COM (CAR FORM)) NIL FORM)) (OR [AND (LISTP ARGNAMES) (OR (FMEMB (SETQ COM VAR) ARGNAMES) (SETQ VAR (FIXSPELL VAR NIL (APPEND ARGNAMES) NIL] (ERROR!)) (RETURN (PROG (($$LST2 ARGNAMES) $$VAL I ARG LST) (* (FOR I FROM 2 AS ARG IN VALS UNTIL ARG=VAR DO --)) (SETQ I 2) $$LP [SETQ ARG (CAR (OR (LISTP $$LST2) (GO $$OUT] [COND ((EQ ARG VAR) (RETURN (COND ((NOT (OR VALS (NULL (CDR FORM)) (CDDR FORM))) (LIST I)) [(CDR FORM) (LIST I (COND ((CDR VALS) VALS) (T (CAR VALS] (T (CONS 'N (NCONC1 LST (COND ((CDR VALS) VALS) (T (CAR VALS] [COND ((NULL (SETQ FORM (CDR FORM))) (SETQ LST (CONS NIL LST] $$ITERATE (SETQ I (IPLUS I 1)) (SETQ $$LST2 (CDR $$LST2)) (GO $$LP) $$OUT (ERROR!) (RETURN $$VAL]) (SWAPPEDCOND [LAMBDA (CND) (* lmm "25-SEP-83 23:50") (SELECTQ (CAR CND) ((IF if) (DWIMIFY CND T L) [COND.TO.IF (CDR (SWAPPEDCOND (COND ((EQ (CAR CND) 'COND) CND) ((GETHASH CND CLISPARRAY)) (T (ERROR!]) (COND [PROG ((C1 (CADR CND)) (CTAIL (CDDR CND)) (C2 (CADDR CND))) (if (NOT (CDR C1)) then (* ; "cannot negate (COND (A) --)") (ERROR!)) (RETURN (CONS 'COND (CONS [CONS (NEGATE (CAR C1)) (OR (AND (EQ (CAR C2) T) (CDR C2)) (COND ((NULL CTAIL) (* ; "only one clause. Turn (COND (A --)) into (COND ((NOT A) NIL) (T --))") (LIST NIL)) (T (* ; "embed multiple subsequent clauses into one COND") (LIST (CONS 'COND CTAIL] (COND ((AND (NULL (CDDR C1)) (EQ (CAADR C1) 'COND)) (* ; "consequent of first clause is a COND itself. Expand out in the tail") (CDADR C1)) ((AND (NULL (CADR C1)) (NULL (CDDR C1))) (* ; "(COND (A NIL) --) when swapped doesn't need a final T clause") NIL) (T (LIST (CONS T (CDR C1]) (SHOULDNT]) (COND.TO.IF [LAMBDA (CONDCLAUSES) (* lmm "25-SEP-83 23:47") (CONS 'if (CDR (for X in CONDCLAUSES join (COND ((AND (EQ (CAR X) T) (NEQ X (CAR CONDCLAUSES))) (CONS 'else (CDR X))) (T (CONS 'elseif (CONS (CAR X) (COND ((CDR X) (CONS 'then (APPEND (CDR X]) ) (PUTPROPS LET EDITGETD EDITGETD-LET) (PUTPROPS CL:IF EDITGETD [LAMBDA (FORM) (DESTRUCTURING-BIND (TEST THEN ELSE) (CDR FORM) `(COND (,TEST ,THEN) ,@(AND ELSE `((T ,ELSE]) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (BLOCK%: NEGATE NEGATE NEGL NEGLST NEGC (NOLINKFNS . T) (GLOBALVARS NEGATIONS)) (BLOCK%: MKPROGN MKPROGN MKPROGN1 (NOLINKFNS . T)) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLISPARRAY MACROPROPS) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (LOCALVARS . T) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS LAMBDASPLST NORMALCOMMENTSFLG COMMENTFLG FIRSTNAME INITIALS INITIALSLST DEFAULTINITIALS) ) (MOVD? 'NILL 'PREEDITFN) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML MAKECOM CHARMACRO) (ADDTOVAR LAMA ) ) (PUTPROPS WEDIT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (9964 14090 (SETTERMCHARS 9974 . 12517) (INTCHECK 12519 . 13789) (CHARMACRO 13791 . 14088)) (16398 16674 (FIRSTATOM 16408 . 16672)) (20296 36077 (MAKEFN 20306 . 22158) (EDITGETD 22160 . 24760) (EDITGETD-LAMBDA 24762 . 26117) (EDITGETD-LET 26119 . 26431) (NEGATE 26433 . 28591) (NEGL 28593 . 28820) (NEGLST 28822 . 28880) (NEGC 28882 . 29664) (MKPROGN 29666 . 29860) (MKPROGN1 29862 . 30448) (MAKECOM 30450 . 32628) (SWAPPEDCOND 32630 . 35407) (COND.TO.IF 35409 . 36075))))) STOP \ No newline at end of file diff --git a/sources/WINDOW b/sources/WINDOW new file mode 100644 index 00000000..d92e423e --- /dev/null +++ b/sources/WINDOW @@ -0,0 +1,1887 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) +(FILECREATED " 9-Apr-2000 17:36:29" {DSK}sybalsky>lispcore>sources>WINDOW.;6 225105 + + changes to%: (FNS WINDOWWORLD CREATESCREEN) + + previous date%: "28-Jun-99 17:17:47" {DSK}sybalsky>lispcore>sources>WINDOW.;5) + + +(* ; " +Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994, 1999, 2000 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT WINDOWCOMS) + +(RPAQQ WINDOWCOMS + [(COMS (FNS WINDOWWORLD WINDOWWORLDP CHANGEBACKGROUND CHANGEBACKGROUNDBORDER TILE + \TTY.CREATING.DISPLAYSTREAM \CREATE.TTY.OUTCHARFN \CREATE.TTYDISPLAYSTREAM + HASTTYWINDOWP TTYINFOSTREAM CREATESCREEN \INSURESCREEN \BITMAPTOSCREEN MAINSCREEN) + (VARS (\TTYREGIONOFFSETSPTR)) + (INITVARS [TTYREGIONOFFSETS '((0 . 0) + (20 . -20) + (40 . 0) + (20 . 20] + (DEFAULTTTYREGION '(153 100 384 208)) + (INITIAL-EXEC-REGION '(8 378 550 330)) + (INITIAL-PROMPT-REGION '(8 719 550 89)) + (\MAINSCREEN) + (\CURRENTBACKGROUNDBORDER) + (\SCREENS) + (\SCREENBITMAPS)) + (GLOBALVARS \TTYREGIONOFFSETSPTR TTYREGIONOFFSETS \DEFAULTTTYDISPLAYSTREAM) + (VARIABLES \TopLevelTtyWindow)) + (COMS (* ; "Window menu operations") + (FNS WINDOW.MOUSE.HANDLER \PROTECTED.APPLY DOWINDOWCOM DOBACKGROUNDCOM + DEFAULT.BACKGROUND.COPYFN) + (VARS (BackgroundCopyMenu)) + (INITVARS BackgroundCopyMenuCommands) + (FNS BURYW CLEARW CLOSEW \CLOSEW1 \OKTOCLOSEW \INTERACTIVE.CLOSEW OPENW DOUSERFNS + DOUSERFNS2 \USERFNISDON'T \OPENW1 CREATEW CREATEW1 \CREATEW1 OPENDISPLAYSTREAM + MOVEW PPROMPT3 \ONSCREENCLIPPINGREGION RELMOVEW SHAPEW SHAPEW1 \SHAPEW2 + RESHOWBORDER \RESHOWBORDER1 TRACKW SNAPW WINDOWREGION) + (FNS MINIMUMWINDOWSIZE) + (INITVARS (BACKGROUNDCURSORINFN) + (BACKGROUNDBUTTONEVENTFN) + (BACKGROUNDCURSOROUTFN) + (BACKGROUNDCURSORMOVEDFN) + (BACKGROUNDCOPYBUTTONEVENTFN) + (BACKGROUNDCOPYRIGHTBUTTONEVENTFN (FUNCTION DEFAULT.BACKGROUND.COPYFN)) + (BACKGROUNDCURSOREXITFN)) + (GLOBALVARS BACKGROUNDCURSORINFN BACKGROUNDBUTTONEVENTFN BACKGROUNDCURSOROUTFN + BACKGROUNDCURSORMOVEDFN BACKGROUNDCOPYBUTTONEVENTFN + BACKGROUNDCOPYRIGHTBUTTONEVENTFN \CARET.UP BACKGROUNDCURSOREXITFN) + (EXPORT (MACROS .COPYKEYDOWNP. WSOP)) + (PROP ARGNAMES WSOP) + (RECORDS WSOPS WSDATA)) + (COMS (* ; "Window utilities") + (FNS ADVISEWDS SHOWWFRAME SHOWWTITLE \STRINGWIDTHGUESS RESHOWTITLE TOTOPW + \INTERNALTOTOPW \TTW1 WHICHW) + (INITVARS (WINDOWTITLEPRINTLEVEL '(2 . 5)) + (WINDOWTITLESHADE BLACKSHADE))) + [COMS (* ; "Window vs non-window world") + (FNS WFROMDS NU\TOTOPWDS \COERCETODS) + (DECLARE%: DONTCOPY (EXPORT (MACROS \COERCETODS .WHILE.ON.TOP.))) + (P (MOVD 'NU\TOTOPWDS '\TOTOPWDS] + (COMS (* ; "User interface functions") + (FNS WINDOWP INSURE.WINDOW WINDOWPROP WINDOWADDPROP WINDOWDELPROP GETWINDOWPROP + GETWINDOWUSERPROP PUTWINDOWPROP REMWINDOWPROP WINDOWADDFNPROP) + (* ; "Compiled WINDOWPROP") + (PROP ARGNAMES WINDOWPROP) + (OPTIMIZERS WINDOWPROP) + (FNS CWINDOWPROP CGETWINDOWPROP \GETWINDOWHEIGHT \GETWINDOWWIDTH)) + (COMS (FNS OPENWP TOPWP RESHAPEBYREPAINTFN \INBETWEENP DECODE/WINDOW/OR/DISPLAYSTREAM + GROW/REGION CLRPROMPT PROMPTPRINT OPENWINDOWS \INSUREWINDOW) + (* ; + "these entries are left in for backward compatibility. They were dedocumented 6/83. rrb") + (P (MOVD 'OPENWP 'ACTIVEWP)) + (FNS OVERLAPPINGWINDOWS WOVERLAPP ORDERFROMBOTTOMTOTOP) + (* ; "screen size changing functions.") + (FNS \ONSCREENW \PUTONSCREENW \UPDATECACHEDFIELDS \WWCHANGESCREENSIZE CREATEWFROMIMAGE + UPDATEWFROMIMAGE)) + [COMS + (* ;; "MEDLEY-NATIVE-WINDOWS INTERFACE FUNCTIONS") + + (GLOBALVARS \SCREENS \SCREENTYPES) + [INITVARS + + (* ;; "\SCREENS is a list of all known screens. The SCREEN-CREATE function for the screen type must register it there. It's used, e.g., by DSPCREATE to find the right screen given a screen bitmap.") + + (\SCREENS) + + (* ;; "\SCREENTYPES is used to interpret the values we get back from the query-for-screen-types function, and to look up the methods for creating a screen and destroying one.") + + (\SCREENTYPES '((1 MEDLEY OPEN-SCREEN CREATESCREEN CLOSE-SCREEN NILL) + (2 MEDLEY-COLOR-4) + (4 MEDLEY-COLOR-8) + (8 MEDLEY-COLOR-24) + (16 X-MONO) + (32 X-COLOR) + (64 MS-WINDOWS] + + (* ;; "OLD-MEDLEY-SCREEN window management functions") + + (FNS \MEDW.CREATEW \MEDW.OPENW \MEDW.CLOSEW \MEDW.MOVEW \MEDW.RELMOVEW \MEDW.SHRINKW + \MEDW.EXPANDW \MEDW.SHAPEW \MEDW.REDISPLAYW \MEDW.BURYW \MEDW.TOTOPW + \MEDW.DSPCREATE \GENERIC.DSPCREATE \MEDW.GETWINDOWPROP \MEDW.PUTWINDOWPROP + \MEDW.CURSOR) + (FNS \GENERIC.CURSOR) + (DECLARE%: EVAL@COMPILE DONTCOPY (EXPORT (MACROS WINDOWOP))) + (DECLARE%: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY + + (* ;; + "Take care of installing the generic DSPCREATE over the simple one defined in LLDISPLAY.") + + (P (CL:UNLESS (EQUAL (GETD 'DSPCREATE) + (GETD '\GENERIC.DSPCREATE)) + (MOVD '\GENERIC.DSPCREATE 'DSPCREATE)) + (CL:UNLESS (EQUAL (GETD 'CURSOR) + (GETD '\GENERIC.CURSOR)) + (MOVD '\GENERIC.CURSOR 'CURSOR))] + (DECLARE%: EVAL@COMPILE DONTCOPY + (GLOBALVARS \LastCursorPosition \LastInWindow WindowMenu BackgroundMenu + BackgroundMenuCommands \LastWindowButtons WWFNS WindowMenuCommands + WindowTitleDisplayStream WINDOWTITLEPRINTLEVEL WBorder \TOPWDS + WINDOWBACKGROUNDSHADE BACKGROUNDFNS) + (EXPORT (CONSTANTS (MinWindowWidth 26) + (MinWindowHeight 16)) + (RECORDS WINDOW SCREEN))) + (DECLARE%: EVAL@COMPILE (EXPORT (GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW + ))) + (SYSRECORDS WINDOW SCREEN) + (INITRECORDS WINDOW SCREEN) + (INITVARS (WindowMenu) + (BackgroundMenu) + (\LastCursorPosition (CREATEPOSITION)) + (\LastInWindow) + (\LastWindowButtons 0) + (WINDOWBACKGROUNDSHADE 34850) + (WBorder 4) + (HIGHLIGHTSHADE 32800) + (WINDOWBACKGROUNDBORDER 34850)) + (FILES PAINTW) + [ADDVARS (WindowMenuCommands (Close '\INTERACTIVE.CLOSEW "Closes a window") + (Snap 'SNAPW "Saves a snapshot of a region of the screen.") + (Paint 'PAINTW + "Starts a painting mode in which the mouse can be +used to draw pictures or make notes on windows.") + (Clear 'CLEARW "Clears a window to its gray.") + (Bury 'BURYW "Puts a window on the bottom.") + (Redisplay 'REDISPLAYW "Redisplays a window using its REPAINTFN.") + (Hardcopy 'HARDCOPYIMAGEW "Prints a window using its HARDCOPYFN." + (SUBITEMS ("To a file" 'HARDCOPYIMAGEW.TOFILE + "Puts image on a file; prompts for filename and format" + ) + ("To a printer" 'HARDCOPYIMAGEW.TOPRINTER + "Sends image to a printer of your choosing"))) + (Move 'MOVEW "Moves a window by a corner.") + (Shape 'SHAPEW "Gets a new region for a window. +Left button down marks fixed corner; sweep to other corner. +Middle button down moves closest corner.") + (Shrink 'SHRINKW + "Replaces this window with its icon (or title if it doesn't have an icon." + )) + (BackgroundMenuCommands (SaveVM '(SAVEVM) + "Updates the virtual memory.") + (Snap '(SNAPW) + "Saves a snapshot of a region of the screen.") + (Hardcopy '(HARDCOPYW) + "Send hardcopy of screen region to printer." + (SUBITEMS ("To a file" '(HARDCOPYREGION.TOFILE) + + "Writes a region of screen to a file; prompts for filename and format" + ) + ("To a printer" '(HARDCOPYREGION.TOPRINTER) + "Sends a region of screen to a printer of your choosing"] + (ADDVARS (WINDOWUSERFORMS) + (ENDOFWINDOWUSERFORMS)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (P (COND ((NULL \MAINSCREEN) + (SETQ \MAINSCREEN (CREATESCREEN (SCREENBITMAP))) + (SETQ \CURSORSCREEN \MAINSCREEN) + (SETQ LASTSCREEN \MAINSCREEN) + (WINDOWWORLD 'ON \MAINSCREEN T))) + (MOVD? 'TRUE 'LISPWINDOWP)) + (VARS (\WINDOWWORLD T))) + + (* ;; "Arrange for the proper compiler") + + (PROP FILETYPE WINDOW) + (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) + (NLAML) + (LAMA PROMPTPRINT + WINDOWPROP + DOWINDOWCOM]) +(DEFINEQ + +(WINDOWWORLD + [LAMBDA (ONOFF SCREEN MAINFLG) (* ; "Edited 28-Feb-94 13:07 by sybalsky") + + (* ;; "ONOFF should be ON or OFF. SCREEN will generally be either \MAINSCREEN or \COLORSCREEN. MAINFLG = T if this is the first window world being created (\MAINSCREEN), in which case we create the EXEC window, PROMPTWINDOW, and LOGOW. ") + + (DECLARE (GLOBALVARS \TopLevelTtyWindow)) + (PROG NIL + (SETQ SCREEN (\INSURESCREEN SCREEN)) + (COND + ((NULL ONOFF) + (RETURN (fetch (SCREEN SCONOFF) of SCREEN))) + ((EQ ONOFF (fetch (SCREEN SCONOFF) of SCREEN)) + (* ; "Already on or off. *") + ) + ((EQ ONOFF 'ON) + (UNINTERRUPTABLY + (\CLEARBM (fetch (SCREEN SCDESTINATION) of SCREEN) + WINDOWBACKGROUNDSHADE) (* ; + "Initially there are no windows. SCTOPW must be NIL before any CREATEWs are done. ") + (replace (SCREEN SCTOPW) of SCREEN with NIL) + (CHANGEBACKGROUNDBORDER WINDOWBACKGROUNDBORDER) + (SETQ \TOPWDS NIL) + (CL:PUSHNEW (fetch (SCREEN SCDESTINATION) of SCREEN) + \SCREENBITMAPS) + (CL:PUSHNEW SCREEN \SCREENS) + (replace (SCREEN SCONOFF) of SCREEN with 'ON) + [COND + (MAINFLG (* ; + "creating the first window system") + + (* ;; "set up stream for displaying titles") + + (SETQ WindowTitleDisplayStream (fetch (SCREEN SCTITLEDS) of + SCREEN)) + (* ; + "Get TTY in shape. Region is only approx as user can change it.") + + (* ;; "default display stream will create a window when it needs one") + + (SETQ \DEFAULTTTYDISPLAYSTREAM (\TTY.CREATING.DISPLAYSTREAM)) + + (* ;; "create the exec window") + + (TTYDISPLAYSTREAM (SETQ \TopLevelTtyWindow (CREATEW + INITIAL-EXEC-REGION + "Exec"))) + (SETLINELENGTH) + (SETQ PROMPTWINDOW (CREATEW INITIAL-PROMPT-REGION "Prompt Window" 2)) + (DSPTEXTURE BLACKSHADE PROMPTWINDOW) + (DSPOPERATION 'ERASE PROMPTWINDOW) + (DSPSCROLL 'ON PROMPTWINDOW) + (WINDOWPROP PROMPTWINDOW 'SHRINKFN 'DON'T) + (CLEARW PROMPTWINDOW) + (WINDOWPROP PROMPTWINDOW 'PAGEFULLFN (FUNCTION NILL)) + (replace (SCREEN PROMPTW) OF SCREEN with PROMPTWINDOW) + + (* ;; "window.mouse.handler variables?") + + (SETQ \LastInWindow NIL) + (SETQ \LastWindowButtons 0) + (SETQ \LastCursorPosition (create POSITION)) + + (* ;; "other things that happen at WINDOWWORLD time") + + (MAPC WINDOWUSERFORMS (FUNCTION EVAL])]) + +(WINDOWWORLDP [LAMBDA (SCREEN) (* kbr%: "30-Mar-85 14:28") (* ; "is the window system operating?") (EQ (fetch (SCREEN SCONOFF) of (\INSURESCREEN SCREEN)) 'ON]) + +(CHANGEBACKGROUND [LAMBDA (SHADE SCREEN) (* ; "Edited 6-Jul-88 11:39 by drc:") (* ;  "changes the window world background to SHADE") (PROG (WINDOWS) (COND ((OR (NULL SHADE) (EQ SHADE T)) (SETQ SHADE WINDOWBACKGROUNDSHADE)) ((NOT (OR (TEXTUREP SHADE) (BITMAPP SHADE))) (\ILLEGAL.ARG SHADE))) (OR SCREEN (SETQ SCREEN \CURSORSCREEN)) (SETQ WINDOWS (OPENWINDOWS SCREEN)) (for W in WINDOWS do (\CLOSEW1 W)) [COND ((TEXTUREP SHADE) (BLTSHADE SHADE (fetch (SCREEN SCDESTINATION) of SCREEN))) ((BITMAPP SHADE) (TILE SHADE (fetch (SCREEN SCDESTINATION) of SCREEN] (for W in (DREVERSE WINDOWS) do (\OPENW1 W]) + +(CHANGEBACKGROUNDBORDER [LAMBDA (SHADE) (* lmm "25-Apr-86 15:48") (* ;; "Changes the screen border on a Dandelion. SHADE is a 8x2 pattern") (PROG1 \CURRENTBACKGROUNDBORDER (COND ((SMALLP SHADE) (SETQ \CURRENTBACKGROUNDBORDER SHADE) (SELECTC \MACHINETYPE (\DANDELION (replace (IOPAGE DLDISPBORDER) of \IOPAGE with SHADE)) (\DAYBREAK (\DoveDisplay.SetBorderPattern SHADE)) NIL))))]) + +(TILE [LAMBDA (SRC DST) (* kbr%: "10-Jul-85 23:51") (PROG (X Y W H DSTW DSTH) (SETQ X 0) (SETQ Y 0) (SETQ W (BITMAPWIDTH SRC)) (SETQ H (BITMAPHEIGHT SRC)) (SETQ DSTW (BITMAPWIDTH DST)) (SETQ DSTH (BITMAPHEIGHT DST)) (while (ILESSP X DSTW) do (SETQ Y 0) (while (ILESSP Y DSTH) do (BITBLT SRC 0 0 DST X Y W H NIL 'REPLACE) (add Y H)) (add X W]) + +(\TTY.CREATING.DISPLAYSTREAM [LAMBDA NIL (* rmk%: "27-AUG-83 13:41") (* ;; "creates a displaystream that points to a stream that has a OUTCHARFN that creates a new displaystream. It is used as the default TtyDisplayStream in a process.") (PROG [(DS (DSPCREATE (BITMAPCREATE 1 1] (replace OUTCHARFN of DS with (FUNCTION \CREATE.TTY.OUTCHARFN)) (replace FULLFILENAME of DS with T) (RETURN DS]) + +(\CREATE.TTY.OUTCHARFN [LAMBDA (STREAM CHAR) (* ; "Edited 8-Mar-87 14:58 by bvm:") (* ;; "outcharfn for \DEFAULTTTYDISPLAYSTREAM which creates a new window and then bouts to it.") (\OUTCHAR (\CREATE.TTYDISPLAYSTREAM) CHAR]) + +(\CREATE.TTYDISPLAYSTREAM [LAMBDA NIL (* ; "Edited 9-Mar-87 13:05 by bvm:") (* ;; "Called when system attempts input from or output to the %"default tty stream%", a dummy stream that is every new process's initial standard i/o. We make a new window to be the ttydisplaystream, and return the stream.") [COND ((AND \WINDOWWORLD (NOT (HASTTYWINDOWP NIL))) (* ;; "Check that the process does not yet have a tty window. We can get called even after one is created in the case where somebody explicitly passed (TTYDISPLAYSTREAM) or *STANDARD-OUTPUT* as an argument to someone else (e.g., as stream arg to a printing fn that prints more than one character). In this case, TTYDISPLAYSTREAM can't update the private variable holding the stream, so the dummy outcharfn gets called again. So avoid creating a second window!") (* ;; "\windowworld check is to prevent error when loading window during loadup") (COND ((NULL (SETQ \TTYREGIONOFFSETSPTR (CDR \TTYREGIONOFFSETSPTR))) (* ;  "the offsets distribute the break windows a little so many can be seen.") (SETQ \TTYREGIONOFFSETSPTR TTYREGIONOFFSETS))) (SETQ \TTYWINDOW (CREATEW (CREATEREGION (IPLUS (fetch (REGION LEFT) of DEFAULTTTYREGION ) (CAR (CAR \TTYREGIONOFFSETSPTR))) (IPLUS (fetch (REGION BOTTOM) of DEFAULTTTYREGION ) (CDR (CAR \TTYREGIONOFFSETSPTR))) (fetch (REGION WIDTH) of DEFAULTTTYREGION) (fetch (REGION HEIGHT) of DEFAULTTTYREGION)) (CONCAT "TTY window for " (PROCESSPROP (THIS.PROCESS) 'NAME)) NIL T)) (* ;; "\TTYWINDOW (bound at top of each process) saves the window so it won't get collected. This allows WFROMDS to find it even if it is closed, which is how we create it initially (in case no output ever actually happens). In future, if windows become streams this can go away.") (TTYDISPLAYSTREAM \TTYWINDOW)) ((EQ *STANDARD-OUTPUT* \DEFAULTTTYDISPLAYSTREAM) (* ; "Somebody bound *STANDARD-OUTPUT* at the time the tty window got created, so masked this binding. Fix it now to avoid future calls here") (SETQ *STANDARD-OUTPUT* (TTYDISPLAYSTREAM] (TTYDISPLAYSTREAM]) + +(HASTTYWINDOWP [LAMBDA (PROCESS) (* lmm "17-Jan-86 20:31") (* ;; "True if PROCESS has a tty window already.") (NEQ (OR (PROCESS.TTY PROCESS) \DEFAULTTTYDISPLAYSTREAM) \DEFAULTTTYDISPLAYSTREAM]) + +(TTYINFOSTREAM + [LAMBDA (PROCESS) (* ; "Edited 7-Mar-94 11:58 by sybalsky") + +(* ;;; "Returns a stream to which to print informative messages = PROCESS tty if PROCESS has one, else PROMPTWINDOW") + + (DECLARE (GLOBALVARS \DEFAULTTTYDISPLAYSTREAM)) + (PROG ((STREAM (PROCESS.TTY PROCESS))) + (RETURN (COND + ((AND STREAM (NEQ STREAM \DEFAULTTTYDISPLAYSTREAM)) + STREAM) + (T (\GETSTREAM PROMPTWINDOW]) + +(CREATESCREEN + [LAMBDA (DESTINATION) (* ; "Edited 2-Mar-94 01:44 by sybalsky") + +(* ;;; "destination is the framebuffer for the screen you want created.e.g. (SCREENBITMAP) Creates a screen describing a medley regular window system.") + + (PROG (TITLEDS SCREEN) + (SETQ TITLEDS (DSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") + (DSPOPERATION 'INVERT TITLEDS) + (DSPFONT WINDOWTITLEFONT TITLEDS) + (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ; + "Set right margin so title doesn't autoCR. ") + + (* ;; "now create SCREEN. ") + + (SETQ SCREEN (create SCREEN + SCONOFF _ 'OFF + SCDESTINATION _ DESTINATION + SCWIDTH _ (BITMAPWIDTH DESTINATION) + SCHEIGHT _ (BITMAPHEIGHT DESTINATION) + SCDEPTH _ (BITSPERPIXEL DESTINATION) + SCTOPW _ NIL + SCTITLEDS _ TITLEDS + CREATEWFN _ (FUNCTION \MEDW.CREATEW) + OPENWFN _ (FUNCTION \MEDW.OPENW) + CLOSEWFN _ (FUNCTION \MEDW.CLOSEW) + MOVEWFN _ (FUNCTION \MEDW.MOVEW) + RELMOVEWFN _ (FUNCTION \MEDW.RELMOVEW) + SHRINKWFN _ (FUNCTION \MEDW.SHRINKW) + EXPANDWFN _ (FUNCTION \MEDW.EXPANDW) + SHAPEWFN _ (FUNCTION \MEDW.SHAPEW) + REDISPLAYFN _ (FUNCTION \MEDW.REDISPLAYW) + BURYWFN _ (FUNCTION \MEDW.BURYW) + TOTOPWFN _ (FUNCTION \MEDW.TOTOPW) + DSPCREATEFN _ (FUNCTION \MEDW.DSPCREATE) + GETWINDOWPROPFN _ (FUNCTION \MEDW.GETWINDOWPROP) + PUTWINDOWPROPFN _ (FUNCTION \MEDW.PUTWINDOWPROP) + SETCURSORFN _ (FUNCTION \MEDW.CURSOR) + WINIMAGEOPS _ \DISPLAYIMAGEOPS + WINFDEV _ DisplayFDEV + BBTTOWIN _ (FUNCTION \MEDW.BBTTOWIN) + BBTFROMWIN _ (FUNCTION \MEDW.BBTFROMWIN) + BBTWINWIN _ (FUNCTION \MEDW.BBTWINWIN) + SCCARETFLASH _ (FUNCTION \MEDW.CARET.SHOW) + SCGETSCREENPOSITION _ (FUNCTION \MEDW.GETSCREENPOSITION) + SCGETBOXSCREENPOSITION _ (FUNCTION \MEDW.GETBOXSCREENPOSITION) + SCGETSCREENREGION _ (FUNCTION \MEDW.GETSCREENREGION))) + (CL:PUSHNEW SCREEN \SCREENS) (* ; "Register this screen.") + (RETURN SCREEN]) + +(\INSURESCREEN [LAMBDA (SCREEN) (* kbr%: " 4-Aug-85 13:30") (COND ((type? SCREEN SCREEN) SCREEN) ((NULL SCREEN) \CURSORSCREEN) (T (\ILLEGAL.ARG SCREEN]) + +(\BITMAPTOSCREEN [LAMBDA (BITMAP) (* gbn%: "25-Jan-86 16:44") (* ;;; "returns the screen with this bitmap as its destination, NIL otherwise") (for SCREEN in \SCREENS thereis (EQ (fetch (SCREEN SCDESTINATION) of SCREEN) BITMAP]) + +(MAINSCREEN [LAMBDA NIL (* kbr%: " 2-Feb-86 14:55") \MAINSCREEN]) +) + +(RPAQQ \TTYREGIONOFFSETSPTR NIL) + +(RPAQ? TTYREGIONOFFSETS '((0 . 0) + (20 . -20) + (40 . 0) + (20 . 20))) + +(RPAQ? DEFAULTTTYREGION '(153 100 384 208)) + +(RPAQ? INITIAL-EXEC-REGION '(8 378 550 330)) + +(RPAQ? INITIAL-PROMPT-REGION '(8 719 550 89)) + +(RPAQ? \MAINSCREEN ) + +(RPAQ? \CURRENTBACKGROUNDBORDER ) + +(RPAQ? \SCREENS ) + +(RPAQ? \SCREENBITMAPS ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \TTYREGIONOFFSETSPTR TTYREGIONOFFSETS \DEFAULTTTYDISPLAYSTREAM) +) + +(DEFGLOBALVAR \TopLevelTtyWindow) + + + +(* ; "Window menu operations") + +(DEFINEQ + +(WINDOW.MOUSE.HANDLER + [LAMBDA NIL (* ; "Edited 22-Mar-94 13:31 by sybalsky") + +(* ;;; "Does user window operations if state of buttons has changed or mouse has changed windows") + + (COND + (\INTERRUPTABLE (* ; + "don't do anything if uninterruptable") + (PROG (\MHCOM \MHPROCESS \MHWINDOW) + (GETMOUSESTATE) + [COND + ((OR (NEQ LASTMOUSEX (fetch XCOORD of \LastCursorPosition)) + (NEQ LASTMOUSEY (fetch YCOORD of \LastCursorPosition)) + (NEQ LASTMOUSEBUTTONS \LastWindowButtons)) + (* ; + "Cursor has changed position or a button is down, see if it is in a window or scroll area.") + (PROG ((\MOUSEBUSY T)) + (DECLARE (SPECVARS \MOUSEBUSY)) + (* ; + "Indicates to others that the mouse process is doing something 'interesting'") + (replace XCOORD of \LastCursorPosition with LASTMOUSEX) + (replace YCOORD of \LastCursorPosition with LASTMOUSEY) + (SETQ \MHWINDOW (WHICHW LASTMOUSEX LASTMOUSEY \CURSORSCREEN)) + [COND + ((NEQ \MHWINDOW \LastInWindow) + + (* ;; "Cursor has moved outside the current window, check to see if it moved into the scroll area and that the scroll handler wants it.") + + (COND + ((AND \LastInWindow (LISPWINDOWP \LastInWindow) + (IN/SCROLL/BAR? \LastInWindow LASTMOUSEX LASTMOUSEY) + (PROGN (* ; + "SCROLL.HANDLER returns NIL if this window doesn't want to scroll.") + (SCROLL.HANDLER \LastInWindow))) + (replace XCOORD of \LastCursorPosition with -1) + (GO RESETBUTTONS)) + [(OR (EQ LASTMOUSEBUTTONS 0) + (NEQ LASTMOUSEBUTTONS \LastWindowButtons)) + + (* ;; "Cursor has changed windows, so call CURSOROUTFN of old window, CURSORINFN of new. The user enters another window by moving the cursor into it with no buttons pressed or by pressing a button in the window. This allows the user to go into a window with a button down, release it and still be 'in' the window he came from.") + + [COND + ((NULL \LastInWindow) + (AND BACKGROUNDCURSOROUTFN (GETD BACKGROUNDCURSOROUTFN) + (\PROTECTED.APPLY BACKGROUNDCURSOROUTFN))) + ((SETQ \MHCOM (fetch (WINDOW CURSOROUTFN) of + \LastInWindow + )) + (ERSETQ (DOUSERFNS \MHCOM \LastInWindow] + [COND + ((NULL \MHWINDOW) + (AND BACKGROUNDCURSORINFN (GETD BACKGROUNDCURSORINFN) + (\PROTECTED.APPLY BACKGROUNDCURSORINFN))) + ((SETQ \MHCOM (fetch (WINDOW CURSORINFN) of + \MHWINDOW + )) + (ERSETQ (DOUSERFNS \MHCOM \MHWINDOW] + (SETQ \LastInWindow \MHWINDOW) + (COND + ((EQ LASTMOUSEBUTTONS 0) + (* ; + "Don't show transition to UP as we come out of another window") + (SETQ \LastWindowButtons LASTMOUSEBUTTONS) + (RETURN] + (T + (* ;; "Mouse is down and had not changed. Nothing interesting to do -- act as if we are still in old window") + + (RETURN] + +(* ;;; "We have now taken care of window changing stuff, and \MHWINDOW = \LastInWindow -- Now take care of button transitions") + + (COND + ([AND (LASTMOUSESTATE (ONLY RIGHT)) + (NOT (AND \MHWINDOW (fetch (WINDOW RIGHTBUTTONFN) + of \MHWINDOW] + (* ; + "Right button is down. This does window com unless overridden by RIGHTBUTTONFN") + (* ; + "this is separated out from the process stuff below so that window commands don't grab the tty.") + (COND + ((AND (NULL \MHWINDOW) + (.COPYKEYDOWNP.) + BACKGROUNDCOPYRIGHTBUTTONEVENTFN + (GETD BACKGROUNDCOPYRIGHTBUTTONEVENTFN)) + (* ; "check for copy key.") + (\PROTECTED.APPLY BACKGROUNDCOPYRIGHTBUTTONEVENTFN)) + (T (* ; + "if \MHWINDOW is NIL, this does background menu stuff.") + (DOWINDOWCOM \MHWINDOW))) + + (* ;; "this attempts to prevent the cursorout fn and scrolling fns from being called if the \LastInWindow was closed.") + + (OR (OPENWP \LastInWindow) + (SETQ \LastInWindow NIL)) + (GO RESETBUTTONS)) + [\MHWINDOW (* ; + "Mouse is in a window, look for button change or cursor moving fn.") + (COND + ((NEQ LASTMOUSEBUTTONS \LastWindowButtons) + (* ; + "Button change within same window") + (COND + ((AND (LASTMOUSESTATE (NOT UP)) + (SETQ \MHPROCESS (WINDOWPROP \MHWINDOW + 'PROCESS)) + (NOT (TTY.PROCESSP \MHPROCESS)) + (NOT (.COPYKEYDOWNP.)) + (SETQ \MHCOM (fetch (WINDOW WINDOWENTRYFN) + of \MHWINDOW))) + (* ; + "make sure that if this window has a process that that process has the tty.") + (ERSETQ (DOUSERFNS \MHCOM \MHWINDOW)) + (GO RESETBUTTONS)) + ([SETQ \MHCOM (COND + [(AND (.COPYKEYDOWNP.) + (WINDOWPROP \MHWINDOW + 'COPYBUTTONEVENTFN] + ((LASTMOUSESTATE (ONLY RIGHT)) + (fetch (WINDOW RIGHTBUTTONFN) + of \MHWINDOW)) + (T (fetch (WINDOW BUTTONEVENTFN) + of \MHWINDOW] + (\PROTECTED.APPLY \MHCOM \MHWINDOW) + (GO RESETBUTTONS))) + (SETQ \LastWindowButtons LASTMOUSEBUTTONS)) + ((SETQ \MHCOM (fetch (WINDOW CURSORMOVEDFN) + of \MHWINDOW)) + (* ; "cursor must have moved.") + (ERSETQ (DOUSERFNS \MHCOM \MHWINDOW] + (T (* ; + "look for button change or cursor moving in background") + (COND + ((NEQ LASTMOUSEBUTTONS \LastWindowButtons) + (* ; "Button change within background") + (COND + ((AND (NULL \MHWINDOW) + (.COPYKEYDOWNP.) + BACKGROUNDCOPYBUTTONEVENTFN + (GETD BACKGROUNDCOPYBUTTONEVENTFN)) + (\PROTECTED.APPLY BACKGROUNDCOPYBUTTONEVENTFN) + (GO RESETBUTTONS)) + ((AND BACKGROUNDBUTTONEVENTFN (GETD + BACKGROUNDBUTTONEVENTFN + )) + (\PROTECTED.APPLY BACKGROUNDBUTTONEVENTFN) + (GO RESETBUTTONS))) + (SETQ \LastWindowButtons LASTMOUSEBUTTONS)) + ((AND BACKGROUNDCURSORMOVEDFN (GETD BACKGROUNDCURSORMOVEDFN)) + (* ; "cursor must have moved.") + (\PROTECTED.APPLY BACKGROUNDCURSORMOVEDFN) + (GO RESETBUTTONS)) + ([AND BACKGROUNDCURSOREXITFN (OR (EQ LASTMOUSEX 0) + (EQ LASTMOUSEX (SUB1 + \CURSORDESTWIDTH + ] + (* ; "cursor must have moved.") + (ERSETQ (APPLY* BACKGROUNDCURSOREXITFN)) + (GETMOUSESTATE) + (replace (POSITION XCOORD) of \LastCursorPosition + with LASTMOUSEX) + (replace (POSITION YCOORD) of \LastCursorPosition + with LASTMOUSEY] + (RETURN) + RESETBUTTONS + (* ; + "Look at mouse again, since user fn may have waited for mouse to come up") + (GETMOUSESTATE) + (SETQ \LastWindowButtons LASTMOUSEBUTTONS) + (RETURN]) + +(\PROTECTED.APPLY [LAMBDA (FN WINDOW) (* bvm%: "20-Apr-84 16:20") (DECLARE (LOCALVARS . T)) (* ;;; "Apply FN to WINDOW under an errorset to trap errors") (ERSETQ (APPLY* FN WINDOW]) + +(DOWINDOWCOM [LAMBDA ARGS (* ; "Edited 25-Nov-86 17:30 by hdj") (* ;; "the button handler for the window system. if no arg, just return.") (if (NEQ ARGS 0) then (LET ((WINDOW (ARG ARGS 1))) (COND [(type? WINDOW WINDOW) (PROG ($$VAR) (COND ((SETQ $$VAR (WINDOWPROP WINDOW 'DOWINDOWCOMFN)) (RETURN (APPLY* $$VAR WINDOW))) (T (\CHECKCARET WINDOW) (TOTOPW WINDOW) (RETURN (COND ([SETQ $$VAR (MENU (COND ((type? MENU WindowMenu) WindowMenu) (T (SETQ WindowMenu (create MENU ITEMS _ WindowMenuCommands CHANGEOFFSETFLG _ 'Y MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) WHENHELDFN _ (FUNCTION PPROMPT3) WHENUNHELDFN _ (FUNCTION CLRPROMPT) CENTERFLG _ T] (APPLY* $$VAR WINDOW) T] ((NULL WINDOW) (DOBACKGROUNDCOM]) + +(DOBACKGROUNDCOM [LAMBDA NIL (* ; "Edited 10-Mar-92 15:48 by jds") (* ;; "Bring up the background menu.") (PROG (FORM) (AND (OR BackgroundMenu BackgroundMenuCommands) [SETQ FORM (MENU (COND ((type? MENU BackgroundMenu) BackgroundMenu) (T (SETQ BackgroundMenu (create MENU ITEMS _ BackgroundMenuCommands CHANGEOFFSETFLG _ 'Y MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) WHENHELDFN _ (FUNCTION PPROMPT3) WHENUNHELDFN _ (FUNCTION CLRPROMPT) CENTERFLG _ T] (ERSETQ (EVAL FORM]) + +(DEFAULT.BACKGROUND.COPYFN [LAMBDA NIL (* bvm%: "17-Oct-85 00:02") (* ;;; "the default function called when the right button goes down in the background and the copy key is held down.") (COND ((AND (MOUSESTATE (NOT UP)) BackgroundCopyMenuCommands) (LET [(FORM (MENU (COND ((type? MENU BackgroundCopyMenu) BackgroundCopyMenu) (T (SETQ BackgroundCopyMenu (create MENU ITEMS _ BackgroundCopyMenuCommands CHANGEOFFSETFLG _ 'Y MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) CENTERFLG _ T] (AND FORM (ERSETQ (EVAL FORM]) +) + +(RPAQQ BackgroundCopyMenu NIL) + +(RPAQ? BackgroundCopyMenuCommands NIL) +(DEFINEQ + +(BURYW + [LAMBDA (WINDOW) (* ; + "Edited 2-Feb-94 13:13 by sybalsky:mv:envos") + (WINDOWOP 'BURYWFN (fetch (WINDOW SCREEN) of (SETQ WINDOW (\INSUREWINDOW WINDOW))) + WINDOW]) + +(CLEARW + [LAMBDA (WINDOW) (* ; "Edited 8-Dec-93 18:10 by nilsson") + + (* ;; "clears a window to its background shade, resets its offsets to 0,0 in the lower left corner and resets the position to the upper left {first line of text}.") + + (SETQ WINDOW (\INSUREWINDOW WINDOW)) + (DSPRESET (fetch (WINDOW DSP) of WINDOW]) + +(CLOSEW + [LAMBDA (WINDOW) (* ; "Edited 25-Apr-94 10:08 by sybalsky") + + (* ;; "closes a window. saves the current state in the WINDOW and allow it to be reOPENWed.") + + (* ;; + "Returns T if the window closed OK (and was previously open), as a signal to \INTERACTIVE.CLOSEW.") + + (SETQ WINDOW (\INSUREWINDOW WINDOW)) + (COND + ((OPENWP WINDOW) + (COND + ((AND (\OKTOCLOSEW WINDOW) + (OPENWP WINDOW)) (* ; + "one of the CLOSEFNs may have closed the window. If so, don't reopen it.") + (WINDOWOP 'CLOSEWFN (fetch (WINDOW SCREEN) of WINDOW) + WINDOW) + T]) + +(\CLOSEW1 + [LAMBDA (WINDOW) (* ; "Edited 25-Apr-94 10:08 by sybalsky") + + (* ;; + "actually does the closing operation. Is used by SHRINKW to avoid the CLOSEFN mechanism.") + + (WINDOWOP 'CLOSEWFN (fetch (WINDOW SCREEN) of (SETQ WINDOW (\INSUREWINDOW WINDOW))) + WINDOW]) + +(\OKTOCLOSEW [LAMBDA (WINDOW) (* rrb "14-JUN-82 12:40") (* ;; "calls the windows closefns. Returns T if it is ok to close the window.") (COND ((EQ (DOUSERFNS (fetch (WINDOW CLOSEFN) of WINDOW) WINDOW T) 'DON'T) NIL) (T WINDOW]) + +(\INTERACTIVE.CLOSEW [LAMBDA (WINDOW) (* ; "Edited 4-Mar-88 09:52 by jds") (* ;; "Interactive version of CLOSEW -- used by the window-command menu. If the window can't be closed, this function prints a message saying so.") (LET ((CLOSEFN (fetch (WINDOW CLOSEFN) of WINDOW))) (COND ((OR (EQ 'DON'T CLOSEFN) (AND (LISTP CLOSEFN) (FMEMB 'DON'T CLOSEFN))) (* ;  "The window has DON'T as one of its CLOSEFNs. Tell the guy the window isn't closeable.") (PROMPTPRINT "This window cannot be closed.")) (T (* ; "Try closing it.") (CLOSEW WINDOW) T]) + +(OPENW + [LAMBDA (WINDOW) (* ; "Edited 25-Apr-94 10:12 by sybalsky") + + (* ;; "Generic OPENW method") + + (SETQ WINDOW (\INSUREWINDOW WINDOW)) + (COND + ((OPENWP WINDOW) (* ; + "used to bring the window to top but doesn't since TOTOPW has been documented.") + NIL) + (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN] + (COND + ((\USERFNISDON'T USEROPENFN) (* ; "one of the OPENFNs is DON'T") + NIL) + (T (* ; + "open it by putting it on top and swapping its bits in") + (\OPENW1 WINDOW) (* ; + "call the openfns after the window has been opened.") + (DOUSERFNS USEROPENFN WINDOW) + (RETURN WINDOW]) + +(DOUSERFNS [LAMBDA (FNLST WINDOW CHECKFORDON'TFLG) (* rrb "20-Mar-84 16:18") (* ;; "applys a list of user functins and If CHECKFORDON'TFLG is non-NIL, it stops if don't is returned as one of the values and returns DON'T") (DECLARE (GLOBALVARS LAMBDASPLST)) (COND [(OR (NLISTP FNLST) (FMEMB (CAR FNLST) LAMBDASPLST)) (COND ((AND CHECKFORDON'TFLG (EQ FNLST 'DON'T)) 'DON'T) (FNLST (AND (EQ (APPLY* FNLST WINDOW) 'DON'T) 'DON'T] ((AND CHECKFORDON'TFLG (FMEMB 'DON'T FNLST)) 'DON'T) ((for USERFN in FNLST when (EQ (APPLY* USERFN WINDOW) 'DON'T) do (* ;  "return if any of the openfns says don't") (AND CHECKFORDON'TFLG (RETURN 'DON'T]) + +(DOUSERFNS2 [LAMBDA (FNLST WINDOW ARG1 ARG2 ARG3) (* rrb " 3-Jul-84 15:59") (* ;; "applys a list of user functions to two arguments. This is used by SHAPEW.") (DECLARE (GLOBALVARS LAMBDASPLST)) (COND [(OR (NLISTP FNLST) (FMEMB (CAR FNLST) LAMBDASPLST)) (COND (FNLST (APPLY* FNLST WINDOW ARG1 ARG2 ARG3] ((for USERFN in FNLST do (APPLY* USERFN WINDOW ARG1 ARG2 ARG3]) + +(\USERFNISDON'T [LAMBDA (USERFN) (* rrb "18-JUN-82 12:16") (* ;; "determines if one of the userfunction is DON'T") (COND ((NLISTP USERFN) (EQ USERFN 'DON'T)) (T (FMEMB 'DON'T USERFN]) + +(\OPENW1 + [LAMBDA (WINDOW) (* ; "Edited 25-Apr-94 10:12 by sybalsky") + +(* ;;; "Open a closed window without running the OPENW methods. ") + + (* ;; "If already open, punt.") + + (WINDOWOP 'OPENWFN (fetch (WINDOW SCREEN) of (SETQ WINDOW (\INSUREWINDOW WINDOW))) + WINDOW]) + +(CREATEW + [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS) (* ; "Edited 7-Jan-94 11:16 by nilsson") + + (* ;; "Generic CREATEW function.") + + (LET (SCREEN REG) + (COND + [(NULL REGION) + (PROMPTPRINT "Specify region for window") + (COND + (TITLE (PROMPTPRINT " %"" TITLE "%""))) + (SETQ REGION (GETSCREENREGION MinWindowWidth MinWindowHeight)) + (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) + (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] + ((type? REGION REGION) + (SETQ SCREEN \CURSORSCREEN) (* ; + "Protect against user smashing REGION later on.") + (SETQ REG (COPY REGION))) + [(type? SCREENREGION REGION) + (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) + (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] + ((DISPLAYSTREAMP REGION) + (HELP "DISPLAYSTREAMs as REGIONS no longer supported.")) + (T (ERROR "Not a region" REG))) + (\CREATEW1 SCREEN REG TITLE BORDERSIZE NOOPENFLG PROPS]) + +(CREATEW1 + [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG PROPS OLDWINDOW) + (* ; "Edited 27-Dec-93 18:41 by nilsson") + + (* ;; "To reuse an old window structure, you have to specify the REGION and OLDWINDOW") + + (LET [SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW (BORDERSIZE (COND + ((NUMBERP BORDERSIZE) + (ABS BORDERSIZE)) + ((NUMBERP WBorder) + (ABS WBorder)) + (T 2] + (COND + [(NULL REGION) + (PROMPTPRINT "Specify region for window") + (COND + (TITLE (PROMPTPRINT " %"" TITLE "%""))) + (SETQ REGION (GETSCREENREGION MinWindowWidth MinWindowHeight)) + (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) + (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] + ((type? REGION REGION) + (SETQ SCREEN \CURSORSCREEN) (* ; + "Protect against user smashing REGION later on.") + (SETQ REG (COPY REGION))) + [(type? SCREENREGION REGION) + (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) + (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] + ((DISPLAYSTREAMP REGION) + (HELP "DISPLAYSTREAMs as REGIONS no longer supported.")) + (T (ERROR "Not a region" REG))) + (COND + ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG) + (fetch (REGION HEIGHT) of REG)) + (UNFOLD BORDERSIZE 2))) + (ERROR "Region too small to use as a window" REGION))) + (SETQ WINDOW (WINDOWOP 'CREATEWFN SCREEN REG TITLE BORDERSIZE NOOPENFLG PROPS OLDWINDOW)) + (COND + ((NOT NOOPENFLG) + (OPENW WINDOW))) + WINDOW]) + +(\CREATEW1 + [LAMBDA (SCREEN REGION TITLE BORDERSIZE NOOPENFLG PROPS OLDWINDOW) + (* ; "Edited 7-Jan-94 10:57 by nilsson") + + (* ;; "To reuse an old window structure, you have to specify the REGION and OLDWINDOW") + + (LET [DSP DISPLAYDATA TITLEHEIGHT WINDOW (BORDERSIZE (COND + ((NUMBERP BORDERSIZE) + (ABS BORDERSIZE)) + ((NUMBERP WBorder) + (ABS WBorder)) + (T 2] + (COND + ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REGION) + (fetch (REGION HEIGHT) of REGION)) + (UNFOLD BORDERSIZE 2))) + (ERROR "Region too small to use as a window" REGION))) + (SETQ WINDOW (WINDOWOP 'CREATEWFN SCREEN REGION TITLE BORDERSIZE NOOPENFLG PROPS OLDWINDOW)) + (COND + ((NOT NOOPENFLG) + (OPENW WINDOW))) + WINDOW]) + +(OPENDISPLAYSTREAM [LAMBDA (FILE OPTIONS) (* hdj "17-Jan-86 14:47") (GETSTREAM (CREATEW (LISTGET OPTIONS 'REGION) (COND ((EQ FILE '{LPT}) "Display image stream") (T FILE]) + +(MOVEW + [LAMBDA (WINDOW POSorX Y FORCE) (* ; "Edited 5-Jan-94 16:08 by nilsson") + (WINDOWOP 'MOVEWFN (fetch (WINDOW SCREEN) of WINDOW) + WINDOW POSorX Y FORCE]) + +(PPROMPT3 [LAMBDA (ITEM) (* rrb "17-NOV-81 12:15") (* ;; "prints the third element of ITEM in the prompt window. This is the default WHENHELDFN for MENUs.") (COND ((AND (LISTP ITEM) (CADDR ITEM)) (PROMPTPRINT (CADDR ITEM]) + +(\ONSCREENCLIPPINGREGION [LAMBDA (WIN) (* kbr%: "26-Mar-85 23:34") (* ;;  "returns a region which is the part of the windows clipping region that is on the screen.") (INTERSECTREGIONS (DSPCLIPPINGREGION NIL WIN) (\DSPUNTRANSFORMREGION (fetch (SCREEN SCREGION) of (fetch (WINDOW SCREEN) of WIN)) (fetch (STREAM IMAGEDATA) of (WINDOWPROP WIN 'DSP]) + +(RELMOVEW + [LAMBDA (WINDOW POS) (* ; + "Edited 2-Feb-94 13:12 by sybalsky:mv:envos") + (WINDOWOP 'RELMOVEWFN (fetch (WINDOW SCREEN) of (SETQ WINDOW (\INSUREWINDOW WINDOW))) + WINDOW POS]) + +(SHAPEW [LAMBDA (WINDOW NEWREGION MAINONLYFLG) (* ; "Edited 24-Jan-97 10:53 by rmk:") (* ; "Edited 24-Sep-92 12:30 by jds") (* ;; "entry that shapes a window checking the userfns for DON'T and interacting to get a region if necessary. This also checks for a user function to do the actual reshaping. look for a function on windowprop INITCORNERSFN, which will take the window and return the initcorners for the window, to be passed to getregion. MAINONLYFLG is a flag passed to any DOSHAPEFN (especially for RESHAPEALLWINDOWS in ATTACHEDWINDOW). It indicates that the new region is to be allocated entirely to the main window.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) (* ;  "Start with the minimum allowable size.") [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) ((WINDOWPROP WINDOW 'INITCORNERSFN) (* ;  "There's an INITCORNERSFN. Fire it up and prompt the user for a new shape.") (GETREGION (CAR NEWSIZE) (CDR NEWSIZE) (WINDOWREGION WINDOW 'SHAPEW) (fetch (WINDOW NEWREGIONFN) of WINDOW) WINDOW (APPLY* (WINDOWPROP WINDOW 'INITCORNERSFN) WINDOW))) (T (* ;  "Just go prompt the user for a new shape.") (GETREGION (CAR NEWSIZE) (CDR NEWSIZE) (WINDOWREGION WINDOW 'SHAPEW) (fetch (WINDOW NEWREGIONFN) of WINDOW) WINDOW] (RETURN (COND ((EQUAL NEWSIZE OLDSIZE) (* ;; "if same size and place as before, do nothing") NIL) ((AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) (* ;; "if same width and height, then optimize to a move") (MOVEW WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE))) (T (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) 'SHAPEW1) WINDOW (COPYALL NEWSIZE) MAINONLYFLG]) + +(SHAPEW1 [LAMBDA (WINDOW REGION) (* kbr%: "25-Jan-86 15:08") (* ;; "entry for shaping a window that does the reshape without checking for a user function.") (DECLARE (LOCALVARS . T)) (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (OLDCLIPREG (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (WBORDER (fetch (WINDOW WBORDER) of WINDOW)) SCREEN NUSAV NOWOPEN?) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) [SETQ NUSAV (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (SCREEN SCDESTINATION ) of SCREEN] (UNINTERRUPTABLY (COND ((OPENWP WINDOW) (* ;  "notice whether window is open or not to call OPENFNs only if not now open.") (SETQ NOWOPEN? T) (\CLOSEW1 WINDOW))) (* ; "Save window image") (replace (WINDOW REG) of WINDOW with REGION) [replace (WINDOW SAVE) of WINDOW with (PROG1 NUSAV (SETQ NUSAV (fetch (WINDOW SAVE) of WINDOW)))] (ADVISEWDS WINDOW OLDREGION) (SHOWWFRAME WINDOW) (COND (NOWOPEN? (\OPENW1 WINDOW)) (T (OPENW WINDOW)))) (DOUSERFNS2 (OR (fetch (WINDOW RESHAPEFN) of WINDOW) (FUNCTION RESHAPEBYREPAINTFN)) WINDOW NUSAV (create REGION LEFT _ WBORDER BOTTOM _ WBORDER WIDTH _ (fetch (REGION WIDTH) of OLDCLIPREG) HEIGHT _ (fetch (REGION HEIGHT) of OLDCLIPREG)) OLDREGION) (RETURN WINDOW]) + +(\SHAPEW2 [LAMBDA (WINDOW REGION) (* ; "Edited 6-Jan-87 13:56 by woz") (* ;;; "entry for shaping a window that does the reshape without checking for a user function, and without running the openfn.") (DECLARE (LOCALVARS . T)) (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (OLDCLIPREG (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (WBORDER (fetch (WINDOW WBORDER) of WINDOW)) SCREEN NUSAV) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) [SETQ NUSAV (BITMAPCREATE (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch (SCREEN SCDESTINATION ) of SCREEN] (UNINTERRUPTABLY (COND ((OPENWP WINDOW) (* ;  "close open window before changing region") (\CLOSEW1 WINDOW))) (* ;; "Save window image") (replace (WINDOW REG) of WINDOW with REGION) [replace (WINDOW SAVE) of WINDOW with (PROG1 NUSAV (SETQ NUSAV (fetch (WINDOW SAVE) of WINDOW)))] (ADVISEWDS WINDOW OLDREGION) (SHOWWFRAME WINDOW) (* ; "open without openfn") (\OPENW1 WINDOW)) (DOUSERFNS2 (OR (fetch (WINDOW RESHAPEFN) of WINDOW) (FUNCTION RESHAPEBYREPAINTFN)) WINDOW NUSAV (CREATEREGION WBORDER WBORDER (fetch (REGION WIDTH) of OLDCLIPREG ) (fetch (REGION HEIGHT) of OLDCLIPREG)) OLDREGION) (RETURN WINDOW]) + +(RESHOWBORDER [LAMBDA (BORDER WINDOW) (* rrb "15-JUN-83 14:46") (* ;; "updates a windows display with a new border") (* ;  "if the border is the same, don't change anything.") (OR (EQ BORDER (fetch (WINDOW WBORDER) of WINDOW)) (\RESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW) WINDOW]) + +(\RESHOWBORDER1 [LAMBDA (NEWBORDER OLDBORDER WINDOW) (* kbr%: "25-Jan-86 15:13") (* ;; "redisplays the border of a window. Is called by RESHOWBORDER and RESHOWTITLE. It doesn't check for equality between the new and old borders because it is also used when a title is added or deleted.") (PROG ((REGION (fetch (WINDOW REG) of WINDOW)) (OLDSAVE (fetch (WINDOW SAVE) of WINDOW)) NUSAV DELTA NUWIDTH NUHEIGHT) (SETQ DELTA (IDIFFERENCE NEWBORDER OLDBORDER)) (SETQ NUWIDTH (IPLUS (fetch (REGION WIDTH) of REGION) (ITIMES DELTA 2))) [SETQ NUHEIGHT (IDIFFERENCE (IPLUS (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (ITIMES NEWBORDER 2)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] (SETQ NUSAV (BITMAPCREATE NUWIDTH NUHEIGHT (fetch (BITMAP BITMAPBITSPERPIXEL) of OLDSAVE))) (.WHILE.TOP.DS. WINDOW (* ; "Save window image") (\SW2BM (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW)) REGION (fetch (WINDOW SAVE) of WINDOW) NIL) (* ; "put new save image into window") (replace (WINDOW SAVE) of WINDOW with NUSAV) (replace (WINDOW WBORDER) of WINDOW with NEWBORDER) (* ;  "create a region that coresponds to the old region with the new border.") (replace (WINDOW REG) of WINDOW with (create REGION LEFT _ (IDIFFERENCE (fetch (REGION LEFT) of REGION) DELTA) BOTTOM _ (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) DELTA) WIDTH _ NUWIDTH HEIGHT _ NUHEIGHT)) (UPDATE/SCROLL/REG WINDOW) (* ; "draw border in the new image.") (SHOWWFRAME WINDOW) (* ;  "copy the visible part from the old image into the new one.") (BITBLT OLDSAVE OLDBORDER OLDBORDER NUSAV NEWBORDER NEWBORDER (IDIFFERENCE (fetch (BITMAP BITMAPWIDTH) of OLDSAVE) (ITIMES 2 OLDBORDER)) (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) 'INPUT 'REPLACE) (* ;  "put the new image up on the screen.") (\SW2BM (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW)) (fetch (WINDOW REG) of WINDOW) (fetch (WINDOW SAVE) of WINDOW) NIL]) + +(TRACKW [LAMBDA (WINDOW) (* rrb " 9-MAR-82 14:28") (* ;;  "causes a window to follow the cursor. found to be not useful but very pretty for small windows.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (RESETFORM (CURSOR CROSSHAIRS) (TOTOPW WINDOW) (until (MOUSESTATE (NOT UP))) (CURSOR LOCKEDSPOT) (bind (DX _ (IDIFFERENCE (fetch (REGION LEFT) of (fetch (WINDOW REG) of WINDOW)) LASTMOUSEX)) (DY _ (IDIFFERENCE (fetch (REGION BOTTOM) of (fetch (WINDOW REG) of WINDOW)) LASTMOUSEY)) until (MOUSESTATE UP) do (MOVEW WINDOW (create POSITION XCOORD _ (IPLUS LASTMOUSEX DX) YCOORD _ (IPLUS LASTMOUSEY DY]) + +(SNAPW [LAMBDA NIL (* ; "Edited 21-Jul-92 17:12 by jds") (* ;;  "makes a new window which is a copy of the bits underneath the REGION read from the user.") (PROG (SCREENREGION SCREEN REGION NEWWINDOW) (SETQ SCREENREGION (GETSCREENREGION 30 20)) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of SCREENREGION)) (SETQ REGION (fetch (SCREENREGION REGION) of SCREENREGION)) (SETQ NEWWINDOW (CREATEW (create SCREENREGION SCREEN _ SCREEN REGION _ (GROW/REGION REGION WBorder)) NIL NIL T)) (* ;  "keep it closed so it doesn't cover any of the bits it is to copy.") (* ;  "put existing screen bits from SAVE.") (BITBLT (fetch (SCREEN SCDESTINATION) of SCREEN) (fetch (REGION LEFT) of REGION) (fetch (REGION BOTTOM) of REGION) (fetch (WINDOW SAVE) of NEWWINDOW) WBorder WBorder (fetch (REGION WIDTH) of REGION) (fetch (REGION HEIGHT) of REGION) 'INPUT 'REPLACE) (WINDOWPROP NEWWINDOW 'TYPE :SNAP) (* ; "MARK THIS AS A SNAP WINDOW.") (OPENW NEWWINDOW) (MOVEW NEWWINDOW) (RETURN NEWWINDOW]) + +(WINDOWREGION [LAMBDA (WINDOW COM) (* jow "26-Aug-85 13:48") (* ;; "gets the region that a window wants to consider to be its. COM can be a window com used to help calculate the region, ie for shaping or moving...") (PROG (FN) (RETURN (COND ((SETQ FN (WINDOWPROP WINDOW 'CALCULATEREGIONFN)) (APPLY* FN WINDOW COM)) (T (WINDOWPROP WINDOW 'REGION]) +) +(DEFINEQ + +(MINIMUMWINDOWSIZE [LAMBDA (WINDOW) (* rrb "20-NOV-83 12:06") (* ;; "returns the minimum extent of a window") (PROG [(EXT (WINDOWPROP WINDOW 'MINSIZE] [COND [(NULL EXT) (SETQ EXT (CONS MinWindowWidth (HEIGHTIFWINDOW (FONTPROP WINDOW 'HEIGHT) (WINDOWPROP WINDOW 'TITLE] ((LITATOM EXT) (SETQ EXT (APPLY* EXT WINDOW] [COND [(AND (NUMBERP (CAR EXT)) (NUMBERP (CDR EXT] (T (SETQ EXT (ERROR "Illegal extent property" EXT] (RETURN EXT]) +) + +(RPAQ? BACKGROUNDCURSORINFN ) + +(RPAQ? BACKGROUNDBUTTONEVENTFN ) + +(RPAQ? BACKGROUNDCURSOROUTFN ) + +(RPAQ? BACKGROUNDCURSORMOVEDFN ) + +(RPAQ? BACKGROUNDCOPYBUTTONEVENTFN ) + +(RPAQ? BACKGROUNDCOPYRIGHTBUTTONEVENTFN (FUNCTION DEFAULT.BACKGROUND.COPYFN)) + +(RPAQ? BACKGROUNDCURSOREXITFN ) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS BACKGROUNDCURSORINFN BACKGROUNDBUTTONEVENTFN BACKGROUNDCURSOROUTFN + BACKGROUNDCURSORMOVEDFN BACKGROUNDCOPYBUTTONEVENTFN BACKGROUNDCOPYRIGHTBUTTONEVENTFN \CARET.UP + BACKGROUNDCURSOREXITFN) +) +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[PUTPROPS .COPYKEYDOWNP. MACRO (NIL (OR (KEYDOWNP 'LSHIFT) + (KEYDOWNP 'RSHIFT) + (KEYDOWNP 'COPY] + +[PUTPROPS WSOP MACRO (ARGS (LET ((METHOD (CADR (CAR ARGS))) + (DISPLAY (CADR ARGS)) + (OTHERARGS (CDDR ARGS))) + `(SPREADAPPLY* (fetch (WSOPS ,METHOD) of (fetch + (FDEV WINDOWOPS) + of + ,DISPLAY)) + ,DISPLAY + ,@OTHERARGS] +) + +(* "END EXPORTED DEFINITIONS") + + +(PUTPROPS WSOP ARGNAMES (METHOD DISPLAY . OTHERARGS)) +(DECLARE%: EVAL@COMPILE + +(RECORD WSOPS (STARTBOARD STARTCOLOR STOPCOLOR EVENTFN SENDCOLORMAPENTRY SENDPAGE PILOTBITBLT)) + +(RECORD WSDATA (WSDESTINATION WSREGION WSBACKGROUND WSCOLORMAP) + (SYSTEM)) +) + + + +(* ; "Window utilities") + +(DEFINEQ + +(ADVISEWDS [LAMBDA (WINDOW OLDREG MOVEONLYFLG) (* kbr%: "29-Mar-85 14:01") (DECLARE (LOCALVARS . T)) (* ;; "called whenever the dimensions of a guaranteed WINDOW change. Updates the dependent fields in the associated DisplayStream. Also updates dependent fields in the WINDOW such as Scroll region.") (* ;; "OLDREG if given, is the region this window used to have and is used to maintain the relationship between the WINDOW coordinates and the displaystreams when the WINDOW moves.") (* ;; "MOVEONLYFLG indicates that the dimensions of the region haven't changed.") (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC) (SETQ R (fetch (WINDOW REG) of WINDOW)) (SETQ D (fetch (WINDOW DSP) of WINDOW)) (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW)) (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2)) (COND (OLDREG (RELDSPXOFFSET (IDIFFERENCE (fetch (REGION LEFT) of R) (fetch (REGION LEFT) of OLDREG)) D) (RELDSPYOFFSET (IDIFFERENCE (fetch (REGION BOTTOM) of R) (fetch (REGION BOTTOM) of OLDREG)) D) (* ;; "if only moving, the clipping region remains the same. This is checked for because the height of the window title may have changed and this calculation results in the wrong answer. All other calls to ADVISEWDS should repaint the border.") (OR MOVEONLYFLG (DSPCLIPPINGREGION [create REGION LEFT _ (fetch (REGION LEFT) of (SETQ CLIPREG ( DSPCLIPPINGREGION NIL D))) BOTTOM _ (fetch (REGION BOTTOM) of CLIPREG) WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) (T (DSPXOFFSET (IPLUS (fetch (REGION LEFT) of R) WBORDERSIZE) D) (DSPYOFFSET (IPLUS (fetch (REGION BOTTOM) of R) WBORDERSIZE) D) (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) [COND ((NULL MOVEONLYFLG) (* ;  "if the previous right margin was the default, change it.") (AND (OR (NOT OLDREG) (EQ (DSPRIGHTMARGIN NIL D) (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG) TWICEBORDER))) (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) D)) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) (EQ D (PROCESS.TTY PROC))) (* ;  "if the window changing is a tty, set its linelength.") [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT) (IQUOTIENT (fetch (REGION HEIGHT) of (SETQ CLIPREG (DSPCLIPPINGREGION NIL D))) (IMINUS (DSPLINEFEED NIL D] (PROCESS.EVAL PROC '(SETLINELENGTH)) (IF NIL THEN (* ; "try it without this.") (COND ((EQ (PROCESSPROP PROC 'NAME) 'EXEC) (* ;; "in the exec process, make sure the current position is inside the new shape. reuse variables R and TWICEBORDER to save binding.") (COND ((ILESSP (SETQ R (DSPYPOSITION NIL D)) (SETQ TWICEBORDER (fetch (REGION BOTTOM) of CLIPREG ))) (DSPYPOSITION TWICEBORDER D)) ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT) of CLIPREG) TWICEBORDER))) (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT)) D] (UPDATE/SCROLL/REG WINDOW)) WINDOW]) + +(SHOWWFRAME [LAMBDA (WIN) (* ; "Edited 24-Sep-92 12:31 by jds") (* ;; "Displays the border and title in the save image of a window") (PROG ((TITLE (fetch (WINDOW WTITLE) of WIN)) (BORDER (fetch (WINDOW WBORDER) of WIN)) (DSP (fetch (WINDOW DSP) of WIN)) (SAVEIMAGE (fetch (WINDOW SAVE) of WIN)) WINWDTH WINHGHT BLACKPART WHITEPART) [SETQ WINHGHT (fetch (REGION HEIGHT) of (SETQ WINWDTH (fetch (WINDOW REG) of WIN] (SETQ WINWDTH (fetch (REGION WIDTH) of WINWDTH)) (* ; "make most of the border black") (SETQ BLACKPART (IMAX (FOLDHI BORDER 2) (IDIFFERENCE BORDER 2))) (SETQ WHITEPART (IDIFFERENCE BORDER BLACKPART)) (* ; "Fill in frame in save image") (BITBLT NIL NIL NIL SAVEIMAGE 0 0 WINWDTH WINHGHT 'TEXTURE 'REPLACE BLACKSHADE) (* ;  "White out the frame in the saved image") (BITBLT NIL NIL NIL SAVEIMAGE BLACKPART BLACKPART (IDIFFERENCE WINWDTH (ITIMES 2 BLACKPART) ) (IPLUS (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL DSP)) (ITIMES 2 WHITEPART)) 'TEXTURE 'REPLACE WHITESHADE) (AND TITLE (SHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN))) WIN]) + +(SHOWWTITLE [LAMBDA (TITLE BM BORDER CENTERFLG WINDOW) (* kbr%: "25-Jan-86 15:21") (* ;; "prints a title in a window.") (PROG (TITLEDS FONT BLACKPART TITLESHADE BMWIDTH HEIGHT BOTTOM X LEFTMARGIN) (SETQ TITLEDS (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW ))) (SETQ FONT (DSPFONT NIL TITLEDS)) (SETQ BLACKPART (SELECTQ BORDER (0 0) ((1 2) 1) (3 2) (IDIFFERENCE BORDER 2))) (SETQ TITLESHADE (OR (TEXTUREP (OR (WINDOWPROP WINDOW 'WINDOWTITLESHADE) WINDOWTITLESHADE)) BLACKSHADE)) (DSPDESTINATION BM TITLEDS) (DSPCLIPPINGREGION (create REGION LEFT _ 0 BOTTOM _ [SETQ BOTTOM (IDIFFERENCE (IPLUS (BITMAPHEIGHT BM) (COND ((ZEROP BORDER) 0) (T (* ;  "if room, leave a line of the border at the top of the title.") -1))) (SETQ HEIGHT (FONTPROP FONT 'HEIGHT] WIDTH _ (SETQ BMWIDTH (BITMAPWIDTH BM)) HEIGHT _ HEIGHT) TITLEDS) (MOVETO (COND [CENTERFLG (* ;  "save left margin for later shading.") (SETQ LEFTMARGIN (IMAX BORDER (IQUOTIENT (IDIFFERENCE BMWIDTH (\STRINGWIDTHGUESS TITLE FONT)) 2] (T BORDER)) (IPLUS BOTTOM (FONTPROP FONT 'DESCENT)) TITLEDS) (RESETFORM (PRINTLEVEL WINDOWTITLEPRINTLEVEL) (PROG ((PLVLFILEFLG T)) (PRIN3 TITLE TITLEDS))) (BITBLT NIL NIL NIL TITLEDS (SETQ X (IPLUS (IMAX 2 BLACKPART) (DSPXPOSITION NIL TITLEDS))) (COND ((EQ BLACKPART 1) (ADD1 BOTTOM)) (T BOTTOM)) (IDIFFERENCE BMWIDTH (IPLUS X BLACKPART)) NIL 'TEXTURE 'REPLACE TITLESHADE) (* ;  "shade stuff before title if centered.") (AND CENTERFLG (BITBLT NIL NIL NIL TITLEDS BORDER (COND ((EQ BLACKPART 1) (ADD1 BOTTOM)) (T BOTTOM)) (IDIFFERENCE LEFTMARGIN (IPLUS (IMAX 2 BLACKPART) BORDER)) NIL 'TEXTURE 'REPLACE TITLESHADE]) + +(\STRINGWIDTHGUESS [LAMBDA (X FONT) (* ; "Edited 3-Apr-87 13:44 by jop") (* ;; "returns a guess as to the string width of X. It goes one level so works on circular structures. It is used as a heuristic by functions who are going to print something with printlevel.") (STRINGWIDTH X FONT T]) + +(RESHOWTITLE [LAMBDA (TITLE WINDOW JUSTDISPLAYFLG) (* kbr%: "25-Jan-86 15:26") (* ;; "updates a windows display with a new title") (PROG* ((WREG (fetch (WINDOW REG) of WINDOW)) (TITLEDS (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW))) (TITLEHEIGHT (IMINUS (DSPLINEFEED NIL TITLEDS))) (OLDTITLE (fetch (WINDOW WTITLE) of WINDOW)) (BORDER (fetch (WINDOW WBORDER) of WINDOW)) BM BMBTM HGHT) [COND (JUSTDISPLAYFLG) ((EQ TITLE (fetch (WINDOW WTITLE) of WINDOW)) (RETURN)) (T (replace (WINDOW WTITLE) of WINDOW with TITLE) (COND ([OR (NULL OLDTITLE) (NULL TITLE) (NEQ TITLEHEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of WREG) (IPLUS (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (ITIMES 2 BORDER] (* ;  "Previously no title, so make space for one") (* ; "Have to remove title") (* ; "or title height changed.") (* ;  "so windows region on the screen has to be made larger.") (\RESHOWBORDER1 (fetch (WINDOW WBORDER) of WINDOW) (fetch (WINDOW WBORDER) of WINDOW) WINDOW) (RETURN] (* ;  "code from here is to reprint the title in place to avoid creating any large bitmaps.") [SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of WREG) (SETQ TITLEHEIGHT (ADD1 TITLEHEIGHT)) (BITSPERPIXEL (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW] (BITBLT NIL NIL NIL BM 0 0 NIL NIL 'TEXTURE 'REPLACE BLACKSHADE) (* ;  "use SHOWWTITLE to put the image of the title into the auxilliary bitmap.") (SHOWWTITLE TITLE BM BORDER NIL WINDOW) [COND ((IGREATERP TITLEHEIGHT (SETQ HGHT (fetch (REGION HEIGHT) of WREG))) (SETQ BMBTM (IDIFFERENCE (SUB1 TITLEHEIGHT) HGHT] (UNINTERRUPTABLY (TOTOPW WINDOW) (BITBLT BM 0 (COND (BMBTM) ((IGREATERP BORDER 0) (* ;; "if there is a border, the title was printed in the scratch bitmap so to leave one point of the border on top") 0) (T 1)) (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW)) (fetch (REGION LEFT) of WREG) [IDIFFERENCE (fetch (REGION PTOP) of WREG) (COND (BMBTM HGHT) (T (IPLUS TITLEHEIGHT (COND ((IGREATERP BORDER 0) (* ;; "if there is a border, the title was printed in the scratch bitmap so to leave one point of the border on top") 0) (T -1] NIL (COND (BMBTM HGHT))))]) + +(TOTOPW + [LAMBDA (WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 21-Feb-94 12:57 by sybalsky") + (WINDOWOP 'TOTOPWFN (fetch (WINDOW SCREEN) of (\INSUREWINDOW WINDOW)) + WINDOW NOCALLTOTOPFNFLG]) + +(\INTERNALTOTOPW [LAMBDA (W1 RPT) (* gbn%: "25-Jan-86 15:36") (PROG (SCREEN SCREENTOPW) (SETQ W1 (\INSUREWINDOW W1)) (SETQ SCREEN (fetch (WINDOW SCREEN) of W1)) (SETQ SCREENTOPW (fetch (SCREEN SCTOPW) of SCREEN)) (OR (EQ W1 SCREENTOPW) (COND ((NULL SCREENTOPW) (* ;  "all windows are closed open this one.") (OPENW W1)) (T (UNINTERRUPTABLY (\TTW1 W1 SCREENTOPW) (* ;; "N.B. \TTW1 can side effect the screen") (COND ((EQ W1 (fetch (SCREEN SCTOPW) of SCREEN))) ((NOT RPT) (* ;  "GC msgs or other glitches can cause W1 not to make it. Check and try ONCE more") (\INTERNALTOTOPW W1 T))))]) + +(\TTW1 [LAMBDA (WINDOW WS) (* ; "Edited 31-Jul-92 10:06 by jds") (* ;;; "This seems to swap the intersection of bitmaps.") (COND [(fetch (WINDOW NEXTW) of WS) (PROG (ISECT SCREEN) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (.WHILE.TOP.DS. \TOPWDS (SETQ ISECT (INTERSECTREGIONS (fetch (WINDOW REG) of WINDOW) (fetch (WINDOW REG) of WS) (fetch (SCREEN SCREGION) of SCREEN)) ) [AND ISECT (\SW2BM (fetch (SCREEN SCDESTINATION) of SCREEN) ISECT (fetch (WINDOW SAVE) of WS) (TRANSLATEREG ISECT (fetch (WINDOW REG) of WS] [COND ((EQ WINDOW (fetch (WINDOW NEXTW) of WS)) (* ;  "doesn't have to be uninterruptable here because TOTOPW is.") (replace (WINDOW NEXTW) of WS with (fetch (WINDOW NEXTW) of WINDOW)) (replace (WINDOW NEXTW) of WINDOW with (fetch (SCREEN SCTOPW ) of SCREEN)) (replace (SCREEN SCTOPW) of SCREEN with WINDOW) (SETQ \TOPWDS (fetch (WINDOW DSP) of WINDOW))) (T (\TTW1 WINDOW (fetch (WINDOW NEXTW) of WS] (AND ISECT (\SW2BM (fetch (WINDOW SAVE) of WINDOW) (TRANSLATEREG ISECT (fetch (WINDOW REG) of WINDOW)) (fetch (WINDOW SAVE) of WS) (TRANSLATEREG ISECT (fetch (WINDOW REG) of WS] ((type? WINDOW WINDOW) (* ;  "must be closed window; reopen it") (OPENW WINDOW]) + +(WHICHW [LAMBDA (X Y SCREEN) (* gbn%: "25-Jan-86 15:47") (SETQ SCREEN (\INSURESCREEN SCREEN)) (COND ((POSITIONP X) (WHICHW (fetch (POSITION XCOORD) of X) (fetch (POSITION YCOORD) of X) SCREEN)) (T (for (WINDOW _ (fetch (SCREEN SCTOPW) of SCREEN)) by (fetch (WINDOW NEXTW) of WINDOW) while WINDOW thereis (INSIDE? (fetch (WINDOW REG) of WINDOW) X Y]) +) + +(RPAQ? WINDOWTITLEPRINTLEVEL '(2 . 5)) + +(RPAQ? WINDOWTITLESHADE BLACKSHADE) + + + +(* ; "Window vs non-window world") + +(DEFINEQ + +(WFROMDS + [LAMBDA (DS DONTCREATE) (* ; "Edited 7-Jan-94 12:12 by nilsson") + + (* ;; "Finds or creates a window for a display stream") + + (* ;; "uses an XPointer from the displaystream as a hint. This means that the window might have been garbage collected, hence all the confirmation.") + + (DECLARE (GLOBALVARS \DEFAULTTTYDISPLAYSTREAM)) + (COND + ((WINDOWP DS) + DS) + ((IMAGESTREAMP DS) + (PROG (DD HINTW) + [COND + ((IMAGESTREAMTYPEP DS 'TEXT) + + (* ;; "generalize this mess!!!") + + (RETURN (CAR (fetch (TEXTOBJ \WINDOW) of (TEXTOBJ DS] + (SETQ DD (\GETDISPLAYDATA DS DS)) + (RETURN (COND + ((AND (SETQ HINTW (fetch (\DISPLAYDATA XWINDOWHINT) of DD)) + (EQ (fetch (WINDOW DSP) of HINTW) + DS)) + HINTW) + [(AND (EQ DS \DEFAULTTTYDISPLAYSTREAM) + (EQ (TTYDISPLAYSTREAM) + \DEFAULTTTYDISPLAYSTREAM))(* ; + "assume this process is doing something with T.") + (COND + ((NOT DONTCREATE) + (\CREATE.TTYDISPLAYSTREAM) + (WFROMDS (TTYDISPLAYSTREAM] + ([SETQ HINTW (for WINDOW in (OPENWINDOWS T) + thereis (EQ DS (fetch (WINDOW DSP) of WINDOW] + (* ; + "(OPENWINDOWS T) returns all windows on all screens") + HINTW) + ((NOT DONTCREATE) + (CREATEW NIL NIL NIL T]) + +(NU\TOTOPWDS [LAMBDA (DS NOTOTOPFNFLG) (* ; "Edited 17-Aug-88 19:37 by jds") (* ;  "Moves the window of displaystream DS to the top") (AND (FMEMB (DSPDESTINATION NIL DS) \SCREENBITMAPS) (TOTOPW (WFROMDS DS) NOTOTOPFNFLG]) + +(\COERCETODS [LAMBDA (X) (* rrb "23-OCT-81 13:29") (* ;; "Called from \SFInsureDisplayStream macro. Compiles open in system code, closed call in user code, and equivalent to \ILLEGAL.ARG if no window package.") (COND ((type? WINDOW X) (fetch (WINDOW DSP) of X)) (T (\ILLEGAL.ARG X]) +) +(DECLARE%: DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[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)] +) + +(* "END EXPORTED DEFINITIONS") + +) + +(MOVD 'NU\TOTOPWDS '\TOTOPWDS) + + + +(* ; "User interface functions") + +(DEFINEQ + +(WINDOWP [LAMBDA (X) (* rrb "20-NOV-81 07:30") (AND (type? WINDOW X) X]) + +(INSURE.WINDOW [LAMBDA (WIN? NOERRORFLG) (* rrb "17-Mar-86 15:39") (* ;;; "coerces WIN? to a window.") (COND ((type? WINDOW WIN?) WIN?) ((DISPLAYSTREAMP (\OUTSTREAMARG WIN? T)) (WFROMDS WIN?)) ((NULL NOERRORFLG) (\ILLEGAL.ARG WIN?]) + +(WINDOWPROP [LAMBDA X (* rrb "26-AUG-82 17:36") (* ;; "general top level entry for both fetching and setting window properties.") (COND ((IGREATERP X 2) (PUTWINDOWPROP (ARG X 1) (ARG X 2) (ARG X 3))) ((EQ X 2) (GETWINDOWPROP (ARG X 1) (ARG X 2))) (T (\ILLEGAL.ARG NIL]) + +(WINDOWADDPROP [LAMBDA (WINDOW PROP ITEMTOADD FIRSTFLG) (* rrb "20-Mar-84 16:07") (* ;; "adds an element to a window property.") (PROG ((CURRENT (WINDOWPROP WINDOW PROP))) (RETURN (WINDOWPROP WINDOW PROP (COND ((NULL CURRENT) (LIST ITEMTOADD)) [(NLISTP CURRENT) (COND ((EQ CURRENT ITEMTOADD) (LIST ITEMTOADD)) (FIRSTFLG (LIST ITEMTOADD CURRENT)) (T (LIST CURRENT ITEMTOADD] ((FMEMB ITEMTOADD CURRENT) (* ; "don't put things on twice.") (COND ((AND FIRSTFLG (NEQ (CAR CURRENT) ITEMTOADD)) (* ; "make it first") (CONS ITEMTOADD (REMOVE ITEMTOADD CURRENT))) (T CURRENT))) (FIRSTFLG (CONS ITEMTOADD CURRENT)) (T (NCONC1 (APPEND CURRENT) ITEMTOADD]) + +(WINDOWDELPROP [LAMBDA (WINDOW PROP ITEMTODELETE) (* rrb "13-JUN-82 17:58") (* ;; "deletes a property from a window property.") (PROG ((CURRENT (WINDOWPROP WINDOW PROP))) (RETURN (COND ((LISTP CURRENT) (AND (FMEMB ITEMTODELETE CURRENT) (WINDOWPROP WINDOW PROP (REMOVE ITEMTODELETE CURRENT]) + +(GETWINDOWPROP [LAMBDA (WINDOW PROP) (* ;  "Edited 27-Dec-93 11:46 by sybalsky:mv:envos") (* ;; "gets values from a window. Called by the macro for WINDOWPROP.") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW T)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (WINDOWOP 'GETWINDOWPROPFN (fetch (WINDOW SCREEN) of WINDOW) WINDOW PROP VALUE]) + +(GETWINDOWUSERPROP [LAMBDA (WINDOW USERPROP) (* rrb "28-OCT-83 11:00") (* ;; "gets a property from the USERDATA property list of a window. This is the function called by the macro for GETWINDOWPROP which result from a call to WINDOWPROP that doesn't have a third argument.") (LISTGET (fetch (WINDOW USERDATA) of (\INSUREWINDOW WINDOW)) USERPROP]) + +(PUTWINDOWPROP [LAMBDA (WINDOW PROP VALUE) (* ;  "Edited 27-Dec-93 11:46 by sybalsky:mv:envos") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (WINDOWOP 'PUTWINDOWPROPFN (fetch (WINDOW SCREEN) of WINDOW) WINDOW PROP VALUE]) + +(REMWINDOWPROP [LAMBDA (WINDOW PROP) (* rmk%: "31-AUG-83 16:42") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) (SETQ WINDOW (WFROMDS WINDOW))) (T (LISPERROR "ILLEGAL ARG" WINDOW] (PROG (DATA) (SETQ DATA (fetch (WINDOW USERDATA) of WINDOW)) (RETURN (for TAIL on DATA by (CDDR TAIL) bind PREV do (COND ((EQ (CAR TAIL) PROP) (COND (PREV (RPLACD (CDR PREV) (CDDR TAIL))) ((CDDR TAIL) (FRPLNODE2 TAIL (CDDR TAIL))) (T (replace (WINDOW USERDATA) of WINDOW with NIL))) (RETURN PROP))) (SETQ PREV TAIL]) + +(WINDOWADDFNPROP [LAMBDA (WINDOW PROP ITEMTOADD) (* rrb "18-JUN-82 16:30") (* ;; "adds A functional element to a window property. This is different from WINDOWADDTOPROP because is checks for LAMBDA expressions as a single element.") (PROG ((CURRENT (WINDOWPROP WINDOW PROP))) (RETURN (WINDOWPROP WINDOW PROP (COND ((NULL CURRENT) (LIST ITEMTOADD)) ((OR (NLISTP CURRENT) (FMEMB (CAR CURRENT) LAMBDASPLST)) (LIST CURRENT ITEMTOADD)) ((FMEMB ITEMTOADD CURRENT) (* ; "don't put things on twice.") CURRENT) (T (NCONC1 (APPEND CURRENT) ITEMTOADD]) +) + + + +(* ; "Compiled WINDOWPROP") + + +(PUTPROPS WINDOWPROP ARGNAMES (NIL (WINDOW PROP {NEWVALUE}) . U)) + +(DEFOPTIMIZER WINDOWPROP (&REST ARGS) + (CWINDOWPROP ARGS)) +(DEFINEQ + +(CWINDOWPROP [LAMBDA (FORMTAIL) (* rrb "28-OCT-83 10:51") (* ;; "compiles calls to WINDOWPROP") (COND ((NULL (CDR FORMTAIL)) (* ; "less than 2 args") (printout T "Possible error in call to WINDOWPROP: less than 2 args" T (LIST 'WINDOWPROP FORMTAIL) T) (CGETWINDOWPROP (CAR FORMTAIL) NIL)) ((NOT (EQ (CAADR FORMTAIL) 'QUOTE)) (* ; "property is not quoted.") 'IGNOREMACRO) [(NULL (CDDR FORMTAIL)) (* ; "fetching a window property.") (CGETWINDOWPROP (CAR FORMTAIL) (CADR (CADR FORMTAIL] (T (* ; "storing a window property") (CONS 'PUTWINDOWPROP FORMTAIL]) + +(CGETWINDOWPROP [LAMBDA (WINFORM PROP) (* kbr%: "17-Feb-86 10:43") (* ;; "compiles calls on WINDOWPROP that are fetching values. This needs to be changed whenever GETWINDOWPROP is changed.") (PROG NIL (RETURN (SUBST (LIST '\INSUREWINDOW WINFORM) 'DATUM (SELECTQ PROP (RIGHTBUTTONFN (CONSTANT (RECORDACCESSFORM '(WINDOW RIGHTBUTTONFN) 'DATUM 'ffetch))) (BUTTONEVENTFN (CONSTANT (RECORDACCESSFORM '(WINDOW BUTTONEVENTFN) 'DATUM 'ffetch))) (CURSORINFN (CONSTANT (RECORDACCESSFORM '(WINDOW CURSORINFN) 'DATUM 'ffetch))) (CURSOROUTFN (CONSTANT (RECORDACCESSFORM '(WINDOW CURSOROUTFN) 'DATUM 'ffetch))) (CURSORMOVEDFN (CONSTANT (RECORDACCESSFORM '(WINDOW CURSORMOVEDFN) 'DATUM 'ffetch))) (DSP (CONSTANT (RECORDACCESSFORM '(WINDOW DSP) 'DATUM 'ffetch))) (SCREEN (CONSTANT (RECORDACCESSFORM '(WINDOW SCREEN) 'DATUM 'ffetch))) (SCROLLFN (CONSTANT (RECORDACCESSFORM '(WINDOW SCROLLFN) 'DATUM 'ffetch))) (MOVEFN (CONSTANT (RECORDACCESSFORM '(WINDOW MOVEFN) 'DATUM 'ffetch))) (RESHAPEFN (CONSTANT (RECORDACCESSFORM '(WINDOW RESHAPEFN) 'DATUM 'ffetch))) (EXTENT (CONSTANT (RECORDACCESSFORM '(WINDOW EXTENT) 'DATUM 'ffetch))) (REPAINTFN (CONSTANT (RECORDACCESSFORM '(WINDOW REPAINTFN) 'DATUM 'ffetch))) (CLOSEFN (CONSTANT (RECORDACCESSFORM '(WINDOW CLOSEFN) 'DATUM 'ffetch))) (WINDOWENTRYFN (CONSTANT (RECORDACCESSFORM '(WINDOW WINDOWENTRYFN) 'DATUM 'ffetch))) (PROCESS (CONSTANT (RECORDACCESSFORM '(WINDOW PROCESS) 'DATUM 'ffetch))) (REGION (CONSTANT (RECORDACCESSFORM '(WINDOW REG) 'DATUM 'ffetch))) (NEWREGIONFN (CONSTANT (RECORDACCESSFORM '(WINDOW NEWREGIONFN) 'DATUM 'ffetch))) (TITLE (CONSTANT (RECORDACCESSFORM '(WINDOW WTITLE) 'DATUM 'ffetch))) (BORDER (CONSTANT (RECORDACCESSFORM '(WINDOW WBORDER) 'DATUM 'ffetch))) (IMAGECOVERED (CONSTANT (RECORDACCESSFORM '(WINDOW SAVE) 'DATUM 'ffetch))) (HEIGHT (LIST 'GETWINDOWPROP WINFORM ''HEIGHT)) (WIDTH (LIST 'GETWINDOWPROP WINFORM ''WIDTH)) (RETURN (PROGN (* ;; "return around SUBST. GETWINDOWUSERPROP will perform the window check and this avoids compiling code for it at every call.") (LIST 'GETWINDOWUSERPROP WINFORM (KWOTE PROP]) + +(\GETWINDOWHEIGHT [LAMBDA (WINDOW) (* gbn%: "25-Jan-86 15:45") (* ;; "calculate the height from the REGION in case user has changed the clipping region. This won't work if the height of the title display stream has changed.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (DIFFERENCE (fetch (REGION HEIGHT) of (fetch (WINDOW REG) of WINDOW)) (DIFFERENCE (ITIMES 2 (fetch (WINDOW WBORDER) of WINDOW)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN ) of WINDOW] (T 0]) + +(\GETWINDOWWIDTH [LAMBDA (WINDOW) (* rrb " 4-Jun-84 18:03") (* ;; "calculate the width from the REGION in case the user has changed the clipping region.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (DIFFERENCE (fetch (REGION WIDTH) of (fetch (WINDOW REG) of WINDOW)) (ITIMES 2 (fetch (WINDOW WBORDER) of WINDOW]) +) +(DEFINEQ + +(OPENWP [LAMBDA (WINDOW) (* rrb "26-OCT-83 15:01") (* ;; "is WINDOW an open window?") (AND (type? WINDOW WINDOW) (NEQ (fetch (WINDOW NEXTW) of WINDOW) 'CLOSED) WINDOW]) + +(TOPWP [LAMBDA (WINDOW) (* kbr%: "17-Feb-86 10:37") (* ;;; "A function user's can use to test if WINDOW is the TOPW of it's screen.") (EQ WINDOW (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW]) + +(RESHAPEBYREPAINTFN [LAMBDA (WINDOW OLDIMAGE IMAGEREGION OLDSCREENREGION) (* rrb "11-Oct-84 17:22") (* ;; "default reshaping function that copies the lower left portion of the old image into the new image and calls the repaint function on the newly exposed portions.") (* ;; "if IMAGEREGION shares a corner with the current region, the excess is added in the opposite directions. Also the newly exposed region will be a subset of the EXTENT property if the window has one.") (PROG ((NEWSCREENREGION (WINDOWPROP WINDOW 'REGION)) (EXTENT (WINDOWPROP WINDOW 'EXTENT)) (DSP (WINDOWPROP WINDOW 'DSP)) (OLDWIDTH (fetch (REGION WIDTH) of IMAGEREGION)) (OLDHEIGHT (fetch (REGION HEIGHT) of IMAGEREGION)) NEWWID NEWHGHT WREGION OLDCRLFT OLDCRBTM NEWCRLFT NEWCRBTM DELTAWID DELTAHGHT NEWPTOP OLDPTOP NEWPRIGHT OLDPRIGHT YPOS) (SETQ WREGION (DSPCLIPPINGREGION NIL DSP)) (SETQ OLDCRLFT (fetch (REGION LEFT) of WREGION)) (SETQ OLDCRBTM (fetch (REGION BOTTOM) of WREGION)) (* ;  "calculate the position of the new clipping region.") (SETQ NEWWID (fetch (REGION WIDTH) of WREGION)) (SETQ DELTAWID (IDIFFERENCE NEWWID OLDWIDTH)) (SETQ NEWHGHT (fetch (REGION HEIGHT) of WREGION)) (SETQ DELTAHGHT (IDIFFERENCE NEWHGHT OLDHEIGHT)) [COND [(AND OLDSCREENREGION EXTENT (EQ (fetch (REGION PRIGHT) of NEWSCREENREGION) (fetch (REGION PRIGHT) of OLDSCREENREGION))) (* ;  "right edges match, move the left one") (SETQ NEWCRLFT (IDIFFERENCE OLDCRLFT DELTAWID)) (COND ((AND (IGREATERP DELTAWID 0) (IGREATERP (fetch (REGION LEFT) of EXTENT) NEWCRLFT)) (* ;; "this would be extending the window onto parts of the extent that don't have anything in them, reset the left so that it gets the entire extent") (SETQ NEWCRLFT (IMIN (fetch (REGION LEFT) of EXTENT) (IDIFFERENCE (fetch (REGION RIGHT) of EXTENT) NEWWID] (T (* ; "otherwise move the right edge.") (COND [(AND (IGREATERP DELTAWID 0) EXTENT (IGREATERP (IPLUS OLDCRLFT NEWWID) (fetch (REGION RIGHT) of EXTENT))) (* ;; "this would be extending the window onto parts of the extent that don't have anything in them, reset the left so that it gets the entire extent") (SETQ NEWCRLFT (IMAX (IMIN (fetch (REGION LEFT) of EXTENT) OLDCRLFT) (IDIFFERENCE OLDCRLFT DELTAWID] (T (SETQ NEWCRLFT OLDCRLFT] [COND [(AND OLDSCREENREGION (EQ (fetch (REGION PTOP) of NEWSCREENREGION) (fetch (REGION PTOP) of OLDSCREENREGION))) (* ;  "top edges match, move the bottom one") (SETQ NEWCRBTM (IDIFFERENCE OLDCRBTM DELTAHGHT)) (COND ((AND (IGREATERP DELTAHGHT 0) EXTENT (IGREATERP (fetch (REGION BOTTOM) of EXTENT) NEWCRBTM)) (* ;; "this would be extending the window onto parts of the extent that don't have anything in them, reset the bottom so that it gets the entire extent") (SETQ NEWCRBTM (IMIN (fetch (REGION BOTTOM) of EXTENT) (IDIFFERENCE (fetch (REGION TOP) of EXTENT) NEWHGHT] (T (* ; "otherwise move the top edge.") (COND [(AND (IGREATERP DELTAHGHT 0) EXTENT (IGREATERP (IPLUS OLDCRBTM OLDHEIGHT DELTAHGHT) (fetch (REGION PTOP) of EXTENT))) (* ;; "this would be extending the window onto parts of the extent that don't have anything in them, reset the bottom so that it gets the entire extent") (SETQ NEWCRBTM (IMAX (IDIFFERENCE OLDCRBTM DELTAHGHT) (fetch (REGION BOTTOM) of EXTENT) (IDIFFERENCE (fetch (REGION PTOP) of EXTENT) NEWHGHT] (T (SETQ NEWCRBTM OLDCRBTM] (* ;  "scroll the window so that the new left bottom is the left bottom of the clipping region.") [COND ((AND (NULL EXTENT) (\INBETWEENP (DSPXPOSITION NIL WINDOW) OLDCRLFT (IPLUS OLDCRLFT OLDWIDTH)) (\INBETWEENP (SETQ YPOS (DSPYPOSITION NIL WINDOW)) OLDCRBTM (IPLUS OLDCRBTM OLDHEIGHT))) (* ;; "if the window doesn't have any EXTENT and its position is visible, make sure its Y position is visible at the end of the scroll.") (COND [(ILESSP YPOS NEWCRBTM) (* ;  "make sure the entire line of text being printed is visible.") (SETQ NEWCRBTM (DIFFERENCE YPOS (FONTPROP WINDOW 'DESCENT] ([IGREATERP YPOS (DIFFERENCE (IPLUS NEWCRBTM NEWHGHT) (FONTPROP WINDOW 'ASCENT] (SETQ NEWCRBTM (IPLUS (IDIFFERENCE YPOS NEWHGHT) (FONTPROP WINDOW 'ASCENT] [COND ((NEQ OLDCRLFT NEWCRLFT) (COND ((EQ (DSPSCROLL NIL WINDOW) 'ON) (* ;  "if scrolling is turned on, don't change the coordinates.") NIL) (T (WXOFFSET (DIFFERENCE OLDCRLFT NEWCRLFT) WINDOW] [COND ((NEQ OLDCRBTM NEWCRBTM) (COND ((EQ (DSPSCROLL NIL WINDOW) 'ON) (* ;  "if scrolling is turned on, change the Y rather than the coordinates.") (DSPYPOSITION (PLUS (DIFFERENCE OLDCRBTM NEWCRBTM) YPOS) WINDOW)) (T (WYOFFSET (DIFFERENCE OLDCRBTM NEWCRBTM) WINDOW] (* ;  "call the redisplay function on the four possible areas and blt the middle one.") (COND ((IGREATERP (SETQ NEWPTOP (IPLUS NEWCRBTM NEWHGHT)) (SETQ OLDPTOP (IPLUS OLDCRBTM OLDHEIGHT))) (* ;  "call the display function on the newly exposed top area.") (REDISPLAYW WINDOW (create REGION LEFT _ NEWCRLFT BOTTOM _ OLDPTOP WIDTH _ NEWWID HEIGHT _ (IDIFFERENCE NEWPTOP OLDPTOP)) T))) (COND ((IGREATERP OLDCRLFT NEWCRLFT) (* ;  "call the display function on the newly exposed LEFT area.") (REDISPLAYW WINDOW (create REGION LEFT _ NEWCRLFT BOTTOM _ OLDCRBTM WIDTH _ (IDIFFERENCE OLDCRLFT NEWCRLFT) HEIGHT _ OLDHEIGHT) T))) (* ; "blt center region.") (BITBLT OLDIMAGE (fetch (REGION LEFT) of IMAGEREGION) (fetch (REGION BOTTOM) of IMAGEREGION) DSP OLDCRLFT OLDCRBTM OLDWIDTH OLDHEIGHT NIL 'REPLACE) (COND ((IGREATERP (SETQ NEWPRIGHT (IPLUS NEWCRLFT NEWWID)) (SETQ OLDPRIGHT (IPLUS OLDCRLFT OLDWIDTH))) (* ;  "call the display function on the newly exposed right area.") (REDISPLAYW WINDOW (create REGION LEFT _ OLDPRIGHT BOTTOM _ OLDCRBTM WIDTH _ (IDIFFERENCE NEWPRIGHT OLDPRIGHT) HEIGHT _ OLDHEIGHT) T))) (COND ((IGREATERP OLDCRBTM NEWCRBTM) (* ;  "call the display function on the newly exposed LEFT area.") (REDISPLAYW WINDOW (create REGION LEFT _ NEWCRLFT BOTTOM _ NEWCRBTM WIDTH _ NEWWID HEIGHT _ (IDIFFERENCE OLDCRBTM NEWCRBTM)) T))) (RETURN WINDOW]) + +(\INBETWEENP [LAMBDA (X LFT RGHT) (* rrb "11-Oct-84 17:07") (* ;; "returns T if X is between LEFT and RIGHT") (AND (GEQ X LFT) (GREATERP RGHT X]) + +(DECODE/WINDOW/OR/DISPLAYSTREAM [LAMBDA (DSORW WINDOWVAR TITLE BORDER) (* ; "Edited 24-Sep-92 12:32 by jds") (* ;; "provides a defaulting mechanism for display-streams that uses windows too. If DSORW is NIL, it uses the value of WINDOWVAR and if DSORW is NEW, it creates a new one.") (COND ((DISPLAYSTREAMP DSORW)) ((WINDOWP DSORW) (OPENW DSORW) (AND TITLE (NOT (EQUAL TITLE (fetch (WINDOW WTITLE) of DSORW))) (WINDOWPROP DSORW 'TITLE TITLE)) (AND BORDER (WINDOWPROP DSORW 'BORDER BORDER)) (fetch (WINDOW DSP) of DSORW)) [(NULL DSORW) (fetch (WINDOW DSP) of (PROG ((WINDOW (EVALV WINDOWVAR))) (RETURN (COND ((WINDOWP WINDOW) (OPENW WINDOW) (AND TITLE (NOT (EQUAL TITLE (fetch (WINDOW WTITLE) of WINDOW))) (WINDOWPROP WINDOW 'TITLE TITLE)) (AND BORDER (WINDOWPROP WINDOW 'BORDER BORDER)) WINDOW) (T (SET WINDOWVAR (CREATEW NIL TITLE BORDER] [(EQ DSORW 'NEW) (fetch (WINDOW DSP) of (SET WINDOWVAR (CREATEW NIL TITLE BORDER] (T (ERROR "Illegal args" (LIST DSORW WINDOWVAR]) + +(GROW/REGION [LAMBDA (REGION AMOUNT) (* rrb "19-OCT-83 11:18") (* ;; "increase REGION by amount in all directions") (CREATEREGION (IDIFFERENCE (fetch (REGION LEFT) of REGION) AMOUNT) (IDIFFERENCE (fetch (REGION BOTTOM) of REGION) AMOUNT) (IPLUS (fetch (REGION WIDTH) of REGION) (SETQ AMOUNT (ITIMES AMOUNT 2))) (IPLUS (fetch (REGION HEIGHT) of REGION) AMOUNT]) + +(CLRPROMPT + [LAMBDA NIL (* ; "Edited 7-Mar-94 11:55 by sybalsky") + + (* ;; "clears the prompt window") + + (LET ((P PROMPTWINDOW)) + (if P + then (COND + ((type? WINDOW P) + (DSPRESET P)) + (T (TERPRI P) + (TERPRI P]) + +(PROMPTPRINT + [LAMBDA N (* ; "Edited 7-Mar-94 11:55 by sybalsky") + (CLRPROMPT) + (for I from 1 to N do (PRIN1 (ARG N I) + PROMPTWINDOW]) + +(OPENWINDOWS [LAMBDA (SCREEN) (* kbr%: " 4-Aug-85 16:34") (* ;; "returns a list of all open windows") (PROG (WINDOW WINDOWS) (COND ((EQ SCREEN T) (* ; "Return all open windows.") (SETQ WINDOWS (for SCREEN in \SCREENS join (OPENWINDOWS SCREEN))) (RETURN WINDOWS))) (SETQ SCREEN (\INSURESCREEN SCREEN)) (SETQ WINDOW (fetch (SCREEN SCTOPW) of SCREEN)) (while WINDOW do (SETQ WINDOWS (CONS WINDOW WINDOWS)) (SETQ WINDOW (fetch (WINDOW NEXTW) of WINDOW))) (SETQ WINDOWS (DREVERSE WINDOWS)) (RETURN WINDOWS]) + +(\INSUREWINDOW [LAMBDA (WINDOW) (* rmk%: " 1-SEP-83 10:25") (* ;; "coerces to a window") (COND ((type? WINDOW WINDOW) WINDOW) ((AND (DISPLAYSTREAMP (\OUTSTREAMARG WINDOW T)) (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW]) +) + + + +(* ; "these entries are left in for backward compatibility. They were dedocumented 6/83. rrb") + + +(MOVD 'OPENWP 'ACTIVEWP) +(DEFINEQ + +(OVERLAPPINGWINDOWS [LAMBDA (WINDOW) (* gbn%: "25-Jan-86 15:52") (* ;; "returns all windows that overlap with WINDOW or that overlap a window that is in the OVERLAPPINGWINDOWS of WINDOW.") (PROG (WPTR OVERLAPS DONTS) (SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW))) (SETQ OVERLAPS (CONS WINDOW (ALLATTACHEDWINDOWS WINDOW))) LP [COND ((NULL WPTR) (RETURN OVERLAPS)) ((MEMB WPTR OVERLAPS) (* ; "skip the window itself") NIL) ([SOME OVERLAPS (FUNCTION (LAMBDA (X) (WOVERLAPP WPTR X] (* ;  "this window overlaps a member of the interesting ones.") (SETQ OVERLAPS (CONS WPTR OVERLAPS)) (* ;; "find all members of donts that overlap this new window and move them {and ones that overlap them} to OVERLAPS.") (PROG ((ADDS (CONS WPTR)) OVERLAPPED) NWLP (COND ((for old OVERLAPPED in DONTS thereis (WOVERLAPP (CAR ADDS) OVERLAPPED)) (* ;  "the window that was added overlaps one of the previously looked at windows that was untouched.") (SETQ ADDS (CONS OVERLAPPED ADDS)) (SETQ OVERLAPS (CONS OVERLAPPED OVERLAPS)) (SETQ DONTS (REMOVE OVERLAPPED DONTS)) (GO NWLP)) ((SETQ ADDS (CDR ADDS)) (* ;  "there are more windows that were added.") (GO NWLP))) (RETURN))) (T (SETQ DONTS (CONS WPTR DONTS] (SETQ WPTR (fetch (WINDOW NEXTW) of WPTR)) (GO LP]) + +(WOVERLAPP [LAMBDA (W1 W2) (* rrb "16-AUG-81 08:30") (* ;; "do these windows overlap?") (REGIONSINTERSECTP (fetch (WINDOW REG) of W1) (fetch (WINDOW REG) of W2]) + +(ORDERFROMBOTTOMTOTOP [LAMBDA (WLST) (* gbn%: "25-Jan-86 15:56") (* ;; "returns a list of windows in order from bottom to top") (PROG (ANS WPTR) (COND ((NULL WLST) (RETURN NIL))) [SETQ WPTR (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of (CAR WLST] (* ; "start at the topw") LP [COND ((NULL WPTR) (RETURN ANS)) ((FMEMB WPTR WLST) (SETQ ANS (CONS WPTR ANS] (SETQ WPTR (fetch (WINDOW NEXTW) of WPTR)) (GO LP]) +) + + + +(* ; "screen size changing functions.") + +(DEFINEQ + +(\ONSCREENW [LAMBDA (W) (* kbr%: "18-Jan-86 18:40") (* ;; "does W have any part on the screen?") (* ;; "for now only consider that it might be too far to the right as this is the wide to narrow screen case.") (* ;; "HARDCURSORWIDTH is to make sure the cursor can be set in the window. It can be taken out when cursor hotspot can go anywhere.") (IGREATERP (IDIFFERENCE (fetch (SCREEN SCWIDTH) of (fetch (WINDOW SCREEN) of W)) HARDCURSORWIDTH) (fetch (REGION LEFT) of (WINDOWPROP W 'REGION]) + +(\PUTONSCREENW [LAMBDA (W) (* kbr%: "26-Mar-85 23:29") (* ;; "moves W so that it will be on the screen. For now, moves it to the left by screenwidth") (MOVEW W (create POSITION XCOORD _ (IDIFFERENCE (fetch (REGION LEFT) of (fetch (WINDOW REG) of W)) (fetch (SCREEN SCWIDTH) of (fetch (WINDOW SCREEN) of W))) YCOORD _ (fetch (REGION BOTTOM) of (WINDOWPROP W 'REGION]) + +(\UPDATECACHEDFIELDS [LAMBDA (DS) (* rrb "14-OCT-81 16:53") (* ;;  "updates the cached fields of a displaystream for the fact that the screen bitmap changed sizes") (\SFFixDestination DS]) + +(\WWCHANGESCREENSIZE [LAMBDA (SCREEN) (* lmm "16-Nov-86 05:04") (* ;; "the sysout has been moved to a screen of a different size. All windows are closed, the screenbitmap is updated to correct new size and the windows are reopened so that at least part of each is visible.") (PROG (WINDOWS) (SETQ SCREEN (\INSURESCREEN SCREEN)) (SETQ WINDOWS (DREVERSE (OPENWINDOWS SCREEN))) (* ;  "OPENWINDOWS returns the windows with bottom window first.") (for W in WINDOWS do (\CLOSEW1 W)) (\STARTDISPLAY) (\CLEARBM (fetch (SCREEN SCDESTINATION) of SCREEN) WINDOWBACKGROUNDSHADE) (* ;  "update cached bitmap width information that is in the display streams") [for W in WINDOWS do (\UPDATECACHEDFIELDS (WINDOWPROP W 'DSP] (* ; "bring back windows") (for W in (REVERSE WINDOWS) do (COND ((NOT (\ONSCREENW W)) (\PUTONSCREENW W))) (OPENW W]) + +(CREATEWFROMIMAGE [LAMBDA (IMAGE SCREEN) (* gbn%: "25-Jan-86 16:05") (* ;; "creates a window that has IMAGE (a bitmap) as an image. It is initially closed and can be opened.") (PROG (WINDOW) (SETQ WINDOW (CREATEW (create SCREENREGION SCREEN _ (\INSURESCREEN SCREEN) LEFT _ 0 BOTTOM _ 0 WIDTH _ (BITMAPWIDTH IMAGE) HEIGHT _ (BITMAPHEIGHT IMAGE)) NIL 0 T)) [WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth (BITMAPWIDTH IMAGE)) (IMIN MinWindowWidth (BITMAPHEIGHT IMAGE] (BITBLT IMAGE 0 0 (fetch (WINDOW SAVE) of WINDOW)) (RETURN WINDOW]) + +(UPDATEWFROMIMAGE [LAMBDA (WINDOW) (* ; "Edited 20-Aug-91 18:05 by jds") (* ;; "makes the fields of a window consistent with its image.") (PROG ((REGION (fetch (WINDOW REG) of WINDOW)) (IMAGE (fetch (WINDOW SAVE) of WINDOW))) (replace (REGION LEFT) of REGION with 0) (replace (REGION BOTTOM) of REGION with 0) (replace (REGION WIDTH) of REGION with (BITMAPWIDTH IMAGE)) (replace (REGION HEIGHT) of REGION with (BITMAPHEIGHT IMAGE]) +) + + + +(* ;; "MEDLEY-NATIVE-WINDOWS INTERFACE FUNCTIONS") + +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \SCREENS \SCREENTYPES) +) + +(RPAQ? \SCREENS ) + +(RPAQ? \SCREENTYPES '((1 MEDLEY OPEN-SCREEN CREATESCREEN CLOSE-SCREEN NILL) + (2 MEDLEY-COLOR-4) + (4 MEDLEY-COLOR-8) + (8 MEDLEY-COLOR-24) + (16 X-MONO) + (32 X-COLOR) + (64 MS-WINDOWS))) + + + +(* ;; "OLD-MEDLEY-SCREEN window management functions") + +(DEFINEQ + +(\MEDW.CREATEW + [LAMBDA (SCREEN REGION TITLE BORDERSIZE NOOPENFLG PROPS OLDWINDOW) + (* ; "Edited 28-Dec-93 15:12 by nilsson") + + (* ;; "creates and returns a window. If OLDWINDOW is defined this method has to reuse OLDWINDOW. This helps us open old windows on new screens.") + + (LET ((DSP (if OLDWINDOW + then (DSPCREATE SCREEN (fetch (WINDOW DSP) of OLDWINDOW)) + else (DSPCREATE SCREEN))) + DISPLAYDATA WINDOW) + (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP)) + [SETQ WINDOW (OR OLDWINDOW (create WINDOW + REG _ REGION + SAVE _ (BITMAPCREATE (fetch (REGION WIDTH) + of REGION) + (fetch (REGION HEIGHT) of REGION) + (BITSPERPIXEL (fetch (SCREEN + SCDESTINATION + ) + of SCREEN))) + WTITLE _ TITLE + WBORDER _ BORDERSIZE + NEXTW _ 'CLOSED] + (replace (WINDOW SCREEN) of WINDOW with SCREEN) + (replace (WINDOW DSP) of WINDOW with DSP) + (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW) + (* ; + "make the display stream and window agree about dimensions.") + (if OLDWINDOW + then (LET ((R (fetch (WINDOW REG) of OLDWINDOW)) + (TWICEBORDER (UNFOLD BORDERSIZE 2))) + + (* ;; "OLDWINDOW was defined. We have to recalculate the clippingregion since some screens (notably X) uses the clipping region relative to the window instead of relative to the screen") + + (DSPXOFFSET (IPLUS (fetch (REGION LEFT) of R) + BORDERSIZE) + DSP) + (DSPYOFFSET (IPLUS (fetch (REGION BOTTOM) of R) + BORDERSIZE) + DSP) + (DSPCLIPPINGREGION [create + REGION + LEFT _ 0 + BOTTOM _ 0 + WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) + of R) + TWICEBORDER) + HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT + ) + of R) + TWICEBORDER) + (COND + [(fetch (WINDOW WTITLE) + of OLDWINDOW) + (DSPLINEFEED + NIL + (fetch (SCREEN SCTITLEDS) + of (fetch (WINDOW + SCREEN) + of OLDWINDOW] + (T 0] + DSP)) + else (ADVISEWDS WINDOW) + (MOVETOUPPERLEFT WINDOW) + (SHOWWFRAME WINDOW)) + (COND + ((NOT NOOPENFLG) + (OPENW WINDOW))) + WINDOW]) + +(\MEDW.OPENW + [LAMBDA (SCREEN WINDOW) (* ; "Edited 25-Apr-94 10:12 by sybalsky") + + (* ;; "opens a window by putting on the window stack and putting its bits on the screen. Returns the window if it was actually opened.") + + (* ;; "If already open, punt.") + + (if (EQ (fetch (WINDOW NEXTW) of WINDOW) + 'CLOSED) + then (LET (DD) + (UNINTERRUPTABLY + (replace (WINDOW NEXTW) of WINDOW with (fetch (SCREEN + SCTOPW) + of SCREEN)) + (replace (SCREEN SCTOPW) of SCREEN with WINDOW) + (SETQ \TOPWDS (fetch (WINDOW DSP) of WINDOW)) + (* ; + "DSP of a window is guaranteed to be a display-stream") + (SETQ DD (fetch (STREAM IMAGEDATA) of \TOPWDS)) + (* ; + "Just in case screen width has changed.") + (replace (PILOTBBT PBTDESTBPL) of (fetch (\DISPLAYDATA + DDPILOTBBT) + of DD) + with (UNFOLD (fetch (BITMAP BITMAPRASTERWIDTH) + of (fetch (SCREEN SCDESTINATION) + of SCREEN)) + BITSPERWORD)) + (.WHILE.TOP.DS. \TOPWDS (\SW2BM (fetch (\DISPLAYDATA DDDestination) + of DD) + (fetch (WINDOW REG) of WINDOW) + (fetch (WINDOW SAVE) of WINDOW) + NIL)))]) + +(\MEDW.CLOSEW + [LAMBDA (SCREEN WINDOW) (* ; "Edited 25-Apr-94 10:07 by sybalsky") + + (* ;; "Do the actual closing operation for Medley windows.") + + (LET (NEXTW) + (COND + ((NOT (EQ \TOPWDS (FETCH (WINDOW DSP) OF WINDOW))) + (* ; + "This window isn't on top, so we want to bring it there WITHOUT running topfns.") + (\TOTOPWDS (FETCH (WINDOW DSP) OF WINDOW) + T))) + (.WHILE.TOP.DS. \TOPWDS (\SW2BM (fetch (SCREEN SCDESTINATION) of SCREEN) + (fetch (WINDOW REG) of WINDOW) + (fetch (WINDOW SAVE) of WINDOW) + NIL) + (SETQ NEXTW (fetch (WINDOW NEXTW) of WINDOW)) + (replace (SCREEN SCTOPW) of SCREEN with NEXTW) + [SETQ \TOPWDS (COND + (NEXTW (fetch (WINDOW DSP) of NEXTW] + (* ; + "smash the window's link to other's in the chain.") + (replace (WINDOW NEXTW) of WINDOW with 'CLOSED]) + +(\MEDW.MOVEW [LAMBDA (SCREEN WINDOW POSorX Y) (* ; "Edited 27-Sep-93 10:23 by jds") (* ;; "moves a window. If window is closed and position is given, it won't open the window. It also calls the window's MOVEFN property.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) (OPEN? (OPENWP WINDOW)) OLDSCREEN POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT OLDCLIPREGION LFT BTM REG FN) (SETQ OLDSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) [COND ((NOT (SUBREGIONP OLDREGION (fetch (SCREEN SCREGION) of OLDSCREEN))) (* ;  "use T as an indication that the window was completely off screen.") (SETQ OLDCLIPREGION (OR (\ONSCREENCLIPPINGREGION WINDOW) T] (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND ([AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (* ; "if not aready open, don't") (AND OPEN? (TOTOPW WINDOW))) (T (* ;  "no position to move to has been given, ask user for one.") (TOTOPW WINDOW) (* ;  "TOTOPW opens the window if it is not already.") [COND [[AND (SETQ FN (WINDOWPROP WINDOW 'CALCULATEREGIONFN)) (SETQ REG (APPLY* FN WINDOW '\MEDW.MOVEW] (* ;  "prompt with a region that is calculated by the window") [SETQ POS (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (ffetch (REGION HEIGHT) of REG) (SETQ LFT (ffetch (REGION LEFT) of REG)) (SETQ BTM (ffetch (REGION BOTTOM) of REG] (* ;; "use a position that is offset by the same amount as the calculated region was from the window's region.") (SETQ POS (create POSITION XCOORD _ (IPLUS (fetch (POSITION XCOORD) of POS) (IDIFFERENCE OLDLEFT LFT)) YCOORD _ (IPLUS (ffetch (POSITION YCOORD) of POS) (IDIFFERENCE OLDBOTTOM BTM] (T (SETQ POS (GETBOXPOSITION OLDWIDTH OLDHEIGHT OLDLEFT OLDBOTTOM] (SETQ OPEN? T))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (ffetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND (OPEN? (* ;; "if window is open, move it to top as its MOVEFN may have changed things and swap its bits to its new location") (.WHILE.TOP.DS. WINDOW (\SW2BM (fetch (SCREEN SCDESTINATION) of OLDSCREEN) OLDREGION (fetch (WINDOW SAVE) of WINDOW) NIL) (\SW2BM (ffetch (WINDOW SAVE) of WINDOW) NIL (ffetch (SCREEN SCDESTINATION) of OLDSCREEN) NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEWDS WINDOW OLDREGION T)) [COND ((AND OPEN? (WINDOWPROP WINDOW 'REPAINTFN) OLDCLIPREGION) (* ;  "redisplay those parts that were off the screen.") (COND ((EQ OLDCLIPREGION T) (* ; "whole window was off.") (REDISPLAYW WINDOW NIL T)) (T (PROG (NEWCLIPPINGREGION NCL OCL NCB OCB OCR NCR OCW NCW OCH NCH OCT NCT) (SETQ NEWCLIPPINGREGION (\ONSCREENCLIPPINGREGION WINDOW)) (* ;  "the title may be the only thing now on the screen.") (OR NEWCLIPPINGREGION (RETURN)) (SETQ NCB (fetch (REGION BOTTOM) of NEWCLIPPINGREGION)) (SETQ OCB (fetch (REGION BOTTOM) of OLDCLIPREGION)) (SETQ OCW (ffetch (REGION WIDTH) of OLDCLIPREGION)) (SETQ NCW (ffetch (REGION WIDTH) of NEWCLIPPINGREGION)) (SETQ OCH (ffetch (REGION HEIGHT) of OLDCLIPREGION)) (SETQ NCH (ffetch (REGION HEIGHT) of NEWCLIPPINGREGION)) [COND ((ILESSP (SETQ NCL (ffetch (REGION LEFT) of NEWCLIPPINGREGION )) (SETQ OCL (ffetch (REGION LEFT) of OLDCLIPREGION))) (REDISPLAYW WINDOW (CREATEREGION NCL OCB (IDIFFERENCE OCL NCL) OCH] [COND ((ILESSP (SETQ OCR (IPLUS OCL OCW)) (SETQ NCR (IPLUS NCL NCW))) (* ;  "some stuff appeared from the right.") (REDISPLAYW WINDOW (CREATEREGION OCR OCB (IDIFFERENCE NCR OCR) OCH] [COND ((ILESSP NCB OCB) (REDISPLAYW WINDOW (CREATEREGION NCL NCB NCW (IDIFFERENCE OCB NCB] [COND ((ILESSP (SETQ OCT (IPLUS OCB OCH)) (SETQ NCT (IPLUS NCB NCH))) (* ;  "some stuff appeared from the top") (REDISPLAYW WINDOW (CREATEREGION NCL OCT NCW (IDIFFERENCE NCT OCT] (COND ((IGREATERP (IPLUS OLDBOTTOM OLDHEIGHT) (fetch (SCREEN SCHEIGHT) of OLDSCREEN)) (* ;  "should reshow the title but don't have any entry for that.") NIL] (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) + +(\MEDW.RELMOVEW +(LAMBDA (SCREEN WINDOW POS) (* ; "Edited 18-Nov-94 13:51 by jds") (* ;; "Move WINDOW by relative DX DY") (PROG ((WINREG (WINDOWPROP WINDOW (QUOTE REGION)))) (MOVEW WINDOW (create POSITION XCOORD _ (IPLUS (fetch (REGION LEFT) of WINREG) (fetch (POSITION XCOORD) of POS)) YCOORD _ (IPLUS (fetch (REGION BOTTOM) of WINREG) (fetch (POSITION YCOORD) of POS)))))) +) + +(\MEDW.SHRINKW [LAMBDA (SCREEN WINDOW TOWHAT ICONPOSITION EXPANDFN) (* ; "Edited 27-Sep-93 10:24 by jds") (* ;; "Create a small WINDOW which acts as an Icon of window. This 'icon window' provides a popup menu which will open the main WINDOW again, and run the function EXPANDFN. TOWHAT can be a BITMAP which will be used to make a WINDOW image, an existing window, or a string which will be printed in TITLE only icon window, or can be an existing window. If TOWHAT is NIL, the TITLE of the main WINDOW is used as the TOWHAT for the icon.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((NOT (OPENWP WINDOW)) (* ;; "if it is not currently open, don't do anything. Maybe something should happen here but I don't understand what --- rrb") NIL) ((WINDOWPROP WINDOW 'ICONFOR) (* ; "This is already an icon!") NIL) ((EQ (DOUSERFNS (WINDOWPROP WINDOW 'SHRINKFN) WINDOW T) 'DON'T) (* ;  "one of the shrinkfns disallowed the shrinkage.") NIL) (T (LET (TITLE ICONW FN ICONISBITMAP) (* ;  "get the icon specification from the window if none is given.") [SETQ ICONW (COND ((type? BITMAP TOWHAT) (* ; "use bitMap to create a WINDOW") [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (CREATEWFROMIMAGE (BITMAPCOPY (SETQ ICONISBITMAP TOWHAT)) (fetch (WINDOW SCREEN) of WINDOW] (* ;  "save the icon on the window so that next time it will shrink to the same thing.") TOWHAT) ((WINDOWP TOWHAT) (* ; "use given WINDOW as icon") (WINDOWPROP WINDOW 'ICON TOWHAT) (* ;  "save the icon on the window so that next time it will shrink to the same thing.") TOWHAT) ((STRINGP TOWHAT) [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (\DTEST (APPLY* DEFAULTICONFN WINDOW TOWHAT ) 'WINDOW] TOWHAT) (T (* ;  "current call doesn't specify an icon window. Look for something on the window.") [SETQ TOWHAT (COND ((SETQ FN (WINDOWPROP WINDOW 'ICONFN)) (* ;  "User fn to create an icon. Can return cached value") (APPLY* FN WINDOW (WINDOWPROP WINDOW 'ICONWINDOW) (POSITIONP ICONPOSITION))) (T (WINDOWPROP WINDOW 'ICON] (COND ((WINDOWP TOWHAT) (* ; "use given WINDOW as icon") TOWHAT) ((type? BITMAP TOWHAT) (* ; "use bitMap to create a WINDOW") (CREATEWFROMIMAGE (BITMAPCOPY (SETQ ICONISBITMAP TOWHAT)) (fetch (WINDOW SCREEN) of WINDOW))) (T (* ;; "Call default icon maker. Note: don't store this as the ICON property, because we want it to be recomputed each time, because, for example, the window's title, from which the icon text is derived, might change. Not a problem for windows that have an ICONFN because then the ICONFN is responsible for keeping it up to date") (\DTEST (APPLY* DEFAULTICONFN WINDOW TOWHAT) 'WINDOW] (WINDOWPROP WINDOW 'ICONWINDOW ICONW) (WINDOWPROP ICONW 'ICONFOR WINDOW) (* ;  "set up so that if icon is closed, main window will be also.") (WINDOWADDFNPROP ICONW 'CLOSEFN (FUNCTION CLOSEMAINWINDOW)) (* ;  "set up so that if main window is opened, icon is closed.") [COND ((EQ (WINDOWPROP ICONW 'BUTTONEVENTFN) 'TOTOPW) (* ;  "if the iconw doesn't have a buttoneventfn, give it one that the middle expands it.") (WINDOWPROP ICONW 'BUTTONEVENTFN (FUNCTION ICONBUTTONEVENTFN] (WINDOWADDFNPROP WINDOW 'OPENFN (FUNCTION CLOSEICONWINDOW)) (WINDOWADDFNPROP ICONW 'MOVEFN (FUNCTION \NOTENEWICONPOSITION)) (AND EXPANDFN (WINDOWADDFNPROP WINDOW 'EXPANDFN EXPANDFN)) (WINDOWPROP ICONW 'DOWINDOWCOMFN (FUNCTION DOICONWINDOWCOM)) [COND [(AND (NEQ ICONPOSITION 'SAME) (OR ICONISBITMAP (POSITIONP ICONPOSITION))) (* ;; "If ICONPOSITION given explicitly, or we derived the icon as a bitmap, need to move it into new position") (MOVEW ICONW (COND ((POSITIONP ICONPOSITION) ICONPOSITION) ((PROG1 [POSITIONP (SETQ ICONPOSITION (WINDOWPROP WINDOW 'ICONPOSITION] (* ;  "leave it in its current location.") )) (T (SETQ ICONPOSITION (ICONPOSITION.FROM.WINDOW WINDOW (WINDOWPROP ICONW 'REGION] (T (SETQ ICONPOSITION (LET [(REG (WINDOWPROP ICONW 'REGION] (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG] (WINDOWPROP WINDOW 'ICONPOSITION ICONPOSITION) (TOTOPW WINDOW T) (* ;; "bring it to the top without callings its totopfns in case the shrinkfns brought another window to the top.") (\CLOSEW1 WINDOW) (OPENW ICONW) ICONW]) + +(\MEDW.EXPANDW [LAMBDA (SCREEN ICONW) (* ; "Edited 27-Sep-93 10:24 by jds") (* ;;; "expands an icon window into its main window.") (PROG ((IW ICONW) MAINWINDOW USEREXPANDFN EXPANDREGION) [COND [(SETQ MAINWINDOW (WINDOWPROP IW 'ICONFOR] ((SETQ IW (WINDOWPROP IW 'ICONWINDOW)) (* ;  "user has passed in the window to expand, not its icon.") (COND ((OPENWP (SETQ MAINWINDOW ICONW)) (* make sure the window is shrunken.) (RETURN ICONW] (COND ([AND MAINWINDOW (NULL (\USERFNISDON'T (SETQ USEREXPANDFN (WINDOWPROP MAINWINDOW 'EXPANDFN] (* ;; "if the main window will open and none of the expandfns stop it, open the main window and Close icon Window") (if (AND (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) (SETQ EXPANDREGION (APPLY* (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) MAINWINDOW))) then (* ;; "there is an EXPANDREGIONFN to calculate a new region to expand into, and it didn't return NIL, so assume EXPANDREGION is a valid region. SHAPE instead of just openning. SHAPEW2 will open the window, ignoring an openfn or doshapefn, but allowing the reshapefns to run.") (\SHAPEW2 MAINWINDOW EXPANDREGION) else (\OPENW1 MAINWINDOW)) (\CLOSEW1 IW) (WINDOWDELPROP MAINWINDOW 'OPENFN 'CLOSEICONWINDOW) (WINDOWDELPROP IW 'CLOSEFN 'CLOSEMAINWINDOW) (* ;  "call the expand functions after the window has been opened.") (DOUSERFNS USEREXPANDFN MAINWINDOW) (* ; "break link from icon to window.") (RETURN (WINDOWPROP IW 'ICONFOR NIL]) + +(\MEDW.SHAPEW [LAMBDA (SCREEN WINDOW NEWREGION) (* ; "Edited 27-Sep-93 10:25 by jds") (* ;; "entry that shapes a window checking the userfns for DON'T and interacting to get a region if necessary. This also checks for a user function to do the actual reshaping. look for a function on windowprop INITCORNERSFN, which will take the window and return the initcorners for the window, to be passed to getregion.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) (* ;  "Start with the minimum allowable size.") [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) ((WINDOWPROP WINDOW 'INITCORNERSFN) (* ;  "There's an INITCORNERSFN. Fire it up and prompt the user for a new shape.") (GETREGION (CAR NEWSIZE) (CDR NEWSIZE) (WINDOWREGION WINDOW '\MEDW.SHAPEW) (fetch (WINDOW NEWREGIONFN) of WINDOW) WINDOW (APPLY* (WINDOWPROP WINDOW 'INITCORNERSFN) WINDOW))) (T (* ;  "Just go prompt the user for a new shape.") (GETREGION (CAR NEWSIZE) (CDR NEWSIZE) (WINDOWREGION WINDOW '\MEDW.SHAPEW) (fetch (WINDOW NEWREGIONFN) of WINDOW) WINDOW] (RETURN (COND ((EQUAL NEWSIZE OLDSIZE) (* ;; "if same size and place as before, do nothing") NIL) ((AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) (* ;; "if same width and height, then optimize to a move") (MOVEW WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE))) (T (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) 'SHAPEW1) WINDOW (COPYALL NEWSIZE]) + +(\MEDW.REDISPLAYW [LAMBDA (SCREEN WINDOW REGION ALWAYSFLG) (* ; "Edited 27-Sep-93 10:26 by jds") (* ;; "calls a repaint function after setting the clipping region of the window to it. If ALWAYSFLG is NIL, it won't redisplay unless there is a window repaintfn.") (PROG ((DSP (fetch (WINDOW DSP) of WINDOW)) REPAINTFN CLIPREG) (COND [(SETQ REPAINTFN (WINDOWPROP WINDOW 'REPAINTFN] (ALWAYSFLG (SETQ REPAINTFN (FUNCTION NILL))) (T (PROMPTPRINT "Window has no REPAINTFN. Can't redisplay.") (RETURN))) (SETQ CLIPREG (DSPCLIPPINGREGION NIL DSP)) (RETURN (COND (REGION [COND ((NOT (SUBREGIONP CLIPREG REGION)) (* ;  "reduce REGION so that it is within the clipping region of the window") (OR (SETQ REGION (INTERSECTREGIONS REGION CLIPREG)) (RETURN] (RESETLST (RESETSAVE NIL (LIST 'DSPCLIPPINGREGION (DSPCLIPPINGREGION REGION DSP ) DSP)) (RESETSAVE NIL (LIST 'DSPXOFFSET (DSPXOFFSET NIL DSP) DSP)) (RESETSAVE NIL (LIST 'DSPYOFFSET (DSPYOFFSET NIL DSP) DSP)) (FILLWITHBACKGROUND WINDOW REGION) (DOUSERFNS2 REPAINTFN WINDOW REGION))) (T (FILLWITHBACKGROUND WINDOW REGION) (DOUSERFNS2 REPAINTFN WINDOW CLIPREG]) + +(\MEDW.BURYW [LAMBDA (SCREEN WINDOW) (* ; "Edited 27-Sep-93 10:26 by jds") (* ;; "HACK: Puts WINDOW at the bottom by putting everything that touches it to the top!") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OVERLAPPINGWINDOWS (ORDERFROMBOTTOMTOTOP (OVERLAPPINGWINDOWS WINDOW))) ABOVEWINDOWS ATWINS) [SETQ ABOVEWINDOWS (REMOVE WINDOW (LDIFFERENCE OVERLAPPINGWINDOWS (SETQ ATWINS ( ALLATTACHEDWINDOWS WINDOW] (* ;; "close them in order from the top. This should be the fastest since they would have to come to the top to be closed anyway.") (for W in (REVERSE OVERLAPPINGWINDOWS) do (\CLOSEW1 W)) (\OPENW1 WINDOW) (* ;  "put attached windows below the other windows.") (for W in ATWINS do (\OPENW1 W)) (* ; "finally open the other windows.") (for W in ABOVEWINDOWS do (\OPENW1 W)) (RETURN WINDOW]) + +(\MEDW.TOTOPW [LAMBDA (SCREEN WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 27-Sep-93 10:27 by jds") (* ;; "user entry to bring a window to the top. Unless NOCALLTOTOPFNFLG is non-NIL, it will call the windows TOTOPFN") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((EQ WINDOW (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW))) (PROGN (* (SETQ \TOPWDS (fetch  (WINDOW DSP) of WINDOW))) NIL)) ((OPENWP WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW)) (\INTERNALTOTOPW WINDOW)) ((OPENW WINDOW) (* ;  "if it is not open, open it and then call the TOTOPFN") (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW))) (T (* ;  "window won't open probably because of DON'T OPENFN") (ERROR "Window won't open; Can't be bring to top." WINDOW))) WINDOW]) + +(\MEDW.DSPCREATE + [LAMBDA (SCREEN DESTINATION OLDSTREAM) (* ; "Edited 28-Dec-93 14:09 by nilsson") + + (* ;; "MEDLEY-WINDOW-SPECIFIC version of DSPCREATE. This is what gets called by dispatch from \GENERIC.DSPCREATE.") + + (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device") + + (LET ([DSTRM (OR OLDSTREAM (create STREAM + USERCLOSEABLE _ NIL + IMAGEDATA _ (create \DISPLAYDATA] + (DESTINATION (OR (BITMAPP (fetch (SCREEN SCDESTINATION) of SCREEN)) + (BITMAPP DESTINATION) + ScreenBitMap))) (* ; + "initial x and y positions are 0 when the data is created.") + (with STREAM DSTRM (SETQ DEVICE (fetch (SCREEN WINFDEV) of SCREEN)) + (SETQ ACCESS 'OUTPUT) + (SETQ STRMBOUTFN (FUNCTION \DSPPRINTCHAR)) + (SETQ OUTCHARFN (FUNCTION \DSPPRINTCHAR)) + (SETQ IMAGEOPS (fetch (SCREEN WINIMAGEOPS) of SCREEN)) + (replace (\DISPLAYDATA DDDestination) of IMAGEDATA with DESTINATION)) + (DSPFONT DEFAULTFONT DSTRM) (* ; + "dspfont can win since the (default) display imageops are filled in the stream") + (DSPDESTINATION DESTINATION DSTRM) (* ; + "dspdestination calls \SFFixFont, which presumes there is a font present.") + (DSPFONT DEFAULTFONT DSTRM) + + (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") + + (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) + DSTRM) + (DSPSOURCETYPE 'INPUT DSTRM) + (DSPOPERATION 'REPLACE DSTRM) (* ; + "called to cause the updating of the bitblt table from the fields initialized earlier.") + DSTRM]) + +(\GENERIC.DSPCREATE + [LAMBDA (DESTINATION OLDDSP) (* ; "Edited 27-Dec-93 13:18 by nilsson") + + (* ;; + "GENERIC version of DSPCREATE. This is installed when WINDOW is loaded by \GENERIC.DSPCREATE.") + + (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device") + + (LET (DSTRM SCREEN) + [COND + [(NULL DESTINATION) + (SETQ DESTINATION ScreenBitMap) + (SETQ SCREEN (for SC in \SCREENS suchthat (EQ DESTINATION + (fetch (SCREEN + SCDESTINATION + ) + of SC] + ((type? SCREEN DESTINATION) + (SETQ SCREEN DESTINATION)) + (T (\DTEST DESTINATION 'BITMAP) + (SETQ SCREEN (for SC in \SCREENS suchthat (EQ DESTINATION + (fetch (SCREEN + SCDESTINATION + ) + of SC] + (COND + (SCREEN (SETQ DSTRM (WINDOWOP 'DSPCREATEFN SCREEN DESTINATION OLDDSP))) + (T + (* ;; "NO SCREEN SPECIFIED, SO THIS IS TO A BITMAP. FILL IT IN:") + + (SETQ DSTRM (create STREAM + USERCLOSEABLE _ NIL + OUTCHARFN _ (FUNCTION \DSPPRINTCHAR) + IMAGEDATA _ (create \DISPLAYDATA) + IMAGEOPS _ \DISPLAYIMAGEOPS + DEVICE _ DisplayFDEV + ACCESS _ 'OUTPUT)) (* ; + "initial x and y positions are 0 when the data is created.") + (DSPFONT DEFAULTFONT DSTRM) (* ; + "dspfont can win since the (default) display imageops are filled in the stream") + (DSPDESTINATION DESTINATION DSTRM) (* ; + "dspdestination calls \SFFixFont, which presumes there is a font present.") + (DSPFONT DEFAULTFONT DSTRM) + + (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") + + (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) + DSTRM) + (DSPSOURCETYPE 'INPUT DSTRM) + (DSPOPERATION 'REPLACE DSTRM) (* ; + "called to cause the updating of the bitblt table from the fields initialized earlier.") + )) + DSTRM]) + +(\MEDW.GETWINDOWPROP [LAMBDA (SCREEN WINDOW PROP) (* ;  "Edited 27-Dec-93 11:41 by sybalsky:mv:envos") (* ;; "gets values from a window. Called by the macro for WINDOWPROP.") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW T)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (SELECTQ PROP (HEIGHT (\GETWINDOWHEIGHT WINDOW)) (WIDTH (* ;  "calculate the width from the REGION in case the user has changed the clipping region.") (\GETWINDOWWIDTH WINDOW)) (RIGHTBUTTONFN (fetch (WINDOW RIGHTBUTTONFN) of WINDOW)) (BUTTONEVENTFN (fetch (WINDOW BUTTONEVENTFN) of WINDOW)) (CURSORINFN (fetch (WINDOW CURSORINFN) of WINDOW)) (CURSOROUTFN (fetch (WINDOW CURSOROUTFN) of WINDOW)) (CURSORMOVEDFN (fetch (WINDOW CURSORMOVEDFN) of WINDOW)) (DSP (fetch (WINDOW DSP) of WINDOW)) (SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (SCROLLFN (fetch (WINDOW SCROLLFN) of WINDOW)) (RESHAPEFN (fetch (WINDOW RESHAPEFN) of WINDOW)) (EXTENT (fetch (WINDOW EXTENT) of WINDOW)) (REPAINTFN (fetch (WINDOW REPAINTFN) of WINDOW)) (MOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) (CLOSEFN (fetch (WINDOW CLOSEFN) of WINDOW)) (WINDOWENTRYFN (fetch (WINDOW WINDOWENTRYFN) of WINDOW)) (PROCESS (fetch (WINDOW PROCESS) of WINDOW)) (REGION (* ;  "make a copy so we don't have to worry about {or document} the user clobbering it.") (fetch (WINDOW REG) of WINDOW)) (NEWREGIONFN (fetch (WINDOW NEWREGIONFN) of WINDOW)) (TITLE (fetch (WINDOW WTITLE) of WINDOW)) (BORDER (fetch (WINDOW WBORDER) of WINDOW)) (IMAGECOVERED (fetch (WINDOW SAVE) of WINDOW)) (GETWINDOWUSERPROP WINDOW PROP]) + +(\MEDW.PUTWINDOWPROP [LAMBDA (SCREEN WINDOW PROP VALUE) (* ;  "Edited 27-Dec-93 11:39 by sybalsky:mv:envos") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (SELECTQ PROP (RIGHTBUTTONFN (PROG1 (fetch (WINDOW RIGHTBUTTONFN) of WINDOW) (replace (WINDOW RIGHTBUTTONFN) of WINDOW with VALUE))) (BUTTONEVENTFN (PROG1 (fetch (WINDOW BUTTONEVENTFN) of WINDOW) (replace (WINDOW BUTTONEVENTFN) of WINDOW with VALUE))) (CLOSEFN (PROG1 (fetch (WINDOW CLOSEFN) of WINDOW) (replace (WINDOW CLOSEFN) of WINDOW with VALUE))) (MOVEFN (PROG1 (fetch (WINDOW MOVEFN) of WINDOW) (replace (WINDOW MOVEFN) of WINDOW with VALUE))) (CURSORINFN (PROG1 (fetch (WINDOW CURSORINFN) of WINDOW) (replace (WINDOW CURSORINFN) of WINDOW with VALUE))) (CURSOROUTFN (PROG1 (fetch (WINDOW CURSOROUTFN) of WINDOW) (replace (WINDOW CURSOROUTFN) of WINDOW with VALUE))) (CURSORMOVEDFN (PROG1 (fetch (WINDOW CURSORMOVEDFN) of WINDOW) (replace (WINDOW CURSORMOVEDFN) of WINDOW with VALUE))) (DSP (ERROR "Can't change DSP of a window" WINDOW)) (SCREEN (ERROR "Can't change SCREEN of a window" WINDOW)) (RESHAPEFN (PROG1 (fetch (WINDOW RESHAPEFN) of WINDOW) (replace (WINDOW RESHAPEFN) of WINDOW with VALUE))) (REPAINTFN (PROG1 (fetch (WINDOW REPAINTFN) of WINDOW) (replace (WINDOW REPAINTFN) of WINDOW with VALUE))) (EXTENT (PROG1 (fetch (WINDOW EXTENT) of WINDOW) (OR (NULL VALUE) (REGIONP VALUE) (\ILLEGAL.ARG VALUE)) (replace (WINDOW EXTENT) of WINDOW with VALUE))) (SCROLLFN (PROG1 (fetch (WINDOW SCROLLFN) of WINDOW) (replace (WINDOW SCROLLFN) of WINDOW with VALUE) (UPDATE/SCROLL/REG WINDOW))) (IMAGECOVERED (ERROR "Not implemented to change IMAGECOVERED property." WINDOW)) (HEIGHT (ERROR "Not implemented to change HEIGHT as property." WINDOW)) (WIDTH (ERROR "Not implemented to change WIDTH as property." WINDOW)) (REGION [PROG (CURREGION) (SETQ CURREGION (WINDOWPROP WINDOW 'REGION)) (COND ((NOT (REGIONP VALUE)) (\ILLEGAL.ARG VALUE))) (* ;; "there is no check for where the new region is nor how big it is; this is left to MOVEW and RESHAPEW.") (COND ((AND (EQ (fetch (REGION WIDTH) of CURREGION) (fetch (REGION WIDTH) of VALUE)) (EQ (fetch (REGION HEIGHT) of CURREGION) (fetch (REGION HEIGHT) of VALUE))) (* ;  "width and height are the same, move the window") (MOVEW WINDOW (fetch (REGION LEFT) of VALUE) (fetch (REGION BOTTOM) of VALUE))) (T (* ; "dimensions changed, reshape it.") (SHAPEW WINDOW VALUE]) (NEWREGIONFN (PROG1 (fetch (WINDOW NEWREGIONFN) of WINDOW) (replace (WINDOW NEWREGIONFN) of WINDOW with VALUE))) (TITLE (PROG1 (fetch (WINDOW WTITLE) of WINDOW) (RESHOWTITLE VALUE WINDOW))) (BORDER (PROG1 (fetch (WINDOW WBORDER) of WINDOW) (COND ((NUMBERP VALUE) (RESHOWBORDER VALUE WINDOW)) (T (\ILLEGAL.ARG VALUE))))) (PROCESS (PROG1 (fetch (WINDOW PROCESS) of WINDOW) (replace (WINDOW PROCESS) of WINDOW with VALUE))) (WINDOWENTRYFN (PROG1 (fetch (WINDOW WINDOWENTRYFN) of WINDOW) (replace (WINDOW WINDOWENTRYFN) of WINDOW with VALUE))) (PROG (OLDDATA OLDVALUE) (SETQ OLDDATA (fetch (WINDOW USERDATA) of WINDOW)) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* Remove the property) (COND ((EQ (CAR OLDDATA) PROP) (replace (WINDOW USERDATA) of WINDOW with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN] OLDVALUE) (VALUE (replace (WINDOW USERDATA) of WINDOW with (LIST PROP VALUE)) (* know old value is NIL) NIL)) (COND ((AND (fetch (WINDOW WTITLE) of WINDOW) (EQ PROP 'WINDOWTITLESHADE)) (* change windowtitleshade.) (RESHOWTITLE (fetch (WINDOW WTITLE) of WINDOW) WINDOW T))))]) + +(\MEDW.CURSOR + [LAMBDA (SCREEN NEWCURSOR INVERTFLG) (* ; "Edited 23-Feb-94 12:16 by sybalsky") + + (* ;; "Installs NEWCURSOR as the cursor and returns the old cursor state. If INVERTFLG is non-NIL, the cursor image is inverted during installation. If NEWCURSOR is NIL, just returns the current cursor state.") + + (DECLARE (GLOBALVARS DEFAULTCURSOR \SOFTCURSORP)) + (PROG (OLDCURSOR) + (SETQ OLDCURSOR \CURRENTCURSOR) + (COND + ((EQ NEWCURSOR T) (* ; + "If NEWCURSOR is T, use the system default cursor.") + (SETQ NEWCURSOR DEFAULTCURSOR))) + (COND + [(\CURSOR-VALID-P NEWCURSOR \SOFTCURSORP) (* ; + "Only install the cursor if it's a real, valid one.") + (\CURSORDOWN) + (\CURSORUP NEWCURSOR INVERTFLG) (* ; + "set after adjustment to avoid confusion about hotspot during adjustment.") + (SETQ \CURSORHOTSPOTX (fetch (CURSOR CUHOTSPOTX) of NEWCURSOR)) + (SETQ \CURSORHOTSPOTY (IDIFFERENCE (SUB1 (fetch (BITMAP BITMAPHEIGHT) + of (fetch (CURSOR CUIMAGE) + of NEWCURSOR))) + (fetch (CURSOR CUHOTSPOTY) of NEWCURSOR] + (NEWCURSOR (* ; "NEWCURSOR = NIL means just return the old one, so only error if one got specified that wasn't valid.") + (\ILLEGAL.ARG NEWCURSOR))) + (RETURN OLDCURSOR]) +) +(DEFINEQ + +(\GENERIC.CURSOR + [LAMBDA (NEWCURSOR INVERTFLG) (* ; "Edited 25-Feb-94 15:07 by sybalsky") + + (* ;; "Installs NEWCURSOR as the cursor and returns the old cursor state. If INVERTFLG is non-NIL, the cursor image is inverted during installation. If NEWCURSOR is NIL, just returns the current cursor state.") + + (COND + [NEWCURSOR (PROG1 \CURRENTCURSOR + (FOR SCREEN IN \SCREENS DO (WINDOWOP 'SETCURSORFN SCREEN NEWCURSOR + INVERTFLG)))] + (T \CURRENTCURSOR]) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +[PUTPROPS WINDOWOP DMACRO (ARGS (LET ((OPNAME (CAR ARGS)) + (METHOD-DEVICE (CADR ARGS)) + (TAIL (CDDR ARGS))) + (COND + [(AND (LISTP OPNAME) + (EQ (CAR OPNAME) + 'QUOTE)) + `(SPREADAPPLY* (fetch (SCREEN ,(CADR OPNAME)) + of ,METHOD-DEVICE) + ,METHOD-DEVICE + ,@TAIL] + (T (ERROR "OPNAME not quoted: " OPNAME] +) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: DONTEVAL@COMPILE DONTEVAL@LOAD DOCOPY + +(CL:UNLESS (EQUAL (GETD 'DSPCREATE) + (GETD '\GENERIC.DSPCREATE)) + (MOVD '\GENERIC.DSPCREATE 'DSPCREATE)) + +(CL:UNLESS (EQUAL (GETD 'CURSOR) + (GETD '\GENERIC.CURSOR)) + (MOVD '\GENERIC.CURSOR 'CURSOR)) +) +(DECLARE%: EVAL@COMPILE DONTCOPY +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LastCursorPosition \LastInWindow WindowMenu BackgroundMenu BackgroundMenuCommands + \LastWindowButtons WWFNS WindowMenuCommands WindowTitleDisplayStream WINDOWTITLEPRINTLEVEL + WBorder \TOPWDS WINDOWBACKGROUNDSHADE BACKGROUNDFNS) +) + +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE + +(RPAQQ MinWindowWidth 26) + +(RPAQQ MinWindowHeight 16) + + +(CONSTANTS (MinWindowWidth 26) + (MinWindowHeight 16)) +) +(DECLARE%: EVAL@COMPILE + +(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 _ '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)) +) + +(/DECLAREDATATYPE 'WINDOW + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER FIXP FIXP WORD WORD POINTER) + '((WINDOW 0 POINTER) + (WINDOW 2 POINTER) + (WINDOW 4 POINTER) + (WINDOW 6 POINTER) + (WINDOW 8 POINTER) + (WINDOW 10 POINTER) + (WINDOW 12 POINTER) + (WINDOW 14 POINTER) + (WINDOW 16 POINTER) + (WINDOW 18 POINTER) + (WINDOW 20 POINTER) + (WINDOW 22 POINTER) + (WINDOW 24 POINTER) + (WINDOW 26 POINTER) + (WINDOW 28 POINTER) + (WINDOW 30 POINTER) + (WINDOW 32 POINTER) + (WINDOW 34 POINTER) + (WINDOW 36 POINTER) + (WINDOW 38 POINTER) + (WINDOW 40 POINTER) + (WINDOW 42 POINTER) + (WINDOW 44 POINTER) + (WINDOW 46 POINTER) + (WINDOW 48 POINTER) + (WINDOW 50 POINTER) + (WINDOW 52 FIXP) + (WINDOW 54 FIXP) + (WINDOW 56 (BITS . 15)) + (WINDOW 57 (BITS . 15)) + (WINDOW 58 POINTER)) + '60) + +(/DECLAREDATATYPE 'SCREEN + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FIXP FIXP + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + '((SCREEN 0 POINTER) + (SCREEN 2 POINTER) + (SCREEN 4 POINTER) + (SCREEN 6 POINTER) + (SCREEN 8 POINTER) + (SCREEN 10 POINTER) + (SCREEN 12 POINTER) + (SCREEN 14 POINTER) + (SCREEN 16 POINTER) + (SCREEN 18 POINTER) + (SCREEN 20 FIXP) + (SCREEN 22 FIXP) + (SCREEN 24 POINTER) + (SCREEN 26 POINTER) + (SCREEN 28 POINTER) + (SCREEN 30 POINTER) + (SCREEN 32 POINTER) + (SCREEN 34 POINTER) + (SCREEN 36 POINTER) + (SCREEN 38 POINTER) + (SCREEN 40 POINTER) + (SCREEN 42 POINTER) + (SCREEN 44 POINTER) + (SCREEN 46 POINTER) + (SCREEN 48 POINTER) + (SCREEN 50 POINTER) + (SCREEN 52 POINTER) + (SCREEN 54 POINTER) + (SCREEN 56 POINTER) + (SCREEN 58 POINTER) + (SCREEN 60 POINTER) + (SCREEN 62 POINTER) + (SCREEN 64 POINTER) + (SCREEN 66 POINTER) + (SCREEN 68 POINTER) + (SCREEN 70 POINTER) + (SCREEN 72 POINTER) + (SCREEN 74 POINTER) + (SCREEN 76 POINTER) + (SCREEN 78 POINTER) + (SCREEN 80 POINTER) + (SCREEN 82 POINTER) + (SCREEN 84 POINTER) + (SCREEN 86 POINTER) + (SCREEN 88 POINTER) + (SCREEN 90 POINTER) + (SCREEN 92 POINTER) + (SCREEN 94 POINTER) + (SCREEN 96 POINTER) + (SCREEN 98 POINTER)) + '100) + +(* "END EXPORTED DEFINITIONS") + +) +(DECLARE%: EVAL@COMPILE +(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS WINDOWUSERFORMS ENDOFWINDOWUSERFORMS PROMPTWINDOW) +) + +(* "END EXPORTED DEFINITIONS") + +) +(ADDTOVAR SYSTEMRECLST + +(DATATYPE WINDOW + (DSP NEXTW SAVE REG BUTTONEVENTFN RIGHTBUTTONFN CURSORINFN CURSOROUTFN CURSORMOVEDFN + REPAINTFN RESHAPEFN EXTENT USERDATA VERTSCROLLREG HORIZSCROLLREG SCROLLFN + VERTSCROLLWINDOW HORIZSCROLLWINDOW CLOSEFN MOVEFN WTITLE NEWREGIONFN WBORDER PROCESS + WINDOWENTRYFN SCREEN (NATIVE-HANDLE FIXP) + (NATIVE-INFO1 FIXP) + (NATIVE-W1 WORD) + (NATIVE-W2 WORD) + (NATIVE-P1 POINTER))) + +(DATATYPE SCREEN + (SCONOFF SCDESTINATION SCWIDTH SCHEIGHT SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA + (HANDLE FIXP) + (HANDLE2 FIXP) + (NATIVE-INFO POINTER) + NATIVETYPE WINIMAGEOPS WINFDEV CREATEWFN OPENWFN CLOSEWFN MOVEWFN RELMOVEWFN + SHRINKWFN EXPANDWFN SHAPEWFN REDISPLAYFN GETWINDOWPROPFN PUTWINDOWPROPFN BURYWFN + TOTOPWFN IMPORTWFN EXPORTWFN DESTROYFN SETCURSORFN PROMPTW SHOWGCFN DSPCREATEFN + BBTTOWIN BBTFROMWIN BBTWINWIN SCCURSOR SCKEYBOARD SCDEPTH SCCLOSEDOWN SCCLOSESCREEN + SCREOPEN SCCARETFLASH SCGETSCREENPOSITION SCGETBOXSCREENPOSITION SCGETSCREENREGION + SCMOVEPOINTER)) +) + +(/DECLAREDATATYPE 'WINDOW + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER FIXP FIXP WORD WORD POINTER) + '((WINDOW 0 POINTER) + (WINDOW 2 POINTER) + (WINDOW 4 POINTER) + (WINDOW 6 POINTER) + (WINDOW 8 POINTER) + (WINDOW 10 POINTER) + (WINDOW 12 POINTER) + (WINDOW 14 POINTER) + (WINDOW 16 POINTER) + (WINDOW 18 POINTER) + (WINDOW 20 POINTER) + (WINDOW 22 POINTER) + (WINDOW 24 POINTER) + (WINDOW 26 POINTER) + (WINDOW 28 POINTER) + (WINDOW 30 POINTER) + (WINDOW 32 POINTER) + (WINDOW 34 POINTER) + (WINDOW 36 POINTER) + (WINDOW 38 POINTER) + (WINDOW 40 POINTER) + (WINDOW 42 POINTER) + (WINDOW 44 POINTER) + (WINDOW 46 POINTER) + (WINDOW 48 POINTER) + (WINDOW 50 POINTER) + (WINDOW 52 FIXP) + (WINDOW 54 FIXP) + (WINDOW 56 (BITS . 15)) + (WINDOW 57 (BITS . 15)) + (WINDOW 58 POINTER)) + '60) + +(/DECLAREDATATYPE 'SCREEN + '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FIXP FIXP + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) + '((SCREEN 0 POINTER) + (SCREEN 2 POINTER) + (SCREEN 4 POINTER) + (SCREEN 6 POINTER) + (SCREEN 8 POINTER) + (SCREEN 10 POINTER) + (SCREEN 12 POINTER) + (SCREEN 14 POINTER) + (SCREEN 16 POINTER) + (SCREEN 18 POINTER) + (SCREEN 20 FIXP) + (SCREEN 22 FIXP) + (SCREEN 24 POINTER) + (SCREEN 26 POINTER) + (SCREEN 28 POINTER) + (SCREEN 30 POINTER) + (SCREEN 32 POINTER) + (SCREEN 34 POINTER) + (SCREEN 36 POINTER) + (SCREEN 38 POINTER) + (SCREEN 40 POINTER) + (SCREEN 42 POINTER) + (SCREEN 44 POINTER) + (SCREEN 46 POINTER) + (SCREEN 48 POINTER) + (SCREEN 50 POINTER) + (SCREEN 52 POINTER) + (SCREEN 54 POINTER) + (SCREEN 56 POINTER) + (SCREEN 58 POINTER) + (SCREEN 60 POINTER) + (SCREEN 62 POINTER) + (SCREEN 64 POINTER) + (SCREEN 66 POINTER) + (SCREEN 68 POINTER) + (SCREEN 70 POINTER) + (SCREEN 72 POINTER) + (SCREEN 74 POINTER) + (SCREEN 76 POINTER) + (SCREEN 78 POINTER) + (SCREEN 80 POINTER) + (SCREEN 82 POINTER) + (SCREEN 84 POINTER) + (SCREEN 86 POINTER) + (SCREEN 88 POINTER) + (SCREEN 90 POINTER) + (SCREEN 92 POINTER) + (SCREEN 94 POINTER) + (SCREEN 96 POINTER) + (SCREEN 98 POINTER)) + '100) + +(RPAQ? WindowMenu ) + +(RPAQ? BackgroundMenu ) + +(RPAQ? \LastCursorPosition (CREATEPOSITION)) + +(RPAQ? \LastInWindow ) + +(RPAQ? \LastWindowButtons 0) + +(RPAQ? WINDOWBACKGROUNDSHADE 34850) + +(RPAQ? WBorder 4) + +(RPAQ? HIGHLIGHTSHADE 32800) + +(RPAQ? WINDOWBACKGROUNDBORDER 34850) + +(FILESLOAD PAINTW) + +(ADDTOVAR WindowMenuCommands (Close '\INTERACTIVE.CLOSEW "Closes a window") + (Snap 'SNAPW "Saves a snapshot of a region of the screen.") + (Paint 'PAINTW + "Starts a painting mode in which the mouse can be +used to draw pictures or make notes on windows.") + (Clear 'CLEARW "Clears a window to its gray.") + (Bury 'BURYW "Puts a window on the bottom.") + (Redisplay 'REDISPLAYW "Redisplays a window using its REPAINTFN.") + (Hardcopy 'HARDCOPYIMAGEW "Prints a window using its HARDCOPYFN." + (SUBITEMS ("To a file" 'HARDCOPYIMAGEW.TOFILE + "Puts image on a file; prompts for filename and format" + ) + ("To a printer" 'HARDCOPYIMAGEW.TOPRINTER + "Sends image to a printer of your choosing"))) + (Move 'MOVEW "Moves a window by a corner.") + (Shape 'SHAPEW "Gets a new region for a window. +Left button down marks fixed corner; sweep to other corner. +Middle button down moves closest corner.") + (Shrink 'SHRINKW + "Replaces this window with its icon (or title if it doesn't have an icon." + )) + +(ADDTOVAR BackgroundMenuCommands (SaveVM '(SAVEVM) + "Updates the virtual memory.") + (Snap '(SNAPW) + "Saves a snapshot of a region of the screen.") + (Hardcopy '(HARDCOPYW) + "Send hardcopy of screen region to printer." + (SUBITEMS ("To a file" '(HARDCOPYREGION.TOFILE) + + "Writes a region of screen to a file; prompts for filename and format" + ) + ("To a printer" '(HARDCOPYREGION.TOPRINTER) + + "Sends a region of screen to a printer of your choosing" + )))) + +(ADDTOVAR WINDOWUSERFORMS ) + +(ADDTOVAR ENDOFWINDOWUSERFORMS ) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(COND + ((NULL \MAINSCREEN) + (SETQ \MAINSCREEN (CREATESCREEN (SCREENBITMAP))) + (SETQ \CURSORSCREEN \MAINSCREEN) + (SETQ LASTSCREEN \MAINSCREEN) + (WINDOWWORLD 'ON \MAINSCREEN T))) + +(MOVD? 'TRUE 'LISPWINDOWP) + + +(RPAQQ \WINDOWWORLD T) +) + + + +(* ;; "Arrange for the proper compiler") + + +(PUTPROPS WINDOW FILETYPE :FAKE-COMPILE-FILE) +(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS + +(ADDTOVAR NLAMA ) + +(ADDTOVAR NLAML ) + +(ADDTOVAR LAMA PROMPTPRINT WINDOWPROP DOWINDOWCOM) +) +(PUTPROPS WINDOW COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991 +1992 1993 1994 1999 2000)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (11575 26185 (WINDOWWORLD 11585 . 15338) (WINDOWWORLDP 15340 . 15640) (CHANGEBACKGROUND +15642 . 16679) (CHANGEBACKGROUNDBORDER 16681 . 17232) (TILE 17234 . 17826) ( +\TTY.CREATING.DISPLAYSTREAM 17828 . 18345) (\CREATE.TTY.OUTCHARFN 18347 . 18647) ( +\CREATE.TTYDISPLAYSTREAM 18649 . 21688) (HASTTYWINDOWP 21690 . 21970) (TTYINFOSTREAM 21972 . 22496) ( +CREATESCREEN 22498 . 25441) (\INSURESCREEN 25443 . 25692) (\BITMAPTOSCREEN 25694 . 26055) (MAINSCREEN +26057 . 26183)) (26844 44127 (WINDOW.MOUSE.HANDLER 26854 . 39649) (\PROTECTED.APPLY 39651 . 39899) ( +DOWINDOWCOM 39901 . 41921) (DOBACKGROUNDCOM 41923 . 43081) (DEFAULT.BACKGROUND.COPYFN 43083 . 44125)) +(44208 76091 (BURYW 44218 . 44506) (CLEARW 44508 . 44898) (CLOSEW 44900 . 45674) (\CLOSEW1 45676 . +46029) (\OKTOCLOSEW 46031 . 46390) (\INTERACTIVE.CLOSEW 46392 . 47215) (OPENW 47217 . 48272) ( +DOUSERFNS 48274 . 49435) (DOUSERFNS2 49437 . 49933) (\USERFNISDON'T 49935 . 50206) (\OPENW1 50208 . +50558) (CREATEW 50560 . 51824) (CREATEW1 51826 . 54104) (\CREATEW1 54106 . 55325) (OPENDISPLAYSTREAM +55327 . 55650) (MOVEW 55652 . 55867) (PPROMPT3 55869 . 56197) (\ONSCREENCLIPPINGREGION 56199 . 56750) +(RELMOVEW 56752 . 57050) (SHAPEW 57052 . 61971) (SHAPEW1 61973 . 64675) (\SHAPEW2 64677 . 67363) ( +RESHOWBORDER 67365 . 67876) (\RESHOWBORDER1 67878 . 72804) (TRACKW 72806 . 73921) (SNAPW 73923 . 75596 +) (WINDOWREGION 75598 . 76089)) (76092 76788 (MINIMUMWINDOWSIZE 76102 . 76786)) (78591 101856 ( +ADVISEWDS 78601 . 86544) (SHOWWFRAME 86546 . 88298) (SHOWWTITLE 88300 . 92334) (\STRINGWIDTHGUESS +92336 . 92695) (RESHOWTITLE 92697 . 97338) (TOTOPW 97340 . 97579) (\INTERNALTOTOPW 97581 . 98671) ( +\TTW1 98673 . 101273) (WHICHW 101275 . 101854)) (101985 104823 (WFROMDS 101995 . 103993) (NU\TOTOPWDS +103995 . 104431) (\COERCETODS 104433 . 104821)) (105468 112268 (WINDOWP 105478 . 105624) ( +INSURE.WINDOW 105626 . 105965) (WINDOWPROP 105967 . 106399) (WINDOWADDPROP 106401 . 108135) ( +WINDOWDELPROP 108137 . 108563) (GETWINDOWPROP 108565 . 109115) (GETWINDOWUSERPROP 109117 . 109544) ( +PUTWINDOWPROP 109546 . 110011) (REMWINDOWPROP 110013 . 111068) (WINDOWADDFNPROP 111070 . 112266)) ( +112472 120036 (CWINDOWPROP 112482 . 113487) (CGETWINDOWPROP 113489 . 118707) (\GETWINDOWHEIGHT 118709 + . 119617) (\GETWINDOWWIDTH 119619 . 120034)) (120037 135485 (OPENWP 120047 . 120325) (TOPWP 120327 . +120610) (RESHAPEBYREPAINTFN 120612 . 130864) (\INBETWEENP 130866 . 131082) ( +DECODE/WINDOW/OR/DISPLAYSTREAM 131084 . 133124) (GROW/REGION 133126 . 133689) (CLRPROMPT 133691 . +134095) (PROMPTPRINT 134097 . 134361) (OPENWINDOWS 134363 . 135147) (\INSUREWINDOW 135149 . 135483)) ( +135616 138865 (OVERLAPPINGWINDOWS 135626 . 137908) (WOVERLAPP 137910 . 138165) (ORDERFROMBOTTOMTOTOP +138167 . 138863)) (138914 143697 (\ONSCREENW 138924 . 139630) (\PUTONSCREENW 139632 . 140459) ( +\UPDATECACHEDFIELDS 140461 . 140725) (\WWCHANGESCREENSIZE 140727 . 142116) (CREATEWFROMIMAGE 142118 . +143081) (UPDATEWFROMIMAGE 143083 . 143695)) (144254 200056 (\MEDW.CREATEW 144264 . 148938) ( +\MEDW.OPENW 148940 . 151298) (\MEDW.CLOSEW 151300 . 152666) (\MEDW.MOVEW 152668 . 163280) ( +\MEDW.RELMOVEW 163282 . 163661) (\MEDW.SHRINKW 163663 . 171847) (\MEDW.EXPANDW 171849 . 174116) ( +\MEDW.SHAPEW 174118 . 178724) (\MEDW.REDISPLAYW 178726 . 180681) (\MEDW.BURYW 180683 . 181965) ( +\MEDW.TOTOPW 181967 . 183315) (\MEDW.DSPCREATE 183317 . 185759) (\GENERIC.DSPCREATE 185761 . 189225) ( +\MEDW.GETWINDOWPROP 189227 . 191465) (\MEDW.PUTWINDOWPROP 191467 . 198252) (\MEDW.CURSOR 198254 . +200054)) (200057 200677 (\GENERIC.CURSOR 200067 . 200675))))) +STOP diff --git a/sources/WINDOWICON b/sources/WINDOWICON new file mode 100644 index 00000000..6a964419 --- /dev/null +++ b/sources/WINDOWICON @@ -0,0 +1,86 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED " 2-Feb-94 13:26:29" {DSK}nilsson>mnw>WINDOWICON.;2 12057 + + changes to%: (FNS SHRINKW EXPANDW) + + previous date%: "29-Sep-93 14:57:05" {DSK}nilsson>mnw>WINDOWICON.;1) + + +(* ; " +Copyright (c) 1986, 1987, 1988, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT WINDOWICONCOMS) + +(RPAQQ WINDOWICONCOMS + ((FNS SHRINKW ICONBUTTONEVENTFN ICONPOSITION.FROM.WINDOW MAKETITLEBARICON \TITLEICONMINSIZE + \NOTENEWICONPOSITION EXPANDW DOICONWINDOWCOM CLOSEMAINWINDOW CLOSEICONWINDOW) + (INITVARS (IconWindowMenu) + (DEFAULTICONFN 'MAKETITLEBARICON)) + (ADDVARS (IconWindowMenuCommands (Close 'CLOSEW "Closes the icon and its associated window") + (Snap 'SNAPW "Saves a snapshot of a region of the screen.") + (Paint 'PAINTW + "Starts a painting mode in which the mouse can +be used to draw pictures or make notes on the icon.") + (Bury 'BURYW "Puts the icon on the bottom.") + (Move 'MOVEW "Moves the icon by a corner.") + (Shape 'SHAPEW "Gets a new region for the icon.") + (Expand 'EXPANDW "Expands the window for which this is the ICON."))) + (GLOBALVARS DEFAULTICONFN IconWindowMenu IconWindowMenuCommands))) +(DEFINEQ + +(SHRINKW + [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN) + (* ; + "Edited 2-Feb-94 13:10 by sybalsky:mv:envos") + (WINDOWOP 'SHRINKWFN (fetch (WINDOW SCREEN) of (SETQ WINDOW (\INSUREWINDOW WINDOW))) + WINDOW TOWHAT ICONPOSITION EXPANDFN]) + +(ICONBUTTONEVENTFN [LAMBDA (ICONW) (* bvm%: "25-Mar-86 17:23") (* * Default icon BUTTONEVENTFN -- middle button expands it, left button moves  it) (COND [(LASTMOUSESTATE MIDDLE) (CURSOR (PROG1 (CURSOR WAITINGCURSOR) (EXPANDW ICONW] (T (MOVEW ICONW]) + +(ICONPOSITION.FROM.WINDOW [LAMBDA (WINDOW ICONREGION) (* bvm%: "18-Mar-86 14:03") (OR (POSITIONP (WINDOWPROP WINDOW 'ICONPOSITION)) (LET ((WREG (WINDOWPROP WINDOW 'REGION)) SCREEN) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (create POSITION XCOORD _ [COND ((ILESSP (fetch (REGION LEFT) of WREG) (IDIFFERENCE (fetch (SCREEN SCWIDTH) of SCREEN) (fetch (REGION PRIGHT) of WREG))) (IMAX 0 (fetch (REGION LEFT) of WREG))) (T (IDIFFERENCE (IMIN (fetch (SCREEN SCWIDTH) of SCREEN) (fetch (REGION PRIGHT) of WREG)) (fetch (REGION WIDTH) of ICONREGION] YCOORD _ (COND ((ILESSP (fetch (REGION BOTTOM) of WREG) (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) (fetch (REGION PTOP) of WREG))) (IMAX 0 (fetch (REGION BOTTOM) of WREG))) (T (IDIFFERENCE (IMIN (fetch (SCREEN SCHEIGHT) of SCREEN) (fetch (REGION PTOP) of WREG)) (fetch (REGION HEIGHT) of ICONREGION]) + +(MAKETITLEBARICON [LAMBDA (WINDOW TEXT) (* bvm%: "18-Mar-86 14:04") (* * Make a "title bar" icon consisting of TEXT or WINDOW's TITLE if TEXT is  NIL) (PROG ((SCREEN (fetch (WINDOW SCREEN) of WINDOW)) W REG POS) [COND ((AND (NULL TEXT) (OR [NULL (SETQ TEXT (WINDOWPROP WINDOW 'TITLE] (EQ (NCHARS TEXT) 0))) (SETQ TEXT (CONCAT "Icon made " (DATE] [SETQ POS (ICONPOSITION.FROM.WINDOW WINDOW (SETQ REG (create REGION LEFT _ 0 BOTTOM _ 0 HEIGHT _ (IMINUS (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS ) of SCREEN))) WIDTH _ (IMAX MinWindowWidth (IPLUS 8 (STRINGWIDTH TEXT (fetch (SCREEN SCTITLEDS) of SCREEN] (* Position the icon near the current location of the window) (replace (REGION LEFT) of REG with (fetch (POSITION XCOORD) of POS)) (replace (REGION BOTTOM) of REG with (fetch (POSITION YCOORD) of POS)) (SETQ W (CREATEW REG TEXT NIL T)) (WINDOWPROP W 'MINSIZE (FUNCTION \TITLEICONMINSIZE)) (RETURN W]) + +(\TITLEICONMINSIZE [LAMBDA (WINDOW) (* kbr%: "29-Mar-85 14:14") (* returns the minimum size the  default icon can be.) (CONS MinWindowWidth (IMINUS (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW]) + +(\NOTENEWICONPOSITION [LAMBDA (ICONW NEWPOS) (* rrb "13-Jan-84 10:39") (* saves the new position of the icon on the property list so that the icon  will come up there again.) (AND (SETQ ICONW (WINDOWPROP ICONW 'ICONFOR)) (WINDOWPROP ICONW 'ICONPOSITION NEWPOS)) NEWPOS]) + +(EXPANDW + [LAMBDA (ICONW) (* ; + "Edited 2-Feb-94 13:10 by sybalsky:mv:envos") + (WINDOWOP 'EXPANDWFN (fetch (WINDOW SCREEN) of (SETQ ICONW (\INSUREWINDOW ICONW))) + ICONW]) + +(DOICONWINDOWCOM [LAMBDA (WINDOW) (* rrb " 7-AUG-83 18:52") (* the button handler for an ICON window Test for non-NIL WINDOW means that  caller needn't worry about whether the mouse is pointing at a window.) (AND (type? WINDOW WINDOW) (PROG (COM) (TOTOPW WINDOW) (RETURN (COND ((SETQ COM (MENU [COND ((TYPENAMEP IconWindowMenu 'MENU) IconWindowMenu) ((SETQ IconWindowMenu (create MENU ITEMS _ IconWindowMenuCommands CHANGEOFFSETFLG _ 'Y MENUOFFSET _ (create POSITION XCOORD _ -1 YCOORD _ 0) WHENHELDFN _ (FUNCTION PPROMPT3) WHENUNHELDFN _ (FUNCTION CLRPROMPT) CENTERFLG _ T] IconWindowMenu)) (APPLY* COM WINDOW) T]) + +(CLOSEMAINWINDOW [LAMBDA (ICONWIN) (* rrb "28-JUN-83 11:58") (* the closefn for an icon window that closes the main window as well.) (PROG [(MAINWIN (WINDOWPROP ICONWIN 'ICONFOR] [COND (MAINWIN (COND ((NULL (\OKTOCLOSEW MAINWIN)) (* Call the main windows closefns. If main window won't close, don't close the  icon. The main window has already been removed from the window stack but its  closefns haven't been executed.) (RETURN 'DON'T)) (T (* closefns for main window may have opened it for example by printing to it.  Close it if it is open.) (AND (OPENWP MAINWIN) (\CLOSEW1 MAINWIN] (* break link between the icon and the main window.  This may give problems if someone holds onto the icon window and explicitly  reopens it and expects it to still be an icon.) (WINDOWPROP ICONWIN 'ICONFOR NIL) (RETURN NIL]) + +(CLOSEICONWINDOW [LAMBDA (MAINWIN) (* rrb " 1-May-85 15:55") (* the open function for a window which has an icon.  It closes the (icon and does the expandfns)) (PROG ((ICONW (WINDOWPROP MAINWIN 'ICONWINDOW)) USEREXPANDFN) (* this code duplicates much of EXPANDW but I couldn't quite get it to be a  call because EXPANDW opens the main window which in this case is already open.) (COND (ICONW (* Don't die if user removed the  ICONWINDOW prop) (WINDOWDELPROP ICONW 'CLOSEFN 'CLOSEMAINWINDOW) (* remove the mainwindowclosing  function first.) (CLOSEW ICONW) (DOUSERFNS (WINDOWPROP MAINWIN 'EXPANDFN) MAINWIN) (* break link from icon to main  window.) (WINDOWPROP ICONW 'ICONFOR NIL))) (* remove icon closing function.) (WINDOWDELPROP MAINWIN 'OPENFN 'CLOSEICONWINDOW]) +) + +(RPAQ? IconWindowMenu ) + +(RPAQ? DEFAULTICONFN 'MAKETITLEBARICON) + +(ADDTOVAR IconWindowMenuCommands + (Close 'CLOSEW "Closes the icon and its associated window") + (Snap 'SNAPW "Saves a snapshot of a region of the screen.") + (Paint 'PAINTW + "Starts a painting mode in which the mouse can +be used to draw pictures or make notes on the icon.") + (Bury 'BURYW "Puts the icon on the bottom.") + (Move 'MOVEW "Moves the icon by a corner.") + (Shape 'SHAPEW "Gets a new region for the icon.") + (Expand 'EXPANDW "Expands the window for which this is the ICON.")) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS DEFAULTICONFN IconWindowMenu IconWindowMenuCommands) +) +(PUTPROPS WINDOWICON COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (1431 11211 (SHRINKW 1441 . 1810) (ICONBUTTONEVENTFN 1812 . 2211) ( +ICONPOSITION.FROM.WINDOW 2213 . 3889) (MAKETITLEBARICON 3891 . 5840) (\TITLEICONMINSIZE 5842 . 6329) ( +\NOTENEWICONPOSITION 6331 . 6708) (EXPANDW 6710 . 6995) (DOICONWINDOWCOM 6997 . 8582) (CLOSEMAINWINDOW + 8584 . 9807) (CLOSEICONWINDOW 9809 . 11209))))) +STOP diff --git a/sources/WINDOWOBJ b/sources/WINDOWOBJ new file mode 100644 index 00000000..24ef2df9 --- /dev/null +++ b/sources/WINDOWOBJ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 11:26:14" {DSK}lde>lispcore>sources>WINDOWOBJ.;3 27891 changes to%: (RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX) previous date%: " 5-Jan-93 09:53:15" {DSK}lde>lispcore>sources>WINDOWOBJ.;2) (* ; " Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT WINDOWOBJCOMS) (RPAQQ WINDOWOBJCOMS [(COMS (* ;  "Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.") (RECORDS IMAGEOBJ IMAGEFNS IMAGEBOX) (FNS COPYINSERT IMAGEBOX IMAGEFNSCREATE IMAGEFNSP IMAGEOBJCREATE IMAGEOBJP IMAGEOBJPROP \IMAGEUSERPROP HPRINT.IMAGEOBJ COPYIMAGEOBJ READIMAGEOBJ WRITEIMAGEOBJ) (ADDVARS (HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ))) (GLOBALVARS (IMAGEOBJTYPES NIL) (IMAGEOBJGETFNS NIL))) (COMS (* ;  "For encapsulating unknown-type IMAGEOBJs.") (FNS ENCAPSULATEDOBJ.BUTTONEVENTINFN ENCAPSULATEDOBJ.PUTFN ENCAPSULATEDOBJ.DISPLAYFN ENCAPSULATEDOBJ.IMAGEBOXFN ENCAPSULATEDIMAGEFNS) (INITVARS ENCAPSULATEDIMAGEFNS) (GLOBALVARS ENCAPSULATEDIMAGEFNS)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA IMAGEOBJPROP]) (* ; "Image object support - here so that DEDIT can use it without needing TEDIT to be loaded.") (DECLARE%: EVAL@COMPILE (DATATYPE IMAGEOBJ (OBJECTDATUM IMAGEOBJPLIST IMAGEOBJFNS) (SYSTEM)) (DATATYPE IMAGEFNS (DISPLAYFN (* ;  "FN called to display the object's image") IMAGEBOXFN (* ; "To tell how big it is") PUTFN (* ; "To write it onto a file") GETFN (* ; "To read it back from the file") COPYFN (* ; "To make a copy of the object") BUTTONEVENTINFN (* ;  "Called when the mouse goes down over the object") COPYBUTTONEVENTINFN (* ;  "Called when the MIDDLE mouse button goes down over the object") WHENMOVEDFN (* ;  "Called when the object is moved within a document or other environment") WHENINSERTEDFN (* ;  "Called when the object is inserted into a context") WHENDELETEDFN (* ;  "Called when the object is removed from a context") WHENCOPIEDFN (* ;  "Called when the object is copied within a context") WHENOPERATEDONFN (* ;  "Called when something interesting happens to the object") PREPRINTFN IMAGECLASSNAME (* ;  "LITATOM unique name by which this kind of IMAGEOBJ is to be known to the world.") ) (SYSTEM)) (RECORD IMAGEBOX (XSIZE YSIZE YDESC XKERN) (SYSTEM)) ) (/DECLAREDATATYPE 'IMAGEOBJ '(POINTER POINTER POINTER) '((IMAGEOBJ 0 POINTER) (IMAGEOBJ 2 POINTER) (IMAGEOBJ 4 POINTER)) '6) (/DECLAREDATATYPE 'IMAGEFNS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((IMAGEFNS 0 POINTER) (IMAGEFNS 2 POINTER) (IMAGEFNS 4 POINTER) (IMAGEFNS 6 POINTER) (IMAGEFNS 8 POINTER) (IMAGEFNS 10 POINTER) (IMAGEFNS 12 POINTER) (IMAGEFNS 14 POINTER) (IMAGEFNS 16 POINTER) (IMAGEFNS 18 POINTER) (IMAGEFNS 20 POINTER) (IMAGEFNS 22 POINTER) (IMAGEFNS 24 POINTER) (IMAGEFNS 26 POINTER)) '28) (DEFINEQ (COPYINSERT [LAMBDA (IMAGEOBJ) (* ; "Edited 17-Sep-90 13:19 by jds") (* ;;; "inserts IMAGEOBJ into the window that currently has the tty. If this window has a COPYINSERTFN property, that is called, otherwise BKSYSBUF is called.") (PROG ([TTYW (\INSUREWINDOW (WFROMDS (PROCESS.TTY (TTY.PROCESS] INSERTFN) (COND ((SETQ INSERTFN (WINDOWPROP TTYW 'COPYINSERTFN)) (APPLY* INSERTFN IMAGEOBJ TTYW)) (T (* ;  "IMAGEOBJ can be a list of things too.") (for IMOBJ inside IMAGEOBJ do (BKSYSBUF (OR (COND [(IMAGEOBJP IMOBJ) (COND ((SETQ INSERTFN (IMAGEOBJPROP IMOBJ 'PREPRINTFN)) (APPLY* INSERTFN IMOBJ)) (T (IMAGEOBJPROP IMOBJ 'OBJECTDATUM] (T IMOBJ)) "") T (PROCESS.EVAL (TTY.PROCESS) '(GETREADTABLE) T]) (IMAGEBOX [LAMBDA (OBJ STREAM MODE) (* jds " 8-Feb-84 10:48") (APPLY* (IMAGEOBJPROP OBJ 'IMAGEBOXFN) OBJ STREAM MODE]) (IMAGEFNSCREATE [LAMBDA (DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN CLASSNAME) (* jds "19-Feb-85 09:33") (* ;; "returns a structure which contains the image functions for a type of image object.") [COND (GETFN (* ;; "If a GETFN was specified, add it to the list of known GETFNs, so that people who verify them will know about it.") (OR (ASSOC GETFN IMAGEOBJGETFNS) (push IMAGEOBJGETFNS (LIST GETFN] (create IMAGEFNS DISPLAYFN _ DISPLAYFN IMAGEBOXFN _ IMAGEBOXFN PUTFN _ PUTFN GETFN _ GETFN COPYFN _ COPYFN BUTTONEVENTINFN _ BUTTONEVENTINFN COPYBUTTONEVENTINFN _ COPYBUTTONEVENTINFN WHENMOVEDFN _ WHENMOVEDFN WHENINSERTEDFN _ WHENINSERTEDFN WHENDELETEDFN _ WHENDELETEDFN WHENCOPIEDFN _ WHENCOPIEDFN WHENOPERATEDONFN _ WHENOPERATEDONFN PREPRINTFN _ PREPRINTFN]) (IMAGEFNSP [LAMBDA (X) (* rrb " 1-Feb-84 11:13") (* ; "is X an IMAGEFNS?") (AND (type? IMAGEFNS X) X]) (IMAGEOBJCREATE [LAMBDA (OBJECTDATUM IMAGEFNS) (* jds " 8-Feb-84 10:20") (* ; "returns an image object") (OR (IMAGEFNSP IMAGEFNS) (\ILLEGAL.ARG IMAGEFNS)) (* ;  "Make sure he handed us a valid set of fn references") (create IMAGEOBJ OBJECTDATUM _ OBJECTDATUM IMAGEOBJPLIST _ NIL IMAGEOBJFNS _ IMAGEFNS]) (IMAGEOBJP [LAMBDA (X) (* rrb " 1-Feb-84 16:22") (* ; "is X an IMAGEOBJ?") (AND (type? IMAGEOBJ X) X]) (IMAGEOBJPROP [LAMBDA NARGS (* jds "18-Feb-85 18:22") (* ;; "accesses and sets properties of an IMAGEOBJ.") (SELECTQ NARGS ((0 1) (\ILLEGAL.ARG NIL)) (PROG ((IMAGEOBJ (ARG NARGS 1)) (PROP (ARG NARGS 2)) (VAL (AND (IGREATERP NARGS 2) (ARG NARGS 3))) (SET? (NEQ NARGS 2)) IMAGEFNS) (COND ((NOT (IMAGEOBJP IMAGEOBJ)) (\ILLEGAL.ARG IMAGEOBJ))) (SETQ IMAGEFNS (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) (RETURN (SELECTQ PROP (OBJECTDATUM (PROG1 (fetch (IMAGEOBJ OBJECTDATUM) of IMAGEOBJ) (COND (SET? (replace (IMAGEOBJ OBJECTDATUM) of IMAGEOBJ with VAL))))) (DISPLAYFN (PROG1 (fetch (IMAGEFNS DISPLAYFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS DISPLAYFN) of IMAGEFNS with VAL))))) (IMAGEBOXFN (PROG1 (fetch (IMAGEFNS IMAGEBOXFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS IMAGEBOXFN) of IMAGEFNS with VAL))))) (PUTFN (PROG1 (fetch (IMAGEFNS PUTFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS PUTFN) of IMAGEFNS with VAL))))) (GETFN (PROG1 (fetch (IMAGEFNS GETFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS GETFN) of IMAGEFNS with VAL))))) (COPYFN (PROG1 (fetch (IMAGEFNS COPYFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS COPYFN) of IMAGEFNS with VAL))))) (BUTTONEVENTINFN (PROG1 (fetch (IMAGEFNS BUTTONEVENTINFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS BUTTONEVENTINFN) of IMAGEFNS with VAL))))) (COPYBUTTONEVENTINFN (PROG1 (fetch (IMAGEFNS COPYBUTTONEVENTINFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS COPYBUTTONEVENTINFN) of IMAGEFNS with VAL))))) (WHENMOVEDFN (PROG1 (fetch (IMAGEFNS WHENMOVEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENMOVEDFN) of IMAGEFNS with VAL))))) (WHENINSERTEDFN (PROG1 (fetch (IMAGEFNS WHENINSERTEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENINSERTEDFN) of IMAGEFNS with VAL))))) (WHENDELETEDFN (PROG1 (fetch (IMAGEFNS WHENDELETEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENDELETEDFN) of IMAGEFNS with VAL))))) (WHENCOPIEDFN (PROG1 (fetch (IMAGEFNS WHENCOPIEDFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENCOPIEDFN) of IMAGEFNS with VAL))))) (WHENOPERATEDONFN (PROG1 (fetch (IMAGEFNS WHENOPERATEDONFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS WHENOPERATEDONFN) of IMAGEFNS with VAL))))) (PREPRINTFN (PROG1 (fetch (IMAGEFNS PREPRINTFN) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS PREPRINTFN) of IMAGEFNS with VAL))))) (IMAGECLASSNAME (PROG1 (fetch (IMAGEFNS IMAGECLASSNAME) of IMAGEFNS) (COND (SET? (replace (IMAGEFNS IMAGECLASSNAME) of IMAGEFNS with VAL))))) (\IMAGEUSERPROP IMAGEOBJ PROP VAL SET?]) (\IMAGEUSERPROP [LAMBDA (IMAGEOBJ PROP VAL SET?) (* rrb " 1-Feb-84 11:44") (* ;; "reads and sets the values of properties on an IMAGEOBJ") (PROG ((PLIST (fetch (IMAGEOBJ IMAGEOBJPLIST) of IMAGEOBJ))) (RETURN (PROG1 (LISTGET PLIST PROP) [COND (SET? (COND (PLIST (LISTPUT PLIST PROP VAL)) (T (replace (IMAGEOBJ IMAGEOBJPLIST) of IMAGEOBJ with (LIST PROP VAL])]) (HPRINT.IMAGEOBJ [LAMBDA (IMAGEOBJ STREAM) (* rrb "19-Dec-84 16:22") (* ;; "HPRINT function for writing out IMAGE OBJECTS") (* ;; "write out the name of the function to read things back in with.") (PRIN2 (LIST (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ ))) STREAM HPRINTRDTBL) (APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) IMAGEOBJ STREAM) T]) (COPYIMAGEOBJ [LAMBDA (FROM TO) (* jds "19-Feb-85 09:59") (* ;; "Copis the contents of one IMAGEOBJ nto another, effectively making TO be the same object as FROM.") (replace (IMAGEOBJ OBJECTDATUM) of TO with (fetch (IMAGEOBJ OBJECTDATUM) of FROM)) (replace (IMAGEOBJ IMAGEOBJPLIST) of TO with (fetch (IMAGEOBJ IMAGEOBJPLIST) of FROM)) (replace (IMAGEOBJ IMAGEOBJFNS) of TO with (fetch (IMAGEOBJ IMAGEOBJFNS) of FROM]) (READIMAGEOBJ [LAMBDA (STREAM GETFN NOERROR DATANBYTES) (* rrb "18-Mar-86 11:35") (DECLARE (SPECVARS UNDERREADIMAGEOBJ)) (* ;; "Reads an IMAGEOBJ, using GETFN. Verifies that the GETFN is legitimate") (* ;; "the variable UNDERREADIMAGEOBJ is used in HVBAKREAD to determine if it should do a validity check on the function which is read from the file.") (LET* ((ENTRY (ASSOC GETFN IMAGEOBJGETFNS)) (SUPPORTFILE (LISTGET (CDR ENTRY) 'FILE)) (UNDERREADIMAGEOBJ T)) [COND ((OR (NOT GETFN) (NOT (GETD GETFN)) (NOT ENTRY)) (* ;; "This function wasn't specified in the IMAGEOBJTYPES list, or isn't defined. Try loading the support file.") (COND ((AND SUPPORTFILE (MOUSECONFIRM (CONCAT "Trying to read an IMAGEOBJ with GETFN " GETFN ". Shall I load the support file, " SUPPORTFILE "?") NIL NIL NIL)) (* ;  "Ask if the user wants to load the support file.") (DOFILESLOAD (LIST SUPPORTFILE)) (* ; "LOAD the file") ] (COND [(OR (NOT GETFN) (NOT (GETD GETFN)) (NOT (ASSOC GETFN IMAGEOBJGETFNS))) (* ;  "Still no support for this kind of IMAGEOBJ. Encapsulate it in something safe.") (COND (NOERROR (* ;  "The caller doesn't want errors if there's a failure.") NIL) (T (LET* [(OBJ (IMAGEOBJCREATE NIL (ENCAPSULATEDIMAGEFNS GETFN] (* ; "Build an ENCAPSULATED imageobj.") (IMAGEOBJPROP OBJ 'FILE (FULLNAME STREAM) STREAM) (* ;  "Remember which file it came from so that it could be written back out.") (IMAGEOBJPROP OBJ 'FILEPTR (GETFILEPTR STREAM)) (IMAGEOBJPROP OBJ 'OBJSIZE DATANBYTES) (* ; "And where on the file") (IMAGEOBJPROP OBJ 'UNKNOWNGETFN GETFN) (AND DATANBYTES (SETFILEPTR STREAM (PLUS (GETFILEPTR STREAM) DATANBYTES))) (* ; "And the name of its GETFN") OBJ] (T (APPLY* GETFN STREAM]) (WRITEIMAGEOBJ [LAMBDA (IMAGEOBJ STREAM) (* jds "19-Feb-85 09:36") (* ;; "HPRINT function for writing out IMAGE OBJECTS") (* ;; "write out the name of the function to read things back in with.") (COND ((NOT (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ))) (* ;  "This IMAGEOBJ has no GETFN. Complain!") (HELP "No GETFN for IMAGEOBJ " IMAGEOBJ))) (PRIN2 [LIST 'READIMAGEOBJ NIL (KWOTE (fetch (IMAGEFNS GETFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ] STREAM HPRINTRDTBL) (* ;  "Write out a call to READIMAGEOBJ, which takes the input stream and a GETFN name as arguments.") (APPLY* (fetch (IMAGEFNS PUTFN) of (fetch (IMAGEOBJ IMAGEOBJFNS) of IMAGEOBJ)) IMAGEOBJ STREAM) (* ;  "Then write out the guts of the IMAGEOBJ itself.") T]) ) (ADDTOVAR HPRINTMACROS (IMAGEOBJ . WRITEIMAGEOBJ)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS (IMAGEOBJTYPES NIL) (IMAGEOBJGETFNS NIL)) ) (* ; "For encapsulating unknown-type IMAGEOBJs.") (DEFINEQ (ENCAPSULATEDOBJ.BUTTONEVENTINFN [LAMBDA (IMAGEOBJ WINDOW) (* ; "Edited 2-Apr-87 15:33 by bvm:") (* ;;; "The user hit a button inside this object. Try loading it now.") (CL:WITH-OPEN-FILE (STREAM (IMAGEOBJPROP IMAGEOBJ 'FILE)) (SETFILEPTR STREAM (IMAGEOBJPROP IMAGEOBJ 'FILEPTR)) (* ;  "Move to where the IMAGEOBJ's description started in the file we read it from") (LET [(OBJ (READIMAGEOBJ STREAM (IMAGEOBJPROP IMAGEOBJ 'UNKNOWNGETFN) T (IMAGEOBJPROP IMAGEOBJ 'ENDOFOBJFILEPTR] (COND (OBJ (* ;  "We succeeded in reading the object this time. Copy its guts over the placeholder.") (COPYIMAGEOBJ OBJ IMAGEOBJ) 'CHANGED) (T (PRIN1 "Still no support for this image object." (GETPROMPTWINDOW WINDOW)) NIL]) (ENCAPSULATEDOBJ.PUTFN [LAMBDA (IMAGEOBJ STREAM) (* ; "Edited 24-Aug-91 14:57 by jds") (* ;;; "image object put function for unknown image objects. It copies the bytes from the source file to the output file if the range of the object is known. If not, it errors because nothing else I could think of makes sense. Since the name of the GETFN has already been written out and we don't know what format it is expecting we can't write out anything that wouldn't cause an error when read in so erroring now is better.") (PROG ((DATANBYTES (IMAGEOBJPROP IMAGEOBJ 'OBJSIZE)) (FILE (IMAGEOBJPROP IMAGEOBJ 'FILE)) (BEGOFOBJ (IMAGEOBJPROP IMAGEOBJ 'FILEPTR)) INSTREAM) (OR (NUMBERP DATANBYTES) (ERROR "No length information for this image object. Either delete this image object or load its support files." IMAGEOBJ) (RETURN)) (CL:WITH-OPEN-STREAM (INSTREAM (OPENSTREAM FILE 'INPUT)) (COPYBYTES INSTREAM STREAM BEGOFOBJ (PLUS BEGOFOBJ DATANBYTES))) T]) (ENCAPSULATEDOBJ.DISPLAYFN [LAMBDA (OBJ STREAM) (* jds "19-Feb-85 10:37") (* ;; "Display function for an IMAGEOBJ that has been encapsulated for safety") (* ;;  "Displays as a box containing text saying 'Unknown IMAGEOBJ type' , and naming the unknown GETFN.") (LET* ((CURX (DSPXPOSITION NIL STREAM)) (CURY (DSPYPOSITION NIL STREAM)) (FONT (FONTCREATE 'HELVETICA 8 'BOLD NIL STREAM)) (OLDFONT (DSPFONT FONT STREAM)) (GETFN (IMAGEOBJPROP OBJ 'UNKNOWNGETFN)) (TYPE (IMAGEOBJPROP OBJ 'TYPE)) (OBJBOX (IMAGEOBJPROP OBJ 'BOUNDBOX)) (XSIZE (IDIFFERENCE (fetch XSIZE of OBJBOX) 4)) (YSIZE (IDIFFERENCE (fetch YSIZE of OBJBOX) 4))) (RELMOVETO 3 (IPLUS (FONTPROP FONT 'HEIGHT) 3) STREAM) (PRIN1 "Unknown IMAGEOBJ type" STREAM) (MOVETO (IPLUS CURX 3) (IPLUS CURY 3) STREAM) (printout STREAM "GETFN: " GETFN) (MOVETO CURX (IDIFFERENCE CURY (fetch YDESC of OBJBOX)) STREAM) (RELDRAWTO XSIZE 0 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO 0 YSIZE 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO (IMINUS XSIZE) 0 2 'PAINT STREAM NIL '(16 8 8 8)) (RELDRAWTO 0 (IMINUS YSIZE) 2 'PAINT STREAM NIL '(16 8 8 8)) (DSPFONT OLDFONT STREAM]) (ENCAPSULATEDOBJ.IMAGEBOXFN [LAMBDA (OBJ STREAM) (* jds "19-Feb-85 10:05") (* ;  "IMAGEOBXFN for an encapsulated IMAGEOBJ") (PROG ((FONT (FONTCREATE 'HELVETICA 8 'BOLD NIL STREAM)) (GETFN (IMAGEOBJPROP OBJ 'UNKNOWNGETFN)) WIDTH HEIGHT) [SETQ HEIGHT (ITIMES 2 (FONTPROP FONT 'HEIGHT] (SETQ WIDTH (IMAX (STRINGWIDTH "Unknown IMAGEOBJ type" FONT) (STRINGWIDTH (CONCAT "GETFN: " GETFN) FONT))) (RETURN (create IMAGEBOX XSIZE _ (IPLUS WIDTH 6) YSIZE _ (IPLUS HEIGHT 6) YDESC _ 0 XKERN _ 0]) (ENCAPSULATEDIMAGEFNS [LAMBDA (GETFN) (* rrb " 3-Feb-86 18:31") (* ;;; "Set up the IMAGEFNS for the encapsulated-IMAGEOBJ type: The way to protect TEdit and friends from unfriendly IMAGEOBJs. The GETFN is used as the GETFN for the imagefns so that is can be written out. The imagefns are cached so that a new set doesn't have to be created for each instance of an unknown image object type.") (OR (CDR (ASSOC GETFN ENCAPSULATEDIMAGEFNS)) (PROG [(IMAGEFNS (IMAGEFNSCREATE (FUNCTION ENCAPSULATEDOBJ.DISPLAYFN) (FUNCTION ENCAPSULATEDOBJ.IMAGEBOXFN) (FUNCTION ENCAPSULATEDOBJ.PUTFN) GETFN (FUNCTION NIL) (FUNCTION ENCAPSULATEDOBJ.BUTTONEVENTINFN) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL) (FUNCTION NILL] (SETQ ENCAPSULATEDIMAGEFNS (CONS (CONS GETFN IMAGEFNS) ENCAPSULATEDIMAGEFNS)) (RETURN IMAGEFNS]) ) (RPAQ? ENCAPSULATEDIMAGEFNS NIL) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ENCAPSULATEDIMAGEFNS) ) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA IMAGEOBJPROP) ) (PUTPROPS WINDOWOBJ COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (5088 21106 (COPYINSERT 5098 . 6542) (IMAGEBOX 6544 . 6724) (IMAGEFNSCREATE 6726 . 7921) (IMAGEFNSP 7923 . 8164) (IMAGEOBJCREATE 8166 . 8711) (IMAGEOBJP 8713 . 8954) (IMAGEOBJPROP 8956 . 14848) (\IMAGEUSERPROP 14850 . 15444) (HPRINT.IMAGEOBJ 15446 . 16035) (COPYIMAGEOBJ 16037 . 16780) ( READIMAGEOBJ 16782 . 19752) (WRITEIMAGEOBJ 19754 . 21104)) (21320 27527 ( ENCAPSULATEDOBJ.BUTTONEVENTINFN 21330 . 22466) (ENCAPSULATEDOBJ.PUTFN 22468 . 23583) ( ENCAPSULATEDOBJ.DISPLAYFN 23585 . 25198) (ENCAPSULATEDOBJ.IMAGEBOXFN 25200 . 26088) ( ENCAPSULATEDIMAGEFNS 26090 . 27525))))) STOP \ No newline at end of file diff --git a/sources/WINDOWSCROLL b/sources/WINDOWSCROLL new file mode 100644 index 00000000..f874f61c --- /dev/null +++ b/sources/WINDOWSCROLL @@ -0,0 +1,913 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "16-Feb-94 12:36:43" {DSK}nilsson>mnw>WINDOWSCROLL.;1 54529 + + changes to%: (FNS SCROLLW SCROLLBYREPAINTFN ADJUSTOFFSETS CREATESCROLLINGW IN/SCROLL/BAR? + RELDSPXOFFSET RELDSPYOFFSET SCROLL.HANDLER \SCROLL.HANDLER.DOIT + \DECODE.EXTENT.USE \UPDATE.EXTENT.IMAGE EXTENDPASTHORIZBOUNDARIES + EXTENDPASTVERTBOUNDARIES FILLWITHBACKGROUND UPDATE/SCROLL/REG WTODSX WTODSY + WXOFFSET WYOFFSET BITMAPSCROLLFN SCROLLBITMAP REDISPLAYBITMAP + ULREDISPLAYBITMAP EXTENDEXTENT WIDTHIFWINDOW HEIGHTIFWINDOW) + (VARS WINDOWSCROLLCOMS) + + previous date%: "29-Sep-93 14:57:22" {DSK}export>lispcore>sources>WINDOWSCROLL.;1) + + +(* ; " +Copyright (c) 1986, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. +") + +(PRETTYCOMPRINT WINDOWSCROLLCOMS) + +(RPAQQ WINDOWSCROLLCOMS + [ (* ; "Scrolling stuff") + (FNS SCROLLW SCROLLBYREPAINTFN ADJUSTOFFSETS CREATESCROLLINGW IN/SCROLL/BAR? RELDSPXOFFSET + RELDSPYOFFSET SCROLL.HANDLER \SCROLL.HANDLER.DOIT \DECODE.EXTENT.USE + \UPDATE.EXTENT.IMAGE EXTENDPASTHORIZBOUNDARIES EXTENDPASTVERTBOUNDARIES REDISPLAYW + FILLWITHBACKGROUND UPDATE/SCROLL/REG WTODSX WTODSY WXOFFSET WYOFFSET BITMAPSCROLLFN + SCROLLBITMAP REDISPLAYBITMAP ULREDISPLAYBITMAP EXTENDEXTENT WIDTHIFWINDOW HEIGHTIFWINDOW + ) + (* ; + "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") + (FNS \DSPUNTRANSFORMREGION) + (CURSORS VertScrollCursor ScrollUpCursor ScrollDownCursor HorizScrollCursor ScrollLeftCursor + ScrollRightCursor VertThumbCursor HorizThumbCursor WAITINGCURSOR) + (GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor + ScrollRightCursor HorizScrollCursor) + (INITVARS (SCROLLBARWIDTH 24) + (SCROLLWAITTIME 100) + (SCROLLBARSHADE 32800) + (WAITBEFORESCROLLTIME 750) + (WAITBETWEENSCROLLTIME 100)) + (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME + SCROLLBARSHADE WAITBEFORESCROLLTIME + WAITBETWEENSCROLLTIME WAITINGCURSOR]) + + + +(* ; "Scrolling stuff") + +(DEFINEQ + +(SCROLLW + [LAMBDA (WINDOW DX DY CONTINUOUSFLG) (* ; "Edited 16-Feb-94 11:58 by nilsson") + + (* ;; "scrolls a window by DX in the X direction and DY in the Y direction. If CONTINUOUSFLG is non-NIL, this is part of a continuous scroll so that the window scrolling function can decide for example to scroll a constant smount.") + + (\CHECKCARET WINDOW) + (APPLY* (OR (fetch SCROLLFN of WINDOW) + (FUNCTION SCROLLBYREPAINTFN)) + WINDOW DX DY CONTINUOUSFLG]) + +(SCROLLBYREPAINTFN + [LAMBDA (WINDOW XDELTA YDELTA CONTINUOUSFLG) (* ; "Edited 16-Feb-94 12:26 by nilsson") + + (* ;; "standard scrolling function that scrolls by blting existing bits and then calling the windows repaintfn to repaint the newly exposed bits.") + + (* ;; "changed 23-jul-86 to treat the part of the window that is coming from off screen as needing to be repainted.") + + (PROG ((DSP (WINDOWPROP WINDOW 'DSP)) + (EXTENT (WINDOWPROP WINDOW 'EXTENT)) + (EXTENTUSE (WINDOWPROP WINDOW 'SCROLLEXTENTUSE)) + X CRHEIGHT CRWIDTH CRLEFT CRBOTTOM WHOLEHEIGHT WHOLEWIDTH XEXTENTUSE YEXTENTUSE + ONSCREENREG ONSLEFT ONSBOTTOM ONSWIDTH ONSHEIGHT) + (SETQ X (DSPCLIPPINGREGION NIL DSP)) + (SETQ CRLEFT (fetch (REGION LEFT) of X)) + (SETQ CRBOTTOM (fetch (REGION BOTTOM) of X)) + (SETQ CRWIDTH (fetch (REGION WIDTH) of X)) + (SETQ CRHEIGHT (fetch (REGION HEIGHT) of X)) + [AND EXTENT (SELECTQ EXTENTUSE + (NIL (* ; "original scrolling mode.") + (SETQ XEXTENTUSE 'LIMIT) + (SETQ YEXTENTUSE '+)) + ((T + - +- LIMIT) + (SETQ XEXTENTUSE (SETQ YEXTENTUSE EXTENTUSE))) + (-+ (SETQ XEXTENTUSE (SETQ YEXTENTUSE '+-))) + (COND + [(LISTP EXTENTUSE) (* ; "CAR is X spec, CDR is Y spec") + (SETQ XEXTENTUSE (\DECODE.EXTENT.USE (CAR EXTENTUSE))) + (SETQ YEXTENTUSE (\DECODE.EXTENT.USE (CDR EXTENTUSE] + (T (* ; "unknown value, default to T") + (SETQ XEXTENTUSE (SETQ YEXTENTUSE T] + +(* ;;; "calculate the amount to be moved in X") + + [COND + ((FLOATP XDELTA) (* ; + "thumb scroll, XDELTA gives the fraction of the way from the left margin the cursor was.") + (COND + [(AND EXTENT (NEQ (fetch (REGION WIDTH) of EXTENT) + -1)) + (PROG (OLDX NEWX) + + (* ;; "if there is an extent, calculate a value of XDELTA that moves to the proper place. If there is not, Don't do anything.") + + [SETQ NEWX (IPLUS (fetch (REGION LEFT) of EXTENT) + (FIXR (FTIMES XDELTA (IDIFFERENCE (fetch (REGION WIDTH) + of EXTENT) + CRWIDTH] + (SETQ OLDX (WXOFFSET NIL DSP)) + (SETQ XDELTA (IDIFFERENCE OLDX NEWX] + (T (SETQ XDELTA 0] + [COND + (CONTINUOUSFLG + + (* ;; "if continuous set it scroll by the linefeed height {no particularly good reason why the linefeed height but why not}.") + + (COND + ((EQ XDELTA 0)) + [(IGREATERP XDELTA 0) (* ; + "linefeed height is normally negative.") + (SETQ XDELTA (IMINUS (DSPLINEFEED NIL DSP] + (T (SETQ XDELTA (DSPLINEFEED NIL DSP] + +(* ;;; "calculate the amount to be moved in Y") + + [COND + ((FLOATP YDELTA) (* ; + "thumb scroll, YDELTA gives the fraction of the way from the top margin the cursor was.") + (COND + [(AND EXTENT (NEQ (fetch (REGION HEIGHT) of EXTENT) + -1)) + (PROG (OLDY NEWY) + + (* ;; "if there is an extent, calculate a value of YDELTA that moves to the proper place. If there is not, Don't do anything.") + + (SETQ NEWY (IPLUS (FIXR (FTIMES (FDIFFERENCE 1.0 YDELTA) + (IDIFFERENCE (fetch (REGION HEIGHT) + of EXTENT) + CRHEIGHT))) + (fetch (REGION BOTTOM) of EXTENT))) + (SETQ OLDY (WYOFFSET NIL DSP)) + (SETQ YDELTA (IDIFFERENCE OLDY NEWY] + (T (SETQ YDELTA 0] + [COND + (CONTINUOUSFLG (* ; + "if continuous set it scroll by the linefeed height") + (COND + ((EQ YDELTA 0)) + [(IGREATERP YDELTA 0) (* ; + "linefeed height is normally negative.") + (SETQ YDELTA (IMINUS (DSPLINEFEED NIL DSP] + (T (SETQ YDELTA (DSPLINEFEED NIL DSP] + (COND + [[NOT (SUBREGIONP (fetch (SCREEN SCREGION) of (fetch (WINDOW SCREEN) + of WINDOW)) + (WINDOWPROP WINDOW 'REGION] (* ; + "reduce clipping region to be that part of the window that is on the screen.") + (COND + ([SETQ ONSCREENREG (INTERSECTREGIONS X (\DSPUNTRANSFORMREGION + (fetch (SCREEN SCREGION) + of (fetch (WINDOW SCREEN) + of WINDOW)) + (fetch IMAGEDATA of DSP] + (* ; + "note what part of the region is on the screen too.") + (SETQ ONSLEFT (fetch (REGION LEFT) of ONSCREENREG)) + (SETQ ONSBOTTOM (fetch (REGION BOTTOM) of ONSCREENREG)) + (SETQ ONSWIDTH (fetch (REGION WIDTH) of ONSCREENREG)) + (SETQ ONSHEIGHT (fetch (REGION HEIGHT) of ONSCREENREG))) + (T (* ; + "whole image is off the screen. Just move the coordinates.") + (WXOFFSET XDELTA DSP) + (WYOFFSET YDELTA DSP) + (RETURN] + (T (SETQ ONSLEFT CRLEFT) + (SETQ ONSBOTTOM CRBOTTOM) + (SETQ ONSWIDTH CRWIDTH) + (SETQ ONSHEIGHT CRHEIGHT))) + + (* ;; "only one of XDELTA or YDELTA should be non-zero but do both anyway. When both can be non-zero, this code should avoid calling the repaintfn on the part of the object that is scrolled on by X but then scrolled off by Y.") + (* ; + "do X first because in the common case of printing it is faster to do it first.") + (COND + ((AND (NEQ XDELTA 0) + (COND + ((AND EXTENT (NEQ XEXTENTUSE T) + (NEQ (fetch (REGION WIDTH) of EXTENT) + -1)) (* ; + "use the extent to limit the scrolling.") + (* ; + "for now limit right extent to right of window ETC. ie keep it always visible.") + (SETQ XDELTA (IMIN (IDIFFERENCE CRLEFT (IDIFFERENCE (fetch (REGION LEFT) + of EXTENT) + (SELECTQ XEXTENTUSE + ((+- +) + (* ; + "if X is allowed to go off to right move effective left of extent.") + CRWIDTH) + 0))) + (IMAX (IDIFFERENCE (IPLUS CRLEFT CRWIDTH) + (PLUS (fetch (REGION PRIGHT) of EXTENT + ) + (SELECTQ XEXTENTUSE + ((- +-) + CRWIDTH) + 0))) + XDELTA))) (* ; "make sure it is still not 0") + (NEQ XDELTA 0)) + (T T))) + (BITBLT WINDOW ONSLEFT ONSBOTTOM WINDOW (IPLUS XDELTA ONSLEFT) + ONSBOTTOM ONSWIDTH ONSHEIGHT 'INPUT 'REPLACE) + (WXOFFSET XDELTA DSP) + (SETQ ONSLEFT (IDIFFERENCE ONSLEFT XDELTA)) + (REDISPLAYW WINDOW (COND + ((IGREATERP XDELTA 0)(* ; + "moving to right, create new region on left for repaintfn") + (CREATEREGION ONSLEFT ONSBOTTOM (IMIN XDELTA ONSWIDTH) + ONSHEIGHT)) + (T (* ; "moving to left.") + (CREATEREGION (IMAX (IPLUS ONSLEFT ONSWIDTH XDELTA) + ONSLEFT) + ONSBOTTOM + (IMIN (IMINUS XDELTA) + ONSWIDTH) + ONSHEIGHT))) + T))) + (COND + ((AND (NEQ YDELTA 0) + (COND + ((AND EXTENT (NEQ YEXTENTUSE T) + (NEQ (fetch (REGION HEIGHT) of EXTENT) + -1)) (* ; "limit amount by the extent") + (SETQ YDELTA (IMIN (IDIFFERENCE CRBOTTOM (IDIFFERENCE (fetch (REGION + BOTTOM) + of EXTENT) + (SELECTQ YEXTENTUSE + ((+- +) + (* ; + "if Y is allowed to go off to top, move effective bottom of extent.") + CRHEIGHT) + 0))) + (IMAX (IDIFFERENCE (IPLUS CRBOTTOM CRHEIGHT) + (PLUS (fetch (REGION PTOP) of EXTENT) + (SELECTQ YEXTENTUSE + ((- +-) + CRHEIGHT) + 0))) + YDELTA))) (* ; "make sure its still not 0") + (NEQ YDELTA 0)) + (T T))) (* ; + "move the current image if any of it is still in view.") + (BITBLT WINDOW ONSLEFT ONSBOTTOM WINDOW ONSLEFT (IPLUS YDELTA ONSBOTTOM) + ONSWIDTH ONSHEIGHT 'INPUT 'REPLACE) + (WYOFFSET YDELTA DSP) (* ; + "use X as pointer to bottom in scrolled clipping region.") + (SETQ X (IDIFFERENCE ONSBOTTOM YDELTA)) + (REDISPLAYW WINDOW [COND + ((IGREATERP YDELTA 0)(* ; "moving up.") + (CREATEREGION ONSLEFT X ONSWIDTH (IMIN YDELTA ONSHEIGHT))) + (T (* ; "moving down, fill in top") + (CREATEREGION ONSLEFT (IMAX (IPLUS ONSHEIGHT X YDELTA) + X) + ONSWIDTH + (IMIN (IMINUS YDELTA) + ONSHEIGHT] + T))) + (RETURN]) + +(ADJUSTOFFSETS + [LAMBDA (WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:27 by nilsson") + (PROG [(DSP (WINDOWPROP WINDOW 'DSP] (* ; + "determine the change in offsets caused by the scroll. and redisplay the graph.") + (WYOFFSET YDELTA DSP) + (WXOFFSET XDELTA DSP) + (RETURN]) + +(CREATESCROLLINGW + [LAMBDA (TITLE BORDER) (* ; "Edited 16-Feb-94 12:27 by nilsson") + (WINDOWPROP (CREATEW NIL TITLE BORDER) + 'SCROLLFN + (FUNCTION SCROLLBYREPAINTFN]) + +(IN/SCROLL/BAR? + [LAMBDA (WINDOW X Y) (* ; "Edited 16-Feb-94 12:27 by nilsson") + (* ; + "is X, Y in the scroll bar for WINDOW?") + (AND (fetch SCROLLFN of WINDOW) + (NOT (WINDOWPROP WINDOW 'NOSCROLLBARS)) + (COND + ((INSIDE? (fetch REG of WINDOW) + X Y) + + (* ;; "if it is inside the window, it is not in its scroll bar. This handles case where window is near left or bottom edge.") + + NIL) + [(INSIDE? (fetch (WINDOW VERTSCROLLREG) of WINDOW) + X Y) + (PROG [(EXTENT (WINDOWPROP WINDOW 'EXTENT)) + (EXTENTUSE (WINDOWPROP WINDOW 'SCROLLEXTENTUSE] + (RETURN (COND + [(OR (NOT EXTENT) + (EQ (fetch (REGION WIDTH) of EXTENT) + -1) + (NOT EXTENTUSE) + (NEQ (COND + ((LISTP EXTENTUSE) + (\DECODE.EXTENT.USE (CDR EXTENTUSE))) + (T (\DECODE.EXTENT.USE EXTENTUSE))) + 'LIMIT] + (T (EXTENDPASTVERTBOUNDARIES (DSPCLIPPINGREGION NIL WINDOW) + EXTENT] + ((INSIDE? (fetch (WINDOW HORIZSCROLLREG) of WINDOW) + X Y) + + (* ;; "if there is an extent, make sure it is past the current view boundaries. -1 is used to mark an unknown width, treat it as if EXTENT wasn't given.") + + (PROG [(EXTENT (WINDOWPROP WINDOW 'EXTENT)) + (EXTENTUSE (WINDOWPROP WINDOW 'SCROLLEXTENTUSE] + (RETURN (COND + [(OR (NOT EXTENT) + (EQ (fetch (REGION WIDTH) of EXTENT) + -1) + (NEQ (COND + ((LISTP EXTENTUSE) + (\DECODE.EXTENT.USE (CAR EXTENTUSE))) + (T (\DECODE.EXTENT.USE EXTENTUSE))) + 'LIMIT] + (T (EXTENDPASTHORIZBOUNDARIES (DSPCLIPPINGREGION NIL WINDOW) + EXTENT]) + +(RELDSPXOFFSET + [LAMBDA (DX DISPLAYSTREAM) (* ; "Edited 16-Feb-94 12:28 by nilsson") + (* ; "relative offsetting function.") + (DSPXOFFSET (IPLUS DX (DSPXOFFSET NIL DISPLAYSTREAM)) + DISPLAYSTREAM]) + +(RELDSPYOFFSET + [LAMBDA (DY DISPLAYSTREAM) (* ; "Edited 16-Feb-94 12:28 by nilsson") + (* ; "relative offsetting function.") + (DSPYOFFSET (IPLUS DY (DSPYOFFSET NIL DISPLAYSTREAM)) + DISPLAYSTREAM]) + +(SCROLL.HANDLER + [LAMBDA (WINDOW) (* ; "Edited 16-Feb-94 12:29 by nilsson") + + (* ;; "cursor has moved into scroll region. region of a window that has a scrollfn and has been IN/SCROLL/BAR? Handle interaction to determine type of scroll, if any, desired.") + (* ; + "returns non-NIL if scrolling was applicable.") + (PROG (SCROLLREG SCROLLW BUTTON DIRECTION SCROLLCURSOR LEFTCURSOR RIGHTCURSOR MIDDLECURSOR + TIMEDOWN CONTINUOUSSCROLL? TIMEIN TIMEINTIMER) + (* ; + "create a window as the easiest thing to do. Fairly inefficient.") + + (* ;; "if the main window is not open, it was probably closed before we got control here. Don't do anything.") + + (OR (OPENWP WINDOW) + (RETURN)) + (GETMOUSESTATE) + (COND + ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW VERTSCROLLREG) of WINDOW)) + LASTMOUSEX LASTMOUSEY) + (PROGN (DISMISS SCROLLWAITTIME) + (GETMOUSESTATE) + (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) + [COND + ((SETQ SCROLLW (fetch (WINDOW VERTSCROLLWINDOW) of WINDOW)) + (* ; + "if there is one already, reopen it.") + (OPENW SCROLLW)) + ((SETQ SCROLLW (replace (WINDOW VERTSCROLLWINDOW) of WINDOW + with (CREATEW SCROLLREG NIL 2] + (SETQ DIRECTION 'VERT) + (SETQ SCROLLCURSOR VertScrollCursor) + (SETQ LEFTCURSOR ScrollUpCursor) + (SETQ RIGHTCURSOR ScrollDownCursor) + (SETQ MIDDLECURSOR VertThumbCursor)) + ((AND (INSIDE? (SETQ SCROLLREG (fetch (WINDOW HORIZSCROLLREG) of WINDOW)) + LASTMOUSEX LASTMOUSEY) + (PROGN (DISMISS SCROLLWAITTIME) + (GETMOUSESTATE) + (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY))) + [COND + ((SETQ SCROLLW (fetch (WINDOW HORIZSCROLLWINDOW) of WINDOW)) + (* ; + "if there is one already, reopen it.") + (OPENW SCROLLW)) + ((SETQ SCROLLW (replace (WINDOW HORIZSCROLLWINDOW) of WINDOW + with (CREATEW SCROLLREG NIL 2] + (SETQ DIRECTION 'HORIZ) + (SETQ SCROLLCURSOR HorizScrollCursor) + (SETQ LEFTCURSOR ScrollLeftCursor) + (SETQ MIDDLECURSOR HorizThumbCursor) + (SETQ RIGHTCURSOR ScrollRightCursor)) + (T (* ; "moved out quickly") + (RETURN NIL))) + (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW) + + (* ;; "set up the timer for when to bring the window to the top. This gives the user a chance to notice that the scroll bar has come up and get out of it if it was unintentional.") + + (SETQ TIMEIN (SETUPTIMER 1200)) + (RETURN (RESETFORM (CURSOR SCROLLCURSOR) + (PROG NIL + LP (GETMOUSESTATE) + (COND + ((NOT (OPENWP WINDOW)) (* ; + "the user closed the window, quit.") + (CLOSEW SCROLLW) + (SETQ \LastInWindow NIL) + (RETURN T))) + (COND + ((AND TIMEIN (TIMEREXPIRED? TIMEIN)) + + (* ;; "after a little while, bring the window to the top. This avoids bringing it up if nothing is happening.") + + (SETQ TIMEIN NIL) + (TOTOPW WINDOW))) + (COND + ((NOT (INSIDE? SCROLLREG LASTMOUSEX LASTMOUSEY)) + (* ; + "if cursor is no longer in scroll region quit.") + (CLOSEW SCROLLW) + + (* ;; "if the mouse is in the window, set last in window so window will get control again. If it is outside, don't set it so that the cursoroutfn for WINDOW will get called.") + + (AND (INSIDE? (WINDOWPROP WINDOW 'REGION) + LASTMOUSEX LASTMOUSEY) + (SETQ \LastInWindow NIL)) + (RETURN T))) (* ; + "bring the scroll window to the top so that it will be visible.") + (TOTOPW SCROLLW) + [COND + [(LASTMOUSESTATE UP) (* ; + "no buttons down; if there was one down, take action; otherwise, wait for one to go down.") + (COND + (BUTTON (COND + (CONTINUOUSSCROLL? + (* ; + "were continuously scrolling, stop it.") + (SETQ CONTINUOUSSCROLL? NIL)) + (T (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION + SCROLLREG LASTMOUSEX LASTMOUSEY) + (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION + WINDOW))) + (CURSOR SCROLLCURSOR) + (SETQ BUTTON) (* ; + "if a button went up, reset the timedown for scrolling.") + (SETQ TIMEDOWN) + (SETQ CONTINUOUSSCROLL? NIL)) + (T (BLOCK] + [(LASTMOUSESTATE (OR LEFT RIGHT)) + (COND + ((AND (LASTMOUSESTATE LEFT) + (NEQ BUTTON 'LEFT)) + (* ; "LEFT button just when down.") + (SETQ BUTTON 'LEFT) + (SETQ TIMEDOWN (CLOCK 0)) + (CURSOR LEFTCURSOR)) + ((AND (LASTMOUSESTATE RIGHT) + (NEQ BUTTON 'RIGHT)) + (* ; "RIGHT button just when down.") + (SETQ BUTTON 'RIGHT) + (SETQ TIMEDOWN (CLOCK 0)) + (CURSOR RIGHTCURSOR)) + ((AND CONTINUOUSSCROLL? (\CLOCKGREATERP TIMEDOWN + WAITBETWEENSCROLLTIME)) + (* ; + "button is still down, keep scrolling.") + (* ; + "note time before calling scroll fn so time to display is included in the wait time.") + (SETQ TIMEDOWN (\CLOCK0 TIMEDOWN)) + (\SCROLL.HANDLER.DOIT WINDOW BUTTON DIRECTION SCROLLREG + LASTMOUSEX LASTMOUSEY T) + (\UPDATE.EXTENT.IMAGE SCROLLW DIRECTION WINDOW)) + ((\CLOCKGREATERP TIMEDOWN WAITBEFORESCROLLTIME) + (* ; + "has enough time past to start continuous scroll?") + (SETQ CONTINUOUSSCROLL? T] + ((LASTMOUSESTATE MIDDLE) + (COND + ((NEQ BUTTON 'MIDDLE) (* ; "MIDDLE button just when down.") + (SETQ BUTTON 'MIDDLE) (* ; + "don't keep track of time down for middle buttons.") + (CURSOR MIDDLECURSOR)) + (T NIL] + (GO LP]) + +(\SCROLL.HANDLER.DOIT + [LAMBDA (WINDOW BUTTON DIRECTION SCROLLREGION XPOS YPOS CONTINUOUS?) + (* ; "Edited 16-Feb-94 12:29 by nilsson") + + (* ;; "decodes how far to scroll given that the button was let up at position XPOS YPOS in the scroll region SCROLLREGION.") + + (ERSETQ + (PROG ((WBORDER (WINDOWPROP WINDOW 'BORDER)) + LFT TOP (SIZEOFORIGIN 8)) (* ; + "correct for the border on the window so that it never moves more than the amount that is seen.") + (SETQ LFT (IPLUS WBORDER (fetch (REGION LEFT) of SCROLLREGION))) + (SETQ TOP (IDIFFERENCE (fetch (REGION TOP) of SCROLLREGION) + WBORDER)) + (RETURN (SCROLLW + WINDOW + (COND + ((EQ DIRECTION 'HORIZ) + (SELECTQ BUTTON + (LEFT (* ; "always scroll at least 1") + (IMIN (IDIFFERENCE LFT XPOS) + 1)) + (RIGHT (* ; "correct for border in window.") + (IMAX (IDIFFERENCE XPOS LFT) + 1)) + (MIDDLE [COND + ((IGREATERP (IPLUS LFT SIZEOFORIGIN) + XPOS) (* ; +"make a portion of the left of the scroll bar indicate left edge of doc since it is a common case.") + 0.0) + (T (MIN 1.0 (MAX 0.0 (FQUOTIENT (IDIFFERENCE XPOS + (IPLUS LFT SIZEOFORIGIN + )) + (IDIFFERENCE (fetch + (REGION WIDTH) + of + SCROLLREGION + ) + (IPLUS 4 SIZEOFORIGIN]) + (SHOULDNT))) + (T 0)) + (COND + ((EQ DIRECTION 'VERT) + (SELECTQ BUTTON + (LEFT (* ; "always scroll at least 1") + (IMAX (IDIFFERENCE TOP YPOS) + 1)) + (RIGHT (IMIN (IDIFFERENCE YPOS TOP) + -1)) + (MIDDLE [COND + ((IGREATERP YPOS (IDIFFERENCE TOP SIZEOFORIGIN)) + (* ; + "make a portion of the top of the scroll bar indicate top edge of doc since it is a common case.") + 0.0) + (T (MIN 1.0 (MAX 0.0 (FQUOTIENT (IDIFFERENCE (IDIFFERENCE + TOP SIZEOFORIGIN + ) + YPOS) + (IDIFFERENCE (fetch + (REGION HEIGHT) + of + SCROLLREGION + ) + (IPLUS 4 SIZEOFORIGIN]) + (SHOULDNT))) + (T 0)) + CONTINUOUS?]) + +(\DECODE.EXTENT.USE + [LAMBDA (EXTENTUSE) (* ; "Edited 16-Feb-94 12:30 by nilsson") + +(* ;;; "decodes an indicator of how the extent should be used to limit scrolling.") + + (SELECTQ EXTENTUSE + (NIL 'LIMIT) + ((LIMIT T + - +-) + EXTENTUSE) + (-+ '+-) + T]) + +(\UPDATE.EXTENT.IMAGE + [LAMBDA (SCROLLBARW DIRECTION SCROLLINGW) (* ; "Edited 16-Feb-94 12:32 by nilsson") + (* ; + "paints the appropriate grey region in the scrolling bar window.") + (CLEARW SCROLLBARW) + (PROG [(EXTENT (WINDOWPROP SCROLLINGW 'EXTENT] + (OR EXTENT (RETURN NIL)) + (COND + [(EQ DIRECTION 'VERT) + (PROG (GRAYHEIGHT GRAYBOTTOM SCROLLWIDTH SCROLLHEIGHT (WINREGION (DSPCLIPPINGREGION + NIL SCROLLINGW)) + (SCROLLREGION (DSPCLIPPINGREGION NIL SCROLLBARW)) + WINHEIGHT + (EXHEIGHT (fetch (REGION HEIGHT) of EXTENT))) + (* ; + "-1 is used to mark an extent of unknown height. If height is 0, return also.") + (OR (GREATERP EXHEIGHT 0) + (RETURN)) + (SETQ SCROLLWIDTH (fetch (REGION WIDTH) of SCROLLREGION)) + (SETQ SCROLLHEIGHT (fetch (REGION HEIGHT) of SCROLLREGION)) + (SETQ WINHEIGHT (fetch (REGION HEIGHT) of WINREGION)) + [SETQ GRAYHEIGHT (IMAX 2 (IMIN SCROLLHEIGHT (IQUOTIENT (ITIMES WINHEIGHT + SCROLLHEIGHT) + EXHEIGHT] + (SETQ GRAYBOTTOM (IDIFFERENCE (IDIFFERENCE + SCROLLHEIGHT + (IQUOTIENT (ITIMES SCROLLHEIGHT + (IDIFFERENCE (fetch + (REGION TOP) + of EXTENT) + (fetch (REGION TOP) + of WINREGION))) + EXHEIGHT)) + GRAYHEIGHT)) + (BITBLT NIL NIL NIL SCROLLBARW 0 GRAYBOTTOM SCROLLWIDTH GRAYHEIGHT 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL SCROLLBARW 1 (IPLUS GRAYBOTTOM 2) + (IDIFFERENCE SCROLLWIDTH 2) + (IDIFFERENCE GRAYHEIGHT 4) + 'TEXTURE + 'REPLACE + (OR (TEXTUREP SCROLLBARSHADE) + 32800] + ((EQ DIRECTION 'HORIZ) + (PROG (GRAYWIDTH GRAYLEFT SCROLLWIDTH SCROLLHEIGHT (WINREGION (DSPCLIPPINGREGION NIL + SCROLLINGW)) + (SCROLLREGION (DSPCLIPPINGREGION NIL SCROLLBARW)) + WINWIDTH + (EXWIDTH (fetch (REGION WIDTH) of EXTENT))) + (* ; + "-1 is used to mark an EXTENT of unknown width. If width is zero, return too.") + (AND (GREATERP 0 EXWIDTH) + (RETURN)) + (SETQ SCROLLWIDTH (fetch (REGION WIDTH) of SCROLLREGION)) + (SETQ SCROLLHEIGHT (fetch (REGION HEIGHT) of SCROLLREGION)) + (SETQ WINWIDTH (fetch (REGION WIDTH) of WINREGION)) + (SETQ GRAYWIDTH (IMIN SCROLLWIDTH (IQUOTIENT (ITIMES WINWIDTH SCROLLWIDTH) + EXWIDTH))) + (SETQ GRAYLEFT (IQUOTIENT (ITIMES WINWIDTH (IDIFFERENCE (fetch (REGION LEFT) + of WINREGION) + (fetch (REGION LEFT) + of EXTENT))) + EXWIDTH)) + (BITBLT NIL NIL NIL SCROLLBARW GRAYLEFT 0 GRAYWIDTH SCROLLHEIGHT 'TEXTURE + 'REPLACE BLACKSHADE) + (BITBLT NIL NIL NIL SCROLLBARW (IPLUS GRAYLEFT 2) + 1 + (IDIFFERENCE GRAYWIDTH 4) + (IDIFFERENCE SCROLLHEIGHT 2) + 'TEXTURE + 'REPLACE + (OR (TEXTUREP SCROLLBARSHADE) + 32800]) + +(EXTENDPASTHORIZBOUNDARIES + [LAMBDA (VIEW EXTENT) (* ; "Edited 16-Feb-94 12:32 by nilsson") + (* ; + "does VIEW entirely cover the hoizontal dimensions of EXTENT?") + (OR (IGREATERP (fetch (REGION LEFT) of VIEW) + (fetch (REGION LEFT) of EXTENT)) + (IGREATERP (fetch (REGION RIGHT) of EXTENT) + (fetch (REGION RIGHT) of VIEW]) + +(EXTENDPASTVERTBOUNDARIES + [LAMBDA (VIEW EXTENT) (* ; "Edited 16-Feb-94 12:33 by nilsson") + (* ; + "does VIEW entirely cover the vertical dimensions of EXTENT?") + (OR (IGREATERP (fetch (REGION BOTTOM) of VIEW) + (fetch (REGION BOTTOM) of EXTENT)) + (IGREATERP (fetch (REGION TOP) of EXTENT) + (fetch (REGION TOP) of VIEW]) + +(REDISPLAYW + [LAMBDA (WINDOW REGION ALWAYSFLG) + (WINDOWOP 'REDISPLAYFN (fetch (WINDOW SCREEN) of WINDOW) + WINDOW REGION ALWAYSFLG]) + +(FILLWITHBACKGROUND + [LAMBDA (WIN REG) (* ; "Edited 16-Feb-94 12:33 by nilsson") + (* ; + "fills a window with its background. This is the default window repainting function.") + (DSPFILL REG (DSPTEXTURE NIL WIN) + 'REPLACE + (WINDOWPROP WIN 'DSP]) + +(UPDATE/SCROLL/REG + [LAMBDA (WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") + (* ; + "updates the scroll region field of the WINDOW") + (COND + ((fetch (WINDOW SCROLLFN) of WINDOW) + (PROG ((IMAGEREG (fetch (WINDOW REG) of WINDOW))) + (* ; + "kill the cache for the scroll region.") + (COND + ((fetch (WINDOW VERTSCROLLWINDOW) of WINDOW) + (CLOSEW (fetch (WINDOW VERTSCROLLWINDOW) of WINDOW)) + (replace (WINDOW VERTSCROLLWINDOW) of WINDOW with NIL))) + (COND + ((fetch (WINDOW HORIZSCROLLWINDOW) of WINDOW) + (CLOSEW (fetch (WINDOW HORIZSCROLLWINDOW) of WINDOW)) + (replace (WINDOW HORIZSCROLLWINDOW) of WINDOW with NIL))) + [replace (WINDOW VERTSCROLLREG) of WINDOW + with (create REGION + LEFT _ (IMAX 0 (IDIFFERENCE (fetch (REGION LEFT) of IMAGEREG + ) + SCROLLBARWIDTH)) + BOTTOM _ (fetch (REGION BOTTOM) of IMAGEREG) + WIDTH _ SCROLLBARWIDTH + HEIGHT _ (IPLUS (fetch (REGION HEIGHT) of IMAGEREG) + (COND + [(fetch (WINDOW WTITLE) of WINDOW) + (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) + of (fetch + (WINDOW SCREEN) + of WINDOW] + (T 0] + (replace (WINDOW HORIZSCROLLREG) of WINDOW + with (create REGION + LEFT _ (fetch (REGION LEFT) of IMAGEREG) + BOTTOM _ (IMAX 0 (IDIFFERENCE (fetch (REGION BOTTOM) + of IMAGEREG) + SCROLLBARWIDTH)) + WIDTH _ (fetch (REGION WIDTH) of IMAGEREG) + HEIGHT _ SCROLLBARWIDTH]) + +(WTODSX + [LAMBDA (WX WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") + + (* ;; "converts from the window natural coordinates which have 0,0 at lower left corner of the window and the displaystreams coordinates.") + + (IPLUS WX (fetch (REGION LEFT) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) + +(WTODSY + [LAMBDA (WY WINDOW) (* ; "Edited 16-Feb-94 12:34 by nilsson") + + (* ;; "converts from the window natural coordinates which have 0,0 at lower left corner of the window and the displaystreams coordinates.") + + (IPLUS WY (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION NIL (fetch DSP of WINDOW]) + +(WXOFFSET + [LAMBDA (DX WINDOW) (* ; "Edited 16-Feb-94 12:26 by nilsson") + + (* ;; "offsets a displaystream by a given delta but leaves its clipping region where it was. Used for offsetting display streams under window.") + + (PROG [CR (DS (OR (DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) + (\ILLEGAL.ARG WINDOW] + (SETQ CR (DSPCLIPPINGREGION NIL DS)) + (RETURN (PROG1 (fetch (REGION LEFT) of CR) + (COND + ((NUMBERP DX) + (DSPXOFFSET (IPLUS DX (DSPXOFFSET NIL DS)) + DS) + (add (fetch (REGION LEFT) of CR) + (IMINUS DX)) (* ; + "recall DSPCLIPPINGREGION to update dependent fields in DS.") + (DSPCLIPPINGREGION CR DS))))]) + +(WYOFFSET + [LAMBDA (DY WINDOW) (* ; "Edited 16-Feb-94 12:26 by nilsson") + + (* ;; "offsets a displaystream by a given delta but leaves its clipping region where it was. Used for offsetting display streams under window.") + + (PROG [CR (DS (OR (DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) + (\ILLEGAL.ARG WINDOW] + (SETQ CR (DSPCLIPPINGREGION NIL DS)) + (RETURN (PROG1 (fetch (REGION BOTTOM) of CR) + (COND + ((NUMBERP DY) + (DSPYOFFSET (IPLUS DY (DSPYOFFSET NIL DS)) + DS) + (add (fetch (REGION BOTTOM) of CR) + (IMINUS DY)) (* ; + "recall DSPCLIPPINGREGION to update dependent fields in DS.") + (DSPCLIPPINGREGION CR DS))))]) + +(BITMAPSCROLLFN + [LAMBDA (WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:34 by nilsson") + (* ; "scrolls a bitmap under a window") + (SCROLLBITMAP (WINDOWPROP WINDOW 'BITMAP) + WINDOW XDELTA YDELTA]) + +(SCROLLBITMAP + [LAMBDA (BITMAP WINDOW XDELTA YDELTA) (* ; "Edited 16-Feb-94 12:35 by nilsson") + (* ; + "scrolls a bitmap under a window.") + (PROG ((DSP (WINDOWPROP WINDOW 'DSP)) + REGION) + (COND + ((NOT (type? BITMAP BITMAP)) + (RETURN))) + (SETQ REGION (DSPCLIPPINGREGION NIL DSP)) (* ; + "determine the change in offsets caused by the scroll.") + (WYOFFSET (IMAX (IMIN (fetch (REGION BOTTOM) of REGION) + YDELTA) + (IDIFFERENCE (fetch (REGION HEIGHT) of REGION) + (fetch (BITMAP BITMAPHEIGHT) of BITMAP))) + DSP) + (WXOFFSET (IMAX (IMIN (fetch (REGION LEFT) of REGION) + XDELTA) + (IDIFFERENCE (fetch (REGION WIDTH) of REGION) + (fetch (BITMAP BITMAPWIDTH) of BITMAP))) + DSP) (* ; "stuff new image over old") + (BITBLT BITMAP 0 0 DSP]) + +(REDISPLAYBITMAP + [LAMBDA (BITMAP WINDOW) (* ; "Edited 16-Feb-94 12:35 by nilsson") + + (* ;; "blts a bitmap into a window so that the lower left corner of the bitmap is in the lower left corner of the window.") + + (OR (type? BITMAP BITMAP) + (ERROR "ILLEGAL ARG" BITMAP)) + (PROG ((DSP (WINDOWPROP WINDOW 'DSP)) + WREGION) + (SETQ WREGION (DSPCLIPPINGREGION NIL DSP)) + (RETURN (BITBLT BITMAP 0 0 DSP (fetch (REGION LEFT) of WREGION) + (fetch (REGION BOTTOM) of WREGION]) + +(ULREDISPLAYBITMAP + [LAMBDA (BITMAP WNEW) (* ; "Edited 16-Feb-94 12:35 by nilsson") + + (* ;; "blts a bitmap into a window so that the upper left corner of the bitmap is in the upper left corner of the window.") + + (OR (type? BITMAP BITMAP) + (ERROR "ILLEGAL ARG" BITMAP)) + (PROG ((DSP (WINDOWPROP WNEW 'DSP)) + REGION) + (SETQ REGION (DSPCLIPPINGREGION NIL DSP)) + (RETURN (BITBLT BITMAP 0 0 DSP (fetch (REGION LEFT) of REGION) + (IDIFFERENCE (IPLUS (fetch (REGION BOTTOM) of REGION) + (fetch (REGION HEIGHT) of REGION)) + (fetch BITMAPHEIGHT of BITMAP]) + +(EXTENDEXTENT + [LAMBDA (WINDOW INCLUDEREGION) (* ; "Edited 16-Feb-94 12:35 by nilsson") + (* ; + "destructively changes the EXTENT region of a WINDOW to include INCLUDEREGION") + (PROG [(EXTENT (WINDOWPROP WINDOW 'EXTENT] + (RETURN (COND + (EXTENT (EXTENDREGION EXTENT INCLUDEREGION)) + (T (WINDOWPROP WINDOW 'EXTENT (create REGION using INCLUDEREGION]) + +(WIDTHIFWINDOW + [LAMBDA (INTERIORWIDTH BORDER) (* ; "Edited 16-Feb-94 12:35 by nilsson") + (* ; + "returns the exterior width of a window with interior dimension INTERIORWIDTH") + (IPLUS INTERIORWIDTH (ITIMES 2 (OR BORDER WBorder]) + +(HEIGHTIFWINDOW + [LAMBDA (INTERIORHEIGHT TITLEFLG BORDER SCREEN) (* ; "Edited 16-Feb-94 12:36 by nilsson") + (* ; + "returns the exterior height of a window which has interior height dimension INTERIORHEIGHT") + (SETQ SCREEN (\INSURESCREEN SCREEN)) + (IPLUS INTERIORHEIGHT (COND + [TITLEFLG (IMINUS (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) + of SCREEN] + (T 0)) + (ITIMES 2 (OR BORDER WBorder]) +) + + + +(* ; "this function should be on LLDISPLAY but Ron has it checked out. Move it later - rrb.") + +(DEFINEQ + +(\DSPUNTRANSFORMREGION + [LAMBDA (REGION DISPLAYDATA) (* rmk%: "30-AUG-83 13:19") + (* translates a region from + destination coordinates into display + stream coordinates.) + (CREATEREGION (\DSPUNTRANSFORMX (fetch (REGION LEFT) of REGION) + DISPLAYDATA) + (\DSPUNTRANSFORMY (fetch (REGION BOTTOM) of REGION) + DISPLAYDATA) + (fetch (REGION WIDTH) of REGION) + (fetch (REGION HEIGHT) of REGION]) +) +(RPAQ VertScrollCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@CH@@CH@@CH@@CH@@ON@@GL@@GL@@CH@@CH@@A@@ +) (QUOTE NIL) 7 15)) +(RPAQ ScrollUpCursor (CURSORCREATE (QUOTE #*(16 16)@A@@@CH@@CH@@GL@@GL@@ON@@ON@AOO@AOO@@CH@@CH@@CH@@CH@@CH@@CH@@CH@ +) (QUOTE NIL) 7 15)) +(RPAQ ScrollDownCursor (CURSORCREATE (QUOTE #*(16 16)@CH@@CH@@CH@@CH@@CH@@CH@@CH@AOO@AOO@@ON@@ON@@GL@@GL@@CH@@CH@@A@@ +) (QUOTE NIL) 7 15)) +(RPAQ HorizScrollCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@HB@AHC@CHCHGHCLOOONOOONGHCLCHCHAHC@@HB@ +) (QUOTE NIL) 7 5)) +(RPAQ ScrollLeftCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@@H@@CH@@OH@COH@OOOOOOOOCOH@@OH@@CH@@@H@ +) (QUOTE NIL) 8 5)) +(RPAQ ScrollRightCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@@@@@@@@@@@@@A@@@AL@@AO@@AOLOOOOOOOO@AOL@AO@@AL@@A@@ +) (QUOTE NIL) 7 5)) +(RPAQ VertThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@OH@@@@@@OO@@@@@@OON@@@@@OOOH@@@@OON@@@@@OO@@@@@@OH@@@@@@@@@@ +) (QUOTE NIL) 6 8)) +(RPAQ HorizThumbCursor (CURSORCREATE (QUOTE #*(16 16)@@@@@@@@@@@@@B@@@B@@@JH@@JH@@JH@BJJ@BJJ@BJJ@JJJHJJJHJJJHJJJHJJJH +) (QUOTE NIL) 6 6)) +(RPAQ WAITINGCURSOR (CURSORCREATE (QUOTE #*(16 16)OOONL@@FF@ALCMGHAOO@@ON@@FL@@CH@@BH@@FL@@MF@AIC@CGMHFGNLOOONOOON +) (QUOTE NIL) 7 8)) +(DECLARE%: DOEVAL@COMPILE DONTCOPY + +(GLOBALVARS \LastInWindow VertScrollCursor ScrollUpCursor ScrollDownCursor ScrollLeftCursor + ScrollRightCursor HorizScrollCursor) +) + +(RPAQ? SCROLLBARWIDTH 24) + +(RPAQ? SCROLLWAITTIME 100) + +(RPAQ? SCROLLBARSHADE 32800) + +(RPAQ? WAITBEFORESCROLLTIME 750) + +(RPAQ? WAITBETWEENSCROLLTIME 100) +(DECLARE%: DONTEVAL@LOAD DOCOPY + +(ADDTOVAR GLOBALVARS SCROLLBARWIDTH SCROLLWAITTIME SCROLLBARSHADE WAITBEFORESCROLLTIME + WAITBETWEENSCROLLTIME WAITINGCURSOR) +) +(PUTPROPS WINDOWSCROLL COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1993 1994)) +(DECLARE%: DONTCOPY + (FILEMAP (NIL (2653 51801 (SCROLLW 2663 . 3186) (SCROLLBYREPAINTFN 3188 . 16871) (ADJUSTOFFSETS 16873 + . 17264) (CREATESCROLLINGW 17266 . 17497) (IN/SCROLL/BAR? 17499 . 20160) (RELDSPXOFFSET 20162 . 20473 +) (RELDSPYOFFSET 20475 . 20786) (SCROLL.HANDLER 20788 . 30242) (\SCROLL.HANDLER.DOIT 30244 . 34675) ( +\DECODE.EXTENT.USE 34677 . 35019) (\UPDATE.EXTENT.IMAGE 35021 . 40034) (EXTENDPASTHORIZBOUNDARIES +40036 . 40575) (EXTENDPASTVERTBOUNDARIES 40577 . 41115) (REDISPLAYW 41117 . 41274) (FILLWITHBACKGROUND + 41276 . 41672) (UPDATE/SCROLL/REG 41674 . 44559) (WTODSX 44561 . 44927) (WTODSY 44929 . 45297) ( +WXOFFSET 45299 . 46264) (WYOFFSET 46266 . 47235) (BITMAPSCROLLFN 47237 . 47550) (SCROLLBITMAP 47552 . +48907) (REDISPLAYBITMAP 48909 . 49506) (ULREDISPLAYBITMAP 49508 . 50280) (EXTENDEXTENT 50282 . 50813) +(WIDTHIFWINDOW 50815 . 51170) (HEIGHTIFWINDOW 51172 . 51799)) (51904 52636 (\DSPUNTRANSFORMREGION +51914 . 52634))))) +STOP diff --git a/sources/WRAPPERS b/sources/WRAPPERS new file mode 100644 index 00000000..343ca3e5 --- /dev/null +++ b/sources/WRAPPERS @@ -0,0 +1,502 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SI") +(IL:FILECREATED " 2-Feb-94 14:15:09" IL:|{PELE:MV:ENVOS}SOURCES>WRAPPERS.;6| 27638 + + IL:|changes| IL:|to:| (IL:FUNCTIONS NAMED-FUNCTION-WRAPPER-INFO) + + IL:|previous| IL:|date:| "10-Mar-93 13:56:58" IL:|{PELE:MV:ENVOS}SOURCES>WRAPPERS.;5| +) + + +; Copyright (c) 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:WRAPPERSCOMS) + +(IL:RPAQQ IL:WRAPPERSCOMS + ((IL:FUNCTIONS COMPILED-FUNCTION-ARGLIST COMPILED-FUNCTION-DEBUGGING-INFO + COMPILED-FUNCTION-INTERLISP? FUNCTION-WRAPPER-INFO CLEAN-UP-CL-ARGLIST + GET-STORED-ARGLIST NAMED-FUNCTION-WRAPPER-INFO PARSE-CL-ARGLIST) + (IL:FUNCTIONS HAS-CALLS CHANGE-CALLS CHANGE-CALLS-IN-CCODE CHANGE-CALLS-IN-LAMBDA + ADD-CHANGED-CALL %WITH-CHANGED-CALLS RESTORE-CALLS) + (IL:FNS IL:VIRGINFN CONSTRUCT-MIDDLE-MAN) + (IL:PROP IL:PROPTYPE IL:NAMESCHANGED) + + (IL:* IL:|;;| "Arrange for the proper compiler and package/readtable.") + + (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) + IL:WRAPPERS) + (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP) + IL:ACODE)) + (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS + (IL:NLAMA) + (IL:NLAML) + (IL:LAMA))))) + +(DEFUN COMPILED-FUNCTION-ARGLIST (FN &KEY INTERLISP?) + (LET ((DEBUGGING-INFO (COMPILED-FUNCTION-DEBUGGING-INFO FN))) + (COND + (DEBUGGING-INFO (IL:* IL:\; + "Oh, good. Its argument list is easy to get.") + (IF INTERLISP? + (IL:|for| X IL:|in| (CAR DEBUGGING-INFO) + IL:|join| (COND + ((STRINGP X) + (LIST (IL:MKATOM X))) + ((EQ X '&OPTIONAL) + NIL) + (T (LIST X)))) + (COPY-TREE (CAR DEBUGGING-INFO)))) + (T (IL:* IL:\; + "Rats. We have to go to some trouble.") + (IL:\\CCODEARGLIST (IL:|fetch| (IL:COMPILED-CLOSURE IL:FNHEADER) IL:|of| FN)))) + )) + +(DEFUN COMPILED-FUNCTION-DEBUGGING-INFO (FN) + +(IL:* IL:|;;;| "Given a compiled-function object, extract the debugging-info list from it. If it's ByteCompiled, it won't have such a list and we should return NIL. We can tell if there is such a list by the length allowed for the local name table. If there's a multiple of a quadword there, it's a name table. Otherwise, it should be exactly one cell long and contain a pointer to the debugging-info list.") + + (LET* ((FNHEADER (IL:|fetch| (IL:COMPILED-CLOSURE IL:FNHEADER) IL:|of| FN)) + (START-PC (IF (IL:|fetch| (IL:FNHEADER IL:NATIVE) IL:|of| FNHEADER) + (- (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| FNHEADER) + 4) + (IL:|fetch| (IL:FNHEADER IL:STARTPC) IL:|of| FNHEADER))) + (NAME-TABLE-WORDS (LET ((SIZE (IL:|fetch| (IL:FNHEADER IL:NTSIZE) IL:|of| FNHEADER) + )) + (IF (ZEROP SIZE) + IL:WORDSPERQUAD + (* SIZE 2)))) + (PAST-NAME-TABLE-IN-WORDS (+ (IL:|fetch| (IL:FNHEADER IL:OVERHEADWORDS) IL:|of| + FN) + NAME-TABLE-WORDS))) + (AND (= (- START-PC (* IL:BYTESPERWORD PAST-NAME-TABLE-IN-WORDS)) + IL:BYTESPERCELL) + + (IL:* IL:|;;| "It's got a debugging-info list.") + + (IL:\\GETBASEPTR FNHEADER PAST-NAME-TABLE-IN-WORDS)))) + +(DEFUN COMPILED-FUNCTION-INTERLISP? (FN) + +(IL:* IL:|;;;| +"Given a compiled-function, return true if and only if the function is an Interlisp one.") + + (LET ((DEBUGGING-INFO (COMPILED-FUNCTION-DEBUGGING-INFO FN))) + (OR (MEMBER (IL:ARGTYPE FN) + '(1 3)) (IL:* IL:\; + "NLambda's are always Interlisp") + (NULL DEBUGGING-INFO) (IL:* IL:\; + "ByteCompiled code is always Interlisp.") + (GETF (CDR DEBUGGING-INFO) + :INTERLISP) (IL:* IL:\; + "PavCompiled Interlisp code should have this marker in it.") + ))) + +(DEFUN FUNCTION-WRAPPER-INFO (WRAPPED-FN FN-TO-CALL) + (LET* ((NAME (AND (SYMBOLP WRAPPED-FN) + WRAPPED-FN)) + (DEFN (IF NAME + (IL:GETD NAME) + WRAPPED-FN))) + (NAMED-FUNCTION-WRAPPER-INFO NAME DEFN FN-TO-CALL))) + +(DEFUN CLEAN-UP-CL-ARGLIST (ARG-LIST) + (IL:|bind| (STATE IL:_ :REQUIRED) IL:|for| PARAM IL:|in| ARG-LIST + IL:|collect| (COND + ((MEMBER PARAM '(&OPTIONAL &REST &KEY &ALLOW-OTHER-KEYS)) + (SETQ STATE PARAM) + PARAM) + ((CONSP PARAM) + (CASE STATE + (&OPTIONAL (FIRST PARAM)) + (&KEY (IF (CONSP (FIRST PARAM)) + (FIRST (FIRST PARAM)) + (INTERN (STRING (FIRST PARAM)) + "KEYWORD"))) + (OTHERWISE + (WARN "Illegal form in argument-list: ~S" PARAM) + 'USER::%LOSE%))) + ((EQ STATE '&KEY) + (INTERN (STRING PARAM) + "KEYWORD")) + (T PARAM)))) + +(DEFUN GET-STORED-ARGLIST (NAME) + +(IL:* IL:|;;;| "The IL:ARGNAMES property is either the argument list itself or a list of the form (NIL arglist-1 . arglist-2) where arglist-1 is semantically void and arglist-2 is interesting. Since NIL is not a legal argument list, we can tell the cases apart. Ugh.") + + (LET ((ARGNAMES (GET NAME 'IL:ARGNAMES))) + (AND ARGNAMES (COND + ((ATOM ARGNAMES) + (ERROR "Illegal ARGNAMES property for ~S" NAME)) + ((NULL (CAR ARGNAMES)) (IL:* IL:\; "It's the fancy case.") + (CDDR ARGNAMES)) + (T (IL:* IL:\; "It's the simple case.") + ARGNAMES))))) + +(DEFUN NAMED-FUNCTION-WRAPPER-INFO (NAME DEFN FN-TO-CALL) + (LET + ((STORED-ARGLIST (AND NAME (GET-STORED-ARGLIST NAME)))) + (ETYPECASE DEFN + (NULL (IL:* IL:\; + "It's an undefined function.") + (ASSERT (NOT (NULL NAME)) + NIL "Null definition passed to SI::FUNCTION-WRAPPER-INFO") + (VALUES 'LAMBDA '(&REST XCL:ARGLIST) + `(ERROR 'XCL:UNDEFINED-FUNCTION :NAME (CONS ',NAME XCL:ARGLIST)))) + (CONS (IL:* IL:\; + "It's an interpreted function.") + (ECASE (CAR DEFN) + ((IL:LAMBDA) + (ETYPECASE (CADR DEFN) + (LIST (IL:* IL:\; "Lambda spread") + (VALUES 'IL:LAMBDA (OR STORED-ARGLIST (CADR DEFN)) + `(FUNCALL ',FN-TO-CALL ,@(OR STORED-ARGLIST (CADR DEFN))))) + (SYMBOL (IL:* IL:\; "Lambda no-spread") + (VALUES + 'IL:LAMBDA + (OR STORED-ARGLIST (CADR DEFN)) + `(APPLY ',FN-TO-CALL + ,(IF (CONSP STORED-ARGLIST) + `(LIST ,@STORED-ARGLIST) + `(IL:FOR $FWI$ IL:TO ,(OR STORED-ARGLIST (CADR DEFN)) + IL:COLLECT (IL:ARG ,(OR STORED-ARGLIST (CADR DEFN)) + $FWI$)))))))) + ((IL:NLAMBDA) + (ETYPECASE (CADR DEFN) + (LIST (IL:* IL:\; "NLambda spread") + (VALUES 'IL:NLAMBDA (OR STORED-ARGLIST (CADR DEFN)) + `(FUNCALL ',FN-TO-CALL ,@(OR STORED-ARGLIST (CADR DEFN))))) + (SYMBOL (IL:* IL:\; "NLambda no-spread") + (VALUES 'IL:NLAMBDA (OR STORED-ARGLIST (CADR DEFN)) + `(FUNCALL ',FN-TO-CALL ,(IF (CONSP STORED-ARGLIST) + `(LIST ,@STORED-ARGLIST) + (OR STORED-ARGLIST (CADR DEFN)))))))) + ((LAMBDA) (VALUES 'LAMBDA (CLEAN-UP-CL-ARGLIST (CADR DEFN)) + `(APPLY ',FN-TO-CALL XCL:ARGLIST))))) + (COMPILED-FUNCTION (IL:* IL:\; "It's compiled.") + (IF (NOT (COMPILED-FUNCTION-INTERLISP? DEFN)) (IL:* IL:\; "Common Lisp function.") + (VALUES 'LAMBDA (COMPILED-FUNCTION-ARGLIST DEFN) + `(APPLY ',FN-TO-CALL XCL:ARGLIST)) + (ECASE (IL:ARGTYPE DEFN) + (0 (IL:* IL:\; "Lambda spread function.") + (LET ((ARGLIST (OR STORED-ARGLIST (COMPILED-FUNCTION-ARGLIST DEFN + :INTERLISP? T)))) + (VALUES 'IL:LAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,@ARGLIST)))) + (1 (IL:* IL:\; "NLambda spread function.") + (LET ((ARGLIST (OR STORED-ARGLIST (COMPILED-FUNCTION-ARGLIST DEFN + :INTERLISP? T)))) + (VALUES 'IL:NLAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,@ARGLIST)))) + (2 (IL:* IL:\; + "Lambda no-spread function.") + (IF (SYMBOLP STORED-ARGLIST) + (VALUES 'IL:LAMBDA 'IL:U + `(APPLY ',FN-TO-CALL (IL:FOR $FWI$ + IL:TO ,(OR STORED-ARGLIST 'IL:U) + IL:COLLECT + (IL:ARG ,(OR STORED-ARGLIST 'IL:U) + $FWI$)))) + (VALUES 'IL:LAMBDA STORED-ARGLIST `(FUNCALL ',FN-TO-CALL ,@STORED-ARGLIST))) +) + (3 (IL:* IL:\; + "NLambda no-spread function.") + + (IL:* IL:|;;| "Its arglist may be a symbol, or NIL, or IL:U. COMPILED-FUNCTION-ARGLIST will return a symbol in this case.") + + (LET ((ARGLIST (OR (AND (IL:NEQ STORED-ARGLIST 'IL:U) + STORED-ARGLIST) + (COMPILED-FUNCTION-ARGLIST DEFN :INTERLISP? T)))) + (COND + (ARGLIST (SYMBOLP ARGLIST) + (VALUES 'IL:NLAMBDA (IF (SYMBOLP ARGLIST) + ARGLIST + (CAR ARGLIST)) + `(IL:APPLY ',FN-TO-CALL (IL:MKLIST + ,(IF (SYMBOLP ARGLIST) + ARGLIST + (CAR ARGLIST)))))) + (T (VALUES 'IL:NLAMBDA ARGLIST `(FUNCALL ',FN-TO-CALL ,ARGLIST)))))))))) + )) + +(DEFUN PARSE-CL-ARGLIST (ARG-LIST) + (LET ((REQUIRED NIL) + (OPTIONAL NIL) + (REST NIL) + (KEY NIL) + (KEY-APPEARED? NIL) + (ALLOW-OTHER-KEYS NIL) + (STATE :REQUIRED)) + (IL:|for| PARAM IL:|in| ARG-LIST + IL:|do| (IF (MEMBER PARAM '(&OPTIONAL &KEY &REST)) + (SETQ STATE PARAM) + (CASE STATE + (:REQUIRED (PUSH PARAM REQUIRED)) + (&OPTIONAL (PUSH PARAM OPTIONAL)) + (&REST (SETQ REST PARAM)) + (&KEY (IF (EQ PARAM '&ALLOW-OTHER-KEYS) + (SETQ ALLOW-OTHER-KEYS T) + (PUSH PARAM KEY))))) + (WHEN (EQ PARAM '&KEY) + (SETQ KEY-APPEARED? T))) + (VALUES (REVERSE REQUIRED) + (REVERSE OPTIONAL) + REST + (REVERSE KEY) + KEY-APPEARED? ALLOW-OTHER-KEYS))) + +(DEFUN HAS-CALLS (CALLER CALLEE) + + (IL:* IL:|;;| "Tell if CALLEE is called by CALLER at all.") + + (IL:* IL:|;;| "[JDS 3-10-93: Used to use CALLS to find callee list; changed to CALLSCCODE, because CALLS isn't always loaded.]") + + (LET ((REAL-CALLER (OR (GET CALLER 'IL:ADVISED) + (GET CALLER 'IL:BROKEN) + CALLER))) + (OR (CONSP (IL:GETD REAL-CALLER)) + (FIND CALLEE (CADR (IL:CALLSCCODE REAL-CALLER)) + :TEST + 'EQ)))) + +(DEFUN CHANGE-CALLS (FROM TO FN &OPTIONAL FIXER) + +(IL:* IL:|;;;| "Side-effect the definition of FN to change all calls to FROM into calls to TO. Also save enough information that SI::RESTORE-CALLS can fix up the definition again.") + + (LET* ((REAL-FN-SYMBOL (OR (GET FN 'IL:ADVISED) + (GET FN 'IL:BROKEN) + FN)) + (REAL-FN-DEFN (IL:GETD REAL-FN-SYMBOL))) + (TYPECASE REAL-FN-DEFN + (CONS (IL:* IL:\; + "The function is interpreted.") + (WHEN (NULL (GET FN 'IL:NAMESCHANGED)) (IL:* IL:\; "The first time we change calls, get a copy so as to avoid sharing structure with the DEFUN form. Ugh.") + (IL:PUTD REAL-FN-SYMBOL (SETQ REAL-FN-DEFN (COPY-TREE REAL-FN-DEFN)))) + (CHANGE-CALLS-IN-LAMBDA FROM TO REAL-FN-DEFN)) + (IL:COMPILED-CLOSURE (CHANGE-CALLS-IN-CCODE FROM TO REAL-FN-DEFN)) + (OTHERWISE (ERROR "SI::CHANGE-CALLS called on a non-function: ~S" FN)))) + + (IL:* IL:|;;| "If there's an opposite entry already in the info, just remove it. We assume that we're being called from the same fellow that called us before and that we want to simply undo that other call.") + + (UNLESS (EQ FIXER 'RESTORE-CALLS) + (FLET ((MATCHING (ENTRY) + (AND (EQ (FIRST ENTRY) + TO) + (EQ (SECOND ENTRY) + FROM)))) + (LET ((CURRENT-INFO (GET FN 'IL:NAMESCHANGED))) + (IF (SOME #'MATCHING CURRENT-INFO) + (IF (NULL (CDR CURRENT-INFO)) + (REMPROP FN 'IL:NAMESCHANGED) + (SETF (GET FN 'IL:NAMESCHANGED) + (DELETE-IF #'MATCHING CURRENT-INFO))) + (PUSH (LIST FROM TO FIXER) + (GET FN 'IL:NAMESCHANGED)))))) + NIL) + +(DEFUN CHANGE-CALLS-IN-CCODE (FROM TO CCODE) + + (IL:* IL:|;;| "Change the calls in a compiled-code object??") + + (IL:FOR REFMAP IL:IN (CDR (IL:CHANGECCODE FROM FROM CCODE)) + IL:DO (LET ((BASE (IL:FETCH (IL:REFMAP IL:CODEARRAY) IL:OF REFMAP))) + (IL:FOR LOC IL:IN (IL:FETCH (IL:REFMAP IL:DEFLOCS) IL:OF REFMAP) + IL:DO (IL:CODEBASESETATOM BASE LOC (IL:NEW-SYMBOL-CODE TO ( + IL:\\ATOMDEFINDEX + TO))))))) + +(DEFUN CHANGE-CALLS-IN-LAMBDA (FROM TO LAMBDA-FORM) + +(IL:* IL:|;;;| "Wrap all of the right parts of the given LAMBDA-FORM in the proper %WITH-CHANGED-CALLS forms changing calls to FROM into calls to TO. Actually side-effect the LAMBDA-FORM to make this change.") + + (ECASE (CAR LAMBDA-FORM) + ((IL:LAMBDA IL:NLAMBDA) (SETF (CDDR LAMBDA-FORM) + (ADD-CHANGED-CALL FROM TO (CDDR LAMBDA-FORM)))) + ((LAMBDA) (IL:* IL:\; "For Common Lisp functions, we have to be careful to wrap up the init-forms for any &OPTIONAL, &KEY, and &AUX parameters.") + (LET ((STATE :REQUIRED)) + (IL:|for| PARAM IL:|in| (SECOND LAMBDA-FORM) + IL:|do| (COND + ((CONSP PARAM) + (WHEN (AND (CONSP (CDR PARAM)) + (MEMBER STATE '(&OPTIONAL &KEY &AUX) + :TEST + 'EQ)) + (SETF (SECOND PARAM) + (CAR (ADD-CHANGED-CALL FROM TO (LIST (SECOND PARAM))) + )))) + ((MEMBER PARAM '(&OPTIONAL &REST &KEY &AUX) + :TEST + 'EQ) + (SETQ STATE PARAM)))) + (SETF (CDDR LAMBDA-FORM) + (ADD-CHANGED-CALL FROM TO (CDDR LAMBDA-FORM)))))) + NIL) + +(DEFUN ADD-CHANGED-CALL (FROM TO BODY) + +(IL:* IL:|;;;| "BODY is a list of forms in which calls to FROM should be changed into calls to TO. If the BODY contains a single form that is a call to the macro SI::%WITH-CHANGED-CALLS, then we just side-effect that form to add another (FROM . TO) pair. Otherwise, we wrap up the BODY in a new call to SI::%WITH-CHANGED-CALLS. In either case, we return a list of the SI::%WITH-CHANGED-CALLS form.") + +(IL:* IL:|;;;| "Actually, I lied. If it's already a SI::%WITH-CHANGED-CALLS form, and the pair (TO . FROM) is in the list of changes, then we simply remove it from the list. If the list is now empty, then we remove the SI::%WITH-CHANGED-CALLS form entirely and actually return the former body of the macro-call.") + +(IL:* IL:|;;;| "The effect of this is that you can undo previous additions simply by exchanging the FROM and TO arguments to this function.") + + (COND + ((AND (NULL (REST BODY)) + (EQ (CAR (FIRST BODY)) + '%WITH-CHANGED-CALLS)) + + (IL:* IL:|;;| "It's already a call to %WITH-CHANGED-CALLS.") + + (LET ((WCC-FORM (FIRST BODY))) + (COND + ((MEMBER (CONS TO FROM) + (SECOND WCC-FORM) + :TEST + 'EQUAL) + + (IL:* IL:|;;| "We're undoing a previous call to ADD-CHANGED-CALL.") + + (COND + ((NULL (REST (SECOND WCC-FORM))) (IL:* IL:\; + "There won't be anything left, so return the old body.") + (CDDR WCC-FORM)) + (T (IL:* IL:\; + "Oh, well, there'll still be something there. Just remove the particular pair.") + (SETF (SECOND WCC-FORM) + (DELETE (CONS TO FROM) + (SECOND WCC-FORM) + :TEST + 'EQUAL)) + (LIST WCC-FORM)))) + (T (PUSH (CONS FROM TO) + (SECOND WCC-FORM)) + (LIST WCC-FORM))))) + (T + (IL:* IL:|;;| "It's not already a %WITH-CHANGED-CALLS form, so make it into one.") + + `((%WITH-CHANGED-CALLS (,(CONS FROM TO)) + ,@BODY))))) + +(DEFMACRO %WITH-CHANGED-CALLS (A-LIST &BODY BODY) + `(MACROLET ,(IL:FOR PAIR IL:IN A-LIST + IL:COLLECT `(,(CAR PAIR) + (&REST ARGS) + (CONS ',(CDR PAIR) + ARGS))) + ,@BODY)) + +(DEFUN RESTORE-CALLS (FN) + (IL:|for| ENTRY IL:|in| (GET FN 'IL:NAMESCHANGED) + IL:|do| (XCL:DESTRUCTURING-BIND (FROM TO FIXER) + ENTRY + (CHANGE-CALLS TO FROM FN 'RESTORE-CALLS) + (FUNCALL FIXER FROM TO FN))) + (AND (REMPROP FN 'IL:NAMESCHANGED) + T)) +(IL:DEFINEQ + +(il:virginfn + (il:lambda (il:fn il:make-virgin?) (il:* il:\; "Edited 13-Apr-87 14:32 by Pavel") + (prog ((il:broken-defn (il:getprop il:fn 'il:broken)) + (il:advised-defn (il:getprop il:fn 'il:advised)) + (il:changed-names (il:getprop il:fn 'il:nameschanged)) + (il:expr-defn (il:getprop il:fn 'il:expr)) + il:real-defn) + (il:if il:make-virgin? + il:then + + (il:* il:|;;| "We're supposed to return the function to its virgin state, without any breaks, advice, or changed names.") + + (il:if il:broken-defn + il:then (xcl:unbreak-function il:fn) + (format *terminal-io* "~S unbroken.~%" il:fn)) + (il:if il:advised-defn + il:then (il:apply 'il:unadvise (list il:fn)) + (format *terminal-io* "~S unadvised.~%" il:fn)) + (il:if il:changed-names + il:then (restore-calls il:fn) + (format *terminal-io* "Names restored in ~S.~%" il:fn)) + (il:setq il:real-defn (il:getd il:fn)) + (il:if (and (not (il:exprp il:real-defn)) + (not (null il:expr-defn))) + il:then (il:setq il:real-defn il:expr-defn)) + (return il:real-defn) + il:else + + (il:* il:|;;| "We're not supposed to change the state of the function with respect to breaking, advising or changed names. We're just supposed to return the real, core definition.") + + (il:setq il:real-defn (il:getd (or il:advised-defn il:broken-defn il:fn))) + (il:if (or (il:nlistp il:real-defn) + (il:nlistp (cdr il:real-defn))) + il:then (return (or il:expr-defn il:real-defn)) + il:else (il:if il:changed-names + il:then (il:setq il:real-defn (il:copy il:real-defn)) + (il:for il:x il:in il:changed-names + il:do (xcl:destructuring-bind (il:from il:to) + il:x + (change-calls-in-lambda il:to il:from + il:real-defn)))) + (return il:real-defn)))))) + +(construct-middle-man + (lambda (object-fn in-fn) + (block construct-middle-man (let ((*print-case* :upcase)) + (intern (format nil "~A in ~A::~A" object-fn + (package-name (symbol-package in-fn)) + in-fn) + (symbol-package object-fn)))))) +) + +(IL:PUTPROPS IL:NAMESCHANGED IL:PROPTYPE IGNORE) + + + +(IL:* IL:|;;| "Arrange for the proper compiler and package/readtable.") + + +(IL:PUTPROPS IL:WRAPPERS IL:FILETYPE :FAKE-COMPILE-FILE) + +(IL:PUTPROPS IL:WRAPPERS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SI")) +(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY + +(IL:FILESLOAD (IL:LOADCOMP) + IL:ACODE) +) +(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS + +(IL:ADDTOVAR IL:NLAMA ) + +(IL:ADDTOVAR IL:NLAML ) + +(IL:ADDTOVAR IL:LAMA ) +) +(IL:PRETTYCOMPRINT IL:WRAPPERSCOMS) + +(IL:RPAQQ IL:WRAPPERSCOMS + ((IL:FUNCTIONS COMPILED-FUNCTION-ARGLIST COMPILED-FUNCTION-DEBUGGING-INFO + COMPILED-FUNCTION-INTERLISP? FUNCTION-WRAPPER-INFO CLEAN-UP-CL-ARGLIST + GET-STORED-ARGLIST NAMED-FUNCTION-WRAPPER-INFO PARSE-CL-ARGLIST) + (IL:FUNCTIONS HAS-CALLS CHANGE-CALLS CHANGE-CALLS-IN-CCODE CHANGE-CALLS-IN-LAMBDA + ADD-CHANGED-CALL %WITH-CHANGED-CALLS RESTORE-CALLS) + (IL:FNS IL:VIRGINFN CONSTRUCT-MIDDLE-MAN) + (IL:PROP IL:PROPTYPE IL:NAMESCHANGED) + + (IL:* IL:|;;| "Arrange for the proper compiler and package/readtable.") + + (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) + IL:WRAPPERS) + (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:LOADCOMP) + IL:ACODE)) + (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS + (IL:ADDVARS (IL:NLAMA) + (IL:NLAML) + (IL:LAMA CONSTRUCT-MIDDLE-MAN))))) +(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS + +(IL:ADDTOVAR IL:NLAMA ) + +(IL:ADDTOVAR IL:NLAML ) + +(IL:ADDTOVAR IL:LAMA CONSTRUCT-MIDDLE-MAN) +) +(IL:PUTPROPS IL:WRAPPERS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1993 1994)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL (22537 25612 (IL:VIRGINFN 22550 . 25161) (CONSTRUCT-MIDDLE-MAN 25163 . 25610))))) +IL:STOP diff --git a/sources/WTFIX b/sources/WTFIX new file mode 100644 index 00000000..a103eff4 --- /dev/null +++ b/sources/WTFIX @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "18-May-90 01:12:06" |{DSK}local>lde>lispcore>sources>WTFIX.;2| 8078 |changes| |to:| (VARS WTFIXCOMS) |previous| |date:| "24-Mar-88 10:35:24" |{DSK}local>lde>lispcore>sources>WTFIX.;1|) ; Copyright (c) 1982, 1983, 1985, 1986, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT WTFIXCOMS) (RPAQQ WTFIXCOMS ((FNS FINDATOM FIXAPPLY1 FIXLISPX/) (SPECVARS TYPE-IN? VARS EXPR PARENT BREAKFLG SUBPARENT FORMSFLG TAIL HELPFIXTAIL HELPFIXFLG TYPE-IN? VARS EXPR PARENT) (GLOBALVARS CLEARSTKLST SPELLINGS2 USERWORDS SPELLINGS3 LISPXHISTORY))) (DEFINEQ (FINDATOM (LAMBDA (ATOM POS BLIP) (* |J.Gibbons| " 9-Jun-83 23:27") (* |;;| "Returns TAIL for which atom is CAR. If found on *form* BLIP, also sets free variable PARENT to this form.") (PROG (XTAIL TEM NAME REALPOS) (COND ((NULL BLIP)) ((SETQ XTAIL (FMEMB ATOM (LISTP BLIP))) (SETQ PARENT BLIP) (SETQ SUBPARENT (AND (OR (EQ (CAR PARENT) 'SETQ) (EQ (CAR PARENT) 'SAVESETQ)) (CDDR PARENT))) (RETURN XTAIL))) (* |;;| "The EQ checks for no eval-blip on the stack, the NULL check checks for whether ATM is in that binding. In either case, must try something else.") (COND ((EQ (SETQ NAME (STKNAME (SETQ REALPOS (SELECTQ (SYSTEMTYPE) ((D JERICHO) (* \;  "Skip over internal interpreter frames") (REALSTKNTH -1 POS T)) POS)))) 'PROG) (* \;  "Error of form (PROG (mumble (VAR U.B.A.) mumble) mumble)") (SOME (CADR (LISTP BLIP)) (FUNCTION (LAMBDA (X) (AND (LISTP X) (SETQ XTAIL (FMEMB ATOM (SETQ PARENT X))))))) (SETQ SUBPARENT XTAIL)) ((EQ ATOM (CAR (SETQ TEM (BLIPVAL '*TAIL* POS)))) (* |;;| "U.B.A. occurs at top level of COND clause but in consequent, e.g. (COND (& .. U.B.A. ..)), or at top level of SELECTQ clause, e.g. (SELECTQ & .. (& .. U.B.A.) ..), or at top level of lambda expression.") (SETQ XTAIL TEM) (COND ((EXPRP NAME) (SETQ PARENT (COND ((LISTP NAME) (* |;;| "open lambda expression, e.g. error occurred at top level of lambda expression which was passed as functonal argument and then apply'ed.") NAME) ((LITATOM NAME) (FGETD NAME)) (T (HELP 'FINDATOM)))) (SETQ SUBPARENT (AND (EQ XTAIL (CDDR PARENT)) XTAIL))) ((SETQ FORMSFLG (EQ NAME 'COND)) (SETQ PARENT (CAR (SOME (STKARG 1 REALPOS) (FUNCTION (LAMBDA (X) (TAILP XTAIL X))))))) ((AND (EQ NAME 'PROGN) (EQ (STKNAME (SETQ REALPOS (FSTKNTH -2 REALPOS REALPOS))) 'SELECTQ) (SETQ PARENT (CAR (SOME (STKARG 1 REALPOS) (FUNCTION (LAMBDA (X) (TAILP XTAIL X))))))) (* |;;| "SELECTQs are a mess: e.g. (SELECTQ X (key ... atom_ (expr) ...)) in this case, need to find the tail of the SELECTQ and it is not bound anywhere easily accessible on the stack. SELECTQs are implemented via a call to PROGN from APPLY") (SETQ SUBPARENT (AND (EQ XTAIL (CDR PARENT)) XTAIL))))) ((AND (LISTP TEM) (EQ ATOM (CAAR TEM))) (* \;  "This is necessary for u.b.a.'s as predicate in COND clause, e.g. (COND .. (U.B.A. ..))") (SETQ PARENT (SETQ XTAIL (CAR TEM))) (SETQ FORMSFLG T)) ((AND (LISTP EXPR) (SETQ XTAIL (FMEMB ATOM (SETQ PARENT EXPR)))) (* |;;| "Desperation. Will work for case like SETQ (FOO 8CONS A B) where there is no higher PARENT containing ATM, but it is contained in EXPR.") (SETQ SUBPARENT (AND (EQ XTAIL (CDR PARENT)) XTAIL)) (SETQ FORMSFLG T) (* \;  "e.g. EDITFNS (' (FOO FIE) --) should go to ((QUOTE --)) not (QUOTE ---)") )) (SELECTQ (SYSTEMTYPE) ((D JERICHO) (RELSTK REALPOS)) NIL) (RETURN (AND PARENT XTAIL))))) (FIXAPPLY1 (LAMBDA (POS OLD NEW *FORM*BLIP) (* |lmm| "11-JUN-81 11:32") (* |;;| "Analagous to FINDATOM. Finds the XTAIL for which the u.d.f. OLD is CAR, and replaces it with NEW. Also changes places where OLD appears on the stack to NEW. Sets PARENT to be the element containing OLD, and returns with the TAIL. Releases POS in all cases.") (PROG (XTAIL LST) (PROG ((N (STKNARGS POS))) LP (COND ((ZEROP N) (RETURN)) ((EQ (FSTKARG N POS) OLD) (SETSTKARG N POS NEW))) (SETQ N (SUB1 N)) (GO LP)) NX (* |;;| "Attempts to find the occurrence of the u.d.f. in the user's program, e.g. if (MAPC X (FUNCTION PRINNT)) caused the error, this will change (FUNCTION PRINNT) to (FUNCTION PRINT)") (COND ((EQ (CAAAAR LISPXHISTORY) OLD) (GO OUT))) (SETQ LST (COND (TYPE-IN? EXPR) (T (OR *FORM*BLIP (BLIPVAL '*FORM* POS))))) (* |;;| "POS0 is used because want to find the form from which the function before FAULTAPPLY, e.g. MAPC, was called.") (COND ((SOME (CDR LST) (FUNCTION (LAMBDA (X) (AND (EQ (CAR X) 'FUNCTION) (EQ (CADR X) OLD) (SETQ XTAIL (CDR X)))))) (SETQ PARENT LST)) ((AND (LISTP EXPR) (SETQ XTAIL (FMEMB OLD EXPR))) (* \;  "Second case corresponds to where MAPC ((A B C) PRINNT) is typed in.") ) (T (GO OUT))) (/RPLNODE XTAIL NEW (CDR XTAIL)) OUT (RELSTK POS) (RETURN XTAIL)))) (FIXLISPX/ (LAMBDA (X FN) (* \; "wt: 25-FEB-76 2 2") (COND ((NULL TYPE-IN?) X) (T (LISPX/ X FN VARS))))) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (SPECVARS TYPE-IN? VARS EXPR PARENT BREAKFLG SUBPARENT FORMSFLG TAIL HELPFIXTAIL HELPFIXFLG TYPE-IN? VARS EXPR PARENT) ) (DECLARE\: DOEVAL@COMPILE DONTCOPY (GLOBALVARS CLEARSTKLST SPELLINGS2 USERWORDS SPELLINGS3 LISPXHISTORY) ) (PUTPROPS WTFIX COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1985 1986 1988 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL (755 7696 (FINDATOM 765 . 5496) (FIXAPPLY1 5498 . 7508) (FIXLISPX/ 7510 . 7694))))) STOP \ No newline at end of file diff --git a/sources/XCL-COMPILER b/sources/XCL-COMPILER new file mode 100644 index 00000000..ba377c6c --- /dev/null +++ b/sources/XCL-COMPILER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "18-May-90 01:13:35" {DSK}local>lde>lispcore>sources>XCL-COMPILER.;2 2600 changes to%: (VARS XCL-COMPILERCOMS) previous date%: "17-Dec-86 21:01:52" {DSK}local>lde>lispcore>sources>XCL-COMPILER.;1) (* ; " Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT XCL-COMPILERCOMS) (RPAQQ XCL-COMPILERCOMS ( (* ;; "The Xerox Common Lisp compiler") (FILES XCLC-RUNTIME (* ; "Run-time support functions.") XCLC-ENV-CTXT (* ; "Environments and contexts.") XCLC-TREES (* ; "Program trees.") XCLC-TOP-LEVEL (* ;  "Entry points and top-level file processing.") XCLC-ALPHA (* ; "Alphatization.") XCLC-OPTIMIZERS (* ; "Internal optimizers.") XCLC-ANALYZE (* ; "Program analysis.") XCLC-META-EVAL (* ; "Meta-evaluation.") XCLC-TRANSFORMS (* ;  "Function-specific transformations.") XCLC-DATABASE (* ; "Function-property database.") XCLC-ANNOTATE (* ; "Tree annotation.") XCLC-GENCODE (* ; "Code generation.") XCLC-PEEPHOLE (* ; "Peephole optimization.")))) (* ;; "The Xerox Common Lisp compiler") (FILESLOAD XCLC-RUNTIME XCLC-ENV-CTXT XCLC-TREES XCLC-TOP-LEVEL XCLC-ALPHA XCLC-OPTIMIZERS XCLC-ANALYZE XCLC-META-EVAL XCLC-TRANSFORMS XCLC-DATABASE XCLC-ANNOTATE XCLC-GENCODE XCLC-PEEPHOLE) (PUTPROPS XCL-COMPILER COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/XCL-EXTRAS b/sources/XCL-EXTRAS new file mode 100644 index 00000000..3b0a92d3 --- /dev/null +++ b/sources/XCL-EXTRAS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL") (IL:FILECREATED "18-May-90 01:15:40" IL:|{DSK}local>lde>lispcore>sources>XCL-EXTRAS.;2| 15315 IL:|changes| IL:|to:| (IL:VARS IL:XCL-EXTRASCOMS) IL:|previous| IL:|date:| "11-Jan-88 16:59:17" IL:|{DSK}local>lde>lispcore>sources>XCL-EXTRAS.;1|) ; Copyright (c) 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCL-EXTRASCOMS) (IL:RPAQQ IL:XCL-EXTRASCOMS ( (IL:* IL:|;;| " Finess the define-file-info problem") (IL:DEFINE-TYPES FILE-ENVIRONMENTS) (IL:FUNCTIONS DEFINE-FILE-ENVIRONMENT) (IL:* IL:|;;| "Macro for writing macros ") (IL:FUNCTIONS ONCE-ONLY) (IL:* IL:|;;| "CL veneer on IL record module") (IL:FUNCTIONS RECORD-FETCH SETF-FETCH RECORD-FFETCH SETF-FFETCH RECORD-CREATE) (IL:SETFS RECORD-FETCH RECORD-FFETCH) (IL:* IL:|;;| "An alternate version of the above") (IL:FUNCTIONS DEFINE-RECORD) (IL:FUNCTIONS RECORD-ACCESS-MACRO SETF-RECORD-ACCESS-MACRO RECORD-PREDICATE-MACRO RECORD-CONSTRUCTOR-MACRO) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:XCL-EXTRAS))) (IL:* IL:|;;| " Finess the define-file-info problem") (DEF-DEFINE-TYPE FILE-ENVIRONMENTS "File info") (DEFDEFINER DEFINE-FILE-ENVIRONMENT FILE-ENVIRONMENTS (FILE &KEY READTABLE PACKAGE BASE COMPILER) (LET ((ROOTNAME (INTERN (STRING FILE) (FIND-PACKAGE "INTERLISP")))) `(EVAL-WHEN (EVAL LOAD) ,@(IF (OR READTABLE PACKAGE BASE) `((SETF (GET ',ROOTNAME 'IL:MAKEFILE-ENVIRONMENT) '(,@(IF READTABLE `(:READTABLE ,READTABLE)) ,@(IF PACKAGE `(:PACKAGE ,PACKAGE)) ,@(IF BASE `(:BASE ,BASE)))))) ,@(IF COMPILER `((SETF (GET ',ROOTNAME 'IL:FILETYPE) ',COMPILER)))))) (IL:* IL:|;;| "Macro for writing macros ") (DEFMACRO ONCE-ONLY (VARS &BODY BODY) (IL:* IL:|;;;| "ONCE-ONLY assures that the forms given as vars are evaluated in the proper order, once only. Used in the body of macro definitions. Taken from Zeta Lisp.") (LET* ((GENSYM-VAR (GENSYM)) (RUN-TIME-VARS (GENSYM)) (RUN-TIME-VALS (GENSYM)) (EXPAND-TIME-VAL-FORMS (MAPCAR #'(LAMBDA (VAR) `(IF (OR (SYMBOLP ,VAR) (CONSTANTP ,VAR)) ,VAR (LET ((,GENSYM-VAR (GENSYM))) (PUSH ,GENSYM-VAR ,RUN-TIME-VARS) (PUSH ,VAR ,RUN-TIME-VALS) ,GENSYM-VAR))) VARS))) `(,'LET* (,RUN-TIME-VARS ,RUN-TIME-VALS (WRAPPED-BODY (,'LET ,(WITH-COLLECTION (DO ((VAR VARS (CDR VAR)) (EXPAND-TIME-VAL-FORM EXPAND-TIME-VAL-FORMS (CDR EXPAND-TIME-VAL-FORM))) ((NULL VAR)) (COLLECT (LIST (CAR VAR) (CAR EXPAND-TIME-VAL-FORM ))))) ,@BODY))) `(,'LET ,(WITH-COLLECTION (DO ((RUN-TIME-VAR (REVERSE ,RUN-TIME-VARS) (CDR RUN-TIME-VAR)) (RUN-TIME-VAL (REVERSE ,RUN-TIME-VALS) (CDR RUN-TIME-VAL))) ((NULL RUN-TIME-VAR)) (COLLECT (LIST (CAR RUN-TIME-VAR) (CAR RUN-TIME-VAL))))) ,WRAPPED-BODY)))) (IL:* IL:|;;| "CL veneer on IL record module") (DEFMACRO RECORD-FETCH (RECORD FIELD OBJECT) (LET ((IL-RECORD (INTERN (STRING RECORD) IL:*INTERLISP-PACKAGE*)) (IL-FIELD (INTERN (STRING FIELD) IL:*INTERLISP-PACKAGE*))) `(IL:|fetch| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT))) (DEFMACRO SETF-FETCH (RECORD FIELD OBJECT NEW-VALUE) (LET ((IL-RECORD (INTERN (STRING RECORD) IL:*INTERLISP-PACKAGE*)) (IL-FIELD (INTERN (STRING FIELD) IL:*INTERLISP-PACKAGE*))) `(IL:|replace| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT IL:|with| ,NEW-VALUE))) (DEFMACRO RECORD-FFETCH (RECORD FIELD OBJECT) (LET ((IL-RECORD (INTERN (STRING RECORD) IL:*INTERLISP-PACKAGE*)) (IL-FIELD (INTERN (STRING FIELD) IL:*INTERLISP-PACKAGE*))) `(IL:|ffetch| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT))) (DEFMACRO SETF-FFETCH (RECORD FIELD OBJECT NEW-VALUE) (LET ((IL-RECORD (INTERN (STRING RECORD) IL:*INTERLISP-PACKAGE*)) (IL-FIELD (INTERN (STRING FIELD) IL:*INTERLISP-PACKAGE*))) `(IL:|freplace| (,IL-RECORD ,IL-FIELD) IL:|of| ,OBJECT IL:|with| ,NEW-VALUE))) (DEFMACRO RECORD-CREATE (RECORD &REST KEYWORD-PAIRS) (LET ((IL-RECORD (INTERN (STRING RECORD) IL:*INTERLISP-PACKAGE*))) `(IL:|create| ,IL-RECORD ,@(WITH-COLLECTION (DO ((KEYWORD KEYWORD-PAIRS (CDDR KEYWORD)) (VALUE (CDR KEYWORD-PAIRS) (CDDR VALUE)) KEYWORD-SYMBOL) ((NULL KEYWORD)) (SETQ KEYWORD-SYMBOL (INTERN (STRING (CAR KEYWORD)) IL:*INTERLISP-PACKAGE*)) (COLLECT KEYWORD-SYMBOL) (IF (NOT (MEMBER KEYWORD-SYMBOL '(IL:USING IL:COPYING IL:REUSING IL:SMASHING ) :TEST #'EQ)) (COLLECT 'IL:_)) (COLLECT (CAR VALUE))))))) (DEFSETF RECORD-FETCH SETF-FETCH) (DEFSETF RECORD-FFETCH SETF-FFETCH) (IL:* IL:|;;| "An alternate version of the above") (DEFDEFINER DEFINE-RECORD IL:STRUCTURES (RECORD-NAME INTERLISP-RECORD-NAME &KEY (CONC-NAME NIL CONC-NAME-P ) (CONSTRUCTOR NIL CONSTRUCTOR-P) (PREDICATE NIL PREDICATE-P) (FAST-ACCESSORS NIL) (PACKAGE *PACKAGE*)) (IF (NOT (PACKAGEP PACKAGE)) (SETQ PACKAGE (FIND-PACKAGE PACKAGE))) (SETQ CONC-NAME (IF CONC-NAME-P (IF CONC-NAME (STRING CONC-NAME) "") (CONCATENATE 'STRING (STRING RECORD-NAME) "-"))) (LET ((DECLARATION (IL:RECLOOK INTERLISP-RECORD-NAME)) (FIELD-NAMES (IL:RECORDFIELDNAMES INTERLISP-RECORD-NAME))) (IF (NULL DECLARATION) (ERROR "Record ~s not yet defined." INTERLISP-RECORD-NAME)) `(EVAL-WHEN (COMPILE LOAD EVAL) ,@(MAPCAN #'(LAMBDA (FIELD-NAME) (WHEN FIELD-NAME (LET ((NEW-NAME (INTERN (CONCATENATE 'STRING CONC-NAME (STRING FIELD-NAME )) PACKAGE))) `((SETF (MACRO-FUNCTION ',NEW-NAME) 'RECORD-ACCESS-MACRO) (CL::SET-SHARED-SETF-INVERSE ',NEW-NAME 'SETF-RECORD-ACCESS-MACRO) (SETF (GET ',NEW-NAME :SLOT-INFO) ',`((,INTERLISP-RECORD-NAME ,FIELD-NAME) ,FAST-ACCESSORS)))))) FIELD-NAMES) ,@(LET ((NEW-NAME (IF PREDICATE-P PREDICATE (INTERN (CONCATENATE 'STRING (STRING RECORD-NAME) "-P") PACKAGE)))) (WHEN (AND NEW-NAME (OR (EQ (CAR DECLARATION) 'IL:DATATYPE) (FIND-IF #'(LAMBDA (CLAUSE) (AND (CONSP CLAUSE) (OR (EQ (CAR CLAUSE) 'IL:TYPE?) (EQ (CAR CLAUSE) 'IL:|type?|)))) DECLARATION))) `((SETF (MACRO-FUNCTION ',NEW-NAME) 'RECORD-PREDICATE-MACRO) (SETF (GET ',NEW-NAME :TYPE-INFO) ',INTERLISP-RECORD-NAME)))) ,@(LET ((NEW-NAME (IF CONSTRUCTOR-P CONSTRUCTOR (INTERN (CONCATENATE 'STRING "MAKE-" (STRING RECORD-NAME)) PACKAGE)))) (WHEN (AND NEW-NAME (OR (NOT (MEMBER (CAR DECLARATION) '(IL:BLOCKRECORD IL:ACCESSFNS IL:ATOMRECORD) :TEST #'EQ)) (FIND-IF #'(LAMBDA (CLAUSE) (IF (CONSP CLAUSE) (OR (EQ (CAR CLAUSE) 'IL:CREATE) (EQ (CAR CLAUSE) 'IL:|create|)) (EQ CLAUSE INTERLISP-RECORD-NAME))) (CDDR DECLARATION)))) `((SETF (MACRO-FUNCTION ',NEW-NAME) 'RECORD-CONSTRUCTOR-MACRO) (SETF (GET ',NEW-NAME :FIELD-INFO) '(,INTERLISP-RECORD-NAME ,FIELD-NAMES)))))))) (DEFUN RECORD-ACCESS-MACRO (FORM &OPTIONAL ENV) (DECLARE (IGNORE ENV)) (DESTRUCTURING-BIND (SPECIFIER FAST-ACCESSOR-P) (OR (GET (CAR FORM) :SLOT-INFO) (ERROR "No slot information cached.")) (IF FAST-ACCESSOR-P `(IL:|ffetch| ,SPECIFIER IL:|of| ,(SECOND FORM)) `(IL:|fetch| ,SPECIFIER IL:|of| ,(SECOND FORM))))) (CL::DEFINE-SHARED-SETF-MACRO SETF-RECORD-ACCESS-MACRO ACCESSOR (DATUM) (NEW-VALUE) (DESTRUCTURING-BIND (SPECIFIER FAST-ACCESSOR-P) (OR (GET ACCESSOR :SLOT-INFO) (ERROR "No slot information cached.")) (IF FAST-ACCESSOR-P `(IL:|freplace| ,SPECIFIER IL:|of| ,DATUM IL:|with| ,NEW-VALUE) `(IL:|replace| ,SPECIFIER IL:|of| ,DATUM IL:|with| ,NEW-VALUE)))) (DEFUN RECORD-PREDICATE-MACRO (FORM &OPTIONAL ENV) (DECLARE (IGNORE ENV)) `(IL:|type?| ,(OR (GET (CAR FORM) :TYPE-INFO) (ERROR "No type information cached.")) ,(SECOND FORM))) (DEFUN RECORD-CONSTRUCTOR-MACRO (FORM &OPTIONAL ENV) (DECLARE (IGNORE ENV)) (DESTRUCTURING-BIND (TYPE FIELD-NAMES) (OR (GET (CAR FORM) :FIELD-INFO) (ERROR "No field information cached.")) `(IL:|create| ,TYPE ,@(WITH-COLLECTION (DO* ((KEYWORD (CDR FORM) (CDDR KEYWORD)) (KEYWORD-SYMBOL (CAR KEYWORD) (CAR KEYWORD)) (VALUE (CADR KEYWORD) (CADR KEYWORD)) RESERVED-WORD) ((NULL KEYWORD)) (SETQ RESERVED-WORD (CAR (MEMBER KEYWORD-SYMBOL '(IL:USING IL:COPYING IL:REUSING IL:SMASHING) :TEST 'STRING=))) (COLLECT (OR RESERVED-WORD (CAR (MEMBER KEYWORD-SYMBOL FIELD-NAMES :TEST 'STRING=)))) (IF (NOT RESERVED-WORD) (COLLECT 'IL:_)) (COLLECT VALUE)))))) (IL:PUTPROPS IL:XCL-EXTRAS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:XCL-EXTRAS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL")) (IL:PUTPROPS IL:XCL-EXTRAS IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCL-PACKAGE b/sources/XCL-PACKAGE new file mode 100644 index 00000000..05e73cab --- /dev/null +++ b/sources/XCL-PACKAGE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE (DEFPACKAGE "XCL" (USE))) (IL:FILECREATED "14-Jun-90 15:54:35" IL:|{PELE:MV:ENVOS}SOURCES>XCL-PACKAGE.;3| 16820 IL:previous IL:date%: "18-May-90 01:18:05" IL:|{PELE:MV:ENVOS}SOURCES>XCL-PACKAGE.;2| ) (IL:* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (IL:PRETTYCOMPRINT IL:XCL-PACKAGECOMS) (IL:RPAQQ IL:XCL-PACKAGECOMS ( (IL:* IL:;;; "Setting up the XCL package.") (IL:FUNCTIONS LISP::DEFECT-FROM-IL-TO-XCL LISP::CHECK-ALL) (IL:VARIABLES LISP::FUTURE-CITIZENS-OF-XCL) (IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY (IL:P (IL:* IL:;; "New exports from XCL should go in the EXPORT clause here") (DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" "CONDITIONS") (:NICKNAMES "XCL") (:PREFIX-NAME "XCL") (:EXPORT ARGLIST SET-EXEC-TYPE SET-DEFAULT-EXEC-TYPE SYNONYM-STREAM-P SYNONYM-STREAM-SYMBOL FOLLOW-SYNONYM-STREAMS BROADCAST-STREAM-P BROADCAST-STREAM-STREAMS CONCATENATED-STREAM-P CONCATENATED-STREAM-STREAMS TWO-WAY-STREAM-P TWO-WAY-STREAM-INPUT-STREAM TWO-WAY-STREAM-OUTPUT-STREAM ECHO-STREAM-P ECHO-STREAM-INPUT-STREAM ECHO-STREAM-OUTPUT-STREAM STRING-STREAM-P OPEN-STREAM-P *CURRENT-CONDITION* *EVAL-FUNCTION* *EXEC-PROMPT* *DEBUGGER-PROMPT* MAKE-PROFILE RESTORE-PROFILE SAVE-PROFILE WITH-PROFILE COPY-PROFILE PROFILE-NAME PROFILE-P FIND-PROFILE LIST-ALL-PROFILES DEFPROFILE PROFILES *DEFAULT-PROFILE* *PROFILE* PACK PACK* *PRINT-STRUCTURE* DO-INTERNAL-SYMBOLS PKG-GOTO READ-CONFLICT READ-CONFLICT-NAME READ-CONFLICT-PACKAGES MISSING-EXTERNAL-SYMBOL MISSING-EXTERNAL-SYMBOL-NAME MISSING-EXTERNAL-SYMBOL-PACKAGE MISSING-PACKAGE MISSING-PACKAGE-PACKAGE-NAME MISSING-PACKAGE-SYMBOL-NAME MISSING-PACKAGE-EXTERNAL PACKAGE-ERROR PACKAGE-ERROR-PACKAGE SYMBOL-CONFLICT SYMBOL-CONFLICT-SYMBOLS USE-CONFLICT USE-CONFLICT-USED-PACKAGE EXPORT-CONFLICT EXPORT-CONFLICT-EXPORTED-SYMBOLS SYMBOL-COLON-ERROR ESCAPE-COLONS-PROCEED EXPORT-CONFLICT-PACAKGES EXPORT-MISSING EXPORT-MISSING-SYMBOLS IMPORT-CONFLICT UNINTERN-CONFLICT UNINTERN-CONFLICT-SYMBOL PREFER-CLSYM-PROCEED RETURN-CLSYM-PROCEED PREFER-ILSYM-PROCEED RETURN-ILSYM-PROCEED MAKE-EXTERNAL-PROCEED MAKE-INTERNAL-PROCEED NEW-PACKAGE-PROCEED UGLY-SYMBOL-PROCEED SHADOW-USE-CONFLICTS-PROCEED UNINTERN-USER-PROCEED UNINTERN-USEE-PROCEED UNINTERN-PROCEED IMPORT-PROCEED SHADOWING-IMPORT-PROCEED *TRACE-IO* HASH-TABLE-FULL HASH-TABLE-FULL-TABLE ATTEMPT-TO-CHANGE-CONSTANT ATTEMPT-TO-CHANGE-CONSTANT-NAME ATTEMPT-TO-RPLAC-NIL ATTEMPT-TO-RPLAC-NIL-NAME TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR SIMPLE-TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR-CULPRIT STREAM-NOT-OPEN STREAM-NOT-OPEN-STREAM SYMBOL-NAME-TOO-LONG SYMBOL-NAME-TOO-LONG-STREAM SYMBOL-HT-FULL ARRAY-SPACE-FULL DATA-TYPES-EXHAUSTED DEVICE-ERROR DEVICE-ERROR-DEVICE SIMPLE-DEVICE-ERROR SIMPLE-DEVICE-ERROR-DEVICE SIMPLE-DEVICE-ERROR-MESSAGE FS-ERROR FILE-WONT-OPEN FILE-WONT-OPEN-PATHNAME FS-RESOURCES-EXCEEDED FS-PROTECTION-VIOLATION ARITHMETIC-ERROR ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS FLOATING-OVERFLOW FLOATING-OVERFLOW-OPERATION FLOATING-OVERFLOW-OPERANDS FLOATING-UNDERFLOW FLOATING-UNDERFLOW-OPERATION FLOATING-UNDERFLOW-OPERANDS PATHNAME-ERROR PATHNAME-ERROR-PATHNAME FILE-NOT-FOUND FILE-NOT-FOUND-PATHNAME INVALID-PATHNAME INVALID-PATHNAME-PATHNAME CONTROL-E-INTERRUPT CONTROL-E-INTERRUPT-FUNCTION ASSERTION-FAILED ASSERTION-FAILED-FORMAT-STRING ASSERTION-FAILED-FORMAT-ARGUMENTS BAD-PROCEED-CASE BAD-PROCEED-CASE-NAME TYPE-MISMATCH TYPE-MISMATCH-EXPECTED-TYPE TYPE-MISMATCH-VALUE TYPE-MISMATCH-MESSAGE STORAGE-EXHAUSTED CREATE-TRACE-WINDOW UNBREAK-FUNCTION REBREAK-FUNCTION TRACE-FUNCTION *TRACE-LEVEL* *TRACE-LENGTH* *TRACE-VERBOSE* INNER REINSTALL-ADVICE ADVISE-FUNCTION UNADVISE-FUNCTION READVISE-FUNCTION ADVISED-FUNCTIONS DEFADVICE WITH-COLLECTION COLLECT ONCE-ONLY *SHORT-SITE-NAME* *LONG-SITE-NAME* DEFINER NAMED-PROGN COMPILE-DEFINER COMPILE-FORM FALSE FILE-ENVIRONMENTS DEFINE-FILE-ENVIRONMENT *BREAK-ON-SIGNALS* HANDLER-CASE WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND COMPUTE-RESTARTS RESTART-NAME FIND-RESTART INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY CONTINUE MUFFLE-WARNING INVOKE-DEBUGGER RESTART TYPE-ERROR TYPE-ERROR-DATUM PROGRAM-ERROR FILE-ERROR FILE-ERROR-PATHNAME DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW ROW-MAJOR-AREF RECORD-FETCH RECORD-FFETCH RECORD-CREATE DEFINE-RECORD PACKAGE-PREFIX)) (IL:MAPC LISP::FUTURE-CITIZENS-OF-XCL 'LISP::DEFECT-FROM-IL-TO-XCL) (LISP::CHECK-ALL))) (IL:* IL:;; "Arrange for the proper makefile environment") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:XCL-PACKAGE))) (IL:* IL:;;; "Setting up the XCL package.") (DEFUN LISP::DEFECT-FROM-IL-TO-XCL (LISP::NAME) (LISP::NATURALIZE LISP::NAME (FIND-PACKAGE 'LISP::IL) (FIND-PACKAGE 'LISP::XCL))) (DEFUN LISP::CHECK-ALL () [LET ((LISP::XCLP (FIND-PACKAGE "XCL"))) (DOLIST (LISP::X LISP::FUTURE-CITIZENS-OF-XCL T) (LET* ((LISP::S (INTERN LISP::X LISP::XCLP)) (LISP::P (SYMBOL-PACKAGE LISP::S))) (IF (NOT (EQ LISP::P LISP::XCLP)) (FORMAT T "~S ~S~%%" LISP::S LISP::P))) (LET [(LISP::SL (MAPCAN [IL:FUNCTION (LAMBDA (PACKAGE) (MULTIPLE-VALUE-BIND (SYMBOL LISP::WHERE) (FIND-SYMBOL LISP::X PACKAGE) (AND SYMBOL (EQ LISP::WHERE :EXTERNAL) (LIST SYMBOL] '("IL" "XCL" "CL"] (IF (NOT (CASE (LENGTH LISP::SL) (2 (EQ (FIRST LISP::SL) (SECOND LISP::SL))) (3 (AND (EQ (FIRST LISP::SL) (SECOND LISP::SL)) (EQ (SECOND LISP::SL) (THIRD LISP::SL)))) (T T))) (ERROR "More than one version of this symbol exists: ~s~%%" LISP::SL))))]) (DEFPARAMETER LISP::FUTURE-CITIZENS-OF-XCL '( (IL:* IL:;; "new definers") "DEFCOMMAND" "DEFDEFINER" "DEFGLOBALPARAMETER" "DEFGLOBALVAR" "DEFINE-CONDITION" "DEFINE-PROCEED-FUNCTION" "DEFINLINE" "DEFOPTIMIZER" "DEFPACKAGE" "DEF-DEFINE-TYPE" "*DEFINITION-HASH-TABLE*" (IL:* IL:;; "for UNDO") "DEFINE-UNDOABLE-MODIFY-MACRO" "UNDOABLY" "UNDOABLY-SETF" "DEFINE-SPECIAL-FORM" (IL:* IL:;; "for the EXEC") "*CURRENT-EVENT*" "EXEC-ID" "*PER-EXEC-VARIABLES*" "*EXEC-MAKE-UNDOABLE-P*" "EXEC-FORMAT" "EXEC-EVAL" "EXEC" "ADD-EXEC" "EXEC-VALUE-OF" (IL:* IL:;; "for the debugger") "DEBUGGER" "PRINT-BACKTRACE" "*DEBUGGER-MENU-ITEMS*" "ENTER-DEBUGGER-P" "*DEBUGGER-ENTRY-POINTS*" "HELP" "UNBREAK" "BREAK-FUNCTION" "*TRACE-DEPTH*" (IL:* IL:;; "others in alphabetical order") "&CONTEXT" "*DEFAULT-PUSH-EXTENSION-SIZE*" "*PREFERRED-READING-SYMBOLS*" "*TOTAL-PACKAGES-LIMIT*" "ABORT" "ARRAY-NEEDS-INDIRECTION-P" "ASET" "BIT-ARRAY-P" "CATCH-ABORT" "CELL-ERROR" "CELL-ERROR-NAME" "COMPUTE-PROCEED-CASES" "CONDITION" "CONDITION-BIND" "CONDITION-CASE" "CONDITION-HANDLER" "CONDITION-REPORTER" "CONTROL-ERROR" "COPY-ARRAY" "DEBUG" "DEFAULT-PROCEED-REPORT" "DEFAULT-PROCEED-TEST" "DELETE-PACKAGE" "DESTRUCTURING-BIND" "DESTRUCTURING-SETQ" "DISPLACED-ARRAY-P" "DO-LOCAL-SYMBOLS" "END-OF-FILE" "END-OF-FILE-STREAM" "EQUAL-DIMENSIONS-P" "EXTENDABLE-ARRAY-P" "FILL-ARRAY" "FILL-VECTOR" "FIND-PROCEED-CASE" "GLOBAL" "GLOBALIZE" "HANDLER-BIND" "IGNORE-ERRORS" "ILLEGAL-GO" "ILLEGAL-GO-TAG" "ILLEGAL-RETURN" "ILLEGAL-RETURN-TAG" "ILLEGAL-THROW" "ILLEGAL-THROW-TAG" "INVOKE-PROCEED-CASE" "MAKE-CONDITION" "MAKE-VECTOR" "OPTIMIZERS" "PARSE-BODY" "PROCEED" "PROCEED-CASE" "PROCEED-CASE-NAME" "READ-ERROR" "READ-ERROR-STREAM" "READ-ONLY-ARRAY-P" "REMOVE-COMMENTS" "SERIOUS-CONDITION" "SHADOWING-USE-PACKAGE" "SIGNAL" "SIMPLE-ARRAY-P" "SIMPLE-BREAK" "SIMPLE-BREAK-FORMAT-ARGUMENTS" "SIMPLE-BREAK-FORMAT-STRING" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-ERROR-FORMAT-ARGUMENTS" "SIMPLE-ERROR-FORMAT-STRING" "SIMPLE-WARNING" "SIMPLE-WARNING-FORMAT-ARGUMENTS" "SIMPLE-WARNING-FORMAT-STRING" "STACK-OVERFLOW" "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "STRING-ARRAY-P" "TRUE" "UNBOUND-VARIABLE" "UNBOUND-VARIABLE-NAME" "UNDEFINED-FUNCTION" "UNDEFINED-FUNCTION-NAME" "USE-VALUE" "VECTOR-LENGTH" "WALK-FORM" "WALK-FORM-INTERNAL" "WALK-TEMPLATE" "WARNING") "A list of names retroactively placed in XCL; do not add to it.") (IL:DECLARE%: IL:DONTEVAL@LOAD IL:DOCOPY (IL:* IL:;; "New exports from XCL should go in the EXPORT clause here") (DEFPACKAGE "XEROX-COMMON-LISP" (:USE "LISP" "CONDITIONS") (:NICKNAMES "XCL") (:PREFIX-NAME "XCL") (:EXPORT ARGLIST SET-EXEC-TYPE SET-DEFAULT-EXEC-TYPE SYNONYM-STREAM-P SYNONYM-STREAM-SYMBOL FOLLOW-SYNONYM-STREAMS BROADCAST-STREAM-P BROADCAST-STREAM-STREAMS CONCATENATED-STREAM-P CONCATENATED-STREAM-STREAMS TWO-WAY-STREAM-P TWO-WAY-STREAM-INPUT-STREAM TWO-WAY-STREAM-OUTPUT-STREAM ECHO-STREAM-P ECHO-STREAM-INPUT-STREAM ECHO-STREAM-OUTPUT-STREAM STRING-STREAM-P OPEN-STREAM-P *CURRENT-CONDITION* *EVAL-FUNCTION* *EXEC-PROMPT* *DEBUGGER-PROMPT* MAKE-PROFILE RESTORE-PROFILE SAVE-PROFILE WITH-PROFILE COPY-PROFILE PROFILE-NAME PROFILE-P FIND-PROFILE LIST-ALL-PROFILES DEFPROFILE PROFILES *DEFAULT-PROFILE* *PROFILE* PACK PACK* *PRINT-STRUCTURE* DO-INTERNAL-SYMBOLS PKG-GOTO READ-CONFLICT READ-CONFLICT-NAME READ-CONFLICT-PACKAGES MISSING-EXTERNAL-SYMBOL MISSING-EXTERNAL-SYMBOL-NAME MISSING-EXTERNAL-SYMBOL-PACKAGE MISSING-PACKAGE MISSING-PACKAGE-PACKAGE-NAME MISSING-PACKAGE-SYMBOL-NAME MISSING-PACKAGE-EXTERNAL PACKAGE-ERROR PACKAGE-ERROR-PACKAGE SYMBOL-CONFLICT SYMBOL-CONFLICT-SYMBOLS USE-CONFLICT USE-CONFLICT-USED-PACKAGE EXPORT-CONFLICT EXPORT-CONFLICT-EXPORTED-SYMBOLS SYMBOL-COLON-ERROR ESCAPE-COLONS-PROCEED EXPORT-CONFLICT-PACAKGES EXPORT-MISSING EXPORT-MISSING-SYMBOLS IMPORT-CONFLICT UNINTERN-CONFLICT UNINTERN-CONFLICT-SYMBOL PREFER-CLSYM-PROCEED RETURN-CLSYM-PROCEED PREFER-ILSYM-PROCEED RETURN-ILSYM-PROCEED MAKE-EXTERNAL-PROCEED MAKE-INTERNAL-PROCEED NEW-PACKAGE-PROCEED UGLY-SYMBOL-PROCEED SHADOW-USE-CONFLICTS-PROCEED UNINTERN-USER-PROCEED UNINTERN-USEE-PROCEED UNINTERN-PROCEED IMPORT-PROCEED SHADOWING-IMPORT-PROCEED *TRACE-IO* HASH-TABLE-FULL HASH-TABLE-FULL-TABLE ATTEMPT-TO-CHANGE-CONSTANT ATTEMPT-TO-CHANGE-CONSTANT-NAME ATTEMPT-TO-RPLAC-NIL ATTEMPT-TO-RPLAC-NIL-NAME TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR SIMPLE-TYPE-ERROR-EXPECTED-TYPE SIMPLE-TYPE-ERROR-CULPRIT STREAM-NOT-OPEN STREAM-NOT-OPEN-STREAM SYMBOL-NAME-TOO-LONG SYMBOL-NAME-TOO-LONG-STREAM SYMBOL-HT-FULL ARRAY-SPACE-FULL DATA-TYPES-EXHAUSTED DEVICE-ERROR DEVICE-ERROR-DEVICE SIMPLE-DEVICE-ERROR SIMPLE-DEVICE-ERROR-DEVICE SIMPLE-DEVICE-ERROR-MESSAGE FS-ERROR FILE-WONT-OPEN FILE-WONT-OPEN-PATHNAME FS-RESOURCES-EXCEEDED FS-PROTECTION-VIOLATION ARITHMETIC-ERROR ARITHMETIC-ERROR-OPERATION ARITHMETIC-ERROR-OPERANDS FLOATING-OVERFLOW FLOATING-OVERFLOW-OPERATION FLOATING-OVERFLOW-OPERANDS FLOATING-UNDERFLOW FLOATING-UNDERFLOW-OPERATION FLOATING-UNDERFLOW-OPERANDS PATHNAME-ERROR PATHNAME-ERROR-PATHNAME FILE-NOT-FOUND FILE-NOT-FOUND-PATHNAME INVALID-PATHNAME INVALID-PATHNAME-PATHNAME CONTROL-E-INTERRUPT CONTROL-E-INTERRUPT-FUNCTION ASSERTION-FAILED ASSERTION-FAILED-FORMAT-STRING ASSERTION-FAILED-FORMAT-ARGUMENTS BAD-PROCEED-CASE BAD-PROCEED-CASE-NAME TYPE-MISMATCH TYPE-MISMATCH-EXPECTED-TYPE TYPE-MISMATCH-VALUE TYPE-MISMATCH-MESSAGE STORAGE-EXHAUSTED CREATE-TRACE-WINDOW UNBREAK-FUNCTION REBREAK-FUNCTION TRACE-FUNCTION *TRACE-LEVEL* *TRACE-LENGTH* *TRACE-VERBOSE* INNER REINSTALL-ADVICE ADVISE-FUNCTION UNADVISE-FUNCTION READVISE-FUNCTION ADVISED-FUNCTIONS DEFADVICE WITH-COLLECTION COLLECT ONCE-ONLY *SHORT-SITE-NAME* *LONG-SITE-NAME* DEFINER NAMED-PROGN COMPILE-DEFINER COMPILE-FORM FALSE FILE-ENVIRONMENTS DEFINE-FILE-ENVIRONMENT *BREAK-ON-SIGNALS* HANDLER-CASE WITH-SIMPLE-RESTART RESTART-CASE RESTART-BIND COMPUTE-RESTARTS RESTART-NAME FIND-RESTART INVOKE-RESTART INVOKE-RESTART-INTERACTIVELY CONTINUE MUFFLE-WARNING INVOKE-DEBUGGER RESTART TYPE-ERROR TYPE-ERROR-DATUM PROGRAM-ERROR FILE-ERROR FILE-ERROR-PATHNAME DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW ROW-MAJOR-AREF RECORD-FETCH RECORD-FFETCH RECORD-CREATE DEFINE-RECORD PACKAGE-PREFIX)) (IL:MAPC LISP::FUTURE-CITIZENS-OF-XCL 'LISP::DEFECT-FROM-IL-TO-XCL) (LISP::CHECK-ALL) ) (IL:* IL:;; "Arrange for the proper makefile environment") (IL:PUTPROPS IL:XCL-PACKAGE IL:FILETYPE IL:COMPILE-FILE) (IL:PUTPROPS IL:XCL-PACKAGE IL:MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE (DEFPACKAGE "XCL" (:USE)))) (IL:PUTPROPS IL:XCL-PACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE%: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-ALPHA b/sources/XCLC-ALPHA new file mode 100644 index 00000000..3146042f --- /dev/null +++ b/sources/XCLC-ALPHA @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (il:filecreated "20-Jul-90 17:07:06" il:|{PELE:MV:ENVOS}SOURCES>XCLC-ALPHA.;3| 84829 il:|changes| il:|to:| (il:functions alpha-form) il:|previous| il:|date:| "18-May-90 01:20:54" il:|{PELE:MV:ENVOS}SOURCES>XCLC-ALPHA.;2| ) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:xclc-alphacoms) (il:rpaqq il:xclc-alphacoms ( (il:* il:|;;;| "Alphatization") (il:functions binding-contour process-declarations process-il-declarations update-environment) (il:functions bind-parameter check-arg) (il:functions binding-to-lambda) (il:variables *block-stack* *tagbody-stack*) (il:functions alpha-argument-form alpha-atom alpha-block alpha-catch alpha-combination alpha-compiler-let alpha-eval-when alpha-flet alpha-form alpha-function alpha-functional-form alpha-go alpha-if alpha-il-function alpha-labels alpha-lambda alpha-lambda-list alpha-let alpha-let* alpha-literal alpha-macrolet alpha-mv-call alpha-mv-prog1 alpha-progn alpha-progv alpha-return-from alpha-setq alpha-tagbody alpha-throw alpha-unwind-protect) (il:functions convert-to-cl-lambda completely-expand expand-openlambda-call) (il:* il:|;;| "Alphatization testing") (il:variables *indent-increment* *node-hash* *node-number*) (il:functions test-alpha test-alpha-2 parse-defun print-tree print-node) (il:variables context-test-form) (il:functions ctxt) (il:* il:|;;| "Arrange to use the correct compiler.") (il:prop il:filetype il:xclc-alpha) (il:* il:|;;| "Arrange for the correct makefile environment") (il:prop il:makefile-environment il:xclc-alpha))) (il:* il:|;;;| "Alphatization") (defmacro binding-contour (declarations &body body) (il:* il:|;;;| "Called around the alphatization of a binding form, this sets up bindings of the various special variables used to communicate information between declarations and code. The given declarations are then processed inside the bindings before going on to the body.") `(let ((*new-specials* nil) (*new-globals* nil) (*new-inlines* nil) (*new-notinlines* nil) (il:specvars il:specvars) (il:localvars il:localvars) (il:globalvars il:globalvars)) (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines* il:specvars il:localvars il:globalvars)) (process-declarations ,declarations) ,@body)) (defun process-declarations (decls) (il:* il:|;;;| "Step through the given declarations, storing the information found therein into various special variables.") (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines* il:specvars il:localvars il:globalvars)) (flet ((check-var-1 (var) (cond ((symbolp var) var) (t (cerror "Use the symbol %LOSE% instead." "The value ~S, appearing in a declaration, is not a symbol" var) '%lose%)))) (macrolet ((check-var (var) `(setq ,var (check-var-1 ,var)))) (dolist (decl decls) (dolist (spec (cdr decl)) (if (atom spec) (cerror "Ignore it." "A non-list, ~S, was found where a declaration specification was expected." spec) (case (car spec) ((special) (dolist (var (cdr spec)) (check-var var) (push var *new-specials*))) ((il:specvars) (cond ((consp (cdr spec)) (unless (eq il:specvars t) (setq il:specvars (union il:specvars (cdr spec))))) ((eq (cdr spec) t) (setq il:specvars t) (setq il:localvars il:syslocalvars)) (t (cerror "Ignore it" "Illegal SPECVARS declaration: ~S" spec)) )) ((il:localvars) (cond ((consp (cdr spec)) (unless (eq il:localvars t) (setq il:localvars (union il:localvars (cdr spec))))) ((eq (cdr spec) t) (setq il:localvars t) (setq il:specvars il:sysspecvars)) (t (cerror "Ignore it" "Illegal LOCALVARS declaration: ~S" spec )))) ((global) (dolist (var (cdr spec)) (check-var var) (push var *new-globals*))) ((il:globalvars) (if (consp (cdr spec)) (setq il:globalvars (union il:globalvars (cdr spec))) (cerror "Ignore it" "Illegal GLOBALVARS declaration: ~S" spec ))) ((type ftype function) (il:* il:\;  "We don't handle type declarations yet.") nil) ((inline) (dolist (var (cdr spec)) (check-var var) (push var *new-inlines*))) ((notinline) (dolist (var (cdr spec)) (check-var var) (push var *new-notinlines*))) ((ignore optimize) (il:* il:\;  "We don't handle IGNORE or OPTIMIZE declarations yet.") nil) ((declaration) (il:* il:\; "Add new declaration specifiers right away so that they can be used in later declarations in the same cluster. It's a picky point, but who cares?") (env-add-decls *environment* (cdr spec))) ((il:usedfree) (il:* il:\;  "Ignored Interlisp declarations") nil) (otherwise (unless (or (eq (car spec) t) (il:type-expander (car spec)) (xcl::decl-specifier-p (car spec)) (env-decl-p *environment* (car spec))) (cerror "Ignore it." "Unknown declaration specifier in DECLARE: ~S." (car spec))))))))))) (defun process-il-declarations (specs) (il:* il:|;;;| " Stroring theInterlisp's declare information found in executable position.") (declare (special il:specvars il:localvars il:globalvars)) (dolist (spec specs t) (if (atom spec) (cerror "Ignore it." "A non-list, ~S, was found where a declaration specification was expected." spec) (case (car spec) ((il:specvars) (cond ((consp (cdr spec)) (unless (eq il:specvars t) (setq il:specvars (union il:specvars (cdr spec))))) ((eq (cdr spec) t) (setq il:specvars t) (setq il:localvars il:syslocalvars)) (t (cerror "Ignore it" "Illegal SPECVARS declaration: ~S" spec)))) ((il:localvars) (cond ((consp (cdr spec)) (unless (eq il:localvars t) (setq il:localvars (union il:localvars (cdr spec))))) ((eq (cdr spec) t) (setq il:localvars t) (setq il:specvars il:sysspecvars)) (t (cerror "Ignore it" "Illegal LOCALVARS declaration: ~S" spec)))) ((il:globalvars) (if (consp (cdr spec)) (setq il:globalvars (union il:globalvars (cdr spec))) (cerror "Ignore it" "Illegal GLOBALVARS declaration: ~S" spec))) ((il:usedfree) (il:* il:\;  "Ignored Interlisp declarations") nil) (otherwise (return-from process-il-declarations nil)))))) (defun update-environment (env) (il:* il:|;;;| "Store the information in a BINDING-CONTOUR's special variables into the given environment.") (declare (special *new-specials* *new-globals* *new-inlines* *new-notinlines*)) (when *new-specials* (env-declare-specials env *new-specials*)) (when *new-globals* (env-declare-globals env *new-globals*)) (when *new-inlines* (env-allow-inlines env *new-inlines*)) (when *new-notinlines* (env-disallow-inlines env *new-notinlines*))) (defun bind-parameter (var binder env) (ecase (resolve-variable-binding env var) (:special (deletef var *new-specials*) (env-declare-a-special env var) (make-variable :scope :special :kind :variable :name var :binder binder)) (:lexical (let ((struct (make-variable :scope :lexical :kind :variable :name (symbol-name var) :binder binder))) (env-bind-variable env var struct) struct)))) (defun check-arg (var) (il:* il:|;;;| "Make sure that VAR is a legal parameter in a lambda-list.") (cond ((not (symbolp var)) (cerror "Ignore it." "The parameter ~S is not a symbol." var) nil) ((keywordp var) (cerror "Ignore it." "The parameter ~S is a keyword and may not be bound." var) nil) (t t))) (defun binding-to-lambda (binding) (il:* il:|;;;| "Convert a binding from an FLET or LABELS into the appropriate LAMBDA form, wrapping a BLOCK around the bodies of the functions.") (destructuring-bind (name arg-list &body body) binding (multiple-value-bind (forms decls) (parse-body body *environment* t) `(lambda ,arg-list ,@decls (block ,name ,@forms))))) (defvar *block-stack* nil (il:* il:|;;;| "Association list of block names to block structures; rebound at several points within the alphatizer.") ) (defvar *tagbody-stack* nil "Association list from TAGBODY tags to the TAGBODY structure containing the tag; rebound at several points in the alphatizer" ) (defun alpha-argument-form (form) (let ((*context* *argument-context*)) (alpha-form form))) (defun alpha-atom (form) (il:* il:|;;;| "The form is atomic. If it's a symbol, do the appropriate look-ups. Otherwise, it must be a literal.") (if (or (not (symbolp form)) (eq form t) (eq form nil)) (alpha-literal form) (resolve-variable-reference *environment* form))) (defun alpha-block (name body) (let* ((new-block (make-block :name name :context *context*)) (*block-stack* (cons (cons name new-block) *block-stack*))) (setf (block-stmt new-block) (alpha-progn body)) new-block)) (defun alpha-catch (tag forms) (make-catch :tag (alpha-argument-form tag) :stmt (alpha-progn forms))) (defun alpha-combination (fn args) (declare (special il:nlama il:nlaml)) (cond (il:* il:|;;| "Calls to FUNCALL are expanded into CALL nodes where the FN is the first argument to FUNCALL, more or less.") ((and (eq fn 'funcall) (not (env-inline-disallowed *environment* fn))) (multiple-value-bind (real-fn not-inline?) (alpha-functional-form (first args)) (make-call :fn real-fn :args (mapcar #'alpha-argument-form (rest args)) :not-inline not-inline?))) (il:* il:|;;| "Calls on IL:OPENLAMBDA's involve lots of hairy processing.") ((and (consp fn) (eq (first fn) 'il:openlambda)) (alpha-form (expand-openlambda-call fn args))) (il:* il:|;;| "Lexical functions and non-symbol functions can't be NLambda's.") ((or (not (symbolp fn)) (env-fboundp *environment* fn)) (make-call :fn (alpha-function fn *context*) :args (mapcar #'alpha-argument-form args) :not-inline (and (symbolp fn) (env-inline-disallowed *environment* fn)))) ((or (eq 3 (il:argtype fn)) (member fn il:nlama :test 'eq)) (il:* il:\;  "It's an NLambda no-spread. Funcall it on a single literal argument, the CDR of the form.") (make-call :fn (alpha-function fn) :args (alpha-literal args) :not-inline (env-inline-disallowed *environment* fn))) ((or (eq 1 (il:argtype fn)) (member fn il:nlaml :test 'eq)) (il:* il:\;  "It's an NLambda spread. Funcall it on the quoted versions of its arguments.") (make-call :fn (alpha-function fn) :args (mapcar #'alpha-literal args) :not-inline (env-inline-disallowed *environment* fn))) (t (make-call :fn (alpha-function fn *context*) :args (mapcar #'alpha-argument-form args) :not-inline (env-inline-disallowed *environment* fn))))) (defun alpha-compiler-let (bindings body) (let ((vars nil) (vals nil)) (il:for binding il:in bindings il:do (cond ((consp binding) (push (car binding) vars) (push (eval (cadr binding)) vals)) (t (push binding vars) (push nil vals)))) (progv vars vals (alpha-progn body)))) (defun alpha-eval-when (times forms) (il:* il:|;;;| "If the times contain COMPILE, we evaluate the forms. If the times include LOAD, we prognify the forms. If LOAD isn't mentioned, this turns into NIL.") (when (or (member 'compile times :test #'eq) (member 'il:compile times :test #'eq)) (mapc #'eval forms)) (if (or (member 'load times :test #'eq) (member 'il:load times :test #'eq)) (alpha-progn forms) *literally-nil*)) (defun alpha-flet (bindings body) (il:* il:|;;;| "An FLET is alphatized as a LABELS node. The only difference is that the new variables for the function bindings are inserted after alphatizing the defined functions and body, whereas in a LABELS you add them to the environment before alphatizing the children.") (let ((*environment* (make-child-env *environment*))) (multiple-value-bind (forms decls) (parse-body body *environment* nil) (binding-contour decls (update-environment *environment*) (let ((new-labels (make-labels)) names) (setq names (with-collection (setf (labels-funs new-labels) (mapcar #'(lambda (binding) (unless (check-arg (car binding)) (setq binding (cons '%lose% (cdr binding)) )) (collect (car binding)) (cons (make-variable :name (symbol-name (car binding)) :scope :lexical :kind :function :binder new-labels) (alpha-lambda (binding-to-lambda binding) :name (il:* il:|;;|    "Really want name to be \"Foo in Bar\"") (symbol-name (car binding))))) bindings)))) (il:* il:|;;| "Having alphatized the function bindings, put them in the environment for alphatization of the body.") (il:for name il:in names il:as fn-pair il:in (labels-funs new-labels) il:do (env-bind-function *environment* name :function (car fn-pair))) (il:* il:|;;| "Now we can alphatize the body.") (setf (labels-body new-labels (alpha-progn forms))) new-labels))))) (defun alpha-form (form) (il:* il:|;;;| "FORM is a random exectuable form. Dispatch to the appropriate alphatization routine.") (il:* il:|;;;| "NOTE NOTE NOTE::: If anything is added to this CASE statement, be sure to add it also to the list in COMPLETELY-EXPAND.") (if (atom form) (alpha-atom form) (case (car form) ((block) (alpha-block (second form) (cddr form))) ((catch) (alpha-catch (second form) (cddr form))) ((compiler-let) (alpha-compiler-let (second form) (cddr form))) ((declare) (or (process-il-declarations (cdr form)) (cerror "Replace the declaration with NIL" "DECLARE found in executable position: ~S" form)) *literally-nil*) ((eval-when) (alpha-eval-when (second form) (cddr form))) ((flet) (alpha-flet (second form) (cddr form))) ((il:function) (alpha-il-function (second form) (third form))) ((function) (alpha-function (second form))) ((go) (alpha-go (second form))) ((if) (alpha-if (second form) (third form) (fourth form))) ((labels) (il:* il:\;  "Rely on the macro expansion for now.") (return-from alpha-form (alpha-labels (second form) (cddr form))) (return-from alpha-form (alpha-form (optimize-and-macroexpand-1 form)))) ((let) (alpha-let (second form) (cddr form))) ((let*) (alpha-let* (second form) (cddr form))) ((macrolet si::%macrolet) (alpha-macrolet (second form) (cddr form))) ((multiple-value-call) (alpha-mv-call (second form) (cddr form))) ((multiple-value-prog1) (alpha-mv-prog1 (cdr form))) ((progn) (alpha-progn (cdr form))) ((progv) (il:* il:\;  "Rely on the macro expansion for now.") (return-from alpha-form (destructuring-bind (vars-expr vals-expr . body) (cdr form) (alpha-form `(il:\\do.progv ,vars-expr ,vals-expr #'(lambda nil ,@body))))) (alpha-progv (second form) (third form) (cdddr form))) ((quote) (alpha-literal (second form))) ((return-from) (alpha-return-from (second form) (third form))) ((setq il:setq) (alpha-setq (car form) (rest form))) ((tagbody) (alpha-tagbody (cdr form))) ((the) (il:* il:\;  "Ignore the THE construct for now.") (alpha-form (third form))) ((throw) (alpha-throw (second form) (third form))) ((unwind-protect) (alpha-unwind-protect (second form) (cddr form))) (otherwise (multiple-value-bind (new-form changed-p) (optimize-and-macroexpand-1 form) (if (null changed-p) (alpha-combination (car form) (cdr form)) (alpha-form new-form))))))) (defun alpha-function (form &optional (context (or (context-applied-context *context*) *null-context*))) (il:* il:|;;;| "If it's a symbol, then turn this into either the FLET/LABELS-bound VARIABLE structure or a structure for the global symbol. Otherwise, it must be either a LAMBDA-form or OPCODES-form and is treated as such. Note that the internal representation of programs treats LAMBDA as a value-producing special form.") (il:* il:|;;;| "The CONTEXT argument is the return-context of the function, if known. It is passed on to alpha-lambda.") (il:* il:|;;;| "We return a second value when the FORM is a symbol, saying whether or not the named function is supposed to be NOTINLINE.") (cond ((symbolp form) (multiple-value-bind (kind struct) (env-fboundp *environment* form) (cond ((eq kind :function) (values (make-var-ref :variable struct) (env-inline-disallowed *environment* form))) (t (unless (null kind) (assert (eq kind :macro)) (il:* il:|;;| "This case can only arise if we are alphatizing a FUNCTION form, since the macro would have been expanded otherwise.") (cerror "Use the global function definition of ~S" "The symbol ~S names a lexically-bound macro and thus cannot be used with the FUNCTION special form." form)) (il:* il:|;;| "Account for block compilation.") (when (not (null *current-block*)) (let ((lookup (assoc form (block-decl-fn-name-map *current-block*)))) (when (not (null lookup)) (il:* il:\;  "This function is to be renamed.") (setq form (cdr lookup))))) (check-for-unknown-function form) (values (make-reference-to-variable :name form :scope :global :kind :function) (env-inline-disallowed *environment* form)))))) (t (case (car form) ((lambda il:lambda il:nlambda il:openlambda) (alpha-lambda form :context context)) ((il:opcodes :opcodes) (make-opcodes :bytes (cdr form))) (otherwise (cerror "Use (LAMBDA () NIL) instead" "The form ~S, appearing in a functional context, is neither a symbol nor a LAMBDA-form" form) (alpha-lambda '(lambda nil nil) :context context)))))) (defun alpha-functional-form (form) (if (and (consp form) (or (eq 'quote (first form)) (eq 'il:function (first form))) (symbolp (second form))) (alpha-function (second form)) (let ((*context* (make-context :values-used 1 :applied-context *context*))) (alpha-form form)))) (defun alpha-go (tag) (let ((dest (assoc tag *tagbody-stack*))) (when (null dest) (cond ((null *tagbody-stack*) (cerror "Replace the GO with NIL" "The GO tag ~S does not appear in any enclosing TAGBODY" tag) (return-from alpha-go *literally-nil*)) (t (cerror "Use the tag ~*~S instead" "The GO tag ~S does not appear in any enclosing TAGBODY" tag (caar *tagbody-stack* )) (setq dest (car *tagbody-stack*))))) (make-go :tagbody (cdr dest) :tag (car dest)))) (defun alpha-if (pred-form then-form else-form) (make-if :pred (let ((*context* *predicate-context*)) (alpha-form pred-form)) :then (alpha-form then-form) :else (alpha-form else-form))) (defun alpha-il-function (fn close-p-form) (il:* il:|;;;| "If there is no close-p-form, then this is just like Common Lisp FUNCTION except that (IL:FUNCTION symbol) == 'symbol.") (il:* il:|;;;| "If there is a close-p-form, then turn this into a function call, remembering to quote the close-p-form and either quote or hash-quote the function.") (il:* il:|;;| "Account for block compilation.") (when (and (symbolp fn) (not (null *current-block*))) (let ((lookup (assoc fn (block-decl-fn-name-map *current-block*)))) (when (not (null lookup)) (il:* il:\;  "This function is to be renamed.") (setq fn (cdr lookup))))) (if (null close-p-form) (cond ((and (symbolp fn) (not (env-fboundp *environment* fn))) (check-for-unknown-function fn) (alpha-literal fn)) (t (alpha-function fn))) (make-call :fn (make-reference-to-variable :name 'il:function :scope :global :kind :function) :args (list (if (symbolp fn) (alpha-literal fn) (alpha-function fn)) (alpha-literal close-p-form))))) (defun alpha-labels (bindings body) (il:* il:|;;;| "Make a first pass down the list of bindings in order to set up the environment in which they will all be defined. Then alphatize each definition and transform the whole thing into a LABELS binding structure.") (let* ((*environment* (make-child-env *environment*)) (labels (make-labels)) (structs (mapcar #'(lambda (binding) (unless (check-arg (car binding)) (setq binding (cons '%lose% (cdr binding)))) (let ((struct (make-variable :name (symbol-name (car binding)) :scope :lexical :kind :function :binder labels))) (env-bind-function *environment* (car binding) :function struct) struct)) bindings))) (multiple-value-bind (forms decls) (parse-body body *environment* nil) (binding-contour decls (update-environment *environment*) (setf (labels-funs labels) (mapcar #'(lambda (binding struct) (cons struct (alpha-lambda (binding-to-lambda binding) :name (il:* il:|;;|  "Really want name to be \"Foo in Bar\"") (symbol-name (car binding))))) bindings structs)) (setf (labels-body labels) (alpha-progn forms)))) labels)) (defun alpha-lambda (original-form &key ((:context *context*) *null-context*) name) (il:* il:|;;| "Check for something other than a CL:LAMBDA and coerce if necessary.") (multiple-value-bind (form arg-type) (convert-to-cl-lambda original-form) (il:* il:|;;| "Crack the argument list, applying any declarations that might be present.") (let ((arg-list (second form)) (body (cddr form)) (*environment* (make-child-env *environment*))) (multiple-value-bind (code decls) (parse-body body *environment* t) (binding-contour decls (il:* il:\; "Process the declarations") (update-environment *environment*) (let* ((node (make-lambda :name name :arg-type arg-type)) (auxes (alpha-lambda-list arg-list node)) (body-node (alpha-progn code))) (il:* il:|;;| "AUXES is now the list of values representing the &aux variables IN REVERSE ORDER. We must bind them around the body one-by-one and then wrap that in the lambda node we've already created.") (il:for aux il:in auxes il:do (let ((binder (make-lambda :required (list (car aux)) :body body-node))) (setf (variable-binder (car aux)) binder) (setq body-node (make-call :fn binder :args (list (cdr aux)))))) (setf (lambda-body node) body-node) (il:* il:|;;| "For Interlisp LAMBDA no-spread's, we need to save away the parameter name so that we can generate code for ARG properly. (Yecch...)") (when (eq arg-type 2) (setf (lambda-no-spread-name node) (second original-form))) node)))))) (defun alpha-lambda-list (arg-list binder) (il:* il:|;;;| "Alpha-converts the argument list of a lambda form. Stores the results of the analysis into the appropriate slots of the LAMBDA structure in BINDER. Returns a list of the values representing the &aux argument variables, in reverse order of binding.") (let ((state :required) required optional keyword aux) (dolist (arg arg-list) (case arg ((&optional) (if (eq state :required) (setq state :optional) (cerror "Ignore it." "Misplaced &optional in lambda-list"))) ((&rest) (if (member state '(:required :optional)) (setq state :rest) (cerror "Ignore it." "Misplaced &rest in lambda-list"))) ((&ignore-rest) (il:* il:\;  "Internal keyword used in translation of Interlisp spread functions.") (assert (eq state :optional) nil "BUG: Misplaced &IGNORE-REST keyword.") (setf (lambda-rest binder) (make-variable :binder binder)) (return) (il:* il:\;  "Nothing is supposed to follow an &IGNORE-REST") ) ((&key) (if (and (il:neq state :aux) (il:neq state :key)) (setq state :key) (cerror "Ignore it." "Misplaced &key in lambda-list"))) ((&allow-other-keys) (unless (eq state :key) (cerror "Ignore it." "Stray &allow-other-keys in lambda-list.")) (setf (lambda-allow-other-keys binder) t)) ((&aux) (if (il:neq state :aux) (setq state :aux) (cerror "Ignore it." "Misplaced &aux in lambda-list."))) (otherwise (ecase state ((:required) (when (check-arg arg) (push (bind-parameter arg binder *environment*) required))) ((:optional) (if (atom arg) (when (check-arg arg) (push (list (bind-parameter arg binder *environment*) *literally-nil*) optional)) (destructuring-bind (var &optional (init-form nil) (svar nil sv-given)) arg (when (check-arg var) (let ((init-struct (alpha-argument-form init-form))) (push `(,(bind-parameter var binder *environment*) ,init-struct ,@(and sv-given (check-arg svar) (list (bind-parameter svar binder *environment*))) ) optional)))))) ((:rest) (when (check-arg arg) (setf (lambda-rest binder) (bind-parameter arg binder *environment*)) (setq state :after-rest))) ((:after-rest) (cerror "Ignore it." "Stray argument ~S found after &rest var.")) ((:key) (if (atom arg) (when (check-arg arg) (push (list (intern (string arg) "KEYWORD") (bind-parameter arg binder *environment*) *literally-nil*) keyword)) (destructuring-bind (key&var &optional (init-form nil) (svar nil sv-given) &aux key var) arg (cond ((atom key&var) (when (check-arg key&var) (il:* il:|;;| "This is not the real legality test; that's below. This just makes sure that the intern will work.") (setq key (intern (string key&var) "KEYWORD"))) (setq var key&var)) (t (setq key (first key&var)) (setq var (second key&var)))) (when (check-arg var) (let ((init-struct (alpha-argument-form init-form))) (push `(,key ,(bind-parameter var binder *environment*) ,init-struct ,@(and sv-given (check-arg svar) (list (bind-parameter svar binder *environment*)))) keyword)))))) ((:aux) (let (var val) (cond ((atom arg) (setq var arg) (setq val nil)) (t (setq var (first arg)) (setq val (second arg)))) (when (check-arg var) (let ((tree (alpha-argument-form val))) (push (cons (bind-parameter var binder *environment*) tree) aux))))))))) (setf (lambda-required binder) (nreverse required)) (setf (lambda-optional binder) (nreverse optional)) (setf (lambda-keyword binder) (nreverse keyword)) aux)) (defun alpha-let (bindings body) (il:* il:|;;| "Install the new variables in a new environment and then install that environment before alphatizing the body.") (multiple-value-bind (body decls) (parse-body body *environment* nil) (binding-contour decls (let ((*environment* (make-child-env *environment*))) (il:* il:|;;| "The standard is losing and wants us to install the environment before alphatizing the init-forms so that SPECIAL declarations will have bigger scope. Ugh.") (update-environment *environment*) (let ((vars nil) (vals nil) (new-lambda (make-lambda))) (il:* il:|;;| "Alphatize the init-forms.") (il:for binding il:in bindings il:do (cond ((consp binding) (push (first binding) vars) (push (alpha-argument-form (second binding )) vals)) (t (push binding vars) (push *literally-nil* vals)))) (il:* il:|;;| "Bind all of the variables") (setf (lambda-required new-lambda) (il:for var il:in (nreverse vars) il:collect (bind-parameter (if (check-arg var) var '%lose%) new-lambda *environment*))) (il:* il:|;;| "Alphatize the body") (setf (lambda-body new-lambda) (alpha-progn body)) (make-call :fn new-lambda :args (nreverse vals))))))) (defun alpha-let* (bindings body) (il:* il:|;;;| "Install the new variables in the environment one at a time, processing the next in an environment including those that came before. The LET* is then represented as several nested lambdas, so we must be careful to get the BINDER links set up properly.") (multiple-value-bind (body decls) (parse-body body *environment* nil) (binding-contour decls (let ((*environment* (make-child-env *environment*)) (binding-list nil)) (update-environment *environment*) (il:* il:|;;| "First, alphatize each of the init-forms in the correct environment.") (il:for binding il:in bindings il:do (if (consp binding) (let ((init-struct (alpha-argument-form (second binding)))) (push (cons (bind-parameter (if (check-arg (first binding)) (first binding) '%lose%) nil *environment*) init-struct) binding-list)) (push (cons (bind-parameter (if (check-arg binding) binding '%lose%) nil *environment*) *literally-nil*) binding-list))) (il:* il:|;;| "BINDING-LIST is now in reverse order, so we can construct the nested lambdas from the inside out.") (il:bind (body-struct il:_ (alpha-progn body)) il:for pair il:in binding-list il:do (let ((binder (make-lambda :required (list (car pair)) :body body-struct))) (setq body-struct (make-call :fn binder :args (list (cdr pair)))) (setf (variable-binder (car pair)) binder)) il:finally (return body-struct)))))) (defun alpha-literal (value) (il:* il:|;;;| "Check for certain special values that have preallocated LITERAL structures. Otherwise, make a new one. The test for undumpable values used to be done in both COMPILE and COMPILE-FILE, but this lost in loading PCL, which COMPILE's functions containing circular structures as literals.") (case value ((nil) *literally-nil*) ((t) *literally-t*) (otherwise (make-literal :value (cond ((and (streamp *input-stream*) (il:* il:\; "This is COMPILE-FILE") (not (fasl:value-dumpable-p value))) (restart-case (error "The literal value ~S would not be dumpable in a FASL file." value) (nil nil :report "Use the value NIL instead" nil) (nil nil :report (lambda (stream) (format stream "Use the value ~S anyway and hope for the best" value)) value))) (t value)))))) (defun alpha-macrolet (bindings body) (il:* il:|;;;| "Turn the bindings into expansion functions and add them into the environment for the analysis of the body.") (let ((new-env (make-child-env *environment*))) (il:for macro il:in bindings il:do (env-bind-function new-env (car macro) :macro (crack-defmacro (cons 'defmacro macro)) )) (let ((*environment* new-env)) (multiple-value-bind (forms decls) (parse-body body *environment* nil) (binding-contour decls (update-environment *environment*) (alpha-progn forms)))))) (defun alpha-mv-call (fn-form arg-forms) (let (values-used) (multiple-value-bind (fn not-inline?) (alpha-functional-form fn-form) (cond ((and (null (cdr arg-forms)) (lambda-p fn) (not (or (lambda-optional fn) (lambda-rest fn) (lambda-keyword fn)))) (il:* il:\;  "In this very common case, we can tell how many values are expected.") (setq values-used (length (lambda-required fn)))) (t (setq values-used :unknown))) (if (null arg-forms) (il:* il:\;  "This is silly, but we'd better handle it correctly.") (make-call :fn fn :args nil :not-inline not-inline?) (make-mv-call :fn fn :arg-exprs (let ((*context* (make-context :values-used values-used))) (mapcar #'alpha-form arg-forms)) :not-inline not-inline?))))) (defun alpha-mv-prog1 (forms) (let ((vals-used (context-values-used *context*))) (cond ((null (cdr forms)) (alpha-form (car forms))) ((and (numberp vals-used) (< vals-used 2)) (il:* il:\;  "The multiple values aren't wanted. Make this a normal PROG1.") (alpha-form (cons 'prog1 forms))) (t (make-mv-prog1 :stmts (cons (alpha-form (first forms)) (let ((*context* *effect-context*)) (mapcar #'alpha-form (rest forms))))))))) (defun alpha-progn (forms) (if (null (cdr forms)) (alpha-form (car forms)) (make-progn :stmts (let ((old-context *context*) (*context* *effect-context*)) (il:for tail il:on forms il:collect (if (null (cdr tail)) (let ((*context* old-context)) (alpha-form (car tail))) (alpha-form (car tail)))))))) (defun alpha-progv (syms-expr vals-expr body-forms) (make-progv :syms-expr (alpha-argument-form syms-expr) :vals-expr (alpha-argument-form vals-expr) :stmt (alpha-progn body-forms))) (defun alpha-return-from (name form) (let ((dest (assoc name *block-stack*))) (when (null dest) (cond ((null *block-stack*) (cerror "Treat (RETURN-FROM name value-form) as simply value-form" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" name) (return-from alpha-return-from (alpha-form form))) (t (cerror "Use the name ~*~S instead" "~S, found in a RETURN-FROM, is not the name of any enclosing BLOCK" name (caar *block-stack*)) (setq dest (car *block-stack*))))) (make-return :block (cdr dest) :value (let ((*context* (block-context (cdr dest)))) (alpha-form form))))) (defun alpha-setq (kind forms) (let ((setqs (il:for tail il:on forms il:by (cddr tail) il:collect (when (and (eq kind 'setq) (null (cdr tail))) (cerror "Add an extra NIL on the end of the form" "Odd number of forms given to SETQ.")) (make-setq :var (resolve-variable-reference *environment* (car tail) t) :value (alpha-argument-form (cadr tail)))))) (if (null (cdr setqs)) (car setqs) (make-progn :stmts setqs)))) (defun alpha-tagbody (body) (il:* il:|;;;| "Break up the body into `segments', each of which is an unbroken series of forms along with the zero or more tags that begin that series of forms.") (when (null body) (return-from alpha-tagbody *literally-nil*)) (let ((tagbody (make-tagbody)) (*tagbody-stack* *tagbody-stack*)) (il:* il:|;;| "Make a first pass down the body to find all of the tags") (il:for form il:in body il:do (when (atom form) (push (cons form tagbody) *tagbody-stack*))) (il:* il:|;;|  "On the second pass, put together the segments and alphatize all of the forms") (do ((*context* *effect-context*) (segment-list nil)) ((null body) (setf (tagbody-segments tagbody) (nreverse segment-list))) (let ((segment (make-segment))) (do nil ((or (null body) (consp (car body)))) (push (pop body) (segment-tags segment))) (do ((form-list nil)) ((or (null body) (atom (car body))) (setf (segment-stmts segment) (nreverse form-list))) (push (alpha-form (pop body)) form-list)) (push segment segment-list))) tagbody)) (defun alpha-throw (tag value) (make-throw :tag (alpha-argument-form tag) :value (let ((*context* *null-context*)) (alpha-form value)))) (defun alpha-unwind-protect (body cleanups) (make-unwind-protect :stmt (alpha-lambda (let ((cleanup-var (gensym))) `(lambda (,cleanup-var) (multiple-value-prog1 ,body (funcall ,cleanup-var)))) :context *context* :name 'si::*unwind-protect*) :cleanup (alpha-lambda `(lambda nil ,@cleanups) :context *effect-context* :name "Clean-up forms"))) (defun convert-to-cl-lambda (form) (il:* il:|;;| "Return two values: a CL:LAMBDA form equivalent to the given one and the Interlisp ARGTYPE for the form.") (case (car form) ((lambda) (il:* il:|;;| "Common Lisp LAMBDA's have indeterminate ARGTYPE. The assembler will figure out whether it's 0 or 2. The LOCALVARS declaration is because Interlisp's scoping rules have overwhelmed those of Common Lisp, may they rest in peace.") (values `(lambda ,(second form) (declare (il:localvars . t)) ,@(cddr form)) nil)) ((il:lambda il:openlambda) (if (listp (second form)) (il:* il:|;;| "LAMBDA spread. Use the Common Lisp &OPTIONAL keyword and also one made for internal compiler use that will throw away the extra arguments.") (values `(lambda (&optional ,@(second form) &ignore-rest) ,@(cddr form)) 0) (il:* il:|;;| "LAMBDA no-spread. Bind the parameter to the number of arguments passed. The handling of ARG must be done in code generation, unfortunately.") (values `(lambda nil (let ((,(second form) (il:\\myargcount))) ,@(cddr form))) 2))) ((il:nlambda) (if (listp (second form)) (il:* il:|;;|  "NLAMBDA spread. Just like the LAMBDA-spread case but we have a different ARG-TYPE.") (values `(lambda (&optional ,@(second form) &ignore-rest) ,@(cddr form)) 1) (il:* il:|;;|  "NLAMBDA no-spread. We take exactly one argument and are otherwise entirely normal.") (values `(lambda (,(second form)) ,@(cddr form)) 3))) (otherwise (il:* il:|;;| "This is not my beautiful LAMBDA form!") (cerror "Use (LAMBDA () NIL) instead" "The form ~S should be a LAMBDA form but is not." form) (values '(lambda nil nil) 0)))) (defun completely-expand (form) (if (atom form) form (let ((new-form form) changed-p) (il:until (member (car new-form) '(block catch compiler-let declare eval-when flet il:function function go if labels let let* macrolet si::%macrolet multiple-value-call multiple-value-prog1 progn progv quote setq il:setq tagbody the throw unwind-protect) :test 'eq) il:do (multiple-value-setq (new-form changed-p) (optimize-and-macroexpand-1 new-form)) (when (null changed-p) (if (and (consp (car new-form)) (eq 'il:openlambda (caar new-form))) (setq new-form (expand-openlambda-call (car new-form) (cdr new-form))) (return new-form))) il:finally (return new-form ))))) (defun expand-openlambda-call (fn args) (il:* il:|;;;| "The idea here is to try to do some substitution into the body of the OPENLAMBDA. We do it here instead of in meta-evaluation because there are parts of the Interlisp system that count on their optimizers being able to find literals in their arguments. They count on the substitution being done so that that will be the case.") (il:* il:|;;;| "It is well-known that the use of SUBLIS here is a bug: for example, if one of the arguments to the OPENLAMBDA has the same name as one of the functions called therein, the subst will still change both of them, undoubtably leading to chaos. However, the ByteCompiler has always done it this way and nothing broke, so, since it's also very easy, we do it too. If anything actually counts on this, though, I may kill the author.") (il:* il:|;;;| "The general details of this transformation are the way they are because it's the way the ByteCompiler did it. Pavel will never defend this code on philosophical grounds. (\"If this code is caught or killed, Pavel will disavow any knowledge of its actions...\")") (let ((unsubbed-params nil) (unsubbed-args nil) (subst-alist nil) extra-args) (do* ((params (cadr fn) (cdr params)) (args (let ((*context* *argument-context*)) (mapcar 'completely-expand args)) (cdr args)) (arg (car args) (car args))) ((null params) (setq extra-args args)) (il:* il:|;;|  "For each pair, if the argument is a constant, add it to the substitution we'll later apply.") (cond ((or (constantp arg) (and (atom arg) (not (symbolp arg))) (and (consp arg) (eq (car arg) 'il:function) (symbolp (cadr arg)))) (push (cons (car params) arg) subst-alist)) (t (push (car params) unsubbed-params) (push arg unsubbed-args)))) (when (null unsubbed-args) (il:* il:\;  "We got rid of all of them.") (return-from expand-openlambda-call `(progn ,@extra-args ,@(sublis subst-alist (cddr fn) :test 'eq)))) (il:* il:|;;| "Perhaps there're no extra arguments or they're all constants. This should really be a full-blown test for side-effect freedom, but that's too much work for alphatization.") (cond ((and extra-args (notevery #'(lambda (arg) (or (constantp arg) (and (atom arg) (not (symbolp arg))) (and (consp arg) (member (car arg) '(il:function function))))))) (il:* il:|;;| "There're extra arguments in the way, so we're done.") (setf (car unsubbed-args) `(prog1 ,(car unsubbed-args) ,@extra-args)) `((lambda ,(reverse unsubbed-params) ,@(sublis subst-alist (cddr fn) :test 'eq)) ,@(reverse unsubbed-args))) (t (il:* il:|;;| "There's nothing interesting between the body and the as yet unsubbed arguments, so maybe we can also substitute some variables. Note that because the unsubbed lists are in reverse order now, we can easily examine the arguments starting with the last one and working backwards, just as we'd like.") (il:while (and unsubbed-args (symbolp (first unsubbed-args))) il:do (push (cons (pop unsubbed-params) (pop unsubbed-args)) subst-alist)) (cond ((null unsubbed-args) (il:* il:\; "All substituted in.") `(progn ,@(sublis subst-alist (cddr fn) :test 'eq))) ((member (car (first unsubbed-args)) '(il:setq setq)) (cond ((null (cdr unsubbed-args)) (push (cons (first unsubbed-params) (cadr (first unsubbed-args))) subst-alist) `(progn ,(first unsubbed-args) ,@(sublis subst-alist (cddr fn) :test 'eq))) (t (push (cons (pop unsubbed-params) (cadr (first unsubbed-args))) subst-alist) (setq unsubbed-args (cons `(prog1 ,(second unsubbed-args) ,(first unsubbed-args)) (cddr unsubbed-args))) `((lambda ,(reverse unsubbed-params) ,@(sublis subst-alist (cddr fn) :test 'eq)) ,@(reverse unsubbed-args))))) (t `((lambda ,(reverse unsubbed-params) ,@(sublis subst-alist (cddr fn) :test 'eq)) ,@(reverse unsubbed-args)))))))) (il:* il:|;;| "Alphatization testing") (defparameter *indent-increment* 3 (il:* il:|;;;| "Number of spaces by which the indentation should increase in nested nodes.") ) (defvar *node-hash* nil "Used by the parse-tree pretty-printer") (defvar *node-number* 0 "Used by the parse-tree pretty-printer") (defun test-alpha (fn) (let ((tree (test-alpha-2 fn))) (unwind-protect (print-tree tree) (release-tree tree)))) (defun test-alpha-2 (fn) (let ((*environment* (make-env)) (*context* *null-context*) (*constants-hash-table* (make-hash-table)) (il:specvars t) (il:localvars il:syslocalvars) (il:globalvars il:globalvars) (il:localfreevars nil) (*processed-functions* nil) (*unknown-functions* nil) (*current-function* nil) (*automatic-special-declarations* nil)) (declare (special il:specvars il:localvars il:localfreevars il:globalvars)) (alpha-lambda (cond ((consp fn) fn) ((consp (il:getd fn)) (il:getd fn)) (t (parse-defun (il:getdef fn 'il:functions))))))) (defun parse-defun (form) (destructuring-bind (ignore name arg-list &body body) form (multiple-value-bind (forms decls) (parse-body body nil t) `(lambda ,arg-list ,@decls (block ,name ,@forms))))) (defun print-tree (tree) (let ((*node-hash* (make-hash-table)) (*node-number* 0) (*print-case* :upcase)) (print-node tree 0)) (terpri) (values)) (defun print-node (node indent) (il:* il:|;;;| "NODE is the node to print. INDENT is the number of spaces over we are on entry to PRINT-NODE. We should not ever print anything on the line to the left of that point.") (let ((number (and (not (literal-p node)) (gethash node *node-hash*)))) (cond (number (format t "-~S-" number)) (t (incf *node-number*) (setf (gethash node *node-hash*) *node-number*) (format t "~S. ~A: " *node-number* (type-of node)) (let ((nested-indent (+ indent *indent-increment*))) (macrolet ((new-line (&optional (delta 0)) `(format t "~%~vT" (+ nested-indent ,delta))) (print-blipper-info nil '(format t " Closed-over-p: ~:[false~;true~] New-frame-p: ~:[false~;true~]" (blipper-closed-over-p node) (blipper-new-frame-p node)))) (etypecase node (block-node (prin1 (block-name node)) (print-blipper-info) (new-line) (print-node (block-stmt node) nested-indent)) (call-node (when (caller-not-inline node) (princ "(not inline)")) (new-line) (princ "Func: ") (print-node (call-fn node) (+ nested-indent 6)) (when (call-args node) (new-line) (princ "Args: ") (il:for arg-tail il:on (call-args node) il:do (print-node (car arg-tail) (+ nested-indent 6)) (when (not (null (cdr arg-tail))) (new-line 6))))) (catch-node (new-line) (princ "Tag: ") (print-node (catch-tag node) (+ nested-indent 6)) (new-line) (princ "Stmt: ") (print-node (catch-stmt node) (+ nested-indent 6))) (go-node (format t "to ~S" (go-tag node)) (new-line) (princ "Tagbody: ") (print-node (go-tagbody node) (+ nested-indent 9))) (if-node (new-line) (princ "Pred: ") (print-node (if-pred node) (+ nested-indent 6)) (new-line) (princ "Then: ") (print-node (if-then node) (+ nested-indent 6)) (new-line) (princ "Else: ") (print-node (if-else node) (+ nested-indent 6))) (labels-node (new-line) (princ "Funs: ") (il:for tail il:on (labels-funs node) il:do (print-node (caar tail) (+ nested-indent 6)) (new-line 10) (print-node (cdar tail) (+ nested-indent 10)) (when (not (null (cdr tail))) (new-line 6))) (new-line) (princ "Body: ") (print-node (labels-body node) (+ nested-indent 6))) (lambda-node (new-line) (when (lambda-required node) (princ "&req: ") (il:for vars il:on (lambda-required node) il:do (print-node (car vars) (+ nested-indent 6)) (if (null (cdr vars)) (new-line) (new-line 6)))) (when (lambda-optional node) (princ "&opt: ") (il:for vars il:on (lambda-optional node) il:do (destructuring-bind (var &optional (init nil i-given) (svar nil sv-given)) (car vars) (cond ((symbolp var) (print-node (car vars) (+ nested-indent 6))) ((not i-given) (print-node var (+ nested-indent 6))) (t (princ "(") (print-node var (+ nested-indent 7)) (new-line 7) (print-node init (+ nested-indent 7)) (new-line 7) (when sv-given (print-node svar (+ nested-indent 7)) (new-line 7)) (princ ")")))) (if (null (cdr vars)) (new-line) (new-line 6)))) (when (lambda-rest node) (princ "&rest: ") (print-node (lambda-rest node) (+ nested-indent 7)) (new-line)) (when (lambda-keyword node) (princ "&key: ") (il:for vars il:on (lambda-keyword node) il:do (destructuring-bind (key var &optional (init nil i-given) (svar nil sv-given)) (car vars) (format t "((~S " key) (new-line 8) (print-node var (+ nested-indent 8)) (princ ")") (new-line 7) (print-node init (+ nested-indent 7)) (new-line 7) (when sv-given (print-node svar (+ nested-indent 7)) (new-line 7)) (princ ")")) (cond ((null (cdr vars)) (when (lambda-allow-other-keys node) (princ "&allow-other-keys")) (new-line)) (t (new-line 6))))) (when (lambda-closed-over-vars node) (princ "Closed-over:") (new-line 10) (il:for vars il:on (lambda-closed-over-vars node) il:do (print-node (car vars) (+ nested-indent 10)) (if (null (cdr vars)) (new-line) (new-line 10)))) (print-node (lambda-body node) nested-indent)) (literal-node (prin1 (literal-value node))) (mv-call-node (when (caller-not-inline node) (princ "(not inline)")) (new-line) (princ "Func: ") (print-node (mv-call-fn node) (+ nested-indent 6)) (new-line) (princ "Args: ") (il:for arg-tail il:on (mv-call-arg-exprs node) il:do (print-node (car arg-tail) (+ nested-indent 6)) (when (not (null (cdr arg-tail))) (new-line 6)))) (mv-prog1-node (il:for stmt il:in (mv-prog1-stmts node) il:do (new-line) (print-node stmt nested-indent))) (opcodes-node (prin1 (opcodes-bytes node))) (progn-node (il:for stmt il:in (progn-stmts node) il:do (new-line) (print-node stmt nested-indent))) (progv-node (new-line) (princ "Vars: ") (print-node (progv-syms-expr node) (+ nested-indent 6)) (new-line) (princ "Vals: ") (print-node (progv-vals-expr node) (+ nested-indent 6)) (new-line) (princ "Body: ") (print-node (progv-stmt node) (+ nested-indent 6))) (return-node (new-line) (princ "From: ") (print-node (return-block node) (+ nested-indent 7)) (new-line) (princ "Value: ") (print-node (return-value node) (+ nested-indent 7))) (setq-node (new-line) (princ "Var: ") (print-node (setq-var node) (+ nested-indent 7)) (new-line) (princ "Value: ") (print-node (setq-value node) (+ nested-indent 7))) (tagbody-node (print-blipper-info) (il:for segment il:in (tagbody-segments node) il:do (il:for tag il:in (segment-tags segment) il:do (new-line) (princ tag)) (il:for stmt il:in (segment-stmts segment) il:do (new-line 4) (print-node stmt (+ nested-indent 4))))) (throw-node (new-line) (princ "Tag: ") (print-node (throw-tag node) (+ nested-indent 7)) (new-line) (princ "Value: ") (print-node (throw-value node) (+ nested-indent 7))) (unwind-protect-node (new-line) (princ "Stmt: ") (print-node (unwind-protect-stmt node) (+ nested-indent 9)) (new-line) (princ "Cleanup: ") (print-node (unwind-protect-cleanup node) (+ nested-indent 9))) ((or variable-struct var-ref-node) (let ((var (if (variable-p node) node (var-ref-variable node)))) (format t "~S ~S ~S ~@[~*Closed-over ~]" (variable-scope var) (variable-kind var) (variable-name var) (variable-closed-over var)) (when (variable-binder var) (cond ((gethash (variable-binder var) *node-hash*) (princ "Binder: ") (print-node (variable-binder var) 0)) (t (new-line) (princ "Binder: ") (print-node (variable-binder var) (+ nested-indent 8)))))))))))))) (defparameter context-test-form '(progn (ctxt) (list (if (ctxt) (ctxt)) (multiple-value-list (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) (ctxt)) (multiple-value-call #'(lambda (a &rest b) (bar a b)) (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) (ctxt) (ctxt)) (let ((x (ctxt))) (setq x (ctxt))) ((lambda (a &optional (b (ctxt))) (ctxt)) (ctxt)) (multiple-value-call #'(lambda (a b) (bar a b)) ((lambda (c) (ctxt)) 17))) (ctxt)) "Form for testing the alphatizer's manipulation of context information.") (defmacro ctxt () (princ-to-string *context*)) (il:* il:|;;| "Arrange to use the correct compiler.") (il:putprops il:xclc-alpha il:filetype compile-file) (il:* il:|;;| "Arrange for the correct makefile environment") (il:putprops il:xclc-alpha il:makefile-environment (:readtable "XCL" :package (defpackage "COMPILER" (:use "LISP" "XCL")))) (il:putprops il:xclc-alpha il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/XCLC-ANALYZE b/sources/XCLC-ANALYZE new file mode 100644 index 00000000..19a429e7 --- /dev/null +++ b/sources/XCLC-ANALYZE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "18-May-90 01:25:52" IL:|{DSK}local>lde>lispcore>sources>XCLC-ANALYZE.;2| 21094 IL:|changes| IL:|to:| (IL:VARS IL:XCLC-ANALYZECOMS) IL:|previous| IL:|date:| " 7-Oct-87 18:39:59" IL:|{DSK}local>lde>lispcore>sources>XCLC-ANALYZE.;1|) ; Copyright (c) 1986, 1987, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-ANALYZECOMS) (IL:RPAQQ IL:XCLC-ANALYZECOMS ( (IL:* IL:|;;| "Analysis of the program tree, prior to and during meta-evaluation") (IL:FUNCTIONS ANALYZE-TREE) (IL:VARIABLES *REDO-FLAG*) (IL:* IL:|;;| "Environment analysis") (IL:FUNCTIONS ENV-ANALYZE) (IL:FUNCTIONS ENV-ANALYZE-BLOCK ENV-ANALYZE-CALL ENV-ANALYZE-CATCH ENV-ANALYZE-GO ENV-ANALYZE-IF ENV-ANALYZE-LABELS ENV-ANALYZE-LAMBDA ENV-ANALYZE-LITERAL ENV-ANALYZE-MV-CALL ENV-ANALYZE-OPCODES ENV-ANALYZE-MV-PROG1 ENV-ANALYZE-PROGN ENV-ANALYZE-PROGV ENV-ANALYZE-RETURN ENV-ANALYZE-SETQ ENV-ANALYZE-TAGBODY ENV-ANALYZE-THROW ENV-ANALYZE-UNWIND-PROTECT ENV-ANALYZE-VAR-REF) (IL:* IL:|;;| "Side-effects analysis") (IL:FUNCTIONS EFFECTS-ANALYZE EFFECTS-UNION REMOVE-EFFECT) (IL:FUNCTIONS EFFECTS-ANALYZE-BLOCK EFFECTS-ANALYZE-CALL EFFECTS-ANALYZE-CATCH EFFECTS-ANALYZE-GO EFFECTS-ANALYZE-IF EFFECTS-ANALYZE-LABELS EFFECTS-ANALYZE-LAMBDA EFFECTS-ANALYZE-LITERAL EFFECTS-ANALYZE-MV-CALL EFFECTS-ANALYZE-MV-PROG1 EFFECTS-ANALYZE-OPCODES EFFECTS-ANALYZE-PROGN EFFECTS-ANALYZE-PROGV EFFECTS-ANALYZE-RETURN EFFECTS-ANALYZE-SETQ EFFECTS-ANALYZE-TAGBODY EFFECTS-ANALYZE-THROW EFFECTS-ANALYZE-UNWIND-PROTECT EFFECTS-ANALYZE-VAR-REF) (IL:FUNCTIONS EFFECTS-ANALYZE-ANY-CALL EFFECTS-ANALYZE-LIST EFFECTS-REPRESENTATION) (IL:* IL:|;;| "Testing analysis") (IL:FUNCTIONS TEST-ANALYSIS) (IL:* IL:|;;| "Arrange to use the proper compiler.") (IL:PROP IL:FILETYPE IL:XCLC-ANALYZE) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-ANALYZE))) (IL:* IL:|;;| "Analysis of the program tree, prior to and during meta-evaluation") (DEFUN ANALYZE-TREE (TREE &OPTIONAL (*REDO-FLAG* :ONCE)) (IL:* IL:|;;;| "The root of all analysis. The variable *REDO-FLAG* is either :ONCE, meaning that only the given node should be analyzed, or :ALL, meaning that the whole tree should be analyzed. This latter operation is rarely, if ever, done.") (ENV-ANALYZE TREE) (IL:* IL:\; "Environment analysis.") (EFFECTS-ANALYZE TREE) (IL:* IL:\; "Side-effects analysis.") TREE) (DEFVAR *REDO-FLAG* NIL (IL:* IL:|;;;| "Used to control the depth of recursion in analysis. It can take on three values:") (IL:* IL:|;;| ":ALL, meaning to recurse all the way down the tree,") (IL:* IL:|;;| ":ONCE, meaning to analyze only the current node, or") (IL:* IL:|;;| "NIL, meaning to do nothing at all.") (IL:* IL:|;;;| "*REDO-FLAG* is only bound or checked in ANALYZE-TREE and the dispatch functions for each kind of analysis.") ) (IL:* IL:|;;| "Environment analysis") (DEFUN ENV-ANALYZE (TREE) (IL:* IL:|;;;| "Environment analysis only does something other than pass the message down in two cases: SETQ and VARIABLE. These two keep track of the read- and write-references to lexical variables.") (WHEN (NOT (NULL *REDO-FLAG*)) (LET ((*REDO-FLAG* (AND (EQ *REDO-FLAG* :ALL) :ALL))) (NODE-DISPATCH ENV-ANALYZE TREE)))) (DEFUN ENV-ANALYZE-BLOCK (NODE) (ENV-ANALYZE (BLOCK-STMT NODE))) (DEFUN ENV-ANALYZE-CALL (NODE) (ENV-ANALYZE (CALL-FN NODE)) (IL:FOR ARG IL:IN (CALL-ARGS NODE) IL:DO (ENV-ANALYZE ARG))) (DEFUN ENV-ANALYZE-CATCH (NODE) (ENV-ANALYZE (CATCH-TAG NODE)) (ENV-ANALYZE (CATCH-STMT NODE))) (DEFUN ENV-ANALYZE-GO (NODE) NIL) (DEFUN ENV-ANALYZE-IF (NODE) (ENV-ANALYZE (IF-PRED NODE)) (ENV-ANALYZE (IF-THEN NODE)) (ENV-ANALYZE (IF-ELSE NODE))) (DEFUN ENV-ANALYZE-LABELS (NODE) (ENV-ANALYZE (LABELS-BODY NODE)) (IL:FOR FUN IL:IN (LABELS-FUNS NODE) IL:DO (ENV-ANALYZE (CDR FUN)))) (DEFUN ENV-ANALYZE-LAMBDA (NODE) (ENV-ANALYZE (LAMBDA-BODY NODE)) (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL NODE) IL:DO (ENV-ANALYZE (SECOND OPT-VAR))) (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD NODE) IL:DO (ENV-ANALYZE (THIRD KEY-VAR)))) (DEFUN ENV-ANALYZE-LITERAL (NODE) NIL) (DEFUN ENV-ANALYZE-MV-CALL (NODE) (ENV-ANALYZE (MV-CALL-FN NODE)) (IL:FOR ARG IL:IN (MV-CALL-ARG-EXPRS NODE) IL:DO (ENV-ANALYZE ARG))) (DEFUN ENV-ANALYZE-OPCODES (NODE) NIL) (DEFUN ENV-ANALYZE-MV-PROG1 (NODE) (IL:FOR STMT IL:IN (MV-PROG1-STMTS NODE) IL:DO (ENV-ANALYZE STMT))) (DEFUN ENV-ANALYZE-PROGN (NODE) (IL:FOR STMT IL:IN (PROGN-STMTS NODE) IL:DO (ENV-ANALYZE STMT))) (DEFUN ENV-ANALYZE-PROGV (NODE) (ENV-ANALYZE (PROGV-SYMS-EXPR NODE)) (ENV-ANALYZE (PROGV-VALS-EXPR NODE)) (ENV-ANALYZE (PROGV-STMT NODE))) (DEFUN ENV-ANALYZE-RETURN (NODE) (ENV-ANALYZE (RETURN-VALUE NODE))) (DEFUN ENV-ANALYZE-SETQ (NODE) (IL:* IL:|;;|  "This one actually does something: we note the write-ref to the variable being SETQ'd.") (PUSHNEW NODE (VARIABLE-WRITE-REFS (SETQ-VAR NODE))) (ENV-ANALYZE (SETQ-VALUE NODE))) (DEFUN ENV-ANALYZE-TAGBODY (NODE) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (IL:FOR STMT IL:IN (SEGMENT-STMTS SEGMENT) IL:DO (ENV-ANALYZE STMT)))) (DEFUN ENV-ANALYZE-THROW (NODE) (ENV-ANALYZE (THROW-TAG NODE)) (ENV-ANALYZE (THROW-VALUE NODE))) (DEFUN ENV-ANALYZE-UNWIND-PROTECT (NODE) (ENV-ANALYZE (UNWIND-PROTECT-STMT NODE)) (ENV-ANALYZE (UNWIND-PROTECT-CLEANUP NODE))) (DEFUN ENV-ANALYZE-VAR-REF (NODE) (IL:* IL:|;;|  "This one actually does something: we note this read-ref to the variable being referenced.") (PUSHNEW NODE (VARIABLE-READ-REFS (VAR-REF-VARIABLE NODE)))) (IL:* IL:|;;| "Side-effects analysis") (DEFUN EFFECTS-ANALYZE (TREE) (IL:* IL:|;;;| "Side-effects analysis methods store the side-effects data for the subtree they're given in the node at the root of that subtree (in the EFFECTS and AFFECTED fields).") (WHEN (AND (NOT (NULL *REDO-FLAG*)) (NOT (NULL TREE))) (LET ((*REDO-FLAG* (AND (EQ *REDO-FLAG* :ALL) :ALL))) (NODE-DISPATCH EFFECTS-ANALYZE TREE)))) (DEFUN EFFECTS-UNION (ONE TWO) (IL:* IL:|;;;| "Return a side-effects description representing the union of the two descriptions given.") (COND ((EQ :NONE ONE) TWO) ((EQ :NONE TWO) ONE) ((OR (EQ :ANY ONE) (EQ :ANY TWO)) :ANY) (T (UNION (IL:MKLIST ONE) (IL:MKLIST TWO))))) (DEFUN REMOVE-EFFECT (EFFECT EFFECTS-REP) (IF (OR (EQ :NONE EFFECTS-REP) (EQ :ANY EFFECTS-REP)) EFFECTS-REP (REMOVE EFFECT (IL:MKLIST EFFECTS-REP)))) (DEFUN EFFECTS-ANALYZE-BLOCK (NODE) (IL:* IL:|;;;| "The side-effect of a RETURN is represented by the BLOCK from which it is returning. Thus, we can remove this node from the effects since the RETURN is invisible outside the BLOCK.") (EFFECTS-ANALYZE (BLOCK-STMT NODE)) (SETF (NODE-EFFECTS NODE) (REMOVE-EFFECT NODE (NODE-EFFECTS (BLOCK-STMT NODE)))) (SETF (NODE-AFFECTED NODE) (NODE-EFFECTS (BLOCK-STMT NODE)))) (DEFUN EFFECTS-ANALYZE-CALL (NODE) (IL:* IL:|;;;| "Much code can be shared between CALL and MV-CALL here.") (EFFECTS-ANALYZE-ANY-CALL NODE (CALL-FN NODE) (CALL-ARGS NODE))) (DEFUN EFFECTS-ANALYZE-CATCH (NODE) (EFFECTS-ANALYZE-LIST NODE (LIST (CATCH-TAG NODE) (CATCH-STMT NODE)))) (DEFUN EFFECTS-ANALYZE-GO (NODE) (IL:* IL:|;;;| "The side-effect of a GO is represented by the TAGBODY to which it is GOing.") (SETF (NODE-EFFECTS NODE) (LIST (GO-TAGBODY NODE))) (SETF (NODE-AFFECTED NODE) :NONE)) (DEFUN EFFECTS-ANALYZE-IF (NODE) (EFFECTS-ANALYZE-LIST NODE (LIST (IF-PRED NODE) (IF-THEN NODE) (IF-ELSE NODE)))) (DEFUN EFFECTS-ANALYZE-LABELS (NODE) (IL:* IL:|;;;| "The effects of a LABELS are exactly those of the body. The functions have no effects.") (DOLIST (FUN (LABELS-FUNS NODE)) (EFFECTS-ANALYZE-LAMBDA (CDR FUN))) (EFFECTS-ANALYZE (LABELS-BODY NODE)) (SETF (NODE-EFFECTS NODE) (NODE-EFFECTS (LABELS-BODY NODE))) (SETF (NODE-AFFECTED NODE) (NODE-AFFECTED (LABELS-BODY NODE)))) (DEFUN EFFECTS-ANALYZE-LAMBDA (NODE) (LET ((EFFECTS :NONE) (AFFECTED :NONE)) (DOLIST (OPT-VAR (LAMBDA-OPTIONAL NODE)) (EFFECTS-ANALYZE (SECOND OPT-VAR)) (SETQ EFFECTS (EFFECTS-UNION EFFECTS (NODE-EFFECTS (SECOND OPT-VAR)))) (SETQ AFFECTED (EFFECTS-UNION AFFECTED (NODE-AFFECTED (SECOND OPT-VAR))))) (DOLIST (KEY-VAR (LAMBDA-KEYWORD NODE)) (EFFECTS-ANALYZE (THIRD KEY-VAR)) (SETQ EFFECTS (EFFECTS-UNION EFFECTS (NODE-EFFECTS (THIRD KEY-VAR)))) (SETQ AFFECTED (EFFECTS-UNION AFFECTED (NODE-AFFECTED (THIRD KEY-VAR))))) (EFFECTS-ANALYZE (LAMBDA-BODY NODE)) (IL:* IL:|;;|  "Save the information on the lambda as applied; it can be used by EFFECTS-ANALYZE-CALL.") (SETF (LAMBDA-APPLIED-EFFECTS NODE) (EFFECTS-UNION EFFECTS (NODE-EFFECTS (LAMBDA-BODY NODE)))) (SETF (LAMBDA-APPLIED-AFFECTED NODE) (EFFECTS-UNION AFFECTED (NODE-AFFECTED (LAMBDA-BODY NODE)))) (IL:* IL:|;;| "The LAMBDA itself has no effects and cannot be affected.") (SETF (NODE-EFFECTS NODE) :NONE) (SETF (NODE-AFFECTED NODE) :NONE))) (DEFUN EFFECTS-ANALYZE-LITERAL (NODE) (IL:* IL:|;;;| "") (IL:IF (EVAL-WHEN-LOAD-P (LITERAL-VALUE NODE)) IL:THEN (IL:* IL:|;;| "A load-time form can have any side effects and be affected by anything - in the future we can be smarter about examining the form itself.") (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) :NONE) IL:ELSE (SETF (NODE-EFFECTS NODE) :NONE) (SETF (NODE-AFFECTED NODE) :NONE))) (DEFUN EFFECTS-ANALYZE-MV-CALL (NODE) (IL:* IL:|;;;| "Much code can be shared between MV-CALL and CALL here.") (EFFECTS-ANALYZE-ANY-CALL NODE (MV-CALL-FN NODE) (MV-CALL-ARG-EXPRS NODE))) (DEFUN EFFECTS-ANALYZE-MV-PROG1 (NODE) (EFFECTS-ANALYZE-LIST NODE (MV-PROG1-STMTS NODE))) (DEFUN EFFECTS-ANALYZE-OPCODES (NODE) (IL:* IL:|;;;| "Remember that OPCODES nodes can only appear in a functional context. What we're asking for here is not the effect of executing the opcodes but the effect of computing them in the first place. Since they're constants, they behave like literals. See EFFECTS-ANALYZE-CALL for the place where we decide we know nothing about any opcodes' effects.") (SETF (NODE-EFFECTS NODE) :NONE) (SETF (NODE-AFFECTED NODE) :NONE)) (DEFUN EFFECTS-ANALYZE-PROGN (NODE) (EFFECTS-ANALYZE-LIST NODE (PROGN-STMTS NODE))) (DEFUN EFFECTS-ANALYZE-PROGV (NODE) (EFFECTS-ANALYZE-LIST NODE (LIST (PROGV-SYMS-EXPR NODE) (PROGV-VALS-EXPR NODE) (PROGV-STMT NODE)))) (DEFUN EFFECTS-ANALYZE-RETURN (NODE) (IL:* IL:|;;;| "The side effect of a RETURN is represented by the BLOCK from which it is returning.") (EFFECTS-ANALYZE (RETURN-VALUE NODE)) (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION (LIST (RETURN-BLOCK NODE)) (NODE-EFFECTS (RETURN-VALUE NODE)))) (SETF (NODE-AFFECTED NODE) (NODE-AFFECTED (RETURN-VALUE NODE)))) (DEFUN EFFECTS-ANALYZE-SETQ (NODE) (IL:* IL:|;;;| "") (EFFECTS-ANALYZE (SETQ-VALUE NODE)) (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION (EFFECTS-REPRESENTATION (SETQ-VAR NODE)) (NODE-EFFECTS (SETQ-VALUE NODE)))) (SETF (NODE-AFFECTED NODE) (NODE-AFFECTED (SETQ-VALUE NODE)))) (DEFUN EFFECTS-ANALYZE-TAGBODY (NODE) (IL:* IL:|;;;| "The side-effect for a GO is represented by the TAGBODY to which it is GOing. Since the GO is invisible outside the TAGBODY, we can remove the TAGBODY from the effects.") (DO ((SEGMENTS (TAGBODY-SEGMENTS NODE) (CDR SEGMENTS)) (EFFECTS :NONE) (AFFECTED :NONE)) ((NULL SEGMENTS) (SETF (NODE-EFFECTS NODE) (REMOVE-EFFECT NODE EFFECTS)) (SETF (NODE-AFFECTED NODE) AFFECTED)) (IL:* IL:|;;| "For each segment, analyze each statement and accumulate the results.") (DOLIST (STMT (SEGMENT-STMTS (CAR SEGMENTS))) (EFFECTS-ANALYZE STMT) (SETQ EFFECTS (EFFECTS-UNION EFFECTS (NODE-EFFECTS STMT))) (SETQ AFFECTED (EFFECTS-UNION AFFECTED (NODE-AFFECTED STMT)))))) (DEFUN EFFECTS-ANALYZE-THROW (NODE) (EFFECTS-ANALYZE (THROW-TAG NODE)) (EFFECTS-ANALYZE (THROW-VALUE NODE)) (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) (EFFECTS-UNION (NODE-AFFECTED (THROW-TAG NODE)) (NODE-AFFECTED (THROW-VALUE NODE))))) (DEFUN EFFECTS-ANALYZE-UNWIND-PROTECT (NODE) (IL:* IL:|;;;| "") (EFFECTS-ANALYZE-LAMBDA (UNWIND-PROTECT-STMT NODE)) (EFFECTS-ANALYZE-LAMBDA (UNWIND-PROTECT-CLEANUP NODE)) (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION (LAMBDA-APPLIED-EFFECTS (UNWIND-PROTECT-STMT NODE)) (LAMBDA-APPLIED-EFFECTS (UNWIND-PROTECT-CLEANUP NODE)))) (SETF (NODE-AFFECTED NODE) (EFFECTS-UNION (LAMBDA-APPLIED-AFFECTED (UNWIND-PROTECT-STMT NODE)) (LAMBDA-APPLIED-AFFECTED (UNWIND-PROTECT-CLEANUP NODE))))) (DEFUN EFFECTS-ANALYZE-VAR-REF (NODE) (IL:* IL:|;;;| "") (SETF (NODE-EFFECTS NODE) :NONE) (SETF (NODE-AFFECTED NODE) (EFFECTS-REPRESENTATION (VAR-REF-VARIABLE NODE)))) (DEFUN EFFECTS-ANALYZE-ANY-CALL (NODE FN ARGUMENTS) (IL:* IL:|;;;| "") (DO ((ARGS ARGUMENTS (CDR ARGS)) (EFFECTS :NONE (EFFECTS-UNION EFFECTS (NODE-EFFECTS (CAR ARGS)))) (AFFECTED :NONE (EFFECTS-UNION AFFECTED (NODE-AFFECTED (CAR ARGS))))) ((NULL ARGS) (IL:* IL:|;;| "Look at the function. If we don't know anything about it, assume the worst: both EFFECTS and AFFECTED are :ANY.") (EFFECTS-ANALYZE FN) (TYPECASE FN (LAMBDA-NODE (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION EFFECTS (LAMBDA-APPLIED-EFFECTS FN))) (SETF (NODE-AFFECTED NODE) (EFFECTS-UNION AFFECTED (LAMBDA-APPLIED-AFFECTED FN)))) (VAR-REF-NODE (LET ((VAR (VAR-REF-VARIABLE FN))) (COND ((CALLER-NOT-INLINE NODE) (IL:* IL:|;;|  "If the function is not inline-expandable, we can't assume any knowledge of it.") (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) :ANY)) ((EQ :FUNCTION (VARIABLE-KIND VAR)) (ECASE (VARIABLE-SCOPE VAR) (:GLOBAL (IL:* IL:|;;| "Just look in the database. We should be smarter about remembering side-effects of user functions when we can.") (LET ((DATA (SIDE-EFFECTS (VARIABLE-NAME VAR)))) (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION EFFECTS (OR (CAR DATA) :ANY))) (SETF (NODE-AFFECTED NODE) (EFFECTS-UNION AFFECTED (OR (CDR DATA) :ANY))))) (:LEXICAL (IL:* IL:|;;| "Local function vars are only bound by LABELS nodes.") (IF (TYPEP (VARIABLE-BINDER VAR) 'LABELS-NODE) (IL:* IL:|;;|  "This is good - we can easily find the function definition and extract its side-effects.") (LET ((FN-DEF (CDR (ASSOC VAR (LABELS-FUNS (VARIABLE-BINDER VAR)) :TEST 'EQ)))) (ASSERT (NOT (NULL FN-DEF)) NIL "BUG: Referenced lexical function not found!") (SETF (NODE-EFFECTS NODE) (EFFECTS-UNION EFFECTS (LAMBDA-APPLIED-EFFECTS FN-DEF)) ) (SETF (NODE-AFFECTED NODE) (EFFECTS-UNION AFFECTED (LAMBDA-APPLIED-AFFECTED FN-DEF )))) (IL:* IL:|;;|  "Damn! We can't find the function definition to get at its side-effects. Assume the worst...") (PROGN (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) :ANY)))))) (T (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) :ANY))))) (OTHERWISE (SETF (NODE-EFFECTS NODE) :ANY) (SETF (NODE-AFFECTED NODE) :ANY)))) (IL:* IL:|;;| "For each argument, analyze it.") (EFFECTS-ANALYZE (CAR ARGS)))) (DEFUN EFFECTS-ANALYZE-LIST (NODE LIST) (IL:* IL:|;;;| "") (DO ((STMTS LIST (CDR STMTS)) (EFFECTS :NONE (EFFECTS-UNION EFFECTS (NODE-EFFECTS (CAR STMTS)))) (AFFECTED :NONE (EFFECTS-UNION AFFECTED (NODE-AFFECTED (CAR STMTS))))) ((NULL STMTS) (SETF (NODE-EFFECTS NODE) EFFECTS) (SETF (NODE-AFFECTED NODE) AFFECTED)) (IL:* IL:|;;| "Analyze each statement.") (EFFECTS-ANALYZE (CAR STMTS)))) (DEFUN EFFECTS-REPRESENTATION (VAR) (IL:* IL:|;;;| "Give a VARIABLE, return the representation of what is effected by a SETQ. Lexical variables are represented by themselves because they're unique in the tree, but specials and globals must be represented by the name, since they aren't unique.") (ECASE (VARIABLE-KIND VAR) (:FUNCTION :NONE) (:VARIABLE (ECASE (VARIABLE-SCOPE VAR) ((:SPECIAL :GLOBAL) (LIST (VARIABLE-NAME VAR))) ((:LEXICAL) (LIST VAR)))))) (IL:* IL:|;;| "Testing analysis") (DEFUN TEST-ANALYSIS (FN) (LET ((TREE (TEST-ALPHA-2 FN))) (UNWIND-PROTECT (PRINT-TREE (ANALYZE-TREE TREE :ALL)) (RELEASE-TREE TREE)))) (IL:* IL:|;;| "Arrange to use the proper compiler.") (IL:PUTPROPS IL:XCLC-ANALYZE IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange for the proper makefile environment") (IL:PUTPROPS IL:XCLC-ANALYZE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-ANALYZE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-ANNOTATE b/sources/XCLC-ANNOTATE new file mode 100644 index 00000000..36880744 --- /dev/null +++ b/sources/XCLC-ANNOTATE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "18-May-90 01:28:45" IL:|{DSK}local>lde>lispcore>sources>XCLC-ANNOTATE.;2| 28066 IL:|changes| IL:|to:| (IL:VARS IL:XCLC-ANNOTATECOMS) IL:|previous| IL:|date:| " 3-May-88 17:43:47" IL:|{DSK}local>lde>lispcore>sources>XCLC-ANNOTATE.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-ANNOTATECOMS) (IL:RPAQQ IL:XCLC-ANNOTATECOMS ( (IL:* IL:|;;| "Annotation of the program tree") (IL:FUNCTIONS ANNOTATE-TREE) (IL:* IL:|;;| "Frame Annotation") (IL:VARIABLES *REFERENCES*) (IL:FUNCTIONS FRAME-ANNOTATE CLOSE-OVER) (IL:FUNCTIONS FRAME-ANNOTATE-BLOCK FRAME-ANNOTATE-CALL FRAME-ANNOTATE-CATCH FRAME-ANNOTATE-GO FRAME-ANNOTATE-IF FRAME-ANNOTATE-LABELS FRAME-ANNOTATE-LAMBDA FRAME-ANNOTATE-LITERAL FRAME-ANNOTATE-MV-CALL FRAME-ANNOTATE-MV-PROG1 FRAME-ANNOTATE-OPCODES FRAME-ANNOTATE-PROGN FRAME-ANNOTATE-PROGV FRAME-ANNOTATE-RETURN FRAME-ANNOTATE-SETQ FRAME-ANNOTATE-TAGBODY FRAME-ANNOTATE-THROW FRAME-ANNOTATE-UNWIND-PROTECT FRAME-ANNOTATE-VAR-REF) (IL:* IL:|;;| "Closure annotation") (IL:VARIABLES *NEED-STORAGE*) (IL:FUNCTIONS CLOSURE-ANNOTATE) (IL:I.S.OPRS UNIONING) (IL:FUNCTIONS CLOSURE-ANNOTATE-BLOCK CLOSURE-ANNOTATE-CALL CLOSURE-ANNOTATE-CATCH CLOSURE-ANNOTATE-GO CLOSURE-ANNOTATE-IF CLOSURE-ANNOTATE-LABELS CLOSURE-ANNOTATE-LAMBDA CLOSURE-ANNOTATE-LITERAL CLOSURE-ANNOTATE-MV-CALL CLOSURE-ANNOTATE-MV-PROG1 CLOSURE-ANNOTATE-OPCODES CLOSURE-ANNOTATE-PROGN CLOSURE-ANNOTATE-PROGV CLOSURE-ANNOTATE-RETURN CLOSURE-ANNOTATE-SETQ CLOSURE-ANNOTATE-TAGBODY CLOSURE-ANNOTATE-THROW CLOSURE-ANNOTATE-UNWIND-PROTECT CLOSURE-ANNOTATE-VAR-REF) (IL:* IL:|;;| "Testing annotation ") (IL:FUNCTIONS TEST-ANNOTATION) (IL:* IL:|;;| "Arrange to use the proper compiler.") (IL:PROP IL:FILETYPE IL:XCLC-ANNOTATE) (IL:* IL:|;;| "Arrange for the proper makefile-environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-ANNOTATE))) (IL:* IL:|;;| "Annotation of the program tree") (DEFUN ANNOTATE-TREE (TREE) (IL:* IL:|;;| "Perform those analyses of the program that are not used by meta-evaluation and which may be expensive to redo.") (FRAME-ANNOTATE TREE) (CLOSURE-ANNOTATE TREE NIL) TREE) (IL:* IL:|;;| "Frame Annotation") (DEFVAR *REFERENCES* NIL "A list of pairs representing references to blippers below this point. Used in frame analysis." ) (DEFUN FRAME-ANNOTATE (NODE) (IL:* IL:|;;;| "Frame annotation methods are used to discover which constructs in the program need separate frames at run time. The limitations are that some LAMBDA's are too complex to be treated inline and that the various blippers (TAGBODY, BLOCK, and CATCH) must share the blip slot among themselves. No two blippers can be using the slot at the same time, so the inner of the two must use a new frame and, thus, a new blip slot. Both TAGBODY and BLOCK require the blip slot if and only if they can be dynamically separated from a reference to them (i.e., a corresponding GO or RETURN-FROM). We call this being ''closed-over''.") (IL:* IL:|;;;| "Thus, frame analysis works as follows:") (IL:* IL:|;;;| "Referencers (GO and RETURN-FROM) push a pair onto the special variable *REFERENCES*.") (IL:* IL:|;;;| "Constructs that can require new frames (blippers and LAMBDA's) bind *REFERENCES* so that they can mark as closed over the referrees that will be separated from their referrers.") (IL:* IL:|;;;| "Possible referrees (TAGBODY and BLOCK) bind *REFERENCES* so that they can filter out any references to themselves before letting the list go higher in the tree.") (IL:* IL:|;;;| "Blippers ''request'' use of the blip slot by returning themselves from the method. All nodes keep track of the list of requests from below them and return that list. Such lists may be destructively NCONC'ed. An invariant of the request list is that all of the requests are mutually exclusive; i.e., no two are nested, one within the other.") (IL:* IL:|;;;| "To maintain this invariant, any blipper that makes a request must tell each of its subordinate requestors that they must be separate frames. Those requestors, in turn, must arrange that the references below them are made aware of their new closed-over status.") (IL:* IL:|;;;| "The astute reader who notices the possibility of infinite regress at this point is to be reassured. The full explanation, in the XCL Compiler Implementor's Handbook, contains a proof of the algorithm's correctness.") (AND NODE (NODE-DISPATCH FRAME-ANNOTATE NODE))) (DEFUN CLOSE-OVER (REFERENCE) (ETYPECASE (CAR REFERENCE) (GO-NODE (LET ((TAGBODY (CDR REFERENCE)) (TAG (GO-TAG (CAR REFERENCE)))) (SETF (TAGBODY-CLOSED-OVER-P TAGBODY) T) (SETF (SEGMENT-CLOSED-OVER-P (FIND-SEGMENT TAGBODY TAG)) T))) (RETURN-NODE (SETF (BLOCK-CLOSED-OVER-P (CDR REFERENCE)) T)))) (DEFUN FRAME-ANNOTATE-BLOCK (SELF) (IL:* IL:|;;| "This is one of the interesting ones. If we are closed over, tell the requests that they need to be separate frames, tell their lists of references that they're closed-over, save our references, and request a blip for us. If we're not closed over, then become a requestor only if we received some requests.") (LET (OUTER-REFERENCES REQUESTS) (LET (*REFERENCES*) (SETQ REQUESTS (FRAME-ANNOTATE (BLOCK-STMT SELF))) (SETQ OUTER-REFERENCES (DELETE-IF #'(LAMBDA (REFERENCE) (EQ SELF (CDR REFERENCE))) *REFERENCES*)) (COND ((BLOCK-CLOSED-OVER-P SELF) (IL:FOR REQUESTOR IL:IN REQUESTS IL:DO (SETF (BLIPPER-NEW-FRAME-P REQUESTOR) T) (IL:FOR REFERENCE IL:IN (BLIPPER-REFERENCES REQUESTOR) IL:DO (CLOSE-OVER REFERENCE))) (SETF (BLIPPER-REFERENCES SELF) (COPY-LIST OUTER-REFERENCES)) (SETQ REQUESTS (LIST SELF))) ((NOT (NULL REQUESTS)) (SETQ REQUESTS (LIST SELF))))) (SETQ *REFERENCES* (NUNION OUTER-REFERENCES *REFERENCES* :TEST 'EQUAL)) REQUESTS)) (DEFUN FRAME-ANNOTATE-CALL (SELF) (IL:* IL:|;;| "Check for a LAMBDA in the function position and let it know that's where it is.") (NCONC (IF (LAMBDA-P (CALL-FN SELF)) (FRAME-ANNOTATE-LAMBDA (CALL-FN SELF) T) (FRAME-ANNOTATE (CALL-FN SELF))) (IL:FOR ARG IL:IN (CALL-ARGS SELF) IL:JOIN (FRAME-ANNOTATE ARG)))) (DEFUN FRAME-ANNOTATE-CATCH (SELF) (IL:* IL:|;;| "This is one of the interesting ones. A CATCH always needs a blip slot, but it can share that slot with other blippers.") (LET (OUTER-REFERENCES) (LET (*REFERENCES*) (SETQ OUTER-REFERENCES *REFERENCES*) (IL:FOR REQUESTOR IL:IN (FRAME-ANNOTATE (CATCH-STMT SELF)) IL:DO (SETF (BLIPPER-NEW-FRAME-P REQUESTOR) T) (IL:FOR REFERENCE IL:IN (BLIPPER-REFERENCES REQUESTOR) IL:DO (CLOSE-OVER REFERENCE))) (SETQ OUTER-REFERENCES *REFERENCES*) (SETF (BLIPPER-REFERENCES SELF) (COPY-LIST *REFERENCES*))) (SETQ *REFERENCES* (NUNION OUTER-REFERENCES *REFERENCES* :TEST 'EQUAL)) (CONS SELF (FRAME-ANNOTATE (CATCH-TAG SELF))))) (DEFUN FRAME-ANNOTATE-GO (SELF) (IL:* IL:|;;| "This is one of the interesting ones. Add this GO to the list of references.") (PUSHNEW (CONS SELF (GO-TAGBODY SELF)) *REFERENCES* :TEST 'EQUAL) NIL) (DEFUN FRAME-ANNOTATE-IF (SELF) (NCONC (FRAME-ANNOTATE (IF-PRED SELF)) (FRAME-ANNOTATE (IF-THEN SELF)) (FRAME-ANNOTATE (IF-ELSE SELF)))) (DEFUN FRAME-ANNOTATE-LABELS (SELF) (NCONC (IL:FOR PAIR IL:IN (LABELS-FUNS SELF) IL:JOIN (FRAME-ANNOTATE (CDR PAIR))) (FRAME-ANNOTATE (LABELS-BODY SELF)))) (DEFUN FRAME-ANNOTATE-LAMBDA (SELF &OPTIONAL FUNCTIONAL-POSITION-P) (IL:* IL:|;;;| "This is one of the interesting ones.") (IL:* IL:|;;;| "The first thing is to decide whether or not this lambda must be a separate frame. If it has only required parameters and appears in functional position, then it need not be a separate frame. However, Interlisp's lambda no-spread's cannot be separate frames.") (IL:* IL:|;;;| "If this lambda is not a separate frame, then it transparently passes along the requests from below. Otherwise, however, it will be a separate frame and can accept the requests from below. It thus discards the requests and posts a new, empty list. Also, any references from below are closed over.") (SETF (LAMBDA-NEW-FRAME-P SELF) (OR (NOT FUNCTIONAL-POSITION-P) (LAMBDA-KEYWORD SELF) (LAMBDA-REST SELF) (LAMBDA-OPTIONAL SELF) (EQ 2 (LAMBDA-ARG-TYPE SELF)))) (LET (OUTER-REFERENCES OUTER-REQUESTS) (LET (*REFERENCES*) (LET ((REQUESTS (NCONC (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL SELF) IL:JOIN (FRAME-ANNOTATE (SECOND OPT-VAR))) (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD SELF) IL:JOIN (FRAME-ANNOTATE (THIRD KEY-VAR))) (FRAME-ANNOTATE (LAMBDA-BODY SELF))))) (COND ((LAMBDA-NEW-FRAME-P SELF) (IL:* IL:\; "We're opaque.") (SETQ OUTER-REQUESTS NIL) (SETQ OUTER-REFERENCES NIL) (IL:FOR REFERENCE IL:IN *REFERENCES* IL:DO (CLOSE-OVER REFERENCE))) (T (IL:* IL:\; "We're transparent.") (SETQ OUTER-REQUESTS REQUESTS) (SETQ OUTER-REFERENCES *REFERENCES*))))) (SETQ *REFERENCES* (NUNION OUTER-REFERENCES *REFERENCES* :TEST 'EQUAL)) OUTER-REQUESTS)) (DEFUN FRAME-ANNOTATE-LITERAL (SELF) NIL) (DEFUN FRAME-ANNOTATE-MV-CALL (SELF) (NCONC (FRAME-ANNOTATE (MV-CALL-FN SELF)) (IL:FOR ARG IL:IN (MV-CALL-ARG-EXPRS SELF) IL:JOIN (FRAME-ANNOTATE ARG)))) (DEFUN FRAME-ANNOTATE-MV-PROG1 (SELF) (IL:|for| STMT IL:|in| (MV-PROG1-STMTS SELF) IL:|join| (FRAME-ANNOTATE STMT))) (DEFUN FRAME-ANNOTATE-OPCODES (SELF) NIL) (DEFUN FRAME-ANNOTATE-PROGN (SELF) (IL:FOR STMT IL:IN (PROGN-STMTS SELF) IL:JOIN (FRAME-ANNOTATE STMT))) (DEFUN FRAME-ANNOTATE-PROGV (SELF) (NCONC (FRAME-ANNOTATE (PROGV-SYMS-EXPR SELF)) (FRAME-ANNOTATE (PROGV-VALS-EXPR SELF)) (FRAME-ANNOTATE (PROGV-STMT SELF)))) (DEFUN FRAME-ANNOTATE-RETURN (SELF) (IL:* IL:|;;| "This is one of the interesting ones. Add this RETURN to the list of references.") (PUSHNEW (CONS SELF (RETURN-BLOCK SELF)) *REFERENCES* :TEST 'EQUAL) (FRAME-ANNOTATE (RETURN-VALUE SELF))) (DEFUN FRAME-ANNOTATE-SETQ (SELF) (FRAME-ANNOTATE (SETQ-VALUE SELF))) (DEFUN FRAME-ANNOTATE-TAGBODY (SELF) (IL:* IL:|;;| "This is one of the interesting ones. If we are closed over, tell the requests that they need to be separate frames, tell their lists of references that they're closed-over, save our references, and request a blip for us. If we're not closed over, then become a requestor only if we received some requests.") (LET (OUTER-REFERENCES REQUESTS) (LET (*REFERENCES*) (SETQ REQUESTS (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS SELF) IL:JOIN (IL:FOR STMT IL:IN (SEGMENT-STMTS SEGMENT) IL:JOIN (FRAME-ANNOTATE STMT)))) (SETQ OUTER-REFERENCES (DELETE-IF #'(LAMBDA (REFERENCE) (EQ SELF (CDR REFERENCE))) *REFERENCES*)) (COND ((BLIPPER-CLOSED-OVER-P SELF) (IL:FOR REQUESTOR IL:IN REQUESTS IL:DO (SETF (BLIPPER-NEW-FRAME-P REQUESTOR) T) (IL:FOR REFERENCE IL:IN (BLIPPER-REFERENCES REQUESTOR) IL:DO (CLOSE-OVER REFERENCE))) (SETF (BLIPPER-REFERENCES SELF) (COPY-LIST OUTER-REFERENCES)) (SETQ REQUESTS (LIST SELF))) ((NOT (NULL REQUESTS)) (SETQ REQUESTS (LIST SELF))))) (SETQ *REFERENCES* (NUNION OUTER-REFERENCES *REFERENCES* :TEST 'EQUAL)) REQUESTS)) (DEFUN FRAME-ANNOTATE-THROW (SELF) (NCONC (FRAME-ANNOTATE (THROW-TAG SELF)) (FRAME-ANNOTATE (THROW-VALUE SELF)))) (DEFUN FRAME-ANNOTATE-UNWIND-PROTECT (SELF) (NCONC (FRAME-ANNOTATE (UNWIND-PROTECT-STMT SELF)) (FRAME-ANNOTATE (UNWIND-PROTECT-CLEANUP SELF)))) (DEFUN FRAME-ANNOTATE-VAR-REF (SELF) NIL) (IL:* IL:|;;| "Closure annotation") (DEFVAR *NEED-STORAGE* NIL "A list of lexical variables that are both closed over and not being allocated space by their binders. Used during closure analysis." ) (DEFUN CLOSURE-ANNOTATE (NODE IN-LOOP-P) (IL:* IL:|;;;| "In closure analysis, the method pushes closed-over VARIABLEs that are not being allocated storage by their binders onto *NEED-STORAGE* and returns a list of the lexical VARIABLEs referenced freely below. IN-LOOP-P is non-nil if inside a tagbody that might contain a loop.") (AND NODE (NODE-DISPATCH CLOSURE-ANNOTATE NODE IN-LOOP-P))) (IL:DECLARE\: IL:EVAL@COMPILE (IL:I.S.OPR 'UNIONING '(SETQ IL:$$VAL (UNION IL:BODY IL:$$VAL))) ) (DEFUN CLOSURE-ANNOTATE-BLOCK (NODE IN-LOOP-P) (IL:* IL:|;;;| "A block is a binder exactly when it is closed over.") (LET (OUTER-NEED-STORAGE NON-LOCALS) (LET (*NEED-STORAGE*) (COND ((BLOCK-NEW-FRAME-P NODE) (IL:FOR VAR IL:IN (CLOSURE-ANNOTATE (BLOCK-STMT NODE) NIL) IL:DO (SETF (VARIABLE-CLOSED-OVER VAR) T)) (SETQ NON-LOCALS NIL)) (T (SETQ NON-LOCALS (CLOSURE-ANNOTATE (BLOCK-STMT NODE) IN-LOOP-P)))) (COND ((BLOCK-CLOSED-OVER-P NODE) (SETF (BLOCK-BLIP-VAR NODE) (MAKE-VARIABLE :SCOPE :LEXICAL :KIND :VARIABLE :NAME "Control blip" :BINDER NODE :CLOSED-OVER T)) (IF (OR (BLOCK-NEW-FRAME-P NODE) IN-LOOP-P) (SETF (BLOCK-CLOSED-OVER-VARS NODE) (CONS (BLOCK-BLIP-VAR NODE) *NEED-STORAGE*)) (SETQ OUTER-NEED-STORAGE (CONS (BLOCK-BLIP-VAR NODE) *NEED-STORAGE*)))) (T (IF (BLOCK-NEW-FRAME-P NODE) (SETF (BLOCK-CLOSED-OVER-VARS NODE) *NEED-STORAGE*) (SETQ OUTER-NEED-STORAGE *NEED-STORAGE*))))) (SETQ *NEED-STORAGE* (UNION OUTER-NEED-STORAGE *NEED-STORAGE*)) NON-LOCALS)) (DEFUN CLOSURE-ANNOTATE-CALL (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (CALL-FN NODE) IN-LOOP-P) (IL:FOR ARG IL:IN (CALL-ARGS NODE) UNIONING (CLOSURE-ANNOTATE ARG IN-LOOP-P)))) (DEFUN CLOSURE-ANNOTATE-CATCH (NODE IN-LOOP-P) (IL:* IL:|;;;| "If we are supposed to be a new frame, then we have to close over all of the non-local references in the catch-stmt and take responsibility for allocating storage for all of the variables in *NEED-STORAGE*. If we aren't a new frame, then we needn't do anything special here.") (COND ((BLIPPER-NEW-FRAME-P NODE) (LET (*NEED-STORAGE*) (IL:FOR VAR IL:IN (CLOSURE-ANNOTATE (CATCH-STMT NODE) NIL) IL:DO (SETF (VARIABLE-CLOSED-OVER VAR) T)) (SETF (CATCH-CLOSED-OVER-VARS NODE) *NEED-STORAGE*)) (CLOSURE-ANNOTATE (CATCH-TAG NODE) IN-LOOP-P)) (T (UNION (CLOSURE-ANNOTATE (CATCH-STMT NODE) IN-LOOP-P) (CLOSURE-ANNOTATE (CATCH-TAG NODE) IN-LOOP-P))))) (DEFUN CLOSURE-ANNOTATE-GO (NODE IN-LOOP-P) NIL) (DEFUN CLOSURE-ANNOTATE-IF (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (IF-PRED NODE) IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (IF-THEN NODE) IN-LOOP-P) (CLOSURE-ANNOTATE (IF-ELSE NODE) IN-LOOP-P)))) (DEFUN CLOSURE-ANNOTATE-LABELS (NODE IN-LOOP-P) (LET (OUTER-NEED-STORAGE NON-LOCALS) (LET (*NEED-STORAGE*) (SETQ NON-LOCALS (DELETE-IF #'(LAMBDA (VAR) (EQ NODE (VARIABLE-BINDER VAR))) (UNION (CLOSURE-ANNOTATE (LABELS-BODY NODE) NIL) (IL:FOR FUN IL:IN (LABELS-FUNS NODE) UNIONING (CLOSURE-ANNOTATE (CDR FUN) NIL))))) (IF (NOT IN-LOOP-P) (SETQ OUTER-NEED-STORAGE *NEED-STORAGE*) (SETF (LABELS-CLOSED-OVER-VARS NODE) *NEED-STORAGE*))) (IL:* IL:|;;| "Now we're outside the scope of the binding of *NEED-STORAGE*") (SETQ *NEED-STORAGE* (UNION *NEED-STORAGE* OUTER-NEED-STORAGE)) NON-LOCALS)) (DEFUN CLOSURE-ANNOTATE-LAMBDA (NODE IN-LOOP-P) (LET* ((NEW-FRAME-P (LAMBDA-NEW-FRAME-P NODE)) OUTER-NEED-STORAGE NON-LOCALS) (LET (*NEED-STORAGE*) (SETQ NON-LOCALS (UNION (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL NODE) UNIONING (CLOSURE-ANNOTATE (SECOND OPT-VAR) NIL)) (UNION (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD NODE) UNIONING (CLOSURE-ANNOTATE (THIRD KEY-VAR) NIL)) (CLOSURE-ANNOTATE (LAMBDA-BODY NODE) NIL)))) (SETQ NON-LOCALS (DELETE-IF #'(LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) NODE)) NON-LOCALS)) (WHEN NEW-FRAME-P (IL:FOR VAR IL:IN NON-LOCALS IL:DO (SETF (VARIABLE-CLOSED-OVER VAR) T)) (SETQ NON-LOCALS NIL)) (SETQ *NEED-STORAGE* (APPEND (IL:FOR VAR IL:IN (LAMBDA-REQUIRED NODE) IL:WHEN (VARIABLE-CLOSED-OVER VAR) IL:COLLECT VAR) (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL NODE) IL:JOIN (NCONC (AND (VARIABLE-CLOSED-OVER (FIRST OPT-VAR)) (LIST (FIRST OPT-VAR))) (AND (THIRD OPT-VAR) (VARIABLE-CLOSED-OVER (THIRD OPT-VAR)) (LIST (THIRD OPT-VAR))))) (AND (LAMBDA-REST NODE) (VARIABLE-CLOSED-OVER (LAMBDA-REST NODE)) (LIST (LAMBDA-REST NODE))) (IL:FOR OPT-VAR IL:IN (LAMBDA-KEYWORD NODE) IL:JOIN (NCONC (AND (VARIABLE-CLOSED-OVER (SECOND OPT-VAR)) (LIST (SECOND OPT-VAR))) (AND (FOURTH OPT-VAR) (VARIABLE-CLOSED-OVER (FOURTH OPT-VAR)) (LIST (FOURTH OPT-VAR))))) *NEED-STORAGE*)) (IF (OR NEW-FRAME-P IN-LOOP-P) (SETF (LAMBDA-CLOSED-OVER-VARS NODE) *NEED-STORAGE*) (SETQ OUTER-NEED-STORAGE *NEED-STORAGE*))) (SETQ *NEED-STORAGE* (UNION OUTER-NEED-STORAGE *NEED-STORAGE*)) NON-LOCALS)) (DEFUN CLOSURE-ANNOTATE-LITERAL (NODE IN-LOOP-P) NIL) (DEFUN CLOSURE-ANNOTATE-MV-CALL (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (MV-CALL-FN NODE) IN-LOOP-P) (IL:FOR ARG IL:IN (MV-CALL-ARG-EXPRS NODE) UNIONING (CLOSURE-ANNOTATE ARG IN-LOOP-P)))) (DEFUN CLOSURE-ANNOTATE-MV-PROG1 (NODE IN-LOOP-P) (IL:FOR STMT IL:IN (MV-PROG1-STMTS NODE) UNIONING (CLOSURE-ANNOTATE STMT IN-LOOP-P))) (DEFUN CLOSURE-ANNOTATE-OPCODES (NODE IN-LOOP-P) NIL) (DEFUN CLOSURE-ANNOTATE-PROGN (NODE IN-LOOP-P) (IL:FOR STMT IL:IN (PROGN-STMTS NODE) UNIONING (CLOSURE-ANNOTATE STMT IN-LOOP-P))) (DEFUN CLOSURE-ANNOTATE-PROGV (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (PROGV-SYMS-EXPR NODE) IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (PROGV-VALS-EXPR NODE) IN-LOOP-P) (CLOSURE-ANNOTATE (PROGV-STMT NODE) IN-LOOP-P)))) (DEFUN CLOSURE-ANNOTATE-RETURN (NODE IN-LOOP-P) (CLOSURE-ANNOTATE (RETURN-VALUE NODE) IN-LOOP-P)) (DEFUN CLOSURE-ANNOTATE-SETQ (NODE IN-LOOP-P) (ADJOIN (SETQ-VAR NODE) (CLOSURE-ANNOTATE (SETQ-VALUE NODE) IN-LOOP-P))) (DEFUN CLOSURE-ANNOTATE-TAGBODY (NODE IN-LOOP-P) (LET (OUTER-NEED-STORAGE NON-LOCALS) (LET* (*NEED-STORAGE* (SEGMENTS (TAGBODY-SEGMENTS NODE)) (COULD-BE-A-LOOP (OR IN-LOOP-P (NOT (NULL (SEGMENT-TAGS (CAR SEGMENTS)))) (NOT (NULL (CDR SEGMENTS)))))) (SETQ NON-LOCALS (IL:FOR SEGMENT IL:IN SEGMENTS UNIONING (IL:FOR STMT IL:IN (SEGMENT-STMTS SEGMENT) UNIONING (CLOSURE-ANNOTATE STMT COULD-BE-A-LOOP )))) (WHEN (TAGBODY-NEW-FRAME-P NODE) (IL:FOR VAR IL:IN NON-LOCALS IL:DO (SETF (VARIABLE-CLOSED-OVER VAR) T)) (SETQ NON-LOCALS NIL)) (COND ((TAGBODY-CLOSED-OVER-P NODE) (SETF (TAGBODY-BLIP-VAR NODE) (MAKE-VARIABLE :SCOPE :LEXICAL :KIND :VARIABLE :NAME "Control blip" :BINDER NODE :CLOSED-OVER T)) (IF (OR (TAGBODY-NEW-FRAME-P NODE) IN-LOOP-P) (SETF (TAGBODY-CLOSED-OVER-VARS NODE) (CONS (TAGBODY-BLIP-VAR NODE) *NEED-STORAGE*)) (SETQ OUTER-NEED-STORAGE (CONS (TAGBODY-BLIP-VAR NODE) *NEED-STORAGE*)))) (T (IF (TAGBODY-NEW-FRAME-P NODE) (SETF (TAGBODY-CLOSED-OVER-VARS NODE) *NEED-STORAGE*) (SETQ OUTER-NEED-STORAGE *NEED-STORAGE*))))) (SETQ *NEED-STORAGE* (UNION OUTER-NEED-STORAGE *NEED-STORAGE*)) NON-LOCALS)) (DEFUN CLOSURE-ANNOTATE-THROW (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (THROW-TAG NODE) IN-LOOP-P) (CLOSURE-ANNOTATE (THROW-VALUE NODE) IN-LOOP-P))) (DEFUN CLOSURE-ANNOTATE-UNWIND-PROTECT (NODE IN-LOOP-P) (UNION (CLOSURE-ANNOTATE (UNWIND-PROTECT-STMT NODE) IN-LOOP-P) (CLOSURE-ANNOTATE (UNWIND-PROTECT-CLEANUP NODE) IN-LOOP-P))) (DEFUN CLOSURE-ANNOTATE-VAR-REF (NODE IN-LOOP-P) (LET ((VAR (VAR-REF-VARIABLE NODE))) (IF (EQ (VARIABLE-SCOPE VAR) :LEXICAL) (LIST VAR)))) (IL:* IL:|;;| "Testing annotation ") (DEFUN TEST-ANNOTATION (FN) (LET ((TREE (TEST-ALPHA-2 FN))) (UNWIND-PROTECT (PRINT-TREE (ANNOTATE-TREE (META-EVALUATE TREE))) (RELEASE-TREE TREE)))) (IL:* IL:|;;| "Arrange to use the proper compiler.") (IL:PUTPROPS IL:XCLC-ANNOTATE IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange for the proper makefile-environment") (IL:PUTPROPS IL:XCLC-ANNOTATE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-ANNOTATE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-DATABASE b/sources/XCLC-DATABASE new file mode 100644 index 00000000..ac5a890f --- /dev/null +++ b/sources/XCLC-DATABASE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "19-Jan-93 11:27:11" IL:|{DSK}lde>lispcore>sources>XCLC-DATABASE.;2| 45494 IL:|previous| IL:|date:| "23-May-90 12:57:24" IL:|{DSK}lde>lispcore>sources>XCLC-DATABASE.;1|) ; Copyright (c) 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-DATABASECOMS) (IL:RPAQQ IL:XCLC-DATABASECOMS ( (IL:* IL:|;;;| "The XCL Compiler's database of information about the properties of functions and other constructs.") (IL:DEFINE-TYPES COMPILER-DATA) (IL:* IL:|;;| "Side Effects (The first keyword is the effects of the function itself and the second is those effects that can affect the running of the function.)") (IL:FUNCTIONS DECLARE-SIDE-EFFECTS SIDE-EFFECTS) (IL:SETFS SIDE-EFFECTS) (IL:PROP IL:PROPTYPE SIDE-EFFECTS-DATA) (COMPILER-DATA ( "Side-effects data for CLtL, Chapter 4: Type Specifiers" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 4: Type Specifiers" :NONE :NONE) ("Side-effects data for CLtL, Chapter 6: Predicates" :NONE :NONE) ( "Side-effects data for CLtL, Chapter 7: Control Structure" (:CONS) :ANY) ( "Side-effects data for CLtL, Chapter 7: Control Structure" :ANY :NONE) ( "Side-effects data for CLtL, Chapter 7: Control Structure" :NONE :ANY) ( "Side-effects data for CLtL, Chapter 7: Control Structure" :ANY :ANY) ("Side-effects data for CLtL, Chapter 8: Macros" :ANY :ANY ) ("Side-effects data for CLtL, Chapter 8: Macros" :NONE :ANY) ("Side-effects data for CLtL, Chapter 9: Declarations" :ANY :ANY) ("Side-effects data for CLtL, Chapter 10: Symbols" :NONE :ANY) ("Side-effects data for CLtL, Chapter 10: Symbols" :ANY :ANY) ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS CL::*GENSYM-PREFIX* CL::*GENSYM-COUNTER*) (CL::*GENSYM-PREFIX* CL::*GENSYM-COUNTER*)) ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 10: Symbols" (:CONS) :ANY) ("Side-effects data for CLtL, Chapter 10: Symbols" :NONE :NONE) ("Side-effects data for CLtL, Chapter 11: Packages" :NONE :ANY) ("Side-effects data for CLtL, Chapter 11: Packages" :ANY :ANY) ("Side-effects data for CLtL, Chapter 12: Numbers" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 12: Numbers" :ANY :ANY) ("Side-effects data for CLtL, Chapter 12: Numbers" :NONE :NONE) ("Side-effects data for CLtL, Chapter 13: Characters" :NONE :NONE) ("Side-effects data for CLtL, Chapter 14: Sequences" :ANY :ANY) ("Side-effects data for CLtL, Chapter 14: Sequences" :NONE :ANY) ("Side-effects data for CLtL, Chapter 14: Sequences" (:CONS) :ANY) ("Side-effects data for CLtL, Chapter 15: Lists" :NONE :NONE) ("Side-effects data for CLtL, Chapter 15: Lists" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 15: Lists" :ANY :ANY ) ("Side-effects data for CLtL, Chapter 15: Lists" :ANY :NONE) ("Side-effects data for CLtL, Chapter 16: Hash Tables" :ANY :NONE) ("Side-effects data for CLtL, Chapter 16: Hash Tables" :ANY :ANY) ("Side-effects data for CLtL, Chapter 16: Hash Tables" :NONE :ANY) ("Side-effects data for CLtL, Chapter 16: Hash Tables" :NONE :NONE) ("Side-effects data for CLtL, Chapter 16: Hash Tables" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 17: Arrays" :NONE :NONE) ("Side-effects data for CLtL, Chapter 17: Arrays" :NONE :ANY) ("Side-effects data for CLtL, Chapter 17: Arrays" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 17: Arrays" :ANY :ANY) ("Side-effects data for CLtL, Chapter 18: Strings" :ANY :ANY) ("Side-effects data for CLtL, Chapter 18: Strings" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 18: Strings" (:CONS) :ANY) ("Side-effects data for CLtL, Chapter 18: Strings" :NONE :NONE) ("Side-effects data for CLtL, Chapter 18: Strings" :NONE :ANY) ("Side-effects data for CLtL, Chapter 20: The Evaluator" :NONE :ANY) ("Side-effects data for CLtL, Chapter 20: The Evaluator" :ANY :ANY) ("Side-effects data for CLtL, Chapter 21: Streams" (:CONS) :ANY) ("Side-effects data for CLtL, Chapter 21: Streams" (:CONS) :NONE) ("Side-effects data for CLtL, Chapter 21: Streams" :ANY :NONE) ("Side-effects data for CLtL, Chapter 21: Streams" :NONE :NONE) ("Side-effects data for CLtL, Chapter 21: Streams" :ANY :ANY) ("Side-effects data for CLtL, Chapter 22: Input/Output" :NONE :NONE) ("Side-effects data for CLtL, Chapter 22: Input/Output" :ANY :ANY) ("Side-effects data for CLtL, Chapter 22: Input/Output" :NONE :ANY) ("Side-effects data for CLtL, Chapter 22: Input/Output" (:CONS) :ANY) ( "Side-effects data for CLtL, Chapter 23: File System Interface" :NONE :ANY) ( "Side-effects data for CLtL, Chapter 23: File System Interface" (:CONS) :ANY) ( "Side-effects data for CLtL, Chapter 23: File System Interface" :ANY :ANY) ( "Side-effects data for CLtL, Chapter 23: File System Interface" :NONE :NONE) ("Side-effects data for CLtL, Chapter 24: Errors" :ANY :ANY) ( "Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :NONE :ANY) ( "Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :ANY :ANY) ( "Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :ANY :NONE) ( "Side-effects data for CLtL, Chapter 25: Miscellaneous Features" :NONE :NONE) ("Side-effects data for IRM, Chapter 2: Litatoms" :ANY :NONE) ("Side-effects data for IRM, Chapter 2: Litatoms" :NONE :ANY) ("Side-effects data for IRM, Chapter 2: Litatoms" :NONE :NONE) ("Side-effects data for IRM, Chapter 2: Litatoms" :ANY :ANY) ("Side-effects data for IRM, Chapter 2: Litatoms" (:CONS) :ANY) ("Side-effects data for IRM, Chapter 3: Lists" :NONE :NONE ) ("Side-effects data for IRM, Chapter 3: Lists" :ANY :ANY) ("Side-effects data for IRM, Chapter 3: Lists" :ANY :NONE) ("Side-effects data for IRM, Chapter 3: Lists" (:CONS) :NONE) ("Side-effects data for IRM, Chapter 3: Lists" (:CONS) :ANY) ("Side-effects data for IRM, Chapter 3: Lists" :NONE :ANY) ("Side-effects data for IRM, Chapter 4: Strings" (:CONS) :ANY) ("Side-effects data for IRM, Chapter 4: Strings" :NONE :ANY) ("Side-effects data for IRM, Chapter 4: Strings" :NONE :NONE) ("Side-effects data for IRM, Chapter 4: Strings" :ANY :ANY ) ("Side-effects data for IRM, Chapter 5: Arrays" :ANY :NONE ) ("Side-effects data for IRM, Chapter 5: Arrays" :NONE :ANY ) ("Side-effects data for IRM, Chapter 5: Arrays" :NONE :NONE) ("Side-effects data for IRM, Chapter 5: Arrays" (:CONS) :ANY) ("Side-effects data for IRM, Chapter 6: Hash Arrays" :ANY :ANY) ("Side-effects data for IRM, Chapter 6: Hash Arrays" :NONE :NONE) ("Side-effects data for IRM, Chapter 6: Hash Arrays" (:CONS) :NONE) ("Side-effects data for IRM, Chapter 6: Hash Arrays" (:CONS) :ANY) ("Side-effects data for IRM, Chapter 6: Hash Arrays" :NONE :ANY) ("Side-effects data for IRM, Chapter 6: Hash Arrays" :ANY :NONE) ( "Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :ANY) ( "Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :NONE :NONE) ( "Side-effects data for IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :NONE) ("Side-effects data for IRM, Chapter 8: Record Package" :NONE :ANY) ("Side-effects data for IRM, Chapter 8: Record Package" :ANY :ANY) ( "Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :NONE) ( "Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :ANY) ( "Side-effects data for IRM, Chapter 9: Conditionals and Iterative Statements" :ANY :ANY) ( "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY :NONE) ( "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE :ANY) ( "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY :ANY) ( "Side-effects data for IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE :NONE) ( "Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :ANY) ( "Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :NONE) ( "Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :ANY) ( "Side-effects data for IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :NONE) ("Side-effects data for IRM, Chapter 12: Miscellaneous" :NONE :NONE) ("Side-effects data for IRM, Chapter 12: Miscellaneous" :ANY :ANY) ("Side-effects data for IRM, Chapter 12: Miscellaneous" :NONE :ANY) ("Side-effects data for Pointer reads" :NONE :NONE) ("Side-effects data for Internal functions in CMLARITH" :NONE :NONE)) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-DATABASE) (IL:* IL:|;;| "Set up the correct package environment.") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-DATABASE))) (IL:* IL:|;;;| "The XCL Compiler's database of information about the properties of functions and other constructs.") (DEF-DEFINE-TYPE COMPILER-DATA "XCL Compiler information") (IL:* IL:|;;| "Side Effects (The first keyword is the effects of the function itself and the second is those effects that can affect the running of the function.)" ) (DEFDEFINER (DECLARE-SIDE-EFFECTS (:NAME (LAMBDA (WHOLE) (LIST (FORMAT NIL "Side-effects data for ~A" (SECOND WHOLE)) (THIRD WHOLE) (FOURTH WHOLE))))) COMPILER-DATA (TITLE EFFECTS AFFECTED &REST FUNCTIONS ) (COND ((AND (OR (EQ EFFECTS :NONE) (EQ EFFECTS :ANY) (LISTP EFFECTS)) (OR (EQ AFFECTED :NONE) (EQ AFFECTED :ANY) (LISTP AFFECTED))) `(LET ((DATA ',(CONS EFFECTS AFFECTED))) ,@(MAPCAR #'(LAMBDA (F) `(SETF (SIDE-EFFECTS ',F) DATA)) FUNCTIONS))) (T (CERROR "Ignore the declaration" "Malformed side-effects descriptor in DECLARE-SIDE-EFFECTS: ~S" (CONS EFFECTS AFFECTED)) NIL))) (DEFUN SIDE-EFFECTS (NAME) (GET NAME 'SIDE-EFFECTS-DATA)) (DEFSETF SIDE-EFFECTS (NAME) (DATA) `(IL:PUTPROP ,NAME 'SIDE-EFFECTS-DATA ,DATA)) (IL:PUTPROPS SIDE-EFFECTS-DATA IL:PROPTYPE IGNORE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 4: Type Specifiers" (:CONS) :NONE COERCE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 4: Type Specifiers" :NONE :NONE TYPE-OF) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 6: Predicates" :NONE :NONE TYPEP SUBTYPEP NULL SYMBOLP ATOM CONSP LISTP NUMBERP INTEGERP RATIONALP FLOATP COMPLEXP CHARACTERP STRINGP BIT-VECTOR-P VECTORP SIMPLE-VECTOR-P SIMPLE-STRING-P SIMPLE-BIT-VECTOR-P ARRAYP PACKAGEP FUNCTIONP COMPILED-FUNCTION-P COMMONP EQ EQL EQUAL EQUALP NOT) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" (:CONS) :ANY GET-SETF-METHOD GET-SETF-METHOD-MULTIPLE-VALUE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :ANY :NONE SET MAKUNBOUND FMAKUNBOUND) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :NONE :ANY SYMBOL-VALUE SYMBOL-FUNCTION BOUNDP FBOUNDP SPECIAL-FORM-P VALUES VALUES-LIST) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 7: Control Structure" :ANY :ANY APPLY FUNCALL MAPCAR MAPLIST MAPC MAPL MAPCAN MAPCON) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 8: Macros" :ANY :ANY MACROEXPAND MACROEXPAND-1) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 8: Macros" :NONE :ANY MACRO-FUNCTION) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 9: Declarations" :ANY :ANY PROCLAIM) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :NONE :ANY SYMBOL-PLIST GETF GET GET-PROPERTIES SYMBOL-NAME SYMBOL-PACKAGE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :ANY :ANY REMF REMPROP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS CL::*GENSYM-PREFIX* CL::*GENSYM-COUNTER* ) (CL::*GENSYM-PREFIX* CL::*GENSYM-COUNTER*) GENSYM) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS) :NONE MAKE-SYMBOL GENTEMP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" (:CONS) :ANY COPY-SYMBOL) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 10: Symbols" :NONE :NONE KEYWORDP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 11: Packages" :NONE :ANY PACKAGE-NAME PACKAGE-NICKNAMES PACKAGE-USE-LIST PACKAGE-USED-BY-LIST PACKAGE-SHADOWING-SYMBOLS LIST-ALL-PACKAGES FIND-SYMBOL FIND-ALL-SYMBOLS FIND-PACKAGE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 11: Packages" :ANY :ANY MAKE-PACKAGE IN-PACKAGE RENAME-PACKAGE INTERN UNINTERN EXPORT UNEXPORT IMPORT SHADOWING-IMPORT SHADOW USE-PACKAGE UNUSE-PACKAGE PROVIDE REQUIRE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" (:CONS) :NONE MAKE-RANDOM-STATE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" :ANY :ANY RANDOM) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 12: Numbers" :NONE :NONE ZEROP PLUSP MINUSP ODDP EVENP = /= < > <= >= MIN MAX + - * / 1+ 1- CONJUGATE GCD LCM EXP EXPT LOG SQRT ISQRT ABS PHASE SIGNUM SIN COS TAN CIS ASIN ACOS ATAN SINH COSH TANH ASINH ACOSH ATANH FLOAT RATIONAL RATIONALIZE NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND MOD REM FFLOOR FCEILING FTRUNCATE FROUND DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT COMPLEX REALPART IMAGPART LOGIOR LOGXOR LOGAND LOGEQV LOGNAND LOGNOR LOGANDC1 LOGANDC2 LOGORC1 LOGORC2 BOOLE LOGNOT LOGTEST LOGBITP ASH LOGCOUNT INTEGER-LENGTH BYTE BYTE-SIZE BYTE-POSITION LDB LDB-TEST MASK-FIELD DPB DEPOSIT-FIELD RANDOM-STATE-P) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 13: Characters" :NONE :NONE STANDARD-CHAR-P GRAPHIC-CHAR-P STRING-CHAR-P ALPHA-CHAR-P UPPER-CASE-P LOWER-CASE-P BOTH-CASE-P DIGIT-CHAR-P ALPHANUMERICP CHAR= CHAR/= CHAR< CHAR> CHAR<= CHAR>= CHAR-EQUAL CHAR-NOT-EQUAL CHAR-LESSP CHAR-GREATERP CHAR-NOT-LESSP CHAR-NOT-GREATERP CHAR-CODE CHAR-BITS CHAR-FONT CODE-CHAR MAKE-CHAR CHARACTER CHAR-UPCASE CHAR-DOWNCASE DIGIT-CHAR CHAR-INT INT-CHAR CHAR-NAME NAME-CHAR CHAR-BIT SET-CHAR-BIT) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" :ANY :ANY NREVERSE MAP SOME EVERY NOTANY NOTEVERY REDUCE FILL REPLACE REMOVE REMOVE-IF REMOVE-IF-NOT DELETE DELETE-IF DELETE-IF-NOT REMOVE-DUPLICATES DELETE-DUPLICATES SUBSTITUTE SUBSTITUTE-IF SUBSTITUTE-IF-NOT NSUBSTITUTE NSUBSTITUTE-IF NSUBSTITUTE-IF-NOT FIND FIND-IF FIND-IF-NOT POSITION POSITION-IF POSITION-IF-NOT COUNT COUNT-IF COUNT-IF-NOT MISMATCH SEARCH SORT STABLE-SORT MERGE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" :NONE :ANY ELT LENGTH) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 14: Sequences" (:CONS) :ANY SUBSEQ COPY-SEQ REVERSE MAKE-SEQUENCE CONCATENATE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :NONE :NONE CAR CDR CAAR CADR CDAR CDDR CAAAR CAADR CADAR CADDR CDAAR CDADR CDDAR CDDDR CAAAAR CAAADR CAADAR CAADDR CADAAR CADADR CADDAR CADDDR CDAAAR CDAADR CDADAR CDADDR CDDAAR CDDADR CDDDAR CDDDDR ENDP LIST-LENGTH NTH FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST NTHCDR LAST TAILP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" (:CONS) :NONE CONS LIST LIST* MAKE-LIST APPEND COPY-LIST COPY-ALIST COPY-TREE REVAPPEND BUTLAST LDIFF ACONS PAIRLIS) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :ANY :ANY TREE-EQUAL SUBST SUBST-IF SUBST-IF-NOT NSUBST NSUBST-IF NSUBST-IF-NOT SUBLIS NSUBLIS MEMBER MEMBER-IF MEMBER-IF-NOT ADJOIN UNION NUNION INTERSECTION NINTERSECTION SET-DIFFERENCE NSET-DIFFERENCE SET-EXCLUSIVE-OR NSET-EXCLUSIVE-OR SUBSETP ASSOC ASSOC-IF ASSOC-IF-NOT RASSOC RASSOC-IF RASSOC-IF-NOT) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 15: Lists" :ANY :NONE NCONC NRECONC NBUTLAST RPLACA RPLACD) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :ANY :NONE CLRHASH) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :ANY :ANY REMHASH MAPHASH) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :NONE :ANY GETHASH HASH-TABLE-COUNT) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" :NONE :NONE HASH-TABLE-P SXHASH) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 16: Hash Tables" (:CONS) :NONE MAKE-HASH-TABLE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :NONE :NONE ARRAY-ELEMENT-TYPE ARRAY-RANK ADJUSTABLE-ARRAY-P ARRAY-HAS-FILL-POINTER-P) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :NONE :ANY AREF SVREF ARRAY-DIMENSIONS ARRAY-TOTAL-SIZE ARRAY-IN-BOUNDS-P ARRAY-ROW-MAJOR-INDEX BIT SBIT FILL-POINTER) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" (:CONS) :NONE MAKE-ARRAY VECTOR) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 17: Arrays" :ANY :ANY BIT-AND BIT-IOR BIT-XOR BIT-EQV BIT-NAND BIT-NOR BIT-ANDC1 BIT-ANDC2 BIT-ORC1 BIT-ORC2 BIT-NOT VECTOR-PUSH VECTOR-PUSH-EXTEND VECTOR-POP ADJUST-ARRAY) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :ANY :ANY NSTRING-UPCASE NSTRING-DOWNCASE NSTRING-CAPITALIZE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" (:CONS) :NONE MAKE-STRING STRING) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" (:CONS) :ANY STRING-TRIM STRING-LEFT-TRIM STRING-RIGHT-TRIM STRING-UPCASE STRING-DOWNCASE STRING-CAPITALIZE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :NONE :NONE STRING= STRING/= STRING< STRING> STRING<= STRING>= STRING-EQUAL STRING-NOT-EQUAL STRING-LESSP STRING-NOT-LESSP STRING-GREATERP STRING-NOT-GREATERP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 18: Strings" :NONE :ANY CHAR SCHAR) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 20: The Evaluator" :NONE :ANY CONSTANTP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 20: The Evaluator" :ANY :ANY EVAL EVALHOOK APPLYHOOK) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" (:CONS) :ANY MAKE-BROADCAST-STREAM MAKE-CONCATENATED-STREAM MAKE-TWO-WAY-STREAM MAKE-ECHO-STREAM MAKE-STRING-INPUT-STREAM) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" (:CONS) :NONE MAKE-SYNONYM-STREAM MAKE-STRING-OUTPUT-STREAM) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :ANY :NONE CLOSE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :NONE :NONE STREAMP INPUT-STREAM-P OUTPUT-STREAM-P STREAM-ELEMENT-TYPE) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 21: Streams" :ANY :ANY GET-OUTPUT-STREAM-STRING) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :NONE :NONE READTABLEP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :ANY :ANY COPY-READTABLE SET-SYNTAX-FROM-CHAR SET-MACRO-CHARACTER MAKE-DISPATCH-MACRO-CHARACTER SET-DISPATCH-MACRO-CHARACTER READ READ-PRESERVING-WHITESPACE READ-DELIMITED-LIST READ-LINE READ-CHAR UNREAD-CHAR PEEK-CHAR READ-CHAR-NO-HANG CLEAR-INPUT READ-FROM-STRING READ-BYTE WRITE PRIN1 PRINT PPRINT PRINC WRITE-CHAR WRITE-STRING WRITE-LINE TERPRI FRESH-LINE FINISH-OUTPUT FORCE-OUTPUT CLEAR-OUTPUT WRITE-BYTE FORMAT Y-OR-N-P YES-OR-NO-P) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" :NONE :ANY GET-MACRO-CHARACTER GET-DISPATCH-MACRO-CHARACTER LISTEN PARSE-INTEGER) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 22: Input/Output" (:CONS) :ANY WRITE-TO-STRING PRIN1-TO-STRING PRINC-TO-STRING) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :NONE :ANY TRUENAME PARSE-NAMESTRING PROBE-FILE FILE-WRITE-DATE FILE-AUTHOR FILE-LENGTH DIRECTORY) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" (:CONS) :ANY PATHNAME MERGE-PATHNAMES MAKE-PATHNAME PATHNAME-HOST PATHNAME-DEVICE PATHNAME-DIRECTORY PATHNAME-NAME PATHNAME-TYPE PATHNAME-VERSION NAMESTRING FILE-NAMESTRING DIRECTORY-NAMESTRING HOST-NAMESTRING ENOUGH-NAMESTRING USER-HOMEDIR-PATHNAME OPEN) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :ANY :ANY RENAME-FILE DELETE-FILE FILE-POSITION LOAD) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 23: File System Interface" :NONE :NONE PATHNAMEP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 24: Errors" :ANY :ANY ERROR CERROR WARN BREAK) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :NONE :ANY DOCUMENTATION APROPOS-LIST GET-DECODED-TIME GET-UNIVERSAL-TIME GET-INTERNAL-RUN-TIME GET-INTERNAL-REAL-TIME LISP-IMPLEMENTATION-TYPE LISP-IMPLEMENTATION-VERSION MACHINE-TYPE MACHINE-VERSION MACHINE-INSTANCE SOFTWARE-TYPE SOFTWARE-VERSION SHORT-SITE-NAME LONG-SITE-NAME) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :ANY :ANY COMPILE COMPILE-FILE DISASSEMBLE DESCRIBE INSPECT ROOM ED DRIBBLE APROPOS) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :ANY :NONE SLEEP) (DECLARE-SIDE-EFFECTS "CLtL, Chapter 25: Miscellaneous Features" :NONE :NONE DECODE-UNIVERSAL-TIME ENCODE-UNIVERSAL-TIME IDENTITY) (DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :ANY :NONE IL:SETTOPVAL IL:SETATOMVAL IL:PUTPROP IL:DEFLIST IL:SETPROPLIST) (DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :NONE :ANY IL:GETTOPVAL IL:GETATOMVAL IL:GETPROP IL:PROPNAMES IL:GETPROPLIST IL:GETLIS IL:NCHARS IL:NTHCHAR IL:U-CASEP IL:NTHCHARCODE IL:CHCON1) (DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :NONE :NONE IL:LITATOM IL:ATOM IL:CHARACTER IL:FCHARACTER) (DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" :ANY :ANY REMPROP IL:ADDPROP IL:REMPROPLIST IL:CHANGEPROP IL:MKATOM IL:SUBATOM IL:PACK IL:PACK* IL:DUNPACK IL:L-CASE IL:U-CASE IL:GENSYM IL:MAPATOMS IL:APROPOS IL:PACKC IL:DCHCON) (DECLARE-SIDE-EFFECTS "IRM, Chapter 2: Litatoms" (:CONS) :ANY IL:UNPACK IL:CHCON) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :NONE :NONE IL:LISTP IL:NLISTP) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :ANY :ANY IL:RPLNODE2 IL:FRPLNODE2 IL:ATTACH IL:TCONC IL:LCONC IL:DOCOLLECT IL:ENDCOLLECT IL:LDIFF IL:DSUBST IL:DSUBLIS IL:PUTASSOC IL:LISTPUT IL:LISTPUT1 IL:SORT IL:MERGE IL:MERGEINSERT IL:DREMOVE IL:DREVERSE IL:COMPARELISTS) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :ANY :NONE IL:RPLNODE IL:FRPLACD IL:FRPLACA IL:FRPLNODE IL:NCONC1) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" (:CONS) :NONE IL:MKLIST IL:APPEND) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" (:CONS) :ANY IL:COPY IL:COPYALL IL:HCOPYALL IL:LASTN IL:LDIFFERENCE IL:INTERSECTION IL:UNION IL:SUBST IL:LSUBST IL:SUBLIS IL:SUBPAIR IL:REMOVE IL:REVERSE IL:NEGATE) (DECLARE-SIDE-EFFECTS "IRM, Chapter 3: Lists" :NONE :ANY IL:NTH IL:FNTH IL:FLAST IL:NLEFT IL:LENGTH IL:FLENGTH IL:EQLENGTH IL:COUNT IL:COUNTDOWN IL:EQUALN IL:MEMB IL:FMEMB IL:MEMBER IL:EQMEMB IL:ASSOC IL:FASSOC IL:SASSOC IL:LISTGET IL:LISTGET1 IL:ALPHORDER IL:UALPHORDER) (DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" (:CONS) :ANY IL:ALLOCSTRING IL:MKSTRING IL:CONCAT IL:CONCATLIST) (DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :NONE :ANY IL:STREQUAL IL:NCHARS IL:STRPOS IL:STRPOSL) (DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :NONE :NONE IL:STRINGP) (DECLARE-SIDE-EFFECTS "IRM, Chapter 4: Strings" :ANY :ANY IL:GNC IL:GLC IL:RPLSTRING IL:RPLCHARCODE IL:MAKEBITTABLE IL:SUBSTRING) (DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :ANY :NONE IL:SETA) (DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :NONE :ANY IL:ELT) (DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" :NONE :NONE IL:ARRAYP IL:ARRAYTYP IL:ARRAYSIZE IL:ARRAYORIG) (DECLARE-SIDE-EFFECTS "IRM, Chapter 5: Arrays" (:CONS) :ANY IL:ARRAY IL:COPYARRAY) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :ANY :ANY IL:HARRAYPROP IL:PUTHASH IL:REHASH IL:MAPHASH IL:DMPHASH) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :NONE :NONE IL:HARRAYP IL:HARRAYSIZE) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" (:CONS) :NONE IL:HARRAY) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" (:CONS) :ANY IL:HASHARRAY) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :NONE :ANY IL:GETHASH IL:STRINGHASHBITS) (DECLARE-SIDE-EFFECTS "IRM, Chapter 6: Hash Arrays" :ANY :NONE CLRHASH) (DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :ANY IL:RAND IL:RANDSET) (DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :NONE :NONE IL:SMALLP IL:FIXP IL:FLOATP IL:NUMBERP IL:EQP IL:PLUS IL:MINUS IL:DIFFERENCE IL:TIMES IL:QUOTIENT IL:REMAINDER IL:GREATERP IL:LESSP IL:GEQ IL:LEQ IL:ZEROP MINUSP MIN MAX ABS IL:IPLUS IL:IMINUS IL:IDIFFERENCE IL:ADD1 IL:SUB1 IL:ITIMES IL:IQUOTIENT IL:IREMAINDER IL:IMOD IL:IGREATERP IL:ILESSP IL:IGEQ IL:ILEQ IL:IMIN IL:IMAX IL:IEQP IL:FIX IL:FIXR IL:GCD LOGAND IL:LOGOR LOGXOR IL:LSH IL:RSH IL:LLSH IL:LRSH IL:INTEGERLENGTH IL:POWEROFTWOP EVENP ODDP LOGNOT IL:BITTEST IL:BITCLEAR IL:BITSET IL:MASK.1\'S IL:MASK.0\'S IL:LOADBYTE IL:DEPOSITBYTE IL:ROT BYTE IL:BYTESIZE IL:BYTEPOSITION LDB DPB IL:FPLUS IL:FMINUS IL:FDIFFERENCE IL:FTIMES IL:FQUOTIENT IL:FREMAINDER IL:FGREATERP IL:FLESSP IL:FEQP IL:FMIN IL:FMAX FLOAT IL:EXPT IL:SQRT IL:LOG IL:ANTILOG IL:SIN IL:COS IL:TAN IL:ARCSIN IL:ARCCOS IL:ARCTAN IL:ARCTAN2) (DECLARE-SIDE-EFFECTS "IRM, Chapter 7: Numbers and Arithmetic Functions" :ANY :NONE IL:OVERFLOW) (DECLARE-SIDE-EFFECTS "IRM, Chapter 8: Record Package" :NONE :ANY IL:RECLOOK IL:FIELDLOOK IL:RECORDFIELDNAMES IL:RECORDACCESSFORM IL:DATATYPES IL:USERDATATYPES IL:TYPENAME IL:TYPENAMEP IL:FETCHFIELD IL:GETFIELDSPECS IL:GETDESCRIPTORS) (DECLARE-SIDE-EFFECTS "IRM, Chapter 8: Record Package" :ANY :ANY IL:EDITREC IL:RECORDACCESS IL:DECLAREDATATYPE IL:REPLACEFIELD) (DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :NONE IL:NEQ) (DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :NONE :ANY IL:EQUAL IL:EQUALALL) (DECLARE-SIDE-EFFECTS "IRM, Chapter 9: Conditionals and Iterative Statements" :ANY :ANY IL:I.S.OPR) (DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY :NONE IL:SETARG) (DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE :ANY IL:ARG IL:CCODEP IL:EXPRP IL:FNTYP IL:ARGTYPE IL:NARGS IL:ARGLIST IL:SMARTARGLIST IL:GETD IL:NLAMBDA.ARGS IL:FUNCTION) (DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :ANY :ANY IL:DEFINEQ IL:DEFINE IL:PUTD IL:MOVD IL:MOVD? IL:APPLY IL:APPLY* IL:EVAL IL:EVALA IL:DEFEVAL IL:EVALHOOK IL:RPT IL:MAP IL:MAPC IL:MAPLIST IL:MAPCAR IL:MAPCON IL:MAPCONC IL:MAP2C IL:MAP2CAR IL:SUBSET IL:EVERY IL:SOME IL:NOTANY IL:NOTEVERY IL:MAPRINT IL:EXPANDMACRO) (DECLARE-SIDE-EFFECTS "IRM, Chapter 10: Function Definition, Manipulation, and Evaluation" :NONE :NONE IL:KWOTE IL:NILL TRUE IL:ZERO) (DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :ANY IL:STKNAME IL:STKSCAN IL:FRAMESCAN IL:STKARG IL:STKARGNAME IL:STKARGS IL:VARIABLES IL:EVALV IL:REALFRAMEP) (DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :NONE IL:STKPOS IL:STKNTH IL:SETSTKNAME IL:SETSTKARG IL:SETSTKARGNAME IL:RELSTK IL:REALSTKNTH) (DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :ANY :ANY IL:ENVEVAL IL:ENVAPPLY IL:STKEVAL IL:STKAPPLY IL:RETFROM IL:RETTO IL:RETEVAL IL:RETAPPLY IL:CLEARSTK IL:BACKTRACE IL:BAKTRACE IL:MAPDL IL:SEARCHPDL) (DECLARE-SIDE-EFFECTS "IRM, Chapter 11: Variable Bindings and the Interlisp Stack" :NONE :NONE IL:STKNARGS IL:STACKP IL:RELSTKP) (DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :NONE :NONE IL:DATEFORMAT IL:TIMEREXPIRED?) (DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :ANY :ANY IL:SETTIME IL:SETUPTIMER IL:SETUPTIMER.DATE) (DECLARE-SIDE-EFFECTS "IRM, Chapter 12: Miscellaneous" :NONE :ANY IL:DATE IL:GDATE IL:IDATE IL:CLOCK IL:MACHINETYPE) (DECLARE-SIDE-EFFECTS "Pointer reads" :NONE :NONE IL:\\GETBASEPTR IL:\\GETBASEBYTE IL:\\GETBASE IL:\\GETBASEFIXP IL:\\GETBASESTRING IL:\\VAG2 IL:\\ADDBASE) (DECLARE-SIDE-EFFECTS "Internal functions in CMLARITH" :NONE :NONE CL::%+ CL::%- CL::%* CL::%/ CL::%= CL::%> CL::%< XCL::STRUNCATE XCL::SFLOOR XCL::SCEILING XCL::SROUND CL::%LOGIOR CL::%LLSH8 CL::%LLSH1 CL::%LRSH8 CL::%LRSH1) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PUTPROPS IL:XCLC-DATABASE IL:FILETYPE :COMPILE-FILE) (IL:* IL:|;;| "Set up the correct package environment.") (IL:PUTPROPS IL:XCLC-DATABASE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-DATABASE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1993)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-ENV-CTXT b/sources/XCLC-ENV-CTXT new file mode 100644 index 00000000..58759ee0 --- /dev/null +++ b/sources/XCLC-ENV-CTXT @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "17-Jul-90 10:48:08" IL:|{DSK}sybalsky>XCLC-ENV-CTXT.;1| 23266 IL:|changes| IL:|to:| (IL:STRUCTURES ENV) (IL:VARS IL:XCLC-ENV-CTXTCOMS) (IL:VARIABLES *HOST-ARCHITECTURE* *TARGET-ARCHITECTURE*) IL:|previous| IL:|date:| "23-May-90 13:00:38" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-ENV-CTXT.;2|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-ENV-CTXTCOMS) (IL:RPAQQ IL:XCLC-ENV-CTXTCOMS ( (IL:* IL:|;;;| "Contexts and Environments") (IL:STRUCTURES CONTEXT ENV) (IL:FUNCTIONS LOCAL-CONSTANT-P PRINT-CONTEXT PRINT-ENV) (IL:FUNCTIONS MAKE-CHILD-ENV ENV-BIND-VARIABLE ENV-BIND-FUNCTION ENV-ADD-DECLS ENV-DECL-P ENV-ALLOW-INLINES ENV-DISALLOW-INLINES ENV-INLINE-ALLOWED ENV-INLINE-DISALLOWED ENV-PROCLAIM-SPECIAL ENV-PROCLAIMED-SPECIAL-P ENV-PROCLAIM-GLOBAL ENV-PROCLAIMED-GLOBAL-P ENV-DECLARE-SPECIALS ENV-DECLARE-GLOBALS ENV-DECLARE-A-SPECIAL ENV-DECLARE-A-GLOBAL) (IL:FUNCTIONS FIND-TOP-ENVIRONMENT RESOLVE-VARIABLE-REFERENCE RESOLVE-VARIABLE-BINDING VALUE-FOLDABLE-P CHECK-GLOBAL-CONSTANT CONSTANT-VALUE SET-CONSTANT-VALUE LOCAL-CONSTANT-P) (IL:SETFS CONSTANT-VALUE) (IL:VARIABLES *CONSTANTS-HASH-TABLE*) (IL:VARIABLES *ENVIRONMENT* *CONTEXT* *ARGUMENT-CONTEXT* *EFFECT-CONTEXT* *NULL-CONTEXT* *PREDICATE-CONTEXT*) (IL:* IL:|;;| "External interface to environments") (IL:FUNCTIONS ENV-BOUNDP ENV-FBOUNDP COPY-ENV-WITH-FUNCTION COPY-ENV-WITH-VARIABLE MAKE-EMPTY-ENV) (IL:* IL:|;;|  "Describe the machine we're running on and the target for hte compiled code") (IL:VARIABLES *HOST-ARCHITECTURE* *TARGET-ARCHITECTURE*) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-ENV-CTXT) (IL:* IL:|;;| "Arrange for the correct reader environment.") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-ENV-CTXT))) (IL:* IL:|;;;| "Contexts and Environments") (DEFSTRUCT (CONTEXT (:PRINT-FUNCTION PRINT-CONTEXT) (:INLINE T)) (IL:* IL:|;;;| "TOP-LEVEL-P is non-nil iff we are analyzing a top-level form.") (IL:* IL:|;;;| "VALUES-USED is either :unknown or the non-negative number of values expected for the result of the current form.") (IL:* IL:|;;;| "PREDICATE-P is non-nil iff the value of the current form will only be used in a nil/non-nil test.") (IL:* IL:|;;;| "APPLIED-CONTEXT is either nil or the context in which the result of applying the current form as a function would be used. If NIL, then assume the *null-context*.") (TOP-LEVEL-P NIL) (VALUES-USED :UNKNOWN) (PREDICATE-P NIL) (APPLIED-CONTEXT NIL)) (DEFSTRUCT (ENV (:PRINT-FUNCTION PRINT-ENV) (:INLINE T)) (IL:* IL:|;;;| "Structure for maintaining the compiler's idea of the environment of a given form.") (IL:* IL:|;;;| "PARENT is either NIL, meaning that this environment is at the top, or another ENV structure.") (IL:* IL:|;;;| "VENV is an AList associating the symbol that is the name of the variable with a list of two elements, the SCOPE of the variable (one of :CONSTANT or :LEXICAL) and the VARIABLE or LITERAL structure corresponding to the variable.") (IL:* IL:|;;;| "FENV is an AList associating the symbol that is the name of the function with a list of two elements: the KIND of the symbol (either :MACRO or :FUNCTION) and either an expansion function (iff KIND = :MACRO) or a VARIABLE structure (iff KIND = :FUNCTION). When KIND = :FUNCTION, the VARIABLE structure may be omitted.") (IL:* IL:|;;;| "The information about INLINE and NOTINLINE declarations is maintained by two lists, ALLOWED-INLINES and DISALLOWED-INLINES. If a symbol is on DISALLOWED-INLINES, the compiler will not expand calls to it inline; nor will any optimizers on that symbol be applied. If a symbol is on ALLOWED-INLINES, the compiler will try harder to expand calls to the symbol inline. A given symbol should not appear on both lists.") (IL:* IL:|;;;| "DECL-SPECIFIERS is a list of non-standard declaration-specifiers to be allowed in the compilation. Such specifiers are created by (declare (declaration foo)) forms.") (IL:* IL:|;;;| "DECLARED-SPECIALS is a list of those symbols that were DECLAREd SPECIAL at this contour. In the top-most environment, the list is used for PROCLAIMed variables.") (IL:* IL:|;;;| "DECLARED-GLOBALS is just like DECLARED-SPECIALS but for globals.") (IL:* IL:|;;| "TARGET-ARCHITECTURE is a list analogous to *FEATURES* that describes the architecture of the target machine we're compiling to. This is intended initially to support multiple instruction sets (for the 3-byte-symbol change).") (PARENT NIL) (VENV NIL) (FENV NIL) (ALLOWED-INLINES NIL) (DISALLOWED-INLINES NIL) (DECL-SPECIFIERS NIL) (DECLARED-SPECIALS NIL) (DECLARED-GLOBALS NIL) (TARGET-ARCHITECTURE *TARGET-ARCHITECTURE*)) (DEFUN LOCAL-CONSTANT-P (SYMBOL) (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*)) (DEFUN PRINT-CONTEXT (STRUCT STREAM DEPTH) (IL:* IL:|;;;| "Print almost all contexts in a more readable form, interpreting the various combinations of the fields.") (DECLARE (IGNORE DEPTH)) (LET ((TL (CONTEXT-TOP-LEVEL-P STRUCT)) (VALS (CONTEXT-VALUES-USED STRUCT)) (PRED (CONTEXT-PREDICATE-P STRUCT)) (APP (CONTEXT-APPLIED-CONTEXT STRUCT))) (MACROLET ((OUTPUT (STRING &REST ARGS) `(FORMAT STREAM ,(CONCATENATE 'STRING "~:[" STRING "~;#~]") *PRINT-ESCAPE* ,@ARGS))) (LET ((VALUE (COND ((AND (EQ TL NIL) (EQ VALS :UNKNOWN) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Null")) ((AND (EQ TL T) (EQ VALS 0) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Top-level form")) ((AND (EQ TL NIL) (EQ VALS 0) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Effect")) ((AND (EQ TL NIL) (EQ VALS 1) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "Argument")) ((AND (EQ TL NIL) (EQ VALS 1) (EQ PRED T) (EQ APP NIL)) (OUTPUT "Predicate")) ((AND (EQ TL NIL) (EQ PRED NIL) (EQ APP NIL)) (OUTPUT "~S values" VALS)) (T (FORMAT STREAM "#" TL VALS PRED APP))))))))) (DEFUN PRINT-ENV (STRUCT STREAM DEPTH) (DECLARE (IGNORE DEPTH)) (FORMAT STREAM "#" (IL:\\HILOC STRUCT) (IL:\\LOLOC STRUCT))) (DEFUN MAKE-CHILD-ENV (PARENT) (MAKE-ENV :PARENT PARENT)) (DEFUN ENV-BIND-VARIABLE (ENV NAME STRUCT) (PUSH (CONS NAME STRUCT) (ENV-VENV ENV))) (DEFUN ENV-BIND-FUNCTION (ENV NAME KIND &OPTIONAL EXPN-OR-VAR) (PUSH (LIST NAME KIND EXPN-OR-VAR) (ENV-FENV ENV))) (DEFUN ENV-ADD-DECLS (ENV SPECIFIERS) (SETF (ENV-DECL-SPECIFIERS ENV) (APPEND SPECIFIERS (ENV-DECL-SPECIFIERS ENV)))) (DEFUN ENV-DECL-P (ENV SPECIFIER) (OR (MEMBER SPECIFIER (ENV-DECL-SPECIFIERS ENV)) (LET ((PARENT (ENV-PARENT ENV))) (AND (ENV-P PARENT) (ENV-DECL-P PARENT SPECIFIER))))) (DEFUN ENV-ALLOW-INLINES (ENV NAMES) (SETF (ENV-DISALLOWED-INLINES ENV) (SET-DIFFERENCE (ENV-DISALLOWED-INLINES ENV) NAMES)) (SETF (ENV-ALLOWED-INLINES ENV) (UNION (ENV-ALLOWED-INLINES ENV) NAMES))) (DEFUN ENV-DISALLOW-INLINES (ENV NAMES) (SETF (ENV-ALLOWED-INLINES ENV) (SET-DIFFERENCE (ENV-ALLOWED-INLINES ENV) NAMES)) (SETF (ENV-DISALLOWED-INLINES ENV) (UNION (ENV-DISALLOWED-INLINES ENV) NAMES))) (DEFUN ENV-INLINE-ALLOWED (ENV NAME) (COND ((MEMBER NAME (ENV-ALLOWED-INLINES ENV) :TEST 'EQ) T) ((MEMBER NAME (ENV-DISALLOWED-INLINES ENV) :TEST 'EQ) NIL) (T (LET ((PARENT (ENV-PARENT ENV))) (IF (ENV-P PARENT) (ENV-INLINE-ALLOWED PARENT NAME) (IL:* IL:|;;| "We don't currently have a way to note globally inline-able functions. Thus, if you run out of environments, you don't have permission to inline it.") NIL))))) (DEFUN ENV-INLINE-DISALLOWED (ENV NAME) (COND ((MEMBER NAME (ENV-DISALLOWED-INLINES ENV) :TEST 'EQ) T) ((MEMBER NAME (ENV-ALLOWED-INLINES ENV) :TEST 'EQ) NIL) (T (LET ((PARENT (ENV-PARENT ENV))) (IF (ENV-P PARENT) (ENV-INLINE-DISALLOWED PARENT NAME) (XCL::GLOBALLY-NOTINLINE-P NAME)))))) (DEFUN ENV-PROCLAIM-SPECIAL (ENV NAME) (PUSH NAME (ENV-DECLARED-SPECIALS (FIND-TOP-ENVIRONMENT ENV))) NAME) (DEFUN ENV-PROCLAIMED-SPECIAL-P (ENV NAME) (MEMBER NAME (ENV-DECLARED-SPECIALS (FIND-TOP-ENVIRONMENT ENV)) :TEST 'EQ)) (DEFUN ENV-PROCLAIM-GLOBAL (ENV NAME) (PUSH NAME (ENV-DECLARED-GLOBALS (FIND-TOP-ENVIRONMENT ENV))) NAME) (DEFUN ENV-PROCLAIMED-GLOBAL-P (ENV NAME) (MEMBER NAME (ENV-DECLARED-GLOBALS (FIND-TOP-ENVIRONMENT ENV)) :TEST 'EQ)) (DEFUN ENV-DECLARE-SPECIALS (ENV SPECIALS) (SETF (ENV-DECLARED-SPECIALS ENV) (APPEND SPECIALS (ENV-DECLARED-SPECIALS ENV)))) (DEFUN ENV-DECLARE-GLOBALS (ENV GLOBALS) (SETF (ENV-DECLARED-GLOBALS ENV) (APPEND GLOBALS (ENV-DECLARED-GLOBALS ENV)))) (DEFUN ENV-DECLARE-A-SPECIAL (ENV VAR) (PUSH VAR (ENV-DECLARED-SPECIALS ENV))) (DEFUN ENV-DECLARE-A-GLOBAL (ENV VAR) (PUSH VAR (ENV-DECLARED-GLOBALS ENV))) (DEFUN FIND-TOP-ENVIRONMENT (ENV) (IL:|until| (NOT (ENV-P (ENV-PARENT ENV))) IL:|do| (SETQ ENV (ENV-PARENT ENV))) ENV) (DEFUN RESOLVE-VARIABLE-REFERENCE (CURRENT-ENV SYMBOL &OPTIONAL (SETQ-P NIL)) (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (LET ((OBJ (IL:* IL:|;;|  "Check up the chain of environments for bindings or local declarations.") (DO ((ENV CURRENT-ENV (ENV-PARENT ENV)) TEMP) ((OR (EQ ENV NIL) (EQ ENV T)) (IL:* IL:|;;| "If we hit the end of the chain, then look for proclamations and check LOCALVARS, SPECVARS and GLOBALVARS.") (COND ((AND SETQ-P (OR (LOCAL-CONSTANT-P SYMBOL) (CONSTANTP SYMBOL))) (WARN "Attempt to SETQ a declared constant: ~S" SYMBOL) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE)) ((LOCAL-CONSTANT-P SYMBOL) (MAKE-LITERAL :VALUE (CONSTANT-VALUE SYMBOL))) ((CONSTANTP SYMBOL) (MULTIPLE-VALUE-BIND (VALUE FOLDABLE?) (CHECK-GLOBAL-CONSTANT SYMBOL) (IF (NOT FOLDABLE?) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE) (MAKE-LITERAL :VALUE (SETF (CONSTANT-VALUE SYMBOL) VALUE))))) ((OR (IL:VARIABLE-GLOBAL-P SYMBOL) (MEMBER SYMBOL IL:GLOBALVARS :TEST 'EQ)) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE)) ((OR (AND (EQ IL:SPECVARS T) (NOT (MEMBER SYMBOL IL:LOCALVARS :TEST 'EQ))) (MEMBER SYMBOL IL:SPECVARS :TEST 'EQ) (MEMBER SYMBOL IL:LOCALFREEVARS :TEST 'EQ) (IL:VARIABLE-GLOBALLY-SPECIAL-P SYMBOL)) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE)) (T (UNLESS (MEMBER SYMBOL *AUTOMATIC-SPECIAL-DECLARATIONS* :TEST 'EQ) (WARN "The variable ~S was unknown and has been declared SPECIAL." SYMBOL) (PUSH SYMBOL *AUTOMATIC-SPECIAL-DECLARATIONS*)) (ENV-DECLARE-A-SPECIAL CURRENT-ENV SYMBOL) (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE)))) (IL:* IL:|;;|  "In each environment, look for bindings or declarations that involve this variable.") (COND ((SETQ TEMP (ASSOC SYMBOL (ENV-VENV ENV))) (RETURN (CDR TEMP))) ((MEMBER SYMBOL (ENV-DECLARED-SPECIALS ENV) :TEST 'EQ) (RETURN (MAKE-VARIABLE :NAME SYMBOL :SCOPE :SPECIAL :KIND :VARIABLE))) ((MEMBER SYMBOL (ENV-DECLARED-GLOBALS ENV) :TEST 'EQ) (RETURN (MAKE-VARIABLE :NAME SYMBOL :SCOPE :GLOBAL :KIND :VARIABLE))))))) (IL:* IL:|;;| "SETQ's want a bare VARIABLE, not a VAR-REF.") (IF (AND (NULL SETQ-P) (VARIABLE-P OBJ)) (MAKE-VAR-REF :VARIABLE OBJ) OBJ))) (DEFUN RESOLVE-VARIABLE-BINDING (ENV SYMBOL) (DECLARE (SPECIAL *NEW-GLOBALS* *NEW-SPECIALS* IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) (COND ((OR (LOCAL-CONSTANT-P SYMBOL) (CONSTANTP SYMBOL)) (CERROR "Make a lexical binding anyway." "The symbol ~S is declared as a constant and thus cannot be bound." SYMBOL) :LEXICAL) ((OR (MEMBER SYMBOL *NEW-GLOBALS* :TEST 'EQ) (ENV-PROCLAIMED-GLOBAL-P ENV SYMBOL) (IL:VARIABLE-GLOBAL-P SYMBOL) (MEMBER SYMBOL IL:GLOBALVARS :TEST 'EQ)) (CERROR "Make a lexical binding anyway." "The symbol ~S is declared as a global and thus cannot be bound." SYMBOL) :LEXICAL) ((OR (MEMBER SYMBOL *NEW-SPECIALS* :TEST 'EQ) (ENV-PROCLAIMED-SPECIAL-P ENV SYMBOL) (IL:VARIABLE-GLOBALLY-SPECIAL-P SYMBOL) (MEMBER SYMBOL IL:LOCALFREEVARS :TEST 'EQ) (IF (EQ IL:SPECVARS T) (NOT (MEMBER SYMBOL IL:LOCALVARS :TEST 'EQ)) (MEMBER SYMBOL IL:SPECVARS :TEST 'EQ))) :SPECIAL) (T :LEXICAL))) (DEFUN VALUE-FOLDABLE-P (VALUE) (IL:* IL:|;;;| "Should we replace a reference to a constant variable with the given value? Be careful: this predicate must imply FASL:VALUE-DUMPABLE-P. Also be careful about allowing folding of objects with components due to the EQ-ness problem.") (TYPEP VALUE '(OR SYMBOL NUMBER CHARACTER))) (DEFUN CHECK-GLOBAL-CONSTANT (SYMBOL) (IL:* IL:|;;;| "Find the value for the globally-declared constant SYMBOL and decide whether or not it should be folded into code that references it. Return two values, the constant value and a boolean which is true iff the value should be used.") (LET ((LOOKUP (GETHASH SYMBOL IL:COMPVARMACROHASH))) (COND ((NULL LOOKUP) (IL:* IL:|;;| "The symbol isn't in the COMPVARMACROHASH. If it's bound, then use its value. This is useful for keywords, for example.") (IF (BOUNDP SYMBOL) (VALUES (SYMBOL-VALUE SYMBOL) T) (ERROR "BUG: ~S is declared as a constant, but no value for it is known." SYMBOL))) ((OR (ATOM LOOKUP) (NOT (EQ (CAR LOOKUP) 'IL:CONSTANT)) (NULL (CDR LOOKUP)) (NOT (NULL (CDDR LOOKUP)))) (ERROR "BUG: The value of ~S in the constants hash table, ~S, has an illegal form." SYMBOL LOOKUP)) (T (LET* ((VALUE-EXPR (CADR LOOKUP)) (VALUE (EVAL VALUE-EXPR))) (IL:* IL:|;;| "Unless the VALUE-EXPR is the same as the SYMBOL (as it will be for all Common Lisp constants), we have no way of getting the value of the constant other than folding it in now. For the cases where the VALUE-EXPR is the same as the SYMBOL, we can afford to use the more conservative VALUE-FOLDABLE-P test.") (VALUES VALUE (OR (NOT (EQ VALUE-EXPR SYMBOL)) (VALUE-FOLDABLE-P VALUE)))))))) (DEFUN CONSTANT-VALUE (SYMBOL) (LET ((VALUE (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*))) (ASSERT VALUE NIL "~S is not a known constant" SYMBOL) (CAR VALUE))) (DEFUN SET-CONSTANT-VALUE (SYMBOL VALUE) (CAR (SETF (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*) (LIST VALUE)))) (DEFUN LOCAL-CONSTANT-P (SYMBOL) (GETHASH SYMBOL *CONSTANTS-HASH-TABLE*)) (DEFSETF CONSTANT-VALUE SET-CONSTANT-VALUE) (DEFVAR *CONSTANTS-HASH-TABLE* NIL (IL:* IL:|;;;| "Hash-table for keeping track of the constants defined in a given file.") ) (DEFVAR *ENVIRONMENT* NIL (IL:* IL:|;;;| "The current environment of declarations, bindings, etc. Rebound at several places within the compiler.") ) (DEFVAR *CONTEXT* NIL "The evaluation context of the current form. Rebound at several places within the compiler.") (DEFCONSTANT *ARGUMENT-CONTEXT* (MAKE-CONTEXT :VALUES-USED 1) "Context structure to be shared among all evaluations in return position.") (DEFCONSTANT *EFFECT-CONTEXT* (MAKE-CONTEXT :VALUES-USED 0) "Context structure to be shared among all evaluations for effect.") (DEFCONSTANT *NULL-CONTEXT* (MAKE-CONTEXT) "Context structure to be shared among all expressions in a position without any contextual information." ) (DEFCONSTANT *PREDICATE-CONTEXT* (MAKE-CONTEXT :VALUES-USED 1 :PREDICATE-P T) "Context structure to be shared among all evaluations as predicates.") (IL:* IL:|;;| "External interface to environments") (DEFUN ENV-BOUNDP (ENV NAME) (IL:* IL:|;;;| "Only used by clients outside the compiler (i.e., macros and optimizers).") (LET ((LOOKUP (ASSOC NAME (ENV-VENV ENV)))) (COND (LOOKUP (LET ((SCOPE-OR-STRUCT (CDR LOOKUP))) (IF (VARIABLE-P SCOPE-OR-STRUCT) (VARIABLE-SCOPE SCOPE-OR-STRUCT) SCOPE-OR-STRUCT))) ((MEMBER NAME (ENV-DECLARED-SPECIALS ENV) :TEST 'EQ) :SPECIAL) ((MEMBER NAME (ENV-DECLARED-GLOBALS ENV) :TEST 'EQ) :GLOBAL) (T (LET ((PARENT (ENV-PARENT ENV))) (AND (ENV-P PARENT) (ENV-BOUNDP PARENT NAME))))))) (DEFUN ENV-FBOUNDP (ENV NAME &KEY (LEXICAL-ONLY NIL)) (IL:* IL:|;;;| "Return two values: the KIND of the given NAME (either :MACRO or :FUNCTION) and, iff KIND = :MACRO, the expansion function for the macro.") (IL:* IL:|;;;| "When LEXICAL-ONLY is true, we're only supposed to tell the user about lexically apparent functions and macros. The environment chain ends in one representing the various top-level objects in the file. In particular, top-level DEFMACRO's are in there. Thus, in our search here, we must be careful to avoid looking in the top environment. We can distinguish such environments because their PARENT is T.") (LABELS ((FIND-FN (ENV) (LET ((PARENT (ENV-PARENT ENV))) (UNLESS (AND LEXICAL-ONLY (EQ PARENT T)) (LET ((LOOKUP (ASSOC NAME (ENV-FENV ENV) :TEST 'EQ))) (IF (NULL LOOKUP) (AND PARENT (NOT (EQ PARENT T)) (FIND-FN PARENT)) (VALUES-LIST (CDR LOOKUP)))))))) (FIND-FN ENV))) (DEFUN COPY-ENV-WITH-FUNCTION (ENV FN &OPTIONAL (KIND :FUNCTION) EXP-FN) (LET ((NEW-ENV (IF ENV (COPY-ENV ENV) (MAKE-EMPTY-ENV)))) (ENV-BIND-FUNCTION NEW-ENV FN KIND EXP-FN) NEW-ENV)) (DEFUN COPY-ENV-WITH-VARIABLE (ENV VAR &OPTIONAL (KIND :LEXICAL)) (LET ((NEW-ENV (IF ENV (COPY-ENV ENV) (MAKE-EMPTY-ENV)))) (ENV-BIND-VARIABLE NEW-ENV VAR KIND) NEW-ENV)) (DEFUN MAKE-EMPTY-ENV () (MAKE-ENV)) (IL:* IL:|;;| "Describe the machine we're running on and the target for hte compiled code") (DEFVAR *HOST-ARCHITECTURE* NIL) (DEFVAR *TARGET-ARCHITECTURE* NIL) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PUTPROPS IL:XCLC-ENV-CTXT IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange for the correct reader environment.") (IL:PUTPROPS IL:XCLC-ENV-CTXT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-ENV-CTXT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-GENCODE b/sources/XCLC-GENCODE new file mode 100644 index 00000000..b042f7bd --- /dev/null +++ b/sources/XCLC-GENCODE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED " 2-Oct-91 11:38:50" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-GENCODE.;4| 70006 IL:|changes| IL:|to:| (IL:FUNCTIONS GENCODE-CALL) IL:|previous| IL:|date:| " 4-Jun-90 13:14:30" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-GENCODE.;3|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-GENCODECOMS) (IL:RPAQQ IL:XCLC-GENCODECOMS ( (IL:* IL:|;;;| "Code Generation") (IL:VARIABLES *AVAILABLE-LEXICAL-NAMES* *BLIP-VAR* *CODE* *CURRENT-FRAME* *FRAME-NAME* *FREE-VENV* *NON-LOCALS* *OTHERS* *PC-VAR* *SPECIAL-LOCALS-BOUND* *SPECIAL-VENV* *STACK-NUMBER* *SUPPRESS-POPS* *TAG-NUMBER* *TAIL-RECURSION-THRESHOLD* *VAR-NUMBER* *LOCAL-FUNCTIONS*) (IL:FUNCTIONS START-LAP EMIT-LAP EMIT-LAP-LIST END-LAP) (IL:FUNCTIONS COLLECT-CODE FIND-SEGMENT MAKE-LAP-VAR MAKE-LAP-VAR-REFERENCE) (IL:FUNCTIONS SET-UP-RETURN-TO TAKE-DOWN-RETURN-TO) (IL:FUNCTIONS FRAME INTERCEPT-NON-LOCALS) (IL:COMS (IL:STRUCTURES UNBIND-FOR-TAIL-RECURSION) (IL:FUNCTIONS STOP-UNBINDS-AT-FRAME-BOUNDARY)) (IL:FUNCTIONS GENERATE-CODE GENCODE) (IL:* IL:\;  "Yet to be written: gencode-progv") (IL:FUNCTIONS GENCODE-BLOCK GENCODE-CALL GENCODE-CATCH GENCODE-GO GENCODE-IF GENCODE-LABELS GENCODE-LAMBDA GENCODE-LET GENCODE-LITERAL GENCODE-MV-CALL GENCODE-MV-PROG1 GENCODE-OPCODES GENCODE-PROGN GENCODE-PROGV GENCODE-RETURN GENCODE-SEGMENT GENCODE-SETQ GENCODE-TAGBODY GENCODE-TAGBODY-INLINE GENCODE-THROW GENCODE-UNWIND-PROTECT GENCODE-VAR-REF) (IL:* IL:|;;| "Policy variables.") (IL:VARIABLES *POP-SUPPRESSION-POLICY* *TAIL-RECURSION-POLICY*) (IL:* IL:|;;| "Testing Code Generation") (IL:FUNCTIONS TEST-GENCODE TEST-GENCODE1) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PROP IL:FILETYPE IL:XCLC-GENCODE) (IL:* IL:|;;| "Arrange to use the proper makefile environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-GENCODE))) (IL:* IL:|;;;| "Code Generation") (DEFVAR *AVAILABLE-LEXICAL-NAMES* NIL (IL:* IL:|;;;| "A list of the previously-allocated-but-now-free names for lexical variables. Newly-bound variables will take names from this list unless it's empty, at which point new names will be generated. Each new frame rebinds this list to NIL.") ) (DEFVAR *BLIP-VAR* NIL "If non-NIL, this is the LAP variable to be used for naming the blip variable in the current frame.") (DEFVAR *CODE* NIL "The current collection of LAP instructions, in reverse order. Added to during code generation.") (DEFVAR *CURRENT-FRAME* NIL (IL:* IL:|;;;| "Set to the block, tagbody, catch, unwind-protect, or lambda that was the cause of the current frame during code generation. Used by GENCODE-GO and GENCODE-RETURN to determine if a jump is possible. Also used by GENCODE-CALL in order to get the right code generated for calls to IL:ARG. (Yecch.)") ) (DEFVAR *FRAME-NAME* NIL "The name of the frame currently under construction. Used in the code generator.") (DEFVAR *FREE-VENV* NIL "An AList mapping the symbols naming freely referenced special variables into the LAP variables representing them. See also *special-venv*." ) (DEFVAR *NON-LOCALS* NIL "A list of the lexical variables (in the form of VARIABLE structures) used freely below this point. Added to and reset at various points during code generation." ) (DEFVAR *OTHERS* NIL "A list of all auxillary variables used below the current point. It eventually includes all non-parameter variables created within a given lambda. Used during code generation." ) (DEFVAR *PC-VAR* NIL (IL:* IL:|;;;| "Bound to the LAP-var representing the special variable SI::*CATCH-RETURN-PC* in the current frame. Used by blippers for unwinding.") ) (DEFVAR *SPECIAL-LOCALS-BOUND* NIL "Bound to T in contexts in which local (i.e., non-argument) specials have been bound, in order to diable the tail-recursion optimization." ) (DEFVAR *SPECIAL-VENV* NIL "An AList mapping the symbols naming currently-bound special variables into the LAP variables representing them. See also *free-venv*." ) (DEFVAR *STACK-NUMBER* NIL "Counter for generation of unique LAP stack-level names.") (DEFVAR *SUPPRESS-POPS* NIL "If non-NIL code in effect context will suppress any extra pop's that might normally be generated. This variable is rebound throughout the code generator. To turn off this optimization, set the variable *pop-suppression-policy* to NIL." ) (DEFVAR *TAG-NUMBER* 0 "Counter for the generation of unique LAP statement labels.") (DEFPARAMETER *TAIL-RECURSION-THRESHOLD* 6 "The maximum number of required arguments a function can have and still enable the tail-recursion optimization." ) (DEFVAR *VAR-NUMBER* 0 "Counter for the generation of unique LAP variables.") (DEFVAR *LOCAL-FUNCTIONS*) (DEFMACRO START-LAP () 'NIL) (DEFMACRO EMIT-LAP (INST) `(PUSH ,INST *CODE*)) (DEFMACRO EMIT-LAP-LIST (L) `(SETQ *CODE* (REVAPPEND ,L *CODE*))) (DEFMACRO END-LAP () `(NREVERSE *CODE*)) (DEFUN COLLECT-CODE (NODE CONTEXT) (LET ((*CODE* (START-LAP))) (GENCODE NODE CONTEXT) (END-LAP))) (DEFUN FIND-SEGMENT (TAGBODY TAG) "Return the segment in the given tagbody that contains the given tag." (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS TAGBODY) IL:WHEN (MEMBER TAG (SEGMENT-TAGS SEGMENT) :TEST 'EQ) IL:DO (RETURN SEGMENT))) (DEFUN MAKE-LAP-VAR (VAR &OPTIONAL ARG-P) (IL:* IL:|;;;| "Create a new LAP variable for the given VARIABLE structure and make the appropriate kind of note about the variable created.") (IF (NOT (VARIABLE-P VAR)) VAR (ECASE (VARIABLE-SCOPE VAR) ((:SPECIAL) (LET ((LV `(:S ,(VARIABLE-NAME VAR) ,(INCF *VAR-NUMBER*)))) (PUSH (CONS (VARIABLE-NAME VAR) LV) *SPECIAL-VENV*) (WHEN (NOT ARG-P) (PUSH LV *OTHERS*)) LV)) ((:LEXICAL) (IF (OR (NULL *AVAILABLE-LEXICAL-NAMES*) (VARIABLE-CLOSED-OVER VAR) (EQ :FUNCTION (VARIABLE-KIND VAR))) (IL:* IL:|;;| "Can't re-use a variable, so we'll make a new one.") (LET ((LV (LIST (IF (EQ :FUNCTION (VARIABLE-KIND VAR)) :FN :L) (VARIABLE-NAME VAR) (INCF *VAR-NUMBER*)))) (SETF (VARIABLE-LAP-VAR VAR) LV) (WHEN (AND (NOT ARG-P) (NOT (EQ (VARIABLE-KIND VAR) :FUNCTION))) (PUSH LV *OTHERS*)) LV) (IL:* IL:|;;| "There are old variables available for use. Re-use one.") (SETF (VARIABLE-LAP-VAR VAR) (LIST :L (VARIABLE-NAME VAR) (POP *AVAILABLE-LEXICAL-NAMES*))))) ((:GLOBAL) `(:G ,(VARIABLE-NAME VAR)))))) (DEFUN MAKE-LAP-VAR-REFERENCE (VAR) (ECASE (VARIABLE-SCOPE VAR) ((:LEXICAL) (PUSHNEW VAR *NON-LOCALS*) (LET ((LAP-VAR (VARIABLE-LAP-VAR VAR))) (ASSERT (NOT (NULL LAP-VAR)) NIL "BUG: ~S should should have a LAP var by now." VAR) LAP-VAR)) ((:SPECIAL) (LET ((LOOKUP (OR (ASSOC (VARIABLE-NAME VAR) *SPECIAL-VENV*) (ASSOC (VARIABLE-NAME VAR) *FREE-VENV*)))) (IF (NOT (NULL LOOKUP)) (CDR LOOKUP) (LET ((LV `(:F ,(VARIABLE-NAME VAR) ,(INCF *VAR-NUMBER*)))) (PUSH (CONS (VARIABLE-NAME VAR) LV) *FREE-VENV*) (PUSH LV *OTHERS*) LV)))) ((:GLOBAL) `(:G ,(VARIABLE-NAME VAR))))) (DEFUN SET-UP-RETURN-TO () (IL:* IL:|;;|  "Perform those operations necessary to set up a return-to context for code-generation.") (WHEN (NULL *BLIP-VAR*) (SETQ *BLIP-VAR* `(:S SI::*CATCH-RETURN-TO* ,(INCF *VAR-NUMBER*))) (PUSH *BLIP-VAR* *OTHERS*)) (WHEN (NULL *PC-VAR*) (SETQ *PC-VAR* `(:S SI::*CATCH-RETURN-PC* ,(INCF *VAR-NUMBER*))) (PUSH *PC-VAR* *OTHERS*))) (DEFUN TAKE-DOWN-RETURN-TO () (EMIT-LAP-LIST `((:CONST NIL) (:VAR_ ,*BLIP-VAR*) (:POP)))) (DEFMACRO FRAME ((&KEY CURRENT-FRAME NAME BLIPS-ALLOWED) &BODY BODY) `(LET (,@(AND CURRENT-FRAME `((*CURRENT-FRAME* ,CURRENT-FRAME))) ,@(AND NAME `((*FRAME-NAME* ,NAME))) (*BLIP-VAR* NIL) (*PC-VAR* NIL) (*CODE* (START-LAP)) *OTHERS* *SPECIAL-LOCALS-BOUND* *SPECIAL-VENV* *FREE-VENV* *AVAILABLE-LEXICAL-NAMES* *LOCAL-FUNCTIONS*) (HANDLER-BIND ((UNBIND-FOR-TAIL-RECURSION #'STOP-UNBINDS-AT-FRAME-BOUNDARY)) ,@BODY))) (DEFMACRO INTERCEPT-NON-LOCALS (PASS-ON &BODY BODY) `(LET (OUTER-NON-LOCALS) (LET (*NON-LOCALS*) ,@BODY (SETQ OUTER-NON-LOCALS ,PASS-ON)) (SETQ *NON-LOCALS* (UNION OUTER-NON-LOCALS *NON-LOCALS*)))) (DEFINE-CONDITION UNBIND-FOR-TAIL-RECURSION (CONDITION) NIL) (DEFUN STOP-UNBINDS-AT-FRAME-BOUNDARY (CONDITION) (IL:* IL:|;;| "This routine stops propagation of UNBIND-FOR-TAIL-RECURSION.") (ASSERT (TYPEP CONDITION 'UNBIND-FOR-TAIL-RECURSION) NIL "BUG: Unbind stopper called with bad condition.") (LET ((RESTART (FIND-RESTART 'CONTINUE-TAIL-CALL-TRANSFORMATION))) (WHEN (NULL RESTART) (CERROR "Muddle on anyway" "BUG: Can't find restart for tail call transformation")) (INVOKE-RESTART RESTART))) (DEFUN GENERATE-CODE (TREE) (IL:* IL:|;;;| "GenCode functions take a subtree as an argument and return a list of LAP instructions that implement that subtree. Here, at the top of the generator, we know that TREE is a LAMBDA and that only one instruction will be returned. We return that instruction.") (ASSERT (LAMBDA-P TREE) NIL "Root tree for code generation is not a LAMBDA") (LET* ((*VAR-NUMBER* 0) (*TAG-NUMBER* 0) (*STACK-NUMBER* 0) (*CODE* (START-LAP))) (GENCODE-LAMBDA TREE :ARGUMENT) (ASSERT (NULL (CDR (SETQ *CODE* (END-LAP)))) NIL "Code generation returned more than one instruction!") (CAR *CODE*))) (DEFUN GENCODE (NODE CONTEXT) "Dispatching function for code generation." (NODE-DISPATCH GENCODE NODE CONTEXT)) (IL:* IL:\; "Yet to be written: gencode-progv") (DEFUN GENCODE-BLOCK (NODE CONTEXT) (COND ((BLOCK-NEW-FRAME-P NODE) (IL:* IL:\;  "Construct a new lambda for the block.") (LET (NEW-LAMBDA) (FRAME (:NAME (FORMAT NIL "block ~A in ~A" (BLOCK-NAME NODE) *FRAME-NAME*) :CURRENT-FRAME NODE) (LET ((EFFECTIVE-CONTEXT (ECASE CONTEXT (:MV :MV) (:RETURN :RETURN) ((:EFFECT :ARGUMENT) :ARGUMENT))) (END-TAG (INCF *TAG-NUMBER*)) BLIP-RETURN-VAR OUR-NON-LOCALS) (SETF (BLOCK-FRAME NODE) *CURRENT-FRAME*) (SETF (BLOCK-CONTEXT NODE) EFFECTIVE-CONTEXT) (SETF (BLOCK-END-TAG NODE) END-TAG) (COND ((BLOCK-CLOSED-OVER-P NODE) (SETQ *BLIP-VAR* `(:S SI::*CATCH-RETURN-FROM* ,(INCF *VAR-NUMBER*))) (SETQ BLIP-RETURN-VAR (MAKE-LAP-VAR (BLOCK-BLIP-VAR NODE))) (EMIT-LAP-LIST `((:CONST ,*FRAME-NAME*) (:CONST NIL) (:CALL CONS 2) (:VAR_ ,*BLIP-VAR*) (:VAR_ ,BLIP-RETURN-VAR) (:POP))) (SETQ *OTHERS* (LIST BLIP-RETURN-VAR *BLIP-VAR*))) (T (SETQ *BLIP-VAR* `(:S SI::*CATCH-RETURN-TO* ,(INCF *VAR-NUMBER*))) (SETQ *OTHERS* (LIST *BLIP-VAR*)))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE (BLOCK-BLIP-VAR NODE) *NON-LOCALS*)) (GENCODE (BLOCK-STMT NODE) EFFECTIVE-CONTEXT)) (EMIT-LAP-LIST `((:TAG ,END-TAG) (:RETURN))) (SETQ NEW-LAMBDA `(:LAMBDA (NIL ,@(AND *OTHERS* `(:OTHERS ,*OTHERS*)) :NAME ,*FRAME-NAME* :BLIP ,*BLIP-VAR* ,@(AND OUR-NON-LOCALS `(:NON-LOCAL ,(MAPCAR #'VARIABLE-LAP-VAR OUR-NON-LOCALS))) ,@(AND (BLOCK-CLOSED-OVER-VARS NODE) `(:CLOSED-OVER ,(MAPCAR #'VARIABLE-LAP-VAR ( BLOCK-CLOSED-OVER-VARS NODE)))) ,@(AND *LOCAL-FUNCTIONS* `(:LOCAL-FUNCTIONS ,*LOCAL-FUNCTIONS*))) ,@(END-LAP))))) (EMIT-LAP `(:CALL ,NEW-LAMBDA 0)) (IL:* IL:\;  "Generate a call to the new lambda.") (WHEN (AND (EQ CONTEXT :EFFECT) (NOT *SUPPRESS-POPS*)) (EMIT-LAP '(:POP))))) (T (IL:* IL:|;;| "No new frame is needed, so compile the block inline, setting up and taking down the blip stuff if it's closed over.") (LET ((END-TAG (INCF *TAG-NUMBER*)) (STK-NUM (INCF *STACK-NUMBER*))) (SETF (BLOCK-FRAME NODE) *CURRENT-FRAME*) (SETF (BLOCK-END-TAG NODE) END-TAG) (SETF (BLOCK-STK-NUM NODE) STK-NUM) (SETF (BLOCK-CONTEXT NODE) CONTEXT) (IL:* IL:|;;| "If the block is closed over, we need to set up and take down the blip stuff around the execution of the body. If it isn't closed over, then almost nothing extra is needed.") (COND ((BLOCK-CLOSED-OVER-P NODE) (LET ((BLIP-VAR (MAKE-LAP-VAR (BLOCK-BLIP-VAR NODE))) (REMOTE-RETURN-TAG (INCF *TAG-NUMBER*))) (FLET ((GENCODE-CLOSED-OVER-BLOCK NIL (SET-UP-RETURN-TO) (EMIT-LAP-LIST `((:CONST ,(BLOCK-NAME NODE)) (:CONST ,*FRAME-NAME*) (:CALL CONS 2) (:VAR_ ,*BLIP-VAR*) (:VAR_ ,BLIP-VAR) (:POP) (:PUSH-TAG ,REMOTE-RETURN-TAG) (:VAR_ ,*PC-VAR*) (:POP) (:NOTE-STACK ,STK-NUM))) (INTERCEPT-NON-LOCALS (DELETE (BLOCK-BLIP-VAR NODE) *NON-LOCALS*) (GENCODE (BLOCK-STMT NODE) CONTEXT)) (ECASE CONTEXT ((:EFFECT) (EMIT-LAP-LIST `((:JUMP ,END-TAG) (:TAG ,REMOTE-RETURN-TAG) (:DSET-STACK ,STK-NUM) (:TAG ,END-TAG))) (TAKE-DOWN-RETURN-TO)) ((:MV :ARGUMENT) (EMIT-LAP-LIST `((:JUMP ,END-TAG) (:TAG ,REMOTE-RETURN-TAG) (:SET-STACK ,STK-NUM) (:TAG ,END-TAG))) (TAKE-DOWN-RETURN-TO)) ((:RETURN) (EMIT-LAP-LIST `((:TAG ,REMOTE-RETURN-TAG) (:TAG ,END-TAG))))))) (IF (NULL (BLOCK-CLOSED-OVER-VARS NODE)) (GENCODE-CLOSED-OVER-BLOCK) (LET ((CODE (LET ((*CODE* (START-LAP))) (GENCODE-CLOSED-OVER-BLOCK) (END-LAP)))) (EMIT-LAP `(:CLOSE ,(MAPCAR #'VARIABLE-LAP-VAR ( BLOCK-CLOSED-OVER-VARS NODE)) ,@CODE))))))) (T (IL:* IL:|;;|  "Simplest case: the block is neither closed over nor needs a new frame.") (EMIT-LAP `(:NOTE-STACK ,STK-NUM)) (GENCODE (BLOCK-STMT NODE) CONTEXT) (EMIT-LAP `(:TAG ,END-TAG)))))))) (DEFUN GENCODE-CALL (NODE CONTEXT) (IL:* IL:|;;;| "If the function is a global function symbol, evaluate the arguments onto the stack and emit a FN. If it's a lambda with only required parameters, then evaluate only the non-nil arguments on the stack, bind the parameters, execute the body, and unbind. Otherwise, evaluate the args and function and call FUNCALL.") (LET* ((FN (CALL-FN NODE)) (ARGS (CALL-ARGS NODE)) (NUM-ARGS (LENGTH ARGS)) (IL-LAMBDA NIL)) (COND (IL:* IL:|;;| "Can we perform tail recursion elimination?") ((AND (EQ CONTEXT :RETURN) (NOT (NULL *TAIL-RECURSION-POLICY*)) (NOT *SPECIAL-LOCALS-BOUND*) (NOT (CALLER-NOT-INLINE NODE)) (VAR-REF-P FN) (LET ((VAR (VAR-REF-VARIABLE FN))) (AND (EQ :FUNCTION (VARIABLE-KIND VAR)) (EQUAL *FRAME-NAME* (VARIABLE-NAME VAR))) (IL:* IL:\;  "EQUAL here because of FLET.") ) (<= (LENGTH (LAMBDA-REQUIRED *CURRENT-FRAME*)) *TAIL-RECURSION-THRESHOLD*) (OR (AND (NULL (LAMBDA-OPTIONAL *CURRENT-FRAME*)) (NULL (LAMBDA-REST *CURRENT-FRAME*))) (IL:* IL:|;;| " This for Interlisp-D LAMBDA form") (PROG1 (= (LENGTH (LAMBDA-OPTIONAL *CURRENT-FRAME*)) NUM-ARGS) (SETQ IL-LAMBDA T))) (NULL (LAMBDA-KEYWORD *CURRENT-FRAME*))) (IL:FOR ARG IL:IN ARGS IL:DO (GENCODE ARG :ARGUMENT)) (IF IL-LAMBDA (IL:FOR PARAM IL:IN (REVERSE (LAMBDA-OPTIONAL *CURRENT-FRAME*)) IL:DO (EMIT-LAP-LIST `((:VAR_ ,(MAKE-LAP-VAR-REFERENCE (CAR PARAM))) (:POP)))) (IL:FOR PARAM IL:IN (REVERSE (LAMBDA-REQUIRED *CURRENT-FRAME*)) IL:DO (EMIT-LAP-LIST `((:VAR_ ,(MAKE-LAP-VAR-REFERENCE PARAM)) (:POP))))) (RESTART-CASE (SIGNAL 'UNBIND-FOR-TAIL-RECURSION) (CONTINUE-TAIL-CALL-TRANSFORMATION NIL)) (EMIT-LAP `(:JUMP ,(OR (LAMBDA-TAIL-CALL-TAG *CURRENT-FRAME*) (SETF (LAMBDA-TAIL-CALL-TAG *CURRENT-FRAME*) (INCF *TAG-NUMBER*)))))) (IL:* IL:|;;| "Maybe it's a global function") ((GLOBAL-FUNCTION-P FN) (LET ((FN-VAR (VAR-REF-VARIABLE FN))) (COND ((EQ (VARIABLE-NAME FN-VAR) 'IL:\\CALLME) (IL:* IL:|;;| "Hook for the IL:\\\\CALLME special form. This simply changes the name of the current frame to the given argument and otherwise generates no code.") (ASSERT (EQ CONTEXT :EFFECT) NIL "BUG: The ~S special form not in effect context in code generation." 'IL:\\CALLME) (ASSERT (LITERAL-P (FIRST ARGS)) NIL "BUG: The ~S special form has an unquoted argument in code generation." 'IL:\\CALLME) (SETQ *FRAME-NAME* (LITERAL-VALUE (FIRST ARGS))) (RETURN-FROM GENCODE-CALL)) ((AND (MEMBER (VARIABLE-NAME FN-VAR) '(IL:\\ARG IL:\\SETARG)) (LITERAL-P (FIRST ARGS)) (NOT (CALLER-NOT-INLINE NODE))) (IL:* IL:|;;| "Here it is, the nasty hook for compiling Interlisp's LAMBDA no-spread's. If we're compiling a call to the function IL:ARG, we check to see if it's referring to the current frame. If so, we compile it as a call to IL:\\\\ARG0 which will later be assembled into an opcode. If the IL:ARG call doesn't refer to the current frame, then we compile it closed, using the LAMBDA-version of that function, IL:\\\\ARG.") (IL:* IL:|;;| "The same mechanism is here for IL:SETARG.") (LET* ((PARAMETER-NAME (LITERAL-VALUE (FIRST ARGS))) (CLOSED-FN-NAME (VARIABLE-NAME FN-VAR)) (OPEN-FN-NAME (CASE CLOSED-FN-NAME (IL:\\ARG 'IL:\\ARG0) (IL:\\SETARG 'IL:\\SETARG0)))) (UNLESS (SYMBOLP PARAMETER-NAME) (CERROR "Use the symbol %LOSE% instead" "Illegal argument to the ~S function: ~S" (VARIABLE-NAME FN-VAR) PARAMETER-NAME)) (COND ((AND (LAMBDA-P *CURRENT-FRAME*) (EQ (LAMBDA-NO-SPREAD-NAME *CURRENT-FRAME*) PARAMETER-NAME)) (IL:* IL:\;  "It's a reference to the local frame.") (GENCODE (SECOND ARGS) :ARGUMENT) (WHEN (THIRD ARGS) (GENCODE (THIRD ARGS) :ARGUMENT)) (EMIT-LAP `(:CALL ,OPEN-FN-NAME ,(1- (LENGTH ARGS))))) (T (IL:* IL:\; "It's a remote reference.") (EMIT-LAP `(:CONST ,PARAMETER-NAME)) (GENCODE (SECOND ARGS) :ARGUMENT) (WHEN (THIRD ARGS) (GENCODE (THIRD ARGS) :ARGUMENT)) (EMIT-LAP `(:CALL ,CLOSED-FN-NAME ,(LENGTH ARGS))))))) (T (IL:FOR ARG IL:IN ARGS IL:DO (GENCODE ARG :ARGUMENT)) (EMIT-LAP `(:CALL ,(VARIABLE-NAME FN-VAR) ,NUM-ARGS ,@(AND (CALLER-NOT-INLINE NODE) `(:NOT-INLINE T)))))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (EMIT-LAP '(:CALL IL:\\MVLIST 1)))))) (IL:* IL:|;;| "Is it a desugared LET?") ((AND (LAMBDA-P FN) (NOT (LAMBDA-NEW-FRAME-P FN))) (IL:* IL:|;;| "NOTE: This code makes the assumption that *code* is maintained by pushing bytes onto a list and should be re-examined if that is ever changed (e.g., to the TCONC method).") (IL:* IL:|;;| "NOTE: This is a LET* so as to guarantee that the code below has been generated before we try to extract LAP vars from the variables, since those LAP vars might not exist yet.") (LET* ((INNER-CODE (LET (*CODE*) (GENCODE-LET FN ARGS CONTEXT) *CODE*)) (CLOSED-OVER (MAPCAR #'VARIABLE-LAP-VAR (LAMBDA-CLOSED-OVER-VARS FN)))) (COND ((NULL CLOSED-OVER) (SETQ *CODE* (NCONC INNER-CODE *CODE*))) (T (EMIT-LAP `(:CLOSE ,CLOSED-OVER ,@(NREVERSE INNER-CODE))))))) (IL:* IL:|;;| "Perhaps it's a low-level OPCODES function.") ((OPCODES-P FN) (IL:FOR ARG IL:IN ARGS IL:DO (GENCODE ARG :ARGUMENT)) (EMIT-LAP `(:CALL (:OPCODES ,@(OPCODES-BYTES FN)) ,NUM-ARGS)) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (EMIT-LAP '(:CALL IL:\\MVLIST 1))))) (IL:* IL:|;;| "Well, it wasn't any of those, so compile the general case. ") (T (COND ((IL:FOR ARG IL:IN ARGS IL:ALWAYS (PASSABLE FN ARG)) (IL:* IL:\;  "The function can pass all of the arguments, so we can use APPLYFN without an auxillary variable.") (IL:FOR ARG IL:IN ARGS IL:DO (GENCODE ARG :ARGUMENT)) (COND ((LAMBDA-P FN) (LET ((CODE-FOR-FN (COLLECT-CODE FN :ARGUMENT))) (EMIT-LAP `(:CALL ,(POP CODE-FOR-FN) ,NUM-ARGS)) (ASSERT (NULL CODE-FOR-FN) NIL "BUG: a lambda generated more than one LAP op."))) ((AND (VAR-REF-P FN) (NOT (EQ (VARIABLE-SCOPE (VAR-REF-VARIABLE FN)) :GLOBAL))) (IL:* IL:\;  "Must be a local or a special - external functions have already been handled.") (LET ((VAR (VAR-REF-VARIABLE FN))) (ASSERT (NOT (EQ (VARIABLE-SCOPE VAR) :GLOBAL)) '(FN) "BUG: external function call got into the general case.") (EMIT-LAP `(:CALL ,(MAKE-LAP-VAR-REFERENCE VAR) ,NUM-ARGS)))) (T (IL:* IL:\;  "Random expression - have to punt to a :STKCALL") (EMIT-LAP `(:CONST ,NUM-ARGS)) (GENCODE FN :ARGUMENT) (EMIT-LAP `(:STKCALL ,NUM-ARGS)))) (COND ((LAMBDA-P FN) (GENCODE-LAMBDA FN :ARGUMENT CONTEXT)))) (T (IL:* IL:\; "Rats! We have to allocate a new local variable to store the function in during the evaluation of the arguments.") (LET ((FN-VAR (COND ((NULL *AVAILABLE-LEXICAL-NAMES*) (LET ((LV `(:L "APPLYFN Variable" ,(INCF *VAR-NUMBER*)))) (PUSH LV *OTHERS*) LV)) (T `(:L "APPLYFN Variable" ,(POP *AVAILABLE-LEXICAL-NAMES*))))) ) (IF (LAMBDA-P FN) (GENCODE-LAMBDA FN :ARGUMENT CONTEXT) (GENCODE FN :ARGUMENT)) (EMIT-LAP-LIST `((:VAR_ ,FN-VAR) (:POP))) (IL:FOR ARG IL:IN ARGS IL:DO (GENCODE ARG :ARGUMENT)) (EMIT-LAP `(:CALL ,FN-VAR ,NUM-ARGS)) (PUSH (THIRD FN-VAR) *AVAILABLE-LEXICAL-NAMES*)))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (UNLESS (LAMBDA-P FN) (IL:* IL:\;  "If the function is a LAMBDA, then we've already made it return a list of values.") (EMIT-LAP '(:CALL IL:\\MVLIST 1))))))))) (DEFUN GENCODE-CATCH (NODE CONTEXT) (COND ((BLIPPER-NEW-FRAME-P NODE) (IL:* IL:|;;| "This CATCH has to be a new frame. Compile the body as a new function with one argument, the value of the tag expression.") (LET (NEW-LAMBDA) (FRAME (:CURRENT-FRAME NODE :NAME (FORMAT NIL "catch in ~A" *FRAME-NAME*)) (LET* ((BLIP-SLOT-NAME (IF (EQ CONTEXT :MV) 'SI::*CATCH-RETURN-TO* 'SI::*CATCH-RETURN-FROM*)) (BLIP-SLOT-VAR `(:S ,BLIP-SLOT-NAME ,(INCF *VAR-NUMBER*))) (TAG-VAR `(:L "%TAG" ,(INCF *VAR-NUMBER*))) OUR-NON-LOCALS (THROW-PC-VAR `(:S SI::*CATCH-RETURN-PC* ,(INCF *VAR-NUMBER*))) (THROW-DESTINATION-TAG (INCF *TAG-NUMBER*))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS *NON-LOCALS*) (GENCODE (CATCH-STMT NODE) CONTEXT)) (SETQ NEW-LAMBDA `(:LAMBDA ((,TAG-VAR) :BLIP ,BLIP-SLOT-VAR :NAME ,*FRAME-NAME* :OTHERS (,BLIP-SLOT-VAR ,@(AND (EQ CONTEXT :MV) `(,THROW-PC-VAR)) ,@*OTHERS*) ,@(AND OUR-NON-LOCALS `(:NON-LOCAL ,(MAPCAR #'VARIABLE-LAP-VAR OUR-NON-LOCALS))) ,@(AND (CATCH-CLOSED-OVER-VARS NODE) `(:CLOSED-OVER ,(MAPCAR #'VARIABLE-LAP-VAR ( CATCH-CLOSED-OVER-VARS NODE)))) ,@(AND *LOCAL-FUNCTIONS* `(:LOCAL-FUNCTIONS ,*LOCAL-FUNCTIONS*))) (IL:* IL:|;;| "Set up the blip and, when in MV context, the THROW PC.") (:VAR ,TAG-VAR) (:VAR_ ,BLIP-SLOT-VAR) (:POP) ,@(AND (EQ CONTEXT :MV) `((:PUSH-TAG ,THROW-DESTINATION-TAG) (:VAR_ ,THROW-PC-VAR) (:POP))) ,@(END-LAP) (:RETURN) ,@(AND (EQ CONTEXT :MV) `((:TAG ,THROW-DESTINATION-TAG) (:CALL IL:\\MVLIST 1) (:RETURN))))))) (GENCODE (CATCH-TAG NODE) :ARGUMENT) (EMIT-LAP `(:CALL ,NEW-LAMBDA 1)) (WHEN (EQ CONTEXT :EFFECT) (EMIT-LAP '(:POP))))) (T (IL:* IL:|;;| "This CATCH should not be a new frame. We compile it inline, setting up and taking down blip stuff around the computation of the body.") (LET ((END-TAG (INCF *TAG-NUMBER*)) (THROW-TAG (INCF *TAG-NUMBER*)) (STK-NUM (INCF *STACK-NUMBER*))) (SET-UP-RETURN-TO) (GENCODE (CATCH-TAG NODE) :ARGUMENT) (EMIT-LAP-LIST `((:VAR_ ,*BLIP-VAR*) (:POP) (:PUSH-TAG ,THROW-TAG) (:VAR_ ,*PC-VAR*) (:POP) (:NOTE-STACK ,STK-NUM))) (GENCODE (CATCH-STMT NODE) CONTEXT) (ECASE CONTEXT ((:EFFECT) (EMIT-LAP-LIST `((:JUMP ,END-TAG) (:TAG ,THROW-TAG) (:DSET-STACK ,STK-NUM) (:TAG ,END-TAG))) (TAKE-DOWN-RETURN-TO)) ((:MV) (EMIT-LAP-LIST `((:JUMP ,END-TAG) (:TAG ,THROW-TAG) (:CALL IL:\\MVLIST 1) (:SET-STACK ,STK-NUM) (:TAG ,END-TAG))) (TAKE-DOWN-RETURN-TO)) ((:ARGUMENT) (EMIT-LAP-LIST `((:JUMP ,END-TAG) (:TAG ,THROW-TAG) (:SET-STACK ,STK-NUM) (:TAG ,END-TAG))) (TAKE-DOWN-RETURN-TO)) ((:RETURN) (EMIT-LAP `(:TAG ,THROW-TAG)))))))) (DEFUN GENCODE-GO (NODE CONTEXT) (DECLARE (IGNORE CONTEXT)) (LET* ((TAGBODY (GO-TAGBODY NODE)) (SEGMENT (FIND-SEGMENT TAGBODY (GO-TAG NODE)))) (COND ((EQ *CURRENT-FRAME* (TAGBODY-FRAME TAGBODY)) (IL:* IL:\;  "The tagbody is local; a simple stack adjustment and JUMP suffice.") (EMIT-LAP-LIST `((:DSET-STACK ,(TAGBODY-STK-NUM TAGBODY)) (:JUMP ,(SEGMENT-LOCAL-TAG SEGMENT))))) (T (EMIT-LAP-LIST `((:VAR ,(VARIABLE-LAP-VAR (TAGBODY-BLIP-VAR TAGBODY))) (:PUSH-TAG ,(SEGMENT-REMOTE-TAG SEGMENT)) (:CALL SI::NON-LOCAL-GO 2))) (PUSH (TAGBODY-BLIP-VAR TAGBODY) *NON-LOCALS*))))) (DEFUN GENCODE-IF (NODE CONTEXT) (LET ((ELSE-TAG (INCF *TAG-NUMBER*)) (AFTER-IF-TAG (INCF *TAG-NUMBER*))) (GENCODE (IF-PRED NODE) :ARGUMENT) (EMIT-LAP `(:FJUMP ,ELSE-TAG)) (GENCODE (IF-THEN NODE) CONTEXT) (IF (EQ CONTEXT :RETURN) (EMIT-LAP '(:RETURN)) (EMIT-LAP `(:JUMP ,AFTER-IF-TAG))) (EMIT-LAP `(:TAG ,ELSE-TAG)) (GENCODE (IF-ELSE NODE) CONTEXT) (UNLESS (EQ CONTEXT :RETURN) (EMIT-LAP `(:TAG ,AFTER-IF-TAG))))) (DEFUN GENCODE-LABELS (NODE CONTEXT) (IL:* IL:|;;| "Make LAP vars first to take care of \"forward\" references.") (DOLIST (FN-PAIR (LABELS-FUNS NODE)) (MAKE-LAP-VAR (CAR FN-PAIR))) (IL:* IL:|;;| "Generate the local functions.") (LET (INNER-CODE CLOSED-OVER) (INTERCEPT-NON-LOCALS (DELETE-IF #'(LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) NODE)) *NON-LOCALS*) (DOLIST (FN-PAIR (LABELS-FUNS NODE)) (PUSH (CONS (MAKE-LAP-VAR-REFERENCE (CAR FN-PAIR)) (COLLECT-CODE (CDR FN-PAIR) :ARGUMENT)) *LOCAL-FUNCTIONS*)) (SETQ INNER-CODE (COLLECT-CODE (LABELS-BODY NODE) CONTEXT)) (SETQ CLOSED-OVER (MAPCAR #'VARIABLE-LAP-VAR (LABELS-CLOSED-OVER-VARS NODE)))) (COND ((NULL CLOSED-OVER) (SETQ *CODE* (REVAPPEND INNER-CODE *CODE*))) (T (EMIT-LAP `(:CLOSE ,CLOSED-OVER ,@INNER-CODE)))))) (DEFUN GENCODE-LAMBDA (NODE CONTEXT) (WHEN (EQ CONTEXT :EFFECT) (IL:* IL:\;  "Lambda expressions cannot have any side-effects.") (RETURN-FROM GENCODE-LAMBDA)) (LET (NEW-LAMBDA OUR-NON-LOCALS CLOSED-OVER REQUIRED OPTIONAL REST KEY) (FRAME (:NAME (OR (LAMBDA-NAME NODE) (FORMAT NIL "lambda in ~A" *FRAME-NAME*)) :CURRENT-FRAME NODE) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE-IF #'(LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) NODE)) *NON-LOCALS*)) (IL:* IL:|;;| "Convert the parameters into LAP-code notation.") (SETQ REQUIRED (MAPCAR #'(LAMBDA (VAR) (MAKE-LAP-VAR VAR T)) (LAMBDA-REQUIRED NODE))) (SETQ OPTIONAL (MAPCAR #'(LAMBDA (OPT-VAR) (LET ((INIT-CODE (COLLECT-CODE (SECOND OPT-VAR) :ARGUMENT))) (IL:* IL:|;;| "Generating code for the init form has to come before we create the varibles so that free references in the init form don't capture them.") (LIST (MAKE-LAP-VAR (FIRST OPT-VAR) T) INIT-CODE (MAKE-LAP-VAR (THIRD OPT-VAR) T)))) (LAMBDA-OPTIONAL NODE))) (SETQ REST (LET ((REST-VAR (LAMBDA-REST NODE))) (COND ((NULL REST-VAR) NIL) ((AND (EQ :LEXICAL (VARIABLE-SCOPE REST-VAR)) (NULL (VARIABLE-READ-REFS REST-VAR)) (NULL (VARIABLE-WRITE-REFS REST-VAR))) :IGNORED) (T (MAKE-LAP-VAR REST-VAR T))))) (SETQ KEY (MAPCAR #'(LAMBDA (KEY-VAR) (LET ((INIT-CODE (COLLECT-CODE (THIRD KEY-VAR) :ARGUMENT))) (IL:* IL:|;;| "Generating code for the init form has to come before we create the varibles so that free references in the init form don't capture them.") (LIST (FIRST KEY-VAR) (MAKE-LAP-VAR (SECOND KEY-VAR) T) INIT-CODE (MAKE-LAP-VAR (FOURTH KEY-VAR) T)))) (LAMBDA-KEYWORD NODE))) (IL:* IL:|;;| "Generate code for the body of the lambda.") (GENCODE (LAMBDA-BODY NODE) :RETURN)) (IL:* IL:|;;| "Convert the closed-over variable list into LAP vars.") (SETQ CLOSED-OVER (MAPCAR #'VARIABLE-LAP-VAR (LAMBDA-CLOSED-OVER-VARS NODE))) (IL:* IL:|;;| "Finally, construct the lambda-structure for the LAP-code.") (SETQ NEW-LAMBDA `(:LAMBDA (,REQUIRED ,@(AND OPTIONAL `(:OPTIONAL ,OPTIONAL)) ,@(AND REST `(:REST ,REST)) ,@(AND KEY `(:KEY ,KEY)) ,@(AND (LAMBDA-ALLOW-OTHER-KEYS NODE) '(:ALLOW-OTHER-KEYS T)) ,@(AND *OTHERS* `(:OTHERS ,*OTHERS*)) ,@(AND *BLIP-VAR* `(:BLIP ,*BLIP-VAR*)) :NAME ,*FRAME-NAME* ,@(AND (LAMBDA-ARG-TYPE NODE) `(:ARG-TYPE ,(LAMBDA-ARG-TYPE NODE))) ,@(AND CLOSED-OVER `(:CLOSED-OVER ,CLOSED-OVER)) ,@(AND OUR-NON-LOCALS `(:NON-LOCAL ,(MAPCAR #'VARIABLE-LAP-VAR OUR-NON-LOCALS))) ,@(AND *LOCAL-FUNCTIONS* `(:LOCAL-FUNCTIONS ,*LOCAL-FUNCTIONS*) )) ,@(AND (LAMBDA-TAIL-CALL-TAG NODE) `((:TAG ,(LAMBDA-TAIL-CALL-TAG NODE)))) ,@(END-LAP) (:RETURN)))) (IL:* IL:|;;| "Now that we're outside of the bindings of the specials above, we can pass on our results to the outside world.") (EMIT-LAP NEW-LAMBDA) (WHEN (EQ CONTEXT :MV) (IL:* IL:\;  "In MV context, we need to make this a list.") (EMIT-LAP-LIST '((:CONST NIL) (:CALL CONS 2)))))) (DEFUN GENCODE-LET (FN ARGS CONTEXT) (IL:* IL:|;;;| "Compile the given function and arguments as a LET.") (IL:* IL:|;;| "Separate the arguments and matching parameters into two sets, according to whether or not the argument is NIL. Also, since we're not allowed to BIND any closed-over variables, we have to store those arguments as we compute them to get them out of the way.") (LET ((*SPECIAL-VENV* *SPECIAL-VENV*) (SPECIAL-LOCALS-HERE NIL) (STK-NUM (INCF *STACK-NUMBER*)) NULL-PARAMS NON-NULL-PARAMS) (IL:FOR ARG IL:IN ARGS IL:AS PARAM IL:IN (LAMBDA-REQUIRED FN) IL:DO (WHEN (EQ :SPECIAL (VARIABLE-SCOPE PARAM)) (SETQ SPECIAL-LOCALS-HERE T)) (COND (IL:* IL:|;;| "This parameter is set to NIL.") ((AND (LITERAL-P ARG) (EQ NIL (LITERAL-VALUE ARG))) (IF (EQ :LEXICAL (VARIABLE-SCOPE PARAM)) (EMIT-LAP-LIST `((:CONST NIL) (:VAR_ ,(MAKE-LAP-VAR PARAM)) (:POP))) (PUSH PARAM NULL-PARAMS))) (IL:* IL:|;;| "This parameter is bound to the result of a non-null expression") (T (GENCODE ARG :ARGUMENT) (IF (EQ :LEXICAL (VARIABLE-SCOPE PARAM)) (EMIT-LAP-LIST `((:VAR_ ,(MAKE-LAP-VAR PARAM)) (:POP))) (PUSH PARAM NON-NULL-PARAMS))))) (SETQ NULL-PARAMS (MAPCAR #'MAKE-LAP-VAR NULL-PARAMS)) (SETQ NON-NULL-PARAMS (NREVERSE (MAPCAR #'MAKE-LAP-VAR NON-NULL-PARAMS))) (IL:* IL:|;;| "Bind the variables and evaluate the body") (WHEN (OR NULL-PARAMS NON-NULL-PARAMS) (EMIT-LAP `(:BIND ,NON-NULL-PARAMS ,NULL-PARAMS ,STK-NUM))) (INTERCEPT-NON-LOCALS (DELETE-IF #'(LAMBDA (VAR) (EQ (VARIABLE-BINDER VAR) FN)) *NON-LOCALS*) (IL:* IL:|;;| "!!HACK!! Fix this silliness once the compiler can use lexical closures.") (LET* ((*SPECIAL-LOCALS-BOUND* (OR *SPECIAL-LOCALS-BOUND* SPECIAL-LOCALS-HERE))) (IL:* IL:|;;| "If we've done a BIND, then we need to make it possible for the tail-recursion optimization to generate a DUNBIND. Otherwise, things are simpler.") (IF (OR NULL-PARAMS NON-NULL-PARAMS) (LET* ((UNBIND-INST `(:DUNBIND ,NON-NULL-PARAMS ,NULL-PARAMS ,STK-NUM)) (UNBIND-FN `(LAMBDA (CONDITION) (DECLARE (IGNORE CONDITION)) (EMIT-LAP ',UNBIND-INST)))) (CONDITION-BIND ((UNBIND-FOR-TAIL-RECURSION UNBIND-FN)) (GENCODE (LAMBDA-BODY FN) CONTEXT))) (GENCODE (LAMBDA-BODY FN) CONTEXT)))) (IL:* IL:|;;| "Again, we only need to UNBIND if we generated a BIND earlier.") (WHEN (OR NULL-PARAMS NON-NULL-PARAMS) (ECASE CONTEXT ((:EFFECT) (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP `(:DUNBIND ,NON-NULL-PARAMS ,NULL-PARAMS ,STK-NUM)))) ((:ARGUMENT :MV) (EMIT-LAP `(:UNBIND ,NON-NULL-PARAMS ,NULL-PARAMS ,STK-NUM))) ((:RETURN) ))) (IL:* IL:|;;| "Finally, we know that these variables aren't in use any more, so we can put their names on *AVAILABLE-LEXICAL-NAMES*.") (IL:FOR PARAM IL:IN (LAMBDA-REQUIRED FN) IL:WHEN (AND (EQ :LEXICAL ( VARIABLE-SCOPE PARAM)) (NOT (VARIABLE-CLOSED-OVER PARAM))) IL:DO (PUSH (THIRD (VARIABLE-LAP-VAR PARAM)) *AVAILABLE-LEXICAL-NAMES*)))) (DEFUN GENCODE-LITERAL (NODE CONTEXT) (ECASE CONTEXT (:EFFECT (IL:* IL:\; "Do nothing.")) ((:ARGUMENT :RETURN) (EMIT-LAP `(:CONST ,(LITERAL-VALUE NODE)))) (:MV (IL:* IL:\; "In MV context, we need to make this a list. Because MV-CALL uses NCONC to put the lists together, we have to CONS a fresh cell here.") (EMIT-LAP-LIST `((:CONST ,(LITERAL-VALUE NODE)) (:CONST NIL) (:CALL CONS 2)))))) (DEFUN GENCODE-MV-CALL (NODE CONTEXT) (LET ((FN (MV-CALL-FN NODE)) (ARGS (MV-CALL-ARG-EXPRS NODE))) (FLET ((GENERATE-VALUES NIL (IL:* IL:|;;|  "Generate the code for putting the list of values on the top-of-stack.") (GENCODE (FIRST ARGS) :MV) (IL:|for| ARG IL:|in| (REST ARGS) IL:|do| (GENCODE ARG :MV) (EMIT-LAP '(:CALL IL:\\NCONC2 2))))) (COND ((AND (GLOBAL-FUNCTION-P FN) (EQ (VARIABLE-NAME (VAR-REF-VARIABLE FN)) 'LIST)) (IL:* IL:\; "This is a use of MULTIPLE-VALUE-LIST, the only use of multiple-values that XCL can do reasonably well.") (IL:* IL:|;;| "we can do better here - if we're in effect context, there's no reason to do all this consing and we should just treat this as a PROGN.") (GENERATE-VALUES)) (T (IF (GLOBAL-FUNCTION-P FN) (EMIT-LAP `(:CONST ,(VARIABLE-NAME (VAR-REF-VARIABLE FN)))) (GENCODE FN :ARGUMENT)) (GENERATE-VALUES) (EMIT-LAP '(:CALL APPLY 2)))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (EMIT-LAP '(:CALL IL:\\MVLIST 1))))))) (DEFUN GENCODE-MV-PROG1 (NODE CONTEXT) (ECASE CONTEXT ((:MV :RETURN) (IL:* IL:\;  "All other contexts should have been meta-eval'ed away.") (DESTRUCTURING-BIND (VALUES-FORM . EFFECT-FORMS) (MV-PROG1-STMTS NODE) (IL:* IL:|;;|  "Save the values from the first statement on the stack while we evaluate the rest of the values.") (GENCODE VALUES-FORM :MV) (IL:FOR FORM IL:IN EFFECT-FORMS IL:DO (GENCODE FORM :EFFECT)) (WHEN (EQ CONTEXT :RETURN) (EMIT-LAP '(:CALL VALUES-LIST 1))))))) (DEFUN GENCODE-OPCODES (NODE CONTEXT) (DECLARE (IGNORE NODE CONTEXT)) (ASSERT NIL NIL "BUG: GENCODE-OPCODES was called!")) (DEFUN GENCODE-PROGN (NODE CONTEXT) (LET ((*SUPPRESS-POPS* (AND *POP-SUPPRESSION-POLICY* (EQ CONTEXT :RETURN)))) (IL:FOR TAIL IL:ON (PROGN-STMTS NODE) IL:DO (GENCODE (CAR TAIL) (IF (NULL (CDR TAIL)) CONTEXT :EFFECT))))) (DEFUN GENCODE-PROGV (&REST IGNORE) (ASSERT NIL NIL "BUG: GENCODE-PROGV was called.")) (DEFUN GENCODE-RETURN (NODE CONTEXT) (LET ((BLOCK (RETURN-BLOCK NODE))) (COND ((EQ *CURRENT-FRAME* (BLOCK-FRAME BLOCK)) (IL:* IL:|;;| "The block is local; a simple stack adjustment and jump will suffice.") (GENCODE (RETURN-VALUE NODE) (BLOCK-CONTEXT BLOCK)) (COND ((BLOCK-NEW-FRAME-P BLOCK) (IL:* IL:|;;| "This RETURN is returning from the frame itself, rather than from a block internal to a frame. Don't need the stack adjustment.") (IL:* IL:|;;| "JDS 1/26/89 I think this is correct.") (ECASE (BLOCK-CONTEXT BLOCK) ((:EFFECT) (EMIT-LAP-LIST `((:JUMP ,(BLOCK-END-TAG BLOCK))))) ((:ARGUMENT :MV) (EMIT-LAP-LIST `((:JUMP ,(BLOCK-END-TAG BLOCK))))) ((:RETURN) (EMIT-LAP '(:RETURN))))) (T (ECASE (BLOCK-CONTEXT BLOCK) ((:EFFECT) (EMIT-LAP-LIST `((:DSET-STACK ,(BLOCK-STK-NUM BLOCK)) (:JUMP ,(BLOCK-END-TAG BLOCK))))) ((:ARGUMENT :MV) (EMIT-LAP-LIST `((:SET-STACK ,(BLOCK-STK-NUM BLOCK)) (:JUMP ,(BLOCK-END-TAG BLOCK))))) ((:RETURN) (EMIT-LAP '(:RETURN))))))) (T (IL:* IL:|;;| "The block is remote; call on the unwinder.") (EMIT-LAP `(:VAR ,(VARIABLE-LAP-VAR (BLOCK-BLIP-VAR BLOCK)))) (ECASE (BLOCK-CONTEXT BLOCK) (:EFFECT (GENCODE (RETURN-VALUE NODE) :EFFECT) (EMIT-LAP '(:CALL SI::NON-LOCAL-RETURN 1))) ((:MV :ARGUMENT) (GENCODE (RETURN-VALUE NODE) (BLOCK-CONTEXT BLOCK)) (EMIT-LAP '(:CALL SI::NON-LOCAL-RETURN 2))) (:RETURN (GENCODE (RETURN-VALUE NODE) :MV) (EMIT-LAP '(:CALL SI::NON-LOCAL-RETURN-VALUES 2)))) (EMIT-LAP `(:RETURN)) (IL:* IL:\;  "This :RETURN will never be reached, but it makes stack analysis happier.") (PUSH (BLOCK-BLIP-VAR BLOCK) *NON-LOCALS*))))) (DEFUN GENCODE-SEGMENT (SEGMENT) (LET ((*SUPPRESS-POPS* NIL)) (EMIT-LAP `(:TAG ,(SEGMENT-LOCAL-TAG SEGMENT))) (DOLIST (STMT (SEGMENT-STMTS SEGMENT)) (GENCODE STMT :EFFECT)))) (DEFUN GENCODE-SETQ (NODE CONTEXT) (ASSERT (NOT (EQ (VARIABLE-KIND (SETQ-VAR NODE)) :FUNCTION)) '(NODE) "BUG: Attempt to set a function variable.") (GENCODE (SETQ-VALUE NODE) :ARGUMENT) (EMIT-LAP `(:VAR_ ,(MAKE-LAP-VAR-REFERENCE (SETQ-VAR NODE)))) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (IL:* IL:\;  "In MV context, we have to return a list of values.") (EMIT-LAP-LIST '((:CONST NIL) (:CALL CONS 2)))))) (DEFUN GENCODE-TAGBODY (NODE CONTEXT) (IL:* IL:|;;;| "Very much like the BLOCK case. Sometimes we need to make a function call but usually we can avoid it to some degree.") (COND ((TAGBODY-NEW-FRAME-P NODE) (IL:* IL:\;  "Construct a new lambda for the tagbody") (LET (NEW-LAMBDA) (FRAME (:CURRENT-FRAME NODE :NAME (FORMAT NIL "tagbody in ~A" *FRAME-NAME*)) (LET ((STK-NUM (INCF *STACK-NUMBER*)) BLIP-GO-VAR OUR-NON-LOCALS) (SETF (TAGBODY-FRAME NODE) *CURRENT-FRAME*) (SETF (TAGBODY-STK-NUM NODE) STK-NUM) (COND ((TAGBODY-CLOSED-OVER-P NODE) (SETQ *BLIP-VAR* `(:S SI::*CATCH-RETURN-FROM* ,(INCF *VAR-NUMBER*))) (SETQ BLIP-GO-VAR (MAKE-LAP-VAR (TAGBODY-BLIP-VAR NODE))) (EMIT-LAP-LIST `((:CONST ,*FRAME-NAME*) (:CONST NIL) (:CALL CONS 2) (:VAR_ ,*BLIP-VAR*) (:VAR_ ,BLIP-GO-VAR) (:POP))) (SETQ *OTHERS* (LIST BLIP-GO-VAR *BLIP-VAR*))) (T (SETQ *BLIP-VAR* `(:S SI::*CATCH-RETURN-TO* ,(INCF *VAR-NUMBER*))) (SETQ *OTHERS* (LIST *BLIP-VAR*)))) (EMIT-LAP `(:NOTE-STACK ,STK-NUM)) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (SETF (SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER*)) (WHEN (SEGMENT-CLOSED-OVER-P SEGMENT) (SETF (SEGMENT-REMOTE-TAG SEGMENT) (INCF *TAG-NUMBER*)))) (INTERCEPT-NON-LOCALS (SETQ OUR-NON-LOCALS (DELETE (TAGBODY-BLIP-VAR NODE) *NON-LOCALS*)) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (  GENCODE-SEGMENT SEGMENT))) (IF (EQ CONTEXT :MV) (IL:* IL:\; "In MV context, we have to return a list of values. We have to CONS it freshly since MV-CALL uses NCONC to put the lists together.") (EMIT-LAP-LIST '((:CONST NIL) (:CONST NIL) (:CALL CONS 2) (:RETURN))) (EMIT-LAP-LIST '((:CONST NIL) (:RETURN)))) (WHEN (TAGBODY-CLOSED-OVER-P NODE) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:WHEN ( SEGMENT-CLOSED-OVER-P SEGMENT) IL:DO (EMIT-LAP-LIST `((:TAG ,(SEGMENT-REMOTE-TAG SEGMENT)) (:DSET-STACK ,STK-NUM) (:JUMP ,(SEGMENT-LOCAL-TAG SEGMENT)))))) (SETQ NEW-LAMBDA `(:LAMBDA (NIL :NAME ,*FRAME-NAME* ,@(AND *OTHERS* `(:OTHERS ,*OTHERS*)) :BLIP ,*BLIP-VAR* ,@(AND OUR-NON-LOCALS `(:NON-LOCAL ,(MAPCAR #'VARIABLE-LAP-VAR OUR-NON-LOCALS))) ,@(AND (TAGBODY-CLOSED-OVER-VARS NODE) `(:CLOSED-OVER ,(MAPCAR #'VARIABLE-LAP-VAR ( TAGBODY-CLOSED-OVER-VARS NODE)))) ,@(AND *LOCAL-FUNCTIONS* `(:LOCAL-FUNCTIONS ,*LOCAL-FUNCTIONS*))) ,@(END-LAP))))) (IL:* IL:|;;| "Generate a call to the new lambda.") (EMIT-LAP `(:CALL ,NEW-LAMBDA 0)) (WHEN (AND (EQ CONTEXT :EFFECT) (NOT *SUPPRESS-POPS*)) (EMIT-LAP '(:POP))))) (T (IF (NULL (TAGBODY-CLOSED-OVER-VARS NODE)) (GENCODE-TAGBODY-INLINE NODE CONTEXT) (LET ((CODE (LET ((*CODE* (START-LAP))) (GENCODE-TAGBODY-INLINE NODE CONTEXT) (END-LAP)))) (EMIT-LAP `(:CLOSE ,(MAPCAR #'VARIABLE-LAP-VAR (TAGBODY-CLOSED-OVER-VARS NODE)) ,@CODE))))))) (DEFUN GENCODE-TAGBODY-INLINE (NODE CONTEXT) (IL:* IL:|;;| "We don't need a separate frame, so generate the code inline, setting up and taking down the blip stuff if necessary.") (LET ((STK-NUM (INCF *STACK-NUMBER*))) (SETF (TAGBODY-FRAME NODE) *CURRENT-FRAME*) (SETF (TAGBODY-STK-NUM NODE) STK-NUM) (COND ((TAGBODY-CLOSED-OVER-P NODE) (LET ((BLIP-VAR (MAKE-LAP-VAR (TAGBODY-BLIP-VAR NODE))) (END-TAG (INCF *TAG-NUMBER*))) (SET-UP-RETURN-TO) (EMIT-LAP-LIST `((:CONST TAGBODY) (:CONST ,*FRAME-NAME*) (:CALL CONS 2) (:VAR_ ,*BLIP-VAR*) (:VAR_ ,BLIP-VAR) (:POP) (:NOTE-STACK ,STK-NUM))) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (SETF (SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER*)) (WHEN (SEGMENT-CLOSED-OVER-P SEGMENT) (SETF (SEGMENT-REMOTE-TAG SEGMENT) (INCF *TAG-NUMBER*)))) (INTERCEPT-NON-LOCALS (DELETE (TAGBODY-BLIP-VAR NODE) *NON-LOCALS*) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (GENCODE-SEGMENT SEGMENT))) (TAKE-DOWN-RETURN-TO) (EMIT-LAP `(:JUMP ,END-TAG)) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:WHEN ( SEGMENT-CLOSED-OVER-P SEGMENT) IL:DO (EMIT-LAP-LIST `((:TAG ,(SEGMENT-REMOTE-TAG SEGMENT)) (:DSET-STACK ,STK-NUM) (:JUMP ,(SEGMENT-LOCAL-TAG SEGMENT))))) (EMIT-LAP `(:TAG ,END-TAG)))) (T (IL:* IL:\;  "Simplest case: the tagbody isn't even closed over.") (EMIT-LAP `(:NOTE-STACK ,STK-NUM)) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (SETF ( SEGMENT-LOCAL-TAG SEGMENT) (INCF *TAG-NUMBER* ))) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (GENCODE-SEGMENT SEGMENT)))) (IL:* IL:|;;| "Arrange to return NIL from the TAGBODY.") (ECASE CONTEXT (:EFFECT (IL:* IL:\; "Do nothing")) ((:ARGUMENT :RETURN) (EMIT-LAP '(:CONST NIL))) (:MV (IL:* IL:\;  "In MV context, we have to return a freshly-CONSed list of values.") (EMIT-LAP-LIST '((:CONST NIL) (:CONST NIL) (:CALL CONS 2))))))) (DEFUN GENCODE-THROW (NODE CONTEXT) (GENCODE (THROW-TAG NODE) :ARGUMENT) (CASE CONTEXT ((:ARGUMENT :RETURN) (GENCODE (THROW-VALUE NODE) CONTEXT) (EMIT-LAP-LIST '((:CALL SI::INTERNAL-THROW 2) (:RETURN)))) (OTHERWISE (GENCODE (THROW-VALUE NODE) :MV) (EMIT-LAP-LIST '((:CALL SI::INTERNAL-THROW-VALUES 2) (:RETURN))) (IL:* IL:\;  "The :RETURN will never be reached, but it makes stack-analysis happier.") ))) (DEFUN GENCODE-UNWIND-PROTECT (NODE CONTEXT) (IL:* IL:|;;;| "Funcall the body on the argument of the cleanup forms as a closure.") (GENCODE (UNWIND-PROTECT-CLEANUP NODE) :ARGUMENT) (LET ((STMT-CODE (COLLECT-CODE (UNWIND-PROTECT-STMT NODE) :ARGUMENT))) (EMIT-LAP `(:CALL ,(POP STMT-CODE) 1)) (ASSERT (NULL STMT-CODE) NIL "BUG: unwind-protect body code generated more than one LAP instruction")) (CASE CONTEXT (:EFFECT (WHEN (NOT *SUPPRESS-POPS*) (EMIT-LAP '(:POP)))) (:MV (EMIT-LAP '(:CALL IL:\\MVLIST 1))))) (DEFUN GENCODE-VAR-REF (NODE CONTEXT) (LET ((VAR (VAR-REF-VARIABLE NODE))) (UNLESS (EQ CONTEXT :EFFECT) (IF (AND (EQ :GLOBAL (VARIABLE-SCOPE VAR)) (EQ :FUNCTION (VARIABLE-KIND VAR))) (EMIT-LAP-LIST `((:CONST ,(VARIABLE-NAME VAR)) (:CALL SYMBOL-FUNCTION 1))) (EMIT-LAP `(:VAR ,(MAKE-LAP-VAR-REFERENCE VAR)))) (WHEN (EQ CONTEXT :MV) (IL:* IL:\;  "In MV context, we have to return a list of the values.") (EMIT-LAP-LIST '((:CONST NIL) (:CALL CONS 2))))))) (IL:* IL:|;;| "Policy variables.") (DEFPARAMETER *POP-SUPPRESSION-POLICY* NIL "If this is non-NIL, the code generator will suppress unnecessary pops. This can increase stack usage." ) (DEFVAR *TAIL-RECURSION-POLICY* T "Set this to NIL to disable the tail-recursion optimization.") (IL:* IL:|;;| "Testing Code Generation") (DEFUN TEST-GENCODE (FN) (PPRINT (TEST-GENCODE1 FN)) (FRESH-LINE) (VALUES)) (DEFUN TEST-GENCODE1 (FN) (DESTRUCTURING-BIND (IGNORE NAME ARG-LIST &BODY BODY) (IL:GETDEF FN 'IL:FUNCTIONS) (MULTIPLE-VALUE-BIND (FORMS DECLS) (PARSE-BODY BODY NIL T) (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV T)) (*PROCESSED-FUNCTIONS* NIL) (*UNKNOWN-FUNCTIONS* NIL) (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE))) (COMPILE-ONE-LAMBDA FN `(LAMBDA ,ARG-LIST ,@DECLS (BLOCK ,NAME ,@FORMS))))))) (IL:* IL:|;;| "Arrange to use the correct compiler.") (IL:PUTPROPS IL:XCLC-GENCODE IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange to use the proper makefile environment") (IL:PUTPROPS IL:XCLC-GENCODE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-GENCODE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-META-EVAL b/sources/XCLC-META-EVAL new file mode 100644 index 00000000..3f21e304 --- /dev/null +++ b/sources/XCLC-META-EVAL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED " 9-Dec-91 03:12:25" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-META-EVAL.;5| 67183 IL:|changes| IL:|to:| (IL:FUNCTIONS META-EVAL-LABELS) IL:|previous| IL:|date:| "16-Aug-91 18:47:02" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-META-EVAL.;4|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-META-EVALCOMS) (IL:RPAQQ IL:XCLC-META-EVALCOMS ( (IL:* IL:|;;;| "Meta-evaluation") (IL:FUNCTIONS META-EVALUATE) (IL:FUNCTIONS MEVAL MEVAL-LIST REDO-MEVAL) (IL:FUNCTIONS REMOVE-NESTED-PROGNS EXPAND-NESTED-PROGNS) (IL:FUNCTIONS GLOBAL-FUNCTION-P) (IL:FUNCTIONS CONSTRUCT-PROG1-TREE) (IL:VARIABLES *MADE-CHANGES* *REDOING-ANALYSIS*) (IL:FUNCTIONS META-EVAL-BLOCK META-EVAL-CALL META-EVAL-CATCH META-EVAL-GO META-EVAL-IF META-EVAL-LABELS META-EVAL-LAMBDA META-EVAL-LITERAL META-EVAL-MV-CALL META-EVAL-MV-PROG1 META-EVAL-OPCODES META-EVAL-PROGN META-EVAL-PROGV META-EVAL-RETURN META-EVAL-SETQ META-EVAL-TAGBODY META-EVAL-THROW META-EVAL-UNWIND-PROTECT META-EVAL-VAR-REF) (IL:FUNCTIONS META-CALL-LAMBDA META-CALL-LAMBDA-SIMPLIFY-PARAMETERS CONSTRUCT-LIST) (IL:* IL:|;;;| "Meta-substitution") (IL:FUNCTIONS META-CALL-LAMBDA-SUBSTITUTE META-CALL-LABELS META-SUBSTITUTE META-SUBST) (IL:FUNCTIONS MSUBST MSUBST-LIST) (IL:FUNCTIONS SUBSTITUTABLE-P) (IL:FUNCTIONS EFFECTLESS EFFECTLESS-EXCEPT-CONS NULL-INTERSECTION NULL-EFFECTS-INTERSECTION NULL-EFFECTS-INTERSECTION-EXCEPT-CONS PASSABLE NONLOCAL-VARIABLE-EFFECT-P COLLECT-NONLOCAL-VAR-EFFECTS) (IL:VARIABLES *SUBST-VAR* *SUBST-EXPR* *SUBST-OCCURRED*) (IL:FUNCTIONS META-SUBST-BLOCK META-SUBST-CALL META-SUBST-CATCH META-SUBST-GO META-SUBST-IF META-SUBST-LABELS META-SUBST-LAMBDA META-SUBST-LITERAL META-SUBST-MV-CALL META-SUBST-MV-PROG1 META-SUBST-OPCODES META-SUBST-PROGN META-SUBST-PROGV META-SUBST-RETURN META-SUBST-SETQ META-SUBST-TAGBODY META-SUBST-THROW META-SUBST-UNWIND-PROTECT META-SUBST-VAR-REF) (IL:FUNCTIONS META-SUBST-ANY-CALL META-SUBST-STMTS) (IL:* IL:|;;| "Testing meta-evaluation") (IL:FUNCTIONS TEST-META-EVAL) (IL:* IL:|;;| "Arrange to use the correct compiler") (IL:PROP IL:FILETYPE IL:XCLC-META-EVAL) (IL:* IL:|;;| "Arrange for the proper makefile-environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-META-EVAL))) (IL:* IL:|;;;| "Meta-evaluation") (DEFUN META-EVALUATE (TREE &OPTIONAL (CONTEXT :ARGUMENT)) (IL:* IL:|;;;| "Each meta-evaluation method takes in a subtree and mungs on it for a while, returning a (possibly identical) subtree. If the method makes no changes or can otherwise guarantee that no further meta-evaluation will be useful, it should set the meta-p field to the current context. This field must never be set if any node lower in the tree does not have it set. You can count on the fact that no node gets returned by meta-evaluate unless it has that field set.") (IL:* IL:|;;;| "The CONTEXT argument has one of the following values:") (IL:* IL:|;;;| ":effect -- No values of this expression are used.") (IL:* IL:|;;;| ":argument -- Exactly one of the values of this expression is used.") (IL:* IL:|;;;| ":mv -- More than one of the values of this expression may be used.") (IL:* IL:|;;;| ":return -- The value(s) of this expression will be returned to the caller of the current function.") (WHEN *REDOING-ANALYSIS* (SETF (NODE-META-P TREE) NIL)) (IL:UNTIL (EQ CONTEXT (NODE-META-P TREE)) IL:DO (SETQ TREE (NODE-DISPATCH META-EVAL TREE CONTEXT))) TREE) (DEFINE-MODIFY-MACRO MEVAL (CONTEXT) META-EVALUATE) (DEFMACRO MEVAL-LIST (LIST-EXPR CONTEXT &OPTIONAL KEY-FN) `(IL:FOR TAIL IL:ON ,LIST-EXPR IL:DO (MEVAL ,(IF KEY-FN `(,KEY-FN (CAR TAIL)) '(CAR TAIL)) ,CONTEXT))) (DEFMACRO REDO-MEVAL (NODE-EXPR CONTEXT) `(LET ((*REDOING-ANALYSIS* T)) (MEVAL ,NODE-EXPR ,CONTEXT))) (DEFINE-MODIFY-MACRO REMOVE-NESTED-PROGNS () EXPAND-NESTED-PROGNS (IL:* IL:|;;;| "Replace the list of nodes in a given place with another list that has had its nested progns spliced inline. It is assumed that the nested PROGN nodes will not be referred to afterwards; this operation uses NCONC to splice the lists together.") ) (DEFUN EXPAND-NESTED-PROGNS (NODE-LIST) (IL:FOR NODE IL:IN NODE-LIST IL:JOIN (IF (PROGN-P NODE) (PROGN-STMTS NODE) (LIST NODE)))) (DEFINLINE GLOBAL-FUNCTION-P (NODE) (AND (VAR-REF-P NODE) (LET ((VAR (VAR-REF-VARIABLE NODE))) (AND (EQ :GLOBAL (VARIABLE-SCOPE VAR)) (EQ :FUNCTION (VARIABLE-KIND VAR)))))) (DEFUN CONSTRUCT-PROG1-TREE (FIRST REST) (IL:* IL:|;;;| "Return a tree that represents a PROG1 in which FIRST's values are the ones that are wanted:") (IL:* IL:|;;;| " ((lambda (x) ,@REST x) FIRST)") (LET* ((PROG1-VAR (MAKE-VARIABLE)) (PROG1-VAR-REF (MAKE-VAR-REF :VARIABLE PROG1-VAR)) (NEW-LAMBDA (MAKE-LAMBDA :REQUIRED (LIST PROG1-VAR) :BODY (MAKE-PROGN :STMTS (APPEND REST (LIST PROG1-VAR-REF)))))) (SETF (VARIABLE-BINDER PROG1-VAR) NEW-LAMBDA) (PUSH PROG1-VAR-REF (VARIABLE-READ-REFS PROG1-VAR)) (MAKE-CALL :FN NEW-LAMBDA :ARGS (LIST FIRST)))) (DEFVAR *MADE-CHANGES* NIL (IL:* IL:|;;;| "This variable is rebound in a few places in meta-evaluation in order to keep track of whether or not a large collection of routines has had any effect on the program tree.") ) (DEFVAR *REDOING-ANALYSIS* NIL (IL:* IL:|;;;| "Bound to T when meta-evaluation is being redone. This forces the analysis to descend all the way back down to the bottom again.") ) (DEFUN META-EVAL-BLOCK (NODE CONTEXT) (SETF (BLOCK-CONTEXT NODE) CONTEXT) (MEVAL (BLOCK-STMT NODE) CONTEXT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-CALL (NODE CONTEXT) (IL:* IL:|;;| "First, meta-eval the subtrees.") (MEVAL (CALL-FN NODE) :ARGUMENT) (MEVAL-LIST (CALL-ARGS NODE) :ARGUMENT) (ANALYZE-TREE NODE) (LET ((FN (CALL-FN NODE)) TRANSFORM ARGS EVAL-WHEN-LOAD? LIST-OF-VALUES) (COND (IL:* IL:|;;| "Then, if it's a lambda-call, try hacking on it.") ((LAMBDA-P FN) (IL:* IL:|;;| "But first, re-meta-evaluate the lambda-body since we now know the context in which it will be evaluated.") (UNLESS (EQ CONTEXT :RETURN) (MEVAL (LAMBDA-BODY FN) CONTEXT) (ANALYZE-TREE FN)) (SETQ NODE (META-CALL-LAMBDA NODE CONTEXT))) (IL:* IL:|;;|  "If it's a call to a side-effect-less function in effect context, blow it away.") (IL:* IL:|;;| "Fix this to find local function side-effects.") ((AND (EQ CONTEXT :EFFECT) (NOT (CALLER-NOT-INLINE NODE)) (GLOBAL-FUNCTION-P FN) (LET ((EFFECTS (CAR (SIDE-EFFECTS (VARIABLE-NAME (VAR-REF-VARIABLE FN)))))) (OR (EQ EFFECTS :NONE) (EQUAL EFFECTS '(:CONS))))) (SETQ NODE (PROG1 (MAKE-PROGN :STMTS (CALL-ARGS NODE)) (SETF (CALL-ARGS NODE) NIL) (IL:* IL:\;  "Detach the args, since they're still in the tree.") (RELEASE-TREE NODE)))) (IL:* IL:|;;| "If it's a constant-foldable function and the arguments are all literals, fold it. We must be careful because some of the literals might be EVAL-WHEN-LOAD objects. In that case, we bring the entire call inside a new EVAL-WHEN-LOAD. This accomplishes, in effect, load-time constant-folding.") ((AND (NOT (CALLER-NOT-INLINE NODE)) (GLOBAL-FUNCTION-P FN) (EQUAL '(:NONE . :NONE) (SIDE-EFFECTS (VARIABLE-NAME (VAR-REF-VARIABLE FN)))) (LISTP (SETQ ARGS (IL:FOR ARG IL:IN (CALL-ARGS NODE) IL:COLLECT (IF (NOT (LITERAL-P ARG)) (RETURN T) (LET ((VALUE (LITERAL-VALUE ARG))) (WHEN (EVAL-WHEN-LOAD-P VALUE) (SETQ EVAL-WHEN-LOAD? T)) VALUE))))) (OR (EQ CONTEXT :ARGUMENT) (NOT EVAL-WHEN-LOAD?))) (LET ((FN-NAME (VARIABLE-NAME (VAR-REF-VARIABLE FN)))) (RELEASE-TREE NODE) (COND ((EQ CONTEXT :ARGUMENT) (SETQ NODE (MAKE-LITERAL :VALUE (IF EVAL-WHEN-LOAD? (MAKE-EVAL-WHEN-LOAD :FORM `(,FN-NAME ,@(IL:FOR ARG IL:IN ARGS IL:COLLECT (IF (EVAL-WHEN-LOAD-P ARG) (EVAL-WHEN-LOAD-FORM ARG) `',ARG)))) (APPLY FN-NAME ARGS))))) (IL:* IL:|;;| "We're in either :RETURN or :MV context and the expression doesn't include any EVAL-WHEN-LOAD forms.") ((NULL (CDR (SETQ LIST-OF-VALUES (MULTIPLE-VALUE-LIST (APPLY FN-NAME ARGS))))) (IL:* IL:|;;| "The form does not return multiple values.") (SETQ NODE (MAKE-LITERAL :VALUE (CAR LIST-OF-VALUES)))) (T (IL:* IL:|;;|  "The form does return multiple values. Turn it into a call on VALUES-LIST.") (SETQ NODE (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :NAME 'VALUES-LIST :KIND :FUNCTION :SCOPE :GLOBAL) :ARGS (LIST (MAKE-LITERAL :VALUE LIST-OF-VALUES)))))))) (IL:* IL:|;;| "If there's a function-specific transformation defined for it, give it a try.") ((AND (NOT (CALLER-NOT-INLINE NODE)) (GLOBAL-FUNCTION-P FN) (SETQ TRANSFORM (GET (VARIABLE-NAME (VAR-REF-VARIABLE FN)) 'TRANSFORM))) (SETQ NODE (FUNCALL TRANSFORM NODE CONTEXT))) (IL:* IL:|;;| "Nothing to do, so we must be done.") (T (SETF (NODE-META-P NODE) CONTEXT))) NODE)) (DEFUN META-EVAL-CATCH (NODE CONTEXT) (MEVAL (CATCH-TAG NODE) :ARGUMENT) (MEVAL (CATCH-STMT NODE) CONTEXT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-GO (NODE CONTEXT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-IF (NODE CONTEXT) (MEVAL (IF-PRED NODE) :ARGUMENT) (MEVAL (IF-THEN NODE) CONTEXT) (MEVAL (IF-ELSE NODE) CONTEXT) (ANALYZE-TREE NODE) (IL:* IL:|;;| "If the predicate is a literal, we can eliminate one of the arms.") (WHEN (LITERAL-P (IF-PRED NODE)) (RETURN-FROM META-EVAL-IF (COND ((LITERAL-VALUE (IF-PRED NODE)) (RELEASE-TREE (IF-ELSE NODE)) (IF-THEN NODE)) (T (RELEASE-TREE (IF-THEN NODE)) (IF-ELSE NODE))))) (IL:* IL:|;;| "If both arms turned into literals and we're in effect context, then the only thing left is the predicate.") (WHEN (AND (EQ CONTEXT :EFFECT) (LITERAL-P (IF-THEN NODE)) (LITERAL-P (IF-ELSE NODE))) (RETURN-FROM META-EVAL-IF (IF-PRED NODE))) (IL:* IL:|;;| "If both arms have no side-effects and we're in effect context, then the only thing left is the predicate.") (WHEN (AND (EQ CONTEXT :EFFECT) (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS (IF-THEN NODE))) (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS (IF-ELSE NODE)))) (RETURN-FROM META-EVAL-IF (IF-PRED NODE))) (IL:* IL:|;;|  "If the IF has the form (IF (IF pred NIL T) then else) then reduce to (IF pred else then).") (LET ((PRED (IF-PRED NODE))) (WHEN (AND (IF-P PRED) (LITERAL-P (IF-THEN PRED)) (EQ NIL (LITERAL-VALUE (IF-THEN PRED))) (LITERAL-P (IF-ELSE PRED)) (EQ T (LITERAL-VALUE (IF-ELSE PRED)))) (SETF (IF-PRED NODE) (IF-PRED PRED)) (ROTATEF (IF-THEN NODE) (IF-ELSE NODE)))) (IL:* IL:|;;| "Nothing worked, so give up.") (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-LABELS (NODE CONTEXT) (IL:* IL:|;;| "First, meta-eval the subtrees: The bodies of the FLET/LABELS-d functions must be meta-evaled first, so we get the side-effects info for meta-evaluating the body correctly (e.g., to detect effect-free FLETd fns in effect context). This fixes AR 11447 JDS 12/8/91") (MEVAL-LIST (LABELS-FUNS NODE) :ARGUMENT CDR) (MEVAL (LABELS-BODY NODE) CONTEXT) (ANALYZE-TREE NODE) (IL:* IL:|;;| "Now try to substitute the local functions into the body.") (SETQ NODE (META-CALL-LABELS NODE CONTEXT)) NODE) (DEFUN META-EVAL-LAMBDA (NODE CONTEXT) (WHEN (EQ CONTEXT :EFFECT) (IL:* IL:\;  "LAMBDA's have no side effects.") (RELEASE-TREE NODE) (RETURN-FROM META-EVAL-LAMBDA *LITERALLY-NIL*)) (MEVAL (LAMBDA-BODY NODE) :RETURN) (MEVAL-LIST (LAMBDA-OPTIONAL NODE) :ARGUMENT SECOND) (MEVAL-LIST (LAMBDA-KEYWORD NODE) :ARGUMENT THIRD) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-LITERAL (NODE CONTEXT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-MV-CALL (NODE CONTEXT) (IL:* IL:|;;;| "Come back to this. If all of the arg-exprs can be guaranteed to return a single value each, we can transform this in to a normal function call. Unfortunately, the information about how many values something might return is not passed up the tree.") (MEVAL (MV-CALL-FN NODE) :ARGUMENT) (WHEN (LAMBDA-P (MV-CALL-FN NODE)) (IL:* IL:|;;| "If the function is a LAMBDA, we should redo the analysis of the body because we now know the context in which it will be evaluated.") (MEVAL (LAMBDA-BODY (MV-CALL-FN NODE)) CONTEXT) (ANALYZE-TREE (MV-CALL-FN NODE))) (MEVAL-LIST (MV-CALL-ARG-EXPRS NODE) :MV) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-MV-PROG1 (NODE CONTEXT) (LET ((STMTS (MV-PROG1-STMTS NODE))) (MEVAL (FIRST STMTS) CONTEXT) (MEVAL-LIST (REST STMTS) :EFFECT) (REMOVE-NESTED-PROGNS (REST STMTS)) (ECASE CONTEXT (:EFFECT (IL:* IL:\;  "In effect context, we transform the MV-PROG1 into a simple PROGN.") (MAKE-PROGN :STMTS STMTS)) (:ARGUMENT (IL:* IL:\;  "If multiple-values aren't wanted, turn this into a normal PROG1:") (CONSTRUCT-PROG1-TREE (FIRST STMTS) (REST STMTS))) ((:RETURN :MV) (IL:* IL:\;  "Oh, well, it's MV context after all. We can still try one last thing, though.") (SETF (NODE-META-P NODE) CONTEXT) (WHEN (PROGN-P (FIRST STMTS)) (IL:* IL:\;  "Transform MV-PROG1 of PROGN into PROGN of MV-PROG1") (ROTATEF NODE (FIRST STMTS) (CAR (LAST (PROGN-STMTS (FIRST STMTS)))))) NODE)))) (DEFUN META-EVAL-OPCODES (NODE CONTEXT) (IL:* IL:|;;;| "Go ahead. Meta-evaluate these opcodes. I dare you.") (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-PROGN (NODE CONTEXT) (IL:* IL:|;;;| "Meta-evaluate the subtrees and then eliminate any nested PROGN's.") (IL:FOR TAIL IL:ON (PROGN-STMTS NODE) IL:DO (IF (NULL (CDR TAIL)) (MEVAL (CAR TAIL) CONTEXT) (MEVAL (CAR TAIL) :EFFECT))) (ANALYZE-TREE NODE) (REMOVE-NESTED-PROGNS (PROGN-STMTS NODE)) (IL:* IL:|;;| "Eliminate any effect-context literals and reduce (PROGN ) to .") (LET ((NEW-STMTS (IL:FOR TAIL IL:ON (PROGN-STMTS NODE) IL:WHEN (OR (NOT (LITERAL-P (CAR TAIL))) (NULL (CDR TAIL))) IL:COLLECT (CAR TAIL)))) (COND ((NULL NEW-STMTS) *LITERALLY-NIL*) ((NULL (CDR NEW-STMTS)) (SETQ NODE (CAR NEW-STMTS))) (T (SETF (PROGN-STMTS NODE) NEW-STMTS)))) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-PROGV (NODE CONTEXT) (MEVAL (PROGV-SYMS-EXPR NODE) :ARGUMENT) (MEVAL (PROGV-VALS-EXPR NODE) :ARGUMENT) (MEVAL (PROGV-STMT NODE) CONTEXT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-RETURN (NODE CONTEXT) (MEVAL (RETURN-VALUE NODE) (BLOCK-CONTEXT (RETURN-BLOCK NODE))) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-SETQ (NODE CONTEXT) (MEVAL (SETQ-VALUE NODE) :ARGUMENT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-TAGBODY (NODE CONTEXT) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:DO (MEVAL-LIST (SEGMENT-STMTS SEGMENT) :EFFECT)) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-THROW (NODE CONTEXT) (MEVAL (THROW-TAG NODE) :ARGUMENT) (MEVAL (THROW-VALUE NODE) :MV) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-UNWIND-PROTECT (NODE CONTEXT) (IL:* IL:|;;;| "This is fucked up right now.") (MEVAL (UNWIND-PROTECT-STMT NODE) :ARGUMENT) (MEVAL (UNWIND-PROTECT-CLEANUP NODE) :ARGUMENT) (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFUN META-EVAL-VAR-REF (NODE CONTEXT) (COND ((EQ CONTEXT :EFFECT) (IL:* IL:\;  "Variable references have no side-effects.") (RELEASE-VAR-REF NODE) *LITERALLY-NIL*) (T (ANALYZE-TREE NODE) (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFUN META-CALL-LAMBDA (NODE CONTEXT) (IL:* IL:|;;| "This is a directly-called LAMBDA. Here are the steps to meta-evaluate it:") (IL:* IL:|;;| " -- Try to eliminate all of the non-required arguments") (IL:* IL:|;;| " -- Try to substitute in all of the required arguments") (IL:* IL:|;;| " -- Try to eliminate all arguments to unreferenced parameters") (IL:* IL:|;;| " -- Beta-convert the now-argument-less LAMBDA") (LET ((*MADE-CHANGES* NIL) (FN (CALL-FN NODE))) (IL:* IL:|;;| "We can't meta-evaluate direct calls to Interlisp's LAMBDA no-spread's.") (WHEN (EQ 2 (LAMBDA-ARG-TYPE FN)) (RETURN-FROM META-CALL-LAMBDA NODE)) (IL:* IL:|;;| "If there are non-required parameters, try to get rid of them.") (WHEN (OR (LAMBDA-OPTIONAL FN) (LAMBDA-KEYWORD FN) (LAMBDA-REST FN) (/= (LENGTH (CALL-ARGS NODE)) (LENGTH (LAMBDA-REQUIRED FN)))) (IL:* IL:\; "Attempt to eliminate all of the non-required parameters. Also, catch wrong number of arguments errors.") (WHEN (NULL (META-CALL-LAMBDA-SIMPLIFY-PARAMETERS NODE)) (WHEN (NULL *MADE-CHANGES*) (SETF (NODE-META-P NODE) CONTEXT)) (RETURN-FROM META-CALL-LAMBDA NODE)) (IL:* IL:|;;| "Some changes were made. We need to re-meta-evaluate the call in order to make sure it's up to date.") (MEVAL (CALL-FN NODE) :ARGUMENT) (MEVAL-LIST (CALL-ARGS NODE) :ARGUMENT)) (IL:* IL:|;;| "Now there are only required parameters. Try to substitute arguments for parameters where appropriate.") (META-CALL-LAMBDA-SUBSTITUTE NODE) (IL:* IL:|;;| "Now we can get rid of any parameters that aren't referenced. ") (LET ((NEW-PARAMS NIL) (NEW-ARGS NIL) (CURRENT-PROG1-TAIL NIL) (CURRENT-PROGN NIL)) (IL:* IL:|;;| "If the first parameter is not referenced, we can turn (fn arg1 . args) into (progn arg1 (fn' . args)) where fn' is just like fn but doesn't have the first parameter.") (IL:* IL:|;;| "If the first is referenced, but the second is not, we can turn (fn arg1 arg2 . args) into (fn' (prog1 arg1 arg2) .args), where fn' is just like fn but without the second parameter and (prog1 (a) . b) is really ((lambda (anon) ,@b anon) (a)) .") (IL:FOR PARAM IL:IN (LAMBDA-REQUIRED FN) IL:AS ARG IL:IN (CALL-ARGS NODE) IL:DO (COND ((OR (EQ :SPECIAL (VARIABLE-SCOPE PARAM)) (NOT (NULL (VARIABLE-READ-REFS PARAM))) (NOT (NULL (VARIABLE-WRITE-REFS PARAM)))) (IL:* IL:\;  "This one's used. Leave it.") (PUSH PARAM NEW-PARAMS) (PUSH ARG NEW-ARGS) (SETQ CURRENT-PROG1-TAIL NIL)) (T (IL:* IL:\;  "This one is not used. Can it.") (SETQ *MADE-CHANGES* T) (COND ((NODE-SUBST-P ARG) (IL:* IL:\;  "The corresponding argument has been substituted into the body. We need not save it at all.") (RELEASE-TREE ARG)) ((NULL NEW-ARGS) (IL:* IL:\;  "It's an early one. Stick it into a PROGN.") (PUSH ARG CURRENT-PROGN)) ((NULL CURRENT-PROG1-TAIL)(IL:* IL:\;  "We need to set up a PROG1 using the previous argument.") (IL:* IL:\; "After putting it together, we make CURRENT-PROG1-TAIL hold the last CONS cell in the body of the LAMBDA of the PROG1. This is to allow splicing new stmts into that body.") (LET* ((NEW-PROG1 (CONSTRUCT-PROG1-TREE (CAR NEW-ARGS) (LIST ARG)))) (SETQ CURRENT-PROG1-TAIL (CDR (PROGN-STMTS (LAMBDA-BODY (CALL-FN NEW-PROG1 ))))) (SETF (CAR NEW-ARGS) NEW-PROG1))) (T (IL:* IL:\;  "There's already a PROG1 set up for us.") (IL:RPLNODE CURRENT-PROG1-TAIL ARG (LIST (CAR CURRENT-PROG1-TAIL ))) (SETQ CURRENT-PROG1-TAIL (CDR CURRENT-PROG1-TAIL))))))) (IL:* IL:|;;| "If there aren't any arguments left, then we can beta-reduce.") (COND ((NULL NEW-ARGS) (SETQ NODE (LAMBDA-BODY FN)) (SETF (LAMBDA-BODY FN) NIL) (SETF (LAMBDA-REQUIRED FN) NIL) (RELEASE-TREE FN) (SETQ *MADE-CHANGES* T)) (T (SETF (LAMBDA-REQUIRED FN) (NREVERSE NEW-PARAMS)) (SETF (CALL-ARGS NODE) (NREVERSE NEW-ARGS)))) (WHEN (NOT (NULL CURRENT-PROGN)) (SETQ NODE (MAKE-PROGN :STMTS (NREVERSE (CONS NODE CURRENT-PROGN)))))) (WHEN (NULL *MADE-CHANGES*) (SETF (NODE-META-P NODE) CONTEXT)) NODE)) (DEFUN META-CALL-LAMBDA-SIMPLIFY-PARAMETERS (NODE) (IL:* IL:|;;| "Attempt to eliminate all of the non-required parameters from the given lambda-call. Return non-nil iff we can get rid of all of them. Also, check for wrong number of arguments.") (LET* ((FN (CALL-FN NODE)) (ARGS (CALL-ARGS NODE)) (INNERMOST-CALL NODE) (INNERMOST-LAMBDA FN) (NEW-ARGS NIL) (NEW-PARAMS NIL) (KEY-PARAMS NIL)) (LABELS ((ADD-PARAM (PARAM ARG) (IL:* IL:|;;|  "Match up the given argument with the given parameter in the current lambda.") (PUSH PARAM NEW-PARAMS) (PUSH ARG NEW-ARGS) (SETF (VARIABLE-BINDER PARAM) INNERMOST-LAMBDA)) (CLOSE-LAMBDA NIL (IL:* IL:|;;| "Close off the current lambda.") (SETF (LAMBDA-REQUIRED INNERMOST-LAMBDA) (NREVERSE NEW-PARAMS)) (SETF (CALL-ARGS INNERMOST-CALL) (NREVERSE NEW-ARGS)) (SETQ NEW-ARGS NIL) (SETQ NEW-PARAMS NIL)) (NEW-LAMBDA NIL (IL:* IL:|;;| "Close off the old lambda and add a new one inside of it.") (CLOSE-LAMBDA) (LET* ((NEW-LAMBDA (MAKE-LAMBDA :BODY (LAMBDA-BODY INNERMOST-LAMBDA))) (NEW-CALL (MAKE-CALL :FN NEW-LAMBDA))) (SETF (LAMBDA-BODY INNERMOST-LAMBDA) NEW-CALL) (SETQ INNERMOST-LAMBDA NEW-LAMBDA) (SETQ INNERMOST-CALL NEW-CALL))) (OUTER-LAMBDA-P NIL (IL:* IL:|;;| "Is the current lambda the outermost one?") (EQ INNERMOST-LAMBDA FN)) (ENSURE-INNER-LAMBDA NIL (IL:* IL:|;;|  "Make sure that the current lambda is not the outermost one.") (WHEN (OUTER-LAMBDA-P) (NEW-LAMBDA)))) (IL:* IL:|;;| "Handle the required parameters") (IL:FOR TAIL IL:ON (LAMBDA-REQUIRED FN) IL:DO (COND ((NULL ARGS) (CERROR "Use NIL for the remaining parameters." "Too few arguments given for explicit LAMBDA call.") (IL:FOR PARAM IL:IN TAIL IL:DO (ADD-PARAM PARAM *LITERALLY-NIL*)) (RETURN)) (T (ADD-PARAM (CAR TAIL) (POP ARGS))))) (IL:* IL:|;;| "Handle the optional parameters") (WHEN (NOT (NULL (LAMBDA-OPTIONAL FN))) (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL FN) IL:DO (COND ((NULL ARGS) (IL:* IL:|;;| "No arguments left. Wrap the body in a LET binding the optional parameter to its default value. Also bind the supplied-p parameter, if any.") (NEW-LAMBDA) (ADD-PARAM (FIRST OPT-VAR) (SECOND OPT-VAR)) (WHEN (THIRD OPT-VAR) (IL:* IL:\; "There's a supplied-p") (ADD-PARAM (THIRD OPT-VAR) *LITERALLY-NIL*))) (T (IL:* IL:|;;| "There are arguments left, so match one up with this optional and match up T with the supplied-p parameter, if any.") (ADD-PARAM (FIRST OPT-VAR) (POP ARGS)) (RELEASE-TREE (SECOND OPT-VAR)) (WHEN (THIRD OPT-VAR) (IL:* IL:\; "There's a supplied-p") (ADD-PARAM (THIRD OPT-VAR) *LITERALLY-T*))))) (SETF (LAMBDA-OPTIONAL FN) NIL) (IL:* IL:\;  "All of the optionals are gone now.") (SETF (NODE-META-P FN) NIL) (SETQ *MADE-CHANGES* T)) (IL:* IL:|;;| "We can't go any further if there are keyword parameters and we can't tell what the corresponding keyword arguments are.") (WHEN (AND (NOT (NULL (LAMBDA-KEYWORD FN))) (NOT (IL:FOR ARG IL:IN ARGS IL:BY CDDR IL:ALWAYS (LITERAL-P ARG)))) (CLOSE-LAMBDA) (RETURN-FROM META-CALL-LAMBDA-SIMPLIFY-PARAMETERS NIL)) (IL:* IL:|;;| "If there are keyword parameters, we need to bind the remaining arguments to new, anonymous variables for any more processing.") (WHEN (NOT (NULL (LAMBDA-KEYWORD FN))) (ENSURE-INNER-LAMBDA) (SETQ KEY-PARAMS (IL:IN ARGS IL:COLLECT (MAKE-VARIABLE :BINDER FN))) (WHEN (NOT (NULL KEY-PARAMS)) (SETF (LAMBDA-REQUIRED FN) (APPEND (LAMBDA-REQUIRED FN) KEY-PARAMS)) (SETF (CALL-ARGS NODE) (APPEND (CALL-ARGS NODE) ARGS))) (SETF (NODE-META-P FN) NIL) (SETQ *MADE-CHANGES* T)) (IL:* IL:|;;| "Handle the &rest parameter, if any. If there are keyword parameters, then we bind the rest-var to a list of the anonymous variables used in that translation. If not, we transform the arguments into a single call on LIST and bind that to the rest-var.") (LET ((REST-VAR (LAMBDA-REST FN))) (WHEN (NOT (NULL REST-VAR)) (COND ((NOT (NULL KEY-PARAMS)) (IL:* IL:\;  "There are keyword parameters.") (ADD-PARAM REST-VAR (CONSTRUCT-LIST (MAPCAR #'(LAMBDA (PARAM) (LET ((REF (MAKE-VAR-REF :VARIABLE PARAM))) (PUSH REF (VARIABLE-READ-REFS PARAM)) REF)) KEY-PARAMS)))) (T (IL:* IL:\;  "There are no keyword parameters.") (COND ((NULL ARGS) (IL:* IL:\;  "There aren't any arguments left, either.") (ADD-PARAM REST-VAR *LITERALLY-NIL*)) ((OUTER-LAMBDA-P) (IL:* IL:\;  "We're still in the outer lambda, so we can just bind the rest-var to a list of the arguments.") (ADD-PARAM REST-VAR (CONSTRUCT-LIST ARGS))) (T (IL:* IL:\; "Sigh. This is the messiest case. We're in an inner lambda, so we have to add an anonymous variable to the outer one, bind that to the list of arguments, and then bind the rest-var to that in the current lambda.") (LET* ((ANON-VAR (MAKE-VARIABLE :BINDER FN)) (ANON-VAR-REF (MAKE-VAR-REF :VARIABLE ANON-VAR))) (SETF (LAMBDA-REQUIRED FN) (NCONC (LAMBDA-REQUIRED FN) (LIST ANON-VAR))) (SETF (CALL-ARGS NODE) (NCONC (CALL-ARGS NODE) (LIST (CONSTRUCT-LIST ARGS)))) (ADD-PARAM REST-VAR ANON-VAR-REF) (PUSH ANON-VAR-REF (VARIABLE-READ-REFS ANON-VAR))))) (SETQ ARGS NIL) (IL:* IL:\;  "All of the arguments have been handled.") )) (SETF (LAMBDA-REST FN) NIL) (IL:* IL:\;  "The &rest parameter is no more.") (SETF (NODE-META-P FN) NIL) (SETQ *MADE-CHANGES* T))) (IL:* IL:|;;| "Handle the keyword parameters. All of the keyword-position arguments are literals; we can thus determine which arguments go with which keyword parameters. Thus, we can turn them all into required ones.") (WHEN (NOT (NULL (LAMBDA-KEYWORD FN))) (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD FN) IL:DO (LET* ((KEYWORD (FIRST KEY-VAR)) (ANON-VAR (IL:FOR ARG IL:IN ARGS IL:BY CDDR IL:AS TAIL IL:ON KEY-PARAMS IL:BY CDDR IL:WHEN (EQ KEYWORD (LITERAL-VALUE ARG)) IL:DO (RETURN (SECOND TAIL)))) (ANON-VAR-REF (MAKE-VAR-REF :VARIABLE ANON-VAR))) (COND ((NULL ANON-VAR) (IL:* IL:|;;|  "This keyword isn't present in the call; treat the same as an unsupplied optional. ") (NEW-LAMBDA) (ADD-PARAM (SECOND KEY-VAR) (THIRD KEY-VAR)) (WHEN (FOURTH KEY-VAR) (ADD-PARAM (FOURTH KEY-VAR) *LITERALLY-NIL*))) (T (IL:* IL:|;;| "There is a matching keyword in the argument list, so we bind the parameter to the corresponding anonymous one.") (ENSURE-INNER-LAMBDA) (ADD-PARAM (SECOND KEY-VAR) ANON-VAR-REF) (PUSH ANON-VAR-REF (VARIABLE-READ-REFS ANON-VAR)) (RELEASE-TREE (THIRD KEY-VAR)) (WHEN (FOURTH KEY-VAR) (ADD-PARAM (FOURTH KEY-VAR) *LITERALLY-T*)))))) (SETF (LAMBDA-KEYWORD FN) NIL) (IL:* IL:\;  "All of the keyword parameters are gone now.") (SETQ ARGS NIL) (IL:* IL:\;  "And we've managed to use up all of the arguments.") ) (IL:* IL:|;;| "Make one final check that there weren't too many arguments.") (WHEN (NOT (NULL ARGS)) (CERROR "Ignore the extra arguments" "Too many arguments were given to an inline LAMBDA call.") (IL:FOR ARG IL:IN ARGS IL:DO (RELEASE-TREE ARG))) (IL:* IL:|;;|  "We're done now. Close up the inner lambda machinery and return a sign of success.") (CLOSE-LAMBDA) T))) (DEFUN CONSTRUCT-LIST (ARGS) (IL:* IL:|;;;| "ARGS is a non-empty list of nodes. Return an tree that computes the result of LIST applied to the results of those nodes. A simple implementation would just make an actual call to the function LIST, but this is inefficient. Instead, we make a nested series of calls to the function CONS.") (LET ((NODE *LITERALLY-NIL*)) (IL:MAPC (REVERSE ARGS) (IL:FUNCTION (IL:LAMBDA (ARG) (SETQ NODE (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :KIND :FUNCTION :SCOPE :GLOBAL :NAME 'CONS) :ARGS (LIST ARG NODE)))))) NODE)) (IL:* IL:|;;;| "Meta-substitution") (DEFUN META-CALL-LAMBDA-SUBSTITUTE (NODE) (LET* ((FN (CALL-FN NODE)) (REQUIRED-ARGS (LAMBDA-REQUIRED FN)) (NON-LOCAL-EFFECTS (WITH-COLLECTION (DOLIST (VAR REQUIRED-ARGS) (UNLESS (EQ (VARIABLE-SCOPE VAR) :LEXICAL) (COLLECT (EFFECTS-REPRESENTATION VAR)))))) (*SUBST-OCCURRED* NIL)) (IL:* IL:\; "Bind *SUBST-OCCURRED* just so that META-SUBST-VAR-REF has a binding to set even when nobody cares.") (IL:FOR VAR IL:IN REQUIRED-ARGS IL:AS TAIL IL:ON (CALL-ARGS NODE) IL:WHEN (AND (EQ (VARIABLE-SCOPE VAR) :LEXICAL) (SUBSTITUTABLE-P (CAR TAIL) VAR) (DOLIST (NON-LOCAL-EFFECT NON-LOCAL-EFFECTS T) (UNLESS (NULL-EFFECTS-INTERSECTION NON-LOCAL-EFFECT (NODE-AFFECTED (CAR TAIL))) (RETURN NIL))) (DOLIST (LATER-ARG (CDR TAIL) T) (WHEN (NOT (PASSABLE (CAR TAIL) LATER-ARG)) (RETURN NIL)))) IL:DO (SETF (LAMBDA-BODY FN) (META-SUBSTITUTE (CAR TAIL) VAR (LAMBDA-BODY FN)))) (WHEN (NULL (NODE-META-P (LAMBDA-BODY FN))) (SETF (NODE-META-P FN) NIL) (SETQ *MADE-CHANGES* T)))) (DEFUN META-CALL-LABELS (NODE CONTEXT) (IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them.") (LET ((*MADE-CHANGES* NIL)) (IL:* IL:|;;| "First, substitute the functions wherever possible.") (DOLIST (FN-PAIR (LABELS-FUNS NODE) (WHEN (NULL (NODE-META-P (LABELS-BODY NODE))) (SETF (NODE-META-P NODE) NIL) (SETQ *MADE-CHANGES* T))) (WHEN (SUBSTITUTABLE-P (CDR FN-PAIR) (CAR FN-PAIR)) (LET ((*SUBST-OCCURRED* NIL)) (IL:* IL:|;;| "First try substituting into the body.") (SETF (LABELS-BODY NODE) (META-SUBSTITUTE (CDR FN-PAIR) (CAR FN-PAIR) (LABELS-BODY NODE))) (WHEN (NOT *SUBST-OCCURRED*) (IL:* IL:|;;| "Wasn't in the body - try the other functions.") (DOLIST (TARGET-PAIR (LABELS-FUNS NODE)) (UNLESS (EQ TARGET-PAIR FN-PAIR) (SETF (CDR TARGET-PAIR) (META-SUBSTITUTE (CDR FN-PAIR) (CAR FN-PAIR) (CDR TARGET-PAIR))) (WHEN *SUBST-OCCURRED* (IL:* IL:\;  "Found it, we can stop now.") (SETF (NODE-META-P NODE) NIL) (SETQ *MADE-CHANGES* T) (RETURN))))) (IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost.") (DOLIST (FNS (LABELS-FUNS NODE)) (MEVAL (CDR FNS) :ARGUMENT)) (MEVAL (LABELS-BODY NODE) :RETURN)))) (IL:* IL:|;;| "Now remove any functions that aren't referenced.") (DOLIST (FN-PAIR (PROG1 (LABELS-FUNS NODE) (SETF (LABELS-FUNS NODE) NIL))) (COND ((NULL (VARIABLE-READ-REFS (CAR FN-PAIR))) (RELEASE-TREE (CDR FN-PAIR)) (SETQ *MADE-CHANGES* T)) (T (PUSH FN-PAIR (LABELS-FUNS NODE))))) (IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.") (WHEN (NULL (LABELS-FUNS NODE)) (LET ((BODY (LABELS-BODY NODE))) (SETF (LABELS-BODY NODE) NIL) (RELEASE-TREE NODE) (SETQ NODE BODY *MADE-CHANGES* T))) (IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.") (IF (NULL *MADE-CHANGES*) (SETF (NODE-META-P NODE) CONTEXT) (SETF (NODE-META-P NODE) NIL))) NODE) (DEFUN META-SUBSTITUTE (*SUBST-EXPR* *SUBST-VAR* TREE) (META-SUBST TREE)) (DEFUN META-SUBST (NODE) (NODE-DISPATCH META-SUBST NODE)) (DEFINE-MODIFY-MACRO MSUBST (CONTEXT) META-SUBST) (DEFMACRO MSUBST-LIST (LIST-EXPR CONTEXT &OPTIONAL KEY-FN) `(IL:FOR TAIL IL:ON ,LIST-EXPR IL:DO (MSUBST ,(IF KEY-FN `(,KEY-FN (CAR TAIL)) '(CAR TAIL)) ,CONTEXT))) (DEFUN SUBSTITUTABLE-P (ARG VAR) (IL:* IL:|;;;| "Should ARG be substituted for all of the references to VAR?") (IL:* IL:|;;;| "This test is very conservative, but still catches an enormous number of cases in practice.") (IL:* IL:|;;;| "NOTEZ BIEN: If you change this test, be sure to look carefully at the various substitution methods and at the code in META-CALL-LAMBDA. Some of it depends upon the precise test being made; in particular, it matters if more side effects are allowed to be substituted.") (AND (NULL (VARIABLE-WRITE-REFS VAR)) (IL:* IL:\;  "The variable is never SETQ'd in the body,") (NOT (NULL (VARIABLE-READ-REFS VAR))) (IL:* IL:\;  "the variable is read at least once,") (IL:* IL:\; "and either") (OR (VAR-REF-P ARG) (IL:* IL:\;  " -- the arg is a variable reference,") (AND (LITERAL-P ARG) (NOT (EVAL-WHEN-LOAD-P (LITERAL-VALUE ARG)))) (IL:* IL:\; " -- the arg is a literal") ))) (DEFUN EFFECTLESS (EFFECTS) (OR (NULL EFFECTS) (EQ EFFECTS :NONE))) (DEFUN EFFECTLESS-EXCEPT-CONS (EFFECTS) (OR (NULL EFFECTS) (EQ EFFECTS :NONE) (EQUAL EFFECTS '(:CONS)))) (DEFUN NULL-INTERSECTION (LIST-1 LIST-2) (OR (NULL LIST-1) (NULL LIST-2) (DOLIST (X LIST-1 T) (WHEN (MEMBER X LIST-2 :TEST 'EQ) (RETURN NIL))))) (DEFUN NULL-EFFECTS-INTERSECTION (EFFECTS-1 EFFECTS-2) (OR (NULL EFFECTS-1) (NULL EFFECTS-2) (EQ EFFECTS-1 :NONE) (EQ EFFECTS-2 :NONE) (COND ((EQ EFFECTS-1 :ANY) NIL) ((EQ EFFECTS-2 :ANY) NIL) (T (NULL-INTERSECTION EFFECTS-1 EFFECTS-2))))) (DEFUN NULL-EFFECTS-INTERSECTION-EXCEPT-CONS (EFFECTS-1 EFFECTS-2) (COND ((OR (NULL EFFECTS-1) (NULL EFFECTS-2) (EQ EFFECTS-1 :NONE) (EQ EFFECTS-2 :NONE)) T) ((EQ EFFECTS-1 :ANY) (IL:EQUAL (IL:MKLIST EFFECTS-2 '(:CONS)))) ((EQ EFFECTS-2 :ANY) (IL:EQUAL (IL:MKLIST EFFECTS-1 '(:CONS)))) (T (DOLIST (EFFECT EFFECTS-1 T) (WHEN (AND (NOT (EQ EFFECT :CONS)) (MEMBER EFFECT EFFECTS-2 :TEST 'EQ)) (RETURN NIL)))))) (DEFUN PASSABLE (NODE-1 NODE-2) (IL:* IL:|;;;| "This predicate is true if and only if the two given nodes can be executed in either order.") (AND (NULL-EFFECTS-INTERSECTION (NODE-EFFECTS NODE-1) (NODE-AFFECTED NODE-2)) (NULL-EFFECTS-INTERSECTION (NODE-AFFECTED NODE-1) (NODE-EFFECTS NODE-2)) (NULL-EFFECTS-INTERSECTION-EXCEPT-CONS (NODE-EFFECTS NODE-1) (NODE-EFFECTS NODE-2)))) (DEFINLINE NONLOCAL-VARIABLE-EFFECT-P (EFFECT-REP) (AND (SYMBOLP EFFECT-REP) (NOT (KEYWORDP EFFECT-REP)))) (DEFUN COLLECT-NONLOCAL-VAR-EFFECTS (NODE) (LET ((VARS NIL)) (DOLIST (EFFECT (IL:MKLIST (NODE-EFFECTS NODE))) (WHEN (NONLOCAL-VARIABLE-EFFECT-P EFFECT) (PUSHNEW EFFECT VARS :TEST 'EQ))) (DOLIST (EFFECT (IL:MKLIST (NODE-AFFECTED NODE))) (WHEN (NONLOCAL-VARIABLE-EFFECT-P EFFECT) (PUSHNEW EFFECT VARS :TEST 'EQ))) VARS)) (DEFVAR *SUBST-VAR* NIL (IL:* IL:|;;;| "The variable for occurrences of which we are substituting *SUBST-EXPR*.") ) (DEFVAR *SUBST-EXPR* NIL (IL:* IL:|;;;| "The expression being substituted for all occurrences of *SUBST-VAR*.") ) (DEFVAR *SUBST-OCCURRED* (IL:* IL:|;;;| "Bound by substitution methods that need to know whether or not anything actually happened and set by META-SUBST-VAR-REF when something does.") ) (DEFUN META-SUBST-BLOCK (NODE) (IL:* IL:\; "") (MSUBST (BLOCK-STMT NODE)) (SETF (NODE-META-P NODE) (NODE-META-P (BLOCK-STMT NODE))) NODE) (DEFUN META-SUBST-CALL (NODE) (WHEN (AND (NOT (LAMBDA-P (CALL-FN NODE))) (NOT (CALLER-NOT-INLINE NODE))) (IL:* IL:\;  "The body of the lambda won't be eval'd until after the arguments.") (MSUBST (CALL-FN NODE))) (META-SUBST-ANY-CALL NODE (CALL-FN NODE) (CALL-ARGS NODE))) (DEFUN META-SUBST-CATCH (NODE) (IL:* IL:\; "") (MSUBST (CATCH-TAG NODE)) (WHEN (PASSABLE *SUBST-EXPR* (CATCH-TAG NODE)) (MSUBST (CATCH-STMT NODE))) (WHEN (OR (NULL (NODE-META-P (CATCH-TAG NODE))) (NULL (NODE-META-P (CATCH-STMT NODE)))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-GO (NODE) NODE) (DEFUN META-SUBST-IF (NODE) (IL:* IL:\; "") (MSUBST (IF-PRED NODE)) (WHEN (AND (EFFECTLESS-EXCEPT-CONS (NODE-EFFECTS *SUBST-EXPR*)) (PASSABLE *SUBST-EXPR* (IF-PRED NODE))) (MSUBST (IF-THEN NODE)) (MSUBST (IF-ELSE NODE))) (WHEN (OR (NULL (NODE-META-P (IF-PRED NODE))) (NULL (NODE-META-P (IF-THEN NODE))) (NULL (NODE-META-P (IF-ELSE NODE)))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-LABELS (NODE) (DOLIST (FUN (LABELS-FUNS NODE)) (MSUBST (CDR FUN)) (WHEN (NULL (NODE-META-P (CDR FUN))) (SETF (NODE-META-P NODE) NIL))) (MSUBST (LABELS-BODY NODE)) (WHEN (NULL (NODE-META-P (LABELS-BODY NODE))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-LAMBDA (NODE &OPTIONAL (IN-FUNCTIONAL-POSITION NIL)) (WHEN (OR IN-FUNCTIONAL-POSITION (AND (EFFECTLESS (NODE-EFFECTS *SUBST-EXPR*)) (EFFECTLESS (NODE-AFFECTED *SUBST-EXPR*)))) (LET ((NONLOCAL-VAR-EFFECTS (COLLECT-NONLOCAL-VAR-EFFECTS *SUBST-EXPR*))) (FLET ((SPECIAL-CLASHES-WITH-EFFECTS (VAR) (IL:* IL:|;;| "This is to check for the case of substituting an expression which depends on a special variable into a scope that rebinds that special.") (AND (EQ (VARIABLE-SCOPE VAR) :SPECIAL) (IL:FMEMB (VARIABLE-NAME VAR) NONLOCAL-VAR-EFFECTS)))) (BLOCK SUBSTITUTION (DOLIST (REQ-VAR (LAMBDA-REQUIRED NODE)) (WHEN (SPECIAL-CLASHES-WITH-EFFECTS REQ-VAR) (RETURN-FROM SUBSTITUTION))) (DOLIST (OPT-VAR (LAMBDA-OPTIONAL NODE)) (MSUBST (SECOND OPT-VAR)) (WHEN (NULL (NODE-META-P (SECOND OPT-VAR))) (SETF (NODE-META-P NODE) NIL)) (WHEN (OR (SPECIAL-CLASHES-WITH-EFFECTS (FIRST OPT-VAR)) (NOT (PASSABLE *SUBST-EXPR* (SECOND OPT-VAR)))) (RETURN-FROM SUBSTITUTION))) (WHEN (AND (LAMBDA-REST NODE) (SPECIAL-CLASHES-WITH-EFFECTS (LAMBDA-REST NODE))) (RETURN-FROM SUBSTITUTION)) (IL:* IL:|;;| "JDS 1/6/89: This appears to loop thru the keywords, checking each one. There uesd to be a (SPECIAL-CLASHES-WITH-EFFECTS (THIRD KEY-VAR)) in the (when (or...)) clause, but that list seems to be ") (IL:* IL:|;;| "( variable-symbol variable-structure var's-value-structure)") (IL:* IL:|;;|  "and that's not checkable with SPECIAL-CLASHES-WITH-EFFECTS....") (DOLIST (KEY-VAR (LAMBDA-KEYWORD NODE)) (MSUBST (THIRD KEY-VAR)) (WHEN (NULL (NODE-META-P (THIRD KEY-VAR))) (SETF (NODE-META-P NODE) NIL)) (WHEN (OR (SPECIAL-CLASHES-WITH-EFFECTS (SECOND KEY-VAR)) (NOT (PASSABLE *SUBST-EXPR* (THIRD KEY-VAR)))) (RETURN-FROM SUBSTITUTION))) (MSUBST (LAMBDA-BODY NODE)) (WHEN (NULL (NODE-META-P (LAMBDA-BODY NODE))) (SETF (NODE-META-P NODE) NIL)))))) NODE) (DEFUN META-SUBST-LITERAL (NODE) NODE) (DEFUN META-SUBST-MV-CALL (NODE) (WHEN (AND (NOT (LAMBDA-P (MV-CALL-FN NODE))) (NOT (CALLER-NOT-INLINE NODE))) (IL:* IL:\;  "The body of the lambda won't be eval'd until after the arguments.") (MSUBST (MV-CALL-FN NODE))) (META-SUBST-ANY-CALL NODE (MV-CALL-FN NODE) (MV-CALL-ARG-EXPRS NODE))) (DEFUN META-SUBST-MV-PROG1 (NODE) (DESTRUCTURING-BIND (VALUES-STMT . EFFECT-STMTS) (MV-PROG1-STMTS NODE) (MSUBST VALUES-STMT) (WHEN (NULL (NODE-META-P VALUES-STMT)) (SETF (NODE-META-P NODE) NIL)) (WHEN (PASSABLE *SUBST-EXPR* VALUES-STMT) (SETQ EFFECT-STMTS (META-SUBST-STMTS NODE EFFECT-STMTS NIL))) (SETF (MV-PROG1-STMTS NODE) (CONS VALUES-STMT EFFECT-STMTS))) NODE) (DEFUN META-SUBST-OPCODES (NODE) NODE) (DEFUN META-SUBST-PROGN (NODE) (SETF (PROGN-STMTS NODE) (META-SUBST-STMTS NODE (PROGN-STMTS NODE) T)) NODE) (DEFUN META-SUBST-PROGV (NODE) (IL:* IL:\; "") (MSUBST (PROGV-SYMS-EXPR NODE)) (WHEN (PASSABLE (PROGV-SYMS-EXPR NODE) *SUBST-EXPR*) (MSUBST (PROGV-VALS-EXPR NODE)) (WHEN (PASSABLE (PROGV-VALS-EXPR NODE) *SUBST-EXPR*) (MSUBST (PROGV-STMT NODE)))) (WHEN (OR (NULL (NODE-META-P (PROGV-SYMS-EXPR NODE))) (NULL (NODE-META-P (PROGV-VALS-EXPR NODE))) (NULL (NODE-META-P (PROGV-STMT NODE)))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-RETURN (NODE) (MSUBST (RETURN-VALUE NODE)) (WHEN (NULL (NODE-META-P (RETURN-VALUE NODE))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-SETQ (NODE) (IL:* IL:|;;;| "Someday, the SETQ removal code will make this method more substantial.") (MSUBST (SETQ-VALUE NODE)) (WHEN (NULL (NODE-META-P (SETQ-VALUE NODE))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-TAGBODY (NODE) (IL:* IL:|;;;| "Because we don't do enough flow-analysis (or any, really), we can only safely substitute literals into loops. Even variables are unsafe since they could be SETQ'd later in the loop. We decide that we may be in a loop when we encounter a segment with a non-empty list of tags.") (DOLIST (SEGMENT (TAGBODY-SEGMENTS NODE)) (UNLESS (OR (LITERAL-P *SUBST-EXPR*) (NULL (SEGMENT-TAGS SEGMENT))) (RETURN)) (MULTIPLE-VALUE-BIND (STMTS PASSABLE?) (META-SUBST-STMTS NODE (SEGMENT-STMTS SEGMENT) NIL) (SETF (SEGMENT-STMTS SEGMENT) STMTS) (UNLESS PASSABLE? (RETURN)))) NODE) (DEFUN META-SUBST-THROW (NODE) (IL:* IL:\; "") (MSUBST (THROW-TAG NODE)) (WHEN (PASSABLE *SUBST-EXPR* (THROW-TAG NODE)) (MSUBST (THROW-VALUE NODE))) (WHEN (OR (NULL (NODE-META-P (THROW-TAG NODE))) (NULL (NODE-META-P (THROW-VALUE NODE)))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-UNWIND-PROTECT (NODE) (IL:* IL:|;;;| "This is fucked up because of the fact that the components of UNWIND-PROTECT's are stored as LAMBDA's prematurely.") (MSUBST (UNWIND-PROTECT-STMT NODE)) (WHEN (PASSABLE *SUBST-EXPR* (UNWIND-PROTECT-STMT NODE)) (MSUBST (UNWIND-PROTECT-CLEANUP NODE))) (WHEN (OR (NULL (NODE-META-P (UNWIND-PROTECT-STMT NODE))) (NULL (NODE-META-P (UNWIND-PROTECT-CLEANUP NODE)))) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-VAR-REF (NODE) (IF (AND (EQ *SUBST-VAR* (VAR-REF-VARIABLE NODE)) (NOT (MEMBER (NODE-META-P NODE) '(:MV :RETURN)))) (LET ((NEW-CODE (COPY-CODE *SUBST-EXPR*))) (RELEASE-TREE NODE) (SETF (NODE-SUBST-P *SUBST-EXPR*) T) (SETQ *SUBST-OCCURRED* T) NEW-CODE) NODE)) (DEFUN META-SUBST-ANY-CALL (NODE FN ARGS) (IL:* IL:|;;;| "Common code between CALL and MV-CALL") (WHEN (PASSABLE *SUBST-EXPR* FN) (IL:* IL:|;;| "This can avoid being the case when the function is computed, for example by function call. Remember, CALL nodes are used for uses of FUNCALL in the source, as well as in other cases.") (DO ((TAIL ARGS (CDR TAIL))) ((NULL TAIL) (WHEN (LAMBDA-P FN) (IL:* IL:|;;| "Finally it's time to substitute inside the lambda.") (META-SUBST-LAMBDA FN T))) (IL:* IL:|;;| "Substitute into each argument and see if we can go further.") (MSUBST (CAR TAIL)) (WHEN (NOT (PASSABLE *SUBST-EXPR* (CAR TAIL))) (IL:* IL:\;  "Can't go beyond this argument.") (RETURN)))) (IL:* IL:|;;| "Keep the META-P information up to date.") (WHEN (OR (NULL (NODE-META-P FN)) (NOTEVERY #'NODE-META-P ARGS)) (SETF (NODE-META-P NODE) NIL)) NODE) (DEFUN META-SUBST-STMTS (NODE STMTS-LIST FINAL-STMT-IMMOVABLE) (IL:* IL:|;;;| "Common code between all of the too-many PROGN-like structures (PROGN, MV-PROG1, TAGBODY).") (IL:* IL:|;;;| "The idea here is that we can reorder the nodes in the list as long as the side-effects analysis permits. We will partition the already-processed nodes into two sets, named after their counterparts in the S-1 compiler: WINNERS and BARRIERS. BARRIERS are nodes that are not PASSABLE with the *SUBST-EXPR*. For each node we process, we try to bring it past all of the BARRIERS. If we succeed, then we can substitute into it. Afterwards, if the node is PASSABLE with *SUBST-EXPR*, it goes on the WINNERS list; otherwise, it gets put onto BARRIERS at the end closer to the front of the stmts list.") (IL:* IL:|;;;| "Before processing node A: || WINNERS || BARRIERS || A | OTHERS ||") (IL:* IL:|;;;| "If can't pass all BARRIERS: || WINNERS || BARRIERS | A || OTHERS ||") (IL:* IL:|;;;| "If passes all BARRIERS and is itself passable: || WINNERS | A || BARRIERS || OTHERS ||") (IL:* IL:|;;;| "If passes all BARRIERS but not itself passable: || WINNERS || A | BARRIERS || OTHERS ||") (IL:* IL:|;;;| "The lists WINNERS and BARRIERS are kept in reverse order, with the CAR being closer to the end of the stmts list.") (IL:* IL:|;;;| "We return the new, possibly-permuted stmts list. Just for META-SUBST-TAGBODY, if there were no barriers (i.e., the whole stmts list is passable) we return a second value of T. The given NODE has its META-P field set to NIL if anything changes under here.") (LET (NEW-STMTS-LIST) (DO ((TAIL STMTS-LIST (CDR TAIL)) (WINNERS NIL) (BARRIERS NIL)) (IL:* IL:|;;| "In some cases (notably PROGN), the final stmt is not movable.") ((NULL (IF FINAL-STMT-IMMOVABLE (CDR TAIL) TAIL)) (WHEN (AND TAIL (NULL BARRIERS)) (MSUBST (CAR TAIL)) (WHEN (NULL (NODE-META-P (CAR TAIL))) (SETF (NODE-META-P NODE) NIL))) (RETURN (VALUES (NCONC (REVERSE WINNERS) (REVERSE BARRIERS) TAIL) (NULL BARRIERS)))) (IL:* IL:|;;| "For each stmt, see if we can get it past all of the barriers.") (COND ((EVERY #'(LAMBDA (BARRIER) (PASSABLE (CAR TAIL) BARRIER)) BARRIERS) (IL:* IL:|;;| "We got past the barriers.") (LET (OUTER-S-O) (LET ((*SUBST-OCCURRED* NIL)) (MSUBST (CAR TAIL)) (SETQ OUTER-S-O *SUBST-OCCURRED*) (IL:* IL:|;;| "We made a change here if either we've permuted some stmts or a substitution was made inside the node.") (COND ((PASSABLE (CAR TAIL) *SUBST-EXPR*) (PUSH (CAR TAIL) WINNERS) (WHEN (OR BARRIERS *SUBST-OCCURRED*) (SETF (NODE-META-P NODE) NIL))) (*SUBST-OCCURRED* (SETQ BARRIERS (NCONC BARRIERS (LIST (CAR TAIL)))) (SETF (NODE-META-P NODE) NIL)) (T (IL:* IL:|;;|  "Nothing happened and this one's not a winner, so don't make any gratuitous changes.") (PUSH (CAR TAIL) BARRIERS)))) (IL:* IL:|;;| "Pass on the fact that a substitution happened below here.") (WHEN OUTER-S-O (SETQ *SUBST-OCCURRED* OUTER-S-O)))) (T (IL:* IL:|;;| "We couldn't get past the barriers.") (PUSH (CAR TAIL) BARRIERS)))))) (IL:* IL:|;;| "Testing meta-evaluation") (DEFUN TEST-META-EVAL (FN) (LET ((TREE (TEST-ALPHA-2 FN))) (UNWIND-PROTECT (PRINT-TREE (META-EVALUATE TREE)) (RELEASE-TREE TREE)))) (IL:* IL:|;;| "Arrange to use the correct compiler") (IL:PUTPROPS IL:XCLC-META-EVAL IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Arrange for the proper makefile-environment") (IL:PUTPROPS IL:XCLC-META-EVAL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-META-EVAL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 )) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-OPTIMIZERS b/sources/XCLC-OPTIMIZERS new file mode 100644 index 00000000..c6a8d626 --- /dev/null +++ b/sources/XCLC-OPTIMIZERS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (il:filecreated " 4-Jun-90 14:31:10" il:|{PELE:MV:ENVOS}SOURCES>XCLC-OPTIMIZERS.;3| 18114 il:|changes| il:|to:| (il:functions optimize-logical-op-1-arg) (optimizers logior logxor logand logeqv) (il:vars il:xclc-optimizerscoms) il:|previous| il:|date:| "23-May-90 13:13:25" il:|{PELE:MV:ENVOS}SOURCES>XCLC-OPTIMIZERS.;2|) ; Copyright (c) 1986, 1987, 1988, 1989, 1990 by Venue & Xerox Corporation. All rights reserved. (il:prettycomprint il:xclc-optimizerscoms) (il:rpaqq il:xclc-optimizerscoms ( (il:* il:|;;;| "Compiler optimizers") (il:define-types optimizers) (il:functions optimizer-list) (il:prop il:proptype optimizer-list) (il:functions defoptimizer) (il:* il:|;;| "Random optimizers defined within the compiler.") (optimizers caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr) (optimizers (il:arg :optimized-by convert-arg-to-\\arg) (il:setarg :optimized-by convert-setarg-to-\\setarg)) (optimizers values values-list) (optimizers il:loadtimeconstant il:getd il:fgetd il:evq) (optimizers eq eql il:eqp equal il:equal equalp) (il:functions optimize-equality optimize-eql) (optimizers (multiple-value-call :optimized-by screen-mv-call) (not :optimized-by not-to-if) (null :optimized-by null-to-if)) (optimizers il:\\callme) (il:* il:|;;| "Optimizers for File Manager forms") (il:variables *input-filecoms-variable*) (optimizers il:rpaq il:rpaq? il:rpaqq il:prettycomprint il:filecreated) (il:* il:|;;| "Other Otimization") (optimizers il:\\pilotbitblt) (il:* il:|;;| "Use the proper makefile-environment") (il:prop il:makefile-environment il:xclc-optimizers) (il:* il:|;;| "Use the proper compiler.") (il:prop il:filetype il:xclc-optimizers))) (il:* il:|;;;| "Compiler optimizers") (def-define-type optimizers "Compiler optimizers") (defmacro optimizer-list (fn) `(get ,fn 'optimizer-list)) (il:putprops optimizer-list il:proptype ignore) (defdefiner (defoptimizer (:prototype (lambda (xcl::name) (if (symbolp xcl::name) `(defoptimizer ,xcl::name ("Arg list") "Body") (destructuring-bind (xcl::form-name xcl::optimized-by xcl::opt-name ) xcl::name (and (eq ':optimized-by xcl::optimized-by) (not (null xcl::opt-name)) `(defoptimizer ,xcl::form-name ,xcl::opt-name ("Arg list") "Body")))))) (:name (lambda (il:whole) (let ((il:name (second il:whole)) (il:opt-name (third il:whole))) (if (listp il:opt-name) il:name (il:* il:\;  "(defoptimizer form-name arglist . body)") `(,il:name :optimized-by ,il:opt-name) (il:* il:\;  "(defoptimizer form-name opt-name [arg-list . body])") ))))) optimizers (il:name il:opt-name &rest il:arglist-body &environment il:env) (cond ((not il:arglist-body) (il:* il:\;  "(defoptimizer name optfn)") `(eval-when (eval compile load) (pushnew ',il:opt-name (optimizer-list ',il:name)))) (t (let* ((il:arg-list il:opt-name) (il:opt-fn-name (il:|if| (listp il:opt-name) il:|then| (il:* il:\;  "(defoptimizer form-name arglist . body)") (pack (list "optimize-" il:name) (symbol-package il:name)) il:|else| (il:* il:\;  "(defoptimizer form-name opt-name arglist . body)") (il:setq il:arg-list (il:pop il:arglist-body)) il:opt-name))) (multiple-value-bind (il:body il:decls il:doc) (il:parse-defmacro il:arg-list 'il:$$whole il:arglist-body il:name il:env :environment 'il:$$env :context 'il:$$ctx) `(eval-when (eval compile load) (setf (symbol-function ',il:opt-fn-name) #'(lambda (il:$$whole il:$$env il:$$ctx) ,@il:decls (block ,il:opt-fn-name ,il:body))) (pushnew ',il:opt-fn-name (optimizer-list ',il:name)))))))) (il:* il:|;;| "Random optimizers defined within the compiler.") (defoptimizer caaaar (cl::x) `(car (car (car (car ,cl::x))))) (defoptimizer caaadr (cl::x) `(car (car (car (cdr ,cl::x))))) (defoptimizer caaar (cl::x) `(car (car (car ,cl::x)))) (defoptimizer caadar (cl::x) `(car (car (cdr (car ,cl::x))))) (defoptimizer caaddr (cl::x) `(car (car (cdr (cdr ,cl::x))))) (defoptimizer caadr (cl::x) `(car (car (cdr ,cl::x)))) (defoptimizer caar (cl::x) `(car (car ,cl::x))) (defoptimizer cadaar (cl::x) `(car (cdr (car (car ,cl::x))))) (defoptimizer cadadr (cl::x) `(car (cdr (car (cdr ,cl::x))))) (defoptimizer cadar (cl::x) `(car (cdr (car ,cl::x)))) (defoptimizer caddar (cl::x) `(car (cdr (cdr (car ,cl::x))))) (defoptimizer cadddr (cl::x) `(car (cdr (cdr (cdr ,cl::x))))) (defoptimizer caddr (cl::x) `(car (cdr (cdr ,cl::x)))) (defoptimizer cadr (cl::x) `(car (cdr ,cl::x))) (defoptimizer cdaaar (cl::x) `(cdr (car (car (car ,cl::x))))) (defoptimizer cdaadr (cl::x) `(cdr (car (car (cdr ,cl::x))))) (defoptimizer cdaar (cl::x) `(cdr (car (car ,cl::x)))) (defoptimizer cdadar (cl::x) `(cdr (car (cdr (car ,cl::x))))) (defoptimizer cdaddr (cl::x) `(cdr (car (cdr (cdr ,cl::x))))) (defoptimizer cdadr (cl::x) `(cdr (car (cdr ,cl::x)))) (defoptimizer cdar (cl::x) `(cdr (car ,cl::x))) (defoptimizer cddaar (cl::x) `(cdr (cdr (car (car ,cl::x))))) (defoptimizer cddadr (cl::x) `(cdr (cdr (car (cdr ,cl::x))))) (defoptimizer cddar (cl::x) `(cdr (cdr (car ,cl::x)))) (defoptimizer cdddar (cl::x) `(cdr (cdr (cdr (car ,cl::x))))) (defoptimizer cddddr (cl::x) `(cdr (cdr (cdr (cdr ,cl::x))))) (defoptimizer cdddr (cl::x) `(cdr (cdr (cdr ,cl::x)))) (defoptimizer cddr (cl::x) `(cdr (cdr ,cl::x))) (defoptimizer il:arg convert-arg-to-\\arg (name expr) (if *new-compiler-is-expanding* `(il:\\arg ',name ,expr) 'pass)) (defoptimizer il:setarg convert-setarg-to-\\setarg (name expr new-value) (if *new-compiler-is-expanding* `(il:\\setarg ',name ,expr ,new-value) 'pass)) (defoptimizer values (&rest cl::args &context cl::ctxt) (cond ((and cl::args (null (cdr cl::args))) (il:* il:\; "Throw away extra values.") `((il:opcodes il:nop) ,(car cl::args))) (*new-compiler-is-expanding* (case (context-values-used cl::ctxt) ((0) `(progn ,@cl::args)) ((1) `(prog1 ,@cl::args)) (otherwise `(il:miscn values ,@cl::args)))) (t `(il:miscn values ,@cl::args)))) (defoptimizer values-list (cl::arg &context cl::ctxt) (if *new-compiler-is-expanding* (case (context-values-used cl::ctxt) ((0) cl::arg) ((1) `(car ,cl::arg)) (otherwise `(il:miscn values-list ,cl::arg))) `(il:miscn values-list ,cl::arg))) (defoptimizer il:loadtimeconstant (il:form) (il:* il:|;;;| "The new compiler uses an unforgable data structure to mark load-time forms. The old ByteCompiler used LOADTIMECONSTANTMARKER, a unique string.") (if *new-compiler-is-expanding* (make-eval-when-load :form il:form) (list 'quote (cons il:loadtimeconstantmarker il:form)))) (defoptimizer il:getd (il:fn &context il:ctxt) (if (context-predicate-p il:ctxt) `(il:\\definedp ,il:fn) 'pass)) (defoptimizer il:fgetd (il:fn) `(il:getd ,il:fn)) (defoptimizer il:evq (il:arg) il:arg) (defoptimizer eq (cl::one cl::two) (cond ((and (constantp cl::one) (null (eval cl::one))) `(null ,cl::two)) ((and (constantp cl::two) (null (eval cl::two))) `(null ,cl::one)) (t 'pass))) (defoptimizer eql (&whole cl::form) (optimize-eql cl::form)) (defoptimizer il:eqp (&whole il:form) (optimize-equality il:form)) (defoptimizer equal (&whole cl::form) (optimize-equality cl::form)) (defoptimizer il:equal (&whole il:form) (optimize-equality il:form)) (defoptimizer equalp (&whole cl::form) (optimize-equality cl::form)) (defun optimize-equality (form) (il:* il:|;;;| "FORM is a call on one of the equality-testing predicates EQL, IL:EQP, EQUAL, IL:EQUAL, or EQUALP. If one of the arguments is a literal symbol, then we can use EQ.") (destructuring-bind (fn one two) form (cond ((and (constantp one) (symbolp (eval one))) `(eq ,two ',(eval one))) ((and (constantp two) (symbolp (eval two))) `(eq ,one ',(eval two))) (t 'pass)))) (defun optimize-eql (form) (il:* il:|;;| "TRANSFORM to EQ if possible") (destructuring-bind (fn one two) form (let (e-one e-two) (cond ((and (constantp one) (or (symbolp (setq e-one (eval one))) (typep e-one 'fixnum))) `(eq ',e-one ,two)) ((and (constantp two) (or (symbolp (setq e-two (eval two))) (typep e-two 'fixnum))) `(eq ,one ',e-two)) (t 'pass))))) (defoptimizer multiple-value-call screen-mv-call (fn &body body) (il:* il:|;;;| "``Optimizer'' for special form MULTIPLE-VALUE-CALL - handle special case of list and let the rest turn into an APPLY") (cond ((and (equal fn '(il:function list)) (null (cdr body))) (cons 'il:\\mvlist body)) (t `(il:apply ,fn (nconc ,@(il:for f il:in body il:collect `(multiple-value-list ,f))))))) (defoptimizer not not-to-if (x) (if *new-compiler-is-expanding* `(if ,x nil t) 'pass)) (defoptimizer null null-to-if (x) (if *new-compiler-is-expanding* `(if ,x nil t) 'pass)) (defoptimizer il:\\callme (name &context ctxt) (cond ((not (eql (context-values-used ctxt) 0)) (warn "The ~S special form appeared in non-effect context." 'il:\\callme) `(progn (il:\\callme ,name) nil)) ((and (not (constantp name)) (or (atom name) (not (eq (car name) 'quote)))) (warn "The ~S special form was given an unquoted argument." 'il:\\callme) `(il:\\callme ',name)) (t 'pass))) (il:* il:|;;| "Optimizers for File Manager forms") (defvar *input-filecoms-variable* (il:* il:|;;;| "Used for communication between the optimizers on RPAQQ and PRETTYCOMPRINT so that the file coms can be eliminated from the file during compilation.") ) (defoptimizer il:rpaq (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (setq ,var ,expr)) 'pass)) (defoptimizer il:rpaq? (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (and (eq ,var 'il:nobind) (setq ,var ,expr))) 'pass)) (defoptimizer il:rpaqq (var expr &context ctxt) (if (context-top-level-p ctxt) `(locally (declare (global ,var)) (setq ,var ',expr)) 'pass)) (defoptimizer il:prettycomprint (coms-name &context ctxt) (cond ((context-top-level-p ctxt) nil) (t 'pass))) (defoptimizer il:filecreated (filedate filename &rest junk &context ctxt) (declare (ignore junk)) (if (and (context-top-level-p ctxt) filename (symbolp filename)) `(il:putprop ',(il:rootfilename filename) 'il:filedates '(,(cons filedate filename))) 'pass)) (il:* il:|;;| "Other Otimization") (defoptimizer il:\\pilotbitblt (&rest il:args) (if (and il:args (null (cdr il:args))) `(il:\\pilotbitblt ,@il:args nil) 'pass)) (il:* il:|;;| "Use the proper makefile-environment") (il:putprops il:xclc-optimizers il:makefile-environment (:readtable "XCL" :package (defpackage "COMPILER" (:use "LISP" "XCL")))) (il:* il:|;;| "Use the proper compiler.") (il:putprops il:xclc-optimizers il:filetype :compile-file) (il:putprops il:xclc-optimizers il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990)) (il:declare\: il:dontcopy (il:filemap (nil))) il:stop \ No newline at end of file diff --git a/sources/XCLC-PEEPHOLE b/sources/XCLC-PEEPHOLE new file mode 100644 index 00000000..616277e7 --- /dev/null +++ b/sources/XCLC-PEEPHOLE @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "27-Aug-91 14:38:23" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-PEEPHOLE.;9| 23880 IL:|changes| IL:|to:| (IL:FUNCTIONS PEEPHOLE-OPTIMIZE PEEPHOLE-OPTIMIZE-CODE) IL:|previous| IL:|date:| "16-Aug-91 18:52:23" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-PEEPHOLE.;8|) ; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-PEEPHOLECOMS) (IL:RPAQQ IL:XCLC-PEEPHOLECOMS ( (IL:* IL:|;;;| "Peephole Optimization") (IL:VARIABLES *REACHABLE-TAG-TABLE* *TAG-EQUIV-TABLE* *TAG-LOCATION-TABLE*) (IL:FUNCTIONS PEEPHOLE-OPTIMIZE FIND-ALL-TAGS FIND-REACHABLE-TAGS FIND-TAG-DUPLICATION PEEPHOLE-OPTIMIZE-CODE) (IL:* IL:|;;| "Arrange to use the proper compiler") (IL:PROP IL:FILETYPE IL:XCLC-PEEPHOLE) (IL:* IL:|;;| "Get the right reader environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-PEEPHOLE))) (IL:* IL:|;;;| "Peephole Optimization") (DEFVAR *REACHABLE-TAG-TABLE* NIL (IL:* IL:|;;;| "A hash-table of those tags that are reachable during execution. See FIND-REACHABLE-TAGS for details.") ) (DEFVAR *TAG-EQUIV-TABLE* NIL (IL:* IL:|;;;| "Hash table mapping LAP tag identifiers into one of two things: 1) the keyword :REFERENCES paired with a list of the jump and push-tag instructions referring to this tag, or 2) the keyword :EQUIV paired with the identifier of the representative of the tags equivalent to this one. Used in the current, ad hoc peephole-optimizer.") ) (DEFVAR *TAG-LOCATION-TABLE* NIL (IL:* IL:|;;;| "A hash-table mapping tag identifiers into the tails of code beginning with them.") ) (DEFUN PEEPHOLE-OPTIMIZE (LAP-FN) (IL:* IL:|;;|  "Extremely ad-hoc peephole optimizer for LAP code. It currently has two obligations:") (IL:* IL:|;;| " -- Eliminate jumps to the very next location. Those screw up the jump-resolution algorithm in the D-machine assembler.") (IL:* IL:|;;| " -- Eliminate unreachable code. This is necessary to make keep stack-analysis from barfing during assembly.") (IL:* IL:|;;| "") (IL:* IL:|;;| "First, optimize any local functions (e.g. FLET, LABELS, etc.):") (DESTRUCTURING-BIND ((REQUIRED &KEY OPTIONAL REST KEY ALLOW-OTHER-KEYS OTHERS NAME ARG-TYPE BLIP CLOSED-OVER NON-LOCAL LOCAL-FUNCTIONS) &REST BODY) (CDR LAP-FN) (IL:FOR LOCAL-FN IL:IN LOCAL-FUNCTIONS IL:DO (PEEPHOLE-OPTIMIZE (CADR LOCAL-FN)))) (IL:* IL:|;;| "Now peephole-optimize the main-body code for this function:") (LET ((*TAG-EQUIV-TABLE* (MAKE-HASH-TABLE :TEST 'EQL)) (*REACHABLE-TAG-TABLE* (MAKE-HASH-TABLE :TEST 'EQL)) (TAGS-USED NIL)) (DECLARE (SPECIAL TAGS-USED)) (FIND-REACHABLE-TAGS (CDDR LAP-FN)) (MULTIPLE-VALUE-BIND (NEW-CODE CHANGED-P) (PEEPHOLE-OPTIMIZE-CODE (CDDR LAP-FN)) (SETF (CDDR LAP-FN) NEW-CODE) (SETQ TAGS-USED NIL) (IF CHANGED-P (PEEPHOLE-OPTIMIZE LAP-FN) LAP-FN)))) (DEFUN FIND-ALL-TAGS (CODE) (DO* ((TAIL CODE (CDR TAIL)) (INST (CAR TAIL) (CAR TAIL))) ((ENDP TAIL)) (IL:* IL:|;;| "") (CASE (CAR INST) ((:TAG) (SETF (GETHASH (SECOND INST) *TAG-LOCATION-TABLE*) TAIL)) ((:CLOSE :LAMBDA) (FIND-ALL-TAGS (CDDR INST))) ((:CALL) (LET ((FN-TO-CALL (SECOND INST))) (WHEN (AND (CONSP FN-TO-CALL) (EQ (FIRST FN-TO-CALL) :LAMBDA)) (FIND-ALL-TAGS (CDDR FN-TO-CALL)))))))) (DEFUN FIND-REACHABLE-TAGS (CODE) (IL:* IL:|;;;| "A tag is reachable if and only if") (IL:* IL:|;;;| " -- It lies in the direct path of execution, starting at the first instruction in CODE.") (IL:* IL:|;;;| " -- It is reachable from the beginning of the inner code of a reachable :CLOSE or :LAMBDA instruction.") (IL:* IL:|;;;| " -- It is the object of a reachable :PUSH-TAG instruction.") (LET ((*TAG-LOCATION-TABLE* (MAKE-HASH-TABLE :TEST 'EQL))) (FIND-ALL-TAGS CODE) (DO ((ROOTS (LIST CODE))) ((NULL ROOTS)) (IL:* IL:|;;| "For each root found, seek out tags reachable form that root.") (ASSERT (NOT (NULL (FIRST ROOTS))) NIL "A tag was referred to but not found.") (DOLIST (INST (POP ROOTS)) (CASE (FIRST INST) ((:TAG) (IL:* IL:\;  "This is a reachable tag. If we already knew that, stop here. Else, mark it.") (IF (GETHASH (SECOND INST) *REACHABLE-TAG-TABLE*) (RETURN) (SETF (GETHASH (SECOND INST) *REACHABLE-TAG-TABLE*) T))) ((:JUMP :TJUMP :FJUMP :NTJUMP :NFJUMP :PUSH-TAG) (IL:* IL:\; "The object of the instruction is reachable, so add it to the list of roots and keep seeking from this root.") (LET ((NEW-ROOT (GETHASH (SECOND INST) *TAG-LOCATION-TABLE*))) (ASSERT (NOT (NULL NEW-ROOT)) NIL "The tag ~S was referred to but not found." (SECOND INST)) (PUSH NEW-ROOT ROOTS)) (WHEN (EQ (FIRST INST) :JUMP) (RETURN))) ((:RETURN) (IL:* IL:\;  "No more reachable tags from this root, so stop here.") (RETURN)) ((:CLOSE :LAMBDA) (IL:* IL:\;  "Add the body of the instruction to the list of roots.") (PUSH (CDDR INST) ROOTS)) ((:CALL) (LET ((FN-TO-CALL (SECOND INST))) (WHEN (AND (CONSP FN-TO-CALL) (EQ (FIRST FN-TO-CALL) :LAMBDA)) (IL:* IL:\;  "Add the body of the directly called lambda to the list of roots.") (PUSH (CDDR FN-TO-CALL) ROOTS))))))))) (DEFUN FIND-TAG-DUPLICATION (CODE) (LET ((NEW-CODE NIL) (FIND-P NIL) INST) (IL:FOR TAIL IL:ON CODE IL:EACHTIME (SETQ INST (CAR TAIL)) IL:DO (IL:* IL:|;;| "Check for unreachable code.") (UNLESS (AND (IL:FMEMB (FIRST (FIRST NEW-CODE)) '(:JUMP :RETURN)) (NOT (AND (EQ (FIRST INST) :TAG) (GETHASH (SECOND INST) *REACHABLE-TAG-TABLE*)))) (CASE (FIRST INST) ((:TAG) (IF (EQ (FIRST (FIRST NEW-CODE)) :TAG) (PROGN (SETQ FIND-P T) (RETURN))) (PUSH INST NEW-CODE)) ((:CLOSE :LAMBDA) (SETQ FIND-P (FIND-TAG-DUPLICATION (CDDR INST))) (PUSH INST NEW-CODE)) ((:CALL) (LET ((FN-TO-CALL (SECOND INST))) (WHEN (AND (CONSP FN-TO-CALL) (EQ (FIRST FN-TO-CALL) :LAMBDA)) (SETQ FIND-P (FIND-TAG-DUPLICATION (CDDR INST))) (PUSH INST NEW-CODE)))) (OTHERWISE (PUSH INST NEW-CODE))))) FIND-P)) (DEFUN PEEPHOLE-OPTIMIZE-CODE (CODE) (IL:* IL:|;;;| "Run through the given code collapsing adjacent TAGs into a single one and eliminating jumps to immediately following TAGs. Also eliminate code that cannot be reached. Return the new version of the code.") (LET ((NEW-CODE NIL) (CHANGED-P NIL) (TAG-DUPLICATED-P (FIND-TAG-DUPLICATION CODE)) INST) (IL:FOR TAIL IL:ON CODE IL:EACHTIME (SETQ INST (CAR TAIL)) IL:DO (IL:* IL:|;;| "Check for unreachable code.") (IL:* IL:|;;| "Code is unreachable if the last instruction was a JUMP or RETURN, and the next thing coming isn't a TAG that is reachable from somewhere else.") (IL:* IL:|;;| " (If dead code is removed here, that's worth a CHANGED-P indication)") (UNLESS (AND (IL:FMEMB (FIRST (FIRST NEW-CODE)) '(:JUMP :RETURN)) (NOT (AND (EQ (FIRST INST) :TAG) (GETHASH (SECOND INST) *REACHABLE-TAG-TABLE*))) (SETQ CHANGED-P T)) (CASE (FIRST INST) ((:JUMP :TJUMP :FJUMP :NTJUMP :NFJUMP :PUSH-TAG) (LET ((LOOKUP (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*))) (PUSH INST NEW-CODE) (ECASE (CAR LOOKUP) ((NIL) (IL:* IL:\; "This tag is not yet in the table. Put it in there mapping to a list of references including only this one.") (PUSHNEW (SECOND INST) TAGS-USED) (SETF (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*) (CONS :REFERENCES (LIST INST)))) ((:REFERENCES) (IL:* IL:\;  "We haven't seen the TAG for this reference yet. Add it to the list of references to that tag.") (PUSHNEW (SECOND INST) TAGS-USED) (PUSH INST (CDR LOOKUP))) ((:EQUIV) (IL:* IL:\;  "We know what the right tag for this reference is now.") (PUSHNEW (CDR LOOKUP) TAGS-USED) (SETF (SECOND INST) (CDR LOOKUP)))))) ((:TAG) (LET ((LOOKUP (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*))) (IF (EQ (FIRST (FIRST NEW-CODE)) :TAG) (PROGN (IL:* IL:|;;| "Mark this tag in the table as being equivalent either to the directly previous tag, if any, or to itself.") (SETF (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*) (CONS :EQUIV (SECOND (FIRST NEW-CODE)))) (PUSHNEW (SECOND (FIRST NEW-CODE)) TAGS-USED) (IL:* IL:|;;|  "If there were forward references to this tag, update all of them to refer to the EQUIV-TAG.") (IF (EQ (CAR LOOKUP) :REFERENCES) (IL:FOR REFERENCE IL:IN (CDR LOOKUP) IL:DO (SETF (SECOND REFERENCE) (SECOND (FIRST NEW-CODE)))) (ASSERT (NULL LOOKUP) NIL "This tag has been seen before!")) (SETQ CHANGED-P T)) (COND ((AND (NOT TAG-DUPLICATED-P) (EQ (FIRST (SECOND TAIL)) :JUMP)) (SETF (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*) (CONS :EQUIV (SECOND (SECOND TAIL)))) (IF (EQ (CAR LOOKUP) :REFERENCES) (IL:FOR REFERENCE IL:IN (CDR LOOKUP) IL:DO (WHEN (NOT (EQL (SECOND REFERENCE) (SECOND (SECOND TAIL)))) (SETF (SECOND REFERENCE) (SECOND (SECOND TAIL))) (SETQ CHANGED-P T)))) (PUSH INST NEW-CODE)) (T (SETF (GETHASH (SECOND INST) *TAG-EQUIV-TABLE*) (CONS :EQUIV (SECOND INST))) (IF (EQ (CAR LOOKUP) :REFERENCES) (IL:FOR REFERENCE IL:IN (CDR LOOKUP) IL:DO (SETF (SECOND REFERENCE) (SECOND INST))) (ASSERT (NULL LOOKUP) NIL "This tag has been seen before!")) (PUSH INST NEW-CODE))))) (IL:* IL:|;;| "If the next instruction is not a :TAG, then it's time to check for useless jumps and to eliminate them.") (WHEN (OR (NULL (CDR TAIL)) (NOT (EQ (FIRST (CDR TAIL)) :TAG))) (LOOP (IL:* IL:|;;|  "Repeatedly examine the top 2 or 3 instructions, looking for sequences") (IL:* IL:|;;| " JUMP x - TAG x or") (IL:* IL:|;;| " JUMP x - SET-STACK - TAG x") (IL:* IL:|;;| " cJUMP x - JUMP y - TAG x") (IL:* IL:|;;|  "and reducing them to just the TAG, with a POP if need be.") (LET ((TAG-INST (FIRST NEW-CODE)) (JUMP-INST (SECOND NEW-CODE)) (SET-STACK-INST (THIRD NEW-CODE))) (IF (EQL (SECOND TAG-INST) (SECOND JUMP-INST)) (IL:* IL:|;;| "Looks like something to eliminate.") (CASE (FIRST JUMP-INST) ((:JUMP) (SETF (CDR NEW-CODE) (CDDR NEW-CODE)) (SETQ CHANGED-P T)) ((:FJUMP :TJUMP) (SETF (SECOND NEW-CODE) '(:POP)) (SETQ CHANGED-P T) (RETURN)) ((:NTJUMP :NFJUMP) (ERROR "BUG: Non-popping jump to very next location." )) (OTHERWISE (IL:* IL:|;;|  "The instruction before the :TAG was not a jump, so do nothing.") (RETURN))) (IF (EQL (SECOND TAG-INST) (SECOND SET-STACK-INST)) (IL:* IL:|;;|  "Looks like it might be JUMP-SET-TAG or cJUMP - JUMP - TAG") (COND ((EQ (FIRST JUMP-INST) :DSET-STACK) (IL:* IL:|;;| "YES, it's JUMP - SET - TAG") (ROTATEF JUMP-INST SET-STACK-INST) (CASE (FIRST JUMP-INST) ((:JUMP) (SETF (CDR NEW-CODE) (CDDDR NEW-CODE)) (SETQ CHANGED-P T)) ((:FJUMP :TJUMP) (SETF (SECOND NEW-CODE) '(:POP)) (SETF (CDDR NEW-CODE) (CDDDR NEW-CODE)) (SETQ CHANGED-P T) (RETURN)) ((:NTJUMP :NFJUMP) (ERROR "BUG: Non-popping jump to very next location." )) (OTHERWISE (IL:* IL:|;;|  "The instruction before the :SET was not a jump, so do nothing.") (RETURN)))) ((EQ (FIRST JUMP-INST) :JUMP) (IL:* IL:|;;| " YES, it's cJUMP - JUMP - TAG") (CASE (FIRST SET-STACK-INST) ((:TJUMP) (RPLACA JUMP-INST :FJUMP) (SETF (CDDR NEW-CODE) (CDDDR NEW-CODE)) (SETQ CHANGED-P T)) ((:FJUMP) (RPLACA JUMP-INST :TJUMP) (SETF (CDDR NEW-CODE) (CDDDR NEW-CODE)) (SETQ CHANGED-P T)) (OTHERWISE (IL:* IL:|;;|  "The instruction before the JUMP was not a cJUMP, so do nothing") (RETURN)))) (T (IL:* IL:|;;|  "The instruction before the :TAG was not a SET, so do nothing.") (RETURN))) (IL:* IL:|;;| "Nothing (more) to get rid of, so stop.") (RETURN))))))) ((:VAR) (IL:* IL:|;;| "Eliminate any unnecesary POPs, e.g.:") (IL:* IL:|;;| "VAR_ x ; POP ; VAR x") (LET ((SET-INST (SECOND NEW-CODE)) (POP-INST (FIRST NEW-CODE))) (COND ((AND (EQ (FIRST POP-INST) :POP) (EQ (FIRST SET-INST) :VAR_) (EQL (SECOND SET-INST) (SECOND INST))) (SETF NEW-CODE (CDR NEW-CODE)) (SETQ CHANGED-P T)) (T (PUSH INST NEW-CODE))))) ((:CLOSE :LAMBDA) (MULTIPLE-VALUE-BIND (CODE-SET CHANGED?) (PEEPHOLE-OPTIMIZE-CODE (CDDR INST)) (SETF (CDDR INST) CODE-SET) (SETQ CHANGED-P (OR CHANGED-P CHANGED?))) (PUSH INST NEW-CODE)) ((:CALL) (LET ((FN-TO-CALL (SECOND INST))) (WHEN (AND (CONSP FN-TO-CALL) (EQ (FIRST FN-TO-CALL) :LAMBDA)) (MULTIPLE-VALUE-BIND (CODE-SET CHANGED?) (PEEPHOLE-OPTIMIZE-CODE (CDDR FN-TO-CALL)) (SETF (CDDR FN-TO-CALL) CODE-SET) (SETQ CHANGED-P (OR CHANGED-P CHANGED?))))) (PUSH INST NEW-CODE)) (OTHERWISE (PUSH INST NEW-CODE))))) (IL:* IL:|;;| "Now remove unused tags, and put things back into first-to-last order.") (VALUES (NREVERSE (IL:FOR INST IL:IN NEW-CODE IL:WHEN (OR (IL:NEQ (FIRST INST) :TAG) (IL:FMEMB (SECOND INST) TAGS-USED) (NOT (SETQ CHANGED-P T))) IL:COLLECT INST)) CHANGED-P))) (IL:* IL:|;;| "Arrange to use the proper compiler") (IL:PUTPROPS IL:XCLC-PEEPHOLE IL:FILETYPE COMPILE-FILE) (IL:* IL:|;;| "Get the right reader environment") (IL:PUTPROPS IL:XCLC-PEEPHOLE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-PEEPHOLE IL:COPYRIGHT ("Xerox Corporation" 1986 1987 1988 1990 1991)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-RUNTIME b/sources/XCLC-RUNTIME new file mode 100644 index 00000000..98f0b0be --- /dev/null +++ b/sources/XCLC-RUNTIME @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "23-May-90 13:18:14" |{DSK}local>lde>lispcore>sources>XCLC-RUNTIME.;2| 1859 |changes| |to:| (VARS XCLC-RUNTIMECOMS) |previous| |date:| "29-Oct-86 13:53:23" |{DSK}local>lde>lispcore>sources>XCLC-RUNTIME.;1| ) ; Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved. (PRETTYCOMPRINT XCLC-RUNTIMECOMS) (RPAQQ XCLC-RUNTIMECOMS ( (* |;;;| "Runtime support for functions compiled by the XCL compiler.") (FUNCTIONS SI::ARGUMENT-ERROR) (* |;;| "Arrange to use the proper compiler") (PROP FILETYPE XCLC-RUNTIME))) (* |;;;| "Runtime support for functions compiled by the XCL compiler.") (CL:DEFUN SI::ARGUMENT-ERROR (SI::MIN-ARGS SI::MAX-ARGS) (* |;;|  "Runtime support function for code compiled with the new compiler. MUST BE RUN COMPILED!") (LET* ((SI::FRAME (STKNTH -2)) (SI::FRAME-NAME (STKNAME SI::FRAME)) (SI::NUM-ARGS (STKNARGS SI::FRAME))) (COND ((< SI::NUM-ARGS SI::MIN-ARGS) (CL:ERROR 'TOO-FEW-ARGUMENTS :CALLEE SI::FRAME-NAME :MINIMUM SI::MIN-ARGS :ACTUAL SI::NUM-ARGS)) ((AND (NOT (NULL SI::MAX-ARGS)) (> SI::NUM-ARGS SI::MAX-ARGS)) (CL:ERROR 'TOO-MANY-ARGUMENTS :CALLEE SI::FRAME-NAME :MAXIMUM SI::MAX-ARGS :ACTUAL SI::NUM-ARGS)) (T (CL:ERROR "BUG: SI::ARGUMENT-ERROR called when no error exists!"))))) (* |;;| "Arrange to use the proper compiler") (PUTPROPS XCLC-RUNTIME FILETYPE CL:COMPILE-FILE) (PUTPROPS XCLC-RUNTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1990)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP \ No newline at end of file diff --git a/sources/XCLC-TOP-LEVEL b/sources/XCLC-TOP-LEVEL new file mode 100644 index 00000000..e60f79ae --- /dev/null +++ b/sources/XCLC-TOP-LEVEL @@ -0,0 +1,1557 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) +(IL:FILECREATED "25-Oct-94 17:07:50" IL:|{DSK}sources>XCLC-TOP-LEVEL.;2| 77450 + + IL:|changes| IL:|to:| (IL:FUNCTIONS PROCESS-FORMS) + + IL:|previous| IL:|date:| " 7-Nov-91 17:05:33" IL:|{DSK}sources>XCLC-TOP-LEVEL.;1|) + + +; Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1994 by Venue & Xerox Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:XCLC-TOP-LEVELCOMS) + +(IL:RPAQQ IL:XCLC-TOP-LEVELCOMS + ( + (IL:* IL:|;;| "Top-level entry points ") + + (IL:STRUCTURES COMPILER-CONTEXT) + (IL:VARIABLES *COMPILE-FILE-CONTEXT* *COMPILE-SCAN-CONTEXT* *COMPILE-DEFINER-CONTEXT*) + (IL:FUNCTIONS COMPILER-ERROR) + (IL:FUNCTIONS COMPILER-APPLY) + (IL:VARIABLES *EVAL-WHEN-COMPILE* *FASL-HANDLE* *INPUT-FILENAME* *INPUT-STREAM* + *LAP-STREAM* *LOAD-COMPILED-CODE* *NEW-COMPILER-IS-EXPANDING* + *OUTSTANDING-LOOSE-FORMS* *COMPILING-DEFINER* *LOOSE-NAME*) + (IL:FUNCTIONS COMPILE-FILE) + (IL:FUNCTIONS START-COMPILATION FINISH-COMPILATION) + (IL:FUNCTIONS SCAN-ONE-FORM FUNCTION-P) + (IL:FUNCTIONS COMPILER-MESSAGE COMPILING-MESSAGE DONE-MESSAGE) + (IL:COMS (IL:STRUCTURES UNKNOWN-FUNCTION-WARNING) + (IL:FUNCTIONS CHECK-FOR-UNKNOWN-FUNCTION WARN-ABOUT-UNKNOWN-FUNCTIONS)) + (IL:VARIABLES *PROCESSED-FUNCTIONS* *UNKNOWN-FUNCTIONS* *CURRENT-FUNCTION*) + (IL:COMS (IL:STRUCTURES ASSEMBLER-ERROR) + (IL:FUNCTIONS ASSEMBLER-ERROR)) + + (IL:* IL:|;;| "Reading the #, macro") + + (IL:VARIABLES *COMPILER-IS-READING*) + (IL:STRUCTURES EVAL-WHEN-LOAD) + + (IL:* IL:|;;| "Support for Block Compilation") + + (IL:VARIABLES *BLOCK-HASH-TABLE* *BLOCKS* *CURRENT-BLOCK*) + (IL:STRUCTURES BLOCK-DECL) + (IL:FUNCTIONS SET-UP-BLOCK-DECLS) + + (IL:* IL:|;;| "Processing of top-level forms in a file") + + (IL:VARIABLES PASS) + (IL:FUNCTIONS CONSTANT-EXPRESSION-P) + (IL:FUNCTIONS COMPILE-AND-DUMP COMPILE-AND-DUMP-1 COMPILE-ONE-LAMBDA) + (IL:FUNCTIONS OPTIMIZE-AND-MACROEXPAND OPTIMIZE-AND-MACROEXPAND-1 EXPAND-DEFINER + PROCESS-FORMS) + (IL:FUNCTIONS MAYBE-REMOVE-COMMENTS) + (IL:FUNCTIONS COMPILE-FILE-SETF-SYMBOL-FUNCTION COMPILE-FILE-DEFINEQ + COMPILE-FILE-DEFCONSTANT COMPILE-FILE-DECLARE\: COMPILE-FILE-DEFINE-FILE-INFO + COMPILE-FILE-PACKAGE-FORM COMPILE-FILE-PROCLAMATION COMPILE-FILE-COMPILER-LET + COMPILE-FILE-MACROLET COMPILE-FILE-DEFINER COMPILE-FILE-NAMED-PROGN + COMPILE-FILE-OUTSTANDING-LOOSE-FORMS COMPILE-FILE-LOOSE-FORM + COMPILE-FILE-PROCESS-FUNCTION) + (IL:FUNCTIONS CRACK-DEFMACRO ESTABLISH-MACRO-IN-COMPILER) + + (IL:* IL:|;;| "Support for :Process-Entire-File") + + (IL:VARIABLES *DEFERRED-FORMS* *MAKING-SECOND-PASS* *PREPROCESSING-PHASE*) + (IL:FUNCTIONS COMPILE-SCAN-DECLARE\: COMPILE-SCAN-DEFINE-FILE-INFO COMPILE-SCAN-MACROLET + COMPILE-SCAN-DEFINER COMPILE-SCAN-LOOSE-FORM COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS) + (IL:FUNCTIONS MERGE-FIRST-FORMS) + + (IL:* IL:|;;| "for compiling definers") + + (IL:VARIABLES *LAP-FLG* *AUTOMATIC-SPECIAL-DECLARATIONS*) + (IL:FUNCTIONS COMPILE COMPILE-DEFINER) + (IL:FUNCTIONS COMPILE-FORM RAW-COMPILE) + (IL:FUNCTIONS COMPILE-DEFINER-DEFINER COMPILE-DEFINER-NAMED-PROGN + COMPILE-DEFINER-PROCESS-FUNCTION COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS) + + (IL:* IL:|;;| "Arrange for correct compiler to be used.") + + (IL:PROP IL:FILETYPE IL:XCLC-TOP-LEVEL) + + (IL:* IL:|;;| "Arrange for the correct makefile environment") + + (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TOP-LEVEL))) + + + +(IL:* IL:|;;| "Top-level entry points ") + + +(DEFSTRUCT (COMPILER-CONTEXT (:FAST-ACCESSORS T) + (:CONC-NAME NIL) + (:COPIER NIL) + (:PREDICATE NIL)) + SETF-SYMBOL-FUNCTION-FN + DEFINEQ-FN + DEFCONSTANT-FN + DECLARE\:-FN + DEFINE-FILE-INFO-FN + PACKAGE-FORM-FN + PROCLAIM-FN + COMPILER-LET-FN + MACROLET-FN + DEFINER-FN + NAMED-PROGN-FN + PROCESS-FUNCTION-FN + PROCESS-LOOSE-FORM-FN + PROCESS-OUTSTANDING-LOOSE-FORMS-FN) + +(DEFPARAMETER *COMPILE-FILE-CONTEXT* + (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN + 'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN + 'COMPILE-FILE-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-FILE-DEFINE-FILE-INFO + :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION + :COMPILER-LET-FN 'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN + 'COMPILE-FILE-DEFINER :NAMED-PROGN-FN 'COMPILE-FILE-NAMED-PROGN :PROCESS-FUNCTION-FN + 'COMPILE-FILE-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM + :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-FILE-OUTSTANDING-LOOSE-FORMS)) + +(DEFPARAMETER *COMPILE-SCAN-CONTEXT* + (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-SCAN-LOOSE-FORM :DEFINEQ-FN + 'COMPILE-SCAN-LOOSE-FORM :DEFCONSTANT-FN 'COMPILE-SCAN-LOOSE-FORM :DECLARE\:-FN + 'COMPILE-SCAN-DECLARE\: :DEFINE-FILE-INFO-FN 'COMPILE-SCAN-DEFINE-FILE-INFO + :PACKAGE-FORM-FN 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION + :COMPILER-LET-FN 'COMPILE-SCAN-LOOSE-FORM :MACROLET-FN 'COMPILE-SCAN-MACROLET :DEFINER-FN + 'COMPILE-SCAN-DEFINER :NAMED-PROGN-FN 'COMPILE-SCAN-LOOSE-FORM :PROCESS-FUNCTION-FN + 'COMPILER-ERROR :PROCESS-LOOSE-FORM-FN 'COMPILE-SCAN-LOOSE-FORM + :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS)) + +(DEFPARAMETER *COMPILE-DEFINER-CONTEXT* + (MAKE-COMPILER-CONTEXT :SETF-SYMBOL-FUNCTION-FN 'COMPILE-FILE-SETF-SYMBOL-FUNCTION :DEFINEQ-FN + 'COMPILE-FILE-DEFINEQ :DEFCONSTANT-FN 'COMPILE-FILE-DEFCONSTANT :DECLARE\:-FN + 'COMPILER-ERROR :DEFINE-FILE-INFO-FN 'COMPILER-ERROR :PACKAGE-FORM-FN + 'COMPILE-FILE-PACKAGE-FORM :PROCLAIM-FN 'COMPILE-FILE-PROCLAMATION :COMPILER-LET-FN + 'COMPILE-FILE-COMPILER-LET :MACROLET-FN 'COMPILE-FILE-MACROLET :DEFINER-FN + 'COMPILE-DEFINER-DEFINER :NAMED-PROGN-FN 'COMPILE-DEFINER-NAMED-PROGN :PROCESS-FUNCTION-FN + 'COMPILE-DEFINER-PROCESS-FUNCTION :PROCESS-LOOSE-FORM-FN 'COMPILE-FILE-LOOSE-FORM + :PROCESS-OUTSTANDING-LOOSE-FORMS-FN 'COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS)) + +(DEFUN COMPILER-ERROR (COMPILER-CONTEXT &REST ARGS) + (ERROR "Unexpected compiler error. Context is ~s args are ~s" COMPILER-CONTEXT ARGS)) + +(DEFMACRO COMPILER-APPLY (KEY COMPILER-CONTEXT &OPTIONAL FORM &REST OTHER-ARGS) + (LET ((ACCESSOR (INTERN (CONCATENATE 'STRING (STRING KEY) + "-FN") + (FIND-PACKAGE "COMPILER")))) + (IF FORM + `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT) + ,COMPILER-CONTEXT + ,FORM + ,@OTHER-ARGS) + `(FUNCALL (,ACCESSOR ,COMPILER-CONTEXT) + ,COMPILER-CONTEXT)))) + +(DEFVAR *EVAL-WHEN-COMPILE* NIL + "Bound to T during processing of forms to be evaluated at compile-time.") + +(DEFVAR *FASL-HANDLE* NIL + "Handle used for writing out the code to a FASL file.") + +(DEFVAR *INPUT-FILENAME* NIL + "Full name of the file being compiled.") + +(DEFVAR *INPUT-STREAM* NIL + "Stream from which compile-file reads forms.") + +(DEFVAR *LAP-STREAM* NIL + "Stream to which compile-file writes LAP output.") + +(DEFVAR *LOAD-COMPILED-CODE* NIL + "Non-nil if new compiled code should be installed in running Lisp. + :save if old versions should be saved on the property list before installing") + +(DEFVAR *NEW-COMPILER-IS-EXPANDING* NIL + "Bound to T whenever the new compiler might be expanding macros. Used in some optimizers to let them only take effect in the new compiler." +) + +(DEFVAR *OUTSTANDING-LOOSE-FORMS* NIL + + "A list of the random top-level forms to be gathered together into a single lambda for compilation.") + +(DEFVAR *COMPILING-DEFINER* NIL) + +(DEFVAR *LOOSE-NAME* NIL) + +(DEFUN COMPILE-FILE (INPUT-FILE &KEY (OUTPUT-FILE NIL) + (LAP-FILE NIL) + (ERROR-FILE NIL) + (ERRORS-TO-TERMINAL T) + (FILE-MANAGER-FORMAT NIL F-M-F-GIVEN) + (PROCESS-ENTIRE-FILE NIL P-E-F-GIVEN) + (LOAD NIL)) + +(IL:* IL:|;;;| "Compiles the forms on Input-File, producing a FASL file.") + +(IL:* IL:|;;;| " :Output-File") + + (IL:* IL:|;;| "The name of a file to which binary code should be written.") + + (IL:* IL:|;;| " Defaults to Input-File with the extension '.dfasl'") + +(IL:* IL:|;;;| ":Lap-File") + + (IL:* IL:|;;| "The name of a file to which LAP assemble code should be written.") + + (IL:* IL:|;;| + " If T, defulats to Input-File with the extension '.dlap', if NIL, no LAP file is produced.") + +(IL:* IL:|;;;| ":Error-FIle") + + (IL:* IL:|;;| "The name of a file to which compiler error messages should be written. Defaults like :Lap-File, but with the extension '.log'") + +(IL:* IL:|;;;| ":Errors-To-Terminal") + + (IL:* IL:|;;| + "True if error messages should be sent to *ERROR-OUTPUT* as well as any :Error-File.") + +(IL:* IL:|;;;| ":File-Manager-Format") + + (IL:* IL:|;;| + "True if the file should be assumed to have been produced by the MAKEFILE function.") + + (IL:* IL:|;;| "If not specified, we check the first non-blank character in the file. If that character is a left-paren, we assume that MAKEFILE made the file.") + +(IL:* IL:|;;;| ":Process-Entire-File") + + (IL:* IL:|;;| "If true, the whole file is read in, evaluating those forms which are explicitly or implicitly EVAL-WHEN (OMPILE), before any code is generated. This allows macros to be defined after use, for example. This defaults to T if the file is declared or discovered to be in Interlisp format.") + +(IL:* IL:|;;;| ":Load") + + (IL:* IL:|;;| "If true, definitions will be installed in the environment after they are compiled. If this is :SAVE, the any previous definitions are saved on the property list before the new ones are installed.") + + (LET ((*ERROR-OUTPUT* *ERROR-OUTPUT*) + (*INPUT-STREAM* NIL) + (*INPUT-FILENAME* NIL) + (*FASL-HANDLE* NIL) + (FASL-PATHNAME NIL) + (*LAP-STREAM* NIL) + (ERROR-FILE-STREAM NIL) + (COMPILATION-SUCCEEDED NIL) + (*LOAD-COMPILED-CODE* LOAD) + (*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0)) + (*ENVIRONMENT* (MAKE-ENV :PARENT T)) + (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) + (*OUTSTANDING-LOOSE-FORMS* NIL) + (*PROCESSED-FUNCTIONS* NIL) + (*UNKNOWN-FUNCTIONS* NIL) + (*INPUT-FILECOMS-VARIABLE* NIL) (IL:* IL:\; + "Bound for the convenience of the optimizers on RPAQQ and PRETTYCOMPRINT.") + + (IL:* IL:|;;| "Rebind all of these both to set up a canonical environment inside the compiler and to protect the outside environment from anything that might happen during this file.") + + (IL:SPECVARS T) + (IL:LOCALVARS IL:SYSLOCALVARS) + (IL:LOCALFREEVARS NIL) + (IL:GLOBALVARS IL:GLOBALVARS) + (IL:NLAMA IL:NLAMA) + (IL:NLAML IL:NLAML) + (IL:LAMA IL:LAMA) + (IL:DONTCOMPILEFNS IL:DONTCOMPILEFNS)) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS IL:NLAMA + IL:NLAML IL:LAMA IL:DONTCOMPILEFNS)) + (UNWIND-PROTECT + (PROGN + (IL:* IL:|;;| "Set up the input stream.") + + (LET ((PATH (OR (PROBE-FILE INPUT-FILE) + (PROBE-FILE (MERGE-PATHNAMES INPUT-FILE ".lisp"))))) + (COND + (PATH (SETQ *INPUT-FILENAME* PATH) + (SETQ *INPUT-STREAM* (OPEN PATH :DIRECTION :INPUT)) + (WHEN (AND (FBOUNDP 'IL:OPENTEXTSTREAM) + (FBOUNDP 'IL:\\TEDIT.FORMATTEDP1) + (IF (IL:RANDACCESSP *INPUT-STREAM*) + (IL:\\TEDIT.FORMATTEDP1 *INPUT-STREAM*) + (WITH-OPEN-FILE (TEMP-STREAM *INPUT-STREAM*) + (IL:\\TEDIT.FORMATTEDP1 TEMP-STREAM)))) + (SETQ *INPUT-STREAM* (IL:OPENTEXTSTREAM *INPUT-STREAM* NIL NIL + NIL '(IL:READONLY T))))) + (T (ERROR "The file \"~A\" is nonexistent or cannot be read.~%" INPUT-FILE + )))) + + (IL:* IL:|;;| "Set up the FASL output stream.") + + (SETQ FASL-PATHNAME (COND + (OUTPUT-FILE (PATHNAME OUTPUT-FILE)) + (T (MAKE-PATHNAME :TYPE + (STRING (LOCALLY (DECLARE (SPECIAL + IL:FASL.EXT) + ) + IL:FASL.EXT)) + :VERSION :NEWEST :DEFAULTS *INPUT-FILENAME*)))) + (SETQ *FASL-HANDLE* (FASL:OPEN-FASL-HANDLE FASL-PATHNAME)) + + (IL:* IL:|;;| "Set up the LAP stream.") + + (WHEN LAP-FILE + (SETQ *LAP-STREAM* (OPEN (IF (EQ LAP-FILE T) + (MAKE-PATHNAME :TYPE "dlap" :VERSION :NEWEST + :DEFAULTS *INPUT-FILENAME*) + LAP-FILE) + :DIRECTION :OUTPUT))) + + (IL:* IL:|;;| "Set up the error output stream.") + + (WHEN ERROR-FILE + (SETQ ERROR-FILE-STREAM (OPEN (IF (EQ ERROR-FILE T) + (MAKE-PATHNAME :TYPE "log" :VERSION :NEWEST + :DEFAULTS *INPUT-FILENAME*) + ERROR-FILE) + :DIRECTION :OUTPUT))) + (SETQ *ERROR-OUTPUT* (IF ERRORS-TO-TERMINAL + (IF ERROR-FILE-STREAM + (MAKE-BROADCAST-STREAM ERROR-FILE-STREAM + *ERROR-OUTPUT*) + *ERROR-OUTPUT*) + ERROR-FILE-STREAM)) + + (IL:* IL:|;;| + "Fix up the default values of FILE-MANAGER-FORMAT and PROCESS-ENTIRE-FILE.") + + (IF (NOT F-M-F-GIVEN) + (SETQ FILE-MANAGER-FORMAT (EQ (IL:SKIPSEPRCODES *INPUT-STREAM* IL:FILERDTBL) + (IL:CHARCODE "(")))) + (IF (NOT P-E-F-GIVEN) + (SETQ PROCESS-ENTIRE-FILE FILE-MANAGER-FORMAT)) + + (IL:* IL:|;;| "Pick the right readtable and do the compilation.") + + (IL:WITH-READER-ENVIRONMENT (IF FILE-MANAGER-FORMAT + IL:*OLD-INTERLISP-READ-ENVIRONMENT* + IL:*COMMON-LISP-READ-ENVIRONMENT*) + (START-COMPILATION) + (PROCESS-FORMS PROCESS-ENTIRE-FILE) + (FINISH-COMPILATION) + (SETQ COMPILATION-SUCCEEDED T) + + (IL:* IL:|;;| + "Return the DFASL pathname so that people can say, for example, (LOAD (COMPILE-FILE ...))") + + FASL-PATHNAME)) + + (IL:* IL:|;;| "The compilation is over. Close all of the streams. If the compilations did not succeed (that is, we have aborted it), then delete the FASL file as well rather than leave garbage around.") + + (IF (STREAMP *INPUT-STREAM*) + (CLOSE *INPUT-STREAM*)) + (IF (NOT (NULL *FASL-HANDLE*)) + (FASL:CLOSE-FASL-HANDLE *FASL-HANDLE* :ABORT (NOT COMPILATION-SUCCEEDED))) + (IF (STREAMP ERROR-FILE-STREAM) + (CLOSE ERROR-FILE-STREAM)) + (IF (STREAMP *LAP-STREAM*) + (CLOSE *LAP-STREAM*))))) + +(DEFUN START-COMPILATION () + +(IL:* IL:|;;;| "Write out banners on the various output files.") + + (FLET ((DATE-STRING (UNIV-TIME) + (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOUR DATE MONTH YEAR DAY-OF-WEEK) + (DECODE-UNIVERSAL-TIME UNIV-TIME) + (FORMAT NIL "~A, ~D ~A ~D, ~D:~2,'0D:~2,'0D" + (NTH DAY-OF-WEEK '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" + "Saturday" "Sunday")) + DATE + (NTH (1- MONTH) + '("January" "February" "March" "April" "May" "June" "July" + "August" "September" "October" "November" "December")) + YEAR HOUR MINUTES SECONDS)))) + (LET ((FASL-STREAM (FASL:BEGIN-TEXT *FASL-HANDLE*))) + (FORMAT FASL-STREAM + "XCL Compiler output for source file ~A~%~ +Source file created ~A.~%~ +FASL file created ~A.~%" (NAMESTRING *INPUT-FILENAME*) + (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*)) + (DATE-STRING (GET-UNIVERSAL-TIME)))) + (FASL:BEGIN-BLOCK *FASL-HANDLE*) + (WHEN (STREAMP *LAP-STREAM*) + (FORMAT *LAP-STREAM* + "XCL Compiler output for source file ~A~%~ +Source file created ~A.~%~ +LAP file created ~A.~%~%" (NAMESTRING *INPUT-FILENAME*) + (DATE-STRING (FILE-WRITE-DATE *INPUT-FILENAME*)) + (DATE-STRING (GET-UNIVERSAL-TIME)))))) + +(DEFUN FINISH-COMPILATION () + +(IL:* IL:|;;;| "Clean up after the compilation.") + + (IL:* IL:|;;| "Remove this file from IL:NOTCOMPILEDFILES for CLEANUP.") + + (LOCALLY (DECLARE (IL:GLOBALVARS IL:NOTCOMPILEDFILES)) + (SETQ IL:NOTCOMPILEDFILES (REMOVE (INTERN (LET ((TYPE (PATHNAME-TYPE *INPUT-FILENAME*))) + (STRING-UPCASE (IF (ZEROP (LENGTH TYPE)) + (PATHNAME-NAME + *INPUT-FILENAME*) + (FORMAT NIL "~A.~A" + (PATHNAME-NAME + *INPUT-FILENAME*) + TYPE)))) + "INTERLISP") + IL:NOTCOMPILEDFILES))) + + (IL:* IL:|;;| "Possibly warn about unknown functions encountered during compilation.") + + (WARN-ABOUT-UNKNOWN-FUNCTIONS)) + +(DEFUN SCAN-ONE-FORM (FORM COMPILER-CONTEXT) + + (IL:* IL:|;;| "Assumes sedit like comments have already been stripped ") + + (IF (ATOM FORM) + FORM + (CASE (CAR FORM) + ((IL:FUNCTION FUNCTION QUOTE) (EVAL FORM)) + ((PROGN) (LET ((VALUE NIL)) + (DOLIST (SUB-FORM (CDR FORM)) + (SETQ VALUE (SCAN-ONE-FORM SUB-FORM COMPILER-CONTEXT))) + VALUE)) + ((DEFMACRO) (LET ((NAME (SECOND FORM))) + (COND + ((NOT (SYMBOLP NAME)) + (CERROR "Ignore this DEFMACRO." "~S is not a legal macro name." NAME) + ) + (T (UNLESS *MAKING-SECOND-PASS* + (ESTABLISH-MACRO-IN-COMPILER NAME (CRACK-DEFMACRO + FORM))) + (SCAN-ONE-FORM (OPTIMIZE-AND-MACROEXPAND-1 FORM) + COMPILER-CONTEXT))))) + ((EVAL-WHEN) (IF (NOT (AND (LISTP (SECOND FORM)) + (NOT (EQ 'QUOTE (CAR (SECOND FORM)))))) + (CERROR "Ignore its contents." "Ill-formed EVAL-WHEN:~%~S" FORM) + (LET ((EVAL-SPECIFIED (OR (MEMBER 'IL:EVAL (CADR FORM) + :TEST + #'EQ) + (MEMBER 'EVAL (CADR FORM) + :TEST + #'EQ))) + (LOAD-SPECIFIED (OR (MEMBER 'IL:LOAD (CADR FORM) + :TEST + #'EQ) + (MEMBER 'LOAD (CADR FORM) + :TEST + #'EQ))) + (COMPILE-SPECIFIED (OR (MEMBER 'IL:COMPILE (CADR FORM) + :TEST + #'EQ) + (MEMBER 'COMPILE (CADR FORM) + :TEST + #'EQ)))) + (COND + ((NOT LOAD-SPECIFIED) + (WHEN (OR COMPILE-SPECIFIED (AND *EVAL-WHEN-COMPILE* + EVAL-SPECIFIED)) + (LET ((VALUE NIL)) + (DOLIST (INNER-FORM (CDDR FORM)) + (SETQ VALUE (EVAL INNER-FORM))) + VALUE))) + (T (LET ((*EVAL-WHEN-COMPILE* (OR COMPILE-SPECIFIED + (AND *EVAL-WHEN-COMPILE* + EVAL-SPECIFIED)))) + (LET ((VALUE NIL)) + (DOLIST (SUB-FORM (CDDR FORM)) + (SETQ VALUE (SCAN-ONE-FORM SUB-FORM + COMPILER-CONTEXT))) + VALUE))))))) + ((DEFCONSTANT) (COMPILER-APPLY DEFCONSTANT COMPILER-CONTEXT FORM)) + ((IL:DECLARE\:) (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT FORM)) + ((IL:SETF-SYMBOL-FUNCTION) (COMPILER-APPLY IL:SETF-SYMBOL-FUNCTION COMPILER-CONTEXT + FORM)) + ((IL:DEFINEQ) (COMPILER-APPLY IL:DEFINEQ COMPILER-CONTEXT FORM)) + ((IL:DEFINE-FILE-INFO) (COMPILER-APPLY IL:DEFINE-FILE-INFO COMPILER-CONTEXT FORM)) + ((MAKE-PACKAGE IN-PACKAGE SHADOW SHADOWING-IMPORT EXPORT UNEXPORT USE-PACKAGE + UNUSE-PACKAGE IMPORT DEFPACKAGE) (COMPILER-APPLY PACKAGE-FORM COMPILER-CONTEXT + FORM)) + ((PROCLAIM) (COMPILER-APPLY PROCLAIM COMPILER-CONTEXT FORM)) + ((COMPILER-LET) (COMPILER-APPLY COMPILER-LET COMPILER-CONTEXT FORM)) + ((MACROLET SI::%MACROLET) (COMPILER-APPLY MACROLET COMPILER-CONTEXT FORM)) + ((DEFINER) (COMPILER-APPLY DEFINER COMPILER-CONTEXT FORM)) + ((NAMED-PROGN) (COMPILER-APPLY NAMED-PROGN COMPILER-CONTEXT FORM)) + (OTHERWISE (IF *MAKING-SECOND-PASS* + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) + (MULTIPLE-VALUE-BIND (NEW-FORM CHANGED-P) + (OPTIMIZE-AND-MACROEXPAND-1 FORM) + (IF (NOT CHANGED-P) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) + (SCAN-ONE-FORM NEW-FORM COMPILER-CONTEXT)))))))) + +(DEFUN FUNCTION-P (FORM) + (AND (CONSP FORM) + (OR (EQ (FIRST FORM) + 'FUNCTION) + (EQ (FIRST FORM) + 'IL:FUNCTION)) + (CONSP (SECOND FORM)))) + +(DEFMACRO COMPILER-MESSAGE (FORMAT-STRING &REST FORMAT-ARGS) + `(FORMAT *ERROR-OUTPUT* ,FORMAT-STRING ,@FORMAT-ARGS)) + +(DEFMACRO COMPILING-MESSAGE (NAME) + `(COMPILER-MESSAGE "Compiling ~a " ,NAME)) + +(DEFMACRO DONE-MESSAGE () + `(COMPILER-MESSAGE " Done~%")) + +(DEFINE-CONDITION UNKNOWN-FUNCTION-WARNING (WARNING) + (CALL-LIST) + (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) + (FORMAT T + "The following functions were called in the code just compiled, but are not known to exist:~%" + ) + (DOLIST (PAIR (UNKNOWN-FUNCTION-WARNING-CALL-LIST CONDITION)) + (FORMAT T " ~S -- called from " (CAR PAIR)) + + (IL:* IL:|;;| + "I almost used this hairy thing, but FORMAT is too slow... Aren't you glad?") + + (IL:* IL:|;;| + "\"~:[nowhere?!~;~:*~{~#[~;~S~;~S and ~S~:;~@{~#[~;and ~]~S~^, ~}~]~}.~]~%\"") + + (COND + ((NULL (CDR PAIR)) + (FORMAT T "nowhere?!~%")) + ((NULL (CDDR PAIR)) + (FORMAT T "~S.~%" (SECOND PAIR))) + ((NULL (CDDDR PAIR)) + (FORMAT T "~S and ~S.~%" (SECOND PAIR) + (THIRD PAIR))) + (T (DO ((TAIL (CDR PAIR) + (CDR TAIL))) + ((NULL TAIL)) + (PRIN1 (CAR TAIL)) + (COND + ((CDDR TAIL) + (PRINC ", ")) + ((CDR TAIL) + (PRINC " and ")))) + (PRINC ".") + (TERPRI))))))) + +(DEFUN CHECK-FOR-UNKNOWN-FUNCTION (NAME) + (WHEN (AND (NOT (FBOUNDP NAME)) + (NOT (MEMBER NAME *PROCESSED-FUNCTIONS* :TEST 'EQ)) + (OR (ENV-INLINE-DISALLOWED *ENVIRONMENT* NAME) + (NOT (OR (GET NAME 'OPTIMIZER-LIST) + (GET NAME 'TRANSFORM) + (GET NAME 'IL:DOPVAL))))) + (LET ((LOOKUP (ASSOC NAME *UNKNOWN-FUNCTIONS* :TEST 'EQ))) + (IF (NULL LOOKUP) + (PUSH (LIST NAME *CURRENT-FUNCTION*) + *UNKNOWN-FUNCTIONS*) + (PUSHNEW *CURRENT-FUNCTION* (CDR LOOKUP)))))) + +(DEFUN WARN-ABOUT-UNKNOWN-FUNCTIONS () + +(IL:* IL:|;;;| "If there's anything on *UNKNOWN-FUNCTIONS*, issue a summary and warning.") + + (WHEN (NOT (NULL *UNKNOWN-FUNCTIONS*)) + (WARN 'UNKNOWN-FUNCTION-WARNING :CALL-LIST *UNKNOWN-FUNCTIONS*))) + +(DEFVAR *PROCESSED-FUNCTIONS* + +(IL:* IL:|;;;| "A list of the names of the global functions processed during this compilation. Used in conjunction with *UNKNOWN-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") + + ) + +(DEFVAR *UNKNOWN-FUNCTIONS* + +(IL:* IL:|;;;| "A list containing the names of undefined global functions called from code in the current compilation. Actually, it's an AList mapping the unknown function to the list of functions in which it is called. Used in conjunction with *PROCESSED-FUNCTIONS* to produce a warning at the end of compilation if there are any functions called but not defined.") + + ) + +(DEFVAR *CURRENT-FUNCTION* + +(IL:* IL:|;;;| "The name of the unit currently being compiled.") + + ) + +(DEFINE-CONDITION ASSEMBLER-ERROR + +(IL:* IL:|;;;| "Signalled by an assembler when it encounters an unrecoverable error. The compiler catches such, prints an error message, and continues with the next form on the file.") + + (ERROR) + (FORMAT-STRING FORMAT-ARGUMENTS) + (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) + (FORMAT *ERROR-OUTPUT* "Error during assembly:~% ~?" ( + ASSEMBLER-ERROR-FORMAT-STRING + CONDITION) + (ASSEMBLER-ERROR-FORMAT-ARGUMENTS CONDITION))))) + +(DEFUN ASSEMBLER-ERROR (STRING &REST ARGUMENTS) + (ERROR 'ASSEMBLER-ERROR :FORMAT-STRING STRING :FORMAT-ARGUMENTS ARGUMENTS)) + + + +(IL:* IL:|;;| "Reading the #, macro") + + +(DEFVAR *COMPILER-IS-READING* NIL + "Bound to T during compile-file so that READ can properly treat #,") + +(DEFSTRUCT EVAL-WHEN-LOAD + "Structure wrapping a form to be evaluated at load time. Used in the implementation of the #, reader macro." + IL:FORM) + + + +(IL:* IL:|;;| "Support for Block Compilation") + + +(DEFVAR *BLOCK-HASH-TABLE* NIL + +(IL:* IL:|;;;| "A mapping from function names to lists of BLOCK-DECL structures describing blocks that include that function. Initialized from the list of BLOCK: declarations gathered into *BLOCKS* (q.v.) during the preprocessing scan.") + + ) + +(DEFVAR *BLOCKS* NIL + +(IL:* IL:|;;;| "A list of the Interlisp block descriptions found on the file. This list is added to during the preprocessing scan of the file and then used for initialising *BLOCK-HASH-TABLE* (q.v.)") + + ) + +(DEFVAR *CURRENT-BLOCK* NIL + +(IL:* IL:|;;;| "Bound during compilation of a LAMBDA to the BLOCK-DECL structure describing the block containing the current function. This is NIL if the function is not a part of any block.") + + ) + +(DEFSTRUCT (BLOCK-DECL (:INLINE NIL)) + +(IL:* IL:|;;;| +"A BLOCK-DECL holds the information describing a particular Interlisp BLOCK: declaration.") + +(IL:* IL:|;;;| "NAME is the symbol naming the block or NIL if this is only a pseudo-block.") + +(IL:* IL:|;;;| +"FN-NAME-MAP is an AList mapping internal function names to their new \\BLOCK/FN style name.") + +(IL:* IL:|;;;| "SPECVARS, LOCALVARS, LOCALFREEVARS and GLOBALVARS contain the values those variables should have during the compilation of functions in this block.") + + NAME + FN-NAME-MAP + SPECVARS + LOCALVARS + LOCALFREEVARS + GLOBALVARS) + +(DEFUN SET-UP-BLOCK-DECLS (DECLS) + +(IL:* IL:|;;;| "Parse the given list of Interlisp BLOCK: declarations and return a hash-table mapping functions named therein to a list of the BLOCK-DECLs representing decls mentioning that function.") + + (LET ((HASH-TABLE (MAKE-HASH-TABLE))) + (DOLIST (DECL DECLS) + (LET* ((BLOCK-NAME (CAR DECL)) + (BD (MAKE-BLOCK-DECL :NAME BLOCK-NAME)) + (IL:SPECVARS IL:SPECVARS) + (IL:LOCALVARS IL:LOCALVARS) + (IL:LOCALFREEVARS NIL) + (IL:GLOBALVARS IL:GLOBALVARS) + (NOT-RENAMED-FNS (CONS BLOCK-NAME (UNION IL:RETFNS IL:NOLINKFNS))) + (FNS NIL)) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS + IL:NOLINKFNS)) + + (IL:* IL:|;;| "We do this next bit because BCOMPL2 does it.") + + (COND + ((NULL BLOCK-NAME) + (SETQ IL:SPECVARS T) + (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) + (T (SETQ IL:LOCALVARS T) + (SETQ IL:SPECVARS IL:SYSSPECVARS))) + + (IL:* IL:|;;| "For each item in the declaration, either add it to the list of functions or make the appropriate modifications to the named variable.") + + (DOLIST (ITEM (CDR DECL)) + (COND + ((SYMBOLP ITEM) + (PUSH ITEM FNS) + (PUSH BD (GETHASH ITEM HASH-TABLE))) + ((CONSP ITEM) + (CASE (CAR ITEM) + ((IL:SPECVARS IL:LOCALVARS) (IL:EVAL ITEM)) + ((IL:GLOBALVARS IL:LOCALFREEVARS) + (LET ((VARIABLE (CAR ITEM)) + (VALUE (CDR ITEM))) + (WHEN (AND (CONSP VALUE) + (EQ (CAR VALUE) + 'IL:*)) + (SETQ VALUE (IL:EVAL (CADR VALUE)))) + (IF (LISTP VALUE) + (SET VARIABLE (UNION (CDR ITEM) + (SYMBOL-VALUE (CAR ITEM)))) + (SET VARIABLE VALUE)))) + ((IL:BLKLIBRARY IL:LINKFNS) (WARN + "The ~S feature is no longer supported." + (CAR ITEM))) + ((IL:DONTCOMPILEFNS) (WARN + "DONTCOMPILEFNS is not supported in BLOCK: declarations." + )) + ((IL:BLKAPPLYFNS IL:NOLINKFNS IL:RETFNS IL:ENTRIES) + (IL:* IL:\; + "These functions should not be renamed, according to BYTEBLOCKCOMPILE2.") + (WHEN (CONSP (CDR ITEM)) + (SETQ NOT-RENAMED-FNS (APPEND (CDR ITEM) + NOT-RENAMED-FNS)))) + (OTHERWISE (CERROR "Ignore the unknown variable." + "Unknown variable ~S mentioned in a BLOCK: declaration" + (CAR ITEM))))) + (T (CERROR "Ignore the illegal item" + "Illegal item in a BLOCK: declaration: ~S" ITEM)))) + (SETF (BLOCK-DECL-SPECVARS BD) + IL:SPECVARS) + (SETF (BLOCK-DECL-LOCALVARS BD) + IL:LOCALVARS) + (SETF (BLOCK-DECL-LOCALFREEVARS BD) + IL:LOCALFREEVARS) + (SETF (BLOCK-DECL-GLOBALVARS BD) + IL:GLOBALVARS) + (LET* ((BLOCK-NAME-STRING (STRING BLOCK-NAME)) + (BLOCK-PACKAGE (SYMBOL-PACKAGE BLOCK-NAME))) + (UNLESS (NULL BLOCK-NAME) (IL:* IL:\; + "NIL blocks don't do renaming.") + (SETF (BLOCK-DECL-FN-NAME-MAP BD) + (IL:|for| FN IL:|in| (NSET-DIFFERENCE FNS NOT-RENAMED-FNS) + IL:|collect| (CONS FN (INTERN (CONCATENATE 'STRING "\\" + BLOCK-NAME-STRING "/" + (STRING FN)) + BLOCK-PACKAGE)))))))) + HASH-TABLE)) + + + +(IL:* IL:|;;| "Processing of top-level forms in a file") + + +(DEFCONSTANT PASS 'PASS "Useful for ameliorating the obvious quoting bug.") + +(DEFUN CONSTANT-EXPRESSION-P (FORM) + (OR (CONSTANTP FORM) + (AND (CONSP FORM) + (LET* ((FN (CAR FORM)) + (S-E-DATA (GET FN 'SIDE-EFFECTS-DATA))) + (AND (EQ (CAR S-E-DATA) + :NONE) + (EQ (CDR S-E-DATA) + :NONE) + (DOLIST (ARG (CDR FORM) + T) + (IF (NOT (CONSTANT-EXPRESSION-P ARG)) + (RETURN NIL)))))))) + +(DEFUN COMPILE-AND-DUMP (NAME DEFN KIND) + (LET ((*CURRENT-BLOCK* NIL) (IL:* IL:\; + "So that we aren't dependent upon the top-level binding.") + ) + (COND + ((AND (SYMBOLP NAME) + (EQ KIND :FUNCTION)) + (WHEN (MEMBER NAME IL:DONTCOMPILEFNS :TEST 'EQ) + (RETURN-FROM COMPILE-AND-DUMP)) + (LET ((BD-LIST (AND *BLOCK-HASH-TABLE* (GETHASH NAME *BLOCK-HASH-TABLE*)))) + (COND + ((NULL BD-LIST) + (COMPILE-AND-DUMP-1 NAME DEFN KIND)) + (T (DOLIST (*CURRENT-BLOCK* BD-LIST) + (LET* ((LOOKUP (ASSOC NAME (BLOCK-DECL-FN-NAME-MAP *CURRENT-BLOCK*))) + (NEW-NAME (IF (NULL LOOKUP) + NAME + (CDR LOOKUP))) + (IL:SPECVARS (BLOCK-DECL-SPECVARS *CURRENT-BLOCK*)) + (IL:LOCALVARS (BLOCK-DECL-LOCALVARS *CURRENT-BLOCK*)) + (IL:LOCALFREEVARS (BLOCK-DECL-LOCALFREEVARS *CURRENT-BLOCK*)) + (IL:GLOBALVARS (BLOCK-DECL-GLOBALVARS *CURRENT-BLOCK*))) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS + IL:GLOBALVARS)) + (COMPILE-AND-DUMP-1 NEW-NAME DEFN KIND))))))) + (T (COMPILE-AND-DUMP-1 NAME DEFN KIND))))) + +(DEFUN COMPILE-AND-DUMP-1 (NAME DEFN KIND) + (WHEN (EQ KIND :FUNCTION) + (PUSH NAME *PROCESSED-FUNCTIONS*) + (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR))) + (LET* ((*CURRENT-FUNCTION* NAME) + (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFN)) + DCODE) + (WHEN (STREAMP *LAP-STREAM*) + (PPRINT LAP-FN *LAP-STREAM*) + (TERPRI *LAP-STREAM*) + (TERPRI *LAP-STREAM*)) + (PRINC ".") + (IL:BLOCK) + (CONDITION-CASE (SETQ DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN)) + (ASSEMBLER-ERROR (CONDITION) + (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION) + (PRINC "Aborted.") + (TERPRI) + (RETURN-FROM COMPILE-AND-DUMP-1 NIL))) + (PRINC ".") + (IL:BLOCK) + (ECASE KIND + ((:FUNCTION) (FASL:DUMP-FUNCTION-DEF *FASL-HANDLE* DCODE NAME)) + ((:ONE-SHOT) (FASL:DUMP-FUNCALL *FASL-HANDLE* DCODE))) + (PRINC ".") + (IL:BLOCK) + (WHEN (NOT (NULL *LOAD-COMPILED-CODE*)) + (ECASE KIND + (:FUNCTION + (WHEN (AND (EQ :SAVE *LOAD-COMPILED-CODE*) + (FBOUNDP NAME) + (CONSP (SYMBOL-FUNCTION NAME)) + (NOT (IL:HASDEF NAME 'IL:FUNCTIONS))) + (SETF (GET NAME 'IL:EXPR) + (SYMBOL-FUNCTION NAME))) + (SETF (SYMBOL-FUNCTION NAME) + (D-ASSEM:INTERN-DCODE DCODE))) + (:ONE-SHOT (LET ((IL:FILEPKGFLG NIL)) (IL:* IL:\; + "so that things don't get marked as changed when you execute the one-shot.") + (DECLARE (SPECIAL IL:FILEPKGFLG)) + (FUNCALL (D-ASSEM:INTERN-DCODE DCODE)))))))) + +(DEFUN COMPILE-ONE-LAMBDA (NAME DEFN) + +(IL:* IL:|;;;| "Return a LAP function for the given function definition. NAME is the symbol with which the definition will be associated at load time and DEFN is the LAMBDA-expression to be compiled.") + + (LET ((*CONTEXT* *NULL-CONTEXT*) + (*AUTOMATIC-SPECIAL-DECLARATIONS* NIL)) + (LET ((TREE (ALPHA-LAMBDA DEFN :NAME NAME)) + LAP-CODE) + (UNWIND-PROTECT + (SETQ LAP-CODE (PEEPHOLE-OPTIMIZE (GENERATE-CODE (ANNOTATE-TREE (META-EVALUATE + TREE))))) + (RELEASE-TREE TREE)) + LAP-CODE))) + +(DEFUN OPTIMIZE-AND-MACROEXPAND (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) + (CONTEXT *CONTEXT*)) + +(IL:* IL:|;;;| "Analagous to MACROEXPAND: keep trying OPTIMIZE-AND-MACROEXPAND-1 until it fails to change the form.") + + (PROG (NEW-FORM CHANGED-P) + (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) + (OPTIMIZE-AND-MACROEXPAND-1 FORM ENVIRONMENT CONTEXT)) + (UNLESS CHANGED-P + (RETURN (VALUES FORM NIL))) + LOOP + (MULTIPLE-VALUE-SETQ (NEW-FORM CHANGED-P) + (OPTIMIZE-AND-MACROEXPAND-1 NEW-FORM ENVIRONMENT CONTEXT)) + (IF CHANGED-P + (GO LOOP) + (RETURN (VALUES NEW-FORM T))))) + +(DEFUN OPTIMIZE-AND-MACROEXPAND-1 (FORM &OPTIONAL (ENVIRONMENT *ENVIRONMENT*) + (CONTEXT *CONTEXT*)) + +(IL:* IL:|;;;| "If the given form is a list, then look for macros and optimizers defined for its CAR. Return two values like MACROEXPAND-1.") + + (LET ((*NEW-COMPILER-IS-EXPANDING* T)) + (COND + ((OR (ATOM FORM) + (NOT (SYMBOLP (CAR FORM)))) + (VALUES FORM NIL)) + (T + (IL:* IL:|;;| "Check for compiler optimizers.") + + (LET ((OPTIMIZERS (OPTIMIZER-LIST (CAR FORM)))) + (WHEN (AND (NOT (NULL OPTIMIZERS)) + (NOT (ENV-FBOUNDP ENVIRONMENT (CAR FORM) + :LEXICAL-ONLY T)) + (NOT (ENV-INLINE-DISALLOWED ENVIRONMENT (CAR FORM)))) + (IL:* IL:\; + "Optimizers cannot apply to lexical functions or macros or to functions declared NOTINLINE.") + (DOLIST (OPT-FN OPTIMIZERS) + (LET ((RESULT (FUNCALL OPT-FN FORM ENVIRONMENT CONTEXT))) + (UNLESS (OR (EQ RESULT 'PASS) + (EQ RESULT 'IL:IGNOREMACRO) + (EQ RESULT FORM))(IL:* IL:\; "This optimizer fired.") + (RETURN-FROM OPTIMIZE-AND-MACROEXPAND-1 (VALUES RESULT T))))))) + + (IL:* IL:|;;| "Check for a macro expansion function.") + + (MACROEXPAND-1 FORM ENVIRONMENT))))) + +(DEFMACRO EXPAND-DEFINER (DEFINER BODY-WITHOUT-COMMENTS &OPTIONAL ENVIRONMENT) + `(LET ((*NEW-COMPILER-IS-EXPANDING* T)) + (XCL::%EXPAND-DEFINER ,DEFINER ,BODY-WITHOUT-COMMENTS ,ENVIRONMENT))) + +(DEFUN PROCESS-FORMS (PROCESS-ENTIRE-FILE) + (LET + ((*DEFERRED-FORMS* NIL) + (*BLOCKS* NIL) + (*BLOCK-HASH-TABLE* NIL) + (*PREPROCESSING-PHASE* PROCESS-ENTIRE-FILE) + (EOF-VALUE '(NIL)) + FORM) + (LOOP (IL:SKIPSEPRS *INPUT-STREAM*) + (WHEN (IL:EOFP *INPUT-STREAM*) + (RETURN)) + (SETQ FORM (LET ((*COMPILER-IS-READING* T)) + (READ *INPUT-STREAM* NIL EOF-VALUE))) + (WHEN (EQ FORM EOF-VALUE) + (RETURN)) + (IF PROCESS-ENTIRE-FILE + (LET ((NEW-FORM (CASE (AND (CONSP FORM) + (CAR FORM)) + (IL:PRETTYCOMPRINT + (SETQ *INPUT-FILECOMS-VARIABLE* (CADR FORM)) + NIL) + (IL:RPAQQ (IF (EQ (SECOND FORM) + *INPUT-FILECOMS-VARIABLE*) + + (IL:* IL:|;;| + "Don't remove comments from file coms") + + FORM + (REMOVE-COMMENTS FORM))) + (IL:DEFCLASS + + (IL:* IL:|;;| + "Don't remove comments from LOOPS DEFCLASS forms") + + FORM) + (IL:DATATYPE + + (IL:* IL:|;;| "Don't remove comments from record declarations") + + FORM) + (IL:RECORD + + (IL:* IL:|;;| "Don't remove comments from record declarations") + + FORM) + (IL:BLOCKRECORD + + (IL:* IL:|;;| "Don't remove comments from record declarations") + + FORM) + (IL:DECLARE\: + + (IL:* IL:|;;| + "Process each form inside this as though it were at top-level") + + (IL:FOR X IL:IN FORM + IL:COLLECT (COND + ((NOT (CONSP X)) + X) + (T (CASE (CAR X) + (IL:DEFCLASS X) + (IL:DATATYPE X) + (IL:RECORD X) + (IL:BLOCKRECORD X) + (OTHERWISE (REMOVE-COMMENTS X))))))) + (OTHERWISE (REMOVE-COMMENTS FORM))))) + (SCAN-ONE-FORM NEW-FORM *COMPILE-SCAN-CONTEXT*)) + (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*))) + (WHEN PROCESS-ENTIRE-FILE + (LET ((*MAKING-SECOND-PASS* T) + (*BLOCK-HASH-TABLE* (SET-UP-BLOCK-DECLS *BLOCKS*))) + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM *COMPILE-FILE-CONTEXT*)) + (NREVERSE *DEFERRED-FORMS*)))) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS *COMPILE-FILE-CONTEXT*))) + +(DEFUN MAYBE-REMOVE-COMMENTS (FORM) + (COND + ((EQ 'IL:DEFCLASS (CAR FORM)) + IL:FORM) + (T (REMOVE-COMMENTS FORM)))) + +(DEFUN COMPILE-FILE-SETF-SYMBOL-FUNCTION (COMPILER-CONTEXT FORM) + (LET ((NAME-FORM (SECOND FORM)) + (FUNCTION-FORM (THIRD FORM))) + (COND + ((AND (CONSTANTP NAME-FORM) + (SYMBOLP (EVAL NAME-FORM)) + (FUNCTION-P FUNCTION-FORM)) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) + (LET ((NAME (SECOND NAME-FORM)) + (DEFINITION (SECOND FUNCTION-FORM))) + (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~a" + (CAR DEFINITION) + NAME) + NAME DEFINITION))) + (T (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM))))) + +(DEFUN COMPILE-FILE-DEFINEQ (COMPILER-CONTEXT FORM) + (WHEN *EVAL-WHEN-COMPILE* (IL:EVAL FORM)) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (MAPCAR #'(LAMBDA (DEFN) + (LET ((REAL-DEFN (IF (NULL (CDDR DEFN)) + (SECOND DEFN) + (CONS 'IL:LAMBDA (CDR DEFN))))) + (COMPILER-APPLY PROCESS-FUNCTION COMPILER-CONTEXT (FORMAT NIL "~s ~s" + (CAR REAL-DEFN) + (CAR DEFN)) + (CAR DEFN) + REAL-DEFN))) + (CDR FORM))) + +(DEFUN COMPILE-FILE-DEFCONSTANT (COMPILER-CONTEXT FORM) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (DESTRUCTURING-BIND (NAME SYMBOL INITIAL-VALUE &OPTIONAL DOC) + FORM + (LET ((VALUE NIL)) + (IF (AND (CONSTANT-EXPRESSION-P INITIAL-VALUE) + (VALUE-FOLDABLE-P (SETQ VALUE (EVAL INITIAL-VALUE)))) + (SETF (CONSTANT-VALUE SYMBOL) + VALUE) + (ENV-DECLARE-A-GLOBAL (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) + SYMBOL))) + (SCAN-ONE-FORM `(NAMED-PROGN DEFCONSTANT ,SYMBOL + (LOCALLY (DECLARE (GLOBAL ,SYMBOL)) + ,(EXPAND-DEFINER 'DEFCONSTANT (REMOVE-COMMENTS FORM) + *ENVIRONMENT*))) + COMPILER-CONTEXT))) + +(DEFUN COMPILE-FILE-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T)) + (LET ((*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*)) + (DO ((TAIL (CDR FORM) + (CDR TAIL))) + ((ENDP TAIL)) + (COND + ((SYMBOLP (CAR TAIL)) + (CASE (CAR TAIL) + ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL) + ((IL:EVAL@LOADWHEN) (POP TAIL)) + ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T)) + ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL)) + ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL + (CAR (SETQ TAIL (CDR TAIL)))))) + ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T)) + ((IL:DONTCOPY) (SETQ DOCOPY NIL)) + ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) + ((IL:FIRST) ) + ((IL:NOTFIRST IL:COMPILERVARS) ) + (OTHERWISE (COMPILER-MESSAGE + "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) + ) + ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) + (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) + DOCOPY)) + ((EQ 'IL:BLOCK\: (CAR (CAR TAIL))) + (IF (NULL *PREPROCESSING-PHASE*) + (CERROR "Ignore the BLOCK: declaration." + "Files with Interlisp BLOCK: declarations must be compiled with :PROCESS-ENTIRE-FILE = T." + ) + (PUSH (CDR (CAR TAIL)) + *BLOCKS*))) + (T (WHEN *EVAL-WHEN-COMPILE* + (IL:EVAL (CAR TAIL))) + (WHEN DOCOPY + (SCAN-ONE-FORM (CAR TAIL) + COMPILER-CONTEXT))))))) + +(DEFUN COMPILE-FILE-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM) + (LET ((*STANDARD-INPUT* *INPUT-STREAM*) + IL:FILECREATEDLOC) + (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) + (EVAL FORM)) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT + `(LET ((*STANDARD-INPUT* (OPEN "{Null}" :DIRECTION :OUTPUT)) + IL:FILECREATEDLOC) + (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) + ,FORM)) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) + +(DEFUN COMPILE-FILE-PACKAGE-FORM (COMPILER-CONTEXT FORM) + (UNLESS *MAKING-SECOND-PASS* (EVAL FORM)) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) + +(DEFUN COMPILE-FILE-PROCLAMATION (COMPILER-CONTEXT FORM) + (DECLARE (SPECIAL IL:GLOBALVARS IL:SPECVARS IL:LOCALVARS)) + (LET ((FORM (EVAL (SECOND FORM))) + (TOP-ENV (FIND-TOP-ENVIRONMENT *ENVIRONMENT*))) + (IF (ATOM FORM) + (CERROR "Ignore the proclamation." "Illegal form in PROCLAIM:~%~S" FORM) + (CASE (CAR FORM) + ((SPECIAL) (MAPC #'(LAMBDA (SYMBOL) + (ENV-PROCLAIM-SPECIAL TOP-ENV SYMBOL)) + (CDR FORM))) + ((GLOBAL) (MAPC #'(LAMBDA (SYMBOL) + (ENV-PROCLAIM-GLOBAL TOP-ENV SYMBOL)) + (CDR FORM))) + ((IL:GLOBALVARS) (SETQ IL:GLOBALVARS (UNION IL:GLOBALVARS (CDR FORM)))) + ((IL:SPECVARS) (COND + ((CONSP (CDR FORM)) + (UNLESS (EQ IL:SPECVARS T) + (SETQ IL:SPECVARS (UNION IL:SPECVARS (CDR FORM))))) + ((EQ (CDR FORM) + T) + (SETQ IL:SPECVARS T) + (SETQ IL:LOCALVARS IL:SYSLOCALVARS)) + (T (CERROR "Ignore it" "Illegal SPECVARS proclamation: ~S" FORM)))) + ((IL:LOCALVARS) (COND + ((CONSP (CDR FORM)) + (UNLESS (EQ IL:LOCALVARS T) + (SETQ IL:LOCALVARS (UNION IL:LOCALVARS (CDR FORM))))) + ((EQ (CDR FORM) + T) + (SETQ IL:LOCALVARS T) + (SETQ IL:SPECVARS IL:SYSSPECVARS)) + (T (CERROR "Ignore it" "Illegal LOCALVARS proclamation: ~S" FORM)) + )) + ((TYPE FTYPE IL:FUNCTION FUNCTION) NIL) + ((INLINE) (ENV-ALLOW-INLINES TOP-ENV (CDR FORM))) + ((NOTINLINE) (ENV-DISALLOW-INLINES TOP-ENV (CDR FORM))) + ((IGNORE OPTIMIZE) NIL) + ((DECLARATION) (ENV-ADD-DECLS TOP-ENV (CDR FORM))) + (OTHERWISE (UNLESS (OR (CL::TYPE-EXPANDER (CAR FORM)) + (XCL::DECL-SPECIFIER-P (CAR FORM)) + (ENV-DECL-P TOP-ENV (CAR FORM))) + (CERROR "Ignore it." "Unknown declaration specifier in PROCLAIM: ~S." + (CAR FORM))))))) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM)) + +(DEFUN COMPILE-FILE-COMPILER-LET (COMPILER-CONTEXT FORM) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (DESTRUCTURING-BIND (BINDING-LIST &REST INNER-FORMS) + (CDR FORM) + (LET (VARS VALS) + (DOLIST (BINDING BINDING-LIST) + (COND + ((ATOM BINDING) + (PUSH BINDING VARS) + (PUSH NIL VALS)) + ((NULL (CDR BINDING)) + (PUSH (CAR BINDING) + VARS) + (PUSH NIL VALS)) + ((AND (CONSP (CDR BINDING)) + (NULL (CDDR BINDING))) + (PUSH (CAR BINDING) + VARS) + (PUSH (EVAL (CADR BINDING)) + VALS)) + (T (CERROR "Bind the CAR of the binding to NIL" + "Bad binding in COMPILER-LET: ~S" BINDING) + (PUSH (CAR BINDING) + VARS) + (PUSH NIL VALS)))) + (PROGV VARS VALS + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + INNER-FORMS) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT))))) + +(DEFUN COMPILE-FILE-MACROLET (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY) + FORM + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (LET ((*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) + (DOLIST (MACRO-DEFN MACRO-DEFNS) + (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN) + :MACRO + (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN)))) + (DOLIST (FORM BODY) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)))) + +(DEFUN COMPILE-FILE-DEFINER (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) + (CDR FORM) + (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) + (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) + (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) + (IF *COMPILING-DEFINER* + (SCAN-ONE-FORM BODY COMPILER-CONTEXT) + (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (LET ((*COMPILING-DEFINER* T) + (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME))) + (COMPILING-MESSAGE *LOOSE-NAME*) + (SCAN-ONE-FORM BODY COMPILER-CONTEXT) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (DONE-MESSAGE))))))) + +(DEFUN COMPILE-FILE-NAMED-PROGN (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS) + (CDR FORM) + (IF *COMPILING-DEFINER* + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + PROGN-FORMS) + (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (LET ((*COMPILING-DEFINER* T) + (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME))) + (COMPILING-MESSAGE *LOOSE-NAME*) + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + PROGN-FORMS) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (DONE-MESSAGE)))))) + +(DEFUN COMPILE-FILE-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) + (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*)) + (IF *COMPILING-DEFINER* + (COMPILE-AND-DUMP *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*)) + :ONE-SHOT) + (LET ((NAME (FORMAT NIL "~&~D top-level form~:P" (LIST-LENGTH *OUTSTANDING-LOOSE-FORMS*))) + ) + (COMPILING-MESSAGE NAME) + (COMPILE-AND-DUMP NAME `(LAMBDA NIL ,@(REVERSE *OUTSTANDING-LOOSE-FORMS*)) + :ONE-SHOT) + (DONE-MESSAGE))) + (SETQ *OUTSTANDING-LOOSE-FORMS* NIL))) + +(DEFUN COMPILE-FILE-LOOSE-FORM (COMPILER-CONTEXT FORM) + (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) + (PUSH FORM *OUTSTANDING-LOOSE-FORMS*)) + +(DEFUN COMPILE-FILE-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION) + (IF *COMPILING-DEFINER* + (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION) + (PROGN (COMPILING-MESSAGE MESSAGE) + (COMPILE-AND-DUMP NAME DEFINITION :FUNCTION) + (DONE-MESSAGE))) + NAME) + +(DEFUN CRACK-DEFMACRO (FORM) + +(IL:* IL:|;;;| "FORM is a call to DEFMACRO. Return two values: the LAMBDA-expression representing the expansion function for the macro and the documentation string, if present.") + + (LET ((NAME (SECOND FORM)) + (ARG-LIST (THIRD FORM)) + (BODY (CDDDR FORM)) + (WHOLE (GENSYM)) + (ENV-VAR (GENSYM))) + (MULTIPLE-VALUE-BIND (CODE DECLS DOC) + (IL:PARSE-DEFMACRO ARG-LIST WHOLE BODY NAME *ENVIRONMENT* :ENVIRONMENT ENV-VAR) + (VALUES `(LAMBDA (,WHOLE ,ENV-VAR) + ,@DECLS + (BLOCK ,NAME ,CODE)) + DOC)))) + +(DEFUN ESTABLISH-MACRO-IN-COMPILER (NAME EXPN-FN) + +(IL:* IL:|;;;| "Arrange for the symbol NAME to refer to a macro with the given expansion-function EXPN-FN within this compilation.") + + (ENV-BIND-FUNCTION (FIND-TOP-ENVIRONMENT *ENVIRONMENT*) + NAME :MACRO EXPN-FN)) + + + +(IL:* IL:|;;| "Support for :Process-Entire-File") + + +(DEFVAR *DEFERRED-FORMS* NIL + "A list onto which most forms will be pushed if we are preprocessing an Interlisp-format file. After the first pass through the file is done, and all macros and other eval-when(compile) forms have been processed, a second pass will be made down this list to actually compile the forms." +) + +(DEFVAR *MAKING-SECOND-PASS* NIL + +(IL:* IL:|;;;| "Bound to T during second pass over saved forms; used for :Process-Entire-File option to compile-file.") + + ) + +(DEFVAR *PREPROCESSING-PHASE* NIL + +(IL:* IL:|;;;| "Bound to T during the preprocessing phase so that inferiors can tell.") + + ) + +(DEFUN COMPILE-SCAN-DECLARE\: (COMPILER-CONTEXT FORM &OPTIONAL (DOCOPY T) + (DOFIRST NIL)) + (LET ((FIRST-FORMS NIL) + (IL:DFNFLG IL:DFNFLG) + (*EVAL-WHEN-COMPILE* *EVAL-WHEN-COMPILE*)) + (DO ((TAIL (CDR FORM) + (CDR TAIL))) + ((ENDP TAIL) + (WHEN FIRST-FORMS (MERGE-FIRST-FORMS FIRST-FORMS))) + (COND + ((SYMBOLP (CAR TAIL)) + (CASE (CAR TAIL) + ((IL:EVAL@LOAD IL:DOEVAL@LOAD IL:DONTEVAL@LOAD) NIL) + ((IL:EVAL@LOADWHEN) (POP TAIL)) + ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* T)) + ((IL:DONTEVAL@COMPILE) (SETQ *EVAL-WHEN-COMPILE* NIL)) + ((IL:EVAL@COMPILEWHEN) (SETQ *EVAL-WHEN-COMPILE* (IL:EVAL + (CAR (SETQ TAIL (CDR TAIL)))))) + ((IL:COPY IL:DOCOPY) (SETQ DOCOPY T)) + ((IL:DONTCOPY) (SETQ DOCOPY NIL)) + ((IL:COPYWHEN) (SETQ DOCOPY (IL:EVAL (CAR (SETQ TAIL (CDR TAIL)))))) + ((IL:FIRST) (SETQ DOFIRST T)) + ((IL:NOTFIRST) (SETQ DOFIRST NIL)) + ((IL:COMPILERVARS) (SETQ IL:DFNFLG T)) + (OTHERWISE (COMPILER-MESSAGE + "Warning: Ignoring unrecognized DECLARE: tag: ~S~%" (CAR TAIL)))) + ) + ((EQ 'IL:DECLARE\: (CAR (CAR TAIL))) + (COMPILER-APPLY IL:DECLARE\: COMPILER-CONTEXT (CAR TAIL) + DOCOPY DOFIRST)) + ((EQ 'IL:BLOCK\: (CAR (CAR TAIL))) + (PUSH (CDR (CAR TAIL)) + *BLOCKS*)) + (T (WHEN *EVAL-WHEN-COMPILE* + (IL:EVAL (CAR TAIL))) + (WHEN DOCOPY + (IF DOFIRST + (LET ((*DEFERRED-FORMS* NIL)) + (SCAN-ONE-FORM (CAR TAIL) + COMPILER-CONTEXT) + (SETQ FIRST-FORMS (APPEND FIRST-FORMS *DEFERRED-FORMS*))) + (SCAN-ONE-FORM (CAR TAIL) + COMPILER-CONTEXT)))))))) + +(DEFUN COMPILE-SCAN-DEFINE-FILE-INFO (COMPILER-CONTEXT FORM) + (LET ((*STANDARD-INPUT* *INPUT-STREAM*) + IL:FILECREATEDLOC) + (DECLARE (SPECIAL *STANDARD-INPUT* IL:FILECREATEDLOC)) + (EVAL FORM)) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT FORM) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)) + +(DEFUN COMPILE-SCAN-MACROLET (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (JUNK MACRO-DEFNS &BODY BODY) + FORM + (LET (OUTER-DEFERRED-FORMS) + (LET ((*DEFERRED-FORMS* NIL) + (*ENVIRONMENT* (MAKE-CHILD-ENV *ENVIRONMENT*))) + (DOLIST (MACRO-DEFN MACRO-DEFNS) + (ENV-BIND-FUNCTION *ENVIRONMENT* (CAR MACRO-DEFN) + :MACRO + (CRACK-DEFMACRO (CONS 'DEFMACRO MACRO-DEFN)))) + (DOLIST (FORM BODY) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + (SETQ OUTER-DEFERRED-FORMS *DEFERRED-FORMS*)) + (WHEN (NOT (NULL OUTER-DEFERRED-FORMS)) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT + `(MACROLET ,MACRO-DEFNS ,@(REVERSE OUTER-DEFERRED-FORMS))))))) + +(DEFUN COMPILE-SCAN-DEFINER (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) + (CDR FORM) + (COMPILER-APPLY PROCESS-LOOSE-FORM COMPILER-CONTEXT + (LET* ((*DEFERRED-FORMS* NIL) + (MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) + (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) + (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) + (SCAN-ONE-FORM BODY COMPILER-CONTEXT) + `(NAMED-PROGN ,DEFINER ,NAME ,@(NREVERSE *DEFERRED-FORMS*)))))) + +(DEFUN COMPILE-SCAN-LOOSE-FORM (COMPILER-CONTEXT FORM) + (WHEN *EVAL-WHEN-COMPILE* (EVAL FORM)) + (PUSH FORM *DEFERRED-FORMS*)) + +(DEFUN COMPILE-SCAN-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) + NIL) + +(DEFUN MERGE-FIRST-FORMS (FORMS) + (DO* ((TAIL *DEFERRED-FORMS* (CDR TAIL)) + (NEW-TAIL (CDR TAIL) + (CDR TAIL))) + ((ENDP TAIL) + (IF (NULL NEW-TAIL) + (NCONC *DEFERRED-FORMS* FORMS)) + NIL) + (WHEN (EQL (CAAR NEW-TAIL) + 'IL:FILECREATED) + (SETF (CDR TAIL) + FORMS) + (SETF (CDR (LAST FORMS)) + NEW-TAIL) + (RETURN)))) + + + +(IL:* IL:|;;| "for compiling definers") + + +(DEFVAR *LAP-FLG* NIL) + +(DEFVAR *AUTOMATIC-SPECIAL-DECLARATIONS*) + +(DEFUN COMPILE (NAME &OPTIONAL DEFN &KEY LAP) + (WHEN (NULL DEFN) + (IL:VIRGINFN NAME T) + (SETQ DEFN (IL:GETD NAME)) + (TYPECASE DEFN + (CONS NIL) + ((OR NULL IL:COMPILED-CLOSURE) + (IF (NULL DEFN) + (FORMAT T "There's nothing in the function cell of ~S.~%" NAME) + (FORMAT T "~S is already compiled.~%" NAME)) + (WHEN (AND (IL:HASDEF NAME 'IL:FUNCTIONS) + (Y-OR-N-P "Shall I use the FUNCTIONS definition? ")) + (RETURN-FROM COMPILE (COMPILE-DEFINER NAME 'IL:FUNCTIONS :LAP LAP))) + (WHEN (AND (GET NAME 'IL:EXPR) + (Y-OR-N-P "Shall I use the definition on the EXPR property? " NAME)) + (RETURN-FROM COMPILE (COMPILE NAME (GET NAME 'IL:EXPR) + :LAP LAP))) + (RETURN-FROM COMPILE)) + (OTHERWISE + (FORMAT T + "There's something funny in the function cell of ~S.~%I'm not going any further.~%" + NAME) + (RETURN-FROM COMPILE)))) + (LET* ((*ENVIRONMENT* (MAKE-ENV :PARENT T :TARGET-ARCHITECTURE *HOST-ARCHITECTURE*)) + (IL:SPECVARS IL:SPECVARS) + (IL:LOCALVARS IL:LOCALVARS) + (IL:LOCALFREEVARS NIL) + (IL:GLOBALVARS IL:GLOBALVARS) + (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) + (*PROCESSED-FUNCTIONS* (LIST NAME)) + (*UNKNOWN-FUNCTIONS* NIL) + (*CURRENT-FUNCTION* NAME) + (*INPUT-STREAM* NIL) + (*LAP-FLG* LAP) (IL:* IL:\; "FXAR-111") + (COMPILED-DEFN (RAW-COMPILE NAME DEFN))) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) + (WARN-ABOUT-UNKNOWN-FUNCTIONS) + (IF (NULL NAME) + COMPILED-DEFN + (PROGN (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS)) + (CONSP (IL:GETD NAME))) + (SETF (GET NAME 'IL:EXPR) + (IL:GETD NAME))) + (SETF (SYMBOL-FUNCTION NAME) + COMPILED-DEFN) + NAME)))) + +(DEFUN COMPILE-DEFINER (NAME TYPE &KEY LAP) + (LET ((*ENVIRONMENT* (MAKE-ENV :PARENT T)) + (*OUTSTANDING-LOOSE-FORMS* NIL) + (*EVAL-WHEN-COMPILE* NIL)) + (COMPILE-FORM (IL:GETDEF NAME TYPE NIL '(IL:NOCOPY T))) + NAME)) + +(DEFUN COMPILE-FORM (FORM &KEY LAP) + (LET ((*CONTEXT* (MAKE-CONTEXT :TOP-LEVEL-P T :VALUES-USED 0)) + (*ENVIRONMENT* (MAKE-ENV :PARENT T)) + (*CONSTANTS-HASH-TABLE* (MAKE-HASH-TABLE)) + (*PROCESSED-FUNCTIONS* NIL) + (*UNKNOWN-FUNCTIONS* NIL) + (*OUTSTANDING-LOOSE-FORMS* NIL) + (*LAP-FLG* LAP) + (IL:SPECVARS IL:SPECVARS) + (IL:LOCALVARS IL:LOCALVARS) + (IL:LOCALFREEVARS NIL) + (IL:GLOBALVARS IL:GLOBALVARS) + VALUE) + (DECLARE (SPECIAL IL:SPECVARS IL:LOCALVARS IL:LOCALFREEVARS IL:GLOBALVARS)) + (SETQ VALUE (MULTIPLE-VALUE-LIST (SCAN-ONE-FORM (REMOVE-COMMENTS FORM) + *COMPILE-DEFINER-CONTEXT*))) + (IF *OUTSTANDING-LOOSE-FORMS* + (SETQ VALUE (MULTIPLE-VALUE-LIST (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS + *COMPILE-DEFINER-CONTEXT*)))) + (WARN-ABOUT-UNKNOWN-FUNCTIONS) + (VALUES-LIST VALUE))) + +(DEFUN RAW-COMPILE (NAME DEFINITION) + (LET* ((*CURRENT-FUNCTION* NAME) + (LAP-FN (COMPILE-ONE-LAMBDA NAME DEFINITION)) + COMPILED-DEFN) + (WHEN (NOT (NULL *LAP-FLG*)) + (PPRINT LAP-FN (IF (STREAMP *LAP-FLG*) + *LAP-FLG* + *STANDARD-OUTPUT*))) + (CONDITION-CASE (SETQ COMPILED-DEFN (LET ((DCODE (D-ASSEM:ASSEMBLE-FUNCTION LAP-FN))) + (UNWIND-PROTECT + (D-ASSEM:INTERN-DCODE DCODE) + (D-ASSEM:RELEASE-DCODE DCODE)))) + (ASSEMBLER-ERROR (CONDITION) + (FORMAT *ERROR-OUTPUT* "~&~A~%" CONDITION) + (RETURN-FROM RAW-COMPILE NIL))) + COMPILED-DEFN)) + +(DEFUN COMPILE-DEFINER-DEFINER (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (TYPE DEFINER DEFINITION &OPTIONAL ENV) + (CDR FORM) + (LET* ((MACRO-DEFINITION (REMOVE-COMMENTS DEFINITION)) + (NAME (XCL::%DEFINER-NAME DEFINER MACRO-DEFINITION)) + (BODY (EXPAND-DEFINER DEFINER MACRO-DEFINITION ENV))) + (IF *COMPILING-DEFINER* + (SCAN-ONE-FORM BODY COMPILER-CONTEXT) + (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (LET ((*COMPILING-DEFINER* T) + (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER NAME)) + VALUE) + (SETQ VALUE (SCAN-ONE-FORM BODY COMPILER-CONTEXT)) + (IF *OUTSTANDING-LOOSE-FORMS* + (SETQ VALUE (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS + COMPILER-CONTEXT))) + VALUE)))))) + +(DEFUN COMPILE-DEFINER-NAMED-PROGN (COMPILER-CONTEXT FORM) + (DESTRUCTURING-BIND (DEFINER-NAME NAME &REST PROGN-FORMS) + (CDR FORM) + (IF *COMPILING-DEFINER* + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + PROGN-FORMS) + (PROGN (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT) + (LET ((*COMPILING-DEFINER* T) + (*LOOSE-NAME* (FORMAT NIL "~s ~s" DEFINER-NAME NAME))) + (MAPC #'(LAMBDA (FORM) + (SCAN-ONE-FORM FORM COMPILER-CONTEXT)) + PROGN-FORMS) + (COMPILER-APPLY PROCESS-OUTSTANDING-LOOSE-FORMS COMPILER-CONTEXT)))) + NAME)) + +(DEFUN COMPILE-DEFINER-PROCESS-FUNCTION (COMPILER-CONTEXT MESSAGE NAME DEFINITION) + (PUSH NAME *PROCESSED-FUNCTIONS*) + (SETQ *UNKNOWN-FUNCTIONS* (REMOVE NAME *UNKNOWN-FUNCTIONS* :KEY 'CAR)) + (LET ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) + COMPILED-DEFN) + + (IL:* IL:|;;| "The resulting function is defined locally, so we have to compile for the host architecture rather than the target architecture:") + + (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) + *HOST-ARCHITECTURE*) + (SETQ COMPILED-DEFN (RAW-COMPILE NAME DEFINITION)) + (WHEN (AND (NOT (IL:HASDEF NAME 'IL:FUNCTIONS)) + (CONSP (IL:GETD NAME))) + (SETF (GET NAME 'IL:EXPR) + (IL:GETD NAME))) + (SETF (SYMBOL-FUNCTION NAME) + COMPILED-DEFN) + NAME)) + +(DEFUN COMPILE-DEFINER-OUTSTANDING-LOOSE-FORMS (COMPILER-CONTEXT) + + (IL:* IL:|;;| + "Compile any outstanding loose forms in the context of a structure definition being compiled") + + (WHEN (NOT (NULL *OUTSTANDING-LOOSE-FORMS*)) + (LET* ((*ENVIRONMENT* (COPY-ENV *ENVIRONMENT*)) + COMPILED-DEFN) + + (IL:* IL:|;;| "The resulting function is executed locally, so have to compile for the host architecture rather than the target architecture:") + + (SETF (ENV-TARGET-ARCHITECTURE *ENVIRONMENT*) + *HOST-ARCHITECTURE*) + (SETQ COMPILED-DEFN (RAW-COMPILE *LOOSE-NAME* `(LAMBDA NIL ,@(REVERSE + *OUTSTANDING-LOOSE-FORMS* + )))) + (SETQ *OUTSTANDING-LOOSE-FORMS* NIL) + (FUNCALL COMPILED-DEFN)))) + + + +(IL:* IL:|;;| "Arrange for correct compiler to be used.") + + +(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:FILETYPE :COMPILE-FILE) + + + +(IL:* IL:|;;| "Arrange for the correct makefile environment") + + +(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE + (DEFPACKAGE "COMPILER" + (:USE "LISP" "XCL")))) +(IL:PUTPROPS IL:XCLC-TOP-LEVEL IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 + 1994)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP diff --git a/sources/XCLC-TRANSFORMS b/sources/XCLC-TRANSFORMS new file mode 100644 index 00000000..a30bcf01 --- /dev/null +++ b/sources/XCLC-TRANSFORMS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "10-Aug-92 13:17:53" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-TRANSFORMS.;3| 21787 IL:|changes| IL:|to:| (IL:FUNCTIONS FIND-AND-PERFORM-RPLCONS-TRANSFORM) IL:|previous| IL:|date:| "23-May-90 13:25:49" IL:|{PELE:MV:ENVOS}SOURCES>XCLC-TRANSFORMS.;2|) ; Copyright (c) 1986, 1987, 1990, 1992 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-TRANSFORMSCOMS) (IL:RPAQQ IL:XCLC-TRANSFORMSCOMS ( (IL:* IL:|;;| "Function-specific transformations") (IL:DEFINE-TYPES TRANSFORMS) (IL:FUNCTIONS DEFTRANSFORM) (IL:PROP IL:PROPTYPE TRANSFORM) (IL:FUNCTIONS IS-CALL-TO) (IL:* IL:|;;| "The various memory-reference primitives.") (TRANSFORMS IL:\\ADDBASE) (TRANSFORMS IL:\\GETBASE IL:\\GETBASEPTR) (TRANSFORMS IL:\\PUTBASE IL:\\PUTBASEPTR IL:\\RPLPTR) (OPTIMIZERS IL:\\PUTBASE IL:\\PUTBASEPTR IL:\\RPLPTR) (TRANSFORMS IL:\\GETBITS IL:\\PUTBITS) (OPTIMIZERS IL:\\GETBITS IL:\\PUTBITS) (IL:FUNCTIONS ENSURE-EFFECT-CONTEXT TRANSFORM-GET/PUT-BASE) (IL:* IL:|;;| "List-structure functions") (TRANSFORMS CAR CDR) (TRANSFORMS RPLACD) (IL:FUNCTIONS FIND-AND-PERFORM-RPLCONS-TRANSFORM) (OPTIMIZERS IL:FRPLACD) (IL:* IL:|;;| "Use the proper makefile-environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TRANSFORMS) (IL:* IL:|;;| "Use the proper compiler.") (IL:PROP IL:FILETYPE IL:XCLC-TRANSFORMS))) (IL:* IL:|;;| "Function-specific transformations") (DEF-DEFINE-TYPE TRANSFORMS "XCL Compiler transformations" :UNDEFINER (LAMBDA (NAME) (WHEN (SYMBOLP NAME) (REMPROP NAME 'TRANSFORM)))) (DEFDEFINER DEFTRANSFORM TRANSFORMS (FN-NAME ARG-LIST &BODY CODE) (IL:* IL:|;;;| "Transforms are called with two arguments: (1) the subtree of the program whose root is a CALL node with FN-NAME as the function, and (2) the evaluation context of the subtree, one of :ARGUMENT, :EFFECT, :RETURN, and :MV. The transform should return the new subtree and should, of course, be careful about releasing any nodes it does away with.") (IL:* IL:|;;;| "Don't forget to set the META-P bit in any new nodes created and in the root node, if no more work is needed.") (LET ((TRANSFORM-NAME (INTERN (CONCATENATE 'STRING "transform-" (STRING FN-NAME)) (SYMBOL-PACKAGE FN-NAME)))) `(PROGN (DEFUN ,TRANSFORM-NAME ,ARG-LIST ,@CODE) (SETF (GET ',FN-NAME 'TRANSFORM) ',TRANSFORM-NAME)))) (IL:PUTPROPS TRANSFORM IL:PROPTYPE IGNORE) (DEFUN IS-CALL-TO (NAME NODE) (IL:* IL:|;;;| "Is NODE a function call to the global function named NAME?") (AND (CALL-P NODE) (LET ((FN (CALL-FN NODE))) (AND (VAR-REF-P FN) (LET ((VAR (VAR-REF-VARIABLE FN))) (EQ :GLOBAL (VARIABLE-SCOPE VAR)) (EQ :FUNCTION (VARIABLE-KIND VAR)) (EQ NAME (VARIABLE-NAME VAR))))))) (IL:* IL:|;;| "The various memory-reference primitives.") (DEFTRANSFORM IL:\\ADDBASE (NODE CONTEXT) (IL:* IL:|;;;| "Get rid of nested \\ADDBASE's. (\\addbase (\\addbase base n) m) => (\\addbase base (+ n m)).") (DESTRUCTURING-BIND (BASE OFFSET) (CALL-ARGS NODE) (WHEN (AND (IS-CALL-TO 'IL:\\ADDBASE BASE) (LITERAL-P OFFSET) (INTEGERP (LITERAL-VALUE OFFSET))) (DESTRUCTURING-BIND (INNER-BASE INNER-OFFSET) (CALL-ARGS BASE) (WHEN (AND (LITERAL-P INNER-OFFSET) (INTEGERP (LITERAL-VALUE INNER-OFFSET))) (LET ((NEW-OFFSET (MAKE-LITERAL :VALUE (+ (LITERAL-VALUE OFFSET) (LITERAL-VALUE INNER-OFFSET))))) (RELEASE-TREE INNER-OFFSET) (SETF (SECOND (CALL-ARGS BASE)) NEW-OFFSET) (POP (CALL-ARGS NODE)) (IL:* IL:\;  "Detach the inner \\addbase call.") (RELEASE-TREE NODE) (SETQ NODE BASE)))))) (SETF (NODE-META-P NODE) CONTEXT) NODE) (DEFTRANSFORM IL:\\GETBASE (NODE CONTEXT) (TRANSFORM-GET/PUT-BASE NODE CONTEXT :GET 'IL:GETBASE.N)) (DEFTRANSFORM IL:\\GETBASEPTR (NODE CONTEXT) (TRANSFORM-GET/PUT-BASE NODE CONTEXT :GET 'IL:GETBASEPTR.N)) (DEFTRANSFORM IL:\\PUTBASE (NODE CONTEXT) (COND ((EQ CONTEXT :EFFECT) (TRANSFORM-GET/PUT-BASE NODE :EFFECT :PUT 'IL:PUTBASE.N)) (IL:* IL:\;  "See transform for \\RPLPTR.") (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFTRANSFORM IL:\\PUTBASEPTR (NODE CONTEXT) (COND ((EQ CONTEXT :EFFECT) (TRANSFORM-GET/PUT-BASE NODE :EFFECT :PUT 'IL:PUTBASEPTR.N)) (IL:* IL:\;  "See transform for \\RPLPTR.") (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFTRANSFORM IL:\\RPLPTR (NODE CONTEXT) (COND ((EQ CONTEXT :EFFECT) (TRANSFORM-GET/PUT-BASE NODE :EFFECT :PUT 'IL:RPLPTR.N)) (IL:* IL:\; "Sometimes we are meta-eval'ed in a less-precise context. Let it go; we'll be re-meta-eval'ed correctly in a moment.") (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFOPTIMIZER IL:\\PUTBASE (&WHOLE FORM &CONTEXT CTXT) (ENSURE-EFFECT-CONTEXT FORM CTXT 2)) (DEFOPTIMIZER IL:\\PUTBASEPTR (&WHOLE FORM &CONTEXT CTXT) (ENSURE-EFFECT-CONTEXT FORM CTXT 2)) (DEFOPTIMIZER IL:\\RPLPTR (&WHOLE FORM &CONTEXT CTXT) (ENSURE-EFFECT-CONTEXT FORM CTXT 2)) (DEFTRANSFORM IL:\\GETBITS (NODE CONTEXT) (IL:* IL:|;;| "Splice out the field-descriptor and pass it as a beta byte") (LET ((FD-NODE (THIRD (CALL-ARGS NODE)))) (ASSERT (AND (LITERAL-P FD-NODE) (INTEGERP (LITERAL-VALUE FD-NODE))) NIL "BUG: Field-descriptor for \\getbits is not a literal integer.") (LET ((FD (LITERAL-VALUE FD-NODE))) (RELEASE-TREE FD-NODE) (SETF (CDDR (CALL-ARGS NODE)) NIL) (TRANSFORM-GET/PUT-BASE NODE CONTEXT :GET 'IL:GETBITS.N.FD FD)))) (DEFTRANSFORM IL:\\PUTBITS (NODE CONTEXT) (COND ((EQ CONTEXT :EFFECT) (IL:* IL:|;;| "Splice out the field-descriptor and pass it as a beta byte") (LET ((FD-NODE (THIRD (CALL-ARGS NODE)))) (ASSERT (AND (LITERAL-P FD-NODE) (INTEGERP (LITERAL-VALUE FD-NODE))) NIL "BUG: Field-descriptor for \\putbits is not a literal integer.") (LET ((FD (LITERAL-VALUE FD-NODE))) (RELEASE-TREE FD-NODE) (SETF (CDDR (CALL-ARGS NODE)) (CDDDR (CALL-ARGS NODE))) (TRANSFORM-GET/PUT-BASE NODE :EFFECT :PUT 'IL:PUTBITS.N.FD FD)))) (IL:* IL:\;  "See transform for \\RPLPTR") (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFOPTIMIZER IL:\\GETBITS (BASE OFFSET FIELD-DESCRIPTOR &WHOLE FORM) (ASSERT (AND (INTEGERP OFFSET) (INTEGERP FIELD-DESCRIPTOR)) NIL "BUG: The second and third arguments to \\GETBITS must be literal integers." ) (IF (= FIELD-DESCRIPTOR 15) (IL:* IL:\;  "Silly case; wants whole word.") `(IL:\\GETBASE ,BASE ,OFFSET) FORM)) (DEFOPTIMIZER IL:\\PUTBITS (BASE OFFSET FIELD-DESCRIPTOR NEW-VALUE &WHOLE FORM &CONTEXT CTXT) (ASSERT (AND (INTEGERP OFFSET) (INTEGERP FIELD-DESCRIPTOR)) NIL "BUG: The second and third arguments to \\PUTBITS must be literal integers." ) (IF (= FIELD-DESCRIPTOR 15) (IL:* IL:\;  "Silly case; wants whole word.") `(IL:\\PUTBASE ,BASE ,OFFSET ,NEW-VALUE) (ENSURE-EFFECT-CONTEXT FORM CTXT 3 '(1 2)))) (DEFUN ENSURE-EFFECT-CONTEXT (FORM CTXT RESULT-ARG-NUMBER &OPTIONAL SUBST-INDICES) (IL:* IL:|;;;| "If the form is not in effect context already, then wrap it in an OPENLAMBDA, returning the RESULT-ARG-NUMBER'th argument as the value. This way, the form will always be in effect context. SUBST-INDICES is a list of the indices of arguments whose values should be substituted in the actual call directly, not passing through the argument list.") (IF (EQL 0 (CONTEXT-VALUES-USED CTXT)) 'PASS (LET (CALL-ARGS LAMBDA-PARAMS LAMBDA-ARGS RESULT-ARG) (IL:FOR A IL:IN (CDR FORM) IL:AS N IL:FROM 0 IL:DO (COND ((MEMBER N SUBST-INDICES) (PUSH A CALL-ARGS) (WHEN (= N RESULT-ARG-NUMBER) (SETQ RESULT-ARG A))) (T (LET ((NAME (IL:PACK* 'ARG- N))) (PUSH NAME CALL-ARGS) (PUSH NAME LAMBDA-PARAMS) (PUSH A LAMBDA-ARGS) (WHEN (= N RESULT-ARG-NUMBER) (SETQ RESULT-ARG NAME)))))) `((IL:OPENLAMBDA ,(REVERSE LAMBDA-PARAMS) (,(CAR FORM) ,@(REVERSE CALL-ARGS)) ,RESULT-ARG) ,@(REVERSE LAMBDA-ARGS))))) (DEFUN TRANSFORM-GET/PUT-BASE (NODE CONTEXT USE OPCODE &OPTIONAL BETA-BYTE) (IL:* IL:|;;;| "Transform a call on one of the memory-accessing functions \\{GET,PUT}BASE{,PTR,FIXP} or \\RPLPTR into the appropriate calls on \\ADDBASE and the given OPCODE. USE is one of :GET or :PUT.") (IL:* IL:|;;;| "The following transformations take place here:") (IL:* IL:|;;| "(fn (\\ADDBASE base n) offset [new-value]) => (fn base (+ n offset) [new-value])") (IL:* IL:|;;|  "Check for a literal OFFSET between 0 and 255 and avoid an \\ADDBASE call in that case.") (LET* ((ARGS (CALL-ARGS NODE)) (LITERAL-OFFSET-VALUE 0) (COMPUTED-OFFSET-TREE NIL) (ADDBASE-CALL NIL) (REAL-BASE (FIRST ARGS))) (WHEN (IS-CALL-TO 'IL:\\ADDBASE REAL-BASE) (SETQ ADDBASE-CALL REAL-BASE) (DESTRUCTURING-BIND (BASE OFFSET) (CALL-ARGS ADDBASE-CALL) (SETQ REAL-BASE BASE) (COND ((AND (LITERAL-P OFFSET) (INTEGERP (LITERAL-VALUE OFFSET))) (INCF LITERAL-OFFSET-VALUE (LITERAL-VALUE OFFSET)) (RELEASE-TREE OFFSET)) (T (SETQ COMPUTED-OFFSET-TREE OFFSET))))) (LET ((OFFSET (SECOND ARGS))) (COND ((AND (LITERAL-P OFFSET) (INTEGERP (LITERAL-VALUE OFFSET))) (INCF LITERAL-OFFSET-VALUE (LITERAL-VALUE OFFSET)) (RELEASE-TREE OFFSET)) ((NULL COMPUTED-OFFSET-TREE) (SETQ COMPUTED-OFFSET-TREE OFFSET)) (T (SETQ COMPUTED-OFFSET-TREE (MAKE-CALL :FN (MAKE-OPCODES :BYTES '(IL:PLUS2)) :ARGS (LIST COMPUTED-OFFSET-TREE OFFSET) :META-P T))))) (UNLESS (<= 0 LITERAL-OFFSET-VALUE 255) (IL:* IL:\;  "The literal offset is not in range to be an alpha byte, so must use \\ADDBASE.") (SETQ COMPUTED-OFFSET-TREE (IF (NULL COMPUTED-OFFSET-TREE) (MAKE-LITERAL :VALUE LITERAL-OFFSET-VALUE :META-P T) (MAKE-CALL :FN (MAKE-OPCODES :BYTES '(IL:PLUS2)) :ARGS (LIST COMPUTED-OFFSET-TREE (MAKE-LITERAL :VALUE LITERAL-OFFSET-VALUE :META-P T)) :META-P T))) (SETQ LITERAL-OFFSET-VALUE 0)) (IF (NULL COMPUTED-OFFSET-TREE) (IL:* IL:|;;| "The \\ADDBASE call is unnecessary.") (WHEN (NOT (NULL ADDBASE-CALL)) (POP (CALL-ARGS ADDBASE-CALL)) (IL:* IL:\;  "Detach the REAL-BASE from this useless node.") (RELEASE-TREE ADDBASE-CALL)) (IL:* IL:|;;| "We need an \\ADDBASE call. Reuse the old one if there is one.") (COND ((NULL ADDBASE-CALL) (SETQ REAL-BASE (MAKE-CALL :FN (MAKE-REFERENCE-TO-VARIABLE :NAME 'IL:\\ADDBASE :SCOPE :GLOBAL :KIND :FUNCTION) :ARGS (LIST REAL-BASE COMPUTED-OFFSET-TREE) :META-P T))) (T (SETF (SECOND (CALL-ARGS ADDBASE-CALL)) COMPUTED-OFFSET-TREE) (SETQ REAL-BASE ADDBASE-CALL)))) (IL:* IL:|;;| "Finally put it all back together again. REAL-BASE is the (possibly computed) base and LITERAL-OFFSET-VALUE is the alpha byte for the opcode. We can reuse the node for the original call.") (RELEASE-TREE (CALL-FN NODE)) (SETF (CALL-FN NODE) (MAKE-OPCODES :BYTES `(,OPCODE ,LITERAL-OFFSET-VALUE ,@(AND BETA-BYTE (LIST BETA-BYTE) )))) (SETF (CALL-ARGS NODE) (IF (EQ USE :GET) (LIST REAL-BASE) (LIST REAL-BASE (THIRD ARGS)))) (SETF (NODE-META-P NODE) CONTEXT) NODE)) (IL:* IL:|;;| "List-structure functions") (DEFTRANSFORM CAR (NODE CONTEXT) (IL:* IL:|;;;| "Transforms (CAR (CONS X Y)) => (PROG1 X Y).") (COND ((IS-CALL-TO 'CONS (FIRST (CALL-ARGS NODE))) (LET* ((CONS-ARGS (CALL-ARGS (FIRST (CALL-ARGS NODE))))) (IL:* IL:|;;| "First, release the CAR and CONS nodes by detaching the CONS's arguments from the tree (they'll be in the PROG1 created below) and then releasing the NODE.") (SETF (CALL-ARGS (FIRST (CALL-ARGS NODE))) NIL) (RELEASE-TREE NODE) (CONSTRUCT-PROG1-TREE (FIRST CONS-ARGS) (LIST (SECOND CONS-ARGS))))) (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFTRANSFORM CDR (NODE CONTEXT) (LET (TEMP) (COND (IL:* IL:|;;| "(CDR (CONS X Y)) => (PROGN X Y)") ((IS-CALL-TO 'CONS (FIRST (CALL-ARGS NODE))) (PROG1 (MAKE-PROGN :STMTS (CALL-ARGS (FIRST (CALL-ARGS NODE))) :META-P NIL) (SETF (CALL-ARGS (FIRST (CALL-ARGS NODE))) NIL) (RELEASE-TREE NODE))) (IL:* IL:|;;| "(CDR (RPLACD X (SETQ Z1 ... (SETQ Zn (CONS Y NIL)) ... ) =>") (IL:* IL:|;;| " (SETQ Z1 ... (SETQ Zn (RPLCONS X Y)) ... )") ((AND (IS-CALL-TO 'RPLACD (FIRST (CALL-ARGS NODE))) (SETQ TEMP (FIND-AND-PERFORM-RPLCONS-TRANSFORM (FIRST (CALL-ARGS NODE)) CONTEXT))) (SETF (CALL-ARGS NODE) NIL) (RELEASE-TREE NODE) (IL:* IL:\;  "Don't forget to free up the CDR node...") TEMP) (IL:* IL:|;;| "Sometimes a CDR is just a CDR...") (T (SETF (NODE-META-P NODE) CONTEXT) NODE)))) (DEFTRANSFORM RPLACD (NODE CONTEXT) (COND (IL:* IL:|;;| "(RPLACD (CONS A B) C) => (CONS A (PROGN B C))") ((IS-CALL-TO 'CONS (FIRST (CALL-ARGS NODE))) (LET ((CONS-NODE (FIRST (CALL-ARGS NODE)))) (SETF (SECOND (CALL-ARGS CONS-NODE)) (MAKE-PROGN :STMTS (LIST (SECOND (CALL-ARGS CONS-NODE)) (SECOND (CALL-ARGS NODE))) :META-P NIL)) (POP (CALL-ARGS NODE)) (IL:* IL:\; "Detach the CONS call.") (RELEASE-TREE NODE) (SETF (NODE-META-P CONS-NODE) CONTEXT) CONS-NODE)) (IL:* IL:|;;| "In :effect context,") (IL:* IL:|;;| "(RPLACD X (SETQ Z1 ... (SETQ Zn (CONS Y NIL))) ... )) =>") (IL:* IL:|;;| " (SETQ Z1 ... (SETQ Zn (RPLCONS X Y)) ... )") ((AND (EQ :EFFECT CONTEXT) (FIND-AND-PERFORM-RPLCONS-TRANSFORM NODE :EFFECT))) (IL:* IL:|;;| "No more transformations, so give up.") (T (SETF (NODE-META-P NODE) CONTEXT) NODE))) (DEFUN FIND-AND-PERFORM-RPLCONS-TRANSFORM (NODE CONTEXT) (IL:* IL:|;;;| "NODE is a CALL to RPLACD.") (IL:* IL:|;;;| "Look for the pattern (RPLACD X (SETQ Z1 ... (SETQ Zn (CONS Y NIL)) ... ) and, if found, return the transformed version: (SETQ Z1 ... (SETQ Zn (RPLCONS X Y)) ... ). If not found, return NIL.") (IL:* IL:|;;;| "This transformation is valid in either :effect context or as the argument to CDR.") (DO* ((INNER-NODE (SECOND (CALL-ARGS NODE)) (SETQ-VALUE INNER-NODE)) (FIRST-SETQ INNER-NODE)) ((NOT (SETQ-P INNER-NODE)) (IL:* IL:|;;| "We've traced down the tree to the bottom of the SETQ's. If the next thing is (CONS Y NIL), then change it into the appropriate RPLCONS and return the top of the series of SETQ's.") (COND ((OR (NOT (IS-CALL-TO 'CONS INNER-NODE)) (NOT (LITERAL-P (SECOND (CALL-ARGS INNER-NODE)))) (NOT (NULL (LITERAL-VALUE (SECOND (CALL-ARGS INNER-NODE)))))) NIL (IL:* IL:\;  "Nope, it's not the pattern.") ) (T (SETF (CALL-ARGS INNER-NODE) (LIST (FIRST (CALL-ARGS NODE)) (FIRST (CALL-ARGS INNER-NODE)))) (RELEASE-TREE (CALL-FN INNER-NODE)) (SETF (CALL-FN INNER-NODE) (MAKE-OPCODES :BYTES '(IL:RPLCONS))) (IL:* IL:|;;|  "The replacement node needs to have the same side-effects as the original RPLACD node did:") (SETF (CALL-EFFECTS INNER-NODE) (CALL-EFFECTS NODE)) (SETF (CALL-AFFECTED INNER-NODE) (CALL-EFFECTS NODE)) (IL:* IL:|;;| "Now dispose of the original node") (SETF (CALL-ARGS NODE) NIL) (RELEASE-TREE NODE) (SETF (NODE-META-P FIRST-SETQ) CONTEXT) FIRST-SETQ (IL:* IL:\;  "Return the stack of SETQ's as the value of this clause of the COND.") ))))) (DEFOPTIMIZER IL:FRPLACD (&REST IL:ARGS) `(RPLACD ,@IL:ARGS)) (IL:* IL:|;;| "Use the proper makefile-environment") (IL:PUTPROPS IL:XCLC-TRANSFORMS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:* IL:|;;| "Use the proper compiler.") (IL:PUTPROPS IL:XCLC-TRANSFORMS IL:FILETYPE COMPILE-FILE) (IL:PUTPROPS IL:XCLC-TRANSFORMS IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1992)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XCLC-TREES b/sources/XCLC-TREES new file mode 100644 index 00000000..931ee557 --- /dev/null +++ b/sources/XCLC-TREES @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "COMPILER" (USE "LISP" "XCL"))) (IL:FILECREATED "23-May-90 13:29:17" IL:|{DSK}local>lde>lispcore>sources>XCLC-TREES.;2| 31528 IL:|changes| IL:|to:| (IL:VARS IL:XCLC-TREESCOMS) IL:|previous| IL:|date:| " 7-Jan-88 14:50:18" IL:|{DSK}local>lde>lispcore>sources>XCLC-TREES.;1|) ; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. (IL:PRETTYCOMPRINT IL:XCLC-TREESCOMS) (IL:RPAQQ IL:XCLC-TREESCOMS ( (IL:* IL:|;;;| "Program trees") (IL:DEFINE-TYPES NODES) (IL:DECLARE\: IL:EVAL@LOAD IL:EVAL@COMPILE IL:DOCOPY (IL:FUNCTIONS NODE-TYPE-NAME CONSTRUCT-COMPILER-SYMBOL) (IL:VARIABLES *NODE-TYPES*)) (IL:FUNCTIONS MAKE-NODE-METHOD) (IL:FUNCTIONS DEFNODE) (IL:STRUCTURES NODE BLIPPER CALLER SEGMENT VARIABLE-STRUCT) (NODES BLOCK-NODE CALL-NODE CATCH-NODE GO-NODE IF-NODE LABELS-NODE LAMBDA-NODE LITERAL-NODE MV-CALL-NODE MV-PROG1-NODE OPCODES-NODE PROGN-NODE PROGV-NODE RETURN-NODE SETQ-NODE TAGBODY-NODE THROW-NODE UNWIND-PROTECT-NODE VAR-REF-NODE) (IL:VARIABLES *LITERALLY-NIL* *LITERALLY-T*) (IL:FUNCTIONS MAKE-REFERENCE-TO-VARIABLE) (IL:FUNCTIONS NODE-DISPATCH) (IL:* IL:|;;| "Eliminating tree circularities") (IL:FUNCTIONS RELEASE-TREE) (IL:FUNCTIONS DELETEF DELETEF-1 DELETEF-2) (IL:FUNCTIONS RELEASE-BLOCK RELEASE-CALL RELEASE-CATCH RELEASE-GO RELEASE-IF RELEASE-LABELS RELEASE-LAMBDA RELEASE-LITERAL RELEASE-MV-CALL RELEASE-MV-PROG1 RELEASE-OPCODES RELEASE-PROGN RELEASE-PROGV RELEASE-RETURN RELEASE-SETQ RELEASE-TAGBODY RELEASE-THROW RELEASE-UNWIND-PROTECT RELEASE-VAR-REF) (IL:* IL:|;;| "Copying tree structure") (IL:FUNCTIONS COPY-CODE COPY-NODES) (IL:VARIABLES *COPY-NODE-TABLE*) (IL:FUNCTIONS COPY-NODE-BLOCK COPY-NODE-CALL COPY-NODE-CATCH COPY-NODE-GO COPY-NODE-IF COPY-NODE-LABELS COPY-NODE-LAMBDA COPY-NODE-LITERAL COPY-NODE-MV-CALL COPY-NODE-MV-PROG1 COPY-NODE-OPCODES COPY-NODE-PROGN COPY-NODE-PROGV COPY-NODE-RETURN COPY-NODE-SETQ COPY-NODE-TAGBODY COPY-NODE-THROW COPY-NODE-UNWIND-PROTECT COPY-NODE-VAR-REF) (IL:FUNCTIONS COPY-NODE-LIST COPY-VARIABLE FIND-COPIED-VARIABLE) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP IL:FILETYPE IL:XCLC-TREES) (IL:* IL:|;;| "Arrange for the correct makefile-environment") (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:XCLC-TREES))) (IL:* IL:|;;;| "Program trees") (DEF-DEFINE-TYPE NODES "XCL compiler tree node types") (IL:DECLARE\: IL:EVAL@LOAD IL:EVAL@COMPILE IL:DOCOPY (DEFUN NODE-TYPE-NAME (TRUE-NAME) (CONSTRUCT-COMPILER-SYMBOL TRUE-NAME "-NODE")) (DEFUN CONSTRUCT-COMPILER-SYMBOL (&REST PARTS) (INTERN (APPLY 'CONCATENATE 'STRING (MAPCAR 'STRING PARTS)) "COMPILER")) (DEFVAR *NODE-TYPES* NIL "List of the names of the various kinds of parse-tree nodes. Names are put on this list by DEFNODE." ) ) (DEFMACRO MAKE-NODE-METHOD (PREFIX) (IL:* IL:|;;;| "Used only during compiler development, this is only useful inside of SEdit, when I can type") (IL:* IL:|;;| "(MAKE-NODE-METHOD FOO)") (IL:* IL:|;;;| "and then hit Meta-X to get the list of function names associated with the new FOO method on nodes. Someday, this will change to cons up the names of PCL methods.") (IL:SORT (IL:FOR F IL:IN *NODE-TYPES* IL:COLLECT (CONSTRUCT-COMPILER-SYMBOL PREFIX "-" F)))) (DEFDEFINER (DEFNODE (:NAME (LAMBDA (WHOLE) (LET* ((NAME-AND-OPTIONS (SECOND WHOLE)) (TRUE-NAME (IF (CONSP NAME-AND-OPTIONS) (FIRST NAME-AND-OPTIONS) NAME-AND-OPTIONS))) (NODE-TYPE-NAME TRUE-NAME))))) NODES (TRUE-NAME &REST DEFSTRUCT-BODY ) (LET ((PARENT 'NODE) OPTIONS) (WHEN (CONSP TRUE-NAME) (PSETQ TRUE-NAME (CAR TRUE-NAME) OPTIONS (CDR TRUE-NAME)) (IL:FOR OPTION IL:IN OPTIONS IL:DO (ECASE (FIRST OPTION) ((:PARENT) (SETQ PARENT (SECOND OPTION )))))) `(PROGN (EVAL-WHEN (COMPILE LOAD EVAL) (PUSHNEW ',TRUE-NAME *NODE-TYPES*)) (DEFSTRUCT (,(NODE-TYPE-NAME TRUE-NAME) (:CONC-NAME ,(CONSTRUCT-COMPILER-SYMBOL TRUE-NAME "-")) (:PREDICATE ,(CONSTRUCT-COMPILER-SYMBOL TRUE-NAME "-P")) (:COPIER NIL) (:CONSTRUCTOR ,(CONSTRUCT-COMPILER-SYMBOL "MAKE-" TRUE-NAME)) (:INCLUDE ,PARENT) (:INLINE NIL)) ,@DEFSTRUCT-BODY)))) (DEFSTRUCT (NODE (:INLINE T)) (IL:* IL:|;;;| "METAP is non-NIL if and only if the tree below this point has already been meta-evaluated. If a given node has this bit set, then every node below should have it set as well.") (IL:* IL:|;;;| "SUBST-P is non-NIL if and only if this node was substituted in for a variable during meta-evaluation. See META-CALL-LAMBDA-SUBSTITUTE.") (IL:* IL:|;;;| "EFFECTS is either :NONE, :CONS, :ANY, or a list of variables representing the side effects possible in the subtree below this node.") (IL:* IL:|;;;| "AFFECTED is like EFFECTS but describes the side-effects that can affect the computation of the subtree below this node.") (META-P NIL) (SUBST-P NIL) (EFFECTS NIL) (AFFECTED NIL)) (DEFSTRUCT (BLIPPER (:INCLUDE NODE) (:INLINE T)) (IL:* IL:|;;;| "REFERENCES is a list of the GO or RETURN structures whose reference will be cut off if this blipper is made into a separate frame.") (IL:* IL:|;;;| "CLOSED-OVER-P is non-NIL if this blipper has dynamically remote references.") (IL:* IL:|;;;| "NEW-FRAME-P is non-NIL if this blipper must be a separate frame.") REFERENCES CLOSED-OVER-P NEW-FRAME-P) (DEFSTRUCT (CALLER (:INCLUDE NODE) (:INLINE T)) (IL:* IL:|;;;| "Shared parent of CALL and MV-CALL.") (IL:* IL:|;;;| "NOT-INLINE is non-NIL iff this call should not be inline-expanded.") (NOT-INLINE NIL)) (DEFSTRUCT (SEGMENT (:INLINE T)) (IL:* IL:|;;;| "TAGS is a list of symbols which are tags for the forms in STMTS.") (IL:* IL:|;;;| "STMTS is a list of structures for the forms tagged by the symbols in TAGS.") (IL:* IL:|;;;| "CLOSED-OVER-P is non-NIL if this segment may be referred to from another frame.") (IL:* IL:|;;;| "LOCAL-TAG is the LAP tag to which local GOs should point.") (IL:* IL:|;;;| "REMOTE-TAG is the LAP tag to which non-local GOs should point.\"") TAGS STMTS CLOSED-OVER-P LOCAL-TAG REMOTE-TAG) (DEFSTRUCT (VARIABLE-STRUCT (:CONC-NAME VARIABLE-) (:CONSTRUCTOR MAKE-VARIABLE) (:COPIER NIL) (:PREDICATE VARIABLE-P) (:INLINE T)) (IL:* IL:|;;| "SCOPE is one of :lexical, :special or :global.") (IL:* IL:|;;| "KIND is one of :variable or :function.") (IL:* IL:|;;| "NAME is a string (for :lexical names) or symbol (for the others) giving the programmer's name for the variable.") (IL:* IL:|;;| "BINDER is the LAMBDA or LABELS structure that binds this variable.") (IL:* IL:|;;| "LAP-VAR is the LAP-code variable corresponding to this one.") (IL:* IL:|;;| "CLOSED-OVER is non-NIL if this variable might be referred to from a distance.") (IL:* IL:|;;| "READ-REFS and WRITE-REFS are lists of references to this variable in VAR-REF's and SETQ's, respectively.") (IL:* IL:|;;| "The defaults are set up to allow the easy generation of anonymous temporaries, for example during the meta-evaluation of called lambdas.") (SCOPE :LEXICAL) (KIND :VARIABLE) (NAME "Anonymous") (BINDER NIL) (READ-REFS NIL) (WRITE-REFS NIL) (LAP-VAR NIL) (CLOSED-OVER NIL)) (DEFNODE (BLOCK (:PARENT BLIPPER)) (IL:* IL:|;;;| "NAME is the symbol which names the block.") (IL:* IL:|;;;| "STMT is the structure representing the form or forms making up the body of the block.") (IL:* IL:|;;;| "CONTEXT is the evaluation context of the block, for use by any RETURN-FROM's for this block.") (IL:* IL:|;;;| "CLOSED-OVER-VARS is a list of lexical VARIABLEs whose storage should be allocated on entry to this block.") (IL:* IL:|;;;| "FRAME is the value of *current-frame* for the body of block.") (IL:* IL:|;;;| "BLIP-VAR is the LAP variable containing the value of the blip associated with this block.") (IL:* IL:|;;;| "END-TAG is the LAP tag pointing to the end of the code for this block.") (IL:* IL:|;;;| "STK-NUM is the LAP stack-level number for the context of this block.") NAME STMT CONTEXT CLOSED-OVER-VARS FRAME BLIP-VAR END-TAG STK-NUM) (DEFNODE (CALL (:PARENT CALLER)) (IL:* IL:|;;;| "FN is the value representing the function to be applied") (IL:* IL:|;;;| "ARGS is a list of structures for the arguments") FN ARGS) (DEFNODE (CATCH (:PARENT BLIPPER)) (IL:* IL:|;;;| "TAG is the structure representing the form to be evaluated to get the catch-tag.") (IL:* IL:|;;;| "STMT is the structure representing the form or forms to be evaluated inside the catch.") (IL:* IL:|;;;| "CLOSED-OVER-VARS is a list of lexical VARIABLEs whose storage should be allocated on entry to the catch body. It need not be allocated before evaluating the tag, however.") TAG STMT CLOSED-OVER-VARS) (DEFNODE GO (IL:* IL:|;;;| "TAGBODY is the structure representing the tagbody form containing the target of this go.") (IL:* IL:|;;;| "TAG is the label in that tagbody to which this go goes.") TAGBODY TAG) (DEFNODE IF (IL:* IL:|;;;| "PRED is the structure representing the predicate form.") (IL:* IL:|;;;| "THEN is the structure representing the consequent form.") (IL:* IL:|;;;| "ELSE is the structure representing the alternative form.") PRED THEN ELSE) (DEFNODE LABELS (IL:* IL:|;;;| "FUNS is an alist mapping the VARIABLE structures representing the names of the functions to the LAMBDA structures representing the functions themselves.") (IL:* IL:|;;;| "BODY is the structure representing the forms in the body of the LABELS.") (IL:* IL:|;;;| "CLOSED-OVER is a list of lexical VARIABLEs whose storage should be allocated on entry to this labels.") FUNS BODY CLOSED-OVER-VARS) (DEFNODE LAMBDA (IL:* IL:|;;;| "NAME is the string or symbol to be used to name this lambda.") (IL:* IL:|;;;| "ARG-TYPE is the Interlisp ARGTYPE of this LAMBDA or NIL if it's Common Lisp.") (IL:* IL:|;;;| "NO-SPREAD-NAME is the symbol naming the parameter of this LAMBDA if it's an Interlisp LAMBDA-NO-SPREAD, otherwise NIL. ") (IL:* IL:|;;;| "REQUIRED is a list of VARIABLEs representing the required parameters of the lambda-form.") (IL:* IL:|;;;| "OPTIONAL is a list of values representing the optional parameters of the lambda-form. Each value is a list of up to three items: the VARIABLE, the structure representing the init-form, and an optional VARIABLE representing the supplied-p parameter.") (IL:* IL:|;;;| "REST is either NIL or a VARIABLE representing the &rest parameter of the lambda-form.") (IL:* IL:|;;;| "KEYWORD is a list of lists, each one representing a keyword-parameter to the lambda-form. Each list has up to four elements: 1) The keyword to be recognized for the parameter, 2) the VARIABLE to be bound, 3) a structure representing the init-form, and 4) an optional VARIABLE representing any supplied-p parameter.") (IL:* IL:|;;;| "ALLOW-OTHER-KEYS is T if and only if &allow-other-keys was specified in the lambda-list.") (IL:* IL:|;;;| "BODY is a structure representing the form or forms of the body of the lambda-form.") (IL:* IL:|;;;| "APPLIED-EFFECTS and APPLIED-AFFECTED are the side-effects of this lambda when applied.") (IL:* IL:|;;;| "CLOSED-OVER-VARS is a list of lexical VARIABLEs to be allocated storage on entry to this lambda.") (IL:* IL:|;;;| "NEW-FRAME-P is non-NIL if this LAMBDA is to be compiled as a separate frame. Set during frame annotation and used during other annotations and code generation.") (IL:* IL:|;;;| "TAIL-CALL-TAG is, if non-NIL, a tag number to be used at the top of the body of the lambda as a target for tail-recursive jumps.") NAME ARG-TYPE NO-SPREAD-NAME REQUIRED OPTIONAL REST KEYWORD ALLOW-OTHER-KEYS BODY APPLIED-EFFECTS APPLIED-AFFECTED CLOSED-OVER-VARS NEW-FRAME-P TAIL-CALL-TAG) (DEFNODE LITERAL (IL:* IL:|;;;| "VALUE is the actual Lisp value of the literal.") VALUE) (DEFNODE (MV-CALL (:PARENT CALLER)) (IL:* IL:|;;;| "FN is a structure representing the function to be called with the values.") (IL:* IL:|;;;| "ARG-EXPRS is a list of structures representing the forms to be evaluated to generate the values.") FN ARG-EXPRS) (DEFNODE MV-PROG1 (IL:* IL:|;;;| "STMTS is a list of structures representing the forms in the body of the multiple-value-prog1. (car stmts) is the structure for the form whose values are the values of this expression.") STMTS) (DEFNODE OPCODES (IL:* IL:|;;;| "BYTES is the list of bytes to be generated.") BYTES) (DEFNODE PROGN (IL:* IL:|;;;| "STMTS is a list of the structures representing the forms of the PROGN.") STMTS) (DEFNODE PROGV (IL:* IL:|;;;| "SYMS-EXPR is the structure representing the form to be evaluated to get the list of symbols to be bound.") (IL:* IL:|;;;| "VALS-EXPR is the structure representing the form to be evaluated to get the list of values ot be bound to the symbols.") (IL:* IL:|;;;| "STMT is the structure representing the form or forms in the body of the progv.") SYMS-EXPR VALS-EXPR STMT) (DEFNODE RETURN (IL:* IL:|;;;| "BLOCK is the structure for the block from which this return-from returns.") (IL:* IL:|;;;| "VALUE is the structure for the form to be evaluated for the returned value.") BLOCK VALUE) (DEFNODE SETQ (IL:* IL:|;;;| "VAR is the VARIABLE structure representing the variable being set.") (IL:* IL:|;;;| "VALUE is the structure for the form whose value will be used.") VAR VALUE) (DEFNODE (TAGBODY (:PARENT BLIPPER)) (IL:* IL:|;;;| "SEGMENTS is a list of SEGMENT structures representing the tags and forms of the tagbody.") (IL:* IL:|;;;| "CLOSED-OVER-VARS is a list of lexical VARIABLEs to be allocated storage on entry to this tagbody.") (IL:* IL:|;;;| "FRAME is the value of *CURRENT-FRAME* at the top level of this tagbody.") (IL:* IL:|;;;| "BLIP-VAR is the LAP variable containing the control blip for this tagbody.") (IL:* IL:|;;;| "STK-NUM is the stack-state number for the top level of this tagbody.") SEGMENTS CLOSED-OVER-VARS FRAME BLIP-VAR STK-NUM) (DEFNODE THROW (IL:* IL:|;;;| "TAG is the structure for the form whose value will be the catch-tag to be thrown.") (IL:* IL:|;;;| "VALUE is the structure for the form whose values will be thrown to the tag.") TAG VALUE) (DEFNODE UNWIND-PROTECT (IL:* IL:|;;;| "STMT is the structure for the form to be protected.") (IL:* IL:|;;;| "CLEANUP is the structure for the cleanup form or forms.") STMT CLEANUP) (DEFNODE VAR-REF (IL:* IL:|;;;| "The wrapper for a variable reference. VARIABLE is the VARIABLE structure being referenced.") VARIABLE) (DEFCONSTANT *LITERALLY-NIL* (MAKE-LITERAL :VALUE NIL) "The LITERAL structure to be used for all occurences of NIL, in order to save allocations.") (DEFCONSTANT *LITERALLY-T* (MAKE-LITERAL :VALUE T) "The LITERAL structure to be used for all occurences of T, to save allocations") (DEFMACRO MAKE-REFERENCE-TO-VARIABLE (&REST ARGS) `(MAKE-VAR-REF :VARIABLE (MAKE-VARIABLE ,@ARGS))) (DEFMACRO NODE-DISPATCH (PREFIX NODE &REST ARGS) (IL:* IL:|;;;| "Expands into a ETYPECASE stmt dispatching on the given node to a call on the function named - with the NODE and the other ARGS as arguments. The node expression is evaluated only once.") `(LET (($$NODE$$ ,NODE)) (ETYPECASE $$NODE$$ ,@(MAPCAR #'(LAMBDA (TRUE-NAME) `((,(NODE-TYPE-NAME TRUE-NAME)) (,(CONSTRUCT-COMPILER-SYMBOL PREFIX "-" TRUE-NAME) $$NODE$$ ,@ARGS))) *NODE-TYPES*)))) (IL:* IL:|;;| "Eliminating tree circularities") (DEFUN RELEASE-TREE (TREE) (IL:* IL:|;;;| "Release-Tree methods should arrange for their sub-tree to be removed from the program tree. Any circularities should be removed and the results of analysis should be fixed up. However, those kinds of nodes that are shared among multiple uses in a single tree (such as variables), should not destroy any fields that other uses are counting on.") (WHEN (NOT (NULL TREE)) (SETF (NODE-EFFECTS TREE) NIL) (SETF (NODE-AFFECTED TREE) NIL) (NODE-DISPATCH RELEASE TREE))) (DEFMACRO DELETEF (ITEM PLACE) `(DELETEF-1 ,PLACE ,ITEM)) (DEFINE-MODIFY-MACRO DELETEF-1 (ITEM) DELETEF-2) (DEFMACRO DELETEF-2 (PLACE ITEM) `(DELETE ,ITEM ,PLACE)) (DEFUN RELEASE-BLOCK (NODE) (SETF (BLOCK-FRAME NODE) NIL) (SETF (BLOCK-REFERENCES NODE) NIL) (RELEASE-TREE (BLOCK-STMT NODE))) (DEFUN RELEASE-CALL (NODE) (RELEASE-TREE (CALL-FN NODE)) (MAPC #'RELEASE-TREE (CALL-ARGS NODE))) (DEFUN RELEASE-CATCH (NODE) (SETF (CATCH-REFERENCES NODE) NIL) (RELEASE-TREE (CATCH-TAG NODE)) (RELEASE-TREE (CATCH-STMT NODE))) (DEFUN RELEASE-GO (NODE) (SETF (GO-TAGBODY NODE) NIL)) (DEFUN RELEASE-IF (NODE) (RELEASE-TREE (IF-PRED NODE)) (RELEASE-TREE (IF-THEN NODE)) (RELEASE-TREE (IF-ELSE NODE))) (DEFUN RELEASE-LABELS (NODE) (IL:|for| BINDING IL:|in| (LABELS-FUNS NODE) IL:|do| (SETF (VARIABLE-BINDER (CAR BINDING)) NIL) (RELEASE-TREE (CDR BINDING))) (RELEASE-TREE (LABELS-BODY NODE))) (DEFUN RELEASE-LAMBDA (NODE) (IL:* IL:\; "") (SETF (LAMBDA-APPLIED-EFFECTS NODE) NIL) (SETF (LAMBDA-APPLIED-AFFECTED NODE) NIL) (IL:FOR VAR IL:IN (LAMBDA-REQUIRED NODE) IL:DO (SETF (VARIABLE-BINDER VAR) NIL)) (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL NODE) IL:DO (SETF (VARIABLE-BINDER (FIRST OPT-VAR)) NIL) (RELEASE-TREE (SECOND OPT-VAR)) (WHEN (THIRD OPT-VAR) (SETF (VARIABLE-BINDER (THIRD OPT-VAR)) NIL))) (WHEN (LAMBDA-REST NODE) (SETF (VARIABLE-BINDER (LAMBDA-REST NODE)) NIL)) (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD NODE) IL:DO (SETF (VARIABLE-BINDER (SECOND KEY-VAR)) NIL) (RELEASE-TREE (THIRD KEY-VAR)) (WHEN (FOURTH KEY-VAR) (SETF (VARIABLE-BINDER (FOURTH KEY-VAR)) NIL))) (RELEASE-TREE (LAMBDA-BODY NODE))) (DEFUN RELEASE-LITERAL (NODE) NIL) (DEFUN RELEASE-MV-CALL (NODE) (RELEASE-TREE (MV-CALL-FN NODE)) (MAPC #'RELEASE-TREE (MV-CALL-ARG-EXPRS NODE))) (DEFUN RELEASE-MV-PROG1 (NODE) (MAPC #'RELEASE-TREE (MV-PROG1-STMTS NODE))) (DEFUN RELEASE-OPCODES (NODE) NIL) (DEFUN RELEASE-PROGN (NODE) (MAPC #'RELEASE-TREE (PROGN-STMTS NODE))) (DEFUN RELEASE-PROGV (NODE) (RELEASE-TREE (PROGV-SYMS-EXPR NODE)) (RELEASE-TREE (PROGV-VALS-EXPR NODE)) (RELEASE-TREE (PROGV-STMT NODE))) (DEFUN RELEASE-RETURN (NODE) (RELEASE-TREE (RETURN-VALUE NODE)) (SETF (RETURN-BLOCK NODE) NIL)) (DEFUN RELEASE-SETQ (NODE) (IL:* IL:|;;;| "Remove the WRITE-REF we're getting rid of.") (DELETEF NODE (VARIABLE-WRITE-REFS (SETQ-VAR NODE))) (RELEASE-TREE (SETQ-VALUE NODE))) (DEFUN RELEASE-TAGBODY (NODE) (IL:* IL:\; "") (SETF (TAGBODY-REFERENCES NODE) NIL) (SETF (TAGBODY-FRAME NODE) NIL) (IL:|for| SEGMENT IL:|in| (TAGBODY-SEGMENTS NODE) IL:|do| (IL:|for| STMT IL:|in| ( SEGMENT-STMTS SEGMENT) IL:|do| (RELEASE-TREE STMT)))) (DEFUN RELEASE-THROW (NODE) (RELEASE-TREE (THROW-TAG NODE)) (RELEASE-TREE (THROW-VALUE NODE))) (DEFUN RELEASE-UNWIND-PROTECT (NODE) (RELEASE-TREE (UNWIND-PROTECT-STMT NODE)) (RELEASE-TREE (UNWIND-PROTECT-CLEANUP NODE))) (DEFUN RELEASE-VAR-REF (NODE) (IL:* IL:|;;;| "The binder field is cleared out in the binder itself, since that's when we can be sure that no more uses exist.") (DELETEF NODE (VARIABLE-READ-REFS (VAR-REF-VARIABLE NODE))) (SETF (VAR-REF-VARIABLE NODE) NIL)) (IL:* IL:|;;| "Copying tree structure") (DEFUN COPY-CODE (TREE) (LET ((*COPY-NODE-TABLE* (MAKE-HASH-TABLE))) (COPY-NODES TREE))) (DEFUN COPY-NODES (TREE) (IL:* IL:|;;;| "COPY-NODE methods return a subtree with the same structure as the one they're given, but without any of the analysis information filled in.") (AND TREE (NODE-DISPATCH COPY-NODE TREE))) (DEFVAR *COPY-NODE-TABLE* NIL (IL:* IL:|;;;| "A hashtable mapping nodes and other structures into their copied counterparts. Used in various COPY-NODE methods.") ) (DEFUN COPY-NODE-BLOCK (NODE) (LET ((NEW-BLOCK (MAKE-BLOCK :NAME (BLOCK-NAME NODE)))) (SETF (GETHASH NODE *COPY-NODE-TABLE*) NEW-BLOCK) (SETF (BLOCK-STMT NEW-BLOCK) (COPY-NODES (BLOCK-STMT NODE))) NEW-BLOCK)) (DEFUN COPY-NODE-CALL (NODE) (MAKE-CALL :FN (COPY-NODES (CALL-FN NODE)) :ARGS (COPY-NODE-LIST (CALL-ARGS NODE)))) (DEFUN COPY-NODE-CATCH (NODE) (MAKE-CATCH :TAG (COPY-NODES (CATCH-TAG NODE)) :STMT (COPY-NODES (CATCH-STMT NODE)))) (DEFUN COPY-NODE-GO (NODE) (LET ((TAGBODY (GETHASH (GO-TAGBODY NODE) *COPY-NODE-TABLE*))) (MAKE-GO :TAGBODY (IF (NULL TAGBODY) (IL:* IL:\;  "This GO is to a TAGBODY not being copied.") (GO-TAGBODY NODE) TAGBODY) :TAG (GO-TAG NODE)))) (DEFUN COPY-NODE-IF (NODE) (MAKE-IF :PRED (COPY-NODES (IF-PRED NODE)) :THEN (COPY-NODES (IF-THEN NODE)) :ELSE (COPY-NODES (IF-ELSE NODE)))) (DEFUN COPY-NODE-LABELS (NODE) (IL:* IL:|;;;| "Make one pass through the functions copying the variables and storing them in the hash table, then do the actual copying of the function bodies and the LABELS body.") (LET* ((NEW-LABELS (MAKE-LABELS))) (SETF (LABELS-FUNS NEW-LABELS) (IL:FOR FUN IL:IN (LABELS-FUNS NODE) IL:AS NEW-VAR IL:IN (IL:FOR FUN IL:IN (LABELS-FUNS NODE) IL:COLLECT (COPY-VARIABLE (CAR FUN) NEW-LABELS)) IL:COLLECT (CONS NEW-VAR (COPY-NODE-LAMBDA (CDR FUN))))) (SETF (LABELS-BODY NEW-LABELS) (COPY-NODES (LABELS-BODY NODE))) NEW-LABELS)) (DEFUN COPY-NODE-LAMBDA (NODE) (LET ((NEW-LAMBDA (MAKE-LAMBDA :NAME (LAMBDA-NAME NODE) :ARG-TYPE (LAMBDA-ARG-TYPE NODE) :NO-SPREAD-NAME (LAMBDA-NO-SPREAD-NAME NODE) :ALLOW-OTHER-KEYS (LAMBDA-ALLOW-OTHER-KEYS NODE)))) (SETF (LAMBDA-REQUIRED NEW-LAMBDA) (IL:FOR VAR IL:IN (LAMBDA-REQUIRED NODE) IL:COLLECT (COPY-VARIABLE VAR NEW-LAMBDA))) (SETF (LAMBDA-OPTIONAL NEW-LAMBDA) (IL:FOR OPT-VAR IL:IN (LAMBDA-OPTIONAL NODE) IL:COLLECT (LIST (COPY-VARIABLE (FIRST OPT-VAR) NEW-LAMBDA) (COPY-NODES (SECOND OPT-VAR)) (COPY-VARIABLE (THIRD OPT-VAR) NEW-LAMBDA)))) (SETF (LAMBDA-REST NEW-LAMBDA) (COPY-VARIABLE (LAMBDA-REST NODE) NEW-LAMBDA)) (SETF (LAMBDA-KEYWORD NEW-LAMBDA) (IL:FOR KEY-VAR IL:IN (LAMBDA-KEYWORD NODE) IL:COLLECT (LIST (FIRST KEY-VAR) (COPY-VARIABLE (SECOND KEY-VAR) NEW-LAMBDA) (COPY-NODES (THIRD KEY-VAR)) (COPY-VARIABLE (FOURTH KEY-VAR) NEW-LAMBDA)))) (SETF (LAMBDA-BODY NEW-LAMBDA) (COPY-NODES (LAMBDA-BODY NODE))) NEW-LAMBDA)) (DEFUN COPY-NODE-LITERAL (NODE) (IL:* IL:|;;;| "Even lowly literals are copied, since their META-P field can be important.") (MAKE-LITERAL :VALUE (LITERAL-VALUE NODE))) (DEFUN COPY-NODE-MV-CALL (NODE) (MAKE-MV-CALL :FN (COPY-NODES (MV-CALL-FN NODE)) :ARG-EXPRS (COPY-NODE-LIST (MV-CALL-ARG-EXPRS NODE)))) (DEFUN COPY-NODE-MV-PROG1 (NODE) (MAKE-MV-PROG1 :STMTS (COPY-NODE-LIST (MV-PROG1-STMTS NODE)))) (DEFUN COPY-NODE-OPCODES (NODE) (IL:* IL:|;;;| "Copy the byte-list just in case somebody wants to do a transformation on it later (ugh!).") (MAKE-OPCODES :BYTES (COPY-LIST (OPCODES-BYTES NODE)))) (DEFUN COPY-NODE-PROGN (NODE) (MAKE-PROGN :STMTS (COPY-NODE-LIST (PROGN-STMTS NODE)))) (DEFUN COPY-NODE-PROGV (NODE) (MAKE-PROGV :SYMS-EXPR (COPY-NODES (PROGV-SYMS-EXPR NODE)) :VALS-EXPR (COPY-NODES (PROGV-VALS-EXPR NODE)) :STMT (COPY-NODES (PROGV-STMT NODE)))) (DEFUN COPY-NODE-RETURN (NODE) (LET ((BLOCK (GETHASH (RETURN-BLOCK NODE) *COPY-NODE-TABLE*))) (MAKE-RETURN :BLOCK (IF (NULL BLOCK) (IL:* IL:\;  "This is a RETURN from a BLOCK not being copied.") (RETURN-BLOCK NODE) BLOCK) :VALUE (COPY-NODES (RETURN-VALUE NODE))))) (DEFUN COPY-NODE-SETQ (NODE) (MAKE-SETQ :VAR (FIND-COPIED-VARIABLE (SETQ-VAR NODE)) :VALUE (COPY-NODES (SETQ-VALUE NODE)))) (DEFUN COPY-NODE-TAGBODY (NODE) (LET ((NEW-TAGBODY (MAKE-TAGBODY))) (SETF (GETHASH NODE *COPY-NODE-TABLE*) NEW-TAGBODY) (SETF (TAGBODY-SEGMENTS NEW-TAGBODY) (IL:FOR SEGMENT IL:IN (TAGBODY-SEGMENTS NODE) IL:COLLECT (MAKE-SEGMENT :TAGS (SEGMENT-TAGS SEGMENT) :STMTS (COPY-NODE-LIST (SEGMENT-STMTS SEGMENT))))) NEW-TAGBODY)) (DEFUN COPY-NODE-THROW (NODE) (MAKE-THROW :TAG (COPY-NODES (THROW-TAG NODE)) :VALUE (COPY-NODES (THROW-VALUE NODE)))) (DEFUN COPY-NODE-UNWIND-PROTECT (NODE) (MAKE-UNWIND-PROTECT :STMT (COPY-NODES (UNWIND-PROTECT-STMT NODE)) :CLEANUP (COPY-NODES (UNWIND-PROTECT-CLEANUP NODE)))) (DEFUN COPY-NODE-VAR-REF (NODE) (MAKE-VAR-REF :VARIABLE (FIND-COPIED-VARIABLE (VAR-REF-VARIABLE NODE)))) (DEFUN COPY-NODE-LIST (NODES) (IL:FOR NODE IL:IN NODES IL:COLLECT (COPY-NODES NODE))) (DEFUN COPY-VARIABLE (VAR BINDER) (AND VAR (SETF (GETHASH VAR *COPY-NODE-TABLE*) (MAKE-VARIABLE :NAME (VARIABLE-NAME VAR) :SCOPE (VARIABLE-SCOPE VAR) :KIND (VARIABLE-KIND VAR) :BINDER BINDER)))) (DEFUN FIND-COPIED-VARIABLE (VAR) (IF (EQ :LEXICAL (VARIABLE-SCOPE VAR)) (OR (GETHASH VAR *COPY-NODE-TABLE*) VAR) (COPY-VARIABLE VAR NIL))) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PUTPROPS IL:XCLC-TREES IL:FILETYPE :COMPILE-FILE) (IL:* IL:|;;| "Arrange for the correct makefile-environment") (IL:PUTPROPS IL:XCLC-TREES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "COMPILER" (:USE "LISP" "XCL")))) (IL:PUTPROPS IL:XCLC-TREES IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL))) IL:STOP \ No newline at end of file diff --git a/sources/XMAS b/sources/XMAS new file mode 100644 index 00000000..f6a6705d --- /dev/null +++ b/sources/XMAS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED " 3-Oct-91 20:16:54" |{PELE:MV:ENVOS}SOURCES>XMAS.;1| 160511 changes to%: (RECORDS XSCREEN) (FNS CREATEXSCREEN) previous date%: " 2-Oct-91 15:15:20" {DSK}nilsson>xmas-split>XMAS.;3) (* ; " Copyright (c) 1991 by Venue. All rights reserved. ") (PRETTYCOMPRINT XMASCOMS) (RPAQQ XMASCOMS [(RECORDS XSCREEN SCREENREGION) (INITVARS XLIB::*DISPLAY* XLIB::*SCREEN* XLIB::*ROOT* XLIB::*BLACK* XLIB::*WHITE* XLIB::*DEFAULTFONT* (XLIB::*DEFAULT-FONT-NAME* "FIXED") XLIB::*GC* XLIB::*COLORMAP*) (MACROS \XCURVESMOOTH) (FNS XLIB::SETUP-CLX) (FNS \XDISPLAYINIT CREATEXSCREEN BITSPERPIXEL BITMAPHEIGHT BITMAPWIDTH DSPDESTINATION XDSPCREATE \DSPOPERATION.XDISPLAY \DSPRESET.XDISPLAY \BLTSHADE.XDISPLAY \BITBLT.XDISPLAY \XBITBLTSUB \XBLTSHADE.PIXMAP \XBITBLT.PIXMAP \DRAWPOINT.XDISPLAY \DRAWLINE.XDISPLAY \XLINEWITHBRUSH \DRAWCIRCLE.XDISPLAY \DRAWCURVE.XDISPLAY \XCURVE2 \XCURVE) (FNS BITBLT) (FNS XCREATEWFROMPIXMAP PIXMAPCREATE PIXMAPWIDTH PIXMAPHEIGHT) (FNS XCREATEW ADVISEXWDS XOPENW \XOPENW1 XCLOSEW \XCLOSEW1 \XSFFixClippingRegion XSHOWWFRAME XSHOWWTITLE \XCREATEBASEW \DSPCLIPPINGREGION.XDISPLAY) (FNS \XDSPPRINTCHAR \XBLTCHAR \XDSPPRINTCR/LF) (FNS OPENWINDOWS \INSURESCREEN DSPSOURCETYPE PUTWINDOWPROP RESHOWBORDER \XRESHOWBORDER1 \GETWINDOWHEIGHT) (FNS XWHICHW) (FNS TOTOPW) (FNS XSHAPEW1 XMOVEW XMOVEW1 XMOVEORRESIZED.WINDOW XMOVED.WINDOW) (INITVARS (\XSCREEN NIL)) [ADDVARS (\DISPLAYSTREAMTYPES XDISPLAY) (IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL) (FONTCREATE \CREATEXDISPLAYFONT) (FONTSAVAILABLE NILL) (CREATECHARSET NILL] (FILES XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA XLIB::SETUP-CLX]) (DECLARE%: EVAL@COMPILE (DATATYPE XSCREEN (SCONOFF SCDESTINATION SCTOPW SCTOPWDS SCTITLEDS SCFDEV SCDS SCDATA (* ;; "Access fns and their caches.") \SCBITSPERPIXELCACHE (* ; "The cache for pixeldepth.") \GETSCBITSPERPIXEL (* ; "The access function for pixdepth. This function must return a number, larger than 0. This function is applied to the screen structure.") \SCWIDTHCACHE (* ; "The screenwidth cache. ") \GETSCWIDTH (* ; "The access function for screenwidth. This function must return a number, larger than 0. This function is applied to the screen structure.") \SCHEIGHTCACHE (* ; "The screenheigth cache. ") \GETSCHEIGHT (* ; "The access function for screenheigth. This function must return a number, larger than 0. This function is applied to the screen structure") CREATEWFN OPENWFN CLOSEWFN) SCONOFF _ 'OFF (* ;; "The function for getting the pixeldepth of the screen.") [ACCESSFNS ((SCBITSPERPIXEL (OR \SCBITSPERPIXELCACHE (replace (XSCREEN \SCBITSPERPIXELCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCBITSPERPIXEL ) of DATUM) (LIST DATUM))) (SHOULDNT "Pixel depth of screen is NIL")) (replace (XSCREEN \SCBITSPERPIXELCACHE) of DATUM with NEWVALUE)) (SCWIDTH (OR \SCWIDTHCACHE (replace (XSCREEN \SCWIDTHCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCWIDTH ) of DATUM) (LIST DATUM))) (SHOULDNT "Width of screen is NIL")) (replace (XSCREEN \SCWIDTHCACHE) of DATUM with NEWVALUE)) (SCHEIGHT (OR \SCHEIGHTCACHE (replace (XSCREEN \SCHEIGHTCACHE) of DATUM with (APPLY (fetch (XSCREEN \GETSCHEIGHT ) of DATUM) (LIST DATUM))) (SHOULDNT "Heigth of screen is NIL")) (replace (XSCREEN \SCHEIGHTCACHE) of DATUM with NEWVALUE)) (SCREGION (create REGION LEFT _ 0 BOTTOM _ 0 (* ; "Behold clever recursion.") WIDTH _ (fetch (XSCREEN SCWIDTH) of DATUM) (* ; "Dito.") HEIGHT _ (fetch (XSCREEN SCHEIGHT) of DATUM] (SYSTEM)) (RECORD SCREENREGION (SCREEN . REGION) (SUBRECORD REGION) [TYPE? (AND (LISTP DATUM) (type? SCREEN (CAR DATUM)) (type? REGION (CDR DATUM] (SYSTEM)) ) (/DECLAREDATATYPE 'XSCREEN '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((XSCREEN 0 POINTER) (XSCREEN 2 POINTER) (XSCREEN 4 POINTER) (XSCREEN 6 POINTER) (XSCREEN 8 POINTER) (XSCREEN 10 POINTER) (XSCREEN 12 POINTER) (XSCREEN 14 POINTER) (XSCREEN 16 POINTER) (XSCREEN 18 POINTER) (XSCREEN 20 POINTER) (XSCREEN 22 POINTER) (XSCREEN 24 POINTER) (XSCREEN 26 POINTER) (XSCREEN 28 POINTER) (XSCREEN 30 POINTER) (XSCREEN 32 POINTER)) '34) (RPAQ? XLIB::*DISPLAY* NIL) (RPAQ? XLIB::*SCREEN* NIL) (RPAQ? XLIB::*ROOT* NIL) (RPAQ? XLIB::*BLACK* NIL) (RPAQ? XLIB::*WHITE* NIL) (RPAQ? XLIB::*DEFAULTFONT* NIL) (RPAQ? XLIB::*DEFAULT-FONT-NAME* "FIXED") (RPAQ? XLIB::*GC* NIL) (RPAQ? XLIB::*COLORMAP* NIL) (DECLARE%: EVAL@COMPILE (PUTPROPS \XCURVESMOOTH MACRO (OPENLAMBDA (NEWX NEWY USERFN DISPLAYSTREAM) (PROG [(DX (IABS (IDIFFERENCE NEWX \OLDX))) (DY (IABS (IDIFFERENCE NEWY \OLDY] (COND ((OR (IGREATERP DX 1) (IGREATERP DY 1)) [COND ((NEQ [IPLUS (ADD1 (IDIFFERENCE \OLDX \OLDERX)) (ITIMES 3 (ADD1 (IDIFFERENCE \OLDY \OLDERY] 4) [COND (DASHON (COND (USERFN (APPLY* USERFN \OLDX \OLDY DISPLAYSTREAM)) (T (DRAWPOINT \OLDX \OLDY BRUSHBM DISPLAYSTREAM] (COND (DASHTAIL (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] (SETQ \OLDERX \OLDX) (SETQ \OLDERY \OLDY) (SETQ \OLDX \CURX) (SETQ \OLDY \CURY))) (SETQ \CURX NEWX) (SETQ \CURY NEWY)))) ) (DEFINEQ (XLIB::SETUP-CLX [CL:LAMBDA (&OPTIONAL (XLIB:DISPLAY "unix:0.0")) (* ; "Edited 11-Sep-91 19:29 by jn") (CL:BLOCK XLIB::SETUP-CLX (LET ((XLIB::HOST-PORT (XSERVERNAME XLIB:DISPLAY))) (CL:SETQ XLIB::*DISPLAY* (XLIB:OPEN-DISPLAY (CAR XLIB::HOST-PORT) :DISPLAY (CDR XLIB::HOST-PORT))) (CL:SETQ XLIB::*SCREEN* (XLIB:DISPLAY-DEFAULT-SCREEN XLIB::*DISPLAY*)) (CL:SETQ XLIB::*BLACK* (XLIB:SCREEN-BLACK-PIXEL XLIB::*SCREEN*)) (CL:SETQ XLIB::*WHITE* (XLIB:SCREEN-WHITE-PIXEL XLIB::*SCREEN*)) (CL:SETQ XLIB::*COLORMAP* (XLIB:SCREEN-DEFAULT-COLORMAP XLIB::*SCREEN*)) (CL:SETQ XLIB::*ROOT* (XLIB:SCREEN-ROOT XLIB::*SCREEN*)) (CL:SETQ XLIB::*DEFAULTFONT* (XLIB:OPEN-FONT XLIB::*DISPLAY* XLIB::*DEFAULT-FONT-NAME*)) (CL:SETQ XLIB::*GC* (XLIB:CREATE-GCONTEXT :DRAWABLE XLIB::*ROOT*)) (CL:SETF (XLIB:DISPLAY-AFTER-FUNCTION XLIB::*DISPLAY*) #'XLIB:DISPLAY-FINISH-OUTPUT)))]) ) (DEFINEQ (\XDISPLAYINIT [LAMBDA NIL (DECLARE (GLOBALVARS XDisplayFDEV \XDISPLAYIMAGEOPS \XDisplayDeviceMethods \XDisplayDeviceData)) (* ; "Edited 16-Feb-91 15:03 by matsuda") (SETQ \XDisplayDeviceMethods (create WSOPS)) (SETQ \XDisplayDeviceData (create WSDATA WSDESTINATION _ "Destination" WSREGION _ (create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ 1024 HEIGHT _ 808))) (SETQ \XDISPLAYIMAGEOPS (create IMAGEOPS IMAGETYPE _ 'XDISPLAY IMFONT _ (FUNCTION \DSPFONT.XDISPLAY) IMLEFTMARGIN _ (FUNCTION \DSPLEFTMARGIN.DISPLAY) IMRIGHTMARGIN _ (FUNCTION \DSPRIGHTMARGIN.DISPLAY) IMLINEFEED _ (FUNCTION \DSPLINEFEED.DISPLAY) IMXPOSITION _ (FUNCTION \DSPXPOSITION.DISPLAY) IMYPOSITION _ (FUNCTION \DSPYPOSITION.DISPLAY) IMCLOSEFN _ (FUNCTION NILL) IMDRAWCURVE _ (FUNCTION \DRAWCURVE.XDISPLAY) IMFILLCIRCLE _ '\FILLCIRCLE.XDISPLAY IMDRAWLINE _ (FUNCTION \DRAWLINE.XDISPLAY) IMDRAWELLIPSE _ (FUNCTION \DRAWELLIPSE.XDISPLAY) IMDRAWCIRCLE _ (FUNCTION \DRAWCIRCLE.XDISPLAY) IMFILLPOLYGON _ (FUNCTION POLYSHADE.XDISPLAY) IMBITBLT _ (FUNCTION \BITBLT.XDISPLAY) IMSCALEDBITBLT _ (FUNCTION \SCALEDBITBLT.XDISPLAY) IMBLTSHADE _ (FUNCTION \BLTSHADE.XDISPLAY) IMNEWPAGE _ (FUNCTION \NEWPAGE.XDISPLAY) IMSCALE _ [FUNCTION (LAMBDA NIL 1] IMSPACEFACTOR _ (FUNCTION NILL) IMFONTCREATE _ 'XDISPLAY IMCOLOR _ (FUNCTION NILL) IMBACKCOLOR _ (FUNCTION \BACKCOLOR.XDISPLAY) IMOPERATION _ (FUNCTION \DSPOPERATION.XDISPLAY) IMSTRINGWIDTH _ (FUNCTION \STRINGWIDTH.XDISPLAY) IMCHARWIDTH _ (FUNCTION \CHARWIDTH.XDISPLAY) IMCLIPPINGREGION _ (FUNCTION \DSPCLIPPINGREGION.XDISPLAY) IMRESET _ (FUNCTION \DSPRESET.XDISPLAY) IMDRAWARC _ (FUNCTION \DRAWARC.XDISPLAY) IMDRAWPOLYGON _ (FUNCTION \DRAWPOLYGON.XDISPLAY) IMDRAWPOINT _ (FUNCTION \DRAWPOINT.XDISPLAY))) (SETQ XDisplayFDEV (create FDEV DEVICENAME _ 'XDISPLAY RESETABLE _ NIL RANDOMACCESSP _ NIL PAGEMAPPED _ NIL CLOSEFILE _ (FUNCTION NILL) DELETEFILE _ (FUNCTION NILL) GETFILEINFO _ (FUNCTION NILL) OPENFILE _ [FUNCTION (LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV) NAME] READPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) SETFILEINFO _ (FUNCTION NILL) GENERATEFILES _ (FUNCTION \GENERATENOFILES) TRUNCATEFILE _ (FUNCTION NILL) WRITEPAGES _ (FUNCTION \ILLEGAL.DEVICEOP) GETFILENAME _ [FUNCTION (LAMBDA (NAME RECOG FDEV) NAME] REOPENFILE _ [FUNCTION (LAMBDA (NAME) NAME] EVENTFN _ (FUNCTION \XDisplayEventFn) DIRECTORYNAMEP _ (FUNCTION NILL) HOSTNAMEP _ (FUNCTION NILL) BIN _ (FUNCTION \ILLEGAL.DEVICEOP) BOUT _ (FUNCTION \DSPPRINTCHAR) PEEKBIN _ (FUNCTION \ILLEGAL.DEVICEOP) BACKFILEPTR _ (FUNCTION \PAGEDBACKFILEPTR) BLOCKIN _ (FUNCTION \ILLEGAL.DEVICEOP) BLOCKOUT _ (FUNCTION \NONPAGEDBOUTS) WINDOWOPS _ \DisplayDeviceMethods WINDOWDATA _ \DisplayDeviceData DEVICEINFO _ (create DISPLAYSTATE))) (\DEFINEDEVICE 'XDISPLAY XDisplayFDEV]) (CREATEXSCREEN [LAMBDA (DESTINATION) (* ; "Edited 3-Oct-91 20:15 by jn") (PROG (TITLEDS SCREEN) (SETQ TITLEDS (XDSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT XWINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") [SETQ SCREEN (create XSCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCTOPW _ NIL SCTITLEDS _ TITLEDS (* ;; "Cached fns.") \GETSCWIDTH _ '[LAMBDA (DATUM) (XLIB:DRAWABLE-WIDTH (fetch (XSCREEN SCDESTINATION ) of DATUM] \GETSCHEIGHT _ '[LAMBDA (DATUM) (XLIB:DRAWABLE-HEIGHT (fetch (XSCREEN SCDESTINATION ) of DATUM] \GETSCBITSPERPIXEL _ '(LAMBDA (DATUM) (XLIB:DRAWABLE-DEPTH (fetch (XSCREEN SCDESTINATION ) of DATUM] (RETURN SCREEN]) (BITSPERPIXEL [LAMBDA (BITMAP) (* ; "Edited 31-Jan-91 14:24 by matsuda") (* ;; "returns the height in pixels of a bitmap.") (COND ((type? BITMAP BITMAP) (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-DEPTH BITMAP)) ((type? SCREEN BITMAP) (BITSPERPIXEL (fetch (SCREEN SCDESTINATION) of BITMAP))) ((type? XSCREEN BITMAP) (BITSPERPIXEL (fetch (XSCREEN SCDESTINATION) of BITMAP))) ((type? WINDOW BITMAP) (BITSPERPIXEL (fetch (WINDOW SCREEN) of BITMAP))) ((ARRAYP BITMAP) (* ;  "Consider array to be a colormap.") (SELECTQ (ARRAYSIZE BITMAP) (256 8) (16 4) (LISPERROR "ILLEGAL ARG" BITMAP))) (T (LISPERROR "ILLEGAL ARG" BITMAP]) (BITMAPHEIGHT [LAMBDA (BITMAP) (* ; "Edited 17-Jul-91 08:44 by matsuda") (* ;; "returns the height in pixels of a bitmap.") (COND ((type? BITMAP BITMAP) (fetch (BITMAP BITMAPHEIGHT) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-HEIGHT BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'HEIGHT)) (T (\ILLEGAL.ARG BITMAP]) (BITMAPWIDTH [LAMBDA (BITMAP) (* ; "Edited 17-Jul-91 08:42 by matsuda") (* ;; "returns the width of a bitmap in pixels") (COND ((type? BITMAP BITMAP) (ffetch (BITMAP BITMAPWIDTH) of BITMAP)) ((XLIB:DRAWABLE-P BITMAP) (XLIB:DRAWABLE-WIDTH BITMAP)) ((type? WINDOW BITMAP) (WINDOWPROP BITMAP 'WIDTH)) (T (\ILLEGAL.ARG BITMAP]) (DSPDESTINATION [LAMBDA (DESTINATION DISPLAYSTREAM) (* ; "Edited 31-Jan-91 14:46 by matsuda") (DECLARE (GLOBALVARS \DISPLAYIMAGEOPS \4DISPLAYIMAGEOPS \8DISPLAYIMAGEOPS \24DISPLAYIMAGEOPS \XDISPLAYIMAGEOPS)) (PROG (DD) (SETQ DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)) (RETURN (PROG1 (ffetch (\DISPLAYDATA DDDestination) of DD) [COND (DESTINATION (COND ((XLIB:DRAWABLE-P DESTINATION) (* ; "XDISPLAY case ") (UNINTERRUPTABLY (replace (STREAM DEVICE) of DISPLAYSTREAM with XDisplayFDEV) (replace (STREAM IMAGEOPS) of DISPLAYSTREAM with \XDISPLAYIMAGEOPS) (freplace (\DISPLAYDATA DDDestination) of DD with DESTINATION))) (T (* ; "LFDISPLAY case") (SETQ DESTINATION (\DTEST DESTINATION 'BITMAP)) (UNINTERRUPTABLY (replace (STREAM DEVICE) of DISPLAYSTREAM with (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL ) of DESTINATION) (1 DisplayFDEV) (4 \4DISPLAYFDEV) (8 \8DISPLAYFDEV) (24 \24DISPLAYFDEV) (SHOULDNT))) (replace (STREAM IMAGEOPS) of DISPLAYSTREAM with (SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL ) of DESTINATION) (1 \DISPLAYIMAGEOPS) (4 \4DISPLAYIMAGEOPS) (8 \8DISPLAYIMAGEOPS) (24 \24DISPLAYIMAGEOPS) (SHOULDNT))) (freplace (\DISPLAYDATA DDDestination) of DD with DESTINATION) (\SFFixDestination DD DISPLAYSTREAM))])]) (XDSPCREATE [LAMBDA (DESTINATION) (* ; "Edited 15-Feb-91 18:29 by matsuda") (LET (DSTRM GC) (COND ((XLIB:DRAWABLE-P DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \XDISPLAYIMAGEOPS DEVICE _ XDisplayFDEV ACCESS _ 'OUTPUT)) (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of DSTRM) with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION))) (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC) XLIB::*BLACK*) (* ; "temp foreground color ") (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC) XLIB::*WHITE*) (* ; "temp background color") (DSPFONT XDEFAULTFONT DSTRM) (DSPDESTINATION DESTINATION DSTRM) (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM) DSTRM) (T NIL]) (\DSPOPERATION.XDISPLAY [LAMBDA (DISPLAYSTREAM OPERATION) (* ; "Edited 15-Feb-91 12:32 by matsuda") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (fetch DDOPERATION of DD) [COND (OPERATION (OR (FMEMB OPERATION '(PAINT REPLACE INVERT ERASE)) (LISPERROR "ILLEGAL ARG" OPERATION)) (UNINTERRUPTABLY (freplace DDOPERATION of DD with OPERATION) (\SETGCFUNCTION (fetch DDPILOTBBT of DD) (fetch DDSOURCETYPE of DD) OPERATION))])]) (\DSPRESET.XDISPLAY [LAMBDA (DISPLAYSTREAM) (DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* ; "Edited 22-Feb-91 17:41 by matsuda") (LET [CREG FONT FONTASCENT (DD (\DTEST (fetch (STREAM IMAGEDATA) of (SETQ DISPLAYSTREAM (\OUTSTREAMARG DISPLAYSTREAM))) '\DISPLAYDATA] (SETQ CREG (ffetch (\DISPLAYDATA DDClippingRegion) of DD)) (SETQ FONT (fetch (\DISPLAYDATA DDFONT) of DD)) (SETQ FONTASCENT (FONTASCENT FONT)) (SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT) (0 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) (\DSPYPOSITION.DISPLAY DISPLAYSTREAM (ADD1 (IDIFFERENCE (fetch (REGION TOP) of CREG) FONTASCENT)))) (ERROR "only supported rotations are 0")) (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*) XLIB::*WHITE*) (XLIB:DRAW-RECTANGLE (fetch (\DISPLAYDATA DDDestination) of DD) XLIB::*GC* (\DSPTRANSFORMX (fetch (REGION LEFT) of CREG) DD) (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CREG) DD) (fetch (REGION WIDTH) of CREG) (fetch (REGION HEIGHT) of CREG) T) (* ; "(BITBLT NIL NIL NIL DISPLAYSTREAM (fetch (REGION LEFT) of CREG) (fetch (REGION BOTTOM) of CREG) (fetch (REGION WIDTH) of CREG) (fetch (REGION HEIGHT) of CREG) 'TEXTURE 'REPLACE (ffetch (\DISPLAYDATA DDTexture) of DD))") (* ;; "if this display stream is the tty display stream of a process, reset the # of lines in that process.") (PROG ((X (WFROMDS DISPLAYSTREAM T))) (COND ((AND X (SETQ X (WINDOWPROP X 'PROCESS)) (EQ (PROCESS.TTY X) DISPLAYSTREAM)) (PROCESS.EVAL X '(SETQ \CURRENTDISPLAYLINE 0]) (\BLTSHADE.XDISPLAY [LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (* ; "Edited 28-Feb-91 13:08 by matsuda") (* ; "BLTSHADE to a display stream") (DECLARE (LOCALVARS . T)) (PROG (left top bottom right DESTINATIONBITMAP DESTDD DESTINATIONNBITS GC PIXMAP ORGFUNCTION) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of STREAM)) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD)) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD)) (COND (CLIPPINGREGION (* ;  "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] (SETQ DESTINATIONBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ DESTINATIONNBITS (BITSPERPIXEL DESTINATIONBITMAP)) (* ;; "left, right top and bottom are the limits in destination taking into account Clipping Regions. Clip to region in the arguments of this call.") [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) (LITATOM (COND ((NULL TEXTURE) (* ;  "NIL case. default texture to background texture.") (ffetch (\DISPLAYDATA DDTexture) of DESTDD)) (T (\ILLEGAL.ARG TEXTURE)))) ((SMALLP FIXP) (LOGAND TEXTURE 65535)) (BITMAP TEXTURE) (\ILLEGAL.ARG TEXTURE))) (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE)) (SETQ ORGFUNCTION (XLIB:GCONTEXT-FUNCTION GC)) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ (OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)) (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) (CL:SETF (XLIB:GCONTEXT-TILE GC) PIXMAP) (CL:SETF (XLIB:GCONTEXT-FILL-STYLE GC) :TILED) (PROG (Y WIDTH HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP) top)) (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP GC left Y WIDTH HEIGHT :FILL-P T)) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) ORGFUNCTION) (RETURN T]) (\BITBLT.XDISPLAY [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (DECLARE (LOCALVARS . T)) (* ; "Edited 17-Jul-91 10:37 by matsuda") (PROG (stodx stody left top bottom right DESTDD DESTBITMAP DESTINATIONNBITS SOURCENBITS MAXSHADE) (SETQ DESTDD (fetch (STREAM IMAGEDATA) of DESTSTRM)) (SETQ DESTBITMAP (fetch (\DISPLAYDATA DDDestination) of DESTDD)) (SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD)) (SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD)) [PROGN (* ;  "compute limits based on clipping regions.") (SETQ left (fetch (\DISPLAYDATA DDClippingLeft) of DESTDD)) (SETQ bottom (fetch (\DISPLAYDATA DDClippingBottom) of DESTDD)) (SETQ right (fetch (\DISPLAYDATA DDClippingRight) of DESTDD)) (SETQ top (fetch (\DISPLAYDATA DDClippingTop) of DESTDD)) (COND (CLIPPINGREGION (* ;  "hard case, two destination clipping regions: do calculations to merge them.") (PROG (CRLEFT CRBOTTOM) [SETQ left (IMAX left (SETQ CRLEFT (\DSPTRANSFORMX (fetch (REGION LEFT) of CLIPPINGREGION) DESTDD] [SETQ bottom (IMAX bottom (SETQ CRBOTTOM (\DSPTRANSFORMY (fetch (REGION BOTTOM) of CLIPPINGREGION) DESTDD] [SETQ right (IMIN right (IPLUS CRLEFT (fetch (REGION WIDTH) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS CRBOTTOM (fetch (REGION HEIGHT) of CLIPPINGREGION] [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx) 0)) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody) 0)) (* ; "compute right margin") (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))) (PROG (GC HEIGHT WIDTH DTY DLX STY SLX) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DESTDD)) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP) (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (IDIFFERENCE (BITMAPWIDTH SOURCEBITMAP) top)) (SETQ SLX left) (\XBITBLTSUB GC SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE)) (RETURN T]) (\XBITBLTSUB [LAMBDA (GC SourceBitMap SLX STY DestinationDrawable DLX DTY WIDTH HEIGHT SourceType Operation Texture WindowXOffset WindowYOffset) (* ; "Edited 17-Jul-91 08:31 by matsuda") (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ SourceType (INVERT (SELECTQ SourceType (PAINT CL:BOOLE-ORC1) (INVERT CL:BOOLE-EQV) (ERASE CL:BOOLE-AND) CL:BOOLE-C1)) (SELECTQ Operation (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1))) (SELECTQ (TYPENAME SourceBitMap) (BITMAP [PROG (XIMAGE) (SETQ XIMAGE (XIMAGEFROMBITMAP SourceBitMap)) (COND ((EQ (BITSPERPIXEL SourceBitMap) 1) (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X DLX :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH :BITMAP-P T)) (T (XLIB:PUT-IMAGE DestinationDrawable GC XIMAGE :SRC-X SLX :SRC-Y STY :X DLX :Y DTY :HEIGHT HEIGHT :WIDTH WIDTH]) ((XLIB:WINDOW XLIB:PIXMAP) (XLIB:COPY-AREA SourceBitMap GC SLX STY WIDTH HEIGHT DestinationDrawable DLX DTY)) NIL]) (\XBLTSHADE.PIXMAP [LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION) (DECLARE (LOCALVARS . T)) (* ; "Edited 6-Mar-91 17:09 by matsuda") (PROG (left bottom top right PIXMAP) (SETQ left 0) (SETQ bottom 0) (SETQ top (PIXMAPHEIGHT DESTINATIONBITMAP)) (SETQ right (PIXMAPWIDTH DESTINATIONBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE) (LITATOM (* ; "includes NIL case") (COND ((NULL TEXTURE) WHITESHADE) (T (\ILLEGAL.ARG TEXTURE)))) ((SMALLP FIXP) (LOGAND TEXTURE BLACKSHADE)) (BITMAP TEXTURE) (\ILLEGAL.ARG TEXTURE))) (SETQ PIXMAP (PIXMAPFROMTEXTURE TEXTURE)) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) (SELECTQ OPERATION (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) (CL:SETF (XLIB:GCONTEXT-TILE XLIB::*GC*) PIXMAP) (CL:SETF (XLIB:GCONTEXT-FILL-STYLE XLIB::*GC*) :TILED) (PROG (Y WIDTH HEIGHT) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTINATIONBITMAP) top)) (XLIB:DRAW-RECTANGLE DESTINATIONBITMAP XLIB::*GC* left Y WIDTH HEIGHT :FILL-P T)) (RETURN T]) (\XBITBLT.PIXMAP [LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) (DECLARE (LOCALVARS . T)) (* ; "Edited 17-Jul-91 08:46 by matsuda") (PROG (stodx stody right top DESTINATIONNBITS left bottom SOURCENBITS) (SETQ top (PIXMAPHEIGHT DESTBITMAP)) (SETQ left 0) (SETQ bottom 0) (SETQ SOURCENBITS (BITSPERPIXEL SOURCEBITMAP)) (SETQ right (PIXMAPWIDTH DESTBITMAP)) [COND (CLIPPINGREGION (* ; "adjust limits") (SETQ left (IMAX left (fetch (REGION LEFT) of CLIPPINGREGION))) (SETQ bottom (IMAX bottom (fetch (REGION BOTTOM) of CLIPPINGREGION))) [SETQ right (IMIN right (IPLUS (fetch (REGION WIDTH) of CLIPPINGREGION) (fetch (REGION LEFT) of CLIPPINGREGION] (SETQ top (IMIN top (IPLUS (fetch (REGION BOTTOM) of CLIPPINGREGION) (fetch (REGION HEIGHT) of CLIPPINGREGION] [PROGN (SETQ left (IMAX DESTINATIONLEFT left)) (SETQ bottom (IMAX DESTINATIONBOTTOM bottom)) [COND (WIDTH (* ; "WIDTH is optional") (SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH) right] (COND (HEIGHT (* ; "HEIGHT is optional") (SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT) top] (* ; "Clip and translate coordinates.") (SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT)) (SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM)) [PROGN (* ; "compute left margin") (SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx))) (* ; "compute bottom margin") (SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody))) (* ; "compute right margin") (SETQ right (IMIN (BITMAPWIDTH SOURCEBITMAP) (IDIFFERENCE right stodx) (IPLUS CLIPPEDSOURCELEFT WIDTH))) (* ; "compute top margin") (SETQ top (IMIN (BITMAPHEIGHT SOURCEBITMAP) (IDIFFERENCE top stody) (IPLUS CLIPPEDSOURCEBOTTOM HEIGHT] (COND ((OR (ILEQ right left) (ILEQ top bottom)) (* ; "there is nothing to move.") (RETURN))) (SELECTQ SOURCETYPE (MERGE (\ILLEGAL.ARG TEXTURE)) NIL) (COND ((OR (XLIB:DRAWABLE-P SOURCEBITMAP) (EQ SOURCENBITS 1)) (PROG (HEIGHT WIDTH DTY DLX STY SLX) (SETQ HEIGHT (IDIFFERENCE top bottom)) (SETQ WIDTH (IDIFFERENCE right left)) (SETQ DTY (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DESTBITMAP) (IPLUS top stody))) (SETQ DLX (IPLUS left stodx)) (SETQ STY (\SFInvert SOURCEBITMAP top)) (SETQ SLX left) (\XBITBLTSUB XLIB::*GC* SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE))) (T (ERROR "Source bitmap should not color bitmaps." SOURCEBITMAP))) (RETURN T]) (\DRAWPOINT.XDISPLAY [LAMBDA (DISPLAYSTREAM X Y BRUSH OPERATION) (* ; "Edited 17-Jul-91 10:43 by matsuda") (PROG ((BRUSHBM (XPIXMAPFROMBRUSH BRUSH))) (RETURN (BITBLT BRUSHBM 0 0 DISPLAYSTREAM [IDIFFERENCE X (HALF (SUB1 (BITMAPWIDTH BRUSHBM] [IDIFFERENCE Y (HALF (SUB1 (BITMAPHEIGHT BRUSHBM] NIL NIL NIL (SELECTQ (OR OPERATION (DSPOPERATION NIL DISPLAYSTREAM)) (REPLACE 'PAINT) OPERATION]) (\DRAWLINE.XDISPLAY [LAMBDA (DISPLAYSTREAM X1 Y1 X2 Y2 WIDTH OPERATION COLOR DASHING) (* ; "Edited 16-Jul-91 13:20 by matsuda") [COND [(OR DASHING (BRUSHP WIDTH)) (LET ((BRUSH (INSURE.BRUSH WIDTH))) (if COLOR then (replace (BRUSH BRUSHCOLOR) of BRUSH with COLOR)) (\XLINEWITHBRUSH X1 Y1 X2 Y2 BRUSH (\GOOD.DASHLST DASHING BRUSH) DISPLAYSTREAM (SELECTQ OPERATION (NIL (ffetch DDOPERATION of (fetch IMAGEDATA of DISPLAYSTREAM ))) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION] (T (PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)) X Y DRAWABLE GC) (SETQ DRAWABLE (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ GC (fetch (\DISPLAYDATA DDPILOTBBT) of DD)) (SETQ X1 (\DSPTRANSFORMX (OR (FIXP X1) (FIXR X1)) DD)) (SETQ Y1 (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE) (\DSPTRANSFORMY (OR (FIXP Y1) (FIXR Y1)) DD))) (SETQ X (\DSPTRANSFORMX (OR (FIXP X2) (FIXR X2)) DD)) (SETQ Y (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT DRAWABLE) (\DSPTRANSFORMY (OR (FIXP Y2) (FIXR Y2)) DD))) (SETQ OPERATION (SELECTQ OPERATION (NIL (ffetch DDOPERATION of DD)) ((REPLACE PAINT INVERT ERASE) OPERATION) (\ILLEGAL.ARG OPERATION))) (CL:SETF (XLIB:GCONTEXT-FUNCTION GC) (SELECTQ OPERATION (REPLACE CL:BOOLE-1) (PAINT CL:BOOLE-IOR) (INVERT CL:BOOLE-XOR) (ERASE CL:BOOLE-ANDC1) CL:BOOLE-1)) [CL:SETF (XLIB:GCONTEXT-LINE-WIDTH GC) (COND ((NULL WIDTH) 1) ((OR (FIXP WIDTH) (FIXR WIDTH] (CL:SETF (XLIB:GCONTEXT-JOIN-STYLE GC) :ROUND) (CL:SETF (XLIB:GCONTEXT-CAP-STYLE GC) :ROUND) (XLIB:DRAW-LINE DRAWABLE GC X1 Y1 X Y] (MOVETO X2 Y2 DISPLAYSTREAM]) (\XLINEWITHBRUSH [LAMBDA (X1 Y1 X2 Y2 BRUSH DASHLST DISPLAYSTREAM OPERATION) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 13:38 by matsuda") (PROG (DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS HALFBRUSHWIDTH HALFBRUSHHEIGHT DX DY YINC CDL (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM))) (* ;  "arrange things so that dx is positive.") (COND ((IGREATERP X1 X2) (* ; "switch points") (swap X1 X2) (swap Y1 Y2))) (SETQ DX (ADD1 (IDIFFERENCE X2 X1))) [SETQ DY (ADD1 (COND ((IGREATERP Y2 Y1) (SETQ YINC 1) (IDIFFERENCE Y2 Y1)) (T (SETQ YINC -1) (IDIFFERENCE Y1 Y2] [SETQ CDL (HALF (COND ((IGREATERP DX DY) (* ;  "set up the bucket so that the ends will be the same.") (IREMAINDER DX DY)) (T (IREMAINDER DY DX] [COND [USERFN (* ;  "if user function is being called, don't bother bringing window to top uninterruptably.") (COND ((IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ((NOT (IGREATERP DX (add CDL DY))) (add Y1 YINC) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (add X1 1))) (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (APPLY* USERFN X1 Y1 DISPLAYSTREAM))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (add Y1 YINC] (T (* ;  "when we put the points down make it uninterruptable") (COND [(IGEQ DX DY) (* ; "X is the fastest mover.") (until (IGREATERP X1 X2) do (* ; "main loop") (COND (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DX (SETQ CDL (IPLUS CDL DY] (SETQ Y1 (IPLUS Y1 YINC)) (COND ((COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DX] (SETQ X1 (ADD1 X1] (T (* ; "Y is the fastest mover.") (until (COND ((EQ YINC -1) (ILESSP Y1 Y2)) ((IGREATERP Y1 Y2))) do (* ; "main loop") (COND (DASHON (DRAWPOINT X1 Y1 BRUSH DISPLAYSTREAM OPERATION))) [COND (DASHTAIL (* ; "do dashing.") (COND ((EQ 0 (SETQ DASHCNT (SUB1 DASHCNT))) (SETQ DASHON (NOT DASHON)) (SETQ DASHTAIL (OR (LISTP (CDR DASHTAIL)) DASHLST)) (SETQ DASHCNT (CAR DASHTAIL] [COND ([NOT (IGREATERP DY (SETQ CDL (IPLUS CDL DX] (COND ((IGREATERP (SETQ X1 (ADD1 X1)) X2) (RETURN))) (SETQ CDL (IDIFFERENCE CDL DY] (SETQ Y1 (IPLUS Y1 YINC] (RETURN NIL]) (\DRAWCIRCLE.XDISPLAY [LAMBDA (DISPLAYSTREAM CENTERX CENTERY RADIUS BRUSH DASHING) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 14:59 by matsuda") (COND ((OR (NOT (NUMBERP RADIUS)) (ILESSP (SETQ RADIUS (FIXR RADIUS)) 0)) (\ILLEGAL.ARG RADIUS)) ((EQ RADIUS 0) NIL) (DASHING (DRAWCURVE (CDR (\COMPUTE.ARC.POINTS CENTERX CENTERY RADIUS 0 360)) T BRUSH DASHING DISPLAYSTREAM)) (T (PROG (X Y D DestinationBitMap LEFT RIGHTPLUS1 TOP BOTTOM BRUSHWIDTH BRUSHHEIGHT LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH BRUSHBM DESTINATIONBASE BRUSHBASE RASTERWIDTH BRUSHRASTERWIDTH NBITSRIGHTPLUS1 OPERATION HEIGHTMINUS1 CX CY BBT COLOR COLORBRUSHBASE NBITS DISPLAYDATA USERFN) (SETQ X 0) (SETQ Y RADIUS) (SETQ D (ITIMES 2 (IDIFFERENCE 1 RADIUS))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DISPLAYSTREAM)) (SETQ USERFN (AND (LITATOM BRUSH) BRUSH)) (SETQ CX CENTERX) (SETQ CY CENTERY) [COND ((EQ RADIUS 1) (COND (USERFN (APPLY* USERFN CX CY DISPLAYSTREAM)) (T (DRAWPOINT CX CY BRUSH DISPLAYSTREAM))) (RETURN)) (T (COND (USERFN (APPLY* USERFN CX (IPLUS CY RADIUS) DISPLAYSTREAM) (APPLY* USERFN CX (IDIFFERENCE CY RADIUS) DISPLAYSTREAM)) (T (DRAWPOINT CX (IPLUS CY RADIUS) BRUSH DISPLAYSTREAM) (DRAWPOINT CX (IDIFFERENCE CY RADIUS) BRUSH DISPLAYSTREAM] LP [COND [(IGREATERP 0 D) (SETQ X (ADD1 X)) (COND ((IGREATERP (UNFOLD (IPLUS D Y) 2) 1) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS D (UNFOLD X 2) 1] ((OR (EQ 0 D) (IGREATERP X D)) (SETQ X (ADD1 X)) (SETQ D (IPLUS D (UNFOLD (IDIFFERENCE X Y) 2) 4)) (SETQ Y (SUB1 Y))) (T (SETQ D (IPLUS (IDIFFERENCE D (UNFOLD Y 2)) 3)) (SETQ Y (SUB1 Y] (COND [(EQ Y 0) (COND (USERFN (APPLY* USERFN (IPLUS CX X) CY DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) CY DISPLAYSTREAM)) (T (DRAWPOINT (IPLUS CX X) CY BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) CY BRUSH DISPLAYSTREAM] (T (COND (USERFN (APPLY* USERFN (IPLUS CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IPLUS CY Y) DISPLAYSTREAM) (APPLY* USERFN (IPLUS CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM) (APPLY* USERFN (IDIFFERENCE CX X) (IDIFFERENCE CY Y) DISPLAYSTREAM)) (T (DRAWPOINT (IPLUS CX X) (IPLUS CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) (IPLUS CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IPLUS CX X) (IDIFFERENCE CY Y) BRUSH DISPLAYSTREAM) (DRAWPOINT (IDIFFERENCE CX X) (IDIFFERENCE CY Y) BRUSH DISPLAYSTREAM))) (GO LP))) (MOVETO CENTERX CENTERY DISPLAYSTREAM) (RETURN NIL]) (\DRAWCURVE.XDISPLAY [LAMBDA (DISPLAYSTREAM KNOTS CLOSED BRUSH DASHING) (* ; "Edited 16-Jul-91 17:04 by matsuda") (PROG ((DASHLST (\GOOD.DASHLST DASHING BRUSH))) (SELECTQ (LENGTH KNOTS) (0 (* ;  "No knots => empty curve rather than error?") NIL) (1 (* ;  "only one knot, put down a brush shape") (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (\DRAWPOINT.DISPLAY DISPLAYSTREAM (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) BRUSH)) (2 (OR (type? POSITION (CAR KNOTS)) (ERROR "bad knot" (CAR KNOTS))) (OR (type? POSITION (CADR KNOTS)) (ERROR "bad knot" (CADR KNOTS))) (\XLINEWITHBRUSH (fetch XCOORD of (CAR KNOTS)) (fetch YCOORD of (CAR KNOTS)) (fetch XCOORD of (CADR KNOTS)) (fetch YCOORD of (CADR KNOTS)) BRUSH DASHLST DISPLAYSTREAM)) (\XCURVE2 (PARAMETRICSPLINE KNOTS CLOSED) BRUSH DASHLST DISPLAYSTREAM)) (RETURN DISPLAYSTREAM]) (\XCURVE2 [LAMBDA (SPLINE BRUSH DASHLST DISPLAYSTREAM) (DECLARE (SPECVARS . T)) (* ; "Edited 16-Jul-91 17:16 by matsuda") (PROG (BRUSHBM DestinationBitMap OPERATION BRUSHWIDTH BRUSHHEIGHT BRUSHBASE BRUSHRASTERWIDTH LEFT RIGHTPLUS1 TOP BOTTOM DESTINATIONBASE LEFTMINUSBRUSH BOTTOMMINUSBRUSH TOPMINUSBRUSH RASTERWIDTH NBITSRIGHTPLUS1 HEIGHTMINUS1 COLOR COLORBRUSHBASE NBITS \CURX \CURY \OLDX \OLDY \OLDERX \OLDERY LKNOT (DASHON T) (DASHTAIL DASHLST) (DASHCNT (CAR DASHLST)) NPOINTS NSEGS POINTSPERSEG DX D2X D3X DY D2Y D3Y D1 D2 D3 X0 Y0 X1 Y1 DX DDX DDDX DY DDY DDDY (XPOLY (create POLYNOMIAL)) (X/PRIME/POLY (create POLYNOMIAL)) (YPOLY (create POLYNOMIAL)) (Y/PRIME/POLY (create POLYNOMIAL)) (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) (USERFN (AND (LITATOM BRUSH) BRUSH))) (SETQ BRUSHBM (\GETBRUSH BRUSH)) (\CURVESTART (ELT (fetch (SPLINE SPLINEX) of SPLINE) 1) (ELT (fetch (SPLINE SPLINEY) of SPLINE) 1)) [bind PERSEG for KNOT from 1 to (SUB1 (fetch %#KNOTS of SPLINE)) when (PROGN (* ;;  "Loop thru the segments of the spline curve, drawing each in turn.") (SETQ X0 (ELT (fetch (SPLINE SPLINEX) of SPLINE) KNOT)) (SETQ Y0 (ELT (fetch (SPLINE SPLINEY) of SPLINE) KNOT)) (SETQ X1 (ELT (fetch (SPLINE SPLINEX) of SPLINE) (ADD1 KNOT))) (SETQ Y1 (ELT (fetch (SPLINE SPLINEY) of SPLINE) (ADD1 KNOT))) (SETQ DX (ELT (fetch (SPLINE SPLINEDX) of SPLINE) KNOT)) (SETQ DY (ELT (fetch (SPLINE SPLINEDY) of SPLINE) KNOT)) (SETQ DDX (ELT (fetch SPLINEDDX of SPLINE) KNOT)) (SETQ DDY (ELT (fetch SPLINEDDY of SPLINE) KNOT)) (SETQ DDDX (ELT (fetch SPLINEDDDX of SPLINE) KNOT)) (SETQ DDDY (ELT (fetch SPLINEDDDY of SPLINE) KNOT)) (SETQ NPOINTS (FOLDLO (ITIMES (IMAX (IABS (IDIFFERENCE X1 X0)) (IABS (IDIFFERENCE Y1 Y0))) 3) 2)) (NOT (ZEROP NPOINTS))) do [COND ((ILEQ NPOINTS 64) (SETQ NSEGS 1) (SETQ POINTSPERSEG NPOINTS)) (T (SETQ NSEGS (FOLDLO NPOINTS 64)) (SETQ POINTSPERSEG 64) (SETQ NPOINTS (UNFOLD NSEGS 64] (SETQ D1 (FQUOTIENT 1.0 NPOINTS)) (SETQ D2 (FTIMES D1 D1)) (SETQ D3 (FTIMES D2 D1)) (SETQ D3X (FTIMES D3 DDDX)) (SETQ D3Y (FTIMES D3 DDDY)) (COND [(EQ NSEGS 1) [SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES DDX D2 0.5) (FTIMES DDDX D3 (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) [SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM)) (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y NPOINTS BRUSHBM DISPLAYDATA NIL NIL NIL DISPLAYSTREAM] (T (SETQ PERSEG (FQUOTIENT 1.0 NSEGS)) (LOADPOLY XPOLY X/PRIME/POLY DDDX DDX DX X0) (LOADPOLY YPOLY Y/PRIME/POLY DDDY DDY DY Y0) (bind (TT _ 0.0) (DDDX/PER/SEG _ (FTIMES DDDX PERSEG)) (DDDY/PER/SEG _ (FTIMES DDDY PERSEG)) [D3XFACTOR _ (FTIMES D3 DDDX (CONSTANT (FQUOTIENT 1.0 6.0] [D3YFACTOR _ (FTIMES D3 DDDY (CONSTANT (FQUOTIENT 1.0 6.0] for I from 0 to (SUB1 NSEGS) do (SETQ TT (FPLUS TT PERSEG)) (SETQ X1 (POLYEVAL TT XPOLY 3)) (SETQ Y1 (POLYEVAL TT YPOLY 3)) (SETQ DX (FPLUS (FTIMES D1 DX) (FTIMES D2 DDX 0.5) D3XFACTOR)) (SETQ D2X (FPLUS (FTIMES D2 DDX) (FTIMES D3 DDDX))) (SETQ DY (FPLUS (FTIMES D1 DY) (FTIMES D2 DDY 0.5) D3YFACTOR)) (SETQ D2Y (FPLUS (FTIMES D2 DDY) (FTIMES D3 DDDY))) (COND (USERFN (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA NIL NIL USERFN DISPLAYSTREAM) ) (T (\XCURVE X0 Y0 X1 Y1 DX DY D2X D2Y D3X D3Y 64 BRUSHBM DISPLAYDATA NIL NIL NIL DISPLAYSTREAM))) (SETQ X0 X1) (SETQ Y0 Y1) (SETQ DDX (FPLUS DDX DDDX/PER/SEG)) (SETQ DDY (FPLUS DDY DDDY/PER/SEG)) (SETQ DX (POLYEVAL TT X/PRIME/POLY 2)) (SETQ DY (POLYEVAL TT Y/PRIME/POLY 2] (COND (USERFN (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T USERFN DISPLAYSTREAM)) (T (\XCURVE 0 0 0 0 0 0 0 0 0 0 0 BRUSHBM DISPLAYDATA NIL T NIL DISPLAYSTREAM]) (\XCURVE [LAMBDA (X0 Y0 X1 Y1 DX DY DDX DDY DDDX DDDY N BRUSHBM DISPLAYDATA BBT ENDING USERFN DISPLAYSTREAM) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Jul-91 16:57 by matsuda") (PROG (OLDX X Y OLDY DELTAX DELTAY DELTA TX TY OOLDX OOLDY) [COND ((NEQ N 0) (SETQ OLDX X0) (SETQ OLDY Y0) (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) (SETQ X (\CONVERTTOFRACTION (FPLUS OLDX 0.49))) (SETQ Y (\CONVERTTOFRACTION (FPLUS OLDY 0.49))) (SETQ DX (\CONVERTTOFRACTION DX)) (SETQ DY (\CONVERTTOFRACTION DY)) (SETQ DDX (\CONVERTTOFRACTION DDX)) (SETQ DDY (\CONVERTTOFRACTION DDY)) (SETQ DDDX (\CONVERTTOFRACTION DDDX)) (SETQ DDDY (\CONVERTTOFRACTION DDDY)) [for I from 1 to N do (\BOXIPLUS X DX) (\BOXIPLUS DX DDX) (\BOXIPLUS DDX DDDX) (\BOXIPLUS Y DY) (\BOXIPLUS DY DDY) (\BOXIPLUS DDY DDDY) (SETQ OOLDX OLDX) (SETQ OOLDY OLDY) (SETQ DELTAX (IDIFFERENCE (SETQ OLDX ( \GETINTEGERPART X)) OOLDX)) (SETQ DELTAY (IDIFFERENCE (SETQ OLDY ( \GETINTEGERPART Y)) OOLDY)) (SETQ DELTA (IMAX (IABS DELTAX) (IABS DELTAY))) (COND ((EQ DELTA 1) (\XCURVESMOOTH OLDX OLDY USERFN DISPLAYSTREAM) )) (COND ((IGREATERP DELTA 1) (SETQ DELTAX (\CONVERTTOFRACTION (FQUOTIENT DELTAX DELTA ))) (SETQ DELTAY (\CONVERTTOFRACTION (FQUOTIENT DELTAY DELTA ))) (SETQ TX (\CONVERTTOFRACTION OOLDX)) (SETQ TY (\CONVERTTOFRACTION OOLDY)) (for I from 0 to DELTA do (\XCURVESMOOTH (\GETINTEGERPART TX) (\GETINTEGERPART TY) USERFN DISPLAYSTREAM) (\BOXIPLUS TX DELTAX) (\BOXIPLUS TY DELTAY] (COND (USERFN (\XCURVESMOOTH X1 Y1 USERFN DISPLAYSTREAM)) (T (\XCURVESMOOTH X1 Y1 NIL DISPLAYSTREAM))) (AND DISPLAYSTREAM (MOVETO X1 Y1 DISPLAYSTREAM] (COND (ENDING (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM) (\XCURVESMOOTH (IPLUS \CURX \CURX (IMINUS \OLDX)) (IPLUS \CURY \CURY (IMINUS \OLDY)) USERFN DISPLAYSTREAM))) (RETURN NIL]) ) (DEFINEQ (BITBLT [LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION) (* ; "Edited 17-Jul-91 08:49 by matsuda") (DECLARE (LOCALVARS . T)) (* ;; "IRM defined defaults") (OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0)) (OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0)) (COND [(EQ SOURCETYPE 'TEXTURE) (COND ((type? BITMAP DESTINATION) (\BLTSHADE.BITMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)) ((XLIB:DRAWABLE-P DESTINATION) (\XBLTSHADE.PIXMAP TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)) (T (PROG ((STREAM (\OUTSTREAMARG DESTINATION))) (RETURN (IMAGEOP 'IMBLTSHADE STREAM TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION] (T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM) [COND [(OR (type? BITMAP SOURCE) (XLIB:DRAWABLE-P SOURCE)) (OR SOURCELEFT (SETQ SOURCELEFT 0)) (OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0)) (SETQ SOURCEBM SOURCE) (SETQ CLIPPEDSOURCELEFT SOURCELEFT) (SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* ;  "limit the WIDTH and HEIGHT to the source size.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (BITMAPWIDTH SOURCE) SOURCELEFT))) (T (BITMAPWIDTH SOURCE] (SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (BITMAPHEIGHT SOURCE) SOURCEBOTTOM))) (T (BITMAPHEIGHT SOURCE] ((SETQ SOURCEDD (\GETDISPLAYDATA SOURCE)) [OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT) of (ffetch (\DISPLAYDATA DDClippingRegion) of SOURCEDD] [OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM) of (ffetch (\DISPLAYDATA DDClippingRegion ) of SOURCEDD ] (* ;  "do transformations coming out of source") (SETQ SOURCEBM (fetch (\DISPLAYDATA DDDestination) of SOURCEDD)) (SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT SOURCEDD)) (fetch (\DISPLAYDATA DDClippingLeft) of SOURCEDD))) (SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM SOURCEDD)) (fetch (\DISPLAYDATA DDClippingBottom) of SOURCEDD))) (* ;  "limit the WIDTH and HEIGHT by the source dimensions.") [SETQ WIDTH (COND (WIDTH (IMIN WIDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of SOURCEDD) CLIPPEDSOURCELEFT] [SETQ HEIGHT (COND (HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop ) of SOURCEDD) CLIPPEDSOURCEBOTTOM))) (T (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingTop) of SOURCEDD) CLIPPEDSOURCEBOTTOM] (* ;  "if texture is not given, use the display stream's.") (OR TEXTURE (SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of SOURCEDD] (COND ((OR (IGEQ 0 WIDTH) (IGEQ 0 HEIGHT)) (* ;  "if either width or height is 0, don't do anything.") (RETURN))) (RETURN (COND [(type? BITMAP DESTINATION) (COND ((WINDOWP SOURCE) (* ;; "bring source window to the top. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))) (T (\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM] ((XLIB:DRAWABLE-P DESTINATION) (\XBITBLT.PIXMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)) (T (PROG (STREAM) (SETQ STREAM (\OUTSTREAMARG DESTINATION)) (COND ((AND (NEQ SOURCE DESTINATION) (WINDOWP SOURCE)) (* ;; "both source and destination are windows, see if they overlap and use an intermediate bitmap. Note: this doesn't work if the user passes in a display stream onto the screen instead of a window.") [COND ((WINDOWP DESTINATION) (COND ((WOVERLAPP SOURCE DESTINATION) (RETURN (PROG (SCRATCHBM) (.WHILE.TOP.DS. (\OUTSTREAMARG SOURCE) (BITBLT SOURCEBM SOURCELEFT SOURCEBOTTOM (SETQ SCRATCHBM (BITMAPCREATE WIDTH HEIGHT)) 0 0 WIDTH HEIGHT 'INPUT 'REPLACE)) (RETURN (BITBLT SCRATCHBM 0 0 STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION] (* ;  "bring the source to the top. this should be done uninterruptably but is better than nothing.") (TOTOPW SOURCE))) (IMAGEOP 'IMBITBLT STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM]) ) (DEFINEQ (XCREATEWFROMPIXMAP [LAMBDA (PIXMAP SCREEN) (* ; "Edited 7-Mar-91 16:39 by matsuda") (PROG (WINDOW WIDTH HEIGHT) (SETQ WINDOW (XCREATEW (create SCREENREGION SCREEN _ (\INSURESCREEN SCREEN) LEFT _ 0 BOTTOM _ 0 WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP)) HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP))) NIL 0 T)) (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH) (IMIN MinWindowWidth HEIGHT))) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW) 0 0) (RETURN WINDOW]) (PIXMAPCREATE [LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* ; "Edited 6-Mar-91 17:25 by matsuda") (PROG NIL (SETQ BITSPERPIXEL (\INSUREBITSPERPIXEL BITSPERPIXEL)) (RETURN (XLIB:CREATE-PIXMAP :WIDTH WIDTH :HEIGHT HEIGHT :DEPTH BITSPERPIXEL :DRAWABLE XLIB::*ROOT*]) (PIXMAPWIDTH [LAMBDA (PIXMAP) (* ; "Edited 6-Mar-91 16:34 by matsuda") (COND ((XLIB:DRAWABLE-P PIXMAP) (XLIB:DRAWABLE-WIDTH PIXMAP)) ((type? WINDOW PIXMAP) (WINDOWPROP PIXMAP 'WIDTH)) (T (\ILLEGAL.ARG PIXMAP]) (PIXMAPHEIGHT [LAMBDA (PIXMAP) (* ; "Edited 6-Mar-91 16:37 by matsuda") (COND ((XLIB:DRAWABLE-P PIXMAP) (XLIB:DRAWABLE-HEIGHT PIXMAP)) ((type? WINDOW PIXMAP) (WINDOWPROP PIXMAP 'HEIGHT)) (T (\ILLEGAL.ARG PIXMAP]) ) (DEFINEQ (XCREATEW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 10-Apr-91 14:02 by matsuda") (* ;; "creates and returns a window.") (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER) (SETQ WBORDER (COND ((NUMBERP BORDERSIZE) (ABS BORDERSIZE)) ((NUMBERP WBorder) (ABS WBorder)) (T 2))) (COND ((type? REGION REGION) (SETQ SCREEN \XSCREEN) (* ;  "Protect against user smashing REGION later on.") (SETQ REG (COPY REGION))) [(type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] (T (ERROR "Not a region" REG))) [COND ((NULL DSP) (* ;  "Don't have a DSP yet. User passed some kind of region.") (SETQ DSP (XDSPCREATE (fetch (XSCREEN SCDESTINATION) of SCREEN))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP] (COND ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG)) (UNFOLD WBORDER 2))) (ERROR "Region too small to use as a window" REG))) (SETQ WINDOW (create WINDOW DSP _ DSP REG _ REG SAVE _ NIL WTITLE _ TITLE WBORDER _ WBORDER NEXTW _ 'CLOSED SCREEN _ SCREEN BUTTONEVENTFN _ NIL)) (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW) (XSHOWWFRAME WINDOW) (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW) DSP) (ADVISEXWDS WINDOW) (* ;  "make the display stream and window agree about dimensions.") (MOVETOUPPERLEFT WINDOW) (AND TITLE (XLIB:SET-STANDARD-PROPERTIES (fetch (WINDOW SAVE) of WINDOW) :NAME TITLE)) (COND ((NOT NOOPENFLG) (XOPENW WINDOW))) (RETURN WINDOW]) (ADVISEXWDS [LAMBDA (WINDOW OLDREG MOVEONLYFLG) (DECLARE (LOCALVARS . T)) (* ; "Edited 25-Feb-91 18:26 by matsuda") (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET) (SETQ R (fetch (WINDOW REG) of WINDOW)) (SETQ D (fetch (WINDOW DSP) of WINDOW)) (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW)) (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2)) (COND (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN ) of WINDOW] (T 0] D))) (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2) (IDIFFERENCE WBORDERSIZE 2))) (DSPXOFFSET OFFSET D) (DSPYOFFSET OFFSET D) (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) [COND ((NULL MOVEONLYFLG) (* ;  "if the previous right margin was the default, change it.") (AND (OR (NOT OLDREG) (EQ (DSPRIGHTMARGIN NIL D) (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG) TWICEBORDER))) (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) D)) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) (EQ D (PROCESS.TTY PROC))) (* ;  "if the window changing is a tty, set its linelength.") [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT) (IQUOTIENT (fetch (REGION HEIGHT) of (SETQ CLIPREG (DSPCLIPPINGREGION NIL D))) (IMINUS (DSPLINEFEED NIL D] (PROCESS.EVAL PROC '(SETLINELENGTH)) (IF NIL THEN (* ; "try it without this.") (COND ((EQ (PROCESSPROP PROC 'NAME) 'EXEC) (* ;; "in the exec process, make sure the current position is inside the new shape. reuse variables R and TWICEBORDER to save binding.") (COND ((ILESSP (SETQ R (DSPYPOSITION NIL D)) (SETQ TWICEBORDER (fetch (REGION BOTTOM) of CLIPREG ))) (DSPYPOSITION TWICEBORDER D)) ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT) of CLIPREG) TWICEBORDER))) (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT)) D] (UPDATE/SCROLL/REG WINDOW)) WINDOW]) (XOPENW [LAMBDA (WINDOW) (* ; "Edited 31-Jan-91 15:28 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (* ;  "used to bring the window to top but doesn't since TOTOPW has been documented.") NIL) (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN] (COND ((\USERFNISDON'T USEROPENFN) (* ; "one of the OPENFNs is DON'T") NIL) (T (* ;  "open it by putting it on top and swapping its bits in") (* \OPENW1 WINDOW) (* ;  "call the openfns after the window has been opened.") (\XOPENW1 WINDOW) (DOUSERFNS USEROPENFN WINDOW) (RETURN WINDOW]) (\XOPENW1 [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 15:50 by matsuda") (if (EQ (fetch (WINDOW NEXTW) of WINDOW) 'CLOSED) then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW)) XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW) ) DD) (if BASEW then (XLIB:MAP-WINDOW BASEW) else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW))) [AND (WINDOWPROP WINDOW 'TITLE) (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW] (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW)) (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN)) (SETQ TOP 0) [COND (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0) (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW] (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP) (XLIB:MAP-SUBWINDOWS BASEW) (XLIB:MAP-WINDOW BASEW)) (UNINTERRUPTABLY (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW)) (replace (WINDOW NEXTW) of WINDOW with (fetch (XSCREEN SCTOPW) of SCREEN)) (replace (XSCREEN SCTOPW) of SCREEN with WINDOW))]) (XCLOSEW [LAMBDA (WINDOW) (* ; "Edited 31-Jan-91 16:12 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (COND ((\OKTOCLOSEW WINDOW) (AND (OPENWP WINDOW) (\XCLOSEW1 WINDOW)) T]) (\XCLOSEW1 [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 15:07 by matsuda") (LET (SCREEN NEXTW SAVE) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (SETQ NEXTW (fetch (XSCREEN SCTOPW) of SCREEN)) (COND ((NULL NEXTW) NIL) ((EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (XSCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of WINDOW with 'CLOSED)) T) (T (PROG NIL (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) LOOP (COND (NEXTW (COND [(EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (WINDOW NEXTW) of SAVE with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))] (T (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) (GO LOOP]) (\XSFFixClippingRegion [LAMBDA (DISPLAYDATA) (* ; "Edited 25-Feb-91 18:43 by matsuda") (* ;; "compute the top, bottom, left and right edges of the clipping region in destination coordinates to save computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the clipping region.") (PROG ((CLIPREG (ffetch (\DISPLAYDATA DDClippingRegion) of DISPLAYDATA)) (BM (ffetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) (GC (ffetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingRight) of DISPLAYDATA with (IMAX 0 (\DSPTRANSFORMX (IPLUS (ffetch (REGION LEFT) of CLIPREG) (ffetch (REGION WIDTH) of CLIPREG)) DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMX (ffetch (REGION LEFT) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER)) (freplace (\DISPLAYDATA DDClippingTop) of DISPLAYDATA with (IMAX 0 (\DSPTRANSFORMY (IPLUS (ffetch (REGION BOTTOM) of CLIPREG) (ffetch (REGION HEIGHT) of CLIPREG)) DISPLAYDATA))) (freplace (\DISPLAYDATA DDClippingBottom) of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMY (ffetch (REGION BOTTOM) of CLIPREG) DISPLAYDATA) 0) MAX.SMALL.INTEGER)) (CL:SETF (XLIB:GCONTEXT-CLIP-MASK GC) (LIST (fetch (\DISPLAYDATA DDClippingLeft) of DISPLAYDATA) (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT BM) (fetch (\DISPLAYDATA DDClippingTop) of DISPLAYDATA)) (fetch (REGION WIDTH) of CLIPREG) (fetch (REGION HEIGHT) of CLIPREG]) (XSHOWWFRAME [LAMBDA (WIN) (* ; "Edited 27-Feb-91 17:38 by matsuda") (* ;; "Displays the border and title in the save image of a window") [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN)) (BORDER (fetch (WINDOW WBORDER) of WIN)) (SAVEIMAGE (fetch (WINDOW SAVE) of WIN)) (SCREEN (fetch (WINDOW SCREEN) of WIN)) (REG (fetch (WINDOW REG) of WIN)) BLACKPART (TITLE-H 0)) (* ; "make most of the border black") (SETQ BLACKPART (IMAX (FOLDHI BORDER 2) (IDIFFERENCE BORDER 2))) (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN) [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW] (if SAVEIMAGE then (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE) TITLE-H) (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE) 0) (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE) (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2))) [CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE) (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2] else (replace SAVE of WIN with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW :PARENT (fetch (XSCREEN SCDESTINATION) of SCREEN) :X (fetch (REGION LEFT) of REG) :Y (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of SCREEN) (IDIFFERENCE (fetch (REGION TOP) of REG) (IPLUS TITLE-H BLACKPART))) :WIDTH (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2)) :HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2))) :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS] WIN]) (XSHOWWTITLE [LAMBDA (TITLE BM BORDER CENTERFLG WINDOW) (* ; "Edited 27-Feb-91 16:51 by matsuda") (PROG ((XTITLEW (WINDOWPROP WINDOW 'XTITLEW)) (XBASEW (WINDOWPROP WINDOW 'XBASEW)) FONT HEIGHT ASCENT (REG (fetch (WINDOW REG) of WINDOW))) (if TITLE then (SETQ HEIGHT (IPLUS (SETQ ASCENT (XLIB:FONT-ASCENT XLIB::*DEFAULTFONT*)) (XLIB:FONT-DESCENT XLIB::*DEFAULTFONT*))) (if XTITLEW then (CL:SETF (XLIB:DRAWABLE-WIDTH XTITLEW) (fetch (REGION WIDTH) of REG)) else (SETQ XTITLEW (XLIB:CREATE-WINDOW :PARENT (OR XBASEW XLIB::*ROOT*) :X 0 :Y 0 :WIDTH (IPLUS (fetch (REGION WIDTH) of REG) (IMAX (ITIMES (- BORDER 2) 2) 0)) :HEIGHT (IPLUS HEIGHT 2) :BORDER-WIDTH 0 :BACKGROUND XLIB::*BLACK* :BACKING-STORE :ALWAYS :BIT-GRAVITY :NORTH-WEST)) ) (if XBASEW then (XLIB:MAP-WINDOW XTITLEW)) (CL:SETF (XLIB:GCONTEXT-FONT XLIB::*GC*) XLIB::*DEFAULTFONT*) (CL:SETF (XLIB:GCONTEXT-FOREGROUND XLIB::*GC*) XLIB::*WHITE*) (CL:SETF (XLIB:GCONTEXT-BACKGROUND XLIB::*GC*) XLIB::*BLACK*) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:CLEAR-AREA XTITLEW) (XLIB:DRAW-IMAGE-GLYPHS XTITLEW XLIB::*GC* BORDER (ADD1 ASCENT) TITLE) else (AND XTITLEW (XLIB:DESTROY-WINDOW XTITLEW)) (SETQ XTITLEW NIL)) (WINDOWPROP WINDOW 'XTITLEW XTITLEW) (RETURN XTITLEW]) (\XCREATEBASEW [LAMBDA (WINDOW) (* ; "Edited 11-Jul-91 14:07 by matsuda") (PROG ((XWIN (fetch (WINDOW SAVE) of WINDOW)) (XTITLEW (WINDOWPROP WINDOW 'XTITLEW)) (REG (fetch (WINDOW REG) WINDOW)) (XCURSOR (XCURSORFROMCURSOR DEFAULTCURSOR)) WIDTH HEIGHT XBORDER BASEW TITLE) [SETQ WIDTH (IPLUS (XLIB:DRAWABLE-WIDTH XWIN) (SETQ XBORDER (ITIMES (XLIB:DRAWABLE-BORDER-WIDTH XWIN) 2] (SETQ HEIGHT (IPLUS (XLIB:DRAWABLE-HEIGHT XWIN) XBORDER)) [COND (XTITLEW (SETQ HEIGHT (IPLUS HEIGHT (XLIB:DRAWABLE-HEIGHT XTITLEW] (SETQ BASEW (XLIB:CREATE-WINDOW :PARENT XLIB::*ROOT* :X (fetch (REGION LEFT) of REG) :Y (fetch (REGION TOP) of REG) :WIDTH WIDTH :HEIGHT HEIGHT :BORDER-WIDTH 0 :BACKGROUND XLIB::*WHITE* :GRAVITY :NORTH-WEST :CURSOR XCURSOR :EVENT-MASK (XLIB:MAKE-EVENT-MASK :STRUCTURE-NOTIFY :KEY-PRESS :KEY-RELEASE :BUTTON-PRESS :BUTTON-RELEASE :POINTER-MOTION :ENTER-WINDOW :LEAVE-WINDOW))) (WINDOWPROP WINDOW 'XCURSOR XCURSOR) (AND (SETQ TITLE (WINDOWPROP WINDOW 'TITLE)) (XLIB:SET-STANDARD-PROPERTIES BASEW :NAME TITLE :INPUT :ON)) (RETURN BASEW]) (\DSPCLIPPINGREGION.XDISPLAY [LAMBDA (DISPLAYSTREAM REGION) (* ; "Edited 1-Feb-91 10:01 by matsuda") (* ;; "sets the clipping region of a display stream.") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM))) (RETURN (PROG1 (ffetch DDClippingRegion of DD) [COND (REGION (OR (type? REGION REGION) (ERROR REGION " is not a REGION.")) (UNINTERRUPTABLY (freplace DDClippingRegion of DD with REGION) (\XSFFixClippingRegion DD) (\INVALIDATEDISPLAYCACHE DD))])]) ) (DEFINEQ (\XDSPPRINTCHAR [LAMBDA (STREAM CHARCODE) (* ; "Edited 15-Feb-91 17:37 by matsuda") (PROG ((DD (ffetch (STREAM IMAGEDATA) of STREAM))) (* \CHECKCARET STREAM) (\MAYBE-DRIBBLE-CHAR STREAM CHARCODE) (* ; "if dribbling, dribble.") (SELECTC (ffetch (TERMCODE CCECHO) of (\SYNCODE \PRIMTERMSA CHARCODE)) (REAL.CCE (* ;; "All fat characters are defined as REAL according to \SYNCODE, so we don't have worry about any of the special cases") [COND ((IGREATERP CHARCODE (CONSTANT (IMAX (CHARCODE EOL) (CHARCODE CR) (CHARCODE LF) ERASECHARCODE))) (* ;  "This is for sure a printing character; take the fast way out.") (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (T (* ; "Take the slow check.") (SELECTC CHARCODE ((CHARCODE (EOL CR LF)) (\XDSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A) STREAM) STREAM) (* ;  "line buffering routines have already taken care of backing up the position") 0) (PROGN (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1]) (INDICATE.CCE (* ;  "Make sure that all the chars in the indicate-string fit on the line or wrap-around together.") (PROG (STR) (SETQ STR (\INDICATESTRING CHARCODE)) (* ; "This isn't right for rotated fonts. But then there should probably be a separate rotated outcharfn") [COND ((IGREATERP (\STRINGWIDTH.DISPLAY STREAM STR) (IDIFFERENCE (ffetch (\DISPLAYDATA DDRightMargin) of DD) (ffetch (\DISPLAYDATA DDXPOSITION) of DD))) (\XDSPPRINTCR/LF (CHARCODE EOL) STREAM) (freplace (STREAM CHARPOSITION) of STREAM with (NCHARS STR))) (T (add (ffetch (STREAM CHARPOSITION) of STREAM) (NCHARS STR] (for I from 1 do (\XBLTCHAR (OR (NTHCHARCODE STR I) (RETURN)) STREAM DD)))) (SIMULATE.CCE (SELCHARQ CHARCODE ((EOL CR LF) (\XDSPPRINTCR/LF CHARCODE STREAM) (freplace (STREAM CHARPOSITION) of STREAM with 0)) (ESCAPE (\XBLTCHAR (CHARCODE $) STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)) (BELL (* ;  "make switching of bits uninterruptable but allow interrupts between flashes.") (SELECTC \MACHINETYPE ((LIST \DANDELION \DAYBREAK \MAIKO) [PLAYTUNE '((880 . 2500]) (FLASHWINDOW (WFROMDS STREAM)))) (TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE) STREAM))) (SETQ TABWIDTH (UNFOLD SPACEWIDTH 8)) (COND ((IGREATERP (\DISPLAYSTREAMINCRXPOSITION (SETQ TABWIDTH (IDIFFERENCE TABWIDTH (MOD (IDIFFERENCE (ffetch (\DISPLAYDATA DDXPOSITION) of DD) (ffetch (\DISPLAYDATA DDLeftMargin) of DD)) TABWIDTH))) DD) (ffetch (\DISPLAYDATA DDRightMargin) of DD)) (* ;  "tab was past rightmargin, force cr.") (\XDSPPRINTCR/LF (CHARCODE EOL) STREAM))) (* ;  "return the number of spaces taken.") (add (ffetch (STREAM CHARPOSITION) of STREAM) (IQUOTIENT TABWIDTH SPACEWIDTH)))) (PROGN (* ;  "this case was copied from \DSCCOUT.") (\XBLTCHAR CHARCODE STREAM DD) (add (ffetch (STREAM CHARPOSITION) of STREAM) 1)))) (IGNORE.CCE) (SHOULDNT]) (\XBLTCHAR [LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (DECLARE (LOCALVARS . T)) (* ; "Edited 1-Oct-91 13:38 by jn") (PROG (LOCAL1 RIGHT LEFT CURX CURY CHAR8CODE DESTINATION) (SETQ CHAR8CODE (\CHAR8CODE CHARCODE)) CRLP [COND ((NOT (EQ (ffetch (\DISPLAYDATA DDCHARSET) of DISPLAYDATA) (\CHARSET CHARCODE))) (\CHANGECHARSET.XDISPLAY DISPLAYDATA (\CHARSET CHARCODE] (SETQ CURX (ffetch (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA)) (SETQ RIGHT (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) [COND ((IGREATERP RIGHT (ffetch (\DISPLAYDATA DDRightMargin) of DISPLAYDATA)) (* ;  "would go past right margin, force a cr") (COND ((IGREATERP CURX (ffetch (\DISPLAYDATA DDLeftMargin) of DISPLAYDATA)) (* ;  "don't bother CR if position is at left margin anyway. This also serves to break the loop.") (\XDSPPRINTCR/LF (CHARCODE EOL) DISPLAYSTREAM) (* ;  "reuse the code in the test of this conditional rather than repeat it here.") (GO CRLP] (* ;  "update the display stream x position.") (freplace (\DISPLAYDATA DDXPOSITION) of DISPLAYDATA with (IPLUS CURX ( \DSPGETCHARWIDTH CHAR8CODE DISPLAYDATA))) (* ;  "transforms an x coordinate into the destination coordinate.") (SETQ LOCAL1 (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA)) (SETQ CURX (IPLUS CURX LOCAL1)) (SETQ CURY (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DISPLAYDATA) (ffetch (\DISPLAYDATA DDXOFFSET) of DISPLAYDATA))) (XLIB:DRAW-IMAGE-GLYPH (SETQ DESTINATION (fetch (\DISPLAYDATA DDDestination) of DISPLAYDATA)) (fetch (\DISPLAYDATA DDPILOTBBT) of DISPLAYDATA) CURX (IDIFFERENCE (\GETWINDOWHEIGHT (* ;  "No roundtrip needed BUT: we have to remember to keep the height in sync with reality. /jarl") (WFROMDS DISPLAYSTREAM)) CURY) CHAR8CODE) (RETURN T]) (\XDSPPRINTCR/LF [LAMBDA (CHARCODE DISPLAY-STREAM) (* ; "Edited 28-Feb-91 12:05 by matsuda") (COND ((EQ DISPLAY-STREAM (TTYDISPLAYSTREAM)) (\STOPSCROLL?) (* ;  "\STOPSCROLL may have turned on the caret.") (* \CHECKCARET DISPLAY-STREAM) )) (PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch (STREAM IMAGEDATA) of DISPLAY-STREAM)) ) (COND ((EQ CHARCODE (CHARCODE EOL)) (* ; "on LF, no change in X") (COND ((SETQ Y (fetch (\DISPLAYDATA DDEOLFN) of DD)) (* ; "call the eol function for ds.") (APPLY* Y DISPLAY-STREAM))) (DSPXPOSITION (ffetch (\DISPLAYDATA DDLeftMargin) of DD) DISPLAY-STREAM))) (SETQ Y (IPLUS (ffetch (\DISPLAYDATA DDYPOSITION) of DD) (ffetch (\DISPLAYDATA DDLINEFEED) of DD))) [COND ((AND (fetch (\DISPLAYDATA DDScroll) of DD) (IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM (fetch (\DISPLAYDATA DDClippingBottom ) of DD)) (fetch (FONTDESCRIPTOR \SFDescent) of (fetch (\DISPLAYDATA DDFONT) of DD))) (\DSPTRANSFORMY Y DD))) 0)) (* ;; "automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of characters will be printed also.") [PROG (LFT WDTH BKGRND DBITMAP HGHT H) (SETQ LFT (fetch (\DISPLAYDATA DDClippingLeft) of DD)) (SETQ DBITMAP (fetch (\DISPLAYDATA DDDestination) of DD)) (SETQ HGHT (IDIFFERENCE (ffetch (\DISPLAYDATA DDClippingTop) of DD) BTM)) (SETQ WDTH (IDIFFERENCE (fetch (\DISPLAYDATA DDClippingRight) of DD) LFT)) (SETQ BKGRND (ffetch (\DISPLAYDATA DDTexture) of DD)) (COND ((IGREATERP AMOUNT/BELOW HGHT) (* ;  "scrolling more than the window size, use different method.") (* ;  "clear the window with background.") (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH HGHT 'REPLACE)) (T (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA DBITMAP XLIB::*GC* LFT [IDIFFERENCE (SETQ H ( XLIB:DRAWABLE-HEIGHT DBITMAP)) (IPLUS BTM (SETQ HGHT (IDIFFERENCE HGHT AMOUNT/BELOW] WDTH HGHT DBITMAP LFT (IDIFFERENCE H (IPLUS (IPLUS BTM AMOUNT/BELOW) HGHT))) (BLTSHADE BKGRND DISPLAY-STREAM LFT BTM WDTH AMOUNT/BELOW 'REPLACE] (SETQ Y (IPLUS Y AMOUNT/BELOW] (DSPYPOSITION Y DISPLAY-STREAM]) ) (DEFINEQ (OPENWINDOWS [LAMBDA (SCREEN) (* ; "Edited 15-Feb-91 16:24 by matsuda") (* ;; "returns a list of all open windows") (PROG (WINDOW WINDOWS) (COND ((EQ SCREEN T) (* ; "Return all open windows.") (SETQ WINDOWS (for SCREEN in \SCREENS join (OPENWINDOWS SCREEN))) (RETURN WINDOWS))) (SETQ SCREEN (\INSURESCREEN SCREEN)) [SETQ WINDOW (COND ((type? SCREEN SCREEN) (fetch (SCREEN SCTOPW) of SCREEN)) ((type? XSCREEN SCREEN) (fetch (XSCREEN SCTOPW) of SCREEN] (while WINDOW do (SETQ WINDOWS (CONS WINDOW WINDOWS)) (SETQ WINDOW (fetch (WINDOW NEXTW) of WINDOW))) (SETQ WINDOWS (DREVERSE WINDOWS)) (RETURN WINDOWS]) (\INSURESCREEN [LAMBDA (SCREEN) (* ; "Edited 15-Feb-91 16:22 by matsuda") (COND ((type? SCREEN SCREEN) SCREEN) ((type? XSCREEN SCREEN) SCREEN) ((NULL SCREEN) \CURSORSCREEN) (T (\ILLEGAL.ARG SCREEN]) (DSPSOURCETYPE [LAMBDA (SOURCETYPE DISPLAYSTREAM) (* ; "Edited 15-Feb-91 13:02 by matsuda") (* ;; "sets the operation field of a display stream") (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)) PBT) (RETURN (PROG1 (fetch DDSOURCETYPE of DD) [COND (SOURCETYPE (OR (FMEMB SOURCETYPE '(INPUT INVERT)) (LISPERROR "ILLEGAL ARG" SOURCETYPE)) (UNINTERRUPTABLY (freplace DDSOURCETYPE of DD with SOURCETYPE) (* ;  "update other fields that depend on operation.") [COND ((type? PILOTBBT (SETQ PBT (fetch DDPILOTBBT of DD))) (\SETPBTFUNCTION PBT SOURCETYPE (fetch DDOPERATION of DD))) ((XLIB:GCONTEXT-P PBT) (\SETGCFUNCTION PBT SOURCETYPE (fetch DDOPERATION of DD])])]) (PUTWINDOWPROP [LAMBDA (WINDOW PROP VALUE) (* ; "Edited 27-Feb-91 16:46 by matsuda") [OR (type? WINDOW WINDOW) (COND ((DISPLAYSTREAMP (\OUTSTREAMARG WINDOW)) (SETQ WINDOW (WFROMDS WINDOW))) (T (\ILLEGAL.ARG WINDOW] (SELECTQ PROP (RIGHTBUTTONFN (PROG1 (fetch (WINDOW RIGHTBUTTONFN) of WINDOW) (replace (WINDOW RIGHTBUTTONFN) of WINDOW with VALUE))) (BUTTONEVENTFN (PROG1 (fetch (WINDOW BUTTONEVENTFN) of WINDOW) (replace (WINDOW BUTTONEVENTFN) of WINDOW with VALUE))) (CLOSEFN (PROG1 (fetch (WINDOW CLOSEFN) of WINDOW) (replace (WINDOW CLOSEFN) of WINDOW with VALUE))) (MOVEFN (PROG1 (fetch (WINDOW MOVEFN) of WINDOW) (replace (WINDOW MOVEFN) of WINDOW with VALUE))) (CURSORINFN (PROG1 (fetch (WINDOW CURSORINFN) of WINDOW) (replace (WINDOW CURSORINFN) of WINDOW with VALUE))) (CURSOROUTFN (PROG1 (fetch (WINDOW CURSOROUTFN) of WINDOW) (replace (WINDOW CURSOROUTFN) of WINDOW with VALUE))) (CURSORMOVEDFN (PROG1 (fetch (WINDOW CURSORMOVEDFN) of WINDOW) (replace (WINDOW CURSORMOVEDFN) of WINDOW with VALUE))) (DSP (ERROR "Can't change DSP of a window" WINDOW)) (SCREEN (ERROR "Can't change SCREEN of a window" WINDOW)) (RESHAPEFN (PROG1 (fetch (WINDOW RESHAPEFN) of WINDOW) (replace (WINDOW RESHAPEFN) of WINDOW with VALUE))) (REPAINTFN (PROG1 (fetch (WINDOW REPAINTFN) of WINDOW) (replace (WINDOW REPAINTFN) of WINDOW with VALUE))) (EXTENT (PROG1 (fetch (WINDOW EXTENT) of WINDOW) (OR (NULL VALUE) (REGIONP VALUE) (\ILLEGAL.ARG VALUE)) (replace (WINDOW EXTENT) of WINDOW with VALUE))) (SCROLLFN (PROG1 (fetch (WINDOW SCROLLFN) of WINDOW) (replace (WINDOW SCROLLFN) of WINDOW with VALUE) (UPDATE/SCROLL/REG WINDOW))) (IMAGECOVERED (ERROR "Not implemented to change IMAGECOVERED property." WINDOW)) (HEIGHT (ERROR "Not implemented to change HEIGHT as property." WINDOW)) (WIDTH (ERROR "Not implemented to change WIDTH as property." WINDOW)) (REGION [PROG (CURREGION) (SETQ CURREGION (WINDOWPROP WINDOW 'REGION)) (COND ((NOT (REGIONP VALUE)) (\ILLEGAL.ARG VALUE))) (* ;; "there is no check for where the new region is nor how big it is; this is left to MOVEW and RESHAPEW.") (COND ((AND (EQ (fetch (REGION WIDTH) of CURREGION) (fetch (REGION WIDTH) of VALUE)) (EQ (fetch (REGION HEIGHT) of CURREGION) (fetch (REGION HEIGHT) of VALUE))) (* ;  "width and height are the same, move the window") (MOVEW WINDOW (fetch (REGION LEFT) of VALUE) (fetch (REGION BOTTOM) of VALUE))) (T (* ; "dimensions changed, reshape it.") (SHAPEW WINDOW VALUE]) (NEWREGIONFN (PROG1 (fetch (WINDOW NEWREGIONFN) of WINDOW) (replace (WINDOW NEWREGIONFN) of WINDOW with VALUE))) (TITLE (PROG1 (fetch (WINDOW WTITLE) of WINDOW) (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (RESHOWTITLE VALUE WINDOW)) ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (replace (WINDOW WTITLE) of WINDOW with VALUE) (XSHOWWTITLE VALUE NIL (fetch (WINDOW WBORDER) of WINDOW) NIL WINDOW))))) (BORDER (PROG1 (fetch (WINDOW WBORDER) of WINDOW) (COND ((NUMBERP VALUE) (RESHOWBORDER VALUE WINDOW)) (T (\ILLEGAL.ARG VALUE))))) (PROCESS (PROG1 (fetch (WINDOW PROCESS) of WINDOW) (replace (WINDOW PROCESS) of WINDOW with VALUE))) (WINDOWENTRYFN (PROG1 (fetch (WINDOW WINDOWENTRYFN) of WINDOW) (replace (WINDOW WINDOWENTRYFN) of WINDOW with VALUE))) (PROG (OLDDATA OLDVALUE) (SETQ OLDDATA (fetch (WINDOW USERDATA) of WINDOW)) (RETURN (PROG1 (COND (OLDDATA (SETQ OLDVALUE (LISTGET OLDDATA PROP)) [COND (VALUE (LISTPUT OLDDATA PROP VALUE)) (OLDVALUE (* Remove the property) (COND ((EQ (CAR OLDDATA) PROP) (replace (WINDOW USERDATA) of WINDOW with (CDDR OLDDATA))) (T (for TAIL on (CDR OLDDATA) by (CDDR TAIL) when (EQ (CADR TAIL) PROP) do (FRPLACD TAIL (CDDDR TAIL)) (RETURN] OLDVALUE) (VALUE (replace (WINDOW USERDATA) of WINDOW with (LIST PROP VALUE)) (* know old value is NIL) NIL)) (COND ((AND (fetch (WINDOW WTITLE) of WINDOW) (EQ PROP 'WINDOWTITLESHADE)) (* change windowtitleshade.) (RESHOWTITLE (fetch (WINDOW WTITLE) of WINDOW) WINDOW T))))]) (RESHOWBORDER [LAMBDA (BORDER WINDOW) (* ; "Edited 27-Feb-91 17:15 by matsuda") (* ;; "updates a windows display with a new border") (* ;  "if the border is the same, don't change anything.") (OR (EQ BORDER (fetch (WINDOW WBORDER) of WINDOW)) (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (\RESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW) WINDOW)) ((type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (\XRESHOWBORDER1 BORDER (fetch (WINDOW WBORDER) of WINDOW) WINDOW]) (\XRESHOWBORDER1 [LAMBDA (NEWBORDER OLDBORDER WINDOW) (* ; "Edited 27-Feb-91 17:45 by matsuda") (PROG ((REGION (fetch (WINDOW REG) of WINDOW)) (OLDSAVE (fetch (WINDOW SAVE) of WINDOW)) DELTA NUWIDTH NUHEIGHT XBASEW) (SETQ DELTA (IDIFFERENCE NEWBORDER OLDBORDER)) (SETQ NUWIDTH (IPLUS (fetch (REGION WIDTH) of REGION) (ITIMES DELTA 2))) [SETQ NUHEIGHT (IDIFFERENCE (IPLUS (fetch (REGION HEIGHT) of (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (ITIMES NEWBORDER 2)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] (replace (WINDOW WBORDER) of WINDOW with NEWBORDER) (CL:SETF (XLIB:DRAWABLE-BORDER-WIDTH OLDSAVE) (IMAX (FOLDHI NEWBORDER 2) (IDIFFERENCE NEWBORDER 2))) (replace (WINDOW REG) of WINDOW with (create REGION LEFT _ (IDIFFERENCE (fetch (REGION LEFT) of REGION) DELTA) BOTTOM _ (IDIFFERENCE (fetch (REGION BOTTOM ) of REGION) DELTA) WIDTH _ NUWIDTH HEIGHT _ NUHEIGHT)) (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (if (SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) then (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW) NUWIDTH) (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW) NUHEIGHT)) (UPDATE/SCROLL/REG WINDOW) (XSHOWWFRAME WINDOW]) (\GETWINDOWHEIGHT [LAMBDA (WINDOW) (* ; "Edited 27-Feb-91 16:24 by matsuda") (* ;; "calculate the height from the REGION in case user has changed the clipping region. This won't work if the height of the title display stream has changed.") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (DIFFERENCE (fetch (REGION HEIGHT) of (fetch (WINDOW REG) of WINDOW)) (DIFFERENCE (ITIMES 2 (fetch (WINDOW WBORDER) of WINDOW)) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (COND ((type? SCREEN (fetch (WINDOW SCREEN) of WINDOW )) (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW))) ((TYPE? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (fetch (XSCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0]) ) (DEFINEQ (XWHICHW [LAMBDA NIL (* ; "Edited 10-Apr-91 14:11 by matsuda") XLASTWINDOW]) ) (DEFINEQ (TOTOPW [LAMBDA (WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 2-Oct-91 15:13 by jn") (* ;; "user entry to bring a window to the top. Unless NOCALLTOTOPFNFLG is non-NIL, it will call the windows TOTOPFN") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND [(type? XSCREEN (fetch (WINDOW SCREEN) of WINDOW)) (XLIB:CIRCULATE-WINDOW-UP (WINDOWPROP WINDOW 'XBASEW] ((EQ WINDOW (fetch (SCREEN SCTOPW) of (fetch (WINDOW SCREEN) of WINDOW))) (PROGN (* (SETQ \TOPWDS (fetch  (WINDOW DSP) of WINDOW))) NIL)) ((OPENWP WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW)) (\INTERNALTOTOPW WINDOW)) ((OPENW WINDOW) (* ;  "if it is not open, open it and then call the TOTOPFN") (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW))) (T (* ;  "window won't open probably because of DON'T OPENFN") (ERROR "Window won't open; Can't be brought to top." WINDOW))) WINDOW]) ) (DEFINEQ (XSHAPEW1 [LAMBDA (WINDOW REGION) (DECLARE (LOCALVARS . T)) (* ; "Edited 16-Feb-91 16:14 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (OLDCLIPREG (DSPCLIPPINGREGION NIL (fetch (WINDOW DSP) of WINDOW))) (WBORDER (fetch (WINDOW WBORDER) of WINDOW)) SCREEN NUSAV NOWOPEN?) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (UNINTERRUPTABLY (* ; "Save window image") (replace (WINDOW REG) of WINDOW with REGION) (ADVISEXWDS WINDOW OLDREGION) (XSHOWWFRAME WINDOW)) (* ; " (DOUSERFNS2 (OR (fetch (WINDOW RESHAPEFN) of WINDOW) (FUNCTION RESHAPEBYREPAINTFN)) WINDOW NUSAV (create REGION LEFT _ WBORDER BOTTOM _ WBORDER WIDTH _ (fetch (REGION WIDTH) of OLDCLIPREG) HEIGHT _ (fetch (REGION HEIGHT) of OLDCLIPREG)) OLDREGION)") (RETURN WINDOW]) (XMOVEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 7-Mar-91 14:24 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (XMOVEW1 [LAMBDA (WINDOW POSorX Y) (* ; "Edited 16-Feb-91 18:04 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT POS NEWREGION REG) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) [AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (ffetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW]) (XMOVEORRESIZED.WINDOW [LAMBDA (WINDOW X Y WIDTH HEIGHT) (* ; "Edited 11-Apr-91 09:37 by matsuda") (PROG ((NEXTW (fetch (XSCREEN SCTOPW) of \XSCREEN)) XBASEW OLDREG NEWREG) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND [(EQ WINDOW XBASEW) (SETQ OLDREG (fetch (WINDOW REG) NEXTW)) (SETQ NEWREG (create REGION LEFT _ X BOTTOM _ (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (IPLUS Y HEIGHT)) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (COND ((AND (EQ (fetch (REGION WIDTH) of OLDREG) WIDTH) (EQ (fetch (REGION HEIGHT) of OLDREG) HEIGHT)) (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG) (fetch (REGION BOTTOM) of NEWREG))) (T (XSHAPEW1 NEXTW NEWREG] (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (XMOVED.WINDOW [LAMBDA (WINDOW) (* ; "Edited 1-Feb-91 16:48 by matsuda") NIL]) ) (RPAQ? \XSCREEN NIL) (ADDTOVAR \DISPLAYSTREAMTYPES XDISPLAY) (ADDTOVAR IMAGESTREAMTYPES (XDISPLAY (OPENSTREAM NILL) (FONTCREATE \CREATEXDISPLAYFONT) (FONTSAVAILABLE NILL) (CREATECHARSET NILL))) (FILESLOAD XLLKEY XLLBITMAP XLLCURSOR XLLMOUSE XLLFONT XSERVER XWATCHER) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML ) (ADDTOVAR LAMA XLIB::SETUP-CLX) ) (PUTPROPS XMAS COPYRIGHT ("Venue" 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (11150 12401 (XLIB::SETUP-CLX 11160 . 12399)) (12402 80675 (\XDISPLAYINIT 12412 . 17445) (CREATEXSCREEN 17447 . 19460) (BITSPERPIXEL 19462 . 20487) (BITMAPHEIGHT 20489 . 20949) (BITMAPWIDTH 20951 . 21406) (DSPDESTINATION 21408 . 25038) (XDSPCREATE 25040 . 26540) (\DSPOPERATION.XDISPLAY 26542 . 27406) (\DSPRESET.XDISPLAY 27408 . 29848) (\BLTSHADE.XDISPLAY 29850 . 35267) (\BITBLT.XDISPLAY 35269 . 40602) (\XBITBLTSUB 40604 . 42083) (\XBLTSHADE.PIXMAP 42085 . 45581) (\XBITBLT.PIXMAP 45583 . 49709) (\DRAWPOINT.XDISPLAY 49711 . 50368) (\DRAWLINE.XDISPLAY 50370 . 53414) (\XLINEWITHBRUSH 53416 . 61792) (\DRAWCIRCLE.XDISPLAY 61794 . 66819) (\DRAWCURVE.XDISPLAY 66821 . 68378) (\XCURVE2 68380 . 75910) (\XCURVE 75912 . 80673)) (80676 91382 (BITBLT 80686 . 91380)) (91383 93367 (XCREATEWFROMPIXMAP 91393 . 92408) (PIXMAPCREATE 92410 . 92748) (PIXMAPWIDTH 92750 . 93055) (PIXMAPHEIGHT 93057 . 93365)) (93368 117849 (XCREATEW 93378 . 95995) (ADVISEXWDS 95997 . 102452) (XOPENW 102454 . 103586) (\XOPENW1 103588 . 105484) (XCLOSEW 105486 . 105815) (\XCLOSEW1 105817 . 107434) (\XSFFixClippingRegion 107436 . 109725) (XSHOWWFRAME 109727 . 112983) (XSHOWWTITLE 112985 . 115389) (\XCREATEBASEW 115391 . 117085) (\DSPCLIPPINGREGION.XDISPLAY 117087 . 117847)) (117850 133562 (\XDSPPRINTCHAR 117860 . 125664) ( \XBLTCHAR 125666 . 128836) (\XDSPPRINTCR/LF 128838 . 133560)) (133563 148886 (OPENWINDOWS 133573 . 134579) (\INSURESCREEN 134581 . 134893) (DSPSOURCETYPE 134895 . 136365) (PUTWINDOWPROP 136367 . 143483 ) (RESHOWBORDER 143485 . 144286) (\XRESHOWBORDER1 144288 . 147269) (\GETWINDOWHEIGHT 147271 . 148884)) (148887 149034 (XWHICHW 148897 . 149032)) (149035 150494 (TOTOPW 149045 . 150492)) (150495 159902 ( XSHAPEW1 150505 . 151645) (XMOVEW 151647 . 155883) (XMOVEW1 155885 . 158159) (XMOVEORRESIZED.WINDOW 158161 . 159765) (XMOVED.WINDOW 159767 . 159900))))) STOP \ No newline at end of file diff --git a/sources/XMAS2 b/sources/XMAS2 new file mode 100644 index 00000000..42ada05c --- /dev/null +++ b/sources/XMAS2 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "22-Oct-91 17:03:36" |{PELE:MV:ENVOS}SOURCES>XMAS2.;1| 62023 changes to%: (FNS XSHOWWFRAME) previous date%: "22-Oct-91 16:41:50" {DSK}nilsson>xmas-split>xmas2.;5) (* ; " Copyright (c) 1991 by Fuji Xerox Co., Ltd. All rights reserved. ") (PRETTYCOMPRINT XMAS2COMS) (RPAQQ XMAS2COMS ((RECORDS WINDOWOPS) (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW EXPANDW.NEW) (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY) (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP XCLOSEMAINWINDOW \XINTERNALTOTOPW) (FNS ISXWINDOW?) (FNS INIT.XMAS2) (VARS XMAS2COMS))) (DECLARE%: EVAL@COMPILE (DATATYPE WINDOWOPS (CREATEW OPENW CLOSEW MOVEW SHAPEW SHRINKW EXPANDW) CREATEW _ (FUNCTION NILL) OPENW _ (FUNCTION NILL) CLOSEW _ (FUNCTION NILL) MOVEW _ (FUNCTION NILL) SHAPEW _ (FUNCTION NILL) SHRINKW _ (FUNCTION NILL) EXPANDW _ (FUNCTION NILL)) ) (/DECLAREDATATYPE 'WINDOWOPS '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((WINDOWOPS 0 POINTER) (WINDOWOPS 2 POINTER) (WINDOWOPS 4 POINTER) (WINDOWOPS 6 POINTER) (WINDOWOPS 8 POINTER) (WINDOWOPS 10 POINTER) (WINDOWOPS 12 POINTER)) '14) (DEFINEQ (CREATESCREEN [LAMBDA (DESTINATION) (* ; "Edited 5-Sep-91 15:20 by matsuda") (* ;;; "destination is the framebuffer for the screen you want created.e.g. (SCREENBITMAP)") (PROG (TITLEDS SCREEN) (COND ((OR (NULL DESTINATION) (TYPE? BITMAP DESTINATION)) (SETQ TITLEDS (DSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT WINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") (SETQ SCREEN (create SCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCWIDTH _ (BITMAPWIDTH DESTINATION) SCHEIGHT _ (BITMAPHEIGHT DESTINATION) SCTOPW _ NIL SCTITLEDS _ TITLEDS)) (RETURN SCREEN)) ((XLIB:DRAWABLE-P DESTINATION) (SETQ TITLEDS (XDSPCREATE DESTINATION)) (* ; "Create TITLEDS. ") (DSPOPERATION 'INVERT TITLEDS) (DSPFONT XWINDOWTITLEFONT TITLEDS) (DSPRIGHTMARGIN MAX.SMALLP TITLEDS) (* ;  "Set right margin so title doesn't autoCR. ") (* ;; "now create SCREEN. ") (SETQ SCREEN (create SCREEN SCONOFF _ 'OFF SCDESTINATION _ DESTINATION SCWIDTH _ (BITMAPWIDTH DESTINATION) SCHEIGHT _ (BITMAPHEIGHT DESTINATION) SCTOPW _ NIL SCTITLEDS _ TITLEDS)) (RETURN SCREEN]) (DSPCREATE [LAMBDA (DESTINATION) (* ; "Edited 5-Sep-91 15:34 by matsuda") (* ;; "Creates a stream-of-type-display on the DESTINATION bitmap or display device") (LET (DSTRM) (OR DESTINATION (SETQ DESTINATION ScreenBitMap)) (* ; "") (* ;  "(COND ((NULL DESTINATION)) (T (\DTEST DESTINATION 'BITMAP)))") (COND ((type? BITMAP DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \DSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \DISPLAYIMAGEOPS DEVICE _ DisplayFDEV ACCESS _ 'OUTPUT)) (* ;  "initial x and y positions are 0 when the data is created.") (DSPFONT DEFAULTFONT DSTRM) (* ;  "dspfont can win since the (default) display imageops are filled in the stream") (DSPDESTINATION DESTINATION DSTRM) (* ;  "dspdestination calls \SFFixFont, which presumes there is a font present.") (DSPFONT DEFAULTFONT DSTRM) (* ;; "the reference to SCREENWIDTH here is for historic reasons: until 3-feb-86 the default right margin was always SCREENWIDTH. It should be the width of the destination and for any destination larger than the screen this is a serious bug and was fixed. The MAX of the right value and SCREENWIDTH was left in because existing code might be assumine a large right margin for small bitmaps and auto-CR in without it. rrb") (DSPRIGHTMARGIN (MAX SCREENWIDTH (fetch (BITMAP BITMAPWIDTH) of DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM) (* ;  "called to cause the updating of the bitblt table from the fields initialized earlier.") ) ((XLIB:DRAWABLE-P DESTINATION) (SETQ DSTRM (create STREAM USERCLOSEABLE _ NIL OUTCHARFN _ (FUNCTION \XDSPPRINTCHAR) IMAGEDATA _ (create \DISPLAYDATA) IMAGEOPS _ \XDISPLAYIMAGEOPS DEVICE _ XDisplayFDEV ACCESS _ 'OUTPUT)) (replace (\DISPLAYDATA DDPILOTBBT) of (fetch (STREAM IMAGEDATA) of DSTRM) with (SETQ GC (XLIB:CREATE-GCONTEXT :DRAWABLE DESTINATION))) (CL:SETF (XLIB:GCONTEXT-FOREGROUND GC) XLIB::*BLACK*) (* ; "temp foreground color ") (CL:SETF (XLIB:GCONTEXT-BACKGROUND GC) XLIB::*WHITE*) (* ; "temp background color") (DSPFONT XDEFAULTFONT DSTRM) (DSPDESTINATION DESTINATION DSTRM) (DSPRIGHTMARGIN (MAX SCREENWIDTH (XLIB:DRAWABLE-WIDTH DESTINATION)) DSTRM) (DSPSOURCETYPE 'INPUT DSTRM) (DSPOPERATION 'REPLACE DSTRM))) DSTRM]) (CREATEW.NEW [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 20-Oct-91 10:53 by jn") (* ;; "creates and returns a window.") (PROG (SCREEN) (COND ((AND (BOUNDP '\SCREEN) \SCREEN) (SETQ SCREEN \SCREEN)) ((type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION))) (T (SETQ SCREEN \MAINSCREEN) (* ; "Default screen is \MAINSCREEN.") )) (RETURN (APPLY* (fetch (WINDOWOPS CREATEW) of (fetch (SCREEN SCDATA) of SCREEN)) REGION TITLE BORDERSIZE NOOPENFLG]) (OPENW.NEW [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 18:05 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS OPENW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW]) (CLOSEW.NEW [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 18:01 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS CLOSEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW)) ) WINDOW]) (MOVEW.NEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 10-Sep-91 15:55 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS MOVEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW POSorX Y]) (SHAPEW.NEW [LAMBDA (WINDOW NEWREGION) (* ; "Edited 13-Sep-91 14:09 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS SHAPEW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW)) ) WINDOW NEWREGION]) (SHRINKW.NEW [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN) (* ; "Edited 13-Sep-91 16:39 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (APPLY* (fetch (WINDOWOPS SHRINKW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of WINDOW) )) WINDOW TOWHAT ICONPOSITION EXPANDFN]) (EXPANDW.NEW [LAMBDA (ICONW) (* ; "Edited 13-Sep-91 16:07 by matsuda") (SETQ ICONW (\INSUREWINDOW ICONW)) (APPLY* (fetch (WINDOWOPS EXPANDW) of (fetch (SCREEN SCDATA) of (fetch (WINDOW SCREEN) of ICONW)) ) ICONW]) ) (DEFINEQ (CREATEW.XDISPLAY [LAMBDA (REGION TITLE BORDERSIZE NOOPENFLG) (* ; "Edited 9-Sep-91 17:03 by matsuda") (* ;; "creates and returns a window.") (PROG (SCREEN REG DSP DISPLAYDATA TITLEHEIGHT WINDOW WBORDER) (SETQ WBORDER (COND ((NUMBERP BORDERSIZE) (ABS BORDERSIZE)) ((NUMBERP WBorder) (ABS WBorder)) (T 2))) (COND ((type? REGION REGION) (SETQ SCREEN \XSCREEN) (* ;  "Protect against user smashing REGION later on.") (SETQ REG (COPY REGION))) [(type? SCREENREGION REGION) (SETQ SCREEN (fetch (SCREENREGION SCREEN) of REGION)) (SETQ REG (COPY (fetch (SCREENREGION REGION) of REGION] (T (ERROR "Not a region" REG))) [COND ((NULL DSP) (* ;  "Don't have a DSP yet. User passed some kind of region.") (SETQ DSP (DSPCREATE (fetch (SCREEN SCDESTINATION) of SCREEN))) (SETQ DISPLAYDATA (fetch (STREAM IMAGEDATA) of DSP] (COND ((NOT (IGREATERP (IMIN (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG)) (UNFOLD WBORDER 2))) (ERROR "Region too small to use as a window" REG))) (SETQ WINDOW (create WINDOW DSP _ DSP REG _ REG SAVE _ NIL WTITLE _ TITLE WBORDER _ WBORDER NEXTW _ 'CLOSED SCREEN _ SCREEN BUTTONEVENTFN _ NIL)) (replace (\DISPLAYDATA XWINDOWHINT) of DISPLAYDATA with WINDOW) (XSHOWWFRAME WINDOW) (DSPDESTINATION (fetch (WINDOW SAVE) of WINDOW) DSP) (ADVISEXWDS WINDOW) (* ;  "make the display stream and window agree about dimensions.") (MOVETOUPPERLEFT WINDOW) (COND ((NOT NOOPENFLG) (XOPENW WINDOW))) (RETURN WINDOW]) (OPENW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 10-Sep-91 15:59 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) NIL) (T (PROG [(USEROPENFN (WINDOWPROP WINDOW 'OPENFN] (COND ((\USERFNISDON'T USEROPENFN) NIL) (T (\XOPENW1 WINDOW) (DOUSERFNS USEROPENFN WINDOW) (RETURN WINDOW]) (CLOSEW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 9-Sep-91 17:44 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (COND ((\OKTOCLOSEW WINDOW) (AND (OPENWP WINDOW) (\XCLOSEW1 WINDOW)) T]) (MOVEW.XDISPLAY [LAMBDA (WINDOW POSorX Y) (* ; "Edited 10-Sep-91 16:04 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (SHAPEW.XDISPLAY [LAMBDA (WINDOW NEWREGION) (* ; "Edited 13-Sep-91 14:11 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) (T (ERROR "NEWREGION must be specified."] (RETURN (if (EQUAL NEWSIZE OLDSIZE) then (* ;; "if same size and place as before, do nothing") NIL elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) then (* ;; "if same width and height, then optimize to a move") (MOVEW.XDISPLAY WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE)) else (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) '\XSHAPEW1) WINDOW (COPYALL NEWSIZE]) (SHRINKW.XDISPLAY [LAMBDA (WINDOW TOWHAT ICONPOSITION EXPANDFN) (* ; "Edited 11-Sep-91 15:59 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((NOT (OPENWP WINDOW)) NIL) ((WINDOWPROP WINDOW 'ICONFOR) NIL) ((EQ (DOUSERFNS (WINDOWPROP WINDOW 'SHRINKFN) WINDOW T) 'DON'T) NIL) (T (LET (TITLE ICONW FN ICONISBITMAP ICONISPIXMAP) [SETQ ICONW (COND ((type? BITMAP TOWHAT) [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP TOWHAT (BITSPERPIXEL (fetch (SCREEN SCDESTINATION ) of (fetch (WINDOW SCREEN) of WINDOW] [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP ICONISPIXMAP (fetch (WINDOW SCREEN) of WINDOW] (XLIB:FREE-PIXMAP ICONISPIXMAP) TOWHAT) ((XLIB:DRAWABLE-P TOWHAT) [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (XCREATEWFROMPIXMAP TOWHAT (fetch (WINDOW SCREEN) of WINDOW] TOWHAT) ((ISXWINDOW? TOWHAT) (WINDOWPROP WINDOW 'ICON TOWHAT) TOWHAT) ((STRINGP TOWHAT) [WINDOWPROP WINDOW 'ICON (SETQ TOWHAT (\DTEST (APPLY* DEFAULTICONFN WINDOW TOWHAT) 'WINDOW] TOWHAT) (T [SETQ TOWHAT (COND ((SETQ FN (WINDOWPROP WINDOW 'ICONFN)) (* ;  "User fn to create an icon. Can return cached value") (APPLY* FN WINDOW (WINDOWPROP WINDOW 'ICONWINDOW) (POSITIONP ICONPOSITION))) (T (WINDOWPROP WINDOW 'ICON] (COND ((ISXWINDOW? TOWHAT) TOWHAT) ((type? BITMAP TOWHAT) [SETQ ICONISPIXMAP (PIXMAPFROMBITMAP TOWHAT (BITSPERPIXEL (fetch (SCREEN SCDESTINATION ) of (fetch (WINDOW SCREEN) of WINDOW] (XCREATEWFROMPIXMAP ICONISPIXMAP (fetch (WINDOW SCREEN) of WINDOW)) (XLIB:FREE-PIXMAP ICONISPIXMAP)) ((XLIB:DRAWABLE-P TOWHAT) (XCREATEWFROMPIXMAP TOWHAT (fetch (WINDOW SCREEN) of WINDOW))) (T (\DTEST (APPLY* XDEFAULTICONFN WINDOW TOWHAT) 'WINDOW] (WINDOWPROP WINDOW 'ICONWINDOW ICONW) (WINDOWPROP ICONW 'ICONFOR WINDOW) (WINDOWADDFNPROP ICONW 'CLOSEFN (FUNCTION XCLOSEMAINWINDOW)) (* ; "(COND ((EQ (WINDOWPROP ICONW 'BUTTONEVENTFN) 'TOTOPW) (WINDOWPROP ICONW 'BUTTONEVENTFN (FUNCTION ICONBUTTONEVENTFN))))") (WINDOWADDFNPROP WINDOW 'OPENFN (FUNCTION CLOSEICONWINDOW)) (WINDOWADDFNPROP ICONW 'MOVEFN (FUNCTION \NOTENEWICONPOSITION)) (AND EXPANDFN (WINDOWADDFNPROP WINDOW 'EXPANDFN EXPANDFN)) (* ;  "(WINDOWPROP ICONW 'DOWINDOWCOMFN (FUNCTION DOICONWINDOWCOM))") [COND [(AND (NEQ ICONPOSITION 'SAME) (OR ICONISBITMAP (POSITIONP ICONPOSITION))) (MOVEW ICONW (COND ((POSITIONP ICONPOSITION) ICONPOSITION) ((PROG1 [POSITIONP (SETQ ICONPOSITION (WINDOWPROP WINDOW 'ICONPOSITION] (* ;  "leave it in its current location.") )) (T (SETQ ICONPOSITION (ICONPOSITION.FROM.WINDOW WINDOW (WINDOWPROP ICONW 'REGION] (T (SETQ ICONPOSITION (LET [(REG (WINDOWPROP ICONW 'REGION] (create POSITION XCOORD _ (fetch (REGION LEFT) of REG) YCOORD _ (fetch (REGION BOTTOM) of REG] (WINDOWPROP WINDOW 'ICONPOSITION ICONPOSITION)(* ; "(TOTOPW WINDOW T)") (\XCLOSEW1 WINDOW) (OPENW ICONW) ICONW]) (EXPANDW.XDISPLAY [LAMBDA (ICONW) (* ; "Edited 11-Sep-91 16:58 by matsuda") (PROG ((IW ICONW) MAINWINDOW USEREXPANDFN EXPANDREGION) [COND [(SETQ MAINWINDOW (WINDOWPROP IW 'ICONFOR] ((SETQ IW (WINDOWPROP IW 'ICONWINDOW)) (COND ((OPENWP (SETQ MAINWINDOW ICONW)) (RETURN ICONW] (COND ([AND MAINWINDOW (NULL (\USERFNISDON'T (SETQ USEREXPANDFN (WINDOWPROP MAINWINDOW 'EXPANDFN] (if (AND (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) (SETQ EXPANDREGION (APPLY* (WINDOWPROP MAINWINDOW 'EXPANDREGIONFN) MAINWINDOW))) then (\XSHAPEW1 MAINWINDOW EXPANDREGION) else (\XOPENW1 MAINWINDOW)) (\XCLOSEW1 IW) (WINDOWDELPROP MAINWINDOW 'OPENFN 'CLOSEICONWINDOW) (WINDOWDELPROP IW 'CLOSEFN 'CLOSEMAINWINDOW) (DOUSERFNS USEREXPANDFN MAINWINDOW) (RETURN (WINDOWPROP IW 'ICONFOR NIL]) (TOTOPW.XDISPLAY [LAMBDA (WINDOW NOCALLTOTOPFNFLG) (* ; "Edited 13-Sep-91 16:51 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (COND ((OPENWP WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW)) (\XINTERNALTOTOPW WINDOW)) ((OPENW WINDOW) (OR NOCALLTOTOPFNFLG (DOUSERFNS (WINDOWPROP WINDOW 'TOTOPFN) WINDOW))) (T (* ;  "window won't open probably because of DON'T OPENFN") (ERROR "Window won't open; Can't be bring to top." WINDOW))) WINDOW]) (BURYW.XDISPLAY [LAMBDA (WINDOW) (* ; "Edited 13-Sep-91 18:02 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW] (AND BASEW (XLIB::SET-WINDOW-PRIORITY :BELOW BASEW]) ) (DEFINEQ (\XOPENW1 [LAMBDA (WINDOW) (* ; "Edited 6-Sep-91 15:22 by matsuda") (if (EQ (fetch (WINDOW NEXTW) of WINDOW) 'CLOSED) then (PROG ((BASEW (WINDOWPROP WINDOW 'XBASEW)) XWIN REG BORDER XTITLEW TOP (SCREEN (fetch (WINDOW SCREEN) of WINDOW) ) DD) (if BASEW then (XLIB:MAP-WINDOW BASEW) else (WINDOWPROP WINDOW 'XBASEW (SETQ BASEW (\XCREATEBASEW WINDOW))) [AND (WINDOWPROP WINDOW 'TITLE) (SETQ XTITLEW (WINDOWPROP WINDOW 'XTITLEW] (SETQ XWIN (fetch (WINDOW SAVE) of WINDOW)) (SETQ BORDER (XLIB:DRAWABLE-BORDER-WIDTH XWIN)) (SETQ TOP 0) [COND (XTITLEW (XLIB:REPARENT-WINDOW XTITLEW BASEW 0 0) (SETQ TOP (XLIB:DRAWABLE-HEIGHT XTITLEW] (XLIB:REPARENT-WINDOW XWIN BASEW 0 TOP) (XLIB:MAP-SUBWINDOWS BASEW) (CL:SETF (XLIB:TRANSIENT-FOR BASEW) BASEW) (XLIB:MAP-WINDOW BASEW)) (UNINTERRUPTABLY (XLIB:MAP-WINDOW (fetch (WINDOW SAVE) of WINDOW)) (replace (WINDOW NEXTW) of WINDOW with (fetch (SCREEN SCTOPW) of SCREEN)) (replace (SCREEN SCTOPW) of SCREEN with WINDOW))]) (XSHOWWFRAME [LAMBDA (WIN) (* ; "Edited 22-Oct-91 17:03 by jn") (* ;; "Displays the border and title in the save image of a window ") [PROG ((TITLE (fetch (WINDOW WTITLE) of WIN)) (BORDER (fetch (WINDOW WBORDER) of WIN)) (SAVEIMAGE (fetch (WINDOW SAVE) of WIN)) (SCREEN (fetch (WINDOW SCREEN) of WIN)) (REG (fetch (WINDOW REG) of WIN)) BLACKPART FOOT (TITLE-H 0)) (* ; "make most of the border black") (SETQ BLACKPART (IMAX (FOLDHI BORDER 2) (IDIFFERENCE BORDER 2))) (XSHOWWTITLE TITLE SAVEIMAGE BORDER NIL WIN) [AND TITLE (SETQ TITLE-H (XLIB:DRAWABLE-HEIGHT (WINDOWPROP WIN 'XTITLEW] (if SAVEIMAGE then [XLIB:WITH-STATE (SAVEIMAGE) (CL:SETF (XLIB:DRAWABLE-Y SAVEIMAGE) TITLE-H) (CL:SETF (XLIB:DRAWABLE-X SAVEIMAGE) 0) (CL:SETF (XLIB:DRAWABLE-WIDTH SAVEIMAGE) (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2))) (CL:SETF (XLIB:DRAWABLE-HEIGHT SAVEIMAGE) (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2] else (replace SAVE of WIN with (SETQ SAVEIMAGE (XLIB:CREATE-WINDOW :PARENT (fetch (SCREEN SCDESTINATION) of SCREEN) :X (fetch (REGION LEFT) of REG) :Y (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of SCREEN) (IDIFFERENCE (fetch (REGION TOP) of REG) (IPLUS TITLE-H BLACKPART))) :WIDTH (IDIFFERENCE (fetch (REGION WIDTH) of REG) (ITIMES BLACKPART 2)) :HEIGHT (IDIFFERENCE (fetch (REGION HEIGHT) of REG) (IPLUS TITLE-H (ITIMES BLACKPART 2))) :BORDER-WIDTH BLACKPART :BACKGROUND XLIB::*WHITE* :BIT-GRAVITY :NORTH-WEST :BACKING-STORE :ALWAYS] WIN]) (ADVISEXWDS [LAMBDA (WINDOW OLDREG MOVEONLYFLG) (DECLARE (LOCALVARS . T)) (* ; "Edited 5-Sep-91 16:23 by matsuda") (PROG (R D WBORDERSIZE CLIPREG TWICEBORDER PROC OFFSET) (SETQ R (fetch (WINDOW REG) of WINDOW)) (SETQ D (fetch (WINDOW DSP) of WINDOW)) (SETQ WBORDERSIZE (fetch (WINDOW WBORDER) of WINDOW)) (SETQ TWICEBORDER (UNFOLD WBORDERSIZE 2)) (COND (OLDREG (OR MOVEONLYFLG (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN ) of WINDOW] (T 0] D))) (T (SETQ OFFSET (IMAX (FOLDHI WBORDERSIZE 2) (IDIFFERENCE WBORDERSIZE 2))) (DSPXOFFSET OFFSET D) (DSPYOFFSET OFFSET D) (DSPCLIPPINGREGION [create REGION LEFT _ 0 BOTTOM _ 0 WIDTH _ (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) HEIGHT _ (IPLUS (IDIFFERENCE (fetch (REGION HEIGHT) of R) TWICEBORDER) (COND [(fetch (WINDOW WTITLE) of WINDOW) (DSPLINEFEED NIL (fetch (SCREEN SCTITLEDS) of (fetch (WINDOW SCREEN) of WINDOW] (T 0] D))) [COND ((NULL MOVEONLYFLG) (* ;  "if the previous right margin was the default, change it.") (AND (OR (NOT OLDREG) (EQ (DSPRIGHTMARGIN NIL D) (IDIFFERENCE (fetch (REGION WIDTH) of OLDREG) TWICEBORDER))) (DSPRIGHTMARGIN (IDIFFERENCE (fetch (REGION WIDTH) of R) TWICEBORDER) D)) (COND ((AND (SETQ PROC (WINDOWPROP WINDOW 'PROCESS)) (EQ D (PROCESS.TTY PROC))) (* ;  "if the window changing is a tty, set its linelength.") [PROCESS.EVAL PROC (LIST (FUNCTION PAGEHEIGHT) (IQUOTIENT (fetch (REGION HEIGHT) of (SETQ CLIPREG (DSPCLIPPINGREGION NIL D))) (IMINUS (DSPLINEFEED NIL D] (PROCESS.EVAL PROC '(SETLINELENGTH)) (IF NIL THEN (* ; "try it without this.") (COND ((EQ (PROCESSPROP PROC 'NAME) 'EXEC) (* ;; "in the exec process, make sure the current position is inside the new shape. reuse variables R and TWICEBORDER to save binding.") (COND ((ILESSP (SETQ R (DSPYPOSITION NIL D)) (SETQ TWICEBORDER (fetch (REGION BOTTOM) of CLIPREG ))) (DSPYPOSITION TWICEBORDER D)) ((IGREATERP R (SETQ TWICEBORDER (IPLUS (fetch (REGION HEIGHT) of CLIPREG) TWICEBORDER))) (DSPYPOSITION (IDIFFERENCE TWICEBORDER (FONTPROP D 'ASCENT)) D] (UPDATE/SCROLL/REG WINDOW)) WINDOW]) (XMOVEORRESIZED.WINDOW [LAMBDA (WINDOW X Y WIDTH HEIGHT) (* ; "Edited 5-Sep-91 16:57 by matsuda") (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN)) XBASEW OLDREG NEWREG) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND [(EQ WINDOW XBASEW) (SETQ OLDREG (fetch (WINDOW REG) NEXTW)) (SETQ NEWREG (create REGION LEFT _ X BOTTOM _ (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) (IPLUS Y HEIGHT)) WIDTH _ WIDTH HEIGHT _ HEIGHT)) (COND ((AND (EQ (fetch (REGION WIDTH) of OLDREG) WIDTH) (EQ (fetch (REGION HEIGHT) of OLDREG) HEIGHT)) (XMOVEW1 NEXTW (fetch (REGION LEFT) of NEWREG) (fetch (REGION BOTTOM) of NEWREG))) (T (XSHAPEW1 NEXTW NEWREG] (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (\XMOUSELEFT [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 16:56 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (COND ((EQ XLASTWINDOW (\FINDWINDOW WINDOW) XLASTWINDOW) (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW) XLASTWINDOW))) (SETQ XLASTWINDOW NIL]) (\XMOUSEMOVED [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 16:55 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (SETQ XLASTWINDOW (\FINDWINDOW WINDOW)) (DOUSERFNS (fetch (WINDOW CURSORMOVEDFN) of XLASTWINDOW) XLASTWINDOW]) (\FINDWINDOW [LAMBDA (WINDOW) (* ; "Edited 5-Sep-91 16:51 by matsuda") (PROG ((NEXTW (fetch (SCREEN SCTOPW) of \XSCREEN)) XBASEW) LOOP (COND (NEXTW (SETQ XBASEW (WINDOWPROP NEXTW 'XBASEW)) (COND ((EQ WINDOW XBASEW) (RETURN NEXTW)) (T (SETQ NEXTW (fetch (WINDOW NEXTW) of NEXTW)) (GO LOOP]) (\XMOUSEENTERED [LAMBDA (WINDOW X Y) (* ; "Edited 5-Sep-91 17:13 by matsuda") (SETQ XLASTMOUSEX X) (SETQ XLASTMOUSEY (IDIFFERENCE (fetch (SCREEN SCHEIGHT) of \XSCREEN) Y)) (SETQ XLASTWINDOW (\FINDWINDOW WINDOW)) (DOUSERFNS (fetch (WINDOW CURSORINFN) of XLASTWINDOW) XLASTWINDOW]) (XMOVEW [LAMBDA (WINDOW POSorX Y) (* ; "Edited 7-Mar-91 14:24 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDREGION (fetch (WINDOW REG) of WINDOW)) (USERMOVEFN (fetch (WINDOW MOVEFN) of WINDOW)) POS NEWREGION OLDLEFT OLDBOTTOM OLDWIDTH OLDHEIGHT XBASEW) (COND ([COND ((LISTP USERMOVEFN) (FMEMB 'DON'T USERMOVEFN)) (T (EQ USERMOVEFN 'DON'T] (PROMPTPRINT "This window cannot be moved.") (RETURN))) (SETQ OLDLEFT (fetch (REGION LEFT) of OLDREGION)) (SETQ OLDBOTTOM (ffetch (REGION BOTTOM) of OLDREGION)) (SETQ OLDWIDTH (ffetch (REGION WIDTH) of OLDREGION)) (SETQ OLDHEIGHT (ffetch (REGION HEIGHT) of OLDREGION)) (COND [(AND POSorX (SETQ POS (COND ((POSITIONP POSorX) POSorX) [(NUMBERP POSorX) (COND ((NUMBERP Y) (create POSITION XCOORD _ POSorX YCOORD _ Y)) (T (\ILLEGAL.ARG Y] ((REGIONP POSorX) (create POSITION XCOORD _ (fetch (REGION LEFT) of POSorX) YCOORD _ (fetch (REGION BOTTOM) of POSorX))) (T (\ILLEGAL.ARG POSorX] (T (\ILLEGAL.ARG POSorX))) [COND ((AND (LISTP USERMOVEFN) (NOT (FMEMB (CAR USERMOVEFN) LAMBDASPLST))) (AND (EQ [for MFN in USERMOVEFN do (SETQ NEWREGION (APPLY* MFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN 'DON'T)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] 'DON'T) (RETURN))) (USERMOVEFN (SETQ NEWREGION (APPLY* USERMOVEFN WINDOW POS)) (COND ((EQ NEWREGION 'DON'T) (RETURN)) ((POSITIONP NEWREGION) (SETQ POS NEWREGION] (COND ((OR (NOT (EQ (fetch (POSITION XCOORD) of POS) OLDLEFT)) (NOT (EQ (fetch (POSITION YCOORD) of POS) OLDBOTTOM))) (SETQ NEWREGION (create REGION LEFT _ (ffetch (POSITION XCOORD) of POS) BOTTOM _ (ffetch (POSITION YCOORD) of POS) WIDTH _ OLDWIDTH HEIGHT _ OLDHEIGHT)) (UNINTERRUPTABLY [COND ((SETQ XBASEW (WINDOWPROP WINDOW 'XBASEW)) (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (fetch (XSCREEN SCHEIGHT) of \XSCREEN) (fetch (REGION TOP) of NEWREGION))) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of NEWREGION] (replace (WINDOW REG) of WINDOW with NEWREGION) (ADVISEXWDS WINDOW OLDREGION T)) (DOUSERFNS (WINDOWPROP WINDOW 'AFTERMOVEFN) WINDOW))) (RETURN POS]) (\XCLOSEW1 [LAMBDA (WINDOW) (* ; "Edited 10-Sep-91 17:31 by matsuda") (LET (SCREEN NEXTW SAVE) (SETQ SCREEN (fetch (WINDOW SCREEN) of WINDOW)) (SETQ NEXTW (fetch (SCREEN SCTOPW) of SCREEN)) (COND ((NULL NEXTW) NIL) ((EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (SCREEN SCTOPW) of SCREEN with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of WINDOW with 'CLOSED)) T) (T (PROG NIL (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) LOOP (COND (NEXTW (COND [(EQ NEXTW WINDOW) (UNINTERRUPTABLY (XLIB:UNMAP-WINDOW (WINDOWPROP NEXTW 'XBASEW)) (replace (WINDOW NEXTW) of SAVE with (fetch (WINDOW NEXTW) of NEXTW)) (replace (WINDOW NEXTW) of NEXTW with 'CLOSED))] (T (SETQ SAVE NEXTW) (SETQ NEXTW (fetch (WINDOW NEXTW) of SAVE)) (GO LOOP]) (XSHAPEW [LAMBDA (WINDOW NEWREGION) (* ; "Edited 6-Sep-91 17:49 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (PROG ((OLDSIZE (WINDOWPROP WINDOW 'REGION)) NEWSIZE) (COND ((\USERFNISDON'T (fetch (WINDOW RESHAPEFN) of WINDOW)) (* ;  "don't allow the window to be reshaped.") (PROMPTPRINT "This window cannot be reshaped.") (RETURN NIL))) (SETQ NEWSIZE (MINIMUMWINDOWSIZE WINDOW)) [SETQ NEWSIZE (COND (NEWREGION (* ;  "An explicit new region was specified; make sure it's big enough.") (COND [(OR (LESSP (fetch (REGION WIDTH) of NEWREGION) (CAR NEWSIZE)) (LESSP (fetch (REGION HEIGHT) of NEWREGION) (CDR NEWSIZE))) (* ;  "given a region that is too small, so expand the width and height to at least the minima.") (CREATEREGION (fetch (REGION LEFT) of NEWREGION) (fetch (REGION BOTTOM) of NEWREGION) (IMAX (CAR NEWSIZE) (fetch (REGION WIDTH) of NEWREGION)) (IMAX (CDR NEWSIZE) (fetch (REGION HEIGHT) of NEWREGION] (T NEWREGION))) (T (ERROR "NEWREGION must be specified."] (RETURN (if (EQUAL NEWSIZE OLDSIZE) then (* ;; "if same size and place as before, do nothing") NIL elseif (AND (EQ (fetch (REGION WIDTH) of NEWSIZE) (fetch (REGION WIDTH) of OLDSIZE)) (EQ (fetch (REGION HEIGHT) of NEWSIZE) (fetch (REGION HEIGHT) of OLDSIZE))) then (* ;; "if same width and height, then optimize to a move") (XMOVEW WINDOW (fetch (REGION LEFT) of NEWSIZE) (fetch (REGION BOTTOM) of NEWSIZE)) else (* ;; "do the shape, checking for a doshapefn") (APPLY* (OR (WINDOWPROP WINDOW 'DOSHAPEFN) '\XSHAPEW1) WINDOW (COPYALL NEWSIZE]) (\XSHAPEW1 [LAMBDA (WINDOW REGION) (* ; "Edited 6-Sep-91 18:05 by matsuda") (SETQ WINDOW (\INSUREWINDOW WINDOW)) (OR (REGIONP REGION) (\ILLEGAL.ARG REGION)) (PROG [(XBASEW (WINDOWPROP WINDOW 'XBASEW] (IF XBASEW THEN (XLIB:WITH-STATE (XBASEW) (CL:SETF (XLIB:DRAWABLE-X XBASEW) (fetch (REGION LEFT) of REGION)) (CL:SETF (XLIB:DRAWABLE-Y XBASEW) (IDIFFERENCE (XLIB:DRAWABLE-HEIGHT XLIB::*ROOT*) (fetch (REGION TOP) of REGION))) (CL:SETF (XLIB:DRAWABLE-WIDTH XBASEW) (fetch (REGION WIDTH) of REGION)) (CL:SETF (XLIB:DRAWABLE-HEIGHT XBASEW) (fetch (REGION HEIGHT) of REGION]) (XCREATEWFROMPIXMAP [LAMBDA (PIXMAP SCREEN) (* ; "Edited 13-Sep-91 14:33 by matsuda") (PROG (WINDOW WIDTH HEIGHT) (SETQ WINDOW (CREATEW (create SCREENREGION SCREEN _ (\INSURESCREEN SCREEN) LEFT _ 0 BOTTOM _ 0 WIDTH _ (SETQ WIDTH (PIXMAPWIDTH PIXMAP)) HEIGHT _ (SETQ HEIGHT (PIXMAPHEIGHT PIXMAP))) NIL 0 T)) (WINDOWPROP WINDOW 'MINSIZE (CONS (IMIN MinWindowWidth WIDTH) (IMIN MinWindowWidth HEIGHT))) (CL:SETF (XLIB:GCONTEXT-FUNCTION XLIB::*GC*) CL:BOOLE-1) (XLIB:COPY-AREA PIXMAP XLIB::*GC* 0 0 WIDTH HEIGHT (fetch (WINDOW SAVE) of WINDOW) 0 0) (RETURN WINDOW]) (XCLOSEMAINWINDOW [LAMBDA (ICONWIN) (* ; "Edited 11-Sep-91 11:22 by matsuda") (PROG [(MAINWIN (WINDOWPROP ICONWIN 'ICONFOR] [COND (MAINWIN (COND ((NULL (\OKTOCLOSEW MAINWIN)) (RETURN 'DON'T)) (T (AND (OPENWP MAINWIN) (\XCLOSEW1 MAINWIN] (WINDOWPROP ICONWIN 'ICONFOR NIL) (RETURN NIL]) (\XINTERNALTOTOPW [LAMBDA (WINDOW) (* ; "Edited 13-Sep-91 18:02 by matsuda") (PROG [(BASEW (WINDOWPROP WINDOW 'XBASEW] (AND BASEW (XLIB::SET-WINDOW-PRIORITY :ABOVE BASEW]) ) (DEFINEQ (ISXWINDOW? [LAMBDA (WINDOW) (* ; "Edited 11-Sep-91 10:56 by matsuda") (AND (TYPE? WINDOW WINDOW) (XLIB:DRAWABLE-P (fetch (SCREEN SCDESTINATION) of (fetch (WINDOW SCREEN) of WINDOW))) WINDOW]) ) (DEFINEQ (INIT.XMAS2 [LAMBDA NIL (* ; "Edited 20-Oct-91 10:55 by jn") (MOVD 'CREATEW 'CREATEW.DISPLAY) (MOVD 'CREATEW.NEW 'CREATEW) (MOVD 'CLOSEW 'CLOSEW.DISPLAY) (MOVD 'CLOSEW.NEW 'CLOSEW) (MOVD 'OPENW 'OPENW.DISPLAY) (MOVD 'OPENW.NEW 'OPENW) (MOVD 'MOVEW 'MOVEW.DISPLAY) (MOVD 'MOVEW.NEW 'MOVEW) (MOVD 'SHAPEW 'SHAPEW.DISPLAY) (MOVD 'SHAPEW.NEW 'SHAPEW) (MOVD 'SHRINKW 'SHRINKW.DISPLAY) (MOVD 'SHRINKW.NEW 'SHRINKW) (MOVD 'EXPANDW 'EXPANDW.DISPLAY) (MOVD 'EXPANDW.NEW 'EXPANDW) (SETQ \XSCREEN (CREATESCREEN XLIB::*ROOT*)) [replace (SCREEN SCDATA) of \XSCREEN with (SETQ \XDisplayWindowOps (CREATE WINDOWOPS CREATEW _ (FUNCTION CREATEW.XDISPLAY) OPENW _ (FUNCTION OPENW.XDISPLAY) CLOSEW _ (FUNCTION CLOSEW.XDISPLAY) MOVEW _ (FUNCTION MOVEW.XDISPLAY) SHAPEW _ (FUNCTION SHAPEW.XDISPLAY) SHRINKW _ (FUNCTION SHRINKW.XDISPLAY) EXPANDW _ (FUNCTION EXPANDW.XDISPLAY] [replace (SCREEN SCDATA) of \MAINSCREEN with (SETQ \DisplayWindowOps (CREATE WINDOWOPS CREATEW _ (FUNCTION CREATEW.DISPLAY) OPENW _ (FUNCTION OPENW.DISPLAY) CLOSEW _ (FUNCTION CLOSEW.DISPLAY) MOVEW _ (FUNCTION MOVEW.DISPLAY) SHAPEW _ (FUNCTION SHAPEW.DISPLAY) SHRINKW _ (FUNCTION SHRINKW.DISPLAY) EXPANDW _ (FUNCTION EXPANDW.DISPLAY] (CL:PUSH \XSCREEN \SCREENS]) ) (RPAQQ XMAS2COMS ((RECORDS WINDOWOPS) (FNS CREATESCREEN DSPCREATE CREATEW.NEW OPENW.NEW CLOSEW.NEW MOVEW.NEW SHAPEW.NEW SHRINKW.NEW EXPANDW.NEW) (FNS CREATEW.XDISPLAY OPENW.XDISPLAY CLOSEW.XDISPLAY MOVEW.XDISPLAY SHAPEW.XDISPLAY SHRINKW.XDISPLAY EXPANDW.XDISPLAY TOTOPW.XDISPLAY BURYW.XDISPLAY) (FNS \XOPENW1 XSHOWWFRAME ADVISEXWDS XMOVEORRESIZED.WINDOW \XMOUSELEFT \XMOUSEMOVED \FINDWINDOW \XMOUSEENTERED XMOVEW \XCLOSEW1 XSHAPEW \XSHAPEW1 XCREATEWFROMPIXMAP XCLOSEMAINWINDOW \XINTERNALTOTOPW) (FNS ISXWINDOW?) (FNS INIT.XMAS2) (VARS XMAS2COMS))) (PUTPROPS XMAS2 COPYRIGHT ("Fuji Xerox Co., Ltd" 1991)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1816 10841 (CREATESCREEN 1826 . 3905) (DSPCREATE 3907 . 7484) (CREATEW.NEW 7486 . 8271) (OPENW.NEW 8273 . 8747) (CLOSEW.NEW 8749 . 9129) (MOVEW.NEW 9131 . 9614) (SHAPEW.NEW 9616 . 10006) ( SHRINKW.NEW 10008 . 10458) (EXPANDW.NEW 10460 . 10839)) (10842 30847 (CREATEW.XDISPLAY 10852 . 13334) (OPENW.XDISPLAY 13336 . 13835) (CLOSEW.XDISPLAY 13837 . 14174) (MOVEW.XDISPLAY 14176 . 18419) ( SHAPEW.XDISPLAY 18421 . 21590) (SHRINKW.XDISPLAY 21592 . 28583) (EXPANDW.XDISPLAY 28585 . 29816) ( TOTOPW.XDISPLAY 29818 . 30569) (BURYW.XDISPLAY 30571 . 30845)) (30848 57817 (\XOPENW1 30858 . 32860) ( XSHOWWFRAME 32862 . 36235) (ADVISEXWDS 36237 . 42690) (XMOVEORRESIZED.WINDOW 42692 . 44286) ( \XMOUSELEFT 44288 . 44760) (\XMOUSEMOVED 44762 . 45165) (\FINDWINDOW 45167 . 45683) (\XMOUSEENTERED 45685 . 46087) (XMOVEW 46089 . 50325) (\XCLOSEW1 50327 . 51941) (XSHAPEW 51943 . 55096) (\XSHAPEW1 55098 . 56108) (XCREATEWFROMPIXMAP 56110 . 57083) (XCLOSEMAINWINDOW 57085 . 57578) (\XINTERNALTOTOPW 57580 . 57815)) (57818 58184 (ISXWINDOW? 57828 . 58182)) (58185 61281 (INIT.XMAS2 58195 . 61279))))) STOP \ No newline at end of file diff --git a/sources/XXFILL b/sources/XXFILL new file mode 100644 index 00000000..bfbc2620 --- /dev/null +++ b/sources/XXFILL @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 11:29:57" {DSK}lde>lispcore>sources>XXFILL.;2 57665 changes to%: (RECORDS SCAN FILL.TBLE) previous date%: "14-Jun-90 09:29:51" {DSK}lde>lispcore>sources>XXFILL.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT XXFILLCOMS) (RPAQQ XXFILLCOMS ((COMS (* ;;; "Filled Polygons") (FNS SCAN.LESSP CRIT.LESSP) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS SCAN)) (INITRECORDS SCAN) (VARS FILL.WRULE \FILL.DEBUG) (DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \FILL.DEBUG) (MACROS \NORMSECT \DrawScanList.Blt \DrawScanList.Display \DrawScanList.XScan.IP \DrawScanList.YScan.IP)) (FNS MAKESCAN SHEDSCAN NORMSECT CRITSECT) (FNS \POLYSHADE.BLT \POLYSHADE.DISPLAY \POLYSHADE.XSCAN.IP \POLYSHADE.YSCAN.IP) (FNS POLYSHADE.BLT POLYSHADE.DISPLAY POLYSHADE.IP POLYSHADE.SCAN.IP) (FNS FILLTRIANGLE)) (COMS (* ;;; "Filled Circles") (FNS \CIRCSHADE.BLT \CIRCSHADE.DISPLAY \CIRCSHADE.IP \CIRCSHADE.XSCAN.IP ) (FNS CIRCSHADE.BLT CIRCSHADE.DISPLAY CIRCSHADE.IP) (FNS FILLCIRCLE.IP FILLNGON.IP)) (P (MOVD 'FILLCIRCLE.IP 'CIRCSHADE.IP)) (* ;;; " Considering scan direction of the printer") (* ;;; " You must set these vars before opening IMAGESTREAM") (COMS (VARS (PRINTER.DEFAULT.SCAN.DIRECTION 'Y) (PRINTER.SCAN.DIRECTIONS.LIST))) (COMS (* ;;; "PBBT Optimized routines") (VARS PBBT.PANEL) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS FILL.TBLE)) (INITRECORDS FILL.TBLE) (FNS FILL.INITTBLE FILL.INCY FILL.LINE) (FNS FILL.TEST FILL.XPER FILL.CONT)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES (LOADCOMP) INTERPRESS XXGEOM)))) (* ;;; "Filled Polygons") (DEFINEQ (SCAN.LESSP [LAMBDA (SCAN1 SCAN2) (* FS " 9-Jul-85 15:24") (* * Is scan segment 1 less than 2, in scanline sense.) (ILESSP (fetch (SCAN LX) of SCAN1) (fetch (SCAN LX) of SCAN2]) (CRIT.LESSP [LAMBDA (SCAN1 SCAN2) (* FS " 8-Jul-85 15:47") (* * Is scan segment 1 less than 2, in critical pt sense) (ILESSP (fetch (SCAN BY) of SCAN1) (fetch (SCAN BY) of SCAN2]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE SCAN (LX RX GEOM TY BY WC REST)) ) (/DECLAREDATATYPE 'SCAN '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SCAN 0 POINTER) (SCAN 2 POINTER) (SCAN 4 POINTER) (SCAN 6 POINTER) (SCAN 8 POINTER) (SCAN 10 POINTER) (SCAN 12 POINTER)) '14) ) (/DECLAREDATATYPE 'SCAN '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((SCAN 0 POINTER) (SCAN 2 POINTER) (SCAN 4 POINTER) (SCAN 6 POINTER) (SCAN 8 POINTER) (SCAN 10 POINTER) (SCAN 12 POINTER)) '14) (RPAQQ FILL.WRULE 1) (RPAQQ \FILL.DEBUG NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS \FILL.DEBUG) ) (DECLARE%: EVAL@COMPILE [PUTPROPS \NORMSECT DMACRO ((SELF Y) (LET (XL XR (GEOM (ffetch (SCAN GEOM) of SELF))) (BRESSTEP GEOM Y XL XR) (freplace (SCAN LX) of SELF with XL) (freplace (SCAN RX) of SELF with XR] [PUTPROPS \DrawScanList.Blt DMACRO ((strm scanlist scany) (* ;; "count, fill.shade fill.wrule fill.frule are dynamically scoped outside macro") (SETQ count 0) [IF (EQ FILL.WRULE 1) THEN (for scan in scanlist do (SETQ count (IPLUS count 1)) (if (ODDP count) then (SETQ ex (IPLUS (ffetch (SCAN RX) of scan) 1)) else (BLTSHADE FILL.SHADE strm ex scany (IDIFFERENCE (ffetch (SCAN LX) of scan) ex) 1 FILL.FRULE] (IF (EQ FILL.WRULE 0) THEN (for scan in scanlist do [if (EQ count 0) then (SETQ ex (ADD1 (ffetch (SCAN RX) of scan] (SETQ count (IPLUS count (ffetch (SCAN WC) of scan))) (if (EQ count 0) then (BLTSHADE FILL.SHADE strm ex scany (IDIFFERENCE (ffetch (SCAN LX) of scan) ex) 1 FILL.FRULE] [PUTPROPS \DrawScanList.Display DMACRO ((strm scanlist scany) (* ;; "count, fill.shade fill.wrule fill.frule, table are dynamically scoped outside macro. Since if fill.wrule is 1 count is merely a toggle, use T and NIL.") [IF (EQ FILL.WRULE 1) THEN (SETQ count NIL) (for scan in scanlist do (SETQ count (NOT count)) (if count then (SETQ ex (ADD1 (ffetch (SCAN RX) of scan))) else (FILL.LINE table scany ex (ffetch (SCAN LX) of scan] (IF (EQ FILL.WRULE 0) THEN (SETQ count 0) (for scan in scanlist do [if (EQ count 0) then (SETQ ex (ADD1 (ffetch (SCAN RX) of scan] (SETQ count (IPLUS count (ffetch (SCAN WC) of scan))) (if (EQ count 0) then (FILL.LINE table scany ex (ffetch (SCAN LX) of scan] [PUTPROPS \DrawScanList.XScan.IP DMACRO ((strm scanlist scany) (* ;; "count, fill.shade fill.wrule fill.frule are dynamically scoped outside macro") (SETQ count 0) [IF (EQ FILL.WRULE 1) THEN (for scan in scanlist do (SETQ ix (fetch (SCAN LX) of scan)) (SETQ tx (ffetch (SCAN RX) of scan)) (SETQ count (IPLUS count 1)) (if (ODDP count) then (SETQ ex (IPLUS tx 1)) else (FILLRECTANGLE.IP strm ex scany (IDIFFERENCE ix ex) 1] (IF (EQ FILL.WRULE 0) THEN (for scan in scanlist do (SETQ ix (fetch (SCAN LX) of scan)) (SETQ tx (ffetch (SCAN RX) of scan)) (if (EQ count 0) then (SETQ ex (IPLUS tx 1))) (SETQ count (IPLUS count (ffetch (SCAN WC) of scan))) (if (EQ count 0) then (FILLRECTANGLE.IP strm ex scany (IDIFFERENCE ix ex) 1] [PUTPROPS \DrawScanList.YScan.IP DMACRO ((strm scanlist scany) (* ;; "count, fill.shade fill.wrule fill.frule are dynamically scoped outside macro * *") (SETQ count 0) [IF (EQ FILL.WRULE 1) THEN (for scan in scanlist do (SETQ ix (fetch (SCAN LX) of scan)) (SETQ tx (fetch (SCAN RX) of scan)) (SETQ count (IPLUS count 1)) (if (ODDP count) then (SETQ ex (IPLUS tx 1)) else (* ;; "Unreflect coordinates back") (FILLRECTANGLE.IP strm scany ix 1 (IDIFFERENCE ex ix] (IF (EQ FILL.WRULE 0) THEN (for scan in scanlist do (SETQ ix (fetch (SCAN LX) of scan)) (SETQ tx (fetch (SCAN RX) of scan)) (if (EQ count 0) then (SETQ ex (IPLUS tx 1))) (SETQ count (IPLUS count (fetch (SCAN WC) of scan))) (if (EQ count 0) then (* ;; "Unreflect coordinates back") (FILLRECTANGLE.IP strm scany ix 1 (IDIFFERENCE ex ix] ) ) (DEFINEQ (MAKESCAN [LAMBDA (EDGELIST) (* ; "Edited 24-Aug-87 22:35 by FS") (* ;; "Returns a scan object given a edge list") (LET [(SELF (create SCAN REST _ (SORT EDGELIST (FUNCTION LINE.LESSP] (SHEDSCAN SELF) SELF]) (SHEDSCAN [LAMBDA (SELF) (* rrb " 6-Mar-86 16:24") (* * remove current edge and replace with next) (LET (X0 Y0 DX DY YDIR EDGE TAIL BRES) (SETQ TAIL (fetch REST of SELF)) (COND (TAIL (SETQ EDGE (CAR TAIL)) (GETLINEORIG EDGE X0 Y0) (GETLINEDIFF EDGE DX DY) (SETQ BRES (MAKEBRES X0 Y0 DX DY)) (SETQ YDIR (fetch (LINE WIND) of EDGE)) (replace (SCAN GEOM) of SELF with BRES) (replace (SCAN REST) of SELF with (CDR TAIL)) (replace (SCAN BY) of SELF with Y0) (replace (SCAN TY) of SELF with (IPLUS Y0 DY)) (replace (SCAN WC) of SELF with YDIR]) (NORMSECT [LAMBDA (SELF Y) (* ; "Edited 24-Aug-87 19:29 by FS") (* ;; "Cause the scan object to update its scan segment based on scany. Assumes that dy is positive, which is true from MakeLine") (\NORMSECT SELF Y]) (CRITSECT [LAMBDA (SELF SCANY) (* FS "10-Feb-86 16:47") (* * Fetch more segments while on critical pt) (LET (IX1 TX1) (if \FILL.DEBUG then (printout T "SCANY: " SCANY T)) (NORMSECT SELF SCANY) (if (fetch (SCAN REST) of SELF) then (SETQ IX1 (fetch LX of SELF)) (SETQ TX1 (fetch RX of SELF)) [while (AND (EQ SCANY (fetch (SCAN TY) of SELF)) (fetch (SCAN REST) of SELF)) do (SHEDSCAN SELF) (NORMSECT SELF SCANY) (SETQ IX1 (IMIN IX1 (fetch (SCAN LX) of SELF))) (SETQ TX1 (IMAX TX1 (fetch (SCAN RX) of SELF] (replace (SCAN LX) of SELF with IX1) (replace (SCAN RX) of SELF with TX1]) ) (DEFINEQ (\POLYSHADE.BLT [LAMBDA (STRM ALIST FILL.SHADE FILL.FRULE FILL.WRULE) (* ; "Edited 1-Feb-89 18:28 by FS") (* ;; "Generic version of polygon code, works for any stream which can do BLTSHADE. Expects integer line lists, for Bltshade destinations, works in dev. coords, should limit to clip region if possible") (PROG (fulllist currlist clist nlist scan currcrit fullcrit crity count scany ix tx ex by ty) (SETQ fulllist (MAPCAR ALIST 'MAKESCAN)) (SETQ fulllist (SORT fulllist 'CRIT.LESSP)) (SETQ currlist NIL) (SETQ currcrit MIN.INTEGER) (SETQ scany (fetch (SCAN BY) of (CAR fulllist))) [while (OR currlist fulllist) do (* ;; "merge new critical edges") (while [AND (LISTP fulllist) (IEQP scany (fetch (SCAN BY) of (CAR fulllist] do (SETQ scan (CAR fulllist)) (SETQ currlist (CONS scan currlist)) (SETQ fulllist (CDR fulllist))) (if (LISTP fulllist) then (SETQ fullcrit (fetch (SCAN BY) of (CAR fulllist))) else (SETQ fullcrit MAX.INTEGER)) (* ;; "paint critical scan line") (for scan in currlist do (CRITSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.Blt STRM currlist scany) (* ;; "cull out exhausted edges") (SETQ scany (IPLUS scany 1)) (* ; "(ILEQ currcrit scany)") (SETQ currcrit MAX.INTEGER) (SETQ clist NIL) [for scan in currlist do (SETQ ty (fetch (SCAN TY) of scan)) (SETQ currcrit (IMIN currcrit ty)) (if (ILEQ scany ty) then (SETQ clist (CONS scan clist)) (SETQ currcrit (IMIN currcrit ty] (SETQ currlist clist) (* ;; "paint normal scan lines") (SETQ crity (IMIN currcrit fullcrit)) (while (ILESSP scany crity) do (for scan in currlist do (NORMSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.Blt STRM currlist scany) (SETQ scany (IPLUS scany 1] (RETURN NIL]) (\POLYSHADE.DISPLAY [LAMBDA (STRM ALIST FILL.SHADE FILL.FRULE FILL.WRULE) (* ; "Edited 24-Aug-87 19:47 by FS") (* ;; "Generic version of polygon code, works for any device which can do pilot bbt. Expects integer line lists, for Bltshade destinations, works in dev. coords, should limit to clip region if possible") (PROG (fulllist currlist clist nlist scan currcrit fullcrit crity count scany ex ty table) (SETQ table (FILL.INITTBLE STRM FILL.SHADE FILL.FRULE)) (SETQ fulllist (for I in ALIST collect (MAKESCAN I))) (SETQ fulllist (SORT fulllist 'CRIT.LESSP)) (SETQ currlist NIL) (SETQ currcrit MIN.SMALLP) (SETQ scany (fetch (SCAN BY) of (CAR fulllist))) [while (OR currlist fulllist) do (* ;; "merge new critical edges") (while [AND (LISTP fulllist) (IEQP scany (fetch (SCAN BY) of (CAR fulllist] do (SETQ scan (CAR fulllist)) (SETQ currlist (CONS scan currlist)) (SETQ fulllist (CDR fulllist))) (COND [(LISTP fulllist) (SETQ fullcrit (fetch (SCAN BY) of (CAR fulllist] (T (SETQ fullcrit MAX.SMALLP))) (* ;; "paint critical scan line") (for scan in currlist do (CRITSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.Display STRM currlist scany) (* ;; "cull out exhausted edges") (SETQ scany (IPLUS scany 1)) (* ; "(ILEQ currcrit scany)") (SETQ currcrit MAX.SMALLP) (SETQ clist NIL) [for scan in currlist do (SETQ ty (fetch (SCAN TY) of scan)) (SETQ currcrit (IMIN currcrit ty)) (COND ((ILEQ scany ty) (SETQ clist (CONS scan clist)) (SETQ currcrit (IMIN currcrit ty] (SETQ currlist clist) (* ;; "paint normal scan lines") (SETQ crity (IMIN currcrit fullcrit)) (while (ILESSP scany crity) do (for scan in currlist do (\NORMSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.Display STRM currlist scany) (SETQ scany (IPLUS scany 1] (RETURN NIL]) (\POLYSHADE.XSCAN.IP [LAMBDA (STRM ALIST FILL.SHADE FILL.FRULE FILL.WRULE) (* ; "Edited 1-Feb-89 18:40 by FS") (* ;; "Current version of polygon code, Expects integer line lists, must be used in device coordinates (transposed 300 dpi)") (PROG (fulllist currlist clist nlist scan currcrit fullcrit crity count scany ix tx ex by ty) (SETCOLOR.IP STRM FILL.SHADE FILL.FRULE) (* ;  "cache texture as ip sampled black") (SETQ fulllist (for I in ALIST collect (MAKESCAN I))) (SETQ fulllist (SORT fulllist 'CRIT.LESSP)) (SETQ currlist NIL) (SETQ currcrit MIN.INTEGER) (SETQ scany (fetch (SCAN BY) of (CAR fulllist))) [while (OR currlist fulllist) do (* ;; "merge new critical edges") (while [AND (LISTP fulllist) (IEQP scany (fetch (SCAN BY) of (CAR fulllist] do (SETQ scan (CAR fulllist)) (SETQ currlist (CONS scan currlist)) (SETQ fulllist (CDR fulllist))) (COND [(LISTP fulllist) (SETQ fullcrit (fetch (SCAN BY) of (CAR fulllist] (T (SETQ fullcrit MAX.INTEGER))) (* ;; "paint critical scan line") (for scan in currlist do (CRITSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.XScan.IP STRM currlist scany) (* ;; "cull out exhausted edges") (SETQ scany (IPLUS scany 1)) (* ; "(ILEQ currcrit scany)") (SETQ currcrit MAX.INTEGER) (SETQ clist NIL) [for scan in currlist do (SETQ ty (fetch (SCAN TY) of scan)) (SETQ currcrit (IMIN currcrit ty)) (COND ((ILEQ scany ty) (SETQ clist (CONS scan clist)) (SETQ currcrit (IMIN currcrit ty] (SETQ currlist clist) (* ;; "paint normal scan lines") (SETQ crity (IMIN currcrit fullcrit)) (while (ILESSP scany crity) do (for scan in currlist do (NORMSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.XScan.IP STRM currlist scany) (SETQ scany (IPLUS scany 1] (RETURN NIL]) (\POLYSHADE.YSCAN.IP [LAMBDA (STRM ALIST FILL.SHADE FILL.FRULE FILL.WRULE) (* ; "Edited 6-Feb-89 18:32 by FS") (* ;; "Current version of polygon code, Expects integer line lists, must be used in device coordinates (transposed 300 dpi)") (PROG (fulllist currlist clist nlist scan currcrit fullcrit crity count scany ix tx ex by ty) (SETCOLOR.IP STRM FILL.SHADE FILL.FRULE) (* ;  "cache texture as ip sampled black") (SETQ fulllist (MAPCAR ALIST 'MAKESCAN)) (SETQ fulllist (SORT fulllist 'CRIT.LESSP)) (SETQ currlist NIL) (SETQ currcrit MIN.INTEGER) (SETQ scany (fetch (SCAN BY) of (CAR fulllist))) [while (OR currlist fulllist) do (* ;; "merge new critical edges") (while [AND (LISTP fulllist) (IEQP scany (fetch (SCAN BY) of (CAR fulllist] do (SETQ scan (CAR fulllist)) (SETQ currlist (CONS scan currlist)) (SETQ fulllist (CDR fulllist))) (COND [(LISTP fulllist) (SETQ fullcrit (fetch (SCAN BY) of (CAR fulllist] (T (SETQ fullcrit MAX.INTEGER))) (* ;; "paint critical scan line") (for scan in currlist do (CRITSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.YScan.IP STRM currlist scany) (* ;; "cull out exhausted edges") (SETQ scany (IPLUS scany 1)) (* ; "(ILEQ currcrit scany)") (SETQ currcrit MAX.INTEGER) (SETQ clist NIL) [for scan in currlist do (SETQ ty (fetch (SCAN TY) of scan)) (SETQ currcrit (IMIN currcrit ty)) (COND ((ILEQ scany ty) (SETQ clist (CONS scan clist)) (SETQ currcrit (IMIN currcrit ty] (SETQ currlist clist) (* ;; "paint normal scan lines") (SETQ crity (IMIN currcrit fullcrit)) (while (ILESSP scany crity) do (for scan in currlist do (NORMSECT scan scany)) (SORT currlist 'SCAN.LESSP) (\DrawScanList.YScan.IP STRM currlist scany) (SETQ scany (IPLUS scany 1] (RETURN NIL]) ) (DEFINEQ (POLYSHADE.BLT [LAMBDA (STREAM POINTS TEXTURE OPERATION WINDNUMBER) (* FS "30-Oct-85 17:32") (* * Convert knot list into internal data structures) (LET (ILIST LLIST) (SETQ ILIST (PREPLOOP POINTS)) (SETQ LLIST (MAPCAR ILIST 'KNOTLINE)) (if (AND (NEQ WINDNUMBER 0) (NEQ WINDNUMBER 1)) then (SETQ WINDNUMBER FILL.WRULE)) (\POLYSHADE.BLT STREAM LLIST TEXTURE OPERATION WINDNUMBER]) (POLYSHADE.DISPLAY [LAMBDA (STREAM POINTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 24-Aug-87 19:44 by FS") (* ;; "Convert knot list into internal data structures, for now call generic routine") (LET (ILIST LLIST) (SETQ ILIST (PREPLOOP POINTS)) (SETQ LLIST (MAPCAR ILIST 'KNOTLINE)) (if (AND (NEQ WINDNUMBER 0) (NEQ WINDNUMBER 1)) then (SETQ WINDNUMBER FILL.WRULE)) (\POLYSHADE.DISPLAY STREAM LLIST TEXTURE OPERATION WINDNUMBER]) (POLYSHADE.IP [LAMBDA (STREAM POINTS TEXTURE OPERATION WINDNUMBER) (* ; "Edited 14-Jun-90 09:29 by takeshi") (* ;; "Default is to scan convert in Y direction.") (DECLARE (GLOBALVARS PRINTER.DEFAULT.SCAN.DIRECTION)) (POLYSHADE.SCAN.IP STREAM POINTS TEXTURE OPERATION WINDNUMBER (COND [(EQ (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) 'PRINTERMODE) 'LANDSCAPE) (* ;  "This stream is treated as Landscape") (COND ((EQ (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) 'P.SCAN.DIRECTION) 'X) (PROGN 'Y)) (T 'X] (T (LISTGET (fetch (STREAM OTHERPROPS) of STREAM) 'P.SCAN.DIRECTION)) (* ; " Portreit") ]) (POLYSHADE.SCAN.IP [LAMBDA (STREAM POINTS TEXTURE OPERATION WINDNUMBER SCANDIRECTION) (* ; "Edited 1-Feb-89 18:53 by FS") (* ;; "Convert micas to device units, and transpose, tell Interpress to take dev units back to micas, convert knot list into internal data structures") (LET (ILIST LLIST (MicasToDev 0.1181102) XTOX XTOY) (* ; "hack until can change IP") (* ; "MicasToDev 300dpi / 2540micaspi") (IF (EQ SCANDIRECTION 'X) THEN (SETQ XTOX MicasToDev) (* ; "just scale") (SETQ XTOY 0) ELSE (SETQ XTOX 0) (* ; "transpose & scale") (SETQ XTOY MicasToDev)) [IF (NUMBERP (CAAR POINTS)) THEN (SETQ POINTS (IMLTLIST POINTS XTOX XTOY 0 XTOY XTOX 0)) ELSE (SETQ POINTS (for I in POINTS collect (IMLTLIST I XTOX XTOY 0 XTOY XTOX 0] (APPENDOP.IP STREAM DOSAVESIMPLEBODY) (APPENDOP.IP STREAM {) (SCALE.IP STREAM 8.466666) (* ; "2540micaspi / 300dpi") (CONCATT.IP STREAM) (* ; "Convert to integer") (SETQ ILIST (PREPLOOP POINTS)) (SETQ LLIST (MAPCAR ILIST 'KNOTLINE)) (IF (AND (NEQ WINDNUMBER 0) (NEQ WINDNUMBER 1)) THEN (SETQ WINDNUMBER FILL.WRULE)) (IF (EQ SCANDIRECTION 'X) THEN (\POLYSHADE.XSCAN.IP STREAM LLIST TEXTURE OPERATION WINDNUMBER) ELSE (\POLYSHADE.YSCAN.IP STREAM LLIST TEXTURE OPERATION WINDNUMBER)) (APPENDOP.IP STREAM }]) ) (DEFINEQ (FILLTRIANGLE [LAMBDA (X1 Y1 X2 Y2 X3 Y3 TEXTURE STREAM OPERATION) (* ; "Edited 24-Aug-87 19:43 by FS") (LET* ([TEMPLIST '((10 . 10) (100 . 100) (200 . 30] (PT1 (CAR TEMPLIST)) (PT2 (CADR TEMPLIST)) (PT3 (CADDR TEMPLIST))) (* ;; "Smash temporary list here") (RPLACA PT1 X1) (RPLACD PT1 Y1) (RPLACA PT2 X2) (RPLACD PT2 Y2) (RPLACA PT3 X3) (RPLACD PT3 Y3) (IF (EQ (IMAGESTREAMTYPE STREAM) 'INTERPRESS) THEN (\FILLPOLYGON.IP STREAM TEMPLIST TEXTURE OPERATION) ELSE (FILLPOLYGON TEMPLIST TEXTURE STREAM OPERATION]) ) (* ;;; "Filled Circles") (DEFINEQ (\CIRCSHADE.BLT [LAMBDA (STREAM CX CY R TEXTURE OPERATION) (* ; "Edited 31-Mar-88 22:08 by FS") (* ;; "Bresenham's circle drawing routine, x and y are reversed") (LET (Y X E U V X0 Y0) (* ;; "Avoid calling DSPOPERATION every call to bitblt") (IF (NOT OPERATION) THEN (SETQ OPERATION (DSPOPERATION NIL STREAM))) (SETQ Y 0) (SETQ X R) (SETQ U 1) (SETQ V (IDIFFERENCE 1 (ITIMES 2 R))) (SETQ E (IDIFFERENCE 1 R)) (BLTSHADE TEXTURE STREAM (IDIFFERENCE CX X) CY (IPLUS X X 1) 1 OPERATION) (while (ILESSP Y X) do (SETQ X0 X) (SETQ Y0 Y) (if (MINUSP E) then (SETQ Y (ADD1 Y)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 2)) (SETQ E (IPLUS E U)) else (SETQ Y (ADD1 Y)) (SETQ X (SUB1 X)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 4)) (SETQ E (IPLUS E V))) (BLTSHADE TEXTURE STREAM (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS X X 1) 1 OPERATION) (BLTSHADE TEXTURE STREAM (IDIFFERENCE CX X) (IPLUS CY Y) (IPLUS X X 1) 1 OPERATION) (if (AND (NOT (EQUAL X0 X)) (IGREATERP (IDIFFERENCE X0 Y0) 1)) then (BLTSHADE TEXTURE STREAM (IDIFFERENCE CX Y0) (IDIFFERENCE CY X0) (IPLUS Y0 Y0 1) 1 OPERATION) (BLTSHADE TEXTURE STREAM (IDIFFERENCE CX Y0) (IPLUS CY X0) (IPLUS Y0 Y0 1) 1 OPERATION]) (\CIRCSHADE.DISPLAY [LAMBDA (STREAM CX CY R TEXTURE OPERATION) (* ; "Edited 31-Mar-88 18:01 by FS") (* ;; "Bresenham's circle drawing routine, x and y are reversed") (LET (Y X E U V X0 Y0 table) (* ;; "Initialize microcode table support") (SETQ table (FILL.INITTBLE STREAM TEXTURE OPERATION)) (* ;; "Do Bresenham circle") (SETQ Y 0) (SETQ X R) (SETQ U 1) (SETQ V (IDIFFERENCE 1 (ITIMES 2 R))) (SETQ E (IDIFFERENCE 1 R)) (FILL.LINE table CY (IDIFFERENCE CX X) (IPLUS CX X)) (while (ILESSP Y X) do (SETQ X0 X) (SETQ Y0 Y) (if (MINUSP E) then (SETQ Y (ADD1 Y)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 2)) (SETQ E (IPLUS E U)) else (SETQ Y (ADD1 Y)) (SETQ X (SUB1 X)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 4)) (SETQ E (IPLUS E V))) (FILL.LINE table (IDIFFERENCE CY Y) (IDIFFERENCE CX X) (IPLUS CX X)) (FILL.LINE table (IPLUS CY Y) (IDIFFERENCE CX X) (IPLUS CX X)) (if (AND (NOT (EQUAL X0 X)) (IGREATERP (IDIFFERENCE X0 Y0) 1)) then (FILL.LINE table (IDIFFERENCE CY X0) (IDIFFERENCE CX Y0) (IPLUS CX Y0)) (FILL.LINE table (IPLUS CY X0) (IDIFFERENCE CX Y0) (IPLUS CX Y0]) (\CIRCSHADE.IP [LAMBDA (STREAM CX CY R TEXTURE OPERATION) (* ; "Edited 31-Mar-88 18:05 by FS") (* ;; "Bresenham's circle drawing routine, x and y are reversed; Used in device coordinates 300dpi transposed") (LET (Y X E U V X0 Y0) (SETCOLOR.IP STREAM TEXTURE OPERATION) (* ;  "cache texture as ip sampled black") (SETQ Y 0) (SETQ X R) (SETQ U 1) (SETQ V (IDIFFERENCE 1 (ITIMES 2 R))) (SETQ E (IDIFFERENCE 1 R)) (FILLRECTANGLE.IP STREAM CX (IDIFFERENCE CY X) 1 (IPLUS X X 1)) (while (ILESSP Y X) do (SETQ X0 X) (SETQ Y0 Y) [COND ((MINUSP E) (SETQ Y (ADD1 Y)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 2)) (SETQ E (IPLUS E U))) (T (SETQ Y (ADD1 Y)) (SETQ X (SUB1 X)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 4)) (SETQ E (IPLUS E V] (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX Y) (IDIFFERENCE CY X) 1 (IPLUS X X 1)) (FILLRECTANGLE.IP STREAM (IPLUS CX Y) (IDIFFERENCE CY X) 1 (IPLUS X X 1)) (COND ((AND (NOT (EQUAL X0 X)) (IGREATERP (IDIFFERENCE X0 Y0) 1)) (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX X0) (IDIFFERENCE CY Y0) 1 (IPLUS Y0 Y0 1)) (FILLRECTANGLE.IP STREAM (IPLUS CX X0) (IDIFFERENCE CY Y0) 1 (IPLUS Y0 Y0 1]) (\CIRCSHADE.XSCAN.IP [LAMBDA (STREAM CX CY R TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:38 by FS") (* ;; "Bresenham's circle drawing routine; Used in device coordinates 300dpi, x and y are reversed. Some printers prefer to scan in the X direction, for those printers use this routine instead.") (LET (Y X E U V X0 Y0) (SETCOLOR.IP STREAM TEXTURE OPERATION) (* ;  "cache texture as ip sampled black") (SETQ Y 0) (SETQ X R) (SETQ U 1) (SETQ V (IDIFFERENCE 1 (ITIMES 2 R))) (SETQ E (IDIFFERENCE 1 R)) (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX X) CY (IPLUS X X 1) 1) (while (ILESSP Y X) do (SETQ X0 X) (SETQ Y0 Y) (if (MINUSP E) then (SETQ Y (ADD1 Y)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 2)) (SETQ E (IPLUS E U)) else (SETQ Y (ADD1 Y)) (SETQ X (SUB1 X)) (SETQ U (IPLUS U 2)) (SETQ V (IPLUS V 4)) (SETQ E (IPLUS E V))) (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX X) (IDIFFERENCE CY Y) (IPLUS X X 1) 1) (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX X) (IPLUS CY Y) (IPLUS X X 1) 1) (if (AND (NOT (EQUAL X0 X)) (IGREATERP (IDIFFERENCE X0 Y0) 1)) then (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX Y0) (IDIFFERENCE CY X0) (IPLUS Y0 Y0 1) 1) (FILLRECTANGLE.IP STREAM (IDIFFERENCE CX Y0) (IPLUS CY X0) (IPLUS Y0 Y0 1) 1]) ) (DEFINEQ (CIRCSHADE.BLT [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) (* ; "Edited 31-Mar-88 21:56 by FS") (* ;; "GenericBlt circle shader, check args") (if (AND (NUMBERP CENTERX) (NUMBERP CENTERY) (NUMBERP RADIUS) (STREAMP STREAM) (TEXTUREP TEXTURE)) then (\CIRCSHADE.BLT STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) else (ERROR "Bad argument(s)"]) (CIRCSHADE.DISPLAY [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) (* ; "Edited 31-Mar-88 18:01 by FS") (* ;; "Check args; This routine not currently used * *") (if (AND (NUMBERP CENTERX) (NUMBERP CENTERY) (NUMBERP RADIUS) (STREAMP STREAM) (TEXTUREP TEXTURE)) then (\CIRCSHADE.DISPLAY STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) else (ERROR "Bad argument(s)"]) (CIRCSHADE.IP [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:12 by FS") (* ;; "Interpress2.1 doesn't support ARCTO, so must either approximate a circle (as here), or scan convert it (e.g. CIRCSHADE.IP)") (* ;; "This code does not generate as nicely %"round%" circles as circshade.ip (the difference is visible to the naked eye). However, this code should be better for landscape printing, for code which uses pushstate/popstate, and for printers which scan in the X direction (e.g. Fuji Xerox XP-9), because it generates a simpler master.") (* ;; "Wimp out and display regular N-gon. For smaller circles, can use fewer points? Could also render two half circles (thus allowing twice the number of points since there are two trajectories), but what the heck.") (* ;;  "Note also the clipping code isn't integrated with this (nor TRAJECTORY.IP, or others).") (FILLNGON.IP STREAM 90 RADIUS CENTERX CENTERY TEXTURE OPERATION]) ) (DEFINEQ (FILLCIRCLE.IP [LAMBDA (STREAM CENTERX CENTERY RADIUS TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:12 by FS") (* ;; "Interpress2.1 doesn't support ARCTO, so must either approximate a circle (as here), or scan convert it (e.g. CIRCSHADE.IP)") (* ;; "This code does not generate as nicely %"round%" circles as circshade.ip (the difference is visible to the naked eye). However, this code should be better for landscape printing, for code which uses pushstate/popstate, and for printers which scan in the X direction (e.g. Fuji Xerox XP-9), because it generates a simpler master.") (* ;; "Wimp out and display regular N-gon. For smaller circles, can use fewer points? Could also render two half circles (thus allowing twice the number of points since there are two trajectories), but what the heck.") (* ;;  "Note also the clipping code isn't integrated with this (nor TRAJECTORY.IP, or others).") (FILLNGON.IP STREAM 90 RADIUS CENTERX CENTERY TEXTURE OPERATION]) (FILLNGON.IP [LAMBDA (IPSTREAM NPOINTS RADIUS CENTERX CENTERY TEXTURE OPERATION) (* ; "Edited 1-Feb-89 17:19 by FS") (* ;; "Create and fill a regular polygon (standing on its tip). Since its convex, we can use the primitive IP operator to do the job. Note there is no clipping in this routine.") (* ;; "Could have used FILLTRAJECTORY.IP, but this function CONSes less. Could have walked 1/8 of circle and used symmetry, but what the heck.......") (LET (BASEANGLE ANGLE X Y) (* ;; "Try to avoid limitations of printers. Anything more than 64 or so looks for all intents and purposes like a circle anyway.") (if (IGREATERP NPOINTS MAXSEGSPERTRAJECTORY) then (SETQ NPOINTS MAXSEGSPERTRAJECTORY)) (SETQ BASEANGLE (FQUOTIENT 360 NPOINTS)) (APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY) (* ;  "Save state (to undo SETCOLOR)") (APPENDOP.IP IPSTREAM {) (SETCOLOR.IP IPSTREAM TEXTURE OPERATION) (MOVETO.IP IPSTREAM CENTERX (IPLUS CENTERY RADIUS)) (* ; "handle 0 point specially") (* ;;  "Note that the trajectory is not closed, IP spec says outlines get closed anyway.") (for I from 1 to (SUB1 NPOINTS) do (SETQ ANGLE (TIMES I BASEANGLE)) (* ; "Since these are micas, we can avoid some floating point by forcing values to be integer") [SETQ X (IPLUS CENTERX (TIMES RADIUS (SIN ANGLE] [SETQ Y (IPLUS CENTERY (TIMES RADIUS (COS ANGLE] (LINETO.IP IPSTREAM X Y)) (APPENDINTEGER.IP IPSTREAM 1) (* ; "number of trajectories") (APPENDOP.IP IPSTREAM MAKEOUTLINE) (APPENDOP.IP IPSTREAM MASKFILL) (APPENDOP.IP IPSTREAM }) (* ; "restore state") NIL]) ) (MOVD 'FILLCIRCLE.IP 'CIRCSHADE.IP) (* ;;; " Considering scan direction of the printer") (* ;;; " You must set these vars before opening IMAGESTREAM") (RPAQQ PRINTER.DEFAULT.SCAN.DIRECTION Y) (RPAQQ PRINTER.SCAN.DIRECTIONS.LIST NIL) (* ;;; "PBBT Optimized routines") (RPAQQ PBBT.PANEL ((NULL (SETQ MYDSTRM (\OUTSTREAMARG MYWIN)) (TIMEALL (FILL.CONT MYDSTRM (RAND) 'REPLACE 10 300) 20) (TIMEALL (FILL.TEST MYDSTRM (RAND) 'REPLACE 10 300) 20) (TIMEALL (FILL.XPER MYDSTRM (RAND) 'REPLACE 10 300) 20) (TIMEALL (FILLPOLYGON KLIST (RAND) MYDSTRM) 20) (TIMEALL (BLTSHADE (RAND) MYDSTRM 10 10 290 290 'REPLACE) 20)))) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (DATATYPE FILL.TBLE (FBBT TX TY ADDR LLEN TXTW TXTH TXTA BITS LFT RGT TOP BOT TEXT STRM)) ) (/DECLAREDATATYPE 'FILL.TBLE '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FILL.TBLE 0 POINTER) (FILL.TBLE 2 POINTER) (FILL.TBLE 4 POINTER) (FILL.TBLE 6 POINTER) (FILL.TBLE 8 POINTER) (FILL.TBLE 10 POINTER) (FILL.TBLE 12 POINTER) (FILL.TBLE 14 POINTER) (FILL.TBLE 16 POINTER) (FILL.TBLE 18 POINTER) (FILL.TBLE 20 POINTER) (FILL.TBLE 22 POINTER) (FILL.TBLE 24 POINTER) (FILL.TBLE 26 POINTER) (FILL.TBLE 28 POINTER)) '30) ) (/DECLAREDATATYPE 'FILL.TBLE '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((FILL.TBLE 0 POINTER) (FILL.TBLE 2 POINTER) (FILL.TBLE 4 POINTER) (FILL.TBLE 6 POINTER) (FILL.TBLE 8 POINTER) (FILL.TBLE 10 POINTER) (FILL.TBLE 12 POINTER) (FILL.TBLE 14 POINTER) (FILL.TBLE 16 POINTER) (FILL.TBLE 18 POINTER) (FILL.TBLE 20 POINTER) (FILL.TBLE 22 POINTER) (FILL.TBLE 24 POINTER) (FILL.TBLE 26 POINTER) (FILL.TBLE 28 POINTER)) '30) (DEFINEQ (FILL.INITTBLE [LAMBDA (DISPLAYSTREAM TEXTURE OPERATION) (* ; "Edited 2-Feb-89 00:40 by FS") (* ;; "Takes normal fill arguments and caches pilot bbt table") (PROG (FILLTBLE TOPP BOTTOM RIGHT LEFT DestinationBitMap (DISPLAYDATA (fetch IMAGEDATA of DISPLAYSTREAM)) DESTINATIONBASE RASTERWIDTH CX CY TEXTUREBM GRAYHEIGHT GRAYWIDTH GRAYBASE NBITS FCBBT) (SETQ FCBBT (create PILOTBBT)) (SETQ TOPP (SUB1 (fetch DDClippingTop of DISPLAYDATA))) (SETQ BOTTOM (fetch DDClippingBottom of DISPLAYDATA)) (SETQ LEFT (fetch DDClippingLeft of DISPLAYDATA)) (SETQ RIGHT (SUB1 (fetch DDClippingRight of DISPLAYDATA))) (if (NOT OPERATION) then (SETQ OPERATION (ffetch DDOPERATION of DISPLAYDATA))) (SETQ DestinationBitMap (fetch DDDestination of DISPLAYDATA)) (SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DestinationBitMap)) [SETQ TEXTUREBM (COND ((BITMAPP TEXTURE)) [(AND (NEQ NBITS 1) (BITMAPP (COLORTEXTUREFROMCOLOR# (COLORNUMBERP (OR TEXTURE (DSPCOLOR NIL DISPLAYSTREAM) ) NBITS) NBITS] [(AND (NULL TEXTURE) (BITMAPP (ffetch DDTexture of DISPLAYDATA] ([OR (FIXP TEXTURE) (AND (NULL TEXTURE) (SETQ TEXTURE (ffetch DDTexture of DISPLAYDATA] (* ;;  "create bitmap for the texture. Could reuse a bitmap but for now this is good enough.") (SETQ TEXTUREBM (BITMAPCREATE 16 4 NBITS)) (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (\PUTBASE GRAYBASE 0 (\SFReplicate (LOGAND (LRSH TEXTURE 12) 15))) (\PUTBASE GRAYBASE 1 (\SFReplicate (LOGAND (LRSH TEXTURE 8) 15))) (\PUTBASE GRAYBASE 2 (\SFReplicate (LOGAND (LRSH TEXTURE 4) 15))) (\PUTBASE GRAYBASE 3 (\SFReplicate (LOGAND TEXTURE 15))) TEXTUREBM) (T (\ILLEGAL.ARG TEXTURE] (SETQ GRAYBASE (fetch (BITMAP BITMAPBASE) of TEXTUREBM)) (SETQ DESTINATIONBASE (fetch BITMAPBASE of DestinationBitMap)) (SETQ RASTERWIDTH (fetch BITMAPRASTERWIDTH of DestinationBitMap)) (* ;; "update as many fields in the brush bitblt table as possible from DS.") (replace PBTFLAGS of FCBBT with 0) (replace PBTDESTBPL of FCBBT with (UNFOLD RASTERWIDTH BITSPERWORD)) (* ;; "clear gray information. PBTSOURCEBPL is used for gray information too.") (replace PBTSOURCEBPL of FCBBT with 0) (replace PBTUSEGRAY of FCBBT with T) [replace PBTGRAYWIDTHLESSONE of FCBBT with (SUB1 (SETQ GRAYWIDTH (IMIN (fetch (BITMAP BITMAPWIDTH ) of TEXTUREBM) 16] [replace PBTGRAYHEIGHTLESSONE of FCBBT with (SUB1 (SETQ GRAYHEIGHT (IMIN (fetch (BITMAP BITMAPHEIGHT) of TEXTUREBM) 16] (replace PBTDISJOINT of FCBBT with T) (\SETPBTFUNCTION FCBBT 'TEXTURE OPERATION) (replace PBTHEIGHT of FCBBT with 1) (SETQ CX (\DSPTRANSFORMX 0 DISPLAYDATA)) (SETQ CY (\DSPTRANSFORMY 0 DISPLAYDATA)) (* ;; "change Y TOP and BOTTOM to be in bitmap coordinates") (SETQ CY (SUB1 (\SFInvert DestinationBitMap CY))) [SETQ BOTTOM (PROG1 (SUB1 (\SFInvert DestinationBitMap TOPP)) (SETQ TOPP (SUB1 (\SFInvert DestinationBitMap BOTTOM))))] (\INSURETOPWDS DISPLAYSTREAM) (* ;; "Move the window to top while interruptable, but verify that it is still there uninterruptably with drawing points") (SETQ FILLTBLE (create FILL.TBLE)) (with FILL.TBLE FILLTBLE (*) (SETQ FBBT FCBBT) (SETQ TX CX) (SETQ TY CY) (SETQ ADDR DESTINATIONBASE) (SETQ LLEN RASTERWIDTH) (SETQ TXTW GRAYWIDTH) (SETQ TXTH GRAYHEIGHT) (SETQ TXTA GRAYBASE) (SETQ TEXT TEXTUREBM) (SETQ STRM DISPLAYSTREAM) (SETQ BITS NBITS) (SETQ LFT LEFT) (SETQ RGT RIGHT) (SETQ TOP TOPP) (SETQ BOT BOTTOM)) (RETURN FILLTBLE]) (FILL.INCY [LAMBDA (TBLE) (* FS "29-Oct-85 19:46") (with FILL.TBLE TBLE (*) (SETQ ADDR (IPLUS ADDR LLEN)) (with PILOTBBT FBBT (*) (SETQ PBTDEST ADDR]) (FILL.LINE [LAMBDA (TBLE Y XL XR) (* FS "29-Oct-85 20:19") (with FILL.TBLE TBLE (*) (SETQ Y (IDIFFERENCE TY Y)) (SETQ XL (IPLUS TX XL)) (SETQ XR (IPLUS TX XR)) (\LINEBLT FBBT XL Y XR ADDR LLEN LFT RGT BOT TOP TXTW TXTH TXTA BITS]) ) (DEFINEQ (FILL.TEST [LAMBDA (STRM TEXT OPER YMIN YMAX) (* FS "29-Oct-85 19:59") (LET (TBLE) (SETQ OPER 'REPLACE) (SETQ TBLE (FILL.INITTBLE STRM TEXT OPER)) (for I from YMIN to YMAX do (FILL.LINE TBLE I I 300]) (FILL.XPER [LAMBDA (STRM TEXT OPER YMIN YMAX) (* FS "30-Oct-85 19:30") (LET (TBLE) (SETQ OPER 'REPLACE) (SETQ TBLE (FILL.INITTBLE STRM TEXT OPER)) (for I from YMIN to YMAX do (.WHILE.TOP.DS. STRM (FILL.LINE TBLE I I 300 ]) (FILL.CONT [LAMBDA (STRM TEXT OPER YMIN YMAX) (* FS "29-Oct-85 20:11") (LET (TBLE) (SETQ OPER 'REPLACE) (SETQ TBLE (FILL.INITTBLE STRM TEXT OPER)) (for I from YMIN to YMAX do (BLTSHADE TEXT STRM I I (IDIFFERENCE 300 I) 1 OPER]) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (FILESLOAD (LOADCOMP) INTERPRESS XXGEOM) ) (PUTPROPS XXFILL COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1989 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2690 3246 (SCAN.LESSP 2700 . 2970) (CRIT.LESSP 2972 . 3244)) (10805 13332 (MAKESCAN 10815 . 11134) (SHEDSCAN 11136 . 12015) (NORMSECT 12017 . 12298) (CRITSECT 12300 . 13330)) (13333 25445 (\POLYSHADE.BLT 13343 . 16244) (\POLYSHADE.DISPLAY 16246 . 19298) (\POLYSHADE.XSCAN.IP 19300 . 22385) (\POLYSHADE.YSCAN.IP 22387 . 25443)) (25446 29450 (POLYSHADE.BLT 25456 . 25951) ( POLYSHADE.DISPLAY 25953 . 26496) (POLYSHADE.IP 26498 . 27551) (POLYSHADE.SCAN.IP 27553 . 29448)) ( 29451 30218 (FILLTRIANGLE 29461 . 30216)) (30252 41279 (\CIRCSHADE.BLT 30262 . 33084) ( \CIRCSHADE.DISPLAY 33086 . 35590) (\CIRCSHADE.IP 35592 . 38366) (\CIRCSHADE.XSCAN.IP 38368 . 41277)) ( 41280 43483 (CIRCSHADE.BLT 41290 . 41833) (CIRCSHADE.DISPLAY 41835 . 42398) (CIRCSHADE.IP 42400 . 43481)) (43484 46634 (FILLCIRCLE.IP 43494 . 44576) (FILLNGON.IP 44578 . 46632)) (49331 56392 ( FILL.INITTBLE 49341 . 55700) (FILL.INCY 55702 . 56024) (FILL.LINE 56026 . 56390)) (56393 57462 ( FILL.TEST 56403 . 56692) (FILL.XPER 56694 . 57086) (FILL.CONT 57088 . 57460))))) STOP \ No newline at end of file diff --git a/sources/XXGEOM b/sources/XXGEOM new file mode 100644 index 00000000..a52b3419 --- /dev/null +++ b/sources/XXGEOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 11:30:54" {DSK}lde>lispcore>sources>XXGEOM.;2 49900 changes to%: (RECORDS XYPT LINE BRES) previous date%: "23-May-90 13:39:37" {DSK}lde>lispcore>sources>XXGEOM.;1) (* ; " Copyright (c) 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT XXGEOMCOMS) (RPAQQ XXGEOMCOMS ( (* ;;; "Integer Geometry Library") (* ;;; "Scalar methods") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SGN)) (FNS \IRND) (* ;;; "XYpt object and methods") (RECORDS XYPT) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS XYPT.X XYPT.Y)) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS HEADPT NEXTPT HEADPTY NEXTPTY)) (FNS MAKEXYPT IRNDLIST NORMLOOP SLITLOOP PREPLOOP YMAPLIST IMAPLIST UNIQLIST MERGLIST MMLTLIST IMLTLIST XYPT.LESSP PATH.LESSP CONVEXP) (* ;;; "Line object and methods") (RECORDS LINE) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS GETLINEDIFF GETLINEORIG \GETLINEDIFF \GETLINEORIGY \GETLINEDIFFY)) (FNS MAKELINE MSECT XSECT YSECT XYSECT KNOTLINE KNOTLOOP LINE.LESSP) (FNS LINEY MIDDX INITX TERMX SCANX XPROD) (* ;;; "line segment methods") (FNS XYSECTLSEG) (* ;;; "Bresenham line object and methods") (RECORDS BRES) (FNS MAKEBRES) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS BRESSTEP)) (* ;;; "Debugging control panel") (DECLARE%: EVAL@COMPILE DONTCOPY (VARS \GEOM.PANEL)) (* ;;; "Trapezoidal decomposition") (FNS TRAPLOOP TRAPMAKE) (VARS TRAP.DEBUG) (DECLARE%: EVAL@COMPILE DONTCOPY (VARS \TRAP.PANEL)))) (* ;;; "Integer Geometry Library") (* ;;; "Scalar methods") (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS \SGN DMACRO ((VAL) (if (IGREATERP VAL 0) then 1 elseif (ILESSP VAL 0) then -1 else 0))) ) ) (DEFINEQ (\IRND [LAMBDA (N D) (* ; "Edited 24-Aug-87 22:14 by FS") (* ;; "integer round operation") (if (MINUSP D) then (SETQ N (IMINUS N)) (SETQ D (IMINUS D))) (IQUOTIENT (if (MINUSP N) then (IDIFFERENCE N (LRSH D 1)) else (IPLUS N (LRSH D 1))) D]) ) (* ;;; "XYpt object and methods") (DECLARE%: EVAL@COMPILE (RECORD XYPT (X . Y)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS XYPT.X DMACRO ((PT) (CAR PT))) (PUTPROPS XYPT.Y DMACRO ((PT) (CDR PT))) ) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE (PUTPROPS HEADPT DMACRO ((PATH) (CAR PATH))) (PUTPROPS NEXTPT DMACRO ((PATH) (CADR PATH))) (PUTPROPS HEADPTY DMACRO ((PATH) (CDAR PATH))) (PUTPROPS NEXTPTY DMACRO ((PATH) (CDADR PATH))) ) ) (DEFINEQ (MAKEXYPT [LAMBDA (IX IY) (* FS "10-Feb-86 12:11") (* * Create and return an XYPT object) (create XYPT X _ IX Y _ IY]) (IRNDLIST [LAMBDA (PATH) (* FS "10-Feb-86 12:14") (* * Return integer version of list (should round) * *) (LET (X Y) (for I in PATH collect (SETQ X (XYPT.X I)) (SETQ Y (XYPT.Y I)) [if (NOT (FIXP X)) then (SETQ X (FIX (PLUS X 0.5] [if (NOT (FIXP Y)) then (SETQ Y (FIX (PLUS Y 0.5] (CONS X Y]) (NORMLOOP [LAMBDA (LIST) (* FS "10-Feb-86 16:56") (* * make a true loop out of list, then snip at a local maxima or minima.  This is defined as normal form, where a loop begins at a local max/min) (PROG (LOOP HEAD LAST Y1 Y2 PREVSGN ANTISGN) (SETQ LOOP (COPY LIST)) (SETQ LAST (LAST LOOP)) (RPLACD LAST LOOP) (* * run until nonhorizontal section, loop points to lead cons cell) (SETQ Y1 (HEADPTY LOOP)) (SETQ Y2 (NEXTPTY LOOP)) (while (AND (NEQ LOOP LAST) (EQ Y1 Y2)) do (SETQ LOOP (CDR LOOP)) (SETQ Y1 Y2) (SETQ Y2 (NEXTPTY LOOP))) (SETQ PREVSGN (\SGN (IDIFFERENCE Y2 Y1))) (* * handle degenerate flat outlines) (if (EQ PREVSGN 0) then (SETQ HEAD (CDR LOOP)) (RPLACD LOOP NIL) (RETURN HEAD)) (* * run until strictly opposite section) (SETQ Y1 Y2) (SETQ Y2 (CDADDR LOOP)) (SETQ ANTISGN (\SGN (IDIFFERENCE Y1 Y2))) [while (NEQ ANTISGN PREVSGN) do (SETQ LOOP (CDR LOOP)) (SETQ Y1 Y2) (SETQ Y2 (CDADDR LOOP)) (SETQ ANTISGN (\SGN (IDIFFERENCE Y1 Y2] (SETQ HEAD (CDR LOOP)) (RPLACD LOOP NIL) (RETURN HEAD]) (SLITLOOP [LAMBDA (KLST) (* FS "10-Feb-86 16:57") (* * Makes a copy of a normalized knot list representing a loop, and slits it  into monotonic sections on y) (PROG (SECTLIST CURRLIST CURRSGN PREVSGN PREV CURR LAST) (* * add first pt to tail to represent all edges) (SETQ KLST (COPY KLST)) (SETQ LAST (COPY (HEADPT KLST))) (SETQ KLST (NCONC KLST (LIST LAST))) (* * slice into monotonic knot lists) (SETQ PREV (HEADPT KLST)) (SETQ KLST (CDR KLST)) (SETQ CURR (HEADPT KLST)) [SETQ PREVSGN (\SGN (IDIFFERENCE (XYPT.Y CURR) (XYPT.Y PREV] (SETQ CURRLIST (LIST PREV)) (SETQ SECTLIST (LIST CURRLIST)) (for CURR in KLST do [SETQ CURRSGN (\SGN (IDIFFERENCE (XYPT.Y CURR) (XYPT.Y PREV] (if (EQ CURRSGN 0) then (SETQ CURRSGN PREVSGN)) (if (EQ CURRSGN PREVSGN) then (ATTACH CURR CURRLIST) else (SETQ CURRLIST (LIST CURR (COPY PREV))) (SETQ SECTLIST (CONS CURRLIST SECTLIST)) (SETQ PREVSGN CURRSGN)) (SETQ PREV CURR)) (* * currently, each monotonic section is reversed, no effect on algorithms?) (RETURN (REVERSE SECTLIST]) (PREPLOOP [LAMBDA (PathOrPathList) (* FS "29-Aug-85 17:47") (* * Normalizes and slits a single path or list of paths, returns list of  monotones ascending or descending * *) (LET (NLIST ILIST LLIST TLIST) (if (NUMBERP (CAAR PathOrPathList)) then (SETQ PathOrPathList (LIST PathOrPathList))) (for I in PathOrPathList do (SETQ NLIST (NORMLOOP (IRNDLIST I))) (SETQ TLIST (SLITLOOP NLIST)) (SETQ ILIST (NCONC TLIST ILIST))) ILIST]) (YMAPLIST [LAMBDA (PATH1 PATH2) (* FS "10-Feb-86 12:30") (* * project y values from path 1 onto path2 resulting in pts which are on path  2, assumes paths are sorted in y ascending) (PROG (YMAP X Y CURRPT NEXTPT X0 Y0 DX DY) (SETQ Y (HEADPTY PATH2)) (while (AND PATH1 (IGEQ Y (HEADPTY PATH1))) do (SETQ PATH1 (CDR PATH1))) [for I in PATH1 do (SETQ Y (XYPT.Y I)) (* * advance path2 until first pt is below current) (while (AND (CDR PATH2) (IGEQ Y (NEXTPTY PATH2))) do (SETQ PATH2 (CDR PATH2))) (if (CDR PATH2) then (SETQ CURRPT (HEADPT PATH2)) (SETQ NEXTPT (NEXTPT PATH2)) (SETQ X0 (XYPT.X CURRPT)) (SETQ Y0 (XYPT.Y CURRPT)) (SETQ DX (IDIFFERENCE (XYPT.X NEXTPT) X0)) (SETQ DY (IDIFFERENCE (XYPT.Y NEXTPT) Y0)) (SETQ X (MIDDX X0 Y0 DX DY Y)) (SETQ YMAP (CONS (CONS X Y) YMAP] (RETURN (REVERSE YMAP]) (IMAPLIST [LAMBDA (PATH1 PATH2) (* FS "10-Feb-86 12:19") (* * project y values from path 1 onto path2 resulting in pts which are on path  2, assumes paths are sorted in y ascending) (PROG (ADVANCE IMAP PT CURR1 NEXT1 CURR2 NEXT2 X0 Y0 DX DY U0 V0 DU DV X1 Y1 U1 V1) (* * should advance both tapes first * *) (SETQ CURR1 (HEADPT PATH1)) (SETQ CURR2 (HEADPT PATH2)) (SETQ NEXT1 (NEXTPT PATH1)) (SETQ NEXT2 (NEXTPT PATH2)) (SETQ Y1 (XYPT.Y NEXT1)) (SETQ V1 (XYPT.Y NEXT2)) (* * force path2 update *) (if (ILEQ V1 Y1) then (SETQ ADVANCE 2) (* will init if fix u1 v1) (SETQ U1 (XYPT.X CURR2)) (SETQ V1 (XYPT.Y CURR2)) (SETQ X0 (XYPT.X CURR1)) (* need to init path1) (SETQ Y0 (XYPT.Y CURR1)) (SETQ X1 (XYPT.X NEXT1)) (SETQ DX (IDIFFERENCE X1 X0)) (SETQ DY (IDIFFERENCE Y1 Y0)) else (SETQ ADVANCE 1) (* will init if fix x1 y1) (SETQ X1 (XYPT.X CURR1)) (SETQ Y1 (XYPT.Y CURR1)) (SETQ U0 (XYPT.X CURR2)) (* need to init path2) (SETQ V0 (XYPT.Y CURR2)) (SETQ U1 (XYPT.X NEXT2)) (SETQ DU (IDIFFERENCE U1 U0)) (SETQ DV (IDIFFERENCE V1 V0))) (* *) (while (AND (CDR PATH1) (CDR PATH2)) do (* * find intersection * *) (if (EQ ADVANCE 1) then (SETQ X0 X1) (SETQ Y0 Y1) (SETQ NEXT1 (NEXTPT PATH1)) (SETQ X1 (XYPT.X NEXT1)) (SETQ Y1 (XYPT.Y NEXT1)) (SETQ DX (IDIFFERENCE X1 X0)) (SETQ DY (IDIFFERENCE Y1 Y0)) else (SETQ U0 U1) (SETQ V0 V1) (SETQ NEXT2 (NEXTPT PATH2)) (SETQ U1 (XYPT.X NEXT2)) (SETQ V1 (XYPT.Y NEXT2)) (SETQ DU (IDIFFERENCE U1 U0)) (SETQ DV (IDIFFERENCE V1 V0))) (* * find intersection * *) (SETQ PT (XYSECTLSEG X0 Y0 DX DY U0 V0 DU DV)) (if (NEQ PT NIL) then (SETQ IMAP (CONS PT IMAP))) (* * advance appropriate path) (if (ILEQ V1 Y1) then (SETQ PATH2 (CDR PATH2)) (SETQ ADVANCE 2) else (SETQ PATH1 (CDR PATH1)) (SETQ ADVANCE 1))) (RETURN (REVERSE IMAP]) (UNIQLIST [LAMBDA (LIST) (* FS "10-Feb-86 12:33") (* * removes duplicate items from a listy dups defined if same scan line) (LET (Y V NEWLIST) (SETQ Y (HEADPTY LIST)) (SETQ NEWLIST (CONS (HEADPT LIST) NIL)) [for PT in (CDR LIST) do (SETQ V (XYPT.Y PT)) (if (NEQ Y V) then (SETQ Y V) (SETQ NEWLIST (CONS PT NEWLIST] (REVERSE NEWLIST]) (MERGLIST [LAMBDA (PATH1 PATH2) (* FS "10-Feb-86 12:48") (* * Merge two nondescending knot lists, NOTE%: cannot use XYPT.LESSP since we  don't want to lose order of x values, also note we are projecting path1 onto  path2, so merge is not commutative, order of pts in path2 is preserved, order  in path1 is not * *) (PROG (IMAP CURR1 CURR2 Y1 Y2) (* * should advance both tapes first * *) (if (EQ PATH1 NIL) then (RETURN PATH2)) (if (EQ PATH2 NIL) then (RETURN PATH1)) (* *) (SETQ CURR1 (HEADPT PATH1)) (SETQ CURR2 (HEADPT PATH2)) (SETQ Y1 (XYPT.Y CURR1)) (SETQ Y2 (XYPT.Y CURR2)) [while (OR PATH1 PATH2) do (if (ILEQ Y2 Y1) then (SETQ IMAP (CONS CURR2 IMAP)) (* insert pt2) (* * if eq, place all such path1 pts) (while (EQ Y1 Y2) do (SETQ IMAP (CONS CURR1 IMAP)) (SETQ PATH1 (CDR PATH1)) (if PATH1 then (SETQ CURR1 (HEADPT PATH1)) (SETQ Y1 (XYPT.Y CURR1)) else (SETQ Y1 MAX.INTEGER))) (* * update path2) (SETQ PATH2 (CDR PATH2)) (if PATH2 then (SETQ CURR2 (HEADPT PATH2)) (SETQ Y2 (XYPT.Y CURR2)) else (SETQ Y2 MAX.INTEGER)) else (SETQ IMAP (CONS CURR1 IMAP)) (SETQ PATH1 (CDR PATH1)) (if PATH1 then (SETQ CURR1 (HEADPT PATH1)) (SETQ Y1 (XYPT.Y CURR1)) else (SETQ Y1 MAX.INTEGER] (* *) (RETURN (REVERSE IMAP]) (MMLTLIST [LAMBDA (KLIST M11 M12 M13 M21 M22 M23) (* FS "10-Feb-86 12:51") (* * matrix multiply vector of points) (LET (NLIST X Y U V) (SETQ NLIST (for PT in KLIST collect (SETQ X (XYPT.X PT)) (SETQ Y (XYPT.Y PT)) (SETQ U (PLUS (TIMES X M11) (TIMES Y M12) M13)) (SETQ V (PLUS (TIMES X M21) (TIMES Y M22) M23)) (CONS U V]) (IMLTLIST [LAMBDA (KLIST M11 M12 M13 M21 M22 M23) (* FS "10-Feb-86 12:53") (* * matrix multiply vector of points, make integers) (LET (NLIST X Y U V) (SETQ NLIST (for PT in KLIST collect (SETQ X (CAR PT)) (SETQ Y (CDR PT)) (SETQ U (PLUS (TIMES X M11) (TIMES Y M12) M13)) (SETQ V (PLUS (TIMES X M21) (TIMES Y M22) M23)) (CONS (FIX U) (FIX V]) (XYPT.LESSP [LAMBDA (PT1 PT2) (* FS "10-Feb-86 12:57") (* * comment) (LET (V1 V2) (SETQ V1 (XYPT.Y PT1)) (SETQ V2 (XYPT.Y PT2)) (if (NEQ V1 V2) then (ILEQ V1 V2) else (ILEQ (XYPT.X PT1) (XYPT.X PT2]) (PATH.LESSP [LAMBDA (PATH1 PATH2) (* FS "10-Feb-86 12:21") (* * y coordinate dominates, otherwise mean x value of edge) (LET (PT1 PT2 Y1 Y2 X1 X2 U1 U2) (if (EQ NIL PATH1) then T elseif (EQ NIL PATH2) then NIL else (SETQ PT1 (CAR PATH1)) (SETQ PT2 (CAR PATH2)) (SETQ Y1 (XYPT.Y PT1)) (SETQ Y2 (XYPT.Y PT2)) (if (NEQ Y1 Y2) then (ILEQ Y1 Y2) else (SETQ X1 (XYPT.X PT1)) (SETQ X2 (XYPT.X PT2)) (if (EQ X1 X2) then (PATH.LESSP (CDR PATH1) (CDR PATH2)) elseif (AND (CDR PATH1) (CDR PATH2)) then (SETQ PT1 (CADR PATH1)) (SETQ PT2 (CADR PATH2)) (SETQ U1 (XYPT.X PT1)) (SETQ U2 (XYPT.X PT2)) (ILEQ (IPLUS X1 U1) (IPLUS X2 U2)) else (ILEQ X1 X2]) (CONVEXP [LAMBDA (PATH) (* FS "10-Feb-86 16:58") (* * tests whether polygon represented by knot list is convex, by checking  whether next vertex is on left/right of origin current and tangental vectors) (PROG (RESULT NEGSGN TSGN CSGN OSGN PT X Y LASTX LASTY ORIGX0 ORIGY0 ORIGDX ORIGDY CURRX0 CURRY0 CURRDX CURRDY TANGX0 TANGY0 TANGDX TANGDY) (* * degenerates assumed convex * *) (if (ILEQ (LENGTH PATH) 3) then (RETURN T)) (SETQ PT (CAR PATH)) (SETQ ORIGX0 (XYPT.X PT)) (SETQ ORIGY0 (XYPT.Y PT)) (SETQ PT (CADR PATH)) (SETQ TANGX0 (XYPT.X PT)) (SETQ TANGY0 (XYPT.Y PT)) (SETQ ORIGDX (IDIFFERENCE TANGX0 ORIGX0)) (SETQ ORIGDY (IDIFFERENCE TANGY0 ORIGY0)) (SETQ PT (CADDR PATH)) (SETQ LASTX (XYPT.X PT)) (SETQ LASTY (XYPT.Y PT)) (SETQ TANGDX (IDIFFERENCE LASTX TANGX0)) (SETQ TANGDY (IDIFFERENCE LASTY TANGY0)) (SETQ CURRX0 ORIGX0) (SETQ CURRY0 ORIGY0) (SETQ CURRDX (IDIFFERENCE LASTX ORIGX0)) (SETQ CURRDY (IDIFFERENCE LASTY ORIGY0)) (SETQ NEGSGN (IMINUS (XPROD ORIGX0 ORIGY0 ORIGDX ORIGDY LASTX LASTY))) (SETQ NEGSGN (\SGN NEGSGN)) (* hope first three pts not collinear, else this wont work) (SETQ PATH (CDDDR PATH)) (SETQ RESULT T) (* 4th pt and beyond *) (while PATH do (SETQ PT (CAR PATH)) (SETQ X (XYPT.X PT)) (SETQ Y (XYPT.Y PT)) (SETQ TSGN (XPROD TANGX0 TANGY0 TANGDX TANGDY X Y)) (SETQ CSGN (XPROD CURRX0 CURRY0 CURRDX CURRDY X Y)) (SETQ OSGN (XPROD ORIGX0 ORIGY0 ORIGDX ORIGDY X Y)) (SETQ TSGN (\SGN TSGN)) (SETQ CSGN (\SGN CSGN)) (SETQ OSGN (\SGN OSGN)) (if (OR (EQ TSGN NEGSGN) (EQ CSGN NEGSGN) (EQ OSGN NEGSGN)) then (SETQ RESULT NIL) (RETURN) (* Exit loop not function *)) (SETQ PATH (CDR PATH)) (SETQ TANGX0 LASTX) (SETQ TANGY0 LASTY) (SETQ TANGDX (IDIFFERENCE X LASTX)) (SETQ TANGDY (IDIFFERENCE Y LASTY)) (SETQ CURRDX (IDIFFERENCE X CURRX0)) (SETQ CURRDY (IDIFFERENCE Y CURRY0)) (SETQ LASTX X) (SETQ LASTY Y)) (RETURN RESULT]) ) (* ;;; "Line object and methods") (DECLARE%: EVAL@COMPILE (RECORD LINE (ORIG DIFF WIND)) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS GETLINEDIFF DMACRO ((SELF DX DY) (* ;; "External method, get dx, dy from line") (WITH LINE SELF (SETQ DX (ffetch (XYPT X) of DIFF)) (SETQ DY (ffetch (XYPT Y) OF DIFF] [PUTPROPS GETLINEORIG DMACRO ((SELF OX OY) (* ;; "External method, get dx, dy from line") (WITH LINE SELF (SETQ OX (ffetch (XYPT X) of ORIG)) (SETQ OY (ffetch (XYPT Y) OF ORIG] [PUTPROPS \GETLINEDIFF DMACRO ((SELF DX DY) (* edited " 1-Jan-00 00:00") (* ;; "Degenerate private method, get dx, dy from line") (WITH LINE SELF (SETQ DX (FFETCH (XYPT X) OF DIFF)) (SETQ DY (FFETCH (XYPT T) OF DIFF] [PUTPROPS \GETLINEORIGY DMACRO ((SELF YPTR) (SETQ YPTR (FFETCH (XYPT Y) of (FFETCH (LINE ORIG) of SELF] [PUTPROPS \GETLINEDIFFY DMACRO ((SELF YPTR) (SETQ YPTR (FFETCH (XYPT Y) of (FFETCH (LINE DIFF) of SELF] ) ) (DEFINEQ (MAKELINE [LAMBDA (X0 Y0 DX DY) (* FS "29-Aug-85 17:48") (* * To simplify bresenham arithmetic, switch all lines to have positive dy.  True direction is held in WIND.) (LET (DIR) (if (ILESSP DY 0) then (SETQ X0 (IPLUS X0 DX)) (SETQ Y0 (IPLUS Y0 DY)) (SETQ DX (IMINUS DX)) (SETQ DY (IMINUS DY)) (SETQ DIR -1) else (SETQ DIR 1)) (create LINE ORIG _ (MAKEXYPT X0 Y0) DIFF _ (MAKEXYPT DX DY) WIND _ DIR]) (MSECT [LAMBDA (X0 Y0 DX DUDY U0 V0 DU DXDV) (* FS "15-Aug-85 23:38") (* * Major axis intersection of line by edge, assuming x is shallow) (* * "(DUDY*X0 - DXDV*U0 + DX*DU*(V0-Y0)) / (DUDY - DXDV)" * *) (IQUOTIENT (IPLUS (ITIMES DUDY X0) (IMINUS (ITIMES DXDV U0)) (ITIMES DX DU (IDIFFERENCE V0 Y0))) (IDIFFERENCE DUDY DXDV]) (XSECT [LAMBDA (X0 Y0 DX DY U0 V0 DU DV) (* FS "15-Aug-85 23:51") (* * X intersection of two bresenham line and edge, on line) (LET (X Y DUDY DXDV) (SETQ DUDY (ITIMES DU DY)) (SETQ DXDV (ITIMES DX DV)) (if (IGEQ (IABS DX) (IABS DY)) then (SETQ X (MSECT X0 Y0 DX DUDY U0 V0 DU DXDV)) else (SETQ Y (MSECT Y0 X0 DY DXDV V0 U0 DV DUDY)) (SETQ X (LINEY Y0 X0 DY DX Y))) X]) (YSECT [LAMBDA (X0 Y0 DX DY U0 V0 DU DV) (* FS "15-Aug-85 23:50") (* * Y intersection of two bresenham line and edge, on line) (LET (X Y DUDY DXDV) (SETQ DUDY (ITIMES DU DY)) (SETQ DXDV (ITIMES DX DV)) (if (IGEQ (IABS DX) (IABS DY)) then (SETQ X (MSECT X0 Y0 DX DUDY U0 V0 DU DXDV)) (SETQ Y (LINEY X0 Y0 DX DY X)) else (SETQ Y (MSECT Y0 X0 DY DXDV V0 U0 DV DUDY))) Y]) (XYSECT [LAMBDA (X0 Y0 DX DY U0 V0 DU DV) (* FS "16-Aug-85 00:42") (* * Intersection of two bresenham line and edge, on line) (LET (X Y DUDY DXDV) (SETQ DUDY (ITIMES DU DY)) (SETQ DXDV (ITIMES DX DV)) (if (NEQ DUDY DXDV) then (if (IGEQ (IABS DX) (IABS DY)) then (SETQ X (MSECT X0 Y0 DX DUDY U0 V0 DU DXDV)) (SETQ Y (LINEY X0 Y0 DX DY X)) else (SETQ Y (MSECT Y0 X0 DY DXDV V0 U0 DV DUDY)) (SETQ X (LINEY Y0 X0 DY DX Y))) (CONS X Y) else NIL]) (KNOTLINE [LAMBDA (KNOTS) (* FS "10-Feb-86 14:06") (* * turns a single knot list, which represents an open path, into a list of  line objects, assume integer values) (PROG (I ALIST ALINE CURRX CURRY PREVX PREVY) (SETQ I (CAR KNOTS)) (SETQ PREVX (XYPT.X I)) (SETQ PREVY (XYPT.Y I)) (SETQ KNOTS (CDR KNOTS)) (for I in KNOTS do (SETQ CURRX (XYPT.X I)) (SETQ CURRY (XYPT.Y I)) (SETQ ALINE (MAKELINE PREVX PREVY (DIFFERENCE CURRX PREVX) (DIFFERENCE CURRY PREVY))) (SETQ ALIST (CONS ALINE ALIST)) (SETQ PREVX CURRX) (SETQ PREVY CURRY)) (RETURN (REVERSE ALIST]) (KNOTLOOP [LAMBDA (KNOTS) (* FS "10-Feb-86 14:06") (* * turns a single knot list, which represents a closed path, into a list of  line objects) (PROG (I ALIST ALINE CURRX CURRY PREVX PREVY) (SETQ I (CAR (LAST KNOTS))) (SETQ PREVX (XYPT.X I)) (SETQ PREVY (XYPT.Y I)) (for I in KNOTS do (SETQ CURRX (XYPT.X I)) (SETQ CURRY (XYPT.Y I)) (SETQ ALINE (MAKELINE PREVX PREVY (IDIFFERENCE CURRX PREVX) (IDIFFERENCE CURRY PREVY))) (SETQ ALIST (CONS ALINE ALIST)) (SETQ PREVX CURRX) (SETQ PREVY CURRY)) (RETURN (REVERSE ALIST]) (LINE.LESSP [LAMBDA (ARG1 ARG2) (* FS " 6-Aug-85 17:58") (* * comment) (LET (Y1 Y2 DY1 DY2) (\GETLINEORIGY ARG1 Y1) (\GETLINEORIGY ARG2 Y2) (if (NEQ Y1 Y2) then (ILEQ Y1 Y2) else (\GETLINEDIFFY ARG1 DY1) (\GETLINEDIFFY ARG2 DY2) (ILEQ DY1 DY2]) ) (DEFINEQ (LINEY [LAMBDA (X0 Y0 DX DY X) (* FS "10-Feb-86 17:35") (* * returns y on shallow line given x.) (* * "Y0 + Round ( DY*(X-X0) / DY )" * *) (if (OR (EQ DX 0) (EQ DY 0)) then (IPLUS Y0 (IQUOTIENT DY 2)) else (SETQ X (IDIFFERENCE X X0)) (IPLUS Y0 (\IRND (ITIMES X DY) DX]) (MIDDX [LAMBDA (X0 Y0 DX DY Y) (* FS "10-Feb-86 17:35") (* * returns middle x on shallow line given y.) (if (OR (EQ DX 0) (EQ DY 0)) then (IPLUS X0 (IQUOTIENT DX 2)) else (SETQ Y (IDIFFERENCE Y Y0)) (if (NEQ (\SGN Y) (\SGN DY)) then X0 else (IPLUS X0 (\IRND (ITIMES Y DX) DY]) (INITX [LAMBDA (X0 Y0 DX DY Y) (* FS "10-Feb-86 16:59") (* * returns minimum x on shallow line.) (PROG (X) (if (OR (EQ DX 0) (EQ DY 0)) then (RETURN X0)) (SETQ Y (IDIFFERENCE Y Y0)) (if (NEQ (\SGN Y) (\SGN DY)) then (RETURN X0)) (* * "X0 + 1 + (2*Y*DX - DX) / 2*DY" * *) [SETQ X (IPLUS X0 1 (IQUOTIENT (IDIFFERENCE (ITIMES 2 Y DX) DX) (ITIMES 2 DY] (RETURN X]) (TERMX [LAMBDA (X0 Y0 DX DY Y) (* FS "10-Feb-86 17:00") (* * returns maximum x on shallow line.) (PROG (X D) (if (OR (EQ DX 0) (EQ DY 0)) then (RETURN (IPLUS X0 DX))) (SETQ Y (IDIFFERENCE Y Y0)) (if (NEQ (\SGN Y) (\SGN DY)) then (RETURN X0)) (* * "X0 + (2*Y*DX + DX) / 2*DY" *) [SETQ X (IPLUS X0 (IQUOTIENT (IPLUS DX (ITIMES 2 Y DX)) (ITIMES 2 DY] (RETURN X]) (SCANX [LAMBDA (X0 Y0 DX DY Y) (* FS "10-Feb-86 17:00") (* * returns scan x values on shallow line.) (PROG (YDX2 DY2 XL XR) [if (OR (EQ DX 0) (EQ DY 0)) then (RETURN (CONS X0 (IPLUS X0 DX] (SETQ Y (IDIFFERENCE Y Y0)) [if (NEQ (\SGN Y) (\SGN DY)) then (RETURN (CONS X0 (IPLUS X0 DX] (SETQ YDX2 (ITIMES 2 Y DX)) (SETQ DY2 (ITIMES 2 DY)) (SETQ XL (IPLUS X0 1 (IQUOTIENT (IDIFFERENCE YDX2 DX) DY2))) (SETQ XR (IPLUS X0 (IQUOTIENT (IPLUS YDX2 DX) DY2))) (RETURN (CONS XL XR]) (XPROD [LAMBDA (X0 Y0 DX DY X Y) (* edited%: " 9-Aug-85 21:27") (* * returns cross product of a vector and the vector from vector origin to a  point. If the sgn of the x-product is positive, the point lies on the relative  left of the (vector, assuming right handed system) * *) (SETQ X (IDIFFERENCE X X0)) (SETQ Y (IDIFFERENCE Y Y0)) (IDIFFERENCE (ITIMES DX Y) (ITIMES DY X]) ) (* ;;; "line segment methods") (DEFINEQ (XYSECTLSEG [LAMBDA (X0 Y0 DX DY U0 V0 DU DV) (* FS "10-Feb-86 14:10") (* * Intersection analogue of lines, but for lsegs, assume dy positive * *) (* * if line segments intersect, return y else y0) (PROG (PT Y XT YT UT VT XMAX XMIN UMAX UMIN) (SETQ XT (IPLUS X0 DX)) (SETQ YT (IPLUS Y0 DY)) (SETQ UT (IPLUS U0 DU)) (SETQ VT (IPLUS V0 DV)) (* * Check X extents first * *) (if (MINUSP DX) then (SETQ XMIN XT) (SETQ XMAX X0) else (SETQ XMIN X0) (SETQ XMAX XT)) (if (MINUSP DU) then (SETQ UMIN UT) (SETQ UMAX U0) else (SETQ UMIN U0) (SETQ UMAX UT)) (if (OR (ILEQ XMAX UMIN) (ILEQ UMAX XMIN)) then (RETURN NIL)) (* * find y intersection) (SETQ PT (XYSECT X0 Y0 DX DY U0 V0 DU DV)) (if (EQ PT NIL) then (RETURN NIL)) (* * Make sure point lies in both line y extents) (SETQ Y (XYPT.Y PT)) (if (OR (ILEQ Y Y0) (ILEQ YT Y) (ILEQ Y V0) (ILEQ VT Y)) then (RETURN NIL)) (RETURN PT]) ) (* ;;; "Bresenham line object and methods") (DECLARE%: EVAL@COMPILE (DATATYPE BRES (MAJOR X Y P IX IY IPX IPY)) ) (/DECLAREDATATYPE 'BRES '(POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER) '((BRES 0 POINTER) (BRES 2 POINTER) (BRES 4 POINTER) (BRES 6 POINTER) (BRES 8 POINTER) (BRES 10 POINTER) (BRES 12 POINTER) (BRES 14 POINTER)) '16) (DEFINEQ (MAKEBRES [LAMBDA (X0 Y0 DX DY) (* ; "Edited 24-Aug-87 22:29 by FS") (* ;; "Assume canonical form, dy is positive") (LET (SELF PX PY PXY) (SETQ SELF (create BRES)) [with BRES SELF (*) (SETQ X X0) (SETQ Y Y0) (SETQ IX (\SGN DX)) (SETQ IY (\SGN DY)) (SETQ PX (IABS DX)) (SETQ PY (IABS DY)) (SETQ PXY (IDIFFERENCE PX PY)) (if (EQ PY 0) then (SETQ MAJOR 'NIL) (SETQ X (IPLUS X0 DX)) (SETQ IPX 1) (SETQ IPY 1) (SETQ P -1) elseif (IGEQ PX PY) then (SETQ MAJOR 'X) (SETQ IPX (IMAX 1 (ITIMES 2 PY))) (SETQ P (IDIFFERENCE IPX PX)) (SETQ IPY (ITIMES 2 (IDIFFERENCE PY PX))) else (SETQ MAJOR 'Y) (SETQ IPY (ITIMES 2 PX)) (SETQ P (IDIFFERENCE IPY PY)) (SETQ IPX (ITIMES 2 (IDIFFERENCE PX PY] (* * (replace (BRES X) of SELF with X0) (replace  (BRES Y) of SELF with Y0) (replace (BRES IX) of SELF with  (\SGN DX)) (replace (BRES IY) of SELF with  (\SGN DY)) (SETQ PX (IABS DX)) (SETQ PY (IABS DY))  (SETQ PXY (IDIFFERENCE PX PY)) (if (EQ PY 0) then  (replace (BRES MAJOR) of SELF with (QUOTE NIL))  (replace (BRES X) of SELF with (IPLUS X0 DX))  (replace (BRES IPX) of SELF with 1) (replace  (BRES IPY) of SELF with 1) (replace (BRES P) of SELF with -1) elseif  (IGEQ PX PY) then (replace (BRES MAJOR) of SELF with  (QUOTE X)) (replace (BRES IPX) of SELF with  (IMAX 1 (ITIMES 2 PY))) (replace (BRES P) of SELF with  (IDIFFERENCE (fetch (BRES IPX) of SELF) PX))  (replace (BRES IPY) of SELF with (ITIMES 2  (IDIFFERENCE PY PX))) else (replace (BRES MAJOR) of SELF with  (QUOTE Y)) (replace (BRES IPY) of SELF with  (ITIMES 2 PX)) (replace (BRES P) of SELF with  (IDIFFERENCE (fetch (BRES IPY) of SELF) PY))  (replace (BRES IPX) of SELF with (ITIMES 2  (IDIFFERENCE PX PY))))) SELF]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTPROPS BRESSTEP DMACRO ((SELF SCANY INITX TERMX) (* * Assume that this Y is exactly incremented by one from the last call, so  DDA can be used. Then passed parameter scany is not used.) (* * (WITH BRES SELF (*) (SETQ INITX X)  (IF (EQ MAJOR (QUOTE X)) THEN (while (ILESSP P 0) do  (SETQ X (IPLUS X IX)) (SETQ P (IPLUS P IPX)))  (IF (ILEQ INITX X) THEN (SETQ TERMX X) ELSE  (SETQ TERMX INITX) (SETQ INITX X)) (SETQ X  (IPLUS X IX)) (SETQ P (IPLUS P IPY)) ELSE  (SETQ TERMX X) (if (ILESSP P 0) then (SETQ P  (IPLUS P IPY)) else (SETQ P (IPLUS P IPX))  (SETQ X (IPLUS X IX)))))) (LET (X0 DX D DDX DDY) (* * (WITH BRES SELF (*) (SETQ X0 X) (SETQ DX IX)  (SETQ D P) (SETQ DDX IPX) (SETQ DDY IPY))) (SETQ D (FFETCH (BRES P) OF SELF)) (SETQ X0 (FFETCH (BRES X) OF SELF)) (SETQ DX (FFETCH (BRES IX) OF SELF)) (SETQ DDX (FFETCH (BRES IPX) OF SELF)) (SETQ DDY (FFETCH (BRES IPY) OF SELF)) (* * Above faster than WITH form * *) (SETQ INITX X0) [IF (EQ (FFETCH (BRES MAJOR) OF SELF) 'X) THEN (while (ILESSP D 0) do (SETQ X0 (IPLUS X0 DX)) (SETQ D (IPLUS D DDX))) (IF (ILEQ INITX X0) THEN (SETQ TERMX X0) ELSE (SETQ TERMX INITX) (SETQ INITX X0)) (SETQ X0 (IPLUS X0 DX)) (SETQ D (IPLUS D DDY)) ELSE (SETQ TERMX X0) (if (ILESSP D 0) then (SETQ D (IPLUS D DDY)) else (SETQ D (IPLUS D DDX)) (SETQ X0 (IPLUS X0 DX] (* * (WITH BRES SELF (*) (SETQ X X0) (SETQ P D))) (FREPLACE (BRES X) OF SELF with X0) (FREPLACE (BRES P) OF SELF with D] ) ) (* ;;; "Debugging control panel") (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ \GEOM.PANEL ((* * Debugging control panel * *) (PROG NIL (SETQQ KLIST ((10 . 10) (20 . 20) (30 . 20) (40 . 30) (50 . 10) (30 . 0))) (SETQ NLIST (NORMLOOP KLIST)) (SETQ SLIST (SLITLOOP NLIST)) (MYPGON MYWIN KLIST) (MYNUMB MYWIN KLIST)))) ) (* ;;; "Trapezoidal decomposition") (DEFINEQ (TRAPLOOP [LAMBDA (PATH) (* FS "10-Feb-86 14:12") (* * decomposes single path or pathlist into trapezoids, odd winding rule) (PROG (KNOTS PLIST CLIST LEN IPATH JPATH KPATH XPATH TEMP PT.LESSP) (SETQ PT.LESSP 'XYPT.LESSP) (* * Handle path or list) (SETQ PLIST (PREPLOOP PATH)) (SETQ PATH (COPYALL PATH)) [if (NUMBERP (CAAR PATH)) then (SETQ KNOTS PATH) else (for LOOP in PATH do (SETQ KNOTS (NCONC KNOTS LOOP] (* * Force monotonic lists to ascend) (SETQ PLIST (for I in PLIST collect (if [IGREATERP (HEADPTY I) (XYPT.Y (CAR (LAST I] then (REVERSE I) else I))) (if TRAP.DEBUG then (DV PLIST)) (SETQ LEN (LENGTH PLIST)) (* * find all intersections, seed into critical lists * *) (* * (SETQ CLIST NIL) (FOR I IN CLIST DO  (SETQ CLIST (CONS NIL CLIST)))) (SETQ CLIST (COPYALL PLIST)) [for I from 1 to (SUB1 LEN) do (SETQ IPATH (CAR (NTH PLIST I))) (for J from (ADD1 I) to LEN do (SETQ JPATH (CAR (NTH PLIST J))) (SETQ XPATH (IMAPLIST IPATH JPATH)) (SETQ CLIST (for K from 1 to LEN collect (SETQ KPATH (CAR (NTH CLIST K))) (if (OR (EQ K I) (EQ K J)) then (MERGLIST (COPY XPATH) KPATH) else (SETQ TEMP (YMAPLIST XPATH KPATH)) (MERGLIST TEMP KPATH] (if TRAP.DEBUG then (DV CLIST)) (* * cull out duplicates and combine with joints * *) (SORT KNOTS PT.LESSP) (SETQ TEMP (for I in PLIST collect (YMAPLIST KNOTS I))) [SETQ CLIST (for I from 1 to LEN collect (MERGLIST (CAR (NTH TEMP I)) (CAR (NTH CLIST I] (* * pull out trapezoids from critical pt list * *) (RETURN (TRAPMAKE CLIST]) (TRAPMAKE [LAMBDA (EDGELIST) (* FS "10-Feb-86 14:13") (* * Given decomposed edges, traverse making trapezoids) (PROG (TRAPLIST UNFINISHED PTR LIST1 LIST2 PT1 PT2 PT3 PT4 TRAP CURRY ALIST) (* * theoretically, each pair of paths must represent a trapezoid for ith and  i+1th pts * *) (SETQ UNFINISHED T) (while UNFINISHED do (SORT EDGELIST 'PATH.LESSP) (SETQ CURRY (CDAAR EDGELIST)) (SETQ PTR EDGELIST) (SETQ ALIST NIL) (while (EQ CURRY (CDAAR PTR)) do (SETQ LIST1 (CAR PTR)) (SETQ LIST2 (CADR PTR)) (SETQ PT1 (HEADPT LIST1)) (SETQ PT2 (NEXTPT LIST1)) (SETQ PT4 (HEADPT LIST2)) (SETQ PT3 (NEXTPT LIST2)) (* * check for duplicate y vals) (while (AND (EQ (XYPT.Y PT1) (XYPT.Y PT2)) (CDR LIST1)) do (SETQ PT1 PT2) (SETQ LIST1 (CDR LIST1)) (SETQ PT2 (NEXTPT LIST1))) (* * check for duplicate y vals) (while (AND (EQ (XYPT.Y PT4) (XYPT.Y PT3)) (CDR LIST2)) do (SETQ PT4 PT3) (SETQ LIST2 (CDR LIST2)) (SETQ PT3 (NEXTPT LIST2))) (* * make trap, advance) (SETQ TRAP (LIST PT1 PT2 PT3 PT4)) (if [ILESSP (XYPT.Y PT2) (XYPT.Y (CAR (LAST LIST1] then (SETQ ALIST (CONS (CDR LIST1) ALIST))) (if [ILESSP (XYPT.Y PT3) (XYPT.Y (CAR (LAST LIST2] then (SETQ ALIST (CONS (CDR LIST2) ALIST))) (* * this had better be a trapezoid, put a debugging hook here * *) (if (OR (NEQ (CDR PT1) (CDR PT4)) (NEQ (CDR PT2) (CDR PT3))) then (printout T "NON-TRAPEZOID FOUND!" T) (DV TRAP)) (SETQ TRAPLIST (CONS TRAP TRAPLIST)) (SETQ PTR (CDDR PTR))) (SETQ EDGELIST (MERGE ALIST PTR 'PATH.LESSP)) (if (IGREATERP 2 (LENGTH EDGELIST)) then (SETQ UNFINISHED NIL))) (RETURN TRAPLIST]) ) (RPAQQ TRAP.DEBUG NIL) (DECLARE%: EVAL@COMPILE DONTCOPY (RPAQQ \TRAP.PANEL [(WHILE (EQ MYWIN (WHICHW (GETPOSITION))) DO (CLEARW MYWIN2) (CLEARW MYWIN) (NILL (SETQ RLIST (MYRAND MYWIN 7))) (MYPGON MYWIN2 RLIST) (POLYSHADE.DISPLAY MYWIN2 RLIST GRAYSHADE) (NILL (SETQ RZOID (TRAPLOOP RLIST))) (PRINTOUT MYWIN "NUMBER OF TRAPEZOIDS: " (LENGTH RZOID) T) (FOR I IN RZOID DO (POLYSHADE.DISPLAY MYWIN I (RAND))) (MYPGON MYWIN RLIST)) (NILL (NILL (SETQ RLIST (MYRAND MYWIN 5))) (MYPGON MYWIN RLIST) (FOR I IN RZOID DO (MYPGON MYWIN I)) (MYPGON MYWIN (CAR (NTH RZOID 27))) (FOR I FROM 23 TO 25 DO (POLYSHADE.DISPLAY MYWIN (CAR (NTH RZOID I)) GRAYSHADE))) (NILL (WHILE (EQ MYWIN (WHICHW (GETPOSITION))) DO (CLEARW MYWIN) (SETQ RLIST (MYDRAW MYWIN NIL)) (MYPGON MYWIN RLIST) (PRINTOUT MYWIN "CONVEX: " (CONVEXP RLIST) T]) ) (PUTPROPS XXGEOM COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993)) (DECLARE%: DONTCOPY (FILEMAP (NIL (2654 3087 (\IRND 2664 . 3085)) (3735 23347 (MAKEXYPT 3745 . 3976) (IRNDLIST 3978 . 4582 ) (NORMLOOP 4584 . 6212) (SLITLOOP 6214 . 7913) (PREPLOOP 7915 . 8580) (YMAPLIST 8582 . 10143) ( IMAPLIST 10145 . 13704) (UNIQLIST 13706 . 14327) (MERGLIST 14329 . 16976) (MMLTLIST 16978 . 17791) ( IMLTLIST 17793 . 18676) (XYPT.LESSP 18678 . 19047) (PATH.LESSP 19049 . 20375) (CONVEXP 20377 . 23345)) (24936 30188 (MAKELINE 24946 . 25626) (MSECT 25628 . 26097) (XSECT 26099 . 26655) (YSECT 26657 . 27215) (XYSECT 27217 . 27958) (KNOTLINE 27960 . 28884) (KNOTLOOP 28886 . 29762) (LINE.LESSP 29764 . 30186)) (30189 33763 (LINEY 30199 . 30653) (MIDDX 30655 . 31158) (INITX 31160 . 31841) (TERMX 31843 . 32473) (SCANX 32475 . 33259) (XPROD 33261 . 33761)) (33803 35267 (XYSECTLSEG 33813 . 35265)) (35711 38266 (MAKEBRES 35721 . 38264)) (41742 48104 (TRAPLOOP 41752 . 44494) (TRAPMAKE 44496 . 48102))))) STOP \ No newline at end of file diff --git a/sources/new-edit-interface.tedit b/sources/new-edit-interface.tedit new file mode 100644 index 0000000000000000000000000000000000000000..693420f8be0acdee34c0a649f8b8ed9b9cf17369 GIT binary patch literal 4542 zcmaJ_+m0K@5gj`LVg%qr{-C`tB88=t4PZdwi?Fs<@dC0|kQgAZ&6ysu&6#exyJxx7 z*Z4c~nlH*1DCbnqg)|WFLd)SycXidNs#9k)Tknjjebe}(bz9|pGEteQL!+%z?Mcm# z{_{fF%4p?lb=>Ks5_Xu%rlobsgj$zI#hve(N^Oh^CLX+tcGJ*oxK`R#d0UCw$)=76 z@a7e5_;B@NHoJ9V&#7PYkkJ)P+LSry98hD}9hmQ{*KIPMC&4hGPjg2Y$|L|db|M0$l z&fCOdZ%#)as(7t7KJApQYlBmOA#HEWPCr_nRgZZ2fP>a}IG(U7eS2sO{a)5i#e*qr zZTl#vz&(L2b<-F^X|nfSG(q+I`yB+dKjPBx(KgMw4GVvJAiLH$0QLXSROL>)t*Krw zu6Z=T9#JD&G{RHi*mQqx9^oTE)*ByyVDwmbRyR2%Qa7cPjU@>5LtS;Q@_FACPRxmA zvGmDB>XH69B83MT4WgqG4;r&9h1UlTuqr;T?Un`OyOe7Zw{YGu`~ zff$CCkBIMn$b3XXYg7nMWG$*_Vk8r&x!i+;aThwbU#w<;{Jb9p8V}+^awKFD25nrA zzG8RVq2U|v_arnF94fF0Mpq~BB)A~AJn(IGDtBnbInYEYX#$MKWf&tX+Qx!e&PZWu z2Jna}H7W+U{U$+@7dgy0u!OI*OnyMs1C?I5BIddEc6v1T< zRrSl2C^hjV*zGs;C+yAKLtQBHmz0{hmzFuXcU6tie+VL>uerrW7$a> z`1mrLLfkmSaWGrp4ET27Kb?z>Ipn5{FbVJXoVTv_FJ@o96ota?y4V%Ah`4GCUsQ!D z8eHc)CGNDv0e5Us7P?4yTH)!YIN@)?PJ_=HPfC2tceskSbP7wtCGMs*9_eYfSmCbYsxVJtHRf&pLvSg@Io4&ou z!vhPm3A=UhPb!XOfa7NPS%Vi?Q;#N)uGrO|?wHK^&C9=i_ww&IkX?~aPpWJ@E0*I8 zx26IDISk1MI@ryK7rCZ$TKxgTrG7dd<4rxBZpKwolp;tUk(`iEJPDCf;7KFk zm`Pe@|B*OIlBz+zM~_~>M@cBQQga~UXs(rr377!+<2qR=1d%Wl5g6nxlhPLr!R2zO z74cS@nfOQFLZ7vub)I^zb0R9jDG24#AmIQ@LLX#i6q=)1AWzE<4zWYiuFIu3xlirq zAeutvJM4*OBB&9Gi!}D(jv}$QW(Wm~3*kX8<21y;v|@5)5qvF5Qq66%;{Dcxfb)W- z!&D!2-q}4FlbruqmrMNt2|)eG(au61{dg*yl^8~8Qj(ForcrdE!!cLJ)l0l`prNG^ z`mrGD-8^ZELspJh$-{Q=SVSgsOV7_F=pb6mFAg^8KFp)MhVq}FzwlvdEKWp@CNga> zl4H@Q6aYPNSd8AU`4v+N-z2;EcIf0ArotXY9sWlV^rG;~6*OoCF>g zom8d;jSxg^=(r#9E~(1X9m8OdOmYaz`y~y}W}H)*^=TZc*u>eaSFPC{QL`5B+N?Lc znnAIZ~ysj{r2JgTHUDmKW=~c@mAgZbunDN!qxij<4^bRZ{Mj`i$(Eg g*)D(n^k05_g@6Akim!R`&9D8PzpRTteE#?U01I&(D*ylh literal 0 HcmV?d00001 diff --git a/sources/read-print-profile.tedit b/sources/read-print-profile.tedit new file mode 100644 index 0000000000000000000000000000000000000000..cf9162e016930cbc15f50ba3b425f808a63d0647 GIT binary patch literal 3785 zcmbVP+iv4F5cO`00$J33?&Ba2i;WTI1M;>Tq-cO7T_o-WSoDFGD4PvM3M6I6{e%8e zf2P0EGn6RVv69va5J4n0!?~V0zLO#+VRHKHlnLa62$Cvi3#H|FJX=a9N$@{u;TDoi zUCyN=Tad40ri7-Ia7xUz^c0pNP-abVR+EEbWfoC)#k#RLBbtc^X(-r*4A2b`=_O=J ze1aE2$ED3BtGAVOA}DK)sj%_Gs1h=4ZPX|o6n>JKs3FSglBtDIZrjp2TW*;tsKn(q zk9spvg&O8HhC1nkjVq{wjwT#S;b|^mHsZ2Uxy;YT;}4ISJ}=?SlpUQ$d+>~LqxTPT zLm&7caAauGy-rS={pno5=C~hUyM13*6|C^>Sz7XWC9(&B6inKeP9~RysCAeY+6p|a zE0Kpr_s~()#Tl7O5BFK&)~Y{+9U*MeX|w82GvzXNt&we3{b}P~bH?xei9=aDCb78a z&$1YlR^yJ;LK?p*lUTFr<+NN$oetw-`^+rDvOnb2SbcZ7OqEu?sgYHWmeei8VZGG6yTOI!j!4?`0v3naQUUB2W zS!wQT(B>6(G7=pw*22``f(?SbMlPb;;ex_Bv3Z4u9{rl3bBCidZVjQb24>B9pzpU? z3kN{d4g&ypMwBuq#uhnhc3S4JR$=)9g2y3F@8>q(uqUMl zeBFr5Sq!UB7#{#gtz(e>!=e_Xcfq{1B_h6jlv&NQk0ajSN1!}_ey~2tqi;J=QCG^5 z7RYm(uV`orb;G3of3)u+^XkS9R1SL9B_mGP6jY*n$z!-3wCSTQ!)LII8QUZw=YDZb zj=ucTQdva#N2@u?s3a~NdajO@@d1^Ya!{aBhKh_^ZD$^i@0H1h8qSk6nYO?}HZPJ{ z1cmu`!$timt(OX27JnkFgwintFq`i4Vm&VCGnZgS!B;{mkr=i~A9)&1x5BYyTCL1U>!$